      subroutine fracdf( x, n, M, nar, nma, dtol, drange, h, hood, d,
     *                   ar, ma, cov, lcov, stderr, cor, lcor,
     *                   hess, lhess, w, lenw, iprint)

      implicit double precision (a-h,o-z)

      logical DEBUG
      parameter (DEBUG=.false.)

      integer            n, M, nar, nma, lcov, lcor, lenw
c     real               x(n)
c      real               x(*)
      real   x(*)
c     double precision   drange(2), ar(nar), ma(nma), stderr(nar+nma+1)
      double precision   drange(2), ar(*), ma(*), stderr(*)
c     double precision   cov(lcov,nar+nma+1), cor(lcor,nar+nma+1)
      double precision   cov(lcov,*), cor(lcor,*), hess(lhess,*)
      double precision   d, dtol, h, hood
c     double precision   w(lenw)
      double precision   w(*)
      integer            iprint

c------------------------------------------------------------------------------
c
c       Calculates the maximum likelihood estimators of the parameters
c       of a fractionally-differenced ARIMA (p,d,q) model, together
c       with their estimated covariance and correlation matrices and
c       standard errors, as well as the value of the maximized likelihood.
c       The fast approximate algorithm of Haslett and Raftery (1989) is used.
c
c       The optimization is carried out in two levels : an outer univariate
c       unimodal optimization with respect to d over the interval [0,.5]
c       (uses Brent's fmin algorithm), and an inner nonlinear least-squares
c       optimization with respect to the AR and MA parameters to minimize
c       white noise variance (uses the MINPACK subroutine LMDER).
c
c REFERENCES :
c
c    J. Haslett and A. E. Raftery,
c        Space-time modeling with  Long-Memory Dependence :
c           Assessing Ireland's Wind Power Resource,
c             Applied Statistics 38 (1989) 1-50.
c
c    R. Brent, Algorithms for Minimization without Derivatives,
c        Prentice-Hall (1973).
c
c    J. J. More, B. S. Garbow, and K. E. Hillstrom,
c        User's Guide for MINPACK-1, Technical Report ANL-80-74,
c        Applied Mathematics Division, Argonne National Laboratory,
c       (August 1980).
c
c   Input :
c
c  x       real     time series for the ARIMA model
c  n       integer  length of the time series
c  M       integer  number of terms in the likelihood approximation
c                   suggested value 100 (see Haslett and Raftery 1989)
c  nar     integer  number of autoregressive parameters
c  nma     integer  number of moving average parameters
c  lcov    integer  row dimension of an array for the covariance matrix
c                   must be as declared in the callng program
c                  (at least nar+nma+1)
c  lcor    integer  row dimension of an array for the correlation matrix
c                   must be as declared in the callng program
c                  (at least nar+nma+1)
c  dtol    double   desired length of final interval of uncertainty for
c                   suggested value : 4th root of machine precision
c                   if dtol < 0 it is automatically set to this value
c                   dtol will be altered if necessary by the program
c  drange  double   array of length 2 giving mimimum and maximum values
c                   for the fractional differencing parameter
c  h       double   finite-difference interval for estimating derivatives
c                   with respect to d. If h < 0 it is automatically reset.
c  d       double   initial guess for optimal fractional differencing parameter
c  ar      double   initial autoregressive parameter estimates
c  ma      double   initial moving average parameter estimates
c  w       double   work array
c  lenw    integer  length of double precision workspace w, must be at least
c max(nar+nma+2*(n+M),3*n+(n+6.5)*(nar+nma)+1,(3+2*(nar+nma+1))*(nar+nma+1)+1)
c  iprint  integer  <= 0 no printing
c                   >  0 intermediate results printed
c
c  Output :
c
c  dtol    double   value of dtol ultimately used by the algorithm
c  h       double   value of h ultimately used by the algorithm
c  d       double   optimal fractional differencing parameter
c  hood    double   logarithm of the maximum likelihood
c  ar      double   optimal autoregressive parameter estimates
c  ma      double   optimal moving average parameter estimates
c  cov     double   covariance matrix of the parameter estimates (d,p,q)
c  stderr  double   standard errors of the parameter estimates (d,p,q)
c  cor     double   correlation matrix of the parameter estimates (d,p,q)
c  hess    double   hessian matrix of the parameter estimates (d,p,q)
c
c------------------------------------------------------------------------------

      double precision   dlamch, dopt

      double precision   BASE
      double precision   FLTMIN, FLTMAX, EPSMIN, EPSMAX
      common /MACHFD/    FLTMIN, FLTMAX, EPSMIN, EPSMAX
      save   /MACHFD/

      double precision   EPSP25, EPSPT3, EPSPT5, EPSP75, BIGNUM
      common /MAUXFD/    EPSP25, EPSPT3, EPSPT5, EPSP75, BIGNUM
      save   /MAUXFD/

      integer            nn, MM, np, nq, npq, npq1, maxpq, maxpq1, nm
      common /DIMSFD/    nn, MM, np, nq, npq, npq1, maxpq, maxpq1, nm
      save   /DIMSFD/

      integer            maxopt, maxfun, nopt, nfun, ngrd,
     *                   ifun, igrd, info
      common /CNTRFD/    maxopt, maxfun, nopt, nfun, ngrd,
     *                   ifun, igrd, info
      save   /CNTRFD/

      double precision   told, tolf, tolx, tolg, anorm, deltax, gnorm
      common /TOLSFD/    told, tolf, tolx, tolg, anorm, deltax, gnorm
      save   /TOLSFD/

      integer            lenthw, lwfree
      common /WORKFD/    lenthw, lwfree
      save   /WORKFD/

      integer            ly, lamk, lak, lvk, lphi, lpi
      common /WFILFD/    ly, lamk, lak, lvk, lphi, lpi
      save   /WFILFD/

      integer            lqp, la, lajac, ipvt, ldiag, lqtf,
     *                   lwa1, lwa2, lwa3, lwa4
      common /WOPTFD/    lqp, la, lajac, ipvt, ldiag, lqtf,
     *                   lwa1, lwa2, lwa3, lwa4
      save   /WOPTFD/

      integer            ILIMIT, JLIMIT
      common /LIMSFD/    ILIMIT, JLIMIT
      save   /LIMSFD/

      integer            IGAMMA, JGAMMA
      common /GAMMFD/    IGAMMA, JGAMMA
      save   /GAMMFD/

      integer            IMINPK, JMINPK
      common /MNPKFD/    IMINPK, JMINPK
      save   /MNPKFD/

      integer            KSVD, KCOV, KCOR
      common /HESSFD/    KSVD, KCOV, KCOR
      save   /HESSFD/

      double precision   zero, one
      parameter         (zero=0.d0, one=1.d0)

      data               ncalls /0/

C      if (DEBUG) then
C         print *,"On Entry to fracdf():"
C         print *,"x(1)=",x(1)
C         print *,"n=",n
C         print *,"M=",M
C         print *,"nar=",nar
C         print *,"nma=",nma
C         print *,"dtol=",dtol
C         print *,"drange=",drange
C         print *,"h=",h
C         print *,"hood=", hood
C         print *,"d=",d
C         print *,"ar=",ar
C         print *,"ma=",ma
C         print *,"cov=",cov
C         print *,"lcov=",lcov
C         print *,"stderr=",stderr
C         print *,"cor=",cor
C         print *,"lcor=",lcor
C         print *,"hess=",hess
C         print *,"lhess=",lhess
C         print *,"w(1)=",w(1)
C         print *,"lenw=",lenw
C         print *,"iprint=",iprint
C      endif

c copyright 1991 Department of Statistics, University of Washington
c written by Chris Fraley

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

      if (ncalls .eq. 0) then

c machine constants

        FLTMIN = dlamch( 'S' )
C       FLTMAX = dlamch( 'O' )  not guaranteed to work
        FLTMAX = one/FLTMIN

        BASE   = dlamch( 'B' )
        EPSMIN = dlamch( 'E' )
        EPSMAX = EPSMIN*BASE
        EPSPT5 = sqrt(EPSMIN)
        EPSP25 = sqrt(EPSPT5)
        EPSPT3 = EPSMIN**(.3)
        EPSP75 = EPSMIN**(.75)
        BIGNUM = one / EPSMIN
        ncalls = 1
      endif

c set error and warning flags
      ILIMIT = 0
      JLIMIT = 0

      IGAMMA = 0
      JGAMMA = 0

      IMINPK = 0
      JMINPK = 0

      KSVD   = 0
      KCOV   = 0
      KCOR   = 0

c useful quantities

      if (M .le. 0) M = 100

      nn    = n
      MM    = M
      np    = nar
      nq    = nma

      npq    = np + nq
      npq1   = npq + 1
      maxpq  = max(np,nq)
      minpq  = min(np,nq)
      maxpq1 = maxpq + 1

      maxopt = 100
      maxfun = 100

      if (dtol .gt. .1d0)  dtol = .1d0

      if (dtol .le. zero) then
        told  =  EPSP25
        tolf  =  EPSPT3
        tolx  =  told
        tolg  =  EPSPT3
      else
        told  =  max( dtol, EPSPT5)
        tolf  =  max( dtol/1.d1, EPSP75)
        tolx  =  told
        tolg  =  max( dtol/1.d1, EPSP75)
      end if

      dtol   = told

      nm     = n - maxpq

c workspace allocation

      lqp    = 1
      ly     = lqp    +  npq
      lamk   = ly
      lak    = lamk   +  n
      lphi   = lak    +  n
      lvk    = lphi   +  M
      lpi    = lphi
      la     = ly     +  n
      lajac  = la     +  n - minpq
      ipvt   = lajac  +  max( (n-np)*np, (n-nq)*nq, (n-maxpq)*npq)
      ldiag  = ipvt   +  npq/2 + 1
      lqtf   = ldiag  +  npq
      lwa1   = lqtf   +  npq
      lwa2   = lwa1   +  npq
      lwa3   = lwa2   +  npq
      lwa4   = lwa3   +  npq
      lfree  = lwa4   +  n - minpq

      lwfree = max( (lvk+M), (lwa4+n-minpq), (12*31))
      lenthw = lenw

      if (lwfree  .gt. (lenw+1)) then
        ILIMIT = lwfree - lenw
c       write( 6, *) 'insufficient storage : ',
c    *               'increase length of w by at least', incw
        return
      endif

c     call dcopy( npq, zero, 0, w(lqp), 1)

      if (npq .ne. 0) then
        call dcopy( np, ar, 1, w(lqp+nq), 1)
        call dcopy( nq, ma, 1, w(lqp)   , 1)
      end if

      nopt = 0
      nfun = 0
      ngrd = 0

      if (iprint .gt. 0) then
        write(6,*)
        write(6,900)
      end if

      d = dopt( x, d, drange, hood, delta, w, iprint)

      if (nopt .ge. maxopt) JLIMIT = 1
c       write( 6, *)
c       write( 6, *) 'WARNING : optimization limit reached'
c     end if

      if (IGAMMA .ne. 0 .or. IMINPK .ne. 0) then
        d    = FLTMAX
        hood = FLTMAX
        call dcopy( np, FLTMAX, 0, ar, 1)
        call dcopy( nq, FLTMAX, 0, ma, 1)
        call dcopy( npq1, FLTMAX, 0, stderr, 1)
        do j = 1, npq1
          call dcopy( npq1, FLTMAX, 0, cov( 1, j), 1)
          call dcopy( npq1, FLTMAX, 0, cor( 1, j), 1)
        end do
        return
      end if

      call dcopy( np, w(lqp+nq), 1, ar, 1)
      call dcopy( nq, w(lqp   ), 1, ma, 1)

      call fdhpq( x, hess, lhess, w)

      if (npq .gt. 0) then
        do i = 2, npq1
         call dcopy( npq, hess(2,i), 1, cov(2,i), 1)
        end do

        call fdcov( x, d, h, hess, cov, lcov, cor, lcor, stderr, w)

      end if

      if (iprint.gt.0) then
         call fdout ( d, ar, ma, dtol, drange, h, hood,
     *        cov, lcov, stderr, cor, lcor)
      end if

C      if (DEBUG) then
C         print *,"On Exit from fracdf():"
C         print *,"x(1)=",x
C         print *,"n=",n
C         print *,"M=",M
C         print *,"nar=",nar
C         print *,"nma=",nma
C         print *,"dtol=",dtol
C         print *,"drange(1)=",drange(1)
C         print *,"h="
C         print *,"hood=", hood
C         print *,"d=",d
C         print *,"ar(1)=",ar(1)
C         print *,"ma(1)=",ma(1)
C         print *,"cov(1,1)=",cov(1,1)
C         print *,"lcov=",lcov
C         print *,"stderr(1)=",stderr
C         print *,"cor(1,1)=",cor(1,1)
C         print *,"lcor=",lcor
C         print *,"hess(1,1)=",hess
C         print *,"lhess=",lhess
C         print *,"w(1)=",w(1)
C         print *,"lenw=",lenw
C         print *,"iprint=",iprint
C      endif

      return
 900  format( 4h itr, 14h     d          ,   14h    est mean  ,
     *                16h     white noise,  17h     log likelihd,
     *                 4h  nf, 3h ng)
      end

*******************************************************************************
*******************************************************************************

      double precision function dopt( x, dinit, drange, hood, delta, w,
     *                                iprint)

      implicit double precision (a-h,o-z)

      integer           iprint

c     real              x(n)
      real              x(*)

      double precision  dinit, drange(2), hood, delta
      double precision  w(*)
c
c optimization with repsect to d based on Brent's fmin algorithm
c
      double precision  pqopt
      double precision  dd, ee, hh, rr, ss, tt
      double precision  uu, vv, ww, fu, fv, fw
      double precision  eps, tol1, tol2, tol3

      intrinsic         abs, sqrt

      double precision  cc
      data              cc /.38196601125011d0/

      double precision  zero, half, one, two, three
      parameter        (zero=0.d0, half=.5d0, one=1.d0,
     *                   two=2.d0, three=3.d0)

      integer           maxopt, maxfun, nopt, nfun, ngrd,
     *                  ifun, igrd, info
      common /CNTRFD/   maxopt, maxfun, nopt, nfun, ngrd,
     *                  ifun, igrd, info
      save   /CNTRFD/

      integer            n, M, np, nq, npq, npq1, maxpq, maxpq1, nm
      common /DIMSFD/    n, M, np, nq, npq, npq1, maxpq, maxpq1, nm
      save   /DIMSFD/

      double precision   aa, xx, bb, fa, fx, fb
      save               aa, xx, bb, fa, fx, fb

      integer            lqp, la, lajac, ipvt, ldiag, lqtf,
     *                   lwa1, lwa2, lwa3, lwa4
      common /WOPTFD/    lqp, la, lajac, ipvt, ldiag, lqtf,
     *                   lwa1, lwa2, lwa3, lwa4
      save   /WOPTFD/

      double precision   hatmu, wnv, cllf
      common /FILTFD/    hatmu, wnv, cllf
      save   /FILTFD/

      double precision   dtol, ftol, xtol, gtol, anorm, deltax, gnorm
      common /TOLSFD/    dtol, ftol, xtol, gtol, anorm, deltax, gnorm
      save   /TOLSFD/

      double precision   FLTMIN, FLTMAX, EPSMIN, EPSMAX
      common /MACHFD/    FLTMIN, FLTMAX, EPSMIN, EPSMAX
      save   /MACHFD/

      integer            IGAMMA, JGAMMA
      common /GAMMFD/    IGAMMA, JGAMMA
      save   /GAMMFD/

      integer            IMINPK, JMINPK
      common /MNPKFD/    IMINPK, JMINPK
      save   /MNPKFD/

c copyright 1991 Department of Statistics, University of Washington
c written by Chris Fraley

c------------------------------------------------------------------------------
c
c  cc is the squared inverse of the golden ratio (see data statement)
c
c     cc = half*(three-sqrt(5.0d0))
c
c  eps is approximately the square root of the relative machine
c  precision.
c
      eps  =  EPSMAX
      tol1 =  one + eps
      eps  =  sqrt(eps)
c
      aa   =  drange(1)
      bb   =  drange(2)
      if (dinit .gt. (aa + dtol) .and. dinit .lt. (bb - dtol)) then
        vv = dinit
      else
        vv = aa + cc*(bb-aa)
      end if
      ww   =  vv
      xx   =  vv
      uu   =  xx
      ee   =  zero

      nopt = 1

      fx   =  pqopt( x, xx, w)

      fv   =  fx
      fw   =  fx

      tol  = max(dtol,zero)
      tol3 = tol/three
c
c  main loop starts here
c
   10 continue

      if (iprint .gt. 0) write(6,900)  nopt, uu, hatmu, wnv, cllf,
     *                                 ifun, igrd

      if (IGAMMA .ne. 0 .or. IMINPK .ne. 0) then
        d    = uu
        hood = FLTMAX
        return
      end if

      hh   =  half*(aa+bb)
      tol1 =  eps*(one+abs(xx)) + tol3
      tol2 =  two*tol1
c
c  check stopping criterion
c
      delta = abs(xx-hh) + half*(bb-aa)
c     if (abs(xx-hh) .le. (tol2-half*(bb-aa))) go to 100
      if (delta .le. tol2) go to 100

      if (nopt .ge. maxopt) go to 100

c     if (delpq .le. EPSMAX*(one+pqnorm)) go to 100

      rr   =  zero
      ss   =  zero
      tt   =  zero

      if (abs(ee) .gt. tol1) then
c
c  fit parabola
c
        rr   = (xx-ww)*(fx-fv)
        ss   = (xx-vv)*(fx-fw)
        tt   = (xx-vv)*ss-(xx-ww)*rr
        ss   =  two*(ss-rr)
        if (ss .le. zero) then
          ss = -ss
        else
          tt = -tt
        end if
        rr   =  ee
        ee   =  dd
      end if

      if ((abs(tt) .ge. abs(half*ss*rr)) .or.
     *   (tt .le. ss*(aa-xx)) .or. (tt .ge. ss*(bb-xx))) then
c
c  a golden-section step
c
        if (xx .ge. hh) then
          ee = aa - xx
        else
          ee = bb - xx
        end if
        dd   =  cc*ee

      else
c
c  a parabolic-interpolation step
c
        dd   =  tt / ss
        uu   =  xx + dd
c
c  f must not be evaluated too close to aa or bb
c
        if (((uu-aa) .lt. tol2) .or. ((bb-uu) .lt. tol2)) then
          dd  =  tol1
          if (xx .ge. hh) dd = -dd
        end if
      end if
c
c  f must not be evaluated too close to xx
c
      if (abs(dd) .ge. tol1)  then
        uu = xx + dd
      else
        if (dd .le. zero) then
          uu = xx - tol1
        else
          uu = xx + tol1
        end if
      end if

      nopt = nopt + 1

      fu   =  pqopt( x, uu, w)
c
c  update  aa, bb, vv, ww, and xx
c
      if (fx .ge. fu) then
        if (uu .ge. xx) then
          aa = xx
          fa = fx
        else
          bb = xx
          fb = fx
        end if
        vv   =  ww
        fv   =  fw
        ww   =  xx
        fw   =  fx
        xx   =  uu
        fx   =  fu
      else
        if (uu .ge. xx) then
          bb = uu
          fb = fu
        else
          aa = uu
          fa = fu
        end if
        if ((fu .gt. fw) .and. (ww .ne. xx)) then
          if ((fu .le. fv) .or. (vv .eq. xx) .or. (vv .eq. ww)) then
             vv   =  uu
             fv   =  fu
          end if
        else
          vv   =  ww
          fv   =  fw
          ww   =  uu
          fw   =  fu
        end if
      end if

      go to 10
c
c  end of main loop
c
  100 dopt =  xx
      hood = -fx
      cllf = hood

      return
 900  format( i4, 2(1pe14.6), 1pe16.7, 1pe17.8, 1x, 2(i3))
      end

***************************************************************************
***************************************************************************

      double precision function pqopt( x, d, w)

      implicit double precision (a-h,o-z)

c     real              x(n)
      real              x(*)

      double precision  d
      double precision  w(*)

      double precision bic, slogvk
      double precision t, u

      intrinsic        log

      double precision  ddot
      external          ajqp

      double precision zero, one
      parameter       (zero=0.d0, one=1.d0)

      double precision  hatmu, wnv, hood
      common /FILTFD/   hatmu, wnv, hood
      save   /FILTFD/

      double precision dtol, ftol, xtol, gtol, anorm, deltax, gnorm
      common /TOLSFD/  dtol, ftol, xtol, gtol, anorm, deltax, gnorm
      save   /TOLSFD/

      integer          n, M, np, nq, npq, npq1, maxpq, maxpq1, nm
      common /DIMSFD/  n, M, np, nq, npq, npq1, maxpq, maxpq1, nm
      save   /DIMSFD/

      integer          maxopt, maxfun, nopt, nfun, ngrd,
     *                 ifun, igrd, info
      common /CNTRFD/  maxopt, maxfun, nopt, nfun, ngrd,
     *                 ifun, igrd, info
      save   /CNTRFD/

      integer           ly, lamk, lak, lvk, lphi, lpi
      common /WFILFD/   ly, lamk, lak, lvk, lphi, lpi
      save   /WFILFD/

      integer           lqp, la, lajac, ipvt, ldiag, lqtf,
     *                  lwa1, lwa2, lwa3, lwa4
      common /WOPTFD/   lqp, la, lajac, ipvt, ldiag, lqtf,
     *                  lwa1, lwa2, lwa3, lwa4
      save   /WOPTFD/

      integer           modelm
      double precision  factlm
      data              modelm/1/, factlm /100.d0/

      double precision   FLTMIN, FLTMAX, EPSMIN, EPSMAX
      common /MACHFD/    FLTMIN, FLTMAX, EPSMIN, EPSMAX
      save   /MACHFD/

      integer            IGAMMA, JGAMMA
      common /GAMMFD/    IGAMMA, JGAMMA
      save   /GAMMFD/

c copyright 1991 Department of Statistics, University of Washington
c written by Chris Fraley

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

        call fdfilt( x, d, w(ly), slogvk,
     *               w(lamk), w(lak), w(lvk), w(lphi), w(lpi))

        if (IGAMMA .ne. 0) then
          pqopt  =  FLTMAX
          wnv    =  FLTMAX
          hood   = -FLTMAX
          return
        end if

        t = dble(n)

       if (npq .eq. 0) then
          wnv   = ddot( n, w(ly), 1, w(ly), 1) / t
          ifun  =  0
          igrd  =  0
          info  = -1
          goto 100
        endif
c
c optimize as an unconstrained optimization problem
c
         if (modelm .eq. 2) call dcopy( npq,  one, 0, w(ldiag), 1)

         if (nopt .lt. 0) then
           if (np .ne. 0) then
             call LMDER1( ajp, n-np, np, w(lqp+nq),w(la),w(lajac), n-np,
     *                    ftol, xtol, gtol, maxfun, w(ldiag), modelm,
     *                    factlm, info, ifun, igrd, w(ipvt), w(lqtf),
     *                    w(lwa1), w(lwa2), w(lwa3), w(lwa4), w(ly))
           end if
           if (nq .ne. 0) then
             call LMDER1( ajq, n-nq, nq, w(lqp),w(la),w(lajac), n-nq,
     *                    ftol, xtol, gtol, maxfun, w(ldiag), modelm,
     *                    factlm, info, ifun, igrd, w(ipvt), w(lqtf),
     *                    w(lwa1), w(lwa2), w(lwa3), w(lwa4), w(ly))
           end if
         end if

         call LMDER1( ajqp, nm, npq, w(lqp), w(la), w(lajac), nm,
     *                ftol, xtol, gtol, maxfun, w(ldiag), modelm,
     *                factlm, info, ifun, igrd, w(ipvt), w(lqtf),
     *                w(lwa1), w(lwa2), w(lwa3), w(lwa4), w(ly))

        if (info .eq. 0) then
c         write( 6, *) 'MINPACK : improper input parameters
          IMINPK = 10
          pqopt  =  FLTMAX
          wnv    =  FLTMAX
          hood   = -FLTMAX
          return
        end if

        if (info .eq. 5) then
c         write( 6, *) 'MINPACK : function evaluation limit reached'
          JMINPK = 5
        end if

        if (info .eq. 6 ) then
c         write( 6, *) 'MINPACK : ftol is too small'
          JMINPK = 6
        end if

        if (info .eq. 7) then
c         write( 6, *) 'MINPACK : xtol is too small'
          JMINPK = 7
        end if

        if (info .eq. 8) then
c         write( 6, *) 'MINPACK : gtol is too small'
          JMINPK = 8
        end if

c        call daxpy( npq, (-one), w(lpq), 1, w(lqp), 1
c        delpq  = sqrt(ddot( npq, w(lqp), 1, w(lqp), 1))
c        pqnorm = sqrt(ddot( npq, w(lpq), 1, w(lpq), 1))

        wnv   =  (anorm*anorm) / dble(nm-1)
 100    u     = (t*(2.8378d0+log(wnv))+slogvk)
        pqopt =  u / 2.d0
        bic   =  u + dble(np+nq+1)*log(t)
        hood  = -pqopt

      return
      end

***************************************************************************
***************************************************************************

      subroutine fdfilt( x, d, y, slogvk, amk, ak, vk, phi, pi)

      implicit double precision (a-h,o-z)

c     real              x(n)
      real              x(*)
      double precision  d, slogvk
c     double precision  y(n), amk(n), ak(n)
      double precision  y(*), amk(*), ak(*)
c     double precision  vk(M), phi(M), pi(M)
      double precision  vk(*), phi(*), pi(*)

c**************************************************************************
c input  :
c          x       real    original time series
c          d       double  estimated value of d
c output :
c          y       double  flitered series
c          slogvk  double  the sum of the logarithms of the vk
c notes  :
c          y can use the same storage as either ak or amk
c          phi and pi can use the same storage
c          can be arranged so that phi, pi and vk share the same storage
c**************************************************************************

      integer           j, k, km, mcap, mcap1
      double precision  g0, r, s, t, u, v, z

      double precision  zero, one, two
      parameter        (zero=0.d0, one=1.d0, two=2.d0)

      double precision  dgamma, dgamr

      intrinsic         log, sqrt

      double precision  hatmu, wnv, cllf
      common /FILTFD/   hatmu, wnv, cllf
      save   /FILTFD/

      integer           n, M, np, nq, npq, npq1, maxpq, maxpq1, nm
      common /DIMSFD/   n, M, np, nq, npq, npq1, maxpq, maxpq1, nm
      save   /DIMSFD/

      integer            IGAMMA, JGAMMA
      common /GAMMFD/    IGAMMA, JGAMMA
      save   /GAMMFD/

c copyright 1991 Department of Statistics, University of Washington
c written by Chris Fraley

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

       mcap  = min(M,n)
        mcap1 = mcap + 1
c
c calculate amk(k), vk(k), and ak(k) for k=1,n (see W522-4 for notation).
c
c
c  k = 1
c
       amk(1) = zero
       ak(1)  = one
c
c  k = 2 ;  initialize phi(1)
c
       z      = d/(one-d)
       amk(2) = z*dble(x(1))
       ak(2)  = one - z
        phi(1) = z

        t  = dgamr(one-d)
        if (IGAMMA .ne. 0) return

       g0 = dgamma(one-(two*d))*(t*t)
        if (IGAMMA .ne. 0) return

       vk(1)  = g0
       vk(2)  = g0*(one-(z*z))
c
c  k = 3, mcap
c
       do k = 3, mcap
          km = k - 1
          t  = dble(km)
          u  = t - d
c
c  calculate phi() and vk() using the recursion formula on W498
c
         do j = 1, km-1
            s      = t-dble(j)
           phi(j) = phi(j)*(t*(s-d)/(u*s))
          end do

          v       = d / u
          phi(km) = v
          vk(k)   = vk(km)*(one-(v*v))
c
c  form amk(k) and ak(k)
c
         u = zero
         v =  one
         do j = 1, km
            t  = phi(j)
           u  = u + (t*dble(x(k-j)))
           v  = v - t
          end do
          amk(k) = u
          ak(k)  = v
        end do

        if (mcap .eq. n) go to 200
c
c  k = mcap+1, n
c
c calculate pi(j), j = 1,mcap
c
       pi(1) = d
       s     = d
       do j = 2, mcap
          u     = dble(j)
          t     = pi(j-1)*((u-one-d)/u)
         s     = s + t
          pi(j) = t
        end do

        s =  one - s
       r = zero
        u = dble(mcap)
        t = u*pi(mcap)
c
       do  k = mcap1, n
         km = k - mcap
          z  = zero
         do  j = 1, mcap
            z = z + (pi(j)*dble(x(k-j)))
          end do
          if (r .eq. zero) then
            amk(k) = z
                   ak(k)  = s
          else
            v      = (t*(one - (u/dble(k))**d))/d
           amk(k) = z + ((v*r)/(dble(km)-one))
            ak(k)  = s - v
          end if
          r = r + dble(x(km))
        end do

 200    continue
c
c  form muhat - see formula on W523.
c
        r = zero
       s = zero
       do  k = 1, n
           t = ak(k)
          u = (dble(x(k))-amk(k))*t
          v = t*t
           if (k .le. mcap) then
             z = vk(k)
             u = u / z
             v = v / z
           end if
           r = r + u
           s = s + v
        end do

       hatmu = r / s
c
c  form filtered version
c
        s = zero
       do k= 1, mcap
         s = s + log(vk(k))
        end do

        slogvk = s
        sumlog = s

        s = zero
       do k= 1, n
          t    = (dble(x(k))-amk(k)-hatmu*ak(k))
          if (k .le. mcap) t = t / sqrt(vk(k))
         s    = s + t
          y(k) = t
        end do

        if (npq .eq. 0) return

        t = dble(n)

        u = z / t
       do k= 1, n
          y(k) = y(k) - u
        end do

      return
      end

*****************************************************************************
*****************************************************************************

      subroutine ajqp( qp, a, ajac, lajac, iflag, y)

      implicit double precision (a-h,o-z)

      integer          lajac, iflag

c     double precision qp(npq), a(nm), ajac(nm,npq), y(n)
      double precision qp(*), a(*), ajac(lajac,*), y(*)

      integer          maxopt, maxfun, nopt, nfun, ngrd,
     *                 ifun, igrd, info
      common /CNTRFD/  maxopt, maxfun, nopt, nfun, ngrd,
     *                 ifun, igrd, info
      save   /CNTRFD/

      integer          n, M, np, nq, npq, npq1, maxpq, maxpq1, nm
      common /DIMSFD/  n, M, np, nq, npq, npq1, maxpq, maxpq1, nm
      save   /DIMSFD/

      double precision   EPSP25, EPSPT3, EPSPT5, EPSP75, BIGNUM
      common /MAUXFD/    EPSP25, EPSPT3, EPSPT5, EPSP75, BIGNUM
      save   /MAUXFD/

      double precision s, t

      double precision zero
      parameter       (zero=0.d0)

c copyright 1991 Department of Statistics, University of Washington
c written by Chris Fraley

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

        if (iflag .eq. 2) goto 200

        if (iflag .ne. 1) return
c
c  objective calculation
c
        do k = maxpq1, n
          km = k - maxpq
          t  = zero
          if (np .ne. 0) then
            do l = 1, np
              t  = t - qp(nq+l)*y(k-l)
            end do
          end if
          s = zero
          if (nq .ne. 0) then
            do l = 1, nq
              if (km .le. l) goto 101
              s  = s + qp(l)*a(km-l)
            end do
          end if
 101      s = y(k) + (t + s)
          if (abs(s) .le. BIGNUM) then
            a(km) = s
          else
            a(km) = sign(one,s)*BIGNUM
          end if
        end do

        nfun = nfun + 1

        return

 200    continue
c
c  jacobian calculation
c
        do i = 1, npq
          do k = maxpq1, n
            km  =  k - maxpq
            t   = zero
            if (nq .ne. 0) then
              do l = 1, nq
                if (km .le. l) goto 201
                t  = t +  qp(l)*ajac(km-l,i)
              end do
            end if
 201        continue
            if (i .le. nq) then
              if (km .gt. i) then
                s = a(km-i) + t
              else
                s =           t
              end if
            else
              s = -y(k-(i-nq)) + t
            end if
            if (abs(s) .le. BIGNUM) then
              ajac(km,i) = s
            else
              ajac(km,i) = sign(one,s)*BIGNUM
            end if
          end do
        end do

        ngrd = ngrd + 1

      return
      end

*****************************************************************************
*****************************************************************************

      subroutine  ajp( p, a, ajac, lajac, iflag, y)

      implicit double precision (a-h,o-z)

      integer          lajac, iflag
c     double precision p(np), a(nm), ajac(nm,npq), y(n)
      double precision p(*), a(*), ajac(lajac,*), y(*)

      integer          n, M, np, nq, npq, npq1, maxpq, maxpq1, nm
      common /DIMSFD/  n, M, np, nq, npq, npq1, maxpq, maxpq1, nm
      save   /DIMSFD/

      double precision  t

      double precision zero
      parameter       (zero=0.d0)

c copyright 1991 Department of Statistics, University of Washington
c written by Chris Fraley

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

        if (iflag .eq. 2) goto 200

        if (iflag .ne. 1) return

        if (np .eq. 0) return
c
c  objective calculation
c
        do k = np+1, n
          t  = zero
          do l = 1, np
            t  = t - p(l)*y(k-l)
          end do
 101      a(k-np) = y(k) + t
        end do

        return

 200    continue
c
c  jacobian calculation
c
          do i = 1, np
            do k = np+1, n
              ajac(k-np,i) = -y(k-i)
            end do
          end do

      return
      end

*****************************************************************************
*****************************************************************************

      subroutine  ajq( qp, a, ajac, lajac, iflag, y)

      implicit double precision (a-h,o-z)

      integer          lajac, iflag
c     double precision qp(npq), a(nm), ajac(nm,npq), y(n)
      double precision qp(*), a(*), ajac(lajac,*), y(*)

      integer          n, M, np, nq, npq, npq1, maxpq, maxpq1, nm
      common /DIMSFD/  n, M, np, nq, npq, npq1, maxpq, maxpq1, nm
      save   /DIMSFD/

      integer          maxopt, maxfun, nopt, nfun, ngrd,
     *                 ifun, igrd, info
      common /CNTRFD/  maxopt, maxfun, nopt, nfun, ngrd,
     *                 ifun, igrd, info
      save   /CNTRFD/

      double precision s, t

      double precision zero
      parameter       (zero=0.d0)

c copyright 1991 Department of Statistics, University of Washington
c written by Chris Fraley

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

        if (iflag .eq. 2) goto 200

        if (iflag .ne. 1) return

        if (nq. eq. 0) return
c
c  objective calculation
c
        do k = maxpq1, n
          km = k - maxpq
          t  = zero
          if (np .ne. 0) then
            do l = 1, np
              t  = t - qp(nq+l)*y(k-l)
            end do
          end if
          s = zero
          if (nq .ne. 0) then
            do l = 1, nq
              if (km .le. l) goto 101
              s  = s + qp(l)*a(km-l)
            end do
          end if
 101      a(km) = y(k) + (t + s)
        end do

        nfun = nfun + 1

        return

 200    continue
c
c  jacobian calculation
c
        do i = 1, npq
          do k = maxpq1, n
            km  =  k - maxpq
            t   = zero
            if (nq .ne. 0) then
              do l = 1, nq
                if (km .le. l) goto 201
                t  = t +  qp(l)*ajac(km-l,i)
              end do
            end if
 201        continue
            if (i .le. nq) then
              if (km .gt. i) then
                ajac(km,i) = a(km-i)    + t
              else
                ajac(km,i) =              t
              end if
            else
              ajac(km,i) = -y(k-(i-nq)) + t
            end if
          end do
        end do

        ngrd = ngrd + 1

      return
      end


program practice
    implicit none
    REAL :: rand(1)
    INTEGER :: low = 1, high = 10

    CALL RANDOM_NUMBER(rand)
    PRINT "(i2)", low + FLOOR((high+1 - low)*rand)

end program practice


      real*8 function drndsr()
C  YOKOYA's subroutine for
C  RANDOM NUMBER GENERATOR OF SYNCHROTRON RADIATION SPECTRUM.
C  GENERATES X(1),X(2).....X(N).
C  X=(PHOTON ENERGY)/(CRITICAL ENERGY)
C   PROBABILITY THAT X BE IN THE INTERVAL (Y,Y+DY) IS
C     PP(Y)*DY= DY*( INTEGRAL (3/(5*PI))*K(5/3,Z) FROM Y TO INFINITY )
C  METHOD: USE INVERSE function Y(P) OF P(Y)
C                 P(Y)=INTEGRAL PP(Y)*DY FROM 0 TO Y.
C          GENERATE UNIFORM RANDOM DEVIATE 'P' IN (0,1) BY THE
C          CONGRUENCE METHOD AND COMPUTE Y(P).
C  ACCURACY: RELATIVE ERROR OF Y(P) IS LESS THAN 2.0*E-4
C     EVERYWHERE IN THE RANGE 0<P<1-2**(-31).
C       <Y>=(8/(15*SQRT(3))*1.0000136
C       <Y**2>=(11/27)*1.0000153
C  CPU-TIME: 4.9*N+5.6 (MICRO SEC) ON M200H.OPT(3) (1984.4.24)
      implicit none
      real*8 p,tran,p2,q,t
      P=tran()
      IF(P.GE.0.658D0) GOTO 100
      P2=P**2
      drndsr=(((0.41841680D0*P2+0.14175015D0)*P2+0.30528148D0)*P2
     %       +0.53520052D0)*P2*P
      return
  100 Q=1D0-P
      IF(Q.LE.0.0297d0) GOTO 200
      drndsr=((-0.32809490D0*Q+0.20653610D0)*Q+0.011920005D0)/
     %    (((Q+0.88765651D0)*Q+0.19270658D0)*Q+0.0033141692D0)
      return
  200 T=-LOG(Q)
      drndsr=(674.99117D0*T+148.32871D0)/
     %  ((T-225.45670D0)*T-692.23986D0)+T
      RETURN
      END

      real*8 function tdusr(anp,an)
c a random energy loss of SR using drndsr
c anp: expected number of photons
c returns: a random energy loss due to SR in unit of uc
c cutoff: threshold to ingnore multiple photons beyond this probability
c npmax: the maximum number of photons to try
      implicit none
      real*8 anp,p,p0,pn,tran,drndsr,an,x
      real*8 , parameter :: cutoff=0.9999d0
      integer*4 np
      integer*4, parameter:: npmax=10000
      p0=exp(-anp)
      pn=p0
      p=tran()
      tdusr=0.d0
      an=0.d0
      x=1.d0
      do np=1,npmax
        if(p .le. pn)then
          return
        endif
        tdusr=tdusr+drndsr()
        an=an+1.d0
        x=x*anp/an
        pn=pn+x*p0
        if(pn .gt. cutoff)then
          exit
        endif
      enddo
      return
      end

      subroutine tdusrn(anp,dph,r1,r2,an)
c a random energy loss of SR using drndsr
c anp: expected number of photons
c returns: dph = sum of photon energies/uc,
c  r1 = sum(r_n u_n)/sum(u_n), r2 = sum(r_n^2 u_n)/sum(r_n u_n)/2
c  an = number of actually emitted photons
c cutoff: threshold to ingnore multiple photons beyond this probability
c npmax: the maximum number of photons to try
      implicit none
      real*8 , intent(in)::anp
      real*8 ,intent(out)::dph,an,r1,r2
      real*8 p,p0,pn,tran,drndsr,x,r,dph1
      real*8 , parameter :: cutoff=0.9999d0
      integer*4 , parameter :: npmax=10000
      integer*4 k
      p0=exp(-anp)
      pn=p0
      p=tran()
      r1=0.d0
      r2=0.d0
      an=0.d0
      x=1.d0
      dph=0.d0
      do k=1,npmax
        if(p .le. pn)then
          exit
        endif
        an=an+1.d0
        x=x*anp/an
        pn=pn+x*p0
        dph1=drndsr()
        dph=dph+dph1
        r=tran()
        r1=r1+r*dph1
        r2=r2+r**2*dph1
        if(pn .gt. cutoff)then
          exit
        endif
      enddo
      if(r1 .ne. 0.d0)then
        r2=r2/r1*.5d0
        r1=r1/dph
      endif
      return
      end

      subroutine tdusrnpl(anp,dph,r1,r2,an,dpr,rph)
c
c Same as tdusrn, with photonlist generation
c
      implicit none
      integer*4 , parameter :: npmax=10000
      real*8 , intent(in)::anp
      real*8 ,intent(out)::dph,an,r1,r2,dpr(npmax),rph(npmax)
      real*8 p,p0,pn,tran,drndsr,x,r,dph1
      real*8 , parameter :: cutoff=0.9999d0
      integer*4 k
      p0=exp(-anp)
      pn=p0
      p=tran()
      r1=0.d0
      r2=0.d0
      an=0.d0
      x=1.d0
      dph=0.d0
      do k=1,npmax
        if(p .le. pn)then
          exit
        endif
        an=an+1.d0
        x=x*anp/an
        pn=pn+x*p0
        dph1=drndsr()
        dph=dph+dph1
        r=tran()
        r1=r1+r*dph1
        r2=r2+r**2*dph1
        dpr(k)=dph1
        rph(k)=r
        if(pn .gt. cutoff)then
          exit
        endif
      enddo
      if(r1 .ne. 0.d0)then
        r2=r2/r1*.5d0
        r1=r1/dph
      endif
      return
      end


*DECK CSHCH
      SUBROUTINE CSHCH (Z, CSH, CCH)
C***BEGIN PROLOGUE  CSHCH
C***SUBSIDIARY
C***PURPOSE  Subsidiary to CBESH and CBESK
C***LIBRARY   SLATEC
C***TYPE      ALL (CSHCH-A, ZSHCH-A)
C***AUTHOR  Amos, D. E., (SNL)
C***DESCRIPTION
C
C     CSHCH COMPUTES THE COMPLEX HYPERBOLIC FUNCTIONS CSH=SINH(X+I*Y)
C     AND CCH=COSH(X+I*Y), WHERE I**2=-1.
C
C***SEE ALSO  CBESH, CBESK
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   830501  DATE WRITTEN
C   910415  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  CSHCH
      COMPLEX CCH, CSH, Z
      REAL CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, X, Y
C***FIRST EXECUTABLE STATEMENT  CSHCH
      X = REAL(Z)
      Y = AIMAG(Z)
      SH = SINH(X)
      CH = COSH(X)
      SN = SIN(Y)
      CN = COS(Y)
      CSHR = SH*CN
      CSHI = CH*SN
      CSH = CMPLX(CSHR,CSHI)
      CCHR = CH*CN
      CCHI = SH*SN
      CCH = CMPLX(CCHR,CCHI)
      RETURN
      END


! =========================================================================
elemental function gsw_gibbs_ice_pt0_pt0 (pt0)
! =========================================================================
!
!  The second temperature derivative of Gibbs energy of ice at the
!  potential temperature with reference sea pressure of zero dbar.  That is
!  the output is gibbs_ice(2,0,pt0,0).
!
!  pt0  =  potential temperature with reference sea pressure of zero dbar
!                                                                 [ deg C ]
!
!  gsw_gibbs_ice_pt0_pt0 = temperature second derivative at pt0
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_t0

use gsw_mod_gibbs_ice_coefficients

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: pt0

real (r8) :: gsw_gibbs_ice_pt0_pt0

real (r8) :: tau
complex (r8) :: g

tau = (pt0 + gsw_t0)*rec_tt

g = r1*(1.0_r8/(t1 - tau) + 1.0_r8/(t1 + tau) - 2.0_r8/t1) &
    + r20*(1.0_r8/(t2 - tau) + 1.0_r8/(t2 + tau) - 2.0_r8/t2)

gsw_gibbs_ice_pt0_pt0 = rec_tt*real(g)

return
end function

!--------------------------------------------------------------------------


    !-------------------------------------------------------------------------------------------------------------
    !
    !> \file    CompExcessGibbsEnergyQKTO.f90
    !> \brief   Compute the partial molar excess Gibbs energy of mixing of solution phase constituents in a QKTO
    !!           solution phase.
    !> \author  M.H.A. Piro
    !> \sa      CompExcessGibbsEnergy.f90
    !> \sa      CompExcessGibbsEnergyRKMP.f90
    !> \sa      CompExcessGibbsEnergySUBL.f90
    !> \date    June 13, 2012
    !
    !
    ! Revisions:
    ! ==========
    !
    !   Date            Programmer          Description of change
    !   ----            ----------          ---------------------
    !   06/13/2012      M.H.A. Piro         Original code.
    !
    !
    ! Purpose:
    ! ========
    !
    !> \details The purpose of this subroutine is to compute the partial molar excess Gibbs energy of mixing
    !! (dPartialExcessGibbs) of all constituents in a non-ideal solution phase designated as 'QKTO'
    !! (Quasi-chemical Kohlter-TOop).  The PolyRegular subroutine computes the excess Gibbs energy of mixing of
    !! a regular solution sub-system (see PolyRegular for a definition) and the KohlerInterpolate subroutine
    !! performs a Kohler interpolation of a sub-system to a phase.
    !!
    !! The molar excess Gibbs energy of mixing of a binary sub-system for a QKTO model is:
    !!
    !! \f$ g_{\lambda,z}^{ex} = L_z x_1^a x_2^b \f$
    !!
    !! where \f$ L_z \f$ is the mixing parameter, \f$ x_1 \f$ and \f$ x_2 \f$ are the mole fractions for
    !! constituents 1 and 2 in the binary term and \f$ a \f$ and \f$ b \f$ are the exponents for constituents
    !! 1 and 2, respectively.
    !!
    !! The molar excess Gibbs energy of mixing for solution phase \f$ \lambda \f$ using Kohler's interpolation
    !! scheme gives
    !!
    !! \f$ g_{\lambda}^{ex} = (x_1 + x_2)^2 g_{\lambda,z}^{ex} \f$
    !!
    !! Similarly, the molar excess Gibbs energy of mixing of a ternary sub-system for a QKTO model is:
    !!
    !! \f$ g_{\lambda,z}^{ex} = L_z x_1^a x_2^b x_3^c \f$
    !!
    !! which is related to the molar excess Gibbs energy of mixing of the phase via Kohler's interpolation:
    !!
    !! \f$ g_{\lambda}^{ex} = (x_1 + x_2 + x_3)^2 g_{\lambda,z}^{ex} \f$
    !!
    !
    ! Pertinent variables:
    ! ====================
    !
    !> \param[in] iSolnIndex    Absolute index of a solution phase
    !
    ! nSpeciesPhase             Highest index number of a species in a particular solution phase
    ! nParam                    Number of parameters
    ! iParam                    Index number of a parameter.
    ! dChemicalPotential        The estimated chemical potential vector.  To be precise, this is defined as the
    !                           molar Gibbs energy of the pure species minus the proper chemical potential
    !                           defined by the element potentials.
    ! dPartialExcessGibbs       Partial molar excess Gibbs energy of mixing of species.
    ! dPartialExcessGibbsLast   Partial molar excess Gibbs energy of mixing of species from the last iteration.
    ! dMolFraction              Current estimated mole fraction.
    !
    !-------------------------------------------------------------------------------------------------------------

subroutine CompExcessGibbsEnergyQKTO(iSolnIndex)

    USE ModuleThermo
    USE ModuleGEMSolver

    implicit none

    integer                       :: iParam, iSolnIndex
    real(8)                       :: dGParam, xT
    real(8), dimension(nMaxParam) :: dPartialGParam

    ! Return control to the parent subroutine if there aren't any interaction parameters for this phase:
    if ((nParamPhase(iSolnIndex) - nParamPhase(iSolnIndex-1) == 0).OR. &
        (cSolnPhaseType(iSolnIndex) /= 'QKTO')) return

    ! Loop through all interaction parameters in this phase:
    do iParam = nParamPhase(iSolnIndex-1)+1, nParamPhase(iSolnIndex)

        ! Compute the partial molar excess Gibbs energy of each sub-system in a regular solution phase:
        call PolyRegularQKTO(iSolnIndex,iParam,xT,dGParam,dPartialGParam)

        ! Perform a Kohler interpolation amoungst the sub-systems to compute the overall partial molar
        ! excess Gibbs energy of mixing:
        call KohlerInterpolate(iSolnIndex,iParam,xT,dGParam,dPartialGParam)

    end do

    return

end subroutine CompExcessGibbsEnergyQKTO


c-----------------------------------------------------------------
c convert phase to phase velocity
c-----------------------------------------------------------------
      subroutine phtovel(delta,ip,n,per,U,pha,npr,prper,prvel,V)
c
c delta  - distance, km
c n      - # of points in per
c per    - apparent periods
c U      - group velocity
c pha    - phase
c npr    - # of points in prper
c prper  - pedicted periods
c prvel  - pedicted phase velocity
c V      - observed phase velocity

      implicit none
      integer*4 ip,n,npr
      real*8    delta,per(100),U(100),pha(100),prper(300),prvel(300),V(100)
      real*8    pi,om(100),sU(100),t(100)
      integer*4 i,ierr,k,m
      real*8    Vpred,phpred,s,ss

      pi = datan(1.0d0)*4.0d0
      Vpred = 0.0d0
      do i =1,n
         om(i) = 2.0d0*pi/per(i)
         sU(i) = 1./U(i)
         t(i)  = delta*sU(i)
         V(i)  = 00d0
      enddo
c find velocity for the largest period by spline interpolation
c with not a knot boundary conditions
      call mspline(ip+2,npr,prper,prvel,0,0.0d0,0,0.0d0)
      call msplder(ip+2,per(n),Vpred,s,ss,ierr)
      write(*,*) 'Starting period= ',per(n),', Phase velocity= ',Vpred
      phpred = om(n)*(t(n)-delta/Vpred)
      k = nint((phpred -pha(n))/2.0d0/pi)
      V(n) = delta/(t(n)-(pha(n)+2.0d0*k*pi)/om(n))
      do m = n-1,1,-1
        Vpred =1/(((sU(m)+sU(m+1))*(om(m)-om(m+1))/2.0d0+om(m+1)/V(m+1))/om(m))
        phpred = om(m)*(t(m)-delta/Vpred)
        k = nint((phpred -pha(m))/2.0d0/pi)
        V(m) = delta/(t(m)-(pha(m)+2.0d0*k*pi)/om(m))
      enddo
      return
      end


*> \brief \b CTGEVC
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CTGEVC + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE CTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL,
*                          LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          HOWMNY, SIDE
*       INTEGER            INFO, LDP, LDS, LDVL, LDVR, M, MM, N
*       ..
*       .. Array Arguments ..
*       LOGICAL            SELECT( * )
*       REAL               RWORK( * )
*       COMPLEX            P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
*      $                   VR( LDVR, * ), WORK( * )
*       ..
*
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CTGEVC computes some or all of the right and/or left eigenvectors of
*> a pair of complex matrices (S,P), where S and P are upper triangular.
*> Matrix pairs of this type are produced by the generalized Schur
*> factorization of a complex matrix pair (A,B):
*>
*>    A = Q*S*Z**H,  B = Q*P*Z**H
*>
*> as computed by CGGHRD + CHGEQZ.
*>
*> The right eigenvector x and the left eigenvector y of (S,P)
*> corresponding to an eigenvalue w are defined by:
*>
*>    S*x = w*P*x,  (y**H)*S = w*(y**H)*P,
*>
*> where y**H denotes the conjugate tranpose of y.
*> The eigenvalues are not input to this routine, but are computed
*> directly from the diagonal elements of S and P.
*>
*> This routine returns the matrices X and/or Y of right and left
*> eigenvectors of (S,P), or the products Z*X and/or Q*Y,
*> where Z and Q are input matrices.
*> If Q and Z are the unitary factors from the generalized Schur
*> factorization of a matrix pair (A,B), then Z*X and Q*Y
*> are the matrices of right and left eigenvectors of (A,B).
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] SIDE
*> \verbatim
*>          SIDE is CHARACTER*1
*>          = 'R': compute right eigenvectors only;
*>          = 'L': compute left eigenvectors only;
*>          = 'B': compute both right and left eigenvectors.
*> \endverbatim
*>
*> \param[in] HOWMNY
*> \verbatim
*>          HOWMNY is CHARACTER*1
*>          = 'A': compute all right and/or left eigenvectors;
*>          = 'B': compute all right and/or left eigenvectors,
*>                 backtransformed by the matrices in VR and/or VL;
*>          = 'S': compute selected right and/or left eigenvectors,
*>                 specified by the logical array SELECT.
*> \endverbatim
*>
*> \param[in] SELECT
*> \verbatim
*>          SELECT is LOGICAL array, dimension (N)
*>          If HOWMNY='S', SELECT specifies the eigenvectors to be
*>          computed.  The eigenvector corresponding to the j-th
*>          eigenvalue is computed if SELECT(j) = .TRUE..
*>          Not referenced if HOWMNY = 'A' or 'B'.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrices S and P.  N >= 0.
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*>          S is COMPLEX array, dimension (LDS,N)
*>          The upper triangular matrix S from a generalized Schur
*>          factorization, as computed by CHGEQZ.
*> \endverbatim
*>
*> \param[in] LDS
*> \verbatim
*>          LDS is INTEGER
*>          The leading dimension of array S.  LDS >= max(1,N).
*> \endverbatim
*>
*> \param[in] P
*> \verbatim
*>          P is COMPLEX array, dimension (LDP,N)
*>          The upper triangular matrix P from a generalized Schur
*>          factorization, as computed by CHGEQZ.  P must have real
*>          diagonal elements.
*> \endverbatim
*>
*> \param[in] LDP
*> \verbatim
*>          LDP is INTEGER
*>          The leading dimension of array P.  LDP >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] VL
*> \verbatim
*>          VL is COMPLEX array, dimension (LDVL,MM)
*>          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
*>          contain an N-by-N matrix Q (usually the unitary matrix Q
*>          of left Schur vectors returned by CHGEQZ).
*>          On exit, if SIDE = 'L' or 'B', VL contains:
*>          if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);
*>          if HOWMNY = 'B', the matrix Q*Y;
*>          if HOWMNY = 'S', the left eigenvectors of (S,P) specified by
*>                      SELECT, stored consecutively in the columns of
*>                      VL, in the same order as their eigenvalues.
*>          Not referenced if SIDE = 'R'.
*> \endverbatim
*>
*> \param[in] LDVL
*> \verbatim
*>          LDVL is INTEGER
*>          The leading dimension of array VL.  LDVL >= 1, and if
*>          SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N.
*> \endverbatim
*>
*> \param[in,out] VR
*> \verbatim
*>          VR is COMPLEX array, dimension (LDVR,MM)
*>          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
*>          contain an N-by-N matrix Q (usually the unitary matrix Z
*>          of right Schur vectors returned by CHGEQZ).
*>          On exit, if SIDE = 'R' or 'B', VR contains:
*>          if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);
*>          if HOWMNY = 'B', the matrix Z*X;
*>          if HOWMNY = 'S', the right eigenvectors of (S,P) specified by
*>                      SELECT, stored consecutively in the columns of
*>                      VR, in the same order as their eigenvalues.
*>          Not referenced if SIDE = 'L'.
*> \endverbatim
*>
*> \param[in] LDVR
*> \verbatim
*>          LDVR is INTEGER
*>          The leading dimension of the array VR.  LDVR >= 1, and if
*>          SIDE = 'R' or 'B', LDVR >= N.
*> \endverbatim
*>
*> \param[in] MM
*> \verbatim
*>          MM is INTEGER
*>          The number of columns in the arrays VL and/or VR. MM >= M.
*> \endverbatim
*>
*> \param[out] M
*> \verbatim
*>          M is INTEGER
*>          The number of columns in the arrays VL and/or VR actually
*>          used to store the eigenvectors.  If HOWMNY = 'A' or 'B', M
*>          is set to N.  Each selected eigenvector occupies one column.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is REAL array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit.
*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complexGEcomputational
*
*  =====================================================================
      SUBROUTINE CTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL,
     $                   LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )
