zblat1.f

Go to the documentation of this file.

*> \brief \b ZBLAT1
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       PROGRAM ZBLAT1
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>    Test program for the COMPLEX*16 Level 1 BLAS.
*>
*>    Based upon the original BLAS test routine together with:
*>    F06GAF Example Program Text
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex16_blas_testing
*
*  =====================================================================
      PROGRAM zblat1
*
*  -- Reference BLAS test routine --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER          nout
      parameter(nout=6)
*     .. Scalars in Common ..
      INTEGER          icase, incx, incy, mode, n
      LOGICAL          pass
*     .. Local Scalars ..
      DOUBLE PRECISION sfac
      INTEGER          ic
*     .. External Subroutines ..
      EXTERNAL         check1, check2, header
*     .. Common blocks ..
      COMMON           /combla/icase, n, incx, incy, mode, pass
*     .. Data statements ..
      DATA             sfac/9.765625d-4/
*     .. Executable Statements ..
      WRITE (nout,99999)
      DO 20 ic = 1, 10
         icase = ic
         CALL header
*
*        Initialize PASS, INCX, INCY, and MODE for a new case.
*        The value 9999 for INCX, INCY or MODE will appear in the
*        detailed  output, if any, for cases that do not involve
*        these parameters.
*
         pass = .true.
         incx = 9999
         incy = 9999
         mode = 9999
         IF (icase.LE.5) THEN
            CALL check2(sfac)
         ELSE IF (icase.GE.6) THEN
            CALL check1(sfac)
         END IF
*        -- Print
         IF (pass) WRITE (nout,99998)
   20 CONTINUE
      stop
*
99999 FORMAT (' Complex BLAS Test Program Results',/1x)
99998 FORMAT ('                                    ----- PASS -----')
*
*     End of ZBLAT1
*
      END
      SUBROUTINE header
*     .. Parameters ..
      INTEGER          NOUT
      parameter(nout=6)
*     .. Scalars in Common ..
      INTEGER          ICASE, INCX, INCY, MODE, N
      LOGICAL          PASS
*     .. Local Arrays ..
      CHARACTER*6      L(10)
*     .. Common blocks ..
      COMMON           /combla/icase, n, incx, incy, mode, pass
*     .. Data statements ..
      DATA             l(1)/'ZDOTC '/
      DATA             l(2)/'ZDOTU '/
      DATA             l(3)/'ZAXPY '/
      DATA             l(4)/'ZCOPY '/
      DATA             l(5)/'ZSWAP '/
      DATA             l(6)/'DZNRM2'/
      DATA             l(7)/'DZASUM'/
      DATA             l(8)/'ZSCAL '/
      DATA             l(9)/'ZDSCAL'/
      DATA             l(10)/'IZAMAX'/
*     .. Executable Statements ..
      WRITE (nout,99999) icase, l(icase)
      RETURN
*
99999 FORMAT (/' Test of subprogram number',i3,12x,a6)
*
*     End of HEADER
*
      END
      SUBROUTINE check1(SFAC)
*     .. Parameters ..
      INTEGER           NOUT
      parameter(nout=6)
*     .. Scalar Arguments ..
      DOUBLE PRECISION  SFAC
*     .. Scalars in Common ..
      INTEGER           ICASE, INCX, INCY, MODE, N
      LOGICAL           PASS
*     .. Local Scalars ..
      COMPLEX*16        CA
      DOUBLE PRECISION  SA
      INTEGER           I, IX, J, LEN, NP1
*     .. Local Arrays ..
      COMPLEX*16        CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CVR(8),
     +                  CX(8), CXR(15), MWPCS(5), MWPCT(5)
      DOUBLE PRECISION  STRUE2(5), STRUE4(5)
      INTEGER           ITRUE3(5), ITRUEC(5)
*     .. External Functions ..
      DOUBLE PRECISION  DZASUM, DZNRM2
      INTEGER           IZAMAX
      EXTERNAL          dzasum, dznrm2, izamax
*     .. External Subroutines ..
      EXTERNAL          zscal, zdscal, ctest, itest1, stest1
