      double precision function vdvgf(lambda,gamma)
!     function G(lambda,gamma) from e.g
!     Van der Veen (1998) , Cold Regions Sci. Tech. vol 27 p 231
!     Eqn (4)
      implicit none
      double precision lambda,gamma
      double precision onemlambda, onemgamma
      onemlambda = 1.0d0 - lambda
      onemgamma = 1.0d0 - gamma
      vdvgf = 3.52d0 * onemgamma / (onemlambda ** 1.5d0)
     &     - (4.35d0 - 5.28d0 * gamma) / (onemlambda ** 0.5d0)
     &     + (1.0d0 - onemgamma * lambda)
     &     * (0.83d0 - 1.76d0 * gamma
     &     + (1.30d0 - 0.30d0 * gamma**1.5d0) /
     &     ((1.0d0 - gamma**2.0d0)**0.5d0))
      return
      end

      double precision function vdvabzg(z)
!     wrapper for integrands of the form
!     (a+b*z)*G(lambda,gamma(z))
      implicit none
      double precision z
      double precision depth,thickness,a,b
      common /vdvcom/ depth,thickness,a,b
      double precision lambda,gamma,vdvgf
      lambda = depth/thickness
      gamma = z/depth
      vdvabzg = (a+b*z)*vdvgf(lambda,gamma)
      return
      end

      subroutine vdvint(result,error,zmin,zmax,depth,thickness,a,b)
c     integrate (a + b*z)*Gb(x,depth,thickness) from z=zmin  to z=zmax
c     assumes the only singular point in the integrand is z=depth
      implicit none
c     args
      double precision result,error,depth, thickness, zmin, zmax, a, b

c     parameters needed by quadpack dqagp
      integer npts2,neval,ier,leniw,lenw,last,iwork
      double precision points,epsabs,epsrel,work
      integer pointsdim,iworkdim,workdim
      parameter (pointsdim=3,iworkdim=64,workdim=128)
      dimension work(workdim)
      dimension points(pointsdim)
      dimension iwork(iworkdim)

c     declarations for integrand (gb)
      external vdvabzg
      double precision vdvabzg,dd1mach
      double precision gdepth, gthickness,ga,gb
      common /vdvcom/ gdepth,gthickness,ga,gb

      gdepth = depth
      gthickness = thickness
      ga = a
      gb = b
      npts2 = 2
      points(1) = zmin
      points(npts2) = zmax
      if (zmax .gt. depth) then
         npts2 = 3
         points(2) = depth
      end if
      leniw = 24*npts2-2
      lenw = leniw*2-npts2
      epsabs = 1.0
      epsrel = 1.0d-6

      work = 0.0d0
      result = 0.0d0
      error = 0.0d0

      call dqagp(vdvabzg,zmin,zmax,npts2,points,epsabs,epsrel,
     &     result, error, neval,ier,leniw,lenw,last,iwork,work)

      return
      end

c eveything following this line is a copy of a quadpack routine

      subroutine dqagp(f,a,b,npts2,points,epsabs,epsrel,result,
     *     abserr,neval,ier,leniw,lenw,last,iwork,work)
c***begin prologue  dqagp
c***date written   800101   (yymmdd)
c***revision date  830518   (yymmdd)
c***category no.  h2a2a1
c***keywords  automatic integrator, general-purpose,
c             singularities at user specified points,
c             extrapolation, globally adaptive
c***author  piessens,robert,appl. math. & progr. div - k.u.leuven
c           de doncker,elise,appl. math. & progr. div. - k.u.leuven
c***purpose  the routine calculates an approximation result to a given
c            definite integral i = integral of f over (a,b),
c            hopefully satisfying following claim for accuracy
c            break points of the integration interval, where local
c            difficulties of the integrand may occur (e.g.
c            singularities, discontinuities), are provided by the user.
c***description
c
c        computation of a definite integral
c        standard fortran subroutine
c        double precision version
c
c        parameters
c         on entry
c            f      - double precision
c                     function subprogram defining the integrand
c                     function f(x). the actual name for f needs to be
c                     declared e x t e r n a l in the driver program.
c
c            a      - double precision
c                     lower limit of integration
c
c            b      - double precision
c                     upper limit of integration
c
c            npts2  - integer
c                     number equal to two more than the number of
c                     user-supplied break points within the integration
c                     range, npts.ge.2.
c                     if npts2.lt.2, the routine will end with ier = 6.
c
c            points - double precision
c                     vector of dimension npts2, the first (npts2-2)
c                     elements of which are the user provided break
c                     points. if these points do not constitute an
c                     ascending sequence there will be an automatic
c                     sorting.
c
c            epsabs - double precision
c                     absolute accuracy requested
c            epsrel - double precision
c                     relative accuracy requested
c                     if  epsabs.le.0
c                     and epsrel.lt.max(50*rel.mach.acc.,0.5d-28),
c                     the routine will end with ier = 6.
c
c         on return
c            result - double precision
c                     approximation to the integral
c
c            abserr - double precision
c                     estimate of the modulus of the absolute error,
c                     which should equal or exceed abs(i-result)
c
c            neval  - integer
c                     number of integrand evaluations
c
c            ier    - integer
c                     ier = 0 normal and reliable termination of the
c                             routine. it is assumed that the requested
c                             accuracy has been achieved.
c                     ier.gt.0 abnormal termination of the routine.
c                             the estimates for integral and error are
c                             less reliable. it is assumed that the
c                             requested accuracy has not been achieved.
c            error messages
c                     ier = 1 maximum number of subdivisions allowed
c                             has been achieved. one can allow more
c                             subdivisions by increasing the value of
c                             limit (and taking the according dimension
c                             adjustments into account). however, if
c                             this yields no improvement it is advised
c                             to analyze the integrand in order to
c                             determine the integration difficulties. if
c                             the position of a local difficulty can be
c                             determined (i.e. singularity,
c                             discontinuity within the interval), it
c                             should be supplied to the routine as an
c                             element of the vector points. if necessary
c                             an appropriate special-purpose integrator
c                             must be used, which is designed for
c                             handling the type of difficulty involved.
c                         = 2 the occurrence of roundoff error is
c                             detected, which prevents the requested
c                             tolerance from being achieved.
c                             the error may be under-estimated.
c                         = 3 extremely bad integrand behaviour occurs
c                             at some points of the integration
c                             interval.
c                         = 4 the algorithm does not converge.
c                             roundoff error is detected in the
c                             extrapolation table.
c                             it is presumed that the requested
c                             tolerance cannot be achieved, and that
c                             the returned result is the best which
c                             can be obtained.
c                         = 5 the integral is probably divergent, or
c                             slowly convergent. it must be noted that
c                             divergence can occur with any other value
c                             of ier.gt.0.
c                         = 6 the input is invalid because
c                             npts2.lt.2 or
c                             break points are specified outside
c                             the integration range or
c                             (epsabs.le.0 and
c                              epsrel.lt.max(50*rel.mach.acc.,0.5d-28))
c                             result, abserr, neval, last are set to
c                             zero. exept when leniw or lenw or npts2 is
c                             invalid, iwork(1), iwork(limit+1),
c                             work(limit*2+1) and work(limit*3+1)
c                             are set to zero.
c                             work(1) is set to a and work(limit+1)
c                             to b (where limit = (leniw-npts2)/2).
c
c         dimensioning parameters
c            leniw - integer
c                    dimensioning parameter for iwork
c                    leniw determines limit = (leniw-npts2)/2,
c                    which is the maximum number of subintervals in the
c                    partition of the given integration interval (a,b),
c                    leniw.ge.(3*npts2-2).
c                    if leniw.lt.(3*npts2-2), the routine will end with
c                    ier = 6.
c
c            lenw  - integer
c                    dimensioning parameter for work
c                    lenw must be at least leniw*2-npts2.
c                    if lenw.lt.leniw*2-npts2, the routine will end
c                    with ier = 6.
c
c            last  - integer
c                    on return, last equals the number of subintervals
c                    produced in the subdivision process, which
c                    determines the number of significant elements
c                    actually in the work arrays.
c
c         work arrays
c            iwork - integer
c                    vector of dimension at least leniw. on return,
c                    the first k elements of which contain
c                    pointers to the error estimates over the
c                    subintervals, such that work(limit*3+iwork(1)),...,
c                    work(limit*3+iwork(k)) form a decreasing
c                    sequence, with k = last if last.le.(limit/2+2), and
c                    k = limit+1-last otherwise
c                    iwork(limit+1), ...,iwork(limit+last) contain the
c                     subdivision levels of the subintervals, i.e.
c                     if (aa,bb) is a subinterval of (p1,p2)
c                     where p1 as well as p2 is a user-provided
c                     break point or integration limit, then (aa,bb) has
c                     level l if abs(bb-aa) = abs(p2-p1)*2**(-l),
c                    iwork(limit*2+1), ..., iwork(limit*2+npts2) have
c                     no significance for the user,
c                    note that limit = (leniw-npts2)/2.
c
c            work  - double precision
c                    vector of dimension at least lenw
c                    on return
c                    work(1), ..., work(last) contain the left
c                     end points of the subintervals in the
c                     partition of (a,b),
c                    work(limit+1), ..., work(limit+last) contain
c                     the right end points,
c                    work(limit*2+1), ..., work(limit*2+last) contain
c                     the integral approximations over the subintervals,
c                    work(limit*3+1), ..., work(limit*3+last)
c                     contain the corresponding error estimates,
c                    work(limit*4+1), ..., work(limit*4+npts2)
c                     contain the integration limits and the
c                     break points sorted in an ascending sequence.
c                    note that limit = (leniw-npts2)/2.
c
c***references  (none)
c***routines called  dqagpe,xerror
c***end prologue  dqagp
c
      double precision a,abserr,b,epsabs,epsrel,f,points,result,work
      integer ier,iwork,last,leniw,lenw,limit,lvl,l1,l2,l3,l4,neval,
     *  npts2
c
      dimension iwork(leniw),points(npts2),work(lenw)
c
      external f
c
c         check validity of limit and lenw.
c
c***first executable statement  dqagp
      ier = 6
      neval = 0
      last = 0
      result = 0.0d+00
      abserr = 0.0d+00
      if(leniw.lt.(3*npts2-2).or.lenw.lt.(leniw*2-npts2).or.npts2.lt.2)
     *  go to 10
c
c         prepare call for dqagpe.
c
      limit = (leniw-npts2)/2
      l1 = limit+1
      l2 = limit+l1
      l3 = limit+l2
      l4 = limit+l3
c
      call dqagpe(f,a,b,npts2,points,epsabs,epsrel,limit,result,abserr,
     *  neval,ier,work(1),work(l1),work(l2),work(l3),work(l4),
     *  iwork(1),iwork(l1),iwork(l2),last)
c
c         call error handler if necessary.
c
      lvl = 0
10    if(ier.eq.6) lvl = 1
c      if(ier.ne.0) call xerror(26habnormal return from dqagp,26,ier,lvl)
      return
      end

      subroutine dqagpe(f,a,b,npts2,points,epsabs,epsrel,limit,result,
     *   abserr,neval,ier,alist,blist,rlist,elist,pts,iord,level,ndin,
     *   last)
