cc Copyright (C) 2018: Travis Askham
cc Contact: askhamwhat@gmail.com
cc
cc This program is free software; you can redistribute it and/or modify
cc it under the terms of the BSD-3-Clause License

      subroutine obhgreenall(zk,zx,zy,ifpot,pot,ifgrad,grad,
     1     ifhess,hess,ifder3,der3,ifder4,der4,ifder5,der5)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Evaluates the Green function
c
c     G(x,y) = (i*H_0^(1)(zk*r)/4 + log(r)/(2*pi))/zk^2 ,
c
c     where H_0^(1) is the Hankel function of the first kind and
c     r = sqrt( (x_1-y_1)^2 + (x_2-y_2)^2),
c     and its derivatives stably (with the derivatives on the
c     "x" or "target" variable).
c
c     INPUTS
c
c     zk - complex *16 helmholtz parameter
c     zx(2) - real *8, coordinates of target
c     zy(2) - real *8, coordinates of source
c     ifpot - if equal to 1, compute potential
c     ifgrad - if equal to 1, compute gradient
c     ifhess - if equal to 1, compute hessian
c     ifder3 - if equal to 1, compute 3rd order derivatives
c     ifder4 - if equal to 1, compute 4th order derivatives
c     ifder5 - if equal to 1, compute 5th order derivatives
c
c     OUTPUTS
c
c     note: for derivatives, the ordering is such that,
c     for a given order, the first entry has all of the
c     derivatives on the x1 variables, the second entry
c     has one derivative on the x2 variable and the rest
c     on x1, and so on. e.g.
c
c     hess(1) = d_x1 d_x1 G(x,y)
c     hess(2) = d_x1 d_x2 G(x,y)
c     hess(3) = d_x2 d_x2 G(x,y)
c
c     pot - complex *16, potential, if requested
c     grad(2) - complex *16, gradient, if requested
c     hess(3) - complex *16, hessian, if requested
c     der3(4) - complex *16, 3rd order derivatives, if requested.
c     der4(5) - complex *16, 4th order derivatives, if requested.
c     der5(6) - complex *16, 5th order derivatives, if requested.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none
c     global variables
      complex *16 zk
      real *8 zx(2), zy(2)
      complex *16 pot, grad(2), hess(3)
      complex *16 der3(4), der4(5), der5(6)
      integer ifpot, ifgrad, ifhess, ifder3, ifder4, ifder5
c     local variables
      real *8 r, r2, r3, r4, r5, r6
      real *8 dx, dy, dx2, dx3, dx4, dx5, dy2, dy3, dy4, dy5
      integer ifders
      real *8 rscale
      integer nmax, ifder, j
      complex *16 z, eye, eyeo4, hvec(0:10), diffs(0:10), ders(0:10)
      complex *16 zkh, ztemp, zkr
      data eye /(0.0d0,1.0d0)/
      data eyeo4 /(0.0d0,0.25d0)/
      real *8 tiny
      data tiny / 1.0d-50 /

      dx = zx(1) - zy(1)
      dy = zx(2) - zy(2)

      dx2 = dx*dx
      dx3 = dx2*dx
      dx4 = dx3*dx
      dx5 = dx4*dx
      dy2 = dy*dy
      dy3 = dy2*dy
      dy4 = dy3*dy
      dy5 = dy4*dy

      r2 = dx2 + dy2

      if (r2 .lt. tiny) then
         if (ifpot .eq. 1) pot = 0.0d0
         if (ifgrad .eq. 1) then
            grad(1) =0.0d0
            grad(2) =0.0d0
         endif
         if (ifhess .eq. 1) then
            hess(1) =0.0d0
            hess(2) =0.0d0
            hess(3) =0.0d0
         endif
         if (ifder3 .eq. 1) then
            der3(1) =0.0d0
            der3(2) =0.0d0
            der3(3) =0.0d0
            der3(4) =0.0d0
         endif
         if (ifder4 .eq. 1) then
            der4(1) =0.0d0
            der4(2) =0.0d0
            der4(3) =0.0d0
            der4(4) =0.0d0
            der4(5) =0.0d0
         endif
         if (ifder5 .eq. 1) then
            der5(1) =0.0d0
            der5(2) =0.0d0
            der5(3) =0.0d0
            der5(4) =0.0d0
            der5(5) =0.0d0
            der5(6) =0.0d0
         endif
         return
      endif

      r = dsqrt(r2)
      r3 = r2*r
      r4 = r3*r
      r5 = r4*r

      nmax = 5

c     get values of difference functions up to nmax-th order

      rscale = 1.0d0
      ifders = 0
      call diffsloghank(r,zk,rscale,diffs,ifders,ders,hvec,nmax)

c     rescale

      zkr = zk*r

c     compute r derivatives using only like order terms to minimize
c     cancellation

      ztemp = eyeo4/(zk**2)
      ders(0) = diffs(0)*ztemp
      ztemp = -zk*ztemp
      ders(1) = diffs(1)*ztemp
      ztemp = -zk*ztemp
      ders(2) = ztemp*(diffs(2)-diffs(1)/zkr)
      ztemp = -zk*ztemp
      ders(3) = ztemp*(diffs(3)-3.0d0*diffs(2)/zkr)
      ztemp = -zk*ztemp
      ders(4) = ztemp*(diffs(4)-(5.25d0*diffs(3)
     1     -0.75d0*hvec(1))/zkr)
      ztemp = -zk*ztemp
      ders(5) = ztemp*(diffs(5)-(7.5d0*diffs(4)
     1     -2.5d0*hvec(2))/zkr)

