      Subroutine epsii(id1,id2,sik,epssq,eps)
C  Calculates the 1/eps^2 and 1/eps term
C  for initial state emitter and initial state spectator
      implicit none

      include 'coupl.inc'
      include 'dipole.inc'
C  Arguments
      integer id1,id2
      real*8 sik,epssq,eps

c  Local
      REAL*8 cf,ca,pi,L,gsq
      PARAMETER (cf=4d0/3d0,ca=3d0)
      PARAMETER (pi=3.1415926d0)
      INTEGER i

      gsq=GG(1)**2
      L=dlog(mu**2/sik)
      epssq=0d0
      eps=0d0

C  quark-quark splitting (i:quark, ij~: quark)
      if(id1.eq.1 .and. id2.eq.1) then
        epssq=gsq/(8d0*pi**2)
        eps=gsq*(3d0 + 2d0*L)/(16.*pi**2)

C  quark-gluon splitting (i:quark, ij~: gluon)
      elseif(id1.eq.1.and.id2.eq.0) then
       return

C  gluon-quark splitting (i:gluon, ij~: quark)
      elseif(id1.eq.0.and.id2.eq.1) then
       return

C  gluon-gluon splitting (i:gluon, ij~: gluon)
      elseif(id1.eq.0.and.id2.eq.0) then
        epssq=gsq/(8d0*pi**2)
        eps=(gsq*((11 + 6*L) - 2*Nf/ca))/(48.*pi**2)

      endif
      end

      Subroutine epsif(id1,id2,sik,mk,epssq,eps)
C  Calculates the 1/eps^2 and 1/eps term
C  for initial state emitter and final state spectator
      implicit none

      include 'coupl.inc'
      include 'dipole.inc'
C  Arguments
      integer id1,id2
      real*8 sik,mk,epssq,eps

c  Local
      REAL*8 cf,ca,pi,L,gsq,musq_k
      PARAMETER (cf=4d0/3d0,ca=3d0)
      PARAMETER (pi=3.1415926d0)
      INTEGER i

      gsq=GG(1)**2
      L=dlog(mu**2/sik)
      musq_k=mk**2/sik
      epssq=0d0
      eps=0d0

C  quark-quark splitting (i:quark, ij~: quark)
      if(id1.eq.1.and.id2.eq.1) then
        epssq=gsq/(8d0*pi**2)
        eps=(gsq*(3+2*L+2*DLog(1+musq_k)))/(16.*pi**2)

C  quark-gluon splitting (i:quark, ij~: gluon)
      elseif(id1.eq.1.and.id2.eq.0) then
       return

C  gluon-quark splitting (i:gluon, ij~: quark)
      elseif(id1.eq.0.and.id2.eq.1) then
       return

C  gluon-gluon splitting (i:gluon, ij~: gluon)
      elseif(id1.eq.0.and.id2.eq.0) then
        epssq=gsq/(8d0*pi**2)
        eps=(gsq*((11+6*L)-2*Nf/ca+6*DLog(1+musq_k)))/(48.*pi**2)

      endif
      end

      Subroutine epsfi(id1,id2,sik,mi,epssq,eps)
C  Calculates the 1/eps^2 and 1/eps term
C  for final state emitter and initia; state spectator
      implicit none

      include 'coupl.inc'
      include 'dipole.inc'
C  Arguments
      integer id1,id2
      real*8 sik,mi,epssq,eps

c  Local
      REAL*8 cf,ca,pi,L,gsq,musq_i
      PARAMETER (cf=4d0/3d0,ca=3d0)
      PARAMETER (pi=3.1415926d0)
      INTEGER i

      gsq=GG(1)**2
      L=dlog(mu**2/sik)
      musq_i=mi**2/sik
      epssq=0d0
      eps=0d0

C  massive quark (ij~:quark)
      if(id1.eq.1.and.mi.gt.0d0) then
         eps=gsq*(1+DLog(musq_i/(1+musq_i)))/(8.*pi**2)

C  massless quark( ij~:quark)
      elseif(id1.eq.1.and.mi.eq.0d0) then
         epssq= gsq/(8d0*pi**2)
         eps=gsq*(3 + 2*L)/(16.*pi**2)

C  gluon splitting (ij~: gluon)
C  1. g-> QQ (i:massive quark )
      elseif(id1.eq.0.and. mi.gt.0d0 ) then
         return
c  2. g-> qq (i:massless quark)
      elseif(id1.eq.0.and.id2.eq.1.and.mi.eq.0d0) then
         eps=-gsq/(24.*pi**2)/ca

C  3. g-> gg (i: gluon )
      elseif(id1.eq.0) then
         epssq=gsq/(4d0*pi**2)
         eps=gsq*(11 + 6*L)/(24.*pi**2)

      endif
      end

      Subroutine epsff(mi,mk,sik,id,id1,epssq,eps)
C  Calculates the 1/eps^2 and 1/eps term
C  for final state emitter and initia; state spectator
      implicit none

      include 'coupl.inc'
      include 'dipole.inc'
c Arguments
      REAL*8 mi,mk,sik,epssq,eps
      INTEGER id,id1
c Global
      REAL*8 ddilog,lambda_tr
      external ddilog,lambda_tr
c  Local
      REAL*8 cf,ca,pi,L,gsq,vik,rho,musq_i,musq_k,Qik,Qik2
      PARAMETER (cf=4d0/3d0,ca=3d0)
      PARAMETER (pi=3.1415926d0)
      INTEGER i

c For the massive case, sik is the Qik^2 from CDST and vice versa.

      musq_i=mi**2/sik
      musq_k=mk**2/sik
      Qik2=sik-mi**2-mk**2
      Qik=Sqrt(Qik2)
      gsq=GG(1)**2
      L=DLog(mu**2/sik)
      vik=Sqrt(lambda_tr(1d0,musq_i,musq_k))/(1d0-musq_i-musq_k)
      rho=Sqrt((1d0-vik)/(1d0+vik))

      epssq=0d0
      eps=0d0

C  ij~ massive and massive spectator
      if(mi.gt.0d0.and.mk.gt.0d0) then
        eps=(gsq*(1d0 + DLog(rho)/vik))/(8.*pi**2)

C  ij~ massive and massless spectator
      elseif(mi.gt.0d0.and.mk.eq.0d0) then
        epssq=gsq/(16d0*pi**2)
        eps=(gsq*(2 + L + DLog(musq_i/(1 - musq_i)**2)))/(16d0*Pi**2)

C  ij~ massless quark and massive spectator
      elseif(id.eq.1.and.mi.eq.0d0.and.mk.gt.0d0) then
        epssq=gsq/(16d0*pi**2)
        eps=(gsq*(3 + L + DLog(musq_k/(1 - musq_k)**2)))/(16d0*pi**2)

C  ij~ massless quark and massless spectator
      elseif(id.eq.1.and.mi.eq.0d0.and.mk.eq.0d0) then
        epssq=gsq/(8d0*pi**2)
        eps=(gsq*(3 + 2*L))/(16.*pi**2)

C  ij~ gluon and massive spectator
      elseif(id.eq.0.and.mk.gt.0d0) then
C  1. g->QQ splitting
         if(id1.eq.1.and.mi.gt.0d0) then
            return

C  2. g->qq aplitting
         elseif(id1.eq.1.and.mi.eq.0d0) then
            eps=-gsq/(24.*pi**2)/ca

C  3. g->gg splitting
         elseif(id1.eq.0) then
            epssq=gsq/(8d0*pi**2)
            eps=(gsq*(11d0/3d0 + L + DLog(musq_k/(1 - musq_k)**2)))
     &           /(8.*Pi**2)
         endif

C  ij~ gluon and massless spectator
      elseif(id.eq.0.and.mk.eq.0d0) then
C  1. g->QQ cplitting
         if(id1.eq.1.and.mi.gt.0d0) then
            return

C  2. g->qq aplitting
         elseif(id.eq.0.and.id1.eq.1.and.mi.eq.0d0) then
            eps=-gsq/(24.*pi**2)/ca

C  3. g->gg splitting
         elseif(id1.eq.0) then
            epssq=gsq/(4d0*pi**2)
            eps=(gsq*(11+6*L))/(24.*pi**2)
         endif
      endif
      end