c***begin prologue  dqagpe
c***date written   800101   (yymmdd)
c***revision date  830518   (yymmdd)
c***category no.  h2a2a1
c***keywords  automatic integrator, general-purpose,
c             singularities at user specified points,
c             extrapolation, globally adaptive.
c***author  piessens,robert ,appl. math. & progr. div. - k.u.leuven
c           de doncker,elise,appl. math. & progr. div. - k.u.leuven
c***purpose  the routine calculates an approximation result to a given
c            definite integral i = integral of f over (a,b), hopefully
c            satisfying following claim for accuracy abs(i-result).le.
c            max(epsabs,epsrel*abs(i)). break points of the integration
c            interval, where local difficulties of the integrand may
c            occur(e.g. singularities,discontinuities),provided by user.
c***description
c
c        computation of a definite integral
c        standard fortran subroutine
c        double precision version
c
c        parameters
c         on entry
c            f      - double precision
c                     function subprogram defining the integrand
c                     function f(x). the actual name for f needs to be
c                     declared e x t e r n a l in the driver program.
c
c            a      - double precision
c                     lower limit of integration
c
c            b      - double precision
c                     upper limit of integration
c
c            npts2  - integer
c                     number equal to two more than the number of
c                     user-supplied break points within the integration
c                     range, npts2.ge.2.
c                     if npts2.lt.2, the routine will end with ier = 6.
c
c            points - double precision
c                     vector of dimension npts2, the first (npts2-2)
c                     elements of which are the user provided break
c                     points. if these points do not constitute an
c                     ascending sequence there will be an automatic
c                     sorting.
c
c            epsabs - double precision
c                     absolute accuracy requested
c            epsrel - double precision
c                     relative accuracy requested
c                     if  epsabs.le.0
c                     and epsrel.lt.max(50*rel.mach.acc.,0.5d-28),
c                     the routine will end with ier = 6.
c
c            limit  - integer
c                     gives an upper bound on the number of subintervals
c                     in the partition of (a,b), limit.ge.npts2
c                     if limit.lt.npts2, the routine will end with
c                     ier = 6.
c
c         on return
c            result - double precision
c                     approximation to the integral
c
c            abserr - double precision
c                     estimate of the modulus of the absolute error,
c                     which should equal or exceed abs(i-result)
c
c            neval  - integer
c                     number of integrand evaluations
c
c            ier    - integer
c                     ier = 0 normal and reliable termination of the
c                             routine. it is assumed that the requested
c                             accuracy has been achieved.
c                     ier.gt.0 abnormal termination of the routine.
c                             the estimates for integral and error are
c                             less reliable. it is assumed that the
c                             requested accuracy has not been achieved.
c            error messages
c                     ier = 1 maximum number of subdivisions allowed
c                             has been achieved. one can allow more
c                             subdivisions by increasing the value of
c                             limit (and taking the according dimension
c                             adjustments into account). however, if
c                             this yields no improvement it is advised
c                             to analyze the integrand in order to
c                             determine the integration difficulties. if
c                             the position of a local difficulty can be
c                             determined (i.e. singularity,
c                             discontinuity within the interval), it
c                             should be supplied to the routine as an
c                             element of the vector points. if necessary
c                             an appropriate special-purpose integrator
c                             must be used, which is designed for
c                             handling the type of difficulty involved.
c                         = 2 the occurrence of roundoff error is
c                             detected, which prevents the requested
c                             tolerance from being achieved.
c                             the error may be under-estimated.
c                         = 3 extremely bad integrand behaviour occurs
c                             at some points of the integration
c                             interval.
c                         = 4 the algorithm does not converge.
c                             roundoff error is detected in the
c                             extrapolation table. it is presumed that
c                             the requested tolerance cannot be
c                             achieved, and that the returned result is
c                             the best which can be obtained.
c                         = 5 the integral is probably divergent, or
c                             slowly convergent. it must be noted that
c                             divergence can occur with any other value
c                             of ier.gt.0.
c                         = 6 the input is invalid because
c                             npts2.lt.2 or
c                             break points are specified outside
c                             the integration range or
c                             (epsabs.le.0 and
c                              epsrel.lt.max(50*rel.mach.acc.,0.5d-28))
c                             or limit.lt.npts2.
c                             result, abserr, neval, last, rlist(1),
c                             and elist(1) are set to zero. alist(1) and
c                             blist(1) are set to a and b respectively.
c
c            alist  - double precision
c                     vector of dimension at least limit, the first
c                      last  elements of which are the left end points
c                     of the subintervals in the partition of the given
c                     integration range (a,b)
c
c            blist  - double precision
c                     vector of dimension at least limit, the first
c                      last  elements of which are the right end points
c                     of the subintervals in the partition of the given
c                     integration range (a,b)
c
c            rlist  - double precision
c                     vector of dimension at least limit, the first
c                      last  elements of which are the integral
c                     approximations on the subintervals
c
c            elist  - double precision
c                     vector of dimension at least limit, the first
c                      last  elements of which are the moduli of the
c                     absolute error estimates on the subintervals
c
c            pts    - double precision
c                     vector of dimension at least npts2, containing the
c                     integration limits and the break points of the
c                     interval in ascending sequence.
c
c            level  - integer
c                     vector of dimension at least limit, containing the
c                     subdivision levels of the subinterval, i.e. if
c                     (aa,bb) is a subinterval of (p1,p2) where p1 as
c                     well as p2 is a user-provided break point or
c                     integration limit, then (aa,bb) has level l if
c                     abs(bb-aa) = abs(p2-p1)*2**(-l).
c
c            ndin   - integer
c                     vector of dimension at least npts2, after first
c                     integration over the intervals (pts(i)),pts(i+1),
c                     i = 0,1, ..., npts2-2, the error estimates over
c                     some of the intervals may have been increased
c                     artificially, in order to put their subdivision
c                     forward. if this happens for the subinterval
c                     numbered k, ndin(k) is put to 1, otherwise
c                     ndin(k) = 0.
c
c            iord   - integer
c                     vector of dimension at least limit, the first k
c                     elements of which are pointers to the
c                     error estimates over the subintervals,
c                     such that elist(iord(1)), ..., elist(iord(k))
c                     form a decreasing sequence, with k = last
c                     if last.le.(limit/2+2), and k = limit+1-last
c                     otherwise
c
c            last   - integer
c                     number of subintervals actually produced in the
c                     subdivisions process
c
c***references  (none)
c***routines called  dd1mach,dqelg,dqk21,dqpsrt
c***end prologue  dqagpe
      double precision a,abseps,abserr,alist,area,area1,area12,area2,a1,
     *  a2,b,blist,b1,b2,correc,dabs,defabs,defab1,defab2,dmax1,dmin1,
     *  dres,dd1mach,elist,epmach,epsabs,epsrel,erlarg,erlast,errbnd,
     *  errmax,error1,erro12,error2,errsum,ertest,f,oflow,points,pts,
     *  resa,resabs,reseps,result,res3la,rlist,rlist2,sign,temp,uflow
      integer i,id,ier,ierro,ind1,ind2,iord,ip1,iroff1,iroff2,iroff3,j,
     *  jlow,jupbnd,k,ksgn,ktmin,last,levcur,level,levmax,limit,maxerr,
     *  ndin,neval,nint,nintp1,npts,npts2,nres,nrmax,numrl2
      logical extrap,noext
c
c
      dimension alist(limit),blist(limit),elist(limit),iord(limit),
     *  level(limit),ndin(npts2),points(npts2),pts(npts2),res3la(3),
     *  rlist(limit),rlist2(52)
c
      external f
c
c            the dimension of rlist2 is determined by the value of
c            limexp in subroutine epsalg (rlist2 should be of dimension
c            (limexp+2) at least).
c
c
c            list of major variables
c            -----------------------
c
c           alist     - list of left end points of all subintervals
c                       considered up to now
c           blist     - list of right end points of all subintervals
c                       considered up to now
c           rlist(i)  - approximation to the integral over
c                       (alist(i),blist(i))
c           rlist2    - array of dimension at least limexp+2
c                       containing the part of the epsilon table which
c                       is still needed for further computations
c           elist(i)  - error estimate applying to rlist(i)
c           maxerr    - pointer to the interval with largest error
c                       estimate
c           errmax    - elist(maxerr)
c           erlast    - error on the interval currently subdivided
c                       (before that subdivision has taken place)
c           area      - sum of the integrals over the subintervals
c           errsum    - sum of the errors over the subintervals
c           errbnd    - requested accuracy max(epsabs,epsrel*
c                       abs(result))
c           *****1    - variable for the left subinterval
c           *****2    - variable for the right subinterval
c           last      - index for subdivision
c           nres      - number of calls to the extrapolation routine
c           numrl2    - number of elements in rlist2. if an appropriate
c                       approximation to the compounded integral has
c                       been obtained, it is put in rlist2(numrl2) after
c                       numrl2 has been increased by one.
c           erlarg    - sum of the errors over the intervals larger
c                       than the smallest interval considered up to now
c           extrap    - logical variable denoting that the routine
c                       is attempting to perform extrapolation. i.e.
c                       before subdividing the smallest interval we
c                       try to decrease the value of erlarg.
c           noext     - logical variable denoting that extrapolation is
c                       no longer allowed (true-value)
c
c            machine dependent constants
c            ---------------------------
c
c           epmach is the largest relative spacing.
c           uflow is the smallest positive magnitude.
c           oflow is the largest positive magnitude.
c
c***first executable statement  dqagpe
      epmach = dd1mach(4)
c
c            test on validity of parameters
c            -----------------------------
c
      ier = 0
      neval = 0
      last = 0
      result = 0.0d+00
      abserr = 0.0d+00
      alist(1) = a
      blist(1) = b
      rlist(1) = 0.0d+00
      elist(1) = 0.0d+00
      iord(1) = 0
      level(1) = 0
      npts = npts2-2
      if(npts2.lt.2.or.limit.le.npts.or.(epsabs.le.0.0d+00.and.
     *  epsrel.lt.dmax1(0.5d+02*epmach,0.5d-28))) ier = 6
      if(ier.eq.6) go to 999
c
c            if any break points are provided, sort them into an
c            ascending sequence.
c
      sign = 1.0d+00
      if(a.gt.b) sign = -1.0d+00
      pts(1) = dmin1(a,b)
      if(npts.eq.0) go to 15
      do 10 i = 1,npts
        pts(i+1) = points(i)
   10 continue
   15 pts(npts+2) = dmax1(a,b)
      nint = npts+1
      a1 = pts(1)
      if(npts.eq.0) go to 40
      nintp1 = nint+1
      do 20 i = 1,nint
        ip1 = i+1
        do 20 j = ip1,nintp1
          if(pts(i).le.pts(j)) go to 20
          temp = pts(i)
          pts(i) = pts(j)
          pts(j) = temp
   20 continue
      if(pts(1).ne.dmin1(a,b).or.pts(nintp1).ne.dmax1(a,b)) ier = 6
      if(ier.eq.6) go to 999