*
*  -- LAPACK computational routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          HOWMNY, SIDE
      INTEGER            INFO, LDP, LDS, LDVL, LDVR, M, MM, N
*     ..
*     .. Array Arguments ..
      LOGICAL            SELECT( * )
      REAL               RWORK( * )
      COMPLEX            P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
     $                   VR( LDVR, * ), WORK( * )
*     ..
*
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
      COMPLEX            CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            COMPL, COMPR, ILALL, ILBACK, ILBBAD, ILCOMP,
     $                   LSA, LSB
      INTEGER            I, IBEG, IEIG, IEND, IHWMNY, IM, ISIDE, ISRC,
     $                   J, JE, JR
      REAL               ACOEFA, ACOEFF, ANORM, ASCALE, BCOEFA, BIG,
     $                   BIGNUM, BNORM, BSCALE, DMIN, SAFMIN, SBETA,
     $                   SCALE, SMALL, TEMP, ULP, XMAX
      COMPLEX            BCOEFF, CA, CB, D, SALPHA, SUM, SUMA, SUMB, X
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL               SLAMCH
      COMPLEX            CLADIV
      EXTERNAL           LSAME, SLAMCH, CLADIV
*     ..
*     .. External Subroutines ..
      EXTERNAL           CGEMV, SLABAD, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, AIMAG, CMPLX, CONJG, MAX, MIN, REAL
