diff options
| author | Stanislaw Halik <sthalik@misaki.pl> | 2019-03-03 21:09:10 +0100 |
|---|---|---|
| committer | Stanislaw Halik <sthalik@misaki.pl> | 2019-03-03 21:10:13 +0100 |
| commit | f0238cfb6997c4acfc2bd200de7295f3fa36968f (patch) | |
| tree | b215183760e4f615b9c1dabc1f116383b72a1b55 /eigen/blas/testing | |
| parent | 543edd372a5193d04b3de9f23c176ab439e51b31 (diff) | |
don't index Eigen
Diffstat (limited to 'eigen/blas/testing')
| -rw-r--r-- | eigen/blas/testing/CMakeLists.txt | 40 | ||||
| -rw-r--r-- | eigen/blas/testing/cblat1.f | 724 | ||||
| -rw-r--r-- | eigen/blas/testing/cblat2.dat | 35 | ||||
| -rw-r--r-- | eigen/blas/testing/cblat2.f | 3279 | ||||
| -rw-r--r-- | eigen/blas/testing/cblat3.dat | 23 | ||||
| -rw-r--r-- | eigen/blas/testing/cblat3.f | 3492 | ||||
| -rw-r--r-- | eigen/blas/testing/dblat1.f | 1065 | ||||
| -rw-r--r-- | eigen/blas/testing/dblat2.dat | 34 | ||||
| -rw-r--r-- | eigen/blas/testing/dblat2.f | 3176 | ||||
| -rw-r--r-- | eigen/blas/testing/dblat3.dat | 20 | ||||
| -rw-r--r-- | eigen/blas/testing/dblat3.f | 2873 | ||||
| -rw-r--r-- | eigen/blas/testing/runblastest.sh | 45 | ||||
| -rw-r--r-- | eigen/blas/testing/sblat1.f | 1021 | ||||
| -rw-r--r-- | eigen/blas/testing/sblat2.dat | 34 | ||||
| -rw-r--r-- | eigen/blas/testing/sblat2.f | 3176 | ||||
| -rw-r--r-- | eigen/blas/testing/sblat3.dat | 20 | ||||
| -rw-r--r-- | eigen/blas/testing/sblat3.f | 2873 | ||||
| -rw-r--r-- | eigen/blas/testing/zblat1.f | 724 | ||||
| -rw-r--r-- | eigen/blas/testing/zblat2.dat | 35 | ||||
| -rw-r--r-- | eigen/blas/testing/zblat2.f | 3287 | ||||
| -rw-r--r-- | eigen/blas/testing/zblat3.dat | 23 | ||||
| -rw-r--r-- | eigen/blas/testing/zblat3.f | 3502 |
22 files changed, 0 insertions, 29501 deletions
diff --git a/eigen/blas/testing/CMakeLists.txt b/eigen/blas/testing/CMakeLists.txt deleted file mode 100644 index 3ab8026..0000000 --- a/eigen/blas/testing/CMakeLists.txt +++ /dev/null @@ -1,40 +0,0 @@ - -macro(ei_add_blas_test testname) - - set(targetname ${testname}) - - set(filename ${testname}.f) - add_executable(${targetname} ${filename}) - - target_link_libraries(${targetname} eigen_blas) - - if(EIGEN_STANDARD_LIBRARIES_TO_LINK_TO) - target_link_libraries(${targetname} ${EIGEN_STANDARD_LIBRARIES_TO_LINK_TO}) - endif() - - target_link_libraries(${targetname} ${EXTERNAL_LIBS}) - - add_test(${testname} "${Eigen_SOURCE_DIR}/blas/testing/runblastest.sh" "${testname}" "${Eigen_SOURCE_DIR}/blas/testing/${testname}.dat") - add_dependencies(buildtests ${targetname}) - -endmacro(ei_add_blas_test) - -ei_add_blas_test(sblat1) -ei_add_blas_test(sblat2) -ei_add_blas_test(sblat3) - -ei_add_blas_test(dblat1) -ei_add_blas_test(dblat2) -ei_add_blas_test(dblat3) - -ei_add_blas_test(cblat1) -ei_add_blas_test(cblat2) -ei_add_blas_test(cblat3) - -ei_add_blas_test(zblat1) -ei_add_blas_test(zblat2) -ei_add_blas_test(zblat3) - -# add_custom_target(level1) -# add_dependencies(level1 sblat1) - diff --git a/eigen/blas/testing/cblat1.f b/eigen/blas/testing/cblat1.f deleted file mode 100644 index 8ca67fb..0000000 --- a/eigen/blas/testing/cblat1.f +++ /dev/null @@ -1,724 +0,0 @@ -*> \brief \b CBLAT1 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM CBLAT1 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the COMPLEX 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. -* -*> \date April 2012 -* -*> \ingroup complex_blas_testing -* -* ===================================================================== - PROGRAM CBLAT1 -* -* -- Reference BLAS test routine (version 3.4.1) -- -* -- 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, MODE, N - LOGICAL PASS -* .. Local Scalars .. - REAL SFAC - INTEGER IC -* .. External Subroutines .. - EXTERNAL CHECK1, CHECK2, HEADER -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS -* .. Data statements .. - DATA SFAC/9.765625E-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 - 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)/'CDOTC '/ - DATA L(2)/'CDOTU '/ - DATA L(3)/'CAXPY '/ - DATA L(4)/'CCOPY '/ - DATA L(5)/'CSWAP '/ - DATA L(6)/'SCNRM2'/ - DATA L(7)/'SCASUM'/ - DATA L(8)/'CSCAL '/ - DATA L(9)/'CSSCAL'/ - DATA L(10)/'ICAMAX'/ -* .. Executable Statements .. - WRITE (NOUT,99999) ICASE, L(ICASE) - RETURN -* -99999 FORMAT (/' Test of subprogram number',I3,12X,A6) - END - SUBROUTINE CHECK1(SFAC) -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalar Arguments .. - REAL SFAC -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, MODE, N - LOGICAL PASS -* .. Local Scalars .. - COMPLEX CA - REAL SA - INTEGER I, J, LEN, NP1 -* .. Local Arrays .. - COMPLEX CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CX(8), - + MWPCS(5), MWPCT(5) - REAL STRUE2(5), STRUE4(5) - INTEGER ITRUE3(5) -* .. External Functions .. - REAL SCASUM, SCNRM2 - INTEGER ICAMAX - EXTERNAL SCASUM, SCNRM2, ICAMAX -* .. External Subroutines .. - EXTERNAL CSCAL, CSSCAL, CTEST, ITEST1, STEST1 -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS -* .. Data statements .. - DATA SA, CA/0.3E0, (0.4E0,-0.7E0)/ - DATA ((CV(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0), - + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), - + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), - + (1.0E0,2.0E0), (0.3E0,-0.4E0), (3.0E0,4.0E0), - + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), - + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), - + (0.1E0,-0.3E0), (0.5E0,-0.1E0), (5.0E0,6.0E0), - + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), - + (5.0E0,6.0E0), (5.0E0,6.0E0), (0.1E0,0.1E0), - + (-0.6E0,0.1E0), (0.1E0,-0.3E0), (7.0E0,8.0E0), - + (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0), - + (7.0E0,8.0E0), (0.3E0,0.1E0), (0.5E0,0.0E0), - + (0.0E0,0.5E0), (0.0E0,0.2E0), (2.0E0,3.0E0), - + (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0)/ - DATA ((CV(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0), - + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), - + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), - + (4.0E0,5.0E0), (0.3E0,-0.4E0), (6.0E0,7.0E0), - + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), - + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), - + (0.1E0,-0.3E0), (8.0E0,9.0E0), (0.5E0,-0.1E0), - + (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0), - + (2.0E0,5.0E0), (2.0E0,5.0E0), (0.1E0,0.1E0), - + (3.0E0,6.0E0), (-0.6E0,0.1E0), (4.0E0,7.0E0), - + (0.1E0,-0.3E0), (7.0E0,2.0E0), (7.0E0,2.0E0), - + (7.0E0,2.0E0), (0.3E0,0.1E0), (5.0E0,8.0E0), - + (0.5E0,0.0E0), (6.0E0,9.0E0), (0.0E0,0.5E0), - + (8.0E0,3.0E0), (0.0E0,0.2E0), (9.0E0,4.0E0)/ - DATA STRUE2/0.0E0, 0.5E0, 0.6E0, 0.7E0, 0.8E0/ - DATA STRUE4/0.0E0, 0.7E0, 1.0E0, 1.3E0, 1.6E0/ - DATA ((CTRUE5(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0), - + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), - + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), - + (1.0E0,2.0E0), (-0.16E0,-0.37E0), (3.0E0,4.0E0), - + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), - + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), - + (-0.17E0,-0.19E0), (0.13E0,-0.39E0), - + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), - + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), - + (0.11E0,-0.03E0), (-0.17E0,0.46E0), - + (-0.17E0,-0.19E0), (7.0E0,8.0E0), (7.0E0,8.0E0), - + (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0), - + (0.19E0,-0.17E0), (0.20E0,-0.35E0), - + (0.35E0,0.20E0), (0.14E0,0.08E0), - + (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0), - + (2.0E0,3.0E0)/ - DATA ((CTRUE5(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0), - + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), - + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), - + (4.0E0,5.0E0), (-0.16E0,-0.37E0), (6.0E0,7.0E0), - + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), - + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), - + (-0.17E0,-0.19E0), (8.0E0,9.0E0), - + (0.13E0,-0.39E0), (2.0E0,5.0E0), (2.0E0,5.0E0), - + (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0), - + (0.11E0,-0.03E0), (3.0E0,6.0E0), - + (-0.17E0,0.46E0), (4.0E0,7.0E0), - + (-0.17E0,-0.19E0), (7.0E0,2.0E0), (7.0E0,2.0E0), - + (7.0E0,2.0E0), (0.19E0,-0.17E0), (5.0E0,8.0E0), - + (0.20E0,-0.35E0), (6.0E0,9.0E0), - + (0.35E0,0.20E0), (8.0E0,3.0E0), - + (0.14E0,0.08E0), (9.0E0,4.0E0)/ - DATA ((CTRUE6(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0), - + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), - + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), - + (1.0E0,2.0E0), (0.09E0,-0.12E0), (3.0E0,4.0E0), - + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), - + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), - + (0.03E0,-0.09E0), (0.15E0,-0.03E0), - + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), - + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), - + (0.03E0,0.03E0), (-0.18E0,0.03E0), - + (0.03E0,-0.09E0), (7.0E0,8.0E0), (7.0E0,8.0E0), - + (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0), - + (0.09E0,0.03E0), (0.15E0,0.00E0), - + (0.00E0,0.15E0), (0.00E0,0.06E0), (2.0E0,3.0E0), - + (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0)/ - DATA ((CTRUE6(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0), - + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), - + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), - + (4.0E0,5.0E0), (0.09E0,-0.12E0), (6.0E0,7.0E0), - + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), - + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), - + (0.03E0,-0.09E0), (8.0E0,9.0E0), - + (0.15E0,-0.03E0), (2.0E0,5.0E0), (2.0E0,5.0E0), - + (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0), - + (0.03E0,0.03E0), (3.0E0,6.0E0), - + (-0.18E0,0.03E0), (4.0E0,7.0E0), - + (0.03E0,-0.09E0), (7.0E0,2.0E0), (7.0E0,2.0E0), - + (7.0E0,2.0E0), (0.09E0,0.03E0), (5.0E0,8.0E0), - + (0.15E0,0.00E0), (6.0E0,9.0E0), (0.00E0,0.15E0), - + (8.0E0,3.0E0), (0.00E0,0.06E0), (9.0E0,4.0E0)/ - DATA ITRUE3/0, 1, 2, 2, 2/ -* .. 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 -* .. SCNRM2 .. - CALL STEST1(SCNRM2(N,CX,INCX),STRUE2(NP1),STRUE2(NP1), - + SFAC) - ELSE IF (ICASE.EQ.7) THEN -* .. SCASUM .. - CALL STEST1(SCASUM(N,CX,INCX),STRUE4(NP1),STRUE4(NP1), - + SFAC) - ELSE IF (ICASE.EQ.8) THEN -* .. CSCAL .. - CALL CSCAL(N,CA,CX,INCX) - CALL CTEST(LEN,CX,CTRUE5(1,NP1,INCX),CTRUE5(1,NP1,INCX), - + SFAC) - ELSE IF (ICASE.EQ.9) THEN -* .. CSSCAL .. - CALL CSSCAL(N,SA,CX,INCX) - CALL CTEST(LEN,CX,CTRUE6(1,NP1,INCX),CTRUE6(1,NP1,INCX), - + SFAC) - ELSE IF (ICASE.EQ.10) THEN -* .. ICAMAX .. - CALL ITEST1(ICAMAX(N,CX,INCX),ITRUE3(NP1)) - ELSE - WRITE (NOUT,*) ' Shouldn''t be here in CHECK1' - STOP - END IF -* - 40 CONTINUE - 60 CONTINUE -* - INCX = 1 - IF (ICASE.EQ.8) THEN -* CSCAL -* Add a test for alpha equal to zero. - CA = (0.0E0,0.0E0) - DO 80 I = 1, 5 - MWPCT(I) = (0.0E0,0.0E0) - MWPCS(I) = (1.0E0,1.0E0) - 80 CONTINUE - CALL CSCAL(5,CA,CX,INCX) - CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) - ELSE IF (ICASE.EQ.9) THEN -* CSSCAL -* Add a test for alpha equal to zero. - SA = 0.0E0 - DO 100 I = 1, 5 - MWPCT(I) = (0.0E0,0.0E0) - MWPCS(I) = (1.0E0,1.0E0) - 100 CONTINUE - CALL CSSCAL(5,SA,CX,INCX) - CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) -* Add a test for alpha equal to one. - SA = 1.0E0 - DO 120 I = 1, 5 - MWPCT(I) = CX(I) - MWPCS(I) = CX(I) - 120 CONTINUE - CALL CSSCAL(5,SA,CX,INCX) - CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) -* Add a test for alpha equal to minus one. - SA = -1.0E0 - DO 140 I = 1, 5 - MWPCT(I) = -CX(I) - MWPCS(I) = -CX(I) - 140 CONTINUE - CALL CSSCAL(5,SA,CX,INCX) - CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) - END IF - RETURN - END - SUBROUTINE CHECK2(SFAC) -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalar Arguments .. - REAL SFAC -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, MODE, N - LOGICAL PASS -* .. Local Scalars .. - COMPLEX CA - INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY -* .. Local Arrays .. - COMPLEX 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), CX(7), CX1(7), CY(7), CY1(7) - INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4) -* .. External Functions .. - COMPLEX CDOTC, CDOTU - EXTERNAL CDOTC, CDOTU -* .. External Subroutines .. - EXTERNAL CAXPY, CCOPY, CSWAP, CTEST -* .. Intrinsic Functions .. - INTRINSIC ABS, MIN -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS -* .. Data statements .. - DATA CA/(0.4E0,-0.7E0)/ - 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.7E0,-0.8E0), (-0.4E0,-0.7E0), - + (-0.1E0,-0.9E0), (0.2E0,-0.8E0), - + (-0.9E0,-0.4E0), (0.1E0,0.4E0), (-0.6E0,0.6E0)/ - DATA CY1/(0.6E0,-0.6E0), (-0.9E0,0.5E0), - + (0.7E0,-0.6E0), (0.1E0,-0.5E0), (-0.1E0,-0.2E0), - + (-0.5E0,-0.3E0), (0.8E0,-0.7E0)/ - DATA ((CT8(I,J,1),I=1,7),J=1,4)/(0.6E0,-0.6E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.32E0,-1.41E0), - + (-1.55E0,0.5E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.32E0,-1.41E0), (-1.55E0,0.5E0), - + (0.03E0,-0.89E0), (-0.38E0,-0.96E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ - DATA ((CT8(I,J,2),I=1,7),J=1,4)/(0.6E0,-0.6E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (-0.07E0,-0.89E0), - + (-0.9E0,0.5E0), (0.42E0,-1.41E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.78E0,0.06E0), (-0.9E0,0.5E0), - + (0.06E0,-0.13E0), (0.1E0,-0.5E0), - + (-0.77E0,-0.49E0), (-0.5E0,-0.3E0), - + (0.52E0,-1.51E0)/ - DATA ((CT8(I,J,3),I=1,7),J=1,4)/(0.6E0,-0.6E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (-0.07E0,-0.89E0), - + (-1.18E0,-0.31E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.78E0,0.06E0), (-1.54E0,0.97E0), - + (0.03E0,-0.89E0), (-0.18E0,-1.31E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ - DATA ((CT8(I,J,4),I=1,7),J=1,4)/(0.6E0,-0.6E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.32E0,-1.41E0), (-0.9E0,0.5E0), - + (0.05E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.32E0,-1.41E0), - + (-0.9E0,0.5E0), (0.05E0,-0.6E0), (0.1E0,-0.5E0), - + (-0.77E0,-0.49E0), (-0.5E0,-0.3E0), - + (0.32E0,-1.16E0)/ - DATA CT7/(0.0E0,0.0E0), (-0.06E0,-0.90E0), - + (0.65E0,-0.47E0), (-0.34E0,-1.22E0), - + (0.0E0,0.0E0), (-0.06E0,-0.90E0), - + (-0.59E0,-1.46E0), (-1.04E0,-0.04E0), - + (0.0E0,0.0E0), (-0.06E0,-0.90E0), - + (-0.83E0,0.59E0), (0.07E0,-0.37E0), - + (0.0E0,0.0E0), (-0.06E0,-0.90E0), - + (-0.76E0,-1.15E0), (-1.33E0,-1.82E0)/ - DATA CT6/(0.0E0,0.0E0), (0.90E0,0.06E0), - + (0.91E0,-0.77E0), (1.80E0,-0.10E0), - + (0.0E0,0.0E0), (0.90E0,0.06E0), (1.45E0,0.74E0), - + (0.20E0,0.90E0), (0.0E0,0.0E0), (0.90E0,0.06E0), - + (-0.55E0,0.23E0), (0.83E0,-0.39E0), - + (0.0E0,0.0E0), (0.90E0,0.06E0), (1.04E0,0.79E0), - + (1.95E0,1.22E0)/ - DATA ((CT10X(I,J,1),I=1,7),J=1,4)/(0.7E0,-0.8E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.6E0,-0.6E0), (-0.9E0,0.5E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.6E0,-0.6E0), - + (-0.9E0,0.5E0), (0.7E0,-0.6E0), (0.1E0,-0.5E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ - DATA ((CT10X(I,J,2),I=1,7),J=1,4)/(0.7E0,-0.8E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.7E0,-0.6E0), (-0.4E0,-0.7E0), - + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.8E0,-0.7E0), - + (-0.4E0,-0.7E0), (-0.1E0,-0.2E0), - + (0.2E0,-0.8E0), (0.7E0,-0.6E0), (0.1E0,0.4E0), - + (0.6E0,-0.6E0)/ - DATA ((CT10X(I,J,3),I=1,7),J=1,4)/(0.7E0,-0.8E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (-0.9E0,0.5E0), (-0.4E0,-0.7E0), - + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.1E0,-0.5E0), - + (-0.4E0,-0.7E0), (0.7E0,-0.6E0), (0.2E0,-0.8E0), - + (-0.9E0,0.5E0), (0.1E0,0.4E0), (0.6E0,-0.6E0)/ - DATA ((CT10X(I,J,4),I=1,7),J=1,4)/(0.7E0,-0.8E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.6E0,-0.6E0), (0.7E0,-0.6E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.6E0,-0.6E0), - + (0.7E0,-0.6E0), (-0.1E0,-0.2E0), (0.8E0,-0.7E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ - DATA ((CT10Y(I,J,1),I=1,7),J=1,4)/(0.6E0,-0.6E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.7E0,-0.8E0), (-0.4E0,-0.7E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.7E0,-0.8E0), - + (-0.4E0,-0.7E0), (-0.1E0,-0.9E0), - + (0.2E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0)/ - DATA ((CT10Y(I,J,2),I=1,7),J=1,4)/(0.6E0,-0.6E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (-0.1E0,-0.9E0), (-0.9E0,0.5E0), - + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (-0.6E0,0.6E0), - + (-0.9E0,0.5E0), (-0.9E0,-0.4E0), (0.1E0,-0.5E0), - + (-0.1E0,-0.9E0), (-0.5E0,-0.3E0), - + (0.7E0,-0.8E0)/ - DATA ((CT10Y(I,J,3),I=1,7),J=1,4)/(0.6E0,-0.6E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (-0.1E0,-0.9E0), (0.7E0,-0.8E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (-0.6E0,0.6E0), - + (-0.9E0,-0.4E0), (-0.1E0,-0.9E0), - + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0)/ - DATA ((CT10Y(I,J,4),I=1,7),J=1,4)/(0.6E0,-0.6E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.7E0,-0.8E0), (-0.9E0,0.5E0), - + (-0.4E0,-0.7E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.7E0,-0.8E0), - + (-0.9E0,0.5E0), (-0.4E0,-0.7E0), (0.1E0,-0.5E0), - + (-0.1E0,-0.9E0), (-0.5E0,-0.3E0), - + (0.2E0,-0.8E0)/ - DATA CSIZE1/(0.0E0,0.0E0), (0.9E0,0.9E0), - + (1.63E0,1.73E0), (2.90E0,2.78E0)/ - DATA CSIZE3/(0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (1.17E0,1.17E0), - + (1.17E0,1.17E0), (1.17E0,1.17E0), - + (1.17E0,1.17E0), (1.17E0,1.17E0), - + (1.17E0,1.17E0), (1.17E0,1.17E0)/ - DATA CSIZE2/(0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (1.54E0,1.54E0), - + (1.54E0,1.54E0), (1.54E0,1.54E0), - + (1.54E0,1.54E0), (1.54E0,1.54E0), - + (1.54E0,1.54E0), (1.54E0,1.54E0)/ -* .. 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 -* .. CDOTC .. - CDOT(1) = CDOTC(N,CX,INCX,CY,INCY) - CALL CTEST(1,CDOT,CT6(KN,KI),CSIZE1(KN),SFAC) - ELSE IF (ICASE.EQ.2) THEN -* .. CDOTU .. - CDOT(1) = CDOTU(N,CX,INCX,CY,INCY) - CALL CTEST(1,CDOT,CT7(KN,KI),CSIZE1(KN),SFAC) - ELSE IF (ICASE.EQ.3) THEN -* .. CAXPY .. - CALL CAXPY(N,CA,CX,INCX,CY,INCY) - CALL CTEST(LENY,CY,CT8(1,KN,KI),CSIZE2(1,KSIZE),SFAC) - ELSE IF (ICASE.EQ.4) THEN -* .. CCOPY .. - CALL CCOPY(N,CX,INCX,CY,INCY) - CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0E0) - ELSE IF (ICASE.EQ.5) THEN -* .. CSWAP .. - CALL CSWAP(N,CX,INCX,CY,INCY) - CALL CTEST(LENX,CX,CT10X(1,KN,KI),CSIZE3,1.0E0) - CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0E0) - ELSE - WRITE (NOUT,*) ' Shouldn''t be here in CHECK2' - STOP - END IF -* - 40 CONTINUE - 60 CONTINUE - RETURN - 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 - REAL ZERO - PARAMETER (NOUT=6, ZERO=0.0E0) -* .. Scalar Arguments .. - REAL SFAC - INTEGER LEN -* .. Array Arguments .. - REAL SCOMP(LEN), SSIZE(LEN), STRUE(LEN) -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, MODE, N - LOGICAL PASS -* .. Local Scalars .. - REAL SD - INTEGER I -* .. External Functions .. - REAL 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,2E36.8,2E12.4) - END - SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC) -* ************************* STEST1 ***************************** -* -* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE 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 .. - REAL SCOMP1, SFAC, STRUE1 -* .. Array Arguments .. - REAL SSIZE(*) -* .. Local Arrays .. - REAL 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 - REAL FUNCTION SDIFF(SA,SB) -* ********************************* SDIFF ************************** -* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 -* -* .. Scalar Arguments .. - REAL SA, SB -* .. Executable Statements .. - SDIFF = SA - SB - RETURN - END - SUBROUTINE CTEST(LEN,CCOMP,CTRUE,CSIZE,SFAC) -* **************************** CTEST ***************************** -* -* C.L. LAWSON, JPL, 1978 DEC 6 -* -* .. Scalar Arguments .. - REAL SFAC - INTEGER LEN -* .. Array Arguments .. - COMPLEX CCOMP(LEN), CSIZE(LEN), CTRUE(LEN) -* .. Local Scalars .. - INTEGER I -* .. Local Arrays .. - REAL SCOMP(20), SSIZE(20), STRUE(20) -* .. External Subroutines .. - EXTERNAL STEST -* .. Intrinsic Functions .. - INTRINSIC AIMAG, REAL -* .. Executable Statements .. - DO 20 I = 1, LEN - SCOMP(2*I-1) = REAL(CCOMP(I)) - SCOMP(2*I) = AIMAG(CCOMP(I)) - STRUE(2*I-1) = REAL(CTRUE(I)) - STRUE(2*I) = AIMAG(CTRUE(I)) - SSIZE(2*I-1) = REAL(CSIZE(I)) - SSIZE(2*I) = AIMAG(CSIZE(I)) - 20 CONTINUE -* - CALL STEST(2*LEN,SCOMP,STRUE,SSIZE,SFAC) - RETURN - 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 diff --git a/eigen/blas/testing/cblat2.dat b/eigen/blas/testing/cblat2.dat deleted file mode 100644 index ae98730..0000000 --- a/eigen/blas/testing/cblat2.dat +++ /dev/null @@ -1,35 +0,0 @@ -'cblat2.summ' NAME OF SUMMARY OUTPUT FILE -6 UNIT NUMBER OF SUMMARY FILE -'cblat2.snap' NAME OF SNAPSHOT OUTPUT FILE --1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -F LOGICAL FLAG, T TO STOP ON FAILURES. -T LOGICAL FLAG, T TO TEST ERROR EXITS. -16.0 THRESHOLD VALUE OF TEST RATIO -6 NUMBER OF VALUES OF N -0 1 2 3 5 9 VALUES OF N -4 NUMBER OF VALUES OF K -0 1 2 4 VALUES OF K -4 NUMBER OF VALUES OF INCX AND INCY -1 2 -1 -2 VALUES OF INCX AND INCY -3 NUMBER OF VALUES OF ALPHA -(0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA -3 NUMBER OF VALUES OF BETA -(0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA -CGEMV T PUT F FOR NO TEST. SAME COLUMNS. -CGBMV T PUT F FOR NO TEST. SAME COLUMNS. -CHEMV T PUT F FOR NO TEST. SAME COLUMNS. -CHBMV T PUT F FOR NO TEST. SAME COLUMNS. -CHPMV T PUT F FOR NO TEST. SAME COLUMNS. -CTRMV T PUT F FOR NO TEST. SAME COLUMNS. -CTBMV T PUT F FOR NO TEST. SAME COLUMNS. -CTPMV T PUT F FOR NO TEST. SAME COLUMNS. -CTRSV T PUT F FOR NO TEST. SAME COLUMNS. -CTBSV T PUT F FOR NO TEST. SAME COLUMNS. -CTPSV T PUT F FOR NO TEST. SAME COLUMNS. -CGERC T PUT F FOR NO TEST. SAME COLUMNS. -CGERU T PUT F FOR NO TEST. SAME COLUMNS. -CHER T PUT F FOR NO TEST. SAME COLUMNS. -CHPR T PUT F FOR NO TEST. SAME COLUMNS. -CHER2 T PUT F FOR NO TEST. SAME COLUMNS. -CHPR2 T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/eigen/blas/testing/cblat2.f b/eigen/blas/testing/cblat2.f deleted file mode 100644 index 5833ea8..0000000 --- a/eigen/blas/testing/cblat2.f +++ /dev/null @@ -1,3279 +0,0 @@ -*> \brief \b CBLAT2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM CBLAT2 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the COMPLEX Level 2 Blas. -*> -*> The program must be driven by a short data file. The first 18 records -*> of the file are read using list-directed input, the last 17 records -*> are read using the format ( A6, L2 ). An annotated example of a data -*> file can be obtained by deleting the first 3 characters from the -*> following 35 lines: -*> 'cblat2.out' NAME OF SUMMARY OUTPUT FILE -*> 6 UNIT NUMBER OF SUMMARY FILE -*> 'CBLA2T.SNAP' NAME OF SNAPSHOT OUTPUT FILE -*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -*> F LOGICAL FLAG, T TO STOP ON FAILURES. -*> T LOGICAL FLAG, T TO TEST ERROR EXITS. -*> 16.0 THRESHOLD VALUE OF TEST RATIO -*> 6 NUMBER OF VALUES OF N -*> 0 1 2 3 5 9 VALUES OF N -*> 4 NUMBER OF VALUES OF K -*> 0 1 2 4 VALUES OF K -*> 4 NUMBER OF VALUES OF INCX AND INCY -*> 1 2 -1 -2 VALUES OF INCX AND INCY -*> 3 NUMBER OF VALUES OF ALPHA -*> (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA -*> 3 NUMBER OF VALUES OF BETA -*> (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA -*> CGEMV T PUT F FOR NO TEST. SAME COLUMNS. -*> CGBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> CHEMV T PUT F FOR NO TEST. SAME COLUMNS. -*> CHBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> CHPMV T PUT F FOR NO TEST. SAME COLUMNS. -*> CTRMV T PUT F FOR NO TEST. SAME COLUMNS. -*> CTBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> CTPMV T PUT F FOR NO TEST. SAME COLUMNS. -*> CTRSV T PUT F FOR NO TEST. SAME COLUMNS. -*> CTBSV T PUT F FOR NO TEST. SAME COLUMNS. -*> CTPSV T PUT F FOR NO TEST. SAME COLUMNS. -*> CGERC T PUT F FOR NO TEST. SAME COLUMNS. -*> CGERU T PUT F FOR NO TEST. SAME COLUMNS. -*> CHER T PUT F FOR NO TEST. SAME COLUMNS. -*> CHPR T PUT F FOR NO TEST. SAME COLUMNS. -*> CHER2 T PUT F FOR NO TEST. SAME COLUMNS. -*> CHPR2 T PUT F FOR NO TEST. SAME COLUMNS. -*> -*> Further Details -*> =============== -*> -*> See: -*> -*> Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. -*> An extended set of Fortran Basic Linear Algebra Subprograms. -*> -*> Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics -*> and Computer Science Division, Argonne National Laboratory, -*> 9700 South Cass Avenue, Argonne, Illinois 60439, US. -*> -*> Or -*> -*> NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms -*> Group Ltd., NAG Central Office, 256 Banbury Road, Oxford -*> OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st -*> Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. -*> -*> -*> -- Written on 10-August-1987. -*> Richard Hanson, Sandia National Labs. -*> Jeremy Du Croz, NAG Central Office. -*> -*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers -*> can be run multiple times without deleting generated -*> output files (susan) -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date April 2012 -* -*> \ingroup complex_blas_testing -* -* ===================================================================== - PROGRAM CBLAT2 -* -* -- Reference BLAS test routine (version 3.4.1) -- -* -- 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 NIN - PARAMETER ( NIN = 5 ) - INTEGER NSUBS - PARAMETER ( NSUBS = 17 ) - COMPLEX ZERO, ONE - PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) - INTEGER NMAX, INCMAX - PARAMETER ( NMAX = 65, INCMAX = 2 ) - INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX - PARAMETER ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7, - $ NALMAX = 7, NBEMAX = 7 ) -* .. Local Scalars .. - REAL EPS, ERR, THRESH - INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB, - $ NOUT, NTRA - LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, - $ TSTERR - CHARACTER*1 TRANS - CHARACTER*6 SNAMET - CHARACTER*32 SNAPS, SUMMRY -* .. Local Arrays .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), - $ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ), - $ X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( 2*NMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX ) - LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) -* .. External Functions .. - REAL SDIFF - LOGICAL LCE - EXTERNAL SDIFF, LCE -* .. External Subroutines .. - EXTERNAL CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CCHK6, - $ CCHKE, CMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Data statements .. - DATA SNAMES/'CGEMV ', 'CGBMV ', 'CHEMV ', 'CHBMV ', - $ 'CHPMV ', 'CTRMV ', 'CTBMV ', 'CTPMV ', - $ 'CTRSV ', 'CTBSV ', 'CTPSV ', 'CGERC ', - $ 'CGERU ', 'CHER ', 'CHPR ', 'CHER2 ', - $ 'CHPR2 '/ -* .. Executable Statements .. -* -* Read name and unit number for summary output file and open file. -* - READ( NIN, FMT = * )SUMMRY - READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) - NOUTC = NOUT -* -* Read name and unit number for snapshot output file and open file. -* - READ( NIN, FMT = * )SNAPS - READ( NIN, FMT = * )NTRA - TRACE = NTRA.GE.0 - IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' ) - END IF -* Read the flag that directs rewinding of the snapshot file. - READ( NIN, FMT = * )REWI - REWI = REWI.AND.TRACE -* Read the flag that directs stopping on any failure. - READ( NIN, FMT = * )SFATAL -* Read the flag that indicates whether error exits are to be tested. - READ( NIN, FMT = * )TSTERR -* Read the threshold value of the test ratio - READ( NIN, FMT = * )THRESH -* -* Read and check the parameter values for the tests. -* -* Values of N - READ( NIN, FMT = * )NIDIM - IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN - WRITE( NOUT, FMT = 9997 )'N', NIDMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) - DO 10 I = 1, NIDIM - IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN - WRITE( NOUT, FMT = 9996 )NMAX - GO TO 230 - END IF - 10 CONTINUE -* Values of K - READ( NIN, FMT = * )NKB - IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN - WRITE( NOUT, FMT = 9997 )'K', NKBMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( KB( I ), I = 1, NKB ) - DO 20 I = 1, NKB - IF( KB( I ).LT.0 )THEN - WRITE( NOUT, FMT = 9995 ) - GO TO 230 - END IF - 20 CONTINUE -* Values of INCX and INCY - READ( NIN, FMT = * )NINC - IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN - WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( INC( I ), I = 1, NINC ) - DO 30 I = 1, NINC - IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN - WRITE( NOUT, FMT = 9994 )INCMAX - GO TO 230 - END IF - 30 CONTINUE -* Values of ALPHA - READ( NIN, FMT = * )NALF - IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN - WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) -* Values of BETA - READ( NIN, FMT = * )NBET - IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN - WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) -* -* Report values of parameters. -* - WRITE( NOUT, FMT = 9993 ) - WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM ) - WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB ) - WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC ) - WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF ) - WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET ) - IF( .NOT.TSTERR )THEN - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9980 ) - END IF - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9999 )THRESH - WRITE( NOUT, FMT = * ) -* -* Read names of subroutines and flags which indicate -* whether they are to be tested. -* - DO 40 I = 1, NSUBS - LTEST( I ) = .FALSE. - 40 CONTINUE - 50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT - DO 60 I = 1, NSUBS - IF( SNAMET.EQ.SNAMES( I ) ) - $ GO TO 70 - 60 CONTINUE - WRITE( NOUT, FMT = 9986 )SNAMET - STOP - 70 LTEST( I ) = LTESTT - GO TO 50 -* - 80 CONTINUE - CLOSE ( NIN ) -* -* Compute EPS (the machine precision). -* - EPS = EPSILON(RZERO) - WRITE( NOUT, FMT = 9998 )EPS -* -* Check the reliability of CMVCH using exact data. -* - N = MIN( 32, NMAX ) - DO 120 J = 1, N - DO 110 I = 1, N - A( I, J ) = MAX( I - J + 1, 0 ) - 110 CONTINUE - X( J ) = J - Y( J ) = ZERO - 120 CONTINUE - DO 130 J = 1, N - YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 - 130 CONTINUE -* YY holds the exact result. On exit from CMVCH YT holds -* the result computed by CMVCH. - TRANS = 'N' - CALL CMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LCE( YY, YT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR - STOP - END IF - TRANS = 'T' - CALL CMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LCE( YY, YT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR - STOP - END IF -* -* Test each subroutine in turn. -* - DO 210 ISNUM = 1, NSUBS - WRITE( NOUT, FMT = * ) - IF( .NOT.LTEST( ISNUM ) )THEN -* Subprogram is not to be tested. - WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM ) - ELSE - SRNAMT = SNAMES( ISNUM ) -* Test error exits. - IF( TSTERR )THEN - CALL CCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) - WRITE( NOUT, FMT = * ) - END IF -* Test computations. - INFOT = 0 - OK = .TRUE. - FATAL = .FALSE. - GO TO ( 140, 140, 150, 150, 150, 160, 160, - $ 160, 160, 160, 160, 170, 170, 180, - $ 180, 190, 190 )ISNUM -* Test CGEMV, 01, and CGBMV, 02. - 140 CALL CCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, - $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, - $ X, XX, XS, Y, YY, YS, YT, G ) - GO TO 200 -* Test CHEMV, 03, CHBMV, 04, and CHPMV, 05. - 150 CALL CCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, - $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, - $ X, XX, XS, Y, YY, YS, YT, G ) - GO TO 200 -* Test CTRMV, 06, CTBMV, 07, CTPMV, 08, -* CTRSV, 09, CTBSV, 10, and CTPSV, 11. - 160 CALL CCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z ) - GO TO 200 -* Test CGERC, 12, CGERU, 13. - 170 CALL CCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) - GO TO 200 -* Test CHER, 14, and CHPR, 15. - 180 CALL CCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) - GO TO 200 -* Test CHER2, 16, and CHPR2, 17. - 190 CALL CCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) -* - 200 IF( FATAL.AND.SFATAL ) - $ GO TO 220 - END IF - 210 CONTINUE - WRITE( NOUT, FMT = 9982 ) - GO TO 240 -* - 220 CONTINUE - WRITE( NOUT, FMT = 9981 ) - GO TO 240 -* - 230 CONTINUE - WRITE( NOUT, FMT = 9987 ) -* - 240 CONTINUE - IF( TRACE ) - $ CLOSE ( NTRA ) - CLOSE ( NOUT ) - STOP -* - 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', - $ 'S THAN', F8.2 ) - 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 ) - 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', - $ 'THAN ', I2 ) - 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) - 9995 FORMAT( ' VALUE OF K IS LESS THAN 0' ) - 9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ', - $ I2 ) - 9993 FORMAT( ' TESTS OF THE COMPLEX LEVEL 2 BLAS', //' THE F', - $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) - 9992 FORMAT( ' FOR N ', 9I6 ) - 9991 FORMAT( ' FOR K ', 7I6 ) - 9990 FORMAT( ' FOR INCX AND INCY ', 7I6 ) - 9989 FORMAT( ' FOR ALPHA ', - $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) - 9988 FORMAT( ' FOR BETA ', - $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) - 9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', - $ /' ******* TESTS ABANDONED *******' ) - 9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', - $ 'ESTS ABANDONED *******' ) - 9985 FORMAT( ' ERROR IN CMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', - $ 'ATED WRONGLY.', /' CMVCH WAS CALLED WITH TRANS = ', A1, - $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', / - $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.' - $ , /' ******* TESTS ABANDONED *******' ) - 9984 FORMAT( A6, L2 ) - 9983 FORMAT( 1X, A6, ' WAS NOT TESTED' ) - 9982 FORMAT( /' END OF TESTS' ) - 9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) - 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) -* -* End of CBLAT2. -* - END - SUBROUTINE CCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, - $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, - $ XS, Y, YY, YS, YT, G ) -* -* Tests CGEMV and CGBMV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX ZERO, HALF - PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, - $ NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), BET( NBET ), X( NMAX ), - $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), - $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - COMPLEX ALPHA, ALS, BETA, BLS, TRANSL - REAL ERR, ERRMAX - INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY, - $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA, - $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK, - $ NL, NS - LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN - CHARACTER*1 TRANS, TRANSS - CHARACTER*3 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CGBMV, CGEMV, CMAKE, CMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'NTC'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'E' - BANDED = SNAME( 3: 3 ).EQ.'B' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 11 - ELSE IF( BANDED )THEN - NARGS = 13 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 120 IN = 1, NIDIM - N = IDIM( IN ) - ND = N/2 + 1 -* - DO 110 IM = 1, 2 - IF( IM.EQ.1 ) - $ M = MAX( N - ND, 0 ) - IF( IM.EQ.2 ) - $ M = MIN( N + ND, NMAX ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IKU = 1, NK - IF( BANDED )THEN - KU = KB( IKU ) - KL = MAX( KU - 1, 0 ) - ELSE - KU = N - 1 - KL = M - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = KL + KU + 1 - ELSE - LDA = M - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - LAA = LDA*N - NULL = N.LE.0.OR.M.LE.0 -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL CMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, AA, - $ LDA, KL, KU, RESET, TRANSL ) -* - DO 90 IC = 1, 3 - TRANS = ICH( IC: IC ) - TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' -* - IF( TRAN )THEN - ML = N - NL = M - ELSE - ML = M - NL = N - END IF -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*NL -* -* Generate the vector X. -* - TRANSL = HALF - CALL CMAKE( 'GE', ' ', ' ', 1, NL, X, 1, XX, - $ ABS( INCX ), 0, NL - 1, RESET, TRANSL ) - IF( NL.GT.1 )THEN - X( NL/2 ) = ZERO - XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO - END IF -* - DO 70 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*ML -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL CMAKE( 'GE', ' ', ' ', 1, ML, Y, 1, - $ YY, ABS( INCY ), 0, ML - 1, - $ RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - TRANSS = TRANS - MS = M - NS = N - KLS = KL - KUS = KU - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - BLS = BETA - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ TRANS, M, N, ALPHA, LDA, INCX, BETA, - $ INCY - IF( REWI ) - $ REWIND NTRA - CALL CGEMV( TRANS, M, N, ALPHA, AA, - $ LDA, XX, INCX, BETA, YY, - $ INCY ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ TRANS, M, N, KL, KU, ALPHA, LDA, - $ INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL CGBMV( TRANS, M, N, KL, KU, ALPHA, - $ AA, LDA, XX, INCX, BETA, - $ YY, INCY ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 130 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = TRANS.EQ.TRANSS - ISAME( 2 ) = MS.EQ.M - ISAME( 3 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 4 ) = ALS.EQ.ALPHA - ISAME( 5 ) = LCE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - ISAME( 7 ) = LCE( XS, XX, LX ) - ISAME( 8 ) = INCXS.EQ.INCX - ISAME( 9 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 10 ) = LCE( YS, YY, LY ) - ELSE - ISAME( 10 ) = LCERES( 'GE', ' ', 1, - $ ML, YS, YY, - $ ABS( INCY ) ) - END IF - ISAME( 11 ) = INCYS.EQ.INCY - ELSE IF( BANDED )THEN - ISAME( 4 ) = KLS.EQ.KL - ISAME( 5 ) = KUS.EQ.KU - ISAME( 6 ) = ALS.EQ.ALPHA - ISAME( 7 ) = LCE( AS, AA, LAA ) - ISAME( 8 ) = LDAS.EQ.LDA - ISAME( 9 ) = LCE( XS, XX, LX ) - ISAME( 10 ) = INCXS.EQ.INCX - ISAME( 11 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 12 ) = LCE( YS, YY, LY ) - ELSE - ISAME( 12 ) = LCERES( 'GE', ' ', 1, - $ ML, YS, YY, - $ ABS( INCY ) ) - END IF - ISAME( 13 ) = INCYS.EQ.INCY - END IF -* -* If data was incorrectly changed, report -* and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 130 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL CMVCH( TRANS, M, N, ALPHA, A, - $ NMAX, X, INCX, BETA, Y, - $ INCY, YT, G, YY, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 130 - ELSE -* Avoid repeating tests with M.le.0 or -* N.le.0. - GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 140 -* - 130 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, TRANS, M, N, ALPHA, LDA, - $ INCX, BETA, INCY - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANS, M, N, KL, KU, - $ ALPHA, LDA, INCX, BETA, INCY - END IF -* - 140 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), '(', - $ F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', - $ F4.1, '), Y,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(', - $ F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', - $ F4.1, '), Y,', I2, ') .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK1. -* - END - SUBROUTINE CCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, - $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, - $ XS, Y, YY, YS, YT, G ) -* -* Tests CHEMV, CHBMV and CHPMV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX ZERO, HALF - PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, - $ NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), BET( NBET ), X( NMAX ), - $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), - $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - COMPLEX ALPHA, ALS, BETA, BLS, TRANSL - REAL ERR, ERRMAX - INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY, - $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY, - $ N, NARGS, NC, NK, NS - LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CHBMV, CHEMV, CHPMV, CMAKE, CMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'E' - BANDED = SNAME( 3: 3 ).EQ.'B' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 10 - ELSE IF( BANDED )THEN - NARGS = 11 - ELSE IF( PACKED )THEN - NARGS = 9 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 110 IN = 1, NIDIM - N = IDIM( IN ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IK = 1, NK - IF( BANDED )THEN - K = KB( IK ) - ELSE - K = N - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = K + 1 - ELSE - LDA = N - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF - NULL = N.LE.0 -* - DO 90 IC = 1, 2 - UPLO = ICH( IC: IC ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA, - $ LDA, K, K, RESET, TRANSL ) -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL CMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, - $ ABS( INCX ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 70 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL CMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, - $ TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - UPLOS = UPLO - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - BLS = BETA - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, N, ALPHA, LDA, INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL CHEMV( UPLO, N, ALPHA, AA, LDA, XX, - $ INCX, BETA, YY, INCY ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, N, K, ALPHA, LDA, INCX, BETA, - $ INCY - IF( REWI ) - $ REWIND NTRA - CALL CHBMV( UPLO, N, K, ALPHA, AA, LDA, - $ XX, INCX, BETA, YY, INCY ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, N, ALPHA, INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL CHPMV( UPLO, N, ALPHA, AA, XX, INCX, - $ BETA, YY, INCY ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LCE( AS, AA, LAA ) - ISAME( 5 ) = LDAS.EQ.LDA - ISAME( 6 ) = LCE( XS, XX, LX ) - ISAME( 7 ) = INCXS.EQ.INCX - ISAME( 8 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 9 ) = LCE( YS, YY, LY ) - ELSE - ISAME( 9 ) = LCERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 10 ) = INCYS.EQ.INCY - ELSE IF( BANDED )THEN - ISAME( 3 ) = KS.EQ.K - ISAME( 4 ) = ALS.EQ.ALPHA - ISAME( 5 ) = LCE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - ISAME( 7 ) = LCE( XS, XX, LX ) - ISAME( 8 ) = INCXS.EQ.INCX - ISAME( 9 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 10 ) = LCE( YS, YY, LY ) - ELSE - ISAME( 10 ) = LCERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 11 ) = INCYS.EQ.INCY - ELSE IF( PACKED )THEN - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LCE( AS, AA, LAA ) - ISAME( 5 ) = LCE( XS, XX, LX ) - ISAME( 6 ) = INCXS.EQ.INCX - ISAME( 7 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 8 ) = LCE( YS, YY, LY ) - ELSE - ISAME( 8 ) = LCERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 9 ) = INCYS.EQ.INCY - END IF -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL CMVCH( 'N', N, N, ALPHA, A, NMAX, X, - $ INCX, BETA, Y, INCY, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 120 - ELSE -* Avoid repeating tests with N.le.0 - GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, LDA, INCX, - $ BETA, INCY - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, K, ALPHA, LDA, - $ INCX, BETA, INCY - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, N, ALPHA, INCX, - $ BETA, INCY - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', - $ F4.1, '), AP, X,', I2, ',(', F4.1, ',', F4.1, '), Y,', I2, - $ ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(', - $ F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', - $ F4.1, '), Y,', I2, ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', - $ F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', F4.1, '), ', - $ 'Y,', I2, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK2. -* - END - SUBROUTINE CCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z ) -* -* Tests CTRMV, CTBMV, CTPMV, CTRSV, CTBSV and CTPSV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX ZERO, HALF, ONE - PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), - $ ONE = ( 1.0, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), - $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), - $ XT( NMAX ), XX( NMAX*INCMAX ), Z( NMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - COMPLEX TRANSL - REAL ERR, ERRMAX - INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K, - $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS - LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME - CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS - CHARACTER*2 ICHD, ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CMAKE, CMVCH, CTBMV, CTBSV, CTPMV, CTPSV, - $ CTRMV, CTRSV -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'R' - BANDED = SNAME( 3: 3 ).EQ.'B' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 8 - ELSE IF( BANDED )THEN - NARGS = 9 - ELSE IF( PACKED )THEN - NARGS = 7 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* Set up zero vector for CMVCH. - DO 10 I = 1, NMAX - Z( I ) = ZERO - 10 CONTINUE -* - DO 110 IN = 1, NIDIM - N = IDIM( IN ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IK = 1, NK - IF( BANDED )THEN - K = KB( IK ) - ELSE - K = N - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = K + 1 - ELSE - LDA = N - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF - NULL = N.LE.0 -* - DO 90 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* - DO 80 ICT = 1, 3 - TRANS = ICHT( ICT: ICT ) -* - DO 70 ICD = 1, 2 - DIAG = ICHD( ICD: ICD ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL CMAKE( SNAME( 2: 3 ), UPLO, DIAG, N, N, A, - $ NMAX, AA, LDA, K, K, RESET, TRANSL ) -* - DO 60 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL CMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, - $ ABS( INCX ), 0, N - 1, RESET, - $ TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - DIAGS = DIAG - NS = N - KS = K - DO 20 I = 1, LAA - AS( I ) = AA( I ) - 20 CONTINUE - LDAS = LDA - DO 30 I = 1, LX - XS( I ) = XX( I ) - 30 CONTINUE - INCXS = INCX -* -* Call the subroutine. -* - IF( SNAME( 4: 5 ).EQ.'MV' )THEN - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL CTRMV( UPLO, TRANS, DIAG, N, AA, LDA, - $ XX, INCX ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, K, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL CTBMV( UPLO, TRANS, DIAG, N, K, AA, - $ LDA, XX, INCX ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, INCX - IF( REWI ) - $ REWIND NTRA - CALL CTPMV( UPLO, TRANS, DIAG, N, AA, XX, - $ INCX ) - END IF - ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL CTRSV( UPLO, TRANS, DIAG, N, AA, LDA, - $ XX, INCX ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, K, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL CTBSV( UPLO, TRANS, DIAG, N, K, AA, - $ LDA, XX, INCX ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, INCX - IF( REWI ) - $ REWIND NTRA - CALL CTPSV( UPLO, TRANS, DIAG, N, AA, XX, - $ INCX ) - END IF - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = TRANS.EQ.TRANSS - ISAME( 3 ) = DIAG.EQ.DIAGS - ISAME( 4 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 5 ) = LCE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 7 ) = LCE( XS, XX, LX ) - ELSE - ISAME( 7 ) = LCERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 8 ) = INCXS.EQ.INCX - ELSE IF( BANDED )THEN - ISAME( 5 ) = KS.EQ.K - ISAME( 6 ) = LCE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 8 ) = LCE( XS, XX, LX ) - ELSE - ISAME( 8 ) = LCERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 9 ) = INCXS.EQ.INCX - ELSE IF( PACKED )THEN - ISAME( 5 ) = LCE( AS, AA, LAA ) - IF( NULL )THEN - ISAME( 6 ) = LCE( XS, XX, LX ) - ELSE - ISAME( 6 ) = LCERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 7 ) = INCXS.EQ.INCX - END IF -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN - IF( SNAME( 4: 5 ).EQ.'MV' )THEN -* -* Check the result. -* - CALL CMVCH( TRANS, N, N, ONE, A, NMAX, X, - $ INCX, ZERO, Z, INCX, XT, G, - $ XX, EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN -* -* Compute approximation to original vector. -* - DO 50 I = 1, N - Z( I ) = XX( 1 + ( I - 1 )* - $ ABS( INCX ) ) - XX( 1 + ( I - 1 )*ABS( INCX ) ) - $ = X( I ) - 50 CONTINUE - CALL CMVCH( TRANS, N, N, ONE, A, NMAX, Z, - $ INCX, ZERO, X, INCX, XT, G, - $ XX, EPS, ERR, FATAL, NOUT, - $ .FALSE. ) - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 120 - ELSE -* Avoid repeating tests with N.le.0. - GO TO 110 - END IF -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, DIAG, N, LDA, - $ INCX - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, DIAG, N, K, - $ LDA, INCX - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, TRANS, DIAG, N, INCX - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', AP, ', - $ 'X,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ), - $ ' A,', I3, ', X,', I2, ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,', - $ I3, ', X,', I2, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK3. -* - END - SUBROUTINE CCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests CGERC and CGERU. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX ZERO, HALF, ONE - PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), - $ ONE = ( 1.0, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - COMPLEX ALPHA, ALS, TRANSL - REAL ERR, ERRMAX - INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX, - $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS, - $ NC, ND, NS - LOGICAL CONJ, NULL, RESET, SAME -* .. Local Arrays .. - COMPLEX W( 1 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CGERC, CGERU, CMAKE, CMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, CONJG, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. - CONJ = SNAME( 5: 5 ).EQ.'C' -* Define the number of arguments. - NARGS = 9 -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 120 IN = 1, NIDIM - N = IDIM( IN ) - ND = N/2 + 1 -* - DO 110 IM = 1, 2 - IF( IM.EQ.1 ) - $ M = MAX( N - ND, 0 ) - IF( IM.EQ.2 ) - $ M = MIN( N + ND, NMAX ) -* -* Set LDA to 1 more than minimum value if room. - LDA = M - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 110 - LAA = LDA*N - NULL = N.LE.0.OR.M.LE.0 -* - DO 100 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*M -* -* Generate the vector X. -* - TRANSL = HALF - CALL CMAKE( 'GE', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ), - $ 0, M - 1, RESET, TRANSL ) - IF( M.GT.1 )THEN - X( M/2 ) = ZERO - XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO - END IF -* - DO 90 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL CMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - Y( N/2 ) = ZERO - YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 80 IA = 1, NALF - ALPHA = ALF( IA ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL CMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, - $ AA, LDA, M - 1, N - 1, RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - MS = M - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N, - $ ALPHA, INCX, INCY, LDA - IF( CONJ )THEN - IF( REWI ) - $ REWIND NTRA - CALL CGERC( M, N, ALPHA, XX, INCX, YY, INCY, AA, - $ LDA ) - ELSE - IF( REWI ) - $ REWIND NTRA - CALL CGERU( M, N, ALPHA, XX, INCX, YY, INCY, AA, - $ LDA ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 140 - END IF -* -* See what data changed inside subroutine. -* - ISAME( 1 ) = MS.EQ.M - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LCE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - ISAME( 6 ) = LCE( YS, YY, LY ) - ISAME( 7 ) = INCYS.EQ.INCY - IF( NULL )THEN - ISAME( 8 ) = LCE( AS, AA, LAA ) - ELSE - ISAME( 8 ) = LCERES( 'GE', ' ', M, N, AS, AA, - $ LDA ) - END IF - ISAME( 9 ) = LDAS.EQ.LDA -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 140 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 50 I = 1, M - Z( I ) = X( I ) - 50 CONTINUE - ELSE - DO 60 I = 1, M - Z( I ) = X( M - I + 1 ) - 60 CONTINUE - END IF - DO 70 J = 1, N - IF( INCY.GT.0 )THEN - W( 1 ) = Y( J ) - ELSE - W( 1 ) = Y( N - J + 1 ) - END IF - IF( CONJ ) - $ W( 1 ) = CONJG( W( 1 ) ) - CALL CMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1, - $ ONE, A( 1, J ), 1, YT, G, - $ AA( 1 + ( J - 1 )*LDA ), EPS, - $ ERR, FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 130 - 70 CONTINUE - ELSE -* Avoid repeating tests with M.le.0 or N.le.0. - GO TO 110 - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 150 -* - 130 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 140 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA -* - 150 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), '(', F4.1, ',', F4.1, - $ '), X,', I2, ', Y,', I2, ', A,', I3, ') ', - $ ' .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK4. -* - END - SUBROUTINE CCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests CHER and CHPR. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX ZERO, HALF, ONE - PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), - $ ONE = ( 1.0, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - COMPLEX ALPHA, TRANSL - REAL ERR, ERRMAX, RALPHA, RALS - INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA, - $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS - LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - COMPLEX W( 1 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CHER, CHPR, CMAKE, CMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, CMPLX, CONJG, MAX, REAL -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'E' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 7 - ELSE IF( PACKED )THEN - NARGS = 6 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDA to 1 more than minimum value if room. - LDA = N - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF -* - DO 90 IC = 1, 2 - UPLO = ICH( IC: IC ) - UPPER = UPLO.EQ.'U' -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL CMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), - $ 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 70 IA = 1, NALF - RALPHA = REAL( ALF( IA ) ) - ALPHA = CMPLX( RALPHA, RZERO ) - NULL = N.LE.0.OR.RALPHA.EQ.RZERO -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, - $ AA, LDA, N - 1, N - 1, RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - NS = N - RALS = RALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, - $ RALPHA, INCX, LDA - IF( REWI ) - $ REWIND NTRA - CALL CHER( UPLO, N, RALPHA, XX, INCX, AA, LDA ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, - $ RALPHA, INCX - IF( REWI ) - $ REWIND NTRA - CALL CHPR( UPLO, N, RALPHA, XX, INCX, AA ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = RALS.EQ.RALPHA - ISAME( 4 ) = LCE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - IF( NULL )THEN - ISAME( 6 ) = LCE( AS, AA, LAA ) - ELSE - ISAME( 6 ) = LCERES( SNAME( 2: 3 ), UPLO, N, N, AS, - $ AA, LDA ) - END IF - IF( .NOT.PACKED )THEN - ISAME( 7 ) = LDAS.EQ.LDA - END IF -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 30 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 30 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 40 I = 1, N - Z( I ) = X( I ) - 40 CONTINUE - ELSE - DO 50 I = 1, N - Z( I ) = X( N - I + 1 ) - 50 CONTINUE - END IF - JA = 1 - DO 60 J = 1, N - W( 1 ) = CONJG( Z( J ) ) - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - CALL CMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W, - $ 1, ONE, A( JJ, J ), 1, YT, G, - $ AA( JA ), EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - IF( FULL )THEN - IF( UPPER )THEN - JA = JA + LDA - ELSE - JA = JA + LDA + 1 - END IF - ELSE - JA = JA + LJ - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 110 - 60 CONTINUE - ELSE -* Avoid repeating tests if N.le.0. - IF( N.LE.0 ) - $ GO TO 100 - END IF -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 110 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, RALPHA, INCX, LDA - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, RALPHA, INCX - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', AP) .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', A,', I3, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK5. -* - END - SUBROUTINE CCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests CHER2 and CHPR2. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX ZERO, HALF, ONE - PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), - $ ONE = ( 1.0, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX, 2 ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - COMPLEX ALPHA, ALS, TRANSL - REAL ERR, ERRMAX - INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX, - $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N, - $ NARGS, NC, NS - LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - COMPLEX W( 2 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CHER2, CHPR2, CMAKE, CMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, CONJG, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'E' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 9 - ELSE IF( PACKED )THEN - NARGS = 8 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 140 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDA to 1 more than minimum value if room. - LDA = N - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 140 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF -* - DO 130 IC = 1, 2 - UPLO = ICH( IC: IC ) - UPPER = UPLO.EQ.'U' -* - DO 120 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL CMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), - $ 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 110 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL CMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - Y( N/2 ) = ZERO - YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 100 IA = 1, NALF - ALPHA = ALF( IA ) - NULL = N.LE.0.OR.ALPHA.EQ.ZERO -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, - $ NMAX, AA, LDA, N - 1, N - 1, RESET, - $ TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, - $ ALPHA, INCX, INCY, LDA - IF( REWI ) - $ REWIND NTRA - CALL CHER2( UPLO, N, ALPHA, XX, INCX, YY, INCY, - $ AA, LDA ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, - $ ALPHA, INCX, INCY - IF( REWI ) - $ REWIND NTRA - CALL CHPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, - $ AA ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 160 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LCE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - ISAME( 6 ) = LCE( YS, YY, LY ) - ISAME( 7 ) = INCYS.EQ.INCY - IF( NULL )THEN - ISAME( 8 ) = LCE( AS, AA, LAA ) - ELSE - ISAME( 8 ) = LCERES( SNAME( 2: 3 ), UPLO, N, N, - $ AS, AA, LDA ) - END IF - IF( .NOT.PACKED )THEN - ISAME( 9 ) = LDAS.EQ.LDA - END IF -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 160 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 50 I = 1, N - Z( I, 1 ) = X( I ) - 50 CONTINUE - ELSE - DO 60 I = 1, N - Z( I, 1 ) = X( N - I + 1 ) - 60 CONTINUE - END IF - IF( INCY.GT.0 )THEN - DO 70 I = 1, N - Z( I, 2 ) = Y( I ) - 70 CONTINUE - ELSE - DO 80 I = 1, N - Z( I, 2 ) = Y( N - I + 1 ) - 80 CONTINUE - END IF - JA = 1 - DO 90 J = 1, N - W( 1 ) = ALPHA*CONJG( Z( J, 2 ) ) - W( 2 ) = CONJG( ALPHA )*CONJG( Z( J, 1 ) ) - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - CALL CMVCH( 'N', LJ, 2, ONE, Z( JJ, 1 ), - $ NMAX, W, 1, ONE, A( JJ, J ), 1, - $ YT, G, AA( JA ), EPS, ERR, FATAL, - $ NOUT, .TRUE. ) - IF( FULL )THEN - IF( UPPER )THEN - JA = JA + LDA - ELSE - JA = JA + LDA + 1 - END IF - ELSE - JA = JA + LJ - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 150 - 90 CONTINUE - ELSE -* Avoid repeating tests with N.le.0. - IF( N.LE.0 ) - $ GO TO 140 - END IF -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* - 140 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 170 -* - 150 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 160 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, - $ INCY, LDA - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX, INCY - END IF -* - 170 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', - $ F4.1, '), X,', I2, ', Y,', I2, ', AP) ', - $ ' .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', - $ F4.1, '), X,', I2, ', Y,', I2, ', A,', I3, ') ', - $ ' .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK6. -* - END - SUBROUTINE CCHKE( ISNUM, SRNAMT, NOUT ) -* -* Tests the error exits from the Level 2 Blas. -* Requires a special version of the error-handling routine XERBLA. -* ALPHA, RALPHA, BETA, A, X and Y should not need to be defined. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Local Scalars .. - COMPLEX ALPHA, BETA - REAL RALPHA -* .. Local Arrays .. - COMPLEX A( 1, 1 ), X( 1 ), Y( 1 ) -* .. External Subroutines .. - EXTERNAL CGBMV, CGEMV, CGERC, CGERU, CHBMV, CHEMV, CHER, - $ CHER2, CHKXER, CHPMV, CHPR, CHPR2, CTBMV, - $ CTBSV, CTPMV, CTPSV, CTRMV, CTRSV -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. -* OK is set to .FALSE. by the special version of XERBLA or by CHKXER -* if anything is wrong. - OK = .TRUE. -* LERR is set to .TRUE. by the special version of XERBLA each time -* it is called, and is then tested and re-set by CHKXER. - LERR = .FALSE. - GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, - $ 90, 100, 110, 120, 130, 140, 150, 160, - $ 170 )ISNUM - 10 INFOT = 1 - CALL CGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 20 INFOT = 1 - CALL CGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CGBMV( 'N', -1, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGBMV( 'N', 0, -1, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CGBMV( 'N', 0, 0, -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGBMV( 'N', 2, 0, 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGBMV( 'N', 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL CGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 30 INFOT = 1 - CALL CHEMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHEMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CHEMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHEMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CHEMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 40 INFOT = 1 - CALL CHBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CHBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CHBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CHBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 50 INFOT = 1 - CALL CHPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CHPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CHPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 60 INFOT = 1 - CALL CTRMV( '/', 'N', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CTRMV( 'U', '/', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CTRMV( 'U', 'N', '/', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CTRMV( 'U', 'N', 'N', -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMV( 'U', 'N', 'N', 2, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CTRMV( 'U', 'N', 'N', 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 70 INFOT = 1 - CALL CTBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CTBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CTBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CTBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CTBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 80 INFOT = 1 - CALL CTPMV( '/', 'N', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CTPMV( 'U', '/', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CTPMV( 'U', 'N', '/', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CTPMV( 'U', 'N', 'N', -1, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CTPMV( 'U', 'N', 'N', 0, A, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 90 INFOT = 1 - CALL CTRSV( '/', 'N', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CTRSV( 'U', '/', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CTRSV( 'U', 'N', '/', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CTRSV( 'U', 'N', 'N', -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSV( 'U', 'N', 'N', 2, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CTRSV( 'U', 'N', 'N', 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 100 INFOT = 1 - CALL CTBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CTBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CTBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CTBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CTBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 110 INFOT = 1 - CALL CTPSV( '/', 'N', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CTPSV( 'U', '/', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CTPSV( 'U', 'N', '/', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CTPSV( 'U', 'N', 'N', -1, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CTPSV( 'U', 'N', 'N', 0, A, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 120 INFOT = 1 - CALL CGERC( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CGERC( 0, -1, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGERC( 0, 0, ALPHA, X, 0, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CGERC( 0, 0, ALPHA, X, 1, Y, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CGERC( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 130 INFOT = 1 - CALL CGERU( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CGERU( 0, -1, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGERU( 0, 0, ALPHA, X, 0, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CGERU( 0, 0, ALPHA, X, 1, Y, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CGERU( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 140 INFOT = 1 - CALL CHER( '/', 0, RALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHER( 'U', -1, RALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CHER( 'U', 0, RALPHA, X, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHER( 'U', 2, RALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 150 INFOT = 1 - CALL CHPR( '/', 0, RALPHA, X, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHPR( 'U', -1, RALPHA, X, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CHPR( 'U', 0, RALPHA, X, 0, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 160 INFOT = 1 - CALL CHER2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHER2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CHER2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHER2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CHER2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 170 INFOT = 1 - CALL CHPR2( '/', 0, ALPHA, X, 1, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHPR2( 'U', -1, ALPHA, X, 1, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CHPR2( 'U', 0, ALPHA, X, 0, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHPR2( 'U', 0, ALPHA, X, 1, Y, 0, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* - 180 IF( OK )THEN - WRITE( NOUT, FMT = 9999 )SRNAMT - ELSE - WRITE( NOUT, FMT = 9998 )SRNAMT - END IF - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) - 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', - $ '**' ) -* -* End of CCHKE. -* - END - SUBROUTINE CMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, - $ KU, RESET, TRANSL ) -* -* Generates values for an M by N matrix A within the bandwidth -* defined by KL and KU. -* Stores the values in the array AA in the data structure required -* by the routine, with unwanted elements set to rogue value. -* -* TYPE is 'GE', 'GB', 'HE', 'HB', 'HP', 'TR', 'TB' OR 'TP'. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX ZERO, ONE - PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) - COMPLEX ROGUE - PARAMETER ( ROGUE = ( -1.0E10, 1.0E10 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) - REAL RROGUE - PARAMETER ( RROGUE = -1.0E10 ) -* .. Scalar Arguments .. - COMPLEX TRANSL - INTEGER KL, KU, LDA, M, N, NMAX - LOGICAL RESET - CHARACTER*1 DIAG, UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - COMPLEX A( NMAX, * ), AA( * ) -* .. Local Scalars .. - INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, JJ, KK - LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER -* .. External Functions .. - COMPLEX CBEG - EXTERNAL CBEG -* .. Intrinsic Functions .. - INTRINSIC CMPLX, CONJG, MAX, MIN, REAL -* .. Executable Statements .. - GEN = TYPE( 1: 1 ).EQ.'G' - SYM = TYPE( 1: 1 ).EQ.'H' - TRI = TYPE( 1: 1 ).EQ.'T' - UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' - LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' - UNIT = TRI.AND.DIAG.EQ.'U' -* -* Generate data in array A. -* - DO 20 J = 1, N - DO 10 I = 1, M - IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) - $ THEN - IF( ( I.LE.J.AND.J - I.LE.KU ).OR. - $ ( I.GE.J.AND.I - J.LE.KL ) )THEN - A( I, J ) = CBEG( RESET ) + TRANSL - ELSE - A( I, J ) = ZERO - END IF - IF( I.NE.J )THEN - IF( SYM )THEN - A( J, I ) = CONJG( A( I, J ) ) - ELSE IF( TRI )THEN - A( J, I ) = ZERO - END IF - END IF - END IF - 10 CONTINUE - IF( SYM ) - $ A( J, J ) = CMPLX( REAL( A( J, J ) ), RZERO ) - IF( TRI ) - $ A( J, J ) = A( J, J ) + ONE - IF( UNIT ) - $ A( J, J ) = ONE - 20 CONTINUE -* -* Store elements in array AS in data structure required by routine. -* - IF( TYPE.EQ.'GE' )THEN - DO 50 J = 1, N - DO 30 I = 1, M - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 30 CONTINUE - DO 40 I = M + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 40 CONTINUE - 50 CONTINUE - ELSE IF( TYPE.EQ.'GB' )THEN - DO 90 J = 1, N - DO 60 I1 = 1, KU + 1 - J - AA( I1 + ( J - 1 )*LDA ) = ROGUE - 60 CONTINUE - DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J ) - AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J ) - 70 CONTINUE - DO 80 I3 = I2, LDA - AA( I3 + ( J - 1 )*LDA ) = ROGUE - 80 CONTINUE - 90 CONTINUE - ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'TR' )THEN - DO 130 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IF( UNIT )THEN - IEND = J - 1 - ELSE - IEND = J - END IF - ELSE - IF( UNIT )THEN - IBEG = J + 1 - ELSE - IBEG = J - END IF - IEND = N - END IF - DO 100 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 100 CONTINUE - DO 110 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 110 CONTINUE - DO 120 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 120 CONTINUE - IF( SYM )THEN - JJ = J + ( J - 1 )*LDA - AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE ) - END IF - 130 CONTINUE - ELSE IF( TYPE.EQ.'HB'.OR.TYPE.EQ.'TB' )THEN - DO 170 J = 1, N - IF( UPPER )THEN - KK = KL + 1 - IBEG = MAX( 1, KL + 2 - J ) - IF( UNIT )THEN - IEND = KL - ELSE - IEND = KL + 1 - END IF - ELSE - KK = 1 - IF( UNIT )THEN - IBEG = 2 - ELSE - IBEG = 1 - END IF - IEND = MIN( KL + 1, 1 + M - J ) - END IF - DO 140 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 140 CONTINUE - DO 150 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J ) - 150 CONTINUE - DO 160 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 160 CONTINUE - IF( SYM )THEN - JJ = KK + ( J - 1 )*LDA - AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE ) - END IF - 170 CONTINUE - ELSE IF( TYPE.EQ.'HP'.OR.TYPE.EQ.'TP' )THEN - IOFF = 0 - DO 190 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 180 I = IBEG, IEND - IOFF = IOFF + 1 - AA( IOFF ) = A( I, J ) - IF( I.EQ.J )THEN - IF( UNIT ) - $ AA( IOFF ) = ROGUE - IF( SYM ) - $ AA( IOFF ) = CMPLX( REAL( AA( IOFF ) ), RROGUE ) - END IF - 180 CONTINUE - 190 CONTINUE - END IF - RETURN -* -* End of CMAKE. -* - END - SUBROUTINE CMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, - $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV ) -* -* Checks the results of the computational tests. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0, 0.0 ) ) - REAL RZERO, RONE - PARAMETER ( RZERO = 0.0, RONE = 1.0 ) -* .. Scalar Arguments .. - COMPLEX ALPHA, BETA - REAL EPS, ERR - INTEGER INCX, INCY, M, N, NMAX, NOUT - LOGICAL FATAL, MV - CHARACTER*1 TRANS -* .. Array Arguments .. - COMPLEX A( NMAX, * ), X( * ), Y( * ), YT( * ), YY( * ) - REAL G( * ) -* .. Local Scalars .. - COMPLEX C - REAL ERRI - INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL - LOGICAL CTRAN, TRAN -* .. Intrinsic Functions .. - INTRINSIC ABS, AIMAG, CONJG, MAX, REAL, SQRT -* .. Statement Functions .. - REAL ABS1 -* .. Statement Function definitions .. - ABS1( C ) = ABS( REAL( C ) ) + ABS( AIMAG( C ) ) -* .. Executable Statements .. - TRAN = TRANS.EQ.'T' - CTRAN = TRANS.EQ.'C' - IF( TRAN.OR.CTRAN )THEN - ML = N - NL = M - ELSE - ML = M - NL = N - END IF - IF( INCX.LT.0 )THEN - KX = NL - INCXL = -1 - ELSE - KX = 1 - INCXL = 1 - END IF - IF( INCY.LT.0 )THEN - KY = ML - INCYL = -1 - ELSE - KY = 1 - INCYL = 1 - END IF -* -* Compute expected result in YT using data in A, X and Y. -* Compute gauges in G. -* - IY = KY - DO 40 I = 1, ML - YT( IY ) = ZERO - G( IY ) = RZERO - JX = KX - IF( TRAN )THEN - DO 10 J = 1, NL - YT( IY ) = YT( IY ) + A( J, I )*X( JX ) - G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) ) - JX = JX + INCXL - 10 CONTINUE - ELSE IF( CTRAN )THEN - DO 20 J = 1, NL - YT( IY ) = YT( IY ) + CONJG( A( J, I ) )*X( JX ) - G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) ) - JX = JX + INCXL - 20 CONTINUE - ELSE - DO 30 J = 1, NL - YT( IY ) = YT( IY ) + A( I, J )*X( JX ) - G( IY ) = G( IY ) + ABS1( A( I, J ) )*ABS1( X( JX ) ) - JX = JX + INCXL - 30 CONTINUE - END IF - YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY ) - G( IY ) = ABS1( ALPHA )*G( IY ) + ABS1( BETA )*ABS1( Y( IY ) ) - IY = IY + INCYL - 40 CONTINUE -* -* Compute the error ratio for this result. -* - ERR = ZERO - DO 50 I = 1, ML - ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS - IF( G( I ).NE.RZERO ) - $ ERRI = ERRI/G( I ) - ERR = MAX( ERR, ERRI ) - IF( ERR*SQRT( EPS ).GE.RONE ) - $ GO TO 60 - 50 CONTINUE -* If the loop completes, all results are at least half accurate. - GO TO 80 -* -* Report fatal error. -* - 60 FATAL = .TRUE. - WRITE( NOUT, FMT = 9999 ) - DO 70 I = 1, ML - IF( MV )THEN - WRITE( NOUT, FMT = 9998 )I, YT( I ), - $ YY( 1 + ( I - 1 )*ABS( INCY ) ) - ELSE - WRITE( NOUT, FMT = 9998 )I, - $ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT( I ) - END IF - 70 CONTINUE -* - 80 CONTINUE - RETURN -* - 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', - $ 'F ACCURATE *******', /' EXPECTED RE', - $ 'SULT COMPUTED RESULT' ) - 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) ) -* -* End of CMVCH. -* - END - LOGICAL FUNCTION LCE( RI, RJ, LR ) -* -* Tests if two arrays are identical. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER LR -* .. Array Arguments .. - COMPLEX RI( * ), RJ( * ) -* .. Local Scalars .. - INTEGER I -* .. Executable Statements .. - DO 10 I = 1, LR - IF( RI( I ).NE.RJ( I ) ) - $ GO TO 20 - 10 CONTINUE - LCE = .TRUE. - GO TO 30 - 20 CONTINUE - LCE = .FALSE. - 30 RETURN -* -* End of LCE. -* - END - LOGICAL FUNCTION LCERES( TYPE, UPLO, M, N, AA, AS, LDA ) -* -* Tests if selected elements in two arrays are equal. -* -* TYPE is 'GE', 'HE' or 'HP'. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER LDA, M, N - CHARACTER*1 UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - COMPLEX AA( LDA, * ), AS( LDA, * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J - LOGICAL UPPER -* .. Executable Statements .. - UPPER = UPLO.EQ.'U' - IF( TYPE.EQ.'GE' )THEN - DO 20 J = 1, N - DO 10 I = M + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 10 CONTINUE - 20 CONTINUE - ELSE IF( TYPE.EQ.'HE' )THEN - DO 50 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 30 I = 1, IBEG - 1 - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 30 CONTINUE - DO 40 I = IEND + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 40 CONTINUE - 50 CONTINUE - END IF -* - LCERES = .TRUE. - GO TO 80 - 70 CONTINUE - LCERES = .FALSE. - 80 RETURN -* -* End of LCERES. -* - END - COMPLEX FUNCTION CBEG( RESET ) -* -* Generates complex numbers as pairs of random numbers uniformly -* distributed between -0.5 and 0.5. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - LOGICAL RESET -* .. Local Scalars .. - INTEGER I, IC, J, MI, MJ -* .. Save statement .. - SAVE I, IC, J, MI, MJ -* .. Intrinsic Functions .. - INTRINSIC CMPLX -* .. Executable Statements .. - IF( RESET )THEN -* Initialize local variables. - MI = 891 - MJ = 457 - I = 7 - J = 7 - IC = 0 - RESET = .FALSE. - END IF -* -* The sequence of values of I or J is bounded between 1 and 999. -* If initial I or J = 1,2,3,6,7 or 9, the period will be 50. -* If initial I or J = 4 or 8, the period will be 25. -* If initial I or J = 5, the period will be 10. -* IC is used to break up the period by skipping 1 value of I or J -* in 6. -* - IC = IC + 1 - 10 I = I*MI - J = J*MJ - I = I - 1000*( I/1000 ) - J = J - 1000*( J/1000 ) - IF( IC.GE.5 )THEN - IC = 0 - GO TO 10 - END IF - CBEG = CMPLX( ( I - 500 )/1001.0, ( J - 500 )/1001.0 ) - RETURN -* -* End of CBEG. -* - END - REAL FUNCTION SDIFF( X, Y ) -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* -* .. Scalar Arguments .. - REAL X, Y -* .. Executable Statements .. - SDIFF = X - Y - RETURN -* -* End of SDIFF. -* - END - SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* -* Tests whether XERBLA has detected an error when it should. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Executable Statements .. - IF( .NOT.LERR )THEN - WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT - OK = .FALSE. - END IF - LERR = .FALSE. - RETURN -* - 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', - $ 'ETECTED BY ', A6, ' *****' ) -* -* End of CHKXER. -* - END - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* This is a special version of XERBLA to be used only as part of -* the test program for testing error exits from the Level 2 BLAS -* routines. -* -* XERBLA is an error handler for the Level 2 BLAS routines. -* -* It is called by the Level 2 BLAS routines if an input parameter is -* invalid. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER INFO - CHARACTER*6 SRNAME -* .. Scalars in Common .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUT, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Executable Statements .. - LERR = .TRUE. - IF( INFO.NE.INFOT )THEN - IF( INFOT.NE.0 )THEN - WRITE( NOUT, FMT = 9999 )INFO, INFOT - ELSE - WRITE( NOUT, FMT = 9997 )INFO - END IF - OK = .FALSE. - END IF - IF( SRNAME.NE.SRNAMT )THEN - WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT - OK = .FALSE. - END IF - RETURN -* - 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', - $ ' OF ', I2, ' *******' ) - 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', - $ 'AD OF ', A6, ' *******' ) - 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, - $ ' *******' ) -* -* End of XERBLA -* - END - diff --git a/eigen/blas/testing/cblat3.dat b/eigen/blas/testing/cblat3.dat deleted file mode 100644 index 59881ea..0000000 --- a/eigen/blas/testing/cblat3.dat +++ /dev/null @@ -1,23 +0,0 @@ -'cblat3.summ' NAME OF SUMMARY OUTPUT FILE -6 UNIT NUMBER OF SUMMARY FILE -'cblat3.snap' NAME OF SNAPSHOT OUTPUT FILE --1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -F LOGICAL FLAG, T TO STOP ON FAILURES. -F LOGICAL FLAG, T TO TEST ERROR EXITS. -16.0 THRESHOLD VALUE OF TEST RATIO -6 NUMBER OF VALUES OF N -0 1 2 3 5 9 VALUES OF N -3 NUMBER OF VALUES OF ALPHA -(0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA -3 NUMBER OF VALUES OF BETA -(0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA -CGEMM T PUT F FOR NO TEST. SAME COLUMNS. -CHEMM T PUT F FOR NO TEST. SAME COLUMNS. -CSYMM T PUT F FOR NO TEST. SAME COLUMNS. -CTRMM T PUT F FOR NO TEST. SAME COLUMNS. -CTRSM T PUT F FOR NO TEST. SAME COLUMNS. -CHERK T PUT F FOR NO TEST. SAME COLUMNS. -CSYRK T PUT F FOR NO TEST. SAME COLUMNS. -CHER2K T PUT F FOR NO TEST. SAME COLUMNS. -CSYR2K T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/eigen/blas/testing/cblat3.f b/eigen/blas/testing/cblat3.f deleted file mode 100644 index 09f2cb9..0000000 --- a/eigen/blas/testing/cblat3.f +++ /dev/null @@ -1,3492 +0,0 @@ -*> \brief \b CBLAT3 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM CBLAT3 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the COMPLEX Level 3 Blas. -*> -*> The program must be driven by a short data file. The first 14 records -*> of the file are read using list-directed input, the last 9 records -*> are read using the format ( A6, L2 ). An annotated example of a data -*> file can be obtained by deleting the first 3 characters from the -*> following 23 lines: -*> 'cblat3.out' NAME OF SUMMARY OUTPUT FILE -*> 6 UNIT NUMBER OF SUMMARY FILE -*> 'CBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE -*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -*> F LOGICAL FLAG, T TO STOP ON FAILURES. -*> T LOGICAL FLAG, T TO TEST ERROR EXITS. -*> 16.0 THRESHOLD VALUE OF TEST RATIO -*> 6 NUMBER OF VALUES OF N -*> 0 1 2 3 5 9 VALUES OF N -*> 3 NUMBER OF VALUES OF ALPHA -*> (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA -*> 3 NUMBER OF VALUES OF BETA -*> (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA -*> CGEMM T PUT F FOR NO TEST. SAME COLUMNS. -*> CHEMM T PUT F FOR NO TEST. SAME COLUMNS. -*> CSYMM T PUT F FOR NO TEST. SAME COLUMNS. -*> CTRMM T PUT F FOR NO TEST. SAME COLUMNS. -*> CTRSM T PUT F FOR NO TEST. SAME COLUMNS. -*> CHERK T PUT F FOR NO TEST. SAME COLUMNS. -*> CSYRK T PUT F FOR NO TEST. SAME COLUMNS. -*> CHER2K T PUT F FOR NO TEST. SAME COLUMNS. -*> CSYR2K T PUT F FOR NO TEST. SAME COLUMNS. -*> -*> Further Details -*> =============== -*> -*> See: -*> -*> Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. -*> A Set of Level 3 Basic Linear Algebra Subprograms. -*> -*> Technical Memorandum No.88 (Revision 1), Mathematics and -*> Computer Science Division, Argonne National Laboratory, 9700 -*> South Cass Avenue, Argonne, Illinois 60439, US. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> -*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers -*> can be run multiple times without deleting generated -*> output files (susan) -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date April 2012 -* -*> \ingroup complex_blas_testing -* -* ===================================================================== - PROGRAM CBLAT3 -* -* -- Reference BLAS test routine (version 3.4.1) -- -* -- 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 NIN - PARAMETER ( NIN = 5 ) - INTEGER NSUBS - PARAMETER ( NSUBS = 9 ) - COMPLEX ZERO, ONE - PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) - INTEGER NMAX - PARAMETER ( NMAX = 65 ) - INTEGER NIDMAX, NALMAX, NBEMAX - PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 ) -* .. Local Scalars .. - REAL EPS, ERR, THRESH - INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA - LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, - $ TSTERR - CHARACTER*1 TRANSA, TRANSB - CHARACTER*6 SNAMET - CHARACTER*32 SNAPS, SUMMRY -* .. Local Arrays .. - COMPLEX AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), - $ ALF( NALMAX ), AS( NMAX*NMAX ), - $ BB( NMAX*NMAX ), BET( NBEMAX ), - $ BS( NMAX*NMAX ), C( NMAX, NMAX ), - $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), - $ W( 2*NMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDMAX ) - LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) -* .. External Functions .. - REAL SDIFF - LOGICAL LCE - EXTERNAL SDIFF, LCE -* .. External Subroutines .. - EXTERNAL CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CCHKE, CMMCH -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Data statements .. - DATA SNAMES/'CGEMM ', 'CHEMM ', 'CSYMM ', 'CTRMM ', - $ 'CTRSM ', 'CHERK ', 'CSYRK ', 'CHER2K', - $ 'CSYR2K'/ -* .. Executable Statements .. -* -* Read name and unit number for summary output file and open file. -* - READ( NIN, FMT = * )SUMMRY - READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY ) - NOUTC = NOUT -* -* Read name and unit number for snapshot output file and open file. -* - READ( NIN, FMT = * )SNAPS - READ( NIN, FMT = * )NTRA - TRACE = NTRA.GE.0 - IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS ) - END IF -* Read the flag that directs rewinding of the snapshot file. - READ( NIN, FMT = * )REWI - REWI = REWI.AND.TRACE -* Read the flag that directs stopping on any failure. - READ( NIN, FMT = * )SFATAL -* Read the flag that indicates whether error exits are to be tested. - READ( NIN, FMT = * )TSTERR -* Read the threshold value of the test ratio - READ( NIN, FMT = * )THRESH -* -* Read and check the parameter values for the tests. -* -* Values of N - READ( NIN, FMT = * )NIDIM - IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN - WRITE( NOUT, FMT = 9997 )'N', NIDMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) - DO 10 I = 1, NIDIM - IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN - WRITE( NOUT, FMT = 9996 )NMAX - GO TO 220 - END IF - 10 CONTINUE -* Values of ALPHA - READ( NIN, FMT = * )NALF - IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN - WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) -* Values of BETA - READ( NIN, FMT = * )NBET - IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN - WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) -* -* Report values of parameters. -* - WRITE( NOUT, FMT = 9995 ) - WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM ) - WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF ) - WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET ) - IF( .NOT.TSTERR )THEN - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9984 ) - END IF - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9999 )THRESH - WRITE( NOUT, FMT = * ) -* -* Read names of subroutines and flags which indicate -* whether they are to be tested. -* - DO 20 I = 1, NSUBS - LTEST( I ) = .FALSE. - 20 CONTINUE - 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT - DO 40 I = 1, NSUBS - IF( SNAMET.EQ.SNAMES( I ) ) - $ GO TO 50 - 40 CONTINUE - WRITE( NOUT, FMT = 9990 )SNAMET - STOP - 50 LTEST( I ) = LTESTT - GO TO 30 -* - 60 CONTINUE - CLOSE ( NIN ) -* -* Compute EPS (the machine precision). -* - EPS = EPSILON(RZERO) - WRITE( NOUT, FMT = 9998 )EPS -* -* Check the reliability of CMMCH using exact data. -* - N = MIN( 32, NMAX ) - DO 100 J = 1, N - DO 90 I = 1, N - AB( I, J ) = MAX( I - J + 1, 0 ) - 90 CONTINUE - AB( J, NMAX + 1 ) = J - AB( 1, NMAX + J ) = J - C( J, 1 ) = ZERO - 100 CONTINUE - DO 110 J = 1, N - CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 - 110 CONTINUE -* CC holds the exact result. On exit from CMMCH CT holds -* the result computed by CMMCH. - TRANSA = 'N' - TRANSB = 'N' - CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LCE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - TRANSB = 'C' - CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LCE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - DO 120 J = 1, N - AB( J, NMAX + 1 ) = N - J + 1 - AB( 1, NMAX + J ) = N - J + 1 - 120 CONTINUE - DO 130 J = 1, N - CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 - - $ ( ( J + 1 )*J*( J - 1 ) )/3 - 130 CONTINUE - TRANSA = 'C' - TRANSB = 'N' - CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LCE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - TRANSB = 'C' - CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LCE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF -* -* Test each subroutine in turn. -* - DO 200 ISNUM = 1, NSUBS - WRITE( NOUT, FMT = * ) - IF( .NOT.LTEST( ISNUM ) )THEN -* Subprogram is not to be tested. - WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM ) - ELSE - SRNAMT = SNAMES( ISNUM ) -* Test error exits. - IF( TSTERR )THEN - CALL CCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) - WRITE( NOUT, FMT = * ) - END IF -* Test computations. - INFOT = 0 - OK = .TRUE. - FATAL = .FALSE. - GO TO ( 140, 150, 150, 160, 160, 170, 170, - $ 180, 180 )ISNUM -* Test CGEMM, 01. - 140 CALL CCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test CHEMM, 02, CSYMM, 03. - 150 CALL CCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test CTRMM, 04, CTRSM, 05. - 160 CALL CCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB, - $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C ) - GO TO 190 -* Test CHERK, 06, CSYRK, 07. - 170 CALL CCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test CHER2K, 08, CSYR2K, 09. - 180 CALL CCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) - GO TO 190 -* - 190 IF( FATAL.AND.SFATAL ) - $ GO TO 210 - END IF - 200 CONTINUE - WRITE( NOUT, FMT = 9986 ) - GO TO 230 -* - 210 CONTINUE - WRITE( NOUT, FMT = 9985 ) - GO TO 230 -* - 220 CONTINUE - WRITE( NOUT, FMT = 9991 ) -* - 230 CONTINUE - IF( TRACE ) - $ CLOSE ( NTRA ) - CLOSE ( NOUT ) - STOP -* - 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', - $ 'S THAN', F8.2 ) - 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 ) - 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', - $ 'THAN ', I2 ) - 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) - 9995 FORMAT( ' TESTS OF THE COMPLEX LEVEL 3 BLAS', //' THE F', - $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) - 9994 FORMAT( ' FOR N ', 9I6 ) - 9993 FORMAT( ' FOR ALPHA ', - $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) - 9992 FORMAT( ' FOR BETA ', - $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) - 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', - $ /' ******* TESTS ABANDONED *******' ) - 9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', - $ 'ESTS ABANDONED *******' ) - 9989 FORMAT( ' ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', - $ 'ATED WRONGLY.', /' CMMCH WAS CALLED WITH TRANSA = ', A1, - $ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ', - $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', - $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', - $ '*******' ) - 9988 FORMAT( A6, L2 ) - 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' ) - 9986 FORMAT( /' END OF TESTS' ) - 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) - 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) -* -* End of CBLAT3. -* - END - SUBROUTINE CCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests CGEMM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - COMPLEX ALPHA, ALS, BETA, BLS - REAL ERR, ERRMAX - INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA, - $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, - $ MA, MB, MS, N, NA, NARGS, NB, NC, NS - LOGICAL NULL, RESET, SAME, TRANA, TRANB - CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB - CHARACTER*3 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CGEMM, CMAKE, CMMCH -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'NTC'/ -* .. Executable Statements .. -* - NARGS = 13 - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 110 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = M - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 100 - LCC = LDC*N - NULL = N.LE.0.OR.M.LE.0 -* - DO 90 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 80 ICA = 1, 3 - TRANSA = ICH( ICA: ICA ) - TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' -* - IF( TRANA )THEN - MA = K - NA = M - ELSE - MA = M - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* -* Generate the matrix A. -* - CALL CMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) -* - DO 70 ICB = 1, 3 - TRANSB = ICH( ICB: ICB ) - TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' -* - IF( TRANB )THEN - MB = N - NB = K - ELSE - MB = K - NB = N - END IF -* Set LDB to 1 more than minimum value if room. - LDB = MB - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 70 - LBB = LDB*NB -* -* Generate the matrix B. -* - CALL CMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB, - $ LDB, RESET, ZERO ) -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL CMAKE( 'GE', ' ', ' ', M, N, C, NMAX, - $ CC, LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - TRANAS = TRANSA - TRANBS = TRANSB - MS = M - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - BLS = BETA - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB, - $ BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL CGEMM( TRANSA, TRANSB, M, N, K, ALPHA, - $ AA, LDA, BB, LDB, BETA, CC, LDC ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = TRANSA.EQ.TRANAS - ISAME( 2 ) = TRANSB.EQ.TRANBS - ISAME( 3 ) = MS.EQ.M - ISAME( 4 ) = NS.EQ.N - ISAME( 5 ) = KS.EQ.K - ISAME( 6 ) = ALS.EQ.ALPHA - ISAME( 7 ) = LCE( AS, AA, LAA ) - ISAME( 8 ) = LDAS.EQ.LDA - ISAME( 9 ) = LCE( BS, BB, LBB ) - ISAME( 10 ) = LDBS.EQ.LDB - ISAME( 11 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 12 ) = LCE( CS, CC, LCC ) - ELSE - ISAME( 12 ) = LCERES( 'GE', ' ', M, N, CS, - $ CC, LDC ) - END IF - ISAME( 13 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report -* and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL CMMCH( TRANSA, TRANSB, M, N, K, - $ ALPHA, A, NMAX, B, NMAX, BETA, - $ C, NMAX, CT, G, CC, LDC, EPS, - $ ERR, FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 120 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K, - $ ALPHA, LDA, LDB, BETA, LDC -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',', - $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, - $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK1. -* - END - SUBROUTINE CCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests CHEMM and CSYMM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - COMPLEX ALPHA, ALS, BETA, BLS - REAL ERR, ERRMAX - INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC, - $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA, - $ NARGS, NC, NS - LOGICAL CONJ, LEFT, NULL, RESET, SAME - CHARACTER*1 SIDE, SIDES, UPLO, UPLOS - CHARACTER*2 ICHS, ICHU -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CHEMM, CMAKE, CMMCH, CSYMM -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHS/'LR'/, ICHU/'UL'/ -* .. Executable Statements .. - CONJ = SNAME( 2: 3 ).EQ.'HE' -* - NARGS = 12 - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 100 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 90 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = M - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 90 - LCC = LDC*N - NULL = N.LE.0.OR.M.LE.0 -* Set LDB to 1 more than minimum value if room. - LDB = M - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 90 - LBB = LDB*N -* -* Generate the matrix B. -* - CALL CMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET, - $ ZERO ) -* - DO 80 ICS = 1, 2 - SIDE = ICHS( ICS: ICS ) - LEFT = SIDE.EQ.'L' -* - IF( LEFT )THEN - NA = M - ELSE - NA = N - END IF -* Set LDA to 1 more than minimum value if room. - LDA = NA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* - DO 70 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* -* Generate the hermitian or symmetric matrix A. -* - CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', NA, NA, A, NMAX, - $ AA, LDA, RESET, ZERO ) -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL CMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC, - $ LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - SIDES = SIDE - UPLOS = UPLO - MS = M - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - BLS = BETA - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE, - $ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC - IF( REWI ) - $ REWIND NTRA - IF( CONJ )THEN - CALL CHEMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, - $ BB, LDB, BETA, CC, LDC ) - ELSE - CALL CSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, - $ BB, LDB, BETA, CC, LDC ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 110 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = SIDES.EQ.SIDE - ISAME( 2 ) = UPLOS.EQ.UPLO - ISAME( 3 ) = MS.EQ.M - ISAME( 4 ) = NS.EQ.N - ISAME( 5 ) = ALS.EQ.ALPHA - ISAME( 6 ) = LCE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - ISAME( 8 ) = LCE( BS, BB, LBB ) - ISAME( 9 ) = LDBS.EQ.LDB - ISAME( 10 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 11 ) = LCE( CS, CC, LCC ) - ELSE - ISAME( 11 ) = LCERES( 'GE', ' ', M, N, CS, - $ CC, LDC ) - END IF - ISAME( 12 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 110 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - IF( LEFT )THEN - CALL CMMCH( 'N', 'N', M, N, M, ALPHA, A, - $ NMAX, B, NMAX, BETA, C, NMAX, - $ CT, G, CC, LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL CMMCH( 'N', 'N', M, N, N, ALPHA, B, - $ NMAX, A, NMAX, BETA, C, NMAX, - $ CT, G, CC, LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 120 -* - 110 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA, - $ LDB, BETA, LDC -* - 120 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, - $ ',', F4.1, '), C,', I3, ') .' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK2. -* - END - SUBROUTINE CCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS, - $ B, BB, BS, CT, G, C ) -* -* Tests CTRMM and CTRSM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX ZERO, ONE - PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER NALF, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CT( NMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - COMPLEX ALPHA, ALS - REAL ERR, ERRMAX - INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB, - $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC, - $ NS - LOGICAL LEFT, NULL, RESET, SAME - CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO, - $ UPLOS - CHARACTER*2 ICHD, ICHS, ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CMAKE, CMMCH, CTRMM, CTRSM -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/ -* .. Executable Statements .. -* - NARGS = 11 - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* Set up zero matrix for CMMCH. - DO 20 J = 1, NMAX - DO 10 I = 1, NMAX - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE -* - DO 140 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 130 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDB to 1 more than minimum value if room. - LDB = M - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 130 - LBB = LDB*N - NULL = M.LE.0.OR.N.LE.0 -* - DO 120 ICS = 1, 2 - SIDE = ICHS( ICS: ICS ) - LEFT = SIDE.EQ.'L' - IF( LEFT )THEN - NA = M - ELSE - NA = N - END IF -* Set LDA to 1 more than minimum value if room. - LDA = NA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 130 - LAA = LDA*NA -* - DO 110 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* - DO 100 ICT = 1, 3 - TRANSA = ICHT( ICT: ICT ) -* - DO 90 ICD = 1, 2 - DIAG = ICHD( ICD: ICD ) -* - DO 80 IA = 1, NALF - ALPHA = ALF( IA ) -* -* Generate the matrix A. -* - CALL CMAKE( 'TR', UPLO, DIAG, NA, NA, A, - $ NMAX, AA, LDA, RESET, ZERO ) -* -* Generate the matrix B. -* - CALL CMAKE( 'GE', ' ', ' ', M, N, B, NMAX, - $ BB, LDB, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - SIDES = SIDE - UPLOS = UPLO - TRANAS = TRANSA - DIAGS = DIAG - MS = M - NS = N - ALS = ALPHA - DO 30 I = 1, LAA - AS( I ) = AA( I ) - 30 CONTINUE - LDAS = LDA - DO 40 I = 1, LBB - BS( I ) = BB( I ) - 40 CONTINUE - LDBS = LDB -* -* Call the subroutine. -* - IF( SNAME( 4: 5 ).EQ.'MM' )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, - $ LDA, LDB - IF( REWI ) - $ REWIND NTRA - CALL CTRMM( SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, AA, LDA, BB, LDB ) - ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, - $ LDA, LDB - IF( REWI ) - $ REWIND NTRA - CALL CTRSM( SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, AA, LDA, BB, LDB ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 150 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = SIDES.EQ.SIDE - ISAME( 2 ) = UPLOS.EQ.UPLO - ISAME( 3 ) = TRANAS.EQ.TRANSA - ISAME( 4 ) = DIAGS.EQ.DIAG - ISAME( 5 ) = MS.EQ.M - ISAME( 6 ) = NS.EQ.N - ISAME( 7 ) = ALS.EQ.ALPHA - ISAME( 8 ) = LCE( AS, AA, LAA ) - ISAME( 9 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 10 ) = LCE( BS, BB, LBB ) - ELSE - ISAME( 10 ) = LCERES( 'GE', ' ', M, N, BS, - $ BB, LDB ) - END IF - ISAME( 11 ) = LDBS.EQ.LDB -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 50 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 50 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 150 - END IF -* - IF( .NOT.NULL )THEN - IF( SNAME( 4: 5 ).EQ.'MM' )THEN -* -* Check the result. -* - IF( LEFT )THEN - CALL CMMCH( TRANSA, 'N', M, N, M, - $ ALPHA, A, NMAX, B, NMAX, - $ ZERO, C, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL CMMCH( 'N', TRANSA, M, N, N, - $ ALPHA, B, NMAX, A, NMAX, - $ ZERO, C, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN -* -* Compute approximation to original -* matrix. -* - DO 70 J = 1, N - DO 60 I = 1, M - C( I, J ) = BB( I + ( J - 1 )* - $ LDB ) - BB( I + ( J - 1 )*LDB ) = ALPHA* - $ B( I, J ) - 60 CONTINUE - 70 CONTINUE -* - IF( LEFT )THEN - CALL CMMCH( TRANSA, 'N', M, N, M, - $ ONE, A, NMAX, C, NMAX, - $ ZERO, B, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .FALSE. ) - ELSE - CALL CMMCH( 'N', TRANSA, M, N, N, - $ ONE, C, NMAX, A, NMAX, - $ ZERO, B, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .FALSE. ) - END IF - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 150 - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* - 140 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 160 -* - 150 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, LDA, LDB -* - 160 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ), - $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ') ', - $ ' .' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK3. -* - END - SUBROUTINE CCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests CHERK and CSYRK. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0, 0.0 ) ) - REAL RONE, RZERO - PARAMETER ( RONE = 1.0, RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - COMPLEX ALPHA, ALS, BETA, BETS - REAL ERR, ERRMAX, RALPHA, RALS, RBETA, RBETS - INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS, - $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA, - $ NARGS, NC, NS - LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER - CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS - CHARACTER*2 ICHT, ICHU -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CHERK, CMAKE, CMMCH, CSYRK -* .. Intrinsic Functions .. - INTRINSIC CMPLX, MAX, REAL -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHT/'NC'/, ICHU/'UL'/ -* .. Executable Statements .. - CONJ = SNAME( 2: 3 ).EQ.'HE' -* - NARGS = 10 - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = N - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 100 - LCC = LDC*N -* - DO 90 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 80 ICT = 1, 2 - TRANS = ICHT( ICT: ICT ) - TRAN = TRANS.EQ.'C' - IF( TRAN.AND..NOT.CONJ ) - $ TRANS = 'T' - IF( TRAN )THEN - MA = K - NA = N - ELSE - MA = N - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* -* Generate the matrix A. -* - CALL CMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) -* - DO 70 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) - UPPER = UPLO.EQ.'U' -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) - IF( CONJ )THEN - RALPHA = REAL( ALPHA ) - ALPHA = CMPLX( RALPHA, RZERO ) - END IF -* - DO 50 IB = 1, NBET - BETA = BET( IB ) - IF( CONJ )THEN - RBETA = REAL( BETA ) - BETA = CMPLX( RBETA, RZERO ) - END IF - NULL = N.LE.0 - IF( CONJ ) - $ NULL = NULL.OR.( ( K.LE.0.OR.RALPHA.EQ. - $ RZERO ).AND.RBETA.EQ.RONE ) -* -* Generate the matrix C. -* - CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, C, - $ NMAX, CC, LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - NS = N - KS = K - IF( CONJ )THEN - RALS = RALPHA - ELSE - ALS = ALPHA - END IF - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - IF( CONJ )THEN - RBETS = RBETA - ELSE - BETS = BETA - END IF - DO 20 I = 1, LCC - CS( I ) = CC( I ) - 20 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( CONJ )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, - $ TRANS, N, K, RALPHA, LDA, RBETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL CHERK( UPLO, TRANS, N, K, RALPHA, AA, - $ LDA, RBETA, CC, LDC ) - ELSE - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, - $ TRANS, N, K, ALPHA, LDA, BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL CSYRK( UPLO, TRANS, N, K, ALPHA, AA, - $ LDA, BETA, CC, LDC ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLOS.EQ.UPLO - ISAME( 2 ) = TRANSS.EQ.TRANS - ISAME( 3 ) = NS.EQ.N - ISAME( 4 ) = KS.EQ.K - IF( CONJ )THEN - ISAME( 5 ) = RALS.EQ.RALPHA - ELSE - ISAME( 5 ) = ALS.EQ.ALPHA - END IF - ISAME( 6 ) = LCE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - IF( CONJ )THEN - ISAME( 8 ) = RBETS.EQ.RBETA - ELSE - ISAME( 8 ) = BETS.EQ.BETA - END IF - IF( NULL )THEN - ISAME( 9 ) = LCE( CS, CC, LCC ) - ELSE - ISAME( 9 ) = LCERES( SNAME( 2: 3 ), UPLO, N, - $ N, CS, CC, LDC ) - END IF - ISAME( 10 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 30 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 30 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( CONJ )THEN - TRANST = 'C' - ELSE - TRANST = 'T' - END IF - JC = 1 - DO 40 J = 1, N - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - IF( TRAN )THEN - CALL CMMCH( TRANST, 'N', LJ, 1, K, - $ ALPHA, A( 1, JJ ), NMAX, - $ A( 1, J ), NMAX, BETA, - $ C( JJ, J ), NMAX, CT, G, - $ CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL CMMCH( 'N', TRANST, LJ, 1, K, - $ ALPHA, A( JJ, 1 ), NMAX, - $ A( J, 1 ), NMAX, BETA, - $ C( JJ, J ), NMAX, CT, G, - $ CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - IF( UPPER )THEN - JC = JC + LDC - ELSE - JC = JC + LDC + 1 - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 110 - 40 CONTINUE - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 110 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9995 )J -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( CONJ )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, RALPHA, - $ LDA, RBETA, LDC - ELSE - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, - $ LDA, BETA, LDC - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') ', - $ ' .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ '(', F4.1, ',', F4.1, ') , A,', I3, ',(', F4.1, ',', F4.1, - $ '), C,', I3, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK4. -* - END - SUBROUTINE CCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) -* -* Tests CHER2K and CSYR2K. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX ZERO, ONE - PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) - REAL RONE, RZERO - PARAMETER ( RONE = 1.0, RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), - $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), - $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ), - $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), - $ W( 2*NMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - COMPLEX ALPHA, ALS, BETA, BETS - REAL ERR, ERRMAX, RBETA, RBETS - INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, - $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, - $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS - LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER - CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS - CHARACTER*2 ICHT, ICHU -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CHER2K, CMAKE, CMMCH, CSYR2K -* .. Intrinsic Functions .. - INTRINSIC CMPLX, CONJG, MAX, REAL -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHT/'NC'/, ICHU/'UL'/ -* .. Executable Statements .. - CONJ = SNAME( 2: 3 ).EQ.'HE' -* - NARGS = 12 - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 130 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = N - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 130 - LCC = LDC*N -* - DO 120 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 110 ICT = 1, 2 - TRANS = ICHT( ICT: ICT ) - TRAN = TRANS.EQ.'C' - IF( TRAN.AND..NOT.CONJ ) - $ TRANS = 'T' - IF( TRAN )THEN - MA = K - NA = N - ELSE - MA = N - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 110 - LAA = LDA*NA -* -* Generate the matrix A. -* - IF( TRAN )THEN - CALL CMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA, - $ LDA, RESET, ZERO ) - ELSE - CALL CMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA, - $ RESET, ZERO ) - END IF -* -* Generate the matrix B. -* - LDB = LDA - LBB = LAA - IF( TRAN )THEN - CALL CMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ), - $ 2*NMAX, BB, LDB, RESET, ZERO ) - ELSE - CALL CMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ), - $ NMAX, BB, LDB, RESET, ZERO ) - END IF -* - DO 100 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) - UPPER = UPLO.EQ.'U' -* - DO 90 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 80 IB = 1, NBET - BETA = BET( IB ) - IF( CONJ )THEN - RBETA = REAL( BETA ) - BETA = CMPLX( RBETA, RZERO ) - END IF - NULL = N.LE.0 - IF( CONJ ) - $ NULL = NULL.OR.( ( K.LE.0.OR.ALPHA.EQ. - $ ZERO ).AND.RBETA.EQ.RONE ) -* -* Generate the matrix C. -* - CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, C, - $ NMAX, CC, LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - IF( CONJ )THEN - RBETS = RBETA - ELSE - BETS = BETA - END IF - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( CONJ )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, - $ TRANS, N, K, ALPHA, LDA, LDB, RBETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL CHER2K( UPLO, TRANS, N, K, ALPHA, AA, - $ LDA, BB, LDB, RBETA, CC, LDC ) - ELSE - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, - $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL CSYR2K( UPLO, TRANS, N, K, ALPHA, AA, - $ LDA, BB, LDB, BETA, CC, LDC ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 150 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLOS.EQ.UPLO - ISAME( 2 ) = TRANSS.EQ.TRANS - ISAME( 3 ) = NS.EQ.N - ISAME( 4 ) = KS.EQ.K - ISAME( 5 ) = ALS.EQ.ALPHA - ISAME( 6 ) = LCE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - ISAME( 8 ) = LCE( BS, BB, LBB ) - ISAME( 9 ) = LDBS.EQ.LDB - IF( CONJ )THEN - ISAME( 10 ) = RBETS.EQ.RBETA - ELSE - ISAME( 10 ) = BETS.EQ.BETA - END IF - IF( NULL )THEN - ISAME( 11 ) = LCE( CS, CC, LCC ) - ELSE - ISAME( 11 ) = LCERES( 'HE', UPLO, N, N, CS, - $ CC, LDC ) - END IF - ISAME( 12 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 150 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( CONJ )THEN - TRANST = 'C' - ELSE - TRANST = 'T' - END IF - JJAB = 1 - JC = 1 - DO 70 J = 1, N - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - IF( TRAN )THEN - DO 50 I = 1, K - W( I ) = ALPHA*AB( ( J - 1 )*2* - $ NMAX + K + I ) - IF( CONJ )THEN - W( K + I ) = CONJG( ALPHA )* - $ AB( ( J - 1 )*2* - $ NMAX + I ) - ELSE - W( K + I ) = ALPHA* - $ AB( ( J - 1 )*2* - $ NMAX + I ) - END IF - 50 CONTINUE - CALL CMMCH( TRANST, 'N', LJ, 1, 2*K, - $ ONE, AB( JJAB ), 2*NMAX, W, - $ 2*NMAX, BETA, C( JJ, J ), - $ NMAX, CT, G, CC( JC ), LDC, - $ EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - ELSE - DO 60 I = 1, K - IF( CONJ )THEN - W( I ) = ALPHA*CONJG( AB( ( K + - $ I - 1 )*NMAX + J ) ) - W( K + I ) = CONJG( ALPHA* - $ AB( ( I - 1 )*NMAX + - $ J ) ) - ELSE - W( I ) = ALPHA*AB( ( K + I - 1 )* - $ NMAX + J ) - W( K + I ) = ALPHA* - $ AB( ( I - 1 )*NMAX + - $ J ) - END IF - 60 CONTINUE - CALL CMMCH( 'N', 'N', LJ, 1, 2*K, ONE, - $ AB( JJ ), NMAX, W, 2*NMAX, - $ BETA, C( JJ, J ), NMAX, CT, - $ G, CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - IF( UPPER )THEN - JC = JC + LDC - ELSE - JC = JC + LDC + 1 - IF( TRAN ) - $ JJAB = JJAB + 2*NMAX - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 140 - 70 CONTINUE - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 160 -* - 140 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9995 )J -* - 150 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( CONJ )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, - $ LDA, LDB, RBETA, LDC - ELSE - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, - $ LDA, LDB, BETA, LDC - END IF -* - 160 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',', F4.1, - $ ', C,', I3, ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, - $ ',', F4.1, '), C,', I3, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK5. -* - END - SUBROUTINE CCHKE( ISNUM, SRNAMT, NOUT ) -* -* Tests the error exits from the Level 3 Blas. -* Requires a special version of the error-handling routine XERBLA. -* A, B and C should not need to be defined. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* 3-19-92: Initialize ALPHA, BETA, RALPHA, and RBETA (eca) -* 3-19-92: Fix argument 12 in calls to CSYMM and CHEMM -* with INFOT = 9 (eca) -* -* .. Scalar Arguments .. - INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Parameters .. - REAL ONE, TWO - PARAMETER ( ONE = 1.0E0, TWO = 2.0E0 ) -* .. Local Scalars .. - COMPLEX ALPHA, BETA - REAL RALPHA, RBETA -* .. Local Arrays .. - COMPLEX A( 2, 1 ), B( 2, 1 ), C( 2, 1 ) -* .. External Subroutines .. - EXTERNAL CGEMM, CHEMM, CHER2K, CHERK, CHKXER, CSYMM, - $ CSYR2K, CSYRK, CTRMM, CTRSM -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. -* OK is set to .FALSE. by the special version of XERBLA or by CHKXER -* if anything is wrong. - OK = .TRUE. -* LERR is set to .TRUE. by the special version of XERBLA each time -* it is called, and is then tested and re-set by CHKXER. - LERR = .FALSE. -* -* Initialize ALPHA, BETA, RALPHA, and RBETA. -* - ALPHA = CMPLX( ONE, -ONE ) - BETA = CMPLX( TWO, -TWO ) - RALPHA = ONE - RBETA = TWO -* - GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, - $ 90 )ISNUM - 10 INFOT = 1 - CALL CGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 1 - CALL CGEMM( '/', 'C', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 1 - CALL CGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CGEMM( 'C', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGEMM( 'N', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGEMM( 'C', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGEMM( 'C', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGEMM( 'C', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGEMM( 'T', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CGEMM( 'N', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CGEMM( 'C', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CGEMM( 'C', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CGEMM( 'C', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CGEMM( 'T', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGEMM( 'N', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGEMM( 'C', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGEMM( 'C', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGEMM( 'C', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGEMM( 'T', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGEMM( 'N', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGEMM( 'C', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGEMM( 'C', 'C', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGEMM( 'C', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGEMM( 'T', 'C', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CGEMM( 'C', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CGEMM( 'N', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CGEMM( 'C', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CGEMM( 'T', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CGEMM( 'C', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL CGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL CGEMM( 'N', 'C', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL CGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL CGEMM( 'C', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL CGEMM( 'C', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL CGEMM( 'C', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL CGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL CGEMM( 'T', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL CGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 20 INFOT = 1 - CALL CHEMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHEMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHEMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHEMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHEMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHEMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHEMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHEMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHEMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHEMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHEMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHEMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHEMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHEMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 30 INFOT = 1 - CALL CSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 40 INFOT = 1 - CALL CTRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CTRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CTRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CTRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'L', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'R', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'L', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'R', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'L', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'R', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'L', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'R', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'R', 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'R', 'L', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'R', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'R', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 50 INFOT = 1 - CALL CTRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CTRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CTRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CTRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'L', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'R', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'L', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'R', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'L', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'R', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'L', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'R', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'R', 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'R', 'L', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'R', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'R', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 60 INFOT = 1 - CALL CHERK( '/', 'N', 0, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHERK( 'U', 'T', 0, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHERK( 'U', 'N', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHERK( 'U', 'C', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHERK( 'L', 'N', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHERK( 'L', 'C', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHERK( 'U', 'N', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHERK( 'U', 'C', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHERK( 'L', 'N', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHERK( 'L', 'C', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHERK( 'U', 'N', 2, 0, RALPHA, A, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHERK( 'U', 'C', 0, 2, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHERK( 'L', 'N', 2, 0, RALPHA, A, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHERK( 'L', 'C', 0, 2, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CHERK( 'U', 'N', 2, 0, RALPHA, A, 2, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CHERK( 'U', 'C', 2, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CHERK( 'L', 'N', 2, 0, RALPHA, A, 2, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CHERK( 'L', 'C', 2, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 70 INFOT = 1 - CALL CSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CSYRK( 'U', 'C', 0, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 80 INFOT = 1 - CALL CHER2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHER2K( 'U', 'T', 0, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHER2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHER2K( 'U', 'C', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHER2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHER2K( 'L', 'C', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHER2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHER2K( 'U', 'C', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHER2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHER2K( 'L', 'C', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHER2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHER2K( 'U', 'C', 0, 2, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHER2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHER2K( 'L', 'C', 0, 2, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CHER2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CHER2K( 'U', 'C', 0, 2, ALPHA, A, 2, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CHER2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CHER2K( 'L', 'C', 0, 2, ALPHA, A, 2, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CHER2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CHER2K( 'U', 'C', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CHER2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CHER2K( 'L', 'C', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 90 INFOT = 1 - CALL CSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CSYR2K( 'U', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* - 100 IF( OK )THEN - WRITE( NOUT, FMT = 9999 )SRNAMT - ELSE - WRITE( NOUT, FMT = 9998 )SRNAMT - END IF - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) - 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', - $ '**' ) -* -* End of CCHKE. -* - END - SUBROUTINE CMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, - $ TRANSL ) -* -* Generates values for an M by N matrix A. -* Stores the values in the array AA in the data structure required -* by the routine, with unwanted elements set to rogue value. -* -* TYPE is 'GE', 'HE', 'SY' or 'TR'. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX ZERO, ONE - PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) - COMPLEX ROGUE - PARAMETER ( ROGUE = ( -1.0E10, 1.0E10 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) - REAL RROGUE - PARAMETER ( RROGUE = -1.0E10 ) -* .. Scalar Arguments .. - COMPLEX TRANSL - INTEGER LDA, M, N, NMAX - LOGICAL RESET - CHARACTER*1 DIAG, UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - COMPLEX A( NMAX, * ), AA( * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J, JJ - LOGICAL GEN, HER, LOWER, SYM, TRI, UNIT, UPPER -* .. External Functions .. - COMPLEX CBEG - EXTERNAL CBEG -* .. Intrinsic Functions .. - INTRINSIC CMPLX, CONJG, REAL -* .. Executable Statements .. - GEN = TYPE.EQ.'GE' - HER = TYPE.EQ.'HE' - SYM = TYPE.EQ.'SY' - TRI = TYPE.EQ.'TR' - UPPER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'U' - LOWER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'L' - UNIT = TRI.AND.DIAG.EQ.'U' -* -* Generate data in array A. -* - DO 20 J = 1, N - DO 10 I = 1, M - IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) - $ THEN - A( I, J ) = CBEG( RESET ) + TRANSL - IF( I.NE.J )THEN -* Set some elements to zero - IF( N.GT.3.AND.J.EQ.N/2 ) - $ A( I, J ) = ZERO - IF( HER )THEN - A( J, I ) = CONJG( A( I, J ) ) - ELSE IF( SYM )THEN - A( J, I ) = A( I, J ) - ELSE IF( TRI )THEN - A( J, I ) = ZERO - END IF - END IF - END IF - 10 CONTINUE - IF( HER ) - $ A( J, J ) = CMPLX( REAL( A( J, J ) ), RZERO ) - IF( TRI ) - $ A( J, J ) = A( J, J ) + ONE - IF( UNIT ) - $ A( J, J ) = ONE - 20 CONTINUE -* -* Store elements in array AS in data structure required by routine. -* - IF( TYPE.EQ.'GE' )THEN - DO 50 J = 1, N - DO 30 I = 1, M - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 30 CONTINUE - DO 40 I = M + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 40 CONTINUE - 50 CONTINUE - ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN - DO 90 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IF( UNIT )THEN - IEND = J - 1 - ELSE - IEND = J - END IF - ELSE - IF( UNIT )THEN - IBEG = J + 1 - ELSE - IBEG = J - END IF - IEND = N - END IF - DO 60 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 60 CONTINUE - DO 70 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 70 CONTINUE - DO 80 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 80 CONTINUE - IF( HER )THEN - JJ = J + ( J - 1 )*LDA - AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE ) - END IF - 90 CONTINUE - END IF - RETURN -* -* End of CMAKE. -* - END - SUBROUTINE CMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, - $ NOUT, MV ) -* -* Checks the results of the computational tests. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0, 0.0 ) ) - REAL RZERO, RONE - PARAMETER ( RZERO = 0.0, RONE = 1.0 ) -* .. Scalar Arguments .. - COMPLEX ALPHA, BETA - REAL EPS, ERR - INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT - LOGICAL FATAL, MV - CHARACTER*1 TRANSA, TRANSB -* .. Array Arguments .. - COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ CC( LDCC, * ), CT( * ) - REAL G( * ) -* .. Local Scalars .. - COMPLEX CL - REAL ERRI - INTEGER I, J, K - LOGICAL CTRANA, CTRANB, TRANA, TRANB -* .. Intrinsic Functions .. - INTRINSIC ABS, AIMAG, CONJG, MAX, REAL, SQRT -* .. Statement Functions .. - REAL ABS1 -* .. Statement Function definitions .. - ABS1( CL ) = ABS( REAL( CL ) ) + ABS( AIMAG( CL ) ) -* .. Executable Statements .. - TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' - TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' - CTRANA = TRANSA.EQ.'C' - CTRANB = TRANSB.EQ.'C' -* -* Compute expected result, one column at a time, in CT using data -* in A, B and C. -* Compute gauges in G. -* - DO 220 J = 1, N -* - DO 10 I = 1, M - CT( I ) = ZERO - G( I ) = RZERO - 10 CONTINUE - IF( .NOT.TRANA.AND..NOT.TRANB )THEN - DO 30 K = 1, KK - DO 20 I = 1, M - CT( I ) = CT( I ) + A( I, K )*B( K, J ) - G( I ) = G( I ) + ABS1( A( I, K ) )*ABS1( B( K, J ) ) - 20 CONTINUE - 30 CONTINUE - ELSE IF( TRANA.AND..NOT.TRANB )THEN - IF( CTRANA )THEN - DO 50 K = 1, KK - DO 40 I = 1, M - CT( I ) = CT( I ) + CONJG( A( K, I ) )*B( K, J ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( K, J ) ) - 40 CONTINUE - 50 CONTINUE - ELSE - DO 70 K = 1, KK - DO 60 I = 1, M - CT( I ) = CT( I ) + A( K, I )*B( K, J ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( K, J ) ) - 60 CONTINUE - 70 CONTINUE - END IF - ELSE IF( .NOT.TRANA.AND.TRANB )THEN - IF( CTRANB )THEN - DO 90 K = 1, KK - DO 80 I = 1, M - CT( I ) = CT( I ) + A( I, K )*CONJG( B( J, K ) ) - G( I ) = G( I ) + ABS1( A( I, K ) )* - $ ABS1( B( J, K ) ) - 80 CONTINUE - 90 CONTINUE - ELSE - DO 110 K = 1, KK - DO 100 I = 1, M - CT( I ) = CT( I ) + A( I, K )*B( J, K ) - G( I ) = G( I ) + ABS1( A( I, K ) )* - $ ABS1( B( J, K ) ) - 100 CONTINUE - 110 CONTINUE - END IF - ELSE IF( TRANA.AND.TRANB )THEN - IF( CTRANA )THEN - IF( CTRANB )THEN - DO 130 K = 1, KK - DO 120 I = 1, M - CT( I ) = CT( I ) + CONJG( A( K, I ) )* - $ CONJG( B( J, K ) ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( J, K ) ) - 120 CONTINUE - 130 CONTINUE - ELSE - DO 150 K = 1, KK - DO 140 I = 1, M - CT( I ) = CT( I ) + CONJG( A( K, I ) )*B( J, K ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( J, K ) ) - 140 CONTINUE - 150 CONTINUE - END IF - ELSE - IF( CTRANB )THEN - DO 170 K = 1, KK - DO 160 I = 1, M - CT( I ) = CT( I ) + A( K, I )*CONJG( B( J, K ) ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( J, K ) ) - 160 CONTINUE - 170 CONTINUE - ELSE - DO 190 K = 1, KK - DO 180 I = 1, M - CT( I ) = CT( I ) + A( K, I )*B( J, K ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( J, K ) ) - 180 CONTINUE - 190 CONTINUE - END IF - END IF - END IF - DO 200 I = 1, M - CT( I ) = ALPHA*CT( I ) + BETA*C( I, J ) - G( I ) = ABS1( ALPHA )*G( I ) + - $ ABS1( BETA )*ABS1( C( I, J ) ) - 200 CONTINUE -* -* Compute the error ratio for this result. -* - ERR = ZERO - DO 210 I = 1, M - ERRI = ABS1( CT( I ) - CC( I, J ) )/EPS - IF( G( I ).NE.RZERO ) - $ ERRI = ERRI/G( I ) - ERR = MAX( ERR, ERRI ) - IF( ERR*SQRT( EPS ).GE.RONE ) - $ GO TO 230 - 210 CONTINUE -* - 220 CONTINUE -* -* If the loop completes, all results are at least half accurate. - GO TO 250 -* -* Report fatal error. -* - 230 FATAL = .TRUE. - WRITE( NOUT, FMT = 9999 ) - DO 240 I = 1, M - IF( MV )THEN - WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J ) - ELSE - WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I ) - END IF - 240 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9997 )J -* - 250 CONTINUE - RETURN -* - 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', - $ 'F ACCURATE *******', /' EXPECTED RE', - $ 'SULT COMPUTED RESULT' ) - 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) ) - 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) -* -* End of CMMCH. -* - END - LOGICAL FUNCTION LCE( RI, RJ, LR ) -* -* Tests if two arrays are identical. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER LR -* .. Array Arguments .. - COMPLEX RI( * ), RJ( * ) -* .. Local Scalars .. - INTEGER I -* .. Executable Statements .. - DO 10 I = 1, LR - IF( RI( I ).NE.RJ( I ) ) - $ GO TO 20 - 10 CONTINUE - LCE = .TRUE. - GO TO 30 - 20 CONTINUE - LCE = .FALSE. - 30 RETURN -* -* End of LCE. -* - END - LOGICAL FUNCTION LCERES( TYPE, UPLO, M, N, AA, AS, LDA ) -* -* Tests if selected elements in two arrays are equal. -* -* TYPE is 'GE' or 'HE' or 'SY'. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER LDA, M, N - CHARACTER*1 UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - COMPLEX AA( LDA, * ), AS( LDA, * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J - LOGICAL UPPER -* .. Executable Statements .. - UPPER = UPLO.EQ.'U' - IF( TYPE.EQ.'GE' )THEN - DO 20 J = 1, N - DO 10 I = M + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 10 CONTINUE - 20 CONTINUE - ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'SY' )THEN - DO 50 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 30 I = 1, IBEG - 1 - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 30 CONTINUE - DO 40 I = IEND + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 40 CONTINUE - 50 CONTINUE - END IF -* - LCERES = .TRUE. - GO TO 80 - 70 CONTINUE - LCERES = .FALSE. - 80 RETURN -* -* End of LCERES. -* - END - COMPLEX FUNCTION CBEG( RESET ) -* -* Generates complex numbers as pairs of random numbers uniformly -* distributed between -0.5 and 0.5. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - LOGICAL RESET -* .. Local Scalars .. - INTEGER I, IC, J, MI, MJ -* .. Save statement .. - SAVE I, IC, J, MI, MJ -* .. Intrinsic Functions .. - INTRINSIC CMPLX -* .. Executable Statements .. - IF( RESET )THEN -* Initialize local variables. - MI = 891 - MJ = 457 - I = 7 - J = 7 - IC = 0 - RESET = .FALSE. - END IF -* -* The sequence of values of I or J is bounded between 1 and 999. -* If initial I or J = 1,2,3,6,7 or 9, the period will be 50. -* If initial I or J = 4 or 8, the period will be 25. -* If initial I or J = 5, the period will be 10. -* IC is used to break up the period by skipping 1 value of I or J -* in 6. -* - IC = IC + 1 - 10 I = I*MI - J = J*MJ - I = I - 1000*( I/1000 ) - J = J - 1000*( J/1000 ) - IF( IC.GE.5 )THEN - IC = 0 - GO TO 10 - END IF - CBEG = CMPLX( ( I - 500 )/1001.0, ( J - 500 )/1001.0 ) - RETURN -* -* End of CBEG. -* - END - REAL FUNCTION SDIFF( X, Y ) -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - REAL X, Y -* .. Executable Statements .. - SDIFF = X - Y - RETURN -* -* End of SDIFF. -* - END - SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* -* Tests whether XERBLA has detected an error when it should. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Executable Statements .. - IF( .NOT.LERR )THEN - WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT - OK = .FALSE. - END IF - LERR = .FALSE. - RETURN -* - 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', - $ 'ETECTED BY ', A6, ' *****' ) -* -* End of CHKXER. -* - END - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* This is a special version of XERBLA to be used only as part of -* the test program for testing error exits from the Level 3 BLAS -* routines. -* -* XERBLA is an error handler for the Level 3 BLAS routines. -* -* It is called by the Level 3 BLAS routines if an input parameter is -* invalid. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER INFO - CHARACTER*6 SRNAME -* .. Scalars in Common .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUT, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Executable Statements .. - LERR = .TRUE. - IF( INFO.NE.INFOT )THEN - IF( INFOT.NE.0 )THEN - WRITE( NOUT, FMT = 9999 )INFO, INFOT - ELSE - WRITE( NOUT, FMT = 9997 )INFO - END IF - OK = .FALSE. - END IF - IF( SRNAME.NE.SRNAMT )THEN - WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT - OK = .FALSE. - END IF - RETURN -* - 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', - $ ' OF ', I2, ' *******' ) - 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', - $ 'AD OF ', A6, ' *******' ) - 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, - $ ' *******' ) -* -* End of XERBLA -* - END - diff --git a/eigen/blas/testing/dblat1.f b/eigen/blas/testing/dblat1.f deleted file mode 100644 index 30691f9..0000000 --- a/eigen/blas/testing/dblat1.f +++ /dev/null @@ -1,1065 +0,0 @@ -*> \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 -* -* -- Reference BLAS test routine (version 3.4.1) -- -* -- 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,99999) - DO 20 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.EQ.3 .OR. ICASE.EQ.11) THEN - CALL CHECK0(SFAC) - ELSE IF (ICASE.EQ.7 .OR. ICASE.EQ.8 .OR. ICASE.EQ.9 .OR. - + ICASE.EQ.10) THEN - CALL CHECK1(SFAC) - ELSE IF (ICASE.EQ.1 .OR. ICASE.EQ.2 .OR. ICASE.EQ.5 .OR. - + ICASE.EQ.6 .OR. ICASE.EQ.12 .OR. ICASE.EQ.13) THEN - CALL CHECK2(SFAC) - ELSE IF (ICASE.EQ.4) THEN - CALL CHECK3(SFAC) - END IF -* -- Print - IF (PASS) WRITE (NOUT,99998) - 20 CONTINUE - STOP -* -99999 FORMAT (' Real BLAS Test Program Results',/1X) -99998 FORMAT (' ----- PASS -----') - END - SUBROUTINE HEADER -* .. 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,99999) ICASE, L(ICASE) - RETURN -* -99999 FORMAT (/' Test of subprogram number',I3,12X,A6) - END - SUBROUTINE CHECK0(SFAC) -* .. 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, 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, - A .7D0, .2D0, .6D0, 4.2D0, - B 0.D0,0.D0,0.D0,0.D0, - C 4.D0, -1.D0, 2.D0, 4.D0, - D 6.D-10, 2.D-2, 1.D5, 10.D0, - E 4.D10, 2.D-2, 1.D-5, 10.D0, - F 2.D-10, 4.D-2, 1.D5, 10.D0, - G 2.D10, 4.D-2, 1.D-5, 10.D0, - H 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, - A 0.D0,0.D0, 4.5D0, 4.2D0, 1.D0, .5D0, 0.D0,0.D0,0.D0, - B 0.D0,0.D0,0.D0,0.D0, -2.D0, 0.D0,0.D0,0.D0,0.D0, - C 0.D0,0.D0,0.D0, 4.D0, -1.D0, 0.D0,0.D0,0.D0,0.D0, - D 0.D0, 15.D-3, 0.D0, 10.D0, -1.D0, 0.D0, -1.D-4, - E 0.D0, 1.D0, - F 0.D0,0.D0, 6144.D-5, 10.D0, -1.D0, 4096.D0, -1.D6, - G 0.D0, 1.D0, - H 0.D0,0.D0,15.D0,10.D0,-1.D0, 5.D-5, 0.D0,1.D0,0.D0, - I 0.D0,0.D0, 15.D0, 10.D0, -1. D0, 5.D5, -4096.D0, - J 1.D0, 4096.D-6, - K 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 20 K = 1, 8 -* .. Set N=K for identification in output if any .. - N = K - IF (ICASE.EQ.3) THEN -* .. DROTG .. - IF (K.GT.8) GO TO 40 - 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.EQ.11) THEN -* .. DROTMG .. - DO I=1,4 - DTEMP(I)= DAB(I,K) - DTEMP(I+4) = 0.0 - END DO - 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 - END IF - 20 CONTINUE - 40 RETURN - END - SUBROUTINE CHECK1(SFAC) -* .. 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, LEN, NP1 -* .. Local Arrays .. - DOUBLE PRECISION DTRUE1(5), DTRUE3(5), DTRUE5(8,5,2), DV(8,5,2), - + SA(10), STEMP(1), STRUE(8), SX(8) - INTEGER ITRUE2(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 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/ -* .. Executable Statements .. - DO 80 INCX = 1, 2 - DO 60 NP1 = 1, 5 - N = NP1 - 1 - LEN = 2*MAX(N,1) -* .. Set vector arguments .. - DO 20 I = 1, LEN - SX(I) = DV(I,NP1,INCX) - 20 CONTINUE -* - IF (ICASE.EQ.7) THEN -* .. DNRM2 .. - STEMP(1) = DTRUE1(NP1) - CALL STEST1(DNRM2(N,SX,INCX),STEMP(1),STEMP,SFAC) - ELSE IF (ICASE.EQ.8) THEN -* .. DASUM .. - STEMP(1) = DTRUE3(NP1) - CALL STEST1(DASUM(N,SX,INCX),STEMP(1),STEMP,SFAC) - ELSE IF (ICASE.EQ.9) THEN -* .. DSCAL .. - CALL DSCAL(N,SA((INCX-1)*5+NP1),SX,INCX) - DO 40 I = 1, LEN - STRUE(I) = DTRUE5(I,NP1,INCX) - 40 CONTINUE - CALL STEST(LEN,SX,STRUE,STRUE,SFAC) - ELSE IF (ICASE.EQ.10) THEN -* .. IDAMAX .. - CALL ITEST1(IDAMAX(N,SX,INCX),ITRUE2(NP1)) - ELSE - WRITE (NOUT,*) ' Shouldn''t be here in CHECK1' - STOP - END IF - 60 CONTINUE - 80 CONTINUE - RETURN - END - SUBROUTINE CHECK2(SFAC) -* .. 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, - $ 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) - 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 -* .. 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)),(DT19X(1,1,5), - A DT19XB(1,1,1)),(DT19X(1,1,9),DT19XC(1,1,1)), - B (DT19X(1,1,13),DT19XD(1,1,1)) - EQUIVALENCE (DT19Y(1,1,1),DT19YA(1,1,1)),(DT19Y(1,1,5), - A DT19YB(1,1,1)),(DT19Y(1,1,9),DT19YC(1,1,1)), - B (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, - A -1.D0, 2.D0, -3.D0, -4.D0, 5.D0, - B 0.D0, 0.D0, 2.D0, -3.D0, 0.D0, - C 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, - A .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - B .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - C .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - D .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - E -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - F -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - G 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - H .6D0, .1D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - I -.8D0, 3.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - J -.9D0, 2.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - K 3.5D0, -.4D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - L .6D0, .1D0, -.5D0, .8D0, 0.D0,0.D0,0.D0, - M -.8D0, 3.8D0, -2.2D0, -1.2D0, 0.D0,0.D0,0.D0, - N -.9D0, 2.8D0, -1.4D0, -1.3D0, 0.D0,0.D0,0.D0, - O 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, - A .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - B .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - C .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - D .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - E -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - F -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - G 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - H .6D0, .1D0, -.5D0, 0.D0,0.D0,0.D0,0.D0, - I 0.D0, .1D0, -3.0D0, 0.D0,0.D0,0.D0,0.D0, - J -.3D0, .1D0, -2.0D0, 0.D0,0.D0,0.D0,0.D0, - K 3.3D0, .1D0, -2.0D0, 0.D0,0.D0,0.D0,0.D0, - L .6D0, .1D0, -.5D0, .8D0, .9D0, -.3D0, -.4D0, - M -2.0D0, .1D0, 1.4D0, .8D0, .6D0, -.3D0, -2.8D0, - N -1.8D0, .1D0, 1.3D0, .8D0, 0.D0, -.3D0, -1.9D0, - O 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, - A .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - B .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - C .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - D .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - E -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - F -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - G 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - H .6D0, .1D0, -.5D0, 0.D0,0.D0,0.D0,0.D0, - I 4.8D0, .1D0, -3.0D0, 0.D0,0.D0,0.D0,0.D0, - J 3.3D0, .1D0, -2.0D0, 0.D0,0.D0,0.D0,0.D0, - K 2.1D0, .1D0, -2.0D0, 0.D0,0.D0,0.D0,0.D0, - L .6D0, .1D0, -.5D0, .8D0, .9D0, -.3D0, -.4D0, - M -1.6D0, .1D0, -2.2D0, .8D0, 5.4D0, -.3D0, -2.8D0, - N -1.5D0, .1D0, -1.4D0, .8D0, 3.6D0, -.3D0, -1.9D0, - O 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, - A .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - B .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - C .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - D .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - E -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - F -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - G 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - H .6D0, .1D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - I -.8D0, -1.0D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - J -.9D0, -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - K 3.5D0, .8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - L .6D0, .1D0, -.5D0, .8D0, 0.D0,0.D0,0.D0, - M -.8D0, -1.0D0, 1.4D0, -1.6D0, 0.D0,0.D0,0.D0, - N -.9D0, -.8D0, 1.3D0, -1.6D0, 0.D0,0.D0,0.D0, - O 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, - A .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - B .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - C .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - D .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - E .7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - F 1.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - G -2.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - H .5D0, -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - I .7D0, -4.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - J 1.7D0, -.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - K -2.6D0, 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - L .5D0, -.9D0, .3D0, .7D0, 0.D0,0.D0,0.D0, - M .7D0, -4.8D0, 3.0D0, 1.1D0, 0.D0,0.D0,0.D0, - N 1.7D0, -.7D0, -.7D0, 2.3D0, 0.D0,0.D0,0.D0, - O -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, - A .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - B .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - C .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - D .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - E .7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - F 1.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - G -2.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - H .5D0, -.9D0, .3D0, 0.D0,0.D0,0.D0,0.D0, - I 4.0D0, -.9D0, -.3D0, 0.D0,0.D0,0.D0,0.D0, - J -.5D0, -.9D0, 1.5D0, 0.D0,0.D0,0.D0,0.D0, - K -1.5D0, -.9D0, -1.8D0, 0.D0,0.D0,0.D0,0.D0, - L .5D0, -.9D0, .3D0, .7D0, -.6D0, .2D0, .8D0, - M 3.7D0, -.9D0, -1.2D0, .7D0, -1.5D0, .2D0, 2.2D0, - N -.3D0, -.9D0, 2.1D0, .7D0, -1.6D0, .2D0, 2.0D0, - O -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, - A .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - B .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - C .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - D .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - E .7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - F 1.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - G -2.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - H .5D0, -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - I 4.0D0, -6.3D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - J -.5D0, .3D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - K -1.5D0, 3.0D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - L .5D0, -.9D0, .3D0, .7D0, 0.D0,0.D0,0.D0, - M 3.7D0, -7.2D0, 3.0D0, 1.7D0, 0.D0,0.D0,0.D0, - N -.3D0, .9D0, -.7D0, 1.9D0, 0.D0,0.D0,0.D0, - O -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, - A .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - B .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - C .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - D .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - E .7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - F 1.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - G -2.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - H .5D0, -.9D0, .3D0, 0.D0,0.D0,0.D0,0.D0, - I .7D0, -.9D0, 1.2D0, 0.D0,0.D0,0.D0,0.D0, - J 1.7D0, -.9D0, .5D0, 0.D0,0.D0,0.D0,0.D0, - K -2.6D0, -.9D0, -1.3D0, 0.D0,0.D0,0.D0,0.D0, - L .5D0, -.9D0, .3D0, .7D0, -.6D0, .2D0, .8D0, - M .7D0, -.9D0, 1.2D0, .7D0, -1.5D0, .2D0, 1.6D0, - N 1.7D0, -.9D0, .5D0, .7D0, -1.6D0, .2D0, 2.4D0, - O -2.6D0, -.9D0, -1.3D0, .7D0, 2.9D0, .2D0, -4.0D0 / -* -* .. Executable Statements .. -* - DO 120 KI = 1, 4 - INCX = INCXS(KI) - INCY = INCYS(KI) - MX = ABS(INCX) - MY = ABS(INCY) -* - DO 100 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 - SX(I) = DX1(I) - SY(I) = DY1(I) - 20 CONTINUE -* - IF (ICASE.EQ.1) THEN -* .. DDOT .. - CALL STEST1(DDOT(N,SX,INCX,SY,INCY),DT7(KN,KI),SSIZE1(KN) - + ,SFAC) - ELSE IF (ICASE.EQ.2) THEN -* .. DAXPY .. - CALL DAXPY(N,SA,SX,INCX,SY,INCY) - DO 40 J = 1, LENY - STY(J) = DT8(J,KN,KI) - 40 CONTINUE - CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC) - ELSE IF (ICASE.EQ.5) THEN -* .. DCOPY .. - DO 60 I = 1, 7 - STY(I) = DT10Y(I,KN,KI) - 60 CONTINUE - CALL DCOPY(N,SX,INCX,SY,INCY) - CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0D0) - ELSE IF (ICASE.EQ.6) THEN -* .. DSWAP .. - CALL DSWAP(N,SX,INCX,SY,INCY) - DO 80 I = 1, 7 - STX(I) = DT10X(I,KN,KI) - STY(I) = DT10Y(I,KN,KI) - 80 CONTINUE - CALL STEST(LENX,SX,STX,SSIZE2(1,1),1.0D0) - CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0D0) - ELSE IF (ICASE.EQ.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) - END DO -* - DO I=1,5 - DTEMP(I) = DPAR(I,KPAR) - END DO -* - DO I=1,LENX - SSIZE(I)=STX(I) - END DO -* SEE REMARK ABOVE ABOUT DT11X(1,2,7) -* AND DT11X(5,3,8). - IF ((KPAR .EQ. 2) .AND. (KNI .EQ. 7)) - $ SSIZE(1) = 2.4D0 - IF ((KPAR .EQ. 3) .AND. (KNI .EQ. 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) - END DO - ELSE IF (ICASE.EQ.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 - END IF - 100 CONTINUE - 120 CONTINUE - RETURN - END - SUBROUTINE CHECK3(SFAC) -* .. 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 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) -* - IF (ICASE.EQ.4) THEN -* .. DROT .. - DO 20 I = 1, 7 - SX(I) = DX1(I) - SY(I) = DY1(I) - STX(I) = DT9X(I,KN,KI) - STY(I) = DT9Y(I,KN,KI) - 20 CONTINUE - 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 - END IF - 40 CONTINUE - 60 CONTINUE -* - MWPC(1) = 1 - DO 80 I = 2, 11 - MWPC(I) = 0 - 80 CONTINUE - MWPS(1) = 0 - DO 100 I = 2, 6 - MWPS(I) = 1 - 100 CONTINUE - DO 120 I = 7, 11 - MWPS(I) = -1 - 120 CONTINUE - 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 140 I = 1, 11 - MWPN(I) = 5 - 140 CONTINUE - MWPN(5) = 3 - MWPN(10) = 3 - DO 160 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 - 160 CONTINUE - 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 200 I = 1, 11 - INCX = MWPINX(I) - INCY = MWPINY(I) - DO 180 K = 1, 5 - COPYX(K) = MWPX(K) - COPYY(K) = MWPY(K) - MWPSTX(K) = MWPTX(I,K) - MWPSTY(K) = MWPTY(I,K) - 180 CONTINUE - 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) - 200 CONTINUE - RETURN - 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, 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 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, I, SCOMP(I), - + STRUE(I), SD, SSIZE(I) - 40 CONTINUE - RETURN -* -99999 FORMAT (' FAIL') -99998 FORMAT (/' CASE N INCX INCY I ', - + ' COMP(I) TRUE(I) DIFFERENCE', - + ' SIZE(I)',/1X) -99997 FORMAT (1X,I4,I3,2I5,I3,2D36.8,2D12.4) - END - SUBROUTINE TESTDSDOT(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 - 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) .LE. ABS(SSIZE) * 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, SCOMP, - + STRUE, SD, SSIZE - 40 CONTINUE - RETURN -* -99999 FORMAT (' FAIL') -99998 FORMAT (/' CASE N INCX INCY ', - + ' COMP(I) TRUE(I) DIFFERENCE', - + ' SIZE(I)',/1X) -99997 FORMAT (1X,I4,I3,1I5,I3,2E36.8,2E12.4) - END - SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC) -* ************************* STEST1 ***************************** -* -* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE 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 - 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 - 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, N - LOGICAL PASS -* .. Local Scalars .. - INTEGER ID -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, 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, ICOMP, ITRUE, ID - 40 CONTINUE - RETURN -* -99999 FORMAT (' FAIL') -99998 FORMAT (/' CASE N INCX INCY ', - + ' COMP TRUE DIFFERENCE', - + /1X) -99997 FORMAT (1X,I4,I3,2I5,2I36,I12) - END diff --git a/eigen/blas/testing/dblat2.dat b/eigen/blas/testing/dblat2.dat deleted file mode 100644 index 3755b83..0000000 --- a/eigen/blas/testing/dblat2.dat +++ /dev/null @@ -1,34 +0,0 @@ -'dblat2.summ' NAME OF SUMMARY OUTPUT FILE -6 UNIT NUMBER OF SUMMARY FILE -'dblat2.snap' NAME OF SNAPSHOT OUTPUT FILE --1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -F LOGICAL FLAG, T TO STOP ON FAILURES. -T LOGICAL FLAG, T TO TEST ERROR EXITS. -16.0 THRESHOLD VALUE OF TEST RATIO -6 NUMBER OF VALUES OF N -0 1 2 3 5 9 VALUES OF N -4 NUMBER OF VALUES OF K -0 1 2 4 VALUES OF K -4 NUMBER OF VALUES OF INCX AND INCY -1 2 -1 -2 VALUES OF INCX AND INCY -3 NUMBER OF VALUES OF ALPHA -0.0 1.0 0.7 VALUES OF ALPHA -3 NUMBER OF VALUES OF BETA -0.0 1.0 0.9 VALUES OF BETA -DGEMV T PUT F FOR NO TEST. SAME COLUMNS. -DGBMV T PUT F FOR NO TEST. SAME COLUMNS. -DSYMV T PUT F FOR NO TEST. SAME COLUMNS. -DSBMV T PUT F FOR NO TEST. SAME COLUMNS. -DSPMV T PUT F FOR NO TEST. SAME COLUMNS. -DTRMV T PUT F FOR NO TEST. SAME COLUMNS. -DTBMV T PUT F FOR NO TEST. SAME COLUMNS. -DTPMV T PUT F FOR NO TEST. SAME COLUMNS. -DTRSV T PUT F FOR NO TEST. SAME COLUMNS. -DTBSV T PUT F FOR NO TEST. SAME COLUMNS. -DTPSV T PUT F FOR NO TEST. SAME COLUMNS. -DGER T PUT F FOR NO TEST. SAME COLUMNS. -DSYR T PUT F FOR NO TEST. SAME COLUMNS. -DSPR T PUT F FOR NO TEST. SAME COLUMNS. -DSYR2 T PUT F FOR NO TEST. SAME COLUMNS. -DSPR2 T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/eigen/blas/testing/dblat2.f b/eigen/blas/testing/dblat2.f deleted file mode 100644 index 0fa80af..0000000 --- a/eigen/blas/testing/dblat2.f +++ /dev/null @@ -1,3176 +0,0 @@ -*> \brief \b DBLAT2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM DBLAT2 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the DOUBLE PRECISION Level 2 Blas. -*> -*> The program must be driven by a short data file. The first 18 records -*> of the file are read using list-directed input, the last 16 records -*> are read using the format ( A6, L2 ). An annotated example of a data -*> file can be obtained by deleting the first 3 characters from the -*> following 34 lines: -*> 'dblat2.out' NAME OF SUMMARY OUTPUT FILE -*> 6 UNIT NUMBER OF SUMMARY FILE -*> 'DBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE -*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -*> F LOGICAL FLAG, T TO STOP ON FAILURES. -*> T LOGICAL FLAG, T TO TEST ERROR EXITS. -*> 16.0 THRESHOLD VALUE OF TEST RATIO -*> 6 NUMBER OF VALUES OF N -*> 0 1 2 3 5 9 VALUES OF N -*> 4 NUMBER OF VALUES OF K -*> 0 1 2 4 VALUES OF K -*> 4 NUMBER OF VALUES OF INCX AND INCY -*> 1 2 -1 -2 VALUES OF INCX AND INCY -*> 3 NUMBER OF VALUES OF ALPHA -*> 0.0 1.0 0.7 VALUES OF ALPHA -*> 3 NUMBER OF VALUES OF BETA -*> 0.0 1.0 0.9 VALUES OF BETAC -*> DGEMV T PUT F FOR NO TEST. SAME COLUMNS. -*> DGBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> DSYMV T PUT F FOR NO TEST. SAME COLUMNS. -*> DSBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> DSPMV T PUT F FOR NO TEST. SAME COLUMNS. -*> DTRMV T PUT F FOR NO TEST. SAME COLUMNS. -*> DTBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> DTPMV T PUT F FOR NO TEST. SAME COLUMNS. -*> DTRSV T PUT F FOR NO TEST. SAME COLUMNS. -*> DTBSV T PUT F FOR NO TEST. SAME COLUMNS. -*> DTPSV T PUT F FOR NO TEST. SAME COLUMNS. -*> DGER T PUT F FOR NO TEST. SAME COLUMNS. -*> DSYR T PUT F FOR NO TEST. SAME COLUMNS. -*> DSPR T PUT F FOR NO TEST. SAME COLUMNS. -*> DSYR2 T PUT F FOR NO TEST. SAME COLUMNS. -*> DSPR2 T PUT F FOR NO TEST. SAME COLUMNS. -*> -*> Further Details -*> =============== -*> -*> See: -*> -*> Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. -*> An extended set of Fortran Basic Linear Algebra Subprograms. -*> -*> Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics -*> and Computer Science Division, Argonne National Laboratory, -*> 9700 South Cass Avenue, Argonne, Illinois 60439, US. -*> -*> Or -*> -*> NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms -*> Group Ltd., NAG Central Office, 256 Banbury Road, Oxford -*> OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st -*> Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. -*> -*> -*> -- Written on 10-August-1987. -*> Richard Hanson, Sandia National Labs. -*> Jeremy Du Croz, NAG Central Office. -*> -*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers -*> can be run multiple times without deleting generated -*> output files (susan) -*> \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 DBLAT2 -* -* -- Reference BLAS test routine (version 3.4.1) -- -* -- 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 NIN - PARAMETER ( NIN = 5 ) - INTEGER NSUBS - PARAMETER ( NSUBS = 16 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - INTEGER NMAX, INCMAX - PARAMETER ( NMAX = 65, INCMAX = 2 ) - INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX - PARAMETER ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7, - $ NALMAX = 7, NBEMAX = 7 ) -* .. Local Scalars .. - DOUBLE PRECISION EPS, ERR, THRESH - INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB, - $ NOUT, NTRA - LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, - $ TSTERR - CHARACTER*1 TRANS - CHARACTER*6 SNAMET - CHARACTER*32 SNAPS, SUMMRY -* .. Local Arrays .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), - $ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ), - $ G( NMAX ), X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( 2*NMAX ) - INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX ) - LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) -* .. External Functions .. - DOUBLE PRECISION DDIFF - LOGICAL LDE - EXTERNAL DDIFF, LDE -* .. External Subroutines .. - EXTERNAL DCHK1, DCHK2, DCHK3, DCHK4, DCHK5, DCHK6, - $ DCHKE, DMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Data statements .. - DATA SNAMES/'DGEMV ', 'DGBMV ', 'DSYMV ', 'DSBMV ', - $ 'DSPMV ', 'DTRMV ', 'DTBMV ', 'DTPMV ', - $ 'DTRSV ', 'DTBSV ', 'DTPSV ', 'DGER ', - $ 'DSYR ', 'DSPR ', 'DSYR2 ', 'DSPR2 '/ -* .. Executable Statements .. -* -* Read name and unit number for summary output file and open file. -* - READ( NIN, FMT = * )SUMMRY - READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) - NOUTC = NOUT -* -* Read name and unit number for snapshot output file and open file. -* - READ( NIN, FMT = * )SNAPS - READ( NIN, FMT = * )NTRA - TRACE = NTRA.GE.0 - IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' ) - END IF -* Read the flag that directs rewinding of the snapshot file. - READ( NIN, FMT = * )REWI - REWI = REWI.AND.TRACE -* Read the flag that directs stopping on any failure. - READ( NIN, FMT = * )SFATAL -* Read the flag that indicates whether error exits are to be tested. - READ( NIN, FMT = * )TSTERR -* Read the threshold value of the test ratio - READ( NIN, FMT = * )THRESH -* -* Read and check the parameter values for the tests. -* -* Values of N - READ( NIN, FMT = * )NIDIM - IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN - WRITE( NOUT, FMT = 9997 )'N', NIDMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) - DO 10 I = 1, NIDIM - IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN - WRITE( NOUT, FMT = 9996 )NMAX - GO TO 230 - END IF - 10 CONTINUE -* Values of K - READ( NIN, FMT = * )NKB - IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN - WRITE( NOUT, FMT = 9997 )'K', NKBMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( KB( I ), I = 1, NKB ) - DO 20 I = 1, NKB - IF( KB( I ).LT.0 )THEN - WRITE( NOUT, FMT = 9995 ) - GO TO 230 - END IF - 20 CONTINUE -* Values of INCX and INCY - READ( NIN, FMT = * )NINC - IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN - WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( INC( I ), I = 1, NINC ) - DO 30 I = 1, NINC - IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN - WRITE( NOUT, FMT = 9994 )INCMAX - GO TO 230 - END IF - 30 CONTINUE -* Values of ALPHA - READ( NIN, FMT = * )NALF - IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN - WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) -* Values of BETA - READ( NIN, FMT = * )NBET - IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN - WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) -* -* Report values of parameters. -* - WRITE( NOUT, FMT = 9993 ) - WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM ) - WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB ) - WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC ) - WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF ) - WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET ) - IF( .NOT.TSTERR )THEN - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9980 ) - END IF - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9999 )THRESH - WRITE( NOUT, FMT = * ) -* -* Read names of subroutines and flags which indicate -* whether they are to be tested. -* - DO 40 I = 1, NSUBS - LTEST( I ) = .FALSE. - 40 CONTINUE - 50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT - DO 60 I = 1, NSUBS - IF( SNAMET.EQ.SNAMES( I ) ) - $ GO TO 70 - 60 CONTINUE - WRITE( NOUT, FMT = 9986 )SNAMET - STOP - 70 LTEST( I ) = LTESTT - GO TO 50 -* - 80 CONTINUE - CLOSE ( NIN ) -* -* Compute EPS (the machine precision). -* - EPS = EPSILON(ZERO) - WRITE( NOUT, FMT = 9998 )EPS -* -* Check the reliability of DMVCH using exact data. -* - N = MIN( 32, NMAX ) - DO 120 J = 1, N - DO 110 I = 1, N - A( I, J ) = MAX( I - J + 1, 0 ) - 110 CONTINUE - X( J ) = J - Y( J ) = ZERO - 120 CONTINUE - DO 130 J = 1, N - YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 - 130 CONTINUE -* YY holds the exact result. On exit from DMVCH YT holds -* the result computed by DMVCH. - TRANS = 'N' - CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LDE( YY, YT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR - STOP - END IF - TRANS = 'T' - CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LDE( YY, YT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR - STOP - END IF -* -* Test each subroutine in turn. -* - DO 210 ISNUM = 1, NSUBS - WRITE( NOUT, FMT = * ) - IF( .NOT.LTEST( ISNUM ) )THEN -* Subprogram is not to be tested. - WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM ) - ELSE - SRNAMT = SNAMES( ISNUM ) -* Test error exits. - IF( TSTERR )THEN - CALL DCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) - WRITE( NOUT, FMT = * ) - END IF -* Test computations. - INFOT = 0 - OK = .TRUE. - FATAL = .FALSE. - GO TO ( 140, 140, 150, 150, 150, 160, 160, - $ 160, 160, 160, 160, 170, 180, 180, - $ 190, 190 )ISNUM -* Test DGEMV, 01, and DGBMV, 02. - 140 CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, - $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, - $ X, XX, XS, Y, YY, YS, YT, G ) - GO TO 200 -* Test DSYMV, 03, DSBMV, 04, and DSPMV, 05. - 150 CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, - $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, - $ X, XX, XS, Y, YY, YS, YT, G ) - GO TO 200 -* Test DTRMV, 06, DTBMV, 07, DTPMV, 08, -* DTRSV, 09, DTBSV, 10, and DTPSV, 11. - 160 CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z ) - GO TO 200 -* Test DGER, 12. - 170 CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) - GO TO 200 -* Test DSYR, 13, and DSPR, 14. - 180 CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) - GO TO 200 -* Test DSYR2, 15, and DSPR2, 16. - 190 CALL DCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) -* - 200 IF( FATAL.AND.SFATAL ) - $ GO TO 220 - END IF - 210 CONTINUE - WRITE( NOUT, FMT = 9982 ) - GO TO 240 -* - 220 CONTINUE - WRITE( NOUT, FMT = 9981 ) - GO TO 240 -* - 230 CONTINUE - WRITE( NOUT, FMT = 9987 ) -* - 240 CONTINUE - IF( TRACE ) - $ CLOSE ( NTRA ) - CLOSE ( NOUT ) - STOP -* - 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', - $ 'S THAN', F8.2 ) - 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 ) - 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', - $ 'THAN ', I2 ) - 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) - 9995 FORMAT( ' VALUE OF K IS LESS THAN 0' ) - 9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ', - $ I2 ) - 9993 FORMAT( ' TESTS OF THE DOUBLE PRECISION LEVEL 2 BLAS', //' THE F', - $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) - 9992 FORMAT( ' FOR N ', 9I6 ) - 9991 FORMAT( ' FOR K ', 7I6 ) - 9990 FORMAT( ' FOR INCX AND INCY ', 7I6 ) - 9989 FORMAT( ' FOR ALPHA ', 7F6.1 ) - 9988 FORMAT( ' FOR BETA ', 7F6.1 ) - 9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', - $ /' ******* TESTS ABANDONED *******' ) - 9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', - $ 'ESTS ABANDONED *******' ) - 9985 FORMAT( ' ERROR IN DMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', - $ 'ATED WRONGLY.', /' DMVCH WAS CALLED WITH TRANS = ', A1, - $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', / - $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.' - $ , /' ******* TESTS ABANDONED *******' ) - 9984 FORMAT( A6, L2 ) - 9983 FORMAT( 1X, A6, ' WAS NOT TESTED' ) - 9982 FORMAT( /' END OF TESTS' ) - 9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) - 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) -* -* End of DBLAT2. -* - END - SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, - $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, - $ XS, Y, YY, YS, YT, G ) -* -* Tests DGEMV and DGBMV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, HALF - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, - $ NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), - $ X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL - INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY, - $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA, - $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK, - $ NL, NS - LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN - CHARACTER*1 TRANS, TRANSS - CHARACTER*3 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DGBMV, DGEMV, DMAKE, DMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'NTC'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'E' - BANDED = SNAME( 3: 3 ).EQ.'B' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 11 - ELSE IF( BANDED )THEN - NARGS = 13 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 120 IN = 1, NIDIM - N = IDIM( IN ) - ND = N/2 + 1 -* - DO 110 IM = 1, 2 - IF( IM.EQ.1 ) - $ M = MAX( N - ND, 0 ) - IF( IM.EQ.2 ) - $ M = MIN( N + ND, NMAX ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IKU = 1, NK - IF( BANDED )THEN - KU = KB( IKU ) - KL = MAX( KU - 1, 0 ) - ELSE - KU = N - 1 - KL = M - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = KL + KU + 1 - ELSE - LDA = M - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - LAA = LDA*N - NULL = N.LE.0.OR.M.LE.0 -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL DMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, AA, - $ LDA, KL, KU, RESET, TRANSL ) -* - DO 90 IC = 1, 3 - TRANS = ICH( IC: IC ) - TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' -* - IF( TRAN )THEN - ML = N - NL = M - ELSE - ML = M - NL = N - END IF -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*NL -* -* Generate the vector X. -* - TRANSL = HALF - CALL DMAKE( 'GE', ' ', ' ', 1, NL, X, 1, XX, - $ ABS( INCX ), 0, NL - 1, RESET, TRANSL ) - IF( NL.GT.1 )THEN - X( NL/2 ) = ZERO - XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO - END IF -* - DO 70 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*ML -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL DMAKE( 'GE', ' ', ' ', 1, ML, Y, 1, - $ YY, ABS( INCY ), 0, ML - 1, - $ RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - TRANSS = TRANS - MS = M - NS = N - KLS = KL - KUS = KU - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - BLS = BETA - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ TRANS, M, N, ALPHA, LDA, INCX, BETA, - $ INCY - IF( REWI ) - $ REWIND NTRA - CALL DGEMV( TRANS, M, N, ALPHA, AA, - $ LDA, XX, INCX, BETA, YY, - $ INCY ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ TRANS, M, N, KL, KU, ALPHA, LDA, - $ INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL DGBMV( TRANS, M, N, KL, KU, ALPHA, - $ AA, LDA, XX, INCX, BETA, - $ YY, INCY ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 130 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = TRANS.EQ.TRANSS - ISAME( 2 ) = MS.EQ.M - ISAME( 3 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 4 ) = ALS.EQ.ALPHA - ISAME( 5 ) = LDE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - ISAME( 7 ) = LDE( XS, XX, LX ) - ISAME( 8 ) = INCXS.EQ.INCX - ISAME( 9 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 10 ) = LDE( YS, YY, LY ) - ELSE - ISAME( 10 ) = LDERES( 'GE', ' ', 1, - $ ML, YS, YY, - $ ABS( INCY ) ) - END IF - ISAME( 11 ) = INCYS.EQ.INCY - ELSE IF( BANDED )THEN - ISAME( 4 ) = KLS.EQ.KL - ISAME( 5 ) = KUS.EQ.KU - ISAME( 6 ) = ALS.EQ.ALPHA - ISAME( 7 ) = LDE( AS, AA, LAA ) - ISAME( 8 ) = LDAS.EQ.LDA - ISAME( 9 ) = LDE( XS, XX, LX ) - ISAME( 10 ) = INCXS.EQ.INCX - ISAME( 11 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 12 ) = LDE( YS, YY, LY ) - ELSE - ISAME( 12 ) = LDERES( 'GE', ' ', 1, - $ ML, YS, YY, - $ ABS( INCY ) ) - END IF - ISAME( 13 ) = INCYS.EQ.INCY - END IF -* -* If data was incorrectly changed, report -* and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 130 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL DMVCH( TRANS, M, N, ALPHA, A, - $ NMAX, X, INCX, BETA, Y, - $ INCY, YT, G, YY, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 130 - ELSE -* Avoid repeating tests with M.le.0 or -* N.le.0. - GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 140 -* - 130 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, TRANS, M, N, ALPHA, LDA, - $ INCX, BETA, INCY - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANS, M, N, KL, KU, - $ ALPHA, LDA, INCX, BETA, INCY - END IF -* - 140 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), F4.1, - $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1, - $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, - $ ') .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK1. -* - END - SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, - $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, - $ XS, Y, YY, YS, YT, G ) -* -* Tests DSYMV, DSBMV and DSPMV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, HALF - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, - $ NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), - $ X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL - INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY, - $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY, - $ N, NARGS, NC, NK, NS - LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DMAKE, DMVCH, DSBMV, DSPMV, DSYMV -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'Y' - BANDED = SNAME( 3: 3 ).EQ.'B' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 10 - ELSE IF( BANDED )THEN - NARGS = 11 - ELSE IF( PACKED )THEN - NARGS = 9 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 110 IN = 1, NIDIM - N = IDIM( IN ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IK = 1, NK - IF( BANDED )THEN - K = KB( IK ) - ELSE - K = N - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = K + 1 - ELSE - LDA = N - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF - NULL = N.LE.0 -* - DO 90 IC = 1, 2 - UPLO = ICH( IC: IC ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL DMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA, - $ LDA, K, K, RESET, TRANSL ) -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL DMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, - $ ABS( INCX ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 70 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL DMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, - $ TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - UPLOS = UPLO - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - BLS = BETA - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, N, ALPHA, LDA, INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL DSYMV( UPLO, N, ALPHA, AA, LDA, XX, - $ INCX, BETA, YY, INCY ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, N, K, ALPHA, LDA, INCX, BETA, - $ INCY - IF( REWI ) - $ REWIND NTRA - CALL DSBMV( UPLO, N, K, ALPHA, AA, LDA, - $ XX, INCX, BETA, YY, INCY ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, N, ALPHA, INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL DSPMV( UPLO, N, ALPHA, AA, XX, INCX, - $ BETA, YY, INCY ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LDE( AS, AA, LAA ) - ISAME( 5 ) = LDAS.EQ.LDA - ISAME( 6 ) = LDE( XS, XX, LX ) - ISAME( 7 ) = INCXS.EQ.INCX - ISAME( 8 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 9 ) = LDE( YS, YY, LY ) - ELSE - ISAME( 9 ) = LDERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 10 ) = INCYS.EQ.INCY - ELSE IF( BANDED )THEN - ISAME( 3 ) = KS.EQ.K - ISAME( 4 ) = ALS.EQ.ALPHA - ISAME( 5 ) = LDE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - ISAME( 7 ) = LDE( XS, XX, LX ) - ISAME( 8 ) = INCXS.EQ.INCX - ISAME( 9 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 10 ) = LDE( YS, YY, LY ) - ELSE - ISAME( 10 ) = LDERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 11 ) = INCYS.EQ.INCY - ELSE IF( PACKED )THEN - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LDE( AS, AA, LAA ) - ISAME( 5 ) = LDE( XS, XX, LX ) - ISAME( 6 ) = INCXS.EQ.INCX - ISAME( 7 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 8 ) = LDE( YS, YY, LY ) - ELSE - ISAME( 8 ) = LDERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 9 ) = INCYS.EQ.INCY - END IF -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL DMVCH( 'N', N, N, ALPHA, A, NMAX, X, - $ INCX, BETA, Y, INCY, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 120 - ELSE -* Avoid repeating tests with N.le.0 - GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, LDA, INCX, - $ BETA, INCY - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, K, ALPHA, LDA, - $ INCX, BETA, INCY - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, N, ALPHA, INCX, - $ BETA, INCY - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', AP', - $ ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1, - $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, - $ ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', A,', - $ I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK2. -* - END - SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z ) -* -* Tests DTRMV, DTBMV, DTPMV, DTRSV, DTBSV and DTPSV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), - $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), - $ XS( NMAX*INCMAX ), XT( NMAX ), - $ XX( NMAX*INCMAX ), Z( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - DOUBLE PRECISION ERR, ERRMAX, TRANSL - INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K, - $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS - LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME - CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS - CHARACTER*2 ICHD, ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DMAKE, DMVCH, DTBMV, DTBSV, DTPMV, DTPSV, - $ DTRMV, DTRSV -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'R' - BANDED = SNAME( 3: 3 ).EQ.'B' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 8 - ELSE IF( BANDED )THEN - NARGS = 9 - ELSE IF( PACKED )THEN - NARGS = 7 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* Set up zero vector for DMVCH. - DO 10 I = 1, NMAX - Z( I ) = ZERO - 10 CONTINUE -* - DO 110 IN = 1, NIDIM - N = IDIM( IN ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IK = 1, NK - IF( BANDED )THEN - K = KB( IK ) - ELSE - K = N - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = K + 1 - ELSE - LDA = N - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF - NULL = N.LE.0 -* - DO 90 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* - DO 80 ICT = 1, 3 - TRANS = ICHT( ICT: ICT ) -* - DO 70 ICD = 1, 2 - DIAG = ICHD( ICD: ICD ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL DMAKE( SNAME( 2: 3 ), UPLO, DIAG, N, N, A, - $ NMAX, AA, LDA, K, K, RESET, TRANSL ) -* - DO 60 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL DMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, - $ ABS( INCX ), 0, N - 1, RESET, - $ TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - DIAGS = DIAG - NS = N - KS = K - DO 20 I = 1, LAA - AS( I ) = AA( I ) - 20 CONTINUE - LDAS = LDA - DO 30 I = 1, LX - XS( I ) = XX( I ) - 30 CONTINUE - INCXS = INCX -* -* Call the subroutine. -* - IF( SNAME( 4: 5 ).EQ.'MV' )THEN - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL DTRMV( UPLO, TRANS, DIAG, N, AA, LDA, - $ XX, INCX ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, K, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL DTBMV( UPLO, TRANS, DIAG, N, K, AA, - $ LDA, XX, INCX ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, INCX - IF( REWI ) - $ REWIND NTRA - CALL DTPMV( UPLO, TRANS, DIAG, N, AA, XX, - $ INCX ) - END IF - ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL DTRSV( UPLO, TRANS, DIAG, N, AA, LDA, - $ XX, INCX ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, K, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL DTBSV( UPLO, TRANS, DIAG, N, K, AA, - $ LDA, XX, INCX ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, INCX - IF( REWI ) - $ REWIND NTRA - CALL DTPSV( UPLO, TRANS, DIAG, N, AA, XX, - $ INCX ) - END IF - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = TRANS.EQ.TRANSS - ISAME( 3 ) = DIAG.EQ.DIAGS - ISAME( 4 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 5 ) = LDE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 7 ) = LDE( XS, XX, LX ) - ELSE - ISAME( 7 ) = LDERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 8 ) = INCXS.EQ.INCX - ELSE IF( BANDED )THEN - ISAME( 5 ) = KS.EQ.K - ISAME( 6 ) = LDE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 8 ) = LDE( XS, XX, LX ) - ELSE - ISAME( 8 ) = LDERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 9 ) = INCXS.EQ.INCX - ELSE IF( PACKED )THEN - ISAME( 5 ) = LDE( AS, AA, LAA ) - IF( NULL )THEN - ISAME( 6 ) = LDE( XS, XX, LX ) - ELSE - ISAME( 6 ) = LDERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 7 ) = INCXS.EQ.INCX - END IF -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN - IF( SNAME( 4: 5 ).EQ.'MV' )THEN -* -* Check the result. -* - CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, - $ INCX, ZERO, Z, INCX, XT, G, - $ XX, EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN -* -* Compute approximation to original vector. -* - DO 50 I = 1, N - Z( I ) = XX( 1 + ( I - 1 )* - $ ABS( INCX ) ) - XX( 1 + ( I - 1 )*ABS( INCX ) ) - $ = X( I ) - 50 CONTINUE - CALL DMVCH( TRANS, N, N, ONE, A, NMAX, Z, - $ INCX, ZERO, X, INCX, XT, G, - $ XX, EPS, ERR, FATAL, NOUT, - $ .FALSE. ) - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 120 - ELSE -* Avoid repeating tests with N.le.0. - GO TO 110 - END IF -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, DIAG, N, LDA, - $ INCX - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, DIAG, N, K, - $ LDA, INCX - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, TRANS, DIAG, N, INCX - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', AP, ', - $ 'X,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ), - $ ' A,', I3, ', X,', I2, ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,', - $ I3, ', X,', I2, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK3. -* - END - SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests DGER. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), - $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), - $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL - INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX, - $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS, - $ NC, ND, NS - LOGICAL NULL, RESET, SAME -* .. Local Arrays .. - DOUBLE PRECISION W( 1 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DGER, DMAKE, DMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. -* Define the number of arguments. - NARGS = 9 -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 120 IN = 1, NIDIM - N = IDIM( IN ) - ND = N/2 + 1 -* - DO 110 IM = 1, 2 - IF( IM.EQ.1 ) - $ M = MAX( N - ND, 0 ) - IF( IM.EQ.2 ) - $ M = MIN( N + ND, NMAX ) -* -* Set LDA to 1 more than minimum value if room. - LDA = M - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 110 - LAA = LDA*N - NULL = N.LE.0.OR.M.LE.0 -* - DO 100 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*M -* -* Generate the vector X. -* - TRANSL = HALF - CALL DMAKE( 'GE', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ), - $ 0, M - 1, RESET, TRANSL ) - IF( M.GT.1 )THEN - X( M/2 ) = ZERO - XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO - END IF -* - DO 90 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL DMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - Y( N/2 ) = ZERO - YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 80 IA = 1, NALF - ALPHA = ALF( IA ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL DMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, - $ AA, LDA, M - 1, N - 1, RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - MS = M - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N, - $ ALPHA, INCX, INCY, LDA - IF( REWI ) - $ REWIND NTRA - CALL DGER( M, N, ALPHA, XX, INCX, YY, INCY, AA, - $ LDA ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 140 - END IF -* -* See what data changed inside subroutine. -* - ISAME( 1 ) = MS.EQ.M - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LDE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - ISAME( 6 ) = LDE( YS, YY, LY ) - ISAME( 7 ) = INCYS.EQ.INCY - IF( NULL )THEN - ISAME( 8 ) = LDE( AS, AA, LAA ) - ELSE - ISAME( 8 ) = LDERES( 'GE', ' ', M, N, AS, AA, - $ LDA ) - END IF - ISAME( 9 ) = LDAS.EQ.LDA -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 140 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 50 I = 1, M - Z( I ) = X( I ) - 50 CONTINUE - ELSE - DO 60 I = 1, M - Z( I ) = X( M - I + 1 ) - 60 CONTINUE - END IF - DO 70 J = 1, N - IF( INCY.GT.0 )THEN - W( 1 ) = Y( J ) - ELSE - W( 1 ) = Y( N - J + 1 ) - END IF - CALL DMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1, - $ ONE, A( 1, J ), 1, YT, G, - $ AA( 1 + ( J - 1 )*LDA ), EPS, - $ ERR, FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 130 - 70 CONTINUE - ELSE -* Avoid repeating tests with M.le.0 or N.le.0. - GO TO 110 - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 150 -* - 130 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 140 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA -* - 150 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), F4.1, ', X,', I2, - $ ', Y,', I2, ', A,', I3, ') .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK4. -* - END - SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests DSYR and DSPR. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), - $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), - $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL - INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA, - $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS - LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - DOUBLE PRECISION W( 1 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DMAKE, DMVCH, DSPR, DSYR -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'Y' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 7 - ELSE IF( PACKED )THEN - NARGS = 6 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDA to 1 more than minimum value if room. - LDA = N - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF -* - DO 90 IC = 1, 2 - UPLO = ICH( IC: IC ) - UPPER = UPLO.EQ.'U' -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL DMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), - $ 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 70 IA = 1, NALF - ALPHA = ALF( IA ) - NULL = N.LE.0.OR.ALPHA.EQ.ZERO -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL DMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, - $ AA, LDA, N - 1, N - 1, RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, - $ ALPHA, INCX, LDA - IF( REWI ) - $ REWIND NTRA - CALL DSYR( UPLO, N, ALPHA, XX, INCX, AA, LDA ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, - $ ALPHA, INCX - IF( REWI ) - $ REWIND NTRA - CALL DSPR( UPLO, N, ALPHA, XX, INCX, AA ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LDE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - IF( NULL )THEN - ISAME( 6 ) = LDE( AS, AA, LAA ) - ELSE - ISAME( 6 ) = LDERES( SNAME( 2: 3 ), UPLO, N, N, AS, - $ AA, LDA ) - END IF - IF( .NOT.PACKED )THEN - ISAME( 7 ) = LDAS.EQ.LDA - END IF -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 30 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 30 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 40 I = 1, N - Z( I ) = X( I ) - 40 CONTINUE - ELSE - DO 50 I = 1, N - Z( I ) = X( N - I + 1 ) - 50 CONTINUE - END IF - JA = 1 - DO 60 J = 1, N - W( 1 ) = Z( J ) - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - CALL DMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W, - $ 1, ONE, A( JJ, J ), 1, YT, G, - $ AA( JA ), EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - IF( FULL )THEN - IF( UPPER )THEN - JA = JA + LDA - ELSE - JA = JA + LDA + 1 - END IF - ELSE - JA = JA + LJ - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 110 - 60 CONTINUE - ELSE -* Avoid repeating tests if N.le.0. - IF( N.LE.0 ) - $ GO TO 100 - END IF -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 110 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, LDA - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', AP) .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', A,', I3, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK5. -* - END - SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests DSYR2 and DSPR2. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), - $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), - $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX, 2 ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL - INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX, - $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N, - $ NARGS, NC, NS - LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - DOUBLE PRECISION W( 2 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DMAKE, DMVCH, DSPR2, DSYR2 -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'Y' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 9 - ELSE IF( PACKED )THEN - NARGS = 8 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 140 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDA to 1 more than minimum value if room. - LDA = N - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 140 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF -* - DO 130 IC = 1, 2 - UPLO = ICH( IC: IC ) - UPPER = UPLO.EQ.'U' -* - DO 120 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL DMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), - $ 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 110 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL DMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - Y( N/2 ) = ZERO - YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 100 IA = 1, NALF - ALPHA = ALF( IA ) - NULL = N.LE.0.OR.ALPHA.EQ.ZERO -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL DMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, - $ NMAX, AA, LDA, N - 1, N - 1, RESET, - $ TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, - $ ALPHA, INCX, INCY, LDA - IF( REWI ) - $ REWIND NTRA - CALL DSYR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, - $ AA, LDA ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, - $ ALPHA, INCX, INCY - IF( REWI ) - $ REWIND NTRA - CALL DSPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, - $ AA ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 160 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LDE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - ISAME( 6 ) = LDE( YS, YY, LY ) - ISAME( 7 ) = INCYS.EQ.INCY - IF( NULL )THEN - ISAME( 8 ) = LDE( AS, AA, LAA ) - ELSE - ISAME( 8 ) = LDERES( SNAME( 2: 3 ), UPLO, N, N, - $ AS, AA, LDA ) - END IF - IF( .NOT.PACKED )THEN - ISAME( 9 ) = LDAS.EQ.LDA - END IF -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 160 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 50 I = 1, N - Z( I, 1 ) = X( I ) - 50 CONTINUE - ELSE - DO 60 I = 1, N - Z( I, 1 ) = X( N - I + 1 ) - 60 CONTINUE - END IF - IF( INCY.GT.0 )THEN - DO 70 I = 1, N - Z( I, 2 ) = Y( I ) - 70 CONTINUE - ELSE - DO 80 I = 1, N - Z( I, 2 ) = Y( N - I + 1 ) - 80 CONTINUE - END IF - JA = 1 - DO 90 J = 1, N - W( 1 ) = Z( J, 2 ) - W( 2 ) = Z( J, 1 ) - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - CALL DMVCH( 'N', LJ, 2, ALPHA, Z( JJ, 1 ), - $ NMAX, W, 1, ONE, A( JJ, J ), 1, - $ YT, G, AA( JA ), EPS, ERR, FATAL, - $ NOUT, .TRUE. ) - IF( FULL )THEN - IF( UPPER )THEN - JA = JA + LDA - ELSE - JA = JA + LDA + 1 - END IF - ELSE - JA = JA + LJ - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 150 - 90 CONTINUE - ELSE -* Avoid repeating tests with N.le.0. - IF( N.LE.0 ) - $ GO TO 140 - END IF -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* - 140 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 170 -* - 150 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 160 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, - $ INCY, LDA - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX, INCY - END IF -* - 170 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', Y,', I2, ', AP) .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', Y,', I2, ', A,', I3, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK6. -* - END - SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) -* -* Tests the error exits from the Level 2 Blas. -* Requires a special version of the error-handling routine XERBLA. -* ALPHA, BETA, A, X and Y should not need to be defined. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, BETA -* .. Local Arrays .. - DOUBLE PRECISION A( 1, 1 ), X( 1 ), Y( 1 ) -* .. External Subroutines .. - EXTERNAL CHKXER, DGBMV, DGEMV, DGER, DSBMV, DSPMV, DSPR, - $ DSPR2, DSYMV, DSYR, DSYR2, DTBMV, DTBSV, DTPMV, - $ DTPSV, DTRMV, DTRSV -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. -* OK is set to .FALSE. by the special version of XERBLA or by CHKXER -* if anything is wrong. - OK = .TRUE. -* LERR is set to .TRUE. by the special version of XERBLA each time -* it is called, and is then tested and re-set by CHKXER. - LERR = .FALSE. - GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, - $ 90, 100, 110, 120, 130, 140, 150, - $ 160 )ISNUM - 10 INFOT = 1 - CALL DGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL DGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 20 INFOT = 1 - CALL DGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DGBMV( 'N', -1, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DGBMV( 'N', 0, -1, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DGBMV( 'N', 0, 0, -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DGBMV( 'N', 2, 0, 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL DGBMV( 'N', 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL DGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL DGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 30 INFOT = 1 - CALL DSYMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DSYMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DSYMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL DSYMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 40 INFOT = 1 - CALL DSBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DSBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DSBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL DSBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DSBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 50 INFOT = 1 - CALL DSPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DSPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DSPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DSPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 60 INFOT = 1 - CALL DTRMV( '/', 'N', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DTRMV( 'U', '/', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DTRMV( 'U', 'N', '/', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DTRMV( 'U', 'N', 'N', -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRMV( 'U', 'N', 'N', 2, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL DTRMV( 'U', 'N', 'N', 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 70 INFOT = 1 - CALL DTBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DTBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DTBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DTBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DTBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 80 INFOT = 1 - CALL DTPMV( '/', 'N', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DTPMV( 'U', '/', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DTPMV( 'U', 'N', '/', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DTPMV( 'U', 'N', 'N', -1, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DTPMV( 'U', 'N', 'N', 0, A, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 90 INFOT = 1 - CALL DTRSV( '/', 'N', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DTRSV( 'U', '/', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DTRSV( 'U', 'N', '/', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DTRSV( 'U', 'N', 'N', -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRSV( 'U', 'N', 'N', 2, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL DTRSV( 'U', 'N', 'N', 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 100 INFOT = 1 - CALL DTBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DTBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DTBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DTBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DTBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 110 INFOT = 1 - CALL DTPSV( '/', 'N', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DTPSV( 'U', '/', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DTPSV( 'U', 'N', '/', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DTPSV( 'U', 'N', 'N', -1, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DTPSV( 'U', 'N', 'N', 0, A, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 120 INFOT = 1 - CALL DGER( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DGER( 0, -1, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DGER( 0, 0, ALPHA, X, 0, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DGER( 0, 0, ALPHA, X, 1, Y, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DGER( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 130 INFOT = 1 - CALL DSYR( '/', 0, ALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DSYR( 'U', -1, ALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DSYR( 'U', 0, ALPHA, X, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYR( 'U', 2, ALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 140 INFOT = 1 - CALL DSPR( '/', 0, ALPHA, X, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DSPR( 'U', -1, ALPHA, X, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DSPR( 'U', 0, ALPHA, X, 0, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 150 INFOT = 1 - CALL DSYR2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DSYR2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DSYR2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYR2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DSYR2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 160 INFOT = 1 - CALL DSPR2( '/', 0, ALPHA, X, 1, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DSPR2( 'U', -1, ALPHA, X, 1, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DSPR2( 'U', 0, ALPHA, X, 0, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSPR2( 'U', 0, ALPHA, X, 1, Y, 0, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* - 170 IF( OK )THEN - WRITE( NOUT, FMT = 9999 )SRNAMT - ELSE - WRITE( NOUT, FMT = 9998 )SRNAMT - END IF - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) - 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', - $ '**' ) -* -* End of DCHKE. -* - END - SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, - $ KU, RESET, TRANSL ) -* -* Generates values for an M by N matrix A within the bandwidth -* defined by KL and KU. -* Stores the values in the array AA in the data structure required -* by the routine, with unwanted elements set to rogue value. -* -* TYPE is 'GE', 'GB', 'SY', 'SB', 'SP', 'TR', 'TB' OR 'TP'. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - DOUBLE PRECISION ROGUE - PARAMETER ( ROGUE = -1.0D10 ) -* .. Scalar Arguments .. - DOUBLE PRECISION TRANSL - INTEGER KL, KU, LDA, M, N, NMAX - LOGICAL RESET - CHARACTER*1 DIAG, UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, * ), AA( * ) -* .. Local Scalars .. - INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, KK - LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER -* .. External Functions .. - DOUBLE PRECISION DBEG - EXTERNAL DBEG -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. Executable Statements .. - GEN = TYPE( 1: 1 ).EQ.'G' - SYM = TYPE( 1: 1 ).EQ.'S' - TRI = TYPE( 1: 1 ).EQ.'T' - UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' - LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' - UNIT = TRI.AND.DIAG.EQ.'U' -* -* Generate data in array A. -* - DO 20 J = 1, N - DO 10 I = 1, M - IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) - $ THEN - IF( ( I.LE.J.AND.J - I.LE.KU ).OR. - $ ( I.GE.J.AND.I - J.LE.KL ) )THEN - A( I, J ) = DBEG( RESET ) + TRANSL - ELSE - A( I, J ) = ZERO - END IF - IF( I.NE.J )THEN - IF( SYM )THEN - A( J, I ) = A( I, J ) - ELSE IF( TRI )THEN - A( J, I ) = ZERO - END IF - END IF - END IF - 10 CONTINUE - IF( TRI ) - $ A( J, J ) = A( J, J ) + ONE - IF( UNIT ) - $ A( J, J ) = ONE - 20 CONTINUE -* -* Store elements in array AS in data structure required by routine. -* - IF( TYPE.EQ.'GE' )THEN - DO 50 J = 1, N - DO 30 I = 1, M - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 30 CONTINUE - DO 40 I = M + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 40 CONTINUE - 50 CONTINUE - ELSE IF( TYPE.EQ.'GB' )THEN - DO 90 J = 1, N - DO 60 I1 = 1, KU + 1 - J - AA( I1 + ( J - 1 )*LDA ) = ROGUE - 60 CONTINUE - DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J ) - AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J ) - 70 CONTINUE - DO 80 I3 = I2, LDA - AA( I3 + ( J - 1 )*LDA ) = ROGUE - 80 CONTINUE - 90 CONTINUE - ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN - DO 130 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IF( UNIT )THEN - IEND = J - 1 - ELSE - IEND = J - END IF - ELSE - IF( UNIT )THEN - IBEG = J + 1 - ELSE - IBEG = J - END IF - IEND = N - END IF - DO 100 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 100 CONTINUE - DO 110 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 110 CONTINUE - DO 120 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 120 CONTINUE - 130 CONTINUE - ELSE IF( TYPE.EQ.'SB'.OR.TYPE.EQ.'TB' )THEN - DO 170 J = 1, N - IF( UPPER )THEN - KK = KL + 1 - IBEG = MAX( 1, KL + 2 - J ) - IF( UNIT )THEN - IEND = KL - ELSE - IEND = KL + 1 - END IF - ELSE - KK = 1 - IF( UNIT )THEN - IBEG = 2 - ELSE - IBEG = 1 - END IF - IEND = MIN( KL + 1, 1 + M - J ) - END IF - DO 140 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 140 CONTINUE - DO 150 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J ) - 150 CONTINUE - DO 160 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 160 CONTINUE - 170 CONTINUE - ELSE IF( TYPE.EQ.'SP'.OR.TYPE.EQ.'TP' )THEN - IOFF = 0 - DO 190 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 180 I = IBEG, IEND - IOFF = IOFF + 1 - AA( IOFF ) = A( I, J ) - IF( I.EQ.J )THEN - IF( UNIT ) - $ AA( IOFF ) = ROGUE - END IF - 180 CONTINUE - 190 CONTINUE - END IF - RETURN -* -* End of DMAKE. -* - END - SUBROUTINE DMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, - $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV ) -* -* Checks the results of the computational tests. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA, EPS, ERR - INTEGER INCX, INCY, M, N, NMAX, NOUT - LOGICAL FATAL, MV - CHARACTER*1 TRANS -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, * ), G( * ), X( * ), Y( * ), YT( * ), - $ YY( * ) -* .. Local Scalars .. - DOUBLE PRECISION ERRI - INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL - LOGICAL TRAN -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. Executable Statements .. - TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' - IF( TRAN )THEN - ML = N - NL = M - ELSE - ML = M - NL = N - END IF - IF( INCX.LT.0 )THEN - KX = NL - INCXL = -1 - ELSE - KX = 1 - INCXL = 1 - END IF - IF( INCY.LT.0 )THEN - KY = ML - INCYL = -1 - ELSE - KY = 1 - INCYL = 1 - END IF -* -* Compute expected result in YT using data in A, X and Y. -* Compute gauges in G. -* - IY = KY - DO 30 I = 1, ML - YT( IY ) = ZERO - G( IY ) = ZERO - JX = KX - IF( TRAN )THEN - DO 10 J = 1, NL - YT( IY ) = YT( IY ) + A( J, I )*X( JX ) - G( IY ) = G( IY ) + ABS( A( J, I )*X( JX ) ) - JX = JX + INCXL - 10 CONTINUE - ELSE - DO 20 J = 1, NL - YT( IY ) = YT( IY ) + A( I, J )*X( JX ) - G( IY ) = G( IY ) + ABS( A( I, J )*X( JX ) ) - JX = JX + INCXL - 20 CONTINUE - END IF - YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY ) - G( IY ) = ABS( ALPHA )*G( IY ) + ABS( BETA*Y( IY ) ) - IY = IY + INCYL - 30 CONTINUE -* -* Compute the error ratio for this result. -* - ERR = ZERO - DO 40 I = 1, ML - ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS - IF( G( I ).NE.ZERO ) - $ ERRI = ERRI/G( I ) - ERR = MAX( ERR, ERRI ) - IF( ERR*SQRT( EPS ).GE.ONE ) - $ GO TO 50 - 40 CONTINUE -* If the loop completes, all results are at least half accurate. - GO TO 70 -* -* Report fatal error. -* - 50 FATAL = .TRUE. - WRITE( NOUT, FMT = 9999 ) - DO 60 I = 1, ML - IF( MV )THEN - WRITE( NOUT, FMT = 9998 )I, YT( I ), - $ YY( 1 + ( I - 1 )*ABS( INCY ) ) - ELSE - WRITE( NOUT, FMT = 9998 )I, - $ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT( I ) - END IF - 60 CONTINUE -* - 70 CONTINUE - RETURN -* - 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', - $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU', - $ 'TED RESULT' ) - 9998 FORMAT( 1X, I7, 2G18.6 ) -* -* End of DMVCH. -* - END - LOGICAL FUNCTION LDE( RI, RJ, LR ) -* -* Tests if two arrays are identical. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER LR -* .. Array Arguments .. - DOUBLE PRECISION RI( * ), RJ( * ) -* .. Local Scalars .. - INTEGER I -* .. Executable Statements .. - DO 10 I = 1, LR - IF( RI( I ).NE.RJ( I ) ) - $ GO TO 20 - 10 CONTINUE - LDE = .TRUE. - GO TO 30 - 20 CONTINUE - LDE = .FALSE. - 30 RETURN -* -* End of LDE. -* - END - LOGICAL FUNCTION LDERES( TYPE, UPLO, M, N, AA, AS, LDA ) -* -* Tests if selected elements in two arrays are equal. -* -* TYPE is 'GE', 'SY' or 'SP'. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER LDA, M, N - CHARACTER*1 UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - DOUBLE PRECISION AA( LDA, * ), AS( LDA, * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J - LOGICAL UPPER -* .. Executable Statements .. - UPPER = UPLO.EQ.'U' - IF( TYPE.EQ.'GE' )THEN - DO 20 J = 1, N - DO 10 I = M + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 10 CONTINUE - 20 CONTINUE - ELSE IF( TYPE.EQ.'SY' )THEN - DO 50 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 30 I = 1, IBEG - 1 - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 30 CONTINUE - DO 40 I = IEND + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 40 CONTINUE - 50 CONTINUE - END IF -* - LDERES = .TRUE. - GO TO 80 - 70 CONTINUE - LDERES = .FALSE. - 80 RETURN -* -* End of LDERES. -* - END - DOUBLE PRECISION FUNCTION DBEG( RESET ) -* -* Generates random numbers uniformly distributed between -0.5 and 0.5. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - LOGICAL RESET -* .. Local Scalars .. - INTEGER I, IC, MI -* .. Save statement .. - SAVE I, IC, MI -* .. Intrinsic Functions .. - INTRINSIC DBLE -* .. Executable Statements .. - IF( RESET )THEN -* Initialize local variables. - MI = 891 - I = 7 - IC = 0 - RESET = .FALSE. - END IF -* -* The sequence of values of I is bounded between 1 and 999. -* If initial I = 1,2,3,6,7 or 9, the period will be 50. -* If initial I = 4 or 8, the period will be 25. -* If initial I = 5, the period will be 10. -* IC is used to break up the period by skipping 1 value of I in 6. -* - IC = IC + 1 - 10 I = I*MI - I = I - 1000*( I/1000 ) - IF( IC.GE.5 )THEN - IC = 0 - GO TO 10 - END IF - DBEG = DBLE( I - 500 )/1001.0D0 - RETURN -* -* End of DBEG. -* - END - DOUBLE PRECISION FUNCTION DDIFF( X, Y ) -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* -* .. Scalar Arguments .. - DOUBLE PRECISION X, Y -* .. Executable Statements .. - DDIFF = X - Y - RETURN -* -* End of DDIFF. -* - END - SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* -* Tests whether XERBLA has detected an error when it should. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Executable Statements .. - IF( .NOT.LERR )THEN - WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT - OK = .FALSE. - END IF - LERR = .FALSE. - RETURN -* - 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', - $ 'ETECTED BY ', A6, ' *****' ) -* -* End of CHKXER. -* - END - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* This is a special version of XERBLA to be used only as part of -* the test program for testing error exits from the Level 2 BLAS -* routines. -* -* XERBLA is an error handler for the Level 2 BLAS routines. -* -* It is called by the Level 2 BLAS routines if an input parameter is -* invalid. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER INFO - CHARACTER*6 SRNAME -* .. Scalars in Common .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUT, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Executable Statements .. - LERR = .TRUE. - IF( INFO.NE.INFOT )THEN - IF( INFOT.NE.0 )THEN - WRITE( NOUT, FMT = 9999 )INFO, INFOT - ELSE - WRITE( NOUT, FMT = 9997 )INFO - END IF - OK = .FALSE. - END IF - IF( SRNAME.NE.SRNAMT )THEN - WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT - OK = .FALSE. - END IF - RETURN -* - 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', - $ ' OF ', I2, ' *******' ) - 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', - $ 'AD OF ', A6, ' *******' ) - 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, - $ ' *******' ) -* -* End of XERBLA -* - END - diff --git a/eigen/blas/testing/dblat3.dat b/eigen/blas/testing/dblat3.dat deleted file mode 100644 index 5cbc2e6..0000000 --- a/eigen/blas/testing/dblat3.dat +++ /dev/null @@ -1,20 +0,0 @@ -'dblat3.summ' NAME OF SUMMARY OUTPUT FILE -6 UNIT NUMBER OF SUMMARY FILE -'dblat3.snap' NAME OF SNAPSHOT OUTPUT FILE --1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -F LOGICAL FLAG, T TO STOP ON FAILURES. -T LOGICAL FLAG, T TO TEST ERROR EXITS. -16.0 THRESHOLD VALUE OF TEST RATIO -6 NUMBER OF VALUES OF N -0 1 2 3 5 9 VALUES OF N -3 NUMBER OF VALUES OF ALPHA -0.0 1.0 0.7 VALUES OF ALPHA -3 NUMBER OF VALUES OF BETA -0.0 1.0 1.3 VALUES OF BETA -DGEMM T PUT F FOR NO TEST. SAME COLUMNS. -DSYMM T PUT F FOR NO TEST. SAME COLUMNS. -DTRMM T PUT F FOR NO TEST. SAME COLUMNS. -DTRSM T PUT F FOR NO TEST. SAME COLUMNS. -DSYRK T PUT F FOR NO TEST. SAME COLUMNS. -DSYR2K T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/eigen/blas/testing/dblat3.f b/eigen/blas/testing/dblat3.f deleted file mode 100644 index 8d37c74..0000000 --- a/eigen/blas/testing/dblat3.f +++ /dev/null @@ -1,2873 +0,0 @@ -*> \brief \b DBLAT3 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM DBLAT3 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the DOUBLE PRECISION Level 3 Blas. -*> -*> The program must be driven by a short data file. The first 14 records -*> of the file are read using list-directed input, the last 6 records -*> are read using the format ( A6, L2 ). An annotated example of a data -*> file can be obtained by deleting the first 3 characters from the -*> following 20 lines: -*> 'dblat3.out' NAME OF SUMMARY OUTPUT FILE -*> 6 UNIT NUMBER OF SUMMARY FILE -*> 'DBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE -*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -*> F LOGICAL FLAG, T TO STOP ON FAILURES. -*> T LOGICAL FLAG, T TO TEST ERROR EXITS. -*> 16.0 THRESHOLD VALUE OF TEST RATIO -*> 6 NUMBER OF VALUES OF N -*> 0 1 2 3 5 9 VALUES OF N -*> 3 NUMBER OF VALUES OF ALPHA -*> 0.0 1.0 0.7 VALUES OF ALPHA -*> 3 NUMBER OF VALUES OF BETA -*> 0.0 1.0 1.3 VALUES OF BETA -*> DGEMM T PUT F FOR NO TEST. SAME COLUMNS. -*> DSYMM T PUT F FOR NO TEST. SAME COLUMNS. -*> DTRMM T PUT F FOR NO TEST. SAME COLUMNS. -*> DTRSM T PUT F FOR NO TEST. SAME COLUMNS. -*> DSYRK T PUT F FOR NO TEST. SAME COLUMNS. -*> DSYR2K T PUT F FOR NO TEST. SAME COLUMNS. -*> -*> Further Details -*> =============== -*> -*> See: -*> -*> Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. -*> A Set of Level 3 Basic Linear Algebra Subprograms. -*> -*> Technical Memorandum No.88 (Revision 1), Mathematics and -*> Computer Science Division, Argonne National Laboratory, 9700 -*> South Cass Avenue, Argonne, Illinois 60439, US. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> -*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers -*> can be run multiple times without deleting generated -*> output files (susan) -*> \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 DBLAT3 -* -* -- Reference BLAS test routine (version 3.4.1) -- -* -- 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 NIN - PARAMETER ( NIN = 5 ) - INTEGER NSUBS - PARAMETER ( NSUBS = 6 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - INTEGER NMAX - PARAMETER ( NMAX = 65 ) - INTEGER NIDMAX, NALMAX, NBEMAX - PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 ) -* .. Local Scalars .. - DOUBLE PRECISION EPS, ERR, THRESH - INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA - LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, - $ TSTERR - CHARACTER*1 TRANSA, TRANSB - CHARACTER*6 SNAMET - CHARACTER*32 SNAPS, SUMMRY -* .. Local Arrays .. - DOUBLE PRECISION AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), - $ ALF( NALMAX ), AS( NMAX*NMAX ), - $ BB( NMAX*NMAX ), BET( NBEMAX ), - $ BS( NMAX*NMAX ), C( NMAX, NMAX ), - $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), - $ G( NMAX ), W( 2*NMAX ) - INTEGER IDIM( NIDMAX ) - LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) -* .. External Functions .. - DOUBLE PRECISION DDIFF - LOGICAL LDE - EXTERNAL DDIFF, LDE -* .. External Subroutines .. - EXTERNAL DCHK1, DCHK2, DCHK3, DCHK4, DCHK5, DCHKE, DMMCH -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Data statements .. - DATA SNAMES/'DGEMM ', 'DSYMM ', 'DTRMM ', 'DTRSM ', - $ 'DSYRK ', 'DSYR2K'/ -* .. Executable Statements .. -* -* Read name and unit number for summary output file and open file. -* - READ( NIN, FMT = * )SUMMRY - READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) - NOUTC = NOUT -* -* Read name and unit number for snapshot output file and open file. -* - READ( NIN, FMT = * )SNAPS - READ( NIN, FMT = * )NTRA - TRACE = NTRA.GE.0 - IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' ) - END IF -* Read the flag that directs rewinding of the snapshot file. - READ( NIN, FMT = * )REWI - REWI = REWI.AND.TRACE -* Read the flag that directs stopping on any failure. - READ( NIN, FMT = * )SFATAL -* Read the flag that indicates whether error exits are to be tested. - READ( NIN, FMT = * )TSTERR -* Read the threshold value of the test ratio - READ( NIN, FMT = * )THRESH -* -* Read and check the parameter values for the tests. -* -* Values of N - READ( NIN, FMT = * )NIDIM - IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN - WRITE( NOUT, FMT = 9997 )'N', NIDMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) - DO 10 I = 1, NIDIM - IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN - WRITE( NOUT, FMT = 9996 )NMAX - GO TO 220 - END IF - 10 CONTINUE -* Values of ALPHA - READ( NIN, FMT = * )NALF - IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN - WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) -* Values of BETA - READ( NIN, FMT = * )NBET - IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN - WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) -* -* Report values of parameters. -* - WRITE( NOUT, FMT = 9995 ) - WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM ) - WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF ) - WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET ) - IF( .NOT.TSTERR )THEN - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9984 ) - END IF - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9999 )THRESH - WRITE( NOUT, FMT = * ) -* -* Read names of subroutines and flags which indicate -* whether they are to be tested. -* - DO 20 I = 1, NSUBS - LTEST( I ) = .FALSE. - 20 CONTINUE - 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT - DO 40 I = 1, NSUBS - IF( SNAMET.EQ.SNAMES( I ) ) - $ GO TO 50 - 40 CONTINUE - WRITE( NOUT, FMT = 9990 )SNAMET - STOP - 50 LTEST( I ) = LTESTT - GO TO 30 -* - 60 CONTINUE - CLOSE ( NIN ) -* -* Compute EPS (the machine precision). -* - EPS = EPSILON(ZERO) - WRITE( NOUT, FMT = 9998 )EPS -* -* Check the reliability of DMMCH using exact data. -* - N = MIN( 32, NMAX ) - DO 100 J = 1, N - DO 90 I = 1, N - AB( I, J ) = MAX( I - J + 1, 0 ) - 90 CONTINUE - AB( J, NMAX + 1 ) = J - AB( 1, NMAX + J ) = J - C( J, 1 ) = ZERO - 100 CONTINUE - DO 110 J = 1, N - CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 - 110 CONTINUE -* CC holds the exact result. On exit from DMMCH CT holds -* the result computed by DMMCH. - TRANSA = 'N' - TRANSB = 'N' - CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LDE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - TRANSB = 'T' - CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LDE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - DO 120 J = 1, N - AB( J, NMAX + 1 ) = N - J + 1 - AB( 1, NMAX + J ) = N - J + 1 - 120 CONTINUE - DO 130 J = 1, N - CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 - - $ ( ( J + 1 )*J*( J - 1 ) )/3 - 130 CONTINUE - TRANSA = 'T' - TRANSB = 'N' - CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LDE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - TRANSB = 'T' - CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LDE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF -* -* Test each subroutine in turn. -* - DO 200 ISNUM = 1, NSUBS - WRITE( NOUT, FMT = * ) - IF( .NOT.LTEST( ISNUM ) )THEN -* Subprogram is not to be tested. - WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM ) - ELSE - SRNAMT = SNAMES( ISNUM ) -* Test error exits. - IF( TSTERR )THEN - CALL DCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) - WRITE( NOUT, FMT = * ) - END IF -* Test computations. - INFOT = 0 - OK = .TRUE. - FATAL = .FALSE. - GO TO ( 140, 150, 160, 160, 170, 180 )ISNUM -* Test DGEMM, 01. - 140 CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test DSYMM, 02. - 150 CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test DTRMM, 03, DTRSM, 04. - 160 CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB, - $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C ) - GO TO 190 -* Test DSYRK, 05. - 170 CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test DSYR2K, 06. - 180 CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) - GO TO 190 -* - 190 IF( FATAL.AND.SFATAL ) - $ GO TO 210 - END IF - 200 CONTINUE - WRITE( NOUT, FMT = 9986 ) - GO TO 230 -* - 210 CONTINUE - WRITE( NOUT, FMT = 9985 ) - GO TO 230 -* - 220 CONTINUE - WRITE( NOUT, FMT = 9991 ) -* - 230 CONTINUE - IF( TRACE ) - $ CLOSE ( NTRA ) - CLOSE ( NOUT ) - STOP -* - 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', - $ 'S THAN', F8.2 ) - 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 ) - 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', - $ 'THAN ', I2 ) - 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) - 9995 FORMAT( ' TESTS OF THE DOUBLE PRECISION LEVEL 3 BLAS', //' THE F', - $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) - 9994 FORMAT( ' FOR N ', 9I6 ) - 9993 FORMAT( ' FOR ALPHA ', 7F6.1 ) - 9992 FORMAT( ' FOR BETA ', 7F6.1 ) - 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', - $ /' ******* TESTS ABANDONED *******' ) - 9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', - $ 'ESTS ABANDONED *******' ) - 9989 FORMAT( ' ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', - $ 'ATED WRONGLY.', /' DMMCH WAS CALLED WITH TRANSA = ', A1, - $ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ', - $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', - $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', - $ '*******' ) - 9988 FORMAT( A6, L2 ) - 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' ) - 9986 FORMAT( /' END OF TESTS' ) - 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) - 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) -* -* End of DBLAT3. -* - END - SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests DGEMM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX - INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA, - $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, - $ MA, MB, MS, N, NA, NARGS, NB, NC, NS - LOGICAL NULL, RESET, SAME, TRANA, TRANB - CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB - CHARACTER*3 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DGEMM, DMAKE, DMMCH -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'NTC'/ -* .. Executable Statements .. -* - NARGS = 13 - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 110 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = M - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 100 - LCC = LDC*N - NULL = N.LE.0.OR.M.LE.0 -* - DO 90 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 80 ICA = 1, 3 - TRANSA = ICH( ICA: ICA ) - TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' -* - IF( TRANA )THEN - MA = K - NA = M - ELSE - MA = M - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* -* Generate the matrix A. -* - CALL DMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) -* - DO 70 ICB = 1, 3 - TRANSB = ICH( ICB: ICB ) - TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' -* - IF( TRANB )THEN - MB = N - NB = K - ELSE - MB = K - NB = N - END IF -* Set LDB to 1 more than minimum value if room. - LDB = MB - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 70 - LBB = LDB*NB -* -* Generate the matrix B. -* - CALL DMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB, - $ LDB, RESET, ZERO ) -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL DMAKE( 'GE', ' ', ' ', M, N, C, NMAX, - $ CC, LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - TRANAS = TRANSA - TRANBS = TRANSB - MS = M - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - BLS = BETA - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB, - $ BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL DGEMM( TRANSA, TRANSB, M, N, K, ALPHA, - $ AA, LDA, BB, LDB, BETA, CC, LDC ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = TRANSA.EQ.TRANAS - ISAME( 2 ) = TRANSB.EQ.TRANBS - ISAME( 3 ) = MS.EQ.M - ISAME( 4 ) = NS.EQ.N - ISAME( 5 ) = KS.EQ.K - ISAME( 6 ) = ALS.EQ.ALPHA - ISAME( 7 ) = LDE( AS, AA, LAA ) - ISAME( 8 ) = LDAS.EQ.LDA - ISAME( 9 ) = LDE( BS, BB, LBB ) - ISAME( 10 ) = LDBS.EQ.LDB - ISAME( 11 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 12 ) = LDE( CS, CC, LCC ) - ELSE - ISAME( 12 ) = LDERES( 'GE', ' ', M, N, CS, - $ CC, LDC ) - END IF - ISAME( 13 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report -* and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL DMMCH( TRANSA, TRANSB, M, N, K, - $ ALPHA, A, NMAX, B, NMAX, BETA, - $ C, NMAX, CT, G, CC, LDC, EPS, - $ ERR, FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 120 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K, - $ ALPHA, LDA, LDB, BETA, LDC -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',', - $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', - $ 'C,', I3, ').' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK1. -* - END - SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests DSYMM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX - INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC, - $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA, - $ NARGS, NC, NS - LOGICAL LEFT, NULL, RESET, SAME - CHARACTER*1 SIDE, SIDES, UPLO, UPLOS - CHARACTER*2 ICHS, ICHU -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DMAKE, DMMCH, DSYMM -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHS/'LR'/, ICHU/'UL'/ -* .. Executable Statements .. -* - NARGS = 12 - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 100 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 90 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = M - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 90 - LCC = LDC*N - NULL = N.LE.0.OR.M.LE.0 -* -* Set LDB to 1 more than minimum value if room. - LDB = M - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 90 - LBB = LDB*N -* -* Generate the matrix B. -* - CALL DMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET, - $ ZERO ) -* - DO 80 ICS = 1, 2 - SIDE = ICHS( ICS: ICS ) - LEFT = SIDE.EQ.'L' -* - IF( LEFT )THEN - NA = M - ELSE - NA = N - END IF -* Set LDA to 1 more than minimum value if room. - LDA = NA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* - DO 70 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* -* Generate the symmetric matrix A. -* - CALL DMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL DMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC, - $ LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - SIDES = SIDE - UPLOS = UPLO - MS = M - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - BLS = BETA - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE, - $ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL DSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, - $ BB, LDB, BETA, CC, LDC ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 110 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = SIDES.EQ.SIDE - ISAME( 2 ) = UPLOS.EQ.UPLO - ISAME( 3 ) = MS.EQ.M - ISAME( 4 ) = NS.EQ.N - ISAME( 5 ) = ALS.EQ.ALPHA - ISAME( 6 ) = LDE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - ISAME( 8 ) = LDE( BS, BB, LBB ) - ISAME( 9 ) = LDBS.EQ.LDB - ISAME( 10 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 11 ) = LDE( CS, CC, LCC ) - ELSE - ISAME( 11 ) = LDERES( 'GE', ' ', M, N, CS, - $ CC, LDC ) - END IF - ISAME( 12 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 110 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - IF( LEFT )THEN - CALL DMMCH( 'N', 'N', M, N, M, ALPHA, A, - $ NMAX, B, NMAX, BETA, C, NMAX, - $ CT, G, CC, LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL DMMCH( 'N', 'N', M, N, N, ALPHA, B, - $ NMAX, A, NMAX, BETA, C, NMAX, - $ CT, G, CC, LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 120 -* - 110 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA, - $ LDB, BETA, LDC -* - 120 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', - $ ' .' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK2. -* - END - SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS, - $ B, BB, BS, CT, G, C ) -* -* Tests DTRMM and DTRSM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER NALF, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CT( NMAX ), G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX - INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB, - $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC, - $ NS - LOGICAL LEFT, NULL, RESET, SAME - CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO, - $ UPLOS - CHARACTER*2 ICHD, ICHS, ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DMAKE, DMMCH, DTRMM, DTRSM -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/ -* .. Executable Statements .. -* - NARGS = 11 - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* Set up zero matrix for DMMCH. - DO 20 J = 1, NMAX - DO 10 I = 1, NMAX - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE -* - DO 140 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 130 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDB to 1 more than minimum value if room. - LDB = M - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 130 - LBB = LDB*N - NULL = M.LE.0.OR.N.LE.0 -* - DO 120 ICS = 1, 2 - SIDE = ICHS( ICS: ICS ) - LEFT = SIDE.EQ.'L' - IF( LEFT )THEN - NA = M - ELSE - NA = N - END IF -* Set LDA to 1 more than minimum value if room. - LDA = NA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 130 - LAA = LDA*NA -* - DO 110 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* - DO 100 ICT = 1, 3 - TRANSA = ICHT( ICT: ICT ) -* - DO 90 ICD = 1, 2 - DIAG = ICHD( ICD: ICD ) -* - DO 80 IA = 1, NALF - ALPHA = ALF( IA ) -* -* Generate the matrix A. -* - CALL DMAKE( 'TR', UPLO, DIAG, NA, NA, A, - $ NMAX, AA, LDA, RESET, ZERO ) -* -* Generate the matrix B. -* - CALL DMAKE( 'GE', ' ', ' ', M, N, B, NMAX, - $ BB, LDB, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - SIDES = SIDE - UPLOS = UPLO - TRANAS = TRANSA - DIAGS = DIAG - MS = M - NS = N - ALS = ALPHA - DO 30 I = 1, LAA - AS( I ) = AA( I ) - 30 CONTINUE - LDAS = LDA - DO 40 I = 1, LBB - BS( I ) = BB( I ) - 40 CONTINUE - LDBS = LDB -* -* Call the subroutine. -* - IF( SNAME( 4: 5 ).EQ.'MM' )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, - $ LDA, LDB - IF( REWI ) - $ REWIND NTRA - CALL DTRMM( SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, AA, LDA, BB, LDB ) - ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, - $ LDA, LDB - IF( REWI ) - $ REWIND NTRA - CALL DTRSM( SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, AA, LDA, BB, LDB ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 150 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = SIDES.EQ.SIDE - ISAME( 2 ) = UPLOS.EQ.UPLO - ISAME( 3 ) = TRANAS.EQ.TRANSA - ISAME( 4 ) = DIAGS.EQ.DIAG - ISAME( 5 ) = MS.EQ.M - ISAME( 6 ) = NS.EQ.N - ISAME( 7 ) = ALS.EQ.ALPHA - ISAME( 8 ) = LDE( AS, AA, LAA ) - ISAME( 9 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 10 ) = LDE( BS, BB, LBB ) - ELSE - ISAME( 10 ) = LDERES( 'GE', ' ', M, N, BS, - $ BB, LDB ) - END IF - ISAME( 11 ) = LDBS.EQ.LDB -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 50 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 50 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 150 - END IF -* - IF( .NOT.NULL )THEN - IF( SNAME( 4: 5 ).EQ.'MM' )THEN -* -* Check the result. -* - IF( LEFT )THEN - CALL DMMCH( TRANSA, 'N', M, N, M, - $ ALPHA, A, NMAX, B, NMAX, - $ ZERO, C, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL DMMCH( 'N', TRANSA, M, N, N, - $ ALPHA, B, NMAX, A, NMAX, - $ ZERO, C, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN -* -* Compute approximation to original -* matrix. -* - DO 70 J = 1, N - DO 60 I = 1, M - C( I, J ) = BB( I + ( J - 1 )* - $ LDB ) - BB( I + ( J - 1 )*LDB ) = ALPHA* - $ B( I, J ) - 60 CONTINUE - 70 CONTINUE -* - IF( LEFT )THEN - CALL DMMCH( TRANSA, 'N', M, N, M, - $ ONE, A, NMAX, C, NMAX, - $ ZERO, B, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .FALSE. ) - ELSE - CALL DMMCH( 'N', TRANSA, M, N, N, - $ ONE, C, NMAX, A, NMAX, - $ ZERO, B, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .FALSE. ) - END IF - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 150 - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* - 140 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 160 -* - 150 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, LDA, LDB -* - 160 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ), - $ F4.1, ', A,', I3, ', B,', I3, ') .' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK3. -* - END - SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests DSYRK. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, ALS, BETA, BETS, ERR, ERRMAX - INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS, - $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA, - $ NARGS, NC, NS - LOGICAL NULL, RESET, SAME, TRAN, UPPER - CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS - CHARACTER*2 ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DMAKE, DMMCH, DSYRK -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHT/'NTC'/, ICHU/'UL'/ -* .. Executable Statements .. -* - NARGS = 10 - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = N - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 100 - LCC = LDC*N - NULL = N.LE.0 -* - DO 90 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 80 ICT = 1, 3 - TRANS = ICHT( ICT: ICT ) - TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' - IF( TRAN )THEN - MA = K - NA = N - ELSE - MA = N - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* -* Generate the matrix A. -* - CALL DMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) -* - DO 70 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) - UPPER = UPLO.EQ.'U' -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL DMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC, - $ LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - BETS = BETA - DO 20 I = 1, LCC - CS( I ) = CC( I ) - 20 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, - $ TRANS, N, K, ALPHA, LDA, BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL DSYRK( UPLO, TRANS, N, K, ALPHA, AA, LDA, - $ BETA, CC, LDC ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLOS.EQ.UPLO - ISAME( 2 ) = TRANSS.EQ.TRANS - ISAME( 3 ) = NS.EQ.N - ISAME( 4 ) = KS.EQ.K - ISAME( 5 ) = ALS.EQ.ALPHA - ISAME( 6 ) = LDE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - ISAME( 8 ) = BETS.EQ.BETA - IF( NULL )THEN - ISAME( 9 ) = LDE( CS, CC, LCC ) - ELSE - ISAME( 9 ) = LDERES( 'SY', UPLO, N, N, CS, - $ CC, LDC ) - END IF - ISAME( 10 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 30 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 30 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - JC = 1 - DO 40 J = 1, N - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - IF( TRAN )THEN - CALL DMMCH( 'T', 'N', LJ, 1, K, ALPHA, - $ A( 1, JJ ), NMAX, - $ A( 1, J ), NMAX, BETA, - $ C( JJ, J ), NMAX, CT, G, - $ CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL DMMCH( 'N', 'T', LJ, 1, K, ALPHA, - $ A( JJ, 1 ), NMAX, - $ A( J, 1 ), NMAX, BETA, - $ C( JJ, J ), NMAX, CT, G, - $ CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - IF( UPPER )THEN - JC = JC + LDC - ELSE - JC = JC + LDC + 1 - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 110 - 40 CONTINUE - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 110 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9995 )J -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, - $ LDA, BETA, LDC -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK4. -* - END - SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) -* -* Tests DSYR2K. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), - $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), - $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ), - $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), - $ G( NMAX ), W( 2*NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, ALS, BETA, BETS, ERR, ERRMAX - INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, - $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, - $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS - LOGICAL NULL, RESET, SAME, TRAN, UPPER - CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS - CHARACTER*2 ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DMAKE, DMMCH, DSYR2K -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHT/'NTC'/, ICHU/'UL'/ -* .. Executable Statements .. -* - NARGS = 12 - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 130 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = N - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 130 - LCC = LDC*N - NULL = N.LE.0 -* - DO 120 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 110 ICT = 1, 3 - TRANS = ICHT( ICT: ICT ) - TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' - IF( TRAN )THEN - MA = K - NA = N - ELSE - MA = N - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 110 - LAA = LDA*NA -* -* Generate the matrix A. -* - IF( TRAN )THEN - CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA, - $ LDA, RESET, ZERO ) - ELSE - CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA, - $ RESET, ZERO ) - END IF -* -* Generate the matrix B. -* - LDB = LDA - LBB = LAA - IF( TRAN )THEN - CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ), - $ 2*NMAX, BB, LDB, RESET, ZERO ) - ELSE - CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ), - $ NMAX, BB, LDB, RESET, ZERO ) - END IF -* - DO 100 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) - UPPER = UPLO.EQ.'U' -* - DO 90 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 80 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL DMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC, - $ LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - BETS = BETA - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, - $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL DSYR2K( UPLO, TRANS, N, K, ALPHA, AA, LDA, - $ BB, LDB, BETA, CC, LDC ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 150 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLOS.EQ.UPLO - ISAME( 2 ) = TRANSS.EQ.TRANS - ISAME( 3 ) = NS.EQ.N - ISAME( 4 ) = KS.EQ.K - ISAME( 5 ) = ALS.EQ.ALPHA - ISAME( 6 ) = LDE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - ISAME( 8 ) = LDE( BS, BB, LBB ) - ISAME( 9 ) = LDBS.EQ.LDB - ISAME( 10 ) = BETS.EQ.BETA - IF( NULL )THEN - ISAME( 11 ) = LDE( CS, CC, LCC ) - ELSE - ISAME( 11 ) = LDERES( 'SY', UPLO, N, N, CS, - $ CC, LDC ) - END IF - ISAME( 12 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 150 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - JJAB = 1 - JC = 1 - DO 70 J = 1, N - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - IF( TRAN )THEN - DO 50 I = 1, K - W( I ) = AB( ( J - 1 )*2*NMAX + K + - $ I ) - W( K + I ) = AB( ( J - 1 )*2*NMAX + - $ I ) - 50 CONTINUE - CALL DMMCH( 'T', 'N', LJ, 1, 2*K, - $ ALPHA, AB( JJAB ), 2*NMAX, - $ W, 2*NMAX, BETA, - $ C( JJ, J ), NMAX, CT, G, - $ CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - DO 60 I = 1, K - W( I ) = AB( ( K + I - 1 )*NMAX + - $ J ) - W( K + I ) = AB( ( I - 1 )*NMAX + - $ J ) - 60 CONTINUE - CALL DMMCH( 'N', 'N', LJ, 1, 2*K, - $ ALPHA, AB( JJ ), NMAX, W, - $ 2*NMAX, BETA, C( JJ, J ), - $ NMAX, CT, G, CC( JC ), LDC, - $ EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - END IF - IF( UPPER )THEN - JC = JC + LDC - ELSE - JC = JC + LDC + 1 - IF( TRAN ) - $ JJAB = JJAB + 2*NMAX - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 140 - 70 CONTINUE - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 160 -* - 140 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9995 )J -* - 150 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, - $ LDA, LDB, BETA, LDC -* - 160 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', - $ ' .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK5. -* - END - SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) -* -* Tests the error exits from the Level 3 Blas. -* Requires a special version of the error-handling routine XERBLA. -* A, B and C should not need to be defined. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* 3-19-92: Initialize ALPHA and BETA (eca) -* 3-19-92: Fix argument 12 in calls to SSYMM with INFOT = 9 (eca) -* -* .. Scalar Arguments .. - INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Parameters .. - DOUBLE PRECISION ONE, TWO - PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, BETA -* .. Local Arrays .. - DOUBLE PRECISION A( 2, 1 ), B( 2, 1 ), C( 2, 1 ) -* .. External Subroutines .. - EXTERNAL CHKXER, DGEMM, DSYMM, DSYR2K, DSYRK, DTRMM, - $ DTRSM -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. -* OK is set to .FALSE. by the special version of XERBLA or by CHKXER -* if anything is wrong. - OK = .TRUE. -* LERR is set to .TRUE. by the special version of XERBLA each time -* it is called, and is then tested and re-set by CHKXER. - LERR = .FALSE. -* -* Initialize ALPHA and BETA. -* - ALPHA = ONE - BETA = TWO -* - GO TO ( 10, 20, 30, 40, 50, 60 )ISNUM - 10 INFOT = 1 - CALL DGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 1 - CALL DGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL DGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL DGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL DGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL DGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL DGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL DGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL DGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL DGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL DGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL DGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL DGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL DGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 - 20 INFOT = 1 - CALL DSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL DSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL DSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 - 30 INFOT = 1 - CALL DTRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DTRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DTRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DTRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 - 40 INFOT = 1 - CALL DTRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DTRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DTRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DTRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 - 50 INFOT = 1 - CALL DSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DSYRK( 'U', '/', 0, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL DSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL DSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL DSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL DSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 - 60 INFOT = 1 - CALL DSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DSYR2K( 'U', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL DSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL DSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* - 70 IF( OK )THEN - WRITE( NOUT, FMT = 9999 )SRNAMT - ELSE - WRITE( NOUT, FMT = 9998 )SRNAMT - END IF - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) - 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', - $ '**' ) -* -* End of DCHKE. -* - END - SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, - $ TRANSL ) -* -* Generates values for an M by N matrix A. -* Stores the values in the array AA in the data structure required -* by the routine, with unwanted elements set to rogue value. -* -* TYPE is 'GE', 'SY' or 'TR'. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - DOUBLE PRECISION ROGUE - PARAMETER ( ROGUE = -1.0D10 ) -* .. Scalar Arguments .. - DOUBLE PRECISION TRANSL - INTEGER LDA, M, N, NMAX - LOGICAL RESET - CHARACTER*1 DIAG, UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, * ), AA( * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J - LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER -* .. External Functions .. - DOUBLE PRECISION DBEG - EXTERNAL DBEG -* .. Executable Statements .. - GEN = TYPE.EQ.'GE' - SYM = TYPE.EQ.'SY' - TRI = TYPE.EQ.'TR' - UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' - LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' - UNIT = TRI.AND.DIAG.EQ.'U' -* -* Generate data in array A. -* - DO 20 J = 1, N - DO 10 I = 1, M - IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) - $ THEN - A( I, J ) = DBEG( RESET ) + TRANSL - IF( I.NE.J )THEN -* Set some elements to zero - IF( N.GT.3.AND.J.EQ.N/2 ) - $ A( I, J ) = ZERO - IF( SYM )THEN - A( J, I ) = A( I, J ) - ELSE IF( TRI )THEN - A( J, I ) = ZERO - END IF - END IF - END IF - 10 CONTINUE - IF( TRI ) - $ A( J, J ) = A( J, J ) + ONE - IF( UNIT ) - $ A( J, J ) = ONE - 20 CONTINUE -* -* Store elements in array AS in data structure required by routine. -* - IF( TYPE.EQ.'GE' )THEN - DO 50 J = 1, N - DO 30 I = 1, M - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 30 CONTINUE - DO 40 I = M + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 40 CONTINUE - 50 CONTINUE - ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN - DO 90 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IF( UNIT )THEN - IEND = J - 1 - ELSE - IEND = J - END IF - ELSE - IF( UNIT )THEN - IBEG = J + 1 - ELSE - IBEG = J - END IF - IEND = N - END IF - DO 60 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 60 CONTINUE - DO 70 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 70 CONTINUE - DO 80 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 80 CONTINUE - 90 CONTINUE - END IF - RETURN -* -* End of DMAKE. -* - END - SUBROUTINE DMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, - $ NOUT, MV ) -* -* Checks the results of the computational tests. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA, EPS, ERR - INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT - LOGICAL FATAL, MV - CHARACTER*1 TRANSA, TRANSB -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ CC( LDCC, * ), CT( * ), G( * ) -* .. Local Scalars .. - DOUBLE PRECISION ERRI - INTEGER I, J, K - LOGICAL TRANA, TRANB -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. Executable Statements .. - TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' - TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' -* -* Compute expected result, one column at a time, in CT using data -* in A, B and C. -* Compute gauges in G. -* - DO 120 J = 1, N -* - DO 10 I = 1, M - CT( I ) = ZERO - G( I ) = ZERO - 10 CONTINUE - IF( .NOT.TRANA.AND..NOT.TRANB )THEN - DO 30 K = 1, KK - DO 20 I = 1, M - CT( I ) = CT( I ) + A( I, K )*B( K, J ) - G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( K, J ) ) - 20 CONTINUE - 30 CONTINUE - ELSE IF( TRANA.AND..NOT.TRANB )THEN - DO 50 K = 1, KK - DO 40 I = 1, M - CT( I ) = CT( I ) + A( K, I )*B( K, J ) - G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( K, J ) ) - 40 CONTINUE - 50 CONTINUE - ELSE IF( .NOT.TRANA.AND.TRANB )THEN - DO 70 K = 1, KK - DO 60 I = 1, M - CT( I ) = CT( I ) + A( I, K )*B( J, K ) - G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( J, K ) ) - 60 CONTINUE - 70 CONTINUE - ELSE IF( TRANA.AND.TRANB )THEN - DO 90 K = 1, KK - DO 80 I = 1, M - CT( I ) = CT( I ) + A( K, I )*B( J, K ) - G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( J, K ) ) - 80 CONTINUE - 90 CONTINUE - END IF - DO 100 I = 1, M - CT( I ) = ALPHA*CT( I ) + BETA*C( I, J ) - G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( I, J ) ) - 100 CONTINUE -* -* Compute the error ratio for this result. -* - ERR = ZERO - DO 110 I = 1, M - ERRI = ABS( CT( I ) - CC( I, J ) )/EPS - IF( G( I ).NE.ZERO ) - $ ERRI = ERRI/G( I ) - ERR = MAX( ERR, ERRI ) - IF( ERR*SQRT( EPS ).GE.ONE ) - $ GO TO 130 - 110 CONTINUE -* - 120 CONTINUE -* -* If the loop completes, all results are at least half accurate. - GO TO 150 -* -* Report fatal error. -* - 130 FATAL = .TRUE. - WRITE( NOUT, FMT = 9999 ) - DO 140 I = 1, M - IF( MV )THEN - WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J ) - ELSE - WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I ) - END IF - 140 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9997 )J -* - 150 CONTINUE - RETURN -* - 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', - $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU', - $ 'TED RESULT' ) - 9998 FORMAT( 1X, I7, 2G18.6 ) - 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) -* -* End of DMMCH. -* - END - LOGICAL FUNCTION LDE( RI, RJ, LR ) -* -* Tests if two arrays are identical. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER LR -* .. Array Arguments .. - DOUBLE PRECISION RI( * ), RJ( * ) -* .. Local Scalars .. - INTEGER I -* .. Executable Statements .. - DO 10 I = 1, LR - IF( RI( I ).NE.RJ( I ) ) - $ GO TO 20 - 10 CONTINUE - LDE = .TRUE. - GO TO 30 - 20 CONTINUE - LDE = .FALSE. - 30 RETURN -* -* End of LDE. -* - END - LOGICAL FUNCTION LDERES( TYPE, UPLO, M, N, AA, AS, LDA ) -* -* Tests if selected elements in two arrays are equal. -* -* TYPE is 'GE' or 'SY'. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER LDA, M, N - CHARACTER*1 UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - DOUBLE PRECISION AA( LDA, * ), AS( LDA, * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J - LOGICAL UPPER -* .. Executable Statements .. - UPPER = UPLO.EQ.'U' - IF( TYPE.EQ.'GE' )THEN - DO 20 J = 1, N - DO 10 I = M + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 10 CONTINUE - 20 CONTINUE - ELSE IF( TYPE.EQ.'SY' )THEN - DO 50 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 30 I = 1, IBEG - 1 - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 30 CONTINUE - DO 40 I = IEND + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 40 CONTINUE - 50 CONTINUE - END IF -* - LDERES = .TRUE. - GO TO 80 - 70 CONTINUE - LDERES = .FALSE. - 80 RETURN -* -* End of LDERES. -* - END - DOUBLE PRECISION FUNCTION DBEG( RESET ) -* -* Generates random numbers uniformly distributed between -0.5 and 0.5. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - LOGICAL RESET -* .. Local Scalars .. - INTEGER I, IC, MI -* .. Save statement .. - SAVE I, IC, MI -* .. Executable Statements .. - IF( RESET )THEN -* Initialize local variables. - MI = 891 - I = 7 - IC = 0 - RESET = .FALSE. - END IF -* -* The sequence of values of I is bounded between 1 and 999. -* If initial I = 1,2,3,6,7 or 9, the period will be 50. -* If initial I = 4 or 8, the period will be 25. -* If initial I = 5, the period will be 10. -* IC is used to break up the period by skipping 1 value of I in 6. -* - IC = IC + 1 - 10 I = I*MI - I = I - 1000*( I/1000 ) - IF( IC.GE.5 )THEN - IC = 0 - GO TO 10 - END IF - DBEG = ( I - 500 )/1001.0D0 - RETURN -* -* End of DBEG. -* - END - DOUBLE PRECISION FUNCTION DDIFF( X, Y ) -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - DOUBLE PRECISION X, Y -* .. Executable Statements .. - DDIFF = X - Y - RETURN -* -* End of DDIFF. -* - END - SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* -* Tests whether XERBLA has detected an error when it should. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Executable Statements .. - IF( .NOT.LERR )THEN - WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT - OK = .FALSE. - END IF - LERR = .FALSE. - RETURN -* - 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', - $ 'ETECTED BY ', A6, ' *****' ) -* -* End of CHKXER. -* - END - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* This is a special version of XERBLA to be used only as part of -* the test program for testing error exits from the Level 3 BLAS -* routines. -* -* XERBLA is an error handler for the Level 3 BLAS routines. -* -* It is called by the Level 3 BLAS routines if an input parameter is -* invalid. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER INFO - CHARACTER*6 SRNAME -* .. Scalars in Common .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUT, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Executable Statements .. - LERR = .TRUE. - IF( INFO.NE.INFOT )THEN - IF( INFOT.NE.0 )THEN - WRITE( NOUT, FMT = 9999 )INFO, INFOT - ELSE - WRITE( NOUT, FMT = 9997 )INFO - END IF - OK = .FALSE. - END IF - IF( SRNAME.NE.SRNAMT )THEN - WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT - OK = .FALSE. - END IF - RETURN -* - 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', - $ ' OF ', I2, ' *******' ) - 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', - $ 'AD OF ', A6, ' *******' ) - 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, - $ ' *******' ) -* -* End of XERBLA -* - END - diff --git a/eigen/blas/testing/runblastest.sh b/eigen/blas/testing/runblastest.sh deleted file mode 100644 index 4ffaf01..0000000 --- a/eigen/blas/testing/runblastest.sh +++ /dev/null @@ -1,45 +0,0 @@ -#!/bin/bash - -black='\E[30m' -red='\E[31m' -green='\E[32m' -yellow='\E[33m' -blue='\E[34m' -magenta='\E[35m' -cyan='\E[36m' -white='\E[37m' - -if [ -f $2 ]; then - data=$2 - if [ -f $1.summ ]; then rm $1.summ; fi - if [ -f $1.snap ]; then rm $1.snap; fi -else - data=$1 -fi - -if ! ./$1 < $data > /dev/null 2> .runtest.log ; then - echo -e $red Test $1 failed: $black - echo -e $blue - cat .runtest.log - echo -e $black - exit 1 -else - if [ -f $1.summ ]; then - if [ `grep "FATAL ERROR" $1.summ | wc -l` -gt 0 ]; then - echo -e $red "Test $1 failed (FATAL ERROR, read the file $1.summ for details)" $black - echo -e $blue - cat .runtest.log - echo -e $black - exit 1; - fi - - if [ `grep "FAILED THE TESTS OF ERROR-EXITS" $1.summ | wc -l` -gt 0 ]; then - echo -e $red "Test $1 failed (FAILED THE TESTS OF ERROR-EXITS, read the file $1.summ for details)" $black - echo -e $blue - cat .runtest.log - echo -e $black - exit 1; - fi - fi - echo -e $green Test $1 passed$black -fi diff --git a/eigen/blas/testing/sblat1.f b/eigen/blas/testing/sblat1.f deleted file mode 100644 index 6657c26..0000000 --- a/eigen/blas/testing/sblat1.f +++ /dev/null @@ -1,1021 +0,0 @@ -*> \brief \b SBLAT1 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM SBLAT1 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the REAL 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 single_blas_testing -* -* ===================================================================== - PROGRAM SBLAT1 -* -* -- Reference BLAS test routine (version 3.4.1) -- -* -- 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 .. - REAL 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.765625E-4/ -* .. Executable Statements .. - WRITE (NOUT,99999) - DO 20 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.EQ.3 .OR. ICASE.EQ.11) THEN - CALL CHECK0(SFAC) - ELSE IF (ICASE.EQ.7 .OR. ICASE.EQ.8 .OR. ICASE.EQ.9 .OR. - + ICASE.EQ.10) THEN - CALL CHECK1(SFAC) - ELSE IF (ICASE.EQ.1 .OR. ICASE.EQ.2 .OR. ICASE.EQ.5 .OR. - + ICASE.EQ.6 .OR. ICASE.EQ.12 .OR. ICASE.EQ.13) THEN - CALL CHECK2(SFAC) - ELSE IF (ICASE.EQ.4) THEN - CALL CHECK3(SFAC) - END IF -* -- Print - IF (PASS) WRITE (NOUT,99998) - 20 CONTINUE - STOP -* -99999 FORMAT (' Real BLAS Test Program Results',/1X) -99998 FORMAT (' ----- PASS -----') - END - SUBROUTINE HEADER -* .. 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)/' SDOT '/ - DATA L(2)/'SAXPY '/ - DATA L(3)/'SROTG '/ - DATA L(4)/' SROT '/ - DATA L(5)/'SCOPY '/ - DATA L(6)/'SSWAP '/ - DATA L(7)/'SNRM2 '/ - DATA L(8)/'SASUM '/ - DATA L(9)/'SSCAL '/ - DATA L(10)/'ISAMAX'/ - DATA L(11)/'SROTMG'/ - DATA L(12)/'SROTM '/ - DATA L(13)/'SDSDOT'/ -* .. Executable Statements .. - WRITE (NOUT,99999) ICASE, L(ICASE) - RETURN -* -99999 FORMAT (/' Test of subprogram number',I3,12X,A6) - END - SUBROUTINE CHECK0(SFAC) -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalar Arguments .. - REAL SFAC -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, N - LOGICAL PASS -* .. Local Scalars .. - REAL D12, SA, SB, SC, SS - INTEGER I, K -* .. Local Arrays .. - REAL DA1(8), DATRUE(8), DB1(8), DBTRUE(8), DC1(8), - + DS1(8), DAB(4,9), DTEMP(9), DTRUE(9,9) -* .. External Subroutines .. - EXTERNAL SROTG, SROTMG, STEST1 -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, PASS -* .. Data statements .. - DATA DA1/0.3E0, 0.4E0, -0.3E0, -0.4E0, -0.3E0, 0.0E0, - + 0.0E0, 1.0E0/ - DATA DB1/0.4E0, 0.3E0, 0.4E0, 0.3E0, -0.4E0, 0.0E0, - + 1.0E0, 0.0E0/ - DATA DC1/0.6E0, 0.8E0, -0.6E0, 0.8E0, 0.6E0, 1.0E0, - + 0.0E0, 1.0E0/ - DATA DS1/0.8E0, 0.6E0, 0.8E0, -0.6E0, 0.8E0, 0.0E0, - + 1.0E0, 0.0E0/ - DATA DATRUE/0.5E0, 0.5E0, 0.5E0, -0.5E0, -0.5E0, - + 0.0E0, 1.0E0, 1.0E0/ - DATA DBTRUE/0.0E0, 0.6E0, 0.0E0, -0.6E0, 0.0E0, - + 0.0E0, 1.0E0, 0.0E0/ -* INPUT FOR MODIFIED GIVENS - DATA DAB/ .1E0,.3E0,1.2E0,.2E0, - A .7E0, .2E0, .6E0, 4.2E0, - B 0.E0,0.E0,0.E0,0.E0, - C 4.E0, -1.E0, 2.E0, 4.E0, - D 6.E-10, 2.E-2, 1.E5, 10.E0, - E 4.E10, 2.E-2, 1.E-5, 10.E0, - F 2.E-10, 4.E-2, 1.E5, 10.E0, - G 2.E10, 4.E-2, 1.E-5, 10.E0, - H 4.E0, -2.E0, 8.E0, 4.E0 / -* TRUE RESULTS FOR MODIFIED GIVENS - DATA DTRUE/0.E0,0.E0, 1.3E0, .2E0, 0.E0,0.E0,0.E0, .5E0, 0.E0, - A 0.E0,0.E0, 4.5E0, 4.2E0, 1.E0, .5E0, 0.E0,0.E0,0.E0, - B 0.E0,0.E0,0.E0,0.E0, -2.E0, 0.E0,0.E0,0.E0,0.E0, - C 0.E0,0.E0,0.E0, 4.E0, -1.E0, 0.E0,0.E0,0.E0,0.E0, - D 0.E0, 15.E-3, 0.E0, 10.E0, -1.E0, 0.E0, -1.E-4, - E 0.E0, 1.E0, - F 0.E0,0.E0, 6144.E-5, 10.E0, -1.E0, 4096.E0, -1.E6, - G 0.E0, 1.E0, - H 0.E0,0.E0,15.E0,10.E0,-1.E0, 5.E-5, 0.E0,1.E0,0.E0, - I 0.E0,0.E0, 15.E0, 10.E0, -1. E0, 5.E5, -4096.E0, - J 1.E0, 4096.E-6, - K 0.E0,0.E0, 7.E0, 4.E0, 0.E0,0.E0, -.5E0, -.25E0, 0.E0/ -* 4096 = 2 ** 12 - DATA D12 /4096.E0/ - DTRUE(1,1) = 12.E0 / 130.E0 - DTRUE(2,1) = 36.E0 / 130.E0 - DTRUE(7,1) = -1.E0 / 6.E0 - DTRUE(1,2) = 14.E0 / 75.E0 - DTRUE(2,2) = 49.E0 / 75.E0 - DTRUE(9,2) = 1.E0 / 7.E0 - DTRUE(1,5) = 45.E-11 * (D12 * D12) - DTRUE(3,5) = 4.E5 / (3.E0 * D12) - DTRUE(6,5) = 1.E0 / D12 - DTRUE(8,5) = 1.E4 / (3.E0 * D12) - DTRUE(1,6) = 4.E10 / (1.5E0 * D12 * D12) - DTRUE(2,6) = 2.E-2 / 1.5E0 - DTRUE(8,6) = 5.E-7 * D12 - DTRUE(1,7) = 4.E0 / 150.E0 - DTRUE(2,7) = (2.E-10 / 1.5E0) * (D12 * D12) - DTRUE(7,7) = -DTRUE(6,5) - DTRUE(9,7) = 1.E4 / D12 - DTRUE(1,8) = DTRUE(1,7) - DTRUE(2,8) = 2.E10 / (1.5E0 * D12 * D12) - DTRUE(1,9) = 32.E0 / 7.E0 - DTRUE(2,9) = -16.E0 / 7.E0 -* .. Executable Statements .. -* -* Compute true values which cannot be prestored -* in decimal notation -* - DBTRUE(1) = 1.0E0/0.6E0 - DBTRUE(3) = -1.0E0/0.6E0 - DBTRUE(5) = 1.0E0/0.6E0 -* - DO 20 K = 1, 8 -* .. Set N=K for identification in output if any .. - N = K - IF (ICASE.EQ.3) THEN -* .. SROTG .. - IF (K.GT.8) GO TO 40 - SA = DA1(K) - SB = DB1(K) - CALL SROTG(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.EQ.11) THEN -* .. SROTMG .. - DO I=1,4 - DTEMP(I)= DAB(I,K) - DTEMP(I+4) = 0.0 - END DO - DTEMP(9) = 0.0 - CALL SROTMG(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 - END IF - 20 CONTINUE - 40 RETURN - END - SUBROUTINE CHECK1(SFAC) -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalar Arguments .. - REAL SFAC -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, N - LOGICAL PASS -* .. Local Scalars .. - INTEGER I, LEN, NP1 -* .. Local Arrays .. - REAL DTRUE1(5), DTRUE3(5), DTRUE5(8,5,2), DV(8,5,2), - + SA(10), STEMP(1), STRUE(8), SX(8) - INTEGER ITRUE2(5) -* .. External Functions .. - REAL SASUM, SNRM2 - INTEGER ISAMAX - EXTERNAL SASUM, SNRM2, ISAMAX -* .. External Subroutines .. - EXTERNAL ITEST1, SSCAL, STEST, STEST1 -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, PASS -* .. Data statements .. - DATA SA/0.3E0, -1.0E0, 0.0E0, 1.0E0, 0.3E0, 0.3E0, - + 0.3E0, 0.3E0, 0.3E0, 0.3E0/ - DATA DV/0.1E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, - + 2.0E0, 2.0E0, 0.3E0, 3.0E0, 3.0E0, 3.0E0, 3.0E0, - + 3.0E0, 3.0E0, 3.0E0, 0.3E0, -0.4E0, 4.0E0, - + 4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0, 0.2E0, - + -0.6E0, 0.3E0, 5.0E0, 5.0E0, 5.0E0, 5.0E0, - + 5.0E0, 0.1E0, -0.3E0, 0.5E0, -0.1E0, 6.0E0, - + 6.0E0, 6.0E0, 6.0E0, 0.1E0, 8.0E0, 8.0E0, 8.0E0, - + 8.0E0, 8.0E0, 8.0E0, 8.0E0, 0.3E0, 9.0E0, 9.0E0, - + 9.0E0, 9.0E0, 9.0E0, 9.0E0, 9.0E0, 0.3E0, 2.0E0, - + -0.4E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, - + 0.2E0, 3.0E0, -0.6E0, 5.0E0, 0.3E0, 2.0E0, - + 2.0E0, 2.0E0, 0.1E0, 4.0E0, -0.3E0, 6.0E0, - + -0.5E0, 7.0E0, -0.1E0, 3.0E0/ - DATA DTRUE1/0.0E0, 0.3E0, 0.5E0, 0.7E0, 0.6E0/ - DATA DTRUE3/0.0E0, 0.3E0, 0.7E0, 1.1E0, 1.0E0/ - DATA DTRUE5/0.10E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, - + 2.0E0, 2.0E0, 2.0E0, -0.3E0, 3.0E0, 3.0E0, - + 3.0E0, 3.0E0, 3.0E0, 3.0E0, 3.0E0, 0.0E0, 0.0E0, - + 4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0, - + 0.20E0, -0.60E0, 0.30E0, 5.0E0, 5.0E0, 5.0E0, - + 5.0E0, 5.0E0, 0.03E0, -0.09E0, 0.15E0, -0.03E0, - + 6.0E0, 6.0E0, 6.0E0, 6.0E0, 0.10E0, 8.0E0, - + 8.0E0, 8.0E0, 8.0E0, 8.0E0, 8.0E0, 8.0E0, - + 0.09E0, 9.0E0, 9.0E0, 9.0E0, 9.0E0, 9.0E0, - + 9.0E0, 9.0E0, 0.09E0, 2.0E0, -0.12E0, 2.0E0, - + 2.0E0, 2.0E0, 2.0E0, 2.0E0, 0.06E0, 3.0E0, - + -0.18E0, 5.0E0, 0.09E0, 2.0E0, 2.0E0, 2.0E0, - + 0.03E0, 4.0E0, -0.09E0, 6.0E0, -0.15E0, 7.0E0, - + -0.03E0, 3.0E0/ - DATA ITRUE2/0, 1, 2, 2, 3/ -* .. Executable Statements .. - DO 80 INCX = 1, 2 - DO 60 NP1 = 1, 5 - N = NP1 - 1 - LEN = 2*MAX(N,1) -* .. Set vector arguments .. - DO 20 I = 1, LEN - SX(I) = DV(I,NP1,INCX) - 20 CONTINUE -* - IF (ICASE.EQ.7) THEN -* .. SNRM2 .. - STEMP(1) = DTRUE1(NP1) - CALL STEST1(SNRM2(N,SX,INCX),STEMP(1),STEMP,SFAC) - ELSE IF (ICASE.EQ.8) THEN -* .. SASUM .. - STEMP(1) = DTRUE3(NP1) - CALL STEST1(SASUM(N,SX,INCX),STEMP(1),STEMP,SFAC) - ELSE IF (ICASE.EQ.9) THEN -* .. SSCAL .. - CALL SSCAL(N,SA((INCX-1)*5+NP1),SX,INCX) - DO 40 I = 1, LEN - STRUE(I) = DTRUE5(I,NP1,INCX) - 40 CONTINUE - CALL STEST(LEN,SX,STRUE,STRUE,SFAC) - ELSE IF (ICASE.EQ.10) THEN -* .. ISAMAX .. - CALL ITEST1(ISAMAX(N,SX,INCX),ITRUE2(NP1)) - ELSE - WRITE (NOUT,*) ' Shouldn''t be here in CHECK1' - STOP - END IF - 60 CONTINUE - 80 CONTINUE - RETURN - END - SUBROUTINE CHECK2(SFAC) -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalar Arguments .. - REAL SFAC -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, N - LOGICAL PASS -* .. Local Scalars .. - REAL SA - INTEGER I, J, KI, KN, KNI, KPAR, KSIZE, LENX, LENY, - $ MX, MY -* .. Local Arrays .. - REAL DT10X(7,4,4), DT10Y(7,4,4), DT7(4,4), - $ DT8(7,4,4), DX1(7), - $ DY1(7), SSIZE1(4), SSIZE2(14,2), SSIZE3(4), - $ 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), - $ ST7B(4,4) - INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4) -* .. External Functions .. - REAL SDOT, SDSDOT - EXTERNAL SDOT, SDSDOT -* .. External Subroutines .. - EXTERNAL SAXPY, SCOPY, SROTM, SSWAP, STEST, STEST1 -* .. 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)),(DT19X(1,1,5), - A DT19XB(1,1,1)),(DT19X(1,1,9),DT19XC(1,1,1)), - B (DT19X(1,1,13),DT19XD(1,1,1)) - EQUIVALENCE (DT19Y(1,1,1),DT19YA(1,1,1)),(DT19Y(1,1,5), - A DT19YB(1,1,1)),(DT19Y(1,1,9),DT19YC(1,1,1)), - B (DT19Y(1,1,13),DT19YD(1,1,1)) - - DATA SA/0.3E0/ - 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.6E0, 0.1E0, -0.5E0, 0.8E0, 0.9E0, -0.3E0, - + -0.4E0/ - DATA DY1/0.5E0, -0.9E0, 0.3E0, 0.7E0, -0.6E0, 0.2E0, - + 0.8E0/ - DATA DT7/0.0E0, 0.30E0, 0.21E0, 0.62E0, 0.0E0, - + 0.30E0, -0.07E0, 0.85E0, 0.0E0, 0.30E0, -0.79E0, - + -0.74E0, 0.0E0, 0.30E0, 0.33E0, 1.27E0/ - DATA ST7B/ .1, .4, .31, .72, .1, .4, .03, .95, - + .1, .4, -.69, -.64, .1, .4, .43, 1.37/ - DATA DT8/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.68E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.68E0, -0.87E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.68E0, -0.87E0, 0.15E0, - + 0.94E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.68E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.35E0, -0.9E0, 0.48E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.38E0, -0.9E0, 0.57E0, 0.7E0, -0.75E0, - + 0.2E0, 0.98E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.68E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.35E0, -0.72E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.38E0, - + -0.63E0, 0.15E0, 0.88E0, 0.0E0, 0.0E0, 0.0E0, - + 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.68E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.68E0, -0.9E0, 0.33E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.68E0, -0.9E0, 0.33E0, 0.7E0, - + -0.75E0, 0.2E0, 1.04E0/ - DATA DT10X/0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.5E0, -0.9E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.5E0, -0.9E0, 0.3E0, 0.7E0, - + 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.3E0, 0.1E0, 0.5E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.8E0, 0.1E0, -0.6E0, - + 0.8E0, 0.3E0, -0.3E0, 0.5E0, 0.6E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.9E0, - + 0.1E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.7E0, - + 0.1E0, 0.3E0, 0.8E0, -0.9E0, -0.3E0, 0.5E0, - + 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.5E0, 0.3E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.5E0, 0.3E0, -0.6E0, 0.8E0, 0.0E0, 0.0E0, - + 0.0E0/ - DATA DT10Y/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.6E0, 0.1E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.0E0, - + 0.0E0, 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, -0.5E0, -0.9E0, 0.6E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, -0.4E0, -0.9E0, 0.9E0, - + 0.7E0, -0.5E0, 0.2E0, 0.6E0, 0.5E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.5E0, - + 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + -0.4E0, 0.9E0, -0.5E0, 0.6E0, 0.0E0, 0.0E0, - + 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.6E0, -0.9E0, 0.1E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.6E0, -0.9E0, 0.1E0, 0.7E0, - + -0.5E0, 0.2E0, 0.8E0/ - DATA SSIZE1/0.0E0, 0.3E0, 1.6E0, 3.2E0/ - DATA SSIZE2/0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, - + 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, - + 1.17E0, 1.17E0, 1.17E0/ - DATA SSIZE3/ .1, .4, 1.7, 3.3 / -* -* FOR DROTM -* - DATA DPAR/-2.E0, 0.E0,0.E0,0.E0,0.E0, - A -1.E0, 2.E0, -3.E0, -4.E0, 5.E0, - B 0.E0, 0.E0, 2.E0, -3.E0, 0.E0, - C 1.E0, 5.E0, 2.E0, 0.E0, -4.E0/ -* TRUE X RESULTS F0R ROTATIONS DROTM - DATA DT19XA/.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - A .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - B .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - C .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - D .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - E -.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - F -.9E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - G 3.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - H .6E0, .1E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - I -.8E0, 3.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - J -.9E0, 2.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - K 3.5E0, -.4E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - L .6E0, .1E0, -.5E0, .8E0, 0.E0,0.E0,0.E0, - M -.8E0, 3.8E0, -2.2E0, -1.2E0, 0.E0,0.E0,0.E0, - N -.9E0, 2.8E0, -1.4E0, -1.3E0, 0.E0,0.E0,0.E0, - O 3.5E0, -.4E0, -2.2E0, 4.7E0, 0.E0,0.E0,0.E0/ -* - DATA DT19XB/.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - A .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - B .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - C .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - D .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - E -.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - F -.9E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - G 3.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - H .6E0, .1E0, -.5E0, 0.E0,0.E0,0.E0,0.E0, - I 0.E0, .1E0, -3.0E0, 0.E0,0.E0,0.E0,0.E0, - J -.3E0, .1E0, -2.0E0, 0.E0,0.E0,0.E0,0.E0, - K 3.3E0, .1E0, -2.0E0, 0.E0,0.E0,0.E0,0.E0, - L .6E0, .1E0, -.5E0, .8E0, .9E0, -.3E0, -.4E0, - M -2.0E0, .1E0, 1.4E0, .8E0, .6E0, -.3E0, -2.8E0, - N -1.8E0, .1E0, 1.3E0, .8E0, 0.E0, -.3E0, -1.9E0, - O 3.8E0, .1E0, -3.1E0, .8E0, 4.8E0, -.3E0, -1.5E0 / -* - DATA DT19XC/.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - A .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - B .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - C .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - D .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - E -.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - F -.9E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - G 3.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - H .6E0, .1E0, -.5E0, 0.E0,0.E0,0.E0,0.E0, - I 4.8E0, .1E0, -3.0E0, 0.E0,0.E0,0.E0,0.E0, - J 3.3E0, .1E0, -2.0E0, 0.E0,0.E0,0.E0,0.E0, - K 2.1E0, .1E0, -2.0E0, 0.E0,0.E0,0.E0,0.E0, - L .6E0, .1E0, -.5E0, .8E0, .9E0, -.3E0, -.4E0, - M -1.6E0, .1E0, -2.2E0, .8E0, 5.4E0, -.3E0, -2.8E0, - N -1.5E0, .1E0, -1.4E0, .8E0, 3.6E0, -.3E0, -1.9E0, - O 3.7E0, .1E0, -2.2E0, .8E0, 3.6E0, -.3E0, -1.5E0 / -* - DATA DT19XD/.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - A .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - B .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - C .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - D .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - E -.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - F -.9E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - G 3.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - H .6E0, .1E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - I -.8E0, -1.0E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - J -.9E0, -.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - K 3.5E0, .8E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - L .6E0, .1E0, -.5E0, .8E0, 0.E0,0.E0,0.E0, - M -.8E0, -1.0E0, 1.4E0, -1.6E0, 0.E0,0.E0,0.E0, - N -.9E0, -.8E0, 1.3E0, -1.6E0, 0.E0,0.E0,0.E0, - O 3.5E0, .8E0, -3.1E0, 4.8E0, 0.E0,0.E0,0.E0/ -* TRUE Y RESULTS FOR ROTATIONS DROTM - DATA DT19YA/.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - A .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - B .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - C .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - D .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - E .7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - F 1.7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - G -2.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - H .5E0, -.9E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - I .7E0, -4.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - J 1.7E0, -.7E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - K -2.6E0, 3.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - L .5E0, -.9E0, .3E0, .7E0, 0.E0,0.E0,0.E0, - M .7E0, -4.8E0, 3.0E0, 1.1E0, 0.E0,0.E0,0.E0, - N 1.7E0, -.7E0, -.7E0, 2.3E0, 0.E0,0.E0,0.E0, - O -2.6E0, 3.5E0, -.7E0, -3.6E0, 0.E0,0.E0,0.E0/ -* - DATA DT19YB/.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - A .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - B .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - C .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - D .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - E .7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - F 1.7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - G -2.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - H .5E0, -.9E0, .3E0, 0.E0,0.E0,0.E0,0.E0, - I 4.0E0, -.9E0, -.3E0, 0.E0,0.E0,0.E0,0.E0, - J -.5E0, -.9E0, 1.5E0, 0.E0,0.E0,0.E0,0.E0, - K -1.5E0, -.9E0, -1.8E0, 0.E0,0.E0,0.E0,0.E0, - L .5E0, -.9E0, .3E0, .7E0, -.6E0, .2E0, .8E0, - M 3.7E0, -.9E0, -1.2E0, .7E0, -1.5E0, .2E0, 2.2E0, - N -.3E0, -.9E0, 2.1E0, .7E0, -1.6E0, .2E0, 2.0E0, - O -1.6E0, -.9E0, -2.1E0, .7E0, 2.9E0, .2E0, -3.8E0 / -* - DATA DT19YC/.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - A .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - B .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - C .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - D .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - E .7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - F 1.7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - G -2.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - H .5E0, -.9E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - I 4.0E0, -6.3E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - J -.5E0, .3E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - K -1.5E0, 3.0E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - L .5E0, -.9E0, .3E0, .7E0, 0.E0,0.E0,0.E0, - M 3.7E0, -7.2E0, 3.0E0, 1.7E0, 0.E0,0.E0,0.E0, - N -.3E0, .9E0, -.7E0, 1.9E0, 0.E0,0.E0,0.E0, - O -1.6E0, 2.7E0, -.7E0, -3.4E0, 0.E0,0.E0,0.E0/ -* - DATA DT19YD/.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - A .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - B .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - C .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - D .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - E .7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - F 1.7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - G -2.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - H .5E0, -.9E0, .3E0, 0.E0,0.E0,0.E0,0.E0, - I .7E0, -.9E0, 1.2E0, 0.E0,0.E0,0.E0,0.E0, - J 1.7E0, -.9E0, .5E0, 0.E0,0.E0,0.E0,0.E0, - K -2.6E0, -.9E0, -1.3E0, 0.E0,0.E0,0.E0,0.E0, - L .5E0, -.9E0, .3E0, .7E0, -.6E0, .2E0, .8E0, - M .7E0, -.9E0, 1.2E0, .7E0, -1.5E0, .2E0, 1.6E0, - N 1.7E0, -.9E0, .5E0, .7E0, -1.6E0, .2E0, 2.4E0, - O -2.6E0, -.9E0, -1.3E0, .7E0, 2.9E0, .2E0, -4.0E0 / -* -* .. Executable Statements .. -* - DO 120 KI = 1, 4 - INCX = INCXS(KI) - INCY = INCYS(KI) - MX = ABS(INCX) - MY = ABS(INCY) -* - DO 100 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 - SX(I) = DX1(I) - SY(I) = DY1(I) - 20 CONTINUE -* - IF (ICASE.EQ.1) THEN -* .. SDOT .. - CALL STEST1(SDOT(N,SX,INCX,SY,INCY),DT7(KN,KI),SSIZE1(KN) - + ,SFAC) - ELSE IF (ICASE.EQ.2) THEN -* .. SAXPY .. - CALL SAXPY(N,SA,SX,INCX,SY,INCY) - DO 40 J = 1, LENY - STY(J) = DT8(J,KN,KI) - 40 CONTINUE - CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC) - ELSE IF (ICASE.EQ.5) THEN -* .. SCOPY .. - DO 60 I = 1, 7 - STY(I) = DT10Y(I,KN,KI) - 60 CONTINUE - CALL SCOPY(N,SX,INCX,SY,INCY) - CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0E0) - ELSE IF (ICASE.EQ.6) THEN -* .. SSWAP .. - CALL SSWAP(N,SX,INCX,SY,INCY) - DO 80 I = 1, 7 - STX(I) = DT10X(I,KN,KI) - STY(I) = DT10Y(I,KN,KI) - 80 CONTINUE - CALL STEST(LENX,SX,STX,SSIZE2(1,1),1.0E0) - CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0E0) - ELSEIF (ICASE.EQ.12) THEN -* .. SROTM .. - 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) - END DO -* - DO I=1,5 - DTEMP(I) = DPAR(I,KPAR) - END DO -* - DO I=1,LENX - SSIZE(I)=STX(I) - END DO -* SEE REMARK ABOVE ABOUT DT11X(1,2,7) -* AND DT11X(5,3,8). - IF ((KPAR .EQ. 2) .AND. (KNI .EQ. 7)) - $ SSIZE(1) = 2.4E0 - IF ((KPAR .EQ. 3) .AND. (KNI .EQ. 8)) - $ SSIZE(5) = 1.8E0 -* - CALL SROTM(N,SX,INCX,SY,INCY,DTEMP) - CALL STEST(LENX,SX,STX,SSIZE,SFAC) - CALL STEST(LENY,SY,STY,STY,SFAC) - END DO - ELSEIF (ICASE.EQ.13) THEN -* .. SDSROT .. - CALL STEST1 (SDSDOT(N,.1,SX,INCX,SY,INCY), - $ ST7B(KN,KI),SSIZE3(KN),SFAC) - ELSE - WRITE (NOUT,*) ' Shouldn''t be here in CHECK2' - STOP - END IF - 100 CONTINUE - 120 CONTINUE - RETURN - END - SUBROUTINE CHECK3(SFAC) -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalar Arguments .. - REAL SFAC -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, N - LOGICAL PASS -* .. Local Scalars .. - REAL SC, SS - INTEGER I, K, KI, KN, KSIZE, LENX, LENY, MX, MY -* .. Local Arrays .. - REAL 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 SROT, 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.6E0, 0.1E0, -0.5E0, 0.8E0, 0.9E0, -0.3E0, - + -0.4E0/ - DATA DY1/0.5E0, -0.9E0, 0.3E0, 0.7E0, -0.6E0, 0.2E0, - + 0.8E0/ - DATA SC, SS/0.8E0, 0.6E0/ - DATA DT9X/0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.78E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.78E0, -0.46E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.78E0, -0.46E0, -0.22E0, - + 1.06E0, 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.78E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.66E0, 0.1E0, -0.1E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.96E0, 0.1E0, -0.76E0, 0.8E0, 0.90E0, - + -0.3E0, -0.02E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.78E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.06E0, 0.1E0, - + -0.1E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.90E0, - + 0.1E0, -0.22E0, 0.8E0, 0.18E0, -0.3E0, -0.02E0, - + 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.78E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.78E0, 0.26E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.78E0, 0.26E0, -0.76E0, 1.12E0, - + 0.0E0, 0.0E0, 0.0E0/ - DATA DT9Y/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.04E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.04E0, -0.78E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.04E0, -0.78E0, 0.54E0, - + 0.08E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.04E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.7E0, - + -0.9E0, -0.12E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.64E0, -0.9E0, -0.30E0, 0.7E0, -0.18E0, 0.2E0, - + 0.28E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.04E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.7E0, -1.08E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.64E0, -1.26E0, - + 0.54E0, 0.20E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.04E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.04E0, -0.9E0, 0.18E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.04E0, -0.9E0, 0.18E0, 0.7E0, - + -0.18E0, 0.2E0, 0.16E0/ - DATA SSIZE2/0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, - + 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, - + 1.17E0, 1.17E0, 1.17E0/ -* .. 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) -* - IF (ICASE.EQ.4) THEN -* .. SROT .. - DO 20 I = 1, 7 - SX(I) = DX1(I) - SY(I) = DY1(I) - STX(I) = DT9X(I,KN,KI) - STY(I) = DT9Y(I,KN,KI) - 20 CONTINUE - CALL SROT(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 - END IF - 40 CONTINUE - 60 CONTINUE -* - MWPC(1) = 1 - DO 80 I = 2, 11 - MWPC(I) = 0 - 80 CONTINUE - MWPS(1) = 0 - DO 100 I = 2, 6 - MWPS(I) = 1 - 100 CONTINUE - DO 120 I = 7, 11 - MWPS(I) = -1 - 120 CONTINUE - 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 140 I = 1, 11 - MWPN(I) = 5 - 140 CONTINUE - MWPN(5) = 3 - MWPN(10) = 3 - DO 160 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 - 160 CONTINUE - 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 200 I = 1, 11 - INCX = MWPINX(I) - INCY = MWPINY(I) - DO 180 K = 1, 5 - COPYX(K) = MWPX(K) - COPYY(K) = MWPY(K) - MWPSTX(K) = MWPTX(I,K) - MWPSTY(K) = MWPTY(I,K) - 180 CONTINUE - CALL SROT(MWPN(I),COPYX,INCX,COPYY,INCY,MWPC(I),MWPS(I)) - CALL STEST(5,COPYX,MWPSTX,MWPSTX,SFAC) - CALL STEST(5,COPYY,MWPSTY,MWPSTY,SFAC) - 200 CONTINUE - RETURN - 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 - REAL ZERO - PARAMETER (NOUT=6, ZERO=0.0E0) -* .. Scalar Arguments .. - REAL SFAC - INTEGER LEN -* .. Array Arguments .. - REAL SCOMP(LEN), SSIZE(LEN), STRUE(LEN) -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, N - LOGICAL PASS -* .. Local Scalars .. - REAL SD - INTEGER I -* .. External Functions .. - REAL SDIFF - EXTERNAL SDIFF -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, 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, I, SCOMP(I), - + STRUE(I), SD, SSIZE(I) - 40 CONTINUE - RETURN -* -99999 FORMAT (' FAIL') -99998 FORMAT (/' CASE N INCX INCY I ', - + ' COMP(I) TRUE(I) DIFFERENCE', - + ' SIZE(I)',/1X) -99997 FORMAT (1X,I4,I3,2I5,I3,2E36.8,2E12.4) - END - SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC) -* ************************* STEST1 ***************************** -* -* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE 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 .. - REAL SCOMP1, SFAC, STRUE1 -* .. Array Arguments .. - REAL SSIZE(*) -* .. Local Arrays .. - REAL 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 - REAL FUNCTION SDIFF(SA,SB) -* ********************************* SDIFF ************************** -* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 -* -* .. Scalar Arguments .. - REAL SA, SB -* .. Executable Statements .. - SDIFF = SA - SB - RETURN - 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, N - LOGICAL PASS -* .. Local Scalars .. - INTEGER ID -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, 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, ICOMP, ITRUE, ID - 40 CONTINUE - RETURN -* -99999 FORMAT (' FAIL') -99998 FORMAT (/' CASE N INCX INCY ', - + ' COMP TRUE DIFFERENCE', - + /1X) -99997 FORMAT (1X,I4,I3,2I5,2I36,I12) - END diff --git a/eigen/blas/testing/sblat2.dat b/eigen/blas/testing/sblat2.dat deleted file mode 100644 index f537d30..0000000 --- a/eigen/blas/testing/sblat2.dat +++ /dev/null @@ -1,34 +0,0 @@ -'sblat2.summ' NAME OF SUMMARY OUTPUT FILE -6 UNIT NUMBER OF SUMMARY FILE -'sblat2.snap' NAME OF SNAPSHOT OUTPUT FILE --1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -F LOGICAL FLAG, T TO STOP ON FAILURES. -T LOGICAL FLAG, T TO TEST ERROR EXITS. -16.0 THRESHOLD VALUE OF TEST RATIO -6 NUMBER OF VALUES OF N -0 1 2 3 5 9 VALUES OF N -4 NUMBER OF VALUES OF K -0 1 2 4 VALUES OF K -4 NUMBER OF VALUES OF INCX AND INCY -1 2 -1 -2 VALUES OF INCX AND INCY -3 NUMBER OF VALUES OF ALPHA -0.0 1.0 0.7 VALUES OF ALPHA -3 NUMBER OF VALUES OF BETA -0.0 1.0 0.9 VALUES OF BETA -SGEMV T PUT F FOR NO TEST. SAME COLUMNS. -SGBMV T PUT F FOR NO TEST. SAME COLUMNS. -SSYMV T PUT F FOR NO TEST. SAME COLUMNS. -SSBMV T PUT F FOR NO TEST. SAME COLUMNS. -SSPMV T PUT F FOR NO TEST. SAME COLUMNS. -STRMV T PUT F FOR NO TEST. SAME COLUMNS. -STBMV T PUT F FOR NO TEST. SAME COLUMNS. -STPMV T PUT F FOR NO TEST. SAME COLUMNS. -STRSV T PUT F FOR NO TEST. SAME COLUMNS. -STBSV T PUT F FOR NO TEST. SAME COLUMNS. -STPSV T PUT F FOR NO TEST. SAME COLUMNS. -SGER T PUT F FOR NO TEST. SAME COLUMNS. -SSYR T PUT F FOR NO TEST. SAME COLUMNS. -SSPR T PUT F FOR NO TEST. SAME COLUMNS. -SSYR2 T PUT F FOR NO TEST. SAME COLUMNS. -SSPR2 T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/eigen/blas/testing/sblat2.f b/eigen/blas/testing/sblat2.f deleted file mode 100644 index 71605ed..0000000 --- a/eigen/blas/testing/sblat2.f +++ /dev/null @@ -1,3176 +0,0 @@ -*> \brief \b SBLAT2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM SBLAT2 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the REAL Level 2 Blas. -*> -*> The program must be driven by a short data file. The first 18 records -*> of the file are read using list-directed input, the last 16 records -*> are read using the format ( A6, L2 ). An annotated example of a data -*> file can be obtained by deleting the first 3 characters from the -*> following 34 lines: -*> 'sblat2.out' NAME OF SUMMARY OUTPUT FILE -*> 6 UNIT NUMBER OF SUMMARY FILE -*> 'SBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE -*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -*> F LOGICAL FLAG, T TO STOP ON FAILURES. -*> T LOGICAL FLAG, T TO TEST ERROR EXITS. -*> 16.0 THRESHOLD VALUE OF TEST RATIO -*> 6 NUMBER OF VALUES OF N -*> 0 1 2 3 5 9 VALUES OF N -*> 4 NUMBER OF VALUES OF K -*> 0 1 2 4 VALUES OF K -*> 4 NUMBER OF VALUES OF INCX AND INCY -*> 1 2 -1 -2 VALUES OF INCX AND INCY -*> 3 NUMBER OF VALUES OF ALPHA -*> 0.0 1.0 0.7 VALUES OF ALPHA -*> 3 NUMBER OF VALUES OF BETA -*> 0.0 1.0 0.9 VALUES OF BETA -*> SGEMV T PUT F FOR NO TEST. SAME COLUMNS. -*> SGBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> SSYMV T PUT F FOR NO TEST. SAME COLUMNS. -*> SSBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> SSPMV T PUT F FOR NO TEST. SAME COLUMNS. -*> STRMV T PUT F FOR NO TEST. SAME COLUMNS. -*> STBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> STPMV T PUT F FOR NO TEST. SAME COLUMNS. -*> STRSV T PUT F FOR NO TEST. SAME COLUMNS. -*> STBSV T PUT F FOR NO TEST. SAME COLUMNS. -*> STPSV T PUT F FOR NO TEST. SAME COLUMNS. -*> SGER T PUT F FOR NO TEST. SAME COLUMNS. -*> SSYR T PUT F FOR NO TEST. SAME COLUMNS. -*> SSPR T PUT F FOR NO TEST. SAME COLUMNS. -*> SSYR2 T PUT F FOR NO TEST. SAME COLUMNS. -*> SSPR2 T PUT F FOR NO TEST. SAME COLUMNS. -*> -*> Further Details -*> =============== -*> -*> See: -*> -*> Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. -*> An extended set of Fortran Basic Linear Algebra Subprograms. -*> -*> Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics -*> and Computer Science Division, Argonne National Laboratory, -*> 9700 South Cass Avenue, Argonne, Illinois 60439, US. -*> -*> Or -*> -*> NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms -*> Group Ltd., NAG Central Office, 256 Banbury Road, Oxford -*> OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st -*> Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. -*> -*> -*> -- Written on 10-August-1987. -*> Richard Hanson, Sandia National Labs. -*> Jeremy Du Croz, NAG Central Office. -*> -*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers -*> can be run multiple times without deleting generated -*> output files (susan) -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date April 2012 -* -*> \ingroup single_blas_testing -* -* ===================================================================== - PROGRAM SBLAT2 -* -* -- Reference BLAS test routine (version 3.4.1) -- -* -- 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 NIN - PARAMETER ( NIN = 5 ) - INTEGER NSUBS - PARAMETER ( NSUBS = 16 ) - REAL ZERO, ONE - PARAMETER ( ZERO = 0.0, ONE = 1.0 ) - INTEGER NMAX, INCMAX - PARAMETER ( NMAX = 65, INCMAX = 2 ) - INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX - PARAMETER ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7, - $ NALMAX = 7, NBEMAX = 7 ) -* .. Local Scalars .. - REAL EPS, ERR, THRESH - INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB, - $ NOUT, NTRA - LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, - $ TSTERR - CHARACTER*1 TRANS - CHARACTER*6 SNAMET - CHARACTER*32 SNAPS, SUMMRY -* .. Local Arrays .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), - $ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ), - $ G( NMAX ), X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( 2*NMAX ) - INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX ) - LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) -* .. External Functions .. - REAL SDIFF - LOGICAL LSE - EXTERNAL SDIFF, LSE -* .. External Subroutines .. - EXTERNAL SCHK1, SCHK2, SCHK3, SCHK4, SCHK5, SCHK6, - $ SCHKE, SMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Data statements .. - DATA SNAMES/'SGEMV ', 'SGBMV ', 'SSYMV ', 'SSBMV ', - $ 'SSPMV ', 'STRMV ', 'STBMV ', 'STPMV ', - $ 'STRSV ', 'STBSV ', 'STPSV ', 'SGER ', - $ 'SSYR ', 'SSPR ', 'SSYR2 ', 'SSPR2 '/ -* .. Executable Statements .. -* -* Read name and unit number for summary output file and open file. -* - READ( NIN, FMT = * )SUMMRY - READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) - NOUTC = NOUT -* -* Read name and unit number for snapshot output file and open file. -* - READ( NIN, FMT = * )SNAPS - READ( NIN, FMT = * )NTRA - TRACE = NTRA.GE.0 - IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' ) - END IF -* Read the flag that directs rewinding of the snapshot file. - READ( NIN, FMT = * )REWI - REWI = REWI.AND.TRACE -* Read the flag that directs stopping on any failure. - READ( NIN, FMT = * )SFATAL -* Read the flag that indicates whether error exits are to be tested. - READ( NIN, FMT = * )TSTERR -* Read the threshold value of the test ratio - READ( NIN, FMT = * )THRESH -* -* Read and check the parameter values for the tests. -* -* Values of N - READ( NIN, FMT = * )NIDIM - IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN - WRITE( NOUT, FMT = 9997 )'N', NIDMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) - DO 10 I = 1, NIDIM - IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN - WRITE( NOUT, FMT = 9996 )NMAX - GO TO 230 - END IF - 10 CONTINUE -* Values of K - READ( NIN, FMT = * )NKB - IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN - WRITE( NOUT, FMT = 9997 )'K', NKBMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( KB( I ), I = 1, NKB ) - DO 20 I = 1, NKB - IF( KB( I ).LT.0 )THEN - WRITE( NOUT, FMT = 9995 ) - GO TO 230 - END IF - 20 CONTINUE -* Values of INCX and INCY - READ( NIN, FMT = * )NINC - IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN - WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( INC( I ), I = 1, NINC ) - DO 30 I = 1, NINC - IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN - WRITE( NOUT, FMT = 9994 )INCMAX - GO TO 230 - END IF - 30 CONTINUE -* Values of ALPHA - READ( NIN, FMT = * )NALF - IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN - WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) -* Values of BETA - READ( NIN, FMT = * )NBET - IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN - WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) -* -* Report values of parameters. -* - WRITE( NOUT, FMT = 9993 ) - WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM ) - WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB ) - WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC ) - WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF ) - WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET ) - IF( .NOT.TSTERR )THEN - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9980 ) - END IF - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9999 )THRESH - WRITE( NOUT, FMT = * ) -* -* Read names of subroutines and flags which indicate -* whether they are to be tested. -* - DO 40 I = 1, NSUBS - LTEST( I ) = .FALSE. - 40 CONTINUE - 50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT - DO 60 I = 1, NSUBS - IF( SNAMET.EQ.SNAMES( I ) ) - $ GO TO 70 - 60 CONTINUE - WRITE( NOUT, FMT = 9986 )SNAMET - STOP - 70 LTEST( I ) = LTESTT - GO TO 50 -* - 80 CONTINUE - CLOSE ( NIN ) -* -* Compute EPS (the machine precision). -* - EPS = EPSILON(ZERO) - WRITE( NOUT, FMT = 9998 )EPS -* -* Check the reliability of SMVCH using exact data. -* - N = MIN( 32, NMAX ) - DO 120 J = 1, N - DO 110 I = 1, N - A( I, J ) = MAX( I - J + 1, 0 ) - 110 CONTINUE - X( J ) = J - Y( J ) = ZERO - 120 CONTINUE - DO 130 J = 1, N - YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 - 130 CONTINUE -* YY holds the exact result. On exit from SMVCH YT holds -* the result computed by SMVCH. - TRANS = 'N' - CALL SMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LSE( YY, YT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR - STOP - END IF - TRANS = 'T' - CALL SMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LSE( YY, YT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR - STOP - END IF -* -* Test each subroutine in turn. -* - DO 210 ISNUM = 1, NSUBS - WRITE( NOUT, FMT = * ) - IF( .NOT.LTEST( ISNUM ) )THEN -* Subprogram is not to be tested. - WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM ) - ELSE - SRNAMT = SNAMES( ISNUM ) -* Test error exits. - IF( TSTERR )THEN - CALL SCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) - WRITE( NOUT, FMT = * ) - END IF -* Test computations. - INFOT = 0 - OK = .TRUE. - FATAL = .FALSE. - GO TO ( 140, 140, 150, 150, 150, 160, 160, - $ 160, 160, 160, 160, 170, 180, 180, - $ 190, 190 )ISNUM -* Test SGEMV, 01, and SGBMV, 02. - 140 CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, - $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, - $ X, XX, XS, Y, YY, YS, YT, G ) - GO TO 200 -* Test SSYMV, 03, SSBMV, 04, and SSPMV, 05. - 150 CALL SCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, - $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, - $ X, XX, XS, Y, YY, YS, YT, G ) - GO TO 200 -* Test STRMV, 06, STBMV, 07, STPMV, 08, -* STRSV, 09, STBSV, 10, and STPSV, 11. - 160 CALL SCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z ) - GO TO 200 -* Test SGER, 12. - 170 CALL SCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) - GO TO 200 -* Test SSYR, 13, and SSPR, 14. - 180 CALL SCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) - GO TO 200 -* Test SSYR2, 15, and SSPR2, 16. - 190 CALL SCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) -* - 200 IF( FATAL.AND.SFATAL ) - $ GO TO 220 - END IF - 210 CONTINUE - WRITE( NOUT, FMT = 9982 ) - GO TO 240 -* - 220 CONTINUE - WRITE( NOUT, FMT = 9981 ) - GO TO 240 -* - 230 CONTINUE - WRITE( NOUT, FMT = 9987 ) -* - 240 CONTINUE - IF( TRACE ) - $ CLOSE ( NTRA ) - CLOSE ( NOUT ) - STOP -* - 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', - $ 'S THAN', F8.2 ) - 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 ) - 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', - $ 'THAN ', I2 ) - 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) - 9995 FORMAT( ' VALUE OF K IS LESS THAN 0' ) - 9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ', - $ I2 ) - 9993 FORMAT( ' TESTS OF THE REAL LEVEL 2 BLAS', //' THE F', - $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) - 9992 FORMAT( ' FOR N ', 9I6 ) - 9991 FORMAT( ' FOR K ', 7I6 ) - 9990 FORMAT( ' FOR INCX AND INCY ', 7I6 ) - 9989 FORMAT( ' FOR ALPHA ', 7F6.1 ) - 9988 FORMAT( ' FOR BETA ', 7F6.1 ) - 9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', - $ /' ******* TESTS ABANDONED *******' ) - 9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', - $ 'ESTS ABANDONED *******' ) - 9985 FORMAT( ' ERROR IN SMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', - $ 'ATED WRONGLY.', /' SMVCH WAS CALLED WITH TRANS = ', A1, - $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', / - $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.' - $ , /' ******* TESTS ABANDONED *******' ) - 9984 FORMAT( A6, L2 ) - 9983 FORMAT( 1X, A6, ' WAS NOT TESTED' ) - 9982 FORMAT( /' END OF TESTS' ) - 9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) - 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) -* -* End of SBLAT2. -* - END - SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, - $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, - $ XS, Y, YY, YS, YT, G ) -* -* Tests SGEMV and SGBMV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - REAL ZERO, HALF - PARAMETER ( ZERO = 0.0, HALF = 0.5 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, - $ NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), - $ X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL - INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY, - $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA, - $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK, - $ NL, NS - LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN - CHARACTER*1 TRANS, TRANSS - CHARACTER*3 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SGBMV, SGEMV, SMAKE, SMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'NTC'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'E' - BANDED = SNAME( 3: 3 ).EQ.'B' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 11 - ELSE IF( BANDED )THEN - NARGS = 13 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 120 IN = 1, NIDIM - N = IDIM( IN ) - ND = N/2 + 1 -* - DO 110 IM = 1, 2 - IF( IM.EQ.1 ) - $ M = MAX( N - ND, 0 ) - IF( IM.EQ.2 ) - $ M = MIN( N + ND, NMAX ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IKU = 1, NK - IF( BANDED )THEN - KU = KB( IKU ) - KL = MAX( KU - 1, 0 ) - ELSE - KU = N - 1 - KL = M - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = KL + KU + 1 - ELSE - LDA = M - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - LAA = LDA*N - NULL = N.LE.0.OR.M.LE.0 -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL SMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, AA, - $ LDA, KL, KU, RESET, TRANSL ) -* - DO 90 IC = 1, 3 - TRANS = ICH( IC: IC ) - TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' -* - IF( TRAN )THEN - ML = N - NL = M - ELSE - ML = M - NL = N - END IF -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*NL -* -* Generate the vector X. -* - TRANSL = HALF - CALL SMAKE( 'GE', ' ', ' ', 1, NL, X, 1, XX, - $ ABS( INCX ), 0, NL - 1, RESET, TRANSL ) - IF( NL.GT.1 )THEN - X( NL/2 ) = ZERO - XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO - END IF -* - DO 70 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*ML -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL SMAKE( 'GE', ' ', ' ', 1, ML, Y, 1, - $ YY, ABS( INCY ), 0, ML - 1, - $ RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - TRANSS = TRANS - MS = M - NS = N - KLS = KL - KUS = KU - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - BLS = BETA - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ TRANS, M, N, ALPHA, LDA, INCX, BETA, - $ INCY - IF( REWI ) - $ REWIND NTRA - CALL SGEMV( TRANS, M, N, ALPHA, AA, - $ LDA, XX, INCX, BETA, YY, - $ INCY ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ TRANS, M, N, KL, KU, ALPHA, LDA, - $ INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL SGBMV( TRANS, M, N, KL, KU, ALPHA, - $ AA, LDA, XX, INCX, BETA, - $ YY, INCY ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 130 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = TRANS.EQ.TRANSS - ISAME( 2 ) = MS.EQ.M - ISAME( 3 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 4 ) = ALS.EQ.ALPHA - ISAME( 5 ) = LSE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - ISAME( 7 ) = LSE( XS, XX, LX ) - ISAME( 8 ) = INCXS.EQ.INCX - ISAME( 9 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 10 ) = LSE( YS, YY, LY ) - ELSE - ISAME( 10 ) = LSERES( 'GE', ' ', 1, - $ ML, YS, YY, - $ ABS( INCY ) ) - END IF - ISAME( 11 ) = INCYS.EQ.INCY - ELSE IF( BANDED )THEN - ISAME( 4 ) = KLS.EQ.KL - ISAME( 5 ) = KUS.EQ.KU - ISAME( 6 ) = ALS.EQ.ALPHA - ISAME( 7 ) = LSE( AS, AA, LAA ) - ISAME( 8 ) = LDAS.EQ.LDA - ISAME( 9 ) = LSE( XS, XX, LX ) - ISAME( 10 ) = INCXS.EQ.INCX - ISAME( 11 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 12 ) = LSE( YS, YY, LY ) - ELSE - ISAME( 12 ) = LSERES( 'GE', ' ', 1, - $ ML, YS, YY, - $ ABS( INCY ) ) - END IF - ISAME( 13 ) = INCYS.EQ.INCY - END IF -* -* If data was incorrectly changed, report -* and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 130 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL SMVCH( TRANS, M, N, ALPHA, A, - $ NMAX, X, INCX, BETA, Y, - $ INCY, YT, G, YY, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 130 - ELSE -* Avoid repeating tests with M.le.0 or -* N.le.0. - GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 140 -* - 130 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, TRANS, M, N, ALPHA, LDA, - $ INCX, BETA, INCY - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANS, M, N, KL, KU, - $ ALPHA, LDA, INCX, BETA, INCY - END IF -* - 140 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), F4.1, - $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1, - $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, - $ ') .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK1. -* - END - SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, - $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, - $ XS, Y, YY, YS, YT, G ) -* -* Tests SSYMV, SSBMV and SSPMV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - REAL ZERO, HALF - PARAMETER ( ZERO = 0.0, HALF = 0.5 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, - $ NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), - $ X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL - INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY, - $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY, - $ N, NARGS, NC, NK, NS - LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SMAKE, SMVCH, SSBMV, SSPMV, SSYMV -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'Y' - BANDED = SNAME( 3: 3 ).EQ.'B' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 10 - ELSE IF( BANDED )THEN - NARGS = 11 - ELSE IF( PACKED )THEN - NARGS = 9 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 110 IN = 1, NIDIM - N = IDIM( IN ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IK = 1, NK - IF( BANDED )THEN - K = KB( IK ) - ELSE - K = N - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = K + 1 - ELSE - LDA = N - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF - NULL = N.LE.0 -* - DO 90 IC = 1, 2 - UPLO = ICH( IC: IC ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL SMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA, - $ LDA, K, K, RESET, TRANSL ) -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL SMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, - $ ABS( INCX ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 70 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL SMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, - $ TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - UPLOS = UPLO - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - BLS = BETA - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, N, ALPHA, LDA, INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL SSYMV( UPLO, N, ALPHA, AA, LDA, XX, - $ INCX, BETA, YY, INCY ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, N, K, ALPHA, LDA, INCX, BETA, - $ INCY - IF( REWI ) - $ REWIND NTRA - CALL SSBMV( UPLO, N, K, ALPHA, AA, LDA, - $ XX, INCX, BETA, YY, INCY ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, N, ALPHA, INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL SSPMV( UPLO, N, ALPHA, AA, XX, INCX, - $ BETA, YY, INCY ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LSE( AS, AA, LAA ) - ISAME( 5 ) = LDAS.EQ.LDA - ISAME( 6 ) = LSE( XS, XX, LX ) - ISAME( 7 ) = INCXS.EQ.INCX - ISAME( 8 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 9 ) = LSE( YS, YY, LY ) - ELSE - ISAME( 9 ) = LSERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 10 ) = INCYS.EQ.INCY - ELSE IF( BANDED )THEN - ISAME( 3 ) = KS.EQ.K - ISAME( 4 ) = ALS.EQ.ALPHA - ISAME( 5 ) = LSE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - ISAME( 7 ) = LSE( XS, XX, LX ) - ISAME( 8 ) = INCXS.EQ.INCX - ISAME( 9 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 10 ) = LSE( YS, YY, LY ) - ELSE - ISAME( 10 ) = LSERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 11 ) = INCYS.EQ.INCY - ELSE IF( PACKED )THEN - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LSE( AS, AA, LAA ) - ISAME( 5 ) = LSE( XS, XX, LX ) - ISAME( 6 ) = INCXS.EQ.INCX - ISAME( 7 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 8 ) = LSE( YS, YY, LY ) - ELSE - ISAME( 8 ) = LSERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 9 ) = INCYS.EQ.INCY - END IF -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL SMVCH( 'N', N, N, ALPHA, A, NMAX, X, - $ INCX, BETA, Y, INCY, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 120 - ELSE -* Avoid repeating tests with N.le.0 - GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, LDA, INCX, - $ BETA, INCY - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, K, ALPHA, LDA, - $ INCX, BETA, INCY - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, N, ALPHA, INCX, - $ BETA, INCY - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', AP', - $ ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1, - $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, - $ ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', A,', - $ I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK2. -* - END - SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z ) -* -* Tests STRMV, STBMV, STPMV, STRSV, STBSV and STPSV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - REAL ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), - $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), - $ XS( NMAX*INCMAX ), XT( NMAX ), - $ XX( NMAX*INCMAX ), Z( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - REAL ERR, ERRMAX, TRANSL - INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K, - $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS - LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME - CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS - CHARACTER*2 ICHD, ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SMAKE, SMVCH, STBMV, STBSV, STPMV, STPSV, - $ STRMV, STRSV -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'R' - BANDED = SNAME( 3: 3 ).EQ.'B' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 8 - ELSE IF( BANDED )THEN - NARGS = 9 - ELSE IF( PACKED )THEN - NARGS = 7 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* Set up zero vector for SMVCH. - DO 10 I = 1, NMAX - Z( I ) = ZERO - 10 CONTINUE -* - DO 110 IN = 1, NIDIM - N = IDIM( IN ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IK = 1, NK - IF( BANDED )THEN - K = KB( IK ) - ELSE - K = N - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = K + 1 - ELSE - LDA = N - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF - NULL = N.LE.0 -* - DO 90 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* - DO 80 ICT = 1, 3 - TRANS = ICHT( ICT: ICT ) -* - DO 70 ICD = 1, 2 - DIAG = ICHD( ICD: ICD ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL SMAKE( SNAME( 2: 3 ), UPLO, DIAG, N, N, A, - $ NMAX, AA, LDA, K, K, RESET, TRANSL ) -* - DO 60 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL SMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, - $ ABS( INCX ), 0, N - 1, RESET, - $ TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - DIAGS = DIAG - NS = N - KS = K - DO 20 I = 1, LAA - AS( I ) = AA( I ) - 20 CONTINUE - LDAS = LDA - DO 30 I = 1, LX - XS( I ) = XX( I ) - 30 CONTINUE - INCXS = INCX -* -* Call the subroutine. -* - IF( SNAME( 4: 5 ).EQ.'MV' )THEN - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL STRMV( UPLO, TRANS, DIAG, N, AA, LDA, - $ XX, INCX ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, K, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL STBMV( UPLO, TRANS, DIAG, N, K, AA, - $ LDA, XX, INCX ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, INCX - IF( REWI ) - $ REWIND NTRA - CALL STPMV( UPLO, TRANS, DIAG, N, AA, XX, - $ INCX ) - END IF - ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL STRSV( UPLO, TRANS, DIAG, N, AA, LDA, - $ XX, INCX ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, K, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL STBSV( UPLO, TRANS, DIAG, N, K, AA, - $ LDA, XX, INCX ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, INCX - IF( REWI ) - $ REWIND NTRA - CALL STPSV( UPLO, TRANS, DIAG, N, AA, XX, - $ INCX ) - END IF - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = TRANS.EQ.TRANSS - ISAME( 3 ) = DIAG.EQ.DIAGS - ISAME( 4 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 5 ) = LSE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 7 ) = LSE( XS, XX, LX ) - ELSE - ISAME( 7 ) = LSERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 8 ) = INCXS.EQ.INCX - ELSE IF( BANDED )THEN - ISAME( 5 ) = KS.EQ.K - ISAME( 6 ) = LSE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 8 ) = LSE( XS, XX, LX ) - ELSE - ISAME( 8 ) = LSERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 9 ) = INCXS.EQ.INCX - ELSE IF( PACKED )THEN - ISAME( 5 ) = LSE( AS, AA, LAA ) - IF( NULL )THEN - ISAME( 6 ) = LSE( XS, XX, LX ) - ELSE - ISAME( 6 ) = LSERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 7 ) = INCXS.EQ.INCX - END IF -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN - IF( SNAME( 4: 5 ).EQ.'MV' )THEN -* -* Check the result. -* - CALL SMVCH( TRANS, N, N, ONE, A, NMAX, X, - $ INCX, ZERO, Z, INCX, XT, G, - $ XX, EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN -* -* Compute approximation to original vector. -* - DO 50 I = 1, N - Z( I ) = XX( 1 + ( I - 1 )* - $ ABS( INCX ) ) - XX( 1 + ( I - 1 )*ABS( INCX ) ) - $ = X( I ) - 50 CONTINUE - CALL SMVCH( TRANS, N, N, ONE, A, NMAX, Z, - $ INCX, ZERO, X, INCX, XT, G, - $ XX, EPS, ERR, FATAL, NOUT, - $ .FALSE. ) - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 120 - ELSE -* Avoid repeating tests with N.le.0. - GO TO 110 - END IF -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, DIAG, N, LDA, - $ INCX - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, DIAG, N, K, - $ LDA, INCX - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, TRANS, DIAG, N, INCX - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', AP, ', - $ 'X,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ), - $ ' A,', I3, ', X,', I2, ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,', - $ I3, ', X,', I2, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK3. -* - END - SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests SGER. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - REAL ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), - $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), - $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - REAL ALPHA, ALS, ERR, ERRMAX, TRANSL - INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX, - $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS, - $ NC, ND, NS - LOGICAL NULL, RESET, SAME -* .. Local Arrays .. - REAL W( 1 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SGER, SMAKE, SMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. -* Define the number of arguments. - NARGS = 9 -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 120 IN = 1, NIDIM - N = IDIM( IN ) - ND = N/2 + 1 -* - DO 110 IM = 1, 2 - IF( IM.EQ.1 ) - $ M = MAX( N - ND, 0 ) - IF( IM.EQ.2 ) - $ M = MIN( N + ND, NMAX ) -* -* Set LDA to 1 more than minimum value if room. - LDA = M - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 110 - LAA = LDA*N - NULL = N.LE.0.OR.M.LE.0 -* - DO 100 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*M -* -* Generate the vector X. -* - TRANSL = HALF - CALL SMAKE( 'GE', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ), - $ 0, M - 1, RESET, TRANSL ) - IF( M.GT.1 )THEN - X( M/2 ) = ZERO - XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO - END IF -* - DO 90 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL SMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - Y( N/2 ) = ZERO - YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 80 IA = 1, NALF - ALPHA = ALF( IA ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL SMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, - $ AA, LDA, M - 1, N - 1, RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - MS = M - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N, - $ ALPHA, INCX, INCY, LDA - IF( REWI ) - $ REWIND NTRA - CALL SGER( M, N, ALPHA, XX, INCX, YY, INCY, AA, - $ LDA ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 140 - END IF -* -* See what data changed inside subroutine. -* - ISAME( 1 ) = MS.EQ.M - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LSE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - ISAME( 6 ) = LSE( YS, YY, LY ) - ISAME( 7 ) = INCYS.EQ.INCY - IF( NULL )THEN - ISAME( 8 ) = LSE( AS, AA, LAA ) - ELSE - ISAME( 8 ) = LSERES( 'GE', ' ', M, N, AS, AA, - $ LDA ) - END IF - ISAME( 9 ) = LDAS.EQ.LDA -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 140 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 50 I = 1, M - Z( I ) = X( I ) - 50 CONTINUE - ELSE - DO 60 I = 1, M - Z( I ) = X( M - I + 1 ) - 60 CONTINUE - END IF - DO 70 J = 1, N - IF( INCY.GT.0 )THEN - W( 1 ) = Y( J ) - ELSE - W( 1 ) = Y( N - J + 1 ) - END IF - CALL SMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1, - $ ONE, A( 1, J ), 1, YT, G, - $ AA( 1 + ( J - 1 )*LDA ), EPS, - $ ERR, FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 130 - 70 CONTINUE - ELSE -* Avoid repeating tests with M.le.0 or N.le.0. - GO TO 110 - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 150 -* - 130 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 140 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA -* - 150 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), F4.1, ', X,', I2, - $ ', Y,', I2, ', A,', I3, ') .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK4. -* - END - SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests SSYR and SSPR. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - REAL ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), - $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), - $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - REAL ALPHA, ALS, ERR, ERRMAX, TRANSL - INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA, - $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS - LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - REAL W( 1 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SMAKE, SMVCH, SSPR, SSYR -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'Y' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 7 - ELSE IF( PACKED )THEN - NARGS = 6 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDA to 1 more than minimum value if room. - LDA = N - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF -* - DO 90 IC = 1, 2 - UPLO = ICH( IC: IC ) - UPPER = UPLO.EQ.'U' -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL SMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), - $ 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 70 IA = 1, NALF - ALPHA = ALF( IA ) - NULL = N.LE.0.OR.ALPHA.EQ.ZERO -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL SMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, - $ AA, LDA, N - 1, N - 1, RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, - $ ALPHA, INCX, LDA - IF( REWI ) - $ REWIND NTRA - CALL SSYR( UPLO, N, ALPHA, XX, INCX, AA, LDA ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, - $ ALPHA, INCX - IF( REWI ) - $ REWIND NTRA - CALL SSPR( UPLO, N, ALPHA, XX, INCX, AA ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LSE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - IF( NULL )THEN - ISAME( 6 ) = LSE( AS, AA, LAA ) - ELSE - ISAME( 6 ) = LSERES( SNAME( 2: 3 ), UPLO, N, N, AS, - $ AA, LDA ) - END IF - IF( .NOT.PACKED )THEN - ISAME( 7 ) = LDAS.EQ.LDA - END IF -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 30 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 30 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 40 I = 1, N - Z( I ) = X( I ) - 40 CONTINUE - ELSE - DO 50 I = 1, N - Z( I ) = X( N - I + 1 ) - 50 CONTINUE - END IF - JA = 1 - DO 60 J = 1, N - W( 1 ) = Z( J ) - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - CALL SMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W, - $ 1, ONE, A( JJ, J ), 1, YT, G, - $ AA( JA ), EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - IF( FULL )THEN - IF( UPPER )THEN - JA = JA + LDA - ELSE - JA = JA + LDA + 1 - END IF - ELSE - JA = JA + LJ - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 110 - 60 CONTINUE - ELSE -* Avoid repeating tests if N.le.0. - IF( N.LE.0 ) - $ GO TO 100 - END IF -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 110 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, LDA - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', AP) .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', A,', I3, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK5. -* - END - SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests SSYR2 and SSPR2. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - REAL ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), - $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), - $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX, 2 ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - REAL ALPHA, ALS, ERR, ERRMAX, TRANSL - INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX, - $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N, - $ NARGS, NC, NS - LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - REAL W( 2 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SMAKE, SMVCH, SSPR2, SSYR2 -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'Y' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 9 - ELSE IF( PACKED )THEN - NARGS = 8 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 140 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDA to 1 more than minimum value if room. - LDA = N - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 140 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF -* - DO 130 IC = 1, 2 - UPLO = ICH( IC: IC ) - UPPER = UPLO.EQ.'U' -* - DO 120 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL SMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), - $ 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 110 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL SMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - Y( N/2 ) = ZERO - YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 100 IA = 1, NALF - ALPHA = ALF( IA ) - NULL = N.LE.0.OR.ALPHA.EQ.ZERO -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL SMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, - $ NMAX, AA, LDA, N - 1, N - 1, RESET, - $ TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, - $ ALPHA, INCX, INCY, LDA - IF( REWI ) - $ REWIND NTRA - CALL SSYR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, - $ AA, LDA ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, - $ ALPHA, INCX, INCY - IF( REWI ) - $ REWIND NTRA - CALL SSPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, - $ AA ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 160 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LSE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - ISAME( 6 ) = LSE( YS, YY, LY ) - ISAME( 7 ) = INCYS.EQ.INCY - IF( NULL )THEN - ISAME( 8 ) = LSE( AS, AA, LAA ) - ELSE - ISAME( 8 ) = LSERES( SNAME( 2: 3 ), UPLO, N, N, - $ AS, AA, LDA ) - END IF - IF( .NOT.PACKED )THEN - ISAME( 9 ) = LDAS.EQ.LDA - END IF -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 160 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 50 I = 1, N - Z( I, 1 ) = X( I ) - 50 CONTINUE - ELSE - DO 60 I = 1, N - Z( I, 1 ) = X( N - I + 1 ) - 60 CONTINUE - END IF - IF( INCY.GT.0 )THEN - DO 70 I = 1, N - Z( I, 2 ) = Y( I ) - 70 CONTINUE - ELSE - DO 80 I = 1, N - Z( I, 2 ) = Y( N - I + 1 ) - 80 CONTINUE - END IF - JA = 1 - DO 90 J = 1, N - W( 1 ) = Z( J, 2 ) - W( 2 ) = Z( J, 1 ) - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - CALL SMVCH( 'N', LJ, 2, ALPHA, Z( JJ, 1 ), - $ NMAX, W, 1, ONE, A( JJ, J ), 1, - $ YT, G, AA( JA ), EPS, ERR, FATAL, - $ NOUT, .TRUE. ) - IF( FULL )THEN - IF( UPPER )THEN - JA = JA + LDA - ELSE - JA = JA + LDA + 1 - END IF - ELSE - JA = JA + LJ - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 150 - 90 CONTINUE - ELSE -* Avoid repeating tests with N.le.0. - IF( N.LE.0 ) - $ GO TO 140 - END IF -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* - 140 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 170 -* - 150 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 160 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, - $ INCY, LDA - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX, INCY - END IF -* - 170 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', Y,', I2, ', AP) .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', Y,', I2, ', A,', I3, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK6. -* - END - SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) -* -* Tests the error exits from the Level 2 Blas. -* Requires a special version of the error-handling routine XERBLA. -* ALPHA, BETA, A, X and Y should not need to be defined. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Local Scalars .. - REAL ALPHA, BETA -* .. Local Arrays .. - REAL A( 1, 1 ), X( 1 ), Y( 1 ) -* .. External Subroutines .. - EXTERNAL CHKXER, SGBMV, SGEMV, SGER, SSBMV, SSPMV, SSPR, - $ SSPR2, SSYMV, SSYR, SSYR2, STBMV, STBSV, STPMV, - $ STPSV, STRMV, STRSV -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. -* OK is set to .FALSE. by the special version of XERBLA or by CHKXER -* if anything is wrong. - OK = .TRUE. -* LERR is set to .TRUE. by the special version of XERBLA each time -* it is called, and is then tested and re-set by CHKXER. - LERR = .FALSE. - GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, - $ 90, 100, 110, 120, 130, 140, 150, - $ 160 )ISNUM - 10 INFOT = 1 - CALL SGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL SGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL SGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL SGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 20 INFOT = 1 - CALL SGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SGBMV( 'N', -1, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SGBMV( 'N', 0, -1, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SGBMV( 'N', 0, 0, -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SGBMV( 'N', 2, 0, 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL SGBMV( 'N', 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL SGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL SGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 30 INFOT = 1 - CALL SSYMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SSYMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SSYMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL SSYMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 40 INFOT = 1 - CALL SSBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SSBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL SSBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL SSBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL SSBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 50 INFOT = 1 - CALL SSPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SSPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL SSPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SSPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 60 INFOT = 1 - CALL STRMV( '/', 'N', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL STRMV( 'U', '/', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL STRMV( 'U', 'N', '/', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL STRMV( 'U', 'N', 'N', -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRMV( 'U', 'N', 'N', 2, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL STRMV( 'U', 'N', 'N', 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 70 INFOT = 1 - CALL STBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL STBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL STBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL STBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL STBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 80 INFOT = 1 - CALL STPMV( '/', 'N', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL STPMV( 'U', '/', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL STPMV( 'U', 'N', '/', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL STPMV( 'U', 'N', 'N', -1, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL STPMV( 'U', 'N', 'N', 0, A, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 90 INFOT = 1 - CALL STRSV( '/', 'N', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL STRSV( 'U', '/', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL STRSV( 'U', 'N', '/', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL STRSV( 'U', 'N', 'N', -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRSV( 'U', 'N', 'N', 2, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL STRSV( 'U', 'N', 'N', 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 100 INFOT = 1 - CALL STBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL STBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL STBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL STBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL STBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 110 INFOT = 1 - CALL STPSV( '/', 'N', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL STPSV( 'U', '/', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL STPSV( 'U', 'N', '/', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL STPSV( 'U', 'N', 'N', -1, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL STPSV( 'U', 'N', 'N', 0, A, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 120 INFOT = 1 - CALL SGER( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SGER( 0, -1, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SGER( 0, 0, ALPHA, X, 0, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SGER( 0, 0, ALPHA, X, 1, Y, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SGER( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 130 INFOT = 1 - CALL SSYR( '/', 0, ALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SSYR( 'U', -1, ALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SSYR( 'U', 0, ALPHA, X, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYR( 'U', 2, ALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 140 INFOT = 1 - CALL SSPR( '/', 0, ALPHA, X, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SSPR( 'U', -1, ALPHA, X, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SSPR( 'U', 0, ALPHA, X, 0, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 150 INFOT = 1 - CALL SSYR2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SSYR2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SSYR2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYR2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SSYR2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 160 INFOT = 1 - CALL SSPR2( '/', 0, ALPHA, X, 1, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SSPR2( 'U', -1, ALPHA, X, 1, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SSPR2( 'U', 0, ALPHA, X, 0, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSPR2( 'U', 0, ALPHA, X, 1, Y, 0, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* - 170 IF( OK )THEN - WRITE( NOUT, FMT = 9999 )SRNAMT - ELSE - WRITE( NOUT, FMT = 9998 )SRNAMT - END IF - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) - 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', - $ '**' ) -* -* End of SCHKE. -* - END - SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, - $ KU, RESET, TRANSL ) -* -* Generates values for an M by N matrix A within the bandwidth -* defined by KL and KU. -* Stores the values in the array AA in the data structure required -* by the routine, with unwanted elements set to rogue value. -* -* TYPE is 'GE', 'GB', 'SY', 'SB', 'SP', 'TR', 'TB' OR 'TP'. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - REAL ZERO, ONE - PARAMETER ( ZERO = 0.0, ONE = 1.0 ) - REAL ROGUE - PARAMETER ( ROGUE = -1.0E10 ) -* .. Scalar Arguments .. - REAL TRANSL - INTEGER KL, KU, LDA, M, N, NMAX - LOGICAL RESET - CHARACTER*1 DIAG, UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - REAL A( NMAX, * ), AA( * ) -* .. Local Scalars .. - INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, KK - LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER -* .. External Functions .. - REAL SBEG - EXTERNAL SBEG -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. Executable Statements .. - GEN = TYPE( 1: 1 ).EQ.'G' - SYM = TYPE( 1: 1 ).EQ.'S' - TRI = TYPE( 1: 1 ).EQ.'T' - UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' - LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' - UNIT = TRI.AND.DIAG.EQ.'U' -* -* Generate data in array A. -* - DO 20 J = 1, N - DO 10 I = 1, M - IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) - $ THEN - IF( ( I.LE.J.AND.J - I.LE.KU ).OR. - $ ( I.GE.J.AND.I - J.LE.KL ) )THEN - A( I, J ) = SBEG( RESET ) + TRANSL - ELSE - A( I, J ) = ZERO - END IF - IF( I.NE.J )THEN - IF( SYM )THEN - A( J, I ) = A( I, J ) - ELSE IF( TRI )THEN - A( J, I ) = ZERO - END IF - END IF - END IF - 10 CONTINUE - IF( TRI ) - $ A( J, J ) = A( J, J ) + ONE - IF( UNIT ) - $ A( J, J ) = ONE - 20 CONTINUE -* -* Store elements in array AS in data structure required by routine. -* - IF( TYPE.EQ.'GE' )THEN - DO 50 J = 1, N - DO 30 I = 1, M - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 30 CONTINUE - DO 40 I = M + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 40 CONTINUE - 50 CONTINUE - ELSE IF( TYPE.EQ.'GB' )THEN - DO 90 J = 1, N - DO 60 I1 = 1, KU + 1 - J - AA( I1 + ( J - 1 )*LDA ) = ROGUE - 60 CONTINUE - DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J ) - AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J ) - 70 CONTINUE - DO 80 I3 = I2, LDA - AA( I3 + ( J - 1 )*LDA ) = ROGUE - 80 CONTINUE - 90 CONTINUE - ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN - DO 130 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IF( UNIT )THEN - IEND = J - 1 - ELSE - IEND = J - END IF - ELSE - IF( UNIT )THEN - IBEG = J + 1 - ELSE - IBEG = J - END IF - IEND = N - END IF - DO 100 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 100 CONTINUE - DO 110 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 110 CONTINUE - DO 120 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 120 CONTINUE - 130 CONTINUE - ELSE IF( TYPE.EQ.'SB'.OR.TYPE.EQ.'TB' )THEN - DO 170 J = 1, N - IF( UPPER )THEN - KK = KL + 1 - IBEG = MAX( 1, KL + 2 - J ) - IF( UNIT )THEN - IEND = KL - ELSE - IEND = KL + 1 - END IF - ELSE - KK = 1 - IF( UNIT )THEN - IBEG = 2 - ELSE - IBEG = 1 - END IF - IEND = MIN( KL + 1, 1 + M - J ) - END IF - DO 140 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 140 CONTINUE - DO 150 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J ) - 150 CONTINUE - DO 160 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 160 CONTINUE - 170 CONTINUE - ELSE IF( TYPE.EQ.'SP'.OR.TYPE.EQ.'TP' )THEN - IOFF = 0 - DO 190 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 180 I = IBEG, IEND - IOFF = IOFF + 1 - AA( IOFF ) = A( I, J ) - IF( I.EQ.J )THEN - IF( UNIT ) - $ AA( IOFF ) = ROGUE - END IF - 180 CONTINUE - 190 CONTINUE - END IF - RETURN -* -* End of SMAKE. -* - END - SUBROUTINE SMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, - $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV ) -* -* Checks the results of the computational tests. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - REAL ZERO, ONE - PARAMETER ( ZERO = 0.0, ONE = 1.0 ) -* .. Scalar Arguments .. - REAL ALPHA, BETA, EPS, ERR - INTEGER INCX, INCY, M, N, NMAX, NOUT - LOGICAL FATAL, MV - CHARACTER*1 TRANS -* .. Array Arguments .. - REAL A( NMAX, * ), G( * ), X( * ), Y( * ), YT( * ), - $ YY( * ) -* .. Local Scalars .. - REAL ERRI - INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL - LOGICAL TRAN -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. Executable Statements .. - TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' - IF( TRAN )THEN - ML = N - NL = M - ELSE - ML = M - NL = N - END IF - IF( INCX.LT.0 )THEN - KX = NL - INCXL = -1 - ELSE - KX = 1 - INCXL = 1 - END IF - IF( INCY.LT.0 )THEN - KY = ML - INCYL = -1 - ELSE - KY = 1 - INCYL = 1 - END IF -* -* Compute expected result in YT using data in A, X and Y. -* Compute gauges in G. -* - IY = KY - DO 30 I = 1, ML - YT( IY ) = ZERO - G( IY ) = ZERO - JX = KX - IF( TRAN )THEN - DO 10 J = 1, NL - YT( IY ) = YT( IY ) + A( J, I )*X( JX ) - G( IY ) = G( IY ) + ABS( A( J, I )*X( JX ) ) - JX = JX + INCXL - 10 CONTINUE - ELSE - DO 20 J = 1, NL - YT( IY ) = YT( IY ) + A( I, J )*X( JX ) - G( IY ) = G( IY ) + ABS( A( I, J )*X( JX ) ) - JX = JX + INCXL - 20 CONTINUE - END IF - YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY ) - G( IY ) = ABS( ALPHA )*G( IY ) + ABS( BETA*Y( IY ) ) - IY = IY + INCYL - 30 CONTINUE -* -* Compute the error ratio for this result. -* - ERR = ZERO - DO 40 I = 1, ML - ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS - IF( G( I ).NE.ZERO ) - $ ERRI = ERRI/G( I ) - ERR = MAX( ERR, ERRI ) - IF( ERR*SQRT( EPS ).GE.ONE ) - $ GO TO 50 - 40 CONTINUE -* If the loop completes, all results are at least half accurate. - GO TO 70 -* -* Report fatal error. -* - 50 FATAL = .TRUE. - WRITE( NOUT, FMT = 9999 ) - DO 60 I = 1, ML - IF( MV )THEN - WRITE( NOUT, FMT = 9998 )I, YT( I ), - $ YY( 1 + ( I - 1 )*ABS( INCY ) ) - ELSE - WRITE( NOUT, FMT = 9998 )I, - $ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT(I) - END IF - 60 CONTINUE -* - 70 CONTINUE - RETURN -* - 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', - $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU', - $ 'TED RESULT' ) - 9998 FORMAT( 1X, I7, 2G18.6 ) -* -* End of SMVCH. -* - END - LOGICAL FUNCTION LSE( RI, RJ, LR ) -* -* Tests if two arrays are identical. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER LR -* .. Array Arguments .. - REAL RI( * ), RJ( * ) -* .. Local Scalars .. - INTEGER I -* .. Executable Statements .. - DO 10 I = 1, LR - IF( RI( I ).NE.RJ( I ) ) - $ GO TO 20 - 10 CONTINUE - LSE = .TRUE. - GO TO 30 - 20 CONTINUE - LSE = .FALSE. - 30 RETURN -* -* End of LSE. -* - END - LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA ) -* -* Tests if selected elements in two arrays are equal. -* -* TYPE is 'GE', 'SY' or 'SP'. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER LDA, M, N - CHARACTER*1 UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - REAL AA( LDA, * ), AS( LDA, * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J - LOGICAL UPPER -* .. Executable Statements .. - UPPER = UPLO.EQ.'U' - IF( TYPE.EQ.'GE' )THEN - DO 20 J = 1, N - DO 10 I = M + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 10 CONTINUE - 20 CONTINUE - ELSE IF( TYPE.EQ.'SY' )THEN - DO 50 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 30 I = 1, IBEG - 1 - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 30 CONTINUE - DO 40 I = IEND + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 40 CONTINUE - 50 CONTINUE - END IF -* - LSERES = .TRUE. - GO TO 80 - 70 CONTINUE - LSERES = .FALSE. - 80 RETURN -* -* End of LSERES. -* - END - REAL FUNCTION SBEG( RESET ) -* -* Generates random numbers uniformly distributed between -0.5 and 0.5. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - LOGICAL RESET -* .. Local Scalars .. - INTEGER I, IC, MI -* .. Save statement .. - SAVE I, IC, MI -* .. Intrinsic Functions .. - INTRINSIC REAL -* .. Executable Statements .. - IF( RESET )THEN -* Initialize local variables. - MI = 891 - I = 7 - IC = 0 - RESET = .FALSE. - END IF -* -* The sequence of values of I is bounded between 1 and 999. -* If initial I = 1,2,3,6,7 or 9, the period will be 50. -* If initial I = 4 or 8, the period will be 25. -* If initial I = 5, the period will be 10. -* IC is used to break up the period by skipping 1 value of I in 6. -* - IC = IC + 1 - 10 I = I*MI - I = I - 1000*( I/1000 ) - IF( IC.GE.5 )THEN - IC = 0 - GO TO 10 - END IF - SBEG = REAL( I - 500 )/1001.0 - RETURN -* -* End of SBEG. -* - END - REAL FUNCTION SDIFF( X, Y ) -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* -* .. Scalar Arguments .. - REAL X, Y -* .. Executable Statements .. - SDIFF = X - Y - RETURN -* -* End of SDIFF. -* - END - SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* -* Tests whether XERBLA has detected an error when it should. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Executable Statements .. - IF( .NOT.LERR )THEN - WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT - OK = .FALSE. - END IF - LERR = .FALSE. - RETURN -* - 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', - $ 'ETECTED BY ', A6, ' *****' ) -* -* End of CHKXER. -* - END - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* This is a special version of XERBLA to be used only as part of -* the test program for testing error exits from the Level 2 BLAS -* routines. -* -* XERBLA is an error handler for the Level 2 BLAS routines. -* -* It is called by the Level 2 BLAS routines if an input parameter is -* invalid. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER INFO - CHARACTER*6 SRNAME -* .. Scalars in Common .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUT, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Executable Statements .. - LERR = .TRUE. - IF( INFO.NE.INFOT )THEN - IF( INFOT.NE.0 )THEN - WRITE( NOUT, FMT = 9999 )INFO, INFOT - ELSE - WRITE( NOUT, FMT = 9997 )INFO - END IF - OK = .FALSE. - END IF - IF( SRNAME.NE.SRNAMT )THEN - WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT - OK = .FALSE. - END IF - RETURN -* - 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', - $ ' OF ', I2, ' *******' ) - 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', - $ 'AD OF ', A6, ' *******' ) - 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, - $ ' *******' ) -* -* End of XERBLA -* - END - diff --git a/eigen/blas/testing/sblat3.dat b/eigen/blas/testing/sblat3.dat deleted file mode 100644 index 680e736..0000000 --- a/eigen/blas/testing/sblat3.dat +++ /dev/null @@ -1,20 +0,0 @@ -'sblat3.summ' NAME OF SUMMARY OUTPUT FILE -6 UNIT NUMBER OF SUMMARY FILE -'sblat3.snap' NAME OF SNAPSHOT OUTPUT FILE --1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -F LOGICAL FLAG, T TO STOP ON FAILURES. -T LOGICAL FLAG, T TO TEST ERROR EXITS. -16.0 THRESHOLD VALUE OF TEST RATIO -6 NUMBER OF VALUES OF N -0 1 2 3 5 9 VALUES OF N -3 NUMBER OF VALUES OF ALPHA -0.0 1.0 0.7 VALUES OF ALPHA -3 NUMBER OF VALUES OF BETA -0.0 1.0 1.3 VALUES OF BETA -SGEMM T PUT F FOR NO TEST. SAME COLUMNS. -SSYMM T PUT F FOR NO TEST. SAME COLUMNS. -STRMM T PUT F FOR NO TEST. SAME COLUMNS. -STRSM T PUT F FOR NO TEST. SAME COLUMNS. -SSYRK T PUT F FOR NO TEST. SAME COLUMNS. -SSYR2K T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/eigen/blas/testing/sblat3.f b/eigen/blas/testing/sblat3.f deleted file mode 100644 index 8792696..0000000 --- a/eigen/blas/testing/sblat3.f +++ /dev/null @@ -1,2873 +0,0 @@ -*> \brief \b SBLAT3 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM SBLAT3 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the REAL Level 3 Blas. -*> -*> The program must be driven by a short data file. The first 14 records -*> of the file are read using list-directed input, the last 6 records -*> are read using the format ( A6, L2 ). An annotated example of a data -*> file can be obtained by deleting the first 3 characters from the -*> following 20 lines: -*> 'sblat3.out' NAME OF SUMMARY OUTPUT FILE -*> 6 UNIT NUMBER OF SUMMARY FILE -*> 'SBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE -*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -*> F LOGICAL FLAG, T TO STOP ON FAILURES. -*> T LOGICAL FLAG, T TO TEST ERROR EXITS. -*> 16.0 THRESHOLD VALUE OF TEST RATIO -*> 6 NUMBER OF VALUES OF N -*> 0 1 2 3 5 9 VALUES OF N -*> 3 NUMBER OF VALUES OF ALPHA -*> 0.0 1.0 0.7 VALUES OF ALPHA -*> 3 NUMBER OF VALUES OF BETA -*> 0.0 1.0 1.3 VALUES OF BETA -*> SGEMM T PUT F FOR NO TEST. SAME COLUMNS. -*> SSYMM T PUT F FOR NO TEST. SAME COLUMNS. -*> STRMM T PUT F FOR NO TEST. SAME COLUMNS. -*> STRSM T PUT F FOR NO TEST. SAME COLUMNS. -*> SSYRK T PUT F FOR NO TEST. SAME COLUMNS. -*> SSYR2K T PUT F FOR NO TEST. SAME COLUMNS. -*> -*> Further Details -*> =============== -*> -*> See: -*> -*> Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. -*> A Set of Level 3 Basic Linear Algebra Subprograms. -*> -*> Technical Memorandum No.88 (Revision 1), Mathematics and -*> Computer Science Division, Argonne National Laboratory, 9700 -*> South Cass Avenue, Argonne, Illinois 60439, US. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> -*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers -*> can be run multiple times without deleting generated -*> output files (susan) -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date April 2012 -* -*> \ingroup single_blas_testing -* -* ===================================================================== - PROGRAM SBLAT3 -* -* -- Reference BLAS test routine (version 3.4.1) -- -* -- 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 NIN - PARAMETER ( NIN = 5 ) - INTEGER NSUBS - PARAMETER ( NSUBS = 6 ) - REAL ZERO, ONE - PARAMETER ( ZERO = 0.0, ONE = 1.0 ) - INTEGER NMAX - PARAMETER ( NMAX = 65 ) - INTEGER NIDMAX, NALMAX, NBEMAX - PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 ) -* .. Local Scalars .. - REAL EPS, ERR, THRESH - INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA - LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, - $ TSTERR - CHARACTER*1 TRANSA, TRANSB - CHARACTER*6 SNAMET - CHARACTER*32 SNAPS, SUMMRY -* .. Local Arrays .. - REAL AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), - $ ALF( NALMAX ), AS( NMAX*NMAX ), - $ BB( NMAX*NMAX ), BET( NBEMAX ), - $ BS( NMAX*NMAX ), C( NMAX, NMAX ), - $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), - $ G( NMAX ), W( 2*NMAX ) - INTEGER IDIM( NIDMAX ) - LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) -* .. External Functions .. - REAL SDIFF - LOGICAL LSE - EXTERNAL SDIFF, LSE -* .. External Subroutines .. - EXTERNAL SCHK1, SCHK2, SCHK3, SCHK4, SCHK5, SCHKE, SMMCH -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Data statements .. - DATA SNAMES/'SGEMM ', 'SSYMM ', 'STRMM ', 'STRSM ', - $ 'SSYRK ', 'SSYR2K'/ -* .. Executable Statements .. -* -* Read name and unit number for summary output file and open file. -* - READ( NIN, FMT = * )SUMMRY - READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY ) - NOUTC = NOUT -* -* Read name and unit number for snapshot output file and open file. -* - READ( NIN, FMT = * )SNAPS - READ( NIN, FMT = * )NTRA - TRACE = NTRA.GE.0 - IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS ) - END IF -* Read the flag that directs rewinding of the snapshot file. - READ( NIN, FMT = * )REWI - REWI = REWI.AND.TRACE -* Read the flag that directs stopping on any failure. - READ( NIN, FMT = * )SFATAL -* Read the flag that indicates whether error exits are to be tested. - READ( NIN, FMT = * )TSTERR -* Read the threshold value of the test ratio - READ( NIN, FMT = * )THRESH -* -* Read and check the parameter values for the tests. -* -* Values of N - READ( NIN, FMT = * )NIDIM - IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN - WRITE( NOUT, FMT = 9997 )'N', NIDMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) - DO 10 I = 1, NIDIM - IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN - WRITE( NOUT, FMT = 9996 )NMAX - GO TO 220 - END IF - 10 CONTINUE -* Values of ALPHA - READ( NIN, FMT = * )NALF - IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN - WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) -* Values of BETA - READ( NIN, FMT = * )NBET - IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN - WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) -* -* Report values of parameters. -* - WRITE( NOUT, FMT = 9995 ) - WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM ) - WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF ) - WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET ) - IF( .NOT.TSTERR )THEN - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9984 ) - END IF - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9999 )THRESH - WRITE( NOUT, FMT = * ) -* -* Read names of subroutines and flags which indicate -* whether they are to be tested. -* - DO 20 I = 1, NSUBS - LTEST( I ) = .FALSE. - 20 CONTINUE - 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT - DO 40 I = 1, NSUBS - IF( SNAMET.EQ.SNAMES( I ) ) - $ GO TO 50 - 40 CONTINUE - WRITE( NOUT, FMT = 9990 )SNAMET - STOP - 50 LTEST( I ) = LTESTT - GO TO 30 -* - 60 CONTINUE - CLOSE ( NIN ) -* -* Compute EPS (the machine precision). -* - EPS = EPSILON(ZERO) - WRITE( NOUT, FMT = 9998 )EPS -* -* Check the reliability of SMMCH using exact data. -* - N = MIN( 32, NMAX ) - DO 100 J = 1, N - DO 90 I = 1, N - AB( I, J ) = MAX( I - J + 1, 0 ) - 90 CONTINUE - AB( J, NMAX + 1 ) = J - AB( 1, NMAX + J ) = J - C( J, 1 ) = ZERO - 100 CONTINUE - DO 110 J = 1, N - CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 - 110 CONTINUE -* CC holds the exact result. On exit from SMMCH CT holds -* the result computed by SMMCH. - TRANSA = 'N' - TRANSB = 'N' - CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LSE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - TRANSB = 'T' - CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LSE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - DO 120 J = 1, N - AB( J, NMAX + 1 ) = N - J + 1 - AB( 1, NMAX + J ) = N - J + 1 - 120 CONTINUE - DO 130 J = 1, N - CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 - - $ ( ( J + 1 )*J*( J - 1 ) )/3 - 130 CONTINUE - TRANSA = 'T' - TRANSB = 'N' - CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LSE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - TRANSB = 'T' - CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LSE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF -* -* Test each subroutine in turn. -* - DO 200 ISNUM = 1, NSUBS - WRITE( NOUT, FMT = * ) - IF( .NOT.LTEST( ISNUM ) )THEN -* Subprogram is not to be tested. - WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM ) - ELSE - SRNAMT = SNAMES( ISNUM ) -* Test error exits. - IF( TSTERR )THEN - CALL SCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) - WRITE( NOUT, FMT = * ) - END IF -* Test computations. - INFOT = 0 - OK = .TRUE. - FATAL = .FALSE. - GO TO ( 140, 150, 160, 160, 170, 180 )ISNUM -* Test SGEMM, 01. - 140 CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test SSYMM, 02. - 150 CALL SCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test STRMM, 03, STRSM, 04. - 160 CALL SCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB, - $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C ) - GO TO 190 -* Test SSYRK, 05. - 170 CALL SCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test SSYR2K, 06. - 180 CALL SCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) - GO TO 190 -* - 190 IF( FATAL.AND.SFATAL ) - $ GO TO 210 - END IF - 200 CONTINUE - WRITE( NOUT, FMT = 9986 ) - GO TO 230 -* - 210 CONTINUE - WRITE( NOUT, FMT = 9985 ) - GO TO 230 -* - 220 CONTINUE - WRITE( NOUT, FMT = 9991 ) -* - 230 CONTINUE - IF( TRACE ) - $ CLOSE ( NTRA ) - CLOSE ( NOUT ) - STOP -* - 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', - $ 'S THAN', F8.2 ) - 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 ) - 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', - $ 'THAN ', I2 ) - 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) - 9995 FORMAT( ' TESTS OF THE REAL LEVEL 3 BLAS', //' THE F', - $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) - 9994 FORMAT( ' FOR N ', 9I6 ) - 9993 FORMAT( ' FOR ALPHA ', 7F6.1 ) - 9992 FORMAT( ' FOR BETA ', 7F6.1 ) - 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', - $ /' ******* TESTS ABANDONED *******' ) - 9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', - $ 'ESTS ABANDONED *******' ) - 9989 FORMAT( ' ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', - $ 'ATED WRONGLY.', /' SMMCH WAS CALLED WITH TRANSA = ', A1, - $ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ', - $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', - $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', - $ '*******' ) - 9988 FORMAT( A6, L2 ) - 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' ) - 9986 FORMAT( /' END OF TESTS' ) - 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) - 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) -* -* End of SBLAT3. -* - END - SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests SGEMM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX - INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA, - $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, - $ MA, MB, MS, N, NA, NARGS, NB, NC, NS - LOGICAL NULL, RESET, SAME, TRANA, TRANB - CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB - CHARACTER*3 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SGEMM, SMAKE, SMMCH -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'NTC'/ -* .. Executable Statements .. -* - NARGS = 13 - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 110 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = M - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 100 - LCC = LDC*N - NULL = N.LE.0.OR.M.LE.0 -* - DO 90 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 80 ICA = 1, 3 - TRANSA = ICH( ICA: ICA ) - TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' -* - IF( TRANA )THEN - MA = K - NA = M - ELSE - MA = M - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* -* Generate the matrix A. -* - CALL SMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) -* - DO 70 ICB = 1, 3 - TRANSB = ICH( ICB: ICB ) - TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' -* - IF( TRANB )THEN - MB = N - NB = K - ELSE - MB = K - NB = N - END IF -* Set LDB to 1 more than minimum value if room. - LDB = MB - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 70 - LBB = LDB*NB -* -* Generate the matrix B. -* - CALL SMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB, - $ LDB, RESET, ZERO ) -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL SMAKE( 'GE', ' ', ' ', M, N, C, NMAX, - $ CC, LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - TRANAS = TRANSA - TRANBS = TRANSB - MS = M - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - BLS = BETA - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB, - $ BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL SGEMM( TRANSA, TRANSB, M, N, K, ALPHA, - $ AA, LDA, BB, LDB, BETA, CC, LDC ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = TRANSA.EQ.TRANAS - ISAME( 2 ) = TRANSB.EQ.TRANBS - ISAME( 3 ) = MS.EQ.M - ISAME( 4 ) = NS.EQ.N - ISAME( 5 ) = KS.EQ.K - ISAME( 6 ) = ALS.EQ.ALPHA - ISAME( 7 ) = LSE( AS, AA, LAA ) - ISAME( 8 ) = LDAS.EQ.LDA - ISAME( 9 ) = LSE( BS, BB, LBB ) - ISAME( 10 ) = LDBS.EQ.LDB - ISAME( 11 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 12 ) = LSE( CS, CC, LCC ) - ELSE - ISAME( 12 ) = LSERES( 'GE', ' ', M, N, CS, - $ CC, LDC ) - END IF - ISAME( 13 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report -* and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL SMMCH( TRANSA, TRANSB, M, N, K, - $ ALPHA, A, NMAX, B, NMAX, BETA, - $ C, NMAX, CT, G, CC, LDC, EPS, - $ ERR, FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 120 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K, - $ ALPHA, LDA, LDB, BETA, LDC -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',', - $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', - $ 'C,', I3, ').' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK1. -* - END - SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests SSYMM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX - INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC, - $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA, - $ NARGS, NC, NS - LOGICAL LEFT, NULL, RESET, SAME - CHARACTER*1 SIDE, SIDES, UPLO, UPLOS - CHARACTER*2 ICHS, ICHU -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SMAKE, SMMCH, SSYMM -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHS/'LR'/, ICHU/'UL'/ -* .. Executable Statements .. -* - NARGS = 12 - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 100 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 90 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = M - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 90 - LCC = LDC*N - NULL = N.LE.0.OR.M.LE.0 -* -* Set LDB to 1 more than minimum value if room. - LDB = M - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 90 - LBB = LDB*N -* -* Generate the matrix B. -* - CALL SMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET, - $ ZERO ) -* - DO 80 ICS = 1, 2 - SIDE = ICHS( ICS: ICS ) - LEFT = SIDE.EQ.'L' -* - IF( LEFT )THEN - NA = M - ELSE - NA = N - END IF -* Set LDA to 1 more than minimum value if room. - LDA = NA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* - DO 70 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* -* Generate the symmetric matrix A. -* - CALL SMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL SMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC, - $ LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - SIDES = SIDE - UPLOS = UPLO - MS = M - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - BLS = BETA - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE, - $ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL SSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, - $ BB, LDB, BETA, CC, LDC ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 110 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = SIDES.EQ.SIDE - ISAME( 2 ) = UPLOS.EQ.UPLO - ISAME( 3 ) = MS.EQ.M - ISAME( 4 ) = NS.EQ.N - ISAME( 5 ) = ALS.EQ.ALPHA - ISAME( 6 ) = LSE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - ISAME( 8 ) = LSE( BS, BB, LBB ) - ISAME( 9 ) = LDBS.EQ.LDB - ISAME( 10 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 11 ) = LSE( CS, CC, LCC ) - ELSE - ISAME( 11 ) = LSERES( 'GE', ' ', M, N, CS, - $ CC, LDC ) - END IF - ISAME( 12 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 110 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - IF( LEFT )THEN - CALL SMMCH( 'N', 'N', M, N, M, ALPHA, A, - $ NMAX, B, NMAX, BETA, C, NMAX, - $ CT, G, CC, LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL SMMCH( 'N', 'N', M, N, N, ALPHA, B, - $ NMAX, A, NMAX, BETA, C, NMAX, - $ CT, G, CC, LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 120 -* - 110 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA, - $ LDB, BETA, LDC -* - 120 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', - $ ' .' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK2. -* - END - SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS, - $ B, BB, BS, CT, G, C ) -* -* Tests STRMM and STRSM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - REAL ZERO, ONE - PARAMETER ( ZERO = 0.0, ONE = 1.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER NALF, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CT( NMAX ), G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - REAL ALPHA, ALS, ERR, ERRMAX - INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB, - $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC, - $ NS - LOGICAL LEFT, NULL, RESET, SAME - CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO, - $ UPLOS - CHARACTER*2 ICHD, ICHS, ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SMAKE, SMMCH, STRMM, STRSM -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/ -* .. Executable Statements .. -* - NARGS = 11 - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* Set up zero matrix for SMMCH. - DO 20 J = 1, NMAX - DO 10 I = 1, NMAX - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE -* - DO 140 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 130 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDB to 1 more than minimum value if room. - LDB = M - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 130 - LBB = LDB*N - NULL = M.LE.0.OR.N.LE.0 -* - DO 120 ICS = 1, 2 - SIDE = ICHS( ICS: ICS ) - LEFT = SIDE.EQ.'L' - IF( LEFT )THEN - NA = M - ELSE - NA = N - END IF -* Set LDA to 1 more than minimum value if room. - LDA = NA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 130 - LAA = LDA*NA -* - DO 110 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* - DO 100 ICT = 1, 3 - TRANSA = ICHT( ICT: ICT ) -* - DO 90 ICD = 1, 2 - DIAG = ICHD( ICD: ICD ) -* - DO 80 IA = 1, NALF - ALPHA = ALF( IA ) -* -* Generate the matrix A. -* - CALL SMAKE( 'TR', UPLO, DIAG, NA, NA, A, - $ NMAX, AA, LDA, RESET, ZERO ) -* -* Generate the matrix B. -* - CALL SMAKE( 'GE', ' ', ' ', M, N, B, NMAX, - $ BB, LDB, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - SIDES = SIDE - UPLOS = UPLO - TRANAS = TRANSA - DIAGS = DIAG - MS = M - NS = N - ALS = ALPHA - DO 30 I = 1, LAA - AS( I ) = AA( I ) - 30 CONTINUE - LDAS = LDA - DO 40 I = 1, LBB - BS( I ) = BB( I ) - 40 CONTINUE - LDBS = LDB -* -* Call the subroutine. -* - IF( SNAME( 4: 5 ).EQ.'MM' )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, - $ LDA, LDB - IF( REWI ) - $ REWIND NTRA - CALL STRMM( SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, AA, LDA, BB, LDB ) - ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, - $ LDA, LDB - IF( REWI ) - $ REWIND NTRA - CALL STRSM( SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, AA, LDA, BB, LDB ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 150 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = SIDES.EQ.SIDE - ISAME( 2 ) = UPLOS.EQ.UPLO - ISAME( 3 ) = TRANAS.EQ.TRANSA - ISAME( 4 ) = DIAGS.EQ.DIAG - ISAME( 5 ) = MS.EQ.M - ISAME( 6 ) = NS.EQ.N - ISAME( 7 ) = ALS.EQ.ALPHA - ISAME( 8 ) = LSE( AS, AA, LAA ) - ISAME( 9 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 10 ) = LSE( BS, BB, LBB ) - ELSE - ISAME( 10 ) = LSERES( 'GE', ' ', M, N, BS, - $ BB, LDB ) - END IF - ISAME( 11 ) = LDBS.EQ.LDB -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 50 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 50 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 150 - END IF -* - IF( .NOT.NULL )THEN - IF( SNAME( 4: 5 ).EQ.'MM' )THEN -* -* Check the result. -* - IF( LEFT )THEN - CALL SMMCH( TRANSA, 'N', M, N, M, - $ ALPHA, A, NMAX, B, NMAX, - $ ZERO, C, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL SMMCH( 'N', TRANSA, M, N, N, - $ ALPHA, B, NMAX, A, NMAX, - $ ZERO, C, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN -* -* Compute approximation to original -* matrix. -* - DO 70 J = 1, N - DO 60 I = 1, M - C( I, J ) = BB( I + ( J - 1 )* - $ LDB ) - BB( I + ( J - 1 )*LDB ) = ALPHA* - $ B( I, J ) - 60 CONTINUE - 70 CONTINUE -* - IF( LEFT )THEN - CALL SMMCH( TRANSA, 'N', M, N, M, - $ ONE, A, NMAX, C, NMAX, - $ ZERO, B, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .FALSE. ) - ELSE - CALL SMMCH( 'N', TRANSA, M, N, N, - $ ONE, C, NMAX, A, NMAX, - $ ZERO, B, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .FALSE. ) - END IF - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 150 - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* - 140 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 160 -* - 150 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, LDA, LDB -* - 160 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ), - $ F4.1, ', A,', I3, ', B,', I3, ') .' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK3. -* - END - SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests SSYRK. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX - INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS, - $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA, - $ NARGS, NC, NS - LOGICAL NULL, RESET, SAME, TRAN, UPPER - CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS - CHARACTER*2 ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SMAKE, SMMCH, SSYRK -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHT/'NTC'/, ICHU/'UL'/ -* .. Executable Statements .. -* - NARGS = 10 - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = N - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 100 - LCC = LDC*N - NULL = N.LE.0 -* - DO 90 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 80 ICT = 1, 3 - TRANS = ICHT( ICT: ICT ) - TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' - IF( TRAN )THEN - MA = K - NA = N - ELSE - MA = N - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* -* Generate the matrix A. -* - CALL SMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) -* - DO 70 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) - UPPER = UPLO.EQ.'U' -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC, - $ LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - BETS = BETA - DO 20 I = 1, LCC - CS( I ) = CC( I ) - 20 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, - $ TRANS, N, K, ALPHA, LDA, BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL SSYRK( UPLO, TRANS, N, K, ALPHA, AA, LDA, - $ BETA, CC, LDC ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLOS.EQ.UPLO - ISAME( 2 ) = TRANSS.EQ.TRANS - ISAME( 3 ) = NS.EQ.N - ISAME( 4 ) = KS.EQ.K - ISAME( 5 ) = ALS.EQ.ALPHA - ISAME( 6 ) = LSE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - ISAME( 8 ) = BETS.EQ.BETA - IF( NULL )THEN - ISAME( 9 ) = LSE( CS, CC, LCC ) - ELSE - ISAME( 9 ) = LSERES( 'SY', UPLO, N, N, CS, - $ CC, LDC ) - END IF - ISAME( 10 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 30 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 30 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - JC = 1 - DO 40 J = 1, N - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - IF( TRAN )THEN - CALL SMMCH( 'T', 'N', LJ, 1, K, ALPHA, - $ A( 1, JJ ), NMAX, - $ A( 1, J ), NMAX, BETA, - $ C( JJ, J ), NMAX, CT, G, - $ CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL SMMCH( 'N', 'T', LJ, 1, K, ALPHA, - $ A( JJ, 1 ), NMAX, - $ A( J, 1 ), NMAX, BETA, - $ C( JJ, J ), NMAX, CT, G, - $ CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - IF( UPPER )THEN - JC = JC + LDC - ELSE - JC = JC + LDC + 1 - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 110 - 40 CONTINUE - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 110 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9995 )J -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, - $ LDA, BETA, LDC -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK4. -* - END - SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) -* -* Tests SSYR2K. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), - $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), - $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ), - $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), - $ G( NMAX ), W( 2*NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX - INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, - $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, - $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS - LOGICAL NULL, RESET, SAME, TRAN, UPPER - CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS - CHARACTER*2 ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SMAKE, SMMCH, SSYR2K -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHT/'NTC'/, ICHU/'UL'/ -* .. Executable Statements .. -* - NARGS = 12 - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 130 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = N - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 130 - LCC = LDC*N - NULL = N.LE.0 -* - DO 120 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 110 ICT = 1, 3 - TRANS = ICHT( ICT: ICT ) - TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' - IF( TRAN )THEN - MA = K - NA = N - ELSE - MA = N - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 110 - LAA = LDA*NA -* -* Generate the matrix A. -* - IF( TRAN )THEN - CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA, - $ LDA, RESET, ZERO ) - ELSE - CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA, - $ RESET, ZERO ) - END IF -* -* Generate the matrix B. -* - LDB = LDA - LBB = LAA - IF( TRAN )THEN - CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ), - $ 2*NMAX, BB, LDB, RESET, ZERO ) - ELSE - CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ), - $ NMAX, BB, LDB, RESET, ZERO ) - END IF -* - DO 100 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) - UPPER = UPLO.EQ.'U' -* - DO 90 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 80 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC, - $ LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - BETS = BETA - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, - $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL SSYR2K( UPLO, TRANS, N, K, ALPHA, AA, LDA, - $ BB, LDB, BETA, CC, LDC ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 150 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLOS.EQ.UPLO - ISAME( 2 ) = TRANSS.EQ.TRANS - ISAME( 3 ) = NS.EQ.N - ISAME( 4 ) = KS.EQ.K - ISAME( 5 ) = ALS.EQ.ALPHA - ISAME( 6 ) = LSE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - ISAME( 8 ) = LSE( BS, BB, LBB ) - ISAME( 9 ) = LDBS.EQ.LDB - ISAME( 10 ) = BETS.EQ.BETA - IF( NULL )THEN - ISAME( 11 ) = LSE( CS, CC, LCC ) - ELSE - ISAME( 11 ) = LSERES( 'SY', UPLO, N, N, CS, - $ CC, LDC ) - END IF - ISAME( 12 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 150 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - JJAB = 1 - JC = 1 - DO 70 J = 1, N - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - IF( TRAN )THEN - DO 50 I = 1, K - W( I ) = AB( ( J - 1 )*2*NMAX + K + - $ I ) - W( K + I ) = AB( ( J - 1 )*2*NMAX + - $ I ) - 50 CONTINUE - CALL SMMCH( 'T', 'N', LJ, 1, 2*K, - $ ALPHA, AB( JJAB ), 2*NMAX, - $ W, 2*NMAX, BETA, - $ C( JJ, J ), NMAX, CT, G, - $ CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - DO 60 I = 1, K - W( I ) = AB( ( K + I - 1 )*NMAX + - $ J ) - W( K + I ) = AB( ( I - 1 )*NMAX + - $ J ) - 60 CONTINUE - CALL SMMCH( 'N', 'N', LJ, 1, 2*K, - $ ALPHA, AB( JJ ), NMAX, W, - $ 2*NMAX, BETA, C( JJ, J ), - $ NMAX, CT, G, CC( JC ), LDC, - $ EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - END IF - IF( UPPER )THEN - JC = JC + LDC - ELSE - JC = JC + LDC + 1 - IF( TRAN ) - $ JJAB = JJAB + 2*NMAX - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 140 - 70 CONTINUE - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 160 -* - 140 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9995 )J -* - 150 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, - $ LDA, LDB, BETA, LDC -* - 160 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', - $ ' .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK5. -* - END - SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) -* -* Tests the error exits from the Level 3 Blas. -* Requires a special version of the error-handling routine XERBLA. -* A, B and C should not need to be defined. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* 3-19-92: Initialize ALPHA and BETA (eca) -* 3-19-92: Fix argument 12 in calls to SSYMM with INFOT = 9 (eca) -* -* .. Scalar Arguments .. - INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Parameters .. - REAL ONE, TWO - PARAMETER ( ONE = 1.0E0, TWO = 2.0E0 ) -* .. Local Scalars .. - REAL ALPHA, BETA -* .. Local Arrays .. - REAL A( 2, 1 ), B( 2, 1 ), C( 2, 1 ) -* .. External Subroutines .. - EXTERNAL CHKXER, SGEMM, SSYMM, SSYR2K, SSYRK, STRMM, - $ STRSM -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. -* OK is set to .FALSE. by the special version of XERBLA or by CHKXER -* if anything is wrong. - OK = .TRUE. -* LERR is set to .TRUE. by the special version of XERBLA each time -* it is called, and is then tested and re-set by CHKXER. - LERR = .FALSE. -* -* Initialize ALPHA and BETA. -* - ALPHA = ONE - BETA = TWO -* - GO TO ( 10, 20, 30, 40, 50, 60 )ISNUM - 10 INFOT = 1 - CALL SGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 1 - CALL SGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL SGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL SGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL SGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL SGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL SGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL SGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL SGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL SGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL SGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL SGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL SGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL SGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 - 20 INFOT = 1 - CALL SSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL SSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL SSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 - 30 INFOT = 1 - CALL STRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL STRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL STRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL STRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 - 40 INFOT = 1 - CALL STRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL STRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL STRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL STRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 - 50 INFOT = 1 - CALL SSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SSYRK( 'U', '/', 0, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL SSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL SSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL SSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL SSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 - 60 INFOT = 1 - CALL SSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SSYR2K( 'U', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL SSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL SSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* - 70 IF( OK )THEN - WRITE( NOUT, FMT = 9999 )SRNAMT - ELSE - WRITE( NOUT, FMT = 9998 )SRNAMT - END IF - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) - 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', - $ '**' ) -* -* End of SCHKE. -* - END - SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, - $ TRANSL ) -* -* Generates values for an M by N matrix A. -* Stores the values in the array AA in the data structure required -* by the routine, with unwanted elements set to rogue value. -* -* TYPE is 'GE', 'SY' or 'TR'. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - REAL ZERO, ONE - PARAMETER ( ZERO = 0.0, ONE = 1.0 ) - REAL ROGUE - PARAMETER ( ROGUE = -1.0E10 ) -* .. Scalar Arguments .. - REAL TRANSL - INTEGER LDA, M, N, NMAX - LOGICAL RESET - CHARACTER*1 DIAG, UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - REAL A( NMAX, * ), AA( * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J - LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER -* .. External Functions .. - REAL SBEG - EXTERNAL SBEG -* .. Executable Statements .. - GEN = TYPE.EQ.'GE' - SYM = TYPE.EQ.'SY' - TRI = TYPE.EQ.'TR' - UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' - LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' - UNIT = TRI.AND.DIAG.EQ.'U' -* -* Generate data in array A. -* - DO 20 J = 1, N - DO 10 I = 1, M - IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) - $ THEN - A( I, J ) = SBEG( RESET ) + TRANSL - IF( I.NE.J )THEN -* Set some elements to zero - IF( N.GT.3.AND.J.EQ.N/2 ) - $ A( I, J ) = ZERO - IF( SYM )THEN - A( J, I ) = A( I, J ) - ELSE IF( TRI )THEN - A( J, I ) = ZERO - END IF - END IF - END IF - 10 CONTINUE - IF( TRI ) - $ A( J, J ) = A( J, J ) + ONE - IF( UNIT ) - $ A( J, J ) = ONE - 20 CONTINUE -* -* Store elements in array AS in data structure required by routine. -* - IF( TYPE.EQ.'GE' )THEN - DO 50 J = 1, N - DO 30 I = 1, M - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 30 CONTINUE - DO 40 I = M + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 40 CONTINUE - 50 CONTINUE - ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN - DO 90 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IF( UNIT )THEN - IEND = J - 1 - ELSE - IEND = J - END IF - ELSE - IF( UNIT )THEN - IBEG = J + 1 - ELSE - IBEG = J - END IF - IEND = N - END IF - DO 60 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 60 CONTINUE - DO 70 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 70 CONTINUE - DO 80 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 80 CONTINUE - 90 CONTINUE - END IF - RETURN -* -* End of SMAKE. -* - END - SUBROUTINE SMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, - $ NOUT, MV ) -* -* Checks the results of the computational tests. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - REAL ZERO, ONE - PARAMETER ( ZERO = 0.0, ONE = 1.0 ) -* .. Scalar Arguments .. - REAL ALPHA, BETA, EPS, ERR - INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT - LOGICAL FATAL, MV - CHARACTER*1 TRANSA, TRANSB -* .. Array Arguments .. - REAL A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ CC( LDCC, * ), CT( * ), G( * ) -* .. Local Scalars .. - REAL ERRI - INTEGER I, J, K - LOGICAL TRANA, TRANB -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. Executable Statements .. - TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' - TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' -* -* Compute expected result, one column at a time, in CT using data -* in A, B and C. -* Compute gauges in G. -* - DO 120 J = 1, N -* - DO 10 I = 1, M - CT( I ) = ZERO - G( I ) = ZERO - 10 CONTINUE - IF( .NOT.TRANA.AND..NOT.TRANB )THEN - DO 30 K = 1, KK - DO 20 I = 1, M - CT( I ) = CT( I ) + A( I, K )*B( K, J ) - G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( K, J ) ) - 20 CONTINUE - 30 CONTINUE - ELSE IF( TRANA.AND..NOT.TRANB )THEN - DO 50 K = 1, KK - DO 40 I = 1, M - CT( I ) = CT( I ) + A( K, I )*B( K, J ) - G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( K, J ) ) - 40 CONTINUE - 50 CONTINUE - ELSE IF( .NOT.TRANA.AND.TRANB )THEN - DO 70 K = 1, KK - DO 60 I = 1, M - CT( I ) = CT( I ) + A( I, K )*B( J, K ) - G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( J, K ) ) - 60 CONTINUE - 70 CONTINUE - ELSE IF( TRANA.AND.TRANB )THEN - DO 90 K = 1, KK - DO 80 I = 1, M - CT( I ) = CT( I ) + A( K, I )*B( J, K ) - G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( J, K ) ) - 80 CONTINUE - 90 CONTINUE - END IF - DO 100 I = 1, M - CT( I ) = ALPHA*CT( I ) + BETA*C( I, J ) - G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( I, J ) ) - 100 CONTINUE -* -* Compute the error ratio for this result. -* - ERR = ZERO - DO 110 I = 1, M - ERRI = ABS( CT( I ) - CC( I, J ) )/EPS - IF( G( I ).NE.ZERO ) - $ ERRI = ERRI/G( I ) - ERR = MAX( ERR, ERRI ) - IF( ERR*SQRT( EPS ).GE.ONE ) - $ GO TO 130 - 110 CONTINUE -* - 120 CONTINUE -* -* If the loop completes, all results are at least half accurate. - GO TO 150 -* -* Report fatal error. -* - 130 FATAL = .TRUE. - WRITE( NOUT, FMT = 9999 ) - DO 140 I = 1, M - IF( MV )THEN - WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J ) - ELSE - WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I ) - END IF - 140 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9997 )J -* - 150 CONTINUE - RETURN -* - 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', - $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU', - $ 'TED RESULT' ) - 9998 FORMAT( 1X, I7, 2G18.6 ) - 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) -* -* End of SMMCH. -* - END - LOGICAL FUNCTION LSE( RI, RJ, LR ) -* -* Tests if two arrays are identical. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER LR -* .. Array Arguments .. - REAL RI( * ), RJ( * ) -* .. Local Scalars .. - INTEGER I -* .. Executable Statements .. - DO 10 I = 1, LR - IF( RI( I ).NE.RJ( I ) ) - $ GO TO 20 - 10 CONTINUE - LSE = .TRUE. - GO TO 30 - 20 CONTINUE - LSE = .FALSE. - 30 RETURN -* -* End of LSE. -* - END - LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA ) -* -* Tests if selected elements in two arrays are equal. -* -* TYPE is 'GE' or 'SY'. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER LDA, M, N - CHARACTER*1 UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - REAL AA( LDA, * ), AS( LDA, * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J - LOGICAL UPPER -* .. Executable Statements .. - UPPER = UPLO.EQ.'U' - IF( TYPE.EQ.'GE' )THEN - DO 20 J = 1, N - DO 10 I = M + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 10 CONTINUE - 20 CONTINUE - ELSE IF( TYPE.EQ.'SY' )THEN - DO 50 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 30 I = 1, IBEG - 1 - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 30 CONTINUE - DO 40 I = IEND + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 40 CONTINUE - 50 CONTINUE - END IF -* - LSERES = .TRUE. - GO TO 80 - 70 CONTINUE - LSERES = .FALSE. - 80 RETURN -* -* End of LSERES. -* - END - REAL FUNCTION SBEG( RESET ) -* -* Generates random numbers uniformly distributed between -0.5 and 0.5. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - LOGICAL RESET -* .. Local Scalars .. - INTEGER I, IC, MI -* .. Save statement .. - SAVE I, IC, MI -* .. Executable Statements .. - IF( RESET )THEN -* Initialize local variables. - MI = 891 - I = 7 - IC = 0 - RESET = .FALSE. - END IF -* -* The sequence of values of I is bounded between 1 and 999. -* If initial I = 1,2,3,6,7 or 9, the period will be 50. -* If initial I = 4 or 8, the period will be 25. -* If initial I = 5, the period will be 10. -* IC is used to break up the period by skipping 1 value of I in 6. -* - IC = IC + 1 - 10 I = I*MI - I = I - 1000*( I/1000 ) - IF( IC.GE.5 )THEN - IC = 0 - GO TO 10 - END IF - SBEG = ( I - 500 )/1001.0 - RETURN -* -* End of SBEG. -* - END - REAL FUNCTION SDIFF( X, Y ) -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - REAL X, Y -* .. Executable Statements .. - SDIFF = X - Y - RETURN -* -* End of SDIFF. -* - END - SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* -* Tests whether XERBLA has detected an error when it should. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Executable Statements .. - IF( .NOT.LERR )THEN - WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT - OK = .FALSE. - END IF - LERR = .FALSE. - RETURN -* - 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', - $ 'ETECTED BY ', A6, ' *****' ) -* -* End of CHKXER. -* - END - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* This is a special version of XERBLA to be used only as part of -* the test program for testing error exits from the Level 3 BLAS -* routines. -* -* XERBLA is an error handler for the Level 3 BLAS routines. -* -* It is called by the Level 3 BLAS routines if an input parameter is -* invalid. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER INFO - CHARACTER*6 SRNAME -* .. Scalars in Common .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUT, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Executable Statements .. - LERR = .TRUE. - IF( INFO.NE.INFOT )THEN - IF( INFOT.NE.0 )THEN - WRITE( NOUT, FMT = 9999 )INFO, INFOT - ELSE - WRITE( NOUT, FMT = 9997 )INFO - END IF - OK = .FALSE. - END IF - IF( SRNAME.NE.SRNAMT )THEN - WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT - OK = .FALSE. - END IF - RETURN -* - 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', - $ ' OF ', I2, ' *******' ) - 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', - $ 'AD OF ', A6, ' *******' ) - 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, - $ ' *******' ) -* -* End of XERBLA -* - END - diff --git a/eigen/blas/testing/zblat1.f b/eigen/blas/testing/zblat1.f deleted file mode 100644 index d30112c..0000000 --- a/eigen/blas/testing/zblat1.f +++ /dev/null @@ -1,724 +0,0 @@ -*> \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. -* -*> \date April 2012 -* -*> \ingroup complex16_blas_testing -* -* ===================================================================== - PROGRAM ZBLAT1 -* -* -- Reference BLAS test routine (version 3.4.1) -- -* -- 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, 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 - 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 - 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, J, LEN, NP1 -* .. Local Arrays .. - COMPLEX*16 CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CX(8), - + MWPCS(5), MWPCT(5) - DOUBLE PRECISION STRUE2(5), STRUE4(5) - INTEGER ITRUE3(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 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/ -* .. 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)) - ELSE - WRITE (NOUT,*) ' Shouldn''t be here in CHECK1' - STOP - END IF -* - 40 CONTINUE - 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 - 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, 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), CX(7), CX1(7), CY(7), 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) - 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 - 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 - SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC) -* ************************* STEST1 ***************************** -* -* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE 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 - 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 - 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 - 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 diff --git a/eigen/blas/testing/zblat2.dat b/eigen/blas/testing/zblat2.dat deleted file mode 100644 index c922440..0000000 --- a/eigen/blas/testing/zblat2.dat +++ /dev/null @@ -1,35 +0,0 @@ -'zblat2.summ' NAME OF SUMMARY OUTPUT FILE -6 UNIT NUMBER OF SUMMARY FILE -'cbla2t.snap' NAME OF SNAPSHOT OUTPUT FILE --1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -F LOGICAL FLAG, T TO STOP ON FAILURES. -T LOGICAL FLAG, T TO TEST ERROR EXITS. -16.0 THRESHOLD VALUE OF TEST RATIO -6 NUMBER OF VALUES OF N -0 1 2 3 5 9 VALUES OF N -4 NUMBER OF VALUES OF K -0 1 2 4 VALUES OF K -4 NUMBER OF VALUES OF INCX AND INCY -1 2 -1 -2 VALUES OF INCX AND INCY -3 NUMBER OF VALUES OF ALPHA -(0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA -3 NUMBER OF VALUES OF BETA -(0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA -ZGEMV T PUT F FOR NO TEST. SAME COLUMNS. -ZGBMV T PUT F FOR NO TEST. SAME COLUMNS. -ZHEMV T PUT F FOR NO TEST. SAME COLUMNS. -ZHBMV T PUT F FOR NO TEST. SAME COLUMNS. -ZHPMV T PUT F FOR NO TEST. SAME COLUMNS. -ZTRMV T PUT F FOR NO TEST. SAME COLUMNS. -ZTBMV T PUT F FOR NO TEST. SAME COLUMNS. -ZTPMV T PUT F FOR NO TEST. SAME COLUMNS. -ZTRSV T PUT F FOR NO TEST. SAME COLUMNS. -ZTBSV T PUT F FOR NO TEST. SAME COLUMNS. -ZTPSV T PUT F FOR NO TEST. SAME COLUMNS. -ZGERC T PUT F FOR NO TEST. SAME COLUMNS. -ZGERU T PUT F FOR NO TEST. SAME COLUMNS. -ZHER T PUT F FOR NO TEST. SAME COLUMNS. -ZHPR T PUT F FOR NO TEST. SAME COLUMNS. -ZHER2 T PUT F FOR NO TEST. SAME COLUMNS. -ZHPR2 T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/eigen/blas/testing/zblat2.f b/eigen/blas/testing/zblat2.f deleted file mode 100644 index 53129a1..0000000 --- a/eigen/blas/testing/zblat2.f +++ /dev/null @@ -1,3287 +0,0 @@ -*> \brief \b ZBLAT2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM ZBLAT2 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the COMPLEX*16 Level 2 Blas. -*> -*> The program must be driven by a short data file. The first 18 records -*> of the file are read using list-directed input, the last 17 records -*> are read using the format ( A6, L2 ). An annotated example of a data -*> file can be obtained by deleting the first 3 characters from the -*> following 35 lines: -*> 'zblat2.out' NAME OF SUMMARY OUTPUT FILE -*> 6 UNIT NUMBER OF SUMMARY FILE -*> 'CBLA2T.SNAP' NAME OF SNAPSHOT OUTPUT FILE -*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -*> F LOGICAL FLAG, T TO STOP ON FAILURES. -*> T LOGICAL FLAG, T TO TEST ERROR EXITS. -*> 16.0 THRESHOLD VALUE OF TEST RATIO -*> 6 NUMBER OF VALUES OF N -*> 0 1 2 3 5 9 VALUES OF N -*> 4 NUMBER OF VALUES OF K -*> 0 1 2 4 VALUES OF K -*> 4 NUMBER OF VALUES OF INCX AND INCY -*> 1 2 -1 -2 VALUES OF INCX AND INCY -*> 3 NUMBER OF VALUES OF ALPHA -*> (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA -*> 3 NUMBER OF VALUES OF BETA -*> (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA -*> ZGEMV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZGBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZHEMV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZHBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZHPMV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZTRMV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZTBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZTPMV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZTRSV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZTBSV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZTPSV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZGERC T PUT F FOR NO TEST. SAME COLUMNS. -*> ZGERU T PUT F FOR NO TEST. SAME COLUMNS. -*> ZHER T PUT F FOR NO TEST. SAME COLUMNS. -*> ZHPR T PUT F FOR NO TEST. SAME COLUMNS. -*> ZHER2 T PUT F FOR NO TEST. SAME COLUMNS. -*> ZHPR2 T PUT F FOR NO TEST. SAME COLUMNS. -*> -*> Further Details -*> =============== -*> -*> See: -*> -*> Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. -*> An extended set of Fortran Basic Linear Algebra Subprograms. -*> -*> Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics -*> and Computer Science Division, Argonne National Laboratory, -*> 9700 South Cass Avenue, Argonne, Illinois 60439, US. -*> -*> Or -*> -*> NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms -*> Group Ltd., NAG Central Office, 256 Banbury Road, Oxford -*> OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st -*> Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. -*> -*> -*> -- Written on 10-August-1987. -*> Richard Hanson, Sandia National Labs. -*> Jeremy Du Croz, NAG Central Office. -*> -*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers -*> can be run multiple times without deleting generated -*> output files (susan) -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date April 2012 -* -*> \ingroup complex16_blas_testing -* -* ===================================================================== - PROGRAM ZBLAT2 -* -* -- Reference BLAS test routine (version 3.4.1) -- -* -- 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 NIN - PARAMETER ( NIN = 5 ) - INTEGER NSUBS - PARAMETER ( NSUBS = 17 ) - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ ONE = ( 1.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) - INTEGER NMAX, INCMAX - PARAMETER ( NMAX = 65, INCMAX = 2 ) - INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX - PARAMETER ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7, - $ NALMAX = 7, NBEMAX = 7 ) -* .. Local Scalars .. - DOUBLE PRECISION EPS, ERR, THRESH - INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB, - $ NOUT, NTRA - LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, - $ TSTERR - CHARACTER*1 TRANS - CHARACTER*6 SNAMET - CHARACTER*32 SNAPS, SUMMRY -* .. Local Arrays .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), - $ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ), - $ X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( 2*NMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX ) - LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) -* .. External Functions .. - DOUBLE PRECISION DDIFF - LOGICAL LZE - EXTERNAL DDIFF, LZE -* .. External Subroutines .. - EXTERNAL ZCHK1, ZCHK2, ZCHK3, ZCHK4, ZCHK5, ZCHK6, - $ ZCHKE, ZMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Data statements .. - DATA SNAMES/'ZGEMV ', 'ZGBMV ', 'ZHEMV ', 'ZHBMV ', - $ 'ZHPMV ', 'ZTRMV ', 'ZTBMV ', 'ZTPMV ', - $ 'ZTRSV ', 'ZTBSV ', 'ZTPSV ', 'ZGERC ', - $ 'ZGERU ', 'ZHER ', 'ZHPR ', 'ZHER2 ', - $ 'ZHPR2 '/ -* .. Executable Statements .. -* -* Read name and unit number for summary output file and open file. -* - READ( NIN, FMT = * )SUMMRY - READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) - NOUTC = NOUT -* -* Read name and unit number for snapshot output file and open file. -* - READ( NIN, FMT = * )SNAPS - READ( NIN, FMT = * )NTRA - TRACE = NTRA.GE.0 - IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' ) - END IF -* Read the flag that directs rewinding of the snapshot file. - READ( NIN, FMT = * )REWI - REWI = REWI.AND.TRACE -* Read the flag that directs stopping on any failure. - READ( NIN, FMT = * )SFATAL -* Read the flag that indicates whether error exits are to be tested. - READ( NIN, FMT = * )TSTERR -* Read the threshold value of the test ratio - READ( NIN, FMT = * )THRESH -* -* Read and check the parameter values for the tests. -* -* Values of N - READ( NIN, FMT = * )NIDIM - IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN - WRITE( NOUT, FMT = 9997 )'N', NIDMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) - DO 10 I = 1, NIDIM - IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN - WRITE( NOUT, FMT = 9996 )NMAX - GO TO 230 - END IF - 10 CONTINUE -* Values of K - READ( NIN, FMT = * )NKB - IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN - WRITE( NOUT, FMT = 9997 )'K', NKBMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( KB( I ), I = 1, NKB ) - DO 20 I = 1, NKB - IF( KB( I ).LT.0 )THEN - WRITE( NOUT, FMT = 9995 ) - GO TO 230 - END IF - 20 CONTINUE -* Values of INCX and INCY - READ( NIN, FMT = * )NINC - IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN - WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( INC( I ), I = 1, NINC ) - DO 30 I = 1, NINC - IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN - WRITE( NOUT, FMT = 9994 )INCMAX - GO TO 230 - END IF - 30 CONTINUE -* Values of ALPHA - READ( NIN, FMT = * )NALF - IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN - WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) -* Values of BETA - READ( NIN, FMT = * )NBET - IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN - WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) -* -* Report values of parameters. -* - WRITE( NOUT, FMT = 9993 ) - WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM ) - WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB ) - WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC ) - WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF ) - WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET ) - IF( .NOT.TSTERR )THEN - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9980 ) - END IF - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9999 )THRESH - WRITE( NOUT, FMT = * ) -* -* Read names of subroutines and flags which indicate -* whether they are to be tested. -* - DO 40 I = 1, NSUBS - LTEST( I ) = .FALSE. - 40 CONTINUE - 50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT - DO 60 I = 1, NSUBS - IF( SNAMET.EQ.SNAMES( I ) ) - $ GO TO 70 - 60 CONTINUE - WRITE( NOUT, FMT = 9986 )SNAMET - STOP - 70 LTEST( I ) = LTESTT - GO TO 50 -* - 80 CONTINUE - CLOSE ( NIN ) -* -* Compute EPS (the machine precision). -* - EPS = EPSILON(RZERO) - WRITE( NOUT, FMT = 9998 )EPS -* -* Check the reliability of ZMVCH using exact data. -* - N = MIN( 32, NMAX ) - DO 120 J = 1, N - DO 110 I = 1, N - A( I, J ) = MAX( I - J + 1, 0 ) - 110 CONTINUE - X( J ) = J - Y( J ) = ZERO - 120 CONTINUE - DO 130 J = 1, N - YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 - 130 CONTINUE -* YY holds the exact result. On exit from ZMVCH YT holds -* the result computed by ZMVCH. - TRANS = 'N' - CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LZE( YY, YT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR - STOP - END IF - TRANS = 'T' - CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LZE( YY, YT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR - STOP - END IF -* -* Test each subroutine in turn. -* - DO 210 ISNUM = 1, NSUBS - WRITE( NOUT, FMT = * ) - IF( .NOT.LTEST( ISNUM ) )THEN -* Subprogram is not to be tested. - WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM ) - ELSE - SRNAMT = SNAMES( ISNUM ) -* Test error exits. - IF( TSTERR )THEN - CALL ZCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) - WRITE( NOUT, FMT = * ) - END IF -* Test computations. - INFOT = 0 - OK = .TRUE. - FATAL = .FALSE. - GO TO ( 140, 140, 150, 150, 150, 160, 160, - $ 160, 160, 160, 160, 170, 170, 180, - $ 180, 190, 190 )ISNUM -* Test ZGEMV, 01, and ZGBMV, 02. - 140 CALL ZCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, - $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, - $ X, XX, XS, Y, YY, YS, YT, G ) - GO TO 200 -* Test ZHEMV, 03, ZHBMV, 04, and ZHPMV, 05. - 150 CALL ZCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, - $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, - $ X, XX, XS, Y, YY, YS, YT, G ) - GO TO 200 -* Test ZTRMV, 06, ZTBMV, 07, ZTPMV, 08, -* ZTRSV, 09, ZTBSV, 10, and ZTPSV, 11. - 160 CALL ZCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z ) - GO TO 200 -* Test ZGERC, 12, ZGERU, 13. - 170 CALL ZCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) - GO TO 200 -* Test ZHER, 14, and ZHPR, 15. - 180 CALL ZCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) - GO TO 200 -* Test ZHER2, 16, and ZHPR2, 17. - 190 CALL ZCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) -* - 200 IF( FATAL.AND.SFATAL ) - $ GO TO 220 - END IF - 210 CONTINUE - WRITE( NOUT, FMT = 9982 ) - GO TO 240 -* - 220 CONTINUE - WRITE( NOUT, FMT = 9981 ) - GO TO 240 -* - 230 CONTINUE - WRITE( NOUT, FMT = 9987 ) -* - 240 CONTINUE - IF( TRACE ) - $ CLOSE ( NTRA ) - CLOSE ( NOUT ) - STOP -* - 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', - $ 'S THAN', F8.2 ) - 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 ) - 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', - $ 'THAN ', I2 ) - 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) - 9995 FORMAT( ' VALUE OF K IS LESS THAN 0' ) - 9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ', - $ I2 ) - 9993 FORMAT( ' TESTS OF THE COMPLEX*16 LEVEL 2 BLAS', //' THE F', - $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) - 9992 FORMAT( ' FOR N ', 9I6 ) - 9991 FORMAT( ' FOR K ', 7I6 ) - 9990 FORMAT( ' FOR INCX AND INCY ', 7I6 ) - 9989 FORMAT( ' FOR ALPHA ', - $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) - 9988 FORMAT( ' FOR BETA ', - $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) - 9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', - $ /' ******* TESTS ABANDONED *******' ) - 9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', - $ 'ESTS ABANDONED *******' ) - 9985 FORMAT( ' ERROR IN ZMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', - $ 'ATED WRONGLY.', /' ZMVCH WAS CALLED WITH TRANS = ', A1, - $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', / - $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.' - $ , /' ******* TESTS ABANDONED *******' ) - 9984 FORMAT( A6, L2 ) - 9983 FORMAT( 1X, A6, ' WAS NOT TESTED' ) - 9982 FORMAT( /' END OF TESTS' ) - 9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) - 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) -* -* End of ZBLAT2. -* - END - SUBROUTINE ZCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, - $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, - $ XS, Y, YY, YS, YT, G ) -* -* Tests ZGEMV and ZGBMV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX*16 ZERO, HALF - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ HALF = ( 0.5D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, - $ NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), BET( NBET ), X( NMAX ), - $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), - $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, ALS, BETA, BLS, TRANSL - DOUBLE PRECISION ERR, ERRMAX - INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY, - $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA, - $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK, - $ NL, NS - LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN - CHARACTER*1 TRANS, TRANSS - CHARACTER*3 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZGBMV, ZGEMV, ZMAKE, ZMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'NTC'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'E' - BANDED = SNAME( 3: 3 ).EQ.'B' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 11 - ELSE IF( BANDED )THEN - NARGS = 13 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 120 IN = 1, NIDIM - N = IDIM( IN ) - ND = N/2 + 1 -* - DO 110 IM = 1, 2 - IF( IM.EQ.1 ) - $ M = MAX( N - ND, 0 ) - IF( IM.EQ.2 ) - $ M = MIN( N + ND, NMAX ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IKU = 1, NK - IF( BANDED )THEN - KU = KB( IKU ) - KL = MAX( KU - 1, 0 ) - ELSE - KU = N - 1 - KL = M - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = KL + KU + 1 - ELSE - LDA = M - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - LAA = LDA*N - NULL = N.LE.0.OR.M.LE.0 -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL ZMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, AA, - $ LDA, KL, KU, RESET, TRANSL ) -* - DO 90 IC = 1, 3 - TRANS = ICH( IC: IC ) - TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' -* - IF( TRAN )THEN - ML = N - NL = M - ELSE - ML = M - NL = N - END IF -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*NL -* -* Generate the vector X. -* - TRANSL = HALF - CALL ZMAKE( 'GE', ' ', ' ', 1, NL, X, 1, XX, - $ ABS( INCX ), 0, NL - 1, RESET, TRANSL ) - IF( NL.GT.1 )THEN - X( NL/2 ) = ZERO - XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO - END IF -* - DO 70 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*ML -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL ZMAKE( 'GE', ' ', ' ', 1, ML, Y, 1, - $ YY, ABS( INCY ), 0, ML - 1, - $ RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - TRANSS = TRANS - MS = M - NS = N - KLS = KL - KUS = KU - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - BLS = BETA - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ TRANS, M, N, ALPHA, LDA, INCX, BETA, - $ INCY - IF( REWI ) - $ REWIND NTRA - CALL ZGEMV( TRANS, M, N, ALPHA, AA, - $ LDA, XX, INCX, BETA, YY, - $ INCY ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ TRANS, M, N, KL, KU, ALPHA, LDA, - $ INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL ZGBMV( TRANS, M, N, KL, KU, ALPHA, - $ AA, LDA, XX, INCX, BETA, - $ YY, INCY ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 130 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = TRANS.EQ.TRANSS - ISAME( 2 ) = MS.EQ.M - ISAME( 3 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 4 ) = ALS.EQ.ALPHA - ISAME( 5 ) = LZE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - ISAME( 7 ) = LZE( XS, XX, LX ) - ISAME( 8 ) = INCXS.EQ.INCX - ISAME( 9 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 10 ) = LZE( YS, YY, LY ) - ELSE - ISAME( 10 ) = LZERES( 'GE', ' ', 1, - $ ML, YS, YY, - $ ABS( INCY ) ) - END IF - ISAME( 11 ) = INCYS.EQ.INCY - ELSE IF( BANDED )THEN - ISAME( 4 ) = KLS.EQ.KL - ISAME( 5 ) = KUS.EQ.KU - ISAME( 6 ) = ALS.EQ.ALPHA - ISAME( 7 ) = LZE( AS, AA, LAA ) - ISAME( 8 ) = LDAS.EQ.LDA - ISAME( 9 ) = LZE( XS, XX, LX ) - ISAME( 10 ) = INCXS.EQ.INCX - ISAME( 11 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 12 ) = LZE( YS, YY, LY ) - ELSE - ISAME( 12 ) = LZERES( 'GE', ' ', 1, - $ ML, YS, YY, - $ ABS( INCY ) ) - END IF - ISAME( 13 ) = INCYS.EQ.INCY - END IF -* -* If data was incorrectly changed, report -* and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 130 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL ZMVCH( TRANS, M, N, ALPHA, A, - $ NMAX, X, INCX, BETA, Y, - $ INCY, YT, G, YY, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 130 - ELSE -* Avoid repeating tests with M.le.0 or -* N.le.0. - GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 140 -* - 130 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, TRANS, M, N, ALPHA, LDA, - $ INCX, BETA, INCY - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANS, M, N, KL, KU, - $ ALPHA, LDA, INCX, BETA, INCY - END IF -* - 140 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), '(', - $ F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', - $ F4.1, '), Y,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(', - $ F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', - $ F4.1, '), Y,', I2, ') .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK1. -* - END - SUBROUTINE ZCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, - $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, - $ XS, Y, YY, YS, YT, G ) -* -* Tests ZHEMV, ZHBMV and ZHPMV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX*16 ZERO, HALF - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ HALF = ( 0.5D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, - $ NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), BET( NBET ), X( NMAX ), - $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), - $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, ALS, BETA, BLS, TRANSL - DOUBLE PRECISION ERR, ERRMAX - INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY, - $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY, - $ N, NARGS, NC, NK, NS - LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZHBMV, ZHEMV, ZHPMV, ZMAKE, ZMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'E' - BANDED = SNAME( 3: 3 ).EQ.'B' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 10 - ELSE IF( BANDED )THEN - NARGS = 11 - ELSE IF( PACKED )THEN - NARGS = 9 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 110 IN = 1, NIDIM - N = IDIM( IN ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IK = 1, NK - IF( BANDED )THEN - K = KB( IK ) - ELSE - K = N - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = K + 1 - ELSE - LDA = N - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF - NULL = N.LE.0 -* - DO 90 IC = 1, 2 - UPLO = ICH( IC: IC ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA, - $ LDA, K, K, RESET, TRANSL ) -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL ZMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, - $ ABS( INCX ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 70 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL ZMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, - $ TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - UPLOS = UPLO - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - BLS = BETA - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, N, ALPHA, LDA, INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL ZHEMV( UPLO, N, ALPHA, AA, LDA, XX, - $ INCX, BETA, YY, INCY ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, N, K, ALPHA, LDA, INCX, BETA, - $ INCY - IF( REWI ) - $ REWIND NTRA - CALL ZHBMV( UPLO, N, K, ALPHA, AA, LDA, - $ XX, INCX, BETA, YY, INCY ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, N, ALPHA, INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL ZHPMV( UPLO, N, ALPHA, AA, XX, INCX, - $ BETA, YY, INCY ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LZE( AS, AA, LAA ) - ISAME( 5 ) = LDAS.EQ.LDA - ISAME( 6 ) = LZE( XS, XX, LX ) - ISAME( 7 ) = INCXS.EQ.INCX - ISAME( 8 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 9 ) = LZE( YS, YY, LY ) - ELSE - ISAME( 9 ) = LZERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 10 ) = INCYS.EQ.INCY - ELSE IF( BANDED )THEN - ISAME( 3 ) = KS.EQ.K - ISAME( 4 ) = ALS.EQ.ALPHA - ISAME( 5 ) = LZE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - ISAME( 7 ) = LZE( XS, XX, LX ) - ISAME( 8 ) = INCXS.EQ.INCX - ISAME( 9 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 10 ) = LZE( YS, YY, LY ) - ELSE - ISAME( 10 ) = LZERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 11 ) = INCYS.EQ.INCY - ELSE IF( PACKED )THEN - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LZE( AS, AA, LAA ) - ISAME( 5 ) = LZE( XS, XX, LX ) - ISAME( 6 ) = INCXS.EQ.INCX - ISAME( 7 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 8 ) = LZE( YS, YY, LY ) - ELSE - ISAME( 8 ) = LZERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 9 ) = INCYS.EQ.INCY - END IF -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL ZMVCH( 'N', N, N, ALPHA, A, NMAX, X, - $ INCX, BETA, Y, INCY, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 120 - ELSE -* Avoid repeating tests with N.le.0 - GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, LDA, INCX, - $ BETA, INCY - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, K, ALPHA, LDA, - $ INCX, BETA, INCY - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, N, ALPHA, INCX, - $ BETA, INCY - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', - $ F4.1, '), AP, X,', I2, ',(', F4.1, ',', F4.1, '), Y,', I2, - $ ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(', - $ F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', - $ F4.1, '), Y,', I2, ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', - $ F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', F4.1, '), ', - $ 'Y,', I2, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK2. -* - END - SUBROUTINE ZCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z ) -* -* Tests ZTRMV, ZTBMV, ZTPMV, ZTRSV, ZTBSV and ZTPSV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX*16 ZERO, HALF, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ HALF = ( 0.5D0, 0.0D0 ), - $ ONE = ( 1.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), - $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), - $ XT( NMAX ), XX( NMAX*INCMAX ), Z( NMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - COMPLEX*16 TRANSL - DOUBLE PRECISION ERR, ERRMAX - INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K, - $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS - LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME - CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS - CHARACTER*2 ICHD, ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZMAKE, ZMVCH, ZTBMV, ZTBSV, ZTPMV, ZTPSV, - $ ZTRMV, ZTRSV -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'R' - BANDED = SNAME( 3: 3 ).EQ.'B' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 8 - ELSE IF( BANDED )THEN - NARGS = 9 - ELSE IF( PACKED )THEN - NARGS = 7 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* Set up zero vector for ZMVCH. - DO 10 I = 1, NMAX - Z( I ) = ZERO - 10 CONTINUE -* - DO 110 IN = 1, NIDIM - N = IDIM( IN ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IK = 1, NK - IF( BANDED )THEN - K = KB( IK ) - ELSE - K = N - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = K + 1 - ELSE - LDA = N - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF - NULL = N.LE.0 -* - DO 90 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* - DO 80 ICT = 1, 3 - TRANS = ICHT( ICT: ICT ) -* - DO 70 ICD = 1, 2 - DIAG = ICHD( ICD: ICD ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL ZMAKE( SNAME( 2: 3 ), UPLO, DIAG, N, N, A, - $ NMAX, AA, LDA, K, K, RESET, TRANSL ) -* - DO 60 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL ZMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, - $ ABS( INCX ), 0, N - 1, RESET, - $ TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - DIAGS = DIAG - NS = N - KS = K - DO 20 I = 1, LAA - AS( I ) = AA( I ) - 20 CONTINUE - LDAS = LDA - DO 30 I = 1, LX - XS( I ) = XX( I ) - 30 CONTINUE - INCXS = INCX -* -* Call the subroutine. -* - IF( SNAME( 4: 5 ).EQ.'MV' )THEN - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL ZTRMV( UPLO, TRANS, DIAG, N, AA, LDA, - $ XX, INCX ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, K, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL ZTBMV( UPLO, TRANS, DIAG, N, K, AA, - $ LDA, XX, INCX ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, INCX - IF( REWI ) - $ REWIND NTRA - CALL ZTPMV( UPLO, TRANS, DIAG, N, AA, XX, - $ INCX ) - END IF - ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL ZTRSV( UPLO, TRANS, DIAG, N, AA, LDA, - $ XX, INCX ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, K, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL ZTBSV( UPLO, TRANS, DIAG, N, K, AA, - $ LDA, XX, INCX ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, INCX - IF( REWI ) - $ REWIND NTRA - CALL ZTPSV( UPLO, TRANS, DIAG, N, AA, XX, - $ INCX ) - END IF - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = TRANS.EQ.TRANSS - ISAME( 3 ) = DIAG.EQ.DIAGS - ISAME( 4 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 5 ) = LZE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 7 ) = LZE( XS, XX, LX ) - ELSE - ISAME( 7 ) = LZERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 8 ) = INCXS.EQ.INCX - ELSE IF( BANDED )THEN - ISAME( 5 ) = KS.EQ.K - ISAME( 6 ) = LZE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 8 ) = LZE( XS, XX, LX ) - ELSE - ISAME( 8 ) = LZERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 9 ) = INCXS.EQ.INCX - ELSE IF( PACKED )THEN - ISAME( 5 ) = LZE( AS, AA, LAA ) - IF( NULL )THEN - ISAME( 6 ) = LZE( XS, XX, LX ) - ELSE - ISAME( 6 ) = LZERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 7 ) = INCXS.EQ.INCX - END IF -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN - IF( SNAME( 4: 5 ).EQ.'MV' )THEN -* -* Check the result. -* - CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, X, - $ INCX, ZERO, Z, INCX, XT, G, - $ XX, EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN -* -* Compute approximation to original vector. -* - DO 50 I = 1, N - Z( I ) = XX( 1 + ( I - 1 )* - $ ABS( INCX ) ) - XX( 1 + ( I - 1 )*ABS( INCX ) ) - $ = X( I ) - 50 CONTINUE - CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, Z, - $ INCX, ZERO, X, INCX, XT, G, - $ XX, EPS, ERR, FATAL, NOUT, - $ .FALSE. ) - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 120 - ELSE -* Avoid repeating tests with N.le.0. - GO TO 110 - END IF -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, DIAG, N, LDA, - $ INCX - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, DIAG, N, K, - $ LDA, INCX - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, TRANS, DIAG, N, INCX - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', AP, ', - $ 'X,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ), - $ ' A,', I3, ', X,', I2, ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,', - $ I3, ', X,', I2, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK3. -* - END - SUBROUTINE ZCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests ZGERC and ZGERU. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX*16 ZERO, HALF, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ HALF = ( 0.5D0, 0.0D0 ), - $ ONE = ( 1.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, ALS, TRANSL - DOUBLE PRECISION ERR, ERRMAX - INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX, - $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS, - $ NC, ND, NS - LOGICAL CONJ, NULL, RESET, SAME -* .. Local Arrays .. - COMPLEX*16 W( 1 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZGERC, ZGERU, ZMAKE, ZMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, DCONJG, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. - CONJ = SNAME( 5: 5 ).EQ.'C' -* Define the number of arguments. - NARGS = 9 -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 120 IN = 1, NIDIM - N = IDIM( IN ) - ND = N/2 + 1 -* - DO 110 IM = 1, 2 - IF( IM.EQ.1 ) - $ M = MAX( N - ND, 0 ) - IF( IM.EQ.2 ) - $ M = MIN( N + ND, NMAX ) -* -* Set LDA to 1 more than minimum value if room. - LDA = M - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 110 - LAA = LDA*N - NULL = N.LE.0.OR.M.LE.0 -* - DO 100 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*M -* -* Generate the vector X. -* - TRANSL = HALF - CALL ZMAKE( 'GE', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ), - $ 0, M - 1, RESET, TRANSL ) - IF( M.GT.1 )THEN - X( M/2 ) = ZERO - XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO - END IF -* - DO 90 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL ZMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - Y( N/2 ) = ZERO - YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 80 IA = 1, NALF - ALPHA = ALF( IA ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL ZMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, - $ AA, LDA, M - 1, N - 1, RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - MS = M - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N, - $ ALPHA, INCX, INCY, LDA - IF( CONJ )THEN - IF( REWI ) - $ REWIND NTRA - CALL ZGERC( M, N, ALPHA, XX, INCX, YY, INCY, AA, - $ LDA ) - ELSE - IF( REWI ) - $ REWIND NTRA - CALL ZGERU( M, N, ALPHA, XX, INCX, YY, INCY, AA, - $ LDA ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 140 - END IF -* -* See what data changed inside subroutine. -* - ISAME( 1 ) = MS.EQ.M - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LZE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - ISAME( 6 ) = LZE( YS, YY, LY ) - ISAME( 7 ) = INCYS.EQ.INCY - IF( NULL )THEN - ISAME( 8 ) = LZE( AS, AA, LAA ) - ELSE - ISAME( 8 ) = LZERES( 'GE', ' ', M, N, AS, AA, - $ LDA ) - END IF - ISAME( 9 ) = LDAS.EQ.LDA -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 140 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 50 I = 1, M - Z( I ) = X( I ) - 50 CONTINUE - ELSE - DO 60 I = 1, M - Z( I ) = X( M - I + 1 ) - 60 CONTINUE - END IF - DO 70 J = 1, N - IF( INCY.GT.0 )THEN - W( 1 ) = Y( J ) - ELSE - W( 1 ) = Y( N - J + 1 ) - END IF - IF( CONJ ) - $ W( 1 ) = DCONJG( W( 1 ) ) - CALL ZMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1, - $ ONE, A( 1, J ), 1, YT, G, - $ AA( 1 + ( J - 1 )*LDA ), EPS, - $ ERR, FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 130 - 70 CONTINUE - ELSE -* Avoid repeating tests with M.le.0 or N.le.0. - GO TO 110 - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 150 -* - 130 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 140 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA -* - 150 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), '(', F4.1, ',', F4.1, - $ '), X,', I2, ', Y,', I2, ', A,', I3, ') ', - $ ' .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK4. -* - END - SUBROUTINE ZCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests ZHER and ZHPR. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX*16 ZERO, HALF, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ HALF = ( 0.5D0, 0.0D0 ), - $ ONE = ( 1.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, TRANSL - DOUBLE PRECISION ERR, ERRMAX, RALPHA, RALS - INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA, - $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS - LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - COMPLEX*16 W( 1 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZHER, ZHPR, ZMAKE, ZMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCMPLX, DCONJG, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'E' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 7 - ELSE IF( PACKED )THEN - NARGS = 6 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDA to 1 more than minimum value if room. - LDA = N - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF -* - DO 90 IC = 1, 2 - UPLO = ICH( IC: IC ) - UPPER = UPLO.EQ.'U' -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL ZMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), - $ 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 70 IA = 1, NALF - RALPHA = DBLE( ALF( IA ) ) - ALPHA = DCMPLX( RALPHA, RZERO ) - NULL = N.LE.0.OR.RALPHA.EQ.RZERO -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, - $ AA, LDA, N - 1, N - 1, RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - NS = N - RALS = RALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, - $ RALPHA, INCX, LDA - IF( REWI ) - $ REWIND NTRA - CALL ZHER( UPLO, N, RALPHA, XX, INCX, AA, LDA ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, - $ RALPHA, INCX - IF( REWI ) - $ REWIND NTRA - CALL ZHPR( UPLO, N, RALPHA, XX, INCX, AA ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = RALS.EQ.RALPHA - ISAME( 4 ) = LZE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - IF( NULL )THEN - ISAME( 6 ) = LZE( AS, AA, LAA ) - ELSE - ISAME( 6 ) = LZERES( SNAME( 2: 3 ), UPLO, N, N, AS, - $ AA, LDA ) - END IF - IF( .NOT.PACKED )THEN - ISAME( 7 ) = LDAS.EQ.LDA - END IF -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 30 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 30 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 40 I = 1, N - Z( I ) = X( I ) - 40 CONTINUE - ELSE - DO 50 I = 1, N - Z( I ) = X( N - I + 1 ) - 50 CONTINUE - END IF - JA = 1 - DO 60 J = 1, N - W( 1 ) = DCONJG( Z( J ) ) - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - CALL ZMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W, - $ 1, ONE, A( JJ, J ), 1, YT, G, - $ AA( JA ), EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - IF( FULL )THEN - IF( UPPER )THEN - JA = JA + LDA - ELSE - JA = JA + LDA + 1 - END IF - ELSE - JA = JA + LJ - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 110 - 60 CONTINUE - ELSE -* Avoid repeating tests if N.le.0. - IF( N.LE.0 ) - $ GO TO 100 - END IF -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 110 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, RALPHA, INCX, LDA - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, RALPHA, INCX - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', AP) .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', A,', I3, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK5. -* - END - SUBROUTINE ZCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests ZHER2 and ZHPR2. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX*16 ZERO, HALF, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ HALF = ( 0.5D0, 0.0D0 ), - $ ONE = ( 1.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX, 2 ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, ALS, TRANSL - DOUBLE PRECISION ERR, ERRMAX - INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX, - $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N, - $ NARGS, NC, NS - LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - COMPLEX*16 W( 2 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZHER2, ZHPR2, ZMAKE, ZMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, DCONJG, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'E' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 9 - ELSE IF( PACKED )THEN - NARGS = 8 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 140 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDA to 1 more than minimum value if room. - LDA = N - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 140 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF -* - DO 130 IC = 1, 2 - UPLO = ICH( IC: IC ) - UPPER = UPLO.EQ.'U' -* - DO 120 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL ZMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), - $ 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 110 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL ZMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - Y( N/2 ) = ZERO - YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 100 IA = 1, NALF - ALPHA = ALF( IA ) - NULL = N.LE.0.OR.ALPHA.EQ.ZERO -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, - $ NMAX, AA, LDA, N - 1, N - 1, RESET, - $ TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, - $ ALPHA, INCX, INCY, LDA - IF( REWI ) - $ REWIND NTRA - CALL ZHER2( UPLO, N, ALPHA, XX, INCX, YY, INCY, - $ AA, LDA ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, - $ ALPHA, INCX, INCY - IF( REWI ) - $ REWIND NTRA - CALL ZHPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, - $ AA ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 160 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LZE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - ISAME( 6 ) = LZE( YS, YY, LY ) - ISAME( 7 ) = INCYS.EQ.INCY - IF( NULL )THEN - ISAME( 8 ) = LZE( AS, AA, LAA ) - ELSE - ISAME( 8 ) = LZERES( SNAME( 2: 3 ), UPLO, N, N, - $ AS, AA, LDA ) - END IF - IF( .NOT.PACKED )THEN - ISAME( 9 ) = LDAS.EQ.LDA - END IF -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 160 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 50 I = 1, N - Z( I, 1 ) = X( I ) - 50 CONTINUE - ELSE - DO 60 I = 1, N - Z( I, 1 ) = X( N - I + 1 ) - 60 CONTINUE - END IF - IF( INCY.GT.0 )THEN - DO 70 I = 1, N - Z( I, 2 ) = Y( I ) - 70 CONTINUE - ELSE - DO 80 I = 1, N - Z( I, 2 ) = Y( N - I + 1 ) - 80 CONTINUE - END IF - JA = 1 - DO 90 J = 1, N - W( 1 ) = ALPHA*DCONJG( Z( J, 2 ) ) - W( 2 ) = DCONJG( ALPHA )*DCONJG( Z( J, 1 ) ) - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - CALL ZMVCH( 'N', LJ, 2, ONE, Z( JJ, 1 ), - $ NMAX, W, 1, ONE, A( JJ, J ), 1, - $ YT, G, AA( JA ), EPS, ERR, FATAL, - $ NOUT, .TRUE. ) - IF( FULL )THEN - IF( UPPER )THEN - JA = JA + LDA - ELSE - JA = JA + LDA + 1 - END IF - ELSE - JA = JA + LJ - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 150 - 90 CONTINUE - ELSE -* Avoid repeating tests with N.le.0. - IF( N.LE.0 ) - $ GO TO 140 - END IF -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* - 140 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 170 -* - 150 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 160 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, - $ INCY, LDA - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX, INCY - END IF -* - 170 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', - $ F4.1, '), X,', I2, ', Y,', I2, ', AP) ', - $ ' .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', - $ F4.1, '), X,', I2, ', Y,', I2, ', A,', I3, ') ', - $ ' .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK6. -* - END - SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT ) -* -* Tests the error exits from the Level 2 Blas. -* Requires a special version of the error-handling routine XERBLA. -* ALPHA, RALPHA, BETA, A, X and Y should not need to be defined. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Local Scalars .. - COMPLEX*16 ALPHA, BETA - DOUBLE PRECISION RALPHA -* .. Local Arrays .. - COMPLEX*16 A( 1, 1 ), X( 1 ), Y( 1 ) -* .. External Subroutines .. - EXTERNAL CHKXER, ZGBMV, ZGEMV, ZGERC, ZGERU, ZHBMV, - $ ZHEMV, ZHER, ZHER2, ZHPMV, ZHPR, ZHPR2, ZTBMV, - $ ZTBSV, ZTPMV, ZTPSV, ZTRMV, ZTRSV -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. -* OK is set to .FALSE. by the special version of XERBLA or by CHKXER -* if anything is wrong. - OK = .TRUE. -* LERR is set to .TRUE. by the special version of XERBLA each time -* it is called, and is then tested and re-set by CHKXER. - LERR = .FALSE. - GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, - $ 90, 100, 110, 120, 130, 140, 150, 160, - $ 170 )ISNUM - 10 INFOT = 1 - CALL ZGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 20 INFOT = 1 - CALL ZGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZGBMV( 'N', -1, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGBMV( 'N', 0, -1, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZGBMV( 'N', 0, 0, -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGBMV( 'N', 2, 0, 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGBMV( 'N', 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL ZGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 30 INFOT = 1 - CALL ZHEMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZHEMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZHEMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHEMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZHEMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 40 INFOT = 1 - CALL ZHBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZHBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZHBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZHBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZHBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 50 INFOT = 1 - CALL ZHPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZHPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZHPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZHPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 60 INFOT = 1 - CALL ZTRMV( '/', 'N', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZTRMV( 'U', '/', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZTRMV( 'U', 'N', '/', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZTRMV( 'U', 'N', 'N', -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMV( 'U', 'N', 'N', 2, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZTRMV( 'U', 'N', 'N', 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 70 INFOT = 1 - CALL ZTBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZTBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZTBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZTBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZTBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 80 INFOT = 1 - CALL ZTPMV( '/', 'N', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZTPMV( 'U', '/', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZTPMV( 'U', 'N', '/', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZTPMV( 'U', 'N', 'N', -1, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZTPMV( 'U', 'N', 'N', 0, A, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 90 INFOT = 1 - CALL ZTRSV( '/', 'N', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZTRSV( 'U', '/', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZTRSV( 'U', 'N', '/', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZTRSV( 'U', 'N', 'N', -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSV( 'U', 'N', 'N', 2, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZTRSV( 'U', 'N', 'N', 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 100 INFOT = 1 - CALL ZTBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZTBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZTBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZTBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZTBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 110 INFOT = 1 - CALL ZTPSV( '/', 'N', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZTPSV( 'U', '/', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZTPSV( 'U', 'N', '/', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZTPSV( 'U', 'N', 'N', -1, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZTPSV( 'U', 'N', 'N', 0, A, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 120 INFOT = 1 - CALL ZGERC( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZGERC( 0, -1, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGERC( 0, 0, ALPHA, X, 0, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZGERC( 0, 0, ALPHA, X, 1, Y, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZGERC( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 130 INFOT = 1 - CALL ZGERU( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZGERU( 0, -1, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGERU( 0, 0, ALPHA, X, 0, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZGERU( 0, 0, ALPHA, X, 1, Y, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZGERU( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 140 INFOT = 1 - CALL ZHER( '/', 0, RALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZHER( 'U', -1, RALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZHER( 'U', 0, RALPHA, X, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHER( 'U', 2, RALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 150 INFOT = 1 - CALL ZHPR( '/', 0, RALPHA, X, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZHPR( 'U', -1, RALPHA, X, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZHPR( 'U', 0, RALPHA, X, 0, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 160 INFOT = 1 - CALL ZHER2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZHER2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZHER2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHER2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZHER2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 170 INFOT = 1 - CALL ZHPR2( '/', 0, ALPHA, X, 1, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZHPR2( 'U', -1, ALPHA, X, 1, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZHPR2( 'U', 0, ALPHA, X, 0, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHPR2( 'U', 0, ALPHA, X, 1, Y, 0, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* - 180 IF( OK )THEN - WRITE( NOUT, FMT = 9999 )SRNAMT - ELSE - WRITE( NOUT, FMT = 9998 )SRNAMT - END IF - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) - 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', - $ '**' ) -* -* End of ZCHKE. -* - END - SUBROUTINE ZMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, - $ KU, RESET, TRANSL ) -* -* Generates values for an M by N matrix A within the bandwidth -* defined by KL and KU. -* Stores the values in the array AA in the data structure required -* by the routine, with unwanted elements set to rogue value. -* -* TYPE is 'GE', 'GB', 'HE', 'HB', 'HP', 'TR', 'TB' OR 'TP'. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ ONE = ( 1.0D0, 0.0D0 ) ) - COMPLEX*16 ROGUE - PARAMETER ( ROGUE = ( -1.0D10, 1.0D10 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) - DOUBLE PRECISION RROGUE - PARAMETER ( RROGUE = -1.0D10 ) -* .. Scalar Arguments .. - COMPLEX*16 TRANSL - INTEGER KL, KU, LDA, M, N, NMAX - LOGICAL RESET - CHARACTER*1 DIAG, UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - COMPLEX*16 A( NMAX, * ), AA( * ) -* .. Local Scalars .. - INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, JJ, KK - LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER -* .. External Functions .. - COMPLEX*16 ZBEG - EXTERNAL ZBEG -* .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, DCONJG, MAX, MIN -* .. Executable Statements .. - GEN = TYPE( 1: 1 ).EQ.'G' - SYM = TYPE( 1: 1 ).EQ.'H' - TRI = TYPE( 1: 1 ).EQ.'T' - UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' - LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' - UNIT = TRI.AND.DIAG.EQ.'U' -* -* Generate data in array A. -* - DO 20 J = 1, N - DO 10 I = 1, M - IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) - $ THEN - IF( ( I.LE.J.AND.J - I.LE.KU ).OR. - $ ( I.GE.J.AND.I - J.LE.KL ) )THEN - A( I, J ) = ZBEG( RESET ) + TRANSL - ELSE - A( I, J ) = ZERO - END IF - IF( I.NE.J )THEN - IF( SYM )THEN - A( J, I ) = DCONJG( A( I, J ) ) - ELSE IF( TRI )THEN - A( J, I ) = ZERO - END IF - END IF - END IF - 10 CONTINUE - IF( SYM ) - $ A( J, J ) = DCMPLX( DBLE( A( J, J ) ), RZERO ) - IF( TRI ) - $ A( J, J ) = A( J, J ) + ONE - IF( UNIT ) - $ A( J, J ) = ONE - 20 CONTINUE -* -* Store elements in array AS in data structure required by routine. -* - IF( TYPE.EQ.'GE' )THEN - DO 50 J = 1, N - DO 30 I = 1, M - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 30 CONTINUE - DO 40 I = M + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 40 CONTINUE - 50 CONTINUE - ELSE IF( TYPE.EQ.'GB' )THEN - DO 90 J = 1, N - DO 60 I1 = 1, KU + 1 - J - AA( I1 + ( J - 1 )*LDA ) = ROGUE - 60 CONTINUE - DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J ) - AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J ) - 70 CONTINUE - DO 80 I3 = I2, LDA - AA( I3 + ( J - 1 )*LDA ) = ROGUE - 80 CONTINUE - 90 CONTINUE - ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'TR' )THEN - DO 130 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IF( UNIT )THEN - IEND = J - 1 - ELSE - IEND = J - END IF - ELSE - IF( UNIT )THEN - IBEG = J + 1 - ELSE - IBEG = J - END IF - IEND = N - END IF - DO 100 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 100 CONTINUE - DO 110 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 110 CONTINUE - DO 120 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 120 CONTINUE - IF( SYM )THEN - JJ = J + ( J - 1 )*LDA - AA( JJ ) = DCMPLX( DBLE( AA( JJ ) ), RROGUE ) - END IF - 130 CONTINUE - ELSE IF( TYPE.EQ.'HB'.OR.TYPE.EQ.'TB' )THEN - DO 170 J = 1, N - IF( UPPER )THEN - KK = KL + 1 - IBEG = MAX( 1, KL + 2 - J ) - IF( UNIT )THEN - IEND = KL - ELSE - IEND = KL + 1 - END IF - ELSE - KK = 1 - IF( UNIT )THEN - IBEG = 2 - ELSE - IBEG = 1 - END IF - IEND = MIN( KL + 1, 1 + M - J ) - END IF - DO 140 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 140 CONTINUE - DO 150 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J ) - 150 CONTINUE - DO 160 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 160 CONTINUE - IF( SYM )THEN - JJ = KK + ( J - 1 )*LDA - AA( JJ ) = DCMPLX( DBLE( AA( JJ ) ), RROGUE ) - END IF - 170 CONTINUE - ELSE IF( TYPE.EQ.'HP'.OR.TYPE.EQ.'TP' )THEN - IOFF = 0 - DO 190 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 180 I = IBEG, IEND - IOFF = IOFF + 1 - AA( IOFF ) = A( I, J ) - IF( I.EQ.J )THEN - IF( UNIT ) - $ AA( IOFF ) = ROGUE - IF( SYM ) - $ AA( IOFF ) = DCMPLX( DBLE( AA( IOFF ) ), RROGUE ) - END IF - 180 CONTINUE - 190 CONTINUE - END IF - RETURN -* -* End of ZMAKE. -* - END - SUBROUTINE ZMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, - $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV ) -* -* Checks the results of the computational tests. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO, RONE - PARAMETER ( RZERO = 0.0D0, RONE = 1.0D0 ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA, BETA - DOUBLE PRECISION EPS, ERR - INTEGER INCX, INCY, M, N, NMAX, NOUT - LOGICAL FATAL, MV - CHARACTER*1 TRANS -* .. Array Arguments .. - COMPLEX*16 A( NMAX, * ), X( * ), Y( * ), YT( * ), YY( * ) - DOUBLE PRECISION G( * ) -* .. Local Scalars .. - COMPLEX*16 C - DOUBLE PRECISION ERRI - INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL - LOGICAL CTRAN, TRAN -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, SQRT -* .. Statement Functions .. - DOUBLE PRECISION ABS1 -* .. Statement Function definitions .. - ABS1( C ) = ABS( DBLE( C ) ) + ABS( DIMAG( C ) ) -* .. Executable Statements .. - TRAN = TRANS.EQ.'T' - CTRAN = TRANS.EQ.'C' - IF( TRAN.OR.CTRAN )THEN - ML = N - NL = M - ELSE - ML = M - NL = N - END IF - IF( INCX.LT.0 )THEN - KX = NL - INCXL = -1 - ELSE - KX = 1 - INCXL = 1 - END IF - IF( INCY.LT.0 )THEN - KY = ML - INCYL = -1 - ELSE - KY = 1 - INCYL = 1 - END IF -* -* Compute expected result in YT using data in A, X and Y. -* Compute gauges in G. -* - IY = KY - DO 40 I = 1, ML - YT( IY ) = ZERO - G( IY ) = RZERO - JX = KX - IF( TRAN )THEN - DO 10 J = 1, NL - YT( IY ) = YT( IY ) + A( J, I )*X( JX ) - G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) ) - JX = JX + INCXL - 10 CONTINUE - ELSE IF( CTRAN )THEN - DO 20 J = 1, NL - YT( IY ) = YT( IY ) + DCONJG( A( J, I ) )*X( JX ) - G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) ) - JX = JX + INCXL - 20 CONTINUE - ELSE - DO 30 J = 1, NL - YT( IY ) = YT( IY ) + A( I, J )*X( JX ) - G( IY ) = G( IY ) + ABS1( A( I, J ) )*ABS1( X( JX ) ) - JX = JX + INCXL - 30 CONTINUE - END IF - YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY ) - G( IY ) = ABS1( ALPHA )*G( IY ) + ABS1( BETA )*ABS1( Y( IY ) ) - IY = IY + INCYL - 40 CONTINUE -* -* Compute the error ratio for this result. -* - ERR = ZERO - DO 50 I = 1, ML - ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS - IF( G( I ).NE.RZERO ) - $ ERRI = ERRI/G( I ) - ERR = MAX( ERR, ERRI ) - IF( ERR*SQRT( EPS ).GE.RONE ) - $ GO TO 60 - 50 CONTINUE -* If the loop completes, all results are at least half accurate. - GO TO 80 -* -* Report fatal error. -* - 60 FATAL = .TRUE. - WRITE( NOUT, FMT = 9999 ) - DO 70 I = 1, ML - IF( MV )THEN - WRITE( NOUT, FMT = 9998 )I, YT( I ), - $ YY( 1 + ( I - 1 )*ABS( INCY ) ) - ELSE - WRITE( NOUT, FMT = 9998 )I, - $ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT( I ) - END IF - 70 CONTINUE -* - 80 CONTINUE - RETURN -* - 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', - $ 'F ACCURATE *******', /' EXPECTED RE', - $ 'SULT COMPUTED RESULT' ) - 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) ) -* -* End of ZMVCH. -* - END - LOGICAL FUNCTION LZE( RI, RJ, LR ) -* -* Tests if two arrays are identical. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER LR -* .. Array Arguments .. - COMPLEX*16 RI( * ), RJ( * ) -* .. Local Scalars .. - INTEGER I -* .. Executable Statements .. - DO 10 I = 1, LR - IF( RI( I ).NE.RJ( I ) ) - $ GO TO 20 - 10 CONTINUE - LZE = .TRUE. - GO TO 30 - 20 CONTINUE - LZE = .FALSE. - 30 RETURN -* -* End of LZE. -* - END - LOGICAL FUNCTION LZERES( TYPE, UPLO, M, N, AA, AS, LDA ) -* -* Tests if selected elements in two arrays are equal. -* -* TYPE is 'GE', 'HE' or 'HP'. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER LDA, M, N - CHARACTER*1 UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - COMPLEX*16 AA( LDA, * ), AS( LDA, * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J - LOGICAL UPPER -* .. Executable Statements .. - UPPER = UPLO.EQ.'U' - IF( TYPE.EQ.'GE' )THEN - DO 20 J = 1, N - DO 10 I = M + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 10 CONTINUE - 20 CONTINUE - ELSE IF( TYPE.EQ.'HE' )THEN - DO 50 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 30 I = 1, IBEG - 1 - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 30 CONTINUE - DO 40 I = IEND + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 40 CONTINUE - 50 CONTINUE - END IF -* - LZERES = .TRUE. - GO TO 80 - 70 CONTINUE - LZERES = .FALSE. - 80 RETURN -* -* End of LZERES. -* - END - COMPLEX*16 FUNCTION ZBEG( RESET ) -* -* Generates complex numbers as pairs of random numbers uniformly -* distributed between -0.5 and 0.5. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - LOGICAL RESET -* .. Local Scalars .. - INTEGER I, IC, J, MI, MJ -* .. Save statement .. - SAVE I, IC, J, MI, MJ -* .. Intrinsic Functions .. - INTRINSIC DCMPLX -* .. Executable Statements .. - IF( RESET )THEN -* Initialize local variables. - MI = 891 - MJ = 457 - I = 7 - J = 7 - IC = 0 - RESET = .FALSE. - END IF -* -* The sequence of values of I or J is bounded between 1 and 999. -* If initial I or J = 1,2,3,6,7 or 9, the period will be 50. -* If initial I or J = 4 or 8, the period will be 25. -* If initial I or J = 5, the period will be 10. -* IC is used to break up the period by skipping 1 value of I or J -* in 6. -* - IC = IC + 1 - 10 I = I*MI - J = J*MJ - I = I - 1000*( I/1000 ) - J = J - 1000*( J/1000 ) - IF( IC.GE.5 )THEN - IC = 0 - GO TO 10 - END IF - ZBEG = DCMPLX( ( I - 500 )/1001.0D0, ( J - 500 )/1001.0D0 ) - RETURN -* -* End of ZBEG. -* - END - DOUBLE PRECISION FUNCTION DDIFF( X, Y ) -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* -* .. Scalar Arguments .. - DOUBLE PRECISION X, Y -* .. Executable Statements .. - DDIFF = X - Y - RETURN -* -* End of DDIFF. -* - END - SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* -* Tests whether XERBLA has detected an error when it should. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Executable Statements .. - IF( .NOT.LERR )THEN - WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT - OK = .FALSE. - END IF - LERR = .FALSE. - RETURN -* - 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', - $ 'ETECTED BY ', A6, ' *****' ) -* -* End of CHKXER. -* - END - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* This is a special version of XERBLA to be used only as part of -* the test program for testing error exits from the Level 2 BLAS -* routines. -* -* XERBLA is an error handler for the Level 2 BLAS routines. -* -* It is called by the Level 2 BLAS routines if an input parameter is -* invalid. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER INFO - CHARACTER*6 SRNAME -* .. Scalars in Common .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUT, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Executable Statements .. - LERR = .TRUE. - IF( INFO.NE.INFOT )THEN - IF( INFOT.NE.0 )THEN - WRITE( NOUT, FMT = 9999 )INFO, INFOT - ELSE - WRITE( NOUT, FMT = 9997 )INFO - END IF - OK = .FALSE. - END IF - IF( SRNAME.NE.SRNAMT )THEN - WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT - OK = .FALSE. - END IF - RETURN -* - 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', - $ ' OF ', I2, ' *******' ) - 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', - $ 'AD OF ', A6, ' *******' ) - 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, - $ ' *******' ) -* -* End of XERBLA -* - END - diff --git a/eigen/blas/testing/zblat3.dat b/eigen/blas/testing/zblat3.dat deleted file mode 100644 index ede516f..0000000 --- a/eigen/blas/testing/zblat3.dat +++ /dev/null @@ -1,23 +0,0 @@ -'zblat3.summ' NAME OF SUMMARY OUTPUT FILE -6 UNIT NUMBER OF SUMMARY FILE -'zblat3.snap' NAME OF SNAPSHOT OUTPUT FILE --1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -F LOGICAL FLAG, T TO STOP ON FAILURES. -F LOGICAL FLAG, T TO TEST ERROR EXITS. -16.0 THRESHOLD VALUE OF TEST RATIO -6 NUMBER OF VALUES OF N -0 1 2 3 5 9 VALUES OF N -3 NUMBER OF VALUES OF ALPHA -(0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA -3 NUMBER OF VALUES OF BETA -(0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA -ZGEMM T PUT F FOR NO TEST. SAME COLUMNS. -ZHEMM T PUT F FOR NO TEST. SAME COLUMNS. -ZSYMM T PUT F FOR NO TEST. SAME COLUMNS. -ZTRMM T PUT F FOR NO TEST. SAME COLUMNS. -ZTRSM T PUT F FOR NO TEST. SAME COLUMNS. -ZHERK T PUT F FOR NO TEST. SAME COLUMNS. -ZSYRK T PUT F FOR NO TEST. SAME COLUMNS. -ZHER2K T PUT F FOR NO TEST. SAME COLUMNS. -ZSYR2K T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/eigen/blas/testing/zblat3.f b/eigen/blas/testing/zblat3.f deleted file mode 100644 index 59ca241..0000000 --- a/eigen/blas/testing/zblat3.f +++ /dev/null @@ -1,3502 +0,0 @@ -*> \brief \b ZBLAT3 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM ZBLAT3 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the COMPLEX*16 Level 3 Blas. -*> -*> The program must be driven by a short data file. The first 14 records -*> of the file are read using list-directed input, the last 9 records -*> are read using the format ( A6, L2 ). An annotated example of a data -*> file can be obtained by deleting the first 3 characters from the -*> following 23 lines: -*> 'zblat3.out' NAME OF SUMMARY OUTPUT FILE -*> 6 UNIT NUMBER OF SUMMARY FILE -*> 'ZBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE -*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -*> F LOGICAL FLAG, T TO STOP ON FAILURES. -*> T LOGICAL FLAG, T TO TEST ERROR EXITS. -*> 16.0 THRESHOLD VALUE OF TEST RATIO -*> 6 NUMBER OF VALUES OF N -*> 0 1 2 3 5 9 VALUES OF N -*> 3 NUMBER OF VALUES OF ALPHA -*> (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA -*> 3 NUMBER OF VALUES OF BETA -*> (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA -*> ZGEMM T PUT F FOR NO TEST. SAME COLUMNS. -*> ZHEMM T PUT F FOR NO TEST. SAME COLUMNS. -*> ZSYMM T PUT F FOR NO TEST. SAME COLUMNS. -*> ZTRMM T PUT F FOR NO TEST. SAME COLUMNS. -*> ZTRSM T PUT F FOR NO TEST. SAME COLUMNS. -*> ZHERK T PUT F FOR NO TEST. SAME COLUMNS. -*> ZSYRK T PUT F FOR NO TEST. SAME COLUMNS. -*> ZHER2K T PUT F FOR NO TEST. SAME COLUMNS. -*> ZSYR2K T PUT F FOR NO TEST. SAME COLUMNS. -*> -*> -*> Further Details -*> =============== -*> -*> See: -*> -*> Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. -*> A Set of Level 3 Basic Linear Algebra Subprograms. -*> -*> Technical Memorandum No.88 (Revision 1), Mathematics and -*> Computer Science Division, Argonne National Laboratory, 9700 -*> South Cass Avenue, Argonne, Illinois 60439, US. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> -*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers -*> can be run multiple times without deleting generated -*> output files (susan) -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date April 2012 -* -*> \ingroup complex16_blas_testing -* -* ===================================================================== - PROGRAM ZBLAT3 -* -* -- Reference BLAS test routine (version 3.4.1) -- -* -- 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 NIN - PARAMETER ( NIN = 5 ) - INTEGER NSUBS - PARAMETER ( NSUBS = 9 ) - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ ONE = ( 1.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) - INTEGER NMAX - PARAMETER ( NMAX = 65 ) - INTEGER NIDMAX, NALMAX, NBEMAX - PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 ) -* .. Local Scalars .. - DOUBLE PRECISION EPS, ERR, THRESH - INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA - LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, - $ TSTERR - CHARACTER*1 TRANSA, TRANSB - CHARACTER*6 SNAMET - CHARACTER*32 SNAPS, SUMMRY -* .. Local Arrays .. - COMPLEX*16 AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), - $ ALF( NALMAX ), AS( NMAX*NMAX ), - $ BB( NMAX*NMAX ), BET( NBEMAX ), - $ BS( NMAX*NMAX ), C( NMAX, NMAX ), - $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), - $ W( 2*NMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDMAX ) - LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) -* .. External Functions .. - DOUBLE PRECISION DDIFF - LOGICAL LZE - EXTERNAL DDIFF, LZE -* .. External Subroutines .. - EXTERNAL ZCHK1, ZCHK2, ZCHK3, ZCHK4, ZCHK5, ZCHKE, ZMMCH -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Data statements .. - DATA SNAMES/'ZGEMM ', 'ZHEMM ', 'ZSYMM ', 'ZTRMM ', - $ 'ZTRSM ', 'ZHERK ', 'ZSYRK ', 'ZHER2K', - $ 'ZSYR2K'/ -* .. Executable Statements .. -* -* Read name and unit number for summary output file and open file. -* - READ( NIN, FMT = * )SUMMRY - READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) - NOUTC = NOUT -* -* Read name and unit number for snapshot output file and open file. -* - READ( NIN, FMT = * )SNAPS - READ( NIN, FMT = * )NTRA - TRACE = NTRA.GE.0 - IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' ) - END IF -* Read the flag that directs rewinding of the snapshot file. - READ( NIN, FMT = * )REWI - REWI = REWI.AND.TRACE -* Read the flag that directs stopping on any failure. - READ( NIN, FMT = * )SFATAL -* Read the flag that indicates whether error exits are to be tested. - READ( NIN, FMT = * )TSTERR -* Read the threshold value of the test ratio - READ( NIN, FMT = * )THRESH -* -* Read and check the parameter values for the tests. -* -* Values of N - READ( NIN, FMT = * )NIDIM - IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN - WRITE( NOUT, FMT = 9997 )'N', NIDMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) - DO 10 I = 1, NIDIM - IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN - WRITE( NOUT, FMT = 9996 )NMAX - GO TO 220 - END IF - 10 CONTINUE -* Values of ALPHA - READ( NIN, FMT = * )NALF - IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN - WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) -* Values of BETA - READ( NIN, FMT = * )NBET - IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN - WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) -* -* Report values of parameters. -* - WRITE( NOUT, FMT = 9995 ) - WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM ) - WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF ) - WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET ) - IF( .NOT.TSTERR )THEN - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9984 ) - END IF - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9999 )THRESH - WRITE( NOUT, FMT = * ) -* -* Read names of subroutines and flags which indicate -* whether they are to be tested. -* - DO 20 I = 1, NSUBS - LTEST( I ) = .FALSE. - 20 CONTINUE - 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT - DO 40 I = 1, NSUBS - IF( SNAMET.EQ.SNAMES( I ) ) - $ GO TO 50 - 40 CONTINUE - WRITE( NOUT, FMT = 9990 )SNAMET - STOP - 50 LTEST( I ) = LTESTT - GO TO 30 -* - 60 CONTINUE - CLOSE ( NIN ) -* -* Compute EPS (the machine precision). -* - EPS = EPSILON(RZERO) - WRITE( NOUT, FMT = 9998 )EPS -* -* Check the reliability of ZMMCH using exact data. -* - N = MIN( 32, NMAX ) - DO 100 J = 1, N - DO 90 I = 1, N - AB( I, J ) = MAX( I - J + 1, 0 ) - 90 CONTINUE - AB( J, NMAX + 1 ) = J - AB( 1, NMAX + J ) = J - C( J, 1 ) = ZERO - 100 CONTINUE - DO 110 J = 1, N - CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 - 110 CONTINUE -* CC holds the exact result. On exit from ZMMCH CT holds -* the result computed by ZMMCH. - TRANSA = 'N' - TRANSB = 'N' - CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LZE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - TRANSB = 'C' - CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LZE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - DO 120 J = 1, N - AB( J, NMAX + 1 ) = N - J + 1 - AB( 1, NMAX + J ) = N - J + 1 - 120 CONTINUE - DO 130 J = 1, N - CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 - - $ ( ( J + 1 )*J*( J - 1 ) )/3 - 130 CONTINUE - TRANSA = 'C' - TRANSB = 'N' - CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LZE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - TRANSB = 'C' - CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LZE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF -* -* Test each subroutine in turn. -* - DO 200 ISNUM = 1, NSUBS - WRITE( NOUT, FMT = * ) - IF( .NOT.LTEST( ISNUM ) )THEN -* Subprogram is not to be tested. - WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM ) - ELSE - SRNAMT = SNAMES( ISNUM ) -* Test error exits. - IF( TSTERR )THEN - CALL ZCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) - WRITE( NOUT, FMT = * ) - END IF -* Test computations. - INFOT = 0 - OK = .TRUE. - FATAL = .FALSE. - GO TO ( 140, 150, 150, 160, 160, 170, 170, - $ 180, 180 )ISNUM -* Test ZGEMM, 01. - 140 CALL ZCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test ZHEMM, 02, ZSYMM, 03. - 150 CALL ZCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test ZTRMM, 04, ZTRSM, 05. - 160 CALL ZCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB, - $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C ) - GO TO 190 -* Test ZHERK, 06, ZSYRK, 07. - 170 CALL ZCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test ZHER2K, 08, ZSYR2K, 09. - 180 CALL ZCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) - GO TO 190 -* - 190 IF( FATAL.AND.SFATAL ) - $ GO TO 210 - END IF - 200 CONTINUE - WRITE( NOUT, FMT = 9986 ) - GO TO 230 -* - 210 CONTINUE - WRITE( NOUT, FMT = 9985 ) - GO TO 230 -* - 220 CONTINUE - WRITE( NOUT, FMT = 9991 ) -* - 230 CONTINUE - IF( TRACE ) - $ CLOSE ( NTRA ) - CLOSE ( NOUT ) - STOP -* - 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', - $ 'S THAN', F8.2 ) - 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 ) - 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', - $ 'THAN ', I2 ) - 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) - 9995 FORMAT( ' TESTS OF THE COMPLEX*16 LEVEL 3 BLAS', //' THE F', - $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) - 9994 FORMAT( ' FOR N ', 9I6 ) - 9993 FORMAT( ' FOR ALPHA ', - $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) - 9992 FORMAT( ' FOR BETA ', - $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) - 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', - $ /' ******* TESTS ABANDONED *******' ) - 9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', - $ 'ESTS ABANDONED *******' ) - 9989 FORMAT( ' ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', - $ 'ATED WRONGLY.', /' ZMMCH WAS CALLED WITH TRANSA = ', A1, - $ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ', - $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', - $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', - $ '*******' ) - 9988 FORMAT( A6, L2 ) - 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' ) - 9986 FORMAT( /' END OF TESTS' ) - 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) - 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) -* -* End of ZBLAT3. -* - END - SUBROUTINE ZCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests ZGEMM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, ALS, BETA, BLS - DOUBLE PRECISION ERR, ERRMAX - INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA, - $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, - $ MA, MB, MS, N, NA, NARGS, NB, NC, NS - LOGICAL NULL, RESET, SAME, TRANA, TRANB - CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB - CHARACTER*3 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZGEMM, ZMAKE, ZMMCH -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'NTC'/ -* .. Executable Statements .. -* - NARGS = 13 - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 110 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = M - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 100 - LCC = LDC*N - NULL = N.LE.0.OR.M.LE.0 -* - DO 90 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 80 ICA = 1, 3 - TRANSA = ICH( ICA: ICA ) - TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' -* - IF( TRANA )THEN - MA = K - NA = M - ELSE - MA = M - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* -* Generate the matrix A. -* - CALL ZMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) -* - DO 70 ICB = 1, 3 - TRANSB = ICH( ICB: ICB ) - TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' -* - IF( TRANB )THEN - MB = N - NB = K - ELSE - MB = K - NB = N - END IF -* Set LDB to 1 more than minimum value if room. - LDB = MB - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 70 - LBB = LDB*NB -* -* Generate the matrix B. -* - CALL ZMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB, - $ LDB, RESET, ZERO ) -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL ZMAKE( 'GE', ' ', ' ', M, N, C, NMAX, - $ CC, LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - TRANAS = TRANSA - TRANBS = TRANSB - MS = M - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - BLS = BETA - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB, - $ BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL ZGEMM( TRANSA, TRANSB, M, N, K, ALPHA, - $ AA, LDA, BB, LDB, BETA, CC, LDC ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = TRANSA.EQ.TRANAS - ISAME( 2 ) = TRANSB.EQ.TRANBS - ISAME( 3 ) = MS.EQ.M - ISAME( 4 ) = NS.EQ.N - ISAME( 5 ) = KS.EQ.K - ISAME( 6 ) = ALS.EQ.ALPHA - ISAME( 7 ) = LZE( AS, AA, LAA ) - ISAME( 8 ) = LDAS.EQ.LDA - ISAME( 9 ) = LZE( BS, BB, LBB ) - ISAME( 10 ) = LDBS.EQ.LDB - ISAME( 11 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 12 ) = LZE( CS, CC, LCC ) - ELSE - ISAME( 12 ) = LZERES( 'GE', ' ', M, N, CS, - $ CC, LDC ) - END IF - ISAME( 13 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report -* and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL ZMMCH( TRANSA, TRANSB, M, N, K, - $ ALPHA, A, NMAX, B, NMAX, BETA, - $ C, NMAX, CT, G, CC, LDC, EPS, - $ ERR, FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 120 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K, - $ ALPHA, LDA, LDB, BETA, LDC -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',', - $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, - $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK1. -* - END - SUBROUTINE ZCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests ZHEMM and ZSYMM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, ALS, BETA, BLS - DOUBLE PRECISION ERR, ERRMAX - INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC, - $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA, - $ NARGS, NC, NS - LOGICAL CONJ, LEFT, NULL, RESET, SAME - CHARACTER*1 SIDE, SIDES, UPLO, UPLOS - CHARACTER*2 ICHS, ICHU -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZHEMM, ZMAKE, ZMMCH, ZSYMM -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHS/'LR'/, ICHU/'UL'/ -* .. Executable Statements .. - CONJ = SNAME( 2: 3 ).EQ.'HE' -* - NARGS = 12 - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 100 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 90 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = M - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 90 - LCC = LDC*N - NULL = N.LE.0.OR.M.LE.0 -* Set LDB to 1 more than minimum value if room. - LDB = M - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 90 - LBB = LDB*N -* -* Generate the matrix B. -* - CALL ZMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET, - $ ZERO ) -* - DO 80 ICS = 1, 2 - SIDE = ICHS( ICS: ICS ) - LEFT = SIDE.EQ.'L' -* - IF( LEFT )THEN - NA = M - ELSE - NA = N - END IF -* Set LDA to 1 more than minimum value if room. - LDA = NA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* - DO 70 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* -* Generate the hermitian or symmetric matrix A. -* - CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', NA, NA, A, NMAX, - $ AA, LDA, RESET, ZERO ) -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL ZMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC, - $ LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - SIDES = SIDE - UPLOS = UPLO - MS = M - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - BLS = BETA - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE, - $ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC - IF( REWI ) - $ REWIND NTRA - IF( CONJ )THEN - CALL ZHEMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, - $ BB, LDB, BETA, CC, LDC ) - ELSE - CALL ZSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, - $ BB, LDB, BETA, CC, LDC ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 110 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = SIDES.EQ.SIDE - ISAME( 2 ) = UPLOS.EQ.UPLO - ISAME( 3 ) = MS.EQ.M - ISAME( 4 ) = NS.EQ.N - ISAME( 5 ) = ALS.EQ.ALPHA - ISAME( 6 ) = LZE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - ISAME( 8 ) = LZE( BS, BB, LBB ) - ISAME( 9 ) = LDBS.EQ.LDB - ISAME( 10 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 11 ) = LZE( CS, CC, LCC ) - ELSE - ISAME( 11 ) = LZERES( 'GE', ' ', M, N, CS, - $ CC, LDC ) - END IF - ISAME( 12 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 110 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - IF( LEFT )THEN - CALL ZMMCH( 'N', 'N', M, N, M, ALPHA, A, - $ NMAX, B, NMAX, BETA, C, NMAX, - $ CT, G, CC, LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL ZMMCH( 'N', 'N', M, N, N, ALPHA, B, - $ NMAX, A, NMAX, BETA, C, NMAX, - $ CT, G, CC, LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 120 -* - 110 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA, - $ LDB, BETA, LDC -* - 120 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, - $ ',', F4.1, '), C,', I3, ') .' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK2. -* - END - SUBROUTINE ZCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS, - $ B, BB, BS, CT, G, C ) -* -* Tests ZTRMM and ZTRSM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ ONE = ( 1.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER NALF, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CT( NMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, ALS - DOUBLE PRECISION ERR, ERRMAX - INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB, - $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC, - $ NS - LOGICAL LEFT, NULL, RESET, SAME - CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO, - $ UPLOS - CHARACTER*2 ICHD, ICHS, ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZMAKE, ZMMCH, ZTRMM, ZTRSM -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/ -* .. Executable Statements .. -* - NARGS = 11 - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* Set up zero matrix for ZMMCH. - DO 20 J = 1, NMAX - DO 10 I = 1, NMAX - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE -* - DO 140 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 130 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDB to 1 more than minimum value if room. - LDB = M - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 130 - LBB = LDB*N - NULL = M.LE.0.OR.N.LE.0 -* - DO 120 ICS = 1, 2 - SIDE = ICHS( ICS: ICS ) - LEFT = SIDE.EQ.'L' - IF( LEFT )THEN - NA = M - ELSE - NA = N - END IF -* Set LDA to 1 more than minimum value if room. - LDA = NA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 130 - LAA = LDA*NA -* - DO 110 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* - DO 100 ICT = 1, 3 - TRANSA = ICHT( ICT: ICT ) -* - DO 90 ICD = 1, 2 - DIAG = ICHD( ICD: ICD ) -* - DO 80 IA = 1, NALF - ALPHA = ALF( IA ) -* -* Generate the matrix A. -* - CALL ZMAKE( 'TR', UPLO, DIAG, NA, NA, A, - $ NMAX, AA, LDA, RESET, ZERO ) -* -* Generate the matrix B. -* - CALL ZMAKE( 'GE', ' ', ' ', M, N, B, NMAX, - $ BB, LDB, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - SIDES = SIDE - UPLOS = UPLO - TRANAS = TRANSA - DIAGS = DIAG - MS = M - NS = N - ALS = ALPHA - DO 30 I = 1, LAA - AS( I ) = AA( I ) - 30 CONTINUE - LDAS = LDA - DO 40 I = 1, LBB - BS( I ) = BB( I ) - 40 CONTINUE - LDBS = LDB -* -* Call the subroutine. -* - IF( SNAME( 4: 5 ).EQ.'MM' )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, - $ LDA, LDB - IF( REWI ) - $ REWIND NTRA - CALL ZTRMM( SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, AA, LDA, BB, LDB ) - ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, - $ LDA, LDB - IF( REWI ) - $ REWIND NTRA - CALL ZTRSM( SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, AA, LDA, BB, LDB ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 150 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = SIDES.EQ.SIDE - ISAME( 2 ) = UPLOS.EQ.UPLO - ISAME( 3 ) = TRANAS.EQ.TRANSA - ISAME( 4 ) = DIAGS.EQ.DIAG - ISAME( 5 ) = MS.EQ.M - ISAME( 6 ) = NS.EQ.N - ISAME( 7 ) = ALS.EQ.ALPHA - ISAME( 8 ) = LZE( AS, AA, LAA ) - ISAME( 9 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 10 ) = LZE( BS, BB, LBB ) - ELSE - ISAME( 10 ) = LZERES( 'GE', ' ', M, N, BS, - $ BB, LDB ) - END IF - ISAME( 11 ) = LDBS.EQ.LDB -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 50 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 50 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 150 - END IF -* - IF( .NOT.NULL )THEN - IF( SNAME( 4: 5 ).EQ.'MM' )THEN -* -* Check the result. -* - IF( LEFT )THEN - CALL ZMMCH( TRANSA, 'N', M, N, M, - $ ALPHA, A, NMAX, B, NMAX, - $ ZERO, C, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL ZMMCH( 'N', TRANSA, M, N, N, - $ ALPHA, B, NMAX, A, NMAX, - $ ZERO, C, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN -* -* Compute approximation to original -* matrix. -* - DO 70 J = 1, N - DO 60 I = 1, M - C( I, J ) = BB( I + ( J - 1 )* - $ LDB ) - BB( I + ( J - 1 )*LDB ) = ALPHA* - $ B( I, J ) - 60 CONTINUE - 70 CONTINUE -* - IF( LEFT )THEN - CALL ZMMCH( TRANSA, 'N', M, N, M, - $ ONE, A, NMAX, C, NMAX, - $ ZERO, B, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .FALSE. ) - ELSE - CALL ZMMCH( 'N', TRANSA, M, N, N, - $ ONE, C, NMAX, A, NMAX, - $ ZERO, B, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .FALSE. ) - END IF - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 150 - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* - 140 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 160 -* - 150 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, LDA, LDB -* - 160 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ), - $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ') ', - $ ' .' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK3. -* - END - SUBROUTINE ZCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests ZHERK and ZSYRK. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) ) - DOUBLE PRECISION RONE, RZERO - PARAMETER ( RONE = 1.0D0, RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, ALS, BETA, BETS - DOUBLE PRECISION ERR, ERRMAX, RALPHA, RALS, RBETA, RBETS - INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS, - $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA, - $ NARGS, NC, NS - LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER - CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS - CHARACTER*2 ICHT, ICHU -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZHERK, ZMAKE, ZMMCH, ZSYRK -* .. Intrinsic Functions .. - INTRINSIC DCMPLX, MAX, DBLE -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHT/'NC'/, ICHU/'UL'/ -* .. Executable Statements .. - CONJ = SNAME( 2: 3 ).EQ.'HE' -* - NARGS = 10 - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = N - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 100 - LCC = LDC*N -* - DO 90 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 80 ICT = 1, 2 - TRANS = ICHT( ICT: ICT ) - TRAN = TRANS.EQ.'C' - IF( TRAN.AND..NOT.CONJ ) - $ TRANS = 'T' - IF( TRAN )THEN - MA = K - NA = N - ELSE - MA = N - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* -* Generate the matrix A. -* - CALL ZMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) -* - DO 70 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) - UPPER = UPLO.EQ.'U' -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) - IF( CONJ )THEN - RALPHA = DBLE( ALPHA ) - ALPHA = DCMPLX( RALPHA, RZERO ) - END IF -* - DO 50 IB = 1, NBET - BETA = BET( IB ) - IF( CONJ )THEN - RBETA = DBLE( BETA ) - BETA = DCMPLX( RBETA, RZERO ) - END IF - NULL = N.LE.0 - IF( CONJ ) - $ NULL = NULL.OR.( ( K.LE.0.OR.RALPHA.EQ. - $ RZERO ).AND.RBETA.EQ.RONE ) -* -* Generate the matrix C. -* - CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, C, - $ NMAX, CC, LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - NS = N - KS = K - IF( CONJ )THEN - RALS = RALPHA - ELSE - ALS = ALPHA - END IF - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - IF( CONJ )THEN - RBETS = RBETA - ELSE - BETS = BETA - END IF - DO 20 I = 1, LCC - CS( I ) = CC( I ) - 20 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( CONJ )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, - $ TRANS, N, K, RALPHA, LDA, RBETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL ZHERK( UPLO, TRANS, N, K, RALPHA, AA, - $ LDA, RBETA, CC, LDC ) - ELSE - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, - $ TRANS, N, K, ALPHA, LDA, BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL ZSYRK( UPLO, TRANS, N, K, ALPHA, AA, - $ LDA, BETA, CC, LDC ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLOS.EQ.UPLO - ISAME( 2 ) = TRANSS.EQ.TRANS - ISAME( 3 ) = NS.EQ.N - ISAME( 4 ) = KS.EQ.K - IF( CONJ )THEN - ISAME( 5 ) = RALS.EQ.RALPHA - ELSE - ISAME( 5 ) = ALS.EQ.ALPHA - END IF - ISAME( 6 ) = LZE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - IF( CONJ )THEN - ISAME( 8 ) = RBETS.EQ.RBETA - ELSE - ISAME( 8 ) = BETS.EQ.BETA - END IF - IF( NULL )THEN - ISAME( 9 ) = LZE( CS, CC, LCC ) - ELSE - ISAME( 9 ) = LZERES( SNAME( 2: 3 ), UPLO, N, - $ N, CS, CC, LDC ) - END IF - ISAME( 10 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 30 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 30 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( CONJ )THEN - TRANST = 'C' - ELSE - TRANST = 'T' - END IF - JC = 1 - DO 40 J = 1, N - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - IF( TRAN )THEN - CALL ZMMCH( TRANST, 'N', LJ, 1, K, - $ ALPHA, A( 1, JJ ), NMAX, - $ A( 1, J ), NMAX, BETA, - $ C( JJ, J ), NMAX, CT, G, - $ CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL ZMMCH( 'N', TRANST, LJ, 1, K, - $ ALPHA, A( JJ, 1 ), NMAX, - $ A( J, 1 ), NMAX, BETA, - $ C( JJ, J ), NMAX, CT, G, - $ CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - IF( UPPER )THEN - JC = JC + LDC - ELSE - JC = JC + LDC + 1 - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 110 - 40 CONTINUE - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 110 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9995 )J -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( CONJ )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, RALPHA, - $ LDA, RBETA, LDC - ELSE - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, - $ LDA, BETA, LDC - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') ', - $ ' .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ '(', F4.1, ',', F4.1, ') , A,', I3, ',(', F4.1, ',', F4.1, - $ '), C,', I3, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK4. -* - END - SUBROUTINE ZCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) -* -* Tests ZHER2K and ZSYR2K. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ ONE = ( 1.0D0, 0.0D0 ) ) - DOUBLE PRECISION RONE, RZERO - PARAMETER ( RONE = 1.0D0, RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), - $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), - $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ), - $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), - $ W( 2*NMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, ALS, BETA, BETS - DOUBLE PRECISION ERR, ERRMAX, RBETA, RBETS - INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, - $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, - $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS - LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER - CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS - CHARACTER*2 ICHT, ICHU -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZHER2K, ZMAKE, ZMMCH, ZSYR2K -* .. Intrinsic Functions .. - INTRINSIC DCMPLX, DCONJG, MAX, DBLE -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHT/'NC'/, ICHU/'UL'/ -* .. Executable Statements .. - CONJ = SNAME( 2: 3 ).EQ.'HE' -* - NARGS = 12 - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 130 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = N - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 130 - LCC = LDC*N -* - DO 120 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 110 ICT = 1, 2 - TRANS = ICHT( ICT: ICT ) - TRAN = TRANS.EQ.'C' - IF( TRAN.AND..NOT.CONJ ) - $ TRANS = 'T' - IF( TRAN )THEN - MA = K - NA = N - ELSE - MA = N - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 110 - LAA = LDA*NA -* -* Generate the matrix A. -* - IF( TRAN )THEN - CALL ZMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA, - $ LDA, RESET, ZERO ) - ELSE - CALL ZMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA, - $ RESET, ZERO ) - END IF -* -* Generate the matrix B. -* - LDB = LDA - LBB = LAA - IF( TRAN )THEN - CALL ZMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ), - $ 2*NMAX, BB, LDB, RESET, ZERO ) - ELSE - CALL ZMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ), - $ NMAX, BB, LDB, RESET, ZERO ) - END IF -* - DO 100 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) - UPPER = UPLO.EQ.'U' -* - DO 90 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 80 IB = 1, NBET - BETA = BET( IB ) - IF( CONJ )THEN - RBETA = DBLE( BETA ) - BETA = DCMPLX( RBETA, RZERO ) - END IF - NULL = N.LE.0 - IF( CONJ ) - $ NULL = NULL.OR.( ( K.LE.0.OR.ALPHA.EQ. - $ ZERO ).AND.RBETA.EQ.RONE ) -* -* Generate the matrix C. -* - CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, C, - $ NMAX, CC, LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - IF( CONJ )THEN - RBETS = RBETA - ELSE - BETS = BETA - END IF - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( CONJ )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, - $ TRANS, N, K, ALPHA, LDA, LDB, RBETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL ZHER2K( UPLO, TRANS, N, K, ALPHA, AA, - $ LDA, BB, LDB, RBETA, CC, LDC ) - ELSE - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, - $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL ZSYR2K( UPLO, TRANS, N, K, ALPHA, AA, - $ LDA, BB, LDB, BETA, CC, LDC ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 150 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLOS.EQ.UPLO - ISAME( 2 ) = TRANSS.EQ.TRANS - ISAME( 3 ) = NS.EQ.N - ISAME( 4 ) = KS.EQ.K - ISAME( 5 ) = ALS.EQ.ALPHA - ISAME( 6 ) = LZE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - ISAME( 8 ) = LZE( BS, BB, LBB ) - ISAME( 9 ) = LDBS.EQ.LDB - IF( CONJ )THEN - ISAME( 10 ) = RBETS.EQ.RBETA - ELSE - ISAME( 10 ) = BETS.EQ.BETA - END IF - IF( NULL )THEN - ISAME( 11 ) = LZE( CS, CC, LCC ) - ELSE - ISAME( 11 ) = LZERES( 'HE', UPLO, N, N, CS, - $ CC, LDC ) - END IF - ISAME( 12 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 150 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( CONJ )THEN - TRANST = 'C' - ELSE - TRANST = 'T' - END IF - JJAB = 1 - JC = 1 - DO 70 J = 1, N - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - IF( TRAN )THEN - DO 50 I = 1, K - W( I ) = ALPHA*AB( ( J - 1 )*2* - $ NMAX + K + I ) - IF( CONJ )THEN - W( K + I ) = DCONJG( ALPHA )* - $ AB( ( J - 1 )*2* - $ NMAX + I ) - ELSE - W( K + I ) = ALPHA* - $ AB( ( J - 1 )*2* - $ NMAX + I ) - END IF - 50 CONTINUE - CALL ZMMCH( TRANST, 'N', LJ, 1, 2*K, - $ ONE, AB( JJAB ), 2*NMAX, W, - $ 2*NMAX, BETA, C( JJ, J ), - $ NMAX, CT, G, CC( JC ), LDC, - $ EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - ELSE - DO 60 I = 1, K - IF( CONJ )THEN - W( I ) = ALPHA*DCONJG( AB( ( K + - $ I - 1 )*NMAX + J ) ) - W( K + I ) = DCONJG( ALPHA* - $ AB( ( I - 1 )*NMAX + - $ J ) ) - ELSE - W( I ) = ALPHA*AB( ( K + I - 1 )* - $ NMAX + J ) - W( K + I ) = ALPHA* - $ AB( ( I - 1 )*NMAX + - $ J ) - END IF - 60 CONTINUE - CALL ZMMCH( 'N', 'N', LJ, 1, 2*K, ONE, - $ AB( JJ ), NMAX, W, 2*NMAX, - $ BETA, C( JJ, J ), NMAX, CT, - $ G, CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - IF( UPPER )THEN - JC = JC + LDC - ELSE - JC = JC + LDC + 1 - IF( TRAN ) - $ JJAB = JJAB + 2*NMAX - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 140 - 70 CONTINUE - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 160 -* - 140 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9995 )J -* - 150 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( CONJ )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, - $ LDA, LDB, RBETA, LDC - ELSE - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, - $ LDA, LDB, BETA, LDC - END IF -* - 160 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',', F4.1, - $ ', C,', I3, ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, - $ ',', F4.1, '), C,', I3, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK5. -* - END - SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT ) -* -* Tests the error exits from the Level 3 Blas. -* Requires a special version of the error-handling routine XERBLA. -* A, B and C should not need to be defined. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* 3-19-92: Initialize ALPHA, BETA, RALPHA, and RBETA (eca) -* 3-19-92: Fix argument 12 in calls to ZSYMM and ZHEMM -* with INFOT = 9 (eca) -* 10-9-00: Declared INTRINSIC DCMPLX (susan) -* -* .. Scalar Arguments .. - INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Parameters .. - REAL ONE, TWO - PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, BETA - DOUBLE PRECISION RALPHA, RBETA -* .. Local Arrays .. - COMPLEX*16 A( 2, 1 ), B( 2, 1 ), C( 2, 1 ) -* .. External Subroutines .. - EXTERNAL ZGEMM, ZHEMM, ZHER2K, ZHERK, CHKXER, ZSYMM, - $ ZSYR2K, ZSYRK, ZTRMM, ZTRSM -* .. Intrinsic Functions .. - INTRINSIC DCMPLX -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. -* OK is set to .FALSE. by the special version of XERBLA or by CHKXER -* if anything is wrong. - OK = .TRUE. -* LERR is set to .TRUE. by the special version of XERBLA each time -* it is called, and is then tested and re-set by CHKXER. - LERR = .FALSE. -* -* Initialize ALPHA, BETA, RALPHA, and RBETA. -* - ALPHA = DCMPLX( ONE, -ONE ) - BETA = DCMPLX( TWO, -TWO ) - RALPHA = ONE - RBETA = TWO -* - GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, - $ 90 )ISNUM - 10 INFOT = 1 - CALL ZGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 1 - CALL ZGEMM( '/', 'C', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 1 - CALL ZGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZGEMM( 'C', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGEMM( 'N', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGEMM( 'C', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGEMM( 'C', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGEMM( 'C', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGEMM( 'T', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZGEMM( 'N', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZGEMM( 'C', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZGEMM( 'C', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZGEMM( 'C', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZGEMM( 'T', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGEMM( 'N', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGEMM( 'C', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGEMM( 'C', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGEMM( 'C', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGEMM( 'T', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGEMM( 'N', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGEMM( 'C', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGEMM( 'C', 'C', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGEMM( 'C', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGEMM( 'T', 'C', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZGEMM( 'C', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZGEMM( 'N', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZGEMM( 'C', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZGEMM( 'T', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZGEMM( 'C', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL ZGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL ZGEMM( 'N', 'C', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL ZGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL ZGEMM( 'C', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL ZGEMM( 'C', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL ZGEMM( 'C', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL ZGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL ZGEMM( 'T', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL ZGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 20 INFOT = 1 - CALL ZHEMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZHEMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHEMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHEMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHEMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHEMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHEMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHEMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHEMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHEMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHEMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHEMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHEMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHEMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 30 INFOT = 1 - CALL ZSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 40 INFOT = 1 - CALL ZTRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZTRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZTRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZTRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'L', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'R', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'L', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'R', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'L', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'R', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'L', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'R', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'R', 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'R', 'L', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'R', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'R', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 50 INFOT = 1 - CALL ZTRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZTRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZTRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZTRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'L', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'R', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'L', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'R', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'L', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'R', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'L', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'R', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'R', 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'R', 'L', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'R', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'R', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 60 INFOT = 1 - CALL ZHERK( '/', 'N', 0, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZHERK( 'U', 'T', 0, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHERK( 'U', 'N', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHERK( 'U', 'C', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHERK( 'L', 'N', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHERK( 'L', 'C', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHERK( 'U', 'N', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHERK( 'U', 'C', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHERK( 'L', 'N', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHERK( 'L', 'C', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHERK( 'U', 'N', 2, 0, RALPHA, A, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHERK( 'U', 'C', 0, 2, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHERK( 'L', 'N', 2, 0, RALPHA, A, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHERK( 'L', 'C', 0, 2, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZHERK( 'U', 'N', 2, 0, RALPHA, A, 2, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZHERK( 'U', 'C', 2, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZHERK( 'L', 'N', 2, 0, RALPHA, A, 2, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZHERK( 'L', 'C', 2, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 70 INFOT = 1 - CALL ZSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZSYRK( 'U', 'C', 0, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 80 INFOT = 1 - CALL ZHER2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZHER2K( 'U', 'T', 0, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHER2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHER2K( 'U', 'C', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHER2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHER2K( 'L', 'C', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHER2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHER2K( 'U', 'C', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHER2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHER2K( 'L', 'C', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHER2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHER2K( 'U', 'C', 0, 2, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHER2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHER2K( 'L', 'C', 0, 2, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZHER2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZHER2K( 'U', 'C', 0, 2, ALPHA, A, 2, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZHER2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZHER2K( 'L', 'C', 0, 2, ALPHA, A, 2, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZHER2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZHER2K( 'U', 'C', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZHER2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZHER2K( 'L', 'C', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 90 INFOT = 1 - CALL ZSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZSYR2K( 'U', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* - 100 IF( OK )THEN - WRITE( NOUT, FMT = 9999 )SRNAMT - ELSE - WRITE( NOUT, FMT = 9998 )SRNAMT - END IF - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) - 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', - $ '**' ) -* -* End of ZCHKE. -* - END - SUBROUTINE ZMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, - $ TRANSL ) -* -* Generates values for an M by N matrix A. -* Stores the values in the array AA in the data structure required -* by the routine, with unwanted elements set to rogue value. -* -* TYPE is 'GE', 'HE', 'SY' or 'TR'. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ ONE = ( 1.0D0, 0.0D0 ) ) - COMPLEX*16 ROGUE - PARAMETER ( ROGUE = ( -1.0D10, 1.0D10 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) - DOUBLE PRECISION RROGUE - PARAMETER ( RROGUE = -1.0D10 ) -* .. Scalar Arguments .. - COMPLEX*16 TRANSL - INTEGER LDA, M, N, NMAX - LOGICAL RESET - CHARACTER*1 DIAG, UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - COMPLEX*16 A( NMAX, * ), AA( * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J, JJ - LOGICAL GEN, HER, LOWER, SYM, TRI, UNIT, UPPER -* .. External Functions .. - COMPLEX*16 ZBEG - EXTERNAL ZBEG -* .. Intrinsic Functions .. - INTRINSIC DCMPLX, DCONJG, DBLE -* .. Executable Statements .. - GEN = TYPE.EQ.'GE' - HER = TYPE.EQ.'HE' - SYM = TYPE.EQ.'SY' - TRI = TYPE.EQ.'TR' - UPPER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'U' - LOWER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'L' - UNIT = TRI.AND.DIAG.EQ.'U' -* -* Generate data in array A. -* - DO 20 J = 1, N - DO 10 I = 1, M - IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) - $ THEN - A( I, J ) = ZBEG( RESET ) + TRANSL - IF( I.NE.J )THEN -* Set some elements to zero - IF( N.GT.3.AND.J.EQ.N/2 ) - $ A( I, J ) = ZERO - IF( HER )THEN - A( J, I ) = DCONJG( A( I, J ) ) - ELSE IF( SYM )THEN - A( J, I ) = A( I, J ) - ELSE IF( TRI )THEN - A( J, I ) = ZERO - END IF - END IF - END IF - 10 CONTINUE - IF( HER ) - $ A( J, J ) = DCMPLX( DBLE( A( J, J ) ), RZERO ) - IF( TRI ) - $ A( J, J ) = A( J, J ) + ONE - IF( UNIT ) - $ A( J, J ) = ONE - 20 CONTINUE -* -* Store elements in array AS in data structure required by routine. -* - IF( TYPE.EQ.'GE' )THEN - DO 50 J = 1, N - DO 30 I = 1, M - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 30 CONTINUE - DO 40 I = M + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 40 CONTINUE - 50 CONTINUE - ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN - DO 90 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IF( UNIT )THEN - IEND = J - 1 - ELSE - IEND = J - END IF - ELSE - IF( UNIT )THEN - IBEG = J + 1 - ELSE - IBEG = J - END IF - IEND = N - END IF - DO 60 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 60 CONTINUE - DO 70 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 70 CONTINUE - DO 80 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 80 CONTINUE - IF( HER )THEN - JJ = J + ( J - 1 )*LDA - AA( JJ ) = DCMPLX( DBLE( AA( JJ ) ), RROGUE ) - END IF - 90 CONTINUE - END IF - RETURN -* -* End of ZMAKE. -* - END - SUBROUTINE ZMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, - $ NOUT, MV ) -* -* Checks the results of the computational tests. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO, RONE - PARAMETER ( RZERO = 0.0D0, RONE = 1.0D0 ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA, BETA - DOUBLE PRECISION EPS, ERR - INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT - LOGICAL FATAL, MV - CHARACTER*1 TRANSA, TRANSB -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ CC( LDCC, * ), CT( * ) - DOUBLE PRECISION G( * ) -* .. Local Scalars .. - COMPLEX*16 CL - DOUBLE PRECISION ERRI - INTEGER I, J, K - LOGICAL CTRANA, CTRANB, TRANA, TRANB -* .. Intrinsic Functions .. - INTRINSIC ABS, DIMAG, DCONJG, MAX, DBLE, SQRT -* .. Statement Functions .. - DOUBLE PRECISION ABS1 -* .. Statement Function definitions .. - ABS1( CL ) = ABS( DBLE( CL ) ) + ABS( DIMAG( CL ) ) -* .. Executable Statements .. - TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' - TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' - CTRANA = TRANSA.EQ.'C' - CTRANB = TRANSB.EQ.'C' -* -* Compute expected result, one column at a time, in CT using data -* in A, B and C. -* Compute gauges in G. -* - DO 220 J = 1, N -* - DO 10 I = 1, M - CT( I ) = ZERO - G( I ) = RZERO - 10 CONTINUE - IF( .NOT.TRANA.AND..NOT.TRANB )THEN - DO 30 K = 1, KK - DO 20 I = 1, M - CT( I ) = CT( I ) + A( I, K )*B( K, J ) - G( I ) = G( I ) + ABS1( A( I, K ) )*ABS1( B( K, J ) ) - 20 CONTINUE - 30 CONTINUE - ELSE IF( TRANA.AND..NOT.TRANB )THEN - IF( CTRANA )THEN - DO 50 K = 1, KK - DO 40 I = 1, M - CT( I ) = CT( I ) + DCONJG( A( K, I ) )*B( K, J ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( K, J ) ) - 40 CONTINUE - 50 CONTINUE - ELSE - DO 70 K = 1, KK - DO 60 I = 1, M - CT( I ) = CT( I ) + A( K, I )*B( K, J ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( K, J ) ) - 60 CONTINUE - 70 CONTINUE - END IF - ELSE IF( .NOT.TRANA.AND.TRANB )THEN - IF( CTRANB )THEN - DO 90 K = 1, KK - DO 80 I = 1, M - CT( I ) = CT( I ) + A( I, K )*DCONJG( B( J, K ) ) - G( I ) = G( I ) + ABS1( A( I, K ) )* - $ ABS1( B( J, K ) ) - 80 CONTINUE - 90 CONTINUE - ELSE - DO 110 K = 1, KK - DO 100 I = 1, M - CT( I ) = CT( I ) + A( I, K )*B( J, K ) - G( I ) = G( I ) + ABS1( A( I, K ) )* - $ ABS1( B( J, K ) ) - 100 CONTINUE - 110 CONTINUE - END IF - ELSE IF( TRANA.AND.TRANB )THEN - IF( CTRANA )THEN - IF( CTRANB )THEN - DO 130 K = 1, KK - DO 120 I = 1, M - CT( I ) = CT( I ) + DCONJG( A( K, I ) )* - $ DCONJG( B( J, K ) ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( J, K ) ) - 120 CONTINUE - 130 CONTINUE - ELSE - DO 150 K = 1, KK - DO 140 I = 1, M - CT( I ) = CT( I ) + DCONJG( A( K, I ) )* - $ B( J, K ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( J, K ) ) - 140 CONTINUE - 150 CONTINUE - END IF - ELSE - IF( CTRANB )THEN - DO 170 K = 1, KK - DO 160 I = 1, M - CT( I ) = CT( I ) + A( K, I )* - $ DCONJG( B( J, K ) ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( J, K ) ) - 160 CONTINUE - 170 CONTINUE - ELSE - DO 190 K = 1, KK - DO 180 I = 1, M - CT( I ) = CT( I ) + A( K, I )*B( J, K ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( J, K ) ) - 180 CONTINUE - 190 CONTINUE - END IF - END IF - END IF - DO 200 I = 1, M - CT( I ) = ALPHA*CT( I ) + BETA*C( I, J ) - G( I ) = ABS1( ALPHA )*G( I ) + - $ ABS1( BETA )*ABS1( C( I, J ) ) - 200 CONTINUE -* -* Compute the error ratio for this result. -* - ERR = ZERO - DO 210 I = 1, M - ERRI = ABS1( CT( I ) - CC( I, J ) )/EPS - IF( G( I ).NE.RZERO ) - $ ERRI = ERRI/G( I ) - ERR = MAX( ERR, ERRI ) - IF( ERR*SQRT( EPS ).GE.RONE ) - $ GO TO 230 - 210 CONTINUE -* - 220 CONTINUE -* -* If the loop completes, all results are at least half accurate. - GO TO 250 -* -* Report fatal error. -* - 230 FATAL = .TRUE. - WRITE( NOUT, FMT = 9999 ) - DO 240 I = 1, M - IF( MV )THEN - WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J ) - ELSE - WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I ) - END IF - 240 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9997 )J -* - 250 CONTINUE - RETURN -* - 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', - $ 'F ACCURATE *******', /' EXPECTED RE', - $ 'SULT COMPUTED RESULT' ) - 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) ) - 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) -* -* End of ZMMCH. -* - END - LOGICAL FUNCTION LZE( RI, RJ, LR ) -* -* Tests if two arrays are identical. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER LR -* .. Array Arguments .. - COMPLEX*16 RI( * ), RJ( * ) -* .. Local Scalars .. - INTEGER I -* .. Executable Statements .. - DO 10 I = 1, LR - IF( RI( I ).NE.RJ( I ) ) - $ GO TO 20 - 10 CONTINUE - LZE = .TRUE. - GO TO 30 - 20 CONTINUE - LZE = .FALSE. - 30 RETURN -* -* End of LZE. -* - END - LOGICAL FUNCTION LZERES( TYPE, UPLO, M, N, AA, AS, LDA ) -* -* Tests if selected elements in two arrays are equal. -* -* TYPE is 'GE' or 'HE' or 'SY'. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER LDA, M, N - CHARACTER*1 UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - COMPLEX*16 AA( LDA, * ), AS( LDA, * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J - LOGICAL UPPER -* .. Executable Statements .. - UPPER = UPLO.EQ.'U' - IF( TYPE.EQ.'GE' )THEN - DO 20 J = 1, N - DO 10 I = M + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 10 CONTINUE - 20 CONTINUE - ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'SY' )THEN - DO 50 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 30 I = 1, IBEG - 1 - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 30 CONTINUE - DO 40 I = IEND + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 40 CONTINUE - 50 CONTINUE - END IF -* - LZERES = .TRUE. - GO TO 80 - 70 CONTINUE - LZERES = .FALSE. - 80 RETURN -* -* End of LZERES. -* - END - COMPLEX*16 FUNCTION ZBEG( RESET ) -* -* Generates complex numbers as pairs of random numbers uniformly -* distributed between -0.5 and 0.5. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - LOGICAL RESET -* .. Local Scalars .. - INTEGER I, IC, J, MI, MJ -* .. Save statement .. - SAVE I, IC, J, MI, MJ -* .. Intrinsic Functions .. - INTRINSIC DCMPLX -* .. Executable Statements .. - IF( RESET )THEN -* Initialize local variables. - MI = 891 - MJ = 457 - I = 7 - J = 7 - IC = 0 - RESET = .FALSE. - END IF -* -* The sequence of values of I or J is bounded between 1 and 999. -* If initial I or J = 1,2,3,6,7 or 9, the period will be 50. -* If initial I or J = 4 or 8, the period will be 25. -* If initial I or J = 5, the period will be 10. -* IC is used to break up the period by skipping 1 value of I or J -* in 6. -* - IC = IC + 1 - 10 I = I*MI - J = J*MJ - I = I - 1000*( I/1000 ) - J = J - 1000*( J/1000 ) - IF( IC.GE.5 )THEN - IC = 0 - GO TO 10 - END IF - ZBEG = DCMPLX( ( I - 500 )/1001.0D0, ( J - 500 )/1001.0D0 ) - RETURN -* -* End of ZBEG. -* - END - DOUBLE PRECISION FUNCTION DDIFF( X, Y ) -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - DOUBLE PRECISION X, Y -* .. Executable Statements .. - DDIFF = X - Y - RETURN -* -* End of DDIFF. -* - END - SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* -* Tests whether XERBLA has detected an error when it should. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Executable Statements .. - IF( .NOT.LERR )THEN - WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT - OK = .FALSE. - END IF - LERR = .FALSE. - RETURN -* - 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', - $ 'ETECTED BY ', A6, ' *****' ) -* -* End of CHKXER. -* - END - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* This is a special version of XERBLA to be used only as part of -* the test program for testing error exits from the Level 3 BLAS -* routines. -* -* XERBLA is an error handler for the Level 3 BLAS routines. -* -* It is called by the Level 3 BLAS routines if an input parameter is -* invalid. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER INFO - CHARACTER*6 SRNAME -* .. Scalars in Common .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUT, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Executable Statements .. - LERR = .TRUE. - IF( INFO.NE.INFOT )THEN - IF( INFOT.NE.0 )THEN - WRITE( NOUT, FMT = 9999 )INFO, INFOT - ELSE - WRITE( NOUT, FMT = 9997 )INFO - END IF - OK = .FALSE. - END IF - IF( SRNAME.NE.SRNAMT )THEN - WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT - OK = .FALSE. - END IF - RETURN -* - 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', - $ ' OF ', I2, ' *******' ) - 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', - $ 'AD OF ', A6, ' *******' ) - 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, - $ ' *******' ) -* -* End of XERBLA -* - END - |