!=============================================================================!
        subroutine grad2 (ndof, nx, ny, v, g1v, g11v, g12v, g22v, dx, dy, &
                          optx, opty, xper, yper, lsym, rsym, bsym, tsym, carp)
!
!  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.
!
!  Added g1v as input to improve efficiency
!
!  Revised: 6-28-95
!=============================================================================!
        use stencil
        implicit none

        integer :: ndof, nx, ny, optx, opty
        logical :: xper, yper
        logical :: lsym, rsym, bsym, tsym, carp
        real    :: v(ndof,nx,ny), g1v(ndof,nx,ny)
!$sgi distribute v(*,*,block), g1v(*,*,block)
        real    :: g11v(ndof,nx,ny), g12v(ndof,nx,ny), g22v(ndof,nx,ny)
!$sgi distribute g11v(*,*,block), g12v(*,*,block), g22v(*,*,block)
        real    :: dx, dy

        real, parameter :: zero = 0.0, one = 1.0, pt5 = 0.5, two = 2.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

        integer :: i, j, idof
        real, parameter :: eps = 1.0e-12
        real :: isign
!=============================================================================!

        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
!=============================================================================!

!.... interior

        !$doacross local(i,idof)
        !$omp parallel do private(i,idof)
        do j = 1, ny
          do i = 4, nx-3
            do idof = 1, ndof
              g11v(idof,i,j) = ( dx1 * v(idof,i-3,j)   + &
                                 dx2 * v(idof,i-2,j)   + &
                                 dx3 * v(idof,i-1,j)   + &
                                 dx4 * v(idof,i,j)     + &
                                 dx5 * v(idof,i+1,j)   + &
                                 dx6 * v(idof,i+2,j)   + &
                                 dx7 * v(idof,i+3,j)   )
            end do
          end do
        end do

        if (xper) then

          !$doacross
          !$omp parallel do
          do j = 1, ny

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

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

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

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

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

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

          end do

        else

          !$doacross
          !$omp parallel do
          do j = 1, ny

          g11v(:,1,j)       = ( dd1 * v(:,1,j) + &
                                dd2 * v(:,2,j) + &
                                dd3 * v(:,3,j) + &
                                dd4 * v(:,4,j) + &
                                dd5 * v(:,5,j) ) * dxsinv

          g11v(:,2,j)       = ( db1 * v(:,1,j) + &
                                db2 * v(:,2,j) + &
                                db3 * v(:,3,j) + &
                                db4 * v(:,4,j) + &
                                db5 * v(:,5,j) ) * dxsinv

          g11v(:,3,j)       = ( da1 * v(:,1,j) + &
                                da2 * v(:,2,j) + &
                                da3 * v(:,3,j) + &
                                da4 * v(:,4,j) + &
                                da5 * v(:,5,j) ) * dxsinv

          g11v(:,nx-2,j)    = ( da1 * v(:,nx-4,j) + &
                                da2 * v(:,nx-3,j) + &
                                da3 * v(:,nx-2,j) + &
                                da4 * v(:,nx-1,j) + &
                                da5 * v(:,nx,j)   ) * dxsinv

          g11v(:,nx-1,j)    =   ( db1 * v(:,nx,j)   + &
                                  db2 * v(:,nx-1,j) + &
                                  db3 * v(:,nx-2,j) + &
                                  db4 * v(:,nx-3,j) + &
                                  db5 * v(:,nx-4,j) ) * dxsinv

          g11v(:,nx,j)      =   ( dd1 * v(:,nx,j)   + &
                                  dd2 * v(:,nx-1,j) + &
                                  dd3 * v(:,nx-2,j) + &
                                  dd4 * v(:,nx-3,j) + &
                                  dd5 * v(:,nx-4,j) ) * dxsinv

          end do

        end if

!.... implement symmetry conditions

        if (lsym) then
          !$doacross local( idof, isign )
          !$omp parallel do private( idof, isign )
          do j = 1, ny
          do idof = 1, ndof
            if (idof .eq. 3) then
              isign = -one
            else
              isign = one
            end if

            g11v(idof,1,j)    = ( isign * dx1 * v(idof,4,j)     + &
                                  isign * dx2 * v(idof,3,j)     + &
                                  isign * dx3 * v(idof,2,j)     + &
                                  dx4 * v(idof,1,j)             + &
                                  dx5 * v(idof,2,j)             + &
                                  dx6 * v(idof,3,j)             + &
                                  dx7 * v(idof,4,j)             )

            g11v(idof,2,j)    = ( isign * dx1 * v(idof,3,j)     + &
                                  isign * dx2 * v(idof,2,j)     + &
                                  dx3 * v(idof,1,j)             + &
                                  dx4 * v(idof,2,j)             + &
                                  dx5 * v(idof,3,j)             + &
                                  dx6 * v(idof,4,j)             + &
                                  dx7 * v(idof,5,j)             )

            g11v(idof,3,j)    = ( isign * dx1 * v(idof,2,j)     + &
                                  dx2 * v(idof,1,j)             + &
                                  dx3 * v(idof,2,j)             + &
                                  dx4 * v(idof,3,j)             + &
                                  dx5 * v(idof,4,j)             + &
                                  dx6 * v(idof,5,j)             + &
                                  dx7 * v(idof,6,j)             )
          end do
          end do

        end if

        if (rsym) then
          !$doacross local( idof, isign )
          !$omp parallel do private( idof, isign )
          do j = 1, ny
          do idof = 1, ndof
            if (idof .eq. 3) then
              isign = -one
            else
              isign = one
            end if

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

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

            g11v(idof,nx,j)   = ( dx1 * v(idof,nx-3,j)          + &
                                  dx2 * v(idof,nx-2,j)          + &
                                  dx3 * v(idof,nx-1,j)          + &
                                  dx4 * v(idof,nx,j)            + &
                                  isign * dx5 * v(idof,nx-1,j)  + &
                                  isign * dx6 * v(idof,nx-2,j)  + &
                                  isign * dx7 * v(idof,nx-3,j)  )
          end do
          end do

        end if

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

!.... interior

        !$doacross local(j,idof)
        !$omp parallel do private(j,idof)
        do i = 1, nx
          do j = 4, ny-3
            do idof = 1, ndof
              g22v(idof,i,j) = ( dy1 * v(idof,i,j-3)   + &
                                 dy2 * v(idof,i,j-2)   + &
                                 dy3 * v(idof,i,j-1)   + &
                                 dy4 * v(idof,i,j  )   + &
                                 dy5 * v(idof,i,j+1)   + &
                                 dy6 * v(idof,i,j+2)   + &
                                 dy7 * v(idof,i,j+3)   )
            end do
          end do
        end do

        if (yper) then

          !$doacross
          !$omp parallel do
          do i = 1, nx

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

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

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

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

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

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

          end do

        else

          if (bsym) then

            !$doacross local( idof, isign )
            !$omp parallel do private(idof, isign)
            do i = 1, nx
              do idof = 1, ndof
                if (idof .eq. 3) then
                  isign = -one
                else
                  isign = one
                end if

                g22v(idof,i,1) = (isign * dy1 * v(idof,i,4)     + &
                                  isign * dy2 * v(idof,i,3)     + &
                                  isign * dy3 * v(idof,i,2)     + &
                                  dy4 * v(idof,i,1)             + &
                                  dy5 * v(idof,i,2)             + &
                                  dy6 * v(idof,i,3)             + &
                                  dy7 * v(idof,i,4)             )

                g22v(idof,i,2) = (isign * dy1 * v(idof,i,3)     + &
                                  isign * dy2 * v(idof,i,2)     + &
                                  dy3 * v(idof,i,1)             + &
                                  dy4 * v(idof,i,2)             + &
                                  dy5 * v(idof,i,3)             + &
                                  dy6 * v(idof,i,4)             + &
                                  dy7 * v(idof,i,5)             )

                g22v(idof,i,3) = (isign * dy1 * v(idof,i,2)     + &
                                  dy2 * v(idof,i,1)             + &
                                  dy3 * v(idof,i,2)             + &
                                  dy4 * v(idof,i,3)             + &
                                  dy5 * v(idof,i,4)             + &
                                  dy6 * v(idof,i,5)             + &
                                  dy7 * v(idof,i,6)             )
              end do
            end do
            !$omp end parallel do

          else

            !$doacross
            !$omp parallel do
            do i = 1, nx

              g22v(:,i,1)  =  ( dd1 * v(:,i,1) + &
                                dd2 * v(:,i,2) + &
                                dd3 * v(:,i,3) + &
                                dd4 * v(:,i,4) + &
                                dd5 * v(:,i,5) ) * dysinv

              g22v(:,i,2)  =  ( db1 * v(:,i,1) + &
                                db2 * v(:,i,2) + &
                                db3 * v(:,i,3) + &
                                db4 * v(:,i,4) + &
                                db5 * v(:,i,5) ) * dysinv

              g22v(:,i,3)   = ( da1 * v(:,i,1) + &
                                da2 * v(:,i,2) + &
                                da3 * v(:,i,3) + &
                                da4 * v(:,i,4) + &
                                da5 * v(:,i,5) ) * dysinv
            end do

          end if

          if (tsym) then

            call error('grad2$','Bsym not implemented$')

          else

            !$doacross
            !$omp parallel do
            do i = 1, nx

              g22v(:,i,ny-2)= ( da1 * v(:,i,ny-4) + &
                                da2 * v(:,i,ny-3) + &
                                da3 * v(:,i,ny-2) + &
                                da4 * v(:,i,ny-1) + &
                                da5 * v(:,i,ny)   ) * dysinv

              g22v(:,i,ny-1)= ( db1 * v(:,i,ny)   + &
                                db2 * v(:,i,ny-1) + &
                                db3 * v(:,i,ny-2) + &
                                db4 * v(:,i,ny-3) + &
                                db5 * v(:,i,ny-4) ) * dysinv

              g22v(:,i,ny) =  ( dd1 * v(:,i,ny)   + &
                                dd2 * v(:,i,ny-1) + &
                                dd3 * v(:,i,ny-2) + &
                                dd4 * v(:,i,ny-3) + &
                                dd5 * v(:,i,ny-4) ) * dysinv

            end do

          end if

        end if

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