*     ..
*     .. Statement Functions ..
      REAL               ABS1
*     ..
*     .. Statement Function definitions ..
      ABS1( X ) = ABS( REAL( X ) ) + ABS( AIMAG( X ) )
*     ..
*     .. Executable Statements ..
*
*     Decode and Test the input parameters
*
      IF( LSAME( HOWMNY, 'A' ) ) THEN
         IHWMNY = 1
         ILALL = .TRUE.
         ILBACK = .FALSE.
      ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN
         IHWMNY = 2
         ILALL = .FALSE.
         ILBACK = .FALSE.
      ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN
         IHWMNY = 3
         ILALL = .TRUE.
         ILBACK = .TRUE.
      ELSE
         IHWMNY = -1
      END IF
*
      IF( LSAME( SIDE, 'R' ) ) THEN
         ISIDE = 1
         COMPL = .FALSE.
         COMPR = .TRUE.
      ELSE IF( LSAME( SIDE, 'L' ) ) THEN
         ISIDE = 2
         COMPL = .TRUE.
         COMPR = .FALSE.
      ELSE IF( LSAME( SIDE, 'B' ) ) THEN
         ISIDE = 3
         COMPL = .TRUE.
         COMPR = .TRUE.
      ELSE
         ISIDE = -1
      END IF