c
c            compute first integral and error approximations.
c            ------------------------------------------------
c
   40 resabs = 0.0d+00
      do 50 i = 1,nint
        b1 = pts(i+1)
        call dqk21(f,a1,b1,area1,error1,defabs,resa)
        abserr = abserr+error1
        result = result+area1
        ndin(i) = 0
        if(error1.eq.resa.and.error1.ne.0.0d+00) ndin(i) = 1
        resabs = resabs+defabs
        level(i) = 0
        elist(i) = error1
        alist(i) = a1
        blist(i) = b1
        rlist(i) = area1
        iord(i) = i
        a1 = b1
   50 continue
      errsum = 0.0d+00
      do 55 i = 1,nint
        if(ndin(i).eq.1) elist(i) = abserr
        errsum = errsum+elist(i)
   55 continue
c
c           test on accuracy.
c
      last = nint
      neval = 21*nint
      dres = dabs(result)
      errbnd = dmax1(epsabs,epsrel*dres)
      if(abserr.le.0.1d+03*epmach*resabs.and.abserr.gt.errbnd) ier = 2
      if(nint.eq.1) go to 80
      do 70 i = 1,npts
        jlow = i+1
        ind1 = iord(i)
        do 60 j = jlow,nint
          ind2 = iord(j)
          if(elist(ind1).gt.elist(ind2)) go to 60
          ind1 = ind2
          k = j
   60   continue
        if(ind1.eq.iord(i)) go to 70
        iord(k) = iord(i)
        iord(i) = ind1
   70 continue
      if(limit.lt.npts2) ier = 1
   80 if(ier.ne.0.or.abserr.le.errbnd) go to 210
c
c           initialization
c           --------------
c
      rlist2(1) = result
      maxerr = iord(1)
      errmax = elist(maxerr)
      area = result
      nrmax = 1
      nres = 0
      numrl2 = 1
      ktmin = 0
      extrap = .false.
      noext = .false.
      erlarg = errsum
      ertest = errbnd
      levmax = 1
      iroff1 = 0
      iroff2 = 0
      iroff3 = 0
      ierro = 0
      uflow = dd1mach(1)
      oflow = dd1mach(2)
      abserr = oflow
      ksgn = -1
      if(dres.ge.(0.1d+01-0.5d+02*epmach)*resabs) ksgn = 1
c
c           main do-loop
c           ------------
c
      do 160 last = npts2,limit
c
c           bisect the subinterval with the nrmax-th largest error
c           estimate.
c
        levcur = level(maxerr)+1
        a1 = alist(maxerr)
        b1 = 0.5d+00*(alist(maxerr)+blist(maxerr))
        a2 = b1
        b2 = blist(maxerr)
        erlast = errmax
        call dqk21(f,a1,b1,area1,error1,resa,defab1)
        call dqk21(f,a2,b2,area2,error2,resa,defab2)
c
c           improve previous approximations to integral
c           and error and test for accuracy.
c
        neval = neval+42
        area12 = area1+area2
        erro12 = error1+error2
        errsum = errsum+erro12-errmax
        area = area+area12-rlist(maxerr)
        if(defab1.eq.error1.or.defab2.eq.error2) go to 95
        if(dabs(rlist(maxerr)-area12).gt.0.1d-04*dabs(area12)
     *  .or.erro12.lt.0.99d+00*errmax) go to 90
        if(extrap) iroff2 = iroff2+1
        if(.not.extrap) iroff1 = iroff1+1
   90   if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1
   95   level(maxerr) = levcur
        level(last) = levcur
        rlist(maxerr) = area1
        rlist(last) = area2
        errbnd = dmax1(epsabs,epsrel*dabs(area))
c
c           test for roundoff error and eventually set error flag.
c
        if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2
        if(iroff2.ge.5) ierro = 3
c
c           set error flag in the case that the number of
c           subintervals equals limit.
c
        if(last.eq.limit) ier = 1
c
c           set error flag in the case of bad integrand behaviour
c           at a point of the integration range
c
        if(dmax1(dabs(a1),dabs(b2)).le.(0.1d+01+0.1d+03*epmach)*
     *  (dabs(a2)+0.1d+04*uflow)) ier = 4
c
c           append the newly-created intervals to the list.
c
        if(error2.gt.error1) go to 100
        alist(last) = a2
        blist(maxerr) = b1
        blist(last) = b2
        elist(maxerr) = error1
        elist(last) = error2
        go to 110
  100   alist(maxerr) = a2
        alist(last) = a1
        blist(last) = b1
        rlist(maxerr) = area2
        rlist(last) = area1
        elist(maxerr) = error2
        elist(last) = error1
c
c           call subroutine dqpsrt to maintain the descending ordering
c           in the list of error estimates and select the subinterval
c           with nrmax-th largest error estimate (to be bisected next).
c
  110   call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax)
c ***jump out of do-loop
        if(errsum.le.errbnd) go to 190
c ***jump out of do-loop
        if(ier.ne.0) go to 170
        if(noext) go to 160
        erlarg = erlarg-erlast
        if(levcur+1.le.levmax) erlarg = erlarg+erro12
        if(extrap) go to 120
c
c           test whether the interval to be bisected next is the
c           smallest interval.
c
        if(level(maxerr)+1.le.levmax) go to 160
        extrap = .true.
        nrmax = 2
  120   if(ierro.eq.3.or.erlarg.le.ertest) go to 140
c
c           the smallest interval has the largest error.
c           before bisecting decrease the sum of the errors over
c           the larger intervals (erlarg) and perform extrapolation.
c
        id = nrmax
        jupbnd = last
        if(last.gt.(2+limit/2)) jupbnd = limit+3-last
        do 130 k = id,jupbnd
          maxerr = iord(nrmax)
          errmax = elist(maxerr)
c ***jump out of do-loop
          if(level(maxerr)+1.le.levmax) go to 160
          nrmax = nrmax+1
  130   continue
c
c           perform extrapolation.
c
  140   numrl2 = numrl2+1
        rlist2(numrl2) = area
        if(numrl2.le.2) go to 155
        call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres)
        ktmin = ktmin+1
        if(ktmin.gt.5.and.abserr.lt.0.1d-02*errsum) ier = 5
        if(abseps.ge.abserr) go to 150
        ktmin = 0
        abserr = abseps
        result = reseps
        correc = erlarg
        ertest = dmax1(epsabs,epsrel*dabs(reseps))
c ***jump out of do-loop
        if(abserr.lt.ertest) go to 170
c
c           prepare bisection of the smallest interval.
c
  150   if(numrl2.eq.1) noext = .true.
        if(ier.ge.5) go to 170
  155   maxerr = iord(1)
        errmax = elist(maxerr)
        nrmax = 1
        extrap = .false.
        levmax = levmax+1
        erlarg = errsum
  160 continue
c
c           set the final result.
c           ---------------------
c
c
  170 if(abserr.eq.oflow) go to 190
      if((ier+ierro).eq.0) go to 180
      if(ierro.eq.3) abserr = abserr+correc
      if(ier.eq.0) ier = 3
      if(result.ne.0.0d+00.and.area.ne.0.0d+00)go to 175
      if(abserr.gt.errsum)go to 190
      if(area.eq.0.0d+00) go to 210
      go to 180
  175 if(abserr/dabs(result).gt.errsum/dabs(area))go to 190
c
c           test on divergence.
c
  180 if(ksgn.eq.(-1).and.dmax1(dabs(result),dabs(area)).le.
     *  resabs*0.1d-01) go to 210
      if(0.1d-01.gt.(result/area).or.(result/area).gt.0.1d+03.or.
     *  errsum.gt.dabs(area)) ier = 6
      go to 210
c
c           compute global integral sum.
c
  190 result = 0.0d+00
      do 200 k = 1,last
        result = result+rlist(k)
  200 continue
      abserr = errsum
  210 if(ier.gt.2) ier = ier-1
      result = result*sign
  999 return
      end

      subroutine dqelg(n,epstab,result,abserr,res3la,nres)
c***begin prologue  dqelg
c***refer to  dqagie,dqagoe,dqagpe,dqagse
c***routines called  dd1mach
c***revision date  830518   (yymmdd)
c***keywords  epsilon algorithm, convergence acceleration,
c             extrapolation
c***author  piessens,robert,appl. math. & progr. div. - k.u.leuven
c           de doncker,elise,appl. math & progr. div. - k.u.leuven
c***purpose  the routine determines the limit of a given sequence of
c            approximations, by means of the epsilon algorithm of
c            p.wynn. an estimate of the absolute error is also given.
c            the condensed epsilon table is computed. only those
c            elements needed for the computation of the next diagonal
c            are preserved.
c***description
c
c           epsilon algorithm
c           standard fortran subroutine
c           double precision version
c
c           parameters
c              n      - integer
c                       epstab(n) contains the new element in the
c                       first column of the epsilon table.
c
c              epstab - double precision
c                       vector of dimension 52 containing the elements
c                       of the two lower diagonals of the triangular
c                       epsilon table. the elements are numbered
c                       starting at the right-hand corner of the
c                       triangle.
c
c              result - double precision
c                       resulting approximation to the integral
c
c              abserr - double precision
c                       estimate of the absolute error computed from
c                       result and the 3 previous results
c
c              res3la - double precision
c                       vector of dimension 3 containing the last 3
c                       results
c
c              nres   - integer
c                       number of calls to the routine
c                       (should be zero at first call)
c
c***end prologue  dqelg
c
      double precision abserr,dabs,delta1,delta2,delta3,dmax1,dd1mach,
     *  epmach,epsinf,epstab,error,err1,err2,err3,e0,e1,e1abs,e2,e3,
     *  oflow,res,result,res3la,ss,tol1,tol2,tol3
      integer i,ib,ib2,ie,indx,k1,k2,k3,limexp,n,newelm,nres,num
      dimension epstab(52),res3la(3)
c
c           list of major variables
c           -----------------------
c
c           e0     - the 4 elements on which the computation of a new
c           e1       element in the epsilon table is based
c           e2
c           e3                 e0
c                        e3    e1    new
c                              e2
c           newelm - number of elements to be computed in the new
c                    diagonal
c           error  - error = abs(e1-e0)+abs(e2-e1)+abs(new-e2)
c           result - the element in the new diagonal with least value
c                    of error
c
c           machine dependent constants
c           ---------------------------
c
c           epmach is the largest relative spacing.
c           oflow is the largest positive magnitude.
c           limexp is the maximum number of elements the epsilon
c           table can contain. if this number is reached, the upper
c           diagonal of the epsilon table is deleted.
c
c***first executable statement  dqelg
      epmach = dd1mach(4)
      oflow = dd1mach(2)
      nres = nres+1
      abserr = oflow
      result = epstab(n)
      if(n.lt.3) go to 100
      limexp = 50
      epstab(n+2) = epstab(n)
      newelm = (n-1)/2
      epstab(n) = oflow
      num = n
      k1 = n
      do 40 i = 1,newelm
        k2 = k1-1
        k3 = k1-2
        res = epstab(k1+2)
        e0 = epstab(k3)
        e1 = epstab(k2)
        e2 = res
        e1abs = dabs(e1)
        delta2 = e2-e1
        err2 = dabs(delta2)
        tol2 = dmax1(dabs(e2),e1abs)*epmach
        delta3 = e1-e0
        err3 = dabs(delta3)
        tol3 = dmax1(e1abs,dabs(e0))*epmach
        if(err2.gt.tol2.or.err3.gt.tol3) go to 10