!.... interior

      !$doacross local(j,idof)
      !$omp parallel do private(j,idof)
        do i = 1, nx
          do j = 4, ny-3
            do idof = 1, ndof
              g12v(idof,i,j) = ( gy1 * g1v(idof,i,j-3)  + &
                                 gy2 * g1v(idof,i,j-2)  + &
                                 gy3 * g1v(idof,i,j-1)  + &
                                 gy4 * g1v(idof,i,j+1)  + &
                                 gy5 * g1v(idof,i,j+2)  + &
                                 gy6 * g1v(idof,i,j+3)  )
            end do
          end do
        end do
        !$omp end parallel do

!.... boundaries

        if (yper) then

          !$doacross
          !$omp parallel do
          do i = 1, nx

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

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

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

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

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

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

          end do
          !$omp end parallel do

        else

          if (bsym) then

            !$doacross local( idof, isign )
            !$omp parallel do private(idof, isign)
            do i = 1, nx
              do idof = 1, ndof
                if (idof .eq. 3) then
                  isign = -one
                else
                  isign = one
                end if

                g12v(idof,i,1) = ( isign * gy1 * g1v(idof,i,4)  + &
                                  isign * gy2 * g1v(idof,i,3)   + &
                                  isign * gy3 * g1v(idof,i,2)   + &
                                  gy4 * g1v(idof,i,2)           + &
                                  gy5 * g1v(idof,i,3)           + &
                                  gy6 * g1v(idof,i,4)           )

                g12v(idof,i,2) = ( isign * gy1 * g1v(idof,i,3)  + &
                                  isign * gy2 * g1v(idof,i,2)   + &
                                  gy3 * g1v(idof,i,1)           + &
                                  gy4 * g1v(idof,i,3)           + &
                                  gy5 * g1v(idof,i,4)           + &
                                  gy6 * g1v(idof,i,5)           )

                g12v(idof,i,3) = ( isign * gy1 * g1v(idof,i,2)  + &
                                  gy2 * g1v(idof,i,1)           + &
                                  gy3 * g1v(idof,i,2)           + &
                                  gy4 * g1v(idof,i,4)           + &
                                  gy5 * g1v(idof,i,5)           + &
                                  gy6 * g1v(idof,i,6)           )
              end do
            end do
            !$omp end parallel do

          else if (carp) then

            !$doacross
            !$omp parallel do
            do i = 1, nx

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

              g12v(:,i,2) = ( gh1 * g1v(:,i,1)  + &
                             gh2 * g1v(:,i,2)   + &
                             gh3 * g1v(:,i,3)   + &
                             gh4 * g1v(:,i,4)   + &
                             gh5 * g1v(:,i,5)   + &
                             gh6 * g1v(:,i,6)  ) * dyinv

              g12v(:,i,3) = ( gi1 * g1v(:,i,1)  + &
                             gi2 * g1v(:,i,2)   + &
                             gi3 * g1v(:,i,3)   + &
                             gi4 * g1v(:,i,4)   + &
                             gi5 * g1v(:,i,5)   + &
                             gi6 * g1v(:,i,6)  ) * dyinv

              g12v(:,i,4) = ( gj1 * g1v(:,i,1)  + &
                             gj2 * g1v(:,i,2)   + &
                             gj3 * g1v(:,i,3)   + &
                             gj4 * g1v(:,i,4)   + &
                             gj5 * g1v(:,i,5)   + &
                             gj6 * g1v(:,i,6)  ) * dyinv

            end do
            !$omp end parallel do

          else

            !$doacross
            !$omp parallel do
            do i = 1, nx

              g12v(:,i,1)= ( gc1 * g1v(:,i,1)   + &
                             gc2 * g1v(:,i,2)   + &
                             gc3 * g1v(:,i,3)   + &
                             gc4 * g1v(:,i,4)   + &
                             gc5 * g1v(:,i,5)     ) * dyinv

              g12v(:,i,2)= ( gb1 * g1v(:,i,1)   + &
                             gb2 * g1v(:,i,2)   + &
                             gb3 * g1v(:,i,3)   + &
                             gb4 * g1v(:,i,4)   + &
                             gb5 * g1v(:,i,5)     ) * dyinv

              g12v(:,i,3)= ( ga1 * g1v(:,i,1)   + &
                             ga2 * g1v(:,i,2)   + &
                             ga3 * g1v(:,i,4)   + &
                             ga4 * g1v(:,i,5)     ) * dyinv

            end do
            !$omp end parallel do

          end if

          if (tsym) then

            call error('grad$','Tsym not implemented$')

          else if (carp) then

            !$doacross
            !$omp parallel do
            do i = 1, nx

              g12v(:,i,ny-3) = -( gj1 * g1v(:,i,ny)     + &
                             gj2 * g1v(:,i,ny-1)  + &
                             gj3 * g1v(:,i,ny-2)  + &
                             gj4 * g1v(:,i,ny-3)  + &
                             gj5 * g1v(:,i,ny-4)  + &
                             gj6 * g1v(:,i,ny-5)  ) * dyinv

              g12v(:,i,ny-2) = -( gi1 * g1v(:,i,ny)     + &
                             gi2 * g1v(:,i,ny-1)  + &
                             gi3 * g1v(:,i,ny-2)  + &
                             gi4 * g1v(:,i,ny-3)  + &
                             gi5 * g1v(:,i,ny-4)  + &
                             gi6 * g1v(:,i,ny-5)  ) * dyinv

              g12v(:,i,ny-1) = -( gh1 * g1v(:,i,ny)     + &
                             gh2 * g1v(:,i,ny-1)  + &
                             gh3 * g1v(:,i,ny-2)  + &
                             gh4 * g1v(:,i,ny-3)  + &
                             gh5 * g1v(:,i,ny-4)  + &
                             gh6 * g1v(:,i,ny-5)  ) * dyinv

              g12v(:,i,ny)   = -( gg1 * g1v(:,i,ny)     + &
                             gg2 * g1v(:,i,ny-1)  + &
                             gg3 * g1v(:,i,ny-2)  + &
                             gg4 * g1v(:,i,ny-3)  + &
                             gg5 * g1v(:,i,ny-4)  + &
                             gg6 * g1v(:,i,ny-5)  ) * dyinv
            end do
            !$omp end parallel do

          else

            !$doacross
            !$omp parallel do
            do i = 1, nx

              g12v(:,i,ny-2) = ( ga1 * g1v(:,i,ny-4)  + &
                             ga2 * g1v(:,i,ny-3)  + &
                             ga3 * g1v(:,i,ny-1)  + &
                             ga4 * g1v(:,i,ny  )  ) * dyinv

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

              g12v(:,i,ny)   = -( gc1 * g1v(:,i,ny  )  + &
                             gc2 * g1v(:,i,ny-1)  + &
                             gc3 * g1v(:,i,ny-2)  + &
                             gc4 * g1v(:,i,ny-3)  + &
                             gc5 * g1v(:,i,ny-4)  ) * dyinv

            end do
            !$omp end parallel do

          end if

        end if

!.... implement a filter of roundoff noise

        if (.false.) then
          !$doacross local(i,idof)
          !$omp parallel do private(i,idof)
          do j = 1, ny
            do i = 1, nx
              do idof = 1, ndof
                if ( abs(g11v(idof,i,j)) .lt. eps ) g11v(idof,i,j) = zero
                if ( abs(g12v(idof,i,j)) .lt. eps ) g12v(idof,i,j) = zero
                if ( abs(g22v(idof,i,j)) .lt. eps ) g22v(idof,i,j) = zero
              end do
            end do
          end do
        end if

        return
        end


! @@name:	task_dep.5f
! @@type:	F-free
! @@compilable:	yes
! @@linkable:	no
! @@expect:	success
! Assume BS divides N perfectly
subroutine matmul_depend (N, BS, A, B, C)
   implicit none
   integer :: N, BS, BM
   real, dimension(N, N) :: A, B, C
   integer :: i, j, k, ii, jj, kk
   BM = BS - 1
   do i = 1, N, BS
      do j = 1, N, BS
         do k = 1, N, BS
!$omp task shared(A,B,C) private(ii,jj,kk) & ! I,J,K are firstprivate by default
!$omp depend ( in: A(i:i+BM, k:k+BM), B(k:k+BM, j:j+BM) ) &
!$omp depend ( inout: C(i:i+BM, j:j+BM) )
            do ii = i, i+BM
               do jj = j, j+BM
                  do kk = k, k+BM
                     C(jj,ii) = C(jj,ii) + A(kk,ii) * B(jj,kk)
                  end do
               end do
            end do
!$omp end task
         end do
      end do
   end do
end subroutine


!======================================================================================================================
!> @file        cg_poisson_matrix.f90
!> @brief       This file contains a module for conjugate gradient method with heptadiagonal poisson matrix
!> @details     This file contains a module for conjugate gradient solver with convergence criteria and
!>              conjugate gradient iterator with iteration number
!> @author
!>              - Ji-Hoon Kang (jhkang@kisti.re.kr), Korea Institute of Science and Technology Information
!>
!> @date        May 2021
!> @version     1.0
!> @par         Copyright
!>              Copyright (c) 2021 Ji-Hoon Kang, Korea Institute of Science and Technology Information,
!>              All rights reserved.
!> @par         License
!>              This project is release under the terms of the MIT License (see LICENSE in )
!======================================================================================================================