c     evaluate potential and derivatives

      if (ifpot .eq. 1) then
         pot = ders(0)
      endif

      if (ifgrad .eq. 1) then
         grad(1) = dx*ders(1)/r
         grad(2) = dy*ders(1)/r
      endif

      if (ifhess .eq. 1) then
         hess(1) = dx2*ders(2)/r2+ders(1)*(1.0d0/r-dx2/r3)
         hess(2) = dx*dy*(ders(2)/r2-ders(1)/r3)
         hess(3) = dy2*ders(2)/r2+ders(1)*(1.0d0/r-dy2/r3)
      endif

      if (ifder3 .eq. 1) then
         der3(1) = (dx3*ders(3)+3.0d0*dy2*dx*(ders(2)/r-ders(1)/r2))/r3
         der3(2) = dx2*dy*(ders(3)/r3-3.0d0*(ders(2)/r4-ders(1)/r5)) +
     1        dy*(ders(2)/r2-ders(1)/r3)
         der3(3) = dx*dy2*(ders(3)/r3-3.0d0*(ders(2)/r4-ders(1)/r5)) +
     1        dx*(ders(2)/r2-ders(1)/r3)
         der3(4) = (dy3*ders(3)+3.0d0*dx2*dy*(ders(2)/r-ders(1)/r2))/r3
      endif

      if (ifder4 .eq. 1) then
         der4(1) = (dx4*(ders(4)-6.0d0*ders(3)/r+15.0d0*(ders(2)/r2
     1        -ders(1)/r3)))/r4 +
     1        (dx2*6.0d0*(ders(3)-3.0d0*(ders(2)/r-ders(1)/r2)))/r3 +
     2        (3.0d0*(ders(2)-ders(1)/r))/r2
         der4(2) = (dx3*dy*(ders(4)-6.0d0*ders(3)/r+15.0d0*(ders(2)/r2
     1        -ders(1)/r3)))/r4 +
     1        (3.0d0*dx*dy*(ders(3)-3.0d0*(ders(2)/r-ders(1)/r2)))/r3
         der4(3) = dx2*dy2*(ders(4)-6.0d0*ders(3)/r+15.0d0*ders(2)/r2
     1        -15.0d0*ders(1)/r3)/r4
     1        + ders(3)/r - 2.0d0*ders(2)/r2 + 2.0d0*ders(1)/r3
         der4(4) = dx*dy3*(ders(4)-6.0d0*ders(3)/r+15.0d0*(ders(2)/r2
     1        -ders(1)/r3))/r4 +
     1        3.0d0*dx*dy*(ders(3)-3.0d0*(ders(2)/r-ders(1)/r2))/r3
         der4(5) = dy4*(ders(4)-6.0d0*ders(3)/r+15.0d0*(ders(2)/r2
     1        -ders(1)/r3))/r4 +
     1        dy2*6.0d0*(ders(3)-3.0d0*(ders(2)/r-ders(1)/r2))/r3 +
     2        3.0d0*(ders(2)-ders(1)/r)/r2
      endif

      if (ifder5 .eq. 1) then
         der5(1) = (dx5*ders(5)+10.0d0*dy2*dx3*ders(4)/r +
     1        (15.0d0*dy4*dx-30.0d0*dy2*dx3)*ders(3)/r2 +
     2        (60.0d0*dy2*dx3-45.0d0*dy4*dx)*ders(2)/r3 +
     3        (45.0d0*dy4*dx-60.0d0*dy2*dx3)*ders(1)/r4)/r5
         der5(2) = (dy*dx4*ders(5)
     1        +(6.0d0*dy3*dx2-4.0d0*dy*dx4)*ders(4)/r +
     1        (3.0d0*dy5+12.0d0*dy*dx4-30.0d0*dy3*dx2)*ders(3)/r2 +
     2        (72.0d0*dy3*dx2-9.0d0*dy5-24.0d0*dy*dx4)*ders(2)/r3 +
     3        (9.0d0*dy5-72.0d0*dy3*dx2+24.0d0*dy*dx4)*ders(1)/r4)/r5
         der5(3) = (dy2*dx3*ders(5)
     1        +(3.0d0*dy4*dx-6.0d0*dy2*dx3+dx5)*ders(4)/r +
     1        (27.0d0*dy2*dx3-15.0d0*dy4*dx-3.0d0*dx5)*ders(3)/r2 +
     2        (36.0d0*dy4*dx-63.0d0*dy2*dx3+6.0d0*dx5)*ders(2)/r3 +
     3        (63.0d0*dy2*dx3-36.0d0*dy4*dx-6.0d0*dx5)*ders(1)/r4)/r5
         der5(4) = (dx2*dy3*ders(5)
     1        +(3.0d0*dx4*dy-6.0d0*dx2*dy3+dy5)*ders(4)/r +
     1        (27.0d0*dx2*dy3-15.0d0*dx4*dy-3.0d0*dy5)*ders(3)/r2 +
     2        (36.0d0*dx4*dy-63.0d0*dx2*dy3+6.0d0*dy5)*ders(2)/r3 +
     3        (63.0d0*dx2*dy3-36.0d0*dx4*dy-6.0d0*dy5)*ders(1)/r4)/r5
         der5(5) = (dx*dy4*ders(5)
     1        +(6.0d0*dx3*dy2-4.0d0*dx*dy4)*ders(4)/r +
     1        (3.0d0*dx5+12.0d0*dx*dy4-30.0d0*dx3*dy2)*ders(3)/r2 +
     2        (72.0d0*dx3*dy2-9.0d0*dx5-24.0d0*dx*dy4)*ders(2)/r3 +
     3        (9.0d0*dx5-72.0d0*dx3*dy2+24.0d0*dx*dy4)*ders(1)/r4)/r5
         der5(6) = (dy5*ders(5)+10.0d0*dx2*dy3*ders(4)/r +
     1        (15.0d0*dx4*dy-30.0d0*dx2*dy3)*ders(3)/r2 +
     2        (60.0d0*dx2*dy3-45.0d0*dx4*dy)*ders(2)/r3 +
     3        (45.0d0*dx4*dy-60.0d0*dx2*dy3)*ders(1)/r4)/r5
      endif

      return
      end

      subroutine obhgreen(zk,zx,zy,ifpot,pot,ifgrad,grad,
     1     ifhess,hess)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Evaluates the Green's function and its derivatives stably
c     (with the derivatives on the "x" or "target" variable).
c
c     INPUTS
c
c     zk - complex *16, helmholtz parameter
c     zx(2) - real *8, coordinates of target
c     zy(2) - real *8, coordinates of source
c     ifpot - if equal to 1, compute potential
c     ifgrad - if equal to 1, compute gradient
c     ifhess - if equal to 1, compute hessian
c
c     OUTPUTS
c
c     pot - complex *16, potential, if requested
c     grad(2) - complex *16, gradient, if requested
c     hess(3) - complex *16, hessian, if requested
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none
c     global variables
      real *8 zx(2), zy(2)
      complex *16 zk, pot, grad(2), hess(3)
      integer ifpot, ifgrad, ifhess
c     local variables
      complex *16 der3(4), der4(5), der5(6)
      integer ifder3, ifder4, ifder5

      ifder3 = 0
      ifder4 = 0
      ifder5 = 0

      call obhgreenall(zk,zx,zy,ifpot,pot,ifgrad,grad,
     1     ifhess,hess,ifder3,der3,ifder4,der4,ifder5,der5)

      return
      end

      subroutine obhgreend1(zk,zx,zy,ifpot,pot,ifgrad,grad,
     1     ifhess,hess,dir1)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Evaluates a directional derivative of the Green's function
c     at the source ("y" variable) and its derivatives stably (with
c     the derivatives on the "x" or "target" variable).
c
c     The potential is (nabla_y * dir1) G
c     The gradient is grad_x (nabla_y * dir1) G
c     The hessian is hess_x (nabla_y * dir1) G
c
c     INPUTS
c
c     zk - complex *16, modified helmholtz parameter
c     zx(2) - real *8, coordinates of target
c     zy(2) - real *8, coordinates of source
c     dir1(2) - real *8, vector determining direction of derivative
c     ifpot - if equal to 1, compute potential
c     ifgrad - if equal to 1, compute gradient
c     ifhess - if equal to 1, compute hessian
c
c     OUTPUTS
c
c     pot - complex *16, potential, if requested
c     grad(2) - complex *16, gradient, if requested
c     hess(3) - complex *16, hessian, if requested
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none
c     global variables
      complex *16 zk, pot, grad(2), hess(3)
      real *8 zx(2), zy(2), dir1(2)
      integer ifpot, ifgrad, ifhess
c     local variables
      complex *16 potloc, gradloc(2), hessloc(3), der3(4), der4(5)
      complex *16 der5(6)
      integer ifder3, ifder4, ifder5, ifpotloc, ifgradloc, ifhessloc

      ifpotloc = 0
      ifgradloc = 0
      ifhessloc = 0
      ifder3 = 0
      ifder4 = 0
      ifder5 = 0

      if (ifpot .eq. 1) ifgradloc = 1
      if (ifgrad .eq. 1) ifhessloc = 1
      if (ifhess .eq. 1) ifder3 = 1

      call obhgreenall(zk,zx,zy,ifpotloc,potloc,ifgradloc,gradloc,
     1     ifhessloc,hessloc,ifder3,der3,ifder4,der4,ifder5,der5)

      if (ifpot .eq. 1) then
         pot = -dir1(1)*gradloc(1)-dir1(2)*gradloc(2)
      endif

      if (ifgrad .eq. 1) then
         grad(1) = -dir1(1)*hessloc(1) - dir1(2)*hessloc(2)
         grad(2) = -dir1(1)*hessloc(2) - dir1(2)*hessloc(3)
      endif

      if (ifhess .eq. 1) then
         hess(1) = -dir1(1)*der3(1) - dir1(2)*der3(2)
         hess(2) = -dir1(1)*der3(2) - dir1(2)*der3(3)
         hess(3) = -dir1(1)*der3(3) - dir1(2)*der3(4)
      endif

      return
      end

      subroutine obhgreend2(zk,zx,zy,ifpot,pot,ifgrad,grad,
     1     ifhess,hess,dir1,dir2)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Evaluates double directional derivatives (on y) of the Green's
c     function and its derivatives stably (with the derivatives on the
c     "x" or "target" variable).
c
c     INPUTS
c
c     zk - complex *16, modified helmholtz parameter
c     zx(2) - real *8, coordinates of target
c     zy(2) - real *8, coordinates of source
c     dir1(2), dir2(2) - real *8, vectors determining directions of
c                        derivatives
c     ifpot - if equal to 1, compute potential
c     ifgrad - if equal to 1, compute gradient
c     ifhess - if equal to 1, compute hessian
c
c     OUTPUTS
c
c     pot - complex *16, potential, if requested
c     grad(2) - complex *16, gradient, if requested
c     hess(3) - complex *16, hessian, if requested
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none
c     global variables
      complex *16 zk, pot, grad(2), hess(3)
      real *8 zx(2), zy(2), dir1(2), dir2(2)
      integer ifpot, ifgrad, ifhess