*
      INFO = 0
      IF( ISIDE.LT.0 ) THEN
         INFO = -1
      ELSE IF( IHWMNY.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDS.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDP.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CTGEVC', -INFO )
         RETURN
      END IF
*
*     Count the number of eigenvectors
*
      IF( .NOT.ILALL ) THEN
         IM = 0
         DO 10 J = 1, N
            IF( SELECT( J ) )
     $         IM = IM + 1
   10    CONTINUE
      ELSE
         IM = N
      END IF
*
*     Check diagonal of B
*
      ILBBAD = .FALSE.
      DO 20 J = 1, N
         IF( AIMAG( P( J, J ) ).NE.ZERO )
     $      ILBBAD = .TRUE.
   20 CONTINUE
*
      IF( ILBBAD ) THEN
         INFO = -7
      ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN
         INFO = -10
      ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN
         INFO = -12
      ELSE IF( MM.LT.IM ) THEN
         INFO = -13
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CTGEVC', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      M = IM
      IF( N.EQ.0 )
     $   RETURN
*
*     Machine Constants
*
      SAFMIN = SLAMCH( 'Safe minimum' )
      BIG = ONE / SAFMIN
      CALL SLABAD( SAFMIN, BIG )
      ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
      SMALL = SAFMIN*N / ULP
      BIG = ONE / SMALL
      BIGNUM = ONE / ( SAFMIN*N )
*
*     Compute the 1-norm of each column of the strictly upper triangular
*     part of A and B to check for possible overflow in the triangular
*     solver.
*
      ANORM = ABS1( S( 1, 1 ) )
      BNORM = ABS1( P( 1, 1 ) )
      RWORK( 1 ) = ZERO
      RWORK( N+1 ) = ZERO
      DO 40 J = 2, N
         RWORK( J ) = ZERO
         RWORK( N+J ) = ZERO
         DO 30 I = 1, J - 1
            RWORK( J ) = RWORK( J ) + ABS1( S( I, J ) )
            RWORK( N+J ) = RWORK( N+J ) + ABS1( P( I, J ) )
   30    CONTINUE
         ANORM = MAX( ANORM, RWORK( J )+ABS1( S( J, J ) ) )
         BNORM = MAX( BNORM, RWORK( N+J )+ABS1( P( J, J ) ) )
   40 CONTINUE
*
      ASCALE = ONE / MAX( ANORM, SAFMIN )
      BSCALE = ONE / MAX( BNORM, SAFMIN )
*
*     Left eigenvectors
*
      IF( COMPL ) THEN
         IEIG = 0
*
*        Main loop over eigenvalues
*
         DO 140 JE = 1, N
            IF( ILALL ) THEN
               ILCOMP = .TRUE.
            ELSE
               ILCOMP = SELECT( JE )
            END IF
            IF( ILCOMP ) THEN
               IEIG = IEIG + 1
*
               IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND.
     $             ABS( REAL( P( JE, JE ) ) ).LE.SAFMIN ) THEN
