      module cfunc
      implicit none
      integer*4 :: icrtc=0
      end module

      module mathfun
      use cfunc
      real*8 ,parameter :: epsieee=5.d-17,
     $     xths1=(epsieee*362880.d0/6.d0)**(1.d0/6.d0),
     $     xths2=(epsieee*6227020800.d0/6.d9)**(1.d0/10.d0),
     $     xthc1=(epsieee*40320.d0/2.d0)**(1.d0/6.d0),
     $     xthc2=(epsieee*479001600.d0/2.d0)**(1.d0/10.d0),
     $     xthcs1=min(xths1,xthc1),
     $     xthcs2=min(xths2,xthc2),
     $     xthasx=(epsieee*13312.d0/231.d0/6.d0)**(1.d0/10.d0)

      contains
      real*8 pure function tfloor(x)
      implicit none
      real*8 ,intent(in)::x
      tfloor=aint(x+1.d-15)
      if(x .lt. 0.d0 .and. x .ne. tfloor)then
        tfloor=tfloor-1.d0
      endif
      return
      end

      complex*16 pure function tcfloor(z)
      implicit none
      complex*16 ,intent(in)::z
      tcfloor=dcmplx(tfloor(dble(z)),tfloor(imag(z)))
      return
      end

      real*8 pure function tceiling(x)
      implicit none
      real*8 ,intent(in)::x
      tceiling=-aint(-x+1.d-15)
      if(x .gt. 0.d0 .and. x .ne. tceiling)then
        tceiling=1.d0+tceiling
      endif
      return
      end

      complex*16 pure function tcceiling(z)
      implicit none
      complex*16 ,intent(in)::z
      tcceiling=dcmplx(tceiling(dble(z)),tceiling(imag(z)))
      return
      end

      real*8 pure function tround(x)
      implicit none
      real*8 ,intent(in)::x
      tround=sign(aint(abs(x)+0.5d0),x)
      return
      end

      complex*16 pure function tcround(z)
      implicit none
      complex*16 ,intent(in)::z
      tcround=dcmplx(tround(dble(z)),tround(imag(z)))
      return
      end

      real*8 pure function tfevenq(x)
      implicit none
      real*8 ,intent(in)::x
      tfevenq=merge(1.d0,0.d0,x*.5d0 .eq. aint(x*.5d0))
      return
      end

      real*8 pure function tfoddq(x)
      implicit none
      real*8 ,intent(in)::x
      tfoddq=tfevenq(x+1.d0)
      return
      end

      complex*16 pure function tfcevenq(z)
      implicit none
      complex*16 ,intent(in)::z
      tfcevenq=dcmplx(tfevenq(dble(z)),tfevenq(imag(z)))
      return
      end

      complex*16 pure function tfcoddq(z)
      implicit none
      complex*16 ,intent(in)::z
      tfcoddq=dcmplx(tfoddq(dble(z)),tfoddq(imag(z)))
      return
      end

      complex*16 pure function tcsinh(z)
      implicit none
      complex*16 ,intent(in)::z
      complex*16 z1
      z1=dcmplx(-imag(z),dble(z))
      tcsinh=sin(z1)
      tcsinh=dcmplx(imag(tcsinh),-dble(tcsinh))
      return
      end

      complex*16 pure function tccosh(z)
      implicit none
      complex*16 ,intent(in)::z
      tccosh=cos(dcmplx(-imag(z),dble(z)))
      return
      end

      complex*16 pure function tctanh(z)
      implicit none
      complex*16 ,intent(in)::z
      complex*16 z1
      z1=dcmplx(-imag(z),dble(z))
      tctanh=sin(z1)/cos(z1)
      tctanh=dcmplx(imag(tctanh),-dble(tctanh))
      return
      end

      complex*16 pure function tcatan(z)
      implicit none
      complex*16 ,intent(in)::z
      tcatan=merge(dcmplx(0.d0,atanh(dimag(z))),
     $     .5d0*dcmplx(atan2(dble(z),1.d0+imag(z))
     $     -atan2(-dble(z),1.d0-imag(z)),
     $     log(((1.d0+imag(z))**2+dble(z)**2)/
     $     ((1.d0-imag(z))**2+dble(z)**2))*.5d0),
     $     dble(z) .eq. 0.d0)
      return
      end

      complex*16 pure function tcatan2(z1,z)
      use macmath
      implicit none
      complex*16 ,intent(in)::z,z1
      if(z .eq. (0.d0,0.d0))then
        if(dble(z1) .eq. 0.d0)then
          tcatan2=dcmplx(merge(0.d0,sign(m_pi_2,imag(z1)),
     $         imag(z1) .eq. 0.d0),0.d0)
        else
          tcatan2=sign(m_pi_2,dble(z1))
        endif
      else
        tcatan2=tcatan(z1/z)
      endif
      return
      end

      complex*16 pure function tcasin(z)
      implicit none
      complex*16 ,intent(in)::z
      complex*16 z1
      z1=sqrt(1.d0-z**2)+(0.d0,1.d0)*z
      tcasin=dcmplx(atan2(imag(z1),dble(z1)),
     $     -.5d0*log(dble(z1)**2+imag(z1)**2))
      return
      end

      complex*16 pure function tcacos(z)
      implicit none
      complex*16 ,intent(in)::z
      complex*16 z1
      z1=sqrt(1.d0-z**2)+(0.d0,1.d0)*z
      tcacos=dcmplx(atan2(dble(z1),imag(z1)),
     $     .5d0*log(dble(z1)**2+imag(z1)**2))
      return
      end

      complex*16 pure function tcasinh(z)
      implicit none
      complex*16 ,intent(in)::z
      complex*16 z1
      z1=dcmplx(-imag(z),dble(z))
      z1=tcasin(z1)
      tcasinh=dcmplx(imag(z1),-dble(z1))
      return
      end

      complex*16 pure function tcacosh(z)
      implicit none
      complex*16 ,intent(in)::z
      complex*16 z1
      z1=tcacos(z)
      tcacosh=dcmplx(imag(z1),-dble(z1))
      return
      end

      complex*16 pure function tcatanh(z)
      implicit none
      complex*16 ,intent(in)::z
      complex*16 z1
      z1=dcmplx(-imag(z),dble(z))
      z1=tcatan(z1)
      tcatanh=dcmplx(imag(z1),-dble(z1))
      return
      end

      real*8 pure function xsin(x) result(xs)
      implicit none
      real*8 ,intent(in)::x
      real*8 x2
      if(abs(x) .lt. xths1)then
        x2=x**2
        xs=x*x2*(1.d0/6.d0-x2*(1.d0/120.d0-x2/5040.d0))
      elseif(abs(x) .lt. xths2)then
        x2=x**2
        xs=x*x2*(1.d0/6.d0-x2*(1.d0/120.d0-x2*(
     1       1.d0/5040.d0-x2*(1.d0/362880.d0-x2/39916800.d0))))
      else
        xs=x-sin(x)
      endif
      return
      end

      subroutine sxsin(x,s,xs)
      implicit none
      real*8 ,intent(in)::x
      real*8 ,intent(out)::s,xs
      real*8 x2
      if(abs(x) .lt. xths1)then
        x2=x**2
        xs=x*x2*(1.d0/6.d0-x2*(1.d0/120.d0-x2/5040.d0))
        s=x-xs
      elseif(abs(x) .lt. xths2)then
        x2=x**2
        xs=x*x2*(1.d0/6.d0-x2*(1.d0/120.d0-x2*(
     1       1.d0/5040.d0-x2*(1.d0/362880.d0-x2/39916800.d0))))
        s=x-xs
      else
        s=sin(x)
        xs=x-s
      endif
      return
      end

      pure elemental subroutine xsincos(x,s,xs,c,dc)
      implicit none
      real*8 ,intent(in)::x
      real*8 ,intent(out)::s,xs,c,dc
      real*8 x2
      if(abs(x) .lt. xthcs1)then
        x2=x**2
        xs=x*x2*(1.d0/6.d0-x2*(1.d0/120.d0-x2/5040.d0))
        s=x-xs
        dc=-x2*(.5d0-x2*(1.d0/24.d0-x2/720.d0))
        c=1.d0+dc
      elseif(abs(x) .lt. xthcs2)then
        x2=x**2
        xs=x*x2*(1.d0/6.d0-x2*(1.d0/120.d0-x2*(
     1       1.d0/5040.d0-x2*(1.d0/362880.d0-x2/39916800.d0))))
        s=x-xs
        dc=-x2*(.5d0-x2*(1.d0/24.d0-x2*
     $       (1.d0/720.d0-x2*(1.d0/40320.d0-x2/3628800.d0))))
        c=1.d0+dc
      else
        s=sin(x)
        xs=x-s
        c=cos(x)
        dc=merge(-s**2/(1.d0+c),c-1.d0,c .gt. 0.d0)
      endif
      return
      end

      real*8 pure function xsinh(x)
      implicit none
      real*8 ,intent(in)::x
      real*8 x2
      if(abs(x) .lt. xths1)then
        x2=x**2
        xsinh=-x*x2*(1.d0/6.d0+x2*(1.d0/120.d0+x2/5040.d0))
      elseif(abs(x) .lt. xths2)then
        x2=x**2
        xsinh=-x*x2*(1.d0/6.d0+x2*(1.d0/120.d0+x2*(
     1       1.d0/5040.d0+x2*(1.d0/362880.d0+x2/39916800.d0))))
      else
        xsinh=x-sinh(x)
      endif
      return
      end

      pure elemental subroutine sxsinh(x,sh,xsh)
      implicit none
      real*8 ,intent(in)::x
      real*8 ,intent(out)::sh,xsh
      real*8 x2
      if(abs(x) .lt. xths1)then
        x2=x**2
        xsh=-x*x2*(1.d0/6.d0+x2*(1.d0/120.d0+x2/5040.d0))
        sh=x-xsh
      elseif(abs(x) .lt. xths2)then
        x2=x**2
        xsh=-x*x2*(1.d0/6.d0+x2*(1.d0/120.d0+x2*(
     1       1.d0/5040.d0+x2*(1.d0/362880.d0+x2/39916800.d0))))
        sh=x-xsh
      else
        sh=sinh(x)
        xsh=x-sh
      endif
      return
      end

      pure elemental subroutine xsincosh(x,sh,xsh,ch,dch)
      implicit none
      real*8 ,intent(in)::x
      real*8 ,intent(out)::sh,xsh,ch,dch
      real*8 x2
      if(abs(x) .lt. xthcs1)then
        x2=x**2
        xsh=-x*x2*(1.d0/6.d0+x2*(1.d0/120.d0+x2/5040.d0))
        sh=x-xsh
        dch= x2*(.5d0+x2*(1.d0/24.d0+x2/720.d0))
        ch=1.d0+dch
      elseif(abs(x) .lt. xthcs2)then
        x2=x**2
        xsh=-x*x2*(1.d0/6.d0+x2*(1.d0/120.d0+x2*(
     1       1.d0/5040.d0+x2*(1.d0/362880.d0+x2/39916800.d0))))
        sh=x-xsh
        dch= x2*(.5d0+x2*(1.d0/24.d0+x2*
     $       (1.d0/720.d0+x2*(1.d0/40320.d0+x2/3628800.d0))))
        ch=1.d0+dch
      else
        sh=sinh(x)
        xsh=x-sh
        ch=cosh(x)
        dch=sh**2/(1.d0+ch)
      endif
      return
      end

      real*8 pure function xlog(x)
      implicit none
      real*8 ,intent(in)::x
      xlog=merge(log(1.d0+x),
     $     x*(1.d0-x*(.5d0-x*(1.d0/3.d0
     1     -x*(.25d0-x*(.2d0-x*(1.d0/6.d0
     1     -x*(1.d0/7.d0-x*(.125d0-x/9.d0)))))))),
     $     abs(x) .gt. 1.d-2)
      return
      end

      real*8 pure function sinc(x)
      implicit none
      real*8 ,intent(in)::x
      real*8 x2
      if(abs(x) .gt. .1d0)then
        sinc=x*cos(x)-sin(x)
      else
        x2=-x**2
        sinc=x*x2*(1.d0/3.d0+x2*(1.d0/30.d0+x2*(
     1       1.d0/840.d0+x2*(1.d0/45360.d0+x2/3991680.d0))))
      endif
      return
      end

      real*8 pure function sinhc(x)
      implicit none
      real*8 ,intent(in)::x
      real*8 x2
      if(abs(x) .gt. .1d0)then
        sinhc=x*cosh(x)-sinh(x)
      else
        x2=x**2
        sinhc=x*x2*(1.d0/3.d0+x2*(1.d0/30.d0+x2*(
     1       1.d0/840.d0+x2*(1.d0/45360.d0+x2/3991680.d0))))
      endif
      return
      end

      complex*16 pure function tcxsin(x)
      implicit none
      complex*16 ,intent(in)::x
      complex*16 x2
      if(abs(x) .gt. .1d0)then
        tcxsin=x-sin(x)
      else
        x2=x**2
        tcxsin=x*x2/6.d0*(1.d0-x2/20.d0*(1.d0-x2/42.d0*(
     1       1.d0-x2/72.d0*(1.d0-x2/110.d0))))
      endif
      return
      end

      complex*16 pure function ccdabs(c)
      implicit none
      complex*16 ,intent(in)::c
      ccdabs=dcmplx(abs(c),0.d0)
      return
      end

      real*8 pure function tfsign(x)
      implicit none
      real*8 ,intent(in)::x
      tfsign=merge(1.d0,merge(0.d0,-1.d0,x .eq. 0.d0),
     $     x .gt. 0.d0)
      return
      end

      complex*16 pure function tfcsign(cx)
      implicit none
      complex*16 ,intent(in)::cx
      tfcsign=merge((0.d0,0.d0),cx/abs(cx),cx .eq. (0.d0,0.d0))
      return
      end

      real*8 pure function tfarg(x)
      implicit none
      real*8 ,intent(in)::x
      tfarg=merge(0.d0,asin(1.d0)*2.d0,x .ge. 0.d0)
      return
      end

      complex*16 pure function tfcarg(z)
      implicit none
      complex*16 ,intent(in)::z
      tfcarg=imag(log(z))
      return
      end

      complex*16 pure function tfdummy(c)
      use cfunc
      implicit none
      complex*16 ,intent(in)::c
      tfdummy=(0.d0,0.d0)
      return
      end

      real*8 pure elemental function sqrtl(x)
      implicit none
      real*8 ,intent(in)::  x
      real*8 ,parameter :: am=1.d-100
      sqrtl=sqrt(max(x,am))
      return
      end function

      real*8 pure elemental function p2h(p)
      implicit none
      real*8, intent(in) :: p
      real*8 p2
      real*8, parameter:: pth=1.d3;
      if(p .gt. pth)then
        p2=1.d0/p**2
        p2h=p*(1.d0+p2*(0.5d0-p2*.125d0))
      else
        p2h=hypot(1.d0,p)
      endif
      return
      end function

      real*8 pure elemental function h2p(h)
      implicit none
      real*8, intent(in) :: h
      real*8 h2
      real*8, parameter:: hth=1.d3;
      if(h .gt. hth)then
        h2=-1.d0/h**2
        h2p=h*(1.d0+h2*(0.5d0-h2*.125d0))
      else
        h2p=sqrt(h**2-1.d0)
      endif
      return
      end function

      real*8 pure elemental function pxy2dpz(px,py)
      implicit none
      real*8, intent(in) :: px,py
      real*8 x
      real*8, parameter:: xth=8.d-6,xmin=1.d-200
      x=px**2+py**2
      if(x .lt. xth)then
        pxy2dpz=-x*(0.5d0+x*(0.125d0+x*0.0625d0))
      else
        pxy2dpz=-x/(1.d0+sqrt(max(xmin,1.d0-x)))
      endif
      return
      end function

      real*8 pure elemental function sqrt1(x)
      implicit none
      real*8, intent(in) :: x
      real*8, parameter:: xth=8.d-6,xth1=3.4d-3,xmin=1.d-200
      if(abs(x) .lt. xth)then
        sqrt1=x*(0.5d0+x*(-0.125d0+x*0.0625d0))
      elseif(abs(x) .lt. xth1)then
        sqrt1=x*(0.5d0+x*(-0.125d0+x*(0.0625d0+
     $       x*(-.0390625d0+x*(.02734375d0-.0205078125*x)))))
      else
        sqrt1=x/(1.d0+sqrt(max(xmin,1.d0+x)))
      endif
      return
      end function

      real*8 pure elemental function sqrt1n(x)
      implicit none
      real*8, intent(in) :: x
      sqrt1n=x*(0.5d0-x*(0.125d0-x*0.0625d0))
      sqrt1n=(sqrt1n**2+x)/(2.d0+2.d0*sqrt1n)
      sqrt1n=(sqrt1n**2+x)/(2.d0+2.d0*sqrt1n)
      return
      end function

      real*8 function akang(ak,al,cr1) result(theta1)
      use macmath, only:m_pi_2
      implicit none
      complex*16 , intent(in)::ak
      complex*16 , intent(out)::cr1
      real*8 , intent(in)::al
      complex*16 a
      if(al .eq. 0.d0)then
        if(imag(ak) .eq. 0.d0)then
          if(dble(ak) .lt. 0.d0)then
            theta1=m_pi_2
            cr1=(0.d0,-1.d0)
          else
            theta1=0.d0
            cr1=(1.d0,0.d0)
          endif
        else
          theta1=atan2(imag(ak),dble(ak))*.5d0
          cr1=dcmplx(cos(theta1),-sin(theta1))
        endif
      else
        a=ak*al
        if(imag(a) .eq. 0.d0)then
          if(dble(a) .lt. 0.d0)then
            theta1=m_pi_2
            cr1=(0.d0,-1.d0)
          else
            theta1=0.d0
            cr1=(1.d0,0.d0)
          endif
        else
          theta1=atan2(imag(a),dble(a))*.5d0
          cr1=dcmplx(cos(theta1),-sin(theta1))
        endif
      endif
      return
      end function

      real*8 pure elemental function asinz(x)
      implicit none
      real*8 ,intent(in):: x
      real*8 x2
      if(abs(x) .lt. 0.0032d0)then
        x2=x**2
        asinz=x+x*x2*(1.d0/6.d0+x2*3.d0/40.d0)
      else
        asinz=asin(min(1.d0,max(-1.d0,x)))
      endif
      return
      end function

      real*8 pure elemental function asinx(x)
      implicit none
      real*8 ,intent(in):: x
      real*8 x2
      if(abs(x) .lt. xthasx)then
        x2=x**2
        asinx=x*x2*(1.d0/6.d0+x2*(3.d0/40.d0+x2*(5.d0/112.d0
     $       +x2*(35.d0/1152.d0+x2*63.d0/2816.d0))))
      else
        asinx=asin(min(1.d0,max(-1.d0,x)))-x
      endif
      return
      end function

      complex*16 pure elemental function zeroim(x) result(f)
      implicit none
      complex*16 ,intent(in):: x
      if(imag(x) .eq. 0.d0)then
        f=dcmplx(dble(x),0.d0)
      else
        f=x
      endif
      if(dble(f) .eq. 0.d0)then
        f=dcmplx(0.d0,imag(f))
      endif
      return
      end function

      complex*16 pure elemental function conjz(x) result(f)
      implicit none
      complex*16 ,intent(in):: x
      f=conjg(x)
      if(imag(x) .eq. 0.d0)then
        f=dcmplx(dble(x),0.d0)
      endif
      if(dble(f) .eq. 0.d0)then
        f=dcmplx(0.d0,imag(f))
      endif
      return
      end function

      real*8 pure elemental function moduloc(x,a) result(f)
      implicit none
      real*8 ,intent(in):: x,a
      if(x .ge. 0.d0)then
        f=modulo(x,a)
      else
        f=-modulo(-x,a)
      endif
      return
      end function

      real*8 pure elemental function moduloc2(x) result(f)
      implicit none
      real*8 ,intent(in):: x
      if(x .ge. 0.d0)then
        f=modulo(x,2.d0)
        if(f .gt. 1.d0)then
          f=f-2.d0
        endif
      else
        f=-modulo(-x,2.d0)
        if(f .lt. -1.d0)then
          f=f+2.d0
        endif
      endif
      return
      end function

      complex*16 pure elemental function csinp(z) result(f)
      use macmath
      implicit none
      complex*16 ,intent(in):: z
      f=sin(m_pi*dcmplx(moduloc2(dble(z)),imag(z)))
      return
      end function

      real*8 pure elemental function sinp(x) result(f)
      use macmath
      implicit none
      real*8 ,intent(in):: x
      f=sin(moduloc2(x)*m_pi)
      return
      end function

      complex*16 pure elemental function ccosp(z) result(f)
      use macmath
      implicit none
      complex*16 ,intent(in):: z
      f=cos(m_pi*dcmplx(moduloc(dble(z),2.d0),imag(z)))
      return
      end function

      real*8 pure elemental function cosp(x) result(f)
      use macmath
      implicit none
      real*8 ,intent(in):: x
      f=cos(moduloc(x,2.d0)*m_pi)
      return
      end function

      complex*16 pure elemental function cexpp(z) result(f)
      use macmath
      implicit none
      complex*16 ,intent(in):: z
      f=exp(m_pi*dble(z))*dcmplx(cosp(imag(z)),sinp(imag(z)))
      return
      end function

      end module

      subroutine tfmod(isp1,kx,mode,irtc)
      use tfstk
      implicit none
      type (sad_descriptor) ,intent(out):: kx
      type (sad_descriptor) tfmodf
      integer*4 ,intent(in):: isp1
      integer*4 ,intent(out):: irtc
      integer*4 itfmessage,mode,i
      if(isp .le. isp1+1)then
        irtc=itfmessage(9,'General::narg','"2"')
      elseif(isp .ne. isp1+2)then
        if(mode .eq. 0)then
          irtc=itfmessage(9,'General::narg','"2"')
        else
          kx=dtastk(isp1+1)
          do i=isp1+2,isp
            kx=tfmodf(kx,dtastk(i),mode,irtc)
            if(irtc .ne. 0)then
              return
            endif
          enddo
        endif
      else
        kx=tfmodf(dtastk(isp1+1),dtastk(isp),mode,irtc)
      endif
      return
      end

      recursive function tfmodf(k1,k2,mode,irtc)
     $     result(kx)
      use iso_c_binding
      use tfstk
      use mathfun
      implicit none
      type (sad_descriptor) kx
      type (sad_descriptor) ,intent(in):: k1,k2
      type (sad_dlist), pointer :: klx,kl1,kl2
      type (sad_rlist), pointer :: klr
      integer*4 ,intent(in):: mode
      integer*4 ,intent(out):: irtc
      integer*8 ka1,ka2
      integer*4 i,n1,n2,itfmessage,isp0,isp2
      real*8 v1,v2,vx
      complex*16 c1,c2,cx