c
c           if e0, e1 and e2 are equal to within machine
c           accuracy, convergence is assumed.
c           result = e2
c           abserr = abs(e1-e0)+abs(e2-e1)
c
        result = res
        abserr = err2+err3
c ***jump out of do-loop
        go to 100
   10   e3 = epstab(k1)
        epstab(k1) = e1
        delta1 = e1-e3
        err1 = dabs(delta1)
        tol1 = dmax1(e1abs,dabs(e3))*epmach
c
c           if two elements are very close to each other, omit
c           a part of the table by adjusting the value of n
c
        if(err1.le.tol1.or.err2.le.tol2.or.err3.le.tol3) go to 20
        ss = 0.1d+01/delta1+0.1d+01/delta2-0.1d+01/delta3
        epsinf = dabs(ss*e1)
c
c           test to detect irregular behaviour in the table, and
c           eventually omit a part of the table adjusting the value
c           of n.
c
        if(epsinf.gt.0.1d-03) go to 30
   20   n = i+i-1
c ***jump out of do-loop
        go to 50
c
c           compute a new element and eventually adjust
c           the value of result.
c
   30   res = e1+0.1d+01/ss
        epstab(k1) = res
        k1 = k1-2
        error = err2+dabs(res-e2)+err3
        if(error.gt.abserr) go to 40
        abserr = error
        result = res
   40 continue
c
c           shift the table.
c
   50 if(n.eq.limexp) n = 2*(limexp/2)-1
      ib = 1
      if((num/2)*2.eq.num) ib = 2
      ie = newelm+1
      do 60 i=1,ie
        ib2 = ib+2
        epstab(ib) = epstab(ib2)
        ib = ib2
   60 continue
      if(num.eq.n) go to 80
      indx = num-n+1
      do 70 i = 1,n
        epstab(i)= epstab(indx)
        indx = indx+1
   70 continue
   80 if(nres.ge.4) go to 90
      res3la(nres) = result
      abserr = oflow
      go to 100
c
c           compute error estimate
c
   90 abserr = dabs(result-res3la(3))+dabs(result-res3la(2))
     *  +dabs(result-res3la(1))
      res3la(1) = res3la(2)
      res3la(2) = res3la(3)
      res3la(3) = result
  100 abserr = dmax1(abserr,0.5d+01*epmach*dabs(result))
      return
      end

      subroutine dqk21(f,a,b,result,abserr,resabs,resasc)
c***begin prologue  dqk21
c***date written   800101   (yymmdd)
c***revision date  830518   (yymmdd)
c***category no.  h2a1a2
c***keywords  21-point gauss-kronrod rules
c***author  piessens,robert,appl. math. & progr. div. - k.u.leuven
c           de doncker,elise,appl. math. & progr. div. - k.u.leuven
c***purpose  to compute i = integral of f over (a,b), with error
c                           estimate
c                       j = integral of abs(f) over (a,b)
c***description
c
c           integration rules
c           standard fortran subroutine
c           double precision version
c
c           parameters
c            on entry
c              f      - double precision
c                       function subprogram defining the integrand
c                       function f(x). the actual name for f needs to be
c                       declared e x t e r n a l in the driver program.
c
c              a      - double precision
c                       lower limit of integration
c
c              b      - double precision
c                       upper limit of integration
c
c            on return
c              result - double precision
c                       approximation to the integral i
c                       result is computed by applying the 21-point
c                       kronrod rule (resk) obtained by optimal addition
c                       of abscissae to the 10-point gauss rule (resg).
c
c              abserr - double precision
c                       estimate of the modulus of the absolute error,
c                       which should not exceed abs(i-result)
c
c              resabs - double precision
c                       approximation to the integral j
c
c              resasc - double precision
c                       approximation to the integral of abs(f-i/(b-a))
c                       over (a,b)
c
c***references  (none)
c***routines called  dd1mach
c***end prologue  dqk21
c
      double precision a,absc,abserr,b,centr,dabs,dhlgth,dmax1,dmin1,
     *  dd1mach,epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs,
     *     resasc,resg,resk,reskh,result,uflow,wg,wgk,xgk
      integer j,jtw,jtwm1
      external f
c
      dimension fv1(10),fv2(10),wg(5),wgk(11),xgk(11)
c
c           the abscissae and weights are given for the interval (-1,1).
c           because of symmetry only the positive abscissae and their
c           corresponding weights are given.
c
c           xgk    - abscissae of the 21-point kronrod rule
c                    xgk(2), xgk(4), ...  abscissae of the 10-point
c                    gauss rule
c                    xgk(1), xgk(3), ...  abscissae which are optimally
c                    added to the 10-point gauss rule
c
c           wgk    - weights of the 21-point kronrod rule
c
c           wg     - weights of the 10-point gauss rule
c
c
c gauss quadrature weights and kronron quadrature abscissae and weights
c as evaluated with 80 decimal digit arithmetic by l. w. fullerton,
c bell labs, nov. 1981.
c
      data wg  (  1) / 0.0666713443 0868813759 3568809893 332 d0 /
      data wg  (  2) / 0.1494513491 5058059314 5776339657 697 d0 /
      data wg  (  3) / 0.2190863625 1598204399 5534934228 163 d0 /
      data wg  (  4) / 0.2692667193 0999635509 1226921569 469 d0 /
      data wg  (  5) / 0.2955242247 1475287017 3892994651 338 d0 /
c
      data xgk (  1) / 0.9956571630 2580808073 5527280689 003 d0 /
      data xgk (  2) / 0.9739065285 1717172007 7964012084 452 d0 /
      data xgk (  3) / 0.9301574913 5570822600 1207180059 508 d0 /
      data xgk (  4) / 0.8650633666 8898451073 2096688423 493 d0 /
      data xgk (  5) / 0.7808177265 8641689706 3717578345 042 d0 /
      data xgk (  6) / 0.6794095682 9902440623 4327365114 874 d0 /
      data xgk (  7) / 0.5627571346 6860468333 9000099272 694 d0 /
      data xgk (  8) / 0.4333953941 2924719079 9265943165 784 d0 /
      data xgk (  9) / 0.2943928627 0146019813 1126603103 866 d0 /
      data xgk ( 10) / 0.1488743389 8163121088 4826001129 720 d0 /
      data xgk ( 11) / 0.0000000000 0000000000 0000000000 000 d0 /
c
      data wgk (  1) / 0.0116946388 6737187427 8064396062 192 d0 /
      data wgk (  2) / 0.0325581623 0796472747 8818972459 390 d0 /
      data wgk (  3) / 0.0547558965 7435199603 1381300244 580 d0 /
      data wgk (  4) / 0.0750396748 1091995276 7043140916 190 d0 /
      data wgk (  5) / 0.0931254545 8369760553 5065465083 366 d0 /
      data wgk (  6) / 0.1093871588 0229764189 9210590325 805 d0 /
      data wgk (  7) / 0.1234919762 6206585107 7958109831 074 d0 /
      data wgk (  8) / 0.1347092173 1147332592 8054001771 707 d0 /
      data wgk (  9) / 0.1427759385 7706008079 7094273138 717 d0 /
      data wgk ( 10) / 0.1477391049 0133849137 4841515972 068 d0 /
      data wgk ( 11) / 0.1494455540 0291690566 4936468389 821 d0 /
c
c
c           list of major variables
c           -----------------------
c
c           centr  - mid point of the interval
c           hlgth  - half-length of the interval
c           absc   - abscissa
c           fval*  - function value
c           resg   - result of the 10-point gauss formula
c           resk   - result of the 21-point kronrod formula
c           reskh  - approximation to the mean value of f over (a,b),
c                    i.e. to i/(b-a)
c
c
c           machine dependent constants
c           ---------------------------
c
c           epmach is the largest relative spacing.
c           uflow is the smallest positive magnitude.
c
c***first executable statement  dqk21
      epmach = dd1mach(4)
      uflow = dd1mach(1)
c
      centr = 0.5d+00*(a+b)
      hlgth = 0.5d+00*(b-a)
      dhlgth = dabs(hlgth)
c
c           compute the 21-point kronrod approximation to
c           the integral, and estimate the absolute error.
c
      resg = 0.0d+00
      fc = f(centr)
      resk = wgk(11)*fc
      resabs = dabs(resk)
      do 10 j=1,5
        jtw = 2*j
        absc = hlgth*xgk(jtw)
        fval1 = f(centr-absc)
        fval2 = f(centr+absc)
        fv1(jtw) = fval1
        fv2(jtw) = fval2
        fsum = fval1+fval2
        resg = resg+wg(j)*fsum
        resk = resk+wgk(jtw)*fsum
        resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2))
   10 continue
      do 15 j = 1,5
        jtwm1 = 2*j-1
        absc = hlgth*xgk(jtwm1)
        fval1 = f(centr-absc)
        fval2 = f(centr+absc)
        fv1(jtwm1) = fval1
        fv2(jtwm1) = fval2
        fsum = fval1+fval2
        resk = resk+wgk(jtwm1)*fsum
        resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2))
   15 continue
      reskh = resk*0.5d+00
      resasc = wgk(11)*dabs(fc-reskh)
      do 20 j=1,10
        resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh))
   20 continue
      result = resk*hlgth
      resabs = resabs*dhlgth
      resasc = resasc*dhlgth
      abserr = dabs((resk-resg)*hlgth)
      if(resasc.ne.0.0d+00.and.abserr.ne.0.0d+00)
     *  abserr = resasc*dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00)
      if(resabs.gt.uflow/(0.5d+02*epmach)) abserr = dmax1
     *  ((epmach*0.5d+02)*resabs,abserr)
      return
      end

      subroutine dqpsrt(limit,last,maxerr,ermax,elist,iord,nrmax)
c***begin prologue  dqpsrt
c***refer to  dqage,dqagie,dqagpe,dqawse
c***routines called  (none)
c***revision date  810101   (yymmdd)
c***keywords  sequential sorting
c***author  piessens,robert,appl. math. & progr. div. - k.u.leuven
c           de doncker,elise,appl. math. & progr. div. - k.u.leuven
c***purpose  this routine maintains the descending ordering in the
c            list of the local error estimated resulting from the
c            interval subdivision process. at each call two error
c            estimates are inserted using the sequential search
c            method, top-down for the largest error estimate and
c            bottom-up for the smallest error estimate.
c***description
c
c           ordering routine
c           standard fortran subroutine
c           double precision version
c
c           parameters (meaning at output)
c              limit  - integer
c                       maximum number of error estimates the list
c                       can contain
c
c              last   - integer
c                       number of error estimates currently in the list
c
c              maxerr - integer
c                       maxerr points to the nrmax-th largest error
c                       estimate currently in the list
c
c              ermax  - double precision
c                       nrmax-th largest error estimate
c                       ermax = elist(maxerr)
c
c              elist  - double precision
c                       vector of dimension last containing
c                       the error estimates
c
c              iord   - integer
c                       vector of dimension last, the first k elements
c                       of which contain pointers to the error
c                       estimates, such that
c                       elist(iord(1)),...,  elist(iord(k))
c                       form a decreasing sequence, with
c                       k = last if last.le.(limit/2+2), and
c                       k = limit+1-last otherwise
c
c              nrmax  - integer
c                       maxerr = iord(nrmax)
c
c***end prologue  dqpsrt
c
      double precision elist,ermax,errmax,errmin
      integer i,ibeg,ido,iord,isucc,j,jbnd,jupbn,k,last,limit,maxerr,
     *  nrmax
      dimension elist(last),iord(last)
