!=============================================================================!
        module diff
!
!  Finite Difference coefficients of various orders
!
!=============================================================================!
!.... First derivatives
!=============================================================================!

!.... fourth order central difference ( 1 2 x 4 5 )

        real, parameter :: ga1 =  8.333333333333333333333E-02
        real, parameter :: ga2 = -6.666666666666666666667E-01
        real, parameter :: ga3 =  6.666666666666666666667E-01
        real, parameter :: ga4 = -8.333333333333333333333E-02

!.... fourth order one-sided ( x 2 3 4 5 )

        real, parameter :: gc1 = -2.083333333333333333333E+00
        real, parameter :: gc2 =  4.000000000000000000000E+00
        real, parameter :: gc3 = -3.000000000000000000000E+00
        real, parameter :: gc4 =  1.333333333333333333333E+00
        real, parameter :: gc5 = -2.500000000000000000000E-01

!.... fourth order biased difference ( 1 x 2 3 4 5 )

        real, parameter :: gb1 = -2.500000000000000000000E-01
        real, parameter :: gb2 = -8.333333333333333333333E-01
        real, parameter :: gb3 =  1.500000000000000000000E+00
        real, parameter :: gb4 = -5.000000000000000000000E-01
        real, parameter :: gb5 =  8.333333333333333333333E-02

!.... fifth order one-sided ( x 2 3 4 5 6 )

        real, parameter :: gd1 = -2.283333333333323E+00
        real, parameter :: gd2 =  4.999999999999969E+00
        real, parameter :: gd3 = -4.999999999999964E+00
        real, parameter :: gd4 =  3.333333333333314E+00
        real, parameter :: gd5 = -1.249999999999996E+00
        real, parameter :: gd6 =  2.000000000000000E-01

!.... sixth order one-sided ( x 2 3 4 5 6 7 )

        real, parameter :: ge1 = -2.449999999999916E+00
        real, parameter :: ge2 =  5.999999999999535E+00
        real, parameter :: ge3 = -7.499999999998948E+00
        real, parameter :: ge4 =  6.666666666665405E+00
        real, parameter :: ge5 = -3.749999999999149E+00
        real, parameter :: ge6 =  1.199999999999693E+00
        real, parameter :: ge7 = -1.666666666666202E-01

!.... sixth order one-pt biased ( 1 x 3 4 5 6 7 )

        real, parameter :: gf1 = -1.666666666666662E-01
        real, parameter :: gf2 = -1.283333333333328E+00
        real, parameter :: gf3 =  2.499999999999976E+00
        real, parameter :: gf4 = -1.666666666666632E+00
        real, parameter :: gf5 =  8.333333333333081E-01
        real, parameter :: gf6 = -2.499999999999907E-01
        real, parameter :: gf7 =  3.333333333333190E-02

!.... sixth order two-pt biased ( 1 2 x 4 5 6 7 )

        real, parameter :: gg1 =  3.333333333333335E-02
        real, parameter :: gg2 = -3.999999999999997E-01
        real, parameter :: gg3 = -5.833333333333346E-01
        real, parameter :: gg4 =  1.333333333333335E+00
        real, parameter :: gg5 = -5.000000000000018E-01
        real, parameter :: gg6 =  1.333333333333340E-01
        real, parameter :: gg7 = -1.666666666666675E-02

!=============================================================================!
!.... Second derivatives
!=============================================================================!

!.... third order one-sided ( x 2 3 4 5 )

        real, parameter :: dd1 =  2.916666666666666666667E+00
        real, parameter :: dd2 = -8.666666666666666666667E+00
        real, parameter :: dd3 =  9.500000000000000000000E+00
        real, parameter :: dd4 = -4.666666666666666666667E+00
        real, parameter :: dd5 =  9.166666666666666666667E-01

!.... third order biased difference  ( 1 x 3 4 5 )

        real, parameter :: db1 =  9.166666666666666666667E-01
        real, parameter :: db2 = -1.666666666666666666667E+00
        real, parameter :: db3 =  5.000000000000000000000E-01
        real, parameter :: db4 =  3.333333333333333333333E-01
        real, parameter :: db5 = -8.333333333333333333333E-02

!.... fourth order central difference ( 1 2 x 4 5 )

        real, parameter :: da1 = -8.333333333333333333333E-02
        real, parameter :: da2 =  1.333333333333333333333E+00
        real, parameter :: da3 = -2.500000000000000000000E+00
        real, parameter :: da4 =  1.333333333333333333333E+00
        real, parameter :: da5 = -8.333333333333333333333E-02