c     local variables
      real *8 quadvec(3)
      integer if0, if1, if2, if3
      integer ifpot1,ifgrad1,ifhess1,ifder3,ifder4,ifder5
      complex *16 potloc,gradloc(2),hessloc(3),der3(4),der4(5),der5(6)

c     convert two directional derivatives to xx, xy, yy

      quadvec(1) = dir1(1)*dir2(1)
      quadvec(2) = dir1(1)*dir2(2) + dir1(2)*dir2(1)
      quadvec(3) = dir1(2)*dir2(2)

      ifpot1 = 0
      ifgrad1 = 0
      ifhess1 = 1
      ifder3 = 1
      ifder4 = 1
      ifder5 = 0

      call obhgreenall(zk,zx,zy,ifpot1,potloc,ifgrad1,gradloc,
     1     ifhess1,hessloc,ifder3,der3,ifder4,der4,ifder5,der5)

      if (ifpot .eq. 1) then
         pot = quadvec(1)*hessloc(1)+quadvec(2)*hessloc(2)
     1        +quadvec(3)*hessloc(3)
      endif

      if (ifgrad .eq. 1) then
         grad(1) = quadvec(1)*der3(1)+quadvec(2)*der3(2)
     1        +quadvec(3)*der3(3)
         grad(2) = quadvec(1)*der3(2)+quadvec(2)*der3(3)
     1        +quadvec(3)*der3(4)
      endif

      if (ifhess .eq. 1) then
         hess(1) = quadvec(1)*der4(1)+quadvec(2)*der4(2)
     1        +quadvec(3)*der4(3)
         hess(2) = quadvec(1)*der4(2)+quadvec(2)*der4(3)
     1        +quadvec(3)*der4(4)
         hess(3) = quadvec(1)*der4(3)+quadvec(2)*der4(4)
     1        +quadvec(3)*der4(5)
      endif

      return
      end

      subroutine diffsloghank(r,zk,rscale,diffs,ifders,ders,
     1     hvec,n)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     WARNING: DERS NOT IMPLEMENTED YET
c
c     This subroutine evaluates the difference kernel
c
c     diffs(0) = H_0(zk * r) - 2*i*log(r)/pi
c
c     diffs(n) = (H_n(zk*r)+2*i*2^(n-1)*(n-1)!/(pi*(zk*r)^n))*rscale^n
c
c     Where H_n is the type 1 Hankel function
c
c     For abs(zk*r/2) < 1.0, this routine performs the
c     cancellation between the two parts explicitly.
c     Otherwise, the formula is evaluated directly
c
c     input:
c     r - real *8, as above
c     zk - complex *16, as above
c     rscale - real *8, scaling factor, as above
c     ifders - integer, flag: determines whether or not to compute
c              derivatives
c     n - integer, order: compute the 0 through n values of diffs
c         and ders (if requested)
c
c     output:
c     diffs - complex *16 array, as above
c     ders - complex *16 array, derivative with respect to r
c     hvec - complex *16 array, can be viewed as workspace, length
c            n+1, returns Hankel Function values (without differencing)
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none
c     global variables
      complex *16 zk, diffs(0:n), ders(0:n), hvec(0:n)
      real *8 r, rscale
      integer n, ifders
c     local variables
      complex *16 eye
      integer ifder, p, j
      data eye / (0.0d0,1.0d0) /
      integer pmax
      parameter (pmax = 12)
      real *8 logcs0(0:pmax), logcs1(0:pmax), rscale2
      complex *16 cs0(0:pmax), cs1(0:pmax)
      complex *16 zkr, zkrh, zkrh2p, hder(0:1), z2iopi, ztemp, zlogtemp
      complex *16 ztemp0, ztemp1, ztempl0, ztempl1, zkrhsc, zkrh2, zkh
      complex *16 diffstop, diffs2
      data z2iopi / (0.0d0,0.636619772367581343075535053d0) /

c     H0-2*i*log(zk*r)/pi is sum of two power series (for small arg)

c     Note that we have to correct and add back 2*i*log(zk)/pi to get
c     true function...

c     coefficients of log(zk*r/2)*(zk*r/2)^(2*j)
c     (multiplied later by 2*i/pi)

      data logcs0 /   0.000000000000000000D+000,
     1     -0.100000000000000000D+001,
     2     0.250000000000000000D+000,
     3     -0.277777777777777778D-001,
     4     0.173611111111111111D-002,
     5     -0.694444444444444444D-004,
     6     0.192901234567901235D-005,
     7     -0.393675988914084152D-007,
     8     0.615118732678256488D-009,
     9     -0.759405842812662331D-011,
     $     0.759405842812662331D-013,
     1     -0.627608134555919281D-015,
     2     0.435838982330499501D-017 /

c     coefficients of (zk*r/2)^(2*j)

      data cs0 / (0.100000000000000000D+001,0.367466905196615962D+000),
     1     ( -0.100000000000000000D+001 ,   0.269152867170965382D+000),
     2     (  0.250000000000000000D+000 ,  -0.146865688338689013D+000),
     3     ( -0.277777777777777778D-001 ,   0.222130373373319398D-001),
     4     (  0.173611111111111111D-002 ,  -0.166462549867334231D-002),
     5     ( -0.694444444444444444D-004 ,   0.754269612298167666D-004),
     6     (  0.192901234567901235D-005 ,  -0.229986793422831468D-005),
     7     ( -0.393675988914084152D-007 ,   0.505163934110747222D-007),
     8     (  0.615118732678256488D-009 ,  -0.838268240495125880D-009),
     9     ( -0.759405842812662331D-011 ,   0.108861603731588473D-010),
     $     (  0.759405842812662331D-013 ,  -0.113696131479448557D-012),
     1     ( -0.627608134555919281D-015 ,   0.975959972766743018D-015),
     2     (  0.435838982330499501D-017 ,  -0.700871957231362727D-017) /

c     Likewise, H1+i*2/(zk*r*pi) is sum of two power series
c     for small arg

c     coefficients of log(zk*r/2)*(zk*r/2)^(2*j+1)
c     (multiplied later by 2*i/pi)

      data logcs1 /   0.100000000000000000D+001,
     1     -0.500000000000000000D+000,
     2     0.833333333333333333D-001,
     3     -0.694444444444444444D-002,
     4     0.347222222222222222D-003,
     5     -0.115740740740740741D-004,
     6     0.275573192239858907D-006,
     7     -0.492094986142605190D-008,
     8     0.683465258531396098D-010,
     9     -0.759405842812662331D-012,
     $     0.690368948011511210D-014,
     1     -0.523006778796599401D-016,
     2     0.335260755638845770D-018 /

c     coefficients of (zk*r/2)^(2*j+1)

      data cs1 /(0.100000000000000000D+001,0.491570190128252900D-001),
     1     ( -0.500000000000000000D+000 ,   0.214153905131430359D+000),
     2     (  0.833333333333333333D-001 ,  -0.577971707291127453D-001),
     3     ( -0.694444444444444444D-002 ,   0.610588066451317710D-002),
     4     (  0.347222222222222222D-003 ,  -0.355029952941876147D-003),
     5     ( -0.115740740740740741D-004 ,   0.131851839051696746D-004),
     6     (  0.275573192239858907D-006 ,  -0.341083657955069719D-006),
     7     ( -0.492094986142605190D-008 ,   0.651034755017267366D-008),
     8     (  0.683465258531396098D-010 ,  -0.955581794844995840D-010),
     9     ( -0.759405842812662331D-012 ,   0.111278867605518515D-011),
     $     (  0.690368948011511210D-014 ,  -0.105357858265556574D-013),
     1     ( -0.523006778796599401D-016 ,   0.827173162991627227D-016),
     2     (  0.335260755638845770D-018 ,  -0.547341260406378455D-018) /

      rscale2 = rscale**2
      zkr = zk*r
      zkrh = 0.5d0*zkr
      zkrh2 = zkrh**2
      zkrhsc = rscale/zkrh