*     .. Intrinsic Functions ..
      INTRINSIC         max
*     .. Common blocks ..
      COMMON            /combla/icase, n, incx, incy, mode, pass
*     .. Data statements ..
      DATA              sa, ca/0.3d0, (0.4d0,-0.7d0)/
      DATA              ((cv(i,j,1),i=1,8),j=1,5)/(0.1d0,0.1d0),
     +                  (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
     +                  (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
     +                  (1.0d0,2.0d0), (0.3d0,-0.4d0), (3.0d0,4.0d0),
     +                  (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
     +                  (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
     +                  (0.1d0,-0.3d0), (0.5d0,-0.1d0), (5.0d0,6.0d0),
     +                  (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
     +                  (5.0d0,6.0d0), (5.0d0,6.0d0), (0.1d0,0.1d0),
     +                  (-0.6d0,0.1d0), (0.1d0,-0.3d0), (7.0d0,8.0d0),
     +                  (7.0d0,8.0d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
     +                  (7.0d0,8.0d0), (0.3d0,0.1d0), (0.5d0,0.0d0),
     +                  (0.0d0,0.5d0), (0.0d0,0.2d0), (2.0d0,3.0d0),
     +                  (2.0d0,3.0d0), (2.0d0,3.0d0), (2.0d0,3.0d0)/
      DATA              ((cv(i,j,2),i=1,8),j=1,5)/(0.1d0,0.1d0),
     +                  (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
     +                  (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
     +                  (4.0d0,5.0d0), (0.3d0,-0.4d0), (6.0d0,7.0d0),
     +                  (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
     +                  (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
     +                  (0.1d0,-0.3d0), (8.0d0,9.0d0), (0.5d0,-0.1d0),
     +                  (2.0d0,5.0d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
     +                  (2.0d0,5.0d0), (2.0d0,5.0d0), (0.1d0,0.1d0),
     +                  (3.0d0,6.0d0), (-0.6d0,0.1d0), (4.0d0,7.0d0),
     +                  (0.1d0,-0.3d0), (7.0d0,2.0d0), (7.0d0,2.0d0),
     +                  (7.0d0,2.0d0), (0.3d0,0.1d0), (5.0d0,8.0d0),
     +                  (0.5d0,0.0d0), (6.0d0,9.0d0), (0.0d0,0.5d0),
     +                  (8.0d0,3.0d0), (0.0d0,0.2d0), (9.0d0,4.0d0)/
      DATA              cvr/(8.0d0,8.0d0), (-7.0d0,-7.0d0),
     +                  (9.0d0,9.0d0), (5.0d0,5.0d0), (9.0d0,9.0d0),
     +                  (8.0d0,8.0d0), (7.0d0,7.0d0), (7.0d0,7.0d0)/
      DATA              strue2/0.0d0, 0.5d0, 0.6d0, 0.7d0, 0.8d0/
      DATA              strue4/0.0d0, 0.7d0, 1.0d0, 1.3d0, 1.6d0/
      DATA              ((ctrue5(i,j,1),i=1,8),j=1,5)/(0.1d0,0.1d0),
     +                  (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
     +                  (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
     +                  (1.0d0,2.0d0), (-0.16d0,-0.37d0), (3.0d0,4.0d0),
     +                  (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
     +                  (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
     +                  (-0.17d0,-0.19d0), (0.13d0,-0.39d0),
     +                  (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
     +                  (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
     +                  (0.11d0,-0.03d0), (-0.17d0,0.46d0),
     +                  (-0.17d0,-0.19d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
     +                  (7.0d0,8.0d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
     +                  (0.19d0,-0.17d0), (0.20d0,-0.35d0),
     +                  (0.35d0,0.20d0), (0.14d0,0.08d0),
     +                  (2.0d0,3.0d0), (2.0d0,3.0d0), (2.0d0,3.0d0),
     +                  (2.0d0,3.0d0)/
      DATA              ((ctrue5(i,j,2),i=1,8),j=1,5)/(0.1d0,0.1d0),
     +                  (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
     +                  (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
     +                  (4.0d0,5.0d0), (-0.16d0,-0.37d0), (6.0d0,7.0d0),
     +                  (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
     +                  (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
     +                  (-0.17d0,-0.19d0), (8.0d0,9.0d0),
     +                  (0.13d0,-0.39d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
     +                  (2.0d0,5.0d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
     +                  (0.11d0,-0.03d0), (3.0d0,6.0d0),
     +                  (-0.17d0,0.46d0), (4.0d0,7.0d0),
     +                  (-0.17d0,-0.19d0), (7.0d0,2.0d0), (7.0d0,2.0d0),
     +                  (7.0d0,2.0d0), (0.19d0,-0.17d0), (5.0d0,8.0d0),
     +                  (0.20d0,-0.35d0), (6.0d0,9.0d0),
     +                  (0.35d0,0.20d0), (8.0d0,3.0d0),
     +                  (0.14d0,0.08d0), (9.0d0,4.0d0)/
      DATA              ((ctrue6(i,j,1),i=1,8),j=1,5)/(0.1d0,0.1d0),
     +                  (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
     +                  (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
     +                  (1.0d0,2.0d0), (0.09d0,-0.12d0), (3.0d0,4.0d0),
     +                  (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
     +                  (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
     +                  (0.03d0,-0.09d0), (0.15d0,-0.03d0),
     +                  (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
     +                  (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
     +                  (0.03d0,0.03d0), (-0.18d0,0.03d0),
     +                  (0.03d0,-0.09d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
     +                  (7.0d0,8.0d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
     +                  (0.09d0,0.03d0), (0.15d0,0.00d0),
     +                  (0.00d0,0.15d0), (0.00d0,0.06d0), (2.0d0,3.0d0),
     +                  (2.0d0,3.0d0), (2.0d0,3.0d0), (2.0d0,3.0d0)/
      DATA              ((ctrue6(i,j,2),i=1,8),j=1,5)/(0.1d0,0.1d0),
     +                  (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
     +                  (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
     +                  (4.0d0,5.0d0), (0.09d0,-0.12d0), (6.0d0,7.0d0),
     +                  (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
     +                  (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
     +                  (0.03d0,-0.09d0), (8.0d0,9.0d0),
     +                  (0.15d0,-0.03d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
     +                  (2.0d0,5.0d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
     +                  (0.03d0,0.03d0), (3.0d0,6.0d0),
     +                  (-0.18d0,0.03d0), (4.0d0,7.0d0),
     +                  (0.03d0,-0.09d0), (7.0d0,2.0d0), (7.0d0,2.0d0),
     +                  (7.0d0,2.0d0), (0.09d0,0.03d0), (5.0d0,8.0d0),
     +                  (0.15d0,0.00d0), (6.0d0,9.0d0), (0.00d0,0.15d0),
     +                  (8.0d0,3.0d0), (0.00d0,0.06d0), (9.0d0,4.0d0)/
      DATA              itrue3/0, 1, 2, 2, 2/
      DATA              itruec/0, 1, 1, 1, 1/
*     .. Executable Statements ..
      DO 60 incx = 1, 2
         DO 40 np1 = 1, 5
            n = np1 - 1
            len = 2*max(n,1)
*           .. Set vector arguments ..
            DO 20 i = 1, len
               cx(i) = cv(i,np1,incx)
   20       CONTINUE
            IF (icase.EQ.6) THEN
*              .. DZNRM2 ..
               CALL stest1(dznrm2(n,cx,incx),strue2(np1),strue2(np1),
     +                     sfac)
            ELSE IF (icase.EQ.7) THEN
*              .. DZASUM ..
               CALL stest1(dzasum(n,cx,incx),strue4(np1),strue4(np1),
     +                     sfac)
            ELSE IF (icase.EQ.8) THEN
*              .. ZSCAL ..
               CALL zscal(n,ca,cx,incx)
               CALL ctest(len,cx,ctrue5(1,np1,incx),ctrue5(1,np1,incx),
     +                    sfac)
            ELSE IF (icase.EQ.9) THEN
*              .. ZDSCAL ..
               CALL zdscal(n,sa,cx,incx)
               CALL ctest(len,cx,ctrue6(1,np1,incx),ctrue6(1,np1,incx),
     +                    sfac)
            ELSE IF (icase.EQ.10) THEN
*              .. IZAMAX ..
               CALL itest1(izamax(n,cx,incx),itrue3(np1))
               DO 160 i = 1, len
                  cx(i) = (42.0d0,43.0d0)
  160          CONTINUE
               CALL itest1(izamax(n,cx,incx),itruec(np1))
            ELSE
               WRITE (nout,*) ' Shouldn''t be here in CHECK1'
               stop
            END IF
*
   40    CONTINUE
         IF (icase.EQ.10) THEN
            n = 8
            ix = 1
            DO 180 i = 1, n
               cxr(ix) = cvr(i)
               ix = ix + incx
  180       CONTINUE
            CALL itest1(izamax(n,cxr,incx),3)
         END IF
   60 CONTINUE
*
      incx = 1
      IF (icase.EQ.8) THEN
*        ZSCAL
*        Add a test for alpha equal to zero.
         ca = (0.0d0,0.0d0)
         DO 80 i = 1, 5
            mwpct(i) = (0.0d0,0.0d0)
            mwpcs(i) = (1.0d0,1.0d0)
   80    CONTINUE
         CALL zscal(5,ca,cx,incx)
         CALL ctest(5,cx,mwpct,mwpcs,sfac)
      ELSE IF (icase.EQ.9) THEN
*        ZDSCAL
*        Add a test for alpha equal to zero.
         sa = 0.0d0
         DO 100 i = 1, 5
            mwpct(i) = (0.0d0,0.0d0)
            mwpcs(i) = (1.0d0,1.0d0)
  100    CONTINUE
         CALL zdscal(5,sa,cx,incx)
         CALL ctest(5,cx,mwpct,mwpcs,sfac)
*        Add a test for alpha equal to one.
         sa = 1.0d0
         DO 120 i = 1, 5
            mwpct(i) = cx(i)
            mwpcs(i) = cx(i)
  120    CONTINUE
         CALL zdscal(5,sa,cx,incx)
         CALL ctest(5,cx,mwpct,mwpcs,sfac)
*        Add a test for alpha equal to minus one.
         sa = -1.0d0
         DO 140 i = 1, 5
            mwpct(i) = -cx(i)
            mwpcs(i) = -cx(i)
  140    CONTINUE
         CALL zdscal(5,sa,cx,incx)
         CALL ctest(5,cx,mwpct,mwpcs,sfac)
      END IF
      RETURN
*
*     End of CHECK1
*
      END
      SUBROUTINE check2(SFAC)
*     .. Parameters ..
      INTEGER           NOUT
      parameter(nout=6)
*     .. Scalar Arguments ..
      DOUBLE PRECISION  SFAC
*     .. Scalars in Common ..
      INTEGER           ICASE, INCX, INCY, MODE, N
      LOGICAL           PASS
*     .. Local Scalars ..
      COMPLEX*16        CA
      INTEGER           I, J, KI, KN, KSIZE, LENX, LENY, LINCX, LINCY,
     +                  MX, MY
*     .. Local Arrays ..
      COMPLEX*16        CDOT(1), CSIZE1(4), CSIZE2(7,2), CSIZE3(14),
     +                  CT10X(7,4,4), CT10Y(7,4,4), CT6(4,4), CT7(4,4),
     +                  CT8(7,4,4), CTY0(1), CX(7), CX0(1), CX1(7),
     +                  CY(7), CY0(1), CY1(7)
      INTEGER           INCXS(4), INCYS(4), LENS(4,2), NS(4)
*     .. External Functions ..
      COMPLEX*16        ZDOTC, ZDOTU
      EXTERNAL          zdotc, zdotu
*     .. External Subroutines ..
      EXTERNAL          zaxpy, zcopy, zswap, ctest
*     .. Intrinsic Functions ..
      INTRINSIC         abs, min
*     .. Common blocks ..
      COMMON            /combla/icase, n, incx, incy, mode, pass
*     .. Data statements ..
      DATA              ca/(0.4d0,-0.7d0)/
      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              cx1/(0.7d0,-0.8d0), (-0.4d0,-0.7d0),
     +                  (-0.1d0,-0.9d0), (0.2d0,-0.8d0),
     +                  (-0.9d0,-0.4d0), (0.1d0,0.4d0), (-0.6d0,0.6d0)/
      DATA              cy1/(0.6d0,-0.6d0), (-0.9d0,0.5d0),
     +                  (0.7d0,-0.6d0), (0.1d0,-0.5d0), (-0.1d0,-0.2d0),
     +                  (-0.5d0,-0.3d0), (0.8d0,-0.7d0)/
      DATA              ((ct8(i,j,1),i=1,7),j=1,4)/(0.6d0,-0.6d0),
     +                  (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.32d0,-1.41d0), (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.32d0,-1.41d0),
     +                  (-1.55d0,0.5d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
     +                  (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
     +                  (0.32d0,-1.41d0), (-1.55d0,0.5d0),
     +                  (0.03d0,-0.89d0), (-0.38d0,-0.96d0),
     +                  (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
      DATA              ((ct8(i,j,2),i=1,7),j=1,4)/(0.6d0,-0.6d0),
     +                  (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.32d0,-1.41d0), (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.07d0,-0.89d0),
     +                  (-0.9d0,0.5d0), (0.42d0,-1.41d0), (0.0d0,0.0d0),
     +                  (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
     +                  (0.78d0,0.06d0), (-0.9d0,0.5d0),
     +                  (0.06d0,-0.13d0), (0.1d0,-0.5d0),
     +                  (-0.77d0,-0.49d0), (-0.5d0,-0.3d0),
     +                  (0.52d0,-1.51d0)/
      DATA              ((ct8(i,j,3),i=1,7),j=1,4)/(0.6d0,-0.6d0),
     +                  (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.32d0,-1.41d0), (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.07d0,-0.89d0),
     +                  (-1.18d0,-0.31d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
     +                  (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
     +                  (0.78d0,0.06d0), (-1.54d0,0.97d0),
     +                  (0.03d0,-0.89d0), (-0.18d0,-1.31d0),
     +                  (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
      DATA              ((ct8(i,j,4),i=1,7),j=1,4)/(0.6d0,-0.6d0),
     +                  (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.32d0,-1.41d0), (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.32d0,-1.41d0), (-0.9d0,0.5d0),
     +                  (0.05d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
     +                  (0.0d0,0.0d0), (0.0d0,0.0d0), (0.32d0,-1.41d0),
     +                  (-0.9d0,0.5d0), (0.05d0,-0.6d0), (0.1d0,-0.5d0),
     +                  (-0.77d0,-0.49d0), (-0.5d0,-0.3d0),
     +                  (0.32d0,-1.16d0)/
      DATA              ct7/(0.0d0,0.0d0), (-0.06d0,-0.90d0),
     +                  (0.65d0,-0.47d0), (-0.34d0,-1.22d0),
     +                  (0.0d0,0.0d0), (-0.06d0,-0.90d0),
     +                  (-0.59d0,-1.46d0), (-1.04d0,-0.04d0),
     +                  (0.0d0,0.0d0), (-0.06d0,-0.90d0),
     +                  (-0.83d0,0.59d0), (0.07d0,-0.37d0),
     +                  (0.0d0,0.0d0), (-0.06d0,-0.90d0),
     +                  (-0.76d0,-1.15d0), (-1.33d0,-1.82d0)/
      DATA              ct6/(0.0d0,0.0d0), (0.90d0,0.06d0),
     +                  (0.91d0,-0.77d0), (1.80d0,-0.10d0),
     +                  (0.0d0,0.0d0), (0.90d0,0.06d0), (1.45d0,0.74d0),
     +                  (0.20d0,0.90d0), (0.0d0,0.0d0), (0.90d0,0.06d0),
     +                  (-0.55d0,0.23d0), (0.83d0,-0.39d0),
     +                  (0.0d0,0.0d0), (0.90d0,0.06d0), (1.04d0,0.79d0),
     +                  (1.95d0,1.22d0)/
      DATA              ((ct10x(i,j,1),i=1,7),j=1,4)/(0.7d0,-0.8d0),
     +                  (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.6d0,-0.6d0), (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.6d0,-0.6d0), (-0.9d0,0.5d0),
     +                  (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
     +                  (0.0d0,0.0d0), (0.0d0,0.0d0), (0.6d0,-0.6d0),
     +                  (-0.9d0,0.5d0), (0.7d0,-0.6d0), (0.1d0,-0.5d0),
     +                  (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
      DATA              ((ct10x(i,j,2),i=1,7),j=1,4)/(0.7d0,-0.8d0),
     +                  (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.6d0,-0.6d0), (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.7d0,-0.6d0), (-0.4d0,-0.7d0),
     +                  (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
     +                  (0.0d0,0.0d0), (0.0d0,0.0d0), (0.8d0,-0.7d0),
     +                  (-0.4d0,-0.7d0), (-0.1d0,-0.2d0),
     +                  (0.2d0,-0.8d0), (0.7d0,-0.6d0), (0.1d0,0.4d0),
     +                  (0.6d0,-0.6d0)/
      DATA              ((ct10x(i,j,3),i=1,7),j=1,4)/(0.7d0,-0.8d0),
     +                  (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.6d0,-0.6d0), (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.9d0,0.5d0), (-0.4d0,-0.7d0),
     +                  (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
     +                  (0.0d0,0.0d0), (0.0d0,0.0d0), (0.1d0,-0.5d0),
     +                  (-0.4d0,-0.7d0), (0.7d0,-0.6d0), (0.2d0,-0.8d0),
     +                  (-0.9d0,0.5d0), (0.1d0,0.4d0), (0.6d0,-0.6d0)/
      DATA              ((ct10x(i,j,4),i=1,7),j=1,4)/(0.7d0,-0.8d0),
     +                  (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.6d0,-0.6d0), (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.6d0,-0.6d0), (0.7d0,-0.6d0),
     +                  (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
     +                  (0.0d0,0.0d0), (0.0d0,0.0d0), (0.6d0,-0.6d0),
     +                  (0.7d0,-0.6d0), (-0.1d0,-0.2d0), (0.8d0,-0.7d0),
     +                  (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
      DATA              ((ct10y(i,j,1),i=1,7),j=1,4)/(0.6d0,-0.6d0),
     +                  (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.7d0,-0.8d0), (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.7d0,-0.8d0), (-0.4d0,-0.7d0),
     +                  (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
     +                  (0.0d0,0.0d0), (0.0d0,0.0d0), (0.7d0,-0.8d0),
     +                  (-0.4d0,-0.7d0), (-0.1d0,-0.9d0),
     +                  (0.2d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
     +                  (0.0d0,0.0d0)/
      DATA              ((ct10y(i,j,2),i=1,7),j=1,4)/(0.6d0,-0.6d0),
     +                  (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.7d0,-0.8d0), (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.1d0,-0.9d0), (-0.9d0,0.5d0),
     +                  (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
     +                  (0.0d0,0.0d0), (0.0d0,0.0d0), (-0.6d0,0.6d0),
     +                  (-0.9d0,0.5d0), (-0.9d0,-0.4d0), (0.1d0,-0.5d0),
     +                  (-0.1d0,-0.9d0), (-0.5d0,-0.3d0),
     +                  (0.7d0,-0.8d0)/
      DATA              ((ct10y(i,j,3),i=1,7),j=1,4)/(0.6d0,-0.6d0),
     +                  (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.7d0,-0.8d0), (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.1d0,-0.9d0), (0.7d0,-0.8d0),
     +                  (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
     +                  (0.0d0,0.0d0), (0.0d0,0.0d0), (-0.6d0,0.6d0),
     +                  (-0.9d0,-0.4d0), (-0.1d0,-0.9d0),
     +                  (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
     +                  (0.0d0,0.0d0)/
      DATA              ((ct10y(i,j,4),i=1,7),j=1,4)/(0.6d0,-0.6d0),
     +                  (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.7d0,-0.8d0), (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.7d0,-0.8d0), (-0.9d0,0.5d0),
     +                  (-0.4d0,-0.7d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
     +                  (0.0d0,0.0d0), (0.0d0,0.0d0), (0.7d0,-0.8d0),
     +                  (-0.9d0,0.5d0), (-0.4d0,-0.7d0), (0.1d0,-0.5d0),
     +                  (-0.1d0,-0.9d0), (-0.5d0,-0.3d0),
     +                  (0.2d0,-0.8d0)/
      DATA              csize1/(0.0d0,0.0d0), (0.9d0,0.9d0),
     +                  (1.63d0,1.73d0), (2.90d0,2.78d0)/
      DATA              csize3/(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)/
      DATA              csize2/(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.54d0,1.54d0),
     +                  (1.54d0,1.54d0), (1.54d0,1.54d0),
     +                  (1.54d0,1.54d0), (1.54d0,1.54d0),
     +                  (1.54d0,1.54d0), (1.54d0,1.54d0)/
*     .. Executable Statements ..
      DO 60 ki = 1, 4
         incx = incxs(ki)
         incy = incys(ki)
         mx = abs(incx)
         my = abs(incy)
*
         DO 40 kn = 1, 4
            n = ns(kn)
            ksize = min(2,kn)
            lenx = lens(kn,mx)
            leny = lens(kn,my)
*           .. initialize all argument arrays ..
            DO 20 i = 1, 7
               cx(i) = cx1(i)
               cy(i) = cy1(i)
   20       CONTINUE
            IF (icase.EQ.1) THEN
*              .. ZDOTC ..
               cdot(1) = zdotc(n,cx,incx,cy,incy)
               CALL ctest(1,cdot,ct6(kn,ki),csize1(kn),sfac)
            ELSE IF (icase.EQ.2) THEN
*              .. ZDOTU ..
               cdot(1) = zdotu(n,cx,incx,cy,incy)
               CALL ctest(1,cdot,ct7(kn,ki),csize1(kn),sfac)
            ELSE IF (icase.EQ.3) THEN
*              .. ZAXPY ..
               CALL zaxpy(n,ca,cx,incx,cy,incy)
               CALL ctest(leny,cy,ct8(1,kn,ki),csize2(1,ksize),sfac)
            ELSE IF (icase.EQ.4) THEN
*              .. ZCOPY ..
               CALL zcopy(n,cx,incx,cy,incy)
               CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0d0)
               IF (ki.EQ.1) THEN
                  cx0(1) = (42.0d0,43.0d0)
                  cy0(1) = (44.0d0,45.0d0)
                  IF (n.EQ.0) THEN
                     cty0(1) = cy0(1)
                  ELSE
                     cty0(1) = cx0(1)
                  END IF
                  lincx = incx
                  incx = 0
                  lincy = incy
                  incy = 0
                  CALL zcopy(n,cx0,incx,cy0,incy)
                  CALL ctest(1,cy0,cty0,csize3,1.0d0)
                  incx = lincx
                  incy = lincy
               END IF
            ELSE IF (icase.EQ.5) THEN
*              .. ZSWAP ..
               CALL zswap(n,cx,incx,cy,incy)
               CALL ctest(lenx,cx,ct10x(1,kn,ki),csize3,1.0d0)
               CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0d0)
            ELSE
               WRITE (nout,*) ' Shouldn''t be here in CHECK2'
               stop
            END IF
*
   40    CONTINUE
   60 CONTINUE
      RETURN
*
*     End of CHECK2
*
      END
      SUBROUTINE stest(LEN,SCOMP,STRUE,SSIZE,SFAC)
*     ********************************* 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, MODE, 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, mode, pass
*     .. Executable Statements ..
*
      DO 40 i = 1, len
         sd = scomp(i) - strue(i)
         IF (abs(sfac*sd) .LE. abs(ssize(i))*epsilon(zero))
     +       GO TO 40
*
*                             HERE    SCOMP(I) IS NOT CLOSE TO STRUE(I).
*
         IF ( .NOT. pass) GO TO 20
*                             PRINT FAIL MESSAGE AND HEADER.
         pass = .false.
         WRITE (nout,99999)
         WRITE (nout,99998)
   20    WRITE (nout,99997) icase, n, incx, incy, mode, i, scomp(i),
     +     strue(i), sd, ssize(i)
   40 CONTINUE
      RETURN
*
99999 FORMAT ('                                       FAIL')
99998 FORMAT (/' CASE  N INCX INCY MODE  I                            ',
     +       ' COMP(I)                             TRUE(I)  DIFFERENCE',
     +       '     SIZE(I)',/1x)
99997 FORMAT (1x,i4,i3,3i5,i3,2d36.8,2d12.4)
*
*     End of STEST
*
      END
      SUBROUTINE stest1(SCOMP1,STRUE1,SSIZE,SFAC)
*     ************************* 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)
*
      RETURN
*
*     End of STEST1
*
      END
      DOUBLE PRECISION FUNCTION sdiff(SA,SB)
*     ********************************* SDIFF **************************
*     COMPUTES DIFFERENCE OF TWO NUMBERS.  C. L. LAWSON, JPL 1974 FEB 15
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION                sa, sb
*     .. Executable Statements ..
      sdiff = sa - sb
      RETURN
*
*     End of SDIFF
*
      END
      SUBROUTINE ctest(LEN,CCOMP,CTRUE,CSIZE,SFAC)
*     **************************** CTEST *****************************
*
*     C.L. LAWSON, JPL, 1978 DEC 6
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION SFAC
      INTEGER          LEN
*     .. Array Arguments ..
      COMPLEX*16       CCOMP(LEN), CSIZE(LEN), CTRUE(LEN)
*     .. Local Scalars ..
      INTEGER          I
*     .. Local Arrays ..
      DOUBLE PRECISION SCOMP(20), SSIZE(20), STRUE(20)
*     .. External Subroutines ..
      EXTERNAL         stest
*     .. Intrinsic Functions ..
      INTRINSIC        dimag, dble
*     .. Executable Statements ..
      DO 20 i = 1, len
         scomp(2*i-1) = dble(ccomp(i))
         scomp(2*i) = dimag(ccomp(i))
         strue(2*i-1) = dble(ctrue(i))
         strue(2*i) = dimag(ctrue(i))
         ssize(2*i-1) = dble(csize(i))
         ssize(2*i) = dimag(csize(i))
   20 CONTINUE
*
      CALL stest(2*len,scomp,strue,ssize,sfac)
      RETURN
*
*     End of CTEST
*
      END
      SUBROUTINE itest1(ICOMP,ITRUE)
*     ********************************* 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, MODE, N
      LOGICAL           PASS
*     .. Local Scalars ..
      INTEGER           ID
*     .. Common blocks ..
      COMMON            /combla/icase, n, incx, incy, mode, pass
*     .. Executable Statements ..
      IF (icomp.EQ.itrue) GO TO 40
*
*                            HERE ICOMP IS NOT EQUAL TO ITRUE.
*
      IF ( .NOT. pass) GO TO 20
*                             PRINT FAIL MESSAGE AND HEADER.
      pass = .false.
      WRITE (nout,99999)
      WRITE (nout,99998)
   20 id = icomp - itrue
      WRITE (nout,99997) icase, n, incx, incy, mode, icomp, itrue, id
   40 CONTINUE
      RETURN
*
99999 FORMAT ('                                       FAIL')
99998 FORMAT (/' CASE  N INCX INCY MODE                               ',
     +       ' COMP                                TRUE     DIFFERENCE',
     +       /1x)
99997 FORMAT (1x,i4,i3,3i5,2i36,i12)
*
*     End of ITEST1
*
      END