c
c           check whether the list contains more than
c           two error estimates.
c
c***first executable statement  dqpsrt
      if(last.gt.2) go to 10
      iord(1) = 1
      iord(2) = 2
      go to 90
c
c           this part of the routine is only executed if, due to a
c           difficult integrand, subdivision increased the error
c           estimate. in the normal case the insert procedure should
c           start after the nrmax-th largest error estimate.
c
   10 errmax = elist(maxerr)
      if(nrmax.eq.1) go to 30
      ido = nrmax-1
      do 20 i = 1,ido
        isucc = iord(nrmax-1)
c ***jump out of do-loop
        if(errmax.le.elist(isucc)) go to 30
        iord(nrmax) = isucc
        nrmax = nrmax-1
   20    continue
c
c           compute the number of elements in the list to be maintained
c           in descending order. this number depends on the number of
c           subdivisions still allowed.
c
   30 jupbn = last
      if(last.gt.(limit/2+2)) jupbn = limit+3-last
      errmin = elist(last)
c
c           insert errmax by traversing the list top-down,
c           starting comparison from the element elist(iord(nrmax+1)).
c
      jbnd = jupbn-1
      ibeg = nrmax+1
      if(ibeg.gt.jbnd) go to 50
      do 40 i=ibeg,jbnd
        isucc = iord(i)
c ***jump out of do-loop
        if(errmax.ge.elist(isucc)) go to 60
        iord(i-1) = isucc
   40 continue
   50 iord(jbnd) = maxerr
      iord(jupbn) = last
      go to 90
c
c           insert errmin by traversing the list bottom-up.
c
   60 iord(i-1) = maxerr
      k = jbnd
      do 70 j=i,jbnd
        isucc = iord(k)
c ***jump out of do-loop
        if(errmin.lt.elist(isucc)) go to 80
        iord(k+1) = isucc
        k = k-1
   70 continue
      iord(i) = last
      go to 90
   80 iord(k+1) = last
c
c           set maxerr and ermax.
c
   90 maxerr = iord(nrmax)
      ermax = elist(maxerr)
      return
      end
      DOUBLE PRECISION FUNCTION DD1MACH(I)
      INTEGER I
C
C  DOUBLE-PRECISION MACHINE CONSTANTS
C  DD1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
C  DD1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
C  DD1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING.
C  DD1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING.
C  DD1MACH( 5) = LOG10(B)
C
      INTEGER SMALL(2)
      INTEGER LARGE(2)
      INTEGER RIGHT(2)
      INTEGER DIVER(2)
      INTEGER LOG10(2)
      INTEGER SC, CRAY1(38), J
      COMMON /D9MACH/ CRAY1
      SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC
      DOUBLE PRECISION DMACH(5)
      EQUIVALENCE (DMACH(1),SMALL(1))
      EQUIVALENCE (DMACH(2),LARGE(1))
      EQUIVALENCE (DMACH(3),RIGHT(1))
      EQUIVALENCE (DMACH(4),DIVER(1))
      EQUIVALENCE (DMACH(5),LOG10(1))
C  THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES.
C  R1MACH CAN HANDLE AUTO-DOUBLE COMPILING, BUT THIS VERSION OF
C  DD1MACH DOES NOT, BECAUSE WE DO NOT HAVE QUAD CONSTANTS FOR
C  MANY MACHINES YET.
C  TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1
C  ON THE NEXT LINE
      DATA SC/0/
C  AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW.
C  CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY
C          mail netlib@research.bell-labs.com
C          send oldd1mach from blas
C  PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com.
C
C     MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
C      DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 /
C      DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 /
C      DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 /
C      DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 /
C      DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/
C
C     MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
C     32-BIT INTEGERS.
C      DATA SMALL(1),SMALL(2) /    8388608,           0 /
C      DATA LARGE(1),LARGE(2) / 2147483647,          -1 /
C      DATA RIGHT(1),RIGHT(2) /  612368384,           0 /
C      DATA DIVER(1),DIVER(2) /  620756992,           0 /
C      DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/
C
C     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
C      DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 /
C      DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 /
C      DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 /
C      DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 /
C      DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/
C
C     ON FIRST CALL, IF NO DATA UNCOMMENTED, TEST MACHINE TYPES.
      IF (SC .NE. 987) THEN
         DMACH(1) = 1.D13
         IF (      SMALL(1) .EQ. 1117925532
     *       .AND. SMALL(2) .EQ. -448790528) THEN
*           *** IEEE BIG ENDIAN ***
            SMALL(1) = 1048576
            SMALL(2) = 0
            LARGE(1) = 2146435071
            LARGE(2) = -1
            RIGHT(1) = 1017118720
            RIGHT(2) = 0
            DIVER(1) = 1018167296
            DIVER(2) = 0
            LOG10(1) = 1070810131
            LOG10(2) = 1352628735
         ELSE IF ( SMALL(2) .EQ. 1117925532
     *       .AND. SMALL(1) .EQ. -448790528) THEN
*           *** IEEE LITTLE ENDIAN ***
            SMALL(2) = 1048576
            SMALL(1) = 0
            LARGE(2) = 2146435071
            LARGE(1) = -1
            RIGHT(2) = 1017118720
            RIGHT(1) = 0
            DIVER(2) = 1018167296
            DIVER(1) = 0
            LOG10(2) = 1070810131
            LOG10(1) = 1352628735
         ELSE IF ( SMALL(1) .EQ. -2065213935
     *       .AND. SMALL(2) .EQ. 10752) THEN
*               *** VAX WITH D_FLOATING ***
            SMALL(1) = 128
            SMALL(2) = 0
            LARGE(1) = -32769
            LARGE(2) = -1
            RIGHT(1) = 9344
            RIGHT(2) = 0
            DIVER(1) = 9472
            DIVER(2) = 0
            LOG10(1) = 546979738
            LOG10(2) = -805796613
         ELSE IF ( SMALL(1) .EQ. 1267827943
     *       .AND. SMALL(2) .EQ. 704643072) THEN
*               *** IBM MAINFRAME ***
            SMALL(1) = 1048576
            SMALL(2) = 0
            LARGE(1) = 2147483647
            LARGE(2) = -1
            RIGHT(1) = 856686592
            RIGHT(2) = 0
            DIVER(1) = 873463808
            DIVER(2) = 0
            LOG10(1) = 1091781651
            LOG10(2) = 1352628735
         ELSE IF ( SMALL(1) .EQ. 1120022684
     *       .AND. SMALL(2) .EQ. -448790528) THEN
*           *** CONVEX C-1 ***
            SMALL(1) = 1048576
            SMALL(2) = 0
            LARGE(1) = 2147483647
            LARGE(2) = -1
            RIGHT(1) = 1019215872
            RIGHT(2) = 0
            DIVER(1) = 1020264448
            DIVER(2) = 0
            LOG10(1) = 1072907283
            LOG10(2) = 1352628735
         ELSE IF ( SMALL(1) .EQ. 815547074
     *       .AND. SMALL(2) .EQ. 58688) THEN
*           *** VAX G-FLOATING ***
            SMALL(1) = 16
            SMALL(2) = 0
            LARGE(1) = -32769
            LARGE(2) = -1
            RIGHT(1) = 15552
            RIGHT(2) = 0
            DIVER(1) = 15568
            DIVER(2) = 0
            LOG10(1) = 1142112243
            LOG10(2) = 2046775455
         ELSE
            DMACH(2) = 1.D27 + 1
            DMACH(3) = 1.D27
            LARGE(2) = LARGE(2) - RIGHT(2)
            IF (LARGE(2) .EQ. 64 .AND. SMALL(2) .EQ. 0) THEN
               CRAY1(1) = 67291416
               DO 10 J = 1, 20
                  CRAY1(J+1) = CRAY1(J) + CRAY1(J)
 10               CONTINUE
               CRAY1(22) = CRAY1(21) + 321322
               DO 20 J = 22, 37
                  CRAY1(J+1) = CRAY1(J) + CRAY1(J)
 20               CONTINUE
               IF (CRAY1(38) .EQ. SMALL(1)) THEN
*                  *** CRAY ***
                  CALL I1MCRY(SMALL(1), J, 8285, 8388608, 0)
                  SMALL(2) = 0
                  CALL I1MCRY(LARGE(1), J, 24574, 16777215, 16777215)
                  CALL I1MCRY(LARGE(2), J, 0, 16777215, 16777214)
                  CALL I1MCRY(RIGHT(1), J, 16291, 8388608, 0)
                  RIGHT(2) = 0
                  CALL I1MCRY(DIVER(1), J, 16292, 8388608, 0)
                  DIVER(2) = 0
                  CALL I1MCRY(LOG10(1), J, 16383, 10100890, 8715215)
                  CALL I1MCRY(LOG10(2), J, 0, 16226447, 9001388)
               ELSE
                  WRITE(*,9000)
                  STOP 779
                  END IF
            ELSE
               WRITE(*,9000)
               STOP 779
               END IF
            END IF
         SC = 987
         END IF
*    SANITY CHECK
      IF (DMACH(4) .GE. 1.0D0) STOP 778
      IF (I .LT. 1 .OR. I .GT. 5) THEN
         WRITE(*,*) 'DD1MACH(I): I =',I,' is out of bounds.'
         STOP
         END IF
      DD1MACH = DMACH(I)
      RETURN
 9000 FORMAT(/' Adjust DD1MACH by uncommenting data statements'/
     *' appropriate for your machine.')
* /* Standard C source for DD1MACH -- remove the * in column 1 */
*#include <stdio.h>
*#include <float.h>
*#include <math.h>
*double dd1mach_(long *i)
*{
*	switch(*i){
*	  case 1: return DBL_MIN;
*	  case 2: return DBL_MAX;
*	  case 3: return DBL_EPSILON/FLT_RADIX;
*	  case 4: return DBL_EPSILON;
*	  case 5: return log10((double)FLT_RADIX);
*	  }
*	fprintf(stderr, "invalid argument: dd1mach(%ld)\n", *i);
*	exit(1); return 0; /* some compilers demand return values */
*}
      END
      SUBROUTINE I1MCRY(A, A1, B, C, D)
**** SPECIAL COMPUTATION FOR OLD CRAY MACHINES ****
      INTEGER A, A1, B, C, D
      A1 = 16777216*B + C
      A = 16777216*A1 + D
      END


! Program to test mathematical intrinsics
subroutine dotest (n, val4, val8, known)
   implicit none
   real(kind=4) val4, known
   real(kind=8) val8
   integer n

   if (abs (val4 - known) .gt. 0.001) call abort
   if (abs (real (val8, kind=4) - known) .gt. 0.001) call abort
end subroutine