c     get Hankel function values

      ifder = 0
      call h2dall(n,zkr,rscale,hvec,ifder,hder)

      if (abs(zkr) .le. 1.0d0) then

c     small arg, use power series to evaluate stably...
c     note: there's some trickery in here around the log terms

         ztemp0 = 0.0d0
         ztemp1 = 0.0d0
         ztempl0 = 0.0d0
         ztempl1 = 0.0d0
         zkrh2p = 1.0d0

c     note: can remove some of the redundancy here later...

         do p = 0,pmax
            ztemp0 = ztemp0 + cs0(p)*zkrh2p
            ztempl0 = ztempl0 + logcs0(p)*zkrh2p
            ztemp1 = ztemp1 + cs1(p)*zkrh2p
            ztempl1 = ztempl1 + logcs1(p)*zkrh2p
            zkrh2p = zkrh2p*zkrh2
         enddo

         zlogtemp = cdlog(zk/2.0d0)*z2iopi

         ztemp = cdlog(zkrh)*z2iopi
         diffs(0) = ztemp0 + zlogtemp + ztempl0*ztemp
         diffs(1) = ztemp1*zkrh + ztempl1*ztemp*zkrh

         diffs(1) = diffs(1)*rscale

         diffs2 = 0.0d0

         if (n .ge. 2 .or. ifders .eq. 1) then
c     recursion formula is bad for diffs(2)
c     explicitly cancel the log terms, reusing the above
            diffs2 = (ztemp1-ztemp0
     1           +(ztempl1-ztempl0-1.0d0)*ztemp)*rscale2
         endif
c     simple recursion for rest
         if (n .ge. 2) then
            diffs(2) = diffs2
            ztemp = diffs(2)
c     recursion formula pretty good for the rest
            do j = 2,n-1
               ztemp = (j*ztemp)*zkrhsc
     1              - hvec(j-1)*rscale2
               diffs(j+1) = ztemp
            enddo
         endif

         if (ifders .eq. 1) then

            ders(0) = -diffs(1)*zk/rscale

            zkh = 0.5d0*zk
            do j = 1,n-1
               ders(j) = zkh*(hvec(j-1)*rscale-diffs(j+1)/rscale)
            enddo

c     use recursion formula for diffs(n+1) implicitly
            ders(n) = zkh*(2*hvec(n-1)*rscale-diffs(n)*n/zkrh)
c     fix if n = 1 (recursion formula for diffs(2) is unstable in this regime)
            if (n .eq. 1) ders(1) = zkh*(2*hvec(0)*rscale-diffs2/rscale)

         endif

      else

c     directly evaluate

         diffs(0) = hvec(0) - dlog(r)*z2iopi

         ztemp = z2iopi*rscale/zkr
         diffs(1) = hvec(1) + ztemp
         do j = 1,n-1
            ztemp = (j*ztemp)*zkrhsc
            diffs(j+1) = hvec(j+1) + ztemp
         enddo

         if (ifders .eq. 1) then

            ders(0) = -diffs(1)*zk/rscale

            zkh = 0.5d0*zk
            do j = 1,n-1
               ders(j) = zkh*(hvec(j-1)*rscale-diffs(j+1)/rscale)
            enddo

c     use recursion formula for diffs(n+1) implicitly
            ders(n) = zkh*(2*hvec(n-1)*rscale-diffs(n)*n/zkrh)

         endif

      endif

      return
      end

      subroutine diffszkjfun(r,zk,rscale,diffs,ifders,ders,jvec,n)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     This subroutine evaluates the difference kernel
c
c     J_n(zk*r) - (zk*r)^n/(rscale^2*2^n*n!)
c
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none
c     global variables
      complex *16 zk, diffs(0:n), ders(0:n), jvec(0:n)
      real *8 r, rscale
      integer n, ifders
c     local variables
      complex *16 eye
      integer ifder, p, j, ntop, ier, n1
      data eye / (0.0d0,1.0d0) /
      integer pmax, lwfjs
      parameter (pmax = 12)
      real *8 cs0(0:pmax), cs1(0:pmax), rscale2
      complex *16 zkr, zkrh, zkr2p, jder(0:1), ztemp
      complex *16, allocatable :: jvals(:)
      integer, allocatable :: iscale(:)

c     J0-1 and J1-zk*r/2 are given as power series
c     coefficients are precomputed

c     J0-1, coefficients of (zk*r)^(2*j)

      data cs0 /   0.000000000000000000D+000,
     1     -0.250000000000000000D+000,
     2     0.156250000000000000D-001,
     3     -0.434027777777777778D-003,
     4     0.678168402777777778D-005,
     5     -0.678168402777777778D-007,
     6     0.470950279706790123D-009,
     7     -0.240280754952443941D-011,
     8     0.938596699032984143D-014,
     9     -0.289690339207711155D-016,
     $     0.724225848019277888D-019,
     1     -0.149633439673404522D-021,
     2     0.259780277210771740D-024 /

c     J1-zk*r/2, coefficients of (zk*r)^(2*j+1)

      data cs1 /   0.000000000000000000D+000,
     1     -0.625000000000000000D-001,
     2     0.260416666666666667D-002,
     3     -0.542534722222222222D-004,
     4     0.678168402777777778D-006,
     5     -0.565140335648148148D-008,
     6     0.336393056933421517D-010,
     7     -0.150175471845277463D-012,
     8     0.521442610573880079D-015,
     9     -0.144845169603855578D-017,
     $     0.329193567281489949D-020,
     1     -0.623472665305852176D-023,
     2     0.999154912349122077D-026 /

      rscale2 = rscale**2
      zkr = zk*r
      zkrh = 0.5d0*zkr

c     get Bessel function values

      lwfjs = n+10+4*n+100
      allocate(jvals(0:lwfjs),iscale(lwfjs))
      n1 = n+1
      ifder = 0
      call jfuns2d(ier,n1,zkr,rscale,jvals,ifder,jder,
     1     lwfjs,iscale,ntop)
      if (ier .ne. 0) then
         write(*,*) "WARNING, JFUNS BOMBED!!!", ier, zkr
         return
      endif
      do j = 0,n
         jvec(j) = jvals(j)
      enddo

      if (abs(zkr) .le. 1.0d0) then

c     small arg, use power series to evaluate stably...

         diffs(0) = 0.0d0
         diffs(1) = 0.0d0
         zkr2p = zkr**2

         do p = 1,pmax
            diffs(0) = diffs(0) + cs0(p)*zkr2p
            zkr2p = zkr2p*zkr
            diffs(1) = diffs(1) + cs1(p)*zkr2p
            zkr2p = zkr2p*zkr
         enddo

c     simple recursion for rest

         diffs(1) = diffs(1)/rscale
         ztemp = diffs(1)
         do j = 2,n
            ztemp = (zkrh*(ztemp+jvals(j+1)*rscale2))/(rscale*j)
            diffs(j) = ztemp
         enddo

      else

c     directly evaluate

         ztemp = 1.0d0
         diffs(0) = jvals(0) - ztemp
         do j = 1,n
            ztemp = (zkrh*ztemp)/(j*rscale)
            diffs(j) = jvals(j) - ztemp
         enddo
      endif

      if (ifders .eq. 1) then

      endif

      return
      end


      program main

c*********************************************************************72
c
cc MAIN is the main program for ANALEMMA.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c   Sourangshu Ghosh
c
c  Author:
c
c    Original C version by Brian Tung.
c    FORTRAN77 version by John Burkardt.
c
c  Local parameters:
c
c    Local, double precision ECC, the orbital eccentricity.
c
c    Local, double precision LON, the longitude of the perihelion in radians.
c
c    Local, double precision OBLIQ, the obliquity in radians.
c
      implicit none

      character * ( 255 ) arg
      character * ( 80 ) command_filename
      integer command_unit
      character * ( 80 ) data_filename
      integer data_unit
      double precision days
      parameter ( days = 365.242D+00 )
      double precision dec
      double precision degrees
      parameter ( degrees = 3.141592653589793D+00 / 180.0D+00 )
      double precision ecc
      double precision eot
      double precision f
      integer i
      double precision lon
      integer n
      integer numarg
      double precision obliq
      double precision pi
      parameter ( pi = 3.141592653589793D+00 )
      double precision t
      double precision tau
      double precision theta
      double precision x1
      double precision x2
      double precision x3
      double precision y1
      double precision y2
      double precision y3
      double precision z1
      double precision z2
      double precision z3

      call timestamp ( )
      write ( *, '(a)' ) ''
      write ( *, '(a)' ) 'ANALEMMA'
      write ( *, '(a)' ) '  FORTRAN77 version'
      write ( *, '(a)' )
     &  '  Compute and plot the analemma, equation of time,'
      write ( *, '(a)' ) '  and declination.'
      write ( *, '(a)' )
     &  '  This program is based on a C program by Brian Tung.'