c     begin initialize for preventing compiler warning
      cx=0.d0
      vx=0.d0
      kx%k=ktfoper+mtfnull
c     end   initialize for preventing compiler warning
      ka1=ktfaddrd(k1)
      ka2=ktfaddrd(k2)
      if(tfcomplexnumlistqk(k1%k,kl1))then
        n1=kl1%nl
        if(tfcomplexnumlistqk(k2%k,kl2))then
          if(n1 .ne. kl2%nl)then
            irtc=itfmessage(9,'General::equalleng','"#1 and #2"')
            return
          endif
          isp0=isp
          if(ktfreallistq(kl1) .and. ktfreallistq(kl2))then
            kx=kxavaloc(-1,n1,klr)
            call descr_sad(kx,klx)
            klr%attr=ior(klr%attr,lconstlist)
            select case (mode)
            case (0)
              do i=1,n1
                klr%rbody(i)=kl1%rbody(i)
     $               -tfloor(kl1%rbody(i)/kl2%rbody(i))*kl2%rbody(i)
              enddo
            case (1)
c              do i=1,n1
              klr%rbody(1:n1)=iand(int8(kl1%rbody(1:n1)),
     $             int8(kl2%rbody(1:n1)))
c              enddo
            case (2)
c              do i=1,n1
              klr%rbody(1:n1)=ior(int8(kl1%rbody(1:n1)),
     $             int8(kl2%rbody(1:n1)))
c              enddo
            case (3)
c              do i=1,n1
              klr%rbody(1:n1)=ieor(int8(kl1%rbody(1:n1)),
     $             int8(kl2%rbody(1:n1)))