!.... fourth order one-sided (assumes f'=0) [not smooth?]

        real, parameter :: dc1 = -5.763888888888888888889E+00
        real, parameter :: dc2 =  8.000000000000000000000E+00
        real, parameter :: dc3 = -3.000000000000000000000E+00
        real, parameter :: dc4 =  8.888888888888888888889E-01
        real, parameter :: dc5 = -1.250000000000000000000E-01

!.... fifth order one-sided ( x 2 3 4 5 6 7 )

        real, parameter :: de1 =  4.511111111110855E+00
        real, parameter :: de2 = -1.739999999999854E+01
        real, parameter :: de3 =  2.924999999999667E+01
        real, parameter :: de4 = -2.822222222221822E+01
        real, parameter :: de5 =  1.649999999999730E+01
        real, parameter :: de6 = -5.399999999999025E+00
        real, parameter :: de7 =  7.611111111109641E-01

!.... fifth order one-pnt biased ( 1 x 3 4 5 6 7 )

        real, parameter :: df1 =  7.611111111111125E-01
        real, parameter :: df2 = -8.166666666666740E-01
        real, parameter :: df3 = -1.416666666666648E+00
        real, parameter :: df4 =  2.611111111111084E+00
        real, parameter :: df5 = -1.583333333333309E+00
        real, parameter :: df6 =  5.166666666666554E-01
        real, parameter :: df7 = -7.222222222222015E-02

!.... fifth order two-pnt biased ( 1 2 x 4 5 6 7 )

        real, parameter :: dg1 = -7.222222222222148E-02
        real, parameter :: dg2 =  1.266666666666662E+00
        real, parameter :: dg3 = -2.333333333333324E+00
        real, parameter :: dg4 =  1.111111111111102E+00
        real, parameter :: dg5 =  8.333333333333835E-02
        real, parameter :: dg6 = -6.666666666666764E-02
        real, parameter :: dg7 =  1.111111111111120E-02

!.... sixth order one-sided ( x 2 3 4 5 6 7 8 )

        real, parameter :: dh1 =  5.211111111107453E+00
        real, parameter :: dh2 = -2.229999999997824E+01
        real, parameter :: dh3 =  4.394999999994423E+01
        real, parameter :: dh4 = -5.272222222214224E+01
        real, parameter :: dh5 =  4.099999999993068E+01
        real, parameter :: dh6 = -2.009999999996367E+01
        real, parameter :: dh7 =  5.661111111100436E+00
        real, parameter :: dh8 = -6.999999999986426E-01

!.... sixth order one-pnt biased ( 1 x 3 4 5 6 7 8 )

        real, parameter :: di1 =  6.999999999999785E-01
        real, parameter :: di2 = -3.888888888887693E-01
        real, parameter :: di3 = -2.700000000000279E+00
        real, parameter :: di4 =  4.750000000000371E+00
        real, parameter :: di5 = -3.722222222222532E+00
        real, parameter :: di6 =  1.800000000000160E+00
        real, parameter :: di7 = -5.000000000000471E-01
        real, parameter :: di8 =  6.111111111111715E-02

!.... sixth order two-pnt biased ( 1 2 x 4 5 6 7 8 )

        real, parameter :: dj1 = -6.111111111110915E-02
        real, parameter :: dj2 =  1.188888888888875E+00
        real, parameter :: dj3 = -2.099999999999959E+00
        real, parameter :: dj4 =  7.222222222221563E-01
        real, parameter :: dj5 =  4.722222222222845E-01
        real, parameter :: dj6 = -3.000000000000333E-01
        real, parameter :: dj7 =  8.888888888889816E-02
        real, parameter :: dj8 = -1.111111111111222E-02

        end module diff

!=============================================================================!
        subroutine grad2 (ndof, nx, ny, v, g11v, g12v, g22v, dx, dy, &
                          optx, opty, xper, yper)
!
!  Take the second derivative of a 2-D field.
!  Updated to sixth order accurate differencing on the interior with
!  the option for optimized fourth order differencing.
!
!=============================================================================!
        use diff
        implicit none

        integer ndof, nx, ny, optx, opty
        logical :: xper, yper
        real v(ny,ndof,nx), g11v(ny,ndof,nx), g12v(ny,ndof,nx)
        real g22v(ny,ndof,nx), g1v(ny,ndof,nx)
        real dx, dy

        real, parameter :: one = 1.0
        real :: dxinv, dyinv, dxsinv, dysinv
        real :: a, b, c, w
        real :: gx1, gx2, gx3, gx4, gx5, gx6
        real :: gy1, gy2, gy3, gy4, gy5, gy6
        real :: dx1, dx2, dx3, dx4, dx5, dx6, dx7
        real :: dy1, dy2, dy3, dy4, dy5, dy6, dy7
!=============================================================================!

        dxinv  = one / dx
        dyinv  = one / dy
        dxsinv = one / dx**2
        dysinv = one / dy**2

!.... seven point stencil in x

        if (optx.eq.0) then
          c = 1.0 / 60.0
        else if (optx.eq.-1) then
          c = 0.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = (w/2.0 - 2.0*Sin(w)/3.0 + Sin(2.0*w)/12.0) / &
              (5.0*Sin(w) - 4.0*Sin(2.0*w) + Sin(3.0*w))
        end if

        a = (2.0 + 15.0 * c) / 3.0
        b = -(1.0 + 48.0 * c) / 12.0

        gx1 =  -c * dxinv
        gx2 =  -b * dxinv
        gx3 =  -a * dxinv
        gx4 =   a * dxinv
        gx5 =   b * dxinv
        gx6 =   c * dxinv

        if (optx.eq.0) then
          c = 1.0 / 90.0
        else if (optx.eq.-1) then
          c = 0.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = -(3.0*w**2 - 16.0*Sin(w/2.0)**2 + Sin(w)**2) / &
               (12.0*(-15.0*Sin(w/2.0)**2 + 6.0*Sin(w)**2 -  &
               Sin(3.0*w/2.0)**2))
        end if

        a = (4.0 + 45.0 * c) / 3.0
        b = -(1.0 + 72.0 * c) / 12.0

        dx1 =  c * dxsinv
        dx2 =  b * dxsinv
        dx3 =  a * dxsinv
        dx4 = -2.0 * ( a + b + c ) * dxsinv
        dx5 =  a * dxsinv
        dx6 =  b * dxsinv
        dx7 =  c * dxsinv

!.... seven point stencil in y

        if (opty.eq.0) then
          c = 1.0 / 60.0
        else if (opty.eq.-1) then
          c = 0.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = (w/2.0 - 2.0*Sin(w)/3.0 + Sin(2.0*w)/12.0) / &
              (5.0*Sin(w) - 4.0*Sin(2.0*w) + Sin(3.0*w))
        end if

        a = (2.0 + 15.0 * c) / 3.0
        b = -(1.0 + 48.0 * c) / 12.0

        gy1 =  -c * dyinv
        gy2 =  -b * dyinv
        gy3 =  -a * dyinv
        gy4 =   a * dyinv
        gy5 =   b * dyinv
        gy6 =   c * dyinv

        if (opty.eq.0) then
          c = 1.0 / 90.0
        else if (opty.eq.-1) then
          c = 0.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = -(3.0*w**2 - 16.0*Sin(w/2.0)**2 + Sin(w)**2) / &
               (12.0*(-15.0*Sin(w/2.0)**2 + 6.0*Sin(w)**2 -  &
               Sin(3.0*w/2.0)**2))
        end if

        a = (4.0 + 45.0 * c) / 3.0
        b = -(1.0 + 72.0 * c) / 12.0

        dy1 =  c * dysinv
        dy2 =  b * dysinv
        dy3 =  a * dysinv
        dy4 = -2.0 * ( a + b + c ) * dysinv
        dy5 =  a * dysinv
        dy6 =  b * dysinv
        dy7 =  c * dysinv

!=============================================================================!
!.... compute the second derivative in x
!=============================================================================!

        if (xper) then

          g11v(:,:,1)       = ( dx1 * v(:,:,nx-3)   + &
                                dx2 * v(:,:,nx-2)   + &
                                dx3 * v(:,:,nx-1)   + &
                                dx4 * v(:,:,1)      + &
                                dx5 * v(:,:,2)   + &
                                dx6 * v(:,:,3)   + &
                                dx7 * v(:,:,4)      )

          g11v(:,:,2)       = ( dx1 * v(:,:,nx-2)   + &
                                dx2 * v(:,:,nx-1)   + &
                                dx3 * v(:,:,1)      + &
                                dx4 * v(:,:,2)      + &
                                dx5 * v(:,:,3)      + &
                                dx6 * v(:,:,4)      + &
                                dx7 * v(:,:,5)      )

          g11v(:,:,3)       = ( dx1 * v(:,:,nx-1)   + &
                                dx2 * v(:,:,1)      + &
                                dx3 * v(:,:,2)      + &
                                dx4 * v(:,:,3)      + &
                                dx5 * v(:,:,4)      + &
                                dx6 * v(:,:,5)      + &
                                dx7 * v(:,:,6)      )

          g11v(:,:,nx-2)    = ( dx1 * v(:,:,nx-5)   + &
                                dx2 * v(:,:,nx-4)   + &
                                dx3 * v(:,:,nx-3)   + &
                                dx4 * v(:,:,nx-2)   + &
                                dx5 * v(:,:,nx-1)   + &
                                dx6 * v(:,:,1)      + &
                                dx7 * v(:,:,2)      )

          g11v(:,:,nx-1)    = ( dx1 * v(:,:,nx-4)   + &
                                dx2 * v(:,:,nx-3)   + &
                                dx3 * v(:,:,nx-2)   + &
                                dx4 * v(:,:,nx-1)   + &
                                dx5 * v(:,:,1)      + &
                                dx6 * v(:,:,2)      + &
                                dx7 * v(:,:,3)   )

          g11v(:,:,nx) = g11v(:,:,1)

        else

          g11v(:,:,1)       = ( dh1 * v(:,:,1) + &
                                dh2 * v(:,:,2) + &
                                dh3 * v(:,:,3) + &
                                dh4 * v(:,:,4) + &
                                dh5 * v(:,:,5) + &
                                dh6 * v(:,:,6) + &
                                dh7 * v(:,:,7) + &
                                dh8 * v(:,:,8) ) * dxsinv

          g11v(:,:,2)       = ( di1 * v(:,:,1) + &
                                di2 * v(:,:,2) + &
                                di3 * v(:,:,3) + &
                                di4 * v(:,:,4) + &
                                di5 * v(:,:,5) + &
                                di6 * v(:,:,6) + &
                                di7 * v(:,:,7) + &
                                di8 * v(:,:,8) ) * dxsinv

          g11v(:,:,3)       = ( dj1 * v(:,:,1) + &
                                dj2 * v(:,:,2) + &
                                dj3 * v(:,:,3) + &
                                dj4 * v(:,:,4) + &
                                dj5 * v(:,:,5) + &
                                dj6 * v(:,:,6) + &
                                dj7 * v(:,:,7) + &
                                dj8 * v(:,:,8) ) * dxsinv

          g11v(:,:,nx-2)   =  ( dj1 * v(:,:,nx) + &
                                dj2 * v(:,:,nx-1) + &
                                dj3 * v(:,:,nx-2) + &
                                dj4 * v(:,:,nx-3) + &
                                dj5 * v(:,:,nx-4) + &
                                dj6 * v(:,:,nx-5) + &
                                dj7 * v(:,:,nx-6) + &
                                dj8 * v(:,:,nx-7)   ) * dxsinv

          g11v(:,:,nx-1)    = ( di1 * v(:,:,nx)   + &
                                di2 * v(:,:,nx-1) + &
                                di3 * v(:,:,nx-2) + &
                                di4 * v(:,:,nx-3) + &
                                di5 * v(:,:,nx-4) + &
                                di6 * v(:,:,nx-5) + &
                                di7 * v(:,:,nx-6) + &
                                di8 * v(:,:,nx-7) ) * dxsinv

          g11v(:,:,nx)      = ( dh1 * v(:,:,nx)   + &
                                dh2 * v(:,:,nx-1) + &
                                dh3 * v(:,:,nx-2) + &
                                dh4 * v(:,:,nx-3) + &
                                dh5 * v(:,:,nx-4) + &
                                dh6 * v(:,:,nx-5) + &
                                dh7 * v(:,:,nx-6) + &
                                dh8 * v(:,:,nx-7) ) * dxsinv
        end if

!.... interior

        g11v(:,:,4:nx-3) = ( dx1 * v(:,:,1:nx-6)   + &
                             dx2 * v(:,:,2:nx-5)   + &
                             dx3 * v(:,:,3:nx-4)   + &
                             dx4 * v(:,:,4:nx-3)   + &
                             dx5 * v(:,:,5:nx-2)   + &
                             dx6 * v(:,:,6:nx-1)   + &
                             dx7 * v(:,:,7:nx  )   )

!=============================================================================!
!.... compute the second derivative in y
!=============================================================================!

        if (yper) then

          g22v(1,:,:)       = ( dy1 * v(ny-3,:,:)   + &
                                dy2 * v(ny-2,:,:)   + &
                                dy3 * v(ny-1,:,:)   + &
                                dy4 * v(1,:,:)      + &
                                dy5 * v(2,:,:)   + &
                                dy6 * v(3,:,:)   + &
                                dy7 * v(4,:,:)      )

          g22v(2,:,:)       = ( dy1 * v(ny-2,:,:)   + &
                                dy2 * v(ny-1,:,:)   + &
                                dy3 * v(1,:,:)      + &
                                dy4 * v(2,:,:)      + &
                                dy5 * v(3,:,:)      + &
                                dy6 * v(4,:,:)      + &
                                dy7 * v(5,:,:)      )

          g22v(3,:,:)       = ( dy1 * v(ny-1,:,:)   + &
                                dy2 * v(1,:,:)      + &
                                dy3 * v(2,:,:)      + &
                                dy4 * v(3,:,:)      + &
                                dy5 * v(4,:,:)      + &
                                dy6 * v(5,:,:)      + &
                                dy7 * v(6,:,:)      )

          g22v(ny-2,:,:)    = ( dy1 * v(ny-5,:,:)   + &
                                dy2 * v(ny-4,:,:)   + &
                                dy3 * v(ny-3,:,:)   + &
                                dy4 * v(ny-2,:,:)   + &
                                dy5 * v(ny-1,:,:)   + &
                                dy6 * v(1,:,:)      + &
                                dy7 * v(2,:,:)      )

          g22v(ny-1,:,:)    = ( dy1 * v(ny-4,:,:)   + &
                                dy2 * v(ny-3,:,:)   + &
                                dy3 * v(ny-2,:,:)   + &
                                dy4 * v(ny-1,:,:)   + &
                                dy5 * v(1,:,:)      + &
                                dy6 * v(2,:,:)      + &
                                dy7 * v(3,:,:)   )

          g22v(ny,:,:) = g22v(1,:,:)

        else

          g22v(1,:,:)      =  ( dh1 * v(1,:,:) + &
                                dh2 * v(2,:,:) + &
                                dh3 * v(3,:,:) + &
                                dh4 * v(4,:,:) + &
                                dh5 * v(5,:,:) + &
                                dh6 * v(6,:,:) + &
                                dh7 * v(7,:,:) + &
                                dh8 * v(8,:,:) ) * dysinv

          g22v(2,:,:)      =  ( di1 * v(1,:,:) + &
                                di2 * v(2,:,:) + &
                                di3 * v(3,:,:) + &
                                di4 * v(4,:,:) + &
                                di5 * v(5,:,:) + &
                                di6 * v(6,:,:) + &
                                di7 * v(7,:,:) + &
                                di8 * v(8,:,:) ) * dysinv

          g22v(3,:,:)       = ( dj1 * v(1,:,:) + &
                                dj2 * v(2,:,:) + &
                                dj3 * v(3,:,:) + &
                                dj4 * v(4,:,:) + &
                                dj5 * v(5,:,:) + &
                                dj6 * v(6,:,:) + &
                                dj7 * v(7,:,:) + &
                                dj8 * v(8,:,:) ) * dysinv

          g22v(ny-2,:,:)    = ( dj1 * v(ny  ,:,:) + &
                                dj2 * v(ny-1,:,:) + &
                                dj3 * v(ny-2,:,:) + &
                                dj4 * v(ny-3,:,:) + &
                                dj5 * v(ny-4,:,:) + &
                                dj6 * v(ny-5,:,:) + &
                                dj7 * v(ny-6,:,:) + &
                                dj8 * v(ny-7,:,:)   ) * dysinv

          g22v(ny-1,:,:)   =  ( di1 * v(ny,:,:)   + &
                                di2 * v(ny-1,:,:) + &
                                di3 * v(ny-2,:,:) + &
                                di4 * v(ny-3,:,:) + &
                                di5 * v(ny-4,:,:) + &
                                di6 * v(ny-5,:,:) + &
                                di7 * v(ny-6,:,:) + &
                                di8 * v(ny-7,:,:) ) * dysinv

          g22v(ny,:,:)     =  ( dh1 * v(ny,:,:)   + &
                                dh2 * v(ny-1,:,:) + &
                                dh3 * v(ny-2,:,:) + &
                                dh4 * v(ny-3,:,:) + &
                                dh5 * v(ny-4,:,:) + &
                                dh6 * v(ny-5,:,:) + &
                                dh7 * v(ny-6,:,:) + &
                                dh8 * v(ny-7,:,:) ) * dysinv

        endif

!.... interior

        g22v(4:ny-3,:,:) = ( dy1 * v(1:ny-6,:,:)   + &
                             dy2 * v(2:ny-5,:,:)   + &
                             dy3 * v(3:ny-4,:,:)   + &
                             dy4 * v(4:ny-3,:,:)   + &
                             dy5 * v(5:ny-2,:,:)   + &
                             dy6 * v(6:ny-1,:,:)   + &
                             dy7 * v(7:ny  ,:,:)   )

!=============================================================================!
!.... compute the cross derivative
!=============================================================================!

        if (xper) then

          g1v(:,:,1)        = ( gx1 * v(:,:,nx-3)       + &
                                gx2 * v(:,:,nx-2)       + &
                                gx3 * v(:,:,nx-1)       + &
                                gx4 * v(:,:,2)  + &
                                gx5 * v(:,:,3)  + &
                                gx6 * v(:,:,4)  )

          g1v(:,:,2)        = ( gx1 * v(:,:,nx-2)       + &
                                gx2 * v(:,:,nx-1)       + &
                                gx3 * v(:,:,1)  + &
                                gx4 * v(:,:,3)  + &
                                gx5 * v(:,:,4)  + &
                                gx6 * v(:,:,5)  )

          g1v(:,:,3)        = ( gx1 * v(:,:,nx-1)       + &
                                gx2 * v(:,:,1)  + &
                                gx3 * v(:,:,2)  + &
                                gx4 * v(:,:,4)  + &
                                gx5 * v(:,:,5)  + &
                                gx6 * v(:,:,6)  )

          g1v(:,:,nx-2)     = ( gx1 * v(:,:,nx-5)       + &
                                gx2 * v(:,:,nx-4)       + &
                                gx3 * v(:,:,nx-3)       + &
                                gx4 * v(:,:,nx-1)       + &
                                gx5 * v(:,:,1)  + &
                                gx6 * v(:,:,2)  )

          g1v(:,:,nx-1)     = ( gx1 * v(:,:,nx-4)       + &
                                gx2 * v(:,:,nx-3)       + &
                                gx3 * v(:,:,nx-2)       + &
                                gx4 * v(:,:,1)  + &
                                gx5 * v(:,:,2)  + &
                                gx6 * v(:,:,3)  )

          g1v(:,:,nx) = g1v(:,:,1)

        else

          g1v(:,:,1)      = ( ge1 * v(:,:,1)  + &
                              ge2 * v(:,:,2)  + &
                              ge3 * v(:,:,3)  + &
                              ge4 * v(:,:,4)  + &
                              ge5 * v(:,:,5)  + &
                              ge6 * v(:,:,6)  + &
                              ge7 * v(:,:,7)  ) * dxinv

          g1v(:,:,2)      = ( gf1 * v(:,:,1)  + &
                              gf2 * v(:,:,2)  + &
                              gf3 * v(:,:,3)  + &
                              gf4 * v(:,:,4)  + &
                              gf5 * v(:,:,5)  + &
                              gf6 * v(:,:,6)  + &
                              gf7 * v(:,:,7)  ) * dxinv

          g1v(:,:,3)      = ( gg1 * v(:,:,1)  + &
                              gg2 * v(:,:,2)  + &
                              gg3 * v(:,:,3)  + &
                              gg4 * v(:,:,4)  + &
                              gg5 * v(:,:,5)  + &
                              gg6 * v(:,:,6)  + &
                              gg7 * v(:,:,7)  ) * dxinv

          g1v(:,:,nx-2)  = -( gg1 * v(:,:,nx)    + &
                              gg2 * v(:,:,nx-1)  + &
                              gg3 * v(:,:,nx-2)  + &
                              gg4 * v(:,:,nx-3)  + &
                              gg5 * v(:,:,nx-4)  + &
                              gg6 * v(:,:,nx-5)  + &
                              gg7 * v(:,:,nx-6)  ) * dxinv

          g1v(:,:,nx-1)  = -( gf1 * v(:,:,nx  )  + &
                              gf2 * v(:,:,nx-1)  + &
                              gf3 * v(:,:,nx-2)  + &
                              gf4 * v(:,:,nx-3)  + &
                              gf5 * v(:,:,nx-4)  + &
                              gf6 * v(:,:,nx-5)  + &
                              gf7 * v(:,:,nx-6)  ) * dxinv

          g1v(:,:,nx)    = -( ge1 * v(:,:,nx  )  + &
                              ge2 * v(:,:,nx-1)  + &
                              ge3 * v(:,:,nx-2)  + &
                              ge4 * v(:,:,nx-3)  + &
                              ge5 * v(:,:,nx-4)  + &
                              ge6 * v(:,:,nx-5)  + &
                              ge7 * v(:,:,nx-6)  ) * dxinv

        end if

!.... interior

        g1v(:,:,4:nx-3)  = ( gx1 * v(:,:,1:nx-6)        + &
                             gx2 * v(:,:,2:nx-5)        + &
                             gx3 * v(:,:,3:nx-4)        + &
                             gx4 * v(:,:,5:nx-2)        + &
                             gx5 * v(:,:,6:nx-1)        + &
                             gx6 * v(:,:,7:nx  )        )

        if (yper) then

          g12v(1,:,:)       = ( gy1 * g1v(ny-3,:,:)     + &
                                gy2 * g1v(ny-2,:,:)     + &
                                gy3 * g1v(ny-1,:,:)     + &
                                gy4 * g1v(2,:,:)        + &
                                gy5 * g1v(3,:,:)        + &
                                gy6 * g1v(4,:,:)        )

          g12v(2,:,:)       = ( gy1 * g1v(ny-2,:,:)     + &
                                gy2 * g1v(ny-1,:,:)     + &
                                gy3 * g1v(1,:,:)        + &
                                gy4 * g1v(3,:,:)        + &
                                gy5 * g1v(4,:,:)        + &
                                gy6 * g1v(5,:,:)        )

          g12v(3,:,:)       = ( gy1 * g1v(ny-1,:,:)     + &
                                gy2 * g1v(1,:,:)        + &
                                gy3 * g1v(2,:,:)        + &
                                gy4 * g1v(4,:,:)        + &
                                gy5 * g1v(5,:,:)        + &
                                gy6 * g1v(6,:,:)        )

          g12v(ny-2,:,:)    = ( gy1 * g1v(ny-5,:,:)     + &
                                gy2 * g1v(ny-4,:,:)     + &
                                gy3 * g1v(ny-3,:,:)     + &
                                gy4 * g1v(ny-1,:,:)     + &
                                gy5 * g1v(1,:,:)        + &
                                gy6 * g1v(2,:,:)        )

          g12v(ny-1,:,:)    = ( gy1 * g1v(ny-4,:,:)     + &
                                gy2 * g1v(ny-3,:,:)     + &
                                gy3 * g1v(ny-2,:,:)     + &
                                gy4 * g1v(1,:,:)        + &
                                gy5 * g1v(2,:,:)        + &
                                gy6 * g1v(3,:,:)        )

          g12v(ny,:,:) = g12v(1,:,:)

        else

          g12v(1,:,:)    = ( ge1 * g1v(1,:,:)  + &
                             ge2 * g1v(2,:,:)  + &
                             ge3 * g1v(3,:,:)  + &
                             ge4 * g1v(4,:,:)  + &
                             ge5 * g1v(5,:,:)  + &
                             ge6 * g1v(6,:,:)  + &
                             ge7 * g1v(7,:,:)  ) * dyinv

          g12v(2,:,:)    = ( gf1 * g1v(1,:,:)  + &
                             gf2 * g1v(2,:,:)  + &
                             gf3 * g1v(3,:,:)  + &
                             gf4 * g1v(4,:,:)  + &
                             gf5 * g1v(5,:,:)  + &
                             gf6 * g1v(6,:,:)  + &
                             gf7 * g1v(7,:,:)  ) * dyinv

          g12v(3,:,:)    = ( gg1 * g1v(1,:,:)  + &
                             gg2 * g1v(2,:,:)  + &
                             gg3 * g1v(3,:,:)  + &
                             gg4 * g1v(4,:,:)  + &
                             gg5 * g1v(5,:,:)  + &
                             gg6 * g1v(6,:,:)  + &
                             gg7 * g1v(7,:,:)  ) * dyinv

          g12v(ny-2,:,:)= -( gg1 * g1v(ny  ,:,:)  + &
                             gg2 * g1v(ny-1,:,:)  + &
                             gg3 * g1v(ny-2,:,:)  + &
                             gg4 * g1v(ny-3,:,:)  + &
                             gg5 * g1v(ny-4,:,:)  + &
                             gg6 * g1v(ny-5,:,:)  + &
                             gg7 * g1v(ny-6,:,:)  ) * dyinv

          g12v(ny-1,:,:)= -( gf1 * g1v(ny  ,:,:)  + &
                             gf2 * g1v(ny-1,:,:)  + &
                             gf3 * g1v(ny-2,:,:)  + &
                             gf4 * g1v(ny-3,:,:)  + &
                             gf5 * g1v(ny-4,:,:)  + &
                             gf6 * g1v(ny-5,:,:)  + &
                             gf7 * g1v(ny-6,:,:)  ) * dyinv

          g12v(ny,:,:)  = -( ge1 * g1v(ny  ,:,:)  + &
                             ge2 * g1v(ny-1,:,:)  + &
                             ge3 * g1v(ny-2,:,:)  + &
                             ge4 * g1v(ny-3,:,:)  + &
                             ge5 * g1v(ny-4,:,:)  + &
                             ge6 * g1v(ny-5,:,:)  + &
                             ge7 * g1v(ny-6,:,:)  ) * dyinv

        end if

!.... interior

        g12v(4:ny-3,:,:) = ( gy1 * g1v(1:ny-6,:,:)      + &
                             gy2 * g1v(2:ny-5,:,:)      + &
                             gy3 * g1v(3:ny-4,:,:)      + &
                             gy4 * g1v(5:ny-2,:,:)      + &
                             gy5 * g1v(6:ny-1,:,:)      + &
                             gy6 * g1v(7:ny  ,:,:)      )

        return
        end

!=============================================================================!
        subroutine grad( ndof, nx, ny, v, g1v, g2v, dx, dy, optx, opty, &
                         xper, yper)
!
!  Take the gradient of a 2-D field.
!  updated to fourth order accurate differencing
!
!=============================================================================!
        use diff
        implicit none

        integer ndof, nx, ny, optx, opty
        logical :: xper, yper
        real v(ny,ndof,nx), g1v(ny,ndof,nx), g2v(ny,ndof,nx)
        real dx, dy

        real,parameter :: one = 1.0
        real dxinv, dyinv
        real a, b, c, w
        real gx1, gx2, gx3, gx4, gx5, gx6
        real gy1, gy2, gy3, gy4, gy5, gy6
!=============================================================================!

        dxinv  = one / dx
        dyinv  = one / dy

!.... seven point stencil in x

        if (optx.eq.0) then
          c = 1.0 / 60.0
        else if (optx.eq.-1) then
          c = 0.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = (w/2.0 - 2.0*Sin(w)/3.0 + Sin(2.0*w)/12.0) / &
              (5.0*Sin(w) - 4.0*Sin(2.0*w) + Sin(3.0*w))
        end if

        a = (2.0 + 15.0 * c) / 3.0
        b = -(1.0 + 48.0 * c) / 12.0

        gx1 =  -c * dxinv
        gx2 =  -b * dxinv
        gx3 =  -a * dxinv
        gx4 =   a * dxinv
        gx5 =   b * dxinv
        gx6 =   c * dxinv

!.... seven point stencil in y

        if (opty.eq.0) then
          c = 1.0 / 60.0
        else if (opty.eq.-1) then
          c = 0.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = (w/2.0 - 2.0*Sin(w)/3.0 + Sin(2.0*w)/12.0) / &
              (5.0*Sin(w) - 4.0*Sin(2.0*w) + Sin(3.0*w))
        end if

        a = (2.0 + 15.0 * c) / 3.0
        b = -(1.0 + 48.0 * c) / 12.0

        gy1 =  -c * dyinv
        gy2 =  -b * dyinv
        gy3 =  -a * dyinv
        gy4 =   a * dyinv
        gy5 =   b * dyinv
        gy6 =   c * dyinv

!=============================================================================!
!.... compute the gradient in x
!=============================================================================!

        if (xper) then

          g1v(:,:,1)        = ( gx1 * v(:,:,nx-3)       + &
                                gx2 * v(:,:,nx-2)       + &
                                gx3 * v(:,:,nx-1)       + &
                                gx4 * v(:,:,2)  + &
                                gx5 * v(:,:,3)  + &
                                gx6 * v(:,:,4)  )

          g1v(:,:,2)        = ( gx1 * v(:,:,nx-2)       + &
                                gx2 * v(:,:,nx-1)       + &
                                gx3 * v(:,:,1)  + &
                                gx4 * v(:,:,3)  + &
                                gx5 * v(:,:,4)  + &
                                gx6 * v(:,:,5)  )

          g1v(:,:,3)        = ( gx1 * v(:,:,nx-1)       + &
                                gx2 * v(:,:,1)  + &
                                gx3 * v(:,:,2)  + &
                                gx4 * v(:,:,4)  + &
                                gx5 * v(:,:,5)  + &
                                gx6 * v(:,:,6)  )

          g1v(:,:,nx-2)     = ( gx1 * v(:,:,nx-5)       + &
                                gx2 * v(:,:,nx-4)       + &
                                gx3 * v(:,:,nx-3)       + &
                                gx4 * v(:,:,nx-1)       + &
                                gx5 * v(:,:,1)  + &
                                gx6 * v(:,:,2)  )

          g1v(:,:,nx-1)     = ( gx1 * v(:,:,nx-4)       + &
                                gx2 * v(:,:,nx-3)       + &
                                gx3 * v(:,:,nx-2)       + &
                                gx4 * v(:,:,1)  + &
                                gx5 * v(:,:,2)  + &
                                gx6 * v(:,:,3)  )

          g1v(:,:,nx) = g1v(:,:,1)

        else

          g1v(:,:,1)      = ( gc1 * v(:,:,1)  + &
                              gc2 * v(:,:,2)  + &
                              gc3 * v(:,:,3)  + &
                              gc4 * v(:,:,4)  + &
                              gc5 * v(:,:,5)  ) * dxinv

          g1v(:,:,2)      = ( gb1 * v(:,:,1)  + &
                              gb2 * v(:,:,2)  + &
                              gb3 * v(:,:,3)  + &
                              gb4 * v(:,:,4)  + &
                              gb5 * v(:,:,5)  ) * dxinv

          g1v(:,:,3)      = ( ga1 * v(:,:,1)  + &
                              ga2 * v(:,:,2)  + &
                              ga3 * v(:,:,4)  + &
                              ga4 * v(:,:,5)  ) * dxinv

          g1v(:,:,nx-2)   = ( ga1 * v(:,:,nx-4)  + &
                              ga2 * v(:,:,nx-3)  + &
                              ga3 * v(:,:,nx-1)  + &
                              ga4 * v(:,:,nx  )  ) * dxinv

          g1v(:,:,nx-1)  = -( gb1 * v(:,:,nx  )  + &
                              gb2 * v(:,:,nx-1)  + &
                              gb3 * v(:,:,nx-2)  + &
                              gb4 * v(:,:,nx-3)  + &
                              gb5 * v(:,:,nx-4)  ) * dxinv

          g1v(:,:,nx)    = -( gc1 * v(:,:,nx  )  + &
                              gc2 * v(:,:,nx-1)  + &
                              gc3 * v(:,:,nx-2)  + &
                              gc4 * v(:,:,nx-3)  + &
                              gc5 * v(:,:,nx-4)  ) * dxinv

        end if

!.... interior

        g1v(:,:,4:nx-3)  = ( gx1 * v(:,:,1:nx-6)        + &
                             gx2 * v(:,:,2:nx-5)        + &
                             gx3 * v(:,:,3:nx-4)        + &
                             gx4 * v(:,:,5:nx-2)        + &
                             gx5 * v(:,:,6:nx-1)        + &
                             gx6 * v(:,:,7:nx  )        )

!=============================================================================!
!.... compute the gradient in y
!=============================================================================!

        if (yper) then

          g2v(1,:,:)        = ( gy1 * v(ny-3,:,:)       + &
                                gy2 * v(ny-2,:,:)       + &
                                gy3 * v(ny-1,:,:)       + &
                                gy4 * v(2,:,:)  + &
                                gy5 * v(3,:,:)  + &
                                gy6 * v(4,:,:)          )

          g2v(2,:,:)        = ( gy1 * v(ny-2,:,:)       + &
                                gy2 * v(ny-1,:,:)       + &
                                gy3 * v(1,:,:)  + &
                                gy4 * v(3,:,:)  + &
                                gy5 * v(4,:,:)  + &
                                gy6 * v(5,:,:)  )

          g2v(3,:,:)        = ( gy1 * v(ny-1,:,:)       + &
                                gy2 * v(1,:,:)  + &
                                gy3 * v(2,:,:)  + &
                                gy4 * v(4,:,:)  + &
                                gy5 * v(5,:,:)  + &
                                gy6 * v(6,:,:)  )

          g2v(ny-2,:,:)     = ( gy1 * v(ny-5,:,:)       + &
                                gy2 * v(ny-4,:,:)       + &
                                gy3 * v(ny-3,:,:)       + &
                                gy4 * v(ny-1,:,:)       + &
                                gy5 * v(1,:,:)  + &
                                gy6 * v(2,:,:)  )

          g2v(ny-1,:,:)     = ( gy1 * v(ny-4,:,:)       + &
                                gy2 * v(ny-3,:,:)       + &
                                gy3 * v(ny-2,:,:)       + &
                                gy4 * v(1,:,:)  + &
                                gy5 * v(2,:,:)  + &
                                gy6 * v(3,:,:)  )

          g2v(ny,:,:)       = g2v(1,:,:)

        else

          g2v(1,:,:)     = ( gc1 * v(1,:,:)     + &
                              gc2 * v(2,:,:)    + &
                              gc3 * v(3,:,:)    + &
                              gc4 * v(4,:,:)    + &
                              gc5 * v(5,:,:)  ) * dyinv

          g2v(2,:,:)     = ( gb1 * v(1,:,:)     + &
                              gb2 * v(2,:,:)    + &
                              gb3 * v(3,:,:)    + &
                              gb4 * v(4,:,:)    + &
                              gb5 * v(5,:,:)  ) * dyinv

          g2v(3,:,:)     = ( ga1 * v(1,:,:)     + &
                              ga2 * v(2,:,:)    + &
                              ga3 * v(4,:,:)    + &
                              ga4 * v(5,:,:)  ) * dyinv

          g2v(ny-2,:,:)  = ( ga1 * v(ny-4,:,:)          + &
                              ga2 * v(ny-3,:,:)         + &
                              ga3 * v(ny-1,:,:)         + &
                              ga4 * v(ny  ,:,:)  )      * dyinv

          g2v(ny-1,:,:) = -( gb1 * v(ny  ,:,:)          + &
                              gb2 * v(ny-1,:,:)         + &
                              gb3 * v(ny-2,:,:)          + &
                              gb4 * v(ny-3,:,:)         + &
                              gb5 * v(ny-4,:,:)  )      * dyinv

          g2v(ny,:,:)   = -( gc1 * v(ny  ,:,:)          + &
                              gc2 * v(ny-1,:,:)         + &
                              gc3 * v(ny-2,:,:)         + &
                              gc4 * v(ny-3,:,:)         + &
                              gc5 * v(ny-4,:,:)  )      * dyinv
        end if

!.... interior

        g2v(4:ny-3,:,:) = ( gy1 * v(1:ny-6,:,:) + &
                             gy2 * v(2:ny-5,:,:)        + &
                             gy3 * v(3:ny-4,:,:)        + &
                             gy4 * v(5:ny-2,:,:)        + &
                             gy5 * v(6:ny-1,:,:)        + &
                             gy6 * v(7:ny  ,:,:)        )

        return
        end

!=============================================================================!
        subroutine g1(v, g1v, nx, dx, optx, xper)
!
!  Take the gradient in the streamwise direction
!  updated to fourth order accurate differencing
!
!=============================================================================!
        use diff
        implicit none

        integer nx, optx
        logical :: xper
        real v(nx), g1v(nx), dx

        real,parameter :: one = 1.0
        real dxinv
        real a, b, c, w
        real gx1, gx2, gx3, gx4, gx5, gx6
!=============================================================================!

        dxinv  = one / dx

!.... seven point stencil in x

        if (optx.eq.0) then
          c = 1.0 / 60.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = (w/2.0 - 2.0*Sin(w)/3.0 + Sin(2.0*w)/12.0) / &
              (5.0*Sin(w) - 4.0*Sin(2.0*w) + Sin(3.0*w))
        end if

        a = (2.0 + 15.0 * c) / 3.0
        b = -(1.0 + 48.0 * c) / 12.0

        gx1 =  -c * dxinv
        gx2 =  -b * dxinv
        gx3 =  -a * dxinv
        gx4 =   a * dxinv
        gx5 =   b * dxinv
        gx6 =   c * dxinv

!=============================================================================!
!.... compute the gradient in x
!=============================================================================!

        if (xper) then

          g1v(1)        = ( gx1 * v(nx-3)       + &
                                gx2 * v(nx-2)   + &
                                gx3 * v(nx-1)   + &
                                gx4 * v(2)      + &
                                gx5 * v(3)      + &
                                gx6 * v(4)      )

          g1v(2)        = ( gx1 * v(nx-2)       + &
                                gx2 * v(nx-1)   + &
                                gx3 * v(1)      + &
                                gx4 * v(3)      + &
                                gx5 * v(4)      + &
                                gx6 * v(5)      )

          g1v(3)        = ( gx1 * v(nx-1)       + &
                                gx2 * v(1)      + &
                                gx3 * v(2)      + &
                                gx4 * v(4)      + &
                                gx5 * v(5)      + &
                                gx6 * v(6)      )

          g1v(nx-2)     = ( gx1 * v(nx-5)       + &
                                gx2 * v(nx-4)   + &
                                gx3 * v(nx-3)   + &
                                gx4 * v(nx-1)   + &
                                gx5 * v(1)      + &
                                gx6 * v(2)      )

          g1v(nx-1)     = ( gx1 * v(nx-4)       + &
                                gx2 * v(nx-3)   + &
                                gx3 * v(nx-2)   + &
                                gx4 * v(1)      + &
                                gx5 * v(2)      + &
                                gx6 * v(3)      )

          g1v(nx) = g1v(1)

        else

          g1v(1)      = ( gc1 * v(1)  + &
                              gc2 * v(2)  + &
                              gc3 * v(3)  + &
                              gc4 * v(4)  + &
                              gc5 * v(5)  ) * dxinv

          g1v(2)      = ( gb1 * v(1)  + &
                              gb2 * v(2)  + &
                              gb3 * v(3)  + &
                              gb4 * v(4)  + &
                              gb5 * v(5)  ) * dxinv

          g1v(3)      = ( ga1 * v(1)  + &
                              ga2 * v(2)  + &
                              ga3 * v(4)  + &
                              ga4 * v(5)  ) * dxinv

          g1v(nx-2)   = ( ga1 * v(nx-4)  + &
                              ga2 * v(nx-3)  + &
                              ga3 * v(nx-1)  + &
                              ga4 * v(nx  )  ) * dxinv

          g1v(nx-1)  = -( gb1 * v(nx  )  + &
                              gb2 * v(nx-1)  + &
                              gb3 * v(nx-2)  + &
                              gb4 * v(nx-3)  + &
                              gb5 * v(nx-4)  ) * dxinv

          g1v(nx)    = -( gc1 * v(nx  )  + &
                              gc2 * v(nx-1)  + &
                              gc3 * v(nx-2)  + &
                              gc4 * v(nx-3)  + &
                              gc5 * v(nx-4)  ) * dxinv

        end if

!.... interior

        g1v(4:nx-3)  = ( gx1 * v(1:nx-6)        + &
                             gx2 * v(2:nx-5)    + &
                             gx3 * v(3:nx-4)    + &
                             gx4 * v(5:nx-2)    + &
                             gx5 * v(6:nx-1)    + &
                             gx6 * v(7:nx  )    )

        return
        end

!=============================================================================!
        subroutine g2(v, g2v, ny, dy, opty, yper)
!
!  Take the gradient in the wall normal direction
!  updated to fourth order accurate differencing
!
!=============================================================================!
        use diff
        implicit none

        integer ny, opty
        logical :: yper
        real v(ny), g2v(ny), dy

        real,parameter :: one = 1.0
        real dyinv
        real a, b, c, w
        real gy1, gy2, gy3, gy4, gy5, gy6
!=============================================================================!

        dyinv  = one / dy

!.... seven point stencil in y

        if (opty.eq.0) then
          c = 1.0 / 60.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = (w/2.0 - 2.0*Sin(w)/3.0 + Sin(2.0*w)/12.0) / &
              (5.0*Sin(w) - 4.0*Sin(2.0*w) + Sin(3.0*w))
        end if

        a = (2.0 + 15.0 * c) / 3.0
        b = -(1.0 + 48.0 * c) / 12.0

        gy1 =  -c * dyinv
        gy2 =  -b * dyinv
        gy3 =  -a * dyinv
        gy4 =   a * dyinv
        gy5 =   b * dyinv
        gy6 =   c * dyinv

!=============================================================================!
!.... compute the gradient in y
!=============================================================================!

        if (yper) then

          g2v(1)       = ( gy1 * v(ny-3)        + &
                                gy2 * v(ny-2)   + &
                                gy3 * v(ny-1)   + &
                                gy4 * v(2)      + &
                                gy5 * v(3)      + &
                                gy6 * v(4)      )

          g2v(2)       = ( gy1 * v(ny-2)        + &
                                gy2 * v(ny-1)   + &
                                gy3 * v(1)      + &
                                gy4 * v(3)      + &
                                gy5 * v(4)      + &
                                gy6 * v(5)      )

          g2v(3)       = ( gy1 * v(ny-1)        + &
                                gy2 * v(1)      + &
                                gy3 * v(2)      + &
                                gy4 * v(4)      + &
                                gy5 * v(5)      + &
                                gy6 * v(6)      )

          g2v(ny-2)    = ( gy1 * v(ny-5)        + &
                                gy2 * v(ny-4)   + &
                                gy3 * v(ny-3)   + &
                                gy4 * v(ny-1)   + &
                                gy5 * v(1)      + &
                                gy6 * v(2)      )

          g2v(ny-1)    = ( gy1 * v(ny-4)        + &
                                gy2 * v(ny-3)   + &
                                gy3 * v(ny-2)   + &
                                gy4 * v(1)      + &
                                gy5 * v(2)      + &
                                gy6 * v(3)      )

          g2v(ny) = g2v(1)

        else

          g2v(1)     = ( gc1 * v(1)  + &
                              gc2 * v(2)  + &
                              gc3 * v(3)  + &
                              gc4 * v(4)  + &
                              gc5 * v(5)  ) * dyinv

          g2v(2)     = ( gb1 * v(1)  + &
                              gb2 * v(2)  + &
                              gb3 * v(3)  + &
                              gb4 * v(4)  + &
                              gb5 * v(5)  ) * dyinv

          g2v(3)     = ( ga1 * v(1)  + &
                              ga2 * v(2)  + &
                              ga3 * v(4)  + &
                              ga4 * v(5)  ) * dyinv

          g2v(ny-2)  = ( ga1 * v(ny-4)  + &
                              ga2 * v(ny-3)  + &
                              ga3 * v(ny-1)  + &
                              ga4 * v(ny  )  ) * dyinv

          g2v(ny-1) = -( gb1 * v(ny  )  + &
                              gb2 * v(ny-1)  + &
                              gb3 * v(ny-2)  + &
                              gb4 * v(ny-3)  + &
                              gb5 * v(ny-4)  ) * dyinv

          g2v(ny)   = -( gc1 * v(ny  )  + &
                              gc2 * v(ny-1)  + &
                              gc3 * v(ny-2)  + &
                              gc4 * v(ny-3)  + &
                              gc5 * v(ny-4)  ) * dyinv

        end if

!.... interior

        g2v(4:ny-3) = ( gy1 * v(1:ny-6) + &
                             gy2 * v(2:ny-5)    + &
                             gy3 * v(3:ny-4)    + &
                             gy4 * v(5:ny-2)    + &
                             gy5 * v(6:ny-1)    + &
                             gy6 * v(7:ny  )    )

        return
        end


! =============================================================================
module random_module

    implicit none

contains

    subroutine init_random_seed()

        implicit none
        integer :: i, n, clock
        integer, dimension(:), allocatable :: seed

        call random_seed(size = n)
        allocate(seed(n))

        call system_clock(count=clock)

        seed = clock + 37 * (/ (i - 1, i = 1, n) /)
        call random_seed(put = seed)

        deallocate(seed)
    end subroutine

end module random_module

! =============================================================================
module preprocessor_module

contains

    subroutine matrix_multiply_preprocessor(A, B, C)

        implicit none

        real(kind=8), intent(in) :: A(:, :), B(:, :)
        real(kind=8), intent(in out) :: C(:, :)

        ! BLAS routine
        external DDOT
        real(kind=8) :: DDOT

        ! Locals
        integer :: i, j, k, N

        N = size(A, 1)

        do i=1,N
            do j=1,N
#ifndef USE_BLAS
                do k=1,N
                    C(i, j) = C(i, j) + A(i, k) * B(k, j)
                enddo
#else
                C(i, j) = DDOT(N, A(i, :), 1, B(:, j), 1)
#endif
            enddo
        enddo

    end subroutine matrix_multiply_preprocessor

end module preprocessor_module

! =============================================================================
module pointer_module

    implicit none

    abstract interface
        subroutine matrix_multiply(A, B, C)
            implicit none
            real(kind=8), intent(in) :: A(:, :), B(:, :)
            real(kind=8), intent(in out) :: C(:, :)
        end subroutine matrix_multiply
    end interface

    abstract interface
        real(kind=8) pure function multiply(a, b) result(c)
            implicit none
            real(kind=8), intent(in) :: a, b
        end function multiply
    end interface

    procedure (matrix_multiply), pointer :: func_matrix_multiply
    procedure (multiply), pointer :: func_multiply

contains

    subroutine set_pointer(method)

        implicit none

        integer, intent(in) :: method

        select case(method)
            case(1)
                func_matrix_multiply => matrix_multiply_non_blas
            case(2)
                func_matrix_multiply => matrix_multiply_blas
        end select
        func_multiply => reg_multiply

    end subroutine set_pointer

    subroutine matrix_multiply_non_blas(A, B, C)

        implicit none
        real(kind=8), intent(in) :: A(:, :), B(:, :)
        real(kind=8), intent(in out) :: C(:, :)

        ! Locals
        integer :: i, j, k, N

        N = size(A, 1)

        do i=1,N
            do j=1,N
                do k=1,N
                    C(i, j) = C(i, j) + func_multiply(A(i, k), B(k, j))
                enddo
            enddo
        enddo

    end subroutine matrix_multiply_non_blas

    subroutine matrix_multiply_blas(A, B, C)

        implicit none

        real(kind=8), intent(in) :: A(:, :), B(:, :)
        real(kind=8), intent(in out) :: C(:, :)

        ! BLAS routine
        external DDOT
        real(kind=8) :: DDOT

        ! Locals
        integer :: i, j, N

        N = size(A, 1)

        do i=1,N
            do j=1,N
                C(i, j) = DDOT(N, A(i, :), 1, B(:, j), 1)
            enddo
        enddo

    end subroutine matrix_multiply_blas

    real(kind=8) pure function reg_multiply(a, b) result(c)
        implicit none
        real(kind=8), intent(in) :: a, b

        c = a * b
    end function reg_multiply

end module pointer_module

! =============================================================================
!  Test for if-statements to set methods
module branching_module

    implicit none

contains

    subroutine matrix_multiply_branching(A, B, C, method)

        implicit none

        real(kind=8), intent(in) :: A(:, :), B(:, :)
        real(kind=8), intent(in out) :: C(:, :)
        integer, intent(in) :: method

        ! BLAS routine
        external DDOT
        real(kind=8) :: DDOT

        ! Locals
        integer :: i, j, k, N

        N = size(A, 1)

        do i=1,N
            do j=1,N
                if (method == 1) then
                    do k=1,N
                        C(i, j) = C(i, j) + A(i, k) * B(k, j)
                    enddo
                else if (method == 2) then
                    C(i, j) = DDOT(N, A(i, :), 1, B(:, j), 1)
                end if
            enddo
        enddo

    end subroutine matrix_multiply_branching

end module branching_module

! =============================================================================
!  Main code
program plugin_test

    use random_module
    use preprocessor_module
    use pointer_module, only: func_matrix_multiply, set_pointer
    use branching_module

    implicit none

    integer :: N, M
    character(len=10) :: input

    integer :: i,j
    real(kind=8), allocatable :: A(:, :), B(:, :), C(:, :)
    integer(kind=8) :: start, finish, count_rate
    real(kind=8) :: time

    N = 100
    M = 100
    if (iargc() == 1) then
        call getarg(1, input)
        read(input, '(i10)') N
    else if (iargc() == 2) then
        call getarg(1, input)
        read(input, '(i10)') N
        call getarg(2, input)
        read(input, '(i10)') M
    end if

    ! Construct random matrices
    call init_random_seed()
    allocate(A(N, N), B(N, N), C(N, N))
    call random_number(A)
    call random_number(B)

    print '("Using",i5," x",i5," matrices")', N, N
    print '("Running each function",i8," times.")', M

    C = 0.0
    call system_clock(start, count_rate)
    do j=1, M
        call matrix_multiply_preprocessor(A, B, C)
    end do
    call system_clock(finish, count_rate)

    time = float(finish - start) / float(count_rate)
#ifndef USE_BLAS
    print '("Preprocessor 1: ",f16.10," s")', time
#else
    print '("Preprocessor 2: ",f16.10," s")', time
#endif

    do i=1, 2
        C = 0.0
        call system_clock(start, count_rate)
        call set_pointer(i)
        do j=1, M
            call func_matrix_multiply(A, B, C)
        end do
        call system_clock(finish, count_rate)

        time = float(finish - start) / float(count_rate)
        print '("Pointer ",i1,": ",f16.10," s")', i, time
    end do

    C = 0.0
    call system_clock(start, count_rate)
    do j=1, M
        call matrix_multiply_branching(A, B, C, 1)
    end do
    call system_clock(finish, count_rate)

    time = float(finish - start) / float(count_rate)
    print '("Branching 1: ",f16.10," s")', time

    C = 0.0
    call system_clock(start, count_rate)
    do j=1, M
       call matrix_multiply_branching(A, B, C, 2)
    end do
    call system_clock(finish, count_rate)

    time = float(finish - start) / float(count_rate)
    print '("Branching 2: ",f16.10," s")', time

end program plugin_test


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

! 2d int array, maxloc with dim, and back

program main
  integer :: res(4)
  integer, dimension(3,4) :: array
  integer :: expect(4)
  array = reshape((/4,3,-1,0,1,-4,5,-2,5,2,6,5/),shape(array))
  res = maxloc(array, dim = 1, back=.true.)
  expect = (/1,2,3,2/)
  call check(res, expect, 4)
  !print *, "base=true:", res
  res = maxloc(array, dim = 1, back=.false.)
  expect = (/1,2,1,2/)
  call check(res, expect, 4)
  !print *, "back=false:", res
end


! Check that parameters are correct intercepted.
! Constants with comma separations are commonly
! used, for instance Pi = 3._dp
subroutine foo_single(x)
  implicit none
  integer, parameter :: rp = selected_real_kind(6)
  real(rp), intent(inout) :: x
  dimension x(3)
  real(rp), parameter :: three = 3._rp
  x(1) = x(1) + x(2) + x(3) * three
  return
end subroutine

subroutine foo_double(x)
  implicit none
  integer, parameter :: rp = selected_real_kind(15)
  real(rp), intent(inout) :: x
  dimension x(3)
  real(rp), parameter :: three = 3._rp
  x(1) = x(1) + x(2) + x(3) * three
  return
end subroutine


program n_body_test
    use n_bodies
    implicit none
    integer(8), parameter :: n = 2, n_times = 100000
    real :: q = 1e-3
    real(8), dimension(n) :: masses
    real(8), dimension(n, 3) :: i_positions, i_velocities, poses, vels
    real(8), dimension(n_times, n, 3) :: velocities, positions
    real(8), dimension(n_times) :: times
    real(8) :: dt, t_tot, g, tolerance
    logical :: update_com
    character(256) :: status
    integer(8) :: i, j, k, q_dt
    masses = (/1. - q, q/)
    i_positions(1, :) = (/-q, 0., 0./)
    i_positions(2, :) = (/1. - q, 0., 0./)
    i_velocities(1, :) = (/0., -q, 0./)
    i_velocities(2, :) = (/0., 1. - q, 0./)
    dt = 1e-3
    t_tot = n_times * dt
    tolerance = 1e-10
    q_dt = 4
    g = 1.
    update_com = .true.

    print *, "Euler"
    call n_body_model("euler", n, n_times, masses, i_positions, i_velocities, &
                      t_tot, dt, g, update_com, times, positions, velocities, &
                      status)
    print *, status

    print *, "RK5"
    call n_body_model("rk5", n, n_times, masses, i_positions, i_velocities, &
                  t_tot, dt, g, update_com, times, positions, velocities, &
                  status)
    print *, status
!
    print *, "RKF45"
    status = "Ok"
    call adaptive_n_body_model("rkf45", n, n_times, masses, i_positions, &
            i_velocities, t_tot, tolerance, dt, q_dt, g, update_com, times, &
            positions, velocities, status)
    print *, status
!    do i=1, n_times
!        print *, positions(i, 2, :)
!    end do

end program n_body_test


program stop
implicit none
integer :: x
x = (2+3)*5
if (x == 25) stop
end program


module orrsomm

implicit none
public
save

integer :: n_re_d, n_alphastar, i_re_d, j_alphastar
complex*16, allocatable, dimension(:) :: uvec,vvec,wvec
real, allocatable, dimension(:) :: alphastar,re_d,enr1,enr2,grow1,grow2
real :: avgdedt,dedterr,avgerr
complex*16 :: omega

contains

subroutine set_linstab_param()
    ! sets up the parameter space for linear stability test
    use mpicom, only: myid
    use runparam, only: astar
    use parameters, only: x0, cguess, xnu, u0
    ! explore Re #s just below and above Re_c
    re_d(i_re_d) = 1805. + (i_re_d-1)*3000./(n_re_d-1)
    ! explore a* just below and above critical region
    alphastar(j_alphastar) = 0.5 + (j_alphastar-1)*.7/(n_alphastar-1)
    ! adjust relevant qties
    x0 = re_d(i_re_d)**2*xnu/(6.02**2*u0)
    astar = alphastar(j_alphastar)
    cguess = cmplx( 0.4 - (i_re_d-1)*0.1/(n_re_d-1)  , 0.0)

    if (myid==0) write(*,*) 'Re_d = ',re_d(i_re_d), ', x0 =', x0, ', astar =', astar, ', cguess =', cguess

end subroutine set_linstab_param

subroutine add_linstab_perturb(uf,vf,wf)
    ! adds more unstable mode from linear stability theory to velocities
    use dim
    use flags, only: debug
    use io
    use mpicom, only: myid
    use grid, only: wavx
    ! i/o
    real, dimension(nxpl,ny,nzpl), intent(inout) :: uf,vf,wf

    ! add most unstable mode to initial velocities
    if (wavx(1)==0.) then
        uf(3,1,:) = uf(1,1,:) + real(uvec(:))
        uf(4,1,:) = uf(2,1,:) + aimag(uvec(:))
        vf(3,1,:) = vf(1,1,:) + real(vvec(:))
        vf(4,1,:) = vf(2,1,:) + aimag(vvec(:))
        wf(3,1,:) = wf(1,1,:) + real(wvec(:))
        wf(4,1,:) = wf(2,1,:) + aimag(wvec(:))
    endif
    ! print perturbation for debugging
    if (debug>=1) then
        if (myid==0) write(*,'(//,A)') '-------- orr-sommerfeld perturbation --------'
        call printuvw(uf,vf,wf)
    end if
    deallocate( uvec, vvec, wvec )

end subroutine add_linstab_perturb

subroutine write_linstab_results(nsteps)
    ! write energy growth rate and corresponding theoretical prediction to file
    use flags, only: debug
    use runparam, only: linstab
    use parameters, only: x0, xnu, u0
    use grid, only: alpha
    use iofiles
    use time, only: tseries
    use mpicom, only: myid
    ! i/o
    integer, intent(in) :: nsteps
    ! local vars
    integer :: i

    avgdedt = sum(grow2)/(nsteps-1) ! avg energy growth/decay
    avgerr = abs( (avgdedt - aimag(omega))/aimag(omega) )*100.0

    if (myid==0) then
        if (debug>=1) then
            write(*,'(//,A)') '---------- Linear Stability Results ------------'
            write(*,'(2(A,G12.4,'',''))') 're_d = ',6.02*sqrt(x0*xnu/u0)*u0/xnu,'alpha* = ',alpha
            write(*,*) 'i, energy, dEtotal/dt, dEnomean/dt'
            do i=1,nsteps
                write(*,'(I5,'','',3(G14.6,'',''))') i, enr2(i), grow1(i), grow2(i)
            end do
            write(*,*) 'omega_i, < dE/dt >, < % error >'
            write(*,'(3(G14.6,'',''))') aimag(omega), avgdedt, avgerr
        end if

        if (linstab==2) then
            if (i_re_d==1 .and. j_alphastar==1) then
                open(unit=iunit_energy,file=energy_file,status='unknown')
                write(iunit_energy,*) 'R, alpha*, omega_i, < dE/dt >, < % error >,'
            end if
            write(iunit_energy,'(5(G14.6,'',''))') re_d(i_re_d),alphastar(j_alphastar),aimag(omega), avgdedt, avgerr

            if (i_re_d==n_re_d .and. j_alphastar==n_alphastar) then
                close(iunit_energy)
                deallocate( alphastar,re_d,enr1,enr2,grow1,grow2 )
            end if
        end if

    end if

end subroutine write_linstab_results

subroutine solve_orrsomm(uvec,vvec,wvec,eps,alphax,betax,omega,iglb)
    ! solves the Orr-Sommerfeld equation for the most unstable mode
    ! everything is non-dimensionalized by the boundary layer thickness
    ! so Reynolds # = 1/nu (assuming u0 = 1.).
    ! This should also affect derivatives... multiply by BL thickness
    use dim
    use parameters, only: xnu
    use paral !, only: ubar
    use grid, only: zpts
    use mats !, only: dor
    use mpicom, only: myid
    use flags, only: debug
    use prng
    ! i/o
    complex*16, dimension(nzp), intent(out) :: uvec, vvec, wvec
    complex*16, intent(inout) :: omega
    real, intent(in) :: eps, alphax, betax
    integer, intent(in) :: iglb
    ! local vars
    real, allocatable, dimension(:,:) :: did, d3, d4 !,d2
    complex*16, allocatable, dimension(:,:) :: a, b, aa, bb, c, ck, ckp1, btrans
    complex*16, allocatable, dimension(:) :: rhs_phi, rhs_gam, residualk, residualkp1
    real, allocatable, dimension(:) ::  reig, aeig !,ubarp, ubarpp
!     complex, allocatable, dimension(:,:) :: fic, fic1, fic2, fic3, ficb, ficb1, ficb2, ficb3
    integer :: i, ii, j, k, iter, iiter, AllocateStatus
    real :: c01, c02, c03, c04 ! only used for membrane bottom wall
    real :: rey, wav2, dmag, etot, xnorm, residualk_norm, residualkp1_norm, inner_rk_norm, inner_rkp1_norm
    complex*16 :: omk, omkp1
    ! local vars req'd for LAPACK
    character*1 :: balanc, jobvl, jobvr, sense, trans
    integer :: n, info, lwork, lrwork, lda, ldb, ldvl, ldvr, ilo, ihi
    integer, allocatable, dimension(:) :: iwork
    logical, allocatable, dimension(:) :: bwork
    double precision :: abnrm, bbnrm
    complex*16, allocatable, dimension(:,:) ::   vl, vr
    complex*16, allocatable, dimension(:) :: phi, gam, phikp1, gamkp1, work
    double precision, allocatable, dimension(:) :: lscale, rscale, rconde, rcondv
    real, allocatable, dimension(:) :: rwork
    integer, allocatable, dimension(:) :: ipiv
    ! rigid wall parameters
    ! (not needed if you change dimensions of the main arrays
    !    (A and B) to A(NZP,NZP) and B(NZP,NZP))
    ! [for special version of linear with kaplan membrane wall boundary cond.
    !    C01 = D/M       C02 = 1/M       C03 = K/M        C04 = T/M ]
    c01 = 1.e-40
    c02 = 1.e-40
    c03 = 1.e-40
    c04 = 1.e-40
    ! set size of problem for the remainder of orr-sommerfeld solver
    n = nzpp2 ! for membrane bottom wall
!     n = nzp
    ! Reynolds number and square of the wavenumber.
    ! [for 2-D problem betax is zero (wavenumber in y-direction)]
    rey = 1./xnu
    wav2 = alphax**2.0 + betax**2.0
    ! allocate and zero a and b
    allocate( did(nzp,nzp), d3(nzp,nzp), d4(nzp,nzp), a(n,n), b(n,n), c(n,n), stat=AllocateStatus )
!     allocate( ubarp(nzp), ubarpp(nzp), d2(nzp,nzp),  stat=AllocateStatus )
    if (AllocateStatus /= 0) then
        write(*,*) "**Not Enough Memory - solve_orrsomm array allocation **"
    end if
    a = 0.; b = 0;
    ! identity matrix
    did = 0.0
    do i=1,nzp
        did(i,i) = 1.
    end do
    ! calculate higher derivatives in vertical
!     d2 = matmul(dor,dor)
!     d3 = matmul(dor,d2)
    d4 = matmul(d2,d2)
!     ubarp = matmul(dor,ubar)
!     ubarpp = matmul(d2,ubar)
    ! We set the Orr-Sommerfeld equation here
    ! in a form A*psi = omega B*psi where
    ! psi is a streamfunction and omega is a complex
    ! eigenvalue omega=c*alphax. See any book on
    ! Orr-Sommerfeld eq.
    if (iglb<=0) then
        do j=1,nzp
            do i=1,nzp
                a(i,j) = d4(i,j) - 2.0*wav2*d2(i,j) + wav2*wav2*did(i,j) - (0.0,1.)*alphax*rey*(ubar(i)*( d2(i,j) - wav2*did(i,j) ) - ubarpp(i)*did(i,j))
                b(i,j) = -(0.0,1.)*rey*( d2(i,j) - wav2*did(i,j) )
            end do
        end do
        ! boundary conditions will need to be changed for channel
        ! flow. I think they should be A(1,1)=1, A(1,J)=0, B(1,J)=0
        ! (this gives psi=0 at the upper wall); A(2,J)=D(1,J), B(2,J)=0
        ! (this gives d psi/dz =0 at the upper wall); and corresponding
        ! conditions at the lower wall: A(NZP,NZP)=1, A(NZP,J)=0, B(NZP,J)=0;
        ! and A(NZ,J)=D(NZP,J),B(NZ,J)=0.0
        ! boundary conditions for Blasius/boundary layer flow (same as channel flow)
        ! psi = phi(z)*exp(i*(alpha*x - beta*t))
        ! u' = d psi /dz, w' = d psi /dx
        ! u' = w' = du'/dz = dw'/dz = 0 as z -> infty ==> psi = 0, d psi/dz = 0
        ! u' = w' = 0 at z = 0 ==> psi = 0, d psi/dz = 0

        ! boundary conditions for rigid wall boundary layer flow
        ! psi(z=0) = 0 -> A(nzp,1) = 1, A(nzp,2:) = 0, B(nzp,:) = 0.0
        ! psi(z=infty) = 0 -> A(1,1) = 1, A(1,2:) = 0, B(1,:) = 0.0
        ! D psi(z=0) = 0 -> A(nzpp,1:nzp) = D(nzp,1:nzp), B(nzpp,:) = 0.0
        ! D psi(z=infty) -> A(nzpp2,1:nzp) = D(1,1:nzp), B(nzpp2,:) = 0.0
        ! matrix A and B are now size (nzpp2,nzp) ? overdetermined!
        ! so try channel flow BCs instead
!         a(1,:) = 0.0
!         a(1,1) = 1.
!         b(1,:) = 0.0
!         a(2,:) = d(1,:)
!         b(2,:) = 0.0
!         a(nzpp,:) = 0.0
!         a(nzpp,nzpp) = 1.
!         b(nzpp,:) = 0.0
!         a(nzpp2,1:nzp) = d(nzp,1:nzp)
!         b(nzpp2,:) = 0.0

        ! boundary conditions appropriate for kaplan membrane wall below
        do j=1,nzp
            a(n,j) = 0.0
            do k=1,nzp
                a(n,j) = a(n,j) - (0.0,1.)*c01/(alphax*rey)*d2(nzp,k)*d(k,j)
            end do
        end do
        do j=1,n
            b(1,j) = 0.0
            b(2,j) = 0.0
            b(3,j) = 0.0
            b(n-1,j) = 0.0
            b(n,j) = 0.0
            a(1,j) = 0.0
            a(3,j) = 0.0
            a(n-1,j) = 0.0
        end do
        do j=1,nzp
            a(2,j) = d(nzp,j)
        end do
        a(1,1) = 1.0
        a(3,nzp) = 1.0
        b(3,n-1) = 1.0/alphax
        a(2,n-1) = ubarp(nzp)
        a(2,n) = 0.0
        a(n-1,n) = (1., 0.)
        b(n-1,n-1) = (0.0,-1.)
        a(n,n-1) = c03 + c04*wav2 - (0.0,1.)*wav2*(c02/rey)*(ubarp(nzp)/alphax)
        a(n,n) = c01
        b(n,n) = (0.0,1.)

        if (iglb<0) then
            ! solve for ALL eigenvalues, but only need one with the highest growth rate
            ! or lowest damping c_i
            ! setup input for LAPACK ZGGEV which calculates eigenvalues,
            ! and eigenvectors for problem A v = lamda*B v
            balanc = 'N'
            jobvl = 'N'
            jobvr = 'V'
            sense = 'N'
            lda = n
            ldb = n
            ldvl = n
            ldvr = n
            lwork = 4*n
            lrwork = 8*n
            allocate( aa(n,n), bb(n,n), reig(n), aeig(n), phi(n), gam(n), vl(ldvl,n), vr(ldvr,n), work(lwork), rwork(lrwork), stat=AllocateStatus )
            allocate( iwork(n+2), bwork(n), rconde(n), rcondv(n), lscale(n), rscale(n),  stat=AllocateStatus )
            if (AllocateStatus /= 0) then
                write(*,*) "**Not Enough Memory - solve_orrsomm_zggevx array allocation **"
            end if

            aa = a
            bb = b
!             call zggev( jobvl, jobvr, n, c, lda, b, ldb, phi, gam, vl, ldvl, vr, ldvr, work, lwork, rwork, info )
            call zggevx( balanc, jobvl, jobvr, sense, n, aa, lda, bb, ldb, phi, gam, vl, ldvl, vr, ldvr,  ilo,  ihi,  lscale,  rscale, abnrm, bbnrm, rconde, rcondv, work, lwork, rwork, iwork, bwork, info )
            if (info/=0 .and. myid==0) write(*,'(//,A,I5)') 'zggev error: info=',info

            reig = real(phi)
            aeig = aimag(phi)
            do k=1,n
                if (abs(gam(k))>0.) then
                    reig(k) = reig(k) / abs(gam(k))
                    aeig(k) = aeig(k) / abs(gam(k))
                end if
!                 if (real(gam(k))>0.) reig(k) = reig(k)/real( gam(k) )
!                 if (aimag(gam(k))>0.)    aeig(k) = aeig(k)/aimag( gam(k) )
            end do

            ! print eigenvalues to screen
            if (myid==0) then
                write(*,'(//,A)') '---- eigenvalues from Orr-Sommerfeld equation ----'
                write(*,*) 'number, omega real, omega imag, c real, c imag'
                do k=1,n
!                     write(*,'(I5,'','',4(G14.6,'',''))') k, reig(k), aeig(k), reig(k)/alphax, aeig(k)/alphax
                    write(*,'(I5,'','',6(G14.6,'',''))') k, phi(k), gam(k), reig(k)/alphax, aeig(k)/alphax
                end do
            end if

            ! find min value of omega and its location
            j = maxloc(aeig/alphax, 1, reig/alphax>0 .and. reig/alphax<0.42)
!             omega = phi(j) / gam(j)
            ! corresponding eigenvector
!             wvec = 0.0
!             wvec(1:nzp) = vr(:,j)

            ! print normalized eigen vector
            if (myid==0 .and. debug>=2) then
                write(*,'(//,A,2G13.6)') 'most unstable c', reig(j)/alphax,aeig(j)/alphax
                write(*,'(A)') 'eigenvector from zggevx (streamfunction) real, imag'
                write(*,'(2(G14.6,'',''))') vr(1:n,j)
            end if

            deallocate( aa, bb, reig, aeig, phi, gam, vl, vr, work, rwork )
            deallocate( iwork, bwork, rconde, rcondv, lscale, rscale )

        end if ! (iglb < 0)

        ! calculate most unstable mode of Orr-Sommerfeld eqn iteratively
        if (myid==0) then
            write(*,'(//,A)') '---- solving for most unstable eigenvalue & mode iteratively ----'
            write(*,*) 'iteration, omega real, omega imag, cr, ci'
        end if

        iiter = 10    ! max outer loop # of iterations
        iter = 10    ! max inner loop # of iterations
!         n = n    ! dimension for LU decomp zgetrf
        lda = n     ! leading dimension of first input matrix for zgetrf
        ldb = n     ! leading dimension of input vector for zgetrs
        lwork = n     ! size of work array for forward/backward substitution
        ! allocate local vars
        allocate( residualk(n), residualkp1(n), reig(n), aeig(n), ck(n,n), ckp1(n,n), phi(n), gam(n), phikp1(n), gamkp1(n), btrans(n,n), rhs_phi(n), rhs_gam(n), ipiv(n), work(lwork) )
        ! set initial omega guess to input omega
        omk = omega
        ! set initial guess for eigenvectors to be [1,1,1,...,1]
        phi = 1.0
        gam = 1.0
        ! set initial guess to a random vector
!         call init_random_seed(n)
!         call random_number(reig)
!         call init_random_seed(n)
!         call random_number(aeig)
!         phi = reig + (0.0,1.)*aeig
!         phi = phi / sum(abs(phi))
!         gam = conjg(phi)
!         btrans = transpose(b)
        btrans = conjg(transpose(b))

        do i=1,iiter ! outer loop

            ck = a - omk*b ! form LHS matrix - unchanged during inner loop
!             ck = a ! form LHS matrix - unchanged during inner loop
            residualk = matmul(ck,phi) ! residual
            residualk_norm = sum(abs(residualk)) ! norm of residualk
            c = ck ! copy of ck which will be factorized
            call zgetrf( n, n, c, lda, ipiv, info ) ! LU decomp of matrix c stored into c
            if (info/=0 .and. myid==0) write(*,'(//,A,I5)') 'zgetrf error: info=',info

            do ii=1,iter ! inner loop

                inner_rk_norm = sum( abs( matmul(ck,phi)) )

                ! solve (A - omk*B)*phi^k+1 = B*phi^k for phi^k+1
                rhs_phi = matmul(b,phi) ! RHS = B*phi
!                 rhs_phi = matmul(omk*b,phi) ! RHS = B*phi
                trans = 'N'
                call zgetrs( trans, n, 1, c, lda, ipiv, rhs_phi, ldb, info )
                if (info/=0 .and. myid==0) write(*,'(//,A,I5)') 'zgetrs error: info=',info

                ! solve (A- omk*B)^H*gam^k+1 = B^H*gam^k for gam^k+1
                rhs_gam = matmul(btrans,gam) ! RHS = B^H*gam
!                 rhs_gam = matmul(omk*btrans,gam) ! RHS = B^H*gam
!                 trans = 'T'
                trans = 'C'
                call zgetrs( trans, n, 1, c, lda, ipiv, rhs_gam, ldb, info )
                if (info/=0 .and. myid==0) write(*,'(//,A,I5)') 'zgetrs error: info=',info

                ! normalize and store solns rhs_phi & rhs_gam into phikp1 and gamkp1
!                 rhs_gam(1) = 0.0
!                 rhs_phi(1) = 0.0
                phikp1 = rhs_phi/sum(abs(rhs_phi))
                gamkp1 = rhs_gam/sum(abs(rhs_gam))
!                 phi(1) = 0.0
!                 gam(1) = 0.0

                inner_rkp1_norm = sum( abs( matmul(ck,phikp1) ) )

                ! convergence check
                if ( sum(abs(phikp1-phi))<5.E-5 .or. inner_rkp1_norm < 5.E-6 ) then
                    ! check if previous answer was better and if so use it
                    if (inner_rkp1_norm > inner_rk_norm) then
                        phikp1 = phi
                        gamkp1 = gam
                    end if
                    phi = phikp1
                    gam = gamkp1
                    ! print that convergence was reached
                    if (myid==0 .and. debug>=1) then
                        write(*,*) 'inner loop convergence reached at ii =',ii
                        write(*,*) '|R_inner| = ', inner_rkp1_norm
                    end if
                    exit
                end if

                ! check for bad starting guess
                if (inner_rkp1_norm >= inner_rk_norm .and. ii<iiter-1) then
                    ! start over with new starting guess
                    if (myid==0 .and. debug>=1) then
                        write(*,*) 'bad eigenvector guess detected at ii =',ii
                        write(*,'(2(A,G17.10,'',''))') '|R_inner^k| =', inner_rk_norm, '|R_inner^k+1| =', inner_rkp1_norm
                    end if
                    k = n
                    reig = 0.0; aeig = 0.0
                    call init_random_seed(k)
                    call random_number(reig)
                    call init_random_seed(k)
                    call random_number(aeig)
                    phikp1 = phi + 0.001*(reig + (0.0,1.)*aeig)
                    phikp1 = phikp1 / sum(abs(phikp1))
                    gamkp1 = gam + 0.001*(reig + (0.0,1.)*aeig)
                    gamkp1 = gamkp1 / sum(abs(gamkp1))
                end if

                ! update phi and gam
                phi = phikp1
                gam = gamkp1

             end do ! inner loop

             ! update eigenvalue omega
            rhs_phi = matmul(b,phikp1) ! B*phi^k+1
            rhs_gam = matmul(a,phikp1) ! A*phi^k+1
            ! omega^k+1 = gam^k+1 * (A * phi^k+1) / ( gam^k+1 (B * phi^k+1) )
            omkp1 = dot_product(gamkp1,rhs_gam)/dot_product(gamkp1,rhs_phi)

            ! write results
            if (myid==0) write(*,'(I5,'','',4(G17.10,'',''))') i*iter, omkp1, omkp1/alphax
            ! normalize phikp1, again?!
!             dmag = sum(abs(phikp1))
!             gamkp1 = gamkp1 / dmag
!             phikp1 = phi / dmag
            ! normalize and sign eigenvector based on largest abs value for printing
            dmag = maxval(abs(phikp1))
            k = maxloc(abs(phikp1),1)
            dmag = sign( dmag, real( phikp1(k) ) )
            ! print normalized eigen vector
            if (myid==0 .and. debug>=2) then
                write(*,'(//,A)') 'normalized eigenvector (streamfunction) real, imag'
                write(*,'(65(2(G14.6,'',''),/))') phikp1(1:nzp)!/dmag !conjg(phi(1:n))/dmag
            end if

            ! calculate residual^k+1
            ckp1 = a - omkp1*b
            residualkp1 = matmul(ckp1,phikp1)
            residualkp1_norm = sum(abs(residualkp1))

            ! write new residual at each outer iteration
            if (myid==0 .and. debug>=1) write(*,'(//,2(A,G17.10,'',''),//)') '|R^k| =', residualk_norm, '|R^k+1| =', residualkp1_norm

            ! convergence check
            if (abs(omkp1 - omk) < 1.E-14 .and. residualkp1_norm < 1.5E-6) then
                if (residualkp1_norm >= residualk_norm) then
                    omkp1 = omk
                    phikp1 = phi
                    gamkp1 = gam
                end if
                if (myid==0) write(*,*) 'outer convergence reached at i =',i*iter
                exit
            end if

            ! check for bad guess or bad behavior
            if (abs(omkp1 - omk) < 1.E-14 .and. residualkp1_norm > 1.5E-6) then
                if (myid==0 .and. debug>=1) write(*,*) 'bad initial omega guess detected at i =',i*iter
                k = 1
                call init_random_seed(k)
                call random_number(reig(k))
                omkp1 = (0.3 + 0.1*reig(k))*alphax
                if (myid==0) write(*,*) 'try with new omega guess =',omkp1
            end if

            ! write(*,*) oscillations
            if (residualkp1_norm >= residualk_norm) then
                if (myid==0 .and. debug>=1) write(*,*) 'regression detected & avoided at i =',i*iter
                omkp1 = omk
                phikp1 = phi
                gamkp1 = gam
            end if

            ! update omega
            omk = omkp1

        end do ! outer loop

        omega = omkp1

        ! normalize eigenvector (mode)
!         dmag = 0.0
!         do k=1,nzp
!             if (abs(phi(k)) > abs(dmag)) then
!                 dmag = abs(phi(k))
!                 dmag = sign( dmag, real(phi(k)) )
!             end if
!         end do
!         ! print normalized eigen vector
!         if (myid==0 .and. debug>=1) then
!             write(*,'(//,A)') 'normalized eigenvector (streamfunction) real, imag'
!             write(*,'(2(G14.6,'',''))') phi(1:n)/dmag !conjg(phi(1:n))/dmag
!         end if

        ! wvec = streamfunction psi
        wvec = 0.0
        wvec(1:nzp) = phikp1(1:nzp)
!         wvec = phi(2:nz)
!         wvec = aimag(phi(1:nzp)) + (0.0,1.)*real(phi(1:nzp))
!         wvec(1:nzp) = phi(2:n-1)
!         wvec(2:nzp) = phi
!         wvec = phi

        deallocate( residualk, residualkp1, reig, aeig, ck, ckp1, phi, gam, phikp1, gamkp1, btrans, rhs_phi, rhs_gam, ipiv, work )

    end if ! (iglb <= 0)

    ! add in checks to see if eqns are really satisfied

    ! find velocities
    ! uvec = d(psi)/dz
    uvec = 0.0
    uvec = matmul(d,wvec)
!     uvec(nzp) = 0.0
!     uvec = matmul(dor,wvec)
    ! wvec = -d(psi)/dx
    wvec = -(0.0,1.)*alphax*wvec
!     wvec(1) = 0.0
!     wvec(nzp) = 0.0
    ! for 2D, vvec = 0.0
    vvec = 0.0

    ! normalize uvec, vvec, wvec so that they form a T-S wave
    ! w a small fraction of total energy of the flow
    etot = energy(uvec,zpts,nzp) + energy(vvec,zpts,nzp) + energy(wvec,zpts,nzp)
    xnorm = sqrt(eps/etot)
    uvec = uvec*xnorm
    vvec = vvec*xnorm
    wvec = wvec*xnorm

    if (myid==0 .and. debug>=1) then
        write(*,'(//,A)') 'normalized orr-somm perturbations'
        write(*,*) 'uvec, wvec,'
        do i=1,nzp
            write(*,'(4(G14.6,'',''))') uvec(i), wvec(i)
        end do
    end if

    deallocate( did, d3, d4, a, b, c )

end subroutine solve_orrsomm

subroutine lintest(uf,vf,wf,enr1,enr2,grow1,grow2)
    ! calculate energy growth to compare to linear stability theory
    use dim
    use time
    use mpicom
    ! inputs/outputs
    real, dimension(nxpl,ny,nzpl), intent(inout) :: uf, vf, wf
    real, dimension(:), intent(inout) :: enr1, enr2, grow1, grow2
    ! other req'd variables
    real, allocatable, dimension(:,:,:) :: up, vp, wp
    real :: en1,en2
    integer :: itot

    allocate( up(nxpl,ny,nzpl), vp(nxpl,ny,nzpl), wp(nxpl,ny,nzpl) )
    !     enr1= mean + perturbation
    !     en2= only perturbation
    itot=1
    ! get total energy integrated through boundary layer
    call ener(uf,vf,wf,itot,en1)
    !     print *,'myid=',myid,'en1=',en1
    ! get mean-removed energy integrated through boundary layer
    up = uf
    vp = vf
    wp = wf
    if (myid==0) then
        up(1:2,1,:)=0.0
        vp(1:2,1,:)=0.0
        wp(1:2,1,:)=0.0
    endif
    itot=0
    call ener(up,vp,wp,itot,en2)
    !     print *,'myid=',myid,'en2=',en2

    call mpi_allreduce(en1,enr1(istep),1,mpi_double_precision,MPI_SUM,comm,ierr)
    call mpi_allreduce(en2,enr2(istep),1,mpi_double_precision,MPI_SUM,comm,ierr)

    !     print *,'myid=',myid,'enr1=',enr1(istep)
    !     print *,'myid=',myid,'enr2=',enr2(istep)
    ! calculate energy growth
    !    grow1(istep)=log(en1/enold1)/(2.0*dt)
    !    grow2(istep)=log(en2/enold2)/(2.0*dt)
    if (istep>1) then
        grow1(istep) = 1./(2.0*enr1(istep))*(enr1(istep)-enr1(istep-1))/dt
!         grow1(istep)=log(enr1(istep)/enr1(istep-1))/(2.0*dt)
        grow2(istep) = 1./(2.0*enr2(istep))*(enr2(istep)-enr2(istep-1))/dt
!         grow2(istep) = log(enr2(istep)/enr2(istep-1))/(2.0*dt)
    else
        grow1(istep)=0.0
        grow2(istep)=0.0
    endif
    !    if (abs(en1).ge.1.0e14) iabort=1
    !    if (abs(en2).ge.1.0e14) iabort=1
    !     if (myid==0) print *, 'grow1=',grow1(its),'grow2=',grow2(its)

    deallocate( up, vp, wp )

end subroutine lintest

subroutine ener(uf,vf,wf,itot,en)
    use dim
    use grid, only: zpts
    use mpicom
    use paral, only: ubar
    use modhorfft
    ! inputs/outputs
    real, dimension(nxpl,ny,nzpl), intent(inout) :: uf,vf,wf
    integer,intent(in) :: itot
    real, intent(out) :: en
    ! other reqd vars
    real, dimension(nxpp,nypl,nzpl) :: u,v,w
    real, dimension(nzpl) :: ee
    integer :: k0, i, j, k
    ! where integration write(*,*)s in z-direction
    k0 = 2 !17 !nz/4 + 1
    ! set total energy per x-y plane to zero for each z
    ee = 0.0
    ! transfer velocity to physical space
    call horfft(u,uf,1)
    call horfft(v,vf,1)
    call horfft(w,wf,1)
    if (itot==1) then
        do k=1,nzp
            u(:,:,k)=u(:,:,k)+ubar(k)
        end do
    endif
    ! cal!total energy 1/2 v^2 per x-y plane
    do j=1,nypl
        do i=1,nx
            ee = ee+0.5*(u(i,j,:)**2.0+v(i,j,:)**2.0+w(i,j,:)**2.0)
        end do
    end do
    ! integrate total energy over z-direction
    en=0.0
    do k=nz,k0,-1
!     do k=k0,nzp
!         en = en + 0.5*(ee(k-1)+ee(k))*(zpts(k-1) - zpts(k))
        en = en + 0.5*(ee(k+1)+ee(k))*(zpts(k) - zpts(k+1))
    end do

end subroutine ener

real function energy(q,zpts,nzp)
    ! integrate energy of complex q (single mode) over z
    complex*16, dimension(nzp), intent(in) :: q
    real, dimension(nzp), intent(in) :: zpts
    integer, intent(in) :: nzp
    ! local vars
    integer :: k
    ! integrate over z using trapeze rule
    energy = 0.0
    do k=2,nzp-1
        energy = energy - 0.5*( abs(q(k+1))**2 + abs(q(k))**2 )*( zpts(k+1)-zpts(k) )
    end do
    energy = energy*2.0/7.
end function energy

end module orrsomm


!*==dgemv.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b DGEMV
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
!
!       .. Scalar Arguments ..
!       DOUBLE PRECISION ALPHA,BETA
!       INTEGER INCX,INCY,LDA,M,N
!       CHARACTER TRANS
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION A(LDA,*),X(*),Y(*)
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DGEMV  performs one of the matrix-vector operations
!>
!>    y := alpha*A*x + beta*y,   or   y := alpha*A**T*x + beta*y,
!>
!> where alpha and beta are scalars, x and y are vectors and A is an
!> m by n matrix.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] TRANS
!> \verbatim
!>          TRANS is CHARACTER*1
!>           On entry, TRANS specifies the operation to be performed as
!>           follows:
!>
!>              TRANS = 'N' or 'n'   y := alpha*A*x + beta*y.
!>
!>              TRANS = 'T' or 't'   y := alpha*A**T*x + beta*y.
!>
!>              TRANS = 'C' or 'c'   y := alpha*A**T*x + beta*y.
!> \endverbatim
!>
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>           On entry, M specifies the number of rows of the matrix A.
!>           M must be at least zero.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>           On entry, N specifies the number of columns of the matrix A.
!>           N must be at least zero.
!> \endverbatim
!>
!> \param[in] ALPHA
!> \verbatim
!>          ALPHA is DOUBLE PRECISION.
!>           On entry, ALPHA specifies the scalar alpha.
!> \endverbatim
!>
!> \param[in] A
!> \verbatim
!>          A is DOUBLE PRECISION array, dimension ( LDA, N )
!>           Before entry, the leading m by n part of the array A must
!>           contain the matrix of coefficients.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>           On entry, LDA specifies the first dimension of A as declared
!>           in the calling (sub) program. LDA must be at least
!>           max( 1, m ).
!> \endverbatim
!>
!> \param[in] X
!> \verbatim
!>          X is DOUBLE PRECISION array, dimension at least
!>           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
!>           and at least
!>           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
!>           Before entry, the incremented array X must contain the
!>           vector x.
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER
!>           On entry, INCX specifies the increment for the elements of
!>           X. INCX must not be zero.
!> \endverbatim
!>
!> \param[in] BETA
!> \verbatim
!>          BETA is DOUBLE PRECISION.
!>           On entry, BETA specifies the scalar beta. When BETA is
!>           supplied as zero then Y need not be set on input.
!> \endverbatim
!>
!> \param[in,out] Y
!> \verbatim
!>          Y is DOUBLE PRECISION array, dimension at least
!>           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
!>           and at least
!>           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
!>           Before entry with BETA non-zero, the incremented array Y
!>           must contain the vector y. On exit, Y is overwritten by the
!>           updated vector y.
!> \endverbatim
!>
!> \param[in] INCY
!> \verbatim
!>          INCY is INTEGER
!>           On entry, INCY specifies the increment for the elements of
!>           Y. INCY must not be zero.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup double_blas_level2
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Level 2 Blas routine.
!>  The vector and matrix arguments are not referenced when N = 0, or M = 0
!>
!>  -- Written on 22-October-1986.
!>     Jack Dongarra, Argonne National Lab.
!>     Jeremy Du Croz, Nag Central Office.
!>     Sven Hammarling, Nag Central Office.
!>     Richard Hanson, Sandia National Labs.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE DGEMV(Trans,M,N,Alpha,A,Lda,X,Incx,Beta,Y,Incy)
      IMPLICIT NONE