c
c  Parse the arguments
c
      numarg = iargc ( )

      if ( numarg .lt. 1 ) then
        ecc = 0.01671D+00
      else
        i = 1
        call getarg ( i, arg )
        call s_to_r8 ( arg, ecc )
      end if

      if ( numarg .lt. 2 ) then
        lon = 1.347D+00
      else
        i = 2
        call getarg ( i, arg )
        call s_to_r8 ( arg, lon )
        lon = lon * pi / 180.0D+00
      end if

      if ( numarg .lt. 3 ) then
        obliq = 0.4091D+00
      else
        i = 3
        call getarg ( i, arg )
        call s_to_r8 ( arg, obliq )
        obliq = obliq * pi / 180.0D+00
      end if
c
c  Compute the data.
c
      data_filename = 'analemma_data.txt'
      call get_unit ( data_unit )
      open ( unit = data_unit, file = data_filename )

      n = 10000

      do i = 0, n - 1

        f = dble ( i ) / dble ( n )
        tau = 2.0D+00 * pi * f
c
c  Set theta to the current longitude.
c
        theta = atan2 ( sqrt ( 1.0D+00 - ecc * ecc ) * sin ( tau ),
     &    cos ( tau ) - ecc )
c
c  Rotate clockwise in XY plane by theta, corrected by lon.
c
        x1 = cos ( theta - ( lon - pi / 2.0D+00 ) )
        y1 = sin ( theta - ( lon - pi / 2.0D+00 ) )
        z1 = 0.0D+00
c
c  Rotate counter-clockwise in XZ plane by obliq.
c
        x2 =   cos ( obliq ) * x1 + sin ( obliq ) * z1
        y2 = y1
        z2 = - sin ( obliq ) * x1 + cos ( obliq ) * z1
c
c  Set t equal to real time from tau and
c  rotate counter-clockwise by t, corrected by lon
c
        t = tau - ecc * sin ( tau );
        x3 =   cos ( t - ( lon - pi / 2.0D+00 ) ) * x2
     &       + sin ( t - ( lon - pi / 2.0D+00 ) ) * y2;
        y3 = - sin ( t - ( lon - pi / 2.0D+00 ) ) * x2
     &       + cos ( t - ( lon - pi / 2.0D+00 ) ) * y2;
        z3 = z2

        eot = - atan2 ( y3, x3 ) * 4.0D+00 / degrees
     &    * days / ( days + 1.0D+00 )
        dec = asin ( z3 ) / degrees
c
c  Print results in minutes early/late and degrees north/south
c
        write ( data_unit, '(2x,g14.6,2x,g14.6,2x,g14.6)' )
     &    t / ( 2.0D+00 * pi ), eot, dec

      end do

      close ( unit = data_unit )

      write ( *, '(a)' ) ''
      write ( *, '(a)' )
     &  '  Created data file "' // trim ( data_filename ) // '".'
c
c  Create the command file.
c
      command_filename = 'analemma_commands.txt'
      call get_unit ( command_unit )
      open ( unit = command_unit, file = command_filename )
      write ( command_unit, '(a)' ) 'set term png'
      write ( command_unit, '(a)' ) 'set grid'
      write ( command_unit, '(a)' ) 'set style data lines'
      write ( command_unit, '(a)' ) 'unset key'
      write ( command_unit, '(a)' ) 'set output "eot.png"'
      write ( command_unit, '(a)' )
     &  'set xlabel "<---Normalized Date--->"'
      write ( command_unit, '(a)' )
     &  'set ylabel "<---Minutes Early/Late--->"'
      write ( command_unit, '(a)' ) 'set title "The equation of time"'
      write ( command_unit, '(a)' ) 'plot "' // trim ( data_filename )
     &  // '" using 1:2 with lines'
      write ( command_unit, '(a)' ) 'set output "declination.png"'
      write ( command_unit, '(a)' )
     &  'set xlabel "<---Normalized Date--->"'
      write ( command_unit, '(a)' )
     &  'set ylabel "<---Degrees North/South--->"'
      write ( command_unit, '(a)' ) 'set title "Declination"'
      write ( command_unit, '(a)' ) 'plot "' // trim ( data_filename )
     &  // '" using 1:3 with lines'
      write ( command_unit, '(a)' ) 'set output "analemma.png"'
      write ( command_unit, '(a)' )
     &  'set xlabel "<---Minutes Early/Late--->"'
      write ( command_unit, '(a)' )
     &  'set ylabel "<---Degrees North/South--->"'
      write ( command_unit, '(a)' ) 'set title "The analemma"'
      write ( command_unit, '(a)' ) 'plot "' // trim ( data_filename )
     &  // '" using 2:3 with lines'
      write ( command_unit, '(a)' ) 'quit'

      close ( unit = command_unit )

      write ( *, '(a)' ) '  Created command file "'
     &  // trim ( command_filename ) // '".'
c
c  Terminate.
c
      write ( *, '(a)' ) ''
      write ( *, '(a)' ) 'ANALEMMA'
      write ( *, '(a)' ) '  Normal end of execution.'
      write ( *, '(a)' ) ''
      call timestamp ( )

      stop
      end
      subroutine get_unit ( iunit )

c*********************************************************************72
c
cc GET_UNIT returns a free FORTRAN unit number.
c
c  Discussion:
c
c    A "free" FORTRAN unit number is a value between 1 and 99 which
c    is not currently associated with an I/O device.  A free FORTRAN unit
c    number is needed in order to open a file with the OPEN command.
c
c    If IUNIT = 0, then no free FORTRAN unit could be found, although
c    all 99 units were checked (except for units 5, 6 and 9, which
c    are commonly reserved for console I/O).
c
c    Otherwise, IUNIT is a value between 1 and 99, representing a
c    free FORTRAN unit.  Note that GET_UNIT assumes that units 5 and 6
c    are special, and will never return those values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 September 2013
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Output, integer IUNIT, the free unit number.
c
      implicit none

      integer i
      integer iunit
      logical value

      iunit = 0

      do i = 1, 99

        if ( i .ne. 5 .and. i .ne. 6 .and. i .ne. 9 ) then

          inquire ( unit = i, opened = value, err = 10 )

          if ( .not. value ) then
            iunit = i
            return
          end if

        end if

10      continue

      end do

      return
      end
      subroutine s_to_r8 ( s, r8 )

c*********************************************************************72
c
cc S_TO_R8 reads an R8 value from a string.
c
c  Discussion:
c
c    An "R8" value is simply a real number to be stored as a
c    variable of type "double precision".
c
c    The routine will read as many characters as possible until it reaches
c    the end of the string, or encounters a character which cannot be
c    part of the number.
c
c    Legal input is:
c
c       1 blanks,
c       2 '+' or '-' sign,
c       2.5 blanks
c       3 integer part,
c       4 decimal point,
c       5 fraction part,
c       6 'E' or 'e' or 'D' or 'd', exponent marker,
c       7 exponent sign,
c       8 exponent integer part,
c       9 exponent decimal point,
c      10 exponent fraction part,
c      11 blanks,
c      12 final comma or semicolon,
c
c    with most quantities optional.
c
c  Example:
c
c    S                 R8
c
c    '1'               1.0
c    '     1   '       1.0
c    '1A'              1.0
c    '12,34,56'        12.0
c    '  34 7'          34.0
c    '-1E2ABCD'        -100.0
c    '-1X2ABCD'        -1.0
c    ' 2E-1'           0.2
c    '23.45'           23.45
c    '-4.2E+2'         -420.0
c    '17d2'            1700.0
c    '-14e-2'         -0.14
c    'e2'              100.0
c    '-12.73e-9.23'   -12.73 * 10.0^(-9.23)
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    06 January 2013
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, character * ( * ) S, the string containing the
c    data to be read.  Reading will begin at position 1 and
c    terminate at the end of the string, or when no more
c    characters can be read to form a legal real.  Blanks,
c    commas, or other nonnumeric data will, in particular,
c    cause the conversion to halt.
c
c    Output, double precision R8, the value read from the string.
c
      implicit none

      character c
      integer ierror
      integer ihave
      integer isgn
      integer iterm
      integer jbot
      integer jsgn
      integer jtop
      integer length
      integer ndig
      double precision r8
      double precision rbot
      double precision rexp
      double precision rtop
      character * ( * ) s
      integer s_length
      character TAB
      parameter ( TAB = char ( 9 ) )

      s_length = len_trim ( s )

      ierror = 0
      r8 = 0.0D+00
      length = -1
      isgn = 1
      rtop = 0
      rbot = 1
      jsgn = 1
      jtop = 0
      jbot = 1
      ihave = 1
      iterm = 0