c              enddo
            end select
          else
            call tfgetllstkall(kl1)
            call tfgetllstkall(kl2)
            isp2=isp
            do i=1,n1
              isp=isp+1
              dtastk(isp)=tfmodf(dtastk(isp0+i),dtastk(isp0+n1+i),
     $             mode,irtc)
              if(irtc .ne. 0)then
                isp=isp0
                return
              endif
            enddo
            kx=kxmakelist(isp2)
            isp=isp0
          endif
        elseif(tfnumberq(k2))then
          isp0=isp
          call tfgetllstkall(kl1)
          isp2=isp
          do i=1,n1
            isp=isp+1
            dtastk(isp)=tfmodf(dtastk(isp0+i),k2,mode,irtc)
            if(irtc .ne. 0)then
              isp=isp0
              return
            endif
          enddo
          kx=kxmakelist(isp2)
          isp=isp0
        else
          irtc=-1
          return
        endif
      elseif(tfcomplexnumlistqk(k2%k,kl2) .and. (tfcomplexq(k1) .or.
     $       tfnonlistq(k1)))then
        n2=kl2%nl
        isp0=isp
        call tfgetllstkall(kl2)
        isp2=isp
        do i=1,n2
          isp=isp+1
          dtastk(isp)=tfmodf(k1,dtastk(isp0+i),mode,irtc)
          if(irtc .ne. 0)then
            isp=isp0
            return
          endif
        enddo
        kx=kxmakelist(isp2)
        isp=isp0
      elseif(ktfrealq(k1,v1))then
        if(ktfrealq(k2,v2))then
          select case (mode)
          case (0)
            if(k2%k .eq. 0)then
              irtc=itfmessage(9,'General::wrongval','"#2","nonzero"')
              return
            endif
            vx=v1-tfloor(v1/v2)*v2
          case (1)
            vx=iand(int8(v1),int8(v2))
          case (2)
            vx=ior(int8(v1),int8(v2))
          case (3)
            vx=ieor(int8(v1),int8(v2))
          end select
          kx=dfromr(vx)
        elseif(tfcomplexq(k2,c2))then
          select case (mode)
          case (0)
            cx=v1-tcfloor(v1/c2)*c2
          case (1)
            cx=dcmplx(dble(iand(int(v1),int(dble(c2)))),
     $           dble(iand(int(v1),int(imag(c2)))))
          case (2)
            cx=dcmplx(dble(ior(int(v1),int(dble(c2)))),
     $           dble(ior(int(v1),int(imag(c2)))))
          case (3)
            cx=dcmplx(dble(ieor(int(v1),int(dble(c2)))),
     $           dble(ieor(int(v1),int(imag(c2)))))
          end select
          go to 10
        else
          irtc=-1
          return
        endif
      elseif(tfcomplexq(k1,c1))then
        if(ktfrealq(k2,v2))then
          select case(mode)
          case (0)
            if(v2 .eq. 0.d0)then
              irtc=itfmessage(9,'General::wrongval','"#2","nonzero"')
              return
            endif
            cx=c1-tcfloor(c1/v2)*v2
          case (1)
            cx=dcmplx(dble(iand(int8(dble(c1)),int8(v2))),
     $           dble(iand(int8(imag(c1)),int8(v2))))
          case (2)
            cx=dcmplx(dble(ior(int8(dble(c1)),int8(v2))),
     $           dble(ior(int8(imag(c1)),int8(v2))))
          case (3)
            cx=dcmplx(dble(ieor(int8(dble(c1)),int8(v2))),
     $           dble(ieor(int8(imag(c1)),int8(v2))))
          end select
        elseif(tfcomplexq(k2,c2))then
          select case (mode)
          case (0)
            cx=c1-tcfloor(c1/c2)*c2
          case (1)
            cx=dcmplx(dble(iand(int8(dble(c1)),int8(dble(c2)))),
     $           dble(iand(int8(imag(c1)),int8(imag(c2)))))
          case (2)
            cx=dcmplx(dble(ior(int8(dble(c1)),int8(dble(c2)))),
     $           dble(ior(int8(imag(c1)),int8(imag(c2)))))
          case (3)
            cx=dcmplx(dble(ieor(int8(dble(c1)),int8(dble(c2)))),
     $           dble(ieor(int8(imag(c1)),int8(imag(c2)))))
          end select
        else
          irtc=-1
          return
        endif
        go to 10
      elseif(tflistq(k1%k,kl1))then
        n1=kl1%nl
        if(tflistq(k2%k,kl2))then
          if(n1 .ne. kl2%nl)then
            irtc=itfmessage(9,'General::equalleng','"#1 and #2"')
            return
          endif
          isp0=isp
          call tfgetllstkall(kl1)
          call tfgetllstkall(kl2)
          isp2=isp
          do i=1,n1
            isp=isp+1
            dtastk(isp)=tfmodf(dtastk(isp0+i),dtastk(isp0+n1+i),
     $           mode,irtc)
            if(irtc .ne. 0)then
              isp=isp0
              return
            endif
          enddo
          kx=kxmakelist(isp2)
          isp=isp0
        else
          isp0=isp
          call tfgetllstkall(kl1)
          isp2=isp
          do i=1,isp2-isp0
            isp=isp+1
            dtastk(isp)=tfmodf(dtastk(isp0+i),k2,mode,irtc)
            if(irtc .ne. 0)then
              isp=isp0
              return
            endif
          enddo
          kx=kxmakelist(isp2)
          isp=isp0
        endif
      else
        irtc=-1
        return
      endif
      irtc=0
      return
 10   kx=kxcalocc(-1,cx)
      irtc=0
      return
      end

      function tfminmax(isp1,mode,irtc) result(kx)
      use tfstk
      use iso_c_binding
      implicit none
      type (sad_descriptor) kx
      type (sad_dlist), pointer :: kli,klx
      type (sad_rlist), pointer :: klr,klir
      integer*4 ,intent(in):: isp1,mode
      integer*4 ,intent(out):: irtc
      integer*4 i
      real*8 xmin,xmax,ymin,ymax
      logical*4 cpx
      xmin=dinfinity
      xmax=-xmin
      cpx=.false.
      ymin=dinfinity
      ymax=-ymin
      if(isp .eq. isp1+1)then
        if(ktastk(isp) .eq. ktfoper+mtfnull)then
          go to 10
        endif
      endif
      do i=isp1+1,isp
        if(ktfrealq(ktastk(i)))then
          xmin=min(xmin,rtastk(i))
          xmax=max(xmax,rtastk(i))
        elseif(ktflistq(ktastk(i),kli))then
          if(kli%head%k .eq. ktfoper+mtfcomplex)then
            if(ktfnonreallistqo(kli) .or. kli%nl .ne. 2)then
              go to 9000
            endif
            call c_f_pointer(c_loc(kli),klir)
            cpx=.true.
            xmin=min(xmin,klir%rbody(1))
            xmax=max(xmax,klir%rbody(1))
            ymin=min(ymin,klir%rbody(2))
            ymax=max(ymax,klir%rbody(2))
          elseif(kli%head%k .eq. ktfoper+mtflist)then
            call tfminandmaxl(ksad_loc(kli%head%k),
     $           xmin,xmax,ymin,ymax,cpx,irtc)
            if(irtc .ne. 0)then
              kx=dxnullo
              return
            endif
          else
            go to 9000
          endif
        else
          go to 9000
        endif
      enddo
 10   if(mode .eq. 0)then
        if(cpx)then
          kx=kxadaloc(-1,2,klx)
          klx%dbody(1)=kxcalocv(0,xmin,ymin)
          klx%dbody(2)=kxcalocv(0,xmax,ymax)
        else
          kx=kxavaloc(-1,2,klr)
          call descr_sad(kx,klx)
          klr%rbody(1)=xmin
          klr%rbody(2)=xmax
        endif
        klx%attr=ior(klx%attr,lconstlist)
      elseif(mode .eq. 1)then
        kx=merge(kxcalocv(-1,xmin,ymin),dfromr(xmin),cpx)
      else
        kx=merge(kxcalocv(-1,xmax,ymax),dfromr(xmax),cpx)
      endif
      irtc=0
      return
 9000 irtc=-1
      kx=dxnullo
      return
      end

      recursive subroutine tfminandmaxl(ka,xmin,xmax,ymin,ymax,cpx,irtc)
      use tfstk
      use iso_c_binding
      implicit none
      type (sad_descriptor) ki
      type (sad_dlist), pointer :: kl,kli
      type (sad_complex), pointer :: klic
      integer*8 ka,i
      integer*4 irtc,n
      real*8 xmin,xmax,ymin,ymax
      logical*4 cpx
      n=ilist(2,ka-1)
      if(n .ne. 0)then
        call loc_sad(ka,kl)
        if(ktfreallistq(kl))then
          xmin=min(xmin,minval(kl%rbody(1:n)))
          xmax=max(xmax,maxval(kl%rbody(1:n)))
        else
          do i=1,n
            ki=kl%dbody(i)
            if(ktfrealq(ki))then
              xmin=min(xmin,kl%rbody(i))
              xmax=max(xmax,kl%rbody(i))
            elseif(ktflistq(ki,kli))then
              if(tfcomplexq(ki,klic))then
                cpx=.true.
                xmin=min(xmin,klic%re)
                xmax=max(xmax,klic%re)
                ymin=min(ymin,klic%im)
                ymax=max(ymax,klic%im)
              elseif(kli%head%k .eq. ktfoper+mtflist)then
                call tfminandmaxl(ksad_loc(kli%head%k),
     $               xmin,xmax,ymin,ymax,cpx,irtc)
                if(irtc .ne. 0)then
                  return
                endif
              else
                go to 9000
              endif
            else
              go to 9000
            endif
          enddo
        endif
      endif
      irtc=0
      return
 9000 irtc=-1
      return
      end

      subroutine tfrestrict(isp1,kx,irtc)
      use tfstk
      implicit none
      type (sad_descriptor) kx,tfrestrictl
      integer*4 isp1,irtc,itfmessage
      if(isp .ne. isp1+3)then
        irtc=itfmessage(9,'General::narg','"3"')
      elseif(ktfnonrealq(ktastk(isp-1)) .or.
     $       ktfnonrealq(ktastk(isp)))then
        irtc=-1
c        irtc=itfmessage(9,'General::wrongtype','"x, min, max"')
      else
        kx=tfrestrictl(dtastk(isp1+1),
     $       rtastk(isp-1),rtastk(isp),irtc)
      endif
      return
      end

      recursive function tfrestrictl(k,x1,x2,irtc)
     $     result(kx)
      use tfstk
      implicit none
      type (sad_descriptor) k,kx
      type (sad_dlist), pointer :: kl,klx
      type (sad_rlist), pointer :: klr
      integer*4 irtc,i,isp0,n
      real*8 x1,x2,v
      irtc=0
      if(ktfrealq(k,v))then
        kx=dfromr(min(x2,max(x1,v)))
      elseif(tflistq(k,kl))then
        n=kl%nl
        if(n .eq. 0)then
          kx=k
          return
        endif
        if(ktfreallistq(kl))then
          kx=kxavaloc(-1,n,klr)
          call descr_sad(kx,klx)
          klr%attr=ior(klr%attr,lconstlist)
          klr%rbody(1:n)=min(x2,max(x1,kl%rbody(1:n)))
c          do i=1,n
c            rlist(kax+i)=min(x2,max(x1,rlist(ka+i)))
c          enddo
        else
          isp0=isp
          do i=1,n
            isp=isp+1
            dtastk(isp)=tfrestrictl(kl%dbody(i),x1,x2,irtc)
            if(irtc .ne. 0)then
              return
            endif
          enddo
          kx=kxmakelist(isp0)
          isp=isp0
        endif
      else
        kx%k=ktfoper+mtfnull
        irtc=-1
c        irtc=itfmessage(9,'General::wrongtype',
c     $       '"Real or List of Reals"')
      endif
      return
      end

      integer*4 function itfsyserr(level)
      implicit none
      character*132 string
      integer*4 level,itfmessagestr,i,l
      call gerror(string)
      do i=1,132
        if(string(i:i) .eq. char(0))then
          string(i:i)=' '
          l=i-1
          go to 10
        endif
      enddo
      l=len_trim(string)
 10   itfsyserr=itfmessagestr(level,'System::error',string(1:l))
      return
      end

      recursive function tfeintf(fun,cfun,k,cmpl,rmin,rmax,ir)
     $     result(kx)
      use tfstk
      use cfunc
c      use tmacro
      implicit none
      type (sad_descriptor) k,kx
      type (sad_dlist), pointer ::klx,kl
      type (sad_rlist), pointer ::klr
      integer*4 ir,i,m,isp0
      real*8 fun,rmin,rmax
      complex*16 cfun,cv
      real*8 v
      logical*4 cmpl
      external fun,cfun
      ir=0
      kx%k=ktfoper+mtfnull
      if(ktfrealq(k,v))then
        if(v .lt. rmin .or. v .gt. rmax)then
          cv=cfun(dcmplx(v,0.d0))
          kx=kxcalocc(-1,cv)
        else
          kx=dfromr(fun(v))
        endif
      elseif(tfnumberq(k,cv))then
        if(cmpl)then
          cv=cfun(cv)
          kx=kxcalocc(-1,cv)
          return
        else
          icrtc=0
          kx=dfromr(dble(cfun(cv)))
          ir=icrtc
        endif
      elseif(ktflistq(k,kl))then
        if(kl%head%k .eq. ktfoper+mtflist)then
          m=kl%nl
          if(ktfreallistq(kl))then
            isp0=isp
            if(rmin .ne. -dinfinity .or. rmax .ne. dinfinity)then
              do i=1,m
                isp=isp+1
                if(kl%rbody(i) .lt. rmin .or. kl%rbody(i) .gt. rmax)then
                  cv=cfun(dcmplx(kl%rbody(i),0.d0))
                  dtastk(isp)=kxcalocc(-1,cv)
                else
                  rtastk(isp)=fun(kl%rbody(i))
                endif
              enddo
              kx=kxmakelist(isp0)
              isp=isp0
            else
              kx=kxavaloc(-1,m,klr)
              call descr_sad(kx,klx)
              klr%attr=ior(klr%attr,lconstlist)
              do i=1,m
                klr%rbody(i)=fun(kl%rbody(i))
              enddo
            endif
          else
            isp0=isp
            do i=1,m
              isp=isp+1
              if(ktfrealq(kl%dbody(i)))then
                if(kl%rbody(i) .lt. rmin .or. kl%rbody(i) .gt. rmax)then
                  cv=cfun(dcmplx(kl%rbody(i),0.d0))
                  dtastk(isp)=kxcalocc(-1,cv)
                else
                  rtastk(isp)=fun(kl%rbody(i))
                endif
              elseif(tfnumberq(kl%dbody(i),cv))then
                if(cmpl)then
                  cv=cfun(cv)
                  dtastk(isp)=kxcalocc(-1,cv)
                else
                  rtastk(isp)=dble(cfun(cv))
                endif
              elseif(tflistq(kl%dbody(i)))then
                dtastk(isp)=tfeintf(fun,cfun,kl%dbody(i),
     $               cmpl,rmin,rmax,ir)
                if(ir .ne. 0.d0)then
                  isp=isp0
                  return
                endif
              else
                isp=isp0
                ir=-1
                return
              endif
            enddo
            kx=kxmakelist(isp0)
            isp=isp0
          endif
        else
          ir=-1
        endif
      else
        ir=-1
      endif
      return
      end

      recursive function tfeintf2(fun,cfun,k,k1,cmpl,ir)
     $     result(kx)
      use tfstk
      use cfunc