! MinimalDX version 0.1.4 (https://www.github.com/dmey/minimal-dx).
! Copyright 2018-2020 D. Meyer and R. Raustad. Licensed under MIT.

module PsychroWrapper
  !+ Wraps PsychroLib functions.

use Psychrometrics, only: PsyRhoAirFnPbTdbW, & ! Becomes GetMoistAirDensity
                          GetTWetBulbFromHumRatio => PsyTwbFnTdbWPb,        &
                          GetMoistAirEnthalpy => PsyHFnTdbW,                &
                          PsyWFnTdbH, & ! Becomes GetHumRatioFromEnthalpyAndTDryBulb
                          GetTDryBulbFromEnthalpyAndHumRatio => PsyTdbFnHW, &
                          GetRelHumFromHumRatio => PsyRhFnTdbWPb,           &
                          GetHumRatioFromTDewPoint => PsyWFnTdpPb,          &
                          PsyTsatFnHPb

implicit none

private

public :: InitPsychrometrics
public :: GetMoistAirDensity
public :: GetTWetBulbFromHumRatio
public :: GetMoistAirEnthalpy
public :: GetHumRatioFromEnthalpyAndTDryBulb
public :: GetTDryBulbFromEnthalpyAndHumRatio
public :: GetRelHumFromHumRatio
public :: GetHumRatioFromTDewPoint
public :: PsyTsatFnHPb

contains
  subroutine InitPsychrometrics()
  end subroutine InitPsychrometrics

  function GetMoistAirDensity(InletTDryBulb, InletHumRatio, OutdoorPressure) result(MoistAirDensity)
    real :: InletTDryBulb, InletHumRatio, OutdoorPressure, MoistAirDensity
    MoistAirDensity = PsyRhoAirFnPbTdbW(OutdoorPressure, InletTDryBulb, InletHumRatio)
  end function GetMoistAirDensity

  function GetHumRatioFromEnthalpyAndTDryBulb(hADP, tADP) result(HumRatio)
    real :: hADP, tADP, HumRatio
    HumRatio = PsyWFnTdbH(tADP, hADP)
  end function GetHumRatioFromEnthalpyAndTDryBulb
end module PsychroWrapper


module config_mod

    use globals_mod

    real(dp), parameter :: CFL = 0.8

    real(dp), parameter :: kappa = 1.4

    integer, parameter  :: ncells(  N_DIMS) = 32 * (/1,1/)

    real(dp), parameter :: width            = 0.5
    real(dp), parameter :: domain(2,N_DIMS) = width * reshape((/(/-1.0_dp, 1.0_dp/),(/-1.0_dp, 1.0_dp/)/),(/2,2/))

    real(dp), parameter :: inittime = 0.0
    real(dp), parameter :: stoptime = 2.0
    real(dp), parameter :: dtdump   = 0.1

    real(dp), parameter :: dens0 = 1.0_dp
    real(dp), parameter :: velx0 = 0.5_dp
    real(dp), parameter :: vely0 = 0.5_dp
    real(dp), parameter :: pres0 = 1.0_dp

    real(dp), parameter :: bell_mass = 1.0_dp
    real(dp), parameter :: bell_sigm = 0.1_dp

end module


      SUBROUTINE STIM21( LINE, NSIZES, NN, NTYPES, DOTYPE, NPARMS, NNB,
     $                   NSHFTS, MAXBS, LDAS, TIMMIN, NOUT, ISEED, A, H,
     $                   Z, W, WORK, LWORK, LLWORK, IWORK, TIMES, LDT1,
     $                   LDT2, LDT3, OPCNTS, LDO1, LDO2, LDO3, INFO )
*
*  -- LAPACK timing routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      CHARACTER*80       LINE
      INTEGER            INFO, LDO1, LDO2, LDO3, LDT1, LDT2, LDT3,
     $                   LWORK, NOUT, NPARMS, NSIZES, NTYPES
      REAL               TIMMIN
*     ..
*     .. Array Arguments ..
      LOGICAL            DOTYPE( * ), LLWORK( * )
      INTEGER            ISEED( * ), IWORK( * ), LDAS( * ), MAXBS( * ),
     $                   NN( * ), NNB( * ), NSHFTS( * )
      REAL               A( * ), H( * ), OPCNTS( LDO1, LDO2, LDO3, * ),
     $                   TIMES( LDT1, LDT2, LDT3, * ), W( * ),
     $                   WORK( * ), Z( * )
*     ..
*
*  Purpose
*  =======
*
*     STIM21 times the LAPACK routines for the REAL
*     non-symmetric eigenvalue problem.
*
*     For each N value in NN(1:NSIZES) and .TRUE. value in
*     DOTYPE(1:NTYPES), a matrix will be generated and used to test the
*     selected routines.  Thus, NSIZES*(number of .TRUE. values in
*     DOTYPE) matrices will be generated.
*
*  Arguments
*  =========
*
*  LINE    (input) CHARACTER*80
*          On entry, LINE contains the input line which requested
*          this routine.  This line may contain a subroutine name,
*          such as SGEHRD, indicating that only routine SGEHRD will
*          be timed, or it may contain a generic name, such as SHS.
*          In this case, the rest of the line is scanned for the
*          first 12 non-blank characters, corresponding to the twelve
*          combinations of subroutine and options:
*          LAPACK:
*          1: SGEHRD
*          2: SHSEQR(JOB='E')
*          3: SHSEQR(JOB='S')
*          4: SHSEQR(JOB='I')
*          5: STREVC(JOB='L')
*          6: STREVC(JOB='R')
*          7: SHSEIN(JOB='L')
*          8: SHSEIN(JOB='R')
*          EISPACK:
*           9: ORTHES (compare with SGEHRD)
*          10: HQR    (compare w/ SHSEQR -- JOB='E')
*          11: HQR2   (compare w/ SHSEQR(JOB='I') plus STREVC(JOB='R'))
*          12: INVIT  (compare with SHSEIN)
*          If a character is 'T' or 't', the corresponding routine in
*          this path is timed.  If the entire line is blank, all the
*          routines in the path are timed.
*
*  NSIZES  (input) INTEGER
*          The number of values of N contained in the vector NN.
*
*  NN      (input) INTEGER array, dimension( NSIZES )
*          The values of the matrix size N to be tested.  For each
*          N value in the array NN, and each .TRUE. value in DOTYPE,
*          a matrix A will be generated and used to test the routines.
*
*  NTYPES  (input) INTEGER
*          The number of types in DOTYPE.  Only the first MAXTYP
*          elements will be examined.  Exception: if NSIZES=1 and
*          NTYPES=MAXTYP+1, and DOTYPE=MAXTYP*f,t, then the input
*          value of A will be used.
*
*  DOTYPE  (input) LOGICAL
*          If DOTYPE(j) is .TRUE., then a matrix of type j will be
*          generated.  The matrix A has the form X**(-1) T X, where
*          X is orthogonal (for j=1--4) or has condition sqrt(ULP)
*          (for j=5--8), and T has random O(1) entries in the upper
*          triangle and:
*          (j=1,5) evenly spaced entries 1, ..., ULP with random signs
*          (j=2,6) geometrically spaced entries 1, ..., ULP with random
*                  signs
*          (j=3,7) "clustered" entries 1, ULP,..., ULP with random
*                  signs
*          (j=4,8) real or complex conjugate paired eigenvalues
*                  randomly chosen from ( ULP, 1 )
*          on the diagonal.
*
*  NPARMS  (input) INTEGER
*          The number of values in each of the arrays NNB, NSHFTS,
*          MAXBS, and LDAS.  For each matrix A generated according to
*          NN and DOTYPE, tests will be run with (NB,NSHIFT,MAXB,LDA)=
*          (NNB(1), NSHFTS(1), MAXBS(1), LDAS(1)),...,
*          (NNB(NPARMS), NSHFTS(NPARMS), MAXBS(NPARMS), LDAS(NPARMS))
*
*  NNB     (input) INTEGER array, dimension( NPARMS )
*          The values of the blocksize ("NB") to be tested.
*
*  NSHFTS  (input) INTEGER array, dimension( NPARMS )
*          The values of the number of shifts ("NSHIFT") to be tested.
*
*  MAXBS   (input) INTEGER array, dimension( NPARMS )
*          The values of "MAXB", the size of largest submatrix to be
*          processed by SLAHQR (EISPACK method), to be tested.
*
*  LDAS    (input) INTEGER array, dimension( NPARMS )
*          The values of LDA, the leading dimension of all matrices,
*          to be tested.
*
*  TIMMIN  (input) REAL
*          The minimum time a subroutine will be timed.
*
*  NOUT    (input) INTEGER
*          If NOUT > 0 then NOUT specifies the unit number
*          on which the output will be printed.  If NOUT <= 0, no
*          output is printed.
*
*  ISEED   (input/output) INTEGER array, dimension( 4 )
*          The random seed used by the random number generator, used
*          by the test matrix generator.  It is used and updated on
*          each call to STIM21
*
*  A       (workspace) REAL array,
*                      dimension( max(NN)*max(LDAS) )
*          (a) During the testing of SGEHRD, the original matrix to
*              be tested.
*          (b) Later, the Schur form of the original matrix.
*
*  H       (workspace) REAL array,
*                      dimension( max(NN)*max(LDAS) )
*          The Hessenberg form of the original matrix.
*
*  Z       (workspace) REAL array,
*                      dimension( max(NN)*max(LDAS) )
*          Various output arrays: from SGEHRD and SHSEQR, the
*          orthogonal reduction matrices; from STREVC and SHSEIN,
*          the eigenvector matrices.
*
*  W       (workspace) REAL array,
*                      dimension( 2*max(LDAS) )
*          Treated as an LDA x 2 matrix whose 1st column holds WR, the
*          real parts of the eigenvalues, and whose 2nd column holds
*          WI, the imaginary parts of the eigenvalues of A.
*
*  WORK    (workspace) REAL array, dimension( LWORK )
*
*  LWORK   (input) INTEGER
*          Number of elements in WORK.  It must be at least
*          (a)  max(NN)*( 3*max(NNB) + 2 )
*          (b)  max(NN)*( max(NNB+NSHFTS) + 1 )
*          (c)  max(NSHFTS)*( max(NSHFTS) + max(NN) )
*          (d)  max(MAXBS)*( max(MAXBS) + max(NN) )
*          (e)  ( max(NN) + 2 )**2  +  max(NN)
*          (f)  NSIZES*NTYPES*NPARMS
*
*  LLWORK  (workspace) LOGICAL array, dimension( max( max(NN), NPARMS ))
*
*  IWORK   (workspace) INTEGER array, dimension( 2*max(NN) )
*          Workspace needed for parameters IFAILL and IFAILR in call
*          to SHSEIN.
*
*  TIMES   (output) REAL array,
*                   dimension (LDT1,LDT2,LDT3,NSUBS)
*          TIMES(i,j,k,l) will be set to the run time (in seconds) for
*          subroutine l, with N=NN(k), matrix type j, and LDA=LDAS(i),
*          MAXB=MAXBS(i), NBLOCK=NNB(i), and NSHIFT=NSHFTS(i).
*
*  LDT1    (input) INTEGER
*          The first dimension of TIMES.  LDT1 >= min( 1, NPARMS ).
*
*  LDT2    (input) INTEGER
*          The second dimension of TIMES.  LDT2 >= min( 1, NTYPES ).
*
*  LDT3    (input) INTEGER
*          The third dimension of TIMES.  LDT3 >= min( 1, NSIZES ).
*
*  OPCNTS  (output) REAL array,
*                   dimension (LDO1,LDO2,LDO3,NSUBS)
*          OPCNTS(i,j,k,l) will be set to the number of floating-point
*          operations executed by subroutine l, with N=NN(k), matrix
*          type j, and LDA=LDAS(i), MAXB=MAXBS(i), NBLOCK=NNB(i), and
*          NSHIFT=NSHFTS(i).
*
*  LDO1    (input) INTEGER
*          The first dimension of OPCNTS.  LDO1 >= min( 1, NPARMS ).
*
*  LDO2    (input) INTEGER
*          The second dimension of OPCNTS.  LDO2 >= min( 1, NTYPES ).
*
*  LDO3    (input) INTEGER
*          The third dimension of OPCNTS.  LDO3 >= min( 1, NSIZES ).
*
*  INFO    (output) INTEGER
*          Error flag.  It will be set to zero if no error occurred.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            MAXTYP, NSUBS
      PARAMETER          ( MAXTYP = 8, NSUBS = 12 )
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            RUNHQR, RUNHRD, RUNORT, RUNQRE, RUNQRS
      INTEGER            IC, ICONDS, IINFO, IMODE, IN, IPAR, ISUB,
     $                   ITEMP, ITYPE, J, J1, J2, J3, J4, JC, JR, LASTL,
     $                   LASTNL, LDA, LDAMIN, LDH, LDT, LDW, MAXB,
     $                   MBMAX, MTYPES, N, NB, NBMAX, NMAX,
     $                   NSBMAX, NSHIFT, NSMAX
      REAL               CONDS, RTULP, RTULPI, S1, S2, TIME, ULP,
     $                   ULPINV, UNTIME
*     ..
*     .. Local Arrays ..
      LOGICAL            TIMSUB( NSUBS )
      CHARACTER          ADUMMA( 1 )
      CHARACTER*4        PNAMES( 4 )
      CHARACTER*9        SUBNAM( NSUBS )
      INTEGER            INPARM( NSUBS ), IOLDSD( 4 ), KCONDS( MAXTYP ),
     $                   KMODE( MAXTYP )
*     ..
*     .. External Functions ..
      REAL               SLAMCH, SECOND, SOPLA
      EXTERNAL           SLAMCH, SECOND, SOPLA
*     ..
*     .. External Subroutines ..
      EXTERNAL           ATIMIN, HQR, HQR2, INVIT, ORTHES, SGEHRD,
     $                   SHSEIN, SHSEQR, SLACPY, SLATME, SLASET, SPRTBE,
     $                   STREVC, XLAENV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, REAL, SQRT
*     ..
*     .. Scalars in Common ..
      REAL               ITCNT, OPS
*     ..
*     .. Common blocks ..
      COMMON             / LATIME / OPS, ITCNT
*     ..
*     .. Data statements ..
      DATA               SUBNAM / 'SGEHRD', 'SHSEQR(E)', 'SHSEQR(S)',
     $                   'SHSEQR(V)', 'STREVC(L)', 'STREVC(R)',
     $                   'SHSEIN(L)', 'SHSEIN(R)', 'ORTHES', 'HQR',
     $                   'HQR2', 'INVIT' /
      DATA               INPARM / 2, 4, 4, 4, 1, 1, 1, 1, 1, 1, 1, 1 /
      DATA               PNAMES / 'LDA', 'NB', 'NS', 'MAXB' /
      DATA               KMODE / 4, 3, 1, 5, 4, 3, 1, 5 /
      DATA               KCONDS / 4*1, 4*2 /
*     ..
*     .. Executable Statements ..
*
*     Quick Return
*
      INFO = 0
      IF( NSIZES.LE.0 .OR. NTYPES.LE.0 .OR. NPARMS.LE.0 )
     $   RETURN
*
*     Extract the timing request from the input line.
*
      CALL ATIMIN( 'SHS', LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
      IF( INFO.NE.0 )
     $   RETURN
*
*     Compute Maximum Values
*
      NMAX = 0
      DO 10 J1 = 1, NSIZES
         NMAX = MAX( NMAX, NN( J1 ) )
   10 CONTINUE
*
      LDAMIN = 2*MAX( 1, NMAX )
      NBMAX = 0
      NSMAX = 0
      MBMAX = 0
      NSBMAX = 0
      DO 20 J1 = 1, NPARMS
         LDAMIN = MIN( LDAMIN, LDAS( J1 ) )
         NBMAX = MAX( NBMAX, NNB( J1 ) )
         NSMAX = MAX( NSMAX, NSHFTS( J1 ) )
         MBMAX = MAX( MBMAX, MAXBS( J1 ) )
         NSBMAX = MAX( NSBMAX, NNB( J1 )+NSHFTS( J1 ) )
   20 CONTINUE
*
*     Check that N <= LDA for the input values.
*
      IF( NMAX.GT.LDAMIN ) THEN
         INFO = -10
         WRITE( NOUT, FMT = 9999 )LINE( 1: 6 )
 9999    FORMAT( 1X, A, ' timing run not attempted -- N > LDA', / )
         RETURN
      END IF
*
*     Check LWORK
*
      IF( LWORK.LT.MAX( NMAX*MAX( 3*NBMAX+2, NSBMAX+1 ),
     $    NSMAX*( NSMAX+NMAX ), MBMAX*( MBMAX+NMAX ),
     $    ( NMAX+1 )*( NMAX+4 ), NSIZES*NTYPES*NPARMS ) ) THEN
         INFO = -19
         WRITE( NOUT, FMT = 9998 )LINE( 1: 6 )
 9998    FORMAT( 1X, A, ' timing run not attempted -- LWORK too small.',
     $         / )
         RETURN
      END IF
*
*     Check to see whether SGEHRD or SHSEQR must be run.
*
*     RUNQRE -- if SHSEQR must be run to get eigenvalues.
*     RUNQRS -- if SHSEQR must be run to get Schur form.
*     RUNHRD -- if SGEHRD must be run.
*
      RUNQRS = .FALSE.
      RUNQRE = .FALSE.
      RUNHRD = .FALSE.
      IF( TIMSUB( 5 ) .OR. TIMSUB( 6 ) )
     $   RUNQRS = .TRUE.
      IF( ( TIMSUB( 7 ) .OR. TIMSUB( 8 ) ) )
     $   RUNQRE = .TRUE.
      IF( TIMSUB( 2 ) .OR. TIMSUB( 3 ) .OR. TIMSUB( 4 ) .OR. RUNQRS .OR.
     $    RUNQRE )RUNHRD = .TRUE.
      IF( TIMSUB( 3 ) .OR. TIMSUB( 4 ) .OR. RUNQRS )
     $   RUNQRE = .FALSE.
      IF( TIMSUB( 4 ) )
     $   RUNQRS = .FALSE.
*
*     Check to see whether ORTHES or HQR must be run.
*
*     RUNHQR -- if HQR must be run to get eigenvalues.
*     RUNORT -- if ORTHES must be run.
*
      RUNHQR = .FALSE.
      RUNORT = .FALSE.
      IF( TIMSUB( 12 ) )
     $   RUNHQR = .TRUE.
      IF( TIMSUB( 10 ) .OR. TIMSUB( 11 ) .OR. RUNHQR )
     $   RUNORT = .TRUE.
      IF( TIMSUB( 10 ) .OR. TIMSUB( 11 ) )
     $   RUNHQR = .FALSE.
      IF( TIMSUB( 9 ) )
     $   RUNORT = .FALSE.
*
*     Various Constants
*
      ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
      ULPINV = ONE / ULP
      RTULP = SQRT( ULP )
      RTULPI = ONE / RTULP
*
*     Zero out OPCNTS, TIMES
*
      DO 60 J4 = 1, NSUBS
         DO 50 J3 = 1, NSIZES
            DO 40 J2 = 1, NTYPES
               DO 30 J1 = 1, NPARMS
                  OPCNTS( J1, J2, J3, J4 ) = ZERO
                  TIMES( J1, J2, J3, J4 ) = ZERO
   30          CONTINUE
   40       CONTINUE
   50    CONTINUE
   60 CONTINUE
*
*     Do for each value of N:
*
      DO 620 IN = 1, NSIZES
*
         N = NN( IN )
*
*        Do for each .TRUE. value in DOTYPE:
*
         MTYPES = MIN( MAXTYP, NTYPES )
         IF( NTYPES.EQ.MAXTYP+1 .AND. NSIZES.EQ.1 )
     $      MTYPES = NTYPES
         DO 610 ITYPE = 1, MTYPES
            IF( .NOT.DOTYPE( ITYPE ) )
     $         GO TO 610
*
*           Save random number seed for error messages
*
            DO 70 J = 1, 4
               IOLDSD( J ) = ISEED( J )
   70       CONTINUE
*
*-----------------------------------------------------------------------
*
*           Time the LAPACK Routines
*
*           Generate A
*
            IF( ITYPE.LE.MAXTYP ) THEN
               IMODE = KMODE( ITYPE )
               ICONDS = KCONDS( ITYPE )
               IF( ICONDS.EQ.1 ) THEN
                  CONDS = ONE
               ELSE
                  CONDS = RTULPI
               END IF
               ADUMMA( 1 ) = ' '
               CALL SLATME( N, 'S', ISEED, WORK, IMODE, ULPINV, ONE,
     $                      ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
     $                      CONDS, N, N, ONE, A, N, WORK( 2*N+1 ),
     $                      IINFO )
            END IF
*
*           Time SGEHRD for each pair NNB(j), LDAS(j)
*
            IF( TIMSUB( 1 ) ) THEN
               DO 110 IPAR = 1, NPARMS
                  LDA = LDAS( IPAR )
                  NB = MIN( N, NNB( IPAR ) )
*
*                 If this combination of (NB,LDA) has occurred before,
*                 just use that value.
*
                  LASTNL = 0
                  DO 80 J = 1, IPAR - 1
                     IF( LDA.EQ.LDAS( J ) .AND. NB.EQ.
     $                   MIN( N, NNB( J ) ) )LASTNL = J
   80             CONTINUE
*
                  IF( LASTNL.EQ.0 ) THEN
                     CALL XLAENV( 1, NB )
                     CALL XLAENV( 2, 2 )
                     CALL XLAENV( 3, NB )
*
*                    Time SGEHRD
*
                     IC = 0
                     OPS = ZERO
                     S1 = SECOND( )
   90                CONTINUE
                     CALL SLACPY( 'Full', N, N, A, N, H, LDA )
*
                     CALL SGEHRD( N, 1, N, H, LDA, WORK,
     $                            WORK(N+1), LWORK-N, IINFO )
*
                     IF( IINFO.NE.0 ) THEN
                        WRITE( NOUT, FMT = 9997 )SUBNAM( 1 ), IINFO, N,
     $                     ITYPE, IPAR, IOLDSD
                        INFO = ABS( IINFO )
                        GO TO 610
                     END IF
*
                     S2 = SECOND( )
                     TIME = S2 - S1
                     IC = IC + 1
                     IF( TIME.LT.TIMMIN )
     $                  GO TO 90
*
*                    Subtract the time used in SLACPY.
*
                     S1 = SECOND( )
                     DO 100 J = 1, IC
                        CALL SLACPY( 'Full', N, N, A, N, Z, LDA )
  100                CONTINUE
                     S2 = SECOND( )
                     UNTIME = S2 - S1
*
                     TIMES( IPAR, ITYPE, IN, 1 ) = MAX( TIME-UNTIME,
     $                  ZERO ) / REAL( IC )
                     OPCNTS( IPAR, ITYPE, IN, 1 ) = SOPLA( 'SGEHRD',
     $                  N, 1, N, 0, NB )
                  ELSE
                     OPCNTS( IPAR, ITYPE, IN, 1 ) = OPCNTS( LASTNL,
     $                  ITYPE, IN, 1 )
                     TIMES( IPAR, ITYPE, IN, 1 ) = TIMES( LASTNL, ITYPE,
     $                  IN, 1 )
                  END IF
  110          CONTINUE
               LDH = LDA
            ELSE
               IF( RUNHRD ) THEN
                  CALL SLACPY( 'Full', N, N, A, N, H, N )
*
                  CALL SGEHRD( N, 1, N, H, N, WORK, WORK( N+1 ),
     $                         LWORK-N, IINFO )
*
                  IF( IINFO.NE.0 ) THEN
                     WRITE( NOUT, FMT = 9997 )SUBNAM( 1 ), IINFO, N,
     $                  ITYPE, 0, IOLDSD
                     INFO = ABS( IINFO )
                     GO TO 610
                  END IF
                  LDH = N
               END IF
            END IF
*
*           Time SHSEQR with JOB='E' for each 4-tuple
*           NNB(j), NSHFTS(j), MAXBS(j), LDAS(j)
*
            IF( TIMSUB( 2 ) ) THEN
               DO 140 IPAR = 1, NPARMS
                  LDA = LDAS( IPAR )
                  NB = 1
                  NSHIFT = NSHFTS( IPAR )
                  MAXB = MAXBS( IPAR )
                  CALL XLAENV( 4, NSHIFT )
                  CALL XLAENV( 8, MAXB )
*
*                 Time SHSEQR with JOB='E'
*
                  IC = 0
                  OPS = ZERO
                  S1 = SECOND( )
  120             CONTINUE
                  CALL SLACPY( 'Full', N, N, H, LDH, A, LDA )
*
                  CALL SHSEQR( 'E', 'N', N, 1, N, A, LDA, W, W( LDA+1 ),
     $                         Z, LDA, WORK, LWORK, IINFO )
*
                  IF( IINFO.NE.0 ) THEN
                     WRITE( NOUT, FMT = 9997 )SUBNAM( 2 ), IINFO, N,
     $                  ITYPE, IPAR, IOLDSD
                     INFO = ABS( IINFO )
                     GO TO 610
                  END IF
*
                  S2 = SECOND( )
                  TIME = S2 - S1
                  IC = IC + 1
                  IF( TIME.LT.TIMMIN )
     $               GO TO 120
*
*                 Subtract the time used in SLACPY.
*
                  S1 = SECOND( )
                  DO 130 J = 1, IC
                     CALL SLACPY( 'Full', N, N, H, LDH, Z, LDA )
  130             CONTINUE
                  S2 = SECOND( )
                  UNTIME = S2 - S1
*
                  TIMES( IPAR, ITYPE, IN, 2 ) = MAX( TIME-UNTIME,
     $               ZERO ) / REAL( IC )
                  OPCNTS( IPAR, ITYPE, IN, 2 ) = OPS / REAL( IC )
  140          CONTINUE
               LDT = 0
               LDW = LDA
            ELSE
               IF( RUNQRE ) THEN
                  CALL SLACPY( 'Full', N, N, H, LDH, A, N )
*
                  CALL SHSEQR( 'E', 'N', N, 1, N, A, N, W, W( N+1 ),
     $                         Z, N, WORK, LWORK, IINFO )
*
                  IF( IINFO.NE.0 ) THEN
                     WRITE( NOUT, FMT = 9997 )SUBNAM( 2 ), IINFO, N,
     $                  ITYPE, 0, IOLDSD
                     INFO = ABS( IINFO )
                     GO TO 610
                  END IF
                  LDT = 0
                  LDW = N
               END IF
            END IF
*
*           Time SHSEQR with JOB='S' for each 4-tuple
*           NNB(j), NSHFTS(j), MAXBS(j), LDAS(j)
*
            IF( TIMSUB( 3 ) ) THEN
               DO 170 IPAR = 1, NPARMS
                  LDA = LDAS( IPAR )
                  NSHIFT = NSHFTS( IPAR )
                  MAXB = MAXBS( IPAR )
                  NB = 1
                  CALL XLAENV( 4, NSHIFT )
                  CALL XLAENV( 8, MAXB )
*
*                 Time SHSEQR with JOB='S'
*
                  IC = 0
                  OPS = ZERO
                  S1 = SECOND( )
  150             CONTINUE
                  CALL SLACPY( 'Full', N, N, H, LDH, A, LDA )
*
                  CALL SHSEQR( 'S', 'N', N, 1, N, A, LDA, W, W( LDA+1 ),
     $                         Z, LDA, WORK, LWORK, IINFO )
*
                  IF( IINFO.NE.0 ) THEN
                     WRITE( NOUT, FMT = 9997 )SUBNAM( 3 ), IINFO, N,
     $                  ITYPE, IPAR, IOLDSD
                     INFO = ABS( IINFO )
                     GO TO 610
                  END IF
*
                  S2 = SECOND( )
                  TIME = S2 - S1
                  IC = IC + 1
                  IF( TIME.LT.TIMMIN )
     $               GO TO 150
*
*                 Subtract the time used in SLACPY.
*
                  S1 = SECOND( )
                  DO 160 J = 1, IC
                     CALL SLACPY( 'Full', N, N, H, LDH, Z, LDA )
  160             CONTINUE
                  S2 = SECOND( )
                  UNTIME = S2 - S1
*
                  TIMES( IPAR, ITYPE, IN, 3 ) = MAX( TIME-UNTIME,
     $               ZERO ) / REAL( IC )
                  OPCNTS( IPAR, ITYPE, IN, 3 ) = OPS / REAL( IC )
  170          CONTINUE
               LDT = LDA
               LDW = LDA
            ELSE
               IF( RUNQRS ) THEN
                  CALL SLACPY( 'Full', N, N, H, LDH, A, N )
*
                  CALL SHSEQR( 'S', 'N', N, 1, N, A, N, W, W( N+1 ),
     $                          Z, N, WORK, LWORK, IINFO )
*
                  IF( IINFO.NE.0 ) THEN
                     WRITE( NOUT, FMT = 9997 )SUBNAM( 3 ), IINFO, N,
     $                  ITYPE, 0, IOLDSD
                     INFO = ABS( IINFO )
                     GO TO 610
                  END IF
                  LDT = N
                  LDW = N
               END IF
            END IF
*
*           Time SHSEQR with JOB='I' for each 4-tuple
*           NNB(j), NSHFTS(j), MAXBS(j), LDAS(j)
*
            IF( TIMSUB( 4 ) ) THEN
               DO 200 IPAR = 1, NPARMS
                  LDA = LDAS( IPAR )
                  NSHIFT = NSHFTS( IPAR )
                  MAXB = MAXBS( IPAR )
                  NB = 1
                  CALL XLAENV( 4, NSHIFT )
                  CALL XLAENV( 8, MAXB )
*
*                 Time SHSEQR with JOB='I'
*
                  IC = 0
                  OPS = ZERO
                  S1 = SECOND( )
  180             CONTINUE
                  CALL SLACPY( 'Full', N, N, H, LDH, A, LDA )
*
                  CALL SHSEQR( 'S', 'I', N, 1, N, A, LDA, W, W( LDA+1 ),
     $                         Z, LDA, WORK, LWORK, IINFO )
*
                  IF( IINFO.NE.0 ) THEN
                     WRITE( NOUT, FMT = 9997 )SUBNAM( 4 ), IINFO, N,
     $                  ITYPE, IPAR, IOLDSD
                     INFO = ABS( IINFO )
                     GO TO 610
                  END IF
*
                  S2 = SECOND( )
                  TIME = S2 - S1
                  IC = IC + 1
                  IF( TIME.LT.TIMMIN )
     $               GO TO 180
*
*                 Subtract the time used in SLACPY.
*
                  S1 = SECOND( )
                  DO 190 J = 1, IC
                     CALL SLACPY( 'Full', N, N, H, LDH, Z, LDA )
  190             CONTINUE
                  S2 = SECOND( )
                  UNTIME = S2 - S1
*
                  TIMES( IPAR, ITYPE, IN, 4 ) = MAX( TIME-UNTIME,
     $               ZERO ) / REAL( IC )
                  OPCNTS( IPAR, ITYPE, IN, 4 ) = OPS / REAL( IC )
  200          CONTINUE
               LDT = LDA
               LDW = LDA
            END IF
*
*           Time STREVC and SHSEIN with various values of LDA
*
*           Select All Eigenvectors
*
            DO 210 J = 1, N
               LLWORK( J ) = .TRUE.
  210       CONTINUE
*
            DO 370 IPAR = 1, NPARMS
               LDA = LDAS( IPAR )
*
*              If this value of LDA has come up before, just use
*              the value previously computed.
*
               LASTL = 0
               DO 220 J = 1, IPAR - 1
                  IF( LDA.EQ.LDAS( J ) )
     $               LASTL = J
  220          CONTINUE
*
*              Time STREVC
*
               IF( ( TIMSUB( 5 ) .OR. TIMSUB( 6 ) ) .AND. LASTL.EQ.0 )
     $              THEN
*
*                 Copy T (which is in A) if necessary to get right LDA.
*
                  IF( LDA.GT.LDT ) THEN
                     DO 240 JC = N, 1, -1
                        DO 230 JR = N, 1, -1
                           A( JR+( JC-1 )*LDA ) = A( JR+( JC-1 )*LDT )
  230                   CONTINUE
  240                CONTINUE
                  ELSE IF( LDA.LT.LDT ) THEN
                     DO 260 JC = 1, N
                        DO 250 JR = 1, N
                           A( JR+( JC-1 )*LDA ) = A( JR+( JC-1 )*LDT )
  250                   CONTINUE
  260                CONTINUE
                  END IF
                  LDT = LDA
*
*                 Time STREVC for Left Eigenvectors
*
                  IF( TIMSUB( 5 ) ) THEN
                     IC = 0
                     OPS = ZERO
                     S1 = SECOND( )
  270                CONTINUE
*
                     CALL STREVC( 'L', 'A', LLWORK, N, A, LDA, Z, LDA,
     $                            Z, LDA, N, ITEMP, WORK, IINFO )
*
                     IF( IINFO.NE.0 ) THEN
                        WRITE( NOUT, FMT = 9997 )SUBNAM( 5 ), IINFO, N,
     $                     ITYPE, IPAR, IOLDSD
                        INFO = ABS( IINFO )
                        GO TO 610
                     END IF
                     S2 = SECOND( )
                     TIME = S2 - S1
                     IC = IC + 1
                     IF( TIME.LT.TIMMIN )
     $                  GO TO 270
*
                     TIMES( IPAR, ITYPE, IN, 5 ) = TIME / REAL( IC )
                     OPCNTS( IPAR, ITYPE, IN, 5 ) = OPS / REAL( IC )
                  END IF
*
*                 Time STREVC for Right Eigenvectors
*
                  IF( TIMSUB( 6 ) ) THEN
                     IC = 0
                     OPS = ZERO
                     S1 = SECOND( )
  280                CONTINUE
                     CALL STREVC( 'R', 'A', LLWORK, N, A, LDA, Z, LDA,
     $                            Z, LDA, N, ITEMP, WORK, IINFO )
*
                     IF( IINFO.NE.0 ) THEN
                        WRITE( NOUT, FMT = 9997 )SUBNAM( 6 ), IINFO, N,
     $                     ITYPE, IPAR, IOLDSD
                        INFO = ABS( IINFO )
                        GO TO 610
                     END IF
                     S2 = SECOND( )
                     TIME = S2 - S1
                     IC = IC + 1
                     IF( TIME.LT.TIMMIN )
     $                  GO TO 280
*
                     TIMES( IPAR, ITYPE, IN, 6 ) = TIME / REAL( IC )
                     OPCNTS( IPAR, ITYPE, IN, 6 ) = OPS / REAL( IC )
                  END IF
               ELSE
                  IF( TIMSUB( 5 ) ) THEN
                     OPCNTS( IPAR, ITYPE, IN, 5 ) = OPCNTS( LASTL,
     $                  ITYPE, IN, 5 )
                     TIMES( IPAR, ITYPE, IN, 5 ) = TIMES( LASTL, ITYPE,
     $                  IN, 5 )
                  END IF
                  IF( TIMSUB( 6 ) ) THEN
                     OPCNTS( IPAR, ITYPE, IN, 6 ) = OPCNTS( LASTL,
     $                  ITYPE, IN, 6 )
                     TIMES( IPAR, ITYPE, IN, 6 ) = TIMES( LASTL, ITYPE,
     $                  IN, 6 )
                  END IF
               END IF
*
*              Time SHSEIN
*
               IF( ( TIMSUB( 7 ) .OR. TIMSUB( 8 ) ) .AND. LASTL.EQ.0 )
     $              THEN
*
*                 Copy H if necessary to get right LDA.
*
                  IF( LDA.GT.LDH ) THEN
                     DO 300 JC = N, 1, -1
                        DO 290 JR = N, 1, -1
                           H( JR+( JC-1 )*LDA ) = H( JR+( JC-1 )*LDH )
  290                   CONTINUE
                        W( JC+LDA ) = W( JC+LDH )
  300                CONTINUE
                  ELSE IF( LDA.LT.LDH ) THEN
                     DO 320 JC = 1, N
                        DO 310 JR = 1, N
                           H( JR+( JC-1 )*LDA ) = H( JR+( JC-1 )*LDH )
  310                   CONTINUE
                        W( JC+LDA ) = W( JC+LDH )
  320                CONTINUE
                  END IF
                  LDH = LDA
*
*                 Copy W if necessary to get right LDA.
*
                  IF( LDA.GT.LDW ) THEN
                     DO 330 J = N, 1, -1
                        W( J+LDA ) = W( J+LDW )
  330                CONTINUE
                  ELSE IF( LDA.LT.LDW ) THEN
                     DO 340 J = 1, N
                        W( J+LDA ) = W( J+LDW )
  340                CONTINUE
                  END IF
                  LDW = LDA
*
*                 Time SHSEIN for Left Eigenvectors
*
                  IF( TIMSUB( 7 ) ) THEN
                     IC = 0
                     OPS = ZERO
                     S1 = SECOND( )
  350                CONTINUE
*
                     CALL SHSEIN( 'L', 'Q', 'N', LLWORK, N, H, LDA, W,
     $                            W( LDA+1 ), Z, LDA, Z, LDA, N, ITEMP,
     $                            WORK, IWORK, IWORK( N+1 ), IINFO )
*
                     IF( IINFO.NE.0 ) THEN
                        WRITE( NOUT, FMT = 9997 )SUBNAM( 7 ), IINFO, N,
     $                     ITYPE, IPAR, IOLDSD
                        INFO = ABS( IINFO )
                        GO TO 610
                     END IF
                     S2 = SECOND( )
                     TIME = S2 - S1
                     IC = IC + 1
                     IF( TIME.LT.TIMMIN )
     $                  GO TO 350
*
                     TIMES( IPAR, ITYPE, IN, 7 ) = TIME / REAL( IC )
                     OPCNTS( IPAR, ITYPE, IN, 7 ) = OPS / REAL( IC )
                  END IF
*
*                 Time SHSEIN for Right Eigenvectors
*
                  IF( TIMSUB( 8 ) ) THEN
                     IC = 0
                     OPS = ZERO
                     S1 = SECOND( )
  360                CONTINUE
*
                     CALL SHSEIN( 'R', 'Q', 'N', LLWORK, N, H, LDA, W,
     $                            W( LDA+1 ), Z, LDA, Z, LDA, N, ITEMP,
     $                            WORK, IWORK, IWORK( N+1 ), IINFO )
*
                     IF( IINFO.NE.0 ) THEN
                        WRITE( NOUT, FMT = 9997 )SUBNAM( 8 ), IINFO, N,
     $                     ITYPE, IPAR, IOLDSD
                        INFO = ABS( IINFO )
                        GO TO 610
                     END IF
                     S2 = SECOND( )
                     TIME = S2 - S1
                     IC = IC + 1
                     IF( TIME.LT.TIMMIN )
     $                  GO TO 360
*
                     TIMES( IPAR, ITYPE, IN, 8 ) = TIME / REAL( IC )
                     OPCNTS( IPAR, ITYPE, IN, 8 ) = OPS / REAL( IC )
                  END IF
               ELSE
                  IF( TIMSUB( 7 ) ) THEN
                     OPCNTS( IPAR, ITYPE, IN, 7 ) = OPCNTS( LASTL,
     $                  ITYPE, IN, 7 )
                     TIMES( IPAR, ITYPE, IN, 7 ) = TIMES( LASTL, ITYPE,
     $                  IN, 7 )
                  END IF
                  IF( TIMSUB( 8 ) ) THEN
                     OPCNTS( IPAR, ITYPE, IN, 8 ) = OPCNTS( LASTL,
     $                  ITYPE, IN, 8 )
                     TIMES( IPAR, ITYPE, IN, 8 ) = TIMES( LASTL, ITYPE,
     $                  IN, 8 )
                  END IF
               END IF
  370       CONTINUE
*
*-----------------------------------------------------------------------
*
*           Time the EISPACK Routines
*
*           Restore random number seed
*
            DO 380 J = 1, 4
               ISEED( J ) = IOLDSD( J )
  380       CONTINUE
*
*           Re-generate A
*
            IF( ITYPE.LE.MAXTYP ) THEN
               IMODE = KMODE( ITYPE )
               IF( ICONDS.EQ.1 ) THEN
                  CONDS = ONE
               ELSE
                  CONDS = RTULPI
               END IF
               CALL SLATME( N, 'S', ISEED, WORK, IMODE, ULPINV, ONE,
     $                      ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
     $                      CONDS, N, N, ONE, A, N, WORK( 2*N+1 ),
     $                      IINFO )
            END IF
*
*           Time ORTHES for each LDAS(j)
*
            IF( TIMSUB( 9 ) ) THEN
               DO 420 IPAR = 1, NPARMS
                  LDA = LDAS( IPAR )
*
*                 If this value of LDA has come up before, just use
*                 the value previously computed.

                  LASTL = 0
                  DO 390 J = 1, IPAR - 1
                     IF( LDA.EQ.LDAS( J ) )
     $                  LASTL = J
  390             CONTINUE
*
                  IF( LASTL.EQ.0 ) THEN
*
*                    Time ORTHES
*
                     IC = 0
                     OPS = ZERO
                     S1 = SECOND( )
*
  400                CONTINUE
                     CALL SLACPY( 'Full', N, N, A, N, H, LDA )
*
                     CALL ORTHES( LDA, N, 1, N, H, WORK )
*
                     S2 = SECOND( )
                     TIME = S2 - S1
                     IC = IC + 1
                     IF( TIME.LT.TIMMIN )
     $                  GO TO 400
*
*                    Subtract the time used in SLACPY.
*
                     S1 = SECOND( )
                     DO 410 J = 1, IC
                        CALL SLACPY( 'Full', N, N, A, N, Z, LDA )
  410                CONTINUE
                     S2 = SECOND( )
                     UNTIME = S2 - S1
*
*                     OPS1 = ( 20*N**3 - 3*N**2 - 23*N ) / 6 - 17
*
                     TIMES( IPAR, ITYPE, IN, 9 ) = MAX( TIME-UNTIME,
     $                  ZERO ) / REAL( IC )
                     OPCNTS( IPAR, ITYPE, IN, 9 ) = OPS / REAL( IC )
                  ELSE
                     OPCNTS( IPAR, ITYPE, IN, 9 ) = OPCNTS( LASTL,
     $                  ITYPE, IN, 9 )
                     TIMES( IPAR, ITYPE, IN, 9 ) = TIMES( LASTL, ITYPE,
     $                  IN, 9 )
                  END IF
                  LDH = LDA
  420          CONTINUE
            ELSE
               IF( RUNORT ) THEN
                  CALL SLACPY( 'Full', N, N, A, N, H, N )
*
                  CALL ORTHES( N, N, 1, N, H, WORK )
*
                  LDH = N
               END IF
            END IF
*
*           Time HQR for each LDAS(j)
*
            IF( TIMSUB( 10 ) ) THEN
               DO 460 IPAR = 1, NPARMS
                  LDA = LDAS( IPAR )
*
*                 If this value of LDA has come up before, just use
*                 the value previously computed.
*
                  LASTL = 0
                  DO 430 J = 1, IPAR - 1
                     IF( LDA.EQ.LDAS( J ) )
     $                  LASTL = J
  430             CONTINUE
*
                  IF( LASTL.EQ.0 ) THEN
*
*                    Time HQR
*
                     IC = 0
                     OPS = ZERO
                     S1 = SECOND( )
  440                CONTINUE
                     CALL SLACPY( 'Full', N, N, H, LDH, A, LDA )
*
                     CALL HQR( LDA, N, 1, N, A, W, W( LDA+1 ), IINFO )
*
                     IF( IINFO.NE.0 ) THEN
                        WRITE( NOUT, FMT = 9997 )SUBNAM( 10 ), IINFO,
     $                     N, ITYPE, IPAR, IOLDSD
                        INFO = ABS( IINFO )
                        GO TO 610
                     END IF
                     S2 = SECOND( )
                     TIME = S2 - S1
                     IC = IC + 1
                     IF( TIME.LT.TIMMIN )
     $                  GO TO 440
*
*                    Subtract the time used in SLACPY.
*
                     S1 = SECOND( )
                     DO 450 J = 1, IC
                        CALL SLACPY( 'Full', N, N, H, LDH, Z, LDA )
  450                CONTINUE
                     S2 = SECOND( )
                     UNTIME = S2 - S1
*
                     TIMES( IPAR, ITYPE, IN, 10 ) = MAX( TIME-UNTIME,
     $                  ZERO ) / REAL( IC )
                     OPCNTS( IPAR, ITYPE, IN, 10 ) = OPS / REAL( IC )
                  ELSE
                     OPCNTS( IPAR, ITYPE, IN, 10 ) = OPCNTS( LASTL,
     $                  ITYPE, IN, 10 )
                     TIMES( IPAR, ITYPE, IN, 10 ) = TIMES( LASTL, ITYPE,
     $                  IN, 10 )
                  END IF
                  LDW = LDA
  460          CONTINUE
            ELSE
               IF( RUNHQR ) THEN
                  CALL SLACPY( 'Full', N, N, A, N, H, N )
*
                  CALL HQR( N, N, 1, N, A, W, W( N+1 ), IINFO )
*
                  LDW = N
               END IF
            END IF
*
*           Time HQR2 for each LDAS(j)
*
            IF( TIMSUB( 11 ) ) THEN
               DO 500 IPAR = 1, NPARMS
                  LDA = LDAS( IPAR )
*
*                 If this value of LDA has come up before, just use
*                 the value previously computed.
*
                  LASTL = 0
                  DO 470 J = 1, IPAR - 1
                     IF( LDA.EQ.LDAS( J ) )
     $                  LASTL = J
  470             CONTINUE
*
                  IF( LASTL.EQ.0 ) THEN
*
*                    Time HQR2
*
                     IC = 0
                     OPS = ZERO
                     S1 = SECOND( )
  480                CONTINUE
                     CALL SLACPY( 'Full', N, N, H, LDH, A, LDA )
                     CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDA )
*
                     CALL HQR2( LDA, N, 1, N, A, W, W( LDA+1 ), Z,
     $                          IINFO )
*
                     IF( IINFO.NE.0 ) THEN
                        WRITE( NOUT, FMT = 9997 )SUBNAM( 11 ), IINFO,
     $                     N, ITYPE, IPAR, IOLDSD
                        INFO = ABS( IINFO )
                        GO TO 610
                     END IF
                     S2 = SECOND( )
                     TIME = S2 - S1
                     IC = IC + 1
                     IF( TIME.LT.TIMMIN )
     $                  GO TO 480
*
*                    Subtract the time used in SLACPY.
*
                     S1 = SECOND( )
                     DO 490 J = 1, IC
                        CALL SLACPY( 'Full', N, N, H, LDH, Z, LDA )
  490                CONTINUE
                     S2 = SECOND( )
                     UNTIME = S2 - S1
*
                     TIMES( IPAR, ITYPE, IN, 11 ) = MAX( TIME-UNTIME,
     $                  ZERO ) / REAL( IC )
                     OPCNTS( IPAR, ITYPE, IN, 11 ) = OPS / REAL( IC )
                  ELSE
                     OPCNTS( IPAR, ITYPE, IN, 11 ) = OPCNTS( LASTL,
     $                  ITYPE, IN, 11 )
                     TIMES( IPAR, ITYPE, IN, 11 ) = TIMES( LASTL, ITYPE,
     $                  IN, 11 )
                  END IF
                  LDW = LDA
  500          CONTINUE
            END IF
*
*           Time INVIT for each LDAS(j)
*
*           Select All Eigenvectors
*
            DO 510 J = 1, N
               LLWORK( J ) = .TRUE.
  510       CONTINUE
*
            IF( TIMSUB( 12 ) ) THEN
               DO 600 IPAR = 1, NPARMS
                  LDA = LDAS( IPAR )
*
*                 If this value of LDA has come up before, just use
*                 the value previously computed.
*
                  LASTL = 0
                  DO 520 J = 1, IPAR - 1
                     IF( LDA.EQ.LDAS( J ) )
     $                  LASTL = J
  520             CONTINUE
*
                  IF( LASTL.EQ.0 ) THEN
*
*                    Copy H if necessary to get right LDA.
*
                     IF( LDA.GT.LDH ) THEN
                        DO 540 JC = N, 1, -1
                           DO 530 JR = N, 1, -1
                              H( JR+( JC-1 )*LDA ) = H( JR+( JC-1 )*
     $                           LDH )
  530                      CONTINUE
  540                   CONTINUE
                     ELSE IF( LDA.LT.LDH ) THEN
                        DO 560 JC = 1, N
                           DO 550 JR = 1, N
                              H( JR+( JC-1 )*LDA ) = H( JR+( JC-1 )*
     $                           LDH )
  550                      CONTINUE
  560                   CONTINUE
                     END IF
                     LDH = LDA
*
*                    Copy W if necessary to get right LDA.
*
                     IF( LDA.GT.LDW ) THEN
                        DO 570 J = N, 1, -1
                           W( J+LDA ) = W( J+LDW )
  570                   CONTINUE
                     ELSE IF( LDA.LT.LDW ) THEN
                        DO 580 J = 1, N
                           W( J+LDA ) = W( J+LDW )
  580                   CONTINUE
                     END IF
                     LDW = LDA
*
*                    Time INVIT for right eigenvectors.
*
                     IC = 0
                     OPS = ZERO
                     S1 = SECOND( )
  590                CONTINUE
*
                     CALL INVIT( LDA, N, H, W, W( LDA+1 ), LLWORK, N,
     $                           ITEMP, Z, IINFO, WORK( 2*N+1 ), WORK,
     $                           WORK( N+1 ) )
*
                     IF( IINFO.NE.0 ) THEN
                        WRITE( NOUT, FMT = 9997 )SUBNAM( 12 ), IINFO,
     $                     N, ITYPE, IPAR, IOLDSD
                        INFO = ABS( IINFO )
                        GO TO 610
                     END IF
                     S2 = SECOND( )
                     TIME = S2 - S1
                     IC = IC + 1
                     IF( TIME.LT.TIMMIN )
     $                  GO TO 590
*
*                    TIME = TIME / REAL( IC )
*                    OPS1 = OPS / REAL( IC )
*                    OPCNTS( IPAR, ITYPE, IN, 12 ) = OPS1
*                    TIMES( IPAR, ITYPE, IN, 12 ) = SMFLOP( OPS1, TIME,
*     $                  IINFO )
*
                     TIMES( IPAR, ITYPE, IN, 12 ) = TIME / REAL( IC )
                     OPCNTS( IPAR, ITYPE, IN, 12 ) = OPS / REAL( IC )
                  ELSE
                     OPCNTS( IPAR, ITYPE, IN, 12 ) = OPCNTS( LASTL,
     $                  ITYPE, IN, 12 )
                     TIMES( IPAR, ITYPE, IN, 12 ) = TIMES( LASTL, ITYPE,
     $                  IN, 12 )
                  END IF
  600          CONTINUE
            END IF
*
  610    CONTINUE
  620 CONTINUE
*
*-----------------------------------------------------------------------
*
*     Print a table of results for each timed routine.
*
      ISUB = 1
      IF( TIMSUB( ISUB ) ) THEN
         CALL SPRTBE( SUBNAM( ISUB ), MTYPES, DOTYPE, NSIZES, NN,
     $                INPARM( ISUB ), PNAMES, NPARMS, LDAS, NNB,
     $                NSHFTS, MAXBS, OPCNTS( 1, 1, 1, ISUB ), LDO1,
     $                LDO2, TIMES( 1, 1, 1, ISUB ), LDT1, LDT2, WORK,
     $                LLWORK, NOUT )
      END IF
*
      DO 625 IN = 1, NPARMS
         NNB( IN ) = 1
  625 CONTINUE
*
      DO 630 ISUB = 2, NSUBS
         IF( TIMSUB( ISUB ) ) THEN
            CALL SPRTBE( SUBNAM( ISUB ), MTYPES, DOTYPE, NSIZES, NN,
     $                   INPARM( ISUB ), PNAMES, NPARMS, LDAS, NNB,
     $                   NSHFTS, MAXBS, OPCNTS( 1, 1, 1, ISUB ), LDO1,
     $                   LDO2, TIMES( 1, 1, 1, ISUB ), LDT1, LDT2, WORK,
     $                   LLWORK, NOUT )
         END IF
  630 CONTINUE
*
      RETURN
*
*     End of STIM21
*
 9997 FORMAT( ' STIM21: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
     $      I6, ', ITYPE=', I6, ', IPAR=', I6, ', ISEED=(',
     $      3( I5, ',' ), I5, ')' )
*
      END


        implicit real *8 (a-h,o-z)
        complex *16 z,j0,ima,ztest(1000 000),jtest(1000 000),
     1    jtest2(1000 000),jtest3(1000 000)
        real *8 rtest(1000 0000),thetatest(1000 0000),jtestr(1000 0000),
     1      jtesti(1000 0000),xtest(1000 0000),ytest(1000 0000)
        data ima/(0.0d0,1.0d0)/

        call prini(6,13)

        ntest=10 000
        OPEN(UNIT=66,FILE="../mathematica/rm1test.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) rtest(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/thetam1test.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) thetatest(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/jm1testr.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) jtestr(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/jm1testi.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) jtesti(i)
        enddo
        close(66)

        do i=1,ntest
           ztest(i)=rtest(i)*exp(ima*thetatest(i))
c           ztest(i)=rtest(i)
        enddo

        do i=1,ntest
           jtest(i)=jtestr(i)+ima*jtesti(i)
        enddo

        ifexpon=0
        t1=second()
        do i=1,ntest
           call abramm1(ztest(i),jtest2(i),ifexpon)
        enddo
        t2=second()
        call prin2('evaluation time of J_{-1}=*',t2-t1,1)

        t1=second()
        do i=1,ntest
           jtest3(i)=exp(ztest(i))
        enddo
        t2=second()
        write(11,*) jtest3(1)
        call prin2('evaluation time of complex exponentials=*',t2-t1,1)

        dmax=0
        imax=0
        do i=1,ntest
           dd=abs((jtest(i)-jtest2(i))/jtest(i))
           if (dd .gt. 1d-32) then
              print *, dd, ztest(i)
           endif
           if (dmax .lt. dd) then
              dmax=dd
              imax=i
           endif
        enddo

        print *, 'maximum relative error = ', dmax
        print *, 'occured at ', ztest(imax), imax
        print *, 'true value = ', jtest(imax)
        print *, 'computed value = ', jtest2(imax)
        print *, 'done with testing J_{-1}'

cc        ntest=10 000
        OPEN(UNIT=66,FILE="../mathematica/r0test.txt",FORM="FORMATTED",
     1      STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) rtest(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/theta0test.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) thetatest(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/j0testr.txt",FORM="FORMATTED",
     1      STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) jtestr(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/j0testi.txt",FORM="FORMATTED",
     1      STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) jtesti(i)
        enddo
        close(66)

        do i=1,ntest
           ztest(i)=rtest(i)*exp(ima*thetatest(i))
c           ztest(i)=rtest(i)
        enddo

        do i=1,ntest
           jtest(i)=jtestr(i)+ima*jtesti(i)
        enddo

        ifexpon=0
        t1=second()
        do i=1,ntest
           call abram0(ztest(i),jtest2(i),ifexpon)
        enddo
        t2=second()
        call prin2('evaluation time of J_0=*',t2-t1,1)

        t1=second()
        do i=1,ntest
           jtest3(i)=exp(ztest(i))
        enddo
        t2=second()
        write(11,*) jtest3(1)
        call prin2('evaluation time of complex exponentials=*',t2-t1,1)

        dmax=0
        imax=0
        do i=1,ntest
           dd=abs((jtest(i)-jtest2(i))/jtest(i))
           if (dd .gt. 1d-32) then
              print *, dd, ztest(i)
           endif
           if (dmax .lt. dd) then
              dmax=dd
              imax=i
           endif
        enddo

        print *, 'maximum relative error = ', dmax
        print *, 'occured at ', ztest(imax), imax
        print *, 'true value = ', jtest(imax)
        print *, 'computed value = ', jtest2(imax)
        print *, 'done with testing J_0'

cc        ntest=10 000
        OPEN(UNIT=66,FILE="../mathematica/r1test.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) rtest(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/theta1test.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) thetatest(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/j1testr.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) jtestr(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/j1testi.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) jtesti(i)
        enddo
        close(66)

        do i=1,ntest
           ztest(i)=rtest(i)*exp(ima*thetatest(i))
c           ztest(i)=rtest(i)
        enddo

        do i=1,ntest
           jtest(i)=jtestr(i)+ima*jtesti(i)
        enddo

        ifexpon=0
        t1=second()
        do i=1,ntest
           call abram1(ztest(i),jtest2(i),ifexpon)
        enddo
        t2=second()
        call prin2('evaluation time of J_1=*',t2-t1,1)

        t1=second()
        do i=1,ntest
           jtest3(i)=exp(ztest(i))
        enddo
        t2=second()
        write(11,*) jtest3(1)
        call prin2('evaluation time of complex exponentials=*',t2-t1,1)

        dmax=0
        imax=0
        do i=1,ntest
           dd=abs((jtest(i)-jtest2(i))/jtest(i))
           if (dd .gt. 1d-32) then
              print *, dd, ztest(i)
           endif
           if (dmax .lt. dd) then
              dmax=dd
              imax=i
           endif
        enddo

        print *, 'maximum relative error = ', dmax
        print *, 'occured at ', ztest(imax), imax
        print *, 'true value = ', jtest(imax)
        print *, 'computed value = ', jtest2(imax)
        print *, 'done with testing J_1'

cc        ntest=10 000
        OPEN(UNIT=66,FILE="../mathematica/r2test.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) rtest(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/theta2test.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) thetatest(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/j2testr.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) jtestr(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/j2testi.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) jtesti(i)
        enddo
        close(66)

        do i=1,ntest
           ztest(i)=rtest(i)*exp(ima*thetatest(i))
c           ztest(i)=rtest(i)
        enddo

        do i=1,ntest
           jtest(i)=jtestr(i)+ima*jtesti(i)
        enddo

        ifexpon=0
        t1=second()
        do i=1,ntest
           call abram2(ztest(i),jtest2(i),ifexpon)
        enddo
        t2=second()
        call prin2('evaluation time of J_2=*',t2-t1,1)

        t1=second()
        do i=1,ntest
           jtest3(i)=exp(ztest(i))
        enddo
        t2=second()
        write(11,*) jtest3(1)
        call prin2('evaluation time of complex exponentials=*',t2-t1,1)

        dmax=0
        imax=0
        do i=1,ntest
           dd=abs((jtest(i)-jtest2(i))/jtest(i))
           if (dd .gt. 1d-32) then
              print *, dd, ztest(i)
           endif
           if (dmax .lt. dd) then
              dmax=dd
              imax=i
           endif
        enddo

        print *, 'maximum relative error = ', dmax
        print *, 'occured at ', ztest(imax), imax
        print *, 'true value = ', jtest(imax)
        print *, 'computed value = ', jtest2(imax)

        print *, 'done with testing J_2'

        stop
        end


        subroutine idd_random_transf00(x,y,n,albetas,ixs)
        implicit real *8 (a-h,o-z)
        save
        dimension x(*),y(*),albetas(2,*),ixs(*)
c
c       implements one step of the random transform
c       required by routine idd_random_transf0 (please see the latter).
c
c        implement the permutation
c
        do 1600 i=1,n
c
        j=ixs(i)
        y(i)=x(j)
 1600 continue
c
c        implement 2 \times 2 matrices
c
        do 1800 i=1,n-1
c
        alpha=albetas(1,i)
        beta=albetas(2,i)
c
        a=y(i)
        b=y(i+1)
c
        y(i)=alpha*a+beta*b
        y(i+1)=-beta*a+alpha*b
 1800 continue
c
        return
        end
c
c
c
c
c


c subroutine fderiv.f (non-analytical)
c
c source
c   Bevington, page 242.
c
c purpose
c   evaluate derivatives of function for least-squares search
c      for arbitrary function given by functn
c
c usage
c   call fderiv (x, i, a, deltaa, nterms, deriv)
c
c description of parameters
c   x	   - array of data points for independent variable
c   i	   - index of data points
c   a	   - array of parameters
c   deltaa - array of parameter increments
c   nterms - number of parameters
c   deriv  - derivatives of function
c
c subroutines and function subprograms required
c   functn (x, i, a)
c      evaluates the fitting function for the ith term
c
	subroutine fderiv (x,i,a,deltaa,nterms,deriv)
	dimension x(1),a(1),deltaa(1),deriv(1)
        real FUNCTN
        external FUNCTN

11	do 18 j=1,nterms
	aj=a(j)
	delta=deltaa(j)
	a(j)=aj+delta
	yfit=functn(x,i,a)
	a(j)=aj-delta
	deriv(j)=(yfit-functn(x,i,a))/(2.*delta)
18	a(j)=aj
	return
	end


      subroutine sphere_setprob()

      implicit none

      double precision pi, pi2
      common /compi/ pi, pi2

      integer example
      common /example_comm/ example

      integer mapping
      common /mapping_comm/ mapping

      integer initchoice
      common /initchoice_comm/ initchoice

      integer refine_pattern
      common /refine_comm/ refine_pattern

      double precision omega(3)
      common /rotation_comm/ omega

      double precision x0(2), y0(2), z0(2)
      common /qinit_comm/ x0, y0, z0

      pi = 4.d0*atan(1.d0)
      pi2 = 2*pi

      open(10,file='setprob.data')
      read(10,*) example
      read(10,*) mapping
      read(10,*) initchoice
      read(10,*) omega(1)
      read(10,*) omega(2)
      read(10,*) omega(3)
      read(10,*) refine_pattern
      close(10)

c    # Center for two disks
      if (example .eq. 0) then
          x0(1) = 0.866025403784439d0    !! cos(5*pi/6)
          x0(2) = 0.866025403784439d0    !! cos(7*pi/6)
          y0(1) = 0.5
          y0(2) = -0.5
      endif

      end


C$Procedure      PL2PSV ( Plane to point and spanning vectors )

      SUBROUTINE PL2PSV ( PLANE, POINT, SPAN1, SPAN2 )

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

      INTEGER               UBPL
      PARAMETER           ( UBPL   =   4 )

      DOUBLE PRECISION      PLANE ( UBPL )
      DOUBLE PRECISION      POINT (    3 )
      DOUBLE PRECISION      SPAN1 (    3 )
      DOUBLE PRECISION      SPAN2 (    3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     PLANE      I   A SPICELIB plane.
C     POINT,
C     SPAN1,
C     SPAN2      O   A point in the input plane and two vectors
C                    spanning the input plane.
C
C$ Detailed_Input
C
C     PLANE          is a SPICELIB plane that represents the geometric
C                    plane defined by POINT, SPAN1, and SPAN2.
C
C$ Detailed_Output
C
C     POINT,
C     SPAN1,
C     SPAN2          are, respectively, a point and two orthogonal
C                    spanning vectors that generate the geometric plane
C                    represented by PLANE.  The geometric plane is the
C                    set of vectors
C
C                       POINT   +   s * SPAN1   +   t * SPAN2
C
C                    where s and t are real numbers.  POINT is the
C                    closest point in the plane to the origin; this
C                    point is always a multiple of the plane's normal
C                    vector.  SPAN1 and SPAN2 are an orthonormal pair
C                    of vectors.  POINT, SPAN1, and SPAN2 are mutually
C                    orthogonal.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     1)  The input plane MUST have been created by one of the SPICELIB
C         routines
C
C            NVC2PL ( Normal vector and constant to plane )
C            NVP2PL ( Normal vector and point to plane    )
C            PSV2PL ( Point and spanning vectors to plane )
C
C         Otherwise, the results of this routine are unpredictable.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     SPICELIB geometry routines that deal with planes use the `plane'
C     data type to represent input and output planes.  This data type
C     makes the subroutine interfaces simpler and more uniform.
C
C     The SPICELIB routines that produce SPICELIB planes from data that
C     define a plane are:
C
C        NVC2PL ( Normal vector and constant to plane )
C        NVP2PL ( Normal vector and point to plane    )
C        PSV2PL ( Point and spanning vectors to plane )
C
C     The SPICELIB routines that convert SPICELIB planes to data that
C     define a plane are:
C
C        PL2NVC ( Plane to normal vector and constant )
C        PL2NVP ( Plane to normal vector and point    )
C        PL2PSV ( Plane to point and spanning vectors )
C
C$ Examples
C
C     1)  Project a vector V orthogonally onto a plane defined by
C         POINT, SPAN1, and SPAN2.  PROJ is the projection we want; it
C         is the closest vector in the plane to V.
C
C            CALL PSV2PL ( POINT,   SPAN1,    SPAN2,   PLANE )
C            CALL VPRJP  ( V,       PLANE,    PROJ           )
C
C
C     2)  Find the intersection of a plane and the unit sphere.  This
C         is a geometry problem that arises in computing the
C         intersection of a plane and a triaxial ellipsoid.  The
C         SPICELIB routine INEDPL computes this intersection, but this
C         example does illustrate how to use this routine.
C
C
C            C
C            C     The geometric plane of interest will be represented
C            C     by the SPICELIB plane PLANE in this example.
C            C
C            C     The intersection circle will be represented by the
C            C     vectors CENTER, V1, and V2; the circle is the set
C            C     of points
C            C
C            C        CENTER  +  cos(theta) V1  +  sin(theta) V2,
C            C
C            C     where theta is in the interval (-pi, pi].
C            C
C            C     The logical variable FOUND indicates whether the
C            C     intersection is non-empty.
C            C
C
C            C
C            C     The center of the intersection circle will be the
C            C     closest point in the plane to the origin.  This
C            C     point is returned by PL2PSV.  The distance of the
C            C     center from the origin is the norm of CENTER.
C            C
C                  CALL PL2PSV  ( PLANE, CENTER, SPAN1, SPAN2 )
C
C                  DIST = VNORM ( CENTER )
C
C            C
C            C     The radius of the intersection circle will be
C            C
C            C             ____________
C            C         _  /          2
C            C          \/  1 - DIST
C            C
C            C     since the radius of the circle, the distance of the
C            C     plane from the origin, and the radius of the sphere
C            C     (1) are the lengths of the sides of a right triangle.
C            C
C                  RADIUS = SQRT ( 1.0D0 - DIST**2 )
C
C                  CALL VSCL  ( RADIUS, SPAN1, V1 )
C                  CALL VSCL  ( RADIUS, SPAN2, V2 )
C
C                  FOUND = .TRUE.
C
C
C     3)  Apply a linear transformation represented by the matrix M to
C         a plane represented by the normal vector N and the constant C.
C         Find a normal vector and constant for the transformed plane.
C
C            C
C            C     Make a SPICELIB plane from N and C, and then find a
C            C     point in the plane and spanning vectors for the
C            C     plane.  N need not be a unit vector.
C            C
C                  CALL NVC2PL ( N,      C,      PLANE         )
C                  CALL PL2PSV ( PLANE,  POINT,  SPAN1,  SPAN2 )
C
C            C
C            C     Apply the linear transformation to the point and
C            C     spanning vectors.  All we need to do is multiply
C            C     these vectors by M, since for any linear
C            C     transformation T,
C            C
C            C           T ( POINT  +  t1 * SPAN1     +  t2 * SPAN2 )
C            C
C            C        =  T (POINT)  +  t1 * T(SPAN1)  +  t2 * T(SPAN2),
C            C
C            C     which means that T(POINT), T(SPAN1), and T(SPAN2)
C            C     are a point and spanning vectors for the transformed
C            C     plane.
C            C
C                  CALL MXV ( M, POINT, TPOINT )
C                  CALL MXV ( M, SPAN1, TSPAN1 )
C                  CALL MXV ( M, SPAN2, TSPAN2 )
C
C            C
C            C     Make a new SPICELIB plane TPLANE from the
C            C     transformed point and spanning vectors, and find a
C            C     unit normal and constant for this new plane.
C            C
C                  CALL PSV2PL ( TPOINT,  TSPAN1,  TSPAN2,  TPLANE )
C                  CALL PL2NVC ( TPLANE,  TN,      TC              )
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     [1] `Calculus and Analytic Geometry', Thomas and Finney.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 01-NOV-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     plane to point and spanning vectors
C
C-&

C
C     Local parameters
C

C
C     The contents of SPICELIB planes are as follows:
C
C        Elements NMLPOS through NMLPOS + 2 contain a unit normal
C        vector for the plane.
C
C        Element CONPOS contains a constant for the plane;  every point
C        X in the plane satisifies
C
C           < X, PLANE(NMLPOS) >  =  PLANE(CONPOS).
C
C        The plane constant is the distance of the plane from the
C        origin; the normal vector, scaled by the constant, is the
C        closest point in the plane to the origin.
C
C
      INTEGER               NMLPOS
      PARAMETER           ( NMLPOS = 1 )

      INTEGER               CONPOS
      PARAMETER           ( CONPOS = 4 )

C
C     Local variables
C
      DOUBLE PRECISION      NORMAL ( 3 )

C
C     Find a unit normal vector for the plane, and find the closest
C     point in the plane to the origin.
C
      CALL PL2NVP ( PLANE, NORMAL, POINT )

C
C     Next, find an orthogonal pair of vectors that are also
C     orthogonal to the PLANE's normal vector.  The SPICELIB routine
C     FRAME does this for us.  NORMAL, SPAN1, and SPAN2 form a
C     right-handed orthonormal system upon output from FRAME.
C
      CALL FRAME  ( NORMAL, SPAN1, SPAN2 )

      RETURN
      END


	subroutine jul2dy(lyr,idyjl,imon,idy)

	INTEGER totday(0:12),mnth(365),totdayly(0:12),mnthly(366)
	data totday/0,31,59,90,120,151,181,212,243,273,304,334,365/
	data totdayly/0,31,60,91,121,152,182,213,244,274,305,335,366/
	mnth=(/(1,i=1,31),(2,i=1,28),(3,i=1,31),(4,i=1,30),(5,i=1,31),(6,i=1,30),
	1	(7,i=1,31),(8,i=1,31),(9,i=1,30),(10,i=1,31),(11,i=1,30),(12,i=1,31)/)
	mnthly=(/(1,i=1,31),(2,i=1,29),(3,i=1,31),(4,i=1,30),(5,i=1,31),(6,i=1,30),
	1	(7,i=1,31),(8,i=1,31),(9,i=1,30),(10,i=1,31),(11,i=1,30),(12,i=1,31)/)

	if(nint(lyr/4.)*4==lyr) then
		imon=mnthly(idyjl)
		idy=idyjl-totdayly(imon-1)
	else
		imon=mnth(idyjl)
		idy=idyjl-totday(imon-1)
	endif

	return
	end

	subroutine dy2jul(lyr,idyjl,imon,idy)

	INTEGER totday(0:12),totdayly(0:12)
	data totday/0,31,59,90,120,151,181,212,243,273,304,334,365/
	data totdayly/0,31,60,91,121,152,182,213,244,274,305,335,366/

	if(nint(lyr/4.)*4==lyr) then
		idyjl=totdayly(imon-1)+idy
	else
		idyjl=totday(imon-1)+idy
	endif

	return
	end

	real function dyinyr(lyr)
	dyinyr=365
	if(nint(lyr/4.)*4==lyr) dyinyr=366
	return
	end

	subroutine day_increment(lyr,idyjl,increment,iyr,idy)

	idy=idyjl+increment;
	iyr=lyr;
	if(idy<1) then
		iyr=iyr-1;idy=idy+dyinyr(iyr)
	endif
	if(idy>dyinyr(iyr)) then
		idy=idy-dyinyr(iyr);iyr=iyr+1;
	endif

	end subroutine

	subroutine get_name_mon(imon,amon)
	integer imon
	character*3 amon

	if(imon==1) amon='JAN'
	if(imon==2) amon='FEB'
	if(imon==3) amon='MAR'
	if(imon==4) amon='APR'
	if(imon==5) amon='MAY'
	if(imon==6) amon='JUN'
	if(imon==7) amon='JUL'
	if(imon==8) amon='AUG'
	if(imon==9) amon='SEP'
	if(imon==10) amon='OCT'
	if(imon==11) amon='NOV'
	if(imon==12) amon='DEC'

	end subroutine


      SUBROUTINE  ZFFT(JN,NTSK,IND,IS)
      IMPLICIT    REAL*8(A-H,O-Z)
      PARAMETER   (IX= 64,IY= 64,IZ= 64 ,M1=6)

      PARAMETER   (IXPP=IX+2,IXHP=IX/2+1,ITOT=IXPP*IY*IZ,
     +          IXY=IXHP*IY,IXZ=IXHP*IZ,IYZ=IY*IZ)
      COMMON/ALL/ U(IXPP,IY,IZ)
      COMMON /DIM/ NX,NY,NZ,NXPP,NXHP,NTOT,NXY,NXZ,NYZ
      REAL*8      AUX1(4*IX),AUX2(2*IX)
      CALL DCFT(M1,U(1,JN,1),NXY,1,U(1,JN,1),NXY,1,NZ, NXHP,1,SZ,
     +     AUX1,AUX2,JN)
      RETURN
      END
C
      SUBROUTINE  XYFFT(KN,NTSK,IND,IS)

      IMPLICIT    REAL*8(A-H,O-Z)
      PARAMETER   (IX= 64,IY= 64,IZ= 64 ,M1=6)

      PARAMETER   (IXPP=IX+2,IXHP=IX/2+1,ITOT=IXPP*IY*IZ,
     +          IXY=IXHP*IY,IXZ=IXHP*IZ,IYZ=IY*IZ)
      COMMON/ALL/ U(IXPP,IY,IZ)
      COMMON /DIM/ NX,NY,NZ,NXPP,NXHP,NTOT,NXY,NXZ,NYZ
      REAL*8      AUX1(4*IX),AUX2(2*IX)
      CALL DCFT(M1,U(1,1,KN),NXHP,1,U(1,1,KN),NXHP,1,NY,NXHP,1,SY,
     +     AUX1,AUX2,KN)
      RETURN
      END

      SUBROUTINE DCFT( M1, X, INC1X, INC2X, Y, INC1Y, INC2Y, N, M,
     &   ISIGN, SCALE, RA, AUX,NQ)

      IMPLICIT REAL*8(A-H,O-Z)
      REAL*8 X(*),Y(10),RA(4*N),AUX(2*N)
C          CALL CFFT(0,M1,AUX,RA,RA(2*N+1),NQ)
        DO 10 I=1,M
          IBR = (I-1)*INC2X*2 + 1
          IBC = (I-1)*INC2X*2 + 2
          DO 20 II=1,N
            INDR = IBR + (II-1)*2*INC1X
            INDC = IBC + (II-1)*2*INC1X
            RA(II) = X(INDR)
            RA(II+N) = X(INDC)
20        CONTINUE
C          CALL CFFT(ISIGN,M1,AUX,RA,RA(2*N+1),NQ)
          DO 30 II=1,N
            INDR = IBR + (II-1)*2*INC1X
            INDC = IBC + (II-1)*2*INC1X
             Y(INDR) = SCALE*RA(II)
             Y(INDC) = SCALE*RA(II+N)
30         CONTINUE
10     CONTINUE
      RETURN
      END


program stretch
   use constants
   use io
   use rationals
   use riff
   implicit none

   integer :: t, t0
   real(dp) :: t1, dt, scaling, factor
   type(audio) :: s0, s

   factor = rational(command_argument(1, '-1'))

   call read_riff(command_argument(2, '/dev/stdin'), s0)

   s%channels  = s0%channels
   s%points    = nint(abs(factor) * s0%points)
   s%rate      = s0%rate
   s%amplitude = s0%amplitude

   if (s%points .eq. s0%points) then
      s%sound = s0%sound
   else
      allocate(s%sound(s0%channels, s%points))

      scaling = real(s0%points - 1, dp) / real(max(s%points, 2) - 1, dp)

      do t = 0, s%points - 1
         t1 = 1 + scaling * t
         t0 = floor(t1)
         dt = t1 - t0
         s%sound(:, 1 + t) = nint(s0%sound(:, t0) * (1 - dt) &
            + s0%sound(:, t0 + 1) * dt, i2)
      end do
   end if

   if (factor .lt. 0.0_dp) s%sound(:, :) = s%sound(:, s%points:1:-1)

   call write_riff(command_argument(3, '/dev/stdout'), s)
end program stretch


      subroutine vgcap_ek	( sl, slr, smr,alpha, beta,smcut,
     2     sucut,hp, dhp)
!***********************************************************************
! Copyright 2011 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************

! this calculates capillary pressure (hp) as a function of liquid saturation (sl)
! slr = minimum residual saturation
! smr = maximum residual saturation
! alpha is 1/m (inverse air entry pressure) = Pa/(density*g)
! beta is 'm' in VG 1980 paper and 'n' in FEHM MMS description
! smcut, sucut are limits of the function -  if sl< smcut or sl > sucut,
! linear interpolation is used.
! subroutine returns hp (capillary pressure) and dhp (dhp/dsl)
!
      implicit none
      integer ireg
      real*8 sl
      real*8 slr
      real*8 smr
      real*8 alpha
      real*8 beta
      real*8 smcut
      real*8 sucut
      real*8 hp
      real*8 dhp,star2,hp_cut
      real*8 lambda
      real*8 ds
      real*8 denom
      real*8 star

      lambda = 1.0-1.0/beta
      denom = smr-slr
      ds = 1.0/denom
      if(sl.gt.smcut.and.sl.lt.sucut) then
      	 star=(sl-slr)/denom
      	 call cc(star,lambda,alpha,denom,hp,dhp)
      elseif(sl.le.smcut)  then
         star=(smcut-slr)/denom

       	 call cc(star,lambda,alpha,denom,hp_cut,dhp)
         dhp=hp_cut/smcut
         hp=hp_cut+(smcut-sl)*dhp
         dhp=-1.*dhp
      else

         star =(sucut-slr)/denom
         call cc(star,lambda,alpha,denom,hp_cut,dhp)
         dhp=hp_cut/(1.d0-sucut)
         hp=hp_cut-(sl-sucut)*dhp
         dhp=-1.*dhp
      endif
!      write(*,*) 'line 63 ',sl,slr,smr,alpha,beta,hp

      return
      end
      subroutine cc(star,lambda,alpha,denom,hp,dhp)
      implicit none
      real*8 star,lambda,alpha,denom,hp,chp,termstar1,termstar2,termb1
      real*8 termb2,dhp
         termstar1 = star**(1./lambda)
         termstar2 = star*termstar1
         termb1 = 1./termstar1 - 1.
         termb2 = termb1**(-lambda)
         hp = 1./alpha * termb1*termb2
         dhp = (1.-lambda)/alpha * termb2 / (-1.*termstar2*lambda*denom)
         return
         end


      module weighted_normal_func_m
c
c------------------------------------------------------------------------------
c  calculating the weighted normal at quadrature points
c------------------------------------------------------------------------------
        implicit none
c
c
      contains
        subroutine get_weighted_normal(nv, w_normal, shp, nshl)
c-------------------------------------------------------------------------------
          use e3if_func_m, only:sum_qpt
          use propar_m, only: npro
          use global_const_m, only: nsd
          implicit none
c
          real*8, dimension(npro,nsd),intent(inout) :: nv
          real*8, dimension(npro,nshl,nsd),intent(in) :: w_normal
          real*8, dimension(npro,nshl), intent(in) :: shp
          integer, intent(in) :: nshl
c
          real*8, dimension(npro,nsd) :: w_n_qpt
          real*8, dimension(npro) :: temp_len
          integer :: iel

c
c... get the weighted normal at qudrature points
          do iel = 1,npro
            w_n_qpt(iel,1) = sum_qpt(nshl,w_normal(iel,:,1),shp(iel,:))
            w_n_qpt(iel,2) = sum_qpt(nshl,w_normal(iel,:,2),shp(iel,:))
            w_n_qpt(iel,3) = sum_qpt(nshl,w_normal(iel,:,3),shp(iel,:))

c... get the length of weighted normal at qudrature points
            temp_len(iel) = sqrt(w_n_qpt(iel,1)*w_n_qpt(iel,1)
     &                    + w_n_qpt(iel,2)*w_n_qpt(iel,2)
     &                    + w_n_qpt(iel,3)*w_n_qpt(iel,3))
c... normalization of the weighted normal
            nv(iel,1)  = w_n_qpt(iel,1) / temp_len(iel)
            nv(iel,2)  = w_n_qpt(iel,2) / temp_len(iel)
            nv(iel,3)  = w_n_qpt(iel,3) / temp_len(iel)
          enddo
c
        end subroutine get_weighted_normal
      end module weighted_normal_func_m


!***********************************************************************
!                                                                      *
      REAL(KIND(0.0D0)) FUNCTION FUNL (X, K)
!                                                                      *
!   This  function  evaluates the LK(X) functions using the analytic   *
!   functions defined  in table 5  and equations  (20) and  (21)  of   *
!   Fullerton and Rinker.                                              *
!                                                                      *
!                                           Last update: 09 Oct 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:04:58   1/ 3/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN) :: K
      REAL(DOUBLE), INTENT(IN) :: X
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: K1, I
      REAL(DOUBLE), DIMENSION(6,2) :: F
      REAL(DOUBLE), DIMENSION(3,2) :: G
      REAL(DOUBLE), DIMENSION(2,2) :: H
      REAL(DOUBLE) :: A, B, SUM, XN, X2, SUMG, SUMH, XM
!-----------------------------------------------
!
!
      DATA F/ 2.008188D00, -2.397605D00, 1.046471D00, -3.670660D-01, &
         6.374000D-02, -3.705800D-02, 1.646407D00, -2.092942D00, 9.623100D-01, &
         -2.549600D-01, 1.644040D-01, 0.0D00/
!
      DATA G/ 7.51198D-01, 1.38889D-01, 2.0886D-02, 1.37691D-01, -4.16667D-01, &
          - 9.7486D-02/
!
      DATA H/ -4.44444D-01, -3.472D-03, 4.44444D-01, 1.7361D-02/
!
      DATA A, B/ 2.2D00,  - 1.72D00/
!
      IF (K>=0 .AND. K<=1) THEN
         IF (X <= 2.0D00) THEN
            IF (X == 0.0D00) GO TO 6
!
!   Use rational approximation for X < 2
!
            K1 = K + 1
            SUM = 0.0D00
            XN = 1.0D00
            DO I = 1, 6
               SUM = SUM + XN*F(I,K1)
               XN = XN*X
            END DO
            X2 = X*X
            SUMG = G(1,K1) + X2*(G(2,K1)+X2*G(3,K1))
            SUMH = H(1,K1) + X2*X2*H(2,K1)
            XN = DLOG(X)
            SUMG = XN*(SUMG + XN*SUMH)
            IF (K /= 0) THEN
               SUM = SUM + SUMG
               GO TO 7
            ENDIF
            SUM = SUM + X*SUMG
            GO TO 7
         ENDIF
!
         SUM = A + B/X
         IF (K /= 0) SUM = SUM + (SUM + B/X)/X
         SUM = SUM/X
         XM = -X
         SUM = SUM*DEXP(XM)
         GO TO 7
    6    CONTINUE
         IF (K == 1) GO TO 98
         SUM = F(1,1)
    7    CONTINUE
         FUNL = SUM
         RETURN
!
!   Error section
!
   98    CONTINUE
         WRITE (*, 302)
         STOP
      ENDIF
      WRITE (*, 301)
      STOP
!
  301 FORMAT(/,'FUNL: K must be either 0 or 1')
  302 FORMAT(/,'FUNL: Attempt to calculate function for'/,&
         ' zero argument and K value of 1')
      RETURN
!
      END FUNCTION FUNL