!>
!> @brief       Module for for conjugate gradient method with heptadiagonal poisson matrix
!> @details     Contains conjugate gradient(CG) solver with convergence criteria and CG iterator with iteration number
!>
module cg_poisson_matrix

    use poisson_matrix_operator

    implicit none

    private

    integer(kind=4)     :: row_size

    public  :: cg_solver_poisson_matrix
    public  :: cg_iterator_poisson_matrix

    contains

    !>
    !> @brief       Conjugate gradient solver with convergence criteria
    !> @param       sol             Result solution having a shape of 3D matrix
    !> @param       a_poisson       Heptadiagonal poisson matrix
    !> @param       rhs             RHS vector having a shape of 3D matrix
    !> @param       dm              Subdomain
    !> @param       maxiteration    Maximum number of iterations
    !> @param       tolerance       Convergence criteria
    !> @param       is_aggregated   Boolean whether domain is aggregated (.true.) or not (.false.)
    !>
    subroutine cg_solver_poisson_matrix(sol, a_poisson, rhs, dm, maxiteration, tolerance, is_aggregated)

        use matrix, only        : matrix_heptadiagonal
        use geometry, only      : subdomain
        use mpi_topology, only  : myrank

        implicit none

        real(kind=8),   intent(inout)           :: sol(0:,0:,0:)
        type(matrix_heptadiagonal),intent(in)   :: a_poisson
        real(kind=8),   intent(in)              :: rhs(0:,0:,0:)
        type(subdomain), intent(in)             :: dm
        integer(kind=4),intent(in)              :: maxiteration
        real(kind=8),   intent(in)              :: tolerance
        logical, intent(in)                     :: is_aggregated(0:2)

        ! Local temporary variables
        integer(kind=4)     :: i, j, k, iter
        real(kind=8)        :: alpha=0.0d0, beta=0.0d0, temp1=0.0d0, temp2=0.0d0, rsd0tol=0.0d0
        real(kind=8), allocatable :: p(:,:,:), Ax(:,:,:), Ap(:,:,:), rsd(:,:,:)

        row_size = a_poisson%dof

        allocate(   p(0:dm%nx+1, 0:dm%ny+1, 0:dm%nz+1) )
        allocate(  Ax(0:dm%nx+1, 0:dm%ny+1, 0:dm%nz+1) )
        allocate(  Ap(0:dm%nx+1, 0:dm%ny+1, 0:dm%nz+1) )
        allocate( rsd(0:dm%nx+1, 0:dm%ny+1, 0:dm%nz+1) )

        p(:,:,:)    = 0.0d0
        ax(:,:,:)   = 0.0d0
        ap(:,:,:)   = 0.0d0
        rsd(:,:,:)  = 0.0d0

        ! Pre-process of CG algorithm
        call mv_mul_poisson_matrix(ax, a_poisson, sol, dm, is_aggregated)

!$omp parallel do shared(rsd,rhs,ax,p)
        do k = 1, dm%nz
            do j = 1, dm%ny
                do i = 1, dm%nx
                    rsd(i,j,k) = rhs(i,j,k) - ax(i,j,k)
                    p(i,j,k)   = rsd(i,j,k)
                enddo
            enddo
        enddo

        ! Initial residual
        call vv_dot_3d_matrix(rsd0tol, rsd, rsd, dm%nx, dm%ny, dm%nz, is_aggregated)
        if(myrank.eq.0) print '(a)', '[CG] Conjugate gradient is started.'
        if(myrank.eq.0) print '(a,e15.7)', '[CG] Initial residual : ', rsd0tol

        ! Main CG algorithm
        do iter=0, maxiteration-1

            if ((mod(iter,10).EQ.0).AND.(myrank.eq.0)) then
                print 101, sqrt(temp2), sqrt(temp2/rsd0tol), sqrt(rsd0tol), tolerance, iter
                101   format('[CG] mse: ',e14.6,x,', r_mse: ',e14.6,x,', rsd0: ',e14.6,' with a tolerance criteria of ',e12.4,' at ',i5,' iterations.')
            endif

            call vv_dot_3d_matrix(temp1, rsd, rsd, dm%nx, dm%ny, dm%nz, is_aggregated)

            call mv_mul_poisson_matrix(ap, a_poisson, p, dm, is_aggregated)
            call vv_dot_3d_matrix(temp2, Ap, p, dm%nx, dm%ny, dm%nz, is_aggregated)

            alpha=temp1/temp2

!$omp parallel do shared(sol,p,rsd,Ap) firstprivate(alpha)
            do k = 1, dm%nz
                do j = 1, dm%ny
                    do i = 1, dm%nx
                        sol(i,j,k) = sol(i,j,k) + alpha * p(i,j,k)
                        rsd(i,j,k) = rsd(i,j,k) - alpha * Ap(i,j,k)
                    enddo
                enddo
            enddo

            call vv_dot_3d_matrix(temp2, rsd, rsd, dm%nx, dm%ny, dm%nz, is_aggregated)

            ! Finish if convergence criteria is satisfied
            if (sqrt(temp2/rsd0tol) .LT. tolerance) exit

            beta = temp2/temp1

!$omp parallel do shared(p,rsd) firstprivate(beta)
            do k = 1, dm%nz
                do j = 1, dm%ny
                    do i = 1, dm%nx
                        p(i,j,k)= rsd(i,j,k) + beta * p(i,j,k)
                    enddo
                enddo
            enddo
        enddo
        if(myrank.eq.0) print '(a,i5,a,e15.7,a,e15.7)','[CG] Finished with total iteration = ',iter,', mse = ',sqrt(temp2),'r_mse = ',sqrt(temp2/rsd0tol)

        deallocate(p)
        deallocate(Ax)
        deallocate(Ap)
        deallocate(rsd)

    end subroutine cg_solver_poisson_matrix

    !>
    !> @brief       Conjugate gradient iterator with number of iteration
    !> @param       sol             Result solution having a shape of 3D matrix
    !> @param       a_poisson       Heptadiagonal poisson matrix
    !> @param       rhs             RHS vector having a shape of 3D matrix
    !> @param       dm              Subdomain
    !> @param       maxiteration    Maximum number of iterations
    !> @param       is_aggregated   Boolean whether domain is aggregated (.true.) or not (.false.)
    !>
    subroutine cg_iterator_poisson_matrix(sol, a_poisson, rhs, dm, maxiteration, is_aggregated)

        use matrix, only        : matrix_heptadiagonal
        use geometry, only      : subdomain
        use mpi_topology, only  : myrank

        implicit none

        real(kind=8),   intent(inout)           :: sol(0:,0:,0:)
        type(matrix_heptadiagonal), intent(in)  :: a_poisson
        real(kind=8),   intent(in)              :: rhs(0:,0:,0:)
        type(subdomain), intent(in)             :: dm
        integer(kind=4),intent(in)              :: maxiteration
        logical, intent(in)                     :: is_aggregated(0:2)

        integer(kind=4)     :: i, j, k, iter
        real(kind=8)        :: alpha=0.0d0, beta=0.0d0, temp1=0.0d0, temp2=0.0d0
        real(kind=8), allocatable :: p(:,:,:), Ax(:,:,:), Ap(:,:,:), rsd(:,:,:)

        row_size = a_poisson%dof

        allocate(   p(0:dm%nx+1, 0:dm%ny+1, 0:dm%nz+1) )
        allocate(  Ax(0:dm%nx+1, 0:dm%ny+1, 0:dm%nz+1) )
        allocate(  Ap(0:dm%nx+1, 0:dm%ny+1, 0:dm%nz+1) )
        allocate( rsd(0:dm%nx+1, 0:dm%ny+1, 0:dm%nz+1) )

        p(:,:,:)    = 0.0d0
        ax(:,:,:)   = 0.0d0
        ap(:,:,:)   = 0.0d0
        rsd(:,:,:)  = 0.0d0

        ! Pre-process of CG algorithm : Initial residual is not required as number of iteration is defined
        call mv_mul_poisson_matrix(ax, a_poisson, sol, dm, is_aggregated)

!$omp parallel do shared(rsd,rhs,ax,p)
        do k = 1, dm%nz
            do j = 1, dm%ny
                do i = 1, dm%nx
                    rsd(i,j,k) = rhs(i,j,k) - ax(i,j,k)
                    p(i,j,k)   = rsd(i,j,k)
                enddo
            enddo
        enddo

        ! Main CG algorithm : Convergence check is not required as number of iteration is defined
        do iter=0, maxiteration-1

            call vv_dot_3d_matrix(temp1, rsd, rsd, dm%nx, dm%ny, dm%nz, is_aggregated)

            call mv_mul_poisson_matrix(ap, a_poisson, p, dm, is_aggregated)
            call vv_dot_3d_matrix(temp2, Ap, p, dm%nx, dm%ny, dm%nz, is_aggregated)

            alpha=temp1/temp2

!$omp parallel do shared(sol,p,rsd,Ap) firstprivate(alpha)
            do k = 1, dm%nz
                do j = 1, dm%ny
                    do i = 1, dm%nx
                        sol(i,j,k) = sol(i,j,k) + alpha * p(i,j,k)
                        rsd(i,j,k) = rsd(i,j,k) - alpha * Ap(i,j,k)
                    enddo
                enddo
            enddo

            call vv_dot_3d_matrix(temp2, rsd, rsd, dm%nx, dm%ny, dm%nz, is_aggregated)

            beta = temp2/temp1