c      use tmacro
      implicit none
      type (sad_descriptor) kx,ki,k1i
      type (sad_descriptor),intent(in):: k,k1
      type (sad_dlist), pointer ::klx,kl,kl1
      type (sad_rlist), pointer ::klr
      integer*4 ,intent(out):: ir
      integer*4 i,m,m1,isp0
      logical*4 ,intent(in):: cmpl
      external fun,cfun
      real*8 fun,v,v1
      complex*16 cv,cv1,cfun
      kx%k=ktfoper+mtfnull
      ir=0
      if(ktfrealq(k,v) .and. ktfrealq(k1,v1))then
        kx=dfromr(fun(v,v1))
      elseif(tfnumberq(k,cv) .and. tfnumberq(k1,cv1))then
        if(cmpl)then
          cv=cfun(cv,cv1)
          kx=kxcalocc(-1,cv)
          return
        else
          icrtc=0
          kx=dfromr(dble(cfun(cv,cv1)))
          ir=icrtc
        endif
      elseif(tflistq(k,kl) .and. tflistq(k1,kl1))then
        m=kl%nl
        m1=kl1%nl
        if(m .ne. m1)then
          ir=8
          return
        endif
        if(iand(kl%attr,lnonreallist) .eq. 0 .and.
     $       iand(kl1%attr,lnonreallist) .eq. 0)then
          kx=kxavaloc(-1,m,klr)
          call descr_sad(kx,klx)
          klr%attr=ior(klr%attr,lconstlist)
          do i=1,m
            klr%rbody(i)=fun(kl%rbody(i),kl1%rbody(i))
          enddo
        else
          isp0=isp
          do i=1,m
            ki=kl%dbody(i)
            k1i=kl1%dbody(i)
            if(ktfrealq(ki) .and.
     $           ktfrealq(k1i))then
              rtastk(isp)=fun(kl%rbody(i),kl1%rbody(i))
            elseif(tflistq(ki) .and. tflistq(k1i))then
              dtastk(isp)=tfeintf2(fun,cfun,ki,k1i,cmpl,ir)
              if(ir .ne. 0.d0)then
                return
              endif
            else
              ir=-1
              return
            endif
          enddo
          kx=kxmakelist(isp0)
          isp=isp0
        endif
      else
        ir=-1
      endif
      return
      end

      recursive subroutine tfrgbcolor(isp1,kx,irtc)
      use tfstk
      implicit none
      type (sad_descriptor) kx,kxi
      type (sad_rlist), pointer ::kl
      integer*8 ka
      integer*4 isp1,irtc,ir,ig,ib,isp2,isp0,itfmessage,i,n
      character*2 ,parameter :: r256(0:255)=[
     $     '00','01','02','03','04','05','06','07',
     $     '08','09','0A','0B','0C','0D','0E','0F',
     $     '10','11','12','13','14','15','16','17',
     $     '18','19','1A','1B','1C','1D','1E','1F',
     $     '20','21','22','23','24','25','26','27',
     $     '28','29','2A','2B','2C','2D','2E','2F',
     $     '30','31','32','33','34','35','36','37',
     $     '38','39','3A','3B','3C','3D','3E','3F',
     $     '40','41','42','43','44','45','46','47',
     $     '48','49','4A','4B','4C','4D','4E','4F',
     $     '50','51','52','53','54','55','56','57',
     $     '58','59','5A','5B','5C','5D','5E','5F',
     $     '60','61','62','63','64','65','66','67',
     $     '68','69','6A','6B','6C','6D','6E','6F',
     $     '70','71','72','73','74','75','76','77',
     $     '78','79','7A','7B','7C','7D','7E','7F',
     $     '80','81','82','83','84','85','86','87',
     $     '88','89','8A','8B','8C','8D','8E','8F',
     $     '90','91','92','93','94','95','96','97',
     $     '98','99','9A','9B','9C','9D','9E','9F',
     $     'A0','A1','A2','A3','A4','A5','A6','A7',
     $     'A8','A9','AA','AB','AC','AD','AE','AF',
     $     'B0','B1','B2','B3','B4','B5','B6','B7',
     $     'B8','B9','BA','BB','BC','BD','BE','BF',
     $     'C0','C1','C2','C3','C4','C5','C6','C7',
     $     'C8','C9','CA','CB','CC','CD','CE','CF',
     $     'D0','D1','D2','D3','D4','D5','D6','D7',
     $     'D8','D9','DA','DB','DC','DD','DE','DF',
     $     'E0','E1','E2','E3','E4','E5','E6','E7',
     $     'E8','E9','EA','EB','EC','ED','EE','EF',
     $     'F0','F1','F2','F3','F4','F5','F6','F7',
     $     'F8','F9','FA','FB','FC','FD','FE','FF']
      if(isp .eq. isp1+1)then
        if(.not. tflistq(ktastk(isp)))then
          go to 9000
        endif
        ka=iand(ktamask,ktastk(isp))
        n=ilist(2,ka-1)
        if(iand(ilist(2,ka-3),lnonreallist) .eq. 0)then
          go to 9000
        endif
        isp0=isp
        do i=1,n
          if(.not. tfnumlistqn(dlist(ka+i),3,kl))then
            go to 9100
          endif
          isp2=isp
          call tfgetllstkall(kl)
          call tfrgbcolor(isp2,kxi,irtc)
          if(irtc .ne. 0)then
            isp=isp0
            return
          endif
          isp=isp2+1
          dtastk(isp)=kxi
        enddo
        kx=kxmakelist(isp0)
        isp=isp0
      elseif(isp .ne. isp1+3)then
        go to 9000
      else
        if(iand(ktrmask,ktastk(isp1+1)) .eq. ktfnr)then
          go to 9000
        endif
        if(iand(ktrmask,ktastk(isp1+2)) .eq. ktfnr)then
          go to 9000
        endif
        if(iand(ktrmask,ktastk(isp)) .eq. ktfnr)then
          go to 9000
        endif
        ir=min(255,max(0,nint(256.d0*rtastk(isp1+1))))
        ig=min(255,max(0,nint(256.d0*rtastk(isp1+2))))
        ib=min(255,max(0,nint(256.d0*rtastk(isp))))
        kx=kxsalocb(-1,'#'//r256(ir)//r256(ig)//r256(ib),7)
        irtc=0
      endif
      return
 9100 isp=isp0
 9000 irtc=itfmessage(9,'General::wrongtype',
     $     '"r,g,b or {{r1, g1, b1}, ...}"')
      return
      end


MODULE LDC3

! ==============================================================================
! =============================     LDC3 v1.0     ==============================
! ==============================================================================
!
! AUTHOR: David Kipping
!         Columbia University, Dept. of Astronomy
!         Please report any problems to: d.kipping@columbia.edu
!
! CITATION: If using this code, please cite:
!           Kipping, D. M., 2015, 'Efficient, uninformative sampling of limb
!           darkening coefficients for a three-parameter law', MNRAS, accepted
!
! DESCRIPTION: LDC3 is a module containing three subroutines: "forward",
!              "inverse" and "criteriatest". These subroutines perform tasks
!              related to identifying physically plausible limb darkening
!              coefficients (LDCs) in the case of the 3-parameter limb
!              darkening law proposed by Sing et al. (2009), A&A, 505, 891:
!              I(mu)/I(1) = 1 - c_2*[1-mu] - c_3*[1-mu^(3/2)] - c_4*[1-mu^2].
!              The expressions used in LDC3 were derived in Kipping (2015),
!              and we recommend the reader review this paper before continuing.
!              See each subroutine for a description of its purpose. Note that
!              alpha_t denotes alpha_theta throughout this code.
!
! HISTORY: v1.0 Initial version released

 implicit none

CONTAINS

!===============================================================================
SUBROUTINE forward(alpha_h,alpha_r,alpha_t,c_2,c_3,c_4)

! DESCRIPTION: forward takes a set of LDCs in the alpha-parameterization and
!              converts them to the c-parameterization. A likely common use
!              of this subroutine would be when fitting LDCs. One would treat
!              the alpha-parameters as the free parameters, but then convert
!              them to the more standard c-parameters before calling whatever
!              astronomical model describes one's observations.
!
! INPUTS: alpha_h, alpha_r, alpha_t, all of which are bound between 0 and 1 and
!         the latter is a wrap-around parameter.
!
! OUTPUTS: c_2, c_3, c_4

 implicit none

 REAL(8), INTENT(IN) :: alpha_h, alpha_r, alpha_t
 REAL(8), INTENT(OUT) :: c_2, c_3, c_4
 REAL(8), PARAMETER :: third = 0.3333333333333333D0
 REAL(8), PARAMETER :: twopi = 6.283185307179586D0
 REAL(8), PARAMETER :: P1 = 4.5008417723138905D0
 REAL(8), PARAMETER :: P2 = 17.14213562373095D0
 REAL(8), PARAMETER :: Q1 = 7.99682547780603D0
 REAL(8), PARAMETER :: Q2 = 8.566161603278331D0

 c_2 = (alpha_h**third)*( P1 + 0.25D0*DSQRT(alpha_r)*( &
       -6.0D0*DCOS(twopi*alpha_t) + P2*DSIN(twopi*alpha_t) ) )

 c_3 = (alpha_h**third)*( -Q1 - Q2*DSQRT(alpha_r)*DSIN(twopi*alpha_t) )

 c_4 = (alpha_h**third)*( P1 + 0.25D0*DSQRT(alpha_r)*( &
       6.0D0*DCOS(twopi*alpha_t) + P2*DSIN(twopi*alpha_t) ) )

END SUBROUTINE forward

!===============================================================================
SUBROUTINE inverse(c_2,c_3,c_4,alpha_h,alpha_r,alpha_t)

! DESCRIPTION: inverse performs the reverse transformation of subroutine
!              forward. It therefore converts c-parameters into
!              alpha-parameters.
!
! INPUTS: c_2, c_3, c_4 (= LDCs)
!
! OUTPUTS: alpha_h, alpha_r, alpha_t

 implicit none

 REAL(8), INTENT(IN) :: c_2, c_3, c_4
 REAL(8), INTENT(OUT) :: alpha_h, alpha_r, alpha_t
 REAL(8), PARAMETER :: third = 0.3333333333333333D0
 REAL(8), PARAMETER :: twopi = 6.283185307179586D0
 REAL(8), PARAMETER :: F1 = 0.9997221357486548D0
 REAL(8), PARAMETER :: F2 = 1.0002947195445628D0
 REAL(8), PARAMETER :: G1 = 51.396969619669996D0
 REAL(8), PARAMETER :: G2 = 51.426406871192850D0
 REAL(8), PARAMETER :: G3 = 0.5098605589396862D0
 REAL(8), PARAMETER :: G4 = 67.195959492893320D0
 REAL(8), PARAMETER :: G5 = 75.639610306789280D0
 REAL(8), PARAMETER :: H1 = 0.4666386075895370D0
 REAL(8), PARAMETER :: H2 = 0.5252750715749255D0

 alpha_h = ( F1*c_2 + F2*c_3 + F1*c_4 )**3

 alpha_r = G3/( G1*c_2 + G2*c_3 + G1*c_4 )**2
 alpha_r = alpha_r*( 576.0D0*(c_2 - c_4)**2 + ( G4*c_2 + G5*c_3 + G4*c_4 )**2 )

 alpha_t = DATAN2( -H1*c_2 - H2*c_3 - H1*c_4 , third*0.5D0*(c_4-c_2) )
 alpha_t = ( alpha_t - twopi*FLOOR( alpha_t/twopi ) )/twopi

END SUBROUTINE inverse
!===============================================================================

!===============================================================================
SUBROUTINE criteriatest(usemod,c_2,c_3,c_4,passed)

! DESCRIPTION: criteriatest tests whether a set of LDCs (with the
!              c-parameterization) satisfy the seven analytic criteria defined
!              in Kipping (2015). Passing this test indicates that LDCs
!              correspond to a physically allowed limb darkened intensity
!              profile, as defined in Kipping (2015). One may choose to use
!              modified or unmodified versions of the criteria with the usemod
!              logical control. The modified versions are slightly more
!              conservative, cropping ~5% of the allowed parameter volume, but
!              yielding a more symmetric volume.
!
! INPUTS: usemod (logical; true = use modified criteria; false = use unmodified
!                          criteria)
!         c_2, c_3, c_4 (= LDCs)
!
! OUTPUTS: passed (logical; true = test passed, false = test failed)

 implicit none

 LOGICAL, INTENT(IN) :: usemod
 REAL(8), INTENT(IN) :: c_2, c_3, c_4
 LOGICAL, INTENT(OUT) :: passed

 passed = .TRUE.

 ! Criteria A
 IF( c_2 + c_3 + c_4 .GT. 1.0D0 ) THEN
   passed = .FALSE.
 END IF

 ! Criteria B
 IF( 2.0D0*c_2 + 3.0D0*c_3 + 4.0D0*c_4 .LT. 0.0D0 ) THEN
   passed = .FALSE.
 END IF

 ! Criteria C
 IF( c_2 .LT. 0.0D0 ) THEN
   passed = .FALSE.
 END IF

 ! Criteria D
 IF( c_2 + c_3 + c_4 .LT. 0.0D0 ) THEN
   passed = .FALSE.
 END IF

 ! Criteria E
 IF( c_3 .GT. 0.0D0 ) THEN
   passed = .FALSE.
 END IF

 ! Criteria F
 IF( usemod ) THEN
   ! Modified Criterion F
   IF( c_4 .LT. 0.0D0 ) THEN
     passed = .FALSE.
   END IF
 ELSE
   ! Unmodified Criterion F
   IF( c_4 .LT. -1.0D0 ) THEN
     passed = .FALSE.
   END IF
 END IF

 ! Criteria G
 IF( usemod ) THEN
   ! Modified Criterion F
   IF( 32.0D0*c_2*c_4 .LT. 9.0D0*c_3*c_3 ) THEN
     passed = .FALSE.
   END IF
 ELSE
   ! Unmodified Criterion F
   IF( (0.375D0*c_3/c_4) .LE. 0.0D0 .AND. (0.375D0*c_3/c_4) .GE. -1.0D0 ) THEN
     IF( 32.0D0*c_2*c_4 .LT. 9.0D0*c_3*c_3 ) THEN
       passed = .FALSE.
     END IF
   END IF
 END IF

END SUBROUTINE criteriatest
!===============================================================================

END MODULE LDC3


      SUBROUTINE slUPCD ( DISCO, X, Y )
*+
*     - - - - - -
*      U P C D
*     - - - - - -
*
*  Remove pincushion/barrel distortion from a distorted [x,y] to give
*  tangent-plane [x,y].
*
*  Given:
*     DISCO    d      pincushion/barrel distortion coefficient
*     X,Y      d      distorted coordinates
*
*  Returned:
*     X,Y      d      tangent-plane coordinates
*
*  Notes:
*
*  1)  The distortion is of the form RP = R*(1+C*R^2), where R is
*      the radial distance from the tangent point, C is the DISCO
*      argument, and RP is the radial distance in the presence of
*      the distortion.
*
*  2)  For pincushion distortion, C is +ve;  for barrel distortion,
*      C is -ve.
*
*  3)  For X,Y in "radians" - units of one projection radius,
*      which in the case of a photograph is the focal length of
*      the camera - the following DISCO values apply:
*
*          Geometry          DISCO
*
*          astrograph         0.0
*          Schmidt           -0.3333
*          AAT PF doublet  +147.069
*          AAT PF triplet  +178.585
*          AAT f/8          +21.20
*          JKT f/8          +13.32
*
*  4)  The present routine is a rigorous inverse of the companion
*      routine slPCD.  The expression for RP in Note 1 is rewritten
*      in the form x^3+a*x+b=0 and solved by standard techniques.
*
*  5)  Cases where the cubic has multiple real roots can sometimes
*      occur, corresponding to extreme instances of barrel distortion
*      where up to three different undistorted [X,Y]s all produce the
*      same distorted [X,Y].  However, only one solution is returned,
*      the one that produces the smallest change in [X,Y].
*
*  P.T.Wallace   Starlink   3 September 2000
*
*  Copyright (C) 2000 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION DISCO,X,Y

      DOUBLE PRECISION THIRD
      PARAMETER (THIRD=1D0/3D0)
      DOUBLE PRECISION D2PI
      PARAMETER (D2PI=6.283185307179586476925286766559D0)

      DOUBLE PRECISION RP,Q,R,D,W,S,T,F,C,T3,F1,F2,F3,W1,W2,W3