subroutine dotestc (n, val4, val8, known)
   implicit none
   complex(kind=4) val4, known
   complex(kind=8) val8
   integer n
   if (abs (val4 - known) .gt. 0.001) call abort
   if (abs (cmplx (val8, kind=4) - known) .gt. 0.001) call abort
end subroutine

program testmath
   implicit none
   real(kind=4) r, two4, half4
   real(kind=8) q, two8, half8
   complex(kind=4) cr
   complex(kind=8) cq
   external dotest, dotestc

   two4 = 2.0
   two8 = 2.0_8
   half4 = 0.5
   half8 = 0.5_8
   r = sin (two4)
   q = sin (two8)
   call dotest (1, r, q, 0.9093)
   r = cos (two4)
   q = cos (two8)
   call dotest (2, r, q, -0.4161)
   r = tan (two4)
   q = tan (two8)
   call dotest (3, r, q, -2.1850)
   r = asin (half4)
   q = asin (half8)
   call dotest (4, r, q, 0.5234)
   r = acos (half4)
   q = acos (half8)
   call dotest (5, r, q, 1.0472)
   r = atan (half4)
   q = atan (half8)
   call dotest (6, r, q, 0.4636)
   r = atan2 (two4, half4)
   q = atan2 (two8, half8)
   call dotest (7, r, q, 1.3258)
   r = exp (two4)
   q = exp (two8)
   call dotest (8, r, q, 7.3891)
   r = log (two4)
   q = log (two8)
   call dotest (9, r, q, 0.6931)
   r = log10 (two4)
   q = log10 (two8)
   call dotest (10, r, q, 0.3010)
   r = sinh (two4)
   q = sinh (two8)
   call dotest (11, r, q, 3.6269)
   r = cosh (two4)
   q = cosh (two8)
   call dotest (12, r, q, 3.7622)
   r = tanh (two4)
   q = tanh (two8)
   call dotest (13, r, q, 0.9640)
   r = sqrt (two4)
   q = sqrt (two8)
   call dotest (14, r, q, 1.4142)

   r = atan2 (0.0, 1.0)
   q = atan2 (0.0_8, 1.0_8)
   call dotest (15, r, q, 0.0)
   r = atan2 (-1.0, 1.0)
   q = atan2 (-1.0_8, 1.0_8)
   call dotest (16, r, q, -0.7854)
   r = atan2 (0.0, -1.0)
   q = atan2 (0.0_8, -1.0_8)
   call dotest (17, r, q, 3.1416)
   r = atan2 (-1.0, -1.0)
   q = atan2 (-1.0_8, -1.0_8)
   call dotest (18, r, q, -2.3562)
   r = atan2 (1.0, 0.0)
   q = atan2 (1.0_8, 0.0_8)
   call dotest (19, r, q, 1.5708)
   r = atan2 (-1.0, 0.0)
   q = atan2 (-1.0_8, 0.0_8)
   call dotest (20, r, q, -1.5708)

   cr = log ((-1.0, -1.0))
   cq = log ((-1.0_8, -1.0_8))
   call dotestc (21, cr, cq, (0.3466, -2.3562))

end program


Module vec3_class

    type :: vec3
        real :: x, y, z
        contains

        procedure :: magnitude       => magnitude_fn
        procedure :: length          => length
        procedure :: length_squared  => length_squared
        procedure :: near_zero       => near_zero

        generic   :: operator(.dot.)   => vec_dot_vec, vec_dot_mat
        generic   :: operator(.cross.) => vec_cross_vec
        generic   :: operator(/)       => vec_div_scal
        generic   :: operator(*)       => vec_mult_vec, vec_mult_scal, scal_mult_vec
        generic   :: operator(+)       => vec_add_vec, vec_add_scal, scal_add_vec
        generic   :: operator(-)       => vec_minus_vec, vec_minus_scal, scal_minus_vec

        procedure, pass(a), private :: vec_dot_vec
        procedure, pass(a), private :: vec_dot_mat

        procedure, pass(a), private :: vec_cross_vec

        procedure, pass(a), private :: vec_div_scal

        procedure, pass(a), private :: vec_mult_vec
        procedure, pass(a), private :: vec_mult_scal
        procedure, pass(b), private :: scal_mult_vec

        procedure, pass(a), private :: vec_add_vec
        procedure, pass(a), private :: vec_add_scal
        procedure, pass(b), private :: scal_add_vec

        procedure, pass(a), private :: vec_minus_vec
        procedure, pass(a), private :: vec_minus_scal
        procedure, pass(b), private :: scal_minus_vec

    end type vec3

    private
    public :: magnitude, vec3, abs, length, max, invert, near_zero, reflect, refract
    public :: random_in_unit_sphere, random_vec3, random_unit_vector,random_in_unit_hemisphere, random_in_unit_disk

    interface abs
        module procedure abs_vec
    end interface abs

    interface max
        module procedure max_vec
    end interface max

    interface random_vec3
        module procedure random_vec3_uni
        module procedure random_vec3_uni_range
    end interface random_vec3

    contains

        type(vec3) function refract(uv, n, etai_over_etat)

            implicit none

            type(vec3), intent(IN) :: uv, n
            real,       intent(IN) :: etai_over_etat

            type(vec3) :: r_out_perp, r_out_parallel
            real       :: cos_theta

            cos_theta = min((-1.)*uv .dot. n, 1.)
            r_out_perp = etai_over_etat * (uv + cos_theta*n)
            r_out_parallel = (-1.)*sqrt(abs(1. - r_out_perp%length_squared())) * n

            refract = r_out_perp + r_out_parallel

        end function refract

        type(vec3) function reflect(v, n)

            implicit none

            type(vec3), intent(IN) :: v, n

            reflect = v - 2.* (v .dot. n) * n

        end function reflect

        logical function near_zero(this)

            implicit none

            class(vec3) :: this
            real :: s

            s = 1e-8
            near_zero = .false.
            if((abs(this%x) < s) .and. (abs(this%y) < s) .and. (abs(this%z) < s))near_zero=.true.

        end function near_zero

        type(vec3) function random_vec3_uni()

            use utils, only : random

            implicit none

            random_vec3_uni = vec3(random(), random(), random())

        end function random_vec3_uni

        type(vec3) function random_vec3_uni_range(minv, maxv)

            use utils, only : random

            implicit none

            real, intent(IN) :: minv, maxv

            random_vec3_uni_range = vec3(random(minv, maxv), random(minv, maxv), random(minv, maxv))

        end function random_vec3_uni_range

        type(vec3) function random_in_unit_sphere()

            implicit none

            type(vec3) :: p

            do
                p = random_vec3(-1., 1.)
                if(p%length_squared() >= 1)continue
                exit
            end do

            random_in_unit_sphere = p

        end function random_in_unit_sphere

        type(vec3) function random_unit_vector()

            implicit none

            random_unit_vector = random_in_unit_sphere()
            random_unit_vector = random_unit_vector%magnitude()

        end function random_unit_vector

        type(vec3) function random_in_unit_hemisphere(normal)

            implicit none

            type(vec3), intent(IN) :: normal

            type(vec3) :: in_unit_sphere

            in_unit_sphere = random_in_unit_sphere()
            if((in_unit_sphere .dot. normal) > 0.)then
                random_in_unit_hemisphere = in_unit_sphere
            else
                random_in_unit_hemisphere = (-1.) * in_unit_sphere
            end if

        end function random_in_unit_hemisphere

        type(vec3) function random_in_unit_disk()

            use utils, only : random

            implicit none

            type(vec3) :: p

            do
                p = vec3(random(-1., 1.), random(-1., 1.), 0.)
                if(p%length_squared() >= 1.)continue
                exit
            end do

            random_in_unit_disk = p
        end function random_in_unit_disk

        type(vec3) function abs_vec(this)

            implicit none

            type(vec3), intent(IN) :: this

            abs_vec = vec3(abs(this%x), abs(this%y), abs(this%z))

        end function abs_vec

        type(vec3) function max_vec(this, val)

            implicit none

            type(vec3), intent(IN) :: this
            real, intent(IN) :: val

            max_vec = vec3(max(this%x, val), max(this%y, val), max(this%z, val))

        end function max_vec

        type(vec3) function min_fn(this, val)

            implicit none

            type(vec3), intent(IN) :: this
            real, intent(IN) :: val

            min_fn = vec3(min(this%x, val), min(this%y, val), min(this%z, val))

        end function min_fn

        type(vec3) function vec_minus_vec(a, b)

            implicit none

            class(vec3), intent(IN) :: a
            type(vec3),  intent(IN) :: b

            vec_minus_vec = vec3(a%x - b%x, a%y - b%y, a%z - b%z)

        end function vec_minus_vec

        type(vec3) function vec_add_scal(a, b)

            implicit none

            class(vec3), intent(IN) :: a
            real,        intent(IN) :: b

            vec_add_scal = vec3(a%x + b, a%y + b, a%z + b)

        end function vec_add_scal

        type(vec3) function scal_add_vec(a, b)

            implicit none

            class(vec3), intent(IN) :: b
            real,          intent(IN) :: a

            scal_add_vec = vec3(b%x + a, b%y + a, b%z + a)

        end function scal_add_vec

        type(vec3) function vec_minus_scal(a, b)

            implicit none

            class(vec3), intent(IN) :: a
            real,          intent(IN) :: b

            vec_minus_scal = vec3(a%x - b, a%y - b, a%z - b)

        end function vec_minus_scal

        type(vec3) function scal_minus_vec(a, b)

            implicit none

            class(vec3), intent(IN) :: b
            real,          intent(IN) :: a

            scal_minus_vec = vec3(b%x - a, b%y - a, b%z - a)

        end function scal_minus_vec

        type(vec3) function vec_add_vec(a, b)

            implicit none

            class(vec3), intent(IN) :: a
            type(vec3),  intent(IN) :: b

            vec_add_vec = vec3(a%x + b%x, a%y + b%y, a%z + b%z)

        end function vec_add_vec

        elemental function vec_dot_vec(a, b) result (dot)

            implicit none

            class(vec3), intent(IN) :: a
            type(vec3),  intent(IN) :: b
            real :: dot

            dot = (a%x * b%x) + (a%y * b%y) + (a%z * b%z)

        end function vec_dot_vec

        elemental function vec_cross_vec(a, b) result (cross)

            implicit none

            class(vec3), intent(IN) :: a
            type(vec3),  intent(IN) :: b
            type(vec3) :: cross

            cross = vec3(a%y * b%z - a%z * b%y, &
                         a%z * b%x - a%x * b%z, &
                         a%x * b%y - a%y * b%x)

        end function vec_cross_vec

        function vec_dot_mat(a, b) result (dot)

            implicit none

            class(vec3), intent(IN) :: a
            real,          intent(IN) :: b(4, 4)
            type(vec3) :: dot

            dot%x = b(1, 1)*a%x + b(2, 1)*a%y + b(3, 1)*a%z + b(4, 1)*1.
            dot%y = b(1, 2)*a%x + b(2, 2)*a%y + b(3, 2)*a%z + b(4, 2)*1.
            dot%z = b(1, 3)*a%x + b(2, 3)*a%y + b(3, 3)*a%z + b(4, 3)*1.

        end function vec_dot_mat

        type(vec3) function vec_mult_vec(a, b)

            implicit none

            class(vec3), intent(IN) :: a
            type(vec3),  intent(IN) :: b

            vec_mult_vec = vec3(a%x * b%x, a%y * b%y, a%z * b%z)

        end function vec_mult_vec

        type(vec3) function vec_mult_scal(a, b)

            implicit none

            class(vec3), intent(IN) :: a
            real,          intent(IN) :: b

            vec_mult_scal = vec3(a%x * b, a%y * b, a%z * b)

        end function vec_mult_scal

        type(vec3) function scal_mult_vec(a, b)

            implicit none

            class(vec3), intent(IN) :: b
            real,          intent(IN) :: a

            scal_mult_vec = vec3(a * b%x, a * b%y, a * b%z)

        end function scal_mult_vec

        type(vec3) function vec_div_scal(a, b)

            implicit none

            class(vec3), intent(IN) :: a
            real,         intent(IN) :: b

            vec_div_scal = vec3(a%x / b, a%y / b, a%z / b)

        end function vec_div_scal

        type(vec3) function magnitude_fn(this)

            implicit none

            class(vec3) :: this

            real :: tmp

            tmp = sqrt(this%x**2 + this%y**2 + this%z**2)
            magnitude_fn = this / tmp

        end function magnitude_fn

        real function length(this)

            implicit none

            class(vec3) :: this

            length = sqrt(this%x**2 + this%y**2 + this%z**2)

        end function length

        real function length_squared(this)

            implicit none

            class(vec3) :: this

            length_squared = this%x**2 + this%y**2 + this%z**2

        end function length_squared

    pure function invert(A) result(B)
        !! from http://fortranwiki.org/fortran/show/Matrix+inversion
        !! Performs a direct calculation of the inverse of a 4×4 matrix.
        real, intent(in) :: A(4,4)   !! Matrix

        real             :: B(4,4)   !! Inverse matrix
        real             :: detinv

    ! Calculate the inverse determinant of the matrix
    detinv = &
      1./(A(1,1)*(A(2,2)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+A(2,4)*(A(3,2)*A(4,3)-A(3,3)*A(4,2)))&
        - A(1,2)*(A(2,1)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(2,4)*(A(3,1)*A(4,3)-A(3,3)*A(4,1)))&
        + A(1,3)*(A(2,1)*(A(3,2)*A(4,4)-A(3,4)*A(4,2))+A(2,2)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(2,4)*(A(3,1)*A(4,2)-A(3,2)*A(4,1)))&
        - A(1,4)*(A(2,1)*(A(3,2)*A(4,3)-A(3,3)*A(4,2))+A(2,2)*(A(3,3)*A(4,1)-A(3,1)*A(4,3))+A(2,3)*(A(3,1)*A(4,2)-A(3,2)*A(4,1))))

    ! Calculate the inverse of the matrix
    B(1,1) = detinv*(A(2,2)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+A(2,4)*(A(3,2)*A(4,3)-A(3,3)*A(4,2)))
    B(2,1) = detinv*(A(2,1)*(A(3,4)*A(4,3)-A(3,3)*A(4,4))+A(2,3)*(A(3,1)*A(4,4)-A(3,4)*A(4,1))+A(2,4)*(A(3,3)*A(4,1)-A(3,1)*A(4,3)))
    B(3,1) = detinv*(A(2,1)*(A(3,2)*A(4,4)-A(3,4)*A(4,2))+A(2,2)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(2,4)*(A(3,1)*A(4,2)-A(3,2)*A(4,1)))
    B(4,1) = detinv*(A(2,1)*(A(3,3)*A(4,2)-A(3,2)*A(4,3))+A(2,2)*(A(3,1)*A(4,3)-A(3,3)*A(4,1))+A(2,3)*(A(3,2)*A(4,1)-A(3,1)*A(4,2)))
    B(1,2) = detinv*(A(1,2)*(A(3,4)*A(4,3)-A(3,3)*A(4,4))+A(1,3)*(A(3,2)*A(4,4)-A(3,4)*A(4,2))+A(1,4)*(A(3,3)*A(4,2)-A(3,2)*A(4,3)))
    B(2,2) = detinv*(A(1,1)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(1,3)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(1,4)*(A(3,1)*A(4,3)-A(3,3)*A(4,1)))
    B(3,2) = detinv*(A(1,1)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+A(1,2)*(A(3,1)*A(4,4)-A(3,4)*A(4,1))+A(1,4)*(A(3,2)*A(4,1)-A(3,1)*A(4,2)))
    B(4,2) = detinv*(A(1,1)*(A(3,2)*A(4,3)-A(3,3)*A(4,2))+A(1,2)*(A(3,3)*A(4,1)-A(3,1)*A(4,3))+A(1,3)*(A(3,1)*A(4,2)-A(3,2)*A(4,1)))
    B(1,3) = detinv*(A(1,2)*(A(2,3)*A(4,4)-A(2,4)*A(4,3))+A(1,3)*(A(2,4)*A(4,2)-A(2,2)*A(4,4))+A(1,4)*(A(2,2)*A(4,3)-A(2,3)*A(4,2)))
    B(2,3) = detinv*(A(1,1)*(A(2,4)*A(4,3)-A(2,3)*A(4,4))+A(1,3)*(A(2,1)*A(4,4)-A(2,4)*A(4,1))+A(1,4)*(A(2,3)*A(4,1)-A(2,1)*A(4,3)))
    B(3,3) = detinv*(A(1,1)*(A(2,2)*A(4,4)-A(2,4)*A(4,2))+A(1,2)*(A(2,4)*A(4,1)-A(2,1)*A(4,4))+A(1,4)*(A(2,1)*A(4,2)-A(2,2)*A(4,1)))
    B(4,3) = detinv*(A(1,1)*(A(2,3)*A(4,2)-A(2,2)*A(4,3))+A(1,2)*(A(2,1)*A(4,3)-A(2,3)*A(4,1))+A(1,3)*(A(2,2)*A(4,1)-A(2,1)*A(4,2)))
    B(1,4) = detinv*(A(1,2)*(A(2,4)*A(3,3)-A(2,3)*A(3,4))+A(1,3)*(A(2,2)*A(3,4)-A(2,4)*A(3,2))+A(1,4)*(A(2,3)*A(3,2)-A(2,2)*A(3,3)))
    B(2,4) = detinv*(A(1,1)*(A(2,3)*A(3,4)-A(2,4)*A(3,3))+A(1,3)*(A(2,4)*A(3,1)-A(2,1)*A(3,4))+A(1,4)*(A(2,1)*A(3,3)-A(2,3)*A(3,1)))
    B(3,4) = detinv*(A(1,1)*(A(2,4)*A(3,2)-A(2,2)*A(3,4))+A(1,2)*(A(2,1)*A(3,4)-A(2,4)*A(3,1))+A(1,4)*(A(2,2)*A(3,1)-A(2,1)*A(3,2)))
    B(4,4) = detinv*(A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))+A(1,2)*(A(2,3)*A(3,1)-A(2,1)*A(3,3))+A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1)))
  end function invert