!$omp parallel do shared(p,rsd) firstprivate(beta)
            do k = 1, dm%nz
                do j = 1, dm%ny
                    do i = 1, dm%nx
                        p(i,j,k)= rsd(i,j,k) + beta * p(i,j,k)
                    enddo
                enddo
            enddo
        enddo
        if(myrank.eq.0) print '(a,i5,a,e15.7)','   [CG] CG iterator completed with total iteration = ',iter,', mse = ',sqrt(temp2)

        deallocate(p)
        deallocate(Ax)
        deallocate(Ap)
        deallocate(rsd)

    end subroutine cg_iterator_poisson_matrix

end module cg_poisson_matrix


    Program dstevx_example

!     DSTEVX Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dstevx
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: abstol, vl, vu
      Integer :: ifail, il, info, iu, ldz, m, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: d(:), e(:), w(:), work(:), z(:, :)
      Integer, Allocatable :: iwork(:), jfail(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: tiny
!     .. Executable Statements ..
      Write (nout, *) 'DSTEVX Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      ldz = n
      m = n
      Allocate (d(n), e(n), w(n), work(5*n), z(ldz,m), iwork(5*n), jfail(n))

!     Read the lower and upper bounds of the interval to be searched,
!     and read the diagonal and off-diagonal elements of the matrix
!     A from data file

      Read (nin, *) vl, vu
      Read (nin, *) d(1:n)
      Read (nin, *) e(1:n-1)

!     Set the absolute error tolerance for eigenvalues.  With ABSTOL
!     set to zero, the default value would be used instead

      abstol = 2.0E0_dp*tiny(1.0E0_dp)

!     Solve the symmetric eigenvalue problem
      Call dstevx('Vectors', 'Values in range', n, d, e, vl, vu, il, iu, &
        abstol, m, w, z, ldz, work, iwork, jfail, info)

      If (info>=0) Then

!       Print solution

        Write (nout, 100) 'Number of eigenvalues found =', m
        Write (nout, *)
        Write (nout, *) 'Eigenvalues'
        Write (nout, 110) w(1:m)
        Flush (nout)

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_real_gen('General', ' ', n, m, z, ldz, &
          'Selected eigenvectors', ifail)

        If (info>0) Then
          Write (nout, 100) 'INFO eigenvectors failed to converge, INFO =', &
            info
          Write (nout, *) 'Indices of eigenvectors that did not converge'
          Write (nout, 120) jfail(1:m)
        End If
      Else
        Write (nout, 100) 'Failure in DSTEVX. INFO =', info
      End If

100   Format (1X, A, I5)
110   Format (3X, (8F8.4))
120   Format (3X, (8I8))
    End Program


      subroutine lapl(ieq,visc)
************************************************************************
*
*   LAPL -- RHS inner products with the laplacian.
*
************************************************************************
      include "parameters.h"

      double precision wpde
      integer nnod,nelt
      common /mfe010/ nnod,nelt /mfe020/ wpde(npde)

      double precision bvl,bvr
      integer bcl,bcr
      common /mfe030/ bcl(nepn),bcr(nepn),bvl(nepn),bvr(nepn)

      double precision gu0,gx0,gu1,gx1
      common /loc12/ gu0(mnod,npde),gx0(mnod),gu1(mnod,npde),gx1(mnod)

      double precision du,dx
      common /loc31/ du(mnod,npde),dx(mnod)

      integer ieq,j
      double precision visc,c,dudx,dS,e,expan,i1(mnod),i2(mnod)
      double precision eta,c3,c5,c7
      parameter (eta=1.d-2,c3=1.d0/3.d0,c5=1.d0/5.d0,c7=1.d0/7.d0)

*     Taylor expansion of .5*log((1+e)/(1-e)).
      expan(e) = e*(1.d0 + (e**2)*(c3 + (e**2)*(c5 + c7*(e**2))))

      c = wpde(ieq)*visc

      do 10 j=1,nelt
       dudx = du(j,ieq)/dx(j)
       dS = sqrt(1.d0 + dudx**2)
       e = dudx/dS
       i2(j) = c*dudx**2/(1.d0 + dS)
       if(abs(e) .gt. eta) then
        i1(j) = c*sign(log(abs(dudx)+dS), dudx)
       else
        i1(j) = c*expan(e)
        endif
   10 continue

      gu1(1,ieq) = gu1(1,ieq) - i1(1)
      gx1(1) = gx1(1) + i2(1)
      do 20 j=2,nelt-1
       gu0(j,ieq) = gu0(j,ieq) + i1(j)
       gu1(j,ieq) = gu1(j,ieq) - i1(j)
       gx0(j) = gx0(j) - i2(j)
       gx1(j) = gx1(j) + i2(j)
   20 continue
      gu0(nelt,ieq) = gu0(nelt,ieq) + i1(nelt)
      gx0(nelt) = gx0(nelt) - i2(nelt)

      if(bcl(ieq).eq.2) gu0(1,ieq)    = gu0(1,ieq)    + i1(1)
      if(bcr(ieq).eq.2) gu1(nelt,ieq) = gu1(nelt,ieq) - i1(nelt)

      return
      end


*DECK R9GMIT
      FUNCTION R9GMIT (A, X, ALGAP1, SGNGAM, ALX)
C***BEGIN PROLOGUE  R9GMIT
C***SUBSIDIARY
C***PURPOSE  Compute Tricomi's incomplete Gamma function for small
C            arguments.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      SINGLE PRECISION (R9GMIT-S, D9GMIT-D)
C***KEYWORDS  COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, SMALL X,
C             SPECIAL FUNCTIONS, TRICOMI
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Compute Tricomi's incomplete gamma function for small X.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  ALNGAM, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  R9GMIT
      SAVE EPS, BOT
      DATA EPS, BOT / 2*0.0 /
C***FIRST EXECUTABLE STATEMENT  R9GMIT
      IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3)
      IF (BOT.EQ.0.0) BOT = LOG(R1MACH(1))
C
      IF (X .LE. 0.0) CALL XERMSG ('SLATEC', 'R9GMIT',
     +   'X SHOULD BE GT 0', 1, 2)
C
      MA = A + 0.5
      IF (A.LT.0.0) MA = A - 0.5
      AEPS = A - MA
C
      AE = A
      IF (A.LT.(-0.5)) AE = AEPS
C
      T = 1.0
      TE = AE
      S = T
      DO 20 K=1,200
        FK = K
        TE = -X*TE/FK
        T = TE/(AE+FK)
        S = S + T
        IF (ABS(T).LT.EPS*ABS(S)) GO TO 30
 20   CONTINUE
      CALL XERMSG ('SLATEC', 'R9GMIT',
     +   'NO CONVERGENCE IN 200 TERMS OF TAYLOR-S SERIES', 2, 2)
C
 30   IF (A.GE.(-0.5)) ALGS = -ALGAP1 + LOG(S)
      IF (A.GE.(-0.5)) GO TO 60
C
      ALGS = -ALNGAM(1.0+AEPS) + LOG(S)
      S = 1.0
      M = -MA - 1
      IF (M.EQ.0) GO TO 50
      T = 1.0
      DO 40 K=1,M
        T = X*T/(AEPS-M-1+K)
        S = S + T
        IF (ABS(T).LT.EPS*ABS(S)) GO TO 50
 40   CONTINUE
C
 50   R9GMIT = 0.0
      ALGS = -MA*LOG(X) + ALGS
      IF (S.EQ.0.0 .OR. AEPS.EQ.0.0) GO TO 60
C
      SGNG2 = SGNGAM*SIGN(1.0,S)
      ALG2 = -X - ALGAP1 + LOG(ABS(S))
C
      IF (ALG2.GT.BOT) R9GMIT = SGNG2*EXP(ALG2)
      IF (ALGS.GT.BOT) R9GMIT = R9GMIT + EXP(ALGS)
      RETURN
C
 60   R9GMIT = EXP(ALGS)
      RETURN
C
      END


! { dg-do run }
! { dg-options "-Wall" }
! Program to check corner cases for DO statements.
program do_1
  implicit none
  integer i, j

  ! limit=HUGE(i), step > 1
  j = 0
  do i = HUGE(i) - 10, HUGE(i), 2
    j = j + 1
  end do
  if (j .ne. 6) STOP 1
  j = 0
  do i = HUGE(i) - 9, HUGE(i), 2
    j = j + 1
  end do
  if (j .ne. 5) STOP 2

  ! Same again, but unknown loop step
  if (test1(10, 1) .ne. 11) STOP 3
  if (test1(10, 2) .ne. 6) STOP 4
  if (test1(9, 2) .ne. 5) STOP 5

  ! Zero iterations
  j = 0
  do i = 1, 0, 1 ! { dg-warning "executed zero times" }
    j = j + 1
  end do
  if (j .ne. 0) STOP 6
  j = 0
  do i = 1, 0, 2 ! { dg-warning "executed zero times" }
    j = j + 1
  end do
  if (j .ne. 0) STOP 7
  j = 0
  do i = 1, 2, -1 ! { dg-warning "executed zero times" }
    j = j + 1
  end do
  if (j .ne. 0) STOP 8
  call test2 (0, 1)
  call test2 (0, 2)
  call test2 (2, -1)
  call test2 (2, -2)

  ! Bound near smallest value
  j = 0;
  do i = -HUGE(i), -HUGE(i), 10
    j = j + 1
  end do
  if (j .ne. 1) STOP 9
contains
! Returns the number of iterations performed.
function test1(r, step)
  implicit none
  integer test1, r, step
  integer k, n
  k = 0
  do n = HUGE(n) - r, HUGE(n), step
    k = k + 1
  end do
  test1 = k