*  Distance of the point from the origin.
      RP = SQRT(X*X+Y*Y)

*  If zero, or if no distortion, no action is necessary.
      IF (RP.NE.0D0.AND.DISCO.NE.0D0) THEN

*     Begin algebraic solution.
         Q = 1D0/(3D0*DISCO)
         R = RP/(2D0*DISCO)
         W = Q*Q*Q+R*R

*     Continue if one real root, or three of which only one is positive.
         IF (W.GE.0D0) THEN
            D = SQRT(W)
            W = R+D
            S = SIGN(ABS(W)**THIRD,W)
            W = R-D
            T = SIGN((ABS(W))**THIRD,W)
            F = S+T
         ELSE

*        Three different real roots:  use geometrical method instead.
            W = 2D0/SQRT(-3D0*DISCO)
            C = 4D0*RP/(DISCO*W*W*W)
            S = SQRT(1D0-MIN(C*C,1D0))
            T3 = ATAN2(S,C)

*        The three solutions.
            F1 = W*COS((D2PI-T3)/3D0)
            F2 = W*COS((T3)/3D0)
            F3 = W*COS((D2PI+T3)/3D0)

*        Pick the one that moves [X,Y] least.
            W1 = ABS(F1-RP)
            W2 = ABS(F2-RP)
            W3 = ABS(F3-RP)
            IF (W1.LT.W2) THEN
               IF (W1.LT.W3) THEN
                  F = F1
               ELSE
                  F = F3
               END IF
            ELSE
               IF (W2.LT.W3) THEN
                  F = F2
               ELSE
                  F = F3
               END IF
            END IF

         END IF

*     Remove the distortion.
         F = F/RP
         X = F*X
         Y = F*Y

      END IF

      END


      SUBROUTINE MB03KA( COMPQ, WHICHQ, WS, K, NC, KSCHUR, IFST, ILST,
     $                   N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, TOL, IWORK,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To reorder the diagonal blocks of the formal matrix product
C
C        T22_K^S(K) * T22_K-1^S(K-1) * ... * T22_1^S(1),             (1)
C
C     of length K, in the generalized periodic Schur form
C
C              [  T11_k  T12_k  T13_k  ]
C        T_k = [    0    T22_k  T23_k  ],    k = 1, ..., K,          (2)
C              [    0      0    T33_k  ]
C
C     where
C
C     - the submatrices T11_k are NI(k+1)-by-NI(k), if S(k) = 1, or
C       NI(k)-by-NI(k+1), if S(k) = -1, and contain dimension-induced
C       infinite eigenvalues,
C     - the submatrices T22_k are NC-by-NC and contain core eigenvalues,
C       which are generically neither zero nor infinite,
C     - the submatrices T33_k contain dimension-induced zero
C       eigenvalues,
C
C     such that the block with starting row index IFST in (1) is moved
C     to row index ILST. The indices refer to the T22_k submatrices.
C
C     Optionally, the transformation matrices Q_1,...,Q_K from the
C     reduction into generalized periodic Schur form are updated with
C     respect to the performed reordering.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPQ   CHARACTER*1
C             = 'N': do not compute any of the matrices Q_k;
C             = 'U': each coefficient of Q must contain an orthogonal
C                    matrix Q1_k on entry, and the products Q1_k*Q_k are
C                    returned, where Q_k, k = 1, ..., K, performed the
C                    reordering;
C             = 'W': the computation of each Q_k is specified
C                    individually in the array WHICHQ.
C
C     WHICHQ  INTEGER array, dimension (K)
C             If COMPQ = 'W', WHICHQ(k) specifies the computation of Q_k
C             as follows:
C             = 0:   do not compute Q_k;
C             > 0:   the kth coefficient of Q must contain an orthogonal
C                    matrix Q1_k on entry, and the product Q1_k*Q_k is
C                    returned.
C             This array is not referenced if COMPQ <> 'W'.
C
C     WS      LOGICAL
C             = .FALSE. : do not perform the strong stability tests;
C             = .TRUE.  : perform the strong stability tests; often,
C                         this is not needed, and omitting them can save
C                         some computations.
C
C     Input/Output Parameters
C
C     K       (input) INTEGER
C             The period of the periodic matrix sequences T and Q (the
C             number of factors in the matrix product).  K >= 2.
C             (For K = 1, a standard eigenvalue reordering problem is
C             obtained.)
C
C     NC      (input) INTEGER
C             The number of core eigenvalues.  0 <= NC <= min(N).
C
C     KSCHUR  (input) INTEGER
C             The index for which the matrix T22_kschur is upper quasi-
C             triangular. All other T22 matrices are upper triangular.
C
C     IFST    (input/output) INTEGER
C     ILST    (input/output) INTEGER
C             Specify the reordering of the diagonal blocks, as follows:
C             The block with starting row index IFST in (1) is moved to
C             row index ILST by a sequence of direct swaps between adjacent
C             blocks in the product.
C             On exit, if IFST pointed on entry to the second row of a
C             2-by-2 block in the product, it is changed to point to the
C             first row; ILST always points to the first row of the block
C             in its final position in the product (which may differ from
C             its input value by +1 or -1).
C             1 <= IFST <= NC, 1 <= ILST <= NC.
C
C     N       (input) INTEGER array, dimension (K)
C             The leading K elements of this array must contain the
C             dimensions of the factors of the formal matrix product T,
C             such that the k-th coefficient T_k is an N(k+1)-by-N(k)
C             matrix, if S(k) = 1, or an N(k)-by-N(k+1) matrix,
C             if S(k) = -1, k = 1, ..., K, where N(K+1) = N(1).
C
C     NI      (input) INTEGER array, dimension (K)
C             The leading K elements of this array must contain the
C             dimensions of the factors of the matrix sequence T11_k.
C             N(k) >= NI(k) + NC >= 0.
C
C     S       (input) INTEGER array, dimension (K)
C             The leading K elements of this array must contain the
C             signatures (exponents) of the factors in the K-periodic
C             matrix sequence. Each entry in S must be either 1 or -1;
C             the value S(k) = -1 corresponds to using the inverse of
C             the factor T_k.
C
C     T       (input/output) DOUBLE PRECISION array, dimension (*)
C             On entry, this array must contain at position IXT(k) the
C             matrix T_k, which is at least N(k+1)-by-N(k), if S(k) = 1,
C             or at least N(k)-by-N(k+1), if S(k) = -1, in periodic
C             Schur form.
C             On exit, the matrices T_k are overwritten by the reordered
C             periodic Schur form.
C
C     LDT     INTEGER array, dimension (K)
C             The leading dimensions of the matrices T_k in the one-
C             dimensional array T.
C             LDT(k) >= max(1,N(k+1)),  if S(k) =  1,
C             LDT(k) >= max(1,N(k)),    if S(k) = -1.
C
C     IXT     INTEGER array, dimension (K)
C             Start indices of the matrices T_k in the one-dimensional
C             array T.
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (*)
C             On entry, this array must contain at position IXQ(k) a
C             matrix Q_k of size at least N(k)-by-N(k), provided that
C             COMPQ = 'U', or COMPQ = 'W' and WHICHQ(k) > 0.
C             On exit, if COMPQ = 'U', or COMPQ = 'W' and WHICHQ(k) > 0,
C             Q_k is post-multiplied with the orthogonal matrix that
C             performed the reordering.
C             This array is not referenced if COMPQ = 'N'.
C
C     LDQ     INTEGER array, dimension (K)
C             The leading dimensions of the matrices Q_k in the one-
C             dimensional array Q.
C             LDQ(k) >= max(1,N(k)), if COMPQ = 'U', or COMPQ = 'W' and
C                                                       WHICHQ(k) > 0;
C             This array is not referenced if COMPQ = 'N'.
C
C     IXQ     INTEGER array, dimension (K)
C             Start indices of the matrices Q_k in the one-dimensional
C             array Q.
C             This array is not referenced if COMPQ = 'N'.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION array, dimension (3)
C             This array contains tolerance parameters. The weak and
C             strong stability tests use a threshold computed by the
C             formula  MAX( c*EPS*NRM, SMLNUM ),  where c is a constant,
C             NRM is the Frobenius norm of the current matrix formed by
C             concatenating K pairs of adjacent diagonal blocks of sizes
C             1 and/or 2 in the T22_k submatrices from (2), which are
C             swapped, and EPS and SMLNUM are the machine precision and
C             safe minimum divided by EPS, respectively (see LAPACK
C             Library routine DLAMCH). The norm NRM is computed by this
C             routine; the other values are stored in the array TOL.
C             TOL(1), TOL(2), and TOL(3) contain c, EPS, and SMLNUM,
C             respectively. TOL(1) should normally be at least 10.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (4*K)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= 10*K + MN, if all blocks between IFST and ILST
C                                  have order 1;
C             LDWORK >= 25*K + MN, if there is at least a block of
C                                  order 2, but no adjacent blocks of
C                                  order 2 can appear between IFST and
C                                  ILST during reordering;
C             LDWORK >= MAX(42*K + MN, 80*K - 48), if at least a pair of
C                                  adjacent blocks of order 2 can appear
C                                  between IFST and ILST during
C                                  reordering;
C             where MN = MXN, if MXN > 10, and MN = 0, otherwise, with
C             MXN = MAX(N(k),k=1,...,K).
C
C             If LDWORK = -1  a workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -21, the LDWORK argument was too small;
C             = 1:  the reordering of T failed because some eigenvalues
C                   are too close to separate (the problem is very ill-
C                   conditioned); T may have been partially reordered.
C                   The returned value of ILST is the index where this
C                   was detected.
C
C     METHOD
C
C     An adaptation of the LAPACK Library routine DTGEXC is used.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically backward stable.
C
C     CONTRIBUTOR
C
C     R. Granat, Umea University, Sweden, Apr. 2008.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Mar. 2010, SLICOT Library version of the PEP routine PEP_DTGEXC.
C     V. Sima, July 2010.
C
C     KEYWORDS
C
C     Orthogonal transformation, periodic QZ algorithm, periodic
C     Sylvester-like equations, QZ algorithm.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          COMPQ
      LOGICAL            WS
      INTEGER            IFST, ILST, INFO, K, KSCHUR, LDWORK, NC
C     ..
C     .. Array Arguments ..
      INTEGER            IWORK( * ), IXQ( * ), IXT( * ), LDQ( * ),
     $                   LDT( * ), N( * ), NI( * ), S( * ), WHICHQ( * )
      DOUBLE PRECISION   DWORK( * ), Q( * ), T( * ), TOL( * )
C     ..
C     .. Local Scalars ..
      INTEGER            HERE, I, IP1, IT, MINWRK, NBF, NBL, NBNEXT
C     ..
C     .. External Subroutines ..
      EXTERNAL           MB03KB, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, MAX, MOD
C     ..
C     .. Executable Statements ..
C
C     For efficiency reasons the parameters are not checked, except for
C     workspace.
C
      IF( NC.EQ.2 ) THEN
         NBF = 1
         NBL = 1
      ELSE IF( NC.EQ.3 ) THEN
         NBF = 1
         NBL = 2
      ELSE
         NBF = 2
         NBL = 2
      END IF
      CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, 1, NBF, NBL, N, NI,
     $             S, T, LDT, IXT, Q, LDQ, IXQ, TOL, IWORK, DWORK, -1,
     $             INFO )
      MINWRK = MAX( 1, INT( DWORK(1) ) )
      IF( LDWORK.NE.-1 .AND. LDWORK.LT.MINWRK )
     $   INFO = -21