*
*                 Singular matrix pencil -- return unit eigenvector
*
                  DO 50 JR = 1, N
                     VL( JR, IEIG ) = CZERO
   50             CONTINUE
                  VL( IEIG, IEIG ) = CONE
                  GO TO 140
               END IF
*
*              Non-singular eigenvalue:
*              Compute coefficients  a  and  b  in
*                   H
*                 y  ( a A - b B ) = 0
*
               TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE,
     $                ABS( REAL( P( JE, JE ) ) )*BSCALE, SAFMIN )
               SALPHA = ( TEMP*S( JE, JE ) )*ASCALE
               SBETA = ( TEMP*REAL( P( JE, JE ) ) )*BSCALE
               ACOEFF = SBETA*ASCALE
               BCOEFF = SALPHA*BSCALE
*
*              Scale to avoid underflow
*
               LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEFF ).LT.SMALL
               LSB = ABS1( SALPHA ).GE.SAFMIN .AND. ABS1( BCOEFF ).LT.
     $               SMALL
*
               SCALE = ONE
               IF( LSA )
     $            SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
               IF( LSB )
     $            SCALE = MAX( SCALE, ( SMALL / ABS1( SALPHA ) )*
     $                    MIN( BNORM, BIG ) )
               IF( LSA .OR. LSB ) THEN
                  SCALE = MIN( SCALE, ONE /
     $                    ( SAFMIN*MAX( ONE, ABS( ACOEFF ),
     $                    ABS1( BCOEFF ) ) ) )
                  IF( LSA ) THEN
                     ACOEFF = ASCALE*( SCALE*SBETA )
                  ELSE
                     ACOEFF = SCALE*ACOEFF
                  END IF
                  IF( LSB ) THEN
                     BCOEFF = BSCALE*( SCALE*SALPHA )
                  ELSE
                     BCOEFF = SCALE*BCOEFF
                  END IF
               END IF
*
               ACOEFA = ABS( ACOEFF )
               BCOEFA = ABS1( BCOEFF )
               XMAX = ONE
               DO 60 JR = 1, N
                  WORK( JR ) = CZERO
   60          CONTINUE
               WORK( JE ) = CONE
               DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
*
*                                              H
*              Triangular solve of  (a A - b B)  y = 0
*
*                                      H
*              (rowwise in  (a A - b B) , or columnwise in a A - b B)
*
               DO 100 J = JE + 1, N
*
*                 Compute
*                       j-1
*                 SUM = sum  conjg( a*S(k,j) - b*P(k,j) )*x(k)
*                       k=je
*                 (Scale if necessary)
*
                  TEMP = ONE / XMAX
                  IF( ACOEFA*RWORK( J )+BCOEFA*RWORK( N+J ).GT.BIGNUM*
     $                TEMP ) THEN
                     DO 70 JR = JE, J - 1
                        WORK( JR ) = TEMP*WORK( JR )
   70                CONTINUE
                     XMAX = ONE
                  END IF
                  SUMA = CZERO
                  SUMB = CZERO
*
                  DO 80 JR = JE, J - 1
                     SUMA = SUMA + CONJG( S( JR, J ) )*WORK( JR )
                     SUMB = SUMB + CONJG( P( JR, J ) )*WORK( JR )
   80             CONTINUE
                  SUM = ACOEFF*SUMA - CONJG( BCOEFF )*SUMB
*
*                 Form x(j) = - SUM / conjg( a*S(j,j) - b*P(j,j) )
*
*                 with scaling and perturbation of the denominator
*
                  D = CONJG( ACOEFF*S( J, J )-BCOEFF*P( J, J ) )
                  IF( ABS1( D ).LE.DMIN )
     $               D = CMPLX( DMIN )
*
                  IF( ABS1( D ).LT.ONE ) THEN
                     IF( ABS1( SUM ).GE.BIGNUM*ABS1( D ) ) THEN
                        TEMP = ONE / ABS1( SUM )
                        DO 90 JR = JE, J - 1
                           WORK( JR ) = TEMP*WORK( JR )
   90                   CONTINUE
                        XMAX = TEMP*XMAX
                        SUM = TEMP*SUM
                     END IF
                  END IF
                  WORK( J ) = CLADIV( -SUM, D )
                  XMAX = MAX( XMAX, ABS1( WORK( J ) ) )
  100          CONTINUE
*
*              Back transform eigenvector if HOWMNY='B'.
*
               IF( ILBACK ) THEN
                  CALL CGEMV( 'N', N, N+1-JE, CONE, VL( 1, JE ), LDVL,
     $                        WORK( JE ), 1, CZERO, WORK( N+1 ), 1 )
                  ISRC = 2
                  IBEG = 1
               ELSE
                  ISRC = 1
                  IBEG = JE
               END IF
*
*              Copy and scale eigenvector into column of VL
*
               XMAX = ZERO
               DO 110 JR = IBEG, N
                  XMAX = MAX( XMAX, ABS1( WORK( ( ISRC-1 )*N+JR ) ) )
  110          CONTINUE
*
               IF( XMAX.GT.SAFMIN ) THEN
                  TEMP = ONE / XMAX
                  DO 120 JR = IBEG, N
                     VL( JR, IEIG ) = TEMP*WORK( ( ISRC-1 )*N+JR )
  120             CONTINUE
               ELSE
                  IBEG = N + 1
               END IF
*
               DO 130 JR = 1, IBEG - 1
                  VL( JR, IEIG ) = CZERO
  130          CONTINUE
*
            END IF
  140    CONTINUE
      END IF
*
*     Right eigenvectors
*
      IF( COMPR ) THEN
         IEIG = IM + 1
*
*        Main loop over eigenvalues
*
         DO 250 JE = N, 1, -1
            IF( ILALL ) THEN
               ILCOMP = .TRUE.
            ELSE
               ILCOMP = SELECT( JE )
            END IF
            IF( ILCOMP ) THEN
               IEIG = IEIG - 1
*
               IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND.
     $             ABS( REAL( P( JE, JE ) ) ).LE.SAFMIN ) THEN
*
*                 Singular matrix pencil -- return unit eigenvector
*
                  DO 150 JR = 1, N
                     VR( JR, IEIG ) = CZERO
  150             CONTINUE
                  VR( IEIG, IEIG ) = CONE
                  GO TO 250
               END IF
*
*              Non-singular eigenvalue:
*              Compute coefficients  a  and  b  in
*
*              ( a A - b B ) x  = 0
*
               TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE,
     $                ABS( REAL( P( JE, JE ) ) )*BSCALE, SAFMIN )
               SALPHA = ( TEMP*S( JE, JE ) )*ASCALE
               SBETA = ( TEMP*REAL( P( JE, JE ) ) )*BSCALE
               ACOEFF = SBETA*ASCALE
               BCOEFF = SALPHA*BSCALE
*
*              Scale to avoid underflow
*
               LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEFF ).LT.SMALL
               LSB = ABS1( SALPHA ).GE.SAFMIN .AND. ABS1( BCOEFF ).LT.
     $               SMALL
*
               SCALE = ONE
               IF( LSA )
     $            SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
               IF( LSB )
     $            SCALE = MAX( SCALE, ( SMALL / ABS1( SALPHA ) )*
     $                    MIN( BNORM, BIG ) )
               IF( LSA .OR. LSB ) THEN
                  SCALE = MIN( SCALE, ONE /
     $                    ( SAFMIN*MAX( ONE, ABS( ACOEFF ),
     $                    ABS1( BCOEFF ) ) ) )
                  IF( LSA ) THEN
                     ACOEFF = ASCALE*( SCALE*SBETA )
                  ELSE
                     ACOEFF = SCALE*ACOEFF
                  END IF
                  IF( LSB ) THEN
                     BCOEFF = BSCALE*( SCALE*SALPHA )
                  ELSE
                     BCOEFF = SCALE*BCOEFF
                  END IF
               END IF
*
               ACOEFA = ABS( ACOEFF )
               BCOEFA = ABS1( BCOEFF )
               XMAX = ONE
               DO 160 JR = 1, N
                  WORK( JR ) = CZERO
  160          CONTINUE
               WORK( JE ) = CONE
               DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
*
*              Triangular solve of  (a A - b B) x = 0  (columnwise)
*
*              WORK(1:j-1) contains sums w,
*              WORK(j+1:JE) contains x
*
               DO 170 JR = 1, JE - 1
                  WORK( JR ) = ACOEFF*S( JR, JE ) - BCOEFF*P( JR, JE )
  170          CONTINUE
               WORK( JE ) = CONE
*
               DO 210 J = JE - 1, 1, -1
*
*                 Form x(j) := - w(j) / d
*                 with scaling and perturbation of the denominator
*
                  D = ACOEFF*S( J, J ) - BCOEFF*P( J, J )
                  IF( ABS1( D ).LE.DMIN )
     $               D = CMPLX( DMIN )
*
                  IF( ABS1( D ).LT.ONE ) THEN
                     IF( ABS1( WORK( J ) ).GE.BIGNUM*ABS1( D ) ) THEN
                        TEMP = ONE / ABS1( WORK( J ) )
                        DO 180 JR = 1, JE
                           WORK( JR ) = TEMP*WORK( JR )
  180                   CONTINUE
                     END IF
                  END IF
*
                  WORK( J ) = CLADIV( -WORK( J ), D )
*
                  IF( J.GT.1 ) THEN
*
*                    w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling
*
                     IF( ABS1( WORK( J ) ).GT.ONE ) THEN
                        TEMP = ONE / ABS1( WORK( J ) )
                        IF( ACOEFA*RWORK( J )+BCOEFA*RWORK( N+J ).GE.
     $                      BIGNUM*TEMP ) THEN
                           DO 190 JR = 1, JE
                              WORK( JR ) = TEMP*WORK( JR )
  190                      CONTINUE
                        END IF
                     END IF
*
                     CA = ACOEFF*WORK( J )
                     CB = BCOEFF*WORK( J )
                     DO 200 JR = 1, J - 1
                        WORK( JR ) = WORK( JR ) + CA*S( JR, J ) -
     $                               CB*P( JR, J )
  200                CONTINUE
                  END IF
  210          CONTINUE
*
*              Back transform eigenvector if HOWMNY='B'.
*
               IF( ILBACK ) THEN
                  CALL CGEMV( 'N', N, JE, CONE, VR, LDVR, WORK, 1,
     $                        CZERO, WORK( N+1 ), 1 )
                  ISRC = 2
                  IEND = N
               ELSE
                  ISRC = 1
                  IEND = JE
               END IF
*
*              Copy and scale eigenvector into column of VR
*
               XMAX = ZERO
               DO 220 JR = 1, IEND
                  XMAX = MAX( XMAX, ABS1( WORK( ( ISRC-1 )*N+JR ) ) )
  220          CONTINUE
*
               IF( XMAX.GT.SAFMIN ) THEN
                  TEMP = ONE / XMAX
                  DO 230 JR = 1, IEND
                     VR( JR, IEIG ) = TEMP*WORK( ( ISRC-1 )*N+JR )
  230             CONTINUE
               ELSE
                  IEND = 0
               END IF
*
               DO 240 JR = IEND + 1, N
                  VR( JR, IEIG ) = CZERO
  240          CONTINUE
*
            END IF
  250    CONTINUE
      END IF
*
      RETURN
*
*     End of CTGEVC
*
      END


module initdata_module

  use amrex_paralleldescriptor_module, only: parallel_IOProcessor => amrex_pd_ioprocessor
  use network, only: nspec
  use amrex_fort_module, only : amrex_spacedim
  use base_state_geometry_module, only: nr_fine, max_radial_level, center
  use meth_params_module, only: nscal, rho_comp, rhoh_comp, temp_comp, spec_comp, pi_comp, &
       prob_lo, prob_hi, base_cutoff_density

  implicit none

  private

  ! width of the gaussian
  double precision, parameter :: W = 0.05

contains

  subroutine initdata(lev, time, lo, hi, &
       scal, scal_lo, scal_hi, nc_s, &
       vel, vel_lo, vel_hi, nc_v, &
       s0_init, p0_init, &
       dx) bind(C, name="initdata")

    integer         , intent(in   ) :: lev, lo(3), hi(3)
    integer         , intent(in   ) :: scal_lo(3), scal_hi(3), nc_s
    integer         , intent(in   ) :: vel_lo(3), vel_hi(3), nc_v
    double precision, intent(in   ) :: time
    double precision, intent(inout) :: scal(scal_lo(1):scal_hi(1), &
         scal_lo(2):scal_hi(2), &
         scal_lo(3):scal_hi(3), 1:nc_s)
    double precision, intent(inout) :: vel(vel_lo(1):vel_hi(1), &
         vel_lo(2):vel_hi(2), &
         vel_lo(3):vel_hi(3), 1:nc_v)
    double precision, intent(in   ) :: s0_init(0:max_radial_level,0:nr_fine-1,1:nscal)
    double precision, intent(in   ) :: p0_init(0:max_radial_level,0:nr_fine-1)
    double precision, intent(in   ) :: dx(3)

    integer          :: i,j,k

    double precision :: x, y, z, dist

    ! set velocity to zero
    vel(lo(1):hi(1),lo(2):hi(2),lo(3):hi(3),1:nc_v) = 0.0d0
    scal(lo(1):hi(1),lo(2):hi(2),lo(3):hi(3),1:nc_s) = 0.0d0

    do k=lo(3),hi(3)
       z = (dble(k)+0.5d0)*dx(3) + prob_lo(3) - center(3)
       do j=lo(2),hi(2)
          y = (dble(j)+0.5d0)*dx(2) + prob_lo(2) - center(2)
          do i=lo(1),hi(1)
             x = (dble(i)+0.5d0)*dx(1) + prob_lo(1) - center(1)

             dist = sqrt(x**2 + y**2 + z**2)

             scal(i,j,k,rho_comp)  = max(exp(-dist**2/W**2),base_cutoff_density)

             scal(i,j,k,spec_comp) = scal(i,j,k,rho_comp)

          end do
       end do
    end do

  end subroutine initdata

