c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine exact_solution(xi,eta,zeta,dtemp)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     this function returns the exact solution at point xi, eta, zeta
c---------------------------------------------------------------------

      include 'header.h'

      double precision  xi, eta, zeta, dtemp(5)
      integer m

      do m = 1, 5
         dtemp(m) =  ce(m,1) +
     >     xi*(ce(m,2) + xi*(ce(m,5) + xi*(ce(m,8) + xi*ce(m,11)))) +
     >     eta*(ce(m,3) + eta*(ce(m,6) + eta*(ce(m,9) + eta*ce(m,12))))+
     >     zeta*(ce(m,4) + zeta*(ce(m,7) + zeta*(ce(m,10) +
     >     zeta*ce(m,13))))
      enddo

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine matvec_sub(ablock,avec,bvec)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     subtracts bvec=bvec - ablock*avec
c---------------------------------------------------------------------

      implicit none

      double precision ablock,avec,bvec
      dimension ablock(5,5),avec(5),bvec(5)
      integer i

      do i=1,5
c---------------------------------------------------------------------
c            rhs(i,ic,jc,kc) = rhs(i,ic,jc,kc)
c     $           - lhs(i,1,ablock,ia)*
c---------------------------------------------------------------------
         bvec(i) = bvec(i) - ablock(i,1)*avec(1)
     >                     - ablock(i,2)*avec(2)
     >                     - ablock(i,3)*avec(3)
     >                     - ablock(i,4)*avec(4)
     >                     - ablock(i,5)*avec(5)
      enddo

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine matmul_sub(ablock, bblock, cblock)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     subtracts a(i,j,k) X b(i,j,k) from c(i,j,k)
c---------------------------------------------------------------------

      implicit none

      double precision ablock, bblock, cblock
      dimension ablock(5,5), bblock(5,5), cblock(5,5)
      integer j

      do j=1,5
         cblock(1,j) = cblock(1,j) - ablock(1,1)*bblock(1,j)
     >                             - ablock(1,2)*bblock(2,j)
     >                             - ablock(1,3)*bblock(3,j)
     >                             - ablock(1,4)*bblock(4,j)
     >                             - ablock(1,5)*bblock(5,j)
         cblock(2,j) = cblock(2,j) - ablock(2,1)*bblock(1,j)
     >                             - ablock(2,2)*bblock(2,j)
     >                             - ablock(2,3)*bblock(3,j)
     >                             - ablock(2,4)*bblock(4,j)
     >                             - ablock(2,5)*bblock(5,j)
         cblock(3,j) = cblock(3,j) - ablock(3,1)*bblock(1,j)
     >                             - ablock(3,2)*bblock(2,j)
     >                             - ablock(3,3)*bblock(3,j)
     >                             - ablock(3,4)*bblock(4,j)
     >                             - ablock(3,5)*bblock(5,j)
         cblock(4,j) = cblock(4,j) - ablock(4,1)*bblock(1,j)
     >                             - ablock(4,2)*bblock(2,j)
     >                             - ablock(4,3)*bblock(3,j)
     >                             - ablock(4,4)*bblock(4,j)
     >                             - ablock(4,5)*bblock(5,j)
         cblock(5,j) = cblock(5,j) - ablock(5,1)*bblock(1,j)
     >                             - ablock(5,2)*bblock(2,j)
     >                             - ablock(5,3)*bblock(3,j)
     >                             - ablock(5,4)*bblock(4,j)
     >                             - ablock(5,5)*bblock(5,j)
      enddo

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine binvcrhs( lhs,c,r )

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c
c---------------------------------------------------------------------

      implicit none

      double precision pivot, coeff, lhs
      dimension lhs(5,5)
      double precision c(5,5), r(5)

