[136] | 1 | *> \brief \b SBLAT1
|
---|
| 2 | *
|
---|
| 3 | * =========== DOCUMENTATION ===========
|
---|
| 4 | *
|
---|
| 5 | * Online html documentation available at
|
---|
| 6 | * http://www.netlib.org/lapack/explore-html/
|
---|
| 7 | *
|
---|
| 8 | * Definition:
|
---|
| 9 | * ===========
|
---|
| 10 | *
|
---|
| 11 | * PROGRAM SBLAT1
|
---|
| 12 | *
|
---|
| 13 | *
|
---|
| 14 | *> \par Purpose:
|
---|
| 15 | * =============
|
---|
| 16 | *>
|
---|
| 17 | *> \verbatim
|
---|
| 18 | *>
|
---|
| 19 | *> Test program for the REAL Level 1 BLAS.
|
---|
| 20 | *>
|
---|
| 21 | *> Based upon the original BLAS test routine together with:
|
---|
| 22 | *> F06EAF Example Program Text
|
---|
| 23 | *> \endverbatim
|
---|
| 24 | *
|
---|
| 25 | * Authors:
|
---|
| 26 | * ========
|
---|
| 27 | *
|
---|
| 28 | *> \author Univ. of Tennessee
|
---|
| 29 | *> \author Univ. of California Berkeley
|
---|
| 30 | *> \author Univ. of Colorado Denver
|
---|
| 31 | *> \author NAG Ltd.
|
---|
| 32 | *
|
---|
| 33 | *> \date April 2012
|
---|
| 34 | *
|
---|
| 35 | *> \ingroup single_blas_testing
|
---|
| 36 | *
|
---|
| 37 | * =====================================================================
|
---|
| 38 | PROGRAM SBLAT1
|
---|
| 39 | *
|
---|
| 40 | * -- Reference BLAS test routine (version 3.4.1) --
|
---|
| 41 | * -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
---|
| 42 | * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
---|
| 43 | * April 2012
|
---|
| 44 | *
|
---|
| 45 | * =====================================================================
|
---|
| 46 | *
|
---|
| 47 | * .. Parameters ..
|
---|
| 48 | INTEGER NOUT
|
---|
| 49 | PARAMETER (NOUT=6)
|
---|
| 50 | * .. Scalars in Common ..
|
---|
| 51 | INTEGER ICASE, INCX, INCY, N
|
---|
| 52 | LOGICAL PASS
|
---|
| 53 | * .. Local Scalars ..
|
---|
| 54 | REAL SFAC
|
---|
| 55 | INTEGER IC
|
---|
| 56 | * .. External Subroutines ..
|
---|
| 57 | EXTERNAL CHECK0, CHECK1, CHECK2, CHECK3, HEADER
|
---|
| 58 | * .. Common blocks ..
|
---|
| 59 | COMMON /COMBLA/ICASE, N, INCX, INCY, PASS
|
---|
| 60 | * .. Data statements ..
|
---|
| 61 | DATA SFAC/9.765625E-4/
|
---|
| 62 | * .. Executable Statements ..
|
---|
| 63 | WRITE (NOUT,99999)
|
---|
| 64 | DO 20 IC = 1, 13
|
---|
| 65 | ICASE = IC
|
---|
| 66 | CALL HEADER
|
---|
| 67 | *
|
---|
| 68 | * .. Initialize PASS, INCX, and INCY for a new case. ..
|
---|
| 69 | * .. the value 9999 for INCX or INCY will appear in the ..
|
---|
| 70 | * .. detailed output, if any, for cases that do not involve ..
|
---|
| 71 | * .. these parameters ..
|
---|
| 72 | *
|
---|
| 73 | PASS = .TRUE.
|
---|
| 74 | INCX = 9999
|
---|
| 75 | INCY = 9999
|
---|
| 76 | IF (ICASE.EQ.3 .OR. ICASE.EQ.11) THEN
|
---|
| 77 | CALL CHECK0(SFAC)
|
---|
| 78 | ELSE IF (ICASE.EQ.7 .OR. ICASE.EQ.8 .OR. ICASE.EQ.9 .OR.
|
---|
| 79 | + ICASE.EQ.10) THEN
|
---|
| 80 | CALL CHECK1(SFAC)
|
---|
| 81 | ELSE IF (ICASE.EQ.1 .OR. ICASE.EQ.2 .OR. ICASE.EQ.5 .OR.
|
---|
| 82 | + ICASE.EQ.6 .OR. ICASE.EQ.12 .OR. ICASE.EQ.13) THEN
|
---|
| 83 | CALL CHECK2(SFAC)
|
---|
| 84 | ELSE IF (ICASE.EQ.4) THEN
|
---|
| 85 | CALL CHECK3(SFAC)
|
---|
| 86 | END IF
|
---|
| 87 | * -- Print
|
---|
| 88 | IF (PASS) WRITE (NOUT,99998)
|
---|
| 89 | 20 CONTINUE
|
---|
| 90 | STOP
|
---|
| 91 | *
|
---|
| 92 | 99999 FORMAT (' Real BLAS Test Program Results',/1X)
|
---|
| 93 | 99998 FORMAT (' ----- PASS -----')
|
---|
| 94 | END
|
---|
| 95 | SUBROUTINE HEADER
|
---|
| 96 | * .. Parameters ..
|
---|
| 97 | INTEGER NOUT
|
---|
| 98 | PARAMETER (NOUT=6)
|
---|
| 99 | * .. Scalars in Common ..
|
---|
| 100 | INTEGER ICASE, INCX, INCY, N
|
---|
| 101 | LOGICAL PASS
|
---|
| 102 | * .. Local Arrays ..
|
---|
| 103 | CHARACTER*6 L(13)
|
---|
| 104 | * .. Common blocks ..
|
---|
| 105 | COMMON /COMBLA/ICASE, N, INCX, INCY, PASS
|
---|
| 106 | * .. Data statements ..
|
---|
| 107 | DATA L(1)/' SDOT '/
|
---|
| 108 | DATA L(2)/'SAXPY '/
|
---|
| 109 | DATA L(3)/'SROTG '/
|
---|
| 110 | DATA L(4)/' SROT '/
|
---|
| 111 | DATA L(5)/'SCOPY '/
|
---|
| 112 | DATA L(6)/'SSWAP '/
|
---|
| 113 | DATA L(7)/'SNRM2 '/
|
---|
| 114 | DATA L(8)/'SASUM '/
|
---|
| 115 | DATA L(9)/'SSCAL '/
|
---|
| 116 | DATA L(10)/'ISAMAX'/
|
---|
| 117 | DATA L(11)/'SROTMG'/
|
---|
| 118 | DATA L(12)/'SROTM '/
|
---|
| 119 | DATA L(13)/'SDSDOT'/
|
---|
| 120 | * .. Executable Statements ..
|
---|
| 121 | WRITE (NOUT,99999) ICASE, L(ICASE)
|
---|
| 122 | RETURN
|
---|
| 123 | *
|
---|
| 124 | 99999 FORMAT (/' Test of subprogram number',I3,12X,A6)
|
---|
| 125 | END
|
---|
| 126 | SUBROUTINE CHECK0(SFAC)
|
---|
| 127 | * .. Parameters ..
|
---|
| 128 | INTEGER NOUT
|
---|
| 129 | PARAMETER (NOUT=6)
|
---|
| 130 | * .. Scalar Arguments ..
|
---|
| 131 | REAL SFAC
|
---|
| 132 | * .. Scalars in Common ..
|
---|
| 133 | INTEGER ICASE, INCX, INCY, N
|
---|
| 134 | LOGICAL PASS
|
---|
| 135 | * .. Local Scalars ..
|
---|
| 136 | REAL D12, SA, SB, SC, SS
|
---|
| 137 | INTEGER I, K
|
---|
| 138 | * .. Local Arrays ..
|
---|
| 139 | REAL DA1(8), DATRUE(8), DB1(8), DBTRUE(8), DC1(8),
|
---|
| 140 | + DS1(8), DAB(4,9), DTEMP(9), DTRUE(9,9)
|
---|
| 141 | * .. External Subroutines ..
|
---|
| 142 | EXTERNAL SROTG, SROTMG, STEST1
|
---|
| 143 | * .. Common blocks ..
|
---|
| 144 | COMMON /COMBLA/ICASE, N, INCX, INCY, PASS
|
---|
| 145 | * .. Data statements ..
|
---|
| 146 | DATA DA1/0.3E0, 0.4E0, -0.3E0, -0.4E0, -0.3E0, 0.0E0,
|
---|
| 147 | + 0.0E0, 1.0E0/
|
---|
| 148 | DATA DB1/0.4E0, 0.3E0, 0.4E0, 0.3E0, -0.4E0, 0.0E0,
|
---|
| 149 | + 1.0E0, 0.0E0/
|
---|
| 150 | DATA DC1/0.6E0, 0.8E0, -0.6E0, 0.8E0, 0.6E0, 1.0E0,
|
---|
| 151 | + 0.0E0, 1.0E0/
|
---|
| 152 | DATA DS1/0.8E0, 0.6E0, 0.8E0, -0.6E0, 0.8E0, 0.0E0,
|
---|
| 153 | + 1.0E0, 0.0E0/
|
---|
| 154 | DATA DATRUE/0.5E0, 0.5E0, 0.5E0, -0.5E0, -0.5E0,
|
---|
| 155 | + 0.0E0, 1.0E0, 1.0E0/
|
---|
| 156 | DATA DBTRUE/0.0E0, 0.6E0, 0.0E0, -0.6E0, 0.0E0,
|
---|
| 157 | + 0.0E0, 1.0E0, 0.0E0/
|
---|
| 158 | * INPUT FOR MODIFIED GIVENS
|
---|
| 159 | DATA DAB/ .1E0,.3E0,1.2E0,.2E0,
|
---|
| 160 | A .7E0, .2E0, .6E0, 4.2E0,
|
---|
| 161 | B 0.E0,0.E0,0.E0,0.E0,
|
---|
| 162 | C 4.E0, -1.E0, 2.E0, 4.E0,
|
---|
| 163 | D 6.E-10, 2.E-2, 1.E5, 10.E0,
|
---|
| 164 | E 4.E10, 2.E-2, 1.E-5, 10.E0,
|
---|
| 165 | F 2.E-10, 4.E-2, 1.E5, 10.E0,
|
---|
| 166 | G 2.E10, 4.E-2, 1.E-5, 10.E0,
|
---|
| 167 | H 4.E0, -2.E0, 8.E0, 4.E0 /
|
---|
| 168 | * TRUE RESULTS FOR MODIFIED GIVENS
|
---|
| 169 | DATA DTRUE/0.E0,0.E0, 1.3E0, .2E0, 0.E0,0.E0,0.E0, .5E0, 0.E0,
|
---|
| 170 | A 0.E0,0.E0, 4.5E0, 4.2E0, 1.E0, .5E0, 0.E0,0.E0,0.E0,
|
---|
| 171 | B 0.E0,0.E0,0.E0,0.E0, -2.E0, 0.E0,0.E0,0.E0,0.E0,
|
---|
| 172 | C 0.E0,0.E0,0.E0, 4.E0, -1.E0, 0.E0,0.E0,0.E0,0.E0,
|
---|
| 173 | D 0.E0, 15.E-3, 0.E0, 10.E0, -1.E0, 0.E0, -1.E-4,
|
---|
| 174 | E 0.E0, 1.E0,
|
---|
| 175 | F 0.E0,0.E0, 6144.E-5, 10.E0, -1.E0, 4096.E0, -1.E6,
|
---|
| 176 | G 0.E0, 1.E0,
|
---|
| 177 | H 0.E0,0.E0,15.E0,10.E0,-1.E0, 5.E-5, 0.E0,1.E0,0.E0,
|
---|
| 178 | I 0.E0,0.E0, 15.E0, 10.E0, -1. E0, 5.E5, -4096.E0,
|
---|
| 179 | J 1.E0, 4096.E-6,
|
---|
| 180 | K 0.E0,0.E0, 7.E0, 4.E0, 0.E0,0.E0, -.5E0, -.25E0, 0.E0/
|
---|
| 181 | * 4096 = 2 ** 12
|
---|
| 182 | DATA D12 /4096.E0/
|
---|
| 183 | DTRUE(1,1) = 12.E0 / 130.E0
|
---|
| 184 | DTRUE(2,1) = 36.E0 / 130.E0
|
---|
| 185 | DTRUE(7,1) = -1.E0 / 6.E0
|
---|
| 186 | DTRUE(1,2) = 14.E0 / 75.E0
|
---|
| 187 | DTRUE(2,2) = 49.E0 / 75.E0
|
---|
| 188 | DTRUE(9,2) = 1.E0 / 7.E0
|
---|
| 189 | DTRUE(1,5) = 45.E-11 * (D12 * D12)
|
---|
| 190 | DTRUE(3,5) = 4.E5 / (3.E0 * D12)
|
---|
| 191 | DTRUE(6,5) = 1.E0 / D12
|
---|
| 192 | DTRUE(8,5) = 1.E4 / (3.E0 * D12)
|
---|
| 193 | DTRUE(1,6) = 4.E10 / (1.5E0 * D12 * D12)
|
---|
| 194 | DTRUE(2,6) = 2.E-2 / 1.5E0
|
---|
| 195 | DTRUE(8,6) = 5.E-7 * D12
|
---|
| 196 | DTRUE(1,7) = 4.E0 / 150.E0
|
---|
| 197 | DTRUE(2,7) = (2.E-10 / 1.5E0) * (D12 * D12)
|
---|
| 198 | DTRUE(7,7) = -DTRUE(6,5)
|
---|
| 199 | DTRUE(9,7) = 1.E4 / D12
|
---|
| 200 | DTRUE(1,8) = DTRUE(1,7)
|
---|
| 201 | DTRUE(2,8) = 2.E10 / (1.5E0 * D12 * D12)
|
---|
| 202 | DTRUE(1,9) = 32.E0 / 7.E0
|
---|
| 203 | DTRUE(2,9) = -16.E0 / 7.E0
|
---|
| 204 | * .. Executable Statements ..
|
---|
| 205 | *
|
---|
| 206 | * Compute true values which cannot be prestored
|
---|
| 207 | * in decimal notation
|
---|
| 208 | *
|
---|
| 209 | DBTRUE(1) = 1.0E0/0.6E0
|
---|
| 210 | DBTRUE(3) = -1.0E0/0.6E0
|
---|
| 211 | DBTRUE(5) = 1.0E0/0.6E0
|
---|
| 212 | *
|
---|
| 213 | DO 20 K = 1, 8
|
---|
| 214 | * .. Set N=K for identification in output if any ..
|
---|
| 215 | N = K
|
---|
| 216 | IF (ICASE.EQ.3) THEN
|
---|
| 217 | * .. SROTG ..
|
---|
| 218 | IF (K.GT.8) GO TO 40
|
---|
| 219 | SA = DA1(K)
|
---|
| 220 | SB = DB1(K)
|
---|
| 221 | CALL SROTG(SA,SB,SC,SS)
|
---|
| 222 | CALL STEST1(SA,DATRUE(K),DATRUE(K),SFAC)
|
---|
| 223 | CALL STEST1(SB,DBTRUE(K),DBTRUE(K),SFAC)
|
---|
| 224 | CALL STEST1(SC,DC1(K),DC1(K),SFAC)
|
---|
| 225 | CALL STEST1(SS,DS1(K),DS1(K),SFAC)
|
---|
| 226 | ELSEIF (ICASE.EQ.11) THEN
|
---|
| 227 | * .. SROTMG ..
|
---|
| 228 | DO I=1,4
|
---|
| 229 | DTEMP(I)= DAB(I,K)
|
---|
| 230 | DTEMP(I+4) = 0.0
|
---|
| 231 | END DO
|
---|
| 232 | DTEMP(9) = 0.0
|
---|
| 233 | CALL SROTMG(DTEMP(1),DTEMP(2),DTEMP(3),DTEMP(4),DTEMP(5))
|
---|
| 234 | CALL STEST(9,DTEMP,DTRUE(1,K),DTRUE(1,K),SFAC)
|
---|
| 235 | ELSE
|
---|
| 236 | WRITE (NOUT,*) ' Shouldn''t be here in CHECK0'
|
---|
| 237 | STOP
|
---|
| 238 | END IF
|
---|
| 239 | 20 CONTINUE
|
---|
| 240 | 40 RETURN
|
---|
| 241 | END
|
---|
| 242 | SUBROUTINE CHECK1(SFAC)
|
---|
| 243 | * .. Parameters ..
|
---|
| 244 | INTEGER NOUT
|
---|
| 245 | PARAMETER (NOUT=6)
|
---|
| 246 | * .. Scalar Arguments ..
|
---|
| 247 | REAL SFAC
|
---|
| 248 | * .. Scalars in Common ..
|
---|
| 249 | INTEGER ICASE, INCX, INCY, N
|
---|
| 250 | LOGICAL PASS
|
---|
| 251 | * .. Local Scalars ..
|
---|
| 252 | INTEGER I, LEN, NP1
|
---|
| 253 | * .. Local Arrays ..
|
---|
| 254 | REAL DTRUE1(5), DTRUE3(5), DTRUE5(8,5,2), DV(8,5,2),
|
---|
| 255 | + SA(10), STEMP(1), STRUE(8), SX(8)
|
---|
| 256 | INTEGER ITRUE2(5)
|
---|
| 257 | * .. External Functions ..
|
---|
| 258 | REAL SASUM, SNRM2
|
---|
| 259 | INTEGER ISAMAX
|
---|
| 260 | EXTERNAL SASUM, SNRM2, ISAMAX
|
---|
| 261 | * .. External Subroutines ..
|
---|
| 262 | EXTERNAL ITEST1, SSCAL, STEST, STEST1
|
---|
| 263 | * .. Intrinsic Functions ..
|
---|
| 264 | INTRINSIC MAX
|
---|
| 265 | * .. Common blocks ..
|
---|
| 266 | COMMON /COMBLA/ICASE, N, INCX, INCY, PASS
|
---|
| 267 | * .. Data statements ..
|
---|
| 268 | DATA SA/0.3E0, -1.0E0, 0.0E0, 1.0E0, 0.3E0, 0.3E0,
|
---|
| 269 | + 0.3E0, 0.3E0, 0.3E0, 0.3E0/
|
---|
| 270 | DATA DV/0.1E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0,
|
---|
| 271 | + 2.0E0, 2.0E0, 0.3E0, 3.0E0, 3.0E0, 3.0E0, 3.0E0,
|
---|
| 272 | + 3.0E0, 3.0E0, 3.0E0, 0.3E0, -0.4E0, 4.0E0,
|
---|
| 273 | + 4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0, 0.2E0,
|
---|
| 274 | + -0.6E0, 0.3E0, 5.0E0, 5.0E0, 5.0E0, 5.0E0,
|
---|
| 275 | + 5.0E0, 0.1E0, -0.3E0, 0.5E0, -0.1E0, 6.0E0,
|
---|
| 276 | + 6.0E0, 6.0E0, 6.0E0, 0.1E0, 8.0E0, 8.0E0, 8.0E0,
|
---|
| 277 | + 8.0E0, 8.0E0, 8.0E0, 8.0E0, 0.3E0, 9.0E0, 9.0E0,
|
---|
| 278 | + 9.0E0, 9.0E0, 9.0E0, 9.0E0, 9.0E0, 0.3E0, 2.0E0,
|
---|
| 279 | + -0.4E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0,
|
---|
| 280 | + 0.2E0, 3.0E0, -0.6E0, 5.0E0, 0.3E0, 2.0E0,
|
---|
| 281 | + 2.0E0, 2.0E0, 0.1E0, 4.0E0, -0.3E0, 6.0E0,
|
---|
| 282 | + -0.5E0, 7.0E0, -0.1E0, 3.0E0/
|
---|
| 283 | DATA DTRUE1/0.0E0, 0.3E0, 0.5E0, 0.7E0, 0.6E0/
|
---|
| 284 | DATA DTRUE3/0.0E0, 0.3E0, 0.7E0, 1.1E0, 1.0E0/
|
---|
| 285 | DATA DTRUE5/0.10E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0,
|
---|
| 286 | + 2.0E0, 2.0E0, 2.0E0, -0.3E0, 3.0E0, 3.0E0,
|
---|
| 287 | + 3.0E0, 3.0E0, 3.0E0, 3.0E0, 3.0E0, 0.0E0, 0.0E0,
|
---|
| 288 | + 4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0,
|
---|
| 289 | + 0.20E0, -0.60E0, 0.30E0, 5.0E0, 5.0E0, 5.0E0,
|
---|
| 290 | + 5.0E0, 5.0E0, 0.03E0, -0.09E0, 0.15E0, -0.03E0,
|
---|
| 291 | + 6.0E0, 6.0E0, 6.0E0, 6.0E0, 0.10E0, 8.0E0,
|
---|
| 292 | + 8.0E0, 8.0E0, 8.0E0, 8.0E0, 8.0E0, 8.0E0,
|
---|
| 293 | + 0.09E0, 9.0E0, 9.0E0, 9.0E0, 9.0E0, 9.0E0,
|
---|
| 294 | + 9.0E0, 9.0E0, 0.09E0, 2.0E0, -0.12E0, 2.0E0,
|
---|
| 295 | + 2.0E0, 2.0E0, 2.0E0, 2.0E0, 0.06E0, 3.0E0,
|
---|
| 296 | + -0.18E0, 5.0E0, 0.09E0, 2.0E0, 2.0E0, 2.0E0,
|
---|
| 297 | + 0.03E0, 4.0E0, -0.09E0, 6.0E0, -0.15E0, 7.0E0,
|
---|
| 298 | + -0.03E0, 3.0E0/
|
---|
| 299 | DATA ITRUE2/0, 1, 2, 2, 3/
|
---|
| 300 | * .. Executable Statements ..
|
---|
| 301 | DO 80 INCX = 1, 2
|
---|
| 302 | DO 60 NP1 = 1, 5
|
---|
| 303 | N = NP1 - 1
|
---|
| 304 | LEN = 2*MAX(N,1)
|
---|
| 305 | * .. Set vector arguments ..
|
---|
| 306 | DO 20 I = 1, LEN
|
---|
| 307 | SX(I) = DV(I,NP1,INCX)
|
---|
| 308 | 20 CONTINUE
|
---|
| 309 | *
|
---|
| 310 | IF (ICASE.EQ.7) THEN
|
---|
| 311 | * .. SNRM2 ..
|
---|
| 312 | STEMP(1) = DTRUE1(NP1)
|
---|
| 313 | CALL STEST1(SNRM2(N,SX,INCX),STEMP(1),STEMP,SFAC)
|
---|
| 314 | ELSE IF (ICASE.EQ.8) THEN
|
---|
| 315 | * .. SASUM ..
|
---|
| 316 | STEMP(1) = DTRUE3(NP1)
|
---|
| 317 | CALL STEST1(SASUM(N,SX,INCX),STEMP(1),STEMP,SFAC)
|
---|
| 318 | ELSE IF (ICASE.EQ.9) THEN
|
---|
| 319 | * .. SSCAL ..
|
---|
| 320 | CALL SSCAL(N,SA((INCX-1)*5+NP1),SX,INCX)
|
---|
| 321 | DO 40 I = 1, LEN
|
---|
| 322 | STRUE(I) = DTRUE5(I,NP1,INCX)
|
---|
| 323 | 40 CONTINUE
|
---|
| 324 | CALL STEST(LEN,SX,STRUE,STRUE,SFAC)
|
---|
| 325 | ELSE IF (ICASE.EQ.10) THEN
|
---|
| 326 | * .. ISAMAX ..
|
---|
| 327 | CALL ITEST1(ISAMAX(N,SX,INCX),ITRUE2(NP1))
|
---|
| 328 | ELSE
|
---|
| 329 | WRITE (NOUT,*) ' Shouldn''t be here in CHECK1'
|
---|
| 330 | STOP
|
---|
| 331 | END IF
|
---|
| 332 | 60 CONTINUE
|
---|
| 333 | 80 CONTINUE
|
---|
| 334 | RETURN
|
---|
| 335 | END
|
---|
| 336 | SUBROUTINE CHECK2(SFAC)
|
---|
| 337 | * .. Parameters ..
|
---|
| 338 | INTEGER NOUT
|
---|
| 339 | PARAMETER (NOUT=6)
|
---|
| 340 | * .. Scalar Arguments ..
|
---|
| 341 | REAL SFAC
|
---|
| 342 | * .. Scalars in Common ..
|
---|
| 343 | INTEGER ICASE, INCX, INCY, N
|
---|
| 344 | LOGICAL PASS
|
---|
| 345 | * .. Local Scalars ..
|
---|
| 346 | REAL SA
|
---|
| 347 | INTEGER I, J, KI, KN, KNI, KPAR, KSIZE, LENX, LENY,
|
---|
| 348 | $ MX, MY
|
---|
| 349 | * .. Local Arrays ..
|
---|
| 350 | REAL DT10X(7,4,4), DT10Y(7,4,4), DT7(4,4),
|
---|
| 351 | $ DT8(7,4,4), DX1(7),
|
---|
| 352 | $ DY1(7), SSIZE1(4), SSIZE2(14,2), SSIZE3(4),
|
---|
| 353 | $ SSIZE(7), STX(7), STY(7), SX(7), SY(7),
|
---|
| 354 | $ DPAR(5,4), DT19X(7,4,16),DT19XA(7,4,4),
|
---|
| 355 | $ DT19XB(7,4,4), DT19XC(7,4,4),DT19XD(7,4,4),
|
---|
| 356 | $ DT19Y(7,4,16), DT19YA(7,4,4),DT19YB(7,4,4),
|
---|
| 357 | $ DT19YC(7,4,4), DT19YD(7,4,4), DTEMP(5),
|
---|
| 358 | $ ST7B(4,4)
|
---|
| 359 | INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4)
|
---|
| 360 | * .. External Functions ..
|
---|
| 361 | REAL SDOT, SDSDOT
|
---|
| 362 | EXTERNAL SDOT, SDSDOT
|
---|
| 363 | * .. External Subroutines ..
|
---|
| 364 | EXTERNAL SAXPY, SCOPY, SROTM, SSWAP, STEST, STEST1
|
---|
| 365 | * .. Intrinsic Functions ..
|
---|
| 366 | INTRINSIC ABS, MIN
|
---|
| 367 | * .. Common blocks ..
|
---|
| 368 | COMMON /COMBLA/ICASE, N, INCX, INCY, PASS
|
---|
| 369 | * .. Data statements ..
|
---|
| 370 | EQUIVALENCE (DT19X(1,1,1),DT19XA(1,1,1)),(DT19X(1,1,5),
|
---|
| 371 | A DT19XB(1,1,1)),(DT19X(1,1,9),DT19XC(1,1,1)),
|
---|
| 372 | B (DT19X(1,1,13),DT19XD(1,1,1))
|
---|
| 373 | EQUIVALENCE (DT19Y(1,1,1),DT19YA(1,1,1)),(DT19Y(1,1,5),
|
---|
| 374 | A DT19YB(1,1,1)),(DT19Y(1,1,9),DT19YC(1,1,1)),
|
---|
| 375 | B (DT19Y(1,1,13),DT19YD(1,1,1))
|
---|
| 376 |
|
---|
| 377 | DATA SA/0.3E0/
|
---|
| 378 | DATA INCXS/1, 2, -2, -1/
|
---|
| 379 | DATA INCYS/1, -2, 1, -2/
|
---|
| 380 | DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/
|
---|
| 381 | DATA NS/0, 1, 2, 4/
|
---|
| 382 | DATA DX1/0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.9E0, -0.3E0,
|
---|
| 383 | + -0.4E0/
|
---|
| 384 | DATA DY1/0.5E0, -0.9E0, 0.3E0, 0.7E0, -0.6E0, 0.2E0,
|
---|
| 385 | + 0.8E0/
|
---|
| 386 | DATA DT7/0.0E0, 0.30E0, 0.21E0, 0.62E0, 0.0E0,
|
---|
| 387 | + 0.30E0, -0.07E0, 0.85E0, 0.0E0, 0.30E0, -0.79E0,
|
---|
| 388 | + -0.74E0, 0.0E0, 0.30E0, 0.33E0, 1.27E0/
|
---|
| 389 | DATA ST7B/ .1, .4, .31, .72, .1, .4, .03, .95,
|
---|
| 390 | + .1, .4, -.69, -.64, .1, .4, .43, 1.37/
|
---|
| 391 | DATA DT8/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 392 | + 0.0E0, 0.68E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 393 | + 0.0E0, 0.0E0, 0.68E0, -0.87E0, 0.0E0, 0.0E0,
|
---|
| 394 | + 0.0E0, 0.0E0, 0.0E0, 0.68E0, -0.87E0, 0.15E0,
|
---|
| 395 | + 0.94E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0,
|
---|
| 396 | + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.68E0,
|
---|
| 397 | + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 398 | + 0.35E0, -0.9E0, 0.48E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 399 | + 0.0E0, 0.38E0, -0.9E0, 0.57E0, 0.7E0, -0.75E0,
|
---|
| 400 | + 0.2E0, 0.98E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 401 | + 0.0E0, 0.0E0, 0.0E0, 0.68E0, 0.0E0, 0.0E0,
|
---|
| 402 | + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.35E0, -0.72E0,
|
---|
| 403 | + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.38E0,
|
---|
| 404 | + -0.63E0, 0.15E0, 0.88E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 405 | + 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 406 | + 0.68E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 407 | + 0.0E0, 0.68E0, -0.9E0, 0.33E0, 0.0E0, 0.0E0,
|
---|
| 408 | + 0.0E0, 0.0E0, 0.68E0, -0.9E0, 0.33E0, 0.7E0,
|
---|
| 409 | + -0.75E0, 0.2E0, 1.04E0/
|
---|
| 410 | DATA DT10X/0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 411 | + 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 412 | + 0.0E0, 0.5E0, -0.9E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 413 | + 0.0E0, 0.0E0, 0.5E0, -0.9E0, 0.3E0, 0.7E0,
|
---|
| 414 | + 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 415 | + 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 416 | + 0.0E0, 0.0E0, 0.0E0, 0.3E0, 0.1E0, 0.5E0, 0.0E0,
|
---|
| 417 | + 0.0E0, 0.0E0, 0.0E0, 0.8E0, 0.1E0, -0.6E0,
|
---|
| 418 | + 0.8E0, 0.3E0, -0.3E0, 0.5E0, 0.6E0, 0.0E0,
|
---|
| 419 | + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0,
|
---|
| 420 | + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.9E0,
|
---|
| 421 | + 0.1E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.7E0,
|
---|
| 422 | + 0.1E0, 0.3E0, 0.8E0, -0.9E0, -0.3E0, 0.5E0,
|
---|
| 423 | + 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 424 | + 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 425 | + 0.5E0, 0.3E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 426 | + 0.5E0, 0.3E0, -0.6E0, 0.8E0, 0.0E0, 0.0E0,
|
---|
| 427 | + 0.0E0/
|
---|
| 428 | DATA DT10Y/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 429 | + 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 430 | + 0.0E0, 0.6E0, 0.1E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 431 | + 0.0E0, 0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.0E0,
|
---|
| 432 | + 0.0E0, 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 433 | + 0.0E0, 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 434 | + 0.0E0, 0.0E0, -0.5E0, -0.9E0, 0.6E0, 0.0E0,
|
---|
| 435 | + 0.0E0, 0.0E0, 0.0E0, -0.4E0, -0.9E0, 0.9E0,
|
---|
| 436 | + 0.7E0, -0.5E0, 0.2E0, 0.6E0, 0.5E0, 0.0E0,
|
---|
| 437 | + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0,
|
---|
| 438 | + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.5E0,
|
---|
| 439 | + 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 440 | + -0.4E0, 0.9E0, -0.5E0, 0.6E0, 0.0E0, 0.0E0,
|
---|
| 441 | + 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 442 | + 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 443 | + 0.0E0, 0.6E0, -0.9E0, 0.1E0, 0.0E0, 0.0E0,
|
---|
| 444 | + 0.0E0, 0.0E0, 0.6E0, -0.9E0, 0.1E0, 0.7E0,
|
---|
| 445 | + -0.5E0, 0.2E0, 0.8E0/
|
---|
| 446 | DATA SSIZE1/0.0E0, 0.3E0, 1.6E0, 3.2E0/
|
---|
| 447 | DATA SSIZE2/0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 448 | + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 449 | + 0.0E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0,
|
---|
| 450 | + 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0,
|
---|
| 451 | + 1.17E0, 1.17E0, 1.17E0/
|
---|
| 452 | DATA SSIZE3/ .1, .4, 1.7, 3.3 /
|
---|
| 453 | *
|
---|
| 454 | * FOR DROTM
|
---|
| 455 | *
|
---|
| 456 | DATA DPAR/-2.E0, 0.E0,0.E0,0.E0,0.E0,
|
---|
| 457 | A -1.E0, 2.E0, -3.E0, -4.E0, 5.E0,
|
---|
| 458 | B 0.E0, 0.E0, 2.E0, -3.E0, 0.E0,
|
---|
| 459 | C 1.E0, 5.E0, 2.E0, 0.E0, -4.E0/
|
---|
| 460 | * TRUE X RESULTS F0R ROTATIONS DROTM
|
---|
| 461 | DATA DT19XA/.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 462 | A .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 463 | B .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 464 | C .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 465 | D .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 466 | E -.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 467 | F -.9E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 468 | G 3.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 469 | H .6E0, .1E0, 0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 470 | I -.8E0, 3.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 471 | J -.9E0, 2.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 472 | K 3.5E0, -.4E0, 0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 473 | L .6E0, .1E0, -.5E0, .8E0, 0.E0,0.E0,0.E0,
|
---|
| 474 | M -.8E0, 3.8E0, -2.2E0, -1.2E0, 0.E0,0.E0,0.E0,
|
---|
| 475 | N -.9E0, 2.8E0, -1.4E0, -1.3E0, 0.E0,0.E0,0.E0,
|
---|
| 476 | O 3.5E0, -.4E0, -2.2E0, 4.7E0, 0.E0,0.E0,0.E0/
|
---|
| 477 | *
|
---|
| 478 | DATA DT19XB/.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 479 | A .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 480 | B .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 481 | C .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 482 | D .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 483 | E -.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 484 | F -.9E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 485 | G 3.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 486 | H .6E0, .1E0, -.5E0, 0.E0,0.E0,0.E0,0.E0,
|
---|
| 487 | I 0.E0, .1E0, -3.0E0, 0.E0,0.E0,0.E0,0.E0,
|
---|
| 488 | J -.3E0, .1E0, -2.0E0, 0.E0,0.E0,0.E0,0.E0,
|
---|
| 489 | K 3.3E0, .1E0, -2.0E0, 0.E0,0.E0,0.E0,0.E0,
|
---|
| 490 | L .6E0, .1E0, -.5E0, .8E0, .9E0, -.3E0, -.4E0,
|
---|
| 491 | M -2.0E0, .1E0, 1.4E0, .8E0, .6E0, -.3E0, -2.8E0,
|
---|
| 492 | N -1.8E0, .1E0, 1.3E0, .8E0, 0.E0, -.3E0, -1.9E0,
|
---|
| 493 | O 3.8E0, .1E0, -3.1E0, .8E0, 4.8E0, -.3E0, -1.5E0 /
|
---|
| 494 | *
|
---|
| 495 | DATA DT19XC/.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 496 | A .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 497 | B .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 498 | C .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 499 | D .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 500 | E -.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 501 | F -.9E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 502 | G 3.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 503 | H .6E0, .1E0, -.5E0, 0.E0,0.E0,0.E0,0.E0,
|
---|
| 504 | I 4.8E0, .1E0, -3.0E0, 0.E0,0.E0,0.E0,0.E0,
|
---|
| 505 | J 3.3E0, .1E0, -2.0E0, 0.E0,0.E0,0.E0,0.E0,
|
---|
| 506 | K 2.1E0, .1E0, -2.0E0, 0.E0,0.E0,0.E0,0.E0,
|
---|
| 507 | L .6E0, .1E0, -.5E0, .8E0, .9E0, -.3E0, -.4E0,
|
---|
| 508 | M -1.6E0, .1E0, -2.2E0, .8E0, 5.4E0, -.3E0, -2.8E0,
|
---|
| 509 | N -1.5E0, .1E0, -1.4E0, .8E0, 3.6E0, -.3E0, -1.9E0,
|
---|
| 510 | O 3.7E0, .1E0, -2.2E0, .8E0, 3.6E0, -.3E0, -1.5E0 /
|
---|
| 511 | *
|
---|
| 512 | DATA DT19XD/.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 513 | A .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 514 | B .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 515 | C .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 516 | D .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 517 | E -.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 518 | F -.9E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 519 | G 3.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 520 | H .6E0, .1E0, 0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 521 | I -.8E0, -1.0E0, 0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 522 | J -.9E0, -.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 523 | K 3.5E0, .8E0, 0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 524 | L .6E0, .1E0, -.5E0, .8E0, 0.E0,0.E0,0.E0,
|
---|
| 525 | M -.8E0, -1.0E0, 1.4E0, -1.6E0, 0.E0,0.E0,0.E0,
|
---|
| 526 | N -.9E0, -.8E0, 1.3E0, -1.6E0, 0.E0,0.E0,0.E0,
|
---|
| 527 | O 3.5E0, .8E0, -3.1E0, 4.8E0, 0.E0,0.E0,0.E0/
|
---|
| 528 | * TRUE Y RESULTS FOR ROTATIONS DROTM
|
---|
| 529 | DATA DT19YA/.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 530 | A .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 531 | B .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 532 | C .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 533 | D .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 534 | E .7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 535 | F 1.7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 536 | G -2.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 537 | H .5E0, -.9E0, 0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 538 | I .7E0, -4.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 539 | J 1.7E0, -.7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 540 | K -2.6E0, 3.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 541 | L .5E0, -.9E0, .3E0, .7E0, 0.E0,0.E0,0.E0,
|
---|
| 542 | M .7E0, -4.8E0, 3.0E0, 1.1E0, 0.E0,0.E0,0.E0,
|
---|
| 543 | N 1.7E0, -.7E0, -.7E0, 2.3E0, 0.E0,0.E0,0.E0,
|
---|
| 544 | O -2.6E0, 3.5E0, -.7E0, -3.6E0, 0.E0,0.E0,0.E0/
|
---|
| 545 | *
|
---|
| 546 | DATA DT19YB/.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 547 | A .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 548 | B .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 549 | C .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 550 | D .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 551 | E .7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 552 | F 1.7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 553 | G -2.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 554 | H .5E0, -.9E0, .3E0, 0.E0,0.E0,0.E0,0.E0,
|
---|
| 555 | I 4.0E0, -.9E0, -.3E0, 0.E0,0.E0,0.E0,0.E0,
|
---|
| 556 | J -.5E0, -.9E0, 1.5E0, 0.E0,0.E0,0.E0,0.E0,
|
---|
| 557 | K -1.5E0, -.9E0, -1.8E0, 0.E0,0.E0,0.E0,0.E0,
|
---|
| 558 | L .5E0, -.9E0, .3E0, .7E0, -.6E0, .2E0, .8E0,
|
---|
| 559 | M 3.7E0, -.9E0, -1.2E0, .7E0, -1.5E0, .2E0, 2.2E0,
|
---|
| 560 | N -.3E0, -.9E0, 2.1E0, .7E0, -1.6E0, .2E0, 2.0E0,
|
---|
| 561 | O -1.6E0, -.9E0, -2.1E0, .7E0, 2.9E0, .2E0, -3.8E0 /
|
---|
| 562 | *
|
---|
| 563 | DATA DT19YC/.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 564 | A .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 565 | B .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 566 | C .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 567 | D .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 568 | E .7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 569 | F 1.7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 570 | G -2.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 571 | H .5E0, -.9E0, 0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 572 | I 4.0E0, -6.3E0, 0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 573 | J -.5E0, .3E0, 0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 574 | K -1.5E0, 3.0E0, 0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 575 | L .5E0, -.9E0, .3E0, .7E0, 0.E0,0.E0,0.E0,
|
---|
| 576 | M 3.7E0, -7.2E0, 3.0E0, 1.7E0, 0.E0,0.E0,0.E0,
|
---|
| 577 | N -.3E0, .9E0, -.7E0, 1.9E0, 0.E0,0.E0,0.E0,
|
---|
| 578 | O -1.6E0, 2.7E0, -.7E0, -3.4E0, 0.E0,0.E0,0.E0/
|
---|
| 579 | *
|
---|
| 580 | DATA DT19YD/.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 581 | A .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 582 | B .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 583 | C .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 584 | D .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 585 | E .7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 586 | F 1.7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 587 | G -2.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0,
|
---|
| 588 | H .5E0, -.9E0, .3E0, 0.E0,0.E0,0.E0,0.E0,
|
---|
| 589 | I .7E0, -.9E0, 1.2E0, 0.E0,0.E0,0.E0,0.E0,
|
---|
| 590 | J 1.7E0, -.9E0, .5E0, 0.E0,0.E0,0.E0,0.E0,
|
---|
| 591 | K -2.6E0, -.9E0, -1.3E0, 0.E0,0.E0,0.E0,0.E0,
|
---|
| 592 | L .5E0, -.9E0, .3E0, .7E0, -.6E0, .2E0, .8E0,
|
---|
| 593 | M .7E0, -.9E0, 1.2E0, .7E0, -1.5E0, .2E0, 1.6E0,
|
---|
| 594 | N 1.7E0, -.9E0, .5E0, .7E0, -1.6E0, .2E0, 2.4E0,
|
---|
| 595 | O -2.6E0, -.9E0, -1.3E0, .7E0, 2.9E0, .2E0, -4.0E0 /
|
---|
| 596 | *
|
---|
| 597 | * .. Executable Statements ..
|
---|
| 598 | *
|
---|
| 599 | DO 120 KI = 1, 4
|
---|
| 600 | INCX = INCXS(KI)
|
---|
| 601 | INCY = INCYS(KI)
|
---|
| 602 | MX = ABS(INCX)
|
---|
| 603 | MY = ABS(INCY)
|
---|
| 604 | *
|
---|
| 605 | DO 100 KN = 1, 4
|
---|
| 606 | N = NS(KN)
|
---|
| 607 | KSIZE = MIN(2,KN)
|
---|
| 608 | LENX = LENS(KN,MX)
|
---|
| 609 | LENY = LENS(KN,MY)
|
---|
| 610 | * .. Initialize all argument arrays ..
|
---|
| 611 | DO 20 I = 1, 7
|
---|
| 612 | SX(I) = DX1(I)
|
---|
| 613 | SY(I) = DY1(I)
|
---|
| 614 | 20 CONTINUE
|
---|
| 615 | *
|
---|
| 616 | IF (ICASE.EQ.1) THEN
|
---|
| 617 | * .. SDOT ..
|
---|
| 618 | CALL STEST1(SDOT(N,SX,INCX,SY,INCY),DT7(KN,KI),SSIZE1(KN)
|
---|
| 619 | + ,SFAC)
|
---|
| 620 | ELSE IF (ICASE.EQ.2) THEN
|
---|
| 621 | * .. SAXPY ..
|
---|
| 622 | CALL SAXPY(N,SA,SX,INCX,SY,INCY)
|
---|
| 623 | DO 40 J = 1, LENY
|
---|
| 624 | STY(J) = DT8(J,KN,KI)
|
---|
| 625 | 40 CONTINUE
|
---|
| 626 | CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC)
|
---|
| 627 | ELSE IF (ICASE.EQ.5) THEN
|
---|
| 628 | * .. SCOPY ..
|
---|
| 629 | DO 60 I = 1, 7
|
---|
| 630 | STY(I) = DT10Y(I,KN,KI)
|
---|
| 631 | 60 CONTINUE
|
---|
| 632 | CALL SCOPY(N,SX,INCX,SY,INCY)
|
---|
| 633 | CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0E0)
|
---|
| 634 | ELSE IF (ICASE.EQ.6) THEN
|
---|
| 635 | * .. SSWAP ..
|
---|
| 636 | CALL SSWAP(N,SX,INCX,SY,INCY)
|
---|
| 637 | DO 80 I = 1, 7
|
---|
| 638 | STX(I) = DT10X(I,KN,KI)
|
---|
| 639 | STY(I) = DT10Y(I,KN,KI)
|
---|
| 640 | 80 CONTINUE
|
---|
| 641 | CALL STEST(LENX,SX,STX,SSIZE2(1,1),1.0E0)
|
---|
| 642 | CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0E0)
|
---|
| 643 | ELSEIF (ICASE.EQ.12) THEN
|
---|
| 644 | * .. SROTM ..
|
---|
| 645 | KNI=KN+4*(KI-1)
|
---|
| 646 | DO KPAR=1,4
|
---|
| 647 | DO I=1,7
|
---|
| 648 | SX(I) = DX1(I)
|
---|
| 649 | SY(I) = DY1(I)
|
---|
| 650 | STX(I)= DT19X(I,KPAR,KNI)
|
---|
| 651 | STY(I)= DT19Y(I,KPAR,KNI)
|
---|
| 652 | END DO
|
---|
| 653 | *
|
---|
| 654 | DO I=1,5
|
---|
| 655 | DTEMP(I) = DPAR(I,KPAR)
|
---|
| 656 | END DO
|
---|
| 657 | *
|
---|
| 658 | DO I=1,LENX
|
---|
| 659 | SSIZE(I)=STX(I)
|
---|
| 660 | END DO
|
---|
| 661 | * SEE REMARK ABOVE ABOUT DT11X(1,2,7)
|
---|
| 662 | * AND DT11X(5,3,8).
|
---|
| 663 | IF ((KPAR .EQ. 2) .AND. (KNI .EQ. 7))
|
---|
| 664 | $ SSIZE(1) = 2.4E0
|
---|
| 665 | IF ((KPAR .EQ. 3) .AND. (KNI .EQ. 8))
|
---|
| 666 | $ SSIZE(5) = 1.8E0
|
---|
| 667 | *
|
---|
| 668 | CALL SROTM(N,SX,INCX,SY,INCY,DTEMP)
|
---|
| 669 | CALL STEST(LENX,SX,STX,SSIZE,SFAC)
|
---|
| 670 | CALL STEST(LENY,SY,STY,STY,SFAC)
|
---|
| 671 | END DO
|
---|
| 672 | ELSEIF (ICASE.EQ.13) THEN
|
---|
| 673 | * .. SDSROT ..
|
---|
| 674 | CALL STEST1 (SDSDOT(N,.1,SX,INCX,SY,INCY),
|
---|
| 675 | $ ST7B(KN,KI),SSIZE3(KN),SFAC)
|
---|
| 676 | ELSE
|
---|
| 677 | WRITE (NOUT,*) ' Shouldn''t be here in CHECK2'
|
---|
| 678 | STOP
|
---|
| 679 | END IF
|
---|
| 680 | 100 CONTINUE
|
---|
| 681 | 120 CONTINUE
|
---|
| 682 | RETURN
|
---|
| 683 | END
|
---|
| 684 | SUBROUTINE CHECK3(SFAC)
|
---|
| 685 | * .. Parameters ..
|
---|
| 686 | INTEGER NOUT
|
---|
| 687 | PARAMETER (NOUT=6)
|
---|
| 688 | * .. Scalar Arguments ..
|
---|
| 689 | REAL SFAC
|
---|
| 690 | * .. Scalars in Common ..
|
---|
| 691 | INTEGER ICASE, INCX, INCY, N
|
---|
| 692 | LOGICAL PASS
|
---|
| 693 | * .. Local Scalars ..
|
---|
| 694 | REAL SC, SS
|
---|
| 695 | INTEGER I, K, KI, KN, KSIZE, LENX, LENY, MX, MY
|
---|
| 696 | * .. Local Arrays ..
|
---|
| 697 | REAL COPYX(5), COPYY(5), DT9X(7,4,4), DT9Y(7,4,4),
|
---|
| 698 | + DX1(7), DY1(7), MWPC(11), MWPS(11), MWPSTX(5),
|
---|
| 699 | + MWPSTY(5), MWPTX(11,5), MWPTY(11,5), MWPX(5),
|
---|
| 700 | + MWPY(5), SSIZE2(14,2), STX(7), STY(7), SX(7),
|
---|
| 701 | + SY(7)
|
---|
| 702 | INTEGER INCXS(4), INCYS(4), LENS(4,2), MWPINX(11),
|
---|
| 703 | + MWPINY(11), MWPN(11), NS(4)
|
---|
| 704 | * .. External Subroutines ..
|
---|
| 705 | EXTERNAL SROT, STEST
|
---|
| 706 | * .. Intrinsic Functions ..
|
---|
| 707 | INTRINSIC ABS, MIN
|
---|
| 708 | * .. Common blocks ..
|
---|
| 709 | COMMON /COMBLA/ICASE, N, INCX, INCY, PASS
|
---|
| 710 | * .. Data statements ..
|
---|
| 711 | DATA INCXS/1, 2, -2, -1/
|
---|
| 712 | DATA INCYS/1, -2, 1, -2/
|
---|
| 713 | DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/
|
---|
| 714 | DATA NS/0, 1, 2, 4/
|
---|
| 715 | DATA DX1/0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.9E0, -0.3E0,
|
---|
| 716 | + -0.4E0/
|
---|
| 717 | DATA DY1/0.5E0, -0.9E0, 0.3E0, 0.7E0, -0.6E0, 0.2E0,
|
---|
| 718 | + 0.8E0/
|
---|
| 719 | DATA SC, SS/0.8E0, 0.6E0/
|
---|
| 720 | DATA DT9X/0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 721 | + 0.0E0, 0.78E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 722 | + 0.0E0, 0.0E0, 0.78E0, -0.46E0, 0.0E0, 0.0E0,
|
---|
| 723 | + 0.0E0, 0.0E0, 0.0E0, 0.78E0, -0.46E0, -0.22E0,
|
---|
| 724 | + 1.06E0, 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0,
|
---|
| 725 | + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.78E0,
|
---|
| 726 | + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 727 | + 0.66E0, 0.1E0, -0.1E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 728 | + 0.0E0, 0.96E0, 0.1E0, -0.76E0, 0.8E0, 0.90E0,
|
---|
| 729 | + -0.3E0, -0.02E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 730 | + 0.0E0, 0.0E0, 0.0E0, 0.78E0, 0.0E0, 0.0E0,
|
---|
| 731 | + 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.06E0, 0.1E0,
|
---|
| 732 | + -0.1E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.90E0,
|
---|
| 733 | + 0.1E0, -0.22E0, 0.8E0, 0.18E0, -0.3E0, -0.02E0,
|
---|
| 734 | + 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 735 | + 0.78E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 736 | + 0.0E0, 0.78E0, 0.26E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 737 | + 0.0E0, 0.0E0, 0.78E0, 0.26E0, -0.76E0, 1.12E0,
|
---|
| 738 | + 0.0E0, 0.0E0, 0.0E0/
|
---|
| 739 | DATA DT9Y/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 740 | + 0.0E0, 0.04E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 741 | + 0.0E0, 0.0E0, 0.04E0, -0.78E0, 0.0E0, 0.0E0,
|
---|
| 742 | + 0.0E0, 0.0E0, 0.0E0, 0.04E0, -0.78E0, 0.54E0,
|
---|
| 743 | + 0.08E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0,
|
---|
| 744 | + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.04E0,
|
---|
| 745 | + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.7E0,
|
---|
| 746 | + -0.9E0, -0.12E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 747 | + 0.64E0, -0.9E0, -0.30E0, 0.7E0, -0.18E0, 0.2E0,
|
---|
| 748 | + 0.28E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 749 | + 0.0E0, 0.0E0, 0.04E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 750 | + 0.0E0, 0.0E0, 0.0E0, 0.7E0, -1.08E0, 0.0E0,
|
---|
| 751 | + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.64E0, -1.26E0,
|
---|
| 752 | + 0.54E0, 0.20E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0,
|
---|
| 753 | + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 754 | + 0.04E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 755 | + 0.0E0, 0.04E0, -0.9E0, 0.18E0, 0.0E0, 0.0E0,
|
---|
| 756 | + 0.0E0, 0.0E0, 0.04E0, -0.9E0, 0.18E0, 0.7E0,
|
---|
| 757 | + -0.18E0, 0.2E0, 0.16E0/
|
---|
| 758 | DATA SSIZE2/0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 759 | + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
|
---|
| 760 | + 0.0E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0,
|
---|
| 761 | + 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0,
|
---|
| 762 | + 1.17E0, 1.17E0, 1.17E0/
|
---|
| 763 | * .. Executable Statements ..
|
---|
| 764 | *
|
---|
| 765 | DO 60 KI = 1, 4
|
---|
| 766 | INCX = INCXS(KI)
|
---|
| 767 | INCY = INCYS(KI)
|
---|
| 768 | MX = ABS(INCX)
|
---|
| 769 | MY = ABS(INCY)
|
---|
| 770 | *
|
---|
| 771 | DO 40 KN = 1, 4
|
---|
| 772 | N = NS(KN)
|
---|
| 773 | KSIZE = MIN(2,KN)
|
---|
| 774 | LENX = LENS(KN,MX)
|
---|
| 775 | LENY = LENS(KN,MY)
|
---|
| 776 | *
|
---|
| 777 | IF (ICASE.EQ.4) THEN
|
---|
| 778 | * .. SROT ..
|
---|
| 779 | DO 20 I = 1, 7
|
---|
| 780 | SX(I) = DX1(I)
|
---|
| 781 | SY(I) = DY1(I)
|
---|
| 782 | STX(I) = DT9X(I,KN,KI)
|
---|
| 783 | STY(I) = DT9Y(I,KN,KI)
|
---|
| 784 | 20 CONTINUE
|
---|
| 785 | CALL SROT(N,SX,INCX,SY,INCY,SC,SS)
|
---|
| 786 | CALL STEST(LENX,SX,STX,SSIZE2(1,KSIZE),SFAC)
|
---|
| 787 | CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC)
|
---|
| 788 | ELSE
|
---|
| 789 | WRITE (NOUT,*) ' Shouldn''t be here in CHECK3'
|
---|
| 790 | STOP
|
---|
| 791 | END IF
|
---|
| 792 | 40 CONTINUE
|
---|
| 793 | 60 CONTINUE
|
---|
| 794 | *
|
---|
| 795 | MWPC(1) = 1
|
---|
| 796 | DO 80 I = 2, 11
|
---|
| 797 | MWPC(I) = 0
|
---|
| 798 | 80 CONTINUE
|
---|
| 799 | MWPS(1) = 0
|
---|
| 800 | DO 100 I = 2, 6
|
---|
| 801 | MWPS(I) = 1
|
---|
| 802 | 100 CONTINUE
|
---|
| 803 | DO 120 I = 7, 11
|
---|
| 804 | MWPS(I) = -1
|
---|
| 805 | 120 CONTINUE
|
---|
| 806 | MWPINX(1) = 1
|
---|
| 807 | MWPINX(2) = 1
|
---|
| 808 | MWPINX(3) = 1
|
---|
| 809 | MWPINX(4) = -1
|
---|
| 810 | MWPINX(5) = 1
|
---|
| 811 | MWPINX(6) = -1
|
---|
| 812 | MWPINX(7) = 1
|
---|
| 813 | MWPINX(8) = 1
|
---|
| 814 | MWPINX(9) = -1
|
---|
| 815 | MWPINX(10) = 1
|
---|
| 816 | MWPINX(11) = -1
|
---|
| 817 | MWPINY(1) = 1
|
---|
| 818 | MWPINY(2) = 1
|
---|
| 819 | MWPINY(3) = -1
|
---|
| 820 | MWPINY(4) = -1
|
---|
| 821 | MWPINY(5) = 2
|
---|
| 822 | MWPINY(6) = 1
|
---|
| 823 | MWPINY(7) = 1
|
---|
| 824 | MWPINY(8) = -1
|
---|
| 825 | MWPINY(9) = -1
|
---|
| 826 | MWPINY(10) = 2
|
---|
| 827 | MWPINY(11) = 1
|
---|
| 828 | DO 140 I = 1, 11
|
---|
| 829 | MWPN(I) = 5
|
---|
| 830 | 140 CONTINUE
|
---|
| 831 | MWPN(5) = 3
|
---|
| 832 | MWPN(10) = 3
|
---|
| 833 | DO 160 I = 1, 5
|
---|
| 834 | MWPX(I) = I
|
---|
| 835 | MWPY(I) = I
|
---|
| 836 | MWPTX(1,I) = I
|
---|
| 837 | MWPTY(1,I) = I
|
---|
| 838 | MWPTX(2,I) = I
|
---|
| 839 | MWPTY(2,I) = -I
|
---|
| 840 | MWPTX(3,I) = 6 - I
|
---|
| 841 | MWPTY(3,I) = I - 6
|
---|
| 842 | MWPTX(4,I) = I
|
---|
| 843 | MWPTY(4,I) = -I
|
---|
| 844 | MWPTX(6,I) = 6 - I
|
---|
| 845 | MWPTY(6,I) = I - 6
|
---|
| 846 | MWPTX(7,I) = -I
|
---|
| 847 | MWPTY(7,I) = I
|
---|
| 848 | MWPTX(8,I) = I - 6
|
---|
| 849 | MWPTY(8,I) = 6 - I
|
---|
| 850 | MWPTX(9,I) = -I
|
---|
| 851 | MWPTY(9,I) = I
|
---|
| 852 | MWPTX(11,I) = I - 6
|
---|
| 853 | MWPTY(11,I) = 6 - I
|
---|
| 854 | 160 CONTINUE
|
---|
| 855 | MWPTX(5,1) = 1
|
---|
| 856 | MWPTX(5,2) = 3
|
---|
| 857 | MWPTX(5,3) = 5
|
---|
| 858 | MWPTX(5,4) = 4
|
---|
| 859 | MWPTX(5,5) = 5
|
---|
| 860 | MWPTY(5,1) = -1
|
---|
| 861 | MWPTY(5,2) = 2
|
---|
| 862 | MWPTY(5,3) = -2
|
---|
| 863 | MWPTY(5,4) = 4
|
---|
| 864 | MWPTY(5,5) = -3
|
---|
| 865 | MWPTX(10,1) = -1
|
---|
| 866 | MWPTX(10,2) = -3
|
---|
| 867 | MWPTX(10,3) = -5
|
---|
| 868 | MWPTX(10,4) = 4
|
---|
| 869 | MWPTX(10,5) = 5
|
---|
| 870 | MWPTY(10,1) = 1
|
---|
| 871 | MWPTY(10,2) = 2
|
---|
| 872 | MWPTY(10,3) = 2
|
---|
| 873 | MWPTY(10,4) = 4
|
---|
| 874 | MWPTY(10,5) = 3
|
---|
| 875 | DO 200 I = 1, 11
|
---|
| 876 | INCX = MWPINX(I)
|
---|
| 877 | INCY = MWPINY(I)
|
---|
| 878 | DO 180 K = 1, 5
|
---|
| 879 | COPYX(K) = MWPX(K)
|
---|
| 880 | COPYY(K) = MWPY(K)
|
---|
| 881 | MWPSTX(K) = MWPTX(I,K)
|
---|
| 882 | MWPSTY(K) = MWPTY(I,K)
|
---|
| 883 | 180 CONTINUE
|
---|
| 884 | CALL SROT(MWPN(I),COPYX,INCX,COPYY,INCY,MWPC(I),MWPS(I))
|
---|
| 885 | CALL STEST(5,COPYX,MWPSTX,MWPSTX,SFAC)
|
---|
| 886 | CALL STEST(5,COPYY,MWPSTY,MWPSTY,SFAC)
|
---|
| 887 | 200 CONTINUE
|
---|
| 888 | RETURN
|
---|
| 889 | END
|
---|
| 890 | SUBROUTINE STEST(LEN,SCOMP,STRUE,SSIZE,SFAC)
|
---|
| 891 | * ********************************* STEST **************************
|
---|
| 892 | *
|
---|
| 893 | * THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO
|
---|
| 894 | * SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
|
---|
| 895 | * NEGLIGIBLE.
|
---|
| 896 | *
|
---|
| 897 | * C. L. LAWSON, JPL, 1974 DEC 10
|
---|
| 898 | *
|
---|
| 899 | * .. Parameters ..
|
---|
| 900 | INTEGER NOUT
|
---|
| 901 | REAL ZERO
|
---|
| 902 | PARAMETER (NOUT=6, ZERO=0.0E0)
|
---|
| 903 | * .. Scalar Arguments ..
|
---|
| 904 | REAL SFAC
|
---|
| 905 | INTEGER LEN
|
---|
| 906 | * .. Array Arguments ..
|
---|
| 907 | REAL SCOMP(LEN), SSIZE(LEN), STRUE(LEN)
|
---|
| 908 | * .. Scalars in Common ..
|
---|
| 909 | INTEGER ICASE, INCX, INCY, N
|
---|
| 910 | LOGICAL PASS
|
---|
| 911 | * .. Local Scalars ..
|
---|
| 912 | REAL SD
|
---|
| 913 | INTEGER I
|
---|
| 914 | * .. External Functions ..
|
---|
| 915 | REAL SDIFF
|
---|
| 916 | EXTERNAL SDIFF
|
---|
| 917 | * .. Intrinsic Functions ..
|
---|
| 918 | INTRINSIC ABS
|
---|
| 919 | * .. Common blocks ..
|
---|
| 920 | COMMON /COMBLA/ICASE, N, INCX, INCY, PASS
|
---|
| 921 | * .. Executable Statements ..
|
---|
| 922 | *
|
---|
| 923 | DO 40 I = 1, LEN
|
---|
| 924 | SD = SCOMP(I) - STRUE(I)
|
---|
| 925 | IF (ABS(SFAC*SD) .LE. ABS(SSIZE(I))*EPSILON(ZERO))
|
---|
| 926 | + GO TO 40
|
---|
| 927 | *
|
---|
| 928 | * HERE SCOMP(I) IS NOT CLOSE TO STRUE(I).
|
---|
| 929 | *
|
---|
| 930 | IF ( .NOT. PASS) GO TO 20
|
---|
| 931 | * PRINT FAIL MESSAGE AND HEADER.
|
---|
| 932 | PASS = .FALSE.
|
---|
| 933 | WRITE (NOUT,99999)
|
---|
| 934 | WRITE (NOUT,99998)
|
---|
| 935 | 20 WRITE (NOUT,99997) ICASE, N, INCX, INCY, I, SCOMP(I),
|
---|
| 936 | + STRUE(I), SD, SSIZE(I)
|
---|
| 937 | 40 CONTINUE
|
---|
| 938 | RETURN
|
---|
| 939 | *
|
---|
| 940 | 99999 FORMAT (' FAIL')
|
---|
| 941 | 99998 FORMAT (/' CASE N INCX INCY I ',
|
---|
| 942 | + ' COMP(I) TRUE(I) DIFFERENCE',
|
---|
| 943 | + ' SIZE(I)',/1X)
|
---|
| 944 | 99997 FORMAT (1X,I4,I3,2I5,I3,2E36.8,2E12.4)
|
---|
| 945 | END
|
---|
| 946 | SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC)
|
---|
| 947 | * ************************* STEST1 *****************************
|
---|
| 948 | *
|
---|
| 949 | * THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN
|
---|
| 950 | * REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
|
---|
| 951 | * ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
|
---|
| 952 | *
|
---|
| 953 | * C.L. LAWSON, JPL, 1978 DEC 6
|
---|
| 954 | *
|
---|
| 955 | * .. Scalar Arguments ..
|
---|
| 956 | REAL SCOMP1, SFAC, STRUE1
|
---|
| 957 | * .. Array Arguments ..
|
---|
| 958 | REAL SSIZE(*)
|
---|
| 959 | * .. Local Arrays ..
|
---|
| 960 | REAL SCOMP(1), STRUE(1)
|
---|
| 961 | * .. External Subroutines ..
|
---|
| 962 | EXTERNAL STEST
|
---|
| 963 | * .. Executable Statements ..
|
---|
| 964 | *
|
---|
| 965 | SCOMP(1) = SCOMP1
|
---|
| 966 | STRUE(1) = STRUE1
|
---|
| 967 | CALL STEST(1,SCOMP,STRUE,SSIZE,SFAC)
|
---|
| 968 | *
|
---|
| 969 | RETURN
|
---|
| 970 | END
|
---|
| 971 | REAL FUNCTION SDIFF(SA,SB)
|
---|
| 972 | * ********************************* SDIFF **************************
|
---|
| 973 | * COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
|
---|
| 974 | *
|
---|
| 975 | * .. Scalar Arguments ..
|
---|
| 976 | REAL SA, SB
|
---|
| 977 | * .. Executable Statements ..
|
---|
| 978 | SDIFF = SA - SB
|
---|
| 979 | RETURN
|
---|
| 980 | END
|
---|
| 981 | SUBROUTINE ITEST1(ICOMP,ITRUE)
|
---|
| 982 | * ********************************* ITEST1 *************************
|
---|
| 983 | *
|
---|
| 984 | * THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
|
---|
| 985 | * EQUALITY.
|
---|
| 986 | * C. L. LAWSON, JPL, 1974 DEC 10
|
---|
| 987 | *
|
---|
| 988 | * .. Parameters ..
|
---|
| 989 | INTEGER NOUT
|
---|
| 990 | PARAMETER (NOUT=6)
|
---|
| 991 | * .. Scalar Arguments ..
|
---|
| 992 | INTEGER ICOMP, ITRUE
|
---|
| 993 | * .. Scalars in Common ..
|
---|
| 994 | INTEGER ICASE, INCX, INCY, N
|
---|
| 995 | LOGICAL PASS
|
---|
| 996 | * .. Local Scalars ..
|
---|
| 997 | INTEGER ID
|
---|
| 998 | * .. Common blocks ..
|
---|
| 999 | COMMON /COMBLA/ICASE, N, INCX, INCY, PASS
|
---|
| 1000 | * .. Executable Statements ..
|
---|
| 1001 | *
|
---|
| 1002 | IF (ICOMP.EQ.ITRUE) GO TO 40
|
---|
| 1003 | *
|
---|
| 1004 | * HERE ICOMP IS NOT EQUAL TO ITRUE.
|
---|
| 1005 | *
|
---|
| 1006 | IF ( .NOT. PASS) GO TO 20
|
---|
| 1007 | * PRINT FAIL MESSAGE AND HEADER.
|
---|
| 1008 | PASS = .FALSE.
|
---|
| 1009 | WRITE (NOUT,99999)
|
---|
| 1010 | WRITE (NOUT,99998)
|
---|
| 1011 | 20 ID = ICOMP - ITRUE
|
---|
| 1012 | WRITE (NOUT,99997) ICASE, N, INCX, INCY, ICOMP, ITRUE, ID
|
---|
| 1013 | 40 CONTINUE
|
---|
| 1014 | RETURN
|
---|
| 1015 | *
|
---|
| 1016 | 99999 FORMAT (' FAIL')
|
---|
| 1017 | 99998 FORMAT (/' CASE N INCX INCY ',
|
---|
| 1018 | + ' COMP TRUE DIFFERENCE',
|
---|
| 1019 | + /1X)
|
---|
| 1020 | 99997 FORMAT (1X,I4,I3,2I5,2I36,I12)
|
---|
| 1021 | END
|
---|