end Module vec3_class


       subroutine quadfit(xin,yin,ndata,poly)

! Polynomial to be fitted:
! Y = a(0) + a(1).X + a(2).X^2 + ... + a(m).X^m

         USE lsq
         IMPLICIT NONE

         REAL*8    :: x(10000),y(10000),xrow(0:20), wt = 1.0, beta(0:20), &
                       var, covmat(231), sterr(0:20), totalSS, center
         real*4  poly(3)
         REAL*8    :: xin(10000), yin(10000)
         INTEGER   :: i, ier, iostatus, j, m, n, ndata
         LOGICAL   :: fit_const = .TRUE., lindep(0:20), xfirst

      do i=1,ndata
         y(i)=yin(i)
         x(i)=xin(i)
      end do

      n=ndata
      m=2

! Least-squares calculations

      CALL startup(m, fit_const)
      DO i = 1, n
         xrow(0) = 1.0
         DO j = 1, m
            xrow(j) = x(i) * xrow(j-1)
         END DO
         CALL includ(wt, xrow, y(i))
      END DO

      CALL sing(lindep, ier)
      IF (ier /= 0) THEN
         DO i = 0, m
            IF (lindep(i)) WRITE(*, '(a, i3)') ' Singularity detected for power: ', i
         END DO
      END IF

! Calculate progressive residual sums of squares
      CALL ss()
      var = rss(m+1) / (n - m - 1)

! Calculate least-squares regn. coeffs.
      CALL regcf(beta, m+1, ier)

! Calculate covariance matrix, and hence std. errors of coeffs.
      CALL cov(m+1, var, covmat, 231, sterr, ier)
      poly(1)=beta(0)
      poly(2)=beta(1)
      poly(3)=beta(2)

!!$      WRITE(*, *) 'Least-squares coefficients & std. errors'
!!$      WRITE(*, *) 'Power  Coefficient          Std.error      Resid.sum of sq.'
!!$      DO i = 0, m
!!$         WRITE(*, '(i4, g20.12, "   ", g14.6, "   ", g14.6)')  &
!!$              i, beta(i), sterr(i), rss(i+1)
!!$      END DO
!!$
!!$      WRITE(*, *)
!!$      WRITE(*, '(a, g20.12)') ' Residual standard deviation = ', SQRT(var)
!!$      totalSS = rss(1)
!!$      WRITE(*, '(a, g20.12)') ' R^2 = ', (totalSS - rss(m+1))/totalSS
      return

      end subroutine quadfit


program test_linspace
    use stdlib_error, only: check
    use stdlib_kinds, only: sp, dp, int8, int16
    use stdlib_math, only: linspace, DEFAULT_LINSPACE_LENGTH

    implicit none

    integer :: iunit
    logical :: warn = .false.
    real(sp), parameter :: TOLERANCE_SP = 1000 * epsilon(1.0_sp)
    real(dp), parameter :: TOLERANCE_DP = 1000 * epsilon(1.0_dp) ! Percentage of the range for which the actual gap must not exceed

    ! Testing linspace.
    !
    ! For single and double precision, check if the beginning and end values are properly recorded
    ! and make sure that the size of the result array is as expected.
    !
    ! This testing suite makes use of the a repeated section of code that will check to make
    ! sure that every element is linearly spaced (i.e., call check(|array(i+1) - array(i)| < |expected_value| * TOLERANCE)).
    ! I would convert this repeated code into a subroutine but that would require the implementation of a
    ! generic procedure given that each linear space will have a different expected_value type and kind.

    open(newunit=iunit, file="test_linspace_log.txt", status="unknown") ! Log the results of the functions

    write(iunit,*) "Writing to unit #: ", iunit

    call test_linspace_sp
    call test_linspace_dp
    call test_linspace_neg_index ! Make sure that when passed a negative index the result is an empty array
    call test_linspace_cmplx
    call test_linspace_cmplx_2
    call test_linspace_cmplx_3
    call test_linspace_cmplx_sp
    call test_linspace_cmplx_sp_2
    call test_linspace_int16
    call test_linspace_int8

    close(unit=iunit)