end module initdata_module


REAL*8 FUNCTION T3J (J1,J2,J3,M1,M2,M3)
  !
  !     ANGULAR MOMENTA ENTER WITH 2X ACTUAL VALUES
  !     ARRAY FCT MUST BE DECLARED AND FILLED GLOBALLY WITH
  !     J-FACTORIAL IN THE 2J+1 POSITION
  !     LARGEST  FACTORIAL NEEDED IS JA+JB+JC+1
  !     FUNCTION NOTRI(J,K,L) RETURNS 1 IF K,L,J FORM A TRIANGLE,-1 IF NOT
  !     FUNCTION PH IS NEEDED TO COMPUTE PHASES
  !     NOTRI AND M-TEST IN MAIN PROGRAM
  !
  use fact, only : FCT
  IMPLICIT REAL*8 (A-H,O-Z)
  !COMMON/FACT/FCT(100)
  T3J=0.
  K0=J1+J2-J3
  K1=J1-M1
  K2=J2+M2
  L1=J2-J3-M1
  L2=J1-J3+M2
  KMAX=MIN0(K1,K2,K0)+1
  KMIN=MAX0(0,L1,L2)+1
  C=SQRT(FCT(K0+1)*FCT(J1-J2+J3+1)*FCT(J2-J1+J3+1)/FCT(J1+J2+J3+3)*FCT(J1+M1+1)*FCT(K1+1)*FCT(J2-M2+1)*FCT(K2+1)*FCT(J3+M3+1)*FCT(J3-M3+1))
  DO I=KMIN,KMAX,2 ! 10
     K=I-1
     T3J=T3J+C*PH(K)/FCT(I)/FCT(K0-K+1)/FCT(K1-K+1)/FCT(K2-K+1)/FCT(I-L1)/FCT(I-L2)
  ENDDO

  T3J=PH(J1-J2-M3)*T3J
  RETURN
END FUNCTION T3J

REAL*8 FUNCTION T3J0(J1,J2,J3)
  use fact, only: FCT
  IMPLICIT REAL*8 (A-H,O-Z)
  !COMMON/FACT/FCT(100)
  J=J1+J2+J3
  F1=SQRT(FCT(J-2*J1+1)*FCT(J-2*J2+1)*FCT(J-2*J3+1)/FCT(J+3))
  F2=FCT(J/2+1)/FCT(J/2-J1+1)/FCT(J/2-J2+1)/FCT(J/2-J3+1)
  T3J0=PH(J/2)*F1*F2
  RETURN
END FUNCTION T3J0

REAL*8 FUNCTION PH(N)
  IMPLICIT REAL*8 (A-H,O-Z)
  PH=1.0D0
  K=MOD(IABS(N),4)
  IF(K.EQ.0) GOTO 5
  PH=-1.0D0
5 RETURN
END FUNCTION PH


!bloss#include <misc.h>
!bloss#include <params.h>
subroutine gffgch(t       ,es      ,itype   )
!-----------------------------------------------------------------------
!
! Purpose:
! Computes saturation vapor pressure over water and/or over ice using
! Goff & Gratch (1946) relationships.
! <Say what the routine does>
!
! Method:
! T (temperature), and itype are input parameters, while es (saturation
! vapor pressure) is an output parameter.  The input parameter itype
! serves two purposes: a value of zero indicates that saturation vapor
! pressures over water are to be returned (regardless of temperature),
! while a value of one indicates that saturation vapor pressures over
! ice should be returned when t is less than freezing degrees.  If itype
! is negative, its absolute value is interpreted to define a temperature
! transition region below freezing in which the returned
! saturation vapor pressure is a weighted average of the respective ice
! and water value.  That is, in the temperature range 0 => -itype
! degrees c, the saturation vapor pressures are assumed to be a weighted
! average of the vapor pressure over supercooled water and ice (all
! water at 0 c; all ice at -itype c).  Maximum transition range => 40 c
!
! Author: J. Hack
!
!-----------------------------------------------------------------------
   use shr_kind_mod, only: r4 => shr_kind_r4
!bloss   use physconst, only: tmelt
   use abortutils, only: endrun

   implicit none
!------------------------------Arguments--------------------------------
!
! Input arguments
!
   real, intent(in) :: t          ! Temperature
!
! Output arguments
!
   integer, intent(inout) :: itype   ! Flag for ice phase and associated transition

   real(r4), intent(out) :: es         ! Saturation vapor pressure
!
!---------------------------Local variables-----------------------------
!
   real(r4) e1         ! Intermediate scratch variable for es over water
   real(r4) e2         ! Intermediate scratch variable for es over water
   real(r4) eswtr      ! Saturation vapor pressure over water
   real(r4) f          ! Intermediate scratch variable for es over water
   real(r4) f1         ! Intermediate scratch variable for es over water
   real(r4) f2         ! Intermediate scratch variable for es over water
   real(r4) f3         ! Intermediate scratch variable for es over water
   real(r4) f4         ! Intermediate scratch variable for es over water
   real(r4) f5         ! Intermediate scratch variable for es over water
   real(r4) ps         ! Reference pressure (mb)
   real(r4) t0         ! Reference temperature (freezing point of water)
   real(r4) term1      ! Intermediate scratch variable for es over ice
   real(r4) term2      ! Intermediate scratch variable for es over ice
   real(r4) term3      ! Intermediate scratch variable for es over ice
   real(r4) tr         ! Transition range for es over water to es over ice
   real(r4) ts         ! Reference temperature (boiling point of water)
   real(r4) weight     ! Intermediate scratch variable for es transition
   integer itypo   ! Intermediate scratch variable for holding itype

   real(r4), parameter :: tmelt = 273.16
!
!-----------------------------------------------------------------------
!
! Check on whether there is to be a transition region for es
!
   if (itype < 0) then
      tr    = abs(float(itype))
      itypo = itype
      itype = 1
   else
      tr    = 0.0
      itypo = itype
   end if
   if (tr > 40.0) then
      write(6,900) tr
      call endrun ('GFFGCH')                ! Abnormal termination
   end if
!
   if(t < (tmelt - tr) .and. itype == 1) go to 10
!
! Water
!
   ps = 1013.246
   ts = 373.16
   e1 = 11.344*(1.0 - t/ts)
   e2 = -3.49149*(ts/t - 1.0)
   f1 = -7.90298*(ts/t - 1.0)
   f2 = 5.02808*log10(ts/t)
   f3 = -1.3816*(10.0**e1 - 1.0)/10000000.0
   f4 = 8.1328*(10.0**e2 - 1.0)/1000.0
   f5 = log10(ps)
   f  = f1 + f2 + f3 + f4 + f5
   es = (10.0**f)*100.0
   eswtr = es
!
   if(t >= tmelt .or. itype == 0) go to 20
!
! Ice
!
10 continue
   t0    = tmelt
   term1 = 2.01889049/(t0/t)
   term2 = 3.56654*log(t0/t)
   term3 = 20.947031*(t0/t)
   es    = 575.185606e10*exp(-(term1 + term2 + term3))
!
   if (t < (tmelt - tr)) go to 20
!
! Weighted transition between water and ice
!
   weight = min((tmelt - real(t,r4))/tr,1.0_r4)
   es = weight*es + (1.0 - weight)*eswtr
!
20 continue
   itype = itypo
   return
!
900 format('GFFGCH: FATAL ERROR ******************************',/, &
           'TRANSITION RANGE FOR WATER TO ICE SATURATION VAPOR', &
           ' PRESSURE, TR, EXCEEDS MAXIMUM ALLOWABLE VALUE OF', &
           ' 40.0 DEGREES C',/, ' TR = ',f7.2)