!*--DGEMV160
!
!  -- Reference BLAS level2 routine (version 3.7.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION Alpha , Beta
      INTEGER Incx , Incy , Lda , M , N
      CHARACTER Trans
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION A(Lda,*) , X(*) , Y(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ONE , ZERO
      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
!     ..
!     .. Local Scalars ..
      DOUBLE PRECISION temp
      INTEGER i , info , ix , iy , j , jx , jy , kx , ky , lenx , leny
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX
!     ..
!
!     Test the input parameters.
!
      info = 0
      IF ( .NOT.LSAME(Trans,'N') .AND. .NOT.LSAME(Trans,'T') .AND.      &
     &     .NOT.LSAME(Trans,'C') ) THEN
         info = 1
      ELSEIF ( M<0 ) THEN
         info = 2
      ELSEIF ( N<0 ) THEN
         info = 3
      ELSEIF ( Lda<MAX(1,M) ) THEN
         info = 6
      ELSEIF ( Incx==0 ) THEN
         info = 8
      ELSEIF ( Incy==0 ) THEN
         info = 11
      ENDIF
      IF ( info/=0 ) THEN
         CALL XERBLA('DGEMV ',info)
         RETURN
      ENDIF
!
!     Quick return if possible.
!
      IF ( (M==0) .OR. (N==0) .OR. ((Alpha==ZERO) .AND. (Beta==ONE)) )  &
     &     RETURN
!
!     Set  LENX  and  LENY, the lengths of the vectors x and y, and set
!     up the start points in  X  and  Y.
!
      IF ( LSAME(Trans,'N') ) THEN
         lenx = N
         leny = M
      ELSE
         lenx = M
         leny = N
      ENDIF
      IF ( Incx>0 ) THEN
         kx = 1
      ELSE
         kx = 1 - (lenx-1)*Incx
      ENDIF
      IF ( Incy>0 ) THEN
         ky = 1
      ELSE
         ky = 1 - (leny-1)*Incy
      ENDIF
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through A.
!
!     First form  y := beta*y.
!
      IF ( Beta/=ONE ) THEN
         IF ( Incy/=1 ) THEN
            iy = ky
            IF ( Beta==ZERO ) THEN
               DO i = 1 , leny
                  Y(iy) = ZERO
                  iy = iy + Incy
               ENDDO
            ELSE
               DO i = 1 , leny
                  Y(iy) = Beta*Y(iy)
                  iy = iy + Incy
               ENDDO
            ENDIF
         ELSEIF ( Beta==ZERO ) THEN
            DO i = 1 , leny
               Y(i) = ZERO
            ENDDO
         ELSE
            DO i = 1 , leny
               Y(i) = Beta*Y(i)
            ENDDO
         ENDIF
      ENDIF
      IF ( Alpha==ZERO ) RETURN
      IF ( LSAME(Trans,'N') ) THEN
!
!        Form  y := alpha*A*x + y.
!
         jx = kx
         IF ( Incy==1 ) THEN
            DO j = 1 , N
               temp = Alpha*X(jx)
               DO i = 1 , M
                  Y(i) = Y(i) + temp*A(i,j)
               ENDDO
               jx = jx + Incx
            ENDDO
         ELSE
            DO j = 1 , N
               temp = Alpha*X(jx)
               iy = ky
               DO i = 1 , M
                  Y(iy) = Y(iy) + temp*A(i,j)
                  iy = iy + Incy
               ENDDO
               jx = jx + Incx
            ENDDO
         ENDIF
      ELSE
!
!        Form  y := alpha*A**T*x + y.
!
         jy = ky
         IF ( Incx==1 ) THEN
            DO j = 1 , N
               temp = ZERO
               DO i = 1 , M
                  temp = temp + A(i,j)*X(i)
               ENDDO
               Y(jy) = Y(jy) + Alpha*temp
               jy = jy + Incy
            ENDDO
         ELSE
            DO j = 1 , N
               temp = ZERO
               ix = kx
               DO i = 1 , M
                  temp = temp + A(i,j)*X(ix)
                  ix = ix + Incx
               ENDDO
               Y(jy) = Y(jy) + Alpha*temp
               jy = jy + Incy
            ENDDO
         ENDIF
      ENDIF
!
!
!     End of DGEMV .
!
      END SUBROUTINE DGEMV


module constants_module

  use iso_c_binding, only : c_float, c_double, c_size_t

  implicit none

  integer, parameter :: type_real = c_double
  ! We could/should use Fortran 2008 c_sizeof here.
  integer (kind=c_size_t), parameter :: type_real_size = 8_c_size_t

  real(kind = type_real), parameter :: M_PI    = &
       3.141592653589793238462643383279502884197_type_real

 end module constants_module