contains

    subroutine test_linspace_sp

        integer, parameter :: n = 20
        real(sp) :: start = 1.0_sp
        real(sp) :: end = 10.0_sp
        real(sp) :: expected_interval
        real(sp) :: true_difference

        integer :: i
        real(sp), allocatable :: x(:)

        x = linspace(start, end, n)

        expected_interval =( end - start ) / real(( n - 1 ), sp)

        call check(x(1) == start, msg="Initial value of array is not equal to the passed start parameter", warn=warn)
        call check(x(n) == end, msg="Final array value is not equal to end parameter", warn=warn)
        call check(size(x) == n, msg="Array not allocated to appropriate size", warn=warn)

        print *, "Made it through first round of tests"

        ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
        do i = 1, n-1

            true_difference = x(i + 1) - x(i)
            call check(abs(true_difference - expected_interval) < abs(expected_interval) * TOLERANCE_SP)

        end do

    end subroutine

    subroutine test_linspace_dp

        real(dp) :: start = 1.0_dp
        real(dp) :: end = 10.0_dp
        integer, parameter :: n = DEFAULT_LINSPACE_LENGTH
        real(dp) :: expected_interval
        real(dp) :: true_difference

        real(dp), allocatable :: x(:)
        integer :: i

        x = linspace(start, end)

        expected_interval =( end - start ) / ( n - 1 )

        call check(x(1) == start, msg="Initial value of array is not equal to the passed start parameter", warn=warn)
        call check(x(n) == end, msg="Final array value is not equal to end parameter", warn=warn)
        call check(size(x) == n, msg="Array not allocated to default size", warn=warn)

        ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
        do i = 1, n-1

            true_difference = x(i + 1) - x(i)
            call check(abs(true_difference - expected_interval) < abs(expected_interval) * TOLERANCE_DP)

        end do

    end subroutine

    subroutine test_linspace_neg_index

        real(dp) :: start = 1.0_dp
        real(dp) :: end = 10.0_dp

        real(dp), allocatable :: x(:)

        x = linspace(start, end, -15)

        call check(size(x) == 0, msg="Allocated array is not empty", warn=warn)

    end subroutine

    subroutine test_linspace_cmplx

        complex(dp) :: start = (0.0_dp, 10.0_dp)
        complex(dp) :: end = (1.0_dp, 0.0_dp)
        complex(dp) :: expected_interval
        integer, parameter :: n = 10

        complex(dp), allocatable :: z(:)

        integer :: i

        z = linspace(start, end, n)

        expected_interval =( end - start ) / ( n - 1 )

        call check(z(1) == start, msg="Initial value of array is not equal to the passed start parameter", warn=warn)
        call check(z(n) == end, msg="Final array value is not equal to end parameter", warn=warn)
        call check(size(z) == n, msg="Array not allocated to correct size", warn=warn)

        ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
        do i = 1, n-1

            call check(abs( ( z(i + 1) - z(i) ) - expected_interval) < abs(expected_interval) * TOLERANCE_DP)

        end do

        write(unit=iunit, fmt=*) "linspace((0.0_dp, 10.0_dp), (1.0_dp, 0.0_dp), 10): "
        write(unit=iunit,fmt='(70("="))')
        do i = 1, n
            write(unit=iunit,fmt=*) z(i)
        end do
        write(iunit,*)
        write(iunit,*)

    end subroutine

    subroutine test_linspace_cmplx_2

        complex(dp) :: start = (10.0_dp, 10.0_dp)
        complex(dp) :: end = (1.0_dp, 1.0_dp)
        complex(dp) :: expected_interval

        integer, parameter :: n = 5

        complex(dp), allocatable :: z(:)

        integer :: i

        z = linspace(start, end, n)

        expected_interval =( end - start ) / ( n - 1 )

        call check(z(1) == start, msg="Initial value of array is not equal to the passed start parameter", warn=warn)
        call check(z(n) == end, msg="Final array value is not equal to end parameter", warn=warn)
        call check(size(z) == n, msg="Array not allocated to correct size", warn=warn)

        ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
        do i = 1, n-1

            call check(abs( ( z(i + 1) - z(i) ) - expected_interval) < abs(expected_interval) * TOLERANCE_DP)

        end do

        write(unit=iunit, fmt=*) "linspace((10.0_dp, 10.0_dp), (1.0_dp, 1.0_dp), 5): "
        write(unit=iunit,fmt='(70("="))')
        do i = 1, n
            write(unit=iunit,fmt=*) z(i)
        end do
        write(iunit,*)
        write(iunit,*)

    end subroutine

    subroutine test_linspace_cmplx_3

        complex(dp) :: start = (-5.0_dp, 100.0_dp)
        complex(dp) :: end = (20.0_dp, 13.0_dp)
        complex(dp) :: expected_interval

        integer, parameter :: n = 20

        complex(dp), allocatable :: z(:)

        integer :: i

        z = linspace(start, end, n)

        expected_interval = ( end - start ) / ( n - 1 )

        call check(z(1) == start, msg="Initial value of array is not equal to the passed start parameter", warn=warn)
        call check(z(n) == end, msg="Final array value is not equal to end parameter", warn=warn)
        call check(size(z) == n, msg="Array not allocated to correct size", warn=warn)

        ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
        do i = 1, n-1

            call check(abs( ( z(i + 1) - z(i) ) - expected_interval) < abs(expected_interval) * TOLERANCE_DP)

        end do

        write(unit=iunit, fmt=*) "linspace((-5.0_dp, 100.0_dp), (20.0_dp, 13.0_dp), 20): "
        write(unit=iunit,fmt='(70("="))')
        do i = 1, n
            write(unit=iunit,fmt=*) z(i)
        end do
        write(iunit,*)
        write(iunit,*)

    end subroutine

    subroutine test_linspace_cmplx_sp

        complex(sp) :: start = (0.5_sp, 5.0_sp)
        complex(sp) :: end = (1.0_sp, -30.0_sp)
        complex(sp) :: expected_interval

        integer, parameter :: n = 10

        complex(sp), allocatable :: z(:)

        integer :: i

        z = linspace(start, end, n)

        expected_interval =( end - start ) / ( n - 1 )

        call check(z(1) == start, msg="Initial value of array is not equal to the passed start parameter", warn=warn)
        call check(z(n) == end, msg="Final array value is not equal to end parameter", warn=warn)
        call check(size(z) == n, msg="Array not allocated to correct size", warn=warn)

        ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
        do i = 1, n-1

            call check(abs( ( z(i + 1) - z(i) ) - expected_interval) < abs(expected_interval) * TOLERANCE_SP)

        end do

        write(unit=iunit, fmt=*) "linspace((0.5_sp, 5.0_sp), (1.0_sp, -30.0_sp), 10): "
        write(unit=iunit,fmt='(70("="))')
        do i = 1, n
            write(unit=iunit,fmt=*) z(i)
        end do
        write(iunit,*)
        write(iunit,*)

    end subroutine

    subroutine test_linspace_cmplx_sp_2

        complex(sp) :: start = (50.0_sp, 500.0_sp)
        complex(sp) :: end = (-100.0_sp, 2000.0_sp)
        complex(sp) :: expected_interval
        complex(sp) :: true_interval
        real(sp) :: offset

        integer, parameter :: n = DEFAULT_LINSPACE_LENGTH

        complex(sp), allocatable :: z(:)

        integer :: i

        z = linspace(start, end)

        expected_interval =( end - start ) / ( n - 1 )

        call check(z(1) == start, msg="Initial value of array is not equal to the passed start parameter", warn=warn)
        call check(z(n) == end, msg="Final array value is not equal to end parameter", warn=warn)
        call check(size(z) == n, msg="Array not allocated to default size", warn=warn)

        ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
        do i = 1, n-1

            true_interval = (z(i + 1) - z(i))
            offset = abs(true_interval - expected_interval)
            call check(abs( ( z(i + 1) - z(i) ) - expected_interval) < abs(expected_interval) * TOLERANCE_SP)
            ! print *, i

        end do

        write(unit=iunit, fmt=*) "linspace((50.0_sp, 500.0_sp), (-100.0_sp, 2000.0_sp)): "
        write(unit=iunit,fmt='(70("="))')
        do i = 1, n
            write(unit=iunit,fmt=*) z(i)
        end do
        write(iunit,*)
        write(iunit,*)

    end subroutine

    subroutine test_linspace_int16

        integer(int16) :: start = 5
        integer(int16) :: end = 10
        real(dp) :: expected_interval

        integer, parameter :: n = 6

        integer(int16), allocatable :: z(:)

        integer :: i

        z = linspace(start, end, n)

        expected_interval =( end - start ) / ( n - 1 )

        call check(z(1) == start, msg="Initial value of array is not equal to the passed start parameter", warn=warn)
        call check(z(n) == end, msg="Final array value is not equal to end parameter", warn=warn)
        call check(size(z) == n, msg="Array not allocated to correct size", warn=warn)

        ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
        do i = 1, n-1

            call check(abs( ( z(i + 1) - z(i) ) - expected_interval) < abs(expected_interval) * TOLERANCE_DP)

        end do

        write(unit=iunit, fmt=*) "linspace(5_int16, 10_int16, 10): "
        write(unit=iunit,fmt='(70("="))')
        do i = 1, n
            write(unit=iunit,fmt=*) z(i)
        end do
        write(iunit,*)
        write(iunit,*)

    end subroutine

    subroutine test_linspace_int8

        integer(int8) :: start = 20
        integer(int8) :: end = 50

        real(dp) :: expected_interval

        integer, parameter :: n = 10

        real(dp), allocatable :: z(:)
        integer(int8) :: z_int(n)

        integer :: i

        z = linspace(start, end, n)
        z_int = linspace(start, end, n)

        expected_interval =real( end - start, dp ) / ( n - 1 )

        call check(z(1) == start, msg="Initial value of array is not equal to the passed start parameter", warn=warn)
        call check(z(n) == end, msg="Final array value is not equal to end parameter", warn=warn)
        call check(size(z) == n, msg="Array not allocated to correct size", warn=warn)

        ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
        do i = 1, n-1

            call check(abs( ( z(i + 1) - z(i) ) - expected_interval) < abs(expected_interval) * TOLERANCE_DP)

        end do

        write(unit=iunit, fmt=*) "linspace(5_int16, 10_int16, 10): "
        write(unit=iunit,fmt='(70("="))')
        do i = 1, n
            write(unit=iunit,fmt=*) z(i)
        end do
        write(iunit,*)
        write(iunit,*)

    end subroutine

end program


use, intrinsic :: iso_fortran_env, only : error_unit
implicit none

! http://fortranwiki.org/fortran/show/Real+precision
integer, parameter :: sp = selected_real_kind(6, 37)
integer, parameter :: dp = selected_real_kind(15, 307)

real(sp) :: a32
real(dp) :: a64

real(sp), parameter :: pi32 = 4*atan(1._sp)
real(dp), parameter :: pi64 = 4*atan(1._dp)

if (pi32 == pi64) stop 1

call timestwo(a32)
call timestwo(a64)

contains

elemental subroutine timestwo(a)

class(*), intent(inout) :: a

select type (a)
  type is (real(sp))
    a = 2*a
  type is (real(dp))
    a = 2*a
  type is (integer)
    a = 2*a
end select

end subroutine timestwo

end program