10    continue

        length = length + 1

        if ( s_length .lt. length + 1 ) then
          go to 20
        end if

        c = s(length+1:length+1)
c
c  Blank character.
c
        if ( c .eq. ' ' .or. c .eq. TAB ) then

          if ( ihave .eq. 2 ) then

          else if ( ihave .eq. 6 .or. ihave .eq. 7 ) then
            iterm = 1
          else if ( 1 < ihave ) then
            ihave = 11
          end if
c
c  Comma.
c
        else if ( c .eq. ',' .or. c .eq. ';' ) then

          if ( ihave .ne. 1 ) then
            iterm = 1
            ihave = 12
            length = length + 1
          end if
c
c  Minus sign.
c
        else if ( c .eq. '-' ) then

          if ( ihave .eq. 1 ) then
            ihave = 2
            isgn = -1
          else if ( ihave .eq. 6 ) then
            ihave = 7
            jsgn = -1
          else
            iterm = 1
          end if
c
c  Plus sign.
c
        else if ( c .eq. '+' ) then

          if ( ihave .eq. 1 ) then
            ihave = 2
          else if ( ihave .eq. 6 ) then
            ihave = 7
          else
            iterm = 1
          end if
c
c  Decimal point.
c
        else if ( c .eq. '.' ) then

          if ( ihave .lt. 4 ) then
            ihave = 4
          else if ( 6 .le. ihave .and. ihave .le. 8 ) then
            ihave = 9
          else
            iterm = 1
          end if
c
c  Scientific notation exponent marker.
c
        else if ( c .eq. 'E' .or. c .eq. 'e' .or.
     &            c .eq. 'D' .or. c .eq. 'd' ) then

          if ( ihave .lt. 6 ) then
            ihave = 6
          else
            iterm = 1
          end if
c
c  Digit.
c
        else if (  ihave .lt. 11 .and. lle ( '0', c )
     &    .and. lle ( c, '9' ) ) then

          if ( ihave .le. 2 ) then
            ihave = 3
          else if ( ihave .eq. 4 ) then
            ihave = 5
          else if ( ihave .eq. 6 .or. ihave .eq. 7 ) then
            ihave = 8
          else if ( ihave .eq. 9 ) then
            ihave = 10
          end if

          ndig = ichar ( c ) - 48

          if ( ihave .eq. 3 ) then
            rtop = 10.0D+00 * rtop + dble ( ndig )
          else if ( ihave .eq. 5 ) then
            rtop = 10.0D+00 * rtop + dble ( ndig )
            rbot = 10.0D+00 * rbot
          else if ( ihave .eq. 8 ) then
            jtop = 10 * jtop + ndig
          else if ( ihave .eq. 10 ) then
            jtop = 10 * jtop + ndig
            jbot = 10 * jbot
          end if
c
c  Anything else is regarded as a terminator.
c
        else
          iterm = 1
        end if
c
c  If we haven't seen a terminator, and we haven't examined the
c  entire string, go get the next character.
c
        if ( iterm .eq. 1 ) then
          go to 20
        end if

      go to 10

20    continue
c
c  If we haven't seen a terminator, and we have examined the
c  entire string, then we're done, and LENGTH is equal to S_LENGTH.
c
      if ( iterm .ne. 1 .and. length + 1 .eq. s_length ) then
        length = s_length
      end if
c
c  Number seems to have terminated.  Have we got a legal number?
c  Not if we terminated in states 1, 2, 6 or 7!
c
      if ( ihave .eq. 1 .or. ihave .eq. 2 .or. ihave .eq. 6 .or.
     &  ihave .eq. 7 ) then
        ierror = ihave
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'S_TO_R8 - Serious errorc'
        write ( *, '(a)' ) '  Illegal or nonnumeric input:'
        write ( *, '(a)' ) '    ' // trim ( s )
        stop
      end if
c
c  Number seems OK.  Form it.
c
      if ( jtop .eq. 0 ) then
        rexp = 1.0D+00
      else
        if ( jbot .eq. 1 ) then
          rexp = 10.0D+00 ** ( jsgn * jtop )
        else
          rexp = 10.0D+00 ** ( dble ( jsgn * jtop ) / dble ( jbot ) )
        end if
      end if

      r8 = dble ( isgn ) * rexp * rtop / rbot

      return
      end
      subroutine timestamp ( )

c*********************************************************************72
c
cc TIMESTAMP prints out the current YMDHMS date as a timestamp.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    12 January 2007
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    None
c
      implicit none

      character * ( 8 ) ampm
      integer d
      character * ( 8 ) date
      integer h
      integer m
      integer mm
      character * ( 9 ) month(12)
      integer n
      integer s
      character * ( 10 ) time
      integer y

      save month

      data month /
     &  'January  ', 'February ', 'March    ', 'April    ',
     &  'May      ', 'June     ', 'July     ', 'August   ',
     &  'September', 'October  ', 'November ', 'December ' /

      call date_and_time ( date, time )

      read ( date, '(i4,i2,i2)' ) y, m, d
      read ( time, '(i2,i2,i2,1x,i3)' ) h, n, s, mm

      if ( h .lt. 12 ) then
        ampm = 'AM'
      else if ( h .eq. 12 ) then
        if ( n .eq. 0 .and. s .eq. 0 ) then
          ampm = 'Noon'
        else
          ampm = 'PM'
        end if
      else
        h = h - 12
        if ( h .lt. 12 ) then
          ampm = 'PM'
        else if ( h .eq. 12 ) then
          if ( n .eq. 0 .and. s .eq. 0 ) then
            ampm = 'Midnight'
          else
            ampm = 'AM'
          end if
        end if
      end if

      write ( *,
     &  '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' )
     &  d, month(m), y, h, ':', n, ':', s, '.', mm, ampm

      return
      end


	FUNCTION PS_BRCH ( datain, nparm, tvflag )
C************************************************************************
C* PS_BRCH								*
C*									*
C* This function computes the Bulk Richardson Number:			*
C*									*
C*	BRCH = CAPE / ( 0.5 * U**2 )					*
C*									*
C*		CAPE  = Convective Available Potential Energy		*
C*		U     = magnitude of shear ( u6 - ub, v6 - vb )		*
C*		ub,vb = average u,v in the layer SFC - 500 m		*
C*		u6,v6 = average u,v in the layer SFC - 6000 m		*
C*									*
C* The first user input depth will replace the 500 m; the second will	*
C* replace the 6000 m.  TVFLAG determines if temperature or virtual	*
C* temperature is used in the calculation.				*
C*									*
C* REAL PS_BRCH ( DATAIN, NPARM, TVFLAG )				*
C*									*
C* Input parameters:							*
C*	DATAIN(NPARM,*)	REAL		Station data			*
C*	NPARM		INTEGER		Number of dataset parameters	*
C*	TVFLAG		LOGICAL		Temperature flag		*
C*									*
C* Output parameters:							*
C*	PS_BRCH		REAL		Bulk Richardson Number		*
C**									*
C* Log:									*
C* G. Huffman/USRA	 9/89	Adapted from PS_PRCL			*
C* M. desJardins/GSFC	 7/90	Reorganized for GEMPAK 5		*
C* J. Whistler/SSAI	 7/91	Changed ier to ier1 & 2 in PS_PRCL call	*
C* T. Lee/GSC		 8/97	Added a temperature flag		*
C* M. Linda/GSC		10/97	Corrected the prologue format		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		datain ( nparm, * )
	LOGICAL		tvflag
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
	PS_BRCH = RMISSD
