1 SUBROUTINE DPTIQP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2 1 ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 3C 4C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS 5C THAT WILL DEFINE A TRUNCATED INFORMATIVE QUANTILE 6C (TIQ) PLOT. 7C EXAMPLES--NORMAL TIQ PLOT Y 8C LOGNORMAL TIQ PLOT Y 9C UNIFORM TIQ PLOT Y 10C GUMBEL TIQ PLOT Y 11C WEIBULL TIQ PLOT Y 12C LOGISTIC TIQ PLOT Y 13C DOUBLE EXPONENTIAL TIQ PLOT Y 14C CAUCHY TIQ PLOT Y 15C SEMICIRCULAR TIQ PLOT Y 16C COSINE TIQ PLOT Y 17C ANGLIT TIQ PLOT Y 18C HYPERBOLIC SECANT TIQ PLOT Y 19C HALF-NORMAL TIQ PLOT Y 20C ARCSINE TIQ PLOT Y 21C EXPONENTIAL TIQ PLOT Y 22C HALF-CAUCHY TIQ PLOT Y 23C SLASH TIQ PLOT Y 24C RAYLEIGH TIQ PLOT Y 25C MAXWELL TIQ PLOT Y 26C 27C REFERENCE--"MIL-HDBK-17-1F Volume 1: Guidelines for Characterization 28C of Structural Materials", Depeartment of Defense, 29C chapter 8, 2002. 30C WRITTEN BY--ALAN HECKERT 31C STATISTICAL ENGINEERING DIVISION 32C INFORMATION TECHNOLOGY LABORATORY 33C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 34C GAITHERSBURG, MD 20899-8980 35C PHONE--301-975-2899 36C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 37C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 38C LANGUAGE--ANSI FORTRAN (1977) 39C VERSION NUMBER--2017/03 40C ORIGINAL VERSION--MARCH 2017. 41C 42C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 43C 44 CHARACTER*4 ICASPL 45 CHARACTER*4 IAND1 46 CHARACTER*4 IAND2 47 CHARACTER*4 ISUBRO 48 CHARACTER*4 IBUGG2 49 CHARACTER*4 IBUGG3 50 CHARACTER*4 IBUGQ 51 CHARACTER*4 IFOUND 52 CHARACTER*4 IERROR 53C 54 CHARACTER*4 ICASE2 55 CHARACTER*4 ICASE 56 CHARACTER*4 ISUBN1 57 CHARACTER*4 ISUBN2 58 CHARACTER*4 ISTEPN 59C 60C--------------------------------------------------------------------- 61C 62 INCLUDE 'DPCOPA.INC' 63C 64 DIMENSION Y1(MAXOBV) 65 DIMENSION TEMP1(MAXOBV) 66 DIMENSION TEMP2(MAXOBV) 67 DIMENSION TEMP3(MAXOBV) 68 DIMENSION TEMP4(MAXOBV) 69C 70 INCLUDE 'DPCOZZ.INC' 71C 72 EQUIVALENCE (GARBAG(IGARB1),Y1(1)) 73 EQUIVALENCE (GARBAG(IGARB2),TEMP1(1)) 74 EQUIVALENCE (GARBAG(IGARB3),TEMP2(1)) 75 EQUIVALENCE (GARBAG(IGARB4),TEMP3(1)) 76 EQUIVALENCE (GARBAG(IGARB5),TEMP4(1)) 77C 78 CHARACTER*40 INAME 79 PARAMETER (MAXSPN=30) 80 CHARACTER*4 IVARN1(MAXSPN) 81 CHARACTER*4 IVARN2(MAXSPN) 82 CHARACTER*4 IVARTY(MAXSPN) 83 REAL PVAR(MAXSPN) 84 INTEGER ILIS(MAXSPN) 85 INTEGER NRIGHT(MAXSPN) 86 INTEGER ICOLR(MAXSPN) 87C 88C-----COMMON---------------------------------------------------------- 89C 90 INCLUDE 'DPCOHK.INC' 91 INCLUDE 'DPCODA.INC' 92 INCLUDE 'DPCOS2.INC' 93 INCLUDE 'DPCOP2.INC' 94C 95C-----START POINT----------------------------------------------------- 96C 97 IFOUND='NO' 98 IERROR='NO' 99 ISUBN1='DPTI' 100 ISUBN2='QP ' 101 ICASPL='TIQP' 102C 103 MAXCP1=MAXCOL+1 104 MAXCP2=MAXCOL+2 105 MAXCP3=MAXCOL+3 106 MAXCP4=MAXCOL+4 107 MAXCP5=MAXCOL+5 108 MAXCP6=MAXCOL+6 109 MAXV2=1 110 MINN2=20 111C 112C *************************************************** 113C ** TREAT THE TIQ PLOT ** 114C *************************************************** 115C 116 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TIQP')THEN 117 WRITE(ICOUT,999) 118 999 FORMAT(1X) 119 CALL DPWRST('XXX','BUG ') 120 WRITE(ICOUT,51) 121 51 FORMAT('***** AT THE BEGINNING OF DPTIQP--') 122 CALL DPWRST('XXX','BUG ') 123 WRITE(ICOUT,52)ICASPL,IAND1,IAND2,NS 124 52 FORMAT('ICASPL,IAND1,IAND2,NS = ',3(A4,2X),I8) 125 CALL DPWRST('XXX','BUG ') 126 WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO 127 53 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4) 128 CALL DPWRST('XXX','BUG ') 129 ENDIF 130C 131C ****************************************************** 132C ** STEP 1-- ** 133C ** EXTRACT THE COMMAND ** 134C ** REPLICATION AND MULTIPLE NOT SUPPORTED FOR THIS ** 135C ** COMMAND. ** 136C ****************************************************** 137C 138 ISTEPN='1' 139 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TIQP') 140 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 141C 142 143 IF(ICOM.EQ.'NORM' .AND. IHARG(1).EQ.'TIQ ' .AND. 144 1 IHARG(2).EQ.'PLOT')THEN 145 ILASTC=2 146 ICASE='NORM' 147 ELSEIF(ICOM.EQ.'NORM' .AND. IHARG(1).EQ.'TRUN' .AND. 148 1 IHARG(2).EQ.'INFO' .AND. IHARG(3).EQ.'QUAN' .AND. 149 1 IHARG(4).EQ.'PLOT')THEN 150 ILASTC=4 151 ICASE='NORM' 152 ELSEIF(ICOM.EQ.'LOGN' .AND. IHARG(1).EQ.'TIQ ' .AND. 153 1 IHARG(2).EQ.'PLOT')THEN 154 ILASTC=2 155 ICASE='LOGN' 156 ELSEIF(ICOM.EQ.'LOGN' .AND. IHARG(1).EQ.'TRUN' .AND. 157 1 IHARG(2).EQ.'INFO' .AND. IHARG(3).EQ.'QUAN' .AND. 158 1 IHARG(4).EQ.'PLOT')THEN 159 ILASTC=4 160 ICASE='LOGN' 161 ELSEIF(ICOM.EQ.'WEIB' .AND. IHARG(1).EQ.'TIQ ' .AND. 162 1 IHARG(2).EQ.'PLOT')THEN 163 ILASTC=2 164 ICASE='WEIB' 165 ELSEIF(ICOM.EQ.'WEIB' .AND. IHARG(1).EQ.'TRUN' .AND. 166 1 IHARG(2).EQ.'INFO' .AND. IHARG(3).EQ.'QUAN' .AND. 167 1 IHARG(4).EQ.'PLOT')THEN 168 ILASTC=4 169 ICASE='WEIB' 170 ELSEIF(ICOM.EQ.'GUMB' .AND. IHARG(1).EQ.'TIQ ' .AND. 171 1 IHARG(2).EQ.'PLOT')THEN 172 ILASTC=2 173 ICASE='GUMB' 174 ELSEIF(ICOM.EQ.'GUMB' .AND. IHARG(1).EQ.'TRUN' .AND. 175 1 IHARG(2).EQ.'INFO' .AND. IHARG(3).EQ.'QUAN' .AND. 176 1 IHARG(4).EQ.'PLOT')THEN 177 ILASTC=4 178 ICASE='GUMB' 179 ELSEIF(ICOM.EQ.'EXTR' .AND. IHARG(1).EQ.'VALU' .AND. 180 1 IHARG(2).EQ.'TYPE' .AND. 181 1 (IHARG(3).EQ.'1 ' .OR. IHARG(3).EQ.'I ') .AND. 182 1 IHARG(4).EQ.'TIQ ' .AND. 183 1 IHARG(5).EQ.'PLOT')THEN 184 ILASTC=5 185 ICASE='GUMB' 186 ELSEIF(ICOM.EQ.'EXTR' .AND. IHARG(1).EQ.'VALU' .AND. 187 1 IHARG(2).EQ.'TYPE' .AND. 188 1 (IHARG(3).EQ.'1 ' .OR. IHARG(3).EQ.'I ') .AND. 189 1 IHARG(4).EQ.'TRUN' .AND. IHARG(5).EQ.'INFO' .AND. 190 1 IHARG(6).EQ.'QUAN' .AND. IHARG(7).EQ.'PLOT')THEN 191 ILASTC=7 192 ICASE='GUMB' 193 ELSEIF(ICOM.EQ.'UNIF' .AND. IHARG(1).EQ.'TIQ ' .AND. 194 1 IHARG(2).EQ.'PLOT')THEN 195 ILASTC=2 196 ICASE='UNIF' 197 ELSEIF(ICOM.EQ.'UNIF' .AND. IHARG(1).EQ.'TRUN' .AND. 198 1 IHARG(2).EQ.'INFO' .AND. IHARG(3).EQ.'QUAN' .AND. 199 1 IHARG(4).EQ.'PLOT')THEN 200 ILASTC=4 201 ICASE='UNIF' 202 ELSEIF(ICOM.EQ.'LOGI' .AND. IHARG(1).EQ.'TIQ ' .AND. 203 1 IHARG(2).EQ.'PLOT')THEN 204 ILASTC=2 205 ICASE='LOGI' 206 ELSEIF(ICOM.EQ.'LOGI' .AND. IHARG(1).EQ.'TRUN' .AND. 207 1 IHARG(2).EQ.'INFO' .AND. IHARG(3).EQ.'QUAN' .AND. 208 1 IHARG(4).EQ.'PLOT')THEN 209 ILASTC=4 210 ICASE='LOGI' 211 ELSEIF(ICOM.EQ.'EXPO' .AND. IHARG(1).EQ.'TIQ ' .AND. 212 1 IHARG(2).EQ.'PLOT')THEN 213 ILASTC=2 214 ICASE='EXPO' 215 ELSEIF(ICOM.EQ.'EXPO' .AND. IHARG(1).EQ.'TRUN' .AND. 216 1 IHARG(2).EQ.'INFO' .AND. IHARG(3).EQ.'QUAN' .AND. 217 1 IHARG(4).EQ.'PLOT')THEN 218 ILASTC=4 219 ICASE='EXPO' 220 ELSEIF(ICOM.EQ.'ARCS' .AND. IHARG(1).EQ.'TIQ ' .AND. 221 1 IHARG(2).EQ.'PLOT')THEN 222 ILASTC=2 223 ICASE='ARCS' 224 ELSEIF(ICOM.EQ.'ARCS' .AND. IHARG(1).EQ.'TRUN' .AND. 225 1 IHARG(2).EQ.'INFO' .AND. IHARG(3).EQ.'QUAN' .AND. 226 1 IHARG(4).EQ.'PLOT')THEN 227 ILASTC=4 228 ICASE='ARCS' 229 ELSEIF(ICOM.EQ.'ANGL' .AND. IHARG(1).EQ.'TIQ ' .AND. 230 1 IHARG(2).EQ.'PLOT')THEN 231 ILASTC=2 232 ICASE='ANGL' 233 ELSEIF(ICOM.EQ.'ANGL' .AND. IHARG(1).EQ.'TRUN' .AND. 234 1 IHARG(2).EQ.'INFO' .AND. IHARG(3).EQ.'QUAN' .AND. 235 1 IHARG(4).EQ.'PLOT')THEN 236 ILASTC=4 237 ICASE='ANGL' 238 ELSEIF(ICOM.EQ.'COSI' .AND. IHARG(1).EQ.'TIQ ' .AND. 239 1 IHARG(2).EQ.'PLOT')THEN 240 ILASTC=2 241 ICASE='COSI' 242 ELSEIF(ICOM.EQ.'COSI' .AND. IHARG(1).EQ.'TRUN' .AND. 243 1 IHARG(2).EQ.'INFO' .AND. IHARG(3).EQ.'QUAN' .AND. 244 1 IHARG(4).EQ.'PLOT')THEN 245 ILASTC=4 246 ICASE='COSI' 247 ELSEIF(ICOM.EQ.'CAUC' .AND. IHARG(1).EQ.'TIQ ' .AND. 248 1 IHARG(2).EQ.'PLOT')THEN 249 ILASTC=2 250 ICASE='CAUC' 251 ELSEIF(ICOM.EQ.'CAUC' .AND. IHARG(1).EQ.'TRUN' .AND. 252 1 IHARG(2).EQ.'INFO' .AND. IHARG(3).EQ.'QUAN' .AND. 253 1 IHARG(4).EQ.'PLOT')THEN 254 ILASTC=4 255 ICASE='CAUC' 256 ELSEIF(ICOM.EQ.'SLAS' .AND. IHARG(1).EQ.'TIQ ' .AND. 257 1 IHARG(2).EQ.'PLOT')THEN 258 ILASTC=2 259 ICASE='SLAS' 260 ELSEIF(ICOM.EQ.'SLAS' .AND. IHARG(1).EQ.'TRUN' .AND. 261 1 IHARG(2).EQ.'INFO' .AND. IHARG(3).EQ.'QUAN' .AND. 262 1 IHARG(4).EQ.'PLOT')THEN 263 ILASTC=4 264 ICASE='SLAS' 265 ELSEIF(ICOM.EQ.'SLAS' .AND. IHARG(1).EQ.'TIQ ' .AND. 266 1 IHARG(2).EQ.'PLOT')THEN 267 ILASTC=2 268 ICASE='SLAS' 269 ELSEIF(ICOM.EQ.'SLAS' .AND. IHARG(1).EQ.'TRUN' .AND. 270 1 IHARG(2).EQ.'INFO' .AND. IHARG(3).EQ.'QUAN' .AND. 271 1 IHARG(4).EQ.'PLOT')THEN 272 ILASTC=4 273 ICASE='SLAS' 274 ELSEIF(ICOM.EQ.'RAYL' .AND. IHARG(1).EQ.'TIQ ' .AND. 275 1 IHARG(2).EQ.'PLOT')THEN 276 ILASTC=2 277 ICASE='RAYL' 278 ELSEIF(ICOM.EQ.'RAYL' .AND. IHARG(1).EQ.'TRUN' .AND. 279 1 IHARG(2).EQ.'INFO' .AND. IHARG(3).EQ.'QUAN' .AND. 280 1 IHARG(4).EQ.'PLOT')THEN 281 ILASTC=4 282 ICASE='RAYL' 283 ELSEIF(ICOM.EQ.'MAXW' .AND. IHARG(1).EQ.'TIQ ' .AND. 284 1 IHARG(2).EQ.'PLOT')THEN 285 ILASTC=2 286 ICASE='MAXW' 287 ELSEIF(ICOM.EQ.'MAXW' .AND. IHARG(1).EQ.'TRUN' .AND. 288 1 IHARG(2).EQ.'INFO' .AND. IHARG(3).EQ.'QUAN' .AND. 289 1 IHARG(4).EQ.'PLOT')THEN 290 ILASTC=4 291 ICASE='MAXW' 292 ELSEIF(ICOM.EQ.'HALF' .AND. IHARG(1).EQ.'NORM' .AND. 293 1 IHARG(2).EQ.'TIQ ' .AND. IHARG(3).EQ.'PLOT')THEN 294 ILASTC=3 295 ICASE='HANO' 296 ELSEIF(ICOM.EQ.'HALF' .AND. IHARG(1).EQ.'NORM' .AND. 297 1 IHARG(2).EQ.'TRUN' .AND. IHARG(3).EQ.'INFO' .AND. 298 1 IHARG(4).EQ.'QUAN' .AND. IHARG(5).EQ.'PLOT')THEN 299 ILASTC=5 300 ICASE='HANO' 301 ELSEIF(ICOM.EQ.'HALF' .AND. IHARG(1).EQ.'CAUC' .AND. 302 1 IHARG(2).EQ.'TIQ ' .AND. IHARG(3).EQ.'PLOT')THEN 303 ILASTC=3 304 ICASE='HACA' 305 ELSEIF(ICOM.EQ.'HALF' .AND. IHARG(1).EQ.'CAUC' .AND. 306 1 IHARG(2).EQ.'TRUN' .AND. IHARG(3).EQ.'INFO' .AND. 307 1 IHARG(4).EQ.'QUAN' .AND. IHARG(5).EQ.'PLOT')THEN 308 ILASTC=5 309 ICASE='HACO' 310 ELSEIF(ICOM.EQ.'HYPE' .AND. IHARG(1).EQ.'SECA' .AND. 311 1 IHARG(2).EQ.'TIQ ' .AND. IHARG(3).EQ.'PLOT')THEN 312 ILASTC=3 313 ICASE='HSE ' 314 ELSEIF(ICOM.EQ.'HYPE' .AND. IHARG(1).EQ.'SECA' .AND. 315 1 IHARG(2).EQ.'TRUN' .AND. IHARG(3).EQ.'INFO' .AND. 316 1 IHARG(4).EQ.'QUAN' .AND. IHARG(5).EQ.'PLOT')THEN 317 ILASTC=5 318 ICASE='HSE ' 319 ELSEIF(ICOM.EQ.'LAPL' .AND. IHARG(1).EQ.'TIQ ' .AND. 320 1 IHARG(2).EQ.'PLOT')THEN 321 ILASTC=2 322 ICASE='DEX ' 323 ELSEIF(ICOM.EQ.'LAPL' .AND. IHARG(1).EQ.'TRUN' .AND. 324 1 IHARG(2).EQ.'INFO' .AND. IHARG(3).EQ.'QUAN' .AND. 325 1 IHARG(4).EQ.'PLOT')THEN 326 ILASTC=4 327 ICASE='DEX ' 328 ELSEIF(ICOM.EQ.'DOUB' .AND. IHARG(1).EQ.'EXPO' .AND. 329 1 IHARG(2).EQ.'TIQ ' .AND. IHARG(3).EQ.'PLOT')THEN 330 ILASTC=3 331 ICASE='DEX ' 332 ELSEIF(ICOM.EQ.'DOUB' .AND. IHARG(1).EQ.'EXPO' .AND. 333 1 IHARG(2).EQ.'TRUN' .AND. IHARG(3).EQ.'INFO' .AND. 334 1 IHARG(4).EQ.'QUAN' .AND. IHARG(5).EQ.'PLOT')THEN 335 ILASTC=5 336 ICASE='DEX ' 337 ELSEIF(ICOM.EQ.'SEMI' .AND. IHARG(1).EQ.'CIRC' .AND. 338 1 IHARG(2).EQ.'TIQ ' .AND. IHARG(3).EQ.'PLOT')THEN 339 ILASTC=3 340 ICASE='SEMC' 341 ELSEIF(ICOM.EQ.'SEMI' .AND. IHARG(1).EQ.'CIRC' .AND. 342 1 IHARG(2).EQ.'TRUN' .AND. IHARG(3).EQ.'INFO' .AND. 343 1 IHARG(4).EQ.'QUAN' .AND. IHARG(5).EQ.'PLOT')THEN 344 ILASTC=5 345 ICASE='SEMC' 346 ELSE 347 GOTO9000 348 ENDIF 349C 350 IFOUND='YES' 351 IF(ILASTC.GE.1)THEN 352 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 353 ILASTC=0 354 ENDIF 355C 356 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'TIQP')THEN 357 WRITE(ICOUT,112)ICASPL,IMULT,IREPL 358 112 FORMAT('ICASPL,IMULT,IREPL = ',2(A4,2X),A4) 359 CALL DPWRST('XXX','BUG ') 360 ENDIF 361C 362C **************************************** 363C ** STEP 2-- ** 364C ** EXTRACT THE VARIABLE LIST ** 365C **************************************** 366C 367 ISTEPN='2' 368 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TIQP') 369 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 370C 371 INAME='TRUNCATED INFORMATIVE QUANTILE PLOT' 372 MINNA=1 373 MAXNA=100 374 MINN2=5 375 IFLAGE=1 376 IFLAGM=1 377 IFLAGP=0 378 JMIN=1 379 JMAX=NUMARG 380 MINNVA=1 381 MAXNVA=1 382C 383 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 384 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 385 1 JMIN,JMAX, 386 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 387 1 IVARN1,IVARN2,IVARTY,PVAR, 388 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 389 1 MINNVA,MAXNVA, 390 1 IFLAGM,IFLAGP, 391 1 IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 392 IF(IERROR.EQ.'YES')GOTO9000 393C 394 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TIQP')THEN 395 WRITE(ICOUT,999) 396 CALL DPWRST('XXX','BUG ') 397 WRITE(ICOUT,281) 398 281 FORMAT('***** AFTER CALL DPPARS--') 399 CALL DPWRST('XXX','BUG ') 400 WRITE(ICOUT,282)NQ,NUMVAR 401 282 FORMAT('NQ,NUMVAR = ',2I8) 402 CALL DPWRST('XXX','BUG ') 403 IF(NUMVAR.GT.0)THEN 404 DO285I=1,NUMVAR 405 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 406 1 ICOLR(I) 407 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 408 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 409 CALL DPWRST('XXX','BUG ') 410 285 CONTINUE 411 ENDIF 412 ENDIF 413C 414C ******************************************** 415C ** STEP 6-- ** 416C ** GENERATE THE TIQ PLOTS FOR ** 417C ** THE VARIOUS CASES. ** 418C ******************************************** 419C 420 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TIQP')THEN 421 ISTEPN='6' 422 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 423 WRITE(ICOUT,601)NRESP,NREPL 424 601 FORMAT('NRESP,NREPL = ',2I5) 425 CALL DPWRST('XXX','BUG ') 426 ENDIF 427C 428C ****************************************** 429C ** STEP 8A-- ** 430C ****************************************** 431C 432 ISTEPN='8A' 433 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TIQP') 434 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 435C 436 NPLOTP=0 437 ICOL=1 438 NUMVA2=1 439 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 440 1 INAME,IVARN1,IVARN2,IVARTY, 441 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 442 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 443 1 MAXCP4,MAXCP5,MAXCP6, 444 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 445 1 Y1,TEMP1,TEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE2, 446 1 IBUGG3,ISUBRO,IFOUND,IERROR) 447 IF(IERROR.EQ.'YES')GOTO9000 448C 449C ***************************************************** 450C ** STEP 8B-- ** 451C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** 452C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** 453C ***************************************************** 454C 455 CALL DPTIQ2(Y1,TEMP1,TEMP2,TEMP3,TEMP4,NLOCAL, 456 1 ICASE,MINMAX, 457 1 Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 458C 459C ***************** 460C ** STEP 90-- ** 461C ** EXIT ** 462C ***************** 463C 464 9000 CONTINUE 465 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TIQP')THEN 466 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 467 WRITE(ICOUT,999) 468 CALL DPWRST('XXX','BUG ') 469 WRITE(ICOUT,9011) 470 9011 FORMAT('***** AT THE END OF DPTIQP--') 471 CALL DPWRST('XXX','BUG ') 472 WRITE(ICOUT,9012)IFOUND,IERROR,ICASPL,IAND1,IAND2 473 9012 FORMAT('IFOUND,IERROR,ICASPL,IAND1,IAND2 = ',4(A4,2X),A4) 474 CALL DPWRST('XXX','BUG ') 475 WRITE(ICOUT,9013)NPLOTV,NPLOTP,NLOCAL 476 9013 FORMAT('NPLOTV,NPLOTP,NLOCAL = ',3I8) 477 CALL DPWRST('XXX','BUG ') 478 IF(NPLOTP.GE.1)THEN 479 DO9015I=1,NPLOTP 480 WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 481 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) 482 CALL DPWRST('XXX','BUG ') 483 9015 CONTINUE 484 ENDIF 485 ENDIF 486C 487 RETURN 488 END 489 SUBROUTINE DPTIQ2(Y,AIQHAT,TIQHAT,UTEMP,QUHAT,N, 490 1 ICASPL,MINMAX, 491 1 Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR) 492C 493C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS 494C THAT WILL DEFINE A TRUNCATED INFORMATIVE QUANTILE 495C (TIQ) PLOT. 496C 497C REFERENCE--"MIL-HDBK-17-1F Volume 1: Guidelines for Characterization 498C of Structural Materials", Depeartment of Defense, 499C chapter 8, 2002. 500C 501C WRITTEN BY--ALAN HECKERT 502C STATISTICAL ENGINEERING DIVISION 503C INFORMATION TECHNOLOGY LABORATORY 504C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 505C GAITHERSBURG, MD 20899-8980 506C PHONE--301-975-2899 507C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 508C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 509C LANGUAGE--ANSI FORTRAN (1977) 510C VERSION NUMBER--2017/03 511C ORIGINAL VERSION--MARCH 2017. 512C 513C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 514C 515 CHARACTER*4 ICASPL 516 CHARACTER*4 IBUGG3 517 CHARACTER*4 ISUBRO 518 CHARACTER*4 IERROR 519C 520 CHARACTER*4 ISUBN1 521 CHARACTER*4 ISUBN2 522 CHARACTER*4 IWRITE 523C 524C--------------------------------------------------------------------- 525C 526 DIMENSION Y(*) 527 DIMENSION UTEMP(*) 528 DIMENSION AIQHAT(*) 529 DIMENSION TIQHAT(*) 530 DIMENSION QUHAT(*) 531 DIMENSION Y2(*) 532 DIMENSION X2(*) 533 DIMENSION D2(*) 534C 535C-----COMMON---------------------------------------------------------- 536C 537 INCLUDE 'DPCOST.INC' 538 INCLUDE 'DPCOP2.INC' 539C 540C-----START POINT----------------------------------------------------- 541C 542 ISUBN1='DPTI' 543 ISUBN2='Q2 ' 544 IWRITE='OFF ' 545 IERROR='NO' 546C 547 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TIQ2')THEN 548 WRITE(ICOUT,999) 549 CALL DPWRST('XXX','BUG ') 550 WRITE(ICOUT,70) 551 70 FORMAT('***** AT THE BEGINNING OF DPTIQ2--') 552 CALL DPWRST('XXX','BUG ') 553 WRITE(ICOUT,72)N,MINMAX,ICASPL 554 72 FORMAT('N,MINMAX,ICASPL = ',2I8,2X,A4) 555 CALL DPWRST('XXX','BUG ') 556 DO73I=1,N 557 WRITE(ICOUT,74)I,Y(I) 558 74 FORMAT('I, Y(I) = ',I8,G15.7) 559 CALL DPWRST('XXX','BUG ') 560 73 CONTINUE 561 ENDIF 562C 563C ******************************************** 564C ** STEP 1-- ** 565C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 566C ******************************************** 567C 568 IF(N.LT.5)THEN 569 WRITE(ICOUT,999) 570 999 FORMAT(1X) 571 CALL DPWRST('XXX','BUG ') 572 WRITE(ICOUT,31) 573 31 FORMAT('***** ERROR IN TRUNCATED INFORMATIVE QUANTILE PLOT--') 574 CALL DPWRST('XXX','BUG ') 575 WRITE(ICOUT,32) 576 32 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 5;') 577 CALL DPWRST('XXX','BUG ') 578 WRITE(ICOUT,34)N 579 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) 580 CALL DPWRST('XXX','BUG ') 581 WRITE(ICOUT,999) 582 CALL DPWRST('XXX','BUG ') 583 IERROR='YES' 584 GOTO9000 585 ENDIF 586C 587 HOLD=Y(1) 588 DO60I=1,N 589 IF(Y(I).NE.HOLD)GOTO69 590 60 CONTINUE 591 WRITE(ICOUT,999) 592 CALL DPWRST('XXX','BUG ') 593 WRITE(ICOUT,31) 594 CALL DPWRST('XXX','BUG ') 595 WRITE(ICOUT,62) 596 62 FORMAT(' ALL INPUT HORIZONTAL AXIS ELEMENTS') 597 CALL DPWRST('XXX','BUG ') 598 WRITE(ICOUT,63)HOLD 599 63 FORMAT(' ARE IDENTICALLY EQUAL TO ',G15.7) 600 CALL DPWRST('XXX','BUG ') 601 WRITE(ICOUT,999) 602 CALL DPWRST('XXX','BUG ') 603 IERROR='YES' 604 GOTO9000 605 69 CONTINUE 606C 607C ********************************************** 608C ** STEP 2-- ** 609C ** FOR WEIBULL AND LOGNORMAL, NEED TO TAKE ** 610C ** LOG OF THE DATA. ** 611C ********************************************** 612C 613 IF(ICASPL.EQ.'WEIB' .OR. ICASPL.EQ.'LOGN')THEN 614 DO200I=1,N 615 IF(Y(I).LE.0.0)THEN 616 WRITE(ICOUT,999) 617 CALL DPWRST('XXX','BUG ') 618 WRITE(ICOUT,31) 619 CALL DPWRST('XXX','BUG ') 620 WRITE(ICOUT,202)I 621 202 FORMAT(' ROW ',I8,' OF THE RESPONSE VARIABLE IS ', 622 1 'NON-POSITIVE.') 623 CALL DPWRST('XXX','BUG ') 624 WRITE(ICOUT,204)Y(I) 625 204 FORMAT(' IT HAS THE VALUE ',G15.7) 626 CALL DPWRST('XXX','BUG ') 627 IERROR='YES' 628 GOTO9000 629 ENDIF 630 Y(I)=LOG(Y(I)) 631 200 CONTINUE 632 ENDIF 633C 634C ********************************************** 635C ** STEP 3-- ** 636C ** CALL EMPQUA ROUTINE TO COMPUTE THE ** 637C ** TRUNCATED INFORMATIVE QUANTILE FUNCTION ** 638C ********************************************** 639C 640C 641 CALL EMPTIQ(Y,N,IWRITE,AIQHAT,TIQHAT,UTEMP,QUHAT,NOUT, 642 1 IBUGG3,ISUBRO,IERROR) 643 IF(IERROR.EQ.'YES')GOTO9000 644C 645 DO310I=1,NOUT 646 N2=N2+1 647 Y2(N2)=TIQHAT(I) 648 X2(N2)=100.0*UTEMP(I) 649 D2(N2)=1.0 650 310 CONTINUE 651C 652C ********************************************** 653C ** STEP 4-- ** 654C ** NOW COMPUTE THE TRUNCATED INFORMATIVE ** 655C ** QUANTILE FUNCTION FOR A THEORETICAL ** 656C ** DISTRIBUTION. ** 657C ********************************************** 658C 659C 660 U25=0.25 661 U50=0.50 662 U75=0.75 663 PINC=0.01 664C 665 IF(ICASPL.EQ.'NORM' .OR. ICASPL.EQ.'LOGN')THEN 666 CALL NORPPF(U25,QU25) 667 CALL NORPPF(U50,QU50) 668 CALL NORPPF(U75,QU75) 669 PVAL=0.01 670 DO401I=1,99 671 CALL NORPPF(PVAL,PPF) 672 AVAL=(PPF - QU50)/(2.0*(QU75-QU25)) 673 IF(AVAL.LE.-1.0)AVAL=-1.0 674 IF(AVAL.GT.1.0)AVAL=1.0 675 N2=N2+1 676 Y2(N2)=AVAL 677 X2(N2)=100.0*PVAL 678 D2(N2)=2.0 679 PVAL=PVAL + PINC 680 401 CONTINUE 681 ELSEIF(ICASPL.EQ.'UNIF')THEN 682 CALL UNIPPF(U25,QU25) 683 CALL UNIPPF(U50,QU50) 684 CALL UNIPPF(U75,QU75) 685 PVAL=0.01 686 DO403I=1,99 687 CALL UNIPPF(PVAL,PPF) 688 AVAL=(PPF - QU50)/(2.0*(QU75-QU25)) 689 IF(AVAL.LE.-1.0)AVAL=-1.0 690 IF(AVAL.GT.1.0)AVAL=1.0 691 N2=N2+1 692 Y2(N2)=AVAL 693 X2(N2)=100.0*PVAL 694 D2(N2)=2.0 695 PVAL=PVAL + PINC 696 403 CONTINUE 697 ELSEIF(ICASPL.EQ.'GUMB' .OR. ICASPL.EQ.'WEIB')THEN 698 MINMX2=MINMAX 699 IF(ICASPL.EQ.'WEIB')MINMX2=1 700 CALL EV1PPF(U25,MINMX2,QU25) 701 CALL EV1PPF(U50,MINMX2,QU50) 702 CALL EV1PPF(U75,MINMX2,QU75) 703 PVAL=0.01 704 DO405I=1,99 705 CALL EV1PPF(PVAL,MINMX2,PPF) 706 AVAL=(PPF - QU50)/(2.0*(QU75-QU25)) 707 IF(AVAL.LE.-1.0)AVAL=-1.0 708 IF(AVAL.GT.1.0)AVAL=1.0 709 N2=N2+1 710 Y2(N2)=AVAL 711 X2(N2)=100.0*PVAL 712 D2(N2)=2.0 713 PVAL=PVAL + PINC 714 405 CONTINUE 715 ELSEIF(ICASPL.EQ.'LOGI')THEN 716 CALL LOGPPF(U25,QU25) 717 CALL LOGPPF(U50,QU50) 718 CALL LOGPPF(U75,QU75) 719 PVAL=0.01 720 DO411I=1,99 721 CALL LOGPPF(PVAL,PPF) 722 AVAL=(PPF - QU50)/(2.0*(QU75-QU25)) 723 IF(AVAL.LE.-1.0)AVAL=-1.0 724 IF(AVAL.GT.1.0)AVAL=1.0 725 N2=N2+1 726 Y2(N2)=AVAL 727 X2(N2)=100.0*PVAL 728 D2(N2)=2.0 729 PVAL=PVAL + PINC 730 411 CONTINUE 731 ELSEIF(ICASPL.EQ.'DEX ')THEN 732 CALL DEXPPF(U25,QU25) 733 CALL DEXPPF(U50,QU50) 734 CALL DEXPPF(U75,QU75) 735 PVAL=0.01 736 DO413I=1,99 737 CALL DEXPPF(PVAL,PPF) 738 AVAL=(PPF - QU50)/(2.0*(QU75-QU25)) 739 IF(AVAL.LE.-1.0)AVAL=-1.0 740 IF(AVAL.GT.1.0)AVAL=1.0 741 N2=N2+1 742 Y2(N2)=AVAL 743 X2(N2)=100.0*PVAL 744 D2(N2)=2.0 745 PVAL=PVAL + PINC 746 413 CONTINUE 747 ELSEIF(ICASPL.EQ.'CAUC')THEN 748 CALL CAUPPF(U25,QU25) 749 CALL CAUPPF(U50,QU50) 750 CALL CAUPPF(U75,QU75) 751 PVAL=0.01 752 DO415I=1,99 753 CALL CAUPPF(PVAL,PPF) 754 AVAL=(PPF - QU50)/(2.0*(QU75-QU25)) 755 IF(AVAL.LE.-1.0)AVAL=-1.0 756 IF(AVAL.GT.1.0)AVAL=1.0 757 N2=N2+1 758 Y2(N2)=AVAL 759 X2(N2)=100.0*PVAL 760 D2(N2)=2.0 761 PVAL=PVAL + PINC 762 415 CONTINUE 763 ELSEIF(ICASPL.EQ.'SEMC')THEN 764 R=1.0 765 CALL SEMPPF(U25,R,QU25) 766 CALL SEMPPF(U50,R,QU50) 767 CALL SEMPPF(U75,R,QU75) 768 PVAL=0.01 769 DO417I=1,99 770 CALL SEMPPF(PVAL,R,PPF) 771 AVAL=(PPF - QU50)/(2.0*(QU75-QU25)) 772 IF(AVAL.LE.-1.0)AVAL=-1.0 773 IF(AVAL.GT.1.0)AVAL=1.0 774 N2=N2+1 775 Y2(N2)=AVAL 776 X2(N2)=100.0*PVAL 777 D2(N2)=2.0 778 PVAL=PVAL + PINC 779 417 CONTINUE 780 ELSEIF(ICASPL.EQ.'COSI')THEN 781 CALL COSPPF(U25,QU25) 782 CALL COSPPF(U50,QU50) 783 CALL COSPPF(U75,QU75) 784 PVAL=0.01 785 DO419I=1,99 786 CALL COSPPF(PVAL,PPF) 787 AVAL=(PPF - QU50)/(2.0*(QU75-QU25)) 788 IF(AVAL.LE.-1.0)AVAL=-1.0 789 IF(AVAL.GT.1.0)AVAL=1.0 790 N2=N2+1 791 Y2(N2)=AVAL 792 X2(N2)=100.0*PVAL 793 D2(N2)=2.0 794 PVAL=PVAL + PINC 795 419 CONTINUE 796 ELSEIF(ICASPL.EQ.'ANGL')THEN 797 CALL ANGPPF(U25,QU25) 798 CALL ANGPPF(U50,QU50) 799 CALL ANGPPF(U75,QU75) 800 PVAL=0.01 801 DO421I=1,99 802 CALL ANGPPF(PVAL,PPF) 803 AVAL=(PPF - QU50)/(2.0*(QU75-QU25)) 804 IF(AVAL.LE.-1.0)AVAL=-1.0 805 IF(AVAL.GT.1.0)AVAL=1.0 806 N2=N2+1 807 Y2(N2)=AVAL 808 X2(N2)=100.0*PVAL 809 D2(N2)=2.0 810 PVAL=PVAL + PINC 811 421 CONTINUE 812 ELSEIF(ICASPL.EQ.'HSE ')THEN 813 CALL HSEPPF(U25,QU25) 814 CALL HSEPPF(U50,QU50) 815 CALL HSEPPF(U75,QU75) 816 PVAL=0.01 817 DO423I=1,99 818 CALL HSEPPF(PVAL,PPF) 819 AVAL=(PPF - QU50)/(2.0*(QU75-QU25)) 820 IF(AVAL.LE.-1.0)AVAL=-1.0 821 IF(AVAL.GT.1.0)AVAL=1.0 822 N2=N2+1 823 Y2(N2)=AVAL 824 X2(N2)=100.0*PVAL 825 D2(N2)=2.0 826 PVAL=PVAL + PINC 827 423 CONTINUE 828 ELSEIF(ICASPL.EQ.'HANO')THEN 829 CALL HFNPPF(U25,QU25) 830 CALL HFNPPF(U50,QU50) 831 CALL HFNPPF(U75,QU75) 832 PVAL=0.01 833 DO425I=1,99 834 CALL HFNPPF(PVAL,PPF) 835 AVAL=(PPF - QU50)/(2.0*(QU75-QU25)) 836 IF(AVAL.LE.-1.0)AVAL=-1.0 837 IF(AVAL.GT.1.0)AVAL=1.0 838 N2=N2+1 839 Y2(N2)=AVAL 840 X2(N2)=100.0*PVAL 841 D2(N2)=2.0 842 PVAL=PVAL + PINC 843 425 CONTINUE 844 ELSEIF(ICASPL.EQ.'ARCS')THEN 845 print *,'at arcsine case' 846 CALL ARSPPF(U25,QU25) 847 CALL ARSPPF(U50,QU50) 848 CALL ARSPPF(U75,QU75) 849 PVAL=0.01 850 DO427I=1,99 851 CALL ARSPPF(PVAL,PPF) 852 AVAL=(PPF - QU50)/(2.0*(QU75-QU25)) 853 IF(AVAL.LE.-1.0)AVAL=-1.0 854 IF(AVAL.GT.1.0)AVAL=1.0 855 N2=N2+1 856 Y2(N2)=AVAL 857 X2(N2)=100.0*PVAL 858 D2(N2)=2.0 859 PVAL=PVAL + PINC 860 427 CONTINUE 861 ELSEIF(ICASPL.EQ.'EXPO')THEN 862 CALL EXPPPF(U25,QU25) 863 CALL EXPPPF(U50,QU50) 864 CALL EXPPPF(U75,QU75) 865 PVAL=0.01 866 DO429I=1,99 867 CALL EXPPPF(PVAL,PPF) 868 AVAL=(PPF - QU50)/(2.0*(QU75-QU25)) 869 IF(AVAL.GT.1.0)AVAL=1.0 870 IF(AVAL.LE.-1.0)AVAL=-1.0 871 N2=N2+1 872 Y2(N2)=AVAL 873 X2(N2)=100.0*PVAL 874 D2(N2)=2.0 875 PVAL=PVAL + PINC 876 429 CONTINUE 877 ELSEIF(ICASPL.EQ.'HACA')THEN 878 CALL HFCPPF(U25,QU25) 879 CALL HFCPPF(U50,QU50) 880 CALL HFCPPF(U75,QU75) 881 PVAL=0.01 882 DO431I=1,99 883 CALL HFCPPF(PVAL,PPF) 884 AVAL=(PPF - QU50)/(2.0*(QU75-QU25)) 885 IF(AVAL.LE.-1.0)AVAL=-1.0 886 IF(AVAL.GT.1.0)AVAL=1.0 887 N2=N2+1 888 Y2(N2)=AVAL 889 X2(N2)=100.0*PVAL 890 D2(N2)=2.0 891 PVAL=PVAL + PINC 892 431 CONTINUE 893 ELSEIF(ICASPL.EQ.'SLAS')THEN 894 CALL SLAPPF(U25,QU25) 895 CALL SLAPPF(U50,QU50) 896 CALL SLAPPF(U75,QU75) 897 PVAL=0.01 898 DO433I=1,99 899 CALL SLAPPF(PVAL,PPF) 900 AVAL=(PPF - QU50)/(2.0*(QU75-QU25)) 901 IF(AVAL.LE.-1.0)AVAL=-1.0 902 IF(AVAL.GT.1.0)AVAL=1.0 903 N2=N2+1 904 Y2(N2)=AVAL 905 X2(N2)=100.0*PVAL 906 D2(N2)=2.0 907 PVAL=PVAL + PINC 908 433 CONTINUE 909 ELSEIF(ICASPL.EQ.'RAYL')THEN 910 CALL RAYPPF(U25,QU25) 911 CALL RAYPPF(U50,QU50) 912 CALL RAYPPF(U75,QU75) 913 PVAL=0.01 914 DO435I=1,99 915 CALL RAYPPF(PVAL,PPF) 916 AVAL=(PPF - QU50)/(2.0*(QU75-QU25)) 917 IF(AVAL.LE.-1.0)AVAL=-1.0 918 IF(AVAL.GT.1.0)AVAL=1.0 919 N2=N2+1 920 Y2(N2)=AVAL 921 X2(N2)=100.0*PVAL 922 D2(N2)=2.0 923 PVAL=PVAL + PINC 924 435 CONTINUE 925 ELSEIF(ICASPL.EQ.'MAXW')THEN 926 CALL MAXPPF(U25,QU25) 927 CALL MAXPPF(U50,QU50) 928 CALL MAXPPF(U75,QU75) 929 PVAL=0.01 930 DO437I=1,99 931 CALL MAXPPF(PVAL,PPF) 932 AVAL=(PPF - QU50)/(2.0*(QU75-QU25)) 933 IF(AVAL.LE.-1.0)AVAL=-1.0 934 IF(AVAL.GT.1.0)AVAL=1.0 935 N2=N2+1 936 Y2(N2)=AVAL 937 X2(N2)=100.0*PVAL 938 D2(N2)=2.0 939 PVAL=PVAL + PINC 940 437 CONTINUE 941 ENDIF 942C 943 NPLOTV=2 944 GOTO9000 945C 946C ****************** 947C ** STEP 90-- ** 948C ** EXIT ** 949C ****************** 950C 951 9000 CONTINUE 952 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TIQ2')THEN 953 WRITE(ICOUT,999) 954 CALL DPWRST('XXX','BUG ') 955 WRITE(ICOUT,9011) 956 9011 FORMAT('***** AT THE END OF DPTIQ2--') 957 CALL DPWRST('XXX','BUG ') 958 WRITE(ICOUT,9012)ICASPL,IERROR,N2 959 9012 FORMAT('ICASPL,IERROR,N2 = ',2(A4,2X),I8) 960 CALL DPWRST('XXX','BUG ') 961 DO9015I=1,N2 962 WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I) 963 9016 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2G15.7,F9.2) 964 CALL DPWRST('XXX','BUG ') 965 9015 CONTINUE 966 ENDIF 967C 968 RETURN 969 END 970 SUBROUTINE DPTISC(ICOM,IHARG,NUMARG, 971 1IX1TSC,IX2TSC,IY1TSC,IY2TSC, 972 1IFOUND,IERROR) 973C 974C PURPOSE--DEFINE THE 4 TIC SCALES CONTAINED IN THE 975C 4 VARIABLES IX1TSC,IX2TSC,IY1TSC,IY2TSC . 976C SUCH TIC SCALE SWITCHES DEFINE THE SCALES 977C (LINEAR OR WEIBULL OR NORMAL) 978C FOR THE TICS ON THE 4 FRAME LINES OF A PLOT. 979C FOCUS OF SUBROUTINE DPTISC--LOG 980C DPTIS2--WEIBULL 981C DPTIS3--NORMAL 982C 983C INPUT ARGUMENTS--ICOM 984C --IHARG (A HOLLERITH VECTOR) 985C --NUMARG 986C OUTPUT ARGUMENTS-- 987C --IX1TSC = LOWER HORIZONTAL TIC SCALE 988C --IX2TSC = UPPER HORIZONTAL TIC SCALE 989C --IY1TSC = LEFT VERTICAL TIC SCALE 990C --IY2TSC = RIGHT VERTICAL TIC SCALE 991C --IFOUND ('YES' OR 'NO' ) 992C --IERROR ('YES' OR 'NO' ) 993C WRITTEN BY--JAMES J. FILLIBEN 994C STATISTICAL ENGINEERING DIVISION 995C INFORMATION TECHNOLOGY LABORATORY 996C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 997C GAITHERSBURG, MD 20899-8980 998C PHONE--301-975-2855 999C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 1000C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 1001C LANGUAGE--ANSI FORTRAN (1977) 1002C VERSION NUMBER--82/7 1003C ORIGINAL VERSION--SEPTEMBER 1980. 1004C UPDATED --MARCH 1981. 1005C UPDATED --MAY 1982. 1006C 1007C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 1008C 1009 CHARACTER*4 ICOM 1010 CHARACTER*4 IHARG 1011C 1012 CHARACTER*4 IX1TSC 1013 CHARACTER*4 IX2TSC 1014 CHARACTER*4 IY1TSC 1015 CHARACTER*4 IY2TSC 1016C 1017 CHARACTER*4 IFOUND 1018 CHARACTER*4 IERROR 1019C 1020C--------------------------------------------------------------------- 1021C 1022 DIMENSION IHARG(*) 1023C 1024C-----COMMON---------------------------------------------------------- 1025C 1026 INCLUDE 'DPCOP2.INC' 1027C 1028C-----START POINT----------------------------------------------------- 1029C 1030 IFOUND='NO' 1031 IERROR='NO' 1032C 1033 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO1900 1034 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CORN')GOTO1900 1035C 1036C ***************************************************** 1037C ** TREAT THE CASE WHEN ** 1038C ** BOTH HORIZONTAL LOG SCALES ARE TO BE LOG ** 1039C ***************************************************** 1040C 1041 IF(ICOM.EQ.'XLOG')GOTO1100 1042 GOTO1199 1043C 1044 1100 CONTINUE 1045 IF(NUMARG.LE.0)GOTO1110 1046 IF(IHARG(NUMARG).EQ.'ON')GOTO1110 1047 IF(IHARG(NUMARG).EQ.'OFF')GOTO1120 1048 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 1049 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 1050 IERROR='YES' 1051 GOTO1900 1052C 1053 1110 CONTINUE 1054 IFOUND='YES' 1055 IX1TSC='LOG' 1056 IX2TSC='LOG' 1057C 1058 IF(IFEEDB.EQ.'OFF')GOTO1119 1059 WRITE(ICOUT,999) 1060 999 FORMAT(1X) 1061 CALL DPWRST('XXX','BUG ') 1062 WRITE(ICOUT,1115) 1063 1115 FORMAT('THE XLOG SWITCH (FOR BOTH HORIZONTAL LOG SCALES ) ', 1064 1'HAS JUST BEEN TURNED ON') 1065 CALL DPWRST('XXX','BUG ') 1066 1119 CONTINUE 1067 GOTO1900 1068C 1069 1120 CONTINUE 1070 IFOUND='YES' 1071 IX1TSC='LINE' 1072 IX2TSC='LINE' 1073C 1074 IF(IFEEDB.EQ.'OFF')GOTO1129 1075 WRITE(ICOUT,999) 1076 CALL DPWRST('XXX','BUG ') 1077 WRITE(ICOUT,1125) 1078 1125 FORMAT('THE XLOG SWITCH (FOR BOTH HORIZONTAL LOG SCALES ) ', 1079 1'HAS JUST BEEN TURNED OFF') 1080 CALL DPWRST('XXX','BUG ') 1081 1129 CONTINUE 1082 GOTO1900 1083C 1084 1199 CONTINUE 1085C 1086C ************************************************************** 1087C ** TREAT THE CASE WHEN ** 1088C ** ONLY THE BOTTOM HORIZONTAL FRAME LINE IS TO BE LOG ** 1089C ************************************************************** 1090C 1091 IF(ICOM.EQ.'X1LO')GOTO1200 1092 GOTO1299 1093C 1094 1200 CONTINUE 1095 IF(NUMARG.LE.0)GOTO1210 1096 IF(IHARG(NUMARG).EQ.'ON')GOTO1210 1097 IF(IHARG(NUMARG).EQ.'OFF')GOTO1220 1098 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1210 1099 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1210 1100 IERROR='YES' 1101 GOTO1900 1102C 1103 1210 CONTINUE 1104 IFOUND='YES' 1105 IX1TSC='LOG' 1106C 1107 IF(IFEEDB.EQ.'OFF')GOTO1219 1108 WRITE(ICOUT,999) 1109 CALL DPWRST('XXX','BUG ') 1110 WRITE(ICOUT,1215) 1111 1215 FORMAT('THE X1LOG SWITCH (FOR THE BOTTOM HORIZONTAL ', 1112 1'FRAME LOG SCALE ONLY) HAS JUST BEEN TURNED ON') 1113 CALL DPWRST('XXX','BUG ') 1114 1219 CONTINUE 1115 GOTO1900 1116C 1117 1220 CONTINUE 1118 IFOUND='YES' 1119 IX1TSC='LINE' 1120C 1121 IF(IFEEDB.EQ.'OFF')GOTO1229 1122 WRITE(ICOUT,999) 1123 CALL DPWRST('XXX','BUG ') 1124 WRITE(ICOUT,1225) 1125 1225 FORMAT('THE X1LOG SWITCH (FOR THE BOTTOM HORIZONTAL ', 1126 1'FRAME LOG SCALE ONLY) HAS JUST BEEN TURNED OFF') 1127 CALL DPWRST('XXX','BUG ') 1128 1229 CONTINUE 1129 GOTO1900 1130C 1131 1299 CONTINUE 1132C 1133C ************************************************************** 1134C ** TREAT THE CASE WHEN ** 1135C ** ONLY THE TOP HORIZONTAL FRAME LINE IS TO BE LOG ** 1136C ************************************************************** 1137C 1138 IF(ICOM.EQ.'X2LO')GOTO1300 1139 GOTO1399 1140C 1141 1300 CONTINUE 1142 IF(NUMARG.LE.0)GOTO1310 1143 IF(IHARG(NUMARG).EQ.'ON')GOTO1310 1144 IF(IHARG(NUMARG).EQ.'OFF')GOTO1320 1145 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1310 1146 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1310 1147 IERROR='YES' 1148 GOTO1900 1149C 1150 1310 CONTINUE 1151 IFOUND='YES' 1152 IX2TSC='LOG' 1153C 1154 IF(IFEEDB.EQ.'OFF')GOTO1319 1155 WRITE(ICOUT,999) 1156 CALL DPWRST('XXX','BUG ') 1157 WRITE(ICOUT,1315) 1158 1315 FORMAT('THE X2LOG SWITCH (FOR THE TOP HORIZONTAL ', 1159 1'FRAME LOG SCALE ONLY) HAS JUST BEEN TURNED ON') 1160 CALL DPWRST('XXX','BUG ') 1161 1319 CONTINUE 1162 GOTO1900 1163C 1164 1320 CONTINUE 1165 IFOUND='YES' 1166 IX2TSC='LINE' 1167C 1168 IF(IFEEDB.EQ.'OFF')GOTO1329 1169 WRITE(ICOUT,999) 1170 CALL DPWRST('XXX','BUG ') 1171 WRITE(ICOUT,1325) 1172 1325 FORMAT('THE X2LOG SWITCH (FOR THE TOP HORIZONTAL ', 1173 1'FRAME LOG SCALE ONLY) HAS JUST BEEN TURNED OFF') 1174 CALL DPWRST('XXX','BUG ') 1175 1329 CONTINUE 1176 GOTO1900 1177C 1178 1399 CONTINUE 1179C 1180C *************************************************** 1181C ** TREAT THE CASE WHEN ** 1182C ** BOTH VERTICAL LOG SCALES ARE TO BE LOG ** 1183C *************************************************** 1184C 1185 IF(ICOM.EQ.'YLOG')GOTO1400 1186 GOTO1499 1187C 1188 1400 CONTINUE 1189 IF(NUMARG.LE.0)GOTO1410 1190 IF(IHARG(NUMARG).EQ.'ON')GOTO1410 1191 IF(IHARG(NUMARG).EQ.'OFF')GOTO1420 1192 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1410 1193 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1410 1194 IERROR='YES' 1195 GOTO1900 1196C 1197 1410 CONTINUE 1198 IFOUND='YES' 1199 IY1TSC='LOG' 1200 IY2TSC='LOG' 1201C 1202 IF(IFEEDB.EQ.'OFF')GOTO1419 1203 WRITE(ICOUT,999) 1204 CALL DPWRST('XXX','BUG ') 1205 WRITE(ICOUT,1415) 1206 1415 FORMAT('THE YLOG SWITCH (FOR BOTH VERTICAL LOG SCALES ) ', 1207 1'HAS JUST BEEN TURNED ON') 1208 CALL DPWRST('XXX','BUG ') 1209 1419 CONTINUE 1210 GOTO1900 1211C 1212 1420 CONTINUE 1213 IFOUND='YES' 1214 IY1TSC='LINE' 1215 IY2TSC='LINE' 1216C 1217 IF(IFEEDB.EQ.'OFF')GOTO1429 1218 WRITE(ICOUT,999) 1219 CALL DPWRST('XXX','BUG ') 1220 WRITE(ICOUT,1425) 1221 1425 FORMAT('THE YLOG SWITCH (FOR BOTH VERTICAL LOG SCALES ) ', 1222 1'HAS JUST BEEN TURNED OFF') 1223 CALL DPWRST('XXX','BUG ') 1224 1429 CONTINUE 1225 GOTO1900 1226C 1227 1499 CONTINUE 1228C 1229C ************************************************************** 1230C ** TREAT THE CASE WHEN ** 1231C ** ONLY THE LEFT VERTICAL FRAME LINE IS TO BE LOG ** 1232C ************************************************************** 1233C 1234 IF(ICOM.EQ.'Y1LO')GOTO1500 1235 GOTO1599 1236C 1237 1500 CONTINUE 1238 IF(NUMARG.LE.0)GOTO1510 1239 IF(IHARG(NUMARG).EQ.'ON')GOTO1510 1240 IF(IHARG(NUMARG).EQ.'OFF')GOTO1520 1241 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1510 1242 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1510 1243 IERROR='YES' 1244 GOTO1900 1245C 1246 1510 CONTINUE 1247 IFOUND='YES' 1248 IY1TSC='LOG' 1249C 1250 IF(IFEEDB.EQ.'OFF')GOTO1519 1251 WRITE(ICOUT,999) 1252 CALL DPWRST('XXX','BUG ') 1253 WRITE(ICOUT,1515) 1254 1515 FORMAT('THE Y1LOG SWITCH (FOR THE LEFT VERTICAL ', 1255 1'FRAME LOG SCALE ONLY) HAS JUST BEEN TURNED ON') 1256 CALL DPWRST('XXX','BUG ') 1257 1519 CONTINUE 1258 GOTO1900 1259C 1260 1520 CONTINUE 1261 IFOUND='YES' 1262 IY1TSC='LINE' 1263C 1264 IF(IFEEDB.EQ.'OFF')GOTO1529 1265 WRITE(ICOUT,999) 1266 CALL DPWRST('XXX','BUG ') 1267 WRITE(ICOUT,1525) 1268 1525 FORMAT('THE Y1LOG SWITCH (FOR THE LEFT VERTICAL ', 1269 1'FRAME LOG SCALE ONLY) HAS JUST BEEN TURNED OFF') 1270 CALL DPWRST('XXX','BUG ') 1271 1529 CONTINUE 1272 GOTO1900 1273C 1274 1599 CONTINUE 1275C 1276C ************************************************************** 1277C ** TREAT THE CASE WHEN ** 1278C ** ONLY THE RIGHT VERTCIAL FRAME LINE IS TO BE LOG ** 1279C ************************************************************** 1280C 1281 IF(ICOM.EQ.'Y2LO')GOTO1600 1282 GOTO1699 1283C 1284 1600 CONTINUE 1285 IF(NUMARG.LE.0)GOTO1610 1286 IF(IHARG(NUMARG).EQ.'ON')GOTO1610 1287 IF(IHARG(NUMARG).EQ.'OFF')GOTO1620 1288 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1610 1289 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1610 1290 IERROR='YES' 1291 GOTO1900 1292C 1293 1610 CONTINUE 1294 IFOUND='YES' 1295 IY2TSC='LOG' 1296C 1297 IF(IFEEDB.EQ.'OFF')GOTO1619 1298 WRITE(ICOUT,999) 1299 CALL DPWRST('XXX','BUG ') 1300 WRITE(ICOUT,1615) 1301 1615 FORMAT('THE Y2LOG SWITCH (FOR THE RIGHT VERTICAL ', 1302 1'FRAME LOG SCALE ONLY) HAS JUST BEEN TURNED ON') 1303 CALL DPWRST('XXX','BUG ') 1304 1619 CONTINUE 1305 GOTO1900 1306C 1307 1620 CONTINUE 1308 IFOUND='YES' 1309 IY2TSC='LINE' 1310C 1311 IF(IFEEDB.EQ.'OFF')GOTO1629 1312 WRITE(ICOUT,999) 1313 CALL DPWRST('XXX','BUG ') 1314 WRITE(ICOUT,1625) 1315 1625 FORMAT('THE Y2LOG SWITCH (FOR THE RIGHT VERTICAL ', 1316 1'FRAME LOG SCALE ONLY) HAS JUST BEEN TURNED OFF') 1317 CALL DPWRST('XXX','BUG ') 1318 1629 CONTINUE 1319 GOTO1900 1320C 1321 1699 CONTINUE 1322C 1323C ************************************************** 1324C ** TREAT THE CASE WHEN ** 1325C ** THE ENTIRE 4-SIDED FRAME IS TO BE LOG ** 1326C ************************************************** 1327C 1328 IF(ICOM.EQ.'XYLO')GOTO1700 1329 IF(ICOM.EQ.'YXLO')GOTO1700 1330 IF(ICOM.EQ.'LOG ')GOTO1700 1331 IF(ICOM.EQ.'LOGL')GOTO1700 1332 GOTO1799 1333C 1334 1700 CONTINUE 1335 IF(NUMARG.LE.0)GOTO1710 1336 IF(IHARG(NUMARG).EQ.'ON')GOTO1710 1337 IF(IHARG(NUMARG).EQ.'OFF')GOTO1720 1338 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1710 1339 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1710 1340 IERROR='YES' 1341 GOTO1900 1342C 1343 1710 CONTINUE 1344 IFOUND='YES' 1345 IX1TSC='LOG' 1346 IX2TSC='LOG' 1347 IY1TSC='LOG' 1348 IY2TSC='LOG' 1349C 1350 IF(IFEEDB.EQ.'OFF')GOTO1719 1351 WRITE(ICOUT,999) 1352 CALL DPWRST('XXX','BUG ') 1353 WRITE(ICOUT,1715) 1354 1715 FORMAT('THE LOG SWITCH (FOR THE ENTIRE 4-SIDED FRAME) ', 1355 1'HAS JUST BEEN TURNED ON') 1356 CALL DPWRST('XXX','BUG ') 1357 1719 CONTINUE 1358 GOTO1900 1359C 1360 1720 CONTINUE 1361 IFOUND='YES' 1362 IX1TSC='LINE' 1363 IX2TSC='LINE' 1364 IY1TSC='LINE' 1365 IY2TSC='LINE' 1366C 1367 IF(IFEEDB.EQ.'OFF')GOTO1729 1368 WRITE(ICOUT,999) 1369 CALL DPWRST('XXX','BUG ') 1370 WRITE(ICOUT,1725) 1371 1725 FORMAT('THE LOG SWITCH (FOR THE ENTIRE 4-SIDED FRAME) ', 1372 1'HAS JUST BEEN TURNED OFF') 1373 CALL DPWRST('XXX','BUG ') 1374 1729 CONTINUE 1375 GOTO1900 1376C 1377 1799 CONTINUE 1378C 1379 1900 CONTINUE 1380 RETURN 1381 END 1382 SUBROUTINE DPTIS2(ICOM,IHARG,NUMARG, 1383 1IX1TSC,IX2TSC,IY1TSC,IY2TSC, 1384 1IFOUND,IERROR) 1385C 1386C PURPOSE--DEFINE THE 4 TIC SCALES CONTAINED IN THE 1387C 4 VARIABLES IX1TSC,IX2TSC,IY1TSC,IY2TSC . 1388C SUCH TIC SCALE SWITCHES DEFINE THE SCALES 1389C (LINEAR OR WEIBULL OR NORMAL) 1390C FOR THE TICS ON THE 4 FRAME LINES OF A PLOT. 1391C FOCUS OF SUBROUTINE DPTISC--LOG 1392C DPTIS2--WEIBULL 1393C DPTIS3--NORMAL 1394C 1395C INPUT ARGUMENTS--ICOM 1396C --IHARG (A HOLLERITH VECTOR) 1397C --NUMARG 1398C OUTPUT ARGUMENTS-- 1399C --IX1TSC = LOWER HORIZONTAL TIC SCALE 1400C --IX2TSC = UPPER HORIZONTAL TIC SCALE 1401C --IY1TSC = LEFT VERTICAL TIC SCALE 1402C --IY2TSC = RIGHT VERTICAL TIC SCALE 1403C --IFOUND ('YES' OR 'NO' ) 1404C --IERROR ('YES' OR 'NO' ) 1405C WRITTEN BY--JAMES J. FILLIBEN 1406C STATISTICAL ENGINEERING DIVISION 1407C INFORMATION TECHNOLOGY LABORATORY 1408C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 1409C GAITHERSBURG, MD 20899-8980 1410C PHONE--301-975-2855 1411C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 1412C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 1413C LANGUAGE--ANSI FORTRAN (1977) 1414C VERSION NUMBER--82/7 1415C ORIGINAL VERSION--SEPTEMBER 1980. 1416C UPDATED --MARCH 1981. 1417C UPDATED --MAY 1982. 1418C 1419C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 1420C 1421 CHARACTER*4 ICOM 1422 CHARACTER*4 IHARG 1423C 1424 CHARACTER*4 IX1TSC 1425 CHARACTER*4 IX2TSC 1426 CHARACTER*4 IY1TSC 1427 CHARACTER*4 IY2TSC 1428C 1429 CHARACTER*4 IFOUND 1430 CHARACTER*4 IERROR 1431C 1432C--------------------------------------------------------------------- 1433C 1434 DIMENSION IHARG(*) 1435C 1436C-----COMMON---------------------------------------------------------- 1437C 1438 INCLUDE 'DPCOP2.INC' 1439C 1440C-----START POINT----------------------------------------------------- 1441C 1442 IFOUND='NO' 1443 IERROR='NO' 1444C 1445 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO1900 1446 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CORN')GOTO1900 1447C 1448C ******************************************************** 1449C ** TREAT THE CASE WHEN ** 1450C ** BOTH HORIZONTAL FRAME LINES ARE TO BE WEIBULL ** 1451C ******************************************************** 1452C 1453 IF(ICOM.EQ.'XWEI')GOTO1100 1454 GOTO1199 1455C 1456 1100 CONTINUE 1457 IF(NUMARG.LE.0)GOTO1110 1458 IF(IHARG(NUMARG).EQ.'ON')GOTO1110 1459 IF(IHARG(NUMARG).EQ.'OFF')GOTO1120 1460 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 1461 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 1462 IERROR='YES' 1463 GOTO1900 1464C 1465 1110 CONTINUE 1466 IFOUND='YES' 1467 IX1TSC='WEIB' 1468 IX2TSC='WEIB' 1469C 1470 IF(IFEEDB.EQ.'OFF')GOTO1119 1471 WRITE(ICOUT,999) 1472 999 FORMAT(1X) 1473 CALL DPWRST('XXX','BUG ') 1474 WRITE(ICOUT,1115) 1475 1115 FORMAT('THE XWEIB SWITCH (FOR BOTH HORIZ. WEIBULL SCALES)', 1476 1'HAS JUST BEEN TURNED ON') 1477 CALL DPWRST('XXX','BUG ') 1478 1119 CONTINUE 1479 GOTO1900 1480C 1481 1120 CONTINUE 1482 IFOUND='YES' 1483 IX1TSC='LINE' 1484 IX2TSC='LINE' 1485C 1486 IF(IFEEDB.EQ.'OFF')GOTO1129 1487 WRITE(ICOUT,999) 1488 CALL DPWRST('XXX','BUG ') 1489 WRITE(ICOUT,1125) 1490 1125 FORMAT('THE XWEIB SWITCH (FOR BOTH HORIZ. WEIBULL SCALES)', 1491 1'HAS JUST BEEN TURNED OFF') 1492 CALL DPWRST('XXX','BUG ') 1493 1129 CONTINUE 1494 GOTO1900 1495C 1496 1199 CONTINUE 1497C 1498C ******************************************************** 1499C ** TREAT THE CASE WHEN 1500C ** ONLY THE BOTTOM HORIZONTAL FRAME LINE IS TO BE WEIBU 1501C ******************************************************** 1502C 1503 IF(ICOM.EQ.'X1WE')GOTO1200 1504 GOTO1299 1505C 1506 1200 CONTINUE 1507 IF(NUMARG.LE.0)GOTO1210 1508 IF(IHARG(NUMARG).EQ.'ON')GOTO1210 1509 IF(IHARG(NUMARG).EQ.'OFF')GOTO1220 1510 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1210 1511 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1210 1512 IERROR='YES' 1513 GOTO1900 1514C 1515 1210 CONTINUE 1516 IFOUND='YES' 1517 IX1TSC='WEIB' 1518C 1519 IF(IFEEDB.EQ.'OFF')GOTO1219 1520 WRITE(ICOUT,999) 1521 CALL DPWRST('XXX','BUG ') 1522 WRITE(ICOUT,1215) 1523 1215 FORMAT('THE X1WEIB SWITCH (FOR THE BOTTOM HORIZONTAL ', 1524 1'FRAME WEIBULL SCALE ONLY) HAS JUST BEEN TURNED ON') 1525 CALL DPWRST('XXX','BUG ') 1526 1219 CONTINUE 1527 GOTO1900 1528C 1529 1220 CONTINUE 1530 IFOUND='YES' 1531 IX1TSC='LINE' 1532C 1533 IF(IFEEDB.EQ.'OFF')GOTO1229 1534 WRITE(ICOUT,999) 1535 CALL DPWRST('XXX','BUG ') 1536 WRITE(ICOUT,1225) 1537 1225 FORMAT('THE X1WEIB SWITCH (FOR THE BOTTOM HORIZONTAL ', 1538 1'FRAME WEIBULL SCALE ONLY) HAS JUST BEEN TURNED OFF') 1539 CALL DPWRST('XXX','BUG ') 1540 1229 CONTINUE 1541 GOTO1900 1542C 1543 1299 CONTINUE 1544C 1545C ******************************************************** 1546C ** TREAT THE CASE WHEN 1547C ** ONLY THE TOP HORIZONTAL FRAME LINE IS TO BE WEIBU 1548C ******************************************************** 1549C 1550 IF(ICOM.EQ.'X2WE')GOTO1300 1551 GOTO1399 1552C 1553 1300 CONTINUE 1554 IF(NUMARG.LE.0)GOTO1310 1555 IF(IHARG(NUMARG).EQ.'ON')GOTO1310 1556 IF(IHARG(NUMARG).EQ.'OFF')GOTO1320 1557 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1310 1558 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1310 1559 IERROR='YES' 1560 GOTO1900 1561C 1562 1310 CONTINUE 1563 IFOUND='YES' 1564 IX2TSC='WEIB' 1565C 1566 IF(IFEEDB.EQ.'OFF')GOTO1319 1567 WRITE(ICOUT,999) 1568 CALL DPWRST('XXX','BUG ') 1569 WRITE(ICOUT,1315) 1570 1315 FORMAT('THE X2WEIB SWITCH (FOR THE TOP HORIZONTAL ', 1571 1'FRAME WEIBULL SCALE ONLY) HAS JUST BEEN TURNED ON') 1572 CALL DPWRST('XXX','BUG ') 1573 1319 CONTINUE 1574 GOTO1900 1575C 1576 1320 CONTINUE 1577 IFOUND='YES' 1578 IX2TSC='LINE' 1579C 1580 IF(IFEEDB.EQ.'OFF')GOTO1329 1581 WRITE(ICOUT,999) 1582 CALL DPWRST('XXX','BUG ') 1583 WRITE(ICOUT,1325) 1584 1325 FORMAT('THE X2WEIB SWITCH (FOR THE TOP HORIZONTAL ', 1585 1'FRAME WEIBULL SCALE ONLY) HAS JUST BEEN TURNED OFF') 1586 CALL DPWRST('XXX','BUG ') 1587 1329 CONTINUE 1588 GOTO1900 1589C 1590 1399 CONTINUE 1591C 1592C ****************************************************** 1593C ** TREAT THE CASE WHEN ** 1594C ** BOTH VERTICAL FRAME LINES ARE TO BE WEIBULL ** 1595C ****************************************************** 1596C 1597 IF(ICOM.EQ.'YWEI')GOTO1400 1598 GOTO1499 1599C 1600 1400 CONTINUE 1601 IF(NUMARG.LE.0)GOTO1410 1602 IF(IHARG(NUMARG).EQ.'ON')GOTO1410 1603 IF(IHARG(NUMARG).EQ.'OFF')GOTO1420 1604 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1410 1605 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1410 1606 IERROR='YES' 1607 GOTO1900 1608C 1609 1410 CONTINUE 1610 IFOUND='YES' 1611 IY1TSC='WEIB' 1612 IY2TSC='WEIB' 1613C 1614 IF(IFEEDB.EQ.'OFF')GOTO1419 1615 WRITE(ICOUT,999) 1616 CALL DPWRST('XXX','BUG ') 1617 WRITE(ICOUT,1415) 1618 1415 FORMAT('THE YWEIB SWITCH (FOR BOTH VERT. WEIBULL SCALES)', 1619 1'HAS JUST BEEN TURNED ON') 1620 CALL DPWRST('XXX','BUG ') 1621 1419 CONTINUE 1622 GOTO1900 1623C 1624 1420 CONTINUE 1625 IFOUND='YES' 1626 IY1TSC='LINE' 1627 IY2TSC='LINE' 1628C 1629 IF(IFEEDB.EQ.'OFF')GOTO1429 1630 WRITE(ICOUT,999) 1631 CALL DPWRST('XXX','BUG ') 1632 WRITE(ICOUT,1425) 1633 1425 FORMAT('THE YWEIB SWITCH (FOR BOTH VERT. WEIBULL SCALES)', 1634 1'HAS JUST BEEN TURNED OFF') 1635 CALL DPWRST('XXX','BUG ') 1636 1429 CONTINUE 1637 GOTO1900 1638C 1639 1499 CONTINUE 1640C 1641C ******************************************************** 1642C ** TREAT THE CASE WHEN 1643C ** ONLY THE LEFT VERTICAL FRAME LINE IS TO BE WEIBU 1644C ******************************************************** 1645C 1646 IF(ICOM.EQ.'Y1WE')GOTO1500 1647 GOTO1599 1648C 1649 1500 CONTINUE 1650 IF(NUMARG.LE.0)GOTO1510 1651 IF(IHARG(NUMARG).EQ.'ON')GOTO1510 1652 IF(IHARG(NUMARG).EQ.'OFF')GOTO1520 1653 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1510 1654 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1510 1655 IERROR='YES' 1656 GOTO1900 1657C 1658 1510 CONTINUE 1659 IFOUND='YES' 1660 IY1TSC='WEIB' 1661C 1662 IF(IFEEDB.EQ.'OFF')GOTO1519 1663 WRITE(ICOUT,999) 1664 CALL DPWRST('XXX','BUG ') 1665 WRITE(ICOUT,1515) 1666 1515 FORMAT('THE Y1WEIB SWITCH (FOR THE LEFT VERTICAL ', 1667 1'FRAME WEIBULL SCALE ONLY) HAS JUST BEEN TURNED ON') 1668 CALL DPWRST('XXX','BUG ') 1669 1519 CONTINUE 1670 GOTO1900 1671C 1672 1520 CONTINUE 1673 IFOUND='YES' 1674 IY1TSC='LINE' 1675C 1676 IF(IFEEDB.EQ.'OFF')GOTO1529 1677 WRITE(ICOUT,999) 1678 CALL DPWRST('XXX','BUG ') 1679 WRITE(ICOUT,1525) 1680 1525 FORMAT('THE Y1WEIB SWITCH (FOR THE LEFT VERTICAL ', 1681 1'FRAME WEIBULL SCALE ONLY) HAS JUST BEEN TURNED OFF') 1682 CALL DPWRST('XXX','BUG ') 1683 1529 CONTINUE 1684 GOTO1900 1685C 1686 1599 CONTINUE 1687C 1688C ******************************************************** 1689C ** TREAT THE CASE WHEN 1690C ** ONLY THE RIGHT VERTCIAL FRAME LINE IS TO BE WEIBU 1691C ******************************************************** 1692C 1693 IF(ICOM.EQ.'Y2WE')GOTO1600 1694 GOTO1699 1695C 1696 1600 CONTINUE 1697 IF(NUMARG.LE.0)GOTO1610 1698 IF(IHARG(NUMARG).EQ.'ON')GOTO1610 1699 IF(IHARG(NUMARG).EQ.'OFF')GOTO1620 1700 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1610 1701 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1610 1702 IERROR='YES' 1703 GOTO1900 1704C 1705 1610 CONTINUE 1706 IFOUND='YES' 1707 IY2TSC='WEIB' 1708C 1709 IF(IFEEDB.EQ.'OFF')GOTO1619 1710 WRITE(ICOUT,999) 1711 CALL DPWRST('XXX','BUG ') 1712 WRITE(ICOUT,1615) 1713 1615 FORMAT('THE Y2WEIB SWITCH (FOR THE RIGHT VERTICAL ', 1714 1'FRAME WEIBULL SCALE ONLY) HAS JUST BEEN TURNED ON') 1715 CALL DPWRST('XXX','BUG ') 1716 1619 CONTINUE 1717 GOTO1900 1718C 1719 1620 CONTINUE 1720 IFOUND='YES' 1721 IY2TSC='LINE' 1722C 1723 IF(IFEEDB.EQ.'OFF')GOTO1629 1724 WRITE(ICOUT,999) 1725 CALL DPWRST('XXX','BUG ') 1726 WRITE(ICOUT,1625) 1727 1625 FORMAT('THE Y2WEIB SWITCH (FOR THE RIGHT VERTICAL ', 1728 1'FRAME WEIBULL SCALE ONLY) HAS JUST BEEN TURNED OFF') 1729 CALL DPWRST('XXX','BUG ') 1730 1629 CONTINUE 1731 GOTO1900 1732C 1733 1699 CONTINUE 1734C 1735C ************************************************** 1736C ** TREAT THE CASE WHEN ** 1737C ** THE ENTIRE 4-SIDED FRAME IS TO BE WEIBULL ** 1738C ************************************************** 1739C 1740 IF(ICOM.EQ.'XYWE')GOTO1700 1741 IF(ICOM.EQ.'YXWE')GOTO1700 1742 IF(ICOM.EQ.'WEIB')GOTO1700 1743CCCCC IF(ICOM.EQ.'WEIW'GOTO1700 1744 GOTO1799 1745C 1746 1700 CONTINUE 1747 IF(NUMARG.LE.0)GOTO1710 1748 IF(IHARG(NUMARG).EQ.'ON')GOTO1710 1749 IF(IHARG(NUMARG).EQ.'OFF')GOTO1720 1750 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1710 1751 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1710 1752 IERROR='YES' 1753 GOTO1900 1754C 1755 1710 CONTINUE 1756 IFOUND='YES' 1757 IX1TSC='WEIB' 1758 IX2TSC='WEIB' 1759 IY1TSC='WEIB' 1760 IY2TSC='WEIB' 1761C 1762 IF(IFEEDB.EQ.'OFF')GOTO1719 1763 WRITE(ICOUT,999) 1764 CALL DPWRST('XXX','BUG ') 1765 WRITE(ICOUT,1715) 1766 1715 FORMAT('THE WEIBULL SWITCH (FOR THE ENTIRE 4-SIDED FRAME) ', 1767 1'HAS JUST BEEN TURNED ON') 1768 CALL DPWRST('XXX','BUG ') 1769 1719 CONTINUE 1770 GOTO1900 1771C 1772 1720 CONTINUE 1773 IFOUND='YES' 1774 IX1TSC='LINE' 1775 IX2TSC='LINE' 1776 IY1TSC='LINE' 1777 IY2TSC='LINE' 1778C 1779 IF(IFEEDB.EQ.'OFF')GOTO1729 1780 WRITE(ICOUT,999) 1781 CALL DPWRST('XXX','BUG ') 1782 WRITE(ICOUT,1725) 1783 1725 FORMAT('THE WEIBULL SWITCH (FOR THE ENTIRE 4-SIDED FRAME) ', 1784 1'HAS JUST BEEN TURNED OFF') 1785 CALL DPWRST('XXX','BUG ') 1786 1729 CONTINUE 1787 GOTO1900 1788C 1789 1799 CONTINUE 1790C 1791 1900 CONTINUE 1792 RETURN 1793 END 1794 SUBROUTINE DPTIS3(ICOM,IHARG,NUMARG, 1795 1IX1TSC,IX2TSC,IY1TSC,IY2TSC, 1796 1IFOUND,IERROR) 1797C 1798C PURPOSE--DEFINE THE 4 TIC SCALES CONTAINED IN THE 1799C 4 VARIABLES IX1TSC,IX2TSC,IY1TSC,IY2TSC . 1800C SUCH TIC SCALE SWITCHES DEFINE THE SCALES 1801C (LINEAR OR WEIBULL OR NORMAL) 1802C FOR THE TICS ON THE 4 FRAME LINES OF A PLOT. 1803C FOCUS OF SUBROUTINE DPTISC--LOG 1804C DPTIS2--WEIBULL 1805C DPTIS3--NORMAL 1806C 1807C INPUT ARGUMENTS--ICOM 1808C --IHARG (A HOLLERITH VECTOR) 1809C --NUMARG 1810C OUTPUT ARGUMENTS-- 1811C --IX1TSC = LOWER HORIZONTAL TIC SCALE 1812C --IX2TSC = UPPER HORIZONTAL TIC SCALE 1813C --IY1TSC = LEFT VERTICAL TIC SCALE 1814C --IY2TSC = RIGHT VERTICAL TIC SCALE 1815C --IFOUND ('YES' OR 'NO' ) 1816C --IERROR ('YES' OR 'NO' ) 1817C WRITTEN BY--JAMES J. FILLIBEN 1818C STATISTICAL ENGINEERING DIVISION 1819C INFORMATION TECHNOLOGY LABORATORY 1820C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 1821C GAITHERSBURG, MD 20899-8980 1822C PHONE--301-975-2855 1823C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 1824C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 1825C LANGUAGE--ANSI FORTRAN (1977) 1826C VERSION NUMBER--82/7 1827C ORIGINAL VERSION--SEPTEMBER 1980. 1828C UPDATED --MARCH 1981. 1829C UPDATED --MAY 1982. 1830C 1831C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 1832C 1833 CHARACTER*4 ICOM 1834 CHARACTER*4 IHARG 1835C 1836 CHARACTER*4 IX1TSC 1837 CHARACTER*4 IX2TSC 1838 CHARACTER*4 IY1TSC 1839 CHARACTER*4 IY2TSC 1840C 1841 CHARACTER*4 IFOUND 1842 CHARACTER*4 IERROR 1843C 1844C--------------------------------------------------------------------- 1845C 1846 DIMENSION IHARG(*) 1847C 1848C-----COMMON---------------------------------------------------------- 1849C 1850 INCLUDE 'DPCOP2.INC' 1851C 1852C-----START POINT----------------------------------------------------- 1853C 1854 IFOUND='NO' 1855 IERROR='NO' 1856C 1857 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO1900 1858 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CORN')GOTO1900 1859C 1860C ******************************************************** 1861C ** TREAT THE CASE WHEN ** 1862C ** BOTH HORIZONTAL FRAME LINES ARE TO BE NORMAL ** 1863C ******************************************************** 1864C 1865 IF(ICOM.EQ.'XNOR')GOTO1100 1866 GOTO1199 1867C 1868 1100 CONTINUE 1869 IF(NUMARG.LE.0)GOTO1110 1870 IF(IHARG(NUMARG).EQ.'ON')GOTO1110 1871 IF(IHARG(NUMARG).EQ.'OFF')GOTO1120 1872 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 1873 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 1874 IERROR='YES' 1875 GOTO1900 1876C 1877 1110 CONTINUE 1878 IFOUND='YES' 1879 IX1TSC='NORM' 1880 IX2TSC='NORM' 1881C 1882 IF(IFEEDB.EQ.'OFF')GOTO1119 1883 WRITE(ICOUT,999) 1884 999 FORMAT(1X) 1885 CALL DPWRST('XXX','BUG ') 1886 WRITE(ICOUT,1115) 1887 1115 FORMAT('THE XNORM SWITCH (FOR BOTH HORIZ. NORMAL SCALES)', 1888 1'HAS JUST BEEN TURNED ON') 1889 CALL DPWRST('XXX','BUG ') 1890 1119 CONTINUE 1891 GOTO1900 1892C 1893 1120 CONTINUE 1894 IFOUND='YES' 1895 IX1TSC='LINE' 1896 IX2TSC='LINE' 1897C 1898 IF(IFEEDB.EQ.'OFF')GOTO1129 1899 WRITE(ICOUT,999) 1900 CALL DPWRST('XXX','BUG ') 1901 WRITE(ICOUT,1125) 1902 1125 FORMAT('THE XNORM SWITCH (FOR BOTH HORIZ. NORMAL SCALES)', 1903 1'HAS JUST BEEN TURNED OFF') 1904 CALL DPWRST('XXX','BUG ') 1905 1129 CONTINUE 1906 GOTO1900 1907C 1908 1199 CONTINUE 1909C 1910C ******************************************************** 1911C ** TREAT THE CASE WHEN 1912C ** ONLY THE BOTTOM HORIZONTAL FRAME LINE IS TO BE NOR 1913C ******************************************************** 1914C 1915 IF(ICOM.EQ.'X1NO')GOTO1200 1916 GOTO1299 1917C 1918 1200 CONTINUE 1919 IF(NUMARG.LE.0)GOTO1210 1920 IF(IHARG(NUMARG).EQ.'ON')GOTO1210 1921 IF(IHARG(NUMARG).EQ.'OFF')GOTO1220 1922 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1210 1923 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1210 1924 IERROR='YES' 1925 GOTO1900 1926C 1927 1210 CONTINUE 1928 IFOUND='YES' 1929 IX1TSC='NORM' 1930C 1931 IF(IFEEDB.EQ.'OFF')GOTO1219 1932 WRITE(ICOUT,999) 1933 CALL DPWRST('XXX','BUG ') 1934 WRITE(ICOUT,1215) 1935 1215 FORMAT('THE X1NORMAL SWITCH (FOR THE BOTTOM HORIZONTAL ', 1936 1'FRAME NORMAL SCALE ONLY) HAS JUST BEEN TURNED ON') 1937 CALL DPWRST('XXX','BUG ') 1938 1219 CONTINUE 1939 GOTO1900 1940C 1941 1220 CONTINUE 1942 IFOUND='YES' 1943 IX1TSC='LINE' 1944C 1945 IF(IFEEDB.EQ.'OFF')GOTO1229 1946 WRITE(ICOUT,999) 1947 CALL DPWRST('XXX','BUG ') 1948 WRITE(ICOUT,1225) 1949 1225 FORMAT('THE X1NORMAL SWITCH (FOR THE BOTTOM HORIZONTAL ', 1950 1'FRAME NORMAL SCALE ONLY) HAS JUST BEEN TURNED OFF') 1951 CALL DPWRST('XXX','BUG ') 1952 1229 CONTINUE 1953 GOTO1900 1954C 1955 1299 CONTINUE 1956C 1957C ******************************************************** 1958C ** TREAT THE CASE WHEN 1959C ** ONLY THE TOP HORIZONTAL FRAME LINE IS TO BE NORM 1960C ******************************************************** 1961C 1962 IF(ICOM.EQ.'X2NO')GOTO1300 1963 GOTO1399 1964C 1965 1300 CONTINUE 1966 IF(NUMARG.LE.0)GOTO1310 1967 IF(IHARG(NUMARG).EQ.'ON')GOTO1310 1968 IF(IHARG(NUMARG).EQ.'OFF')GOTO1320 1969 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1310 1970 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1310 1971 IERROR='YES' 1972 GOTO1900 1973C 1974 1310 CONTINUE 1975 IFOUND='YES' 1976 IX2TSC='NORM' 1977C 1978 IF(IFEEDB.EQ.'OFF')GOTO1319 1979 WRITE(ICOUT,999) 1980 CALL DPWRST('XXX','BUG ') 1981 WRITE(ICOUT,1315) 1982 1315 FORMAT('THE X2NORMAL SWITCH (FOR THE TOP HORIZONTAL ', 1983 1'FRAME NORMAL SCALE ONLY) HAS JUST BEEN TURNED ON') 1984 CALL DPWRST('XXX','BUG ') 1985 1319 CONTINUE 1986 GOTO1900 1987C 1988 1320 CONTINUE 1989 IFOUND='YES' 1990 IX2TSC='LINE' 1991C 1992 IF(IFEEDB.EQ.'OFF')GOTO1329 1993 WRITE(ICOUT,999) 1994 CALL DPWRST('XXX','BUG ') 1995 WRITE(ICOUT,1325) 1996 1325 FORMAT('THE X2NORMAL SWITCH (FOR THE TOP HORIZONTAL ', 1997 1'FRAME NORMAL SCALE ONLY) HAS JUST BEEN TURNED OFF') 1998 CALL DPWRST('XXX','BUG ') 1999 1329 CONTINUE 2000 GOTO1900 2001C 2002 1399 CONTINUE 2003C 2004C ****************************************************** 2005C ** TREAT THE CASE WHEN ** 2006C ** BOTH VERTICAL FRAME LINES ARE TO BE NORMAL ** 2007C ****************************************************** 2008C 2009 IF(ICOM.EQ.'YNOR')GOTO1400 2010 GOTO1499 2011C 2012 1400 CONTINUE 2013 IF(NUMARG.LE.0)GOTO1410 2014 IF(IHARG(NUMARG).EQ.'ON')GOTO1410 2015 IF(IHARG(NUMARG).EQ.'OFF')GOTO1420 2016 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1410 2017 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1410 2018 IERROR='YES' 2019 GOTO1900 2020C 2021 1410 CONTINUE 2022 IFOUND='YES' 2023 IY1TSC='NORM' 2024 IY2TSC='NORM' 2025C 2026 IF(IFEEDB.EQ.'OFF')GOTO1419 2027 WRITE(ICOUT,999) 2028 CALL DPWRST('XXX','BUG ') 2029 WRITE(ICOUT,1415) 2030 1415 FORMAT('THE YNORM SWITCH (FOR BOTH VERT. NORMAL SCALES)', 2031 1'HAS JUST BEEN TURNED ON') 2032 CALL DPWRST('XXX','BUG ') 2033 1419 CONTINUE 2034 GOTO1900 2035C 2036 1420 CONTINUE 2037 IFOUND='YES' 2038 IY1TSC='LINE' 2039 IY2TSC='LINE' 2040C 2041 IF(IFEEDB.EQ.'OFF')GOTO1429 2042 WRITE(ICOUT,999) 2043 CALL DPWRST('XXX','BUG ') 2044 WRITE(ICOUT,1425) 2045 1425 FORMAT('THE YNORM SWITCH (FOR BOTH VERT. NORMAL SCALES)', 2046 1'HAS JUST BEEN TURNED OFF') 2047 CALL DPWRST('XXX','BUG ') 2048 1429 CONTINUE 2049 GOTO1900 2050C 2051 1499 CONTINUE 2052C 2053C ******************************************************** 2054C ** TREAT THE CASE WHEN 2055C ** ONLY THE LEFT VERTICAL FRAME LINE IS TO BE NORM 2056C ******************************************************** 2057C 2058 IF(ICOM.EQ.'Y1NO')GOTO1500 2059 GOTO1599 2060C 2061 1500 CONTINUE 2062 IF(NUMARG.LE.0)GOTO1510 2063 IF(IHARG(NUMARG).EQ.'ON')GOTO1510 2064 IF(IHARG(NUMARG).EQ.'OFF')GOTO1520 2065 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1510 2066 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1510 2067 IERROR='YES' 2068 GOTO1900 2069C 2070 1510 CONTINUE 2071 IFOUND='YES' 2072 IY1TSC='NORM' 2073C 2074 IF(IFEEDB.EQ.'OFF')GOTO1519 2075 WRITE(ICOUT,999) 2076 CALL DPWRST('XXX','BUG ') 2077 WRITE(ICOUT,1515) 2078 1515 FORMAT('THE Y1NORMAL SWITCH (FOR THE LEFT VERTICAL ', 2079 1'FRAME NORMAL SCALE ONLY) HAS JUST BEEN TURNED ON') 2080 CALL DPWRST('XXX','BUG ') 2081 1519 CONTINUE 2082 GOTO1900 2083C 2084 1520 CONTINUE 2085 IFOUND='YES' 2086 IY1TSC='LINE' 2087C 2088 IF(IFEEDB.EQ.'OFF')GOTO1529 2089 WRITE(ICOUT,999) 2090 CALL DPWRST('XXX','BUG ') 2091 WRITE(ICOUT,1525) 2092 1525 FORMAT('THE Y1NORMAL SWITCH (FOR THE LEFT VERTICAL ', 2093 1'FRAME NORMAL SCALE ONLY) HAS JUST BEEN TURNED OFF') 2094 CALL DPWRST('XXX','BUG ') 2095 1529 CONTINUE 2096 GOTO1900 2097C 2098 1599 CONTINUE 2099C 2100C ******************************************************** 2101C ** TREAT THE CASE WHEN 2102C ** ONLY THE RIGHT VERTCIAL FRAME LINE IS TO BE NORM 2103C ******************************************************** 2104C 2105 IF(ICOM.EQ.'Y2NO')GOTO1600 2106 GOTO1699 2107C 2108 1600 CONTINUE 2109 IF(NUMARG.LE.0)GOTO1610 2110 IF(IHARG(NUMARG).EQ.'ON')GOTO1610 2111 IF(IHARG(NUMARG).EQ.'OFF')GOTO1620 2112 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1610 2113 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1610 2114 IERROR='YES' 2115 GOTO1900 2116C 2117 1610 CONTINUE 2118 IFOUND='YES' 2119 IY2TSC='NORM' 2120C 2121 IF(IFEEDB.EQ.'OFF')GOTO1619 2122 WRITE(ICOUT,999) 2123 CALL DPWRST('XXX','BUG ') 2124 WRITE(ICOUT,1615) 2125 1615 FORMAT('THE Y2NORMAL SWITCH (FOR THE RIGHT VERTICAL ', 2126 1'FRAME NORMAL SCALE ONLY) HAS JUST BEEN TURNED ON') 2127 CALL DPWRST('XXX','BUG ') 2128 1619 CONTINUE 2129 GOTO1900 2130C 2131 1620 CONTINUE 2132 IFOUND='YES' 2133 IY2TSC='LINE' 2134C 2135 IF(IFEEDB.EQ.'OFF')GOTO1629 2136 WRITE(ICOUT,999) 2137 CALL DPWRST('XXX','BUG ') 2138 WRITE(ICOUT,1625) 2139 1625 FORMAT('THE Y2NORMAL SWITCH (FOR THE RIGHT VERTICAL ', 2140 1'FRAME NORMAL SCALE ONLY) HAS JUST BEEN TURNED OFF') 2141 CALL DPWRST('XXX','BUG ') 2142 1629 CONTINUE 2143 GOTO1900 2144C 2145 1699 CONTINUE 2146C 2147C ************************************************** 2148C ** TREAT THE CASE WHEN ** 2149C ** THE ENTIRE 4-SIDED FRAME IS TO BE NORMAL ** 2150C ************************************************** 2151C 2152 IF(ICOM.EQ.'XYNO')GOTO1700 2153 IF(ICOM.EQ.'YXNO')GOTO1700 2154CCCCC IF(ICOM.EQ.'NORM')GOTO1700 2155 GOTO1799 2156C 2157 1700 CONTINUE 2158 IF(NUMARG.LE.0)GOTO1710 2159 IF(IHARG(NUMARG).EQ.'ON')GOTO1710 2160 IF(IHARG(NUMARG).EQ.'OFF')GOTO1720 2161 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1710 2162 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1710 2163 IERROR='YES' 2164 GOTO1900 2165C 2166 1710 CONTINUE 2167 IFOUND='YES' 2168 IX1TSC='NORM' 2169 IX2TSC='NORM' 2170 IY1TSC='NORM' 2171 IY2TSC='NORM' 2172C 2173 IF(IFEEDB.EQ.'OFF')GOTO1719 2174 WRITE(ICOUT,999) 2175 CALL DPWRST('XXX','BUG ') 2176 WRITE(ICOUT,1715) 2177 1715 FORMAT('THE NORMAL SWITCH (FOR THE ENTIRE 4-SIDED FRAME) ', 2178 1'HAS JUST BEEN TURNED ON') 2179 CALL DPWRST('XXX','BUG ') 2180 1719 CONTINUE 2181 GOTO1900 2182C 2183 1720 CONTINUE 2184 IFOUND='YES' 2185 IX1TSC='LINE' 2186 IX2TSC='LINE' 2187 IY1TSC='LINE' 2188 IY2TSC='LINE' 2189C 2190 IF(IFEEDB.EQ.'OFF')GOTO1729 2191 WRITE(ICOUT,999) 2192 CALL DPWRST('XXX','BUG ') 2193 WRITE(ICOUT,1725) 2194 1725 FORMAT('THE NORMAL SWITCH (FOR THE ENTIRE 4-SIDED FRAME) ', 2195 1'HAS JUST BEEN TURNED OFF') 2196 CALL DPWRST('XXX','BUG ') 2197 1729 CONTINUE 2198 GOTO1900 2199C 2200 1799 CONTINUE 2201C 2202 1900 CONTINUE 2203 RETURN 2204 END 2205 SUBROUTINE DPTISZ(IHARG,IARGT,ARG,NUMARG, 2206 1PDEFHE,PDEFWI, 2207 1PTITHE,PTITWI,PTITVG,PTITHG, 2208 1IFOUND,IERROR) 2209C 2210C PURPOSE--DEFINE THE SIZE FOR THE TITLE 2211C (THE HORIZONTAL STRING ABOVE THE UPPER HORIZONTAL FRAME). 2212C THE SIZE FOR THE TITLE WILL BE PLACED 2213C IN THE FLOATING POINT VARIABLE PTITHE. 2214C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 2215C --NUMARG 2216C --PDEFHE 2217C --PDEFWI 2218C OUTPUT ARGUMENTS--PTITHE = TITLE HEIGHT 2219C --PTITWI = TITLE WIDTH 2220C --PTITVG = TITLE VERTICAL GAP 2221C --PTITHG = TITLE HORIZONTAL GAP 2222C --IFOUND ('YES' OR 'NO' ) 2223C --IERROR ('YES' OR 'NO' ) 2224C WRITTEN BY--JAMES J. FILLIBEN 2225C STATISTICAL ENGINEERING DIVISION 2226C INFORMATION TECHNOLOGY LABORATORY 2227C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 2228C GAITHERSBURG, MD 20899-8980 2229C PHONE--301-975-2855 2230C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 2231C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 2232C LANGUAGE--ANSI FORTRAN (1977) 2233C VERSION NUMBER--82/7 2234C ORIGINAL VERSION--SEPTEMBER 1980. 2235C UPDATED --MAY 1982. 2236C UPDATED --DECEMBER 1988. DEFAULT WIDTH 2237C 2238C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 2239C 2240 CHARACTER*4 IHARG 2241 CHARACTER*4 IARGT 2242 CHARACTER*4 IFOUND 2243 CHARACTER*4 IERROR 2244C 2245C--------------------------------------------------------------------- 2246C 2247 DIMENSION IHARG(*) 2248 DIMENSION IARGT(*) 2249 DIMENSION ARG(*) 2250C 2251C-----COMMON---------------------------------------------------------- 2252C 2253 INCLUDE 'DPCOP2.INC' 2254C 2255C-----START POINT----------------------------------------------------- 2256C 2257 IFOUND='NO' 2258 IERROR='NO' 2259C 2260 IF(NUMARG.LE.0)GOTO1199 2261 IF(IHARG(1).NE.'SIZE')GOTO1199 2262 IF(NUMARG.EQ.1)GOTO1150 2263 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 2264 GOTO1110 2265C 2266 1110 CONTINUE 2267 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 2268 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 2269 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 2270 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 2271C 2272 IERROR='YES' 2273 WRITE(ICOUT,1121) 2274 1121 FORMAT('***** ERROR IN DPTISZ--') 2275 CALL DPWRST('XXX','BUG ') 2276 WRITE(ICOUT,1122) 2277 1122 FORMAT(' ILLEGAL FORM FOR TITLE SIZE ', 2278 1'COMMAND.') 2279 CALL DPWRST('XXX','BUG ') 2280 WRITE(ICOUT,1124) 2281 1124 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 2282 1'PROPER FORM--') 2283 CALL DPWRST('XXX','BUG ') 2284 WRITE(ICOUT,1125) 2285 1125 FORMAT(' SUPPOSE IT IS DESIRED TO HAVE ') 2286 CALL DPWRST('XXX','BUG ') 2287 WRITE(ICOUT,1126) 2288 1126 FORMAT(' THE TITLE ONE AND ONE HALF TIMES AS BIG ') 2289 CALL DPWRST('XXX','BUG ') 2290 WRITE(ICOUT,1127) 2291 1127 FORMAT(' AS THE DEFAULT SIZE (WHICH IS SIZE 1), ') 2292 CALL DPWRST('XXX','BUG ') 2293 WRITE(ICOUT,1128) 2294 1128 FORMAT(' THEN THE ALLOWABLE FORM IS--') 2295 CALL DPWRST('XXX','BUG ') 2296 WRITE(ICOUT,1131) 2297 1131 FORMAT(' TITLE SIZE 1.5 ') 2298 CALL DPWRST('XXX','BUG ') 2299 GOTO9000 2300C 2301 1150 CONTINUE 2302 PTITHE=PDEFHE 2303 PTITWI=PDEFWI 2304 GOTO1180 2305C 2306 1160 CONTINUE 2307 PTITHE=ARG(NUMARG) 2308 PTITWI=PTITHE*0.5 2309 PTITVG=PTITHE*0.375 2310 PTITHG=PTITHE*0.125 2311 GOTO1180 2312C 2313 1180 CONTINUE 2314 IFOUND='YES' 2315C 2316 IF(IFEEDB.EQ.'OFF')GOTO1189 2317 WRITE(ICOUT,999) 2318 999 FORMAT(1X) 2319 CALL DPWRST('XXX','BUG ') 2320 WRITE(ICOUT,1181)PTITHE 2321 1181 FORMAT('THE TITLE SIZE HAS JUST BEEN SET TO ', 2322 1E15.7) 2323 CALL DPWRST('XXX','BUG ') 2324 1189 CONTINUE 2325 GOTO1199 2326C 2327 1199 CONTINUE 2328 GOTO9000 2329C 2330 9000 CONTINUE 2331 RETURN 2332 END 2333 SUBROUTINE DPTIT(IANS,IANSLC,IWIDTH,IHARG,IHARG2,NUMARG, 2334CCCCC SUBROUTINE DPTIT(IANS,IWIDTH,IHARG,IHARG2,NUMARG, 2335CCCCC THE ABOVE LINE WAS CHANGED SEPTEMBER 1993 2336CCCCC SO AS TO ALLOW FOR LOWER CASE SEPTEMBER 1993 2337CCCCC SUBROUTINE DPTIT(IANS,IWIDTH,IHARG,NUMARG, 2338CCCCC THE ABOVE LINE WAS AUGMENTED AUGUST 1992 2339CCCCC THE FOLLOWING LINE WAS AUGMENTED AUGUST 1992 2340CCCCC1ITITTE,NCTITL,IBUGP2,IFOUND,IERROR) 2341 1ITITTE,NCTITL,ITIAUT,IBUGP2,IFOUND,IERROR) 2342C 2343C PURPOSE--EXTRACT THE STRING TO BE USED AS A TITLE; 2344C SAVE THIS STRING FOR USE ON PRINTER PLOTS; 2345C ALSO, CONVERT THIS STRING INTO PROPER FORM 2346C (ASCII INTEGER REPRESENTATION) FOR USE 2347C WITH TEKTRONIX (OR EQUIVALENT) SOFTWARE. 2348C INPUT ARGUMENTS--IANS (A CHARACTER VECTOR) 2349C --IWIDTH 2350C --IHARG (A CHARACTER VECTOR) 2351C --IHARG2 (A CHARACTER VECTOR) 2352C --NUMARG 2353C OUTPUT ARGUMENTS--ITITTE (A CHARACTER VECTOR 2354C CONTAINING THE STRING FOR THE TITLE). 2355C --NCTITL (AN INTEGER VARIABLE 2356C CONTAINING THE 2357C NUMBER OF CHARACTERS IN THE TITLE). 2358C --IFOUND ('YES' OR 'NO' ) 2359C --IERROR ('YES' OR 'NO' ) 2360C WRITTEN BY--JAMES J. FILLIBEN 2361C STATISTICAL ENGINEERING DIVISION 2362C INFORMATION TECHNOLOGY LABORATORY 2363C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 2364C GAITHERSBURG, MD 20899-8980 2365C PHONE--301-975-2855 2366C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 2367C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 2368C LANGUAGE--ANSI FORTRAN (1977) 2369C VERSION NUMBER--82/7 2370C ORIGINAL VERSION--JANUARY 1978. 2371C UPDATED --JUNE 1978. 2372C UPDATED --JUNE 1979. 2373C UPDATED --SEPTEMBER 1980. 2374C UPDATED --MARCH 1981. 2375C UPDATED --DECEMBER 1981. 2376C UPDATED --MAY 1982. 2377C UPDATED --AUGUST 1992. ADD TITLE SWITCH 2378C FOR AUTOMATIC 2379C UPDATED --SEPTEMBER 1993. ALLOW LOWER CASE 2380C 2381C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 2382C 2383 CHARACTER*4 IANS 2384CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1993 2385CCCCC TO ALLOW FOR LOWER CASE SEPTEMBER 1993 2386 CHARACTER*4 IANSLC 2387 CHARACTER*4 IHARG 2388CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1992 2389 CHARACTER*4 IHARG2 2390C 2391 CHARACTER*4 ITITTE 2392C 2393CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1992 2394 CHARACTER*4 ITIAUT 2395C 2396 CHARACTER*4 IBUGP2 2397 CHARACTER*4 IFOUND 2398 CHARACTER*4 IERROR 2399C 2400C--------------------------------------------------------------------- 2401C 2402 DIMENSION IANS(*) 2403CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1993 2404CCCCC TO ALLOW FOR LOWER CASE SEPTEMBER 1993 2405 DIMENSION IANSLC(*) 2406 DIMENSION IHARG(*) 2407CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1992 2408 DIMENSION IHARG2(*) 2409C 2410 DIMENSION ITITTE(*) 2411C 2412C-----COMMON---------------------------------------------------------- 2413C 2414 INCLUDE 'DPCOP2.INC' 2415C 2416C-----START POINT----------------------------------------------------- 2417C 2418 IFOUND='NO' 2419 IERROR='NO' 2420C 2421 IF(IBUGP2.NE.'ON')GOTO90 2422 WRITE(ICOUT,999) 2423 999 FORMAT(1X) 2424 CALL DPWRST('XXX','BUG ') 2425 WRITE(ICOUT,51) 2426 51 FORMAT('AT THE BEGINNING OF DPTIT--') 2427 CALL DPWRST('XXX','BUG ') 2428 WRITE(ICOUT,53)NCTITL 2429 53 FORMAT('NCTITL = ',I5) 2430 CALL DPWRST('XXX','BUG ') 2431 WRITE(ICOUT,999) 2432 CALL DPWRST('XXX','BUG ') 2433 ILENT=NCTITL 2434 WRITE(ICOUT,41)(ITITTE(I),I=1,ILENT) 2435 41 FORMAT('CHARACTER ITITTE(.) --',100A1) 2436 CALL DPWRST('XXX','BUG ') 2437 WRITE(ICOUT,999) 2438 CALL DPWRST('XXX','BUG ') 2439 WRITE(ICOUT,999) 2440 CALL DPWRST('XXX','BUG ') 2441 90 CONTINUE 2442C 2443C ***************************************** 2444C ** STEP 1-- ** 2445C ** DETERMINE THE COMMAND ** 2446C ** (TITLE) AND ITS LOCATION ** 2447C ** ON THE LINE. ** 2448C ***************************************** 2449C 2450 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'COLO')GOTO9000 2451 IF(NUMARG.EQ.2.AND.IHARG(1).EQ.'COLO')GOTO9000 2452 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'SIZE')GOTO9000 2453 IF(NUMARG.EQ.2.AND.IHARG(1).EQ.'SIZE')GOTO9000 2454C 2455 DO1000I=1,IWIDTH 2456 I2=I 2457 IP1=I+1 2458 IP2=I+2 2459 IP3=I+3 2460 IP4=I+4 2461 IP5=I+5 2462 IP6=I+6 2463 IF(IANS(I).EQ.'T'.AND.IANS(IP1).EQ.'I' 2464 1.AND.IANS(IP2).EQ.'T'.AND.IANS(IP3).EQ.'L' 2465 1.AND.IANS(IP4).EQ.'E') 2466 1GOTO100 2467C 2468 1000 CONTINUE 2469 WRITE(ICOUT,1001) 2470 1001 FORMAT('***** ERROR IN DPTIT--') 2471 CALL DPWRST('XXX','BUG ') 2472 WRITE(ICOUT,1002) 2473 1002 FORMAT(' NO MATCH FOR COMMAND.') 2474 CALL DPWRST('XXX','BUG ') 2475 IERROR='YES' 2476 GOTO800 2477C 2478C ********************************************************** 2479C ** STEP 2-- ** 2480C ** DEFINE THE START POSITION (ISTART) FOR THE STRING. ** 2481C ********************************************************** 2482C 2483 100 CONTINUE 2484 ISTART=I2+6 2485 GOTO300 2486C 2487C ******************************************************** 2488C ** STEP 3-- ** 2489C ** DEFINE THE STOP POSITION (ISTOP) FOR THE STRING. ** 2490C ******************************************************** 2491C 2492 300 CONTINUE 2493 IFOUND='YES' 2494 ISTOP=0 2495 IF(ISTART.GT.IWIDTH)GOTO329 2496 DO320I=ISTART,IWIDTH 2497 IREV=IWIDTH-I+ISTART 2498 IF(IANS(IREV).NE.' ')GOTO325 2499 320 CONTINUE 2500 GOTO329 2501 325 CONTINUE 2502 ISTOP=IREV 2503 329 CONTINUE 2504C 2505C ***************************************** 2506C ** STEP 4-- ** 2507C ** COPY OVER THE STRING OF INTEREST. ** 2508C ***************************************** 2509C 2510 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'ON')GOTO359 2511 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'OFF')GOTO359 2512CCCCC IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'AUTO')GOTO359 2513 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'DEFA')GOTO359 2514 IF(NUMARG.EQ.0)GOTO359 2515C 2516 IF(ISTART.GT.ISTOP)GOTO359 2517 IF(ISTOP.EQ.0)GOTO359 2518 J=0 2519 DO350I=ISTART,ISTOP 2520 J=J+1 2521CCCCC THE FOLLOWING LINE WAS CHANGED SEPTEMBER 1993 2522CCCCC TO ALLOW FOR LOWER CASE SEPTEMBER 1993 2523CCCCC ITITTE(J)=IANS(I) 2524 ITITTE(J)=IANSLC(I) 2525 350 CONTINUE 2526 NCTITL=J 2527 GOTO800 2528 359 CONTINUE 2529C 2530C ************************************ 2531C ** STEP 5-- ** 2532C ** TREAT THE EMPTY-STRING CASE. ** 2533C ************************************ 2534C 2535 NCTITL=0 2536 GOTO800 2537C 2538C *************************** 2539C ** STEP 6-- ** 2540C ** PRINT OUT A MESSAGE ** 2541C *************************** 2542C 2543 800 CONTINUE 2544 ILENT=NCTITL 2545C 2546CCCCC THE FOLLOWING 6 LINES WERE ADDED AUGUST 1992 2547 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'AUTO'.AND. 2548 1IHARG2(1).EQ.'MATI')THEN 2549 ITIAUT='ON' 2550 ELSE 2551 ITIAUT='OFF' 2552 ENDIF 2553 IF(IFEEDB.EQ.'OFF')GOTO889 2554 WRITE(ICOUT,999) 2555 CALL DPWRST('XXX','BUG ') 2556 WRITE(ICOUT,811) 2557 811 FORMAT('THE TITLE HAS JUST BEEN SET TO') 2558 CALL DPWRST('XXX','BUG ') 2559 IF(ILENT.EQ.0)THEN 2560 WRITE(ICOUT,999) 2561 CALL DPWRST('XXX','BUG ') 2562 ELSEIF(ILENT.GE.1)THEN 2563 WRITE(ICOUT,812)(ITITTE(I),I=1,MIN(ILENT,120)) 2564 812 FORMAT(10X,120A1) 2565 CALL DPWRST('XXX','BUG ') 2566 ENDIF 2567 889 CONTINUE 2568 GOTO9000 2569C 2570C **************** 2571C ** STEP 90-- ** 2572C ** EXIT ** 2573C **************** 2574C 2575 9000 CONTINUE 2576 IF(IBUGP2.NE.'ON')GOTO9090 2577 WRITE(ICOUT,999) 2578 CALL DPWRST('XXX','BUG ') 2579 WRITE(ICOUT,9011) 2580 9011 FORMAT('AT THE END OF DPTIT--') 2581 CALL DPWRST('XXX','BUG ') 2582 WRITE(ICOUT,9012)NCTITL 2583 9012 FORMAT('NCTITL = ',I5) 2584 CALL DPWRST('XXX','BUG ') 2585 WRITE(ICOUT,999) 2586 CALL DPWRST('XXX','BUG ') 2587 ILENT=NCTITL 2588 WRITE(ICOUT,9021)(ITITTE(I),I=1,ILENT) 2589 9021 FORMAT('CHARACTER ITITTE(.) --',100A1) 2590 CALL DPWRST('XXX','BUG ') 2591 WRITE(ICOUT,999) 2592 CALL DPWRST('XXX','BUG ') 2593 9090 CONTINUE 2594C 2595 RETURN 2596 END 2597 SUBROUTINE DPTIDS(IHARG,ARG,NUMARG,PDEFDS,PTITDS,IFOUND,IERROR) 2598C 2599C PURPOSE--DEFINE THE DISPLACEMENT FOR THE TITLE 2600C (THE HORIZONTAL STRING ABOVE THE UPPER HORIZONTAL FRAME). 2601C THE DISPLACEMENT FOR THE TITLE WILL BE PLACED 2602C IN THE REAL VARIABLE PTITDS. 2603C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 2604C --ARG (A REAL VECTOR) 2605C --NUMARG 2606C --PDEFDS 2607C OUTPUT ARGUMENTS--PTITDS 2608C --IFOUND ('YES' OR 'NO' ) 2609C --IERROR ('YES' OR 'NO' ) 2610C WRITTEN BY--JAMES J. FILLIBEN 2611C STATISTICAL ENGINEERING DIVISION 2612C INFORMATION TECHNOLOGY LABORATORY 2613C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 2614C GAITHERSBURG, MD 20899-8980 2615C PHONE--301-975-2855 2616C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 2617C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 2618C LANGUAGE--ANSI FORTRAN (1977) 2619C VERSION NUMBER--89/8 2620C ORIGINAL VERSION--JULY 1989. 2621C 2622C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 2623C 2624 CHARACTER*4 IHARG 2625 CHARACTER*4 IFOUND 2626 CHARACTER*4 IERROR 2627C 2628C--------------------------------------------------------------------- 2629C 2630 DIMENSION IHARG(*) 2631 DIMENSION ARG(*) 2632C 2633C-----COMMON---------------------------------------------------------- 2634C 2635 INCLUDE 'DPCOP2.INC' 2636C 2637C-----START POINT----------------------------------------------------- 2638C 2639 IFOUND='NO' 2640 IERROR='NO' 2641C 2642 IF(NUMARG.LE.0)GOTO1199 2643 IF(IHARG(1).EQ.'DISP')GOTO1110 2644 IF(IHARG(1).EQ.'OFFS')GOTO1110 2645 IF(IHARG(1).EQ.'GAP')GOTO1110 2646 GOTO1199 2647C 2648 1110 CONTINUE 2649 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 2650 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 2651 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 2652 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 2653 IF(NUMARG.EQ.1)GOTO1150 2654 GOTO1160 2655C 2656 1150 CONTINUE 2657 PTITDS=PDEFDS 2658 GOTO1180 2659C 2660 1160 CONTINUE 2661 PTITDS=ARG(NUMARG) 2662 GOTO1180 2663C 2664 1180 CONTINUE 2665 IFOUND='YES' 2666C 2667 IF(IFEEDB.EQ.'OFF')GOTO1189 2668 WRITE(ICOUT,999) 2669 999 FORMAT(1X) 2670 CALL DPWRST('XXX','BUG ') 2671 WRITE(ICOUT,1181)PTITDS 2672 1181 FORMAT('THE TITLE DISPLACEMENT HAS JUST BEEN ', 2673 1'SET TO ',E15.7) 2674 CALL DPWRST('XXX','BUG ') 2675 1189 CONTINUE 2676 GOTO1199 2677C 2678 1199 CONTINUE 2679 RETURN 2680 END 2681 SUBROUTINE DPTITH(IHARG,ARG,NUMARG,PDEFTH,PTITTH,IFOUND,IERROR) 2682C 2683C PURPOSE--DEFINE THE THICKNESS FOR THE TITLE 2684C (THE HORIZONTAL STRING ABOVE THE UPPER HORIZONTAL FRAME). 2685C THE THICKNESS FOR THE TITLE WILL BE PLACED 2686C IN THE REAL VARIABLE PTITTH. 2687C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 2688C --ARG (A REAL VECTOR) 2689C --NUMARG 2690C --PDEFTH 2691C OUTPUT ARGUMENTS--PTITTH 2692C --IFOUND ('YES' OR 'NO' ) 2693C --IERROR ('YES' OR 'NO' ) 2694C WRITTEN BY--ALAN HECKERT 2695C COMPUTER SERVICES DIVISION 2696C INFORMATION TECHNOLOGY LABORATORY 2697C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 2698C GAITHERSBURG, MD 20899-8980 2699C PHONE--301-975-2899 2700C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 2701C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 2702C LANGUAGE--ANSI FORTRAN (1977) 2703C VERSION NUMBER--89/2 2704C ORIGINAL VERSION--JANUARY 1989. 2705C 2706C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 2707C 2708 CHARACTER*4 IHARG 2709 CHARACTER*4 IFOUND 2710 CHARACTER*4 IERROR 2711C 2712C--------------------------------------------------------------------- 2713C 2714 DIMENSION IHARG(*) 2715 DIMENSION ARG(*) 2716C 2717C-----COMMON---------------------------------------------------------- 2718C 2719 INCLUDE 'DPCOP2.INC' 2720C 2721C-----START POINT----------------------------------------------------- 2722C 2723 IFOUND='NO' 2724 IERROR='NO' 2725C 2726 IF(NUMARG.LE.0)GOTO1199 2727 IF(IHARG(1).EQ.'THIC')GOTO1110 2728 GOTO1199 2729C 2730 1110 CONTINUE 2731 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 2732 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 2733 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 2734 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 2735 IF(NUMARG.EQ.1)GOTO1150 2736 GOTO1160 2737C 2738 1150 CONTINUE 2739 PTITTH=PDEFTH 2740 GOTO1180 2741C 2742 1160 CONTINUE 2743 PTITTH=ARG(NUMARG) 2744 GOTO1180 2745C 2746 1180 CONTINUE 2747 IFOUND='YES' 2748C 2749 IF(IFEEDB.EQ.'OFF')GOTO1189 2750 WRITE(ICOUT,999) 2751 999 FORMAT(1X) 2752 CALL DPWRST('XXX','BUG ') 2753 WRITE(ICOUT,1181)PTITTH 2754 1181 FORMAT('THE TITLE THICKNESS HAS JUST BEEN SET TO ', 2755 1E15.7) 2756 CALL DPWRST('XXX','BUG ') 2757 1189 CONTINUE 2758 GOTO1199 2759C 2760 1199 CONTINUE 2761 RETURN 2762 END 2763 SUBROUTINE DPTL(ICOM,IHARG,NUMARG, 2764 1IX1ZSW,IX2ZSW,IY1ZSW,IY2ZSW, 2765 1IFOUND,IERROR) 2766C 2767C PURPOSE--DEFINE THE 4 TIC LABEL SWITCHES CONTAINED IN THE 2768C 4 VARIABLES IX1ZSW,IX2ZSW,IY1ZSW,IY2ZSW 2769C SUCH TIC LABEL SWITCHES TURN ON OR OFF 2770C THE TIC LABELS ON THE 4 FRAME LINES OF A PLOT. 2771C INPUT ARGUMENTS--ICOM 2772C --IHARG (A HOLLERITH VECTOR) 2773C --NUMARG 2774C OUTPUT ARGUMENTS-- 2775C --IX1ZSW = LOWER HORIZONTAL TIC LABELS 2776C --IX2ZSW = UPPER HORIZONTAL TIC LABELS 2777C --IY1ZSW = LEFT VERTICAL TIC LABELS 2778C --IY2ZSW = RIGHT VERTICAL TIC LABELS 2779C --IFOUND ('YES' OR 'NO' ) 2780C --IERROR ('YES' OR 'NO' ) 2781C WRITTEN BY--JAMES J. FILLIBEN 2782C STATISTICAL ENGINEERING DIVISION 2783C INFORMATION TECHNOLOGY LABORATORY 2784C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 2785C GAITHERSBURG, MD 20899-8980 2786C PHONE--301-975-2855 2787C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 2788C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 2789C LANGUAGE--ANSI FORTRAN (1977) 2790C VERSION NUMBER--82/7 2791C ORIGINAL VERSION--SEPTEMBER 1980. 2792C UPDATED --MARCH 1981. 2793C UPDATED --MAY 1982. 2794C 2795C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 2796C 2797 CHARACTER*4 ICOM 2798 CHARACTER*4 IHARG 2799C 2800 CHARACTER*4 IX1ZSW 2801 CHARACTER*4 IX2ZSW 2802 CHARACTER*4 IY1ZSW 2803 CHARACTER*4 IY2ZSW 2804C 2805 CHARACTER*4 IFOUND 2806 CHARACTER*4 IERROR 2807C 2808 CHARACTER*4 IHOLD 2809C 2810C--------------------------------------------------------------------- 2811C 2812 DIMENSION IHARG(*) 2813C 2814C-----COMMON---------------------------------------------------------- 2815C 2816 INCLUDE 'DPCOP2.INC' 2817C 2818C-----START POINT----------------------------------------------------- 2819C 2820 IFOUND='NO' 2821 IERROR='NO' 2822C 2823 IF(NUMARG.LE.0)GOTO1900 2824C 2825 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'NUMB')GOTO1900 2826C 2827 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 2828 1IHARG(2).EQ.'NUMB')GOTO1900 2829C FOLLOWING 4 LINES ADDED MAY, 1990. 2830 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'OFFS')GOTO1900 2831C 2832 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 2833 1IHARG(2).EQ.'OFFS')GOTO1900 2834C 2835 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 2836 1IHARG(2).EQ.'COLO')GOTO1900 2837 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 2838 1IHARG(2).EQ.'SIZE')GOTO1900 2839 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 2840 1IHARG(2).EQ.'HW')GOTO1900 2841 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 2842 1IHARG(2).EQ.'FORM')GOTO1900 2843 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 2844 1IHARG(2).EQ.'CONT')GOTO1900 2845 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 2846 1IHARG(2).EQ.'NUMB')GOTO1900 2847C 2848 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 2849 1IHARG(2).EQ.'LABE'.AND.IHARG(3).EQ.'COLO')GOTO1900 2850 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 2851 1IHARG(2).EQ.'LABE'.AND.IHARG(3).EQ.'SIZE')GOTO1900 2852 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 2853 1IHARG(2).EQ.'LABE'.AND.IHARG(3).EQ.'HW')GOTO1900 2854 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 2855 1IHARG(2).EQ.'LABE'.AND.IHARG(3).EQ.'FORM')GOTO1900 2856 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 2857 1IHARG(2).EQ.'LABE'.AND.IHARG(3).EQ.'CONT')GOTO1900 2858 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 2859 1IHARG(2).EQ.'LABE'.AND.IHARG(3).EQ.'NUMB')GOTO1900 2860C 2861C ***************************************************** 2862C ** TREAT THE CASE WHEN ** 2863C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 2864C ***************************************************** 2865C 2866 IF(ICOM.EQ.'XTIC')GOTO1100 2867 GOTO1199 2868C 2869 1100 CONTINUE 2870 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 2871 IF(IHARG(NUMARG).EQ.'OFF')GOTO1160 2872 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 2873 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 2874 IF(IHARG(NUMARG).EQ.'LABE')GOTO1160 2875 GOTO1150 2876C 2877 1150 CONTINUE 2878 IHOLD='ON' 2879 GOTO1180 2880C 2881 1160 CONTINUE 2882 IHOLD='OFF' 2883 GOTO1180 2884C 2885 1180 CONTINUE 2886 IFOUND='YES' 2887 IX1ZSW=IHOLD 2888 IX2ZSW=IHOLD 2889C 2890 IF(IFEEDB.EQ.'OFF')GOTO1189 2891 WRITE(ICOUT,999) 2892 999 FORMAT(1X) 2893 CALL DPWRST('XXX','BUG ') 2894 WRITE(ICOUT,1181) 2895 1181 FORMAT('THE TIC MARK LABEL (FOR BOTH HORIZONTAL ', 2896 1'FRAME LINES)') 2897 CALL DPWRST('XXX','BUG ') 2898 WRITE(ICOUT,1182)IHOLD 2899 1182 FORMAT('HAS JUST BEEN TURNED ',A4) 2900 CALL DPWRST('XXX','BUG ') 2901 1189 CONTINUE 2902 GOTO1900 2903C 2904 1199 CONTINUE 2905C 2906C ************************************************************** 2907C ** TREAT THE CASE WHEN ** 2908C ** ONLY THE BOTTOM HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 2909C ************************************************************** 2910C 2911 IF(ICOM.EQ.'X1TI')GOTO1200 2912 GOTO1299 2913C 2914 1200 CONTINUE 2915 IF(IHARG(NUMARG).EQ.'ON')GOTO1250 2916 IF(IHARG(NUMARG).EQ.'OFF')GOTO1260 2917 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 2918 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 2919 IF(IHARG(NUMARG).EQ.'LABE')GOTO1260 2920 GOTO1250 2921C 2922 1250 CONTINUE 2923 IHOLD='ON' 2924 GOTO1280 2925C 2926 1260 CONTINUE 2927 IHOLD='OFF' 2928 GOTO1280 2929C 2930 1280 CONTINUE 2931 IFOUND='YES' 2932 IX1ZSW=IHOLD 2933C 2934 IF(IFEEDB.EQ.'OFF')GOTO1289 2935 WRITE(ICOUT,999) 2936 CALL DPWRST('XXX','BUG ') 2937 WRITE(ICOUT,1281) 2938 1281 FORMAT('THE TIC MARK LABEL (FOR THE BOTTOM ', 2939 1'HORIZONTAL FRAME LINE)') 2940 CALL DPWRST('XXX','BUG ') 2941 WRITE(ICOUT,1282)IHOLD 2942 1282 FORMAT('HAS JUST BEEN TURNED ',A4) 2943 CALL DPWRST('XXX','BUG ') 2944 1289 CONTINUE 2945 GOTO1900 2946C 2947 1299 CONTINUE 2948C 2949C ************************************************************** 2950C ** TREAT THE CASE WHEN ** 2951C ** ONLY THE TOP HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 2952C ************************************************************** 2953C 2954 IF(ICOM.EQ.'X2TI')GOTO1300 2955 GOTO1399 2956C 2957 1300 CONTINUE 2958 IF(IHARG(NUMARG).EQ.'ON')GOTO1350 2959 IF(IHARG(NUMARG).EQ.'OFF')GOTO1360 2960 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 2961 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 2962 IF(IHARG(NUMARG).EQ.'LABE')GOTO1360 2963 GOTO1350 2964C 2965 1350 CONTINUE 2966 IHOLD='ON' 2967 GOTO1380 2968C 2969 1360 CONTINUE 2970 IHOLD='OFF' 2971 GOTO1380 2972C 2973 1380 CONTINUE 2974 IFOUND='YES' 2975 IX2ZSW=IHOLD 2976C 2977 IF(IFEEDB.EQ.'OFF')GOTO1389 2978 WRITE(ICOUT,999) 2979 CALL DPWRST('XXX','BUG ') 2980 WRITE(ICOUT,1381) 2981 1381 FORMAT('THE TIC MARK LABEL (FOR THE TOP HORIZONTAL ', 2982 1'FRAME LINE)') 2983 CALL DPWRST('XXX','BUG ') 2984 WRITE(ICOUT,1382)IHOLD 2985 1382 FORMAT('HAS JUST BEEN TURNED ',A4) 2986 CALL DPWRST('XXX','BUG ') 2987 1389 CONTINUE 2988 GOTO1900 2989C 2990 1399 CONTINUE 2991C 2992C ***************************************************** 2993C ** TREAT THE CASE WHEN ** 2994C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 2995C ***************************************************** 2996C 2997 IF(ICOM.EQ.'YTIC')GOTO1400 2998 GOTO1499 2999C 3000 1400 CONTINUE 3001 IF(IHARG(NUMARG).EQ.'ON')GOTO1450 3002 IF(IHARG(NUMARG).EQ.'OFF')GOTO1460 3003 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 3004 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 3005 IF(IHARG(NUMARG).EQ.'LABE')GOTO1460 3006 GOTO1450 3007C 3008 1450 CONTINUE 3009 IHOLD='ON' 3010 GOTO1480 3011C 3012 1460 CONTINUE 3013 IHOLD='OFF' 3014 GOTO1480 3015C 3016 1480 CONTINUE 3017 IFOUND='YES' 3018 IY1ZSW=IHOLD 3019 IY2ZSW=IHOLD 3020C 3021 IF(IFEEDB.EQ.'OFF')GOTO1489 3022 WRITE(ICOUT,999) 3023 CALL DPWRST('XXX','BUG ') 3024 WRITE(ICOUT,1481) 3025 1481 FORMAT('THE TIC MARK LABEL (FOR BOTH VERTICAL ', 3026 1'FRAME LINES)') 3027 CALL DPWRST('XXX','BUG ') 3028 WRITE(ICOUT,1482)IHOLD 3029 1482 FORMAT('HAS JUST BEEN TURNED ',A4) 3030 CALL DPWRST('XXX','BUG ') 3031 1489 CONTINUE 3032 GOTO1900 3033C 3034 1499 CONTINUE 3035C 3036C ************************************************************** 3037C ** TREAT THE CASE WHEN ** 3038C ** ONLY THE LEFT VERTICAL TIC MARKS ARE TO BE CHANGED ** 3039C ************************************************************** 3040C 3041 IF(ICOM.EQ.'Y1TI')GOTO1500 3042 GOTO1599 3043C 3044 1500 CONTINUE 3045 IF(IHARG(NUMARG).EQ.'ON')GOTO1550 3046 IF(IHARG(NUMARG).EQ.'OFF')GOTO1560 3047 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 3048 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 3049 IF(IHARG(NUMARG).EQ.'LABE')GOTO1560 3050 GOTO1550 3051C 3052 1550 CONTINUE 3053 IHOLD='ON' 3054 GOTO1580 3055C 3056 1560 CONTINUE 3057 IHOLD='OFF' 3058 GOTO1580 3059C 3060 1580 CONTINUE 3061 IFOUND='YES' 3062 IY1ZSW=IHOLD 3063C 3064 IF(IFEEDB.EQ.'OFF')GOTO1589 3065 WRITE(ICOUT,999) 3066 CALL DPWRST('XXX','BUG ') 3067 WRITE(ICOUT,1581) 3068 1581 FORMAT('THE TIC MARK LABEL (FOR THE LEFT VERTICAL ', 3069 1'FRAME LINE)') 3070 CALL DPWRST('XXX','BUG ') 3071 WRITE(ICOUT,1582)IHOLD 3072 1582 FORMAT('HAS JUST BEEN TURNED ',A4) 3073 CALL DPWRST('XXX','BUG ') 3074 1589 CONTINUE 3075 GOTO1900 3076C 3077 1599 CONTINUE 3078C 3079C ************************************************************** 3080C ** TREAT THE CASE WHEN ** 3081C ** ONLY THE RIGHT VERTICAL TIC MARKS ARE TO BE CHANGED ** 3082C ************************************************************** 3083C 3084 IF(ICOM.EQ.'Y2TI')GOTO1600 3085 GOTO1699 3086C 3087 1600 CONTINUE 3088 IF(IHARG(NUMARG).EQ.'ON')GOTO1650 3089 IF(IHARG(NUMARG).EQ.'OFF')GOTO1660 3090 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 3091 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 3092 IF(IHARG(NUMARG).EQ.'LABE')GOTO1660 3093 GOTO1650 3094C 3095 1650 CONTINUE 3096 IHOLD='ON' 3097 GOTO1680 3098C 3099 1660 CONTINUE 3100 IHOLD='OFF' 3101 GOTO1680 3102C 3103 1680 CONTINUE 3104 IFOUND='YES' 3105 IY2ZSW=IHOLD 3106C 3107 IF(IFEEDB.EQ.'OFF')GOTO1689 3108 WRITE(ICOUT,999) 3109 CALL DPWRST('XXX','BUG ') 3110 WRITE(ICOUT,1681) 3111 1681 FORMAT('THE TIC MARK LABEL (FOR THE RIGHT VERTICAL ', 3112 1'FRAME LINE)') 3113 CALL DPWRST('XXX','BUG ') 3114 WRITE(ICOUT,1682)IHOLD 3115 1682 FORMAT('HAS JUST BEEN TURNED ',A4) 3116 CALL DPWRST('XXX','BUG ') 3117 1689 CONTINUE 3118 GOTO1900 3119C 3120 1699 CONTINUE 3121C 3122C ***************************************************** 3123C ** TREAT THE CASE WHEN ** 3124C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 3125C ***************************************************** 3126C 3127 IF(ICOM.EQ.'TIC')GOTO1700 3128 IF(ICOM.EQ.'TICS')GOTO1700 3129 IF(ICOM.EQ.'XYTI')GOTO1700 3130 IF(ICOM.EQ.'YXTI')GOTO1700 3131 GOTO1799 3132C 3133 1700 CONTINUE 3134 IF(IHARG(NUMARG).EQ.'ON')GOTO1750 3135 IF(IHARG(NUMARG).EQ.'OFF')GOTO1760 3136 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 3137 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 3138 IF(IHARG(NUMARG).EQ.'LABE')GOTO1760 3139 GOTO1750 3140C 3141 1750 CONTINUE 3142 IHOLD='ON' 3143 GOTO1780 3144C 3145 1760 CONTINUE 3146 IHOLD='OFF' 3147 GOTO1780 3148C 3149 1780 CONTINUE 3150 IFOUND='YES' 3151 IX1ZSW=IHOLD 3152 IX2ZSW=IHOLD 3153 IY1ZSW=IHOLD 3154 IY2ZSW=IHOLD 3155C 3156 IF(IFEEDB.EQ.'OFF')GOTO1789 3157 WRITE(ICOUT,999) 3158 CALL DPWRST('XXX','BUG ') 3159 WRITE(ICOUT,1781) 3160 1781 FORMAT('THE TIC MARK LABEL (FOR ALL 4 ', 3161 1'FRAME LINES)') 3162 CALL DPWRST('XXX','BUG ') 3163 WRITE(ICOUT,1782)IHOLD 3164 1782 FORMAT('HAS JUST BEEN TURNED ',A4) 3165 CALL DPWRST('XXX','BUG ') 3166 1789 CONTINUE 3167 GOTO1900 3168C 3169 1799 CONTINUE 3170C 3171 1900 CONTINUE 3172 RETURN 3173 END 3174 SUBROUTINE DPTLAN(ICOM,IHARG,ARG,NUMARG, 3175 1PDEFAN, 3176 1PX1ZAN,PX2ZAN,PY1ZAN,PY2ZAN, 3177 1IFOUND,IERROR) 3178C 3179C PURPOSE--DEFINE THE 4 TIC LABEL ANGLES CONTAINED IN THE 3180C 4 VARIABLES PX1ZAN,PX2ZAN,PY1ZAN,PY2ZAN 3181C SUCH TIC LABEL ANGLES DEFINE THE ANGLES FOR 3182C THE TIC LABELS ON THE 4 FRAME LINES OF A PLOT. 3183C INPUT ARGUMENTS--ICOM 3184C --IHARG (A HOLLERITH VECTOR) 3185C --ARG (A REAL VECTOR) 3186C --NUMARG 3187C --PDEFAN 3188C OUTPUT ARGUMENTS-- 3189C --PX1ZAN = LOWER HORIZONTAL TIC LABEL ANGLE 3190C --PX2ZAN = UPPER HORIZONTAL TIC LABEL ANGLE 3191C --PY1ZAN = LEFT VERTICAL TIC LABEL ANGLE 3192C --PY2ZAN = RIGHT VERTICAL TIC LABEL ANGLE 3193C --IFOUND ('YES' OR 'NO' ) 3194C --IERROR ('YES' OR 'NO' ) 3195C WRITTEN BY--ALAN HECKERT 3196C COMPUTER SERVICES DIVISION 3197C INFORMATION TECHNOLOGY LABORATORY 3198C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 3199C GAITHERSBURG, MD 20899-8980 3200C PHONE--301-975-2899 3201C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 3202C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 3203C LANGUAGE--ANSI FORTRAN (1977) 3204C VERSION NUMBER--89/2 3205C ORIGINAL VERSION--JANUARY 1989. 3206C 3207C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 3208C 3209 CHARACTER*4 ICOM 3210 CHARACTER*4 IHARG 3211C 3212C 3213 CHARACTER*4 IFOUND 3214 CHARACTER*4 IERROR 3215C 3216C--------------------------------------------------------------------- 3217C 3218 DIMENSION IHARG(*) 3219 DIMENSION ARG(*) 3220C 3221C-----COMMON---------------------------------------------------------- 3222C 3223 INCLUDE 'DPCOP2.INC' 3224C 3225C-----START POINT----------------------------------------------------- 3226C 3227 IFOUND='NO' 3228 IERROR='NO' 3229C 3230 IF(NUMARG.LE.1)GOTO1900 3231 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 3232 1IHARG(2).EQ.'ANGL')GOTO1090 3233 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 3234 1IHARG(2).EQ.'LABE'.AND.IHARG(3).EQ.'ANGL')GOTO1090 3235 GOTO1900 3236 1090 CONTINUE 3237C 3238C ***************************************************** 3239C ** TREAT THE CASE WHEN ** 3240C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 3241C ***************************************************** 3242C 3243 IF(ICOM.EQ.'XTIC')GOTO1100 3244 GOTO1199 3245C 3246 1100 CONTINUE 3247 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 3248 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 3249 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 3250 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 3251 IF(IHARG(NUMARG).EQ.'ANGL')GOTO1150 3252 GOTO1160 3253C 3254 1150 CONTINUE 3255 PHOLD=PDEFAN 3256 GOTO1180 3257C 3258 1160 CONTINUE 3259 PHOLD=ARG(NUMARG) 3260 GOTO1180 3261C 3262 1180 CONTINUE 3263 IFOUND='YES' 3264 PX1ZAN=PHOLD 3265 PX2ZAN=PHOLD 3266C 3267 IF(IFEEDB.EQ.'OFF')GOTO1189 3268 WRITE(ICOUT,999) 3269 999 FORMAT(1X) 3270 CALL DPWRST('XXX','BUG ') 3271 WRITE(ICOUT,1181) 3272 1181 FORMAT('THE TIC MARK LABEL ANGLE (FOR BOTH HORIZONTAL ', 3273 1'FRAME LINES)') 3274 CALL DPWRST('XXX','BUG ') 3275 WRITE(ICOUT,1182)PHOLD 3276 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7) 3277 CALL DPWRST('XXX','BUG ') 3278 1189 CONTINUE 3279 GOTO1900 3280C 3281 1199 CONTINUE 3282C 3283C ************************************************************** 3284C ** TREAT THE CASE WHEN ** 3285C ** ONLY THE BOTTOM HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 3286C ************************************************************** 3287C 3288 IF(ICOM.EQ.'X1TI')GOTO1200 3289 GOTO1299 3290C 3291 1200 CONTINUE 3292 IF(IHARG(NUMARG).EQ.'ON')GOTO1250 3293 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 3294 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 3295 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 3296 IF(IHARG(NUMARG).EQ.'ANGL')GOTO1250 3297 GOTO1260 3298C 3299 1250 CONTINUE 3300 PHOLD=PDEFAN 3301 GOTO1280 3302C 3303 1260 CONTINUE 3304 PHOLD=ARG(NUMARG) 3305 GOTO1280 3306C 3307 1280 CONTINUE 3308 IFOUND='YES' 3309 PX1ZAN=PHOLD 3310C 3311 IF(IFEEDB.EQ.'OFF')GOTO1289 3312 WRITE(ICOUT,999) 3313 CALL DPWRST('XXX','BUG ') 3314 WRITE(ICOUT,1281) 3315 1281 FORMAT('THE TIC MARK LABEL ANGLE (FOR THE BOTTOM ', 3316 1'HORIZONTAL FRAME LINE)') 3317 CALL DPWRST('XXX','BUG ') 3318 WRITE(ICOUT,1282)PHOLD 3319 1282 FORMAT('HAS JUST BEEN SET TO ',E15.7) 3320 CALL DPWRST('XXX','BUG ') 3321 1289 CONTINUE 3322 GOTO1900 3323C 3324 1299 CONTINUE 3325C 3326C ************************************************************** 3327C ** TREAT THE CASE WHEN ** 3328C ** ONLY THE TOP HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 3329C ************************************************************** 3330C 3331 IF(ICOM.EQ.'X2TI')GOTO1300 3332 GOTO1399 3333C 3334 1300 CONTINUE 3335 IF(IHARG(NUMARG).EQ.'ON')GOTO1350 3336 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 3337 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 3338 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 3339 IF(IHARG(NUMARG).EQ.'ANGL')GOTO1350 3340 GOTO1360 3341C 3342 1350 CONTINUE 3343 PHOLD=PDEFAN 3344 GOTO1380 3345C 3346 1360 CONTINUE 3347 PHOLD=ARG(NUMARG) 3348 GOTO1380 3349C 3350 1380 CONTINUE 3351 IFOUND='YES' 3352 PX2ZAN=PHOLD 3353C 3354 IF(IFEEDB.EQ.'OFF')GOTO1389 3355 WRITE(ICOUT,999) 3356 CALL DPWRST('XXX','BUG ') 3357 WRITE(ICOUT,1381) 3358 1381 FORMAT('THE TIC MARK LABEL ANGLE (FOR THE TOP HORIZONTAL ', 3359 1'FRAME LINE)') 3360 CALL DPWRST('XXX','BUG ') 3361 WRITE(ICOUT,1382)PHOLD 3362 1382 FORMAT('HAS JUST BEEN SET TO ',E15.7) 3363 CALL DPWRST('XXX','BUG ') 3364 1389 CONTINUE 3365 GOTO1900 3366C 3367 1399 CONTINUE 3368C 3369C ***************************************************** 3370C ** TREAT THE CASE WHEN ** 3371C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 3372C ***************************************************** 3373C 3374 IF(ICOM.EQ.'YTIC')GOTO1400 3375 GOTO1499 3376C 3377 1400 CONTINUE 3378 IF(IHARG(NUMARG).EQ.'ON')GOTO1450 3379 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 3380 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 3381 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 3382 IF(IHARG(NUMARG).EQ.'ANGL')GOTO1450 3383 GOTO1460 3384C 3385 1450 CONTINUE 3386 PHOLD=PDEFAN 3387 GOTO1480 3388C 3389 1460 CONTINUE 3390 PHOLD=ARG(NUMARG) 3391 GOTO1480 3392C 3393 1480 CONTINUE 3394 IFOUND='YES' 3395 PY1ZAN=PHOLD 3396 PY2ZAN=PHOLD 3397C 3398 IF(IFEEDB.EQ.'OFF')GOTO1489 3399 WRITE(ICOUT,999) 3400 CALL DPWRST('XXX','BUG ') 3401 WRITE(ICOUT,1481) 3402 1481 FORMAT('THE TIC MARK LABEL ANGLE (FOR BOTH VERTICAL ', 3403 1'FRAME LINES)') 3404 CALL DPWRST('XXX','BUG ') 3405 WRITE(ICOUT,1482)PHOLD 3406 1482 FORMAT('HAS JUST BEEN SET TO ',E15.7) 3407 CALL DPWRST('XXX','BUG ') 3408 1489 CONTINUE 3409 GOTO1900 3410C 3411 1499 CONTINUE 3412C 3413C ************************************************************** 3414C ** TREAT THE CASE WHEN ** 3415C ** ONLY THE LEFT VERTICAL TIC MARKS ARE TO BE CHANGED ** 3416C ************************************************************** 3417C 3418 IF(ICOM.EQ.'Y1TI')GOTO1500 3419 GOTO1599 3420C 3421 1500 CONTINUE 3422 IF(IHARG(NUMARG).EQ.'ON')GOTO1550 3423 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 3424 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 3425 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 3426 IF(IHARG(NUMARG).EQ.'ANGL')GOTO1550 3427 GOTO1560 3428C 3429 1550 CONTINUE 3430 PHOLD=PDEFAN 3431 GOTO1580 3432C 3433 1560 CONTINUE 3434 PHOLD=ARG(NUMARG) 3435 GOTO1580 3436C 3437 1580 CONTINUE 3438 IFOUND='YES' 3439 PY1ZAN=PHOLD 3440C 3441 IF(IFEEDB.EQ.'OFF')GOTO1589 3442 WRITE(ICOUT,999) 3443 CALL DPWRST('XXX','BUG ') 3444 WRITE(ICOUT,1581) 3445 1581 FORMAT('THE TIC MARK LABEL ANGLE (FOR THE LEFT VERTICAL ', 3446 1'FRAME LINE)') 3447 CALL DPWRST('XXX','BUG ') 3448 WRITE(ICOUT,1582)PHOLD 3449 1582 FORMAT('HAS JUST BEEN SET TO ',E15.7) 3450 CALL DPWRST('XXX','BUG ') 3451 1589 CONTINUE 3452 GOTO1900 3453C 3454 1599 CONTINUE 3455C 3456C ************************************************************** 3457C ** TREAT THE CASE WHEN ** 3458C ** ONLY THE RIGHT VERTICAL TIC MARKS ARE TO BE CHANGED ** 3459C ************************************************************** 3460C 3461 IF(ICOM.EQ.'Y2TI')GOTO1600 3462 GOTO1699 3463C 3464 1600 CONTINUE 3465 IF(IHARG(NUMARG).EQ.'ON')GOTO1650 3466 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 3467 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 3468 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 3469 IF(IHARG(NUMARG).EQ.'ANGL')GOTO1650 3470 GOTO1660 3471C 3472 1650 CONTINUE 3473 PHOLD=PDEFAN 3474 GOTO1680 3475C 3476 1660 CONTINUE 3477 PHOLD=ARG(NUMARG) 3478 GOTO1680 3479C 3480 1680 CONTINUE 3481 IFOUND='YES' 3482 PY2ZAN=PHOLD 3483C 3484 IF(IFEEDB.EQ.'OFF')GOTO1689 3485 WRITE(ICOUT,999) 3486 CALL DPWRST('XXX','BUG ') 3487 WRITE(ICOUT,1681) 3488 1681 FORMAT('THE TIC MARK LABEL ANGLE (FOR THE RIGHT VERTICAL ', 3489 1'FRAME LINE)') 3490 CALL DPWRST('XXX','BUG ') 3491 WRITE(ICOUT,1682)PHOLD 3492 1682 FORMAT('HAS JUST BEEN SET TO ',E15.7) 3493 CALL DPWRST('XXX','BUG ') 3494 1689 CONTINUE 3495 GOTO1900 3496C 3497 1699 CONTINUE 3498C 3499C ***************************************************** 3500C ** TREAT THE CASE WHEN ** 3501C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 3502C ***************************************************** 3503C 3504 IF(ICOM.EQ.'TIC')GOTO1700 3505 IF(ICOM.EQ.'TICS')GOTO1700 3506 IF(ICOM.EQ.'XYTI')GOTO1700 3507 IF(ICOM.EQ.'YXTI')GOTO1700 3508 GOTO1799 3509C 3510 1700 CONTINUE 3511 IF(IHARG(NUMARG).EQ.'ON')GOTO1750 3512 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 3513 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 3514 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 3515 IF(IHARG(NUMARG).EQ.'ANGL')GOTO1750 3516 GOTO1760 3517C 3518 1750 CONTINUE 3519 PHOLD=PDEFAN 3520 GOTO1780 3521C 3522 1760 CONTINUE 3523 PHOLD=ARG(NUMARG) 3524 GOTO1780 3525C 3526 1780 CONTINUE 3527 IFOUND='YES' 3528 PX1ZAN=PHOLD 3529 PX2ZAN=PHOLD 3530 PY1ZAN=PHOLD 3531 PY2ZAN=PHOLD 3532C 3533 IF(IFEEDB.EQ.'OFF')GOTO1789 3534 WRITE(ICOUT,999) 3535 CALL DPWRST('XXX','BUG ') 3536 WRITE(ICOUT,1781) 3537 1781 FORMAT('THE TIC MARK LABEL ANGLE (FOR ALL 4 ', 3538 1'FRAME LINES)') 3539 CALL DPWRST('XXX','BUG ') 3540 WRITE(ICOUT,1782)PHOLD 3541 1782 FORMAT('HAS JUST BEEN SET TO ',E15.7) 3542 CALL DPWRST('XXX','BUG ') 3543 1789 CONTINUE 3544 GOTO1900 3545C 3546 1799 CONTINUE 3547C 3548 1900 CONTINUE 3549 RETURN 3550 END 3551 SUBROUTINE DPTLCA(ICOM,IHARG,NUMARG, 3552 1IDEFCA, 3553 1IX1ZCA,IX2ZCA,IY1ZCA,IY2ZCA, 3554 1IFOUND,IERROR) 3555C 3556C PURPOSE--DEFINE THE 4 TIC LABEL CASES CONTAINED IN THE 3557C 4 VARIABLES IX1ZCA,IX2ZCA,IY1ZCA,IY2ZCA 3558C SUCH TIC LABEL CASES DEFINE THE CASES FOR 3559C THE TIC LABELS ON THE 4 FRAME LINES OF A PLOT. 3560C INPUT ARGUMENTS--ICOM 3561C --IHARG (A HOLLERITH VECTOR) 3562C --NUMARG 3563C --IDEFCA 3564C OUTPUT ARGUMENTS-- 3565C --IX1ZCA = LOWER HORIZONTAL TIC LABEL CASE 3566C --IX2ZCA = UPPER HORIZONTAL TIC LABEL CASE 3567C --IY1ZCA = LEFT VERTICAL TIC LABEL CASE 3568C --IY2ZCA = RIGHT VERTICAL TIC LABEL CASE 3569C --IFOUND ('YES' OR 'NO' ) 3570C --IERROR ('YES' OR 'NO' ) 3571C WRITTEN BY--ALAN HECKERT 3572C COMPUTER SERVICES DIVISION 3573C INFORMATION TECHNOLOGY LABORATORY 3574C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 3575C GAITHERSBURG, MD 20899-8980 3576C PHONE--301-975-2899 3577C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 3578C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 3579C LANGUAGE--ANSI FORTRAN (1977) 3580C VERSION NUMBER--89/2 3581C ORIGINAL VERSION--JANUARY 1989. 3582C 3583C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 3584C 3585 CHARACTER*4 ICOM 3586 CHARACTER*4 IHARG 3587C 3588 CHARACTER*4 IDEFCA 3589C 3590 CHARACTER*4 IX1ZCA 3591 CHARACTER*4 IX2ZCA 3592 CHARACTER*4 IY1ZCA 3593 CHARACTER*4 IY2ZCA 3594C 3595 CHARACTER*4 IFOUND 3596 CHARACTER*4 IERROR 3597C 3598 CHARACTER*4 IHOLD 3599C 3600C--------------------------------------------------------------------- 3601C 3602 DIMENSION IHARG(*) 3603C 3604C-----COMMON---------------------------------------------------------- 3605C 3606 INCLUDE 'DPCOP2.INC' 3607C 3608C-----START POINT----------------------------------------------------- 3609C 3610 IFOUND='NO' 3611 IERROR='NO' 3612C 3613 IF(NUMARG.LE.1)GOTO1900 3614 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 3615 1IHARG(2).EQ.'CASE')GOTO1090 3616 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 3617 1IHARG(2).EQ.'LABE'.AND.IHARG(3).EQ.'CASE')GOTO1090 3618 GOTO1900 3619 1090 CONTINUE 3620C 3621C ***************************************************** 3622C ** TREAT THE CASE WHEN ** 3623C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 3624C ***************************************************** 3625C 3626 IF(ICOM.EQ.'XTIC')GOTO1100 3627 GOTO1199 3628C 3629 1100 CONTINUE 3630 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 3631 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 3632 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 3633 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 3634 IF(IHARG(NUMARG).EQ.'CASE')GOTO1150 3635 GOTO1160 3636C 3637 1150 CONTINUE 3638 IHOLD=IDEFCA 3639 GOTO1180 3640C 3641 1160 CONTINUE 3642 IHOLD=IHARG(NUMARG) 3643 GOTO1180 3644C 3645 1180 CONTINUE 3646 IFOUND='YES' 3647 IX1ZCA=IHOLD 3648 IX2ZCA=IHOLD 3649C 3650 IF(IFEEDB.EQ.'OFF')GOTO1189 3651 WRITE(ICOUT,999) 3652 999 FORMAT(1X) 3653 CALL DPWRST('XXX','BUG ') 3654 WRITE(ICOUT,1181) 3655 1181 FORMAT('THE TIC MARK LABEL CASE (FOR BOTH HORIZONTAL ', 3656 1'FRAME LINES)') 3657 CALL DPWRST('XXX','BUG ') 3658 WRITE(ICOUT,1182)IHOLD 3659 1182 FORMAT('HAS JUST BEEN SET TO ',A4) 3660 CALL DPWRST('XXX','BUG ') 3661 1189 CONTINUE 3662 GOTO1900 3663C 3664 1199 CONTINUE 3665C 3666C ************************************************************** 3667C ** TREAT THE CASE WHEN ** 3668C ** ONLY THE BOTTOM HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 3669C ************************************************************** 3670C 3671 IF(ICOM.EQ.'X1TI')GOTO1200 3672 GOTO1299 3673C 3674 1200 CONTINUE 3675 IF(IHARG(NUMARG).EQ.'ON')GOTO1250 3676 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 3677 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 3678 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 3679 IF(IHARG(NUMARG).EQ.'CASE')GOTO1250 3680 GOTO1260 3681C 3682 1250 CONTINUE 3683 IHOLD=IDEFCA 3684 GOTO1280 3685C 3686 1260 CONTINUE 3687 IHOLD=IHARG(NUMARG) 3688 GOTO1280 3689C 3690 1280 CONTINUE 3691 IFOUND='YES' 3692 IX1ZCA=IHOLD 3693C 3694 IF(IFEEDB.EQ.'OFF')GOTO1289 3695 WRITE(ICOUT,999) 3696 CALL DPWRST('XXX','BUG ') 3697 WRITE(ICOUT,1281) 3698 1281 FORMAT('THE TIC MARK LABEL CASE (FOR THE BOTTOM ', 3699 1'HORIZONTAL FRAME LINE)') 3700 CALL DPWRST('XXX','BUG ') 3701 WRITE(ICOUT,1282)IHOLD 3702 1282 FORMAT('HAS JUST BEEN SET TO ',A4) 3703 CALL DPWRST('XXX','BUG ') 3704 1289 CONTINUE 3705 GOTO1900 3706C 3707 1299 CONTINUE 3708C 3709C ************************************************************** 3710C ** TREAT THE CASE WHEN ** 3711C ** ONLY THE TOP HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 3712C ************************************************************** 3713C 3714 IF(ICOM.EQ.'X2TI')GOTO1300 3715 GOTO1399 3716C 3717 1300 CONTINUE 3718 IF(IHARG(NUMARG).EQ.'ON')GOTO1350 3719 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 3720 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 3721 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 3722 IF(IHARG(NUMARG).EQ.'CASE')GOTO1350 3723 GOTO1360 3724C 3725 1350 CONTINUE 3726 IHOLD=IDEFCA 3727 GOTO1380 3728C 3729 1360 CONTINUE 3730 IHOLD=IHARG(NUMARG) 3731 GOTO1380 3732C 3733 1380 CONTINUE 3734 IFOUND='YES' 3735 IX2ZCA=IHOLD 3736C 3737 IF(IFEEDB.EQ.'OFF')GOTO1389 3738 WRITE(ICOUT,999) 3739 CALL DPWRST('XXX','BUG ') 3740 WRITE(ICOUT,1381) 3741 1381 FORMAT('THE TIC MARK LABEL CASE (FOR THE TOP HORIZONTAL ', 3742 1'FRAME LINE)') 3743 CALL DPWRST('XXX','BUG ') 3744 WRITE(ICOUT,1382)IHOLD 3745 1382 FORMAT('HAS JUST BEEN SET TO ',A4) 3746 CALL DPWRST('XXX','BUG ') 3747 1389 CONTINUE 3748 GOTO1900 3749C 3750 1399 CONTINUE 3751C 3752C ***************************************************** 3753C ** TREAT THE CASE WHEN ** 3754C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 3755C ***************************************************** 3756C 3757 IF(ICOM.EQ.'YTIC')GOTO1400 3758 GOTO1499 3759C 3760 1400 CONTINUE 3761 IF(IHARG(NUMARG).EQ.'ON')GOTO1450 3762 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 3763 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 3764 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 3765 IF(IHARG(NUMARG).EQ.'CASE')GOTO1450 3766 GOTO1460 3767C 3768 1450 CONTINUE 3769 IHOLD=IDEFCA 3770 GOTO1480 3771C 3772 1460 CONTINUE 3773 IHOLD=IHARG(NUMARG) 3774 GOTO1480 3775C 3776 1480 CONTINUE 3777 IFOUND='YES' 3778 IY1ZCA=IHOLD 3779 IY2ZCA=IHOLD 3780C 3781 IF(IFEEDB.EQ.'OFF')GOTO1489 3782 WRITE(ICOUT,999) 3783 CALL DPWRST('XXX','BUG ') 3784 WRITE(ICOUT,1481) 3785 1481 FORMAT('THE TIC MARK LABEL CASE (FOR BOTH VERTICAL ', 3786 1'FRAME LINES)') 3787 CALL DPWRST('XXX','BUG ') 3788 WRITE(ICOUT,1482)IHOLD 3789 1482 FORMAT('HAS JUST BEEN SET TO ',A4) 3790 CALL DPWRST('XXX','BUG ') 3791 1489 CONTINUE 3792 GOTO1900 3793C 3794 1499 CONTINUE 3795C 3796C ************************************************************** 3797C ** TREAT THE CASE WHEN ** 3798C ** ONLY THE LEFT VERTICAL TIC MARKS ARE TO BE CHANGED ** 3799C ************************************************************** 3800C 3801 IF(ICOM.EQ.'Y1TI')GOTO1500 3802 GOTO1599 3803C 3804 1500 CONTINUE 3805 IF(IHARG(NUMARG).EQ.'ON')GOTO1550 3806 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 3807 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 3808 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 3809 IF(IHARG(NUMARG).EQ.'CASE')GOTO1550 3810 GOTO1560 3811C 3812 1550 CONTINUE 3813 IHOLD=IDEFCA 3814 GOTO1580 3815C 3816 1560 CONTINUE 3817 IHOLD=IHARG(NUMARG) 3818 GOTO1580 3819C 3820 1580 CONTINUE 3821 IFOUND='YES' 3822 IY1ZCA=IHOLD 3823C 3824 IF(IFEEDB.EQ.'OFF')GOTO1589 3825 WRITE(ICOUT,999) 3826 CALL DPWRST('XXX','BUG ') 3827 WRITE(ICOUT,1581) 3828 1581 FORMAT('THE TIC MARK LABEL CASE (FOR THE LEFT VERTICAL ', 3829 1'FRAME LINE)') 3830 CALL DPWRST('XXX','BUG ') 3831 WRITE(ICOUT,1582)IHOLD 3832 1582 FORMAT('HAS JUST BEEN SET TO ',A4) 3833 CALL DPWRST('XXX','BUG ') 3834 1589 CONTINUE 3835 GOTO1900 3836C 3837 1599 CONTINUE 3838C 3839C ************************************************************** 3840C ** TREAT THE CASE WHEN ** 3841C ** ONLY THE RIGHT VERTICAL TIC MARKS ARE TO BE CHANGED ** 3842C ************************************************************** 3843C 3844 IF(ICOM.EQ.'Y2TI')GOTO1600 3845 GOTO1699 3846C 3847 1600 CONTINUE 3848 IF(IHARG(NUMARG).EQ.'ON')GOTO1650 3849 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 3850 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 3851 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 3852 IF(IHARG(NUMARG).EQ.'CASE')GOTO1650 3853 GOTO1660 3854C 3855 1650 CONTINUE 3856 IHOLD=IDEFCA 3857 GOTO1680 3858C 3859 1660 CONTINUE 3860 IHOLD=IHARG(NUMARG) 3861 GOTO1680 3862C 3863 1680 CONTINUE 3864 IFOUND='YES' 3865 IY2ZCA=IHOLD 3866C 3867 IF(IFEEDB.EQ.'OFF')GOTO1689 3868 WRITE(ICOUT,999) 3869 CALL DPWRST('XXX','BUG ') 3870 WRITE(ICOUT,1681) 3871 1681 FORMAT('THE TIC MARK LABEL CASE (FOR THE RIGHT VERTICAL ', 3872 1'FRAME LINE)') 3873 CALL DPWRST('XXX','BUG ') 3874 WRITE(ICOUT,1682)IHOLD 3875 1682 FORMAT('HAS JUST BEEN SET TO ',A4) 3876 CALL DPWRST('XXX','BUG ') 3877 1689 CONTINUE 3878 GOTO1900 3879C 3880 1699 CONTINUE 3881C 3882C ***************************************************** 3883C ** TREAT THE CASE WHEN ** 3884C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 3885C ***************************************************** 3886C 3887 IF(ICOM.EQ.'TIC')GOTO1700 3888 IF(ICOM.EQ.'TICS')GOTO1700 3889 IF(ICOM.EQ.'XYTI')GOTO1700 3890 IF(ICOM.EQ.'YXTI')GOTO1700 3891 GOTO1799 3892C 3893 1700 CONTINUE 3894 IF(IHARG(NUMARG).EQ.'ON')GOTO1750 3895 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 3896 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 3897 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 3898 IF(IHARG(NUMARG).EQ.'CASE')GOTO1750 3899 GOTO1760 3900C 3901 1750 CONTINUE 3902 IHOLD=IDEFCA 3903 GOTO1780 3904C 3905 1760 CONTINUE 3906 IHOLD=IHARG(NUMARG) 3907 GOTO1780 3908C 3909 1780 CONTINUE 3910 IFOUND='YES' 3911 IX1ZCA=IHOLD 3912 IX2ZCA=IHOLD 3913 IY1ZCA=IHOLD 3914 IY2ZCA=IHOLD 3915C 3916 IF(IFEEDB.EQ.'OFF')GOTO1789 3917 WRITE(ICOUT,999) 3918 CALL DPWRST('XXX','BUG ') 3919 WRITE(ICOUT,1781) 3920 1781 FORMAT('THE TIC MARK LABEL CASE (FOR ALL 4 ', 3921 1'FRAME LINES)') 3922 CALL DPWRST('XXX','BUG ') 3923 WRITE(ICOUT,1782)IHOLD 3924 1782 FORMAT('HAS JUST BEEN SET TO ',A4) 3925 CALL DPWRST('XXX','BUG ') 3926 1789 CONTINUE 3927 GOTO1900 3928C 3929 1799 CONTINUE 3930C 3931 1900 CONTINUE 3932 RETURN 3933 END 3934 SUBROUTINE DPTLCL(ICOM,IHARG,NUMARG, 3935 1IDEFCO, 3936 1IX1ZCO,IX2ZCO,IY1ZCO,IY2ZCO, 3937 1IFOUND,IERROR) 3938C 3939C PURPOSE--DEFINE THE 4 TIC LABEL COLORS CONTAINED IN THE 3940C 4 VARIABLES IX1ZCO,IX2ZCO,IY1ZCO,IY2ZCO 3941C SUCH TIC LABEL COLORS DEFINE THE COLORS FOR 3942C THE TIC LABELS ON THE 4 FRAME LINES OF A PLOT. 3943C INPUT ARGUMENTS--ICOM 3944C --IHARG (A HOLLERITH VECTOR) 3945C --NUMARG 3946C --IDEFCO 3947C OUTPUT ARGUMENTS-- 3948C --IX1ZCO = LOWER HORIZONTAL TIC LABEL COLOR 3949C --IX2ZCO = UPPER HORIZONTAL TIC LABEL COLOR 3950C --IY1ZCO = LEFT VERTICAL TIC LABEL COLOR 3951C --IY2ZCO = RIGHT VERTICAL TIC LABEL COLOR 3952C --IFOUND ('YES' OR 'NO' ) 3953C --IERROR ('YES' OR 'NO' ) 3954C WRITTEN BY--JAMES J. FILLIBEN 3955C STATISTICAL ENGINEERING DIVISION 3956C INFORMATION TECHNOLOGY LABORATORY 3957C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 3958C GAITHERSBURG, MD 20899-8980 3959C PHONE--301-975-2855 3960C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 3961C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 3962C LANGUAGE--ANSI FORTRAN (1977) 3963C VERSION NUMBER--82/7 3964C ORIGINAL VERSION--SEPTEMBER 1980. 3965C UPDATED --MARCH 1981. 3966C UPDATED --MAY 1982. 3967C 3968C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 3969C 3970 CHARACTER*4 ICOM 3971 CHARACTER*4 IHARG 3972C 3973 CHARACTER*4 IDEFCO 3974C 3975 CHARACTER*4 IX1ZCO 3976 CHARACTER*4 IX2ZCO 3977 CHARACTER*4 IY1ZCO 3978 CHARACTER*4 IY2ZCO 3979C 3980 CHARACTER*4 IFOUND 3981 CHARACTER*4 IERROR 3982C 3983 CHARACTER*4 IHOLD 3984C 3985C--------------------------------------------------------------------- 3986C 3987 DIMENSION IHARG(*) 3988C 3989C-----COMMON---------------------------------------------------------- 3990C 3991 INCLUDE 'DPCOP2.INC' 3992C 3993C-----START POINT----------------------------------------------------- 3994C 3995 IFOUND='NO' 3996 IERROR='NO' 3997C 3998 IF(NUMARG.LE.1)GOTO1900 3999 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 4000 1IHARG(2).EQ.'COLO')GOTO1090 4001 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 4002 1IHARG(2).EQ.'LABE'.AND.IHARG(3).EQ.'COLO')GOTO1090 4003 GOTO1900 4004 1090 CONTINUE 4005C 4006C ***************************************************** 4007C ** TREAT THE CASE WHEN ** 4008C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 4009C ***************************************************** 4010C 4011 IF(ICOM.EQ.'XTIC')GOTO1100 4012 GOTO1199 4013C 4014 1100 CONTINUE 4015 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 4016 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 4017 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 4018 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 4019 IF(IHARG(NUMARG).EQ.'COLO')GOTO1150 4020 GOTO1160 4021C 4022 1150 CONTINUE 4023 IHOLD=IDEFCO 4024 GOTO1180 4025C 4026 1160 CONTINUE 4027 IHOLD=IHARG(NUMARG) 4028 GOTO1180 4029C 4030 1180 CONTINUE 4031 IFOUND='YES' 4032 IX1ZCO=IHOLD 4033 IX2ZCO=IHOLD 4034C 4035 IF(IFEEDB.EQ.'OFF')GOTO1189 4036 WRITE(ICOUT,999) 4037 999 FORMAT(1X) 4038 CALL DPWRST('XXX','BUG ') 4039 WRITE(ICOUT,1181) 4040 1181 FORMAT('THE TIC MARK LABEL COLOR (FOR BOTH HORIZONTAL ', 4041 1'FRAME LINES)') 4042 CALL DPWRST('XXX','BUG ') 4043 WRITE(ICOUT,1182)IHOLD 4044 1182 FORMAT('HAS JUST BEEN SET TO ',A4) 4045 CALL DPWRST('XXX','BUG ') 4046 1189 CONTINUE 4047 GOTO1900 4048C 4049 1199 CONTINUE 4050C 4051C ************************************************************** 4052C ** TREAT THE CASE WHEN ** 4053C ** ONLY THE BOTTOM HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 4054C ************************************************************** 4055C 4056 IF(ICOM.EQ.'X1TI')GOTO1200 4057 GOTO1299 4058C 4059 1200 CONTINUE 4060 IF(IHARG(NUMARG).EQ.'ON')GOTO1250 4061 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 4062 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 4063 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 4064 IF(IHARG(NUMARG).EQ.'COLO')GOTO1250 4065 GOTO1260 4066C 4067 1250 CONTINUE 4068 IHOLD=IDEFCO 4069 GOTO1280 4070C 4071 1260 CONTINUE 4072 IHOLD=IHARG(NUMARG) 4073 GOTO1280 4074C 4075 1280 CONTINUE 4076 IFOUND='YES' 4077 IX1ZCO=IHOLD 4078C 4079 IF(IFEEDB.EQ.'OFF')GOTO1289 4080 WRITE(ICOUT,999) 4081 CALL DPWRST('XXX','BUG ') 4082 WRITE(ICOUT,1281) 4083 1281 FORMAT('THE TIC MARK LABEL COLOR (FOR THE BOTTOM ', 4084 1'HORIZONTAL FRAME LINE)') 4085 CALL DPWRST('XXX','BUG ') 4086 WRITE(ICOUT,1282)IHOLD 4087 1282 FORMAT('HAS JUST BEEN SET TO ',A4) 4088 CALL DPWRST('XXX','BUG ') 4089 1289 CONTINUE 4090 GOTO1900 4091C 4092 1299 CONTINUE 4093C 4094C ************************************************************** 4095C ** TREAT THE CASE WHEN ** 4096C ** ONLY THE TOP HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 4097C ************************************************************** 4098C 4099 IF(ICOM.EQ.'X2TI')GOTO1300 4100 GOTO1399 4101C 4102 1300 CONTINUE 4103 IF(IHARG(NUMARG).EQ.'ON')GOTO1350 4104 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 4105 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 4106 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 4107 IF(IHARG(NUMARG).EQ.'COLO')GOTO1350 4108 GOTO1360 4109C 4110 1350 CONTINUE 4111 IHOLD=IDEFCO 4112 GOTO1380 4113C 4114 1360 CONTINUE 4115 IHOLD=IHARG(NUMARG) 4116 GOTO1380 4117C 4118 1380 CONTINUE 4119 IFOUND='YES' 4120 IX2ZCO=IHOLD 4121C 4122 IF(IFEEDB.EQ.'OFF')GOTO1389 4123 WRITE(ICOUT,999) 4124 CALL DPWRST('XXX','BUG ') 4125 WRITE(ICOUT,1381) 4126 1381 FORMAT('THE TIC MARK LABEL COLOR (FOR THE TOP HORIZONTAL ', 4127 1'FRAME LINE)') 4128 CALL DPWRST('XXX','BUG ') 4129 WRITE(ICOUT,1382)IHOLD 4130 1382 FORMAT('HAS JUST BEEN SET TO ',A4) 4131 CALL DPWRST('XXX','BUG ') 4132 1389 CONTINUE 4133 GOTO1900 4134C 4135 1399 CONTINUE 4136C 4137C ***************************************************** 4138C ** TREAT THE CASE WHEN ** 4139C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 4140C ***************************************************** 4141C 4142 IF(ICOM.EQ.'YTIC')GOTO1400 4143 GOTO1499 4144C 4145 1400 CONTINUE 4146 IF(IHARG(NUMARG).EQ.'ON')GOTO1450 4147 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 4148 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 4149 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 4150 IF(IHARG(NUMARG).EQ.'COLO')GOTO1450 4151 GOTO1460 4152C 4153 1450 CONTINUE 4154 IHOLD=IDEFCO 4155 GOTO1480 4156C 4157 1460 CONTINUE 4158 IHOLD=IHARG(NUMARG) 4159 GOTO1480 4160C 4161 1480 CONTINUE 4162 IFOUND='YES' 4163 IY1ZCO=IHOLD 4164 IY2ZCO=IHOLD 4165C 4166 IF(IFEEDB.EQ.'OFF')GOTO1489 4167 WRITE(ICOUT,999) 4168 CALL DPWRST('XXX','BUG ') 4169 WRITE(ICOUT,1481) 4170 1481 FORMAT('THE TIC MARK LABEL COLOR (FOR BOTH VERTICAL ', 4171 1'FRAME LINES)') 4172 CALL DPWRST('XXX','BUG ') 4173 WRITE(ICOUT,1482)IHOLD 4174 1482 FORMAT('HAS JUST BEEN SET TO ',A4) 4175 CALL DPWRST('XXX','BUG ') 4176 1489 CONTINUE 4177 GOTO1900 4178C 4179 1499 CONTINUE 4180C 4181C ************************************************************** 4182C ** TREAT THE CASE WHEN ** 4183C ** ONLY THE LEFT VERTICAL TIC MARKS ARE TO BE CHANGED ** 4184C ************************************************************** 4185C 4186 IF(ICOM.EQ.'Y1TI')GOTO1500 4187 GOTO1599 4188C 4189 1500 CONTINUE 4190 IF(IHARG(NUMARG).EQ.'ON')GOTO1550 4191 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 4192 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 4193 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 4194 IF(IHARG(NUMARG).EQ.'COLO')GOTO1550 4195 GOTO1560 4196C 4197 1550 CONTINUE 4198 IHOLD=IDEFCO 4199 GOTO1580 4200C 4201 1560 CONTINUE 4202 IHOLD=IHARG(NUMARG) 4203 GOTO1580 4204C 4205 1580 CONTINUE 4206 IFOUND='YES' 4207 IY1ZCO=IHOLD 4208C 4209 IF(IFEEDB.EQ.'OFF')GOTO1589 4210 WRITE(ICOUT,999) 4211 CALL DPWRST('XXX','BUG ') 4212 WRITE(ICOUT,1581) 4213 1581 FORMAT('THE TIC MARK LABEL COLOR (FOR THE LEFT VERTICAL ', 4214 1'FRAME LINE)') 4215 CALL DPWRST('XXX','BUG ') 4216 WRITE(ICOUT,1582)IHOLD 4217 1582 FORMAT('HAS JUST BEEN SET TO ',A4) 4218 CALL DPWRST('XXX','BUG ') 4219 1589 CONTINUE 4220 GOTO1900 4221C 4222 1599 CONTINUE 4223C 4224C ************************************************************** 4225C ** TREAT THE CASE WHEN ** 4226C ** ONLY THE RIGHT VERTICAL TIC MARKS ARE TO BE CHANGED ** 4227C ************************************************************** 4228C 4229 IF(ICOM.EQ.'Y2TI')GOTO1600 4230 GOTO1699 4231C 4232 1600 CONTINUE 4233 IF(IHARG(NUMARG).EQ.'ON')GOTO1650 4234 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 4235 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 4236 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 4237 IF(IHARG(NUMARG).EQ.'COLO')GOTO1650 4238 GOTO1660 4239C 4240 1650 CONTINUE 4241 IHOLD=IDEFCO 4242 GOTO1680 4243C 4244 1660 CONTINUE 4245 IHOLD=IHARG(NUMARG) 4246 GOTO1680 4247C 4248 1680 CONTINUE 4249 IFOUND='YES' 4250 IY2ZCO=IHOLD 4251C 4252 IF(IFEEDB.EQ.'OFF')GOTO1689 4253 WRITE(ICOUT,999) 4254 CALL DPWRST('XXX','BUG ') 4255 WRITE(ICOUT,1681) 4256 1681 FORMAT('THE TIC MARK LABEL COLOR (FOR THE RIGHT VERTICAL ', 4257 1'FRAME LINE)') 4258 CALL DPWRST('XXX','BUG ') 4259 WRITE(ICOUT,1682)IHOLD 4260 1682 FORMAT('HAS JUST BEEN SET TO ',A4) 4261 CALL DPWRST('XXX','BUG ') 4262 1689 CONTINUE 4263 GOTO1900 4264C 4265 1699 CONTINUE 4266C 4267C ***************************************************** 4268C ** TREAT THE CASE WHEN ** 4269C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 4270C ***************************************************** 4271C 4272 IF(ICOM.EQ.'TIC')GOTO1700 4273 IF(ICOM.EQ.'TICS')GOTO1700 4274 IF(ICOM.EQ.'XYTI')GOTO1700 4275 IF(ICOM.EQ.'YXTI')GOTO1700 4276 GOTO1799 4277C 4278 1700 CONTINUE 4279 IF(IHARG(NUMARG).EQ.'ON')GOTO1750 4280 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 4281 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 4282 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 4283 IF(IHARG(NUMARG).EQ.'COLO')GOTO1750 4284 GOTO1760 4285C 4286 1750 CONTINUE 4287 IHOLD=IDEFCO 4288 GOTO1780 4289C 4290 1760 CONTINUE 4291 IHOLD=IHARG(NUMARG) 4292 GOTO1780 4293C 4294 1780 CONTINUE 4295 IFOUND='YES' 4296 IX1ZCO=IHOLD 4297 IX2ZCO=IHOLD 4298 IY1ZCO=IHOLD 4299 IY2ZCO=IHOLD 4300C 4301 IF(IFEEDB.EQ.'OFF')GOTO1789 4302 WRITE(ICOUT,999) 4303 CALL DPWRST('XXX','BUG ') 4304 WRITE(ICOUT,1781) 4305 1781 FORMAT('THE TIC MARK LABEL COLOR (FOR ALL 4 ', 4306 1'FRAME LINES)') 4307 CALL DPWRST('XXX','BUG ') 4308 WRITE(ICOUT,1782)IHOLD 4309 1782 FORMAT('HAS JUST BEEN SET TO ',A4) 4310 CALL DPWRST('XXX','BUG ') 4311 1789 CONTINUE 4312 GOTO1900 4313C 4314 1799 CONTINUE 4315C 4316 1900 CONTINUE 4317 RETURN 4318 END 4319 SUBROUTINE DPTLCN(ICOM,IHARG,NUMARG, 4320CCCCC THE FOLLOWING LINE WAS CHANGED SEPTEMBER 1993 4321CCCCC TO ALLOW FOR LOWER CASE SEPTEMBER 1993 4322CCCCC1 IANS,IWIDTH, 4323 1 IANS,IANSLC,IWIDTH, 4324 1 IX1ZCN,IX2ZCN,IY1ZCN,IY2ZCN, 4325 1 IFOUND,IERROR) 4326C 4327C PURPOSE--DEFINE THE 4 TIC LABEL CONTENTS CONTAINED IN THE 4328C 4 VARIABLES IX1ZCN,IX2ZCN,IY1ZCN,IY2ZCN 4329C SUCH TIC LABEL CONTENTS DEFINE THE CONTENTS FOR 4330C THE TIC LABELS ON THE 4 FRAME LINES OF A PLOT. 4331C INPUT ARGUMENTS--ICOM 4332C --IHARG (A HOLLERITH VECTOR) 4333C --NUMARG 4334C OUTPUT ARGUMENTS-- 4335C --IX1ZCN = LOWER HORIZONTAL TIC LABEL CONTENTS 4336C --IX2ZCN = UPPER HORIZONTAL TIC LABEL CONTENTS 4337C --IY1ZCN = LEFT VERTICAL TIC LABEL CONTENTS 4338C --IY2ZCN = RIGHT VERTICAL TIC LABEL CONTENTS 4339C --IFOUND ('YES' OR 'NO' ) 4340C --IERROR ('YES' OR 'NO' ) 4341C WRITTEN BY--JAMES J. FILLIBEN 4342C STATISTICAL ENGINEERING DIVISION 4343C INFORMATION TECHNOLOGY LABORATORY 4344C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 4345C GAITHERSBURG, MD 20899-8980 4346C PHONE--301-975-2855 4347C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 4348C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 4349C LANGUAGE--ANSI FORTRAN (1977) 4350C VERSION NUMBER--88/2 4351C ORIGINAL VERSION--JANUARY 1988. 4352C UPDATED --AUGUST 2001. UPDATE DIMENSIONS FROM 130 4353C TO 160 4354C UPDATED --SEPTEMBER 2014. UPDATE DIMENSIONS FROM 512 TO 4355C 2048 4356C UPDATED --APRIL 2017. SOME RECODING FOR BETTER READABILITY 4357C 4358C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 4359C 4360 CHARACTER*4 IANS 4361CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1993 4362CCCCC TO ALLOW FOR LOWER CASE SEPTEMBER 1993 4363 CHARACTER*4 IANSLC 4364C 4365 CHARACTER*4 ICOM 4366 CHARACTER*4 IHARG 4367C 4368 CHARACTER*2048 IHOLCN 4369 CHARACTER*2048 ICJUNK 4370C 4371 CHARACTER*2048 IX1ZCN 4372 CHARACTER*2048 IX2ZCN 4373 CHARACTER*2048 IY1ZCN 4374 CHARACTER*2048 IY2ZCN 4375C 4376 CHARACTER*4 IFOUND 4377 CHARACTER*4 IERROR 4378C 4379C--------------------------------------------------------------------- 4380C 4381 DIMENSION IHARG(*) 4382C 4383 DIMENSION IANS(*) 4384CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1993 4385CCCCC TO ALLOW FOR LOWER CASE SEPTEMBER 1993 4386 DIMENSION IANSLC(*) 4387C 4388C-----COMMON---------------------------------------------------------- 4389C 4390 INCLUDE 'DPCOP2.INC' 4391C 4392C-----START POINT----------------------------------------------------- 4393C 4394 IFOUND='NO' 4395 IERROR='NO' 4396C 4397 IF(NUMARG.LE.1)GOTO9000 4398 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 4399 1 IHARG(2).EQ.'CONT')GOTO1009 4400 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 4401 1 IHARG(2).EQ.'LABE'.AND.IHARG(3).EQ.'CONT')GOTO1009 4402 GOTO9000 4403 1009 CONTINUE 4404C 4405C ************************************ 4406C ** EXTRACT THE FULL STRING ** 4407C ************************************ 4408C 4409 DO1010I=1,IWIDTH-6 4410 I2=I 4411 IF(IANS(I).EQ.'C'.AND.IANS(I+1).EQ.'O'.AND. 4412 1 IANS(I+2).EQ.'N'.AND.IANS(I+3).EQ.'T'.AND. 4413 1 IANS(I+4).EQ.'E'.AND.IANS(I+5).EQ.'N'.AND. 4414 1 IANS(I+6).EQ.'T')THEN 4415 IFOUND='YES' 4416 ISTART=I+8 4417 IF(IANS(I+7).EQ.'S')ISTART=ISTART+1 4418 GOTO1019 4419 ENDIF 4420 1010 CONTINUE 4421C 4422 WRITE(ICOUT,1011) 4423 1011 FORMAT('***** ERROR IN TIC MARK LABEL CONTENT--') 4424 CALL DPWRST('XXX','BUG ') 4425 WRITE(ICOUT,1012) 4426 1012 FORMAT(' NO MATCH FOR COMMAND.') 4427 CALL DPWRST('XXX','BUG ') 4428 IERROR='YES' 4429 GOTO9000 4430C 4431 1019 CONTINUE 4432C 4433 ISTOP=0 4434 IF(ISTART.GT.IWIDTH)GOTO1039 4435 DO1030I=ISTART,IWIDTH 4436 IREV=IWIDTH-I+ISTART 4437 IF(IANS(IREV).NE.' ')THEN 4438 ISTOP=IREV 4439 GOTO1039 4440 ENDIF 4441 1030 CONTINUE 4442 1039 CONTINUE 4443C 4444 ICJUNK=' ' 4445 NCJUNK=0 4446 IF(ISTART.LE.ISTOP .AND. ISTOP.GT.0)THEN 4447 J=0 4448 DO1040I=ISTART,ISTOP 4449 J=J+1 4450CCCCC THE FOLLOWING LINE WAS CHANGED SEPTEMBER 1993 4451CCCCC TO ALLOW FOR LOWER CASE SEPTEMBER 1993 4452CCCCC ICJUNK(J:J)=IANS(I) 4453 ICJUNK(J:J)=IANSLC(I) 4454 1040 CONTINUE 4455 NCJUNK=J 4456 ENDIF 4457C 4458C ***************************************************** 4459C ** TREAT THE CASE WHEN ** 4460C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 4461C ***************************************************** 4462C 4463 IF(ICOM.EQ.'XTIC')THEN 4464 IF(IHARG(NUMARG).EQ.'ON' .OR. IHARG(NUMARG).EQ.'OFF' .OR. 4465 1 IHARG(NUMARG).EQ.'AUTO' .OR. IHARG(NUMARG).EQ.'DEFA' .OR. 4466 1 IHARG(NUMARG).EQ.'CONT')THEN 4467 IHOLCN='DEFAULT' 4468 ELSE 4469 IHOLCN=ICJUNK 4470 ENDIF 4471C 4472 IFOUND='YES' 4473 IX1ZCN=IHOLCN 4474 IX2ZCN=IHOLCN 4475C 4476 IF(IFEEDB.EQ.'ON')THEN 4477 WRITE(ICOUT,999) 4478 999 FORMAT(1X) 4479 CALL DPWRST('XXX','BUG ') 4480 WRITE(ICOUT,1181) 4481 1181 FORMAT('THE TIC MARK LABEL CONTENTS FOR BOTH HORIZONTAL') 4482 CALL DPWRST('XXX','BUG ') 4483 WRITE(ICOUT,1183) 4484 1183 FORMAT('FRAME LINES HAS JUST BEEN SET TO') 4485 CALL DPWRST('XXX','BUG ') 4486 IF(NCJUNK.LE.0)THEN 4487 WRITE(ICOUT,1185) 4488 1185 FORMAT('FLOAT WITH THE DATA.') 4489 CALL DPWRST('XXX','BUG ') 4490 ELSE 4491 WRITE(ICOUT,1184)(IHOLCN(I:I),I=1,MIN(80,NCJUNK)) 4492 1184 FORMAT(80A1) 4493 CALL DPWRST('XXX','BUG ') 4494 IF(NCJUNK.GE.81)THEN 4495 WRITE(ICOUT,1184)(IHOLCN(I:I),I=81,MIN(160,NCJUNK)) 4496 CALL DPWRST('XXX','BUG ') 4497 ENDIF 4498 IF(NCJUNK.GE.161)THEN 4499 WRITE(ICOUT,1184)(IHOLCN(I:I),I=161,MIN(240,NCJUNK)) 4500 CALL DPWRST('XXX','BUG ') 4501 ENDIF 4502 ENDIF 4503 ENDIF 4504 GOTO9000 4505 ENDIF 4506C 4507C ****************************************************** 4508C ** TREAT THE CASE WHEN ** 4509C ** ONLY THE BOTTOM HORIZONTAL TIC MARKS ARE TO BE ** 4510C ** CHANGED ** 4511C ****************************************************** 4512C 4513 IF(ICOM.EQ.'X1TI')THEN 4514 IF(IHARG(NUMARG).EQ.'ON' .OR. IHARG(NUMARG).EQ.'OFF' .OR. 4515 1 IHARG(NUMARG).EQ.'AUTO' .OR. IHARG(NUMARG).EQ.'DEFA' .OR. 4516 1 IHARG(NUMARG).EQ.'CONT')THEN 4517 IHOLCN='DEFAULT' 4518 ELSE 4519 IHOLCN=ICJUNK 4520 ENDIF 4521 IFOUND='YES' 4522 IX1ZCN=IHOLCN 4523C 4524 IF(IFEEDB.EQ.'ON')THEN 4525 WRITE(ICOUT,999) 4526 CALL DPWRST('XXX','BUG ') 4527 WRITE(ICOUT,1281) 4528 1281 FORMAT('THE TIC MARK LABEL CONTENTS FOR THE BOTTOM ', 4529 1 'HORIZONTAL') 4530 CALL DPWRST('XXX','BUG ') 4531 WRITE(ICOUT,1283) 4532 1283 FORMAT('FRAME LINE HAS JUST BEEN SET TO') 4533 CALL DPWRST('XXX','BUG ') 4534 IF(NCJUNK.LE.0)THEN 4535 WRITE(ICOUT,1185) 4536 CALL DPWRST('XXX','BUG ') 4537 ELSE 4538 WRITE(ICOUT,1184)(IHOLCN(I:I),I=1,MIN(80,NCJUNK)) 4539 CALL DPWRST('XXX','BUG ') 4540 IF(NCJUNK.GE.81)THEN 4541 WRITE(ICOUT,1184)(IHOLCN(I:I),I=81,MIN(160,NCJUNK)) 4542 CALL DPWRST('XXX','BUG ') 4543 ENDIF 4544 IF(NCJUNK.GE.161)THEN 4545 WRITE(ICOUT,1184)(IHOLCN(I:I),I=161,MIN(NCJUNK,240)) 4546 CALL DPWRST('XXX','BUG ') 4547 ENDIF 4548 ENDIF 4549 ENDIF 4550 GOTO9000 4551 ENDIF 4552C 4553C ************************************************************** 4554C ** TREAT THE CASE WHEN ** 4555C ** ONLY THE TOP HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 4556C ************************************************************** 4557C 4558 IF(ICOM.EQ.'X2TI')THEN 4559 IF(IHARG(NUMARG).EQ.'ON' .OR. IHARG(NUMARG).EQ.'OFF' .OR. 4560 1 IHARG(NUMARG).EQ.'AUTO' .OR. IHARG(NUMARG).EQ.'DEFA' .OR. 4561 1 IHARG(NUMARG).EQ.'CONT')THEN 4562 IHOLCN='DEFAULT' 4563 ELSE 4564 IHOLCN=ICJUNK 4565 ENDIF 4566 IFOUND='YES' 4567 IX2ZCN=IHOLCN 4568C 4569 IF(IFEEDB.EQ.'ON')THEN 4570 WRITE(ICOUT,999) 4571 CALL DPWRST('XXX','BUG ') 4572 WRITE(ICOUT,1381) 4573 1381 FORMAT('THE TIC MARK LABEL CONTENTS FOR THE TOP HORIZONTAL') 4574 CALL DPWRST('XXX','BUG ') 4575 WRITE(ICOUT,1383) 4576 1383 FORMAT('FRAME LINE HAS JUST BEEN SET TO') 4577 CALL DPWRST('XXX','BUG ') 4578 IF(NCJUNK.LE.0)THEN 4579 WRITE(ICOUT,1185) 4580 CALL DPWRST('XXX','BUG ') 4581 ELSE 4582 WRITE(ICOUT,1184)(IHOLCN(I:I),I=1,MIN(80,NCJUNK)) 4583 CALL DPWRST('XXX','BUG ') 4584 IF(NCJUNK.GE.81)THEN 4585 WRITE(ICOUT,1184)(IHOLCN(I:I),I=81,MIN(160,NCJUNK)) 4586 CALL DPWRST('XXX','BUG ') 4587 ENDIF 4588 IF(NCJUNK.GE.161)THEN 4589 WRITE(ICOUT,1184)(IHOLCN(I:I),I=161,MIN(240,NCJUNK)) 4590 CALL DPWRST('XXX','BUG ') 4591 ENDIF 4592 ENDIF 4593 ENDIF 4594 GOTO9000 4595 ENDIF 4596C 4597C ***************************************************** 4598C ** TREAT THE CASE WHEN ** 4599C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 4600C ***************************************************** 4601C 4602 IF(ICOM.EQ.'YTIC')THEN 4603 IF(IHARG(NUMARG).EQ.'ON' .OR. IHARG(NUMARG).EQ.'OFF' .OR. 4604 1 IHARG(NUMARG).EQ.'AUTO' .OR. IHARG(NUMARG).EQ.'DEFA' .OR. 4605 1 IHARG(NUMARG).EQ.'CONT')THEN 4606 IHOLCN='DEFAULT' 4607 ELSE 4608 IHOLCN=ICJUNK 4609 ENDIF 4610 IFOUND='YES' 4611 IY1ZCN=IHOLCN 4612 IY2ZCN=IHOLCN 4613C 4614 IF(IFEEDB.EQ.'ON')THEN 4615 WRITE(ICOUT,999) 4616 CALL DPWRST('XXX','BUG ') 4617 WRITE(ICOUT,1481) 4618 1481 FORMAT('THE TIC MARK LABEL CONTENTS FOR BOTH VERTICAL') 4619 CALL DPWRST('XXX','BUG ') 4620 WRITE(ICOUT,1483) 4621 1483 FORMAT('FRAME LINES HAS JUST BEEN SET TO') 4622 CALL DPWRST('XXX','BUG ') 4623 IF(NCJUNK.LE.0)THEN 4624 WRITE(ICOUT,1185) 4625 CALL DPWRST('XXX','BUG ') 4626 ELSE 4627 WRITE(ICOUT,1184)(IHOLCN(I:I),I=1,MIN(80,NCJUNK)) 4628 CALL DPWRST('XXX','BUG ') 4629 IF(NCJUNK.GE.81)THEN 4630 WRITE(ICOUT,1184)(IHOLCN(I:I),I=81,MIN(160,NCJUNK)) 4631 CALL DPWRST('XXX','BUG ') 4632 ENDIF 4633 IF(NCJUNK.GE.161)THEN 4634 WRITE(ICOUT,1184)(IHOLCN(I:I),I=161,MIN(240,NCJUNK)) 4635 CALL DPWRST('XXX','BUG ') 4636 ENDIF 4637 ENDIF 4638 ENDIF 4639 GOTO9000 4640 ENDIF 4641C 4642C ************************************************************** 4643C ** TREAT THE CASE WHEN ** 4644C ** ONLY THE LEFT VERTICAL TIC MARKS ARE TO BE CHANGED ** 4645C ************************************************************** 4646C 4647 IF(ICOM.EQ.'Y1TI')THEN 4648 IF(IHARG(NUMARG).EQ.'ON' .OR. IHARG(NUMARG).EQ.'OFF' .OR. 4649 1 IHARG(NUMARG).EQ.'AUTO' .OR. IHARG(NUMARG).EQ.'DEFA' .OR. 4650 1 IHARG(NUMARG).EQ.'CONT')THEN 4651 IHOLCN='DEFAULT' 4652 ELSE 4653 IHOLCN=ICJUNK 4654 ENDIF 4655 IFOUND='YES' 4656 IY1ZCN=IHOLCN 4657C 4658 IF(IFEEDB.EQ.'ON')THEN 4659 WRITE(ICOUT,999) 4660 CALL DPWRST('XXX','BUG ') 4661 WRITE(ICOUT,1581) 4662 1581 FORMAT('THE TIC MARK LABEL CONTENTS FOR THE LEFT VERTICAL') 4663 CALL DPWRST('XXX','BUG ') 4664 WRITE(ICOUT,1583) 4665 1583 FORMAT('FRAME LINE HAS JUST BEEN SET TO') 4666 CALL DPWRST('XXX','BUG ') 4667 IF(NCJUNK.LE.0)THEN 4668 WRITE(ICOUT,1185) 4669 CALL DPWRST('XXX','BUG ') 4670 ELSE 4671 WRITE(ICOUT,1184)(IHOLCN(I:I),I=1,MIN(80,NCJUNK)) 4672 CALL DPWRST('XXX','BUG ') 4673 IF(NCJUNK.GE.81)THEN 4674 WRITE(ICOUT,1184)(IHOLCN(I:I),I=81,MIN(160,NCJUNK)) 4675 CALL DPWRST('XXX','BUG ') 4676 ENDIF 4677 IF(NCJUNK.GE.161)THEN 4678 WRITE(ICOUT,1184)(IHOLCN(I:I),I=161,MIN(240,NCJUNK)) 4679 CALL DPWRST('XXX','BUG ') 4680 ENDIF 4681 ENDIF 4682 ENDIF 4683 GOTO9000 4684 ENDIF 4685C 4686C ************************************************************** 4687C ** TREAT THE CASE WHEN ** 4688C ** ONLY THE RIGHT VERTICAL TIC MARKS ARE TO BE CHANGED ** 4689C ************************************************************** 4690C 4691 IF(ICOM.EQ.'Y2TI')THEN 4692 IF(IHARG(NUMARG).EQ.'ON' .OR. IHARG(NUMARG).EQ.'OFF' .OR. 4693 1 IHARG(NUMARG).EQ.'AUTO' .OR. IHARG(NUMARG).EQ.'DEFA' .OR. 4694 1 IHARG(NUMARG).EQ.'CONT')THEN 4695 IHOLCN='DEFAULT' 4696 ELSE 4697 IHOLCN=ICJUNK 4698 ENDIF 4699 IFOUND='YES' 4700 IY2ZCN=IHOLCN 4701C 4702 IF(IFEEDB.EQ.'ON')THEN 4703 WRITE(ICOUT,999) 4704 CALL DPWRST('XXX','BUG ') 4705 WRITE(ICOUT,1681) 4706 1681 FORMAT('THE TIC MARK LABEL CONTENTS OR THE RIGHT VERTICAL') 4707 CALL DPWRST('XXX','BUG ') 4708 WRITE(ICOUT,1683) 4709 1683 FORMAT('FRAME LINE HAS JUST BEEN SET TO') 4710 CALL DPWRST('XXX','BUG ') 4711 IF(NCJUNK.LE.0)THEN 4712 WRITE(ICOUT,1185) 4713 CALL DPWRST('XXX','BUG ') 4714 ELSE 4715 WRITE(ICOUT,1184)(IHOLCN(I:I),I=1,MIN(80,NCJUNK)) 4716 CALL DPWRST('XXX','BUG ') 4717 IF(NCJUNK.GE.81)THEN 4718 WRITE(ICOUT,1184)(IHOLCN(I:I),I=81,MIN(160,NCJUNK)) 4719 CALL DPWRST('XXX','BUG ') 4720 ENDIF 4721 IF(NCJUNK.GE.161)THEN 4722 WRITE(ICOUT,1184)(IHOLCN(I:I),I=161,MIN(240,NCJUNK)) 4723 CALL DPWRST('XXX','BUG ') 4724 ENDIF 4725 ENDIF 4726 ENDIF 4727 GOTO9000 4728 ENDIF 4729C 4730C ***************************************************** 4731C ** TREAT THE CASE WHEN ** 4732C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 4733C ***************************************************** 4734C 4735 IF(ICOM.EQ.'TIC' .OR. ICOM.EQ.'TICS' .OR. 4736 1 ICOM.EQ.'XYTI' .OR. ICOM.EQ.'YXTI')THEN 4737 IF(IHARG(NUMARG).EQ.'ON' .OR. IHARG(NUMARG).EQ.'OFF' .OR. 4738 1 IHARG(NUMARG).EQ.'AUTO' .OR. IHARG(NUMARG).EQ.'DEFA' .OR. 4739 1 IHARG(NUMARG).EQ.'CONT')THEN 4740 IHOLCN='DEFAULT' 4741 ELSE 4742 IHOLCN=ICJUNK 4743 ENDIF 4744 IFOUND='YES' 4745 IX1ZCN=IHOLCN 4746 IX2ZCN=IHOLCN 4747 IY1ZCN=IHOLCN 4748 IY2ZCN=IHOLCN 4749C 4750 IF(IFEEDB.EQ.'ON')THEN 4751 WRITE(ICOUT,999) 4752 CALL DPWRST('XXX','BUG ') 4753 WRITE(ICOUT,1781) 4754 1781 FORMAT('THE TIC MARK LABEL CONTENTS FOR ALL 4 FRAME LINES') 4755 CALL DPWRST('XXX','BUG ') 4756 WRITE(ICOUT,1783) 4757 1783 FORMAT('HAVE JUST BEEN SET TO') 4758 CALL DPWRST('XXX','BUG ') 4759 IF(NCJUNK.LE.0)THEN 4760 WRITE(ICOUT,1185) 4761 CALL DPWRST('XXX','BUG ') 4762 ELSE 4763 WRITE(ICOUT,1184)(IHOLCN(I:I),I=1,MIN(80,NCJUNK)) 4764 CALL DPWRST('XXX','BUG ') 4765 IF(NCJUNK.GE.81)THEN 4766 WRITE(ICOUT,1184)(IHOLCN(I:I),I=81,MIN(160,NCJUNK)) 4767 CALL DPWRST('XXX','BUG ') 4768 ENDIF 4769 IF(NCJUNK.GE.161)THEN 4770 WRITE(ICOUT,1184)(IHOLCN(I:I),I=161,MIN(240,NCJUNK)) 4771 CALL DPWRST('XXX','BUG ') 4772 ENDIF 4773 ENDIF 4774 ENDIF 4775 GOTO9000 4776 ENDIF 4777C 4778 9000 CONTINUE 4779 RETURN 4780 END 4781 SUBROUTINE DPTLDI(ICOM,IHARG,NUMARG, 4782 1IDEFDI, 4783 1IX1ZDI,IX2ZDI,IY1ZDI,IY2ZDI, 4784 1IFOUND,IERROR) 4785C 4786C PURPOSE--DEFINE THE 4 TIC LABEL DIRECTIONS CONTAINED IN THE 4787C 4 VARIABLES IX1ZDI,IX2ZDI,IY1ZDI,IY2ZDI 4788C SUCH TIC LABEL DIRECTIONS DEFINE THE DIRECTIONS FOR 4789C THE TIC LABELS ON THE 4 FRAME LINES OF A PLOT. 4790C INPUT ARGUMENTS--ICOM 4791C --IHARG (A HOLLERITH VECTOR) 4792C --NUMARG 4793C --IDEFDI 4794C OUTPUT ARGUMENTS-- 4795C --IX1ZDI = LOWER HORIZONTAL TIC LABEL DIRECTION 4796C --IX2ZDI = UPPER HORIZONTAL TIC LABEL DIRECTION 4797C --IY1ZDI = LEFT VERTICAL TIC LABEL DIRECTION 4798C --IY2ZDI = RIGHT VERTICAL TIC LABEL DIRECTION 4799C --IFOUND ('YES' OR 'NO' ) 4800C --IERROR ('YES' OR 'NO' ) 4801C WRITTEN BY--ALAN HECKERT 4802C COMPUTER SERVICES DIVISION 4803C INFORMATION TECHNOLOGY LABORATORY 4804C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 4805C GAITHERSBURG, MD 20899-8980 4806C PHONE--301-975-2899 4807C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 4808C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 4809C LANGUAGE--ANSI FORTRAN (1977) 4810C VERSION NUMBER--89/2 4811C ORIGINAL VERSION--JANUARY 1989. 4812C 4813C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 4814C 4815 CHARACTER*4 ICOM 4816 CHARACTER*4 IHARG 4817C 4818 CHARACTER*4 IDEFDI 4819C 4820 CHARACTER*4 IX1ZDI 4821 CHARACTER*4 IX2ZDI 4822 CHARACTER*4 IY1ZDI 4823 CHARACTER*4 IY2ZDI 4824C 4825 CHARACTER*4 IFOUND 4826 CHARACTER*4 IERROR 4827C 4828 CHARACTER*4 IHOLD 4829C 4830C--------------------------------------------------------------------- 4831C 4832 DIMENSION IHARG(*) 4833C 4834C-----COMMON---------------------------------------------------------- 4835C 4836 INCLUDE 'DPCOP2.INC' 4837C 4838C-----START POINT----------------------------------------------------- 4839C 4840 IFOUND='NO' 4841 IERROR='NO' 4842C 4843 IF(NUMARG.LE.1)GOTO1900 4844 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 4845 1IHARG(2).EQ.'DIRE')GOTO1090 4846 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 4847 1IHARG(2).EQ.'LABE'.AND.IHARG(3).EQ.'DIRE')GOTO1090 4848 GOTO1900 4849 1090 CONTINUE 4850C 4851C ***************************************************** 4852C ** TREAT THE CASE WHEN ** 4853C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 4854C ***************************************************** 4855C 4856 IF(ICOM.EQ.'XTIC')GOTO1100 4857 GOTO1199 4858C 4859 1100 CONTINUE 4860 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 4861 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 4862 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 4863 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 4864 IF(IHARG(NUMARG).EQ.'DIRE')GOTO1150 4865 GOTO1160 4866C 4867 1150 CONTINUE 4868 IHOLD=IDEFDI 4869 GOTO1180 4870C 4871 1160 CONTINUE 4872 IHOLD=IHARG(NUMARG) 4873 GOTO1180 4874C 4875 1180 CONTINUE 4876 IFOUND='YES' 4877 IX1ZDI=IHOLD 4878 IX2ZDI=IHOLD 4879C 4880 IF(IFEEDB.EQ.'OFF')GOTO1189 4881 WRITE(ICOUT,999) 4882 999 FORMAT(1X) 4883 CALL DPWRST('XXX','BUG ') 4884 WRITE(ICOUT,1181) 4885 1181 FORMAT('THE TIC MARK LABEL DIRECTION (FOR BOTH HORIZONTAL ', 4886 1'FRAME LINES)') 4887 CALL DPWRST('XXX','BUG ') 4888 WRITE(ICOUT,1182)IHOLD 4889 1182 FORMAT('HAS JUST BEEN SET TO ',A4) 4890 CALL DPWRST('XXX','BUG ') 4891 1189 CONTINUE 4892 GOTO1900 4893C 4894 1199 CONTINUE 4895C 4896C ************************************************************** 4897C ** TREAT THE CASE WHEN ** 4898C ** ONLY THE BOTTOM HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 4899C ************************************************************** 4900C 4901 IF(ICOM.EQ.'X1TI')GOTO1200 4902 GOTO1299 4903C 4904 1200 CONTINUE 4905 IF(IHARG(NUMARG).EQ.'ON')GOTO1250 4906 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 4907 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 4908 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 4909 IF(IHARG(NUMARG).EQ.'DIRE')GOTO1250 4910 GOTO1260 4911C 4912 1250 CONTINUE 4913 IHOLD=IDEFDI 4914 GOTO1280 4915C 4916 1260 CONTINUE 4917 IHOLD=IHARG(NUMARG) 4918 GOTO1280 4919C 4920 1280 CONTINUE 4921 IFOUND='YES' 4922 IX1ZDI=IHOLD 4923C 4924 IF(IFEEDB.EQ.'OFF')GOTO1289 4925 WRITE(ICOUT,999) 4926 CALL DPWRST('XXX','BUG ') 4927 WRITE(ICOUT,1281) 4928 1281 FORMAT('THE TIC MARK LABEL DIRECTION (FOR THE BOTTOM ', 4929 1'HORIZONTAL FRAME LINE)') 4930 CALL DPWRST('XXX','BUG ') 4931 WRITE(ICOUT,1282)IHOLD 4932 1282 FORMAT('HAS JUST BEEN SET TO ',A4) 4933 CALL DPWRST('XXX','BUG ') 4934 1289 CONTINUE 4935 GOTO1900 4936C 4937 1299 CONTINUE 4938C 4939C ************************************************************** 4940C ** TREAT THE CASE WHEN ** 4941C ** ONLY THE TOP HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 4942C ************************************************************** 4943C 4944 IF(ICOM.EQ.'X2TI')GOTO1300 4945 GOTO1399 4946C 4947 1300 CONTINUE 4948 IF(IHARG(NUMARG).EQ.'ON')GOTO1350 4949 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 4950 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 4951 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 4952 IF(IHARG(NUMARG).EQ.'DIRE')GOTO1350 4953 GOTO1360 4954C 4955 1350 CONTINUE 4956 IHOLD=IDEFDI 4957 GOTO1380 4958C 4959 1360 CONTINUE 4960 IHOLD=IHARG(NUMARG) 4961 GOTO1380 4962C 4963 1380 CONTINUE 4964 IFOUND='YES' 4965 IX2ZDI=IHOLD 4966C 4967 IF(IFEEDB.EQ.'OFF')GOTO1389 4968 WRITE(ICOUT,999) 4969 CALL DPWRST('XXX','BUG ') 4970 WRITE(ICOUT,1381) 4971 1381 FORMAT('THE TIC MARK LABEL DIRECTION (FOR THE TOP HORIZONTAL ', 4972 1'FRAME LINE)') 4973 CALL DPWRST('XXX','BUG ') 4974 WRITE(ICOUT,1382)IHOLD 4975 1382 FORMAT('HAS JUST BEEN SET TO ',A4) 4976 CALL DPWRST('XXX','BUG ') 4977 1389 CONTINUE 4978 GOTO1900 4979C 4980 1399 CONTINUE 4981C 4982C ***************************************************** 4983C ** TREAT THE CASE WHEN ** 4984C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 4985C ***************************************************** 4986C 4987 IF(ICOM.EQ.'YTIC')GOTO1400 4988 GOTO1499 4989C 4990 1400 CONTINUE 4991 IF(IHARG(NUMARG).EQ.'ON')GOTO1450 4992 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 4993 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 4994 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 4995 IF(IHARG(NUMARG).EQ.'DIRE')GOTO1450 4996 GOTO1460 4997C 4998 1450 CONTINUE 4999 IHOLD=IDEFDI 5000 GOTO1480 5001C 5002 1460 CONTINUE 5003 IHOLD=IHARG(NUMARG) 5004 GOTO1480 5005C 5006 1480 CONTINUE 5007 IFOUND='YES' 5008 IY1ZDI=IHOLD 5009 IY2ZDI=IHOLD 5010C 5011 IF(IFEEDB.EQ.'OFF')GOTO1489 5012 WRITE(ICOUT,999) 5013 CALL DPWRST('XXX','BUG ') 5014 WRITE(ICOUT,1481) 5015 1481 FORMAT('THE TIC MARK LABEL DIRECTION (FOR BOTH VERTICAL ', 5016 1'FRAME LINES)') 5017 CALL DPWRST('XXX','BUG ') 5018 WRITE(ICOUT,1482)IHOLD 5019 1482 FORMAT('HAS JUST BEEN SET TO ',A4) 5020 CALL DPWRST('XXX','BUG ') 5021 1489 CONTINUE 5022 GOTO1900 5023C 5024 1499 CONTINUE 5025C 5026C ************************************************************** 5027C ** TREAT THE CASE WHEN ** 5028C ** ONLY THE LEFT VERTICAL TIC MARKS ARE TO BE CHANGED ** 5029C ************************************************************** 5030C 5031 IF(ICOM.EQ.'Y1TI')GOTO1500 5032 GOTO1599 5033C 5034 1500 CONTINUE 5035 IF(IHARG(NUMARG).EQ.'ON')GOTO1550 5036 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 5037 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 5038 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 5039 IF(IHARG(NUMARG).EQ.'DIRE')GOTO1550 5040 GOTO1560 5041C 5042 1550 CONTINUE 5043 IHOLD=IDEFDI 5044 GOTO1580 5045C 5046 1560 CONTINUE 5047 IHOLD=IHARG(NUMARG) 5048 GOTO1580 5049C 5050 1580 CONTINUE 5051 IFOUND='YES' 5052 IY1ZDI=IHOLD 5053C 5054 IF(IFEEDB.EQ.'OFF')GOTO1589 5055 WRITE(ICOUT,999) 5056 CALL DPWRST('XXX','BUG ') 5057 WRITE(ICOUT,1581) 5058 1581 FORMAT('THE TIC MARK LABEL DIRECTION (FOR THE LEFT VERTICAL ', 5059 1'FRAME LINE)') 5060 CALL DPWRST('XXX','BUG ') 5061 WRITE(ICOUT,1582)IHOLD 5062 1582 FORMAT('HAS JUST BEEN SET TO ',A4) 5063 CALL DPWRST('XXX','BUG ') 5064 1589 CONTINUE 5065 GOTO1900 5066C 5067 1599 CONTINUE 5068C 5069C ************************************************************** 5070C ** TREAT THE CASE WHEN ** 5071C ** ONLY THE RIGHT VERTICAL TIC MARKS ARE TO BE CHANGED ** 5072C ************************************************************** 5073C 5074 IF(ICOM.EQ.'Y2TI')GOTO1600 5075 GOTO1699 5076C 5077 1600 CONTINUE 5078 IF(IHARG(NUMARG).EQ.'ON')GOTO1650 5079 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 5080 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 5081 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 5082 IF(IHARG(NUMARG).EQ.'DIRE')GOTO1650 5083 GOTO1660 5084C 5085 1650 CONTINUE 5086 IHOLD=IDEFDI 5087 GOTO1680 5088C 5089 1660 CONTINUE 5090 IHOLD=IHARG(NUMARG) 5091 GOTO1680 5092C 5093 1680 CONTINUE 5094 IFOUND='YES' 5095 IY2ZDI=IHOLD 5096C 5097 IF(IFEEDB.EQ.'OFF')GOTO1689 5098 WRITE(ICOUT,999) 5099 CALL DPWRST('XXX','BUG ') 5100 WRITE(ICOUT,1681) 5101 1681 FORMAT('THE TIC MARK LABEL DIRECTION (FOR THE RIGHT VERTICAL ', 5102 1'FRAME LINE)') 5103 CALL DPWRST('XXX','BUG ') 5104 WRITE(ICOUT,1682)IHOLD 5105 1682 FORMAT('HAS JUST BEEN SET TO ',A4) 5106 CALL DPWRST('XXX','BUG ') 5107 1689 CONTINUE 5108 GOTO1900 5109C 5110 1699 CONTINUE 5111C 5112C ***************************************************** 5113C ** TREAT THE CASE WHEN ** 5114C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 5115C ***************************************************** 5116C 5117 IF(ICOM.EQ.'TIC')GOTO1700 5118 IF(ICOM.EQ.'TICS')GOTO1700 5119 IF(ICOM.EQ.'XYTI')GOTO1700 5120 IF(ICOM.EQ.'YXTI')GOTO1700 5121 GOTO1799 5122C 5123 1700 CONTINUE 5124 IF(IHARG(NUMARG).EQ.'ON')GOTO1750 5125 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 5126 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 5127 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 5128 IF(IHARG(NUMARG).EQ.'DIRE')GOTO1750 5129 GOTO1760 5130C 5131 1750 CONTINUE 5132 IHOLD=IDEFDI 5133 GOTO1780 5134C 5135 1760 CONTINUE 5136 IHOLD=IHARG(NUMARG) 5137 GOTO1780 5138C 5139 1780 CONTINUE 5140 IFOUND='YES' 5141 IX1ZDI=IHOLD 5142 IX2ZDI=IHOLD 5143 IY1ZDI=IHOLD 5144 IY2ZDI=IHOLD 5145C 5146 IF(IFEEDB.EQ.'OFF')GOTO1789 5147 WRITE(ICOUT,999) 5148 CALL DPWRST('XXX','BUG ') 5149 WRITE(ICOUT,1781) 5150 1781 FORMAT('THE TIC MARK LABEL DIRECTION (FOR ALL 4 ', 5151 1'FRAME LINES)') 5152 CALL DPWRST('XXX','BUG ') 5153 WRITE(ICOUT,1782)IHOLD 5154 1782 FORMAT('HAS JUST BEEN SET TO ',A4) 5155 CALL DPWRST('XXX','BUG ') 5156 1789 CONTINUE 5157 GOTO1900 5158C 5159 1799 CONTINUE 5160C 5161 1900 CONTINUE 5162 RETURN 5163 END 5164 SUBROUTINE DPTLDS(ICOM,IHARG,IARGT,ARG,NUMARG, 5165 1PDEFHG,PDEFVG, 5166 1PX1ZDS,PX2ZDS,PY1ZDS,PY2ZDS, 5167 1IFOUND,IERROR) 5168C 5169C PURPOSE--DEFINE THE TIC MARK LABEL DISPLACEMENT SWITCHES 5170C FOR ANY OF THE 4 FRAME LINES. 5171C SUCH TIC MARK SWITCHES DEFINE THE DISPLACEMENT 5172C OF THE TIC MARK LABELS ON THE 4 FRAME LINES OF A PLOT. 5173C INPUT ARGUMENTS--ICOM 5174C --IHARG (A HOLLERITH VECTOR) 5175C --IARGT (A HOLLERITH VECTOR) 5176C --ARG (A FLOATING POINT VECTOR) 5177C --NUMARG 5178C --PDEFHG 5179C --PDEFVG 5180C OUTPUT ARGUMENTS-- 5181C --PX1ZDS, 5182C --PX2ZDS, 5183C --PY1ZDS, 5184C --PY2ZDS, 5185C --IFOUND ('YES' OR 'NO' ) 5186C --IERROR ('YES' OR 'NO' ) 5187C WRITTEN BY--JAMES J. FILLIBEN 5188C STATISTICAL ENGINEERING DIVISION 5189C INFORMATION TECHNOLOGY LABORATORY 5190C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5191C GAITHERSBURG, MD 20899-8980 5192C PHONE--301-975-2855 5193C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5194C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5195C LANGUAGE--ANSI FORTRAN (1977) 5196C VERSION NUMBER--91/9 5197C ORIGINAL VERSION--AUGUST 1991. 5198C 5199C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5200C 5201 CHARACTER*4 ICOM 5202 CHARACTER*4 IHARG 5203 CHARACTER*4 IARGT 5204 CHARACTER*4 IFOUND 5205 CHARACTER*4 IERROR 5206C 5207C--------------------------------------------------------------------- 5208C 5209 DIMENSION IHARG(*) 5210 DIMENSION IARGT(*) 5211 DIMENSION ARG(*) 5212C 5213C-----COMMON---------------------------------------------------------- 5214C 5215 INCLUDE 'DPCOP2.INC' 5216C 5217C-----START POINT----------------------------------------------------- 5218C 5219 IFOUND='NO' 5220 IERROR='NO' 5221C 5222CCCCC IF(NUMARG.LE.1)GOTO1900 5223 IF(NUMARG.LE.1)GOTO9000 5224 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 5225 1IHARG(2).EQ.'DISP')GOTO1090 5226 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 5227 1IHARG(2).EQ.'LABE'.AND.IHARG(3).EQ.'DISP')GOTO1090 5228 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 5229 1IHARG(2).EQ.'OFFS')GOTO1090 5230 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 5231 1IHARG(2).EQ.'LABE'.AND.IHARG(3).EQ.'OFFS')GOTO1090 5232 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 5233 1IHARG(2).EQ.'GAP')GOTO1090 5234 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 5235 1IHARG(2).EQ.'LABE'.AND.IHARG(3).EQ.'GAP')GOTO1090 5236CCCCC GOTO1900 5237 GOTO9000 5238 1090 CONTINUE 5239 HOLD1=(-999.9) 5240 HOLD2=(-999.9) 5241C 5242C ***************************************************** 5243C ** TREAT THE CASE WHEN ** 5244C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 5245C ***************************************************** 5246C 5247 IF(ICOM.EQ.'XTIC')GOTO1100 5248 GOTO1199 5249C 5250 1100 CONTINUE 5251 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 5252 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 5253 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 5254 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 5255 IF(IHARG(NUMARG).EQ.'DISP')GOTO1150 5256 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 5257 IERROR='YES' 5258 GOTO9000 5259C 5260 1150 CONTINUE 5261 HOLD1=PDEFHG 5262 GOTO1180 5263C 5264 1160 CONTINUE 5265 HOLD1=ARG(NUMARG) 5266 GOTO1180 5267C 5268 1180 CONTINUE 5269 IFOUND='YES' 5270 PX1ZDS=HOLD1 5271 PX2ZDS=HOLD1 5272C 5273 IF(IFEEDB.EQ.'OFF')GOTO1189 5274 WRITE(ICOUT,999) 5275 999 FORMAT(1X) 5276 CALL DPWRST('XXX','BUG ') 5277 WRITE(ICOUT,1181) 5278 1181 FORMAT('THE TIC MARK LABEL DISPLACEMENT') 5279 CALL DPWRST('XXX','BUG ') 5280 WRITE(ICOUT,1182) 5281 1182 FORMAT('(FOR BOTH HORIZONTAL FRAME LINES)') 5282 CALL DPWRST('XXX','BUG ') 5283 WRITE(ICOUT,1183)HOLD1 5284 1183 FORMAT('HAS JUST BEEN SET TO ',E15.7) 5285 CALL DPWRST('XXX','BUG ') 5286 1189 CONTINUE 5287 GOTO1900 5288C 5289 1199 CONTINUE 5290C 5291C ************************************************************** 5292C ** TREAT THE CASE WHEN ** 5293C ** ONLY THE BOTTOM HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 5294C ************************************************************** 5295C 5296 IF(ICOM.EQ.'X1TI')GOTO1200 5297 GOTO1299 5298C 5299 1200 CONTINUE 5300 IF(IHARG(NUMARG).EQ.'ON')GOTO1250 5301 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 5302 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 5303 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 5304 IF(IHARG(NUMARG).EQ.'DISP')GOTO1250 5305 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1260 5306 IERROR='YES' 5307 GOTO9000 5308C 5309 1250 CONTINUE 5310 HOLD1=PDEFHG 5311 GOTO1280 5312C 5313 1260 CONTINUE 5314 HOLD1=ARG(NUMARG) 5315 GOTO1280 5316C 5317 1280 CONTINUE 5318 IFOUND='YES' 5319 PX1ZDS=HOLD1 5320C 5321 IF(IFEEDB.EQ.'OFF')GOTO1289 5322 WRITE(ICOUT,999) 5323 CALL DPWRST('XXX','BUG ') 5324 WRITE(ICOUT,1181) 5325 CALL DPWRST('XXX','BUG ') 5326 WRITE(ICOUT,1282) 5327 1282 FORMAT('(FOR THE BOTTOM HORIZONTAL FRAME LINE)') 5328 CALL DPWRST('XXX','BUG ') 5329 WRITE(ICOUT,1183)HOLD1 5330 CALL DPWRST('XXX','BUG ') 5331 1289 CONTINUE 5332 GOTO1900 5333C 5334 1299 CONTINUE 5335C 5336C ************************************************************** 5337C ** TREAT THE CASE WHEN ** 5338C ** ONLY THE TOP HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 5339C ************************************************************** 5340C 5341 IF(ICOM.EQ.'X2TI')GOTO1300 5342 GOTO1399 5343C 5344 1300 CONTINUE 5345 IF(IHARG(NUMARG).EQ.'ON')GOTO1350 5346 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 5347 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 5348 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 5349 IF(IHARG(NUMARG).EQ.'DISP')GOTO1350 5350 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1360 5351 IERROR='YES' 5352 GOTO9000 5353C 5354 1350 CONTINUE 5355 HOLD1=PDEFHG 5356 GOTO1380 5357C 5358 1360 CONTINUE 5359 HOLD1=ARG(NUMARG) 5360 GOTO1380 5361C 5362 1380 CONTINUE 5363 IFOUND='YES' 5364 PX2ZDS=HOLD1 5365C 5366 IF(IFEEDB.EQ.'OFF')GOTO1389 5367 WRITE(ICOUT,999) 5368 CALL DPWRST('XXX','BUG ') 5369 WRITE(ICOUT,1181) 5370 CALL DPWRST('XXX','BUG ') 5371 WRITE(ICOUT,1382) 5372 1382 FORMAT('(FOR THE TOP HORIZONTAL FRAME LINE)') 5373 CALL DPWRST('XXX','BUG ') 5374 WRITE(ICOUT,1183)HOLD1 5375 CALL DPWRST('XXX','BUG ') 5376 1389 CONTINUE 5377 GOTO1900 5378C 5379 1399 CONTINUE 5380C 5381C ***************************************************** 5382C ** TREAT THE CASE WHEN ** 5383C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 5384C ***************************************************** 5385C 5386 IF(ICOM.EQ.'YTIC')GOTO1400 5387 GOTO1499 5388C 5389 1400 CONTINUE 5390 IF(IHARG(NUMARG).EQ.'ON')GOTO1450 5391 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 5392 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 5393 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 5394 IF(IHARG(NUMARG).EQ.'DISP')GOTO1450 5395 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1460 5396 IERROR='YES' 5397 GOTO9000 5398C 5399 1450 CONTINUE 5400 HOLD1=PDEFVG 5401 GOTO1480 5402C 5403 1460 CONTINUE 5404 HOLD1=ARG(NUMARG) 5405 GOTO1480 5406C 5407 1480 CONTINUE 5408 IFOUND='YES' 5409 PY1ZDS=HOLD1 5410 PY2ZDS=HOLD1 5411C 5412 IF(IFEEDB.EQ.'OFF')GOTO1489 5413 WRITE(ICOUT,999) 5414 CALL DPWRST('XXX','BUG ') 5415 WRITE(ICOUT,1181) 5416 CALL DPWRST('XXX','BUG ') 5417 WRITE(ICOUT,1482) 5418 1482 FORMAT('(FOR BOTH VERTICAL FRAME LINES)') 5419 CALL DPWRST('XXX','BUG ') 5420 WRITE(ICOUT,1183)HOLD1 5421 CALL DPWRST('XXX','BUG ') 5422 1489 CONTINUE 5423 GOTO1900 5424C 5425 1499 CONTINUE 5426C 5427C ************************************************************** 5428C ** TREAT THE CASE WHEN ** 5429C ** ONLY THE LEFT VERTICAL TIC MARKS ARE TO BE CHANGED ** 5430C ************************************************************** 5431C 5432 IF(ICOM.EQ.'Y1TI')GOTO1500 5433 GOTO1599 5434C 5435 1500 CONTINUE 5436 IF(IHARG(NUMARG).EQ.'ON')GOTO1550 5437 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 5438 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 5439 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 5440 IF(IHARG(NUMARG).EQ.'DISP')GOTO1550 5441 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1560 5442 IERROR='YES' 5443 GOTO9000 5444C 5445 1550 CONTINUE 5446 HOLD1=PDEFVG 5447 GOTO1580 5448C 5449 1560 CONTINUE 5450 HOLD1=ARG(NUMARG) 5451 GOTO1580 5452C 5453 1580 CONTINUE 5454 IFOUND='YES' 5455 PY1ZDS=HOLD1 5456C 5457 IF(IFEEDB.EQ.'OFF')GOTO1589 5458 WRITE(ICOUT,999) 5459 CALL DPWRST('XXX','BUG ') 5460 WRITE(ICOUT,1181) 5461 CALL DPWRST('XXX','BUG ') 5462 WRITE(ICOUT,1582) 5463 1582 FORMAT('(FOR THE LEFT VERTICAL FRAME LINE)') 5464 CALL DPWRST('XXX','BUG ') 5465 WRITE(ICOUT,1183)HOLD1 5466 CALL DPWRST('XXX','BUG ') 5467 1589 CONTINUE 5468 GOTO1900 5469C 5470 1599 CONTINUE 5471C 5472C ************************************************************** 5473C ** TREAT THE CASE WHEN ** 5474C ** ONLY THE RIGHT VERTICAL TIC MARKS ARE TO BE CHANGED ** 5475C ************************************************************** 5476C 5477 IF(ICOM.EQ.'Y2TI')GOTO1600 5478 GOTO1699 5479C 5480 1600 CONTINUE 5481 IF(IHARG(NUMARG).EQ.'ON')GOTO1650 5482 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 5483 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 5484 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 5485 IF(IHARG(NUMARG).EQ.'DISP')GOTO1650 5486 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1660 5487 IERROR='YES' 5488 GOTO9000 5489C 5490 1650 CONTINUE 5491 HOLD1=PDEFVG 5492 GOTO1680 5493C 5494 1660 CONTINUE 5495 HOLD1=ARG(NUMARG) 5496 GOTO1680 5497C 5498 1680 CONTINUE 5499 IFOUND='YES' 5500 PY2ZDS=HOLD1 5501C 5502 IF(IFEEDB.EQ.'OFF')GOTO1689 5503 WRITE(ICOUT,999) 5504 CALL DPWRST('XXX','BUG ') 5505 WRITE(ICOUT,1181) 5506 CALL DPWRST('XXX','BUG ') 5507 WRITE(ICOUT,1682) 5508 1682 FORMAT('(FOR THE RIGHT VERTICAL FRAME LINE)') 5509 CALL DPWRST('XXX','BUG ') 5510 WRITE(ICOUT,1183)HOLD1 5511 CALL DPWRST('XXX','BUG ') 5512 1689 CONTINUE 5513 GOTO1900 5514C 5515 1699 CONTINUE 5516C 5517C ***************************************************** 5518C ** TREAT THE CASE WHEN ** 5519C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 5520C ***************************************************** 5521C 5522 IF(ICOM.EQ.'TIC')GOTO1700 5523 IF(ICOM.EQ.'TICS')GOTO1700 5524 IF(ICOM.EQ.'XYTI')GOTO1700 5525 IF(ICOM.EQ.'YXTI')GOTO1700 5526 GOTO1799 5527C 5528 1700 CONTINUE 5529 IF(IHARG(NUMARG).EQ.'ON')GOTO1750 5530 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 5531 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 5532 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 5533 IF(IHARG(NUMARG).EQ.'DISP')GOTO1750 5534 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1760 5535 IERROR='YES' 5536 GOTO9000 5537C 5538 1750 CONTINUE 5539 HOLD1=PDEFHG 5540 HOLD2=PDEFVG 5541 GOTO1780 5542C 5543 1760 CONTINUE 5544 HOLD1=ARG(NUMARG) 5545 HOLD2=ARG(NUMARG) 5546 GOTO1780 5547C 5548 1780 CONTINUE 5549 IFOUND='YES' 5550 PX1ZDS=HOLD1 5551 PX2ZDS=HOLD1 5552 PY1ZDS=HOLD2 5553 PY2ZDS=HOLD2 5554C 5555 IF(IFEEDB.EQ.'OFF')GOTO1789 5556 WRITE(ICOUT,999) 5557 CALL DPWRST('XXX','BUG ') 5558 WRITE(ICOUT,1181) 5559 CALL DPWRST('XXX','BUG ') 5560 WRITE(ICOUT,1782) 5561 1782 FORMAT('(FOR BOTH HORIZONTAL FRAME LINES)') 5562 CALL DPWRST('XXX','BUG ') 5563 WRITE(ICOUT,1183)HOLD1 5564 CALL DPWRST('XXX','BUG ') 5565 WRITE(ICOUT,1181) 5566 CALL DPWRST('XXX','BUG ') 5567 WRITE(ICOUT,1784) 5568 1784 FORMAT('(FOR BOTH VERTICAL FRAME LINES)') 5569 CALL DPWRST('XXX','BUG ') 5570 WRITE(ICOUT,1183)HOLD2 5571 CALL DPWRST('XXX','BUG ') 5572 1789 CONTINUE 5573 GOTO1900 5574C 5575 1799 CONTINUE 5576C 5577 1900 CONTINUE 5578C 5579 GOTO9000 5580C 5581 9000 CONTINUE 5582 RETURN 5583 END 5584 SUBROUTINE DPTLFI(ICOM,IHARG,NUMARG, 5585 1IDEFFI, 5586 1IX1ZFI,IX2ZFI,IY1ZFI,IY2ZFI, 5587 1IFOUND,IERROR) 5588C 5589C PURPOSE--DEFINE THE 4 TIC LABEL FILLS CONTAINED IN THE 5590C 4 VARIABLES IX1ZFI,IX2ZFI,IY1ZFI,IY2ZFI 5591C SUCH TIC LABEL FILLS DEFINE THE FILLS FOR 5592C THE TIC LABELS ON THE 4 FRAME LINES OF A PLOT. 5593C INPUT ARGUMENTS--ICOM 5594C --IHARG (A HOLLERITH VECTOR) 5595C --NUMARG 5596C --IDEFFI 5597C OUTPUT ARGUMENTS-- 5598C --IX1ZFI = LOWER HORIZONTAL TIC LABEL FILL 5599C --IX2ZFI = UPPER HORIZONTAL TIC LABEL FILL 5600C --IY1ZFI = LEFT VERTICAL TIC LABEL FILL 5601C --IY2ZFI = RIGHT VERTICAL TIC LABEL FILL 5602C --IFOUND ('YES' OR 'NO' ) 5603C --IERROR ('YES' OR 'NO' ) 5604C WRITTEN BY--ALAN HECKERT 5605C COMPUTER SERVICES DIVISION 5606C INFORMATION TECHNOLOGY LABORATORY 5607C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5608C GAITHERSBURG, MD 20899-8980 5609C PHONE--301-975-2899 5610C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5611C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5612C LANGUAGE--ANSI FORTRAN (1977) 5613C VERSION NUMBER--89/2 5614C ORIGINAL VERSION--JANUARY 1989. 5615C 5616C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5617C 5618 CHARACTER*4 ICOM 5619 CHARACTER*4 IHARG 5620C 5621 CHARACTER*4 IDEFFI 5622C 5623 CHARACTER*4 IX1ZFI 5624 CHARACTER*4 IX2ZFI 5625 CHARACTER*4 IY1ZFI 5626 CHARACTER*4 IY2ZFI 5627C 5628 CHARACTER*4 IFOUND 5629 CHARACTER*4 IERROR 5630C 5631 CHARACTER*4 IHOLD 5632C 5633C--------------------------------------------------------------------- 5634C 5635 DIMENSION IHARG(*) 5636C 5637C-----COMMON---------------------------------------------------------- 5638C 5639 INCLUDE 'DPCOP2.INC' 5640C 5641C-----START POINT----------------------------------------------------- 5642C 5643 IFOUND='NO' 5644 IERROR='NO' 5645C 5646 IF(NUMARG.LE.1)GOTO1900 5647 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 5648 1IHARG(2).EQ.'FILL')GOTO1090 5649 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 5650 1IHARG(2).EQ.'LABE'.AND.IHARG(3).EQ.'FILL')GOTO1090 5651 GOTO1900 5652 1090 CONTINUE 5653C 5654C ***************************************************** 5655C ** TREAT THE CASE WHEN ** 5656C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 5657C ***************************************************** 5658C 5659 IF(ICOM.EQ.'XTIC')GOTO1100 5660 GOTO1199 5661C 5662 1100 CONTINUE 5663 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 5664 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 5665 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 5666 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 5667 IF(IHARG(NUMARG).EQ.'FILL')GOTO1150 5668 GOTO1160 5669C 5670 1150 CONTINUE 5671 IHOLD=IDEFFI 5672 GOTO1180 5673C 5674 1160 CONTINUE 5675 IHOLD=IHARG(NUMARG) 5676 GOTO1180 5677C 5678 1180 CONTINUE 5679 IFOUND='YES' 5680 IX1ZFI=IHOLD 5681 IX2ZFI=IHOLD 5682C 5683 IF(IFEEDB.EQ.'OFF')GOTO1189 5684 WRITE(ICOUT,999) 5685 999 FORMAT(1X) 5686 CALL DPWRST('XXX','BUG ') 5687 WRITE(ICOUT,1181) 5688 1181 FORMAT('THE TIC MARK LABEL FILL (FOR BOTH HORIZONTAL ', 5689 1'FRAME LINES)') 5690 CALL DPWRST('XXX','BUG ') 5691 WRITE(ICOUT,1182)IHOLD 5692 1182 FORMAT('HAS JUST BEEN SET TO ',A4) 5693 CALL DPWRST('XXX','BUG ') 5694 1189 CONTINUE 5695 GOTO1900 5696C 5697 1199 CONTINUE 5698C 5699C ************************************************************** 5700C ** TREAT THE CASE WHEN ** 5701C ** ONLY THE BOTTOM HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 5702C ************************************************************** 5703C 5704 IF(ICOM.EQ.'X1TI')GOTO1200 5705 GOTO1299 5706C 5707 1200 CONTINUE 5708 IF(IHARG(NUMARG).EQ.'ON')GOTO1250 5709 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 5710 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 5711 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 5712 IF(IHARG(NUMARG).EQ.'FILL')GOTO1250 5713 GOTO1260 5714C 5715 1250 CONTINUE 5716 IHOLD=IDEFFI 5717 GOTO1280 5718C 5719 1260 CONTINUE 5720 IHOLD=IHARG(NUMARG) 5721 GOTO1280 5722C 5723 1280 CONTINUE 5724 IFOUND='YES' 5725 IX1ZFI=IHOLD 5726C 5727 IF(IFEEDB.EQ.'OFF')GOTO1289 5728 WRITE(ICOUT,999) 5729 CALL DPWRST('XXX','BUG ') 5730 WRITE(ICOUT,1281) 5731 1281 FORMAT('THE TIC MARK LABEL FILL (FOR THE BOTTOM ', 5732 1'HORIZONTAL FRAME LINE)') 5733 CALL DPWRST('XXX','BUG ') 5734 WRITE(ICOUT,1282)IHOLD 5735 1282 FORMAT('HAS JUST BEEN SET TO ',A4) 5736 CALL DPWRST('XXX','BUG ') 5737 1289 CONTINUE 5738 GOTO1900 5739C 5740 1299 CONTINUE 5741C 5742C ************************************************************** 5743C ** TREAT THE CASE WHEN ** 5744C ** ONLY THE TOP HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 5745C ************************************************************** 5746C 5747 IF(ICOM.EQ.'X2TI')GOTO1300 5748 GOTO1399 5749C 5750 1300 CONTINUE 5751 IF(IHARG(NUMARG).EQ.'ON')GOTO1350 5752 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 5753 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 5754 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 5755 IF(IHARG(NUMARG).EQ.'FILL')GOTO1350 5756 GOTO1360 5757C 5758 1350 CONTINUE 5759 IHOLD=IDEFFI 5760 GOTO1380 5761C 5762 1360 CONTINUE 5763 IHOLD=IHARG(NUMARG) 5764 GOTO1380 5765C 5766 1380 CONTINUE 5767 IFOUND='YES' 5768 IX2ZFI=IHOLD 5769C 5770 IF(IFEEDB.EQ.'OFF')GOTO1389 5771 WRITE(ICOUT,999) 5772 CALL DPWRST('XXX','BUG ') 5773 WRITE(ICOUT,1381) 5774 1381 FORMAT('THE TIC MARK LABEL FILL (FOR THE TOP HORIZONTAL ', 5775 1'FRAME LINE)') 5776 CALL DPWRST('XXX','BUG ') 5777 WRITE(ICOUT,1382)IHOLD 5778 1382 FORMAT('HAS JUST BEEN SET TO ',A4) 5779 CALL DPWRST('XXX','BUG ') 5780 1389 CONTINUE 5781 GOTO1900 5782C 5783 1399 CONTINUE 5784C 5785C ***************************************************** 5786C ** TREAT THE CASE WHEN ** 5787C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 5788C ***************************************************** 5789C 5790 IF(ICOM.EQ.'YTIC')GOTO1400 5791 GOTO1499 5792C 5793 1400 CONTINUE 5794 IF(IHARG(NUMARG).EQ.'ON')GOTO1450 5795 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 5796 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 5797 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 5798 IF(IHARG(NUMARG).EQ.'FILL')GOTO1450 5799 GOTO1460 5800C 5801 1450 CONTINUE 5802 IHOLD=IDEFFI 5803 GOTO1480 5804C 5805 1460 CONTINUE 5806 IHOLD=IHARG(NUMARG) 5807 GOTO1480 5808C 5809 1480 CONTINUE 5810 IFOUND='YES' 5811 IY1ZFI=IHOLD 5812 IY2ZFI=IHOLD 5813C 5814 IF(IFEEDB.EQ.'OFF')GOTO1489 5815 WRITE(ICOUT,999) 5816 CALL DPWRST('XXX','BUG ') 5817 WRITE(ICOUT,1481) 5818 1481 FORMAT('THE TIC MARK LABEL FILL (FOR BOTH VERTICAL ', 5819 1'FRAME LINES)') 5820 CALL DPWRST('XXX','BUG ') 5821 WRITE(ICOUT,1482)IHOLD 5822 1482 FORMAT('HAS JUST BEEN SET TO ',A4) 5823 CALL DPWRST('XXX','BUG ') 5824 1489 CONTINUE 5825 GOTO1900 5826C 5827 1499 CONTINUE 5828C 5829C ************************************************************** 5830C ** TREAT THE CASE WHEN ** 5831C ** ONLY THE LEFT VERTICAL TIC MARKS ARE TO BE CHANGED ** 5832C ************************************************************** 5833C 5834 IF(ICOM.EQ.'Y1TI')GOTO1500 5835 GOTO1599 5836C 5837 1500 CONTINUE 5838 IF(IHARG(NUMARG).EQ.'ON')GOTO1550 5839 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 5840 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 5841 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 5842 IF(IHARG(NUMARG).EQ.'FILL')GOTO1550 5843 GOTO1560 5844C 5845 1550 CONTINUE 5846 IHOLD=IDEFFI 5847 GOTO1580 5848C 5849 1560 CONTINUE 5850 IHOLD=IHARG(NUMARG) 5851 GOTO1580 5852C 5853 1580 CONTINUE 5854 IFOUND='YES' 5855 IY1ZFI=IHOLD 5856C 5857 IF(IFEEDB.EQ.'OFF')GOTO1589 5858 WRITE(ICOUT,999) 5859 CALL DPWRST('XXX','BUG ') 5860 WRITE(ICOUT,1581) 5861 1581 FORMAT('THE TIC MARK LABEL FILL (FOR THE LEFT VERTICAL ', 5862 1'FRAME LINE)') 5863 CALL DPWRST('XXX','BUG ') 5864 WRITE(ICOUT,1582)IHOLD 5865 1582 FORMAT('HAS JUST BEEN SET TO ',A4) 5866 CALL DPWRST('XXX','BUG ') 5867 1589 CONTINUE 5868 GOTO1900 5869C 5870 1599 CONTINUE 5871C 5872C ************************************************************** 5873C ** TREAT THE CASE WHEN ** 5874C ** ONLY THE RIGHT VERTICAL TIC MARKS ARE TO BE CHANGED ** 5875C ************************************************************** 5876C 5877 IF(ICOM.EQ.'Y2TI')GOTO1600 5878 GOTO1699 5879C 5880 1600 CONTINUE 5881 IF(IHARG(NUMARG).EQ.'ON')GOTO1650 5882 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 5883 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 5884 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 5885 IF(IHARG(NUMARG).EQ.'FILL')GOTO1650 5886 GOTO1660 5887C 5888 1650 CONTINUE 5889 IHOLD=IDEFFI 5890 GOTO1680 5891C 5892 1660 CONTINUE 5893 IHOLD=IHARG(NUMARG) 5894 GOTO1680 5895C 5896 1680 CONTINUE 5897 IFOUND='YES' 5898 IY2ZFI=IHOLD 5899C 5900 IF(IFEEDB.EQ.'OFF')GOTO1689 5901 WRITE(ICOUT,999) 5902 CALL DPWRST('XXX','BUG ') 5903 WRITE(ICOUT,1681) 5904 1681 FORMAT('THE TIC MARK LABEL FILL (FOR THE RIGHT VERTICAL ', 5905 1'FRAME LINE)') 5906 CALL DPWRST('XXX','BUG ') 5907 WRITE(ICOUT,1682)IHOLD 5908 1682 FORMAT('HAS JUST BEEN SET TO ',A4) 5909 CALL DPWRST('XXX','BUG ') 5910 1689 CONTINUE 5911 GOTO1900 5912C 5913 1699 CONTINUE 5914C 5915C ***************************************************** 5916C ** TREAT THE CASE WHEN ** 5917C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 5918C ***************************************************** 5919C 5920 IF(ICOM.EQ.'TIC')GOTO1700 5921 IF(ICOM.EQ.'TICS')GOTO1700 5922 IF(ICOM.EQ.'XYTI')GOTO1700 5923 IF(ICOM.EQ.'YXTI')GOTO1700 5924 GOTO1799 5925C 5926 1700 CONTINUE 5927 IF(IHARG(NUMARG).EQ.'ON')GOTO1750 5928 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 5929 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 5930 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 5931 IF(IHARG(NUMARG).EQ.'FILL')GOTO1750 5932 GOTO1760 5933C 5934 1750 CONTINUE 5935 IHOLD=IDEFFI 5936 GOTO1780 5937C 5938 1760 CONTINUE 5939 IHOLD=IHARG(NUMARG) 5940 GOTO1780 5941C 5942 1780 CONTINUE 5943 IFOUND='YES' 5944 IX1ZFI=IHOLD 5945 IX2ZFI=IHOLD 5946 IY1ZFI=IHOLD 5947 IY2ZFI=IHOLD 5948C 5949 IF(IFEEDB.EQ.'OFF')GOTO1789 5950 WRITE(ICOUT,999) 5951 CALL DPWRST('XXX','BUG ') 5952 WRITE(ICOUT,1781) 5953 1781 FORMAT('THE TIC MARK LABEL FILL (FOR ALL 4 ', 5954 1'FRAME LINES)') 5955 CALL DPWRST('XXX','BUG ') 5956 WRITE(ICOUT,1782)IHOLD 5957 1782 FORMAT('HAS JUST BEEN SET TO ',A4) 5958 CALL DPWRST('XXX','BUG ') 5959 1789 CONTINUE 5960 GOTO1900 5961C 5962 1799 CONTINUE 5963C 5964 1900 CONTINUE 5965 RETURN 5966 END 5967 SUBROUTINE DPTLFM(ICOM,IHARG,NUMARG, 5968 1 IDETLF, 5969 1 IX1ZFM,IX2ZFM,IY1ZFM,IY2ZFM, 5970 1 IFOUND,IERROR) 5971C 5972C PURPOSE--DEFINE THE 4 TIC LABEL FORMATS CONTAINED IN THE 5973C 4 VARIABLES IX1ZFM,IX2ZFM,IY1ZFM,IY2ZFM 5974C SUCH TIC LABEL FORMATS DEFINE THE FORMATS FOR 5975C THE TIC LABELS ON THE 4 FRAME LINES OF A PLOT. 5976C INPUT ARGUMENTS--ICOM 5977C --IHARG (A HOLLERITH VECTOR) 5978C --NUMARG 5979C --IDETLF 5980C OUTPUT ARGUMENTS-- 5981C --IX1ZFM = LOWER HORIZONTAL TIC LABEL FORMAT 5982C --IX2ZFM = UPPER HORIZONTAL TIC LABEL FORMAT 5983C --IY1ZFM = LEFT VERTICAL TIC LABEL FORMAT 5984C --IY2ZFM = RIGHT VERTICAL TIC LABEL FORMAT 5985C --IFOUND ('YES' OR 'NO' ) 5986C --IERROR ('YES' OR 'NO' ) 5987C WRITTEN BY--JAMES J. FILLIBEN 5988C STATISTICAL ENGINEERING DIVISION 5989C INFORMATION TECHNOLOGY LABORATORY 5990C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5991C GAITHERSBURG, MD 20899-8980 5992C PHONE--301-975-2855 5993C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5994C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5995C LANGUAGE--ANSI FORTRAN (1977) 5996C VERSION NUMBER--88/2 5997C ORIGINAL VERSION--FEBRUARY 1988. 5998C UPDATED --JANUARY 2004. ADD SUPPORT FOR: 5999C ROW LABEL 6000C GROUP LABEL 6001C VARIABLE 6002C UPDATED --APRIL 2017. ROW LABEL CAN HAVE A 6003C A START ROW AND A STOP 6004C ROW. ALSO SOME RE-CODING 6005C FOR BETTER READABILTY 6006C 6007C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 6008C 6009 CHARACTER*4 ICOM 6010 CHARACTER*4 IHARG 6011 CHARACTER*4 IDETLF 6012 CHARACTER*4 IX1ZFM 6013 CHARACTER*4 IX2ZFM 6014 CHARACTER*4 IY1ZFM 6015 CHARACTER*4 IY2ZFM 6016 CHARACTER*4 IFOUND 6017 CHARACTER*4 IERROR 6018C 6019 CHARACTER*4 IHOLD 6020C 6021C--------------------------------------------------------------------- 6022C 6023 DIMENSION IHARG(*) 6024C 6025C-----COMMON---------------------------------------------------------- 6026C 6027 INCLUDE 'DPCOP2.INC' 6028C 6029C-----START POINT----------------------------------------------------- 6030C 6031 IFOUND='NO' 6032 IERROR='NO' 6033C 6034 IF(NUMARG.LE.1)GOTO1900 6035 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 6036 1IHARG(2).EQ.'FORM')GOTO1090 6037 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 6038 1IHARG(2).EQ.'LABE'.AND.IHARG(3).EQ.'FORM')GOTO1090 6039 GOTO1900 6040 1090 CONTINUE 6041C 6042C ***************************************************** 6043C ** TREAT THE CASE WHEN ** 6044C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 6045C ***************************************************** 6046C 6047 IF(ICOM.EQ.'XTIC')THEN 6048 IF(IHARG(NUMARG).EQ.'ON' .OR. IHARG(NUMARG).EQ.'OFF' .OR. 6049 1 IHARG(NUMARG).EQ.'AUTO' .OR. IHARG(NUMARG).EQ.'DEFA' .OR. 6050 1 IHARG(NUMARG).EQ.'FORM')THEN 6051 IHOLD=IDETLF 6052 ELSEIF(IHARG(NUMARG).EQ.'ROWL')THEN 6053 IHOLD='ROWL' 6054 ELSEIF(IHARG(NUMARG-1).EQ.'ROW '.AND.IHARG(NUMARG).EQ.'LABE') 6055 1 THEN 6056 IHOLD='ROWL' 6057 ELSEIF(IHARG(NUMARG-1).EQ.'GROU'.AND.IHARG(NUMARG).EQ.'LABE') 6058 1 THEN 6059 IHOLD='GLAB' 6060 ELSEIF(IHARG(NUMARG).EQ.'VARI')THEN 6061 IHOLD='VARI' 6062 ELSE 6063 IHOLD=IHARG(NUMARG) 6064 IF(IHOLD.EQ.'FIXE')IHOLD='REAL' 6065 ENDIF 6066C 6067 IFOUND='YES' 6068 IX1ZFM=IHOLD 6069 IX2ZFM=IHOLD 6070C 6071 IF(IFEEDB.EQ.'ON')THEN 6072 WRITE(ICOUT,999) 6073 999 FORMAT(1X) 6074 CALL DPWRST('XXX','BUG ') 6075 WRITE(ICOUT,1181) 6076 1181 FORMAT('THE TIC MARK LABEL FORMAT (FOR BOTH HORIZONTAL ', 6077 1 'FRAME LINES)') 6078 CALL DPWRST('XXX','BUG ') 6079 WRITE(ICOUT,1182)IHOLD 6080 1182 FORMAT('HAS JUST BEEN SET TO ',A4) 6081 CALL DPWRST('XXX','BUG ') 6082 ENDIF 6083 GOTO1900 6084 ENDIF 6085C 6086C ******************************************************* 6087C ** TREAT THE CASE WHEN ONLY THE BOTTOM ** 6088C ** HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 6089C ******************************************************* 6090C 6091 IF(ICOM.EQ.'X1TI')THEN 6092 IF(IHARG(NUMARG).EQ.'ON' .OR. IHARG(NUMARG).EQ.'OFF' .OR. 6093 1 IHARG(NUMARG).EQ.'AUTO' .OR. IHARG(NUMARG).EQ.'DEFA' .OR. 6094 1 IHARG(NUMARG).EQ.'FORM')THEN 6095 IHOLD=IDETLF 6096 ELSEIF(IHARG(NUMARG).EQ.'ROWL')THEN 6097 IHOLD='ROWL' 6098 ELSEIF(IHARG(NUMARG-1).EQ.'ROW '.AND.IHARG(NUMARG).EQ.'LABE') 6099 1 THEN 6100 IHOLD='ROWL' 6101 ELSEIF(IHARG(NUMARG-1).EQ.'GROU'.AND.IHARG(NUMARG).EQ.'LABE') 6102 1 THEN 6103 IHOLD='GLAB' 6104 ELSEIF(IHARG(NUMARG).EQ.'VARI')THEN 6105 IHOLD='VARI' 6106 ELSE 6107 IHOLD=IHARG(NUMARG) 6108 IF(IHOLD.EQ.'FIXE')IHOLD='REAL' 6109 ENDIF 6110C 6111 IFOUND='YES' 6112 IX1ZFM=IHOLD 6113C 6114 IF(IFEEDB.EQ.'ON')THEN 6115 WRITE(ICOUT,999) 6116 CALL DPWRST('XXX','BUG ') 6117 WRITE(ICOUT,1281) 6118 1281 FORMAT('THE TIC MARK LABEL FORMAT (FOR THE BOTTOM ', 6119 1 'HORIZONTAL FRAME LINE)') 6120 CALL DPWRST('XXX','BUG ') 6121 WRITE(ICOUT,1282)IHOLD 6122 1282 FORMAT('HAS JUST BEEN SET TO ',A4) 6123 CALL DPWRST('XXX','BUG ') 6124 ENDIF 6125 GOTO1900 6126 ENDIF 6127C 6128C ******************************************************* 6129C ** TREAT THE CASE WHEN ONLY THE TOP ** 6130C ** HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 6131C ******************************************************* 6132C 6133 IF(ICOM.EQ.'X2TI')THEN 6134 IF(IHARG(NUMARG).EQ.'ON' .OR. IHARG(NUMARG).EQ.'OFF' .OR. 6135 1 IHARG(NUMARG).EQ.'AUTO' .OR. IHARG(NUMARG).EQ.'DEFA' .OR. 6136 1 IHARG(NUMARG).EQ.'FORM')THEN 6137 IHOLD=IDETLF 6138 ELSEIF(IHARG(NUMARG).EQ.'ROWL')THEN 6139 IHOLD='ROWL' 6140 ELSEIF(IHARG(NUMARG-1).EQ.'ROW '.AND.IHARG(NUMARG).EQ.'LABE') 6141 1 THEN 6142 IHOLD='ROWL' 6143 ELSEIF(IHARG(NUMARG-1).EQ.'GROU'.AND.IHARG(NUMARG).EQ.'LABE') 6144 1 THEN 6145 IHOLD='GLAB' 6146 ELSEIF(IHARG(NUMARG).EQ.'VARI')THEN 6147 IHOLD='VARI' 6148 ELSE 6149 IHOLD=IHARG(NUMARG) 6150 IF(IHOLD.EQ.'FIXE')IHOLD='REAL' 6151 ENDIF 6152C 6153 IFOUND='YES' 6154 IX2ZFM=IHOLD 6155C 6156 IF(IFEEDB.EQ.'ON')THEN 6157 WRITE(ICOUT,999) 6158 CALL DPWRST('XXX','BUG ') 6159 WRITE(ICOUT,1381) 6160 1381 FORMAT('THE TIC MARK LABEL FORMAT (FOR THE TOP HORIZONTAL ', 6161 1 'FRAME LINE)') 6162 CALL DPWRST('XXX','BUG ') 6163 WRITE(ICOUT,1382)IHOLD 6164 1382 FORMAT('HAS JUST BEEN SET TO ',A4) 6165 CALL DPWRST('XXX','BUG ') 6166 ENDIF 6167 GOTO1900 6168 ENDIF 6169C 6170C ***************************************************** 6171C ** TREAT THE CASE WHEN ** 6172C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 6173C ***************************************************** 6174C 6175 IF(ICOM.EQ.'YTIC')THEN 6176 IF(IHARG(NUMARG).EQ.'ON' .OR. IHARG(NUMARG).EQ.'OFF' .OR. 6177 1 IHARG(NUMARG).EQ.'AUTO' .OR. IHARG(NUMARG).EQ.'DEFA' .OR. 6178 1 IHARG(NUMARG).EQ.'FORM')THEN 6179 IHOLD=IDETLF 6180 ELSEIF(IHARG(NUMARG).EQ.'ROWL')THEN 6181 IHOLD='ROWL' 6182 ELSEIF(IHARG(NUMARG-1).EQ.'ROW '.AND.IHARG(NUMARG).EQ.'LABE') 6183 1 THEN 6184 IHOLD='ROWL' 6185 ELSEIF(IHARG(NUMARG-1).EQ.'GROU'.AND.IHARG(NUMARG).EQ.'LABE') 6186 1 THEN 6187 IHOLD='GLAB' 6188 ELSEIF(IHARG(NUMARG).EQ.'VARI')THEN 6189 IHOLD='VARI' 6190 ELSE 6191 IHOLD=IHARG(NUMARG) 6192 IF(IHOLD.EQ.'FIXE')IHOLD='REAL' 6193 ENDIF 6194C 6195 IFOUND='YES' 6196 IY1ZFM=IHOLD 6197 IY2ZFM=IHOLD 6198C 6199 IF(IFEEDB.EQ.'ON')THEN 6200 WRITE(ICOUT,999) 6201 CALL DPWRST('XXX','BUG ') 6202 WRITE(ICOUT,1481) 6203 1481 FORMAT('THE TIC MARK LABEL FORMAT (FOR BOTH VERTICAL ', 6204 1 'FRAME LINES)') 6205 CALL DPWRST('XXX','BUG ') 6206 WRITE(ICOUT,1482)IHOLD 6207 1482 FORMAT('HAS JUST BEEN SET TO ',A4) 6208 CALL DPWRST('XXX','BUG ') 6209 ENDIF 6210 GOTO1900 6211 ENDIF 6212C 6213C ******************************************************* 6214C ** TREAT THE CASE WHEN ONLY THE LEFT ** 6215C ** VERTICAL TIC MARKS ARE TO BE CHANGED ** 6216C ******************************************************* 6217C 6218 IF(ICOM.EQ.'Y1TI')THEN 6219 IF(IHARG(NUMARG).EQ.'ON' .OR. IHARG(NUMARG).EQ.'OFF' .OR. 6220 1 IHARG(NUMARG).EQ.'AUTO' .OR. IHARG(NUMARG).EQ.'DEFA' .OR. 6221 1 IHARG(NUMARG).EQ.'FORM')THEN 6222 IHOLD=IDETLF 6223 ELSEIF(IHARG(NUMARG).EQ.'ROWL')THEN 6224 IHOLD='ROWL' 6225 ELSEIF(IHARG(NUMARG-1).EQ.'ROW '.AND.IHARG(NUMARG).EQ.'LABE') 6226 1 THEN 6227 IHOLD='ROWL' 6228 ELSEIF(IHARG(NUMARG-1).EQ.'GROU'.AND.IHARG(NUMARG).EQ.'LABE') 6229 1 THEN 6230 IHOLD='GLAB' 6231 ELSEIF(IHARG(NUMARG).EQ.'VARI')THEN 6232 IHOLD='VARI' 6233 ELSE 6234 IHOLD=IHARG(NUMARG) 6235 IF(IHOLD.EQ.'FIXE')IHOLD='REAL' 6236 ENDIF 6237C 6238 IFOUND='YES' 6239 IY1ZFM=IHOLD 6240C 6241 IF(IFEEDB.EQ.'ON')THEN 6242 WRITE(ICOUT,999) 6243 CALL DPWRST('XXX','BUG ') 6244 WRITE(ICOUT,1581) 6245 1581 FORMAT('THE TIC MARK LABEL FORMAT (FOR THE LEFT VERTICAL ', 6246 1 'FRAME LINE)') 6247 CALL DPWRST('XXX','BUG ') 6248 WRITE(ICOUT,1582)IHOLD 6249 1582 FORMAT('HAS JUST BEEN SET TO ',A4) 6250 CALL DPWRST('XXX','BUG ') 6251 ENDIF 6252 GOTO1900 6253 ENDIF 6254C 6255C ******************************************************* 6256C ** TREAT THE CASE WHEN ONLY THE RIGHT ** 6257C ** VERTICAL TIC MARKS ARE TO BE CHANGED ** 6258C ******************************************************* 6259C 6260 IF(ICOM.EQ.'Y2TI')THEN 6261 IF(IHARG(NUMARG).EQ.'ON' .OR. IHARG(NUMARG).EQ.'OFF' .OR. 6262 1 IHARG(NUMARG).EQ.'AUTO' .OR. IHARG(NUMARG).EQ.'DEFA' .OR. 6263 1 IHARG(NUMARG).EQ.'FORM')THEN 6264 IHOLD=IDETLF 6265 ELSEIF(IHARG(NUMARG).EQ.'ROWL')THEN 6266 IHOLD='ROWL' 6267 ELSEIF(IHARG(NUMARG-1).EQ.'ROW '.AND.IHARG(NUMARG).EQ.'LABE') 6268 1 THEN 6269 IHOLD='ROWL' 6270 ELSEIF(IHARG(NUMARG-1).EQ.'GROU'.AND.IHARG(NUMARG).EQ.'LABE') 6271 1 THEN 6272 IHOLD='GLAB' 6273 ELSEIF(IHARG(NUMARG).EQ.'VARI')THEN 6274 IHOLD='VARI' 6275 ELSE 6276 IHOLD=IHARG(NUMARG) 6277 IF(IHOLD.EQ.'FIXE')IHOLD='REAL' 6278 ENDIF 6279C 6280 IFOUND='YES' 6281 IY2ZFM=IHOLD 6282C 6283 IF(IFEEDB.EQ.'ON')THEN 6284 WRITE(ICOUT,999) 6285 CALL DPWRST('XXX','BUG ') 6286 WRITE(ICOUT,1681) 6287 1681 FORMAT('THE TIC MARK LABEL FORMAT (FOR THE RIGHT VERTICAL ', 6288 1 'FRAME LINE)') 6289 CALL DPWRST('XXX','BUG ') 6290 WRITE(ICOUT,1682)IHOLD 6291 1682 FORMAT('HAS JUST BEEN SET TO ',A4) 6292 CALL DPWRST('XXX','BUG ') 6293 ENDIF 6294 GOTO1900 6295 ENDIF 6296C 6297C ***************************************************** 6298C ** TREAT THE CASE WHEN ** 6299C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 6300C ***************************************************** 6301C 6302 IF(ICOM.EQ.'TIC' .OR. ICOM.EQ.'TICS' .OR. 6303 1 ICOM.EQ.'XYTI' .OR. ICOM.EQ.'YXTI')THEN 6304 IF(IHARG(NUMARG).EQ.'ON' .OR. IHARG(NUMARG).EQ.'OFF' .OR. 6305 1 IHARG(NUMARG).EQ.'AUTO' .OR. IHARG(NUMARG).EQ.'DEFA' .OR. 6306 1 IHARG(NUMARG).EQ.'FORM')THEN 6307 IHOLD=IDETLF 6308 ELSEIF(IHARG(NUMARG).EQ.'ROWL')THEN 6309 IHOLD='ROWL' 6310 ELSEIF(IHARG(NUMARG-1).EQ.'ROW '.AND.IHARG(NUMARG).EQ.'LABE') 6311 1 THEN 6312 IHOLD='ROWL' 6313 ELSEIF(IHARG(NUMARG-1).EQ.'GROU'.AND.IHARG(NUMARG).EQ.'LABE') 6314 1 THEN 6315 IHOLD='GLAB' 6316 ELSEIF(IHARG(NUMARG).EQ.'VARI')THEN 6317 IHOLD='VARI' 6318 ELSE 6319 IHOLD=IHARG(NUMARG) 6320 IF(IHOLD.EQ.'FIXE')IHOLD='REAL' 6321 ENDIF 6322C 6323 IFOUND='YES' 6324 IX1ZFM=IHOLD 6325 IX2ZFM=IHOLD 6326 IY1ZFM=IHOLD 6327 IY2ZFM=IHOLD 6328C 6329 IF(IFEEDB.EQ.'ON')THEN 6330 WRITE(ICOUT,999) 6331 CALL DPWRST('XXX','BUG ') 6332 WRITE(ICOUT,1781) 6333 1781 FORMAT('THE TIC MARK LABEL FORMAT (FOR ALL 4 ', 6334 1 'FRAME LINES)') 6335 CALL DPWRST('XXX','BUG ') 6336 WRITE(ICOUT,1782)IHOLD 6337 1782 FORMAT('HAS JUST BEEN SET TO ',A4) 6338 CALL DPWRST('XXX','BUG ') 6339 ENDIF 6340 GOTO1900 6341 ENDIF 6342C 6343 1900 CONTINUE 6344 RETURN 6345 END 6346 SUBROUTINE DPTLFO(ICOM,IHARG,NUMARG, 6347 1IDEFFO, 6348 1IX1ZFO,IX2ZFO,IY1ZFO,IY2ZFO, 6349 1IFOUND,IERROR) 6350C 6351C PURPOSE--DEFINE THE 4 TIC LABEL FONTS CONTAINED IN THE 6352C 4 VARIABLES IX1ZFO,IX2ZFO,IY1ZFO,IY2ZFO 6353C SUCH TIC LABEL FONTS DEFINE THE FONTS FOR 6354C THE TIC LABELS ON THE 4 FRAME LINES OF A PLOT. 6355C INPUT ARGUMENTS--ICOM 6356C --IHARG (A HOLLERITH VECTOR) 6357C --NUMARG 6358C --IDEFFO 6359C OUTPUT ARGUMENTS-- 6360C --IX1ZFO = LOWER HORIZONTAL TIC LABEL FONT 6361C --IX2ZFO = UPPER HORIZONTAL TIC LABEL FONT 6362C --IY1ZFO = LEFT VERTICAL TIC LABEL FONT 6363C --IY2ZFO = RIGHT VERTICAL TIC LABEL FONT 6364C --IFOUND ('YES' OR 'NO' ) 6365C --IERROR ('YES' OR 'NO' ) 6366C WRITTEN BY--ALAN HECKERT 6367C STATISTICAL ENGINEERING DIVISION 6368C INFORMATION TECHNOLOGY LABORATORY 6369C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 6370C GAITHERSBURG, MD 20899-8980 6371C PHONE--301-975-2899 6372C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 6373C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 6374C LANGUAGE--ANSI FORTRAN (1977) 6375C VERSION NUMBER--89/2 6376C ORIGINAL VERSION--JANUARY 1989. 6377C 6378C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 6379C 6380 CHARACTER*4 ICOM 6381 CHARACTER*4 IHARG 6382C 6383 CHARACTER*4 IDEFFO 6384C 6385 CHARACTER*4 IX1ZFO 6386 CHARACTER*4 IX2ZFO 6387 CHARACTER*4 IY1ZFO 6388 CHARACTER*4 IY2ZFO 6389C 6390 CHARACTER*4 IFOUND 6391 CHARACTER*4 IERROR 6392C 6393 CHARACTER*4 IHOLD 6394C 6395C--------------------------------------------------------------------- 6396C 6397 DIMENSION IHARG(*) 6398C 6399C-----COMMON---------------------------------------------------------- 6400C 6401 INCLUDE 'DPCOP2.INC' 6402C 6403C-----START POINT----------------------------------------------------- 6404C 6405 IFOUND='NO' 6406 IERROR='NO' 6407C 6408 IF(NUMARG.LE.1)GOTO1900 6409 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 6410 1IHARG(2).EQ.'FONT')GOTO1090 6411 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 6412 1IHARG(2).EQ.'LABE'.AND.IHARG(3).EQ.'FONT')GOTO1090 6413 GOTO1900 6414 1090 CONTINUE 6415C 6416C ***************************************************** 6417C ** TREAT THE CASE WHEN ** 6418C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 6419C ***************************************************** 6420C 6421 IF(ICOM.EQ.'XTIC')GOTO1100 6422 GOTO1199 6423C 6424 1100 CONTINUE 6425 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 6426 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 6427 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 6428 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 6429 IF(IHARG(NUMARG).EQ.'FONT')GOTO1150 6430 GOTO1160 6431C 6432 1150 CONTINUE 6433 IHOLD=IDEFFO 6434 GOTO1180 6435C 6436 1160 CONTINUE 6437 IHOLD=IHARG(NUMARG) 6438 GOTO1180 6439C 6440 1180 CONTINUE 6441 IFOUND='YES' 6442 IX1ZFO=IHOLD 6443 IX2ZFO=IHOLD 6444C 6445 IF(IFEEDB.EQ.'OFF')GOTO1189 6446 WRITE(ICOUT,999) 6447 999 FORMAT(1X) 6448 CALL DPWRST('XXX','BUG ') 6449 WRITE(ICOUT,1181) 6450 1181 FORMAT('THE TIC MARK LABEL FONT (FOR BOTH HORIZONTAL ', 6451 1'FRAME LINES)') 6452 CALL DPWRST('XXX','BUG ') 6453 WRITE(ICOUT,1182)IHOLD 6454 1182 FORMAT('HAS JUST BEEN SET TO ',A4) 6455 CALL DPWRST('XXX','BUG ') 6456 1189 CONTINUE 6457 GOTO1900 6458C 6459 1199 CONTINUE 6460C 6461C ************************************************************** 6462C ** TREAT THE CASE WHEN ** 6463C ** ONLY THE BOTTOM HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 6464C ************************************************************** 6465C 6466 IF(ICOM.EQ.'X1TI')GOTO1200 6467 GOTO1299 6468C 6469 1200 CONTINUE 6470 IF(IHARG(NUMARG).EQ.'ON')GOTO1250 6471 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 6472 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 6473 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 6474 IF(IHARG(NUMARG).EQ.'FONT')GOTO1250 6475 GOTO1260 6476C 6477 1250 CONTINUE 6478 IHOLD=IDEFFO 6479 GOTO1280 6480C 6481 1260 CONTINUE 6482 IHOLD=IHARG(NUMARG) 6483 GOTO1280 6484C 6485 1280 CONTINUE 6486 IFOUND='YES' 6487 IX1ZFO=IHOLD 6488C 6489 IF(IFEEDB.EQ.'OFF')GOTO1289 6490 WRITE(ICOUT,999) 6491 CALL DPWRST('XXX','BUG ') 6492 WRITE(ICOUT,1281) 6493 1281 FORMAT('THE TIC MARK LABEL FONT (FOR THE BOTTOM ', 6494 1'HORIZONTAL FRAME LINE)') 6495 CALL DPWRST('XXX','BUG ') 6496 WRITE(ICOUT,1282)IHOLD 6497 1282 FORMAT('HAS JUST BEEN SET TO ',A4) 6498 CALL DPWRST('XXX','BUG ') 6499 1289 CONTINUE 6500 GOTO1900 6501C 6502 1299 CONTINUE 6503C 6504C ************************************************************** 6505C ** TREAT THE CASE WHEN ** 6506C ** ONLY THE TOP HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 6507C ************************************************************** 6508C 6509 IF(ICOM.EQ.'X2TI')GOTO1300 6510 GOTO1399 6511C 6512 1300 CONTINUE 6513 IF(IHARG(NUMARG).EQ.'ON')GOTO1350 6514 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 6515 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 6516 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 6517 IF(IHARG(NUMARG).EQ.'FONT')GOTO1350 6518 GOTO1360 6519C 6520 1350 CONTINUE 6521 IHOLD=IDEFFO 6522 GOTO1380 6523C 6524 1360 CONTINUE 6525 IHOLD=IHARG(NUMARG) 6526 GOTO1380 6527C 6528 1380 CONTINUE 6529 IFOUND='YES' 6530 IX2ZFO=IHOLD 6531C 6532 IF(IFEEDB.EQ.'OFF')GOTO1389 6533 WRITE(ICOUT,999) 6534 CALL DPWRST('XXX','BUG ') 6535 WRITE(ICOUT,1381) 6536 1381 FORMAT('THE TIC MARK LABEL FONT (FOR THE TOP HORIZONTAL ', 6537 1'FRAME LINE)') 6538 CALL DPWRST('XXX','BUG ') 6539 WRITE(ICOUT,1382)IHOLD 6540 1382 FORMAT('HAS JUST BEEN SET TO ',A4) 6541 CALL DPWRST('XXX','BUG ') 6542 1389 CONTINUE 6543 GOTO1900 6544C 6545 1399 CONTINUE 6546C 6547C ***************************************************** 6548C ** TREAT THE CASE WHEN ** 6549C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 6550C ***************************************************** 6551C 6552 IF(ICOM.EQ.'YTIC')GOTO1400 6553 GOTO1499 6554C 6555 1400 CONTINUE 6556 IF(IHARG(NUMARG).EQ.'ON')GOTO1450 6557 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 6558 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 6559 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 6560 IF(IHARG(NUMARG).EQ.'FONT')GOTO1450 6561 GOTO1460 6562C 6563 1450 CONTINUE 6564 IHOLD=IDEFFO 6565 GOTO1480 6566C 6567 1460 CONTINUE 6568 IHOLD=IHARG(NUMARG) 6569 GOTO1480 6570C 6571 1480 CONTINUE 6572 IFOUND='YES' 6573 IY1ZFO=IHOLD 6574 IY2ZFO=IHOLD 6575C 6576 IF(IFEEDB.EQ.'OFF')GOTO1489 6577 WRITE(ICOUT,999) 6578 CALL DPWRST('XXX','BUG ') 6579 WRITE(ICOUT,1481) 6580 1481 FORMAT('THE TIC MARK LABEL FONT (FOR BOTH VERTICAL ', 6581 1'FRAME LINES)') 6582 CALL DPWRST('XXX','BUG ') 6583 WRITE(ICOUT,1482)IHOLD 6584 1482 FORMAT('HAS JUST BEEN SET TO ',A4) 6585 CALL DPWRST('XXX','BUG ') 6586 1489 CONTINUE 6587 GOTO1900 6588C 6589 1499 CONTINUE 6590C 6591C ************************************************************** 6592C ** TREAT THE CASE WHEN ** 6593C ** ONLY THE LEFT VERTICAL TIC MARKS ARE TO BE CHANGED ** 6594C ************************************************************** 6595C 6596 IF(ICOM.EQ.'Y1TI')GOTO1500 6597 GOTO1599 6598C 6599 1500 CONTINUE 6600 IF(IHARG(NUMARG).EQ.'ON')GOTO1550 6601 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 6602 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 6603 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 6604 IF(IHARG(NUMARG).EQ.'FONT')GOTO1550 6605 GOTO1560 6606C 6607 1550 CONTINUE 6608 IHOLD=IDEFFO 6609 GOTO1580 6610C 6611 1560 CONTINUE 6612 IHOLD=IHARG(NUMARG) 6613 GOTO1580 6614C 6615 1580 CONTINUE 6616 IFOUND='YES' 6617 IY1ZFO=IHOLD 6618C 6619 IF(IFEEDB.EQ.'OFF')GOTO1589 6620 WRITE(ICOUT,999) 6621 CALL DPWRST('XXX','BUG ') 6622 WRITE(ICOUT,1581) 6623 1581 FORMAT('THE TIC MARK LABEL FONT (FOR THE LEFT VERTICAL ', 6624 1'FRAME LINE)') 6625 CALL DPWRST('XXX','BUG ') 6626 WRITE(ICOUT,1582)IHOLD 6627 1582 FORMAT('HAS JUST BEEN SET TO ',A4) 6628 CALL DPWRST('XXX','BUG ') 6629 1589 CONTINUE 6630 GOTO1900 6631C 6632 1599 CONTINUE 6633C 6634C ************************************************************** 6635C ** TREAT THE CASE WHEN ** 6636C ** ONLY THE RIGHT VERTICAL TIC MARKS ARE TO BE CHANGED ** 6637C ************************************************************** 6638C 6639 IF(ICOM.EQ.'Y2TI')GOTO1600 6640 GOTO1699 6641C 6642 1600 CONTINUE 6643 IF(IHARG(NUMARG).EQ.'ON')GOTO1650 6644 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 6645 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 6646 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 6647 IF(IHARG(NUMARG).EQ.'FONT')GOTO1650 6648 GOTO1660 6649C 6650 1650 CONTINUE 6651 IHOLD=IDEFFO 6652 GOTO1680 6653C 6654 1660 CONTINUE 6655 IHOLD=IHARG(NUMARG) 6656 GOTO1680 6657C 6658 1680 CONTINUE 6659 IFOUND='YES' 6660 IY2ZFO=IHOLD 6661C 6662 IF(IFEEDB.EQ.'OFF')GOTO1689 6663 WRITE(ICOUT,999) 6664 CALL DPWRST('XXX','BUG ') 6665 WRITE(ICOUT,1681) 6666 1681 FORMAT('THE TIC MARK LABEL FONT (FOR THE RIGHT VERTICAL ', 6667 1'FRAME LINE)') 6668 CALL DPWRST('XXX','BUG ') 6669 WRITE(ICOUT,1682)IHOLD 6670 1682 FORMAT('HAS JUST BEEN SET TO ',A4) 6671 CALL DPWRST('XXX','BUG ') 6672 1689 CONTINUE 6673 GOTO1900 6674C 6675 1699 CONTINUE 6676C 6677C ***************************************************** 6678C ** TREAT THE CASE WHEN ** 6679C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 6680C ***************************************************** 6681C 6682 IF(ICOM.EQ.'TIC')GOTO1700 6683 IF(ICOM.EQ.'TICS')GOTO1700 6684 IF(ICOM.EQ.'XYTI')GOTO1700 6685 IF(ICOM.EQ.'YXTI')GOTO1700 6686 GOTO1799 6687C 6688 1700 CONTINUE 6689 IF(IHARG(NUMARG).EQ.'ON')GOTO1750 6690 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 6691 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 6692 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 6693 IF(IHARG(NUMARG).EQ.'FONT')GOTO1750 6694 GOTO1760 6695C 6696 1750 CONTINUE 6697 IHOLD=IDEFFO 6698 GOTO1780 6699C 6700 1760 CONTINUE 6701 IHOLD=IHARG(NUMARG) 6702 GOTO1780 6703C 6704 1780 CONTINUE 6705 IFOUND='YES' 6706 IX1ZFO=IHOLD 6707 IX2ZFO=IHOLD 6708 IY1ZFO=IHOLD 6709 IY2ZFO=IHOLD 6710C 6711 IF(IFEEDB.EQ.'OFF')GOTO1789 6712 WRITE(ICOUT,999) 6713 CALL DPWRST('XXX','BUG ') 6714 WRITE(ICOUT,1781) 6715 1781 FORMAT('THE TIC MARK LABEL FONT (FOR ALL 4 ', 6716 1'FRAME LINES)') 6717 CALL DPWRST('XXX','BUG ') 6718 WRITE(ICOUT,1782)IHOLD 6719 1782 FORMAT('HAS JUST BEEN SET TO ',A4) 6720 CALL DPWRST('XXX','BUG ') 6721 1789 CONTINUE 6722 GOTO1900 6723C 6724 1799 CONTINUE 6725C 6726 1900 CONTINUE 6727 RETURN 6728 END 6729 SUBROUTINE DPTLHW(ICOM,IHARG,IARGT,ARG,NUMARG, 6730 1PDEFHE,PDEFWI, 6731 1PX1ZHE,PX1ZWI,PX1ZVG,PX1ZHG, 6732 1PX2ZHE,PX2ZWI,PX2ZVG,PX2ZHG, 6733 1PY1ZHE,PY1ZWI,PY1ZVG,PY1ZHG, 6734 1PY2ZHE,PY2ZWI,PY2ZVG,PY2ZHG, 6735 1IFOUND,IERROR) 6736C 6737C PURPOSE--DEFINE THE TIC MARK LABEL HEIGHT AND WIDTH SWITCHES 6738C FOR ANY OF THE 4 FRAME LINES. 6739C SUCH TIC MARK SWITCHES DEFINE THE HEIGHT AND WIDTH 6740C OF THE TIC MARK LABELS ON THE 4 FRAME LINES OF A PLOT. 6741C INPUT ARGUMENTS--ICOM 6742C --IHARG (A HOLLERITH VECTOR) 6743C --IARGT (A HOLLERITH VECTOR) 6744C --ARG (A FLOATING POINT VECTOR) 6745C --NUMARG 6746C --PDEFHE 6747C --PDEFWI 6748C OUTPUT ARGUMENTS-- 6749C --PX1ZHE,PX1ZWI,PX1ZVG,PX1ZHG, 6750C --PX2ZHE,PX2ZWI,PX2ZVG,PX2ZHG, 6751C --PY1ZHE,PY1ZWI,PY1ZVG,PY1ZHG, 6752C --PY2ZHE,PY2ZWI,PY2ZVG,PY2ZHG, 6753C --IFOUND ('YES' OR 'NO' ) 6754C --IERROR ('YES' OR 'NO' ) 6755C WRITTEN BY--JAMES J. FILLIBEN 6756C STATISTICAL ENGINEERING DIVISION 6757C INFORMATION TECHNOLOGY LABORATORY 6758C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 6759C GAITHERSBURG, MD 20899-8980 6760C PHONE--301-975-2855 6761C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 6762C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 6763C LANGUAGE--ANSI FORTRAN (1977) 6764C VERSION NUMBER--82/7 6765C ORIGINAL VERSION--JULY 1987. 6766C UPDATED --DECEMBER 1988. ADD DEFAULT WIDTH 6767C 6768C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 6769C 6770 CHARACTER*4 ICOM 6771 CHARACTER*4 IHARG 6772 CHARACTER*4 IARGT 6773 CHARACTER*4 IFOUND 6774 CHARACTER*4 IERROR 6775C 6776C--------------------------------------------------------------------- 6777C 6778 DIMENSION IHARG(*) 6779 DIMENSION IARGT(*) 6780 DIMENSION ARG(*) 6781C 6782C-----COMMON---------------------------------------------------------- 6783C 6784 INCLUDE 'DPCOP2.INC' 6785C 6786C-----START POINT----------------------------------------------------- 6787C 6788 IFOUND='NO' 6789 IERROR='NO' 6790C 6791 NUMAM1=NUMARG-1 6792C 6793CCCCC IF(NUMARG.LE.1)GOTO1900 6794 IF(NUMARG.LE.1)GOTO9000 6795 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 6796 1IHARG(2).EQ.'HW')GOTO1090 6797 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 6798 1IHARG(2).EQ.'LABE'.AND.IHARG(3).EQ.'HW')GOTO1090 6799CCCCC GOTO1900 6800 GOTO9000 6801 1090 CONTINUE 6802C 6803C ***************************************************** 6804C ** TREAT THE CASE WHEN ** 6805C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 6806C ***************************************************** 6807C 6808 IF(ICOM.EQ.'XTIC')GOTO1100 6809 GOTO1199 6810C 6811 1100 CONTINUE 6812 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 6813 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 6814 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 6815 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 6816 IF(IHARG(NUMARG).EQ.'HW')GOTO1150 6817 IF(IARGT(NUMAM1).EQ.'NUMB'.AND. 6818 1 IARGT(NUMARG).EQ.'NUMB')GOTO1160 6819 IERROR='YES' 6820 GOTO9000 6821C 6822 1150 CONTINUE 6823 HOLD1=PDEFHE 6824 HOLD2=PDEFWI 6825 GOTO1180 6826C 6827 1160 CONTINUE 6828 HOLD1=ARG(NUMAM1) 6829 HOLD2=ARG(NUMARG) 6830 GOTO1180 6831C 6832 1180 CONTINUE 6833 IFOUND='YES' 6834 PX1ZHE=HOLD1 6835 PX2ZHE=HOLD1 6836 PX1ZWI=HOLD2 6837 PX2ZWI=HOLD2 6838C 6839 IF(IFEEDB.EQ.'OFF')GOTO1189 6840 WRITE(ICOUT,999) 6841 999 FORMAT(1X) 6842 CALL DPWRST('XXX','BUG ') 6843 WRITE(ICOUT,1181) 6844 1181 FORMAT('THE TIC MARK LABEL HEIGHT & WIDTH (FOR BOTH ', 6845 1'HORIZONTAL FRAME LINES)') 6846 CALL DPWRST('XXX','BUG ') 6847 WRITE(ICOUT,1182)HOLD1,HOLD2 6848 1182 FORMAT('HAVE JUST BEEN SET TO ',2E15.7) 6849 CALL DPWRST('XXX','BUG ') 6850 1189 CONTINUE 6851 GOTO1900 6852C 6853 1199 CONTINUE 6854C 6855C ************************************************************** 6856C ** TREAT THE CASE WHEN ** 6857C ** ONLY THE BOTTOM HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 6858C ************************************************************** 6859C 6860 IF(ICOM.EQ.'X1TI')GOTO1200 6861 GOTO1299 6862C 6863 1200 CONTINUE 6864 IF(IHARG(NUMARG).EQ.'ON')GOTO1250 6865 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 6866 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 6867 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 6868 IF(IHARG(NUMARG).EQ.'HW')GOTO1250 6869 IF(IARGT(NUMAM1).EQ.'NUMB'.AND. 6870 1 IARGT(NUMARG).EQ.'NUMB')GOTO1260 6871 IERROR='YES' 6872 GOTO9000 6873C 6874 1250 CONTINUE 6875 HOLD1=PDEFHE 6876 HOLD2=PDEFWI 6877 GOTO1280 6878C 6879 1260 CONTINUE 6880 HOLD1=ARG(NUMAM1) 6881 HOLD2=ARG(NUMARG) 6882 GOTO1280 6883C 6884 1280 CONTINUE 6885 IFOUND='YES' 6886 PX1ZHE=HOLD1 6887 PX1ZWI=HOLD2 6888C 6889 IF(IFEEDB.EQ.'OFF')GOTO1289 6890 WRITE(ICOUT,999) 6891 CALL DPWRST('XXX','BUG ') 6892 WRITE(ICOUT,1281) 6893 1281 FORMAT('THE TIC MARK LABEL HEIGHT & WIDTH (FOR THE BOTTOM ', 6894 1'HORIZONTAL FRAME LINE)') 6895 CALL DPWRST('XXX','BUG ') 6896 WRITE(ICOUT,1282)HOLD1,HOLD2 6897 1282 FORMAT('HAVE JUST BEEN SET TO ',2E15.7) 6898 CALL DPWRST('XXX','BUG ') 6899 1289 CONTINUE 6900 GOTO1900 6901C 6902 1299 CONTINUE 6903C 6904C ************************************************************** 6905C ** TREAT THE CASE WHEN ** 6906C ** ONLY THE TOP HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 6907C ************************************************************** 6908C 6909 IF(ICOM.EQ.'X2TI')GOTO1300 6910 GOTO1399 6911C 6912 1300 CONTINUE 6913 IF(IHARG(NUMARG).EQ.'ON')GOTO1350 6914 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 6915 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 6916 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 6917 IF(IHARG(NUMARG).EQ.'HW')GOTO1350 6918 IF(IARGT(NUMAM1).EQ.'NUMB'.AND. 6919 1 IARGT(NUMARG).EQ.'NUMB')GOTO1360 6920 IERROR='YES' 6921 GOTO9000 6922C 6923 1350 CONTINUE 6924 HOLD1=PDEFHE 6925 HOLD2=PDEFWI 6926 GOTO1380 6927C 6928 1360 CONTINUE 6929 HOLD1=ARG(NUMAM1) 6930 HOLD2=ARG(NUMARG) 6931 GOTO1380 6932C 6933 1380 CONTINUE 6934 IFOUND='YES' 6935 PX2ZHE=HOLD1 6936 PX2ZWI=HOLD2 6937C 6938 IF(IFEEDB.EQ.'OFF')GOTO1389 6939 WRITE(ICOUT,999) 6940 CALL DPWRST('XXX','BUG ') 6941 WRITE(ICOUT,1381) 6942 1381 FORMAT('THE TIC MARK LABEL HEIGHT & WIDTH (FOR THE TOP ', 6943 1'HORIZONTAL FRAME LINE)') 6944 CALL DPWRST('XXX','BUG ') 6945 WRITE(ICOUT,1382)HOLD1,HOLD2 6946 1382 FORMAT('HAVE JUST BEEN SET TO ',2E15.7) 6947 CALL DPWRST('XXX','BUG ') 6948 1389 CONTINUE 6949 GOTO1900 6950C 6951 1399 CONTINUE 6952C 6953C ***************************************************** 6954C ** TREAT THE CASE WHEN ** 6955C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 6956C ***************************************************** 6957C 6958 IF(ICOM.EQ.'YTIC')GOTO1400 6959 GOTO1499 6960C 6961 1400 CONTINUE 6962 IF(IHARG(NUMARG).EQ.'ON')GOTO1450 6963 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 6964 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 6965 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 6966 IF(IHARG(NUMARG).EQ.'HW')GOTO1450 6967 IF(IARGT(NUMAM1).EQ.'NUMB'.AND. 6968 1 IARGT(NUMARG).EQ.'NUMB')GOTO1460 6969 IERROR='YES' 6970 GOTO9000 6971C 6972 1450 CONTINUE 6973 HOLD1=PDEFHE 6974 HOLD2=PDEFWI 6975 GOTO1480 6976C 6977 1460 CONTINUE 6978 HOLD1=ARG(NUMAM1) 6979 HOLD2=ARG(NUMARG) 6980 GOTO1480 6981C 6982 1480 CONTINUE 6983 IFOUND='YES' 6984 PY1ZHE=HOLD1 6985 PY2ZHE=HOLD1 6986 PY1ZWI=HOLD2 6987 PY2ZWI=HOLD2 6988C 6989 IF(IFEEDB.EQ.'OFF')GOTO1489 6990 WRITE(ICOUT,999) 6991 CALL DPWRST('XXX','BUG ') 6992 WRITE(ICOUT,1481) 6993 1481 FORMAT('THE TIC MARK LABEL HEIGHT & WIDTH (FOR BOTH ', 6994 1'VERTICAL FRAME LINES)') 6995 CALL DPWRST('XXX','BUG ') 6996 WRITE(ICOUT,1482)HOLD1,HOLD2 6997 1482 FORMAT('HAVE JUST BEEN SET TO ',2E15.7) 6998 CALL DPWRST('XXX','BUG ') 6999 1489 CONTINUE 7000 GOTO1900 7001C 7002 1499 CONTINUE 7003C 7004C ************************************************************** 7005C ** TREAT THE CASE WHEN ** 7006C ** ONLY THE LEFT VERTICAL TIC MARKS ARE TO BE CHANGED ** 7007C ************************************************************** 7008C 7009 IF(ICOM.EQ.'Y1TI')GOTO1500 7010 GOTO1599 7011C 7012 1500 CONTINUE 7013 IF(IHARG(NUMARG).EQ.'ON')GOTO1550 7014 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 7015 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 7016 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 7017 IF(IHARG(NUMARG).EQ.'HW')GOTO1550 7018 IF(IARGT(NUMAM1).EQ.'NUMB'.AND. 7019 1 IARGT(NUMARG).EQ.'NUMB')GOTO1560 7020 IERROR='YES' 7021 GOTO9000 7022C 7023 1550 CONTINUE 7024 HOLD1=PDEFHE 7025 HOLD2=PDEFWI 7026 GOTO1580 7027C 7028 1560 CONTINUE 7029 HOLD1=ARG(NUMAM1) 7030 HOLD2=ARG(NUMARG) 7031 GOTO1580 7032C 7033 1580 CONTINUE 7034 IFOUND='YES' 7035 PY1ZHE=HOLD1 7036 PY1ZWI=HOLD2 7037C 7038 IF(IFEEDB.EQ.'OFF')GOTO1589 7039 WRITE(ICOUT,999) 7040 CALL DPWRST('XXX','BUG ') 7041 WRITE(ICOUT,1581) 7042 1581 FORMAT('THE TIC MARK LABEL HEIGHT & WIDTH (FOR THE LEFT ', 7043 1'VERTICAL FRAME LINE)') 7044 CALL DPWRST('XXX','BUG ') 7045 WRITE(ICOUT,1582)HOLD1,HOLD2 7046 1582 FORMAT('HAVE JUST BEEN SET TO ',2E15.7) 7047 CALL DPWRST('XXX','BUG ') 7048 1589 CONTINUE 7049 GOTO1900 7050C 7051 1599 CONTINUE 7052C 7053C ************************************************************** 7054C ** TREAT THE CASE WHEN ** 7055C ** ONLY THE RIGHT VERTICAL TIC MARKS ARE TO BE CHANGED ** 7056C ************************************************************** 7057C 7058 IF(ICOM.EQ.'Y2TI')GOTO1600 7059 GOTO1699 7060C 7061 1600 CONTINUE 7062 IF(IHARG(NUMARG).EQ.'ON')GOTO1650 7063 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 7064 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 7065 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 7066 IF(IHARG(NUMARG).EQ.'HW')GOTO1650 7067 IF(IARGT(NUMAM1).EQ.'NUMB'.AND. 7068 1 IARGT(NUMARG).EQ.'NUMB')GOTO1660 7069 IERROR='YES' 7070 GOTO9000 7071C 7072 1650 CONTINUE 7073 HOLD1=PDEFHE 7074 HOLD2=PDEFWI 7075 GOTO1680 7076C 7077 1660 CONTINUE 7078 HOLD1=ARG(NUMAM1) 7079 HOLD2=ARG(NUMARG) 7080 GOTO1680 7081C 7082 1680 CONTINUE 7083 IFOUND='YES' 7084 PY2ZHE=HOLD1 7085 PY2ZWI=HOLD2 7086C 7087 IF(IFEEDB.EQ.'OFF')GOTO1689 7088 WRITE(ICOUT,999) 7089 CALL DPWRST('XXX','BUG ') 7090 WRITE(ICOUT,1681) 7091 1681 FORMAT('THE TIC MARK LABEL HEIGHT & WIDTH (FOR THE RIGHT ', 7092 1'VERTICAL FRAME LINE)') 7093 CALL DPWRST('XXX','BUG ') 7094 WRITE(ICOUT,1682)HOLD1,HOLD2 7095 1682 FORMAT('HAVE JUST BEEN SET TO ',2E15.7) 7096 CALL DPWRST('XXX','BUG ') 7097 1689 CONTINUE 7098 GOTO1900 7099C 7100 1699 CONTINUE 7101C 7102C ***************************************************** 7103C ** TREAT THE CASE WHEN ** 7104C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 7105C ***************************************************** 7106C 7107 IF(ICOM.EQ.'TIC')GOTO1700 7108 IF(ICOM.EQ.'TICS')GOTO1700 7109 IF(ICOM.EQ.'XYTI')GOTO1700 7110 IF(ICOM.EQ.'YXTI')GOTO1700 7111 GOTO1799 7112C 7113 1700 CONTINUE 7114 IF(IHARG(NUMARG).EQ.'ON')GOTO1750 7115 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 7116 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 7117 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 7118 IF(IHARG(NUMARG).EQ.'HW')GOTO1750 7119 IF(IARGT(NUMAM1).EQ.'NUMB'.AND. 7120 1 IARGT(NUMARG).EQ.'NUMB')GOTO1760 7121 IERROR='YES' 7122 GOTO9000 7123C 7124 1750 CONTINUE 7125 HOLD1=PDEFHE 7126 HOLD2=PDEFWI 7127 GOTO1780 7128C 7129 1760 CONTINUE 7130 HOLD1=ARG(NUMAM1) 7131 HOLD2=ARG(NUMARG) 7132 GOTO1780 7133C 7134 1780 CONTINUE 7135 IFOUND='YES' 7136 PX1ZHE=HOLD1 7137 PX2ZHE=HOLD1 7138 PY1ZHE=HOLD1 7139 PY2ZHE=HOLD1 7140 PX1ZWI=HOLD2 7141 PX2ZWI=HOLD2 7142 PY1ZWI=HOLD2 7143 PY2ZWI=HOLD2 7144C 7145 IF(IFEEDB.EQ.'OFF')GOTO1789 7146 WRITE(ICOUT,999) 7147 CALL DPWRST('XXX','BUG ') 7148 WRITE(ICOUT,1781) 7149 1781 FORMAT('THE TIC MARK LABEL HEIGHT & WIDTH (FOR ', 7150 1'ALL 4 FRAME LINES)') 7151 CALL DPWRST('XXX','BUG ') 7152 WRITE(ICOUT,1782)HOLD1,HOLD2 7153 1782 FORMAT('HAVE JUST BEEN SET TO ',2E15.7) 7154 CALL DPWRST('XXX','BUG ') 7155 1789 CONTINUE 7156 GOTO1900 7157C 7158 1799 CONTINUE 7159C 7160 1900 CONTINUE 7161C 7162 PX1ZVG=PX1ZHE*0.375 7163 PX2ZVG=PX2ZHE*0.375 7164 PY1ZVG=PY1ZHE*0.375 7165 PY2ZVG=PY2ZHE*0.375 7166C 7167 PX1ZHG=PX1ZHE*0.125 7168 PX2ZHG=PX2ZHE*0.125 7169 PY1ZHG=PY1ZHE*0.125 7170 PY2ZHG=PY2ZHE*0.125 7171 GOTO9000 7172C 7173 9000 CONTINUE 7174 RETURN 7175 END 7176 SUBROUTINE DPTLJU(ICOM,IHARG,NUMARG, 7177 1IDEFJU, 7178 1IX1ZJU,IX2ZJU,IY1ZJU,IY2ZJU, 7179 1IFOUND,IERROR) 7180C 7181C PURPOSE--DEFINE THE 4 TIC LABEL JUSTIFICATIONS CONTAINED IN THE 7182C 4 VARIABLES IX1ZJU,IX2ZJU,IY1ZJU,IY2ZJU 7183C SUCH TIC LABEL JUSTIFICATIONS DEFINE THE JUSTIFICATIONS FOR 7184C THE TIC LABELS ON THE 4 FRAME LINES OF A PLOT. 7185C INPUT ARGUMENTS--ICOM 7186C --IHARG (A HOLLERITH VECTOR) 7187C --NUMARG 7188C --IDEFJU 7189C OUTPUT ARGUMENTS-- 7190C --IX1ZJU = LOWER HORIZONTAL TIC LABEL JUSTIFICATION 7191C --IX2ZJU = UPPER HORIZONTAL TIC LABEL JUSTIFICATION 7192C --IY1ZJU = LEFT VERTICAL TIC LABEL JUSTIFICATION 7193C --IY2ZJU = RIGHT VERTICAL TIC LABEL JUSTIFICATION 7194C --IFOUND ('YES' OR 'NO' ) 7195C --IERROR ('YES' OR 'NO' ) 7196C WRITTEN BY--ALAN HECKERT 7197C STATISTICAL ENGINEERING DIVISION 7198C INFORMATION TECHNOLOGY LABORATORY 7199C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 7200C GAITHERSBURG, MD 20899-8980 7201C PHONE--301-975-2899 7202C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 7203C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 7204C LANGUAGE--ANSI FORTRAN (1977) 7205C VERSION NUMBER--89/2 7206C ORIGINAL VERSION--JANUARY 1989. 7207C 7208C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 7209C 7210 CHARACTER*4 ICOM 7211 CHARACTER*4 IHARG 7212C 7213 CHARACTER*4 IDEFJU 7214C 7215 CHARACTER*4 IX1ZJU 7216 CHARACTER*4 IX2ZJU 7217 CHARACTER*4 IY1ZJU 7218 CHARACTER*4 IY2ZJU 7219C 7220 CHARACTER*4 IFOUND 7221 CHARACTER*4 IERROR 7222C 7223 CHARACTER*4 IHOLD 7224C 7225C--------------------------------------------------------------------- 7226C 7227 DIMENSION IHARG(*) 7228C 7229C-----COMMON---------------------------------------------------------- 7230C 7231 INCLUDE 'DPCOP2.INC' 7232C 7233C-----START POINT----------------------------------------------------- 7234C 7235 IFOUND='NO' 7236 IERROR='NO' 7237C 7238 IF(NUMARG.LE.1)GOTO1900 7239 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 7240 1IHARG(2).EQ.'JUST')GOTO1090 7241 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 7242 1IHARG(2).EQ.'LABE'.AND.IHARG(3).EQ.'JUST')GOTO1090 7243 GOTO1900 7244 1090 CONTINUE 7245C 7246C ***************************************************** 7247C ** TREAT THE CASE WHEN ** 7248C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 7249C ***************************************************** 7250C 7251 IF(ICOM.EQ.'XTIC')GOTO1100 7252 GOTO1199 7253C 7254 1100 CONTINUE 7255 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 7256 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 7257 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 7258 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 7259 IF(IHARG(NUMARG).EQ.'JUST')GOTO1150 7260 GOTO1160 7261C 7262 1150 CONTINUE 7263 IHOLD=IDEFJU 7264 GOTO1180 7265C 7266 1160 CONTINUE 7267 IHOLD=IHARG(NUMARG) 7268 GOTO1180 7269C 7270 1180 CONTINUE 7271 IFOUND='YES' 7272 IX1ZJU=IHOLD 7273 IX2ZJU=IHOLD 7274C 7275 IF(IFEEDB.EQ.'OFF')GOTO1189 7276 WRITE(ICOUT,999) 7277 999 FORMAT(1X) 7278 CALL DPWRST('XXX','BUG ') 7279 WRITE(ICOUT,1181) 7280 1181 FORMAT('THE TIC MARK LABEL JUSTIFICATION (FOR BOTH ', 7281 1'HORIZONTAL FRAME LINES)') 7282 CALL DPWRST('XXX','BUG ') 7283 WRITE(ICOUT,1182)IHOLD 7284 1182 FORMAT('HAS JUST BEEN SET TO ',A4) 7285 CALL DPWRST('XXX','BUG ') 7286 1189 CONTINUE 7287 GOTO1900 7288C 7289 1199 CONTINUE 7290C 7291C ************************************************************** 7292C ** TREAT THE CASE WHEN ** 7293C ** ONLY THE BOTTOM HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 7294C ************************************************************** 7295C 7296 IF(ICOM.EQ.'X1TI')GOTO1200 7297 GOTO1299 7298C 7299 1200 CONTINUE 7300 IF(IHARG(NUMARG).EQ.'ON')GOTO1250 7301 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 7302 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 7303 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 7304 IF(IHARG(NUMARG).EQ.'JUST')GOTO1250 7305 GOTO1260 7306C 7307 1250 CONTINUE 7308 IHOLD=IDEFJU 7309 GOTO1280 7310C 7311 1260 CONTINUE 7312 IHOLD=IHARG(NUMARG) 7313 GOTO1280 7314C 7315 1280 CONTINUE 7316 IFOUND='YES' 7317 IX1ZJU=IHOLD 7318C 7319 IF(IFEEDB.EQ.'OFF')GOTO1289 7320 WRITE(ICOUT,999) 7321 CALL DPWRST('XXX','BUG ') 7322 WRITE(ICOUT,1281) 7323 1281 FORMAT('THE TIC MARK LABEL JUSTIFICATION (FOR THE BOTTOM ', 7324 1'HORIZONTAL FRAME LINE)') 7325 CALL DPWRST('XXX','BUG ') 7326 WRITE(ICOUT,1282)IHOLD 7327 1282 FORMAT('HAS JUST BEEN SET TO ',A4) 7328 CALL DPWRST('XXX','BUG ') 7329 1289 CONTINUE 7330 GOTO1900 7331C 7332 1299 CONTINUE 7333C 7334C ************************************************************** 7335C ** TREAT THE CASE WHEN ** 7336C ** ONLY THE TOP HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 7337C ************************************************************** 7338C 7339 IF(ICOM.EQ.'X2TI')GOTO1300 7340 GOTO1399 7341C 7342 1300 CONTINUE 7343 IF(IHARG(NUMARG).EQ.'ON')GOTO1350 7344 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 7345 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 7346 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 7347 IF(IHARG(NUMARG).EQ.'JUST')GOTO1350 7348 GOTO1360 7349C 7350 1350 CONTINUE 7351 IHOLD=IDEFJU 7352 GOTO1380 7353C 7354 1360 CONTINUE 7355 IHOLD=IHARG(NUMARG) 7356 GOTO1380 7357C 7358 1380 CONTINUE 7359 IFOUND='YES' 7360 IX2ZJU=IHOLD 7361C 7362 IF(IFEEDB.EQ.'OFF')GOTO1389 7363 WRITE(ICOUT,999) 7364 CALL DPWRST('XXX','BUG ') 7365 WRITE(ICOUT,1381) 7366 1381 FORMAT('THE TIC MARK LABEL JUSTIFICATION (FOR THE TOP ', 7367 1'HORIZONTAL FRAME LINE)') 7368 CALL DPWRST('XXX','BUG ') 7369 WRITE(ICOUT,1382)IHOLD 7370 1382 FORMAT('HAS JUST BEEN SET TO ',A4) 7371 CALL DPWRST('XXX','BUG ') 7372 1389 CONTINUE 7373 GOTO1900 7374C 7375 1399 CONTINUE 7376C 7377C ***************************************************** 7378C ** TREAT THE CASE WHEN ** 7379C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 7380C ***************************************************** 7381C 7382 IF(ICOM.EQ.'YTIC')GOTO1400 7383 GOTO1499 7384C 7385 1400 CONTINUE 7386 IF(IHARG(NUMARG).EQ.'ON')GOTO1450 7387 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 7388 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 7389 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 7390 IF(IHARG(NUMARG).EQ.'JUST')GOTO1450 7391 GOTO1460 7392C 7393 1450 CONTINUE 7394 IHOLD=IDEFJU 7395 GOTO1480 7396C 7397 1460 CONTINUE 7398 IHOLD=IHARG(NUMARG) 7399 GOTO1480 7400C 7401 1480 CONTINUE 7402 IFOUND='YES' 7403 IY1ZJU=IHOLD 7404 IY2ZJU=IHOLD 7405C 7406 IF(IFEEDB.EQ.'OFF')GOTO1489 7407 WRITE(ICOUT,999) 7408 CALL DPWRST('XXX','BUG ') 7409 WRITE(ICOUT,1481) 7410 1481 FORMAT('THE TIC MARK LABEL JUSTIFICATION (FOR BOTH VERTICAL ', 7411 1'FRAME LINES)') 7412 CALL DPWRST('XXX','BUG ') 7413 WRITE(ICOUT,1482)IHOLD 7414 1482 FORMAT('HAS JUST BEEN SET TO ',A4) 7415 CALL DPWRST('XXX','BUG ') 7416 1489 CONTINUE 7417 GOTO1900 7418C 7419 1499 CONTINUE 7420C 7421C ************************************************************** 7422C ** TREAT THE CASE WHEN ** 7423C ** ONLY THE LEFT VERTICAL TIC MARKS ARE TO BE CHANGED ** 7424C ************************************************************** 7425C 7426 IF(ICOM.EQ.'Y1TI')GOTO1500 7427 GOTO1599 7428C 7429 1500 CONTINUE 7430 IF(IHARG(NUMARG).EQ.'ON')GOTO1550 7431 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 7432 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 7433 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 7434 IF(IHARG(NUMARG).EQ.'JUST')GOTO1550 7435 GOTO1560 7436C 7437 1550 CONTINUE 7438 IHOLD=IDEFJU 7439 GOTO1580 7440C 7441 1560 CONTINUE 7442 IHOLD=IHARG(NUMARG) 7443 GOTO1580 7444C 7445 1580 CONTINUE 7446 IFOUND='YES' 7447 IY1ZJU=IHOLD 7448C 7449 IF(IFEEDB.EQ.'OFF')GOTO1589 7450 WRITE(ICOUT,999) 7451 CALL DPWRST('XXX','BUG ') 7452 WRITE(ICOUT,1581) 7453 1581 FORMAT('THE TIC MARK LABEL JUSTIFICATION (FOR THE LEFT ', 7454 1'VERTICAL FRAME LINE)') 7455 CALL DPWRST('XXX','BUG ') 7456 WRITE(ICOUT,1582)IHOLD 7457 1582 FORMAT('HAS JUST BEEN SET TO ',A4) 7458 CALL DPWRST('XXX','BUG ') 7459 1589 CONTINUE 7460 GOTO1900 7461C 7462 1599 CONTINUE 7463C 7464C ************************************************************** 7465C ** TREAT THE CASE WHEN ** 7466C ** ONLY THE RIGHT VERTICAL TIC MARKS ARE TO BE CHANGED ** 7467C ************************************************************** 7468C 7469 IF(ICOM.EQ.'Y2TI')GOTO1600 7470 GOTO1699 7471C 7472 1600 CONTINUE 7473 IF(IHARG(NUMARG).EQ.'ON')GOTO1650 7474 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 7475 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 7476 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 7477 IF(IHARG(NUMARG).EQ.'JUST')GOTO1650 7478 GOTO1660 7479C 7480 1650 CONTINUE 7481 IHOLD=IDEFJU 7482 GOTO1680 7483C 7484 1660 CONTINUE 7485 IHOLD=IHARG(NUMARG) 7486 GOTO1680 7487C 7488 1680 CONTINUE 7489 IFOUND='YES' 7490 IY2ZJU=IHOLD 7491C 7492 IF(IFEEDB.EQ.'OFF')GOTO1689 7493 WRITE(ICOUT,999) 7494 CALL DPWRST('XXX','BUG ') 7495 WRITE(ICOUT,1681) 7496 1681 FORMAT('THE TIC MARK LABEL JUSTIFICATION (FOR THE RIGHT ', 7497 1'VERTICAL FRAME LINE)') 7498 CALL DPWRST('XXX','BUG ') 7499 WRITE(ICOUT,1682)IHOLD 7500 1682 FORMAT('HAS JUST BEEN SET TO ',A4) 7501 CALL DPWRST('XXX','BUG ') 7502 1689 CONTINUE 7503 GOTO1900 7504C 7505 1699 CONTINUE 7506C 7507C ***************************************************** 7508C ** TREAT THE CASE WHEN ** 7509C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 7510C ***************************************************** 7511C 7512 IF(ICOM.EQ.'TIC')GOTO1700 7513 IF(ICOM.EQ.'TICS')GOTO1700 7514 IF(ICOM.EQ.'XYTI')GOTO1700 7515 IF(ICOM.EQ.'YXTI')GOTO1700 7516 GOTO1799 7517C 7518 1700 CONTINUE 7519 IF(IHARG(NUMARG).EQ.'ON')GOTO1750 7520 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 7521 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 7522 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 7523 IF(IHARG(NUMARG).EQ.'JUST')GOTO1750 7524 GOTO1760 7525C 7526 1750 CONTINUE 7527 IHOLD=IDEFJU 7528 GOTO1780 7529C 7530 1760 CONTINUE 7531 IHOLD=IHARG(NUMARG) 7532 GOTO1780 7533C 7534 1780 CONTINUE 7535 IFOUND='YES' 7536 IX1ZJU=IHOLD 7537 IX2ZJU=IHOLD 7538 IY1ZJU=IHOLD 7539 IY2ZJU=IHOLD 7540C 7541 IF(IFEEDB.EQ.'OFF')GOTO1789 7542 WRITE(ICOUT,999) 7543 CALL DPWRST('XXX','BUG ') 7544 WRITE(ICOUT,1781) 7545 1781 FORMAT('THE TIC MARK LABEL JUSTIFICATION (FOR ALL 4 ', 7546 1'FRAME LINES)') 7547 CALL DPWRST('XXX','BUG ') 7548 WRITE(ICOUT,1782)IHOLD 7549 1782 FORMAT('HAS JUST BEEN SET TO ',A4) 7550 CALL DPWRST('XXX','BUG ') 7551 1789 CONTINUE 7552 GOTO1900 7553C 7554 1799 CONTINUE 7555C 7556 1900 CONTINUE 7557 RETURN 7558 END 7559 SUBROUTINE DPTLSZ(ICOM,IHARG,IARGT,ARG,NUMARG, 7560 1PDEFHE,PDEFWI, 7561 1PX1ZHE,PX1ZWI,PX1ZVG,PX1ZHG, 7562 1PX2ZHE,PX2ZWI,PX2ZVG,PX2ZHG, 7563 1PY1ZHE,PY1ZWI,PY1ZVG,PY1ZHG, 7564 1PY2ZHE,PY2ZWI,PY2ZVG,PY2ZHG, 7565 1IFOUND,IERROR) 7566C 7567C PURPOSE--DEFINE THE TIC MARK LABEL SIZE SWITCHES 7568C FOR ANY OF THE 4 FRAME LINES. 7569C SUCH TIC MARK SWITCHES DEFINE THE SIZE (HEIGHT) 7570C OF THE TIC MARK LABELS ON THE 4 FRAME LINES OF A PLOT. 7571C INPUT ARGUMENTS--ICOM 7572C --IHARG (A HOLLERITH VECTOR) 7573C --IARGT (A HOLLERITH VECTOR) 7574C --ARG (A FLOATING POINT VECTOR) 7575C --NUMARG 7576C --PDEFHE 7577C OUTPUT ARGUMENTS-- 7578C --PX1ZHE,PX1ZWI,PX1ZVG,PX1ZHG, 7579C --PX2ZHE,PX2ZWI,PX2ZVG,PX2ZHG, 7580C --PY1ZHE,PY1ZWI,PY1ZVG,PY1ZHG, 7581C --PY2ZHE,PY2ZWI,PY2ZVG,PY2ZHG, 7582C --IFOUND ('YES' OR 'NO' ) 7583C --IERROR ('YES' OR 'NO' ) 7584C WRITTEN BY--JAMES J. FILLIBEN 7585C STATISTICAL ENGINEERING DIVISION 7586C INFORMATION TECHNOLOGY LABORATORY 7587C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 7588C GAITHERSBURG, MD 20899-8980 7589C PHONE--301-975-2855 7590C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 7591C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 7592C LANGUAGE--ANSI FORTRAN (1977) 7593C VERSION NUMBER--82/7 7594C ORIGINAL VERSION--OCTOBER 1980. 7595C UPDATED --MAY 1982. 7596C UPDATED --DECEMBER 1988. DEFAULT WIDTH 7597C 7598C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 7599C 7600 CHARACTER*4 ICOM 7601 CHARACTER*4 IHARG 7602 CHARACTER*4 IARGT 7603 CHARACTER*4 IFOUND 7604 CHARACTER*4 IERROR 7605C 7606C--------------------------------------------------------------------- 7607C 7608 DIMENSION IHARG(*) 7609 DIMENSION IARGT(*) 7610 DIMENSION ARG(*) 7611C 7612C-----COMMON---------------------------------------------------------- 7613C 7614 INCLUDE 'DPCOP2.INC' 7615C 7616C-----START POINT----------------------------------------------------- 7617C 7618 IFOUND='NO' 7619 IERROR='NO' 7620C 7621CCCCC IF(NUMARG.LE.1)GOTO1900 7622 IF(NUMARG.LE.1)GOTO9000 7623 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 7624 1IHARG(2).EQ.'SIZE')GOTO1090 7625 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 7626 1IHARG(2).EQ.'LABE'.AND.IHARG(3).EQ.'SIZE')GOTO1090 7627CCCCC GOTO1900 7628 GOTO9000 7629 1090 CONTINUE 7630C 7631C ***************************************************** 7632C ** TREAT THE CASE WHEN ** 7633C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 7634C ***************************************************** 7635C 7636 IF(ICOM.EQ.'XTIC')GOTO1100 7637 GOTO1199 7638C 7639 1100 CONTINUE 7640 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 7641 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 7642 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 7643 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 7644 IF(IHARG(NUMARG).EQ.'SIZE')GOTO1150 7645 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 7646 IERROR='YES' 7647 GOTO9000 7648C 7649 1150 CONTINUE 7650 HOLD1=PDEFHE 7651 HOLD2=PDEFWI 7652 GOTO1180 7653C 7654 1160 CONTINUE 7655 HOLD1=ARG(NUMARG) 7656 HOLD2=HOLD1*0.5 7657 GOTO1180 7658C 7659 1180 CONTINUE 7660 IFOUND='YES' 7661 PX1ZHE=HOLD1 7662 PX2ZHE=HOLD1 7663 PX1ZWI=HOLD2 7664 PX2ZWI=HOLD2 7665C 7666 IF(IFEEDB.EQ.'OFF')GOTO1189 7667 WRITE(ICOUT,999) 7668 999 FORMAT(1X) 7669 CALL DPWRST('XXX','BUG ') 7670 WRITE(ICOUT,1181) 7671 1181 FORMAT('THE TIC MARK LABEL SIZE (FOR BOTH HORIZONTAL ', 7672 1'FRAME LINES)') 7673 CALL DPWRST('XXX','BUG ') 7674 WRITE(ICOUT,1182)HOLD1 7675 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7) 7676 CALL DPWRST('XXX','BUG ') 7677 1189 CONTINUE 7678 GOTO1900 7679C 7680 1199 CONTINUE 7681C 7682C ************************************************************** 7683C ** TREAT THE CASE WHEN ** 7684C ** ONLY THE BOTTOM HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 7685C ************************************************************** 7686C 7687 IF(ICOM.EQ.'X1TI')GOTO1200 7688 GOTO1299 7689C 7690 1200 CONTINUE 7691 IF(IHARG(NUMARG).EQ.'ON')GOTO1250 7692 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 7693 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 7694 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 7695 IF(IHARG(NUMARG).EQ.'SIZE')GOTO1250 7696 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1260 7697 IERROR='YES' 7698 GOTO9000 7699C 7700 1250 CONTINUE 7701 HOLD1=PDEFHE 7702 HOLD2=PDEFWI 7703 GOTO1280 7704C 7705 1260 CONTINUE 7706 HOLD1=ARG(NUMARG) 7707 HOLD2=HOLD1*0.5 7708 GOTO1280 7709C 7710 1280 CONTINUE 7711 IFOUND='YES' 7712 PX1ZHE=HOLD1 7713 PX1ZWI=HOLD2 7714C 7715 IF(IFEEDB.EQ.'OFF')GOTO1289 7716 WRITE(ICOUT,999) 7717 CALL DPWRST('XXX','BUG ') 7718 WRITE(ICOUT,1281) 7719 1281 FORMAT('THE TIC MARK LABEL SIZE (FOR THE BOTTOM HORIZONTAL ', 7720 1'FRAME LINE)') 7721 CALL DPWRST('XXX','BUG ') 7722 WRITE(ICOUT,1282)HOLD1 7723 1282 FORMAT('HAS JUST BEEN SET TO ',E15.7) 7724 CALL DPWRST('XXX','BUG ') 7725 1289 CONTINUE 7726 GOTO1900 7727C 7728 1299 CONTINUE 7729C 7730C ************************************************************** 7731C ** TREAT THE CASE WHEN ** 7732C ** ONLY THE TOP HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 7733C ************************************************************** 7734C 7735 IF(ICOM.EQ.'X2TI')GOTO1300 7736 GOTO1399 7737C 7738 1300 CONTINUE 7739 IF(IHARG(NUMARG).EQ.'ON')GOTO1350 7740 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 7741 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 7742 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 7743 IF(IHARG(NUMARG).EQ.'SIZE')GOTO1350 7744 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1360 7745 IERROR='YES' 7746 GOTO9000 7747C 7748 1350 CONTINUE 7749 HOLD1=PDEFHE 7750 HOLD2=PDEFWI 7751 GOTO1380 7752C 7753 1360 CONTINUE 7754 HOLD1=ARG(NUMARG) 7755 HOLD2=HOLD1*0.5 7756 GOTO1380 7757C 7758 1380 CONTINUE 7759 IFOUND='YES' 7760 PX2ZHE=HOLD1 7761 PX2ZWI=HOLD2 7762C 7763 IF(IFEEDB.EQ.'OFF')GOTO1389 7764 WRITE(ICOUT,999) 7765 CALL DPWRST('XXX','BUG ') 7766 WRITE(ICOUT,1381) 7767 1381 FORMAT('THE TIC MARK LABEL SIZE (FOR THE TOP HORIZONTAL ', 7768 1'FRAME LINE)') 7769 CALL DPWRST('XXX','BUG ') 7770 WRITE(ICOUT,1382)HOLD1 7771 1382 FORMAT('HAS JUST BEEN SET TO ',E15.7) 7772 CALL DPWRST('XXX','BUG ') 7773 1389 CONTINUE 7774 GOTO1900 7775C 7776 1399 CONTINUE 7777C 7778C ***************************************************** 7779C ** TREAT THE CASE WHEN ** 7780C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 7781C ***************************************************** 7782C 7783 IF(ICOM.EQ.'YTIC')GOTO1400 7784 GOTO1499 7785C 7786 1400 CONTINUE 7787 IF(IHARG(NUMARG).EQ.'ON')GOTO1450 7788 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 7789 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 7790 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 7791 IF(IHARG(NUMARG).EQ.'SIZE')GOTO1450 7792 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1460 7793 IERROR='YES' 7794 GOTO9000 7795C 7796 1450 CONTINUE 7797 HOLD1=PDEFHE 7798 HOLD2=PDEFWI 7799 GOTO1480 7800C 7801 1460 CONTINUE 7802 HOLD1=ARG(NUMARG) 7803 HOLD2=HOLD1*0.5 7804 GOTO1480 7805C 7806 1480 CONTINUE 7807 IFOUND='YES' 7808 PY1ZHE=HOLD1 7809 PY2ZHE=HOLD1 7810 PY1ZWI=HOLD2 7811 PY2ZWI=HOLD2 7812C 7813 IF(IFEEDB.EQ.'OFF')GOTO1489 7814 WRITE(ICOUT,999) 7815 CALL DPWRST('XXX','BUG ') 7816 WRITE(ICOUT,1481) 7817 1481 FORMAT('THE TIC MARK LABEL SIZE (FOR BOTH VERTICAL ', 7818 1'FRAME LINES)') 7819 CALL DPWRST('XXX','BUG ') 7820 WRITE(ICOUT,1482)HOLD1 7821 1482 FORMAT('HAS JUST BEEN SET TO ',E15.7) 7822 CALL DPWRST('XXX','BUG ') 7823 1489 CONTINUE 7824 GOTO1900 7825C 7826 1499 CONTINUE 7827C 7828C ************************************************************** 7829C ** TREAT THE CASE WHEN ** 7830C ** ONLY THE LEFT VERTICAL TIC MARKS ARE TO BE CHANGED ** 7831C ************************************************************** 7832C 7833 IF(ICOM.EQ.'Y1TI')GOTO1500 7834 GOTO1599 7835C 7836 1500 CONTINUE 7837 IF(IHARG(NUMARG).EQ.'ON')GOTO1550 7838 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 7839 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 7840 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 7841 IF(IHARG(NUMARG).EQ.'SIZE')GOTO1550 7842 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1560 7843 IERROR='YES' 7844 GOTO9000 7845C 7846 1550 CONTINUE 7847 HOLD1=PDEFHE 7848 HOLD2=PDEFWI 7849 GOTO1580 7850C 7851 1560 CONTINUE 7852 HOLD1=ARG(NUMARG) 7853 HOLD2=HOLD1*0.5 7854 GOTO1580 7855C 7856 1580 CONTINUE 7857 IFOUND='YES' 7858 PY1ZHE=HOLD1 7859 PY1ZWI=HOLD2 7860C 7861 IF(IFEEDB.EQ.'OFF')GOTO1589 7862 WRITE(ICOUT,999) 7863 CALL DPWRST('XXX','BUG ') 7864 WRITE(ICOUT,1581) 7865 1581 FORMAT('THE TIC MARK LABEL SIZE (FOR THE LEFT VERTICAL ', 7866 1'FRAME LINE)') 7867 CALL DPWRST('XXX','BUG ') 7868 WRITE(ICOUT,1582)HOLD1 7869 1582 FORMAT('HAS JUST BEEN SET TO ',E15.7) 7870 CALL DPWRST('XXX','BUG ') 7871 1589 CONTINUE 7872 GOTO1900 7873C 7874 1599 CONTINUE 7875C 7876C ************************************************************** 7877C ** TREAT THE CASE WHEN ** 7878C ** ONLY THE RIGHT VERTICAL TIC MARKS ARE TO BE CHANGED ** 7879C ************************************************************** 7880C 7881 IF(ICOM.EQ.'Y2TI')GOTO1600 7882 GOTO1699 7883C 7884 1600 CONTINUE 7885 IF(IHARG(NUMARG).EQ.'ON')GOTO1650 7886 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 7887 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 7888 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 7889 IF(IHARG(NUMARG).EQ.'SIZE')GOTO1650 7890 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1660 7891 IERROR='YES' 7892 GOTO9000 7893C 7894 1650 CONTINUE 7895 HOLD1=PDEFHE 7896 HOLD2=PDEFWI 7897 GOTO1680 7898C 7899 1660 CONTINUE 7900 HOLD1=ARG(NUMARG) 7901 HOLD2=HOLD1*0.5 7902 GOTO1680 7903C 7904 1680 CONTINUE 7905 IFOUND='YES' 7906 PY2ZHE=HOLD1 7907 PY2ZWI=HOLD2 7908C 7909 IF(IFEEDB.EQ.'OFF')GOTO1689 7910 WRITE(ICOUT,999) 7911 CALL DPWRST('XXX','BUG ') 7912 WRITE(ICOUT,1681) 7913 1681 FORMAT('THE TIC MARK LABEL SIZE (FOR THE RIGHT VERTICAL ', 7914 1'FRAME LINE)') 7915 CALL DPWRST('XXX','BUG ') 7916 WRITE(ICOUT,1682)HOLD1 7917 1682 FORMAT('HAS JUST BEEN SET TO ',E15.7) 7918 CALL DPWRST('XXX','BUG ') 7919 1689 CONTINUE 7920 GOTO1900 7921C 7922 1699 CONTINUE 7923C 7924C ***************************************************** 7925C ** TREAT THE CASE WHEN ** 7926C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 7927C ***************************************************** 7928C 7929 IF(ICOM.EQ.'TIC')GOTO1700 7930 IF(ICOM.EQ.'TICS')GOTO1700 7931 IF(ICOM.EQ.'XYTI')GOTO1700 7932 IF(ICOM.EQ.'YXTI')GOTO1700 7933 GOTO1799 7934C 7935 1700 CONTINUE 7936 IF(IHARG(NUMARG).EQ.'ON')GOTO1750 7937 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 7938 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 7939 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 7940 IF(IHARG(NUMARG).EQ.'SIZE')GOTO1750 7941 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1760 7942 IERROR='YES' 7943 GOTO9000 7944C 7945 1750 CONTINUE 7946 HOLD1=PDEFHE 7947 HOLD2=PDEFWI 7948 GOTO1780 7949C 7950 1760 CONTINUE 7951 HOLD1=ARG(NUMARG) 7952 HOLD2=HOLD1*0.5 7953 GOTO1780 7954C 7955 1780 CONTINUE 7956 IFOUND='YES' 7957 PX1ZHE=HOLD1 7958 PX2ZHE=HOLD1 7959 PY1ZHE=HOLD1 7960 PY2ZHE=HOLD1 7961 PX1ZWI=HOLD2 7962 PX2ZWI=HOLD2 7963 PY1ZWI=HOLD2 7964 PY2ZWI=HOLD2 7965C 7966 IF(IFEEDB.EQ.'OFF')GOTO1789 7967 WRITE(ICOUT,999) 7968 CALL DPWRST('XXX','BUG ') 7969 WRITE(ICOUT,1781) 7970 1781 FORMAT('THE TIC MARK LABEL SIZE (FOR ALL 4 ', 7971 1'FRAME LINES)') 7972 CALL DPWRST('XXX','BUG ') 7973 WRITE(ICOUT,1782)HOLD1 7974 1782 FORMAT('HAS JUST BEEN SET TO ',E15.7) 7975 CALL DPWRST('XXX','BUG ') 7976 1789 CONTINUE 7977 GOTO1900 7978C 7979 1799 CONTINUE 7980C 7981 1900 CONTINUE 7982C 7983 PX1ZVG=PX1ZHE*0.375 7984 PX2ZVG=PX2ZHE*0.375 7985 PY1ZVG=PY1ZHE*0.375 7986 PY2ZVG=PY2ZHE*0.375 7987C 7988 PX1ZHG=PX1ZHE*0.125 7989 PX2ZHG=PX2ZHE*0.125 7990 PY1ZHG=PY1ZHE*0.125 7991 PY2ZHG=PY2ZHE*0.125 7992 GOTO9000 7993C 7994 9000 CONTINUE 7995 RETURN 7996 END 7997 SUBROUTINE DPTLTH(ICOM,IHARG,ARG,NUMARG, 7998 1PDEFTH, 7999 1PTIZTH, 8000 1IFOUND,IERROR) 8001C 8002C PURPOSE--DEFINE THE 4 TIC LABEL THICKNESSS CONTAINED IN THE 8003C 4 VARIABLES PTIZTH,PTIZTH,PTIZTH,PTIZTH 8004C SUCH TIC LABEL THICKNESSS DEFINE THE THICKNESSS FOR 8005C THE TIC LABELS ON THE 4 FRAME LINES OF A PLOT. 8006C NOTE: ALL 4 THICKNESS CURRENTLY LIMITED TO ONE 8007C SETTING, PTIZTH 8008C INPUT ARGUMENTS--ICOM 8009C --IHARG (A HOLLERITH VECTOR) 8010C --ARG (A REAL VECTOR) 8011C --NUMARG 8012C --PDEFTH 8013C OUTPUT ARGUMENTS-- 8014C --PTIZTH = LOWER HORIZONTAL TIC LABEL THICKNESS 8015C --PTIZTH = UPPER HORIZONTAL TIC LABEL THICKNESS 8016C --PTIZTH = LEFT VERTICAL TIC LABEL THICKNESS 8017C --PTIZTH = RIGHT VERTICAL TIC LABEL THICKNESS 8018C --IFOUND ('YES' OR 'NO' ) 8019C --IERROR ('YES' OR 'NO' ) 8020C WRITTEN BY--ALAN HECKERT 8021C STATISTICAL ENGINEERING DIVISION 8022C INFORMATION TECHNOLOGY LABORATORY 8023C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 8024C GAITHERSBURG, MD 20899-8980 8025C PHONE--301-975-2899 8026C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 8027C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 8028C LANGUAGE--ANSI FORTRAN (1977) 8029C VERSION NUMBER--89/2 8030C ORIGINAL VERSION--JANUARY 1989. 8031C 8032C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 8033C 8034 CHARACTER*4 ICOM 8035 CHARACTER*4 IHARG 8036C 8037C 8038 CHARACTER*4 IFOUND 8039 CHARACTER*4 IERROR 8040C 8041C--------------------------------------------------------------------- 8042C 8043 DIMENSION IHARG(*) 8044 DIMENSION ARG(*) 8045C 8046C-----COMMON---------------------------------------------------------- 8047C 8048 INCLUDE 'DPCOP2.INC' 8049C 8050C-----START POINT----------------------------------------------------- 8051C 8052 IFOUND='NO' 8053 IERROR='NO' 8054C 8055 IF(NUMARG.LE.1)GOTO1900 8056 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 8057 1IHARG(2).EQ.'THIC')GOTO1090 8058 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 8059 1IHARG(2).EQ.'LABE'.AND.IHARG(3).EQ.'THIC')GOTO1090 8060 GOTO1900 8061 1090 CONTINUE 8062C 8063C ***************************************************** 8064C ** TREAT THE CASE WHEN ** 8065C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 8066C ***************************************************** 8067C 8068 IF(ICOM.EQ.'XTIC')GOTO1100 8069 GOTO1199 8070C 8071 1100 CONTINUE 8072 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 8073 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 8074 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 8075 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 8076 IF(IHARG(NUMARG).EQ.'THIC')GOTO1150 8077 GOTO1160 8078C 8079 1150 CONTINUE 8080 PHOLD=PDEFTH 8081 GOTO1180 8082C 8083 1160 CONTINUE 8084 PHOLD=ARG(NUMARG) 8085 GOTO1180 8086C 8087 1180 CONTINUE 8088 IFOUND='YES' 8089 PTIZTH=PHOLD 8090C 8091 IF(IFEEDB.EQ.'OFF')GOTO1189 8092 WRITE(ICOUT,999) 8093 999 FORMAT(1X) 8094 CALL DPWRST('XXX','BUG ') 8095 WRITE(ICOUT,1181) 8096 1181 FORMAT('THE TIC MARK LABEL THICKNESS (FOR ALL ', 8097 1'FRAME LINES)') 8098 CALL DPWRST('XXX','BUG ') 8099 WRITE(ICOUT,1182)PHOLD 8100 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7) 8101 CALL DPWRST('XXX','BUG ') 8102 1189 CONTINUE 8103 GOTO1900 8104C 8105 1199 CONTINUE 8106C 8107C ************************************************************** 8108C ** TREAT THE CASE WHEN ** 8109C ** ONLY THE BOTTOM HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 8110C ************************************************************** 8111C 8112 IF(ICOM.EQ.'X1TI')GOTO1200 8113 GOTO1299 8114C 8115 1200 CONTINUE 8116 IF(IHARG(NUMARG).EQ.'ON')GOTO1250 8117 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 8118 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 8119 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 8120 IF(IHARG(NUMARG).EQ.'THIC')GOTO1250 8121 GOTO1260 8122C 8123 1250 CONTINUE 8124 PHOLD=PDEFTH 8125 GOTO1280 8126C 8127 1260 CONTINUE 8128 PHOLD=ARG(NUMARG) 8129 GOTO1280 8130C 8131 1280 CONTINUE 8132 IFOUND='YES' 8133 PTIZTH=PHOLD 8134C 8135 IF(IFEEDB.EQ.'OFF')GOTO1289 8136 WRITE(ICOUT,999) 8137 CALL DPWRST('XXX','BUG ') 8138 WRITE(ICOUT,1281) 8139 1281 FORMAT('THE TIC MARK LABEL THICKNESS (ALL ', 8140 1'FRAME LINES)') 8141 CALL DPWRST('XXX','BUG ') 8142 WRITE(ICOUT,1282)PHOLD 8143 1282 FORMAT('HAS JUST BEEN SET TO ',E15.7) 8144 CALL DPWRST('XXX','BUG ') 8145 1289 CONTINUE 8146 GOTO1900 8147C 8148 1299 CONTINUE 8149C 8150C ************************************************************** 8151C ** TREAT THE CASE WHEN ** 8152C ** ONLY THE TOP HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 8153C ************************************************************** 8154C 8155 IF(ICOM.EQ.'X2TI')GOTO1300 8156 GOTO1399 8157C 8158 1300 CONTINUE 8159 IF(IHARG(NUMARG).EQ.'ON')GOTO1350 8160 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 8161 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 8162 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 8163 IF(IHARG(NUMARG).EQ.'THIC')GOTO1350 8164 GOTO1360 8165C 8166 1350 CONTINUE 8167 PHOLD=PDEFTH 8168 GOTO1380 8169C 8170 1360 CONTINUE 8171 PHOLD=ARG(NUMARG) 8172 GOTO1380 8173C 8174 1380 CONTINUE 8175 IFOUND='YES' 8176 PTIZTH=PHOLD 8177C 8178 IF(IFEEDB.EQ.'OFF')GOTO1389 8179 WRITE(ICOUT,999) 8180 CALL DPWRST('XXX','BUG ') 8181 WRITE(ICOUT,1381) 8182 1381 FORMAT('THE TIC MARK LABEL THICKNESS (FOR ALL ', 8183 1'FRAME LINES)') 8184 CALL DPWRST('XXX','BUG ') 8185 WRITE(ICOUT,1382)PHOLD 8186 1382 FORMAT('HAS JUST BEEN SET TO ',E15.7) 8187 CALL DPWRST('XXX','BUG ') 8188 1389 CONTINUE 8189 GOTO1900 8190C 8191 1399 CONTINUE 8192C 8193C ***************************************************** 8194C ** TREAT THE CASE WHEN ** 8195C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 8196C ***************************************************** 8197C 8198 IF(ICOM.EQ.'YTIC')GOTO1400 8199 GOTO1499 8200C 8201 1400 CONTINUE 8202 IF(IHARG(NUMARG).EQ.'ON')GOTO1450 8203 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 8204 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 8205 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 8206 IF(IHARG(NUMARG).EQ.'THIC')GOTO1450 8207 GOTO1460 8208C 8209 1450 CONTINUE 8210 PHOLD=PDEFTH 8211 GOTO1480 8212C 8213 1460 CONTINUE 8214 PHOLD=ARG(NUMARG) 8215 GOTO1480 8216C 8217 1480 CONTINUE 8218 IFOUND='YES' 8219 PTIZTH=PHOLD 8220C 8221 IF(IFEEDB.EQ.'OFF')GOTO1489 8222 WRITE(ICOUT,999) 8223 CALL DPWRST('XXX','BUG ') 8224 WRITE(ICOUT,1481) 8225 1481 FORMAT('THE TIC MARK LABEL THICKNESS (FOR ALL ', 8226 1'FRAME LINES)') 8227 CALL DPWRST('XXX','BUG ') 8228 WRITE(ICOUT,1482)PHOLD 8229 1482 FORMAT('HAS JUST BEEN SET TO ',E15.7) 8230 CALL DPWRST('XXX','BUG ') 8231 1489 CONTINUE 8232 GOTO1900 8233C 8234 1499 CONTINUE 8235C 8236C ************************************************************** 8237C ** TREAT THE CASE WHEN ** 8238C ** ONLY THE LEFT VERTICAL TIC MARKS ARE TO BE CHANGED ** 8239C ************************************************************** 8240C 8241 IF(ICOM.EQ.'Y1TI')GOTO1500 8242 GOTO1599 8243C 8244 1500 CONTINUE 8245 IF(IHARG(NUMARG).EQ.'ON')GOTO1550 8246 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 8247 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 8248 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 8249 IF(IHARG(NUMARG).EQ.'THIC')GOTO1550 8250 GOTO1560 8251C 8252 1550 CONTINUE 8253 PHOLD=PDEFTH 8254 GOTO1580 8255C 8256 1560 CONTINUE 8257 PHOLD=ARG(NUMARG) 8258 GOTO1580 8259C 8260 1580 CONTINUE 8261 IFOUND='YES' 8262 PTIZTH=PHOLD 8263C 8264 IF(IFEEDB.EQ.'OFF')GOTO1589 8265 WRITE(ICOUT,999) 8266 CALL DPWRST('XXX','BUG ') 8267 WRITE(ICOUT,1581) 8268 1581 FORMAT('THE TIC MARK LABEL THICKNESS (FOR ALL ', 8269 1'FRAME LINES)') 8270 CALL DPWRST('XXX','BUG ') 8271 WRITE(ICOUT,1582)PHOLD 8272 1582 FORMAT('HAS JUST BEEN SET TO ',E15.7) 8273 CALL DPWRST('XXX','BUG ') 8274 1589 CONTINUE 8275 GOTO1900 8276C 8277 1599 CONTINUE 8278C 8279C ************************************************************** 8280C ** TREAT THE CASE WHEN ** 8281C ** ONLY THE RIGHT VERTICAL TIC MARKS ARE TO BE CHANGED ** 8282C ************************************************************** 8283C 8284 IF(ICOM.EQ.'Y2TI')GOTO1600 8285 GOTO1699 8286C 8287 1600 CONTINUE 8288 IF(IHARG(NUMARG).EQ.'ON')GOTO1650 8289 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 8290 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 8291 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 8292 IF(IHARG(NUMARG).EQ.'THIC')GOTO1650 8293 GOTO1660 8294C 8295 1650 CONTINUE 8296 PHOLD=PDEFTH 8297 GOTO1680 8298C 8299 1660 CONTINUE 8300 PHOLD=ARG(NUMARG) 8301 GOTO1680 8302C 8303 1680 CONTINUE 8304 IFOUND='YES' 8305 PTIZTH=PHOLD 8306C 8307 IF(IFEEDB.EQ.'OFF')GOTO1689 8308 WRITE(ICOUT,999) 8309 CALL DPWRST('XXX','BUG ') 8310 WRITE(ICOUT,1681) 8311 1681 FORMAT('THE TIC MARK LABEL THICKNESS (FOR ALL ', 8312 1'FRAME LINES)') 8313 CALL DPWRST('XXX','BUG ') 8314 WRITE(ICOUT,1682)PHOLD 8315 1682 FORMAT('HAS JUST BEEN SET TO ',E15.7) 8316 CALL DPWRST('XXX','BUG ') 8317 1689 CONTINUE 8318 GOTO1900 8319C 8320 1699 CONTINUE 8321C 8322C ***************************************************** 8323C ** TREAT THE CASE WHEN ** 8324C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 8325C ***************************************************** 8326C 8327 IF(ICOM.EQ.'TIC')GOTO1700 8328 IF(ICOM.EQ.'TICS')GOTO1700 8329 IF(ICOM.EQ.'XYTI')GOTO1700 8330 IF(ICOM.EQ.'YXTI')GOTO1700 8331 GOTO1799 8332C 8333 1700 CONTINUE 8334 IF(IHARG(NUMARG).EQ.'ON')GOTO1750 8335 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 8336 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 8337 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 8338 IF(IHARG(NUMARG).EQ.'THIC')GOTO1750 8339 GOTO1760 8340C 8341 1750 CONTINUE 8342 PHOLD=PDEFTH 8343 GOTO1780 8344C 8345 1760 CONTINUE 8346 PHOLD=ARG(NUMARG) 8347 GOTO1780 8348C 8349 1780 CONTINUE 8350 IFOUND='YES' 8351 PTIZTH=PHOLD 8352C 8353 IF(IFEEDB.EQ.'OFF')GOTO1789 8354 WRITE(ICOUT,999) 8355 CALL DPWRST('XXX','BUG ') 8356 WRITE(ICOUT,1781) 8357 1781 FORMAT('THE TIC MARK LABEL THICKNESS (FOR ALL 4 ', 8358 1'FRAME LINES)') 8359 CALL DPWRST('XXX','BUG ') 8360 WRITE(ICOUT,1782)PHOLD 8361 1782 FORMAT('HAS JUST BEEN SET TO ',E15.7) 8362 CALL DPWRST('XXX','BUG ') 8363 1789 CONTINUE 8364 GOTO1900 8365C 8366 1799 CONTINUE 8367C 8368 1900 CONTINUE 8369 RETURN 8370 END 8371 SUBROUTINE DPTMCO(XTEMP1,XTEMP2,MAXNXT,ICASAN, 8372 1 ICAPSW,IFORSW,IMULT,IREPL, 8373 1 ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) 8374C 8375C PURPOSE--GENERATE CONFIDENCE LIMITS FOR THE TRIMMED MEAN 8376C FOR PROBABILITY VALUE P = .90, .95, .99, .999, AND .9999. 8377C WRITTEN BY--ALAN HECKERT 8378C STATISTICAL ENGINEERING DIVISION 8379C INFORMATION TECHNOLOGY LABORATORY 8380C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 8381C GAITHERSBURG, MD 20899-8980 8382C PHONE--301-975-2899 8383C REFERENCE--"INTRODUCTION TO ROBUST ESTIMATION AND HYPOTHESIS 8384C TESTING", RAND R. WILCOX, ACADEMIC PRESS, 1997. 8385C 1977. 8386C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 8387C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 8388C LANGUAGE--ANSI FORTRAN (1977) 8389C VERSION NUMBER--2003/2 8390C ORIGINAL VERSION--FEBRUARY 2003. 8391C UPDATED --OCTOBER 2003. ADD SUPPORT FOR HTML, LATEX 8392C OUTPUT 8393C UPDATED --MARCH 2010. USE DPDTA1, DPDTA4 TO GENERATE 8394C HTML, LATEX, RTF FORMAT 8395C UPDATED --MARCH 2010. SUPPORT FOR MULTIPLE RESPONSE 8396C VARIABLES AND FOR GROUP-ID 8397C VARIABLES (I.E., REPLICATION 8398C CASE) 8399C UPDATED --MARCH 2010. USE DPPAR3 TO EXTRACT EITHER A 8400C RESPONSE VARIABLE OR A MATRIX 8401C NAME 8402C UPDATED --OCTOBER 2012. TRIMMING CAN BE SPECIFIED EITHER 8403C AS A PROPORTION OR AS A SPECIFIC 8404C NUMBER TO TRIM 8405C UPDATED --AUGUST 2019. ADD CTL999, CTU999 8406C 8407C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 8408C 8409 CHARACTER*4 ICAPSW 8410 CHARACTER*4 IFORSW 8411 CHARACTER*4 IBUGA2 8412 CHARACTER*4 IBUGA3 8413 CHARACTER*4 IBUGQ 8414 CHARACTER*4 ISUBRO 8415 CHARACTER*4 IFOUND 8416 CHARACTER*4 IERROR 8417C 8418 CHARACTER*4 IHWUSE 8419 CHARACTER*4 MESSAG 8420 CHARACTER*4 ICASEQ 8421 CHARACTER*4 IH 8422 CHARACTER*4 IH2 8423 CHARACTER*4 ICASAN 8424 CHARACTER*4 ICASE 8425 CHARACTER*4 ISUBN1 8426 CHARACTER*4 ISUBN2 8427 CHARACTER*4 ISTEPN 8428 CHARACTER*4 IFLAGU 8429 CHARACTER*4 IREPL 8430 CHARACTER*4 IMULT 8431C 8432 LOGICAL IFRST 8433 LOGICAL ILAST 8434C 8435 CHARACTER*40 INAME 8436 PARAMETER (MAXSPN=30) 8437 CHARACTER*4 IVARN1(MAXSPN) 8438 CHARACTER*4 IVARN2(MAXSPN) 8439 CHARACTER*4 IVARTY(MAXSPN) 8440 CHARACTER*4 IVARID(MAXSPN) 8441 CHARACTER*4 IVARI2(MAXSPN) 8442 REAL PVAR(MAXSPN) 8443 REAL PID(MAXSPN) 8444 INTEGER ILIS(MAXSPN) 8445 INTEGER NRIGHT(MAXSPN) 8446 INTEGER ICOLR(MAXSPN) 8447C 8448C--------------------------------------------------------------------- 8449C 8450 INCLUDE 'DPCOPA.INC' 8451C 8452 DIMENSION XTEMP1(*) 8453 DIMENSION XTEMP2(*) 8454 DIMENSION W(MAXOBV) 8455 DIMENSION TEMP1(MAXOBV) 8456 DIMENSION TEMP2(MAXOBV) 8457C 8458 DIMENSION XDESGN(MAXOBV,6) 8459 DIMENSION XIDTEM(MAXOBV) 8460 DIMENSION XIDTE2(MAXOBV) 8461 DIMENSION XIDTE3(MAXOBV) 8462 DIMENSION XIDTE4(MAXOBV) 8463 DIMENSION XIDTE5(MAXOBV) 8464 DIMENSION XIDTE6(MAXOBV) 8465C 8466 INCLUDE 'DPCOZZ.INC' 8467 EQUIVALENCE (GARBAG(IGARB1),XIDTEM(1)) 8468 EQUIVALENCE (GARBAG(IGARB2),XIDTE2(1)) 8469 EQUIVALENCE (GARBAG(IGARB3),XIDTE3(1)) 8470 EQUIVALENCE (GARBAG(IGARB4),XIDTE4(1)) 8471 EQUIVALENCE (GARBAG(IGARB5),XIDTE5(1)) 8472 EQUIVALENCE (GARBAG(IGARB6),XIDTE6(1)) 8473 EQUIVALENCE (GARBAG(IGARB7),TEMP1(1)) 8474 EQUIVALENCE (GARBAG(IGARB8),TEMP2(1)) 8475 EQUIVALENCE (GARBAG(IGARB9),W(1)) 8476 EQUIVALENCE (GARBAG(IGAR10),XDESGN(1,1)) 8477C 8478C-----COMMON---------------------------------------------------------- 8479C 8480 INCLUDE 'DPCOHK.INC' 8481 INCLUDE 'DPCOSU.INC' 8482 INCLUDE 'DPCODA.INC' 8483 INCLUDE 'DPCOHO.INC' 8484 INCLUDE 'DPCOST.INC' 8485 INCLUDE 'DPCOP2.INC' 8486C 8487C-----START POINT----------------------------------------------------- 8488C 8489 ISUBN1='DPTM' 8490 ISUBN2='CO ' 8491 IFOUND='YES' 8492 IERROR='NO' 8493C 8494 MAXCP1=MAXCOL+1 8495 MAXCP2=MAXCOL+2 8496 MAXCP3=MAXCOL+3 8497 MAXCP4=MAXCOL+4 8498 MAXCP5=MAXCOL+5 8499 MAXCP6=MAXCOL+6 8500C 8501C ***************************************************** 8502C ** TREAT THE TRIMMED MEAN CONFIDENCE LIMITS CASE ** 8503C ***************************************************** 8504C 8505 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TMCO')THEN 8506 WRITE(ICOUT,999) 8507 999 FORMAT(1X) 8508 CALL DPWRST('XXX','BUG ') 8509 WRITE(ICOUT,51) 8510 51 FORMAT('***** AT THE BEGINNING OF DPTMCO--') 8511 CALL DPWRST('XXX','BUG ') 8512 WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ICASAN,MAXNXT 8513 52 FORMAT('IBUGA2,IBUGA3,IBUGQ,ICASAN,MAXNXT = ',4(A4,2X),I8) 8514 CALL DPWRST('XXX','BUG ') 8515 ENDIF 8516C 8517C ********************************* 8518C ** STEP 1-- ** 8519C ** EXTRACT THE VARIABLE LIST ** 8520C ********************************* 8521C 8522 ISTEPN='1' 8523 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TMCO') 8524 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8525C 8526 INAME='TRIMMED MEAN CONFIDENCE LIMITS' 8527 MAXNA=100 8528 MINNVA=1 8529 MAXNVA=100 8530 MINNA=1 8531 IFLAGE=1 8532 IF(IREPL.EQ.'ON')THEN 8533 MAXNVA=7 8534 ELSE 8535 MAXNVA=100 8536 IFLAGE=0 8537 ENDIF 8538 MINN2=2 8539 IFLAGM=1 8540 IFLAGP=0 8541 JMIN=1 8542 JMAX=NUMARG 8543C 8544 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 8545 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 8546 1 JMIN,JMAX, 8547 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 8548 1 IVARN1,IVARN2,IVARTY,PVAR, 8549 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 8550 1 MINNVA,MAXNVA, 8551 1 IFLAGM,IFLAGP, 8552 1 IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 8553 IF(IERROR.EQ.'YES')GOTO9000 8554C 8555 IF(NUMVAR.GT.1 .AND. IREPL.EQ.'OFF')IMULT='ON' 8556C 8557 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TMCO')THEN 8558 WRITE(ICOUT,999) 8559 CALL DPWRST('XXX','BUG ') 8560 WRITE(ICOUT,181) 8561 181 FORMAT('***** AFTER CALL DPPARS--') 8562 CALL DPWRST('XXX','BUG ') 8563 WRITE(ICOUT,182)NQ,NUMVAR,IMULT,IREPL 8564 182 FORMAT('NQ,NUMVAR,IMULT,IREPL = ',2I8,2X,A4,2X,A4) 8565 CALL DPWRST('XXX','BUG ') 8566 IF(NUMVAR.GT.0)THEN 8567 DO185I=1,NUMVAR 8568 WRITE(ICOUT,187)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 8569 1 ICOLR(I) 8570 187 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 8571 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 8572 CALL DPWRST('XXX','BUG ') 8573 185 CONTINUE 8574 ENDIF 8575 ENDIF 8576C 8577C *********************************************** 8578C ** STEP 2-- ** 8579C ** DETERMINE: ** 8580C ** 1) NUMBER OF REPLICATION VARIABLES (0-6) ** 8581C ** 2) NUMBER OF RESPONSE VARIABLES (>= 1)** 8582C *********************************************** 8583C 8584 ISTEPN='2' 8585 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TMCO') 8586 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8587C 8588 NRESP=0 8589 NREPL=0 8590C 8591 IF(IMULT.EQ.'ON')THEN 8592 NRESP=NUMVAR 8593 ELSEIF(IREPL.EQ.'ON')THEN 8594 NRESP=1 8595 NREPL=NUMVAR-NRESP 8596 IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN 8597 WRITE(ICOUT,999) 8598 CALL DPWRST('XXX','BUG ') 8599 WRITE(ICOUT,101) 8600 101 FORMAT('***** ERROR IN TRIMMED MEAN CONFIDENCE LIMITS--') 8601 CALL DPWRST('XXX','BUG ') 8602 WRITE(ICOUT,211) 8603 211 FORMAT(' FOR THE REPLICATION CASE, THE NUMBER OF ', 8604 1 'REPLICATION VARIABLES') 8605 CALL DPWRST('XXX','BUG ') 8606 WRITE(ICOUT,213)NREPL 8607 213 FORMAT(' THE NUMBER OF REPLICATION VARIABLES = ',I5) 8608 CALL DPWRST('XXX','BUG ') 8609 IERROR='YES' 8610 GOTO9000 8611 ENDIF 8612 ELSE 8613 NRESP=1 8614 ENDIF 8615C 8616 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TMCO')THEN 8617 WRITE(ICOUT,221)NRESP,NREPL 8618 221 FORMAT('NRESP,NREPL = ',2I5) 8619 CALL DPWRST('XXX','BUG ') 8620 ENDIF 8621C 8622 DO230I=1,MAXN 8623 W(I)=1.0 8624 230 CONTINUE 8625C 8626C ****************************************************** 8627C ** STEP 3-- ** 8628C ** DETERMINE VALUE OF TRIMMING CONSTANTS (OBTAINED ** 8629C ** FROM PARAMETERS P1 AND P2) ** 8630C ****************************************************** 8631C 8632C 8633C 2012/10: FOR TRIMMED MEAN, CAN SPECIFY EITHER A SPECIFIC NUMBER 8634C TO TRIM OR A PERCENTAGE TO TRIM. CHECK FOR SPECIFIC 8635C NUMBER FIRST AND IF NOT SPECIFIED, CHECK FOR A 8636C PERCENTAGE. 8637C 8638 NTRIM1=-1 8639 NTRIM2=-1 8640 P1=-99.0 8641 P2=-99.0 8642C 8643 IH='NTRI' 8644 IH2='M1 ' 8645 IHWUSE='P' 8646 MESSAG='NO' 8647 CALL CHECKN(IH,IH2,IHWUSE, 8648 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 8649 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 8650 IF(IERROR.EQ.'NO')THEN 8651 NTRIM1=INT(VALUE(ILOCP)+0.1) 8652 IF(NTRIM1.LT.0)NTRIM1=0 8653 ENDIF 8654C 8655 IH='NTRI' 8656 IH2='M2 ' 8657 IHWUSE='P' 8658 MESSAG='NO' 8659 CALL CHECKN(IH,IH2,IHWUSE, 8660 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 8661 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 8662 IF(IERROR.EQ.'NO')THEN 8663 NTRIM2=INT(VALUE(ILOCP)+0.1) 8664 IF(NTRIM2.LT.0)NTRIM2=0 8665 ENDIF 8666C 8667 IF(NTRIM1.LE.0)THEN 8668 IH='P1 ' 8669 IH2=' ' 8670 IHWUSE='P' 8671 MESSAG='YES' 8672 CALL CHECKN(IH,IH2,IHWUSE, 8673 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 8674 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 8675 IF(IERROR.EQ.'YES')GOTO9000 8676 IF(PROP1.LT.0.0 .OR. PROP1.GT.100.0)THEN 8677 WRITE(ICOUT,999) 8678 CALL DPWRST('XXX','BUG ') 8679 WRITE(ICOUT,301) 8680 301 FORMAT('***** ERROR IN TRIMMED MEAN CONFIDENCE LIMITS--') 8681 CALL DPWRST('XXX','BUG ') 8682 WRITE(ICOUT,302) 8683 302 FORMAT(' THE PROPORTION FOR TRIMMING BELOW MUST BE') 8684 CALL DPWRST('XXX','BUG ') 8685 WRITE(ICOUT,303) 8686 303 FORMAT(' BETWEEN 0 AND 100, BUT WAS NOT.') 8687 CALL DPWRST('XXX','BUG ') 8688 WRITE(ICOUT,304)PROP1 8689 304 FORMAT(' PARAMETER P1 = LOWER PROPORTION = ',G15.7) 8690 CALL DPWRST('XXX','BUG ') 8691 WRITE(ICOUT,305) 8692 305 FORMAT(' USE THE LET COMMAND TO PRE-DEFINE P1 AS IN') 8693 CALL DPWRST('XXX','BUG ') 8694 WRITE(ICOUT,306) 8695 306 FORMAT(' LET P1 = 25') 8696 CALL DPWRST('XXX','BUG ') 8697 IERROR='YES' 8698 GOTO9000 8699 ELSE 8700 PROP1=VALUE(ILOCP) 8701 ENDIF 8702 ENDIF 8703C 8704 IF(NTRIM2.LE.0)THEN 8705 IH='P2 ' 8706 IH2=' ' 8707 IHWUSE='P' 8708 MESSAG='YES' 8709 CALL CHECKN(IH,IH2,IHWUSE, 8710 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 8711 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 8712 IF(IERROR.EQ.'YES')GOTO9000 8713 IF(PROP2.LT.0.0 .OR. PROP2.GT.100.0)THEN 8714 WRITE(ICOUT,999) 8715 CALL DPWRST('XXX','BUG ') 8716 WRITE(ICOUT,301) 8717 CALL DPWRST('XXX','BUG ') 8718 WRITE(ICOUT,312) 8719 312 FORMAT(' THE PROPORTION FOR TRIMMING ABOVE MUST BE') 8720 CALL DPWRST('XXX','BUG ') 8721 WRITE(ICOUT,303) 8722 CALL DPWRST('XXX','BUG ') 8723 WRITE(ICOUT,314)PROP2 8724 314 FORMAT(' PARAMETER P2 = LOWER PROPORTION = ',G15.7) 8725 CALL DPWRST('XXX','BUG ') 8726 WRITE(ICOUT,315) 8727 315 FORMAT(' USE THE LET COMMAND TO PRE-DEFINE P2 AS IN') 8728 CALL DPWRST('XXX','BUG ') 8729 WRITE(ICOUT,316) 8730 316 FORMAT(' LET P2 = 25') 8731 CALL DPWRST('XXX','BUG ') 8732 IERROR='YES' 8733 GOTO9000 8734 ELSE 8735 PROP2=VALUE(ILOCP) 8736 ENDIF 8737 ENDIF 8738C 8739C 8740C ****************************************************** 8741C ** STEP 3-- ** 8742C ** GENERATE THE CONFIDENCE LIMITS FOR THE VARIOUS ** 8743C ** CASES ** 8744C ****************************************************** 8745C 8746 ISTEPN='3' 8747 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TMCO') 8748 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8749C 8750C ***************************************** 8751C ** STEP 3A-- ** 8752C ** CASE 1: SINGLE RESPONSE VARIABLE ** 8753C ** WITH NO REPLICATION ** 8754C ***************************************** 8755C 8756 IF(IMULT.EQ.'OFF' .AND. NREPL.EQ.0)THEN 8757 ISTEPN='3A' 8758 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TMCO') 8759 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8760C 8761 PID(1)=CPUMIN 8762 IVARID(1)=IVARN1(1) 8763 IVARI2(1)=IVARN2(1) 8764C 8765 ICOL=1 8766 NUMVA2=1 8767 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 8768 1 INAME,IVARN1,IVARN2,IVARTY, 8769 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 8770 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 8771 1 MAXCP4,MAXCP5,MAXCP6, 8772 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 8773 1 Y,XTEMP1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE, 8774 1 IBUGA3,ISUBRO,IFOUND,IERROR) 8775 IF(IERROR.EQ.'YES')GOTO9000 8776C 8777C ****************************************************** 8778C ** STEP 3B-- ** 8779C ** PREPARE FOR ENTRANCE INTO DPTMC2-- ** 8780C ** SET THE WEIGHT VECTOR TO UNITY THROUGHOUT. ** 8781C ****************************************************** 8782C 8783 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TMCO')THEN 8784 ISTEPN='3B' 8785 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8786 WRITE(ICOUT,999) 8787 CALL DPWRST('XXX','BUG ') 8788 WRITE(ICOUT,331) 8789 331 FORMAT('***** FROM DPTMCO, AS WE ARE ABOUT TO CALL DPTMC2--') 8790 CALL DPWRST('XXX','BUG ') 8791 WRITE(ICOUT,332)NLOCAL,MAXN 8792 332 FORMAT('NLOCAL,MAXN = ',2I8) 8793 CALL DPWRST('XXX','BUG ') 8794 DO335I=1,N 8795 WRITE(ICOUT,336)I,Y(I) 8796 336 FORMAT('I,Y(I) = ',I8,G15.7) 8797 CALL DPWRST('XXX','BUG ') 8798 335 CONTINUE 8799 ENDIF 8800C 8801 CALL DPTMC2(Y,NLOCAL,W,PROP1,PROP2,NTRIM1,NTRIM2, 8802 1 XTEMP1,XTEMP2,MAXNXT, 8803 1 PID,IVARID,IVARI2,NREPL, 8804 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 8805 1 CTL999,CTU999, 8806 1 ICAPSW,ICAPTY,IFORSW, 8807 1 ICASAN,ISUBRO,IBUGA3,IERROR) 8808C 8809 IFLAGU='ON' 8810 IFRST=.FALSE. 8811 ILAST=.FALSE. 8812 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 8813 1 CTL999,CTU999, 8814 1 IFLAGU,IFRST,ILAST,ICASAN, 8815 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 8816C 8817C ******************************************* 8818C ** STEP 4A-- ** 8819C ** CASE 2: MULTIPLE RESPONSE VARIABLES ** 8820C ******************************************* 8821C 8822 ELSEIF(IMULT.EQ.'ON')THEN 8823 ISTEPN='4A' 8824 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TMCO') 8825 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8826C 8827C LOOP THROUGH EACH OF THE RESPONSE VARIABLES 8828C 8829 NCURVE=0 8830 DO410IRESP=1,NRESP 8831 NCURVE=NCURVE+1 8832C 8833 IINDX=ICOLR(IRESP) 8834 PID(1)=CPUMIN 8835 IVARID(1)=IVARN1(IRESP) 8836 IVARI2(1)=IVARN2(IRESP) 8837C 8838 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TMCO')THEN 8839 WRITE(ICOUT,999) 8840 CALL DPWRST('XXX','BUG ') 8841 WRITE(ICOUT,411)IRESP,NCURVE 8842 411 FORMAT('IRESP,NCURVE = ',2I5) 8843 CALL DPWRST('XXX','BUG ') 8844 ENDIF 8845C 8846 ICOL=IRESP 8847 NUMVA2=1 8848 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 8849 1 INAME,IVARN1,IVARN2,IVARTY, 8850 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 8851 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 8852 1 MAXCP4,MAXCP5,MAXCP6, 8853 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 8854 1 Y,XTEMP1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE, 8855 1 IBUGA3,ISUBRO,IFOUND,IERROR) 8856 IF(IERROR.EQ.'YES')GOTO9000 8857C 8858C ***************************************************** 8859C ** STEP 4B-- ** 8860C ***************************************************** 8861C 8862 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TMCO')THEN 8863 ISTEPN='4B' 8864 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8865 WRITE(ICOUT,999) 8866 CALL DPWRST('XXX','BUG ') 8867 WRITE(ICOUT,422) 8868 422 FORMAT('***** FROM THE MIDDLE OF DPTMCO--') 8869 CALL DPWRST('XXX','BUG ') 8870 WRITE(ICOUT,423)ICASAN,NUMVAR,NLOCAL,IRESP 8871 423 FORMAT('ICASAN,NUMVAR,NLOCAL,IRESP = ',A4,3I8) 8872 CALL DPWRST('XXX','BUG ') 8873 IF(NLOCAL.GE.1)THEN 8874 DO425I=1,NLOCAL 8875 WRITE(ICOUT,426)I,Y(I) 8876 426 FORMAT('I,Y(I) = ',I8,F12.5) 8877 CALL DPWRST('XXX','BUG ') 8878 425 CONTINUE 8879 ENDIF 8880 ENDIF 8881C 8882 CALL DPTMC2(Y,NLOCAL,W,PROP1,PROP2,NTRIM1,NTRIM2, 8883 1 XTEMP1,XTEMP2,MAXNXT, 8884 1 PID,IVARID,IVARI2,NREPL, 8885 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 8886 1 CTL999,CTU999, 8887 1 ICAPSW,ICAPTY,IFORSW, 8888 1 ICASAN,ISUBRO,IBUGA3,IERROR) 8889C 8890 IFLAGU='FILE' 8891 IFRST=.FALSE. 8892 ILAST=.FALSE. 8893 IF(IRESP.EQ.1)IFRST=.TRUE. 8894 IF(IRESP.EQ.NRESP)ILAST=.TRUE. 8895 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 8896 1 CTL999,CTU999, 8897 1 IFLAGU,IFRST,ILAST,ICASAN, 8898 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 8899C 8900 410 CONTINUE 8901C 8902C **************************************************** 8903C ** STEP 5A-- ** 8904C ** CASE 3: ONE OR MORE REPLICATION VARIABLES. ** 8905C ** FOR THIS CASE, ALL VARIABLES MUST ** 8906C ** HAVE THE SAME LENGTH. ** 8907C **************************************************** 8908C 8909 ELSEIF(IREPL.EQ.'ON')THEN 8910 ISTEPN='5A' 8911 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TMCO') 8912 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8913C 8914 J=0 8915 IMAX=NRIGHT(1) 8916 IF(NQ.LT.NRIGHT(1))IMAX=NQ 8917 DO510I=1,IMAX 8918 IF(ISUB(I).EQ.0)GOTO510 8919 J=J+1 8920C 8921C RESPONSE VARIABLE IN Y 8922C 8923 ICOLC=1 8924 IJ=MAXN*(ICOLR(ICOLC)-1)+I 8925 IF(ICOLR(ICOLC).LE.MAXCOL)Y(J)=V(IJ) 8926 IF(ICOLR(ICOLC).EQ.MAXCP1)Y(J)=PRED(I) 8927 IF(ICOLR(ICOLC).EQ.MAXCP2)Y(J)=RES(I) 8928 IF(ICOLR(ICOLC).EQ.MAXCP3)Y(J)=YPLOT(I) 8929 IF(ICOLR(ICOLC).EQ.MAXCP4)Y(J)=XPLOT(I) 8930 IF(ICOLR(ICOLC).EQ.MAXCP5)Y(J)=X2PLOT(I) 8931 IF(ICOLR(ICOLC).EQ.MAXCP6)Y(J)=TAGPLO(I) 8932C 8933 IF(NREPL.GE.1)THEN 8934 DO520IR=1,MIN(NREPL,6) 8935 ICOLC=ICOLC+1 8936 ICOLT=ICOLR(ICOLC) 8937 IJ=MAXN*(ICOLT-1)+I 8938 IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ) 8939 IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I) 8940 IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I) 8941 IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I) 8942 IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I) 8943 IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I) 8944 IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I) 8945 520 CONTINUE 8946 ENDIF 8947C 8948 510 CONTINUE 8949 NLOCAL=J 8950C 8951 ISTEPN='5B' 8952 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TMCO') 8953 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8954C 8955 PID(1)=CPUMIN 8956 IVARID(1)=IVARN1(1) 8957 IVARI2(1)=IVARN2(1) 8958 IADD=1 8959 DO540II=1,NREPL 8960 IVARID(II+IADD)=IVARN1(II+IADD) 8961 IVARI2(II+IADD)=IVARN2(II+IADD) 8962 540 CONTINUE 8963C 8964C ***************************************************** 8965C ** STEP 5C-- ** 8966C ** ** 8967C ** FOR THIS CASE, WE NEED TO LOOP THROUGH THE ** 8968C ** VARIOUS REPLICATIONS. ** 8969C ***************************************************** 8970C 8971C 8972 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TMCO')THEN 8973 ISTEPN='5C' 8974 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8975 WRITE(ICOUT,999) 8976 CALL DPWRST('XXX','BUG ') 8977 WRITE(ICOUT,541) 8978 541 FORMAT('***** FROM THE MIDDLE OF DPTMCO--') 8979 CALL DPWRST('XXX','BUG ') 8980 WRITE(ICOUT,542)ICASAN,NUMVAR,NLOCAL,NREPL 8981 542 FORMAT('ICASAN,NUMVAR,NLOCAL,NREPL = ',A4,2X,3I8) 8982 CALL DPWRST('XXX','BUG ') 8983 IF(NLOCAL.GE.1)THEN 8984 DO545I=1,NLOCAL 8985 WRITE(ICOUT,546)I,Y(I),XDESGN(I,1),XDESGN(I,2) 8986 546 FORMAT('I,Y(I),XDESGN(I,1),XDESGN(I,2) = ', 8987 1 I8,3F12.5) 8988 CALL DPWRST('XXX','BUG ') 8989 545 CONTINUE 8990 ENDIF 8991 ENDIF 8992C 8993C ***************************************************** 8994C ** STEP 5C-- ** 8995C ** FIND THE DISTINCT VALUES IN EACH OF THE ** 8996C ** REPLICATION VARIABLES. ** 8997C ***************************************************** 8998C 8999 CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3), 9000 1 XDESGN(1,4),XDESGN(1,5),XDESGN(1,6), 9001 1 NREPL,NLOCAL,MAXOBV, 9002 1 XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6, 9003 1 XTEMP1,XTEMP2, 9004 1 NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6, 9005 1 IBUGA3,ISUBRO,IERROR) 9006C 9007C ***************************************************** 9008C ** STEP 5D-- ** 9009C ** NOW LOOP THROUGH THE VARIOUS REPLICATIONS ** 9010C ***************************************************** 9011C 9012 NPLOTP=0 9013 NCURVE=0 9014 IF(NREPL.EQ.1)THEN 9015 J=0 9016 DO1110ISET1=1,NUMSE1 9017 K=0 9018 PID(IADD+1)=XIDTEM(ISET1) 9019 DO1130I=1,NLOCAL 9020 IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN 9021 K=K+1 9022 TEMP1(K)=Y(I) 9023 ENDIF 9024 1130 CONTINUE 9025 NTEMP=K 9026 NCURVE=NCURVE+1 9027 IF(NTEMP.GT.0)THEN 9028 CALL DPTMC2(TEMP1,NTEMP,W,PROP1,PROP2,NTRIM1,NTRIM2, 9029 1 XTEMP1,XTEMP2,MAXNXT, 9030 1 PID,IVARID,IVARI2,NREPL, 9031 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 9032 1 CTL999,CTU999, 9033 1 ICAPSW,ICAPTY,IFORSW, 9034 1 ICASAN,ISUBRO,IBUGA3,IERROR) 9035 ENDIF 9036C 9037 IFLAGU='FILE' 9038 IFRST=.FALSE. 9039 ILAST=.FALSE. 9040 IF(NCURVE.EQ.1)IFRST=.TRUE. 9041 IF(NCURVE.EQ.NUMSE1)ILAST=.TRUE. 9042 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 9043 1 CTL999,CTU999, 9044 1 IFLAGU,IFRST,ILAST,ICASAN, 9045 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 9046 1110 CONTINUE 9047 ELSEIF(NREPL.EQ.2)THEN 9048 J=0 9049 NTOT=NUMSE1*NUMSE2 9050 DO1210ISET1=1,NUMSE1 9051 DO1220ISET2=1,NUMSE2 9052 K=0 9053 PID(1+IADD)=XIDTEM(ISET1) 9054 PID(2+IADD)=XIDTE2(ISET2) 9055 DO1290I=1,NLOCAL 9056 IF( 9057 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 9058 1 XIDTE2(ISET2).EQ.XDESGN(I,2) 9059 1 )THEN 9060 K=K+1 9061 TEMP1(K)=Y(I) 9062 ENDIF 9063 1290 CONTINUE 9064 NTEMP=K 9065 NCURVE=NCURVE+1 9066 NPLOT1=NPLOTP 9067 IF(NTEMP.GT.0)THEN 9068 CALL DPTMC2(TEMP1,NTEMP,W,PROP1,PROP2,NTRIM1,NTRIM2, 9069 1 XTEMP1,XTEMP2,MAXNXT, 9070 1 PID,IVARID,IVARI2,NREPL, 9071 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 9072 1 CTL999,CTU999, 9073 1 ICAPSW,ICAPTY,IFORSW, 9074 1 ICASAN,ISUBRO,IBUGA3,IERROR) 9075 ENDIF 9076 NPLOT2=NPLOTP 9077 IFLAGU='FILE' 9078 IFRST=.FALSE. 9079 ILAST=.FALSE. 9080 IF(NCURVE.EQ.1)IFRST=.TRUE. 9081 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 9082 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 9083 1 CTL999,CTU999, 9084 1 IFLAGU,IFRST,ILAST,ICASAN, 9085 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 9086 1220 CONTINUE 9087 1210 CONTINUE 9088 ELSEIF(NREPL.EQ.3)THEN 9089 J=0 9090 NTOT=NUMSE1*NUMSE2*NUMSE3 9091 DO1310ISET1=1,NUMSE1 9092 DO1320ISET2=1,NUMSE2 9093 DO1330ISET3=1,NUMSE3 9094 K=0 9095 PID(1+IADD)=XIDTEM(ISET1) 9096 PID(2+IADD)=XIDTE2(ISET2) 9097 PID(3+IADD)=XIDTE3(ISET3) 9098 DO1390I=1,NLOCAL 9099 IF( 9100 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 9101 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 9102 1 XIDTE3(ISET3).EQ.XDESGN(I,3) 9103 1 )THEN 9104 K=K+1 9105 TEMP1(K)=Y(I) 9106 ENDIF 9107 1390 CONTINUE 9108 NTEMP=K 9109 NCURVE=NCURVE+1 9110 IF(NTEMP.GT.0)THEN 9111 CALL DPTMC2(TEMP1,NTEMP,W,PROP1,PROP2,NTRIM1,NTRIM2, 9112 1 XTEMP1,XTEMP2,MAXNXT, 9113 1 PID,IVARID,IVARI2,NREPL, 9114 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 9115 1 CTL999,CTU999, 9116 1 ICAPSW,ICAPTY,IFORSW, 9117 1 ICASAN,ISUBRO,IBUGA3,IERROR) 9118 ENDIF 9119 IFLAGU='FILE' 9120 IFRST=.FALSE. 9121 ILAST=.FALSE. 9122 IF(NCURVE.EQ.1)IFRST=.TRUE. 9123 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 9124 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 9125 1 CTL999,CTU999, 9126 1 IFLAGU,IFRST,ILAST,ICASAN, 9127 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 9128 1330 CONTINUE 9129 1320 CONTINUE 9130 1310 CONTINUE 9131 ELSEIF(NREPL.EQ.4)THEN 9132 J=0 9133 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4 9134 DO1410ISET1=1,NUMSE1 9135 DO1420ISET2=1,NUMSE2 9136 DO1430ISET3=1,NUMSE3 9137 DO1440ISET4=1,NUMSE4 9138 K=0 9139 PID(1+IADD)=XIDTEM(ISET1) 9140 PID(2+IADD)=XIDTE2(ISET2) 9141 PID(3+IADD)=XIDTE3(ISET3) 9142 PID(4+IADD)=XIDTE4(ISET4) 9143 DO1490I=1,NLOCAL 9144 IF( 9145 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 9146 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 9147 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 9148 1 XIDTE4(ISET4).EQ.XDESGN(I,4) 9149 1 )THEN 9150 K=K+1 9151 TEMP1(K)=Y(I) 9152 ENDIF 9153 1490 CONTINUE 9154 NTEMP=K 9155 NCURVE=NCURVE+1 9156 IF(NTEMP.GT.0)THEN 9157 CALL DPTMC2(TEMP1,NTEMP,W,PROP1,PROP2,NTRIM1,NTRIM2, 9158 1 XTEMP1,XTEMP2,MAXNXT, 9159 1 PID,IVARID,IVARI2,NREPL, 9160 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 9161 1 CTL999,CTU999, 9162 1 ICAPSW,ICAPTY,IFORSW, 9163 1 ICASAN,ISUBRO,IBUGA3,IERROR) 9164 ENDIF 9165 IFLAGU='FILE' 9166 IFRST=.FALSE. 9167 ILAST=.FALSE. 9168 IF(NCURVE.EQ.1)IFRST=.TRUE. 9169 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 9170 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 9171 1 CTL999,CTU999, 9172 1 IFLAGU,IFRST,ILAST,ICASAN, 9173 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 9174 1440 CONTINUE 9175 1430 CONTINUE 9176 1420 CONTINUE 9177 1410 CONTINUE 9178 ELSEIF(NREPL.EQ.5)THEN 9179 J=0 9180 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5 9181 DO1510ISET1=1,NUMSE1 9182 DO1520ISET2=1,NUMSE2 9183 DO1530ISET3=1,NUMSE3 9184 DO1540ISET4=1,NUMSE4 9185 DO1550ISET5=1,NUMSE5 9186 K=0 9187 PID(1+IADD)=XIDTEM(ISET1) 9188 PID(2+IADD)=XIDTE2(ISET2) 9189 PID(3+IADD)=XIDTE3(ISET3) 9190 PID(4+IADD)=XIDTE4(ISET4) 9191 PID(5+IADD)=XIDTE5(ISET4) 9192 DO1590I=1,NLOCAL 9193 IF( 9194 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 9195 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 9196 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 9197 1 XIDTE4(ISET4).EQ.XDESGN(I,4) .AND. 9198 1 XIDTE5(ISET5).EQ.XDESGN(I,5) 9199 1 )THEN 9200 K=K+1 9201 TEMP1(K)=Y(I) 9202 ENDIF 9203 1590 CONTINUE 9204 NTEMP=K 9205 NCURVE=NCURVE+1 9206 IF(NTEMP.GT.0)THEN 9207 CALL DPTMC2(TEMP1,NTEMP,W,PROP1,PROP2,NTRIM1,NTRIM2, 9208 1 XTEMP1,XTEMP2,MAXNXT, 9209 1 PID,IVARID,IVARI2,NREPL, 9210 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 9211 1 CTL999,CTU999, 9212 1 ICAPSW,ICAPTY,IFORSW, 9213 1 ICASAN,ISUBRO,IBUGA3,IERROR) 9214 ENDIF 9215 IFLAGU='FILE' 9216 IFRST=.FALSE. 9217 ILAST=.FALSE. 9218 IF(NCURVE.EQ.1)IFRST=.TRUE. 9219 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 9220 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 9221 1 CTL999,CTU999, 9222 1 IFLAGU,IFRST,ILAST,ICASAN, 9223 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 9224 1550 CONTINUE 9225 1540 CONTINUE 9226 1530 CONTINUE 9227 1520 CONTINUE 9228 1510 CONTINUE 9229 ELSEIF(NREPL.EQ.6)THEN 9230 J=0 9231 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6 9232 DO1610ISET1=1,NUMSE1 9233 DO1620ISET2=1,NUMSE2 9234 DO1630ISET3=1,NUMSE3 9235 DO1640ISET4=1,NUMSE4 9236 DO1650ISET5=1,NUMSE5 9237 DO1660ISET6=1,NUMSE6 9238 K=0 9239 PID(1+IADD)=XIDTEM(ISET1) 9240 PID(2+IADD)=XIDTE2(ISET2) 9241 PID(3+IADD)=XIDTE3(ISET3) 9242 PID(4+IADD)=XIDTE4(ISET4) 9243 PID(5+IADD)=XIDTE5(ISET4) 9244 PID(6+IADD)=XIDTE6(ISET4) 9245 DO1690I=1,NLOCAL 9246 IF( 9247 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 9248 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 9249 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 9250 1 XIDTE4(ISET4).EQ.XDESGN(I,4) .AND. 9251 1 XIDTE5(ISET5).EQ.XDESGN(I,5) .AND. 9252 1 XIDTE6(ISET6).EQ.XDESGN(I,6) 9253 1 )THEN 9254 K=K+1 9255 TEMP1(K)=Y(I) 9256 ENDIF 9257 1690 CONTINUE 9258 NTEMP=K 9259 NCURVE=NCURVE+1 9260 IF(NTEMP.GT.0)THEN 9261 CALL DPTMC2(TEMP1,NTEMP,W,PROP1,PROP2,NTRIM1,NTRIM2, 9262 1 XTEMP1,XTEMP2,MAXNXT, 9263 1 PID,IVARID,IVARI2,NREPL, 9264 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 9265 1 CTL999,CTU999, 9266 1 ICAPSW,ICAPTY,IFORSW, 9267 1 ICASAN,ISUBRO,IBUGA3,IERROR) 9268 ENDIF 9269 IFLAGU='FILE' 9270 IFRST=.FALSE. 9271 ILAST=.FALSE. 9272 IF(NCURVE.EQ.1)IFRST=.TRUE. 9273 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 9274 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 9275 1 CTL999,CTU999, 9276 1 IFLAGU,IFRST,ILAST,ICASAN, 9277 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 9278 1660 CONTINUE 9279 1650 CONTINUE 9280 1640 CONTINUE 9281 1630 CONTINUE 9282 1620 CONTINUE 9283 1610 CONTINUE 9284 ENDIF 9285C 9286 ENDIF 9287C 9288C ***************** 9289C ** STEP 90-- ** 9290C ** EXIT ** 9291C ***************** 9292C 9293 9000 CONTINUE 9294 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TMCO')THEN 9295 WRITE(ICOUT,999) 9296 CALL DPWRST('XXX','BUG ') 9297 WRITE(ICOUT,9011) 9298 9011 FORMAT('***** AT THE END OF DPTMCO--') 9299 CALL DPWRST('XXX','BUG ') 9300 WRITE(ICOUT,9014)ICASEQ,NRIGHT(1),NS 9301 9014 FORMAT('ICASEQ,NRIGHT(1),NS = ',A4,2X,2I8) 9302 CALL DPWRST('XXX','BUG ') 9303 WRITE(ICOUT,9016)IFOUND,IERROR 9304 9016 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 9305 CALL DPWRST('XXX','BUG ') 9306 ENDIF 9307C 9308 RETURN 9309 END 9310 SUBROUTINE DPTMC2(Y,N,W,PROP1,PROP2,NTRIM1,NTRIM2, 9311 1 XTEMP1,XTEMP2,MAXNXT, 9312 1 PID,IVARID,IVARI2,NREPL, 9313 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 9314 1 CTL999,CTU999, 9315 1 ICAPSW,ICAPTY,IFORSW, 9316 1 ICASAN,ISUBRO,IBUGA3,IERROR) 9317C 9318C PURPOSE--THIS ROUTINE GENERATES TRIMMED MEAN CONFIDENCE LIMITS 9319C FOR THE DATA IN THE INPUT VECTOR Y. 9320C NOTE--ASSUMPTION--MODEL IS RESPONSE = CONSTANT + ERROR. 9321C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR 9322C OF OBSERVATIONS 9323C N = THE INTEGER NUMBER OF 9324C OBSERVATIONS IN THE VECTOR Y. 9325C WRITTEN BY--ALAN HECKERT 9326C STATISTICAL ENGINEERING DIVISION 9327C INFORMATION TECHNOLOGY LABORATORY 9328C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 9329C GAITHERSBURG, MD 20899-8980 9330C PHONE--301-975-2899 9331C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 9332C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 9333C LANGUAGE--ANSI FORTRAN (1977) 9334C VERSION NUMBER--2003/2 9335C ORIGINAL VERSION--FEBRUARY 2003. 9336C UPDATED --OCTOBER 2003. ADD SUPPORT FOR HTML, LATEX 9337C OUTPUT 9338C 9339C UPDATED --OCTOBER 2006. CALL LIST TO TPPF 9340C UPDATED --MARCH 2010. USE DPDTA2 AND DPDTA4 TO 9341C GENERATE OUTPUT (ADDS RTF 9342C SUPPORT) 9343C UPDATED --MARCH 2010. SOME MODIFICATIONS TO THE 9344C OUTPUT (AESTHETIC, NOT 9345C SUBSTANTIVE) 9346C UPDATED --AUGUST 2019. ADD CTL999, CTU999 9347C 9348C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 9349C 9350 CHARACTER*4 IBUGA3 9351 CHARACTER*4 ISUBRO 9352 CHARACTER*4 IERROR 9353C 9354 CHARACTER*4 IWRITE 9355 CHARACTER*4 ICASAN 9356 CHARACTER*4 ICASA2 9357 CHARACTER*4 ICAPSW 9358 CHARACTER*4 ICAPTY 9359 CHARACTER*4 IFORSW 9360C 9361 CHARACTER*4 IVARID(*) 9362 CHARACTER*4 IVARI2(*) 9363C 9364 CHARACTER*4 ISUBN1 9365 CHARACTER*4 ISUBN2 9366 CHARACTER*4 ISTEPN 9367C 9368C--------------------------------------------------------------------- 9369C 9370 DIMENSION Y(*) 9371 DIMENSION W(*) 9372 DIMENSION XTEMP1(*) 9373 DIMENSION XTEMP2(*) 9374 DIMENSION PID(*) 9375C 9376 PARAMETER (NUMALP=8) 9377C 9378 DIMENSION CONF(NUMALP) 9379 DIMENSION T(NUMALP) 9380 DIMENSION TSDM(NUMALP) 9381 DIMENSION ALOWER(NUMALP) 9382 DIMENSION AUPPER(NUMALP) 9383C 9384 PARAMETER(NUMCLI=5) 9385 PARAMETER(MAXLIN=2) 9386 PARAMETER (MAXROW=20) 9387 CHARACTER*60 ITITLE 9388 CHARACTER*60 ITITLZ 9389 CHARACTER*60 ITEXT(MAXROW) 9390 REAL AVALUE(MAXROW) 9391 INTEGER NCTEXT(MAXROW) 9392 INTEGER IDIGIT(MAXROW) 9393 INTEGER NTOT(MAXROW) 9394 LOGICAL IFRST 9395 LOGICAL ILAST 9396C 9397C-----COMMON---------------------------------------------------------- 9398C 9399 INCLUDE 'DPCOP2.INC' 9400C 9401C-----START POINT----------------------------------------------------- 9402C 9403 ISUBN1='DPTM' 9404 ISUBN2='C2 ' 9405 IWRITE='OFF' 9406 IERROR='NO' 9407 ICASA2='TMCO' 9408C 9409 NUMDIG=7 9410 IF(IFORSW.EQ.'1')NUMDIG=1 9411 IF(IFORSW.EQ.'2')NUMDIG=2 9412 IF(IFORSW.EQ.'3')NUMDIG=3 9413 IF(IFORSW.EQ.'4')NUMDIG=4 9414 IF(IFORSW.EQ.'5')NUMDIG=5 9415 IF(IFORSW.EQ.'6')NUMDIG=6 9416 IF(IFORSW.EQ.'7')NUMDIG=7 9417 IF(IFORSW.EQ.'8')NUMDIG=8 9418 IF(IFORSW.EQ.'9')NUMDIG=9 9419 IF(IFORSW.EQ.'0')NUMDIG=0 9420 IF(IFORSW.EQ.'E')NUMDIG=-2 9421 IF(IFORSW.EQ.'-2')NUMDIG=-2 9422 IF(IFORSW.EQ.'-3')NUMDIG=-3 9423 IF(IFORSW.EQ.'-4')NUMDIG=-4 9424 IF(IFORSW.EQ.'-5')NUMDIG=-5 9425 IF(IFORSW.EQ.'-6')NUMDIG=-6 9426 IF(IFORSW.EQ.'-7')NUMDIG=-7 9427 IF(IFORSW.EQ.'-8')NUMDIG=-8 9428 IF(IFORSW.EQ.'-9')NUMDIG=-9 9429C 9430 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TMC2')THEN 9431 WRITE(ICOUT,999) 9432 999 FORMAT(1X) 9433 CALL DPWRST('XXX','WRIT') 9434 WRITE(ICOUT,51) 9435 51 FORMAT('**** AT THE BEGINNING OF DPTMC2--') 9436 CALL DPWRST('XXX','WRIT') 9437 WRITE(ICOUT,52)N,NUMDIG,PROP1,PROP2,IBUGA3,ICASAN 9438 52 FORMAT('N,NUMDIG,PROP1,PROP2,IBUGA3,ICASAN = ', 9439 1 2I8,2X,2G15.7,2X,A4,2X,A4) 9440 CALL DPWRST('XXX','WRIT') 9441 DO56I=1,N 9442 WRITE(ICOUT,57)I,Y(I),W(I) 9443 57 FORMAT('I,Y(I),W(I) = ',I8,2G15.7) 9444 CALL DPWRST('XXX','WRIT') 9445 56 CONTINUE 9446 ENDIF 9447C 9448C ******************************************** 9449C ** STEP 1-- ** 9450C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 9451C ******************************************** 9452C 9453 ISTEPN='1' 9454 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TMC2') 9455 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9456C 9457 IF(N.LT.5)THEN 9458 WRITE(ICOUT,999) 9459 CALL DPWRST('XXX','WRIT') 9460 WRITE(ICOUT,111) 9461 111 FORMAT('***** ERROR IN TRIMMED MEAN--') 9462 CALL DPWRST('XXX','WRIT') 9463 WRITE(ICOUT,112) 9464 112 FORMAT(' THE NUMBER OF OBSERVATIONS IN THE RESPONSE ', 9465 1 'VARIABLE IS LESS THAN 5') 9466 CALL DPWRST('XXX','WRIT') 9467 WRITE(ICOUT,113)N 9468 113 FORMAT('SAMPLE SIZE = ',I8) 9469 CALL DPWRST('XXX','WRIT') 9470 IERROR='YES' 9471 GOTO9000 9472 ENDIF 9473C 9474 HOLD=Y(1) 9475 DO135I=2,N 9476 IF(Y(I).NE.HOLD)GOTO139 9477 135 CONTINUE 9478 WRITE(ICOUT,999) 9479 CALL DPWRST('XXX','WRIT') 9480 WRITE(ICOUT,111) 9481 CALL DPWRST('XXX','WRIT') 9482 WRITE(ICOUT,131)HOLD 9483 131 FORMAT(' THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7) 9484 CALL DPWRST('XXX','WRIT') 9485 GOTO9000 9486 139 CONTINUE 9487C 9488C *************************************************** 9489C ** STEP 3-- ** 9490C ** COMPUTE THE TRIMMED MEAN LOCATION ESTIMATE ** 9491C ** COMPUTE THE TRIMMED MEAN STANDARD ERROR ** 9492C *************************************************** 9493C 9494C 9495 ISTEPN='3' 9496 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TMC2') 9497 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9498C 9499 IWRITE='OFF' 9500C 9501 CALL TRIMME(Y,N,PROP1,PROP2,NTRIM1,NTRIM2,IWRITE,XTEMP1, 9502 1 MAXNXT,YTRMME, 9503 1 IBUGA3,ISUBRO,IERROR) 9504 CALL TRIMSE(Y,N,PROP1,PROP2,NRIM1,NTRIM2,IWRITE,XTEMP1,XTEMP2, 9505 1 MAXNXT,YTRMSE, 9506 1 IBUGA3,ISUBRO,IERROR) 9507C 9508 AN1=N 9509 LAMBDA=INT(AN1*(PROP1+PROP2)/100.) 9510 V=0.7*(AN1-1.0) 9511 IV=N - LAMBDA - 1 9512 IF(IV.LT.1)IV=1 9513C 9514C *************************************** 9515C ** STEP 4-- ** 9516C ** COMPUTE CONFIDENCE LIMITS ** 9517C ** FOR VARIOUS PROBABILITY VALUES. ** 9518C *************************************** 9519C 9520 ISTEPN='4' 9521 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TMC2') 9522 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9523C 9524 CONF(1)=50.0 9525 CONF(2)=75.0 9526 CONF(3)=90.0 9527 CONF(4)=95.0 9528 CONF(5)=99.0 9529 CONF(6)=99.9 9530 CONF(7)=99.99 9531 CONF(8)=99.999 9532C 9533 DO1400I=1,8 9534 PCONF=CONF(I)/100.0 9535 CDF=0.5+PCONF/2.0 9536 CALL TPPF(CDF,REAL(IV),T(I)) 9537 TSDM(I)=T(I)*YTRMSE 9538 ALOWER(I)=YTRMME-TSDM(I) 9539 AUPPER(I)=YTRMME+TSDM(I) 9540 1400 CONTINUE 9541 CUTL90=ALOWER(3) 9542 CUTU90=AUPPER(3) 9543 CUTL95=ALOWER(4) 9544 CUTU95=AUPPER(4) 9545 CUTL99=ALOWER(5) 9546 CUTU99=AUPPER(5) 9547 CTL999=ALOWER(6) 9548 CTU999=AUPPER(6) 9549C 9550C ADD A FUDGE FACTOR SO THAT CONFIDENCE LEVEL WILL 9551C BE PRINTED CORRECTLY TO 3 DECIMAL PLACES. 9552C 9553 CONF(1)=50.0001 9554 CONF(2)=75.0001 9555 CONF(3)=90.0001 9556 CONF(4)=95.0001 9557 CONF(5)=99.0001 9558 CONF(6)=99.9001 9559 CONF(7)=99.9901 9560 CONF(8)=99.9991 9561C 9562C **************************** 9563C ** STEP 7-- ** 9564C ** WRITE EVERYTHING OUT ** 9565C **************************** 9566C 9567 ISTEPN='7' 9568 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TMC2') 9569 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9570C 9571 IF(IPRINT.EQ.'OFF')GOTO9000 9572C 9573 ITITLE='Confidence Limits for the Trimmed Mean' 9574 NCTITL=38 9575 ITITLZ='(Two-Sided)' 9576 NCTITZ=11 9577C 9578 ICNT=1 9579 ITEXT(ICNT)=' ' 9580 NCTEXT(ICNT)=0 9581 AVALUE(ICNT)=0.0 9582 IDIGIT(ICNT)=-1 9583 ICNT=ICNT+1 9584 ITEXT(ICNT)='Response Variable: ' 9585 WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4) 9586 WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4) 9587 NCTEXT(ICNT)=27 9588 AVALUE(ICNT)=0.0 9589 IDIGIT(ICNT)=-1 9590C 9591 IF(NREPL.GT.0)THEN 9592 NRESP=1 9593 DO4101I=1,NREPL 9594 ICNT=ICNT+1 9595 ITEMP=I+NRESP 9596 ITEXT(ICNT)='Factor Variable : ' 9597 WRITE(ITEXT(ICNT)(17:17),'(I1)')I 9598 WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4) 9599 WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4) 9600 NCTEXT(ICNT)=27 9601 AVALUE(ICNT)=PID(ITEMP) 9602 IDIGIT(ICNT)=NUMDIG 9603 4101 CONTINUE 9604 ENDIF 9605C 9606 ICNT=ICNT+1 9607 ITEXT(ICNT)=' ' 9608 NCTEXT(ICNT)=1 9609 AVALUE(ICNT)=0.0 9610 IDIGIT(ICNT)=-1 9611C 9612 ICNT=ICNT+1 9613 ITEXT(ICNT)='Summary Statistics:' 9614 NCTEXT(ICNT)=19 9615 AVALUE(ICNT)=0.0 9616 IDIGIT(ICNT)=-1 9617 ICNT=ICNT+1 9618 ITEXT(ICNT)='Number of Observations:' 9619 NCTEXT(ICNT)=23 9620 AVALUE(ICNT)=REAL(N) 9621 IDIGIT(ICNT)=0 9622 ICNT=ICNT+1 9623 ITEXT(ICNT)='Percentage Trimmed Below:' 9624 NCTEXT(ICNT)=25 9625 AVALUE(ICNT)=PROP1 9626 IDIGIT(ICNT)=NUMDIG 9627 ICNT=ICNT+1 9628 ITEXT(ICNT)='Percentage Trimmed Above:' 9629 NCTEXT(ICNT)=25 9630 AVALUE(ICNT)=PROP2 9631 IDIGIT(ICNT)=NUMDIG 9632 ICNT=ICNT+1 9633 ITEXT(ICNT)='Sample Trimmed Mean:' 9634 NCTEXT(ICNT)=20 9635 AVALUE(ICNT)=YTRMME 9636 IDIGIT(ICNT)=NUMDIG 9637 ICNT=ICNT+1 9638 ITEXT(ICNT)='Sample Trimmed Mean Standard Error:' 9639 NCTEXT(ICNT)=35 9640 AVALUE(ICNT)=YTRMSE 9641 IDIGIT(ICNT)=NUMDIG 9642 ICNT=ICNT+1 9643 ITEXT(ICNT)='Degrees of Freedom:' 9644 NCTEXT(ICNT)=19 9645 AVALUE(ICNT)=REAL(IV) 9646 IDIGIT(ICNT)=NUMDIG 9647 ICNT=ICNT+1 9648 ITEXT(ICNT)=' ' 9649 NCTEXT(ICNT)=1 9650 AVALUE(ICNT)=0.0 9651 IDIGIT(ICNT)=-1 9652C 9653 NUMROW=ICNT 9654 DO4210I=1,NUMROW 9655 NTOT(I)=15 9656 4210 CONTINUE 9657C 9658 IFRST=.TRUE. 9659 ILAST=.TRUE. 9660C 9661 ISTEPN='5A' 9662 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TMC2') 9663 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9664C 9665 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT, 9666 1 AVALUE,IDIGIT, 9667 1 NTOT,NUMROW, 9668 1 ICAPSW,ICAPTY,ILAST,IFRST, 9669 1 ISUBRO,IBUGA3,IERROR) 9670C 9671 ISTEPN='5B' 9672 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2') 9673 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9674C 9675 CALL DPDT11(CONF,T,TSDM,ALOWER,AUPPER, 9676 1 ICASA2,ICAPSW,ICAPTY,NUMDIG, 9677 1 ISUBRO,IBUGA3,IERROR) 9678C 9679C ***************** 9680C ** STEP 90-- ** 9681C ** EXIT ** 9682C ***************** 9683C 9684 9000 CONTINUE 9685 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TMC2')THEN 9686 WRITE(ICOUT,999) 9687 CALL DPWRST('XXX','WRIT') 9688 WRITE(ICOUT,9011) 9689 9011 FORMAT('***** AT THE END OF DPTMC2--') 9690 CALL DPWRST('XXX','WRIT') 9691 WRITE(ICOUT,9012)N,IBUGA3,IERROR 9692 9012 FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4) 9693 CALL DPWRST('XXX','WRIT') 9694 WRITE(ICOUT,9013)YTRMME,YTRMSE,IV 9695 9013 FORMAT('YTRMME,YTRMSE,IV = ',2G15.7,I8) 9696 CALL DPWRST('XXX','WRIT') 9697 ENDIF 9698C 9699 RETURN 9700 END 9701 SUBROUTINE DPTNS1(Y,X,N,T, 9702 1 TEMP1, 9703 1 MUMOME,SDMOME,MUML,SDML, 9704 1 MUMLSE,SDMLSE,COVSE, 9705 1 ISUBRO,IBUGA3,IERROR) 9706C 9707C PURPOSE--THIS ROUTINE ESTIMATES THE PARAMETERS FOR THE 9708C "DETECTION LIMIT PLOT" COMMAND. NOTE THAT THIS 9709C IS ACTUALLY A SINGLY LEFT CENSORED PROBLEM (THE 9710C DISTINCTION BETWEEN CENSORING AND TRUNCATION IS 9711C THAT FOR THE CENSORED CASE WE KNOW HOW MANY 9712C MEASUREMENTS ARE RESTRICTED WHILE FOR THE TRUNCATED 9713C CASE WE DO NOT. 9714C 9715C THE 3-MOMENT ESTIMATES ARE: 9716C 9717C SIGMA* = SQRT{(V1P**2 - V1P*V2P)/(V2P - 2*V1P**2)} 9718C MU* = T + A* 9719C 9720C WHERE 9721C 9722C A* = (V3P - 2*V1P*V2P)/(V2P - 2*V1P**2) 9723C V1P = XBAR - T 9724C V2P = S**2 + (XBAR - T)**2 9725C V3P = SUM[i=1 to n][(X(i) - XBAR)**3]/n 9726C 9727C THE MAXIMUM LIKELIHOOD ESTIMATES ARE: 9728C 9729C SIGMAHAT = SQRT{S**2 + lambda(h,alphahat)*(XBAR - T)**2} 9730C MUHAT = XBAR - lambda(h,alphahat)*(XBAR - T) 9731C 9732C WHERE 9733C 9734C alphahat = S**2/(XBAR - T)**2 9735C h = c/N 9736C N = TOTAL NUMBER OF OBSERVATIONS 9737C n = NUMBER OF NON-TRUNCATED OBSERVATIONS 9738C c = NUMBER OF TRUNCATED OBSERVATIONS 9739C 9740C XBAR AND S ARE THE MEAN AND SD OF THE NON-TRUNCATED 9741C OBSERVATIONS. 9742C 9743C LAMBDA(H,ALPHAHAT) IS A TABULATED VALUE IN THE 9744C COHEN REFERENCE. HOWEVER, WE DETERMINE IT BY 9745C SOLVING THE FUNCTION 9746C 9747C ((1 - OMEGA(h,XI)*(OMEGA(h,XI) - XI))/ 9748C (OMEGA(h,XI) - XI)**2) - S**2/(MU - T)**2 9749C 9750C FOR XI WHERE 9751C 9752C OMEGA(h,XI) = (h/(1-h))*NORPDF(XI)/NORCDF(XI) 9753C 9754C NOTE THAT XI IS THE STANDARDIZED TRUNCATION 9755C POINT. ONCE WE SOLVE FOR XI, WE PLUG IT INTO 9756C THE FUNCTION 9757C 9758C LAMBDA = OMEGA(h,XI)/(OMEGA(h,XI) - XI) 9759C 9760C NOTE THAT THERE MAY BE TWO SOLUTIONS TO THIS 9761C EQUATION. WE PICK THE ONE THAT RESULTS IN A 9762C POSITIVE LAMBDA. 9763C 9764C REFERENCE--CLIFFORD COHEN (1991), "TRUNCATED AND CENSORED 9765C SAMPLES", MARCEL DEKKER INC., CHAPTER 2. 9766C WRITTEN BY--JAMES J. FILLIBEN 9767C STATISTICAL ENGINEERING DIVISION 9768C INFORMATION TECHNOLOGY LABORATORY 9769C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 9770C GAITHERSBURG, MD 20899-8980 9771C PHONE--301-975-2855 9772C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 9773C OF THE NATIONAL BUREAU OF STANDARDS. 9774C LANGUAGE--ANSI FORTRAN (1977) 9775C VERSION NUMBER--2008/12 9776C ORIGINAL VERSION--DECEMBER 2008. 9777C 9778C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 9779C 9780 CHARACTER*4 ISUBRO 9781 CHARACTER*4 IBUGA3 9782 CHARACTER*4 IERROR 9783C 9784 CHARACTER*4 IWRITE 9785 CHARACTER*4 ISUBN1 9786 CHARACTER*4 ISUBN2 9787C 9788C--------------------------------------------------------------------- 9789C 9790 DIMENSION Y(*) 9791 DIMENSION X(*) 9792 DIMENSION TEMP1(*) 9793C 9794 DOUBLE PRECISION DSUM1 9795 DOUBLE PRECISION DMEAN 9796 DOUBLE PRECISION DVARI 9797 DOUBLE PRECISION DT 9798 DOUBLE PRECISION V1P 9799 DOUBLE PRECISION V2P 9800 DOUBLE PRECISION V3P 9801 DOUBLE PRECISION DNTOT 9802 DOUBLE PRECISION DNFULL 9803 DOUBLE PRECISION DPDF 9804 DOUBLE PRECISION DCDF 9805 DOUBLE PRECISION DTERM1 9806 DOUBLE PRECISION DNUM1 9807 DOUBLE PRECISION DNUM2 9808 DOUBLE PRECISION DDENOM 9809 DOUBLE PRECISION DDENO2 9810 DOUBLE PRECISION DOMEGA 9811 DOUBLE PRECISION DLAMB 9812 DOUBLE PRECISION DQ 9813 DOUBLE PRECISION DPHI11 9814 DOUBLE PRECISION DPHI12 9815 DOUBLE PRECISION DPHI22 9816 DOUBLE PRECISION DU11 9817 DOUBLE PRECISION DU12 9818 DOUBLE PRECISION DU22 9819C 9820 REAL MUMOME 9821 REAL SDMOME 9822 REAL MUML 9823 REAL SDML 9824 REAL MUMLSE 9825 REAL SDMLSE 9826C 9827 DOUBLE PRECISION AE 9828 DOUBLE PRECISION RE 9829 DOUBLE PRECISION XLOW 9830 DOUBLE PRECISION XUP 9831 DOUBLE PRECISION XMID 9832 DOUBLE PRECISION XI 9833C 9834 DOUBLE PRECISION TNRFUN 9835 EXTERNAL TNRFUN 9836C 9837 DOUBLE PRECISION DC1 9838 DOUBLE PRECISION DH 9839 COMMON/TNRCOM/DC1,DH 9840C 9841C-----COMMON---------------------------------------------------------- 9842C 9843 INCLUDE 'DPCOP2.INC' 9844C 9845C-----START POINT----------------------------------------------------- 9846C 9847 ISUBN1='DPTN' 9848 ISUBN2='S1 ' 9849 IERROR='NO' 9850 IWRITE='OFF' 9851C 9852C ******************************************** 9853C ** STEP 1-- ** 9854C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 9855C ******************************************** 9856C 9857 IF(N.LE.2)THEN 9858 WRITE(ICOUT,999) 9859 999 FORMAT(1X) 9860 CALL DPWRST('XXX','BUG ') 9861 WRITE(ICOUT,31) 9862 31 FORMAT('***** ERROR IN TRUNCATED NORMAL SINGLY TRUNCATED ', 9863 1 'PARAMETER ESTIMATION--') 9864 CALL DPWRST('XXX','BUG ') 9865 WRITE(ICOUT,32) 9866 32 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.') 9867 CALL DPWRST('XXX','BUG ') 9868 WRITE(ICOUT,34)N 9869 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) 9870 CALL DPWRST('XXX','BUG ') 9871 WRITE(ICOUT,999) 9872 CALL DPWRST('XXX','BUG ') 9873 IERROR='YES' 9874 GOTO9000 9875 ENDIF 9876C 9877 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TNS1')THEN 9878 WRITE(ICOUT,999) 9879 CALL DPWRST('XXX','BUG ') 9880 WRITE(ICOUT,70) 9881 70 FORMAT('***** AT THE BEGINNING OF DPTNS1--') 9882 CALL DPWRST('XXX','BUG ') 9883 WRITE(ICOUT,71)N 9884 71 FORMAT('N = ',I8) 9885 CALL DPWRST('XXX','BUG ') 9886 DO73I=1,N 9887 WRITE(ICOUT,74)I,Y(I),X(I) 9888 74 FORMAT('I,Y(I),X(I) = ',I8,2G15.7) 9889 CALL DPWRST('XXX','BUG ') 9890 73 CONTINUE 9891 ENDIF 9892C 9893C ********************************************** 9894C ** STEP 2-- ** 9895C ** COMPUTE SUMMARY STATISTICS ** 9896C ********************************************** 9897C 9898 MUMOME=0.0 9899 SDMOME=0.0 9900 MUML=0.0 9901 SDML=0.0 9902C 9903 NC=0 9904 NFULL=0 9905 YMIN=CPUMAX 9906 DSUM1=0.0D0 9907C 9908 DO1010I=1,N 9909 IF(X(I).GT.0.0)THEN 9910 NFULL=NFULL+1 9911 TEMP1(NFULL)=Y(I) 9912 DSUM1=DSUM1 + DBLE(Y(I)) 9913 IF(Y(I).LT.YMIN)YMIN=Y(I) 9914 ELSE 9915 NC=NC+1 9916 ENDIF 9917 1010 CONTINUE 9918 DNFULL=DBLE(NFULL) 9919 DNC=DBLE(NC) 9920 DNTOT=DBLE(N) 9921 DMEAN=DSUM1/DNFULL 9922 IF(T.GT.CPUMIN .AND. T.LE.YMIN)THEN 9923 DT=DBLE(T) 9924 ELSE 9925 DT=DBLE(YMIN) 9926 ENDIF 9927C 9928 IF(NFULL.LT.2)THEN 9929 WRITE(ICOUT,999) 9930 CALL DPWRST('XXX','BUG ') 9931 WRITE(ICOUT,31) 9932 CALL DPWRST('XXX','BUG ') 9933 WRITE(ICOUT,1012) 9934 1012 FORMAT(' THE NUMBER OF UNTRUNCATED OBSERVATIONS MUST BE ', 9935 1 'AT LEAST 2.') 9936 CALL DPWRST('XXX','BUG ') 9937 WRITE(ICOUT,1014)NFULL 9938 1014 FORMAT(' THE NUMBER OF UNTRUNCATED OBSERVATIONS HERE = ', 9939 1 I8) 9940 CALL DPWRST('XXX','BUG ') 9941 WRITE(ICOUT,999) 9942 CALL DPWRST('XXX','BUG ') 9943 IERROR='YES' 9944 GOTO9000 9945 ENDIF 9946C 9947 DVARI=0.0D0 9948 V3P=0.0D0 9949 DO1020I=1,NFULL 9950 DVARI=DVARI + (DBLE(TEMP1(I)) - DMEAN)**2/DNFULL 9951 V3P=V3P + (DBLE(TEMP1(I)) - DT)**3/DNFULL 9952 1020 CONTINUE 9953 V1P=DMEAN - DT 9954 V2P=DVARI + (DMEAN - DT)**2 9955C 9956 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TNS1')THEN 9957 WRITE(ICOUT,999) 9958 CALL DPWRST('XXX','BUG ') 9959 WRITE(ICOUT,1031) 9960 1031 FORMAT('***** DPTNS1: AFTER COMPUTE SUMMARY STATISTICS') 9961 CALL DPWRST('XXX','BUG ') 9962 WRITE(ICOUT,1032)N,NFULL,NC 9963 1032 FORMAT('N,NFULL,NC = ',3I8) 9964 CALL DPWRST('XXX','BUG ') 9965 WRITE(ICOUT,1033)DMEAN,DVARI,DT,V1P,V2P,V3P 9966 1033 FORMAT('DMEAN,DVARI,DT,V1P,V2P,V3P = ',6G15.7) 9967 CALL DPWRST('XXX','BUG ') 9968 ENDIF 9969C 9970C ********************************************** 9971C ** STEP 3-- ** 9972C ** COMPUTE 3-MOMENT ESTIMATES ** 9973C ********************************************** 9974C 9975 DNUM1=V2P**2 - V1P*V3P 9976 DDENOM=V2P - 2.0D0*V1P**2 9977 SDMOME=REAL(DSQRT(DNUM1/DDENOM)) 9978 DNUM2=V3P - 2.0D0*V1P*V2P 9979 DDENO2=V2P - 2.0D0*V1P**2 9980 MUMOME=REAL(DT + (DNUM2/DDENO2)) 9981C 9982 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TNS1')THEN 9983 WRITE(ICOUT,999) 9984 CALL DPWRST('XXX','BUG ') 9985 WRITE(ICOUT,1101) 9986 1101 FORMAT('***** DPTNS1: AFTER COMPUTE 3-MOMENT ESTIMATES') 9987 CALL DPWRST('XXX','BUG ') 9988 WRITE(ICOUT,1102)DNUM1,DDENOM,SDMOME 9989 1102 FORMAT('DNUM1,DDENOM,SDMOME = ',3G15.7) 9990 CALL DPWRST('XXX','BUG ') 9991 WRITE(ICOUT,1103)DNUM2,DDENO2,MUMOME 9992 1103 FORMAT('DNUM2,DENO2,MUMOME = ',3G15.7) 9993 CALL DPWRST('XXX','BUG ') 9994 ENDIF 9995C 9996C ********************************************** 9997C ** STEP 4-- ** 9998C ** COMPUTE MAXIMUM LIKELIHOOD ESTIMATES ** 9999C ********************************************** 10000C 10001C DEFINE SOME CONSTANTS FOR THE FUNCTION SOLVER 10002C 10003 DH=DNC/DNTOT 10004 DC1=DVARI/(DMEAN - DT)**2 10005C 10006C USE DFZERO TO SOLVE THE LAMBDAHAT FUNCTION 10007C 10008 AE=1.D-7 10009 RE=1.D-7 10010 XLOW=-10.0D0 10011 XUP=10.0D0 10012 IF(DMEAN.GT.DT)THEN 10013 XMID=-1.0D0 10014 ELSE 10015 XMID=1.0D0 10016 ENDIF 10017 ITER=0 10018C 10019 1410 CONTINUE 10020 CALL DFZERO(TNRFUN,XLOW,XUP,XMID,RE,AE,IFLAG) 10021 XI=XLOW 10022C 10023C NOW EVALUATE - CHECK FOR POSITIVE RESULT 10024C 10025 CALL NODPDF(XI,DPDF) 10026 CALL NODCDF(XI,DCDF) 10027 DOMEGA=(DH/(1.0D0-DH))*DPDF/DCDF 10028 DLAMB=DOMEGA/(DOMEGA - XI) 10029 IF(DLAMB.LT.0.0D0)THEN 10030 IF(ITER.EQ.0)THEN 10031 ITER=1 10032 XLOW=-10.0D0 10033 XUP=XI-0.1D0 10034 XMID=(XLOW+XUP)/2.0D0 10035 GOTO1410 10036 ELSEIF(ITER.EQ.1)THEN 10037 ITER=2 10038 XLOW=XI+0.1D0 10039 XUP=10.0D0 10040 XMID=(XLOW+XUP)/2.0D0 10041 GOTO1410 10042 ELSE 10043 WRITE(ICOUT,999) 10044 CALL DPWRST('XXX','BUG ') 10045 WRITE(ICOUT,31) 10046 CALL DPWRST('XXX','BUG ') 10047 WRITE(ICOUT,1413) 10048 1413 FORMAT(' UNABLE TO DETERMINE MAXIMUM LIKELIHOOD ', 10049 1 'ESTIMATES.') 10050 CALL DPWRST('XXX','BUG ') 10051 GOTO1499 10052 ENDIF 10053 ENDIF 10054C 10055 SDML=REAL(DSQRT(DVARI + DLAMB*(DMEAN - DT)**2)) 10056 MUML=REAL(DMEAN - DLAMB*(DMEAN - DT)) 10057C 10058C NOW COMPUTE STANDARD ERRORS 10059C 10060 IF(DCDF.GE.1.0D0)THEN 10061 WRITE(ICOUT,999) 10062 CALL DPWRST('XXX','BUG ') 10063 WRITE(ICOUT,1431) 10064 1431 FORMAT('***** WARNING IN TRUNCATED NORMAL SINGLY TRUNCATED ', 10065 1 'PARAMETER ESTIMATION--') 10066 CALL DPWRST('XXX','BUG ') 10067 WRITE(ICOUT,1433) 10068 1433 FORMAT(' UNABLE TO COMPUTE STANDARD ERRORS OF THE ', 10069 1 'MAXIMUM LIKELIHOOD ESTIMATES.') 10070 CALL DPWRST('XXX','BUG ') 10071 GOTO1499 10072 ENDIF 10073C 10074 DQ=DPDF/(1.0D0 - DCDF) 10075 DPHI11=1.0D0 - DQ*(DQ - XI) 10076 DPHI12=DQ*(1.0D0 - XI*(DQ - XI)) 10077 DPHI22=2.0D0 + XI*DPHI12 10078 DDENOM=DPHI11*DPHI22 - DPHI12**2 10079 DU11=DPHI22/DDENOM 10080 DU22=DPHI11/DDENOM 10081 DU12=-DPHI12/DDENOM 10082CCCCC DTERM1=DBLE(SDML)**2/DBLE(NFULL) 10083 DTERM1=DBLE(SDML)**2/DNTOT 10084 MUMLSE=REAL(DSQRT(DTERM1*DU11)) 10085 SDMLSE=REAL(DSQRT(DTERM1*DU22)) 10086 COVSE=REAL(DTERM1*DU12) 10087C 10088 1499 CONTINUE 10089C 10090 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TNS1')THEN 10091 WRITE(ICOUT,999) 10092 CALL DPWRST('XXX','BUG ') 10093 WRITE(ICOUT,1111) 10094 1111 FORMAT('***** DPTNS1: AFTER COMPUTE ML ESTIMATES') 10095 CALL DPWRST('XXX','BUG ') 10096 WRITE(ICOUT,1112)DH,XI,DPDF,DCDF 10097 1112 FORMAT('DH,XI,DPDF,DCDF = ',4G15.7) 10098 CALL DPWRST('XXX','BUG ') 10099 WRITE(ICOUT,1113)DTERM1,DOMEGA,DLAMB 10100 1113 FORMAT('DTERM1,DOMEGA,DLAMB = ',3G15.7) 10101 CALL DPWRST('XXX','BUG ') 10102 WRITE(ICOUT,1114)MUML,SDML 10103 1114 FORMAT('MUML,SDML = ',2G15.7) 10104 CALL DPWRST('XXX','BUG ') 10105 WRITE(ICOUT,1115)DQ,DPHI11,DPHI12,DPHI22 10106 1115 FORMAT('DQ,DPHI11,DPHI12,DPHI22 = ',4G15.7) 10107 CALL DPWRST('XXX','BUG ') 10108 WRITE(ICOUT,1116)DDENOM,DU11,DU22,DU12 10109 1116 FORMAT('DDENOM,DU11,DU22,DU12 = ',4G15.7) 10110 CALL DPWRST('XXX','BUG ') 10111 ENDIF 10112C 10113C ****************** 10114C ** STEP 90-- ** 10115C ** EXIT ** 10116C ****************** 10117C 10118 9000 CONTINUE 10119 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TNS1')THEN 10120 WRITE(ICOUT,999) 10121 CALL DPWRST('XXX','BUG ') 10122 WRITE(ICOUT,9011) 10123 9011 FORMAT('***** AT THE END OF DPTNS1--') 10124 CALL DPWRST('XXX','BUG ') 10125 ENDIF 10126C 10127 RETURN 10128 END 10129 SUBROUTINE DPTOLI(XTEMP1,XTEMP2,XTEMP3,MAXNXT, 10130 1 ICASAN,ICAPSW,IFORSW, 10131 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 10132C 10133C PURPOSE--GENERATE TOLERANCE LIMITS 10134C WRITTEN BY--JAMES J. FILLIBEN 10135C STATISTICAL ENGINEERING DIVISION 10136C INFORMATION TECHNOLOGY LABORATORY 10137C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10138C GAITHERSBURG, MD 20899-8980 10139C PHONE--301-975-2855 10140C EXAMPLE--TOLERANCE LIMITS Y 10141C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 10142C OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY. 10143C LANGUAGE--ANSI FORTRAN (1977) 10144C VERSION NUMBER--98/11 10145C ORIGINAL VERSION--NOVEMBER 1998. 10146C UPDATED --MARCH 2011. USE DPPARS ROUTINE 10147C UPATED --MARCH 2011. REWRITTEN TO HANDLE MULTIPLE 10148C RESPONSE VARIABLES, GROUP-ID 10149C VARIABLES, OR A LAB-ID VARIABLE 10150C UPATED --AUGUST 2011. CHECK FOR CONFLICT WITH ABASIS AND 10151C BBASIS TOLERANCE INTERVALS 10152C UPATED --AUGUST 2011. ADD ONE-SIDED CASE FOR NORMAL TOLERANCE 10153C LIMITS 10154C UPATED --AUGUST 2011. ADD SUMMARY DATA FOR NORMAL TOLERANCE 10155C LIMITS (I.E., MEAN, SD, SAMPLE SIZE) 10156C UPATED --AUGUST 2011. ADD WEIBULL TOLERANCE LIMITS 10157C UPATED --MAY 2014. ADD LOGNORMAL TOLERANCE LIMITS 10158C UPATED --MAY 2014. ADD BOX COX TOLERANCE LIMITS 10159C UPATED --JULY 2019. TWEAK SCRATCH SPACE 10160C 10161C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10162C 10163 CHARACTER*4 ICASAN 10164 CHARACTER*4 ICASA2 10165 CHARACTER*4 ICAPSW 10166 CHARACTER*4 ICASDI 10167 CHARACTER*4 IFORSW 10168 CHARACTER*4 IBUGA2 10169 CHARACTER*4 IBUGA3 10170 CHARACTER*4 IBUGQ 10171 CHARACTER*4 ISUBRO 10172 CHARACTER*4 IFOUND 10173 CHARACTER*4 IERROR 10174C 10175 CHARACTER*4 IDATSW 10176 CHARACTER*4 ISUBN1 10177 CHARACTER*4 ISUBN2 10178 CHARACTER*4 ISTEPN 10179 CHARACTER*4 IREPL 10180 CHARACTER*4 IMULT 10181 CHARACTER*4 ICTMP1 10182 CHARACTER*4 ICTMP2 10183 CHARACTER*4 ICTMP3 10184 CHARACTER*4 ICTMP4 10185 CHARACTER*4 ICASE 10186C 10187 CHARACTER*40 INAME 10188 PARAMETER (MAXSPN=30) 10189 CHARACTER*4 IVARN1(MAXSPN) 10190 CHARACTER*4 IVARN2(MAXSPN) 10191 CHARACTER*4 IVARTY(MAXSPN) 10192 CHARACTER*4 IVARID(1) 10193 CHARACTER*4 IVARI2(1) 10194 REAL PVAR(MAXSPN) 10195 REAL PID(MAXSPN) 10196 INTEGER ILIS(MAXSPN) 10197 INTEGER NRIGHT(MAXSPN) 10198 INTEGER ICOLR(MAXSPN) 10199C 10200C--------------------------------------------------------------------- 10201C 10202 INCLUDE 'DPCOPA.INC' 10203C 10204 DIMENSION XTEMP1(*) 10205 DIMENSION XTEMP2(*) 10206 DIMENSION XTEMP3(*) 10207 DIMENSION Y1(MAXOBV) 10208C 10209 DIMENSION XDESGN(MAXOBV,7) 10210 DIMENSION XIDTEM(MAXOBV) 10211 DIMENSION XIDTE2(MAXOBV) 10212 DIMENSION XIDTE3(MAXOBV) 10213 DIMENSION XIDTE4(MAXOBV) 10214 DIMENSION XIDTE5(MAXOBV) 10215 DIMENSION XIDTE6(MAXOBV) 10216C 10217 DIMENSION TEMP1(MAXOBV) 10218 DOUBLE PRECISION DTEMP1(MAXOBV) 10219C 10220 INCLUDE 'DPCOZZ.INC' 10221 INCLUDE 'DPCOZD.INC' 10222C 10223 EQUIVALENCE (GARBAG(IGARB1),Y1(1)) 10224 EQUIVALENCE (GARBAG(IGARB2),TEMP1(1)) 10225 EQUIVALENCE (GARBAG(IGARB3),XIDTEM(1)) 10226 EQUIVALENCE (GARBAG(IGARB4),XIDTE2(1)) 10227 EQUIVALENCE (GARBAG(IGARB5),XIDTE3(1)) 10228 EQUIVALENCE (GARBAG(IGARB6),XIDTE4(1)) 10229 EQUIVALENCE (GARBAG(IGARB7),XIDTE5(1)) 10230 EQUIVALENCE (GARBAG(IGARB8),XIDTE6(1)) 10231 EQUIVALENCE (GARBAG(IGARB9),XDESGN(1,1)) 10232 EQUIVALENCE (DGARBG(IDGAR1),DTEMP1(1)) 10233C 10234C-----COMMON---------------------------------------------------------- 10235C 10236 INCLUDE 'DPCOHK.INC' 10237 INCLUDE 'DPCODA.INC' 10238 INCLUDE 'DPCOSU.INC' 10239 INCLUDE 'DPCOS2.INC' 10240 INCLUDE 'DPCOHO.INC' 10241 INCLUDE 'DPCOMC.INC' 10242 INCLUDE 'DPCOST.INC' 10243 INCLUDE 'DPCOP2.INC' 10244C 10245C-----START POINT----------------------------------------------------- 10246C 10247 IERROR='NO' 10248 IFOUND='NO' 10249 ICASAN='TOLE' 10250 ICASA2='TWOS' 10251 ICASDI='NORM' 10252 IREPL='OFF' 10253 IMULT='OFF' 10254 ISUBN1='DPTO' 10255 ISUBN2='LI ' 10256 XMEAN=CPUMIN 10257 XSD=CPUMIN 10258 AN=CPUMIN 10259C 10260 MAXCP1=MAXCOL+1 10261 MAXCP2=MAXCOL+2 10262 MAXCP3=MAXCOL+3 10263 MAXCP4=MAXCOL+4 10264 MAXCP5=MAXCOL+5 10265 MAXCP6=MAXCOL+6 10266C 10267C *********************************************** 10268C ** TREAT THE TOLERANCE LIMITS TEST CASE ** 10269C *********************************************** 10270C 10271 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TOLI')THEN 10272 WRITE(ICOUT,999) 10273 999 FORMAT(1X) 10274 CALL DPWRST('XXX','BUG ') 10275 WRITE(ICOUT,51) 10276 51 FORMAT('***** AT THE BEGINNING OF DPTOLI--') 10277 CALL DPWRST('XXX','BUG ') 10278 WRITE(ICOUT,52)ICASAN,MAXNXT 10279 52 FORMAT('ICASAN,MAXNXT = ',A4,2X,I8) 10280 CALL DPWRST('XXX','BUG ') 10281 WRITE(ICOUT,53)IBUGA2,IBUGA3,IBUGQ,ISUBRO 10282 53 FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',3(A4,2X),A4) 10283 CALL DPWRST('XXX','BUG ') 10284 ENDIF 10285C 10286C ***************************************************** 10287C ** STEP 1-- ** 10288C ** EXTRACT THE COMMAND ** 10289C ** LOOK FOR ONE OF THE FOLLOWING COMMANDS: ** 10290C ** 1) TOLERANCE LIMITS Y ** 10291C ** 2) MULTIPLE TOLERANCE LIMITS Y1 ... YK ** 10292C ** 3) REPLICATED TOLERANCE LIMITS Y X1 ... XK ** 10293C ***************************************************** 10294C 10295 ISTEPN='1' 10296 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TOLI') 10297 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10298C 10299 ILASTC=9999 10300 ILASTZ=9999 10301 ICASAN='TOLE' 10302 IDATSW='RAW' 10303C 10304 DO100I=0,NUMARG-1 10305C 10306 IF(I.EQ.0)THEN 10307 ICTMP1=ICOM 10308 ELSE 10309 ICTMP1=IHARG(I) 10310 ENDIF 10311 ICTMP2=IHARG(I+1) 10312 ICTMP3=IHARG(I+2) 10313 ICTMP4=IHARG(I+3) 10314C 10315 IF(ICTMP1.EQ.'=')THEN 10316 IFOUND='NO' 10317 GOTO9000 10318 ELSEIF(ICTMP1.EQ.'ABAS')THEN 10319 IFOUND='NO' 10320 GOTO9000 10321 ELSEIF(ICTMP1.EQ.'A ' .AND. ICTMP2.EQ.'BASI')THEN 10322 IFOUND='NO' 10323 GOTO9000 10324 ELSEIF(ICTMP1.EQ.'BBAS')THEN 10325 IFOUND='NO' 10326 GOTO9000 10327 ELSEIF(ICTMP1.EQ.'B ' .AND. ICTMP2.EQ.'BASI')THEN 10328 IFOUND='NO' 10329 GOTO9000 10330 ELSEIF(ICTMP1.EQ.'TOLE' .AND. 10331 1 (ICTMP2.EQ.'LIMI' .OR. ICTMP2.EQ.'INTE'))THEN 10332 IFOUND='YES' 10333 ILASTC=I 10334 ILASTZ=I+1 10335 ELSEIF(ICTMP1.EQ.'TOLE')THEN 10336 IFOUND='YES' 10337 ILASTC=I 10338 ILASTZ=I 10339 ELSEIF(ICTMP1.EQ.'REPL')THEN 10340 IREPL='ON' 10341 ILASTC=MIN(ILASTC,I) 10342 ILASTZ=MAX(ILASTZ,I) 10343 ELSEIF(ICTMP1.EQ.'MULT')THEN 10344 IMULT='ON' 10345 ILASTC=MIN(ILASTC,I) 10346 ILASTZ=MAX(ILASTZ,I) 10347 ELSEIF(ICTMP1.EQ.'NORM')THEN 10348 ICASAN='NTOL' 10349 ICASDI='NORM' 10350 ILASTC=MIN(ILASTC,I) 10351 ILASTZ=MAX(ILASTZ,I) 10352 ELSEIF(ICTMP1.EQ.'WEIB')THEN 10353 ICASDI='WEIB' 10354 ILASTC=MIN(ILASTC,I) 10355 ILASTZ=MAX(ILASTZ,I) 10356 ELSEIF(ICTMP1.EQ.'LOGN')THEN 10357 ICASAN='LNTO' 10358 ICASDI='LOGN' 10359 ILASTC=MIN(ILASTC,I) 10360 ILASTZ=MAX(ILASTZ,I) 10361 ELSEIF(ICTMP1.EQ.'BOXC')THEN 10362 ICASAN='BCTO' 10363 ICASDI='BOXC' 10364 ILASTC=MIN(ILASTC,I) 10365 ILASTZ=MAX(ILASTZ,I) 10366 ELSEIF(ICTMP1.EQ.'BOX' .AND. ICTMP2.EQ.'COX')THEN 10367 ICASAN='BCTO' 10368 ICASDI='BOXC' 10369 ILASTC=MIN(ILASTC,I) 10370 ILASTZ=MAX(ILASTZ,I+1) 10371 ELSEIF(ICTMP1.EQ.'LOWE')THEN 10372 ICASA2='LOWE' 10373 ILASTC=MIN(ILASTC,I) 10374 ILASTZ=MAX(ILASTZ,I) 10375 ELSEIF(ICTMP1.EQ.'UPPE')THEN 10376 ICASA2='UPPE' 10377 ILASTC=MIN(ILASTC,I) 10378 ILASTZ=MAX(ILASTZ,I) 10379 ELSEIF(ICTMP1.EQ.'SUMM')THEN 10380 IDATSW='SUMM' 10381 ILASTC=MIN(ILASTC,I) 10382 ILASTZ=MAX(ILASTZ,I) 10383 ELSEIF(ICTMP1.EQ.'NONP')THEN 10384 ICASAN='NPTO' 10385 ILASTC=MIN(ILASTC,I) 10386 ILASTZ=MAX(ILASTZ,I) 10387 ENDIF 10388 100 CONTINUE 10389C 10390 IF(IFOUND.EQ.'NO')GOTO9000 10391C 10392 ISHIFT=ILASTZ 10393 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 10394 1 IBUGA2,IERROR) 10395C 10396 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TOLI')THEN 10397 WRITE(ICOUT,91)ICASAN,IMULT,IREPL,ISHIFT 10398 91 FORMAT('DPTOLI: ICASAN,IMULT,IREPL,ISHIFT = ',3(A4,2X),I5) 10399 CALL DPWRST('XXX','BUG ') 10400 ENDIF 10401C 10402 IF(IMULT.EQ.'ON')THEN 10403 IF(IREPL.EQ.'ON')THEN 10404 WRITE(ICOUT,999) 10405 CALL DPWRST('XXX','BUG ') 10406 WRITE(ICOUT,101) 10407 101 FORMAT('***** ERROR IN TOLERANCE LIMITS--') 10408 CALL DPWRST('XXX','BUG ') 10409 WRITE(ICOUT,102) 10410 102 FORMAT(' YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ', 10411 1 '"REPLICATION"') 10412 CALL DPWRST('XXX','BUG ') 10413 WRITE(ICOUT,104) 10414 104 FORMAT(' FOR THE TOLERANCE LIMITS TEST COMMAND.') 10415 CALL DPWRST('XXX','BUG ') 10416 IERROR='YES' 10417 GOTO9000 10418 ENDIF 10419 ENDIF 10420C 10421 IF(IDATSW.EQ.'SUMM')THEN 10422 IF(IREPL.EQ.'ON')THEN 10423 WRITE(ICOUT,999) 10424 CALL DPWRST('XXX','BUG ') 10425 WRITE(ICOUT,101) 10426 CALL DPWRST('XXX','BUG ') 10427 WRITE(ICOUT,112) 10428 112 FORMAT(' YOU CANNOT SPECIFY BOTH "SUMMARY" AND ', 10429 1 '"REPLICATION"') 10430 CALL DPWRST('XXX','BUG ') 10431 WRITE(ICOUT,104) 10432 CALL DPWRST('XXX','BUG ') 10433 IERROR='YES' 10434 GOTO9000 10435 ELSEIF(IMULT.EQ.'ON')THEN 10436 WRITE(ICOUT,999) 10437 CALL DPWRST('XXX','BUG ') 10438 WRITE(ICOUT,101) 10439 CALL DPWRST('XXX','BUG ') 10440 WRITE(ICOUT,122) 10441 122 FORMAT(' YOU CANNOT SPECIFY BOTH "SUMMARY" AND ', 10442 1 '"MULTIPLE"') 10443 CALL DPWRST('XXX','BUG ') 10444 WRITE(ICOUT,104) 10445 CALL DPWRST('XXX','BUG ') 10446 IERROR='YES' 10447 GOTO9000 10448 ELSEIF(ICASDI.EQ.'WEIB')THEN 10449 WRITE(ICOUT,999) 10450 CALL DPWRST('XXX','BUG ') 10451 WRITE(ICOUT,101) 10452 CALL DPWRST('XXX','BUG ') 10453 WRITE(ICOUT,132) 10454 132 FORMAT(' YOU CANNOT SPECIFY BOTH "SUMMARY" AND ', 10455 1 '"WEIBULL"') 10456 CALL DPWRST('XXX','BUG ') 10457 WRITE(ICOUT,104) 10458 CALL DPWRST('XXX','BUG ') 10459 IERROR='YES' 10460 ELSEIF(ICASDI.EQ.'LOGN')THEN 10461 WRITE(ICOUT,999) 10462 CALL DPWRST('XXX','BUG ') 10463 WRITE(ICOUT,101) 10464 CALL DPWRST('XXX','BUG ') 10465 WRITE(ICOUT,142) 10466 142 FORMAT(' YOU CANNOT SPECIFY BOTH "SUMMARY" AND ', 10467 1 '"LOGNORMAL"') 10468 CALL DPWRST('XXX','BUG ') 10469 WRITE(ICOUT,104) 10470 CALL DPWRST('XXX','BUG ') 10471 IERROR='YES' 10472 ENDIF 10473 ENDIF 10474C 10475C ********************************* 10476C ** STEP 4-- ** 10477C ** EXTRACT THE VARIABLE LIST ** 10478C ********************************* 10479C 10480 ISTEPN='4' 10481 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TOLI') 10482 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10483C 10484 INAME='TOLERANCE LIMITS' 10485 MINNA=1 10486 MAXNA=100 10487 MINN2=2 10488 IFLAGE=0 10489 IFLAGM=1 10490 IF(IREPL.EQ.'ON')THEN 10491 IFLAGM=0 10492 IFLAGE=1 10493 ENDIF 10494 IFLAGP=0 10495 JMIN=1 10496 JMAX=NUMARG 10497 MINNVA=1 10498 MAXNVA=MAXSPN 10499 IF(IDATSW.EQ.'SUMM')THEN 10500 MINN2=1 10501 IFLAGM=0 10502 IFLAGP=19 10503 MINNVA=3 10504 MAXNVA=3 10505 ENDIF 10506C 10507 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 10508 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 10509 1 JMIN,JMAX, 10510 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 10511 1 IVARN1,IVARN2,IVARTY,PVAR, 10512 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 10513 1 MINNVA,MAXNVA, 10514 1 IFLAGM,IFLAGP, 10515 1 IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 10516 IF(IERROR.EQ.'YES')GOTO9000 10517C 10518 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TOLI')THEN 10519 WRITE(ICOUT,999) 10520 CALL DPWRST('XXX','BUG ') 10521 WRITE(ICOUT,281) 10522 281 FORMAT('***** AFTER CALL DPPARS--') 10523 CALL DPWRST('XXX','BUG ') 10524 WRITE(ICOUT,282)NQ,NUMVAR 10525 282 FORMAT('NQ,NUMVAR = ',2I8) 10526 CALL DPWRST('XXX','BUG ') 10527 IF(NUMVAR.GT.0)THEN 10528 DO285I=1,NUMVAR 10529 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 10530 1 ICOLR(I) 10531 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 10532 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 10533 CALL DPWRST('XXX','BUG ') 10534 285 CONTINUE 10535 ENDIF 10536 ENDIF 10537C 10538C *********************************************** 10539C ** STEP 5-- ** 10540C ** DETERMINE: ** 10541C ** 1) NUMBER OF REPLICATION VARIABLES (0-6) ** 10542C ** 2) NUMBER OF RESPONSE VARIABLES (>= 1)** 10543C *********************************************** 10544C 10545 ISTEPN='5' 10546 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TOLI') 10547 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10548C 10549 IF(IDATSW.EQ.'SUMM')GOTO599 10550 NRESP=0 10551 NREPL=0 10552 IF(IMULT.EQ.'ON')THEN 10553 NRESP=NUMVAR 10554 ELSEIF(IREPL.EQ.'ON')THEN 10555 NRESP=1 10556 NREPL=NUMVAR-NRESP 10557 IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN 10558 WRITE(ICOUT,999) 10559 CALL DPWRST('XXX','BUG ') 10560 WRITE(ICOUT,101) 10561 CALL DPWRST('XXX','BUG ') 10562 WRITE(ICOUT,511) 10563 511 FORMAT(' FOR THE REPLICATION CASE, THE NUMBER OF ', 10564 1 'REPLICATION VARIABLES') 10565 CALL DPWRST('XXX','BUG ') 10566 WRITE(ICOUT,512) 10567 512 FORMAT(' MUST BE BETWEEN ONE AND SIX.') 10568 CALL DPWRST('XXX','BUG ') 10569 WRITE(ICOUT,513)NREPL 10570 513 FORMAT(' THE NUMBER OF REPLICATION VARIABLES = ',I5) 10571 CALL DPWRST('XXX','BUG ') 10572 IERROR='YES' 10573 GOTO9000 10574 ENDIF 10575 ELSE 10576 NRESP=NUMVAR 10577 IMULT='ON' 10578 ENDIF 10579C 10580 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TOLI')THEN 10581 WRITE(ICOUT,521)NRESP,NREPL 10582 521 FORMAT('NRESP,NREPL = ',2I5) 10583 CALL DPWRST('XXX','BUG ') 10584 ENDIF 10585C 10586 599 CONTINUE 10587C 10588C ****************************************************** 10589C ** STEP 6-- ** 10590C ** GENERATE THE TOLERANCE LIMITS TEST FOR THE ** 10591C ** VARIOUS CASES ** 10592C ****************************************************** 10593C 10594 ISTEPN='6' 10595 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TOLI') 10596 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10597C 10598C ****************************************** 10599C ** STEP 7A-- ** 10600C ** CASE 0: SUMMARY CASE ** 10601C ****************************************** 10602C 10603 IF(IDATSW.EQ.'SUMM')THEN 10604 ISTEPN='7A' 10605 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TOLI') 10606 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10607C 10608C TWO CASES: EITHER DATA ENTERED AS 3 PARAMETERS OR 10609C AS 3 VARIABLES 10610C 10611 NREPL=0 10612 IF(IVARTY(1).EQ.'PARA')THEN 10613 XMEAN=PVAR(1) 10614 XSD=PVAR(2) 10615 AN=PVAR(3) 10616 PID(1)=CPUMIN 10617 IVARID(1)='ROW ' 10618 IVARI2(1)='1 ' 10619 IF(ICASA2.EQ.'LOWE')THEN 10620 CALL TOL2(Y1,NLOCAL,XMEAN,XSD,AN, 10621 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 10622 1 PID,IVARID,IVARI2,NREPL, 10623 1 ISUBRO,IBUGA3,IERROR) 10624 ELSEIF(ICASA2.EQ.'UPPE')THEN 10625 CALL TOL2(Y1,NLOCAL,XMEAN,XSD,AN, 10626 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 10627 1 PID,IVARID,IVARI2,NREPL, 10628 1 ISUBRO,IBUGA3,IERROR) 10629 ELSE 10630 CALL TOL(Y1,NLOCAL,XMEAN,XSD,AN, 10631 1 XTEMP1,XTEMP2,XTEMP3, 10632 1 ICASAN,ICAPSW,ICAPTY,IFORSW, 10633 1 PID,IVARID,IVARI2,NREPL, 10634 1 ISUBRO,IBUGA3,IERROR) 10635 ENDIF 10636 ELSE 10637 ICOL=1 10638 NUMVA2=3 10639 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 10640 1 INAME,IVARN1,IVARN2,IVARTY, 10641 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 10642 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 10643 1 MAXCP4,MAXCP5,MAXCP6, 10644 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 10645 1 Y1,XTEMP1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE, 10646 1 IBUGA3,ISUBRO,IFOUND,IERROR) 10647 IF(IERROR.EQ.'YES')GOTO9000 10648C 10649 DO710IROW=1,NLOCAL 10650C 10651 PID(1)=CPUMIN 10652 IVARID(1)='ROW ' 10653 WRITE(IVARI2(1)(1:4),'(I4)')IROW 10654 XMEAN=Y1(IROW) 10655 XSD=XTEMP1(IROW) 10656 AN=XTEMP2(IROW) 10657C 10658 IF(ICASA2.EQ.'LOWE')THEN 10659 CALL TOL2(Y1,NLOCAL,XMEAN,XSD,AN, 10660 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 10661 1 PID,IVARID,IVARI2,NREPL, 10662 1 ISUBRO,IBUGA3,IERROR) 10663 ELSEIF(ICASA2.EQ.'UPPE')THEN 10664 CALL TOL2(Y1,NLOCAL,XMEAN,XSD,AN, 10665 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 10666 1 PID,IVARID,IVARI2,NREPL, 10667 1 ISUBRO,IBUGA3,IERROR) 10668 ELSE 10669 CALL TOL(Y1,NLOCAL,XMEAN,XSD,AN, 10670 1 XTEMP1,XTEMP2,XTEMP3, 10671 1 ICASAN,ICAPSW,ICAPTY,IFORSW, 10672 1 PID,IVARID,IVARI2,NREPL, 10673 1 ISUBRO,IBUGA3,IERROR) 10674 ENDIF 10675C 10676 710 CONTINUE 10677 ENDIF 10678 GOTO9000 10679 ENDIF 10680C 10681C 10682C ****************************************** 10683C ** STEP 8A-- ** 10684C ** CASE 1: NO REPLICATION VARIABLES ** 10685C ****************************************** 10686C 10687 IF(NREPL.LT.1)THEN 10688 ISTEPN='8A' 10689 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TOLI') 10690 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10691C 10692C LOOP THROUGH EACH OF THE RESPONSE VARIABLES 10693C 10694 NCURVE=0 10695 DO810IRESP=1,NRESP 10696 NCURVE=NCURVE+1 10697C 10698 IINDX=ICOLR(IRESP) 10699 PID(1)=CPUMIN 10700 IVARID(1)=IVARN1(IRESP) 10701 IVARI2(1)=IVARN2(IRESP) 10702C 10703 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TOLI')THEN 10704 WRITE(ICOUT,999) 10705 CALL DPWRST('XXX','BUG ') 10706 WRITE(ICOUT,811)IRESP,NCURVE 10707 811 FORMAT('IRESP,NCURVE = ',2I5) 10708 CALL DPWRST('XXX','BUG ') 10709 ENDIF 10710C 10711 ICOL=IRESP 10712 NUMVA2=1 10713 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 10714 1 INAME,IVARN1,IVARN2,IVARTY, 10715 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 10716 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 10717 1 MAXCP4,MAXCP5,MAXCP6, 10718 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 10719 1 Y1,XTEMP1,XTEMP1,NLOCAL,NLOCA2,NLOCA3,ICASE, 10720 1 IBUGA3,ISUBRO,IFOUND,IERROR) 10721 IF(IERROR.EQ.'YES')GOTO9000 10722C 10723C ***************************************************** 10724C ** STEP 8B-- ** 10725C ***************************************************** 10726C 10727 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TOLI')THEN 10728 ISTEPN='8B' 10729 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10730 WRITE(ICOUT,999) 10731 CALL DPWRST('XXX','BUG ') 10732 WRITE(ICOUT,822) 10733 822 FORMAT('***** FROM THE MIDDLE OF DPTOLI--') 10734 CALL DPWRST('XXX','BUG ') 10735 WRITE(ICOUT,823)ICASAN,NUMVAR,IDATSW,NLOCAL 10736 823 FORMAT('ICASAN,NUMVAR,IDATSW,NQ = ', 10737 1 A4,I8,2X,A4,I8) 10738 CALL DPWRST('XXX','BUG ') 10739 IF(NLOCAL.GE.1)THEN 10740 DO825I=1,NLOCAL 10741 WRITE(ICOUT,826)I,Y1(I) 10742 826 FORMAT('I,Y1(I) = ',I8,G15.7) 10743 CALL DPWRST('XXX','BUG ') 10744 825 CONTINUE 10745 ENDIF 10746 ENDIF 10747C 10748 IF(ICASDI.EQ.'WEIB')THEN 10749 CALL TOLWEI(Y1,NLOCAL, 10750 1 MINMAX,IWEIBC,XTEMP1,DTEMP1, 10751 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 10752 1 PID,IVARID,IVARI2,NREPL, 10753 1 ISUBRO,IBUGA3,IERROR) 10754 ELSEIF(ICASA2.EQ.'LOWE')THEN 10755 CALL TOL2(Y1,NLOCAL,XMEAN,XSD,AN, 10756 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 10757 1 PID,IVARID,IVARI2,NREPL, 10758 1 ISUBRO,IBUGA3,IERROR) 10759 ELSEIF(ICASA2.EQ.'UPPE')THEN 10760 CALL TOL2(Y1,NLOCAL,XMEAN,XSD,AN, 10761 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 10762 1 PID,IVARID,IVARI2,NREPL, 10763 1 ISUBRO,IBUGA3,IERROR) 10764 ELSE 10765 CALL TOL(Y1,NLOCAL,XMEAN,XSD,AN, 10766 1 XTEMP1,XTEMP2,XTEMP3, 10767 1 ICASAN,ICAPSW,ICAPTY,IFORSW, 10768 1 PID,IVARID,IVARI2,NREPL, 10769 1 ISUBRO,IBUGA3,IERROR) 10770 ENDIF 10771C 10772 810 CONTINUE 10773C 10774C **************************************************** 10775C ** STEP 9A-- ** 10776C ** CASE 3: ONE OR MORE REPLICATION VARIABLES. ** 10777C ** FOR THIS CASE, THE NUMBER OF RESPONSE ** 10778C ** VARIABLES MUST BE EXACTLY 1. ** 10779C ** FOR THIS CASE, ALL VARIABLES MUST ** 10780C ** HAVE THE SAME LENGTH. ** 10781C **************************************************** 10782C 10783 ELSEIF(NREPL.GE.1)THEN 10784 ISTEPN='9A' 10785 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TOLI') 10786 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10787C 10788 J=0 10789 IMAX=NRIGHT(1) 10790 IF(NQ.LT.NRIGHT(1))IMAX=NQ 10791 DO910I=1,IMAX 10792 IF(ISUB(I).EQ.0)GOTO910 10793 J=J+1 10794C 10795C RESPONSE VARIABLE IN Y1 10796C 10797 ICOLC=1 10798 IJ=MAXN*(ICOLR(ICOLC)-1)+I 10799 IF(ICOLR(ICOLC).LE.MAXCOL)Y1(J)=V(IJ) 10800 IF(ICOLR(ICOLC).EQ.MAXCP1)Y1(J)=PRED(I) 10801 IF(ICOLR(ICOLC).EQ.MAXCP2)Y1(J)=RES(I) 10802 IF(ICOLR(ICOLC).EQ.MAXCP3)Y1(J)=YPLOT(I) 10803 IF(ICOLR(ICOLC).EQ.MAXCP4)Y1(J)=XPLOT(I) 10804 IF(ICOLR(ICOLC).EQ.MAXCP5)Y1(J)=X2PLOT(I) 10805 IF(ICOLR(ICOLC).EQ.MAXCP6)Y1(J)=TAGPLO(I) 10806C 10807 IF(NREPL.GE.1)THEN 10808 DO920IR=1,MIN(NREPL,6) 10809 ICOLC=ICOLC+1 10810 ICOLT=ICOLR(ICOLC) 10811 IJ=MAXN*(ICOLT-1)+I 10812 IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ) 10813 IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I) 10814 IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I) 10815 IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I) 10816 IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I) 10817 IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I) 10818 IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I) 10819 920 CONTINUE 10820 ENDIF 10821C 10822 910 CONTINUE 10823 NLOCAL=J 10824C 10825C ***************************************************** 10826C ** STEP 9B-- ** 10827C ** CALL TOL TO PERFORM TOLERANCE LIMITS TEST. ** 10828C ***************************************************** 10829C 10830C 10831 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TOLI')THEN 10832 ISTEPN='9C' 10833 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10834 WRITE(ICOUT,999) 10835 CALL DPWRST('XXX','BUG ') 10836 WRITE(ICOUT,941) 10837 941 FORMAT('***** FROM THE MIDDLE OF DPTOLI--') 10838 CALL DPWRST('XXX','BUG ') 10839 WRITE(ICOUT,942)ICASAN,NUMVAR,NLOCAL,NREPL 10840 942 FORMAT('ICASAN,NUMVAR,NLOCAL,NREPL = ', 10841 1 A4,3I8) 10842 CALL DPWRST('XXX','BUG ') 10843 IF(NLOCAL.GE.1)THEN 10844 DO945I=1,NLOCAL 10845 WRITE(ICOUT,946)I,Y1(I),XDESGN(I,1),XDESGN(I,2) 10846 946 FORMAT('I,Y1(I),XDESGN(I,1),XDESGN(I,2) = ', 10847 1 I8,4F12.5) 10848 CALL DPWRST('XXX','BUG ') 10849 945 CONTINUE 10850 ENDIF 10851 ENDIF 10852C 10853C ***************************************************** 10854C ** STEP 9C-- ** 10855C ** FIND THE DISTINCT VALUES IN EACH OF THE ** 10856C ** REPLICATION VARIABLES. ** 10857C ***************************************************** 10858C 10859 CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3), 10860 1 XDESGN(1,4),XDESGN(1,5),XDESGN(1,6), 10861 1 NREPL,NLOCAL,MAXOBV, 10862 1 XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6, 10863 1 XTEMP1,XTEMP2, 10864 1 NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6, 10865 1 IBUGA3,ISUBRO,IERROR) 10866C 10867C ***************************************************** 10868C ** STEP 9D-- ** 10869C ** NOW LOOP THROUGH THE VARIOUS REPLICATIONS ** 10870C ***************************************************** 10871C 10872 NPLOTP=0 10873 NCURVE=0 10874 IADD=1 10875C 10876 IF(NREPL.EQ.1)THEN 10877 J=0 10878 DO1110ISET1=1,NUMSE1 10879 K=0 10880 PID(IADD+1)=XIDTEM(ISET1) 10881 DO1130I=1,NLOCAL 10882 IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN 10883 K=K+1 10884 TEMP1(K)=Y1(I) 10885 ENDIF 10886 1130 CONTINUE 10887 NTEMP=K 10888 NCURVE=NCURVE+1 10889 NPLOT1=NPLOTP 10890 IF(NTEMP.GT.0)THEN 10891 IF(ICASDI.EQ.'WEIB')THEN 10892 CALL TOLWEI(TEMP1,NTEMP, 10893 1 MINMAX,IWEIBC,XTEMP1,DTEMP1, 10894 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 10895 1 PID,IVARID,IVARI2,NREPL, 10896 1 ISUBRO,IBUGA3,IERROR) 10897 ELSEIF(ICASA2.EQ.'LOWE')THEN 10898 CALL TOL2(TEMP1,NTEMP,XMEAN,XSD,AN, 10899 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 10900 1 PID,IVARN1,IVARN2,NREPL, 10901 1 ISUBRO,IBUGA3,IERROR) 10902 ELSEIF(ICASA2.EQ.'UPPE')THEN 10903 CALL TOL2(TEMP1,NTEMP,XMEAN,XSD,AN, 10904 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 10905 1 PID,IVARN1,IVARN2,NREPL, 10906 1 ISUBRO,IBUGA3,IERROR) 10907 ELSE 10908 CALL TOL(TEMP1,NTEMP,XMEAN,XSD,AN, 10909 1 XTEMP1,XTEMP2,XTEMP3, 10910 1 ICASAN,ICAPSW,ICAPTY,IFORSW, 10911 1 PID,IVARN1,IVARN2,NREPL, 10912 1 ISUBRO,IBUGA3,IERROR) 10913 ENDIF 10914 ENDIF 10915 1110 CONTINUE 10916 ELSEIF(NREPL.EQ.2)THEN 10917 J=0 10918 NTOT=NUMSE1*NUMSE2 10919 DO1210ISET1=1,NUMSE1 10920 DO1220ISET2=1,NUMSE2 10921 K=0 10922 PID(1+IADD)=XIDTEM(ISET1) 10923 PID(2+IADD)=XIDTE2(ISET2) 10924 DO1290I=1,NLOCAL 10925 IF( 10926 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 10927 1 XIDTE2(ISET2).EQ.XDESGN(I,2) 10928 1 )THEN 10929 K=K+1 10930 TEMP1(K)=Y1(I) 10931 ENDIF 10932 1290 CONTINUE 10933 NTEMP=K 10934 NCURVE=NCURVE+1 10935 NPLOT1=NPLOTP 10936 IF(NTEMP.GT.0)THEN 10937 IF(ICASDI.EQ.'WEIB')THEN 10938 CALL TOLWEI(TEMP1,NTEMP, 10939 1 MINMAX,IWEIBC,XTEMP1,DTEMP1, 10940 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 10941 1 PID,IVARID,IVARI2,NREPL, 10942 1 ISUBRO,IBUGA3,IERROR) 10943 ELSEIF(ICASA2.EQ.'LOWE')THEN 10944 CALL TOL2(TEMP1,NTEMP,XMEAN,XSD,AN, 10945 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 10946 1 PID,IVARN1,IVARN2,NREPL, 10947 1 ISUBRO,IBUGA3,IERROR) 10948 ELSEIF(ICASA2.EQ.'UPPE')THEN 10949 CALL TOL2(TEMP1,NTEMP,XMEAN,XSD,AN, 10950 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 10951 1 PID,IVARN1,IVARN2,NREPL, 10952 1 ISUBRO,IBUGA3,IERROR) 10953 ELSE 10954 CALL TOL(TEMP1,NTEMP,XMEAN,XSD,AN, 10955 1 XTEMP1,XTEMP2,XTEMP3, 10956 1 ICASAN,ICAPSW,ICAPTY,IFORSW, 10957 1 PID,IVARN1,IVARN2,NREPL, 10958 1 ISUBRO,IBUGA3,IERROR) 10959 ENDIF 10960 ENDIF 10961 1220 CONTINUE 10962 1210 CONTINUE 10963 ELSEIF(NREPL.EQ.3)THEN 10964 J=0 10965 NTOT=NUMSE1*NUMSE2*NUMSE3 10966 DO1310ISET1=1,NUMSE1 10967 DO1320ISET2=1,NUMSE2 10968 DO1330ISET3=1,NUMSE3 10969 K=0 10970 PID(1+IADD)=XIDTEM(ISET1) 10971 PID(2+IADD)=XIDTE2(ISET2) 10972 PID(3+IADD)=XIDTE3(ISET3) 10973 DO1390I=1,NLOCAL 10974 IF( 10975 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 10976 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 10977 1 XIDTE3(ISET3).EQ.XDESGN(I,3) 10978 1 )THEN 10979 K=K+1 10980 TEMP1(K)=Y1(I) 10981 ENDIF 10982 1390 CONTINUE 10983 NTEMP=K 10984 NCURVE=NCURVE+1 10985 NPLOT1=NPLOTP 10986 IF(NTEMP.GT.0)THEN 10987 IF(ICASDI.EQ.'WEIB')THEN 10988 CALL TOLWEI(TEMP1,NTEMP, 10989 1 MINMAX,IWEIBC,XTEMP1,DTEMP1, 10990 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 10991 1 PID,IVARID,IVARI2,NREPL, 10992 1 ISUBRO,IBUGA3,IERROR) 10993 ELSEIF(ICASA2.EQ.'LOWE')THEN 10994 CALL TOL2(TEMP1,NTEMP,XMEAN,XSD,AN, 10995 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 10996 1 PID,IVARN1,IVARN2,NREPL, 10997 1 ISUBRO,IBUGA3,IERROR) 10998 ELSEIF(ICASA2.EQ.'UPPE')THEN 10999 CALL TOL2(TEMP1,NTEMP,XMEAN,XSD,AN, 11000 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 11001 1 PID,IVARN1,IVARN2,NREPL, 11002 1 ISUBRO,IBUGA3,IERROR) 11003 ELSE 11004 CALL TOL(TEMP1,NTEMP,XMEAN,XSD,AN, 11005 1 XTEMP1,XTEMP2,XTEMP3, 11006 1 ICASAN,ICAPSW,ICAPTY,IFORSW, 11007 1 PID,IVARN1,IVARN2,NREPL, 11008 1 ISUBRO,IBUGA3,IERROR) 11009 ENDIF 11010 ENDIF 11011 1330 CONTINUE 11012 1320 CONTINUE 11013 1310 CONTINUE 11014 ELSEIF(NREPL.EQ.4)THEN 11015 J=0 11016 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4 11017 DO1410ISET1=1,NUMSE1 11018 DO1420ISET2=1,NUMSE2 11019 DO1430ISET3=1,NUMSE3 11020 DO1440ISET4=1,NUMSE4 11021 K=0 11022 PID(1+IADD)=XIDTEM(ISET1) 11023 PID(2+IADD)=XIDTE2(ISET2) 11024 PID(3+IADD)=XIDTE3(ISET3) 11025 PID(4+IADD)=XIDTE4(ISET4) 11026 DO1490I=1,NLOCAL 11027 IF( 11028 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 11029 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 11030 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 11031 1 XIDTE4(ISET4).EQ.XDESGN(I,4) 11032 1 )THEN 11033 K=K+1 11034 TEMP1(K)=Y1(I) 11035 ENDIF 11036 1490 CONTINUE 11037 NTEMP=K 11038 NCURVE=NCURVE+1 11039 NPLOT1=NPLOTP 11040 IF(NTEMP.GT.0)THEN 11041 IF(ICASDI.EQ.'WEIB')THEN 11042 CALL TOLWEI(TEMP1,NTEMP, 11043 1 MINMAX,IWEIBC,XTEMP1,DTEMP1, 11044 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 11045 1 PID,IVARID,IVARI2,NREPL, 11046 1 ISUBRO,IBUGA3,IERROR) 11047 ELSEIF(ICASA2.EQ.'LOWE')THEN 11048 CALL TOL2(TEMP1,NTEMP,XMEAN,XSD,AN, 11049 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 11050 1 PID,IVARN1,IVARN2,NREPL, 11051 1 ISUBRO,IBUGA3,IERROR) 11052 ELSEIF(ICASA2.EQ.'UPPE')THEN 11053 CALL TOL2(TEMP1,NTEMP,XMEAN,XSD,AN, 11054 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 11055 1 PID,IVARN1,IVARN2,NREPL, 11056 1 ISUBRO,IBUGA3,IERROR) 11057 ELSE 11058 CALL TOL(TEMP1,NTEMP,XMEAN,XSD,AN, 11059 1 XTEMP1,XTEMP2,XTEMP3, 11060 1 ICASAN,ICAPSW,ICAPTY,IFORSW, 11061 1 PID,IVARN1,IVARN2,NREPL, 11062 1 ISUBRO,IBUGA3,IERROR) 11063 ENDIF 11064 ENDIF 11065 1440 CONTINUE 11066 1430 CONTINUE 11067 1420 CONTINUE 11068 1410 CONTINUE 11069 ELSEIF(NREPL.EQ.5)THEN 11070 J=0 11071 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5 11072 DO1510ISET1=1,NUMSE1 11073 DO1520ISET2=1,NUMSE2 11074 DO1530ISET3=1,NUMSE3 11075 DO1540ISET4=1,NUMSE4 11076 DO1550ISET5=1,NUMSE5 11077 K=0 11078 PID(1+IADD)=XIDTEM(ISET1) 11079 PID(2+IADD)=XIDTE2(ISET2) 11080 PID(3+IADD)=XIDTE3(ISET3) 11081 PID(4+IADD)=XIDTE4(ISET4) 11082 PID(5+IADD)=XIDTE5(ISET4) 11083 DO1590I=1,NLOCAL 11084 IF( 11085 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 11086 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 11087 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 11088 1 XIDTE4(ISET4).EQ.XDESGN(I,4) .AND. 11089 1 XIDTE5(ISET5).EQ.XDESGN(I,5) 11090 1 )THEN 11091 K=K+1 11092 TEMP1(K)=Y1(I) 11093 ENDIF 11094 1590 CONTINUE 11095 NTEMP=K 11096 NCURVE=NCURVE+1 11097 NPLOT1=NPLOTP 11098 IF(NTEMP.GT.0)THEN 11099 IF(ICASDI.EQ.'WEIB')THEN 11100 CALL TOLWEI(TEMP1,NTEMP, 11101 1 MINMAX,IWEIBC,XTEMP1,DTEMP1, 11102 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 11103 1 PID,IVARID,IVARI2,NREPL, 11104 1 ISUBRO,IBUGA3,IERROR) 11105 ELSEIF(ICASA2.EQ.'LOWE')THEN 11106 CALL TOL2(TEMP1,NTEMP,XMEAN,XSD,AN, 11107 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 11108 1 PID,IVARN1,IVARN2,NREPL, 11109 1 ISUBRO,IBUGA3,IERROR) 11110 ELSEIF(ICASA2.EQ.'UPPE')THEN 11111 CALL TOL2(TEMP1,NTEMP,XMEAN,XSD,AN, 11112 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 11113 1 PID,IVARN1,IVARN2,NREPL, 11114 1 ISUBRO,IBUGA3,IERROR) 11115 ELSE 11116 CALL TOL(TEMP1,NTEMP,XMEAN,XSD,AN, 11117 1 XTEMP1,XTEMP2,XTEMP3, 11118 1 ICASAN,ICAPSW,ICAPTY,IFORSW, 11119 1 PID,IVARN1,IVARN2,NREPL, 11120 1 ISUBRO,IBUGA3,IERROR) 11121 ENDIF 11122 ENDIF 11123 1550 CONTINUE 11124 1540 CONTINUE 11125 1530 CONTINUE 11126 1520 CONTINUE 11127 1510 CONTINUE 11128 ELSEIF(NREPL.EQ.6)THEN 11129 J=0 11130 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6 11131 DO1610ISET1=1,NUMSE1 11132 DO1620ISET2=1,NUMSE2 11133 DO1630ISET3=1,NUMSE3 11134 DO1640ISET4=1,NUMSE4 11135 DO1650ISET5=1,NUMSE5 11136 DO1660ISET6=1,NUMSE6 11137 K=0 11138 PID(1+IADD)=XIDTEM(ISET1) 11139 PID(2+IADD)=XIDTE2(ISET2) 11140 PID(3+IADD)=XIDTE3(ISET3) 11141 PID(4+IADD)=XIDTE4(ISET4) 11142 PID(5+IADD)=XIDTE5(ISET4) 11143 PID(6+IADD)=XIDTE6(ISET4) 11144 DO1690I=1,NLOCAL 11145 IF( 11146 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 11147 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 11148 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 11149 1 XIDTE4(ISET4).EQ.XDESGN(I,4) .AND. 11150 1 XIDTE5(ISET5).EQ.XDESGN(I,5) .AND. 11151 1 XIDTE6(ISET6).EQ.XDESGN(I,6) 11152 1 )THEN 11153 K=K+1 11154 TEMP1(K)=Y1(I) 11155 ENDIF 11156 1690 CONTINUE 11157 NTEMP=K 11158 NCURVE=NCURVE+1 11159 NPLOT1=NPLOTP 11160 IF(NTEMP.GT.0)THEN 11161 IF(ICASDI.EQ.'WEIB')THEN 11162 CALL TOLWEI(TEMP1,NTEMP, 11163 1 MINMAX,IWEIBC,XTEMP1,DTEMP1, 11164 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 11165 1 PID,IVARID,IVARI2,NREPL, 11166 1 ISUBRO,IBUGA3,IERROR) 11167 ELSEIF(ICASA2.EQ.'LOWE')THEN 11168 CALL TOL2(TEMP1,NTEMP,XMEAN,XSD,AN, 11169 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 11170 1 PID,IVARN1,IVARN2,NREPL, 11171 1 ISUBRO,IBUGA3,IERROR) 11172 ELSEIF(ICASA2.EQ.'UPPE')THEN 11173 CALL TOL2(TEMP1,NTEMP,XMEAN,XSD,AN, 11174 1 ICASA2,ICAPSW,ICAPTY,IFORSW, 11175 1 PID,IVARN1,IVARN2,NREPL, 11176 1 ISUBRO,IBUGA3,IERROR) 11177 ELSE 11178 CALL TOL(TEMP1,NTEMP,XMEAN,XSD,AN, 11179 1 XTEMP1,XTEMP2,XTEMP3, 11180 1 ICASAN,ICAPSW,ICAPTY,IFORSW, 11181 1 PID,IVARN1,IVARN2,NREPL, 11182 1 ISUBRO,IBUGA3,IERROR) 11183 ENDIF 11184 ENDIF 11185 1660 CONTINUE 11186 1650 CONTINUE 11187 1640 CONTINUE 11188 1630 CONTINUE 11189 1620 CONTINUE 11190 1610 CONTINUE 11191 ENDIF 11192C 11193 ENDIF 11194C 11195C ***************** 11196C ** STEP 90-- ** 11197C ** EXIT ** 11198C ***************** 11199C 11200 9000 CONTINUE 11201C 11202 IF(IERROR.EQ.'YES')THEN 11203 IF(IWIDTH.GE.1)THEN 11204 WRITE(ICOUT,9001)(IANS(I),I=1,MIN(100,IWIDTH)) 11205 9001 FORMAT(100A1) 11206 CALL DPWRST('XXX','BUG ') 11207 ENDIF 11208 ENDIF 11209C 11210 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TOLI')THEN 11211 WRITE(ICOUT,999) 11212 CALL DPWRST('XXX','BUG ') 11213 WRITE(ICOUT,9011) 11214 9011 FORMAT('***** AT THE END OF DPTOLI--') 11215 CALL DPWRST('XXX','BUG ') 11216 WRITE(ICOUT,9012)IFOUND,IERROR,ICASAN 11217 9012 FORMAT('IFOUND,IERROR,ICASAN = ',2(A4,2X),A4) 11218 CALL DPWRST('XXX','BUG ') 11219 ENDIF 11220C 11221 RETURN 11222 END 11223 SUBROUTINE DPTOL3(X,N,XMEAN,XSD,AN,ANU, 11224 1 ICASAN,ALPHA,GAMMA,ITOLGC,ITOLM2, 11225 1 AK,ALOWLM,AUPPLM, 11226 1 ISUBRO,IBUGA3,IERROR) 11227C 11228C PURPOSE--THIS SUBROUTINE COMPUTES NORMAL ONE-SIDED AND 11229C TWO-SIDED NORMAL TOLERANCE LOWER AND UPPER LIMITS 11230C AND K-FACTORS. THIS IS FOR USE BY THE "STATISTICS" 11231C COMMAND. 11232C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 11233C (UNSORTED OR SORTED) OBSERVATIONS. 11234C N = THE INTEGER NUMBER OF OBSERVATIONS 11235C IN THE VECTOR X. 11236C OTHER DATAPAC SUBROUTINES NEEDED--CHSPPF, NORPPF, NCTPPF. 11237C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. 11238C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 11239C LANGUAGE--ANSI FORTRAN. 11240C REFERENCES--GARDINER AND HULL, TECHNOMETRICS, 1966, PAGES 115-122 11241C --WILKS, ANNALS OF MATHEMATICAL STATISTICS, 1941, PAGE 92 11242C --MOOD AND GRABLE, PAGES 416-417 11243C --HOWE (1969), "TWO-SIDED TOLERANCE LIMITS FOR NORMAL 11244C POPULATIONS - SOME IMPROVEMENTS", JOURNAL OF THE 11245C AMERICAN STATISTICAL ASSOCIATION, VOL. 64, PP. 11246C 610-620. 11247C --GUENTHER (1977), "SAMPLING INSPECTION IN STATISTICAL 11248C QUALITY CONTROL", GRIFFIN'S STATISTICAL MONOGRAPHS, 11249C NUMBER 37, LONDON. 11250C --MARY NATRELLA (1963), "EXPERIMENTAL STATISTICS, NBS 11251C HANDBOOK 91", US DEPARTMENT OF COMMERCE. 11252C WRITTEN BY--ALAN HECKERT 11253C STATISTICAL ENGINEERING LABORATORY 11254C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11255C GAITHERSBURG, MD 20899-8980 11256C PHONE--301-975-2899 11257C ORIGINAL VERSION--MARCH 2011. 11258C UPDATED --MAY 2018. OPTION FOR NU (DEGREES OF 11259C FREEDOM INDEPENDENT OF 11260C CURRENT SAMPLE) 11261C UPDATED --MAY 2018. FOR 2-SIDED CASE, ADJUST FORMULA 11262C SO THAT COVERAGE FACTORS < 0.5 11263C WILL BE COMPUTED CORRECTLY. 11264C UPDATED --MAY 2018. OPTIONALLY COMPUTE GUENTHER 11265C CORRECTION TO HOWE FORMULA 11266C FOR TWO-SIDED CASE 11267C 11268C--------------------------------------------------------------------- 11269C 11270 DIMENSION X(*) 11271C 11272 CHARACTER*4 ICASAN 11273 CHARACTER*4 ITOLGC 11274 CHARACTER*4 ITOLM2 11275 CHARACTER*4 ISUBRO 11276 CHARACTER*4 IBUGA3 11277 CHARACTER*4 IERROR 11278C 11279 DOUBLE PRECISION DTEMP 11280 DOUBLE PRECISION DTEMP2 11281 DOUBLE PRECISION DA 11282 DOUBLE PRECISION DB 11283 DOUBLE PRECISION DTERM1 11284C 11285 CHARACTER*4 IWRITE 11286 CHARACTER*4 ISUBN1 11287 CHARACTER*4 ISUBN2 11288 CHARACTER*4 ISTEPN 11289C 11290C-----COMMON---------------------------------------------------------- 11291C 11292 INCLUDE 'DPCOP2.INC' 11293C 11294C-----START POINT----------------------------------------------------- 11295C 11296C 11297 ISUBN1='TOL3' 11298 ISUBN2=' ' 11299 IWRITE='OFF' 11300 IERROR='NO' 11301C 11302 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TOL3')THEN 11303 WRITE(ICOUT,999) 11304 999 FORMAT(1X) 11305 CALL DPWRST('XXX','WRIT') 11306 WRITE(ICOUT,51) 11307 51 FORMAT('**** AT THE BEGINNING OF DPTOL3--') 11308 CALL DPWRST('XXX','WRIT') 11309 WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASAN,N,ALPHA,GAMMA 11310 52 FORMAT('IBUGA3,ISUBRO,ICASAN,N,ALPHA,GAMMA = ', 11311 1 3(A4,2X),I8,2G15.7) 11312 CALL DPWRST('XXX','WRIT') 11313 WRITE(ICOUT,53)XMEAN,XSD,ITOLGC,ITOLM2 11314 53 FORMAT('XMEAN,XSD,ITOLGC,ITOLM2 = ',2G15.7,2(2X,A4)) 11315 CALL DPWRST('XXX','WRIT') 11316 IF(XMEAN.EQ.CPUMIN)THEN 11317 DO56I=1,N 11318 WRITE(ICOUT,57)I,X(I) 11319 57 FORMAT('I,X(I) = ',I8,G15.7) 11320 CALL DPWRST('XXX','WRIT') 11321 56 CONTINUE 11322 ENDIF 11323 ENDIF 11324C 11325C ******************************************** 11326C ** STEP 11-- ** 11327C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 11328C ******************************************** 11329C 11330 ISTEPN='11' 11331 IF(IBUGA3.EQ.'ON'.AND.ISUBRO.EQ.'TOL3') 11332 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 11333C 11334 IF(XMEAN.EQ.CPUMIN .AND. N.LT.2)THEN 11335 WRITE(ICOUT,999) 11336 CALL DPWRST('XXX','WRIT') 11337 WRITE(ICOUT,101) 11338 101 FORMAT('***** ERROR: TOLERANCE LIMITS--') 11339 CALL DPWRST('XXX','WRIT') 11340 WRITE(ICOUT,102) 11341 102 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.', 11342 1 ' SUCH WAS NOT THE CASE HERE.') 11343 CALL DPWRST('XXX','WRIT') 11344 WRITE(ICOUT,103)N 11345 103 FORMAT(' SAMPLE SIZE = ',I8) 11346 CALL DPWRST('XXX','WRIT') 11347 IERROR='YES' 11348 GOTO9000 11349 ENDIF 11350C 11351 IF(XMEAN.EQ.CPUMIN)THEN 11352 HOLD=X(1) 11353 DO135I=2,N 11354 IF(X(I).NE.HOLD)GOTO139 11355 135 CONTINUE 11356 WRITE(ICOUT,999) 11357 CALL DPWRST('XXX','WRIT') 11358 WRITE(ICOUT,101) 11359 CALL DPWRST('XXX','WRIT') 11360 WRITE(ICOUT,131)HOLD 11361 131 FORMAT(' THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7) 11362 CALL DPWRST('XXX','WRIT') 11363 GOTO9000 11364 139 CONTINUE 11365 ENDIF 11366C 11367C ******************************************** 11368C ** STEP 21-- ** 11369C ** CARRY OUT CALCULATIONS FOR TOLERANCE ** 11370C ** LIMITS. ** 11371C ******************************************** 11372C 11373 ISTEPN='21' 11374 IF(IBUGA3.EQ.'ON'.AND.ISUBRO.EQ.'TOL3') 11375 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 11376C 11377C COMPUTE MEAN AND STANDARD DEVIATION 11378C 11379 ALOWLM=CPUMIN 11380 AUPPLM=CPUMIN 11381 AK=CPUMIN 11382 AN=REAL(N) 11383 IF(XMEAN.EQ.CPUMIN)THEN 11384 CALL MEAN(X,N,IWRITE,XMEAN,IBUGA3,IERROR) 11385 CALL SD(X,N,IWRITE,XSD,IBUGA3,IERROR) 11386 ELSE 11387 N=INT(AN+0.1) 11388 ENDIF 11389C 11390C NOTE: ALPHA IS THE CONFIDENCE AND GAMMA IS THE COVERAGE 11391C 11392 IF(ALPHA.GE.1.0 .AND. ALPHA.LT.100.0)THEN 11393 ALPHA=ALPHA/100. 11394 ENDIF 11395 IF(ALPHA.GT.0.0 .AND. ALPHA.LT.1.0)THEN 11396 IF(ALPHA.LT.0.5)ALPHA=1.0 - ALPHA 11397 ELSE 11398 ALPHA=0.95 11399 ENDIF 11400C 11401 IF(GAMMA.GE.1.0 .AND. GAMMA.LT.100.0)THEN 11402 GAMMA=GAMMA/100. 11403 ENDIF 11404 IF(GAMMA.GT.0.0 .AND. GAMMA.LT.1.0)THEN 11405 IF(GAMMA.LT.0.5)GAMMA=1.0 - GAMMA 11406 ELSE 11407 GAMMA=0.95 11408 ENDIF 11409C 11410C COMPUTE THE NORMAL TWO-SIDED TOLERANCE LIMITS USING HOWE'S METHOD, 11411C OPTIONALLY APPLY GUENTHER'S CORRECTION 11412C 11413 AN=REAL(N) 11414 IF(ICASAN(1:1).EQ.'2')THEN 11415 IF(ANU.GT.0.0)THEN 11416 NU=INT(ANU+0.5) 11417 ELSE 11418 NU=N-1 11419 ENDIF 11420 IF(NU.LT.1)NU=1 11421 AN=REAL(N) 11422 ANU=REAL(NU) 11423 TERM2=ANU*(1.0 + (1.0/AN)) 11424 PCOV=GAMMA 11425 PCONF=ALPHA 11426 TERM1=(1.0 + PCOV)/2.0 11427 CALL NORPPF(TERM1,Z) 11428 AVAL=1.0 - PCONF 11429 CALL CHSPPF(AVAL,NU,TERM3) 11430 AK=Z*SQRT(TERM2/TERM3) 11431C 11432C APPLY GUENTHER CORRECTION IF REQUESTED 11433C 11434 IF(ITOLGC.EQ.'ON')THEN 11435 ANUM=AN - 3.0 - TERM3 11436 DENOM=2.0*(AN+1)**2 11437 TERM4=SQRT(1.0 + (ANUM/DENOM)) 11438 AK=TERM4*AK 11439 ENDIF 11440C 11441 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TOL3')THEN 11442 WRITE(ICOUT,201)AN,ANU,TERM2,TERM1,Z,AVAL,TERM3 11443 201 FORMAT('AN,ANU,TERM2,TERM1,Z,AVAL,TERM3 = ',7G15.7) 11444 CALL DPWRST('XXX','WRIT') 11445 IF(ITOLGC.EQ.'ON')THEN 11446 WRITE(ICOUT,203)ANUM,DENOM,TERM4 11447 203 FORMAT('ANUM,DENOM,TERM4 = ',3G15.7) 11448 CALL DPWRST('XXX','WRIT') 11449 ENDIF 11450 ENDIF 11451C 11452 ELSEIF(ICASAN(1:1).EQ.'1')THEN 11453C 11454C FOR ONE-SIDED INTERVAL, USE EITHER APPROXIMATION BASED ON 11455C NON-CENTRAL T OR APPROXIMATION BASED ON NORMAL. THE 11456C NON-CENTRAL T IS CONSIDERED MORE ACCURATE, BUT NON-CENTRAL T 11457C MAY LOSE ACCURACY AS N BECOMES LARGE. 11458C 11459 IF(ITOLM2.EQ.'NONC')THEN 11460 IF(ANU.GT.0.0)THEN 11461 NU=INT(ANU+0.5) 11462 IF(NU.LT.2)NU=2 11463 AF=REAL(NU-1) 11464 ELSE 11465 AF=AN - 1.0 11466 ENDIF 11467 CALL NODPPF(DBLE(GAMMA),DTEMP) 11468 DELTA=REAL(DTEMP*DSQRT(DBLE(N))) 11469 CALL NCTPPF(ALPHA,AF,DELTA,PPF) 11470 AK=PPF/SQRT(AN) 11471 ELSE 11472 CALL NODPPF(DBLE(ALPHA),DTEMP) 11473 DA=1.0D0 - DTEMP**2/(2.0*(DBLE(N) - 1.0D0)) 11474 CALL NODPPF(DBLE(GAMMA),DTEMP2) 11475 DB=DTEMP2**2 - DTEMP**2/DBLE(N) 11476 DTERM1=(DTEMP2 + DSQRT(DTEMP2**2 - DA*DB))/DA 11477 AK=REAL(DTERM1) 11478 ENDIF 11479 ELSE 11480 IERROR='YES' 11481 GOTO9000 11482 ENDIF 11483 ALOWLM=XMEAN - AK*XSD 11484 AUPPLM=XMEAN + AK*XSD 11485C 11486 9000 CONTINUE 11487 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TOL3')THEN 11488 WRITE(ICOUT,999) 11489 CALL DPWRST('XXX','WRIT') 11490 WRITE(ICOUT,9051) 11491 9051 FORMAT('**** AT THE END OF DPTOL3--') 11492 CALL DPWRST('XXX','WRIT') 11493 WRITE(ICOUT,9052)XBAR,XSD,AK,ALOWLM,AUPPLM 11494 9052 FORMAT('XBAR,XSD,AK,ALOWLM,AUPPLM = ',5G15.7) 11495 CALL DPWRST('XXX','WRIT') 11496 WRITE(ICOUT,9054)ALPHA,GAMMA,AN 11497 9054 FORMAT('ALPHA,GAMMA,N = ',2G15.7,I8) 11498 CALL DPWRST('XXX','WRIT') 11499 IF(ICASAN(1:1).EQ.'2')THEN 11500 WRITE(ICOUT,9056)NU,DTEMP,ANP,AK 11501 9056 FORMAT('NU,DTEMP,ANP,AK = ',4G15.7) 11502 CALL DPWRST('XXX','WRIT') 11503 ELSE 11504 WRITE(ICOUT,9058)AF,DTEMP,DELTA,PPF 11505 9058 FORMAT('AF,DTEMP,DELTA,PPF = ',4G15.7) 11506 CALL DPWRST('XXX','WRIT') 11507 ENDIF 11508 ENDIF 11509C 11510 RETURN 11511 END 11512 SUBROUTINE DPTPCO(IHARG,NUMARG,IDETPC,MAXTEX,ITEPCO, 11513 1IBUGP2,IFOUND,IERROR) 11514C 11515C PURPOSE--DEFINE THE TEXT PATTERN COLORS = THE COLORS 11516C OF THE LINES MAKING UP A PATTERN WITHIN A TEXT. 11517C THESE ARE LOCATED IN THE VECTOR ITEPCO(.). 11518C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 11519C --NUMARG 11520C --IDETPC 11521C --MAXTEX 11522C --IBUGP2 ('ON' OR 'OFF' ) 11523C OUTPUT ARGUMENTS--ITEPCO (A CHARACTER VECTOR) 11524C --IFOUND ('YES' OR 'NO' ) 11525C --IERROR ('YES' OR 'NO' ) 11526C WRITTEN BY--JAMES J. FILLIBEN 11527C STATISTICAL ENGINEERING DIVISION 11528C INFORMATION TECHNOLOGY LABORATORY 11529C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11530C GAITHERSBURG, MD 20899-8980 11531C PHONE--301-975-2855 11532C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11533C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11534C LANGUAGE--ANSI FORTRAN (1977) 11535C VERSION NUMBER--82/7 11536C ORIGINAL VERSION--DECEMBER 1983. 11537C 11538C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11539C 11540 CHARACTER*4 IHARG 11541 CHARACTER*4 IDETPC 11542 CHARACTER*4 ITEPCO 11543C 11544 CHARACTER*4 IBUGP2 11545 CHARACTER*4 IFOUND 11546 CHARACTER*4 IERROR 11547C 11548 CHARACTER*4 IHOLD1 11549 CHARACTER*4 IHOLD2 11550C 11551 CHARACTER*4 ISUBN1 11552 CHARACTER*4 ISUBN2 11553 CHARACTER*4 ISTEPN 11554C 11555 DIMENSION IHARG(*) 11556 DIMENSION ITEPCO(*) 11557C 11558C-----COMMON---------------------------------------------------------- 11559C 11560 INCLUDE 'DPCOP2.INC' 11561C 11562C-----START POINT----------------------------------------------------- 11563C 11564 IFOUND='NO' 11565 IERROR='NO' 11566 ISUBN1='DPTP' 11567 ISUBN2='CO ' 11568C 11569 NUMTEX=0 11570 IHOLD1='-999' 11571 IHOLD2='-999' 11572C 11573 IF(IBUGP2.EQ.'OFF')GOTO90 11574 WRITE(ICOUT,999) 11575 999 FORMAT(1X) 11576 CALL DPWRST('XXX','BUG ') 11577 WRITE(ICOUT,51) 11578 51 FORMAT('***** AT THE BEGINNING OF DPTPCO--') 11579 CALL DPWRST('XXX','BUG ') 11580 WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 11581 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11582 CALL DPWRST('XXX','BUG ') 11583 WRITE(ICOUT,53)MAXTEX,NUMTEX 11584 53 FORMAT('MAXTEX,NUMTEX = ',I8,I8) 11585 CALL DPWRST('XXX','BUG ') 11586 WRITE(ICOUT,54)IHOLD1,IHOLD2 11587 54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 11588 CALL DPWRST('XXX','BUG ') 11589 WRITE(ICOUT,55)IDETPC 11590 55 FORMAT('IDETPC = ',A4) 11591 CALL DPWRST('XXX','BUG ') 11592 WRITE(ICOUT,60)NUMARG 11593 60 FORMAT('NUMARG = ',I8) 11594 CALL DPWRST('XXX','BUG ') 11595 DO65I=1,NUMARG 11596 WRITE(ICOUT,66)IHARG(I) 11597 66 FORMAT('IHARG(I) = ',A4) 11598 CALL DPWRST('XXX','BUG ') 11599 65 CONTINUE 11600 WRITE(ICOUT,70)ITEPCO(1) 11601 70 FORMAT('ITEPCO(1) = ',A4) 11602 CALL DPWRST('XXX','BUG ') 11603 DO75I=1,10 11604 WRITE(ICOUT,76)I,ITEPCO(I) 11605 76 FORMAT('I,ITEPCO(I) = ',I8,2X,A4) 11606 CALL DPWRST('XXX','BUG ') 11607 75 CONTINUE 11608 90 CONTINUE 11609C 11610C ************************************** 11611C ** STEP 1-- ** 11612C ** BRANCH TO THE APPROPRIATE CASE ** 11613C ************************************** 11614C 11615 ISTEPN='1' 11616 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 11617C 11618 IF(NUMARG.LE.1)GOTO9000 11619 IF(NUMARG.EQ.2)GOTO1120 11620 IF(NUMARG.EQ.3)GOTO1130 11621 IF(NUMARG.EQ.4)GOTO1140 11622 GOTO1150 11623C 11624 1120 CONTINUE 11625 GOTO1200 11626C 11627 1130 CONTINUE 11628 IF(IHARG(3).EQ.'ALL')IHOLD1=' ' 11629 IF(IHARG(3).EQ.'ALL')GOTO1300 11630 GOTO1200 11631C 11632 1140 CONTINUE 11633 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) 11634 IF(IHARG(3).EQ.'ALL')GOTO1300 11635 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) 11636 IF(IHARG(4).EQ.'ALL')GOTO1300 11637 GOTO1200 11638C 11639 1150 CONTINUE 11640 GOTO1200 11641C 11642C ************************************************* 11643C ** STEP 2-- ** 11644C ** TREAT THE SINGLE SPECIFICATION CASE ** 11645C ************************************************* 11646C 11647 1200 CONTINUE 11648 ISTEPN='2' 11649 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 11650C 11651 IF(NUMARG.LE.2)GOTO1210 11652 GOTO1220 11653C 11654 1210 CONTINUE 11655 NUMTEX=1 11656 ITEPCO(1)=IDETPC 11657 GOTO1270 11658C 11659 1220 CONTINUE 11660 NUMTEX=NUMARG-2 11661 IF(NUMTEX.GT.MAXTEX)NUMTEX=MAXTEX 11662 DO1225I=1,NUMTEX 11663 J=I+2 11664 IHOLD1=IHARG(J) 11665 IHOLD2=IHOLD1 11666 IF(IHOLD1.EQ.'ON')IHOLD2=IDETPC 11667 IF(IHOLD1.EQ.'OFF')IHOLD2=IDETPC 11668 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDETPC 11669 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDETPC 11670 ITEPCO(I)=IHOLD2 11671 1225 CONTINUE 11672 GOTO1270 11673C 11674 1270 CONTINUE 11675 IF(IFEEDB.EQ.'OFF')GOTO1279 11676 WRITE(ICOUT,999) 11677 CALL DPWRST('XXX','BUG ') 11678 DO1278I=1,NUMTEX 11679 WRITE(ICOUT,1276)I,ITEPCO(I) 11680 1276 FORMAT('THE COLOR OF TEXT PATTERN ',I6, 11681 1' HAS JUST BEEN SET TO ',A4) 11682 CALL DPWRST('XXX','BUG ') 11683 1278 CONTINUE 11684 1279 CONTINUE 11685 IFOUND='YES' 11686 GOTO9000 11687C 11688C ************************** 11689C ** STEP 3-- ** 11690C ** TREAT THE ALL CASE ** 11691C ************************** 11692C 11693 1300 CONTINUE 11694 ISTEPN='3' 11695 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 11696C 11697 NUMTEX=MAXTEX 11698 IHOLD2=IHOLD1 11699 IF(IHOLD1.EQ.'ON')IHOLD2=IDETPC 11700 IF(IHOLD1.EQ.'OFF')IHOLD2=IDETPC 11701 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDETPC 11702 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDETPC 11703 DO1315I=1,NUMTEX 11704 ITEPCO(I)=IHOLD2 11705 1315 CONTINUE 11706 GOTO1370 11707C 11708 1370 CONTINUE 11709 IF(IFEEDB.EQ.'OFF')GOTO1319 11710 WRITE(ICOUT,999) 11711 CALL DPWRST('XXX','BUG ') 11712 I=1 11713 WRITE(ICOUT,1316)ITEPCO(I) 11714 1316 FORMAT('THE COLOR OF ALL TEXT PATTERNS', 11715 1' HAS JUST BEEN SET TO ',A4) 11716 CALL DPWRST('XXX','BUG ') 11717 1319 CONTINUE 11718 IFOUND='YES' 11719 GOTO9000 11720C 11721C ***************** 11722C ** STEP 90-- ** 11723C ** EXIT ** 11724C ***************** 11725C 11726 9000 CONTINUE 11727 IF(IBUGP2.EQ.'OFF')GOTO9090 11728 WRITE(ICOUT,9011) 11729 9011 FORMAT('***** AT THE END OF DPTPCO--') 11730 CALL DPWRST('XXX','BUG ') 11731 WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 11732 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11733 CALL DPWRST('XXX','BUG ') 11734 WRITE(ICOUT,9013)MAXTEX,NUMTEX 11735 9013 FORMAT('MAXTEX,NUMTEX = ',I8,I8) 11736 CALL DPWRST('XXX','BUG ') 11737 WRITE(ICOUT,9014)IHOLD1,IHOLD2 11738 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 11739 CALL DPWRST('XXX','BUG ') 11740 WRITE(ICOUT,9015)IDETPC 11741 9015 FORMAT('IDETPC = ',A4) 11742 CALL DPWRST('XXX','BUG ') 11743 WRITE(ICOUT,9020)NUMARG 11744 9020 FORMAT('NUMARG = ',I8) 11745 CALL DPWRST('XXX','BUG ') 11746 DO9025I=1,NUMARG 11747 WRITE(ICOUT,9026)IHARG(I) 11748 9026 FORMAT('IHARG(I) = ',A4) 11749 CALL DPWRST('XXX','BUG ') 11750 9025 CONTINUE 11751 WRITE(ICOUT,9030)ITEPCO(1) 11752 9030 FORMAT('ITEPCO(1) = ',A4) 11753 CALL DPWRST('XXX','BUG ') 11754 DO9035I=1,10 11755 WRITE(ICOUT,9036)I,ITEPCO(I) 11756 9036 FORMAT('I,ITEPCO(I) = ',I8,2X,A4) 11757 CALL DPWRST('XXX','BUG ') 11758 9035 CONTINUE 11759 9090 CONTINUE 11760C 11761 RETURN 11762 END 11763 SUBROUTINE DPTPLI(IHARG,IHARG2,NUMARG,IDETPL,MAXTEX,ITEPLI, 11764CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC 11765CCCC SUBROUTINE DPTPLI(IHARG,NUMARG,IDETPL,MAXTEX,ITEPLI, 11766 1IBUGP2,IFOUND,IERROR) 11767C 11768C PURPOSE--DEFINE THE PATTERN LINES = THE LINES TYPES 11769C OF THE PATTERN WITHIN THE TEXTS. 11770C THESE ARE LOCATED IN THE VECTOR ITEPLI(.). 11771C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 11772C --NUMARG 11773C --IDETPL 11774C --MAXTEX 11775C --IBUGP2 ('ON' OR 'OFF' ) 11776C OUTPUT ARGUMENTS--ITEPLI (A CHARACTER VECTOR) 11777C --IFOUND ('YES' OR 'NO' ) 11778C --IERROR ('YES' OR 'NO' ) 11779C WRITTEN BY--JAMES J. FILLIBEN 11780C STATISTICAL ENGINEERING DIVISION 11781C INFORMATION TECHNOLOGY LABORATORY 11782C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11783C GAITHERSBURG, MD 20899-8980 11784C PHONE--301-975-2855 11785C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11786C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11787C LANGUAGE--ANSI FORTRAN (1977) 11788C VERSION NUMBER--82/7 11789C ORIGINAL VERSION--DECEMBER 1983. 11790C UPDATED --AUGUST 1995. DASH2 BUG 11791C 11792C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11793C 11794 CHARACTER*4 IHARG 11795CCCCC AUGUST 1995. ADD FOLLOWING LINE 11796 CHARACTER*4 IHARG2 11797 CHARACTER*4 IDETPL 11798 CHARACTER*4 ITEPLI 11799C 11800 CHARACTER*4 IBUGP2 11801 CHARACTER*4 IFOUND 11802 CHARACTER*4 IERROR 11803C 11804 CHARACTER*4 IHOLD1 11805 CHARACTER*4 IHOLD2 11806C 11807 CHARACTER*4 ISUBN1 11808 CHARACTER*4 ISUBN2 11809 CHARACTER*4 ISTEPN 11810C 11811 DIMENSION IHARG(*) 11812CCCCC AUGUST 1995. ADD FOLLOWING LINE 11813 DIMENSION IHARG2(*) 11814 DIMENSION ITEPLI(*) 11815C 11816C-----COMMON---------------------------------------------------------- 11817C 11818 INCLUDE 'DPCOP2.INC' 11819C 11820C-----START POINT----------------------------------------------------- 11821C 11822 IFOUND='NO' 11823 IERROR='NO' 11824 ISUBN1='DPTP' 11825 ISUBN2='LI ' 11826C 11827 NUMTEX=0 11828 IHOLD1='-999' 11829 IHOLD2='-999' 11830C 11831 IF(IBUGP2.EQ.'OFF')GOTO90 11832 WRITE(ICOUT,999) 11833 999 FORMAT(1X) 11834 CALL DPWRST('XXX','BUG ') 11835 WRITE(ICOUT,51) 11836 51 FORMAT('***** AT THE BEGINNING OF DPTPLI--') 11837 CALL DPWRST('XXX','BUG ') 11838 WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 11839 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11840 CALL DPWRST('XXX','BUG ') 11841 WRITE(ICOUT,53)MAXTEX,NUMTEX 11842 53 FORMAT('MAXTEX,NUMTEX = ',I8,I8) 11843 CALL DPWRST('XXX','BUG ') 11844 WRITE(ICOUT,54)IHOLD1,IHOLD2 11845 54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 11846 CALL DPWRST('XXX','BUG ') 11847 WRITE(ICOUT,55)IDETPL 11848 55 FORMAT('IDETPL = ',A4) 11849 CALL DPWRST('XXX','BUG ') 11850 WRITE(ICOUT,60)NUMARG 11851 60 FORMAT('NUMARG = ',I8) 11852 CALL DPWRST('XXX','BUG ') 11853 DO65I=1,NUMARG 11854 WRITE(ICOUT,66)IHARG(I) 11855 66 FORMAT('IHARG(I) = ',A4) 11856 CALL DPWRST('XXX','BUG ') 11857 65 CONTINUE 11858 WRITE(ICOUT,70)ITEPLI(1) 11859 70 FORMAT('ITEPLI(1) = ',A4) 11860 CALL DPWRST('XXX','BUG ') 11861 DO75I=1,10 11862 WRITE(ICOUT,76)I,ITEPLI(I) 11863 76 FORMAT('I,ITEPLI(I) = ',I8,2X,A4) 11864 CALL DPWRST('XXX','BUG ') 11865 75 CONTINUE 11866 90 CONTINUE 11867C 11868C ************************************** 11869C ** STEP 1-- ** 11870C ** BRANCH TO THE APPROPRIATE CASE ** 11871C ************************************** 11872C 11873 ISTEPN='1' 11874 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 11875C 11876 IF(NUMARG.LE.2)GOTO9000 11877 IF(NUMARG.EQ.3)GOTO1130 11878 IF(NUMARG.EQ.4)GOTO1140 11879 IF(NUMARG.EQ.5)GOTO1150 11880 GOTO1160 11881C 11882 1130 CONTINUE 11883 GOTO1200 11884C 11885 1140 CONTINUE 11886 IF(IHARG(5).EQ.'ALL')IHOLD1=' ' 11887 IF(IHARG(5).EQ.'ALL')GOTO1300 11888 GOTO1200 11889C 11890 1150 CONTINUE 11891CCCCC APRIL 1996. CHANGE IHOLD TO IHOLD1 BELOW 11892 IF(IHARG(5).EQ.'ALL')THEN 11893 IHOLD1=IHARG(6) 11894 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'2')IHOLD1='DA2' 11895 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'3')IHOLD1='DA3' 11896 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'4')IHOLD1='DA4' 11897 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'5')IHOLD1='DA5' 11898 GOTO1300 11899 ENDIF 11900 IF(IHARG(6).EQ.'ALL')THEN 11901 IHOLD1=IHARG(5) 11902 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'2')IHOLD1='DA2' 11903 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'3')IHOLD1='DA3' 11904 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'4')IHOLD1='DA4' 11905 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'5')IHOLD1='DA5' 11906 GOTO1300 11907 ENDIF 11908 GOTO1200 11909C 11910 1160 CONTINUE 11911 GOTO1200 11912C 11913C ************************************************* 11914C ** STEP 2-- ** 11915C ** TREAT THE SINGLE SPECIFICATION CASE ** 11916C ************************************************* 11917C 11918 1200 CONTINUE 11919 ISTEPN='2' 11920 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 11921C 11922 IF(NUMARG.LE.3)GOTO1210 11923 GOTO1220 11924C 11925 1210 CONTINUE 11926 NUMTEX=1 11927 ITEPLI(1)=' ' 11928 GOTO1270 11929C 11930 1220 CONTINUE 11931 NUMTEX=NUMARG-3 11932 IF(NUMTEX.GT.MAXTEX)NUMTEX=MAXTEX 11933 DO1225I=1,NUMTEX 11934 J=I+3 11935 IHOLD1=IHARG(J) 11936 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'2')IHOLD1='DA2' 11937 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'3')IHOLD1='DA3' 11938 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'4')IHOLD1='DA4' 11939 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'5')IHOLD1='DA5' 11940 IHOLD2=IHOLD1 11941 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' 11942 IF(IHOLD1.EQ.'OFF')IHOLD2=' ' 11943 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDETPL 11944 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDETPL 11945 ITEPLI(I)=IHOLD2 11946 1225 CONTINUE 11947 GOTO1270 11948C 11949 1270 CONTINUE 11950 IF(IFEEDB.EQ.'OFF')GOTO1279 11951 WRITE(ICOUT,999) 11952 CALL DPWRST('XXX','BUG ') 11953 DO1278I=1,NUMTEX 11954 WRITE(ICOUT,1276)I,ITEPLI(I) 11955 1276 FORMAT('THE LINE TYPE FOR TEXT PATTERN ',I6, 11956 1' HAS JUST BEEN SET TO ',A4) 11957 CALL DPWRST('XXX','BUG ') 11958 1278 CONTINUE 11959 1279 CONTINUE 11960 IFOUND='YES' 11961 GOTO9000 11962C 11963C ************************** 11964C ** STEP 3-- ** 11965C ** TREAT THE ALL CASE ** 11966C ************************** 11967C 11968 1300 CONTINUE 11969 ISTEPN='3' 11970 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 11971C 11972 NUMTEX=MAXTEX 11973 IHOLD2=IHOLD1 11974 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' 11975 IF(IHOLD1.EQ.'OFF')IHOLD2=' ' 11976 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDETPL 11977 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDETPL 11978 DO1315I=1,NUMTEX 11979 ITEPLI(I)=IHOLD2 11980 1315 CONTINUE 11981 GOTO1370 11982C 11983 1370 CONTINUE 11984 IF(IFEEDB.EQ.'OFF')GOTO1319 11985 WRITE(ICOUT,999) 11986 CALL DPWRST('XXX','BUG ') 11987 I=1 11988 WRITE(ICOUT,1316)ITEPLI(I) 11989 1316 FORMAT('THE LINE TYPE FOR ALL TEXT PATTERNS', 11990 1' HAS JUST BEEN SET TO ',A4) 11991 CALL DPWRST('XXX','BUG ') 11992 1319 CONTINUE 11993 IFOUND='YES' 11994 GOTO9000 11995C 11996C ***************** 11997C ** STEP 90-- ** 11998C ** EXIT ** 11999C ***************** 12000C 12001 9000 CONTINUE 12002 IF(IBUGP2.EQ.'OFF')GOTO9090 12003 WRITE(ICOUT,9011) 12004 9011 FORMAT('***** AT THE END OF DPTPLI--') 12005 CALL DPWRST('XXX','BUG ') 12006 WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 12007 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 12008 CALL DPWRST('XXX','BUG ') 12009 WRITE(ICOUT,9013)MAXTEX,NUMTEX 12010 9013 FORMAT('MAXTEX,NUMTEX = ',I8,I8) 12011 CALL DPWRST('XXX','BUG ') 12012 WRITE(ICOUT,9014)IHOLD1,IHOLD2 12013 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 12014 CALL DPWRST('XXX','BUG ') 12015 WRITE(ICOUT,9015)IDETPL 12016 9015 FORMAT('IDETPL = ',A4) 12017 CALL DPWRST('XXX','BUG ') 12018 WRITE(ICOUT,9020)NUMARG 12019 9020 FORMAT('NUMARG = ',I8) 12020 CALL DPWRST('XXX','BUG ') 12021 DO9025I=1,NUMARG 12022 WRITE(ICOUT,9026)IHARG(I) 12023 9026 FORMAT('IHARG(I) = ',A4) 12024 CALL DPWRST('XXX','BUG ') 12025 9025 CONTINUE 12026 WRITE(ICOUT,9030)ITEPLI(1) 12027 9030 FORMAT('ITEPLI(1) = ',A4) 12028 CALL DPWRST('XXX','BUG ') 12029 DO9035I=1,10 12030 WRITE(ICOUT,9036)I,ITEPLI(I) 12031 9036 FORMAT('I,ITEPLI(I) = ',I8,2X,A4) 12032 CALL DPWRST('XXX','BUG ') 12033 9035 CONTINUE 12034 9090 CONTINUE 12035C 12036 RETURN 12037 END 12038 SUBROUTINE DPTPSP(IHARG,IARGT,ARG,NUMARG,PDETPS,MAXTEX,PTEPSP, 12039 1IBUGP2,IFOUND,IERROR) 12040C 12041C PURPOSE--DEFINE THE TEXT PATTERN SPACINGS = THE SPACINGS 12042C BETWEEN THE LINES WHICH MAKE UP THE PATTERNS WITHIN THE TEXTS. 12043C THESE ARE LOCATED IN THE VECTOR PTEPSP(.). 12044C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 12045C --IARGT (A CHARACTER VECTOR) 12046C --ARG 12047C --NUMARG 12048C --PDETPS 12049C --MAXTEX 12050C --IBUGP2 ('ON' OR 'OFF' ) 12051C OUTPUT ARGUMENTS--PTEPSP (A FLOATING POINT VECTOR) 12052C --IFOUND ('YES' OR 'NO' ) 12053C --IERROR ('YES' OR 'NO' ) 12054C WRITTEN BY--JAMES J. FILLIBEN 12055C STATISTICAL ENGINEERING DIVISION 12056C INFORMATION TECHNOLOGY LABORATORY 12057C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 12058C GAITHERSBURG, MD 20899-8980 12059C PHONE--301-975-2855 12060C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12061C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 12062C LANGUAGE--ANSI FORTRAN (1977) 12063C VERSION NUMBER--82/7 12064C ORIGINAL VERSION--DECEMBER 1983. 12065C 12066C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12067C 12068 CHARACTER*4 IHARG 12069 CHARACTER*4 IARGT 12070C 12071 CHARACTER*4 IBUGP2 12072 CHARACTER*4 IFOUND 12073 CHARACTER*4 IERROR 12074C 12075 CHARACTER*4 IHOLD1 12076C 12077 CHARACTER*4 ISUBN1 12078 CHARACTER*4 ISUBN2 12079 CHARACTER*4 ISTEPN 12080C 12081 DIMENSION IHARG(*) 12082 DIMENSION IARGT(*) 12083 DIMENSION ARG(*) 12084 DIMENSION PTEPSP(*) 12085C 12086C-----COMMON---------------------------------------------------------- 12087C 12088 INCLUDE 'DPCOP2.INC' 12089C 12090C-----START POINT----------------------------------------------------- 12091C 12092 IFOUND='NO' 12093 IERROR='NO' 12094 ISUBN1='DPTP' 12095 ISUBN2='SP ' 12096C 12097 NUMTEX=0 12098 IHOLD1='-999' 12099 HOLD1=-999.0 12100 HOLD2=-999.0 12101C 12102 IF(IBUGP2.EQ.'OFF')GOTO90 12103 WRITE(ICOUT,999) 12104 999 FORMAT(1X) 12105 CALL DPWRST('XXX','BUG ') 12106 WRITE(ICOUT,51) 12107 51 FORMAT('***** AT THE BEGINNING OF DPTPSP--') 12108 CALL DPWRST('XXX','BUG ') 12109 WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 12110 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 12111 CALL DPWRST('XXX','BUG ') 12112 WRITE(ICOUT,53)MAXTEX,NUMTEX 12113 53 FORMAT('MAXTEX,NUMTEX = ',I8,I8) 12114 CALL DPWRST('XXX','BUG ') 12115 WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2 12116 54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) 12117 CALL DPWRST('XXX','BUG ') 12118 WRITE(ICOUT,55)PDETPS 12119 55 FORMAT('PDETPS = ',E15.7) 12120 CALL DPWRST('XXX','BUG ') 12121 WRITE(ICOUT,60)NUMARG 12122 60 FORMAT('NUMARG = ',I8) 12123 CALL DPWRST('XXX','BUG ') 12124 DO65I=1,NUMARG 12125 WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I) 12126 66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) 12127 CALL DPWRST('XXX','BUG ') 12128 65 CONTINUE 12129 WRITE(ICOUT,70)PTEPSP(1) 12130 70 FORMAT('PTEPSP(1) = ',E15.7) 12131 CALL DPWRST('XXX','BUG ') 12132 DO75I=1,10 12133 WRITE(ICOUT,76)I,PTEPSP(I) 12134 76 FORMAT('I,PTEPSP(I) = ',I8,2X,E15.7) 12135 CALL DPWRST('XXX','BUG ') 12136 75 CONTINUE 12137 90 CONTINUE 12138C 12139C ************************************** 12140C ** STEP 1-- ** 12141C ** BRANCH TO THE APPROPRIATE CASE ** 12142C ************************************** 12143C 12144 ISTEPN='1' 12145 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12146C 12147 IF(NUMARG.LE.1)GOTO9000 12148 IF(NUMARG.EQ.2)GOTO1120 12149 IF(NUMARG.EQ.3)GOTO1130 12150 IF(NUMARG.EQ.4)GOTO1140 12151 GOTO1150 12152C 12153 1120 CONTINUE 12154 GOTO1200 12155C 12156 1130 CONTINUE 12157 IF(IHARG(3).EQ.'ALL')IHOLD1=' ' 12158 IF(IHARG(3).EQ.'ALL')HOLD1=PDETPS 12159 IF(IHARG(3).EQ.'ALL')GOTO1300 12160 GOTO1200 12161C 12162 1140 CONTINUE 12163 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) 12164 IF(IHARG(3).EQ.'ALL')HOLD1=ARG(4) 12165 IF(IHARG(3).EQ.'ALL')GOTO1300 12166 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) 12167 IF(IHARG(4).EQ.'ALL')HOLD1=ARG(3) 12168 IF(IHARG(4).EQ.'ALL')GOTO1300 12169 GOTO1200 12170C 12171 1150 CONTINUE 12172 GOTO1200 12173C 12174C ************************************************* 12175C ** STEP 2-- ** 12176C ** TREAT THE SINGLE SPECIFICATION CASE ** 12177C ************************************************* 12178C 12179 1200 CONTINUE 12180 ISTEPN='2' 12181 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12182C 12183 IF(NUMARG.LE.2)GOTO1210 12184 GOTO1220 12185C 12186 1210 CONTINUE 12187 NUMTEX=1 12188 PTEPSP(1)=PDETPS 12189 GOTO1270 12190C 12191 1220 CONTINUE 12192 NUMTEX=NUMARG-2 12193 IF(NUMTEX.GT.MAXTEX)NUMTEX=MAXTEX 12194 DO1225I=1,NUMTEX 12195 J=I+2 12196 IHOLD1=IHARG(J) 12197 HOLD1=ARG(J) 12198 HOLD2=HOLD1 12199 IF(IHOLD1.EQ.'ON')HOLD2=PDETPS 12200 IF(IHOLD1.EQ.'OFF')HOLD2=PDETPS 12201 IF(IHOLD1.EQ.'AUTO')HOLD2=PDETPS 12202 IF(IHOLD1.EQ.'DEFA')HOLD2=PDETPS 12203 PTEPSP(I)=HOLD2 12204 1225 CONTINUE 12205 GOTO1270 12206C 12207 1270 CONTINUE 12208 IF(IFEEDB.EQ.'OFF')GOTO1279 12209 WRITE(ICOUT,999) 12210 CALL DPWRST('XXX','BUG ') 12211 DO1278I=1,NUMTEX 12212 WRITE(ICOUT,1276)I,PTEPSP(I) 12213 1276 FORMAT('THE SPACING BETWEEN (LINES WITHIN) PATTERN ',I6, 12214 1' HAS JUST BEEN SET TO ',E15.7) 12215 CALL DPWRST('XXX','BUG ') 12216 1278 CONTINUE 12217 1279 CONTINUE 12218 IFOUND='YES' 12219 GOTO9000 12220C 12221C ************************** 12222C ** STEP 3-- ** 12223C ** TREAT THE ALL CASE ** 12224C ************************** 12225C 12226 1300 CONTINUE 12227 ISTEPN='3' 12228 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12229C 12230 NUMTEX=MAXTEX 12231 HOLD2=HOLD1 12232 IF(IHOLD1.EQ.'ON')HOLD2=PDETPS 12233 IF(IHOLD1.EQ.'OFF')HOLD2=PDETPS 12234 IF(IHOLD1.EQ.'AUTO')HOLD2=PDETPS 12235 IF(IHOLD1.EQ.'DEFA')HOLD2=PDETPS 12236 DO1315I=1,NUMTEX 12237 PTEPSP(I)=HOLD2 12238 1315 CONTINUE 12239 GOTO1370 12240C 12241 1370 CONTINUE 12242 IF(IFEEDB.EQ.'OFF')GOTO1319 12243 WRITE(ICOUT,999) 12244 CALL DPWRST('XXX','BUG ') 12245 I=1 12246 WRITE(ICOUT,1316)PTEPSP(I) 12247 1316 FORMAT('THE SPACING BETWEEN (LINES WITHIN) ALL PATTERNS', 12248 1' HAS JUST BEEN SET TO ',E15.7) 12249 CALL DPWRST('XXX','BUG ') 12250 1319 CONTINUE 12251 IFOUND='YES' 12252 GOTO9000 12253C 12254C ***************** 12255C ** STEP 90-- ** 12256C ** EXIT ** 12257C ***************** 12258C 12259 9000 CONTINUE 12260 IF(IBUGP2.EQ.'OFF')GOTO9090 12261 WRITE(ICOUT,9011) 12262 9011 FORMAT('***** AT THE END OF DPTPSP--') 12263 CALL DPWRST('XXX','BUG ') 12264 WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 12265 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 12266 CALL DPWRST('XXX','BUG ') 12267 WRITE(ICOUT,9013)MAXTEX,NUMTEX 12268 9013 FORMAT('MAXTEX,NUMTEX = ',I8,I8) 12269 CALL DPWRST('XXX','BUG ') 12270 WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2 12271 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) 12272 CALL DPWRST('XXX','BUG ') 12273 WRITE(ICOUT,9015)PDETPS 12274 9015 FORMAT('PDETPS = ',E15.7) 12275 CALL DPWRST('XXX','BUG ') 12276 WRITE(ICOUT,9020)NUMARG 12277 9020 FORMAT('NUMARG = ',I8) 12278 CALL DPWRST('XXX','BUG ') 12279 DO9025I=1,NUMARG 12280 WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I) 12281 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) 12282 CALL DPWRST('XXX','BUG ') 12283 9025 CONTINUE 12284 WRITE(ICOUT,9030)PTEPSP(1) 12285 9030 FORMAT('PTEPSP(1) = ',E15.7) 12286 CALL DPWRST('XXX','BUG ') 12287 DO9035I=1,10 12288 WRITE(ICOUT,9036)I,PTEPSP(I) 12289 9036 FORMAT('I,PTEPSP(I) = ',I8,2X,E15.7) 12290 CALL DPWRST('XXX','BUG ') 12291 9035 CONTINUE 12292 9090 CONTINUE 12293C 12294 RETURN 12295 END 12296 SUBROUTINE DPTPTH(IHARG,IARGT,ARG,NUMARG,PDETPT,MAXTEX,PTEPTH, 12297 1IBUGP2,IFOUND,IERROR) 12298C 12299C PURPOSE--DEFINE THE TEXT PATTERN THICKNESSES = THE THICKNESSES 12300C OF THE LINES WHICH MAKE UP THE PATTERNS WITHIN THE TEXTS. 12301C THESE ARE LOCATED IN THE VECTOR PTEPTH(.). 12302C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 12303C --IARGT (A CHARACTER VECTOR) 12304C --ARG 12305C --NUMARG 12306C --PDETPT 12307C --MAXTEX 12308C --IBUGP2 ('ON' OR 'OFF' ) 12309C OUTPUT ARGUMENTS--PTEPTH (A FLOATING POINT VECTOR) 12310C --IFOUND ('YES' OR 'NO' ) 12311C --IERROR ('YES' OR 'NO' ) 12312C WRITTEN BY--JAMES J. FILLIBEN 12313C STATISTICAL ENGINEERING DIVISION 12314C INFORMATION TECHNOLOGY LABORATORY 12315C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 12316C GAITHERSBURG, MD 20899-8980 12317C PHONE--301-975-2855 12318C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12319C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 12320C LANGUAGE--ANSI FORTRAN (1977) 12321C VERSION NUMBER--82/7 12322C ORIGINAL VERSION--DECEMBER 1983. 12323C 12324C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12325C 12326 CHARACTER*4 IHARG 12327 CHARACTER*4 IARGT 12328C 12329 CHARACTER*4 IBUGP2 12330 CHARACTER*4 IFOUND 12331 CHARACTER*4 IERROR 12332C 12333 CHARACTER*4 IHOLD1 12334C 12335 CHARACTER*4 ISUBN1 12336 CHARACTER*4 ISUBN2 12337 CHARACTER*4 ISTEPN 12338C 12339 DIMENSION IHARG(*) 12340 DIMENSION IARGT(*) 12341 DIMENSION ARG(*) 12342 DIMENSION PTEPTH(*) 12343C 12344C-----COMMON---------------------------------------------------------- 12345C 12346 INCLUDE 'DPCOP2.INC' 12347C 12348C-----START POINT----------------------------------------------------- 12349C 12350 IFOUND='NO' 12351 IERROR='NO' 12352 ISUBN1='DPTP' 12353 ISUBN2='TH ' 12354C 12355 NUMTEX=0 12356 IHOLD1='-999' 12357 HOLD1=-999.0 12358 HOLD2=-999.0 12359C 12360 IF(IBUGP2.EQ.'OFF')GOTO90 12361 WRITE(ICOUT,999) 12362 999 FORMAT(1X) 12363 CALL DPWRST('XXX','BUG ') 12364 WRITE(ICOUT,51) 12365 51 FORMAT('***** AT THE BEGINNING OF DPTPTH--') 12366 CALL DPWRST('XXX','BUG ') 12367 WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 12368 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 12369 CALL DPWRST('XXX','BUG ') 12370 WRITE(ICOUT,53)MAXTEX,NUMTEX 12371 53 FORMAT('MAXTEX,NUMTEX = ',I8,I8) 12372 CALL DPWRST('XXX','BUG ') 12373 WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2 12374 54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) 12375 CALL DPWRST('XXX','BUG ') 12376 WRITE(ICOUT,55)PDETPT 12377 55 FORMAT('PDETPT = ',E15.7) 12378 CALL DPWRST('XXX','BUG ') 12379 WRITE(ICOUT,60)NUMARG 12380 60 FORMAT('NUMARG = ',I8) 12381 CALL DPWRST('XXX','BUG ') 12382 DO65I=1,NUMARG 12383 WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I) 12384 66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) 12385 CALL DPWRST('XXX','BUG ') 12386 65 CONTINUE 12387 WRITE(ICOUT,70)PTEPTH(1) 12388 70 FORMAT('PTEPTH(1) = ',E15.7) 12389 CALL DPWRST('XXX','BUG ') 12390 DO75I=1,10 12391 WRITE(ICOUT,76)I,PTEPTH(I) 12392 76 FORMAT('I,PTEPTH(I) = ',I8,2X,E15.7) 12393 CALL DPWRST('XXX','BUG ') 12394 75 CONTINUE 12395 90 CONTINUE 12396C 12397C ************************************** 12398C ** STEP 1-- ** 12399C ** BRANCH TO THE APPROPRIATE CASE ** 12400C ************************************** 12401C 12402 ISTEPN='1' 12403 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12404C 12405 IF(NUMARG.LE.1)GOTO9000 12406 IF(NUMARG.EQ.2)GOTO1120 12407 IF(NUMARG.EQ.3)GOTO1130 12408 IF(NUMARG.EQ.4)GOTO1140 12409 GOTO1150 12410C 12411 1120 CONTINUE 12412 GOTO1200 12413C 12414 1130 CONTINUE 12415 IF(IHARG(3).EQ.'ALL')IHOLD1=' ' 12416 IF(IHARG(3).EQ.'ALL')HOLD1=PDETPT 12417 IF(IHARG(3).EQ.'ALL')GOTO1300 12418 GOTO1200 12419C 12420 1140 CONTINUE 12421 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) 12422 IF(IHARG(3).EQ.'ALL')HOLD1=ARG(4) 12423 IF(IHARG(3).EQ.'ALL')GOTO1300 12424 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) 12425 IF(IHARG(4).EQ.'ALL')HOLD1=ARG(2) 12426 IF(IHARG(4).EQ.'ALL')GOTO1300 12427 GOTO1200 12428C 12429 1150 CONTINUE 12430 GOTO1200 12431C 12432C ************************************************* 12433C ** STEP 2-- ** 12434C ** TREAT THE SINGLE SPECIFICATION CASE ** 12435C ************************************************* 12436C 12437 1200 CONTINUE 12438 ISTEPN='2' 12439 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12440C 12441 IF(NUMARG.LE.2)GOTO1210 12442 GOTO1220 12443C 12444 1210 CONTINUE 12445 NUMTEX=1 12446 PTEPTH(1)=PDETPT 12447 GOTO1270 12448C 12449 1220 CONTINUE 12450 NUMTEX=NUMARG-2 12451 IF(NUMTEX.GT.MAXTEX)NUMTEX=MAXTEX 12452 DO1225I=1,NUMTEX 12453 J=I+2 12454 IHOLD1=IHARG(J) 12455 HOLD1=ARG(J) 12456 HOLD2=HOLD1 12457 IF(IHOLD1.EQ.'ON')HOLD2=PDETPT 12458 IF(IHOLD1.EQ.'OFF')HOLD2=PDETPT 12459 IF(IHOLD1.EQ.'AUTO')HOLD2=PDETPT 12460 IF(IHOLD1.EQ.'DEFA')HOLD2=PDETPT 12461 PTEPTH(I)=HOLD2 12462 1225 CONTINUE 12463 GOTO1270 12464C 12465 1270 CONTINUE 12466 IF(IFEEDB.EQ.'OFF')GOTO1279 12467 WRITE(ICOUT,999) 12468 CALL DPWRST('XXX','BUG ') 12469 DO1278I=1,NUMTEX 12470 WRITE(ICOUT,1276)I,PTEPTH(I) 12471 1276 FORMAT('THE THICKNESS OF (LINES WITHIN) PATTERN ',I6, 12472 1' HAS JUST BEEN SET TO ',E15.7) 12473 CALL DPWRST('XXX','BUG ') 12474 1278 CONTINUE 12475 1279 CONTINUE 12476 IFOUND='YES' 12477 GOTO9000 12478C 12479C ************************** 12480C ** STEP 3-- ** 12481C ** TREAT THE ALL CASE ** 12482C ************************** 12483C 12484 1300 CONTINUE 12485 ISTEPN='3' 12486 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12487C 12488 NUMTEX=MAXTEX 12489 HOLD2=HOLD1 12490 IF(IHOLD1.EQ.'ON')HOLD2=PDETPT 12491 IF(IHOLD1.EQ.'OFF')HOLD2=PDETPT 12492 IF(IHOLD1.EQ.'AUTO')HOLD2=PDETPT 12493 IF(IHOLD1.EQ.'DEFA')HOLD2=PDETPT 12494 DO1315I=1,NUMTEX 12495 PTEPTH(I)=HOLD2 12496 1315 CONTINUE 12497 GOTO1370 12498C 12499 1370 CONTINUE 12500 IF(IFEEDB.EQ.'OFF')GOTO1319 12501 WRITE(ICOUT,999) 12502 CALL DPWRST('XXX','BUG ') 12503 I=1 12504 WRITE(ICOUT,1316)PTEPTH(I) 12505 1316 FORMAT('THE THICKNESS OF (LINES WITHIN) ALL PATTERNS', 12506 1' HAS JUST BEEN SET TO ',E15.7) 12507 CALL DPWRST('XXX','BUG ') 12508 1319 CONTINUE 12509 IFOUND='YES' 12510 GOTO9000 12511C 12512C ***************** 12513C ** STEP 90-- ** 12514C ** EXIT ** 12515C ***************** 12516C 12517 9000 CONTINUE 12518 IF(IBUGP2.EQ.'OFF')GOTO9090 12519 WRITE(ICOUT,9011) 12520 9011 FORMAT('***** AT THE END OF DPTPTH--') 12521 CALL DPWRST('XXX','BUG ') 12522 WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 12523 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 12524 CALL DPWRST('XXX','BUG ') 12525 WRITE(ICOUT,9013)MAXTEX,NUMTEX 12526 9013 FORMAT('MAXTEX,NUMTEX = ',I8,I8) 12527 CALL DPWRST('XXX','BUG ') 12528 WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2 12529 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) 12530 CALL DPWRST('XXX','BUG ') 12531 WRITE(ICOUT,9015)PDETPT 12532 9015 FORMAT('PDETPT = ',E15.7) 12533 CALL DPWRST('XXX','BUG ') 12534 WRITE(ICOUT,9020)NUMARG 12535 9020 FORMAT('NUMARG = ',I8) 12536 CALL DPWRST('XXX','BUG ') 12537 DO9025I=1,NUMARG 12538 WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I) 12539 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) 12540 CALL DPWRST('XXX','BUG ') 12541 9025 CONTINUE 12542 WRITE(ICOUT,9030)PTEPTH(1) 12543 9030 FORMAT('PTEPTH(1) = ',E15.7) 12544 CALL DPWRST('XXX','BUG ') 12545 DO9035I=1,10 12546 WRITE(ICOUT,9036)I,PTEPTH(I) 12547 9036 FORMAT('I,PTEPTH(I) = ',I8,2X,E15.7) 12548 CALL DPWRST('XXX','BUG ') 12549 9035 CONTINUE 12550 9090 CONTINUE 12551C 12552 RETURN 12553 END 12554 SUBROUTINE DPTPTY(IHARG,NUMARG,IDETPT,MAXTEX,ITEPTY, 12555 1IBUGP2,IFOUND,IERROR) 12556C 12557C PURPOSE--DEFINE THE PATTERN TYPES = THE TYPES 12558C OF THE PATTERN WITHIN THE TEXTS. 12559C THESE ARE LOCATED IN THE VECTOR ITEPTY(.). 12560C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 12561C --NUMARG 12562C --IDETPT 12563C --MAXTEX 12564C --IBUGP2 ('ON' OR 'OFF' ) 12565C OUTPUT ARGUMENTS--ITEPTY (A CHARACTER VECTOR) 12566C --IFOUND ('YES' OR 'NO' ) 12567C --IERROR ('YES' OR 'NO' ) 12568C WRITTEN BY--JAMES J. FILLIBEN 12569C STATISTICAL ENGINEERING DIVISION 12570C INFORMATION TECHNOLOGY LABORATORY 12571C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 12572C GAITHERSBURG, MD 20899-8980 12573C PHONE--301-975-2855 12574C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12575C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 12576C LANGUAGE--ANSI FORTRAN (1977) 12577C VERSION NUMBER--82/7 12578C ORIGINAL VERSION--DECEMBER 1983. 12579C 12580C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12581C 12582 CHARACTER*4 IHARG 12583 CHARACTER*4 IDETPT 12584 CHARACTER*4 ITEPTY 12585C 12586 CHARACTER*4 IBUGP2 12587 CHARACTER*4 IFOUND 12588 CHARACTER*4 IERROR 12589C 12590 CHARACTER*4 IHOLD1 12591 CHARACTER*4 IHOLD2 12592C 12593 CHARACTER*4 ISUBN1 12594 CHARACTER*4 ISUBN2 12595 CHARACTER*4 ISTEPN 12596C 12597 DIMENSION IHARG(*) 12598 DIMENSION ITEPTY(*) 12599C 12600C-----COMMON---------------------------------------------------------- 12601C 12602 INCLUDE 'DPCOP2.INC' 12603C 12604C-----START POINT----------------------------------------------------- 12605C 12606 IFOUND='NO' 12607 IERROR='NO' 12608 ISUBN1='DPTP' 12609 ISUBN2='TY ' 12610C 12611 NUMTEX=0 12612 IHOLD1='-999' 12613 IHOLD2='-999' 12614C 12615 IF(IBUGP2.EQ.'OFF')GOTO90 12616 WRITE(ICOUT,999) 12617 999 FORMAT(1X) 12618 CALL DPWRST('XXX','BUG ') 12619 WRITE(ICOUT,51) 12620 51 FORMAT('***** AT THE BEGINNING OF DPTPTY--') 12621 CALL DPWRST('XXX','BUG ') 12622 WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 12623 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 12624 CALL DPWRST('XXX','BUG ') 12625 WRITE(ICOUT,53)MAXTEX,NUMTEX 12626 53 FORMAT('MAXTEX,NUMTEX = ',I8,I8) 12627 CALL DPWRST('XXX','BUG ') 12628 WRITE(ICOUT,54)IHOLD1,IHOLD2 12629 54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 12630 CALL DPWRST('XXX','BUG ') 12631 WRITE(ICOUT,55)IDETPT 12632 55 FORMAT('IDETPT = ',A4) 12633 CALL DPWRST('XXX','BUG ') 12634 WRITE(ICOUT,60)NUMARG 12635 60 FORMAT('NUMARG = ',I8) 12636 CALL DPWRST('XXX','BUG ') 12637 DO65I=1,NUMARG 12638 WRITE(ICOUT,66)IHARG(I) 12639 66 FORMAT('IHARG(I) = ',A4) 12640 CALL DPWRST('XXX','BUG ') 12641 65 CONTINUE 12642 WRITE(ICOUT,70)ITEPTY(1) 12643 70 FORMAT('ITEPTY(1) = ',A4) 12644 CALL DPWRST('XXX','BUG ') 12645 DO75I=1,10 12646 WRITE(ICOUT,76)I,ITEPTY(I) 12647 76 FORMAT('I,ITEPTY(I) = ',I8,2X,A4) 12648 CALL DPWRST('XXX','BUG ') 12649 75 CONTINUE 12650 90 CONTINUE 12651C 12652C ************************************** 12653C ** STEP 1-- ** 12654C ** BRANCH TO THE APPROPRIATE CASE ** 12655C ************************************** 12656C 12657 ISTEPN='1' 12658 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12659C 12660 IF(NUMARG.LE.1)GOTO9000 12661 IF(NUMARG.EQ.2)GOTO1120 12662 IF(NUMARG.EQ.3)GOTO1130 12663 IF(NUMARG.EQ.4)GOTO1140 12664 GOTO1150 12665C 12666 1120 CONTINUE 12667 GOTO1200 12668C 12669 1130 CONTINUE 12670 IF(IHARG(3).EQ.'ALL')IHOLD1=' ' 12671 IF(IHARG(3).EQ.'ALL')GOTO1300 12672 GOTO1200 12673C 12674 1140 CONTINUE 12675 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) 12676 IF(IHARG(3).EQ.'ALL')GOTO1300 12677 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) 12678 IF(IHARG(4).EQ.'ALL')GOTO1300 12679 GOTO1200 12680C 12681 1150 CONTINUE 12682 GOTO1200 12683C 12684C ************************************************* 12685C ** STEP 2-- ** 12686C ** TREAT THE SINGLE SPECIFICATION CASE ** 12687C ************************************************* 12688C 12689 1200 CONTINUE 12690 ISTEPN='2' 12691 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12692C 12693 IF(NUMARG.LE.2)GOTO1210 12694 GOTO1220 12695C 12696 1210 CONTINUE 12697 NUMTEX=1 12698 ITEPTY(1)=' ' 12699 GOTO1270 12700C 12701 1220 CONTINUE 12702 NUMTEX=NUMARG-2 12703 IF(NUMTEX.GT.MAXTEX)NUMTEX=MAXTEX 12704 DO1225I=1,NUMTEX 12705 J=I+2 12706 IHOLD1=IHARG(J) 12707 IHOLD2=IHOLD1 12708 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' 12709 IF(IHOLD1.EQ.'OFF')IHOLD2=' ' 12710 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDETPT 12711 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDETPT 12712 ITEPTY(I)=IHOLD2 12713 1225 CONTINUE 12714 GOTO1270 12715C 12716 1270 CONTINUE 12717 IF(IFEEDB.EQ.'OFF')GOTO1279 12718 WRITE(ICOUT,999) 12719 CALL DPWRST('XXX','BUG ') 12720 DO1278I=1,NUMTEX 12721 WRITE(ICOUT,1276)I,ITEPTY(I) 12722 1276 FORMAT('THE TYPE FOR TEXT PATTERN ',I6, 12723 1' HAS JUST BEEN SET TO ',A4) 12724 CALL DPWRST('XXX','BUG ') 12725 1278 CONTINUE 12726 1279 CONTINUE 12727 IFOUND='YES' 12728 GOTO9000 12729C 12730C ************************** 12731C ** STEP 3-- ** 12732C ** TREAT THE ALL CASE ** 12733C ************************** 12734C 12735 1300 CONTINUE 12736 ISTEPN='3' 12737 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12738C 12739 NUMTEX=MAXTEX 12740 IHOLD2=IHOLD1 12741 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' 12742 IF(IHOLD1.EQ.'OFF')IHOLD2=' ' 12743 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDETPT 12744 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDETPT 12745 DO1315I=1,NUMTEX 12746 ITEPTY(I)=IHOLD2 12747 1315 CONTINUE 12748 GOTO1370 12749C 12750 1370 CONTINUE 12751 IF(IFEEDB.EQ.'OFF')GOTO1319 12752 WRITE(ICOUT,999) 12753 CALL DPWRST('XXX','BUG ') 12754 I=1 12755 WRITE(ICOUT,1316)ITEPTY(I) 12756 1316 FORMAT('THE TYPE FOR ALL TEXT PATTERNS', 12757 1' HAS JUST BEEN SET TO ',A4) 12758 CALL DPWRST('XXX','BUG ') 12759 1319 CONTINUE 12760 IFOUND='YES' 12761 GOTO9000 12762C 12763C ***************** 12764C ** STEP 90-- ** 12765C ** EXIT ** 12766C ***************** 12767C 12768 9000 CONTINUE 12769 IF(IBUGP2.EQ.'OFF')GOTO9090 12770 WRITE(ICOUT,9011) 12771 9011 FORMAT('***** AT THE END OF DPTPTY--') 12772 CALL DPWRST('XXX','BUG ') 12773 WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 12774 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 12775 CALL DPWRST('XXX','BUG ') 12776 WRITE(ICOUT,9013)MAXTEX,NUMTEX 12777 9013 FORMAT('MAXTEX,NUMTEX = ',I8,I8) 12778 CALL DPWRST('XXX','BUG ') 12779 WRITE(ICOUT,9014)IHOLD1,IHOLD2 12780 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 12781 CALL DPWRST('XXX','BUG ') 12782 WRITE(ICOUT,9015)IDETPT 12783 9015 FORMAT('IDETPT = ',A4) 12784 CALL DPWRST('XXX','BUG ') 12785 WRITE(ICOUT,9020)NUMARG 12786 9020 FORMAT('NUMARG = ',I8) 12787 CALL DPWRST('XXX','BUG ') 12788 DO9025I=1,NUMARG 12789 WRITE(ICOUT,9026)IHARG(I) 12790 9026 FORMAT('IHARG(I) = ',A4) 12791 CALL DPWRST('XXX','BUG ') 12792 9025 CONTINUE 12793 WRITE(ICOUT,9030)ITEPTY(1) 12794 9030 FORMAT('ITEPTY(1) = ',A4) 12795 CALL DPWRST('XXX','BUG ') 12796 DO9035I=1,10 12797 WRITE(ICOUT,9036)I,ITEPTY(I) 12798 9036 FORMAT('I,ITEPTY(I) = ',I8,2X,A4) 12799 CALL DPWRST('XXX','BUG ') 12800 9035 CONTINUE 12801 9090 CONTINUE 12802C 12803 RETURN 12804 END 12805 SUBROUTINE DPTREN(XTEMP2,MAXNXT,ICAPSW,IFORSW, 12806 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 12807C 12808C PURPOSE--CARRY OUT 3 TRENDS TEST FOR RELIABILITY ANALYSIS. 12809C 1) REVERSE ARRANGEMENTS TEST 12810C 2) MILITARY HANDBOOK TEST 12811C 3) LAPLACE TEST 12812C EXAMPLES--LET TEND = <VALUE>; RELIABILITY TREND TEST Y 12813C --LET TEND = <VALUE>; RELIABILITY TREND TEST Y GROUPID 12814C --RELIABILITY TREND TEST Y GROUPID CENSOR 12815C REFERENCE--TOBIAS AND TRINDADE (1995), "APPLIED RELIABILITY 12816C ANALYSIS", SECOND EDITION, CHAPMAN & HALL/CRC, 12817C PP. 344-354. 12818C WRITTEN BY--ALAN HECKERT 12819C STATISTICAL ENGINEERING DIVISION 12820C INFORMATION TECHNOLOGY LABORATORY 12821C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 12822C GAITHERSBURG, MD 20899-8980 12823C PHONE--301-975-2899 12824C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12825C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 12826C LANGUAGE--ANSI FORTRAN (1977) 12827C VERSION NUMBER--98/5 12828C ORIGINAL VERSION--MAY 1998. 12829C UPDATED --OCTOBER 2006. SUPPORT FOR MULTIPLE SYSTEMS 12830C UPDATED --OCTOBER 2006. CAPTURE HTML/LATEX/RTF 12831C UPDATED --FEBRUARY 2011. USE DPPARS AND DPPAR3 12832C 12833C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12834C 12835 CHARACTER*4 ICAPSW 12836 CHARACTER*4 IFORSW 12837 CHARACTER*4 IBUGA2 12838 CHARACTER*4 IBUGA3 12839 CHARACTER*4 IBUGQ 12840 CHARACTER*4 ISUBRO 12841 CHARACTER*4 IFOUND 12842 CHARACTER*4 IERROR 12843C 12844 CHARACTER*4 IHP 12845 CHARACTER*4 IHP2 12846 CHARACTER*4 IHWUSE 12847 CHARACTER*4 MESSAG 12848C 12849 CHARACTER*4 ISUBN1 12850 CHARACTER*4 ISUBN2 12851 CHARACTER*4 ISTEPN 12852C 12853 CHARACTER*4 ICASE 12854 CHARACTER*40 INAME 12855 PARAMETER (MAXSPN=20) 12856 CHARACTER*4 IVARN1(MAXSPN) 12857 CHARACTER*4 IVARN2(MAXSPN) 12858 CHARACTER*4 IVARTY(MAXSPN) 12859 REAL PVAR(MAXSPN) 12860 INTEGER ILIS(MAXSPN) 12861 INTEGER NRIGHT(MAXSPN) 12862 INTEGER ICOLR(MAXSPN) 12863C 12864C--------------------------------------------------------------------- 12865C 12866 INCLUDE 'DPCOPA.INC' 12867C 12868 DIMENSION XTEMP2(*) 12869C 12870 DIMENSION Y1(MAXOBV) 12871 DIMENSION X1(MAXOBV) 12872 DIMENSION XCEN(MAXOBV) 12873 DIMENSION TEMP1(MAXOBV) 12874 DIMENSION TEMP2(MAXOBV) 12875 DIMENSION TEMP3(MAXOBV) 12876 DIMENSION TEMP4(MAXOBV) 12877 DIMENSION TEMP5(MAXOBV) 12878 DIMENSION TEMP6(MAXOBV) 12879C 12880 INCLUDE 'DPCOZZ.INC' 12881 EQUIVALENCE (GARBAG(IGARB1),Y1(1)) 12882 EQUIVALENCE (GARBAG(IGARB2),X1(1)) 12883 EQUIVALENCE (GARBAG(IGARB3),XCEN(1)) 12884 EQUIVALENCE (GARBAG(IGARB4),TEMP1(1)) 12885 EQUIVALENCE (GARBAG(IGARB5),TEMP2(1)) 12886 EQUIVALENCE (GARBAG(IGARB6),TEMP3(1)) 12887 EQUIVALENCE (GARBAG(IGARB7),TEMP4(1)) 12888 EQUIVALENCE (GARBAG(IGARB8),TEMP5(1)) 12889 EQUIVALENCE (GARBAG(IGARB9),TEMP6(1)) 12890C 12891C-----COMMON---------------------------------------------------------- 12892C 12893 INCLUDE 'DPCOHK.INC' 12894 INCLUDE 'DPCOSU.INC' 12895 INCLUDE 'DPCODA.INC' 12896 INCLUDE 'DPCOP2.INC' 12897C 12898C-----START POINT----------------------------------------------------- 12899C 12900 ISUBN1='DPTR' 12901 ISUBN2='EN ' 12902 IFOUND='YES' 12903 IERROR='NO' 12904C 12905 MAXCP1=MAXCOL+1 12906 MAXCP2=MAXCOL+2 12907 MAXCP3=MAXCOL+3 12908 MAXCP4=MAXCOL+4 12909 MAXCP5=MAXCOL+5 12910 MAXCP6=MAXCOL+6 12911C 12912 NGROUP=0 12913 NCENS=0 12914C 12915C ********************************** 12916C ** TREAT THE TRENDS TEST CASE ** 12917C ********************************** 12918C 12919 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TREN')THEN 12920 WRITE(ICOUT,999) 12921 999 FORMAT(1X) 12922 CALL DPWRST('XXX','BUG ') 12923 WRITE(ICOUT,51) 12924 51 FORMAT('***** AT THE BEGINNING OF DPTREN--') 12925 CALL DPWRST('XXX','BUG ') 12926 WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO 12927 52 FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',3(A4,2X),A4) 12928 CALL DPWRST('XXX','BUG ') 12929 ENDIF 12930C 12931C ********************************* 12932C ** STEP 1-- ** 12933C ** EXTRACT THE VARIABLE LIST ** 12934C ********************************* 12935C 12936 ISTEPN='4' 12937 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TREN') 12938 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12939C 12940 INAME='RELIABILITY TREND TEST' 12941 MINNA=1 12942 MAXNA=100 12943 MINN2=4 12944 IFLAGE=1 12945 IFLAGM=9 12946 IFLAGP=0 12947 JMIN=1 12948 JMAX=NUMARG 12949 MINNVA=1 12950 MAXNVA=3 12951C 12952 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 12953 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 12954 1 JMIN,JMAX, 12955 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 12956 1 IVARN1,IVARN2,IVARTY,PVAR, 12957 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 12958 1 MINNVA,MAXNVA, 12959 1 IFLAGM,IFLAGP, 12960 1 IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 12961 IF(IERROR.EQ.'YES')GOTO9000 12962C 12963 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TREN')THEN 12964 WRITE(ICOUT,999) 12965 CALL DPWRST('XXX','BUG ') 12966 WRITE(ICOUT,281) 12967 281 FORMAT('***** AFTER CALL DPPARS--') 12968 CALL DPWRST('XXX','BUG ') 12969 WRITE(ICOUT,282)NQ,NUMVAR 12970 282 FORMAT('NQ,NUMVAR = ',2I8) 12971 CALL DPWRST('XXX','BUG ') 12972 IF(NUMVAR.GT.0)THEN 12973 DO285I=1,NUMVAR 12974 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 12975 1 ICOLR(I),PVAR(I) 12976 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 12977 1 'ICOLR(I),PVAR(I) = ',I8,2X,A4,A4,2X,3I8,G15.7) 12978 CALL DPWRST('XXX','BUG ') 12979 285 CONTINUE 12980 ENDIF 12981 ENDIF 12982C 12983 ICOL=1 12984 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 12985 1 INAME,IVARN1,IVARN2,IVARTY, 12986 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 12987 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 12988 1 MAXCP4,MAXCP5,MAXCP6, 12989 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 12990 1 Y1,X1,XCEN,NS,NGROUP,NCENS,ICASE, 12991 1 IBUGA3,ISUBRO,IFOUND,IERROR) 12992C 12993C ***************************************** 12994C ** STEP 3-- ** 12995C ** CHECK TO SEE THE IF THE PARAMETER ** 12996C ** TEND (TO SPECIFY THE CENSORING TIME)* 12997C ***************************************** 12998C 12999 IHP='TEND' 13000 IHP2=' ' 13001 IHWUSE='P' 13002 MESSAG='NO' 13003 CALL CHECKN(IHP,IHP2,IHWUSE, 13004 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 13005 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 13006 IF(IERROR.EQ.'YES')THEN 13007 TEND=CPUMIN 13008 ELSE 13009 TEND=VALUE(ILOCP) 13010 ENDIF 13011C 13012C *********************************************** 13013C ** STEP 4-- ** 13014C ** PREPARE FOR ENTRANCE INTO DPTREN2-- ** 13015C *********************************************** 13016C 13017 ISTEPN='4' 13018 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TREN') 13019 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 13020C 13021 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TREN')THEN 13022 WRITE(ICOUT,999) 13023 CALL DPWRST('XXX','BUG ') 13024 WRITE(ICOUT,1211) 13025 1211 FORMAT('***** FROM DPTREN, AS WE ARE ABOUT TO CALL DPTRE2--') 13026 CALL DPWRST('XXX','BUG ') 13027 WRITE(ICOUT,1212)NS 13028 1212 FORMAT('NS = ',I8) 13029 CALL DPWRST('XXX','BUG ') 13030 DO1215I=1,NS 13031 WRITE(ICOUT,1216)I,Y1(I),X1(I),XCEN(I) 13032 1216 FORMAT('I,Y1(I),X1(I),XCEN(I) = ',I8,3G15.7) 13033 CALL DPWRST('XXX','BUG ') 13034 1215 CONTINUE 13035 ENDIF 13036C 13037 CALL DPTRE2(Y1,NS,X1,NGROUP,XCEN,NCENS, 13038 1 ICAPSW,ICAPTY,IFORSW, 13039 1 XTEMP2,TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6, 13040 1 TEND,MAXNXT, 13041 1 ISUBRO,IBUGA3,IERROR) 13042C 13043C ***************** 13044C ** STEP 90-- ** 13045C ** EXIT ** 13046C ***************** 13047C 13048 9000 CONTINUE 13049 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TREN')THEN 13050 WRITE(ICOUT,999) 13051 CALL DPWRST('XXX','BUG ') 13052 WRITE(ICOUT,9011) 13053 9011 FORMAT('***** AT THE END OF DPTREN--') 13054 CALL DPWRST('XXX','BUG ') 13055 WRITE(ICOUT,9016)IFOUND,IERROR 13056 9016 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 13057 CALL DPWRST('XXX','BUG ') 13058 ENDIF 13059C 13060 RETURN 13061 END 13062 SUBROUTINE DPTRE2(Y,N,X1,NGROUP,XCEN,NCENS, 13063 1 ICAPSW,ICAPTY,IFORSW, 13064 1 XTEMP1,XIDTEM,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6, 13065 1 TEND,MAXNXT, 13066 1 ISUBRO,IBUGA3,IERROR) 13067C 13068C PURPOSE--THIS ROUTINE CARRIES OUT A TRENDS ANALYSIS 13069C FOR THE DATA IN THE INPUT VECTOR Y. 13070C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR OF 13071C (UNSORTED) REPAIR/CENSORING TIMES. 13072C --X1 = THE OPTIONAL SINGLE PRECISION VECTOR 13073C GROUP-ID VALUES 13074C --XCEN = THE OPTIONAL SINGLE PRECISION VECTOR 13075C OF CENSOR VALUES (1 = REPAIR 13076C TIME, 0 = CENSOR TIME). 13077C NY = THE INTEGER NUMBER OF OBSERVATIONS 13078C IN THE VECTOR Y. 13079C NX = THE INTEGER NUMBER OF OBSERVATIONS 13080C IN THE VECTOR X1. 13081C NC = THE INTEGER NUMBER OF OBSERVATIONS 13082C IN THE VECTOR XCEN. 13083C REFERENCE--TOBIAS AND TRINDADE (1995), "APPLIED 13084C RELIABILITY", SECOND EDITION, CHAPMAN AND HALL, 13085C PP. 314. 13086C NOTE--3 TRENDS TESTS ARE PERFORMED: 13087C 1) REVERSE ARRANGEMENT TEST 13088C 2) MILITARY HANDBOOK TEST 13089C 3) LAPLACE TEST 13090C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. 13091C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 13092C LANGUAGE--ANSI 77 FORTRAN. 13093C WRITTEN BY--ALAN HECKERT 13094C STATISTICAL ENGINEERING DIVISION 13095C INFORMATION TECHNOLOGY LABORATORY 13096C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13097C GAITHERSBURG, MD 20899-8980 13098C PHONE--301-975-2899 13099C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13100C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13101C LANGUAGE--ANSI FORTRAN (1977) 13102C VERSION NUMBER--98/5 13103C ORIGINAL VERSION--MAY 1998. 13104C UPDATED --OCTOBER 2006. SUPPORT FOR MULTIPLE SYSTEMS 13105C UPDATED --OCTOBER 2006. SUPPORT FOR HTML/LATEX/RFT 13106C OUTPUT 13107C UPDATED --OCTOBER 2006. CHANGE OUTPUT FORMAT FOR 13108C REVERSE ARRANGEMENT TEST 13109C AND CORRECTED BUG IN THIS 13110C TEST 13111C UPDATED --OCTOBER 2006. CODE FOR SINGLE TEST 13112C EXTRACTED TO DPTRE3 13113C UPDATED --FEBRUARY 2011. USE DPDTA1 AND DPDTA5 TO PRINT 13114C TABLES 13115C 13116C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13117C 13118 CHARACTER*4 ICAPSW 13119 CHARACTER*4 ICAPTY 13120 CHARACTER*4 IFORSW 13121 CHARACTER*4 ISUBRO 13122 CHARACTER*4 IBUGA3 13123 CHARACTER*4 IERROR 13124C 13125 CHARACTER*4 ISUBN1 13126 CHARACTER*4 ISUBN2 13127 CHARACTER*4 ISTEPN 13128C 13129 DOUBLE PRECISION DSUM1 13130 DOUBLE PRECISION DSUM2 13131 DOUBLE PRECISION DSUM3 13132 DOUBLE PRECISION DVAL2 13133 DOUBLE PRECISION DVAL3 13134C 13135 REAL MHTPVA 13136C 13137C--------------------------------------------------------------------- 13138C 13139 DIMENSION Y(*) 13140 DIMENSION X1(*) 13141 DIMENSION XCEN(*) 13142 DIMENSION XTEMP1(*) 13143 DIMENSION XIDTEM(*) 13144 DIMENSION TEMP2(*) 13145 DIMENSION TEMP3(*) 13146 DIMENSION TEMP4(*) 13147 DIMENSION TEMP5(*) 13148 DIMENSION TEMP6(*) 13149C 13150 PARAMETER (NUMALP=3) 13151 PARAMETER(NUMCLI=5) 13152 PARAMETER(MAXLIN=3) 13153 PARAMETER (MAXROW=NUMALP) 13154 PARAMETER (MAXRO2=25) 13155 CHARACTER*60 ITITLE 13156 CHARACTER*60 ITITLZ 13157 CHARACTER*60 ITITL9 13158 CHARACTER*60 ITEXT(MAXRO2) 13159 CHARACTER*4 ALIGN(NUMCLI) 13160 CHARACTER*4 VALIGN(NUMCLI) 13161 REAL AVALUE(MAXRO2) 13162 INTEGER NCTEXT(MAXRO2) 13163 INTEGER IDIGIT(MAXRO2) 13164 INTEGER NTOT(MAXRO2) 13165 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 13166 CHARACTER*15 IVALUE(MAXROW,NUMCLI) 13167 CHARACTER*4 ITYPCO(NUMCLI) 13168 INTEGER NCTIT2(MAXLIN,NUMCLI) 13169 INTEGER NCVALU(MAXROW,NUMCLI) 13170 INTEGER IWHTML(NUMCLI) 13171 INTEGER IWRTF(NUMCLI) 13172 REAL AMAT(MAXROW,NUMCLI) 13173 LOGICAL IFRST 13174 LOGICAL ILAST 13175 LOGICAL IFLAGS 13176 LOGICAL IFLAGE 13177C 13178C 13179C-----COMMON---------------------------------------------------------- 13180C 13181 INCLUDE 'DPCOP2.INC' 13182C 13183C-----START POINT----------------------------------------------------- 13184C 13185 ISUBN1='DPTR' 13186 ISUBN2='E2 ' 13187 IERROR='NO' 13188C 13189 MAXSYS=10000 13190C 13191 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TRE2')THEN 13192 WRITE(ICOUT,999) 13193 999 FORMAT(1X) 13194 CALL DPWRST('XXX','BUG ') 13195 WRITE(ICOUT,51) 13196 51 FORMAT('**** AT THE BEGINNING OF DPTRE2--') 13197 CALL DPWRST('XXX','BUG ') 13198 WRITE(ICOUT,52)N,IBUGA3,ISUBRO 13199 52 FORMAT('N,IBUGA3,ISUBRO = ',I8,2X,A4,2X,A4) 13200 CALL DPWRST('XXX','BUG ') 13201 DO56I=1,MIN(N,100) 13202 WRITE(ICOUT,57)I,Y(I),X1(I),XCEN(I) 13203 57 FORMAT('I,Y(I),X1(I),XCEN(I) = ',I8,3G15.7) 13204 CALL DPWRST('XXX','BUG ') 13205 56 CONTINUE 13206 ENDIF 13207C 13208C ******************************************** 13209C ** STEP 1-- ** 13210C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 13211C ******************************************** 13212C 13213 ISTEPN='1' 13214 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TRE2') 13215 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 13216C 13217 IF(N.LT.4)THEN 13218 WRITE(ICOUT,999) 13219 CALL DPWRST('XXX','BUG ') 13220 WRITE(ICOUT,111) 13221 111 FORMAT('***** ERROR IN RELIABILITY TREND TEST--') 13222 CALL DPWRST('XXX','BUG ') 13223 WRITE(ICOUT,112) 13224 112 FORMAT(' THE NUMBER OF OBSERVATIONS IN THE RESPONSE ', 13225 1 'VARIABLE IS LESS THAN 4.') 13226 CALL DPWRST('XXX','BUG ') 13227 WRITE(ICOUT,115)N 13228 115 FORMAT('SAMPLE SIZE = ',I8) 13229 CALL DPWRST('XXX','BUG ') 13230 IERROR='YES' 13231 GOTO9000 13232 ENDIF 13233C 13234 HOLD=Y(1) 13235 DO135I=2,N 13236 IF(Y(I).NE.HOLD)GOTO139 13237 135 CONTINUE 13238 WRITE(ICOUT,999) 13239 CALL DPWRST('XXX','BUG ') 13240 WRITE(ICOUT,111) 13241 CALL DPWRST('XXX','BUG ') 13242 WRITE(ICOUT,131)HOLD 13243 131 FORMAT(' THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7) 13244 CALL DPWRST('XXX','BUG ') 13245 IERROR='YES' 13246 GOTO9000 13247 139 CONTINUE 13248C 13249C ******************************************** 13250C ** STEP 11-- ** 13251C ** GENERATE THE RELIABILITY TREND TESTS ** 13252C ******************************************** 13253C 13254 ISTEPN='11' 13255 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TRE2') 13256 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 13257C 13258C CASE 1: NO GROUP OR CENSORING VARIABLE 13259C 13260 IF(NGROUP.EQ.0 .AND. NCENS.EQ.0)THEN 13261 ISET=1 13262 CALL DPTRE3(Y,N,XTEMP1,TEND,MAXNXT, 13263 1 RATPVA,MHTPVA,DSUM1,DVAL2,DVAL3, 13264 1 ISET,ICAPSW,ICAPTY,IFORSW, 13265 1 ISUBRO,IBUGA3,IERROR) 13266 NUMSET=1 13267C 13268C CASE 2: GROUP VARIABLE, BUT NO CENSORING VARIABLE 13269C 13270 ELSEIF(NCENS.EQ.0)THEN 13271C 13272C STEP 1: DETERMINE UNIQUE GROUPS 13273C 13274 NUMSET=0 13275 DO1051I=1,N 13276 IF(NUMSET.EQ.0)GOTO1053 13277 DO1052J=1,NUMSET 13278 IF(X1(I).EQ.XIDTEM(J))GOTO1051 13279 1052 CONTINUE 13280 1053 CONTINUE 13281 NUMSET=NUMSET+1 13282 XIDTEM(NUMSET)=X1(I) 13283 1051 CONTINUE 13284 CALL SORT(XIDTEM,NUMSET,XIDTEM) 13285C 13286C STEP 2: GENERATE TRACES FOR EACH GROUP 13287C 13288 J=0 13289 DO1090ISET=1,NUMSET 13290C 13291 K=0 13292 DO1091I=1,N 13293 IF(X1(I).EQ.XIDTEM(ISET))THEN 13294 K=K+1 13295 TEMP2(K)=Y(I) 13296 ENDIF 132971091 CONTINUE 13298 NI=K 13299 CALL DPTRE3(TEMP2,NI,XTEMP1,TEND,MAXNXT, 13300 1 RATPVA,MHTPVA,DSUM1,DVAL2,DVAL3, 13301 1 ISET,ICAPSW,ICAPTY,IFORSW, 13302 1 ISUBRO,IBUGA3,IERROR) 13303 TEMP6(ISET)=RATPVA 13304 TEMP6(MAXSYS+ISET)=MHTPVA 13305 TEMP6(2*MAXSYS+ISET)=REAL(DSUM1) 13306 TEMP6(3*MAXSYS+ISET)=REAL(DVAL2) 13307 TEMP6(4*MAXSYS+ISET)=REAL(DVAL3) 133081090 CONTINUE 13309C 13310C CASE 3: BOTH GROUP VARIABLE AND CENSORING VARIABLE 13311C 13312 ELSE 13313C 13314C STEP 1: DETERMINE UNIQUE GROUPS 13315C 13316 NUMSET=0 13317 DO1111I=1,N 13318 IF(NUMSET.EQ.0)GOTO1113 13319 DO1112J=1,NUMSET 13320 IF(X1(I).EQ.XIDTEM(J))GOTO1111 13321 1112 CONTINUE 13322 1113 CONTINUE 13323 NUMSET=NUMSET+1 13324 XIDTEM(NUMSET)=X1(I) 13325 1111 CONTINUE 13326 CALL SORT(XIDTEM,NUMSET,XIDTEM) 13327C 13328C STEP 2A: EXTRACT RESPONSE AND CENSORING DATA FOR EACH 13329C GROUP 13330C 13331 J=0 13332 ISETMX=NUMSET 13333 DO1120ISET=1,NUMSET 13334C 13335 K=0 13336 DO1121I=1,N 13337 IF(X1(I).EQ.XIDTEM(ISET))THEN 13338 K=K+1 13339 TEMP2(K)=Y(I) 13340 TEMP3(K)=XCEN(I) 13341 ENDIF 133421121 CONTINUE 13343 NI=K 13344C 13345C STEP 2B: PROCESS THE CENSORING VARIABLE. THERE CAN 13346C BE AT MOST ONE CENSORING POINT FOR EACH 13347C GROUP. 13348C 13349 CALL SORTC(TEMP2,TEMP3,NI,TEMP4,TEMP5) 13350 DO1160I=1,NI 13351 TEMP2(I)=TEMP4(I) 13352 TEMP3(I)=TEMP5(I) 13353 1160 CONTINUE 13354 AREP=TEMP3(1) 13355 ACEN=TEMP2(NI) 13356 IF(NI.LE.1)THEN 13357 NTEMPR=1 13358 NTEMPC=0 13359 ELSE 13360 IF(AREP.EQ.ACEN)THEN 13361 NTEMPR=NI 13362 NTEMPC=0 13363 DO1170I=1,NI 13364 IF(TEMP3(I).NE.AREP)THEN 13365 WRITE(ICOUT,999) 13366 CALL DPWRST('XXX','BUG ') 13367 WRITE(ICOUT,111) 13368 CALL DPWRST('XXX','BUG ') 13369 WRITE(ICOUT,1171) 13370 CALL DPWRST('XXX','BUG ') 13371 WRITE(ICOUT,1172) 13372 CALL DPWRST('XXX','BUG ') 13373 WRITE(ICOUT,1173) 13374 CALL DPWRST('XXX','BUG ') 13375 WRITE(ICOUT,1174)XIDTEM(ISET) 13376 CALL DPWRST('XXX','BUG ') 13377 IERROR='YES' 13378 GOTO1120 13379 ENDIF 13380 1170 CONTINUE 13381 ELSE 13382 TEND=TEMP2(NI) 13383 NTEMPR=NI-1 13384 NTEMPC=1 13385 DO1180I=1,NTEMPR 13386 IF(TEMP3(I).NE.AREP)THEN 13387 WRITE(ICOUT,999) 13388 CALL DPWRST('XXX','BUG ') 13389 WRITE(ICOUT,111) 13390 CALL DPWRST('XXX','BUG ') 13391 WRITE(ICOUT,1171) 13392 CALL DPWRST('XXX','BUG ') 13393 WRITE(ICOUT,1172) 13394 CALL DPWRST('XXX','BUG ') 13395 WRITE(ICOUT,1173) 13396 CALL DPWRST('XXX','BUG ') 13397 WRITE(ICOUT,1174)XIDTEM(ISET) 13398 CALL DPWRST('XXX','BUG ') 13399 IERROR='YES' 13400 GOTO1120 13401 ENDIF 13402 1180 CONTINUE 13403 ENDIF 13404 ENDIF 13405 1171 FORMAT(' FOR EACH SYSTEM, THERE SHOULD BE AT MOST') 13406 1172 FORMAT(' ONE CENSORING TIME AND IT MUST BE THE MAXIMUM') 13407 1173 FORMAT(' VALUE FOR THAT SYSTEM.') 13408 1174 FORMAT(' SUCH WAS NOT THE CASE FOR SYSTEM ',G15.7) 13409C 13410C STEP 2C: COMPUTE THE TREND TEST FOR A SINGLE SYSTEM 13411C 13412 TEND=ACEN 13413 CALL DPTRE3(TEMP2,NTEMPR,XTEMP1,TEND,MAXNXT, 13414 1 RATPVA,MHTPVA,DSUM1,DVAL2,DVAL3, 13415 1 ISET,ICAPSW,ICAPTY,IFORSW, 13416 1 ISUBRO,IBUGA3,IERROR) 13417 TEMP6(ISET)=RATPVA 13418 TEMP6(MAXSYS+ISET)=MHTPVA 13419 TEMP6(2*MAXSYS+ISET)=REAL(DSUM1) 13420 TEMP6(3*MAXSYS+ISET)=REAL(DVAL2) 13421 TEMP6(4*MAXSYS+ISET)=REAL(DVAL3) 13422C 134231120 CONTINUE 13424 ENDIF 13425C 13426C ******************************************** 13427C ** STEP 21-- ** 13428C ** PERFORM COMPOSITE TESTS ** 13429C ******************************************** 13430C 13431 ISTEPN='21' 13432 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TRE2') 13433 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 13434C 13435 IF(NUMSET.LE.1)GOTO9000 13436C 13437C COMPOSITE TESTS 13438C 13439C PRINT SUMMARY STATISTICS TABLE 13440C 13441 IF(IPRINT.EQ.'OFF')GOTO9000 13442C 13443 NUMDIG=7 13444 IF(IFORSW.EQ.'1')NUMDIG=1 13445 IF(IFORSW.EQ.'2')NUMDIG=2 13446 IF(IFORSW.EQ.'3')NUMDIG=3 13447 IF(IFORSW.EQ.'4')NUMDIG=4 13448 IF(IFORSW.EQ.'5')NUMDIG=5 13449 IF(IFORSW.EQ.'6')NUMDIG=6 13450 IF(IFORSW.EQ.'7')NUMDIG=7 13451 IF(IFORSW.EQ.'8')NUMDIG=8 13452 IF(IFORSW.EQ.'9')NUMDIG=9 13453 IF(IFORSW.EQ.'0')NUMDIG=0 13454 IF(IFORSW.EQ.'E')NUMDIG=-2 13455 IF(IFORSW.EQ.'-2')NUMDIG=-2 13456 IF(IFORSW.EQ.'-3')NUMDIG=-3 13457 IF(IFORSW.EQ.'-4')NUMDIG=-4 13458 IF(IFORSW.EQ.'-5')NUMDIG=-5 13459 IF(IFORSW.EQ.'-6')NUMDIG=-6 13460 IF(IFORSW.EQ.'-7')NUMDIG=-7 13461 IF(IFORSW.EQ.'-8')NUMDIG=-8 13462 IF(IFORSW.EQ.'-9')NUMDIG=-9 13463C 13464 IDF=2 13465 ISUM=0 13466 SUM1=0.0 13467 SUM2=0.0 13468 DO2010I=1,NUMSET 13469 PVAL=TEMP6(I) 13470 ATERM1=-2.0*LOG(PVAL) 13471 SUM1=SUM1 + PVAL 13472 SUM2=SUM2 + ATERM1 13473 ISUM=ISUM+IDF 13474 2010 CONTINUE 13475C 13476 ALP90=0.90 13477 CALL CHSPPF(ALP90,ISUM,CV1) 13478 ALP95=0.95 13479 CALL CHSPPF(ALP95,ISUM,CV2) 13480 ALP99=0.99 13481 CALL CHSPPF(ALP99,ISUM,CV3) 13482C 13483 ITITLE='Reverse Arrangements Test: Fisher Composite Test' 13484 NCTITL=48 13485 ITITLZ=' ' 13486 NCTITZ=0 13487C 13488 ICNT=0 13489 ICNT=ICNT+1 13490 ITEXT(ICNT)='Summary Statistics:' 13491 NCTEXT(ICNT)=19 13492 AVALUE(ICNT)=0.0 13493 IDIGIT(ICNT)=-1 13494 ICNT=ICNT+1 13495 ITEXT(ICNT)='Number of Systems:' 13496 NCTEXT(ICNT)=18 13497 AVALUE(ICNT)=REAL(NUMSET) 13498 IDIGIT(ICNT)=0 13499 ICNT=ICNT+1 13500 ITEXT(ICNT)='Sum of -2*LN(p-value):' 13501 NCTEXT(ICNT)=22 13502 AVALUE(ICNT)=SUM2 13503 IDIGIT(ICNT)=NUMDIG 13504 ICNT=ICNT+1 13505 ITEXT(ICNT)='Total Degrees of Freedom:' 13506 NCTEXT(ICNT)=25 13507 AVALUE(ICNT)=REAL(ISUM) 13508 IDIGIT(ICNT)=0 13509 ICNT=ICNT+1 13510 ITEXT(ICNT)=' ' 13511 NCTEXT(ICNT)=0 13512 AVALUE(ICNT)=0.0 13513 IDIGIT(ICNT)=-1 13514C 13515 ICNT=ICNT+1 13516 ITEXT(ICNT)='H0: No Trend for Interarrival Times' 13517 NCTEXT(ICNT)=35 13518 AVALUE(ICNT)=0.0 13519 IDIGIT(ICNT)=-1 13520 ICNT=ICNT+1 13521 ITEXT(ICNT)='Ha: There is a Trend for Interarrival Times' 13522 NCTEXT(ICNT)=43 13523 AVALUE(ICNT)=0.0 13524 IDIGIT(ICNT)=-1 13525C 13526 NUMROW=ICNT 13527 DO2020I=1,NUMROW 13528 NTOT(I)=15 13529 2020 CONTINUE 13530C 13531 IFRST=.TRUE. 13532 ILAST=.TRUE. 13533 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT, 13534 1 AVALUE,IDIGIT, 13535 1 NTOT,NUMROW, 13536 1 ICAPSW,ICAPTY,ILAST,IFRST, 13537 1 ISUBRO,IBUGA3,IERROR) 13538C 13539 ITITLE(1:25)=' ' 13540 NCTITL=0 13541 ITITL9=' ' 13542 NCTIT9=0 13543C 13544 DO2030J=1,5 13545 DO2040I=1,3 13546 ITITL2(I,J)=' ' 13547 NCTIT2(I,J)=0 13548 2040 CONTINUE 13549 2030 CONTINUE 13550C 13551 ITITL2(2,1)='Null' 13552 NCTIT2(2,1)=4 13553 ITITL2(3,1)='Hypothesis' 13554 NCTIT2(3,1)=10 13555C 13556 ITITL2(2,2)='Significance' 13557 NCTIT2(2,2)=12 13558 ITITL2(3,2)='Level' 13559 NCTIT2(3,2)=5 13560C 13561 ITITL2(2,3)='Chi-Square' 13562 NCTIT2(2,3)=10 13563 ITITL2(3,3)='Test Statistic' 13564 NCTIT2(3,3)=14 13565C 13566 ITITL2(2,4)='Critical' 13567 NCTIT2(2,4)=8 13568 ITITL2(3,4)='Region (>=)' 13569 NCTIT2(3,4)=11 13570C 13571 ITITL2(1,5)='Null' 13572 NCTIT2(1,5)=4 13573 ITITL2(2,5)='Hypothesis' 13574 NCTIT2(2,5)=10 13575 ITITL2(3,5)='Conclusion' 13576 NCTIT2(3,5)=10 13577C 13578 NMAX=0 13579 NUMCOL=5 13580 DO2050I=1,NUMCOL 13581 VALIGN(I)='b' 13582 ALIGN(I)='r' 13583 NTOT(I)=15 13584 IF(I.EQ.1)NTOT(I)=10 13585 NMAX=NMAX+NTOT(I) 13586 ITYPCO(I)='NUME' 13587 IDIGIT(I)=NUMDIG 13588 IF(I.EQ.1 .OR. I.EQ.2 .OR. I.EQ.5)THEN 13589 ITYPCO(I)='ALPH' 13590 ENDIF 13591 IWHTML(1)=150 13592 IWHTML(2)=125 13593 IWHTML(3)=150 13594 IWHTML(4)=150 13595 IWHTML(5)=150 13596 IINC=1600 13597 IINC2=1400 13598 IINC3=2200 13599 IWRTF(1)=IINC 13600 IWRTF(2)=IWRTF(1)+IINC 13601 IWRTF(3)=IWRTF(2)+IINC2 13602 IWRTF(4)=IWRTF(3)+IINC 13603 IWRTF(5)=IWRTF(4)+IINC 13604C 13605 DO2060J=1,3 13606 IVALUE(J,1)='No Trend' 13607 NCVALU(J,1)=8 13608 IF(J.EQ.1)THEN 13609 IVALUE(J,2)='0.90' 13610 NCVALU(J,2)=4 13611 AMAT(J,3)=SUM2 13612 AMAT(J,4)=CV1 13613 IF(SUM2.GT.CV1)THEN 13614 IVALUE(J,5)(1:6)='REJECT' 13615 ELSE 13616 IVALUE(J,5)(1:6)='ACCEPT' 13617 ENDIF 13618 NCVALU(J,5)=6 13619 ELSEIF(J.EQ.2)THEN 13620 IVALUE(J,2)='0.95' 13621 NCVALU(J,2)=4 13622 AMAT(J,3)=SUM2 13623 AMAT(J,4)=CV2 13624 IF(SUM2.GT.CV2)THEN 13625 IVALUE(J,5)(1:6)='REJECT' 13626 ELSE 13627 IVALUE(J,5)(1:6)='ACCEPT' 13628 ENDIF 13629 NCVALU(J,5)=6 13630 ELSEIF(J.EQ.3)THEN 13631 IVALUE(J,2)='0.99' 13632 NCVALU(J,2)=4 13633 AMAT(J,3)=SUM2 13634 AMAT(J,4)=CV3 13635 IF(SUM2.GT.CV3)THEN 13636 IVALUE(J,5)(1:6)='REJECT' 13637 ELSE 13638 IVALUE(J,5)(1:6)='ACCEPT' 13639 ENDIF 13640 NCVALU(J,5)=6 13641 ENDIF 13642 2060 CONTINUE 13643C 13644 2050 CONTINUE 13645C 13646 ICNT=3 13647 NUMLIN=3 13648 NUMCOL=5 13649 IFRST=.TRUE. 13650 ILAST=.TRUE. 13651 IFLAGS=.TRUE. 13652 IFLAGE=.TRUE. 13653 CALL DPDTA5(ITITLE,NCTITL, 13654 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 13655 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 13656 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 13657 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 13658 1 ICAPSW,ICAPTY,IFRST,ILAST, 13659 1 IFLAGS,IFLAGE, 13660 1 ISUBRO,IBUGA3,IERROR) 13661C 13662C COMPOSITE TEST FOR MILITARY HANDBOOK TEST 13663C 13664 IDF=2 13665 ISUM=0 13666 SUM1=0.0 13667 SUM2=0.0 13668 DO3010I=1,NUMSET 13669 PVAL=TEMP6(MAXSYS+I) 13670 ATERM1=-2.0*LOG(PVAL) 13671 SUM1=SUM1 + PVAL 13672 SUM2=SUM2 + ATERM1 13673 ISUM=ISUM+IDF 13674 3010 CONTINUE 13675C 13676 ALP90=0.90 13677 CALL CHSPPF(ALP90,ISUM,CV1) 13678 ALP95=0.95 13679 CALL CHSPPF(ALP95,ISUM,CV2) 13680 ALP99=0.99 13681 CALL CHSPPF(ALP99,ISUM,CV3) 13682C 13683 ITITLE='Military Handbook Test: Fisher Composite Test' 13684 NCTITL=45 13685 ITITLZ=' ' 13686 NCTITZ=0 13687C 13688 ICNT=0 13689 ICNT=ICNT+1 13690 ITEXT(ICNT)='Summary Statistics:' 13691 NCTEXT(ICNT)=19 13692 AVALUE(ICNT)=0.0 13693 IDIGIT(ICNT)=-1 13694 ICNT=ICNT+1 13695 ITEXT(ICNT)='Number of Systems:' 13696 NCTEXT(ICNT)=18 13697 AVALUE(ICNT)=REAL(NUMSET) 13698 IDIGIT(ICNT)=0 13699 ICNT=ICNT+1 13700 ITEXT(ICNT)='Sum of -2*LN(p-value):' 13701 NCTEXT(ICNT)=22 13702 AVALUE(ICNT)=SUM2 13703 IDIGIT(ICNT)=NUMDIG 13704 ICNT=ICNT+1 13705 ITEXT(ICNT)='Total Degrees of Freedom:' 13706 NCTEXT(ICNT)=25 13707 AVALUE(ICNT)=REAL(ISUM) 13708 IDIGIT(ICNT)=0 13709 ICNT=ICNT+1 13710 ITEXT(ICNT)=' ' 13711 NCTEXT(ICNT)=0 13712 AVALUE(ICNT)=0.0 13713 IDIGIT(ICNT)=-1 13714C 13715 ICNT=ICNT+1 13716 ITEXT(ICNT)='H0: No Trend for Interarrival Times' 13717 NCTEXT(ICNT)=35 13718 AVALUE(ICNT)=0.0 13719 IDIGIT(ICNT)=-1 13720 ICNT=ICNT+1 13721 ITEXT(ICNT)='Ha: There is a Trend for Interarrival Times' 13722 NCTEXT(ICNT)=43 13723 AVALUE(ICNT)=0.0 13724 IDIGIT(ICNT)=-1 13725 ICNT=ICNT+1 13726 ITEXT(ICNT)='Ha: There is a Trend Following a NHPP' 13727 NCTEXT(ICNT)=37 13728 AVALUE(ICNT)=0.0 13729 IDIGIT(ICNT)=-1 13730 ICNT=ICNT+1 13731 ITEXT(ICNT)=' Power Law Model' 13732 NCTEXT(ICNT)=19 13733 AVALUE(ICNT)=0.0 13734 IDIGIT(ICNT)=-1 13735C 13736 NUMROW=ICNT 13737 DO3020I=1,NUMROW 13738 NTOT(I)=15 13739 3020 CONTINUE 13740C 13741 IFRST=.TRUE. 13742 ILAST=.TRUE. 13743 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT, 13744 1 NCTEXT,AVALUE,IDIGIT, 13745 1 NTOT,NUMROW, 13746 1 ICAPSW,ICAPTY,ILAST,IFRST, 13747 1 ISUBRO,IBUGA3,IERROR) 13748C 13749 ITITLE(1:25)=' ' 13750 NCTITL=0 13751 ITITL9=' ' 13752 NCTIT9=0 13753C 13754 NMAX=0 13755 NUMCOL=5 13756 DO3050I=1,NUMCOL 13757 VALIGN(I)='b' 13758 ALIGN(I)='r' 13759 NTOT(I)=15 13760 IF(I.EQ.1)NTOT(I)=10 13761 NMAX=NMAX+NTOT(I) 13762 ITYPCO(I)='NUME' 13763 IDIGIT(I)=NUMDIG 13764 IF(I.EQ.1 .OR. I.EQ.2 .OR. I.EQ.5)THEN 13765 ITYPCO(I)='ALPH' 13766 ENDIF 13767C 13768 DO3060J=1,3 13769 IF(J.EQ.1)THEN 13770 AMAT(J,3)=SUM2 13771 AMAT(J,4)=CV1 13772 IF(SUM2.GT.CV1)THEN 13773 IVALUE(J,5)(1:6)='REJECT' 13774 ELSE 13775 IVALUE(J,5)(1:6)='ACCEPT' 13776 ENDIF 13777 NCVALU(J,5)=6 13778 ELSEIF(J.EQ.2)THEN 13779 AMAT(J,3)=SUM2 13780 AMAT(J,4)=CV2 13781 IF(SUM2.GT.CV2)THEN 13782 IVALUE(J,5)(1:6)='REJECT' 13783 ELSE 13784 IVALUE(J,5)(1:6)='ACCEPT' 13785 ENDIF 13786 NCVALU(J,5)=6 13787 ELSEIF(J.EQ.3)THEN 13788 AMAT(J,3)=SUM2 13789 AMAT(J,4)=CV3 13790 IF(SUM2.GT.CV3)THEN 13791 IVALUE(J,5)(1:6)='REJECT' 13792 ELSE 13793 IVALUE(J,5)(1:6)='ACCEPT' 13794 ENDIF 13795 NCVALU(J,5)=6 13796 ENDIF 13797 3060 CONTINUE 13798C 13799 3050 CONTINUE 13800C 13801 ICNT=3 13802 IFRST=.TRUE. 13803 ILAST=.TRUE. 13804 IFLAGS=.TRUE. 13805 IFLAGE=.TRUE. 13806 CALL DPDTA5(ITITLE,NCTITL, 13807 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 13808 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 13809 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 13810 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 13811 1 ICAPSW,ICAPTY,IFRST,ILAST, 13812 1 IFLAGS,IFLAGE, 13813 1 ISUBRO,IBUGA3,IERROR) 13814C 13815C LAPLACE COMPOSITE TEST 13816C 13817 DSUM1=0.0D0 13818 DSUM2=0.0D0 13819 DSUM3=0.0D0 13820 DO4010I=1,NUMSET 13821 VAL1=TEMP6(2*MAXSYS+I) 13822 VAL2=TEMP6(3*MAXSYS+I) 13823 VAL3=TEMP6(4*MAXSYS+I) 13824 DSUM1=DSUM1 + DBLE(VAL1) 13825 DSUM2=DSUM2 + DBLE(VAL2) 13826 DSUM3=DSUM3 + DBLE(VAL3) 13827 4010 CONTINUE 13828 DSUM2=-0.5D0*DSUM2 13829 Z=REAL((DSUM1 + DSUM2)/DSQRT(DSUM3/12.0D0)) 13830 CALL NORCDF(Z,CDF) 13831 ALP01=0.01 13832 CALL NORPPF(ALP01,CV1) 13833 ALP05=0.05 13834 CALL NORPPF(ALP05,CV2) 13835 ALP10=0.10 13836 CALL NORPPF(ALP10,CV3) 13837 ALP90=0.90 13838 CALL NORPPF(ALP90,CV4) 13839 ALP95=0.95 13840 CALL NORPPF(ALP95,CV5) 13841 ALP99=0.99 13842 CALL NORPPF(ALP99,CV6) 13843C 13844 ITITLE='Laplace Test: Composite Test' 13845 NCTITL=28 13846 ITITLZ=' ' 13847 NCTITZ=0 13848C 13849 ICNT=0 13850 ICNT=ICNT+1 13851 ITEXT(ICNT)='Summary Statistics:' 13852 NCTEXT(ICNT)=19 13853 AVALUE(ICNT)=0.0 13854 IDIGIT(ICNT)=-1 13855 ICNT=ICNT+1 13856 ITEXT(ICNT)='Normal Test Statistic Value:' 13857 NCTEXT(ICNT)=28 13858 AVALUE(ICNT)=Z 13859 IDIGIT(ICNT)=NUMDIG 13860 ICNT=ICNT+1 13861 ITEXT(ICNT)='Normal Test Statistic CDF Value:' 13862 NCTEXT(ICNT)=32 13863 AVALUE(ICNT)=CDF 13864 IDIGIT(ICNT)=NUMDIG 13865 ICNT=ICNT+1 13866 ITEXT(ICNT)=' ' 13867 NCTEXT(ICNT)=0 13868 AVALUE(ICNT)=0.0 13869 IDIGIT(ICNT)=-1 13870C 13871 ICNT=ICNT+1 13872 ITEXT(ICNT)='H0: No Trend for Interarrival Times' 13873 NCTEXT(ICNT)=35 13874 AVALUE(ICNT)=0.0 13875 IDIGIT(ICNT)=-1 13876 ICNT=ICNT+1 13877 ITEXT(ICNT)='Ha: There is a Trend Following a NHPP' 13878 NCTEXT(ICNT)=37 13879 AVALUE(ICNT)=0.0 13880 IDIGIT(ICNT)=-1 13881 ICNT=ICNT+1 13882 ITEXT(ICNT)=' Exponential Law Model' 13883 NCTEXT(ICNT)=25 13884 AVALUE(ICNT)=0.0 13885 IDIGIT(ICNT)=-1 13886C 13887 NUMROW=ICNT 13888 DO2310I=1,NUMROW 13889 NTOT(I)=15 13890 2310 CONTINUE 13891C 13892 IFRST=.TRUE. 13893 ILAST=.TRUE. 13894 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT, 13895 1 NCTEXT,AVALUE,IDIGIT, 13896 1 NTOT,NUMROW, 13897 1 ICAPSW,ICAPTY,ILAST,IFRST, 13898 1 ISUBRO,IBUGA3,IERROR) 13899C 13900 ITITLE(1:25)=' ' 13901 NCTITL=0 13902 ITITL9=' ' 13903 NCTIT9=0 13904C 13905 ITITL2(2,3)='Normal' 13906 NCTIT2(2,3)=6 13907 ITITL2(3,3)='Test Statistic' 13908 NCTIT2(3,3)=14 13909C 13910 ITITL2(2,4)='Critical' 13911 NCTIT2(2,4)=8 13912 ITITL2(3,4)='Region (>=)' 13913 NCTIT2(3,4)=11 13914C 13915 NMAX=0 13916 DO4050I=1,NUMCOL 13917 VALIGN(I)='b' 13918 ALIGN(I)='r' 13919 NTOT(I)=15 13920 IF(I.EQ.1)NTOT(I)=10 13921 NMAX=NMAX+NTOT(I) 13922 ITYPCO(I)='NUME' 13923 IDIGIT(I)=NUMDIG 13924 IF(I.EQ.1 .OR. I.EQ.2 .OR. I.EQ.5)THEN 13925 ITYPCO(I)='ALPH' 13926 ENDIF 13927C 13928 DO4060J=1,3 13929 IF(J.EQ.1)THEN 13930 IVALUE(J,2)='0.01' 13931 NCVALU(J,2)=4 13932 AMAT(J,3)=Z 13933 AMAT(J,4)=CV1 13934 IF(Z.LE.CV1)THEN 13935 IVALUE(J,5)(1:6)='REJECT' 13936 ELSE 13937 IVALUE(J,5)(1:6)='ACCEPT' 13938 ENDIF 13939 NCVALU(J,5)=6 13940 ELSEIF(J.EQ.2)THEN 13941 IVALUE(J,2)='0.05' 13942 NCVALU(J,2)=4 13943 AMAT(J,3)=Z 13944 AMAT(J,4)=CV2 13945 IF(Z.LE.CV2)THEN 13946 IVALUE(J,5)(1:6)='REJECT' 13947 ELSE 13948 IVALUE(J,5)(1:6)='ACCEPT' 13949 ENDIF 13950 NCVALU(J,5)=6 13951 ELSEIF(J.EQ.3)THEN 13952 IVALUE(J,2)='0.10' 13953 NCVALU(J,2)=4 13954 AMAT(J,3)=Z 13955 AMAT(J,4)=CV3 13956 IF(Z.LE.CV3)THEN 13957 IVALUE(J,5)(1:6)='REJECT' 13958 ELSE 13959 IVALUE(J,5)(1:6)='ACCEPT' 13960 ENDIF 13961 NCVALU(J,5)=6 13962 ENDIF 13963 4060 CONTINUE 13964C 13965 4050 CONTINUE 13966C 13967 ICNT=3 13968 CALL DPDTA5(ITITLE,NCTITL, 13969 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 13970 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 13971 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 13972 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 13973 1 ICAPSW,ICAPTY,IFRST,ILAST, 13974 1 IFLAGS,IFLAGE, 13975 1 ISUBRO,IBUGA3,IERROR) 13976C 13977 ITITLE(1:25)=' ' 13978 NCTITL=0 13979 ITITL9=' ' 13980 NCTIT9=0 13981C 13982 ITITL2(2,4)='Critical' 13983 NCTIT2(2,4)=8 13984 ITITL2(3,4)='Region (<=)' 13985 NCTIT2(3,4)=11 13986C 13987 DO4150I=1,NUMCOL 13988 NTOT(I)=15 13989 IF(I.EQ.1)NTOT(I)=10 13990C 13991 DO4160J=1,3 13992 IF(J.EQ.1)THEN 13993 IVALUE(J,2)='0.90' 13994 NCVALU(J,2)=4 13995 AMAT(J,3)=Z 13996 AMAT(J,4)=CV4 13997 IF(Z.GE.CV4)THEN 13998 IVALUE(J,5)(1:6)='REJECT' 13999 ELSE 14000 IVALUE(J,5)(1:6)='ACCEPT' 14001 ENDIF 14002 NCVALU(J,5)=6 14003 ELSEIF(J.EQ.2)THEN 14004 IVALUE(J,2)='0.95' 14005 NCVALU(J,2)=4 14006 AMAT(J,3)=Z 14007 AMAT(J,4)=CV5 14008 IF(Z.GE.CV5)THEN 14009 IVALUE(J,5)(1:6)='REJECT' 14010 ELSE 14011 IVALUE(J,5)(1:6)='ACCEPT' 14012 ENDIF 14013 NCVALU(J,5)=6 14014 ELSEIF(J.EQ.3)THEN 14015 IVALUE(J,2)='0.99' 14016 NCVALU(J,2)=4 14017 AMAT(J,3)=Z 14018 AMAT(J,4)=CV6 14019 IF(Z.GE.CV6)THEN 14020 IVALUE(J,5)(1:6)='REJECT' 14021 ELSE 14022 IVALUE(J,5)(1:6)='ACCEPT' 14023 ENDIF 14024 NCVALU(J,5)=6 14025 ENDIF 14026 4160 CONTINUE 14027C 14028 4150 CONTINUE 14029C 14030 ICNT=3 14031 CALL DPDTA5(ITITLE,NCTITL, 14032 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 14033 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 14034 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 14035 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 14036 1 ICAPSW,ICAPTY,IFRST,ILAST, 14037 1 IFLAGS,IFLAGE, 14038 1 ISUBRO,IBUGA3,IERROR) 14039C 14040C ***************** 14041C ** STEP 90-- ** 14042C ** EXIT ** 14043C ***************** 14044C 14045 9000 CONTINUE 14046 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TRE2')THEN 14047 WRITE(ICOUT,999) 14048 CALL DPWRST('XXX','BUG ') 14049 WRITE(ICOUT,9011) 14050 9011 FORMAT('***** AT THE END OF DPTRE2--') 14051 CALL DPWRST('XXX','BUG ') 14052 WRITE(ICOUT,9012)N,IBUGA3,IERROR 14053 9012 FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4) 14054 CALL DPWRST('XXX','BUG ') 14055 DO9016I=1,N 14056 WRITE(ICOUT,9017)I,Y(I) 14057 9017 FORMAT('I,Y(I),W(I) = ',I8,E15.7) 14058 CALL DPWRST('XXX','BUG ') 14059 9016 CONTINUE 14060 ENDIF 14061C 14062 RETURN 14063 END 14064 SUBROUTINE DPTRE3(Y,N,XTEMP1,TEND,MAXNXT, 14065 1 RATPVA,MHTPVA,DSUM1,DVAL2,DVAL3, 14066 1 ISET,ICAPSW,ICAPTY,IFORSW, 14067 1 ISUBRO,IBUGA3,IERROR) 14068C 14069C PURPOSE--THIS ROUTINE CARRIES OUT A TRENDS ANALYSIS 14070C FOR THE DATA IN THE INPUT VECTOR Y. 14071C NOTE--DPTRE2 CAN LOOP THROUGH MULTIPLE SYSTEMS. 14072C THIS ROUTINE IS USED TO COMPUTE THE TESTS FOR 14073C A SINGLE SYSTEM. 14074C NOTE--3 TRENDS TESTS ARE PERFORMED: 14075C 1) REVERSE ARRANGEMENT TEST 14076C 2) MILITARY HANDBOOK TEST 14077C 3) LAPLACE TEST 14078C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR 14079C OF FAILURE TIMES 14080C N = THE INTEGER NUMBER OF 14081C OBSERVATIONS IN THE VECTOR Y. 14082C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. 14083C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 14084C LANGUAGE--ANSI 77 FORTRAN. 14085C WRITTEN BY--ALAN HECKERT 14086C STATISTICAL ENGINEERING DIVISION 14087C INFORMATION TECHNOLOGY LABORATORY 14088C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 14089C GAITHERSBURG, MD 20899-8980 14090C PHONE--301-975-2899 14091C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 14092C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 14093C LANGUAGE--ANSI FORTRAN (1977) 14094C VERSION NUMBER--2006/10 14095C ORIGINAL VERSION--OCTOBER 2006. EXTRACTED FROM DPTRE3 14096C UPDATED --FEBRUARY 2011. USE DPDTA1 AND DPDTA5 TO 14097C PRINT TABLES 14098C 14099C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 14100C 14101 CHARACTER*4 ICAPSW 14102 CHARACTER*4 ICAPTY 14103 CHARACTER*4 IFORSW 14104C 14105 CHARACTER*4 ISUBRO 14106 CHARACTER*4 IBUGA3 14107 CHARACTER*4 IERROR 14108C 14109 CHARACTER*4 IWRITE 14110 CHARACTER*4 ISUBN1 14111 CHARACTER*4 ISUBN2 14112 CHARACTER*4 ISTEPN 14113C 14114C--------------------------------------------------------------------- 14115C 14116 DOUBLE PRECISION DSUM 14117 DOUBLE PRECISION DSUM1 14118 DOUBLE PRECISION DVAL2 14119 DOUBLE PRECISION DVAL3 14120C 14121 REAL MHTPVA 14122C 14123 DIMENSION Y(*) 14124 DIMENSION XTEMP1(*) 14125C 14126 PARAMETER (NUMALP=3) 14127 PARAMETER(NUMCLI=5) 14128 PARAMETER(MAXLIN=3) 14129 PARAMETER (MAXROW=NUMALP) 14130 PARAMETER (MAXRO2=25) 14131 CHARACTER*60 ITITLE 14132 CHARACTER*60 ITITLZ 14133 CHARACTER*60 ITITL9 14134 CHARACTER*60 ITEXT(MAXRO2) 14135 CHARACTER*4 ALIGN(NUMCLI) 14136 CHARACTER*4 VALIGN(NUMCLI) 14137 REAL AVALUE(MAXRO2) 14138 INTEGER NCTEXT(MAXRO2) 14139 INTEGER IDIGIT(MAXRO2) 14140 INTEGER NTOT(MAXRO2) 14141 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 14142 CHARACTER*15 IVALUE(MAXROW,NUMCLI) 14143 CHARACTER*4 ITYPCO(NUMCLI) 14144 INTEGER NCTIT2(MAXLIN,NUMCLI) 14145 INTEGER NCVALU(MAXROW,NUMCLI) 14146 INTEGER IWHTML(NUMCLI) 14147 INTEGER IWRTF(NUMCLI) 14148 REAL AMAT(MAXROW,NUMCLI) 14149 LOGICAL IFRST 14150 LOGICAL ILAST 14151 LOGICAL IFLAGS 14152 LOGICAL IFLAGE 14153C 14154C-----COMMON---------------------------------------------------------- 14155C 14156 INCLUDE 'DPCOP2.INC' 14157C 14158C-----START POINT----------------------------------------------------- 14159C 14160 ISUBN1='DPTR' 14161 ISUBN2='E3 ' 14162 IERROR='NO' 14163C 14164 IRMN01=0 14165 IRMN05=0 14166 IRMN10=0 14167 IRMN90=0 14168 IRMN95=0 14169 IRMN99=0 14170C 14171 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TRE3')THEN 14172 WRITE(ICOUT,999) 14173 999 FORMAT(1X) 14174 CALL DPWRST('XXX','BUG ') 14175 WRITE(ICOUT,51) 14176 51 FORMAT('**** AT THE BEGINNING OF DPTRE3--') 14177 CALL DPWRST('XXX','BUG ') 14178 WRITE(ICOUT,52)N,MAXNXT,IBUGA3 14179 52 FORMAT('N,MAXNXT,IBUGA3 = ',2I8,2X,A4) 14180 CALL DPWRST('XXX','BUG ') 14181 DO56I=1,N 14182 WRITE(ICOUT,57)I,Y(I) 14183 57 FORMAT('I,Y(I) = ',I8,G15.7) 14184 CALL DPWRST('XXX','BUG ') 14185 56 CONTINUE 14186 ENDIF 14187C 14188C ******************************************** 14189C ** STEP 1-- ** 14190C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 14191C ******************************************** 14192C 14193 ISTEPN='1' 14194 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TRE3') 14195 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14196C 14197 IF(N.LT.4)THEN 14198 WRITE(ICOUT,999) 14199 CALL DPWRST('XXX','BUG ') 14200 WRITE(ICOUT,111)ISET 14201 111 FORMAT('***** ERROR IN RELIABILITY TREND TEST--SYSTEM ',I8) 14202 CALL DPWRST('XXX','BUG ') 14203 WRITE(ICOUT,113) 14204 113 FORMAT(' THE NUMBER OF OBSERVATONS IS LESS THAN 4.') 14205 CALL DPWRST('XXX','BUG ') 14206 WRITE(ICOUT,112)N 14207 112 FORMAT('SAMPLE SIZE = ',I8) 14208 CALL DPWRST('XXX','BUG ') 14209 IERROR='YES' 14210 GOTO9000 14211 ENDIF 14212C 14213 HOLD=Y(1) 14214 DO135I=2,N 14215 IF(Y(I).NE.HOLD)GOTO139 14216 135 CONTINUE 14217 WRITE(ICOUT,999) 14218 CALL DPWRST('XXX','BUG ') 14219 WRITE(ICOUT,111)ISET 14220 CALL DPWRST('XXX','BUG ') 14221 WRITE(ICOUT,131)HOLD 14222 131 FORMAT(' THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7) 14223 CALL DPWRST('XXX','BUG ') 14224 GOTO9000 14225 139 CONTINUE 14226C 14227C ******************************************** 14228C ** STEP 11-- ** 14229C ** REVERSE ARRANGEMENTS TEST ** 14230C ******************************************** 14231C 14232C ******************************************** 14233C ** STEP 11A- ** 14234C ** CREATE INTERARRIVAL TIME ARRAY ** 14235C ******************************************** 14236C 14237 ISTEPN='11' 14238 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TRE3') 14239 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14240C 14241 IWRITE='NO' 14242 CALL INTARR(Y,N,IWRITE,XTEMP1,NX,IBUGA3,IERROR) 14243C 14244C ******************************************** 14245C ** STEP 11B- ** 14246C ** CALCULATE NUMBER OF REVERSALS ** 14247C ******************************************** 14248 IREV=0 14249 DO140J=1,N-1 14250 DO149K=J+1,N 14251 IF(XTEMP1(K).GT.XTEMP1(J))IREV=IREV+1 14252 149 CONTINUE 14253 140 CONTINUE 14254 IRMAX=N*(N-1)/2 14255 AN=REAL(N) 14256 REXP=AN*(AN-1.0)/4.0 14257 RVAR=(2.0*AN + 5.0)*(AN - 1.0)*AN/72.0 14258 RSD=SQRT(RVAR) 14259C 14260 R=REAL(IREV) 14261 ANUM=R + 0.5 - REXP 14262 Z=ANUM/RSD 14263 CALL NORCDF(Z,CDF) 14264 RATPVA=CDF 14265C 14266C ************************* 14267C ** STEP 11C- ** 14268C ** FORM Z STATISTICS ** 14269C ************************* 14270C 14271 ISTEPN='11C' 14272 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TRE3') 14273 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14274C 14275 ALP01=0.01 14276 CALL NORPPF(ALP01,PPF01) 14277 ALP05=0.05 14278 CALL NORPPF(ALP05,PPF05) 14279 ALP10=0.10 14280 CALL NORPPF(ALP10,PPF10) 14281 ALP90=0.90 14282 CALL NORPPF(ALP90,PPF90) 14283 ALP95=0.95 14284 CALL NORPPF(ALP95,PPF95) 14285 ALP99=0.99 14286 CALL NORPPF(ALP99,PPF99) 14287 IF(N.EQ.4)THEN 14288 IRMN01=-1 14289 IRMN05=0 14290 IRMN10=0 14291 IRMN90=6 14292 IRMN95=6 14293 IRMN99=-1 14294 ELSEIF(N.EQ.5)THEN 14295 IRMN01=0 14296 IRMN05=1 14297 IRMN10=1 14298 IRMN90=9 14299 IRMN95=9 14300 IRMN99=10 14301 ELSEIF(N.EQ.6)THEN 14302 IRMN01=1 14303 IRMN05=2 14304 IRMN10=3 14305 IRMN90=12 14306 IRMN95=13 14307 IRMN99=14 14308 ELSEIF(N.EQ.7)THEN 14309 IRMN01=2 14310 IRMN05=4 14311 IRMN10=5 14312 IRMN90=16 14313 IRMN95=17 14314 IRMN99=19 14315 ELSEIF(N.EQ.8)THEN 14316 IRMN01=4 14317 IRMN05=6 14318 IRMN10=8 14319 IRMN90=20 14320 IRMN95=22 14321 IRMN99=24 14322 ELSEIF(N.EQ.9)THEN 14323 IRMN01=6 14324 IRMN05=9 14325 IRMN10=11 14326 IRMN90=25 14327 IRMN95=27 14328 IRMN99=30 14329 ELSEIF(N.EQ.10)THEN 14330 IRMN01=9 14331 IRMN05=12 14332 IRMN10=14 14333 IRMN90=31 14334 IRMN95=33 14335 IRMN99=36 14336 ELSEIF(N.EQ.11)THEN 14337 IRMN01=12 14338 IRMN05=16 14339 IRMN10=18 14340 IRMN90=37 14341 IRMN95=39 14342 IRMN99=43 14343 ELSEIF(N.EQ.12)THEN 14344 IRMN01=16 14345 IRMN05=20 14346 IRMN10=23 14347 IRMN90=43 14348 IRMN95=46 14349 IRMN99=50 14350 ELSEIF(N.GT.12)THEN 14351 IRMN01=INT(PPF01*RSD + REXP - 0.5) 14352 IRMN05=INT(PPF05*RSD + REXP - 0.5) 14353 IRMN10=INT(PPF10*RSD + REXP - 0.5) 14354 IRMN90=INT(PPF90*RSD + REXP - 0.5) 14355 IRMN95=INT(PPF95*RSD + REXP - 0.5) 14356 IRMN99=INT(PPF99*RSD + REXP - 0.5) 14357 ENDIF 14358C 14359C **************************** 14360C ** STEP 11D- ** 14361C ** WRITE EVERYTHING OUT ** 14362C **************************** 14363C 14364 ISTEPN='11D' 14365 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TRE3') 14366 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14367C 14368C PRINT SUMMARY STATISTICS TABLE 14369C 14370 IF(IPRINT.EQ.'OFF')GOTO9000 14371C 14372 NUMDIG=7 14373 IF(IFORSW.EQ.'1')NUMDIG=1 14374 IF(IFORSW.EQ.'2')NUMDIG=2 14375 IF(IFORSW.EQ.'3')NUMDIG=3 14376 IF(IFORSW.EQ.'4')NUMDIG=4 14377 IF(IFORSW.EQ.'5')NUMDIG=5 14378 IF(IFORSW.EQ.'6')NUMDIG=6 14379 IF(IFORSW.EQ.'7')NUMDIG=7 14380 IF(IFORSW.EQ.'8')NUMDIG=8 14381 IF(IFORSW.EQ.'9')NUMDIG=9 14382 IF(IFORSW.EQ.'0')NUMDIG=0 14383 IF(IFORSW.EQ.'E')NUMDIG=-2 14384 IF(IFORSW.EQ.'-2')NUMDIG=-2 14385 IF(IFORSW.EQ.'-3')NUMDIG=-3 14386 IF(IFORSW.EQ.'-4')NUMDIG=-4 14387 IF(IFORSW.EQ.'-5')NUMDIG=-5 14388 IF(IFORSW.EQ.'-6')NUMDIG=-6 14389 IF(IFORSW.EQ.'-7')NUMDIG=-7 14390 IF(IFORSW.EQ.'-8')NUMDIG=-8 14391 IF(IFORSW.EQ.'-9')NUMDIG=-9 14392C 14393 ITITLE='Reverse Arrangements Test: (System )' 14394 NCTITL=41 14395 WRITE(ITITLE(36:40),'(I5)')ISET 14396 ITITLZ=' ' 14397 NCTITZ=0 14398C 14399 ICNT=0 14400 ICNT=ICNT+1 14401 ITEXT(ICNT)='Summary Statistics:' 14402 NCTEXT(ICNT)=19 14403 AVALUE(ICNT)=0.0 14404 IDIGIT(ICNT)=-1 14405 ICNT=ICNT+1 14406 ITEXT(ICNT)='Number of Failure Times:' 14407 NCTEXT(ICNT)=24 14408 AVALUE(ICNT)=REAL(N) 14409 IDIGIT(ICNT)=0 14410 ICNT=ICNT+1 14411 ITEXT(ICNT)='Observed Number of Reversals:' 14412 NCTEXT(ICNT)=29 14413 AVALUE(ICNT)=REAL(IREV) 14414 IDIGIT(ICNT)=0 14415 ICNT=ICNT+1 14416 ITEXT(ICNT)='Maximum Possible Number of Reversals:' 14417 NCTEXT(ICNT)=37 14418 AVALUE(ICNT)=REAL(IRMAX) 14419 IDIGIT(ICNT)=0 14420 ICNT=ICNT+1 14421 ITEXT(ICNT)='Expected Number of Reversals:' 14422 NCTEXT(ICNT)=29 14423 AVALUE(ICNT)=REXP 14424 IDIGIT(ICNT)=NUMDIG 14425 ICNT=ICNT+1 14426 ITEXT(ICNT)='Variance(Expected Number of Reversals):' 14427 NCTEXT(ICNT)=39 14428 AVALUE(ICNT)=RVAR 14429 IDIGIT(ICNT)=NUMDIG 14430 ICNT=ICNT+1 14431 ITEXT(ICNT)='Value of Test Statistic (Z-Score):' 14432 NCTEXT(ICNT)=34 14433 AVALUE(ICNT)=Z 14434 IDIGIT(ICNT)=NUMDIG 14435 ICNT=ICNT+1 14436 ITEXT(ICNT)='Z-Score CDF Value:' 14437 NCTEXT(ICNT)=18 14438 AVALUE(ICNT)=CDF 14439 IDIGIT(ICNT)=NUMDIG 14440 ICNT=ICNT+1 14441 ITEXT(ICNT)=' ' 14442 NCTEXT(ICNT)=0 14443 AVALUE(ICNT)=0.0 14444 IDIGIT(ICNT)=-1 14445C 14446 ICNT=ICNT+1 14447 ITEXT(ICNT)='Improvement Test' 14448 NCTEXT(ICNT)=16 14449 AVALUE(ICNT)=0.0 14450 IDIGIT(ICNT)=-1 14451 ICNT=ICNT+1 14452 ITEXT(ICNT)='H0: No Trend for Interarrival Times' 14453 NCTEXT(ICNT)=35 14454 AVALUE(ICNT)=0.0 14455 IDIGIT(ICNT)=-1 14456 ICNT=ICNT+1 14457 ITEXT(ICNT)='Ha: Increasing Trend for Interarrival Times' 14458 NCTEXT(ICNT)=43 14459 AVALUE(ICNT)=0.0 14460 IDIGIT(ICNT)=-1 14461C 14462 NUMROW=ICNT 14463 DO2310I=1,NUMROW 14464 NTOT(I)=15 14465 2310 CONTINUE 14466C 14467 IFRST=.TRUE. 14468 ILAST=.TRUE. 14469 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT, 14470 1 NCTEXT,AVALUE,IDIGIT, 14471 1 NTOT,NUMROW, 14472 1 ICAPSW,ICAPTY,ILAST,IFRST, 14473 1 ISUBRO,IBUGA3,IERROR) 14474C 14475 ITITLE(1:25)=' ' 14476 NCTITL=0 14477 ITITL9=' ' 14478 NCTIT9=0 14479C 14480 DO2320J=1,5 14481 DO2325I=1,3 14482 ITITL2(I,J)=' ' 14483 NCTIT2(I,J)=0 14484 2325 CONTINUE 14485 2320 CONTINUE 14486C 14487 ITITL2(2,1)='Null' 14488 NCTIT2(2,1)=4 14489 ITITL2(3,1)='Hypothesis' 14490 NCTIT2(3,1)=10 14491C 14492 ITITL2(2,2)='Significance' 14493 NCTIT2(2,2)=12 14494 ITITL2(3,2)='Level' 14495 NCTIT2(3,2)=5 14496C 14497 ITITL2(2,3)='Number of' 14498 NCTIT2(2,3)=9 14499 ITITL2(3,3)='Reversals' 14500 NCTIT2(3,3)=9 14501C 14502 ITITL2(2,4)='Critical' 14503 NCTIT2(2,4)=8 14504 ITITL2(3,4)='Region (>=)' 14505 NCTIT2(3,4)=11 14506C 14507 ITITL2(1,5)='Null' 14508 NCTIT2(1,5)=4 14509 ITITL2(2,5)='Hypothesis' 14510 NCTIT2(2,5)=10 14511 ITITL2(3,5)='Conclusion' 14512 NCTIT2(3,5)=10 14513C 14514 NMAX=0 14515 NUMCOL=5 14516 DO5210I=1,NUMCOL 14517 VALIGN(I)='b' 14518 ALIGN(I)='r' 14519 NTOT(I)=15 14520 IF(I.EQ.1)NTOT(I)=10 14521 NMAX=NMAX+NTOT(I) 14522 ITYPCO(I)='NUME' 14523 IDIGIT(I)=NUMDIG 14524 IF(I.EQ.1 .OR. I.EQ.2 .OR. I.EQ.5)THEN 14525 ITYPCO(I)='ALPH' 14526 ENDIF 14527 IF(I.EQ.3 .OR. I.EQ.4)THEN 14528 IDIGIT(I)=0 14529 ENDIF 14530 IWHTML(1)=150 14531 IWHTML(2)=125 14532 IWHTML(3)=150 14533 IWHTML(4)=150 14534 IWHTML(5)=150 14535 IINC=1600 14536 IINC2=1400 14537 IINC3=2200 14538 IWRTF(1)=IINC 14539 IWRTF(2)=IWRTF(1)+IINC 14540 IWRTF(3)=IWRTF(2)+IINC2 14541 IWRTF(4)=IWRTF(3)+IINC 14542 IWRTF(5)=IWRTF(4)+IINC 14543C 14544 DO5289J=1,3 14545 IVALUE(J,1)='No Trend' 14546 NCVALU(J,1)=8 14547 IF(J.EQ.1)THEN 14548 IVALUE(J,2)='0.90' 14549 NCVALU(J,2)=4 14550 AMAT(J,3)=REAL(IREV) 14551 AMAT(J,4)=REAL(IRMN90) 14552 IF(IREV.GE.IRMN90)THEN 14553 IVALUE(J,5)(1:6)='REJECT' 14554 ELSE 14555 IVALUE(J,5)(1:6)='ACCEPT' 14556 ENDIF 14557 NCVALU(J,5)=6 14558 ELSEIF(J.EQ.2)THEN 14559 IVALUE(J,2)='0.95' 14560 NCVALU(J,2)=4 14561 AMAT(J,3)=REAL(IREV) 14562 AMAT(J,4)=REAL(IRMN95) 14563 IF(IREV.GE.IRMN95)THEN 14564 IVALUE(J,5)(1:6)='REJECT' 14565 ELSE 14566 IVALUE(J,5)(1:6)='ACCEPT' 14567 ENDIF 14568 NCVALU(J,5)=6 14569 ELSEIF(J.EQ.3)THEN 14570 IVALUE(J,2)='0.99' 14571 NCVALU(J,2)=4 14572 AMAT(J,3)=REAL(IREV) 14573 AMAT(J,4)=REAL(IRMN99) 14574 IF(IREV.GE.IRMN99)THEN 14575 IVALUE(J,5)(1:6)='REJECT' 14576 ELSE 14577 IVALUE(J,5)(1:6)='ACCEPT' 14578 ENDIF 14579 NCVALU(J,5)=6 14580 ENDIF 14581 5289 CONTINUE 14582C 14583 5210 CONTINUE 14584C 14585 ICNT=3 14586 NUMLIN=3 14587 NUMCOL=5 14588 IFRST=.TRUE. 14589 ILAST=.TRUE. 14590 IFLAGS=.TRUE. 14591 IFLAGE=.TRUE. 14592 CALL DPDTA5(ITITLE,NCTITL, 14593 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 14594 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 14595 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 14596 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 14597 1 ICAPSW,ICAPTY,IFRST,ILAST, 14598 1 IFLAGS,IFLAGE, 14599 1 ISUBRO,IBUGA3,IERROR) 14600C 14601 ICNT=0 14602 ICNT=ICNT+1 14603 ITEXT(ICNT)=' ' 14604 NCTEXT(ICNT)=0 14605 AVALUE(ICNT)=0.0 14606 IDIGIT(ICNT)=-1 14607 ICNT=ICNT+1 14608 ITEXT(ICNT)='Degradation Test' 14609 NCTEXT(ICNT)=16 14610 AVALUE(ICNT)=0.0 14611 IDIGIT(ICNT)=-1 14612 ICNT=ICNT+1 14613 ITEXT(ICNT)='H0: No Trend for Interarrival Times' 14614 NCTEXT(ICNT)=35 14615 AVALUE(ICNT)=0.0 14616 IDIGIT(ICNT)=-1 14617 ICNT=ICNT+1 14618 ITEXT(ICNT)='Ha: Declining Trend for Interarrival Times' 14619 NCTEXT(ICNT)=42 14620 AVALUE(ICNT)=0.0 14621 IDIGIT(ICNT)=-1 14622C 14623 NUMROW=ICNT 14624 DO6210I=1,NUMROW 14625 NTOT(I)=15 14626 6210 CONTINUE 14627C 14628 IFRST=.TRUE. 14629 ILAST=.TRUE. 14630 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT, 14631 1 NCTEXT,AVALUE,IDIGIT, 14632 1 NTOT,NUMROW, 14633 1 ICAPSW,ICAPTY,ILAST,IFRST, 14634 1 ISUBRO,IBUGA3,IERROR) 14635C 14636 ITITLE(1:25)=' ' 14637 NCTITL=0 14638 ITITL9=' ' 14639 NCTIT9=0 14640C 14641 ITITL2(2,4)='Critical' 14642 NCTIT2(2,4)=8 14643 ITITL2(3,4)='Region (<=)' 14644 NCTIT2(3,4)=11 14645C 14646 DO6310I=1,NUMCOL 14647C 14648 NTOT(I)=15 14649 IF(I.EQ.1)NTOT(I)=10 14650 ITYPCO(I)='NUME' 14651 IDIGIT(I)=NUMDIG 14652 IF(I.EQ.1 .OR. I.EQ.2 .OR. I.EQ.5)THEN 14653 ITYPCO(I)='ALPH' 14654 ENDIF 14655 IF(I.EQ.3 .OR. I.EQ.4)THEN 14656 IDIGIT(I)=0 14657 ENDIF 14658C 14659 DO6389J=1,3 14660 IF(J.EQ.3)THEN 14661 IVALUE(J,2)='0.01' 14662 NCVALU(J,2)=4 14663 AMAT(J,4)=REAL(IRMN01) 14664 IF(IREV.LE.IRMN01)THEN 14665 IVALUE(J,5)(1:6)='REJECT' 14666 ELSE 14667 IVALUE(J,5)(1:6)='ACCEPT' 14668 ENDIF 14669 NCVALU(J,5)=6 14670 ELSEIF(J.EQ.2)THEN 14671 IVALUE(J,2)='0.05' 14672 NCVALU(J,2)=4 14673 AMAT(J,4)=REAL(IRMN05) 14674 IF(IREV.LE.IRMN05)THEN 14675 IVALUE(J,5)(1:6)='REJECT' 14676 ELSE 14677 IVALUE(J,5)(1:6)='ACCEPT' 14678 ENDIF 14679 NCVALU(J,5)=6 14680 ELSEIF(J.EQ.1)THEN 14681 IVALUE(J,2)='0.10' 14682 NCVALU(J,2)=4 14683 AMAT(J,4)=REAL(IRMN10) 14684 IF(IREV.LE.IRMN10)THEN 14685 IVALUE(J,5)(1:6)='REJECT' 14686 ELSE 14687 IVALUE(J,5)(1:6)='ACCEPT' 14688 ENDIF 14689 NCVALU(J,5)=6 14690 ENDIF 14691 6389 CONTINUE 14692C 14693 6310 CONTINUE 14694C 14695 ICNT=3 14696 CALL DPDTA5(ITITLE,NCTITL, 14697 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 14698 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 14699 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 14700 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 14701 1 ICAPSW,ICAPTY,IFRST,ILAST, 14702 1 IFLAGS,IFLAGE, 14703 1 ISUBRO,IBUGA3,IERROR) 14704C 14705C ******************************************** 14706C ** STEP 21-- ** 14707C ** MILITARY HANDBOOK TEST ** 14708C ******************************************** 14709C 14710 ISTEPN='21' 14711 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TRE3') 14712 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14713C 14714C ******************************************** 14715C ** STEP 21B- ** 14716C ** CALCULATE TEST STATISTIC ** 14717C ******************************************** 14718C 14719 DSUM=0.0D0 14720 DO310I=1,N 14721 IF(Y(I).GE.TEND)THEN 14722 WRITE(ICOUT,311) 14723 311 FORMAT('***** ERROR FROM MILITARY HANDBOOK TEST--') 14724 CALL DPWRST('XXX','BUG ') 14725 WRITE(ICOUT,312)ISET 14726 312 FORMAT(' FOR SYSTEM ',I8) 14727 CALL DPWRST('XXX','BUG ') 14728 WRITE(ICOUT,313)TEND 14729 313 FORMAT(' THE SPECIFIED CENSORING TIME,',G15.7,',') 14730 CALL DPWRST('XXX','BUG ') 14731 WRITE(ICOUT,314) 14732 314 FORMAT(' IS LESS THAN AT LEAST ONE FAILURE TIME.') 14733 CALL DPWRST('XXX','BUG ') 14734 WRITE(ICOUT,316)I,Y(I) 14735 316 FORMAT(' FAILURE TIME ',I8,' = ',G15.7) 14736 CALL DPWRST('XXX','BUG ') 14737 IERROR='YES' 14738 GOTO9000 14739 ELSEIF(Y(I).LE.0.0)THEN 14740 WRITE(ICOUT,311) 14741 CALL DPWRST('XXX','BUG ') 14742 WRITE(ICOUT,317)I 14743 317 FORMAT(' FAILURE ',I8,' IS NON-POSITIVE. ') 14744 CALL DPWRST('XXX','BUG ') 14745 WRITE(ICOUT,318)Y(I) 14746 318 FORMAT(' IT HAS THE VALUE ',G15.7) 14747 CALL DPWRST('XXX','BUG ') 14748 IERROR='YES' 14749 GOTO9000 14750 ENDIF 14751 DSUM=DSUM + DLOG(DBLE(TEND/Y(I))) 14752 310 CONTINUE 14753 Z=REAL(2.0D0*DSUM) 14754 INU=2*N 14755 CALL CHSCDF(Z,INU,CDF) 14756 MHTPVA=CDF 14757C 14758 ALP01=0.01 14759 CALL CHSPPF(ALP01,INU,CV1) 14760 ALP05=0.05 14761 CALL CHSPPF(ALP05,INU,CV2) 14762 ALP10=0.10 14763 CALL CHSPPF(ALP10,INU,CV3) 14764 ALP90=0.90 14765 CALL CHSPPF(ALP90,INU,CV4) 14766 ALP95=0.95 14767 CALL CHSPPF(ALP95,INU,CV5) 14768 ALP99=0.99 14769 CALL CHSPPF(ALP99,INU,CV6) 14770C 14771C **************************** 14772C ** STEP 21B- ** 14773C ** WRITE EVERYTHING OUT ** 14774C **************************** 14775C 14776 ISTEPN='21B' 14777 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14778C 14779 ITITLE='Military Handbook Test: (System )' 14780 NCTITL=38 14781 WRITE(ITITLE(33:37),'(I5)')ISET 14782 ITITLZ=' ' 14783 NCTITZ=0 14784C 14785 ICNT=0 14786 ICNT=ICNT+1 14787 ITEXT(ICNT)='Summary Statistics:' 14788 NCTEXT(ICNT)=19 14789 AVALUE(ICNT)=0.0 14790 IDIGIT(ICNT)=-1 14791 ICNT=ICNT+1 14792 ITEXT(ICNT)='Number of Failure Times:' 14793 NCTEXT(ICNT)=24 14794 AVALUE(ICNT)=REAL(N) 14795 IDIGIT(ICNT)=0 14796 ICNT=ICNT+1 14797 ITEXT(ICNT)='Chi-Square Test Statistic Value:' 14798 NCTEXT(ICNT)=32 14799 AVALUE(ICNT)=Z 14800 IDIGIT(ICNT)=NUMDIG 14801 ICNT=ICNT+1 14802 ITEXT(ICNT)='Chi-Square Test Statistic CDF Value:' 14803 NCTEXT(ICNT)=36 14804 AVALUE(ICNT)=CDF 14805 IDIGIT(ICNT)=NUMDIG 14806 ICNT=ICNT+1 14807 ITEXT(ICNT)=' ' 14808 NCTEXT(ICNT)=0 14809 AVALUE(ICNT)=0.0 14810 IDIGIT(ICNT)=-1 14811C 14812 ICNT=ICNT+1 14813 ITEXT(ICNT)='Improvement Test' 14814 NCTEXT(ICNT)=16 14815 AVALUE(ICNT)=0.0 14816 IDIGIT(ICNT)=-1 14817 ICNT=ICNT+1 14818 ITEXT(ICNT)='H0: No Trend for Interarrival Times:' 14819 NCTEXT(ICNT)=36 14820 AVALUE(ICNT)=0.0 14821 IDIGIT(ICNT)=-1 14822 ICNT=ICNT+1 14823 ITEXT(ICNT)='Ha: There is a Trend Following a NHPP' 14824 NCTEXT(ICNT)=37 14825 AVALUE(ICNT)=0.0 14826 IDIGIT(ICNT)=-1 14827 ICNT=ICNT+1 14828 ITEXT(ICNT)=' Power Law Model' 14829 NCTEXT(ICNT)=19 14830 AVALUE(ICNT)=0.0 14831 IDIGIT(ICNT)=-1 14832C 14833 NUMROW=ICNT 14834 DO7310I=1,NUMROW 14835 NTOT(I)=15 14836 7310 CONTINUE 14837C 14838 IFRST=.TRUE. 14839 ILAST=.TRUE. 14840 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT, 14841 1 NCTEXT,AVALUE,IDIGIT, 14842 1 NTOT,NUMROW, 14843 1 ICAPSW,ICAPTY,ILAST,IFRST, 14844 1 ISUBRO,IBUGA3,IERROR) 14845C 14846 ITITLE(1:25)=' ' 14847 NCTITL=0 14848 ITITL9=' ' 14849 NCTIT9=0 14850C 14851 ITITL2(2,3)='Chi-Square' 14852 NCTIT2(2,3)=10 14853 ITITL2(3,3)='Test Statistic' 14854 NCTIT2(3,3)=14 14855C 14856 ITITL2(2,4)='Critical' 14857 NCTIT2(2,4)=8 14858 ITITL2(3,4)='Region (>=)' 14859 NCTIT2(3,4)=11 14860C 14861 DO5310I=1,NUMCOL 14862C 14863 NTOT(I)=15 14864 IF(I.EQ.1)NTOT(I)=10 14865 ITYPCO(I)='NUME' 14866 IDIGIT(I)=NUMDIG 14867 IF(I.EQ.1 .OR. I.EQ.2 .OR. I.EQ.5)THEN 14868 ITYPCO(I)='ALPH' 14869 ENDIF 14870 IF(I.EQ.3 .OR. I.EQ.4)THEN 14871 IDIGIT(I)=NUMDIG 14872 ENDIF 14873C 14874 DO5389J=1,3 14875 IF(J.EQ.1)THEN 14876 IVALUE(J,2)='0.90' 14877 NCVALU(J,2)=4 14878 AMAT(J,3)=Z 14879 AMAT(J,4)=CV4 14880 IF(0.000.LE.CDF.AND.CDF.LE.0.9)THEN 14881 IVALUE(J,5)(1:6)='ACCEPT' 14882 ELSE 14883 IVALUE(J,5)(1:6)='REJECT' 14884 ENDIF 14885 NCVALU(J,5)=6 14886 ELSEIF(J.EQ.2)THEN 14887 IVALUE(J,2)='0.95' 14888 NCVALU(J,2)=4 14889 AMAT(J,3)=Z 14890 AMAT(J,4)=CV5 14891 IF(0.000.LE.CDF.AND.CDF.LE.0.95)THEN 14892 IVALUE(J,5)(1:6)='ACCEPT' 14893 ELSE 14894 IVALUE(J,5)(1:6)='REJECT' 14895 ENDIF 14896 NCVALU(J,5)=6 14897 ELSEIF(J.EQ.3)THEN 14898 IVALUE(J,2)='0.99' 14899 NCVALU(J,2)=4 14900 AMAT(J,3)=Z 14901 AMAT(J,4)=CV6 14902 IF(0.000.LE.CDF.AND.CDF.LE.0.99)THEN 14903 IVALUE(J,5)(1:6)='ACCEPT' 14904 ELSE 14905 IVALUE(J,5)(1:6)='REJECT' 14906 ENDIF 14907 NCVALU(J,5)=6 14908 ENDIF 14909 5389 CONTINUE 14910C 14911 5310 CONTINUE 14912C 14913 ICNT=3 14914 CALL DPDTA5(ITITLE,NCTITL, 14915 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 14916 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 14917 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 14918 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 14919 1 ICAPSW,ICAPTY,IFRST,ILAST, 14920 1 IFLAGS,IFLAGE, 14921 1 ISUBRO,IBUGA3,IERROR) 14922C 14923 ICNT=0 14924 ICNT=ICNT+1 14925 ITEXT(ICNT)=' ' 14926 NCTEXT(ICNT)=0 14927 AVALUE(ICNT)=0.0 14928 IDIGIT(ICNT)=-1 14929 ICNT=ICNT+1 14930 ITEXT(ICNT)='Degradation Test' 14931 NCTEXT(ICNT)=16 14932 AVALUE(ICNT)=0.0 14933 IDIGIT(ICNT)=-1 14934 ICNT=ICNT+1 14935 ITEXT(ICNT)='H0: No Trend for Interarrival Times' 14936 NCTEXT(ICNT)=35 14937 AVALUE(ICNT)=0.0 14938 IDIGIT(ICNT)=-1 14939 ICNT=ICNT+1 14940 ITEXT(ICNT)='Ha: There is a Trend Following a NHPP' 14941 NCTEXT(ICNT)=37 14942 AVALUE(ICNT)=0.0 14943 IDIGIT(ICNT)=-1 14944 ICNT=ICNT+1 14945 ITEXT(ICNT)=' Power Law Model' 14946 NCTEXT(ICNT)=19 14947 AVALUE(ICNT)=0.0 14948 IDIGIT(ICNT)=-1 14949C 14950 NUMROW=ICNT 14951 DO7390I=1,NUMROW 14952 NTOT(I)=15 14953 7390 CONTINUE 14954C 14955 IFRST=.TRUE. 14956 ILAST=.TRUE. 14957 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT, 14958 1 NCTEXT,AVALUE,IDIGIT, 14959 1 NTOT,NUMROW, 14960 1 ICAPSW,ICAPTY,ILAST,IFRST, 14961 1 ISUBRO,IBUGA3,IERROR) 14962C 14963 ITITLE(1:25)=' ' 14964 NCTITL=0 14965 ITITL9=' ' 14966 NCTIT9=0 14967C 14968 ITITL2(2,4)='Critical' 14969 NCTIT2(2,4)=8 14970 ITITL2(3,4)='Region (<=)' 14971 NCTIT2(3,4)=11 14972C 14973 DO7410I=1,NUMCOL 14974C 14975 NTOT(I)=15 14976 IF(I.EQ.1)NTOT(I)=10 14977 ITYPCO(I)='NUME' 14978 IDIGIT(I)=NUMDIG 14979 IF(I.EQ.1 .OR. I.EQ.2 .OR. I.EQ.5)THEN 14980 ITYPCO(I)='ALPH' 14981 ENDIF 14982 IF(I.EQ.3 .OR. I.EQ.4)THEN 14983 IDIGIT(I)=NUMDIG 14984 ENDIF 14985C 14986 DO7489J=1,3 14987 IF(J.EQ.3)THEN 14988 IVALUE(J,2)='0.01' 14989 NCVALU(J,2)=4 14990 AMAT(J,4)=CV1 14991 IF(CDF.GE.0.01)THEN 14992 IVALUE(J,5)(1:6)='ACCEPT' 14993 ELSE 14994 IVALUE(J,5)(1:6)='REJECT' 14995 ENDIF 14996 NCVALU(J,5)=6 14997 ELSEIF(J.EQ.2)THEN 14998 IVALUE(J,2)='0.05' 14999 NCVALU(J,2)=4 15000 AMAT(J,4)=CV2 15001 IF(CDF.GE.0.05)THEN 15002 IVALUE(J,5)(1:6)='ACCEPT' 15003 ELSE 15004 IVALUE(J,5)(1:6)='REJECT' 15005 ENDIF 15006 NCVALU(J,5)=6 15007 ELSEIF(J.EQ.1)THEN 15008 IVALUE(J,2)='0.10' 15009 NCVALU(J,2)=4 15010 AMAT(J,4)=CV3 15011 IF(CDF.GE.0.10)THEN 15012 IVALUE(J,5)(1:6)='ACCEPT' 15013 ELSE 15014 IVALUE(J,5)(1:6)='REJECT' 15015 ENDIF 15016 NCVALU(J,5)=6 15017 ENDIF 15018 7489 CONTINUE 15019C 15020 7410 CONTINUE 15021C 15022 ICNT=3 15023 CALL DPDTA5(ITITLE,NCTITL, 15024 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 15025 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 15026 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 15027 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 15028 1 ICAPSW,ICAPTY,IFRST,ILAST, 15029 1 IFLAGS,IFLAGE, 15030 1 ISUBRO,IBUGA3,IERROR) 15031C 15032C ******************************************** 15033C ** STEP 31-- ** 15034C ** LAPLACE TEST ** 15035C ******************************************** 15036C 15037 ISTEPN='31' 15038 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TRE3') 15039 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 15040C 15041C ******************************************** 15042C ** STEP 31B- ** 15043C ** CALCULATE TEST STATISTIC ** 15044C ******************************************** 15045C 15046 DSUM=0.0D0 15047 DSUM1=0.0D0 15048 DO510I=1,N 15049 IF(Y(I).GE.TEND)THEN 15050 WRITE(ICOUT,511)TEND 15051 511 FORMAT('***** ERROR FROM LAPLACE TREND TEST--') 15052 CALL DPWRST('XXX','BUG ') 15053 WRITE(ICOUT,512)ISET 15054 512 FORMAT(' FOR SYSTEM ',I8) 15055 CALL DPWRST('XXX','BUG ') 15056 WRITE(ICOUT,513)TEND 15057 513 FORMAT(' THE SPECIFIED CENSORING TIME, ',G15.7) 15058 CALL DPWRST('XXX','BUG ') 15059 WRITE(ICOUT,514) 15060 514 FORMAT(' IS LESS THAN AT LEAST ONE FAILURE TIME.') 15061 CALL DPWRST('XXX','BUG ') 15062 WRITE(ICOUT,516)I,Y(I) 15063 516 FORMAT(' FAILURE TIME ',I8,' = ',G15.7) 15064 CALL DPWRST('XXX','BUG ') 15065 IERROR='YES' 15066 GOTO9000 15067 ENDIF 15068 IF(Y(I).LE.0.0)THEN 15069 WRITE(ICOUT,511)TEND 15070 CALL DPWRST('XXX','BUG ') 15071 WRITE(ICOUT,512)ISET 15072 CALL DPWRST('XXX','BUG ') 15073 WRITE(ICOUT,521)I 15074 521 FORMAT(' FAILURE ',I8,' IS NOT POSITIVE.') 15075 CALL DPWRST('XXX','BUG ') 15076 WRITE(ICOUT,523)Y(I) 15077 523 FORMAT(' IT HAS THE VALUE ',G15.7) 15078 CALL DPWRST('XXX','BUG ') 15079 IERROR='YES' 15080 GOTO9000 15081 ENDIF 15082 DSUM=DSUM + DBLE(Y(I)-TEND/2.0) 15083 DSUM1=DSUM1 + DBLE(Y(I)) 15084 510 CONTINUE 15085 DVAL2=DBLE(N)*DBLE(TEND) 15086 DVAL3=DBLE(N)*DBLE(TEND)**2 15087C 15088 AN=REAL(N) 15089 Z=REAL(DBLE(SQRT(12.0*AN))*DSUM/DBLE(AN*TEND)) 15090 CALL NORCDF(Z,CDF) 15091C 15092 ALP01=0.01 15093 CALL NORPPF(ALP01,CV1) 15094 ALP05=0.05 15095 CALL NORPPF(ALP05,CV2) 15096 ALP10=0.10 15097 CALL NORPPF(ALP10,CV3) 15098 ALP90=0.90 15099 CALL NORPPF(ALP90,CV4) 15100 ALP95=0.95 15101 CALL NORPPF(ALP95,CV5) 15102 ALP99=0.99 15103 CALL NORPPF(ALP99,CV6) 15104C 15105C **************************** 15106C ** STEP 31B- ** 15107C ** WRITE EVERYTHING OUT ** 15108C **************************** 15109C 15110 ISTEPN='31B' 15111 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TRE3') 15112 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 15113C 15114 ITITLE='Laplace Test: (System )' 15115 NCTITL=28 15116 WRITE(ITITLE(23:27),'(I5)')ISET 15117 ITITLZ=' ' 15118 NCTITZ=0 15119C 15120 ICNT=0 15121 ICNT=ICNT+1 15122 ITEXT(ICNT)='Summary Statistics:' 15123 NCTEXT(ICNT)=19 15124 AVALUE(ICNT)=0.0 15125 IDIGIT(ICNT)=-1 15126 ICNT=ICNT+1 15127 ITEXT(ICNT)='Number of Failure Times:' 15128 NCTEXT(ICNT)=24 15129 AVALUE(ICNT)=REAL(N) 15130 IDIGIT(ICNT)=0 15131 ICNT=ICNT+1 15132 ITEXT(ICNT)='Normal Test Statistic Value:' 15133 NCTEXT(ICNT)=28 15134 AVALUE(ICNT)=Z 15135 IDIGIT(ICNT)=NUMDIG 15136 ICNT=ICNT+1 15137 ITEXT(ICNT)='Normal Test Statistic CDF Value:' 15138 NCTEXT(ICNT)=32 15139 AVALUE(ICNT)=CDF 15140 IDIGIT(ICNT)=NUMDIG 15141 ICNT=ICNT+1 15142 ITEXT(ICNT)=' ' 15143 NCTEXT(ICNT)=0 15144 AVALUE(ICNT)=0.0 15145 IDIGIT(ICNT)=-1 15146C 15147 ICNT=ICNT+1 15148 ITEXT(ICNT)='Improvement Test' 15149 NCTEXT(ICNT)=16 15150 AVALUE(ICNT)=0.0 15151 IDIGIT(ICNT)=-1 15152 ICNT=ICNT+1 15153 ITEXT(ICNT)='H0: No Trend for Interarrival Times:' 15154 NCTEXT(ICNT)=36 15155 AVALUE(ICNT)=0.0 15156 IDIGIT(ICNT)=-1 15157 ICNT=ICNT+1 15158 ITEXT(ICNT)='Ha: There is a Trend Following a NHPP' 15159 NCTEXT(ICNT)=37 15160 AVALUE(ICNT)=0.0 15161 IDIGIT(ICNT)=-1 15162 ICNT=ICNT+1 15163 ITEXT(ICNT)=' Exponential Law Model' 15164 NCTEXT(ICNT)=25 15165 AVALUE(ICNT)=0.0 15166 IDIGIT(ICNT)=-1 15167C 15168 NUMROW=ICNT 15169 DO8210I=1,NUMROW 15170 NTOT(I)=15 15171 8210 CONTINUE 15172C 15173 IFRST=.TRUE. 15174 ILAST=.TRUE. 15175 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT, 15176 1 NCTEXT,AVALUE,IDIGIT, 15177 1 NTOT,NUMROW, 15178 1 ICAPSW,ICAPTY,ILAST,IFRST, 15179 1 ISUBRO,IBUGA3,IERROR) 15180C 15181 ITITLE(1:25)=' ' 15182 NCTITL=0 15183 ITITL9=' ' 15184 NCTIT9=0 15185C 15186 ITITL2(2,3)='Normal' 15187 NCTIT2(2,3)=6 15188 ITITL2(3,3)='Test Statistic' 15189 NCTIT2(3,3)=14 15190C 15191 ITITL2(2,4)='Critical' 15192 NCTIT2(2,4)=8 15193 ITITL2(3,4)='Region (>=)' 15194 NCTIT2(3,4)=11 15195C 15196 DO8310I=1,NUMCOL 15197C 15198 NTOT(I)=15 15199 IF(I.EQ.1)NTOT(I)=10 15200 ITYPCO(I)='NUME' 15201 IDIGIT(I)=NUMDIG 15202 IF(I.EQ.1 .OR. I.EQ.2 .OR. I.EQ.5)THEN 15203 ITYPCO(I)='ALPH' 15204 ENDIF 15205 IF(I.EQ.3 .OR. I.EQ.4)THEN 15206 IDIGIT(I)=NUMDIG 15207 ENDIF 15208C 15209 DO8389J=1,3 15210 IF(J.EQ.1)THEN 15211 IVALUE(J,2)='0.90' 15212 NCVALU(J,2)=4 15213 AMAT(J,3)=Z 15214 AMAT(J,4)=CV4 15215 IF(0.000.LE.CDF.AND.CDF.LE.0.9)THEN 15216 IVALUE(J,5)(1:6)='ACCEPT' 15217 ELSE 15218 IVALUE(J,5)(1:6)='REJECT' 15219 ENDIF 15220 NCVALU(J,5)=6 15221 ELSEIF(J.EQ.2)THEN 15222 IVALUE(J,2)='0.95' 15223 NCVALU(J,2)=4 15224 AMAT(J,3)=Z 15225 AMAT(J,4)=CV5 15226 IF(0.000.LE.CDF.AND.CDF.LE.0.95)THEN 15227 IVALUE(J,5)(1:6)='ACCEPT' 15228 ELSE 15229 IVALUE(J,5)(1:6)='REJECT' 15230 ENDIF 15231 NCVALU(J,5)=6 15232 ELSEIF(J.EQ.3)THEN 15233 IVALUE(J,2)='0.99' 15234 NCVALU(J,2)=4 15235 AMAT(J,3)=Z 15236 AMAT(J,4)=CV6 15237 IF(0.000.LE.CDF.AND.CDF.LE.0.99)THEN 15238 IVALUE(J,5)(1:6)='ACCEPT' 15239 ELSE 15240 IVALUE(J,5)(1:6)='REJECT' 15241 ENDIF 15242 NCVALU(J,5)=6 15243 ENDIF 15244 8389 CONTINUE 15245C 15246 8310 CONTINUE 15247C 15248 ICNT=3 15249 CALL DPDTA5(ITITLE,NCTITL, 15250 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 15251 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 15252 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 15253 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 15254 1 ICAPSW,ICAPTY,IFRST,ILAST, 15255 1 IFLAGS,IFLAGE, 15256 1 ISUBRO,IBUGA3,IERROR) 15257C 15258 ICNT=0 15259 ICNT=ICNT+1 15260 ITEXT(ICNT)=' ' 15261 NCTEXT(ICNT)=0 15262 AVALUE(ICNT)=0.0 15263 IDIGIT(ICNT)=-1 15264 ICNT=ICNT+1 15265 ITEXT(ICNT)='Degradation Test' 15266 NCTEXT(ICNT)=16 15267 AVALUE(ICNT)=0.0 15268 IDIGIT(ICNT)=-1 15269 ICNT=ICNT+1 15270 ITEXT(ICNT)='H0: No Trend for Interarrival Times' 15271 NCTEXT(ICNT)=35 15272 AVALUE(ICNT)=0.0 15273 IDIGIT(ICNT)=-1 15274 ICNT=ICNT+1 15275 ITEXT(ICNT)='Ha: There is a Trend Following a NHPP' 15276 NCTEXT(ICNT)=37 15277 AVALUE(ICNT)=0.0 15278 IDIGIT(ICNT)=-1 15279 ICNT=ICNT+1 15280 ITEXT(ICNT)=' Exponential Law Model' 15281 NCTEXT(ICNT)=25 15282 AVALUE(ICNT)=0.0 15283 IDIGIT(ICNT)=-1 15284C 15285 NUMROW=ICNT 15286 DO8390I=1,NUMROW 15287 NTOT(I)=15 15288 8390 CONTINUE 15289C 15290 IFRST=.TRUE. 15291 ILAST=.TRUE. 15292 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT, 15293 1 NCTEXT,AVALUE,IDIGIT, 15294 1 NTOT,NUMROW, 15295 1 ICAPSW,ICAPTY,ILAST,IFRST, 15296 1 ISUBRO,IBUGA3,IERROR) 15297C 15298 ITITLE(1:25)=' ' 15299 NCTITL=0 15300 ITITL9=' ' 15301 NCTIT9=0 15302C 15303 ITITL2(2,4)='Critical' 15304 NCTIT2(2,4)=8 15305 ITITL2(3,4)='Region (<=)' 15306 NCTIT2(3,4)=11 15307C 15308 DO8410I=1,NUMCOL 15309C 15310 NTOT(I)=15 15311 IF(I.EQ.1)NTOT(I)=10 15312 ITYPCO(I)='NUME' 15313 IDIGIT(I)=NUMDIG 15314 IF(I.EQ.1 .OR. I.EQ.2 .OR. I.EQ.5)THEN 15315 ITYPCO(I)='ALPH' 15316 ENDIF 15317 IF(I.EQ.3 .OR. I.EQ.4)THEN 15318 IDIGIT(I)=NUMDIG 15319 ENDIF 15320C 15321 DO8489J=1,3 15322 IF(J.EQ.3)THEN 15323 IVALUE(J,2)='0.01' 15324 NCVALU(J,2)=4 15325 AMAT(J,4)=CV1 15326 IF(CDF.GE.0.01)THEN 15327 IVALUE(J,5)(1:6)='ACCEPT' 15328 ELSE 15329 IVALUE(J,5)(1:6)='REJECT' 15330 ENDIF 15331 NCVALU(J,5)=6 15332 ELSEIF(J.EQ.2)THEN 15333 IVALUE(J,2)='0.05' 15334 NCVALU(J,2)=4 15335 AMAT(J,4)=CV2 15336 IF(CDF.GE.0.05)THEN 15337 IVALUE(J,5)(1:6)='ACCEPT' 15338 ELSE 15339 IVALUE(J,5)(1:6)='REJECT' 15340 ENDIF 15341 NCVALU(J,5)=6 15342 ELSEIF(J.EQ.1)THEN 15343 IVALUE(J,2)='0.10' 15344 NCVALU(J,2)=4 15345 AMAT(J,4)=CV3 15346 IF(CDF.GE.0.10)THEN 15347 IVALUE(J,5)(1:6)='ACCEPT' 15348 ELSE 15349 IVALUE(J,5)(1:6)='REJECT' 15350 ENDIF 15351 NCVALU(J,5)=6 15352 ENDIF 15353 8489 CONTINUE 15354C 15355 8410 CONTINUE 15356C 15357 ICNT=3 15358 CALL DPDTA5(ITITLE,NCTITL, 15359 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 15360 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 15361 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 15362 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 15363 1 ICAPSW,ICAPTY,IFRST,ILAST, 15364 1 IFLAGS,IFLAGE, 15365 1 ISUBRO,IBUGA3,IERROR) 15366C 15367C ***************** 15368C ** STEP 90-- ** 15369C ** EXIT ** 15370C ***************** 15371C 15372 9000 CONTINUE 15373 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TRE3')THEN 15374 WRITE(ICOUT,999) 15375 CALL DPWRST('XXX','BUG ') 15376 WRITE(ICOUT,9011) 15377 9011 FORMAT('***** AT THE END OF DPTRE3--') 15378 CALL DPWRST('XXX','BUG ') 15379 WRITE(ICOUT,9012)N,IBUGA3,IERROR 15380 9012 FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4) 15381 CALL DPWRST('XXX','BUG ') 15382 DO9016I=1,N 15383 WRITE(ICOUT,9017)I,Y(I),XTEMP1(I) 15384 9017 FORMAT('I,Y(I),XTEMP1(I) = ',I8,2G15.7) 15385 CALL DPWRST('XXX','BUG ') 15386 9016 CONTINUE 15387 ENDIF 15388C 15389 RETURN 15390 END 15391 SUBROUTINE DPTRI2(X1,Y1,X2,Y2,X3,Y3, 15392 1IFIG, 15393 1ILINPA,ILINCO,PLINTH, 15394 1AREGBA, 15395 1IREBLI,IREBCO,PREBTH, 15396 1IREFSW,IREFCO, 15397 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 15398 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) 15399C 15400C PURPOSE--DRAW A TRIANGLE 15401C WITH FRONT FACE VERTICES AT (X1,Y1), 15402C (X2,Y2), AND (X3,Y3). 15403C WRITTEN BY--JAMES J. FILLIBEN 15404C STATISTICAL ENGINEERING DIVISION 15405C INFORMATION TECHNOLOGY LABORATORY 15406C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 15407C GAITHERSBURG, MD 20899-8980 15408C PHONE--301-975-2855 15409C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 15410C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 15411C LANGUAGE--ANSI FORTRAN (1977) 15412C VERSION NUMBER--82/7 15413C ORIGINAL VERSION--APRIL 1981. 15414C UPDATED --MAY 1982. 15415C UPDATED --JANUARY 1989. MODIFY CALLS TO DPDRPL (ALAN) 15416C UPDATED --JANUARY 1989. MODIFY CALL TO DPFIRE (ALAN) 15417C 15418C-----NON-COMMON VARIABLES------------------------------------- 15419C 15420 CHARACTER*4 IFIG 15421 CHARACTER*4 IPATT2 15422C 15423 CHARACTER*4 ILINPA 15424 CHARACTER*4 ILINCO 15425C 15426 CHARACTER*4 IREBLI 15427 CHARACTER*4 IREBCO 15428 CHARACTER*4 IREFSW 15429 CHARACTER*4 IREFCO 15430 CHARACTER*4 IREPTY 15431 CHARACTER*4 IREPLI 15432 CHARACTER*4 IREPCO 15433C 15434 CHARACTER*4 IPATT 15435 CHARACTER*4 ICOLF 15436 CHARACTER*4 ICOLP 15437 CHARACTER*4 ICOL 15438 CHARACTER*4 IFLAG 15439C 15440 DIMENSION PX(10) 15441 DIMENSION PY(10) 15442CCCCC DIMENSION PX3(10) 15443CCCCC DIMENSION PY3(10) 15444C 15445 DIMENSION ILINPA(*) 15446 DIMENSION ILINCO(*) 15447 DIMENSION PLINTH(*) 15448C 15449 DIMENSION AREGBA(*) 15450 DIMENSION IREBLI(*) 15451 DIMENSION IREBCO(*) 15452 DIMENSION PREBTH(*) 15453 DIMENSION IREFSW(*) 15454 DIMENSION IREFCO(*) 15455 DIMENSION IREPTY(*) 15456 DIMENSION IREPLI(*) 15457 DIMENSION IREPCO(*) 15458 DIMENSION PREPTH(*) 15459 DIMENSION PREPSP(*) 15460C 15461C-----COMMON---------------------------------------------------------- 15462C 15463 INCLUDE 'DPCOGR.INC' 15464 INCLUDE 'DPCOBE.INC' 15465 INCLUDE 'DPCOP2.INC' 15466C 15467C-----START POINT----------------------------------------------------- 15468C 15469 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TRI2')GOTO90 15470 WRITE(ICOUT,999) 15471 999 FORMAT(1X) 15472 CALL DPWRST('XXX','BUG ') 15473 WRITE(ICOUT,51) 15474 51 FORMAT('***** AT THE BEGINNING OF DPTRI2--') 15475 CALL DPWRST('XXX','BUG ') 15476 WRITE(ICOUT,53)X1,Y1 15477 53 FORMAT('X1,Y1 = ',2E15.7) 15478 CALL DPWRST('XXX','BUG ') 15479 WRITE(ICOUT,54)X2,Y2 15480 54 FORMAT('X2,Y2 = ',2E15.7) 15481 CALL DPWRST('XXX','BUG ') 15482 WRITE(ICOUT,59)IFIG 15483 59 FORMAT('IFIG = ',A4) 15484 CALL DPWRST('XXX','BUG ') 15485 WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1) 15486 61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7) 15487 CALL DPWRST('XXX','BUG ') 15488 WRITE(ICOUT,62)AREGBA(1) 15489 62 FORMAT('AREGBA(1) = ',E15.7) 15490 CALL DPWRST('XXX','BUG ') 15491 WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1) 15492 63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7) 15493 CALL DPWRST('XXX','BUG ') 15494 WRITE(ICOUT,64)IREFSW(1),IREFCO(1) 15495 64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4) 15496 CALL DPWRST('XXX','BUG ') 15497 WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) 15498 65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ', 15499 1A4,2X,A4,2X,A4,2E15.7) 15500 CALL DPWRST('XXX','BUG ') 15501 WRITE(ICOUT,69)PTEXHE,PTEXWI 15502 69 FORMAT('PTEXHE,PTEXWI= ',2E15.7) 15503 CALL DPWRST('XXX','BUG ') 15504 WRITE(ICOUT,70)PTEXVG,PTEXHG 15505 70 FORMAT('PTEXVG,PTEXHG= ',2E15.6) 15506 CALL DPWRST('XXX','BUG ') 15507 WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4 15508 79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 15509 CALL DPWRST('XXX','BUG ') 15510 90 CONTINUE 15511C 15512C ********************************* 15513C ** STEP 1-- ** 15514C ** DETERMINE THE COORDINATES ** 15515C ** FOR THE TRIANGLE ** 15516C ********************************* 15517C 15518 PX(1)=X1 15519 PY(1)=Y1 15520C 15521 PX(2)=X2 15522 PY(2)=Y2 15523C 15524 PX(3)=X3 15525 PY(3)=Y3 15526C 15527 PX(4)=X1 15528 PY(4)=Y1 15529C 15530 NP=4 15531C 15532C 15533C *********************** 15534C ** STEP 2-- ** 15535C ** FILL THE FIGURE ** 15536C ** (IF CALLED FOR) ** 15537C *********************** 15538C 15539 IF(IREFSW(1).EQ.'OFF')GOTO2190 15540 IPATT=IREPTY(1) 15541 IPATT2='SOLI' 15542 PTHICK=PREPTH(1) 15543 PXGAP=PREPSP(1) 15544 PYGAP=PREPSP(1) 15545 ICOLF=IREFCO(1) 15546 ICOLP=IREPCO(1) 15547 CALL DPFIRE(PX,PY,NP, 15548 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2) 15549 2190 CONTINUE 15550C 15551C *************************** 15552C ** STEP 3-- ** 15553C ** DRAW OUT THE FIGURE ** 15554C *************************** 15555C 15556 IPATT=ILINPA(1) 15557 PTHICK=PLINTH(1) 15558 ICOL=ILINCO(1) 15559 IFLAG='ON' 15560CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3, 15561CCCCC1IFIG,IPATT,PTHICK,ICOL) 15562 CALL DPDRPL(PX,PY,NP, 15563 1IFIG,IPATT,PTHICK,ICOL, 15564 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 15565C 15566C ***************** 15567C ** STEP 90-- ** 15568C ** EXIT ** 15569C ***************** 15570C 15571 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TRI2')GOTO9090 15572 WRITE(ICOUT,999) 15573 CALL DPWRST('XXX','BUG ') 15574 WRITE(ICOUT,9011) 15575 9011 FORMAT('***** AT THE END OF DPTRI2--') 15576 CALL DPWRST('XXX','BUG ') 15577 WRITE(ICOUT,9013)NP 15578 9013 FORMAT('NP = ',I8) 15579 CALL DPWRST('XXX','BUG ') 15580 DO9015I=1,NP 15581 WRITE(ICOUT,9016)I,PX(I),PY(I) 15582 9016 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7) 15583 CALL DPWRST('XXX','BUG ') 15584 9015 CONTINUE 15585 WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4 15586 9039 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 15587 CALL DPWRST('XXX','BUG ') 15588 9090 CONTINUE 15589C 15590 RETURN 15591 END 15592 SUBROUTINE DPTRIA(IHARG,IARGT,ARG,NUMARG, 15593 1 PXSTAR,PYSTAR,PXEND,PYEND, 15594 1 ILINPA,ILINCO,PLINTH, 15595 1 AREGBA,IREBLI,IREBCO,PREBTH, 15596 1 IREFSW,IREFCO, 15597 1 IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 15598 1 PTEXHE,PTEXWI,PTEXVG,PTEXHG, 15599 1 IGRASW,IDIASW, 15600 1 PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 15601 1 PDIAHE,PDIAWI,PDIAVG,PDIAHG, 15602 1 NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3, 15603 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 15604 1 IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL, 15605 1 IBUGD2,IFOUND,IERROR) 15606C 15607C PURPOSE--DRAW ONE OR MORE TRIANGLES 15608C (DEPENDING ON HOW MANY NUMBERS ARE PROVIDED). 15609C THE COORDINATES ARE IN STANDARDIZED UNITS 15610C OF 0 TO 100. 15611C NOTE--THE INPUT COORDINATES DEFINE THE VERTICES 15612C OF THE TRIANGLE. 15613C NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 3 15614C AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*3 = 6. 15615C NOTE--IF 4 NUMBERS ARE PROVIDED, 15616C THEN THE DRAWN TRIANGLE WILL GO 15617C FROM THE LAST CURSOR POSITION 15618C (ASSUMED TO BE AT VERTEX 1) 15619C THROUGH THE (X,Y) POINT 15620C (EITHER ABSOLUTE OR RELATIVE) 15621C AS DEFINED BY THE FIRST AND SECOND NUMBERS 15622C (ASSUMED TO BE AT VERTEX 2) 15623C TO THE (X,Y) POINT 15624C (EITHER ABSOLUTE OR RELATIVE) 15625C AS DEFINED BY THE THIRD AND FOURTH NUMBERS 15626C (ASSUMED TO BE AT VERTEX 3) 15627C AND CONTINUING BACK THE START POINT TO CLOSE THE TRIANGLE. 15628C NOTE--IF 6 NUMBERS ARE PROVIDED, 15629C THEN THE DRAWN TRIANGLE WILL GO 15630C FROM THE ABSOLUTE (X,Y) POSITION 15631C AS RESULTING FORM THE FIRST AND SECOND NUMBERS 15632C (ASSUMED TO BE AT VERTEX 1) 15633C THROUGH THE (X,Y) POINT 15634C (EITHER ABSOLUTE OR RELATIVE) 15635C AS DEFINED BY THE THIRD AND FOURTH NUMBERS 15636C (ASSUMED TO BE AT VERTEX 2) 15637C TO THE (X,Y) POINT 15638C (EITHER ABSOLUTE OR RELATIVE) 15639C AS DEFINED BY THE FIFTH AND SIXTH NUMBERS 15640C (ASSUMED TO BE AT VERTEX 3) 15641C AND THEN CONTINUING BACK THE START POINT TO CLOSE THE TRIANGLE. 15642C NOTE--AND SO FORTH FOR 10, 14, 18, ... NUMBERS. 15643C INPUT ARGUMENTS--IHARG 15644C --IARGT 15645C --ARG 15646C --NUMARG 15647C --PXSTAR 15648C --PYSTAR 15649C OUTPUT ARGUMENTS--PXEND 15650C --PYEND 15651C --IFOUND ('YES' OR 'NO' ) 15652C --IERROR ('YES' OR 'NO' ) 15653C WRITTEN BY--JAMES J. FILLIBEN 15654C STATISTICAL ENGINEERING DIVISION 15655C INFORMATION TECHNOLOGY LABORATORY 15656C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 15657C GAITHERSBURG, MD 20899-8980 15658C PHONE--301-975-2855 15659C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 15660C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 15661C LANGUAGE--ANSI FORTRAN (1977) 15662C VERSION NUMBER--82/7 15663C ORIGINAL VERSION--APRIL 1981. 15664C UPDATED --MARCH 1982. 15665C UPDATED --MAY 1982. 15666C UPDATED --NOVEMBER 1982. 15667C UPDATED --JANUARY 1989. CALL LIST FOR OFFSET VAR (ALAN) 15668C UPDATED --MARCH 1997. SUPPORT FOR DEVICE FONT (ALAN) 15669C UPDATED --JULY 1997. SUPPORT FOR "DATA" UNITS (ALAN) 15670C UPDATED --DECEMBER 2018. SUPPORT FOR "DEVICE ... SCALE" 15671C COMMAND 15672C 15673C-----NON-COMMON VARIABLES----------------------------------------- 15674C 15675 CHARACTER*4 IHARG 15676 CHARACTER*4 IARGT 15677C 15678 CHARACTER*4 ILINPA 15679 CHARACTER*4 ILINCO 15680C 15681 CHARACTER*4 IREBLI 15682 CHARACTER*4 IREBCO 15683 CHARACTER*4 IREFSW 15684 CHARACTER*4 IREFCO 15685 CHARACTER*4 IREPTY 15686 CHARACTER*4 IREPLI 15687 CHARACTER*4 IREPCO 15688C 15689 CHARACTER*4 IGRASW 15690 CHARACTER*4 IDIASW 15691C 15692 CHARACTER*4 IDMANU 15693 CHARACTER*4 IDMODE 15694 CHARACTER*4 IDMOD2 15695 CHARACTER*4 IDMOD3 15696 CHARACTER*4 IDPOWE 15697 CHARACTER*4 IDCONT 15698 CHARACTER*4 IDCOLO 15699CCCCC ADD FOLLOWING LINE MARCH 1997. 15700 CHARACTER*4 IDFONT 15701CCCCC ADD FOLLOWING LINE JULY 1997. 15702 CHARACTER*4 UNITSW 15703C 15704 CHARACTER*4 IFOUND 15705 CHARACTER*4 IBUGD2 15706 CHARACTER*4 IERROR 15707 CHARACTER*4 ISUBRO 15708C 15709 CHARACTER*4 IFIG 15710 CHARACTER*4 IBELSW 15711 CHARACTER*4 IERASW 15712 CHARACTER*4 IBACCO 15713 CHARACTER*4 ICOPSW 15714 CHARACTER*4 ITYPEO 15715C 15716 DIMENSION IHARG(*) 15717 DIMENSION IARGT(*) 15718 DIMENSION ARG(*) 15719C 15720 DIMENSION ILINPA(*) 15721 DIMENSION ILINCO(*) 15722 DIMENSION PLINTH(*) 15723C 15724 DIMENSION AREGBA(*) 15725 DIMENSION IREBLI(*) 15726 DIMENSION IREBCO(*) 15727 DIMENSION PREBTH(*) 15728 DIMENSION IREFSW(*) 15729 DIMENSION IREFCO(*) 15730 DIMENSION IREPTY(*) 15731 DIMENSION IREPLI(*) 15732 DIMENSION IREPCO(*) 15733 DIMENSION PREPTH(*) 15734 DIMENSION PREPSP(*) 15735 DIMENSION PDSCAL(*) 15736C 15737 DIMENSION IDMANU(*) 15738 DIMENSION IDMODE(*) 15739 DIMENSION IDMOD2(*) 15740 DIMENSION IDMOD3(*) 15741 DIMENSION IDPOWE(*) 15742 DIMENSION IDCONT(*) 15743 DIMENSION IDCOLO(*) 15744CCCCC ADD FOLLOWING LINE MARCH 1997. 15745 DIMENSION IDFONT(*) 15746 DIMENSION IDNVPP(*) 15747 DIMENSION IDNHPP(*) 15748 DIMENSION IDUNIT(*) 15749C 15750 DIMENSION IDNVOF(*) 15751 DIMENSION IDNHOF(*) 15752C 15753C-----COMMON---------------------------------------------------------- 15754C 15755 INCLUDE 'DPCOGR.INC' 15756 INCLUDE 'DPCOBE.INC' 15757 INCLUDE 'DPCOP2.INC' 15758C 15759C-----START POINT----------------------------------------------------- 15760C 15761 IFOUND='NO' 15762 IERROR='NO' 15763 IERRG4=IERROR 15764CCCCC IBUGG4=IBUGD2 15765CCCCC ISUBG4=ISUBRO 15766C 15767 ILOCFN=0 15768 NUMNUM=0 15769C 15770 X1=0.0 15771 Y1=0.0 15772 X2=0.0 15773 Y2=0.0 15774C 15775 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TRIA')GOTO90 15776 WRITE(ICOUT,999) 15777 999 FORMAT(1X) 15778 CALL DPWRST('XXX','BUG ') 15779 WRITE(ICOUT,51) 15780 51 FORMAT('***** AT THE BEGINNING OF DPTRIA--') 15781 CALL DPWRST('XXX','BUG ') 15782 WRITE(ICOUT,53)NUMARG 15783 53 FORMAT('NUMARG = ',I8) 15784 CALL DPWRST('XXX','BUG ') 15785 DO55I=1,NUMARG 15786 WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I) 15787 56 FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2X,A4,2X,A4,E15.7) 15788 CALL DPWRST('XXX','BUG ') 15789 55 CONTINUE 15790 WRITE(ICOUT,57)PXSTAR,PYSTAR 15791 57 FORMAT('PXSTAR,PYSTAR = ',2E15.7) 15792 CALL DPWRST('XXX','BUG ') 15793 WRITE(ICOUT,58)PXEND,PYEND 15794 58 FORMAT('PXEND,PYEND = ',2E15.7) 15795 CALL DPWRST('XXX','BUG ') 15796 WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1) 15797 61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7) 15798 CALL DPWRST('XXX','BUG ') 15799 WRITE(ICOUT,62)AREGBA(1) 15800 62 FORMAT('AREGBA(1) = ',E15.7) 15801 CALL DPWRST('XXX','BUG ') 15802 WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1) 15803 63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7) 15804 CALL DPWRST('XXX','BUG ') 15805 WRITE(ICOUT,64)IREFSW(1),IREFCO(1) 15806 64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4) 15807 CALL DPWRST('XXX','BUG ') 15808 WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) 15809 65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ', 15810 1A4,2X,A4,2X,A4,2E15.7) 15811 CALL DPWRST('XXX','BUG ') 15812 WRITE(ICOUT,69)PTEXHE,PTEXWI 15813 69 FORMAT('PTEXHE,PTEXWI= ',2E15.7) 15814 CALL DPWRST('XXX','BUG ') 15815 WRITE(ICOUT,70)PTEXVG,PTEXHG 15816 70 FORMAT('PTEXVG,PTEXHG= ',2E15.6) 15817 CALL DPWRST('XXX','BUG ') 15818 WRITE(ICOUT,76)IGRASW,IDIASW 15819 76 FORMAT('IGRASW,IDIASW = ',A4,2X,A4) 15820 CALL DPWRST('XXX','BUG ') 15821 WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC 15822 77 FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4E15.7) 15823 CALL DPWRST('XXX','BUG ') 15824 WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG 15825 78 FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4E15.7) 15826 CALL DPWRST('XXX','BUG ') 15827 WRITE(ICOUT,80)NUMDEV 15828 80 FORMAT('NUMDEV= ',I8) 15829 CALL DPWRST('XXX','BUG ') 15830 DO81I=1,NUMDEV 15831 WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) 15832 82 FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ', 15833 1A4,2X,A4,2X,A4,2X,A4) 15834 CALL DPWRST('XXX','BUG ') 15835 WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I) 15836 83 FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ', 15837 1A4,2X,A4,2X,A4) 15838 CALL DPWRST('XXX','BUG ') 15839 WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I) 15840 84 FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ', 15841 1I8,I8,I8) 15842 CALL DPWRST('XXX','BUG ') 15843 81 CONTINUE 15844 WRITE(ICOUT,87)IFOUND 15845 87 FORMAT('IFOUND= ',A4) 15846 CALL DPWRST('XXX','BUG ') 15847 WRITE(ICOUT,88)IBUGG4,ISUBG4,IERRG4 15848 88 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 15849 CALL DPWRST('XXX','BUG ') 15850 WRITE(ICOUT,89)IBUGD2,IERROR 15851 89 FORMAT('IBUGD2,IERROR= ',A4,2X,A4) 15852 CALL DPWRST('XXX','BUG ') 15853 90 CONTINUE 15854C 15855 IFIG='TRIA' 15856 NUMPT=3 15857 NUMPT2=2*NUMPT 15858C 15859C ******************************** 15860C ** STEP 0-- ** 15861C ** STEP THROUGH EACH DEVICE ** 15862C ******************************** 15863C 15864 IF(NUMDEV.LE.0)GOTO9000 15865 DO8000IDEVIC=1,NUMDEV 15866C 15867 IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000 15868 IF(IDMANU(IDEVIC).EQ.'OFF')GOTO8000 15869 IF(IDMANU(IDEVIC).EQ.'NULL')GOTO8000 15870 IF(IDMANU(IDEVIC).EQ.'NONE')GOTO8000 15871 IF(IDMANU(IDEVIC).EQ.'DISC')GOTO8000 15872C 15873 IMANUF=IDMANU(IDEVIC) 15874 IMODEL=IDMODE(IDEVIC) 15875 IMODE2=IDMOD2(IDEVIC) 15876 IMODE3=IDMOD3(IDEVIC) 15877 IGCONT=IDCONT(IDEVIC) 15878 IGCOLO=IDCOLO(IDEVIC) 15879 IGFONT=IDFONT(IDEVIC) 15880 NUMVPP=IDNVPP(IDEVIC) 15881 NUMHPP=IDNHPP(IDEVIC) 15882 ANUMVP=NUMVPP 15883 ANUMHP=NUMHPP 15884 IOFFSV=IDNVOF(IDEVIC) 15885 IOFFSH=IDNHOF(IDEVIC) 15886 IGUNIT=IDUNIT(IDEVIC) 15887 PCHSCA=PDSCAL(IDEVIC) 15888C 15889C ************************************ 15890C ** STEP 1-- ** 15891C ** CARRY OUT OPENING OPERATIONS ** 15892C ** ON THE GRAPHICS DEVICES ** 15893C ************************************ 15894C 15895 CALL DPOPDE 15896C 15897 IBELSW='OFF' 15898 NUMRIN=0 15899 IERASW='OFF' 15900 IBACCO='JUNK' 15901C 15902 CALL DPOPPL(IGRASW, 15903 1IBELSW,NUMRIN,IERASW, 15904 1IBACCO) 15905C 15906C ***************************************** 15907C ** STEP 2-- ** 15908C ** SEARCH FOR COMMAND SPECIFICATIONS ** 15909C ***************************************** 15910C 15911 IF(NUMARG.GE.2.AND. 15912 1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB') 15913 1GOTO1111 15914 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND. 15915 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 15916 1GOTO1112 15917 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND. 15918 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 15919 1GOTO1113 15920 GOTO1130 15921C 15922 1111 CONTINUE 15923 ITYPEO='ABSO' 15924 ILOCFN=1 15925 GOTO1119 15926C 15927 1112 CONTINUE 15928 ITYPEO='ABSO' 15929 ILOCFN=2 15930 GOTO1119 15931C 15932 1113 CONTINUE 15933 ITYPEO='RELA' 15934 ILOCFN=2 15935 GOTO1119 15936 1119 CONTINUE 15937C 15938 IF(ILOCFN.GT.NUMARG)GOTO1129 15939 DO1120I=ILOCFN,NUMARG 15940 IF(IARGT(I).EQ.'NUMB')GOTO1120 15941 GOTO1129 15942 1120 CONTINUE 15943 IFOUND='YES' 15944 GOTO1149 15945 1129 CONTINUE 15946 GOTO1130 15947C 15948 1130 CONTINUE 15949 IERRG4='YES' 15950 WRITE(ICOUT,1131) 15951 1131 FORMAT('***** ERROR IN DPTRIA--') 15952 CALL DPWRST('XXX','BUG ') 15953 WRITE(ICOUT,1132) 15954 1132 FORMAT(' ILLEGAL FORM FOR DRAW ', 15955 1'COMMAND.') 15956 CALL DPWRST('XXX','BUG ') 15957 WRITE(ICOUT,1134) 15958 1134 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 15959 1'PROPER FORM--') 15960 CALL DPWRST('XXX','BUG ') 15961 WRITE(ICOUT,1135) 15962 1135 FORMAT(' SUPPOSE IT IS DESIRED TO DRAW A TRIANGLE ') 15963 CALL DPWRST('XXX','BUG ') 15964 WRITE(ICOUT,1136) 15965 1136 FORMAT(' WITH VERTICES (20,20), (50,20), (35,40)') 15966 CALL DPWRST('XXX','BUG ') 15967 WRITE(ICOUT,1141) 15968 1141 FORMAT(' THEN ALLOWABLE FORMS ARE--') 15969 CALL DPWRST('XXX','BUG ') 15970 WRITE(ICOUT,1142) 15971 1142 FORMAT(' TRIANGLE 20 20 50 20 35 40') 15972 CALL DPWRST('XXX','BUG ') 15973 WRITE(ICOUT,1143) 15974 1143 FORMAT(' TRIANGLE ABSOLUTE 20 20 50 20 35 40') 15975 CALL DPWRST('XXX','BUG ') 15976 GOTO9000 15977 1149 CONTINUE 15978C 15979C **************************** 15980C ** STEP 3-- ** 15981C ** DRAW OUT THE LINE(S) ** 15982C **************************** 15983C 15984 NUMNUM=NUMARG-ILOCFN+1 15985 IF(NUMNUM.LT.NUMPT2)GOTO1151 15986 GOTO1152 15987C 15988 1151 CONTINUE 15989 J=ILOCFN-1 15990 X1=PXSTAR 15991 Y1=PYSTAR 15992 GOTO1159 15993C 15994 1152 CONTINUE 15995 J=ILOCFN 15996 IF(J.GT.NUMARG)GOTO1190 15997 X1=ARG(J) 15998CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 15999 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,IBUGD2,ISUBRO,IERROR) 16000 J=J+1 16001 IF(J.GT.NUMARG)GOTO1190 16002 Y1=ARG(J) 16003CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 16004 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBRO,IERROR) 16005 GOTO1159 16006 1159 CONTINUE 16007C 16008 1160 CONTINUE 16009 J=J+1 16010 IF(J.GT.NUMARG)GOTO1190 16011 X2=ARG(J) 16012CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 16013 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR) 16014 IF(ITYPEO.EQ.'RELA')X2=X1+X2 16015 J=J+1 16016 IF(J.GT.NUMARG)GOTO1190 16017 Y2=ARG(J) 16018CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 16019 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR) 16020 IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2 16021C 16022 J=J+1 16023 IF(J.GT.NUMARG)GOTO1190 16024 X3=ARG(J) 16025CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 16026 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X3,X3,IBUGD2,ISUBRO,IERROR) 16027 IF(ITYPEO.EQ.'RELA')X3=X2+X3 16028 J=J+1 16029 IF(J.GT.NUMARG)GOTO1190 16030 Y3=ARG(J) 16031CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 16032 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y3,Y3,IBUGD2,ISUBRO,IERROR) 16033 IF(ITYPEO.EQ.'RELA')Y3=Y2+Y3 16034C 16035 CALL DPTRI2(X1,Y1,X2,Y2,X3,Y3, 16036 1IFIG, 16037 1ILINPA,ILINCO,PLINTH, 16038 1AREGBA, 16039 1IREBLI,IREBCO,PREBTH, 16040 1IREFSW,IREFCO, 16041 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 16042 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) 16043C 16044 X1=X3 16045 Y1=Y3 16046C 16047 GOTO1160 16048 1190 CONTINUE 16049C 16050 PXEND=X3 16051 PYEND=Y3 16052C 16053C ************************************ 16054C ** STEP 4-- ** 16055C ** CARRY OUT CLOSING OPERATIONS ** 16056C ** ON THE GRAPHICS DEVICES ** 16057C ************************************ 16058C 16059 ICOPSW='OFF' 16060 NUMCOP=0 16061 CALL DPCLPL(ICOPSW,NUMCOP, 16062 1PGRAXF,PGRAYF, 16063 1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 16064 1PDIAHE,PDIAWI,PDIAVG,PDIAHG) 16065C 16066 CALL DPCLDE 16067C 16068 8000 CONTINUE 16069C 16070C ***************** 16071C ** STEP 90-- ** 16072C ** EXIT ** 16073C ***************** 16074C 16075 9000 CONTINUE 16076 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TRIA')GOTO9090 16077 WRITE(ICOUT,999) 16078 CALL DPWRST('XXX','BUG ') 16079 WRITE(ICOUT,9011) 16080 9011 FORMAT('***** AT THE END OF DPTRIA--') 16081 CALL DPWRST('XXX','BUG ') 16082 WRITE(ICOUT,9012)ILOCFN,NUMNUM 16083 9012 FORMAT('ILOCFN,NUMNUM = ',2I8) 16084 CALL DPWRST('XXX','BUG ') 16085 WRITE(ICOUT,9013)X1,Y1,X2,Y2,X3,Y3 16086 9013 FORMAT('X1,Y1,X2,Y2,X3,Y3 = ',6E15.7) 16087 CALL DPWRST('XXX','BUG ') 16088 WRITE(ICOUT,9015)PXSTAR,PYSTAR 16089 9015 FORMAT('PXSTAR,PYSTAR = ',2E15.7) 16090 CALL DPWRST('XXX','BUG ') 16091 WRITE(ICOUT,9016)PXEND,PYEND 16092 9016 FORMAT('PXEND,PYEND = ',2E15.7) 16093 CALL DPWRST('XXX','BUG ') 16094 WRITE(ICOUT,9017)IFIG 16095 9017 FORMAT('IFIG = ',A4) 16096 CALL DPWRST('XXX','BUG ') 16097 WRITE(ICOUT,9027)IFOUND 16098 9027 FORMAT('IFOUND = ',A4) 16099 CALL DPWRST('XXX','BUG ') 16100 WRITE(ICOUT,9028)IBUGG4,ISUBG4,IERRG4 16101 9028 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4) 16102 CALL DPWRST('XXX','BUG ') 16103 WRITE(ICOUT,9029)IBUGD2,IERROR 16104 9029 FORMAT('IBUGD2,IERROR = ',A4,2X,A4) 16105 CALL DPWRST('XXX','BUG ') 16106 9090 CONTINUE 16107C 16108 RETURN 16109 END 16110 SUBROUTINE DPTRIP(IHARG,NUMARG,IDEFPR,IHMXPR, 16111 1IPREC,IFOUND,IERROR) 16112C 16113C PURPOSE--DEFINE THE PRECISION SWITCH 16114C AS TRIPLE PRECISION. 16115C THIS IN TURN SPECIFIES THAT SUBSEQUENT 16116C CALCULATIONS WILL ALL BE CARRIED OUT 16117C IN TRIPLE PRECISION. 16118C THE SPECIFIED PRECISION SWITCH SPECIFICATION 16119C WILL BE PLACED IN THE HOLLERITH VARIABLE IPREC. 16120C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 16121C --NUMARG (AN INTEGER VARIABLE) 16122C --IDEFPR (A HOLLERITH VARIABLE) 16123C --IHMXPR (A HOLLERITH VARIABLE) 16124C OUTPUT ARGUMENTS--IPREC (A HOLLERITH VARIABLE) 16125C --IFOUND ('YES' OR 'NO' ) 16126C --IERROR ('YES' OR 'NO' ) 16127C WRITTEN BY--JAMES J. FILLIBEN 16128C STATISTICAL ENGINEERING DIVISION 16129C INFORMATION TECHNOLOGY LABORATORY 16130C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 16131C GAITHERSBURG, MD 20899-8980 16132C PHONE--301-975-2855 16133C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16134C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 16135C LANGUAGE--ANSI FORTRAN (1977) 16136C VERSION NUMBER--82/7 16137C ORIGINAL VERSION--NOVEMBER 1980. 16138C UPDATED --SEPTEMBER 1981. 16139C UPDATED --MAY 1982. 16140C 16141C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16142C 16143 CHARACTER*4 IHARG 16144 CHARACTER*4 IDEFPR 16145 CHARACTER*4 IHMXPR 16146 CHARACTER*4 IPREC 16147 CHARACTER*4 IFOUND 16148 CHARACTER*4 IERROR 16149C 16150 CHARACTER*4 IHOLD 16151C 16152C--------------------------------------------------------------------- 16153C 16154 DIMENSION IHARG(*) 16155C 16156C-----COMMON---------------------------------------------------------- 16157C 16158 INCLUDE 'DPCOP2.INC' 16159C 16160C-----START POINT----------------------------------------------------- 16161C 16162 IFOUND='NO' 16163 IERROR='NO' 16164 IFOUND='YES' 16165C 16166 IF(NUMARG.LE.0)GOTO1120 16167 IF(IHARG(NUMARG).EQ.'ON')GOTO1130 16168 IF(IHARG(NUMARG).EQ.'OFF')GOTO1120 16169 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1130 16170 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1120 16171 GOTO1130 16172C 16173 1120 CONTINUE 16174 IHOLD=IDEFPR 16175 GOTO1160 16176C 16177 1130 CONTINUE 16178 IHOLD='TRIP' 16179 GOTO1160 16180C 16181 1160 CONTINUE 16182 IF(IHOLD.EQ.'DOUB'.AND.IHMXPR.EQ.'SING')GOTO1170 16183 IF(IHOLD.EQ.'TRIP'.AND.IHMXPR.EQ.'SING')GOTO1170 16184 IF(IHOLD.EQ.'TRIP'.AND.IHMXPR.EQ.'DOUB')GOTO1170 16185 IF(IHOLD.EQ.'QUAD'.AND.IHMXPR.EQ.'SING')GOTO1170 16186 IF(IHOLD.EQ.'QUAD'.AND.IHMXPR.EQ.'DOUB')GOTO1170 16187 IF(IHOLD.EQ.'QUAD'.AND.IHMXPR.EQ.'TRIP')GOTO1170 16188 GOTO1180 16189C 16190 1170 CONTINUE 16191 IERROR='YES' 16192 WRITE(ICOUT,999) 16193 999 FORMAT(1X) 16194 CALL DPWRST('XXX','BUG ') 16195 WRITE(ICOUT,1172) 16196 1172 FORMAT('***** ERROR IN DPTRIP--') 16197 CALL DPWRST('XXX','BUG ') 16198 WRITE(ICOUT,1173) 16199 1173 FORMAT(' THE DESIRED PRECISION IS HIGHER') 16200 CALL DPWRST('XXX','BUG ') 16201 WRITE(ICOUT,1174) 16202 1174 FORMAT(' THAN PERMITTED ON THIS COMPUTER.') 16203 CALL DPWRST('XXX','BUG ') 16204 WRITE(ICOUT,1175)IHOLD 16205 1175 FORMAT(' DESIRED PRECISION = ',A4) 16206 CALL DPWRST('XXX','BUG ') 16207 WRITE(ICOUT,1176)IHMXPR 16208 1176 FORMAT(' MAXIMUM ALLOWABLE PRECISION = ',A4) 16209 CALL DPWRST('XXX','BUG ') 16210 GOTO1199 16211C 16212 1180 CONTINUE 16213 IPREC=IHOLD 16214C 16215 IF(IFEEDB.EQ.'OFF')GOTO1189 16216 WRITE(ICOUT,999) 16217 CALL DPWRST('XXX','BUG ') 16218 WRITE(ICOUT,1188)IPREC 16219 1188 FORMAT('THE PRECISION SWITCH HAS JUST BEEN SET TO ', 16220 1A4) 16221 CALL DPWRST('XXX','BUG ') 16222 1189 CONTINUE 16223 GOTO1199 16224C 16225 1199 CONTINUE 16226 RETURN 16227 END 16228 SUBROUTINE DPTRPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 16229 1 IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR) 16230C 16231C PURPOSE--GENERATE A TRILINEAR PLOT. 16232C WRITTEN BY--ALAN HECKERT 16233C STATISTICAL ENGINEERING DIVISION 16234C INFORMATION TECHNOLOGY LABORATORY 16235C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 16236C GAITHERSBURG, MD 20899-8980 16237C PHONE--301-975-2899 16238C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16239C OF THE NATIONAL BUREAU OF STANDARDS. 16240C LANGUAGE--ANSI FORTRAN (1977) 16241C VERSION NUMBER--2006/12 16242C ORIGINAL VERSION--DECEMBER 2006. 16243C UPDATED --FEBRUARY 2011. USE DPPARS AND DPPAR3 16244C 16245C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16246C 16247 CHARACTER*4 ICASPL 16248 CHARACTER*4 IAND1 16249 CHARACTER*4 IAND2 16250 CHARACTER*4 IBUGG2 16251 CHARACTER*4 IBUGG3 16252 CHARACTER*4 ISUBRO 16253 CHARACTER*4 IBUGQ 16254 CHARACTER*4 IFOUND 16255 CHARACTER*4 IERROR 16256C 16257 CHARACTER*4 ISUBN1 16258 CHARACTER*4 ISUBN2 16259 CHARACTER*4 ISTEPN 16260 CHARACTER*4 IREPL 16261C 16262 CHARACTER*40 INAME 16263 PARAMETER (MAXSPN=20) 16264 CHARACTER*4 IVARN1(MAXSPN) 16265 CHARACTER*4 IVARN2(MAXSPN) 16266 CHARACTER*4 IVARTY(MAXSPN) 16267 REAL PVAR(MAXSPN) 16268 INTEGER ILIS(MAXSPN) 16269 INTEGER NRIGHT(MAXSPN) 16270 INTEGER ICOLR(MAXSPN) 16271C 16272C--------------------------------------------------------------------- 16273C 16274C-----COMMON---------------------------------------------------------- 16275C 16276 INCLUDE 'DPCOPA.INC' 16277C 16278 DIMENSION Y1(MAXOBV) 16279 DIMENSION Y2(MAXOBV) 16280 DIMENSION Y3(MAXOBV) 16281 DIMENSION GROUP(MAXOBV) 16282 DIMENSION TEMP1(MAXOBV) 16283 DIMENSION TEMP2(MAXOBV) 16284 DIMENSION TEMP3(MAXOBV) 16285 DIMENSION TEMP4(MAXOBV) 16286C 16287 INCLUDE 'DPCOZZ.INC' 16288 EQUIVALENCE (GARBAG(IGARB1),Y1(1)) 16289 EQUIVALENCE (GARBAG(IGARB2),Y2(1)) 16290 EQUIVALENCE (GARBAG(IGARB3),Y3(1)) 16291 EQUIVALENCE (GARBAG(IGARB4),GROUP(1)) 16292 EQUIVALENCE (GARBAG(IGARB5),TEMP1(1)) 16293 EQUIVALENCE (GARBAG(IGARB6),TEMP2(1)) 16294 EQUIVALENCE (GARBAG(IGARB7),TEMP3(1)) 16295 EQUIVALENCE (GARBAG(IGARB8),TEMP4(1)) 16296C 16297C-----COMMON VARIABLES (GENERAL)-------------------------------------- 16298C 16299 INCLUDE 'DPCOHK.INC' 16300 INCLUDE 'DPCODA.INC' 16301 INCLUDE 'DPCOP2.INC' 16302C 16303C-----START POINT----------------------------------------------------- 16304C 16305 IFOUND='NO' 16306 IERROR='NO' 16307 ISUBN1='DPTR' 16308 ISUBN2='PL ' 16309C 16310 MAXCP1=MAXCOL+1 16311 MAXCP2=MAXCOL+2 16312 MAXCP3=MAXCOL+3 16313 MAXCP4=MAXCOL+4 16314 MAXCP5=MAXCOL+5 16315 MAXCP6=MAXCOL+6 16316C 16317C *************************** 16318C ** TREAT THE PLOT CASE ** 16319C *************************** 16320C 16321 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'TRPL')THEN 16322 WRITE(ICOUT,999) 16323 999 FORMAT(1X) 16324 CALL DPWRST('XXX','BUG ') 16325 WRITE(ICOUT,51) 16326 51 FORMAT('***** AT THE BEGINNING OF DPTRPL--') 16327 CALL DPWRST('XXX','BUG ') 16328 WRITE(ICOUT,53)ICASPL,IAND1,IAND2,MAXNPP 16329 53 FORMAT('ICASPL,IAND1,IAND2,MAXNPP = ',3(A4,2X),I8) 16330 CALL DPWRST('XXX','BUG ') 16331 WRITE(ICOUT,54)IBUGG2,IBUGG3,ISUBRO,IBUGQ 16332 54 FORMAT('IBUGG2,IBUGG3,ISUBRO,IBUGQ = ',3(A4,2X),A4) 16333 CALL DPWRST('XXX','BUG ') 16334 WRITE(ICOUT,55)IFOUND,IERROR 16335 55 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 16336 CALL DPWRST('XXX','BUG ') 16337 ENDIF 16338C 16339C ******************************************* 16340C ** STEP 1-- ** 16341C ** SEARCH FOR TRILINEAR PLOT ** 16342C ******************************************* 16343C 16344 ISTEPN='1' 16345 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TRPL') 16346 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16347C 16348 ICASPL='TRPL' 16349 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')THEN 16350 ILASTC=1 16351 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 16352 IFOUND='YES' 16353 IHARG(NUMARG+1)=' ' 16354 IHARG2(NUMARG+1)=' ' 16355 ELSE 16356 ICASPL=' ' 16357 IFOUND='NO' 16358 GOTO9000 16359 ENDIF 16360C 16361C ********************************* 16362C ** STEP 4-- ** 16363C ** EXTRACT THE VARIABLE LIST ** 16364C ********************************* 16365C 16366 ISTEPN='4' 16367 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TRPL') 16368 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16369C 16370 INAME='TRILINEAR PLOT' 16371 MINNA=3 16372 MAXNA=100 16373 MINN2=1 16374 IFLAGE=1 16375 IFLAGM=0 16376 IFLAGP=0 16377 JMIN=1 16378 JMAX=NUMARG 16379 MINNVA=3 16380 MAXNVA=4 16381C 16382 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 16383 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 16384 1 JMIN,JMAX, 16385 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 16386 1 IVARN1,IVARN2,IVARTY,PVAR, 16387 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 16388 1 MINNVA,MAXNVA, 16389 1 IFLAGM,IFLAGP, 16390 1 IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 16391 IF(IERROR.EQ.'YES')GOTO9000 16392C 16393 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TRPL')THEN 16394 WRITE(ICOUT,999) 16395 CALL DPWRST('XXX','BUG ') 16396 WRITE(ICOUT,281) 16397 281 FORMAT('***** AFTER CALL DPPARS--') 16398 CALL DPWRST('XXX','BUG ') 16399 WRITE(ICOUT,282)NQ,NUMVAR 16400 282 FORMAT('NQ,NUMVAR = ',2I8) 16401 CALL DPWRST('XXX','BUG ') 16402 IF(NUMVAR.GT.0)THEN 16403 DO285I=1,NUMVAR 16404 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 16405 1 ICOLR(I),PVAR(I) 16406 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 16407 1 'ICOLR(I),PVAR(I) = ',I8,2X,A4,A4,2X,3I8,G15.7) 16408 CALL DPWRST('XXX','BUG ') 16409 285 CONTINUE 16410 ENDIF 16411 ENDIF 16412C 16413 ICOL=1 16414 CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 16415 1 INAME,IVARN1,IVARN2,IVARTY, 16416 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 16417 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 16418 1 MAXCP4,MAXCP5,MAXCP6, 16419 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 16420 1 Y1,Y2,Y3,GROUP,GROUP,GROUP,GROUP,NS, 16421 1 IBUGG3,ISUBRO,IFOUND,IERROR) 16422C 16423C ***************************************************** 16424C ** STEP 41-- ** 16425C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** 16426C ** VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR ** 16427C ** THE PLOT. ** 16428C ** FORM THE CURVE DESIGNATION VARIABLE D(.) . ** 16429C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** 16430C ** DEFINE THE NUMBER OF PLOT VARIABLES(NPLOTV). ** 16431C ***************************************************** 16432C 16433 ISTEPN='61' 16434 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TRPL') 16435 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16436C 16437 CALL DPTRP2(Y1,Y2,Y3,GROUP,NS, 16438 1 ICASPL,IREPL,MAXN,TEMP1, 16439 1 Y,X,X3D,D,NPLOTP,NPLOTV, 16440 1 IBUGG3,ISUBRO,IERROR) 16441C 16442C ***************** 16443C ** STEP 90-- ** 16444C ** EXIT. ** 16445C ***************** 16446C 16447 9000 CONTINUE 16448 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'TRPL')THEN 16449 WRITE(ICOUT,999) 16450 CALL DPWRST('XXX','BUG ') 16451 WRITE(ICOUT,9011) 16452 9011 FORMAT('***** AT THE END OF DPTRPL--') 16453 CALL DPWRST('XXX','BUG ') 16454 WRITE(ICOUT,9012)IFOUND,IERROR 16455 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 16456 CALL DPWRST('XXX','BUG ') 16457 WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 16458 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 16459 1 I8,I8,I8,2X,A4,2X,A4,2X,A4) 16460 CALL DPWRST('XXX','BUG ') 16461 WRITE(ICOUT,9014)IBUGG2,IBUGG3 16462 9014 FORMAT('IBUGG2,IBUGG3 = ', A4,2X,A4) 16463 CALL DPWRST('XXX','BUG ') 16464 WRITE(ICOUT,9020) 16465 9020 FORMAT('I,Y(.),X(.),D(.),ISUB(.)--') 16466 CALL DPWRST('XXX','BUG ') 16467 DO9021I=1,NPLOTP 16468 WRITE(ICOUT,9022)I,Y(I),X(I),D(I),ISUB(I) 16469 9022 FORMAT(I8,E15.7,E15.7,E15.7,I8) 16470 CALL DPWRST('XXX','BUG ') 16471 9021 CONTINUE 16472 ENDIF 16473C 16474 RETURN 16475 END 16476 SUBROUTINE DPTRP2(Y1,Y2,Y3,GROUP,NS, 16477 1 ICASPL,IREPL,MAXN,TEMP1, 16478 1 Y,X,X3D,D,NPLOTP,NPLOTV, 16479 1 IBUGG3,ISUBRO,IERROR) 16480C 16481C PURPOSE--FORM A TRILINEAR PLOT. 16482C REFERENCE--WAINER (1997), "VISUAL REVELATIONS", 16483C COPERNICUS, PP. 111-118. 16484C WRITTEN BY--JAMES J. FILLIBEN 16485C STATISTICAL ENGINEERING DIVISION 16486C INFORMATION TECHNOLOGY LABORATORY 16487C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 16488C GAITHERSBURG, MD 20899-8980 16489C PHONE--301-975-2855 16490C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16491C OF THE NATIONAL BUREAU OF STANDARDS. 16492C LANGUAGE--ANSI FORTRAN (1977) 16493C VERSION NUMBER--2006/12 16494C ORIGINAL VERSION--DECEMBER 2006. 16495C 16496C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16497C 16498 CHARACTER*4 ICASPL 16499 CHARACTER*4 IREPL 16500 CHARACTER*4 IBUGG3 16501 CHARACTER*4 ISUBRO 16502 CHARACTER*4 IERROR 16503C 16504 CHARACTER*4 ISUBN1 16505 CHARACTER*4 ISUBN2 16506 CHARACTER*4 ISTEPN 16507 CHARACTER*4 IWRITE 16508C 16509 DIMENSION Y1(*) 16510 DIMENSION Y2(*) 16511 DIMENSION Y3(*) 16512 DIMENSION GROUP(*) 16513 DIMENSION TEMP1(*) 16514 DIMENSION Y(*) 16515 DIMENSION X(*) 16516 DIMENSION X3D(*) 16517 DIMENSION D(*) 16518C 16519C-----COMMON---------------------------------------------------------- 16520C 16521 INCLUDE 'DPCOP2.INC' 16522C 16523C-----START POINT----------------------------------------------------- 16524C 16525 ISUBN1='DPTR' 16526 ISUBN2='PL ' 16527 IERROR='NO' 16528C 16529 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TRP2')THEN 16530 WRITE(ICOUT,999) 16531 999 FORMAT(1X) 16532 CALL DPWRST('XXX','BUG ') 16533 WRITE(ICOUT,51) 16534 51 FORMAT('***** AT THE BEGINNING OF DPTRPL--') 16535 CALL DPWRST('XXX','BUG ') 16536 WRITE(ICOUT,52)NPLOTV,NPLOTP,NS,MAXN 16537 52 FORMAT('NPLOTV,NPLOTP,NS,MAXN = ',4I8) 16538 CALL DPWRST('XXX','BUG ') 16539 WRITE(ICOUT,53)ICASPL,IREPL,IBUGG3,IERROR 16540 53 FORMAT('ICASPL,IREPL,IBUGG3,IERROR = ',A4,2X,A4,2X,A4,2X,A4) 16541 CALL DPWRST('XXX','BUG ') 16542 DO55I=1,MIN(NS,100) 16543 WRITE(ICOUT,56)I,Y1(I),Y2(I),Y3(I),GROUP(I) 16544 56 FORMAT('I,Y1(I),Y2(I),Y3(I),GROUP(I) = ',I8,4G15.7) 16545 CALL DPWRST('XXX','BUG ') 16546 55 CONTINUE 16547 ENDIF 16548C 16549 ISTEPN='1' 16550 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TRP2') 16551 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16552C 16553C ******************************************** 16554C ** STEP 1-- ** 16555C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 16556C ** 1) THE SUM OF Y1, Y2, AND Y3 MUST BE ** 16557C ** EITHER 1 OR 100 (FOR PERCENTAGE ** 16558C ** UNITS). ** 16559C ** 2) EACH OF THE COMPONENTS MUST BE IN ** 16560C ** THE INTERVAL (0,1) OR (0,100). ** 16561C ******************************************** 16562C 16563 N=NS 16564 ACASE=1.0 16565C 16566 DO120I=1,N 16567 ASUM=Y1(I)+Y2(I)+Y3(I) 16568 IF(I.EQ.1)THEN 16569 IF(ABS(ASUM - 1.0).LE.0.001)THEN 16570 ACASE=1.0 16571 EPS=0.001 16572 ELSEIF(ABS(ASUM - 100.0).LE.0.1)THEN 16573 ACASE=100.0 16574 EPS=0.1 16575 ELSE 16576 WRITE(ICOUT,999) 16577 CALL DPWRST('XXX','BUG ') 16578 WRITE(ICOUT,121) 16579 121 FORMAT('***** ERROR IN TRILINEAR PLOT--') 16580 CALL DPWRST('XXX','BUG ') 16581 WRITE(ICOUT,123)I 16582 123 FORMAT(' FOR ROW ',I8,', THE COMPONENTS DO NOT ', 16583 1 'SUM TO EITHER 1 OR 100') 16584 CALL DPWRST('XXX','BUG ') 16585 WRITE(ICOUT,124)ASUM 16586 124 FORMAT(' SUM = ',G15.7) 16587 CALL DPWRST('XXX','BUG ') 16588 WRITE(ICOUT,125)Y1(I) 16589 125 FORMAT(' COMPONENT 1 = ',G15.7) 16590 CALL DPWRST('XXX','BUG ') 16591 WRITE(ICOUT,126)Y2(I) 16592 126 FORMAT(' COMPONENT 2 = ',G15.7) 16593 CALL DPWRST('XXX','BUG ') 16594 WRITE(ICOUT,127)Y3(I) 16595 127 FORMAT(' COMPONENT 3 = ',G15.7) 16596 CALL DPWRST('XXX','BUG ') 16597 IERROR='YES' 16598 GOTO9000 16599 ENDIF 16600 ELSE 16601 IF(ABS(ASUM - ACASE).GT.EPS)THEN 16602 WRITE(ICOUT,999) 16603 CALL DPWRST('XXX','BUG ') 16604 WRITE(ICOUT,121) 16605 CALL DPWRST('XXX','BUG ') 16606 WRITE(ICOUT,133)I,ACASE 16607 133 FORMAT(' FOR ROW ',I8,', THE COMPONENTS DO NOT ', 16608 1 'SUM TO ',F7.1) 16609 CALL DPWRST('XXX','BUG ') 16610 WRITE(ICOUT,124)ASUM 16611 CALL DPWRST('XXX','BUG ') 16612 WRITE(ICOUT,125)Y1(I) 16613 CALL DPWRST('XXX','BUG ') 16614 WRITE(ICOUT,126)Y2(I) 16615 CALL DPWRST('XXX','BUG ') 16616 WRITE(ICOUT,127)Y3(I) 16617 CALL DPWRST('XXX','BUG ') 16618 IERROR='YES' 16619 GOTO9000 16620 ENDIF 16621 ENDIF 16622 120 CONTINUE 16623C 16624C **************************************************** 16625C ** STEP 2-- ** 16626C ** COMPUTE COORDINATES FOR TRILINEAR PLOT ** 16627C **************************************************** 16628C 16629 IF(IREPL.EQ.'ON')THEN 16630 CALL DISTIN(GROUP,N,IWRITE,TEMP1,NDIST,IBUGG3,IERROR) 16631 DO1010I=1,N 16632 Y(I)=Y1(I) 16633 X(I)=Y2(I) 16634 X3D(I)=Y3(I) 16635 D(I)=1.0 16636 DO1020J=1,NDIST 16637 IF(GROUP(I).EQ.TEMP1(J))THEN 16638 D(I)=REAL(J) 16639 GOTO1029 16640 ENDIF 16641 1020 CONTINUE 16642 1029 CONTINUE 16643 1010 CONTINUE 16644 NPLOTP=N 16645 NPLOTV=3 16646 ELSE 16647 DO2010I=1,N 16648 Y(I)=Y1(I) 16649 X(I)=Y2(I) 16650 X3D(I)=Y3(I) 16651 D(I)=1.0 16652 2010 CONTINUE 16653 NPLOTP=N 16654 NPLOTV=3 16655 ENDIF 16656C 16657C ***************** 16658C ** STEP 90-- ** 16659C ** EXIT ** 16660C ***************** 16661C 16662 9000 CONTINUE 16663 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TRP2')THEN 16664 WRITE(ICOUT,999) 16665 CALL DPWRST('XXX','BUG ') 16666 WRITE(ICOUT,9011) 16667 9011 FORMAT('***** AT THE END OF DPTRPL--') 16668 CALL DPWRST('XXX','BUG ') 16669 WRITE(ICOUT,9012)IFOUND,IERROR 16670 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 16671 CALL DPWRST('XXX','BUG ') 16672 WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL 16673 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL = ', 16674 1 I8,I8,I8,2X,A4) 16675 CALL DPWRST('XXX','BUG ') 16676 WRITE(ICOUT,9020) 16677 9020 FORMAT('I,Y(.),X(.),X3D(.),D(.)--') 16678 CALL DPWRST('XXX','BUG ') 16679 DO9021I=1,NPLOTP 16680 WRITE(ICOUT,9022)I,Y(I),X(I),X3D(I),D(I) 16681 9022 FORMAT(I8,4F15.7) 16682 CALL DPWRST('XXX','BUG ') 16683 9021 CONTINUE 16684 ENDIF 16685C 16686 RETURN 16687 END 16688 SUBROUTINE DPTRPO(X,Y,N, 16689 1 TX,TY,SX,SY,THETA, 16690 1 X2,Y2, 16691 1 ISUBRO,IBUGA3,IERROR) 16692C 16693C PURPOSE--GIVEN A SET OF (X,Y) PAIRS, PERFORM A TRANSLATION, 16694C SCALING, AND ROTATION TRANSFORMATION. 16695C 16696C THE TRANSLATION CAN BE IMPLEMENTED AS: 16697C 16698C X'=X - Tx 16699C Y'=Y - Ty 16700C 16701C THE SCALING CAN BE IMPLENENTED AS: 16702C 16703C X'=X*Sx 16704C Y'=Y*Sy 16705C 16706C THE ROTATION CAN BE IMPLEMENTED AS: 16707C 16708C X'=COS(THETA)*X + SIN(THETA)*Y 16709C Y'=-SIN(THETA)*X + COS(THETA)*Y 16710C 16711C INPUT ARGUMENTS--X = A REAL VECTOR CONTAINING THE X 16712C COORDINATES OF THE POINTS 16713C --Y = A REAL VECTOR CONTAINING THE Y 16714C COORDINATES OF THE POINTS 16715C --N = NUMBER OF POINTS IN X, Y 16716C --TX = TRANSLATION IN X DIRECTION 16717C --TY = TRANSLATION IN Y DIRECTION 16718C --SX = SCALING IN X DIRECTION 16719C --SY = SCALING IN Y DIRECTION 16720C --THETA = ANGLE OF ROTATION (IN COUNTER CLOCKWISE 16721C DIRECTION) IN RADIANS 16722C OUTPUT ARGUMENTS--X2 = A REAL VECTOR CONTAINING THE X 16723C COORDINATES OF THE TRANSFORMED POINTS 16724C --Y = A REAL VECTOR CONTAINING THE Y 16725C COORDINATES OF THE TRANSFORMED POINTS 16726C REFERENCE--XXXXX 16727C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 16728C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 16729C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 16730C LANGUAGE--ANSI FORTRAN (1977) 16731C WRITTEN BY--ALAN HECKERT 16732C STATISTICAL ENGINEERING DIVISION 16733C INFORMATION TECHNOLOGY LABORATORY 16734C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 16735C GAITHERSBURG, MD 20899-8980 16736C PHONE--301-975-2899 16737C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16738C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 16739C LANGUAGE--ANSI FORTRAN (1977) 16740C VERSION NUMBER--2012.10 16741C ORIGINAL VERSION--OCTOBER 2012. 16742C 16743C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16744C 16745C 16746 REAL X(*) 16747 REAL Y(*) 16748 REAL X2(*) 16749 REAL Y2(*) 16750C 16751 DOUBLE PRECISION PI 16752 DOUBLE PRECISION DX 16753 DOUBLE PRECISION DY 16754 DOUBLE PRECISION DXP 16755 DOUBLE PRECISION DYP 16756 DOUBLE PRECISION DTHETA 16757C 16758 INTEGER N 16759C 16760 CHARACTER*4 ISUBRO 16761 CHARACTER*4 IBUGA3 16762 CHARACTER*4 IERROR 16763C 16764C-----COMMON---------------------------------------------------------- 16765C 16766 INCLUDE 'DPCOP2.INC' 16767C 16768 DATA PI / 3.1415926535 8979323846 2643383279 503 D0 / 16769C 16770C-----START POINT----------------------------------------------------- 16771C 16772 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TRPO')THEN 16773 WRITE(ICOUT,999) 16774 999 FORMAT(1X) 16775 CALL DPWRST('XXX','BUG ') 16776 WRITE(ICOUT,51) 16777 51 FORMAT('***** AT THE BEGINNING OF DPTRPO--') 16778 CALL DPWRST('XXX','BUG ') 16779 WRITE(ICOUT,52)IBUGA3,ISUBRO,N 16780 52 FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8) 16781 CALL DPWRST('XXX','BUG ') 16782 WRITE(ICOUT,54)TX,TY,SX,SY,THETA 16783 54 FORMAT('TX,TY,SX,SY,THETA = ',5G15.7) 16784 CALL DPWRST('XXX','BUG ') 16785 IF(N.GT.0)THEN 16786 DO65I=1,N 16787 WRITE(ICOUT,66)I,X(I),Y(I) 16788 66 FORMAT('I,X(I),Y(I) = ',I8,2X,2G15.7) 16789 CALL DPWRST('XXX','BUG ') 16790 65 CONTINUE 16791 ENDIF 16792 ENDIF 16793C 16794 IF(SX.LE.0.0)THEN 16795 WRITE(ICOUT,999) 16796 CALL DPWRST('XXX','BUG ') 16797 WRITE(ICOUT,101) 16798 101 FORMAT('***** ERROR IN TRANSFORM POINTS--') 16799 CALL DPWRST('XXX','BUG ') 16800 WRITE(ICOUT,103)SX 16801 103 FORMAT(' THE SCALING FACTOR ',G15.7,' FOR THE X ', 16802 1 'DIRECTION IS NON-POSITIVE.') 16803 CALL DPWRST('XXX','BUG ') 16804 IERROR='YES' 16805 GOTO9000 16806 ENDIF 16807C 16808 IF(SY.LE.0.0)THEN 16809 WRITE(ICOUT,999) 16810 CALL DPWRST('XXX','BUG ') 16811 WRITE(ICOUT,101) 16812 CALL DPWRST('XXX','BUG ') 16813 WRITE(ICOUT,108)SY 16814 108 FORMAT(' THE SCALING FACTOR ',G15.7,' FOR THE Y ', 16815 1 'DIRECTION IS NON-POSITIVE.') 16816 CALL DPWRST('XXX','BUG ') 16817 IERROR='YES' 16818 GOTO9000 16819 ENDIF 16820C 16821 DTHETA=DBLE(THETA) 16822 IF((DTHETA.LT.-PI) .OR. (DTHETA.GT.PI))THEN 16823 WRITE(ICOUT,999) 16824 CALL DPWRST('XXX','BUG ') 16825 WRITE(ICOUT,101) 16826 CALL DPWRST('XXX','BUG ') 16827 WRITE(ICOUT,113)THETA 16828 113 FORMAT(' THE ROTATION FACTOR ',G15.7, 16829 1 'IS OUTSIDE THE (-PI,PI) INTERVAL.') 16830 CALL DPWRST('XXX','BUG ') 16831 IERROR='YES' 16832 GOTO9000 16833 ENDIF 16834C 16835 DO100IROW=1,N 16836 DX=DBLE(X(IROW)) 16837 DY=DBLE(Y(IROW)) 16838 DXP= DCOS(DTHETA)*DX + DSIN(DTHETA)*DY 16839 DYP=-DSIN(DTHETA)*DX + DCOS(DTHETA)*DY 16840 DXP=DXP - DBLE(TX) 16841 DYP=DYP - DBLE(TY) 16842 DXP=DXP*DBLE(SX) 16843 DYP=DYP*DBLE(SY) 16844 X2(IROW)=REAL(DXP) 16845 Y2(IROW)=REAL(DYP) 16846 100 CONTINUE 16847C 16848 9000 CONTINUE 16849C 16850 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TRPO')THEN 16851 WRITE(ICOUT,9051) 16852 9051 FORMAT('***** AT THE END OF DPTRPO--') 16853 CALL DPWRST('XXX','BUG ') 16854 DO9055I=1,N 16855 WRITE(ICOUT,9056)I,X2(I),Y2(I) 16856 9056 FORMAT('I,X2(I),Y2(I) = ',I8,2X,2G15.7) 16857 CALL DPWRST('XXX','BUG ') 16858 9055 CONTINUE 16859 ENDIF 16860C 16861 RETURN 16862 END 16863 SUBROUTINE DPTTES(XTEMP1,MAXNXT,ICAPSW,IFORSW, 16864 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 16865C 16866C PURPOSE--CARRY OUT A 1-SAMPLE OR A 2-SAMPLE T TEST 16867C EXAMPLE--T TEST Y MU 16868C T TEST MU Y 16869C T TEST Y1 Y2 16870C T TEST Y1 Y2 Y3 Y4 MU 16871C T TEST Y1 Y2 Y3 Y4 Y5 16872C PAIRED T TEST Y1 Y2 16873C WRITTEN BY--JAMES J. FILLIBEN 16874C STATISTICAL ENGINEERING DIVISION 16875C INFORMATION TECHNOLOGY LABORATORY 16876C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 16877C GAITHERSBURG, MD 20899-8980 16878C PHONE--301-921-3651 16879C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16880C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 16881C LANGUAGE--ANSI FORTRAN (1977) 16882C VERSION NUMBER--82/7 16883C ORIGINAL VERSION--JULY 1984. 16884C UPDATED --FEBRUARY 1994. ADD COMMENTS ABOVE 16885C UPDATED --DECEMBER 1994. COPY T TEST PARAMETERS 16886C UPDATED --MAY 1995. BUG FIX (DECLARATIONS) 16887C UPDATED --MARCH 2011. USE DPPARS AND DPPAR3 16888C UPDATED --MARCH 2011. SUPPORT FOR PAIRED T-TEST 16889C 16890C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16891C 16892 CHARACTER*4 ICAPSW 16893 CHARACTER*4 IFORSW 16894 CHARACTER*4 IBUGA2 16895 CHARACTER*4 IBUGA3 16896 CHARACTER*4 IBUGQ 16897 CHARACTER*4 ISUBRO 16898 CHARACTER*4 IFOUND 16899 CHARACTER*4 IERROR 16900C 16901 CHARACTER*4 ICASAN 16902 CHARACTER*4 ICASA2 16903 CHARACTER*4 ICASA3 16904 CHARACTER*4 ICTMP1 16905 CHARACTER*4 ICTMP2 16906 CHARACTER*4 ICTMP3 16907 CHARACTER*4 IREPL 16908 CHARACTER*4 IMULT 16909 CHARACTER*4 IPAIR 16910 CHARACTER*4 ISUBN1 16911 CHARACTER*4 ISUBN2 16912 CHARACTER*4 ISTEPN 16913C 16914 CHARACTER*4 ICASE 16915 CHARACTER*4 IVARID 16916 CHARACTER*4 IVARI2 16917 CHARACTER*4 IVARI3 16918 CHARACTER*4 IVARI4 16919 CHARACTER*40 INAME 16920 PARAMETER (MAXSPN=30) 16921 CHARACTER*4 IVARN1(MAXSPN) 16922 CHARACTER*4 IVARN2(MAXSPN) 16923 CHARACTER*4 IVARTY(MAXSPN) 16924 REAL PVAR(MAXSPN) 16925 INTEGER ILIS(MAXSPN) 16926 INTEGER NRIGHT(MAXSPN) 16927 INTEGER ICOLR(MAXSPN) 16928C 16929 CHARACTER*4 IFLAGU 16930 LOGICAL IFRST 16931 LOGICAL ILAST 16932C 16933C--------------------------------------------------------------------- 16934C 16935 DIMENSION XTEMP1(*) 16936C 16937C-----COMMON---------------------------------------------------------- 16938C 16939 INCLUDE 'DPCOPA.INC' 16940 INCLUDE 'DPCOHK.INC' 16941 INCLUDE 'DPCOSU.INC' 16942 INCLUDE 'DPCODA.INC' 16943 INCLUDE 'DPCOHO.INC' 16944 INCLUDE 'DPCOST.INC' 16945 INCLUDE 'DPCOP2.INC' 16946C 16947C-----START POINT----------------------------------------------------- 16948C 16949 ISUBN1='DPTT' 16950 ISUBN2='ES ' 16951 IFOUND='NO' 16952 IERROR='NO' 16953C 16954 MAXCP1=MAXCOL+1 16955 MAXCP2=MAXCOL+2 16956 MAXCP3=MAXCOL+3 16957 MAXCP4=MAXCOL+4 16958 MAXCP5=MAXCOL+5 16959 MAXCP6=MAXCOL+6 16960C 16961C ******************************** 16962C ** TREAT THE T TEST CASE ** 16963C ******************************** 16964C 16965 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TTES')THEN 16966 WRITE(ICOUT,999) 16967 999 FORMAT(1X) 16968 CALL DPWRST('XXX','BUG ') 16969 WRITE(ICOUT,51) 16970 51 FORMAT('***** AT THE BEGINNING OF DPTTES--') 16971 CALL DPWRST('XXX','BUG ') 16972 WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT 16973 52 FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',4(A4,2X),I8) 16974 CALL DPWRST('XXX','BUG ') 16975 ENDIF 16976C 16977C ********************************************************* 16978C ** STEP 1-- ** 16979C ** EXTRACT THE COMMAND ** 16980C ********************************************************* 16981C 16982 ISTEPN='1' 16983 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TTES') 16984 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16985C 16986 ILASTC=9999 16987 ILASTZ=9999 16988 ICASAN='TTES' 16989 ICASA2='UNKN' 16990 ICASA3='UNKN' 16991 IPAIR='OFF' 16992 IREPL='OFF' 16993 IMULT='OFF' 16994C 16995C LOOK FOR: 16996C 16997C T TEST/TTEST 16998C MULTIPLE 16999C REPLICATED 17000C PAIRED 17001C ONE SAMPLE (OR 1 SAMPLE) 17002C TWO SAMPLE (OR 2 SAMPLE) 17003C 17004 DO100I=0,NUMARG-1 17005C 17006 IF(I.EQ.0)THEN 17007 ICTMP1=ICOM 17008 ELSE 17009 ICTMP1=IHARG(I) 17010 ENDIF 17011 ICTMP2=IHARG(I+1) 17012 ICTMP3=IHARG(I+2) 17013C 17014 IF(ICTMP1.EQ.'=')THEN 17015 IFOUND='NO' 17016 GOTO9000 17017 ELSEIF(ICTMP1.EQ.'T ' .AND. ICTMP2.EQ.'TEST')THEN 17018 IFOUND='YES' 17019 ICASAN='TTES' 17020 ILASTC=I 17021 ILASTZ=I+1 17022 ELSEIF(ICTMP1.EQ.'TTES')THEN 17023 IFOUND='YES' 17024 ICASAN='TTES' 17025 ILASTC=I 17026 ILASTZ=I 17027 ELSEIF(ICTMP1.EQ.'REPL')THEN 17028 IREPL='ON' 17029 ILASTC=MIN(ILASTC,I) 17030 ILASTZ=MAX(ILASTZ,I) 17031 ELSEIF(ICTMP1.EQ.'MULT')THEN 17032 IMULT='ON' 17033 ILASTC=MIN(ILASTC,I) 17034 ILASTZ=MAX(ILASTZ,I) 17035 ELSEIF(ICTMP1.EQ.'PAIR')THEN 17036 IPAIR='ON' 17037 ILASTC=MIN(ILASTC,I) 17038 ILASTZ=MAX(ILASTZ,I) 17039 ELSEIF(ICTMP1.EQ.'ONE' .AND. ICTMP2.EQ.'SAMP')THEN 17040 ICASA2='ONES' 17041 ILASTC=MIN(ILASTC,I) 17042 ILASTZ=MAX(ILASTZ,I+1) 17043 ELSEIF(ICTMP1.EQ.'1' .AND. ICTMP2.EQ.'SAMP')THEN 17044 ICASA2='ONES' 17045 ILASTC=MIN(ILASTC,I) 17046 ILASTZ=MAX(ILASTZ,I+1) 17047 ELSEIF(ICTMP1.EQ.'TWO' .AND. ICTMP2.EQ.'SAMP')THEN 17048 ICASA2='TWOS' 17049 ILASTC=MIN(ILASTC,I) 17050 ILASTZ=MAX(ILASTZ,I+1) 17051 ELSEIF(ICTMP1.EQ.'2' .AND. ICTMP2.EQ.'SAMP')THEN 17052 ICASA2='TWOS' 17053 ILASTC=MIN(ILASTC,I) 17054 ILASTZ=MAX(ILASTZ,I+1) 17055 ELSEIF(ICTMP1.EQ.'LOWE' .AND. ICTMP2.EQ.'TAIL')THEN 17056 ICASA3='LOWE' 17057 ILASTC=MIN(ILASTC,I) 17058 ILASTZ=MAX(ILASTZ,I+1) 17059 ELSEIF(ICTMP1.EQ.'UPPE' .AND. ICTMP2.EQ.'TAIL')THEN 17060 ICASA3='UPPE' 17061 ILASTC=MIN(ILASTC,I) 17062 ILASTZ=MAX(ILASTZ,I+1) 17063 ELSEIF(ICTMP1.EQ.'TWO' .AND. ICTMP2.EQ.'TAIL')THEN 17064 ICASA3='TWOT' 17065 ILASTC=MIN(ILASTC,I) 17066 ILASTZ=MAX(ILASTZ,I+1) 17067 ELSEIF(ICTMP1.EQ.'2' .AND. ICTMP2.EQ.'TAIL')THEN 17068 ICASA3='TWOT' 17069 ILASTC=MIN(ILASTC,I) 17070 ILASTZ=MAX(ILASTZ,I+1) 17071 ENDIF 17072 100 CONTINUE 17073C 17074 IF(IFOUND.EQ.'NO')GOTO9000 17075C 17076 ISHIFT=ILASTZ 17077 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 17078 1 IBUGA2,IERROR) 17079C 17080 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TTES')THEN 17081 WRITE(ICOUT,91)ICASAN,ICASA2,IMULT,IREPL,ISHIFT 17082 91 FORMAT('DPTTES: ICASAN,ICASA2,IMULT,IREPL,ISHIFT = ', 17083 1 4(A4,2X),I5) 17084 CALL DPWRST('XXX','BUG ') 17085 ENDIF 17086C 17087 IF(IFOUND.EQ.'NO')GOTO9000 17088 IF(IMULT.EQ.'ON')THEN 17089 IF(IREPL.EQ.'ON')THEN 17090 WRITE(ICOUT,999) 17091 CALL DPWRST('XXX','BUG ') 17092 WRITE(ICOUT,101) 17093 101 FORMAT('***** ERROR IN T-TEST--') 17094 CALL DPWRST('XXX','BUG ') 17095 WRITE(ICOUT,102) 17096 102 FORMAT(' YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ') 17097 CALL DPWRST('XXX','BUG ') 17098 WRITE(ICOUT,103) 17099 103 FORMAT(' "REPLICATION" FOR THE T-TEST COMMAND. ') 17100 CALL DPWRST('XXX','BUG ') 17101 IERROR='YES' 17102 GOTO9000 17103 ENDIF 17104 ENDIF 17105C 17106C **************************************** 17107C ** STEP 2-- ** 17108C ** EXTRACT THE VARIABLE LIST ** 17109C **************************************** 17110C 17111 ISTEPN='2' 17112 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TTES') 17113 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17114C 17115 INAME='T-TEST' 17116 MINNA=1 17117 MAXNA=100 17118 MINN2=2 17119 IFLAGE=0 17120 IFLAGM=1 17121 MINNVA=2 17122 MAXNVA=MAXSPN 17123 IFLAGP=29 17124 IF(IREPL.EQ.'ON')THEN 17125 IFLAGE=1 17126 IFLAGM=0 17127 ENDIF 17128 IF(IPAIR.EQ.'ON')THEN 17129 IFLAGE=1 17130 ICASA2='TWOS' 17131 ENDIF 17132 IF(ICASA2.EQ.'TWOS')THEN 17133 IFLAGP=0 17134 ENDIF 17135 JMIN=1 17136 JMAX=NUMARG 17137C 17138 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 17139 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 17140 1 JMIN,JMAX, 17141 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 17142 1 IVARN1,IVARN2,IVARTY,PVAR, 17143 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 17144 1 MINNVA,MAXNVA, 17145 1 IFLAGM,IFLAGP, 17146 1 IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 17147 IF(IERROR.EQ.'YES')GOTO9000 17148C 17149 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TTES')THEN 17150 WRITE(ICOUT,999) 17151 CALL DPWRST('XXX','BUG ') 17152 WRITE(ICOUT,281) 17153 281 FORMAT('***** AFTER CALL DPPARS--') 17154 CALL DPWRST('XXX','BUG ') 17155 WRITE(ICOUT,282)NQ,NUMVAR 17156 282 FORMAT('NQ,NUMVAR = ',2I8) 17157 CALL DPWRST('XXX','BUG ') 17158 IF(NUMVAR.GT.0)THEN 17159 DO285I=1,NUMVAR 17160 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),IVARTY(I), 17161 1 ILIS(I),NRIGHT(I),ICOLR(I) 17162 287 FORMAT('I,IVARN1(I),IVARN2(I),IVARTY(I),ILIS(I),', 17163 1 'NRIGHT(I),ICOLR(I) = ',I8,2X,2A4,2X,A4,2X,3I8) 17164 CALL DPWRST('XXX','BUG ') 17165 285 CONTINUE 17166 ENDIF 17167 ENDIF 17168C 17169C IF EITHER FIRST OR LAST ARGUMENT IS A PARAMETER, THEN 17170C WE HAVE THE ONE-SAMPLE T-TEST. OTHERWISE, HAVE ASSUME 17171C A TWO-SAMPLE T-TEST. 17172C 17173 IF(ICASA2.EQ.'ONES')THEN 17174 IF(IVARTY(1).NE.'PARA' .AND. IVARTY(NUMVAR).NE.'PARA')THEN 17175 WRITE(ICOUT,999) 17176 CALL DPWRST('XXX','BUG ') 17177 WRITE(ICOUT,101) 17178 CALL DPWRST('XXX','BUG ') 17179 WRITE(ICOUT,292) 17180 292 FORMAT(' FOR THE ONE-SAMPLE TEST, EITHER THE FIRST OR') 17181 CALL DPWRST('XXX','BUG ') 17182 WRITE(ICOUT,294) 17183 294 FORMAT(' THE LAST ARGUMENT MUST BE A PARAMETER.') 17184 CALL DPWRST('XXX','BUG ') 17185 IERROR='YES' 17186 GOTO9000 17187 ENDIF 17188 ISTART=1 17189 ISTOP=NUMVAR-1 17190 AMU0=PVAR(NUMVAR) 17191 ELSEIF(IVARTY(1).EQ.'PARA')THEN 17192 ICASA2='ONES' 17193 ISTART=2 17194 ISTOP=NUMVAR 17195 AMU0=PVAR(1) 17196 ELSEIF(IVARTY(NUMVAR).EQ.'PARA')THEN 17197 ICASA2='ONES' 17198 ISTART=1 17199 ISTOP=NUMVAR-1 17200 AMU0=PVAR(NUMVAR) 17201 ELSE 17202 ICASA2='TWOS' 17203 ISTART=1 17204 ISTOP=NUMVAR 17205 ENDIF 17206C 17207C ****************************************************** 17208C ** STEP 3A-- ** 17209C ** CASE 1: TWO RESPONSE VARIABLES, NO REPLICATION ** 17210C ** HANDLE MULTIPLE RESPONSE VARIABLES ** 17211C ** DIFFERENTLY FOR ONE SAMPLE AND TWO ** 17212C ** SAMPLE TESTS. ** 17213C ****************************************************** 17214C 17215 ISTEPN='3A' 17216 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TTES') 17217 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17218C 17219 NUMVA2=1 17220 DO5210I=ISTART,ISTOP 17221 ICOL=I 17222 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 17223 1 INAME,IVARN1,IVARN2,IVARTY, 17224 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 17225 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 17226 1 MAXCP4,MAXCP5,MAXCP6, 17227 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 17228 1 Y,Y,Y,NS1,NLOCA2,NLOCA3,ICASE, 17229 1 IBUGA3,ISUBRO,IFOUND,IERROR) 17230 IF(IERROR.EQ.'YES')GOTO9000 17231C 17232 IF(ICASA2.EQ.'ONES')THEN 17233 ISTRT2=1 17234 ISTOP2=1 17235 ELSE 17236 ISTRT2=I+1 17237 ISTOP2=ISTOP 17238 ENDIF 17239C 17240 DO5220J=ISTRT2,ISTOP2 17241C 17242 IF(ICASA2.EQ.'TWOS')THEN 17243 ICOL=J 17244 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 17245 1 INAME,IVARN1,IVARN2,IVARTY, 17246 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 17247 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 17248 1 MAXCP4,MAXCP5,MAXCP6, 17249 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 17250 1 X,X,X,NS2,NLOCA2,NLOCA3,ICASE, 17251 1 IBUGA3,ISUBRO,IFOUND,IERROR) 17252 IF(IERROR.EQ.'YES')GOTO9000 17253 ENDIF 17254C 17255C ***************************************** 17256C ** STEP 52-- ** 17257C ** PERFORM 2-SAMPLE T-TEST ** 17258C ***************************************** 17259C 17260 ISTEPN='52' 17261 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TTES')THEN 17262 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17263 WRITE(ICOUT,999) 17264 CALL DPWRST('XXX','BUG ') 17265 WRITE(ICOUT,5211) 17266 5211 FORMAT('***** FROM DPTTES, BEFORE CALL DPTTE2--') 17267 CALL DPWRST('XXX','BUG ') 17268 WRITE(ICOUT,5212)I,J,NS1,NS2,MAXN 17269 5212 FORMAT('I,J,NS1,NS2,MAXN = ',5I8) 17270 CALL DPWRST('XXX','BUG ') 17271 IF(ICASA2.EQ.'ONES')NS2=NS1 17272 DO5215II=1,MAX(NS1,NS2) 17273 WRITE(ICOUT,5216)II,Y(II),X(II) 17274 5216 FORMAT('I,Y(I),X(I) = ',I8,2G15.7) 17275 CALL DPWRST('XXX','BUG ') 17276 5215 CONTINUE 17277 ENDIF 17278C 17279 IVARID=IVARN1(I) 17280 IVARI2=IVARN2(I) 17281 IVARI3=IVARN1(J) 17282 IVARI4=IVARN2(J) 17283 CALL DPTTE2(Y,NS1,X,NS2,AMU0,ICASA2,ICASA3,IPAIR, 17284 1 XTEMP1,MAXNXT, 17285 1 ICAPSW,ICAPTY,IFORSW,ITTEVA, 17286 1 IVARID,IVARI2,IVARI3,IVARI4, 17287 1 STATVA,STATCD,STATNU,POOLSD, 17288 1 STATV2,STATC2,STATN2, 17289 1 PVAL2T,PVALLT,PVALUT, 17290 1 CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50, 17291 1 CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50, 17292 1 IBUGA3,ISUBRO,IERROR) 17293 IF(IERROR.EQ.'YES')GOTO9000 17294C 17295C *************************************** 17296C ** STEP 8C-- ** 17297C ** UPDATE INTERNAL DATAPLOT TABLES ** 17298C *************************************** 17299C 17300 ISTEPN='8C' 17301 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TTE2') 17302 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17303C 17304 IF(ICASA2.EQ.'TWOS')THEN 17305 IF(NUMVAR.GT.2)THEN 17306 IFLAGU='FILE' 17307 ELSE 17308 IFLAGU='ON' 17309 ENDIF 17310 IFRST=.FALSE. 17311 ILAST=.FALSE. 17312 IF(I.EQ.1 .AND. J.EQ.2)IFRST=.TRUE. 17313 IF(I.EQ.NUMVAR .AND. J.EQ.NUMVAR)ILAST=.TRUE. 17314 IF(IPAIR.EQ.'OFF')THEN 17315 IF(ITTEVA.EQ.'EQUA')THEN 17316 STATV2=STATVA 17317 STATC2=STATCD 17318 STATN2=STATNU 17319 ENDIF 17320 ENDIF 17321 ELSE 17322 IF(ISTOP-ISTART.GT.0)THEN 17323 IFLAGU='FILE' 17324 ELSE 17325 IFLAGU='ON' 17326 ENDIF 17327 IFRST=.FALSE. 17328 ILAST=.FALSE. 17329 IF(I.EQ.ISTART)IFRST=.TRUE. 17330 IF(I.EQ.ISTOP)ILAST=.TRUE. 17331 ENDIF 17332 CALL DPTTE5(ICASA2,STATVA,STATCD,STATNU, 17333 1 STATV2,STATC2,STATN2, 17334 1 PVAL2T,PVALLT,PVALUT, 17335 1 CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50, 17336 1 CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50, 17337 1 IFLAGU,IFRST,ILAST, 17338 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 17339C 17340 5220 CONTINUE 17341 5210 CONTINUE 17342C 17343C ***************** 17344C ** STEP 90-- ** 17345C ** EXIT ** 17346C ***************** 17347C 17348 9000 CONTINUE 17349 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TTES')THEN 17350 WRITE(ICOUT,999) 17351 CALL DPWRST('XXX','BUG ') 17352 WRITE(ICOUT,9011) 17353 9011 FORMAT('***** AT THE END OF DPTTES--') 17354 CALL DPWRST('XXX','BUG ') 17355 WRITE(ICOUT,9016)IFOUND,IERROR 17356 9016 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 17357 CALL DPWRST('XXX','BUG ') 17358 ENDIF 17359C 17360 RETURN 17361 END 17362 SUBROUTINE DPTTE2(Y1,N1,Y2,N2,AMU0,ICASA2,ICASA3,IPAIR, 17363 1 XTEMP1,MAXNXT, 17364 1 ICAPSW,ICAPTY,IFORSW,ITTEVA, 17365 1 IVARID,IVARI2,IVARI3,IVARI4, 17366 1 STATVA,STATCD,STATNU,POOLSD, 17367 1 STATV2,STATC2,STATN2, 17368 1 PVAL2T,PVALLT,PVALUT, 17369 1 CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50, 17370 1 CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50, 17371 1 IBUGA3,ISUBRO,IERROR) 17372C 17373C PURPOSE--THIS ROUTINE CARRIES OUT A T TEST 17374C (1-SAMPLE OR UNPAIRED 2-SAMPLE) 17375C EXAMPLE--T TEST Y MU 17376C T TEST MU Y 17377C T TEST Y1 Y2 17378C SAMPLE 1 IS IN INPUT VECTOR Y1 17379C (WITH N1 OBSERVATIONS). 17380C SAMPLE 2 IS IN INPUT VECTOR Y2 17381C (WITH N2 OBSERVATIONS). 17382C WRITTEN BY--JAMES J. FILLIBEN 17383C STATISTICAL ENGINEERING DIVISION 17384C INFORMATION TECHNOLOGY LABORATORY 17385C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 17386C GAITHERSBURG, MD 20899-8980 17387C PHONE--301-975-2855 17388C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 17389C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 17390C LANGUAGE--ANSI FORTRAN (1977) 17391C VERSION NUMBER--82/7 17392C ORIGINAL VERSION--MAY 1984. 17393C UPDATED --APRIL 1987. (LARRY KNAB CORRECTION-- 17394C BROWNLEE, P. 225) 17395C UPDATED --FEBRUARY 1994. REFORMAT OUTPUT 17396C UPDATED --FEBRUARY 1994. DPWRST: 'BUG ' => 'WRIT' 17397C UPDATED --DECEMBER 1994. COPY T TEST PARAMETERS 17398C UPDATED --OCTOBER 2006. CALL LIST TO TCDF/TPPF 17399C UPDATED --NOVEMBER 2007. ALLOW USER-SPECIFIED 17400C SIGNIFICANCE LEVEL 17401C UPDATED --APRIL 2011. USE DPDTA1, DPDTA5 TO PRINT 17402C OUTPUT. REFORMAT OUTPUT 17403C SOMEWHAT AS WELL. 17404C 17405C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 17406C 17407 CHARACTER*4 IVARID 17408 CHARACTER*4 IVARI2 17409 CHARACTER*4 IVARI3 17410 CHARACTER*4 IVARI4 17411 CHARACTER*4 ICAPSW 17412 CHARACTER*4 ICAPTY 17413 CHARACTER*4 IFORSW 17414 CHARACTER*4 ITTEVA 17415 CHARACTER*4 ICASA2 17416 CHARACTER*4 ICASA3 17417 CHARACTER*4 IPAIR 17418 CHARACTER*4 IBUGA3 17419 CHARACTER*4 ISUBRO 17420 CHARACTER*4 IERROR 17421C 17422 CHARACTER*4 IWRITE 17423 CHARACTER*4 ISUBN1 17424 CHARACTER*4 ISUBN2 17425 CHARACTER*4 ISTEPN 17426C 17427C--------------------------------------------------------------------- 17428C 17429 DIMENSION Y1(*) 17430 DIMENSION Y2(*) 17431 DIMENSION XTEMP1(*) 17432C 17433 PARAMETER (NUMALP=6) 17434 REAL ALPHA(NUMALP) 17435C 17436 PARAMETER(NUMCLI=4) 17437 PARAMETER(MAXLIN=3) 17438 PARAMETER (MAXROW=NUMALP) 17439 PARAMETER (MAXRO2=40) 17440 CHARACTER*60 ITITLE 17441 CHARACTER*60 ITITLZ 17442 CHARACTER*60 ITITL9 17443 CHARACTER*60 ITEXT(MAXRO2) 17444 CHARACTER*4 ALIGN(NUMCLI) 17445 CHARACTER*4 VALIGN(NUMCLI) 17446 REAL AVALUE(MAXRO2) 17447 INTEGER NCTEXT(MAXRO2) 17448 INTEGER IDIGIT(MAXRO2) 17449 INTEGER NTOT(MAXRO2) 17450 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 17451 CHARACTER*15 IVALUE(MAXROW,NUMCLI) 17452 CHARACTER*4 ITYPCO(NUMCLI) 17453 INTEGER NCTIT2(MAXLIN,NUMCLI) 17454 INTEGER NCVALU(MAXROW,NUMCLI) 17455 INTEGER IWHTML(NUMCLI) 17456 INTEGER IWRTF(NUMCLI) 17457 REAL AMAT(MAXROW,NUMCLI) 17458 LOGICAL IFRST 17459 LOGICAL ILAST 17460 LOGICAL IFLAGS 17461 LOGICAL IFLAGE 17462C 17463C-----COMMON---------------------------------------------------------- 17464C 17465 INCLUDE 'DPCOP2.INC' 17466C 17467 DATA ALPHA/0.50, 0.80, 0.90, 0.95, 0.99, 0.999/ 17468C 17469C-----START POINT----------------------------------------------------- 17470C 17471 ISUBN1='DPTT' 17472 ISUBN2='E2 ' 17473 IERROR='NO' 17474 IWRITE='OFF' 17475C 17476 NUMDIG=7 17477 IF(IFORSW.EQ.'1')NUMDIG=1 17478 IF(IFORSW.EQ.'2')NUMDIG=2 17479 IF(IFORSW.EQ.'3')NUMDIG=3 17480 IF(IFORSW.EQ.'4')NUMDIG=4 17481 IF(IFORSW.EQ.'5')NUMDIG=5 17482 IF(IFORSW.EQ.'6')NUMDIG=6 17483 IF(IFORSW.EQ.'7')NUMDIG=7 17484 IF(IFORSW.EQ.'8')NUMDIG=8 17485 IF(IFORSW.EQ.'9')NUMDIG=9 17486 IF(IFORSW.EQ.'0')NUMDIG=0 17487 IF(IFORSW.EQ.'E')NUMDIG=-2 17488 IF(IFORSW.EQ.'-2')NUMDIG=-2 17489 IF(IFORSW.EQ.'-3')NUMDIG=-3 17490 IF(IFORSW.EQ.'-4')NUMDIG=-4 17491 IF(IFORSW.EQ.'-5')NUMDIG=-5 17492 IF(IFORSW.EQ.'-6')NUMDIG=-6 17493 IF(IFORSW.EQ.'-7')NUMDIG=-7 17494 IF(IFORSW.EQ.'-8')NUMDIG=-8 17495 IF(IFORSW.EQ.'-9')NUMDIG=-9 17496C 17497 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TTE2')THEN 17498 WRITE(ICOUT,999) 17499 999 FORMAT(1X) 17500 CALL DPWRST('XXX','WRIT') 17501 WRITE(ICOUT,51) 17502 51 FORMAT('**** AT THE BEGINNING OF DPTTE2--') 17503 CALL DPWRST('XXX','WRIT') 17504 WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASA2,ITTEVA 17505 52 FORMAT('IBUGA3,ISUBRO = ',3(A4,2X),A4) 17506 CALL DPWRST('XXX','WRIT') 17507 WRITE(ICOUT,55)N1,N2,NUMDIG,MAXNXT,AMU 17508 55 FORMAT('N1,N2,NUMDIG,MAXNXT,AMU = ',4I8,G15.7) 17509 CALL DPWRST('XXX','WRIT') 17510 IF(N1.GE.1)THEN 17511 DO56I=1,N1 17512 WRITE(ICOUT,57)I,Y1(I) 17513 57 FORMAT('I,Y1(I) = ',I8,G15.7) 17514 CALL DPWRST('XXX','WRIT') 17515 56 CONTINUE 17516 ENDIF 17517 IF(N2.GE.1 .AND. ICASA2.EQ.'TWOS')THEN 17518 DO66I=1,N2 17519 WRITE(ICOUT,67)I,Y2(I) 17520 67 FORMAT('I,Y2(I) = ',I8,G15.7) 17521 CALL DPWRST('XXX','WRIT') 17522 66 CONTINUE 17523 ENDIF 17524 ENDIF 17525C 17526C ************************************ 17527C ** STEP 1-- ** 17528C ** BRANCH DEPENDING ON WHETHER ** 17529C ** 1-SAMPLE T TEST OR ** 17530C ** 2-SAMPLE T TEST. ** 17531C ************************************ 17532C 17533 ISTEPN='1' 17534 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TTE2') 17535 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17536C 17537 IF(ICASA2.EQ.'ONES')THEN 17538 GOTO2100 17539 ELSEIF(ICASA2.EQ.'TWOS')THEN 17540 IF(IPAIR.EQ.'OFF')GOTO3100 17541 IF(IPAIR.EQ.'ON')GOTO4100 17542 ELSE 17543 GOTO9000 17544 ENDIF 17545C 17546C ****************************** 17547C ** STEP 21-- ** 17548C ** CARRY OUT CALCULATIONS ** 17549C ** FOR A 1-SAMPLE T TEST ** 17550C ****************************** 17551C 17552 2100 CONTINUE 17553C 17554 ISTEPN='21' 17555 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TTE2') 17556 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17557C 17558 CALL DPTTE3(Y1,N1,AMU0,IWRITE,STATVA,STATCD,STATNU, 17559 1 YMEAN,YSD,YSDM,DEL, 17560 1 PVAL2T,PVALLT,PVALUT, 17561 1 ISUBRO,IBUGA3,IERROR) 17562C 17563 CALL TPPF(.0005,STATNU,CTL999) 17564 CALL TPPF(.005,STATNU,CUTL99) 17565 CALL TPPF(.025,STATNU,CUTL95) 17566 CALL TPPF(.05,STATNU,CUTL90) 17567 CALL TPPF(.1,STATNU,CUTL80) 17568 CALL TPPF(.25,STATNU,CUTL50) 17569 CALL TPPF(.75,STATNU,CUTU50) 17570 CALL TPPF(.90,STATNU,CUTU80) 17571 CALL TPPF(.95,STATNU,CUTU90) 17572 CALL TPPF(.975,STATNU,CUTU95) 17573 CALL TPPF(.995,STATNU,CUTU99) 17574 CALL TPPF(.9995,STATNU,CTU999) 17575C 17576C ****************************** 17577C ** STEP 22-- ** 17578C ** WRITE OUT EVERYTHING ** 17579C ** FOR A 1-SAMPLE T TEST ** 17580C ****************************** 17581C 17582 ISTEPN='22' 17583 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TTE2') 17584 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17585C 17586 IF(IPRINT.EQ.'OFF')GOTO9000 17587C 17588 ITITLE='One Sample t-Test for the Mean' 17589 NCTITL=30 17590 ITITLZ=' ' 17591 NCTITZ=0 17592C 17593 ICNT=1 17594 ITEXT(ICNT)=' ' 17595 NCTEXT(ICNT)=0 17596 AVALUE(ICNT)=0.0 17597 IDIGIT(ICNT)=-1 17598C 17599 ICNT=ICNT+1 17600 ITEXT(ICNT)='Response Variable: ' 17601 WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1:4) 17602 WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1:4) 17603 NCTEXT(ICNT)=27 17604 AVALUE(ICNT)=0.0 17605 IDIGIT(ICNT)=-1 17606C 17607 ICNT=ICNT+1 17608 ITEXT(ICNT)=' ' 17609 NCTEXT(ICNT)=1 17610 AVALUE(ICNT)=0.0 17611 IDIGIT(ICNT)=-1 17612C 17613 ICNT=ICNT+1 17614 ITEXT(ICNT)='H0: Mean Equal' 17615 NCTEXT(ICNT)=14 17616 AVALUE(ICNT)=AMU0 17617 IDIGIT(ICNT)=NUMDIG 17618 ICNT=ICNT+1 17619 ITEXT(ICNT)='Ha: Mean Not Equal' 17620 NCTEXT(ICNT)=18 17621 AVALUE(ICNT)=AMU0 17622 IDIGIT(ICNT)=NUMDIG 17623C 17624 ICNT=ICNT+1 17625 ITEXT(ICNT)=' ' 17626 NCTEXT(ICNT)=1 17627 AVALUE(ICNT)=0.0 17628 IDIGIT(ICNT)=-1 17629 ICNT=ICNT+1 17630 ITEXT(ICNT)='Summary Statistics:' 17631 NCTEXT(ICNT)=19 17632 AVALUE(ICNT)=0.0 17633 IDIGIT(ICNT)=-1 17634 ICNT=ICNT+1 17635 ITEXT(ICNT)='Number of Observations:' 17636 NCTEXT(ICNT)=23 17637 AVALUE(ICNT)=REAL(N1) 17638 IDIGIT(ICNT)=0 17639 ICNT=ICNT+1 17640 ITEXT(ICNT)='Sample Mean:' 17641 NCTEXT(ICNT)=12 17642 AVALUE(ICNT)=YMEAN 17643 IDIGIT(ICNT)=NUMDIG 17644 ICNT=ICNT+1 17645 ITEXT(ICNT)='Sample Standard Deviation:' 17646 NCTEXT(ICNT)=26 17647 AVALUE(ICNT)=YSD 17648 IDIGIT(ICNT)=NUMDIG 17649 ICNT=ICNT+1 17650 ITEXT(ICNT)='Sample Standard Deviation of the Mean:' 17651 NCTEXT(ICNT)=38 17652 AVALUE(ICNT)=YSDM 17653 IDIGIT(ICNT)=NUMDIG 17654 ICNT=ICNT+1 17655 ITEXT(ICNT)=' ' 17656 NCTEXT(ICNT)=1 17657 AVALUE(ICNT)=0.0 17658 IDIGIT(ICNT)=-1 17659C 17660 ICNT=ICNT+1 17661 ITEXT(ICNT)='Test:' 17662 NCTEXT(ICNT)=5 17663 AVALUE(ICNT)=0.0 17664 IDIGIT(ICNT)=-1 17665 ICNT=ICNT+1 17666 ITEXT(ICNT)='Mean - Mu0:' 17667 NCTEXT(ICNT)=11 17668 AVALUE(ICNT)=DEL 17669 IDIGIT(ICNT)=NUMDIG 17670 ICNT=ICNT+1 17671 ITEXT(ICNT)='t-Test Statistic Value:' 17672 NCTEXT(ICNT)=23 17673 AVALUE(ICNT)=STATVA 17674 IDIGIT(ICNT)=NUMDIG 17675 ICNT=ICNT+1 17676 ITEXT(ICNT)='Degrees of Freedom:' 17677 NCTEXT(ICNT)=19 17678 AVALUE(ICNT)=INT(STATNU+0.1) 17679 IDIGIT(ICNT)=0 17680 ICNT=ICNT+1 17681 ITEXT(ICNT)='CDF Value:' 17682 NCTEXT(ICNT)=10 17683 AVALUE(ICNT)=STATCD 17684 IDIGIT(ICNT)=NUMDIG 17685 ICNT=ICNT+1 17686 ITEXT(ICNT)='P-Value (2-tailed test):' 17687 NCTEXT(ICNT)=24 17688 AVALUE(ICNT)=PVAL2T 17689 IDIGIT(ICNT)=NUMDIG 17690 ICNT=ICNT+1 17691 ITEXT(ICNT)='P-Value (lower-tailed test):' 17692 NCTEXT(ICNT)=28 17693 AVALUE(ICNT)=PVALLT 17694 IDIGIT(ICNT)=NUMDIG 17695 ICNT=ICNT+1 17696 ITEXT(ICNT)='P-Value (upper-tailed test):' 17697 NCTEXT(ICNT)=28 17698 AVALUE(ICNT)=PVALUT 17699 IDIGIT(ICNT)=NUMDIG 17700C 17701 NUMROW=ICNT 17702 DO2110I=1,NUMROW 17703 NTOT(I)=15 17704 2110 CONTINUE 17705C 17706 IFRST=.TRUE. 17707 ILAST=.TRUE. 17708C 17709 ISTEPN='21A' 17710 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TTE2') 17711 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17712C 17713 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT, 17714 1 AVALUE,IDIGIT, 17715 1 NTOT,NUMROW, 17716 1 ICAPSW,ICAPTY,ILAST,IFRST, 17717 1 ISUBRO,IBUGA3,IERROR) 17718C 17719 ISTEPN='21B' 17720 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TTE2') 17721 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17722C 17723 ITITLE='Two-Tailed Test' 17724 NCTITL=15 17725 ITITL9='H0: u = m0; Ha: u <> m0' 17726 NCTIT9=23 17727C 17728 DO2130J=1,4 17729 DO2140I=1,3 17730 ITITL2(I,J)=' ' 17731 NCTIT2(I,J)=0 17732 2140 CONTINUE 17733 2130 CONTINUE 17734C 17735 ITITL2(2,1)='Significance' 17736 NCTIT2(2,1)=12 17737 ITITL2(3,1)='Level' 17738 NCTIT2(3,1)=5 17739C 17740 ITITL2(2,2)='Test ' 17741 NCTIT2(2,2)=4 17742 ITITL2(3,2)='Statistic' 17743 NCTIT2(3,2)=9 17744C 17745 ITITL2(2,3)='Critical' 17746 NCTIT2(2,3)=8 17747 ITITL2(3,3)='Value (+/-)' 17748 NCTIT2(3,3)=11 17749C 17750 ITITL2(1,4)='Null' 17751 NCTIT2(1,4)=4 17752 ITITL2(2,4)='Hypothesis' 17753 NCTIT2(2,4)=10 17754 ITITL2(3,4)='Conclusion' 17755 NCTIT2(3,4)=10 17756C 17757 NMAX=0 17758 NUMCOL=4 17759 DO2150I=1,NUMCOL 17760 VALIGN(I)='b' 17761 ALIGN(I)='r' 17762 NTOT(I)=15 17763 NMAX=NMAX+NTOT(I) 17764 ITYPCO(I)='NUME' 17765 IDIGIT(I)=NUMDIG 17766 IF(I.EQ.1 .OR. I.EQ.4)THEN 17767 ITYPCO(I)='ALPH' 17768 ENDIF 17769 2150 CONTINUE 17770C 17771 IWHTML(1)=125 17772 IWHTML(2)=175 17773 IWHTML(3)=175 17774 IWHTML(4)=175 17775 IINC=1800 17776 IINC2=1400 17777 IWRTF(1)=IINC 17778 IWRTF(2)=IWRTF(1)+IINC 17779 IWRTF(3)=IWRTF(2)+IINC 17780 IWRTF(4)=IWRTF(3)+IINC 17781C 17782 DO2160J=1,NUMALP 17783C 17784 AMAT(J,2)=STATVA 17785 IF(J.EQ.1)THEN 17786 AMAT(J,3)=CUTU50 17787 ELSEIF(J.EQ.2)THEN 17788 AMAT(J,3)=CUTU80 17789 ELSEIF(J.EQ.3)THEN 17790 AMAT(J,3)=CUTU90 17791 ELSEIF(J.EQ.4)THEN 17792 AMAT(J,3)=CUTU95 17793 ELSEIF(J.EQ.5)THEN 17794 AMAT(J,3)=CUTU99 17795 ELSEIF(J.EQ.6)THEN 17796 AMAT(J,3)=CTU999 17797 ENDIF 17798 IVALUE(J,4)(1:6)='REJECT' 17799 IF(ABS(STATVA).LT.AMAT(J,3))THEN 17800 IVALUE(J,4)(1:6)='ACCEPT' 17801 ENDIF 17802 NCVALU(J,4)=6 17803C 17804 ALPHAT=100.0*ALPHA(J) 17805 WRITE(IVALUE(J,1)(1:4),'(F4.1)')ALPHAT 17806 IVALUE(J,1)(5:5)='%' 17807 NCVALU(J,1)=5 17808 2160 CONTINUE 17809C 17810 ICNT=NUMALP 17811 NUMLIN=3 17812 NUMCOL=4 17813 IFRST=.TRUE. 17814 ILAST=.TRUE. 17815 IFLAGS=.TRUE. 17816 IFLAGE=.TRUE. 17817 IF(ICASA3.NE.'LOWE' .AND. ICASA3.NE.'UPPE')THEN 17818 CALL DPDTA5(ITITLE,NCTITL, 17819 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 17820 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 17821 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 17822 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 17823 1 ICAPSW,ICAPTY,IFRST,ILAST, 17824 1 IFLAGS,IFLAGE, 17825 1 ISUBRO,IBUGA3,IERROR) 17826 ENDIF 17827 IF(ICASA3.EQ.'TWOT')GOTO9000 17828C 17829 ITITLE='Lower One-Tailed Test' 17830 NCTITL=21 17831 ITITL9='H0: u = m0; Ha: u < m0' 17832 NCTIT9=22 17833C 17834 ITITL2(2,3)='Critical' 17835 NCTIT2(2,3)=8 17836 ITITL2(3,3)='Value (<)' 17837 NCTIT2(3,3)=9 17838C 17839 NMAX=0 17840 NUMCOL=4 17841 DO2250I=1,NUMCOL 17842 NTOT(I)=15 17843 NMAX=NMAX+NTOT(I) 17844 2250 CONTINUE 17845C 17846 DO2260J=1,NUMALP 17847 ALPHAT=1.0 - ALPHA(J) 17848 CALL TPPF(ALPHAT,STATNU,ATEMP) 17849 AMAT(J,3)=ATEMP 17850 IVALUE(J,4)(1:6)='REJECT' 17851 IF(STATVA.GE.AMAT(J,3))THEN 17852 IVALUE(J,4)(1:6)='ACCEPT' 17853 ENDIF 17854 NCVALU(J,4)=6 17855 2260 CONTINUE 17856C 17857 ICNT=NUMALP 17858 NUMLIN=3 17859 IFRST=.TRUE. 17860 ILAST=.TRUE. 17861 IFLAGS=.TRUE. 17862 IFLAGE=.TRUE. 17863 IF(ICASA3.NE.'UPPE')THEN 17864 CALL DPDTA5(ITITLE,NCTITL, 17865 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 17866 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 17867 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 17868 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 17869 1 ICAPSW,ICAPTY,IFRST,ILAST, 17870 1 IFLAGS,IFLAGE, 17871 1 ISUBRO,IBUGA3,IERROR) 17872 ENDIF 17873C 17874 IF(ICASA3.EQ.'LOWE')GOTO9000 17875C 17876 ITITLE='Upper One-Tailed Test' 17877 NCTITL=21 17878 ITITL9='H0: u = m0; Ha: u > m0' 17879 NCTIT9=22 17880C 17881 ITITL2(2,3)='Critical' 17882 NCTIT2(2,3)=8 17883 ITITL2(3,3)='Value (>)' 17884 NCTIT2(3,3)=9 17885C 17886 NMAX=0 17887 NUMCOL=4 17888 DO2350I=1,NUMCOL 17889 NTOT(I)=15 17890 NMAX=NMAX+NTOT(I) 17891 2350 CONTINUE 17892C 17893 DO2360J=1,NUMALP 17894 ALPHAT=ALPHA(J) 17895 CALL TPPF(ALPHAT,STATNU,ATEMP) 17896 AMAT(J,3)=ATEMP 17897 IVALUE(J,4)(1:6)='REJECT' 17898 IF(STATVA.LE.AMAT(J,3))THEN 17899 IVALUE(J,4)(1:6)='ACCEPT' 17900 ENDIF 17901 NCVALU(J,4)=6 17902 2360 CONTINUE 17903C 17904 ICNT=NUMALP 17905 NUMLIN=3 17906 IFRST=.TRUE. 17907 ILAST=.TRUE. 17908 IFLAGS=.TRUE. 17909 IFLAGE=.TRUE. 17910 CALL DPDTA5(ITITLE,NCTITL, 17911 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 17912 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 17913 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 17914 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 17915 1 ICAPSW,ICAPTY,IFRST,ILAST, 17916 1 IFLAGS,IFLAGE, 17917 1 ISUBRO,IBUGA3,IERROR) 17918C 17919 GOTO9000 17920C 17921C **************************************** 17922C ** STEP 31-- ** 17923C ** CARRY OUT CALCULATIONS ** 17924C ** FOR AN UNPAIRED 2-SAMPLE T TEST ** 17925C **************************************** 17926C 17927 3100 CONTINUE 17928C 17929 ISTEPN='31' 17930 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TTE2') 17931 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17932C 17933 CALL DPTTE4(Y1,N1,Y2,N2,IWRITE, 17934 1 STATVA,STATCD,STATNU, 17935 1 STATV2,STATC2,STATN2, 17936 1 Y1MEAN,Y1SD,Y1SDM, 17937 1 Y2MEAN,Y2SD,Y2SDM, 17938 1 DEL,POOLSD,DELSD,DELSD2,CDFBAR, 17939 1 PVAL2T,PVALLT,PVALUT, 17940 1 ISUBRO,IBUGA3,IERROR) 17941 IF(IERROR.EQ.'YES')GOTO9000 17942C 17943C ****************************** 17944C ** STEP 32-- ** 17945C ** WRITE OUT EVERYTHING ** 17946C ** FOR A 2-SAMPLE T TEST ** 17947C ****************************** 17948C 17949 ISTEPN='32' 17950 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TTE2') 17951 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17952C 17953 IF(IPRINT.EQ.'OFF')GOTO9000 17954C 17955 ITITLE='Two Sample t-Test for Equal Means' 17956 NCTITL=34 17957 ITITLZ=' ' 17958 NCTITZ=0 17959C 17960 ICNT=1 17961 ITEXT(ICNT)=' ' 17962 NCTEXT(ICNT)=0 17963 AVALUE(ICNT)=0.0 17964 IDIGIT(ICNT)=-1 17965C 17966 ICNT=ICNT+1 17967 ITEXT(ICNT)='First Response Variable: ' 17968 WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARID(1:4) 17969 WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARI2(1:4) 17970 NCTEXT(ICNT)=34 17971 AVALUE(ICNT)=0.0 17972 IDIGIT(ICNT)=-1 17973C 17974 ICNT=ICNT+1 17975 ITEXT(ICNT)='Second Response Variable: ' 17976 WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARI3(1:4) 17977 WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARI4(1:4) 17978 NCTEXT(ICNT)=34 17979 AVALUE(ICNT)=0.0 17980 IDIGIT(ICNT)=-1 17981C 17982 ICNT=ICNT+1 17983 ITEXT(ICNT)=' ' 17984 NCTEXT(ICNT)=0 17985 AVALUE(ICNT)=0.0 17986 IDIGIT(ICNT)=-1 17987C 17988 ICNT=ICNT+1 17989 ITEXT(ICNT)='H0: Population Means Are Equal (u1=u2)' 17990 NCTEXT(ICNT)=30 17991 AVALUE(ICNT)=0.0 17992 IDIGIT(ICNT)=-1 17993 ICNT=ICNT+1 17994 ITEXT(ICNT)='Ha: Population Means Are Not Equal' 17995 NCTEXT(ICNT)=34 17996 AVALUE(ICNT)=0.0 17997 IDIGIT(ICNT)=-1 17998C 17999 ICNT=ICNT+1 18000 ITEXT(ICNT)=' ' 18001 NCTEXT(ICNT)=1 18002 AVALUE(ICNT)=0.0 18003 IDIGIT(ICNT)=-1 18004C 18005 ICNT=ICNT+1 18006 ITEXT(ICNT)='Sample One Summary Statistics:' 18007 NCTEXT(ICNT)=30 18008 AVALUE(ICNT)=0.0 18009 IDIGIT(ICNT)=-1 18010 ICNT=ICNT+1 18011 ITEXT(ICNT)='Number of Observations:' 18012 NCTEXT(ICNT)=23 18013 AVALUE(ICNT)=REAL(N1) 18014 IDIGIT(ICNT)=0 18015 ICNT=ICNT+1 18016 ITEXT(ICNT)='Sample Mean:' 18017 NCTEXT(ICNT)=12 18018 AVALUE(ICNT)=Y1MEAN 18019 IDIGIT(ICNT)=NUMDIG 18020 ICNT=ICNT+1 18021 ITEXT(ICNT)='Sample Standard Deviation:' 18022 NCTEXT(ICNT)=26 18023 AVALUE(ICNT)=Y1SD 18024 IDIGIT(ICNT)=NUMDIG 18025 ICNT=ICNT+1 18026 ITEXT(ICNT)='Sample Standard Deviation of the Mean:' 18027 NCTEXT(ICNT)=38 18028 AVALUE(ICNT)=Y1SDM 18029 IDIGIT(ICNT)=NUMDIG 18030 ICNT=ICNT+1 18031 ITEXT(ICNT)=' ' 18032 NCTEXT(ICNT)=1 18033 AVALUE(ICNT)=0.0 18034 IDIGIT(ICNT)=-1 18035C 18036 ICNT=ICNT+1 18037 ITEXT(ICNT)='Sample Two Summary Statistics:' 18038 NCTEXT(ICNT)=30 18039 AVALUE(ICNT)=0.0 18040 IDIGIT(ICNT)=-1 18041 ICNT=ICNT+1 18042 ITEXT(ICNT)='Number of Observations:' 18043 NCTEXT(ICNT)=23 18044 AVALUE(ICNT)=REAL(N2) 18045 IDIGIT(ICNT)=0 18046 ICNT=ICNT+1 18047 ITEXT(ICNT)='Sample Mean:' 18048 NCTEXT(ICNT)=12 18049 AVALUE(ICNT)=Y2MEAN 18050 IDIGIT(ICNT)=NUMDIG 18051 ICNT=ICNT+1 18052 ITEXT(ICNT)='Sample Standard Deviation:' 18053 NCTEXT(ICNT)=26 18054 AVALUE(ICNT)=Y2SD 18055 IDIGIT(ICNT)=NUMDIG 18056 ICNT=ICNT+1 18057 ITEXT(ICNT)='Sample Standard Deviation of the Mean:' 18058 NCTEXT(ICNT)=38 18059 AVALUE(ICNT)=Y2SDM 18060 IDIGIT(ICNT)=NUMDIG 18061 ICNT=ICNT+1 18062 ITEXT(ICNT)=' ' 18063 NCTEXT(ICNT)=1 18064 AVALUE(ICNT)=0.0 18065 IDIGIT(ICNT)=-1 18066C 18067 IF(ITTEVA.EQ.'EQUA' .OR. ITTEVA.EQ.'BOTH')THEN 18068 ICNT=ICNT+1 18069 ITEXT(ICNT)='Test When Assume Equal Variances:' 18070 NCTEXT(ICNT)=33 18071 AVALUE(ICNT)=0.0 18072 IDIGIT(ICNT)=-1 18073 ICNT=ICNT+1 18074 ITEXT(ICNT)='Pooled Standard Deviation:' 18075 NCTEXT(ICNT)=26 18076 AVALUE(ICNT)=POOLSD 18077 IDIGIT(ICNT)=NUMDIG 18078 ICNT=ICNT+1 18079 ITEXT(ICNT)='Difference (Delta) in Means:' 18080 NCTEXT(ICNT)=28 18081 AVALUE(ICNT)=DEL 18082 IDIGIT(ICNT)=NUMDIG 18083 ICNT=ICNT+1 18084 ITEXT(ICNT)='Standard Deviation of Delta:' 18085 NCTEXT(ICNT)=28 18086 AVALUE(ICNT)=DELSD 18087 IDIGIT(ICNT)=NUMDIG 18088 ICNT=ICNT+1 18089 ITEXT(ICNT)='t-Test Statistic Value:' 18090 NCTEXT(ICNT)=23 18091 AVALUE(ICNT)=STATVA 18092 IDIGIT(ICNT)=NUMDIG 18093 ICNT=ICNT+1 18094 ITEXT(ICNT)='Degrees of Freedom:' 18095 NCTEXT(ICNT)=19 18096 AVALUE(ICNT)=STATNU 18097 IDIGIT(ICNT)=0 18098 ICNT=ICNT+1 18099 ITEXT(ICNT)='CDF Value:' 18100 NCTEXT(ICNT)=10 18101 AVALUE(ICNT)=STATCD 18102 IDIGIT(ICNT)=NUMDIG 18103 ICNT=ICNT+1 18104 ITEXT(ICNT)='P-Value (2-tailed test):' 18105 NCTEXT(ICNT)=24 18106 IF(STATVA.LE.0.0)THEN 18107 ATEMP=2.0*STATCD 18108 ELSE 18109 ATEMP=2.0*(1.0-STATCD) 18110 ENDIF 18111 AVALUE(ICNT)=ATEMP 18112 IDIGIT(ICNT)=NUMDIG 18113 ICNT=ICNT+1 18114 ITEXT(ICNT)='P-Value (lower-tailed test):' 18115 NCTEXT(ICNT)=28 18116 AVALUE(ICNT)=STATCD 18117 IDIGIT(ICNT)=NUMDIG 18118 ICNT=ICNT+1 18119 ITEXT(ICNT)='P-Value (upper-tailed test):' 18120 NCTEXT(ICNT)=28 18121 AVALUE(ICNT)=1.0 - STATCD 18122 IDIGIT(ICNT)=NUMDIG 18123 ICNT=ICNT+1 18124 ITEXT(ICNT)=' ' 18125 NCTEXT(ICNT)=1 18126 AVALUE(ICNT)=0.0 18127 IDIGIT(ICNT)=-1 18128 ENDIF 18129C 18130 IF(ITTEVA.EQ.'UNEQ' .OR. ITTEVA.EQ.'BOTH')THEN 18131 ICNT=ICNT+1 18132 ITEXT(ICNT)='Test When Assume Unequal Variances:' 18133 NCTEXT(ICNT)=35 18134 AVALUE(ICNT)=0.0 18135 IDIGIT(ICNT)=-1 18136 ICNT=ICNT+1 18137 ITEXT(ICNT)='Bartlett CDF Value:' 18138 NCTEXT(ICNT)=19 18139 AVALUE(ICNT)=CDFBAR 18140 IDIGIT(ICNT)=NUMDIG 18141 ICNT=ICNT+1 18142 ITEXT(ICNT)='Difference (Delta) in Means:' 18143 NCTEXT(ICNT)=28 18144 AVALUE(ICNT)=DEL 18145 IDIGIT(ICNT)=NUMDIG 18146 ICNT=ICNT+1 18147 ITEXT(ICNT)='Standard Deviation of Delta:' 18148 NCTEXT(ICNT)=28 18149 AVALUE(ICNT)=DELSD2 18150 IDIGIT(ICNT)=NUMDIG 18151 ICNT=ICNT+1 18152 ITEXT(ICNT)='t-Test Statistic Value:' 18153 NCTEXT(ICNT)=23 18154 AVALUE(ICNT)=STATV2 18155 IDIGIT(ICNT)=NUMDIG 18156 ICNT=ICNT+1 18157 ITEXT(ICNT)='Degrees of Freedom:' 18158 NCTEXT(ICNT)=19 18159 AVALUE(ICNT)=STATN2 18160 IDIGIT(ICNT)=0 18161 ICNT=ICNT+1 18162 ITEXT(ICNT)='CDF Value:' 18163 NCTEXT(ICNT)=10 18164 AVALUE(ICNT)=STATC2 18165 IDIGIT(ICNT)=NUMDIG 18166 ICNT=ICNT+1 18167 ITEXT(ICNT)='P-Value (2-tailed test):' 18168 NCTEXT(ICNT)=24 18169 AVALUE(ICNT)=PVAL2T 18170 IDIGIT(ICNT)=NUMDIG 18171 ICNT=ICNT+1 18172 ITEXT(ICNT)='P-Value (lower-tailed test):' 18173 NCTEXT(ICNT)=28 18174 AVALUE(ICNT)=PVALLT 18175 IDIGIT(ICNT)=NUMDIG 18176 ICNT=ICNT+1 18177 ITEXT(ICNT)='P-Value (upper-tailed test):' 18178 NCTEXT(ICNT)=28 18179 AVALUE(ICNT)=PVALUT 18180 IDIGIT(ICNT)=NUMDIG 18181 ENDIF 18182C 18183 NUMROW=ICNT 18184 DO3110I=1,NUMROW 18185 NTOT(I)=15 18186 3110 CONTINUE 18187C 18188 IFRST=.TRUE. 18189 ILAST=.TRUE. 18190C 18191 ISTEPN='31A' 18192 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TTE2') 18193 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18194C 18195 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT, 18196 1 AVALUE,IDIGIT, 18197 1 NTOT,NUMROW, 18198 1 ICAPSW,ICAPTY,ILAST,IFRST, 18199 1 ISUBRO,IBUGA3,IERROR) 18200C 18201 ISTEPN='31B' 18202 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TTE2') 18203 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18204C 18205 DO3199ICASE=1,2 18206C 18207 IF(ICASE.EQ.1 .AND. ITTEVA.EQ.'UNEQ')GOTO3199 18208 IF(ICASE.EQ.2 .AND. ITTEVA.EQ.'EQUA')GOTO3199 18209C 18210 IF(ICASE.EQ.1)THEN 18211 ITITLE='Two-Tailed Test (Assume Equal Variances)' 18212 NCTITL=40 18213 STATV=STATVA 18214 STATC=STATCD 18215 STATN=STATNU 18216 PVALL=STATCD 18217 PVALU=1.0 - STATCD 18218 IF(STATVA.LE.0.0)THEN 18219 PVAL2=2.0*STATCD 18220 ELSE 18221 PVAL2=2.0*(1.0 - STATCD) 18222 ENDIF 18223 ELSEIF(ICASE.EQ.2)THEN 18224 ITITLE='Two-Tailed Test (Assume Unequal Variances)' 18225 NCTITL=42 18226 STATV=STATV2 18227 STATC=STATC2 18228 STATN=STATN2 18229 PVAL2=PVAL2T 18230 PVALL=PVALLT 18231 PVALU=PVALUT 18232 ENDIF 18233C 18234 CALL TPPF(.0005,STATN,CTL999) 18235 CALL TPPF(.005,STATN,CUTL99) 18236 CALL TPPF(.025,STATN,CUTL95) 18237 CALL TPPF(.05,STATN,CUTL90) 18238 CALL TPPF(.1,STATN,CUTL80) 18239 CALL TPPF(.25,STATN,CUTL50) 18240 CALL TPPF(.75,STATN,CUTU50) 18241 CALL TPPF(.90,STATN,CUTU80) 18242 CALL TPPF(.95,STATN,CUTU90) 18243 CALL TPPF(.975,STATN,CUTU95) 18244 CALL TPPF(.995,STATN,CUTU99) 18245 CALL TPPF(.9995,STATN,CTU999) 18246C 18247 ITITL9='H0: u1 = u2; Ha: u1 <> u2' 18248 NCTIT9=25 18249C 18250 DO3130J=1,4 18251 DO3140I=1,3 18252 ITITL2(I,J)=' ' 18253 NCTIT2(I,J)=0 18254 3140 CONTINUE 18255 3130 CONTINUE 18256C 18257 ITITL2(2,1)='Significance' 18258 NCTIT2(2,1)=12 18259 ITITL2(3,1)='Level' 18260 NCTIT2(3,1)=5 18261C 18262 ITITL2(2,2)='Test ' 18263 NCTIT2(2,2)=4 18264 ITITL2(3,2)='Statistic' 18265 NCTIT2(3,2)=9 18266C 18267 ITITL2(2,3)='Critical' 18268 NCTIT2(2,3)=8 18269 ITITL2(3,3)='Value (+/-)' 18270 NCTIT2(3,3)=11 18271C 18272 ITITL2(1,4)='Null' 18273 NCTIT2(1,4)=4 18274 ITITL2(2,4)='Hypothesis' 18275 NCTIT2(2,4)=10 18276 ITITL2(3,4)='Conclusion' 18277 NCTIT2(3,4)=10 18278C 18279 NMAX=0 18280 NUMCOL=4 18281 DO3150I=1,NUMCOL 18282 VALIGN(I)='b' 18283 ALIGN(I)='r' 18284 NTOT(I)=15 18285 NMAX=NMAX+NTOT(I) 18286 ITYPCO(I)='NUME' 18287 IDIGIT(I)=NUMDIG 18288 IF(I.EQ.1 .OR. I.EQ.4)THEN 18289 ITYPCO(I)='ALPH' 18290 ENDIF 18291 3150 CONTINUE 18292C 18293 IWHTML(1)=125 18294 IWHTML(2)=175 18295 IWHTML(3)=175 18296 IWHTML(4)=175 18297 IINC=1800 18298 IINC2=1400 18299 IWRTF(1)=IINC 18300 IWRTF(2)=IWRTF(1)+IINC 18301 IWRTF(3)=IWRTF(2)+IINC 18302 IWRTF(4)=IWRTF(3)+IINC 18303C 18304 DO3160J=1,NUMALP 18305 AMAT(J,2)=STATV 18306 IF(J.EQ.1)THEN 18307 AMAT(J,3)=CUTU50 18308 ELSEIF(J.EQ.2)THEN 18309 AMAT(J,3)=CUTU80 18310 ELSEIF(J.EQ.3)THEN 18311 AMAT(J,3)=CUTU90 18312 ELSEIF(J.EQ.4)THEN 18313 AMAT(J,3)=CUTU95 18314 ELSEIF(J.EQ.5)THEN 18315 AMAT(J,3)=CUTU99 18316 ELSEIF(J.EQ.6)THEN 18317 AMAT(J,3)=CTU999 18318 ENDIF 18319 IVALUE(J,4)(1:6)='REJECT' 18320 IF(ABS(STATV).LT.AMAT(J,3))THEN 18321 IVALUE(J,4)(1:6)='ACCEPT' 18322 ENDIF 18323 NCVALU(J,4)=6 18324C 18325 ALPHAT=100.0*ALPHA(J) 18326 WRITE(IVALUE(J,1)(1:4),'(F4.1)')ALPHAT 18327 IVALUE(J,1)(5:5)='%' 18328 NCVALU(J,1)=5 18329 3160 CONTINUE 18330C 18331 ICNT=NUMALP 18332 NUMLIN=3 18333 IFRST=.TRUE. 18334 ILAST=.TRUE. 18335 IFLAGS=.TRUE. 18336 IFLAGE=.TRUE. 18337 IF(ICASA3.NE.'LOWE' .AND. ICASA3.NE.'UPPE')THEN 18338 CALL DPDTA5(ITITLE,NCTITL, 18339 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 18340 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 18341 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 18342 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 18343 1 ICAPSW,ICAPTY,IFRST,ILAST, 18344 1 IFLAGS,IFLAGE, 18345 1 ISUBRO,IBUGA3,IERROR) 18346 ENDIF 18347 IF(ICASA3.EQ.'TWOT')GOTO3199 18348C 18349 IF(ICASE.EQ.1)THEN 18350 ITITLE='Lower One-Tailed Test (Assume Equal Variances)' 18351 NCTITL=46 18352 ELSEIF(ICASE.EQ.2)THEN 18353 ITITLE='Lower One-Tailed Test (Assume Unequal Variances)' 18354 NCTITL=48 18355 ENDIF 18356C 18357 ITITL9='H0: u1 = u2; Ha: u1 < u2' 18358 NCTIT9=24 18359C 18360 ITITL2(2,3)='Critical' 18361 NCTIT2(2,3)=8 18362 ITITL2(3,3)='Value (<)' 18363 NCTIT2(3,3)=9 18364C 18365 NMAX=0 18366 NUMCOL=4 18367 DO3250I=1,NUMCOL 18368 NTOT(I)=15 18369 NMAX=NMAX+NTOT(I) 18370 3250 CONTINUE 18371C 18372 DO3260J=1,NUMALP 18373 ALPHAT=ALPHA(J) 18374 CALL TPPF(ALPHAT,STATN,ATEMP) 18375 AMAT(J,3)=-ATEMP 18376 IVALUE(J,4)(1:6)='REJECT' 18377 IF(STATV.GE.AMAT(J,3))THEN 18378 IVALUE(J,4)(1:6)='ACCEPT' 18379 ENDIF 18380 NCVALU(J,4)=6 18381 3260 CONTINUE 18382C 18383 ICNT=NUMALP 18384 NUMLIN=3 18385 IFRST=.TRUE. 18386 ILAST=.TRUE. 18387 IFLAGS=.TRUE. 18388 IFLAGE=.TRUE. 18389 IF(ICASA3.NE.'UPPE')THEN 18390 CALL DPDTA5(ITITLE,NCTITL, 18391 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 18392 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 18393 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 18394 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 18395 1 ICAPSW,ICAPTY,IFRST,ILAST, 18396 1 IFLAGS,IFLAGE, 18397 1 ISUBRO,IBUGA3,IERROR) 18398 ENDIF 18399C 18400 IF(ICASA3.EQ.'LOWE')GOTO3199 18401C 18402 IF(ICASE.EQ.1)THEN 18403 ITITLE='Upper One-Tailed Test (Assume Equal Variances)' 18404 NCTITL=46 18405 ELSEIF(ICASE.EQ.2)THEN 18406 ITITLE='Upper One-Tailed Test (Assume Unequal Variances)' 18407 NCTITL=48 18408 ENDIF 18409C 18410 ITITL9='H0: u1 = u2; Ha: u1 > u2' 18411 NCTIT9=24 18412C 18413 ITITL2(2,3)='Critical' 18414 NCTIT2(2,3)=8 18415 ITITL2(3,3)='Value (>)' 18416 NCTIT2(3,3)=9 18417C 18418 NMAX=0 18419 NUMCOL=4 18420 DO3350I=1,NUMCOL 18421 NTOT(I)=15 18422 NMAX=NMAX+NTOT(I) 18423 3350 CONTINUE 18424C 18425 DO3360J=1,NUMALP 18426 ALPHAT=ALPHA(J) 18427 CALL TPPF(ALPHAT,STATN,ATEMP) 18428 AMAT(J,3)=ATEMP 18429 IVALUE(J,4)(1:6)='REJECT' 18430 IF(STATV.LE.AMAT(J,3))THEN 18431 IVALUE(J,4)(1:6)='ACCEPT' 18432 ENDIF 18433 NCVALU(J,4)=6 18434 3360 CONTINUE 18435C 18436 ICNT=NUMALP 18437 NUMLIN=3 18438 IFRST=.TRUE. 18439 ILAST=.TRUE. 18440 IFLAGS=.TRUE. 18441 IFLAGE=.TRUE. 18442 CALL DPDTA5(ITITLE,NCTITL, 18443 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 18444 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 18445 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 18446 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 18447 1 ICAPSW,ICAPTY,IFRST,ILAST, 18448 1 IFLAGS,IFLAGE, 18449 1 ISUBRO,IBUGA3,IERROR) 18450C 18451 3199 CONTINUE 18452C 18453 GOTO9000 18454C 18455 4100 CONTINUE 18456C 18457 ISTEPN='41' 18458 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TTE2') 18459 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18460C 18461 CALL DPTTE6(Y1,N1,Y2,N2,XTEMP1,IWRITE, 18462 1 STATVA,STATCD,STATNU, 18463 1 Y1MEAN,Y1SD,Y1SDM, 18464 1 Y2MEAN,Y2SD,Y2SDM, 18465 1 YDMEAN,YDSD,YDSDM, 18466 1 PVAL2T,PVALLT,PVALUT, 18467 1 ISUBRO,IBUGA3,IERROR) 18468 IF(IERROR.EQ.'YES')GOTO9000 18469C 18470 CALL TPPF(.0005,STATNU,CTL999) 18471 CALL TPPF(.005,STATNU,CUTL99) 18472 CALL TPPF(.025,STATNU,CUTL95) 18473 CALL TPPF(.05,STATNU,CUTL90) 18474 CALL TPPF(.1,STATNU,CUTL80) 18475 CALL TPPF(.25,STATNU,CUTL50) 18476 CALL TPPF(.75,STATNU,CUTU50) 18477 CALL TPPF(.90,STATNU,CUTU80) 18478 CALL TPPF(.95,STATNU,CUTU90) 18479 CALL TPPF(.975,STATNU,CUTU95) 18480 CALL TPPF(.995,STATNU,CUTU99) 18481 CALL TPPF(.9995,STATNU,CTU999) 18482C 18483C ****************************** 18484C ** STEP 32-- ** 18485C ** WRITE OUT EVERYTHING ** 18486C ** FOR A 2-SAMPLE T TEST ** 18487C ****************************** 18488C 18489 ISTEPN='42' 18490 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TTE2') 18491 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18492C 18493 IF(IPRINT.EQ.'OFF')GOTO9000 18494C 18495 ITITLE='Two Sample Paired t-Test for Equal Means' 18496 NCTITL=41 18497 ITITLZ=' ' 18498 NCTITZ=0 18499C 18500 ICNT=1 18501 ITEXT(ICNT)=' ' 18502 NCTEXT(ICNT)=0 18503 AVALUE(ICNT)=0.0 18504 IDIGIT(ICNT)=-1 18505C 18506 ICNT=ICNT+1 18507 ITEXT(ICNT)='First Response Variable: ' 18508 WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARID(1:4) 18509 WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARI2(1:4) 18510 NCTEXT(ICNT)=34 18511 AVALUE(ICNT)=0.0 18512 IDIGIT(ICNT)=-1 18513C 18514 ICNT=ICNT+1 18515 ITEXT(ICNT)='Second Response Variable: ' 18516 WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARI3(1:4) 18517 WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARI4(1:4) 18518 NCTEXT(ICNT)=34 18519 AVALUE(ICNT)=0.0 18520 IDIGIT(ICNT)=-1 18521C 18522 ICNT=ICNT+1 18523 ITEXT(ICNT)=' ' 18524 NCTEXT(ICNT)=0 18525 AVALUE(ICNT)=0.0 18526 IDIGIT(ICNT)=-1 18527C 18528 ICNT=ICNT+1 18529 ITEXT(ICNT)='H0: Population Means Are Equal (u1=u2)' 18530 NCTEXT(ICNT)=30 18531 AVALUE(ICNT)=0.0 18532 IDIGIT(ICNT)=-1 18533 ICNT=ICNT+1 18534 ITEXT(ICNT)='Ha: Population Means Are Not Equal' 18535 NCTEXT(ICNT)=34 18536 AVALUE(ICNT)=0.0 18537 IDIGIT(ICNT)=-1 18538C 18539 ICNT=ICNT+1 18540 ITEXT(ICNT)=' ' 18541 NCTEXT(ICNT)=1 18542 AVALUE(ICNT)=0.0 18543 IDIGIT(ICNT)=-1 18544C 18545 ICNT=ICNT+1 18546 ITEXT(ICNT)='Sample One Summary Statistics:' 18547 NCTEXT(ICNT)=30 18548 AVALUE(ICNT)=0.0 18549 IDIGIT(ICNT)=-1 18550 ICNT=ICNT+1 18551 ITEXT(ICNT)='Number of Observations:' 18552 NCTEXT(ICNT)=23 18553 AVALUE(ICNT)=REAL(N1) 18554 IDIGIT(ICNT)=0 18555 ICNT=ICNT+1 18556 ITEXT(ICNT)='Sample Mean:' 18557 NCTEXT(ICNT)=12 18558 AVALUE(ICNT)=Y1MEAN 18559 IDIGIT(ICNT)=NUMDIG 18560 ICNT=ICNT+1 18561 ITEXT(ICNT)='Sample Standard Deviation:' 18562 NCTEXT(ICNT)=26 18563 AVALUE(ICNT)=Y1SD 18564 IDIGIT(ICNT)=NUMDIG 18565 ICNT=ICNT+1 18566 ITEXT(ICNT)=' ' 18567 NCTEXT(ICNT)=1 18568 AVALUE(ICNT)=0.0 18569 IDIGIT(ICNT)=-1 18570C 18571 ICNT=ICNT+1 18572 ITEXT(ICNT)='Sample Two Summary Statistics:' 18573 NCTEXT(ICNT)=30 18574 AVALUE(ICNT)=0.0 18575 IDIGIT(ICNT)=-1 18576 ICNT=ICNT+1 18577 ITEXT(ICNT)='Number of Observations:' 18578 NCTEXT(ICNT)=23 18579 AVALUE(ICNT)=REAL(N2) 18580 IDIGIT(ICNT)=0 18581 ICNT=ICNT+1 18582 ITEXT(ICNT)='Sample Mean:' 18583 NCTEXT(ICNT)=12 18584 AVALUE(ICNT)=Y2MEAN 18585 IDIGIT(ICNT)=NUMDIG 18586 ICNT=ICNT+1 18587 ITEXT(ICNT)='Sample Standard Deviation:' 18588 NCTEXT(ICNT)=26 18589 AVALUE(ICNT)=Y2SD 18590 IDIGIT(ICNT)=NUMDIG 18591 ICNT=ICNT+1 18592 ITEXT(ICNT)=' ' 18593 NCTEXT(ICNT)=1 18594 AVALUE(ICNT)=0.0 18595 IDIGIT(ICNT)=-1 18596C 18597 ICNT=ICNT+1 18598 ITEXT(ICNT)='Summary Statistics of Paired Data:' 18599 NCTEXT(ICNT)=34 18600 AVALUE(ICNT)=0.0 18601 IDIGIT(ICNT)=-1 18602 ICNT=ICNT+1 18603 ITEXT(ICNT)='Number of Observations:' 18604 NCTEXT(ICNT)=23 18605 AVALUE(ICNT)=REAL(N1) 18606 IDIGIT(ICNT)=0 18607 ICNT=ICNT+1 18608 ITEXT(ICNT)='Sample Mean:' 18609 NCTEXT(ICNT)=12 18610 AVALUE(ICNT)=YDMEAN 18611 IDIGIT(ICNT)=NUMDIG 18612 ICNT=ICNT+1 18613 ITEXT(ICNT)='Sample Standard Deviation:' 18614 NCTEXT(ICNT)=26 18615 AVALUE(ICNT)=YDSD 18616 IDIGIT(ICNT)=NUMDIG 18617 ICNT=ICNT+1 18618 ITEXT(ICNT)='Sample Standard Deviation of the Mean:' 18619 NCTEXT(ICNT)=38 18620 AVALUE(ICNT)=YDSDM 18621 IDIGIT(ICNT)=NUMDIG 18622 ICNT=ICNT+1 18623 ITEXT(ICNT)=' ' 18624 NCTEXT(ICNT)=1 18625 AVALUE(ICNT)=0.0 18626 IDIGIT(ICNT)=-1 18627C 18628 ICNT=ICNT+1 18629 ITEXT(ICNT)='Test:' 18630 NCTEXT(ICNT)=5 18631 AVALUE(ICNT)=0.0 18632 IDIGIT(ICNT)=-1 18633 ICNT=ICNT+1 18634 ITEXT(ICNT)='Difference (Delta) in Means:' 18635 NCTEXT(ICNT)=28 18636 DEL=Y1MEAN-Y2MEAN 18637 AVALUE(ICNT)=DEL 18638 IDIGIT(ICNT)=NUMDIG 18639 ICNT=ICNT+1 18640 ITEXT(ICNT)='t-Test Statistic Value:' 18641 NCTEXT(ICNT)=23 18642 AVALUE(ICNT)=STATVA 18643 IDIGIT(ICNT)=NUMDIG 18644 ICNT=ICNT+1 18645 ITEXT(ICNT)='Degrees of Freedom:' 18646 NCTEXT(ICNT)=19 18647 AVALUE(ICNT)=STATNU 18648 IDIGIT(ICNT)=0 18649 ICNT=ICNT+1 18650 ITEXT(ICNT)='CDF Value:' 18651 NCTEXT(ICNT)=10 18652 AVALUE(ICNT)=STATCD 18653 IDIGIT(ICNT)=NUMDIG 18654 ICNT=ICNT+1 18655 ITEXT(ICNT)='P-Value (2-tailed test):' 18656 NCTEXT(ICNT)=24 18657 AVALUE(ICNT)=PVAL2T 18658 IDIGIT(ICNT)=NUMDIG 18659 ICNT=ICNT+1 18660 ITEXT(ICNT)='P-Value (lower-tailed test):' 18661 NCTEXT(ICNT)=28 18662 AVALUE(ICNT)=PVALLT 18663 IDIGIT(ICNT)=NUMDIG 18664 ICNT=ICNT+1 18665 ITEXT(ICNT)='P-Value (upper-tailed test):' 18666 NCTEXT(ICNT)=28 18667 AVALUE(ICNT)=PVALUT 18668 IDIGIT(ICNT)=NUMDIG 18669 NUMROW=ICNT 18670 DO4110I=1,NUMROW 18671 NTOT(I)=15 18672 4110 CONTINUE 18673C 18674 IFRST=.TRUE. 18675 ILAST=.TRUE. 18676C 18677 ISTEPN='31A' 18678 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TTE2') 18679 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18680C 18681 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT, 18682 1 AVALUE,IDIGIT, 18683 1 NTOT,NUMROW, 18684 1 ICAPSW,ICAPTY,ILAST,IFRST, 18685 1 ISUBRO,IBUGA3,IERROR) 18686C 18687 ISTEPN='31B' 18688 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TTE2') 18689 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18690C 18691 ITITLE='Two-Tailed Test' 18692 NCTITL=15 18693 ITITL9='H0: u1 = u2; Ha: u1 <> u2' 18694 NCTIT9=25 18695C 18696 DO4130J=1,4 18697 DO4140I=1,3 18698 ITITL2(I,J)=' ' 18699 NCTIT2(I,J)=0 18700 4140 CONTINUE 18701 4130 CONTINUE 18702C 18703 ITITL2(2,1)='Significance' 18704 NCTIT2(2,1)=12 18705 ITITL2(3,1)='Level' 18706 NCTIT2(3,1)=5 18707C 18708 ITITL2(2,2)='Test ' 18709 NCTIT2(2,2)=4 18710 ITITL2(3,2)='Statistic' 18711 NCTIT2(3,2)=9 18712C 18713 ITITL2(2,3)='Critical' 18714 NCTIT2(2,3)=8 18715 ITITL2(3,3)='Value (+/-)' 18716 NCTIT2(3,3)=11 18717C 18718 ITITL2(1,4)='Null' 18719 NCTIT2(1,4)=4 18720 ITITL2(2,4)='Hypothesis' 18721 NCTIT2(2,4)=10 18722 ITITL2(3,4)='Conclusion' 18723 NCTIT2(3,4)=10 18724C 18725 NMAX=0 18726 NUMCOL=4 18727 DO4150I=1,NUMCOL 18728 VALIGN(I)='b' 18729 ALIGN(I)='r' 18730 NTOT(I)=15 18731 NMAX=NMAX+NTOT(I) 18732 ITYPCO(I)='NUME' 18733 IDIGIT(I)=NUMDIG 18734 IF(I.EQ.1 .OR. I.EQ.4)THEN 18735 ITYPCO(I)='ALPH' 18736 ENDIF 18737 4150 CONTINUE 18738C 18739 IWHTML(1)=125 18740 IWHTML(2)=175 18741 IWHTML(3)=175 18742 IWHTML(4)=175 18743 IINC=1800 18744 IINC2=1400 18745 IWRTF(1)=IINC 18746 IWRTF(2)=IWRTF(1)+IINC 18747 IWRTF(3)=IWRTF(2)+IINC 18748 IWRTF(4)=IWRTF(3)+IINC 18749C 18750 DO4160J=1,NUMALP 18751 AMAT(J,2)=STATVA 18752 IF(J.EQ.1)THEN 18753 AMAT(J,3)=CUTU50 18754 ELSEIF(J.EQ.2)THEN 18755 AMAT(J,3)=CUTU80 18756 ELSEIF(J.EQ.3)THEN 18757 AMAT(J,3)=CUTU90 18758 ELSEIF(J.EQ.4)THEN 18759 AMAT(J,3)=CUTU95 18760 ELSEIF(J.EQ.5)THEN 18761 AMAT(J,3)=CUTU99 18762 ELSEIF(J.EQ.6)THEN 18763 AMAT(J,3)=CTU999 18764 ENDIF 18765 IVALUE(J,4)(1:6)='REJECT' 18766 IF(ABS(STATVA).LT.AMAT(J,3))THEN 18767 IVALUE(J,4)(1:6)='ACCEPT' 18768 ENDIF 18769 NCVALU(J,4)=6 18770C 18771 ALPHAT=100.0*ALPHA(J) 18772 WRITE(IVALUE(J,1)(1:4),'(F4.1)')ALPHAT 18773 IVALUE(J,1)(5:5)='%' 18774 NCVALU(J,1)=5 18775 4160 CONTINUE 18776C 18777 ICNT=NUMALP 18778 NUMLIN=3 18779 IFRST=.TRUE. 18780 ILAST=.TRUE. 18781 IFLAGS=.TRUE. 18782 IFLAGE=.TRUE. 18783 IF(ICASA3.NE.'LOWE' .AND. ICASA3.NE.'UPPE')THEN 18784 CALL DPDTA5(ITITLE,NCTITL, 18785 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 18786 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 18787 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 18788 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 18789 1 ICAPSW,ICAPTY,IFRST,ILAST, 18790 1 IFLAGS,IFLAGE, 18791 1 ISUBRO,IBUGA3,IERROR) 18792 ENDIF 18793 IF(ICASA3.EQ.'TWOT')GOTO9000 18794C 18795 ITITLE='Lower One-Tailed Test' 18796 NCTITL=21 18797 ITITL9='H0: u1 = u2; Ha: u1 < u2' 18798 NCTIT9=24 18799C 18800 ITITL2(2,3)='Critical' 18801 NCTIT2(2,3)=8 18802 ITITL2(3,3)='Value (<)' 18803 NCTIT2(3,3)=9 18804C 18805 NMAX=0 18806 NUMCOL=4 18807 DO4250I=1,NUMCOL 18808 NTOT(I)=15 18809 NMAX=NMAX+NTOT(I) 18810 4250 CONTINUE 18811C 18812 DO4260J=1,NUMALP 18813 ALPHAT=ALPHA(J) 18814 CALL TPPF(ALPHAT,STATNU,ATEMP) 18815 AMAT(J,3)=-ATEMP 18816 IVALUE(J,4)(1:6)='REJECT' 18817 IF(STATVA.GE.AMAT(J,3))THEN 18818 IVALUE(J,4)(1:6)='ACCEPT' 18819 ENDIF 18820 NCVALU(J,4)=6 18821 4260 CONTINUE 18822C 18823 ICNT=NUMALP 18824 NUMLIN=3 18825 IFRST=.TRUE. 18826 ILAST=.TRUE. 18827 IFLAGS=.TRUE. 18828 IFLAGE=.TRUE. 18829 IF(ICASA3.NE.'UPPE')THEN 18830 CALL DPDTA5(ITITLE,NCTITL, 18831 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 18832 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 18833 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 18834 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 18835 1 ICAPSW,ICAPTY,IFRST,ILAST, 18836 1 IFLAGS,IFLAGE, 18837 1 ISUBRO,IBUGA3,IERROR) 18838 ENDIF 18839C 18840 IF(ICASA3.EQ.'LOWE')GOTO9000 18841C 18842 ITITLE='Upper One-Tailed Test' 18843 NCTITL=21 18844 ITITL9='H0: u1 = u2; Ha: u1 > u2' 18845 NCTIT9=24 18846C 18847 ITITL2(2,3)='Critical' 18848 NCTIT2(2,3)=8 18849 ITITL2(3,3)='Value (>)' 18850 NCTIT2(3,3)=9 18851C 18852 NMAX=0 18853 NUMCOL=4 18854 DO4350I=1,NUMCOL 18855 NTOT(I)=15 18856 NMAX=NMAX+NTOT(I) 18857 4350 CONTINUE 18858C 18859 DO4360J=1,NUMALP 18860 ALPHAT=ALPHA(J) 18861 CALL TPPF(ALPHAT,STATNU,ATEMP) 18862 AMAT(J,3)=ATEMP 18863 IVALUE(J,4)(1:6)='REJECT' 18864 IF(STATVA.LE.AMAT(J,3))THEN 18865 IVALUE(J,4)(1:6)='ACCEPT' 18866 ENDIF 18867 NCVALU(J,4)=6 18868 4360 CONTINUE 18869C 18870 ICNT=NUMALP 18871 NUMLIN=3 18872 IFRST=.TRUE. 18873 ILAST=.TRUE. 18874 IFLAGS=.TRUE. 18875 IFLAGE=.TRUE. 18876 CALL DPDTA5(ITITLE,NCTITL, 18877 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 18878 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 18879 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 18880 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 18881 1 ICAPSW,ICAPTY,IFRST,ILAST, 18882 1 IFLAGS,IFLAGE, 18883 1 ISUBRO,IBUGA3,IERROR) 18884C 18885 GOTO9000 18886C ***************** 18887C ** STEP 90-- ** 18888C ** EXIT ** 18889C ***************** 18890C 18891 9000 CONTINUE 18892 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TTE2')THEN 18893 WRITE(ICOUT,999) 18894 CALL DPWRST('XXX','WRIT') 18895 WRITE(ICOUT,9011) 18896 9011 FORMAT('***** AT THE END OF DPTTE2--') 18897 CALL DPWRST('XXX','WRIT') 18898 WRITE(ICOUT,9013)STATVA,STATCD,PVAL2T,PVALLT,PVALUT 18899 9013 FORMAT('STATVA,STATCD,PVAL2T,PVALLT,PVALUT = ',5G15.7) 18900 CALL DPWRST('XXX','WRIT') 18901 ENDIF 18902C 18903 RETURN 18904 END 18905 SUBROUTINE DPTTE3(X,N,AMU,IWRITE,STATVA,STATCD,STATNU, 18906 1 XMEAN,XSD,XSDM,DEL, 18907 1 PVAL2T,PVALLT,PVALUT, 18908 1 ISUBRO,IBUGA3,IERROR) 18909C 18910C PURPOSE--THIS SUBROUTINE COMPUTES THE ONE SAMPLE T-TEST (AND 18911C ALTERNATIVELY THE CDF VALUE). 18912C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 18913C (UNSORTED OR SORTED) OBSERVATIONS. 18914C --N = THE INTEGER NUMBER OF OBSERVATIONS 18915C IN THE VECTOR X. 18916C --AMU = THE SINGLE PRECISION VALUE FOR WHICH 18917C THE TEST IS PERFORMED (I.E., 18918C H0: MU = AMU). 18919C OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE 18920C COMPUTED STATISTIC. 18921C --STATCD = THE SINGLE PRECISION VALUE OF THE 18922C COMPUTED CDF OF THE TEST STATISTIC. 18923C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE 18924C TEST STATISTIC. 18925C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 18926C OF N FOR THIS SUBROUTINE. 18927C OTHER DATAPAC SUBROUTINES NEEDED--TPPF. 18928C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 18929C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 18930C LANGUAGE--ANSI FORTRAN (1977) 18931C WRITTEN BY--JAMES J. FILLIBEN 18932C STATISTICAL ENGINEERING DIVISION 18933C INFORMATION TECHNOLOGY LABORATORY 18934C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 18935C GAITHERSBURG, MD 20899-8980 18936C PHONE--301-975-2855 18937C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 18938C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 18939C LANGUAGE--ANSI FORTRAN (1977) 18940C VERSION NUMBER--2009.2 18941C ORIGINAL VERSION--FEBRUARY 2009. 18942C 18943C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 18944C 18945 CHARACTER*4 IWRITE 18946 CHARACTER*4 IWRTSV 18947 CHARACTER*4 ISUBRO 18948 CHARACTER*4 IBUGA3 18949 CHARACTER*4 IERROR 18950C 18951 CHARACTER*4 ISUBN1 18952 CHARACTER*4 ISUBN2 18953C 18954C--------------------------------------------------------------------- 18955C 18956 DIMENSION X(*) 18957C 18958C-----COMMON---------------------------------------------------------- 18959C 18960 INCLUDE 'DPCOP2.INC' 18961C 18962C-----START POINT----------------------------------------------------- 18963C 18964 ISUBN1='DPTT' 18965 ISUBN2='E3 ' 18966 IWRTSV=IWRITE 18967C 18968 IERROR='NO' 18969C 18970 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TTE3')THEN 18971 WRITE(ICOUT,999) 18972 999 FORMAT(1X) 18973 CALL DPWRST('XXX','BUG ') 18974 WRITE(ICOUT,51) 18975 51 FORMAT('***** AT THE BEGINNING OF DPTTE3--') 18976 CALL DPWRST('XXX','BUG ') 18977 WRITE(ICOUT,52)IBUGA3 18978 52 FORMAT('IBUGA3 = ',A4) 18979 CALL DPWRST('XXX','BUG ') 18980 WRITE(ICOUT,53)N,ANU 18981 53 FORMAT('N,AMU = ',I8,G15.7) 18982 CALL DPWRST('XXX','BUG ') 18983 DO55I=1,N 18984 WRITE(ICOUT,56)I,X(I) 18985 56 FORMAT('I,X(I) = ',I8,G15.7) 18986 CALL DPWRST('XXX','BUG ') 18987 55 CONTINUE 18988 ENDIF 18989C 18990C ********************************* 18991C ** COMPUTE ONE SAMPLE T-TEST ** 18992C ********************************* 18993C 18994C ******************************************** 18995C ** STEP 1-- ** 18996C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 18997C ******************************************** 18998C 18999 STATVA=-99.0 19000 STATCD=-99.0 19001 STATNU=-99.0 19002 PVAL2T=-99.0 19003 PVALLT=-99.0 19004 PVALUT=-99.0 19005 IWRITE='OFF' 19006C 19007 AN=N 19008C 19009 IF(N.LE.1)THEN 19010 IERROR='YES' 19011 WRITE(ICOUT,999) 19012 CALL DPWRST('XXX','BUG ') 19013 WRITE(ICOUT,111) 19014 111 FORMAT('***** ERROR IN ONE SAMPLE T-TEST--') 19015 CALL DPWRST('XXX','BUG ') 19016 WRITE(ICOUT,112) 19017 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR THE ', 19018 1 'RESPONSE') 19019 CALL DPWRST('XXX','BUG ') 19020 WRITE(ICOUT,113) 19021 113 FORMAT(' VARIABLE MUST BE 2 OR LARGER.') 19022 CALL DPWRST('XXX','BUG ') 19023 WRITE(ICOUT,116) 19024 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') 19025 CALL DPWRST('XXX','BUG ') 19026 WRITE(ICOUT,117)N 19027 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 19028 1 '.') 19029 CALL DPWRST('XXX','BUG ') 19030 GOTO9000 19031 ENDIF 19032C 19033C ***************************************** 19034C ** STEP 2-- ** 19035C ** COMPUTE THE ONE SAMPLE T-TEST. ** 19036C ***************************************** 19037C 19038 CALL MEAN(X,N,IWRITE,XMEAN,IBUGA3,IERROR) 19039 CALL SD(X,N,IWRITE,XSD,IBUGA3,IERROR) 19040 CALL SDMEAN(X,N,IWRITE,XSDM,IBUGA3,IERROR) 19041 DEL=XMEAN-AMU 19042 STATVA=DEL/XSDM 19043 IDF=N-1 19044 STATNU=REAL(IDF) 19045 CALL TCDF(STATVA,STATNU,STATCD) 19046C 19047 PVALLT=STATCD 19048 PVALUT=1.0 - STATCD 19049 IF(STATVA.LE.0.0)THEN 19050 PVAL2T=2.0*PVALLT 19051 ELSE 19052 PVAL2T=2.0*PVALUT 19053 ENDIF 19054C 19055C ******************************* 19056C ** STEP 3-- ** 19057C ** WRITE OUT A LINE ** 19058C ** OF SUMMARY INFORMATION. ** 19059C ******************************* 19060C 19061 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 19062 WRITE(ICOUT,999) 19063 CALL DPWRST('XXX','BUG ') 19064 WRITE(ICOUT,811)N,STATVA 19065 811 FORMAT('THE VALUE OF THE ONE SAMPLE T-TEST OF THE ',I8, 19066 1 ' OBSERVATIONS = ',G15.7) 19067 CALL DPWRST('XXX','BUG ') 19068 ENDIF 19069C 19070C ***************** 19071C ** STEP 90-- ** 19072C ** EXIT. ** 19073C ***************** 19074C 19075 9000 CONTINUE 19076C 19077 IWRITE=IWRTSV 19078C 19079 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TTE3')THEN 19080 WRITE(ICOUT,999) 19081 CALL DPWRST('XXX','BUG ') 19082 WRITE(ICOUT,9011) 19083 9011 FORMAT('***** AT THE END OF DPTTE3--') 19084 CALL DPWRST('XXX','BUG ') 19085 WRITE(ICOUT,9012)IBUGA3,IERROR 19086 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 19087 CALL DPWRST('XXX','BUG ') 19088 WRITE(ICOUT,9015)STATVA,STATCD 19089 9015 FORMAT('STATVA,STATCD = ',2G15.7) 19090 CALL DPWRST('XXX','BUG ') 19091 WRITE(ICOUT,9016)XMEAN,XSD,XSDM 19092 9016 FORMAT('XMEAN,XSD,XSDM = ',3G15.7) 19093 CALL DPWRST('XXX','BUG ') 19094 ENDIF 19095C 19096 RETURN 19097 END 19098 SUBROUTINE DPTTE4(Y1,N1,Y2,N2,IWRITE, 19099 1 STATVA,STATCD,STATNU, 19100 1 STATV2,STATC2,STATN2, 19101 1 Y1MEAN,Y1SD,Y1SDM, 19102 1 Y2MEAN,Y2SD,Y2SDM, 19103 1 DEL,POOLSD,DELSD,DELSD2,CDFBAR, 19104 1 PVAL2T,PVALLT,PVALUT, 19105 1 ISUBRO,IBUGA3,IERROR) 19106C 19107C PURPOSE--THIS SUBROUTINE COMPUTES THE UNPAIRED TWO SAMPLE T-TEST 19108C (AND ALTERNATIVELY THE CDF OR P-VALUES). 19109C INPUT ARGUMENTS--Y1 = THE SINGLE PRECISION VECTOR OF 19110C (UNSORTED OR SORTED) OBSERVATIONS 19111C FOR THE FIRST RESPONSE VARIABLE. 19112C --N1 = THE INTEGER NUMBER OF OBSERVATIONS 19113C IN THE VECTOR Y1. 19114C --Y2 = THE SINGLE PRECISION VECTOR OF 19115C (UNSORTED OR SORTED) OBSERVATIONS 19116C FOR THE SECOND RESPONSE VARIABLE. 19117C --N2 = THE INTEGER NUMBER OF OBSERVATIONS 19118C IN THE VECTOR Y2. 19119C OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE 19120C COMPUTED STATISTIC. 19121C --STATCD = THE SINGLE PRECISION VALUE OF THE 19122C COMPUTED CDF OF THE TEST STATISTIC. 19123C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE 19124C TEST STATISTIC. 19125C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 19126C OF N FOR THIS SUBROUTINE. 19127C OTHER DATAPAC SUBROUTINES NEEDED--TPPF. 19128C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 19129C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 19130C LANGUAGE--ANSI FORTRAN (1977) 19131C WRITTEN BY--JAMES J. FILLIBEN 19132C STATISTICAL ENGINEERING DIVISION 19133C INFORMATION TECHNOLOGY LABORATORY 19134C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 19135C GAITHERSBURG, MD 20899-8980 19136C PHONE--301-975-2855 19137C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 19138C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 19139C LANGUAGE--ANSI FORTRAN (1977) 19140C VERSION NUMBER--2011.4 19141C ORIGINAL VERSION--APRIL 2011. EXTRACTED FROM DPTTE2 TO 19142C ALLOWED IT TO BE CALLED FROM 19143C CMPSTA (I.E., FOR USE AS A 19144C "STATISTIC") 19145C 19146C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19147C 19148 CHARACTER*4 IWRITE 19149 CHARACTER*4 IWRTSV 19150 CHARACTER*4 ISUBRO 19151 CHARACTER*4 IBUGA3 19152 CHARACTER*4 IERROR 19153C 19154 CHARACTER*4 ISUBN1 19155 CHARACTER*4 ISUBN2 19156C 19157C--------------------------------------------------------------------- 19158C 19159 DIMENSION Y1(*) 19160 DIMENSION Y2(*) 19161C 19162C-----COMMON---------------------------------------------------------- 19163C 19164 INCLUDE 'DPCOP2.INC' 19165C 19166C-----START POINT----------------------------------------------------- 19167C 19168 ISUBN1='DPTT' 19169 ISUBN2='E4 ' 19170 IWRTSV=IWRITE 19171 IERROR='NO' 19172C 19173 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TTE4')THEN 19174 WRITE(ICOUT,999) 19175 999 FORMAT(1X) 19176 CALL DPWRST('XXX','BUG ') 19177 WRITE(ICOUT,51) 19178 51 FORMAT('***** AT THE BEGINNING OF DPTTE4--') 19179 CALL DPWRST('XXX','BUG ') 19180 WRITE(ICOUT,52)IBUGA3,ISUBRO 19181 52 FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4) 19182 CALL DPWRST('XXX','BUG ') 19183 WRITE(ICOUT,53)N1,N2 19184 53 FORMAT('N1,N2 = ',2I8) 19185 CALL DPWRST('XXX','BUG ') 19186 DO55I=1,N1 19187 WRITE(ICOUT,56)I,Y1(I) 19188 56 FORMAT('I,Y1(I) = ',I8,G15.7) 19189 CALL DPWRST('XXX','BUG ') 19190 55 CONTINUE 19191 DO65I=1,N1 19192 WRITE(ICOUT,66)I,Y2(I) 19193 66 FORMAT('I,Y2(I) = ',I8,G15.7) 19194 CALL DPWRST('XXX','BUG ') 19195 65 CONTINUE 19196 ENDIF 19197C 19198C ********************************* 19199C ** COMPUTE TWO SAMPLE T-TEST ** 19200C ********************************* 19201C 19202C ******************************************** 19203C ** STEP 1-- ** 19204C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 19205C ******************************************** 19206C 19207 STATVA=-99.0 19208 STATCD=-99.0 19209 STATNU=-99.0 19210 STATV2=-99.0 19211 STATC2=-99.0 19212 STATN2=-99.0 19213 PVAL2T=-99.0 19214 PVALLT=-99.0 19215 PVALUT=-99.0 19216 IWRITE='OFF' 19217C 19218 IF(N1.LT.2)THEN 19219 WRITE(ICOUT,999) 19220 CALL DPWRST('XXX','WRIT') 19221 WRITE(ICOUT,111) 19222 111 FORMAT('***** ERROR IN T-TEST--') 19223 CALL DPWRST('XXX','WRIT') 19224 WRITE(ICOUT,112) 19225 112 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE FIRST ', 19226 1 'RESPONSE VARIABLE IS LESS THAN 2.') 19227 CALL DPWRST('XXX','WRIT') 19228 WRITE(ICOUT,113)N1 19229 113 FORMAT('SAMPLE SIZE = ',I8) 19230 CALL DPWRST('XXX','WRIT') 19231 IERROR='YES' 19232 GOTO9000 19233 ENDIF 19234C 19235 HOLD=Y1(1) 19236 DO135I=2,N1 19237 IF(Y1(I).NE.HOLD)GOTO139 19238 135 CONTINUE 19239 WRITE(ICOUT,999) 19240 CALL DPWRST('XXX','WRIT') 19241 WRITE(ICOUT,111) 19242 CALL DPWRST('XXX','WRIT') 19243 WRITE(ICOUT,131)HOLD 19244 131 FORMAT(' THE FIRST RESPONSE VARIABLE HAS ALL ELEMENTS = ', 19245 1 G15.7) 19246 CALL DPWRST('XXX','WRIT') 19247 GOTO9000 19248 139 CONTINUE 19249C 19250 IF(N2.LT.2)THEN 19251 WRITE(ICOUT,999) 19252 CALL DPWRST('XXX','WRIT') 19253 WRITE(ICOUT,111) 19254 CALL DPWRST('XXX','WRIT') 19255 WRITE(ICOUT,142) 19256 142 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE SECOND ', 19257 1 'RESPONSE VARIABLE IS LESS THAN 2.') 19258 CALL DPWRST('XXX','WRIT') 19259 WRITE(ICOUT,113)N2 19260 CALL DPWRST('XXX','WRIT') 19261 IERROR='YES' 19262 GOTO9000 19263 ENDIF 19264C 19265 HOLD=Y2(1) 19266 DO155I=2,N1 19267 IF(Y2(I).NE.HOLD)GOTO159 19268 155 CONTINUE 19269 WRITE(ICOUT,999) 19270 CALL DPWRST('XXX','WRIT') 19271 WRITE(ICOUT,111) 19272 CALL DPWRST('XXX','WRIT') 19273 WRITE(ICOUT,151)HOLD 19274 151 FORMAT(' THE SECOND RESPONSE VARIABLE HAS ALL ELEMENTS = ', 19275 1 G15.7) 19276 CALL DPWRST('XXX','WRIT') 19277 GOTO9000 19278 159 CONTINUE 19279C 19280C ************************************************** 19281C ** STEP 2-- ** 19282C ** COMPUTE THE TWO SAMPLE UNPAIRED T-TEST. ** 19283C ************************************************** 19284C 19285 CALL MEAN(Y1,N1,IWRITE,Y1MEAN,IBUGA3,IERROR) 19286 CALL SD(Y1,N1,IWRITE,Y1SD,IBUGA3,IERROR) 19287 Y1VAR=Y1SD**2 19288 CALL SDMEAN(Y1,N1,IWRITE,Y1SDM,IBUGA3,IERROR) 19289C 19290 CALL MEAN(Y2,N2,IWRITE,Y2MEAN,IBUGA3,IERROR) 19291 CALL SD(Y2,N2,IWRITE,Y2SD,IBUGA3,IERROR) 19292 Y2VAR=Y2SD**2 19293 CALL SDMEAN(Y2,N2,IWRITE,Y2SDM,IBUGA3,IERROR) 19294C 19295 AN1=N1 19296 AN2=N2 19297C 19298 DEL=Y1MEAN-Y2MEAN 19299 POOLSS=(AN1-1.0)*Y1VAR+(AN2-1.0)*Y2VAR 19300 POOLVA=POOLSS/(AN1+AN2-2.0) 19301 POOLSD=SQRT(POOLVA) 19302 POOLN=1.0/((1.0/AN1)+(1.0/AN2)) 19303 DELSD=POOLSD/SQRT(POOLN) 19304 STATVA=DEL/DELSD 19305 IDF=N1+N2-2 19306 STATNU=REAL(IDF) 19307 CALL TCDF(STATVA,STATNU,STATCD) 19308C 19309 DEL2=DEL 19310 DELVA2=(Y1VAR/AN1)+(Y2VAR/AN2) 19311 DELSD2=SQRT(DELVA2) 19312 STATV2=DEL2/DELSD2 19313 C=(Y1VAR/AN1)/((Y1VAR/AN1)+(Y2VAR/AN2)) 19314 TERM1=C*C/(AN1-1.0) 19315 TERM2=(1-C)*(1-C)/(AN2-1.0) 19316 SUM=TERM1+TERM2 19317 STATN2=1.0/SUM 19318 CALL TCDF(STATV2,STATN2,STATC2) 19319C 19320 TERM11=1.0/(AN1-1.0) 19321 TERM12=1.0/(AN2-1.0) 19322 TERM13=1.0/(AN1+AN2-2.0) 19323 SUMC=TERM11+TERM12-TERM13 19324 CBART=1.0+SUMC/3.0 19325 TERM21=(AN1-1.0)*2*LOG(Y1SD/POOLSD) 19326 TERM22=(AN2-1.0)*2*LOG(Y2SD/POOLSD) 19327 BBART=(-TERM21-TERM22) 19328 BART=BBART/CBART 19329 IDFBAR=1 19330 CALL CHSCDF(BART,IDFBAR,CDFBAR) 19331C 19332 PVALLT=STATC2 19333 PVALUT=1.0 - STATC2 19334 IF(STATV2.LE.0.0)THEN 19335 PVAL2T=2.0*PVALLT 19336 ELSE 19337 PVAL2T=2.0*PVALUT 19338 ENDIF 19339C 19340C ******************************* 19341C ** STEP 3-- ** 19342C ** WRITE OUT A LINE ** 19343C ** OF SUMMARY INFORMATION. ** 19344C ******************************* 19345C 19346 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 19347 WRITE(ICOUT,999) 19348 CALL DPWRST('XXX','BUG ') 19349 WRITE(ICOUT,811)STATVA 19350 811 FORMAT('THE VALUE OF THE TWO SAMPLE T-TEST = ',G15.7) 19351 CALL DPWRST('XXX','BUG ') 19352 ENDIF 19353C 19354C ***************** 19355C ** STEP 90-- ** 19356C ** EXIT. ** 19357C ***************** 19358C 19359 9000 CONTINUE 19360C 19361 IWRITE=IWRTSV 19362C 19363 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TTE4')THEN 19364 WRITE(ICOUT,999) 19365 CALL DPWRST('XXX','BUG ') 19366 WRITE(ICOUT,9011) 19367 9011 FORMAT('***** AT THE END OF DPTTE4--') 19368 CALL DPWRST('XXX','BUG ') 19369 WRITE(ICOUT,9012)IERROR 19370 9012 FORMAT('IERROR = ',A4) 19371 CALL DPWRST('XXX','BUG ') 19372 WRITE(ICOUT,9015)STATVA,STATCD,STATNU 19373 9015 FORMAT('STATVA,STATCD,STATNU = ',3G15.7) 19374 CALL DPWRST('XXX','BUG ') 19375 WRITE(ICOUT,9016)STATV2,STATC2,STATN2 19376 9016 FORMAT('STATV2,STATC2,STATN2 = ',3G15.7) 19377 CALL DPWRST('XXX','BUG ') 19378 WRITE(ICOUT,9017)Y1MEAN,Y1SD,Y1SDM 19379 9017 FORMAT('Y1MEAN,Y1SD,Y1SDM = ',3G15.7) 19380 CALL DPWRST('XXX','BUG ') 19381 WRITE(ICOUT,9018)Y2MEAN,Y2SD,Y2SDM 19382 9018 FORMAT('Y2MEAN,Y2SD,Y2SDM = ',3G15.7) 19383 CALL DPWRST('XXX','BUG ') 19384 ENDIF 19385C 19386 RETURN 19387 END 19388 SUBROUTINE DPTTE5(ICASAN,STATVA,STATCD,STATNU, 19389 1 STATV2,STATC2,STATN2, 19390 1 PVAL2T,PVALLT,PVALUT, 19391 1 CTL999,CUTL99,CUTL95,CUTL90,CUTL80,CUTL50, 19392 1 CTU999,CUTU99,CUTU95,CUTU90,CUTU80,CUTU50, 19393 1 IFLAGU,IFRST,ILAST, 19394 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 19395C 19396C PURPOSE--UTILITY ROUTINE USED BY DPTTES TO UPDATE VARIOUS 19397C INTERNAL PARAMETERS AFTER A T-TEST. 19398C 19399C WRITTEN BY--ALAN HECKERT 19400C STATISTICAL ENGINEERING DIVISION 19401C INFORMATION TECHNOLOGY LABORAOTRY 19402C NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY 19403C GAITHERSBURG, MD 20899-8980 19404C PHONE--301-975-2899 19405C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 19406C OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY. 19407C LANGUAGE--ANSI FORTRAN (1977) 19408C VERSION NUMBER--2011/4 19409C ORIGINAL VERSION--APRIL 2011. 19410C 19411C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19412C 19413 CHARACTER*4 ICASAN 19414 CHARACTER*4 IFLAGU 19415 CHARACTER*4 IBUGA2 19416 CHARACTER*4 IBUGA3 19417 CHARACTER*4 ISUBRO 19418 CHARACTER*4 IERROR 19419C 19420 LOGICAL IFRST 19421 LOGICAL ILAST 19422C 19423 CHARACTER*4 IH 19424 CHARACTER*4 IH2 19425 CHARACTER*4 ISUBN0 19426C 19427 CHARACTER*4 ISUBN1 19428 CHARACTER*4 ISUBN2 19429 CHARACTER*4 ISTEPN 19430C 19431C--------------------------------------------------------------------- 19432C 19433 INCLUDE 'DPCOPA.INC' 19434 INCLUDE 'DPCOHK.INC' 19435 INCLUDE 'DPCOHO.INC' 19436C 19437 CHARACTER*4 IOP 19438 SAVE IOUNI1 19439C 19440C-----COMMON---------------------------------------------------------- 19441C 19442 INCLUDE 'DPCOP2.INC' 19443C 19444C-----START POINT----------------------------------------------------- 19445C 19446 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TTE5')THEN 19447 ISTEPN='1' 19448 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19449 WRITE(ICOUT,999) 19450 999 FORMAT(1X) 19451 CALL DPWRST('XXX','BUG ') 19452 WRITE(ICOUT,51) 19453 51 FORMAT('***** AT THE BEGINNING OF DPTTE5--') 19454 CALL DPWRST('XXX','BUG ') 19455 WRITE(ICOUT,53)STATVA,STATCD,STATNU,PVAL2T,PVALLT,PVALUT 19456 53 FORMAT('STATVA,STATCD,STATNU,PVAL2T,PVALLT,PVALUT = ',6G15.7) 19457 CALL DPWRST('XXX','BUG ') 19458 WRITE(ICOUT,54)CUTL50,CUTL80,CUTL90,CUTL95,CUTL99,CTL999 19459 54 FORMAT('CUTL50,CUTL80,CUTL90,CUTL95,CUTL99,CTL999 = ',6G15.7) 19460 CALL DPWRST('XXX','BUG ') 19461 WRITE(ICOUT,55)CUTU50,CUTU80,CUTU90,CUTU95,CUTU99,CTU999 19462 55 FORMAT('CUTU50,CUTU80,CUTU90,CUTU95,CUTU99,CTU999 = ',6G15.7) 19463 CALL DPWRST('XXX','BUG ') 19464 ENDIF 19465C 19466 IF(ICASAN.EQ.'ONES' .OR. ICASAN.EQ.'PDTE')THEN 19467 STATV=STATVA 19468 STATC=STATCD 19469 STATN=STATNU 19470 ELSE 19471 STATV=STATV2 19472 STATC=STATC2 19473 STATN=STATN2 19474 ENDIF 19475C 19476 IF(IFLAGU.EQ.'FILE')THEN 19477C 19478 IF(IFRST)THEN 19479 IOP='OPEN' 19480 IFLAG1=1 19481 IFLAG2=0 19482 IFLAG3=0 19483 IFLAG4=0 19484 IFLAG5=0 19485 CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5, 19486 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 19487 1 IBUGA3,ISUBRO,IERROR) 19488 IF(IERROR.EQ.'YES')GOTO9000 19489C 19490 WRITE(IOUNI1,295) 19491 295 FORMAT(11X,'STATVAL',8X,'STATCDF',8X,'STATNU', 19492 1 9X,'PVAL2T',9X,'PVALLT',X,'PVALUT', 19493 1 7X,'CUTLOW50',7X,'CUTLOW80',7X,'CUTLOW90', 19494 1 7X,'CUTLOW95',7X,'CUTLOW99',7X,'CUTLO999', 19495 1 7X,'CUTUPP50',7X,'CUTUPP80',7X,'CUTUPP90', 19496 1 7X,'CUTUPP95',7X,'CUTUPP99',7X,'CUTUP999') 19497 ENDIF 19498 WRITE(IOUNI1,299)STATV,STATC,STATN,PVAL2T,PVALLT,PVALUT, 19499 1 CUTL50,CUTL80,CUTL90,CUTL95,CUTL99,CTL999, 19500 1 CUTU50,CUTU80,CUTU90,CUTU95,CUTU99,CTU999 19501 299 FORMAT(18E15.7) 19502 ELSEIF(IFLAGU.EQ.'ON')THEN 19503 IF(STATV.NE.CPUMIN)THEN 19504 IH='STAT' 19505 IH2='VAL ' 19506 VALUE0=STATV 19507 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19508 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19509 1 IANS,IWIDTH,IBUGA3,IERROR) 19510 ENDIF 19511C 19512 IF(STATC.NE.CPUMIN)THEN 19513 IH='STAT' 19514 IH2='CDF ' 19515 VALUE0=STATC 19516 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19517 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19518 1 IANS,IWIDTH,IBUGA3,IERROR) 19519 ENDIF 19520C 19521 IF(STATN.NE.CPUMIN)THEN 19522 IH='STAT' 19523 IH2='NU ' 19524 VALUE0=STATN 19525 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19526 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19527 1 IANS,IWIDTH,IBUGA3,IERROR) 19528 ENDIF 19529C 19530 IF(PVAL2T.NE.CPUMIN)THEN 19531 IH='PVAL' 19532 IH2='UE ' 19533 VALUE0=PVAL2T 19534 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19535 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19536 1 IANS,IWIDTH,IBUGA3,IERROR) 19537 ENDIF 19538C 19539 IF(PVALLT.NE.CPUMIN)THEN 19540 IH='PVAL' 19541 IH2='UELT' 19542 VALUE0=PVALLT 19543 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19544 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19545 1 IANS,IWIDTH,IBUGA3,IERROR) 19546 ENDIF 19547C 19548 IF(PVALUT.NE.CPUMIN)THEN 19549 IH='PVAL' 19550 IH2='UEUT' 19551 VALUE0=PVALUT 19552 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19553 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19554 1 IANS,IWIDTH,IBUGA3,IERROR) 19555 ENDIF 19556C 19557 IF(CUTU50.NE.CPUMIN)THEN 19558 IH='CUTU' 19559 IH2='PP50' 19560 VALUE0=CUTU50 19561 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19562 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19563 1 IANS,IWIDTH,IBUGA3,IERROR) 19564 ENDIF 19565C 19566 IF(CUTL50.NE.CPUMIN)THEN 19567 IH='CUTL' 19568 IH2='OW50' 19569 VALUE0=CUTU50 19570 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19571 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19572 1 IANS,IWIDTH,IBUGA3,IERROR) 19573 ENDIF 19574C 19575 IF(CUTU80.NE.CPUMIN)THEN 19576 IH='CUTU' 19577 IH2='PP80' 19578 VALUE0=CUTU80 19579 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19580 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19581 1 IANS,IWIDTH,IBUGA3,IERROR) 19582 ENDIF 19583C 19584 IF(CUTL80.NE.CPUMIN)THEN 19585 IH='CUTL' 19586 IH2='OW80' 19587 VALUE0=CUTL80 19588 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19589 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19590 1 IANS,IWIDTH,IBUGA3,IERROR) 19591 ENDIF 19592C 19593 IF(CUTU90.NE.CPUMIN)THEN 19594 IH='CUTU' 19595 IH2='PP90' 19596 VALUE0=CUTU90 19597 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19598 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19599 1 IANS,IWIDTH,IBUGA3,IERROR) 19600 ENDIF 19601C 19602 IF(CUTL90.NE.CPUMIN)THEN 19603 IH='CUTL' 19604 IH2='OW90' 19605 VALUE0=CUTL90 19606 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19607 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19608 1 IANS,IWIDTH,IBUGA3,IERROR) 19609 ENDIF 19610C 19611 IF(CUTU95.NE.CPUMIN)THEN 19612 IH='CUTU' 19613 IH2='PP95' 19614 VALUE0=CUTU95 19615 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19616 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19617 1 IANS,IWIDTH,IBUGA3,IERROR) 19618 ENDIF 19619C 19620 IF(CUTL95.NE.CPUMIN)THEN 19621 IH='CUTL' 19622 IH2='OW95' 19623 VALUE0=CUTL95 19624 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19625 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19626 1 IANS,IWIDTH,IBUGA3,IERROR) 19627 ENDIF 19628C 19629 IF(CUTU99.NE.CPUMIN)THEN 19630 IH='CUTU' 19631 IH2='PP99' 19632 VALUE0=CUTU99 19633 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19634 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19635 1 IANS,IWIDTH,IBUGA3,IERROR) 19636 ENDIF 19637C 19638 IF(CUTL99.NE.CPUMIN)THEN 19639 IH='CUTL' 19640 IH2='OW99' 19641 VALUE0=CUTL99 19642 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19643 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19644 1 IANS,IWIDTH,IBUGA3,IERROR) 19645 ENDIF 19646C 19647 IF(CTU999.NE.CPUMIN)THEN 19648 IH='CUTU' 19649 IH2='P999' 19650 VALUE0=CTU999 19651 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19652 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19653 1 IANS,IWIDTH,IBUGA3,IERROR) 19654 ENDIF 19655C 19656 IF(CTL999.NE.CPUMIN)THEN 19657 IH='CUTL' 19658 IH2='O999' 19659 VALUE0=CTL999 19660 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19661 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19662 1 IANS,IWIDTH,IBUGA3,IERROR) 19663 ENDIF 19664C 19665 ENDIF 19666C 19667 IF(IFLAGU.EQ.'FILE')THEN 19668 IF(ILAST)THEN 19669 IOP='CLOS' 19670 IFLAG1=1 19671 IFLAG2=0 19672 IFLAG3=0 19673 IFLAG4=0 19674 IFLAG5=0 19675 CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5, 19676 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 19677 1 IBUGA3,ISUBRO,IERROR) 19678C 19679 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TTE5')THEN 19680 ISTEPN='3A' 19681 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19682 WRITE(ICOUT,999) 19683 CALL DPWRST('XXX','BUG ') 19684 WRITE(ICOUT,301)IERROR 19685 301 FORMAT('AFTER CALL DPCLFI, IERROR = ',A4) 19686 CALL DPWRST('XXX','BUG ') 19687 ENDIF 19688C 19689 IF(IERROR.EQ.'YES')GOTO9000 19690 ENDIF 19691 ENDIF 19692C 19693C ***************** 19694C ** STEP 90-- ** 19695C ** EXIT ** 19696C ***************** 19697C 19698 9000 CONTINUE 19699C 19700 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TTE5')THEN 19701 WRITE(ICOUT,999) 19702 CALL DPWRST('XXX','BUG ') 19703 WRITE(ICOUT,9011) 19704 9011 FORMAT('***** AT THE END OF DPTTE5--') 19705 CALL DPWRST('XXX','BUG ') 19706 ENDIF 19707C 19708 RETURN 19709 END 19710 SUBROUTINE DPTTE6(Y1,N1,Y2,N2,YTEMP,IWRITE, 19711 1 STATVA,STATCD,STATNU, 19712 1 Y1MEAN,Y1SD,Y1SDM, 19713 1 Y2MEAN,Y2SD,Y2SDM, 19714 1 YDMEAN,YDSD,YDSDM, 19715 1 PVAL2T,PVALLT,PVALUT, 19716 1 ISUBRO,IBUGA3,IERROR) 19717C 19718C PURPOSE--THIS SUBROUTINE COMPUTES THE PAIRED TWO SAMPLE T-TEST 19719C (AND ALTERNATIVELY THE CDF OR P-VALUES). 19720C INPUT ARGUMENTS--Y1 = THE SINGLE PRECISION VECTOR OF 19721C (UNSORTED OR SORTED) OBSERVATIONS 19722C FOR THE FIRST RESPONSE VARIABLE. 19723C --N1 = THE INTEGER NUMBER OF OBSERVATIONS 19724C IN THE VECTOR Y1. 19725C --Y2 = THE SINGLE PRECISION VECTOR OF 19726C (UNSORTED OR SORTED) OBSERVATIONS 19727C FOR THE SECOND RESPONSE VARIABLE. 19728C --N2 = THE INTEGER NUMBER OF OBSERVATIONS 19729C IN THE VECTOR Y2. 19730C OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE 19731C COMPUTED STATISTIC. 19732C --STATCD = THE SINGLE PRECISION VALUE OF THE 19733C COMPUTED CDF OF THE TEST STATISTIC. 19734C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE 19735C TEST STATISTIC. 19736C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 19737C OF N FOR THIS SUBROUTINE. 19738C OTHER DATAPAC SUBROUTINES NEEDED--TCDF. 19739C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 19740C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 19741C LANGUAGE--ANSI FORTRAN (1977) 19742C WRITTEN BY--ALAN HECKERT 19743C STATISTICAL ENGINEERING DIVISION 19744C INFORMATION TECHNOLOGY LABORATORY 19745C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 19746C GAITHERSBURG, MD 20899-8980 19747C PHONE--301-975-2888 19748C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 19749C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 19750C LANGUAGE--ANSI FORTRAN (1977) 19751C VERSION NUMBER--2011.4 19752C ORIGINAL VERSION--APRIL 2011 19753C 19754C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19755C 19756 CHARACTER*4 IWRITE 19757 CHARACTER*4 IWRTSV 19758 CHARACTER*4 ISUBRO 19759 CHARACTER*4 IBUGA3 19760 CHARACTER*4 IERROR 19761C 19762 CHARACTER*4 ISUBN1 19763 CHARACTER*4 ISUBN2 19764C 19765C--------------------------------------------------------------------- 19766C 19767 DIMENSION Y1(*) 19768 DIMENSION Y2(*) 19769 DIMENSION YTEMP(*) 19770C 19771C-----COMMON---------------------------------------------------------- 19772C 19773 INCLUDE 'DPCOP2.INC' 19774C 19775C-----START POINT----------------------------------------------------- 19776C 19777 ISUBN1='DPTT' 19778 ISUBN2='E6 ' 19779 IWRTSV=IWRITE 19780 IERROR='NO' 19781C 19782 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TTE6')THEN 19783 WRITE(ICOUT,999) 19784 999 FORMAT(1X) 19785 CALL DPWRST('XXX','BUG ') 19786 WRITE(ICOUT,51) 19787 51 FORMAT('***** AT THE BEGINNING OF DPTTE6--') 19788 CALL DPWRST('XXX','BUG ') 19789 WRITE(ICOUT,52)IBUGA3,ISUBRO 19790 52 FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4) 19791 CALL DPWRST('XXX','BUG ') 19792 WRITE(ICOUT,53)N1,N2 19793 53 FORMAT('N1,N2 = ',2I8) 19794 CALL DPWRST('XXX','BUG ') 19795 DO55I=1,MIN(N1,N2) 19796 WRITE(ICOUT,56)I,Y1(I),Y2(I) 19797 56 FORMAT('I,Y1(I),Y2(I) = ',I8,2G15.7) 19798 CALL DPWRST('XXX','BUG ') 19799 55 CONTINUE 19800 ENDIF 19801C 19802C **************************************** 19803C ** COMPUTE TWO SAMPLE PAIRED T-TEST ** 19804C **************************************** 19805C 19806C ******************************************** 19807C ** STEP 1-- ** 19808C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 19809C ******************************************** 19810C 19811 STATVA=-99.0 19812 STATCD=-99.0 19813 STATNU=-99.0 19814 PVAL2T=-99.0 19815 PVALLT=-99.0 19816 PVALUT=-99.0 19817 IWRITE='OFF' 19818C 19819 IF(N1.NE.N2)THEN 19820 WRITE(ICOUT,999) 19821 CALL DPWRST('XXX','WRIT') 19822 WRITE(ICOUT,111) 19823 CALL DPWRST('XXX','WRIT') 19824 WRITE(ICOUT,102) 19825 102 FORMAT(' FOR THE PAIRED TEST, THE SAMPLE SIZES FOR THE') 19826 CALL DPWRST('XXX','WRIT') 19827 WRITE(ICOUT,103) 19828 103 FORMAT(' RESPONSE VARIABLES MUST BE EQUAL.') 19829 CALL DPWRST('XXX','WRIT') 19830 WRITE(ICOUT,104)N1 19831 104 FORMAT('SAMPLE SIZE FOR THE FIRST RESPONSE VARIABLE = ',I8) 19832 CALL DPWRST('XXX','WRIT') 19833 WRITE(ICOUT,105)N2 19834 105 FORMAT('SAMPLE SIZE FOR THE SECOND RESPONSE VARIABLE = ',I8) 19835 CALL DPWRST('XXX','WRIT') 19836 IERROR='YES' 19837 GOTO9000 19838 ENDIF 19839C 19840 IF(N1.LT.2)THEN 19841 WRITE(ICOUT,999) 19842 CALL DPWRST('XXX','WRIT') 19843 WRITE(ICOUT,111) 19844 111 FORMAT('***** ERROR IN PAIRED T-TEST--') 19845 CALL DPWRST('XXX','WRIT') 19846 WRITE(ICOUT,112) 19847 112 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE FIRST ', 19848 1 'RESPONSE VARIABLE IS LESS THAN 2.') 19849 CALL DPWRST('XXX','WRIT') 19850 WRITE(ICOUT,113)N1 19851 113 FORMAT('SAMPLE SIZE = ',I8) 19852 CALL DPWRST('XXX','WRIT') 19853 IERROR='YES' 19854 GOTO9000 19855 ENDIF 19856C 19857 HOLD=Y1(1) 19858 DO135I=2,N1 19859 IF(Y1(I).NE.HOLD)GOTO139 19860 135 CONTINUE 19861 WRITE(ICOUT,999) 19862 CALL DPWRST('XXX','WRIT') 19863 WRITE(ICOUT,111) 19864 CALL DPWRST('XXX','WRIT') 19865 WRITE(ICOUT,131)HOLD 19866 131 FORMAT(' THE FIRST RESPONSE VARIABLE HAS ALL ELEMENTS = ', 19867 1 G15.7) 19868 CALL DPWRST('XXX','WRIT') 19869 GOTO9000 19870 139 CONTINUE 19871C 19872 IF(N2.LT.2)THEN 19873 WRITE(ICOUT,999) 19874 CALL DPWRST('XXX','WRIT') 19875 WRITE(ICOUT,111) 19876 CALL DPWRST('XXX','WRIT') 19877 WRITE(ICOUT,142) 19878 142 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE SECOND ', 19879 1 'RESPONSE VARIABLE IS LESS THAN 2.') 19880 CALL DPWRST('XXX','WRIT') 19881 WRITE(ICOUT,113)N2 19882 CALL DPWRST('XXX','WRIT') 19883 IERROR='YES' 19884 GOTO9000 19885 ENDIF 19886C 19887 HOLD=Y2(1) 19888 DO155I=2,N1 19889 IF(Y2(I).NE.HOLD)GOTO159 19890 155 CONTINUE 19891 WRITE(ICOUT,999) 19892 CALL DPWRST('XXX','WRIT') 19893 WRITE(ICOUT,111) 19894 CALL DPWRST('XXX','WRIT') 19895 WRITE(ICOUT,151)HOLD 19896 151 FORMAT(' THE SECOND RESPONSE VARIABLE HAS ALL ELEMENTS = ', 19897 1 G15.7) 19898 CALL DPWRST('XXX','WRIT') 19899 GOTO9000 19900 159 CONTINUE 19901C 19902C ************************************************** 19903C ** STEP 2-- ** 19904C ** COMPUTE THE TWO SAMPLE PAIRED T-TEST. ** 19905C ************************************************** 19906C 19907 DO200I=1,N1 19908 YTEMP(I)=Y1(I) - Y2(I) 19909 200 CONTINUE 19910C 19911 CALL MEAN(Y1,N1,IWRITE,Y1MEAN,IBUGA3,IERROR) 19912 CALL SD(Y1,N1,IWRITE,Y1SD,IBUGA3,IERROR) 19913 Y1VAR=Y1SD**2 19914 CALL SDMEAN(Y1,N1,IWRITE,Y1SDM,IBUGA3,IERROR) 19915C 19916 CALL MEAN(Y2,N2,IWRITE,Y2MEAN,IBUGA3,IERROR) 19917 CALL SD(Y2,N2,IWRITE,Y2SD,IBUGA3,IERROR) 19918 Y2VAR=Y2SD**2 19919 CALL SDMEAN(Y2,N2,IWRITE,Y2SDM,IBUGA3,IERROR) 19920C 19921 CALL MEAN(YTEMP,N2,IWRITE,YDMEAN,IBUGA3,IERROR) 19922 CALL SD(YTEMP,N2,IWRITE,YDSD,IBUGA3,IERROR) 19923 YDVAR=YDSD**2 19924 CALL SDMEAN(YTEMP,N2,IWRITE,YDSDM,IBUGA3,IERROR) 19925C 19926 AN1=N1 19927 AN2=N2 19928C 19929 DEL=Y1MEAN-Y2MEAN 19930 STATVA=DEL/YDSDM 19931 IDF=N1-1 19932 STATNU=REAL(IDF) 19933 CALL TCDF(STATVA,STATNU,STATCD) 19934C 19935 PVALLT=STATCD 19936 PVALUT=1.0 - STATCD 19937 IF(STATVA.LE.0.0)THEN 19938 PVAL2T=2.0*PVALLT 19939 ELSE 19940 PVAL2T=2.0*PVALUT 19941 ENDIF 19942C 19943C ******************************* 19944C ** STEP 3-- ** 19945C ** WRITE OUT A LINE ** 19946C ** OF SUMMARY INFORMATION. ** 19947C ******************************* 19948C 19949 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 19950 WRITE(ICOUT,999) 19951 CALL DPWRST('XXX','BUG ') 19952 WRITE(ICOUT,811)STATVA 19953 811 FORMAT('THE VALUE OF THE PAIRED TWO SAMPLE T-TEST = ',G15.7) 19954 CALL DPWRST('XXX','BUG ') 19955 ENDIF 19956C 19957C ***************** 19958C ** STEP 90-- ** 19959C ** EXIT. ** 19960C ***************** 19961C 19962 9000 CONTINUE 19963C 19964 IWRITE=IWRTSV 19965C 19966 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TTE6')THEN 19967 WRITE(ICOUT,999) 19968 CALL DPWRST('XXX','BUG ') 19969 WRITE(ICOUT,9011) 19970 9011 FORMAT('***** AT THE END OF DPTTE6--') 19971 CALL DPWRST('XXX','BUG ') 19972 WRITE(ICOUT,9012)IERROR 19973 9012 FORMAT('IERROR = ',A4) 19974 CALL DPWRST('XXX','BUG ') 19975 WRITE(ICOUT,9015)STATVA,STATCD,STATNU 19976 9015 FORMAT('STATVA,STATCD,STATNU = ',3G15.7) 19977 CALL DPWRST('XXX','BUG ') 19978 WRITE(ICOUT,9017)Y1MEAN,Y1SD,Y1SDM 19979 9017 FORMAT('Y1MEAN,Y1SD,Y1SDM = ',3G15.7) 19980 CALL DPWRST('XXX','BUG ') 19981 WRITE(ICOUT,9018)Y2MEAN,Y2SD,Y2SDM 19982 9018 FORMAT('Y2MEAN,Y2SD,Y2SDM = ',3G15.7) 19983 CALL DPWRST('XXX','BUG ') 19984 WRITE(ICOUT,9019)YDMEAN,YDSD,YDSDM 19985 9019 FORMAT('YDMEAN,YDSD,YDSDM = ',3G15.7) 19986 CALL DPWRST('XXX','BUG ') 19987 ENDIF 19988C 19989 RETURN 19990 END 19991 SUBROUTINE DPTUMD(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 19992 1 IANGLU,MAXNPP, 19993 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 19994C 19995C PURPOSE--FORM A TUKEY MEAN DIFFERENCE PLOT 19996C (USEFUL FOR DISTRIBUTIONALLY COMPARING 2 DATA SETS). 19997C WRITTEN BY--ALAN HECKERT 19998C STATISTICAL ENGINEERING DIVISION 19999C INFORMATION TECHNOLOGY LABORATORY 20000C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 20001C GAITHERSBURG, MD 20899-8980 20002C PHONE--301-975-2855 20003C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 20004C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 20005C LANGUAGE--ANSI FORTRAN (1977) 20006C VERSION NUMBER--99/8 20007C ORIGINAL VERSION--SEPTEMBER 1999 . 20008C UPDATED --FEBRUARY 2011. USE DPPARS, DPPAR3 20009C UPDATED --FEBRUARY 2011. SUPPORT FOR "HIGHLIGHTED" OPTION 20010C UPDATED --JUNE 2016. ALLOW USER-SPECIFED PERCENTILES 20011C 20012C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 20013C 20014 CHARACTER*4 ICASPL 20015 CHARACTER*4 IAND1 20016 CHARACTER*4 IAND2 20017 CHARACTER*4 IANGLU 20018 CHARACTER*4 IBUGG2 20019 CHARACTER*4 IBUGG3 20020 CHARACTER*4 IBUGQ 20021 CHARACTER*4 ISUBRO 20022 CHARACTER*4 IFOUND 20023 CHARACTER*4 IERROR 20024C 20025 CHARACTER*4 ISUBN1 20026 CHARACTER*4 ISUBN2 20027 CHARACTER*4 ISTEPN 20028 CHARACTER*4 ICASE 20029 CHARACTER*4 IHIGH 20030C 20031 CHARACTER*40 INAME 20032 PARAMETER (MAXSPN=20) 20033 CHARACTER*4 IVARN1(MAXSPN) 20034 CHARACTER*4 IVARN2(MAXSPN) 20035 CHARACTER*4 IVARTY(MAXSPN) 20036 REAL PVAR(MAXSPN) 20037 INTEGER ILIS(MAXSPN) 20038 INTEGER NRIGHT(MAXSPN) 20039 INTEGER ICOLR(MAXSPN) 20040C 20041C--------------------------------------------------------------------- 20042C 20043 INCLUDE 'DPCOPA.INC' 20044 DIMENSION Y1(MAXOBV) 20045 DIMENSION Y2(MAXOBV) 20046 DIMENSION Y3(MAXOBV) 20047 DIMENSION Y4(MAXOBV) 20048 DIMENSION XD(MAXOBV) 20049 DIMENSION YD(MAXOBV) 20050 DIMENSION XHIGH(MAXOBV) 20051 DIMENSION XDIST(MAXOBV) 20052 DIMENSION TEMP1(MAXOBV) 20053 DIMENSION TEMP2(MAXOBV) 20054C 20055 INCLUDE 'DPCOZZ.INC' 20056 DIMENSION YLARGE(MAXOBV) 20057 DIMENSION YSMALL(MAXOBV) 20058 EQUIVALENCE (GARBAG(IGARB1),Y1(1)) 20059 EQUIVALENCE (GARBAG(IGARB2),Y2(1)) 20060 EQUIVALENCE (GARBAG(IGARB3),Y3(1)) 20061 EQUIVALENCE (GARBAG(IGARB4),Y4(1)) 20062 EQUIVALENCE (GARBAG(IGARB5),XD(1)) 20063 EQUIVALENCE (GARBAG(IGARB6),YD(1)) 20064 EQUIVALENCE (GARBAG(IGARB7),YLARGE(1)) 20065 EQUIVALENCE (GARBAG(IGARB8),YSMALL(1)) 20066 EQUIVALENCE (GARBAG(IGARB9),XHIGH(1)) 20067 EQUIVALENCE (GARBAG(IGAR10),XDIST(1)) 20068 EQUIVALENCE (GARBAG(JGAR11),TEMP1(1)) 20069 EQUIVALENCE (GARBAG(JGAR12),TEMP2(1)) 20070C 20071C-----COMMON---------------------------------------------------------- 20072C 20073 INCLUDE 'DPCOHK.INC' 20074 INCLUDE 'DPCODA.INC' 20075 INCLUDE 'DPCOST.INC' 20076 INCLUDE 'DPCOP2.INC' 20077C 20078C-----START POINT----------------------------------------------------- 20079C 20080 ISUBN1='DPTU' 20081 ISUBN2='MD ' 20082 IFOUND='NO' 20083 IERROR='NO' 20084C 20085 MAXCP1=MAXCOL+1 20086 MAXCP2=MAXCOL+2 20087 MAXCP3=MAXCOL+3 20088 MAXCP4=MAXCOL+4 20089 MAXCP5=MAXCOL+5 20090 MAXCP6=MAXCOL+6 20091C 20092 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TUMD')THEN 20093 WRITE(ICOUT,999) 20094 999 FORMAT(1X) 20095 CALL DPWRST('XXX','BUG ') 20096 WRITE(ICOUT,51) 20097 51 FORMAT('***** AT THE BEGINNING OF DPTUMD--') 20098 CALL DPWRST('XXX','BUG ') 20099 WRITE(ICOUT,52)NPLOTV,NPLOTP,NS,MAXN,MAXNPP,IQQNPR 20100 52 FORMAT('NPLOTV,NPLOTP,NS,MAXN,MAXNPP,IQQNPR = ',6I8) 20101 CALL DPWRST('XXX','BUG ') 20102 WRITE(ICOUT,53)ICASPL,IAND1,IAND2 20103 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) 20104 CALL DPWRST('XXX','BUG ') 20105 WRITE(ICOUT,54)IANGLU,IBUGG2,IBUGG3,IBUGQ,ISUBRO 20106 54 FORMAT('IANGLU,IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',4(A4,2X),A4) 20107 CALL DPWRST('XXX','BUG ') 20108 WRITE(ICOUT,57)IFOUND,IERROR 20109 57 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 20110 CALL DPWRST('XXX','BUG ') 20111 ENDIF 20112C 20113C ******************************************* 20114C ** TREAT THE TUKEY MEAN-DIFFERENCE CASE ** 20115C ******************************************* 20116C 20117C *************************** 20118C ** STEP 11-- ** 20119C ** EXTRACT THE COMMAND ** 20120C *************************** 20121C 20122 ISTEPN='11' 20123 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TUMD') 20124 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 20125C 20126 IHIGH='OFF' 20127 IF(ICOM.EQ.'TUKE')THEN 20128 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MEAN'.AND. 20129 1 IHARG(2).EQ.'DIFF')THEN 20130 IF((IHARG(3).EQ.'HIGH' .OR. IHARG(3).EQ.'SUBS') .AND. 20131 1 IHARG(4).EQ.'PLOT')THEN 20132 IHIGH='ON' 20133 ILASTC=4 20134 ELSEIF(IHARG(3).EQ.'PLOT')THEN 20135 ILASTC=3 20136 ELSE 20137 GOTO9000 20138 ENDIF 20139 ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'M '.AND. 20140 1 IHARG(2).EQ.'D ')THEN 20141 IF((IHARG(3).EQ.'HIGH' .OR. IHARG(3).EQ.'SUBS') .AND. 20142 1 IHARG(4).EQ.'PLOT')THEN 20143 ILASTC=4 20144 IHIGH='ON' 20145 ELSEIF(IHARG(3).EQ.'PLOT')THEN 20146 ILASTC=3 20147 ELSE 20148 GOTO9000 20149 ENDIF 20150 ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'MD ')THEN 20151 IF((IHARG(2).EQ.'HIGH' .OR. IHARG(2).EQ.'SUBS') .AND. 20152 1 IHARG(3).EQ.'PLOT')THEN 20153 ILASTC=3 20154 IHIGH='ON' 20155 ELSEIF(IHARG(2).EQ.'PLOT')THEN 20156 ILASTC=2 20157 ELSE 20158 GOTO9000 20159 ENDIF 20160 ENDIF 20161 ELSEIF(ICOM.EQ.'HIGH' .OR. ICOM.EQ.'SUBS')THEN 20162 IHIGH='ON' 20163 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'TUKE'.AND. 20164 1 IHARG(2).EQ.'MEAN'.AND.IHARG(3).EQ.'DIFF'.AND. 20165 1 IHARG(4).EQ.'PLOT')THEN 20166 IHIGH='ON' 20167 ILASTC=4 20168 ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'TUKE'.AND. 20169 1 IHARG(2).EQ.'M '.AND.IHARG(3).EQ.'D '.AND. 20170 1 IHARG(4).EQ.'PLOT')THEN 20171 ILASTC=3 20172 IHIGH='ON' 20173 ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'TUKE'.AND. 20174 1 IHARG(2).EQ.'MD '.AND.IHARG(3).EQ.'PLOT')THEN 20175 ILASTC=3 20176 ELSE 20177 GOTO9000 20178 ENDIF 20179 ELSE 20180 GOTO9000 20181 ENDIF 20182C 20183 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 20184 IFOUND='YES' 20185 ICASPL='TUMD' 20186C 20187C **************************************** 20188C ** STEP 2-- ** 20189C ** EXTRACT THE VARIABLE LIST ** 20190C **************************************** 20191C 20192 ISTEPN='2' 20193 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TUMD') 20194 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 20195C 20196 INAME='TUKEY MEAN-DIFFERENCE PLOT' 20197 MINNA=2 20198 MAXNA=100 20199 MINN2=2 20200 IFLAGE=0 20201 IFLAGM=1 20202 IFLAGP=0 20203 JMIN=1 20204 JMAX=NUMARG 20205 MINNVA=2 20206 MAXNVA=2 20207 IF(IHIGH.EQ.'ON')THEN 20208 MINNA=3 20209 MINNVA=3 20210 MAXNVA=3 20211 ENDIF 20212C 20213 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 20214 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 20215 1 JMIN,JMAX, 20216 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 20217 1 IVARN1,IVARN2,IVARTY,PVAR, 20218 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 20219 1 MINNVA,MAXNVA, 20220 1 IFLAGM,IFLAGP, 20221 1 IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 20222 IF(IERROR.EQ.'YES')GOTO9000 20223C 20224 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TUMD')THEN 20225 WRITE(ICOUT,999) 20226 CALL DPWRST('XXX','BUG ') 20227 WRITE(ICOUT,281) 20228 281 FORMAT('***** AFTER CALL DPPARS--') 20229 CALL DPWRST('XXX','BUG ') 20230 WRITE(ICOUT,282)NQ,NUMVAR 20231 282 FORMAT('NQ,NUMVAR = ',2I8) 20232 CALL DPWRST('XXX','BUG ') 20233 IF(NUMVAR.GT.0)THEN 20234 DO285I=1,NUMVAR 20235 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 20236 1 ICOLR(I) 20237 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 20238 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 20239 CALL DPWRST('XXX','BUG ') 20240 285 CONTINUE 20241 ENDIF 20242 ENDIF 20243C 20244 DO290I=1,MAX(NRIGHT(1),NRIGHT(2)) 20245 XHIGH(I)=1.0 20246 290 CONTINUE 20247C 20248C IN ORDER TO ACCOMODATE MATRIX ARGUMENTS, CALL EACH 20249C VARIABLE SEPARATELY. 20250C 20251 NUMVA2=1 20252 ICOL=1 20253 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 20254 1 INAME,IVARN1,IVARN2,IVARTY, 20255 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 20256 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 20257 1 MAXCP4,MAXCP5,MAXCP6, 20258 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 20259 1 Y1,Y1,Y1,NS1,NTEMP,NTEMP,ICASE, 20260 1 IBUGG3,ISUBRO,IFOUND,IERROR) 20261 IF(IERROR.EQ.'YES')GOTO9000 20262C 20263 ICOL=2 20264 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 20265 1 INAME,IVARN1,IVARN2,IVARTY, 20266 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 20267 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 20268 1 MAXCP4,MAXCP5,MAXCP6, 20269 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 20270 1 Y2,Y2,Y2,NS2,NTEMP,NTEMP,ICASE, 20271 1 IBUGG3,ISUBRO,IFOUND,IERROR) 20272C 20273 IF(IHIGH.EQ.'ON')THEN 20274 ICOL=3 20275 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 20276 1 INAME,IVARN1,IVARN2,IVARTY, 20277 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 20278 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 20279 1 MAXCP4,MAXCP5,MAXCP6, 20280 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 20281 1 XHIGH,XHIGH,XHIGH,NHIGH,NTEMP,NTEMP,ICASE, 20282 1 IBUGG3,ISUBRO,IFOUND,IERROR) 20283 ELSE 20284 NHIGH=0 20285 ENDIF 20286C 20287C **************************************************** 20288C ** STEP 41-- * 20289C ** FORM THE VERTICAL AND HORIZONTAL AXIS * 20290C ** VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR * 20291C ** THE PLOT. * 20292C ** FORM THE CURVE DESIGNATION VARIABLE D(.) . * 20293C ** THIS WILL BE BOTH ONES FOR BOTH CASES * 20294C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). * 20295C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). * 20296C **************************************************** 20297C 20298 ISTEPN='41' 20299 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TUMD') 20300 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 20301C 20302 NS=NS1 20303 IF(NS2.GT.NS1)NS=NS2 20304 CALL DPTUM2(Y1,NS1,Y2,NS2,ICASPL,MAXN,IQQNPR, 20305 1 Y,X,D,NPLOTP,NPLOTV, 20306 1 YLARGE,YSMALL,TEMP1,TEMP2, 20307 1 XHIGH,NHIGH,XDIST, 20308 1 IBUGG3,ISUBRO,IERROR) 20309C 20310C 20311C ***************** 20312C ** STEP 90-- ** 20313C ** EXIT ** 20314C ***************** 20315C 20316 9000 CONTINUE 20317 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TUMD')THEN 20318 WRITE(ICOUT,999) 20319 CALL DPWRST('XXX','BUG ') 20320 WRITE(ICOUT,9011) 20321 9011 FORMAT('***** AT THE END OF DPTUMD--') 20322 CALL DPWRST('XXX','BUG ') 20323 WRITE(ICOUT,9012)IFOUND,IERROR 20324 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 20325 CALL DPWRST('XXX','BUG ') 20326 WRITE(ICOUT,9013)NPLOTV,NPLOTP,NUMVAR,NS,ICASPL,IAND1,IAND2 20327 9013 FORMAT('NPLOTV,NPLOTP,NUMVAR,NS,ICASPL,IAND1,IAND2 = ', 20328 1 4I8,2X,2(A4,2X),A4) 20329 CALL DPWRST('XXX','BUG ') 20330 WRITE(ICOUT,9014)ICASPL,MAXN,NUMVAR 20331 9014 FORMAT('ICASPL,MAXN,NUMVAR = ',A4,I8,I8) 20332 CALL DPWRST('XXX','BUG ') 20333 IF(NPLOTP.GE.1)THEN 20334 DO9020I=1,NPLOTP 20335 WRITE(ICOUT,9021)I,Y(I),X(I),D(I) 20336 9021 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) 20337 CALL DPWRST('XXX','BUG ') 20338 9020 CONTINUE 20339 ENDIF 20340 ENDIF 20341C 20342 RETURN 20343 END 20344 SUBROUTINE DPTUM2(Y,NY,X,NX,ICASPL,MAXN,IQQNPR, 20345 1 Y2,X2,D2,N2,NPLOTV, 20346 1 YLARGE,YSMALL,TEMP1,TEMP2, 20347 1 XHIGH,NHIGH,XDIST, 20348 1 IBUGG3,ISUBRO,IERROR) 20349C 20350C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS 20351C THAT WILL DEFINE A TUKEY MEAN-DIFFERENCE PLOT 20352C (USEFUL FOR DISTRIBUTIONALLY COMPARING 2 DATA SETS). 20353C AFTER CALCULATING COORDINATES FOR Q-Q PLOT, CALCULATE 20354C (Bi - Ti) VERSUS (Bi+Ti)/2 WHERE Bi AND Ti ARE 20355C THE QUANTILES FOR THE RESPECTIVE DATA SETS. 20356C WRITTEN BY--ALAN HECKERT 20357C STATISTICAL ENGINEERING DIVISION 20358C INFORMATION TECHNOLOGY LABORATORY 20359C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 20360C GAITHERSBURG, MD 20899-8980 20361C PHONE--301-975-2899 20362C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 20363C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 20364C LANGUAGE--ANSI FORTRAN (1977) 20365C VERSION NUMBER--99/9 20366C ORIGINAL VERSION--SEPTEMBER 1999. 20367C UPDATED --FEBRUARY 2011. 20368C UPDATED --JUNE 2016. ALLOW USER-SPECIFED PERCENTILES 20369C UPDATED --JUNE 2016. DON'T TREAT N=1 OR ALL DATA 20370C VALUES EQUAL AS AN ERROR. TREAT 20371C AS A "DEGENERATE" CASE. 20372C 20373C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 20374C 20375 CHARACTER*4 IBUGG3 20376 CHARACTER*4 ISUBRO 20377 CHARACTER*4 IERROR 20378C 20379 CHARACTER*4 ICASE 20380 CHARACTER*4 ICASPL 20381C 20382 CHARACTER*4 ISUBN1 20383 CHARACTER*4 ISUBN2 20384 CHARACTER*4 ISTEPN 20385 CHARACTER*4 IWRITE 20386C 20387C--------------------------------------------------------------------- 20388C 20389 INCLUDE 'DPCOPA.INC' 20390C 20391 DIMENSION Y(*) 20392 DIMENSION X(*) 20393 DIMENSION XHIGH(*) 20394 DIMENSION Y2(*) 20395 DIMENSION X2(*) 20396 DIMENSION D2(*) 20397C 20398 DIMENSION YLARGE(*) 20399 DIMENSION YSMALL(*) 20400 DIMENSION XDIST(*) 20401 DIMENSION TEMP1(*) 20402 DIMENSION TEMP2(*) 20403C 20404C-----COMMON---------------------------------------------------------- 20405C 20406 INCLUDE 'DPCOP2.INC' 20407C 20408C-----START POINT----------------------------------------------------- 20409C 20410 ISUBN1='DPQU' 20411 ISUBN2='M2 ' 20412 IERROR='NO' 20413 IWRITE='OFF' 20414 ICASE=ICASPL 20415C 20416 ANY=NY 20417 ANX=NX 20418C 20419 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TUM2')THEN 20420 WRITE(ICOUT,999) 20421 999 FORMAT(1X) 20422 CALL DPWRST('XXX','BUG ') 20423 WRITE(ICOUT,51) 20424 51 FORMAT('***** AT THE BEGINNING OF DPTUM2--') 20425 CALL DPWRST('XXX','BUG ') 20426 WRITE(ICOUT,52)IBUGG3,ISUBRO,ICASPL 20427 52 FORMAT('IBUGG3,ISUBRO,ICASPL = ',2(A4,2X),A4) 20428 CALL DPWRST('XXX','BUG ') 20429 WRITE(ICOUT,53)NX,NY,NHIGH,IQQNPR 20430 53 FORMAT('NX,NY.NHIGH,IQQNPR = ',4I8) 20431 CALL DPWRST('XXX','BUG ') 20432 IF(NY.GE.1)THEN 20433 DO61I=1,NY 20434 WRITE(ICOUT,62)I,Y(I) 20435 62 FORMAT('I,Y(I) = ',I8,G15.7) 20436 CALL DPWRST('XXX','BUG ') 20437 61 CONTINUE 20438 ENDIF 20439 IF(NX.GE.1)THEN 20440 DO71I=1,NX 20441 WRITE(ICOUT,72)I,X(I) 20442 72 FORMAT('I,X(I) = ',I8,G15.7) 20443 CALL DPWRST('XXX','BUG ') 20444 71 CONTINUE 20445 ENDIF 20446 ENDIF 20447C 20448C ******************************************** 20449C ** STEP 11-- ** 20450C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 20451C ******************************************** 20452C 20453C 2016/06: ONLY REQUIRE N >= 1. 20454C 20455CCCCC IF(NY.LT.2)THEN 20456 IF(NY.LT.1)THEN 20457 WRITE(ICOUT,999) 20458 CALL DPWRST('XXX','BUG ') 20459 WRITE(ICOUT,1111) 20460 1111 FORMAT('***** ERROR IN TUKEY MEAN DIFFERENCE PLOT--') 20461 CALL DPWRST('XXX','BUG ') 20462 WRITE(ICOUT,1112) 20463 1112 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE FIRST ', 20464 1 'RESPONSE VARIABLE') 20465 CALL DPWRST('XXX','BUG ') 20466 WRITE(ICOUT,1113) 20467 1113 FORMAT(' MUST BE AT LEAST 1;') 20468 CALL DPWRST('XXX','BUG ') 20469 WRITE(ICOUT,1114)NY 20470 1114 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) 20471 CALL DPWRST('XXX','BUG ') 20472 IERROR='YES' 20473 GOTO9000 20474 ELSEIF(NX.LT.1)THEN 20475 WRITE(ICOUT,999) 20476 CALL DPWRST('XXX','BUG ') 20477 WRITE(ICOUT,1111) 20478 CALL DPWRST('XXX','BUG ') 20479 WRITE(ICOUT,1122) 20480 1122 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE SECOND ', 20481 1 'RESPONSE VARIABLE') 20482 CALL DPWRST('XXX','BUG ') 20483 WRITE(ICOUT,1113) 20484 CALL DPWRST('XXX','BUG ') 20485 WRITE(ICOUT,1114)NX 20486 CALL DPWRST('XXX','BUG ') 20487 IERROR='YES' 20488 GOTO9000 20489 ELSEIF(NHIGH.GT.0 .AND. NHIGH.NE.MIN(NX,NY))THEN 20490 WRITE(ICOUT,999) 20491 CALL DPWRST('XXX','BUG ') 20492 WRITE(ICOUT,1111) 20493 CALL DPWRST('XXX','BUG ') 20494 WRITE(ICOUT,1125) 20495 1125 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE HIGHLIGHTING ', 20496 1 'VARIABLE IS') 20497 CALL DPWRST('XXX','BUG ') 20498 WRITE(ICOUT,1126) 20499 1126 FORMAT(' NOT EQUAL TO THE NUMBER OF OBSERVATIONS IN THE ', 20500 1 'SHORTER RESPONSE VARIABLE.') 20501 CALL DPWRST('XXX','BUG ') 20502 WRITE(ICOUT,1127)NY 20503 1127 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE FIRST ', 20504 1 'RESPONSE VARIABLE = ',I8) 20505 CALL DPWRST('XXX','BUG ') 20506 WRITE(ICOUT,1128)NX 20507 1128 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE SECOND ', 20508 1 'RESPONSE VARIABLE = ',I8) 20509 CALL DPWRST('XXX','BUG ') 20510 WRITE(ICOUT,1129)NHIGH 20511 1129 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE HIGHLIGHT ', 20512 1 'VARIABLE = ',I8) 20513 CALL DPWRST('XXX','BUG ') 20514 IERROR='YES' 20515 GOTO9000 20516 ENDIF 20517C 20518CCCCC HOLD=Y(1) 20519CCCCC DO1130I=1,NY 20520CCCCC IF(Y(I).NE.HOLD)GOTO1139 20521C1130 CONTINUE 20522CCCCC WRITE(ICOUT,999) 20523CCCCC CALL DPWRST('XXX','BUG ') 20524CCCCC WRITE(ICOUT,1111) 20525CCCCC CALL DPWRST('XXX','BUG ') 20526CCCCC WRITE(ICOUT,1132) 20527C1132 FORMAT(' ALL INPUT ELEMENTS FOR THE FIRST RESPONSE VARIABLE') 20528CCCCC CALL DPWRST('XXX','BUG ') 20529CCCCC WRITE(ICOUT,1133)HOLD 20530C1133 FORMAT(' ARE IDENTICALLY EQUAL TO ',G15.7) 20531CCCCC CALL DPWRST('XXX','BUG ') 20532CCCCC WRITE(ICOUT,999) 20533CCCCC CALL DPWRST('XXX','BUG ') 20534CCCCC IERROR='YES' 20535CCCCC GOTO9000 20536C1139 CONTINUE 20537C 20538CCCCC HOLD=X(1) 20539CCCCC DO1140I=1,NY 20540CCCCC IF(X(I).NE.HOLD)GOTO1149 20541C1140 CONTINUE 20542CCCCC WRITE(ICOUT,999) 20543CCCCC CALL DPWRST('XXX','BUG ') 20544CCCCC WRITE(ICOUT,1111) 20545CCCCC CALL DPWRST('XXX','BUG ') 20546CCCCC WRITE(ICOUT,1142) 20547C1142 FORMAT(' ALL INPUT ELEMENTS FOR THE SECOND RESPONSE ', 20548CCCCC1 'VARIABLE') 20549CCCCC CALL DPWRST('XXX','BUG ') 20550CCCCC WRITE(ICOUT,1133)HOLD 20551CCCCC CALL DPWRST('XXX','BUG ') 20552CCCCC WRITE(ICOUT,999) 20553CCCCC CALL DPWRST('XXX','BUG ') 20554CCCCC IERROR='YES' 20555CCCCC GOTO9000 20556C1149 CONTINUE 20557C 20558C **************************************************** 20559C ** STEP 21-- ** 20560C ** SORT Y AND SORT X ** 20561C **************************************************** 20562C 20563 IF(NHIGH.LE.0)THEN 20564 IF(IQQNPR.GT.0)THEN 20565 CALL PERCE2(IQQNPR,X,NX,IWRITE,TEMP2,MAXN,TEMP1, 20566 1 IBUGG3,ISUBRO,IERROR) 20567 DO2010II=1,IQQNPR 20568 X(II)=TEMP1(II) 20569 2010 CONTINUE 20570 NX=IQQNPR 20571C 20572 CALL PERCE2(IQQNPR,Y,NY,IWRITE,TEMP2,MAXN,TEMP1, 20573 1 IBUGG3,ISUBRO,IERROR) 20574 DO2020II=1,IQQNPR 20575 Y(II)=TEMP2(II) 20576 2020 CONTINUE 20577 NY=IQQNPR 20578C 20579 ELSE 20580 CALL SORT(X,NX,X) 20581 CALL SORT(Y,NY,Y) 20582 ENDIF 20583 ELSEIF(NY.LE.NX)THEN 20584 CALL SORT(X,NX,X) 20585 CALL SORTC(Y,XHIGH,NY,Y,XDIST) 20586 DO2101I=1,NY 20587 XHIGH(I)=XDIST(I) 20588 2101 CONTINUE 20589 ELSEIF(NY.GT.NX)THEN 20590 CALL SORT(Y,NY,Y) 20591 CALL SORTC(X,XHIGH,NX,X,XDIST) 20592 DO2103I=1,NX 20593 XHIGH(I)=XDIST(I) 20594 2103 CONTINUE 20595 ENDIF 20596C 20597C ***************************************** 20598C ** STEP 22-- ** 20599C ** DETERMINE THE TYPE CASE ** 20600C ** EQUAL SAMPLE SIZES OR NOT) ** 20601C ** AND BRANCH ACORDINGLY ** 20602C ***************************************** 20603C 20604 ICASE='UNEQ' 20605 IF(NY.EQ.NX)ICASE='EQUA' 20606 IF(ICASE.EQ.'EQUA')GOTO5100 20607C 20608C ************************************************** 20609C ** STEP 23-- ** 20610C ** DETERMINE THE SMALLER OF THE 2-- ** 20611C ** NY OR NX ** 20612C ** DETERMINE THE LARGER OF THE 2-- ** 20613C ** NY OR NX ** 20614C ************************************************** 20615C 20616 NSMALL=NX 20617 IF(NY.LT.NX)NSMALL=NY 20618 ANSMAL=NSMALL 20619C 20620 NLARGE=NX 20621 IF(NY.GT.NX)NLARGE=NY 20622 ANLARG=NLARGE 20623C 20624C **************************************************** 20625C ** STEP 24-- ** 20626C ** STEP THROUGH THE VARIOUS SORTED VALUES OF ** 20627C ** THE SMALLER OF Y OR X. ** 20628C ** COMPUTE A CORRESPONDING PERCENTAGE. ** 20629C ** ESTIMATE THIS PERCENT POINT ** 20630C ** IN THE LARGER OF Y OR X. ** 20631C **************************************************** 20632C 20633 DO2400I=1,NSMALL 20634 AI=I 20635 PSMALL=(AI-0.5)/ANSMAL 20636 IF(NY.LE.NX)YSMALL(I)=Y(I) 20637 IF(NY.GT.NX)YSMALL(I)=X(I) 20638C 20639 PLARGE=0.0 20640 DO2410J=1,NLARGE 20641 AJ=J 20642 J2=J 20643 J2M1=J2-1 20644 PPRIOR=PLARGE 20645 PLARGE=(AJ-0.5)/ANLARG 20646C 20647 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TUM2')THEN 20648 WRITE(ICOUT,777)I,J,J2,J2M1,PSMALL,PLARGE,PPRIOR 20649 777 FORMAT('I,J,J2,J2M1,PSMALL,PLARGE,PPRIOR = ',4I8,3G15.7) 20650 CALL DPWRST('XXX','BUG ') 20651 ENDIF 20652C 20653 IF(PLARGE.LT.PSMALL)GOTO2410 20654 IF(PLARGE.EQ.PSMALL)THEN 20655 IF(NY.LE.NX)YLARGE(I)=X(J2) 20656 IF(NY.GT.NX)YLARGE(I)=Y(J2) 20657 ELSE 20658 RATIO=(PSMALL-PPRIOR)/(PLARGE-PPRIOR) 20659 IF(NY.LE.NX)YLARGE(I)=RATIO*X(J2M1)+(1.0-RATIO)*X(J2) 20660 IF(NY.GT.NX)YLARGE(I)=RATIO*Y(J2M1)+(1.0-RATIO)*Y(J2) 20661 ENDIF 20662 GOTO2400 20663 2410 CONTINUE 20664 2400 CONTINUE 20665C 20666C ******************************************* 20667C ** STEP 51-- ** 20668C ** FORM PLOT COORDINATES ** 20669C ******************************************* 20670C 20671 5100 CONTINUE 20672C 20673 ISTEPN='51' 20674 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TUM2') 20675 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 20676C 20677 IF(NHIGH.GT.0)THEN 20678 CALL CODE(XHIGH,NHIGH,IWRITE,XDIST,D2,MAXN,IBUGG3,IERROR) 20679 CALL MAXIM(XDIST,NHIGH,IWRITE,XMAX,IBUGG3,IERROR) 20680 ELSE 20681 XMAX=1.0 20682 ENDIF 20683C 20684 IF(ICASE.EQ.'EQUA')THEN 20685 J=0 20686 DO5111I=1,NY 20687 J=J+1 20688 ADIFF=Y(I)-X(I) 20689 AMEAN=(Y(I)+X(I))/2.0 20690 Y2(J)=ADIFF 20691 X2(J)=AMEAN 20692 IF(NHIGH.EQ.0)THEN 20693 D2(J)=1.0 20694 ELSE 20695 D2(J)=XDIST(J) 20696 ENDIF 20697 5111 CONTINUE 20698 J=J+1 20699 X2(J)=X2(1) 20700 Y2(J)=0.0 20701 D2(J)=XMAX+1.0 20702 J=J+1 20703 X2(J)=X2(NY) 20704 Y2(J)=0.0 20705 D2(J)=XMAX+1.0 20706C 20707 ELSE 20708C 20709 J=0 20710 DO5121I=1,NSMALL 20711 J=J+1 20712 IF(NY.LE.NX)Y2(J)=YSMALL(I) 20713 IF(NY.GT.NX)Y2(J)=YLARGE(I) 20714 IF(NY.LE.NX)X2(J)=YLARGE(I) 20715 IF(NY.GT.NX)X2(J)=YSMALL(I) 20716 IF(NHIGH.EQ.0)THEN 20717 D2(J)=1.0 20718 ELSE 20719 D2(J)=XDIST(J) 20720 ENDIF 20721 ADIFF=Y2(J)-X2(J) 20722 AMEAN=(Y2(J)+X2(J))/2.0 20723 Y2(J)=ADIFF 20724 X2(J)=AMEAN 20725 5121 CONTINUE 20726C 20727 J=J+1 20728 X2(J)=X2(1) 20729 Y2(J)=0.0 20730 D2(J)=XMAX+1.0 20731 J=J+1 20732 X2(J)=X2(NSMALL) 20733 Y2(J)=0.0 20734 D2(J)=XMAX+1.0 20735 ENDIF 20736C 20737 N2=J 20738 NPLOTV=3 20739C 20740C ***************** 20741C ** STEP 90-- ** 20742C ** EXIT ** 20743C ***************** 20744C 20745 9000 CONTINUE 20746 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TUM2')THEN 20747 WRITE(ICOUT,999) 20748 CALL DPWRST('XXX','BUG ') 20749 WRITE(ICOUT,9011) 20750 9011 FORMAT('***** AT THE END OF DPTUM2--') 20751 CALL DPWRST('XXX','BUG ') 20752 WRITE(ICOUT,9012)ICASPL,ICASE,IERROR,MAXNXT,N2 20753 9012 FORMAT('ICASPL,ICASE,IERROR,MAXNXT,N2 = ',3(A4,2X),2I8) 20754 CALL DPWRST('XXX','BUG ') 20755 DO9015I=1,N2 20756 WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I) 20757 9016 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) 20758 CALL DPWRST('XXX','BUG ') 20759 9015 CONTINUE 20760 WRITE(ICOUT,9031)NY,NX,NSMALL,NLARGE,RATIO 20761 9031 FORMAT('NY,NX,NSMALL,NLARGE,RATIO = ',4I8,G15.7) 20762 CALL DPWRST('XXX','BUG ') 20763 DO9032I=1,NLARGE 20764 WRITE(ICOUT,9033)I,YLARGE(I) 20765 9033 FORMAT('I,YLARGE(I) = ',I8,E15.7) 20766 CALL DPWRST('XXX','BUG ') 20767 9032 CONTINUE 20768 DO9042I=1,NSMALL 20769 WRITE(ICOUT,9043)I,YSMALL(I) 20770 9043 FORMAT('I,YSMALL(I) = ',I8,E15.7) 20771 CALL DPWRST('XXX','BUG ') 20772 9042 CONTINUE 20773 ENDIF 20774C 20775 RETURN 20776 END 20777 SUBROUTINE DPTWFP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 20778 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 20779C 20780C PURPOSE--GIVEN DATA OF THE FORM 20781C 20782C RESPONSE LAB-ID MAT-ID 20783C 20784C GENERATE EITHER A "LABORATORIES WITHIN MATERIALS" 20785C OR A "MATERIALS WITHIN LABORATORIES" PLOT. 20786C 20787C THIS IS ESSENTIALLY A RUN SEQUENCE PLOT SORTED 20788C BY 2 FACTOR VARIABLES. 20789C 20790C THIS PLOT IS MOTIVATED BY THE DESIRE TO PLOT 20791C RESIDUALS FOR THE "PHASE 3" ANALYSIS IN THE 20792C ASTM E-691 STANDARD. THE PHASE 3 ANALYSIS 20793C (ESSENTIALLY A ROW-LINEAR MODEL FOR THE TABLE) 20794C WAS SUGGESTED BY JOHN MANDEL (SEE REFERENCES 20795C BELOW) AS AN ADDITIONAL STEP IN THE E-691 ANALYSIS 20796C (THE PHASE 3 ANALYSIS IS NOT PART OF THE STANDARD). 20797C IN PARTICULAR, HE RECOMMENDED A PLOT OF THE 20798C STANDARDIZED RESIDUALS FROM THE ROW-LINEAR MODEL 20799C (SPECIFIC PLOTS FOR THE H AND K CONSISTENCY 20800C STATISTICS CAN ALREADY BE GENERATED USING THE 20801C H CONSISTENCY PLOT COMMAND). 20802C 20803C ALTHOUGH MOTIVATED BY THE EXTENSION TO THE 20804C ASTM E-691 STANDARD, THIS PLOT CAN BE APPLIED 20805C TO ANY TWO FACTOR SET OF DATA. 20806C 20807C THERE ARE TWO FORMATS FOR THE PLOT: 20808C 20809C 1) THE VALUES ARE PLOTTED LINEARLY. THAT IS, 20810C 20811C LAB: 1 2 3 1 2 3 1 2 3 20812C MAT: 1 1 1 2 2 2 3 3 3 20813C 20814C 2) YOU CAN STACK THE LAB VALUES VERTICALLY 20815C 20816C LAB: 1 1 1 20817C 2 2 2 20818C 3 3 3 20819C MAT: 1 2 3 20820C 20821C MULTIPLE AND REPLICATION OPTIONS ARE NOT SUPPORTED 20822C FOR THIS PLOT. 20823C 20824C 20825C EXAMPLE--TWO FACTOR PLOT Y LABID MATID 20826C WRITTEN BY--ALAN HECKERT 20827C STATISTICAL ENGINEERING DIVISION 20828C INFORMATION TECHNOLOGY LABORATORY 20829C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 20830C GAITHERSBURG, MD 20899-8980 20831C PHONE--301-975-2899 20832C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 20833C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 20834C LANGUAGE--ANSI FORTRAN (1977) 20835C VERSION NUMBER--2015/6 20836C ORIGINAL VERSION--JUNE 2015. 20837C 20838C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 20839C 20840 CHARACTER*4 ICASPL 20841 CHARACTER*4 IAND1 20842 CHARACTER*4 IAND2 20843 CHARACTER*4 IBUGG2 20844 CHARACTER*4 IBUGG3 20845 CHARACTER*4 IBUGQ 20846 CHARACTER*4 ISUBRO 20847 CHARACTER*4 IFOUND 20848 CHARACTER*4 IERROR 20849C 20850 CHARACTER*4 ISUBN1 20851 CHARACTER*4 ISUBN2 20852 CHARACTER*4 ISTEPN 20853C 20854 CHARACTER*40 INAME 20855 PARAMETER (MAXSPN=10) 20856 CHARACTER*4 IVARN1(MAXSPN) 20857 CHARACTER*4 IVARN2(MAXSPN) 20858 CHARACTER*4 IVARTY(MAXSPN) 20859 REAL PVAR(MAXSPN) 20860 INTEGER ILIS(MAXSPN) 20861 INTEGER NRIGHT(MAXSPN) 20862 INTEGER ICOLR(MAXSPN) 20863C 20864C--------------------------------------------------------------------- 20865C 20866 INCLUDE 'DPCOPA.INC' 20867 INCLUDE 'DPCOZZ.INC' 20868C 20869 REAL Y1(MAXOBV) 20870 REAL MATID(MAXOBV) 20871 REAL LABID(MAXOBV) 20872 REAL XIDTEM(MAXOBV) 20873 REAL XIDTE2(MAXOBV) 20874 REAL TEMP1(MAXOBV) 20875 REAL TEMP2(MAXOBV) 20876C 20877 EQUIVALENCE (GARBAG(IGARB1),Y1(1)) 20878 EQUIVALENCE (GARBAG(IGARB2),MATID(1)) 20879 EQUIVALENCE (GARBAG(IGARB3),LABID(1)) 20880 EQUIVALENCE (GARBAG(IGARB4),XIDTEM(1)) 20881 EQUIVALENCE (GARBAG(IGARB5),XIDTE2(1)) 20882 EQUIVALENCE (GARBAG(IGARB6),TEMP1(1)) 20883 EQUIVALENCE (GARBAG(IGARB7),TEMP2(1)) 20884C 20885C-----COMMON---------------------------------------------------------- 20886C 20887 INCLUDE 'DPCOST.INC' 20888 INCLUDE 'DPCOHO.INC' 20889 INCLUDE 'DPCOHK.INC' 20890 INCLUDE 'DPCODA.INC' 20891 INCLUDE 'DPCOP2.INC' 20892C 20893C-----START POINT----------------------------------------------------- 20894C 20895 IERROR='NO' 20896 IFOUND='NO' 20897 ISUBN1='DPTW' 20898 ISUBN2='FP ' 20899C 20900 MAXCP1=MAXCOL+1 20901 MAXCP2=MAXCOL+2 20902 MAXCP3=MAXCOL+3 20903 MAXCP4=MAXCOL+4 20904 MAXCP5=MAXCOL+5 20905 MAXCP6=MAXCOL+6 20906C 20907C **************************************** 20908C ** TREAT THE TWO FACTOR PLOT CASE ** 20909C **************************************** 20910C 20911 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TWFP')THEN 20912 WRITE(ICOUT,999) 20913 999 FORMAT(1X) 20914 CALL DPWRST('XXX','BUG ') 20915 WRITE(ICOUT,51) 20916 51 FORMAT('***** AT THE BEGINNING OF DPTWFP--') 20917 CALL DPWRST('XXX','BUG ') 20918 WRITE(ICOUT,52)IBUGG2,IBUGG3,IBUGQ,ISUBRO 20919 52 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4) 20920 CALL DPWRST('XXX','BUG ') 20921 WRITE(ICOUT,53)ICASPL,IAND1,IAND2,MAXN 20922 53 FORMAT('ICASPL,IAND1,IAND2,MAXN = ',3(A4,2X),I8) 20923 CALL DPWRST('XXX','BUG ') 20924 ENDIF 20925C 20926C *************************** 20927C ** STEP 1-- ** 20928C ** EXTRACT THE COMMAND ** 20929C *************************** 20930C 20931 ISTEPN='11' 20932 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TWFP') 20933 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 20934C 20935 IF(NUMARG.GE.2.AND.ICOM.EQ.'TWO '.AND.IHARG(1).EQ.'FACT'.AND. 20936 1 IHARG(2).EQ.'PLOT')THEN 20937 ILASTC=2 20938 ICASPL='TWFP' 20939 ELSE 20940 GOTO9000 20941 ENDIF 20942C 20943 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 20944 IFOUND='YES' 20945C 20946C **************************************** 20947C ** STEP 2-- ** 20948C ** EXTRACT THE VARIABLE LIST ** 20949C **************************************** 20950C 20951 ISTEPN='2' 20952 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TWFP') 20953 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 20954C 20955 INAME='TWO FACTOR PLOT' 20956 MINNA=3 20957 MAXNA=100 20958 MINN2=5 20959 IFLAGE=1 20960 IFLAGM=0 20961 IFLAGP=0 20962 JMIN=1 20963 JMAX=NUMARG 20964 MINNVA=3 20965 MAXNVA=3 20966C 20967 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 20968 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 20969 1 JMIN,JMAX, 20970 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 20971 1 IVARN1,IVARN2,IVARTY,PVAR, 20972 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 20973 1 MINNVA,MAXNVA, 20974 1 IFLAGM,IFLAGP, 20975 1 IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 20976 IF(IERROR.EQ.'YES')GOTO9000 20977C 20978 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TWFP')THEN 20979 WRITE(ICOUT,999) 20980 CALL DPWRST('XXX','BUG ') 20981 WRITE(ICOUT,281) 20982 281 FORMAT('***** AFTER CALL DPPARS--') 20983 CALL DPWRST('XXX','BUG ') 20984 WRITE(ICOUT,282)NQ,NUMVAR 20985 282 FORMAT('NQ,NUMVAR = ',2I8) 20986 CALL DPWRST('XXX','BUG ') 20987 IF(NUMVAR.GT.0)THEN 20988 DO285I=1,NUMVAR 20989 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 20990 1 ICOLR(I),IVARTY(I) 20991 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 20992 1 'ICOLR(I),IVARTY(I) = ',I8,2X,A4,A4,2X,3I8,2X,A4) 20993 CALL DPWRST('XXX','BUG ') 20994 285 CONTINUE 20995 ENDIF 20996 ENDIF 20997C 20998C ********************************************** 20999C ** STEP 33-- ** 21000C ** FORM THE SUBSETTED VARIABLES ** 21001C ** Y(.) ** 21002C ** LABID(.) ** 21003C ** MATID(.) ** 21004C ********************************************** 21005C 21006 ISTEPN='33' 21007 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TWFP') 21008 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 21009C 21010 ICOL=1 21011 CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 21012 1 INAME,IVARN1,IVARN2,IVARTY, 21013 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 21014 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 21015 1 MAXCP4,MAXCP5,MAXCP6, 21016 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 21017 1 Y1,LABID,MATID,XIDTEM,XIDTEM,XIDTEM,XIDTEM,NS, 21018 1 IBUGG3,ISUBRO,IFOUND,IERROR) 21019 IF(IERROR.EQ.'YES')GOTO9000 21020C 21021C ******************************************************* 21022C ** STEP 8-- ** 21023C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** 21024C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** 21025C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** 21026C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** 21027C ******************************************************* 21028C 21029 ISTEPN='5' 21030 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TWFP') 21031 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 21032C 21033 CALL DPTWF2(Y1,LABID,MATID,NS,NUMVAR,ICASPL, 21034 1 ITWFPT,ITWFGP,ITWFLM, 21035 1 ITWFM1,ITWFM2,ITWFL1,ITWFL2, 21036 1 XIDTEM,XIDTE2,TEMP1,TEMP2, 21037 1 Y,X,D, 21038 1 NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 21039C 21040C ***************** 21041C ** STEP 9-- ** 21042C ** EXIT ** 21043C ***************** 21044C 21045 9000 CONTINUE 21046 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TWFP')THEN 21047 WRITE(ICOUT,999) 21048 CALL DPWRST('XXX','BUG ') 21049 WRITE(ICOUT,9011) 21050 9011 FORMAT('***** AT THE END OF DPTWFP--') 21051 CALL DPWRST('XXX','BUG ') 21052 WRITE(ICOUT,9013)IFOUND,IERROR 21053 9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 21054 CALL DPWRST('XXX','BUG ') 21055 WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 21056 9014 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',3I8,3(2X,A4)) 21057 CALL DPWRST('XXX','BUG ') 21058 ENDIF 21059C 21060 RETURN 21061 END 21062 SUBROUTINE DPTWF2(Y1,LABID,MATID,N,NUMVAR,ICASPL, 21063 1 ITWFPT,ITWFGP,ITWFLM, 21064 1 ITWFM1,ITWFM2,ITWFL1,ITWFL2, 21065 1 XIDTEM,XIDTE2,TEMP1,TEMP2, 21066 1 Y,X,D, 21067 1 NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 21068C 21069C PURPOSE--GIVEN DATA OF THE FORM 21070C 21071C RESPONSE LAB-ID MAT-ID 21072C 21073C GENERATE EITHER A "LABORATORIES WITHIN MATERIALS" 21074C OR A "MATERIALS WITHIN LABORATORIES" PLOT. 21075C 21076C THIS IS ESSENTIALLY A RUN SEQUENCE PLOT SORTED 21077C BY 2 FACTOR VARIABLES. 21078C 21079C THIS PLOT IS MOTIVATED BY THE DESIRE TO PLOT 21080C RESIDUALS FOR THE "PHASE 3" ANALYSIS IN THE 21081C ASTM E-691 STANDARD. THE PHASE 3 ANALYSIS 21082C (ESSENTIALLY A ROW-LINEAR MODEL FOR THE TABLE) 21083C WAS SUGGESTED BY JOHN MANDEL (SEE REFERENCES 21084C BELOW) AS AN ADDITIONAL STEP IN THE E-691 ANALYSIS 21085C (THE PHASE 3 ANALYSIS IS NOT PART OF THE STANDARD). 21086C IN PARTICULAR, HE RECOMMENDED A PLOT OF THE 21087C STANDARDIZED RESIDUALS FROM THE ROW-LINEAR MODEL 21088C (SPECIFIC PLOTS FOR THE H AND K CONSISTENCY 21089C STATISTICS CAN ALREADY BE GENERATED USING THE 21090C H CONSISTENCY PLOT COMMAND). 21091C 21092C ALTHOUGH MOTIVATED BY THE EXTENSION TO THE 21093C ASTM E-691 STANDARD, THIS PLOT CAN BE APPLIED 21094C TO ANY TWO FACTOR SET OF DATA. 21095C 21096C THERE ARE TWO FORMATS FOR THE PLOT: 21097C 21098C 1) THE VALUES ARE PLOTTED LINEARLY. THAT IS, 21099C 21100C LAB: 1 2 3 1 2 3 1 2 3 21101C MAT: 1 1 1 2 2 2 3 3 3 21102C 21103C 2) YOU CAN STACK THE LAB VALUES VERTICALLY 21104C 21105C LAB: 1 1 1 21106C 2 2 2 21107C 3 3 3 21108C MAT: 1 2 3 21109C 21110C MULTIPLE AND REPLICATION OPTIONS ARE NOT SUPPORTED 21111C FOR THIS PLOT. 21112C 21113C REFERENCES--"Standard Practice for Conducting an Interlaboratory 21114C Study to Determine the Precision of a Test Method", 21115C ASTM International, 100 Barr Harbor Drive, PO BOX C700, 21116C West Conshohoceken, PA 19428-2959, USA. 21117C --Mandel (1994), "Analyzing Interlaboratory Data 21118C According to ASTM Standard E691", Quality and 21119C Statistics: Total Quality Management,ASTM STP 1209, 21120C Kowalewski, Ed., American Society for Testing and 21121C Materials, Philadelphia, PA 1994, pp. 59-70. 21122C --Mandel (1995), "Structure and Outliers in 21123C Interlaboratory Studies", Journal of Testing and 21124C Evaluation, Vol. 23, No. 5, pp. 364-369. 21125C --Mandel (1991), "Evaluation and Control of 21126C Measurements", Marcel Dekker, Inc., chapter 7. 21127C WRITTEN BY--ALAN HECKERT 21128C STATISTICAL ENGINEERING DIVISION 21129C INFORMATION TECHNOLOGY LABORATORY 21130C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 21131C GAITHERSBURG, MD 20899-8980 21132C PHONE--301-975-2899 21133C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 21134C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 21135C LANGUAGE--ANSI FORTRAN (1977) 21136C VERSION NUMBER--2015/6 21137C ORIGINAL VERSION--JUNE 2015. 21138C 21139C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 21140C 21141 CHARACTER*4 ICASPL 21142 CHARACTER*4 ITWFPT 21143 CHARACTER*4 ITWFLM 21144 CHARACTER*4 IBUGG3 21145 CHARACTER*4 ISUBRO 21146 CHARACTER*4 IERROR 21147C 21148 CHARACTER*4 IWRITE 21149 CHARACTER*4 ISUBN1 21150 CHARACTER*4 ISUBN2 21151 CHARACTER*4 ISTEPN 21152C 21153C--------------------------------------------------------------------- 21154C 21155 REAL Y1(*) 21156 REAL MATID(*) 21157 REAL LABID(*) 21158 REAL XIDTEM(*) 21159 REAL XIDTE2(*) 21160 REAL TEMP1(*) 21161 REAL TEMP2(*) 21162C 21163 REAL Y(*) 21164 REAL X(*) 21165 REAL D(*) 21166C 21167C-----COMMON---------------------------------------------------------- 21168C 21169 INCLUDE 'DPCOP2.INC' 21170C 21171C-----START POINT----------------------------------------------------- 21172C 21173 ISUBN1='DPTW' 21174 ISUBN2='F2 ' 21175 IWRITE='OFF' 21176 IERROR='NO' 21177 NPLOTP=0 21178 NPLOTV=3 21179C 21180 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TWF2')THEN 21181 WRITE(ICOUT,999) 21182 CALL DPWRST('XXX','BUG ') 21183 WRITE(ICOUT,71) 21184 71 FORMAT('***** AT THE BEGINNING OF DPTWF2--') 21185 CALL DPWRST('XXX','BUG ') 21186 WRITE(ICOUT,72)IBUGG3,ISUBRO,ICASPL,N,NUMVAR 21187 72 FORMAT('IBUGG3,ISUBRO,ICASPL,N,NUMVAR = ',3(A4,2X),2I8) 21188 CALL DPWRST('XXX','BUG ') 21189 IF(N.GT.0)THEN 21190 DO81I=1,N 21191 WRITE(ICOUT,82)I,Y1(I),MATID(I),LABID(I) 21192 82 FORMAT('I,Y1(I),MATID(I),LABID(I) = ',I8,3G15.7) 21193 CALL DPWRST('XXX','BUG ') 21194 81 CONTINUE 21195 ENDIF 21196 ENDIF 21197C 21198C ******************************************** 21199C ** STEP 1-- ** 21200C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 21201C ******************************************** 21202C 21203 IF(N.LT.5)THEN 21204 WRITE(ICOUT,999) 21205 999 FORMAT(1X) 21206 CALL DPWRST('XXX','BUG ') 21207 WRITE(ICOUT,31) 21208 31 FORMAT('***** ERROR IN TWO FACTOR PLOT--') 21209 CALL DPWRST('XXX','BUG ') 21210 WRITE(ICOUT,32) 21211 32 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 5.') 21212 CALL DPWRST('XXX','BUG ') 21213 WRITE(ICOUT,34)N 21214 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) 21215 CALL DPWRST('XXX','BUG ') 21216 WRITE(ICOUT,999) 21217 CALL DPWRST('XXX','BUG ') 21218 IERROR='YES' 21219 GOTO9000 21220 ENDIF 21221C 21222C ****************************************************** 21223C ** STEP 1-- ** 21224C ** DETERMINE THE NUMBER OF DISTINCT VALUES ** 21225C ** FOR THE GROUP VARIABLES (LABID, MATID). ** 21226C ** CHECK FOR MISSING CELLS AND FOR REPLICATION ** 21227C ** WITHIN CELLS (REPLICATED VALUES WILL BE ** 21228C ** REPLACED WITH THEIR MEAN VALUE). ** 21229C ****************************************************** 21230C 21231 ISTEPN='1' 21232 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TWF2') 21233 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 21234C 21235 CALL DISTIN(LABID,N,IWRITE,XIDTEM,NUMSE1,IBUGG3,IERROR) 21236 CALL SORT(XIDTEM,NUMSE1,XIDTEM) 21237 CALL DISTIN(MATID,N,IWRITE,XIDTE2,NUMSE2,IBUGG3,IERROR) 21238 CALL SORT(XIDTE2,NUMSE2,XIDTE2) 21239C 21240C CHECK FOR MISSING CELLS (PLOT CURRENTLY NOT SUPPORTED FOR 21241C CASE WHERE THERE IS MISSING CELLS). IF REPLICATION IS DETECTED, 21242C REPLACE RAW DATA WITH CELL AVERAGES. 21243C 21244 IREPL=0 21245 DO110ISET1=1,NUMSE1 21246 AHOLD1=XIDTEM(ISET1) 21247 DO120ISET2=1,NUMSE2 21248 AHOLD2=XIDTE2(ISET2) 21249 K=0 21250 DO130I=1,N 21251 IF(LABID(I).EQ.AHOLD1 .AND. MATID(I).EQ.AHOLD2)THEN 21252 K=K+1 21253 GOTO139 21254 ENDIF 21255 130 CONTINUE 21256 139 CONTINUE 21257 IF(K.EQ.0)THEN 21258 WRITE(ICOUT,999) 21259 CALL DPWRST('XXX','BUG ') 21260 WRITE(ICOUT,31) 21261 CALL DPWRST('XXX','BUG ') 21262 WRITE(ICOUT,142) 21263 142 FORMAT(' THERE IS NO DATA FOR:') 21264 CALL DPWRST('XXX','BUG ') 21265 WRITE(ICOUT,144)AHOLD1 21266 144 FORMAT(' GROUP ONE VARIABLE WITH VALUE: ',G15.7) 21267 CALL DPWRST('XXX','BUG ') 21268 WRITE(ICOUT,146)AHOLD2 21269 146 FORMAT(' GROUP TWO VARIABLE WITH VALUE: ',G15.7) 21270 CALL DPWRST('XXX','BUG ') 21271 WRITE(ICOUT,148) 21272 148 FORMAT(' THIS COMMAND IS NOT SUPPORTED FOR THE CASE ', 21273 1 'WHERE THERE ARE MISSING CELLS.') 21274 CALL DPWRST('XXX','BUG ') 21275 IERROR='YES' 21276 GOTO9000 21277 ELSEIF(K.GT.1)THEN 21278 IREPL=1 21279 ENDIF 21280 120 CONTINUE 21281 110 CONTINUE 21282C 21283C IF REPLICATION DETECTED, REPLACE RAW VALUES WITH MEANS 21284C 21285 ICNT=0 21286 IF(IREPL.EQ.1)THEN 21287 DO210ISET1=1,NUMSE1 21288 AHOLD1=XIDTEM(ISET1) 21289 DO220ISET2=1,NUMSE2 21290 AHOLD2=XIDTE2(ISET2) 21291 K=0 21292 DO230I=1,N 21293 IF(LABID(I).EQ.AHOLD1 .AND. MATID(I).EQ.AHOLD2)THEN 21294 K=K+1 21295 TEMP1(K)=Y(I) 21296 ENDIF 21297 230 CONTINUE 21298C 21299 ICNT=ICNT+1 21300 IF(K.EQ.1)THEN 21301 TEMP2(ICNT)=TEMP1(1) 21302 ELSE 21303 CALL MEAN(TEMP1,K,IWRITE,XMEAN,IBUGG3,IERROR) 21304 TEMP2(ICNT)=XMEAN 21305 ENDIF 21306 XIDTEM(ICNT)=AHOLD1 21307 XIDTE2(ICNT)=AHOLD2 21308C 21309 220 CONTINUE 21310 210 CONTINUE 21311C 21312 DO310I=1,ICNT 21313 Y(I)=TEMP2(I) 21314 LABID(I)=XIDTEM(I) 21315 MATID(I)=XIDTE2(I) 21316 310 CONTINUE 21317 N=ICNT 21318 ENDIF 21319C 21320C 21321C 21322C ******************************************** 21323C ** STEP 2-- ** 21324C ** GENERATE THE PLOT COORDINATES. ** 21325C ******************************************** 21326C 21327C NOTE: TYPICALLY, WE WANT TO COMPUTE THE H AND K CONSISTENCY 21328C STATISTICS BASED ON ALL LAB's AND MATERIALS. HOWEVER, 21329C WE SOMETIMES WANT TO RESTRICT THE PLOT TO A SUBSET 21330C OF MATERIALS OR LABORATORIES FOR BETTER PLOT 21331C RESOLUTION. 21332C 21333C TO ADDRESS THIS, THE FOLLOWING COMMANDS WERE ADDED: 21334C 21335C SET TWO FACTOR PLOT MATERIAL FIRST <value> 21336C SET TWO FACTOR PLOT MATERIAL LAST <value> 21337C SET TWO FACTOR PLOT LABORATORY FIRST <value> 21338C SET TWO FACTOR PLOT LABORATORY LAST <value> 21339C 21340 IWRITE='OFF' 21341 CALL DISTIN(LABID,N,IWRITE,XIDTEM,NLAB,IBUGG3,IERROR) 21342 CALL DISTIN(MATID,N,IWRITE,XIDTE2,NMAT,IBUGG3,IERROR) 21343 NTOT=NLAB*NMAT 21344 IMAT1=ITWFM1 21345 IF(IMAT1.LT.1 .OR. IMAT1.GT.NMAT)IMAT1=1 21346 IMAT2=ITWFM2 21347 IF(IMAT2.LT.1 .OR. IMAT2.GT.NMAT)IMAT2=NMAT 21348 ILAB1=ITWFL1 21349 IF(ILAB1.LT.1 .OR. ILAB1.GT.NLAB)ILAB1=1 21350 ILAB2=ITWFL2 21351 IF(ILAB2.LT.1 .OR. ILAB2.GT.NLAB)ILAB2=NLAB 21352 IF(IMAT1.GT.IMAT2)IMAT1=IMAT2 21353 IF(ILAB1.GT.ILAB2)ILAB1=ILAB2 21354C 21355 NPLOTP=0 21356C 21357 IF(ITWFPT.EQ.'DEFA')THEN 21358 IXCNT=0 21359 IXCNT2=0 21360 IF(ITWFLM.EQ.'LABO')THEN 21361 DO1010J=1,NMAT 21362 DO1020I=1,NLAB 21363 IXCNT=IXCNT+1 21364 IF(J.LT.IMAT1 .OR. J.GT.IMAT2)GOTO1020 21365 IF(I.LT.ILAB1 .OR. I.GT.ILAB2)GOTO1020 21366 IXCNT2=IXCNT2+1 21367 NPLOTP=NPLOTP+1 21368 Y(NPLOTP)=Y1(IXCNT) 21369 X(NPLOTP)=REAL(IXCNT2) 21370 D(NPLOTP)=1.0 21371 1020 CONTINUE 21372 IF(ITWFGP.GT.0 .AND. J.LT.NMAT)IXCNT2=IXCNT2+ITWFGP 21373 1010 CONTINUE 21374 ITAG=1 21375 NLAST=IXCNT2 21376 ELSE 21377 DO1030J=1,NLAB 21378 DO1040I=1,NMAT 21379 IF(J.LT.ILAB1 .OR. J.GT.ILAB2)GOTO1040 21380 IF(I.LT.IMAT1 .OR. I.GT.IMAT2)GOTO1040 21381 IXCNT=IXCNT+1 21382 IXCNT2=IXCNT2+1 21383 IXCNT3=(I-1)*NLAB + J 21384 NPLOTP=NPLOTP+1 21385 Y(NPLOTP)=Y1(IXCNT3) 21386 X(NPLOTP)=REAL(IXCNT2) 21387 D(NPLOTP)=1.0 21388 1040 CONTINUE 21389 IF(ITWFGP.GT.0 .AND. J.LT.NMAT)IXCNT2=IXCNT2+ITWFGP 21390 1030 CONTINUE 21391 ITAG=1 21392 NLAST=IXCNT2 21393 ENDIF 21394 ELSE 21395 IXCNT=0 21396 IF(ITWFLM.EQ.'LABO')THEN 21397 DO1110J=1,NMAT 21398 DO1120I=1,NLAB 21399 IXCNT=IXCNT+1 21400 IF(J.LT.IMAT1 .OR. J.GT.IMAT2)GOTO1120 21401 IF(I.LT.ILAB1 .OR. I.GT.ILAB2)GOTO1120 21402 NPLOTP=NPLOTP+1 21403 Y(NPLOTP)=Y1(IXCNT) 21404 X(NPLOTP)=REAL(J) 21405 D(NPLOTP)=REAL(I) 21406 1120 CONTINUE 21407 1110 CONTINUE 21408 ITAG=NLAB 21409 NLAST=NMAT 21410 ELSE 21411 DO1130J=1,NLAB 21412 DO1140I=1,NMAT 21413 IF(J.LT.ILAB1 .OR. J.GT.ILAB2)GOTO1140 21414 IF(I.LT.IMAT1 .OR. I.GT.IMAT2)GOTO1140 21415 IXCNT=IXCNT+1 21416 NPLOTP=NPLOTP+1 21417 IXCNT3=(I-1)*NLAB + J 21418 Y(NPLOTP)=Y1(IXCNT3) 21419 X(NPLOTP)=REAL(J) 21420 D(NPLOTP)=REAL(I) 21421 1140 CONTINUE 21422 1130 CONTINUE 21423 ITAG=NMAT 21424 NLAST=NLAB 21425 ENDIF 21426 ENDIF 21427C 21428C ***************** 21429C ** STEP 90-- ** 21430C ** EXIT ** 21431C ***************** 21432C 21433 9000 CONTINUE 21434 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TWF2')THEN 21435 WRITE(ICOUT,999) 21436 CALL DPWRST('XXX','BUG ') 21437 WRITE(ICOUT,9011) 21438 9011 FORMAT('***** AT THE END OF DPTWF2--') 21439 CALL DPWRST('XXX','BUG ') 21440 WRITE(ICOUT,9013)IERROR,NPLOTP,NPLOTV 21441 9013 FORMAT('IERROR,NPLOTP,NPLOTV = ',A4,2X,2I8) 21442 CALL DPWRST('XXX','BUG ') 21443 IF(NPLOTP.GT.0)THEN 21444 DO9035I=1,NPLOTP 21445 WRITE(ICOUT,9036)I,Y(I),X(I),D(I) 21446 9036 FORMAT('I,Y(I),X(I),D(I) = ',I8,2G15.7,F9.2) 21447 CALL DPWRST('XXX','BUG ') 21448 9035 CONTINUE 21449 ENDIF 21450 ENDIF 21451C 21452 RETURN 21453 END 21454 SUBROUTINE DPTWPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 21455 1 ICAPSW,ICAPTY,IFORSW, 21456 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 21457C 21458C PURPOSE--GENERATE MANDEL'S ROW-LINEAR OR COLUMN-LINEAR PLOTS FOR 21459C JOHN MANDEL'S TWO-WAY TABLE ANALYSIS 21460C 21461C WRITTEN BY--ALAN HECKERT 21462C STATISTICAL ENGINEERING DIVISION 21463C INFORMATION TECHNOLOGY LABORATORY 21464C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 21465C GAITHERSBURG, MD 20899-8980 21466C PHONE--301-975-2899 21467C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 21468C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 21469C LANGUAGE--ANSI FORTRAN (1977) 21470C VERSION NUMBER--2015/06 21471C ORIGINAL VERSION--JUNE 2015. 21472C 21473C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 21474C 21475 CHARACTER*4 ICAPSW 21476 CHARACTER*4 ICAPTY 21477 CHARACTER*4 IFORSW 21478 CHARACTER*4 ICASPL 21479 CHARACTER*4 ICASP2 21480 CHARACTER*4 IAND1 21481 CHARACTER*4 IAND2 21482 CHARACTER*4 ICONT 21483 CHARACTER*4 ISUBRO 21484 CHARACTER*4 IBUGG2 21485 CHARACTER*4 IBUGG3 21486 CHARACTER*4 IBUGQ 21487 CHARACTER*4 IFOUND 21488 CHARACTER*4 IERROR 21489C 21490 CHARACTER*4 ISUBN1 21491 CHARACTER*4 ISUBN2 21492 CHARACTER*4 ISTEPN 21493C 21494 CHARACTER*40 INAME 21495 PARAMETER (MAXSPN=30) 21496 CHARACTER*4 IVARN1(MAXSPN) 21497 CHARACTER*4 IVARN2(MAXSPN) 21498 CHARACTER*4 IVARTY(MAXSPN) 21499 REAL PVAR(MAXSPN) 21500 INTEGER ILIS(MAXSPN) 21501 INTEGER NRIGHT(MAXSPN) 21502 INTEGER ICOLR(MAXSPN) 21503 CHARACTER*12 IX1LAB 21504 CHARACTER*12 IX2LAB 21505 CHARACTER*25 IYLAB 21506C 21507C--------------------------------------------------------------------- 21508C 21509 INCLUDE 'DPCOPA.INC' 21510 INCLUDE 'DPCOZZ.INC' 21511C 21512 DIMENSION Y1(MAXOBV) 21513 DIMENSION TAG1(MAXOBV) 21514 DIMENSION TAG2(MAXOBV) 21515 DIMENSION XIDTEM(MAXOBV) 21516 DIMENSION XIDTE2(MAXOBV) 21517 DIMENSION TEMP1(MAXOBV) 21518 DIMENSION TEMP2(MAXOBV) 21519 DIMENSION TEMP3(MAXOBV) 21520 DIMENSION TEMP4(MAXOBV) 21521 DIMENSION TEMP5(MAXOBV) 21522C 21523 EQUIVALENCE (GARBAG(IGARB1),Y1(1)) 21524 EQUIVALENCE (GARBAG(IGARB2),XIDTEM(1)) 21525 EQUIVALENCE (GARBAG(IGARB3),XIDTE2(1)) 21526 EQUIVALENCE (GARBAG(IGARB4),TEMP1(1)) 21527 EQUIVALENCE (GARBAG(IGARB5),TEMP2(1)) 21528 EQUIVALENCE (GARBAG(IGARB6),TEMP3(1)) 21529 EQUIVALENCE (GARBAG(IGARB7),TEMP4(1)) 21530 EQUIVALENCE (GARBAG(IGARB8),TEMP5(1)) 21531 EQUIVALENCE (GARBAG(IGARB9),TAG1(1)) 21532 EQUIVALENCE (GARBAG(IGAR10),TAG2(1)) 21533C 21534C-----COMMON---------------------------------------------------------- 21535C 21536 INCLUDE 'DPCOHK.INC' 21537 INCLUDE 'DPCODA.INC' 21538 INCLUDE 'DPCOHO.INC' 21539 INCLUDE 'DPCOST.INC' 21540 INCLUDE 'DPCOP2.INC' 21541C 21542C-----START POINT----------------------------------------------------- 21543C 21544 IERROR='NO' 21545 ISUBN1='DPTW' 21546 ISUBN2='PL ' 21547 ICASPL='TWOW' 21548 ICASP2='ROW' 21549C 21550 MAXCP1=MAXCOL+1 21551 MAXCP2=MAXCOL+2 21552 MAXCP3=MAXCOL+3 21553 MAXCP4=MAXCOL+4 21554 MAXCP5=MAXCOL+5 21555 MAXCP6=MAXCOL+6 21556C 21557C ****************************************** 21558C ** TREAT THE CROSS TABULATE PLOT CASE ** 21559C ****************************************** 21560C 21561 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TWPL')THEN 21562 WRITE(ICOUT,999) 21563 999 FORMAT(1X) 21564 CALL DPWRST('XXX','BUG ') 21565 WRITE(ICOUT,51) 21566 51 FORMAT('***** AT THE BEGINNING OF DPTWPL--') 21567 CALL DPWRST('XXX','BUG ') 21568 WRITE(ICOUT,52)ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ 21569 52 FORMAT('ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ = ',5(A4,2X),A4) 21570 CALL DPWRST('XXX','BUG ') 21571 WRITE(ICOUT,53)ICASPL,IAND1,IAND2 21572 53 FORMAT('ICASPL,IAND1,IAND2 = ',2(A4,2X),A4) 21573 CALL DPWRST('XXX','BUG ') 21574 ENDIF 21575C 21576C ************************************* 21577C ** STEP 1-- ** 21578C ** EXTRACT THE COMMAND ** 21579C ** COMMAND SYNTAX IS: ** 21580C ** TWO-WAY <ROW/COLUMN> PLOT ** 21581C ************************************* 21582C 21583 ISTEPN='1' 21584 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TWPL') 21585 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 21586C 21587 IF(NUMARG.LE.2)GOTO9000 21588 IF(ICOM.EQ.'TWO ' .AND. IHARG(1).EQ.'WAY')THEN 21589 IF(IHARG(2).EQ.'PLOT')THEN 21590 IFOUND='YES' 21591 ILASTC=2 21592 ELSEIF(IHARG(2).EQ.'ROW ' .AND. IHARG(3).EQ.'PLOT')THEN 21593 IFOUND='YES' 21594 ILASTC=3 21595 ELSEIF(IHARG(2).EQ.'COLU' .AND. IHARG(3).EQ.'PLOT')THEN 21596 ICASP2='COLU' 21597 IFOUND='YES' 21598 ILASTC=3 21599 ELSE 21600 IFOUND='NO' 21601 GOTO9000 21602 ENDIF 21603 ENDIF 21604C 21605 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 21606C 21607C ********************************* 21608C ** STEP 2-- ** 21609C ** EXTRACT THE VARIABLE LIST ** 21610C ********************************* 21611C 21612 INAME='TWO-WAY ROW PLOT' 21613 IF(ICASP2.EQ.'COLU') INAME='TWO-WAY COLUMN PLOT' 21614 MINNA=1 21615 MAXNA=100 21616 MINN2=5 21617 IFLAGE=1 21618 IFLAGM=8 21619 IFLAGP=0 21620 JMIN=1 21621 JMAX=NUMARG 21622 MINNVA=3 21623 MAXNVA=3 21624C 21625 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 21626 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 21627 1 JMIN,JMAX, 21628 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 21629 1 IVARN1,IVARN2,IVARTY,PVAR, 21630 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 21631 1 MINNVA,MAXNVA, 21632 1 IFLAGM,IFLAGP, 21633 1 IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 21634 IF(IERROR.EQ.'YES')GOTO9000 21635C 21636 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TWPL')THEN 21637 WRITE(ICOUT,999) 21638 CALL DPWRST('XXX','BUG ') 21639 WRITE(ICOUT,281) 21640 281 FORMAT('***** AFTER CALL DPPARS--') 21641 CALL DPWRST('XXX','BUG ') 21642 WRITE(ICOUT,282)NQ,NUMVAR 21643 282 FORMAT('NQ,NUMVAR = ',2I8) 21644 CALL DPWRST('XXX','BUG ') 21645 IF(NUMVAR.GT.0)THEN 21646 DO285I=1,NUMVAR 21647 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 21648 1 ICOLR(I) 21649 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 21650 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 21651 CALL DPWRST('XXX','BUG ') 21652 285 CONTINUE 21653 ENDIF 21654 ENDIF 21655C 21656C NEED FOLLOWING VARIABLES: 21657C 1) TWO GROUP-ID VARIABLE 21658C 2) ONE RESPONSE VARIABLE 21659C VARIABLES 21660C 21661C 21662C ******************************** 21663C ** STEP 3-- ** 21664C ** EXTRACT THE DATA ** 21665C ******************************** 21666C 21667 ISTEPN='3' 21668 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TWPL') 21669 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 21670C 21671 IYLAB=' ' 21672 IX1LAB=' ' 21673 IX2LAB=' ' 21674 IF(NUMVAR.EQ.1)THEN 21675 ICOL=1 21676 IF(IVARLB(ICOLR(1)).EQ.' ')THEN 21677 IYLAB(1:4)=IVARN1(1)(1:4) 21678 IYLAB(5:8)=IVARN2(1)(1:4) 21679 ELSE 21680 IYLAB(1:25)=IVARLB(ICOLR(1))(1:25) 21681 ENDIF 21682 IX1LAB='ROW' 21683 IX2LAB='COLUMN' 21684 CALL DPPARZ(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 21685 1 INAME,IVARN1,IVARN2,IVARTY, 21686 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 21687 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 21688 1 MAXCP4,MAXCP5,MAXCP6, 21689 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 21690 1 Y1,TAG1,TAG2,NLOCAL, 21691 1 IBUGG3,ISUBRO,IFOUND,IERROR) 21692 ELSE 21693 ICOL=1 21694 IF(IVARLB(ICOLR(1)).EQ.' ')THEN 21695 IYLAB(1:4)=IVARN1(1)(1:4) 21696 IYLAB(5:8)=IVARN2(1)(1:4) 21697 ELSE 21698 IYLAB(1:25)=IVARLB(ICOLR(1))(1:25) 21699 ENDIF 21700 IF(IVARLB(ICOLR(2)).EQ.' ')THEN 21701 IX1LAB(1:4)=IVARN1(2)(1:4) 21702 IX1LAB(5:8)=IVARN2(2)(1:4) 21703 ELSE 21704 IX1LAB(1:12)=IVARLB(ICOLR(2))(1:12) 21705 ENDIF 21706 IF(IVARLB(ICOLR(3)).EQ.' ')THEN 21707 IX2LAB(1:4)=IVARN1(3)(1:4) 21708 IX2LAB(5:8)=IVARN2(3)(1:4) 21709 ELSE 21710 IX2LAB(1:12)=IVARLB(ICOLR(3))(1:12) 21711 ENDIF 21712 CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 21713 1 INAME,IVARN1,IVARN2,IVARTY, 21714 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 21715 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 21716 1 MAXCP4,MAXCP5,MAXCP6, 21717 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 21718 1 Y1,TAG1,TAG2,TEMP1,TEMP1,TEMP1,TEMP1,NLOCAL, 21719 1 IBUGG3,ISUBRO,IFOUND,IERROR) 21720 ENDIF 21721 IF(IERROR.EQ.'YES')GOTO9000 21722C 21723C ****************************************************** 21724C ** STEP 4-- ** 21725C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** 21726C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** 21727C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** 21728C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** 21729C ****************************************************** 21730C 21731 ISTEPN='4' 21732 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TWPL') 21733 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 21734C 21735 CALL DPTWP2(Y1,TAG1,TAG2,NLOCAL,NUMVAR,ICASPL,ICASP2, 21736 1 IYLAB,IX1LAB,IX2LAB, 21737 1 ICAPSW,ICAPTY,IFORSW, 21738 1 TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,XIDTEM,XIDTE2, 21739 1 Y,X,D,NPLOTP,NPLOTV,ISUBRO,IBUGG3,IERROR) 21740C 21741C 21742C ***************** 21743C ** STEP 90-- ** 21744C ** EXIT ** 21745C ***************** 21746C 21747 9000 CONTINUE 21748 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TWPL')THEN 21749 WRITE(ICOUT,999) 21750 CALL DPWRST('XXX','BUG ') 21751 WRITE(ICOUT,9011) 21752 9011 FORMAT('***** AT THE END OF DPTWPL--') 21753 CALL DPWRST('XXX','BUG ') 21754 WRITE(ICOUT,9013)IFOUND,IERROR,NPLOTV,NPLOTP,NS 21755 9013 FORMAT('IFOUND,IERROR,NPLOTV,NPLOTP,NS = ',2(A4,2X),3I8) 21756 CALL DPWRST('XXX','BUG ') 21757 WRITE(ICOUT,9017)IHLEFT,IHLEF2,ICOLL,NLEFT 21758 9017 FORMAT('IHLEFT,IHLEF2,ICOLL,NLEFT = ',A4,2X,A4,I8,I8) 21759 CALL DPWRST('XXX','BUG ') 21760 IF(IFOUND.EQ.'YES'.AND.NPLOTP.GT.0)THEN 21761 DO9025I=1,NPLOTP 21762 WRITE(ICOUT,9026)I,Y(I),X(I),D(I) 21763 9026 FORMAT('I,Y(I),X(I),D(I) = ',I8,3G15.7) 21764 CALL DPWRST('XXX','BUG ') 21765 9025 CONTINUE 21766 ENDIF 21767 ENDIF 21768C 21769 RETURN 21770 END 21771 SUBROUTINE DPTWP2(Y,TAG1,TAG2,N,NUMV2,ICASPL,ICASP2, 21772 1 IYLAB,IX1LAB,IX2LAB, 21773 1 ICAPSW,ICAPTY,IFORSW, 21774 1 TEMP1,TEMP2,COLAVE,ROWAVE,SLOPES,XIDTEM,XIDTE2, 21775 1 Y2,X2,D2,N2,NPLOTV,ISUBRO,IBUGG3,IERROR) 21776C 21777C PURPOSE--GENERATE MANDEL'S ROW-LINEAR OR COLUMN-LINEAR PLOTS FOR 21778C JOHN MANDEL'S TWO-WAY TABLE ANALYSIS 21779C WRITTEN BY--ALAN HECKERT 21780C STATISTICAL ENGINEERING DIVISION 21781C INFORMATION TECHNOLOGY LABORATORY 21782C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 21783C GAITHERSBURG, MD 20899-8980 21784C PHONE--301-975-2899 21785C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 21786C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 21787C REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105 21788C LANGUAGE--ANSI FORTRAN (1977) 21789C VERSION NUMBER--2015/06 21790C ORIGINAL VERSION--JUNE 2015. 21791C 21792C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 21793C 21794 CHARACTER*4 ICAPSW 21795 CHARACTER*4 ICAPTY 21796 CHARACTER*4 IFORSW 21797 CHARACTER*4 ICASPL 21798 CHARACTER*4 ICASP2 21799 CHARACTER*25 IYLAB 21800 CHARACTER*12 IX1LAB 21801 CHARACTER*12 IX2LAB 21802 CHARACTER*4 ISUBRO 21803 CHARACTER*4 IBUGG3 21804 CHARACTER*4 IERROR 21805C 21806 CHARACTER*4 IWRITE 21807 CHARACTER*4 ISUBN1 21808 CHARACTER*4 ISUBN2 21809 CHARACTER*4 ISTEPN 21810 CHARACTER*4 IOP 21811C 21812C--------------------------------------------------------------------- 21813C 21814 DIMENSION Y(*) 21815 DIMENSION TAG1(*) 21816 DIMENSION TAG2(*) 21817 DIMENSION Y2(*) 21818 DIMENSION X2(*) 21819 DIMENSION D2(*) 21820C 21821 DIMENSION TEMP1(*) 21822 DIMENSION TEMP2(*) 21823 DIMENSION COLAVE(*) 21824 DIMENSION ROWAVE(*) 21825 DIMENSION SLOPES(*) 21826 DIMENSION XIDTEM(*) 21827 DIMENSION XIDTE2(*) 21828C 21829 PARAMETER(NUMCLI=6) 21830 PARAMETER(MAXLIN=2) 21831 PARAMETER (MAXROW=45) 21832 CHARACTER*65 ITITLE 21833 CHARACTER*1 ITITL9 21834 CHARACTER*4 ALIGN(NUMCLI) 21835 CHARACTER*4 VALIGN(NUMCLI) 21836 INTEGER IDIGIT(MAXROW) 21837 INTEGER NTOT(MAXROW) 21838 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 21839 CHARACTER*40 ITTEMP 21840 CHARACTER*20 IVALUE(MAXROW,NUMCLI) 21841 CHARACTER*4 ITYPCO(NUMCLI) 21842 CHARACTER*1 IBASLC 21843 INTEGER NCTIT2(MAXLIN,NUMCLI) 21844 INTEGER NCVALU(MAXROW,NUMCLI) 21845 INTEGER IWHTML(NUMCLI) 21846 INTEGER IWRTF(NUMCLI) 21847 REAL AMAT(MAXROW,NUMCLI) 21848 LOGICAL IFRST 21849 LOGICAL ILAST 21850 LOGICAL IFLAGA 21851 LOGICAL IFLAGB 21852C 21853 DOUBLE PRECISION DSUM 21854 DOUBLE PRECISION DSUM1 21855 DOUBLE PRECISION DSUM2 21856 DOUBLE PRECISION DSUM3 21857 DOUBLE PRECISION DTERM1 21858 DOUBLE PRECISION DTERM2 21859 DOUBLE PRECISION DSSTO 21860 DOUBLE PRECISION DSSROW 21861 DOUBLE PRECISION DSSCOL 21862 DOUBLE PRECISION DSSERR 21863 DOUBLE PRECISION DSSSL 21864 DOUBLE PRECISION DSSER2 21865 DOUBLE PRECISION DSSRGR 21866C 21867C-----COMMON---------------------------------------------------------- 21868C 21869 INCLUDE 'DPCOST.INC' 21870C 21871 CHARACTER*4 IRTFMZ 21872 CHARACTER*4 IRTFMD 21873 COMMON/COMRTF/IRTFMD 21874C 21875C 21876C-----COMMON VARIABLES (GENERAL)-------------------------------------- 21877C 21878 INCLUDE 'DPCOP2.INC' 21879C 21880C-----START POINT----------------------------------------------------- 21881C 21882 ISUBN1='DPTW' 21883 ISUBN2='P2 ' 21884 IWRITE='OFF' 21885 IRTFSV=IRTFPS 21886 IRTFPS=16 21887 CALL DPCONA(92,IBASLC) 21888 IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN 21889 WRITE(ICOUT,103)IBASLC,IRTFPS 21890 103 FORMAT(A1,'fs',I2) 21891 CALL DPWRST('XXX','WRIT') 21892 ENDIF 21893C 21894 ATAG=0.0 21895C 21896 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TWP2')THEN 21897 WRITE(ICOUT,70) 21898 70 FORMAT('AT THE BEGINNING OF DPTWP2--') 21899 CALL DPWRST('XXX','BUG ') 21900 WRITE(ICOUT,71)IBUGG3,ISUBRO,ICASPL,ICASP2,N,NUMV2 21901 71 FORMAT('IBUGG3,ISUBRO,ICASPL,ICASP2,N,NUMV2 = ',4(A4,2X),2I8) 21902 CALL DPWRST('XXX','BUG ') 21903 WRITE(ICOUT,72)ITWOYA,ITWOFI,ITWOAV,ITWOAN 21904 72 FORMAT('ITWOYA,ITWOFI,ITWOAV,ITWOAN = ',3(A4,2X),A4) 21905 CALL DPWRST('XXX','BUG ') 21906 DO73I=1,N 21907 WRITE(ICOUT,74)I,Y(I),TAG1(I),TAG2(I) 21908 74 FORMAT('I, Y(I),TAG1(I)TAG2(I) = ',I8,5G15.7) 21909 CALL DPWRST('XXX','BUG ') 21910 73 CONTINUE 21911 ENDIF 21912C 21913C WRITE FOLLOWING TO DPST1F.DAT 21914C 21915C 1. DPST1F.DAT: ROW, HEIGHT, SLOPE, RESSD, STANDARD ERROR OF SLOPE 21916C 2. DPST2F.DAT: COLUMN, COLUMN AVERAGE 21917C 3. DPST3F.DAT: ROW, COL, Y(ROW,COL), RES(ROW,COL), PRED(ROW,COL) 21918C 21919 IOP='OPEN' 21920 IFLG11=1 21921 IFLG21=1 21922 IFLG31=1 21923 IFLG41=0 21924 IFLG51=0 21925 CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLA41,IFLG51, 21926 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 21927 1 IBUGG3,ISUBRO,IERROR) 21928C 21929C CHECK THE INPUT ARGUMENTS FOR ERRORS 21930C 21931 IF(N.LT.5)THEN 21932 WRITE(ICOUT,999) 21933 999 FORMAT(1X) 21934 CALL DPWRST('XXX','BUG ') 21935 WRITE(ICOUT,31) 21936 31 FORMAT('***** ERROR IN TWO-WAY <ROW/COLUMN> PLOT--') 21937 CALL DPWRST('XXX','BUG ') 21938 WRITE(ICOUT,32) 21939 32 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 5;') 21940 CALL DPWRST('XXX','BUG ') 21941 WRITE(ICOUT,34)N 21942 34 FORMAT(' THE NUMBER OF OBSERVATIONS = ',I6) 21943 CALL DPWRST('XXX','BUG ') 21944 WRITE(ICOUT,999) 21945 CALL DPWRST('XXX','BUG ') 21946 IERROR='YES' 21947 GOTO9000 21948 ENDIF 21949C 21950C ****************************************************** 21951C ** STEP 1-- ** 21952C ** DETERMINE THE NUMBER OF DISTINCT VALUES ** 21953C ** FOR THE GROUP VARIABLES (TAG1, TAG2) ** 21954C ** IF ALL VALUES ARE DISTINCT, THEN THIS ** 21955C ** IMPLIES WE HAVE THE NO REPLICATION CASE ** 21956C ** WHICH IS AN ERROR CONDITION FOR A PLOT. ** 21957C ****************************************************** 21958C 21959 ISTEPN='1' 21960 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TWP2') 21961 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 21962C 21963 CALL DISTIN(TAG1,N,IWRITE,XIDTEM,NUMSE1,IBUGG3,IERROR) 21964 CALL SORT(XIDTEM,NUMSE1,XIDTEM) 21965 CALL DISTIN(TAG2,N,IWRITE,XIDTE2,NUMSE2,IBUGG3,IERROR) 21966 CALL SORT(XIDTE2,NUMSE2,XIDTE2) 21967C 21968C CHECK FOR MISSING CELLS (PLOT CURRENTLY NOT SUPPORTED FOR 21969C CASE WHERE THERE IS MISSING CELLS). IF REPLICATION IS DETECTED, 21970C REPLACE RAW DATA WITH CELL AVERAGES. 21971C 21972 IREPL=0 21973 DO110ISET1=1,NUMSE1 21974 AHOLD1=XIDTEM(ISET1) 21975 DO120ISET2=1,NUMSE2 21976 AHOLD2=XIDTE2(ISET2) 21977 K=0 21978 DO130I=1,N 21979 IF(TAG1(I).EQ.AHOLD1 .AND. TAG2(I).EQ.AHOLD2)THEN 21980 K=K+1 21981 GOTO139 21982 ENDIF 21983 130 CONTINUE 21984 139 CONTINUE 21985 IF(K.EQ.0)THEN 21986 WRITE(ICOUT,999) 21987 CALL DPWRST('XXX','BUG ') 21988 WRITE(ICOUT,31) 21989 CALL DPWRST('XXX','BUG ') 21990 WRITE(ICOUT,142) 21991 142 FORMAT(' THERE IS NO DATA FOR:') 21992 CALL DPWRST('XXX','BUG ') 21993 WRITE(ICOUT,144)AHOLD1 21994 144 FORMAT(' GROUP ONE VARIABLE WITH VALUE: ',G15.7) 21995 CALL DPWRST('XXX','BUG ') 21996 WRITE(ICOUT,146)AHOLD2 21997 146 FORMAT(' GROUP TWO VARIABLE WITH VALUE: ',G15.7) 21998 CALL DPWRST('XXX','BUG ') 21999 WRITE(ICOUT,148) 22000 148 FORMAT(' THIS COMMAND IS NOT SUPPORTED FOR THE CASE ', 22001 1 'WHERE THERE ARE MISSING CELLS.') 22002 CALL DPWRST('XXX','BUG ') 22003 IERROR='YES' 22004 GOTO9000 22005 ELSEIF(K.GT.1)THEN 22006 IREPL=1 22007 ENDIF 22008 120 CONTINUE 22009 110 CONTINUE 22010C 22011C IF REPLICATION DETECTED, REPLACE RAW VALUES WITH MEANS 22012C 22013 ICNT=0 22014 IF(IREPL.EQ.1)THEN 22015 DO210ISET1=1,NUMSE1 22016 AHOLD1=XIDTEM(ISET1) 22017 DO220ISET2=1,NUMSE2 22018 AHOLD2=XIDTE2(ISET2) 22019 K=0 22020 DO230I=1,N 22021 IF(TAG1(I).EQ.AHOLD1 .AND. TAG2(I).EQ.AHOLD2)THEN 22022 K=K+1 22023 TEMP1(K)=Y(I) 22024 ENDIF 22025 230 CONTINUE 22026C 22027 ICNT=ICNT+1 22028 IF(K.EQ.1)THEN 22029 TEMP2(ICNT)=TEMP1(1) 22030 ELSE 22031 CALL MEAN(TEMP1,K,IWRITE,XMEAN,IBUGG3,IERROR) 22032 TEMP2(ICNT)=XMEAN 22033 ENDIF 22034 XIDTEM(ICNT)=AHOLD1 22035 XIDTE2(ICNT)=AHOLD2 22036C 22037 220 CONTINUE 22038 210 CONTINUE 22039C 22040 DO310I=1,ICNT 22041 Y(I)=TEMP2(I) 22042 TAG1(I)=XIDTEM(I) 22043 TAG2(I)=XIDTE2(I) 22044 310 CONTINUE 22045 N=ICNT 22046 ENDIF 22047C 22048 AN=N 22049 ANUMS1=NUMSE1 22050 ANUMS2=NUMSE2 22051C 22052 NUMDIG=0 22053 IF(IPRINT.EQ.'ON')THEN 22054 NUMDIG=7 22055 IF(IFORSW.EQ.'1')NUMDIG=1 22056 IF(IFORSW.EQ.'2')NUMDIG=2 22057 IF(IFORSW.EQ.'3')NUMDIG=3 22058 IF(IFORSW.EQ.'4')NUMDIG=4 22059 IF(IFORSW.EQ.'5')NUMDIG=5 22060 IF(IFORSW.EQ.'6')NUMDIG=6 22061 IF(IFORSW.EQ.'7')NUMDIG=7 22062 IF(IFORSW.EQ.'8')NUMDIG=8 22063 IF(IFORSW.EQ.'9')NUMDIG=9 22064 IF(IFORSW.EQ.'0')NUMDIG=0 22065 IF(IFORSW.EQ.'E')NUMDIG=-2 22066 IF(IFORSW.EQ.'-2')NUMDIG=-2 22067 IF(IFORSW.EQ.'-3')NUMDIG=-3 22068 IF(IFORSW.EQ.'-4')NUMDIG=-4 22069 IF(IFORSW.EQ.'-5')NUMDIG=-5 22070 IF(IFORSW.EQ.'-6')NUMDIG=-6 22071 IF(IFORSW.EQ.'-7')NUMDIG=-7 22072 IF(IFORSW.EQ.'-8')NUMDIG=-8 22073 IF(IFORSW.EQ.'-9')NUMDIG=-9 22074 ENDIF 22075C 22076 NCX1=1 22077 DO906I=12,1,-1 22078 IF(IX1LAB(I:I).NE.' ')THEN 22079 NCX1=I 22080 GOTO908 22081 ENDIF 22082 906 CONTINUE 22083 908 CONTINUE 22084C 22085 NCX2=1 22086 DO916I=12,1,-1 22087 IF(IX2LAB(I:I).NE.' ')THEN 22088 NCX2=I 22089 GOTO918 22090 ENDIF 22091 916 CONTINUE 22092 918 CONTINUE 22093C 22094C 22095C **************************************************** 22096C ** STEP 11-- ** 22097C ** COMPUTE THE SPECIFIED STATISTIC ** 22098C ** FOR EACH CROSS-TAB CATEGORY OF THE DATA, AND ** 22099C ** THEN FOR THE FULL DATA SET ** 22100C **************************************************** 22101C 22102 ISTEPN='11' 22103 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TWP2') 22104 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 22105C 22106C FOR "ROW" CASE, PLOT Y(ij) - R(i) VERSUS R(i) FOR ALL j. 22107C 22108C THAT IS, WE PLOT DEVIATION FROM COLUMN AVERAGE VERSUS THE COLUMN AVERAGE 22109C 22110 IF(ICASP2.EQ.'ROW')THEN 22111C 22112 WRITE(IOUNI1,1001) 22113 1001 FORMAT(5X,'ROW',11X,'HEIGHT',10X,'SLOPE',10X,'RESSD',4X, 22114 1 'SD OF SLOPE',4X,'CORRELATION') 22115 WRITE(IOUNI2,1002) 22116 1002 FORMAT(2X,'COLUMN',6X,'COLUMN MEAN') 22117 WRITE(IOUNI3,1003) 22118 1003 FORMAT(2X,'ROW-ID',2X,'COL-ID',10X,'Y(ij)',7X,'PRED(ij)',8X, 22119 1 'RES(ij)',1X,'STAND. RES(ij)') 22120C 22121 ITITL9=' ' 22122 NCTIT9=0 22123 ITITLE='Parameters of Row-Linear Fit for ' 22124 WRITE(ITITLE(34:58),'(A25)')IYLAB 22125 NCTITL=58 22126C 22127 NUMLIN=2 22128 NUMCOL=6 22129 ITITL2(1,1)=' ' 22130 ITITL2(2,1)=IX1LAB(1:NCX1) 22131 NCTIT2(1,1)=0 22132 NCTIT2(2,1)=NCX1 22133 ITITL2(1,2)=' ' 22134 ITITL2(2,2)='Height' 22135 NCTIT2(1,2)=0 22136 NCTIT2(2,2)=6 22137 ITITL2(1,3)=' ' 22138 ITITL2(2,3)='Slope' 22139 NCTIT2(1,3)=0 22140 NCTIT2(2,3)=5 22141 ITITL2(1,4)=' ' 22142 ITITL2(2,4)='RESSD' 22143 NCTIT2(1,4)=0 22144 NCTIT2(2,4)=5 22145 ITITL2(1,5)='Standard Error' 22146 ITITL2(2,5)='of Slope' 22147 NCTIT2(1,5)=14 22148 NCTIT2(2,5)=8 22149 ITITL2(1,6)='Correlation' 22150 ITITL2(2,6)='Coefficient' 22151 NCTIT2(1,6)=11 22152 NCTIT2(2,6)=11 22153C 22154 NMAX=0 22155 NUMROW=NUMSE1 22156 IF(NUMROW.GT.MAXROW)NUMROW=NUMSE1 22157 DO1032II=1,NUMCOL 22158 VALIGN(II)='b' 22159 ALIGN(II)='r' 22160 NTOT(II)=15 22161 IF(II.EQ.1)NTOT(II)=10 22162 NMAX=NMAX+NTOT(II) 22163 IDIGIT(II)=NUMDIG 22164 ITYPCO(II)='NUME' 22165 1032 CONTINUE 22166 IDIGIT(1)=0 22167 IDIGIT(6)=4 22168 IF(ITWOLA.EQ.'VALU' .AND. ITWODE.GT.0)THEN 22169 IDIGIT(1)=ITWODE 22170 ENDIF 22171 DO1033II=1,MAXROW 22172 DO1035JJ=1,NUMCOL 22173 NCVALU(II,JJ)=0 22174 IVALUE(II,JJ)=' ' 22175 NCVALU(II,JJ)=0 22176 AMAT(II,JJ)=0.0 22177 1035 CONTINUE 22178 1033 CONTINUE 22179C 22180 IWHTML(1)=125 22181 IWHTML(2)=150 22182 IWHTML(3)=150 22183 IWHTML(4)=150 22184 IWHTML(5)=150 22185 IWHTML(6)=150 22186 IWRTF(1)=1300 22187 IWRTF(2)=IWRTF(1)+1700 22188 IWRTF(3)=IWRTF(2)+1700 22189 IWRTF(4)=IWRTF(3)+1700 22190 IWRTF(5)=IWRTF(4)+1700 22191 IWRTF(6)=IWRTF(5)+1500 22192 IFRST=.TRUE. 22193 ILAST=.TRUE. 22194C 22195C COMPUTE THE COLUMN AVERAGES 22196C 22197 DO1000ISET2=1,NUMSE2 22198C 22199 K=0 22200 DO1005I=1,N 22201 IF(TAG2(I).EQ.XIDTE2(ISET2))THEN 22202 K=K+1 22203 TEMP1(K)=Y(I) 22204 ENDIF 22205 1005 CONTINUE 22206C 22207 CALL MEAN(TEMP1,K,IWRITE,XMEAN,IBUGG3,IERROR) 22208 COLAVE(ISET2)=XMEAN 22209C 22210 IF(ITWOLA.EQ.'VALU')THEN 22211 WRITE(IOUNI2,1008)XIDTE2(ISET2),COLAVE(ISET2) 22212 1008 FORMAT(2E15.7) 22213 ELSE 22214 WRITE(IOUNI2,1007)ISET2,COLAVE(ISET2) 22215 1007 FORMAT(I8,2X,E15.7) 22216 ENDIF 22217C 22218 1000 CONTINUE 22219 CALL MINIM(COLAVE,NUMSE2,IWRITE,XMIN,IBUGG3,IERROR) 22220 CALL MAXIM(COLAVE,NUMSE2,IWRITE,XMAX,IBUGG3,IERROR) 22221 CALL MEAN(COLAVE,NUMSE2,IWRITE,XGRAND,IBUGG3,IERROR) 22222C 22223C NOW COMPUTE DEVIATIONS FROM COLUMN AVERAGES FOR EACH ROW 22224C 22225 J=0 22226 ATAG=0.0 22227 DSUM=0.0D0 22228 ICNTRW=0 22229 DO1100ISET1=1,NUMSE1 22230C 22231 K=0 22232 DO1101I=1,N 22233 IF(TAG1(I).EQ.XIDTEM(ISET1))THEN 22234 K=K+1 22235 TEMP1(K)=Y(I) 22236 ENDIF 22237 1101 CONTINUE 22238C 22239C NOW COMPUTE ROW AVERAGE 22240C 22241 CALL MEAN(TEMP1,K,IWRITE,AVAL,IBUGG3,IERROR) 22242 ROWAVE(ISET1)=AVAL 22243C 22244 ATAG=ATAG+1.0 22245 IF(ITWOYA.EQ.'RAW')THEN 22246 DO1103I=1,K 22247 J=J+1 22248 X2(J)=COLAVE(I) 22249 TEMP2(I)=TEMP1(I) 22250 Y2(J)=TEMP1(I) 22251 D2(J)=ATAG 22252 1103 CONTINUE 22253 ELSE 22254 DO1105I=1,K 22255 J=J+1 22256 X2(J)=COLAVE(I) 22257 TEMP2(I)=TEMP1(I) - COLAVE(I) 22258 Y2(J)=TEMP2(I) 22259 D2(J)=ATAG 22260 1105 CONTINUE 22261 ENDIF 22262 CALL LINFIT(TEMP2,COLAVE,K, 22263 1 PPA0,PPA1,XRESSD,XRESDF,PPCC,SDPPA0,SDPPA1,CCALBE, 22264 1 ISUBRO,IBUGG3,IERROR) 22265 ATAG=ATAG+1.0 22266 AY1=PPA0 + PPA1*XMIN 22267 AY2=PPA0 + PPA1*XMAX 22268 SLOPES(ISET1)=PPA1 22269C 22270 DO1108II=1,K 22271 PREDVA=PPA0 + PPA1*COLAVE(II) 22272 RESVA=TEMP2(II) - PREDVA 22273 RESVA2=RESVA/XRESSD 22274 IF(ITWOLA.EQ.'VALU')THEN 22275 WRITE(IOUNI3,1119)XIDTEM(ISET1),II,TEMP2(II),PREDVA, 22276 1 RESVA,RESVA2 22277 1119 FORMAT(E15.7,I8,4E15.7) 22278 ELSE 22279 WRITE(IOUNI3,1109)ISET1,II,TEMP2(II),PREDVA, 22280 1 RESVA,RESVA2 22281 1109 FORMAT(2I8,4E15.7) 22282 ENDIF 22283 1108 CONTINUE 22284C 22285 CALL MEAN(TEMP2,K,IWRITE,AVAL,IBUGG3,IERROR) 22286 ICNTRW=ICNTRW+1 22287 IF(ISET1.GT.MAXROW)THEN 22288 IF(ITWOFI.EQ.'ON')THEN 22289 CALL DPDTA4(ITITL9,NCTIT9, 22290 1 ITITLE,NCTITL,ITITL2,NCTIT2, 22291 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 22292 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNTRW, 22293 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 22294 1 ICAPSW,ICAPTY,IFRST,ILAST, 22295 1 ISUBRO,IBUGG3,IERROR) 22296 ENDIF 22297 ICNTRW=1 22298 ENDIF 22299 IF(ITWOLA.EQ.'VALU')THEN 22300 AMAT(ICNTRW,1)=XIDTEM(ISET1) 22301 ELSE 22302 AMAT(ICNTRW,1)=REAL(ISET1) 22303 ENDIF 22304 AMAT(ICNTRW,2)=AVAL 22305 AMAT(ICNTRW,3)=PPA1 22306 AMAT(ICNTRW,4)=XRESSD 22307 AMAT(ICNTRW,5)=SDPPA1 22308 AMAT(ICNTRW,6)=PPCC 22309 DSUM=DSUM + DBLE(XRESSD)**2 22310C 22311 IF(ITWOLA.EQ.'VALU')THEN 22312 WRITE(IOUNI1,1106)XIDTEM(ISET1),AVAL,PPA1,XRESSD,SDPPA1,PPCC 22313 1106 FORMAT(6E15.7) 22314 ELSE 22315 WRITE(IOUNI1,1107)ISET1,AVAL,PPA1,XRESSD,SDPPA1,PPCC 22316 1107 FORMAT(I8,2X,5E15.7) 22317 ENDIF 22318C 22319 J=J+1 22320 X2(J)=XMIN 22321 Y2(J)=AY1 22322 D2(J)=ATAG 22323 J=J+1 22324 X2(J)=XMAX 22325 Y2(J)=AY2 22326 D2(J)=ATAG 22327 1100 CONTINUE 22328C 22329 IF(ITWOFI.EQ.'ON')THEN 22330 CALL DPDTA4(ITITL9,NCTIT9, 22331 1 ITITLE,NCTITL,ITITL2,NCTIT2, 22332 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 22333 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNTRW, 22334 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 22335 1 ICAPSW,ICAPTY,IFRST,ILAST, 22336 1 ISUBRO,IBUGG3,IERROR) 22337C 22338 CALL SD(SLOPES,NUMSE1,IWRITE,SDSLOP,IBUGG3,IERROR) 22339C 22340 IRTFMZ=IRTFMD 22341 IRTFMD='OFF' 22342 IFLAGA=.TRUE. 22343 IFLAGB=.FALSE. 22344 ISIZE=0 22345 NTOTAL=40 22346 NBLNK1=0 22347 NBLNK2=0 22348 ITYPE=3 22349 ITTEMP='Standard Deviation of Slopes: ' 22350 NCTEMP=30 22351 CALL DPDTXT(ITTEMP,NCTEMP,SDSLOP,NUMDIG,NTOTAL, 22352 1 NBLNK1,NBLNK2,IFLAGA,IFLAGB,ISIZE, 22353 1 ICAPSW,ICAPTY,ITYPE,ISUBRO,IBUGG3,IERROR) 22354C 22355 DTERM1=DSUM/DBLE(NUMSE1-1) 22356 AVAL=REAL(DSQRT(DTERM1)) 22357 IFLAGA=.FALSE. 22358 IFLAGB=.TRUE. 22359 NBLNK2=2 22360 ITTEMP='Pooled Standard Deviation of Fit: ' 22361 NCTEMP=34 22362 CALL DPDTXT(ITTEMP,NCTEMP,AVAL,NUMDIG,NTOTAL, 22363 1 NBLNK1,NBLNK2,IFLAGA,IFLAGB,ISIZE, 22364 1 ICAPSW,ICAPTY,ITYPE,ISUBRO,IBUGG3,IERROR) 22365 IRTFMD=IRTFMZ 22366 ENDIF 22367C 22368 ITITL9=' ' 22369 NCTIT9=0 22370 ITITLE='Column Averages' 22371 NCTITL=15 22372C 22373 NUMLIN=2 22374 NUMCOL=2 22375 ITITL2(1,1)=' ' 22376 ITITL2(2,1)=IX2LAB(1:NCX2) 22377 NCTIT2(1,1)=0 22378 NCTIT2(2,1)=NCX2 22379 ITITL2(1,2)='Column' 22380 ITITL2(2,2)='Average' 22381 NCTIT2(1,2)=6 22382 NCTIT2(2,2)=7 22383C 22384 NMAX=0 22385 NUMROW=NUMSE2 22386 DO1042II=1,NUMCOL 22387 VALIGN(II)='b' 22388 ALIGN(II)='r' 22389 NTOT(II)=15 22390 IF(II.EQ.1)NTOT(II)=12 22391 NMAX=NMAX+NTOT(II) 22392 IDIGIT(II)=NUMDIG 22393 ITYPCO(II)='NUME' 22394 1042 CONTINUE 22395 IDIGIT(1)=0 22396 IF(ITWOLA.EQ.'VALU' .AND. ITWODE.GT.0)THEN 22397 IDIGIT(1)=ITWODE 22398 ENDIF 22399 DO1043II=1,MAXROW 22400 DO1045JJ=1,NUMCOL 22401 NCVALU(II,JJ)=0 22402 IVALUE(II,JJ)=' ' 22403 NCVALU(II,JJ)=0 22404 AMAT(II,JJ)=0.0 22405 1045 CONTINUE 22406 1043 CONTINUE 22407C 22408 IWHTML(1)=125 22409 IWHTML(2)=150 22410 IWRTF(1)=1300 22411 IWRTF(2)=IWRTF(1)+1700 22412 IFRST=.TRUE. 22413 ILAST=.TRUE. 22414C 22415 DO1051ISET2=1,NUMSE2 22416 IF(ITWOLA.EQ.'VALU')THEN 22417 AMAT(ISET2,1)=XIDTE2(ISET2) 22418 ELSE 22419 AMAT(ISET2,1)=REAL(ISET2) 22420 ENDIF 22421 AMAT(ISET2,2)=COLAVE(ISET2) 22422 1051 CONTINUE 22423C 22424 IF(ITWOAV.EQ.'ON')THEN 22425 CALL DPDTA4(ITITL9,NCTIT9, 22426 1 ITITLE,NCTITL,ITITL2,NCTIT2, 22427 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 22428 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW, 22429 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 22430 1 ICAPSW,ICAPTY,IFRST,ILAST, 22431 1 ISUBRO,IBUGG3,IERROR) 22432C 22433 CALL MEAN(COLAVE,NUMSE2,IWRITE,GMEAN,IBUGG3,IERROR) 22434 IRTFMZ=IRTFMD 22435 IRTFMD='OFF' 22436 IFLAGA=.TRUE. 22437 IFLAGB=.TRUE. 22438 ISIZE=0 22439 NTOTAL=30 22440 NBLNK1=0 22441 NBLNK2=2 22442 ITYPE=3 22443 ITTEMP='Mean of Column Means: ' 22444 NCTEMP=22 22445 CALL DPDTXT(ITTEMP,NCTEMP,GMEAN,NUMDIG,NTOTAL, 22446 1 NBLNK1,NBLNK2,IFLAGA,IFLAGB,ISIZE, 22447 1 ICAPSW,ICAPTY,ITYPE,ISUBRO,IBUGG3,IERROR) 22448 IRTFMD=IRTFMZ 22449 ENDIF 22450C 22451C IF REQUESTED, GENERATE AN EXTENDED ANOVA TABLE 22452C 22453 IF(ITWOAN.EQ.'ON')THEN 22454C 22455C COMPUTE SSTO 22456C 22457 DSUM1=0.0D0 22458 DTERM1=DBLE(NUMSE1)*DBLE(NUMSE2)*DBLE(XGRAND)**2 22459C 22460 DO1610II=1,N 22461 DSUM1=DSUM1 + DBLE(Y(II))**2 22462 1610 CONTINUE 22463 DSSTO=DSUM1 -DTERM1 22464C 22465C COMPUTE SS(ROWS) 22466C 22467 DSUM1=0.0D0 22468 DO1620II=1,NUMSE1 22469 DSUM1=DSUM1 + DBLE(ROWAVE(II))**2 22470 1620 CONTINUE 22471 DSSROW=DBLE(NUMSE2)*DSUM1 - DTERM1 22472C 22473C COMPUTE SS(COLS) 22474C 22475 DSUM1=0.0D0 22476 DO1630II=1,NUMSE2 22477 DSUM1=DSUM1 + DBLE(COLAVE(II))**2 22478 1630 CONTINUE 22479 DSSCOL=DBLE(NUMSE1)*DSUM1 - DTERM1 22480C 22481C COMPUTE ERROR SUM OF SQUARES 22482C 22483 DSSERR=DSSTO - DSSROW - DSSCOL 22484C 22485 DSUM1=0.0D0 22486 DO1640II=1,NUMSE1 22487 DTERM1=DBLE(SLOPES(II) - 1.0)**2 22488 DSUM1=DSUM1 + DTERM1 22489 1640 CONTINUE 22490C 22491 DSUM2=0.0D0 22492 DO1650II=1,NUMSE2 22493 DTERM2=DBLE((COLAVE(II) - XGRAND)**2) 22494 DSUM2=DSUM2 + DTERM2 22495 1650 CONTINUE 22496 DSSSL=DSUM1*DSUM2 22497 DSSER2=DSSERR-DSSSL 22498C 22499C COMPUTE SUM OF SQUARES FOR COHERENCE. FORMULAS FROM 22500C MANDEL's 1961 JASA PAPER. THESE FURTHER DECOMPOSE 22501C "SLOPE" SUM OF SQUARES INTO "CONCURRENCE" AND 22502C "NON-CONCURRENCE". 22503C 22504 DSUM1=0.0D0 22505 DSUM2=0.0D0 22506 DSUM3=0.0D0 22507 DO1660II=1,NUMSE1 22508 DTERM1=DBLE(ROWAVE(II)-XGRAND) 22509 DSUM1=DSUM1 + DTERM1*DBLE(SLOPES(II)) 22510 DSUM2=DSUM2 + DTERM1**2 22511 1660 CONTINUE 22512 DO1670JJ=1,NUMSE2 22513 DTERM1=DBLE(COLAVE(JJ)-XGRAND) 22514 DSUM3=DSUM3 + DTERM1**2 22515 1670 CONTINUE 22516 DSSRGR=(DSUM1**2/DSUM2)*DSUM3 22517 DSSNCN=DSSSL - DSSRGR 22518C 22519 ITITL9=' ' 22520 NCTIT9=0 22521 ITITLE='ANOVA Table for Row-Linear Fit' 22522 NCTITL=30 22523C 22524 NUMLIN=2 22525 NUMCOL=4 22526 ITITL2(1,1)=' ' 22527 ITITL2(2,1)='Source' 22528 NCTIT2(1,1)=0 22529 NCTIT2(2,1)=6 22530 ITITL2(1,2)='Degrees of' 22531 ITITL2(2,2)='Freedom' 22532 NCTIT2(1,2)=10 22533 NCTIT2(2,2)=7 22534 ITITL2(1,3)='Sum of' 22535 ITITL2(2,3)='Squares' 22536 NCTIT2(1,3)=6 22537 NCTIT2(2,3)=7 22538 ITITL2(1,4)='Mean' 22539 ITITL2(2,4)='Square' 22540 NCTIT2(1,4)=4 22541 NCTIT2(2,4)=6 22542 ITITL2(1,5)='F' 22543 ITITL2(2,5)='Statistic' 22544 NCTIT2(1,5)=1 22545 NCTIT2(2,5)=9 22546 ITITL2(1,6)=' ' 22547 ITITL2(2,6)='F CDF' 22548 NCTIT2(1,6)=0 22549 NCTIT2(2,6)=5 22550C 22551 NMAX=0 22552 NUMROW=8 22553 IWRTF(1)=1900 22554 DO1742II=1,NUMCOL 22555 VALIGN(II)='b' 22556 ALIGN(II)='r' 22557 NTOT(II)=15 22558 IF(II.EQ.1)NTOT(II)=20 22559 NMAX=NMAX+NTOT(II) 22560 IDIGIT(II)=NUMDIG 22561 IF(II.GE.3.AND.II.LE.4.AND.ITWOAD.GE.-9)IDIGIT(II)=ITWOAD 22562 ITYPCO(II)='NUME' 22563 IWHTML(II)=150 22564 IF(II.GE.2)IWRTF(II)=IWRTF(II-1)+1700 22565 1742 CONTINUE 22566 IDIGIT(1)=0 22567 IDIGIT(2)=0 22568 ALIGN(1)='l' 22569 ITYPCO(1)='ALPH' 22570 DO1743II=1,MAXROW 22571 DO1745JJ=1,NUMCOL 22572 NCVALU(II,JJ)=0 22573 IVALUE(II,JJ)=' ' 22574 NCVALU(II,JJ)=0 22575 AMAT(II,JJ)=0.0 22576 1745 CONTINUE 22577 1743 CONTINUE 22578C 22579 IFRST=.TRUE. 22580 ILAST=.TRUE. 22581C 22582C LABEL 22583C 22584 IVALUE(1,1)='Total' 22585 NCVALU(1,1)=5 22586 IVALUE(2,1)='Rows' 22587 NCVALU(2,1)=4 22588 IVALUE(3,1)='Columns' 22589 NCVALU(3,1)=6 22590 IVALUE(4,1)='Error' 22591 NCVALU(4,1)=5 22592 IVALUE(5,1)=' Residuals' 22593 NCVALU(5,1)=11 22594 IVALUE(6,1)=' Slopes' 22595 NCVALU(6,1)=8 22596 IVALUE(7,1)=' Concurrence' 22597 NCVALU(7,1)=15 22598 IVALUE(8,1)=' Non-Concurrence' 22599 NCVALU(8,1)=19 22600C 22601C DEGREES OF FREEDOM 22602C 22603 AMAT(1,2)=REAL(NUMSE1-1) + REAL(NUMSE2-1) + 22604 1 REAL((NUMSE1-1)*(NUMSE2-1)) 22605 AMAT(2,2)=REAL(NUMSE1-1) 22606 AMAT(3,2)=REAL(NUMSE2-1) 22607 AMAT(4,2)=REAL((NUMSE1-1)*(NUMSE2-1)) 22608 AMAT(5,2)=REAL((NUMSE1-1)*(NUMSE2-1)) - REAL(NUMSE1-1) 22609 AMAT(6,2)=REAL(NUMSE1-1) 22610 AMAT(7,2)=1.0 22611 AMAT(8,2)=REAL(NUMSE1-2) 22612C 22613C SUM OF SQUARES 22614C 22615 AMAT(1,3)=REAL(DSSTO) 22616 AMAT(2,3)=REAL(DSSROW) 22617 AMAT(3,3)=REAL(DSSCOL) 22618 AMAT(4,3)=REAL(DSSERR) 22619 AMAT(5,3)=REAL(DSSER2) 22620 AMAT(6,3)=REAL(DSSSL) 22621 AMAT(7,3)=REAL(DSSRGR) 22622 AMAT(8,3)=REAL(DSSNCN) 22623C 22624C MEAN SQUARE 22625C 22626 AMAT(1,4)=AMAT(1,3)/AMAT(1,2) 22627 AMAT(2,4)=AMAT(2,3)/AMAT(2,2) 22628 AMAT(3,4)=AMAT(3,3)/AMAT(3,2) 22629 AMAT(4,4)=AMAT(4,3)/AMAT(4,2) 22630 AMAT(5,4)=AMAT(5,3)/AMAT(5,2) 22631 AMAT(6,4)=AMAT(6,3)/AMAT(6,2) 22632 AMAT(7,4)=AMAT(7,3)/AMAT(7,2) 22633 AMAT(8,4)=AMAT(8,3)/AMAT(8,2) 22634C 22635 CALL DPDTA4(ITITL9,NCTIT9, 22636 1 ITITLE,NCTITL,ITITL2,NCTIT2, 22637 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 22638 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW, 22639 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 22640 1 ICAPSW,ICAPTY,IFRST,ILAST, 22641 1 ISUBRO,IBUGG3,IERROR) 22642C 22643 ENDIF 22644C 22645C FOR "COLUMN" CASE, PLOT Y(ij) - R(i) VERSUS R(i) FOR ALL j. 22646C 22647C THAT IS, WE PLOT DEVIATION FROM ROW AVERAGE VERSUS THE ROW AVERAGE 22648C 22649 ELSE 22650C 22651 WRITE(IOUNI1,2001) 22652 2001 FORMAT(2X,'COLUMN',11X,'HEIGHT',10X,'SLOPE',10X,'RESSD',4X, 22653 1 'SD OF SLOPE',4X,'CORRELATION') 22654 WRITE(IOUNI2,2002) 22655 2002 FORMAT(5X,'ROW',9X,'ROW MEAN') 22656 WRITE(IOUNI3,2003) 22657 2003 FORMAT(2X,'ROW-ID',2X,'COL-ID',10X,'Y(ij)',7X,'PRED(ij)',8X, 22658 1 'RES(ij)',1X,'STAND. RES(ij)') 22659C 22660 ITITL9=' ' 22661 NCTIT9=0 22662 ITITLE='Parameters of Column-Linear Fit for ' 22663 WRITE(ITITLE(37:61),'(A25)')IYLAB 22664 NCTITL=61 22665C 22666 NUMLIN=2 22667 NUMCOL=6 22668 ITITL2(1,1)=' ' 22669 ITITL2(2,1)=IX2LAB(1:NCX2) 22670 NCTIT2(1,1)=0 22671 NCTIT2(2,1)=NCX2 22672 ITITL2(1,2)=' ' 22673 ITITL2(2,2)='Height' 22674 NCTIT2(1,2)=0 22675 NCTIT2(2,2)=6 22676 ITITL2(1,3)=' ' 22677 ITITL2(2,3)='Slope' 22678 NCTIT2(1,3)=0 22679 NCTIT2(2,3)=5 22680 ITITL2(1,4)=' ' 22681 ITITL2(2,4)='RESSD' 22682 NCTIT2(1,4)=0 22683 NCTIT2(2,4)=5 22684 ITITL2(1,5)='Standard Error' 22685 ITITL2(2,5)='of Slope' 22686 NCTIT2(1,5)=14 22687 NCTIT2(2,5)=8 22688 ITITL2(1,6)='Correlation' 22689 ITITL2(2,6)='Coefficient' 22690 NCTIT2(1,6)=11 22691 NCTIT2(2,6)=11 22692C 22693 NMAX=0 22694 NUMROW=NUMSE2 22695 IF(NUMROW.GT.MAXROW)NUMROW=NUMSE2 22696 DO2032II=1,NUMCOL 22697 VALIGN(II)='b' 22698 ALIGN(II)='r' 22699 NTOT(II)=15 22700 IF(II.EQ.1)NTOT(II)=12 22701 NMAX=NMAX+NTOT(II) 22702 IDIGIT(II)=NUMDIG 22703 ITYPCO(II)='NUME' 22704 2032 CONTINUE 22705 IDIGIT(1)=0 22706 IDIGIT(6)=4 22707 IF(ITWOLA.EQ.'VALU' .AND. ITWODE.GT.0)THEN 22708 IDIGIT(1)=ITWODE 22709 ENDIF 22710 DO2033II=1,MAXROW 22711 DO2035JJ=1,NUMCOL 22712 NCVALU(II,JJ)=0 22713 IVALUE(II,JJ)=' ' 22714 NCVALU(II,JJ)=0 22715 AMAT(II,JJ)=0.0 22716 2035 CONTINUE 22717 2033 CONTINUE 22718C 22719 IWHTML(1)=125 22720 IWHTML(2)=150 22721 IWHTML(3)=150 22722 IWHTML(4)=150 22723 IWHTML(5)=150 22724 IWHTML(6)=150 22725 IWRTF(1)=1300 22726 IWRTF(2)=IWRTF(1)+1700 22727 IWRTF(3)=IWRTF(2)+1700 22728 IWRTF(4)=IWRTF(3)+1700 22729 IWRTF(5)=IWRTF(4)+1700 22730 IWRTF(6)=IWRTF(5)+1700 22731 IFRST=.TRUE. 22732 ILAST=.TRUE. 22733C 22734C COMPUTE THE ROW AVERAGES 22735C 22736 DO2000ISET1=1,NUMSE1 22737C 22738 K=0 22739 DO2005I=1,N 22740 IF(TAG1(I).EQ.XIDTEM(ISET1))THEN 22741 K=K+1 22742 TEMP1(K)=Y(I) 22743 ENDIF 22744 2005 CONTINUE 22745C 22746 CALL MEAN(TEMP1,K,IWRITE,XMEAN,IBUGG3,IERROR) 22747 COLAVE(ISET1)=XMEAN 22748C 22749 IF(ITWOLA.EQ.'VALU')THEN 22750 WRITE(IOUNI2,2008)XIDTEM(ISET1),COLAVE(ISET1) 22751 2008 FORMAT(2E15.7) 22752 ELSE 22753 WRITE(IOUNI2,2007)ISET1,COLAVE(ISET1) 22754 2007 FORMAT(I8,2X,E15.7) 22755 ENDIF 22756C 22757 2000 CONTINUE 22758 CALL MINIM(COLAVE,NUMSE1,IWRITE,XMIN,IBUGG3,IERROR) 22759 CALL MAXIM(COLAVE,NUMSE1,IWRITE,XMAX,IBUGG3,IERROR) 22760C 22761C NOW COMPUTE DEVIATIONS FROM ROW AVERAGES FOR EACH COLUMN 22762C 22763 J=0 22764 ATAG1=0.0 22765 DSUM=0.0D0 22766 ICNTRW=0 22767 DO2100ISET2=1,NUMSE2 22768C 22769 K=0 22770 DO2101I=1,N 22771 IF(TAG2(I).EQ.XIDTE2(ISET2))THEN 22772 K=K+1 22773 TEMP1(K)=Y(I) 22774 ENDIF 22775 2101 CONTINUE 22776C 22777C NOW COMPUTE COLUMN AVERAGE 22778C 22779 CALL MEAN(TEMP1,K,IWRITE,AVAL,IBUGG3,IERROR) 22780 ROWAVE(ISET2)=AVAL 22781C 22782 ATAG=ATAG+1.0 22783 IF(ITWOYA.EQ.'RAW')THEN 22784 DO2103I=1,K 22785 J=J+1 22786 X2(J)=COLAVE(I) 22787 TEMP2(I)=TEMP1(I) 22788 Y2(J)=TEMP1(I) 22789 D2(J)=ATAG 22790 2103 CONTINUE 22791 ELSE 22792 DO2105I=1,K 22793 J=J+1 22794 X2(J)=COLAVE(I) 22795 TEMP2(I)=TEMP1(I) - COLAVE(I) 22796 Y2(J)=TEMP2(I) 22797 D2(J)=ATAG 22798 2105 CONTINUE 22799 ENDIF 22800 CALL LINFIT(TEMP2,COLAVE,K, 22801 1 PPA0,PPA1,XRESSD,XRESDF,PPCC,SDPPA0,SDPPA1,CCALBE, 22802 1 ISUBRO,IBUGG3,IERROR) 22803 ATAG=ATAG+1.0 22804 AY1=PPA0 + PPA1*XMIN 22805 AY2=PPA0 + PPA1*XMAX 22806 SLOPES(ISET2)=PPA1 22807C 22808 DO2108II=1,K 22809 PREDVA=PPA0 + PPA1*COLAVE(II) 22810 RESVA=TEMP2(II) - PREDVA 22811 RESVA2=RESVA2/XRESSD 22812 IF(ITWOLA.EQ.'VALU')THEN 22813 WRITE(IOUNI3,2119)XIDTE2(ISET2),II,TEMP2(II),PREDVA, 22814 1 RESVA,RESVA2 22815 2119 FORMAT(E15.7,I8,4E15.7) 22816 ELSE 22817 WRITE(IOUNI3,2109)ISET2,II,TEMP2(II),PREDVA, 22818 1 RESVA,RESVA2 22819 2109 FORMAT(2I8,4E15.7) 22820 ENDIF 22821 2108 CONTINUE 22822C 22823 CALL MEAN(TEMP2,K,IWRITE,AVAL,IBUGG3,IERROR) 22824 ICNTRW=ICNTRW+1 22825 IF(ISET2.GT.MAXROW)THEN 22826 IF(ITWOFI.EQ.'ON')THEN 22827 CALL DPDTA4(ITITL9,NCTIT9, 22828 1 ITITLE,NCTITL,ITITL2,NCTIT2, 22829 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 22830 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNTRW, 22831 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 22832 1 ICAPSW,ICAPTY,IFRST,ILAST, 22833 1 ISUBRO,IBUGG3,IERROR) 22834 ENDIF 22835 ICNTRW=ICNTRW+1 22836 ENDIF 22837 IF(ITWOLA.EQ.'VALU')THEN 22838 AMAT(ICNTRW,1)=XIDTE2(ISET2) 22839 ELSE 22840 AMAT(ICNTRW,1)=REAL(ISET2) 22841 ENDIF 22842 AMAT(ICNTRW,2)=AVAL 22843 AMAT(ICNTRW,3)=PPA1 22844 AMAT(ICNTRW,4)=XRESSD 22845 AMAT(ICNTRW,5)=SDPPA1 22846 AMAT(ICNTRW,6)=PPCC 22847 DSUM=DSUM + DBLE(XRESSD)**2 22848C 22849 IF(ITWOLA.EQ.'VALU')THEN 22850 WRITE(IOUNI1,2106)XIDTE2(ISET2),AVAL,PPA1,XRESSD,SDPPA1,PPCC 22851 2106 FORMAT(6E15.7) 22852 ELSE 22853 WRITE(IOUNI1,2107)ISET2,AVAL,PPA1,XRESSD,SDPPA1,PPCC 22854 2107 FORMAT(I8,2X,5E15.7) 22855 ENDIF 22856C 22857 J=J+1 22858 X2(J)=XMIN 22859 Y2(J)=AY1 22860 D2(J)=ATAG 22861 J=J+1 22862 X2(J)=XMAX 22863 Y2(J)=AY2 22864 D2(J)=ATAG 22865 2100 CONTINUE 22866C 22867 IF(ITWOFI.EQ.'ON')THEN 22868 CALL DPDTA4(ITITL9,NCTIT9, 22869 1 ITITLE,NCTITL,ITITL2,NCTIT2, 22870 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 22871 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNTRW, 22872 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 22873 1 ICAPSW,ICAPTY,IFRST,ILAST, 22874 1 ISUBRO,IBUGG3,IERROR) 22875C 22876 CALL SD(SLOPES,NUMSE2,IWRITE,SDSLOP,IBUGG3,IERROR) 22877C 22878 IRTFMZ=IRTFMD 22879 IRTFMD='OFF' 22880 IFLAGA=.TRUE. 22881 IFLAGB=.FALSE. 22882 ISIZE=0 22883 NTOTAL=40 22884 NBLNK1=0 22885 NBLNK2=0 22886 ITYPE=2 22887 ITTEMP='Standard Deviation of Slopes: ' 22888 NCTEMP=30 22889 CALL DPDTXT(ITTEMP,NCTEMP,SDSLOP,NUMDIG,NTOTAL, 22890 1 NBLNK1,NBLNK2,IFLAGA,IFLAGB,ISIZE, 22891 1 ICAPSW,ICAPTY,ITYPE,ISUBRO,IBUGG3,IERROR) 22892C 22893 DTERM1=DSUM/DBLE(NUMSE2-1) 22894 AVAL=REAL(DSQRT(DTERM1)) 22895 IFLAGA=.FALSE. 22896 IFLAGB=.TRUE. 22897 NBLNK1=0 22898 NBLNK2=2 22899 ITYPE=2 22900 ITTEMP='Pooled Standard Deviation of Fit: ' 22901 NCTEMP=34 22902 CALL DPDTXT(ITTEMP,NCTEMP,AVAL,NUMDIG,NTOTAL, 22903 1 NBLNK1,NBLNK2,IFLAGA,IFLAGB,ISIZE, 22904 1 ICAPSW,ICAPTY,ITYPE,ISUBRO,IBUGG3,IERROR) 22905 IRTFMD=IRTFMZ 22906 ENDIF 22907C 22908 ITITL9=' ' 22909 NCTIT9=0 22910 ITITLE='Row Averages' 22911 NCTITL=12 22912C 22913 NUMLIN=2 22914 NUMCOL=2 22915 ITITL2(1,1)=' ' 22916 ITITL2(2,1)=IX1LAB(1:NCX1) 22917 NCTIT2(1,1)=0 22918 NCTIT2(2,1)=NCX1 22919 ITITL2(1,2)='Row' 22920 ITITL2(2,2)='Average' 22921 NCTIT2(1,2)=3 22922 NCTIT2(2,2)=7 22923C 22924 NMAX=0 22925 NUMROW=NUMSE1 22926 DO2042II=1,NUMCOL 22927 VALIGN(II)='b' 22928 ALIGN(II)='r' 22929 NTOT(II)=15 22930 IF(II.EQ.1)NTOT(II)=12 22931 NMAX=NMAX+NTOT(II) 22932 IDIGIT(II)=NUMDIG 22933 ITYPCO(II)='NUME' 22934 2042 CONTINUE 22935 IDIGIT(1)=0 22936 IF(ITWOLA.EQ.'VALU' .AND. ITWODE.GT.0)THEN 22937 IDIGIT(1)=ITWODE 22938 ENDIF 22939 DO2043II=1,MAXROW 22940 DO2045JJ=1,NUMCOL 22941 NCVALU(II,JJ)=0 22942 IVALUE(II,JJ)=' ' 22943 NCVALU(II,JJ)=0 22944 AMAT(II,JJ)=0.0 22945 2045 CONTINUE 22946 2043 CONTINUE 22947C 22948 IWHTML(1)=125 22949 IWHTML(2)=150 22950 IWRTF(1)=1300 22951 IWRTF(2)=IWRTF(1)+1700 22952 IFRST=.TRUE. 22953 ILAST=.TRUE. 22954C 22955 DO2051ISET1=1,NUMSE1 22956 IF(ITWOLA.EQ.'VALU')THEN 22957 AMAT(ISET1,1)=XIDTEM(ISET1) 22958 ELSE 22959 AMAT(ISET1,1)=REAL(ISET1) 22960 ENDIF 22961 AMAT(ISET1,2)=COLAVE(ISET1) 22962 2051 CONTINUE 22963C 22964 IF(ITWOAV.EQ.'ON')THEN 22965 CALL DPDTA4(ITITL9,NCTIT9, 22966 1 ITITLE,NCTITL,ITITL2,NCTIT2, 22967 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 22968 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW, 22969 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 22970 1 ICAPSW,ICAPTY,IFRST,ILAST, 22971 1 ISUBRO,IBUGG3,IERROR) 22972C 22973 CALL MEAN(COLAVE,NUMSE1,IWRITE,GMEAN,IBUGG3,IERROR) 22974 IRTFMZ=IRTFMD 22975 IRTFMD='OFF' 22976 IFLAGA=.TRUE. 22977 IFLAGB=.TRUE. 22978 ISIZE=0 22979 NTOTAL=30 22980 NBLNK1=0 22981 NBLNK2=2 22982 ITYPE=2 22983 ITTEMP='Mean of Row Means: ' 22984 NCTEMP=19 22985 CALL DPDTXT(ITTEMP,NCTEMP,GMEAN,NUMDIG,NTOTAL, 22986 1 NBLNK1,NBLNK2,IFLAGA,IFLAGB,ISIZE, 22987 1 ICAPSW,ICAPTY,ITYPE,ISUBRO,IBUGG3,IERROR) 22988 IRTFMD=IRTFMZ 22989 ENDIF 22990C 22991C IF REQUESTED, GENERATE AN EXTENDED ANOVA TABLE 22992C 22993 IF(ITWOAN.EQ.'ON')THEN 22994C 22995C COMPUTE SSTO 22996C 22997 DSUM1=0.0D0 22998 DTERM1=DBLE(NUMSE1)*DBLE(NUMSE2)*DBLE(XGRAND)**2 22999C 23000 DO2610II=1,N 23001 DSUM1=DSUM1 + DBLE(Y(II))**2 23002 2610 CONTINUE 23003 DSSTO=DSUM1 -DTERM1 23004C 23005C COMPUTE SS(ROWS) 23006C 23007 DSUM1=0.0D0 23008 DO2620II=1,NUMSE1 23009 DSUM1=DSUM1 + DBLE(ROWAVE(II))**2 23010 2620 CONTINUE 23011 DSSROW=DBLE(NUMSE2)*DSUM1 - DTERM1 23012C 23013C COMPUTE SS(COLS) 23014C 23015 DSUM1=0.0D0 23016 DO2630II=1,NUMSE2 23017 DSUM1=DSUM1 + DBLE(COLAVE(II))**2 23018 2630 CONTINUE 23019 DSSCOL=DBLE(NUMSE1)*DSUM1 - DTERM1 23020C 23021 DSSERR=DSSTO - DSSROW - DSSCOL 23022C 23023 DSUM1=0.0D0 23024 DO2640II=1,NUMSE2 23025 DTERM1=DBLE(SLOPES(II) - 1.0)**2 23026 DSUM1=DSUM1 + DTERM1 23027 2640 CONTINUE 23028C 23029 DSUM2=0.0D0 23030 DO2650II=1,NUMSE1 23031 DTERM2=DBLE((COLAVE(II) - XGRAND)**2) 23032 DSUM2=DSUM2 + DTERM2 23033 2650 CONTINUE 23034 DSSSL=DSUM1*DSUM2 23035 DSSER2=DSSERR-DSSSL 23036C 23037C COMPUTE SUM OF SQUARES FOR COHERENCE. FORMULAS FROM 23038C MANDEL's 1961 JASA PAPER. THESE FURTHER DECOMPOSE 23039C "SLOPE" SUM OF SQUARES INTO "CONCURRENCE" AND 23040C "NON-CONCURRENCE". 23041C 23042 DSUM1=0.0D0 23043 DSUM2=0.0D0 23044 DSUM3=0.0D0 23045 DO2660II=1,NUMSE1 23046 DTERM1=DBLE(ROWAVE(II)-XGRAND) 23047 DSUM1=DSUM1 + DTERM1*DBLE(SLOPES(II)) 23048 DSUM2=DSUM2 + DTERM1**2 23049 2660 CONTINUE 23050 DO2670JJ=1,NUMSE2 23051 DTERM1=DBLE(COLAVE(JJ)-XGRAND) 23052 DSUM3=DSUM3 + DTERM1**2 23053 2670 CONTINUE 23054 DSSRGR=(DSUM1**2/DSUM2)*DSUM3 23055 DSSNCN=DSSSL - DSSRGR 23056C 23057 ITITL9=' ' 23058 NCTIT9=0 23059 ITITLE='ANOVA Table for Column-Linear Fit' 23060 NCTITL=33 23061C 23062 NUMLIN=2 23063 NUMCOL=4 23064 ITITL2(1,1)=' ' 23065 ITITL2(2,1)='Source' 23066 NCTIT2(1,1)=0 23067 NCTIT2(2,1)=6 23068 ITITL2(1,2)='Degrees of' 23069 ITITL2(2,2)='Freedom' 23070 NCTIT2(1,2)=10 23071 NCTIT2(2,2)=7 23072 ITITL2(1,3)='Sum of' 23073 ITITL2(2,3)='Squares' 23074 NCTIT2(1,3)=6 23075 NCTIT2(2,3)=7 23076 ITITL2(1,4)='Mean' 23077 ITITL2(2,4)='Square' 23078 NCTIT2(1,4)=4 23079 NCTIT2(2,4)=6 23080 ITITL2(1,5)='F' 23081 ITITL2(2,5)='Statistic' 23082 NCTIT2(1,5)=1 23083 NCTIT2(2,5)=9 23084 ITITL2(1,6)=' ' 23085 ITITL2(2,6)='F CDF' 23086 NCTIT2(1,6)=0 23087 NCTIT2(2,6)=5 23088C 23089 NMAX=0 23090 NUMROW=8 23091 IWRTF(1)=1900 23092 DO2742II=1,NUMCOL 23093 VALIGN(II)='b' 23094 ALIGN(II)='r' 23095 NTOT(II)=15 23096 IF(II.EQ.1)NTOT(II)=20 23097 NMAX=NMAX+NTOT(II) 23098 IDIGIT(II)=NUMDIG 23099 IF(II.GE.3.AND.II.LE.4.AND.ITWOAD.GE.-9)IDIGIT(II)=ITWOAD 23100 ITYPCO(II)='NUME' 23101 IWHTML(II)=150 23102 IF(II.GE.2)IWRTF(II)=IWRTF(II-1)+1700 23103 2742 CONTINUE 23104 IDIGIT(1)=0 23105 IDIGIT(2)=0 23106 ALIGN(1)='l' 23107 ITYPCO(1)='ALPH' 23108 DO2743II=1,MAXROW 23109 DO2745JJ=1,NUMCOL 23110 NCVALU(II,JJ)=0 23111 IVALUE(II,JJ)=' ' 23112 NCVALU(II,JJ)=0 23113 AMAT(II,JJ)=0.0 23114 2745 CONTINUE 23115 2743 CONTINUE 23116C 23117 IFRST=.TRUE. 23118 ILAST=.TRUE. 23119C 23120C LABEL 23121C 23122 IVALUE(1,1)='Total' 23123 NCVALU(1,1)=5 23124 IVALUE(2,1)='Rows' 23125 NCVALU(2,1)=4 23126 IVALUE(3,1)='Columns' 23127 NCVALU(3,1)=6 23128 IVALUE(4,1)='Error' 23129 NCVALU(4,1)=5 23130 IVALUE(5,1)=' Residuals' 23131 NCVALU(5,1)=11 23132 IVALUE(6,1)=' Slopes' 23133 NCVALU(6,1)=8 23134 IVALUE(7,1)=' Concurrence' 23135 NCVALU(7,1)=15 23136 IVALUE(8,1)=' Non-Concurrence' 23137 NCVALU(8,1)=19 23138C 23139C DEGREES OF FREEDOM 23140C 23141 AMAT(1,2)=REAL(NUMSE1-1) + REAL(NUMSE2-1) + 23142 1 REAL((NUMSE1-1)*(NUMSE2-1)) 23143 AMAT(2,2)=REAL(NUMSE1-1) 23144 AMAT(3,2)=REAL(NUMSE2-1) 23145 AMAT(4,2)=REAL((NUMSE1-1)*(NUMSE2-1)) 23146 AMAT(5,2)=REAL((NUMSE1-1)*(NUMSE2-1)) - REAL(NUMSE1-1) 23147 AMAT(6,2)=REAL(NUMSE1-1) 23148 AMAT(7,2)=1.0 23149 AMAT(8,2)=REAL(NUMSE1-2) 23150C 23151C SUM OF SQUARES 23152C 23153 AMAT(1,3)=REAL(DSSTO) 23154 AMAT(2,3)=REAL(DSSROW) 23155 AMAT(3,3)=REAL(DSSCOL) 23156 AMAT(4,3)=REAL(DSSERR) 23157 AMAT(5,3)=REAL(DSSER2) 23158 AMAT(6,3)=REAL(DSSSL) 23159 AMAT(7,3)=REAL(DSSRGR) 23160 AMAT(8,3)=REAL(DSSNCN) 23161C 23162C MEAN SQUARE 23163C 23164 AMAT(1,4)=AMAT(1,3)/AMAT(1,2) 23165 AMAT(2,4)=AMAT(2,3)/AMAT(2,2) 23166 AMAT(3,4)=AMAT(3,3)/AMAT(3,2) 23167 AMAT(4,4)=AMAT(4,3)/AMAT(4,2) 23168 AMAT(5,4)=AMAT(5,3)/AMAT(5,2) 23169 AMAT(6,4)=AMAT(6,3)/AMAT(6,2) 23170 AMAT(7,4)=AMAT(7,3)/AMAT(7,2) 23171 AMAT(8,4)=AMAT(8,3)/AMAT(8,2) 23172C 23173 CALL DPDTA4(ITITL9,NCTIT9, 23174 1 ITITLE,NCTITL,ITITL2,NCTIT2, 23175 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 23176 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW, 23177 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 23178 1 ICAPSW,ICAPTY,IFRST,ILAST, 23179 1 ISUBRO,IBUGG3,IERROR) 23180C 23181 ENDIF 23182C 23183 ENDIF 23184C 23185 N2=J 23186 NPLOTV=3 23187 GOTO9000 23188C 23189C ****************** 23190C ** STEP 90-- ** 23191C ** EXIT ** 23192C ****************** 23193C 23194 9000 CONTINUE 23195C 23196 IRTFPS=IRTFSV 23197 IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN 23198 WRITE(ICOUT,103)IBASLC,IRTFPS 23199 CALL DPWRST('XXX','WRIT') 23200 ENDIF 23201C 23202 IOP='CLOS' 23203 CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLA41,IFLG51, 23204 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 23205 1 IBUGG3,ISUBRO,IERROR) 23206C 23207 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TWP2')THEN 23208 WRITE(ICOUT,999) 23209 CALL DPWRST('XXX','BUG ') 23210 WRITE(ICOUT,9011) 23211 9011 FORMAT('***** AT THE END OF DPTWP2--') 23212 CALL DPWRST('XXX','BUG ') 23213 WRITE(ICOUT,9013)IERROR,NUMSE1,NUMSE2,N2 23214 9013 FORMAT('IERROR,NUMSE1,NUMSE2,N2 = ',A4,3I8) 23215 CALL DPWRST('XXX','BUG ') 23216 DO9020I=1,N2 23217 WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I) 23218 9021 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,3G15.7) 23219 CALL DPWRST('XXX','BUG ') 23220 9020 CONTINUE 23221 ENDIF 23222C 23223 RETURN 23224 END 23225 SUBROUTINE DPTY3B(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX, 23226 1 IBUGA3, 23227 1 IFOUZ2,ISTAR2,ISTOP2, 23228 1 ITYPE2,IHOL,IHOL2,INTZ,FLOAT,IERROR) 23229C 23230C NOTE--THIS SUBROUTINE IS IDENTICAL TO DPTYP3 23231C AND HAS BEEN DUPLICATED ONLY FOR MAPPING PURPOSES. 23232C DATE--SEPTEMBER 5, 1981. 23233C 23234C PURPOSE--SCAN THE CHARACTER ARRAY IANS(.) BETWEEN 23235C COLUMNS ISTAR1 AND ISTOP1 23236C FOR THE STRING DEFINED IN STRIN AND ISTRI2. 23237C NOTE THAT THE STRING DEFINED IN ISTRIN AND ISTRI2 23238C MAY BE EXPRESSED IN SEVERAL WAYS-- 23239C 1) EXPLICITELY, E.G., LET FOR SUBSET, ETC. 23240C 2) IMPLICITELY WITH ! REPRESENTING THE FIRST 23241C NON-BLANK CHARACTER THAT IS ENCOUNTERED; 23242C 3) IMPLICITELY WITH ; REPRESENTING ANY STRING 23243C (INCLUDING ALL CHARACTERS, EVEN BLANKS)); 23244C 4) IMPLICITELY WITH : REPRESENTING THE FIRST 23245C BLANK CHARACTER THAT IS ENCOUNTERED. 23246C NOTE--A GIVEN ARGUMENT MAY END UP WITH 23247C 3 DIFFERENT REPRESENTATIONS-- 23248C HOLLERITH, INTEGER, AND FLOATING POINT. 23249C INPUT ARGUMENTS--IANS = A HOLLERITH 1-CHARACTER-PER-WORD 23250C VARIABLE CONTAINING THE INPUT LINE 23251C TO BE EXAMINED. 23252C --IWIDTH = THE (FULL) WIDTH OF THE INPUT LINE 23253C (THAT IS, THE NUMBER OF COLUMNS) 23254C --ISTAR1 = THE FIRST COLUMN FOR WHICH THE 23255C SCAN IS TO BE CARRIED OUT. 23256C --ISTOP1 = THE LAST COLUMN FOR WHICH THE 23257C SCAN IS TO BE CARRIED OUT. 23258C --ISTRIN = THE HOLLERITH VARIABLE 23259C WHICH CONTAINS CHARACTERS 1 TO 4 23260C OF THE STRING TO BE SEARCHED FOR. 23261C THE DEFINITION OF THE STRING IN ISTRIN MAY 23262C MAY BE DONE EXPLICTELY (BUT IS LIMITED 23263C TO 4 CHARACTERS) OR IMPLICITELY 23264C WHICH IS NOT LIMITED TO 4 CHARACTERS AND IS MOR 23265C IS MORE GENERAL IN 23266C OTHER WAYS ALSO. 23267C --ISTRI2 = THE HOLLERITH VARIABLE 23268C WHICH CONTAINS CHARACTERS 5 TO 8 23269C OF THE STRING TO BE SEARCHED FOR. 23270C THE DEFINITION OF THE STRING IN ISTRIN MAY 23271C MAY BE DONE EXPLICTELY (BUT IS LIMITED 23272C TO 4 CHARACTERS) OR IMPLICITELY 23273C WHICH IS NOT LIMITED TO 4 CHARACTERS AND IS MOR 23274C IS MORE GENERAL IN 23275C OTHER WAYS ALSO. 23276C --INEX = A HOLLERITH VARIABLE WHICH 23277C WILL CONTAIN ONE OF THE FOLLOWING 4 VALUES-- 23278C II, IE, EI, EE THAT STANDS FOR 23279C WHERE I STANDS FOR INCLUSIVE AND 23280C WHERE E STANDS FOR EXCLUSIVE; 23281C INEX SPECIFIES WHETHER THE FIRST OR LAST CHARAC 23282C CHARACTER IS TO BE INCLUDED OR EXCLUDED IN 23283C IN DEFINING ISTAR2 AND ISTOP2. 23284C OUTPUT ARGUMENTS--IFOUZ2 = A HOLLERITH VARIABLE 23285C WITH THE VALUE 'YES' 23286C IF THE STRING WAS FOUND; 23287C AND THE VALUE 'NO' 23288C IF THE STRING WAS NOT FOUND. 23289C --ISTAR2 = THE START COLUMN OF THE FOUND STRING 23290C --ISTOP2 = THE STOP COLUMN OF THE FIUND STRING. 23291C --ITYPE2 = A HOLLERITH VARIABLE 23292C WITH THE VALUE 'WORD' IF THE STRING CONTAINS 23293C ANY NON-NUMERIC (EXCLUDING BLANKS) CHARACTER; 23294C AND WITH THE VALUE 'NUMB' IF THE STRING CONTA 23295C ALL NUMERIC VALUES OR DECIMAL POINT OR + OR - 23296C (WITH INTERMITTENT BLANKS IGNORED). 23297C --IHOL = THE HOLLERITH VARIABLE 23298C CONTAINING THE PACKED (4 CHARACTERS) VERSION 23299C OF CHARACTERS 1 TO 4 OF THE FOUND STRING. 23300C --IHOL2 = THE HOLLERITH VARIABLE 23301C CONTAINING THE PACKED (4 CHARACTERS) VERSION 23302C OF CHARACTERS 5 TO 8 OF THE FOUND STRING. 23303C --INT = THE INTEGER VARIABLE 23304C CONTAINING THE INTEGER REPRESENTATION 23305C (IF POSSIBLE) OF THE FOUND STRING. 23306C --FLOAT = THE FLOATING POINT VARIABLE 23307C CONTAINING THE FLOATING POINT REPRESENTATION 23308C (IF POSSIBLE) OF THE FOUND STRING. 23309C --IERROR = A HOLLERITH VARIABLE WITH VALUE 23310C 'YES' OR 'NO' INDICATING IF AN 23311C ERROR CONDITION EXISTS. 23312C WRITTEN BY--JAMES J. FILLIBEN 23313C STATISTICAL ENGINEERING DIVISION 23314C INFORMATION TECHNOLOGY LABORATORY 23315C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 23316C GAITHERSBURG, MD 20899-8980 23317C PHONE--301-975-2855 23318C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 23319C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 23320C LANGUAGE--ANSI FORTRAN (1977) 23321C VERSION NUMBER--82/7 23322C ORIGINAL VERSION--FEBRUARY 1978. 23323C UPDATED --JULY 1978. 23324C UPDATED --OCTOBER 1978. 23325C UPDATED --NOVEMBER 1980. 23326C UPDATED --JANUARY 1981. 23327C UPDATED --JUNE 1981. 23328C UPDATED --MARCH 1982. 23329C UPDATED --MAY 1982. 23330C 23331C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 23332C 23333 CHARACTER*4 IANS 23334 CHARACTER*4 ISTRIN 23335 CHARACTER*4 ISTRI2 23336 CHARACTER*4 INEX 23337 CHARACTER*4 IBUGA3 23338 CHARACTER*4 IFOUZ2 23339 CHARACTER*4 ITYPE2 23340 CHARACTER*4 IHOL 23341 CHARACTER*4 IHOL2 23342 CHARACTER*4 IERROR 23343C 23344 CHARACTER*4 IBUG1 23345 CHARACTER*4 IBUG2 23346 CHARACTER*4 ITEMP 23347 CHARACTER*4 IFLUNK 23348 CHARACTER*4 ISTRI3 23349C 23350 CHARACTER*4 ISUBN1 23351 CHARACTER*4 ISUBN2 23352 CHARACTER*4 ISTEPN 23353C 23354C--------------------------------------------------------------------- 23355C 23356 DIMENSION IANS(*) 23357C 23358 DIMENSION ISTRI3(20) 23359C 23360C-----COMMON---------------------------------------------------------- 23361C 23362 INCLUDE 'DPCOP2.INC' 23363C 23364C-----START POINT----------------------------------------------------- 23365C 23366 ISUBN1='DPTY' 23367 ISUBN2='P3 ' 23368 IERROR='NO' 23369C 23370 I2=0 23371 IPJM1=0 23372C 23373 IF(IBUGA3.EQ.'ON')THEN 23374 WRITE(ICOUT,999) 23375 999 FORMAT(1X) 23376 CALL DPWRST('XXX','BUG ') 23377 WRITE(ICOUT,51) 23378 51 FORMAT('***** AT THE BEGINNING OF DPTY3B--') 23379 CALL DPWRST('XXX','BUG ') 23380 WRITE(ICOUT,53)ISTAR1,ISTOP1 23381 53 FORMAT('ISTAR1,ISTOP1 = ',2I8) 23382 CALL DPWRST('XXX','BUG ') 23383 WRITE(ICOUT,54)IBUGA3,ISTRI,ISTRI2 23384 54 FORMAT('IBUGA3,ISTRIN,ISTRI2 = ',2(A4,2X),A4) 23385 CALL DPWRST('XXX','BUG ') 23386 ENDIF 23387C 23388 NUMASC=4 23389C 23390 IBUG1='OFF' 23391 IBUG2='OFF' 23392C 23393C ****************************************************** 23394C ** STEP 1-- ** 23395C ** INITIALIZE THE OUTPUT PARAMETERS AND VARIABLES ** 23396C ****************************************************** 23397C 23398 ISTEPN='1' 23399 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 23400C 23401 IF(IBUG1.EQ.'OFF')GOTO150 23402 WRITE(ICOUT,101) 23403 101 FORMAT('AT THE BEGINNING OF DPTY3B--') 23404 CALL DPWRST('XXX','BUG ') 23405 WRITE(ICOUT,102)IWIDTH 23406 102 FORMAT('IWIDTH = ',I8) 23407 CALL DPWRST('XXX','BUG ') 23408 WRITE(ICOUT,103)(IANS(I),I=1,IWIDTH) 23409 103 FORMAT('IANS(.) = ',80A1) 23410 CALL DPWRST('XXX','BUG ') 23411 WRITE(ICOUT,104)ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX 23412 104 FORMAT('ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX = ',I8,I8,A4,A4,A4) 23413 CALL DPWRST('XXX','BUG ') 23414 150 CONTINUE 23415 IFOUZ2='NO' 23416 ISTAR2=-1 23417 ISTOP2=-1 23418 ITYPE2='9999' 23419 IHOL ='9999' 23420 IHOL2='9999' 23421 INTZ = -999999 23422 FLOAT=-999999.0 23423C 23424C ************************************************************ 23425C ** STEP 2-- ** 23426C ** DECOMPOSE THE INPUT SEARCH STRING INTO A1 CHARACTERS ** 23427C ************************************************************ 23428C 23429 ISTEPN='2' 23430 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 23431 IMAX=2*NUMASC 23432 DO300I=1,IMAX 23433 I2=I 23434 J=I 23435 IF(I.GT.NUMASC)J=I-NUMASC 23436 ISTAR3=NUMBPC*(J-1) 23437 ISTAR3=IABS(ISTAR3) 23438 ITEMP=' ' 23439 IF(I.LE.NUMASC)CALL DPCHEX(ISTAR3,NUMBPC,ISTRIN,0,NUMBPC,ITEMP) 23440 IF(I.GT.NUMASC)CALL DPCHEX(ISTAR3,NUMBPC,ISTRI2,0,NUMBPC,ITEMP) 23441 IF(ITEMP.EQ.' ')GOTO350 23442 ISTRI3(I)=ITEMP 23443 300 CONTINUE 23444 ILEN2=I2 23445 GOTO390 23446 350 CONTINUE 23447 ILEN2=I2-1 23448 390 CONTINUE 23449C 23450 IF(IBUG2.EQ.'OFF')GOTO399 23451 WRITE(ICOUT,391) 23452 391 FORMAT('IN THE MIDDLE OF DPTY3B (AFTER STEP 2)--') 23453 CALL DPWRST('XXX','BUG ') 23454 WRITE(ICOUT,392)ILEN2 23455 392 FORMAT('ILEN2 = ',I8) 23456 CALL DPWRST('XXX','BUG ') 23457 WRITE(ICOUT,393)(ISTRI3(I),I=1,ILEN2) 23458 393 FORMAT('ISTRI3(.) = ',6A1) 23459 CALL DPWRST('XXX','BUG ') 23460 399 CONTINUE 23461C 23462C **************************************************************** 23463C ** STEP 3-- 23464C ** DISTINGUISH BETWEEN THE 3 TYPES OF POSSIBLE SEARCH STRINGS-- 23465C ** 1) AN EXPLICITELY-DEFINED STRING; E.G., 23466C ** LET FOR SUBSET = 5.3 -2.6666666 23467C ** (AS IN COMMANDS, KEY WORDS, AND NUMBERS); 23468C ** 2) A STRING STARTING WITH THE FIRST NON-BLANK CHARACTER 23469C ** AND ENDING WITH SOME SPECIFIED CHARACTER; E.G., XXXXX( 23470C ** (AS IN THE VARIABLE NAME OF A SUBSCRIPTED VARIABLE, 23471C ** OR THE ARGUMENT (I. E., THE SUBSCRIPT) IN A SUBSCRIPTED 23472C ** VARIABLE); 23473C ** 3) A STRING STARTING WITH THE FIRST NON-BLANK CHARACTER 23474C ** AND ENDING WITH THE FIRST SUBSEQUENT BLANK CHARCTER (EXCL 23475C ** E.G., XXXX 23476C ** (AS IN SOME UNSPECIFIED PARAMETER OR VARIABLE NAME). 23477C **************************************************************** 23478C 23479 ISTEPN='3' 23480 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 23481 ICASE=1 23482 IF(ISTRI3(1).NE.'!'.AND.ISTRI3(2).EQ.';'.AND.ISTRI3(3).NE.':') 23483 1ICASE=2 23484 IF(ISTRI3(1).EQ.'!'.AND.ISTRI3(2).EQ.';'.AND.ISTRI3(3).NE.':') 23485 1ICASE=3 23486 IF(ISTRI3(1).EQ.'!'.AND.ISTRI3(2).EQ.';'.AND.ISTRI3(3).EQ.':') 23487 1ICASE=4 23488 IF(ILEN2.EQ.1.OR.ILEN2.EQ.2)ICASE=1 23489C 23490 IF(IBUG2.EQ.'OFF')GOTO398 23491 WRITE(ICOUT,395) 23492 395 FORMAT('AFTER STEP 3 OF DPTY3B--') 23493 CALL DPWRST('XXX','BUG ') 23494 WRITE(ICOUT,396)ICASE 23495 396 FORMAT('ICASE = ',I8) 23496 CALL DPWRST('XXX','BUG ') 23497 398 CONTINUE 23498C 23499C ********************************************************* 23500C ** STEP 4-- ** 23501C ** DETERMINE IF THE DESIRED SEARCH STRING IS PRESENT ** 23502C ********************************************************* 23503C 23504 ISTEPN='4' 23505 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 23506 IF(ICASE.EQ.1)GOTO400 23507 IF(ICASE.EQ.2)GOTO500 23508 IF(ICASE.EQ.3)GOTO600 23509 IF(ICASE.EQ.4)GOTO700 23510C 23511 400 CONTINUE 23512 DO410I=ISTAR1,ISTOP1 23513 I2=I 23514 IF(IANS(I).EQ.ISTRI3(1))GOTO420 23515 GOTO410 23516 420 CONTINUE 23517 DO430J=1,ILEN2 23518 IPJM1=J+I-1 23519 IF(IPJM1.GT.ISTOP1)GOTO410 23520 IF(IANS(IPJM1).EQ.ISTRI3(J))GOTO430 23521 GOTO410 23522 430 CONTINUE 23523 IFOUZ2='YES' 23524 IF(INEX.EQ.'II')ISTAR2=I2 23525 IF(INEX.EQ.'IE')ISTAR2=I2 23526 IF(INEX.EQ.'EI')ISTAR2=I2+1 23527 IF(INEX.EQ.'EE')ISTAR2=I2+1 23528 IF(INEX.EQ.'II')ISTOP2=IPJM1 23529 IF(INEX.EQ.'IE')ISTOP2=IPJM1-1 23530 IF(INEX.EQ.'EI')ISTOP2=IPJM1 23531 IF(INEX.EQ.'EE')ISTOP2=IPJM1-1 23532 IF(ISTAR2.LE.ISTOP2)GOTO990 23533 GOTO900 23534 410 CONTINUE 23535 IFOUZ2='NO' 23536 GOTO9000 23537C 23538 500 CONTINUE 23539 DO510I=ISTAR1,ISTOP1 23540 I2=I 23541 IF(IANS(I).EQ.ISTRI3(1))GOTO520 23542 510 CONTINUE 23543 IFOUZ2='NO' 23544 GOTO9000 23545 520 CONTINUE 23546 IMIN=I2 23547 DO530I=IMIN,ISTOP1 23548 I2=I 23549 IF(IANS(I).EQ.ISTRI3(ILEN2))GOTO540 23550 530 CONTINUE 23551 IFOUZ2='NO' 23552 GOTO9000 23553 540 CONTINUE 23554 IFOUZ2='YES' 23555 IF(INEX.EQ.'II')ISTAR2=IMIN 23556 IF(INEX.EQ.'IE')ISTAR2=IMIN 23557 IF(INEX.EQ.'EI')ISTAR2=IMIN+1 23558 IF(INEX.EQ.'EE')ISTAR2=IMIN+1 23559 IF(INEX.EQ.'II')ISTOP2=I2 23560 IF(INEX.EQ.'IE')ISTOP2=I2-1 23561 IF(INEX.EQ.'EI')ISTOP2=I2 23562 IF(INEX.EQ.'EE')ISTOP2=I2-1 23563 IF(ISTAR2.LE.ISTOP2)GOTO990 23564 GOTO900 23565C 23566 600 CONTINUE 23567 DO610I=ISTAR1,ISTOP1 23568 I2=I 23569 IF(IANS(I).NE.' ')GOTO620 23570 610 CONTINUE 23571 IFOUZ2='NO' 23572 GOTO9000 23573 620 CONTINUE 23574 IMIN=I2 23575 DO630I=IMIN,ISTOP1 23576 I2=I 23577 IF(IANS(I).EQ.ISTRI3(ILEN2))GOTO640 23578 630 CONTINUE 23579 IFOUZ2='NO' 23580 GOTO9000 23581 640 CONTINUE 23582 IFOUZ2='YES' 23583 IF(INEX.EQ.'II')ISTAR2=IMIN 23584 IF(INEX.EQ.'IE')ISTAR2=IMIN 23585 IF(INEX.EQ.'EI')ISTAR2=IMIN+1 23586 IF(INEX.EQ.'EE')ISTAR2=IMIN+1 23587 IF(INEX.EQ.'II')ISTOP2=I2 23588 IF(INEX.EQ.'IE')ISTOP2=I2-1 23589 IF(INEX.EQ.'EI')ISTOP2=I2 23590 IF(INEX.EQ.'EE')ISTOP2=I2-1 23591 IF(ISTAR2.LE.ISTOP2)GOTO990 23592 GOTO900 23593C 23594 700 CONTINUE 23595 DO710I=ISTAR1,ISTOP1 23596 I2=I 23597 IF(IANS(I).NE.' ')GOTO720 23598 710 CONTINUE 23599 IFOUZ2='NO' 23600 GOTO9000 23601 720 CONTINUE 23602 IMIN=I2 23603 DO730I=IMIN,ISTOP1 23604 I2=I 23605 IF(IANS(I).EQ.' ')GOTO740 23606 730 CONTINUE 23607 IFOUZ2='NO' 23608 GOTO9000 23609 740 CONTINUE 23610 IFOUZ2='YES' 23611 IF(INEX.EQ.'II')ISTAR2=IMIN 23612 IF(INEX.EQ.'IE')ISTAR2=IMIN 23613 IF(INEX.EQ.'EI')ISTAR2=IMIN+1 23614 IF(INEX.EQ.'EE')ISTAR2=IMIN+1 23615 IF(INEX.EQ.'II')ISTOP2=I2 23616 IF(INEX.EQ.'IE')ISTOP2=I2-1 23617 IF(INEX.EQ.'EI')ISTOP2=I2 23618 IF(INEX.EQ.'EE')ISTOP2=I2-1 23619 IF(ISTAR2.LE.ISTOP2)GOTO990 23620 GOTO900 23621C 23622 900 CONTINUE 23623C 23624C NOTE--THE FOLLOWING SECTION HAS BEEN 'BUGGED' OUT 23625C TO CIRCUMVENT A PROBLEM WITH Y=(... 23626C WHILE IT STILL LOOKED FOR A VARIABLE NAME 23627C BETWEEN THE = AND THE ( . 23628C CAUTION--WHEN IBUGA3 = 'OFF', AS IT USUALLY IS, 23629C IERROR CAN NEVER BE 'YES' 23630C UPON RETURN FROM DPTY3B: 23631C BUT WHEN IBUGA3 = 'ON' (AS IN ERROR TRACING) 23632C IERROR MAY = 'YES' WHICH MAY CHANGE THE 23633C LOGIC PATH BACK IN DPTYP2. 23634C 23635 IF(IBUGA3.EQ.'OFF')GOTO9000 23636 WRITE(ICOUT,921) 23637 921 FORMAT('***** INTERNAL ERROR IN DPTY3B SUBROUTINE') 23638 CALL DPWRST('XXX','BUG ') 23639 WRITE(ICOUT,922) 23640 922 FORMAT('ISTAR2 GREATER THAN ISTOP2') 23641 CALL DPWRST('XXX','BUG ') 23642 WRITE(ICOUT,923)ISTAR2,ISTOP2 23643 923 FORMAT('ISTAR2, ISTOP2 = ',2I8) 23644 CALL DPWRST('XXX','BUG ') 23645 WRITE(ICOUT,924)ICASE 23646 924 FORMAT('ICASE = ',I8) 23647 CALL DPWRST('XXX','BUG ') 23648 WRITE(ICOUT,999) 23649 CALL DPWRST('XXX','BUG ') 23650 WRITE(ICOUT,925)IWIDTH 23651 925 FORMAT('IWIDTH = ',I8) 23652 CALL DPWRST('XXX','BUG ') 23653 WRITE(ICOUT,926)(IANS(I),I=1,IWIDTH) 23654 926 FORMAT('IANS(.) = ',80A1) 23655 CALL DPWRST('XXX','BUG ') 23656 WRITE(ICOUT,927)ISTAR1,ISTOP1 23657 927 FORMAT('ISTAR1, ISTOP1 = ',2I8) 23658 CALL DPWRST('XXX','BUG ') 23659 WRITE(ICOUT,928)ILEN2 23660 928 FORMAT('ILEN2 = ',I8) 23661 CALL DPWRST('XXX','BUG ') 23662 WRITE(ICOUT,929)(ISTRI3(I),I=1,ILEN2) 23663 929 FORMAT('ISTRI3(.) = ',80A1) 23664 CALL DPWRST('XXX','BUG ') 23665 WRITE(ICOUT,930)ISTRIN,ISTRI2 23666 930 FORMAT('ISTRIN,ISTRI2 = ',2A4) 23667 CALL DPWRST('XXX','BUG ') 23668 WRITE(ICOUT,931)INEX 23669 931 FORMAT('INEX = ',A4) 23670 CALL DPWRST('XXX','BUG ') 23671 IERROR='YES' 23672 GOTO9000 23673 990 CONTINUE 23674C 23675C ******************************************************** 23676C ** STEP 5-- ** 23677C ** CONVERT THE STRING INTO 2 HOLLERITH A4 WORDS. ** 23678C ** IF MORE THAN 8 CHARACTERS, CONVERT ONLY ** 23679C ** THE FIRST 8 CHARACTERS. ** 23680C ** OUTPUT THESE HOLLERITH WORDS AS IHOL AND IHOL2. ** 23681C ******************************************************** 23682C 23683 ISTEPN='5' 23684 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 23685 IHOL =' ' 23686 IHOL2=' ' 23687 IMAX=2*NUMASC 23688 J=0 23689 DO1000I=ISTAR2,ISTOP2 23690 J=J+1 23691 K=J 23692 IF(J.GT.NUMASC)K=J-NUMASC 23693 ISTAR3=NUMBPC*(K-1) 23694 ISTAR3=IABS(ISTAR3) 23695 IF(J.LE.NUMASC)CALL DPCHEX(0,NUMBPC,IANS(I),ISTAR3,NUMBPC,IHOL) 23696 IF(J.GT.NUMASC)CALL DPCHEX(0,NUMBPC,IANS(I),ISTAR3,NUMBPC,IHOL2) 23697 IF(J.GE.IMAX)GOTO1050 23698 1000 CONTINUE 23699 1050 CONTINUE 23700C 23701C **************************************************************** 23702C ** STEP 6-- 23703C ** CONVERT (IF POSSIBLE) THE STRING INTO AN INTEGER ARGUMENT. 23704C ** OUTPUT THIS INTEGER VALUE IN INT. 23705C **************************************************************** 23706C 23707 ISTEPN='6' 23708 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 23709 IFLUNK='NO' 23710 ITYPE2='NUMB' 23711 IDIG=0 23712 ISIGN=0 23713 IDECPT=0 23714 ISUM=0 23715 DO2700I=ISTAR2,ISTOP2 23716 IREV=ISTOP2-(I-ISTAR2) 23717 IF(IANS(IREV).EQ.' ')GOTO2700 23718 IF(IANS(IREV).EQ.'0')GOTO2710 23719 IF(IANS(IREV).EQ.'1')GOTO2711 23720 IF(IANS(IREV).EQ.'2')GOTO2712 23721 IF(IANS(IREV).EQ.'3')GOTO2713 23722 IF(IANS(IREV).EQ.'4')GOTO2714 23723 IF(IANS(IREV).EQ.'5')GOTO2715 23724 IF(IANS(IREV).EQ.'6')GOTO2716 23725 IF(IANS(IREV).EQ.'7')GOTO2717 23726 IF(IANS(IREV).EQ.'8')GOTO2718 23727 IF(IANS(IREV).EQ.'9')GOTO2719 23728 IF(IANS(IREV).EQ.'+')GOTO2720 23729 IF(IANS(IREV).EQ.'-')GOTO2721 23730 IF(IANS(IREV).EQ.'.')GOTO2722 23731 IFLUNK='YES' 23732 GOTO2800 23733 2710 ITERM=0 23734 GOTO2725 23735 2711 ITERM=1 23736 GOTO2725 23737 2712 ITERM=2 23738 GOTO2725 23739 2713 ITERM=3 23740 GOTO2725 23741 2714 ITERM=4 23742 GOTO2725 23743 2715 ITERM=5 23744 GOTO2725 23745 2716 ITERM=6 23746 GOTO2725 23747 2717 ITERM=7 23748 GOTO2725 23749 2718 ITERM=8 23750 GOTO2725 23751 2719 ITERM=9 23752 GOTO2725 23753 2720 ISIGN=ISIGN+1 23754 GOTO2700 23755 2721 ISIGN=ISIGN+1 23756 ISUM=-ISUM 23757 GOTO2700 23758 2722 IDECPT=IDECPT+1 23759 IF(IDECPT.EQ.1.AND.IDIG.EQ.0)GOTO2700 23760 GOTO2800 23761 2725 IDIG=IDIG+1 23762 TERM2=10.0**(IDIG-1) 23763 ITERM2=INT(TERM2 + 0.01) 23764 ISUM=ISUM+ITERM*ITERM2 23765 2700 CONTINUE 23766 IF(IDIG.LE.0)GOTO2800 23767 IF(ISIGN.GE.2)GOTO2800 23768 INTZ=ISUM 23769 2800 CONTINUE 23770 IF(IFLUNK.EQ.'YES')ITYPE2='WORD' 23771C 23772C ******************************************************* 23773C ** STEP 7-- ** 23774C ** CONVERT (IF POSSIBLE) THE STRING INTO A FLOATING ** 23775C ** POINT ARGUMENT. ** 23776C ** OUTPUT THIS FLOATING POINT VALUE IN FLOAT. ** 23777C ******************************************************* 23778C 23779 ISTEPN='7' 23780 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 23781 AMIN=-1000000. 23782 AMAX=+1000000. 23783 IFLUNK='NO' 23784 ITYPE2='NUMB' 23785 FLOAT=-1.0 23786C 23787 ILOC=0 23788 IDECPT=0 23789 DO3060I=ISTAR2,ISTOP2 23790 IF(IANS(I).EQ.'.')ILOC=I 23791 IF(IANS(I).EQ.'.')IDECPT=IDECPT+1 23792 3060 CONTINUE 23793 IF(IDECPT.GE.2)GOTO3900 23794 IF(IDECPT.EQ.1)GOTO3150 23795 DO3100I=ISTAR2,ISTOP2 23796 IREV=ISTOP2-(I-ISTAR2) 23797 IF(IANS(IREV).EQ.' ')GOTO3100 23798 IF(IANS(IREV).EQ.'0')GOTO3110 23799 IF(IANS(IREV).EQ.'1')GOTO3110 23800 IF(IANS(IREV).EQ.'2')GOTO3110 23801 IF(IANS(IREV).EQ.'3')GOTO3110 23802 IF(IANS(IREV).EQ.'4')GOTO3110 23803 IF(IANS(IREV).EQ.'5')GOTO3110 23804 IF(IANS(IREV).EQ.'6')GOTO3110 23805 IF(IANS(IREV).EQ.'7')GOTO3110 23806 IF(IANS(IREV).EQ.'8')GOTO3110 23807 IF(IANS(IREV).EQ.'9')GOTO3110 23808 IFLUNK='YES' 23809 IF(IANS(IREV).EQ.'+')GOTO3900 23810 IF(IANS(IREV).EQ.'-')GOTO3900 23811 GOTO3900 23812 3100 CONTINUE 23813 IFLUNK='YES' 23814 GOTO3900 23815 3110 ILOC=IREV+1 23816 3150 CONTINUE 23817 IF(IBUG2.EQ.'ON')WRITE(ICOUT,3111)ILOC,IDECPT 23818 3111 FORMAT('ILOC = ',I8,' IDECPT = ',I8) 23819 IF(IBUG2.EQ.'ON')CALL DPWRST('XXX','BUG ') 23820C 23821C SECONDLY, COMPUTE THE INTEGER PART OF THE VALUE 23822C 23823 SIGN=1.0 23824 IDIGI=0 23825 ISIGN=0 23826 SUMI=0 23827 ILOCM1=ILOC-1 23828 IF(ILOCM1.LT.ISTAR2)GOTO3250 23829 DO3200I=ISTAR2,ILOCM1 23830 IREV=ILOCM1-(I-ISTAR2) 23831 IF(IANS(IREV).EQ.' ')GOTO3200 23832 IF(IANS(IREV).EQ.'0')GOTO3210 23833 IF(IANS(IREV).EQ.'1')GOTO3211 23834 IF(IANS(IREV).EQ.'2')GOTO3232 23835 IF(IANS(IREV).EQ.'3')GOTO3213 23836 IF(IANS(IREV).EQ.'4')GOTO3214 23837 IF(IANS(IREV).EQ.'5')GOTO3215 23838 IF(IANS(IREV).EQ.'6')GOTO3216 23839 IF(IANS(IREV).EQ.'7')GOTO3217 23840 IF(IANS(IREV).EQ.'8')GOTO3218 23841 IF(IANS(IREV).EQ.'9')GOTO3219 23842 IF(IANS(IREV).EQ.'+')GOTO3220 23843 IF(IANS(IREV).EQ.'-')GOTO3221 23844 IFLUNK='YES' 23845 GOTO3900 23846 3210 ITERM=0 23847 GOTO3225 23848 3211 ITERM=1 23849 GOTO3225 23850 3232 ITERM=2 23851 GOTO3225 23852 3213 ITERM=3 23853 GOTO3225 23854 3214 ITERM=4 23855 GOTO3225 23856 3215 ITERM=5 23857 GOTO3225 23858 3216 ITERM=6 23859 GOTO3225 23860 3217 ITERM=7 23861 GOTO3225 23862 3218 ITERM=8 23863 GOTO3225 23864 3219 ITERM=9 23865 GOTO3225 23866 3220 ISIGN=ISIGN+1 23867 GOTO3200 23868 3221 ISIGN=ISIGN+1 23869 SIGN=-SIGN 23870 GOTO3200 23871 3225 IDIGI=IDIGI+1 23872 TERM=ITERM 23873 IEXP=IDIGI-1 23874 SUMI=SUMI+TERM*(10.0**IEXP) 23875 3200 CONTINUE 23876 3250 CONTINUE 23877 IF(ISIGN.GE.2)GOTO3900 23878 IF(IBUG2.EQ.'ON')WRITE(ICOUT,3255)IDIGI,SUMI 23879 3255 FORMAT('IDIGI = ',I8,' SUMI = ',F20.10) 23880 IF(IBUG2.EQ.'ON')CALL DPWRST('XXX','BUG ') 23881C 23882C THIRDLY, COMPUTE THE DECIMAL PART OF THE VALUE 23883C 23884 IDIGD=0 23885 SUMD=0.0 23886 ILOCP1=ILOC+1 23887 IF(ILOCP1.GT.ISTOP2)GOTO3350 23888 DO3300I=ILOCP1,ISTOP2 23889 IF(IANS(I).EQ.' ')GOTO3300 23890 IF(IANS(I).EQ.'0')GOTO3310 23891 IF(IANS(I).EQ.'1')GOTO3311 23892 IF(IANS(I).EQ.'2')GOTO3312 23893 IF(IANS(I).EQ.'3')GOTO3333 23894 IF(IANS(I).EQ.'4')GOTO3314 23895 IF(IANS(I).EQ.'5')GOTO3315 23896 IF(IANS(I).EQ.'6')GOTO3316 23897 IF(IANS(I).EQ.'7')GOTO3317 23898 IF(IANS(I).EQ.'8')GOTO3318 23899 IF(IANS(I).EQ.'9')GOTO3319 23900 IFLUNK='YES' 23901 GOTO3900 23902 3310 ITERM=0 23903 GOTO3325 23904 3311 ITERM=1 23905 GOTO3325 23906 3312 ITERM=2 23907 GOTO3325 23908 3333 ITERM=3 23909 GOTO3325 23910 3314 ITERM=4 23911 GOTO3325 23912 3315 ITERM=5 23913 GOTO3325 23914 3316 ITERM=6 23915 GOTO3325 23916 3317 ITERM=7 23917 GOTO3325 23918 3318 ITERM=8 23919 GOTO3325 23920 3319 ITERM=9 23921 GOTO3325 23922 3325 IDIGD=IDIGD+1 23923 TERM=ITERM 23924 SUMD=SUMD+TERM/(10.0**IDIGD) 23925 3300 CONTINUE 23926 3350 CONTINUE 23927 IF(IBUG2.EQ.'ON')WRITE(ICOUT,3355)IDIGD,SUMD 23928 3355 FORMAT('IDIGD = ',I8,' SUMD = ',F20.10) 23929 IF(IBUG2.EQ.'ON')CALL DPWRST('XXX','BUG ') 23930 IDIGT=IDIGI+IDIGD 23931 IF(IDIGT.LE.0)GOTO3900 23932 FLOAT=SUMI+SUMD 23933 IF(SIGN.LT.0.0)FLOAT=-FLOAT 23934 IF(AMIN.LE.FLOAT.AND.FLOAT.LE.AMAX)GOTO3000 23935 GOTO3900 23936C 23937 3900 CONTINUE 23938 IF(IFLUNK.EQ.'YES')ITYPE2='WORD' 23939 3000 CONTINUE 23940 GOTO9000 23941C 23942 9000 CONTINUE 23943 IF(IBUGA3.EQ.'ON')THEN 23944 WRITE(ICOUT,999) 23945 CALL DPWRST('XXX','BUG ') 23946 WRITE(ICOUT,9001) 23947 9001 FORMAT('AT THE END OF DPTY3B--') 23948 CALL DPWRST('XXX','BUG ') 23949 WRITE(ICOUT,9002)IFOUZ2,ISTAR2,ISTOP2 23950 9002 FORMAT('IFOUZ2, ISTAR2, ISTOP2 = ',A4,2I8) 23951 CALL DPWRST('XXX','BUG ') 23952 WRITE(ICOUT,9003)ITYPE2,IHOL,IHOL2,INTZ,FLOAT,IERROR 23953 9003 FORMAT('ITYPE2,IHOL,IHOL2,INTZ,FLOAT,IERROR = ',A4,2X,2A4,2X, 23954 1 I8,F15.7,2X,A4) 23955 CALL DPWRST('XXX','BUG ') 23956 ENDIF 23957C 23958 RETURN 23959 END 23960 SUBROUTINE DPTYP2(IANS,IWIDTH,IHNAME,IHNAM2,NUMNAM,MAXNAM,IBUGA3, 23961 1 IUSE,IVALUE,VALUE,IN, 23962 1 IFOUNZ,IBEGIN,IEND, 23963 1 ITYPE,IHOL,IHOL2,INT1,FLOAT1,IERRO1, 23964 1 NUMCL,NUMPL,NUMAOL,ITYW1L,ICAT1L,INLI1L,ITYW2L, 23965 1 NUMCR,NUMPR,NUMAOR,ITYW1R,ICAT1R,INLI1R,ITYW2R) 23966C 23967C PURPOSE--SCAN THE CHARACTER ARRAY IANS(.) 23968C AND EXTRACT INFORMATION 23969C REGARDING THE EXISTENCE AND LOACTION 23970C OF CERTAIN SUBSTRINGS USED IN THE LET COMMAND. 23971C THIS SUBROUTINE (DPTYP2) IS CALLED BY DPLET. 23972C OTHER SUBROUINTES NEEDED--DPTYP3 23973C MOST GENERAL FORM--LET X(I) = XXX FOR I = A B C 23974C --LET X(I) = XXX SUBSET XX A B 23975C INPUT ARGUMENTS--IANS = A HOLLERITH 1-CHARACTER-PER-WORD 23976C VARIABLE CONTAINING THE INPUT LINE 23977C TO BE EXAMINED. 23978C --IWIDTH = AN INTEGER VARIABLE CONTAINING 23979C THE (FULL) WIDTH OF THE INPUT LINE 23980C (THAT IS, THE NUMBER OF COLUMNS) 23981C OUTPUT ARGUMENTS--IFOUNZ = A HOLLERITH ARRAY 23982C WITH THE VALUE 'YES' 23983C IF THE SUBSTRING WAS FOUND; 23984C AND THE VALUE 'NO' 23985C IF THE SUBSTRING WAS NOT FOUND. 23986C --IBEGIN = AN INTEGER ARRAY WITH 23987C THE START COLUMN OF THE FOUND SUBSTRING 23988C --IEND = AN INTEGER ARRAY WITH 23989C THE STOP COLUMN OF THE FIUND SUBSTRING. 23990C --ITYPE = A HOLLERITH ARRAY 23991C WITH THE VALUE 'WORD' IF THE SUBSTRING CONTAINS 23992C ANY NON-NUMERIC (EXCLUDING BLANKS) CHARACTER; 23993C AND WITH THE VALUE 'NUMB' IF THE SUBSTRING CO 23994C ALL NUMERIC VALUES OR DECIMAL POINT OR + OR - 23995C (WITH INTERMITTENT BLANKS IGNORED). 23996C --IHOL = AN HOLLERITH ARRAY 23997C CONTAINING THE PACKED (FIRST 4 CHARACTERS) VERS 23998C OF THE FOUND SUBSTRING. 23999C --IHOL2 = AN HOLLERITH ARRAY 24000C CONTAINING THE PACKED (NEXT 4 CHARACTERS) VERSI 24001C OF THE FOUND SUBSTRING. 24002C --INT1 = AN INTEGER ARRAY 24003C CONTAINING THE INTEGER REPRESENTATION 24004C (IF POSSIBLE) OF THE FOUND SUBSTRING. 24005C --FLOAT1 = AN FLOATING POINT ARRAY 24006C CONTAINING THE FLOATING POINT REPRESENTATION 24007C (IF POSSIBLE) OF THE FOUND SUBSTRING. 24008C --IERRO1 = AN HOLLERITH ARRAY 24009C WITH THE VALUE 'NO' IF 24010C NO ERROR HAS BEEN ENCOUNTERED, 24011C AND THE VALUE 'YES' IF AN 24012C ERROR HAS BEEN ENCOUNTERED. 24013C --NUMCL = AN INTEGER VARIABLE CONTAINING THE 24014C NUMBER OF COMPONENTS 24015C ON THE LEFT SIDE 24016C (NOT COUNTING LET OR THE = SIGN). 24017C --NUMPL = AN INTEGER VARIABLE CONTAINING THE 24018C NUMBER OF PARENTHESES (LEFT + RIGHT) 24019C ON THE LEFT SIDE 24020C (NOT COUNTING LET OR THE = SIGN). 24021C --NUMAOL = AN INTEGER VARIABLE CONTAINING THE 24022C NUMBER OF ARITHMETIC OPERATIONS 24023C ON THE LEFT SIDE 24024C (NOT COUNTING LET OR THE = SIGN). 24025C --ITYW1L = A HOLLERITH VARIABLE CONTAINING THE 24026C TYPE ('WORD' VERSUS 'NUMB') 24027C FOR THE FIRST WORD 24028C (THAT IS, THE VARIABLE 24029C OR PARAMETER NAME) 24030C ON THE LEFT SIDE 24031C (NOT COUNTING LET OR THE = SIGN). 24032C --ITYW2L = A HOLLERITH VARIABLE CONTAINING THE 24033C TYPE ('WORD' VERSUS 'NUMB') 24034C FOR THE SECOND WORD 24035C (THAT IS, THE ARGUMENT) 24036C ON THE LEFT SIDE 24037C (NOT COUNTING LET OR THE = SIGN). 24038C --INLI1L = A HOLLERITH VARIABLE CONTAINING THE 24039C ANSWER ('YES' VERSUS 'NO') 24040C TO THE QUESTION AS TO WHETHER 24041C THE FIRST WORD ON THE LEFT 24042C (THAT IS, THE VARIABLE 24043C OR PARAMETER NAME) 24044C IS ALREADY EXISTENT IN THE 24045C INTERNAL DATAPLOT NAME LIST 24046C (NOT COUNTING LET OR THE = SIGN). 24047C --NUMCR = AN INTEGER VARIABLE CONTAINING THE 24048C NUMBER OF COMPONENTS 24049C ON THE RIGHT SIDE 24050C (NOT COUNTING THE = SIGN OR SUBSET OR FOR). 24051C --NUMPR = AN INTEGER VARIABLE CONTAINING THE 24052C NUMBER OF PARENTHESES (RIGHT + RIGHT) 24053C ON THE RIGHT SIDE 24054C (NOT COUNTING THE = SIGN OR SUBSET OR FOR). 24055C --NUMAOR = AN INTEGER VARIABLE CONTAINING THE 24056C NUMBER OF ARITHMETIC OPERATIONS 24057C ON THE RIGHT SIDE 24058C (NOT COUNTING THE = SIGN OR SUBSET OR FOR). 24059C --ITYW1R = A HOLLERITH VARIABLE CONTAINING THE 24060C TYPE ('WORD' VERSUS 'NUMB') 24061C FOR THE FIRST WORD 24062C (THAT IS, THE VARIABLE 24063C OR PARAMETER NAME) 24064C ON THE RIGHT SIDE 24065C (NOT COUNTING THE = SIGN OR SUBSET OR FOR). 24066C --ITYW2R = A HOLLERITH VARIABLE CONTAINING THE 24067C TYPE ('WORD' VERSUS 'NUMB') 24068C FOR THE SECOND WORD 24069C (THAT IS, THE ARGUMENT) 24070C ON THE RIGHT SIDE 24071C (NOT COUNTING THE = SIGN OR SUBSET OR FOR). 24072C --INLI1R = A HOLLERITH VARIABLE CONTAINING THE 24073C ANSWER ('YES' VERSUS 'NO') 24074C TO THE QUESTION AS TO WHETHER 24075C THE FIRST WORD ON THE RIGHT 24076C (THAT IS, THE VARIABLE 24077C OR PARAMETER NAME) 24078C IS ALREADY EXISTENT IN THE 24079C INTERNAL DATAPLOT NAME LIST 24080C (NOT COUNTING THE = SIGN OR SUBSET OR FOR). 24081C WRITTEN BY--JAMES J. FILLIBEN 24082C STATISTICAL ENGINEERING DIVISION 24083C INFORMATION TECHNOLOGY LABORATORY 24084C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 24085C GAITHERSBURG, MD 20899-8980 24086C PHONE--301-975-2855 24087C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 24088C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 24089C LANGUAGE--ANSI FORTRAN (1977) 24090C VERSION NUMBER--82/7 24091C ORIGINAL VERSION--MARCH 1978 24092C UPDATED --JUNE 1978. 24093C UPDATED --JULY 1978. 24094C UPDATED --JUNE 1981. 24095C UPDATED --JULY 1981. 24096C UPDATED --OCTOBER 1981. 24097C UPDATED --JANUARY 1982. 24098C UPDATED --MARCH 1982. 24099C UPDATED --MAY 1982. 24100C UPDATED --JANUARY 1983. 24101C UPDATED --DECEMBER 1988. ELIM. SPUR. ERROR MESS. FOR IFRINGE 24102C UPDATED --JANAURY 1989. IANS(IENDP) WITH IENDP = 0 (ALAN) 24103C UPDATED --NOVEMBER 1989. FIX IANS(IENDP=0) (NELSON) 24104C 24105C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 24106C 24107 CHARACTER*4 IANS 24108 CHARACTER*4 IHNAME 24109 CHARACTER*4 IHNAM2 24110 CHARACTER*4 IBUGA3 24111 CHARACTER*4 IUSE 24112 CHARACTER*4 IFOUNZ 24113 CHARACTER*4 ITYPE 24114 CHARACTER*4 IHOL 24115 CHARACTER*4 IHOL2 24116 CHARACTER*4 IERRO1 24117 CHARACTER*4 ITYW1L 24118 CHARACTER*4 ICAT1L 24119 CHARACTER*4 INLI1L 24120 CHARACTER*4 ITYW2L 24121 CHARACTER*4 ITYW1R 24122 CHARACTER*4 ICAT1R 24123 CHARACTER*4 INLI1R 24124 CHARACTER*4 ITYW2R 24125C 24126 CHARACTER*4 ISTRIN 24127 CHARACTER*4 ISTRI2 24128 CHARACTER*4 INEX 24129 CHARACTER*4 IVARL 24130 CHARACTER*4 IVARL2 24131 CHARACTER*4 IVARR 24132 CHARACTER*4 IVARR2 24133 CHARACTER*4 IQUAL 24134 CHARACTER*4 IHSTAT 24135 CHARACTER*4 IHSTA2 24136 CHARACTER*4 IHMAN 24137 CHARACTER*4 IHMAN2 24138 CHARACTER*4 IERROR 24139 CHARACTER*4 ISUBN1 24140 CHARACTER*4 ISUBN2 24141 CHARACTER*4 ISTEPN 24142C 24143C--------------------------------------------------------------------- 24144C 24145 DIMENSION IANS(*) 24146 DIMENSION IHNAME(*) 24147 DIMENSION IHNAM2(*) 24148C 24149 DIMENSION IUSE(*) 24150 DIMENSION IVALUE(*) 24151 DIMENSION VALUE(*) 24152 DIMENSION IN(*) 24153C 24154 DIMENSION IFOUNZ(*) 24155 DIMENSION IBEGIN(*) 24156 DIMENSION IEND(*) 24157 DIMENSION ITYPE(*) 24158 DIMENSION IHOL(*) 24159 DIMENSION IHOL2(*) 24160 DIMENSION INT1(*) 24161 DIMENSION FLOAT1(*) 24162 DIMENSION IERRO1(*) 24163C 24164 DIMENSION IHMAN(10) 24165 DIMENSION IHMAN2(10) 24166 DIMENSION IHSTAT(25) 24167 DIMENSION IHSTA2(25) 24168C 24169C-----COMMON---------------------------------------------------------- 24170C 24171 INCLUDE 'DPCOP2.INC' 24172C 24173C-----DATA STATEMENTS------------------------------------------------- 24174C 24175 DATA NUMMAN/8/ 24176C 24177 DATA IHMAN(1),IHMAN2(1)/'SORT',' '/ 24178 DATA IHMAN(2),IHMAN2(2)/'RANK',' '/ 24179 DATA IHMAN(3),IHMAN2(3)/'CODE',' '/ 24180 DATA IHMAN(4),IHMAN2(4)/'DIST','INCT'/ 24181 DATA IHMAN(5),IHMAN2(5)/'SEQU','ENTI'/ 24182 DATA IHMAN(6),IHMAN2(6)/'CUMU','LATI'/ 24183 DATA IHMAN(7),IHMAN2(7)/'CUMU','LATI'/ 24184 DATA IHMAN(8),IHMAN2(8)/'CUMU','LATI'/ 24185C 24186 DATA NUMSTA/22/ 24187C 24188 DATA IHSTAT(1),IHSTA2(1)/'SIZE',' '/ 24189 DATA IHSTAT(2),IHSTA2(2)/'NUMB','ER '/ 24190 DATA IHSTAT(3),IHSTA2(3)/'SUM ',' '/ 24191 DATA IHSTAT(4),IHSTA2(4)/'MIDR','ANGE'/ 24192 DATA IHSTAT(5),IHSTA2(5)/'MEAN',' '/ 24193 DATA IHSTAT(6),IHSTA2(6)/'AVER','AGE '/ 24194 DATA IHSTAT(7),IHSTA2(7)/'MIDM','EAN '/ 24195 DATA IHSTAT(8),IHSTA2(8)/'MEDI','AN '/ 24196 DATA IHSTAT(9),IHSTA2(9)/'STAN','ARD '/ 24197 DATA IHSTAT(10),IHSTA2(10)/'VARI','ANCE'/ 24198 DATA IHSTAT(11),IHSTA2(11)/'RELA','TIVE'/ 24199 DATA IHSTAT(12),IHSTA2(12)/'RANG','E '/ 24200 DATA IHSTAT(13),IHSTA2(13)/'MINI','MUM '/ 24201 DATA IHSTAT(14),IHSTA2(14)/'MAXI','MUM '/ 24202 DATA IHSTAT(15),IHSTA2(15)/'STAN','DARD'/ 24203 DATA IHSTAT(16),IHSTA2(16)/'SKEW','NESS'/ 24204 DATA IHSTAT(17),IHSTA2(17)/'STAN','DARD'/ 24205 DATA IHSTAT(18),IHSTA2(18)/'KURT','OSIS'/ 24206 DATA IHSTAT(19),IHSTA2(19)/'AUTO','CORR'/ 24207 DATA IHSTAT(20),IHSTA2(20)/'STAN','DARD'/ 24208 DATA IHSTAT(21),IHSTA2(21)/'CORR','ELAT'/ 24209 DATA IHSTAT(22),IHSTA2(22)/'RANK',' '/ 24210C 24211C-----START POINT----------------------------------------------------- 24212C 24213 ISUBN1='DPTY' 24214 ISUBN2='P2 ' 24215 IERROR='NO' 24216 IQUAL='UNKN' 24217C 24218 IMAXR=0 24219C 24220 IF(IBUGA3.EQ.'ON')THEN 24221 WRITE(ICOUT,999) 24222 999 FORMAT(1X) 24223 CALL DPWRST('XXX','BUG ') 24224 WRITE(ICOUT,51) 24225 51 FORMAT('***** AT THE BEGINNING OF DPTYP2--') 24226 CALL DPWRST('XXX','BUG ') 24227 WRITE(ICOUT,52)IBUGA3,IWIDTH,MAXNAM,IN(1) 24228 52 FORMAT('IBUGA3,IWIDTH,MAXNAM,IN(1) = ',A4,2X,2I5,I8) 24229 CALL DPWRST('XXX','BUG ') 24230 WRITE(ICOUT,54)(IANS(I),I=1,MIN(80,IWIDTH)) 24231 54 FORMAT('IANS(.) = ',80A1) 24232 CALL DPWRST('XXX','BUG ') 24233 ENDIF 24234C 24235C ****************************************************** 24236C ** STEP 1-- ** 24237C ** INITIALIZE THE OUTPUT PARAMETERS AND VARIABLES ** 24238C ****************************************************** 24239C 24240 ISTEPN='1' 24241 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 24242C 24243 DO100I=1,30 24244 IFOUNZ(I)='NO' 24245 IBEGIN(I)=-1 24246 IEND(I)=-1 24247 ITYPE(I)='9999' 24248 IHOL(I)='9999' 24249 IHOL2(I)='9999' 24250 INT1(I)=-999999 24251 FLOAT1(I)=-999999.0 24252 IERRO1(I)='NO' 24253 100 CONTINUE 24254C 24255 NUMCL=0 24256 NUMPL=0 24257 NUMAOL=0 24258 ITYW1L='9999' 24259 ICAT1L='9999' 24260 INLI1L='9999' 24261 ITYW2L='9999' 24262 NUMCR=0 24263 NUMPR=0 24264 NUMAOR=0 24265 ITYW1R='9999' 24266 ICAT1R='9999' 24267 INLI1R='9999' 24268 ITYW2R='9999' 24269C 24270C **************************************************************** 24271C ** STEP 2-- 24272C ** EXAMINE THE LEFT-HAND SIDE OF EXPRESSION. 24273C ** DETERMINE IF PARAMETER OR VARIABLE NAME TO LEFT OF = SIGN 24274C ** HAS PARENTHESES. 24275C ** IF IT HAS PARENTHESES, THIS MEANS THAT WE WILL BE 24276C ** DEFINING PART OF A VARIABLE. 24277C ** COMPONENT 1 = LET 24278C ** COMPONENT 2 = VARIABLE NAME 24279C ** COMPONENT 3 = ( (IF IT EXISTS) 24280C ** COMPONENT 4 = ARGUMENT (I.E., ROW OF TABLE) (IF IT EXISTS) 24281C ** COMPONENT 5 = ) (IF IT EXISTS) 24282C ** COMPONENT 6 = = 24283C **************************************************************** 24284C 24285C MOST GENERAL FORM--LET X(I) = XXX FOR I = A B C 24286C --LET X(I) = XXX SUBSET XX A B 24287C 24288 ISTEPN='2' 24289 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 24290C 24291C STEP 2.1--SEARCH FOR LET. 24292C 24293 ISTAR1=1 24294 ISTOP1=IWIDTH 24295 ISTRIN='LET' 24296 ISTRI2=' ' 24297 INEX='II' 24298 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24299 1 IFOUNZ(1),IBEGIN(1),IEND(1), 24300 1 ITYPE(1),IHOL(1),IHOL2(1),INT1(1),FLOAT1(1),IERRO1(1)) 24301 IF(IFOUNZ(1).EQ.'YES')GOTO2190 24302 CALL DPLETE(IANS,IWIDTH) 24303 IERROR='YES' 24304 GOTO9000 24305 2190 CONTINUE 24306C 24307C STEP 2.2--SEARCH FOR = SIGN. 24308C 24309 ISTAR1=IEND(1)+1 24310 ISTOP1=IWIDTH 24311 ISTRIN='=' 24312 ISTRI2=' ' 24313 INEX='II' 24314 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24315 1 IFOUNZ(6),IBEGIN(6),IEND(6), 24316 1 ITYPE(6),IHOL(6),IHOL2(6),INT1(6),FLOAT1(6),IERRO1(6)) 24317 IF(IFOUNZ(6).EQ.'YES')GOTO2290 24318 CALL DPLETE(IANS,IWIDTH) 24319 IERROR='YES' 24320 GOTO9000 24321 2290 CONTINUE 24322C 24323C STEP 2.3--SEARCH FOR LEFT-HAND SIDE (; 24324C SEARCH BETWEEN LET AND =. 24325C 24326 ISTAR1=IEND(1)+1 24327 ISTOP1=IBEGIN(6)-1 24328 ISTRIN='(' 24329 ISTRI2=' ' 24330 INEX='II' 24331 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24332 1 IFOUNZ(3),IBEGIN(3),IEND(3), 24333 1 ITYPE(3),IHOL(3),IHOL2(3),INT1(3),FLOAT1(3),IERRO1(3)) 24334 IF(IFOUNZ(3).EQ.'YES')GOTO2390 24335 GOTO2500 24336 2390 CONTINUE 24337C 24338C STEP 2.4--SEARCH FOR LEFT-HAND SIDE ); 24339C SEARCH BETWEEN ( AND =. 24340C 24341 ISTAR1=IEND(3)+1 24342 ISTOP1=IBEGIN(6)-1 24343 ISTRIN=')' 24344 ISTRI2=' ' 24345 INEX='II' 24346 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24347 1 IFOUNZ(5),IBEGIN(5),IEND(5), 24348 1 ITYPE(5),IHOL(5),IHOL2(5),INT1(5),FLOAT1(5),IERRO1(5)) 24349 IF(IFOUNZ(5).EQ.'YES')GOTO2490 24350 CALL DPLETE(IANS,IWIDTH) 24351 IERROR='YES' 24352 GOTO9000 24353 2490 CONTINUE 24354 GOTO2600 24355C 24356C STEP 2.5--IF NO LEFT-HAND SIDE PARENTHESES FOUND, 24357C EXTRACT VARIABLE NAME; 24358C SEARCH BETWEEN LET AND =. 24359C 24360 2500 CONTINUE 24361 ISTAR1=IEND(1)+1 24362 ISTOP1=IBEGIN(6) 24363 ISTRIN='!;=' 24364 ISTRI2=' ' 24365 INEX='IE' 24366 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24367 1 IFOUNZ(2),IBEGIN(2),IEND(2), 24368 1 ITYPE(2),IHOL(2),IHOL2(2),INT1(2),FLOAT1(2),IERRO1(2)) 24369 IF(IFOUNZ(2).EQ.'YES')GOTO2590 24370 CALL DPLETE(IANS,IWIDTH) 24371 IERROR='YES' 24372 GOTO9000 24373 2590 CONTINUE 24374 GOTO2800 24375C 24376C STEP 2.6--IF LEFT-HAND SIDE PARENTHESES FOUND, 24377C FIRST EXTRACT VARIABLE NAME; 24378C SEARCH BETWEEN LET AND (. 24379C 24380 2600 CONTINUE 24381 ISTAR1=IEND(1)+1 24382 ISTOP1=IBEGIN(3) 24383 ISTRIN='!;(' 24384 ISTRI2=' ' 24385 INEX='IE' 24386 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24387 1 IFOUNZ(2),IBEGIN(2),IEND(2), 24388 1 ITYPE(2),IHOL(2),IHOL2(2),INT1(2),FLOAT1(2),IERRO1(2)) 24389 IF(IFOUNZ(2).EQ.'YES')GOTO2690 24390 CALL DPLETE(IANS,IWIDTH) 24391 IERROR='YES' 24392 GOTO9000 24393 2690 CONTINUE 24394C 24395C STEP 2.7--ALSO IF LEFT-HAND SIDE PARENTHESES FOUND, 24396C SEARCH FOR LEFT-HAND SIDE ARGUMENT NAME OR VALUE; 24397C SEARCH BETWEEN ( AND ). 24398C 24399 ISTAR1=IEND(3) 24400 ISTOP1=IBEGIN(5) 24401 ISTRIN='(;)' 24402 ISTRI2=' ' 24403 INEX='EE' 24404 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24405 1 IFOUNZ(4),IBEGIN(4),IEND(4), 24406 1 ITYPE(4),IHOL(4),IHOL2(4),INT1(4),FLOAT1(4),IERRO1(4)) 24407 IF(IFOUNZ(4).EQ.'YES')GOTO2790 24408 CALL DPLETE(IANS,IWIDTH) 24409 IERROR='YES' 24410 GOTO9000 24411 2790 CONTINUE 24412 K=4 24413 IF(ITYPE(K).EQ.'WORD') 24414 1CALL DPCHEC(K,IHOL,IHOL2, 24415 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 24416 1INT1,FLOAT1,IBUGA3,IERROR) 24417C 24418 2800 CONTINUE 24419C 24420C ******************************************************* 24421C ** STEP 3-- ** 24422C ** EXAMINE THE RIGHT-HAND SIDE OF EXPRESSION. ** 24423C ** DETERMINE WHICH OF THE 3 CASES WE HAVE-- ** 24424C ** 1) LET X(I) = ** 24425C ** 2) LET X(I) = SUBSET XX A B ** 24426C ** 3) LET X(I) = FOR XX = A B C ** 24427C ** IF CASE 1 (THE NON-SUBSET AND NON-FOR CASE), ** 24428C ** SEARCH FOR COMPONENTS 7, 8, 9, AND 10-- ** 24429C ** COMPONENT 7 = VARIABLE NAME ** 24430C ** COMPONENT 8 = ( ** 24431C ** COMPONENT 9 = ARGUMENT (THAT IS, ROW OF TABLE) ** 24432C ** COMPONENT 10 = ) ** 24433C ** IF CASE 2 (THE SUBSET CASE), JUMP TO STEP 4 ** 24434C ** IF CASE 3 (THE FOR CASE), JUMP TO STEP 5. ** 24435C ******************************************************* 24436C 24437 ISTEPN='3' 24438 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 24439C 24440C STEP 3.1A--SEARCH FOR SUBSET. 24441C 24442 ISTAR1=IEND(6)+1 24443 ISTOP1=IWIDTH 24444 ISTRIN='SUBS' 24445 ISTRI2='ET ' 24446 INEX='II' 24447 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24448 1 IFOUNZ(11),IBEGIN(11),IEND(11), 24449 1 ITYPE(11),IHOL(11),IHOL2(11),INT1(11),FLOAT1(11),IERRO1(11)) 24450CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 1988 TO AVOID 24451CCCCC SPURIOUS ERROR MESSAGES WITH A LONG VARIABLE NAME LIKE SUBSETXX 24452CCCCC THE SECTION WAS CORRECTED ALSO IN JANUARY 1988 AND NOVEMBER 1989 24453 IENDP=IEND(11)+1 24454 IF(IENDP.LE.0)IFOUNZ(11)='NO' 24455 IF(IENDP.LE.0)GOTO3119 24456 IF(IFOUNZ(11).EQ.'YES'.AND. 24457 1 IENDP.LE.ISTOP1.AND. 24458 1 IANS(IENDP).NE.' ')IFOUNZ(11)='NO' 24459 IF(IFOUNZ(11).EQ.'YES')GOTO4000 24460 3119 CONTINUE 24461C 24462C STEP 3.1B--SEARCH FOR EXCEPT. 24463C 24464 ISTAR1=IEND(6)+1 24465 ISTOP1=IWIDTH 24466 ISTRIN='EXCE' 24467 ISTRI2='PT ' 24468 INEX='II' 24469 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24470 1 IFOUNZ(11),IBEGIN(11),IEND(11), 24471 1 ITYPE(11),IHOL(11),IHOL2(11),INT1(11),FLOAT1(11),IERRO1(11)) 24472CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 1988 TO AVOID 24473CCCCC SPURIOUS ERROR MESSAGES WITH A LONG VARIABLE NAME LIKE EXCEPTXX 24474CCCCC THE SECTION WAS CORRECTED ALSO IN JANUARY 1988 AND NOVEMBER 1989 24475 IENDP=IEND(11)+1 24476 IF(IENDP.LE.0)IFOUNZ(11)='NO' 24477 IF(IENDP.LE.0)GOTO3129 24478 IF(IFOUNZ(11).EQ.'YES'.AND. 24479 1 IENDP.LE.ISTOP1.AND. 24480 1 IANS(IENDP).NE.' ')IFOUNZ(11)='NO' 24481 IF(IFOUNZ(11).EQ.'YES')GOTO4000 24482 3129 CONTINUE 24483C 24484C STEP 3.1C--SEARCH FOR FOR. 24485C 24486 ISTAR1=IEND(6)+1 24487 ISTOP1=IWIDTH 24488 ISTRIN='FOR' 24489 ISTRI2=' ' 24490 INEX='II' 24491 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24492 1 IFOUNZ(21),IBEGIN(21),IEND(21), 24493 1 ITYPE(21),IHOL(21),IHOL2(21),INT1(21),FLOAT1(21),IERRO1(21)) 24494CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 1988 TO AVOID 24495CCCCC SPURIOUS ERROR MESSAGES WITH A LONG VARIABLE NAME LIKE FORTUNE 24496CCCCC THE SECTION WAS CORRECTED ALSO IN JANUARY 1988 AND NOVEMBER 1989 24497 IENDP=IEND(21)+1 24498 IF(IENDP.LE.0)IFOUNZ(21)='NO' 24499 IF(IENDP.LE.0)GOTO3139 24500 IF(IFOUNZ(21).EQ.'YES'.AND. 24501 1 IENDP.LE.ISTOP1.AND. 24502 1 IANS(IENDP).NE.' ')IFOUNZ(21)='NO' 24503 IF(IFOUNZ(21).EQ.'YES')GOTO5000 24504 3139 CONTINUE 24505C 24506C STEP 3.1D--SEARCH FOR IF. 24507C 24508 ISTAR1=IEND(6)+1 24509 ISTOP1=IWIDTH 24510 ISTRIN='IF ' 24511 ISTRI2=' ' 24512 INEX='II' 24513 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24514 1 IFOUNZ(11),IBEGIN(11),IEND(11), 24515 1 ITYPE(11),IHOL(11),IHOL2(11),INT1(11),FLOAT1(11),IERRO1(11)) 24516CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 1988 TO AVOID 24517CCCCC SPURIOUS ERROR MESSAGES WITH A LONG VARIABLE NAME LIKE IFRING 24518CCCCC THE SECTION WAS CORRECTED ALSO IN JANUARY 1988 AND NOVEMBER 1989 24519 IENDP=IEND(11)+1 24520 IF(IENDP.LE.0)IFOUNZ(11)='NO' 24521 IF(IENDP.LE.0)GOTO3149 24522 IF(IFOUNZ(11).EQ.'YES'.AND. 24523 1 IENDP.LE.ISTOP1.AND. 24524 1 IANS(IENDP).NE.' ')IFOUNZ(11)='NO' 24525 IF(IFOUNZ(11).EQ.'YES')GOTO4000 24526 3149 CONTINUE 24527C 24528C STEP 3.2--IF NEITHER SUBSET NOR FOR HAVE BEEN FOUND, 24529C SEARCH FOR RIGHT-HAND SIDE (; 24530C SEARCH BETWEEN = AND END OF LINE. 24531C 24532 ISTAR1=IEND(6)+1 24533 ISTOP1=IWIDTH 24534 ISTRIN='(' 24535 ISTRI2=' ' 24536 INEX='II' 24537 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24538 1 IFOUNZ(8),IBEGIN(8),IEND(8), 24539 1 ITYPE(8),IHOL(8),IHOL2(8),INT1(8),FLOAT1(8),IERRO1(8)) 24540 IF(IFOUNZ(8).EQ.'YES')GOTO3290 24541 GOTO3400 24542 3290 CONTINUE 24543C 24544C STEP 3.3--IF NEITHER SUBSET NOR FOR HAVE BEEN FOUND, 24545C SEARCH FOR RIGHT-HAND SIDE ); 24546C SEARCH BETWEEN ( AND END OF LINE. 24547C 24548 ISTAR1=IEND(8)+1 24549 ISTOP1=IWIDTH 24550 ISTRIN=')' 24551 ISTRI2=' ' 24552 INEX='II' 24553 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24554 1 IFOUNZ(10),IBEGIN(10),IEND(10), 24555 1 ITYPE(10),IHOL(10),IHOL2(10),INT1(10),FLOAT1(10),IERRO1(10)) 24556 IF(IFOUNZ(10).EQ.'YES')GOTO3390 24557 CALL DPLETE(IANS,IWIDTH) 24558 IERROR='YES' 24559 GOTO9000 24560 3390 CONTINUE 24561 GOTO3500 24562C 24563C STEP 3.4--IF NEITHER SUBSET NOR FOR HAVE BEEN FOUND, 24564C IF NO RIGHT-HAND SIDE PARENTHESES FOUND, 24565C EXTRACT VARIABLE NAME OR VALUE; 24566C SEARCH BETWEEN = AND END OF LINE. 24567C ALSO, TO HANDLE THE COLUMN NAMING CASE 24568C (E.G., LET X = COLUMN 1), 24569C CHECK TO SEE IF ANOTHER ITEM 24570C FOLLOWS THE VARIABLE NAME OR VALUE. 24571C AND FURTERMORE, TO HANDLE THE DATA GENERATION CASE 24572C (E.G., LET X = 1 1 10), 24573C CHECK TO SEE OF 2 ITEMS 24574C FOLLOW THE FIRST VALUE. 24575C 24576 3400 CONTINUE 24577 ISTAR1=IEND(6)+1 24578 ISTOP1=IWIDTH 24579 ISTRIN='!;:' 24580 ISTRI2=' ' 24581 INEX='IE' 24582 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24583 1 IFOUNZ(7),IBEGIN(7),IEND(7), 24584 1 ITYPE(7),IHOL(7),IHOL2(7),INT1(7),FLOAT1(7),IERRO1(7)) 24585 IF(IFOUNZ(7).EQ.'YES')GOTO3410 24586 CALL DPLETE(IANS,IWIDTH) 24587 IERROR='YES' 24588 GOTO9000 24589C 24590 3410 CONTINUE 24591 ISTAR1=IEND(7)+1 24592 ISTOP1=IWIDTH 24593 ISTRIN='!;:' 24594 ISTRI2=' ' 24595 INEX='IE' 24596 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24597 1 IFOUNZ(8),IBEGIN(8),IEND(8), 24598 1 ITYPE(8),IHOL(8),IHOL2(8),INT1(8),FLOAT1(8),IERRO1(8)) 24599 IF(IFOUNZ(8).EQ.'YES')GOTO3420 24600 GOTO3900 24601C 24602 3420 CONTINUE 24603 ISTAR1=IEND(8)+1 24604 ISTOP1=IWIDTH 24605 ISTRIN='!;:' 24606 ISTRI2=' ' 24607 INEX='IE' 24608 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24609 1 IFOUNZ(9),IBEGIN(9),IEND(9), 24610 1 ITYPE(9),IHOL(9),IHOL2(9),INT1(9),FLOAT1(9),IERRO1(9)) 24611 GOTO3900 24612C 24613C STEP 3.5--IF NEITHER SUBSET NOR FOR HAVE BEEN FOUND, 24614C IF RIGHT-HAND SIDE PARENTHESES FOUND, 24615C FIRST EXTRACT VARIABLE NAME; 24616C SEARCH BETWEEN = AND (. 24617C 24618 3500 CONTINUE 24619 ISTAR1=IEND(6)+1 24620 ISTOP1=IBEGIN(8) 24621 ISTRIN='!;(' 24622 ISTRI2=' ' 24623 INEX='IE' 24624 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24625 1 IFOUNZ(7),IBEGIN(7),IEND(7), 24626 1 ITYPE(7),IHOL(7),IHOL2(7),INT1(7),FLOAT1(7),IERRO1(7)) 24627 IF(IFOUNZ(7).EQ.'YES')GOTO3590 24628 CALL DPLETE(IANS,IWIDTH) 24629 IERROR='YES' 24630 GOTO9000 24631 3590 CONTINUE 24632C 24633C STEP 3.6--IF NEITHER SUBSET NOR FOR HAVE BEEN FOUND, 24634C ALSO IF RIGHT-HAND SIDE PARENTHESES FOUND, 24635C SEARCH FOR RIGHT-HAND SIDE ARGUMENT NAME OR VALUE; 24636C SEARCH BETWEEN ( AND ). 24637C 24638 ISTAR1=IEND(8) 24639 ISTOP1=IBEGIN(10) 24640 ISTRIN='(;)' 24641 ISTRI2=' ' 24642 INEX='EE' 24643 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24644 1 IFOUNZ(9),IBEGIN(9),IEND(9), 24645 1 ITYPE(9),IHOL(9),IHOL2(9),INT1(9),FLOAT1(9),IERRO1(9)) 24646 IF(IFOUNZ(9).EQ.'YES')GOTO3690 24647 CALL DPLETE(IANS,IWIDTH) 24648 IERROR='YES' 24649 GOTO9000 24650 3690 CONTINUE 24651 K=9 24652 IF(ITYPE(K).EQ.'WORD') 24653 1CALL DPCHEC(K,IHOL,IHOL2, 24654 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 24655 1INT1,FLOAT1,IBUGA3,IERROR) 24656C 24657 3900 CONTINUE 24658 GOTO6000 24659C 24660C ********************************************************** 24661C ** STEP 4-- ** 24662C ** FOR THE CASE WHEN HAVE LET X(I) = ** 24663C ** EXAMINE THE RIGHT-HAND SIDE FOR SUBSET XX A B ** 24664C ** COMPONENT 7 = VARIABLE NAME ** 24665C ** COMPONENT 8 = ( ** 24666C ** COMPONENT 9 = ARGUMENT (THAT IS, ROW OF TABLE) ** 24667C ** COMPONENT 10 = ) ** 24668C ** COMPONENT 11 = SUBSET ** 24669C ** COMPONENT 12 = LOWER LIMIT OF SUBSET ** 24670C ** COMPONENT 13 = UPPER LIMIT (IF EXISTS) OF SUBSET ** 24671C ********************************************************** 24672C 24673 4000 CONTINUE 24674 ISTEPN='4' 24675 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 24676C 24677C STEP 4.2--IF SUBSET HAS BEEN FOUND, 24678C SEARCH FOR RIGHT-HAND SIDE (; 24679C SEARCH BETWEEN = AND SUBSET. 24680C 24681 ISTAR1=IEND(6)+1 24682 ISTOP1=IBEGIN(11)-1 24683 ISTRIN='(' 24684 ISTRI2=' ' 24685 INEX='II' 24686 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24687 1 IFOUNZ(8),IBEGIN(8),IEND(8), 24688 1 ITYPE(8),IHOL(8),IHOL2(8),INT1(8),FLOAT1(8),IERRO1(8)) 24689 IF(IFOUNZ(8).EQ.'YES')GOTO4090 24690 GOTO4400 24691 4090 CONTINUE 24692C 24693C STEP 4.3--IF SUBSET HAS BEEN FOUND, 24694C SEARCH FOR RIGHT-HAND SIDE ); 24695C SEARCH BETWEEN ( AND SUBSET. 24696C 24697 ISTAR1=IEND(8)+1 24698 ISTOP1=IBEGIN(11)-1 24699 ISTRIN=')' 24700 ISTRI2=' ' 24701 INEX='II' 24702 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24703 1 IFOUNZ(10),IBEGIN(10),IEND(10), 24704 1 ITYPE(10),IHOL(10),IHOL2(10),INT1(10),FLOAT1(10),IERRO1(10)) 24705 IF(IFOUNZ(10).EQ.'YES')GOTO4390 24706 CALL DPLETE(IANS,IWIDTH) 24707 IERROR='YES' 24708 GOTO9000 24709 4390 CONTINUE 24710 GOTO4500 24711C 24712C STEP 4.4--IF SUBSET HAS BEEN FOUND, 24713C IF NO RIGHT-HAND SIDE PARENTHESES FOUND, 24714C EXTRACT VARIABLE NAME OR VALUE; 24715C SEARCH BETWEEN = AND SUBSET. 24716C 24717 4400 CONTINUE 24718 ISTAR1=IEND(6)+1 24719 ISTOP1=IBEGIN(11) 24720 ISTRIN='!;:' 24721 ISTRI2=' ' 24722 INEX='IE' 24723 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24724 1 IFOUNZ(7),IBEGIN(7),IEND(7), 24725 1 ITYPE(7),IHOL(7),IHOL2(7),INT1(7),FLOAT1(7),IERRO1(7)) 24726 IF(IFOUNZ(7).EQ.'YES')GOTO4490 24727 CALL DPLETE(IANS,IWIDTH) 24728 IERROR='YES' 24729 GOTO9000 24730 4490 CONTINUE 24731 GOTO4700 24732C 24733C STEP 4.5--IF SUBSET HAS BEEN FOUND, 24734C IF RIGHT-HAND SIDE PARENTHESES FOUND, 24735C FIRST EXTRACT VARIABLE NAME; 24736C SEARCH BETWEEN = AND (. 24737C 24738 4500 CONTINUE 24739 ISTAR1=IEND(6)+1 24740 ISTOP1=IBEGIN(8) 24741 ISTRIN='!;(' 24742 ISTRI2=' ' 24743 INEX='IE' 24744 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24745 1 IFOUNZ(7),IBEGIN(7),IEND(7), 24746 1 ITYPE(7),IHOL(7),IHOL2(7),INT1(7),FLOAT1(7),IERRO1(7)) 24747 IF(IFOUNZ(7).EQ.'YES')GOTO4590 24748 CALL DPLETE(IANS,IWIDTH) 24749 IERROR='YES' 24750 GOTO9000 24751 4590 CONTINUE 24752C 24753C STEP 4.6--IF SUBSET HAS BEEN FOUND, 24754C ALSO IF RIGHT-HAND SIDE PARENTHESES FOUND, 24755C SEARCH FOR RIGHT-HAND SIDE ARGUMENT NAME OR VALUE; 24756C SEARCH BETWEEN ( AND ). 24757C 24758 ISTAR1=IEND(8) 24759 ISTOP1=IBEGIN(10) 24760 ISTRIN='(;)' 24761 ISTRI2=' ' 24762 INEX='EE' 24763 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24764 1 IFOUNZ(9),IBEGIN(9),IEND(9), 24765 1 ITYPE(9),IHOL(9),IHOL2(9),INT1(9),FLOAT1(9),IERRO1(9)) 24766 IF(IFOUNZ(9).EQ.'YES')GOTO4690 24767 CALL DPLETE(IANS,IWIDTH) 24768 IERROR='YES' 24769 GOTO9000 24770 4690 CONTINUE 24771 K=9 24772 IF(ITYPE(K).EQ.'WORD') 24773 1CALL DPCHEC(K,IHOL,IHOL2, 24774 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 24775 1INT1,FLOAT1,IBUGA3,IERROR) 24776C 24777C STEP 4.7--IF SUBSET HAS BEEN FOUND, 24778C SEARCH FOR VARIABLE NAME AFTER SUBSET; 24779C SEARCH BETWEEN SUBSET AND THE END OF THE LINE. 24780C 24781 4700 CONTINUE 24782 ISTAR1=IEND(11)+1 24783 ISTOP1=IWIDTH 24784 ISTRIN='!;:' 24785 ISTRI2=' ' 24786 INEX='IE' 24787 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24788 1 IFOUNZ(12),IBEGIN(12),IEND(12), 24789 1 ITYPE(12),IHOL(12),IHOL2(12),INT1(12),FLOAT1(12),IERRO1(12)) 24790 IF(IFOUNZ(12).EQ.'YES')GOTO4790 24791 CALL DPLETE(IANS,IWIDTH) 24792 IERROR='YES' 24793 GOTO9000 24794 4790 CONTINUE 24795C 24796C STEP 4.8--IF SUBSET HAS BEEN FOUND, 24797C SEARCH FOR LOWER LIMIT VALUE AFTER SUBSET XXX 24798C SEARCH BETWEEN VARIABLE NAME AND THE END OF THE LINE. 24799C 24800 ISTAR1=IEND(12)+1 24801 ISTOP1=IWIDTH 24802 ISTRIN='!;:' 24803 ISTRI2=' ' 24804 INEX='IE' 24805 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24806 1 IFOUNZ(13),IBEGIN(13),IEND(13), 24807 1 ITYPE(13),IHOL(13),IHOL2(13),INT1(13),FLOAT1(13),IERRO1(13)) 24808 IF(IFOUNZ(13).EQ.'YES')GOTO4890 24809 CALL DPLETE(IANS,IWIDTH) 24810 IERROR='YES' 24811 GOTO9000 24812 4890 CONTINUE 24813C 24814C STEP 4.9--IF SUBSET HAS BEEN FOUND, 24815C SEARCH FOR UPPER LIMIT (IF EXISTENT) AFTER SUBSET XXX 24816C SEARCH BETWEEN LOWER LIMIT AND THE END OF THE LINE. 24817C 24818 ISTAR1=IEND(13)+1 24819 ISTOP1=IWIDTH 24820 ISTRIN='!;:' 24821 ISTRI2=' ' 24822 INEX='IE' 24823 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24824 1 IFOUNZ(14),IBEGIN(14),IEND(14), 24825 1 ITYPE(14),IHOL(14),IHOL2(14),INT1(14),FLOAT1(14),IERRO1(14)) 24826 GOTO6000 24827C 24828C ******************************************************* 24829C ** STEP 5-- ** 24830C ** FOR THE CASE WHEN HAVE LET X(I) = ** 24831C ** EXAMINE THE RIGHT-HAND SIDE FOR FOR I = A B C* 24832C ** COMPONENT 7 = VARIABLE NAME ** 24833C ** COMPONENT 8 = ( ** 24834C ** COMPONENT 9 = ARGUMENT (THAT IS, ROW OF TABLE) ** 24835C ** COMPONENT 10 = ) ** 24836C ** COMPONENT 21 = FOR ** 24837C ** COMPONENT 22 = = ** 24838C ** COMPONENT 23 = START VALUE FOR DUMMY INDEX ** 24839C ** COMPONENT 24 = INCREMENT VALUE FOR DUMMY INDEX ** 24840C ** COMPONENT 25 = STOP VALUE FOR SUMMY INDEX ** 24841C ******************************************************* 24842C 24843 5000 CONTINUE 24844 ISTEPN='5' 24845 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 24846C 24847C STEP 5.2--IF FOR HAS BEEN FOUND, 24848C SEARCH FOR RIGHT-HAND SIDE (; 24849C SEARCH BETWEEN = AND FOR. 24850C 24851 ISTAR1=IEND(6)+1 24852 ISTOP1=IBEGIN(21)-1 24853 ISTRIN='(' 24854 ISTRI2=' ' 24855 INEX='II' 24856 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24857 1 IFOUNZ(8),IBEGIN(8),IEND(8), 24858 1 ITYPE(8),IHOL(8),IHOL2(8),INT1(8),FLOAT1(8),IERRO1(8)) 24859 IF(IFOUNZ(8).EQ.'YES')GOTO5290 24860 GOTO5400 24861 5290 CONTINUE 24862C 24863C STEP 5.3--IF FOR HAS BEEN FOUND, 24864C SEARCH FOR RIGHT-HAND SIDE ); 24865C SEARCH BETWEEN ( AND FOR. 24866C 24867 ISTAR1=IEND(8)+1 24868 ISTOP1=IBEGIN(21)-1 24869 ISTRIN=')' 24870 ISTRI2=' ' 24871 INEX='II' 24872 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24873 1 IFOUNZ(10),IBEGIN(10),IEND(10), 24874 1 ITYPE(10),IHOL(10),IHOL2(10),INT1(10),FLOAT1(10),IERRO1(10)) 24875 IF(IFOUNZ(10).EQ.'YES')GOTO5390 24876 CALL DPLETE(IANS,IWIDTH) 24877 IERROR='YES' 24878 GOTO9000 24879 5390 CONTINUE 24880 GOTO5500 24881C 24882C STEP 5.4--IF FOR HAS BEEN FOUND, 24883C IF NO RIGHT-HAND SIDE PARENTHESES FOUND, 24884C EXTRACT VARIABLE NAME OR VALUE; 24885C SEARCH BETWEEN = AND FOR. 24886C 24887 5400 CONTINUE 24888 ISTAR1=IEND(6)+1 24889 ISTOP1=IBEGIN(21) 24890 ISTRIN='!;:' 24891 ISTRI2=' ' 24892 INEX='IE' 24893 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24894 1 IFOUNZ(7),IBEGIN(7),IEND(7), 24895 1 ITYPE(7),IHOL(7),IHOL2(7),INT1(7),FLOAT1(7),IERRO1(7)) 24896 IF(IFOUNZ(7).EQ.'YES')GOTO5490 24897 CALL DPLETE(IANS,IWIDTH) 24898 IERROR='YES' 24899 GOTO9000 24900 5490 CONTINUE 24901 GOTO5700 24902C 24903C STEP 5.5--IF FOR HAS BEEN FOUND, 24904C IF RIGHT-HAND SIDE PARENTHESES FOUND, 24905C FIRST EXTRACT VARIABLE NAME; 24906C SEARCH BETWEEN = AND (. 24907C 24908 5500 CONTINUE 24909 ISTAR1=IEND(6)+1 24910 ISTOP1=IBEGIN(8) 24911 ISTRIN='!;(' 24912 ISTRI2=' ' 24913 INEX='IE' 24914 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24915 1 IFOUNZ(7),IBEGIN(7),IEND(7), 24916 1 ITYPE(7),IHOL(7),IHOL2(7),INT1(7),FLOAT1(7),IERRO1(7)) 24917 IF(IFOUNZ(7).EQ.'YES')GOTO5590 24918 CALL DPLETE(IANS,IWIDTH) 24919 IERROR='YES' 24920 GOTO9000 24921 5590 CONTINUE 24922C 24923C STEP 5.6--IF FOR HAS BEEN FOUND, 24924C ALSO IF RIGHT-HAND SIDE PARENTHESES FOUND, 24925C SEARCH FOR RIGHT-HAND SIDE ARGUMENT NAME OR VALUE; 24926C SEARCH BETWEEN ( AND ). 24927C 24928 ISTAR1=IEND(8) 24929 ISTOP1=IBEGIN(10) 24930 ISTRIN='(;)' 24931 ISTRI2=' ' 24932 INEX='EE' 24933 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24934 1 IFOUNZ(9),IBEGIN(9),IEND(9), 24935 1 ITYPE(9),IHOL(9),IHOL2(9),INT1(9),FLOAT1(9),IERRO1(9)) 24936 IF(IFOUNZ(9).EQ.'YES')GOTO5690 24937 CALL DPLETE(IANS,IWIDTH) 24938 IERROR='YES' 24939 GOTO9000 24940 5690 CONTINUE 24941 K=9 24942 IF(ITYPE(K).EQ.'WORD') 24943 1CALL DPCHEC(K,IHOL,IHOL2, 24944 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 24945 1INT1,FLOAT1,IBUGA3,IERROR) 24946C 24947C STEP 5.7--IF FOR HAS BEEN FOUND, 24948C SEARCH FOR VARIABLE NAME AFTER FOR; 24949C SEARCH BETWEEN FOR AND THE END OF THE LINE. 24950C 24951 5700 CONTINUE 24952 ISTAR1=IEND(21)+1 24953 ISTOP1=IWIDTH 24954 ISTRIN='!;:' 24955 ISTRI2=' ' 24956 INEX='IE' 24957 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24958 1 IFOUNZ(22),IBEGIN(22),IEND(22), 24959 1 ITYPE(22),IHOL(22),IHOL2(22),INT1(22),FLOAT1(22),IERRO1(22)) 24960 IF(IFOUNZ(22).EQ.'YES')GOTO5790 24961 CALL DPLETE(IANS,IWIDTH) 24962 IERROR='YES' 24963 GOTO9000 24964 5790 CONTINUE 24965C 24966C STEP 5.8--IF FOR HAS BEEN FOUND, 24967C SEARCH FOR = SIGN AFTER FOR XXX 24968C SEARCH BETWEEN VARIABLE NAME AND END OF LINE. 24969C 24970 ISTAR1=IEND(22)+1 24971 ISTOP1=IWIDTH 24972 ISTRIN='=' 24973 ISTRI2=' ' 24974 INEX='II' 24975 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24976 1 IFOUNZ(23),IBEGIN(23),IEND(23), 24977 1 ITYPE(23),IHOL(23),IHOL2(23),INT1(23),FLOAT1(23),IERRO1(23)) 24978 IF(IFOUNZ(23).EQ.'YES')GOTO5890 24979 CALL DPLETE(IANS,IWIDTH) 24980 IERROR='YES' 24981 GOTO9000 24982 5890 CONTINUE 24983C 24984C STEP 5.9--IF FOR HAS BEEN FOUND, 24985C SEARCH FOR START VALUE AFTER FOR XXX = 24986C SEARCH BETWEEN = AND THE END OF THE LINE. 24987C 24988 ISTAR1=IEND(23)+1 24989 ISTOP1=IWIDTH 24990 ISTRIN='!;:' 24991 ISTRI2=' ' 24992 INEX='IE' 24993 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 24994 1 IFOUNZ(24),IBEGIN(24),IEND(24), 24995 1 ITYPE(24),IHOL(24),IHOL2(24),INT1(24),FLOAT1(24),IERRO1(24)) 24996 IF(IFOUNZ(24).EQ.'YES')GOTO5990 24997 CALL DPLETE(IANS,IWIDTH) 24998 IERROR='YES' 24999 GOTO9000 25000 5990 CONTINUE 25001C 25002C STEP 5.10--IF FOR HAS BEEN FOUND, 25003C SEARCH FOR INCREMENT VALUE AFTER FOR XXX = 25004C SEARCH BETWEEN START VALUE AND THE END OF THE LINE. 25005C 25006 ISTAR1=IEND(24)+1 25007 ISTOP1=IWIDTH 25008 ISTRIN='!;:' 25009 ISTRI2=' ' 25010 INEX='IE' 25011 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 25012 1 IFOUNZ(25),IBEGIN(25),IEND(25), 25013 1 ITYPE(25),IHOL(25),IHOL2(25),INT1(25),FLOAT1(25),IERRO1(25)) 25014 IF(IFOUNZ(25).EQ.'YES')GOTO5930 25015 CALL DPLETE(IANS,IWIDTH) 25016 IERROR='YES' 25017 GOTO9000 25018 5930 CONTINUE 25019C 25020C STEP 5.11--IF FOR HAS BEEN FOUND, 25021C SEARCH FOR STOP VALUE AFTER FOR XXX = 25022C SEARCH BETWEEN INCREMENT VALUE AND THE END OF THE LINE. 25023C 25024 ISTAR1=IEND(25)+1 25025 ISTOP1=IWIDTH 25026 ISTRIN='!;:' 25027 ISTRI2=' ' 25028 INEX='IE' 25029 CALL DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGA3, 25030 1 IFOUNZ(26),IBEGIN(26),IEND(26), 25031 1 ITYPE(26),IHOL(26),IHOL2(26),INT1(26),FLOAT1(26),IERRO1(26)) 25032 IF(IFOUNZ(26).EQ.'YES')GOTO5950 25033 CALL DPLETE(IANS,IWIDTH) 25034 IERROR='YES' 25035 GOTO9000 25036 5950 CONTINUE 25037 GOTO6000 25038C 25039C ************************************************ 25040C ** STEP 6-- ** 25041C ** DETERMINE VARIOUS SUMMARY VARIABLES ** 25042C ** FOR THE LEFT SIDE ** 25043C ** OF THE COMMAND LINE ** 25044C ** WHICH WILL BE HELPFUL BACK IN DPLET ** 25045C ** FOR BRANCHING TO THE CORRECT ** 25046C ** TYPE OF OPERATION. ** 25047C ** NOTE THAT THE LEFT SIDE ** 25048C ** WILL BE FROM LET ** 25049C ** TO THE = SIGN ** 25050C ** BUT WILL NOT INCLUDE EITHER. ** 25051C ************************************************ 25052C 25053 6000 CONTINUE 25054 ISTEPN='6' 25055 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 25056C 25057C STEP 6.0-- 25058C DETERMINE THE LIMITS OF THE LEFT SIDE 25059C 25060 IMINL=0 25061 IF(IFOUNZ(1).EQ.'YES')IMINL=IEND(1)+1 25062C 25063 IMAXL=0 25064 IF(IFOUNZ(6).EQ.'YES')IMAXL=IBEGIN(6)-1 25065C 25066 IF(IMINL.LE.0)GOTO6900 25067 IF(IMAXL.LE.0)GOTO6900 25068 IF(IMINL.GT.IMAXL)GOTO6900 25069C 25070C STEP 6.1-- 25071C DETERMINE THE NUMBER OF COMPONENTS ON THE LEFT. 25072C A COMPONET HERE = A WORD OR A PARENTHESIS. 25073C 25074 ISUM=0 25075 IMIN=2 25076 IMAX=5 25077 DO6100I=IMIN,IMAX 25078 IF(IFOUNZ(I).EQ.'YES')ISUM=ISUM+1 25079 6100 CONTINUE 25080 NUMCL=ISUM 25081C 25082C STEP 6.2-- 25083C DETERMINE THE NUMBER OF PARENTHESES (LEFT + RIGHT). 25084C 25085 ISUM=0 25086 IMIN=IMINL 25087 IMAX=IMAXL 25088 DO6200I=IMIN,IMAX 25089 IF(IANS(I).EQ.'('.OR.IANS(I).EQ.')')ISUM=ISUM+1 25090 6200 CONTINUE 25091 NUMPL=ISUM 25092C 25093C STEP 6.3-- 25094C DETERMINE THE NUMBER OF ARITHMETIC OPERATIONS 25095C + - * / ON THE LEFT 25096C (IT SHOULD BE 0). 25097C NOTE THAT THE ARITHMETIC OPERATION ** 25098C WILL BE LUMPED IN WITH * . 25099C 25100 ISUM=0 25101 IMIN=IMINL 25102 IMAX=IMAXL 25103 DO6300I=IMIN,IMAX 25104 IF(IANS(I).EQ.'+'.OR.IANS(I).EQ.'-'. 25105 1OR.IANS(I).EQ.'*'.OR.IANS(I).EQ.'/')ISUM=ISUM+1 25106 6300 CONTINUE 25107 NUMAOL=ISUM 25108C 25109C STEP 6.4-- 25110C DETERMINE THE TYPE ('NUMB' OR 'WORD') 25111C FOR THE FIRST WORD ON THE LEFT. 25112C THIS SHOULD BE THE VARIABLE OR PARAMETER 25113C DESIGNATION, 25114C AND IT SHOULD BE A 'WORD'. 25115C 25116 ITYW1L=ITYPE(2) 25117C 25118C STEP 6.5-- 25119C DETERMINE IF FIRST WORD ON THE LEFT 25120C IS ALREADY IN THE NAME LIST OR NOT. 25121C 25122 INLI1L='NO' 25123 IVARL=IHOL(2) 25124 IVARL2=IHOL2(2) 25125 DO6500I=1,NUMNAM 25126 IF(IVARL.EQ.IHNAME(I).AND.IVARL2.EQ.IHNAM2(I))INLI1L='YES' 25127 6500 CONTINUE 25128C 25129C STEP 6.6-- 25130C DETERMINE IF FIRST WORD ON THE LEFT 25131C IS IN THE VARIABLE/PARAMETER NAME LIST, OR 25132C IS A COLUMN NAMING (I.E., THE WORD 'COLU' OR 'COL', OR 25133C IS A DATA MANIPULATION FUNCTION, OR 25134C IS A STATISTICAL CALCULATION FUNCTION 25135C (SEARCH IS DONE IN THAT ORDER). 25136C 25137C 25138 ICAT1L='NONE' 25139 IVARL=IHOL(2) 25140 IVARL2=IHOL2(2) 25141C 25142 IF(INLI1L.EQ.'YES'.AND.IVARL.NE.'COLU')GOTO6615 25143 IF(INLI1L.EQ.'YES'.AND.IVARL.NE.'COL ')GOTO6615 25144 IF(INLI1L.EQ.'YES'.AND.IVARL.EQ.'COLU'.AND.IVARL2.EQ.'MN '.AND. 25145 1IFOUNZ(3).EQ.'NO')GOTO6615 25146 IF(INLI1L.EQ.'YES'.AND.IVARL.EQ.'COL '.AND.IVARL2.EQ.' '.AND. 25147 1IFOUNZ(3).EQ.'NO')GOTO6615 25148 IF(INLI1L.EQ.'YES'.AND.IVARL.EQ.'COLU'.AND.IVARL2.EQ.'MN '.AND. 25149 1IFOUNZ(3).EQ.'YES'.AND.ITYPE(3).NE.'NUMB')GOTO6615 25150 IF(INLI1L.EQ.'YES'.AND.IVARL.EQ.'COL '.AND.IVARL2.EQ.' '.AND. 25151 1IFOUNZ(3).EQ.'YES'.AND.ITYPE(3).NE.'NUMB')GOTO6615 25152 GOTO6620 25153 6615 CONTINUE 25154 ICAT1L='VARP' 25155 GOTO6690 25156C 25157 6620 CONTINUE 25158 IF(IVARL.EQ.'COLU'.AND.IVARL2.EQ.'MN '.AND. 25159 1IFOUNZ(3).EQ.'YES'.AND.ITYPE(3).EQ.'NUMB')GOTO6625 25160 IF(IVARL.EQ.'COL '.AND.IVARL2.EQ.' '.AND. 25161 1IFOUNZ(3).EQ.'YES'.AND.ITYPE(3).EQ.'NUMB')GOTO6625 25162 GOTO6630 25163 6625 CONTINUE 25164 ICAT1L='COL' 25165 GOTO6690 25166C 25167 6630 CONTINUE 25168 DO6632I=1,NUMMAN 25169 IF(IVARL.EQ.IHMAN(I).AND.IVARL2.EQ.IHMAN2(I))GOTO6635 25170 6632 CONTINUE 25171 GOTO6640 25172 6635 CONTINUE 25173 ICAT1L='MANI' 25174 GOTO6690 25175C 25176 6640 CONTINUE 25177 DO6642I=1,NUMSTA 25178 IF(IVARL.EQ.IHSTAT(I).AND.IVARL2.EQ.IHSTA2(I))GOTO6645 25179 6642 CONTINUE 25180 GOTO6690 25181 6645 CONTINUE 25182 ICAT1L='STAT' 25183 GOTO6690 25184C 25185 6690 CONTINUE 25186C 25187C STEP 6.7-- 25188C DETERMINE THE TYPE ('NUMB' OR 'WORD') 25189C FOR THE SECOND WORD 25190C (AS OPPOSED TO THE SECOND COMPONENT) 25191C ON THE LEFT. 25192C IF EXISTENT, THIS SHOULD BE THE ARGUMENT DESIGNATION 25193C OF A VARIABLE, 25194C AND IT MAY BE EITHER A 'WORD' OR A 'NUMB'. 25195C 25196 ITYW2L=ITYPE(4) 25197C 25198 6900 CONTINUE 25199C 25200C ******************************************************* 25201C ** STEP 7-- ** 25202C ** DETERMINE VARIOUS SUMMARY VARIABLES FOR THE ** 25203C ** RIGHT SIDE OF THE COMMAND LINE WHICH WILL BE ** 25204C ** HELPFUL BACK IN DPLET FOR BRANCHING TO THE ** 25205C ** CORRECT TYPE OF OPERATION. NOTE THAT THE ** 25206C ** RIGHT SIDE WILL BE FROM THE = SIGN ** 25207C ** TO THE END OF THE LINE, ** 25208C ** OR TO AN ISOLATED FOR, ** 25209C ** OR TO AN ISOLATED SUBSET ** 25210C ** (WHICHEVER OF THE 3 IS SMALLEST). ** 25211C ** ALSO DETERMINE WHETHER THE QUALIFICATION ** 25212C ** ON THE FAR RIGHT OF THE CARD IS ** 25213C ** 1) BLANK (THAT IS, NO QUALIFICATION) ** 25214C ** 2) SUBSET ** 25215C ** 3) FOR ** 25216C ** THE VARIABLE IQUAL WILL BE DEFINED IN ** 25217C ** THIS REGARD ** 25218C ** IQUAL WILL = 'NONE', 'FOR', 'SUBS', OR 'ERRO'. ** 25219C ******************************************************* 25220C 25221 ISTEPN='7' 25222 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 25223C 25224C STEP 7.0-- 25225C DETERMINE THE LIMITS OF THE RIGHT SIDE 25226C 25227 IMINR=0 25228 IF(IFOUNZ(6).EQ.'YES')IMINR=IEND(6)+1 25229C 25230 IF(IFOUNZ(11).EQ.'YES'.AND.IFOUNZ(21).EQ.'YES')GOTO7020 25231 GOTO7030 25232C 25233 7020 CONTINUE 25234 WRITE(ICOUT,7021) 25235 7021 FORMAT('***** ERROR IN DPTYP2--') 25236 CALL DPWRST('XXX','BUG ') 25237 WRITE(ICOUT,7022) 25238 7022 FORMAT(' BOTH FOR CASE AND SUBSET CASE FOUND') 25239 CALL DPWRST('XXX','BUG ') 25240 WRITE(ICOUT,7023)IWIDTH 25241 7023 FORMAT('IWIDTH = ',I8) 25242 CALL DPWRST('XXX','BUG ') 25243 WRITE(ICOUT,7024) 25244 7024 FORMAT('THE COMMAND LINE IS AS FOLLOWS--') 25245 CALL DPWRST('XXX','BUG ') 25246 WRITE(ICOUT,7025)(IANS(I),I=1,IWIDTH) 25247 7025 FORMAT(80A1) 25248 CALL DPWRST('XXX','BUG ') 25249 IQUAL = 'ERRO' 25250 IMAXR=0 25251 GOTO7090 25252C 25253 7030 CONTINUE 25254 IF(IFOUNZ(11).EQ.'NO'.AND.IFOUNZ(21).EQ.'NO')IQUAL='NONE' 25255 IF(IFOUNZ(11).EQ.'YES')IQUAL='SUBS' 25256 IF(IFOUNZ(21).EQ.'YES')IQUAL='FOR' 25257 IF(IQUAL.EQ.'NONE')IMAXR=IWIDTH 25258 IF(IQUAL.EQ.'SUBS')IMAXR=IBEGIN(11)-1 25259 IF(IQUAL.EQ.'FOR')IMAXR=IBEGIN(21)-1 25260C 25261 7090 CONTINUE 25262 IF(IMINR.LE.0)GOTO7900 25263 IF(IMAXR.LE.0)GOTO7900 25264 IF(IMINR.GT.IMAXR)GOTO7900 25265C 25266C STEP 7.1-- 25267C DETERMINE THE NUMBER OF COMPONENTS ON THE RIGHT. 25268C A COMPONENT HERE = A WORD OR A PARENTHESIS. 25269C 25270 ISUM=0 25271 IMIN=7 25272 IMAX=10 25273 DO7100I=IMIN,IMAX 25274 IF(IFOUNZ(I).EQ.'YES')ISUM=ISUM+1 25275 7100 CONTINUE 25276 NUMCR=ISUM 25277C 25278C STEP 7.2-- 25279C DETERMINE THE NUMBER OF PARENTHESES (LEFT + RIGHT). 25280C 25281 ISUM=0 25282 IMIN=IMINR 25283 IMAX=IMAXR 25284 DO7200I=IMIN,IMAX 25285 IF(IANS(I).EQ.'('.OR.IANS(I).EQ.')')ISUM=ISUM+1 25286 7200 CONTINUE 25287 NUMPR=ISUM 25288C 25289C STEP 7.3-- 25290C DETERMINE THE NUMBER OF ARITHMETIC OPERATIONS 25291C + - * / ON THE RIGHT 25292C (IT SHOULD BE 0). 25293C NOTE THAT THE ARITHMETIC OPERATION ** 25294C WILL BE LUMPED IN WITH * . 25295C 25296 ISUM=0 25297 IMIN=IMINR 25298 IMAX=IMAXR 25299 DO7300I=IMIN,IMAX 25300 IF(IANS(I).EQ.'+'.OR.IANS(I).EQ.'-'.OR. 25301 1 IANS(I).EQ.'*'.OR.IANS(I).EQ.'/')ISUM=ISUM+1 25302 7300 CONTINUE 25303 NUMAOR=ISUM 25304C 25305C STEP 7.4-- 25306C DETERMINE THE TYPE ('NUMB' OR 'WORD') 25307C FOR THE FIRST WORD ON THE RIGHT. 25308C THIS SHOULD BE THE VARIABLE OR PARAMETER 25309C DESIGNATION, 25310C AND IT SHOULD BE A 'WORD'. 25311C 25312 ITYW1R=ITYPE(7) 25313C 25314C STEP 7.5-- 25315C DETERMINE IF FIRST WORD ON THE RIGHT 25316C IS ALREADY IN THE NAME LIST OR NOT. 25317C 25318 INLI1R='NO' 25319 IVARR=IHOL(7) 25320 IVARR2=IHOL2(7) 25321 DO7500I=1,NUMNAM 25322 IF(IVARR.EQ.IHNAME(I).AND.IVARR2.EQ.IHNAM2(I))INLI1R='YES' 25323 7500 CONTINUE 25324C 25325C STEP 7.6-- 25326C DETERMINE IF FIRST WORD ON THE RIGHT 25327C IS IN THE VARIABLE/PARAMETER NAME LIST, OR 25328C IS A COLUMN NAMING (I.E., THE WORD 'COLU' OR 'COL', OR 25329C IS A DATA MANIPULATION FUNCTION, OR 25330C IS A STATISTICAL CALCULATION FUNCTION 25331C (SEARCH IS DONE IN THAT ORDER). 25332C 25333 ICAT1R='NONE' 25334 IVARR=IHOL(7) 25335 IVARR2=IHOL2(7) 25336C 25337 IF(INLI1R.EQ.'YES'.AND.IVARR.NE.'COLU')GOTO7615 25338 IF(INLI1R.EQ.'YES'.AND.IVARR.NE.'COL ')GOTO7615 25339 IF(INLI1R.EQ.'YES'.AND.IVARR.EQ.'COLU'.AND.IVARR2.EQ.'MN '.AND. 25340 1IFOUNZ(8).EQ.'NO')GOTO7615 25341 IF(INLI1R.EQ.'YES'.AND.IVARR.EQ.'COL '.AND.IVARR2.EQ.' '.AND. 25342 1IFOUNZ(8).EQ.'NO')GOTO7615 25343 IF(INLI1R.EQ.'YES'.AND.IVARR.EQ.'COLU'.AND.IVARR2.EQ.'MN '.AND. 25344 1IFOUNZ(8).EQ.'YES'.AND.ITYPE(8).NE.'NUMB')GOTO7615 25345 IF(INLI1R.EQ.'YES'.AND.IVARR.EQ.'COL '.AND.IVARR2.EQ.' '.AND. 25346 1IFOUNZ(8).EQ.'YES'.AND.ITYPE(8).NE.'NUMB')GOTO7615 25347 GOTO7620 25348 7615 CONTINUE 25349 ICAT1R='VARP' 25350 GOTO7690 25351C 25352 7620 CONTINUE 25353 IF(IVARR.EQ.'COLU'.AND.IVARR2.EQ.'MN '.AND. 25354 1IFOUNZ(8).EQ.'YES'.AND.ITYPE(8).EQ.'NUMB')GOTO7625 25355 IF(IVARR.EQ.'COL '.AND.IVARR2.EQ.' '.AND. 25356 1IFOUNZ(8).EQ.'YES'.AND.ITYPE(8).EQ.'NUMB')GOTO7625 25357 GOTO7630 25358 7625 CONTINUE 25359 ICAT1R='COL' 25360 GOTO7690 25361C 25362 7630 CONTINUE 25363 DO7632I=1,NUMMAN 25364 IF(IVARR.EQ.IHMAN(I).AND.IVARR2.EQ.IHMAN2(I))GOTO7635 25365 7632 CONTINUE 25366 GOTO7640 25367 7635 CONTINUE 25368 ICAT1R='MANI' 25369 GOTO7690 25370C 25371 7640 CONTINUE 25372 DO7642I=1,NUMSTA 25373 IF(IVARR.EQ.IHSTAT(I).AND.IVARR2.EQ.IHSTA2(I))GOTO7645 25374 7642 CONTINUE 25375 GOTO7690 25376 7645 CONTINUE 25377 ICAT1R='STAT' 25378 GOTO7690 25379C 25380 7690 CONTINUE 25381C 25382C STEP 7.7-- 25383C DETERMINE THE TYPE ('NUMB' OR 'WORD') 25384C FOR THE SECOND WORD 25385C (AS OPPOSED TO THE SECOND COMPONENT) 25386C ON THE RIGHT. 25387C IF EXISTENT, THIS SHOULD BE THE ARGUMENT DESIGNATION 25388C OF A VARIABLE, 25389C AND IT MAY BE EITHER A 'WORD' OR A 'NUMB'. 25390C 25391 ITYW2R=ITYPE(9) 25392C 25393 7900 CONTINUE 25394C 25395C ***************** 25396C ** STEP 90-- ** 25397C ** EXIT ** 25398C ***************** 25399C 25400 9000 CONTINUE 25401 IF(IBUGA3.EQ.'ON')THEN 25402 WRITE(ICOUT,999) 25403 CALL DPWRST('XXX','BUG ') 25404 WRITE(ICOUT,9011) 25405 9011 FORMAT('****** AT THE END OF DPTYP2--') 25406 CALL DPWRST('XXX','BUG ') 25407 DO9020I=1,30 25408 IF(18.LE.I.AND.I.LE.20)GOTO9020 25409 IF(I.GE.25)GOTO9020 25410 WRITE(ICOUT,999) 25411 CALL DPWRST('XXX','BUG ') 25412 WRITE(ICOUT,9022) 25413 9022 FORMAT('I--IFOUNZ,IBEGIN,IEND,', 25414 1 'ITYPE,IHOL,IHOL2,INT1,FLOAT1,IERRO1') 25415 CALL DPWRST('XXX','BUG ') 25416 WRITE(ICOUT,9025)I,IFOUNZ(I),IBEGIN(I),IEND(I),ITYPE(I), 25417 1 IHOL(I),IHOL2(I),INT1(I),FLOAT1(I),IERRO1(I) 25418 9025 FORMAT(I3,'--',A4,2(2X,I2),4X,3(A4,2X),I8,2X,D15.7,2X,A4) 25419 CALL DPWRST('XXX','BUG ') 25420 9020 CONTINUE 25421C 25422 WRITE(ICOUT,999) 25423 CALL DPWRST('XXX','BUG ') 25424 WRITE(ICOUT,9031)NUMCL,NUMPL,NUMAOL,ITYW1L,ITYW2L,INLI1L,ICAT1L 25425 9031 FORMAT('NUMCL,NUMPL,NUMAOL,ITYW1L,ITYW2L,INLI1L,ICAT1L = ', 25426 1 3I8,4(2X,A4)) 25427 CALL DPWRST('XXX','BUG ') 25428 WRITE(ICOUT,9032)NUMCR,NUMPR,NUMAOR,ITYW1R,ITYW2R,INLI1R,ICAT1R 25429 9032 FORMAT('NUMCR,NUMPR,NUMAOR,ITYW1R,ITYW2R,INLI1R,ICAT1R = ', 25430 1 3I8,4(2X,A4)) 25431 CALL DPWRST('XXX','BUG ') 25432 ENDIF 25433C 25434 RETURN 25435 END 25436 SUBROUTINE DPTYP3(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX, 25437 1 IBUGA3, 25438 1 IFOUZ2,ISTAR2,ISTOP2, 25439 1 ITYPE2,IHOL,IHOL2,INTZ,FLOATZ,IERROR) 25440C 25441C NOTE--THIS SUBROUTINE IS IDENTICAL TO DPTY3C 25442C AND HAS BEEN DUPLICATED ONLY FOR MAPPING PURPOSES. 25443C DATE--JULY 7, 1978. 25444C 25445C PURPOSE--SCAN THE CHARACTER ARRAY IANS(.) BETWEEN 25446C COLUMNS ISTAR1 AND ISTOP1 25447C FOR THE STRING DEFINED IN STRIN AND ISTRI2. 25448C NOTE THAT THE STRING DEFINED IN ISTRIN AND ISTRI2 25449C MAY BE EXPRESSED IN SEVERAL WAYS-- 25450C 1) EXPLICITELY, E.G., LET FOR SUBSET, ETC. 25451C 2) IMPLICITELY WITH ! REPRESENTING THE FIRST 25452C NON-BLANK CHARACTER THAT IS ENCOUNTERED; 25453C 3) IMPLICITELY WITH ; REPRESENTING ANY STRING 25454C (INCLUDING ALL CHARACTERS, EVEN BLANKS)); 25455C 4) IMPLICITELY WITH : REPRESENTING THE FIRST 25456C BLANK CHARACTER THAT IS ENCOUNTERED. 25457C NOTE--A GIVEN ARGUMENT MAY END UP WITH 25458C 3 DIFFERENT REPRESENTATIONS-- 25459C HOLLERITH, INTEGER, AND FLOATING POINT. 25460C INPUT ARGUMENTS--IANS = A HOLLERITH 1-CHARACTER-PER-WORD 25461C VARIABLE CONTAINING THE INPUT LINE 25462C TO BE EXAMINED. 25463C --IWIDTH = THE (FULL) WIDTH OF THE INPUT LINE 25464C (THAT IS, THE NUMBER OF COLUMNS) 25465C --ISTAR1 = THE FIRST COLUMN FOR WHICH THE 25466C SCAN IS TO BE CARRIED OUT. 25467C --ISTOP1 = THE LAST COLUMN FOR WHICH THE 25468C SCAN IS TO BE CARRIED OUT. 25469C --ISTRIN = THE HOLLERITH VARIABLE 25470C WHICH CONTAINS CHARACTERS 1 TO 4 25471C OF THE STRING TO BE SEARCHED FOR. 25472C THE DEFINITION OF THE STRING IN ISTRIN MAY 25473C MAY BE DONE EXPLICTELY (BUT IS LIMITED 25474C TO 4 CHARACTERS) OR IMPLICITELY 25475C WHICH IS NOT LIMITED TO 4 CHARACTERS AND IS MOR 25476C IS MORE GENERAL IN 25477C OTHER WAYS ALSO. 25478C --ISTRI2 = THE HOLLERITH VARIABLE 25479C WHICH CONTAINS CHARACTERS 5 TO 8 25480C OF THE STRING TO BE SEARCHED FOR. 25481C THE DEFINITION OF THE STRING IN ISTRIN MAY 25482C MAY BE DONE EXPLICTELY (BUT IS LIMITED 25483C TO 4 CHARACTERS) OR IMPLICITELY 25484C WHICH IS NOT LIMITED TO 4 CHARACTERS AND IS MOR 25485C IS MORE GENERAL IN 25486C OTHER WAYS ALSO. 25487C --INEX = A HOLLERITH VARIABLE WHICH 25488C WILL CONTAIN ONE OF THE FOLLOWING 4 VALUES-- 25489C II, IE, EI, EE THAT STANDS FOR 25490C WHERE I STANDS FOR INCLUSIVE AND 25491C WHERE E STANDS FOR EXCLUSIVE; 25492C INEX SPECIFIES WHETHER THE FIRST OR LAST CHARAC 25493C CHARACTER IS TO BE INCLUDED OR EXCLUDED IN 25494C IN DEFINING ISTAR2 AND ISTOP2. 25495C OUTPUT ARGUMENTS--IFOUZ2 = A HOLLERITH VARIABLE 25496C WITH THE VALUE 'YES' 25497C IF THE STRING WAS FOUND; 25498C AND THE VALUE 'NO' 25499C IF THE STRING WAS NOT FOUND. 25500C --ISTAR2 = THE START COLUMN OF THE FOUND STRING 25501C --ISTOP2 = THE STOP COLUMN OF THE FIUND STRING. 25502C --ITYPE2 = A HOLLERITH VARIABLE 25503C WITH THE VALUE 'WORD' IF THE STRING CONTAINS 25504C ANY NON-NUMERIC (EXCLUDING BLANKS) CHARACTER; 25505C AND WITH THE VALUE 'NUMB' IF THE STRING CONTA 25506C ALL NUMERIC VALUES OR DECIMAL POINT OR + OR - 25507C (WITH INTERMITTENT BLANKS IGNORED). 25508C --IHOL = THE HOLLERITH VARIABLE 25509C CONTAINING THE PACKED (4 CHARACTERS) VERSION 25510C OF CHARACTERS 1 TO 4 OF THE FOUND STRING. 25511C --IHOL2 = THE HOLLERITH VARIABLE 25512C CONTAINING THE PACKED (4 CHARACTERS) VERSION 25513C OF CHARACTERS 5 TO 8 OF THE FOUND STRING. 25514C --INT = THE INTEGER VARIABLE 25515C CONTAINING THE INTEGER REPRESENTATION 25516C (IF POSSIBLE) OF THE FOUND STRING. 25517C --FLOAT = THE FLOATING POINT VARIABLE 25518C CONTAINING THE FLOATING POINT REPRESENTATION 25519C (IF POSSIBLE) OF THE FOUND STRING. 25520C --IERROR = A HOLLERITH VARIABLE WITH VALUE 25521C 'YES' OR 'NO' INDICATING IF AN 25522C ERROR CONDITION EXISTS. 25523C WRITTEN BY--JAMES J. FILLIBEN 25524C STATISTICAL ENGINEERING DIVISION 25525C INFORMATION TECHNOLOGY LABORATORY 25526C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 25527C GAITHERSBURG, MD 20899-8980 25528C PHONE--301-975-2855 25529C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 25530C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 25531C LANGUAGE--ANSI FORTRAN (1977) 25532C VERSION NUMBER--82/7 25533C ORIGINAL VERSION--FEBRUARY 1978. 25534C UPDATED --JULY 1978. 25535C UPDATED --OCTOBER 1978. 25536C UPDATED --NOVEMBER 1980. 25537C UPDATED --JANUARY 1981. 25538C UPDATED --JUNE 1981. 25539C UPDATED --MARCH 1982. 25540C UPDATED --MAY 1982. 25541C 25542C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 25543C 25544 CHARACTER*4 IANS 25545 CHARACTER*4 ISTRIN 25546 CHARACTER*4 ISTRI2 25547 CHARACTER*4 INEX 25548 CHARACTER*4 IBUGA3 25549 CHARACTER*4 IFOUZ2 25550 CHARACTER*4 ITYPE2 25551 CHARACTER*4 IHOL 25552 CHARACTER*4 IHOL2 25553 CHARACTER*4 IERROR 25554C 25555 CHARACTER*4 ITEMP 25556 CHARACTER*4 IFLUNK 25557 CHARACTER*4 ISTRI3 25558 CHARACTER*4 ILAST 25559 CHARACTER*4 ISUBN1 25560 CHARACTER*4 ISUBN2 25561 CHARACTER*4 ISTEPN 25562C 25563C--------------------------------------------------------------------- 25564C 25565 DIMENSION IANS(*) 25566C 25567 DIMENSION ISTRI3(20) 25568C 25569C-----COMMON---------------------------------------------------------- 25570C 25571 INCLUDE 'DPCOP2.INC' 25572C 25573C-----START POINT----------------------------------------------------- 25574C 25575 ISUBN1='DPTY' 25576 ISUBN2='P3 ' 25577 IERROR='NO' 25578C 25579 IPJM1=0 25580C 25581 IF(IBUGA3.EQ.'ON')THEN 25582 WRITE(ICOUT,999) 25583 999 FORMAT(1X) 25584 CALL DPWRST('XXX','BUG ') 25585 WRITE(ICOUT,51) 25586 51 FORMAT('***** AT THE BEGINNING OF DPTYP3--') 25587 CALL DPWRST('XXX','BUG ') 25588 WRITE(ICOUT,53)ISTAR1,ISTOP1 25589 53 FORMAT('ISTAR1,ISTOP1 = ',I8,I8) 25590 CALL DPWRST('XXX','BUG ') 25591 WRITE(ICOUT,54)IBUGA3,ISTRIN,ISTRI2 25592 54 FORMAT('IBUGA3,ISTRIN,ISTRI2 = ',2(A4,2X),A4) 25593 CALL DPWRST('XXX','BUG ') 25594 ENDIF 25595C 25596 NUMASC=4 25597C 25598C ****************************************************** 25599C ** STEP 1-- ** 25600C ** INITIALIZE THE OUTPUT PARAMETERS AND VARIABLES ** 25601C ****************************************************** 25602C 25603 ISTEPN='1' 25604 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 25605C 25606 IF(IBUGA3.EQ.'OFF')GOTO150 25607 WRITE(ICOUT,101) 25608 101 FORMAT('AT THE BEGINNING OF DPTYP3--') 25609 CALL DPWRST('XXX','BUG ') 25610 WRITE(ICOUT,102)IWIDTH 25611 102 FORMAT('IWIDTH = ',I8) 25612 CALL DPWRST('XXX','BUG ') 25613 WRITE(ICOUT,103)(IANS(I),I=1,IWIDTH) 25614 103 FORMAT('IANS(.) = ',80A1) 25615 CALL DPWRST('XXX','BUG ') 25616 WRITE(ICOUT,104)ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX 25617 104 FORMAT('ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX = ',I8,I8,A4,A4,A4) 25618 CALL DPWRST('XXX','BUG ') 25619 150 CONTINUE 25620 IFOUZ2='NO' 25621 ISTAR2=-1 25622 ISTOP2=-1 25623 ITYPE2='9999' 25624 IHOL ='9999' 25625 IHOL2='9999' 25626 FLOATZ=-999999.0 25627C 25628C ********************************************************* 25629C ** STEP 2-- ** 25630C ** DECOMPOSE THE INPUT SEARCH STRING INTO A1 CHARACTERS* 25631C ********************************************************* 25632C 25633 ISTEPN='2' 25634 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 25635 IMAX=2*NUMASC 25636 DO300I=1,IMAX 25637 I2=I 25638 J=I 25639 IF(I.GT.NUMASC)J=I-NUMASC 25640 ISTAR3=NUMBPC*(J-1) 25641 ISTAR3=IABS(ISTAR3) 25642 ITEMP=' ' 25643 IF(I.LE.NUMASC)CALL DPCHEX(ISTAR3,NUMBPC,ISTRIN,0,NUMBPC,ITEMP) 25644 IF(I.GT.NUMASC)CALL DPCHEX(ISTAR3,NUMBPC,ISTRI2,0,NUMBPC,ITEMP) 25645 IF(ITEMP.EQ.' ')GOTO350 25646 ISTRI3(I)=ITEMP 25647 300 CONTINUE 25648 ILEN2=I2 25649 GOTO390 25650 350 CONTINUE 25651 ILEN2=I2-1 25652 390 CONTINUE 25653C 25654 IF(IBUGA3.EQ.'OFF')GOTO399 25655 WRITE(ICOUT,391) 25656 391 FORMAT('IN THE MIDDLE OF DPTYP3 (AFTER STEP 2)--') 25657 CALL DPWRST('XXX','BUG ') 25658 WRITE(ICOUT,392)ILEN2 25659 392 FORMAT('ILEN2 = ',I8) 25660 CALL DPWRST('XXX','BUG ') 25661 WRITE(ICOUT,393)(ISTRI3(I),I=1,ILEN2) 25662 393 FORMAT('ISTRI3(.) = ',6A1) 25663 CALL DPWRST('XXX','BUG ') 25664 399 CONTINUE 25665C 25666C **************************************************************** 25667C ** STEP 3-- 25668C ** DISTINGUISH BETWEEN THE 3 TYPES OF POSSIBLE SEARCH STRINGS-- 25669C ** 1) AN EXPLICITELY-DEFINED STRING; E.G., 25670C ** LET FOR SUBSET = 5.3 -2.6666666 25671C ** (AS IN COMMANDS, KEY WORDS, AND NUMBERS); 25672C ** 2) A STRING STARTING WITH THE FIRST NON-BLANK CHARACTER 25673C ** AND ENDING WITH SOME SPECIFIED CHARACTER; E.G., XXXXX( 25674C ** (AS IN THE VARIABLE NAME OF A SUBSCRIPTED VARIABLE, 25675C ** OR THE ARGUMENT (I. E., THE SUBSCRIPT) IN A SUBSCRIPTED 25676C ** VARIABLE); 25677C ** 3) A STRING STARTING WITH THE FIRST NON-BLANK CHARACTER 25678C ** AND ENDING WITH THE FIRST SUBSEQUENT BLANK CHARACTER 25679C ** (OR ENDING WITH THE END OF THE LINE). 25680C ** E.G., XXXX 25681C ** (AS IN SOME UNSPECIFIED PARAMETER OR VARIABLE NAME). 25682C **************************************************************** 25683C 25684 ISTEPN='3' 25685 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 25686 ICASE=1 25687 IF(ISTRI3(1).NE.'!'.AND.ISTRI3(2).EQ.';'.AND.ISTRI3(3).NE.':') 25688 1ICASE=2 25689 IF(ISTRI3(1).EQ.'!'.AND.ISTRI3(2).EQ.';'.AND.ISTRI3(3).NE.':') 25690 1ICASE=3 25691 IF(ISTRI3(1).EQ.'!'.AND.ISTRI3(2).EQ.';'.AND.ISTRI3(3).EQ.':') 25692 1ICASE=4 25693 IF(ILEN2.EQ.1.OR.ILEN2.EQ.2)ICASE=1 25694C 25695 IF(IBUGA3.EQ.'OFF')GOTO398 25696 WRITE(ICOUT,395) 25697 395 FORMAT('AFTER STEP 3 OF DPTYP3--') 25698 CALL DPWRST('XXX','BUG ') 25699 WRITE(ICOUT,396)ICASE 25700 396 FORMAT('ICASE = ',I8) 25701 CALL DPWRST('XXX','BUG ') 25702 398 CONTINUE 25703C 25704C ********************************************************* 25705C ** STEP 4-- ** 25706C ** DETERMINE IF THE DESIRED SEARCH STRING IS PRESENT ** 25707C ********************************************************* 25708C 25709 ISTEPN='4' 25710 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 25711 IF(ICASE.EQ.1)GOTO400 25712 IF(ICASE.EQ.2)GOTO500 25713 IF(ICASE.EQ.3)GOTO600 25714 IF(ICASE.EQ.4)GOTO700 25715C 25716 400 CONTINUE 25717 DO410I=ISTAR1,ISTOP1 25718 I2=I 25719 IF(IANS(I).EQ.ISTRI3(1))GOTO420 25720 GOTO410 25721 420 CONTINUE 25722 DO430J=1,ILEN2 25723 IPJM1=J+I-1 25724 IF(IPJM1.GT.ISTOP1)GOTO410 25725 IF(IANS(IPJM1).EQ.ISTRI3(J))GOTO430 25726 GOTO410 25727 430 CONTINUE 25728 IFOUZ2='YES' 25729 IF(INEX.EQ.'II')ISTAR2=I2 25730 IF(INEX.EQ.'IE')ISTAR2=I2 25731 IF(INEX.EQ.'EI')ISTAR2=I2+1 25732 IF(INEX.EQ.'EE')ISTAR2=I2+1 25733 IF(INEX.EQ.'II')ISTOP2=IPJM1 25734 IF(INEX.EQ.'IE')ISTOP2=IPJM1-1 25735 IF(INEX.EQ.'EI')ISTOP2=IPJM1 25736 IF(INEX.EQ.'EE')ISTOP2=IPJM1-1 25737 IF(ISTAR2.LE.ISTOP2)GOTO990 25738 GOTO900 25739 410 CONTINUE 25740 IFOUZ2='NO' 25741 GOTO9000 25742C 25743 500 CONTINUE 25744 DO510I=ISTAR1,ISTOP1 25745 I2=I 25746 IF(IANS(I).EQ.ISTRI3(1))GOTO520 25747 510 CONTINUE 25748 IFOUZ2='NO' 25749 GOTO9000 25750 520 CONTINUE 25751 IMIN=I2 25752 DO530I=IMIN,ISTOP1 25753 I2=I 25754 IF(IANS(I).EQ.ISTRI3(ILEN2))GOTO540 25755 530 CONTINUE 25756 IFOUZ2='NO' 25757 GOTO9000 25758 540 CONTINUE 25759 IFOUZ2='YES' 25760 IF(INEX.EQ.'II')ISTAR2=IMIN 25761 IF(INEX.EQ.'IE')ISTAR2=IMIN 25762 IF(INEX.EQ.'EI')ISTAR2=IMIN+1 25763 IF(INEX.EQ.'EE')ISTAR2=IMIN+1 25764 IF(INEX.EQ.'II')ISTOP2=I2 25765 IF(INEX.EQ.'IE')ISTOP2=I2-1 25766 IF(INEX.EQ.'EI')ISTOP2=I2 25767 IF(INEX.EQ.'EE')ISTOP2=I2-1 25768 IF(ISTAR2.LE.ISTOP2)GOTO990 25769 GOTO900 25770C 25771 600 CONTINUE 25772 DO610I=ISTAR1,ISTOP1 25773 I2=I 25774 IF(IANS(I).NE.' ')GOTO620 25775 610 CONTINUE 25776 IFOUZ2='NO' 25777 GOTO9000 25778 620 CONTINUE 25779 IMIN=I2 25780 DO630I=IMIN,ISTOP1 25781 I2=I 25782 IF(IANS(I).EQ.ISTRI3(ILEN2))GOTO640 25783 630 CONTINUE 25784 IFOUZ2='NO' 25785 GOTO9000 25786 640 CONTINUE 25787 IFOUZ2='YES' 25788 IF(INEX.EQ.'II')ISTAR2=IMIN 25789 IF(INEX.EQ.'IE')ISTAR2=IMIN 25790 IF(INEX.EQ.'EI')ISTAR2=IMIN+1 25791 IF(INEX.EQ.'EE')ISTAR2=IMIN+1 25792 IF(INEX.EQ.'II')ISTOP2=I2 25793 IF(INEX.EQ.'IE')ISTOP2=I2-1 25794 IF(INEX.EQ.'EI')ISTOP2=I2 25795 IF(INEX.EQ.'EE')ISTOP2=I2-1 25796 IF(ISTAR2.LE.ISTOP2)GOTO990 25797 GOTO900 25798C 25799 700 CONTINUE 25800 ILAST='BLAN' 25801 DO710I=ISTAR1,ISTOP1 25802 I2=I 25803 IF(IANS(I).NE.' ')GOTO720 25804 710 CONTINUE 25805 IFOUZ2='NO' 25806 GOTO9000 25807 720 CONTINUE 25808 IMIN=I2 25809 DO730I=IMIN,ISTOP1 25810 I2=I 25811 IF(IANS(I).EQ.' ')GOTO740 25812 730 CONTINUE 25813 ILAST='NOBL' 25814 IF(ISTOP1.EQ.IWIDTH)GOTO740 25815 IFOUZ2='NO' 25816 GOTO9000 25817 740 CONTINUE 25818 IFOUZ2='YES' 25819 IF(INEX.EQ.'II')ISTAR2=IMIN 25820 IF(INEX.EQ.'IE')ISTAR2=IMIN 25821 IF(INEX.EQ.'EI')ISTAR2=IMIN+1 25822 IF(INEX.EQ.'EE')ISTAR2=IMIN+1 25823 IF(INEX.EQ.'II'.AND.ISTOP1.NE.IWIDTH) 25824 1ISTOP2=I2 25825 IF(INEX.EQ.'II'.AND.ISTOP1.EQ.IWIDTH.AND.ILAST.EQ.'BLAN') 25826 1ISTOP2=I2 25827 IF(INEX.EQ.'II'.AND.ISTOP1.EQ.IWIDTH.AND.ILAST.NE.'BLAN') 25828 1ISTOP2=I2 25829 IF(INEX.EQ.'IE'.AND.ISTOP1.NE.IWIDTH) 25830 1ISTOP2=I2-1 25831 IF(INEX.EQ.'IE'.AND.ISTOP1.EQ.IWIDTH.AND.ILAST.EQ.'BLAN') 25832 1ISTOP2=I2-1 25833 IF(INEX.EQ.'IE'.AND.ISTOP1.EQ.IWIDTH.AND.ILAST.NE.'BLAN') 25834 1ISTOP2=I2 25835 IF(INEX.EQ.'EI'.AND.ISTOP1.NE.IWIDTH) 25836 1ISTOP2=I2 25837 IF(INEX.EQ.'EI'.AND.ISTOP1.EQ.IWIDTH.AND.ILAST.EQ.'BLAN') 25838 1ISTOP2=I2 25839 IF(INEX.EQ.'EI'.AND.ISTOP1.EQ.IWIDTH.AND.ILAST.NE.'BLAN') 25840 1ISTOP2=I2 25841 IF(INEX.EQ.'EE'.AND.ISTOP1.NE.IWIDTH) 25842 1ISTOP2=I2-1 25843 IF(INEX.EQ.'EE'.AND.ISTOP1.EQ.IWIDTH.AND.ILAST.EQ.'BLAN') 25844 1ISTOP2=I2-1 25845 IF(INEX.EQ.'EE'.AND.ISTOP1.EQ.IWIDTH.AND.ILAST.NE.'BLAN') 25846 1ISTOP2=I2 25847 IF(ISTAR2.LE.ISTOP2)GOTO990 25848 GOTO900 25849C 25850 900 CONTINUE 25851C 25852C NOTE--THE FOLLOWING SECTION HAS BEEN 'BUGGED' OUT 25853C TO CIRCUMVENT A PROBLEM WITH Y=(... 25854C WHILE IT STILL LOOKED FOR A VARIABLE NAME 25855C BETWEEN THE = AND THE ( . 25856C CAUTION--WHEN IBUGA3 = 'OFF', AS IT USUALLY IS, 25857C IERROR CAN NEVER BE 'YES' 25858C UPON RETURN FROM DPTYP3: 25859C BUT WHEN IBUGA3 = 'ON' (AS IN ERROR TRACING) 25860C IERROR MAY = 'YES' WHICH MAY CHANGE THE 25861C LOGIC PATH BACK IN DPTYP2. 25862C 25863 IF(IBUGA3.EQ.'OFF')GOTO9000 25864 WRITE(ICOUT,921) 25865 921 FORMAT('***** INTERNAL ERROR IN DPTYP3 SUBROUTINE') 25866 CALL DPWRST('XXX','BUG ') 25867 WRITE(ICOUT,922) 25868 922 FORMAT('ISTAR2 GREATER THAN ISTOP2') 25869 CALL DPWRST('XXX','BUG ') 25870 WRITE(ICOUT,923)ISTAR2,ISTOP2 25871 923 FORMAT('ISTAR2, ISTOP2 = ',2I8) 25872 CALL DPWRST('XXX','BUG ') 25873 WRITE(ICOUT,924)ICASE 25874 924 FORMAT('ICASE = ',I8) 25875 CALL DPWRST('XXX','BUG ') 25876 WRITE(ICOUT,999) 25877 CALL DPWRST('XXX','BUG ') 25878 WRITE(ICOUT,925)IWIDTH 25879 925 FORMAT('IWIDTH = ',I8) 25880 CALL DPWRST('XXX','BUG ') 25881 WRITE(ICOUT,926)(IANS(I),I=1,IWIDTH) 25882 926 FORMAT('IANS(.) = ',80A1) 25883 CALL DPWRST('XXX','BUG ') 25884 WRITE(ICOUT,927)ISTAR1,ISTOP1 25885 927 FORMAT('ISTAR1, ISTOP1 = ',2I8) 25886 CALL DPWRST('XXX','BUG ') 25887 WRITE(ICOUT,928)ILEN2 25888 928 FORMAT('ILEN2 = ',I8) 25889 CALL DPWRST('XXX','BUG ') 25890 WRITE(ICOUT,929)(ISTRI3(I),I=1,ILEN2) 25891 929 FORMAT('ISTRI3(.) = ',80A1) 25892 CALL DPWRST('XXX','BUG ') 25893 WRITE(ICOUT,930)ISTRIN,ISTRI2 25894 930 FORMAT('ISTRIN,ISTRI2 = ',2A4) 25895 CALL DPWRST('XXX','BUG ') 25896 WRITE(ICOUT,931)INEX 25897 931 FORMAT('INEX = ',A4) 25898 CALL DPWRST('XXX','BUG ') 25899 IERROR='YES' 25900 GOTO9000 25901 990 CONTINUE 25902C 25903C ******************************************************** 25904C ** STEP 5-- ** 25905C ** CONVERT THE STRING INTO 2 HOLLERITH A4 WORDS. ** 25906C ** IF MORE THAN 8 CHARACTERS, CONVERT ONLY ** 25907C ** THE FIRST 8 CHARACTERS. ** 25908C ** OUTPUT THESE HOLLERITH WORDS AS IHOL AND IHOL2. ** 25909C ******************************************************** 25910C 25911 ISTEPN='5' 25912 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 25913 IHOL =' ' 25914 IHOL2=' ' 25915 IMAX=2*NUMASC 25916 J=0 25917 DO1000I=ISTAR2,ISTOP2 25918 J=J+1 25919 K=J 25920 IF(J.GT.NUMASC)K=J-NUMASC 25921 ISTAR3=NUMBPC*(K-1) 25922 ISTAR3=IABS(ISTAR3) 25923 IF(J.LE.NUMASC)CALL DPCHEX(0,NUMBPC,IANS(I),ISTAR3,NUMBPC,IHOL) 25924 IF(J.GT.NUMASC)CALL DPCHEX(0,NUMBPC,IANS(I),ISTAR3,NUMBPC,IHOL2) 25925 IF(J.GE.IMAX)GOTO1050 25926 1000 CONTINUE 25927 1050 CONTINUE 25928C 25929C **************************************************************** 25930C ** STEP 6-- 25931C ** CONVERT (IF POSSIBLE) THE STRING INTO AN INTEGER ARGUMENT. 25932C ** OUTPUT THIS INTEGER VALUE IN INT. 25933C **************************************************************** 25934C 25935 ISTEPN='6' 25936 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 25937 IFLUNK='NO' 25938 ITYPE2='NUMB' 25939 IDIG=0 25940 ISIGN=0 25941 IDECPT=0 25942 ISUM=0 25943 DO2700I=ISTAR2,ISTOP2 25944 IREV=ISTOP2-(I-ISTAR2) 25945 IF(IANS(IREV).EQ.' ')GOTO2700 25946 IF(IANS(IREV).EQ.'0')GOTO2710 25947 IF(IANS(IREV).EQ.'1')GOTO2711 25948 IF(IANS(IREV).EQ.'2')GOTO2712 25949 IF(IANS(IREV).EQ.'3')GOTO2713 25950 IF(IANS(IREV).EQ.'4')GOTO2714 25951 IF(IANS(IREV).EQ.'5')GOTO2715 25952 IF(IANS(IREV).EQ.'6')GOTO2716 25953 IF(IANS(IREV).EQ.'7')GOTO2717 25954 IF(IANS(IREV).EQ.'8')GOTO2718 25955 IF(IANS(IREV).EQ.'9')GOTO2719 25956 IF(IANS(IREV).EQ.'+')GOTO2720 25957 IF(IANS(IREV).EQ.'-')GOTO2721 25958 IF(IANS(IREV).EQ.'.')GOTO2722 25959 IFLUNK='YES' 25960 GOTO2800 25961 2710 ITERM=0 25962 GOTO2725 25963 2711 ITERM=1 25964 GOTO2725 25965 2712 ITERM=2 25966 GOTO2725 25967 2713 ITERM=3 25968 GOTO2725 25969 2714 ITERM=4 25970 GOTO2725 25971 2715 ITERM=5 25972 GOTO2725 25973 2716 ITERM=6 25974 GOTO2725 25975 2717 ITERM=7 25976 GOTO2725 25977 2718 ITERM=8 25978 GOTO2725 25979 2719 ITERM=9 25980 GOTO2725 25981 2720 ISIGN=ISIGN+1 25982 GOTO2700 25983 2721 ISIGN=ISIGN+1 25984 ISUM=-ISUM 25985 GOTO2700 25986 2722 IDECPT=IDECPT+1 25987 IF(IDECPT.EQ.1.AND.IDIG.EQ.0)GOTO2700 25988 GOTO2800 25989 2725 IDIG=IDIG+1 25990 TERM2=10.0**(IDIG-1) 25991 ITERM2=INT(TERM2 + 0.01) 25992 ISUM=ISUM+ITERM*ITERM2 25993 2700 CONTINUE 25994 IF(IDIG.LE.0)GOTO2800 25995 IF(ISIGN.GE.2)GOTO2800 25996 INTZ=ISUM 25997 2800 CONTINUE 25998 IF(IFLUNK.EQ.'YES')ITYPE2='WORD' 25999C 26000C ******************************************************* 26001C ** STEP 7-- ** 26002C ** CONVERT (IF POSSIBLE) THE STRING INTO A FLOATING ** 26003C ** POINT ARGUMENT. ** 26004C ** OUTPUT THIS FLOATING POINT VALUE IN FLOAT. ** 26005C ******************************************************* 26006C 26007 ISTEPN='7' 26008 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 26009 AMIN=-1000000. 26010 AMAX=+1000000. 26011 IFLUNK='NO' 26012 ITYPE2='NUMB' 26013 FLOATZ=-1.0 26014C 26015 ILOC=0 26016 IDECPT=0 26017 DO3060I=ISTAR2,ISTOP2 26018 IF(IANS(I).EQ.'.')ILOC=I 26019 IF(IANS(I).EQ.'.')IDECPT=IDECPT+1 26020 3060 CONTINUE 26021 IF(IDECPT.GE.2)GOTO3900 26022 IF(IDECPT.EQ.1)GOTO3150 26023 DO3100I=ISTAR2,ISTOP2 26024 IREV=ISTOP2-(I-ISTAR2) 26025 IF(IANS(IREV).EQ.' ')GOTO3100 26026 IF(IANS(IREV).EQ.'0')GOTO3110 26027 IF(IANS(IREV).EQ.'1')GOTO3110 26028 IF(IANS(IREV).EQ.'2')GOTO3110 26029 IF(IANS(IREV).EQ.'3')GOTO3110 26030 IF(IANS(IREV).EQ.'4')GOTO3110 26031 IF(IANS(IREV).EQ.'5')GOTO3110 26032 IF(IANS(IREV).EQ.'6')GOTO3110 26033 IF(IANS(IREV).EQ.'7')GOTO3110 26034 IF(IANS(IREV).EQ.'8')GOTO3110 26035 IF(IANS(IREV).EQ.'9')GOTO3110 26036 IFLUNK='YES' 26037 IF(IANS(IREV).EQ.'+')GOTO3900 26038 IF(IANS(IREV).EQ.'-')GOTO3900 26039 GOTO3900 26040 3100 CONTINUE 26041 IFLUNK='YES' 26042 GOTO3900 26043 3110 ILOC=IREV+1 26044 3150 CONTINUE 26045 IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3111)ILOC,IDECPT 26046 3111 FORMAT('ILOC = ',I8,' IDECPT = ',I8) 26047 IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') 26048C 26049C SECONDLY, COMPUTE THE INTEGER PART OF THE VALUE 26050C 26051 SIGN=1.0 26052 IDIGI=0 26053 ISIGN=0 26054 SUMI=0 26055 ILOCM1=ILOC-1 26056 IF(ILOCM1.LT.ISTAR2)GOTO3250 26057 DO3200I=ISTAR2,ILOCM1 26058 IREV=ILOCM1-(I-ISTAR2) 26059 IF(IANS(IREV).EQ.' ')GOTO3200 26060 IF(IANS(IREV).EQ.'0')GOTO3210 26061 IF(IANS(IREV).EQ.'1')GOTO3211 26062 IF(IANS(IREV).EQ.'2')GOTO3232 26063 IF(IANS(IREV).EQ.'3')GOTO3213 26064 IF(IANS(IREV).EQ.'4')GOTO3214 26065 IF(IANS(IREV).EQ.'5')GOTO3215 26066 IF(IANS(IREV).EQ.'6')GOTO3216 26067 IF(IANS(IREV).EQ.'7')GOTO3217 26068 IF(IANS(IREV).EQ.'8')GOTO3218 26069 IF(IANS(IREV).EQ.'9')GOTO3219 26070 IF(IANS(IREV).EQ.'+')GOTO3220 26071 IF(IANS(IREV).EQ.'-')GOTO3221 26072 IFLUNK='YES' 26073 GOTO3900 26074 3210 ITERM=0 26075 GOTO3225 26076 3211 ITERM=1 26077 GOTO3225 26078 3232 ITERM=2 26079 GOTO3225 26080 3213 ITERM=3 26081 GOTO3225 26082 3214 ITERM=4 26083 GOTO3225 26084 3215 ITERM=5 26085 GOTO3225 26086 3216 ITERM=6 26087 GOTO3225 26088 3217 ITERM=7 26089 GOTO3225 26090 3218 ITERM=8 26091 GOTO3225 26092 3219 ITERM=9 26093 GOTO3225 26094 3220 ISIGN=ISIGN+1 26095 GOTO3200 26096 3221 ISIGN=ISIGN+1 26097 SIGN=-SIGN 26098 GOTO3200 26099 3225 IDIGI=IDIGI+1 26100 TERM=ITERM 26101 IEXP=IDIGI-1 26102 SUMI=SUMI+TERM*(10.0**IEXP) 26103 3200 CONTINUE 26104 3250 CONTINUE 26105 IF(ISIGN.GE.2)GOTO3900 26106 IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3255)IDIGI,SUMI 26107 3255 FORMAT('IDIGI = ',I8,' SUMI = ',F20.10) 26108 IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') 26109C 26110C THIRDLY, COMPUTE THE DECIMAL PART OF THE VALUE 26111C 26112 IDIGD=0 26113 SUMD=0.0 26114 ILOCP1=ILOC+1 26115 IF(ILOCP1.GT.ISTOP2)GOTO3350 26116 DO3300I=ILOCP1,ISTOP2 26117 IF(IANS(I).EQ.' ')GOTO3300 26118 IF(IANS(I).EQ.'0')GOTO3310 26119 IF(IANS(I).EQ.'1')GOTO3311 26120 IF(IANS(I).EQ.'2')GOTO3312 26121 IF(IANS(I).EQ.'3')GOTO3333 26122 IF(IANS(I).EQ.'4')GOTO3314 26123 IF(IANS(I).EQ.'5')GOTO3315 26124 IF(IANS(I).EQ.'6')GOTO3316 26125 IF(IANS(I).EQ.'7')GOTO3317 26126 IF(IANS(I).EQ.'8')GOTO3318 26127 IF(IANS(I).EQ.'9')GOTO3319 26128 IFLUNK='YES' 26129 GOTO3900 26130 3310 ITERM=0 26131 GOTO3325 26132 3311 ITERM=1 26133 GOTO3325 26134 3312 ITERM=2 26135 GOTO3325 26136 3333 ITERM=3 26137 GOTO3325 26138 3314 ITERM=4 26139 GOTO3325 26140 3315 ITERM=5 26141 GOTO3325 26142 3316 ITERM=6 26143 GOTO3325 26144 3317 ITERM=7 26145 GOTO3325 26146 3318 ITERM=8 26147 GOTO3325 26148 3319 ITERM=9 26149 GOTO3325 26150 3325 IDIGD=IDIGD+1 26151 TERM=ITERM 26152 SUMD=SUMD+TERM/(10.0**IDIGD) 26153 3300 CONTINUE 26154 3350 CONTINUE 26155 IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3355)IDIGD,SUMD 26156 3355 FORMAT('IDIGD = ',I8,' SUMD = ',F20.10) 26157 IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') 26158 IDIGT=IDIGI+IDIGD 26159 IF(IDIGT.LE.0)GOTO3900 26160 FLOATZ=SUMI+SUMD 26161 IF(SIGN.LT.0.0)FLOATZ=-FLOATZ 26162 IF(AMIN.LE.FLOATZ.AND.FLOATZ.LE.AMAX)GOTO3000 26163 GOTO3900 26164C 26165 3900 CONTINUE 26166 IF(IFLUNK.EQ.'YES')ITYPE2='WORD' 26167 3000 CONTINUE 26168 GOTO9000 26169C 26170 9000 CONTINUE 26171 IF(IBUGA3.EQ.'OFF')GOTO9900 26172 WRITE(ICOUT,999) 26173 CALL DPWRST('XXX','BUG ') 26174 WRITE(ICOUT,9001) 26175 9001 FORMAT('****** AT THE END OF DPTYP3--') 26176 CALL DPWRST('XXX','BUG ') 26177 WRITE(ICOUT,9002)IFOUZ2,ISTAR2,ISTOP2 26178 9002 FORMAT('IFOUZ2, ISTAR2, ISTOP2 = ',A4,I8,I8) 26179 CALL DPWRST('XXX','BUG ') 26180 WRITE(ICOUT,9003)ITYPE2,IHOL,IHOL2,INTZ,FLOATZ,IERROR 26181 9003 FORMAT('ITYPE2,IHOL,IHOL2,INTZ,FLOATZ,IERROR = ', 26182 1 A4,2X,2A4,2X,I8,F15.7,2X,A4) 26183 CALL DPWRST('XXX','BUG ') 26184C 26185 9900 CONTINUE 26186 RETURN 26187 END 26188 SUBROUTINE DPTYPE(IANSLC,IWIDTH,IBUGTY, 26189 1 ICOM,ICOM2,ICOMT,ICOMI,ACOM,ICOMLC,ICOML2, 26190 1 IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 26191 1 IHARG,IHARG2,IARGT,IARG,ARG, 26192 1 IHARLC,IHARL2,NUMARG, 26193 1 IHOST1,IHOST2) 26194C 26195C PUTPOSE--TAKE THE COMPONENTS OF AN INPUT COMMAND LINE 26196C AND COMPUTE HOLLERITH, INTEGER, AND FLOATING POINT 26197C EQUIVALENTS FOR EACH COMPONENT. 26198C INPUT ARGUMENTS--IANSLC (A HOLLERITH VECTOR) 26199C --IWIDTH (AN INTEGER VARIABLE) 26200C OUTPUT ARGUMENTS--ICOM (AN A4 HOLLERITH VALUE FOR COMMAND) 26201C --ICOM2 (AN A4 HOLLERITH VALUE FOR COMMAND) 26202C --ICOMLC (AN A4 HOLLERITH VALUE FOR COMMAND) 26203C --ICOML2 (AN A4 HOLLERITH VALUE FOR COMMAND) 26204C --IHARG (AN A4 HOLLERITH VECTOR) 26205C --IHARG2 (AN A4 HOLLERITH VECTOR) 26206C --IARG (AN INTEGER VECTOR) 26207C --ARG (A FLOATING POINT VECTOR) 26208C --IHARLC (AN A4 HOLLERITH VECTOR) 26209C --IHARL2 (AN A4 HOLLERITH VECTOR) 26210C --NUMARG (AN INTEGER VARIABLE) 26211C NOTE--A GIVEN ARGUMENT MAY END UP WITH 26212C 3 DIFFERENT REPRESENTATIONS-- 26213C HOLLERITH, INTEGER, AND FLOATING POINT. 26214C WRITTEN BY--JAMES J. FILLIBEN 26215C STATISTICAL ENGINEERING DIVISION 26216C INFORMATION TECHNOLOGY LABORATORY 26217C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 26218C GAITHERSBURG, MD 20899-8980 26219C PHONE--301-975-2855 26220C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 26221C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 26222C LANGUAGE--ANSI FORTRAN (1977) 26223C VERSION NUMBER--82/7 26224C ORIGINAL VERSION--NOVEMBER 10, 1977. 26225C UPDATED --MAY 1978. 26226C UPDATED --OCTOBER 1978. 26227C UPDATED --SEPTEMBER 1980. 26228C UPDATED --NOVEMBER 1980. 26229C UPDATED --AUGUST 1981. 26230C UPDATED --OCTOBER 1981. 26231C UPDATED --MAY 1982. 26232C UPDATED --NOVEMBER 1982. 26233C UPDATED --SEPTEMBER 1986. 26234C UPDATED --FEBRUARY 1989. ADJUST <> CASE (ALAN) 26235C UPDATED --AUGUST 1990. FIX HONEYWELL/PRIME > PROBLEM 26236C UPDATED --OCTOBER 1997. CHECK FOR EXPONENTIAL NUMBERS 26237C UPDATED --OCTOBER 2001. BUG ON SUN 26238C UPDATED --APRIL 2018. TREAT COMMA AS DELIMITER (IN 26239C ADDITION TO SPACE AND HYPHEN) 26240C UPDATED --APRIL 2018. OPTIONS TO TURN OFF HYPHEN, 26241C COMMA, OR EQUAL AS A DELIMITER 26242C UPDATED --APRIL 2018. IF EQUAL SIGN NOT A DELIMITER, 26243C THEN QUOTE TO RIGHT OF EQUAL 26244C DOES NOT START A NEW WORD 26245C (BUT DO TURN QUOTING ON), 26246C NEEDED FOR: 26247C CALL TITLE="Sample Title" 26248C 26249C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 26250C 26251 CHARACTER*4 IERROR 26252 CHARACTER*4 IANSLC 26253 CHARACTER*4 IBUGTY 26254 CHARACTER*4 ICOM 26255 CHARACTER*4 ICOM2 26256 CHARACTER*4 ICOMT 26257 CHARACTER*4 ICOMLC 26258 CHARACTER*4 ICOML2 26259 CHARACTER*4 IHNAME 26260 CHARACTER*4 IHNAM2 26261 CHARACTER*4 IUSE 26262 CHARACTER*4 IHARG 26263 CHARACTER*4 IHARG2 26264 CHARACTER*4 IARGT 26265 CHARACTER*4 IHARLC 26266 CHARACTER*4 IHARL2 26267 CHARACTER*4 IHOST1 26268 CHARACTER*4 IHOST2 26269C 26270 CHARACTER*4 IFLUNK 26271 CHARACTER*4 IB 26272 CHARACTER*4 IANS1 26273 CHARACTER*4 IANS2 26274 CHARACTER*4 IH 26275 CHARACTER*4 IH2 26276C 26277 CHARACTER*4 ISUBN1 26278 CHARACTER*4 ISUBN2 26279 CHARACTER*4 ISTEPN 26280C 26281 CHARACTER*10 ICJUNK 26282 CHARACTER*5 IFRMT 26283C 26284C--------------------------------------------------------------------- 26285C 26286 DIMENSION IANSLC(*) 26287C 26288 DIMENSION IHNAME(*) 26289 DIMENSION IHNAM2(*) 26290 DIMENSION IUSE(*) 26291 DIMENSION IVALUE(*) 26292 DIMENSION VALUE(*) 26293C 26294 DIMENSION IHARG(*) 26295 DIMENSION IHARG2(*) 26296 DIMENSION IARGT(*) 26297 DIMENSION IARG(*) 26298 DIMENSION ARG(*) 26299 DIMENSION IHARLC(*) 26300 DIMENSION IHARL2(*) 26301C 26302CCCCC PARAMETER (MAXZZZ=255) 26303 PARAMETER (MAXZZZ=1024) 26304C 26305 DIMENSION ISTART(MAXZZZ) 26306 DIMENSION ISTOP(MAXZZZ) 26307 DIMENSION IB(MAXZZZ) 26308C 26309C-----COMMON---------------------------------------------------------- 26310C 26311 INCLUDE 'DPCOST.INC' 26312 INCLUDE 'DPCOP2.INC' 26313C 26314C-----START POINT----------------------------------------------------- 26315C 26316 ISUBN1='DPTY' 26317 ISUBN2='PE ' 26318 IERROR='OFF' 26319C 26320 IF(IBUGTY.EQ.'ON')THEN 26321 WRITE(ICOUT,999) 26322 999 FORMAT(1X) 26323 CALL DPWRST('XXX','BUG ') 26324 WRITE(ICOUT,51) 26325 51 FORMAT('***** AT THE BEGINNING OF DPTYPE--') 26326 CALL DPWRST('XXX','BUG ') 26327 WRITE(ICOUT,53)(IANSLC(I),I=1,MIN(120,IWIDTH)) 26328 53 FORMAT('(IANSLC(.) = ',120A1) 26329 CALL DPWRST('XXX','BUG ') 26330 WRITE(ICOUT,61)IWIDTH,IHOST1,IHOST2 26331 61 FORMAT('IWIDTH,IHOST1,IHOST2 = ',I8,2(2X,A4)) 26332 CALL DPWRST('XXX','BUG ') 26333 ENDIF 26334C 26335C ************************************************************ 26336C ** DEFINE NUMASC = NUMBER OF ASCII CHARACTERS PER WORD. ** 26337C ** THIS IS 4 REGARDLESS OF THE COMPUTER MAKE AND ** 26338C ** REGARDLESS OF THE WORD SIZE. ** 26339C ************************************************************ 26340C 26341 NUMASC=4 26342C 26343C ********************************** 26344C ** STEP 1-- ** 26345C ** INITIALIZE SOME VARIABLES. ** 26346C ********************************** 26347C 26348 ISTEPN='1' 26349 IF(IBUGTY.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 26350C 26351 ICOM=' ' 26352 ICOM2=' ' 26353 ICOMT='NUMB' 26354 ICOMI=(-1) 26355 ACOM=(-1.0) 26356 ICOMLC=' ' 26357 ICOML2=' ' 26358 DO110I=1,100 26359 IHARG(I)=' ' 26360 IHARG2(I)=' ' 26361 IARGT(I)='NUMB' 26362 IARG(I)=(-1) 26363 ARG(I)=(-1.0) 26364 IHARLC(I)=' ' 26365 IHARL2(I)=' ' 26366 110 CONTINUE 26367 NUMARG=(-1) 26368C 26369C ********************************************************** 26370C ** STEP 2-- * 26371C ** SEPARATE IANSLC(.) INTO COMPONENTS WHERE A COMPONENT * 26372C ** IS DEFINED AS THAT SEPARATED BY 1 OR MORE BLANKS * 26373C ** IN ADDITION, AN EQUAL SIGN (=), * 26374C ** IN ADDITION, A COMMA (,), (2018/04) * 26375C 26376CCCCC -------------------------------------------------------------------- 26377CCCCC THE FOLLOWING DEALING WITH > AND < WAS DEACTIVATED AUGUST 1990 26378CCCCC DUE TO FACT THAT > IS A DIRECTORY SEPARATOR FOR AUGUST 1990 26379CCCCC CERTAIN COMPUTERS (E.G., HONEYWELL, PRIME). AUGUST 1990 26380CCCCC AND CALL DATAPLOT>DPSYSF.TEX WAS BOMBING AUGUST 1990 26381CCCCC WITH ARRAY OVERFLOW. AUGUST 1990 26382CCCCC THEREFORE--USER MUST MANUALLY MAKE SURE THAT > AND < AUGUST 1990 26383CCCCC ARE SURROUNDED BY SPACES IN MATH COMMANDS. AUGUST 1990 26384C 26385C ** A GREATER-THAN SIGN (>), AND A LESS-THAN SIGN (<) * 26386C ** ARE ALSO CONSIDERED AS A COMPONENT UNTO ITSELF * 26387C ** REGARDLESS OF WHETHER OR NOT * 26388C ** IT HAS PRECEEDING AND SUCCEEDING BLANKS. * 26389CCCCC -------------------------------------------------------------------- 26390C ** FINALLY, A HYPHEN WHEN IMMEDIATELY PRECEDED * 26391C ** AND SUCCEEDED BY A NON-BLANK CHARACTER * 26392C ** WILL ALSO BE CONSIDERED AS A SEPARATOR * 26393C ** AND SO WILL NOT BE COPIED AS A CHARACTER. * 26394C ** HOWEVER, IF THERE IS A BLANK BEFORE OR AFTER THE * 26395C ** HYPEN (AS IN DEFINING THE - AS A PLOT CHARACTER* 26396C ** TYPE), THEN THE HYPHEN WILL BE TREATED AND COPIED * 26397C ** AS A SEPARATE COMPONENT. * 26398C ** OCTOBER 1997: CHECK FOR EXPONENTIAL NOTATION, I.E. * 26399C ** 1.2E02, 1.2E-02, 1.2E+02, 1.2D02, 1.2D-02, 1.2D+02 26400C ** TREAT THE CASE WHERE THE ORIGINAL LINE IANSLC(.) WAS NON-EMP 26401C ** LOCATE THE START AND STOP COLUMNS FOR EACH 'WORD'. * 26402C ********************************************************** 26403C 26404 ISTEPN='2' 26405 IF(IBUGTY.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 26406C 26407 NUMWD=0 26408 DO300I=1,IWIDTH 26409 IM1=I-1 26410 IM2=I-2 26411 IP1=I+1 26412C 26413 IF(IEQUCL.EQ.'ON'.AND.IANSLC(I).EQ.'=')GOTO350 26414 IF(IHOST1.EQ.'HONE')THEN 26415 IF(IANSLC(I).EQ.'>')GOTO350 26416 IF(IANSLC(I).EQ.'<')GOTO350 26417 ENDIF 26418C ADD "<> " CASE 26419 IF(I.GT.1.AND.IANSLC(I).EQ.'>'.AND.IANSLC(I-1).EQ.'<')GOTO300 26420C 26421CCCCC THE FOLLOWING LINE WAS COMMENTED OUT AUGUST 1990 26422CCCCC DUE TO BOMB ON HONEYWELL/PRIME WHEN TRYING TO EXECUTE AUGUST 1990 26423CCCCC CALL DATAPLOT>DPSYSF.TEX (> IS A DIRECTORY SYMBOL AUGUST 1990 26424CCCCC ON HONEYWELL AND PRIME) AUGUST 1990 26425CCCCC IF(IANSLC(I).EQ.'>')GOTO350 26426 IF(IANSLC(I).EQ.'<'.AND.IANSLC(I+1).EQ.'>')GOTO345 26427C 26428CCCCC THE FOLLOWING LINE WAS COMMENTED OUT AUGUST 1990 26429CCCCC TO PARALLEL THE COMMENTING OUT FOR > 2 LINES ABOVE AUGUST 1990 26430CCCCC IF(IANSLC(I).EQ.'<')GOTO350 26431C 26432 IF(IANSLC(I).NE.' '.AND.I.LE.1)GOTO350 26433C 26434 IF(I.LE.1)GOTO360 26435 IF(IANSLC(I).NE.' '.AND.IANSLC(IM1).EQ.' ')GOTO350 26436 IF(IEQUCL.EQ.'ON'.AND.IANSLC(I).NE.' '.AND. 26437 1 IANSLC(IM1).EQ.'=')GOTO350 26438 IF(IHOST1.EQ.'HONE')THEN 26439 IF(IANSLC(I).NE.' '.AND.IANSLC(IM1).EQ.'>')GOTO350 26440 IF(IANSLC(I).NE.' '.AND.IANSLC(IM1).EQ.'<')GOTO350 26441 ENDIF 26442C 26443 IF(I.LE.2)GOTO360 26444C 26445CCCCC OCTOBER 1997. CHECK FOR EXPONENTIAL NOTATION, 26446CCCCC I.E., IF "-" IS PRECEDED BY AN "E" AND SUCCEDED 26447CCCCC BY ANUMBER. 26448C 26449 IF(IANSLC(IM1).EQ.'-')THEN 26450 IF(IANSLC(IM2).EQ.'E' .OR. IANSLC(IM2).EQ.'e')THEN 26451 CALL DPCOAN(IANSLC(I),IJUNK) 26452 IF(IJUNK.GE.48 .AND. IJUNK.LE.57)GOTO370 26453 ENDIF 26454 ENDIF 26455C 26456 IF(IHYPCL.EQ.'ON'.AND.IANSLC(I).NE.' '.AND. 26457 1 IANSLC(IM1).EQ.'-')GOTO340 26458 IF(ICOMCL.EQ.'ON'.AND.IANSLC(I).NE.' '.AND. 26459 1 IANSLC(IM1).EQ.',')GOTO340 26460 GOTO360 26461C 26462 340 CONTINUE 26463 IF(IEQUCL.EQ.'ON'.AND.IANSLC(IM2).EQ.'=')GOTO360 26464 IF(IHYPCL.EQ.'ON'.AND.IANSLC(IM2).EQ.'-')GOTO355 26465 IF(ICOMCL.EQ.'ON'.AND.IANSLC(IM2).EQ.',')GOTO355 26466 IF(IANSLC(IM2).NE.' ')GOTO350 26467 GOTO360 26468C 26469C ADD "<> " CASE 26470 345 CONTINUE 26471 NUMWD=NUMWD+1 26472 ISTART(NUMWD)=I 26473 ISTOP(NUMWD)=I+1 26474 GOTO390 26475C END ADD 26476 350 CONTINUE 26477 NUMWD=NUMWD+1 26478C 26479 355 CONTINUE 26480 ISTART(NUMWD)=I 26481C 26482 360 CONTINUE 26483 IF(IEQUCL.EQ.'ON'.AND.IANSLC(I).EQ.'=')GOTO370 26484CCCCC IF(IANSLC(I).EQ.'>')GOTO370 26485CCCCC IF(IANSLC(I).EQ.'<')GOTO370 26486 IF(IANSLC(I).NE.' '.AND.I.GE.IWIDTH)GOTO370 26487C 26488 IF(I.GE.IWIDTH)GOTO390 26489 IF(IANSLC(I).NE.' '.AND.IANSLC(IP1).EQ.' ')GOTO370 26490 IF(IEQUCL.EQ.'ON'.AND.IANSLC(I).NE.' '.AND. 26491 1 IANSLC(IP1).EQ.'=')GOTO370 26492CCCCC IF(IANSLC(I).NE.' '.AND.IANSLC(IP1).EQ.'>')GOTO370 26493CCCCC IF(IANSLC(I).NE.' '.AND.IANSLC(IP1).EQ.'<')GOTO370 26494 IF(IHYPCL.EQ.'ON'.AND.IANSLC(I).NE.' '.AND. 26495 1 IANSLC(IP1).EQ.'-')GOTO370 26496 IF(ICOMCL.EQ.'ON'.AND.IANSLC(I).NE.' '.AND. 26497 1 IANSLC(IP1).EQ.',')GOTO370 26498C 26499 GOTO390 26500C 26501 370 CONTINUE 26502 ISTOP(NUMWD)=I 26503C 26504 390 CONTINUE 26505C 26506 IF(IBUGTY.EQ.'ON')THEN 26507 WRITE(ICOUT,391)NUMWD 26508 391 FORMAT('NUMWD = ',I8) 26509 CALL DPWRST('XXX','BUG ') 26510 IF(NUMWD.GE.1)THEN 26511 WRITE(ICOUT,392)I,NUMWD,ISTART(NUMWD),ISTOP(NUMWD) 26512 392 FORMAT('I,NUMWD,ISTART(NUMWD),ISTOP(NUMWD) = ',4I8) 26513 CALL DPWRST('XXX','BUG ') 26514 ENDIF 26515 ENDIF 26516C 26517 300 CONTINUE 26518 IF(NUMWD.LE.0)GOTO9000 26519C 26520C *********************************************************** 26521C ** STEP 3-- ** 26522C ** CONVERT THE FIRST STRING TO A COMMAND ** 26523C ** EXTRACT THE FIRST 4 CHARACTERS OF ** 26524C ** THE COMMAND. PACK THESE 4 CHARACTERS ** 26525C ** INTO THE HOLLERITH VARIABLE ICOM. ** 26526C ** ONLY 4 CHARACTERS ARE RETAINED ** 26527C ** REGARDLESS OF THE MAX NUMBER OF ** 26528C ** CHARACTERS PER WORD ON A GIVEN ** 26529C ** COMPUTER (E.G., EVEN THOUGH UNIVAC ** 26530C ** COULD RETAIN 6 CHARACTERS PER WORD, ** 26531C ** IT IS SUFFICIENT TO RETAIN ** 26532C ** ONLY 4 CHARACTERS PER WORD--ON A UNIVAC ** 26533C ** OR ANY OTHER COMPUTER. ** 26534C ** OR ANY OTHER COMPUTER. ** 26535C ** ALSO, IF THE NUMBER OF CHARACTERS ** 26536C ** IN THE FIRST WORD IS 5 OR MORE, ** 26537C ** THEN PACK CHARACTERS 5 THROUGH 8 ** 26538C ** (OR CHARACTERS 5 THROUGH THE END OF THE WORD ** 26539C ** IF THE END OF THE WORD IS BEFORE CHARACTER 8) ** 26540C ** INTO THE 4-CHARACTER WORD ICOM2. ** 26541C *********************************************************** 26542C 26543 ISTEPN='3' 26544 IF(IBUGTY.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 26545C 26546 IWORD=1 26547 IWID=ISTOP(IWORD)-ISTART(IWORD)+1 26548 JMIN=ISTART(IWORD) 26549 JMAX=ISTOP(IWORD) 26550 I=0 26551 DO800J=JMIN,JMAX 26552 I=I+1 26553 IB(I)=IANSLC(J) 26554 800 CONTINUE 26555C 26556 IANS1=' ' 26557 IANS2=' ' 26558 IMAX=2*NUMASC 26559 IF(IWID.LT.IMAX)IMAX=IWID 26560C 26561 IF(IBUGTY.EQ.'ON')THEN 26562 WRITE(ICOUT,901)IMAX 26563 901 FORMAT('IMAX = ',I6) 26564 CALL DPWRST('XXX','BUG ') 26565 ENDIF 26566C 26567 DO900I=1,IMAX 26568 IF(IB(I).EQ.' ')GOTO910 26569 IM4=I-4 26570 IF(I.LE.NUMASC)IANS1(I:I)=IB(I) 26571 IF(I.GT.NUMASC)IANS2(IM4:IM4)=IB(I) 26572 900 CONTINUE 26573 910 CONTINUE 26574 ICOMLC=IANS1 26575 ICOML2=IANS2 26576 CALL DPUPP4(ICOMLC,ICOM,IBUGTY,IERROR) 26577 CALL DPUPP4(ICOML2,ICOM2,IBUGTY,IERROR) 26578C 26579C ******************************************** 26580C ** STEP 4-- ** 26581C ** CONVERT STRINGS 2 THROUGH END ** 26582C ** TO HOLLERITH A4 ARGUMENTS. ** 26583C ** IF MORE THAN 8 CHARACTERS, ** 26584C ** CONVERT ONLY THE FIRST 8 CHARACTERS ** 26585C ** (REGARDLESS OF THE COMPUTER TYPE). ** 26586C ******************************************** 26587C 26588 ISTEPN='4' 26589 IF(IBUGTY.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 26590C 26591 NUMARG=NUMWD-1 26592 IF(NUMWD.LE.1)GOTO1999 26593 DO1000IWORD=2,NUMWD 26594 IWID=ISTOP(IWORD)-ISTART(IWORD)+1 26595C 26596 JMIN=ISTART(IWORD) 26597 JMAX=ISTOP(IWORD) 26598 I=0 26599 DO1100J=JMIN,JMAX 26600 I=I+1 26601 IB(I)=IANSLC(J) 26602 1100 CONTINUE 26603C 26604 IANS1=' ' 26605 IANS2=' ' 26606 IMAX=2*NUMASC 26607 IF(IWID.LT.IMAX)IMAX=IWID 26608 DO1200I=1,IMAX 26609 IF(IB(I).EQ.' ')GOTO1210 26610 IM4=I-4 26611 IF(I.LE.NUMASC)IANS1(I:I)=IB(I) 26612 IF(I.GT.NUMASC)IANS2(IM4:IM4)=IB(I) 26613 1200 CONTINUE 26614 1210 CONTINUE 26615 IWORM1=IWORD-1 26616 IHARLC(IWORM1)=IANS1 26617 IHARL2(IWORM1)=IANS2 26618C 26619 1000 CONTINUE 26620 1999 CONTINUE 26621C 26622C ********************************************************** 26623C ** STEP 4.5-- ** 26624C ** CONVERT EACH ARGUMENT TO UPPER CASE. ** 26625C ********************************************************** 26626C 26627 ISTEPN='4.5' 26628 IF(IBUGTY.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 26629C 26630 IF(NUMARG.LE.0)GOTO1390 26631 DO1300I=1,NUMARG 26632 CALL DPUPP4(IHARLC(I),IHARG(I),IBUGTY,IERROR) 26633 CALL DPUPP4(IHARL2(I),IHARG2(I),IBUGTY,IERROR) 26634 1300 CONTINUE 26635 1390 CONTINUE 26636C 26637C ********************************************************** 26638C ** STEP 5-- ** 26639C ** CONVERT STRINGS 1 THROUGH END TO INTEGER ARGUMENTS ** 26640C ********************************************************** 26641C 26642 ISTEPN='5' 26643 IF(IBUGTY.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 26644C 26645 IF(NUMWD.LE.0)GOTO2999 26646 DO2000IWORD=1,NUMWD 26647 IWORM1=IWORD-1 26648C 26649 IF(IWORD.LE.1)THEN 26650 IH=ICOM 26651 IH2=ICOM2 26652 ELSE 26653 IH=IHARG(IWORM1) 26654 IH2=IHARG2(IWORM1) 26655 ENDIF 26656C 26657 IF(NUMNAM.LE.0)GOTO2040 26658 DO2010INAME=1,NUMNAM 26659 IF(IH.EQ.IHNAME(INAME).AND.IH2.EQ.IHNAM2(INAME))THEN 26660 IF(IUSE(INAME).EQ.'P')THEN 26661 IF(IWORM1.GT.0)IARGT(IWORM1)='NUMB' 26662 IF(IWORM1.GT.0)IARG(IWORM1)=IVALUE(INAME) 26663 GOTO2000 26664 ELSE 26665 GOTO2040 26666 ENDIF 26667 ENDIF 26668 2010 CONTINUE 26669 2040 CONTINUE 26670C 26671 IFLUNK='NO' 26672 IANS3=(-1) 26673 IWID=ISTOP(IWORD)-ISTART(IWORD)+1 26674 JMIN=ISTART(IWORD) 26675 JMAX=ISTOP(IWORD) 26676 I=0 26677 DO2100J=JMIN,JMAX 26678 I=I+1 26679 IB(I)=IANSLC(J) 26680 2100 CONTINUE 26681C 26682 IDIG=0 26683 ISIGN=0 26684 IDECP2=0 26685 ISUM=0 26686 DO2700I=1,IWID 26687 IREV=IWID-I+1 26688 IF(IB(IREV).EQ.' ')THEN 26689 GOTO2700 26690 ELSEIF(IB(IREV).EQ.'0')THEN 26691 ITERM=0 26692 GOTO2725 26693 ELSEIF(IB(IREV).EQ.'1')THEN 26694 ITERM=1 26695 GOTO2725 26696 ELSEIF(IB(IREV).EQ.'2')THEN 26697 ITERM=2 26698 GOTO2725 26699 ELSEIF(IB(IREV).EQ.'3')THEN 26700 ITERM=3 26701 GOTO2725 26702 ELSEIF(IB(IREV).EQ.'4')THEN 26703 ITERM=4 26704 GOTO2725 26705 ELSEIF(IB(IREV).EQ.'5')THEN 26706 ITERM=5 26707 GOTO2725 26708 ELSEIF(IB(IREV).EQ.'6')THEN 26709 ITERM=6 26710 GOTO2725 26711 ELSEIF(IB(IREV).EQ.'7')THEN 26712 ITERM=7 26713 GOTO2725 26714 ELSEIF(IB(IREV).EQ.'8')THEN 26715 ITERM=8 26716 GOTO2725 26717 ELSEIF(IB(IREV).EQ.'9')THEN 26718 ITERM=9 26719 GOTO2725 26720 ELSEIF(IB(IREV).EQ.'+')THEN 26721 ISIGN=ISIGN+1 26722 GOTO2700 26723 ELSEIF(IB(IREV).EQ.'-')THEN 26724 ISIGN=ISIGN+1 26725 ISUM=-ISUM 26726 GOTO2700 26727 ELSEIF(IB(IREV).EQ.'.')THEN 26728 IDECP2=IDECP2+1 26729 IF(IDECP2.EQ.1.AND.IDIG.EQ.0)GOTO2700 26730 GOTO2800 26731 ELSE 26732 IFLUNK='YES' 26733 GOTO2800 26734 ENDIF 26735C 26736 2725 CONTINUE 26737 IDIG=IDIG+1 26738 IF(IDIG.EQ.1)THEN 26739 ISUM=ISUM+ITERM 26740 ELSE 26741CCCCC FOLLOWING FIXES WHAT APPEARS TO BE COMPILER BUG ON LAHEY 95 26742CCCCC COMPILER. MAY 2001 26743CCCCC SPECIFICALLY, 10**IPOW SEEMS TO RETURN A 0. 26744CCCCC ISUM=ISUM+ITERM*10**(IDIG-1) 26745 ITERM1=IDIG-1 26746 ITERM2=INT(10.0**ITERM1 + 0.01) 26747 ISUM=ISUM+ITERM*ITERM2 26748 ENDIF 26749C 26750 2700 CONTINUE 26751 IF(IDIG.LE.0)GOTO2800 26752 IF(ISIGN.GE.2)GOTO2800 26753 IANS3=ISUM 26754C 26755 2800 CONTINUE 26756 IWORM1=IWORD-1 26757 IF(IWORD.LE.1)ICOMI=IANS3 26758 IF(IWORD.GE.2)IARG(IWORM1)=IANS3 26759 IF(IWORD.LE.1.AND.IFLUNK.EQ.'YES')ICOMT='WORD' 26760 IF(IWORD.GE.2.AND.IFLUNK.EQ.'YES')IARGT(IWORM1)='WORD' 26761 2000 CONTINUE 26762 2999 CONTINUE 26763C 26764C *************************************************************** 26765C ** STEP 6-- ** 26766C ** CONVERT STRINGS 2 THROUGH N TO FLOATING POINT ARGUMENTS ** 26767C *************************************************************** 26768C 26769 ISTEPN='6' 26770 IF(IBUGTY.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 26771C 26772C ************************************************************ 26773C ** STEP 6.1-- ** 26774C ** FIRST OF ALL, LOCATE THE DECIMAL POINT (IF EXISTENT) ** 26775C ** OCTOBER 1997. CHECK FOR EXPONENTIAL NOTATION. I.E. ** 26776C ** 1.2E02, 1.2E-02, 1.2E+02 ** 26777C ************************************************************ 26778C 26779 ISTEPN='6.1' 26780 IF(IBUGTY.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 26781C 26782CCCCC OCTOBER 1997. FOR EXPONENTIAL NOTATION, NEED TO ALLOW LARGER NUMBERS 26783CCCCC AMIN=-1000000. 26784CCCCC AMAX=+1000000. 26785 AMIN=CPUMIN 26786 AMAX=CPUMAX 26787 NUMARG=NUMWD-1 26788CCCCC IF(NUMARG.LE.0)GOTO3999 26789 IF(NUMWD.LE.0)GOTO3999 26790 DO3000IWORD=1,NUMWD 26791C 26792 IWORM1=IWORD-1 26793 IF(IWORD.LE.1)THEN 26794 IH=ICOM 26795 IH2=ICOM2 26796 ELSE 26797 IH=IHARG(IWORM1) 26798 IH2=IHARG2(IWORM1) 26799 ENDIF 26800C 26801 IF(NUMNAM.LE.0)GOTO3040 26802 DO3010INAME=1,NUMNAM 26803 IF(IH.EQ.IHNAME(INAME).AND.IH2.EQ.IHNAM2(INAME))THEN 26804 IF(IUSE(INAME).EQ.'P')THEN 26805 IF(IWORD.LE.1)ICOMT='NUMB' 26806 IF(IWORD.GE.2)IARGT(IWORM1)='NUMB' 26807 IF(IWORD.LE.1)ACOM=VALUE(INAME) 26808 IF(IWORD.GE.2)ARG(IWORM1)=VALUE(INAME) 26809 GOTO3000 26810 ELSE 26811 GOTO3040 26812 ENDIF 26813 ENDIF 26814 3010 CONTINUE 26815 3040 CONTINUE 26816C 26817 IFLUNK='NO' 26818 ANS2=(-1.0) 26819 IWID=ISTOP(IWORD)-ISTART(IWORD)+1 26820 JMIN=ISTART(IWORD) 26821 JMAX=ISTOP(IWORD) 26822 I=0 26823 DO3050J=JMIN,JMAX 26824 I=I+1 26825 IB(I)=IANSLC(J) 26826 3050 CONTINUE 26827C 26828 ILOC=0 26829 IDECP2=0 26830 ILOCE=0 26831 IEXPPT=0 26832 DO3060I=1,IWID 26833 IF(IB(I).EQ.'.')ILOC=I 26834 IF(IB(I).EQ.'.')IDECP2=IDECP2+1 26835 IF(IB(I).EQ.'E'.OR.IB(I).EQ.'e')ILOCE=I 26836 IF(IB(I).EQ.'E'.OR.IB(I).EQ.'e')IEXPPT=IEXPPT+1 26837 3060 CONTINUE 26838 IF(IDECP2.GE.2)GOTO3900 26839 IF(IEXPPT.GE.2)GOTO3900 26840C 26841 IESCAL=0 26842 IESIGN=1 26843 IWID2=IWID 26844 IF(ILOCE+1.GT.IWID)THEN 26845 IFLUNK='YES' 26846 GOTO3900 26847 ENDIF 26848 IF(IEXPPT.EQ.1)THEN 26849 IWID=ILOCE-1 26850 IF(IB(ILOCE+1).EQ.'-')THEN 26851 IESIGN=-1 26852 ISTRT2=ILOCE+2 26853 ELSEIF(IB(ILOCE+1).EQ.'+')THEN 26854 IESIGN=1 26855 ISTRT2=ILOCE+2 26856 ELSE 26857 IESIGN=1 26858 ISTRT2=ILOCE+1 26859 ENDIF 26860 ICOUNT=0 26861 ICJUNK=' ' 26862 IF(ISTRT2.GT.IWID2)THEN 26863 IFLUNK='YES' 26864 GOTO3900 26865 ENDIF 26866 DO13065I=ISTRT2,IWID2 26867 IF(IB(I).EQ.' ')GOTO13065 26868 IF(IB(I).EQ.'0')GOTO13060 26869 IF(IB(I).EQ.'1')GOTO13060 26870 IF(IB(I).EQ.'2')GOTO13060 26871 IF(IB(I).EQ.'3')GOTO13060 26872 IF(IB(I).EQ.'4')GOTO13060 26873 IF(IB(I).EQ.'5')GOTO13060 26874 IF(IB(I).EQ.'6')GOTO13060 26875 IF(IB(I).EQ.'7')GOTO13060 26876 IF(IB(I).EQ.'8')GOTO13060 26877 IF(IB(I).EQ.'9')GOTO13060 26878 IFLUNK='YES' 26879 GOTO3900 26880C 2688113060 CONTINUE 26882 ICOUNT=ICOUNT+1 26883 ICJUNK(ICOUNT:ICOUNT)=IB(I)(1:1) 26884C 2688513065 CONTINUE 26886CCCCC FOLLOWING TO ADDRESS BUG ON SUN. OCTOBER 2001. 26887 IFRMT(1:5)='(I )' 26888 IF(ICOUNT.LE.9)THEN 26889 WRITE(IFRMT(3:3),'(I1)')ICOUNT 26890 ELSE 26891 WRITE(IFRMT(3:4),'(I2)')ICOUNT 26892 ENDIF 26893 READ(ICJUNK(1:ICOUNT),IFRMT)IESCAL 26894 ENDIF 26895C 26896 IF(IDECP2.EQ.1)GOTO3150 26897 DO3100I=1,IWID 26898 IREV=IWID-I+1 26899 IF(IB(IREV).EQ.' ')GOTO3100 26900 IF(IB(IREV).EQ.'0' .OR. IB(IREV).EQ.'1' .OR. 26901 1 IB(IREV).EQ.'2' .OR. IB(IREV).EQ.'3' .OR. 26902 1 IB(IREV).EQ.'4' .OR. IB(IREV).EQ.'5' .OR. 26903 1 IB(IREV).EQ.'6' .OR. IB(IREV).EQ.'7' .OR. 26904 1 IB(IREV).EQ.'8' .OR. IB(IREV).EQ.'9')THEN 26905 GOTO3110 26906 ENDIF 26907 IFLUNK='YES' 26908 IF(IB(IREV).EQ.'+')GOTO3900 26909 IF(IB(IREV).EQ.'-')GOTO3900 26910 GOTO3900 26911C 26912 3100 CONTINUE 26913 IFLUNK='YES' 26914 GOTO3900 26915C 26916 3110 ILOC=IREV+1 26917 3150 CONTINUE 26918C 26919 IF(IBUGTY.NE.'OFF')THEN 26920 WRITE(ICOUT,3111)ILOC,IDECP2 26921 3111 FORMAT('ILOC = ',I8,' IDECP2 = ',I8) 26922 CALL DPWRST('XXX','BUG ') 26923 ENDIF 26924C 26925C ******************************************************* 26926C ** STEP 6.2-- ** 26927C ** SECONDLY, COMPUTE THE INTEGER PART OF THE VALUE ** 26928C ******************************************************* 26929C 26930 ISTEPN='6.2' 26931 IF(IBUGTY.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 26932C 26933 SIGN=1.0 26934 IDIGI=0 26935 ISIGN=0 26936 SUMI=0 26937 ILOCM1=ILOC-1 26938 IF(ILOCM1.LT.1)GOTO3250 26939 DO3200I=1,ILOCM1 26940 IREV=ILOCM1-I+1 26941 IF(IB(IREV).EQ.' ')THEN 26942 GOTO3200 26943 ELSEIF(IB(IREV).EQ.'0')THEN 26944 ITERM=0 26945 GOTO3225 26946 ELSEIF(IB(IREV).EQ.'1')THEN 26947 ITERM=1 26948 GOTO3225 26949 ELSEIF(IB(IREV).EQ.'2')THEN 26950 ITERM=2 26951 GOTO3225 26952 ELSEIF(IB(IREV).EQ.'3')THEN 26953 ITERM=3 26954 GOTO3225 26955 ELSEIF(IB(IREV).EQ.'4')THEN 26956 ITERM=4 26957 GOTO3225 26958 ELSEIF(IB(IREV).EQ.'5')THEN 26959 ITERM=5 26960 GOTO3225 26961 ELSEIF(IB(IREV).EQ.'6')THEN 26962 ITERM=6 26963 GOTO3225 26964 ELSEIF(IB(IREV).EQ.'7')THEN 26965 ITERM=7 26966 GOTO3225 26967 ELSEIF(IB(IREV).EQ.'8')THEN 26968 ITERM=8 26969 GOTO3225 26970 ELSEIF(IB(IREV).EQ.'9')THEN 26971 ITERM=9 26972 GOTO3225 26973 ELSEIF(IB(IREV).EQ.'+')THEN 26974 ISIGN=ISIGN+1 26975 GOTO3200 26976 ELSEIF(IB(IREV).EQ.'-')THEN 26977 ISIGN=ISIGN+1 26978 SIGN=-SIGN 26979 GOTO3200 26980 ELSE 26981 IFLUNK='YES' 26982 GOTO3900 26983 ENDIF 26984C 26985 3225 CONTINUE 26986 IDIGI=IDIGI+1 26987 TERM=ITERM 26988 IEXP=IDIGI-1 26989 SUMI=SUMI+TERM*(10.0 **IEXP) 26990 3200 CONTINUE 26991 3250 CONTINUE 26992 IF(ISIGN.GE.2)GOTO3900 26993C 26994 IF(IBUGTY.NE.'OFF')THEN 26995 WRITE(ICOUT,3255)IDIGI,SUMI 26996 3255 FORMAT('IDIGI = ',I8,' SUMI = ',F20.10) 26997 CALL DPWRST('XXX','BUG ') 26998 ENDIF 26999C 27000C ****************************************************** 27001C ** STEP 6.3-- ** 27002C ** THIRDLY, COMPUTE THE DECIMAL PART OF THE VALUE ** 27003C ****************************************************** 27004C 27005 ISTEPN='6.3' 27006 IF(IBUGTY.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 27007C 27008 IDIGD=0 27009 SUMD=0.0 27010 ILOCP1=ILOC+1 27011 IF(ILOCP1.GT.IWID)GOTO3350 27012 DO3300I=ILOCP1,IWID 27013 IF(IB(I).EQ.' ')THEN 27014 GOTO3300 27015 ELSEIF(IB(I).EQ.'0')THEN 27016 ITERM=0 27017 GOTO3325 27018 ELSEIF(IB(I).EQ.'1')THEN 27019 ITERM=1 27020 GOTO3325 27021 ELSEIF(IB(I).EQ.'2')THEN 27022 ITERM=2 27023 GOTO3325 27024 ELSEIF(IB(I).EQ.'3')THEN 27025 ITERM=3 27026 GOTO3325 27027 ELSEIF(IB(I).EQ.'4')THEN 27028 ITERM=4 27029 GOTO3325 27030 ELSEIF(IB(I).EQ.'5')THEN 27031 ITERM=5 27032 GOTO3325 27033 ELSEIF(IB(I).EQ.'6')THEN 27034 ITERM=6 27035 GOTO3325 27036 ELSEIF(IB(I).EQ.'7')THEN 27037 ITERM=7 27038 GOTO3325 27039 ELSEIF(IB(I).EQ.'8')THEN 27040 ITERM=8 27041 GOTO3325 27042 ELSEIF(IB(I).EQ.'9')THEN 27043 ITERM=9 27044 GOTO3325 27045 ELSE 27046 IFLUNK='YES' 27047 GOTO3900 27048 ENDIF 27049C 27050 3325 IDIGD=IDIGD+1 27051 TERM=ITERM 27052 SUMD=SUMD+TERM/(10.0**IDIGD) 27053C 27054 3300 CONTINUE 27055 3350 CONTINUE 27056C 27057 IF(IBUGTY.EQ.'ON')THEN 27058 WRITE(ICOUT,3355)IDIGD,SUMD 27059 3355 FORMAT('IDIGD = ',I8,' SUMD = ',F20.10) 27060 CALL DPWRST('XXX','BUG ') 27061 ENDIF 27062C 27063 IDIGT=IDIGI+IDIGD 27064 IF(IDIGT.LE.0)GOTO3900 27065 ANS2=SUMI+SUMD 27066 IF(SIGN.LT.0.0)ANS2=-ANS2 27067 ANS2=ANS2*10.0**(IESIGN*IESCAL) 27068 IWORM1=IWORD-1 27069 IF(IWORD.LE.1)ACOM=ANS2 27070 IF(IWORD.GE.2)ARG(IWORM1)=ANS2 27071CCCC OCTOBER 1997. IF EXPONENTIAL NUMBER, NEED TO RESET IARGT 27072 IF(AMIN.LE.ANS2.AND.ANS2.LE.AMAX)THEN 27073 IF(IWORM1.GE.1)IARGT(IWORM1)='NUMB' 27074 GOTO3000 27075 ELSE 27076 GOTO3900 27077 ENDIF 27078C 27079 3900 CONTINUE 27080 IF(IWORM1.LT.1) GOTO 3000 27081 IWORM1=IWORD-1 27082 ARG(IWORM1)=ANS2 27083 IF(IFLUNK.EQ.'YES')IARGT(IWORM1)='WORD' 27084 3000 CONTINUE 27085 3999 CONTINUE 27086C 27087C ***************** 27088C ** STEP 90-- ** 27089C ** EXIT ** 27090C ***************** 27091C 27092 9000 CONTINUE 27093 IF(IBUGTY.EQ.'ON')THEN 27094 WRITE(ICOUT,999) 27095 CALL DPWRST('XXX','BUG ') 27096 WRITE(ICOUT,9011) 27097 9011 FORMAT('***** AT THE END OF DPTYPE--') 27098 CALL DPWRST('XXX','BUG ') 27099 WRITE(ICOUT,9012)ICOM,ICOM2,ICOMT,ACOM,ICOMI 27100 9012 FORMAT('ICOM,ICOM2,ICOMT,ACOM,ICOMI = ', 27101 1 2(A4,2X),A4,E15.7,I8) 27102 CALL DPWRST('XXX','BUG ') 27103 WRITE(ICOUT,9013)ICOMLC,ICOML2,NUMARG 27104 9013 FORMAT('ICOMLC,ICOML2,NUMARG = ',2(A4,2X),I8) 27105 CALL DPWRST('XXX','BUG ') 27106 DO9015I=1,NUMARG 27107 WRITE(ICOUT,9016)I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) 27108 9016 FORMAT('I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) = ', 27109 1 I6,2(1X,A4),1X,I6,1X,E15.7,1X,A4) 27110 CALL DPWRST('XXX','BUG ') 27111 WRITE(ICOUT,9017)I,IHARLC(I),IHARL2(I) 27112 9017 FORMAT('I,IHARLC(I),IHARL2(I) = ',I6,1X,A4,1X,A4) 27113 CALL DPWRST('XXX','BUG ') 27114 9015 CONTINUE 27115 WRITE(ICOUT,9021)IHOST1,IHOST2 27116 9021 FORMAT('IHOST1,IHOST2 = ',A4,2X,A4) 27117 CALL DPWRST('XXX','BUG ') 27118 ENDIF 27119C 27120 RETURN 27121 END 27122