LAPACK 3.3.1
Linear Algebra PACKage

dblat1.f

Go to the documentation of this file.
00001       PROGRAM DBLAT1
00002 *     Test program for the DOUBLE PRECISION Level 1 BLAS.
00003 *     Based upon the original BLAS test routine together with:
00004 *     F06EAF Example Program Text
00005 *     .. Parameters ..
00006       INTEGER          NOUT
00007       PARAMETER        (NOUT=6)
00008 *     .. Scalars in Common ..
00009       INTEGER          ICASE, INCX, INCY, N
00010       LOGICAL          PASS
00011 *     .. Local Scalars ..
00012       DOUBLE PRECISION SFAC
00013       INTEGER          IC
00014 *     .. External Subroutines ..
00015       EXTERNAL         CHECK0, CHECK1, CHECK2, CHECK3, HEADER
00016 *     .. Common blocks ..
00017       COMMON           /COMBLA/ICASE, N, INCX, INCY, PASS
00018 *     .. Data statements ..
00019       DATA             SFAC/9.765625D-4/
00020 *     .. Executable Statements ..
00021       WRITE (NOUT,99999)
00022       DO 20 IC = 1, 13
00023          ICASE = IC
00024          CALL HEADER
00025 *
00026 *        .. Initialize  PASS,  INCX,  and INCY for a new case. ..
00027 *        .. the value 9999 for INCX or INCY will appear in the ..
00028 *        .. detailed  output, if any, for cases  that do not involve ..
00029 *        .. these parameters ..
00030 *
00031          PASS = .TRUE.
00032          INCX = 9999
00033          INCY = 9999
00034          IF (ICASE.EQ.3 .OR. ICASE.EQ.11) THEN
00035             CALL CHECK0(SFAC)
00036          ELSE IF (ICASE.EQ.7 .OR. ICASE.EQ.8 .OR. ICASE.EQ.9 .OR.
00037      +            ICASE.EQ.10) THEN
00038             CALL CHECK1(SFAC)
00039          ELSE IF (ICASE.EQ.1 .OR. ICASE.EQ.2 .OR. ICASE.EQ.5 .OR.
00040      +            ICASE.EQ.6 .OR. ICASE.EQ.12 .OR. ICASE.EQ.13) THEN
00041             CALL CHECK2(SFAC)
00042          ELSE IF (ICASE.EQ.4) THEN
00043             CALL CHECK3(SFAC)
00044          END IF
00045 *        -- Print
00046          IF (PASS) WRITE (NOUT,99998)
00047    20 CONTINUE
00048       STOP
00049 *
00050 99999 FORMAT (' Real BLAS Test Program Results',/1X)
00051 99998 FORMAT ('                                    ----- PASS -----')
00052       END
00053       SUBROUTINE HEADER
00054 *     .. Parameters ..
00055       INTEGER          NOUT
00056       PARAMETER        (NOUT=6)
00057 *     .. Scalars in Common ..
00058       INTEGER          ICASE, INCX, INCY, N
00059       LOGICAL          PASS
00060 *     .. Local Arrays ..
00061       CHARACTER*6      L(13)
00062 *     .. Common blocks ..
00063       COMMON           /COMBLA/ICASE, N, INCX, INCY, PASS
00064 *     .. Data statements ..
00065       DATA             L(1)/' DDOT '/
00066       DATA             L(2)/'DAXPY '/
00067       DATA             L(3)/'DROTG '/
00068       DATA             L(4)/' DROT '/
00069       DATA             L(5)/'DCOPY '/
00070       DATA             L(6)/'DSWAP '/
00071       DATA             L(7)/'DNRM2 '/
00072       DATA             L(8)/'DASUM '/
00073       DATA             L(9)/'DSCAL '/
00074       DATA             L(10)/'IDAMAX'/
00075       DATA             L(11)/'DROTMG'/
00076       DATA             L(12)/'DROTM '/
00077       DATA             L(13)/'DSDOT '/
00078 *     .. Executable Statements ..
00079       WRITE (NOUT,99999) ICASE, L(ICASE)
00080       RETURN
00081 *
00082 99999 FORMAT (/' Test of subprogram number',I3,12X,A6)
00083       END
00084       SUBROUTINE CHECK0(SFAC)
00085 *     .. Parameters ..
00086       INTEGER           NOUT
00087       PARAMETER         (NOUT=6)
00088 *     .. Scalar Arguments ..
00089       DOUBLE PRECISION  SFAC
00090 *     .. Scalars in Common ..
00091       INTEGER           ICASE, INCX, INCY, N
00092       LOGICAL           PASS
00093 *     .. Local Scalars ..
00094       DOUBLE PRECISION  SA, SB, SC, SS, D12
00095       INTEGER           I, K
00096 *     .. Local Arrays ..
00097       DOUBLE PRECISION  DA1(8), DATRUE(8), DB1(8), DBTRUE(8), DC1(8),
00098      $                  DS1(8), DAB(4,9), DTEMP(9), DTRUE(9,9)
00099 *     .. External Subroutines ..
00100       EXTERNAL          DROTG, DROTMG, STEST1
00101 *     .. Common blocks ..
00102       COMMON            /COMBLA/ICASE, N, INCX, INCY, PASS
00103 *     .. Data statements ..
00104       DATA              DA1/0.3D0, 0.4D0, -0.3D0, -0.4D0, -0.3D0, 0.0D0,
00105      +                  0.0D0, 1.0D0/
00106       DATA              DB1/0.4D0, 0.3D0, 0.4D0, 0.3D0, -0.4D0, 0.0D0,
00107      +                  1.0D0, 0.0D0/
00108       DATA              DC1/0.6D0, 0.8D0, -0.6D0, 0.8D0, 0.6D0, 1.0D0,
00109      +                  0.0D0, 1.0D0/
00110       DATA              DS1/0.8D0, 0.6D0, 0.8D0, -0.6D0, 0.8D0, 0.0D0,
00111      +                  1.0D0, 0.0D0/
00112       DATA              DATRUE/0.5D0, 0.5D0, 0.5D0, -0.5D0, -0.5D0,
00113      +                  0.0D0, 1.0D0, 1.0D0/
00114       DATA              DBTRUE/0.0D0, 0.6D0, 0.0D0, -0.6D0, 0.0D0,
00115      +                  0.0D0, 1.0D0, 0.0D0/
00116 *     INPUT FOR MODIFIED GIVENS
00117       DATA DAB/ .1D0,.3D0,1.2D0,.2D0,
00118      A          .7D0, .2D0, .6D0, 4.2D0,
00119      B          0.D0,0.D0,0.D0,0.D0,
00120      C          4.D0, -1.D0, 2.D0, 4.D0,
00121      D          6.D-10, 2.D-2, 1.D5, 10.D0,
00122      E          4.D10, 2.D-2, 1.D-5, 10.D0,
00123      F          2.D-10, 4.D-2, 1.D5, 10.D0,
00124      G          2.D10, 4.D-2, 1.D-5, 10.D0,
00125      H          4.D0, -2.D0, 8.D0, 4.D0    /
00126 *    TRUE RESULTS FOR MODIFIED GIVENS
00127       DATA DTRUE/0.D0,0.D0, 1.3D0, .2D0, 0.D0,0.D0,0.D0, .5D0, 0.D0,
00128      A           0.D0,0.D0, 4.5D0, 4.2D0, 1.D0, .5D0, 0.D0,0.D0,0.D0,
00129      B           0.D0,0.D0,0.D0,0.D0, -2.D0, 0.D0,0.D0,0.D0,0.D0,
00130      C           0.D0,0.D0,0.D0, 4.D0, -1.D0, 0.D0,0.D0,0.D0,0.D0,
00131      D           0.D0, 15.D-3, 0.D0, 10.D0, -1.D0, 0.D0, -1.D-4,
00132      E           0.D0, 1.D0,
00133      F           0.D0,0.D0, 6144.D-5, 10.D0, -1.D0, 4096.D0, -1.D6,
00134      G           0.D0, 1.D0,
00135      H           0.D0,0.D0,15.D0,10.D0,-1.D0, 5.D-5, 0.D0,1.D0,0.D0,
00136      I           0.D0,0.D0, 15.D0, 10.D0, -1. D0, 5.D5, -4096.D0,
00137      J           1.D0, 4096.D-6,
00138      K           0.D0,0.D0, 7.D0, 4.D0, 0.D0,0.D0, -.5D0, -.25D0, 0.D0/
00139 *                   4096 = 2 ** 12
00140       DATA D12  /4096.D0/
00141       DTRUE(1,1) = 12.D0 / 130.D0
00142       DTRUE(2,1) = 36.D0 / 130.D0
00143       DTRUE(7,1) = -1.D0 / 6.D0
00144       DTRUE(1,2) = 14.D0 / 75.D0
00145       DTRUE(2,2) = 49.D0 / 75.D0
00146       DTRUE(9,2) = 1.D0 / 7.D0
00147       DTRUE(1,5) = 45.D-11 * (D12 * D12)
00148       DTRUE(3,5) = 4.D5 / (3.D0 * D12)
00149       DTRUE(6,5) = 1.D0 / D12
00150       DTRUE(8,5) = 1.D4 / (3.D0 * D12)
00151       DTRUE(1,6) = 4.D10 / (1.5D0 * D12 * D12)
00152       DTRUE(2,6) = 2.D-2 / 1.5D0
00153       DTRUE(8,6) = 5.D-7 * D12
00154       DTRUE(1,7) = 4.D0 / 150.D0
00155       DTRUE(2,7) = (2.D-10 / 1.5D0) * (D12 * D12)
00156       DTRUE(7,7) = -DTRUE(6,5)
00157       DTRUE(9,7) = 1.D4 / D12
00158       DTRUE(1,8) = DTRUE(1,7)
00159       DTRUE(2,8) = 2.D10 / (1.5D0 * D12 * D12)
00160       DTRUE(1,9) = 32.D0 / 7.D0
00161       DTRUE(2,9) = -16.D0 / 7.D0
00162 *     .. Executable Statements ..
00163 *
00164 *     Compute true values which cannot be prestored
00165 *     in decimal notation
00166 *
00167       DBTRUE(1) = 1.0D0/0.6D0
00168       DBTRUE(3) = -1.0D0/0.6D0
00169       DBTRUE(5) = 1.0D0/0.6D0
00170 *
00171       DO 20 K = 1, 8
00172 *        .. Set N=K for identification in output if any ..
00173          N = K
00174          IF (ICASE.EQ.3) THEN
00175 *           .. DROTG ..
00176             IF (K.GT.8) GO TO 40
00177             SA = DA1(K)
00178             SB = DB1(K)
00179             CALL DROTG(SA,SB,SC,SS)
00180             CALL STEST1(SA,DATRUE(K),DATRUE(K),SFAC)
00181             CALL STEST1(SB,DBTRUE(K),DBTRUE(K),SFAC)
00182             CALL STEST1(SC,DC1(K),DC1(K),SFAC)
00183             CALL STEST1(SS,DS1(K),DS1(K),SFAC)
00184          ELSEIF (ICASE.EQ.11) THEN
00185 *           .. DROTMG ..
00186             DO I=1,4
00187                DTEMP(I)= DAB(I,K)
00188                DTEMP(I+4) = 0.0
00189             END DO
00190             DTEMP(9) = 0.0
00191             CALL DROTMG(DTEMP(1),DTEMP(2),DTEMP(3),DTEMP(4),DTEMP(5))
00192             CALL STEST(9,DTEMP,DTRUE(1,K),DTRUE(1,K),SFAC)
00193          ELSE
00194             WRITE (NOUT,*) ' Shouldn''t be here in CHECK0'
00195             STOP
00196          END IF
00197    20 CONTINUE
00198    40 RETURN
00199       END
00200       SUBROUTINE CHECK1(SFAC)
00201 *     .. Parameters ..
00202       INTEGER           NOUT
00203       PARAMETER         (NOUT=6)
00204 *     .. Scalar Arguments ..
00205       DOUBLE PRECISION  SFAC
00206 *     .. Scalars in Common ..
00207       INTEGER           ICASE, INCX, INCY, N
00208       LOGICAL           PASS
00209 *     .. Local Scalars ..
00210       INTEGER           I, LEN, NP1
00211 *     .. Local Arrays ..
00212       DOUBLE PRECISION  DTRUE1(5), DTRUE3(5), DTRUE5(8,5,2), DV(8,5,2),
00213      +                  SA(10), STEMP(1), STRUE(8), SX(8)
00214       INTEGER           ITRUE2(5)
00215 *     .. External Functions ..
00216       DOUBLE PRECISION  DASUM, DNRM2
00217       INTEGER           IDAMAX
00218       EXTERNAL          DASUM, DNRM2, IDAMAX
00219 *     .. External Subroutines ..
00220       EXTERNAL          ITEST1, DSCAL, STEST, STEST1
00221 *     .. Intrinsic Functions ..
00222       INTRINSIC         MAX
00223 *     .. Common blocks ..
00224       COMMON            /COMBLA/ICASE, N, INCX, INCY, PASS
00225 *     .. Data statements ..
00226       DATA              SA/0.3D0, -1.0D0, 0.0D0, 1.0D0, 0.3D0, 0.3D0,
00227      +                  0.3D0, 0.3D0, 0.3D0, 0.3D0/
00228       DATA              DV/0.1D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0,
00229      +                  2.0D0, 2.0D0, 0.3D0, 3.0D0, 3.0D0, 3.0D0, 3.0D0,
00230      +                  3.0D0, 3.0D0, 3.0D0, 0.3D0, -0.4D0, 4.0D0,
00231      +                  4.0D0, 4.0D0, 4.0D0, 4.0D0, 4.0D0, 0.2D0,
00232      +                  -0.6D0, 0.3D0, 5.0D0, 5.0D0, 5.0D0, 5.0D0,
00233      +                  5.0D0, 0.1D0, -0.3D0, 0.5D0, -0.1D0, 6.0D0,
00234      +                  6.0D0, 6.0D0, 6.0D0, 0.1D0, 8.0D0, 8.0D0, 8.0D0,
00235      +                  8.0D0, 8.0D0, 8.0D0, 8.0D0, 0.3D0, 9.0D0, 9.0D0,
00236      +                  9.0D0, 9.0D0, 9.0D0, 9.0D0, 9.0D0, 0.3D0, 2.0D0,
00237      +                  -0.4D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0,
00238      +                  0.2D0, 3.0D0, -0.6D0, 5.0D0, 0.3D0, 2.0D0,
00239      +                  2.0D0, 2.0D0, 0.1D0, 4.0D0, -0.3D0, 6.0D0,
00240      +                  -0.5D0, 7.0D0, -0.1D0, 3.0D0/
00241       DATA              DTRUE1/0.0D0, 0.3D0, 0.5D0, 0.7D0, 0.6D0/
00242       DATA              DTRUE3/0.0D0, 0.3D0, 0.7D0, 1.1D0, 1.0D0/
00243       DATA              DTRUE5/0.10D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0,
00244      +                  2.0D0, 2.0D0, 2.0D0, -0.3D0, 3.0D0, 3.0D0,
00245      +                  3.0D0, 3.0D0, 3.0D0, 3.0D0, 3.0D0, 0.0D0, 0.0D0,
00246      +                  4.0D0, 4.0D0, 4.0D0, 4.0D0, 4.0D0, 4.0D0,
00247      +                  0.20D0, -0.60D0, 0.30D0, 5.0D0, 5.0D0, 5.0D0,
00248      +                  5.0D0, 5.0D0, 0.03D0, -0.09D0, 0.15D0, -0.03D0,
00249      +                  6.0D0, 6.0D0, 6.0D0, 6.0D0, 0.10D0, 8.0D0,
00250      +                  8.0D0, 8.0D0, 8.0D0, 8.0D0, 8.0D0, 8.0D0,
00251      +                  0.09D0, 9.0D0, 9.0D0, 9.0D0, 9.0D0, 9.0D0,
00252      +                  9.0D0, 9.0D0, 0.09D0, 2.0D0, -0.12D0, 2.0D0,
00253      +                  2.0D0, 2.0D0, 2.0D0, 2.0D0, 0.06D0, 3.0D0,
00254      +                  -0.18D0, 5.0D0, 0.09D0, 2.0D0, 2.0D0, 2.0D0,
00255      +                  0.03D0, 4.0D0, -0.09D0, 6.0D0, -0.15D0, 7.0D0,
00256      +                  -0.03D0, 3.0D0/
00257       DATA              ITRUE2/0, 1, 2, 2, 3/
00258 *     .. Executable Statements ..
00259       DO 80 INCX = 1, 2
00260          DO 60 NP1 = 1, 5
00261             N = NP1 - 1
00262             LEN = 2*MAX(N,1)
00263 *           .. Set vector arguments ..
00264             DO 20 I = 1, LEN
00265                SX(I) = DV(I,NP1,INCX)
00266    20       CONTINUE
00267 *
00268             IF (ICASE.EQ.7) THEN
00269 *              .. DNRM2 ..
00270                STEMP(1) = DTRUE1(NP1)
00271                CALL STEST1(DNRM2(N,SX,INCX),STEMP(1),STEMP,SFAC)
00272             ELSE IF (ICASE.EQ.8) THEN
00273 *              .. DASUM ..
00274                STEMP(1) = DTRUE3(NP1)
00275                CALL STEST1(DASUM(N,SX,INCX),STEMP(1),STEMP,SFAC)
00276             ELSE IF (ICASE.EQ.9) THEN
00277 *              .. DSCAL ..
00278                CALL DSCAL(N,SA((INCX-1)*5+NP1),SX,INCX)
00279                DO 40 I = 1, LEN
00280                   STRUE(I) = DTRUE5(I,NP1,INCX)
00281    40          CONTINUE
00282                CALL STEST(LEN,SX,STRUE,STRUE,SFAC)
00283             ELSE IF (ICASE.EQ.10) THEN
00284 *              .. IDAMAX ..
00285                CALL ITEST1(IDAMAX(N,SX,INCX),ITRUE2(NP1))
00286             ELSE
00287                WRITE (NOUT,*) ' Shouldn''t be here in CHECK1'
00288                STOP
00289             END IF
00290    60    CONTINUE
00291    80 CONTINUE
00292       RETURN
00293       END
00294       SUBROUTINE CHECK2(SFAC)
00295 *     .. Parameters ..
00296       INTEGER           NOUT
00297       PARAMETER         (NOUT=6)
00298 *     .. Scalar Arguments ..
00299       DOUBLE PRECISION  SFAC
00300 *     .. Scalars in Common ..
00301       INTEGER           ICASE, INCX, INCY, N
00302       LOGICAL           PASS
00303 *     .. Local Scalars ..
00304       DOUBLE PRECISION  SA
00305       INTEGER           I, J, KI, KN, KNI, KPAR, KSIZE, LENX, LENY,
00306      $                  MX, MY 
00307 *     .. Local Arrays ..
00308       DOUBLE PRECISION  DT10X(7,4,4), DT10Y(7,4,4), DT7(4,4),
00309      $                  DT8(7,4,4), DX1(7),
00310      $                  DY1(7), SSIZE1(4), SSIZE2(14,2), SSIZE(7),
00311      $                  STX(7), STY(7), SX(7), SY(7),
00312      $                  DPAR(5,4), DT19X(7,4,16),DT19XA(7,4,4),
00313      $                  DT19XB(7,4,4), DT19XC(7,4,4),DT19XD(7,4,4),
00314      $                  DT19Y(7,4,16), DT19YA(7,4,4),DT19YB(7,4,4),
00315      $                  DT19YC(7,4,4), DT19YD(7,4,4), DTEMP(5)
00316       INTEGER           INCXS(4), INCYS(4), LENS(4,2), NS(4)
00317 *     .. External Functions ..
00318       DOUBLE PRECISION  DDOT, DSDOT
00319       EXTERNAL          DDOT, DSDOT
00320 *     .. External Subroutines ..
00321       EXTERNAL          DAXPY, DCOPY, DROTM, DSWAP, STEST, STEST1
00322 *     .. Intrinsic Functions ..
00323       INTRINSIC         ABS, MIN
00324 *     .. Common blocks ..
00325       COMMON            /COMBLA/ICASE, N, INCX, INCY, PASS
00326 *     .. Data statements ..
00327       EQUIVALENCE (DT19X(1,1,1),DT19XA(1,1,1)),(DT19X(1,1,5),
00328      A   DT19XB(1,1,1)),(DT19X(1,1,9),DT19XC(1,1,1)),
00329      B   (DT19X(1,1,13),DT19XD(1,1,1))
00330       EQUIVALENCE (DT19Y(1,1,1),DT19YA(1,1,1)),(DT19Y(1,1,5),
00331      A   DT19YB(1,1,1)),(DT19Y(1,1,9),DT19YC(1,1,1)),
00332      B   (DT19Y(1,1,13),DT19YD(1,1,1))
00333 
00334       DATA              SA/0.3D0/
00335       DATA              INCXS/1, 2, -2, -1/
00336       DATA              INCYS/1, -2, 1, -2/
00337       DATA              LENS/1, 1, 2, 4, 1, 1, 3, 7/
00338       DATA              NS/0, 1, 2, 4/
00339       DATA              DX1/0.6D0, 0.1D0, -0.5D0, 0.8D0, 0.9D0, -0.3D0,
00340      +                  -0.4D0/
00341       DATA              DY1/0.5D0, -0.9D0, 0.3D0, 0.7D0, -0.6D0, 0.2D0,
00342      +                  0.8D0/
00343       DATA              DT7/0.0D0, 0.30D0, 0.21D0, 0.62D0, 0.0D0,
00344      +                  0.30D0, -0.07D0, 0.85D0, 0.0D0, 0.30D0, -0.79D0,
00345      +                  -0.74D0, 0.0D0, 0.30D0, 0.33D0, 1.27D0/
00346       DATA              DT8/0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00347      +                  0.0D0, 0.68D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00348      +                  0.0D0, 0.0D0, 0.68D0, -0.87D0, 0.0D0, 0.0D0,
00349      +                  0.0D0, 0.0D0, 0.0D0, 0.68D0, -0.87D0, 0.15D0,
00350      +                  0.94D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0,
00351      +                  0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.68D0,
00352      +                  0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00353      +                  0.35D0, -0.9D0, 0.48D0, 0.0D0, 0.0D0, 0.0D0,
00354      +                  0.0D0, 0.38D0, -0.9D0, 0.57D0, 0.7D0, -0.75D0,
00355      +                  0.2D0, 0.98D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0,
00356      +                  0.0D0, 0.0D0, 0.0D0, 0.68D0, 0.0D0, 0.0D0,
00357      +                  0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.35D0, -0.72D0,
00358      +                  0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.38D0,
00359      +                  -0.63D0, 0.15D0, 0.88D0, 0.0D0, 0.0D0, 0.0D0,
00360      +                  0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00361      +                  0.68D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00362      +                  0.0D0, 0.68D0, -0.9D0, 0.33D0, 0.0D0, 0.0D0,
00363      +                  0.0D0, 0.0D0, 0.68D0, -0.9D0, 0.33D0, 0.7D0,
00364      +                  -0.75D0, 0.2D0, 1.04D0/
00365       DATA              DT10X/0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00366      +                  0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00367      +                  0.0D0, 0.5D0, -0.9D0, 0.0D0, 0.0D0, 0.0D0,
00368      +                  0.0D0, 0.0D0, 0.5D0, -0.9D0, 0.3D0, 0.7D0,
00369      +                  0.0D0, 0.0D0, 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0,
00370      +                  0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0,
00371      +                  0.0D0, 0.0D0, 0.0D0, 0.3D0, 0.1D0, 0.5D0, 0.0D0,
00372      +                  0.0D0, 0.0D0, 0.0D0, 0.8D0, 0.1D0, -0.6D0,
00373      +                  0.8D0, 0.3D0, -0.3D0, 0.5D0, 0.6D0, 0.0D0,
00374      +                  0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0,
00375      +                  0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, -0.9D0,
00376      +                  0.1D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.7D0,
00377      +                  0.1D0, 0.3D0, 0.8D0, -0.9D0, -0.3D0, 0.5D0,
00378      +                  0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00379      +                  0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00380      +                  0.5D0, 0.3D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00381      +                  0.5D0, 0.3D0, -0.6D0, 0.8D0, 0.0D0, 0.0D0,
00382      +                  0.0D0/
00383       DATA              DT10Y/0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00384      +                  0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00385      +                  0.0D0, 0.6D0, 0.1D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00386      +                  0.0D0, 0.6D0, 0.1D0, -0.5D0, 0.8D0, 0.0D0,
00387      +                  0.0D0, 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00388      +                  0.0D0, 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00389      +                  0.0D0, 0.0D0, -0.5D0, -0.9D0, 0.6D0, 0.0D0,
00390      +                  0.0D0, 0.0D0, 0.0D0, -0.4D0, -0.9D0, 0.9D0,
00391      +                  0.7D0, -0.5D0, 0.2D0, 0.6D0, 0.5D0, 0.0D0,
00392      +                  0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.6D0, 0.0D0,
00393      +                  0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, -0.5D0,
00394      +                  0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00395      +                  -0.4D0, 0.9D0, -0.5D0, 0.6D0, 0.0D0, 0.0D0,
00396      +                  0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00397      +                  0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00398      +                  0.0D0, 0.6D0, -0.9D0, 0.1D0, 0.0D0, 0.0D0,
00399      +                  0.0D0, 0.0D0, 0.6D0, -0.9D0, 0.1D0, 0.7D0,
00400      +                  -0.5D0, 0.2D0, 0.8D0/
00401       DATA              SSIZE1/0.0D0, 0.3D0, 1.6D0, 3.2D0/
00402       DATA              SSIZE2/0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00403      +                  0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00404      +                  0.0D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0,
00405      +                  1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0,
00406      +                  1.17D0, 1.17D0, 1.17D0/
00407 *
00408 *                         FOR DROTM
00409 *
00410       DATA DPAR/-2.D0,  0.D0,0.D0,0.D0,0.D0,
00411      A          -1.D0,  2.D0, -3.D0, -4.D0,  5.D0,
00412      B           0.D0,  0.D0,  2.D0, -3.D0,  0.D0,
00413      C           1.D0,  5.D0,  2.D0,  0.D0, -4.D0/
00414 *                        TRUE X RESULTS F0R ROTATIONS DROTM
00415       DATA DT19XA/.6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00416      A            .6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00417      B            .6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00418      C            .6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00419      D            .6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00420      E           -.8D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00421      F           -.9D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00422      G           3.5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00423      H            .6D0,   .1D0,             0.D0,0.D0,0.D0,0.D0,0.D0,
00424      I           -.8D0,  3.8D0,             0.D0,0.D0,0.D0,0.D0,0.D0,
00425      J           -.9D0,  2.8D0,             0.D0,0.D0,0.D0,0.D0,0.D0,
00426      K           3.5D0,  -.4D0,             0.D0,0.D0,0.D0,0.D0,0.D0,
00427      L            .6D0,   .1D0,  -.5D0,   .8D0,          0.D0,0.D0,0.D0,
00428      M           -.8D0,  3.8D0, -2.2D0, -1.2D0,          0.D0,0.D0,0.D0,
00429      N           -.9D0,  2.8D0, -1.4D0, -1.3D0,          0.D0,0.D0,0.D0,
00430      O           3.5D0,  -.4D0, -2.2D0,  4.7D0,          0.D0,0.D0,0.D0/
00431 *
00432       DATA DT19XB/.6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00433      A            .6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00434      B            .6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00435      C            .6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00436      D            .6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00437      E           -.8D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00438      F           -.9D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00439      G           3.5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00440      H            .6D0,   .1D0,  -.5D0,             0.D0,0.D0,0.D0,0.D0,
00441      I           0.D0,    .1D0, -3.0D0,             0.D0,0.D0,0.D0,0.D0,
00442      J           -.3D0,   .1D0, -2.0D0,             0.D0,0.D0,0.D0,0.D0,
00443      K           3.3D0,   .1D0, -2.0D0,             0.D0,0.D0,0.D0,0.D0,
00444      L            .6D0,   .1D0,  -.5D0,   .8D0,   .9D0,  -.3D0,  -.4D0,
00445      M          -2.0D0,   .1D0,  1.4D0,   .8D0,   .6D0,  -.3D0, -2.8D0,
00446      N          -1.8D0,   .1D0,  1.3D0,   .8D0,  0.D0,   -.3D0, -1.9D0,
00447      O           3.8D0,   .1D0, -3.1D0,   .8D0,  4.8D0,  -.3D0, -1.5D0 /
00448 *
00449       DATA DT19XC/.6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00450      A            .6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00451      B            .6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00452      C            .6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00453      D            .6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00454      E           -.8D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00455      F           -.9D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00456      G           3.5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00457      H            .6D0,   .1D0,  -.5D0,             0.D0,0.D0,0.D0,0.D0,
00458      I           4.8D0,   .1D0, -3.0D0,             0.D0,0.D0,0.D0,0.D0,
00459      J           3.3D0,   .1D0, -2.0D0,             0.D0,0.D0,0.D0,0.D0,
00460      K           2.1D0,   .1D0, -2.0D0,             0.D0,0.D0,0.D0,0.D0,
00461      L            .6D0,   .1D0,  -.5D0,   .8D0,   .9D0,  -.3D0,  -.4D0,
00462      M          -1.6D0,   .1D0, -2.2D0,   .8D0,  5.4D0,  -.3D0, -2.8D0,
00463      N          -1.5D0,   .1D0, -1.4D0,   .8D0,  3.6D0,  -.3D0, -1.9D0,
00464      O           3.7D0,   .1D0, -2.2D0,   .8D0,  3.6D0,  -.3D0, -1.5D0 /
00465 *
00466       DATA DT19XD/.6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00467      A            .6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00468      B            .6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00469      C            .6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00470      D            .6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00471      E           -.8D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00472      F           -.9D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00473      G           3.5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00474      H            .6D0,   .1D0,             0.D0,0.D0,0.D0,0.D0,0.D0,
00475      I           -.8D0, -1.0D0,             0.D0,0.D0,0.D0,0.D0,0.D0,
00476      J           -.9D0,  -.8D0,             0.D0,0.D0,0.D0,0.D0,0.D0,
00477      K           3.5D0,   .8D0,             0.D0,0.D0,0.D0,0.D0,0.D0,
00478      L            .6D0,   .1D0,  -.5D0,   .8D0,          0.D0,0.D0,0.D0,
00479      M           -.8D0, -1.0D0,  1.4D0, -1.6D0,          0.D0,0.D0,0.D0,
00480      N           -.9D0,  -.8D0,  1.3D0, -1.6D0,          0.D0,0.D0,0.D0,
00481      O           3.5D0,   .8D0, -3.1D0,  4.8D0,          0.D0,0.D0,0.D0/
00482 *                        TRUE Y RESULTS FOR ROTATIONS DROTM
00483       DATA DT19YA/.5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00484      A            .5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00485      B            .5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00486      C            .5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00487      D            .5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00488      E            .7D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00489      F           1.7D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00490      G          -2.6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00491      H            .5D0,  -.9D0,             0.D0,0.D0,0.D0,0.D0,0.D0,
00492      I            .7D0, -4.8D0,             0.D0,0.D0,0.D0,0.D0,0.D0,
00493      J           1.7D0,  -.7D0,             0.D0,0.D0,0.D0,0.D0,0.D0,
00494      K          -2.6D0,  3.5D0,             0.D0,0.D0,0.D0,0.D0,0.D0,
00495      L            .5D0,  -.9D0,   .3D0,   .7D0,          0.D0,0.D0,0.D0,
00496      M            .7D0, -4.8D0,  3.0D0,  1.1D0,          0.D0,0.D0,0.D0,
00497      N           1.7D0,  -.7D0,  -.7D0,  2.3D0,          0.D0,0.D0,0.D0,
00498      O          -2.6D0,  3.5D0,  -.7D0, -3.6D0,          0.D0,0.D0,0.D0/
00499 *
00500       DATA DT19YB/.5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00501      A            .5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00502      B            .5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00503      C            .5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00504      D            .5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00505      E            .7D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00506      F           1.7D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00507      G          -2.6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00508      H            .5D0,  -.9D0,   .3D0,             0.D0,0.D0,0.D0,0.D0,
00509      I           4.0D0,  -.9D0,  -.3D0,             0.D0,0.D0,0.D0,0.D0,
00510      J           -.5D0,  -.9D0,  1.5D0,             0.D0,0.D0,0.D0,0.D0,
00511      K          -1.5D0,  -.9D0, -1.8D0,             0.D0,0.D0,0.D0,0.D0,
00512      L            .5D0,  -.9D0,   .3D0,   .7D0,  -.6D0,   .2D0,   .8D0,
00513      M           3.7D0,  -.9D0, -1.2D0,   .7D0, -1.5D0,   .2D0,  2.2D0,
00514      N           -.3D0,  -.9D0,  2.1D0,   .7D0, -1.6D0,   .2D0,  2.0D0,
00515      O          -1.6D0,  -.9D0, -2.1D0,   .7D0,  2.9D0,   .2D0, -3.8D0 /
00516 *
00517       DATA DT19YC/.5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00518      A            .5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00519      B            .5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00520      C            .5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00521      D            .5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00522      E            .7D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00523      F           1.7D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00524      G          -2.6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00525      H            .5D0,  -.9D0,             0.D0,0.D0,0.D0,0.D0,0.D0,
00526      I           4.0D0, -6.3D0,             0.D0,0.D0,0.D0,0.D0,0.D0,
00527      J           -.5D0,   .3D0,             0.D0,0.D0,0.D0,0.D0,0.D0,
00528      K          -1.5D0,  3.0D0,             0.D0,0.D0,0.D0,0.D0,0.D0,
00529      L            .5D0,  -.9D0,   .3D0,   .7D0,          0.D0,0.D0,0.D0,
00530      M           3.7D0, -7.2D0,  3.0D0,  1.7D0,          0.D0,0.D0,0.D0,
00531      N           -.3D0,   .9D0,  -.7D0,  1.9D0,          0.D0,0.D0,0.D0,
00532      O          -1.6D0,  2.7D0,  -.7D0, -3.4D0,          0.D0,0.D0,0.D0/
00533 *
00534       DATA DT19YD/.5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00535      A            .5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00536      B            .5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00537      C            .5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00538      D            .5D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00539      E            .7D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00540      F           1.7D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00541      G          -2.6D0,                  0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,
00542      H            .5D0,  -.9D0,   .3D0,             0.D0,0.D0,0.D0,0.D0,
00543      I            .7D0,  -.9D0,  1.2D0,             0.D0,0.D0,0.D0,0.D0,
00544      J           1.7D0,  -.9D0,   .5D0,             0.D0,0.D0,0.D0,0.D0,
00545      K          -2.6D0,  -.9D0, -1.3D0,             0.D0,0.D0,0.D0,0.D0,
00546      L            .5D0,  -.9D0,   .3D0,   .7D0,  -.6D0,   .2D0,   .8D0,
00547      M            .7D0,  -.9D0,  1.2D0,   .7D0, -1.5D0,   .2D0,  1.6D0,
00548      N           1.7D0,  -.9D0,   .5D0,   .7D0, -1.6D0,   .2D0,  2.4D0,
00549      O          -2.6D0,  -.9D0, -1.3D0,   .7D0,  2.9D0,   .2D0, -4.0D0 /
00550 *    
00551 *     .. Executable Statements ..
00552 *
00553       DO 120 KI = 1, 4
00554          INCX = INCXS(KI)
00555          INCY = INCYS(KI)
00556          MX = ABS(INCX)
00557          MY = ABS(INCY)
00558 *
00559          DO 100 KN = 1, 4
00560             N = NS(KN)
00561             KSIZE = MIN(2,KN)
00562             LENX = LENS(KN,MX)
00563             LENY = LENS(KN,MY)
00564 *           .. Initialize all argument arrays ..
00565             DO 20 I = 1, 7
00566                SX(I) = DX1(I)
00567                SY(I) = DY1(I)
00568    20       CONTINUE
00569 *
00570             IF (ICASE.EQ.1) THEN
00571 *              .. DDOT ..
00572                CALL STEST1(DDOT(N,SX,INCX,SY,INCY),DT7(KN,KI),SSIZE1(KN)
00573      +                     ,SFAC)
00574             ELSE IF (ICASE.EQ.2) THEN
00575 *              .. DAXPY ..
00576                CALL DAXPY(N,SA,SX,INCX,SY,INCY)
00577                DO 40 J = 1, LENY
00578                   STY(J) = DT8(J,KN,KI)
00579    40          CONTINUE
00580                CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC)
00581             ELSE IF (ICASE.EQ.5) THEN
00582 *              .. DCOPY ..
00583                DO 60 I = 1, 7
00584                   STY(I) = DT10Y(I,KN,KI)
00585    60          CONTINUE
00586                CALL DCOPY(N,SX,INCX,SY,INCY)
00587                CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0D0)
00588             ELSE IF (ICASE.EQ.6) THEN
00589 *              .. DSWAP ..
00590                CALL DSWAP(N,SX,INCX,SY,INCY)
00591                DO 80 I = 1, 7
00592                   STX(I) = DT10X(I,KN,KI)
00593                   STY(I) = DT10Y(I,KN,KI)
00594    80          CONTINUE
00595                CALL STEST(LENX,SX,STX,SSIZE2(1,1),1.0D0)
00596                CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0D0)
00597             ELSE IF (ICASE.EQ.12) THEN
00598 *              .. DROTM ..
00599                KNI=KN+4*(KI-1)
00600                DO KPAR=1,4
00601                   DO I=1,7
00602                      SX(I) = DX1(I)
00603                      SY(I) = DY1(I)
00604                      STX(I)= DT19X(I,KPAR,KNI)
00605                      STY(I)= DT19Y(I,KPAR,KNI)
00606                   END DO
00607 *
00608                   DO I=1,5
00609                      DTEMP(I) = DPAR(I,KPAR)
00610                   END DO
00611 *
00612                   DO  I=1,LENX
00613                      SSIZE(I)=STX(I)
00614                   END DO
00615 *                   SEE REMARK ABOVE ABOUT DT11X(1,2,7)
00616 *                       AND DT11X(5,3,8).
00617                   IF ((KPAR .EQ. 2) .AND. (KNI .EQ. 7))
00618      $               SSIZE(1) = 2.4D0
00619                   IF ((KPAR .EQ. 3) .AND. (KNI .EQ. 8))
00620      $               SSIZE(5) = 1.8D0
00621 *
00622                   CALL   DROTM(N,SX,INCX,SY,INCY,DTEMP)
00623                   CALL   STEST(LENX,SX,STX,SSIZE,SFAC)
00624                   CALL   STEST(LENY,SY,STY,STY,SFAC)
00625                END DO
00626             ELSE IF (ICASE.EQ.13) THEN
00627 *              .. DSDOT ..
00628             CALL TESTDSDOT(SNGL(DSDOT(N,SNGL(SX),INCX,SNGL(SY),INCY)),
00629      $                 SNGL(DT7(KN,KI)),SNGL(SSIZE1(KN)), .3125E-1)
00630             ELSE
00631                WRITE (NOUT,*) ' Shouldn''t be here in CHECK2'
00632                STOP
00633             END IF
00634   100    CONTINUE
00635   120 CONTINUE
00636       RETURN
00637       END
00638       SUBROUTINE CHECK3(SFAC)
00639 *     .. Parameters ..
00640       INTEGER           NOUT
00641       PARAMETER         (NOUT=6)
00642 *     .. Scalar Arguments ..
00643       DOUBLE PRECISION  SFAC
00644 *     .. Scalars in Common ..
00645       INTEGER           ICASE, INCX, INCY, N
00646       LOGICAL           PASS
00647 *     .. Local Scalars ..
00648       DOUBLE PRECISION  SC, SS
00649       INTEGER           I, K, KI, KN, KSIZE, LENX, LENY, MX, MY
00650 *     .. Local Arrays ..
00651       DOUBLE PRECISION  COPYX(5), COPYY(5), DT9X(7,4,4), DT9Y(7,4,4),
00652      +                  DX1(7), DY1(7), MWPC(11), MWPS(11), MWPSTX(5),
00653      +                  MWPSTY(5), MWPTX(11,5), MWPTY(11,5), MWPX(5),
00654      +                  MWPY(5), SSIZE2(14,2), STX(7), STY(7), SX(7),
00655      +                  SY(7)
00656       INTEGER           INCXS(4), INCYS(4), LENS(4,2), MWPINX(11),
00657      +                  MWPINY(11), MWPN(11), NS(4)
00658 *     .. External Subroutines ..
00659       EXTERNAL          DROT, STEST
00660 *     .. Intrinsic Functions ..
00661       INTRINSIC         ABS, MIN
00662 *     .. Common blocks ..
00663       COMMON            /COMBLA/ICASE, N, INCX, INCY, PASS
00664 *     .. Data statements ..
00665       DATA              INCXS/1, 2, -2, -1/
00666       DATA              INCYS/1, -2, 1, -2/
00667       DATA              LENS/1, 1, 2, 4, 1, 1, 3, 7/
00668       DATA              NS/0, 1, 2, 4/
00669       DATA              DX1/0.6D0, 0.1D0, -0.5D0, 0.8D0, 0.9D0, -0.3D0,
00670      +                  -0.4D0/
00671       DATA              DY1/0.5D0, -0.9D0, 0.3D0, 0.7D0, -0.6D0, 0.2D0,
00672      +                  0.8D0/
00673       DATA              SC, SS/0.8D0, 0.6D0/
00674       DATA              DT9X/0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00675      +                  0.0D0, 0.78D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00676      +                  0.0D0, 0.0D0, 0.78D0, -0.46D0, 0.0D0, 0.0D0,
00677      +                  0.0D0, 0.0D0, 0.0D0, 0.78D0, -0.46D0, -0.22D0,
00678      +                  1.06D0, 0.0D0, 0.0D0, 0.0D0, 0.6D0, 0.0D0,
00679      +                  0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.78D0,
00680      +                  0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00681      +                  0.66D0, 0.1D0, -0.1D0, 0.0D0, 0.0D0, 0.0D0,
00682      +                  0.0D0, 0.96D0, 0.1D0, -0.76D0, 0.8D0, 0.90D0,
00683      +                  -0.3D0, -0.02D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0,
00684      +                  0.0D0, 0.0D0, 0.0D0, 0.78D0, 0.0D0, 0.0D0,
00685      +                  0.0D0, 0.0D0, 0.0D0, 0.0D0, -0.06D0, 0.1D0,
00686      +                  -0.1D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.90D0,
00687      +                  0.1D0, -0.22D0, 0.8D0, 0.18D0, -0.3D0, -0.02D0,
00688      +                  0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00689      +                  0.78D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00690      +                  0.0D0, 0.78D0, 0.26D0, 0.0D0, 0.0D0, 0.0D0,
00691      +                  0.0D0, 0.0D0, 0.78D0, 0.26D0, -0.76D0, 1.12D0,
00692      +                  0.0D0, 0.0D0, 0.0D0/
00693       DATA              DT9Y/0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00694      +                  0.0D0, 0.04D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00695      +                  0.0D0, 0.0D0, 0.04D0, -0.78D0, 0.0D0, 0.0D0,
00696      +                  0.0D0, 0.0D0, 0.0D0, 0.04D0, -0.78D0, 0.54D0,
00697      +                  0.08D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0,
00698      +                  0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.04D0,
00699      +                  0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.7D0,
00700      +                  -0.9D0, -0.12D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00701      +                  0.64D0, -0.9D0, -0.30D0, 0.7D0, -0.18D0, 0.2D0,
00702      +                  0.28D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00703      +                  0.0D0, 0.0D0, 0.04D0, 0.0D0, 0.0D0, 0.0D0,
00704      +                  0.0D0, 0.0D0, 0.0D0, 0.7D0, -1.08D0, 0.0D0,
00705      +                  0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.64D0, -1.26D0,
00706      +                  0.54D0, 0.20D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0,
00707      +                  0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00708      +                  0.04D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00709      +                  0.0D0, 0.04D0, -0.9D0, 0.18D0, 0.0D0, 0.0D0,
00710      +                  0.0D0, 0.0D0, 0.04D0, -0.9D0, 0.18D0, 0.7D0,
00711      +                  -0.18D0, 0.2D0, 0.16D0/
00712       DATA              SSIZE2/0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00713      +                  0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
00714      +                  0.0D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0,
00715      +                  1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0,
00716      +                  1.17D0, 1.17D0, 1.17D0/
00717 *     .. Executable Statements ..
00718 *
00719       DO 60 KI = 1, 4
00720          INCX = INCXS(KI)
00721          INCY = INCYS(KI)
00722          MX = ABS(INCX)
00723          MY = ABS(INCY)
00724 *
00725          DO 40 KN = 1, 4
00726             N = NS(KN)
00727             KSIZE = MIN(2,KN)
00728             LENX = LENS(KN,MX)
00729             LENY = LENS(KN,MY)
00730 *
00731             IF (ICASE.EQ.4) THEN
00732 *              .. DROT ..
00733                DO 20 I = 1, 7
00734                   SX(I) = DX1(I)
00735                   SY(I) = DY1(I)
00736                   STX(I) = DT9X(I,KN,KI)
00737                   STY(I) = DT9Y(I,KN,KI)
00738    20          CONTINUE
00739                CALL DROT(N,SX,INCX,SY,INCY,SC,SS)
00740                CALL STEST(LENX,SX,STX,SSIZE2(1,KSIZE),SFAC)
00741                CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC)
00742             ELSE
00743                WRITE (NOUT,*) ' Shouldn''t be here in CHECK3'
00744                STOP
00745             END IF
00746    40    CONTINUE
00747    60 CONTINUE
00748 *
00749       MWPC(1) = 1
00750       DO 80 I = 2, 11
00751          MWPC(I) = 0
00752    80 CONTINUE
00753       MWPS(1) = 0
00754       DO 100 I = 2, 6
00755          MWPS(I) = 1
00756   100 CONTINUE
00757       DO 120 I = 7, 11
00758          MWPS(I) = -1
00759   120 CONTINUE
00760       MWPINX(1) = 1
00761       MWPINX(2) = 1
00762       MWPINX(3) = 1
00763       MWPINX(4) = -1
00764       MWPINX(5) = 1
00765       MWPINX(6) = -1
00766       MWPINX(7) = 1
00767       MWPINX(8) = 1
00768       MWPINX(9) = -1
00769       MWPINX(10) = 1
00770       MWPINX(11) = -1
00771       MWPINY(1) = 1
00772       MWPINY(2) = 1
00773       MWPINY(3) = -1
00774       MWPINY(4) = -1
00775       MWPINY(5) = 2
00776       MWPINY(6) = 1
00777       MWPINY(7) = 1
00778       MWPINY(8) = -1
00779       MWPINY(9) = -1
00780       MWPINY(10) = 2
00781       MWPINY(11) = 1
00782       DO 140 I = 1, 11
00783          MWPN(I) = 5
00784   140 CONTINUE
00785       MWPN(5) = 3
00786       MWPN(10) = 3
00787       DO 160 I = 1, 5
00788          MWPX(I) = I
00789          MWPY(I) = I
00790          MWPTX(1,I) = I
00791          MWPTY(1,I) = I
00792          MWPTX(2,I) = I
00793          MWPTY(2,I) = -I
00794          MWPTX(3,I) = 6 - I
00795          MWPTY(3,I) = I - 6
00796          MWPTX(4,I) = I
00797          MWPTY(4,I) = -I
00798          MWPTX(6,I) = 6 - I
00799          MWPTY(6,I) = I - 6
00800          MWPTX(7,I) = -I
00801          MWPTY(7,I) = I
00802          MWPTX(8,I) = I - 6
00803          MWPTY(8,I) = 6 - I
00804          MWPTX(9,I) = -I
00805          MWPTY(9,I) = I
00806          MWPTX(11,I) = I - 6
00807          MWPTY(11,I) = 6 - I
00808   160 CONTINUE
00809       MWPTX(5,1) = 1
00810       MWPTX(5,2) = 3
00811       MWPTX(5,3) = 5
00812       MWPTX(5,4) = 4
00813       MWPTX(5,5) = 5
00814       MWPTY(5,1) = -1
00815       MWPTY(5,2) = 2
00816       MWPTY(5,3) = -2
00817       MWPTY(5,4) = 4
00818       MWPTY(5,5) = -3
00819       MWPTX(10,1) = -1
00820       MWPTX(10,2) = -3
00821       MWPTX(10,3) = -5
00822       MWPTX(10,4) = 4
00823       MWPTX(10,5) = 5
00824       MWPTY(10,1) = 1
00825       MWPTY(10,2) = 2
00826       MWPTY(10,3) = 2
00827       MWPTY(10,4) = 4
00828       MWPTY(10,5) = 3
00829       DO 200 I = 1, 11
00830          INCX = MWPINX(I)
00831          INCY = MWPINY(I)
00832          DO 180 K = 1, 5
00833             COPYX(K) = MWPX(K)
00834             COPYY(K) = MWPY(K)
00835             MWPSTX(K) = MWPTX(I,K)
00836             MWPSTY(K) = MWPTY(I,K)
00837   180    CONTINUE
00838          CALL DROT(MWPN(I),COPYX,INCX,COPYY,INCY,MWPC(I),MWPS(I))
00839          CALL STEST(5,COPYX,MWPSTX,MWPSTX,SFAC)
00840          CALL STEST(5,COPYY,MWPSTY,MWPSTY,SFAC)
00841   200 CONTINUE
00842       RETURN
00843       END
00844       SUBROUTINE STEST(LEN,SCOMP,STRUE,SSIZE,SFAC)
00845 *     ********************************* STEST **************************
00846 *
00847 *     THIS SUBR COMPARES ARRAYS  SCOMP() AND STRUE() OF LENGTH LEN TO
00848 *     SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
00849 *     NEGLIGIBLE.
00850 *
00851 *     C. L. LAWSON, JPL, 1974 DEC 10
00852 *
00853 *     .. Parameters ..
00854       INTEGER          NOUT
00855       PARAMETER        (NOUT=6)
00856 *     .. Scalar Arguments ..
00857       DOUBLE PRECISION SFAC
00858       INTEGER          LEN
00859 *     .. Array Arguments ..
00860       DOUBLE PRECISION SCOMP(LEN), SSIZE(LEN), STRUE(LEN)
00861 *     .. Scalars in Common ..
00862       INTEGER          ICASE, INCX, INCY, N
00863       LOGICAL          PASS
00864 *     .. Local Scalars ..
00865       DOUBLE PRECISION SD
00866       INTEGER          I
00867 *     .. External Functions ..
00868       DOUBLE PRECISION SDIFF
00869       EXTERNAL         SDIFF
00870 *     .. Intrinsic Functions ..
00871       INTRINSIC        ABS
00872 *     .. Common blocks ..
00873       COMMON           /COMBLA/ICASE, N, INCX, INCY, PASS
00874 *     .. Executable Statements ..
00875 *
00876       DO 40 I = 1, LEN
00877          SD = SCOMP(I) - STRUE(I)
00878          IF (SDIFF(ABS(SSIZE(I))+ABS(SFAC*SD),ABS(SSIZE(I))).EQ.0.0D0)
00879      +       GO TO 40
00880 *
00881 *                             HERE    SCOMP(I) IS NOT CLOSE TO STRUE(I).
00882 *
00883          IF ( .NOT. PASS) GO TO 20
00884 *                             PRINT FAIL MESSAGE AND HEADER.
00885          PASS = .FALSE.
00886          WRITE (NOUT,99999)
00887          WRITE (NOUT,99998)
00888    20    WRITE (NOUT,99997) ICASE, N, INCX, INCY, I, SCOMP(I),
00889      +     STRUE(I), SD, SSIZE(I)
00890    40 CONTINUE
00891       RETURN
00892 *
00893 99999 FORMAT ('                                       FAIL')
00894 99998 FORMAT (/' CASE  N INCX INCY  I                            ',
00895      +       ' COMP(I)                             TRUE(I)  DIFFERENCE',
00896      +       '     SIZE(I)',/1X)
00897 99997 FORMAT (1X,I4,I3,2I5,I3,2D36.8,2D12.4)
00898       END
00899       SUBROUTINE TESTDSDOT(SCOMP,STRUE,SSIZE,SFAC)
00900 *     ********************************* STEST **************************
00901 *
00902 *     THIS SUBR COMPARES ARRAYS  SCOMP() AND STRUE() OF LENGTH LEN TO
00903 *     SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
00904 *     NEGLIGIBLE.
00905 *
00906 *     C. L. LAWSON, JPL, 1974 DEC 10
00907 *
00908 *     .. Parameters ..
00909       INTEGER          NOUT
00910       PARAMETER        (NOUT=6)
00911 *     .. Scalar Arguments ..
00912       REAL             SFAC, SCOMP, SSIZE, STRUE
00913 *     .. Scalars in Common ..
00914       INTEGER          ICASE, INCX, INCY, N
00915       LOGICAL          PASS
00916 *     .. Local Scalars ..
00917       REAL             SD
00918 *     .. Intrinsic Functions ..
00919       INTRINSIC        ABS
00920 *     .. Common blocks ..
00921       COMMON           /COMBLA/ICASE, N, INCX, INCY, PASS
00922 *     .. Executable Statements ..
00923 *
00924          SD = SCOMP - STRUE
00925          IF ((ABS(SSIZE)+ABS(SFAC*SD)-ABS(SSIZE)).EQ.0.0E0)
00926      +       GO TO 40
00927 *
00928 *                             HERE    SCOMP(I) IS NOT CLOSE TO STRUE(I).
00929 *
00930          IF ( .NOT. PASS) GO TO 20
00931 *                             PRINT FAIL MESSAGE AND HEADER.
00932          PASS = .FALSE.
00933          WRITE (NOUT,99999)
00934          WRITE (NOUT,99998)
00935    20    WRITE (NOUT,99997) ICASE, N, INCX, INCY, SCOMP,
00936      +     STRUE, SD, SSIZE
00937    40 CONTINUE
00938       RETURN
00939 *
00940 99999 FORMAT ('                                       FAIL')
00941 99998 FORMAT (/' CASE  N INCX INCY                           ',
00942      +       ' COMP(I)                             TRUE(I)  DIFFERENCE',
00943      +       '     SIZE(I)',/1X)
00944 99997 FORMAT (1X,I4,I3,1I5,I3,2E36.8,2E12.4)
00945       END
00946       SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC)
00947 *     ************************* STEST1 *****************************
00948 *
00949 *     THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN
00950 *     REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
00951 *     ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
00952 *
00953 *     C.L. LAWSON, JPL, 1978 DEC 6
00954 *
00955 *     .. Scalar Arguments ..
00956       DOUBLE PRECISION  SCOMP1, SFAC, STRUE1
00957 *     .. Array Arguments ..
00958       DOUBLE PRECISION  SSIZE(*)
00959 *     .. Local Arrays ..
00960       DOUBLE PRECISION  SCOMP(1), STRUE(1)
00961 *     .. External Subroutines ..
00962       EXTERNAL          STEST
00963 *     .. Executable Statements ..
00964 *
00965       SCOMP(1) = SCOMP1
00966       STRUE(1) = STRUE1
00967       CALL STEST(1,SCOMP,STRUE,SSIZE,SFAC)
00968 *
00969       RETURN
00970       END
00971       DOUBLE PRECISION FUNCTION SDIFF(SA,SB)
00972 *     ********************************* SDIFF **************************
00973 *     COMPUTES DIFFERENCE OF TWO NUMBERS.  C. L. LAWSON, JPL 1974 FEB 15
00974 *
00975 *     .. Scalar Arguments ..
00976       DOUBLE PRECISION                SA, SB
00977 *     .. Executable Statements ..
00978       SDIFF = SA - SB
00979       RETURN
00980       END
00981       SUBROUTINE ITEST1(ICOMP,ITRUE)
00982 *     ********************************* ITEST1 *************************
00983 *
00984 *     THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
00985 *     EQUALITY.
00986 *     C. L. LAWSON, JPL, 1974 DEC 10
00987 *
00988 *     .. Parameters ..
00989       INTEGER           NOUT
00990       PARAMETER         (NOUT=6)
00991 *     .. Scalar Arguments ..
00992       INTEGER           ICOMP, ITRUE
00993 *     .. Scalars in Common ..
00994       INTEGER           ICASE, INCX, INCY, N
00995       LOGICAL           PASS
00996 *     .. Local Scalars ..
00997       INTEGER           ID
00998 *     .. Common blocks ..
00999       COMMON            /COMBLA/ICASE, N, INCX, INCY, PASS
01000 *     .. Executable Statements ..
01001 *
01002       IF (ICOMP.EQ.ITRUE) GO TO 40
01003 *
01004 *                            HERE ICOMP IS NOT EQUAL TO ITRUE.
01005 *
01006       IF ( .NOT. PASS) GO TO 20
01007 *                             PRINT FAIL MESSAGE AND HEADER.
01008       PASS = .FALSE.
01009       WRITE (NOUT,99999)
01010       WRITE (NOUT,99998)
01011    20 ID = ICOMP - ITRUE
01012       WRITE (NOUT,99997) ICASE, N, INCX, INCY, ICOMP, ITRUE, ID
01013    40 CONTINUE
01014       RETURN
01015 *
01016 99999 FORMAT ('                                       FAIL')
01017 99998 FORMAT (/' CASE  N INCX INCY                               ',
01018      +       ' COMP                                TRUE     DIFFERENCE',
01019      +       /1X)
01020 99997 FORMAT (1X,I4,I3,2I5,2I36,I12)
01021       END
 All Files Functions