C
C*	Compute CAPE.
C
	cape = PS_CAPE ( datain, nparm, tvflag )
	IF  ( ERMISS ( cape ) )  RETURN
C
C*	Get average u- and v- wind components in the 500 m and 6000 m
C*	layers.
C
	CALL PS_PRCL  ( datain, nparm, 500., 3, 1, depth, idcord, pavg,
     +			tavg, tdavg, u500, v500, zavg, thavg,
     +			rmxavg, ier1 )
	CALL PS_PRCL  ( datain, nparm, 6000., 3, 2, depth, idcord, pavg,
     +			tavg, tdavg, u6000, v6000, zavg, thavg,
     +			rmxavg, ier2 )
	IF  ( ( ier1 .ne. 0 ) .or. ( ier2 .ne. 0 ) .or.
     +	      ( ERMISS (u500) ) .or. ( ERMISS (v500) ) .or.
     +	      ( ERMISS (u6000) ) .or. ( ERMISS (v6000) ) )  RETURN
C
C*	Compute the Bulk Richardson Number.
C
	PS_BRCH = cape / ( .5 * ( (u6000 - u500) ** 2 +
     +				  (v6000 - v500) ** 2 ) )
C*
	RETURN
	END


      subroutine MATMUL(a, b, c)

      integer i, j, k
      integer mat1(1:1000, 1:1000), mat2(1:1000, 1:1000),
     & mat3(1:1000, 1:1000)

      do 10 i = 1, 1000
         do 20 j = 1, 1000
c BEGIN_FPGA_MATMULHRE
            mat3(i, j) = 0
            do 30 k = 1, 1000
               mat3(i, j) = mat3(i, j) + mat1(i, k) * mat2(k, j)
 30   enddo
c END_FPGA_MATMULHRE
 20   enddo
 10   enddo

      return
      end


! These subroutines are copyright John Manchuk (2013) and used
! with permission.

!Module with types and functions for using rotation matrices
!in gslib type programs
!COPYRIGHT JOHN MANCHUK JANUARY 2013
module rotationmatrix
    implicit none

    public :: set_rmat, &
              dsqrd, &
              fix_angles
    private

    real*8, parameter :: PI=3.141592653589793238462643383279502884197D0
    real*8, parameter :: DEG2RAD = PI / 180.D0

contains

    !Populate a rotation matrix based on angles (uncorrected!), and
    !ranges that describe a variogram or search ellipse.
    function set_rmat ( angles, ranges ) result ( rm )
        real*8, intent (in) :: angles( 3 )
        real*8, intent (in) :: ranges( 3 )
        real*8 :: sina, sinb, sint, cosa, cosb, cost
        real*8, dimension ( 3 ) :: a
        real*8 :: r1, r2
        real*8 :: rm(3,3)

        ! Fix the angles and get the required sines and cosines:
        a = angles
        call fix_angles ( a )
        sina = dsin(a(1)) ; sinb = dsin(a(2)) ; sint = dsin(a(3))
        cosa = dcos(a(1)) ; cosb = dcos(a(2)) ; cost = dcos(a(3))

        ! Construct the rotation matrix:
        r1 = ranges(1) / ranges(2)
        r2 = ranges(1) / ranges(3)
        rm(1,:) = (/ cosb * cosa , cosb * sina , -sinb /)
        rm(2,:) = (/ r1 * (-cost * sina + sint * sinb * cosa) , &
                     r1 * ( cost * cosa + sint * sinb * sina) , &
                     r1 * ( sint * cosb) /)
        rm(3,:) = (/ r2 * ( sint * sina + cost * sinb * cosa) , &
                     r2 * (-sint * cosa + cost * sinb * sina) , &
                     r2 * ( cost * cosb) /)
        Return
    end function set_rmat

    !Convert three angles of anisotropy to those that are usable.  Note that
    !the vector of angles will be updated and returned
    subroutine fix_angles ( angles )
        real*8, intent (inout) :: angles( 3 )
        !1st - angle between the major axis of anisotropy and the
        !      E-W axis. Note: Counter clockwise is positive.
        !2nd - angle between major axis and the horizontal plane.
        !      (The dip of the ellipsoid measured positive down)
        !3rd - Angle of rotation of minor axis about the major axis
        !      of the ellipsoid.
        if(angles(1) >= 0.0D+00 .and. angles(1) < 270.0D+00) then
            angles(1) = ( 90.0D+00 - angles(1)) * DEG2RAD
        else
            angles(1) = (450.0D+00 - angles(1)) * DEG2RAD
        endif
        angles(2) = -1.0D+00 * angles(2) * DEG2RAD
        angles(3) =  1.0D+00 * angles(3) * DEG2RAD
        Return
    end subroutine fix_angles

    !Get the anisotropic distance between two points
    real*8 function dsqrd ( a, b, rm )
        real*8, intent (in) :: a(3), b(3)
        real*8, optional :: rm(3,3)
        real*8 :: ba(3)
        ba = b - a
        if(present(rm))then
            dsqrd = (rm(1,1)*ba(1) + rm(1,2)*ba(2) + rm(1,3)*ba(3))**2 + &
                    (rm(2,1)*ba(1) + rm(2,2)*ba(2) + rm(2,3)*ba(3))**2 + &
                    (rm(3,1)*ba(1) + rm(3,2)*ba(2) + rm(3,3)*ba(3))**2
        else
            dsqrd = ba(1)**2 + ba(2)**2 + ba(3)**2
        endif
    end function dsqrd

end module rotationmatrix


!Module with types and functions for using normal distributions
!in gslib type programs
! Author: John Manchuk, 2010
! References:   Michael Wichura,
!               The Percentage Points of the Normal Distribution,
!               Algorithm AS 241,
!               Applied Statistics,
!               Volume 37, Number 3, pages 477-484, 1988.
! Some routines were written by John Burkardt
!
module normaldist
    implicit none

    !Normal distribution functions
    PUBLIC ::  norm_pdf, & !calculate the non-standard normal density
              snorm_pdf, & !calculate the standard normal density
               norm_cdf, & !calculate the non-standard normal cumulative probability
              snorm_cdf, & !calculate the standard normal cumulative probability
              snorm_inv    !calculate the inverse standard normal cdf

    PUBLIC :: locate, powint

    PRIVATE

    real*8, parameter :: PI = 3.141592653589793238462643383279502884197
    real*8, parameter :: SCALE = 1. / ( 2. * PI )