!
end subroutine gffgch


  !     *******************************************************
  !     START of dispersive PACK
  !     *******************************************************
  !==========================================================================
  !     AUTHOR: Dr. Roberto Capote Noy
  !
  !     e-mail: r.capotenoy@iaea.org ; rcapotenoy@yahoo.com;
  !
  !     DISPERSIVE OPTICAL MODEL POTENTIAL PACKAGE
  !
  !     Analytical dispersive integrals are included
  !     see Quesada JM, Capote R et al,
  !             Computer Physics Communications 153(2003) 97
  !             Phys. Rev. C67(2003) 067601
  !
  !     Dispersive integral's derivatives calculated by Dr.J.M.Quesada
  !
  !     Further coding July 2021 by Ian Thompson.
  !         Conversion to double precision everywhere.
  !
  !==========================================================================

  REAL*8 FUNCTION DOM_INT_Wv (Ef,Ep,Av,Bv,n,Einc,DerivIntWv)

    IMPLICIT NONE
    REAL*8 Ef,Ep,Av,Bv,E,pi,Einc
    REAL*8 E0,Ex,Eplus,Emin,Rs,ResEmin,ResEplus
    REAL*8 DerEmin, DerEplus, Rds, DerivIntWv
    DOUBLE COMPLEX Pj,I,Zj,Ztmp
    DOUBLE COMPLEX Fs,Ds
    INTEGER N,j,IS

    DATA I/(0.d0,1.d0)/

    pi=4.0*atan(1.0)

    IS = 1
    E = Einc
    IF(Einc.LE.Ef) THEN
      E=2.0*Ef-Einc
      IS = -1
    ENDIF

    E0 = Ep - Ef
    Ex = E  - Ef
    Eplus = Ex + E0
    Emin  = Ex - E0
    DOM_INT_Wv = 0.0
    DerivIntWv = 0.0

    ResEmin  =  Emin**n / (Emin**n + Bv**n)

    DerEmin  =  Emin**(n-1)* &
                ( Emin**n + Bv**n*(1.0 + n*log(ABS(Emin)) ) ) &
                / (Emin**n + Bv**n)**2

    ResEplus = -Eplus**n / (Eplus**n + Bv**n)

    DerEplus = -Eplus**(n-1) * &
                   ( Eplus**n + Bv**n*(1.0+n*log(Eplus)) ) &
                   / (Eplus**n + Bv**n)**2

    Fs = (0.d0,0.d0)
    Ds = (0.d0,0.d0)
    DO j=1,n
      Ztmp = I*(2*j-1)/dble(n)*pi
      Pj = Bv*exp(Ztmp)
      Zj = Pj * (2*Pj +Eplus -Emin) * Ex
      Zj = Zj / ( (Pj+E0) * (Pj+Eplus) * (Pj-Emin) )
      Fs = Fs + Zj*log(-Pj)
      Ds = Ds + 2*Pj*(Ex*Ex + (Pj+E0)**2)*log(-Pj) &
                  /( (Pj+Eplus)**2 * (Pj-Emin)**2 )
    ENDDO

    IF(ABS(IMAG(Fs)).gt.1.d-4) STOP 'Too big imag part in Wv'
    IF(ABS(IMAG(Ds)).gt.1.d-4) STOP 'Too big imag deriv in Wv'
    Rs  = DBLE(Fs)
    Rds = DBLE(Ds)
    DOM_INT_Wv = -Av/pi*IS* &
        (Rs/n  + ResEplus*log(Eplus) + ResEmin*log(ABS(Emin)))
    DerivIntWv =  Av/pi*IS*( Rds/n + DerEplus + DerEmin)

    RETURN
  END FUNCTION DOM_INT_Wv

  REAL*8 FUNCTION DOM_INT_Ws (Ef,Ep,As,Bs,Cs,m,Einc,DerivIntWs)

    IMPLICIT NONE
    REAL*8 Ef,Ep,As,Bs,Cs,E,Einc
    DOUBLE COMPLEX I,Pj,Zj,Ztmp
    REAL*8 Emin,Eplus,E0,Ex,pi
    REAL*8 Rs,ResEmin,ResEplus
    REAL*8 DerivIntWs,DerEmin,DerEplus,Rds
    INTEGER m,j,IS
    DOUBLE COMPLEX Fs,Ds,zfi
    REAL*8 EIn

    DATA I/(0.d0,1.d0)/

    pi=4.0*atan(1.0)

    IS = 1
    E = Einc
    IF(Einc.LE.Ef) THEN
      E=2.0*Ef-Einc
      IS = -1
    ENDIF

    E0 = Ep - Ef
    Ex = E  - Ef
    Eplus = Ex + E0
    Emin  = Ex - E0
    DOM_INT_Ws = 0.0
    DerivIntWs = 0.0
    ResEmin  =  Emin**m / (Emin**m + Bs**m)

    DerEmin  = -Emin**(m-1) * &
                 ( Emin**m + Bs**m + ( -Cs*Emin**(m+1) + &
                Bs**m *(-Cs*Emin+m) ) * exp(-Cs*Emin)*EIn(Cs*Emin) ) &
                / (Emin**m + Bs**m)**2

    ResEplus = -Eplus**m / (Eplus**m + Bs**m)

    DerEplus =  Eplus**(m-1) * &
                  ( Eplus**m + Bs**m + ( Cs*Eplus**(m+1) + &
                   Bs**m *(Cs*Eplus+m) ) * exp(Cs*Eplus)*EIn(-Cs*Eplus) ) &
                   / (Eplus**m + Bs**m)**2

    Fs = (0.d0,0.d0)
    Ds = (0.d0,0.d0)
    DO j=1,m
         Ztmp = I*(2*j-1)/dble(m)*pi
         Pj = Bs*exp(Ztmp)
         Zj = Pj * (2*Pj +Eplus -Emin) * Ex
         Zj = Zj / (Pj+E0) / (Pj+Eplus) / (Pj-Emin)
         Fs = Fs + Zj* zfi(-Pj*Cs)
         Ds = Ds + 2*Pj*(Ex*Ex + (Pj+E0)**2)*zfi(-Pj*Cs) &
                  /( (Pj+Eplus)**2 * (Pj-Emin)**2 )
    ENDDO

    IF(ABS(IMAG(Fs)).GT.1.d-4) STOP 'Too big imag part in Ws'
    IF(ABS(IMAG(Ds)).GT.1.d-4) STOP 'Too big imag deriv in Ws'
    Rs = DBLE(Fs)
    Rds = DBLE(Ds)

    DOM_INT_Ws = As/pi*IS*(Rs/m &
                         - ResEplus*exp(Cs*Eplus)*EIn(-Cs*Eplus) &
                         - ResEmin*exp(-Cs*Emin)*EIn(Cs*Emin) )
    RETURN
  END FUNCTION DOM_INT_Ws

  REAL*8 FUNCTION WV(A,B,Ep,Ef,E,n)

    IMPLICIT NONE
    REAL*8  A,B,Ep,Ef,E,ee
    INTEGER n
    WV=0.d0
    IF(E.LE.Ef) E=2.d0*Ef-E
    IF(E.LT.Ep) RETURN
    ee=(E-Ep)**n
    WV=A*ee/(ee+B**n)
    RETURN
  END FUNCTION WV

  REAL*8 FUNCTION WDD(A,B,C,Ep,Ef,E,m)
    IMPLICIT NONE
    REAL*8 A,B,C,Ep,Ef,E,ee,arg
    INTEGER m
    WDD=0.d0
    IF(E.LE.Ef) E=2.d0*Ef-E
    IF(E.LT.Ep) RETURN
    arg=C*(E-Ep)
    IF(arg.GT.15) RETURN
    ee=(E-Ep)**m
    WDD=A*ee/(ee+B**m)*EXP(-arg)
    RETURN
  END FUNCTION WDD

  REAL*8 FUNCTION DOM_int_T1(Ef,Ea,E)

    IMPLICIT NONE
    REAL*8 E,Ea,Ef,Ex,Ea2,Eax,Pi,T11,T12,T13
    Pi=4.0*ATAN(1.0)
    Ex=E-Ef
    Ea2=Ea**2
    Eax=Ex+Ea
    T11 = 0.5d0*log(Ea)/Ex
    T12 =  ( (2*Ea+Ex)*log(Ea)+0.5d0*pi*Ex ) &
             /(2.*(Eax**2 + Ea2))
    T13 = -Eax**2*log(Eax)/(Ex*(Eax**2+Ea2))
    DOM_int_T1 = Ex/Pi*(T11+T12+T13)
    RETURN
  END FUNCTION DOM_int_T1

  REAL*8 FUNCTION DOM_int_T2(Ef,Ea,E)

    IMPLICIT NONE
    REAL*8 E,Ea,Ef,EL,Pi
    Pi=4.0*ATAN(1.0)
    EL=Ef+Ea
    DOM_int_T2= 1.0 / Pi * ( &
             sqrt(abs(Ef)) * atan( (2*sqrt(EL*abs(Ef)))/(EL-abs(Ef)) ) &
        +    EL**1.50/(2*Ef)*log(Ea/EL) )
    IF(E.GT.EL) THEN
      DOM_int_T2 = DOM_int_T2 + 1.0/Pi* ( &
         sqrt(E) * log( (sqrt(E)+sqrt(EL)) / (sqrt(E)-sqrt(EL)) ) + &
         1.50*sqrt(EL)*log((E-EL)/Ea) + EL**1.50/(2*E)*log(EL/(E-EL)) )
    ELSEIF(E.EQ.EL) THEN
      DOM_int_T2 = DOM_int_T2 + 1.0/Pi*1.50*sqrt(EL) &
        *log((2**(4.0/3.0)*EL)/Ea)
    ELSEIF(E.GT.0.d0 .AND. E.LE.EL) THEN
      DOM_int_T2 = DOM_int_T2 + 1.0/Pi * ( &
        sqrt(e) * log( (sqrt(E)+sqrt(EL)) / (sqrt(EL)-sqrt(E)) ) + &
        1.50*sqrt(EL)*log((EL-E)/Ea)+EL**1.50/(2.0*E)*log(EL/(EL-E)) )
    ELSEIF(abs(E)<1e-10) then
      DOM_int_T2 = DOM_int_T2 + 1.0/Pi*( 1.5*sqrt(EL) &
        * log(EL/Ea) + 0.50*sqrt(EL) )
    ELSE
      DOM_int_T2 = DOM_int_T2 + 1.0/Pi * ( &
        -sqrt(abs(E))*atan( 2*(sqrt(EL*abs(E))) / (EL-abs(E)) ) + &
        1.50*sqrt(EL)*log((EL-E)/Ea)+EL**1.50/(2.0*E)*log(EL/(EL-E)) )
    ENDIF
  	!write(101,*) E,DOM_int_T2,Ef,Ea
    RETURN
  END FUNCTION DOM_int_T2

  DOUBLE COMPLEX FUNCTION zfi(za)

    IMPLICIT NONE
    REAL*8 aj
    DOUBLE COMPLEX za,y
    INTEGER m,i
    zfi=0.d0
    IF (za.EQ.0.d0) RETURN
    IF (abs(real(za)+18.5d0).GE.25.d0) GO TO 3
    IF (SQRT(625.d0-(DBLE(za)+18.5d0)**2)/1.665d0.LT.ABS(imag(za))) GO TO 3
    zfi=-.57721566490153d0-log(za)
    y=1.d0
    DO 1 m=1,2000
      aj=m
      y=-y*za/aj
      IF (ABS(y).lt.1.d-15*ABS(zfi)) GO TO 2
        zfi=zfi-y/aj
      1 continue
      2 zfi=EXP(za)*zfi
        RETURN
      3 DO 4 i=1,20
          aj=21-i
          zfi=aj/(za+zfi)
            zfi=aj/(1.d0+zfi)
          4 continue
          zfi=1.d0/(zfi+za)
    RETURN
  END FUNCTION zfi

  REAL*8 FUNCTION EIn(X)

    IMPLICIT NONE
    REAL*8 FAC, H, X
    INTEGER N
    EIn = 0.57721566490153d0+LOG(ABS(X))
    FAC = 1.0
    DO N = 1,100
      H = FLOAT(N)
      FAC = FAC*H
      EIn = EIn + X**N/(H*FAC)
    ENDDO
    RETURN
  END FUNCTION EIn

  SUBROUTINE dispers2(A,Z,k,eopt, &
  v,rvv,avv, dv,drv,dav, dvs,drs,das, w,rw,aw, wd,rwd,awd, &
  vso,rvso,avso,dvso, wso,rwso,awso, &
  Vlin,Vdep,lambdaHF,Cviso,Vso0,lambdaso,Ccoul, &
  AAv,BBv,W0l,W0dep,BBs,CCs,Cwiso,Wso0,BBso, &
  Ea,alpha,eferm,Ades, &
  rHFl,rHFdep,aHFl,aHFdep,rv,avpot, &
  rsl,rsdep,as, &
  rso,aso)

    implicit REAL*8(A-H,O-Z)
    REAL*8 eopt,asym,eferm,f,Cviso,Ccoul,Cwiso
    REAL*8 lambdaHF,lambdaso,Ades
    pi = 4.d0*atan(1.d0)
    !
    ! *** Parameters definitions of Soukhovitskii, Capote, Quesada, Chiba and Martyanov (Nov 25, 2015) ***
    ! *** with Asymmetrical W energy-dependence
    ! *** dispers2:  T1 integral with correct coefficient
    ! *** done by Ian Thompson
    ! k         : designator for particle
    ! Z         : charge number of residual nucleus
    ! A         : mass number of residual nucleus
    ! eopt      : incident energy
    ! asym      : asymmetry parameter
    ! eferm     : Fermi energy
    ! f         : eopt-eferm

    Au = A-Ades
    asym=(A-2.*Z)/A
    V0 = Vlin + Vdep*Au
    rHF = rHFL + rHFdep * Au
    aHF = aHFl + aHFdep * Au
    W0 = W0l + W0dep*Au
    av = avpot
    rs = rsl + rsdep * Au
    AAHF = V0 * (1 + (-1)**k * Cviso*asym/V0)
    AAs  = W0 * (1 + (-1)**k * Cwiso*asym/W0)
    eoffset = 0.
    IF (k==2) eoffset =  Ccoul * Z/A**(1./3.)
    Eeff = eopt - eoffset
    f = Eeff  - eferm
    v = AAHF * EXP(-lambdaHF*f)
    vso=Vso0*EXP(-lambdaso*f)

    ! sources of dispersive terms
    w = AAv * f*f/(f*f + BBv**2)
    IF(f < -Ea) THEN
      fe  = f + Ea
      w = w * (1 - fe*fe/(fe*fe + Ea*Ea))
    ELSE IF(f>Ea) THEN
      w = w + alpha * (SQRT(Eeff) + (eferm+Ea)**1.50/(2*Eeff) &
           - 1.50*SQRT(eferm+Ea))
    endif
    wd = AAs * f*f/(f*f + BBs**2) * EXP( -CCs * ABS(f))
    wso=Wso0* f*f/(f*f + BBso**2)
    ! dispersive terms to add for real volume and real surface forms
    drv= rv;  dav = av
    drs = rs; das = as
    dvs = DOM_INT_Ws (eferm,eferm,AAs,BBs,CCs,2,Eeff,DerivIntWs)
    DWv = DOM_INT_Wv (eferm,eferm,AAv,BBv,2,Eeff,DerivIntWv)
    T1 = DOM_int_T1(eferm,Ea,Eeff) * AAv * Ea*Ea/(Ea*Ea + BBv**2)
    T2 = DOM_int_T2(eferm,Ea,Eeff) * alpha
    dv = DWv + T1 + T2
    dvso = DOM_INT_Wv (eferm,eferm,Wso0,BBso,2,Eeff,DerivIntWv)

    ! name translations
    rvv = rHF ; avv = aHF
    rvso = rso; avso = aso
    rwso = rso; awso = aso
    rw  = rv  ; aw   = av
    rwd = rs  ; awd  = as
    RETURN
  END SUBROUTINE dispers2

  ! ***********************************************************
  ! *                    END of dispersive                    *
  ! ***********************************************************


SUBROUTINE stiff6(km,coord,ym,pr)
!
!    exact stiffness matrix of a 6-node triangle
!    with straight sides in plane strain
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::coord(6,2),ym,pr
 REAL(iwp),INTENT(OUT)::km(12,12)
 REAL(iwp)::x1,x3,x5,y1,y3,y5,cf
 REAL(iwp)::d0=0._iwp,d1=1._iwp,d2=2._iwp,d3=3._iwp,d4=4._iwp,d12=12._iwp
 x1=coord(1,1)
 y1=coord(1,2)
 x3=coord(3,1)
 y3=coord(3,2)
 x5=coord(5,1)
 y5=coord(5,2)
 cf=ym/(-d1+d2*pr)/(d1+pr)/(x1*y3-x1*y5+x3*y5-y1*x3+y1*x5-y3*x5)
!----------------------------------------------------------------------------
 km(1,1)=-(-d2*y3**2+d2*y3**2*pr+d4*y3*y5-d4*y3*y5*pr-d2*y5**2+           &
   d2*y5**2*pr-x3**2+d2*x3**2*pr+d2*x3*x5-d4*x3*x5*pr-x5**2+              &
   d2*x5**2*pr)/d4*cf
 km(1,2)=-(x3-x5)*(y3-y5)/d4*cf
 km(1,3)=(d2*y3*y5-d2*y5**2+d2*y5**2*pr+x3*x5-x5**2+d2*x5**2*pr+d2*y5*y1+ &
   x5*x1-x3*x1-d2*y3*y5*pr-d2*x5*x1*pr+d2*pr*y3*y1-d2*y5*pr*y1+           &
   d2*x3*x1*pr-d2*x3*x5*pr-d2*y3*y1)/d3*cf
 km(1,4)=(d2*pr*y3*x1-d2*pr*y5*x1+d2*x5*y1*pr-d2*x3*y1*pr+x5*y5-y1*x5+    &
   y1*x3-x3*y5+d2*pr*x3*y5-d2*pr*y3*x5)/d3*cf
 km(1,5)=-(d2*y3*y5-d2*y5**2+d2*y5**2*pr+x3*x5-x5**2+d2*x5**2*pr+         &
   d2*y5*y1+x5*x1-x3*x1-d2*y3*y5*pr-d2*x5*x1*pr+d2*pr*y3*y1-d2*y5*pr*y1+  &
   d2*x3*x1*pr-d2*x3*x5*pr-d2*y3*y1)/d12*cf
 km(1,6)=-(d2*pr*y3*x1-d2*pr*y5*x1+d2*x5*y1*pr-d2*x3*y1*pr+x5*y5-y1*x5+   &
   y1*x3-x3*y5+d2*pr*x3*y5-d2*pr*y3*x5)/d12*cf
 km(1,7)=d0
 km(1,8)=d0
 km(1,9)=(-x3*x5-d2*y3*y1+x5*x1-x3*x1+d2*y5*y1+d2*pr*y3*y1-d2*y3*y5+      &
   d2*x3*x1*pr-d2*y3**2*pr-d2*x3**2*pr-d2*y5*pr*y1+d2*x3*x5*pr+d2*y3**2-  &
   d2*x5*x1*pr+x3**2+d2*y3*y5*pr)/d12*cf
 km(1,10)=(-d2*pr*y5*x1+d2*pr*x3*y5-d2*x3*y1*pr+d2*x5*y1*pr-d2*pr*y3*x5+  &
   y3*x5-y1*x5+y1*x3-y3*x3+d2*pr*y3*x1)/d12*cf
 km(1,11)=-(-x3*x5-d2*y3*y1+x5*x1-x3*x1+d2*y5*y1+d2*pr*y3*y1-d2*y3*y5+    &
   d2*x3*x1*pr-d2*y3**2*pr-d2*x3**2*pr-d2*y5*pr*y1+d2*x3*x5*pr+d2*y3**2-  &
   d2*x5*x1*pr+x3**2+d2*y3*y5*pr)/d3*cf
 km(1,12)=-(-d2*pr*y5*x1+d2*pr*x3*y5-d2*x3*y1*pr+d2*x5*y1*pr-d2*pr*y3*x5+ &
   y3*x5-y1*x5+y1*x3-y3*x3+d2*pr*y3*x1)/d3*cf
!--------------------------------------------------------------------------
 km(2,2)=-(-d2*x3**2+d4*x3*x5-d2*x5**2+d2*x3**2*pr-d4*x3*x5*pr+           &
   d2*x5**2*pr-y3**2+d2*y3**2*pr+d2*y3*y5-d4*y3*y5*pr-y5**2+              &
   d2*y5**2*pr)/d4*cf
 km(2,3)=-(d2*pr*y3*x1-d2*pr*y5*x1+d2*x5*y1*pr-d2*x3*y1*pr-x5*y5+y3*x5-   &
   x1*y3+x1*y5+d2*pr*x3*y5-d2*pr*y3*x5)/d3*cf
 km(2,4)=(y3*y5-y5**2+d2*y5**2*pr+d2*x3*x5-d2*x5**2+d2*x5**2*pr+y5*y1+    &
   d2*x5*x1-d2*x3*x1-d2*y3*y5*pr-d2*x5*x1*pr+d2*pr*y3*y1-d2*y5*pr*y1+     &
   d2*x3*x1*pr-d2*x3*x5*pr-y3*y1)/d3*cf
 km(2,5)=(d2*pr*y3*x1-d2*pr*y5*x1+d2*x5*y1*pr-d2*x3*y1*pr-x5*y5+y3*x5-    &
   x1*y3+x1*y5+d2*pr*x3*y5-d2*pr*y3*x5)/d12*cf
 km(2,6)=-(y3*y5-y5**2+d2*y5**2*pr+d2*x3*x5-d2*x5**2+d2*x5**2*pr+y5*y1+   &
   d2*x5*x1-d2*x3*x1-d2*y3*y5*pr-d2*x5*x1*pr+d2*pr*y3*y1-d2*y5*pr*y1+     &
   d2*x3*x1*pr-d2*x3*x5*pr-y3*y1)/d12*cf
 km(2,7)=d0
 km(2,8)=d0
 km(2,9)=-(-d2*pr*y5*x1+d2*pr*x3*y5-d2*x3*y1*pr+d2*x5*y1*pr-d2*pr*y3*x5+  &
   x1*y5-x1*y3-x3*y5+y3*x3+d2*pr*y3*x1)/d12*cf
 km(2,10)=(d2*x3*x1*pr-d2*x5*x1*pr-d2*y5*pr*y1+d2*pr*y3*y1+d2*x3*x5*pr+   &
   y3**2+d2*y3*y5*pr+d2*x3**2-d2*y3**2*pr-y3*y5+y5*y1-y3*y1-d2*x3*x5+     &
   d2*x5*x1-d2*x3*x1-d2*x3**2*pr)/d12*cf
 km(2,11)=(-d2*pr*y5*x1+d2*pr*x3*y5-d2*x3*y1*pr+d2*x5*y1*pr-d2*pr*y3*x5+  &
   x1*y5-x1*y3-x3*y5+y3*x3+d2*pr*y3*x1)/d3*cf
 km(2,12)=-(d2*x3*x1*pr-d2*x5*x1*pr-d2*y5*pr*y1+d2*pr*y3*y1+d2*x3*x5*pr+  &
   y3**2+d2*y3*y5*pr+d2*x3**2-d2*y3**2*pr-y3*y5+y5*y1-y3*y1-d2*x3*x5+     &
   d2*x5*x1-d2*x3*x1-d2*x3**2*pr)/d3*cf