end function

subroutine test2 (lim, step)
  implicit none
  integer lim, step
  integer k, n
  k = 0
  do n = 1, lim, step
    k = k + 1
  end do
  if (k .ne. 0) STOP 10
end subroutine
end program


! { dg-do run }
! PR34540 cshift, eoshift, kind=1 and kind=2 arguments.
! Test case thanks to Thomas Koenig.
module tst_foo
  implicit none
contains
  subroutine tst_optional(a,n1,n2)
    integer(kind=1), intent(in), optional:: n1
    integer(kind=2), intent(in), optional:: n2
    integer(kind=1), dimension(2) :: s1
    character(64) :: testbuf
    real, dimension(:,:) :: a
    s1 = (/1, 1/)
    write(testbuf,'(4F10.2)') cshift(a, shift=s1)
    if (testbuf /= "      2.00      1.00      4.00      3.00") CALL abort
    write(testbuf,'(4F10.2)') cshift(a,shift=s1,dim=n2)
    if (testbuf /= "      2.00      1.00      4.00      3.00") CALL abort
    write(testbuf,'(4F10.2)') eoshift(a,shift=s1,dim=n1)
    if (testbuf /= "      2.00      0.00      4.00      0.00") CALL abort
    write(testbuf,'(4F10.2)') eoshift(a,shift=s1,dim=n2)
    if (testbuf /= "      2.00      0.00      4.00      0.00") CALL abort
  end subroutine tst_optional
 subroutine sub(bound, dimmy)
   integer(kind=8), optional :: dimmy
   logical, optional :: bound
   logical :: lotto(4)
   character(20) :: testbuf
   lotto = .false.
   lotto = cshift((/.true.,.false.,.true.,.false./),1,dim=dimmy)
   write(testbuf,*) lotto
   if (trim(testbuf).ne." F T F T") call abort
   lotto = .false.
   lotto = eoshift((/.true.,.true.,.true.,.true./),1,boundary=bound,dim=dimmy)
   lotto = eoshift(lotto,1,dim=dimmy)
   write(testbuf,*) lotto
   if (trim(testbuf).ne." T T F F") call abort
 end subroutine
end module tst_foo

program main
  use tst_foo
  implicit none
  real, dimension(2,2) :: r
  integer(kind=1) :: d1
  integer(kind=2) :: d2
  data r /1.0, 2.0, 3.0, 4.0/
  d1 = 1_1
  d2 = 1_2
  call tst_optional(r,d1, d2)
  call sub(bound=.false., dimmy=1_8)
  call sub()
end program main


!
!
! Copyright (c) 2011 - 2015
!   University of Houston System and UT-Battelle, LLC.
! Copyright (c) 2009 - 2015
!   Silicon Graphics International Corp.  SHMEM is copyrighted
!   by Silicon Graphics International Corp. (SGI) The OpenSHMEM API
!   (shmem) is released by Open Source Software Solutions, Inc., under an
!   agreement with Silicon Graphics International Corp. (SGI).
!
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
!
! o Redistributions of source code must retain the above copyright notice,
!   this list of conditions and the following disclaimer.
!
! o Redistributions in binary form must reproduce the above copyright
!   notice, this list of conditions and the following disclaimer in the
!   documentation and/or other materials provided with the distribution.
!
! o Neither the name of the University of Houston System,
!   UT-Battelle, LLC. nor the names of its contributors may be used to
!   endorse or promote products derived from this software without specific
!   prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
! HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
! TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!

!**********************************************************************
!   pi.f - compute pi by integrating f(x) = 4/(1 + x**2)
!
!  (C) 2001 by Argonne UT-Battelle, LLC.
!      See COPYRIGHT in top-level directory.
!
!   Each node:
!    1) receives the number of rectangles used in the approximation.
!    2) calculates the areas of it's rectangles.
!    3) Synchronizes for a global summation.
!   Node 0 prints the result.
!
!  Variables:
!
!    pi  the calculated result
!    n   number of points of integration.
!    x           midpoint of each rectangle's interval
!    f           function to integrate
!    sum,pi      area of rectangles
!    tmp         temporary scratch space for global summation
!    i           do loop index
!****************************************************************************

function f(x)
  double precision x
  f = 4.d0 / (1.d0 + x*x)
end function

program main

  include 'shmem.fh'

  integer :: shmem_n_pes, shmem_my_pe

  double precision  PI25DT
  parameter        (PI25DT = 3.141592653589793238462643d0)

  double precision, save :: mypi, pi
  double precision       :: h, sum, x, a
  integer, save          :: n
  integer                :: myid, numprocs, i, rc

  integer :: psync_bcast(SHMEM_BCAST_SYNC_SIZE)
  data psync_bcast /SHMEM_BCAST_SYNC_SIZE*SHMEM_SYNC_VALUE/

  integer :: psync_reduce(SHMEM_REDUCE_SYNC_SIZE)
  data psync_reduce /SHMEM_REDUCE_SYNC_SIZE*SHMEM_SYNC_VALUE/

  real(kind=8), dimension(SHMEM_REDUCE_MIN_WRKDATA_SIZE), save :: pwrk

  call shmem_init ()
  myid = shmem_my_pe()
  numprocs = shmem_n_pes()
! print *, "Process ", myid, " of ", numprocs, " is alive"

  call shmem_barrier_all

10 if ( myid .eq. 0 ) then
     write(6,98)
98   format('Enter the number of intervals: (0 quits)')
     read(5,99) n
99   format(i10)
  endif

  call shmem_broadcast4(n, n, 1, 0, 0, 0, numprocs, psync_bcast)

  !                                 check for quit signal
  if ( n .le. 0 ) goto 30

  !                                 calculate the interval size
  h = 1.0d0/n

  sum  = 0.0d0
  do i = myid+1, n, numprocs
     x = h * (dble(i) - 0.5d0)
     sum = sum + f(x)
  end do
  mypi = h * sum

  !                                 collect all the partial sums
  call shmem_barrier_all
  call shmem_real8_sum_to_all(pi, mypi, 1, 0, 0, numprocs, pwrk, psync_reduce)

  !                                 node 0 prints the answer.
  if (myid .eq. 0) then
     write(6, 97) pi, abs(pi - PI25DT)
97   format('  pi is approximately: ', F18.16, '  Error is: ', F18.16)
  endif

  goto 10

30 stop

  call shmem_finalize()

end program main


!!## MODULE: FUNCTION  InterpGrid2S_Nearest
MODULE FUN_InterpGrid2S_Nearest
!!### PURPOSE
!! This subroutine interpolates a list of discrete
!! function values <F(1:N)> provided at points
!! <(x,y)=r(:,1:N)>, to a grid, given by <xout(1:M)>
!! and <yout(1:M)>, by simply using the value closest
!! to the grid point.

!!### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!### GLOBAL PROCEDURE MODULES
USE FUN_NEARLOC                                !!((06-A-FUN_NEARLOC.f90))
USE SUB_CLEAR                                  !!((04-A-SUB_CLEAR.f90))

!!### DEFAULT IMPLICIT
IMPLICIT NONE

!!### DEFAULT ACCESS
PRIVATE

!!### PROCEDURE OVERLOADING
INTERFACE InterpGrid2S_Nearest
 MODULE PROCEDURE InterpGrid2S_Nearest_Rsp
 MODULE PROCEDURE InterpGrid2S_Nearest_Rdp
END INTERFACE

!!### PUBLIC ACCESS LIST
PUBLIC :: InterpGrid2S_Nearest

!!### PROCEDURES
CONTAINS

!!### FUNCTION: InterpGrid2S_Nearest_Rsp
FUNCTION InterpGrid2S_Nearest_Rsp( F , r , xout , yout , errmsg , &
  errint)  RESULT(Fout)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "07-B-FUN_InterpGrid2S_Nearest_R.f90.hdr"
!!--begin--
INCLUDE "07-B-FUN_InterpGrid2S_Nearest_R.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION: InterpGrid2S_Nearest_Rdp
FUNCTION InterpGrid2S_Nearest_Rdp( F , r , xout , yout , errmsg , &
  errint)  RESULT(Fout)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "07-B-FUN_InterpGrid2S_Nearest_R.f90.hdr"
!!--begin--
INCLUDE "07-B-FUN_InterpGrid2S_Nearest_R.f90.bdy"
!!--end--
END FUNCTION

END MODULE


!
! 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
!
!   Check functions that return pointers

      module  mod
      contains
      function  vector  (a,b,c)
      integer a,b,c
      integer,  pointer  ::  vector(:)
      integer j
      allocate  (vector  (a))
      j = b
      do i = 1,a
      vector(i) = j
      j = j + c
      enddo
      end function
      function v2 (a,b,c)
      integer:: a,b,c
      integer:: v2(a)
      integer j
      j = b
      do i = lbound(v2,1),ubound(v2,1)
       v2(i) = j
       j = j + c
      enddo
      end function
      end module mod
      program tt
      use mod
      integer, pointer :: v(:)
      integer, parameter::n=37
      integer result(n),expect(n)
      data expect/0,2,4,6,8,10,12,1,2,3,4,2, &
        4,6,8,22,20,18,16,14,12,10,8,10,&
        20,30,40,50,60,70,80,90,100,2,4,6,0/
      result = 0
      result(2:7) = vector(6,2,2)
      v => vector(4,1,1)
      result(8:11) = v
      result(12:15) = vector(4,2,2)
      deallocate(v)
      result(16:23) = vector(8,22,-2)
      allocate(v(1:10))
      v = v2(10,10,10)
      result(24:33) = v
      result(34:36) = v2(3,2,2)
        ! print *,result
      call check(result,expect,n)
      end