C
C     Quick return if possible
C
      IF( LDWORK.EQ.-1 ) THEN
         DWORK(1) = DBLE( MINWRK )
         RETURN
      ELSE IF( INFO.LT.0 ) THEN
         CALL XERBLA( 'MB03KA', -INFO )
         RETURN
      END IF
C
C     Set I and IP1 to point to KSCHUR and KSCHUR+1 to simplify
C     indices below.
C
      I   = KSCHUR
      IP1 = MOD( I, K ) + 1
C
C     Determine the first row of the block in T22_kschur corresponding
C     to the first block in the product and find out if it is 1-by-1 or
C     2-by-2.
C
      IF( IFST.GT.1 ) THEN
         IF( S(I).EQ.1 ) THEN
            IT = IXT(I) + ( NI(I) + IFST - 2 )*LDT(I) + NI(IP1) + IFST
     $                  - 1
         ELSE
            IT = IXT(I) + ( NI(IP1) + IFST - 2 )*LDT(I) + NI(I) + IFST
     $                  - 1
         END IF
         IF( T( IT ).NE.ZERO )
     $      IFST = IFST - 1
      END IF
      NBF = 1
      IF( IFST.LT.NC ) THEN
         IF( S(I).EQ.1 ) THEN
            IT = IXT(I) + ( NI(I) + IFST - 1 )*LDT(I) + NI(IP1) + IFST
         ELSE
            IT = IXT(I) + ( NI(IP1) + IFST - 1 )*LDT(I) + NI(I) + IFST
         END IF
         IF( T( IT ).NE.ZERO )
     $      NBF = 2
      END IF
C
C     Determine the first row of the block in T_kschur corresponding
C     to the last block in the product and find out it is 1-by-1 or
C     2-by-2.
C
      IF( ILST.GT.1 ) THEN
         IF( S(I).EQ.1 ) THEN
            IT = IXT(I) + ( NI(I) + ILST - 2 )*LDT(I) + NI(IP1) + ILST
     $                  - 1
         ELSE
            IT = IXT(I) + ( NI(IP1) + ILST - 2 )*LDT(I) + NI(I) + ILST
     $                  - 1
         END IF
         IF( T( IT ).NE.ZERO )
     $      ILST = ILST - 1
      END IF
      NBL = 1
      IF( ILST.LT.NC ) THEN
         IF( S(I).EQ.1 ) THEN
            IT = IXT(I) + ( NI(I) + ILST - 1 )*LDT(I) + NI(IP1) + ILST
         ELSE
            IT = IXT(I) + ( NI(IP1) + ILST - 1 )*LDT(I) + NI(I) + ILST
         END IF
         IF( T( IT ).NE.ZERO )
     $      NBL = 2
      END IF
C
C     If the specified and last block in the product were the same,
C     return.
C
      IF( IFST.EQ.ILST )
     $   RETURN
C
C     If the specified block lies above the last block on the diagonal
C     of the product and the blocks have unequal sizes, update ILST.
C
      IF( IFST.LT.ILST ) THEN
C
C        Update ILST.
C
         IF( NBF.EQ.2 .AND. NBL.EQ.1 )
     $      ILST = ILST - 1
         IF( NBF.EQ.1 .AND. NBL.EQ.2 )
     $      ILST = ILST + 1
C
         HERE = IFST
C
   10    CONTINUE
C
C        Swap a block with next one below.
C
         IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
C
C           Current next block is either 1-by-1 or 2-by-2.
C
            NBNEXT = 1
            IF( HERE+NBF+1.LE.NC ) THEN
               IF( S(I).EQ.1 ) THEN
                  IT = IXT(I) + ( NI(I) + HERE + NBF - 1 )*LDT(I) +
     $                          NI(IP1) + HERE + NBF
               ELSE
                  IT = IXT(I) + ( NI(IP1) + HERE + NBF - 1 )*LDT(I) +
     $                              NI(I) + HERE + NBF
               END IF
               IF( T( IT ).NE.ZERO )
     $            NBNEXT = 2
            END IF
            CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE, NBF,
     $                   NBNEXT, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ,
     $                   TOL, IWORK, DWORK, LDWORK, INFO )
            IF( INFO.NE.0 ) THEN
               ILST = HERE
               RETURN
            END IF
            HERE = HERE + NBNEXT
C
C           Test if a 2-by-2 block breaks into two 1-by-1 blocks.
C
            IF( NBF.EQ.2 ) THEN
               IF( S(I).EQ.1 ) THEN
                  IT = IXT(I) + ( NI(I) + HERE - 1 )*LDT(I) + NI(IP1)
     $                        + HERE
               ELSE
                  IT = IXT(I) + ( NI(IP1) + HERE - 1 )*LDT(I) + NI(I)
     $                        + HERE
               END IF
               IF( T( IT ).EQ.ZERO )
     $            NBF = 3
            END IF
         ELSE
C
C           Current next block consists of two 1-by-1 blocks each of
C           which must be swapped individually.
C
            NBNEXT = 1
            IF( HERE+3.LE.NC ) THEN
               IF( S(I).EQ.1 ) THEN
                  IT = IXT(I) + ( NI(I) + HERE + 1 )*LDT(I) + NI(IP1) +
     $                                    HERE + 2
               ELSE
                  IT = IXT(I) + ( NI(IP1) + HERE + 1 )*LDT(I) + NI(I) +
     $                                      HERE + 2
               END IF
               IF( T( IT ).NE.ZERO )
     $            NBNEXT = 2
            END IF
            CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE+1, 1,
     $                   NBNEXT, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ,
     $                   TOL, IWORK, DWORK, LDWORK, INFO )
            IF( INFO.NE.0 ) THEN
               ILST = HERE
               RETURN
            END IF
            IF( NBNEXT.EQ.1 ) THEN
C
C              Swap two 1-by-1 blocks.
C
               CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE, 1,
     $                      NBNEXT, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ,
     $                      TOL, IWORK, DWORK, LDWORK, INFO )
               IF( INFO.NE.0 ) THEN
                  ILST = HERE
                  RETURN
               END IF
               HERE = HERE + 1
            ELSE
C
C              Recompute NBNEXT in case 2-by-2 split.
C
               IF( S(I).EQ.1 ) THEN
                  IT = IXT(I) + ( NI(I) + HERE )*LDT(I) + NI(IP1) + HERE
     $                        + 1
               ELSE
                  IT = IXT(I) + ( NI(IP1) + HERE )*LDT(I) + NI(I) + HERE
     $                                    + 1
               END IF
               IF( T( IT ).EQ.ZERO )
     $            NBNEXT = 1
               IF( NBNEXT.EQ.2 ) THEN
C
C                 The 2-by-2 block did not split.
C
                  CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE,
     $                         1, NBNEXT, N, NI, S, T, LDT, IXT, Q, LDQ,
     $                         IXQ, TOL, IWORK, DWORK, LDWORK, INFO )
                  IF( INFO.NE.0 ) THEN
                     ILST = HERE
                     RETURN
                  END IF
                  HERE = HERE + 2
               ELSE
C
C                 The 2-by-2 block did split.
C
                  CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE,
     $                         1, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ,
     $                         TOL, IWORK, DWORK, LDWORK, INFO )
                  IF( INFO.NE.0 ) THEN
                     ILST = HERE
                     RETURN
                  END IF
                  CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE+1,
     $                         1, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ,
     $                         TOL, IWORK, DWORK, LDWORK, INFO )
                  IF( INFO.NE.0 ) THEN
                     ILST = HERE + 1
                     RETURN
                  END IF
                  HERE = HERE + 2
               END IF
            END IF
         END IF
         IF( HERE.LT.ILST )
     $      GO TO 10
C
      ELSE
C
         HERE = IFST
   20    CONTINUE
C
C        Swap a block with next one above.
C
         IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
C
C           Current block is either 1-by-1 or 2-by-2.
C
            NBNEXT = 1
            IF( HERE.GE.3 ) THEN
               IF( S(I).EQ.1 ) THEN
                  IT = IXT(I) + ( NI(I) + HERE - 3 )*LDT(I) + NI(IP1)
     $                                  + HERE - 2
               ELSE
                  IT = IXT(I) + ( NI(IP1) + HERE - 3 )*LDT(I) + NI(I)
     $                                    + HERE - 2
               END IF
               IF( T( IT ).NE.ZERO )
     $            NBNEXT = 2
            END IF
            CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE-NBNEXT,
     $                   NBNEXT, NBF, N, NI, S, T, LDT, IXT, Q, LDQ,
     $                   IXQ, TOL, IWORK, DWORK, LDWORK, INFO )
            IF( INFO.NE.0 ) THEN
               ILST = HERE
               RETURN
            END IF
            HERE = HERE - NBNEXT
C
C           Test if a 2-by-2 block breaks into two 1-by-1 blocks.
C
            IF( NBF.EQ.2 ) THEN
               IF( S(I).EQ.1 ) THEN
                  IT = IXT(I) + ( NI(I) + HERE - 1 )*LDT(I) + NI(IP1)
     $                                  + HERE
               ELSE
                  IT = IXT(I) + ( NI(IP1) + HERE - 1 )*LDT(I) + NI(I)
     $                                    + HERE
               END IF
               IF( T( IT ).EQ.ZERO )
     $            NBF = 3
            END IF
C
         ELSE
C
C           Current block consists of two 1-by-1 blocks each of which
C           must be swapped individually.
C
            NBNEXT = 1
            IF( HERE.GE.3 ) THEN
               IF( S(I).EQ.1 ) THEN
                  IT = IXT(I) + ( NI(I) + HERE - 3 )*LDT(I) + NI(IP1)
     $                                  + HERE - 2
               ELSE
                  IT = IXT(I) + ( NI(IP1) + HERE - 3 )*LDT(I) + NI(I)
     $                                    + HERE - 2
               END IF
               IF( T( IT ).NE.ZERO )
     $            NBNEXT = 2
            END IF
            CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE-NBNEXT,
     $                   NBNEXT, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ,
     $                   TOL, IWORK, DWORK, LDWORK, INFO )
            IF( INFO.NE.0 ) THEN
               ILST = HERE
               RETURN
            END IF
            IF( NBNEXT.EQ.1 ) THEN
C
C              Swap two 1-by-1 blocks.
C
               CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE,
     $                      NBNEXT, 1, N, NI, S, T, LDT, IXT, Q, LDQ,
     $                      IXQ, TOL, IWORK, DWORK, LDWORK, INFO )
               IF( INFO.NE.0 ) THEN
                  ILST = HERE
                  RETURN
               END IF
               HERE = HERE - 1
            ELSE
C
C              Recompute NBNEXT in case 2-by-2 split.
C
               IF( S(I).EQ.1 ) THEN
                  IT = IXT(I) + ( NI(I) + HERE - 2 )*LDT(I) + NI(IP1)
     $                                  + HERE - 1
               ELSE
                  IT = IXT(I) + ( NI(IP1) + HERE - 2 )*LDT(I) + NI(I)
     $                                    + HERE - 1
               END IF
               IF( T( IT ).EQ.ZERO )
     $            NBNEXT = 1
               IF( NBNEXT.EQ.2 ) THEN
C
C                 The 2-by-2 block did not split.
C
                  CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE-1,
     $                         2, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ,
     $                         TOL, IWORK, DWORK, LDWORK, INFO )
                  IF( INFO.NE.0 ) THEN
                     ILST = HERE
                     RETURN
                  END IF
                  HERE = HERE - 2
               ELSE

C                 The 2-by-2 block did split.
C
                  CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE,
     $                         1, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ,
     $                         TOL, IWORK, DWORK, LDWORK, INFO )
                  IF( INFO.NE.0 ) THEN
                     ILST = HERE
                     RETURN
                  END IF
                  CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE-1,
     $                         1, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ,
     $                         TOL, IWORK, DWORK, LDWORK, INFO )
                  IF( INFO.NE.0 ) THEN
                     ILST = HERE - 1
                     RETURN
                  END IF
                  HERE = HERE - 2
               END IF
            END IF
         END IF
         IF( HERE.GT.ILST )
     $      GO TO 20
      END IF
      ILST = HERE
C
C     Store optimal workspace values and return.
C
      DWORK(1) = DBLE( MINWRK )
      RETURN
C
C *** Last line of MB03KA ***
      END


      SUBROUTINE rzextr(iest,xest,yest,yz,dy,nv)
      INTEGER iest,nv,IMAX,NMAX
      REAL xest,dy(nv),yest(nv),yz(nv)
      PARAMETER (IMAX=13,NMAX=50)
      INTEGER j,k
      REAL b,b1,c,ddy,v,yy,d(NMAX,IMAX),fx(IMAX),x(IMAX)
      SAVE d,x
      x(iest)=xest
      if(iest.eq.1) then
        do 11 j=1,nv
          yz(j)=yest(j)
          d(j,1)=yest(j)
          dy(j)=yest(j)
11      continue
      else
        do 12 k=1,iest-1
          fx(k+1)=x(iest-k)/xest
12      continue
        do 14 j=1,nv
          yy=yest(j)
          v=d(j,1)
          c=yy
          d(j,1)=yy
          do 13 k=2,iest
            b1=fx(k)*v
            b=b1-c
            if(b.ne.0.) then
              b=(c-v)/b
              ddy=c*b
              c=b1*b
            else
              ddy=v
            endif
            if (k.ne.iest) v=d(j,k)
            d(j,k)=ddy
            yy=yy+ddy
13        continue
          dy(j)=ddy
          yz(j)=yy
14      continue
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/rzextr.for


      DOUBLE PRECISION FUNCTION slEQEX (DATE)