contains

    !***********************************!
    !   NORMAL DISTRIBUTION FUNCTIONS   !
    !***********************************!

    !Calculate the non-standard probability density for a value
    real*8 function norm_pdf ( x, m, v ) result ( y )
        real*8, intent (in) :: x, m, v !value, mean, variance
        y = snorm_pdf ( (x - m) / dsqrt( v ) )
    end function norm_pdf

    !Calculate the standard normal probability density for a value
    real*8 function snorm_pdf ( x ) result ( y )
        real*8, intent (in) :: x
        y = dsqrt ( SCALE ) * exp ( -0.5 * x**2 )
    end function snorm_pdf

    !Calculate the non-standard cumulative probability for a value
    real*8 function norm_cdf ( x, m, v ) result ( cdf )
        real*8, intent (in) :: x, m, v !value, mean, variance
        cdf = snorm_cdf ( (x - m) / dsqrt( v ) )
    end function norm_cdf

    !Calculate the standard cumulative probability for a value
    real*8 function snorm_cdf ( x ) result ( cdf )
        real*8, intent (in) :: x
        real*8, parameter :: a1 = 0.398942280444D+00, a2 = 0.399903438504D+00, a3 = 5.75885480458D+00, &
	                         a4 = 29.8213557808D+00,  a5 = 2.62433121679D+00,  a6 = 48.6959930692D+00, &
	                         a7 = 5.92885724438D+00
	    real*8, parameter :: b0 = 0.398942280385D+00, b1 = 3.8052D-08,         b2 = 1.00000615302D+00, &
	                         b3 = 3.98064794D-04,     b4 = 1.98615381364D+00,  b5 = 0.151679116635D+00, &
	                         b6 = 5.29330324926D+00,  b7 = 4.8385912808D+00,   b8 = 15.1508972451D+00, &
	                         b9 = 0.742380924027D+00, b10 = 30.789933034D+00,  b11 = 3.99019417011D+00
	    real*8 :: q, y

        !  |X| <= 1.28.
	    if( abs( x ) <= 1.28 )then
	        y = 0.5 * x**2
	        q = 0.5 - abs ( x ) * (a1 - a2 * y / (y + a3 - a4 / (y + a5 + a6 / (y + a7 ))))

        !  1.28 < |X| <= 12.7
	    elseif( abs( x ) <= 12.7 )then
	        y = 0.5 * x**2
	        q = exp( -y ) * b0 / ( abs ( x ) - b1                 &
                + b2  / (abs( x ) + b3 + b4 / (abs( x ) - b5   &
                + b6  / (abs( x ) + b7 - b8 / (abs( x ) + b9   &
                + b10 / (abs( x ) + b11))))))

        !  12.7 < |X|
	    else
	        q = 0.0
	    end if

        !  Take account of negative X.
        if(x < 0.0)then
            cdf = q
        else
            cdf = 1.0 - q
        end if
    end function snorm_cdf

    !Invert the normal cdf at a specified quantile
    real*8 function snorm_inv ( p ) result ( x )
        !  Discussion: The result is accurate to about 1 part in 10**16.
        !  Modified: 27 December 2004
        !  Author: Michael Wichura. FORTRAN90 version by John Burkardt
        !  Reference:
        !    Michael Wichura,
        !    The Percentage Points of the Normal Distribution,
        !    Algorithm AS 241,
        !    Applied Statistics,
        !    Volume 37, Number 3, pages 477-484, 1988.
        real*8, intent (in) :: p
        real*8, parameter, dimension ( 8 ) :: a = (/ 3.3871328727963666080D+00, 1.3314166789178437745D+02, &
            1.9715909503065514427D+03, 1.3731693765509461125D+04, 4.5921953931549871457D+04, &
            6.7265770927008700853D+04, 3.3430575583588128105D+04, 2.5090809287301226727D+03 /)
        real*8, parameter, dimension ( 8 ) :: b = (/ 1.0000000000000000000D+00, 4.2313330701600911252D+01, &
            6.8718700749205790830D+02, 5.3941960214247511077D+03, 2.1213794301586595867D+04, &
            3.9307895800092710610D+04, 2.8729085735721942674D+04, 5.2264952788528545610D+03 /)
        real*8, parameter, dimension ( 8 ) :: c = (/ 1.42343711074968357734D+00, 4.63033784615654529590D+00, &
            5.76949722146069140550D+00, 3.64784832476320460504D+00, 1.27045825245236838258D+00, &
            2.41780725177450611770D-01, 2.27238449892691845833D-02, 7.74545014278341407640D-04 /)
        real*8, parameter, dimension ( 8 ) :: d = (/ 1.00000000000000000000D+00, 2.05319162663775882187D+00, &
            1.67638483018380384940D+00, 6.89767334985100004550D-01, 1.48103976427480074590D-01, &
            1.51986665636164571966D-02, 5.47593808499534494600D-04, 1.05075007164441684324D-09 /)
        real*8, parameter, dimension ( 8 ) :: e = (/ 6.65790464350110377720D+00, 5.46378491116411436990D+00, &
            1.78482653991729133580D+00, 2.96560571828504891230D-01, 2.65321895265761230930D-02, &
            1.24266094738807843860D-03, 2.71155556874348757815D-05, 2.01033439929228813265D-07 /)
        real*8, parameter, dimension ( 8 ) :: f = (/ 1.00000000000000000000D+00, 5.99832206555887937690D-01, &
            1.36929880922735805310D-01, 1.48753612908506148525D-02, 7.86869131145613259100D-04, &
            1.84631831751005468180D-05, 1.42151175831644588870D-07, 2.04426310338993978564D-15 /)
        real*8, parameter :: split1 = 0.425
        real*8, parameter :: split2 = 5.0
        real*8, parameter :: const1 = 0.180625
        real*8, parameter :: const2 = 1.6
        real*8 :: q, r

        !Is p valid ( 0 <= p <= 1 )
        if ( p <= 0.0 ) then
            x = -huge ( p ) ; return
        endif

        if ( p >= 1.0 ) then
            x = huge ( p ) ; return
        endif

        q = p - 0.5

        if( abs ( q ) <= split1 )then
            r = const1 - q * q
            x = q * dpoly_value ( 8, a, r ) / dpoly_value ( 8, b, r )
        else
            if( q < 0.0 )then
                r = p
            else
                r = 1.0 - p
            endif

            if( r <= 0.0 )then
                x = -1.0
                STOP
            endif

            r = dsqrt ( -dlog ( r ) )

            if( r <= split2 )then
                r = r - const2
                x = dpoly_value ( 8, c, r ) / dpoly_value ( 8, d, r )
            else
                r = r - split2
                x = dpoly_value ( 8, e, r ) / dpoly_value ( 8, f, r )
            endif

            if ( q < 0.0 ) then
                x = -x
            endif
        endif

        contains
        real*8 function dpoly_value ( n, a, x ) result ( p )
            !Given N and A, the form of the polynomial is:
            !  p(x) = a(1) + a(2) * x + ... + a(n-1) * x^(n-2) + a(n) * x^(n-1)
            !  Modified: 13 August 2004
            !  Author: John Burkardt
            integer, intent (in) :: n
            real*8,    intent (in) :: x
            real*8, dimension ( n ), intent (in) :: a
            integer :: i
            p = 0.0
            do i = n, 1, -1
                p = p * x + a(i)
            enddo
        end function dpoly_value
    end function snorm_inv

    !Power interpolate the value of y between (xlow,ylow) and (xhigh,yhigh)
    !for a value of x and a power pow.
    real*8 function powint ( xlow, xhigh, ylow, yhigh, xval, pow)
        real*8, parameter   :: EPSLON = 1.0e-20
        real*8, intent (in) :: xlow, xhigh, ylow, yhigh, xval, pow

        if((xhigh - xlow) < EPSLON) then
            powint = (yhigh + ylow) / 2.0
        else
            powint = ylow + (yhigh-ylow) * (((xval-xlow)/(xhigh-xlow))**pow)
        end if
    end function powint

    subroutine locate ( xx, n, is, ie, x, j )
    !-----------------------------------------------------------------------
    ! Given an array "xx" of length "n", and given a value "x", this routine
    ! returns a value "j" such that "x" is between xx(j) and xx(j+1).  xx
    ! must be monotonic, either increasing or decreasing.  j=is-1 or j=ie is
    ! returned to indicate that x is out of range.
    ! Modified from GSLIB version (Deutsch, C.V., 1992)
    !-----------------------------------------------------------------------
        integer, intent (in)    :: n,is,ie
        integer, intent (inout) :: j
        real*8,  pointer    :: xx(:)
        real*8,  intent (inout) :: x
        integer :: jl, ju, jm

        ! Initialize lower and upper methods:
        jl = lbound(xx, 1)
        if(is < jl .or. ie > n) &
            STOP 'ERROR IN LOCATE ROUTINE: LOWER BOUNDS EXCEEDED'

        jl = is - 1
        ju = ie
        if(xx(n) <= x) then
            j = ie ; return
        end if

        ! If we are not done then compute a midpoint:
        do while (ju - jl > 1)
            jm = (ju + jl) / 2
            if((xx(ie) > xx(is)).eqv.(x > xx(jm))) then
                jl = jm ; else
                ju = jm ; endif
        enddo
        j = jl
    end subroutine locate

end module normaldist


program solve2by2eq
    implicit none
    real a11,a12,a21,a22,b1,b2,det,x1,x2
    a11=7;a12=4 ;b1=2
    a21=1;a22=-8;b2=-1
    det = a11*a22-a21*a12
    x1=(b1*a22-b2*a12)/det
    x2=(a11*b2-a21*b1)/det
    print*,x1,x2
end program solve2by2eq