module quicksort_mod
    implicit none

    private
    public :: qsort, lampsort

contains

    subroutine qsort(values)
        implicit none
        real, dimension(:), intent(inout) :: values

        call qsort_r(values, 1, size(values))
    end subroutine qsort

    recursive subroutine qsort_r(values, low, high)
        implicit none
        real, dimension(:), intent(inout) :: values
        integer, intent(in) :: low, high
        integer :: pivot

        if (low < high) then
            pivot = find_pivot(values, low, high)
            call qsort_r(values, low, pivot - 1)
            call qsort_r(values, pivot + 1, high)
        end if
    end subroutine qsort_r

    subroutine lampsort(values)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        real, dimension(:), intent(inout) :: values
        integer, dimension(:, :), allocatable :: indices
        integer :: current_indices, low, high, pivot, status

        allocate(indices(2, 1 + size(values)), stat=status)
        if (status /= 0) then
            write (unit=error_unit, fmt='(A)') &
                'error: can not allocate indices array'
            stop 51
        end if
        current_indices = 1
        indices(1, current_indices) = 1
        indices(2, current_indices) = size(values)
        do while (current_indices > 0)
            low = indices(1, current_indices)
            high = indices(2, current_indices)
            current_indices = current_indices - 1
            if (low < high) then
                pivot = find_pivot(values, low, high)
                ! print *, low, pivot, high, values(low), values(high)
                if ((pivot - 1) - low > 0) then
                    current_indices = current_indices + 1
                    indices(1, current_indices) = low
                    indices(2, current_indices) = pivot - 1
                end if
                if (high - (pivot + 1) > 0) then
                    current_indices = current_indices + 1
                    indices(1, current_indices) = pivot + 1
                    indices(2, current_indices) = high
                end if
            end if
        end do
    end subroutine lampsort

    subroutine swap_values(values, i, j)
        implicit none
        real, dimension(:), intent(inout) :: values
        integer, intent(in) :: i, j
        real :: tmp

        tmp = values(i)
        values(i) = values(j)
        values(j) = tmp
    end subroutine swap_values

    function find_pivot(values, low, high) result(pivot)
        implicit none
        real, dimension(:), intent(inout) :: values
        integer, intent(in) :: low, high
        integer :: pivot
        real :: pivot_value
        integer :: i

        pivot_value = values(high)
        pivot = low
        do i = low, high - 1
            if (values(i) < pivot_value) then
                call swap_values(values, i, pivot)
                pivot = pivot + 1
            end if
        end do
        call swap_values(values, pivot, high)
    end function find_pivot

end module quicksort_mod


      function cosin2(x1,y1,x2,y2)
C...01/09/78
      r=x1*x2+y1*y2
      cosin2=r*abs(r)/((x1**2+y1**2)*(x2**2+y2**2))
      return
      end


*DECK REDUC2
      SUBROUTINE REDUC2 (NM, N, A, B, DL, IERR)
C***BEGIN PROLOGUE  REDUC2
C***PURPOSE  Reduce a certain generalized symmetric eigenproblem to a
C            standard symmetric eigenproblem using Cholesky
C            factorization.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C1C
C***TYPE      SINGLE PRECISION (REDUC2-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure REDUC2,
C     NUM. MATH. 11, 99-110(1968) by Martin and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971).
C
C     This subroutine reduces the generalized SYMMETRIC eigenproblems
C     ABx=(LAMBDA)x OR BAy=(LAMBDA)y, where B is POSITIVE DEFINITE,
C     to the standard symmetric eigenproblem using the Cholesky
C     factorization of B.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A and B, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrices A and B.  If the Cholesky
C          factor L of B is already available, N should be prefixed
C          with a minus sign.  N is an INTEGER variable.
C
C        A and B contain the real symmetric input matrices.  Only
C          the full upper triangles of the matrices need be supplied.
C          If N is negative, the strict lower triangle of B contains,
C          instead, the strict lower triangle of its Cholesky factor L.
C          A and B are two-dimensional REAL arrays, dimensioned A(NM,N)
C          and B(NM,N).
C
C       DL contains, if N is negative, the diagonal elements of L.
C          DL is a one-dimensional REAL array, dimensioned DL(N).
C
C     On Output
C
C        A contains in its full lower triangle the full lower triangle
C          of the symmetric matrix derived from the reduction to the
C          standard form.  The strict upper triangle of A is unaltered.
C
C        B contains in its strict lower triangle the strict lower
C          triangle of its Cholesky factor L.  The full upper triangle
C          of B is unaltered.
C
C        DL contains the diagonal elements of L.
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          7*N+1      if B is not positive definite.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  REDUC2
C
      INTEGER I,J,K,N,I1,J1,NM,NN,IERR
      REAL A(NM,*),B(NM,*),DL(*)
      REAL X,Y
C
C***FIRST EXECUTABLE STATEMENT  REDUC2
      IERR = 0
      NN = ABS(N)
      IF (N .LT. 0) GO TO 100
C     .......... FORM L IN THE ARRAYS B AND DL ..........
      DO 80 I = 1, N
         I1 = I - 1
C
         DO 80 J = I, N
            X = B(I,J)
            IF (I .EQ. 1) GO TO 40
C
            DO 20 K = 1, I1
   20       X = X - B(I,K) * B(J,K)
C
   40       IF (J .NE. I) GO TO 60
            IF (X .LE. 0.0E0) GO TO 1000
            Y = SQRT(X)
            DL(I) = Y
            GO TO 80
   60       B(J,I) = X / Y
   80 CONTINUE
C     .......... FORM THE LOWER TRIANGLE OF A*L
C                IN THE LOWER TRIANGLE OF THE ARRAY A ..........
  100 DO 200 I = 1, NN
         I1 = I + 1
C
         DO 200 J = 1, I
            X = A(J,I) * DL(J)
            IF (J .EQ. I) GO TO 140
            J1 = J + 1
C
            DO 120 K = J1, I
  120       X = X + A(K,I) * B(K,J)
C
  140       IF (I .EQ. NN) GO TO 180
C
            DO 160 K = I1, NN
  160       X = X + A(I,K) * B(K,J)
C
  180       A(I,J) = X
  200 CONTINUE
C     .......... PRE-MULTIPLY BY TRANSPOSE(L) AND OVERWRITE ..........
      DO 300 I = 1, NN
         I1 = I + 1
         Y = DL(I)
C
         DO 300 J = 1, I
            X = Y * A(I,J)
            IF (I .EQ. NN) GO TO 280
C
            DO 260 K = I1, NN
  260       X = X + A(K,J) * B(K,I)
C
  280       A(I,J) = X
  300 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- B IS NOT POSITIVE DEFINITE ..........
 1000 IERR = 7 * N + 1
 1001 RETURN
      END


!
! FT verification routine.
!
      subroutine verify(n1, n2, n3, nt, cksum, verified)
        implicit none
        include 'npbparams.h'
!
! Arguments.
!

         integer n1, n2, n3, nt
         double complex cksum(0:nt)
	 logical verified

!
! Local variables.
!
         integer kt
         double complex cexpd(20)
         real*8 epsilon, err
!
! Initialize tolerance level and success flag.
!
         epsilon = 1.0d-12
         verified = .true.
!
         if ((n1 .eq. 64) .and. (n2 .eq. 64) .and.
     &            (n3 .eq. 64) .and. (nt .eq. 6)) then
!
! Class S reference values.
!
            cexpd(1) = dcmplx(554.6087004964D0, 484.5363331978D0)
            cexpd(2) = dcmplx(554.6385409189D0, 486.5304269511D0)
            cexpd(3) = dcmplx(554.6148406171D0, 488.3910722336D0)
            cexpd(4) = dcmplx(554.5423607415D0, 490.1273169046D0)
            cexpd(5) = dcmplx(554.4255039624D0, 491.7475857993D0)
            cexpd(6) = dcmplx(554.2683411902D0, 493.2597244941D0)

         else if ((n1 .eq. 128) .and. (n2 .eq. 128) .and.
     &            (n3 .eq. 32) .and. (nt .eq. 6)) then
!
! Class W reference values.
!
            cexpd(1) = dcmplx(567.3612178944D0, 529.3246849175D0)
            cexpd(2) = dcmplx(563.1436885271D0, 528.2149986629D0)
            cexpd(3) = dcmplx(559.4024089970D0, 527.0996558037D0)
            cexpd(4) = dcmplx(556.0698047020D0, 526.0027904925D0)
            cexpd(5) = dcmplx(553.0898991250D0, 524.9400845633D0)
            cexpd(6) = dcmplx(550.4159734538D0, 523.9212247086D0)
!
         else if ((n1 .eq. 256) .and. (n2 .eq. 256) .and.
     &            (n3 .eq. 128) .and. (nt .eq. 6)) then
!
! Class A reference values.
!
            cexpd(1) = dcmplx(504.6735008193D0, 511.4047905510D0)
            cexpd(2) = dcmplx(505.9412319734D0, 509.8809666433D0)
            cexpd(3) = dcmplx(506.9376896287D0, 509.8144042213D0)
            cexpd(4) = dcmplx(507.7892868474D0, 510.1336130759D0)
            cexpd(5) = dcmplx(508.5233095391D0, 510.4914655194D0)
            cexpd(6) = dcmplx(509.1487099959D0, 510.7917842803D0)
!
         else if ((n1 .eq. 512) .and. (n2 .eq. 256) .and.
     &            (n3 .eq. 256) .and. (nt .eq. 20)) then