*+
*     - - - - - -
*      E Q E X
*     - - - - - -
*
*  Equation of the equinoxes  (IAU 1994, double precision)
*
*  Given:
*     DATE    dp      TDB (loosely ET) as Modified Julian Date
*                                          (JD-2400000.5)
*
*  The result is the equation of the equinoxes (double precision)
*  in radians:
*
*     Greenwich apparent ST = GMST + slEQEX
*
*  References:  IAU Resolution C7, Recommendation 3 (1994)
*               Capitaine, N. & Gontier, A.-M., Astron. Astrophys.,
*               275, 645-650 (1993)
*
*  Called:  slNUTC
*
*  Patrick Wallace   Starlink   23 August 1996, amended 22 May 2021
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*-

      IMPLICIT NONE

      DOUBLE PRECISION DATE

*  Turns to arc seconds and arc seconds to radians
      DOUBLE PRECISION T2AS,AS2R
      PARAMETER (T2AS=1296000D0,
     :           AS2R=0.484813681109535994D-5)

      DOUBLE PRECISION T,OM,DPSI,DEPS,EPS0

*  Interval between basic epoch J2000.0 and current epoch (JC)
      T=(DATE-51544.5D0)/36525D0

*  Longitude of the mean ascending node of the lunar orbit on the
*   ecliptic, measured from the mean equinox of date
      OM=AS2R*(450160.280D0+(-5D0*T2AS-482890.539D0
     :         +(7.455D0+0.008D0*T)*T)*T)

*  Nutation
      CALL slNUTC80(DATE,DPSI,DEPS,EPS0)

*  Equation of the equinoxes
      slEQEX=DPSI*COS(EPS0)+AS2R*(0.00264D0*SIN(OM)+
     :                               0.000063D0*SIN(OM+OM))

      END


      SUBROUTINE GEOP (JJ)
C--
C--   SUBROUTINE GEOP (JJ)
C--
C--   Purpose : compute spectral geopotential from spectral temperature T
C--             and spectral topography PHIS, as in GFDL Climate Group GCM
C--   Input :   JJ = time level index (1 or 2)
C--   Modified common blocks : DYNSP2
C--
      include "atparam.h"
      include "atparam1.h"

      include "com_dyncon1.h"
      include "com_dynvar.h"

C--   1. Bottom layer (integration over half a layer)

      DO M=1,MX
       DO N=1,NX
         PHI(M,N,KX)=PHIS(M,N)+XGEOP1(KX)*T(M,N,KX,JJ)
       ENDDO
      ENDDO

C--   2. Other layers (integration two half-layers)

      DO K=KX-1,1,-1
        DO M=1,MX
         DO N=1,NX
           PHI(M,N,K)=PHI(M,N,K+1)+XGEOP2(K+1)*T(M,N,K+1,JJ)
     &                           +XGEOP1(K)  *T(M,N,K,  JJ)
         ENDDO
        ENDDO
      ENDDO

C     3. lapse-rate correction in the free troposphere

      DO K=2,KX-1
        CORF=XGEOP1(K)*0.5*LOG(HSG(K+1)/FSG(K))/LOG(FSG(K+1)/FSG(K-1))
        DO N=1,NX
          PHI(1,N,K)=PHI(1,N,K)+CORF*(T(1,N,K+1,JJ)-T(1,N,K-1,JJ))
        ENDDO
      ENDDO

C--
      RETURN
      END


!> Implements the Lennard-Jones 12-6 potential and the force derived from it.
module m_lj
  use num_kind
  use json_module
  use m_json_wrapper, only: get_parameter
  implicit none

  type :: lj_potential
     !> The range parameter which gives the zero-crossing distance of the
     !! potential.
     real(dp) :: sigma_0 = 1.

     !> The well-depth of the potential.
     real(dp) :: epsilon_0 = 1.
   contains
     procedure :: potential => lj1
     procedure :: force => lj_force
     procedure :: to_json => lj_to_json
  end type lj_potential

  interface lj_potential
     module procedure lj_init_parameters, lj_from_json
  end interface lj_potential

contains

  !> Initializes the LJ 12-6 potential with the well-depth @p epsilon_0
  !! and contact distance @p sigma_0.
  function lj_init_parameters(epsilon_0, sigma_0) result(this)
    real(dp), intent(in) :: epsilon_0, sigma_0
    type(lj_potential) :: this
    this%epsilon_0 = epsilon_0
    this%sigma_0 = sigma_0
  end function lj_init_parameters

  !> Initialize the module using parameters given by @p reader.
  function lj_from_json(json_val) result(this)
    type(json_value), pointer, intent(in) :: json_val
    type(lj_potential) :: this
    call get_parameter(json_val, 'lj_sigma_0', this%sigma_0, error_lb=0._dp)
    call get_parameter(json_val, 'lj_epsilon_0', this%epsilon_0, error_lb=0._dp)
  end function lj_from_json

  !> Write the module parameters using the output unit and format defined
  !! by @p writer.
  subroutine lj_to_json(this, json_val)
    class(lj_potential), intent(in) :: this
    type(json_value), pointer, intent(inout) :: json_val
    call json_add(json_val, 'type', 'lj')
    call json_add(json_val, 'lj_sigma_0', this%sigma_0)
    call json_add(json_val, 'lj_epsilon_0', this%epsilon_0)
  end subroutine lj_to_json

  !> Returns the LJ 12-6 potential with the parameterization set with
  !! lj_init and a given internuclear vector @p rij.
  pure subroutine lj1(this, r, energy, overlap)
    class(lj_potential), intent(in) :: this
    real(dp), intent(in) :: r
    real(dp), intent(out) :: energy
    logical, intent(out), optional :: overlap
    energy = lj3(r, this%epsilon_0, this%sigma_0)
    if (present(overlap)) overlap = .false.
  end subroutine lj1

  !> Returns the LJ 12-6 potential value with given well-depth @p epsilon,
  !! range parameter @p sigma and the internuclear vector @p rij from
  !! particle i to particle j.
  pure function lj3(rij, epsilon, sigma)
    real(dp) :: lj3
    real(dp), intent(in) :: rij
    real(dp), intent(in) :: epsilon
    real(dp), intent(in) :: sigma
    lj3 = (sigma / rij)**6
    lj3 = lj3 * (lj3 - 1.)
    lj3 = 4. * epsilon * lj3
  end function lj3

  !> Returns the force exerted on the particle j by particle i when the
  !! interparticle vector from i to j is @p rij.
  pure function lj_force(this, rij)
    class(lj_potential), intent(in) :: this
    real(dp), intent(in) :: rij(3)
    real(dp) :: lj_force(3)
    real(dp) :: urij(3)
    real(dp) :: rijabs
    rijabs = sqrt(dot_product(rij, rij))
    urij = rij/rijabs
    lj_force = 24. * this%epsilon_0 * this%sigma_0**6 / rijabs**7 * &
         (2. * this%sigma_0**6 / rijabs**6 - 1.) * urij
  end function lj_force

end module m_lj


	real function iad(s)

	real s,a,b,c,d,e,f,alpha,beta

	data a,b,c,d,e,f/28.06,-53.63,32.28,-10.25,2.37,1.02/
	data alpha,beta/.31,1./

	if (s.gt.1..or.s.lt.0.) then
	  iad=0.
	else
	  iad=a*s+b
	  iad=iad*s+c
	  iad=iad*s+d
	  iad=iad*s+e
	  iad=iad*s+f
	  iad=s**alpha*(1.-s)**beta*exp(iad)
	endif
	return
	end


*DECK XNRMP
      SUBROUTINE XNRMP (NU, MU1, MU2, SARG, MODE, SPN, IPN, ISIG,
     1   IERROR)
C***BEGIN PROLOGUE  XNRMP
C***PURPOSE  Compute normalized Legendre polynomials.
C***LIBRARY   SLATEC
C***CATEGORY  C3A2, C9
C***TYPE      SINGLE PRECISION (XNRMP-S, DXNRMP-D)
C***KEYWORDS  LEGENDRE FUNCTIONS
C***AUTHOR  Lozier, Daniel W., (National Bureau of Standards)
C           Smith, John M., (NBS and George Mason University)
C***DESCRIPTION
C
C        SUBROUTINE TO CALCULATE NORMALIZED LEGENDRE POLYNOMIALS
C        (DXNRMP is double-precision version)
C        XNRMP calculates normalized Legendre polynomials of varying
C        order and fixed argument and degree. The order MU and degree
C        NU are non-negative integers and the argument is real. Because
C        the algorithm requires the use of numbers outside the normal
C        machine range, this subroutine employs a special arithmetic
C        called extended-range arithmetic. See J.M. Smith, F.W.J. Olver,
C        and D.W. Lozier, Extended-Range Arithmetic and Normalized
C        Legendre Polynomials, ACM Transactions on Mathematical Soft-
C        ware, 93-105, March 1981, for a complete description of the
C        algorithm and special arithmetic. Also see program comments
C        in XSET.
C
C        The normalized Legendre polynomials are multiples of the
C        associated Legendre polynomials of the first kind where the
C        normalizing coefficients are chosen so as to make the integral
C        from -1 to 1 of the square of each function equal to 1. See
C        E. Jahnke, F. Emde and F. Losch, Tables of Higher Functions,
C        McGraw-Hill, New York, 1960, p. 121.
C
C        The input values to XNRMP are NU, MU1, MU2, SARG, and MODE.
C        These must satisfy
C          1. NU .GE. 0 specifies the degree of the normalized Legendre
C             polynomial that is wanted.
C          2. MU1 .GE. 0 specifies the lowest-order normalized Legendre
C             polynomial that is wanted.
C          3. MU2 .GE. MU1 specifies the highest-order normalized Leg-
C             endre polynomial that is wanted.
C         4a. MODE = 1 and -1.0 .LE. SARG .LE. 1.0 specifies that
C             Normalized Legendre(NU, MU, SARG) is wanted for MU = MU1,
C             MU1 + 1, ..., MU2.
C         4b. MODE = 2 and -3.14159... .LT. SARG .LT. 3.14159... spec-
C             ifies that Normalized Legendre(NU, MU, COS(SARG)) is want-
C             ed for MU = MU1, MU1 + 1, ..., MU2.
C
C        The output of XNRMP consists of the two vectors SPN and IPN
C        and the error estimate ISIG. The computed values are stored as
C        extended-range numbers such that
C             (SPN(1),IPN(1))=NORMALIZED LEGENDRE(NU,MU1,X)
C             (SPN(2),IPN(2))=NORMALIZED LEGENDRE(NU,MU1+1,X)
C                .
C                .
C             (SPN(K),IPN(K))=NORMALIZED LEGENDRE(NU,MU2,X)
C        where K = MU2 - MU1 + 1 and X = SARG or COS(SARG) according
C        to whether MODE = 1 or 2. Finally, ISIG is an estimate of the
C        number of decimal digits lost through rounding errors in the
C        computation. For example if SARG is accurate to 12 significant
C        decimals, then the computed function values are accurate to
C        12 - ISIG significant decimals (except in neighborhoods of
C        zeros).
C
C        The interpretation of (SPN(I),IPN(I)) is SPN(I)*(IR**IPN(I))
C        where IR is the internal radix of the computer arithmetic. When
C        IPN(I) = 0 the value of the normalized Legendre polynomial is
C        contained entirely in SPN(I) and subsequent single-precision
C        computations can be performed without further consideration of
C        extended-range arithmetic. However, if IPN(I) .NE. 0 the corre-
C        sponding value of the normalized Legendre polynomial cannot be
C        represented in single-precision because of overflow or under-
C        flow. THE USER MUST TEST IPN(I) IN HIS/HER PROGRAM. In the case
C        that IPN(I) is nonzero, the user should try using double pre-
C        cision if it has a wider exponent range. If double precision
C        fails, the user could rewrite his/her program to use extended-
C        range arithmetic.
C
C        The interpretation of (SPN(I),IPN(I)) can be changed to
C        SPN(I)*(10**IPN(I)) by calling the extended-range subroutine
C        XCON. This should be done before printing the computed values.
C        As an example of usage, the Fortran coding
C              J = K
C              DO 20 I = 1, K
C              CALL XCON(SPN(I), IPN(I),IERROR)
C              IF (IERROR.NE.0) RETURN
C              PRINT 10, SPN(I), IPN(I)
C           10 FORMAT(1X, E30.8 , I15)
C              IF ((IPN(I) .EQ. 0) .OR. (J .LT. K)) GO TO 20
C              J = I - 1
C           20 CONTINUE
C        will print all computed values and determine the largest J
C        such that IPN(1) = IPN(2) = ... = IPN(J) = 0. Because of the
C        change of representation caused by calling XCON, (SPN(I),
C        IPN(I)) for I = J+1, J+2, ... cannot be used in subsequent
C        extended-range computations.
C
C        IERROR is an error indicator. If no errors are detected,
C        IERROR=0 when control returns to the calling routine. If
C        an error is detected, IERROR is returned as nonzero. The
C        calling routine must check the value of IERROR.
C
C        If IERROR=112 or 113, invalid input was provided to XNRMP.
C        If IERROR=101,102,103, or 104, invalid input was provided
C        to XSET.
C        If IERROR=105 or 106, an internal consistency error occurred
C        in XSET (probably due to a software malfunction in the
C        library routine I1MACH).
C        If IERROR=107, an overflow or underflow of an extended-range
C        number was detected in XADJ.
C        If IERROR=108, an overflow or underflow of an extended-range
C        number was detected in XC210.
C
C***SEE ALSO  XSET
C***REFERENCES  Smith, Olver and Lozier, Extended-Range Arithmetic and
C                 Normalized Legendre Polynomials, ACM Trans on Math
C                 Softw, v 7, n 1, March 1981, pp 93--105.
C***ROUTINES CALLED  XADD, XADJ, XERMSG, XRED, XSET
C***REVISION HISTORY  (YYMMDD)
C   820712  DATE WRITTEN
C   881020  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Changed all specific intrinsics to generic.  (WRB)
C           Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C           CALLs to XERROR changed to CALLs to XERMSG.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  XNRMP
      INTEGER NU, MU1, MU2, MODE, IPN, ISIG
      REAL SARG, SPN
      DIMENSION SPN(*), IPN(*)
      REAL C1,C2,P,P1,P2,P3,S,SX,T,TX,X,RK