!--------------------------------------------------------------------------
 km(3,3)=-d2/d3*(-d2*y3**2+d2*y3*y5-d2*y5**2+d2*y3**2*pr+d2*y5**2*pr-     &
   x3**2+x3*x5-x5**2+d2*x3**2*pr+d2*x5**2*pr+d2*pr*y1**2-d2*y1**2+        &
   d2*x1**2*pr-x1**2+d2*y5*y1+x5*x1+x3*x1-d2*y3*y5*pr-d2*x5*x1*pr-        &
   d2*pr*y3*y1-d2*y5*pr*y1-d2*x3*x1*pr-d2*x3*x5*pr+d2*y3*y1)*cf
 km(3,4)=-(d2*x5*y5-y3*x5-y1*x5-x3*y5+d2*y3*x3-y1*x3-x1*y5-x1*y3+         &
   d2*x1*y1)/d3*cf
 km(3,5)=km(1,3)
 km(3,6)=km(1,4)
 km(3,7)=-d2/d3*(-x3*x5-d2*y3*y1+x5*x1-x3*x1+d2*y5*y1+d2*pr*y3*y1-        &
   d2*y3*y5+d2*x3*x1*pr-d2*y3**2*pr-d2*x3**2*pr-d2*y5*pr*y1+d2*x3*x5*pr+  &
   d2*y3**2-d2*x5*x1*pr+x3**2+d2*y3*y5*pr)*cf
 km(3,8)=-(-y1*x5+y3*x5+y1*x3+x1*y3-x1*y5+x3*y5-d2*y3*x3)/d3*cf
 km(3,9)=d0
 km(3,10)=d0
 km(3,11)=d2/d3*(-d2*y3*y5-x3*x5+d2*pr*y1**2-d2*y1**2+d2*x1**2*pr-x1**2+  &
   d2*y5*y1+x5*x1+x3*x1+d2*y3*y5*pr-d2*x5*x1*pr-d2*pr*y3*y1-d2*y5*pr*y1-  &
   d2*x3*x1*pr+d2*x3*x5*pr+d2*y3*y1)*cf
 km(3,12)=(d2*x1*y1-y1*x5+y3*x5-y1*x3-x1*y3-x1*y5+x3*y5)/d3*cf
!--------------------------------------------------------------------------
 km(4,4)=-d2/d3*(-y3**2+y3*y5-y5**2+d2*y3**2*pr+d2*y5**2*pr-d2*x3**2+     &
   d2*x3*x5-d2*x5**2+d2*x3**2*pr+d2*x5**2*pr+d2*pr*y1**2-y1**2+           &
   d2*x1**2*pr-d2*x1**2+y5*y1+d2*x5*x1+d2*x3*x1-d2*y3*y5*pr-d2*x5*x1*pr-  &
   d2*pr*y3*y1-d2*y5*pr*y1-d2*x3*x1*pr-d2*x3*x5*pr+y3*y1)*cf
 km(4,5)=km(2,3)
 km(4,6)=km(2,4)
 km(4,7)=km(3,8)
 km(4,8)=-d2/d3*(d2*x3*x1*pr-d2*x5*x1*pr-d2*y5*pr*y1+d2*pr*y3*y1+         &
   d2*x3*x5*pr+y3**2+d2*y3*y5*pr+d2*x3**2-d2*y3**2*pr-y3*y5+y5*y1-y3*y1-  &
   d2*x3*x5+d2*x5*x1-d2*x3*x1-d2*x3**2*pr)*cf
 km(4,9)=d0
 km(4,10)=d0
 km(4,11)=km(3,12)
 km(4,12)=d2/d3*(-y3*y5-d2*x3*x5+d2*pr*y1**2-y1**2+d2*x1**2*pr-d2*x1**2+  &
   y5*y1+d2*x5*x1+d2*x3*x1+d2*y3*y5*pr-d2*x5*x1*pr-d2*pr*y3*y1-           &
   d2*y5*pr*y1-d2*x3*x1*pr+d2*x3*x5*pr+y3*y1)*cf
!--------------------------------------------------------------------------
 km(5,5)=-(-d2*y5**2+d4*y5*y1-d2*y1**2+d2*y5**2*pr-d4*y5*pr*y1+           &
   d2*pr*y1**2-x1**2+d2*x1**2*pr+d2*x5*x1-d4*x5*x1*pr-x5**2+              &
   d2*x5**2*pr)/d4*cf
 km(5,6)=-(x1-x5)*(-y5+y1)/d4*cf
 km(5,7)=(-d2*y3*y5-x3*x5+d2*pr*y1**2-d2*y1**2+d2*x1**2*pr-x1**2+         &
   d2*y5*y1+x5*x1+x3*x1+d2*y3*y5*pr-d2*x5*x1*pr-d2*pr*y3*y1-d2*y5*pr*y1-  &
   d2*x3*x1*pr+d2*x3*x5*pr+d2*y3*y1)/d3*cf
 km(5,8)=(-d2*pr*y3*x5-d2*pr*y5*x1+d2*x5*y1*pr-y1*x5+y3*x5+x1*y1+         &
   d2*pr*y3*x1-x1*y3-d2*x3*y1*pr+d2*pr*x3*y5)/d3*cf
 km(5,9)=-(-d2*y3*y5-x3*x5+d2*pr*y1**2-d2*y1**2+d2*x1**2*pr-x1**2+        &
   d2*y5*y1+x5*x1+x3*x1+d2*y3*y5*pr-d2*x5*x1*pr-d2*pr*y3*y1-d2*y5*pr*y1-  &
   d2*x3*x1*pr+d2*x3*x5*pr+d2*y3*y1)/d12*cf
 km(5,10)=-(-d2*pr*y3*x5-d2*pr*y5*x1+d2*x5*y1*pr-y1*x5+y3*x5+x1*y1+       &
   d2*pr*y3*x1-x1*y3-d2*x3*y1*pr+d2*pr*x3*y5)/d12*cf
 km(5,11)=d0
 km(5,12)=d0
!--------------------------------------------------------------------------
 km(6,6)=-(-d2*x1**2+d4*x5*x1-d2*x5**2+d2*x1**2*pr-d4*x5*x1*pr+           &
   d2*x5**2*pr-y5**2+d2*y5**2*pr+d2*y5*y1-d4*y5*pr*y1-y1**2+              &
   d2*pr*y1**2)/d4*cf
 km(6,7)=-(-d2*x3*y1*pr+d2*pr*x3*y5-d2*pr*y5*x1+d2*x5*y1*pr-d2*pr*y3*x5+  &
   d2*pr*y3*x1+x1*y5-x3*y5-x1*y1+y1*x3)/d3*cf
 km(6,8)=(-y3*y5-d2*x3*x5+d2*pr*y1**2-y1**2+d2*x1**2*pr-d2*x1**2+y5*y1+   &
   d2*x5*x1+d2*x3*x1+d2*y3*y5*pr-d2*x5*x1*pr-d2*pr*y3*y1-d2*y5*pr*y1-     &
   d2*x3*x1*pr+d2*x3*x5*pr+y3*y1)/d3*cf
 km(6,9)=(-d2*x3*y1*pr+d2*pr*x3*y5-d2*pr*y5*x1+d2*x5*y1*pr-d2*pr*y3*x5+   &
   d2*pr*y3*x1+x1*y5-x3*y5-x1*y1+y1*x3)/d12*cf
 km(6,10)=-(-y3*y5-d2*x3*x5+d2*pr*y1**2-y1**2+d2*x1**2*pr-d2*x1**2+y5*y1+ &
   d2*x5*x1+d2*x3*x1+d2*y3*y5*pr-d2*x5*x1*pr-d2*pr*y3*y1-d2*y5*pr*y1-     &
   d2*x3*x1*pr+d2*x3*x5*pr+y3*y1)/d12*cf
 km(6,11)=d0
 km(6,12)=d0
!--------------------------------------------------------------------------
 km(7,7)=km(3,3)
 km(7,8)=km(3,4)
 km(7,9)=km(5,7)
 km(7,10)=km(5,8)
 km(7,11)=d2/d3*(d2*y3*y5-d2*y5**2+d2*y5**2*pr+x3*x5-x5**2+d2*x5**2*pr+   &
   d2*y5*y1+x5*x1-x3*x1-d2*y3*y5*pr-d2*x5*x1*pr+d2*pr*y3*y1-d2*y5*pr*y1+  &
   d2*x3*x1*pr-d2*x3*x5*pr-d2*y3*y1)*cf
!--------------------------------------------------------------------------
 km(7,12)=(d2*x5*y5-y1*x5-y3*x5+y1*x3+x1*y3-x1*y5-x3*y5)/d3*cf
 km(8,8)=km(4,4)
 km(8,9)=km(6,7)
 km(8,10)=km(6,8)
 km(8,11)=km(7,12)
 km(8,12)=d2/d3*(y3*y5-y5**2+d2*y5**2*pr+d2*x3*x5-d2*x5**2+d2*x5**2*pr+   &
   y5*y1+d2*x5*x1-d2*x3*x1-d2*y3*y5*pr-d2*x5*x1*pr+d2*pr*y3*y1-           &
   d2*y5*pr*y1+d2*x3*x1*pr-d2*x3*x5*pr-y3*y1)*cf
!--------------------------------------------------------------------------
 km(9,9)=-(-d2*y1**2+d4*y3*y1-d2*y3**2+d2*pr*y1**2-d4*pr*y3*y1+           &
   d2*y3**2*pr-x1**2+d2*x1**2*pr+d2*x3*x1-d4*x3*x1*pr-x3**2+              &
   d2*x3**2*pr)/d4*cf
 km(9,10)=-(x1-x3)*(y1-y3)/d4*cf
 km(9,11)=km(1,11)
 km(9,12)=km(2,11)
!--------------------------------------------------------------------------
 km(10,10)=-(d2*x3**2*pr-y1**2-d2*x3**2+d2*y3*y1+d2*x1**2*pr+d2*y3**2*pr- &
   y3**2-d2*x1**2+d2*pr*y1**2+d4*x3*x1-d4*pr*y3*y1-d4*x3*x1*pr)/d4*cf
 km(10,11)=km(1,12)
 km(10,12)=km(2,12)
!--------------------------------------------------------------------------
 km(11,11)=km(3,3)
 km(11,12)=km(3,4)
!--------------------------------------------------------------------------
 km(12,12)=km(4,4)
!---------------------------------LOWER TRIANGLE---------------------------
 km(2,1)=km(1,2)
 km(3,1)=km(1,3)
 km(3,2)=km(2,3)
 km(4,1)=km(1,4)
 km(4,2)=km(2,4)
 km(4,3)=km(3,4)
 km(5,1)=km(1,5)
 km(5,2)=km(2,5)
 km(5,3)=km(3,5)
 km(5,4)=km(4,5)
 km(6,1)=km(1,6)
 km(6,2)=km(2,6)
 km(6,3)=km(3,6)
 km(6,4)=km(4,6)
 km(6,5)=km(5,6)
 km(7,1)=km(1,7)
 km(7,2)=km(2,7)
 km(7,3)=km(3,7)
 km(7,4)=km(4,7)
 km(7,5)=km(5,7)
 km(7,6)=km(6,7)
 km(8,1)=km(1,8)
 km(8,2)=km(2,8)
 km(8,3)=km(3,8)
 km(8,4)=km(4,8)
 km(8,5)=km(5,8)
 km(8,6)=km(6,8)
 km(8,7)=km(7,8)
 km(9,1)=km(1,9)
 km(9,2)=km(2,9)
 km(9,3)=km(3,9)
 km(9,4)=km(4,9)
 km(9,5)=km(5,9)
 km(9,6)=km(6,9)
 km(9,7)=km(7,9)
 km(9,8)=km(8,9)
 km(10,1)=km(1,10)
 km(10,2)=km(2,10)
 km(10,3)=km(3,10)
 km(10,4)=km(4,10)
 km(10,5)=km(5,10)
 km(10,6)=km(6,10)
 km(10,7)=km(7,10)
 km(10,8)=km(8,10)
 km(10,9)=km(9,10)
 km(11,1)=km(1,11)
 km(11,2)=km(2,11)
 km(11,3)=km(3,11)
 km(11,4)=km(4,11)
 km(11,5)=km(5,11)
 km(11,6)=km(6,11)
 km(11,7)=km(7,11)
 km(11,8)=km(8,11)
 km(11,9)=km(9,11)
 km(11,10)=km(10,11)
 km(12,1)=km(1,12)
 km(12,2)=km(2,12)
 km(12,3)=km(3,12)
 km(12,4)=km(4,12)
 km(12,5)=km(5,12)
 km(12,6)=km(6,12)
 km(12,7)=km(7,12)
 km(12,8)=km(8,12)
 km(12,9)=km(9,12)
 km(12,10)=km(10,12)
 km(12,11)=km(11,12)
RETURN
END SUBROUTINE stiff6


      subroutine unique_elements(i, j, n, nu)
!
!     Given an integer vector i(n), sort the vector
!     in ascending order and then fill the integer vector
!     j(nu) with the ascending unique entries of j(n).
!
!     Input:  i ,n
!     Output: j, nu
!
      implicit none
      integer n, nu, k, iflag
      integer i(n), j(n)
!
!     Fill j with i
!
      do k = 1, n
         j(k) = i(k)
      enddo
!
!     Sort and reorder j in ascending order
!
      iflag = 1
      call isort(j,j,n,iflag)
!
!     Compact the entries in j so that only the unique
!     entries are kept.
!
      nu = 1
      do k = 2, n
        if(j(k) .ne. j(k-1))then
           nu = nu + 1
           j(nu) = j(k)
        endif
      enddo
!
!     Fill the extra space at the end, if it exists, with
!     a value 1 smaller than the smallest j(1) entry.
      if(nu+1 .lt. n)then
      do k = nu+1, n
        j(k) = j(1) - 1
      enddo
      endif

      return
      end subroutine unique_elements


! PR libfortran/18025  <coudert@clipper.ens.fr>
! { dg-do run }
  character(len=80) :: c
  write(c, "('#',F0.2,'#')") 1.23
  if (c /= '#1.23#') call abort
  write(c, "('#',F0.2,'#')") -1.23
  if (c /= '#-1.23#') call abort
  end