!
! Class B reference values.
!
            cexpd(1)  = dcmplx(517.7643571579D0, 507.7803458597D0)
            cexpd(2)  = dcmplx(515.4521291263D0, 508.8249431599D0)
            cexpd(3)  = dcmplx(514.6409228649D0, 509.6208912659D0)
            cexpd(4)  = dcmplx(514.2378756213D0, 510.1023387619D0)
            cexpd(5)  = dcmplx(513.9626667737D0, 510.3976610617D0)
            cexpd(6)  = dcmplx(513.7423460082D0, 510.5948019802D0)
            cexpd(7)  = dcmplx(513.5547056878D0, 510.7404165783D0)
            cexpd(8)  = dcmplx(513.3910925466D0, 510.8576573661D0)
            cexpd(9)  = dcmplx(513.2470705390D0, 510.9577278523D0)
            cexpd(10) = dcmplx(513.1197729984D0, 511.0460304483D0)
            cexpd(11) = dcmplx(513.0070319283D0, 511.1252433800D0)
            cexpd(12) = dcmplx(512.9070537032D0, 511.1968077718D0)
            cexpd(13) = dcmplx(512.8182883502D0, 511.2616233064D0)
            cexpd(14) = dcmplx(512.7393733383D0, 511.3203605551D0)
            cexpd(15) = dcmplx(512.6691062020D0, 511.3735928093D0)
            cexpd(16) = dcmplx(512.6064276004D0, 511.4218460548D0)
            cexpd(17) = dcmplx(512.5504076570D0, 511.4656139760D0)
            cexpd(18) = dcmplx(512.5002331720D0, 511.5053595966D0)
            cexpd(19) = dcmplx(512.4551951846D0, 511.5415130407D0)
            cexpd(20) = dcmplx(512.4146770029D0, 511.5744692211D0)
!
         else if ((n1 .eq. 512) .and. (n2 .eq. 512) .and.
     &            (n3 .eq. 512) .and. (nt .eq. 20)) then
!
! Class C reference values.
!
            cexpd(1)  = dcmplx(519.5078707457D0, 514.9019699238D0)
            cexpd(2)  = dcmplx(515.5422171134D0, 512.7578201997D0)
            cexpd(3)  = dcmplx(514.4678022222D0, 512.2251847514D0)
            cexpd(4)  = dcmplx(514.0150594328D0, 512.1090289018D0)
            cexpd(5)  = dcmplx(513.7550426810D0, 512.1143685824D0)
            cexpd(6)  = dcmplx(513.5811056728D0, 512.1496764568D0)
            cexpd(7)  = dcmplx(513.4569343165D0, 512.1870921893D0)
            cexpd(8)  = dcmplx(513.3651975661D0, 512.2193250322D0)
            cexpd(9)  = dcmplx(513.2955192805D0, 512.2454735794D0)
            cexpd(10) = dcmplx(513.2410471738D0, 512.2663649603D0)
            cexpd(11) = dcmplx(513.1971141679D0, 512.2830879827D0)
            cexpd(12) = dcmplx(513.1605205716D0, 512.2965869718D0)
            cexpd(13) = dcmplx(513.1290734194D0, 512.3075927445D0)
            cexpd(14) = dcmplx(513.1012720314D0, 512.3166486553D0)
            cexpd(15) = dcmplx(513.0760908195D0, 512.3241541685D0)
            cexpd(16) = dcmplx(513.0528295923D0, 512.3304037599D0)
            cexpd(17) = dcmplx(513.0310107773D0, 512.3356167976D0)
            cexpd(18) = dcmplx(513.0103090133D0, 512.3399592211D0)
            cexpd(19) = dcmplx(512.9905029333D0, 512.3435588985D0)
            cexpd(20) = dcmplx(512.9714421109D0, 512.3465164008D0)
!
         else
!
            write (*,    120) 'NOT DONE'
            verified = .false.
!
         end if
!
! Verification test for results.
!
         if (verified) then

            do kt = 1, nt
              err = abs((cksum(kt)-cexpd(kt))/cexpd(kt))
              if (.not.(err.le.epsilon)) then
                verified = .false.
                goto 100
	      endif
            end do
  100       continue

            if (verified) then
               write (*,    120) 'PASSED'
            else
               write (*,    120) 'FAILED'
            end if

  120       format (' Verification test for FT ', a)
         end if
!
         return
      end


C
C       $Id: curvs1.f,v 1.4 2008-07-27 03:10:11 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
C NOTE: If you make any changes to this software, please remember to
C make the same changes to the corresponding double precision routine.
C
      SUBROUTINE CURVS1(N,X,Y,D,ISW,S,EPS,PARAM,XS,YS,XSP,YSP,
     +                  SIGMA,TEMP,IERR)
C
C  This subroutine determines the parameters necessary to
C  compute a smoothing spline under tension from data values
C  in the plane.  In general the curve will not pass through
C  the original data points.  For actual computation of points
C  on the curve it is necessary to call the subroutine CURVS2.
C
C  On input:
C
C    N
C      The number of points to be interpolated (N .GE. 2).
C
C    X
C      An array containing N X-coordinates of the input data.
C
C    Y
C      An array containing N Y-coordinates of the
C      input data. (adjacent X-Y pairs must be distinct, i.e.
C      either X(I) .NE. X(I+1) or Y(I) .NE. Y(I+1), for
C      I = 1,...,N-1.)
C
C    D
C      A parameter containing the observation weights.
C      this may either be an array of length N or a scalar
C      (interpreted as a constant).  The value of D
C      corresponding to the observation (X(K),Y(K)) should
C      be an approximation to the standard deviation of error.
C      Effectively the value of D controls how close the smoothed
C      curve comes to the input data points. If D is small
C      then the interpolated curve will pass close to the input data.
C      The larger the value of D, the more freedom the smooth curve
C      has in how close it comes to the input data values.
C
C    ISW
C      A switch indicating whether the parameter D is to be
C      considered a vector or a scalar,
C
C          = 0 if D is an array of length N,
C          = 1 if D is a scalar.
C
C    S
C      The value controlling the smoothing. this
C      must be non-negative.  For S equal to zero, the
C      subroutine does interpolation, larger values lead to
C      smoother funtions.  If parameter D contains standard
C      deviation estimates, a reasonable value for S is
C      FLOAT(N).
C
C    EPS
C      Contains a tolerance on the relative precision to
C      which S is to be interpreted. this must be greater than
C      or equal to zero and less than or equal to one.  A
C      reasonable value for EPS is SQRT(2./FLOAT(N)).
C
C    PARAM
C      An array of length at least N.
C
C    XS
C      An array of length at least N.
C
C    XSP
C      An array of length at least N.
C
C    YS
C      An array of length at least N.
C
C    YSP
C      An array of length at least N.
C
C    SIGMA
C      The tension factor.  This value indicates
C      the degree to which the first derivative part of the
C      smoothing functional is emphasized.  If SIGMA is nearly
C      zero (e.g. 0.001), the resulting curve is approximately a
C      cubic spline.  If SIGMA is large (e.g. 50.), the
C      resulting curve is nearly a polygonal line.  If sigma
C      equals zero a cubic spline results.  A standard value for
C      SIGMA is approximately 1.
C
C    TEMP
C      An array of length at least 19*N which is used
C      for scratch storage.
C
C
C  On output:
C
C    PARAM
C      PARAM(I) is the arc length of the curve up through
C      point (X(I),Y(I)), divided by the total arc length.
C
C    XS
C      The smoothed X-coordinate values.
C
C    XSP
C      The values of the second derivative of the
C      smoothed X-coordinate values at the given nodes.
C
C    YS
C      The smoothed Y-coordinate values.
C
C    YSP
C      The values of the second derivative of the
C      smoothed Y-coordinate values at the given nodes.
C
C    IERR
C      An error flag,
C         = 0 for normal return,
C         = 1 if N is less than 2,
C         = 2 if S is negative,
C         = 3 if EPS is negative or greater than one,
C         = 5 if a D-value is non-positive.
C
C  and
C
C    N, X, Y, D, ISW, S, EPS, and SIGMA are unaltered.
C
C this subroutine references package module CURVS.
C
      REAL X(N),Y(N),D(N),S,EPS,PARAM(N),XS(N),YS(N),XSP(N),YSP(N),
     +     SIGMA,TEMP(N,20)
C
C  Calculate the arc length of each polygonal segment.
C
      TEMP(1,1) = 0.
      DO 10 I=2,N
        IM1  = I-1
        TEMP(I,1) = SQRT((X(I)-X(IM1))**2 + (Y(I)-Y(IM1))**2)
   10 CONTINUE
C
C  Calculate the total arc length.
C
      TSM = 0
      DO 5 I=1,N
        TSM = TSM+TEMP(I,1)
    5 CONTINUE
C
C  Calculate the arc length parameter values at the input points.
C
      PARAM(1) = 0.
      DO 20 I=2,N
        SM = 0
        DO 30 J=1,I
          SM = SM+TEMP(J,1)
   30   CONTINUE
        PARAM(I) = SM/TSM
   20 CONTINUE
C
C  Get the smoothing coordinates for both X and Y.
C
      CALL CURVS(N,PARAM,X,D,ISW,S,EPS,XS,XSP,SIGMA,TEMP(1, 2),IERR)
      CALL CURVS(N,PARAM,Y,D,ISW,S,EPS,YS,YSP,SIGMA,TEMP(1,11),IERR)
C
      RETURN
      END