c---------------------------------------------------------------------
c
c---------------------------------------------------------------------

      pivot = 1.00d0/lhs(1,1)
      lhs(1,2) = lhs(1,2)*pivot
      lhs(1,3) = lhs(1,3)*pivot
      lhs(1,4) = lhs(1,4)*pivot
      lhs(1,5) = lhs(1,5)*pivot
      c(1,1) = c(1,1)*pivot
      c(1,2) = c(1,2)*pivot
      c(1,3) = c(1,3)*pivot
      c(1,4) = c(1,4)*pivot
      c(1,5) = c(1,5)*pivot
      r(1)   = r(1)  *pivot

      coeff = lhs(2,1)
      lhs(2,2)= lhs(2,2) - coeff*lhs(1,2)
      lhs(2,3)= lhs(2,3) - coeff*lhs(1,3)
      lhs(2,4)= lhs(2,4) - coeff*lhs(1,4)
      lhs(2,5)= lhs(2,5) - coeff*lhs(1,5)
      c(2,1) = c(2,1) - coeff*c(1,1)
      c(2,2) = c(2,2) - coeff*c(1,2)
      c(2,3) = c(2,3) - coeff*c(1,3)
      c(2,4) = c(2,4) - coeff*c(1,4)
      c(2,5) = c(2,5) - coeff*c(1,5)
      r(2)   = r(2)   - coeff*r(1)

      coeff = lhs(3,1)
      lhs(3,2)= lhs(3,2) - coeff*lhs(1,2)
      lhs(3,3)= lhs(3,3) - coeff*lhs(1,3)
      lhs(3,4)= lhs(3,4) - coeff*lhs(1,4)
      lhs(3,5)= lhs(3,5) - coeff*lhs(1,5)
      c(3,1) = c(3,1) - coeff*c(1,1)
      c(3,2) = c(3,2) - coeff*c(1,2)
      c(3,3) = c(3,3) - coeff*c(1,3)
      c(3,4) = c(3,4) - coeff*c(1,4)
      c(3,5) = c(3,5) - coeff*c(1,5)
      r(3)   = r(3)   - coeff*r(1)

      coeff = lhs(4,1)
      lhs(4,2)= lhs(4,2) - coeff*lhs(1,2)
      lhs(4,3)= lhs(4,3) - coeff*lhs(1,3)
      lhs(4,4)= lhs(4,4) - coeff*lhs(1,4)
      lhs(4,5)= lhs(4,5) - coeff*lhs(1,5)
      c(4,1) = c(4,1) - coeff*c(1,1)
      c(4,2) = c(4,2) - coeff*c(1,2)
      c(4,3) = c(4,3) - coeff*c(1,3)
      c(4,4) = c(4,4) - coeff*c(1,4)
      c(4,5) = c(4,5) - coeff*c(1,5)
      r(4)   = r(4)   - coeff*r(1)

      coeff = lhs(5,1)
      lhs(5,2)= lhs(5,2) - coeff*lhs(1,2)
      lhs(5,3)= lhs(5,3) - coeff*lhs(1,3)
      lhs(5,4)= lhs(5,4) - coeff*lhs(1,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(1,5)
      c(5,1) = c(5,1) - coeff*c(1,1)
      c(5,2) = c(5,2) - coeff*c(1,2)
      c(5,3) = c(5,3) - coeff*c(1,3)
      c(5,4) = c(5,4) - coeff*c(1,4)
      c(5,5) = c(5,5) - coeff*c(1,5)
      r(5)   = r(5)   - coeff*r(1)

      pivot = 1.00d0/lhs(2,2)
      lhs(2,3) = lhs(2,3)*pivot
      lhs(2,4) = lhs(2,4)*pivot
      lhs(2,5) = lhs(2,5)*pivot
      c(2,1) = c(2,1)*pivot
      c(2,2) = c(2,2)*pivot
      c(2,3) = c(2,3)*pivot
      c(2,4) = c(2,4)*pivot
      c(2,5) = c(2,5)*pivot
      r(2)   = r(2)  *pivot

      coeff = lhs(1,2)
      lhs(1,3)= lhs(1,3) - coeff*lhs(2,3)
      lhs(1,4)= lhs(1,4) - coeff*lhs(2,4)
      lhs(1,5)= lhs(1,5) - coeff*lhs(2,5)
      c(1,1) = c(1,1) - coeff*c(2,1)
      c(1,2) = c(1,2) - coeff*c(2,2)
      c(1,3) = c(1,3) - coeff*c(2,3)
      c(1,4) = c(1,4) - coeff*c(2,4)
      c(1,5) = c(1,5) - coeff*c(2,5)
      r(1)   = r(1)   - coeff*r(2)

      coeff = lhs(3,2)
      lhs(3,3)= lhs(3,3) - coeff*lhs(2,3)
      lhs(3,4)= lhs(3,4) - coeff*lhs(2,4)
      lhs(3,5)= lhs(3,5) - coeff*lhs(2,5)
      c(3,1) = c(3,1) - coeff*c(2,1)
      c(3,2) = c(3,2) - coeff*c(2,2)
      c(3,3) = c(3,3) - coeff*c(2,3)
      c(3,4) = c(3,4) - coeff*c(2,4)
      c(3,5) = c(3,5) - coeff*c(2,5)
      r(3)   = r(3)   - coeff*r(2)

      coeff = lhs(4,2)
      lhs(4,3)= lhs(4,3) - coeff*lhs(2,3)
      lhs(4,4)= lhs(4,4) - coeff*lhs(2,4)
      lhs(4,5)= lhs(4,5) - coeff*lhs(2,5)
      c(4,1) = c(4,1) - coeff*c(2,1)
      c(4,2) = c(4,2) - coeff*c(2,2)
      c(4,3) = c(4,3) - coeff*c(2,3)
      c(4,4) = c(4,4) - coeff*c(2,4)
      c(4,5) = c(4,5) - coeff*c(2,5)
      r(4)   = r(4)   - coeff*r(2)

      coeff = lhs(5,2)
      lhs(5,3)= lhs(5,3) - coeff*lhs(2,3)
      lhs(5,4)= lhs(5,4) - coeff*lhs(2,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(2,5)
      c(5,1) = c(5,1) - coeff*c(2,1)
      c(5,2) = c(5,2) - coeff*c(2,2)
      c(5,3) = c(5,3) - coeff*c(2,3)
      c(5,4) = c(5,4) - coeff*c(2,4)
      c(5,5) = c(5,5) - coeff*c(2,5)
      r(5)   = r(5)   - coeff*r(2)

      pivot = 1.00d0/lhs(3,3)
      lhs(3,4) = lhs(3,4)*pivot
      lhs(3,5) = lhs(3,5)*pivot
      c(3,1) = c(3,1)*pivot
      c(3,2) = c(3,2)*pivot
      c(3,3) = c(3,3)*pivot
      c(3,4) = c(3,4)*pivot
      c(3,5) = c(3,5)*pivot
      r(3)   = r(3)  *pivot

      coeff = lhs(1,3)
      lhs(1,4)= lhs(1,4) - coeff*lhs(3,4)
      lhs(1,5)= lhs(1,5) - coeff*lhs(3,5)
      c(1,1) = c(1,1) - coeff*c(3,1)
      c(1,2) = c(1,2) - coeff*c(3,2)
      c(1,3) = c(1,3) - coeff*c(3,3)
      c(1,4) = c(1,4) - coeff*c(3,4)
      c(1,5) = c(1,5) - coeff*c(3,5)
      r(1)   = r(1)   - coeff*r(3)

      coeff = lhs(2,3)
      lhs(2,4)= lhs(2,4) - coeff*lhs(3,4)
      lhs(2,5)= lhs(2,5) - coeff*lhs(3,5)
      c(2,1) = c(2,1) - coeff*c(3,1)
      c(2,2) = c(2,2) - coeff*c(3,2)
      c(2,3) = c(2,3) - coeff*c(3,3)
      c(2,4) = c(2,4) - coeff*c(3,4)
      c(2,5) = c(2,5) - coeff*c(3,5)
      r(2)   = r(2)   - coeff*r(3)

      coeff = lhs(4,3)
      lhs(4,4)= lhs(4,4) - coeff*lhs(3,4)
      lhs(4,5)= lhs(4,5) - coeff*lhs(3,5)
      c(4,1) = c(4,1) - coeff*c(3,1)
      c(4,2) = c(4,2) - coeff*c(3,2)
      c(4,3) = c(4,3) - coeff*c(3,3)
      c(4,4) = c(4,4) - coeff*c(3,4)
      c(4,5) = c(4,5) - coeff*c(3,5)
      r(4)   = r(4)   - coeff*r(3)

      coeff = lhs(5,3)
      lhs(5,4)= lhs(5,4) - coeff*lhs(3,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(3,5)
      c(5,1) = c(5,1) - coeff*c(3,1)
      c(5,2) = c(5,2) - coeff*c(3,2)
      c(5,3) = c(5,3) - coeff*c(3,3)
      c(5,4) = c(5,4) - coeff*c(3,4)
      c(5,5) = c(5,5) - coeff*c(3,5)
      r(5)   = r(5)   - coeff*r(3)

      pivot = 1.00d0/lhs(4,4)
      lhs(4,5) = lhs(4,5)*pivot
      c(4,1) = c(4,1)*pivot
      c(4,2) = c(4,2)*pivot
      c(4,3) = c(4,3)*pivot
      c(4,4) = c(4,4)*pivot
      c(4,5) = c(4,5)*pivot
      r(4)   = r(4)  *pivot

      coeff = lhs(1,4)
      lhs(1,5)= lhs(1,5) - coeff*lhs(4,5)
      c(1,1) = c(1,1) - coeff*c(4,1)
      c(1,2) = c(1,2) - coeff*c(4,2)
      c(1,3) = c(1,3) - coeff*c(4,3)
      c(1,4) = c(1,4) - coeff*c(4,4)
      c(1,5) = c(1,5) - coeff*c(4,5)
      r(1)   = r(1)   - coeff*r(4)

      coeff = lhs(2,4)
      lhs(2,5)= lhs(2,5) - coeff*lhs(4,5)
      c(2,1) = c(2,1) - coeff*c(4,1)
      c(2,2) = c(2,2) - coeff*c(4,2)
      c(2,3) = c(2,3) - coeff*c(4,3)
      c(2,4) = c(2,4) - coeff*c(4,4)
      c(2,5) = c(2,5) - coeff*c(4,5)
      r(2)   = r(2)   - coeff*r(4)

      coeff = lhs(3,4)
      lhs(3,5)= lhs(3,5) - coeff*lhs(4,5)
      c(3,1) = c(3,1) - coeff*c(4,1)
      c(3,2) = c(3,2) - coeff*c(4,2)
      c(3,3) = c(3,3) - coeff*c(4,3)
      c(3,4) = c(3,4) - coeff*c(4,4)
      c(3,5) = c(3,5) - coeff*c(4,5)
      r(3)   = r(3)   - coeff*r(4)

      coeff = lhs(5,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(4,5)
      c(5,1) = c(5,1) - coeff*c(4,1)
      c(5,2) = c(5,2) - coeff*c(4,2)
      c(5,3) = c(5,3) - coeff*c(4,3)
      c(5,4) = c(5,4) - coeff*c(4,4)
      c(5,5) = c(5,5) - coeff*c(4,5)
      r(5)   = r(5)   - coeff*r(4)

      pivot = 1.00d0/lhs(5,5)
      c(5,1) = c(5,1)*pivot
      c(5,2) = c(5,2)*pivot
      c(5,3) = c(5,3)*pivot
      c(5,4) = c(5,4)*pivot
      c(5,5) = c(5,5)*pivot
      r(5)   = r(5)  *pivot

      coeff = lhs(1,5)
      c(1,1) = c(1,1) - coeff*c(5,1)
      c(1,2) = c(1,2) - coeff*c(5,2)
      c(1,3) = c(1,3) - coeff*c(5,3)
      c(1,4) = c(1,4) - coeff*c(5,4)
      c(1,5) = c(1,5) - coeff*c(5,5)
      r(1)   = r(1)   - coeff*r(5)

      coeff = lhs(2,5)
      c(2,1) = c(2,1) - coeff*c(5,1)
      c(2,2) = c(2,2) - coeff*c(5,2)
      c(2,3) = c(2,3) - coeff*c(5,3)
      c(2,4) = c(2,4) - coeff*c(5,4)
      c(2,5) = c(2,5) - coeff*c(5,5)
      r(2)   = r(2)   - coeff*r(5)

      coeff = lhs(3,5)
      c(3,1) = c(3,1) - coeff*c(5,1)
      c(3,2) = c(3,2) - coeff*c(5,2)
      c(3,3) = c(3,3) - coeff*c(5,3)
      c(3,4) = c(3,4) - coeff*c(5,4)
      c(3,5) = c(3,5) - coeff*c(5,5)
      r(3)   = r(3)   - coeff*r(5)

      coeff = lhs(4,5)
      c(4,1) = c(4,1) - coeff*c(5,1)
      c(4,2) = c(4,2) - coeff*c(5,2)
      c(4,3) = c(4,3) - coeff*c(5,3)
      c(4,4) = c(4,4) - coeff*c(5,4)
      c(4,5) = c(4,5) - coeff*c(5,5)
      r(4)   = r(4)   - coeff*r(5)

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine binvrhs( lhs,r )

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c
c---------------------------------------------------------------------

      implicit none

      double precision pivot, coeff, lhs
      dimension lhs(5,5)
      double precision r(5)

c---------------------------------------------------------------------
c
c---------------------------------------------------------------------

      pivot = 1.00d0/lhs(1,1)
      lhs(1,2) = lhs(1,2)*pivot
      lhs(1,3) = lhs(1,3)*pivot
      lhs(1,4) = lhs(1,4)*pivot
      lhs(1,5) = lhs(1,5)*pivot
      r(1)   = r(1)  *pivot

      coeff = lhs(2,1)
      lhs(2,2)= lhs(2,2) - coeff*lhs(1,2)
      lhs(2,3)= lhs(2,3) - coeff*lhs(1,3)
      lhs(2,4)= lhs(2,4) - coeff*lhs(1,4)
      lhs(2,5)= lhs(2,5) - coeff*lhs(1,5)
      r(2)   = r(2)   - coeff*r(1)

      coeff = lhs(3,1)
      lhs(3,2)= lhs(3,2) - coeff*lhs(1,2)
      lhs(3,3)= lhs(3,3) - coeff*lhs(1,3)
      lhs(3,4)= lhs(3,4) - coeff*lhs(1,4)
      lhs(3,5)= lhs(3,5) - coeff*lhs(1,5)
      r(3)   = r(3)   - coeff*r(1)

      coeff = lhs(4,1)
      lhs(4,2)= lhs(4,2) - coeff*lhs(1,2)
      lhs(4,3)= lhs(4,3) - coeff*lhs(1,3)
      lhs(4,4)= lhs(4,4) - coeff*lhs(1,4)
      lhs(4,5)= lhs(4,5) - coeff*lhs(1,5)
      r(4)   = r(4)   - coeff*r(1)

      coeff = lhs(5,1)
      lhs(5,2)= lhs(5,2) - coeff*lhs(1,2)
      lhs(5,3)= lhs(5,3) - coeff*lhs(1,3)
      lhs(5,4)= lhs(5,4) - coeff*lhs(1,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(1,5)
      r(5)   = r(5)   - coeff*r(1)

      pivot = 1.00d0/lhs(2,2)
      lhs(2,3) = lhs(2,3)*pivot
      lhs(2,4) = lhs(2,4)*pivot
      lhs(2,5) = lhs(2,5)*pivot
      r(2)   = r(2)  *pivot

      coeff = lhs(1,2)
      lhs(1,3)= lhs(1,3) - coeff*lhs(2,3)
      lhs(1,4)= lhs(1,4) - coeff*lhs(2,4)
      lhs(1,5)= lhs(1,5) - coeff*lhs(2,5)
      r(1)   = r(1)   - coeff*r(2)

      coeff = lhs(3,2)
      lhs(3,3)= lhs(3,3) - coeff*lhs(2,3)
      lhs(3,4)= lhs(3,4) - coeff*lhs(2,4)
      lhs(3,5)= lhs(3,5) - coeff*lhs(2,5)
      r(3)   = r(3)   - coeff*r(2)

      coeff = lhs(4,2)
      lhs(4,3)= lhs(4,3) - coeff*lhs(2,3)
      lhs(4,4)= lhs(4,4) - coeff*lhs(2,4)
      lhs(4,5)= lhs(4,5) - coeff*lhs(2,5)
      r(4)   = r(4)   - coeff*r(2)

      coeff = lhs(5,2)
      lhs(5,3)= lhs(5,3) - coeff*lhs(2,3)
      lhs(5,4)= lhs(5,4) - coeff*lhs(2,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(2,5)
      r(5)   = r(5)   - coeff*r(2)

      pivot = 1.00d0/lhs(3,3)
      lhs(3,4) = lhs(3,4)*pivot
      lhs(3,5) = lhs(3,5)*pivot
      r(3)   = r(3)  *pivot

      coeff = lhs(1,3)
      lhs(1,4)= lhs(1,4) - coeff*lhs(3,4)
      lhs(1,5)= lhs(1,5) - coeff*lhs(3,5)
      r(1)   = r(1)   - coeff*r(3)

      coeff = lhs(2,3)
      lhs(2,4)= lhs(2,4) - coeff*lhs(3,4)
      lhs(2,5)= lhs(2,5) - coeff*lhs(3,5)
      r(2)   = r(2)   - coeff*r(3)

      coeff = lhs(4,3)
      lhs(4,4)= lhs(4,4) - coeff*lhs(3,4)
      lhs(4,5)= lhs(4,5) - coeff*lhs(3,5)
      r(4)   = r(4)   - coeff*r(3)

      coeff = lhs(5,3)
      lhs(5,4)= lhs(5,4) - coeff*lhs(3,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(3,5)
      r(5)   = r(5)   - coeff*r(3)

      pivot = 1.00d0/lhs(4,4)
      lhs(4,5) = lhs(4,5)*pivot
      r(4)   = r(4)  *pivot

      coeff = lhs(1,4)
      lhs(1,5)= lhs(1,5) - coeff*lhs(4,5)
      r(1)   = r(1)   - coeff*r(4)

      coeff = lhs(2,4)
      lhs(2,5)= lhs(2,5) - coeff*lhs(4,5)
      r(2)   = r(2)   - coeff*r(4)

      coeff = lhs(3,4)
      lhs(3,5)= lhs(3,5) - coeff*lhs(4,5)
      r(3)   = r(3)   - coeff*r(4)

      coeff = lhs(5,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(4,5)
      r(5)   = r(5)   - coeff*r(4)

      pivot = 1.00d0/lhs(5,5)
      r(5)   = r(5)  *pivot

      coeff = lhs(1,5)
      r(1)   = r(1)   - coeff*r(5)

      coeff = lhs(2,5)
      r(2)   = r(2)   - coeff*r(5)

      coeff = lhs(3,5)
      r(3)   = r(3)   - coeff*r(5)

      coeff = lhs(4,5)
      r(4)   = r(4)   - coeff*r(5)

      return
      end


!*==dblat1.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022

!> \brief \b DBLAT1
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       PROGRAM DBLAT1
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!>    Test program for the DOUBLE PRECISION Level 1 BLAS.
!>
!>    Based upon the original BLAS test routine together with:
!>    F06EAF Example Program Text
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date April 2012
!
!> \ingroup double_blas_testing
!
!  =====================================================================
      PROGRAM DBLAT1
      IMPLICIT NONE
!*--DBLAT142
!
!  -- Reference BLAS test routine (version 3.8.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     April 2012
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , N
      LOGICAL PASs
!     .. Local Scalars ..
      DOUBLE PRECISION sfac
      INTEGER ic
!     .. External Subroutines ..
      EXTERNAL CHECK0 , CHECK1 , CHECK2 , CHECK3 , HEADER
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , PASs
!     .. Data statements ..
      DATA sfac/9.765625D-4/
!     .. Executable Statements ..
      WRITE (NOUT,99001)
!
99001 FORMAT (' Real BLAS Test Program Results',/1X)
      DO ic = 1 , 13
         ICAse = ic
         CALL HEADER
!
!        .. Initialize  PASS,  INCX,  and INCY for a new case. ..
!        .. the value 9999 for INCX or INCY will appear in the ..
!        .. detailed  output, if any, for cases  that do not involve ..
!        .. these parameters ..
!
         PASs = .TRUE.
         INCx = 9999
         INCy = 9999
         IF ( ICAse==3 .OR. ICAse==11 ) THEN
            CALL CHECK0(sfac)
         ELSEIF ( ICAse==7 .OR. ICAse==8 .OR. ICAse==9 .OR. ICAse==10 ) &
     &            THEN
            CALL CHECK1(sfac)
         ELSEIF ( ICAse==1 .OR. ICAse==2 .OR. ICAse==5 .OR.             &
     &            ICAse==6 .OR. ICAse==12 .OR. ICAse==13 ) THEN
            CALL CHECK2(sfac)
         ELSEIF ( ICAse==4 ) THEN
            CALL CHECK3(sfac)
         ENDIF
!        -- Print
         IF ( PASs ) WRITE (NOUT,99002)
99002    FORMAT ('                                    ----- PASS -----')
      ENDDO
      STOP
      END PROGRAM DBLAT1
!*==header.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE HEADER
      IMPLICIT NONE
!*--HEADER102
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , N
      LOGICAL PASs
!     .. Local Arrays ..
      CHARACTER*6 l(13)
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , PASs
!     .. Data statements ..
      DATA l(1)/' DDOT '/
      DATA l(2)/'DAXPY '/
      DATA l(3)/'DROTG '/
      DATA l(4)/' DROT '/
      DATA l(5)/'DCOPY '/
      DATA l(6)/'DSWAP '/
      DATA l(7)/'DNRM2 '/
      DATA l(8)/'DASUM '/
      DATA l(9)/'DSCAL '/
      DATA l(10)/'IDAMAX'/
      DATA l(11)/'DROTMG'/
      DATA l(12)/'DROTM '/
      DATA l(13)/'DSDOT '/
!     .. Executable Statements ..
      WRITE (NOUT,99001) ICAse , l(ICAse)
!
99001 FORMAT (/' Test of subprogram number',I3,12X,A6)
      RETURN
      END SUBROUTINE HEADER
!*==check0.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE CHECK0(Sfac)
      IMPLICIT NONE
!*--CHECK0136
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalar Arguments ..
      DOUBLE PRECISION Sfac
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , N
      LOGICAL PASs
!     .. Local Scalars ..
      DOUBLE PRECISION sa , sb , sc , ss , d12
      INTEGER i , k
!     .. Local Arrays ..
      DOUBLE PRECISION da1(8) , datrue(8) , db1(8) , dbtrue(8) , dc1(8) &
     &                 , ds1(8) , dab(4,9) , dtemp(9) , dtrue(9,9)
!     .. External Subroutines ..
      EXTERNAL DROTG , DROTMG , STEST , STEST1
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , PASs
!     .. Data statements ..
      DATA da1/0.3D0 , 0.4D0 , -0.3D0 , -0.4D0 , -0.3D0 , 0.0D0 ,       &
     &     0.0D0 , 1.0D0/
      DATA db1/0.4D0 , 0.3D0 , 0.4D0 , 0.3D0 , -0.4D0 , 0.0D0 , 1.0D0 , &
     &     0.0D0/
      DATA dc1/0.6D0 , 0.8D0 , -0.6D0 , 0.8D0 , 0.6D0 , 1.0D0 , 0.0D0 , &
     &     1.0D0/
      DATA ds1/0.8D0 , 0.6D0 , 0.8D0 , -0.6D0 , 0.8D0 , 0.0D0 , 1.0D0 , &
     &     0.0D0/
      DATA datrue/0.5D0 , 0.5D0 , 0.5D0 , -0.5D0 , -0.5D0 , 0.0D0 ,     &
     &     1.0D0 , 1.0D0/
      DATA dbtrue/0.0D0 , 0.6D0 , 0.0D0 , -0.6D0 , 0.0D0 , 0.0D0 ,      &
     &     1.0D0 , 0.0D0/
!     INPUT FOR MODIFIED GIVENS
      DATA dab/.1D0 , .3D0 , 1.2D0 , .2D0 , .7D0 , .2D0 , .6D0 , 4.2D0 ,&
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 4.D0 , -1.D0 , 2.D0 , 4.D0 ,     &
     &     6.D-10 , 2.D-2 , 1.D5 , 10.D0 , 4.D10 , 2.D-2 , 1.D-5 ,      &
     &     10.D0 , 2.D-10 , 4.D-2 , 1.D5 , 10.D0 , 2.D10 , 4.D-2 ,      &
     &     1.D-5 , 10.D0 , 4.D0 , -2.D0 , 8.D0 , 4.D0/
!    TRUE RESULTS FOR MODIFIED GIVENS
      DATA dtrue/0.D0 , 0.D0 , 1.3D0 , .2D0 , 0.D0 , 0.D0 , 0.D0 ,      &
     &     .5D0 , 0.D0 , 0.D0 , 0.D0 , 4.5D0 , 4.2D0 , 1.D0 , .5D0 ,    &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , -2.D0 ,     &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 4.D0 ,      &
     &     -1.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 15.D-3 , 0.D0 ,   &
     &     10.D0 , -1.D0 , 0.D0 , -1.D-4 , 0.D0 , 1.D0 , 0.D0 , 0.D0 ,  &
     &     6144.D-5 , 10.D0 , -1.D0 , 4096.D0 , -1.D6 , 0.D0 , 1.D0 ,   &
     &     0.D0 , 0.D0 , 15.D0 , 10.D0 , -1.D0 , 5.D-5 , 0.D0 , 1.D0 ,  &
     &     0.D0 , 0.D0 , 0.D0 , 15.D0 , 10.D0 , -1.D0 , 5.D5 ,          &
     &     -4096.D0 , 1.D0 , 4096.D-6 , 0.D0 , 0.D0 , 7.D0 , 4.D0 ,     &
     &     0.D0 , 0.D0 , -.5D0 , -.25D0 , 0.D0/
!                   4096 = 2 ** 12
      DATA d12/4096.D0/
      dtrue(1,1) = 12.D0/130.D0
      dtrue(2,1) = 36.D0/130.D0
      dtrue(7,1) = -1.D0/6.D0
      dtrue(1,2) = 14.D0/75.D0
      dtrue(2,2) = 49.D0/75.D0
      dtrue(9,2) = 1.D0/7.D0
      dtrue(1,5) = 45.D-11*(d12*d12)
      dtrue(3,5) = 4.D5/(3.D0*d12)
      dtrue(6,5) = 1.D0/d12
      dtrue(8,5) = 1.D4/(3.D0*d12)
      dtrue(1,6) = 4.D10/(1.5D0*d12*d12)
      dtrue(2,6) = 2.D-2/1.5D0
      dtrue(8,6) = 5.D-7*d12
      dtrue(1,7) = 4.D0/150.D0
      dtrue(2,7) = (2.D-10/1.5D0)*(d12*d12)
      dtrue(7,7) = -dtrue(6,5)
      dtrue(9,7) = 1.D4/d12
      dtrue(1,8) = dtrue(1,7)
      dtrue(2,8) = 2.D10/(1.5D0*d12*d12)
      dtrue(1,9) = 32.D0/7.D0
      dtrue(2,9) = -16.D0/7.D0
!     .. Executable Statements ..
!
!     Compute true values which cannot be prestored
!     in decimal notation
!
      dbtrue(1) = 1.0D0/0.6D0
      dbtrue(3) = -1.0D0/0.6D0
      dbtrue(5) = 1.0D0/0.6D0
!
      DO k = 1 , 8
!        .. Set N=K for identification in output if any ..
         N = k
         IF ( ICAse==3 ) THEN
!           .. DROTG ..
            IF ( k>8 ) EXIT
            sa = da1(k)
            sb = db1(k)
            CALL DROTG(sa,sb,sc,ss)
            CALL STEST1(sa,datrue(k),datrue(k),Sfac)
            CALL STEST1(sb,dbtrue(k),dbtrue(k),Sfac)
            CALL STEST1(sc,dc1(k),dc1(k),Sfac)
            CALL STEST1(ss,ds1(k),ds1(k),Sfac)
         ELSEIF ( ICAse==11 ) THEN
!           .. DROTMG ..
            DO i = 1 , 4
               dtemp(i) = dab(i,k)
               dtemp(i+4) = 0.0
            ENDDO
            dtemp(9) = 0.0
            CALL DROTMG(dtemp(1),dtemp(2),dtemp(3),dtemp(4),dtemp(5))
            CALL STEST(9,dtemp,dtrue(1,k),dtrue(1,k),Sfac)
         ELSE
            WRITE (NOUT,*) ' Shouldn''t be here in CHECK0'
            STOP
         ENDIF
      ENDDO
      END SUBROUTINE CHECK0
!*==check1.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE CHECK1(Sfac)
      IMPLICIT NONE
!*--CHECK1249
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalar Arguments ..
      DOUBLE PRECISION Sfac
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , N
      LOGICAL PASs
!     .. Local Scalars ..
      INTEGER i , ix , len , np1
!     .. Local Arrays ..
      DOUBLE PRECISION dtrue1(5) , dtrue3(5) , dtrue5(8,5,2) , dv(8,5,2)&
     &                 , dvr(8) , sa(10) , stemp(1) , strue(8) , sx(8) ,&
     &                 sxr(15)
      INTEGER itrue2(5) , itruec(5)
!     .. External Functions ..
      DOUBLE PRECISION DASUM , DNRM2
      INTEGER IDAMAX
      EXTERNAL DASUM , DNRM2 , IDAMAX
!     .. External Subroutines ..
      EXTERNAL ITEST1 , DSCAL , STEST , STEST1
!     .. Intrinsic Functions ..
      INTRINSIC MAX
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , PASs
!     .. Data statements ..
      DATA sa/0.3D0 , -1.0D0 , 0.0D0 , 1.0D0 , 0.3D0 , 0.3D0 , 0.3D0 ,  &
     &     0.3D0 , 0.3D0 , 0.3D0/
      DATA dv/0.1D0 , 2.0D0 , 2.0D0 , 2.0D0 , 2.0D0 , 2.0D0 , 2.0D0 ,   &
     &     2.0D0 , 0.3D0 , 3.0D0 , 3.0D0 , 3.0D0 , 3.0D0 , 3.0D0 ,      &
     &     3.0D0 , 3.0D0 , 0.3D0 , -0.4D0 , 4.0D0 , 4.0D0 , 4.0D0 ,     &
     &     4.0D0 , 4.0D0 , 4.0D0 , 0.2D0 , -0.6D0 , 0.3D0 , 5.0D0 ,     &
     &     5.0D0 , 5.0D0 , 5.0D0 , 5.0D0 , 0.1D0 , -0.3D0 , 0.5D0 ,     &
     &     -0.1D0 , 6.0D0 , 6.0D0 , 6.0D0 , 6.0D0 , 0.1D0 , 8.0D0 ,     &
     &     8.0D0 , 8.0D0 , 8.0D0 , 8.0D0 , 8.0D0 , 8.0D0 , 0.3D0 ,      &
     &     9.0D0 , 9.0D0 , 9.0D0 , 9.0D0 , 9.0D0 , 9.0D0 , 9.0D0 ,      &
     &     0.3D0 , 2.0D0 , -0.4D0 , 2.0D0 , 2.0D0 , 2.0D0 , 2.0D0 ,     &
     &     2.0D0 , 0.2D0 , 3.0D0 , -0.6D0 , 5.0D0 , 0.3D0 , 2.0D0 ,     &
     &     2.0D0 , 2.0D0 , 0.1D0 , 4.0D0 , -0.3D0 , 6.0D0 , -0.5D0 ,    &
     &     7.0D0 , -0.1D0 , 3.0D0/
      DATA dvr/8.0D0 , -7.0D0 , 9.0D0 , 5.0D0 , 9.0D0 , 8.0D0 , 7.0D0 , &
     &     7.0D0/
      DATA dtrue1/0.0D0 , 0.3D0 , 0.5D0 , 0.7D0 , 0.6D0/
      DATA dtrue3/0.0D0 , 0.3D0 , 0.7D0 , 1.1D0 , 1.0D0/
      DATA dtrue5/0.10D0 , 2.0D0 , 2.0D0 , 2.0D0 , 2.0D0 , 2.0D0 ,      &
     &     2.0D0 , 2.0D0 , -0.3D0 , 3.0D0 , 3.0D0 , 3.0D0 , 3.0D0 ,     &
     &     3.0D0 , 3.0D0 , 3.0D0 , 0.0D0 , 0.0D0 , 4.0D0 , 4.0D0 ,      &
     &     4.0D0 , 4.0D0 , 4.0D0 , 4.0D0 , 0.20D0 , -0.60D0 , 0.30D0 ,  &
     &     5.0D0 , 5.0D0 , 5.0D0 , 5.0D0 , 5.0D0 , 0.03D0 , -0.09D0 ,   &
     &     0.15D0 , -0.03D0 , 6.0D0 , 6.0D0 , 6.0D0 , 6.0D0 , 0.10D0 ,  &
     &     8.0D0 , 8.0D0 , 8.0D0 , 8.0D0 , 8.0D0 , 8.0D0 , 8.0D0 ,      &
     &     0.09D0 , 9.0D0 , 9.0D0 , 9.0D0 , 9.0D0 , 9.0D0 , 9.0D0 ,     &
     &     9.0D0 , 0.09D0 , 2.0D0 , -0.12D0 , 2.0D0 , 2.0D0 , 2.0D0 ,   &
     &     2.0D0 , 2.0D0 , 0.06D0 , 3.0D0 , -0.18D0 , 5.0D0 , 0.09D0 ,  &
     &     2.0D0 , 2.0D0 , 2.0D0 , 0.03D0 , 4.0D0 , -0.09D0 , 6.0D0 ,   &
     &     -0.15D0 , 7.0D0 , -0.03D0 , 3.0D0/
      DATA itrue2/0 , 1 , 2 , 2 , 3/
      DATA itruec/0 , 1 , 1 , 1 , 1/
!     .. Executable Statements ..
      DO INCx = 1 , 2
         DO np1 = 1 , 5
            N = np1 - 1
            len = 2*MAX(N,1)
!           .. Set vector arguments ..
            DO i = 1 , len
               sx(i) = dv(i,np1,INCx)
            ENDDO
!
            IF ( ICAse==7 ) THEN
!              .. DNRM2 ..
               stemp(1) = dtrue1(np1)
               CALL STEST1(DNRM2(N,sx,INCx),stemp(1),stemp,Sfac)
            ELSEIF ( ICAse==8 ) THEN
!              .. DASUM ..
               stemp(1) = dtrue3(np1)
               CALL STEST1(DASUM(N,sx,INCx),stemp(1),stemp,Sfac)
            ELSEIF ( ICAse==9 ) THEN
!              .. DSCAL ..
               CALL DSCAL(N,sa((INCx-1)*5+np1),sx,INCx)
               DO i = 1 , len
                  strue(i) = dtrue5(i,np1,INCx)
               ENDDO
               CALL STEST(len,sx,strue,strue,Sfac)
            ELSEIF ( ICAse==10 ) THEN
!              .. IDAMAX ..
               CALL ITEST1(IDAMAX(N,sx,INCx),itrue2(np1))
               DO i = 1 , len
                  sx(i) = 42.0D0
               ENDDO
               CALL ITEST1(IDAMAX(N,sx,INCx),itruec(np1))
            ELSE
               WRITE (NOUT,*) ' Shouldn''t be here in CHECK1'
               STOP
            ENDIF
         ENDDO
         IF ( ICAse==10 ) THEN
            N = 8
            ix = 1
            DO i = 1 , N
               sxr(ix) = dvr(i)
               ix = ix + INCx
            ENDDO
            CALL ITEST1(IDAMAX(N,sxr,INCx),3)
         ENDIF
      ENDDO
      END SUBROUTINE CHECK1
!*==check2.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE CHECK2(Sfac)
      IMPLICIT NONE
!*--CHECK2359
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalar Arguments ..
      DOUBLE PRECISION Sfac
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , N
      LOGICAL PASs
!     .. Local Scalars ..
      DOUBLE PRECISION sa
      INTEGER i , j , ki , kn , kni , kpar , ksize , lenx , leny ,      &
     &        lincx , lincy , mx , my
!     .. Local Arrays ..
      DOUBLE PRECISION dt10x(7,4,4) , dt10y(7,4,4) , dt7(4,4) ,         &
     &                 dt8(7,4,4) , dx1(7) , dy1(7) , ssize1(4) ,       &
     &                 ssize2(14,2) , ssize(7) , stx(7) , sty(7) ,      &
     &                 sx(7) , sy(7) , dpar(5,4) , dt19x(7,4,16) ,      &
     &                 dt19xa(7,4,4) , dt19xb(7,4,4) , dt19xc(7,4,4) ,  &
     &                 dt19xd(7,4,4) , dt19y(7,4,16) , dt19ya(7,4,4) ,  &
     &                 dt19yb(7,4,4) , dt19yc(7,4,4) , dt19yd(7,4,4) ,  &
     &                 dtemp(5) , sty0(1) , sx0(1) , sy0(1)
      INTEGER incxs(4) , incys(4) , lens(4,2) , ns(4)
!     .. External Functions ..
      DOUBLE PRECISION DDOT , DSDOT
      EXTERNAL DDOT , DSDOT
!     .. External Subroutines ..
      EXTERNAL DAXPY , DCOPY , DROTM , DSWAP , STEST , STEST1 ,         &
     &         TESTDSDOT
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MIN
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , PASs
!     .. Data statements ..
      EQUIVALENCE (dt19x(1,1,1),dt19xa(1,1,1))
      EQUIVALENCE (dt19x(1,1,5),dt19xb(1,1,1))
      EQUIVALENCE (dt19x(1,1,9),dt19xc(1,1,1))
      EQUIVALENCE (dt19x(1,1,13),dt19xd(1,1,1))
      EQUIVALENCE (dt19y(1,1,1),dt19ya(1,1,1))
      EQUIVALENCE (dt19y(1,1,5),dt19yb(1,1,1))
      EQUIVALENCE (dt19y(1,1,9),dt19yc(1,1,1))
      EQUIVALENCE (dt19y(1,1,13),dt19yd(1,1,1))

      DATA sa/0.3D0/
      DATA incxs/1 , 2 , -2 , -1/
      DATA incys/1 , -2 , 1 , -2/
      DATA lens/1 , 1 , 2 , 4 , 1 , 1 , 3 , 7/
      DATA ns/0 , 1 , 2 , 4/
      DATA dx1/0.6D0 , 0.1D0 , -0.5D0 , 0.8D0 , 0.9D0 , -0.3D0 , -0.4D0/
      DATA dy1/0.5D0 , -0.9D0 , 0.3D0 , 0.7D0 , -0.6D0 , 0.2D0 , 0.8D0/
      DATA dt7/0.0D0 , 0.30D0 , 0.21D0 , 0.62D0 , 0.0D0 , 0.30D0 ,      &
     &     -0.07D0 , 0.85D0 , 0.0D0 , 0.30D0 , -0.79D0 , -0.74D0 ,      &
     &     0.0D0 , 0.30D0 , 0.33D0 , 1.27D0/
      DATA dt8/0.5D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,  &
     &     0.68D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,     &
     &     0.68D0 , -0.87D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,   &
     &     0.68D0 , -0.87D0 , 0.15D0 , 0.94D0 , 0.0D0 , 0.0D0 , 0.0D0 , &
     &     0.5D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.68D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,     &
     &     0.35D0 , -0.9D0 , 0.48D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,   &
     &     0.38D0 , -0.9D0 , 0.57D0 , 0.7D0 , -0.75D0 , 0.2D0 , 0.98D0 ,&
     &     0.5D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.68D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,     &
     &     0.35D0 , -0.72D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,   &
     &     0.38D0 , -0.63D0 , 0.15D0 , 0.88D0 , 0.0D0 , 0.0D0 , 0.0D0 , &
     &     0.5D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.68D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,     &
     &     0.68D0 , -0.9D0 , 0.33D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,   &
     &     0.68D0 , -0.9D0 , 0.33D0 , 0.7D0 , -0.75D0 , 0.2D0 , 1.04D0/
      DATA dt10x/0.6D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,&
     &     0.5D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.5D0 , -0.9D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,     &
     &     0.5D0 , -0.9D0 , 0.3D0 , 0.7D0 , 0.0D0 , 0.0D0 , 0.0D0 ,     &
     &     0.6D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.5D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.3D0 , 0.1D0 , 0.5D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.8D0 , 0.1D0 , -0.6D0 , 0.8D0 , 0.3D0 , -0.3D0 , 0.5D0 ,    &
     &     0.6D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.5D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     -0.9D0 , 0.1D0 , 0.5D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,     &
     &     0.7D0 , 0.1D0 , 0.3D0 , 0.8D0 , -0.9D0 , -0.3D0 , 0.5D0 ,    &
     &     0.6D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.5D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.5D0 , 0.3D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.5D0 , 0.3D0 , -0.6D0 , 0.8D0 , 0.0D0 , 0.0D0 , 0.0D0/
      DATA dt10y/0.5D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,&
     &     0.6D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.6D0 , 0.1D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.6D0 , 0.1D0 , -0.5D0 , 0.8D0 , 0.0D0 , 0.0D0 , 0.0D0 ,     &
     &     0.5D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.6D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     -0.5D0 , -0.9D0 , 0.6D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,    &
     &     -0.4D0 , -0.9D0 , 0.9D0 , 0.7D0 , -0.5D0 , 0.2D0 , 0.6D0 ,   &
     &     0.5D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.6D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     -0.5D0 , 0.6D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,     &
     &     -0.4D0 , 0.9D0 , -0.5D0 , 0.6D0 , 0.0D0 , 0.0D0 , 0.0D0 ,    &
     &     0.5D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.6D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.6D0 , -0.9D0 , 0.1D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,     &
     &     0.6D0 , -0.9D0 , 0.1D0 , 0.7D0 , -0.5D0 , 0.2D0 , 0.8D0/
      DATA ssize1/0.0D0 , 0.3D0 , 1.6D0 , 3.2D0/
      DATA ssize2/0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,       &
     &     0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.0D0 , 1.17D0 , 1.17D0 , 1.17D0 , 1.17D0 , 1.17D0 , 1.17D0 ,&
     &     1.17D0 , 1.17D0 , 1.17D0 , 1.17D0 , 1.17D0 , 1.17D0 ,        &
     &     1.17D0 , 1.17D0/
!
!                         FOR DROTM
!
      DATA dpar/ - 2.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , -1.D0 , 2.D0 ,    &
     &     -3.D0 , -4.D0 , 5.D0 , 0.D0 , 0.D0 , 2.D0 , -3.D0 , 0.D0 ,   &
     &     1.D0 , 5.D0 , 2.D0 , 0.D0 , -4.D0/
!                        TRUE X RESULTS F0R ROTATIONS DROTM
      DATA dt19xa/.6D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,      &
     &     .6D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .6D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .6D0 , 0.D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .6D0 , 0.D0 , 0.D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , -.8D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     0.D0 , 0.D0 , 0.D0 , -.9D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     0.D0 , 0.D0 , 3.5D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     0.D0 , .6D0 , .1D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,      &
     &     -.8D0 , 3.8D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , -.9D0 ,   &
     &     2.8D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 3.5D0 , -.4D0 ,   &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .6D0 , .1D0 , -.5D0 ,     &
     &     .8D0 , 0.D0 , 0.D0 , 0.D0 , -.8D0 , 3.8D0 , -2.2D0 , -1.2D0 ,&
     &     0.D0 , 0.D0 , 0.D0 , -.9D0 , 2.8D0 , -1.4D0 , -1.3D0 , 0.D0 ,&
     &     0.D0 , 0.D0 , 3.5D0 , -.4D0 , -2.2D0 , 4.7D0 , 0.D0 , 0.D0 , &
     &     0.D0/
!
      DATA dt19xb/.6D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,      &
     &     .6D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .6D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .6D0 , 0.D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .6D0 , 0.D0 , 0.D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , -.8D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     0.D0 , 0.D0 , 0.D0 , -.9D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     0.D0 , 0.D0 , 3.5D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     0.D0 , .6D0 , .1D0 , -.5D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     0.D0 , .1D0 , -3.0D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , -.3D0 ,   &
     &     .1D0 , -2.0D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 3.3D0 , .1D0 ,   &
     &     -2.0D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .6D0 , .1D0 , -.5D0 ,   &
     &     .8D0 , .9D0 , -.3D0 , -.4D0 , -2.0D0 , .1D0 , 1.4D0 , .8D0 , &
     &     .6D0 , -.3D0 , -2.8D0 , -1.8D0 , .1D0 , 1.3D0 , .8D0 , 0.D0 ,&
     &     -.3D0 , -1.9D0 , 3.8D0 , .1D0 , -3.1D0 , .8D0 , 4.8D0 ,      &
     &     -.3D0 , -1.5D0/
!
      DATA dt19xc/.6D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,      &
     &     .6D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .6D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .6D0 , 0.D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .6D0 , 0.D0 , 0.D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , -.8D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     0.D0 , 0.D0 , 0.D0 , -.9D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     0.D0 , 0.D0 , 3.5D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     0.D0 , .6D0 , .1D0 , -.5D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     4.8D0 , .1D0 , -3.0D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 3.3D0 ,  &
     &     .1D0 , -2.0D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 2.1D0 , .1D0 ,   &
     &     -2.0D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .6D0 , .1D0 , -.5D0 ,   &
     &     .8D0 , .9D0 , -.3D0 , -.4D0 , -1.6D0 , .1D0 , -2.2D0 , .8D0 ,&
     &     5.4D0 , -.3D0 , -2.8D0 , -1.5D0 , .1D0 , -1.4D0 , .8D0 ,     &
     &     3.6D0 , -.3D0 , -1.9D0 , 3.7D0 , .1D0 , -2.2D0 , .8D0 ,      &
     &     3.6D0 , -.3D0 , -1.5D0/
!
      DATA dt19xd/.6D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,      &
     &     .6D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .6D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .6D0 , 0.D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .6D0 , 0.D0 , 0.D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , -.8D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     0.D0 , 0.D0 , 0.D0 , -.9D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     0.D0 , 0.D0 , 3.5D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     0.D0 , .6D0 , .1D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,      &
     &     -.8D0 , -1.0D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , -.9D0 ,  &
     &     -.8D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 3.5D0 , .8D0 ,    &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .6D0 , .1D0 , -.5D0 ,     &
     &     .8D0 , 0.D0 , 0.D0 , 0.D0 , -.8D0 , -1.0D0 , 1.4D0 , -1.6D0 ,&
     &     0.D0 , 0.D0 , 0.D0 , -.9D0 , -.8D0 , 1.3D0 , -1.6D0 , 0.D0 , &
     &     0.D0 , 0.D0 , 3.5D0 , .8D0 , -3.1D0 , 4.8D0 , 0.D0 , 0.D0 ,  &
     &     0.D0/
!                        TRUE Y RESULTS FOR ROTATIONS DROTM
      DATA dt19ya/.5D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,      &
     &     .5D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .5D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .5D0 , 0.D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .5D0 , 0.D0 , 0.D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , .7D0 , 0.D0 , 0.D0 , 0.D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 1.7D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     0.D0 , 0.D0 , -2.6D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,    &
     &     0.D0 , .5D0 , -.9D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     .7D0 , -4.8D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 1.7D0 ,   &
     &     -.7D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , -2.6D0 , 3.5D0 ,  &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .5D0 , -.9D0 , .3D0 ,     &
     &     .7D0 , 0.D0 , 0.D0 , 0.D0 , .7D0 , -4.8D0 , 3.0D0 , 1.1D0 ,  &
     &     0.D0 , 0.D0 , 0.D0 , 1.7D0 , -.7D0 , -.7D0 , 2.3D0 , 0.D0 ,  &
     &     0.D0 , 0.D0 , -2.6D0 , 3.5D0 , -.7D0 , -3.6D0 , 0.D0 , 0.D0 ,&
     &     0.D0/
!
      DATA dt19yb/.5D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,      &
     &     .5D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .5D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .5D0 , 0.D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .5D0 , 0.D0 , 0.D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , .7D0 , 0.D0 , 0.D0 , 0.D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 1.7D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     0.D0 , 0.D0 , -2.6D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,    &
     &     0.D0 , .5D0 , -.9D0 , .3D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     4.0D0 , -.9D0 , -.3D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , -.5D0 ,  &
     &     -.9D0 , 1.5D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , -1.5D0 , -.9D0 , &
     &     -1.8D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .5D0 , -.9D0 , .3D0 ,   &
     &     .7D0 , -.6D0 , .2D0 , .8D0 , 3.7D0 , -.9D0 , -1.2D0 , .7D0 , &
     &     -1.5D0 , .2D0 , 2.2D0 , -.3D0 , -.9D0 , 2.1D0 , .7D0 ,       &
     &     -1.6D0 , .2D0 , 2.0D0 , -1.6D0 , -.9D0 , -2.1D0 , .7D0 ,     &
     &     2.9D0 , .2D0 , -3.8D0/
!
      DATA dt19yc/.5D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,      &
     &     .5D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .5D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .5D0 , 0.D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .5D0 , 0.D0 , 0.D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , .7D0 , 0.D0 , 0.D0 , 0.D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 1.7D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     0.D0 , 0.D0 , -2.6D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,    &
     &     0.D0 , .5D0 , -.9D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     4.0D0 , -6.3D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , -.5D0 ,  &
     &     .3D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , -1.5D0 , 3.0D0 ,   &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .5D0 , -.9D0 , .3D0 ,     &
     &     .7D0 , 0.D0 , 0.D0 , 0.D0 , 3.7D0 , -7.2D0 , 3.0D0 , 1.7D0 , &
     &     0.D0 , 0.D0 , 0.D0 , -.3D0 , .9D0 , -.7D0 , 1.9D0 , 0.D0 ,   &
     &     0.D0 , 0.D0 , -1.6D0 , 2.7D0 , -.7D0 , -3.4D0 , 0.D0 , 0.D0 ,&
     &     0.D0/
!
      DATA dt19yd/.5D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,      &
     &     .5D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .5D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .5D0 , 0.D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .5D0 , 0.D0 , 0.D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 0.D0 , .7D0 , 0.D0 , 0.D0 , 0.D0 ,      &
     &     0.D0 , 0.D0 , 0.D0 , 1.7D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     0.D0 , 0.D0 , -2.6D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,    &
     &     0.D0 , .5D0 , -.9D0 , .3D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,     &
     &     .7D0 , -.9D0 , 1.2D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , 1.7D0 ,   &
     &     -.9D0 , .5D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , -2.6D0 , -.9D0 ,  &
     &     -1.3D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , .5D0 , -.9D0 , .3D0 ,   &
     &     .7D0 , -.6D0 , .2D0 , .8D0 , .7D0 , -.9D0 , 1.2D0 , .7D0 ,   &
     &     -1.5D0 , .2D0 , 1.6D0 , 1.7D0 , -.9D0 , .5D0 , .7D0 ,        &
     &     -1.6D0 , .2D0 , 2.4D0 , -2.6D0 , -.9D0 , -1.3D0 , .7D0 ,     &
     &     2.9D0 , .2D0 , -4.0D0/
!
!     .. Executable Statements ..
!
      DO ki = 1 , 4
         INCx = incxs(ki)
         INCy = incys(ki)
         mx = ABS(INCx)
         my = ABS(INCy)
!
         DO kn = 1 , 4
            N = ns(kn)
            ksize = MIN(2,kn)
            lenx = lens(kn,mx)
            leny = lens(kn,my)
!           .. Initialize all argument arrays ..
            DO i = 1 , 7
               sx(i) = dx1(i)
               sy(i) = dy1(i)
            ENDDO
!
            IF ( ICAse==1 ) THEN
!              .. DDOT ..
               CALL STEST1(DDOT(N,sx,INCx,sy,INCy),dt7(kn,ki),ssize1(kn)&
     &                     ,Sfac)
            ELSEIF ( ICAse==2 ) THEN
!              .. DAXPY ..
               CALL DAXPY(N,sa,sx,INCx,sy,INCy)
               DO j = 1 , leny
                  sty(j) = dt8(j,kn,ki)
               ENDDO
               CALL STEST(leny,sy,sty,ssize2(1,ksize),Sfac)
            ELSEIF ( ICAse==5 ) THEN
!              .. DCOPY ..
               DO i = 1 , 7
                  sty(i) = dt10y(i,kn,ki)
               ENDDO
               CALL DCOPY(N,sx,INCx,sy,INCy)
               CALL STEST(leny,sy,sty,ssize2(1,1),1.0D0)
               IF ( ki==1 ) THEN
                  sx0(1) = 42.0D0
                  sy0(1) = 43.0D0
                  IF ( N==0 ) THEN
                     sty0(1) = sy0(1)
                  ELSE
                     sty0(1) = sx0(1)
                  ENDIF
                  lincx = INCx
                  INCx = 0
                  lincy = INCy
                  INCy = 0
                  CALL DCOPY(N,sx0,INCx,sy0,INCy)
                  CALL STEST(1,sy0,sty0,ssize2(1,1),1.0D0)
                  INCx = lincx
                  INCy = lincy
               ENDIF
            ELSEIF ( ICAse==6 ) THEN
!              .. DSWAP ..
               CALL DSWAP(N,sx,INCx,sy,INCy)
               DO i = 1 , 7
                  stx(i) = dt10x(i,kn,ki)
                  sty(i) = dt10y(i,kn,ki)
               ENDDO
               CALL STEST(lenx,sx,stx,ssize2(1,1),1.0D0)
               CALL STEST(leny,sy,sty,ssize2(1,1),1.0D0)
            ELSEIF ( ICAse==12 ) THEN
!              .. DROTM ..
               kni = kn + 4*(ki-1)
               DO kpar = 1 , 4
                  DO i = 1 , 7
                     sx(i) = dx1(i)
                     sy(i) = dy1(i)
                     stx(i) = dt19x(i,kpar,kni)
                     sty(i) = dt19y(i,kpar,kni)
                  ENDDO
!
                  DO i = 1 , 5
                     dtemp(i) = dpar(i,kpar)
                  ENDDO
!
                  DO i = 1 , lenx
                     ssize(i) = stx(i)
                  ENDDO
!                   SEE REMARK ABOVE ABOUT DT11X(1,2,7)
!                       AND DT11X(5,3,8).
                  IF ( (kpar==2) .AND. (kni==7) ) ssize(1) = 2.4D0
                  IF ( (kpar==3) .AND. (kni==8) ) ssize(5) = 1.8D0
!
                  CALL DROTM(N,sx,INCx,sy,INCy,dtemp)
                  CALL STEST(lenx,sx,stx,ssize,Sfac)
                  CALL STEST(leny,sy,sty,sty,Sfac)
               ENDDO
            ELSEIF ( ICAse==13 ) THEN
!              .. DSDOT ..
               CALL TESTDSDOT(REAL(DSDOT(N,REAL(sx),INCx,REAL(sy),INCy))&
     &                        ,REAL(dt7(kn,ki)),REAL(ssize1(kn)),       &
     &                        .3125E-1)
            ELSE
               WRITE (NOUT,*) ' Shouldn''t be here in CHECK2'
               STOP
            ENDIF
         ENDDO
      ENDDO
      END SUBROUTINE CHECK2
!*==check3.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE CHECK3(Sfac)
      IMPLICIT NONE
!*--CHECK3706
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalar Arguments ..
      DOUBLE PRECISION Sfac
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , N
      LOGICAL PASs
!     .. Local Scalars ..
      DOUBLE PRECISION sc , ss
      INTEGER i , k , ki , kn , ksize , lenx , leny , mx , my
!     .. Local Arrays ..
      DOUBLE PRECISION copyx(5) , copyy(5) , dt9x(7,4,4) , dt9y(7,4,4) ,&
     &                 dx1(7) , dy1(7) , mwpc(11) , mwps(11) , mwpstx(5)&
     &                 , mwpsty(5) , mwptx(11,5) , mwpty(11,5) , mwpx(5)&
     &                 , mwpy(5) , ssize2(14,2) , stx(7) , sty(7) ,     &
     &                 sx(7) , sy(7)
      INTEGER incxs(4) , incys(4) , lens(4,2) , mwpinx(11) , mwpiny(11) &
     &        , mwpn(11) , ns(4)
!     .. External Subroutines ..
      EXTERNAL DROT , STEST
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MIN
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , PASs
!     .. Data statements ..
      DATA incxs/1 , 2 , -2 , -1/
      DATA incys/1 , -2 , 1 , -2/
      DATA lens/1 , 1 , 2 , 4 , 1 , 1 , 3 , 7/
      DATA ns/0 , 1 , 2 , 4/
      DATA dx1/0.6D0 , 0.1D0 , -0.5D0 , 0.8D0 , 0.9D0 , -0.3D0 , -0.4D0/
      DATA dy1/0.5D0 , -0.9D0 , 0.3D0 , 0.7D0 , -0.6D0 , 0.2D0 , 0.8D0/
      DATA sc , ss/0.8D0 , 0.6D0/
      DATA dt9x/0.6D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , &
     &     0.78D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,     &
     &     0.78D0 , -0.46D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,   &
     &     0.78D0 , -0.46D0 , -0.22D0 , 1.06D0 , 0.0D0 , 0.0D0 , 0.0D0 ,&
     &     0.6D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.78D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,     &
     &     0.66D0 , 0.1D0 , -0.1D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,    &
     &     0.96D0 , 0.1D0 , -0.76D0 , 0.8D0 , 0.90D0 , -0.3D0 ,         &
     &     -0.02D0 , 0.6D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,    &
     &     0.0D0 , 0.78D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,     &
     &     0.0D0 , -0.06D0 , 0.1D0 , -0.1D0 , 0.0D0 , 0.0D0 , 0.0D0 ,   &
     &     0.0D0 , 0.90D0 , 0.1D0 , -0.22D0 , 0.8D0 , 0.18D0 , -0.3D0 , &
     &     -0.02D0 , 0.6D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,    &
     &     0.0D0 , 0.78D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,     &
     &     0.0D0 , 0.78D0 , 0.26D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,    &
     &     0.0D0 , 0.78D0 , 0.26D0 , -0.76D0 , 1.12D0 , 0.0D0 , 0.0D0 , &
     &     0.0D0/
      DATA dt9y/0.5D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , &
     &     0.04D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,     &
     &     0.04D0 , -0.78D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,   &
     &     0.04D0 , -0.78D0 , 0.54D0 , 0.08D0 , 0.0D0 , 0.0D0 , 0.0D0 , &
     &     0.5D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.04D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,     &
     &     0.7D0 , -0.9D0 , -0.12D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,   &
     &     0.64D0 , -0.9D0 , -0.30D0 , 0.7D0 , -0.18D0 , 0.2D0 ,        &
     &     0.28D0 , 0.5D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,     &
     &     0.0D0 , 0.04D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,     &
     &     0.0D0 , 0.7D0 , -1.08D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,    &
     &     0.0D0 , 0.64D0 , -1.26D0 , 0.54D0 , 0.20D0 , 0.0D0 , 0.0D0 , &
     &     0.0D0 , 0.5D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.0D0 , 0.04D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,     &
     &     0.0D0 , 0.04D0 , -0.9D0 , 0.18D0 , 0.0D0 , 0.0D0 , 0.0D0 ,   &
     &     0.0D0 , 0.04D0 , -0.9D0 , 0.18D0 , 0.7D0 , -0.18D0 , 0.2D0 , &
     &     0.16D0/
      DATA ssize2/0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,       &
     &     0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,      &
     &     0.0D0 , 1.17D0 , 1.17D0 , 1.17D0 , 1.17D0 , 1.17D0 , 1.17D0 ,&
     &     1.17D0 , 1.17D0 , 1.17D0 , 1.17D0 , 1.17D0 , 1.17D0 ,        &
     &     1.17D0 , 1.17D0/
!     .. Executable Statements ..
!
      DO ki = 1 , 4
         INCx = incxs(ki)
         INCy = incys(ki)
         mx = ABS(INCx)
         my = ABS(INCy)
!
         DO kn = 1 , 4
            N = ns(kn)
            ksize = MIN(2,kn)
            lenx = lens(kn,mx)
            leny = lens(kn,my)
!
            IF ( ICAse==4 ) THEN
!              .. DROT ..
               DO i = 1 , 7
                  sx(i) = dx1(i)
                  sy(i) = dy1(i)
                  stx(i) = dt9x(i,kn,ki)
                  sty(i) = dt9y(i,kn,ki)
               ENDDO
               CALL DROT(N,sx,INCx,sy,INCy,sc,ss)
               CALL STEST(lenx,sx,stx,ssize2(1,ksize),Sfac)
               CALL STEST(leny,sy,sty,ssize2(1,ksize),Sfac)
            ELSE
               WRITE (NOUT,*) ' Shouldn''t be here in CHECK3'
               STOP
            ENDIF
         ENDDO
      ENDDO
!
      mwpc(1) = 1
      DO i = 2 , 11
         mwpc(i) = 0
      ENDDO
      mwps(1) = 0
      DO i = 2 , 6
         mwps(i) = 1
      ENDDO
      DO i = 7 , 11
         mwps(i) = -1
      ENDDO
      mwpinx(1) = 1
      mwpinx(2) = 1
      mwpinx(3) = 1
      mwpinx(4) = -1
      mwpinx(5) = 1
      mwpinx(6) = -1
      mwpinx(7) = 1
      mwpinx(8) = 1
      mwpinx(9) = -1
      mwpinx(10) = 1
      mwpinx(11) = -1
      mwpiny(1) = 1
      mwpiny(2) = 1
      mwpiny(3) = -1
      mwpiny(4) = -1
      mwpiny(5) = 2
      mwpiny(6) = 1
      mwpiny(7) = 1
      mwpiny(8) = -1
      mwpiny(9) = -1
      mwpiny(10) = 2
      mwpiny(11) = 1
      DO i = 1 , 11
         mwpn(i) = 5
      ENDDO
      mwpn(5) = 3
      mwpn(10) = 3
      DO i = 1 , 5
         mwpx(i) = i
         mwpy(i) = i
         mwptx(1,i) = i
         mwpty(1,i) = i
         mwptx(2,i) = i
         mwpty(2,i) = -i
         mwptx(3,i) = 6 - i
         mwpty(3,i) = i - 6
         mwptx(4,i) = i
         mwpty(4,i) = -i
         mwptx(6,i) = 6 - i
         mwpty(6,i) = i - 6
         mwptx(7,i) = -i
         mwpty(7,i) = i
         mwptx(8,i) = i - 6
         mwpty(8,i) = 6 - i
         mwptx(9,i) = -i
         mwpty(9,i) = i
         mwptx(11,i) = i - 6
         mwpty(11,i) = 6 - i
      ENDDO
      mwptx(5,1) = 1
      mwptx(5,2) = 3
      mwptx(5,3) = 5
      mwptx(5,4) = 4
      mwptx(5,5) = 5
      mwpty(5,1) = -1
      mwpty(5,2) = 2
      mwpty(5,3) = -2
      mwpty(5,4) = 4
      mwpty(5,5) = -3
      mwptx(10,1) = -1
      mwptx(10,2) = -3
      mwptx(10,3) = -5
      mwptx(10,4) = 4
      mwptx(10,5) = 5
      mwpty(10,1) = 1
      mwpty(10,2) = 2
      mwpty(10,3) = 2
      mwpty(10,4) = 4
      mwpty(10,5) = 3
      DO i = 1 , 11
         INCx = mwpinx(i)
         INCy = mwpiny(i)
         DO k = 1 , 5
            copyx(k) = mwpx(k)
            copyy(k) = mwpy(k)
            mwpstx(k) = mwptx(i,k)
            mwpsty(k) = mwpty(i,k)
         ENDDO
         CALL DROT(mwpn(i),copyx,INCx,copyy,INCy,mwpc(i),mwps(i))
         CALL STEST(5,copyx,mwpstx,mwpstx,Sfac)
         CALL STEST(5,copyy,mwpsty,mwpsty,Sfac)
      ENDDO
      END SUBROUTINE CHECK3
!*==stest.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE STEST(Len,Scomp,Strue,Ssize,Sfac)
      IMPLICIT NONE
!*--STEST908
!     ********************************* STEST **************************
!
!     THIS SUBR COMPARES ARRAYS  SCOMP() AND STRUE() OF LENGTH LEN TO
!     SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
!     NEGLIGIBLE.
!
!     C. L. LAWSON, JPL, 1974 DEC 10
!
!     .. Parameters ..
      INTEGER NOUT
      DOUBLE PRECISION ZERO
      PARAMETER (NOUT=6,ZERO=0.0D0)
!     .. Scalar Arguments ..
      DOUBLE PRECISION Sfac
      INTEGER Len
!     .. Array Arguments ..
      DOUBLE PRECISION Scomp(Len) , Ssize(Len) , Strue(Len)
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , N
      LOGICAL PASs
!     .. Local Scalars ..
      DOUBLE PRECISION sd
      INTEGER i
!     .. External Functions ..
      DOUBLE PRECISION SDIFF
      EXTERNAL SDIFF
!     .. Intrinsic Functions ..
      INTRINSIC ABS
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , PASs
!     .. Executable Statements ..
!
      DO i = 1 , Len
         sd = Scomp(i) - Strue(i)
         IF ( ABS(Sfac*sd)>ABS(Ssize(i))*EPSILON(ZERO) ) THEN
!
!                             HERE    SCOMP(I) IS NOT CLOSE TO STRUE(I).
!
            IF ( PASs ) THEN
!                             PRINT FAIL MESSAGE AND HEADER.
               PASs = .FALSE.
               WRITE (NOUT,99001)
!
99001          FORMAT ('                                       FAIL')
               WRITE (NOUT,99002)
99002          FORMAT (/                                                &
     &               ' CASE  N INCX INCY  I                            '&
     &               ,                                                  &
     &        ' COMP(I)                             TRUE(I)  DIFFERENCE'&
     &        ,'     SIZE(I)',/1X)
            ENDIF
            WRITE (NOUT,99003) ICAse , N , INCx , INCy , i , Scomp(i) , &
     &                         Strue(i) , sd , Ssize(i)
99003       FORMAT (1X,I4,I3,2I5,I3,2D36.8,2D12.4)
         ENDIF
      ENDDO
      RETURN
      END SUBROUTINE STEST
!*==testdsdot.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE TESTDSDOT(Scomp,Strue,Ssize,Sfac)
      IMPLICIT NONE
!*--TESTDSDOT970
!     ********************************* STEST **************************
!
!     THIS SUBR COMPARES ARRAYS  SCOMP() AND STRUE() OF LENGTH LEN TO
!     SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
!     NEGLIGIBLE.
!
!     C. L. LAWSON, JPL, 1974 DEC 10
!
!     .. Parameters ..
      INTEGER NOUT
      REAL ZERO
      PARAMETER (NOUT=6,ZERO=0.0E0)
!     .. Scalar Arguments ..
      REAL Sfac , Scomp , Ssize , Strue
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , N
      LOGICAL PASs
!     .. Local Scalars ..
      REAL sd
!     .. Intrinsic Functions ..
      INTRINSIC ABS
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , PASs
!     .. Executable Statements ..
!
      sd = Scomp - Strue
      IF ( ABS(Sfac*sd)>ABS(Ssize)*EPSILON(ZERO) ) THEN
!
!                             HERE    SCOMP(I) IS NOT CLOSE TO STRUE(I).
!
         IF ( PASs ) THEN
!                             PRINT FAIL MESSAGE AND HEADER.
            PASs = .FALSE.
            WRITE (NOUT,99001)
!
99001       FORMAT ('                                       FAIL')
            WRITE (NOUT,99002)
99002       FORMAT (/' CASE  N INCX INCY                           ',   &
     &        ' COMP(I)                             TRUE(I)  DIFFERENCE'&
     &        ,'     SIZE(I)',/1X)
         ENDIF
         WRITE (NOUT,99003) ICAse , N , INCx , INCy , Scomp , Strue ,   &
     &                      sd , Ssize
99003    FORMAT (1X,I4,I3,1I5,I3,2E36.8,2E12.4)
      ENDIF
      RETURN
      END SUBROUTINE TESTDSDOT
!*==stest1.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE STEST1(Scomp1,Strue1,Ssize,Sfac)
      IMPLICIT NONE
!*--STEST11021
!     ************************* STEST1 *****************************
!
!     THIS IS AN INTERFACE SUBROUTINE TO ACCOMMODATE THE FORTRAN
!     REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
!     ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
!
!     C.L. LAWSON, JPL, 1978 DEC 6
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION Scomp1 , Sfac , Strue1
!     .. Array Arguments ..
      DOUBLE PRECISION Ssize(*)
!     .. Local Arrays ..
      DOUBLE PRECISION scomp(1) , strue(1)
!     .. External Subroutines ..
      EXTERNAL STEST
!     .. Executable Statements ..
!
      scomp(1) = Scomp1
      strue(1) = Strue1
      CALL STEST(1,scomp,strue,Ssize,Sfac)
!
      END SUBROUTINE STEST1
!*==sdiff.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      DOUBLE PRECISION FUNCTION SDIFF(Sa,Sb)
      IMPLICIT NONE
!*--SDIFF1048
!     ********************************* SDIFF **************************
!     COMPUTES DIFFERENCE OF TWO NUMBERS.  C. L. LAWSON, JPL 1974 FEB 15
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION Sa , Sb
!     .. Executable Statements ..
      SDIFF = Sa - Sb
      END FUNCTION SDIFF
!*==itest1.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE ITEST1(Icomp,Itrue)
      IMPLICIT NONE
!*--ITEST11060
!     ********************************* ITEST1 *************************
!
!     THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
!     EQUALITY.
!     C. L. LAWSON, JPL, 1974 DEC 10
!
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalar Arguments ..
      INTEGER Icomp , Itrue
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , N
      LOGICAL PASs
!     .. Local Scalars ..
      INTEGER id
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , PASs
!     .. Executable Statements ..
!
      IF ( Icomp/=Itrue ) THEN
!
!                            HERE ICOMP IS NOT EQUAL TO ITRUE.
!
         IF ( PASs ) THEN
!                             PRINT FAIL MESSAGE AND HEADER.
            PASs = .FALSE.
            WRITE (NOUT,99001)
!
99001       FORMAT ('                                       FAIL')
            WRITE (NOUT,99002)
99002       FORMAT (/' CASE  N INCX INCY                               '&
     &              ,                                                   &
     &        ' COMP                                TRUE     DIFFERENCE'&
     &        ,/1X)
         ENDIF
         id = Icomp - Itrue
         WRITE (NOUT,99003) ICAse , N , INCx , INCy , Icomp , Itrue , id
99003    FORMAT (1X,I4,I3,2I5,2I36,I12)
      ENDIF
      RETURN
      END SUBROUTINE ITEST1


nfactorial = PRODUCT((/(i, i=1,n)/))


C    Copyright(C) 1988-2017 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    Redistribution and use in source and binary forms, with or without
C    modification, are permitted provided that the following conditions are
C    met:
C
C    * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C    * Redistributions in binary form must reproduce the above
C      copyright notice, this list of conditions and the following
C      disclaimer in the documentation and/or other materials provided
C      with the distribution.
C
C    * Neither the name of NTESS nor the names of its
C      contributors may be used to endorse or promote products derived
C      from this software without specific prior written permission.
C
C    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C    A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C    OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C    SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C    LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C    DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C    THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C    (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C    OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

C $Id: plane3.f,v 1.1 1991/02/21 15:44:49 gdsjaar Exp $
C $Log: plane3.f,v $
C Revision 1.1  1991/02/21 15:44:49  gdsjaar
C Initial revision
C
      SUBROUTINE PLANE3 (COORD, NUMNP, DIST, DISTR, NDIM, P1, P2, TOLER,
     *   NODEL, SORTYP, MAP, SORUP, INUM, OPT, SELECT)
      DIMENSION COORD (NUMNP,*), DIST(*), DISTR(*), P1(*), P2(*),
     *   TOLER(*), MAP(*)
      CHARACTER*(*) NODEL, SORTYP, OPT
      LOGICAL SORUP, SELECT(*), ISABRT
      include 'nu_io.blk'
C
      CALL LOCOUT ('PLANE', NDIM, NODEL, TOLER, SORTYP, P1, P2, ' ')

      A = P2(1)
      B = P2(2)
      C = P2(3)
      D = A * P1(1) + B * P1(2) + C * P1(3)
C
      TEMP = TOLER(1)
      TOLER(1) = MAX(0.0, TEMP - TOLER(2))
      TOLER(2) = MAX(0.0, TEMP + TOLER(2))
C
      DO 10 I=1, NUMNP
         IF (SELECT(I)) THEN
            X0 = COORD(I,1)
            Y0 = COORD(I,2)
            Z0 = COORD(I,3)
            DIST(I) = ABS(A * X0 + B * Y0 + C * Z0 - D) /
     *         SQRT(A**2 + B**2 + C**2)
            DISTR(I)=(X0 - P1(1))**2 + (Y0 - P1(2))**2 + (Z0 - P1(3))**2
         END IF
   10 CONTINUE

      INUM = 0
      DISMIN = 1.0E30
      DO 20 I=1, NUMNP
         IF (SELECT(I)) THEN
            DISMIN = MIN(DIST(I), ABS(DISMIN-TEMP))
            IF (DIST(I) .GE. TOLER(1) .AND. DIST(I) .LE. TOLER(2)) THEN
               INUM = INUM + 1
               MAP(INUM) = I
            END IF
         END IF
   20 CONTINUE

      IF      (SORTYP .EQ. 'X') THEN
         CALL INDEXX (COORD(1,1), MAP, INUM, .FALSE.)
      ELSE IF (SORTYP .EQ. 'Y') THEN
         CALL INDEXX (COORD(1,2), MAP, INUM, .FALSE.)
      ELSE IF (SORTYP .EQ. 'Z') THEN
         CALL INDEXX (COORD(1,3), MAP, INUM, .FALSE.)
      ELSE IF (SORTYP .EQ. 'RADIAL') THEN
         CALL INDEXX (DISTR,      MAP, INUM, .FALSE.)
      ELSE IF (SORTYP .EQ. 'DISTANCE') THEN
         CALL INDEXX (DIST,       MAP, INUM, .FALSE.)
      END IF

      IF (SORUP) THEN
         IBEG = 1
         IEND = INUM
         IINC = 1
      ELSE
         IBEG = INUM
         IEND = 1
         IINC = -1
      END IF

      IF (OPT .EQ. '*' .OR. INDEX(OPT, 'P') .GT. 0) THEN
         DO 30 IO=IOMIN, IOMAX
            WRITE (IO, 40) NODEL
   30    CONTINUE
   40    FORMAT (/,T50,'DISTANCE',/2X,A8,T16,'X',T26,'Y',T36,'Z',
     *      T45,'NORMAL',T57,'RADIAL',/)
         DO 60 IN = IBEG, IEND, IINC
            IF (ISABRT()) RETURN
            I = MAP(IN)
            DO 50 IO=IOMIN, IOMAX
               WRITE (IO, 90) I, (COORD(I,J),J=1,3), DIST(I),
     *            SQRT(DISTR(I))
   50       CONTINUE
   60    CONTINUE
         IF (INUM .EQ. 0) THEN
            DO 70 IO=IOMIN, IOMAX
               WRITE (IO, 80) DISMIN
   70       CONTINUE
         END IF
      END IF
   80 FORMAT (/' None found within tolerance, minimum distance = ',
     *   1PE12.3,/)
   90 FORMAT (I10, 3(F10.4), 2(1PE12.3))
      RETURN
      END


       DOUBLE COMPLEX FUNCTION InProd_mass(p1,m1,l1,p2,m2,l2)
c////////////////////////////////////////////////////////////////
c                                                              //
c  Inner product for massive spinors: Ub(p1,m1,l1)*U(p2,m2,l2) //
c                                                              //
c////////////////////////////////////////////////////////////////

          IMPLICIT NONE
          INTEGER          l1,l2
          DOUBLE PRECISION p1(0:3),p2(0:3),m1,m2
          DOUBLE PRECISION sqrt1,sqrt2,forSqrt1
          DOUBLE COMPLEX   InProd_zero
          EXTERNAL         InProd_zero
          INCLUDE 'MC_Declare.h'

          IF ((l1.EQ.+1).AND.(l2.EQ.+1)) THEN
             forSqrt1    = (p1(0)-p1(1))/(p2(0)-p2(1))
             sqrt1       = dsqrt(forSqrt1)
             sqrt2       = 1d0/sqrt1
             InProd_mass = Dcmplx(m1*sqrt2+m2*sqrt1,0d0)

          ELSEIF ((l1.EQ.+1).AND.(l2.EQ.-1)) THEN
             InProd_mass = InProd_zero(p1,+1,p2,-1)

          ELSEIF ((l1.EQ.-1).AND.(l2.EQ.+1)) THEN
             InProd_mass = InProd_zero(p1,-1,p2,+1)

          ELSEIF ((l1.EQ.-1).AND.(l2.EQ.-1)) THEN
             forSqrt1    = (p1(0)-p1(1))/(p2(0)-p2(1))
             sqrt1       = dsqrt(forSqrt1)
             sqrt2       = 1d0/sqrt1
             InProd_mass = Dcmplx(m1*sqrt2+m2*sqrt1,0d0)

          ELSE
             WRITE(MCLUN,*) " "
             WRITE(MCLUN,*) " ERROR IN InProd_mass.."
             WRITE(MCLUN,*) "       WRONG VALUES FOR l1,l2: l1,l2 = -1,+1"
             WRITE(MCLUN,*) " "
             STOP
          ENDIF

       RETURN
       END


size(tvec, dim=2)
min(tvec(2, i), tvec(1, i))
a(1, 2, 3)
f(a, b, d=5/2, c=3+3)
A(i,j,k)
X(i)
X(:)
X(a:)
X(:b)
X(a:b)
X(::c)
X(: :c)
X(a::c)
X(a: :c)
X(:b:c)
X(a:b:c)
X(a:b, : :c, a:, a: :c)


!##############################################################################
!# Tutorial 012a: Refine a brick triangulation
!##############################################################################

module tutorial012a

  ! Include basic Feat-2 modules
  use fsystem
  use genoutput

  use triangulation
  use meshgeneration
  use ucd

  implicit none
  private

  public :: start_tutorial012a

contains

  ! ***************************************************************************

  subroutine start_tutorial012a

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation
    type(t_ucdExport) :: rexport
    character(LEN=SYS_STRLEN) :: spostdir

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 012a")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Create a brick mesh
    ! =================================

    ! The mesh must always be in "standard" format to work with it.
    ! First create a 5x5-mesh on [0,1]x[0,1], then convert to standard.
    call meshgen_rectangular2DQuadMesh (rtriangulation, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP, 4, 4)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Write a VTK file with the mesh
    ! =================================
    if (sys_getenv_string("POSTDIR",spostdir)) then
      call output_line ("Writing file '"//trim(spostdir)//"/tutorial012a_level1.vtk'.")
    else
      call output_line ("Writing file './post/tutorial012a_level1.vtk'.")
    end if

    ! Open / write / close
    if (sys_getenv_string("POSTDIR",spostdir)) then
      call ucd_startVTK (rexport,UCD_FLAG_STANDARD,rtriangulation,&
                         trim(spostdir)//"/tutorial012a_level1.vtk")
    else
      call ucd_startVTK (rexport,UCD_FLAG_STANDARD,rtriangulation,&
                         "./post/tutorial012a_level1.vtk")
    end if
    call ucd_write (rexport)
    call ucd_release (rexport)

    ! =================================
    ! Refine by 2-level ordering
    ! =================================

    call tria_refine2LevelOrdering(rtriangulation)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Write a VTK file with the mesh
    ! =================================
    if (sys_getenv_string("POSTDIR",spostdir)) then
      call output_line ("Writing file '"//trim(spostdir)//"/tutorial012a_level2.vtk'.")
    else
      call output_line ("Writing file './post/tutorial012a_level2.vtk'.")
    end if

    ! Open / write / close
    if (sys_getenv_string("POSTDIR",spostdir)) then
      call ucd_startVTK (rexport,UCD_FLAG_STANDARD,rtriangulation,&
                         trim(spostdir)//"/tutorial012a_level2.vtk")
    else
      call ucd_startVTK (rexport,UCD_FLAG_STANDARD,rtriangulation,&
                         "./post/tutorial012a_level2.vtk")
    end if
    call ucd_write (rexport)
    call ucd_release (rexport)

    ! =================================
    ! Refine by 2-level ordering
    ! =================================

    call tria_refine2LevelOrdering(rtriangulation)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Write a VTK file with the mesh
    ! =================================
    if (sys_getenv_string("POSTDIR",spostdir)) then
      call output_line ("Writing file '"//trim(spostdir)//"/tutorial012a_level3.vtk'.")
    else
      call output_line ("Writing file './post/tutorial012a_level3.vtk'.")
    end if

    ! Open / write / close
    if (sys_getenv_string("POSTDIR",spostdir)) then
      call ucd_startVTK (rexport,UCD_FLAG_STANDARD,rtriangulation,&
                         trim(spostdir)//"/tutorial012a_level3.vtk")
    else
      call ucd_startVTK (rexport,UCD_FLAG_STANDARD,rtriangulation,&
                         "./post/tutorial012a_level3.vtk")
    end if
    call ucd_write (rexport)
    call ucd_release (rexport)

    ! =================================
    ! Cleanup
    ! =================================

    call tria_done (rtriangulation)

  end subroutine

end module


    !> Just compute the inverse of the anisotropy tensor (no parameters)
    !! @author Rocha, Felipe Figueredo
Subroutine computeAnisotropyTensorInv(AE, BE, MaxLRows, XLL, NDim, iDofT, NodELT, &
									Sol0, Sol1, CommonPar, Param, JParam, DelT, DTm, Time)
!     ------------------------------------------------------------------
	use globalVariables, only : setAnisoTensorInv
	implicit none

	!   ===== SUBROUTINE ARGUMENTS  =======
	integer :: MaxLRows,Ndim,iDofT,NodELT ! all integers
	Real*8 :: DelT, DTm,Time ! all reals
	Real*8 :: AE(MaxLRows,MaxLRows), BE(MaxLRows), XLL(*), Sol0(*), Sol1(*), Param(*), JParam(*), CommonPar(*)

	!   =====   END ARGUMENTS  =======

    call setAnisoTensorInv()

	AE(1,1) = 1.0d0
	BE(1) = Sol1(1)

End

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine computeAnisotropyTensorInvS(Coupling,CommonPar,iDofT,Ndim,MaxLRows,iAdd)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	IMPLICIT NONE
	Integer :: MaxLRows,Ndim,iDofT, iAdd, ipRow , i
	Integer   Coupling(MaxLRows,MaxLRows)
	Real*8 CommonPar(*)

	Coupling=0

	Coupling(1,1) = 1

end Subroutine


program ewald_conv4

! Runs a convergence study on the test_ewald4 problem, the example 4.1 in [1].
!
! [1] Pask, J. E., Sukumar, N., & Mousavi, S. E. (2012). Linear scaling
! solution of the all-electron Coulomb problem in solids. International Journal
! for Multiscale Computational Engineering, 10(1), 83–99.
! doi:10.1615/IntJMultCompEng.2011002201

use types, only: dp
use constants, only: ang2bohr, kJmol2Ha
use ewald_sums, only: ewald_box, ewald_fft1, fred2fcart
use utils, only: assert, init_random
implicit none

integer :: natom, ntypat
real(dp), parameter :: alpha = 0.90980836237716_dp ! Madelung constant
real(dp), parameter :: stress0 = 1.213077816502878_dp

real(dp) :: stress(6)
real(dp), allocatable :: xred(:, :), forces(:, :), q(:)
real(dp) :: L, E_ewald, E_ewald_fft, E_madelung
integer :: i, Ng, u

natom = 2
ntypat = 1
allocate(xred(3, natom), forces(3, natom), q(natom))
xred(:, 1) = [0, 0, 0]
xred(:, 2) = [1, 1, 1] / 2._dp
q = [1, 1]
L = 2 / sqrt(3._dp)

call ewald_box(L, xred*L, q, E_ewald, forces, stress)
E_ewald = E_ewald / (natom/ntypat)
E_madelung = -2*alpha/L
print *, "a =", L/ang2bohr*100, "pm"
print *, "Madelung: ", E_madelung / kJmol2Ha, "kJ/mol =", E_madelung, "a.u."
print *, "Ewald:    ", E_ewald / kJmol2Ha, "kJ/mol =", E_ewald, "a.u."
print *, "Ewald error:     ", abs(E_ewald - E_madelung), "a.u."
call assert(abs(E_ewald - E_madelung) < 5e-14_dp)
call assert(all(abs(forces) < 1e-15_dp))
call assert(all(abs(stress - (-stress0/L)*[1, 1, 1, 0, 0, 0]) < 1e-15_dp))

open(newunit=u, file="ewald_conv4.txt", status="replace")

Ng = 1
do i = 1, 8
    Ng = Ng*2
    print *
    print *, "Ng =",Ng

    call ewald_fft1(L, xred*L, q, Ng, 0.25_dp*L, E_ewald_fft)
    E_ewald_fft = E_ewald_fft / (natom/ntypat)

    print *, "Ewald FFT:", E_ewald_fft / kJmol2Ha, "kJ/mol =",E_ewald_fft,"a.u."
    print *, "Ewald FFT error: ", abs(E_ewald_fft - E_madelung), "a.u."

    write(u, *) Ng, E_ewald_fft
end do

close(u)

end program


submodule(euler_interface_m) euler_prob_0008_m
    implicit none

contains

    module character(len=20) function euler0008()
        write (euler0008, "(i20)") answer()
    end function euler0008

    function answer() result(ret)
        use euler_data_m, only: get_euler_data_0008
        implicit none

        integer(int64) :: big_int(1000), i, s, ret
        character(len=:), allocatable :: euler_data(:)

        call get_euler_data_0008(euler_data)
        do i = 1, 20
            s = (i - 1)*50 + 1
            read (euler_data(i), "(50(i1))") big_int(s:s + 49)
        end do

        ret = 0
        do i = 1, 988
            associate (p => product(big_int(i:i + 12)))
                if (p > ret) ret = p
            end associate
        end do
    end function answer

end submodule euler_prob_0008_m


      subroutine difsy1(n,eps,h,x,y)
c          Bulirsch-Stoer integrator.
c          --------------------------
c      For \Gamma=(H-E)/L and Y(ntime)=time
*
      PARAMETER  (NMX=80,NMX7=7*NMX)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8  Y(N),YA(NMX),YL(NMX),YM(NMX),DY(NMX),DZ(NMX),DT(NMX,7),
     &        D(7),X,XN,H,G,B,B1,U,V,C,TA,W,DABS
      COMMON/INTFAC/  LX,LE,LP,LV,LT,J10,NHALF2
      COMMON/BSSAVE/  EP(4),DSC,FACM,TFAC,ITFAC,JC
*
      LOGICAL  KONV,BO,KL,GR,FYBAD
      DATA DT /NMX7*0.0D0/
*     DATA  EP/0.4D-1,0.16D-2,0.64D-4,0.256D-5/
      SAVE
*
*     nhalf2=(n/2)*2
      jti=0
      fy=1.
      reduc=0.5
       do i=1,n
       ya(i)=y(i)
       end do
      CALL DERQP(Y(1),Y(LX),Y(LE),Y(LP),Y(LV),Y(LT),
     &           DZ(1),DZ(LX),DZ(LE),DZ(LP),DZ(LV),DZ(LT))
      IF (JC.GT.0)H=DSC
   10 xn=x+h
      bo=.false.
      m=1
      jr=2
      js=3
      do  j=1,10 ! Jmax (10 -> efficient,  4 -> short steps)
       if(bo)then
       d(2)=16d0/9.d0
       d(4)=64.d0/9.d0
       d(6)=256.d0/9.d0
       else
       d(2)=2.25d0
       d(4)=9.d0
       d(6)=3.6d1
       end if
       if(j.gt.7)then
       l=7
       d(7)=6.4d1
       else
       l=j
       d(l)=m*m
       end if
      konv=l.gt.3
      m=m+m
      g=h/(m)
      b=g+g
      m=m-1
       do i=1,n
       yl(i)=ya(i)
       ym(i)=ya(i)+g*dz(i)
       end do
      do k=1,m
      CALL DERQP(YM(1),YM(LX),YM(LE),YM(LP),YM(LV),YM(LT),
     &           DY(1),DY(LX),DY(LE),DY(LP),DY(LV),DY(LT))
       do i=1,n
       u=yl(i)+b*dy(i)
       yl(i)=ym(i)
       ym(i)=u
       end do
      end do
      CALL DERQP(YM(1),YM(LX),YM(LE),YM(LP),YM(LV),YM(LT),
     &           DY(1),DY(LX),DY(LE),DY(LP),DY(LV),DY(LT))
      kl=l.lt.2
      gr=l.gt.5
      fs=0.
      do i=1,n
      v=dt(i,1)
      c=(ym(i)+yl(i)+g*dy(i))*0.5d0
      dt(i,1)=c
      ta=c
      if(.not.kl)then
      do k=2,l
      b1=d(k)*v
      b=b1-c
      w=c-v
      u=v
       if(b.ne.0.d0)then
       b=w/b
       u=c*b
       c=b1*b
       end if
      v=dt(i,k)
      dt(i,k)=u
      ta=u+ta
      end do
      is=i+n/2
      if(is.gt.nhalf2)is=i-(n/2)
      dyis=dabs(dy(is))
      if(i.eq.n)dyis=1/(abs(ya(i))+abs(ta)) ! for time
        if(konv)then
        test=dabs( (y(i)-ta)*dyis )
        if(test.gt.eps) konv=.false.
        end if
      if(.not.gr)then
      fv=dabs(w)*dyis
      if(fs.lt.fv) fs=fv
      end if
      end if
      y(i)=ta
      end do
       if(fs.ne.0.d0)then
       fa=fy
       k=l-1
       fy=(ep(k)/fs)**(1./(l+k))
       fa7=0.7*fa
       if(l.eq.2)fa7=0.0
       fybad=.not.((fa7.gt.fy).or.(fy.gt.0.7))
        if(fy bad)then
        h=h*fy
        jti=jti+1
         if(jti.gt.10)then !Seppo's suggestion Oct/06 (5 before).
         h=0.0
          do i=1,n
          y(i)=ya(i)
          end do
         return
         end if
        goto 10
        end if
       end if
      if(konv)then
      h=xn-x
      x=xn
*     if(fy.gt.10.0)fy=10. ! factor 10 may be too large
*     if(fy.gt.4.0)fy=4. ! factor 10 may be too large
      if(fy.gt.2.0)fy=2. ! factor 10 may be too large
      h=h*fy
      return
      end if
      d(3)=4.d0
      d(5)=1.6d1
      bo=.not.bo
      m=jr
      jr=js
      js=m+m
      end do
      h=reduc*h
      reduc=0.01+reduc*reduc
      goto 10
      end