C CALL XSET TO INITIALIZE EXTENDED-RANGE ARITHMETIC (SEE XSET
C LISTING FOR DETAILS)
C***FIRST EXECUTABLE STATEMENT  XNRMP
      IERROR=0
      CALL XSET (0, 0, 0.0, 0,IERROR)
      IF (IERROR.NE.0) RETURN
C
C        TEST FOR PROPER INPUT VALUES.
C
      IF (NU.LT.0) GO TO 110
      IF (MU1.LT.0) GO TO 110
      IF (MU1.GT.MU2) GO TO 110
      IF (NU.EQ.0) GO TO 90
      IF (MODE.LT.1 .OR. MODE.GT.2) GO TO 110
      GO TO (10, 20), MODE
   10 IF (ABS(SARG).GT.1.0) GO TO 120
      IF (ABS(SARG).EQ.1.0) GO TO 90
      X = SARG
      SX = SQRT((1.0+ABS(X))*((0.5-ABS(X))+0.5))
      TX = X/SX
      ISIG = LOG10(2.0*NU*(5.0+TX**2))
      GO TO 30
   20 IF (ABS(SARG).GT.4.0*ATAN(1.0)) GO TO 120
      IF (SARG.EQ.0.0) GO TO 90
      X = COS(SARG)
      SX = ABS(SIN(SARG))
      TX = X/SX
      ISIG = LOG10(2.0*NU*(5.0+ABS(SARG*TX)))
C
C        BEGIN CALCULATION
C
   30 MU = MU2
      I = MU2 - MU1 + 1
C
C        IF MU.GT.NU, NORMALIZED LEGENDRE(NU,MU,X)=0.
C
   40 IF (MU.LE.NU) GO TO 50
      SPN(I) = 0.0
      IPN(I) = 0
      I = I - 1
      MU = MU - 1
      IF (I .GT. 0) GO TO 40
      ISIG = 0
      GO TO 160
   50 MU = NU
C
C        P1 = 0. = NORMALIZED LEGENDRE(NU,NU+1,X)
C
      P1 = 0.0
      IP1 = 0
C
C        CALCULATE P2 = NORMALIZED LEGENDRE(NU,NU,X)
C
      P2 = 1.0
      IP2 = 0
      P3 = 0.5
      RK = 2.0
      DO 60 J=1,NU
        P3 = ((RK+1.0)/RK)*P3
        P2 = P2*SX
        CALL XADJ(P2, IP2,IERROR)
        IF (IERROR.NE.0) RETURN
        RK = RK + 2.0
   60 CONTINUE
      P2 = P2*SQRT(P3)
      CALL XADJ(P2, IP2,IERROR)
      IF (IERROR.NE.0) RETURN
      S = 2.0*TX
      T = 1.0/NU
      IF (MU2.LT.NU) GO TO 70
      SPN(I) = P2
      IPN(I) = IP2
      I = I - 1
      IF (I .EQ. 0) GO TO 140
C
C        RECURRENCE PROCESS
C
   70 P = MU*T
      C1 = 1.0/SQRT((1.0-P+T)*(1.0+P))
      C2 = S*P*C1*P2
      C1 = -SQRT((1.0+P+T)*(1.0-P))*C1*P1
      CALL XADD(C2, IP2, C1, IP1, P, IP,IERROR)
      IF (IERROR.NE.0) RETURN
      MU = MU - 1
      IF (MU.GT.MU2) GO TO 80
C
C        STORE IN ARRAY SPN FOR RETURN TO CALLING ROUTINE.
C
      SPN(I) = P
      IPN(I) = IP
      I = I - 1
      IF (I .EQ. 0) GO TO 140
   80 P1 = P2
      IP1 = IP2
      P2 = P
      IP2 = IP
      IF (MU.LE.MU1) GO TO 140
      GO TO 70
C
C        SPECIAL CASE WHEN X=-1 OR +1, OR NU=0.
C
   90 K = MU2 - MU1 + 1
      DO 100 I=1,K
        SPN(I) = 0.0
        IPN(I) = 0
  100 CONTINUE
      ISIG = 0
      IF (MU1.GT.0) GO TO 160
      ISIG = 1
      SPN(1) = SQRT(NU+0.5)
      IPN(1) = 0
      IF (MOD(NU,2).EQ.0) GO TO 160
      IF (MODE.EQ.1 .AND. SARG.EQ.1.0) GO TO 160
      IF (MODE.EQ.2) GO TO 160
      SPN(1) = -SPN(1)
      GO TO 160
C
C          ERROR PRINTOUTS AND TERMINATION.
C
  110 CALL XERMSG ('SLATEC', 'XNRMP', 'NU, MU1, MU2 or MODE not valid',
     +             112, 1)
      IERROR=112
      RETURN
  120 CALL XERMSG ('SLATEC', 'XNRMP', 'SARG out of range', 113, 1)
      IERROR=113
      RETURN
C
C        RETURN TO CALLING PROGRAM
C
  140 K = MU2 - MU1 + 1
      DO 150 I=1,K
        CALL XRED(SPN(I),IPN(I),IERROR)
        IF (IERROR.NE.0) RETURN
  150 CONTINUE
  160 RETURN
      END


C/MEMBR ADD NAME=DSUM,SSI=0
c     Copyright INRIA
      double precision function dsum(n,dx,incx)
c
c!but
c
c     cette fonction donne la somme des n composantes d'un vecteur dx.
c
c!liste d'appel
c
c     double precision function dsum(n,dx,incx)
c
c     n: entier, taille du vecteur dx.
c
c     dx: double precision, vecteur dont on veut la somme
c
c     incx: increment entre deux composantes consecutives de dx.
c
c!auteur
c
c     serge Steer ,inria 86
c!
c
      double precision dx(*),dtemp
      integer i,incx,n,nincx
c
      dsum = 0.0d+0
      dtemp = 0.0d+0
      if(n.le.0)return
      if(incx.eq.1)go to 20
c
c code for increment not equal to 1
c
      nincx = n*incx
      do 10 i = 1,nincx,incx
        dtemp = dtemp + dx(i)
   10 continue
      dsum = dtemp
      return
c
c code for increment equal to 1
c
   20 continue
      do 30 i = 1,n
        dtemp = dtemp + dx(i)
   30 continue
      dsum = dtemp
c
      end


program test_max

  implicit none

  write (*, '(i0)') &
    & max (1, 2, 3)
  write (*, '(f3.1)') &
    & max (1.0, 2.0, 3.0)
  write (*, '(a)') &
    & max ('a', 'b', 'c')
  write (*, '(a)') &
    & max ('abc', 'bca', 'cab')
  write (*, '(i0, 2 (1x, i0))') &
    & max ([1, 8, 6], [7, 5, 3], [4, 2, 9])
  write (*, '(f3.1, 2 (1x, f3.1))') &
    & max ([1.0, 8.0, 6.0], [7.0, 5.0, 3.0], [4.0, 2.0, 9.0])
  write (*, '(a, 2 (1x, a))') &
    & max (['a', 'h', 'f'], ['g', 'e', 'c'], ['d', 'b', 'i'])
  write (*, '(a, 2 (1x, a))') &
    & max (['abc', 'hig', 'fde'], ['ghi', 'efd', 'cab'], ['def', 'bca', 'igh'])

end program test_max


module gauge_statistics_mod
    !
    use iso_c_binding
    implicit none

    integer, parameter:: dp = C_DOUBLE, ip = C_INT
    integer, parameter:: num_gauge_statistics = 5

    contains

    ! Compute multi-gauge summary statistics
    !
    subroutine gauge_statistics(gauge_times, flow_var, &
        stage_threshold_for_arrival_time, &
        ngauges, ntimes, nflow_var, output) BIND(C, name='gauge_statistics')

        real(dp), intent(in) :: gauge_times(ntimes), stage_threshold_for_arrival_time
        integer(ip), intent(in) :: ngauges, ntimes, nflow_var
        real(dp), intent(in) :: flow_var(ngauges, ntimes, nflow_var)
        real(dp), intent(inout) :: output(ngauges, num_gauge_statistics)

        integer(ip) :: i, j, k
        !real(dp) :: stage(ntimes) ! Small chance of stack overflow
        real(dp), allocatable :: stage(:), work(:)
        allocate(stage(ntimes), work(ntimes))

        do i = 1, ngauges
            ! It is assumed that flow_var(:,:,1) contains the stage time_series
            ! at every gauge
            stage = flow_var(i, :, 1)

            ! Maximum stage
            output(i,1) = maxval(stage)

            ! Zero-crossing period
            output(i,2) = zero_crossing_period(gauge_times, stage, work, ntimes)

            ! Peak to trough
            output(i,3) = output(i,1) - minval(stage)

            ! Arrival time
            output(i,4) = -1.0 ! 'Later R will treat this as missing value'
            do j = 1, ntimes
                if(abs(stage(j)) > stage_threshold_for_arrival_time) then
                    output(i,4) = gauge_times(j)
                    ! Break out of the loop
                    exit
                end if
            end do

            ! Initial stage
            output(i,5) = stage(1)

        end do
    end subroutine

    ! Compute the zero crossing period of vector 'x' measured at times 't'
    !
    ! Returns -1 if there are not enough crossings to compute this [we
    ! need at least 2 up crossings and 2 down crossings]
    !
    ! @param t times -- must be monotonic increasing
    ! @param x values at time t
    ! @param work a real work array (to avoid repeated allocation)
    ! @param ntimes length of t, x, and work
    ! @return average of up-crossing and down-crossing periods
    !
    function zero_crossing_period(t, x, work, ntimes) result(zcp)
        integer(ip), intent(in) :: ntimes
        real(dp), intent(in) :: t(ntimes), x(ntimes)
        real(dp), intent(inout) :: work(ntimes)
        real(dp) :: zcp

        integer(ip) :: i, nup, ndown
        real(dp) :: first_up_crossing, first_down_crossing
        real(dp) :: last_up_crossing, last_down_crossing
        logical :: found_first_up_crossing, found_first_down_crossing
        real(dp) :: s01, t_when_x_equals_zero

        ! Sign of x
        work(1) = 0.0_dp
        do i = 2, ntimes
            ! positive --> up crossing
            ! negative --> down crossing
            ! 0 --> no sign change
            !work(i) = sign(1.0_dp, x(i)) - sign(1.0_dp, x(i-1))
            if(x(i) > 0.0_dp .and. x(i-1) <= 0.0_dp) then
                work(i) = 1.0_dp
            else
                if(x(i) < 0.0_dp .and. x(i-1) >= 0.0_dp) then
                    work(i) = -1.0_dp
                else
                    work(i) = 0.0_dp
                end if
            end if
        end do

        found_first_up_crossing = .FALSE.
        found_first_down_crossing = .FALSE.
        nup = 0
        ndown = 0
        do i = 2, ntimes
            if(work(i) == 0.0_dp) cycle

            ! A number in [0-1] giving the position of the zero between
            ! t(i-1) and t(i)
            s01 = -x(i-1)/(x(i)-x(i-1))
            t_when_x_equals_zero = t(i-1) + s01 * (t(i)-t(i-1))

            if(work(i) > 0.0_dp) then
                ! Up crossing
                nup = nup + 1
                last_up_crossing = t_when_x_equals_zero
                if(.not. found_first_up_crossing) then
                    first_up_crossing = last_up_crossing
                    found_first_up_crossing = .TRUE.
                endif
            else
                ! down crossing
                ndown = ndown + 1
                last_down_crossing = t_when_x_equals_zero
                if(.not. found_first_down_crossing) then
                    first_down_crossing = last_down_crossing
                    found_first_down_crossing = .TRUE.
                endif
            end if

        end do

        !! DEBUG
        !print*, 'dc: ', ndown, last_down_crossing, first_down_crossing
        !print*, 'uc: ', nup, last_up_crossing, first_up_crossing

        if( (ndown < 2).or.(nup < 2) ) then
            zcp = -1.0_dp
        else
            zcp = 0.5_dp * ( &
                (last_down_crossing - first_down_crossing)/(ndown-1) + &
                (last_up_crossing - first_up_crossing)/(nup-1) )
        end if

    end function

end module


      SUBROUTINE qrupdt(r,qt,n,np,u,v)
      INTEGER n,np
      REAL r(np,np),qt(np,np),u(np),v(np)
CU    USES rotate
      INTEGER i,j,k
      do 11 k=n,1,-1
        if(u(k).ne.0.)goto 1
11    continue
      k=1
1     do 12 i=k-1,1,-1
        call rotate(r,qt,n,np,i,u(i),-u(i+1))
        if(u(i).eq.0.)then
          u(i)=abs(u(i+1))
        else if(abs(u(i)).gt.abs(u(i+1)))then
          u(i)=abs(u(i))*sqrt(1.+(u(i+1)/u(i))**2)
        else
          u(i)=abs(u(i+1))*sqrt(1.+(u(i)/u(i+1))**2)
        endif
12    continue
      do 13 j=1,n
        r(1,j)=r(1,j)+u(1)*v(j)
13    continue
      do 14 i=1,k-1
        call rotate(r,qt,n,np,i,r(i,i),-r(i+1,i))
14    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/qrupdt.for