! ==============================================================================
! Subroutine: SETUPNUC (N)
!
! Purpose: Creates a table of nucleation probabilites between pairs of
!          nucleotides based on a worm like chain model.
!          See:
!          (1) Toan et al. J. Phys. Chem. B 112, 6094-6106 (2008).
!          (2) S. Kuznetsov and A. Ansari "A kinetic zipper model with
!          interchain interactions applied to nucleic acid hairpin
!          folding kinetics", Biophys J 102, 1001-111 (2012).
!
! Method: Uses the formula from:
!
! Arguments:
!
!             N - Number of nucleotides in the sequence.
!
! History:
!
! Version    Date         Comment
! --------   ----------   -----------------------
!            01/01/2015   Original Code
!
! Dependancies:
!
! Modules -
! Functions -
! Subroutines -
!
! Author(s): Eric Dykeman
!            Copyright (c) 2015 (Please Refer to LICENCE)
!
! ==============================================================================

      SUBROUTINE SETUPNUC (N)

        USE RNAVar, ONLY : pnuc,beta

        IMPLICIT NONE

        !=== ARGUMENTS ===!

        INTEGER, INTENT(IN) :: n

        !=== VARIABLES ===!

        INTEGER :: i

        DOUBLE PRECISION :: x,xi,e

        DOUBLE PRECISION, PARAMETER :: c = 0.1785714290d0
!       DOUBLE PRECISION, PARAMETER :: c2= 3.9274668195d8  !rate in (1/s)
        DOUBLE PRECISION, PARAMETER :: c2= 3.9274668195d2  !rate in (1/uS)
        DOUBLE PRECISION, PARAMETER :: xp= 4.0000000000d0

        IF ( ALLOCATED (pnuc) ) DEALLOCATE (pnuc)

        ALLOCATE (pnuc(n))

        pnuc(:) = 0.0d0

        DO i=5,n

          x  = c * DBLE(i-1)
          xi = 1.0d0 / x

          IF ( x <= xp ) THEN

            e = -7.0270d0 * xi + 0.4920d0 * x
            x = 84.90d0 * ( xi ** 5.50d0 )
            x = c2 * x / beta

            pnuc(i) = x * DEXP(e)

          ELSE

            x = xi * xi

            e = 1.0d0 - 0.6250d0 * xi - 0.12343750d0 * x
            x = c2 * x / beta

            pnuc(i) = x * e

          ENDIF

        ENDDO

        RETURN

      END SUBROUTINE SETUPNUC


REAL*8 FUNCTION GAUNT1(LP,L,LS,MP,M,MS)
  IMPLICIT NONE
  !
  !        Arguments
  !
  INTEGER, intent(in) :: L, LP, LS, M, MP, MS
  !..................................................................
  !
  !   GAUNT computes the integral of
  !      CONJG(Y(LP,MP))*Y(L,M)*Y(LS,MS) for LP+L+LS .LE. 23
  !   using gaussian quadrature with N=12 as given by
  !      M. Abramowitz and I.A. Stegun,
  !      'Handbook of Mathematical Functions',
  !      NBS Applied Mathematics Series 55 (1968), pages 887 and 916
  !   written by Bruce Harmon based on suggestion by W. Rudge
  !   Iowa State Sept.1973
  !
  !   extended by M. Weinert and E. Wimmer
  !   Northwestern University March 1980
  !
  !..................................................................
  INTEGER            MAXDIM, N
  PARAMETER          (MAXDIM = 81, N = 6)
  DOUBLE PRECISION   ZERO
  PARAMETER          (ZERO = 0.0D+0)
  !        Common blocks
  DOUBLE PRECISION   YR(N,MAXDIM)
  COMMON  /ASSLEG/   YR
  SAVE    /ASSLEG/
  !
  !        Local Scalars
  !
  INTEGER            I, IL, ILP, ILS
  DOUBLE PRECISION   S
  DOUBLE PRECISION   W(N)
  !
  !        Data statements
  !
  DATA W /0.24914704581340D+0, 0.23349253653836D+0,0.20316742672307D+0, 0.16007832854335D+0,0.10693932599532D+0, 0.04717533638651D+0/
  !
  IL = L*(L+1) + M + 1
  ILP = LP*(LP+1) + MP + 1
  ILS = LS*(LS+1) + MS + 1
  S = ZERO
  DO I = 1, N
     S = S + W(I)*YR(I,ILP)*YR(I,IL)*YR(I,ILS)
  ENDDO
  GAUNT1 = S
  !
  RETURN
END FUNCTION GAUNT1


! ----------------------------------------------------------
	subroutine pstomo(m,n,x,u,v,w,itmax,nz,aaa,ncolrow,ncol)
!
!   subroutine to solve the linear tomographic problem Ax=u using the
!   lsqr algorithm.
!
!   Input: m is the number of data (rows), n the number of unknowns (columns),
!      u contains the data (is overwritten), itmax is the number of iterations.
!   Output: x is the solution; intermediate results are written to a diskfile
!      named <tomo.int> which must not already exist before the call.
!   Scratch: arrays v(n) and w(n)
!   Subroutines: routines avpu and atupv must be supplied by the user.
!      avpu(m,n,u,v) computes u=u+A*v for given input u,v (overwrites u)
!      atupv(m,n,u,v) computes v=v+A(transpose)*u for given u,v (overwrites v)
!
	real x(n),u(m),v(n),w(n)
	real aaa(nz)
	integer ncolrow(nz),ncol(m)
	x=0.
	v=0.
	call normlz(m,u,beta)
	b1=beta
	!write(*,*)' b1=',b1
	call atupv(m,n,u,v,nz,aaa,ncolrow,ncol)
	!write(*,*)' b1=',b1
	call normlz(n,v,alfa)
	!write(*,*)' alfa=',alfa,' beta=',beta
	rhobar=alfa
	phibar=beta
	w=v
	do iter =1,itmax 		! repeat for fixed nr of iterations
		!if(mod(iter,20).eq.0) write(*,*)' iter=',iter
   	   a=-alfa
   	   u=a*u			! bidiagonalization
   	   call avpu(m,n,u,v,nz,aaa,ncolrow,ncol)
   	   call normlz(m,u,beta)
   	   b=-beta
   	   v=b*v
   	   call atupv(m,n,u,v,nz,aaa,ncolrow,ncol)
   	   call normlz(n,v,alfa)
!	write(*,*)' rhobar*rhobar+beta*beta=',rhobar*rhobar+beta*beta
	if(rhobar*rhobar+beta*beta.lt.0.) then
		!write(*,*)' rhobar*rhobar+beta*beta=',rhobar*rhobar+beta*beta
	end if
   	   rho=sqrt(rhobar*rhobar+beta*beta)	! modified QR factorization
   	   c=rhobar/rho
   	   s=beta/rho
   	   teta=s*alfa
   	   rhobar=-c*alfa
   	   phi=c*phibar
   	   phibar=s*phibar
   	   t1=phi/rho
   	   t2=-teta/rho
   	   xnorm=0.0
   	   do i=1,n				! update solution x and storage vector w
      	      x(i)=t1*w(i)+x(i)
      	      xnorm=xnorm+abs(x(i))
      	      w(i)=t2*w(i)+v(i)
           end do
   	   r=phibar/b1
   	   xnorm=xnorm/n
	end do
	return
	end

	subroutine avpu(m,n,u,v,nz,aaa,ncolrow,ncol)		! computes u=u+a*v
	real u(m),v(n)
	real aaa(nz)
	integer ncolrow(nz),ncol(m)
	kount=0
	do i=1,m 				! work row by row
  	   nc=ncol(i)
  	   if (nc.eq.0) cycle
  	   do j=1,nc
    	      kount=kount+1
              u(i)=u(i)+aaa(kount)*v(ncolrow(kount))
 	   end do
	end do
	return
	end

	subroutine atupv(m,n,u,v,nz,aaa,ncolrow,ncol)		! computes v=v+a(transpose)*u
	real u(m),v(n)
	real aaa(nz)
	integer ncolrow(nz),ncol(m)
	kount=0
	!write(*,*)' m=',m,' nz=',nz,' n=',n
	do i=1,m 				! work row by row (here too!)
		!if(mod(i,100).eq.0)write(*,*)' i=',i
  		nc=ncol(i)
!if(i.ge.10920)write(*,*)' i=',i,' nc=',nc
!		if(i.ge.24662)write(*,*)' i=',i
  	   if (nc.eq.0) cycle
  	   do j=1,nc
    		kount=kount+1
!if(i.eq.10920)write(*,*)' kount=',kount,' j=',j
    		jj=ncolrow(kount)
!if(i.eq.10920) write(*,*)' i=',i,kount,' aaa=',aaa(kount),' u=',u(i)
!	if(i.ge.24662)write(*,*)' jj=',jj
    		v(jj)=v(jj)+aaa(kount)*u(i)	! add to the right vector element
!	if(i.ge.24662)write(*,*)' v(jj)=',v(jj)
	   end do
	end do
	!write(*,'(15f5.1)')(v(i),i=300,500)
	!do i=300,500
		!write(*,*)i,v(i)
	!end do
	!write(*,*)' n=',n
	return
	end

	subroutine normlz(n,x,s)
	real x(n)
	s=0.
	!write(*,'(10f5.1)')(x(i),i=1,n)
	do i=1,n
	   s=s+x(i)**2
	end do
	!write(*,*)' s=',s
	s=sqrt(s)
	ss=1./s
	x=x*ss
	return
	end

	function vref(z, nma,hma,vma)
	real hma(300),vma(300)
	do ilay=2,nma
		z1=hma(ilay-1)
		z2=hma(ilay)
		if(z.ge.z1.and.z.le.z2) then
			v1=vma(ilay-1)
			v2=vma(ilay)
			vref=v1+(v2-v1)/(z2-z1)*(z-z1)
		end if
	end do
	return
	end