1 SUBROUTINE DPRTL(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 2 1 IBUGD2,IFOUND,IERROR) 3C 4C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 5C FOR ROMAN TRIPLEX LOWER CASE. 6C WRITTEN BY--JAMES J. FILLIBEN 7C STATISTICAL ENGINEERING DIVISION 8C INFORMATION TECHNOLOGY LABORATORY 9C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10C GAITHERSBURG, MD 20899-8980 11C PHONE--301-975-2899 12C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 14C LANGUAGE--ANSI FORTRAN (1977) 15C VERSION NUMBER--87/4 16C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 17C UPDATED --MAY 1982. 18C UPDATED --MARCH 1987. 19C 20C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 21C 22 CHARACTER*4 ICHAR2 23 CHARACTER*4 IOP 24 CHARACTER*4 IBUGD2 25 CHARACTER*4 IFOUND 26 CHARACTER*4 IERROR 27C 28C--------------------------------------------------------------------- 29C 30 DIMENSION IOP(*) 31 DIMENSION X(*) 32 DIMENSION Y(*) 33C 34C-----COMMON---------------------------------------------------------- 35C 36 INCLUDE 'DPCOP2.INC' 37C 38C-----START POINT----------------------------------------------------- 39C 40 IFOUND='NO' 41 IERROR='NO' 42C 43 NUMCO=1 44 ISTART=1 45 ISTOP=1 46 NC=1 47C 48C ****************************************** 49C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 50C ** HERSHEY CHARACTER SET CASE ** 51C ****************************************** 52C 53C 54 IF(IBUGD2.EQ.'OFF')GOTO90 55 WRITE(ICOUT,999) 56 999 FORMAT(1X) 57 CALL DPWRST('XXX','BUG ') 58 WRITE(ICOUT,51) 59 51 FORMAT('***** AT THE BEGINNING OF DPRTL--') 60 CALL DPWRST('XXX','BUG ') 61 WRITE(ICOUT,52)ICHAR2 62 52 FORMAT('ICHAR2 = ',A4) 63 CALL DPWRST('XXX','BUG ') 64 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 65 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 66 CALL DPWRST('XXX','BUG ') 67 90 CONTINUE 68C 69C ************************************************** 70C ** STEP 1-- ** 71C ** SEARCH FOR THE INPUT CHARACTER(S). ** 72C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** 73C ************************************************** 74C 75 CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND) 76 IF(IFOUND.EQ.'NO')GOTO9000 77C 78 IF(ICHARN.LE.6)GOTO1010 79 GOTO1019 80 1010 CONTINUE 81 CALL DRTL1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 82 1IBUGD2,IFOUND,IERROR) 83 GOTO9000 84 1019 CONTINUE 85C 86 IF(7.LE.ICHARN.AND.ICHARN.LE.12)GOTO1020 87 GOTO1029 88 1020 CONTINUE 89 CALL DRTL2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 90 1IBUGD2,IFOUND,IERROR) 91 GOTO9000 92 1029 CONTINUE 93C 94 IF(13.LE.ICHARN.AND.ICHARN.LE.18)GOTO1030 95 GOTO1039 96 1030 CONTINUE 97 CALL DRTL3(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 98 1IBUGD2,IFOUND,IERROR) 99 GOTO9000 100 1039 CONTINUE 101C 102 IF(ICHARN.GE.19)GOTO1040 103 GOTO1049 104 1040 CONTINUE 105 CALL DRTL4(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 106 1IBUGD2,IFOUND,IERROR) 107 GOTO9000 108 1049 CONTINUE 109C 110 IFOUND='NO' 111 GOTO9000 112C 113C ***************** 114C ** STEP 90-- ** 115C ** EXIT ** 116C ***************** 117C 118 9000 CONTINUE 119 IF(IBUGD2.EQ.'OFF')GOTO9090 120 WRITE(ICOUT,999) 121 CALL DPWRST('XXX','BUG ') 122 WRITE(ICOUT,9011) 123 9011 FORMAT('***** AT THE END OF DPRTL--') 124 CALL DPWRST('XXX','BUG ') 125 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 126 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 127 CALL DPWRST('XXX','BUG ') 128 WRITE(ICOUT,9013)ICHAR2,ICHARN 129 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) 130 CALL DPWRST('XXX','BUG ') 131 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 132 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 133 CALL DPWRST('XXX','BUG ') 134 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 135 DO9015I=1,NUMCO 136 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 137 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 138 CALL DPWRST('XXX','BUG ') 139 9015 CONTINUE 140 9019 CONTINUE 141 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 142 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 143 CALL DPWRST('XXX','BUG ') 144 9090 CONTINUE 145C 146 RETURN 147 END 148 SUBROUTINE DPRTN(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 149 1IBUGD2,IFOUND,IERROR) 150C 151C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 152C FOR ROMAN TRIPLEX NUMERIC. 153C WRITTEN BY--JAMES J. FILLIBEN 154C STATISTICAL ENGINEERING DIVISION 155C INFORMATION TECHNOLOGY LABORATORY 156C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 157C GAITHERSBURG, MD 20899-8980 158C PHONE--301-975-2899 159C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 160C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 161C LANGUAGE--ANSI FORTRAN (1977) 162C VERSION NUMBER--87/4 163C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 164C UPDATED --MAY 1982. 165C UPDATED --MARCH 1987. 166C 167C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 168C 169 CHARACTER*4 ICHAR2 170 CHARACTER*4 IOP 171 CHARACTER*4 IBUGD2 172 CHARACTER*4 IFOUND 173 CHARACTER*4 IERROR 174C 175C--------------------------------------------------------------------- 176C 177 DIMENSION IOP(*) 178 DIMENSION X(*) 179 DIMENSION Y(*) 180C 181C-----COMMON---------------------------------------------------------- 182C 183 INCLUDE 'DPCOP2.INC' 184C 185C-----START POINT----------------------------------------------------- 186C 187 IFOUND='NO' 188 IERROR='NO' 189C 190 NUMCO=1 191 ISTART=1 192 ISTOP=1 193 NC=1 194C 195C ****************************************** 196C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 197C ** HERSHEY CHARACTER SET CASE ** 198C ****************************************** 199C 200C 201 IF(IBUGD2.EQ.'OFF')GOTO90 202 WRITE(ICOUT,999) 203 999 FORMAT(1X) 204 CALL DPWRST('XXX','BUG ') 205 WRITE(ICOUT,51) 206 51 FORMAT('***** AT THE BEGINNING OF DPRTN--') 207 CALL DPWRST('XXX','BUG ') 208 WRITE(ICOUT,52)ICHAR2 209 52 FORMAT('ICHAR2 = ',A4) 210 CALL DPWRST('XXX','BUG ') 211 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 212 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 213 CALL DPWRST('XXX','BUG ') 214 90 CONTINUE 215C 216C ************************************************** 217C ** STEP 1-- ** 218C ** SEARCH FOR THE INPUT CHARACTER(S). ** 219C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** 220C ************************************************** 221C 222 CALL DPCHNU(ICHAR2,ICHARN,IBUGD2,IFOUND) 223 IF(IFOUND.EQ.'NO')GOTO9000 224C 225 IF(ICHARN.LE.6)GOTO1010 226 GOTO1019 227 1010 CONTINUE 228 CALL DRTN1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 229 1IBUGD2,IFOUND,IERROR) 230 GOTO9000 231 1019 CONTINUE 232C 233 IF(ICHARN.GE.7)GOTO1020 234 GOTO1029 235 1020 CONTINUE 236 CALL DRTN2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 237 1IBUGD2,IFOUND,IERROR) 238 GOTO9000 239 1029 CONTINUE 240C 241 IFOUND='NO' 242 GOTO9000 243C 244C ***************** 245C ** STEP 90-- ** 246C ** EXIT ** 247C ***************** 248C 249 9000 CONTINUE 250 IF(IBUGD2.EQ.'OFF')GOTO9090 251 WRITE(ICOUT,999) 252 CALL DPWRST('XXX','BUG ') 253 WRITE(ICOUT,9011) 254 9011 FORMAT('***** AT THE END OF DPRTN--') 255 CALL DPWRST('XXX','BUG ') 256 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 257 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 258 CALL DPWRST('XXX','BUG ') 259 WRITE(ICOUT,9013)ICHAR2,ICHARN 260 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) 261 CALL DPWRST('XXX','BUG ') 262 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 263 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 264 CALL DPWRST('XXX','BUG ') 265 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 266 DO9015I=1,NUMCO 267 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 268 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 269 CALL DPWRST('XXX','BUG ') 270 9015 CONTINUE 271 9019 CONTINUE 272 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 273 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 274 CALL DPWRST('XXX','BUG ') 275 9090 CONTINUE 276C 277 RETURN 278 END 279 SUBROUTINE DPRTS(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 280 1IBUGD2,IFOUND,IERROR) 281C 282C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 283C FOR ROMAN TRIPLEX SYMBOLS. 284C WRITTEN BY--JAMES J. FILLIBEN 285C STATISTICAL ENGINEERING DIVISION 286C INFORMATION TECHNOLOGY LABORATORY 287C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 288C GAITHERSBURG, MD 20899-8980 289C PHONE--301-975-2899 290C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 291C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 292C LANGUAGE--ANSI FORTRAN (1977) 293C VERSION NUMBER--87/4 294C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 295C UPDATED --MARCH 1982. 296C UPDATED --MARCH 1987. 297C UPDATED --MAY 1982. 298C 299C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 300C 301 CHARACTER*4 ICHAR2 302 CHARACTER*4 IOP 303 CHARACTER*4 IBUGD2 304 CHARACTER*4 IFOUND 305 CHARACTER*4 IERROR 306C 307C--------------------------------------------------------------------- 308C 309 DIMENSION IOP(*) 310 DIMENSION X(*) 311 DIMENSION Y(*) 312C 313C-----COMMON---------------------------------------------------------- 314C 315 INCLUDE 'DPCOP2.INC' 316C 317C-----START POINT----------------------------------------------------- 318C 319 IFOUND='NO' 320 IERROR='NO' 321C 322 NUMCO=1 323 ISTART=1 324 ISTOP=1 325 NC=1 326C 327C ****************************************** 328C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 329C ** HERSHEY CHARACTER SET CASE ** 330C ****************************************** 331C 332C 333 IF(IBUGD2.EQ.'OFF')GOTO90 334 WRITE(ICOUT,999) 335 999 FORMAT(1X) 336 CALL DPWRST('XXX','BUG ') 337 WRITE(ICOUT,51) 338 51 FORMAT('***** AT THE BEGINNING OF DPRTS--') 339 CALL DPWRST('XXX','BUG ') 340 WRITE(ICOUT,52)ICHAR2 341 52 FORMAT('ICHAR2 = ',A4) 342 CALL DPWRST('XXX','BUG ') 343 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 344 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 345 CALL DPWRST('XXX','BUG ') 346 90 CONTINUE 347C 348C ************************************************** 349C ** STEP 1-- ** 350C ** SEARCH FOR THE INPUT CHARACTER(S). ** 351C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** 352C ************************************************** 353C 354 CALL DPCHSY(ICHAR2,ICHARN,IBUGD2,IFOUND) 355 IF(IFOUND.EQ.'NO')GOTO9000 356C 357 IF(ICHARN.LE.8)GOTO1010 358 GOTO1019 359 1010 CONTINUE 360 CALL DRTS1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 361 1IBUGD2,IFOUND,IERROR) 362 GOTO9000 363 1019 CONTINUE 364C 365 IF(ICHARN.GE.9)GOTO1020 366 GOTO1029 367 1020 CONTINUE 368 CALL DRTS2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 369 1IBUGD2,IFOUND,IERROR) 370 GOTO9000 371 1029 CONTINUE 372C 373 IFOUND='NO' 374 GOTO9000 375C 376C ***************** 377C ** STEP 90-- ** 378C ** EXIT ** 379C ***************** 380C 381 9000 CONTINUE 382 IF(IBUGD2.EQ.'OFF')GOTO9090 383 WRITE(ICOUT,999) 384 CALL DPWRST('XXX','BUG ') 385 WRITE(ICOUT,9011) 386 9011 FORMAT('***** AT THE END OF DPRTS--') 387 CALL DPWRST('XXX','BUG ') 388 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 389 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 390 CALL DPWRST('XXX','BUG ') 391 WRITE(ICOUT,9013)ICHAR2,ICHARN 392 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) 393 CALL DPWRST('XXX','BUG ') 394 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 395 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 396 CALL DPWRST('XXX','BUG ') 397 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 398 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 399 DO9015I=1,NUMCO 400 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 401 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 402 CALL DPWRST('XXX','BUG ') 403 9015 CONTINUE 404 9019 CONTINUE 405 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 406 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 407 CALL DPWRST('XXX','BUG ') 408 9090 CONTINUE 409C 410 RETURN 411 END 412 SUBROUTINE DPRTU(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 413 1IBUGD2,IFOUND,IERROR) 414C 415C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 416C FOR ROMAN TRIPLEX UPPER CASE. 417C WRITTEN BY--JAMES J. FILLIBEN 418C STATISTICAL ENGINEERING DIVISION 419C INFORMATION TECHNOLOGY LABORATORY 420C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 421C GAITHERSBURG, MD 20899-8980 422C PHONE--301-975-2899 423C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 424C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 425C LANGUAGE--ANSI FORTRAN (1977) 426C VERSION NUMBER--87/4 427C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 428C UPDATED --MAY 1982. 429C UPDATED --MARCH 1987. 430C 431C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 432C 433 CHARACTER*4 ICHAR2 434 CHARACTER*4 IOP 435 CHARACTER*4 IBUGD2 436 CHARACTER*4 IFOUND 437 CHARACTER*4 IERROR 438C 439C--------------------------------------------------------------------- 440C 441 DIMENSION IOP(*) 442 DIMENSION X(*) 443 DIMENSION Y(*) 444C 445C-----COMMON---------------------------------------------------------- 446C 447 INCLUDE 'DPCOP2.INC' 448C 449C-----START POINT----------------------------------------------------- 450C 451 IFOUND='NO' 452 IERROR='NO' 453C 454 NUMCO=1 455 ISTART=1 456 ISTOP=1 457 NC=1 458C 459C ****************************************** 460C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 461C ** HERSHEY CHARACTER SET CASE ** 462C ****************************************** 463C 464C 465 IF(IBUGD2.EQ.'OFF')GOTO90 466 WRITE(ICOUT,999) 467 999 FORMAT(1X) 468 CALL DPWRST('XXX','BUG ') 469 WRITE(ICOUT,51) 470 51 FORMAT('***** AT THE BEGINNING OF DPRTU--') 471 CALL DPWRST('XXX','BUG ') 472 WRITE(ICOUT,52)ICHAR2 473 52 FORMAT('ICHAR2 = ',A4) 474 CALL DPWRST('XXX','BUG ') 475 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 476 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 477 CALL DPWRST('XXX','BUG ') 478 90 CONTINUE 479C 480C ************************************************** 481C ** STEP 1-- ** 482C ** SEARCH FOR THE INPUT CHARACTER(S). ** 483C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** 484C ************************************************** 485C 486 CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND) 487 IF(IFOUND.EQ.'NO')GOTO9000 488C 489 IF(ICHARN.LE.6)GOTO1010 490 GOTO1019 491 1010 CONTINUE 492 CALL DRTU1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 493 1IBUGD2,IFOUND,IERROR) 494 GOTO9000 495 1019 CONTINUE 496C 497 IF(7.LE.ICHARN.AND.ICHARN.LE.13)GOTO1020 498 GOTO1029 499 1020 CONTINUE 500 CALL DRTU2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 501 1IBUGD2,IFOUND,IERROR) 502 GOTO9000 503 1029 CONTINUE 504C 505 IF(14.LE.ICHARN.AND.ICHARN.LE.19)GOTO1030 506 GOTO1039 507 1030 CONTINUE 508 CALL DRTU3(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 509 1IBUGD2,IFOUND,IERROR) 510 GOTO9000 511 1039 CONTINUE 512C 513 IF(ICHARN.GE.20)GOTO1040 514 GOTO1049 515 1040 CONTINUE 516 CALL DRTU4(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 517 1IBUGD2,IFOUND,IERROR) 518 GOTO9000 519 1049 CONTINUE 520C 521 IFOUND='NO' 522 GOTO9000 523C 524C ***************** 525C ** STEP 90-- ** 526C ** EXIT ** 527C ***************** 528C 529 9000 CONTINUE 530 IF(IBUGD2.EQ.'OFF')GOTO9090 531 WRITE(ICOUT,999) 532 CALL DPWRST('XXX','BUG ') 533 WRITE(ICOUT,9011) 534 9011 FORMAT('***** AT THE END OF DPRTU--') 535 CALL DPWRST('XXX','BUG ') 536 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 537 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 538 CALL DPWRST('XXX','BUG ') 539 WRITE(ICOUT,9013)ICHAR2,ICHARN 540 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) 541 CALL DPWRST('XXX','BUG ') 542 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 543 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 544 CALL DPWRST('XXX','BUG ') 545 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 546 DO9015I=1,NUMCO 547 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 548 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 549 CALL DPWRST('XXX','BUG ') 550 9015 CONTINUE 551 9019 CONTINUE 552 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 553 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 554 CALL DPWRST('XXX','BUG ') 555 9090 CONTINUE 556C 557 RETURN 558 END 559 SUBROUTINE DPRUH1(P1,N1,P2,N2,P3,N3,ALPHA,ICASAN,IWRITE, 560 1 PVALUE,ALOWLM,AUPPLM, 561 1 IBUGA3,ISUBRO,IERROR) 562C 563C PURPOSE--FOR THREE BINOMIAL PROPORTIONS (P1, N1, P2, N2, P3, N3) 564C AND ALPHA, COMPUTE THE HYPOTHESIS TEST FOR: 565C 566C Ho: P1 = P2*P3 567C 568C AGAINST 569C 570C Ha: P1 <> P1*P2 571C Ha: P1 < P1*P2 572C Ha: P1 > P1*P2 573C 574C RETURN THE APPROPRIATE P-VALUE. 575C REFERENCE--PRIVATE COMMUNICATION WITH ANDREW RUHKIN OF THE 576C NIST STATISTICAL ENGINEERING DIVISION. 577C WRITTEN BY--JAMES J. FILLIBEN 578C STATISTICAL ENGINEERING DIVISION 579C INFORMATION TECHNOLOGY LABORATORY 580C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 581C GAITHERSBURG, MD 20899-8980 582C PHONE--301-975-2855 583C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 584C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 585C LANGUAGE--ANSI FORTRAN (1977) 586C VERSION NUMBER--2008/9 587C ORIGINAL VERSION--SEPTEMBER 2008. 588C 589C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 590C 591 CHARACTER*4 ICASAN 592 CHARACTER*4 IWRITE 593 CHARACTER*4 IBUGA3 594 CHARACTER*4 ISUBRO 595 CHARACTER*4 IERROR 596C 597 CHARACTER*4 ISUBN1 598 CHARACTER*4 ISUBN2 599C 600C--------------------------------------------------------------------- 601C 602 REAL P1 603 REAL P2 604 REAL P3 605 REAL ALPHA 606 REAL PVALUE 607 REAL ALOWLM 608 REAL AUPPLM 609 INTEGER N1 610 INTEGER N2 611 INTEGER N3 612C 613 DOUBLE PRECISION DTERM1 614 DOUBLE PRECISION DTERM2 615 DOUBLE PRECISION DTERM3 616 DOUBLE PRECISION DTERM4 617 DOUBLE PRECISION DP1 618 DOUBLE PRECISION DP2 619 DOUBLE PRECISION DP3 620 DOUBLE PRECISION DN1 621 DOUBLE PRECISION DN2 622 DOUBLE PRECISION DN3 623 DOUBLE PRECISION DPVAL 624 DOUBLE PRECISION DPPF 625C 626C-----COMMON---------------------------------------------------------- 627C 628 INCLUDE 'DPCOP2.INC' 629C 630C-----START POINT----------------------------------------------------- 631C 632 ISUBN1='DPRU' 633 ISUBN2='H1 ' 634 IERROR='NO' 635C 636 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RUH1')THEN 637 WRITE(ICOUT,999) 638 999 FORMAT(1X) 639 CALL DPWRST('XXX','BUG ') 640 WRITE(ICOUT,51) 641 51 FORMAT('***** AT THE BEGINNING OF DPRUH1--') 642 CALL DPWRST('XXX','BUG ') 643 WRITE(ICOUT,52)IBUGA3,ICASAN,IWRITE 644 52 FORMAT('IBUGA3,ICASAN,IWRITE = ',2(A4,2X),A4) 645 CALL DPWRST('XXX','BUG ') 646 WRITE(ICOUT,53)P1,N1,P2,N2,P3,N3,ALPHA 647 53 FORMAT('P1,N1,P2,N2,P3,N3,ALPHA = ',3(G15.7,I8),G15.7) 648 CALL DPWRST('XXX','BUG ') 649 WRITE(ICOUT,999) 650 CALL DPWRST('XXX','BUG ') 651 ENDIF 652C 653C ******************************** 654C ** STEP 1-- ** 655C ** CHECK FOR INPUT ERRORS ** 656C ******************************** 657C 658 PVALUE=0.0 659 ALOWLM=0.0 660 AUPPLM=1.0 661C 662 IF(N1.LT.1)THEN 663 WRITE(ICOUT,999) 664 CALL DPWRST('XXX','WRIT') 665 WRITE(ICOUT,111) 666 111 FORMAT('****** ERROR IN RUHKIN 1 TEST-- ') 667 CALL DPWRST('XXX','BUG ') 668 WRITE(ICOUT,113) 669 113 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE FIRST ', 670 1 'RESPONSE VARIABLE IS LESS THAN 2.') 671 CALL DPWRST('XXX','WRIT') 672 WRITE(ICOUT,114)N1 673 114 FORMAT('SAMPLE SIZE = ',I8) 674 CALL DPWRST('XXX','WRIT') 675 IERROR='YES' 676 GOTO9000 677 ENDIF 678C 679 IF(N2.LT.2)THEN 680 WRITE(ICOUT,999) 681 CALL DPWRST('XXX','WRIT') 682 WRITE(ICOUT,111) 683 CALL DPWRST('XXX','BUG ') 684 WRITE(ICOUT,123) 685 123 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE ', 686 1 'SECOND RESPONSE VARIABLE IS LESS THAN 2.') 687 CALL DPWRST('XXX','WRIT') 688 WRITE(ICOUT,114)N2 689 CALL DPWRST('XXX','WRIT') 690 IERROR='YES' 691 GOTO9000 692 ENDIF 693C 694 IF(N3.LT.2)THEN 695 WRITE(ICOUT,999) 696 CALL DPWRST('XXX','WRIT') 697 WRITE(ICOUT,111) 698 CALL DPWRST('XXX','BUG ') 699 WRITE(ICOUT,133) 700 133 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE ', 701 1 'THIRD RESPONSE VARIABLE IS LESS THAN 2.') 702 CALL DPWRST('XXX','WRIT') 703 WRITE(ICOUT,114)N3 704 CALL DPWRST('XXX','WRIT') 705 IERROR='YES' 706 GOTO9000 707 ENDIF 708C 709 IF(P1.LT.0.0 .OR. P1.GT.1.0)THEN 710 IERROR='YES' 711 WRITE(ICOUT,999) 712 CALL DPWRST('XXX','BUG ') 713 WRITE(ICOUT,111) 714 CALL DPWRST('XXX','BUG ') 715 WRITE(ICOUT,162) 716 162 FORMAT(' THE BINOMIAL PROBABILITY OF SUCCESS PARAMETER ', 717 1 'FOR THE') 718 CALL DPWRST('XXX','BUG ') 719 WRITE(ICOUT,164) 720 164 FORMAT(' FIRST RESPONSE VARIABLE IS OUTSIDE THE ', 721 1 '(0,1) INTERVAL.') 722 CALL DPWRST('XXX','BUG ') 723 WRITE(ICOUT,167)P1 724 167 FORMAT(' THE PROBABILITY OF SUCCESS PARAMETER = ',G15.7) 725 CALL DPWRST('XXX','BUG ') 726 GOTO9000 727 ENDIF 728C 729 IF(P2.LT.0.0 .OR. P2.GT.1.0)THEN 730 IERROR='YES' 731 WRITE(ICOUT,999) 732 CALL DPWRST('XXX','BUG ') 733 WRITE(ICOUT,111) 734 CALL DPWRST('XXX','BUG ') 735 WRITE(ICOUT,162) 736 CALL DPWRST('XXX','BUG ') 737 WRITE(ICOUT,174) 738 174 FORMAT(' SECOND RESPONSE VARIABLE IS OUTSIDE THE ', 739 1 '(0,1) INTERVAL.') 740 CALL DPWRST('XXX','BUG ') 741 WRITE(ICOUT,167)P2 742 CALL DPWRST('XXX','BUG ') 743 GOTO9000 744 ENDIF 745C 746 IF(P3.LT.0.0 .OR. P3.GT.1.0)THEN 747 IERROR='YES' 748 WRITE(ICOUT,999) 749 CALL DPWRST('XXX','BUG ') 750 WRITE(ICOUT,111) 751 CALL DPWRST('XXX','BUG ') 752 WRITE(ICOUT,162) 753 CALL DPWRST('XXX','BUG ') 754 WRITE(ICOUT,184) 755 184 FORMAT(' THIRD RESPONSE VARIABLE IS OUTSIDE THE ', 756 1 '(0,1) INTERVAL.') 757 CALL DPWRST('XXX','BUG ') 758 WRITE(ICOUT,167)P3 759 CALL DPWRST('XXX','BUG ') 760 GOTO9000 761 ENDIF 762C 763 ALPHSV=ALPHA 764 IF(ALPHA.GT.1.0 .AND. ALPHA.LE.100.0)ALPHA=ALPHA/100.0 765 IF(ALPHA.LE.0.0 .OR. ALPHA.GE.1.0)THEN 766 IERROR='YES' 767 WRITE(ICOUT,999) 768 CALL DPWRST('XXX','BUG ') 769 WRITE(ICOUT,111) 770 CALL DPWRST('XXX','BUG ') 771 WRITE(ICOUT,192) 772 192 FORMAT(' THE VALUE OF ALPHA IS OUTSIDE THE (0,1) ', 773 1 'INTERVAL.') 774 CALL DPWRST('XXX','BUG ') 775 WRITE(ICOUT,197)ALPHA 776 197 FORMAT(' THE VALUE OF ALPHA = ',G15.7) 777 CALL DPWRST('XXX','BUG ') 778 GOTO9000 779 ENDIF 780C 781CCCCC FOR THESE FORMULAS, WE WANT ALPHA AS 0.05 RATHER THAN 782CCCCC 0.95. 783C 784CCCCC IF(ALPHA.LT.0.5)ALPHA=1.0 - ALPHA 785 IF(ALPHA.GT.0.5)ALPHA=1.0 - ALPHA 786C 787C ******************************************** 788C ** STEP 2-- ** 789C ** COMPUTE THE DIFFERENCE OF PROPORTIONS ** 790C ** CONFIDENCE INTERVAL. ** 791C ******************************************** 792C 793 STATVA=P1 - P2*P3 794 IF(P1.GE.1.0 .AND. P2.GE.1.0 .AND. P3.GE.1.0)THEN 795 PVALUE=1.0 796 ALOWLM=STATVA 797 AUPPLM=STATVA 798 GOTO9000 799 ELSEIF(P1.LE.0.0 .AND. P2.LE.0.0 .AND. P3.LE.0.0)THEN 800 PVALUE=1.0 801 ALOWLM=STATVA 802 AUPPLM=STATVA 803 GOTO9000 804 ENDIF 805C 806 DN1=DBLE(N1) 807 DN2=DBLE(N2) 808 DN3=DBLE(N3) 809 DP1=DBLE(P1) 810 DP2=DBLE(P2) 811 DP3=DBLE(P3) 812C 813 DTERM1=DP1*(1.0D0 - DP1)/DN1 814 DTERM2=(DP3**2)*DP2*(1.0D0 - DP2)/DN2 815 DTERM3=(DP2**2)*DP3*(1.0D0 - DP3)/DN3 816 IF(ICASAN.EQ.'R1LT')THEN 817 DTERM4=(DP2*DP3 - DP1)/DSQRT(DTERM1 + DTERM2 + DTERM3) 818 CALL NODCDF(DTERM4,DPVAL) 819 DPVAL=1.0D0 - DPVAL 820 ELSEIF(ICASAN.EQ.'R1UT')THEN 821 DTERM4=(DP1 - DP2*DP3)/DSQRT(DTERM1 + DTERM2 + DTERM3) 822 CALL NODCDF(DTERM4,DPVAL) 823 DPVAL=1.0D0 - DPVAL 824 ELSE 825 DTERM4=DABS(DP1 - DP2*DP3)/DSQRT(DTERM1 + DTERM2 + DTERM3) 826 CALL NODCDF(DTERM4,DPVAL) 827 DPVAL=2.0D0*(1.0D0 - DPVAL) 828 ENDIF 829 PVALUE=REAL(DPVAL) 830C 831 DTERM4=DSQRT(DTERM1 + DTERM2 + DTERM3) 832 ALP2=ALPHA/2.0 833 IF(ALP2.LE.0.5)ALP2=1.0 - ALP2 834 CALL NODPPF(DBLE(ALP2),DPPF) 835 A1=STATVA - REAL(DPPF*DTERM4) 836 A2=STATVA + REAL(DPPF*DTERM4) 837 ALOWLM=MIN(A1,A2) 838 AUPPLM=MAX(A1,A2) 839 IF(ALOWLM.LT.-1.0)ALOWLM=-1.0 840 IF(AUPPLM.GT.1.0)AUPPLM=1.0 841C 842C ***************** 843C ** STEP 90-- ** 844C ** EXIT. ** 845C ***************** 846C 847 9000 CONTINUE 848C 849 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RUH1')THEN 850 WRITE(ICOUT,999) 851 CALL DPWRST('XXX','BUG ') 852 WRITE(ICOUT,9011) 853 9011 FORMAT('***** AT THE END OF DPRUH1--') 854 CALL DPWRST('XXX','BUG ') 855 WRITE(ICOUT,9012)IBUGA3,IERROR 856 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 857 CALL DPWRST('XXX','BUG ') 858 WRITE(ICOUT,9013)STATVA,ALP2,DPPF 859 9013 FORMAT('STATVA,ALP2,DPPF = ',3(G15.7,2X)) 860 CALL DPWRST('XXX','BUG ') 861 WRITE(ICOUT,9014)A1,A2,ALOWLM,AUPPLM 862 9014 FORMAT('A1,A2,ALOWLM,AUPPLM = ',4(G15.7,2X)) 863 CALL DPWRST('XXX','BUG ') 864 WRITE(ICOUT,9018)DTERM1,DTERM2,DTERM3,DTERM4 865 9018 FORMAT('DTERM1,DTERM2,DTERM3,DTERM4 = ',4(G15.7,2X)) 866 CALL DPWRST('XXX','BUG ') 867 WRITE(ICOUT,9019)DPVAL,PVALUE 868 9019 FORMAT('DPVAL,PVALUE = ',2(G15.7,2X)) 869 CALL DPWRST('XXX','BUG ') 870 ENDIF 871C 872 RETURN 873 END 874 SUBROUTINE DPRUH2(P1,N1,P2,N2,ALPHA,ICASAN,IWRITE, 875 1 PVALUE,ALOWLM,AUPPLM, 876 1 IBUGA3,IERROR) 877C 878C PURPOSE--FOR TWO BINOMIAL PROPORTIONS (P1, N1, P2, N2) 879C AND ALPHA, COMPUTE THE HYPOTHESIS TEST FOR: 880C 881C Ho: P1 = 0.5*P2 882C 883C AGAINST 884C 885C Ha: P1 <> 0.5*P2 886C Ha: P1 < 0.5*P2 887C Ha: P1 > 0.5*P2 888C 889C RETURN THE APPROPRIATE P-VALUE AND A CONFIDENCE 890C INTERVAL. 891C REFERENCE--PRIVATE COMMUNICATION WITH ANDREW RUHKIN OF THE 892C NIST STATISTICAL ENGINEERING DIVISION. 893C WRITTEN BY--JAMES J. FILLIBEN 894C STATISTICAL ENGINEERING DIVISION 895C INFORMATION TECHNOLOGY LABORATORY 896C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 897C GAITHERSBURG, MD 20899-8980 898C PHONE--301-975-2855 899C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 900C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 901C LANGUAGE--ANSI FORTRAN (1977) 902C VERSION NUMBER--2008/9 903C ORIGINAL VERSION--SEPTEMBER 2008. 904C 905C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 906C 907 CHARACTER*4 ICASAN 908 CHARACTER*4 IWRITE 909 CHARACTER*4 IBUGA3 910 CHARACTER*4 IERROR 911C 912 CHARACTER*4 ISUBN1 913 CHARACTER*4 ISUBN2 914C 915C--------------------------------------------------------------------- 916C 917 REAL P1 918 REAL P2 919 REAL ALPHA 920 REAL PVALUE 921 INTEGER N1 922 INTEGER N2 923C 924 DOUBLE PRECISION DTERM1 925 DOUBLE PRECISION DTERM2 926 DOUBLE PRECISION DTERM3 927 DOUBLE PRECISION DTERM4 928 DOUBLE PRECISION DP1 929 DOUBLE PRECISION DP2 930 DOUBLE PRECISION DN1 931 DOUBLE PRECISION DN2 932 DOUBLE PRECISION DPVAL 933 DOUBLE PRECISION DPPF 934C 935C-----COMMON---------------------------------------------------------- 936C 937 INCLUDE 'DPCOP2.INC' 938C 939C-----START POINT----------------------------------------------------- 940C 941 ISUBN1='DPRU' 942 ISUBN2='H2 ' 943 IERROR='NO' 944C 945 IF(IBUGA3.EQ.'ON')THEN 946 WRITE(ICOUT,999) 947 999 FORMAT(1X) 948 CALL DPWRST('XXX','BUG ') 949 WRITE(ICOUT,51) 950 51 FORMAT('***** AT THE BEGINNING OF DPRUH2--') 951 CALL DPWRST('XXX','BUG ') 952 WRITE(ICOUT,52)IBUGA3,ICASAN,IWRITE 953 52 FORMAT('IBUGA3,ICASAN,IWRITE = ',2(A4,2X),A4) 954 CALL DPWRST('XXX','BUG ') 955 WRITE(ICOUT,53)P1,N1,P2,N2,ALPHA 956 53 FORMAT('P1,N1,P2,N2,ALPHA = ',2(G15.7,I8),G15.7) 957 CALL DPWRST('XXX','BUG ') 958 WRITE(ICOUT,999) 959 CALL DPWRST('XXX','BUG ') 960 ENDIF 961C 962C ******************************** 963C ** STEP 1-- ** 964C ** CHECK FOR INPUT ERRORS ** 965C ******************************** 966C 967 PVALUE=0.0 968 ALOWLM=0.0 969 AUPPLM=1.0 970C 971 IF(N1.LT.1)THEN 972 WRITE(ICOUT,999) 973 CALL DPWRST('XXX','WRIT') 974 WRITE(ICOUT,111) 975 111 FORMAT('****** ERROR IN RUHKIN 2 TEST-- ') 976 CALL DPWRST('XXX','BUG ') 977 WRITE(ICOUT,113) 978 113 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE FIRST ', 979 1 'RESPONSE VARIABLE IS LESS THAN 2.') 980 CALL DPWRST('XXX','WRIT') 981 WRITE(ICOUT,114)N1 982 114 FORMAT('SAMPLE SIZE = ',I8) 983 CALL DPWRST('XXX','WRIT') 984 IERROR='YES' 985 GOTO9000 986 ENDIF 987C 988 IF(N2.LT.2)THEN 989 WRITE(ICOUT,999) 990 CALL DPWRST('XXX','WRIT') 991 WRITE(ICOUT,111) 992 CALL DPWRST('XXX','BUG ') 993 WRITE(ICOUT,123) 994 123 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE ', 995 1 'SECOND RESPONSE VARIABLE IS LESS THAN 2.') 996 CALL DPWRST('XXX','WRIT') 997 WRITE(ICOUT,114)N2 998 CALL DPWRST('XXX','WRIT') 999 IERROR='YES' 1000 GOTO9000 1001 ENDIF 1002C 1003 IF(P1.LT.0.0 .OR. P1.GT.1.0)THEN 1004 IERROR='YES' 1005 WRITE(ICOUT,999) 1006 CALL DPWRST('XXX','BUG ') 1007 WRITE(ICOUT,111) 1008 CALL DPWRST('XXX','BUG ') 1009 WRITE(ICOUT,162) 1010 162 FORMAT(' THE BINOMIAL PROBABILITY OF SUCCESS PARAMETER ', 1011 1 'FOR THE') 1012 CALL DPWRST('XXX','BUG ') 1013 WRITE(ICOUT,164) 1014 164 FORMAT(' FIRST RESPONSE VARIABLE IS OUTSIDE THE ', 1015 1 '(0,1) INTERVAL.') 1016 CALL DPWRST('XXX','BUG ') 1017 WRITE(ICOUT,167)P1 1018 167 FORMAT(' THE PROBABILITY OF SUCCESS PARAMETER = ',G15.7) 1019 CALL DPWRST('XXX','BUG ') 1020 GOTO9000 1021 ENDIF 1022C 1023 IF(P2.LT.0.0 .OR. P2.GT.1.0)THEN 1024 IERROR='YES' 1025 WRITE(ICOUT,999) 1026 CALL DPWRST('XXX','BUG ') 1027 WRITE(ICOUT,111) 1028 CALL DPWRST('XXX','BUG ') 1029 WRITE(ICOUT,162) 1030 CALL DPWRST('XXX','BUG ') 1031 WRITE(ICOUT,174) 1032 174 FORMAT(' SECOND RESPONSE VARIABLE IS OUTSIDE THE ', 1033 1 '(0,1) INTERVAL.') 1034 CALL DPWRST('XXX','BUG ') 1035 WRITE(ICOUT,167)P2 1036 CALL DPWRST('XXX','BUG ') 1037 GOTO9000 1038 ENDIF 1039C 1040 ALPHSV=ALPHA 1041 IF(ALPHA.GT.1.0 .AND. ALPHA.LE.100.0)ALPHA=ALPHA/100.0 1042 IF(ALPHA.LE.0.0 .OR. ALPHA.GE.1.0)THEN 1043 IERROR='YES' 1044 WRITE(ICOUT,999) 1045 CALL DPWRST('XXX','BUG ') 1046 WRITE(ICOUT,111) 1047 CALL DPWRST('XXX','BUG ') 1048 WRITE(ICOUT,192) 1049 192 FORMAT(' THE VALUE OF ALPHA IS OUTSIDE THE (0,1) ', 1050 1 'INTERVAL.') 1051 CALL DPWRST('XXX','BUG ') 1052 WRITE(ICOUT,197)ALPHA 1053 197 FORMAT(' THE VALUE OF ALPHA = ',G15.7) 1054 CALL DPWRST('XXX','BUG ') 1055 GOTO9000 1056 ENDIF 1057C 1058CCCCC FOR THESE FORMULAS, WE WANT ALPHA AS 0.05 RATHER THAN 1059CCCCC 0.95. 1060C 1061CCCCC IF(ALPHA.LT.0.5)ALPHA=1.0 - ALPHA 1062 IF(ALPHA.GT.0.5)ALPHA=1.0 - ALPHA 1063C 1064C ******************************************** 1065C ** STEP 2-- ** 1066C ** COMPUTE THE DIFFERENCE OF PROPORTIONS ** 1067C ** CONFIDENCE INTERVAL. ** 1068C ******************************************** 1069C 1070 STATVA=P1 - 0.5*P2 1071 IF(P1.GE.1.0 .AND. P2.GE.1.0)THEN 1072 PVALUE=1.0 1073 ALOWLM=STATVA 1074 AUPPLM=STATVA 1075 GOTO9000 1076 ELSEIF(P1.LE.0.0 .AND. P2.LE.0.0)THEN 1077 PVALUE=1.0 1078 ALOWLM=STATVA 1079 AUPPLM=STATVA 1080 GOTO9000 1081 ENDIF 1082C 1083 DN1=DBLE(N1) 1084 DN2=DBLE(N2) 1085 DP1=DBLE(P1) 1086 DP2=DBLE(P2) 1087C 1088 DTERM1=DP1*(1.0D0 - DP1)/DN1 1089 DTERM2=DP2*(1.0D0 - DP2)/(4.0D0*DN2) 1090 IF(ICASAN.EQ.'R2LT')THEN 1091 DTERM3=0.5D0*DP2 - DP1 1092 DTERM4=DTERM3/DSQRT(DTERM1 + DTERM2) 1093 CALL NODCDF(DTERM4,DPVAL) 1094 DPVAL=1.0D0 - DPVAL 1095 ELSEIF(ICASAN.EQ.'R2UT')THEN 1096 DTERM3=DP1 - 0.5D0*DP2 1097 DTERM4=DTERM3/DSQRT(DTERM1 + DTERM2) 1098 CALL NODCDF(DTERM4,DPVAL) 1099 DPVAL=1.0D0 - DPVAL 1100 ELSE 1101 DTERM3=DABS(DP1 - 0.5D0*DP2) 1102 DTERM4=DTERM3/DSQRT(DTERM1 + DTERM2) 1103 CALL NODCDF(DTERM4,DPVAL) 1104 DPVAL=2.0D0*(1.0D0 - DPVAL) 1105 ENDIF 1106 PVALUE=REAL(DPVAL) 1107C 1108 DTERM4=DSQRT(DTERM1 + DTERM2) 1109 ALP2=ALPHA/2.0 1110 IF(ALP2.LE.0.5)ALP2=1.0 - ALP2 1111 CALL NODPPF(DBLE(ALP2),DPPF) 1112 A1=STATVA - REAL(DPPF*DTERM4) 1113 A2=STATVA + REAL(DPPF*DTERM4) 1114 ALOWLM=MIN(A1,A2) 1115 AUPPLM=MAX(A1,A2) 1116C 1117C ***************** 1118C ** STEP 90-- ** 1119C ** EXIT. ** 1120C ***************** 1121C 1122 9000 CONTINUE 1123C 1124 IF(IBUGA3.EQ.'ON')THEN 1125 WRITE(ICOUT,999) 1126 CALL DPWRST('XXX','BUG ') 1127 WRITE(ICOUT,9011) 1128 9011 FORMAT('***** AT THE END OF DPRUH2--') 1129 CALL DPWRST('XXX','BUG ') 1130 WRITE(ICOUT,9012)IBUGA3,IERROR 1131 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 1132 CALL DPWRST('XXX','BUG ') 1133 WRITE(ICOUT,9013)DTERM1,DTERM2,DTERM3,DTERM4 1134 9013 FORMAT('DTERM1,DTERM2,DTERM3,DTERM4 = ',4(G15.7,2X)) 1135 CALL DPWRST('XXX','BUG ') 1136 WRITE(ICOUT,9014)DPVAL,PVALUE 1137 9014 FORMAT('DPVAL,PVALUE = ',2(G15.7,2X)) 1138 CALL DPWRST('XXX','BUG ') 1139 ENDIF 1140C 1141 RETURN 1142 END 1143 SUBROUTINE DPRUH3(P1,N1,P2,N2,P3,N3,P4,N4,ALPHA,ICASAN,IWRITE, 1144 1 PVALUE,ALOWLM,AUPPLM, 1145 1 IBUGA3,ISUBRO,IERROR) 1146C 1147C PURPOSE--FOR THREE BINOMIAL PROPORTIONS (P1, N1, P2, N2, P3, N3) 1148C AND ALPHA, COMPUTE THE HYPOTHESIS TEST FOR: 1149C 1150C Ho: P1*P2 = P3*P4 1151C 1152C AGAINST 1153C 1154C Ha: P1*P2 <> P3*P4 1155C Ha: P1*P2 < P3*P4 1156C Ha: P1*P2 > P3*P4 1157C 1158C RETURN THE APPROPRIATE P-VALUE. 1159C REFERENCE--PRIVATE COMMUNICATION WITH ANDREW RUHKIN AND 1160C BILL STRAWDERMAN OF THE NIST STATISTICAL ENGINEERING 1161C DIVISION. 1162C WRITTEN BY--JAMES J. FILLIBEN 1163C STATISTICAL ENGINEERING DIVISION 1164C INFORMATION TECHNOLOGY LABORATORY 1165C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 1166C GAITHERSBURG, MD 20899-8980 1167C PHONE--301-975-2855 1168C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 1169C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 1170C LANGUAGE--ANSI FORTRAN (1977) 1171C VERSION NUMBER--2010/6 1172C ORIGINAL VERSION--JUNE 2010. 1173C 1174C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 1175C 1176 CHARACTER*4 ICASAN 1177 CHARACTER*4 IWRITE 1178 CHARACTER*4 IBUGA3 1179 CHARACTER*4 ISUBRO 1180 CHARACTER*4 IERROR 1181C 1182 CHARACTER*4 ISUBN1 1183 CHARACTER*4 ISUBN2 1184C 1185C--------------------------------------------------------------------- 1186C 1187 REAL P1 1188 REAL P2 1189 REAL P3 1190 REAL P4 1191 REAL ALPHA 1192 REAL PVALUE 1193 REAL ALOWLM 1194 REAL AUPPLM 1195 INTEGER N1 1196 INTEGER N2 1197 INTEGER N3 1198 INTEGER N4 1199C 1200 DOUBLE PRECISION DTERM1 1201 DOUBLE PRECISION DTERM2 1202 DOUBLE PRECISION DTERM3 1203 DOUBLE PRECISION DTERM4 1204 DOUBLE PRECISION DTERM5 1205 DOUBLE PRECISION DDELTA 1206 DOUBLE PRECISION DP1 1207 DOUBLE PRECISION DP2 1208 DOUBLE PRECISION DP3 1209 DOUBLE PRECISION DP4 1210 DOUBLE PRECISION DN1 1211 DOUBLE PRECISION DN2 1212 DOUBLE PRECISION DN3 1213 DOUBLE PRECISION DN4 1214 DOUBLE PRECISION DPVAL 1215 DOUBLE PRECISION DPPF 1216C 1217C-----COMMON---------------------------------------------------------- 1218C 1219 INCLUDE 'DPCOP2.INC' 1220C 1221C-----START POINT----------------------------------------------------- 1222C 1223 ISUBN1='DPRU' 1224 ISUBN2='H3 ' 1225 IERROR='NO' 1226C 1227 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RUH3')THEN 1228 WRITE(ICOUT,999) 1229 999 FORMAT(1X) 1230 CALL DPWRST('XXX','BUG ') 1231 WRITE(ICOUT,51) 1232 51 FORMAT('***** AT THE BEGINNING OF DPRUH3--') 1233 CALL DPWRST('XXX','BUG ') 1234 WRITE(ICOUT,52)IBUGA3,ICASAN,IWRITE 1235 52 FORMAT('IBUGA3,ICASAN,IWRITE = ',2(A4,2X),A4) 1236 CALL DPWRST('XXX','BUG ') 1237 WRITE(ICOUT,53)P1,N1,P2,N2,P3,N3,P4,N4,ALPHA 1238 53 FORMAT('P1,N1,P2,N2,P3,N3,P4,N4,ALPHA = ',4(G15.7,I8),G15.7) 1239 CALL DPWRST('XXX','BUG ') 1240 WRITE(ICOUT,999) 1241 CALL DPWRST('XXX','BUG ') 1242 ENDIF 1243C 1244C ******************************** 1245C ** STEP 1-- ** 1246C ** CHECK FOR INPUT ERRORS ** 1247C ******************************** 1248C 1249 PVALUE=0.0 1250 ALOWLM=0.0 1251 AUPPLM=1.0 1252C 1253 IF(N1.LT.1)THEN 1254 WRITE(ICOUT,999) 1255 CALL DPWRST('XXX','WRIT') 1256 WRITE(ICOUT,111) 1257 111 FORMAT('****** ERROR IN RUHKIN 3 TEST-- ') 1258 CALL DPWRST('XXX','BUG ') 1259 WRITE(ICOUT,113) 1260 113 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE FIRST ', 1261 1 'RESPONSE VARIABLE IS LESS THAN 2.') 1262 CALL DPWRST('XXX','WRIT') 1263 WRITE(ICOUT,114)N1 1264 114 FORMAT('SAMPLE SIZE = ',I8) 1265 CALL DPWRST('XXX','WRIT') 1266 IERROR='YES' 1267 GOTO9000 1268 ENDIF 1269C 1270 IF(N2.LT.2)THEN 1271 WRITE(ICOUT,999) 1272 CALL DPWRST('XXX','WRIT') 1273 WRITE(ICOUT,111) 1274 CALL DPWRST('XXX','BUG ') 1275 WRITE(ICOUT,123) 1276 123 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE ', 1277 1 'SECOND RESPONSE VARIABLE IS LESS THAN 2.') 1278 CALL DPWRST('XXX','WRIT') 1279 WRITE(ICOUT,114)N2 1280 CALL DPWRST('XXX','WRIT') 1281 IERROR='YES' 1282 GOTO9000 1283 ENDIF 1284C 1285 IF(N3.LT.2)THEN 1286 WRITE(ICOUT,999) 1287 CALL DPWRST('XXX','WRIT') 1288 WRITE(ICOUT,111) 1289 CALL DPWRST('XXX','BUG ') 1290 WRITE(ICOUT,133) 1291 133 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE ', 1292 1 'THIRD RESPONSE VARIABLE IS LESS THAN 2.') 1293 CALL DPWRST('XXX','WRIT') 1294 WRITE(ICOUT,114)N3 1295 CALL DPWRST('XXX','WRIT') 1296 IERROR='YES' 1297 GOTO9000 1298 ENDIF 1299C 1300 IF(N4.LT.2)THEN 1301 WRITE(ICOUT,999) 1302 CALL DPWRST('XXX','WRIT') 1303 WRITE(ICOUT,111) 1304 CALL DPWRST('XXX','BUG ') 1305 WRITE(ICOUT,143) 1306 143 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE ', 1307 1 'FOURTH RESPONSE VARIABLE IS LESS THAN 2.') 1308 CALL DPWRST('XXX','WRIT') 1309 WRITE(ICOUT,114)N4 1310 CALL DPWRST('XXX','WRIT') 1311 IERROR='YES' 1312 GOTO9000 1313 ENDIF 1314C 1315 IF(P1.LT.0.0 .OR. P1.GT.1.0)THEN 1316 IERROR='YES' 1317 WRITE(ICOUT,999) 1318 CALL DPWRST('XXX','BUG ') 1319 WRITE(ICOUT,111) 1320 CALL DPWRST('XXX','BUG ') 1321 WRITE(ICOUT,162) 1322 162 FORMAT(' THE BINOMIAL PROBABILITY OF SUCCESS PARAMETER ', 1323 1 'FOR THE') 1324 CALL DPWRST('XXX','BUG ') 1325 WRITE(ICOUT,164) 1326 164 FORMAT(' FIRST RESPONSE VARIABLE IS OUTSIDE THE ', 1327 1 '(0,1) INTERVAL.') 1328 CALL DPWRST('XXX','BUG ') 1329 WRITE(ICOUT,167)P1 1330 167 FORMAT(' THE PROBABILITY OF SUCCESS PARAMETER = ',G15.7) 1331 CALL DPWRST('XXX','BUG ') 1332 GOTO9000 1333 ENDIF 1334C 1335 IF(P2.LT.0.0 .OR. P2.GT.1.0)THEN 1336 IERROR='YES' 1337 WRITE(ICOUT,999) 1338 CALL DPWRST('XXX','BUG ') 1339 WRITE(ICOUT,111) 1340 CALL DPWRST('XXX','BUG ') 1341 WRITE(ICOUT,162) 1342 CALL DPWRST('XXX','BUG ') 1343 WRITE(ICOUT,174) 1344 174 FORMAT(' SECOND RESPONSE VARIABLE IS OUTSIDE THE ', 1345 1 '(0,1) INTERVAL.') 1346 CALL DPWRST('XXX','BUG ') 1347 WRITE(ICOUT,167)P2 1348 CALL DPWRST('XXX','BUG ') 1349 GOTO9000 1350 ENDIF 1351C 1352 IF(P3.LT.0.0 .OR. P3.GT.1.0)THEN 1353 IERROR='YES' 1354 WRITE(ICOUT,999) 1355 CALL DPWRST('XXX','BUG ') 1356 WRITE(ICOUT,111) 1357 CALL DPWRST('XXX','BUG ') 1358 WRITE(ICOUT,162) 1359 CALL DPWRST('XXX','BUG ') 1360 WRITE(ICOUT,184) 1361 184 FORMAT(' THIRD RESPONSE VARIABLE IS OUTSIDE THE ', 1362 1 '(0,1) INTERVAL.') 1363 CALL DPWRST('XXX','BUG ') 1364 WRITE(ICOUT,167)P3 1365 CALL DPWRST('XXX','BUG ') 1366 GOTO9000 1367 ENDIF 1368C 1369 IF(P4.LT.0.0 .OR. P4.GT.1.0)THEN 1370 IERROR='YES' 1371 WRITE(ICOUT,999) 1372 CALL DPWRST('XXX','BUG ') 1373 WRITE(ICOUT,111) 1374 CALL DPWRST('XXX','BUG ') 1375 WRITE(ICOUT,162) 1376 CALL DPWRST('XXX','BUG ') 1377 WRITE(ICOUT,194) 1378 194 FORMAT(' FOURTH RESPONSE VARIABLE IS OUTSIDE THE ', 1379 1 '(0,1) INTERVAL.') 1380 CALL DPWRST('XXX','BUG ') 1381 WRITE(ICOUT,167)P4 1382 CALL DPWRST('XXX','BUG ') 1383 GOTO9000 1384 ENDIF 1385C 1386 ALPHSV=ALPHA 1387 IF(ALPHA.GT.1.0 .AND. ALPHA.LE.100.0)ALPHA=ALPHA/100.0 1388 IF(ALPHA.LE.0.0 .OR. ALPHA.GE.1.0)THEN 1389 IERROR='YES' 1390 WRITE(ICOUT,999) 1391 CALL DPWRST('XXX','BUG ') 1392 WRITE(ICOUT,111) 1393 CALL DPWRST('XXX','BUG ') 1394 WRITE(ICOUT,192) 1395 192 FORMAT(' THE VALUE OF ALPHA IS OUTSIDE THE (0,1) ', 1396 1 'INTERVAL.') 1397 CALL DPWRST('XXX','BUG ') 1398 WRITE(ICOUT,197)ALPHA 1399 197 FORMAT(' THE VALUE OF ALPHA = ',G15.7) 1400 CALL DPWRST('XXX','BUG ') 1401 GOTO9000 1402 ENDIF 1403C 1404CCCCC FOR THESE FORMULAS, WE WANT ALPHA AS 0.05 RATHER THAN 1405CCCCC 0.95. 1406C 1407CCCCC IF(ALPHA.LT.0.5)ALPHA=1.0 - ALPHA 1408 IF(ALPHA.GT.0.5)ALPHA=1.0 - ALPHA 1409C 1410C ******************************************** 1411C ** STEP 2-- ** 1412C ** COMPUTE THE DIFFERENCE OF PROPORTIONS ** 1413C ** CONFIDENCE INTERVAL. ** 1414C ******************************************** 1415C 1416C DEFINE CORRECTION TERM: 1417C 1418C P(i) = (X(i) + 0.5)/(N(i) + 1) 1419C 1420 X1=P1*REAL(N1) 1421 IX1=INT(X1+0.01) 1422 X1=REAL(IX1) 1423 P1=(X1+0.5)/(REAL(N1)+1.0) 1424 X2=P2*REAL(N2) 1425 IX2=INT(X2+0.01) 1426 X2=REAL(IX2) 1427 P2=(X2+0.5)/(REAL(N2)+1.0) 1428 X3=P3*REAL(N3) 1429 IX3=INT(X3+0.01) 1430 X3=REAL(IX3) 1431 P3=(X3+0.5)/(REAL(N3)+1.0) 1432 X4=P4*REAL(N4) 1433 IX4=INT(X4+0.01) 1434 X4=REAL(IX4) 1435 P4=(X4+0.5)/(REAL(N4)+1.0) 1436C 1437 STATVA=P1*P2 - P3*P4 1438C 1439 IF(P1.GE.1.0 .AND. P2.GE.1.0 .AND. P3.GE.1.0 .AND. P4.GE.1.0)THEN 1440 PVALUE=1.0 1441 ALOWLM=STATVA 1442 AUPPLM=STATVA 1443 GOTO9000 1444 ELSEIF(P1.LE.0.0 .AND. P2.LE.0.0 .AND. P3.LE.0.0 .AND. 1445 1 P4.LE.0.0)THEN 1446 PVALUE=1.0 1447 ALOWLM=STATVA 1448 AUPPLM=STATVA 1449 GOTO9000 1450 ENDIF 1451C 1452 DN1=DBLE(N1) 1453 DN2=DBLE(N2) 1454 DN3=DBLE(N3) 1455 DN4=DBLE(N4) 1456 DP1=DBLE(P1) 1457 DP2=DBLE(P2) 1458 DP3=DBLE(P3) 1459 DP4=DBLE(P4) 1460C 1461 DTERM1=(DP2**2)*DP1*(1.0D0 - DP1)/DN1 1462 DTERM2=(DP1**2)*DP2*(1.0D0 - DP2)/DN2 1463 DTERM3=(DP4**2)*DP3*(1.0D0 - DP3)/DN3 1464 DTERM4=(DP3**2)*DP4*(1.0D0 - DP4)/DN4 1465 DDELTA=DSQRT(DTERM1 + DTERM2 + DTERM3 + DTERM4) 1466C 1467 IF(ICASAN.EQ.'R3LT')THEN 1468 DTERM5=(DP3*DP4 - DP1*DP2)/DDELTA 1469 CALL NODCDF(DTERM5,DPVAL) 1470 DPVAL=1.0D0 - DPVAL 1471 ELSEIF(ICASAN.EQ.'R3UT')THEN 1472 DTERM5=(DP1*DP2 - DP3*DP4)/DDELTA 1473 CALL NODCDF(DTERM5,DPVAL) 1474 DPVAL=1.0D0 - DPVAL 1475 ELSE 1476 DTERM5=DABS(DP3*DP4 - DP1*DP2)/DDELTA 1477 CALL NODCDF(DTERM5,DPVAL) 1478 DPVAL=2.0D0*(1.0D0 - DPVAL) 1479 ENDIF 1480 PVALUE=REAL(DPVAL) 1481C 1482 ALP2=ALPHA/2.0 1483 IF(ALP2.LE.0.5)ALP2=1.0 - ALP2 1484 CALL NODPPF(DBLE(ALP2),DPPF) 1485 A1=STATVA - REAL(DPPF*DDELTA) 1486 A2=STATVA + REAL(DPPF*DDELTA) 1487 ALOWLM=MIN(A1,A2) 1488 AUPPLM=MAX(A1,A2) 1489 IF(ALOWLM.LT.-1.0)ALOWLM=-1.0 1490 IF(AUPPLM.GT.1.0)AUPPLM=1.0 1491C 1492C ***************** 1493C ** STEP 90-- ** 1494C ** EXIT. ** 1495C ***************** 1496C 1497 9000 CONTINUE 1498C 1499 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RUH3')THEN 1500 WRITE(ICOUT,999) 1501 CALL DPWRST('XXX','BUG ') 1502 WRITE(ICOUT,9011) 1503 9011 FORMAT('***** AT THE END OF DPRUH3--') 1504 CALL DPWRST('XXX','BUG ') 1505 WRITE(ICOUT,9012)IBUGA3,IERROR 1506 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 1507 CALL DPWRST('XXX','BUG ') 1508 WRITE(ICOUT,9013)STATVA,ALP2,DPPF 1509 9013 FORMAT('STATVA,ALP2,DPPF = ',3(G15.7,2X)) 1510 CALL DPWRST('XXX','BUG ') 1511 WRITE(ICOUT,9014)A1,A2,ALOWLM,AUPPLM 1512 9014 FORMAT('A1,A2,ALOWLM,AUPPLM = ',4(G15.7,2X)) 1513 CALL DPWRST('XXX','BUG ') 1514 WRITE(ICOUT,9018)DTERM1,DTERM2,DTERM3,DTERM4,DTERM5 1515 9018 FORMAT('DTERM1,DTERM2,DTERM3,DTERM4,DTERM5 = ',5(G15.7,2X)) 1516 CALL DPWRST('XXX','BUG ') 1517 WRITE(ICOUT,9019)DPVAL,PVALUE 1518 9019 FORMAT('DPVAL,PVALUE = ',2(G15.7,2X)) 1519 CALL DPWRST('XXX','BUG ') 1520 ENDIF 1521C 1522 RETURN 1523 END 1524 SUBROUTINE DPRUN(XTEMP1,MAXNXT,ICASAN,ICAPSW,IFORSW, 1525 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 1526C 1527C PURPOSE--CARRY OUT A RUNS ANALYSIS TO TEST FOR RANDOMNESS. 1528C EXAMPLE--RUNS Y 1529C RUNS Y1 TO Y5 1530C REFERENCES--LEVENE AND WOLFOWITZ, ANNALS OF MATHEMATICAL 1531C STATISTICS, 1944, PAGES 58-69; 1532C ESPECIALLY PAGES 60, 63, AND 64. 1533C --BRADLEY, DISTRIBUTION-FREE STATISTICAL TESTS, 1534C 1968, CHAPTER 12, PAGES 271-282. 1535C WRITTEN BY--JAMES J. FILLIBEN 1536C STATISTICAL ENGINEERING DIVISION 1537C INFORMATION TECHNOLOGY LABORATORY 1538C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 1539C GAITHERSBURG, MD 20899-8980 1540C PHONE--301-975-2855 1541C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 1542C OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY. 1543C LANGUAGE--ANSI FORTRAN (1977) 1544C VERSION NUMBER--82/7 1545C ORIGINAL VERSION--JULY 1984. 1546C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON 1547C UPDATED --MAY 2011. USE DPPARS ROUTINE 1548C UPATED --MAY 2011. REWRITTEN TO HANDLE MULTIPLE 1549C RESPONSE VARIABLES, GROUP-ID 1550C VARIABLES, OR A LAB-ID VARIABLE 1551C UPATED --JULY 2019. TWEAK SCRATCH SPACE 1552C 1553C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 1554C 1555 CHARACTER*4 ICASAN 1556 CHARACTER*4 ICAPSW 1557 CHARACTER*4 IFORSW 1558 CHARACTER*4 IBUGA2 1559 CHARACTER*4 IBUGA3 1560 CHARACTER*4 IBUGQ 1561 CHARACTER*4 ISUBRO 1562 CHARACTER*4 IFOUND 1563 CHARACTER*4 IERROR 1564C 1565 CHARACTER*4 ISUBN1 1566 CHARACTER*4 ISUBN2 1567 CHARACTER*4 ISTEPN 1568 CHARACTER*4 IREPL 1569 CHARACTER*4 IMULT 1570 CHARACTER*4 ICTMP1 1571 CHARACTER*4 ICTMP2 1572 CHARACTER*4 ICTMP3 1573 CHARACTER*4 ICTMP4 1574 CHARACTER*4 ICASE 1575C 1576 CHARACTER*40 INAME 1577 PARAMETER (MAXSPN=30) 1578 CHARACTER*4 IVARN1(MAXSPN) 1579 CHARACTER*4 IVARN2(MAXSPN) 1580 CHARACTER*4 IVARTY(MAXSPN) 1581 CHARACTER*4 IVARID(1) 1582 CHARACTER*4 IVARI2(1) 1583 REAL PVAR(MAXSPN) 1584 REAL PID(MAXSPN) 1585 INTEGER ILIS(MAXSPN) 1586 INTEGER NRIGHT(MAXSPN) 1587 INTEGER ICOLR(MAXSPN) 1588C 1589C--------------------------------------------------------------------- 1590C 1591 INCLUDE 'DPCOPA.INC' 1592C 1593 DIMENSION XTEMP1(*) 1594 DIMENSION W(MAXOBV) 1595C 1596 DIMENSION XDESGN(MAXOBV,7) 1597 DIMENSION XIDTEM(MAXOBV) 1598 DIMENSION XIDTE2(MAXOBV) 1599 DIMENSION XIDTE3(MAXOBV) 1600 DIMENSION XIDTE4(MAXOBV) 1601 DIMENSION XIDTE5(MAXOBV) 1602 DIMENSION XIDTE6(MAXOBV) 1603C 1604 DIMENSION TEMP1(MAXOBV) 1605 DIMENSION TEMP2(MAXOBV) 1606C 1607 INCLUDE 'DPCOZZ.INC' 1608C 1609 EQUIVALENCE (GARBAG(IGARB1),TEMP1(1)) 1610 EQUIVALENCE (GARBAG(IGARB2),XIDTEM(1)) 1611 EQUIVALENCE (GARBAG(IGARB3),XIDTE2(1)) 1612 EQUIVALENCE (GARBAG(IGARB4),XIDTE3(1)) 1613 EQUIVALENCE (GARBAG(IGARB5),XIDTE4(1)) 1614 EQUIVALENCE (GARBAG(IGARB6),XIDTE5(1)) 1615 EQUIVALENCE (GARBAG(IGARB7),XIDTE6(1)) 1616 EQUIVALENCE (GARBAG(IGARB8),W(1)) 1617 EQUIVALENCE (GARBAG(IGARB9),TEMP2(1)) 1618 EQUIVALENCE (GARBAG(IGAR10),XDESGN(1,1)) 1619C 1620C-----COMMON---------------------------------------------------------- 1621C 1622 INCLUDE 'DPCOHK.INC' 1623 INCLUDE 'DPCODA.INC' 1624 INCLUDE 'DPCOSU.INC' 1625 INCLUDE 'DPCOST.INC' 1626 INCLUDE 'DPCOP2.INC' 1627C 1628C-----START POINT----------------------------------------------------- 1629C 1630 IERROR='NO' 1631 IFOUND='NO' 1632 ICASAN='RUNS' 1633 IREPL='OFF' 1634 IMULT='OFF' 1635 ISUBN1='DPRU' 1636 ISUBN2='N ' 1637C 1638 MAXCP1=MAXCOL+1 1639 MAXCP2=MAXCOL+2 1640 MAXCP3=MAXCOL+3 1641 MAXCP4=MAXCOL+4 1642 MAXCP5=MAXCOL+5 1643 MAXCP6=MAXCOL+6 1644C 1645C *********************************************** 1646C ** TREAT THE RUNS TEST CASE ** 1647C *********************************************** 1648C 1649 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'PRUN')THEN 1650 WRITE(ICOUT,999) 1651 999 FORMAT(1X) 1652 CALL DPWRST('XXX','BUG ') 1653 WRITE(ICOUT,51) 1654 51 FORMAT('***** AT THE BEGINNING OF DPRUN--') 1655 CALL DPWRST('XXX','BUG ') 1656 WRITE(ICOUT,53)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT 1657 53 FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT = ',4(A4,2X),I8) 1658 CALL DPWRST('XXX','BUG ') 1659 ENDIF 1660C 1661C ***************************************************** 1662C ** STEP 1-- ** 1663C ** EXTRACT THE COMMAND ** 1664C ** LOOK FOR ONE OF THE FOLLOWING COMMANDS: ** 1665C ** 1) RUNS Y ** 1666C ** 2) MULTIPLE RUNS Y1 ... YK ** 1667C ** 3) REPLICATED RUNS Y X1 ... XK ** 1668C ***************************************************** 1669C 1670 ISTEPN='1' 1671 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PRUN') 1672 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1673C 1674 ILASTZ=9999 1675C 1676C LOOK FOR: 1677C 1678C RUNS 1679C RUNS TEST 1680C 1681 DO100I=0,NUMARG-1 1682C 1683 IF(I.EQ.0)THEN 1684 ICTMP1=ICOM 1685 ELSE 1686 ICTMP1=IHARG(I) 1687 ENDIF 1688 ICTMP2=IHARG(I+1) 1689 ICTMP3=IHARG(I+2) 1690 ICTMP4=IHARG(I+3) 1691C 1692 IF(ICTMP1.EQ.'=')THEN 1693 IFOUND='NO' 1694 GOTO9000 1695 ELSEIF(ICTMP1.EQ.'RUNS' .AND. ICTMP2.EQ.'TEST')THEN 1696 IFOUND='YES' 1697 ILASTZ=I+1 1698 ELSEIF(ICTMP1.EQ.'RUNS')THEN 1699 IFOUND='YES' 1700 ILASTZ=I 1701 ELSEIF(ICTMP1.EQ.'REPL')THEN 1702 IREPL='ON' 1703 ILASTZ=MAX(ILASTZ,I) 1704 ELSEIF(ICTMP1.EQ.'MULT')THEN 1705 IMULT='ON' 1706 ILASTZ=MAX(ILASTZ,I) 1707 ENDIF 1708 100 CONTINUE 1709C 1710 IF(IFOUND.EQ.'NO')GOTO9000 1711C 1712 ISHIFT=ILASTZ 1713 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1714 1 IBUGA2,IERROR) 1715C 1716 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PRUN')THEN 1717 WRITE(ICOUT,91)ICASAN,IMULT,IREPL,ISHIFT 1718 91 FORMAT('DPRUN: ICASAN,IMULT,IREPL,ISHIFT = ',3(A4,2X),I5) 1719 CALL DPWRST('XXX','BUG ') 1720 ENDIF 1721C 1722 IF(IMULT.EQ.'ON')THEN 1723 IF(IREPL.EQ.'ON')THEN 1724 WRITE(ICOUT,999) 1725 CALL DPWRST('XXX','BUG ') 1726 WRITE(ICOUT,101) 1727 101 FORMAT('***** ERROR IN RUNS TEST--') 1728 CALL DPWRST('XXX','BUG ') 1729 WRITE(ICOUT,103) 1730 103 FORMAT(' YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ', 1731 1 '"REPLICATION"') 1732 CALL DPWRST('XXX','BUG ') 1733 WRITE(ICOUT,104) 1734 104 FORMAT(' FOR THE RUNS COMMAND.') 1735 CALL DPWRST('XXX','BUG ') 1736 IERROR='YES' 1737 GOTO9000 1738 ENDIF 1739 ENDIF 1740C 1741C ********************************* 1742C ** STEP 4-- ** 1743C ** EXTRACT THE VARIABLE LIST ** 1744C ********************************* 1745C 1746 ISTEPN='4' 1747 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PRUN') 1748 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1749C 1750 INAME='RUNS' 1751 MINNA=1 1752 MAXNA=100 1753 MINN2=2 1754 IFLAGE=0 1755 IFLAGM=1 1756 IF(IREPL.EQ.'ON')THEN 1757 IFLAGM=0 1758 IFLAGE=1 1759 ENDIF 1760 IFLAGP=0 1761 JMIN=1 1762 JMAX=NUMARG 1763 MINNVA=1 1764 MAXNVA=MAXSPN 1765C 1766 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 1767 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 1768 1 JMIN,JMAX, 1769 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 1770 1 IVARN1,IVARN2,IVARTY,PVAR, 1771 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 1772 1 MINNVA,MAXNVA, 1773 1 IFLAGM,IFLAGP, 1774 1 IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 1775 IF(IERROR.EQ.'YES')GOTO9000 1776C 1777 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PRUN')THEN 1778 WRITE(ICOUT,999) 1779 CALL DPWRST('XXX','BUG ') 1780 WRITE(ICOUT,281) 1781 281 FORMAT('***** AFTER CALL DPPARS--') 1782 CALL DPWRST('XXX','BUG ') 1783 WRITE(ICOUT,282)NQ,NUMVAR 1784 282 FORMAT('NQ,NUMVAR = ',2I8) 1785 CALL DPWRST('XXX','BUG ') 1786 IF(NUMVAR.GT.0)THEN 1787 DO285I=1,NUMVAR 1788 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 1789 1 ICOLR(I) 1790 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 1791 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 1792 CALL DPWRST('XXX','BUG ') 1793 285 CONTINUE 1794 ENDIF 1795 ENDIF 1796C 1797C *********************************************** 1798C ** STEP 5-- ** 1799C ** DETERMINE: ** 1800C ** 1) NUMBER OF REPLICATION VARIABLES (0-6) ** 1801C ** 2) NUMBER OF RESPONSE VARIABLES (>= 1)** 1802C *********************************************** 1803C 1804 ISTEPN='5' 1805 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PRUN') 1806 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1807C 1808 DO501I=1,MAXNXT 1809 W(I)=1.0 1810 501 CONTINUE 1811 NRESP=0 1812 NREPL=0 1813 IF(IMULT.EQ.'ON')THEN 1814 NRESP=NUMVAR 1815 ELSEIF(IREPL.EQ.'ON')THEN 1816 NRESP=1 1817 NREPL=NUMVAR-NRESP 1818 IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN 1819 WRITE(ICOUT,999) 1820 CALL DPWRST('XXX','BUG ') 1821 WRITE(ICOUT,101) 1822 CALL DPWRST('XXX','BUG ') 1823 WRITE(ICOUT,511) 1824 511 FORMAT(' FOR THE REPLICATION CASE, THE NUMBER OF ', 1825 1 'REPLICATION VARIABLES') 1826 CALL DPWRST('XXX','BUG ') 1827 WRITE(ICOUT,512) 1828 512 FORMAT(' MUST BE BETWEEN ONE AND SIX.') 1829 CALL DPWRST('XXX','BUG ') 1830 WRITE(ICOUT,513)NREPL 1831 513 FORMAT(' THE NUMBER OF REPLICATION VARIABLES = ',I5) 1832 CALL DPWRST('XXX','BUG ') 1833 IERROR='YES' 1834 GOTO9000 1835 ENDIF 1836 ELSE 1837 NRESP=NUMVAR 1838 IMULT='ON' 1839 ENDIF 1840C 1841 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PRUN')THEN 1842 WRITE(ICOUT,521)NRESP,NREPL 1843 521 FORMAT('NRESP,NREPL = ',2I5) 1844 CALL DPWRST('XXX','BUG ') 1845 ENDIF 1846C 1847C ****************************************************** 1848C ** STEP 6-- ** 1849C ** GENERATE THE RUNS TEST FOR THE ** 1850C ** VARIOUS CASES ** 1851C ****************************************************** 1852C 1853 ISTEPN='6' 1854 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PRUN') 1855 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1856C 1857C ****************************************** 1858C ** STEP 8A-- ** 1859C ** CASE 1: NO REPLICATION VARIABLES ** 1860C ****************************************** 1861C 1862 IF(NREPL.LT.1)THEN 1863 ISTEPN='8A' 1864 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PRUN') 1865 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1866C 1867C LOOP THROUGH EACH OF THE RESPONSE VARIABLES 1868C 1869 NCURVE=0 1870 DO810IRESP=1,NRESP 1871 NCURVE=NCURVE+1 1872C 1873 IINDX=ICOLR(IRESP) 1874 PID(1)=CPUMIN 1875 IVARID(1)=IVARN1(IRESP) 1876 IVARI2(1)=IVARN2(IRESP) 1877C 1878 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PRUN')THEN 1879 WRITE(ICOUT,999) 1880 CALL DPWRST('XXX','BUG ') 1881 WRITE(ICOUT,811)IRESP,NCURVE 1882 811 FORMAT('IRESP,NCURVE = ',2I5) 1883 CALL DPWRST('XXX','BUG ') 1884 ENDIF 1885C 1886 ICOL=IRESP 1887 NUMVA2=1 1888 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 1889 1 INAME,IVARN1,IVARN2,IVARTY, 1890 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 1891 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 1892 1 MAXCP4,MAXCP5,MAXCP6, 1893 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 1894 1 Y,XTEMP1,XTEMP1,NS1,NLOCA2,NLOCA3,ICASE, 1895 1 IBUGA3,ISUBRO,IFOUND,IERROR) 1896 IF(IERROR.EQ.'YES')GOTO9000 1897C 1898C ***************************************************** 1899C ** STEP 8B-- ** 1900C ***************************************************** 1901C 1902 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'PRUN')THEN 1903 ISTEPN='8B' 1904 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1905 WRITE(ICOUT,999) 1906 CALL DPWRST('XXX','BUG ') 1907 WRITE(ICOUT,822) 1908 822 FORMAT('***** FROM THE MIDDLE OF DPRUN--') 1909 CALL DPWRST('XXX','BUG ') 1910 WRITE(ICOUT,823)ICASAN,NUMVAR,NS1 1911 823 FORMAT('ICASAN,NUMVAR,NS1 = ',A4,2I8) 1912 CALL DPWRST('XXX','BUG ') 1913 IF(NS1.GE.1)THEN 1914 DO825I=1,NS1 1915 WRITE(ICOUT,826)I,Y(I) 1916 826 FORMAT('I,Y(I) = ',I8,G15.7) 1917 CALL DPWRST('XXX','BUG ') 1918 825 CONTINUE 1919 ENDIF 1920 ENDIF 1921C 1922 CALL DPRUN2(Y,W,NS1,XTEMP1,MAXNXT, 1923 1 ICAPSW,ICAPTY,IFORSW,ICASAN, 1924 1 PID,IVARID,IVARI2,NREPL, 1925 1 ISUBRO,IBUGA3,IERROR) 1926 810 CONTINUE 1927C 1928C **************************************************** 1929C ** STEP 9A-- ** 1930C ** CASE 3: ONE OR MORE REPLICATION VARIABLES. ** 1931C ** FOR THIS CASE, THE NUMBER OF RESPONSE ** 1932C ** VARIABLES MUST BE EXACTLY 1. ** 1933C ** FOR THIS CASE, ALL VARIABLES MUST ** 1934C ** HAVE THE SAME LENGTH. ** 1935C **************************************************** 1936C 1937 ELSEIF(NREPL.GE.1)THEN 1938 ISTEPN='9A' 1939 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PRUN') 1940 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1941C 1942 J=0 1943 IMAX=NRIGHT(1) 1944 IF(NQ.LT.NRIGHT(1))IMAX=NQ 1945 DO910I=1,IMAX 1946 IF(ISUB(I).EQ.0)GOTO910 1947 J=J+1 1948C 1949C RESPONSE VARIABLE IN Y 1950C 1951 ICOLC=1 1952 IJ=MAXN*(ICOLR(ICOLC)-1)+I 1953 IF(ICOLR(ICOLC).LE.MAXCOL)Y(J)=V(IJ) 1954 IF(ICOLR(ICOLC).EQ.MAXCP1)Y(J)=PRED(I) 1955 IF(ICOLR(ICOLC).EQ.MAXCP2)Y(J)=RES(I) 1956 IF(ICOLR(ICOLC).EQ.MAXCP3)Y(J)=YPLOT(I) 1957 IF(ICOLR(ICOLC).EQ.MAXCP4)Y(J)=XPLOT(I) 1958 IF(ICOLR(ICOLC).EQ.MAXCP5)Y(J)=X2PLOT(I) 1959 IF(ICOLR(ICOLC).EQ.MAXCP6)Y(J)=TAGPLO(I) 1960C 1961 IF(NREPL.GE.1)THEN 1962 DO920IR=1,MIN(NREPL,6) 1963 ICOLC=ICOLC+1 1964 ICOLT=ICOLR(ICOLC) 1965 IJ=MAXN*(ICOLT-1)+I 1966 IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ) 1967 IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I) 1968 IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I) 1969 IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I) 1970 IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I) 1971 IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I) 1972 IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I) 1973 920 CONTINUE 1974 ENDIF 1975C 1976 910 CONTINUE 1977 NLOCAL=J 1978C 1979C ***************************************************** 1980C ** STEP 9B-- ** 1981C ** CALL DPRUN2 TO PERFORM RUNS TEST. ** 1982C ***************************************************** 1983C 1984C 1985 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'PRUN')THEN 1986 ISTEPN='9C' 1987 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1988 WRITE(ICOUT,999) 1989 CALL DPWRST('XXX','BUG ') 1990 WRITE(ICOUT,941) 1991 941 FORMAT('***** FROM THE MIDDLE OF DPRUN--') 1992 CALL DPWRST('XXX','BUG ') 1993 WRITE(ICOUT,942)ICASAN,NUMVAR,NLOCAL,NREPL 1994 942 FORMAT('ICASAN,NUMVAR,NLOCAL,NREPL = ', 1995 1 A4,3I8) 1996 CALL DPWRST('XXX','BUG ') 1997 IF(NLOCAL.GE.1)THEN 1998 DO945I=1,NLOCAL 1999 WRITE(ICOUT,946)I,Y(I),XDESGN(I,1),XDESGN(I,2) 2000 946 FORMAT('I,Y(I),XDESGN(I,1),XDESGN(I,2) = ', 2001 1 I8,4F12.5) 2002 CALL DPWRST('XXX','BUG ') 2003 945 CONTINUE 2004 ENDIF 2005 ENDIF 2006C 2007C ***************************************************** 2008C ** STEP 9C-- ** 2009C ** FIND THE DISTINCT VALUES IN EACH OF THE ** 2010C ** REPLICATION VARIABLES. ** 2011C ***************************************************** 2012C 2013 CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3), 2014 1 XDESGN(1,4),XDESGN(1,5),XDESGN(1,6), 2015 1 NREPL,NLOCAL,MAXOBV, 2016 1 XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6, 2017 1 XTEMP1,TEMP2, 2018 1 NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6, 2019 1 IBUGA3,ISUBRO,IERROR) 2020C 2021C ***************************************************** 2022C ** STEP 9D-- ** 2023C ** NOW LOOP THROUGH THE VARIOUS REPLICATIONS ** 2024C ***************************************************** 2025C 2026 NCURVE=0 2027 IADD=1 2028C 2029 IF(NREPL.EQ.1)THEN 2030 J=0 2031 DO1110ISET1=1,NUMSE1 2032 K=0 2033 PID(IADD+1)=XIDTEM(ISET1) 2034 DO1130I=1,NLOCAL 2035 IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN 2036 K=K+1 2037 TEMP1(K)=Y(I) 2038 ENDIF 2039 1130 CONTINUE 2040 NTEMP=K 2041 NCURVE=NCURVE+1 2042 IF(NTEMP.GT.0)THEN 2043 CALL DPRUN2(TEMP1,W,NTEMP,XTEMP1,MAXNXT, 2044 1 ICAPSW,ICAPTY,IFORSW,ICASAN, 2045 1 PID,IVARN1,IVARN2,NREPL, 2046 1 ISUBRO,IBUGA3,IERROR) 2047 ENDIF 2048 1110 CONTINUE 2049 ELSEIF(NREPL.EQ.2)THEN 2050 J=0 2051 NTOT=NUMSE1*NUMSE2 2052 DO1210ISET1=1,NUMSE1 2053 DO1220ISET2=1,NUMSE2 2054 K=0 2055 PID(1+IADD)=XIDTEM(ISET1) 2056 PID(2+IADD)=XIDTE2(ISET2) 2057 DO1290I=1,NLOCAL 2058 IF( 2059 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 2060 1 XIDTE2(ISET2).EQ.XDESGN(I,2) 2061 1 )THEN 2062 K=K+1 2063 TEMP1(K)=Y(I) 2064 ENDIF 2065 1290 CONTINUE 2066 NTEMP=K 2067 NCURVE=NCURVE+1 2068 IF(NTEMP.GT.0)THEN 2069 CALL DPRUN2(TEMP1,W,NTEMP,XTEMP1,MAXNXT, 2070 1 ICAPSW,ICAPTY,IFORSW,ICASAN, 2071 1 PID,IVARN1,IVARN2,NREPL, 2072 1 ISUBRO,IBUGA3,IERROR) 2073 ENDIF 2074 1220 CONTINUE 2075 1210 CONTINUE 2076 ELSEIF(NREPL.EQ.3)THEN 2077 J=0 2078 NTOT=NUMSE1*NUMSE2*NUMSE3 2079 DO1310ISET1=1,NUMSE1 2080 DO1320ISET2=1,NUMSE2 2081 DO1330ISET3=1,NUMSE3 2082 K=0 2083 PID(1+IADD)=XIDTEM(ISET1) 2084 PID(2+IADD)=XIDTE2(ISET2) 2085 PID(3+IADD)=XIDTE3(ISET3) 2086 DO1390I=1,NLOCAL 2087 IF( 2088 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 2089 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 2090 1 XIDTE3(ISET3).EQ.XDESGN(I,3) 2091 1 )THEN 2092 K=K+1 2093 TEMP1(K)=Y(I) 2094 ENDIF 2095 1390 CONTINUE 2096 NTEMP=K 2097 NCURVE=NCURVE+1 2098 NPLOT1=NPLOTP 2099 IF(NTEMP.GT.0)THEN 2100 CALL DPRUN2(TEMP1,W,NTEMP,XTEMP1,MAXNXT, 2101 1 ICAPSW,ICAPTY,IFORSW,ICASAN, 2102 1 PID,IVARN1,IVARN2,NREPL, 2103 1 ISUBRO,IBUGA3,IERROR) 2104 ENDIF 2105 1330 CONTINUE 2106 1320 CONTINUE 2107 1310 CONTINUE 2108 ELSEIF(NREPL.EQ.4)THEN 2109 J=0 2110 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4 2111 DO1410ISET1=1,NUMSE1 2112 DO1420ISET2=1,NUMSE2 2113 DO1430ISET3=1,NUMSE3 2114 DO1440ISET4=1,NUMSE4 2115 K=0 2116 PID(1+IADD)=XIDTEM(ISET1) 2117 PID(2+IADD)=XIDTE2(ISET2) 2118 PID(3+IADD)=XIDTE3(ISET3) 2119 PID(4+IADD)=XIDTE4(ISET4) 2120 DO1490I=1,NLOCAL 2121 IF( 2122 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 2123 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 2124 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 2125 1 XIDTE4(ISET4).EQ.XDESGN(I,4) 2126 1 )THEN 2127 K=K+1 2128 TEMP1(K)=Y(I) 2129 ENDIF 2130 1490 CONTINUE 2131 NTEMP=K 2132 NCURVE=NCURVE+1 2133 NPLOT1=NPLOTP 2134 IF(NTEMP.GT.0)THEN 2135 CALL DPRUN2(TEMP1,W,NTEMP,XTEMP1,MAXNXT, 2136 1 ICAPSW,ICAPTY,IFORSW,ICASAN, 2137 1 PID,IVARN1,IVARN2,NREPL, 2138 1 ISUBRO,IBUGA3,IERROR) 2139 ENDIF 2140 1440 CONTINUE 2141 1430 CONTINUE 2142 1420 CONTINUE 2143 1410 CONTINUE 2144 ELSEIF(NREPL.EQ.5)THEN 2145 J=0 2146 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5 2147 DO1510ISET1=1,NUMSE1 2148 DO1520ISET2=1,NUMSE2 2149 DO1530ISET3=1,NUMSE3 2150 DO1540ISET4=1,NUMSE4 2151 DO1550ISET5=1,NUMSE5 2152 K=0 2153 PID(1+IADD)=XIDTEM(ISET1) 2154 PID(2+IADD)=XIDTE2(ISET2) 2155 PID(3+IADD)=XIDTE3(ISET3) 2156 PID(4+IADD)=XIDTE4(ISET4) 2157 PID(5+IADD)=XIDTE5(ISET4) 2158 DO1590I=1,NLOCAL 2159 IF( 2160 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 2161 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 2162 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 2163 1 XIDTE4(ISET4).EQ.XDESGN(I,4) .AND. 2164 1 XIDTE5(ISET5).EQ.XDESGN(I,5) 2165 1 )THEN 2166 K=K+1 2167 TEMP1(K)=Y(I) 2168 ENDIF 2169 1590 CONTINUE 2170 NTEMP=K 2171 NCURVE=NCURVE+1 2172 NPLOT1=NPLOTP 2173 IF(NTEMP.GT.0)THEN 2174 CALL DPRUN2(TEMP1,W,NTEMP,XTEMP1,MAXNXT, 2175 1 ICAPSW,ICAPTY,IFORSW,ICASAN, 2176 1 PID,IVARN1,IVARN2,NREPL, 2177 1 ISUBRO,IBUGA3,IERROR) 2178 ENDIF 2179 1550 CONTINUE 2180 1540 CONTINUE 2181 1530 CONTINUE 2182 1520 CONTINUE 2183 1510 CONTINUE 2184 ELSEIF(NREPL.EQ.6)THEN 2185 J=0 2186 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6 2187 DO1610ISET1=1,NUMSE1 2188 DO1620ISET2=1,NUMSE2 2189 DO1630ISET3=1,NUMSE3 2190 DO1640ISET4=1,NUMSE4 2191 DO1650ISET5=1,NUMSE5 2192 DO1660ISET6=1,NUMSE6 2193 K=0 2194 PID(1+IADD)=XIDTEM(ISET1) 2195 PID(2+IADD)=XIDTE2(ISET2) 2196 PID(3+IADD)=XIDTE3(ISET3) 2197 PID(4+IADD)=XIDTE4(ISET4) 2198 PID(5+IADD)=XIDTE5(ISET4) 2199 PID(6+IADD)=XIDTE6(ISET4) 2200 DO1690I=1,NLOCAL 2201 IF( 2202 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 2203 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 2204 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 2205 1 XIDTE4(ISET4).EQ.XDESGN(I,4) .AND. 2206 1 XIDTE5(ISET5).EQ.XDESGN(I,5) .AND. 2207 1 XIDTE6(ISET6).EQ.XDESGN(I,6) 2208 1 )THEN 2209 K=K+1 2210 TEMP1(K)=Y(I) 2211 ENDIF 2212 1690 CONTINUE 2213 NTEMP=K 2214 NCURVE=NCURVE+1 2215 NPLOT1=NPLOTP 2216 IF(NTEMP.GT.0)THEN 2217 CALL DPRUN2(TEMP1,W,NTEMP,XTEMP1,MAXNXT, 2218 1 ICAPSW,ICAPTY,IFORSW,ICASAN, 2219 1 PID,IVARN1,IVARN2,NREPL, 2220 1 ISUBRO,IBUGA3,IERROR) 2221 ENDIF 2222 1660 CONTINUE 2223 1650 CONTINUE 2224 1640 CONTINUE 2225 1630 CONTINUE 2226 1620 CONTINUE 2227 1610 CONTINUE 2228 ENDIF 2229C 2230 ENDIF 2231C 2232C ***************** 2233C ** STEP 90-- ** 2234C ** EXIT ** 2235C ***************** 2236C 2237 9000 CONTINUE 2238C 2239 IF(IERROR.EQ.'YES')THEN 2240 IF(IWIDTH.GE.1)THEN 2241 WRITE(ICOUT,9001)(IANS(I),I=1,MIN(100,IWIDTH)) 2242 9001 FORMAT(100A1) 2243 CALL DPWRST('XXX','BUG ') 2244 ENDIF 2245 ENDIF 2246C 2247 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'PRUN')THEN 2248 WRITE(ICOUT,999) 2249 CALL DPWRST('XXX','BUG ') 2250 WRITE(ICOUT,9011) 2251 9011 FORMAT('***** AT THE END OF DPRUN--') 2252 CALL DPWRST('XXX','BUG ') 2253 WRITE(ICOUT,9012)IFOUND,IERROR,ICASAN 2254 9012 FORMAT('IFOUND,IERROR,ICASAN = ',2(A4,2X),A4) 2255 CALL DPWRST('XXX','BUG ') 2256 ENDIF 2257C 2258 RETURN 2259 END 2260 SUBROUTINE DPRUN2(Y,W,N,XTEMP1,MAXNXT, 2261 1 ICAPSW,ICAPTY,IFORSW,ICASAN, 2262 1 PID,IVARID,IVARI2,NREPL, 2263 1 ISUBRO,IBUGA3,IERROR) 2264C 2265C PURPOSE--THIS ROUTINE CARRIES OUT A RUNS ANALYSIS 2266C FOR THE DATA IN THE INPUT VECTOR Y. 2267C NOTE--ASSUMPTION--DATA COLLECTED SEQUENTIALLY IN TIME. 2268C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR 2269C OF EQUALLY-SPACED OBSERVATIONS 2270C TO BE SMOOTHED. 2271C N = THE INTEGER NUMBER OF 2272C OBSERVATIONS IN THE VECTOR Y. 2273C NOTE--THE ANALYSIS CONSISTS OF FIRST DETERMINING 2274C THE OBSERVED NUMBER OF RUNS FROM THE DATA, 2275C AND THEN COMPUTING 2276C THE EXPECTED NUMBER OF RUNS, 2277C THE STANDARD DEVIATION OF THE NUMBER OF RUNS, 2278C AND THE RESULTING STANDARDIZED STATISTIC 2279C FOR THE NUMBER OF RUNS FOR RUNS OF VARIOUS 2280C LENGTHS. 2281C THIS IS DONE FOR RUNS UP, RUNS DOWN, AND 2282C RUNS UP AND DOWN. 2283C THIS RUNS ANSLYSIS IS A USEFUL DISTRIBUTION-FREE 2284C TEST OF THE RANDOMNESS OF A DATA SET. 2285C OUTPUT--4 PAGES OF AUTOMATIC PRINTOUT 2286C CONSISTING OF THE OBSERVED NUMBER, 2287C EXPECTED NUMBER, STANDARD DEVIATION 2288C AND RESULTING STANDARDIZED STATISTIC 2289C FOR RUNS OF VARIOUS LENGTHS. 2290C AND THE CUMULATIVE FREQUENCY. 2291C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. 2292C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 2293C LANGUAGE--ANSI 77 FORTRAN. 2294C REFERENCES--LEVENE AND WOLFOWITZ, ANNALS OF MATHEMATICAL 2295C STATISTICS, 1944, PAGES 58-69; 2296C ESPECIALLY PAGES 60, 63, AND 64. 2297C REFERENCES--BRADLEY, DISTRIBUTION-FREE STATISTICAL TESTS, 2298C 1968, CHAPTER 12, PAGES 271-282. 2299C WRITTEN BY--JAMES J. FILLIBEN 2300C STATISTICAL ENGINEERING DIVISION 2301C INFORMATION TECHNOLOGY LABORATORY 2302C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 2303C GAITHERSBURG, MD 20899-8980 2304C PHONE--301-975-2899 2305C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 2306C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 2307C LANGUAGE--ANSI FORTRAN (1977) 2308C VERSION NUMBER--82/7 2309C ORIGINAL VERSION--JULY 1984. 2310C UPDATED --MAY 2011. USE DPDTA1 AND DPDTA2 TO PRINT 2311C TABLES 2312C 2313C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 2314C 2315 CHARACTER*4 IVARID(*) 2316 CHARACTER*4 IVARI2(*) 2317C 2318 CHARACTER*4 ICAPSW 2319 CHARACTER*4 ICAPTY 2320 CHARACTER*4 IFORSW 2321 CHARACTER*4 ICASAN 2322C 2323 CHARACTER*4 ISUBRO 2324 CHARACTER*4 IBUGA3 2325 CHARACTER*4 IERROR 2326C 2327 CHARACTER*4 ISUBN1 2328 CHARACTER*4 ISUBN2 2329 CHARACTER*4 ISTEPN 2330C 2331C--------------------------------------------------------------------- 2332C 2333 DIMENSION Y(*) 2334 DIMENSION W(*) 2335 DIMENSION XTEMP1(*) 2336 DIMENSION PID(*) 2337C 2338 DIMENSION NRUL(16), NRDL(16), NRTL(16), NRULG(16), NRDLG(16) 2339 DIMENSION NRTLG(16) 2340 DIMENSION ENRUL(16),ENRTL(16),ENRULG(16),ENRTLG(16) 2341 DIMENSION SNRUL(16),SNRTL(16),SNRULG(16),SNRTLG(16) 2342 DIMENSION ZNRUL(16),ZNRDL(16),ZNRTL(16),ZNRULG(16),ZNRDLG(16) 2343 DIMENSION ZNRTLG(16) 2344 DIMENSION C1(15),C2(15),C3(15),C4(15) 2345 DIMENSION ANRUL(16),ANRDL(16),ANRTL(16) 2346 DIMENSION ANRULG(16),ANRDLG(16),ANRTLG(16) 2347C 2348 PARAMETER (MAXROW=20) 2349 CHARACTER*60 ITITLE 2350 CHARACTER*60 ITITLZ 2351 CHARACTER*60 ITITL9 2352 CHARACTER*40 ITEXT(MAXROW) 2353 CHARACTER*4 ALIGN(MAXROW) 2354 CHARACTER*4 VALIGN(MAXROW) 2355 REAL AVALUE(MAXROW) 2356 INTEGER NCTEXT(MAXROW) 2357 INTEGER IDIGIT(MAXROW) 2358 INTEGER NTOT(MAXROW) 2359 LOGICAL IFRST 2360 LOGICAL ILAST 2361C 2362 PARAMETER(NUMCLI=6) 2363 PARAMETER(MAXLIN=1) 2364 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 2365 INTEGER NCTIT2(MAXLIN,NUMCLI) 2366 INTEGER IWHTML(NUMCLI) 2367 INTEGER IWRTF(NUMCLI) 2368 REAL AMAT(MAXROW,NUMCLI) 2369C 2370C-----COMMON---------------------------------------------------------- 2371C 2372 INCLUDE 'DPCOP2.INC' 2373C 2374C------DATA STATEMENTS------------------------------------------------ 2375C 2376 DATA C1(1),C1(2),C1(3),C1(4),C1(5),C1(6),C1(7),C1(8),C1(9),C1(10), 2377 1C1(11),C1(12),C1(13),C1(14),C1(15) 2378 1/ .4236111111E+00, .1126675485E+00, .4191688713E-01, 2379 1 .1076912487E-01, .2003959238E-02, .3023235799E-03, 2380 1 .3911555473E-04, .4459038843E-05, .4551105210E-06, 2381 1 .4207466837E-07, .3555930927E-08, .2768273257E-09, 2382 1 .1997821524E-10, .1343876568E-11, .8465610177E-13/ 2383 DATA C2(1),C2(2),C2(3),C2(4),C2(5),C2(6),C2(7),C2(8),C2(9),C2(10), 2384 1C2(11),C2(12),C2(13),C2(14),C2(15) 2385 1/-.4819444444E+00, -.1628284832E+00, -.9690696649E-01, 2386 1 -.3778106786E-01, -.9289228716E-02, -.1724429252E-02, 2387 1 -.2638557888E-03, -.3466965096E-04, -.4004129153E-05, 2388 1 -.4130382587E-06, -.3851876069E-07, -.3279103786E-08, 2389 1 -.2568491117E-09, -.1863433868E-10, -.1259220466E-11/ 2390 DATA C3(1),C3(2),C3(3),C3(4),C3(5),C3(6),C3(7),C3(8),C3(9),C3(10), 2391 1C3(11),C3(12),C3(13),C3(14),C3(15) 2392 1/ .1777777778E+00, .7916666667E-01, .4738977072E-01, 2393 1 .1274801587E-01, .2338606059E-02, .3461358734E-03, 2394 1 .4407121770E-04, .4960020603E-05, .5010387575E-06, 2395 1 .4592883352E-07, .3854170274E-08, .2982393839E-09, 2396 1 .2141205844E-10, .1433843200E-11, .8996663214E-13/ 2397 DATA C4(1),C4(2),C4(3),C4(4),C4(5),C4(6),C4(7),C4(8),C4(9),C4(10), 2398 1C4(11),C4(12),C4(13),C4(14),C4(15) 2399 1/-.3222222222E+00, -.5972222222E-01, -.1130268959E+00, 2400 1 -.4696428571E-01, -.1123273065E-01, -.2025170849E-02, 2401 1 -.3029410411E-03, -.3912824548E-04, -.4459234519E-05, 2402 1 -.4551128785E-06, -.4207469124E-07, -.3555931110E-08, 2403 1 -.2768273269E-09, -.1997821525E-10, -.1343876568E-11/ 2404C 2405C-----START POINT----------------------------------------------------- 2406C 2407 ISUBN1='DPRU' 2408 ISUBN2='N2 ' 2409 IERROR='NO' 2410C 2411 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RUN2')THEN 2412 WRITE(ICOUT,999) 2413 999 FORMAT(1X) 2414 CALL DPWRST('XXX','BUG ') 2415 WRITE(ICOUT,51) 2416 51 FORMAT('**** AT THE BEGINNING OF DPRUN2--') 2417 CALL DPWRST('XXX','BUG ') 2418 WRITE(ICOUT,52)ICASAN,IBUGA3,ISUBRO,N,MAXNXT 2419 52 FORMAT('ICASAN,IBUGA3,ISUBRO,N,MAXNXT = ',3(A4,2X),2I8) 2420 CALL DPWRST('XXX','BUG ') 2421 DO56I=1,N 2422 WRITE(ICOUT,57)I,Y(I),W(I) 2423 57 FORMAT('I,Y(I),W(I) = ',I8,2G15.7) 2424 CALL DPWRST('XXX','BUG ') 2425 56 CONTINUE 2426 ENDIF 2427C 2428C ******************************************** 2429C ** STEP 1-- ** 2430C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 2431C ******************************************** 2432C 2433 ISTEPN='1' 2434 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RUN2') 2435 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2436C 2437 IF(N.LT.2)THEN 2438 WRITE(ICOUT,999) 2439 CALL DPWRST('XXX','BUG ') 2440 WRITE(ICOUT,111) 2441 111 FORMAT('***** ERROR IN RUNS ANALYSIS--') 2442 CALL DPWRST('XXX','BUG ') 2443 WRITE(ICOUT,113) 2444 113 FORMAT(' THE NUMBER OF OBSERVATIONS IS LESS THAN TWO.') 2445 CALL DPWRST('XXX','BUG ') 2446 WRITE(ICOUT,112)N 2447 112 FORMAT('SAMPLE SIZE = ',I8) 2448 CALL DPWRST('XXX','BUG ') 2449 IERROR='YES' 2450 GOTO9000 2451 ENDIF 2452C 2453 HOLD=Y(1) 2454 DO135I=2,N 2455 IF(Y(I).NE.HOLD)GOTO139 2456 135 CONTINUE 2457 WRITE(ICOUT,999) 2458 CALL DPWRST('XXX','BUG ') 2459 WRITE(ICOUT,111) 2460 CALL DPWRST('XXX','BUG ') 2461 WRITE(ICOUT,131)HOLD 2462 131 FORMAT(' THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7) 2463 CALL DPWRST('XXX','BUG ') 2464 GOTO9000 2465 139 CONTINUE 2466C 2467C ******************************************** 2468C ** STEP 11-- ** 2469C ** FORM THE SEQUENTIAL DIFFERENCE TABLE ** 2470C ******************************************** 2471C 2472 ISTEPN='11' 2473 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RUN2') 2474 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2475C 2476 AN=N 2477 NM1=N-1 2478 DO100I=1,NM1 2479 IP1=I+1 2480 XTEMP1(I)=Y(IP1)-Y(I) 2481 100 CONTINUE 2482C 2483C *********************************************** 2484C ** STEP 12-- ** 2485C ** ZERO-OUT THE 6 'NUMBER OF RUNS' VECTORS ** 2486C *********************************************** 2487C 2488 ISTEPN='12' 2489 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RUN2') 2490 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2491C 2492 DO200I=1,16 2493 NRUL(I)=0 2494 NRDL(I)=0 2495 NRTL(I)=0 2496 NRULG(I)=0 2497 NRDLG(I)=0 2498 NRTLG(I)=0 2499 200 CONTINUE 2500C 2501C ********************************************************* 2502C ** STEP 13-- ** 2503C ** DETERMINE THE NUMBER OF RUNS UP OF LENGTH EXACTLY I** 2504C ** AND THE NUMBER OF RUNS DOWN OF LENGTH EXACTLY I ** 2505C ** DETERMINE THE LENGTH OF THE LONGEST RUN UP ** 2506C ** AND THE LENGTH OF THE LONGEST RUN DOWN ** 2507C ********************************************************* 2508C 2509 ISTEPN='13' 2510 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RUN2') 2511 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2512C 2513 LENUP=0 2514 LENDN=0 2515 MAXLNU=0 2516 MAXLND=0 2517 DO300I=1,NM1 2518 IF(XTEMP1(I).EQ.0.0)THEN 2519 IF(LENUP.GE.1)LENUP=LENUP+1 2520 IF(LENDN.GE.1)LENDN=LENDN+1 2521 IF(LENUP.EQ.0.AND.LENDN.EQ.0)LENUP=LENUP+1 2522 ELSEIF(XTEMP1(I).GT.0.0)THEN 2523 IF(LENDN.GE.1.AND.LENDN.LE.15)NRDL(LENDN)=NRDL(LENDN)+1 2524 IF(LENDN.GE.16)NRDL(16)=NRDL(16)+1 2525 LENDN=0 2526 LENUP=LENUP+1 2527 ELSEIF(XTEMP1(I).LT.0.0)THEN 2528 IF(LENUP.GE.1.AND.LENUP.LE.15)NRUL(LENUP)=NRUL(LENUP)+1 2529 IF(LENUP.GE.16)NRUL(16)=NRUL(16)+1 2530 LENUP=0 2531 LENDN=LENDN+1 2532 ENDIF 2533 IF(I.EQ.NM1.AND.LENDN.GE.1)THEN 2534 IF(LENDN.LE.15)NRDL(LENDN)=NRDL(LENDN)+1 2535 IF(LENDN.GE.16)NRDL(16)=NRDL(16)+1 2536 ENDIF 2537 IF(I.EQ.NM1.AND.LENUP.GE.1)THEN 2538 IF(LENUP.LE.15)NRUL(LENUP)=NRUL(LENUP)+1 2539 IF(LENUP.GE.16)NRUL(16)=NRUL(16)+1 2540 ENDIF 2541 IF(LENUP.GT.MAXLNU)MAXLNU=LENUP 2542 IF(LENDN.GT.MAXLND)MAXLND=LENDN 2543 300 CONTINUE 2544C 2545C ************************************************************** 2546C ** STEP 14-- ** 2547C ** DETERMINE THE NUMBER OF RUNS TOTAL OF LENGTH EXACTLY I ** 2548C ** AND THE LENGTH OF THE LONGEST RUN UP OR DOWN ** 2549C ************************************************************** 2550C 2551 ISTEPN='14' 2552 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RUN2') 2553 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2554C 2555 DO400I=1,16 2556 NRTL(I)=NRUL(I)+NRDL(I) 2557 400 CONTINUE 2558 MAXLNT=MAXLNU 2559 IF(MAXLND.GT.MAXLNU)MAXLNT=MAXLND 2560C 2561C *********************************************************** 2562C ** STEP 15-- ** 2563C ** DETERMINE THE NUMBER OF RUNS UP OF LENGTH I OR MORE ** 2564C ** AND THE NUMBER OF RUNS DOWN OF LENGTH I OR MORE ** 2565C ** AND THE NUMBER OF RUNS TOTAL OF LENGTH I OR MORE ** 2566C *********************************************************** 2567C 2568 ISTEPN='15' 2569 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RUN2') 2570 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2571C 2572 NRULG(16)=NRUL(16) 2573 NRDLG(16)=NRDL(16) 2574 NRTLG(16)=NRTL(16) 2575 DO500I=1,15 2576 J=16-I 2577 JP1=J+1 2578 NRULG(J)=NRULG(JP1)+NRUL(J) 2579 NRDLG(J)=NRDLG(JP1)+NRDL(J) 2580 NRTLG(J)=NRTLG(JP1)+NRTL(J) 2581 500 CONTINUE 2582C 2583C **************************************************************** 2584C ** STEP 16-- 2585C ** DETERMINE THE NUMBER OF POSITIVE, ZERO, AND NEGATIVE ENTRIES 2586C ** IN THE DIFFERENCE TABLE. IF RANDOM, THE NUMBER OF POSITIVE 2587C ** APPROXIMATELY EQUAL TO THE NUMBER OF NEGATIVE 2588C **************************************************************** 2589C 2590 ISTEPN='16' 2591 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RUN2') 2592 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2593C 2594 NNEG=0 2595 NZER=0 2596 NPOS=0 2597 DO800I=1,NM1 2598 IF(XTEMP1(I).LT.0.0)NNEG=NNEG+1 2599 IF(XTEMP1(I).EQ.0.0)NZER=NZER+1 2600 IF(XTEMP1(I).GT.0.0)NPOS=NPOS+1 2601 800 CONTINUE 2602C 2603C **************************************************************** 2604C ** STEP 17-- 2605C ** COMPUTE THE EXPECTED NUMBER OF RUNS UP OF LENGTH EXACTLY I = 2606C ** THE EXPECTED NUMBER OF RUNS DOWN OF LENGTH EXACTLY I = 2607C ** ONE HALF THE EXPECTED NUMBER OF RUNS TOTAL OF LENGTH EXACTLY 2608C **************************************************************** 2609C 2610 ISTEPN='17' 2611 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RUN2') 2612 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2613C 2614 DEN=6.0 2615 DO2000I=1,15 2616 AI=I 2617 ENRUL(I)=AN*(AI*AI+3.0*AI+1.0)-(AI*AI*AI+3.0*AI*AI-AI-4.0) 2618 DEN=DEN*(AI+3.0) 2619 ENRUL(I)=ENRUL(I)/DEN 2620 ENRTL(I)=2.0*ENRUL(I) 2621 2000 CONTINUE 2622C 2623C **************************************************************** 2624C ** STEP 18- 2625C ** COMPUTE THE EXPECTED NUMBER OF RUNS UP OF LENGTH I OR MORE = 2626C ** THE EXPECTED NUMBER OF RUNS DOWN OF LENGTH I OR MORE = 2627C ** ONE HALF THE EXPECTED NUMBER OF RUNS TOTAL OF LENGTH I OR MO 2628C **************************************************************** 2629C 2630 ISTEPN='18' 2631 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RUN2') 2632 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2633C 2634 DEN=2.0 2635 DO2100I=1,15 2636 AI=I 2637 ENRULG(I)=AN*(AI+1.0)-(AI*AI+AI-1.0) 2638 DEN=DEN*(AI+2.0) 2639 ENRULG(I)=ENRULG(I)/DEN 2640 ENRTLG(I)=2.0*ENRULG(I) 2641 2100 CONTINUE 2642C 2643C **************************************************************** 2644C ** STEP 19-- 2645C ** COMPUTE THE STANDARD DEV. OF THE NUMBER OF RUNS UP OF LENGTH 2646C ** THE STANDARD DEV. OF THE NUMBER OF RUNS DOWN OF LENGTH EXACT 2647C ** SQRT(0.5)* THE STAND. DEV. OF THE NUMBER OF RUNS TOTAL OF LE 2648C **************************************************************** 2649C 2650 ISTEPN='19' 2651 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RUN2') 2652 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2653C 2654 DO2500I=1,15 2655 ARG=C1(I)*AN+C2(I) 2656 SNRTL(I)=0.0 2657 IF(ARG.GT.0.0)SNRTL(I)=SQRT(ARG) 2658 SNRUL(I)=SQRT(0.5)*SNRTL(I) 2659 2500 CONTINUE 2660C 2661C **************************************************************** 2662C ** STEP 20-- 2663C ** COMPUTE THE STAND. DEV. OF THE NUMBER OF RUNS UP OF LENGTH I 2664C ** THE STAND. DEV. OF THE NUMBER OF RUNS DOWN OF LENGTH I OR MO 2665C ** SQRT(0.5)* THE STAND. DEV. OF THE NUMBER OF RUNS TOTAL OF LE 2666C **************************************************************** 2667C 2668 ISTEPN='20' 2669 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RUN2') 2670 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2671C 2672 DO2600I=1,15 2673 ARG=C3(I)*AN+C4(I) 2674 SNRTLG(I)=0.0 2675 IF(ARG.GT.0.0)SNRTLG(I)=SQRT(ARG) 2676 SNRULG(I)=SQRT(0.5)*SNRTLG(I) 2677 2600 CONTINUE 2678C 2679C ************************* 2680C ** STEP 21-- ** 2681C ** FORM Z STATISTICS ** 2682C ************************* 2683C 2684 ISTEPN='21' 2685 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RUN2') 2686 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2687C 2688 DO3100I=1,15 2689C 2690 STAT=NRUL(I) 2691 ZNRUL(I)=(-99999.99) 2692 IF(SNRUL(I).GT.0.0)ZNRUL(I)=(STAT-ENRUL(I))/SNRUL(I) 2693C 2694 STAT=NRDL(I) 2695 ZNRDL(I)=(-99999.99) 2696 IF(SNRUL(I).GT.0.0)ZNRDL(I)=(STAT-ENRUL(I))/SNRUL(I) 2697C 2698 STAT=NRTL(I) 2699 ZNRTL(I)=(-99999.99) 2700 IF(SNRTL(I).GT.0.0)ZNRTL(I)=(STAT-ENRTL(I))/SNRTL(I) 2701C 2702 STAT=NRULG(I) 2703 ZNRULG(I)=(-99999.99) 2704 IF(SNRULG(I).GT.0.0)ZNRULG(I)=(STAT-ENRULG(I))/SNRULG(I) 2705C 2706 STAT=NRDLG(I) 2707 ZNRDLG(I)=(-99999.99) 2708 IF(SNRULG(I).GT.0.0)ZNRDLG(I)=(STAT-ENRULG(I))/SNRULG(I) 2709C 2710 STAT=NRTLG(I) 2711 ZNRTLG(I)=(-99999.99) 2712 IF(SNRTLG(I).GT.0.0)ZNRTLG(I)=(STAT-ENRTLG(I))/SNRTLG(I) 2713C 2714 3100 CONTINUE 2715C 2716 DO3200I=1,15 2717 ANRUL(I)=NRUL(I) 2718 ANRDL(I)=NRDL(I) 2719 ANRTL(I)=NRTL(I) 2720 ANRULG(I)=NRULG(I) 2721 ANRDLG(I)=NRDLG(I) 2722 ANRTLG(I)=NRTLG(I) 2723 3200 CONTINUE 2724C 2725C **************************** 2726C ** STEP 22-- ** 2727C ** WRITE EVERYTHING OUT ** 2728C **************************** 2729C 2730 ISTEPN='22' 2731 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RUN2') 2732 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2733C 2734C PRINT SUMMARY STATISTICS TABLE 2735C 2736 NUMDIG=7 2737 IF(IFORSW.EQ.'1')NUMDIG=1 2738 IF(IFORSW.EQ.'2')NUMDIG=2 2739 IF(IFORSW.EQ.'3')NUMDIG=3 2740 IF(IFORSW.EQ.'4')NUMDIG=4 2741 IF(IFORSW.EQ.'5')NUMDIG=5 2742 IF(IFORSW.EQ.'6')NUMDIG=6 2743 IF(IFORSW.EQ.'7')NUMDIG=7 2744 IF(IFORSW.EQ.'8')NUMDIG=8 2745 IF(IFORSW.EQ.'9')NUMDIG=9 2746 IF(IFORSW.EQ.'0')NUMDIG=0 2747 IF(IFORSW.EQ.'E')NUMDIG=-2 2748 IF(IFORSW.EQ.'-2')NUMDIG=-2 2749 IF(IFORSW.EQ.'-3')NUMDIG=-3 2750 IF(IFORSW.EQ.'-4')NUMDIG=-4 2751 IF(IFORSW.EQ.'-5')NUMDIG=-5 2752 IF(IFORSW.EQ.'-6')NUMDIG=-6 2753 IF(IFORSW.EQ.'-7')NUMDIG=-7 2754 IF(IFORSW.EQ.'-8')NUMDIG=-8 2755 IF(IFORSW.EQ.'-9')NUMDIG=-9 2756C 2757 ITITLE='Runs Analysis' 2758 NCTITL=13 2759 ITITLZ=' ' 2760 NCTITZ=0 2761C 2762 ICNT=1 2763 ITEXT(ICNT)='Response Variable: ' 2764 WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4) 2765 WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4) 2766 NCTEXT(ICNT)=27 2767 AVALUE(ICNT)=0.0 2768 IDIGIT(ICNT)=-1 2769C 2770 IF(NREPL.GT.0)THEN 2771 IADD=1 2772 DO2101I=1,NREPL 2773 ICNT=ICNT+1 2774 ITEMP=I+IADD 2775 ITEXT(ICNT)='Factor Variable : ' 2776 WRITE(ITEXT(ICNT)(17:17),'(I1)')I 2777 WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4) 2778 WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4) 2779 NCTEXT(ICNT)=27 2780 AVALUE(ICNT)=PID(ITEMP) 2781 IDIGIT(ICNT)=NUMDIG 2782 2101 CONTINUE 2783 ENDIF 2784C 2785 ICNT=ICNT+1 2786 ITEXT(ICNT)=' ' 2787 NCTEXT(ICNT)=1 2788 AVALUE(ICNT)=0.0 2789 IDIGIT(ICNT)=-1 2790C 2791 ICNT=ICNT+1 2792 ITEXT(ICNT)='Summary Statistics:' 2793 NCTEXT(ICNT)=19 2794 AVALUE(ICNT)=0.0 2795 IDIGIT(ICNT)=-1 2796 ICNT=ICNT+1 2797 ITEXT(ICNT)='Number of Observations:' 2798 NCTEXT(ICNT)=23 2799 AVALUE(ICNT)=REAL(N) 2800 IDIGIT(ICNT)=0 2801 ICNT=ICNT+1 2802 ITEXT(ICNT)='Length of the Longest Run Up:' 2803 NCTEXT(ICNT)=29 2804 AVALUE(ICNT)=REAL(MAXLNU) 2805 IDIGIT(ICNT)=0 2806 ICNT=ICNT+1 2807 ITEXT(ICNT)='Length of the Longest Run Down:' 2808 NCTEXT(ICNT)=31 2809 AVALUE(ICNT)=REAL(MAXLND) 2810 IDIGIT(ICNT)=0 2811 ICNT=ICNT+1 2812 ITEXT(ICNT)='Length of the Longest Run Up or Down:' 2813 NCTEXT(ICNT)=37 2814 AVALUE(ICNT)=REAL(MAXLNT) 2815 IDIGIT(ICNT)=0 2816 ICNT=ICNT+1 2817 ITEXT(ICNT)=' ' 2818 NCTEXT(ICNT)=0 2819 AVALUE(ICNT)=0.0 2820 IDIGIT(ICNT)=-1 2821 ICNT=ICNT+1 2822 ITEXT(ICNT)='Number of Positive Differences:' 2823 NCTEXT(ICNT)=31 2824 AVALUE(ICNT)=REAL(NPOS) 2825 IDIGIT(ICNT)=0 2826 ICNT=ICNT+1 2827 ITEXT(ICNT)='Number of Negative Differences:' 2828 NCTEXT(ICNT)=31 2829 AVALUE(ICNT)=REAL(NNEG) 2830 IDIGIT(ICNT)=0 2831 ICNT=ICNT+1 2832 ITEXT(ICNT)='Number of Zero Differences:' 2833 NCTEXT(ICNT)=25 2834 AVALUE(ICNT)=REAL(NZER) 2835 IDIGIT(ICNT)=0 2836C 2837 NUMROW=ICNT 2838 DO2410I=1,NUMROW 2839 NTOT(I)=15 2840 2410 CONTINUE 2841C 2842 IFRST=.TRUE. 2843 ILAST=.TRUE. 2844 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT, 2845 1 AVALUE,IDIGIT, 2846 1 NTOT,NUMROW, 2847 1 ICAPSW,ICAPTY,ILAST,IFRST, 2848 1 ISUBRO,IBUGA3,IERROR) 2849C 2850 ITITL9='Runs Up' 2851 NCTIT9=7 2852 ITITLE='Statistic: Number of Runs Up of Length Exactly I' 2853 NCTITL=48 2854C 2855 NUMLIN=1 2856 NUMCOL=5 2857 DO4101J=1,NUMCLI 2858 DO4103I=1,MAXLIN 2859 ITITL2(I,J)=' ' 2860 NCTIT2(I,J)=0 2861 4103 CONTINUE 2862 4101 CONTINUE 2863C 2864 ITITL2(1,1)='I' 2865 NCTIT2(1,1)=1 2866 ITITL2(1,2)='Statistic' 2867 NCTIT2(1,2)=9 2868 ITITL2(1,3)='EXP(Stat)' 2869 NCTIT2(1,3)=9 2870 ITITL2(1,4)='SD(Stat)' 2871 NCTIT2(1,4)=8 2872 ITITL2(1,5)='Z-Score' 2873 NCTIT2(1,5)=7 2874C 2875 NMAX=0 2876 DO4106I=1,NUMCOL 2877 VALIGN(I)='b' 2878 ALIGN(I)='r' 2879 NTOT(I)=15 2880 IF(I.EQ.1)NTOT(I)=3 2881 IF(I.EQ.5)NTOT(I)=10 2882 NMAX=NMAX+NTOT(I) 2883 IDIGIT(I)=NUMDIG 2884 IF(I.EQ.1)IDIGIT(I)=0 2885 IF(I.EQ.2)IDIGIT(I)=2 2886 IF(I.EQ.5)IDIGIT(I)=2 2887 4106 CONTINUE 2888C 2889 IMAX=15 2890 IF(IMAX.GT.N)IMAX=N 2891 IMAX2=10 2892C 2893 DO4110I=1,IMAX2 2894 NCTEXT(I)=0 2895 AMAT(I,1)=REAL(I) 2896 AMAT(I,2)=ANRUL(I) 2897 AMAT(I,3)=ENRUL(I) 2898 AMAT(I,4)=SNRUL(I) 2899 AMAT(I,5)=ZNRUL(I) 2900 4110 CONTINUE 2901 IWHTML(1)=75 2902 IWHTML(2)=150 2903 IWHTML(3)=150 2904 IWHTML(4)=150 2905 IWHTML(5)=150 2906 IWHTML(6)=150 2907 IWRTF(1)=800 2908 IWRTF(2)=IWRTF(1)+1800 2909 IWRTF(3)=IWRTF(2)+1800 2910 IWRTF(4)=IWRTF(3)+1800 2911 IWRTF(5)=IWRTF(4)+1800 2912 IFRST=.TRUE. 2913 ILAST=.TRUE. 2914C 2915 CALL DPDTA2(ITITL9,NCTIT9, 2916 1 ITITLE,NCTITL,ITITL2,NCTIT2, 2917 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 2918 1 ITEXT,NCTEXT,AMAT,MAXROW,IMAX2, 2919 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 2920 1 ICAPSW,ICAPTY,IFRST,ILAST, 2921 1 ISUBRO,IBUGA3,IERROR) 2922C 2923 ITITL9=' ' 2924 NCTIT9=0 2925 ITITLE='Statistic: Number of Runs Up of Length I or More' 2926 NCTITL=48 2927C 2928 DO4130I=1,IMAX2 2929 NCTEXT(I)=0 2930 AMAT(I,1)=REAL(I) 2931 AMAT(I,2)=ANRULG(I) 2932 AMAT(I,3)=ENRULG(I) 2933 AMAT(I,4)=SNRULG(I) 2934 AMAT(I,5)=ZNRULG(I) 2935 4130 CONTINUE 2936 IFRST=.TRUE. 2937 ILAST=.TRUE. 2938C 2939 CALL DPDTA2(ITITL9,NCTIT9, 2940 1 ITITLE,NCTITL,ITITL2,NCTIT2, 2941 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 2942 1 ITEXT,NCTEXT,AMAT,MAXROW,IMAX2, 2943 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 2944 1 ICAPSW,ICAPTY,IFRST,ILAST, 2945 1 ISUBRO,IBUGA3,IERROR) 2946C 2947 ITITL9='Runs Down' 2948 NCTIT9=9 2949 ITITLE='Statistic: Number of Runs Down of Length Exactly I' 2950 NCTITL=50 2951C 2952 DO4210I=1,IMAX2 2953 NCTEXT(I)=0 2954 AMAT(I,1)=REAL(I) 2955 AMAT(I,2)=ANRDL(I) 2956 AMAT(I,3)=ENRUL(I) 2957 AMAT(I,4)=SNRUL(I) 2958 AMAT(I,5)=ZNRDL(I) 2959 4210 CONTINUE 2960 IFRST=.TRUE. 2961 ILAST=.TRUE. 2962C 2963 CALL DPDTA2(ITITL9,NCTIT9, 2964 1 ITITLE,NCTITL,ITITL2,NCTIT2, 2965 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 2966 1 ITEXT,NCTEXT,AMAT,MAXROW,IMAX2, 2967 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 2968 1 ICAPSW,ICAPTY,IFRST,ILAST, 2969 1 ISUBRO,IBUGA3,IERROR) 2970C 2971 ITITL9=' ' 2972 NCTIT9=0 2973 ITITLE='Statistic: Number of Runs Down of Length I or More' 2974 NCTITL=50 2975C 2976 DO4230I=1,IMAX2 2977 NCTEXT(I)=0 2978 AMAT(I,1)=REAL(I) 2979 AMAT(I,2)=ANRDLG(I) 2980 AMAT(I,3)=ENRULG(I) 2981 AMAT(I,4)=SNRULG(I) 2982 AMAT(I,5)=ZNRDLG(I) 2983 4230 CONTINUE 2984 IFRST=.TRUE. 2985 ILAST=.TRUE. 2986C 2987 CALL DPDTA2(ITITL9,NCTIT9, 2988 1 ITITLE,NCTITL,ITITL2,NCTIT2, 2989 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 2990 1 ITEXT,NCTEXT,AMAT,MAXROW,IMAX2, 2991 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 2992 1 ICAPSW,ICAPTY,IFRST,ILAST, 2993 1 ISUBRO,IBUGA3,IERROR) 2994C 2995 ITITL9='Runs Total = Runs Up + Runs Down' 2996 NCTIT9=32 2997 ITITLE='Statistic: Number of Runs Total of Length Exactly I' 2998 NCTITL=51 2999C 3000 DO4310I=1,IMAX2 3001 NCTEXT(I)=0 3002 AMAT(I,1)=REAL(I) 3003 AMAT(I,2)=ANRTL(I) 3004 AMAT(I,3)=ENRTL(I) 3005 AMAT(I,4)=SNRTL(I) 3006 AMAT(I,5)=ZNRTL(I) 3007 4310 CONTINUE 3008 IFRST=.TRUE. 3009 ILAST=.TRUE. 3010C 3011 CALL DPDTA2(ITITL9,NCTIT9, 3012 1 ITITLE,NCTITL,ITITL2,NCTIT2, 3013 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 3014 1 ITEXT,NCTEXT,AMAT,MAXROW,IMAX2, 3015 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 3016 1 ICAPSW,ICAPTY,IFRST,ILAST, 3017 1 ISUBRO,IBUGA3,IERROR) 3018C 3019 ITITL9=' ' 3020 NCTIT9=0 3021 ITITLE='Statistic: Number of Runs Total of Length I or More' 3022 NCTITL=51 3023C 3024 DO4330I=1,IMAX2 3025 NCTEXT(I)=0 3026 AMAT(I,1)=REAL(I) 3027 AMAT(I,2)=ANRTLG(I) 3028 AMAT(I,3)=ENRTLG(I) 3029 AMAT(I,4)=SNRTLG(I) 3030 AMAT(I,5)=ZNRTLG(I) 3031 4330 CONTINUE 3032 IFRST=.TRUE. 3033 ILAST=.TRUE. 3034C 3035 CALL DPDTA2(ITITL9,NCTIT9, 3036 1 ITITLE,NCTITL,ITITL2,NCTIT2, 3037 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 3038 1 ITEXT,NCTEXT,AMAT,MAXROW,IMAX2, 3039 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 3040 1 ICAPSW,ICAPTY,IFRST,ILAST, 3041 1 ISUBRO,IBUGA3,IERROR) 3042C 3043C ***************** 3044C ** STEP 90-- ** 3045C ** EXIT ** 3046C ***************** 3047C 3048 9000 CONTINUE 3049 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RUN2')THEN 3050 WRITE(ICOUT,999) 3051 CALL DPWRST('XXX','BUG ') 3052 WRITE(ICOUT,9011) 3053 9011 FORMAT('***** AT THE END OF DPRUN2--') 3054 CALL DPWRST('XXX','BUG ') 3055 WRITE(ICOUT,9012)IERROR 3056 9012 FORMAT('IERROR = ',A4) 3057 CALL DPWRST('XXX','BUG ') 3058 ENDIF 3059C 3060 RETURN 3061 END 3062 SUBROUTINE DPRUNS(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 3063 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 3064C 3065C PURPOSE--FORM A RUN-SEQUENCE PLOT. 3066C WRITTEN BY--JAMES J. FILLIBEN 3067C STATISTICAL ENGINEERING DIVISION 3068C INFORMATION TECHNOLOGY LABORATORY 3069C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 3070C GAITHERSBURG, MD 20899-8980 3071C PHONE--301-975-2899 3072C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 3073C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 3074C LANGUAGE--ANSI FORTRAN (1977) 3075C VERSION NUMBER--82/7 3076C ORIGINAL VERSION--DECEMBER 1977. 3077C UPDATED --JANUARY 1978. 3078C UPDATED --FEBRUARY 1978. 3079C UPDATED --MAY 1978. 3080C UPDATED --JULY 1978. 3081C UPDATED --JANUARY 1981. 3082C UPDATED --MAY 1982. 3083C UPDATED --MAY 2011. USE DPPARS 3084C UPDATED --MAY 2011. SUPPORT HIGHLIGHT, MULTIPLE 3085C AND REPLICATION OPTIONS 3086C 3087C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 3088C 3089 CHARACTER*4 ICASPL 3090 CHARACTER*4 IAND1 3091 CHARACTER*4 IAND2 3092 CHARACTER*4 IBUGG2 3093 CHARACTER*4 IBUGG3 3094 CHARACTER*4 IBUGQ 3095 CHARACTER*4 ISUBRO 3096 CHARACTER*4 IFOUND 3097 CHARACTER*4 IERROR 3098C 3099 CHARACTER*4 ISUBN1 3100 CHARACTER*4 ISUBN2 3101 CHARACTER*4 ISTEPN 3102C 3103 CHARACTER*4 IREPL 3104 CHARACTER*4 IMULT 3105 CHARACTER*4 IHIGH 3106 CHARACTER*4 IWRITE 3107C 3108 CHARACTER*4 ICTMP1 3109 CHARACTER*4 ICTMP2 3110 CHARACTER*4 ICTMP3 3111 CHARACTER*4 ICTMP4 3112 CHARACTER*4 ICASE 3113 CHARACTER*40 INAME 3114 PARAMETER (MAXSPN=30) 3115 CHARACTER*4 IVARN1(MAXSPN) 3116 CHARACTER*4 IVARN2(MAXSPN) 3117 CHARACTER*4 IVARTY(MAXSPN) 3118 REAL PVAR(MAXSPN) 3119 INTEGER ILIS(MAXSPN) 3120 INTEGER NRIGHT(MAXSPN) 3121 INTEGER ICOLR(MAXSPN) 3122C 3123C--------------------------------------------------------------------- 3124C 3125C-----COMMON---------------------------------------------------------- 3126C 3127 INCLUDE 'DPCOPA.INC' 3128 INCLUDE 'DPCOHK.INC' 3129 INCLUDE 'DPCODA.INC' 3130C 3131 DIMENSION XHIGH(MAXOBV) 3132 DIMENSION ZY(MAXOBV) 3133 DIMENSION ZX(MAXOBV) 3134 DIMENSION X1(MAXOBV) 3135 DIMENSION X2(MAXOBV) 3136 DIMENSION X3(MAXOBV) 3137 DIMENSION X4(MAXOBV) 3138 DIMENSION X5(MAXOBV) 3139 DIMENSION X6(MAXOBV) 3140 DIMENSION XTEMP1(MAXOBV) 3141 DIMENSION XTEMP2(MAXOBV) 3142 DIMENSION XTEMP3(MAXOBV) 3143 DIMENSION XTEMP4(MAXOBV) 3144 DIMENSION XTEMP5(MAXOBV) 3145 DIMENSION XTEMP6(MAXOBV) 3146C 3147 INCLUDE 'DPCOZZ.INC' 3148 EQUIVALENCE (GARBAG(IGARB1),XHIGH(1)) 3149 EQUIVALENCE (GARBAG(IGARB2),ZY(1)) 3150 EQUIVALENCE (GARBAG(IGARB3),ZX(1)) 3151 EQUIVALENCE (GARBAG(IGARB4),X1(1)) 3152 EQUIVALENCE (GARBAG(IGARB5),X2(1)) 3153 EQUIVALENCE (GARBAG(IGARB6),X3(1)) 3154 EQUIVALENCE (GARBAG(IGARB7),X4(1)) 3155 EQUIVALENCE (GARBAG(IGARB8),X5(1)) 3156 EQUIVALENCE (GARBAG(IGARB9),X6(1)) 3157 EQUIVALENCE (GARBAG(IGAR10),XTEMP1(1)) 3158 EQUIVALENCE (GARBAG(JGAR11),XTEMP2(1)) 3159 EQUIVALENCE (GARBAG(JGAR12),XTEMP3(1)) 3160 EQUIVALENCE (GARBAG(JGAR13),XTEMP4(1)) 3161 EQUIVALENCE (GARBAG(JGAR14),XTEMP5(1)) 3162 EQUIVALENCE (GARBAG(JGAR15),XTEMP6(1)) 3163C 3164C-----COMMON VARIABLES (GENERAL)-------------------------------------- 3165C 3166 INCLUDE 'DPCOP2.INC' 3167C 3168C-----START POINT----------------------------------------------------- 3169C 3170 IFOUND='NO' 3171 IERROR='NO' 3172 IREPL='OFF' 3173 IHIGH='OFF' 3174 IMULT='OFF' 3175 ISUBN1='DPRU' 3176 ISUBN2='NS ' 3177C 3178 MAXCP1=MAXCOL+1 3179 MAXCP2=MAXCOL+2 3180 MAXCP3=MAXCOL+3 3181 MAXCP4=MAXCOL+4 3182 MAXCP5=MAXCOL+5 3183 MAXCP6=MAXCOL+6 3184C 3185C **************************************** 3186C ** TREAT THE RUN-SEQUENCE PLOT CASE ** 3187C **************************************** 3188C 3189 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'RUNS')THEN 3190 WRITE(ICOUT,999) 3191 999 FORMAT(1X) 3192 CALL DPWRST('XXX','BUG ') 3193 WRITE(ICOUT,51) 3194 51 FORMAT('***** AT THE BEGINNING OF DPRUNS--') 3195 CALL DPWRST('XXX','BUG ') 3196 WRITE(ICOUT,52)ICASPL,IAND1,IAND2 3197 52 FORMAT('ICASPL,IAND1,IAND2 = ',2(A4,2X),A4) 3198 CALL DPWRST('XXX','BUG ') 3199 WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO 3200 53 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4) 3201 CALL DPWRST('XXX','BUG ') 3202 ENDIF 3203C 3204 ICASPL='RUNS' 3205 ILASTZ=9999 3206 DO100I=0,NUMARG-1 3207 IF(I.EQ.0)THEN 3208 ICTMP1=ICOM 3209 ELSE 3210 ICTMP1=IHARG(I) 3211 ENDIF 3212 ICTMP2=IHARG(I+1) 3213 ICTMP3=IHARG(I+2) 3214 ICTMP4=IHARG(I+3) 3215C 3216 IF(ICTMP1.EQ.'RUN' .AND. ICTMP2.EQ.'SEQU')THEN 3217 IFOUND='YES' 3218 ILASTZ=I+1 3219 ELSEIF(ICTMP1.EQ.'PLOT')THEN 3220 ILASTZ=I 3221 ELSEIF(ICTMP1.EQ.'REPL')THEN 3222 IREPL='ON' 3223 ILASTZ=MAX(ILASTZ,I) 3224 ELSEIF(ICTMP1.EQ.'MULT')THEN 3225 IMULT='ON' 3226 ILASTZ=MAX(ILASTZ,I) 3227 ELSEIF(ICTMP1.EQ.'HIGH' .OR. ICTMP1.EQ.'SUBS')THEN 3228 IHIGH='ON' 3229 ILASTZ=MAX(ILASTZ,I) 3230 ENDIF 3231 100 CONTINUE 3232C 3233 IF(IFOUND.EQ.'NO')GOTO9000 3234C 3235 ISHIFT=ILASTZ 3236 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 3237 1 IBUGG2,IERROR) 3238C 3239 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'RUNS')THEN 3240 WRITE(ICOUT,92)IMULT,IREPL,IHIGH,ILASTZ 3241 92 FORMAT('IMULT,IREPL,IHIGH,ILASTZ = ',3(A4,2X),I5) 3242 CALL DPWRST('XXX','BUG ') 3243 ENDIF 3244C 3245 IF(IMULT.EQ.'ON')THEN 3246 IF(IREPL.EQ.'ON')THEN 3247 WRITE(ICOUT,999) 3248 CALL DPWRST('XXX','BUG ') 3249 WRITE(ICOUT,101) 3250 101 FORMAT('***** ERROR IN RUN SEQUENCE PLOT--') 3251 CALL DPWRST('XXX','BUG ') 3252 WRITE(ICOUT,102) 3253 102 FORMAT(' YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ', 3254 1 '"REPLICATION" FOR THE PROBABILITY PLOT.') 3255 CALL DPWRST('XXX','BUG ') 3256 IERROR='YES' 3257 GOTO9000 3258 ELSEIF(IHIGH.EQ.'ON')THEN 3259 WRITE(ICOUT,999) 3260 CALL DPWRST('XXX','BUG ') 3261 WRITE(ICOUT,101) 3262 CALL DPWRST('XXX','BUG ') 3263 WRITE(ICOUT,122) 3264 122 FORMAT(' YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ', 3265 1 '"HIGHTLIGHTED" FOR THE PROBABILITY PLOT.') 3266 CALL DPWRST('XXX','BUG ') 3267 IERROR='YES' 3268 GOTO9000 3269 ENDIF 3270 ENDIF 3271C 3272C ********************************* 3273C ** STEP 2-- ** 3274C ** EXTRACT THE VARIABLE LIST ** 3275C ********************************* 3276C 3277 ISTEPN='4' 3278 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'RUNS') 3279 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3280C 3281 INAME='RUN SEQUENCE PLOT' 3282 MINNA=1 3283 MAXNA=100 3284 MINN2=1 3285 IFLAGE=1 3286 IFLAGM=0 3287 IF(IMULT.EQ.'ON')THEN 3288 IFLAGE=0 3289 IFLAGM=1 3290 ELSE 3291 IF(IREPL.EQ.'OFF' .AND. IHIGH.EQ.'OFF')IFLAGM=1 3292 ENDIF 3293 IFLAGP=0 3294 JMIN=1 3295 JMAX=NUMARG 3296 MINNVA=1 3297 MAXNVA=1 3298 IF(IHIGH.EQ.'ON')THEN 3299 MINNVA=2 3300 MAXNVA=2 3301 ELSEIF(IREPL.EQ.'ON')THEN 3302 MINNVA=2 3303 MAXNVA=7 3304 ELSEIF(IMULT.EQ.'ON')THEN 3305 MINNVA=1 3306 MAXNVA=MAXSPN 3307 ENDIF 3308C 3309 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 3310 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 3311 1 JMIN,JMAX, 3312 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 3313 1 IVARN1,IVARN2,IVARTY,PVAR, 3314 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 3315 1 MINNVA,MAXNVA, 3316 1 IFLAGM,IFLAGP, 3317 1 IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 3318C 3319 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'RUNS')THEN 3320 WRITE(ICOUT,999) 3321 CALL DPWRST('XXX','BUG ') 3322 WRITE(ICOUT,281) 3323 281 FORMAT('***** AFTER CALL DPPARS--') 3324 CALL DPWRST('XXX','BUG ') 3325 WRITE(ICOUT,282)NQ,NUMVAR 3326 282 FORMAT('NQ,NUMVAR = ',2I8) 3327 CALL DPWRST('XXX','BUG ') 3328 IF(NUMVAR.GT.0)THEN 3329 DO285I=1,NUMVAR 3330 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 3331 1 ICOLR(I) 3332 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 3333 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 3334 CALL DPWRST('XXX','BUG ') 3335 285 CONTINUE 3336 ENDIF 3337 ENDIF 3338 IF(IERROR.EQ.'YES')GOTO9000 3339C 3340C *********************************************** 3341C ** STEP 3-- ** 3342C ** DETERMINE: ** 3343C ** 1) NUMBER OF REPLICATION VARIABLES (0-1) ** 3344C ** 2) NUMBER OF RESPONSE VARIABLES (>= 1)** 3345C ** 3) NUMBER OF HIGHLIGHT VARIABLES (0-1) ** 3346C *********************************************** 3347C 3348 ISTEPN='5' 3349 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'RUNS') 3350 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3351C 3352 NRESP=0 3353 NREPL=0 3354 NHIGH=0 3355 IF(IMULT.EQ.'ON')THEN 3356 NRESP=NUMVAR 3357 ELSEIF(IHIGH.EQ.'ON')THEN 3358 NRESP=1 3359 NHIGH=1 3360 ELSEIF(IREPL.EQ.'ON')THEN 3361 NRESP=1 3362 NREPL=NUMVAR-NRESP 3363 IF(NREPL.LT.1)IREPL='OFF' 3364 IF(NREPL.GT.6)THEN 3365 WRITE(ICOUT,999) 3366 CALL DPWRST('XXX','BUG ') 3367 WRITE(ICOUT,101) 3368 CALL DPWRST('XXX','BUG ') 3369 WRITE(ICOUT,511) 3370 511 FORMAT(' FOR THE REPLICATION CASE, AT MOST SIX ', 3371 1 'REPLICATION VARIABLE') 3372 CALL DPWRST('XXX','BUG ') 3373 WRITE(ICOUT,512) 3374 512 FORMAT(' ALLOWED; SUCH WAS NOT THE CASE HERE.') 3375 CALL DPWRST('XXX','BUG ') 3376 WRITE(ICOUT,513)NREPL 3377 513 FORMAT(' THE NUMBER OF REPLICATION VARIABLES = ',I5) 3378 CALL DPWRST('XXX','BUG ') 3379 IERROR='YES' 3380 GOTO9000 3381 ENDIF 3382 ENDIF 3383C 3384C CASE 1: NO HIGHLIGHTING AND NO REPLICATION 3385C 3386 IF(IREPL.EQ.'OFF' .AND. IHIGH.EQ.'OFF')THEN 3387 NPLOTP=0 3388 ICNT=0 3389 DO510K=1,NUMVAR 3390 ICOL=K 3391 NUMVA2=1 3392 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 3393 1 INAME,IVARN1,IVARN2,IVARTY, 3394 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 3395 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 3396 1 MAXCP4,MAXCP5,MAXCP6, 3397 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 3398 1 ZY,ZY,ZY,NS,NS,NS,ICASE, 3399 1 IBUGG3,ISUBRO,IFOUND,IERROR) 3400 IF(IERROR.EQ.'YES')GOTO9000 3401C 3402 ICNT=ICNT+1 3403 IF(NS.GE.1)THEN 3404 DO520I=1,NS 3405 NPLOTP=NPLOTP+1 3406 Y(NPLOTP)=ZY(I) 3407 X(NPLOTP)=REAL(NPLOTP) 3408 D(NPLOTP)=REAL(ICNT) 3409 520 CONTINUE 3410 ENDIF 3411 510 CONTINUE 3412C 3413C CASE 2: HIGHLIGHTING 3414C 3415 ELSEIF(IHIGH.EQ.'ON')THEN 3416 NPLOTP=0 3417 ICOL=1 3418 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 3419 1 INAME,IVARN1,IVARN2,IVARTY, 3420 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 3421 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 3422 1 MAXCP4,MAXCP5,MAXCP6, 3423 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 3424 1 ZY,XHIGH,ZY,NS,NS,NS,ICASE, 3425 1 IBUGG3,ISUBRO,IFOUND,IERROR) 3426 IF(IERROR.EQ.'YES')GOTO9000 3427C 3428 IF(NS.GE.1)THEN 3429 DO620I=1,NS 3430 NPLOTP=NPLOTP+1 3431 Y(NPLOTP)=ZY(I) 3432 X(NPLOTP)=REAL(NPLOTP) 3433 D(NPLOTP)=XHIGH(I) 3434 620 CONTINUE 3435 ENDIF 3436 ELSEIF(IREPL.EQ.'ON')THEN 3437 ICOL=1 3438 CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 3439 1 INAME,IVARN1,IVARN2,IVARTY, 3440 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 3441 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 3442 1 MAXCP4,MAXCP5,MAXCP6, 3443 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 3444 1 ZY,X1,X2,X3,X4,X5,X6,NLOCAL, 3445 1 IBUGG3,ISUBRO,IFOUND,IERROR) 3446 IF(IERROR.EQ.'YES')GOTO9000 3447 IF(NLOCAL.LE.0)GOTO9000 3448C 3449C IF THERE ARE TWO OR MORE REPLICATION VARIABLES, COMBINE 3450C THEM TO CREATE A SINGLE REPLICATION VARIABLE. 3451C 3452 ICCTOF=0 3453 ICCTG1=-99 3454 ICCTG2=-99 3455 ICCTG3=-99 3456 ICCTG4=-99 3457 ICCTG5=-99 3458 IWRITE='OFF' 3459C 3460 IF(NUMVAR.EQ.3)THEN 3461 CALL CODCT2(X1,X2,NLOCAL,ICCTOF,ICCTG1,IWRITE, 3462 1 ZX,XTEMP1,XTEMP2, 3463 1 IBUGG3,ISUBRO,IERROR) 3464 DO7011I=1,NLOCAL 3465 X1(I)=ZX(I) 3466 7011 CONTINUE 3467 NUMVAR=2 3468 ELSEIF(NUMVAR.EQ.4)THEN 3469 CALL CODCT3(X1,X2,X3,NLOCAL,ICCTOF,ICCTG1,ICCTG2,IWRITE, 3470 1 ZX,XTEMP1,XTEMP2,XTEMP3, 3471 1 IBUGG3,ISUBRO,IERROR) 3472 DO7012I=1,NLOCAL 3473 X1(I)=ZX(I) 3474 7012 CONTINUE 3475 NUMVAR=2 3476 ELSEIF(NUMVAR.EQ.5)THEN 3477 CALL CODCT4(X1,X2,X3,X4,NLOCAL, 3478 1 ICCTOF,ICCTG1,ICCTG2,ICCTG3,IWRITE, 3479 1 ZX,XTEMP1,XTEMP2,XTEMP3,XTEMP4, 3480 1 IBUGG3,ISUBRO,IERROR) 3481 DO7013I=1,NLOCAL 3482 X1(I)=ZX(I) 3483 7013 CONTINUE 3484 NUMVAR=2 3485 ELSEIF(NUMVAR.EQ.6)THEN 3486 CALL CODCT5(X1,X2,X3,X4,X5,NLOCAL, 3487 1 ICCTOF,ICCTG1,ICCTG2,ICCTG3,ICCTG4,IWRITE, 3488 1 ZX,XTEMP1,XTEMP2,XTEMP3,XTEMP4,XTEMP5, 3489 1 IBUGG3,ISUBRO,IERROR) 3490 DO7014I=1,NLOCAL 3491 X1(I)=ZX(I) 3492 7014 CONTINUE 3493 NUMVAR=2 3494 ELSEIF(NUMVAR.EQ.7)THEN 3495 CALL CODCT6(X1,X2,X3,X4,X5,X6,NLOCAL, 3496 1 ICCTOF,ICCTG1,ICCTG2,ICCTG3,ICCTG4,ICCTG5,IWRITE, 3497 1 ZX,XTEMP1,XTEMP2,XTEMP3,XTEMP4,XTEMP5,XTEMP6, 3498 1 IBUGG3,ISUBRO,IERROR) 3499 DO7015I=1,NLOCAL 3500 X1(I)=ZX(I) 3501 7015 CONTINUE 3502 NUMVAR=2 3503 ENDIF 3504C 3505 NPLOTP=0 3506 DO7020I=1,NLOCAL 3507 NPLOTP=NPLOTP+1 3508 Y(NPLOTP)=ZY(I) 3509 X(NPLOTP)=REAL(NPLOTP) 3510 D(NPLOTP)=X1(I) 3511 7020 CONTINUE 3512 ENDIF 3513C 3514C ***************** 3515C ** STEP 90-- ** 3516C ** EXIT ** 3517C ***************** 3518C 3519 9000 CONTINUE 3520 NPLOTV=1 3521 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'RUNS')THEN 3522 WRITE(ICOUT,999) 3523 CALL DPWRST('XXX','BUG ') 3524 WRITE(ICOUT,9011) 3525 9011 FORMAT('***** AT THE END OF DPRUNS--') 3526 CALL DPWRST('XXX','BUG ') 3527 WRITE(ICOUT,9012)IFOUND,IERROR 3528 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 3529 CALL DPWRST('XXX','BUG ') 3530 WRITE(ICOUT,9013)NPLOTV,NPLOTP,NLOCAL 3531 9013 FORMAT('NPLOTV,NPLOTP,NLOCAL = ',3I8) 3532 CALL DPWRST('XXX','BUG ') 3533 IF(NPLOTP.GE.1)THEN 3534 DO9015I=1,NPLOTP 3535 WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 3536 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) 3537 CALL DPWRST('XXX','BUG ') 3538 9015 CONTINUE 3539 ENDIF 3540 ENDIF 3541C 3542 RETURN 3543 END 3544 SUBROUTINE DPRUPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 3545 1 IANGLU,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 3546C 3547C PURPOSE--GENERATE A RUNS PLOT. 3548C 3549C WRITTEN BY--JAMES J. FILLIBEN 3550C STATISTICAL ENGINEERING DIVISION 3551C INFORMATION TECHNOLOGY LABORATORY 3552C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 3553C GAITHERSBURG, MD 20899-8980 3554C PHONE--301-975-2899 3555C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 3556C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 3557C LANGUAGE--ANSI FORTRAN (1977) 3558C VERSION NUMBER--82/7 3559C ORIGINAL VERSION--SEPTEMBER 1981. 3560C UPDATED --MAY 1982. 3561C 3562C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 3563C 3564 CHARACTER*4 ICASPL 3565 CHARACTER*4 IAND1 3566 CHARACTER*4 IAND2 3567 CHARACTER*4 IANGLU 3568 CHARACTER*4 IBUGG2 3569 CHARACTER*4 IBUGG3 3570 CHARACTER*4 IBUGQ 3571 CHARACTER*4 IFOUND 3572 CHARACTER*4 IERROR 3573C 3574 CHARACTER*4 ISUBN1 3575 CHARACTER*4 ISUBN2 3576C 3577C-----COMMON---------------------------------------------------------- 3578C 3579 INCLUDE 'DPCOP2.INC' 3580C 3581C-----START POINT----------------------------------------------------- 3582C 3583 ISUBN1='DPRU' 3584 ISUBN2='PL ' 3585 IFOUND='YES' 3586 IERROR='NO' 3587C 3588 IF(IBUGG2.EQ.'ON')THEN 3589 WRITE(ICOUT,51) 3590 51 FORMAT('***** ERROR IN DPRUPL--') 3591 CALL DPWRST('XXX','BUG ') 3592 WRITE(ICOUT,53)NPLOTV,NPLOTP,NS 3593 53 FORMAT('NPLOTV,NPLOTP,NS = ',3I8) 3594 CALL DPWRST('XXX','BUG ') 3595 WRITE(ICOUT,55)ICASPL,IAND1,IAND2,IANGLU 3596 55 FORMAT('ICASPL,IAND1,IAND2,IANGLU = ',3(A4,2X),A4) 3597 CALL DPWRST('XXX','BUG ') 3598 WRITE(ICOUT,57)IBUGG2,IBUGG3,IBUGQ 3599 57 FORMAT('IBUGG2,IBUGG3,IBUGQ = ',2(A4,2X),A4) 3600 CALL DPWRST('XXX','BUG ') 3601 ENDIF 3602C 3603 WRITE(ICOUT,999) 3604 999 FORMAT(1X) 3605 CALL DPWRST('XXX','BUG ') 3606 WRITE(ICOUT,101) 3607 101 FORMAT('***** ERROR IN DPRUPL--') 3608 CALL DPWRST('XXX','BUG ') 3609 WRITE(ICOUT,102) 3610 102 FORMAT(' RUNS PLOT CAPABILITY') 3611 CALL DPWRST('XXX','BUG ') 3612 WRITE(ICOUT,103) 3613 103 FORMAT(' NOT YET AVAILABLE') 3614 CALL DPWRST('XXX','BUG ') 3615C 3616 RETURN 3617 END 3618 SUBROUTINE DPRWLA(IA,IPARN,IPARN2,IWRITE,IINDX, 3619 1 IBUGA3,ISUBRO,IERROR) 3620C 3621C PURPOSE--CONVERT A STRING TO A ROW LABEL. EXAMPLE: 3622C 3623C LET ROWLABEL = STRING TO ROW LABEL IROW S 3624C 3625C WHERE IROW IS THE ROW NUMBER IN THE ROW LABEL AND 3626C S IS A PREVIOUSLY DEFINED STRING. 3627C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 3628C RESTRICTIONS--THE MAXIMUM ROW NUMBER IS MAXOBV. 3629C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 3630C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 3631C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 3632C LANGUAGE--ANSI FORTRAN (1977) 3633C REFERENCES--NONE. 3634C WRITTEN BY--ALAN HECKERT 3635C STATISTICAL ENGINEERING DIVISION 3636C INFORMATION TECHNOLOGY LABORATORY 3637C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 3638C GAITHERSBURG, MD 20899-8980 3639C PHONE--301-975-2899 3640C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 3641C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 3642C LANGUAGE--ANSI FORTRAN (1977) 3643C VERSION NUMBER--2012/6 3644C ORIGINAL VERSION--JUNE 2012. 3645C 3646C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 3647C 3648 CHARACTER*4 IWRITE 3649 CHARACTER*4 IBUGA3 3650 CHARACTER*4 ISUBRO 3651 CHARACTER*4 IERROR 3652C 3653 CHARACTER*4 ISTEPN 3654 CHARACTER*4 ISUBN1 3655 CHARACTER*4 ISUBN2 3656 CHARACTER*4 MESSAG 3657 CHARACTER*4 IA 3658 CHARACTER*4 IPARN 3659 CHARACTER*4 IPARN2 3660C 3661 DIMENSION IA(*) 3662 DIMENSION IPARN(*) 3663 DIMENSION IPARN2(*) 3664C 3665C--------------------------------------------------------------------- 3666C 3667 INCLUDE 'DPCOPA.INC' 3668 INCLUDE 'DPCODA.INC' 3669 INCLUDE 'DPCOHK.INC' 3670C 3671 CHARACTER*4 IHTEMP(200) 3672 CHARACTER*130 ISTRIN 3673 CHARACTER*130 ISTRI2 3674C 3675 PARAMETER(MAXIND=100) 3676C 3677 CHARACTER*4 ISTRN1(MAXIND) 3678 CHARACTER*4 ISTRN2(MAXIND) 3679C 3680C-----COMMON---------------------------------------------------------- 3681C 3682 INCLUDE 'DPCOP2.INC' 3683C 3684C-----START POINT----------------------------------------------------- 3685C 3686 ISUBN1='DPRW' 3687 ISUBN2='LA ' 3688 IERROR='NO' 3689 IOPFLG=0 3690C 3691 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RWLA')THEN 3692 WRITE(ICOUT,999) 3693 999 FORMAT(1X) 3694 CALL DPWRST('XXX','BUG ') 3695 WRITE(ICOUT,51) 3696 51 FORMAT('***** AT THE BEGINNING OF DPRWLA--') 3697 CALL DPWRST('XXX','BUG ') 3698 WRITE(ICOUT,52)IBUGA3,ISUBRO,IA(1),IPARN(1),IPARN2(1) 3699 52 FORMAT('IBUGA3,ISUBRO,IA(1),IPARN1,IPARN2 = ',3(A4,2X),2A4) 3700 CALL DPWRST('XXX','BUG ') 3701 ENDIF 3702C 3703C ************************************************* 3704C ** STEP 1-- ** 3705C ** DETERMINE ROW INDEX. ** 3706C ************************************************* 3707C 3708 ISTEPN='1' 3709 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RWLA') 3710 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3711C 3712 NTEMP=IINDX+1 3713 IF(IARGT(NTEMP).EQ.'NUMB')THEN 3714 IROW=INT(ARG(NTEMP)+0.5) 3715 IF(IROW.LT.1 .OR. IROW.GT.MAXOBV)THEN 3716 WRITE(ICOUT,1001) 3717 CALL DPWRST('XXX','BUG ') 3718 WRITE(ICOUT,1013)MAXOBV 3719 1013 FORMAT(' THE ROW INDEX IS LESS THAN ONE OR GREATER ', 3720 1 'THAN ',I8) 3721 CALL DPWRST('XXX','BUG ') 3722 WRITE(ICOUT,1015)NTEMP 3723 1015 FORMAT(' THE VALUE OF THE ROW INDEX = ',I8) 3724 CALL DPWRST('XXX','BUG ') 3725 IERROR='YES' 3726 GOTO9000 3727 ENDIF 3728 ELSE 3729 WRITE(ICOUT,1001) 3730 1001 FORMAT('***** ERROR IN STRING TO ROW LABEL--') 3731 CALL DPWRST('XXX','BUG ') 3732 WRITE(ICOUT,1003)NTEMP 3733 1003 FORMAT(' ARGUMENT ',I5,' (THE ROW INDEX) IS NOT NUMBER.') 3734 CALL DPWRST('XXX','BUG ') 3735 WRITE(ICOUT,1005)IHARG(NTEMP),IHARG2(NTEMP) 3736 1005 FORMAT(' THE VALUE OF THE ARGUMENT = ',A4,A4) 3737 CALL DPWRST('XXX','BUG ') 3738 IERROR='YES' 3739 GOTO9000 3740 ENDIF 3741C 3742C ************************************************* 3743C ** STEP 2-- ** 3744C ** DETERMINE IF NEXT ARGUMENT IS A PREVIOUSLY ** 3745C ** DEFINED STRING. IF NOT, TREAT AS A ** 3746C ** LITERAL STRING. ** 3747C ************************************************* 3748C 3749 ISTEPN='2' 3750 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RWLA') 3751 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3752C 3753 JMIN=IINDX+2 3754 JMAX=NUMARG 3755C 3756 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RWLA')THEN 3757 WRITE(ICOUT,4001)JMIN,JMAX,MAXIND 3758 4001 FORMAT('JMIN,JMAX,MAXIND = ',3I8) 3759 CALL DPWRST('XXX','BUG ') 3760 ENDIF 3761C 3762 IF(JMAX.LT.JMIN)GOTO8000 3763 IWRITE='OFF' 3764 IERROR='NO' 3765C 3766 CALL EXTSTR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXIND, 3767 1 IHNAME,IHNAM2,IUSE,NUMNAM, 3768 1 ISTRN1,ISTRN2,NUMSTR, 3769 1 IWRITE,IBUGA3,ISUBRO,IERROR) 3770C 3771 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RWLA')THEN 3772 WRITE(ICOUT,4003)NUMSTR 3773 4003 FORMAT('NUMSTR = ',I8) 3774 CALL DPWRST('XXX','BUG ') 3775 ENDIF 3776C 3777 IF(IERROR.EQ.'NO')THEN 3778C 3779C CASE WHERE WE ARE EXTRACTING STRINGS 3780C 3781 IONE=1 3782 NUMSTR=MIN(NUMSTR,IONE) 3783 N=NUMSTR 3784 IROWLB(IROW)=' ' 3785C 3786 DO4010I2=1,NUMSTR 3787 DO4015I=1,NUMNAM 3788 II=I 3789 IF(ISTRN1(I2).EQ.IHNAME(I) .AND. ISTRN2(I2).EQ.IHNAM2(I)) 3790 1 GOTO4019 3791 4015 CONTINUE 3792C 3793 WRITE(ICOUT,999) 3794 CALL DPWRST('XXX','BUG ') 3795 WRITE(ICOUT,1001) 3796 CALL DPWRST('XXX','BUG ') 3797 WRITE(ICOUT,4023)ISTRN1(I2),ISTRN2(I2) 3798 4023 FORMAT(' STRING ',A4,A4,' NOT MATCHED IN NAME ', 3799 1 'TABLE.') 3800 CALL DPWRST('XXX','BUG ') 3801 IERROR='YES' 3802 GOTO8000 3803C 3804 4019 CONTINUE 3805 IVAL=IVALUE(II) 3806 VAL=VALUE(II) 3807 IL1=IVSTAR(II) 3808 IL2=IVSTOP(II) 3809C 3810 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RWLA')THEN 3811 WRITE(ICOUT,4011)IL1,IL2 3812 4011 FORMAT('II,IL1,IL2 = ',3I8) 3813 CALL DPWRST('XXX','BUG ') 3814 ENDIF 3815C 3816 CALL DPCOFH(IL1,IL2,IFUNC,NUMCHF,IHTEMP,NH,IBUGA3,IERROR) 3817 ILAST=MIN(24,NH) 3818C 3819 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RWLA')THEN 3820 WRITE(ICOUT,4013)NH,ILAST 3821 4013 FORMAT('NH,ILAST = ',2I8) 3822 CALL DPWRST('XXX','BUG ') 3823 ENDIF 3824C 3825 IF(ILAST.GT.0)THEN 3826 IROWLB(IROW)=' ' 3827 DO4020J=1,ILAST 3828 IROWLB(IROW)(J:J)=IHTEMP(J)(1:1) 3829 4020 CONTINUE 3830C 3831 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RWLA')THEN 3832 WRITE(ICOUT,4014)IROW,IROWLB(IROW) 3833 4014 FORMAT('IROW,IROWLB(IROW) = ',I8,A24) 3834 CALL DPWRST('XXX','BUG ') 3835 ENDIF 3836C 3837 ENDIF 3838 4010 CONTINUE 3839 ELSE 3840C 3841C CASE WHERE WE ARE EXTRACTING LITERALS 3842C 3843 ICNT=0 3844 IFRST=5 3845 MESSAG='OFF' 3846 IROWLB(IROW)=' ' 3847 DO4108I=1,130 3848 ISTRIN(I:I)=IANSLC(I)(1:1) 3849 4108 CONTINUE 3850C 3851 4100 CONTINUE 3852 IFRST=IFRST+1 3853 ICNT=ICNT+1 3854 ISTART=1 3855 ISTOP=130 3856 IERROR='NO' 3857 ICOL1=1 3858 ICOL2=130 3859 NCOLMX=130 3860 CALL DPEXS1(ISTRIN,NCOLMX,ISTART,ISTOP,IFRST,MESSAG, 3861 1 ICOL1,ICOL2,ISTRI2,NCSTR2, 3862 1 IBUGA3,ISUBRO,IERROR) 3863 IF(NCSTR2.GT.0 .AND. IERROR.NE.'YES')THEN 3864 ILAST=MIN(24,NCSTR2) 3865 IROWLB(IROW)=' ' 3866 DO4120J=1,ILAST 3867 IROWLB(IROW)(J:J)=ISTRI2(J:J) 3868 4120 CONTINUE 3869 GOTO4100 3870 ENDIF 3871 N=ICNT-1 3872 ENDIF 3873C 3874C ****************************** 3875C ** STEP 3-- ** 3876C ** WRITE OUT A FEW LINES ** 3877C ** OF SUMMARY INFORMATION ** 3878C ** ABOUT THE CODING. ** 3879C ****************************** 3880C 3881 IF(IFEEDB.EQ.'ON')THEN 3882 WRITE(ICOUT,999) 3883 CALL DPWRST('XXX','BUG ') 3884 WRITE(ICOUT,2821)IROW,IROWLB(IROW) 3885 2821 FORMAT('ROW LABEL ',I8,' SET TO: ',A24) 3886 CALL DPWRST('XXX','BUG ') 3887 ENDIF 3888 GOTO8000 3889C 3890 8000 CONTINUE 3891C 3892C ***************** 3893C ** STEP 90-- ** 3894C ** EXIT. ** 3895C ***************** 3896C 3897 9000 CONTINUE 3898C 3899 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RWLA')THEN 3900 WRITE(ICOUT,999) 3901 CALL DPWRST('XXX','BUG ') 3902 WRITE(ICOUT,9011) 3903 9011 FORMAT('***** AT THE END OF DPRWLA--') 3904 CALL DPWRST('XXX','BUG ') 3905 WRITE(ICOUT,9012)IBUGA3,IERROR 3906 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 3907 CALL DPWRST('XXX','BUG ') 3908 ENDIF 3909C 3910 RETURN 3911 END 3912 SUBROUTINE DPRWL2(IBUGA3,ISUBRO,IERROR) 3913C 3914C PURPOSE--DEFINE A SPECIFIC ROW LABEL. FOR EXAMPLE 3915C 3916C LET ROWLABEL 3 = CIRC 3917C 3918C WILL DEFINE ROW LABEL 3 AS "CIRC". THIS COMMAND 3919C HAS OCCASSIONAL USE WHEN THE ROW LABELS ARE USED 3920C BY THE CHARACTER COMMAND TO DEFINE PLOT POINTS. 3921C 3922C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 3923C RESTRICTIONS--THE MAXIMUM ROW NUMBER IS MAXOBV. 3924C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 3925C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 3926C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 3927C LANGUAGE--ANSI FORTRAN (1977) 3928C REFERENCES--NONE. 3929C WRITTEN BY--ALAN HECKERT 3930C STATISTICAL ENGINEERING DIVISION 3931C INFORMATION TECHNOLOGY LABORATORY 3932C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 3933C GAITHERSBURG, MD 20899-8980 3934C PHONE--301-975-2899 3935C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 3936C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 3937C LANGUAGE--ANSI FORTRAN (1977) 3938C VERSION NUMBER--2012/8 3939C ORIGINAL VERSION--AUGUST 2012. 3940C 3941C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 3942C 3943 CHARACTER*4 IBUGA3 3944 CHARACTER*4 ISUBRO 3945 CHARACTER*4 IERROR 3946C 3947 CHARACTER*4 ISTEPN 3948 CHARACTER*4 ISUBN1 3949 CHARACTER*4 ISUBN2 3950C 3951C-----COMMON---------------------------------------------------------- 3952C 3953 INCLUDE 'DPCOPA.INC' 3954 INCLUDE 'DPCODA.INC' 3955 INCLUDE 'DPCOHK.INC' 3956 INCLUDE 'DPCOP2.INC' 3957C 3958C-----START POINT----------------------------------------------------- 3959C 3960 ISUBN1='DPRW' 3961 ISUBN2='L2 ' 3962 IERROR='NO' 3963C 3964 DO10I=1,MAXOBV 3965 ISUB(I)=1 3966 10 CONTINUE 3967 IEQUAL=0 3968 ILAST=0 3969 IFRST=0 3970 NLEN=0 3971C 3972 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RWL2')THEN 3973 WRITE(ICOUT,999) 3974 999 FORMAT(1X) 3975 CALL DPWRST('XXX','BUG ') 3976 WRITE(ICOUT,51) 3977 51 FORMAT('***** AT THE BEGINNING OF DPRWL2--') 3978 CALL DPWRST('XXX','BUG ') 3979 WRITE(ICOUT,52)IBUGA3,ISUBRO 3980 52 FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4) 3981 CALL DPWRST('XXX','BUG ') 3982 ENDIF 3983C 3984C ************************************************* 3985C ** STEP 1-- ** 3986C ** DETERMINE INDEX VALUE ** 3987C ************************************************* 3988C 3989 ISTEPN='1' 3990 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RWL2') 3991 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3992C 3993 IINDX=0 3994 IF(IARGT(2).EQ.'NUMB')THEN 3995 IINDX=INT(ARG(2)+0.5) 3996 IF(IINDX.LT.1 .OR. IINDX.GT.MAXOBV)THEN 3997 WRITE(ICOUT,1001) 3998 CALL DPWRST('XXX','BUG ') 3999 WRITE(ICOUT,1013)MAXOBV 4000 1013 FORMAT(' THE ROW INDEX IS LESS THAN ONE OR GREATER ', 4001 1 'THAN ',I8) 4002 CALL DPWRST('XXX','BUG ') 4003 WRITE(ICOUT,1015)IINDX 4004 1015 FORMAT(' THE VALUE OF THE ROW INDEX = ',I8) 4005 CALL DPWRST('XXX','BUG ') 4006 IERROR='YES' 4007 GOTO9000 4008 ENDIF 4009 ELSE 4010 WRITE(ICOUT,1001) 4011 1001 FORMAT('***** ERROR IN ROW LABEL INDEX--') 4012 CALL DPWRST('XXX','BUG ') 4013 WRITE(ICOUT,1003) 4014 1003 FORMAT(' ARGUMENT 3 (THE ROW INDEX) IS NOT A NUMBER.') 4015 CALL DPWRST('XXX','BUG ') 4016 WRITE(ICOUT,1005)IHARG(3),IHARG2(3) 4017 1005 FORMAT(' THE VALUE OF THE ARGUMENT = ',2A4) 4018 CALL DPWRST('XXX','BUG ') 4019 IERROR='YES' 4020 GOTO9000 4021 ENDIF 4022C 4023C ************************************************* 4024C ** STEP 2-- ** 4025C ** NOW EXTRACT THE LABEL FROM IANSLC ** 4026C ************************************************* 4027C 4028 ISTEPN='2' 4029 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RWL2') 4030 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4031C 4032C CHECK FOR SPECIAL CASE: NO ARGUMENTS AFTER "=" 4033C 4034 IF(NUMARG.EQ.3)THEN 4035 IROWLB(IINDX)(I:I)=' ' 4036 GOTO4000 4037 ENDIF 4038C 4039C FIRST FIND THE LOCATION OF THE "=" 4040C 4041 DO2010I=1,IWIDTH 4042 IF(IANSLC(I)(1:1).EQ.'=')THEN 4043 IEQUAL=I 4044 GOTO2019 4045 ENDIF 4046 2010 CONTINUE 4047 2019 CONTINUE 4048C 4049C NOW FIND THE LAST NON-BLANK CHARACTER IN IANSLC 4050C 4051 DO2110I=IWIDTH,IEQUAL+1,-1 4052 IF(IANSLC(I)(1:1).NE.' ')THEN 4053 ILAST=I 4054 GOTO2119 4055 ENDIF 4056 2110 CONTINUE 4057 2119 CONTINUE 4058C 4059C ************************************************* 4060C ** STEP 3-- ** 4061C ** NOW DEFINE THE ROW LABEL ** 4062C ************************************************* 4063C 4064 ISTEPN='3' 4065 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RWL2') 4066 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4067 4068 IFRST=IEQUAL+1 4069 NLEN=ILAST-IFRST+1 4070 IF(NLEN.GT.24)NLEN=24 4071 IF(NLEN.LT.1)NLEN=1 4072 IROWLB(IINDX)=' ' 4073 DO3010I=1,NLEN 4074 ICNT=IEQUAL+I 4075 IROWLB(IINDX)(I:I)=IANSLC(ICNT)(1:1) 4076 3010 CONTINUE 4077C 4078C ****************************** 4079C ** STEP 4-- ** 4080C ** WRITE OUT A FEW LINES ** 4081C ** OF SUMMARY INFORMATION ** 4082C ** ABOUT THE CODING. ** 4083C ****************************** 4084C 4085 4000 CONTINUE 4086 IF(IFEEDB.EQ.'ON')THEN 4087 WRITE(ICOUT,999) 4088 CALL DPWRST('XXX','BUG ') 4089 WRITE(ICOUT,4010)IINDX,IROWLB(IINDX)(1:24) 4090 4010 FORMAT('ROW LABEL ',I8,' HAS BEEN SET TO ',A24) 4091 CALL DPWRST('XXX','BUG ') 4092 ENDIF 4093C 4094C ***************** 4095C ** STEP 90-- ** 4096C ** EXIT. ** 4097C ***************** 4098C 4099 9000 CONTINUE 4100C 4101 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RWL2')THEN 4102 WRITE(ICOUT,999) 4103 CALL DPWRST('XXX','BUG ') 4104 WRITE(ICOUT,9011) 4105 9011 FORMAT('***** AT THE END OF DPRWL2--') 4106 CALL DPWRST('XXX','BUG ') 4107 WRITE(ICOUT,9012)IBUGA3,IERROR,IINDX 4108 9012 FORMAT('IBUGA3,IERROR,IINDX = ',A4,2X,A4,2X,I8) 4109 CALL DPWRST('XXX','BUG ') 4110 IF(IINDX.GE.1 .AND. IINDX.LE.MAXOBV)THEN 4111 WRITE(ICOUT,9014)IROWLB(IINDX)(1:24) 4112 9014 FORMAT('IROWLB(IINDX) = ',A24) 4113 CALL DPWRST('XXX','BUG ') 4114 ENDIF 4115 ENDIF 4116C 4117 RETURN 4118 END 4119 SUBROUTINE DPRWSH(IBUGA3,ISUBRO,IERROR) 4120C 4121C PURPOSE--SHIFT ROW LABELS LEFT (DOWN) OR RIGHT (UP) 4122C A SPECIFIED NUMBER OF ROWS. FOR EXAMPLE, 4123C 4124C LET ROWLABEL = SHIFT LEFT 3 4125C 4126C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 4127C RESTRICTIONS--THE MAXIMUM ROW NUMBER IS MAXOBV. 4128C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 4129C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 4130C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 4131C LANGUAGE--ANSI FORTRAN (1977) 4132C REFERENCES--NONE. 4133C WRITTEN BY--ALAN HECKERT 4134C STATISTICAL ENGINEERING DIVISION 4135C INFORMATION TECHNOLOGY LABORATORY 4136C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 4137C GAITHERSBURG, MD 20899-8980 4138C PHONE--301-975-2899 4139C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 4140C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 4141C LANGUAGE--ANSI FORTRAN (1977) 4142C VERSION NUMBER--2012/8 4143C ORIGINAL VERSION--AUGUST 2012. 4144C 4145C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 4146C 4147 CHARACTER*4 IBUGA3 4148 CHARACTER*4 ISUBRO 4149 CHARACTER*4 IERROR 4150C 4151 CHARACTER*4 IDIR 4152 CHARACTER*4 ISTEPN 4153 CHARACTER*4 ISUBN1 4154 CHARACTER*4 ISUBN2 4155C 4156C-----COMMON---------------------------------------------------------- 4157C 4158 INCLUDE 'DPCOPA.INC' 4159 INCLUDE 'DPCODA.INC' 4160 INCLUDE 'DPCOHK.INC' 4161 INCLUDE 'DPCOP2.INC' 4162C 4163C-----START POINT----------------------------------------------------- 4164C 4165 ISUBN1='DPRW' 4166 ISUBN2='SH ' 4167 IERROR='NO' 4168 IDIR='LEFT' 4169 IF(IHARG(4).EQ.'RIGH')IDIR='RIGH' 4170C 4171 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RWSH')THEN 4172 WRITE(ICOUT,999) 4173 999 FORMAT(1X) 4174 CALL DPWRST('XXX','BUG ') 4175 WRITE(ICOUT,51) 4176 51 FORMAT('***** AT THE BEGINNING OF DPRWSH--') 4177 CALL DPWRST('XXX','BUG ') 4178 WRITE(ICOUT,52)IBUGA3,ISUBRO,IDIR 4179 52 FORMAT('IBUGA3,ISUBRO,IDIR = ',2(A4,2X),A4) 4180 CALL DPWRST('XXX','BUG ') 4181 ENDIF 4182C 4183C ************************************************* 4184C ** STEP 1-- ** 4185C ** DETERMINE SHIFT VALUE ** 4186C ************************************************* 4187C 4188 ISTEPN='1' 4189 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RWSH') 4190 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4191C 4192 NSHIFT=0 4193 IF(IARGT(5).EQ.'NUMB')THEN 4194 NSHIFT=INT(ARG(5)+0.5) 4195 NSHIFT=ABS(NSHIFT) 4196 IF(NSHIFT.LT.1 .OR. NSHIFT.GT.MAXOBV)THEN 4197 WRITE(ICOUT,1001) 4198 CALL DPWRST('XXX','BUG ') 4199 WRITE(ICOUT,1013)MAXOBV 4200 1013 FORMAT(' THE SHIFT VALUE IS LESS THAN ONE OR GREATER ', 4201 1 'THAN ',I8) 4202 CALL DPWRST('XXX','BUG ') 4203 WRITE(ICOUT,1015)NSHIFT 4204 1015 FORMAT(' THE VALUE OF THE SHIFT = ',I8) 4205 CALL DPWRST('XXX','BUG ') 4206 IERROR='YES' 4207 GOTO9000 4208 ENDIF 4209 ELSE 4210 WRITE(ICOUT,1001) 4211 1001 FORMAT('***** ERROR IN ROW LABEL SHIFT--') 4212 CALL DPWRST('XXX','BUG ') 4213 WRITE(ICOUT,1003) 4214 1003 FORMAT(' ARGUMENT 5 (THE SHIFT VALUE) IS NOT A NUMBER.') 4215 CALL DPWRST('XXX','BUG ') 4216 WRITE(ICOUT,1005)IHARG(5),IHARG2(5) 4217 1005 FORMAT(' THE VALUE OF THE ARGUMENT = ',2A4) 4218 CALL DPWRST('XXX','BUG ') 4219 IERROR='YES' 4220 GOTO9000 4221 ENDIF 4222C 4223C ************************************************* 4224C ** STEP 2-- ** 4225C ** NOW SHIFT THE ROW LABELS. ** 4226C ************************************************* 4227C 4228 ISTEPN='2' 4229 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RWSH') 4230 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4231C 4232 IF(IDIR.EQ.'LEFT')THEN 4233 ISTRT=NSHIFT+1 4234 ISTOP=MAXOBV 4235 DO2010I=ISTRT,ISTOP 4236 IROWLB(I-NSHIFT)=IROWLB(I) 4237 2010 CONTINUE 4238 ITEMP=MAXOBV-NSHIFT+1 4239 DO2020I=ITEMP,MAXOBV 4240 IROWLB(I)='BLAN' 4241 2020 CONTINUE 4242 ELSE 4243 ISTRT=1 4244 ISTOP=MAXOBV-NSHIFT 4245 DO2110I=ISTOP,ISTRT,-1 4246 IROWLB(I+NSHIFT)=IROWLB(I) 4247 2110 CONTINUE 4248 DO2120I=1,NSHIFT 4249 IROWLB(I)='BLAN' 4250 2120 CONTINUE 4251 ENDIF 4252C 4253C ****************************** 4254C ** STEP 3-- ** 4255C ** WRITE OUT A FEW LINES ** 4256C ** OF SUMMARY INFORMATION ** 4257C ** ABOUT THE CODING. ** 4258C ****************************** 4259C 4260 IF(IFEEDB.EQ.'ON')THEN 4261 WRITE(ICOUT,999) 4262 CALL DPWRST('XXX','BUG ') 4263 IF(IDIR.EQ.'LEFT')THEN 4264 WRITE(ICOUT,2811)NSHIFT 4265 2811 FORMAT('THE ROW LABELS HAVE BEEN SHIFTED ',I8,' ROWS LEFT.') 4266 CALL DPWRST('XXX','BUG ') 4267 ELSE 4268 WRITE(ICOUT,2821)NSHIFT 4269 2821 FORMAT('THE ROW LABELS HAVE BEEN SHIFTED ',I8,' ROWS RIGHT.') 4270 CALL DPWRST('XXX','BUG ') 4271 ENDIF 4272 ENDIF 4273C 4274C ***************** 4275C ** STEP 90-- ** 4276C ** EXIT. ** 4277C ***************** 4278C 4279 9000 CONTINUE 4280C 4281 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RWSH')THEN 4282 WRITE(ICOUT,999) 4283 CALL DPWRST('XXX','BUG ') 4284 WRITE(ICOUT,9011) 4285 9011 FORMAT('***** AT THE END OF DPRWSH--') 4286 CALL DPWRST('XXX','BUG ') 4287 WRITE(ICOUT,9012)IBUGA3,IERROR,NSHIFT 4288 9012 FORMAT('IBUGA3,IERROR,NSHIFT = ',A4,2X,A4,2X,I8) 4289 CALL DPWRST('XXX','BUG ') 4290 ENDIF 4291C 4292 RETURN 4293 END 4294 SUBROUTINE DPSACO(IANSLC,IWIDTH,IHARG,IARGT,IARG,NUMARG, 4295 1 IANSSV,IREPMX,IPOINT,ISACNC, 4296 1 IBUGS2,ISUBRO,IFOUND,IERROR) 4297C 4298C PURPOSE--SAVE (FOR FUTURE USE BY THE REEXECUTE COMMAND) 4299C SELECTED COMMANDS IN THE (RECENT) COMMAND LIST. 4300C THE RECENT COMMAND LIST CONSISTS OF THE 4301C LAST IREPMX (= 50) COMMANDS. 4302C LAST MAXLIS (==> 200) COMMANDS. APRIL 1993 4303C 4304C WRITTEN BY--JAMES J. FILLIBEN 4305C STATISTICAL ENGINEERING DIVISION 4306C INFORMATION TECHNOLOGY LABORATORY 4307C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 4308C GAITHERSBURG, MD 20899-8980 4309C PHONE--301-975-2899 4310C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 4311C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 4312C LANGUAGE--ANSI FORTRAN (1977) 4313C VERSION NUMBER--86/1 4314C ORIGINAL VERSION--APRIL 1986. 4315C UPDATED --APRIL 1993. SOFT-CODE DIMEN. FOR IANSSV() 4316C 4317C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 4318C 4319CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1993 4320 INCLUDE 'DPCOPA.INC' 4321C 4322 CHARACTER*4 IANSLC(*) 4323 CHARACTER*4 IHARG(*) 4324 CHARACTER*4 IARGT(*) 4325 CHARACTER*1 IANSSV(MAXLIS,MAXCIS) 4326CCCCC CHARACTER*80 ISACNC 4327 CHARACTER (LEN=*) :: ISACNC 4328C 4329 CHARACTER*4 IBUGS2 4330 CHARACTER*4 ISUBRO 4331 CHARACTER*4 IERROR 4332 CHARACTER*4 IFOUND 4333C 4334CCCCC CHARACTER*80 IFILE 4335 CHARACTER (LEN=MAXFNC) :: IFILE 4336 CHARACTER*12 ISTAT 4337 CHARACTER*12 IFORM 4338 CHARACTER*12 IACCES 4339 CHARACTER*12 IPROT 4340 CHARACTER*12 ICURST 4341 CHARACTER*4 IENDFI 4342 CHARACTER*4 IREWIN 4343 CHARACTER*4 ISUBN0 4344 CHARACTER*4 IERRFI 4345C 4346 CHARACTER*1 IC1 4347 CHARACTER*4 IC4 4348CCCCC CHARACTER*80 ISTRIN 4349CCCCC CHARACTER*80 ISTRI2 4350 CHARACTER (LEN=MAXSTR) :: ISTRIN 4351 CHARACTER (LEN=MAXSTR) :: ISTRI2 4352C 4353 CHARACTER*4 ISTEPN 4354 CHARACTER*4 ISUBN1 4355 CHARACTER*4 ISUBN2 4356C 4357 DIMENSION IARG(*) 4358CCCCC THE FOLLOWING 2 LINES WERE CHANGED APRIL 1993 4359CCCCC DIMENSION IANSSV(50,80) 4360CCCCC DIMENSION ITAB(50) 4361 DIMENSION ITAB(MAXLIS) 4362C 4363C-----COMMON---------------------------------------------------------- 4364C 4365 INCLUDE 'DPCOF2.INC' 4366 INCLUDE 'DPCOP2.INC' 4367C 4368C-----START POINT----------------------------------------------------- 4369C 4370 ISUBN1='DPSA' 4371 ISUBN2='CO ' 4372 IFOUND='NO' 4373 IERROR='NO' 4374C 4375 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SACO')THEN 4376 WRITE(ICOUT,999) 4377 999 FORMAT(1X) 4378 CALL DPWRST('XXX','BUG ') 4379 WRITE(ICOUT,51) 4380 51 FORMAT('AT THE BEGINNING OF DPSACO--') 4381 CALL DPWRST('XXX','BUG ') 4382 WRITE(ICOUT,52)IBUGS2,ISUBRO,IFOUND,IERROR,IWIDTH,NUMARG 4383 52 FORMAT('IBUGS2,ISUBRO,IFOUND,IERROR,IWIDTH,NUMARG = ', 4384 1 4(A4,2X),2I8) 4385 CALL DPWRST('XXX','BUG ') 4386 IF(IWIDTH.GE.1)THEN 4387 WRITE(ICOUT,54)(IANSLC(I),I=1,MIN(80,IWIDTH)) 4388 54 FORMAT('(IANSLC(I),I=1,IWIDTH) = ',80A1) 4389 CALL DPWRST('XXX','BUG ') 4390 ENDIF 4391 IF(NUMARG.GE.1)THEN 4392 DO56I=1,NUMARG 4393 WRITE(ICOUT,57)I,IHARG(I) 4394 57 FORMAT('I,IHARG(I) = ',I8,2X,A4) 4395 CALL DPWRST('XXX','BUG ') 4396 56 CONTINUE 4397 ENDIF 4398CCCCC THE FOLLOWING 2 LINES WERE CHANGED APRIL 1993 4399CCCCC WRITE(ICOUT,61)IREPMX,IPOINT 4400CCC61 FORMAT('IREPMX,IPOINT = ',I8,2X,I8) 4401CCCCC CALL DPWRST('XXX','BUG ') 4402 WRITE(ICOUT,61)MAXLIS,IPOINT,ISACNU 4403 61 FORMAT('MAXLIS,IPOINT,ISACNU = ',3I8) 4404 CALL DPWRST('XXX','BUG ') 4405CCCCC THE FOLLOWING LINE WAS CHANGED APRIL 1993 4406CCCCC DO62J=1,IREPMX 4407 DO62J=1,MAXLIS 4408 WRITE(ICOUT,63)J,(IANSSV(J,I),I=1,80) 4409 63 FORMAT('J,(IANSSV(J,I),I=1,80) = ',I8,2X,80A1) 4410 CALL DPWRST('XXX','BUG ') 4411 62 CONTINUE 4412 WRITE(ICOUT,72)ISACNA 4413 72 FORMAT('ISACNA = ',A80) 4414 CALL DPWRST('XXX','BUG ') 4415 WRITE(ICOUT,73)ISACST,ISACFO,ISACAC,ISACFO,ISACCS 4416 73 FORMAT('ISACST,ISACFO,ISACAC,ISACFO,ISACCS = ',4(A12,2X),A12) 4417 CALL DPWRST('XXX','BUG ') 4418 WRITE(ICOUT,81)ISACNC 4419 81 FORMAT('ISACNC = ',A80) 4420 CALL DPWRST('XXX','BUG ') 4421 ENDIF 4422C 4423 IFOUND='YES' 4424C 4425C ****************************************************** 4426C ** STEP 11-- ** 4427C ** DETERMINE IF HAVE AN EXPLICIT FILE REFERENCE ** 4428C ** WHERE THE COMMANDS WILL BE SAVED, OR WILL THEY ** 4429C ** BE SAVED IN THE DEFAULT FILE (DPSACF.TEX)? ** 4430C ****************************************************** 4431C 4432 ISTEPN='11' 4433 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SACO') 4434 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4435C 4436 IFILWD=(-999) 4437C 4438 DO1100I=1,MAXSTR 4439 IC4=IANSLC(I) 4440 ISTRIN(I:I)=IC4(1:1) 4441 1100 CONTINUE 4442C 4443 IWORD=1 4444 ISTART=1 4445 ISTOP=MAXSTR 4446 CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD, 4447 1 ICOL1,ICOL2,ISTRI2,NCSTR2, 4448 1 IBUGS2,ISUBRO,IERROR) 4449C 4450 IF(NUMARG.GT.0)THEN 4451 IWORD=2 4452 ISTART=1 4453 ISTOP=MAXSTR 4454 CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD, 4455 1 ICOL1,ICOL2,ISTRI2,NCSTR2, 4456 1 IBUGS2,ISUBRO,IERROR) 4457 IF(NCSTR2.GT.0)THEN 4458 DO1121I=1,NCSTR2 4459 IF(ISTRI2(I:I).EQ.'.')THEN 4460 IFILWD=2 4461 GOTO1190 4462 ENDIF 4463 1121 CONTINUE 4464 ENDIF 4465 ENDIF 4466C 4467 IF(NUMARG.GT.1)THEN 4468 IWORD=3 4469 ISTART=1 4470 ISTOP=MAXSTR 4471 CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD, 4472 1 ICOL1,ICOL2,ISTRI2,NCSTR2, 4473 1 IBUGS2,ISUBRO,IERROR) 4474 IF(NCSTR2.GT.0)THEN 4475 DO1131I=1,NCSTR2 4476 IF(ISTRI2(I:I).EQ.'.')THEN 4477 IFILWD=3 4478 GOTO1190 4479 ENDIF 4480 1131 CONTINUE 4481 ENDIF 4482 ENDIF 4483C 4484 1190 CONTINUE 4485 ISTAM1=0 4486 IF(IFILWD.EQ.2.OR.IFILWD.EQ.3)ISTAM1=1 4487C 4488C ******************************* 4489C ** STEP 12-- ** 4490C ** COPY OVER FILE VARIABLES ** 4491C ******************************* 4492C 4493 ISTEPN='12' 4494 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SACO') 4495 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4496C 4497 ISACNC=ISACNA 4498 IF(IFILWD.EQ.2.OR.IFILWD.EQ.3)ISACNC=ISTRI2 4499C 4500 IOUNIT=ISACNU 4501 IFILE=ISACNA 4502 IF(IFILWD.EQ.2.OR.IFILWD.EQ.3)IFILE=ISTRI2(1:256) 4503 ISTAT=ISACST 4504 IFORM=ISACFO 4505 IACCES=ISACAC 4506 IPROT=ISACPR 4507 ICURST=ISACCS 4508C 4509 ISUBN0='SACO' 4510 IERRFI='NO' 4511C 4512 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SACO')THEN 4513 WRITE(ICOUT,1294)IFILE 4514 1294 FORMAT('IFILE = ',A80) 4515 CALL DPWRST('XXX','BUG ') 4516 WRITE(ICOUT,1295)ISTAT,IFORM,IACCES,IPROT,ICURST 4517 1295 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',4(A12,2X),A12) 4518 CALL DPWRST('XXX','BUG ') 4519 WRITE(ICOUT,1296)ISUBN0,IERRFI,IOUNIT 4520 1296 FORMAT('ISUBN0,IERRFI,IOUNIT = ',2(A4,2X),I8) 4521 CALL DPWRST('XXX','BUG ') 4522 ENDIF 4523C 4524C *********************************************************** 4525C ** STEP 13-- ** 4526C ** CHECK TO SEE IF THE SAVE-CONCLUSIONS FILE MAY EXIST ** 4527C *********************************************************** 4528C 4529 ISTEPN='13' 4530 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SACO') 4531 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4532C 4533 IF(ISTAT.EQ.'NONE')THEN 4534 IERROR='YES' 4535 WRITE(ICOUT,999) 4536 CALL DPWRST('XXX','BUG ') 4537 WRITE(ICOUT,1311) 4538 1311 FORMAT('***** IMPLEMENTATION ERROR IN DPSACO--') 4539 CALL DPWRST('XXX','BUG ') 4540 WRITE(ICOUT,1312) 4541 1312 FORMAT(' THE DESIRED SAVING OF COMMANDS CANNOT BE') 4542 CALL DPWRST('XXX','BUG ') 4543 WRITE(ICOUT,1314) 4544 1314 FORMAT(' OUT BECAUSE THE INTERNAL VARIABLE ISACST ') 4545 CALL DPWRST('XXX','BUG ') 4546 WRITE(ICOUT,1315) 4547 1315 FORMAT(' WHICH ALLOWS SUCH COMMAND-SAVINGING') 4548 CALL DPWRST('XXX','BUG ') 4549 WRITE(ICOUT,1316) 4550 1316 FORMAT(' HAS BEEN SET TO NONE.') 4551 CALL DPWRST('XXX','BUG ') 4552 WRITE(ICOUT,1317)ISTAT,ISACST 4553 1317 FORMAT('ISTAT,ISACST = ',A12,2X,A12) 4554 CALL DPWRST('XXX','BUG ') 4555 GOTO9000 4556 ENDIF 4557C 4558C ********************************************************* 4559C ** STEP 21-- ** 4560C ** FROM THE RECALL-LIST OF THE PREVIOUS 30 COMMANDS, ** 4561C ** STRIP OUT THE DESIRED COMMAND LINE NUMBERS ** 4562C ** THE LIST THAT THE ANALYST HAS SPECIFIED ** 4563C ** SHOULD BE IN THE ORDER THAT THE ANALYST ** 4564C ** WANTS THE COMMANDS EXECUTED ** 4565C ** (USUALLY--BUT NOT NECESSARILY--IT IS FROM LARGEST ** 4566C ** (MOST DISTANT) TO SMALLEST (MOST RECENT)) ** 4567C ********************************************************* 4568C 4569CCCCC THE FOLLOWING LINE WAS CHANGED APRIL 1993 4570CCCCC MAXTAB=IREPMX 4571 MAXTAB=MAXLIS 4572 MININT=1 4573CCCCC THE FOLLOWING LINE WAS CHANGED APRIL 1993 4574CCCCC MAXINT=IREPMX 4575 MAXINT=MAXLIS 4576 ISTART=ISTAM1+1 4577 ISTOP=NUMARG 4578 IF(ISTART.GT.ISTOP)THEN 4579 I=1 4580 ITAB(I)=1 4581 NTAB=I 4582 ELSE 4583 CALL DPEXIN(IHARG,IARGT,IARG,NUMARG,ISTART,ISTOP, 4584 1 MININT,MAXINT, 4585 1 ITAB,NTAB,MAXTAB, 4586 1 IBUGS2,ISUBRO,IERROR) 4587 ENDIF 4588C 4589C ************************** 4590C ** STEP 31-- ** 4591C ** OPEN THE FILE ** 4592C ************************** 4593C 4594 ISTEPN='31' 4595 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SACO') 4596 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4597C 4598 IREWIN='ON' 4599 CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 4600 1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 4601 IF(IERRFI.EQ.'YES')GOTO9000 4602C 4603C ****************************************************** 4604C ** STEP 41-- ** 4605C ** PRINT OUT THE SPECIFIED COMMANDS ** 4606C ** (BOTH TO SCREEN AND TO FILE) ** 4607C ** IN ORDER OF EXECUTION ** 4608C ****************************************************** 4609C 4610 ISTEPN='41' 4611 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SACO') 4612 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4613C 4614 IF(IFEEDB.EQ.'ON')THEN 4615 WRITE(ICOUT,999) 4616 CALL DPWRST('XXX','BUG ') 4617 WRITE(ICOUT,4101) 4618 4101 FORMAT('THE SAVED COMMAND LINES--') 4619 CALL DPWRST('XXX','BUG ') 4620 WRITE(ICOUT,999) 4621 CALL DPWRST('XXX','BUG ') 4622 ENDIF 4623C 4624 NMAX=80 4625 DO4110I=1,NTAB 4626 I2=ITAB(I) 4627 I3=IPOINT-I2 4628CCCCC THE FOLLOWING LINE WAS CHANGED APRIL 1993 4629CCCCC IF(I3.LE.0)I3=I3+IREPMX 4630 IF(I3.LE.0)I3=I3+MAXLIS 4631 DO4120J=1,MAXSTR 4632 IC1=IANSSV(I3,J) 4633 ISTRIN(J:J)=IC1 4634 4120 CONTINUE 4635 WRITE(IOUNIT,4125)(ISTRIN(J:J),J=1,80) 4636 4125 FORMAT(80A1) 4637C 4638 IF(IFEEDB.EQ.'ON')THEN 4639 CALL DPDB80(ISTRIN,J2MAX,NMAX,IBUGS2,ISUBRO,IERROR) 4640 WRITE(ICOUT,4126)I2,(ISTRIN(J:J),J=1,MIN(80,J2MAX)) 4641 4126 FORMAT(4X,I2,'--',80A1) 4642 CALL DPWRST('XXX','BUG ') 4643 ENDIF 4644C 4645 4110 CONTINUE 4646C 4647C ************************** 4648C ** STEP 51-- ** 4649C ** CLOSE THE FILE ** 4650C ************************** 4651C 4652 ISTEPN='51' 4653 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SACO') 4654 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4655C 4656 IENDFI='OFF' 4657 IREWIN='OFF' 4658 CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 4659 1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 4660C 4661C ***************** 4662C ** STEP 90-- ** 4663C ** EXIT. ** 4664C ***************** 4665C 4666 9000 CONTINUE 4667 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SACO')THEN 4668 WRITE(ICOUT,999) 4669 CALL DPWRST('XXX','BUG ') 4670 WRITE(ICOUT,9011) 4671 9011 FORMAT('AT THE END OF DPSACO--') 4672 CALL DPWRST('XXX','BUG ') 4673 WRITE(ICOUT,9012)IBUGS2,ISUBRO,IFOUND,IERROR 4674 9012 FORMAT('IBUGS2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4,2X,A4) 4675 CALL DPWRST('XXX','BUG ') 4676 WRITE(ICOUT,9021)MAXLIS,IPOINT,IOUNIT 4677 9021 FORMAT('MAXLIS,IPOINT,IOUNIT = ',3I8) 4678 CALL DPWRST('XXX','BUG ') 4679 DO9022J=1,IREPMX 4680 WRITE(ICOUT,9023)J,(IANSSV(J,I),I=1,80) 4681 9023 FORMAT('J,(IANSSV(J,I),I=1,80) = ',I8,2X,80A1) 4682 CALL DPWRST('XXX','BUG ') 4683 9022 CONTINUE 4684 WRITE(ICOUT,9042)IFILE(1:80) 4685 9042 FORMAT('IFILE = ',A80) 4686 CALL DPWRST('XXX','BUG ') 4687 WRITE(ICOUT,9043)ISTAT,IFORM,IACCES,IPROT,ICURST 4688 9043 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',4(A12,2X),A12) 4689 CALL DPWRST('XXX','BUG ') 4690 WRITE(ICOUT,9048)IENDFI,IREWIN,ISUBN0,IERRFI 4691 9048 FORMAT('IENDFI,IREWIN,ISUBN0,IERRFI = ',3(A4,2X),A4) 4692 CALL DPWRST('XXX','BUG ') 4693 WRITE(ICOUT,9061)IFILWD,ISTAM1,ISTART,ISTOP 4694 9061 FORMAT('IFILWD,ISTAM1,ISTART,ISTOP = ',4I8) 4695 CALL DPWRST('XXX','BUG ') 4696 WRITE(ICOUT,9063)MININT,MAXINT,NTAB,MAXTAB 4697 9063 FORMAT('MININT,MAXINT,NTAB,MAXTAB = ',4I8) 4698 CALL DPWRST('XXX','BUG ') 4699 IF(NTAB.GT.0)THEN 4700 DO9072I=1,NTAB 4701 WRITE(ICOUT,9073)I,ITAB(I) 4702 9073 FORMAT('I,ITAB(I) = ',2I8) 4703 CALL DPWRST('XXX','BUG ') 4704 9072 CONTINUE 4705 ENDIF 4706 WRITE(ICOUT,9081)ISACNC(1:80) 4707 9081 FORMAT('ISACNC = ',A80) 4708 CALL DPWRST('XXX','BUG ') 4709 ENDIF 4710C 4711 RETURN 4712 END 4713 SUBROUTINE DPSAPC(IBUGS2,ISUBRO,IFOUND,IERROR) 4714C 4715C PURPOSE--GUI SAVE PLOT CONTROL (= LIST OUT PLOT CONTROL 4716C SETTINGS TO SCREEN SO TCL/TK CAN READ THEM. 4717C WRITTEN BY--JAMES J. FILLIBEN 4718C STATISTICAL ENGINEERING DIVISION 4719C INFORMATION TECHNOLOGY LABORATORY 4720C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 4721C GAITHERSBURG, MD 20899-8980 4722C PHONE--301-975-2855 4723C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 4724C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 4725C LANGUAGE--ANSI FORTRAN (1977) 4726C VERSION NUMBER--97/11 4727C ORIGINAL VERSION--NOVEMBER 1997. 4728C UPDATED --JULY 2009. MODIFY SOME FORMATS FOR 4729C GUI 4730C 4731C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 4732C 4733 CHARACTER*4 IBUGS2 4734 CHARACTER*4 ISUBRO 4735 CHARACTER*4 IFOUND 4736 CHARACTER*4 IERROR 4737C 4738 CHARACTER*4 ISTEPN 4739 CHARACTER*4 ISUBN1 4740 CHARACTER*4 ISUBN2 4741C 4742 CHARACTER*4 ITEMP 4743 CHARACTER*4 ITITFL 4744 CHARACTER*4 ILABFL 4745 CHARACTER*4 ILEGFL 4746 CHARACTER*4 ILINFL 4747 CHARACTER*4 ICHAFL 4748 CHARACTER*4 ISPIFL 4749 CHARACTER*4 IBARFL 4750 CHARACTER*4 IBACFL 4751 CHARACTER*4 ILIMFL 4752C 4753 CHARACTER*4 ITMP1 4754 CHARACTER*4 ITMP2 4755 CHARACTER*4 ITMP3 4756 CHARACTER*4 ITMP4 4757C 4758 CHARACTER*24 ITEMPH(10) 4759C 4760 REAL TEMP(100) 4761C 4762C-----COMMON---------------------------------------------------------- 4763C 4764 INCLUDE 'DPCOPA.INC' 4765 INCLUDE 'DPCOPC.INC' 4766 INCLUDE 'DPCOHK.INC' 4767 INCLUDE 'DPCOP2.INC' 4768C 4769C-----START POINT----------------------------------------------------- 4770C 4771 ISUBN1='DPSA' 4772 ISUBN2='PC ' 4773 IFOUND='YES' 4774 IERROR='NO' 4775C 4776 IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SAPC')GOTO90 4777 WRITE(ICOUT,999) 4778 999 FORMAT(1X) 4779 CALL DPWRST('XXX','BUG ') 4780 WRITE(ICOUT,51) 4781 51 FORMAT('***** AT THE BEGINNING OF DPSAPC--') 4782 CALL DPWRST('XXX','BUG ') 4783 WRITE(ICOUT,53)IBUGS2,ISUBRO,IERROR 4784 53 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) 4785 CALL DPWRST('XXX','BUG ') 4786 WRITE(ICOUT,54)IWIDTH 4787 54 FORMAT('IWIDTH = ',I8) 4788 CALL DPWRST('XXX','BUG ') 4789 IF(IWIDTH.GE.1)WRITE(ICOUT,55)(IANSLC(I),I=1,IWIDTH) 4790 55 FORMAT('(IANSLC(I),I=1,IWIDTH) = ',80A1) 4791 IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') 4792 90 CONTINUE 4793C 4794 ISTART=1 4795 ISTOP=100 4796 ITITFL='OFF' 4797 ILABFL='OFF' 4798 ILEGFL='OFF' 4799 ILINFL='OFF' 4800 ICHAFL='OFF' 4801 ISPIFL='OFF' 4802 IBARFL='OFF' 4803 IBACFL='OFF' 4804 ILIMFL='OFF' 4805C 4806 IJUNK1=NUMARG 4807 IJUNK2=NUMARG-1 4808 IJUNK3=NUMARG-2 4809 IF(NUMARG.GE.2.AND.IARGT(IJUNK1).EQ.'NUMB'.AND. 4810 1 IARGT(IJUNK2).EQ.'NUMB')THEN 4811 ISTART=IARG(IJUNK2) 4812 ISTOP=IARG(IJUNK1) 4813 IF(ISTART.LT.1)ISTART=1 4814 IF(ISTOP.GT.100)ISTOP=100 4815 IF(ISTART.GT.ISTOP)THEN 4816 IJUNK4=ISTOP 4817 ISTOP=ISTART 4818 ISTART=IJUNK4 4819 ENDIF 4820 ELSEIF(NUMARG.GE.2.AND.IARGT(IJUNK1).EQ.'NUMB'.AND. 4821 1 IARGT(IJUNK2).NE.'NUMB')THEN 4822 ISTART=1 4823 ISTOP=IARG(IJUNK1) 4824 IF(ISTOP.GT.100)ISTOP=100 4825 IJUNK3=IJUNK2 4826 ELSE 4827 IJUNK3=IJUNK1 4828 ENDIF 4829C 4830 IF(IJUNK3.GE.1)THEN 4831 ITEMP=IHARG(IJUNK3) 4832 IF(ITEMP.EQ.'TITL')ITITFL='ON' 4833 IF(ITEMP.EQ.'LABE')ILABFL='ON' 4834 IF(ITEMP.EQ.'LEGE')ILEGFL='ON' 4835 IF(ITEMP.EQ.'LINE')ILINFL='ON' 4836 IF(ITEMP.EQ.'CHAR')ICHAFL='ON' 4837 IF(ITEMP.EQ.'SPIK')ISPIFL='ON' 4838 IF(ITEMP.EQ.'BAR ')IBARFL='ON' 4839 IF(ITEMP.EQ.'BACK')IBACFL='ON' 4840 IF(ITEMP.EQ.'LIMI')ILIMFL='ON' 4841 IF(ITEMP.EQ.'ALL ')THEN 4842 ITITFL='ON' 4843 ILABFL='ON' 4844 ILEGFL='ON' 4845 ILINFL='ON' 4846 ICHAFL='ON' 4847 ISPIFL='ON' 4848 IBARFL='ON' 4849 IBACFL='ON' 4850 ILIMFL='ON' 4851 ENDIF 4852 ENDIF 4853C 4854 LINC=5 4855C 4856C ****************************************************** 4857C ** STEP 41-- 4858C ** WRITE OUT TO THE SAVE FILE; 4859C ****************************************************** 4860C 4861 ISTEPN='41' 4862 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAPC') 4863 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4864C 4865C -----WRITE OUT COMMON FOR PLOT CONTROL----- 4866C 4867 IF(IBACFL.EQ.'OFF')GOTO199 4868 WRITE(ICOUT,101)IBACCO 4869 101 FORMAT('BACKGROUND COLOR = ',A4) 4870 CALL DPWRST('XXX','BUG ') 4871 199 CONTINUE 4872C 4873 IF(ITITFL.EQ.'OFF')GOTO299 4874 WRITE(ICOUT,201) 4875 201 FORMAT('TITLE ATTRIBUTES') 4876 CALL DPWRST('XXX','BUG ') 4877C 4878 WRITE(ICOUT,202)(ITITTE(I)(1:1),I=1,MIN(NCTITL,130)) 4879 202 FORMAT(' TITLE = ',130A1) 4880 CALL DPWRST('XXX','BUG ') 4881 WRITE(ICOUT,203)ITITFO 4882 203 FORMAT(' TITLE FONT = ',A4) 4883 CALL DPWRST('XXX','BUG ') 4884 WRITE(ICOUT,204)ITITCA 4885 204 FORMAT(' TITLE CASE = ',A4) 4886 CALL DPWRST('XXX','BUG ') 4887 WRITE(ICOUT,205)ITITFI 4888 205 FORMAT(' TITLE FILL = ',A4) 4889 CALL DPWRST('XXX','BUG ') 4890 WRITE(ICOUT,206)ITITCO 4891 206 FORMAT(' TITLE COLOR = ',A4) 4892 CALL DPWRST('XXX','BUG ') 4893 WRITE(ICOUT,207)PTITHE 4894 207 FORMAT(' TITLE SIZE = ',E12.5) 4895 CALL DPWRST('XXX','BUG ') 4896 WRITE(ICOUT,208)PTITTH 4897 208 FORMAT(' TITLE THICKNESS = ',E12.5) 4898 CALL DPWRST('XXX','BUG ') 4899 WRITE(ICOUT,209)PTITDS 4900 209 FORMAT(' TITLE DISPLACEMENT = ',E12.5) 4901 CALL DPWRST('XXX','BUG ') 4902 299 CONTINUE 4903C 4904 IF(ILABFL.EQ.'OFF')GOTO399 4905 WRITE(ICOUT,301) 4906 301 FORMAT('AXIS LABEL ATTRIBUTES') 4907 CALL DPWRST('XXX','BUG ') 4908C 4909 WRITE(ICOUT,311)(IX1LTE(I)(1:1),I=1,NCX1LA) 4910 311 FORMAT(' X1LABEL = ',130A1) 4911 CALL DPWRST('XXX','BUG ') 4912 WRITE(ICOUT,312)(IX2LTE(I)(1:1),I=1,NCX2LA) 4913 312 FORMAT(' X2LABEL = ',130A1) 4914 CALL DPWRST('XXX','BUG ') 4915 WRITE(ICOUT,313)(IX3LTE(I)(1:1),I=1,NCX3LA) 4916 313 FORMAT(' X3LABEL = ',130A1) 4917 CALL DPWRST('XXX','BUG ') 4918 WRITE(ICOUT,314)(IY1LTE(I)(1:1),I=1,NCY1LA) 4919 314 FORMAT(' Y1LABEL = ',130A1) 4920 CALL DPWRST('XXX','BUG ') 4921 WRITE(ICOUT,315)(IY2LTE(I)(1:1),I=1,NCY2LA) 4922 315 FORMAT(' Y2LABEL = ',130A1) 4923 CALL DPWRST('XXX','BUG ') 4924C 4925 WRITE(ICOUT,321)IX1LFO 4926 321 FORMAT(' X1LABEL FONT = ',A4) 4927 CALL DPWRST('XXX','BUG ') 4928 WRITE(ICOUT,322)IX1LCA 4929 322 FORMAT(' X1LABEL CASE = ',A4) 4930 CALL DPWRST('XXX','BUG ') 4931 WRITE(ICOUT,323)IX1LFI 4932 323 FORMAT(' X1LABEL FILL = ',A4) 4933 CALL DPWRST('XXX','BUG ') 4934 WRITE(ICOUT,324)IX1LCO 4935 324 FORMAT(' X1LABEL COLOR = ',A4) 4936 CALL DPWRST('XXX','BUG ') 4937 WRITE(ICOUT,325)PX1LDS 4938 325 FORMAT(' X1LABEL DISPLACEMENT = ',E12.5) 4939 CALL DPWRST('XXX','BUG ') 4940 WRITE(ICOUT,326)PX1LHE 4941 326 FORMAT(' X1LABEL SIZE = ',E12.5) 4942 CALL DPWRST('XXX','BUG ') 4943 WRITE(ICOUT,327)PX1LTH 4944 327 FORMAT(' X1LABEL THICKNESS = ',E12.5) 4945 CALL DPWRST('XXX','BUG ') 4946C 4947 WRITE(ICOUT,331)IX2LFO 4948 331 FORMAT(' X2LABEL FONT = ',A4) 4949 CALL DPWRST('XXX','BUG ') 4950 WRITE(ICOUT,332)IX2LCA 4951 332 FORMAT(' X2LABEL CASE = ',A4) 4952 CALL DPWRST('XXX','BUG ') 4953 WRITE(ICOUT,333)IX2LFI 4954 333 FORMAT(' X2LABEL FILL = ',A4) 4955 CALL DPWRST('XXX','BUG ') 4956 WRITE(ICOUT,334)IX2LCO 4957 334 FORMAT(' X2LABEL COLOR = ',A4) 4958 CALL DPWRST('XXX','BUG ') 4959 WRITE(ICOUT,335)PX2LDS 4960 335 FORMAT(' X2LABEL DISPLACEMENT = ',E12.5) 4961 CALL DPWRST('XXX','BUG ') 4962 WRITE(ICOUT,336)PX2LHE 4963 336 FORMAT(' X2LABEL SIZE = ',E12.5) 4964 CALL DPWRST('XXX','BUG ') 4965 WRITE(ICOUT,337)PX2LTH 4966 337 FORMAT(' X2LABEL THICKNESS = ',E12.5) 4967 CALL DPWRST('XXX','BUG ') 4968C 4969 WRITE(ICOUT,341)IX3LFO 4970 341 FORMAT(' X3LABEL FONT = ',A4) 4971 CALL DPWRST('XXX','BUG ') 4972 WRITE(ICOUT,342)IX3LCA 4973 342 FORMAT(' X3LABEL CASE = ',A4) 4974 CALL DPWRST('XXX','BUG ') 4975 WRITE(ICOUT,343)IX3LFI 4976 343 FORMAT(' X3LABEL FILL = ',A4) 4977 CALL DPWRST('XXX','BUG ') 4978 WRITE(ICOUT,344)IX3LCO 4979 344 FORMAT(' X3LABEL COLOR = ',A4) 4980 CALL DPWRST('XXX','BUG ') 4981 WRITE(ICOUT,345)PX3LDS 4982 345 FORMAT(' X3LABEL DISPLACEMENT = ',E12.5) 4983 CALL DPWRST('XXX','BUG ') 4984 WRITE(ICOUT,346)PX3LHE 4985 346 FORMAT(' X3LABEL SIZE = ',E12.5) 4986 CALL DPWRST('XXX','BUG ') 4987 WRITE(ICOUT,347)PX3LTH 4988 347 FORMAT(' X3LABEL THICKNESS = ',E12.5) 4989 CALL DPWRST('XXX','BUG ') 4990C 4991 WRITE(ICOUT,351)IY1LFO 4992 351 FORMAT(' Y1LABEL FONT = ',A4) 4993 CALL DPWRST('XXX','BUG ') 4994 WRITE(ICOUT,352)IY1LCA 4995 352 FORMAT(' Y1LABEL CASE = ',A4) 4996 CALL DPWRST('XXX','BUG ') 4997 WRITE(ICOUT,353)IY1LFI 4998 353 FORMAT(' Y1LABEL FILL = ',A4) 4999 CALL DPWRST('XXX','BUG ') 5000 WRITE(ICOUT,354)IY1LCO 5001 354 FORMAT(' Y1LABEL COLOR = ',A4) 5002 CALL DPWRST('XXX','BUG ') 5003 WRITE(ICOUT,355)PY1LDS 5004 355 FORMAT(' Y1LABEL DISPLACEMENT = ',E12.5) 5005 CALL DPWRST('XXX','BUG ') 5006 WRITE(ICOUT,356)PY1LHE 5007 356 FORMAT(' Y1LABEL SIZE = ',E12.5) 5008 CALL DPWRST('XXX','BUG ') 5009 WRITE(ICOUT,357)PY1LTH 5010 357 FORMAT(' Y1LABEL THICKNESS = ',E12.5) 5011 CALL DPWRST('XXX','BUG ') 5012C 5013 WRITE(ICOUT,361)IY2LFO 5014 361 FORMAT(' Y2LABEL FONT = ',A4) 5015 CALL DPWRST('XXX','BUG ') 5016 WRITE(ICOUT,362)IY2LCA 5017 362 FORMAT(' Y2LABEL CASE = ',A4) 5018 CALL DPWRST('XXX','BUG ') 5019 WRITE(ICOUT,363)IY2LFI 5020 363 FORMAT(' Y2LABEL FILL = ',A4) 5021 CALL DPWRST('XXX','BUG ') 5022 WRITE(ICOUT,364)IY2LCO 5023 364 FORMAT(' Y2LABEL COLOR = ',A4) 5024 CALL DPWRST('XXX','BUG ') 5025 WRITE(ICOUT,365)PY2LDS 5026 365 FORMAT(' Y2LABEL DISPLACEMENT = ',E12.5) 5027 CALL DPWRST('XXX','BUG ') 5028 WRITE(ICOUT,366)PY2LHE 5029 366 FORMAT(' Y2LABEL SIZE = ',E12.5) 5030 CALL DPWRST('XXX','BUG ') 5031 WRITE(ICOUT,367)PY2LTH 5032 367 FORMAT(' Y2LABEL THICKNESS = ',E12.5) 5033 CALL DPWRST('XXX','BUG ') 5034 399 CONTINUE 5035C 5036 IF(ILEGFL.EQ.'OFF')GOTO499 5037 WRITE(ICOUT,401) 5038 401 FORMAT('LEGEND ATTRIBUTES') 5039 CALL DPWRST('XXX','BUG ') 5040 WRITE(ICOUT,402)NUMLEG 5041 402 FORMAT(' NUMBER OF CURRENTLY DEFINED LEGENDS = ',I10) 5042 CALL DPWRST('XXX','BUG ') 5043C 5044 DO491LL=1,20 5045 LSTRT=(LL-1)*LINC+1 5046 LSTOP=LL*LINC 5047 IF(LSTRT.GT.NUMLEG)GOTO498 5048 IF(LSTOP.GT.NUMLEG)LSTOP=NUMLEG 5049C 5050 DO490L=LSTRT,LSTOP 5051 ISTRT=ILEGST(L) 5052 ISTP=ILEGSP(L) 5053 IF(ISTP-ISTRT+1.GT.80)ISTP=ISTRT+79 5054 WRITE(ICOUT,411)L,L,(ILEGTE(J)(1:1),J=ISTRT,ISTP) 5055 411 FORMAT(' LEGEND ',2I5,' = ',80A1) 5056 CALL DPWRST('XXX','BUG ') 5057 490 CONTINUE 5058 491 CONTINUE 5059 498 CONTINUE 5060C 5061 DO492LL=1,20 5062 LSTRT=(LL-1)*LINC+1 5063 LSTOP=LL*LINC 5064 IF(LSTRT.GT.ISTOP)GOTO492 5065 IF(LSTRT.LT.ISTART)LSTRT=ISTART 5066 IF(LSTOP.GT.ISTOP)LSTOP=ISTOP 5067C 5068 WRITE(ICOUT,412)LSTRT,LSTOP,(ILEGFO(I),I=LSTRT,LSTOP) 5069 412 FORMAT(' LEGEND FONT ',I5,1X,I5,' = ',10(A4,1X)) 5070 CALL DPWRST('XXX','BUG ') 5071 WRITE(ICOUT,413)LSTRT,LSTOP,(ILEGCA(I),I=LSTRT,LSTOP) 5072 413 FORMAT(' LEGEND CASE ',I5,1X,I5,' = ',10(A4,1X)) 5073 CALL DPWRST('XXX','BUG ') 5074 WRITE(ICOUT,414)LSTRT,LSTOP,(ILEGJU(I),I=LSTRT,LSTOP) 5075 414 FORMAT(' LEGEND JUSTIFICATION ',I5,1X,I5,' = ',10(A4,1X)) 5076 CALL DPWRST('XXX','BUG ') 5077 WRITE(ICOUT,415)LSTRT,LSTOP,(ILEGDI(I),I=LSTRT,LSTOP) 5078 415 FORMAT(' LEGEND DIRECTION ',I5,1X,I5,' = ',10(A4,1X)) 5079 CALL DPWRST('XXX','BUG ') 5080 WRITE(ICOUT,416)LSTRT,LSTOP,(ILEGFI(I),I=LSTRT,LSTOP) 5081 416 FORMAT(' LEGEND FILL ',I5,1X,I5,' = ',10(A4,1X)) 5082 CALL DPWRST('XXX','BUG ') 5083 WRITE(ICOUT,417)LSTRT,LSTOP,(ILEGCO(I),I=LSTRT,LSTOP) 5084 417 FORMAT(' LEGEND COLOR ',I5,1X,I5,' = ',10(A4,1X)) 5085 CALL DPWRST('XXX','BUG ') 5086C 5087 DO1418I=LSTRT,LSTOP 5088 WRITE(ICOUT,418)I,I,PLEGXC(I),PLEGYC(I) 5089 418 FORMAT(' LEGEND COORDINATES ',I5,1X,I5,' = ',2(E12.5,1X)) 5090 CALL DPWRST('XXX','BUG ') 5091 1418 CONTINUE 5092C 5093 WRITE(ICOUT,419)LSTRT,LSTOP,(PLEGHE(I),I=LSTRT,LSTOP) 5094 419 FORMAT(' LEGEND SIZE ',I5,1X,I5,' = ',10(E12.5,1X)) 5095 CALL DPWRST('XXX','BUG ') 5096 WRITE(ICOUT,420)LSTRT,LSTOP,(PLEGWI(I),I=LSTRT,LSTOP) 5097 420 FORMAT(' LEGEND WIDTH ',I5,1X,I5,' = ',10(E12.5,1X)) 5098 CALL DPWRST('XXX','BUG ') 5099 WRITE(ICOUT,421)LSTRT,LSTOP,(PLEGTH(I),I=LSTRT,LSTOP) 5100 421 FORMAT(' LEGEND THICKNESS ',I5,1X,I5,' = ',10(E12.5,1X)) 5101 CALL DPWRST('XXX','BUG ') 5102 WRITE(ICOUT,422)LSTRT,LSTOP,(ALEGAN(I),I=LSTRT,LSTOP) 5103 422 FORMAT(' LEGEND ANGLE ',I5,1X,I5,' = ',10(E12.5,1X)) 5104 CALL DPWRST('XXX','BUG ') 5105 492 CONTINUE 5106C 5107 499 CONTINUE 5108C 5109 DO1990LL=1,20 5110 LSTRT=(LL-1)*LINC+1 5111 LSTOP=LL*LINC 5112 IF(LSTRT.GT.ISTOP)GOTO1999 5113 IF(LSTRT.LT.ISTART)LSTRT=ISTART 5114 IF(LSTOP.GT.ISTOP)LSTOP=ISTOP 5115C 5116 IF(ILINFL.EQ.'OFF')GOTO599 5117CCCCC WRITE(ICOUT,501) 5118CC501 FORMAT('LINE ATTRIBUTES') 5119CCCCC CALL DPWRST('XXX','BUG ') 5120 WRITE(ICOUT,512)LSTRT,LSTOP,(ILINPA(I),I=LSTRT,LSTOP) 5121 512 FORMAT(' LINE ',I5,1X,I5,' = ',10(A4,1X)) 5122 CALL DPWRST('XXX','BUG ') 5123 WRITE(ICOUT,513)LSTRT,LSTOP,(ILINCO(I),I=LSTRT,LSTOP) 5124 513 FORMAT(' LINE COLOR ',I5,1X,I5,' = ',10(A4,1X)) 5125 CALL DPWRST('XXX','BUG ') 5126 WRITE(ICOUT,514)LSTRT,LSTOP,(PLINTH(I),I=LSTRT,LSTOP) 5127 514 FORMAT(' LINE THICKNESS ',I5,1X,I5,' = ',10(E12.5,1X)) 5128 CALL DPWRST('XXX','BUG ') 5129 599 CONTINUE 5130C 5131 IF(ICHAFL.EQ.'OFF')GOTO699 5132CCCCC WRITE(ICOUT,601) 5133CC601 FORMAT('CHARACTER ATTRIBUTES') 5134CCCCC CALL DPWRST('XXX','BUG ') 5135 ICOUNT=0 5136 DO601I=LSTRT,LSTOP 5137 ICOUNT=ICOUNT+1 5138 ITEMPH(ICOUNT)='BLAN' 5139 IF(ICHAPA(I).NE.' ')ITEMPH(ICOUNT)=ICHAPA(I) 5140 601 CONTINUE 5141C 5142 WRITE(ICOUT,611)LSTRT,LSTOP,(ITEMPH(I),I=1,ICOUNT) 5143 611 FORMAT(' CHARACTER ',I5,1X,I5,' = ',10(A16,1X)) 5144 CALL DPWRST('XXX','BUG ') 5145 WRITE(ICOUT,612)LSTRT,LSTOP,(ICHAFO(I),I=LSTRT,LSTOP) 5146 612 FORMAT(' CHARACTER FONT ',I5,1X,I5,' = ',10(A4,1X)) 5147 CALL DPWRST('XXX','BUG ') 5148 WRITE(ICOUT,613)LSTRT,LSTOP,(ICHACO(I),I=LSTRT,LSTOP) 5149 613 FORMAT(' CHARACTER COLOR ',I5,1X,I5,' = ',10(A4,1X)) 5150 CALL DPWRST('XXX','BUG ') 5151 WRITE(ICOUT,614)LSTRT,LSTOP,(ICHACA(I),I=LSTRT,LSTOP) 5152 614 FORMAT(' CHARACTER CASE ',I5,1X,I5,' = ',10(A4,1X)) 5153 CALL DPWRST('XXX','BUG ') 5154 WRITE(ICOUT,615)LSTRT,LSTOP,(ICHAJU(I),I=LSTRT,LSTOP) 5155 615 FORMAT(' CHARACTER JUSTIFICATION ',I5,1X,I5,' = ',10(A4,1X)) 5156 CALL DPWRST('XXX','BUG ') 5157 WRITE(ICOUT,616)LSTRT,LSTOP,(ICHADI(I),I=LSTRT,LSTOP) 5158 616 FORMAT(' CHARACTER DIRECTION ',I5,1X,I5,' = ',10(A4,1X)) 5159 CALL DPWRST('XXX','BUG ') 5160 WRITE(ICOUT,617)LSTRT,LSTOP,(ICHAFI(I),I=LSTRT,LSTOP) 5161 617 FORMAT(' CHARACTER FILL ',I5,1X,I5,' = ',10(A4,1X)) 5162 CALL DPWRST('XXX','BUG ') 5163 WRITE(ICOUT,618)LSTRT,LSTOP,(PCHAHE(I),I=LSTRT,LSTOP) 5164 618 FORMAT(' CHARACTER SIZE ',I5,1X,I5,' = ',10(E12.5,1X)) 5165 CALL DPWRST('XXX','BUG ') 5166 WRITE(ICOUT,619)LSTRT,LSTOP,(PCHAWI(I),I=LSTRT,LSTOP) 5167 619 FORMAT(' CHARACTER WIDTH ',I5,1X,I5,' = ',10(E12.5,1X)) 5168 CALL DPWRST('XXX','BUG ') 5169 WRITE(ICOUT,620)LSTRT,LSTOP,(ACHAAN(I),I=LSTRT,LSTOP) 5170 620 FORMAT(' CHARACTER ANGLE ',I5,1X,I5,' = ',10(E12.5,1X)) 5171 CALL DPWRST('XXX','BUG ') 5172 WRITE(ICOUT,621)LSTRT,LSTOP,(PCHATH(I),I=LSTRT,LSTOP) 5173 621 FORMAT(' CHARACTER THICKNESS ',I5,1X,I5,' = ',10(E12.5,1X)) 5174 CALL DPWRST('XXX','BUG ') 5175 699 CONTINUE 5176C 5177 IF(ISPIFL.EQ.'OFF')GOTO799 5178CCCCC WRITE(ICOUT,701) 5179CC701 FORMAT('SPIKE ATTRIBUTES') 5180CCCCC CALL DPWRST('XXX','BUG ') 5181 WRITE(ICOUT,711)LSTRT,LSTOP,(ISPISW(I),I=LSTRT,LSTOP) 5182 711 FORMAT(' SPIKE ',I5,1X,I5,' = ',10(A4,1X)) 5183 CALL DPWRST('XXX','BUG ') 5184 WRITE(ICOUT,712)LSTRT,LSTOP,(ISPILI(I),I=LSTRT,LSTOP) 5185 712 FORMAT(' SPIKE LINE ',I5,1X,I5,' = ',10(A4,1X)) 5186 CALL DPWRST('XXX','BUG ') 5187 WRITE(ICOUT,713)LSTRT,LSTOP,(ISPICO(I),I=LSTRT,LSTOP) 5188 713 FORMAT(' SPIKE COLOR ',I5,1X,I5,' = ',10(A4,1X)) 5189 CALL DPWRST('XXX','BUG ') 5190 WRITE(ICOUT,714)LSTRT,LSTOP,(PSPITH(I),I=LSTRT,LSTOP) 5191 714 FORMAT(' SPIKE THICKNESS ',I5,1X,I5,' = ',10(E12.5,1X)) 5192 CALL DPWRST('XXX','BUG ') 5193 WRITE(ICOUT,715)LSTRT,LSTOP,(ASPIBA(I),I=LSTRT,LSTOP) 5194 715 FORMAT(' SPIKE BASE ',I5,1X,I5,' = ',10(E12.5,1X)) 5195 CALL DPWRST('XXX','BUG ') 5196 799 CONTINUE 5197C 5198 IF(IBARFL.EQ.'OFF')GOTO899 5199CCCCC WRITE(ICOUT,801) 5200CC801 FORMAT('BAR ATTRIBUTES') 5201CCCCC CALL DPWRST('XXX','BUG ') 5202 WRITE(ICOUT,811)LSTRT,LSTOP,(IBARSW(I),I=LSTRT,LSTOP) 5203 811 FORMAT(' BAR ',I5,1X,I5,' = ',10(A4,1X)) 5204 CALL DPWRST('XXX','BUG ') 5205 WRITE(ICOUT,812)LSTRT,LSTOP,(ABARBA(I),I=LSTRT,LSTOP) 5206 812 FORMAT(' BAR BASE ',I5,1X,I5,' ',' = ',10(E12.5,1X)) 5207 CALL DPWRST('XXX','BUG ') 5208C 5209C NOTE JULY 2009: FOR GUI, IF VALUE SET TO CPUMIN, THEN 5210C SET TO -99. 5211C 5212 DO8813I=1,100 5213 IF(ABARWI(I).LT.-99.0)THEN 5214 TEMP(I)=-99.0 5215 ELSE 5216 TEMP(I)=ABARWI(I) 5217 ENDIF 5218 8813 CONTINUE 5219CCCCC WRITE(ICOUT,813)LSTRT,LSTOP,(ABARWI(I),I=LSTRT,LSTOP) 5220 WRITE(ICOUT,813)LSTRT,LSTOP,(TEMP(I),I=LSTRT,LSTOP) 5221 813 FORMAT(' BAR WIDTH ',I5,1X,I5,' = ',10(E12.5,1X)) 5222 CALL DPWRST('XXX','BUG ') 5223 WRITE(ICOUT,821)LSTRT,LSTOP,(IBABLI(I),I=LSTRT,LSTOP) 5224 821 FORMAT(' BAR BORDER LINE ',I5,1X,I5,' = ',10(A4,1X)) 5225 CALL DPWRST('XXX','BUG ') 5226 WRITE(ICOUT,822)LSTRT,LSTOP,(IBABCO(I),I=LSTRT,LSTOP) 5227 822 FORMAT(' BAR BORDER COLOR ',I5,1X,I5,' = ',10(A4,1X)) 5228 CALL DPWRST('XXX','BUG ') 5229 WRITE(ICOUT,823)LSTRT,LSTOP,(PBABTH(I),I=LSTRT,LSTOP) 5230 823 FORMAT(' BAR BORDER THICKNESS ',I5,1X,I5,' = ',10(E12.5,1X)) 5231 CALL DPWRST('XXX','BUG ') 5232 WRITE(ICOUT,831)LSTRT,LSTOP,(IBAFSW(I),I=LSTRT,LSTOP) 5233 831 FORMAT(' BAR FILL ',I5,1X,I5,' = ',10(A4,1X)) 5234 CALL DPWRST('XXX','BUG ') 5235 WRITE(ICOUT,832)LSTRT,LSTOP,(IBAFCO(I),I=LSTRT,LSTOP) 5236 832 FORMAT(' BAR FILL COLOR ',I5,1X,I5,' = ',10(A4,1X)) 5237 CALL DPWRST('XXX','BUG ') 5238 WRITE(ICOUT,841)LSTRT,LSTOP,(IBAPTY(I),I=LSTRT,LSTOP) 5239 841 FORMAT(' BAR PATTERN ',I5,1X,I5,' = ',10(A4,1X)) 5240 CALL DPWRST('XXX','BUG ') 5241 WRITE(ICOUT,842)LSTRT,LSTOP,(IBAPLI(I),I=LSTRT,LSTOP) 5242 842 FORMAT(' BAR PATTERN LINE ',I5,1X,I5,' = ',10(A4,1X)) 5243 CALL DPWRST('XXX','BUG ') 5244 WRITE(ICOUT,843)LSTRT,LSTOP,(IBAPCO(I),I=LSTRT,LSTOP) 5245 843 FORMAT(' BAR PATTERN COLOR ',I5,1X,I5,' = ',10(A4,1X)) 5246 CALL DPWRST('XXX','BUG ') 5247 WRITE(ICOUT,844)LSTRT,LSTOP,(PBABTH(I),I=LSTRT,LSTOP) 5248 844 FORMAT(' BAR PATTERN THICKNESS ',I5,1X,I5,' = ',10(E12.5,1X)) 5249 CALL DPWRST('XXX','BUG ') 5250 WRITE(ICOUT,845)LSTRT,LSTOP,(PBAPSP(I),I=LSTRT,LSTOP) 5251 845 FORMAT(' BAR PATTERN SPACING ',I5,1X,I5,' = ',10(E12.5,1X)) 5252 CALL DPWRST('XXX','BUG ') 5253 899 CONTINUE 5254C 5255 1990 CONTINUE 5256 1999 CONTINUE 5257C 5258 IF(ILIMFL.EQ.'OFF')GOTO990 5259 WRITE(ICOUT,901) 5260 901 FORMAT('LIMIT AND TIC MARK ATTRIBUTES') 5261 CALL DPWRST('XXX','BUG ') 5262C 5263C NOTE JULY 2009: FOR GUI, IF VALUE SET TO CPUMIN, THEN 5264C SET TO -99. 5265C 5266 ATEMP1=FX1MNZ 5267 ATEMP2=FX1MXZ 5268 IF(FX1MNZ.LT.-99)ATEMP1=-99.0 5269 IF(FX1MXZ.LT.-99)ATEMP1=-99.0 5270CCCCC WRITE(ICOUT,902)FX1MNZ,FX1MXZ 5271 WRITE(ICOUT,902)ATEMP1,ATEMP2 5272 902 FORMAT(' X1 LIMITS = ',E12.5,1X,E15.7) 5273 CALL DPWRST('XXX','BUG ') 5274 ATEMP1=FX2MNZ 5275 ATEMP2=FX2MXZ 5276 IF(FX2MNZ.LT.-99)ATEMP1=-99.0 5277 IF(FX2MXZ.LT.-99)ATEMP1=-99.0 5278CCCCC WRITE(ICOUT,904)FX2MNZ,FX2MXZ 5279 WRITE(ICOUT,904)ATEMP1,ATEMP2 5280 904 FORMAT(' X2 LIMITS = ',E12.5,1X,E15.7) 5281 CALL DPWRST('XXX','BUG ') 5282 ATEMP1=FY1MNZ 5283 ATEMP2=FY1MXZ 5284 IF(FY1MNZ.LT.-99)ATEMP1=-99.0 5285 IF(FY1MXZ.LT.-99)ATEMP1=-99.0 5286CCCCC WRITE(ICOUT,906)FY1MNZ,FY1MXZ 5287 WRITE(ICOUT,906)ATEMP1,ATEMP2 5288 906 FORMAT(' Y1 LIMITS = ',E12.5,1X,E15.7) 5289 CALL DPWRST('XXX','BUG ') 5290 ATEMP1=FY2MNZ 5291 ATEMP2=FY2MXZ 5292 IF(FY2MNZ.LT.-99)ATEMP1=-99.0 5293 IF(FY2MXZ.LT.-99)ATEMP1=-99.0 5294CCCCC WRITE(ICOUT,908)FY2MNZ,FY2MXZ 5295 WRITE(ICOUT,908)ATEMP1,ATEMP2 5296 908 FORMAT(' Y2 LIMITS = ',E12.5,1X,E15.7) 5297 CALL DPWRST('XXX','BUG ') 5298C 5299 WRITE(ICOUT,911)IX1FSW,IX2FSW,IY1FSW,IY2FSW 5300 911 FORMAT(' X1, X2, Y1, Y2 FRAME = ',4(A4,1X)) 5301 CALL DPWRST('XXX','BUG ') 5302 WRITE(ICOUT,1911)IX1FPA,IX2FPA,IY1FPA,IY2FPA 5303 1911 FORMAT(' X1, X2, Y1, Y2 FRAME PATTERN = ',4(A4,1X)) 5304 CALL DPWRST('XXX','BUG ') 5305 WRITE(ICOUT,1912)IX1FCO,IX2FCO,IY1FCO,IY2FCO 5306 1912 FORMAT(' X1, X2, Y1, Y2 FRAME COLOR = ',4(A4,1X)) 5307 CALL DPWRST('XXX','BUG ') 5308 WRITE(ICOUT,1913)PFRATH 5309 1913 FORMAT(' FRAME THICKNESS = ',E12.5) 5310 CALL DPWRST('XXX','BUG ') 5311 WRITE(ICOUT,1915)PXMIN,PXMAX,PYMIN,PYMAX 5312 1915 FORMAT(' FRAME COORDINATES = ',4E12.5) 5313 CALL DPWRST('XXX','BUG ') 5314C 5315 WRITE(ICOUT,912)IVGRSW,IHGRSW 5316 912 FORMAT(' X, Y GRID = ',2(A4,1X)) 5317 CALL DPWRST('XXX','BUG ') 5318 WRITE(ICOUT,913)IVGRPA,IHGRPA 5319 913 FORMAT(' X, Y GRID PATTERN = ',2(A4,1X)) 5320 CALL DPWRST('XXX','BUG ') 5321 WRITE(ICOUT,914)IVGRCO,IHGRCO 5322 914 FORMAT(' X, Y GRID COLOR = ',2(A4,1X)) 5323 CALL DPWRST('XXX','BUG ') 5324 WRITE(ICOUT,915)PVGRTH,PHGRTH 5325 915 FORMAT(' X, Y GRID THICKNESS = ',2(E12.5,1X)) 5326 CALL DPWRST('XXX','BUG ') 5327C 5328 WRITE(ICOUT,921)IX1TSW,IX2TSW,IY1TSW,IY2TSW 5329 921 FORMAT(' X1, X2, Y1, Y2 TIC = ',4(A4,1X)) 5330 CALL DPWRST('XXX','BUG ') 5331 WRITE(ICOUT,922)IX1TJU,IX2TJU,IY1TJU,IY2TJU 5332 922 FORMAT(' X1, X2, Y1, Y2 TIC POSITION = ',4(A4,1X)) 5333 CALL DPWRST('XXX','BUG ') 5334 WRITE(ICOUT,923)IX1TCO,IX2TCO,IY1TCO,IY2TCO 5335 923 FORMAT(' X1, X2, Y1, Y2 TIC COLOR = ',4(A4,1X)) 5336 CALL DPWRST('XXX','BUG ') 5337 WRITE(ICOUT,924)PX1TLE,PX2TLE,PY1TLE,PY2TLE 5338 924 FORMAT(' X1, X2, Y1, Y2 TIC SIZE = ',4(E12.5,1X)) 5339 CALL DPWRST('XXX','BUG ') 5340 ITMP1='OFF' 5341 ITMP2='OFF' 5342 ITMP3='OFF' 5343 ITMP4='OFF' 5344 IF(IX1TSC.EQ.'LOG')ITMP1='ON' 5345 IF(IX2TSC.EQ.'LOG')ITMP2='ON' 5346 IF(IY1TSC.EQ.'LOG')ITMP3='ON' 5347 IF(IY2TSC.EQ.'LOG')ITMP4='ON' 5348 WRITE(ICOUT,925)ITMP1,ITMP2,ITMP3,ITMP4 5349 925 FORMAT(' X1, X2, Y1, Y2 LOG = ',4(A4,1X)) 5350 CALL DPWRST('XXX','BUG ') 5351 WRITE(ICOUT,931)PX1TOL,PX1TOR 5352 931 FORMAT(' X1 TIC OFFSET = ',2(E12.5,1X)) 5353 CALL DPWRST('XXX','BUG ') 5354 WRITE(ICOUT,932)PX2TOL,PX2TOR 5355 932 FORMAT(' X2 TIC OFFSET = ',2(E12.5,1X)) 5356 CALL DPWRST('XXX','BUG ') 5357 WRITE(ICOUT,933)PY1TOB,PY1TOT 5358 933 FORMAT(' Y1 TIC OFFSET = ',2(E12.5,1X)) 5359 CALL DPWRST('XXX','BUG ') 5360 WRITE(ICOUT,934)PY2TOB,PY2TOT 5361 934 FORMAT(' Y2 TIC OFFSET = ',2(E12.5,1X)) 5362 CALL DPWRST('XXX','BUG ') 5363 WRITE(ICOUT,935)ITICUN 5364 935 FORMAT(' TIC OFFSET UNITS = ',A4) 5365 CALL DPWRST('XXX','BUG ') 5366 WRITE(ICOUT,941)NMJX1T,NMJX2T,NMJY1T,NMJY2T 5367 941 FORMAT(' X1, X2, Y1, Y2 TIC NUMBER MAJOR = ',4(I5,1X)) 5368 CALL DPWRST('XXX','BUG ') 5369 WRITE(ICOUT,942)NMNX1T,NMNX2T,NMNY1T,NMNY2T 5370 942 FORMAT(' X1, X2, Y1, Y2 TIC NUMBER MINOR = ',4(I5,1X)) 5371 CALL DPWRST('XXX','BUG ') 5372 WRITE(ICOUT,951)IX1ZSW,IX2ZSW,IY1ZSW,IY2ZSW 5373 951 FORMAT(' X1, X2, Y1, Y2 TIC LABEL = ',4(A4,1X)) 5374 CALL DPWRST('XXX','BUG ') 5375 WRITE(ICOUT,952)IX1ZCO,IX2ZCO,IY1ZCO,IY2ZCO 5376 952 FORMAT(' X1, X2, Y1, Y2 TIC LABEL COLOR = ',4(A4,1X)) 5377 CALL DPWRST('XXX','BUG ') 5378 WRITE(ICOUT,953)IX1ZCA,IX2ZCA,IY1ZCA,IY2ZCA 5379 953 FORMAT(' X1, X2, Y1, Y2 TIC LABEL CASE = ',4(A4,1X)) 5380 CALL DPWRST('XXX','BUG ') 5381 WRITE(ICOUT,954)IX1ZFO,IX2ZFO,IY1ZFO,IY2ZFO 5382 954 FORMAT(' X1, X2, Y1, Y2 TIC LABEL FONT = ',4(A4,1X)) 5383 CALL DPWRST('XXX','BUG ') 5384 WRITE(ICOUT,955)IX1ZJU,IX2ZJU,IY1ZJU,IY2ZJU 5385 955 FORMAT(' X1, X2, Y1, Y2 TIC LABEL JUSTIFICATION = ', 5386 14(A4,1X)) 5387 CALL DPWRST('XXX','BUG ') 5388 WRITE(ICOUT,956)IX1ZDI,IX2ZDI,IY1ZDI,IY2ZDI 5389 956 FORMAT(' X1, X2, Y1, Y2 TIC LABEL DIRECTION = ', 5390 14(A4,1X)) 5391 CALL DPWRST('XXX','BUG ') 5392 WRITE(ICOUT,957)IX1ZFI,IX2ZFI,IY1ZFI,IY2ZFI 5393 957 FORMAT(' X1, X2, Y1, Y2 TIC LABEL FILL = ',4(A4,1X)) 5394 CALL DPWRST('XXX','BUG ') 5395 WRITE(ICOUT,958)IX1ZDP,IX2ZDP,IY1ZDP,IY2ZDP 5396 958 FORMAT(' X1, X2, Y1, Y2 TIC LABEL DECIMALS = ',4(I5,1X)) 5397 CALL DPWRST('XXX','BUG ') 5398 WRITE(ICOUT,959)PX1ZDS,PX2ZDS,PY1ZDS,PY2ZDS 5399 959 FORMAT(' X1, X2, Y1, Y2 TIC LABEL DISPLACEMENT = ', 5400 14(E12.5,1X)) 5401 CALL DPWRST('XXX','BUG ') 5402 WRITE(ICOUT,960)AX1ZAN,AX2ZAN,AY1ZAN,AY2ZAN 5403 960 FORMAT(' X1, X2, Y1, Y2 TIC LABEL ANGLE = ',4(E12.5,1X)) 5404 CALL DPWRST('XXX','BUG ') 5405 WRITE(ICOUT,961)PX1ZHE,PX2ZHE,PY1ZHE,PY2ZHE 5406 961 FORMAT(' X1, X2, Y1, Y2 TIC LABEL SIZE = ',4(E12.5,1X)) 5407 CALL DPWRST('XXX','BUG ') 5408 WRITE(ICOUT,971)PTIZTH 5409 971 FORMAT(' TIC LABEL THICKNESS = ',4(E12.5,1X)) 5410 CALL DPWRST('XXX','BUG ') 5411C 5412 990 CONTINUE 5413C 5414C -----END WRITING OUT----------------------- 5415C 5416C *************************** 5417C ** STEP 42-- ** 5418C ** WRITE OUT A MESSAGE ** 5419C *************************** 5420C 5421 ISTEPN='42' 5422 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAPC') 5423 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5424C 5425C **************** 5426C ** STEP 90-- ** 5427C ** EXIT. ** 5428C **************** 5429C 5430 RETURN 5431 END 5432 SUBROUTINE DPSAPL(IANSLC,IWIDTH,IHARG,NUMARG, 5433 1 IBUGS2,ISUBRO,IFOUND,IERROR) 5434C 5435C PURPOSE--SAVE (FOR FUTURE USE BY THE REPEAT GRAPH COMMAND) 5436C SELECTED PLOTS. IT SUPPORTS THE FOLLOWING: 5437C 5438C SAVE PLOT <FILE NAME>: 5439C SAVES THE CURRENT PIXMAP TO THE SPECIFIED FILE 5440C SAVE PLOT AUTOMATIC <FILENAME>: 5441C AUTOMATICALLY SAVE ALL SUBSEQUENT FILES, USING 5442C <FILE NAME> AS THE BASE FILE NAME (APPEND A 5443C ".1", ".2", ETC.) 5444C 5445C WRITTEN BY--JAMES J. FILLIBEN 5446C STATISTICAL ENGINEERING DIVISION 5447C INFORMATION TECHNOLOGY LABORATORY 5448C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5449C GAITHERSBURG, MD 20899-8980 5450C PHONE--301-975-2899 5451C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5452C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGU 5453C LANGUAGE--ANSI FORTRAN (1977) 5454C VERSION NUMBER--97/4 5455C ORIGINAL VERSION--APRIL 1997. 5456C UPDATED --AUGUST 1997. MOVE SOME CODE TO A LOWER LEVEL 5457C TO SUPPORT NON-X11 DEVICES 5458C (SPECIFICALLY PC FOR NOW) 5459C 5460C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5461C 5462 INCLUDE 'DPCOPA.INC' 5463C 5464 CHARACTER*4 IANSLC(*) 5465 CHARACTER*4 IHARG(*) 5466CCCCC CHARACTER*1 IANSSV 5467CCCCC CHARACTER*80 ISACNC 5468C 5469 CHARACTER*4 IBUGS2 5470 CHARACTER*4 ISUBRO 5471 CHARACTER*4 IERROR 5472 CHARACTER*4 IFOUND 5473C 5474 CHARACTER*4 IC4 5475 CHARACTER*4 ICODE 5476C DIMENSION FOLLOWING 2 LINES TO MAXSTR 5477 CHARACTER (LEN=MAXSTR) :: ISTRIN 5478 CHARACTER (LEN=MAXSTR) :: ISTRI2 5479 CHARACTER*128 CTEMP 5480C 5481 CHARACTER*4 ISTEPN 5482 CHARACTER*4 ISUBN1 5483 CHARACTER*4 ISUBN2 5484 CHARACTER*4 ISAVFL 5485C 5486CCCCC DIMENSION IADE(128) 5487C 5488C-----COMMON---------------------------------------------------------- 5489C 5490 INCLUDE 'DPCOPM.INC' 5491 INCLUDE 'DPCOF2.INC' 5492 INCLUDE 'DPCOP2.INC' 5493C 5494C-----START POINT----------------------------------------------------- 5495C 5496 ISUBN1='DPSA' 5497 ISUBN2='PL ' 5498 IFOUND='NO' 5499 IERROR='NO' 5500C 5501 IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'SAPL')THEN 5502 WRITE(ICOUT,999) 5503 999 FORMAT(1X) 5504 CALL DPWRST('XXX','BUG ') 5505 WRITE(ICOUT,51) 5506 51 FORMAT('AT THE BEGINNING OF DPSAPL--') 5507 CALL DPWRST('XXX','BUG ') 5508 WRITE(ICOUT,52)IBUGS2,ISUBRO,IFOUND,IERROR 5509 52 FORMAT('IBUGS2,ISUBRO,IFOUND,IERROR = ',3(A4,2X),A4) 5510 CALL DPWRST('XXX','BUG ') 5511 WRITE(ICOUT,53)IWIDTH,NUMARG 5512 53 FORMAT('IWIDTH,NUMARG = ',2I8) 5513 CALL DPWRST('XXX','BUG ') 5514 IF(IWIDTH.GE.1)THEN 5515 WRITE(ICOUT,54)(IANSLC(I),I=1,MIN(80,IWIDTH)) 5516 54 FORMAT('(IANSLC(I),I=1,IWIDTH) = ',80A1) 5517 CALL DPWRST('XXX','BUG ') 5518 ENDIF 5519 IF(NUMARG.GE.1)THEN 5520 DO56I=1,NUMARG 5521 WRITE(ICOUT,57)I,IHARG(I) 5522 57 FORMAT('I,IHARG(I) = ',I8,2X,A4) 5523 CALL DPWRST('XXX','BUG ') 5524 56 CONTINUE 5525 ENDIF 5526 ENDIF 5527C 5528 IFOUND='YES' 5529C 5530C ****************************************************** 5531C ** STEP 10-- ** 5532C ** DETERMINE IF HAVE SAVE PLOT AUTOMATIC CASE ** 5533C ****************************************************** 5534C 5535 ISTEPN='10' 5536 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAPL') 5537 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5538C 5539 ISAVFL='OFF' 5540 IF(NUMARG.GE.1)THEN 5541 DO1010I=1,NUMARG 5542 IF(IHARG(I).EQ.'AUTO' .OR. IHARG(I).EQ.'ON' .OR. 5543 1 IHARG(I).EQ.'YES' )THEN 5544 ISAVFL='ON' 5545 IPXMFL='ON' 5546 GOTO1019 5547 ENDIF 5548 1010 CONTINUE 5549 1019 CONTINUE 5550 ENDIF 5551C 5552C ****************************************************** 5553C ** STEP 11-- ** 5554C ** DETERMINE IF HAVE AN EXPLICIT FILE REFERENCE ** 5555C ** WHERE THE PIXMAPS WILL BE SAVED, OR WILL THEY ** 5556C ** BE SAVED IN THE DEFAULT FILE (PIXMAP.<n>? ** 5557C ****************************************************** 5558C 5559 ISTEPN='11' 5560 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAPL') 5561 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5562C 5563 IFILWD=(-999) 5564C 5565 DO1100I=1,MAXSTR 5566 IC4=IANSLC(I) 5567 ISTRIN(I:I)=IC4(1:1) 5568 1100 CONTINUE 5569C 5570 IWORD=1 5571 ISTART=1 5572 ISTOP=MAXSTR-1 5573 CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD, 5574 1ICOL1,ICOL2,ISTRI2,NCSTR2, 5575 1IBUGS2,ISUBRO,IERROR) 5576C 5577 IF(NUMARG.LE.0)GOTO1129 5578 IWORD=2 5579 ISTART=1 5580 ISTOP=MAXSTR-1 5581 CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD, 5582 1ICOL1,ICOL2,ISTRI2,NCSTR2, 5583 1IBUGS2,ISUBRO,IERROR) 5584 IF(NCSTR2.LE.0)GOTO1129 5585 DO1121I=1,NCSTR2 5586 IF(ISTRI2(I:I).EQ.'.')GOTO1122 5587 1121 CONTINUE 5588 GOTO1129 5589 1122 CONTINUE 5590 IFILWD=2 5591 GOTO1190 5592 1129 CONTINUE 5593C 5594 IF(NUMARG.LE.1)GOTO1139 5595 IWORD=3 5596 ISTART=1 5597 ISTOP=MAXSTR-1 5598 CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD, 5599 1ICOL1,ICOL2,ISTRI2,NCSTR2, 5600 1IBUGS2,ISUBRO,IERROR) 5601 IF(NCSTR2.LE.0)GOTO1139 5602 DO1131I=1,NCSTR2 5603 IF(ISTRI2(I:I).EQ.'.')GOTO1132 5604 1131 CONTINUE 5605 GOTO1139 5606 1132 CONTINUE 5607 IFILWD=3 5608 GOTO1190 5609 1139 CONTINUE 5610C 5611 IF(NUMARG.LE.2)GOTO1149 5612 IWORD=4 5613 ISTART=1 5614 ISTOP=MAXSTR-1 5615 CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD, 5616 1ICOL1,ICOL2,ISTRI2,NCSTR2, 5617 1IBUGS2,ISUBRO,IERROR) 5618 IF(NCSTR2.LE.0)GOTO1149 5619 DO1141I=1,NCSTR2 5620 IF(ISTRI2(I:I).EQ.'.')GOTO1142 5621 1141 CONTINUE 5622 GOTO1149 5623 1142 CONTINUE 5624 IFILWD=4 5625 GOTO1190 5626 1149 CONTINUE 5627C 5628 1190 CONTINUE 5629C 5630 IF(ISAVFL.EQ.'ON')THEN 5631 IF(IFILWD.GE.1)THEN 5632 IPXMFB=' ' 5633 IPXMFB(1:NCSTR2)=ISTRI2(1:NCSTR2) 5634 IPXMNC=NCSTR2 5635 ENDIF 5636 IF(IHARG(NUMARG).EQ.'OFF'.OR.IHARG(NUMARG).EQ.'DEFA'.OR. 5637 1 IHARG(NUMARG).EQ.'NO')THEN 5638 ISAVFL='OFF' 5639 ENDIF 5640 GOTO9000 5641 ENDIF 5642C 5643 NUMPXM=NUMPXM+1 5644 IF(NUMPXM.GT.MAXPM)THEN 5645 WRITE(ICOUT,999) 5646 CALL DPWRST('XXX','BUG ') 5647 WRITE(ICOUT,1191)MAXPM 5648 CALL DPWRST('XXX','BUG ') 5649 IERROR='YES' 5650 GOTO9000 5651 ENDIF 5652 1191 FORMAT('***** ERROR IN DPSAPL: MAXIMUM NUMBER OF PIXMAPS (',I5, 5653 1') EXCEEDED.') 5654C 5655 IF(IFILWD.LE.0)THEN 5656 ISTRI2=' ' 5657 ISTRI2(1:7)='pixmap.' 5658 IF(NUMPXM.LE.9)THEN 5659 WRITE(ISTRI2(8:8),'(I1)')NUMPXM 5660 NCSTR2=8 5661 ELSEIF(NUMPXM.LE.99)THEN 5662 WRITE(ISTRI2(8:9),'(I2)')NUMPXM 5663 NCSTR2=9 5664 ELSEIF(NUMPXM.LE.999)THEN 5665 WRITE(ISTRI2(8:10),'(I3)')NUMPXM 5666 NCSTR2=10 5667 ENDIF 5668 ENDIF 5669 IPXMFN(NUMPXM)=' ' 5670 IPXMFN(NUMPXM)(1:128)=ISTRI2(1:128) 5671 IF(IPXMCM(NUMPXM).EQ.' ')THEN 5672 IPXMCM(NUMPXM)(1:128)=IPXMFN(NUMPXM)(1:128) 5673 ENDIF 5674C 5675C ******************************* 5676C ** STEP 12-- ** 5677C ** CALL XSAVEG ** 5678C ******************************* 5679C 5680 ISTEPN='12' 5681 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAPL') 5682 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5683C 5684 IF(NCSTR2.GT.127)THEN 5685 WRITE(ICOUT,999) 5686 CALL DPWRST('XXX','BUG ') 5687 WRITE(ICOUT,1209) 5688 CALL DPWRST('XXX','BUG ') 5689 IERROR='YES' 5690 GOTO9000 5691 1209 FORMAT('***** ERROR IN DPSAPL--FILE NAME EXCEEDS 127 ', 5692 1'CHARACTERS.') 5693 ENDIF 5694c 5695C AUGUST 1997. TO MAKE CODE MORE GENERAL, CALL A LOW LEVEL 5696C GRAPHICS ROUTINE. MOVE THIS CODE TO THAT SUBROUTINE. 5697C 5698 ICODE='SAVE' 5699 CTEMP=' ' 5700 NCTEMP=0 5701 CALL GRSAGR(ICODE,ISTRI2,NCSTR2,CTEMP,NCTEMP) 5702C 5703CCCCC DO1220I=1,NCSTR2 5704CCCCC CALL DPCOAN(ISTRI2(I:I),IJUNK) 5705CCCCC IADE(I)=IJUNK 5706C1220 CONTINUE 5707CCCCC IADE(NCSTR2+1)=0 5708C 5709CCCCC IERR=0 5710CCCCC CALL XSAVEG(IADE,IERR) 5711CCCCC IF(IERR.EQ.1)THEN 5712CCCCC WRITE(ICOUT,999) 5713CCCCC CALL DPWRST('XXX','BUG ') 5714CCCCC WRITE(ICOUT,1251) 5715CCCCC CALL DPWRST('XXX','BUG ') 5716CCCCC IERROR='YES' 5717CCCCC GOTO9000 5718C1251 FORMAT('***** ERROR IN DPSAPL--WRITING BIT MAP UNSUCCESSFUL.') 5719CCCCC ELSEIF(IERR.EQ.2)THEN 5720CCCCC WRITE(ICOUT,999) 5721CCCCC CALL DPWRST('XXX','BUG ') 5722CCCCC WRITE(ICOUT,1261) 5723CCCCC CALL DPWRST('XXX','BUG ') 5724CCCCC IERROR='YES' 5725CCCCC GOTO9000 5726C1261 FORMAT('***** ERROR IN DPSAPL--NO CURRENT PIXMAP TO SAVE.') 5727CCCCC ELSEIF(IERR.EQ.3)THEN 5728CCCCC WRITE(ICOUT,999) 5729CCCCC CALL DPWRST('XXX','BUG ') 5730CCCCC WRITE(ICOUT,1271) 5731CCCCC CALL DPWRST('XXX','BUG ') 5732CCCCC IERROR='YES' 5733CCCCC GOTO9000 5734C1271 FORMAT('***** ERROR IN DPSAPL--X11 HAS NOT BEEN OPENED.') 5735CCCCC ELSEIF(IERR.EQ.4)THEN 5736CCCCC WRITE(ICOUT,999) 5737CCCCC CALL DPWRST('XXX','BUG ') 5738CCCCC WRITE(ICOUT,1281) 5739CCCCC CALL DPWRST('XXX','BUG ') 5740CCCCC IERROR='YES' 5741CCCCC GOTO9000 5742C1281 FORMAT('***** ERROR IN DPSAPL--X11 NOT INSTALLED ON THIS ', 5743CCCCC1'IMPLEMENTATION.') 5744CCCCC ELSE 5745CCCCC WRITE(ICOUT,999) 5746CCCCC CALL DPWRST('XXX','BUG ') 5747CCCCC WRITE(ICOUT,1291) 5748CCCCC CALL DPWRST('XXX','BUG ') 5749CCCCC WRITE(ICOUT,1292)ISTRI2(1:NCSTR2) 5750CCCCC CALL DPWRST('XXX','BUG ') 5751CCCCC IERROR='YES' 5752CCCCC GOTO9000 5753C1291 FORMAT('***** CURRENT PIXMAP SUCCESSFULLY SAVED TO FILE ') 5754C1292 FORMAT(' ',A128) 5755CCCCC ENDIF 5756C 5757 IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'SAPL')THEN 5758 WRITE(ICOUT,1293)ISTRI2(1:MIN(128,NCSTR2)) 5759 1293 FORMAT('ISTRI2 = ',A128) 5760 CALL DPWRST('XXX','BUG ') 5761 WRITE(ICOUT,1294)NCSTR2 5762 1294 FORMAT('NCSTR2 = ',I4) 5763 CALL DPWRST('XXX','BUG ') 5764 ENDIF 5765C 5766C ***************** 5767C ** STEP 90-- ** 5768C ** EXIT. ** 5769C ***************** 5770C 5771 9000 CONTINUE 5772 IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'SAPL')THEN 5773 WRITE(ICOUT,999) 5774 CALL DPWRST('XXX','BUG ') 5775 WRITE(ICOUT,9011) 5776 9011 FORMAT('AT THE END OF DPSAPL--') 5777 CALL DPWRST('XXX','BUG ') 5778 WRITE(ICOUT,9012)IBUGS2,ISUBRO,IFOUND,IERROR 5779 9012 FORMAT('IBUGS2,ISUBRO,IFOUND,IERROR = ',3(A4,2X),A4) 5780 CALL DPWRST('XXX','BUG ') 5781 WRITE(ICOUT,9013)IWIDTH,NUMARG 5782 9013 FORMAT('IWIDTH,NUMARG = ',2I8) 5783 CALL DPWRST('XXX','BUG ') 5784 IF(IWIDTH.GE.1)THEN 5785 WRITE(ICOUT,9014)(IANSLC(I),I=1,IWIDTH) 5786 9014 FORMAT('(IANSLC(I),I=1,IWIDTH) = ',80A1) 5787 CALL DPWRST('XXX','BUG ') 5788 ENDIF 5789 IF(NUMARG.GE.1)THEN 5790 DO9016I=1,NUMARG 5791 WRITE(ICOUT,9017)I,IHARG(I) 5792 9017 FORMAT('I,IHARG(I) = ',I8,2X,A4) 5793 CALL DPWRST('XXX','BUG ') 5794 9016 CONTINUE 5795 ENDIF 5796 ENDIF 5797C 5798 RETURN 5799 END 5800 SUBROUTINE DPSAVE(IFOUND,IERROR) 5801C 5802C PURPOSE--SAVE (= WRITE OUT TO FILE) ALL INTERNAL DATAPLOT 5803C SETTINGS. THE MASS STORAGE FILE 5804C IS DESIGNATED BY THE ANALYST. 5805C THIS IS USEFUL WHEN A RUN MUST BE 5806C INTERRUPTED (E.G., LUNCH) (SEE THE SAVE COMMAND) 5807C AND IT IS DESIRED 5808C TO PICK UP THE RUN LATER AT THE POINT 5809C OF INTERRUPTION (SEE THE RESTORE COMMAND). 5810C NOTE--THE SAVE COMMAND (AND ITS COMPLEMENT, THE RESTORE COMMAND) 5811C BOTH USE UNFORMATTED FORTRAN I/O STATEMENTS 5812C (FOR SPEED AND EFFICIENCY). 5813C WRITTEN BY--JAMES J. FILLIBEN 5814C STATISTICAL ENGINEERING DIVISION 5815C INFORMATION TECHNOLOGY LABORATORY 5816C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5817C GAITHERSBURG, MD 20899-8980 5818C PHONE--301-975-2899 5819C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5820C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5821C LANGUAGE--ANSI FORTRAN (1977) 5822C VERSION NUMBER--86/1 5823C ORIGINAL VERSION--NOVEMBER 1980. 5824C UPDATED --JANUARY 1981. 5825C UPDATED --JUNE 1981. 5826C UPDATED --NOVEMBER 1981. 5827C UPDATED --JANUARY 1982. 5828C UPDATED --MARCH 1982. 5829C UPDATED --MAY 1982. 5830C UPDATED --DECEMBER 1985. 5831C UPDATED --JUNE 1986. 5832C UPDATED --NOVEMBER 1987. (DIMENSION FOR I1DATA--1100 TO 100) 5833C UPDATED --DECEMBER 1987. (DIMENSION FOR V--10000 TO MAXOBW) 5834C UPDATED --FEBRUARY 1989. SOFT-CODE ALL (ALAN) 5835C UPDATED --OCTOBER 1991. SUN HAS LIMIT ON # OF WORDS 5836C UPDATED FOR UNFORMATTED I/O (2,046) 5837C UPDATED --APRIL 1992. INCLUDE DPCO3D.INC (ALAN) 5838C UPDATED --APRIL 1992. PPEDHE TO APEDSZ (ALAN) 5839C 5840C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5841C 5842 INCLUDE 'DPCOPA.INC' 5843C 5844 CHARACTER*4 ISUBRO 5845 CHARACTER*4 IFOUND 5846 CHARACTER*4 IERROR 5847C 5848CCCCC CHARACTER*80 IFILE 5849 CHARACTER (LEN=MAXFNC) :: IFILE 5850 CHARACTER*12 ISTAT 5851 CHARACTER*12 IFORM 5852 CHARACTER*12 IACCES 5853 CHARACTER*12 IPROT 5854 CHARACTER*12 ICURST 5855 CHARACTER*4 IENDFI 5856 CHARACTER*4 IREWIN 5857 CHARACTER*4 ISUBN0 5858 CHARACTER*4 IERRFI 5859C 5860 CHARACTER*4 ISUBN1 5861 CHARACTER*4 ISUBN2 5862 CHARACTER*4 ISTEPN 5863C 5864CCCCC CHARACTER*80 ICANS 5865 CHARACTER (LEN=MAXSTR) :: ICANS 5866C 5867C-----COMMON---------------------------------------------------------- 5868C 5869 INCLUDE 'DPCOMC.INC' 5870 INCLUDE 'DPCODB.INC' 5871 INCLUDE 'DPCOHK.INC' 5872 INCLUDE 'DPCOPC.INC' 5873 INCLUDE 'DPCOSU.INC' 5874 INCLUDE 'DPCODA.INC' 5875 INCLUDE 'DPCOFO.INC' 5876 INCLUDE 'DPCOF2.INC' 5877 INCLUDE 'DPCOSO.INC' 5878 INCLUDE 'DPCOGR.INC' 5879 INCLUDE 'DPCONP.INC' 5880 INCLUDE 'DPCOHO.INC' 5881 INCLUDE 'DPCOTR.INC' 5882 INCLUDE 'DPCOBE.INC' 5883 INCLUDE 'DPCODG.INC' 5884 INCLUDE 'DPCOCO.INC' 5885C APRIL 1992. ADD FOLLOWING INCLUDE FILE. 5886 INCLUDE 'DPCO3D.INC' 5887 INCLUDE 'DPCOP2.INC' 5888C 5889C-----START POINT----------------------------------------------------- 5890C 5891 ISUBN1='DPSA' 5892 ISUBN2='VE ' 5893 ISUBRO='-999' 5894 IFOUND='YES' 5895 IERROR='NO' 5896C 5897 IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SAVE')GOTO90 5898 WRITE(ICOUT,999) 5899 999 FORMAT(1X) 5900 CALL DPWRST('XXX','BUG ') 5901 WRITE(ICOUT,51) 5902 51 FORMAT('***** AT THE BEGINNING OF DPSAVE--') 5903 CALL DPWRST('XXX','BUG ') 5904 WRITE(ICOUT,53)IBUGS2,ISUBRO,IERROR 5905 53 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) 5906 CALL DPWRST('XXX','BUG ') 5907 WRITE(ICOUT,54)IWIDTH 5908 54 FORMAT('IWIDTH = ',I8) 5909 CALL DPWRST('XXX','BUG ') 5910 IF(IWIDTH.GE.1)WRITE(ICOUT,55)(IANSLC(I),I=1,IWIDTH) 5911 55 FORMAT('(IANSLC(I),I=1,IWIDTH) = ',80A1) 5912 IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') 5913 WRITE(ICOUT,61)ISAVNU 5914 61 FORMAT('ISAVNU = ',I8) 5915 CALL DPWRST('XXX','BUG ') 5916 WRITE(ICOUT,62)ISAVNA 5917 62 FORMAT('ISAVNA = ',A80) 5918 CALL DPWRST('XXX','BUG ') 5919 WRITE(ICOUT,63)ISAVST 5920 63 FORMAT('ISAVST = ',A12) 5921 CALL DPWRST('XXX','BUG ') 5922 WRITE(ICOUT,64)ISAVFO 5923 64 FORMAT('ISAVFO = ',A12) 5924 CALL DPWRST('XXX','BUG ') 5925 WRITE(ICOUT,65)ISAVAC 5926 65 FORMAT('ISAVAC = ',A12) 5927 CALL DPWRST('XXX','BUG ') 5928 WRITE(ICOUT,66)ISAVFO 5929 66 FORMAT('ISAVFO = ',A12) 5930 CALL DPWRST('XXX','BUG ') 5931 WRITE(ICOUT,67)ISAVCS 5932 67 FORMAT('ISAVCS = ',A12) 5933 CALL DPWRST('XXX','BUG ') 5934 90 CONTINUE 5935C 5936C ************************** 5937C ** STEP 11-- ** 5938C ** COPY OVER VARIABLES ** 5939C ************************** 5940C 5941 ISTEPN='11' 5942 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAVE') 5943 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5944C 5945 IOUNIT=ISAVNU 5946 IFILE=ISAVNA 5947 ISTAT=ISAVST 5948 IFORM=ISAVFO 5949 IACCES=ISAVAC 5950 IPROT=ISAVPR 5951 ICURST=ISAVCS 5952C 5953 ISUBN0='SAVE' 5954 IERRFI='NO' 5955C 5956 IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SAVE')GOTO1199 5957 WRITE(ICOUT,1193)IOUNIT 5958 1193 FORMAT('IOUNIT = ',I8) 5959 CALL DPWRST('XXX','BUG ') 5960 WRITE(ICOUT,1194)IFILE 5961 1194 FORMAT('IFILE = ',A80) 5962 CALL DPWRST('XXX','BUG ') 5963 WRITE(ICOUT,1195)ISTAT,IFORM,IACCES,IPROT,ICURST 5964 1195 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ', 5965 1A12,2X,A12,2X,A12,2X,A12,2X,A12) 5966 CALL DPWRST('XXX','BUG ') 5967 WRITE(ICOUT,1196)ISUBN0,IERRFI 5968 1196 FORMAT('ISUBN0,IERRFI = ',A4,2X,A4) 5969 CALL DPWRST('XXX','BUG ') 5970 1199 CONTINUE 5971C 5972C ******************************************* 5973C ** STEP 12-- ** 5974C ** CHECK TO SEE IF SAVE FILE MAY EXIST ** 5975C ******************************************* 5976C 5977 ISTEPN='12' 5978 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAVE') 5979 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5980C 5981 IF(ISTAT.EQ.'NONE')GOTO1200 5982 GOTO1290 5983 1200 CONTINUE 5984 IERROR='YES' 5985 WRITE(ICOUT,999) 5986 CALL DPWRST('XXX','BUG ') 5987 WRITE(ICOUT,1211) 5988 1211 FORMAT('***** ERROR IN DPSAVE--') 5989 CALL DPWRST('XXX','BUG ') 5990 WRITE(ICOUT,1212) 5991 1212 FORMAT(' THE DESIRED SAVE') 5992 CALL DPWRST('XXX','BUG ') 5993 WRITE(ICOUT,1213) 5994 1213 FORMAT(' CANNOT BE GIVEN BECAUSE') 5995 CALL DPWRST('XXX','BUG ') 5996 WRITE(ICOUT,1214) 5997 1214 FORMAT(' THE REQUIRED SYSTEM MASS STORAGE FILE') 5998 CALL DPWRST('XXX','BUG ') 5999 WRITE(ICOUT,1215) 6000 1215 FORMAT(' WHICH STORES SUCH SAVE') 6001 CALL DPWRST('XXX','BUG ') 6002 WRITE(ICOUT,1216) 6003 1216 FORMAT(' IS NOT AVAILABLE AT THIS INSTALLATION.') 6004 CALL DPWRST('XXX','BUG ') 6005 WRITE(ICOUT,1217)ISTAT,ISAVST 6006 1217 FORMAT('ISTAT,ISAVST = ',A12,2X,A12) 6007 CALL DPWRST('XXX','BUG ') 6008 GOTO9000 6009 1290 CONTINUE 6010C 6011C **************************** 6012C ** STEP 13-- ** 6013C ** EXTRACT THE FILE NAME ** 6014C ** (THE THIRD WORD) ** 6015C **************************** 6016C 6017 ISTEPN='13' 6018 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAVE') 6019 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6020C 6021 DO1310I=1,80 6022 IFILE(I:I)=' ' 6023 1310 CONTINUE 6024C 6025 DO1320I=1,80 6026 ICANS(I:I)=IANSLC(I) 6027 1320 CONTINUE 6028C 6029 ISTART=1 6030 ISTOP=IWIDTH 6031 IF(NUMARG.LE.1) 6032 1CALL DPW280(ICANS,ISTART,ISTOP,ICOL3,IBUGS2,ISUBRO,IERROR) 6033 IF(NUMARG.GE.2) 6034 1CALL DPW380(ICANS,ISTART,ISTOP,ICOL3,IBUGS2,ISUBRO,IERROR) 6035 IF(IERROR.EQ.'YES')GOTO9000 6036C 6037 J=0 6038 IF(ICOL3.GT.IWIDTH)GOTO1339 6039 DO1330I=ICOL3,IWIDTH 6040 J=J+1 6041 IFILE(J:J)=ICANS(I:I) 6042 1330 CONTINUE 6043 1339 CONTINUE 6044C 6045 NMAX=80 6046 CALL DPDB80(IFILE,JMAX,NMAX,IBUGS2,ISUBRO,IERROR) 6047 IF(IERROR.EQ.'YES')GOTO9000 6048 NCFILE=JMAX 6049C 6050 IF(NCFILE.GE.1)GOTO1349 6051 IERROR='YES' 6052 WRITE(ICOUT,999) 6053 CALL DPWRST('XXX','BUG ') 6054 WRITE(ICOUT,1341) 6055 1341 FORMAT('***** ERROR IN DPSAVE--') 6056 CALL DPWRST('XXX','BUG ') 6057 WRITE(ICOUT,1342) 6058 1342 FORMAT(' A FILE NAME IS REQUIRED') 6059 CALL DPWRST('XXX','BUG ') 6060 WRITE(ICOUT,1343) 6061 1343 FORMAT(' IN THE SAVE COMMAND') 6062 CALL DPWRST('XXX','BUG ') 6063 WRITE(ICOUT,1344) 6064 1344 FORMAT(' (FOR EXAMPLE, SAVE MEMORY DPRUN.DAT)') 6065 CALL DPWRST('XXX','BUG ') 6066 WRITE(ICOUT,1345) 6067 1345 FORMAT(' BUT NONE WAS GIVEN HERE.') 6068 CALL DPWRST('XXX','BUG ') 6069 WRITE(ICOUT,1346) 6070 1346 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') 6071 CALL DPWRST('XXX','BUG ') 6072 IF(IWIDTH.GE.1)WRITE(ICOUT,1347)(IANSLC(I),I=1,IWIDTH) 6073 1347 FORMAT(' ',80A1) 6074 IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') 6075 IF(IWIDTH.LE.0)WRITE(ICOUT,999) 6076 IF(IWIDTH.LE.0)CALL DPWRST('XXX','BUG ') 6077 GOTO9000 6078 1349 CONTINUE 6079C 6080C ********************* 6081C ** STEP 31-- ** 6082C ** OPEN THE FILE ** 6083C ********************* 6084C 6085 ISTEPN='31' 6086 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAVE') 6087 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6088C 6089 IREWIN='ON' 6090 CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 6091 1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 6092 IF(IERRFI.EQ.'YES')GOTO9000 6093C 6094C ******************************************************** 6095C ** STEP 41- ** 6096C ** WRITE OUT TO THE SAVE FILE; ** 6097C ******************************************************** 6098C 6099 ISTEPN='41' 6100 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAVE') 6101 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6102C 6103C -----BEGIN WRITING OUT----------------------- 6104C 6105C -----WRITE OUT COMMON FOR STANDARD I/O----- 6106C 6107 WRITE(IOUNIT)IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW 6108 WRITE(IOUNIT)IFEEDB,IPRINT 6109C 6110C -----WRITE OUT COMMON FOR MACHINE CONSTANTS----- 6111C 6112 WRITE(IOUNIT)(I1MACH(I),I=1,16) 6113 WRITE(IOUNIT)(R1MACH(I),I=1,5) 6114 WRITE(IOUNIT)(D1MACH(I),I=1,5) 6115C 6116C -----WRITE OUT COMMON FOR BUGS----- 6117C 6118 WRITE(IOUNIT)(I1BUG(I),I=1,10) 6119 WRITE(IOUNIT)(IH1BUG(I),I=1,100) 6120C 6121C -----WRITE OUT COMMON FOR HOUSEKEEPING----- 6122C 6123C WRITE(IOUNIT)(I1HOUS(I),I=1,1050) 6124 WRITE(IOUNIT)(I1HOUS(I),I=1,5*MAXSTR+50) 6125C WRITE(IOUNIT)(IH1HOU(I),I=1,2320) 6126 WRITE(IOUNIT)(IH1HOU(I),I=1,11*MAXSTR+120) 6127C WRITE(IOUNIT)(R1HOUS(I),I=1,400) 6128 WRITE(IOUNIT)(R1HOUS(I),I=1,2*MAXSTR) 6129C 6130C -----WRITE OUT COMMON FOR DATA----- 6131C 6132C OCTOBER 1991. FOLLOWING BLOCK OF CODE HEAVILY MODIFIED TO HANDLE 6133C PROBLEM ON SUN. SUN APPEARS TO LIMIT UNFORMATTED I/O TO 2,046 WORDS. 6134C NEED TO BREAK INTO CHUNKS FOR MANY OF THESE WRITE OPERATIONS. 6135C 6136 MAXWRD=100000 6137 IF(IHOST1.EQ.'SUN')MAXWRD=2046 6138 NLOOP1=(MAXOBV/MAXWRD)+1 6139 NLOOP2=(MAXPOP/MAXWRD)+1 6140 NLOOP3=(MAXOBW/MAXWRD)+1 6141C 6142CCCC WRITE(IOUNIT)(I1DATA(I),I=1,1100) 6143CCCCC WRITE(IOUNIT)(I1DATA(I),I=1,MAXOBS+100) 6144 WRITE(IOUNIT)(I1DATA(I),I=1,100) 6145CCCCC WRITE(IOUNIT)(ISUB(I),I=1,MAXOBV) 6146 DO9112IK=1,NLOOP1 6147 JSTART=(IK-1)*MAXWRD+1 6148 IF(JSTART.GT.MAXOBV)GOTO9117 6149 JSTOP=IK*MAXWRD 6150 IF(JSTOP.GT.MAXOBV)JSTOP=MAXOBV 6151 WRITE(IOUNIT)(ISUB(I),I=JSTART,JSTOP) 6152 9112 CONTINUE 6153 9117 CONTINUE 6154CCCCC WRITE(IOUNIT)(IH1DAT(I),I=1,3500) 6155CCCCC WRITE(IOUNIT)(IH1DAT(I),I=1,3*MAXF1+3*MAXFN2+MAXF3) 6156 WRITE(IOUNIT)(IPARNC(I),I=1,MAXFN2) 6157 WRITE(IOUNIT)(IPANC2(I),I=1,MAXFN2) 6158 WRITE(IOUNIT)(IPAROP(I),I=1,MAXFN2) 6159 WRITE(IOUNIT)(MODEL(I),I=1,MAXF3) 6160 WRITE(IOUNIT)(IFUNC(I),I=1,MAXF1) 6161 WRITE(IOUNIT)(IFUNC2(I),I=1,MAXF1) 6162 WRITE(IOUNIT)(IFUNC3(I),I=1,MAXF1) 6163CCCCC WRITE(IOUNIT)(R1DATA(I),I=1,10200) 6164CCCCC WRITE(IOUNIT)(R1DATA(I),I=1,42200) 6165 WRITE(IOUNIT)(PARLIM(I),I=1,100) 6166CCCCC WRITE(IOUNIT)(PRED(I),I=1,MAXOBV) 6167 DO9122IK=1,NLOOP1 6168 JSTART=(IK-1)*MAXWRD+1 6169 IF(JSTART.GT.MAXOBV)GOTO9127 6170 JSTOP=IK*MAXWRD 6171 IF(JSTOP.GT.MAXOBV)JSTOP=MAXOBV 6172 WRITE(IOUNIT)(PRED(I),I=JSTART,JSTOP) 6173 9122 CONTINUE 6174 9127 CONTINUE 6175CCCCC WRITE(IOUNIT)(RES(I),I=1,MAXOBV) 6176 DO9132IK=1,NLOOP1 6177 JSTART=(IK-1)*MAXWRD+1 6178 IF(JSTART.GT.MAXOBV)GOTO9137 6179 JSTOP=IK*MAXWRD 6180 IF(JSTOP.GT.MAXOBV)JSTOP=MAXOBV 6181 WRITE(IOUNIT)(RES(I),I=JSTART,JSTOP) 6182 9132 CONTINUE 6183 9137 CONTINUE 6184CCCCC WRITE(IOUNIT)(Y(I),I=1,MAXPOP) 6185 DO9142IK=1,NLOOP2 6186 JSTART=(IK-1)*MAXWRD+1 6187 IF(JSTART.GT.MAXPOP)GOTO9147 6188 JSTOP=IK*MAXWRD 6189 IF(JSTOP.GT.MAXPOP)JSTOP=MAXPOP 6190 WRITE(IOUNIT)(Y(I),I=JSTART,JSTOP) 6191 9142 CONTINUE 6192 9147 CONTINUE 6193CCCCC WRITE(IOUNIT)(X(I),I=1,MAXPOP) 6194 DO9152IK=1,NLOOP2 6195 JSTART=(IK-1)*MAXWRD+1 6196 IF(JSTART.GT.MAXPOP)GOTO9157 6197 JSTOP=IK*MAXWRD 6198 IF(JSTOP.GT.MAXPOP)JSTOP=MAXPOP 6199 WRITE(IOUNIT)(X(I),I=JSTART,JSTOP) 6200 9152 CONTINUE 6201 9157 CONTINUE 6202CCCCC WRITE(IOUNIT)(X3D(I),I=1,MAXPOP) 6203 DO9162IK=1,NLOOP2 6204 JSTART=(IK-1)*MAXWRD+1 6205 IF(JSTART.GT.MAXPOP)GOTO9167 6206 JSTOP=IK*MAXWRD 6207 IF(JSTOP.GT.MAXPOP)JSTOP=MAXPOP 6208 WRITE(IOUNIT)(X3D(I),I=JSTART,JSTOP) 6209 9162 CONTINUE 6210 9167 CONTINUE 6211CCCCC WRITE(IOUNIT)(D(I),I=1,MAXPOP) 6212 DO9172IK=1,NLOOP2 6213 JSTART=(IK-1)*MAXWRD+1 6214 IF(JSTART.GT.MAXPOP)GOTO9177 6215 JSTOP=IK*MAXWRD 6216 IF(JSTOP.GT.MAXPOP)JSTOP=MAXPOP 6217 WRITE(IOUNIT)(D(I),I=JSTART,JSTOP) 6218 9172 CONTINUE 6219 9177 CONTINUE 6220CCCCC WRITE(IOUNIT)(YPLOT(I),I=1,MAXPOP) 6221 DO9182IK=1,NLOOP2 6222 JSTART=(IK-1)*MAXWRD+1 6223 IF(JSTART.GT.MAXPOP)GOTO9187 6224 JSTOP=IK*MAXWRD 6225 IF(JSTOP.GT.MAXPOP)JSTOP=MAXPOP 6226 WRITE(IOUNIT)(YPLOT(I),I=JSTART,JSTOP) 6227 9182 CONTINUE 6228 9187 CONTINUE 6229CCCCC WRITE(IOUNIT)(XPLOT(I),I=1,MAXPOP) 6230 DO9192IK=1,NLOOP2 6231 JSTART=(IK-1)*MAXWRD+1 6232 IF(JSTART.GT.MAXPOP)GOTO9197 6233 JSTOP=IK*MAXWRD 6234 IF(JSTOP.GT.MAXPOP)JSTOP=MAXPOP 6235 WRITE(IOUNIT)(XPLOT(I),I=JSTART,JSTOP) 6236 9192 CONTINUE 6237 9197 CONTINUE 6238CCCCC WRITE(IOUNIT)(X2PLOT(I),I=1,MAXPOP) 6239 DO9212IK=1,NLOOP2 6240 JSTART=(IK-1)*MAXWRD+1 6241 IF(JSTART.GT.MAXPOP)GOTO9217 6242 JSTOP=IK*MAXWRD 6243 IF(JSTOP.GT.MAXPOP)JSTOP=MAXPOP 6244 WRITE(IOUNIT)(X2PLOT(I),I=JSTART,JSTOP) 6245 9212 CONTINUE 6246 9217 CONTINUE 6247CCCCC WRITE(IOUNIT)(TAGPLO(I),I=1,MAXPOP) 6248 DO9222IK=1,NLOOP2 6249 JSTART=(IK-1)*MAXWRD+1 6250 IF(JSTART.GT.MAXPOP)GOTO9227 6251 JSTOP=IK*MAXWRD 6252 IF(JSTOP.GT.MAXPOP)JSTOP=MAXPOP 6253 WRITE(IOUNIT)(TAGPLO(I),I=JSTART,JSTOP) 6254 9222 CONTINUE 6255 9227 CONTINUE 6256CCCCC WRITE(IOUNIT)(V(I),I=1,MAXOBW) 6257 DO9232IK=1,NLOOP3 6258 JSTART=(IK-1)*MAXWRD+1 6259 IF(JSTART.GT.MAXOBW)GOTO9237 6260 JSTOP=IK*MAXWRD 6261 IF(JSTOP.GT.MAXOBW)JSTOP=MAXOBW 6262 WRITE(IOUNIT)(V(I),I=JSTART,JSTOP) 6263 9232 CONTINUE 6264 9237 CONTINUE 6265CCCCC WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=1,100) 6266 ITEMP=100*100 6267 IF(ITEMP.LE.MAXWRD)THEN 6268 WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=1,100) 6269 ELSE 6270 WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=1,10) 6271 WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=11,20) 6272 WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=21,30) 6273 WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=31,40) 6274 WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=41,50) 6275 WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=51,60) 6276 WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=61,70) 6277 WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=71,80) 6278 WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=81,90) 6279 WRITE(IOUNIT)((AMATR1(I,J),I=1,100),J=91,100) 6280 END IF 6281CCCCC WRITE(IOUNIT)(R1DATA(I),I=1,2*MAXOBS+8*MAXPLP+200) 6282CCCCC WRITE(IOUNIT)(V(I),I=1,10000) 6283CCCCC WRITE(IOUNIT)(V(I),I=1,MAXWS) 6284C 6285C -----WRITE OUT COMMON FOR SUPPORT----- 6286C 6287 WRITE(IOUNIT)(I1SUPP(I),I=1,50) 6288 WRITE(IOUNIT)(IH1SUP(I),I=1,70) 6289 WRITE(IOUNIT)(R1SUPP(I),I=1,60) 6290C 6291C -----WRITE OUT COMMON FOR SUBFILE I/O (UNIVAC ONLY)----- 6292C 6293 WRITE(IOUNIT)(IBUF(I),I=1,504) 6294C 6295C -----WRITE OUT COMMON FOR DIAGRAMMATIC GRAPHICS----- 6296C 6297 WRITE(IOUNIT)(IH1DIA(I),I=1,40) 6298 WRITE(IOUNIT)(R1DIAG(I),I=1,40) 6299C 6300C -----WRITE OUT COMMON FOR COLOR----- 6301C 6302 WRITE(IOUNIT)ICOLOR 6303 WRITE(IOUNIT)IPLOTF 6304C 6305C -----WRITE OUT COMMON FOR BUGS AND ERROR----- 6306C 6307 WRITE(IOUNIT)IBUGG4 6308 WRITE(IOUNIT)ISUBG4 6309 WRITE(IOUNIT)IERRG4 6310C 6311C -----WRITE OUT COMMON FOR HOST----- 6312C 6313 WRITE(IOUNIT)IHOST1 6314 WRITE(IOUNIT)IHOST2 6315 WRITE(IOUNIT)IHMOD1 6316 WRITE(IOUNIT)IHMOD2 6317 WRITE(IOUNIT)IOPSY1 6318 WRITE(IOUNIT)IOPSY2 6319 WRITE(IOUNIT)ICOMPI 6320 WRITE(IOUNIT)ISITE 6321C 6322C -----WRITE OUT COMMON FOR TRANSLATOR----- 6323C 6324 WRITE(IOUNIT)ITRANS 6325 WRITE(IOUNIT)NCTRA1 6326 WRITE(IOUNIT)NCTRA2 6327 WRITE(IOUNIT)NUMTRA 6328 WRITE(IOUNIT)ICTRA1 6329 WRITE(IOUNIT)ICTRA2 6330C 6331C -----WRITE OUT COMMON FOR NON-PRINTING CHARACTERS----- 6332C 6333 WRITE(IOUNIT)INULC 6334 WRITE(IOUNIT)ISOHC 6335 WRITE(IOUNIT)ISTXC 6336 WRITE(IOUNIT)IETXC 6337 WRITE(IOUNIT)IEOTC 6338 WRITE(IOUNIT)IENQC 6339 WRITE(IOUNIT)IACKC 6340 WRITE(IOUNIT)IBELC 6341 WRITE(IOUNIT)IBSC 6342 WRITE(IOUNIT)IHTC 6343 WRITE(IOUNIT)ILFC 6344 WRITE(IOUNIT)IVTC 6345 WRITE(IOUNIT)IFFC 6346 WRITE(IOUNIT)ICRC 6347 WRITE(IOUNIT)ISOC 6348 WRITE(IOUNIT)ISIC 6349 WRITE(IOUNIT)IDLEC 6350 WRITE(IOUNIT)IDC1C 6351 WRITE(IOUNIT)IDC2C 6352 WRITE(IOUNIT)IDC3C 6353 WRITE(IOUNIT)IDC4C 6354 WRITE(IOUNIT)INAKC 6355 WRITE(IOUNIT)ISYNC 6356 WRITE(IOUNIT)IETBC 6357 WRITE(IOUNIT)ICANC 6358 WRITE(IOUNIT)IEMC 6359 WRITE(IOUNIT)ISUBC 6360 WRITE(IOUNIT)IESCC 6361 WRITE(IOUNIT)IFSC 6362 WRITE(IOUNIT)IGSC 6363 WRITE(IOUNIT)IRSC 6364 WRITE(IOUNIT)IUSC 6365C 6366C -----WRITE OUT COMMON FOR GRAPHICS----- 6367C 6368 WRITE(IOUNIT)IMANUF 6369 WRITE(IOUNIT)IMODEL 6370 WRITE(IOUNIT)IMODE2 6371 WRITE(IOUNIT)IMODE3 6372 WRITE(IOUNIT)IGCODE 6373 WRITE(IOUNIT)IGUNIT 6374 WRITE(IOUNIT)IGCONT 6375 WRITE(IOUNIT)NUMHPP 6376 WRITE(IOUNIT)NUMVPP 6377 WRITE(IOUNIT)ANUMHP 6378 WRITE(IOUNIT)ANUMVP 6379 WRITE(IOUNIT)IGCOLO 6380 WRITE(IOUNIT)IGBAUD 6381 WRITE(IOUNIT)AGERDE 6382 WRITE(IOUNIT)AGCODE 6383 WRITE(IOUNIT)ISOFT 6384 WRITE(IOUNIT)ISOFT2 6385 WRITE(IOUNIT)ISOFT3 6386C 6387C -----WRITE OUT COMMON FOR FILE OPERATIONS----- 6388C 6389 WRITE(IOUNIT)(I1FILO(I),I=1,10) 6390 WRITE(IOUNIT)(IH1FIL(I),I=1,200) 6391C 6392C -----WRITE OUT COMMON FOR FILE OPERATIONS, PART 2----- 6393C 6394 WRITE(IOUNIT)IMESNU 6395 WRITE(IOUNIT)IMESNA 6396 WRITE(IOUNIT)IMESST 6397 WRITE(IOUNIT)IMESFO 6398 WRITE(IOUNIT)IMESAC 6399 WRITE(IOUNIT)IMESPR 6400 WRITE(IOUNIT)IMESCS 6401C 6402 WRITE(IOUNIT)INEWNU 6403 WRITE(IOUNIT)INEWNA 6404 WRITE(IOUNIT)INEWST 6405 WRITE(IOUNIT)INEWFO 6406 WRITE(IOUNIT)INEWAC 6407 WRITE(IOUNIT)INEWPR 6408 WRITE(IOUNIT)INEWCS 6409C 6410 WRITE(IOUNIT)IMAINU 6411 WRITE(IOUNIT)IMAINA 6412 WRITE(IOUNIT)IMAIST 6413 WRITE(IOUNIT)IMAIFO 6414 WRITE(IOUNIT)IMAIAC 6415 WRITE(IOUNIT)IMAIPR 6416 WRITE(IOUNIT)IMAICS 6417C 6418 WRITE(IOUNIT)IHELNU 6419 WRITE(IOUNIT)IHELNA 6420 WRITE(IOUNIT)IHELST 6421 WRITE(IOUNIT)IHELFO 6422 WRITE(IOUNIT)IHELAC 6423 WRITE(IOUNIT)IHELPR 6424 WRITE(IOUNIT)IHELCS 6425C 6426 WRITE(IOUNIT)IBUGNU 6427 WRITE(IOUNIT)IBUGNA 6428 WRITE(IOUNIT)IBUGST 6429 WRITE(IOUNIT)IBUGFO 6430 WRITE(IOUNIT)IBUGAC 6431 WRITE(IOUNIT)IBUGPR 6432 WRITE(IOUNIT)IBUGCS 6433C 6434 WRITE(IOUNIT)IQUENU 6435 WRITE(IOUNIT)IQUENA 6436 WRITE(IOUNIT)IQUEST 6437 WRITE(IOUNIT)IQUEFO 6438 WRITE(IOUNIT)IQUEAC 6439 WRITE(IOUNIT)IQUEPR 6440 WRITE(IOUNIT)IQUECS 6441C 6442 WRITE(IOUNIT)ILOGNU 6443 WRITE(IOUNIT)ILOGNA 6444 WRITE(IOUNIT)ILOGST 6445 WRITE(IOUNIT)ILOGFO 6446 WRITE(IOUNIT)ILOGAC 6447 WRITE(IOUNIT)ILOGPR 6448 WRITE(IOUNIT)ILOGCS 6449C 6450 WRITE(IOUNIT)IREANU 6451 WRITE(IOUNIT)IREANA 6452 WRITE(IOUNIT)IREAST 6453 WRITE(IOUNIT)IREAFO 6454 WRITE(IOUNIT)IREAAC 6455 WRITE(IOUNIT)IREAPR 6456 WRITE(IOUNIT)IREACS 6457C 6458 WRITE(IOUNIT)IWRINU 6459 WRITE(IOUNIT)IWRINA 6460 WRITE(IOUNIT)IWRIST 6461 WRITE(IOUNIT)IWRIFO 6462 WRITE(IOUNIT)IWRIAC 6463 WRITE(IOUNIT)IWRIPR 6464 WRITE(IOUNIT)IWRICS 6465C 6466 WRITE(IOUNIT)ISAVNU 6467 WRITE(IOUNIT)ISAVNA 6468 WRITE(IOUNIT)ISAVST 6469 WRITE(IOUNIT)ISAVFO 6470 WRITE(IOUNIT)ISAVAC 6471 WRITE(IOUNIT)ISAVPR 6472 WRITE(IOUNIT)ISAVCS 6473C 6474 WRITE(IOUNIT)ILISNU 6475 WRITE(IOUNIT)ILISNA 6476 WRITE(IOUNIT)ILISST 6477 WRITE(IOUNIT)ILISFO 6478 WRITE(IOUNIT)ILISAC 6479 WRITE(IOUNIT)ILISPR 6480 WRITE(IOUNIT)ILISCS 6481C 6482 WRITE(IOUNIT)ICRENU 6483 WRITE(IOUNIT)ICRENA 6484 WRITE(IOUNIT)ICREST 6485 WRITE(IOUNIT)ICREFO 6486 WRITE(IOUNIT)ICREAC 6487 WRITE(IOUNIT)ICREPR 6488 WRITE(IOUNIT)ICRECS 6489C 6490 WRITE(IOUNIT)ISCRNU 6491 WRITE(IOUNIT)ISCRNA 6492 WRITE(IOUNIT)ISCRST 6493 WRITE(IOUNIT)ISCRFO 6494 WRITE(IOUNIT)ISCRAC 6495 WRITE(IOUNIT)ISCRPR 6496 WRITE(IOUNIT)ISCRCS 6497C 6498 WRITE(IOUNIT)IDATNU 6499 WRITE(IOUNIT)IDATNA 6500 WRITE(IOUNIT)IDATST 6501 WRITE(IOUNIT)IDATFO 6502 WRITE(IOUNIT)IDATAC 6503 WRITE(IOUNIT)IDATPR 6504 WRITE(IOUNIT)IDATCS 6505C 6506 WRITE(IOUNIT)IPL1NU 6507 WRITE(IOUNIT)IPL1NA 6508 WRITE(IOUNIT)IPL1ST 6509 WRITE(IOUNIT)IPL1FO 6510 WRITE(IOUNIT)IPL1AC 6511 WRITE(IOUNIT)IPL1PR 6512 WRITE(IOUNIT)IPL1CS 6513C 6514 WRITE(IOUNIT)IPL2NU 6515 WRITE(IOUNIT)IPL2NA 6516 WRITE(IOUNIT)IPL2ST 6517 WRITE(IOUNIT)IPL2FO 6518 WRITE(IOUNIT)IPL2AC 6519 WRITE(IOUNIT)IPL2PR 6520 WRITE(IOUNIT)IPL2CS 6521C 6522 WRITE(IOUNIT)IPRONU 6523 WRITE(IOUNIT)IPRONA 6524 WRITE(IOUNIT)IPROST 6525 WRITE(IOUNIT)IPROFO 6526 WRITE(IOUNIT)IPROAC 6527 WRITE(IOUNIT)IPROPR 6528 WRITE(IOUNIT)IPROCS 6529C 6530 WRITE(IOUNIT)ICONNU 6531 WRITE(IOUNIT)ICONNA 6532 WRITE(IOUNIT)ICONST 6533 WRITE(IOUNIT)ICONFO 6534 WRITE(IOUNIT)ICONAC 6535 WRITE(IOUNIT)ICONPR 6536 WRITE(IOUNIT)ICONCS 6537C 6538 WRITE(IOUNIT)ISACNU 6539 WRITE(IOUNIT)ISACNA 6540 WRITE(IOUNIT)ISACST 6541 WRITE(IOUNIT)ISACFO 6542 WRITE(IOUNIT)ISACAC 6543 WRITE(IOUNIT)ISACPR 6544 WRITE(IOUNIT)ISACCS 6545C 6546 WRITE(IOUNIT)IEX1NU 6547 WRITE(IOUNIT)IEX1NA 6548 WRITE(IOUNIT)IEX1ST 6549 WRITE(IOUNIT)IEX1FO 6550 WRITE(IOUNIT)IEX1AC 6551 WRITE(IOUNIT)IEX1PR 6552 WRITE(IOUNIT)IEX1CS 6553C 6554 WRITE(IOUNIT)IEX2NU 6555 WRITE(IOUNIT)IEX2NA 6556 WRITE(IOUNIT)IEX2ST 6557 WRITE(IOUNIT)IEX2FO 6558 WRITE(IOUNIT)IEX2AC 6559 WRITE(IOUNIT)IEX2PR 6560 WRITE(IOUNIT)IEX2CS 6561C 6562 WRITE(IOUNIT)IEX3NU 6563 WRITE(IOUNIT)IEX3NA 6564 WRITE(IOUNIT)IEX3ST 6565 WRITE(IOUNIT)IEX3FO 6566 WRITE(IOUNIT)IEX3AC 6567 WRITE(IOUNIT)IEX3PR 6568 WRITE(IOUNIT)IEX3CS 6569C 6570 WRITE(IOUNIT)IEX4NU 6571 WRITE(IOUNIT)IEX4NA 6572 WRITE(IOUNIT)IEX4ST 6573 WRITE(IOUNIT)IEX4FO 6574 WRITE(IOUNIT)IEX4AC 6575 WRITE(IOUNIT)IEX4PR 6576 WRITE(IOUNIT)IEX4CS 6577C 6578 WRITE(IOUNIT)IEX5NU 6579 WRITE(IOUNIT)IEX5NA 6580 WRITE(IOUNIT)IEX5ST 6581 WRITE(IOUNIT)IEX5FO 6582 WRITE(IOUNIT)IEX5AC 6583 WRITE(IOUNIT)IEX5PR 6584 WRITE(IOUNIT)IEX5CS 6585C 6586 WRITE(IOUNIT)IFCHAR 6587C 6588C -----WRITE OUT COMMON FOR PLOT CONTROL----- 6589C 6590 WRITE(IOUNIT)(IDMANU(I),I=1,MAXDV) 6591 WRITE(IOUNIT)(IDMODE(I),I=1,MAXDV) 6592 WRITE(IOUNIT)(IDMOD2(I),I=1,MAXDV) 6593 WRITE(IOUNIT)(IDMOD3(I),I=1,MAXDV) 6594 WRITE(IOUNIT)(IDPOWE(I),I=1,MAXDV) 6595 WRITE(IOUNIT)(IDCONT(I),I=1,MAXDV) 6596 WRITE(IOUNIT)(IDCOLO(I),I=1,MAXDV) 6597 WRITE(IOUNIT)(IDSCRE(I),I=1,MAXDV) 6598 WRITE(IOUNIT)(IDSCRO(I),I=1,MAXDV) 6599 WRITE(IOUNIT)(IDPAER(I),I=1,MAXDV) 6600 WRITE(IOUNIT)(IDSEGM(I),I=1,MAXDV) 6601 WRITE(IOUNIT)(IDSOFT(I),I=1,MAXDV) 6602 WRITE(IOUNIT)(IDSOF2(I),I=1,MAXDV) 6603 WRITE(IOUNIT)(IDSOF3(I),I=1,MAXDV) 6604C 6605 WRITE(IOUNIT)(IDCODE(I),I=1,MAXDV) 6606 WRITE(IOUNIT)(IDUNIT(I),I=1,MAXDV) 6607 WRITE(IOUNIT)(IDNHPP(I),I=1,MAXDV) 6608 WRITE(IOUNIT)(IDNVPP(I),I=1,MAXDV) 6609 WRITE(IOUNIT)(IDBAUD(I),I=1,MAXDV) 6610 WRITE(IOUNIT)NUMDEV,MAXDEV 6611C 6612 WRITE(IOUNIT)IERASW,IBELSW,ISORSW,ICOPSW 6613 WRITE(IOUNIT)IPENSW 6614 WRITE(IOUNIT)IBACCO,IMARCO 6615 WRITE(IOUNIT)IDEFXC,IDEFBK,IDEFMC,IDEPEC 6616 WRITE(IOUNIT)ISEQSW 6617 WRITE(IOUNIT)IFENSW 6618 WRITE(IOUNIT)INEGSW 6619 WRITE(IOUNIT)IVISSW,IPEDSW,IPEDCO 6620 WRITE(IOUNIT)IDEFMA,IDEFMO,IDEFM2,IDEFM3 6621 WRITE(IOUNIT)IDEFPO,IDEFCN,IDEFDC 6622C 6623 WRITE(IOUNIT)NUMRIN,NUMCOP 6624 WRITE(IOUNIT)NUMSEQ 6625 WRITE(IOUNIT)IDEFVP,IDEFHP,IDEFUN 6626C 6627 WRITE(IOUNIT)BAWIDT,BARSPA,DEFBAS 6628 WRITE(IOUNIT)AORIXC,AORIYC,AORIZC 6629 WRITE(IOUNIT)AEYEXC,AEYEYC,AEYEZC 6630CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1992 (ALAN) 6631CCCCC WRITE(IOUNIT)PPEDHE 6632 WRITE(IOUNIT)APEDSZ 6633 WRITE(IOUNIT)DEFSZ,DEFTL 6634C 6635 WRITE(IOUNIT)IGRASW 6636C 6637 WRITE(IOUNIT)PGRAXO,PGRAYO,PGRAXC,PGRAYC,PGRAXN,PGRAYN 6638 WRITE(IOUNIT)PMARXC 6639 WRITE(IOUNIT)PGRAXF,PGRAYF 6640 WRITE(IOUNIT)PCROXC,PCROYC 6641C 6642 WRITE(IOUNIT)IDIASW 6643C 6644 WRITE(IOUNIT)PDIAXC,PDIAYC,PDIAX2,PDIAY2 6645 WRITE(IOUNIT)PDIAHE,PDIAWI,PDIAVG,PDIAHG 6646C 6647 WRITE(IOUNIT)PWXMIN,PWXMAX,PWYMIN,PWYMAX 6648 WRITE(IOUNIT)WWXMIN,WWXMAX,WWYMIN,WWYMAX 6649C 6650 WRITE(IOUNIT)IX1MIN,IX1MAX,IY1MIN,IY1MAX 6651 WRITE(IOUNIT)IX2MIN,IX2MAX,IY2MIN,IY2MAX 6652C 6653 WRITE(IOUNIT)PXMIN,PXMAX,PYMIN,PYMAX 6654 WRITE(IOUNIT)PDXMIN,PDXMAX,PDYMIN,PDYMAX 6655 WRITE(IOUNIT)PGXMIN,PGXMAX,PGYMIN,PGYMAX 6656 WRITE(IOUNIT)GX1MIN,GX1MAX,GY1MIN,GY1MAX 6657 WRITE(IOUNIT)GX2MIN,GX2MAX,GY2MIN,GY2MAX 6658 WRITE(IOUNIT)DX1MIN,DX1MAX,DY1MIN,DY1MAX 6659 WRITE(IOUNIT)DX2MIN,DX2MAX,DY2MIN,DY2MAX 6660 WRITE(IOUNIT)FX1MIN,FX1MAX,FY1MIN,FY1MAX 6661 WRITE(IOUNIT)FX2MIN,FX2MAX,FY2MIN,FY2MAX 6662C 6663 WRITE(IOUNIT)IX1FSW,IX2FSW,IY1FSW,IY2FSW 6664 WRITE(IOUNIT)IX1FPA,IX2FPA,IY1FPA,IY2FPA 6665 WRITE(IOUNIT)IX1FCO,IX2FCO,IY1FCO,IY2FCO 6666C 6667 WRITE(IOUNIT)PFRATH 6668C 6669 WRITE(IOUNIT)IX1TSW,IX2TSW,IY1TSW,IY2TSW 6670 WRITE(IOUNIT)IX1JSW,IX2JSW,IY1JSW,IY2JSW 6671 WRITE(IOUNIT)IX1NSW,IX2NSW,IY1NSW,IY2NSW 6672 WRITE(IOUNIT)IX1TSC,IX2TSC,IY1TSC,IY2TSC 6673 WRITE(IOUNIT)IX1TJU,IX2TJU,IY1TJU,IY2TJU 6674 WRITE(IOUNIT)IX1TCO,IX2TCO,IY1TCO,IY2TCO 6675C 6676 WRITE(IOUNIT)NMJX1T,NMJX2T,NMJY1T,NMJY2T 6677 WRITE(IOUNIT)NMNX1T,NMNX2T,NMNY1T,NMNY2T 6678 WRITE(IOUNIT)NX1COO,NX2COO,NY1COO,NY2COO 6679 WRITE(IOUNIT)NX1CMN,NX2CMN,NY1CMN,NY2CMN 6680 WRITE(IOUNIT)MAXTIC 6681C 6682 WRITE(IOUNIT)(PX1COO(I),I=1,MAXTC) 6683 WRITE(IOUNIT)(PX2COO(I),I=1,MAXTC) 6684 WRITE(IOUNIT)(PY1COO(I),I=1,MAXTC) 6685 WRITE(IOUNIT)(PY2COO(I),I=1,MAXTC) 6686 WRITE(IOUNIT)(X1COOR(I),I=1,MAXTC) 6687 WRITE(IOUNIT)(X2COOR(I),I=1,MAXTC) 6688 WRITE(IOUNIT)(Y1COOR(I),I=1,MAXTC) 6689 WRITE(IOUNIT)(Y2COOR(I),I=1,MAXTC) 6690 WRITE(IOUNIT)(PX1CMN(I),I=1,MAXTC) 6691 WRITE(IOUNIT)(PX2CMN(I),I=1,MAXTC) 6692 WRITE(IOUNIT)(PY1CMN(I),I=1,MAXTC) 6693 WRITE(IOUNIT)(PY2CMN(I),I=1,MAXTC) 6694 WRITE(IOUNIT)(X1COMN(I),I=1,MAXTC) 6695 WRITE(IOUNIT)(X2COMN(I),I=1,MAXTC) 6696 WRITE(IOUNIT)(Y1COMN(I),I=1,MAXTC) 6697 WRITE(IOUNIT)(Y2COMN(I),I=1,MAXTC) 6698 WRITE(IOUNIT)PX1TLE,PX2TLE,PY1TLE,PY2TLE 6699 WRITE(IOUNIT)PTICTH,PMNTFA 6700C 6701 WRITE(IOUNIT)IX1ZSW,IX2ZSW,IY1ZSW,IY2ZSW 6702 WRITE(IOUNIT)IX1ZFO,IX2ZFO,IY1ZFO,IY2ZFO 6703 WRITE(IOUNIT)IX1ZCA,IX2ZCA,IY1ZCA,IY2ZCA 6704 WRITE(IOUNIT)IX1ZJU,IX2ZJU,IY1ZJU,IY2ZJU 6705 WRITE(IOUNIT)IX1ZDI,IX2ZDI,IY1ZDI,IY2ZDI 6706 WRITE(IOUNIT)IX1ZFI,IX2ZFI,IY1ZFI,IY2ZFI 6707 WRITE(IOUNIT)IX1ZCO,IX2ZCO,IY1ZCO,IY2ZCO 6708C 6709 WRITE(IOUNIT)IX1ZDP,IX2ZDP,IY1ZDP,IY2ZDP 6710C 6711 WRITE(IOUNIT)PX1ZDS,PX2ZDS,PY1ZDS,PY2ZDS 6712 WRITE(IOUNIT)AX1ZAN,AX2ZAN,AY1ZAN,AY2ZAN 6713 WRITE(IOUNIT)PX1ZHE,PX1ZWI,PX1ZVG,PX1ZHG 6714 WRITE(IOUNIT)PX2ZHE,PX2ZWI,PX2ZVG,PX2ZHG 6715 WRITE(IOUNIT)PY1ZHE,PY1ZWI,PY1ZVG,PY1ZHG 6716 WRITE(IOUNIT)PY2ZHE,PY2ZWI,PY2ZVG,PY2ZHG 6717 WRITE(IOUNIT)PTIZTH 6718C 6719 WRITE(IOUNIT)IVGRSW,IHGRSW 6720 WRITE(IOUNIT)IVGRPA,IHGRPA 6721 WRITE(IOUNIT)IVGRCO,IHGRCO 6722C 6723 WRITE(IOUNIT)PVGRTH,PHGRTH 6724C 6725 WRITE(IOUNIT)(ITITTE(I),I=1,MAXCH) 6726 WRITE(IOUNIT)ITITFO,ITITCA,ITITFI,ITITCO 6727C 6728 WRITE(IOUNIT)NCTITL 6729C 6730 WRITE(IOUNIT)PTITHE,PTITWI,PTITVG,PTITHG,PTITTH,PTITDS 6731C 6732 WRITE(IOUNIT)(IX1LTE(I),I=1,MAXCH) 6733 WRITE(IOUNIT)IX1LFO,IX1LCA,IX1LFI,IX1LCO 6734 WRITE(IOUNIT)(IX2LTE(I),I=1,MAXCH) 6735 WRITE(IOUNIT)IX2LFO,IX2LCA,IX2LFI,IX2LCO 6736 WRITE(IOUNIT)(IX3LTE(I),I=1,MAXCH) 6737 WRITE(IOUNIT)IX3LFO,IX3LCA,IX3LFI,IX3LCO 6738 WRITE(IOUNIT)(IY1LTE(I),I=1,MAXCH) 6739 WRITE(IOUNIT)IY1LFO,IY1LCA,IY1LFI,IY1LCO 6740 WRITE(IOUNIT)(IY2LTE(I),I=1,MAXCH) 6741 WRITE(IOUNIT)IY2LFO,IY2LCA,IY2LFI,IY2LCO 6742C 6743 WRITE(IOUNIT)NCX1LA,NCX2LA,NCX3LA,NCY1LA,NCY2LA 6744C 6745 WRITE(IOUNIT)PX1LHE,PX1LWI,PX1LVG,PX1LHG,PX1LTH,PX1LDS 6746 WRITE(IOUNIT)PX2LHE,PX2LWI,PX2LVG,PX2LHG,PX2LTH,PX2LDS 6747 WRITE(IOUNIT)PX3LHE,PX3LWI,PX3LVG,PX3LHG,PX3LTH,PX3LDS 6748 WRITE(IOUNIT)PY1LHE,PY1LWI,PY1LVG,PY1LHG,PY1LTH,PY1LDS 6749 WRITE(IOUNIT)PY2LHE,PY2LWI,PY2LVG,PY2LHG,PY2LTH,PY2LDS 6750C 6751 WRITE(IOUNIT)(ILEGTE(I),I=1,MAXLG2) 6752 WRITE(IOUNIT)(ILEGFO(I),I=1,MAXLG) 6753 WRITE(IOUNIT)(ILEGCA(I),I=1,MAXLG) 6754 WRITE(IOUNIT)(ILEGJU(I),I=1,MAXLG) 6755 WRITE(IOUNIT)(ILEGDI(I),I=1,MAXLG) 6756 WRITE(IOUNIT)(ILEGFI(I),I=1,MAXLG) 6757 WRITE(IOUNIT)(ILEGCO(I),I=1,MAXLG) 6758 WRITE(IOUNIT)(ILEGNA(I),I=1,MAXLG) 6759C 6760 WRITE(IOUNIT)(ILEGST(I),I=1,MAXLG) 6761 WRITE(IOUNIT)(ILEGSP(I),I=1,MAXLG) 6762 WRITE(IOUNIT)NCLEG,MXCLEG 6763 WRITE(IOUNIT)NUMLEG,MAXLEG 6764C 6765 WRITE(IOUNIT)(PLEGXC(I),I=1,MAXLG) 6766 WRITE(IOUNIT)(PLEGYC(I),I=1,MAXLG) 6767 WRITE(IOUNIT)(PLEGHE(I),I=1,MAXLG) 6768 WRITE(IOUNIT)(PLEGWI(I),I=1,MAXLG) 6769 WRITE(IOUNIT)(PLEGVG(I),I=1,MAXLG) 6770 WRITE(IOUNIT)(PLEGHG(I),I=1,MAXLG) 6771 WRITE(IOUNIT)(PLEGTH(I),I=1,MAXLG) 6772 WRITE(IOUNIT)(ALEGAN(I),I=1,MAXLG) 6773C 6774 WRITE(IOUNIT)(IBOBFI(I),I=1,MAXBX) 6775 WRITE(IOUNIT)(IBOBCO(I),I=1,MAXBX) 6776 WRITE(IOUNIT)(IBOPPA(I),I=1,MAXBX) 6777 WRITE(IOUNIT)(IBOPCO(I),I=1,MAXBX) 6778 WRITE(IOUNIT)(IBOFPA(I),I=1,MAXBX) 6779 WRITE(IOUNIT)(IBOFCO(I),I=1,MAXBX) 6780C 6781 WRITE(IOUNIT)NUMBOX,MAXBOX 6782C 6783 WRITE(IOUNIT)((PBOXXC(I,J),I=1,MAXBX),J=1,2) 6784 WRITE(IOUNIT)((PBOXYC(I,J),I=1,MAXBX),J=1,2) 6785 WRITE(IOUNIT)(PBOPTH(I),I=1,MAXBX) 6786 WRITE(IOUNIT)(PBOPGA(I),I=1,MAXBX) 6787 WRITE(IOUNIT)(PBOFTH(I),I=1,MAXBX) 6788C 6789 WRITE(IOUNIT)(IARRPA(I),I=1,MAXAR) 6790 WRITE(IOUNIT)(IARRCO(I),I=1,MAXAR) 6791 WRITE(IOUNIT)(IARHFI(I),I=1,MAXAR) 6792C 6793 WRITE(IOUNIT)NUMARR,MAXARR 6794C 6795 WRITE(IOUNIT)((PARRXC(I,J),I=1,MAXAR),J=1,2) 6796 WRITE(IOUNIT)((PARRYC(I,J),I=1,MAXAR),J=1,2) 6797 WRITE(IOUNIT)(PARRTH(I),I=1,MAXAR) 6798 WRITE(IOUNIT)(PARHLE(I),I=1,MAXAR) 6799 WRITE(IOUNIT)(PARHWI(I),I=1,MAXAR) 6800C 6801 WRITE(IOUNIT)(ISEGPA(I),I=1,MAXSG) 6802 WRITE(IOUNIT)(ISEGCO(I),I=1,MAXSG) 6803C 6804 WRITE(IOUNIT)NUMSEG,MAXSEG 6805C 6806 WRITE(IOUNIT)((PSEGXC(I,J),I=1,MAXSG),J=1,2) 6807 WRITE(IOUNIT)((PSEGYC(I,J),I=1,MAXSG),J=1,2) 6808 WRITE(IOUNIT)(PSEGTH(I),I=1,MAXSG) 6809C 6810 WRITE(IOUNIT)(ILINPA(I),I=1,MAXLN) 6811 WRITE(IOUNIT)(ILINCO(I),I=1,MAXLN) 6812C 6813 WRITE(IOUNIT)MAXLIN 6814C 6815 WRITE(IOUNIT)(PLINTH(I),I=1,MAXLN) 6816 WRITE(IOUNIT)(PLINLE(I),I=1,MAXLN) 6817 WRITE(IOUNIT)(PLINL2(I),I=1,MAXLN) 6818 WRITE(IOUNIT)(PLINL3(I),I=1,MAXLN) 6819 WRITE(IOUNIT)(PLINGA(I),I=1,MAXLN) 6820 WRITE(IOUNIT)(PLING2(I),I=1,MAXLN) 6821 WRITE(IOUNIT)(PLING3(I),I=1,MAXLN) 6822C 6823 WRITE(IOUNIT)(ICHAPA(I),I=1,MAXCH2) 6824 WRITE(IOUNIT)(ICHAFO(I),I=1,MAXCH2) 6825 WRITE(IOUNIT)(ICHACA(I),I=1,MAXCH2) 6826 WRITE(IOUNIT)(ICHAJU(I),I=1,MAXCH2) 6827 WRITE(IOUNIT)(ICHADI(I),I=1,MAXCH2) 6828 WRITE(IOUNIT)(ICHAFI(I),I=1,MAXCH2) 6829 WRITE(IOUNIT)(ICHACO(I),I=1,MAXCH2) 6830C 6831 WRITE(IOUNIT)MAXCHA 6832C 6833 WRITE(IOUNIT)(PCHAHE(I),I=1,MAXCH2) 6834 WRITE(IOUNIT)(PCHAWI(I),I=1,MAXCH2) 6835 WRITE(IOUNIT)(PCHAVG(I),I=1,MAXCH2) 6836 WRITE(IOUNIT)(PCHAHG(I),I=1,MAXCH2) 6837 WRITE(IOUNIT)(PCHATH(I),I=1,MAXCH2) 6838 WRITE(IOUNIT)(ACHAAN(I),I=1,MAXCH2) 6839C 6840 WRITE(IOUNIT)(ITEXTE(I),I=1,MAXCH) 6841 WRITE(IOUNIT)ITEXPA,ITEXFO,ITEXCA,ITEXJU,ITEXDI,ITEXAU,ITEXFI, 6842 1ITEXCO 6843 WRITE(IOUNIT)IDEFPA,IDEFFO,IDEFCA,IDEFJU,IDEFDI,IDEFAU,IDEFFI, 6844 1IDEFCO 6845 WRITE(IOUNIT)ITEXCR,ITEXLF 6846 WRITE(IOUNIT)IDEFCR,IDEFLF 6847 WRITE(IOUNIT)ITEXSY,ITEXSP 6848 WRITE(IOUNIT)IDEFSY,IDEFSP 6849C 6850 WRITE(IOUNIT)NCTEXT,MXCTEX 6851C 6852 WRITE(IOUNIT)PTEXHE,PTEXWI,PTEXVG,PTEXHG 6853 WRITE(IOUNIT)PTEXTH,PTEXLE,ATEXAN 6854 WRITE(IOUNIT)PDEFHE,PDEFWI,PDEFVG,PDEFHG 6855 WRITE(IOUNIT)PDEFTH,PDEFLE,ADEFAN 6856 WRITE(IOUNIT)PTEXMR 6857 WRITE(IOUNIT)PDEFMR 6858 WRITE(IOUNIT)PXSTAR,PYSTAR 6859 WRITE(IOUNIT)PXEND,PYEND 6860C 6861 WRITE(IOUNIT)(IFILSW(I),I=1,MAXFL) 6862 WRITE(IOUNIT)(IFILPA(I),I=1,MAXFL) 6863 WRITE(IOUNIT)(IFILCO(I),I=1,MAXFL) 6864 WRITE(IOUNIT)IDEFFS 6865 WRITE(IOUNIT)IDEFFP 6866 WRITE(IOUNIT)IDEFFC 6867C 6868 WRITE(IOUNIT)MAXFIL 6869C 6870 WRITE(IOUNIT)(PFILSP(I),I=1,MAXFL) 6871 WRITE(IOUNIT)(PFILTH(I),I=1,MAXFL) 6872 WRITE(IOUNIT)(AFILBA(I),I=1,MAXFL) 6873 WRITE(IOUNIT)PDEFFG 6874 WRITE(IOUNIT)PDEFFT 6875 WRITE(IOUNIT)ADEFFB 6876C 6877 WRITE(IOUNIT)(IPATSW(I),I=1,MAXPT) 6878 WRITE(IOUNIT)(IPATPA(I),I=1,MAXPT) 6879 WRITE(IOUNIT)(IPATLI(I),I=1,MAXPT) 6880 WRITE(IOUNIT)(IPATCO(I),I=1,MAXPT) 6881 WRITE(IOUNIT)IDEFPS 6882 WRITE(IOUNIT)IDEFPP 6883 WRITE(IOUNIT)IDEFPL 6884 WRITE(IOUNIT)IDEFPC 6885C 6886 WRITE(IOUNIT)MAXPAT 6887C 6888 WRITE(IOUNIT)(PPATHE(I),I=1,MAXPT) 6889 WRITE(IOUNIT)(PPATWI(I),I=1,MAXPT) 6890 WRITE(IOUNIT)(PPATSP(I),I=1,MAXPT) 6891 WRITE(IOUNIT)(PPATTH(I),I=1,MAXPT) 6892 WRITE(IOUNIT)PDEFPH 6893 WRITE(IOUNIT)PDEFPW 6894 WRITE(IOUNIT)PDEFPG 6895 WRITE(IOUNIT)PDEFPT 6896C 6897 WRITE(IOUNIT)(ISPISW(I),I=1,MAXSP) 6898 WRITE(IOUNIT)(ISPILI(I),I=1,MAXSP) 6899 WRITE(IOUNIT)(ISPICO(I),I=1,MAXSP) 6900 WRITE(IOUNIT)IDEFSS 6901 WRITE(IOUNIT)IDEFSL 6902 WRITE(IOUNIT)IDEFSC 6903C 6904 WRITE(IOUNIT)MAXSPI 6905C 6906 WRITE(IOUNIT)(PSPITH(I),I=1,MAXSP) 6907 WRITE(IOUNIT)(ASPIBA(I),I=1,MAXSP) 6908 WRITE(IOUNIT)PDEFST 6909 WRITE(IOUNIT)ADEFSB 6910C 6911 WRITE(IOUNIT)(IBARSW(I),I=1,MAXBA) 6912 WRITE(IOUNIT)(IBABLI(I),I=1,MAXBA) 6913 WRITE(IOUNIT)(IBABCO(I),I=1,MAXBA) 6914 WRITE(IOUNIT)(IBAFSW(I),I=1,MAXBA) 6915 WRITE(IOUNIT)(IBAFCO(I),I=1,MAXBA) 6916 WRITE(IOUNIT)(IBAPTY(I),I=1,MAXBA) 6917 WRITE(IOUNIT)(IBAPLI(I),I=1,MAXBA) 6918 WRITE(IOUNIT)(IBAPCO(I),I=1,MAXBA) 6919 WRITE(IOUNIT)IDEBSW 6920 WRITE(IOUNIT)IDEBBL 6921 WRITE(IOUNIT)IDEBBC 6922 WRITE(IOUNIT)IDEBFS 6923 WRITE(IOUNIT)IDEBFC 6924 WRITE(IOUNIT)IDEBPT 6925 WRITE(IOUNIT)IDEBPL 6926 WRITE(IOUNIT)IDEBPC 6927C 6928 WRITE(IOUNIT)MAXBAR 6929C 6930 WRITE(IOUNIT)(ABARBA(I),I=1,MAXBA) 6931 WRITE(IOUNIT)(ABARWI(I),I=1,MAXBA) 6932 WRITE(IOUNIT)(PBABTH(I),I=1,MAXBA) 6933 WRITE(IOUNIT)(PBAPTH(I),I=1,MAXBA) 6934 WRITE(IOUNIT)(PBAPSP(I),I=1,MAXBA) 6935 WRITE(IOUNIT)ADEBBA 6936 WRITE(IOUNIT)ADEBWI 6937 WRITE(IOUNIT)PDEBBT 6938 WRITE(IOUNIT)PDEBPT 6939 WRITE(IOUNIT)PDEBPS 6940C 6941 WRITE(IOUNIT)(IREGSW(I),I=1,MAXRG) 6942 WRITE(IOUNIT)(IREBLI(I),I=1,MAXRG) 6943 WRITE(IOUNIT)(IREBCO(I),I=1,MAXRG) 6944 WRITE(IOUNIT)(IREFSW(I),I=1,MAXRG) 6945 WRITE(IOUNIT)(IREFCO(I),I=1,MAXRG) 6946 WRITE(IOUNIT)(IREPTY(I),I=1,MAXRG) 6947 WRITE(IOUNIT)(IREPLI(I),I=1,MAXRG) 6948 WRITE(IOUNIT)(IREPCO(I),I=1,MAXRG) 6949 WRITE(IOUNIT)IDERSW 6950 WRITE(IOUNIT)IDERBL 6951 WRITE(IOUNIT)IDERBC 6952 WRITE(IOUNIT)IDERFS 6953 WRITE(IOUNIT)IDERFC 6954 WRITE(IOUNIT)IDERPT 6955 WRITE(IOUNIT)IDERPL 6956 WRITE(IOUNIT)IDERPC 6957C 6958 WRITE(IOUNIT)MAXREG 6959C 6960 WRITE(IOUNIT)(AREGBA(I),I=1,MAXRG) 6961 WRITE(IOUNIT)(AREGWI(I),I=1,MAXRG) 6962 WRITE(IOUNIT)(PREBTH(I),I=1,MAXRG) 6963 WRITE(IOUNIT)(PREPTH(I),I=1,MAXRG) 6964 WRITE(IOUNIT)(PREPSP(I),I=1,MAXRG) 6965 WRITE(IOUNIT)ADERBA 6966 WRITE(IOUNIT)ADERWI 6967 WRITE(IOUNIT)PDERBT 6968 WRITE(IOUNIT)PDERPT 6969 WRITE(IOUNIT)PDERPS 6970C 6971 WRITE(IOUNIT)(IMARSW(I),I=1,MAXMR) 6972 WRITE(IOUNIT)(IMABLI(I),I=1,MAXMR) 6973 WRITE(IOUNIT)(IMABCO(I),I=1,MAXMR) 6974 WRITE(IOUNIT)(IMAFSW(I),I=1,MAXMR) 6975 WRITE(IOUNIT)(IMAFCO(I),I=1,MAXMR) 6976 WRITE(IOUNIT)(IMAPTY(I),I=1,MAXMR) 6977 WRITE(IOUNIT)(IMAPLI(I),I=1,MAXMR) 6978 WRITE(IOUNIT)(IMAPCO(I),I=1,MAXMR) 6979 WRITE(IOUNIT)IDEMSW 6980 WRITE(IOUNIT)IDEMBL 6981 WRITE(IOUNIT)IDEMBC 6982 WRITE(IOUNIT)IDEMFS 6983 WRITE(IOUNIT)IDEMFC 6984 WRITE(IOUNIT)IDEMPT 6985 WRITE(IOUNIT)IDEMPL 6986 WRITE(IOUNIT)IDEMPC 6987C 6988 WRITE(IOUNIT)MAXMAR 6989C 6990 WRITE(IOUNIT)(AMARBA(I),I=1,MAXMR) 6991 WRITE(IOUNIT)(AMARWI(I),I=1,MAXMR) 6992 WRITE(IOUNIT)(PMABTH(I),I=1,MAXMR) 6993 WRITE(IOUNIT)(PMAPTH(I),I=1,MAXMR) 6994 WRITE(IOUNIT)(PMAPSP(I),I=1,MAXMR) 6995 WRITE(IOUNIT)ADEMBA 6996 WRITE(IOUNIT)ADEMWI 6997 WRITE(IOUNIT)PDEMBT 6998 WRITE(IOUNIT)PDEMPT 6999 WRITE(IOUNIT)PDEMPS 7000C 7001 WRITE(IOUNIT)(ITEXSW(I),I=1,MAXTX) 7002 WRITE(IOUNIT)(ITEBLI(I),I=1,MAXTX) 7003 WRITE(IOUNIT)(ITEBCO(I),I=1,MAXTX) 7004 WRITE(IOUNIT)(ITEFSW(I),I=1,MAXTX) 7005 WRITE(IOUNIT)(ITEFCO(I),I=1,MAXTX) 7006 WRITE(IOUNIT)(ITEPTY(I),I=1,MAXTX) 7007 WRITE(IOUNIT)(ITEPLI(I),I=1,MAXTX) 7008 WRITE(IOUNIT)(ITEPCO(I),I=1,MAXTX) 7009 WRITE(IOUNIT)IDETSW 7010 WRITE(IOUNIT)IDETBL 7011 WRITE(IOUNIT)IDETBC 7012 WRITE(IOUNIT)IDETFS 7013 WRITE(IOUNIT)IDETFC 7014 WRITE(IOUNIT)IDETPT 7015 WRITE(IOUNIT)IDETPL 7016 WRITE(IOUNIT)IDETPC 7017C 7018 WRITE(IOUNIT)MAXTEX 7019C 7020 WRITE(IOUNIT)(ATEXBA(I),I=1,MAXTX) 7021 WRITE(IOUNIT)(ATEXWI(I),I=1,MAXTX) 7022 WRITE(IOUNIT)(PTEBTH(I),I=1,MAXTX) 7023 WRITE(IOUNIT)(PTEPTH(I),I=1,MAXTX) 7024 WRITE(IOUNIT)(PTEPSP(I),I=1,MAXTX) 7025 WRITE(IOUNIT)ADETBA 7026 WRITE(IOUNIT)ADETWI 7027 WRITE(IOUNIT)PDETBT 7028 WRITE(IOUNIT)PDETPT 7029 WRITE(IOUNIT)PDETPS 7030C 7031C -----END WRITING OUT----------------------- 7032C 7033C *************************** 7034C ** STEP 42-- ** 7035C ** WRITE OUT A MESSAGE ** 7036C *************************** 7037C 7038 ISTEPN='42' 7039 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAVE') 7040 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7041C 7042 IF(IERROR.EQ.'YES')GOTO4290 7043 IF(IFEEDB.EQ.'OFF')GOTO4290 7044 WRITE(ICOUT,999) 7045 CALL DPWRST('XXX','BUG ') 7046 WRITE(ICOUT,4211) 7047 4211 FORMAT('THE SAVING OF ALL INTERNAL DATAPLOT VARIABLES,') 7048 CALL DPWRST('XXX','BUG ') 7049 WRITE(ICOUT,4212) 7050 4212 FORMAT(' PARAMETERS, ETC. HAS JUST BEEN COMPLETED') 7051 CALL DPWRST('XXX','BUG ') 7052 4290 CONTINUE 7053C 7054C *********************** 7055C ** STEP 51-- ** 7056C ** CLOSE THE FILE. ** 7057C *********************** 7058C 7059 ISTEPN='51' 7060 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SAVE') 7061 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7062C 7063 IENDFI='ON' 7064 IREWIN='ON' 7065 CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 7066 1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 7067C 7068C **************** 7069C ** STEP 90-- ** 7070C ** EXIT. ** 7071C **************** 7072C 7073 9000 CONTINUE 7074 IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SAVE')GOTO9090 7075 WRITE(ICOUT,999) 7076 CALL DPWRST('XXX','BUG ') 7077 WRITE(ICOUT,9011) 7078 9011 FORMAT('***** AT THE END OF DPSAVE--') 7079 CALL DPWRST('XXX','BUG ') 7080 WRITE(ICOUT,9012)IBUGS2,ISUBRO,IERROR 7081 9012 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) 7082 CALL DPWRST('XXX','BUG ') 7083 WRITE(ICOUT,9021)IOUNIT 7084 9021 FORMAT('IOUNIT = ',I8) 7085 CALL DPWRST('XXX','BUG ') 7086 WRITE(ICOUT,9022)IFILE 7087 9022 FORMAT('IFILE = ',A80) 7088 CALL DPWRST('XXX','BUG ') 7089 WRITE(ICOUT,9023)ISTAT 7090 9023 FORMAT('ISTAT = ',A12) 7091 CALL DPWRST('XXX','BUG ') 7092 WRITE(ICOUT,9024)IFORM 7093 9024 FORMAT('IFORM = ',A12) 7094 CALL DPWRST('XXX','BUG ') 7095 WRITE(ICOUT,9025)IACCES 7096 9025 FORMAT('IACCES = ',A12) 7097 CALL DPWRST('XXX','BUG ') 7098 WRITE(ICOUT,9026)IPROT 7099 9026 FORMAT('IPROT = ',A12) 7100 CALL DPWRST('XXX','BUG ') 7101 WRITE(ICOUT,9027)ICURST 7102 9027 FORMAT('ICURST = ',A12) 7103 CALL DPWRST('XXX','BUG ') 7104 WRITE(ICOUT,9028)IENDFI 7105 9028 FORMAT('IENDFI = ',A4) 7106 CALL DPWRST('XXX','BUG ') 7107 WRITE(ICOUT,9029)IREWIN 7108 9029 FORMAT('IREWIN = ',A4) 7109 CALL DPWRST('XXX','BUG ') 7110 WRITE(ICOUT,9031)ISUBN0 7111 9031 FORMAT('ISUBN0 = ',A12) 7112 CALL DPWRST('XXX','BUG ') 7113 WRITE(ICOUT,9032)IERRFI 7114 9032 FORMAT('IERRFI = ',A12) 7115 CALL DPWRST('XXX','BUG ') 7116 9090 CONTINUE 7117C 7118 RETURN 7119 END 7120 SUBROUTINE DPSBEX(ISBNAM,IANGLU,ISEED,IFTEXP,IFTORD,IFORSW, 7121 1 IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ, 7122 1 ISUBRO,IFOUND,IERROR) 7123C 7124C PURPOSE--CARRY OUT A SUBSET OF THE LET COMMAND TO BE USED BY 7125C THE "STATISTIC BLOCK". 7126C WRITTEN BY--ALAN HECKERT 7127C STATISTICAL ENGINEERING DIVISION 7128C INFORMATION TECHNOLOGY LABOARATORY 7129C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 7130C GAITHERSBURG, MD 20899-8980 7131C PHONE--301-975-2899 7132C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 7133C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 7134C LANGUAGE--ANSI FORTRAN (1977) 7135C VERSION NUMBER--2016/08 7136C ORIGINAL VERSION--AUGUST 2016. 7137C 7138C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 7139C 7140 CHARACTER*8 ISBNAM 7141 CHARACTER*4 IANGLU 7142 CHARACTER*4 IFTEXP 7143 CHARACTER*4 IFTORD 7144 CHARACTER*4 IFORSW 7145 CHARACTER*4 IBUGA2 7146 CHARACTER*4 IBUGA3 7147 CHARACTER*4 IBUGCO 7148 CHARACTER*4 IBUGEV 7149 CHARACTER*4 IBUGQ 7150 CHARACTER*4 ISUBRO 7151 CHARACTER*4 IFOUND 7152 CHARACTER*4 IERROR 7153C 7154 CHARACTER*4 ICASLE 7155 CHARACTER*4 ITYPEL 7156 CHARACTER*4 IFOUNZ 7157 CHARACTER*4 ITYPE 7158 CHARACTER*4 IHOL 7159 CHARACTER*4 IHOL2 7160 CHARACTER*4 IERRO1 7161 CHARACTER*4 ITYPEH 7162 CHARACTER*4 IW21HO 7163 CHARACTER*4 IW22HO 7164 CHARACTER*4 IA 7165 CHARACTER*4 IPARN 7166 CHARACTER*4 IPARN2 7167 CHARACTER*4 IFOUNR 7168 CHARACTER*4 IFOUN7 7169 CHARACTER*4 IFOUN8 7170 CHARACTER*4 ICASL7 7171 CHARACTER*4 ICASS7 7172 CHARACTER*4 ICASL8 7173 CHARACTER*4 ICASRA 7174 CHARACTER*4 ITYW1L 7175 CHARACTER*4 ICAT1L 7176 CHARACTER*4 INLI1L 7177 CHARACTER*4 ITYW2L 7178 CHARACTER*4 ITYW1R 7179 CHARACTER*4 ICAT1R 7180 CHARACTER*4 INLI1R 7181 CHARACTER*4 ITYW2R 7182 CHARACTER*4 IH 7183 CHARACTER*4 IH2 7184 CHARACTER*4 ISUBN1 7185 CHARACTER*4 ISUBN2 7186 CHARACTER*4 ICOMT 7187 CHARACTER*4 IMSUBC 7188 CHARACTER*4 ICASAR 7189 CHARACTER*1 IREPCH 7190C 7191C--------------------------------------------------------------------- 7192C 7193 DIMENSION IFOUNZ(30) 7194 DIMENSION IBEGIN(30) 7195 DIMENSION IEND(30) 7196 DIMENSION ITYPE(30) 7197 DIMENSION IHOL(30) 7198 DIMENSION IHOL2(30) 7199 DIMENSION INT1(30) 7200 DIMENSION FLOAT1(30) 7201 DIMENSION IERRO1(30) 7202C 7203 DIMENSION ITYPEH(1000) 7204 DIMENSION IW21HO(1000) 7205 DIMENSION IW22HO(1000) 7206 DIMENSION W2HOLD(1000) 7207C 7208C NOTE--THE DIMENSION OF IA SHOULD BE THE SAME AS 7209C THE DIMENSION OF IB IN SUBROUTINE COMPIM 7210C (THE DIMENSION OF IB IS 1000 (JULY 1986)) 7211C 7212 DIMENSION IA(1000) 7213 DIMENSION PARAM(100) 7214 DIMENSION IPARN(100) 7215 DIMENSION IPARN2(100) 7216C 7217C-----COMMON---------------------------------------------------------- 7218C 7219 INCLUDE 'DPCOPA.INC' 7220 INCLUDE 'DPCOHK.INC' 7221 INCLUDE 'DPCOSB.INC' 7222 INCLUDE 'DPCOHO.INC' 7223 INCLUDE 'DPCODA.INC' 7224C 7225 INCLUDE 'DPCOZI.INC' 7226 INCLUDE 'DPCOZ3.INC' 7227 INCLUDE 'DPCOZD.INC' 7228C 7229 DIMENSION TEMP1(MAXOBV) 7230 DIMENSION TEMP2(MAXOBV) 7231 DIMENSION TEMP3(MAXOBV) 7232 DIMENSION TEMP4(MAXOBV) 7233 DIMENSION TEMP5(MAXOBV) 7234 DIMENSION TEMP6(MAXOBV) 7235 INTEGER ITEMP1(MAXOBV) 7236 INTEGER ITEMP2(MAXOBV) 7237 INTEGER ITEMP3(MAXOBV) 7238 INTEGER ITEMP4(MAXOBV) 7239 INTEGER ITEMP5(MAXOBV) 7240 INTEGER ITEMP6(MAXOBV) 7241C 7242 EQUIVALENCE (G3RBAG(KGARB1),TEMP1(1)) 7243 EQUIVALENCE (G3RBAG(KGARB2),TEMP2(1)) 7244 EQUIVALENCE (G3RBAG(KGARB3),TEMP3(1)) 7245 EQUIVALENCE (G3RBAG(KGARB4),TEMP4(1)) 7246 EQUIVALENCE (G3RBAG(KGARB5),TEMP5(1)) 7247 EQUIVALENCE (G3RBAG(KGARB6),TEMP6(1)) 7248C 7249 EQUIVALENCE (IGARBG(IIGR12),ITEMP1(1)) 7250 EQUIVALENCE (IGARBG(IIGR13),ITEMP2(1)) 7251 EQUIVALENCE (IGARBG(IIGR14),ITEMP3(1)) 7252 EQUIVALENCE (IGARBG(IIGR15),ITEMP4(1)) 7253 EQUIVALENCE (IGARBG(IIGR16),ITEMP5(1)) 7254 EQUIVALENCE (IGARBG(IIGR17),ITEMP6(1)) 7255C 7256 DOUBLE PRECISION DTEMP1(MAXOBV) 7257 DOUBLE PRECISION DTEMP2(MAXOBV) 7258 DOUBLE PRECISION DTEMP3(MAXOBV) 7259 EQUIVALENCE (DGARBG(IDGAR8),DTEMP1(1)) 7260 EQUIVALENCE (DGARBG(IDGAR9),DTEMP2(1)) 7261 EQUIVALENCE (DGARBG(IDGA10),DTEMP3(1)) 7262C 7263 CHARACTER*4 IANSSV(MAXSTR) 7264C 7265C-----COMMON VARIABLES (GENERAL)-------------------------------------- 7266C 7267 INCLUDE 'DPCOP2.INC' 7268C 7269C-----START POINT----------------------------------------------------- 7270C 7271 ISUBN1='DPSB' 7272 ISUBN2='EX ' 7273 IERROR='NO' 7274 ICASLE='UNKN' 7275 IMSUBC='UNKN' 7276 IREPCH='^' 7277C 7278 MAXCP1=MAXCOL+1 7279 MAXCP2=MAXCOL+2 7280 MAXCP3=MAXCOL+3 7281 MAXCP4=MAXCOL+4 7282 MAXCP5=MAXCOL+5 7283 MAXCP6=MAXCOL+6 7284C 7285 DO40I=1,1000 7286 ITYPEH(I)=' ' 7287 IW21HO(I)=' ' 7288 IW22HO(I)=' ' 7289 W2HOLD(I)=0.0 7290 40 CONTINUE 7291C 7292C ************************************* 7293C ** TREAT THE STATISTIC BLOCK CASE ** 7294C ************************************* 7295C 7296 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'SBEX')THEN 7297 WRITE(ICOUT,51) 7298 51 FORMAT('***** AT THE BEGINNING OF DPSBEX--') 7299 CALL DPWRST('XXX','BUG ') 7300 WRITE(ICOUT,52)ISBNAM,IANGLU,IFTEXP,IFORSW,ISEED 7301 52 FORMAT('ISBNAM,IANGLU,IFTEXP,IFORSW,ISEED, = ', 7302 1 A8,2X,3(A4,2X),I8) 7303 CALL DPWRST('XXX','BUG ') 7304 WRITE(ICOUT,53)IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ 7305 53 FORMAT('IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ = ',4(A4,2X),A4) 7306 CALL DPWRST('XXX','BUG ') 7307 WRITE(ICOUT,55)ISBNA1,ISBNA2,ISBNA3 7308 55 FORMAT('ISBNA1,ISBNA2,ISBNA3 = ',2(A8,2X),A8) 7309 CALL DPWRST('XXX','BUG ') 7310 WRITE(ICOUT,57)ISBCN1,ISBCN2,ISBCN3 7311 57 FORMAT('ISBCN1,ISBCN2,ISBCN3 = ',3I8) 7312 CALL DPWRST('XXX','BUG ') 7313 ENDIF 7314C 7315C ****************************************** 7316C ** STEP 1-- ** 7317C ** CHECK IF STATISTIC BLOCK IS DEFINED ** 7318C ****************************************** 7319C 7320 IFLAG=0 7321 IF(ISBNAM.EQ.ISBNA1)THEN 7322 IFLAG=1 7323 ISBCNT=ISBCN1 7324 ISBCN2=ISBCP1 7325 ELSEIF(ISBNAM.EQ.ISBNA2)THEN 7326 IFLAG=2 7327 ISBCNT=ISBCN2 7328 ISBCN2=ISBCP2 7329 ELSEIF(ISBNAM.EQ.ISBNA3)THEN 7330 IFLAG=3 7331 ISBCNT=ISBCN3 7332 ISBCN2=ISBCP3 7333 ELSE 7334 WRITE(ICOUT,999) 7335 999 FORMAT(1X) 7336 CALL DPWRST('XXX','BUG ') 7337 WRITE(ICOUT,101) 7338 101 FORMAT('***** ERROR IN STATISTIC BLOCK--') 7339 CALL DPWRST('XXX','BUG ') 7340 WRITE(ICOUT,102)ISBNAM 7341 102 FORMAT(' STATISTIC BLOCK ',A8,' HAS NOT BEEN DEFINED.') 7342 CALL DPWRST('XXX','BUG ') 7343 IERROR='YES' 7344 GOTO9000 7345 ENDIF 7346C 7347 IF(ISBCNT.LT.1)THEN 7348 WRITE(ICOUT,999) 7349 CALL DPWRST('XXX','BUG ') 7350 WRITE(ICOUT,101) 7351 CALL DPWRST('XXX','BUG ') 7352 WRITE(ICOUT,112)ISBNAM 7353 112 FORMAT(' FUNCTION BLOCK ',A8,' HAS NO ACTIVE COMMANDS.') 7354 CALL DPWRST('XXX','BUG ') 7355 IERROR='YES' 7356 GOTO9000 7357 ENDIF 7358C 7359C SAVE CURRENT COMMAND LINE 7360C 7361 DO910II=1,MAXSTR 7362 IANSSV(II)=IANSLC(II) 7363 910 CONTINUE 7364C 7365C LOOP THROUGH EACH LINE OF THE FUNCTION BLOCK 7366C 7367 DO1000KK=1,ISBCNT 7368C 7369C STEP 1: PUT THE FUNCTION BLOCK LINE INTO IANSLC 7370C 7371 IF(IFLAG.EQ.1)THEN 7372 DO1010II=1,MAXSTR 7373 IANSLC(II)=' ' 7374 IANSLC(II)(1:1)=ISBLI1(KK)(II:II) 7375 1010 CONTINUE 7376 ELSEIF(IFLAG.EQ.2)THEN 7377 DO1020II=1,MAXSTR 7378 IANSLC(II)=' ' 7379 IANSLC(II)(1:1)=ISBLI2(KK)(II:II) 7380 1020 CONTINUE 7381 ELSEIF(IFLAG.EQ.3)THEN 7382 DO1030II=1,MAXSTR 7383 IANSLC(II)=' ' 7384 IANSLC(II)(1:1)=ISBLI3(KK)(II:II) 7385 1030 CONTINUE 7386 ENDIF 7387C 7388 IWIDTH=1 7389 DO1040II=MAXSTR,1,-1 7390 IF(IANSLC(II)(1:1).NE.' ')THEN 7391 IWIDTH=II 7392 GOTO1049 7393 ENDIF 7394 1040 CONTINUE 7395 1049 CONTINUE 7396C 7397 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'SBEX')THEN 7398 WRITE(ICOUT,1051)KK,IWIDTH 7399 1051 FORMAT('KK,IWIDTH = ',2I8) 7400 CALL DPWRST('XXX','BUG ') 7401 DO1053II=1,IWIDTH 7402 WRITE(ICOUT,1054)II,IANSLC(II) 7403 1054 FORMAT('II,IANSLC(II) = ',I5,2X,A4) 7404 CALL DPWRST('XXX','BUG ') 7405 1053 CONTINUE 7406 ENDIF 7407C 7408C STEP 2: NOW PROCESS IANSLC TO BREAK IT INTO COMPONENT ARGUMENTS 7409C 7410 CALL DPNONP(IANSLC,IWIDTH,IANSLC,IBUGA2,ISUBRO,IERROR) 7411 CALL DPREP2(IANSLC,IWIDTH, 7412 1 IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 7413 1 IVARLB,IROWLB,MAXOBV, 7414 1 IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,IMALEV, 7415 1 IBUGA2,ISUBRO,IERROR) 7416 CALL DPUPPE(IANSLC,IWIDTH,IANS,IBUGA2,IERROR) 7417 CALL DPTYPE(IANSLC,IWIDTH,IBUGA2, 7418 1 ICOM,ICOM2,ICOMT,ICOMI,ACOM,ICOMLC,ICOML2, 7419 1 IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 7420 1 IHARG,IHARG2,IARGT,IARG,ARG,IHARLC,IHARL2,NUMARG, 7421 1 IHOST1,IHOST2) 7422C 7423 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'SBEX')THEN 7424 WRITE(ICOUT,1061)NUMARG 7425 1061 FORMAT('NUMARG = ',I8) 7426 CALL DPWRST('XXX','BUG ') 7427 DO1063II=1,NUMARG 7428 WRITE(ICOUT,1064)II,IHARG(II),IHARG2(II) 7429 1064 FORMAT('II,IHARG(II),IHARG2(II) = ',I5,2(2X,A4)) 7430 CALL DPWRST('XXX','BUG ') 7431 1063 CONTINUE 7432 ENDIF 7433C 7434C STEP 3: NOW PROCESS THE LET COMMANDS 7435C 7436C CHECK FOR AN "=" SIGN (THIS SHOULD NOT BE LAST 7437C ARGUMENT IN LIST) 7438C 7439 DO1103I=1,NUMARG 7440 IF(IHARG(I).EQ.'= ')THEN 7441 IF(I.LT.NUMARG)GOTO1119 7442 WRITE(ICOUT,999) 7443 CALL DPWRST('XXX','BUG ') 7444 WRITE(ICOUT,101) 7445 CALL DPWRST('XXX','BUG ') 7446 WRITE(ICOUT,1112) 7447 1112 FORMAT(' IMPROPER FORM FOR THE LET COMMAND.') 7448 CALL DPWRST('XXX','BUG ') 7449 WRITE(ICOUT,1123) 7450 1123 FORMAT(' NOTHING FOUND TO THE RIGHT OF THE EQUAL SIGN') 7451 CALL DPWRST('XXX','BUG ') 7452 WRITE(ICOUT,1114) 7453 CALL DPWRST('XXX','BUG ') 7454 IF(IWIDTH.GE.1)THEN 7455 WRITE(ICOUT,1115)(IANSLC(JJ),JJ=1,MIN(120,IWIDTH)) 7456 CALL DPWRST('XXX','BUG ') 7457 ENDIF 7458 IERROR='YES' 7459 GOTO9000 7460 ENDIF 7461 1103 CONTINUE 7462C 7463 WRITE(ICOUT,999) 7464 CALL DPWRST('XXX','BUG ') 7465 WRITE(ICOUT,101) 7466 CALL DPWRST('XXX','BUG ') 7467 WRITE(ICOUT,1112) 7468 CALL DPWRST('XXX','BUG ') 7469 WRITE(ICOUT,1113) 7470 1113 FORMAT(' NO EQUAL SIGN FOUND AFTER THE ', 7471 1 'VARIABLE/PARAMETER NAME.') 7472 CALL DPWRST('XXX','BUG ') 7473 WRITE(ICOUT,1114) 7474 1114 FORMAT(' THE ENTERED COMMAND LINE IS AS FOLLOWS--') 7475 CALL DPWRST('XXX','BUG ') 7476 IF(IWIDTH.GE.1)THEN 7477 WRITE(ICOUT,1115)(IANSLC(I),I=1,MIN(120,IWIDTH)) 7478 1115 FORMAT(' ',120A1) 7479 CALL DPWRST('XXX','BUG ') 7480 ENDIF 7481 IERROR='YES' 7482 GOTO9000 7483C 7484 1119 CONTINUE 7485C 7486C ************************************** 7487C ** STEP 2-- ** 7488C ** TREAT THE VARIOUS LET SUBCASES ** 7489C ************************************** 7490C 7491C CURRENTLY, THERE ARE 25 COMMANDS THAT UTILIZE SUPPORTED 7492C STATISTICS. THE STATISTIC BLOCKS CAN BE USED BY ANY OF 7493C THESE 25 COMMANDS: 7494C 7495C CURRENTLY, STATISTIC BLOCKS ARE RESTRICTED TO THE FOLLOWING 7496C LET SUB-COMMANDS: 7497C 7498C 1. PATTERN/DATA 7499C 2. RANDOM NUMBERS 7500C 3. MATH LET SUB-COMMANDS (BUT NOT MATRIX COMMANDS) 7501C 4. STATISTICS LET SUB-COMMANDS 7502C 5. ARITHMETIC OPERATIONS 7503C 6. LET ... = EXECUTE ... 7504C 7505C NOTE THAT FOLLOWING MATH LET SUB-COMMANDS ARE NOT HANDLED 7506C IN DPMATC AND ARE NOT SUPPORTED IN STATISTIC BLOCKS: 7507C 7508C A. DERIVATIVE 7509C B. NUMERICAL DERIVATIVE 7510C C. INTEGRAL 7511C D. RUNGE-KUTTA 7512C E. OPTIMIZE 7513C F. ROOTS 7514C 7515C NOTE THAT FOR STATISTIC LET SUB-COMMANDS, WE NEED TO BE 7516C CONCERNED ABOUT RECURSION. 7517C 7518C ******************************************** 7519C ** STEP 2.12-- ** 7520C ** TREAT THE PATTERN GENERATION SUBCASE ** 7521C ******************************************** 7522C 7523 IF((IHARG(3).EQ.'PATT'.AND.IHARG2(3).EQ.'ERN ') .OR. 7524 1 (IHARG(3).EQ.'DATA'.AND.IHARG2(3).EQ.' '))THEN 7525 IF(IHARG(1).EQ.'PLOT' .AND. 7526 1 (IHARG(2).EQ.'CHAR' .OR. IHARG(2).EQ.'LINE' .OR. 7527 1 IHARG(2).EQ.'SPIK' .OR. IHARG(2).EQ.'REGI' .OR. 7528 1 IHARG(2).EQ.'BAR'))GOTO1290 7529 ICASLE='PATT' 7530 CALL DPPAT(IBUGA3,IBUGQ,IFOUND,IERROR) 7531 ENDIF 7532C 7533 1290 CONTINUE 7534C 7535C ************************************************** 7536C ** STEP 2.13-- ** 7537C ** TREAT THE RANDOM NUMBER GENERATION SUBCASE ** 7538C ** (AND THE RANDOM PERMUTATION SUBCASE) ** 7539C ** (AND THE BOOTSTRAP INDEX SUBCASE == THE ** 7540C ** DISCRETE UNIFORM RANDOM NUMBER SUBCASE) ** 7541C ************************************************** 7542C 7543 CALL CKRAND(ICASRA,ILOCNU,NUMSHA, 7544 1 SHAPE1,SHAPE2,SHAPE3,SHAPE4, 7545 1 SHAPE5,SHAPE6,SHAPE7, 7546 1 IBUGA3,ISUBRO,IFOUNR,IERROR) 7547 IF(IFOUNR.EQ.'YES')THEN 7548 ICASLE='RAND' 7549 CALL DPRAND(ICASRA,ISEED,ILOCNU,NUMSHA, 7550 1 SHAPE1,SHAPE2,SHAPE3,SHAPE4, 7551 1 SHAPE5,SHAPE6,SHAPE7, 7552 1 IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 7553 GOTO9000 7554 ENDIF 7555C 7556C ********************************************** 7557C ** STEP 2.20-- ** 7558C ** TREAT THE MATH CALCULATIONS SUBCASE ** 7559C ** (INPUT = A VECTOR; OUTPUT = A VECTOR) ** 7560C ********************************************** 7561C 7562C 7563 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'SBEX')THEN 7564 WRITE(ICOUT,2001) 7565 2001 FORMAT('BEFORE CALL CKMATH') 7566 CALL DPWRST('XXX','BUG ') 7567 ENDIF 7568C 7569C MATH LET SUBCOMMANDS. 7570C 7571 CALL CKMATH(IBUGA3,ISUBRO,IFOUN7,ICASL7,ICASS7,ISTANR, 7572 1 IMSUBC,ILOCV) 7573 IF(IFOUN7.EQ.'YES'.AND.ICASL7.NE.'UNKN'.AND. 7574 1 ILOCV.GE.1)THEN 7575 ICASLE='MANI' 7576 IFOUND='NO' 7577 CALL DPMATC(ICASL7,ICASS7,ISTANR,ILOCV,IFTEXP,IFTORD,ISEED, 7578 1 IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 7579 IF(IFOUND.EQ.'YES')GOTO1000 7580C 7581C DON'T SUPPORT MATRIX CALLS AS THESE MAY HAVE 7582C POTENTIAL CONFLICTS WITH SCRATCH STORAGE. 7583C 7584CCCCC CALL DPMAT2(ICASL7,ICASS7,ILOCV, 7585CCCCC1 ISEED,IMSUBC, 7586CCCCC1 IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 7587 GOTO1000 7588 ENDIF 7589C 7590C ************************************************** 7591C ** STEP 2.41-- ** 7592C ** TREAT THE STATISTICAL CALCULATIONS SUBCASE ** 7593C ** (INPUT = A VECTOR; OUTPUT = A PARAMETER) ** 7594C ************************************************** 7595C 7596 CALL DPTYP2(IANS,IWIDTH,IHNAME,IHNAM2,NUMNAM,MAXNAM,IBUGA3, 7597 1 IUSE,IVALUE,VALUE,IN, 7598 1 IFOUNZ,IBEGIN,IEND, 7599 1 ITYPE,IHOL,IHOL2,INT1,FLOAT1,IERRO1, 7600 1 NUMCL,NUMPL,NUMAOL,ITYW1L,ICAT1L,INLI1L,ITYW2L, 7601 1 NUMCR,NUMPR,NUMAOR,ITYW1R,ICAT1R,INLI1R,ITYW2R) 7602C 7603 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'SBEX')THEN 7604 WRITE(ICOUT,3091) 7605 3091 FORMAT('BEFORE CALL CKARIT') 7606 CALL DPWRST('XXX','BUG ') 7607 ENDIF 7608C 7609 CALL CKARIT(IFOUNZ,IBEGIN,IANS,IWIDTH,ICASAR,IBUGA3,ISUBRO) 7610C 7611 IF(NUMARG.GE.3 .AND. 7612 1 (IHARG(3).EQ.'SN- ' .OR. IHARG(3).EQ.'SN+ '))ICASAR='NO' 7613 IF(NUMARG.GE.4 .AND. IHARG(3).EQ.'TAGU' .AND. 7614 1 (IHARG(4).EQ.'SN- ' .OR. IHARG(4).EQ.'SN+ '))ICASAR='NO' 7615 IF(NUMARG.GE.6 .AND. IHARG(3).EQ.'CHI ' .AND. 7616 1 IHARG(4).EQ.'SQUA'.AND. IHARG(5).EQ.'SD ' .AND. 7617 1 IHARG(6).EQ.'TEST')ICASAR='NO' 7618 IF(NUMARG.GE.6 .AND. IHARG(3).EQ.'ONE '.AND. 7619 1 IHARG(4).EQ.'SAMP' .AND. IHARG(5).EQ.'T ' .AND. 7620 1 IHARG(6).EQ.'TEST')ICASAR='NO' 7621 IF(NUMARG.GE.7 .AND. IHARG(3).EQ.'CHI ' .AND. 7622 1 IHARG(4).EQ.'SQUA' .AND. IHARG(5).EQ.'STAN' .AND. 7623 1 IHARG(6).EQ.'DEVI' .AND. IHARG(7).EQ.'TEST')ICASAR='NO' 7624 IF(NUMARG.GE.4 .AND. IHARG(3).EQ.'HODG' .AND. 7625 1 IHARG(4).EQ.'LEHM')ICASAR='NO' 7626 IF(NUMARG.GE.6 .AND. IHARG(5).EQ.'HODG' .AND. 7627 1 IHARG(6).EQ.'LEHM')ICASAR='NO' 7628C 7629 IF(ICASAR.EQ.'NO')THEN 7630C 7631 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'SBEX')THEN 7632 WRITE(ICOUT,4001) 7633 4001 FORMAT('BEFORE CALL CKSTAT') 7634 CALL DPWRST('XXX','BUG ') 7635 ENDIF 7636C 7637 CALL CKSTAT(IBUGA3,IFOUN8,ICASL8,ILOCV,ISTANR) 7638 IF(IFOUN8.EQ.'YES'.AND.ICASL8.NE.'UNKN'.AND. 7639 1 ILOCV.GE.1)THEN 7640 ICASLE='STAT' 7641 CALL DPSTC2(ICASL8,ILOCV,ISTANR, 7642 1 IFOUNZ,IBEGIN,IEND,ITYPE,IHOL,IHOL2,INT1, 7643 1 FLOAT1,IERRO1, 7644 1 TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6,MAXOBV, 7645 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 7646 1 DTEMP1,DTEMP2,DTEMP3, 7647 1 IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 7648 GOTO1000 7649 ENDIF 7650 ENDIF 7651C 7652C ********************************************** 7653C ** STEP 2.19A-- ** 7654C ** TREAT THE EXECUTE SUBCASE ** 7655C ********************************************** 7656C 7657 IF(IHARG(2).EQ.'= '.AND.IHARG(3).EQ.'EXEC')THEN 7658 ICASLE='EXEC' 7659 IFOUND='YES' 7660 ITYPEL='V' 7661C 7662C EXTRACT CURRENT PARAMETER LIST FOR FUNCTION BLOCK 7663C 7664 ICNT=0 7665 DO2190K=1,ISBCN2 7666 IH=' ' 7667 IH2=' ' 7668 IF(IFLAG.EQ.1)THEN 7669 IH=ISBPL1(K)(1:4) 7670 IH2=ISBPL1(K)(5:8) 7671 ELSEIF(IFLAG.EQ.2)THEN 7672 IH=ISBPL2(K)(1:4) 7673 IH2=ISBPL2(K)(5:8) 7674 ELSEIF(IFLAG.EQ.3)THEN 7675 IH=ISBPL3(K)(1:4) 7676 IH2=ISBPL3(K)(5:8) 7677 ENDIF 7678C 7679 DO2195II=1,NUMNAM 7680 IF(IH.EQ.IHNAME(II) .AND. IH2.EQ.IHNAM2(II) .AND. 7681 1 IUSE(II).EQ.'P')THEN 7682 ICNT=ICNT+1 7683 TEMP1(ICNT)=VALUE(II) 7684 GOTO2190 7685 ENDIF 7686 2195 CONTINUE 7687 2190 CONTINUE 7688C 7689 CALL DPEXFI(TEMP1,ICNT,IBUGA3,ISUBRO,IFOUND,IERROR) 7690 GOTO1000 7691 ENDIF 7692C 7693C ********************************************* 7694C ** STEP 2.50-- ** 7695C ** TREAT THE FUNCTION EVALUATION SUBCASE ** 7696C ********************************************* 7697C 7698C DON'T SUPPORT THIS AS IT IS MORE USEFUL TO CALL DPSBEX FROM 7699C DPFUEV (I.E., ALLOW FUNCTION EVALUATION TO HANDLE FUNCTION 7700C BLOCKS). 7701C 7702 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'SBEX')THEN 7703 WRITE(ICOUT,5001) 7704 5001 FORMAT('BEFORE CALL DPFUEV') 7705 CALL DPWRST('XXX','BUG ') 7706 ENDIF 7707C 7708 ICASLE='FUNC' 7709 CALL DPFUEV(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 7710 1 IA,PARAM,IPARN,IPARN2, 7711 1 IFOUNZ,IBEGIN,IEND,ITYPE,IHOL,IHOL2,INT1, 7712 1 FLOAT1,IERRO1, 7713 1 NUMCL,NUMPL,NUMAOL,ITYW1L,ICAT1L,INLI1L,ITYW2L, 7714 1 NUMCR,NUMPR,NUMAOR,ITYW1R,ICAT1R,INLI1R,ITYW2R, 7715 1 IANGLU, 7716 1 IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,IFOUND,IERROR) 7717 IF(IFOUND.EQ.'YES')GOTO1000 7718C 7719C ADMISSABLE LET COMMAND NOT FOUND 7720C 7721 WRITE(ICOUT,999) 7722 CALL DPWRST('XXX','BUG ') 7723 WRITE(ICOUT,101) 7724 CALL DPWRST('XXX','BUG ') 7725 WRITE(ICOUT,6001) 7726 6001 FORMAT(' COMMAND IS NOT SUPPORTED IN FUNCTION BLOCK') 7727 IERROR='YES' 7728 GOTO9000 7729C 7730 1000 CONTINUE 7731C 7732C 7733C ************************************** 7734C ** STEP 3-- ** 7735C ** RESET ORIGINAL COMMAND LINE ** 7736C ************************************** 7737C 7738 DO7010II=1,MAXSTR 7739 IANSLC(II)=IANSSV(II) 7740 7010 CONTINUE 7741C 7742 CALL DPNONP(IANSLC,IWIDTH,IANSLC,IBUGA2,ISUBRO,IERROR) 7743 CALL DPREP2(IANSLC,IWIDTH, 7744 1 IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 7745 1 IVARLB,IROWLB,MAXOBV, 7746 1 IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,IMALEV, 7747 1 IBUGA2,ISUBRO,IERROR) 7748 CALL DPUPPE(IANSLC,IWIDTH,IANS,IBUGA2,IERROR) 7749 CALL DPTYPE(IANSLC,IWIDTH,IBUGA2, 7750 1 ICOM,ICOM2,ICOMT,ICOMI,ACOM,ICOMLC,ICOML2, 7751 1 IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 7752 1 IHARG,IHARG2,IARGT,IARG,ARG,IHARLC,IHARL2,NUMARG, 7753 1 IHOST1,IHOST2) 7754C 7755C ***************** 7756C ** STEP 90-- ** 7757C ** EXIT ** 7758C ***************** 7759C 7760 9000 CONTINUE 7761 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'SBEX')THEN 7762 WRITE(ICOUT,999) 7763 CALL DPWRST('XXX','BUG ') 7764 WRITE(ICOUT,9011) 7765 9011 FORMAT('***** AT THE END OF DPSBEX--') 7766 CALL DPWRST('XXX','BUG ') 7767 WRITE(ICOUT,9016)ICASLE,IMSUBC 7768 9016 FORMAT('ICASLE,IMSUBC = ',A4,2X,A4) 7769 CALL DPWRST('XXX','BUG ') 7770 WRITE(ICOUT,9017)IFOUND,IERROR 7771 9017 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 7772 CALL DPWRST('XXX','BUG ') 7773 ENDIF 7774C 7775 RETURN 7776 END 7777 SUBROUTINE DPSBLI(ICOM,IHARG,IARGT,ARG,NUMARG, 7778 1ASUBXL,ASUBXU,ASUBYL,ASUBYU, 7779 1MAXSUB, 7780 1IFOUND,IERROR) 7781C 7782C PURPOSE--DEFINE LIMITS FOR SUBREGIONS. 7783C SUBREGION XLIMITS 10 20 7784C SUBREGION YLIMITS 10 20 7785C SUBREGION 1 YLIMITS 10 20 7786C SUBREGION 2 YLIMITS 10 20 7787C INPUT ARGUMENTS--ICOM (A HOLLERITH VARIABLE) 7788C --IHARG (A HOLLERITH VECTOR) 7789C --IARGT (A HOLLERITH VECTOR) 7790C --ARG (A FLOATING POINT VECTOR) 7791C --NUMARG 7792C OUTPUT ARGUMENTS-- 7793C --ASUBXL = COORDINATE FOR LOWER X LIMIT 7794C --ASUBXU = COORDINATE FOR UPPER X LIMIT 7795C --ASUBYL = COORDINATE FOR LOWER Y LIMIT 7796C --ASUBYU = COORDINATE FOR UPPER Y LIMIT 7797C --MAXSUB = MAXIMUM NUMBER OF SUBREGIONS 7798C --IFOUND ('YES' OR 'NO' ) 7799C --IERROR ('YES' OR 'NO' ) 7800C WRITTEN BY--JAMES J. FILLIBEN 7801C STATISTICAL ENGINEERING DIVISION 7802C INFORMATION TECHNOLOGY LABORATORY 7803C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 7804C GAITHERSBURG, MD 20899-8980 7805C PHONE--301-975-2899 7806C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 7807C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 7808C LANGUAGE--ANSI FORTRAN (1977) 7809C VERSION NUMBER--99/11 7810C ORIGINAL VERSION--NOVEMBER 1999. 7811C 7812C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 7813C 7814 CHARACTER*4 ICOM 7815 CHARACTER*4 IHARG 7816 CHARACTER*4 IARGT 7817C 7818 CHARACTER*4 IFOUND 7819 CHARACTER*4 IERROR 7820C 7821C--------------------------------------------------------------------- 7822C 7823 DIMENSION IHARG(*) 7824 DIMENSION IARGT(*) 7825 DIMENSION ARG(*) 7826C 7827 DIMENSION ASUBXL(*) 7828 DIMENSION ASUBXU(*) 7829 DIMENSION ASUBYL(*) 7830 DIMENSION ASUBYU(*) 7831C 7832C--------------------------------------------------------------------- 7833C 7834 INCLUDE 'DPCOP2.INC' 7835C 7836C-----START POINT----------------------------------------------------- 7837C 7838 IFOUND='NO' 7839 IERROR='NO' 7840C 7841 IF(ICOM.NE.'SUBR')THEN 7842 IFOUND='NO' 7843 GOTO9000 7844 ENDIF 7845C 7846 IF(NUMARG.LE.0)THEN 7847 GOTO9000 7848 ENDIF 7849 IF(IHARG(NUMARG).EQ.'?')GOTO8100 7850C 7851C ***************************************************** 7852C ** CHECK IF THE FIRST ARGUMENT IS NUMERIC ** 7853C ** (THIS SHOULD DEFINE WHICH SUBREGION IS BEING ** 7854C ** SET) ** 7855C ***************************************************** 7856C 7857 IF(IARGT(1).EQ.'NUMB')THEN 7858 ISUBID=INT(ARG(1)+0.5) 7859 IF(ISUBID.LT.1 .OR. ISUBID.GT.MAXSUB)ISUBID=1 7860 IWORD=2 7861 ELSE 7862 IWORD=1 7863 ISUBID=1 7864 ENDIF 7865C 7866C ***************************************************** 7867C ** TREAT THE CASE WHEN ** 7868C ** THE HORIZONTAL SUBREGION LIMITS ARE TO BE FIXED** 7869C ***************************************************** 7870C 7871 IF(IHARG(IWORD).EQ.'XLIM')GOTO1100 7872 GOTO1199 7873C 7874 1100 CONTINUE 7875 IF(NUMARG.LE.IWORD)GOTO1110 7876 IF(IHARG(IWORD+1).EQ.'DEFA')GOTO1110 7877 IF(IARGT(IWORD+1).EQ.'NUMB'.AND.IARGT(IWORD+2).EQ.'NUMB')GOTO1120 7878 GOTO1110 7879C 7880 1110 CONTINUE 7881 IFOUND='YES' 7882 ASUBXL(ISUBID)=CPUMIN 7883 ASUBXU(ISUBID)=CPUMAX 7884C 7885 IF(IFEEDB.EQ.'ON')THEN 7886 WRITE(ICOUT,999) 7887 999 FORMAT(1X) 7888 CALL DPWRST('XXX','BUG ') 7889 WRITE(ICOUT,1115)ISUBID 7890 1115 FORMAT('THE X LIMITS FOR SUB-REGION ',I8,' HAVE JUST BEEN SET') 7891 CALL DPWRST('XXX','BUG ') 7892 WRITE(ICOUT,1117) 7893 1117 FORMAT('TO THE FULL PLOT AREA.') 7894 CALL DPWRST('XXX','BUG ') 7895 ENDIF 7896 GOTO9000 7897C 7898 1120 CONTINUE 7899 IFOUND='YES' 7900 ASUBXL(ISUBID)=ARG(IWORD+1) 7901 ASUBXU(ISUBID)=ARG(IWORD+2) 7902 IF(ASUBXL(ISUBID).GT.ASUBXU(ISUBID))THEN 7903 ATEMP=ASUBXL(ISUBID) 7904 ASUBXL(ISUBID)=ASUBXU(ISUBID) 7905 ASUBXU(ISUBID)=ATEMP 7906 ENDIF 7907C 7908 IF(IFEEDB.EQ.'OFF')GOTO1129 7909 WRITE(ICOUT,999) 7910 CALL DPWRST('XXX','BUG ') 7911 WRITE(ICOUT,1125)ISUBID 7912 1125 FORMAT('THE SUBREGION X LIMITS FOR SUBREGION ',I8) 7913 CALL DPWRST('XXX','BUG ') 7914 WRITE(ICOUT,1126)ASUBXL(ISUBID),ASUBXU(ISUBID) 7915 1126 FORMAT('HAVE JUST BEEN SET TO ',E15.7,E15.7) 7916 CALL DPWRST('XXX','BUG ') 7917 1129 CONTINUE 7918 GOTO9000 7919C 7920 1199 CONTINUE 7921C 7922C ***************************************************** 7923C ** TREAT THE CASE WHEN ** 7924C ** THE VERTICAL SUBREGION LIMITS ARE TO BE FIXED** 7925C ***************************************************** 7926C 7927 IF(IHARG(IWORD).EQ.'YLIM')GOTO2100 7928 GOTO2199 7929C 7930 2100 CONTINUE 7931 IF(NUMARG.LE.IWORD)GOTO2110 7932 IF(IHARG(IWORD+1).EQ.'DEFA')GOTO2110 7933 IF(IARGT(IWORD+1).EQ.'NUMB'.AND.IARGT(IWORD+2).EQ.'NUMB')GOTO2120 7934 GOTO2110 7935C 7936 2110 CONTINUE 7937 IFOUND='YES' 7938 ASUBYL(ISUBID)=CPUMIN 7939 ASUBYU(ISUBID)=CPUMAX 7940C 7941 IF(IFEEDB.EQ.'OFF')GOTO2119 7942 WRITE(ICOUT,999) 7943 CALL DPWRST('XXX','BUG ') 7944 WRITE(ICOUT,2115)ISUBID 7945 2115 FORMAT('THE Y LIMITS FOR SUB-REGION ',I8,' HAVE JUST BEEN SET') 7946 CALL DPWRST('XXX','BUG ') 7947 WRITE(ICOUT,2117) 7948 2117 FORMAT('TO THE FULL PLOT AREA.') 7949 CALL DPWRST('XXX','BUG ') 7950 2119 CONTINUE 7951 GOTO9000 7952C 7953 2120 CONTINUE 7954 IFOUND='YES' 7955 ASUBYL(ISUBID)=ARG(IWORD+1) 7956 ASUBYU(ISUBID)=ARG(IWORD+2) 7957 IF(ASUBYL(ISUBID).GT.ASUBYU(ISUBID))THEN 7958 ATEMP=ASUBYL(ISUBID) 7959 ASUBYL(ISUBID)=ASUBYU(ISUBID) 7960 ASUBYU(ISUBID)=ATEMP 7961 ENDIF 7962C 7963 IF(IFEEDB.EQ.'OFF')GOTO2129 7964 WRITE(ICOUT,999) 7965 CALL DPWRST('XXX','BUG ') 7966 WRITE(ICOUT,2125)ISUBID 7967 2125 FORMAT('THE SUBREGION Y LIMITS FOR SUBREGION ',I8) 7968 CALL DPWRST('XXX','BUG ') 7969 WRITE(ICOUT,2126)ASUBYL(ISUBID),ASUBYU(ISUBID) 7970 2126 FORMAT('HAVE JUST BEEN SET TO ',E15.7,E15.7) 7971 CALL DPWRST('XXX','BUG ') 7972 2129 CONTINUE 7973 GOTO9000 7974C 7975 2199 CONTINUE 7976C 7977C ***************************************************** 7978C ** TREAT THE CASE WHEN BOTH THE HORIZONTAL AND ** 7979C ** VERTICAL SUBREGION LIMITS ARE TO BE FIXED ** 7980C ***************************************************** 7981C 7982 IF(IHARG(IWORD).EQ.'LIMI')GOTO3100 7983 GOTO3199 7984C 7985 3100 CONTINUE 7986 IF(NUMARG.LE.IWORD)GOTO3110 7987 IF(IHARG(IWORD+1).EQ.'DEFA')GOTO3110 7988 IF(IARGT(IWORD+1).EQ.'NUMB'.AND.IARGT(IWORD+2).EQ.'NUMB')GOTO3120 7989 GOTO3110 7990C 7991 3110 CONTINUE 7992 IFOUND='YES' 7993 ASUBXL(ISUBID)=CPUMIN 7994 ASUBXU(ISUBID)=CPUMAX 7995 ASUBYL(ISUBID)=CPUMIN 7996 ASUBYU(ISUBID)=CPUMAX 7997C 7998 IF(IFEEDB.EQ.'ON')THEN 7999 WRITE(ICOUT,999) 8000 CALL DPWRST('XXX','BUG ') 8001 WRITE(ICOUT,3115)ISUBID 8002 3115 FORMAT('THE LIMITS FOR SUB-REGION ',I8,' HAVE JUST BEEN SET') 8003 CALL DPWRST('XXX','BUG ') 8004 WRITE(ICOUT,3117) 8005 3117 FORMAT('TO THE FULL PLOT AREA.') 8006 CALL DPWRST('XXX','BUG ') 8007 ENDIF 8008 GOTO9000 8009C 8010 3120 CONTINUE 8011 IFOUND='YES' 8012 ASUBXL(ISUBID)=ARG(IWORD+1) 8013 ASUBXU(ISUBID)=ARG(IWORD+2) 8014 ASUBYL(ISUBID)=ARG(IWORD+1) 8015 ASUBYU(ISUBID)=ARG(IWORD+2) 8016 IF(ASUBYL(ISUBID).GT.ASUBYU(ISUBID))THEN 8017 ATEMP=ASUBYL(ISUBID) 8018 ASUBYL(ISUBID)=ASUBYU(ISUBID) 8019 ASUBYU(ISUBID)=ATEMP 8020 ENDIF 8021 IF(ASUBXL(ISUBID).GT.ASUBXU(ISUBID))THEN 8022 ATEMP=ASUBXL(ISUBID) 8023 ASUBXL(ISUBID)=ASUBXU(ISUBID) 8024 ASUBXU(ISUBID)=ATEMP 8025 ENDIF 8026C 8027 IF(IFEEDB.EQ.'ON')THEN 8028 WRITE(ICOUT,999) 8029 CALL DPWRST('XXX','BUG ') 8030 WRITE(ICOUT,3125)ISUBID 8031 3125 FORMAT('THE SUBREGION Y LIMITS FOR SUBREGION ',I8) 8032 CALL DPWRST('XXX','BUG ') 8033 WRITE(ICOUT,3126)ASUBYL(ISUBID),ASUBYU(ISUBID) 8034 3126 FORMAT('HAVE JUST BEEN SET TO ',2G15.7) 8035 CALL DPWRST('XXX','BUG ') 8036 WRITE(ICOUT,3126)ASUBXL(ISUBID),ASUBXU(ISUBID) 8037 CALL DPWRST('XXX','BUG ') 8038 ENDIF 8039 GOTO9000 8040C 8041 3199 CONTINUE 8042 GOTO9000 8043C 8044C ******************************************** 8045C ** STEP 81-- ** 8046C ** TREAT THE ? CASE-- ** 8047C ** DUMP OUT CURRENT AND DEFAULT VALUES. ** 8048C ******************************************** 8049C 8050 8100 CONTINUE 8051 IFOUND='YES' 8052 DO8105I=1,MAXSUB 8053 WRITE(ICOUT,999) 8054 CALL DPWRST('XXX','BUG ') 8055 WRITE(ICOUT,8111)I 8056 8111 FORMAT('THE CURRENT SUBREGION ',I5,' LIMITS ARE ') 8057 CALL DPWRST('XXX','BUG ') 8058 WRITE(ICOUT,8112)ASUBXL(I),ASUBXU(I) 8059 8112 FORMAT(' --XLIMITS = ',2E15.7) 8060 CALL DPWRST('XXX','BUG ') 8061 WRITE(ICOUT,8113)ASUBYL(I),ASUBYU(I) 8062 8113 FORMAT(' --YLIMITS = ',2E15.7) 8063 CALL DPWRST('XXX','BUG ') 8064 8105 CONTINUE 8065 GOTO9000 8066C 8067C ***************** 8068C ** STEP 90-- ** 8069C ** EXIT ** 8070C ***************** 8071C 8072 9000 CONTINUE 8073 RETURN 8074 END 8075 SUBROUTINE DPSBSP(IFOUNO,IOP,XEND,YEND,HEIGHT,WIDTH, 8076 1 PHEIGH,PWIDTH,PVEGAP,PHOGAP, 8077 1 PHEIG2,PWIDT2,PVEGA2,PHOGA2, 8078 1 ANGLE,AMAX, 8079 1 IBUGD2,IERROR) 8080C 8081C PURPOSE--ADJUST XEND, YEND, HEIGHT, AND WIDTH 8082C WHEN ENTERING OR EXITING 8083C SUBSCRIPT OR SUPERSCRIPT MODE. 8084C NOTE--THE INPUT ARGUMENTS XEND, YEND, HEIGHT, AND WIDTH 8085C MAY BE CHANGED BY THIS SUBROUTINE. 8086C WRITTEN BY--JAMES J. FILLIBEN 8087C STATISTICAL ENGINEERING DIVISION 8088C INFORMATION TECHNOLOGY LABORATORY 8089C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 8090C GAITHERSBURG, MD 20899-8980 8091C PHONE--301-975-2899 8092C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 8093C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 8094C LANGUAGE--ANSI FORTRAN (1977) 8095C VERSION NUMBER--82/7 8096C ORIGINAL VERSION--APRIL 1981. 8097C UPDATED --MAY 1982. 8098C UPDATED --MARCH 2001. ALLOW SCALE FACTORS FOR 8099C SIZE OF SUPER/SUB/SCRIPTS 8100C 8101C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 8102C 8103 CHARACTER*4 IFOUNO 8104 CHARACTER*4 IOP 8105 CHARACTER*4 IBUGD2 8106 CHARACTER*4 IERROR 8107C 8108C-----COMMON---------------------------------------------------------- 8109C 8110 INCLUDE 'DPCOBE.INC' 8111 INCLUDE 'DPCOST.INC' 8112 INCLUDE 'DPCOP2.INC' 8113C 8114C-----START POINT----------------------------------------------------- 8115C 8116 IERROR='NO' 8117 SUBFAC=0.15 8118 SUPFAC=0.50 8119C 8120 IF(IBUGD2.EQ.'ON' .OR. ISUBG4.EQ.'SBSP')THEN 8121 WRITE(ICOUT,999) 8122 999 FORMAT(1X) 8123 CALL DPWRST('XXX','BUG ') 8124 WRITE(ICOUT,51) 8125 51 FORMAT('***** AT THE BEGINNING OF DPSBSP--') 8126 CALL DPWRST('XXX','BUG ') 8127 WRITE(ICOUT,52)IFOUNO,IOP 8128 52 FORMAT('IFOUNO,IOP = ',A4,2X,A4) 8129 CALL DPWRST('XXX','BUG ') 8130 WRITE(ICOUT,53)XEND,YEND,HEIGHT,WIDTH 8131 53 FORMAT('XEND,YEND,HEIGHT,WIDTH = ',4G15.7) 8132 CALL DPWRST('XXX','BUG ') 8133 WRITE(ICOUT,55)SUBFAC,SUPFAC,PSUPXS,PSUPYS 8134 55 FORMAT('SUBFAC,SUPFAC,PSUPXS,PSUPYS = ',4G15.7) 8135 CALL DPWRST('XXX','BUG ') 8136 WRITE(ICOUT,56)PHEIGH,PWIDTH,PVEGAP,PHOGAP 8137 56 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4G15.7) 8138 CALL DPWRST('XXX','BUG ') 8139 WRITE(ICOUT,57)PHEIG2,PWIDT2,PVEGA2,PHOGA2 8140 57 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4G15.7) 8141 CALL DPWRST('XXX','BUG ') 8142 WRITE(ICOUT,58)ANGLE,AMAX 8143 58 FORMAT('ANGLE,AMAX = ',2E15.7) 8144 CALL DPWRST('XXX','BUG ') 8145 WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4 8146 69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 8147 CALL DPWRST('XXX','BUG ') 8148 ENDIF 8149C 8150 THETA=(ANGLE/AMAX)*2.0*3.1315926 8151C 8152 IF(IFOUNO.EQ.'NO')GOTO1190 8153C 8154 IF(IOP.EQ.'SUB')GOTO1110 8155 IF(IOP.EQ.'UNSB')GOTO1120 8156 IF(IOP.EQ.'SUP')GOTO1130 8157 IF(IOP.EQ.'UNSP')GOTO1140 8158 GOTO1190 8159C 8160 1110 CONTINUE 8161CCCCC YEND=YEND-SUBFAC*HEIGHT 8162 XEND=XEND+SUBFAC*HEIGHT*SIN(THETA) 8163 YEND=YEND-SUBFAC*HEIGHT*COS(THETA) 8164CCCCC HEIGHT=HEIGHT/2.0 8165CCCCC WIDTH=WIDTH/2.0 8166CCCCC PHEIGH=PHEIGH/2.0 8167CCCCC PWIDTH=PWIDTH/2.0 8168CCCCC PVEGAP=PVEGAP/2.0 8169CCCCC PHOGAP=PHOGAP/2.0 8170CCCCC PHEIG2=PHEIG2/2.0 8171CCCCC PWIDT2=PWIDT2/2.0 8172CCCCC PVEGA2=PVEGA2/2.0 8173CCCCC PHOGA2=PHOGA2/2.0 8174 HEIGHT=HEIGHT/2.0 8175 WIDTH=WIDTH*PSUPXS 8176 PHEIGH=PHEIGH*PSUPYS 8177 PWIDTH=PWIDTH*PSUPXS 8178 PVEGAP=PVEGAP*PSUPYS 8179 PHOGAP=PHOGAP*PSUPXS 8180 PHEIG2=PHEIG2*PSUPYS 8181 PWIDT2=PWIDT2*PSUPXS 8182 PVEGA2=PVEGA2*PSUPYS 8183 PHOGA2=PHOGA2*PSUPXS 8184 GOTO1190 8185C 8186 1120 CONTINUE 8187CCCCC HEIGHT=HEIGHT*2.0 8188CCCCC WIDTH=WIDTH*2.0 8189CCCCC PHEIGH=PHEIGH*2.0 8190CCCCC PWIDTH=PWIDTH*2.0 8191CCCCC PVEGAP=PVEGAP*2.0 8192CCCCC PHOGAP=PHOGAP*2.0 8193CCCCC PHEIG2=PHEIG2*2.0 8194CCCCC PWIDT2=PWIDT2*2.0 8195CCCCC PVEGA2=PVEGA2*2.0 8196CCCCC PHOGA2=PHOGA2*2.0 8197 HEIGHT=HEIGHT*(1.0/PSUPYS) 8198 WIDTH=WIDTH*(1.0/PSUPXS) 8199 PHEIGH=PHEIGH*(1.0/PSUPYS) 8200 PWIDTH=PWIDTH*(1.0/PSUPXS) 8201 PVEGAP=PVEGAP*(1.0/PSUPYS) 8202 PHOGAP=PHOGAP*(1.0/PSUPXS) 8203 PHEIG2=PHEIG2*(1.0/PSUPYS) 8204 PWIDT2=PWIDT2*(1.0/PSUPXS) 8205 PVEGA2=PVEGA2*(1.0/PSUPYS) 8206 PHOGA2=PHOGA2*(1.0/PSUPXS) 8207CCCCC YEND=YEND+SUBFAC*HEIGHT 8208 XEND=XEND-SUBFAC*HEIGHT*SIN(THETA) 8209 YEND=YEND+SUBFAC*HEIGHT*COS(THETA) 8210 GOTO1190 8211C 8212 1130 CONTINUE 8213CCCCC YEND=YEND+SUPFAC*HEIGHT 8214 XEND=XEND-SUPFAC*HEIGHT*SIN(THETA) 8215 YEND=YEND+SUPFAC*HEIGHT*COS(THETA) 8216CCCCC HEIGHT=HEIGHT/2.0 8217CCCCC WIDTH=WIDTH/2.0 8218CCCCC PHEIGH=PHEIGH/2.0 8219CCCCC PWIDTH=PWIDTH/2.0 8220CCCCC PVEGAP=PVEGAP/2.0 8221CCCCC PHOGAP=PHOGAP/2.0 8222CCCCC PHEIG2=PHEIG2/2.0 8223CCCCC PWIDT2=PWIDT2/2.0 8224CCCCC PVEGA2=PVEGA2/2.0 8225CCCCC PHOGA2=PHOGA2/2.0 8226 HEIGHT=HEIGHT*PSUPYS 8227 WIDTH=WIDTH*PSUPXS 8228 PHEIGH=PHEIGH*PSUPYS 8229 PWIDTH=PWIDTH*PSUPXS 8230 PVEGAP=PVEGAP*PSUPYS 8231 PHOGAP=PHOGAP*PSUPXS 8232 PHEIG2=PHEIG2*PSUPYS 8233 PWIDT2=PWIDT2*PSUPXS 8234 PVEGA2=PVEGA2*PSUPYS 8235 PHOGA2=PHOGA2*PSUPXS 8236 GOTO1190 8237C 8238 1140 CONTINUE 8239CCCCC HEIGHT=HEIGHT*2.0 8240CCCCC WIDTH=WIDTH*2.0 8241CCCCC PHEIGH=PHEIGH*2.0 8242CCCCC PWIDTH=PWIDTH*2.0 8243CCCCC PVEGAP=PVEGAP*2.0 8244CCCCC PHOGAP=PHOGAP*2.0 8245CCCCC PHEIG2=PHEIG2*2.0 8246CCCCC PWIDT2=PWIDT2*2.0 8247CCCCC PVEGA2=PVEGA2*2.0 8248CCCCC PHOGA2=PHOGA2*2.0 8249 HEIGHT=HEIGHT*(1.0/PSUPYS) 8250 WIDTH=WIDTH*(1.0/PSUPXS) 8251 PHEIGH=PHEIGH*(1.0/PSUPYS) 8252 PWIDTH=PWIDTH*(1.0/PSUPXS) 8253 PVEGAP=PVEGAP*(1.0/PSUPYS) 8254 PHOGAP=PHOGAP*(1.0/PSUPXS) 8255 PHEIG2=PHEIG2*(1.0/PSUPYS) 8256 PWIDT2=PWIDT2*(1.0/PSUPXS) 8257 PVEGA2=PVEGA2*(1.0/PSUPYS) 8258 PHOGA2=PHOGA2*(1.0/PSUPXS) 8259CCCCC YEND=YEND-SUPFAC*HEIGHT 8260 XEND=XEND+SUPFAC*HEIGHT*SIN(THETA) 8261 YEND=YEND-SUPFAC*HEIGHT*COS(THETA) 8262 GOTO1190 8263C 8264 1190 CONTINUE 8265C 8266C ***************** 8267C ** STEP 90-- ** 8268C ** EXIT ** 8269C ***************** 8270C 8271 IF(IBUGG4.EQ.'ON' .OR. ISUBG4.EQ.'SBSP')THEN 8272 WRITE(ICOUT,999) 8273 CALL DPWRST('XXX','BUG ') 8274 WRITE(ICOUT,9011) 8275 9011 FORMAT('***** AT THE END OF DPSBSP--') 8276 CALL DPWRST('XXX','BUG ') 8277 WRITE(ICOUT,9012)IFOUNO,IOP,IERRG4 8278 9012 FORMAT('IFOUNO,IOP,IERRG4 = ',2(A4,2X),A4) 8279 CALL DPWRST('XXX','BUG ') 8280 WRITE(ICOUT,9013)XEND,YEND,HEIGHT,WIDTH 8281 9013 FORMAT('XEND,YEND,HEIGHT,WIDTH = ',4G15.7) 8282 CALL DPWRST('XXX','BUG ') 8283 WRITE(ICOUT,9015)SUBFAC,SUPFAC,ANGLE,AMAX,THETA 8284 9015 FORMAT('SUBFAC,SUPFAC,ANGLE,AMAX,THETA = ',5G15.7) 8285 CALL DPWRST('XXX','BUG ') 8286 WRITE(ICOUT,9016)PHEIGH,PWIDTH,PVEGAP,PHOGAP 8287 9016 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4G15.7) 8288 CALL DPWRST('XXX','BUG ') 8289 WRITE(ICOUT,9017)PHEIG2,PWIDT2,PVEGA2,PHOGA2 8290 9017 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4G15.7) 8291 CALL DPWRST('XXX','BUG ') 8292 ENDIF 8293C 8294 RETURN 8295 END 8296 SUBROUTINE DPSBSW(IHARG,NUMARG,IDEFSB,MAXSUB,ISUBSW, 8297 1 IBUGP2,IFOUND,IERROR) 8298C 8299C PURPOSE--DEFINE THE SUB-REGION SWITCHES. 8300C THESE ARE LOCATED IN THE VECTOR ISUBSW(.). 8301C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 8302C --NUMARG 8303C --IDEFSB 8304C --MAXSUB 8305C --IBUGP2 ('ON' OR 'OFF' ) 8306C OUTPUT ARGUMENTS--ISUBSW (A CHARACTER VECTOR) 8307C --IFOUND ('YES' OR 'NO' ) 8308C --IERROR ('YES' OR 'NO' ) 8309C WRITTEN BY--JAMES J. FILLIBEN 8310C STATISTICAL ENGINEERING DIVISION 8311C INFORMATION TECHNOLOGY LABORATORY 8312C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 8313C GAITHERSBURG, MD 20899-8980 8314C PHONE--301-975-2855 8315C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 8316C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 8317C LANGUAGE--ANSI FORTRAN (1977) 8318C VERSION NUMBER--99/11 8319C ORIGINAL VERSION--NOVEMBER 1999. 8320C 8321C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 8322C 8323 CHARACTER*4 IHARG 8324 CHARACTER*4 IDEFSB 8325 CHARACTER*4 ISUBSW 8326C 8327 CHARACTER*4 IBUGP2 8328 CHARACTER*4 IFOUND 8329 CHARACTER*4 IERROR 8330C 8331 CHARACTER*4 IHOLD1 8332 CHARACTER*4 IHOLD2 8333C 8334 CHARACTER*4 ISUBN1 8335 CHARACTER*4 ISUBN2 8336 CHARACTER*4 ISTEPN 8337C 8338 DIMENSION IHARG(*) 8339 DIMENSION ISUBSW(*) 8340C 8341C--------------------------------------------------------------------- 8342C 8343 INCLUDE 'DPCOP2.INC' 8344C 8345C-----START POINT----------------------------------------------------- 8346C 8347 IFOUND='NO' 8348 IERROR='NO' 8349 ISUBN1='DPSB' 8350 ISUBN2='SW ' 8351C 8352 NUMSUB=0 8353 IHOLD1='-999' 8354 IHOLD2='-999' 8355C 8356 IF(IBUGP2.EQ.'OFF')GOTO90 8357 WRITE(ICOUT,999) 8358 999 FORMAT(1X) 8359 CALL DPWRST('XXX','BUG ') 8360 WRITE(ICOUT,51) 8361 51 FORMAT('***** AT THE BEGINNING OF DPSBSW--') 8362 CALL DPWRST('XXX','BUG ') 8363 WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 8364 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 8365 CALL DPWRST('XXX','BUG ') 8366 WRITE(ICOUT,53)MAXSUB,NUMSUB 8367 53 FORMAT('MAXSUB,NUMSUB = ',I8,I8) 8368 CALL DPWRST('XXX','BUG ') 8369 WRITE(ICOUT,54)IHOLD1,IHOLD2 8370 54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 8371 CALL DPWRST('XXX','BUG ') 8372 WRITE(ICOUT,55)IDEFSB 8373 55 FORMAT('IDEFSB = ',A4) 8374 CALL DPWRST('XXX','BUG ') 8375 WRITE(ICOUT,60)NUMARG 8376 60 FORMAT('NUMARG = ',I8) 8377 CALL DPWRST('XXX','BUG ') 8378 DO65I=1,NUMARG 8379 WRITE(ICOUT,66)IHARG(I) 8380 66 FORMAT('IHARG(I) = ',A4) 8381 CALL DPWRST('XXX','BUG ') 8382 65 CONTINUE 8383 WRITE(ICOUT,70)ISUBSW(1) 8384 70 FORMAT('ISUBSW(1) = ',A4) 8385 CALL DPWRST('XXX','BUG ') 8386 DO75I=1,10 8387 WRITE(ICOUT,76)I,ISUBSW(I) 8388 76 FORMAT('I,ISUBSW(I) = ',I8,2X,A4) 8389 CALL DPWRST('XXX','BUG ') 8390 75 CONTINUE 8391 90 CONTINUE 8392C 8393C ************************************** 8394C ** STEP 1-- ** 8395C ** BRANCH TO THE APPROPRIATE CASE ** 8396C ************************************** 8397C 8398 ISTEPN='1' 8399 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8400C 8401 IF(NUMARG.LE.0)GOTO1100 8402 IF(NUMARG.EQ.1)GOTO1110 8403 IF(NUMARG.EQ.2)GOTO1120 8404 GOTO1130 8405C 8406 1100 CONTINUE 8407 GOTO1200 8408C 8409 1110 CONTINUE 8410 IF(IHARG(1).EQ.'ALL')IHOLD1='OFF' 8411 IF(IHARG(1).EQ.'ALL')GOTO1300 8412 GOTO1200 8413C 8414 1120 CONTINUE 8415 IF(IHARG(1).EQ.'ALL')IHOLD1=IHARG(2) 8416 IF(IHARG(1).EQ.'ALL')GOTO1300 8417 IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(1) 8418 IF(IHARG(2).EQ.'ALL')GOTO1300 8419 GOTO1200 8420C 8421 1130 CONTINUE 8422 GOTO1200 8423C 8424C ************************************************* 8425C ** STEP 2-- ** 8426C ** TREAT THE INDIVIDUAL SPECIFICATIONS CASE ** 8427C ************************************************* 8428C 8429 1200 CONTINUE 8430 ISTEPN='2' 8431 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8432C 8433 IF(NUMARG.LE.0)GOTO1210 8434 GOTO1220 8435C 8436 1210 CONTINUE 8437 NUMSUB=1 8438 ISUBSW(1)='ON' 8439 GOTO1270 8440C 8441 1220 CONTINUE 8442 NUMSUB=NUMARG 8443 IF(NUMSUB.GT.MAXSUB)NUMSUB=MAXSUB 8444 DO1225I=1,NUMSUB 8445 J=I 8446 IHOLD1=IHARG(J) 8447 IHOLD2=IHOLD1 8448 IF(IHOLD1.EQ.'ON')IHOLD2='ON' 8449 IF(IHOLD1.EQ.'OFF')IHOLD2='OFF' 8450 ISUBSW(I)=IHOLD2 8451 1225 CONTINUE 8452 GOTO1270 8453C 8454 1270 CONTINUE 8455 IF(IFEEDB.EQ.'OFF')GOTO1279 8456 WRITE(ICOUT,999) 8457 CALL DPWRST('XXX','BUG ') 8458 DO1278I=1,NUMSUB 8459 WRITE(ICOUT,1276)I,ISUBSW(I) 8460 1276 FORMAT('SUBREGION ',I6,' HAS JUST BEEN SET TO ', 8461 1A4) 8462 CALL DPWRST('XXX','BUG ') 8463 1278 CONTINUE 8464 1279 CONTINUE 8465 IFOUND='YES' 8466 GOTO9000 8467C 8468C ************************** 8469C ** STEP 2-- ** 8470C ** TREAT THE ALL CASE ** 8471C ************************** 8472C 8473 1300 CONTINUE 8474 ISTEPN='3' 8475 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8476C 8477 NUMSUB=MAXSUB 8478 IHOLD2=IHOLD1 8479 IF(IHOLD1.EQ.'ON')IHOLD2='ON' 8480 IF(IHOLD1.EQ.'OFF')IHOLD2='OFF' 8481 DO1315I=1,NUMSUB 8482 ISUBSW(I)=IHOLD2 8483 1315 CONTINUE 8484 GOTO1370 8485C 8486 1370 CONTINUE 8487 IF(IFEEDB.EQ.'OFF')GOTO1319 8488 WRITE(ICOUT,999) 8489 CALL DPWRST('XXX','BUG ') 8490 I=1 8491 WRITE(ICOUT,1316)ISUBSW(I) 8492 1316 FORMAT('ALL SPIKES HAVE JUST BEEN SET TO ', 8493 1A4) 8494 CALL DPWRST('XXX','BUG ') 8495 1319 CONTINUE 8496 IFOUND='YES' 8497 GOTO9000 8498C 8499C ***************** 8500C ** STEP 90-- ** 8501C ** EXIT ** 8502C ***************** 8503C 8504 9000 CONTINUE 8505 IF(IBUGP2.EQ.'OFF')GOTO9090 8506 WRITE(ICOUT,9011) 8507 9011 FORMAT('***** AT THE END OF DPSBSW--') 8508 CALL DPWRST('XXX','BUG ') 8509 WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 8510 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 8511 CALL DPWRST('XXX','BUG ') 8512 WRITE(ICOUT,9013)MAXSUB,NUMSUB 8513 9013 FORMAT('MAXSUB,NUMSUB = ',I8,I8) 8514 CALL DPWRST('XXX','BUG ') 8515 WRITE(ICOUT,9014)IHOLD1,IHOLD2 8516 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 8517 CALL DPWRST('XXX','BUG ') 8518 WRITE(ICOUT,9015)IDEFSB 8519 9015 FORMAT('IDEFSB = ',A4) 8520 CALL DPWRST('XXX','BUG ') 8521 WRITE(ICOUT,9020)NUMARG 8522 9020 FORMAT('NUMARG = ',I8) 8523 CALL DPWRST('XXX','BUG ') 8524 DO9025I=1,NUMARG 8525 WRITE(ICOUT,9026)IHARG(I) 8526 9026 FORMAT('IHARG(I) = ',A4) 8527 CALL DPWRST('XXX','BUG ') 8528 9025 CONTINUE 8529 WRITE(ICOUT,9030)ISUBSW(1) 8530 9030 FORMAT('ISUBSW(1) = ',A4) 8531 CALL DPWRST('XXX','BUG ') 8532 DO9035I=1,10 8533 WRITE(ICOUT,9036)I,ISUBSW(I) 8534 9036 FORMAT('I,ISUBSW(I) = ',I8,2X,A4) 8535 CALL DPWRST('XXX','BUG ') 8536 9035 CONTINUE 8537 9090 CONTINUE 8538C 8539 RETURN 8540 END 8541 SUBROUTINE DPSCAN(ISTART,ISTRIN,NUMCHS,ILOCR2, 8542 1ICHAR2,IOP,IFONT,ICASE,IJUST,ISEQUE,ISUBSU, 8543 1HMAX,VMAX,AMAX,X0,Y0,ANGLE,WIDTH,HEIGHT, 8544 1IEND,IFOUNC,IFOUNO,IBUGD2,IERROR) 8545C 8546C PURPOSE--SCAN THE STRING IN ISTRIN(.) STARTING WITH POSITION ISTART. 8547C EXAMINE THE NEXT 6 CHARACTERS AT MOST. 8548C COPY AND PACK THE NEXT 4 CHARACTERS INTO IWORD1. 8549C IF () FOUND IN NEXT 6 CHARACTERS, THEN STRIP OFF () 8550C AND SAVE PREVIOUS INTO IWORD1 (PACKED). 8551C | IF() NOT FOUND, THEN OUTPUT A SINGLE CHARACTER IN IWORD1. 8552C WRITTEN BY--JAMES J. FILLIBEN 8553C STATISTICAL ENGINEERING DIVISION 8554C INFORMATION TECHNOLOGY LABORATORY 8555C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 8556C GAITHERSBURG, MD 20899-8980 8557C PHONE--301-975-2899 8558C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 8559C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 8560C LANGUAGE--ANSI FORTRAN (1977) 8561C VERSION NUMBER--82/7 8562C ORIGINAL VERSION--JANUARY 1981. 8563C UPDATED --OCTOBER 1981. 8564C UPDATED --MAY 1982. 8565C UPDATED --APRIL 1987. 8566C UPDATED --AUGUST 1992. ADDITIONAL SYMBOLS 8567C UPDATED --FEBRUARY 1995. CONVERT IWORD1 TO UPPER CASE 8568C (CASE ASIS COMPLICATION) 8569C UPDATED --NOVEMBER 1996. COMPILE ERROR FOR LINIX G77 8570C 8571C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 8572C 8573 CHARACTER*4 ISTRIN 8574 CHARACTER*4 ICHAR2 8575 CHARACTER*4 IOP 8576 CHARACTER*4 IFONT 8577 CHARACTER*4 ICASE 8578 CHARACTER*4 IJUST 8579 CHARACTER*4 ISEQUE 8580 CHARACTER*4 ISUBSU 8581 CHARACTER*4 IFOUNC 8582 CHARACTER*4 IFOUNO 8583 CHARACTER*4 IBUGD2 8584 CHARACTER*4 IERROR 8585C 8586 CHARACTER*4 IWORD1 8587 CHARACTER*4 IXXXXX 8588 CHARACTER*4 IFOULR 8589 CHARACTER*4 IOPERT 8590 CHARACTER*4 IGREET 8591 CHARACTER*4 IMATHT 8592C 8593CCCCC CHARACTER*4 ICHAR3 8594C 8595 CHARACTER*4 ISUBN1 8596 CHARACTER*4 ISUBN2 8597 CHARACTER*4 ISTEPN 8598C 8599C--------------------------------------------------------------------- 8600C 8601 DIMENSION ISTRIN(*) 8602C 8603 DIMENSION IOPERT(50) 8604 DIMENSION IGREET(25) 8605 DIMENSION IMATHT(200) 8606C 8607 DIMENSION IOPERN(50) 8608 DIMENSION IGREEN(25) 8609 DIMENSION IMATHN(200) 8610C 8611C-----COMMON---------------------------------------------------------- 8612C 8613 INCLUDE 'DPCOBE.INC' 8614 INCLUDE 'DPCOP2.INC' 8615C 8616C-----DATA STATEMENTS------------------------------------------------- 8617C 8618C ************************* 8619C ** DEFINE OPERATIONS ** 8620C ************************* 8621C 8622 DATA IOPERT( 1) /'SIMP'/ 8623 DATA IOPERT( 2) /'DUPL'/ 8624 DATA IOPERT( 3) /'TRIP'/ 8625 DATA IOPERT( 4) /'COMP'/ 8626 DATA IOPERT( 5) /'TRII'/ 8627 DATA IOPERT( 6) /'COMI'/ 8628 DATA IOPERT( 7) /'SIMS'/ 8629 DATA IOPERT( 8) /'COMS'/ 8630C 8631 DATA IOPERT( 9) /'UC '/ 8632 DATA IOPERT(10) /'CAP '/ 8633 DATA IOPERT(11) /'CAPS'/ 8634 DATA IOPERT(12) /'LC '/ 8635C 8636 DATA IOPERT(13) /'LJUS'/ 8637 DATA IOPERT(14) /'CJUS'/ 8638 DATA IOPERT(15) /'RJUS'/ 8639C 8640 DATA IOPERT(16) /'SEQ '/ 8641 DATA IOPERT(17) /'UNSQ'/ 8642C 8643 DATA IOPERT(18) /'SUB '/ 8644 DATA IOPERT(19) /'UNSB'/ 8645 DATA IOPERT(20) /'SUP '/ 8646 DATA IOPERT(21) /'UNSP'/ 8647C 8648 DATA IOPERT(22) /'HMAX'/ 8649 DATA IOPERT(23) /'VMAX'/ 8650 DATA IOPERT(24) /'ANGL'/ 8651 DATA IOPERT(25) /'HEIG'/ 8652 DATA IOPERT(26) /'WIDT'/ 8653 DATA IOPERT(27) /'ANGL'/ 8654C 8655 DATA IOPERT(28) /'MOVE'/ 8656 DATA IOPERT(29) /'DRAW'/ 8657 DATA IOPERT(30) /'RELM'/ 8658 DATA IOPERT(31) /'RELD'/ 8659C 8660 DATA IOPERT(32) /'BACK'/ 8661 DATA IOPERT(33) /'OVER'/ 8662 DATA IOPERT(34) /'UP '/ 8663 DATA IOPERT(35) /'DOWN'/ 8664 DATA IOPERT(36) /'TAB '/ 8665 DATA IOPERT(37) /'RETU'/ 8666C 8667C ******************************* 8668C ** DEFINE GREEK CHARACTERS ** 8669C ******************************* 8670C 8671 DATA IGREET( 1) /'ALPH'/ 8672 DATA IGREET( 2) /'BETA'/ 8673 DATA IGREET( 3) /'GAMM'/ 8674 DATA IGREET( 4) /'DELT'/ 8675 DATA IGREET( 5) /'EPSI'/ 8676 DATA IGREET( 6) /'ZETA'/ 8677 DATA IGREET( 7) /'ETA '/ 8678 DATA IGREET( 8) /'THET'/ 8679 DATA IGREET( 9) /'IOTA'/ 8680 DATA IGREET(10) /'KAPP'/ 8681 DATA IGREET(11) /'LAMB'/ 8682 DATA IGREET(12) /'MU '/ 8683 DATA IGREET(13) /'NU '/ 8684 DATA IGREET(14) /'XI '/ 8685 DATA IGREET(15) /'OMIC'/ 8686 DATA IGREET(16) /'PI '/ 8687 DATA IGREET(17) /'RHO '/ 8688 DATA IGREET(18) /'SIGM'/ 8689 DATA IGREET(19) /'TAU '/ 8690 DATA IGREET(20) /'UPSI'/ 8691 DATA IGREET(21) /'PHI '/ 8692 DATA IGREET(22) /'CHI '/ 8693 DATA IGREET(23) /'PSI '/ 8694 DATA IGREET(24) /'OMEG'/ 8695C 8696C *************************** 8697C ** DEFINE MATH SYMBOLS ** 8698C *************************** 8699C 8700 DATA IMATHT( 1) /'HASP'/ 8701 DATA IMATHT( 2) /'SPAC'/ 8702 DATA IMATHT( 3) /'SP '/ 8703 DATA IMATHT( 4) /'LAPO'/ 8704 DATA IMATHT( 5) /'RAPO'/ 8705 DATA IMATHT( 6) /'LBRA'/ 8706 DATA IMATHT( 7) /'RBRA'/ 8707 DATA IMATHT( 8) /'LCBR'/ 8708 DATA IMATHT( 9) /'RCBR'/ 8709 DATA IMATHT(10) /'LELB'/ 8710 DATA IMATHT(11) /'RELB'/ 8711 DATA IMATHT(12) /'+- '/ 8712 DATA IMATHT(13) /'-+ '/ 8713 DATA IMATHT(14) /'TIME'/ 8714 DATA IMATHT(15) /'DOTP'/ 8715 DATA IMATHT(16) /'DIVI'/ 8716 DATA IMATHT(17) /'NOT='/ 8717 DATA IMATHT(18) /'EQUI'/ 8718 DATA IMATHT(19) /'LT '/ 8719 DATA IMATHT(20) /'GT '/ 8720 DATA IMATHT(21) /'LTEQ'/ 8721 DATA IMATHT(22) /'GTEQ'/ 8722 DATA IMATHT(23) /'VARI'/ 8723 DATA IMATHT(24) /'APPR'/ 8724 DATA IMATHT(25) /'TILD'/ 8725 DATA IMATHT(26) /'CARA'/ 8726 DATA IMATHT(27) /'RACC'/ 8727 DATA IMATHT(28) /'PRIM'/ 8728 DATA IMATHT(29) /'LACC'/ 8729 DATA IMATHT(30) /'BREV'/ 8730 DATA IMATHT(31) /'RQUO'/ 8731 DATA IMATHT(32) /'LQUO'/ 8732 DATA IMATHT(33) /'NASP'/ 8733 DATA IMATHT(34) /'IASP'/ 8734 DATA IMATHT(35) /'RADI'/ 8735 DATA IMATHT(36) /'LRAD'/ 8736 DATA IMATHT(37) /'BRAD'/ 8737 DATA IMATHT(38) /'SUBS'/ 8738 DATA IMATHT(39) /'SUPE'/ 8739 DATA IMATHT(40) /'UNIO'/ 8740 DATA IMATHT(41) /'INTR'/ 8741 DATA IMATHT(42) /'ELEM'/ 8742 DATA IMATHT(43) /'RARR'/ 8743 DATA IMATHT(44) /'LARR'/ 8744 DATA IMATHT(45) /'UARR'/ 8745 DATA IMATHT(46) /'DARR'/ 8746 DATA IMATHT(47) /'PART'/ 8747 DATA IMATHT(48) /'INTE'/ 8748 DATA IMATHT(49) /'CINT'/ 8749 DATA IMATHT(50) /'SUMM'/ 8750 DATA IMATHT(51) /'PROD'/ 8751 DATA IMATHT(52) /'INFI'/ 8752 DATA IMATHT(53) /'PARA'/ 8753 DATA IMATHT(54) /'DAGG'/ 8754 DATA IMATHT(55) /'DDAG'/ 8755 DATA IMATHT(56) /'THEX'/ 8756 DATA IMATHT(57) /'THFO'/ 8757 DATA IMATHT(58) /'VBAR'/ 8758 DATA IMATHT(59) /'DVBA'/ 8759 DATA IMATHT(60) /'LVBA'/ 8760 DATA IMATHT(61) /'HBAR'/ 8761 DATA IMATHT(62) /'LHBA'/ 8762 DATA IMATHT(63) /'HHBA'/ 8763 DATA IMATHT(64) /'BAR '/ 8764 DATA IMATHT(65) /'DEL '/ 8765C 8766 DATA IMATHT(66) /'ZZZZ'/ 8767 DATA IMATHT(67) /'ZZZZ'/ 8768 DATA IMATHT(68) /'ZZZZ'/ 8769 DATA IMATHT(69) /'ZZZZ'/ 8770 DATA IMATHT(70) /'ZZZZ'/ 8771C 8772 DATA IMATHT(71) /'. '/ 8773 DATA IMATHT(72) /'POIN'/ 8774 DATA IMATHT(73) /'PO '/ 8775 DATA IMATHT(74) /'PT '/ 8776 DATA IMATHT(75) /'CIRC'/ 8777 DATA IMATHT(76) /'CI '/ 8778 DATA IMATHT(77) /'SQUA'/ 8779 DATA IMATHT(78) /'SQ '/ 8780 DATA IMATHT(79) /'TRIA'/ 8781 DATA IMATHT(80) /'TR '/ 8782 DATA IMATHT(81) /'DIAM'/ 8783 DATA IMATHT(82) /'DI '/ 8784 DATA IMATHT(83) /'STAR'/ 8785 DATA IMATHT(84) /'ST '/ 8786 DATA IMATHT(85) /'* '/ 8787 DATA IMATHT(86) /'ASTE'/ 8788 DATA IMATHT(87) /'AS '/ 8789 DATA IMATHT(88) /'TRIR'/ 8790 DATA IMATHT(89) /'TRII'/ 8791 DATA IMATHT(90) /'BARU'/ 8792 DATA IMATHT(91) /'BU '/ 8793 DATA IMATHT(92) /'BARV'/ 8794 DATA IMATHT(93) /'BV '/ 8795 DATA IMATHT(94) /'BARH'/ 8796 DATA IMATHT(95) /'BH '/ 8797 DATA IMATHT(96) /'ARRU'/ 8798 DATA IMATHT(97) /'AU '/ 8799 DATA IMATHT(98) /'ARRD'/ 8800 DATA IMATHT(99) /'AD '/ 8801 DATA IMATHT(100) /'ARRL'/ 8802 DATA IMATHT(101) /'AL '/ 8803 DATA IMATHT(102) /'ARRR'/ 8804 DATA IMATHT(103) /'AR '/ 8805CCCCC NOVEMBER 1996. FOLLOWING LINE CAUSES COMPILE ERROR ON LINUX 8806CCCCC G77 COMPILER. 8807CLINX DATA IMATHT(104) /'\ '/ 8808 DATA IMATHT(105) /'BASL'/ 8809 DATA IMATHT(106) /'BACK'/ 8810 DATA IMATHT(107) /'BS '/ 8811 DATA IMATHT(108) /'_ '/ 8812 DATA IMATHT(109) /'UNDE'/ 8813 DATA IMATHT(110) /'CUBE'/ 8814 DATA IMATHT(111) /'PYRA'/ 8815C AUGUST 1992. ADD REVT, RT (FOR REVERSE TRIANGLE, TO AGREE WITH 8816C DOCUMENTATION), AND ARRO, ARRH, VECT FOR THE ARROW COMMAND 8817 DATA IMATHT(112) /'REVT'/ 8818 DATA IMATHT(113) /'RT '/ 8819 DATA IMATHT(114) /'ARRO'/ 8820 DATA IMATHT(115) /'ARRH'/ 8821 DATA IMATHT(116) /'VECT'/ 8822 DATA IMATHT(117) /'DEGR'/ 8823C 8824C--------------------------------------------------------------------- 8825C 8826C ****************************************************** 8827C ** DEFINE THE NUMBER OF CHARACTERS FOR OPERATIONS ** 8828C ****************************************************** 8829C 8830 DATA IOPERN( 1) /4/ 8831 DATA IOPERN( 2) /4/ 8832 DATA IOPERN( 3) /4/ 8833 DATA IOPERN( 4) /4/ 8834 DATA IOPERN( 5) /4/ 8835 DATA IOPERN( 6) /4/ 8836 DATA IOPERN( 7) /4/ 8837 DATA IOPERN( 8) /4/ 8838C 8839 DATA IOPERN( 9) /2/ 8840 DATA IOPERN(10) /3/ 8841 DATA IOPERN(11) /4/ 8842 DATA IOPERN(12) /2/ 8843C 8844 DATA IOPERN(13) /4/ 8845 DATA IOPERN(14) /4/ 8846 DATA IOPERN(15) /4/ 8847C 8848 DATA IOPERN(16) /3/ 8849 DATA IOPERN(17) /4/ 8850C 8851 DATA IOPERN(18) /3/ 8852 DATA IOPERN(19) /4/ 8853 DATA IOPERN(20) /3/ 8854 DATA IOPERN(21) /4/ 8855C 8856 DATA IOPERN(22) /4/ 8857 DATA IOPERN(23) /4/ 8858 DATA IOPERN(24) /4/ 8859 DATA IOPERN(25) /4/ 8860 DATA IOPERN(26) /4/ 8861 DATA IOPERN(27) /4/ 8862C 8863 DATA IOPERN(28) /4/ 8864 DATA IOPERN(29) /4/ 8865 DATA IOPERN(30) /4/ 8866 DATA IOPERN(31) /4/ 8867C 8868 DATA IOPERN(32) /4/ 8869 DATA IOPERN(33) /4/ 8870 DATA IOPERN(34) /2/ 8871 DATA IOPERN(35) /4/ 8872 DATA IOPERN(36) /3/ 8873 DATA IOPERN(37) /4/ 8874C 8875C ************************************************************ 8876C ** DEFINE THE NUMBER OF CHARACTERS FOR GREEK CHARACTERS ** 8877C ************************************************************ 8878C 8879 DATA IGREEN( 1) /4/ 8880 DATA IGREEN( 2) /4/ 8881 DATA IGREEN( 3) /4/ 8882 DATA IGREEN( 4) /4/ 8883 DATA IGREEN( 5) /4/ 8884 DATA IGREEN( 6) /4/ 8885 DATA IGREEN( 7) /3/ 8886 DATA IGREEN( 8) /4/ 8887 DATA IGREEN( 9) /4/ 8888 DATA IGREEN(10) /4/ 8889 DATA IGREEN(11) /4/ 8890 DATA IGREEN(12) /2/ 8891 DATA IGREEN(13) /2/ 8892 DATA IGREEN(14) /2/ 8893 DATA IGREEN(15) /4/ 8894 DATA IGREEN(16) /2/ 8895 DATA IGREEN(17) /3/ 8896 DATA IGREEN(18) /4/ 8897 DATA IGREEN(19) /3/ 8898 DATA IGREEN(20) /4/ 8899 DATA IGREEN(21) /3/ 8900 DATA IGREEN(22) /3/ 8901 DATA IGREEN(23) /3/ 8902 DATA IGREEN(24) /4/ 8903C 8904C ******************************************************** 8905C ** DEFINE THE NUMBER OF CHARACTERS FOR MATH SYMBOLS ** 8906C ******************************************************** 8907C 8908 DATA IMATHN( 1) /4/ 8909 DATA IMATHN( 2) /4/ 8910 DATA IMATHN( 3) /2/ 8911 DATA IMATHN( 4) /4/ 8912 DATA IMATHN( 5) /4/ 8913 DATA IMATHN( 6) /4/ 8914 DATA IMATHN( 7) /4/ 8915 DATA IMATHN( 8) /4/ 8916 DATA IMATHN( 9) /4/ 8917 DATA IMATHN(10) /4/ 8918 DATA IMATHN(11) /4/ 8919 DATA IMATHN(12) /2/ 8920 DATA IMATHN(13) /2/ 8921 DATA IMATHN(14) /4/ 8922 DATA IMATHN(15) /4/ 8923 DATA IMATHN(16) /4/ 8924 DATA IMATHN(17) /4/ 8925 DATA IMATHN(18) /4/ 8926 DATA IMATHN(19) /2/ 8927 DATA IMATHN(20) /2/ 8928 DATA IMATHN(21) /4/ 8929 DATA IMATHN(22) /4/ 8930 DATA IMATHN(23) /4/ 8931 DATA IMATHN(24) /4/ 8932 DATA IMATHN(25) /4/ 8933 DATA IMATHN(26) /4/ 8934 DATA IMATHN(27) /4/ 8935 DATA IMATHN(28) /4/ 8936 DATA IMATHN(29) /4/ 8937 DATA IMATHN(30) /4/ 8938 DATA IMATHN(31) /4/ 8939 DATA IMATHN(32) /4/ 8940 DATA IMATHN(33) /4/ 8941 DATA IMATHN(34) /4/ 8942 DATA IMATHN(35) /4/ 8943 DATA IMATHN(36) /4/ 8944 DATA IMATHN(37) /4/ 8945 DATA IMATHN(38) /4/ 8946 DATA IMATHN(39) /4/ 8947 DATA IMATHN(40) /4/ 8948 DATA IMATHN(41) /4/ 8949 DATA IMATHN(42) /4/ 8950 DATA IMATHN(43) /4/ 8951 DATA IMATHN(44) /4/ 8952 DATA IMATHN(45) /4/ 8953 DATA IMATHN(46) /4/ 8954 DATA IMATHN(47) /4/ 8955 DATA IMATHN(48) /4/ 8956 DATA IMATHN(49) /4/ 8957 DATA IMATHN(50) /4/ 8958 DATA IMATHN(51) /4/ 8959 DATA IMATHN(52) /4/ 8960 DATA IMATHN(53) /4/ 8961 DATA IMATHN(54) /4/ 8962 DATA IMATHN(55) /4/ 8963 DATA IMATHN(56) /4/ 8964 DATA IMATHN(57) /4/ 8965 DATA IMATHN(58) /4/ 8966 DATA IMATHN(59) /4/ 8967 DATA IMATHN(60) /4/ 8968 DATA IMATHN(61) /4/ 8969 DATA IMATHN(62) /4/ 8970 DATA IMATHN(63) /4/ 8971 DATA IMATHN(64) /3/ 8972 DATA IMATHN(65) /3/ 8973C 8974 DATA IMATHN(66) /4/ 8975 DATA IMATHN(67) /4/ 8976 DATA IMATHN(68) /4/ 8977 DATA IMATHN(69) /4/ 8978 DATA IMATHN(70) /4/ 8979C 8980 DATA IMATHN(71) /1/ 8981 DATA IMATHN(72) /4/ 8982 DATA IMATHN(73) /2/ 8983 DATA IMATHN(74) /2/ 8984 DATA IMATHN(75) /4/ 8985 DATA IMATHN(76) /2/ 8986 DATA IMATHN(77) /4/ 8987 DATA IMATHN(78) /2/ 8988 DATA IMATHN(79) /4/ 8989 DATA IMATHN(80) /2/ 8990 DATA IMATHN(81) /4/ 8991 DATA IMATHN(82) /2/ 8992 DATA IMATHN(83) /4/ 8993 DATA IMATHN(84) /2/ 8994 DATA IMATHN(85) /1/ 8995 DATA IMATHN(86) /4/ 8996 DATA IMATHN(87) /2/ 8997 DATA IMATHN(88) /4/ 8998 DATA IMATHN(89) /4/ 8999 DATA IMATHN(90) /4/ 9000 DATA IMATHN(91) /2/ 9001 DATA IMATHN(92) /4/ 9002 DATA IMATHN(93) /2/ 9003 DATA IMATHN(94) /4/ 9004 DATA IMATHN(95) /2/ 9005 DATA IMATHN(96) /4/ 9006 DATA IMATHN(97) /2/ 9007 DATA IMATHN(98) /4/ 9008 DATA IMATHN(99) /2/ 9009 DATA IMATHN(100) /4/ 9010 DATA IMATHN(101) /2/ 9011 DATA IMATHN(102) /4/ 9012 DATA IMATHN(103) /2/ 9013 DATA IMATHN(104) /1/ 9014 DATA IMATHN(105) /4/ 9015 DATA IMATHN(106) /4/ 9016 DATA IMATHN(107) /2/ 9017 DATA IMATHN(108) /1/ 9018 DATA IMATHN(109) /4/ 9019 DATA IMATHN(110) /4/ 9020 DATA IMATHN(111) /4/ 9021C 9022C AUGUST 1992. ADDED FOLLOWING LINES FOR REVERSE TRIANGLE SYNONYMS 9023C AND FOR ARROW. 9024C 9025 DATA IMATHN(112) /4/ 9026 DATA IMATHN(113) /2/ 9027 DATA IMATHN(114) /4/ 9028 DATA IMATHN(115) /4/ 9029 DATA IMATHN(116) /4/ 9030 DATA IMATHN(117) /4/ 9031C 9032C-----START POINT----------------------------------------------------- 9033C 9034 ISUBN1='DPSC' 9035 ISUBN2='AN ' 9036C 9037 IFOUNO='NO' 9038 IFOUNC='NO' 9039 IERROR='NO' 9040C 9041CLINX NOVEMBER 1996. FOLLOWING TO ACCOMODATE LINUX G77 COMPILER. 9042 CALL DPCONA(92,IMATHT(104)) 9043 J2=0 9044 NUMC=0 9045C 9046 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SCAN')GOTO90 9047 WRITE(ICOUT,999) 9048 999 FORMAT(1X) 9049 CALL DPWRST('XXX','BUG ') 9050 WRITE(ICOUT,51) 9051 51 FORMAT('***** AT THE BEGINNING OF DPSCAN--') 9052 CALL DPWRST('XXX','BUG ') 9053 WRITE(ICOUT,52)ISTART,ISTRIN(ISTART),NUMCHS,ILOCR2 9054 52 FORMAT('ISTART,ISTRIN(ISTART),NUMCHS,ILOCR2 = ',I8,2X,A4,2I8) 9055 CALL DPWRST('XXX','BUG ') 9056 WRITE(ICOUT,53)(ISTRIN(I),I=1,NUMCHS) 9057 53 FORMAT('(ISTRIN(I),I=1,NUMCHS) = ',100A1) 9058 CALL DPWRST('XXX','BUG ') 9059 WRITE(ICOUT,59)IBUGG4,ISUBG4 9060 59 FORMAT('IBUGG4,ISUBG4 = ',A4,2X,A4) 9061 CALL DPWRST('XXX','BUG ') 9062 90 CONTINUE 9063C 9064C ********************************************* 9065C ** STEP 2-- ** 9066C ** PACK THE PRESENT CHARACTER ** 9067C ** AND THE NEXT 3 CHARACTERS INTO ** 9068C ** THE SINGLE COMPUTER WORD IWORD1. ** 9069C ** IF A LEFT PARENTHESIS IS ENCOUNTERED, ** 9070C ** STOP THE PACK ** 9071C ** (AND EXCLUDE THE LEFT PARENTHESIS ** 9072C ** FROM THE PACK). ** 9073C ********************************************* 9074C 9075 ISTEPN='2' 9076 IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9077C 9078 IWORD1=' ' 9079C 9080 ISTAR1=0 9081 ILEN1=NUMBPC 9082 ILEN2=NUMBPC 9083C 9084 DO1100K=1,4 9085 L=ISTART+K-1 9086 IF(L.GT.NUMCHS)GOTO1190 9087 IF(ISTRIN(L).EQ.'(')GOTO1190 9088 ISTAR2=NUMBPC*(K-1) 9089 CALL DPCHEX(ISTAR1,ILEN1,ISTRIN(L),ISTAR2,ILEN2,IWORD1) 9090 1100 CONTINUE 9091 1190 CONTINUE 9092CCCCC CONVERT IWORD1 TO UPPER CASE. FEBRUARY 1995. 9093 DO1191I=1,4 9094 CALL DPCOAN(IWORD1(I:I),IVALT) 9095 IF(IVALT.GE.97.AND.IVALT.LE.122)IVALT=IVALT-32 9096 CALL DPCONA(IVALT,IWORD1(I:I)) 9097 1191 CONTINUE 9098C 9099C ************************************************************* 9100C ** STEP 1--CHECK TO SEE ** 9101C ** IF BEYOND THE RIGHTMOST RIGHT PARENTHESIS ** 9102C ** (WHICH IMPLIES THAT ALL SUBSEQUENT CHARACTERS ** 9103C ** ARE ONLY 1 CHARACTER LONG). ** 9104C ************************************************************* 9105C 9106 IF(ISTART.GT.ILOCR2)GOTO6000 9107C 9108C *************************** 9109C ** STEP 3.1-- ** 9110C ** CHECK FOR FONT TYPE ** 9111C *************************** 9112C 9113 ISTEPN='3.1' 9114 IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9115C 9116 JMIN=1 9117 JMAX=8 9118 DO2110J=JMIN,JMAX 9119 J2=J 9120 IF(IWORD1.EQ.IOPERT(J))GOTO2150 9121 2110 CONTINUE 9122 GOTO2190 9123 2150 CONTINUE 9124 NUMC=IOPERN(J2) 9125 ILOCLP=ISTART+NUMC 9126 ILOCRP=ISTART+NUMC+1 9127 CALL DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUGD2,IERROR) 9128 IF(IFOULR.EQ.'YES')GOTO2160 9129 GOTO2190 9130 2160 CONTINUE 9131 IFONT=IWORD1 9132 IEND=ILOCRP 9133 IOP=IFONT 9134 IFOUNO='YES' 9135 GOTO9000 9136 2190 CONTINUE 9137C 9138C ********************************** 9139C ** STEP 3.2-- ** 9140C ** CHECK FOR UPPER/LOWER CASE ** 9141C ********************************** 9142C 9143 ISTEPN='3.2' 9144 IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9145C 9146C 9147 JMIN=9 9148 JMAX=12 9149 DO2210J=JMIN,JMAX 9150 J2=J 9151 IF(IWORD1.EQ.IOPERT(J))GOTO2250 9152 2210 CONTINUE 9153 GOTO2290 9154 2250 CONTINUE 9155 NUMC=IOPERN(J2) 9156 ILOCLP=ISTART+NUMC 9157 ILOCRP=ISTART+NUMC+1 9158 CALL DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUGD2,IERROR) 9159 IF(IFOULR.EQ.'YES')GOTO2260 9160 GOTO2290 9161 2260 CONTINUE 9162 ICASE=IWORD1 9163 IF(ICASE.EQ.'LC')ICASE='LOWE' 9164 IF(ICASE.EQ.'LCAS')ICASE='LOWE' 9165 IF(ICASE.EQ.'UC')ICASE='UPPE' 9166 IF(ICASE.EQ.'UCAS')ICASE='UPPE' 9167 IF(ICASE.EQ.'CAPS')ICASE='UPPE' 9168 IF(ICASE.EQ.'CAP')ICASE='UPPE' 9169 IEND=ILOCRP 9170 IOP=ICASE 9171 IFOUNO='YES' 9172 GOTO9000 9173 2290 CONTINUE 9174C 9175C ************************************************* 9176C ** STEP 3.3-- ** 9177C ** CHECK FOR LEFT/CENTER/RIGHT JUSTIFICATION ** 9178C ************************************************* 9179C 9180 ISTEPN='3.3' 9181 IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9182C 9183 JMIN=13 9184 JMAX=15 9185 DO2310J=JMIN,JMAX 9186 J2=J 9187 IF(IWORD1.EQ.IOPERT(J))GOTO2350 9188 2310 CONTINUE 9189 GOTO2390 9190 2350 CONTINUE 9191 NUMC=IOPERN(J2) 9192 ILOCLP=ISTART+NUMC 9193 ILOCRP=ISTART+NUMC+1 9194 CALL DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUGD2,IERROR) 9195 IF(IFOULR.EQ.'YES')GOTO2360 9196 GOTO2390 9197 2360 CONTINUE 9198 IJUST=IWORD1 9199 IEND=ILOCRP 9200 IOP=IJUST 9201 IFOUNO='YES' 9202 GOTO9000 9203 2390 CONTINUE 9204C 9205C ****************************************** 9206C ** STEP 3.4-- ** 9207C ** CHECK FOR SEQUENCE/UNSEQUENCE CASE ** 9208C ****************************************** 9209C 9210 ISTEPN='3.4' 9211 IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9212C 9213 JMIN=16 9214 JMAX=17 9215 DO2410J=JMIN,JMAX 9216 J2=J 9217 IF(IWORD1.EQ.IOPERT(J))GOTO2450 9218 2410 CONTINUE 9219 GOTO2490 9220 2450 CONTINUE 9221 NUMC=IOPERN(J2) 9222 ILOCLP=ISTART+NUMC 9223 ILOCRP=ISTART+NUMC+1 9224 CALL DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUGD2,IERROR) 9225 IF(IFOULR.EQ.'YES')GOTO2460 9226 GOTO2490 9227 2460 CONTINUE 9228 ISEQUE=IWORD1 9229 IEND=ILOCRP 9230 IOP=ISEQUE 9231 IFOUNO='YES' 9232 GOTO9000 9233 2490 CONTINUE 9234C 9235C ******************************************** 9236C ** STEP 3.5-- ** 9237C ** CHECK FOR SUBSCRIPT/SUPERSCRIPT CASE ** 9238C ******************************************** 9239C 9240 ISTEPN='3.5' 9241 IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9242C 9243 JMIN=18 9244 JMAX=21 9245 DO2510J=JMIN,JMAX 9246 J2=J 9247 IF(IWORD1.EQ.IOPERT(J))GOTO2550 9248 2510 CONTINUE 9249 GOTO2590 9250 2550 CONTINUE 9251 NUMC=IOPERN(J2) 9252 ILOCLP=ISTART+NUMC 9253 ILOCRP=ISTART+NUMC+1 9254 CALL DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUGD2,IERROR) 9255 IF(IFOULR.EQ.'YES')GOTO2560 9256 GOTO2590 9257 2560 CONTINUE 9258 ISUBSU=IWORD1 9259 IEND=ILOCRP 9260 IOP=ISUBSU 9261 IFOUNO='YES' 9262 GOTO9000 9263 2590 CONTINUE 9264C 9265C **************************************** 9266C ** STEP 3.6-- ** 9267C ** CHECK FOR SCREEN MAX, ANGLE MAX, ** 9268C ** HEIGHT, WIDTH, AND ANGLE. ** 9269C **************************************** 9270C 9271 ISTEPN='3.6' 9272 IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9273C 9274 JMIN=22 9275 JMAX=27 9276 DO2610J=JMIN,JMAX 9277 J2=J 9278 IF(IWORD1.EQ.IOPERT(J))GOTO2650 9279 2610 CONTINUE 9280 GOTO2690 9281 2650 CONTINUE 9282 NUMC=IOPERN(J2) 9283 ILOCLP=ISTART+NUMC 9284 ILOCRP=ISTART+NUMC+1 9285 CALL DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUGD2,IERROR) 9286 IF(IFOULR.EQ.'YES')GOTO2660 9287 GOTO2690 9288 2660 CONTINUE 9289 IXXXXX=IWORD1 9290 IEND=ILOCRP 9291 IOP=IXXXXX 9292 IFOUNO='YES' 9293 GOTO9000 9294 2690 CONTINUE 9295C 9296C ********************************************* 9297C ** STEP 3.7-- ** 9298C ** CHECK FOR MOVE, DRAW, ETC. OPERATIONS ** 9299C ********************************************* 9300C 9301 ISTEPN='3.7' 9302 IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9303C 9304 JMIN=28 9305 JMAX=37 9306 DO2710J=JMIN,JMAX 9307 J2=J 9308 IF(IWORD1.EQ.IOPERT(J))GOTO2750 9309 2710 CONTINUE 9310 GOTO2790 9311 2750 CONTINUE 9312 NUMC=IOPERN(J2) 9313 ILOCLP=ISTART+NUMC 9314 ILOCRP=ISTART+NUMC+1 9315 CALL DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUGD2,IERROR) 9316 IF(IFOULR.EQ.'YES')GOTO2760 9317 GOTO2790 9318 2760 CONTINUE 9319 IXXXXX=IWORD1 9320 IEND=ILOCRP 9321 IOP=IXXXXX 9322 IFOUNO='YES' 9323 GOTO9000 9324 2790 CONTINUE 9325C 9326C ********************************** 9327C ** STEP 3.8-- ** 9328C ** CHECK FOR GREEK CHARACTERS ** 9329C ********************************** 9330C 9331 ISTEPN='3.8' 9332 IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9333C 9334 JMIN=1 9335 JMAX=24 9336 DO3110J=JMIN,JMAX 9337 J2=J 9338 IF(IWORD1.EQ.IGREET(J))GOTO3150 9339 3110 CONTINUE 9340 GOTO3190 9341 3150 CONTINUE 9342 NUMC=IGREEN(J2) 9343 ILOCLP=ISTART+NUMC 9344 ILOCRP=ISTART+NUMC+1 9345 CALL DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUGD2,IERROR) 9346 IF(IFOULR.EQ.'YES')GOTO3160 9347 GOTO3190 9348 3160 CONTINUE 9349 ICHAR2=IWORD1 9350 IEND=ILOCRP 9351 IFOUNC='YES' 9352 GOTO9000 9353 3190 CONTINUE 9354C 9355C ****************************** 9356C ** STEP 3.9-- ** 9357C ** CHECK FOR MATH SYMBOLS ** 9358C ****************************** 9359C 9360 ISTEPN='3.9' 9361 IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9362C 9363 JMIN=1 9364CCCCC JMAX=109 9365CCCCC JMAX=111 9366 JMAX=117 9367 DO4110J=JMIN,JMAX 9368 J2=J 9369 IF(IWORD1.EQ.IMATHT(J))GOTO4150 9370 4110 CONTINUE 9371 GOTO4190 9372 4150 CONTINUE 9373 NUMC=IMATHN(J2) 9374 ILOCLP=ISTART+NUMC 9375 ILOCRP=ISTART+NUMC+1 9376 CALL DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUGD2,IERROR) 9377 IF(IFOULR.EQ.'YES')GOTO4160 9378 GOTO4190 9379 4160 CONTINUE 9380 ICHAR2=IWORD1 9381 IEND=ILOCRP 9382 IFOUNC='YES' 9383 GOTO9000 9384 4190 CONTINUE 9385C 9386C ************************************************* 9387C ** STEP 4-- ** 9388C ** NO MATCH FOUND FOR ANY OF THE ABOVE; ** 9389C ** THEREFORE OUTPUT ONLY THE LEAD CHARACTER. ** 9390C ************************************************* 9391C 9392C 9393 6000 CONTINUE 9394 ISTEPN='4' 9395 IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9396C 9397 IF(NUMCHS.LE.1)GOTO6005 9398 ILOCLP=ISTART 9399 ILOCRP=ISTART+1 9400 IF(ISTRIN(ILOCLP).EQ.'('.AND.ISTRIN(ILOCRP).EQ.')')GOTO6006 9401 6005 CONTINUE 9402 ICHAR2=ISTRIN(ISTART) 9403 IEND=ISTART 9404 IFOUNC='YES' 9405 GOTO9000 9406 6006 CONTINUE 9407 IEND=ILOCRP 9408 IFOUNO='YES' 9409 GOTO9000 9410C 9411C PRE-1986--THE FOLLOWING COMMENTED-OUT CODE WAS FOR PUTTING OUT 9412C UP TO 4 CHARACTERS AS A PLOT CHARACTER 9413C AND THEREFORE COMMENTED OUT. 9414C 9415CCCCC DO6010I=1,4 9416CCCCC I2=I 9417CCCCC ICHAR3=' ' 9418CCCCC ICHAR3(1:1)=IWORD1(I:I) 9419CCCCC IF(ICHAR3.EQ.'(')GOTO6020 9420CCCCC IF(ICHAR3.EQ.' ')GOTO6020 9421C6010 CONTINUE 9422CCCCC NUMC=I2 9423CCCCC GOTO6080 9424C6020 CONTINUE 9425CCCCC NUMC=I2-1 9426CCCCC GOTO6080 9427C6080 CONTINUE 9428CCCCC IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SCAN')GOTO6089 9429CCCCC WRITE(ICOUT,6081) 9430C6081 FORMAT('***** FROM THE MIDDLE OF DPSCAN--') 9431CCCCC CALL DPWRST('XXX','BUG ') 9432CCCCC WRITE(ICOUT,6082)IWORD1,ICHAR3 9433C6082 FORMAT('IWORD1,ICHAR3 = ',A4,2X,A4) 9434CCCCC CALL DPWRST('XXX','BUG ') 9435CCCCC WRITE(ICOUT,6083)I2,NUMC 9436C6083 FORMAT('I2,NUMC = ',2I8) 9437CCCCC CALL DPWRST('XXX','BUG ') 9438C6089 CONTINUE 9439C6090 CONTINUE 9440CCCCC ILOCLP=ISTART+NUMC 9441CCCCC ILOCRP=ISTART+NUMC+1 9442CCCCC CALL DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUGD2,IERROR) 9443CCCCC IF(IFOULR.EQ.'YES')GOTO6095 9444CCCCC GOTO6097 9445C6095 CONTINUE 9446CCCCC ICHAR2=IWORD1 9447CCCCC IEND=ILOCRP 9448CCCCC IFOUNC='YES' 9449CCCCC GOTO9000 9450C6097 CONTINUE 9451CCCCC ICHAR2=ISTRIN(ISTART) 9452CCCCC IEND=ISTART 9453CCCCC IFOUNC='YES' 9454CCCCC GOTO9000 9455C ***************** 9456C ** STEP 90-- ** 9457C ** EXIT ** 9458C ***************** 9459C 9460 9000 CONTINUE 9461 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SCAN')GOTO9090 9462 WRITE(ICOUT,999) 9463 CALL DPWRST('XXX','BUG ') 9464 WRITE(ICOUT,9011) 9465 9011 FORMAT('***** AT THE END OF DPSCAN--') 9466 CALL DPWRST('XXX','BUG ') 9467 WRITE(ICOUT,9012)IFOUNC,IFOUNO,IBUGD2,IERROR 9468 9012 FORMAT('IFOUNC,IFOUNO,IBUGD2,IERROR = ', 9469 1A4,2X,A4,2X,A4,2X,A4) 9470 CALL DPWRST('XXX','BUG ') 9471 WRITE(ICOUT,9013)ICHAR2,IOP,ISTART,IEND 9472 9013 FORMAT('ICHAR2,IOP,ISTART,IEND = ',A4,2X,A4,I8,I8) 9473 CALL DPWRST('XXX','BUG ') 9474 WRITE(ICOUT,9014)IFONT,ICASE,IJUST,ISEQUE,ISUBSU 9475 9014 FORMAT('IFONT,ICASE,IJUST,ISEQUE,ISUBSU = ', 9476 1A4,2X,A4,2X,A4,2X,A4,2X,A4) 9477 CALL DPWRST('XXX','BUG ') 9478 WRITE(ICOUT,9015)HMAX,VMAX,AMAX 9479 9015 FORMAT('HMAX,VMAX,AMAX = ',3E15.7) 9480 CALL DPWRST('XXX','BUG ') 9481 WRITE(ICOUT,9016)X0,Y0,ANGLE 9482 9016 FORMAT('X0,Y0,ANGLE = ',3E15.7) 9483 CALL DPWRST('XXX','BUG ') 9484 WRITE(ICOUT,9017)WIDTH,HEIGHT 9485 9017 FORMAT('WIDTH,HEIGHT = ',2E15.7) 9486 CALL DPWRST('XXX','BUG ') 9487 WRITE(ICOUT,9018)ISTAR2,IWORD1,NUMC,J2 9488 9018 FORMAT('ISTAR2,IWORD1,NUMC,J2 = ',I8,2X,A4,I8,I8) 9489 CALL DPWRST('XXX','BUG ') 9490 WRITE(ICOUT,9019)IBUGG4,ISUBG4 9491 9019 FORMAT('IBUGG4,ISUBG4 = ',A4,2X,A4) 9492 CALL DPWRST('XXX','BUG ') 9493 9090 CONTINUE 9494C 9495 RETURN 9496 END 9497 SUBROUTINE DPSCEB(NPTS,NLAB, 9498 1 W,N, 9499 1 AMEAN,ASD,S2BMPS, 9500 1 XSE,XSES2,IDFH,SIGMAH, 9501 1 SESUK1,SESUK2, 9502 1 DLOWSE,DHIGSE, 9503 1 IWRITE, 9504 1 ICAPSW,ICAPTY,NUMDIG, 9505 1 ISUBRO,IBUGA3,IERROR) 9506C 9507C PURPOSE--IMPLEMENT SCHILLER-EBERHARDT APPROACH TO CONSENSUS MEANS 9508C PRINTING--YES 9509C SUBROUTINES NEEDED--NONE 9510C WRITTEN BY--ALAN HECKERT 9511C STATISTICAL ENGINEERING DIVISION 9512C INFORMATION TECHNOLOGY LABORATORY 9513C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 9514C GAITHERSBURG, MD 20899-8980 9515C PHONE--301-975-2899 9516C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 9517C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 9518C LANGUAGE--ANSI FORTRAN (1977) 9519C VERSION NUMBER--2006/3 9520C ORIGINAL VERSION--MARCH 2006. EXTRACTED FROM DPMAN2 ROUTINE 9521C UPDATED --OCTOBER 2006. CALL LIST TO TPPF 9522C UPDATED --FEBRUARY 2010. USE DPDTA1 TO PRINT 9523C 9524C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------- 9525C 9526 IMPLICIT DOUBLE PRECISION (A-H, O-Z) 9527C 9528 CHARACTER*4 ICAPSW 9529 CHARACTER*4 ICAPTY 9530 CHARACTER*4 ISUBRO 9531 CHARACTER*4 IBUGA3 9532 CHARACTER*4 IERROR 9533C 9534 CHARACTER*4 IWRITE 9535 CHARACTER*4 ISUBN1 9536 CHARACTER*4 ISUBN2 9537C 9538 REAL APPF 9539 REAL XSE 9540 REAL XSES2 9541 REAL S2BMPS 9542 REAL SIGMAH 9543 REAL SESUK1 9544 REAL SESUK2 9545C 9546C---------------------------------------------------------------- 9547C 9548 REAL AMEAN(*) 9549 REAL ASD(*) 9550C 9551 INTEGER N(*) 9552C 9553 DOUBLE PRECISION W(*) 9554C 9555 INCLUDE 'DPCOST.INC' 9556C 9557 PARAMETER (MAXROW=20) 9558 CHARACTER*60 ITITLE 9559 CHARACTER*60 ITITLZ 9560 CHARACTER*60 ITITL9 9561 CHARACTER*60 ITEXT(MAXROW) 9562 REAL AVALUE(MAXROW) 9563 INTEGER NCTEXT(MAXROW) 9564 INTEGER IDIGIT(MAXROW) 9565 INTEGER NTOT(MAXROW) 9566 LOGICAL IFRST 9567 LOGICAL ILAST 9568C 9569C-----COMMON----------------------------------------------------- 9570C 9571 INCLUDE 'DPCOP2.INC' 9572C 9573C-----START POINT------------------------------------------------ 9574C 9575 IERROR='NO' 9576 ISUBN1='DPVR' 9577 ISUBN2='ML ' 9578C 9579 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SCEB')THEN 9580 WRITE(ICOUT,999) 9581 999 FORMAT(1X) 9582 CALL DPWRST('XXX','BUG ') 9583 WRITE(ICOUT,51) 9584 51 FORMAT('***** AT THE BEGINNING OF DPSCEB--') 9585 CALL DPWRST('XXX','BUG ') 9586 WRITE(ICOUT,52)IWRITE,NPTS,NLAB 9587 52 FORMAT('IWRITE,NPTS,NLAB = ',A4,2X,2I8) 9588 CALL DPWRST('XXX','BUG ') 9589 DO55I=1,NPTS 9590 WRITE(ICOUT,56)I,AMEAN(I),ASD(I),N(I) 9591 56 FORMAT('I,AMEAN(I),ASD(I),N(I) = ',I8,2G15.7,I8) 9592 CALL DPWRST('XXX','BUG ') 9593 55 CONTINUE 9594 ENDIF 9595C 9596 DSUM1=0.0D0 9597 DO810I=1,NLAB 9598 DVAR=DBLE(ASD(I))**2 9599 W(I)=1.0D0/(DVAR+DBLE(S2BMPS)) 9600 DSUM1=DSUM1 + W(I) 9601 810 CONTINUE 9602 DWTSUM=DSUM1 9603 DSUM1=0.0D0 9604 DSUM2=0.0D0 9605 DSUM3=0.0D0 9606 DO815I=1,NLAB 9607 NITEMP=ABS(N(I)) 9608 IF(NITEMP.EQ.0)THEN 9609 IERROR='YES' 9610 GOTO9000 9611 ENDIF 9612 DVAR=DBLE(ASD(I))**2 9613 W(I)=W(I)/DWTSUM 9614 XI=DBLE(AMEAN(I)) 9615 DSUM1=DSUM1 + W(I)*XI 9616 DSUM2=DSUM2 + W(I)*DVAR 9617 DSUM3=DSUM3 + (W(I)*DVAR)**2/DBLE(NITEMP-1.0D0) 9618 815 CONTINUE 9619 XSE=REAL(DSUM1) 9620 ADFH=REAL(IDFH) 9621 DTERM1=(DSUM2 + SIGMAH**2)**2 9622 DTERM2=(DSUM3 + SIGMAH**4/ADFH) 9623 ADF=REAL(DTERM1/DTERM2) 9624 IDF=INT(ADF+0.5) 9625C 9626 DSUM1=0.0D0 9627 DO820I=1,NLAB 9628 DVAR=DBLE(ASD(I))**2 9629 W(I)=1.0D0/DVAR 9630 DSUM1=DSUM1 + W(I) 9631 820 CONTINUE 9632 DWTSUM=DSUM1 9633 DSUM1=0.0D0 9634 DO825I=1,NLAB 9635 DTERM1=(W(I)/DWTSUM)**2 9636 DSUM1=DSUM1 + DTERM1*DBLE(ASD(I)**2) 9637 825 CONTINUE 9638 XSES2=REAL(DSUM1) 9639C 9640 DBIAS=0.0D0 9641 DO830I=1,NLAB 9642 XI=DBLE(AMEAN(I)) 9643 DTERM1=DABS(XI-DBLE(XSE)) 9644 IF(DTERM1.GT.DBIAS)DBIAS=DTERM1 9645 830 CONTINUE 9646C 9647 CALL TPPF(0.975,REAL(IDF),APPF) 9648 DSESU1=SQRT(DBLE(XSES2) + DBLE(SIGMAH)**2) + DBIAS 9649 DSESU2=2.0D0*SQRT(DBLE(XSES2) + DBLE(SIGMAH)**2) + DBIAS 9650 DSEU=DBLE(APPF)*SQRT(DBLE(XSES2) + DBLE(SIGMAH)**2) + DBIAS 9651 DLOWSE=DBLE(XSE) - DSEU 9652 DHIGSE=DBLE(XSE) + DSEU 9653 ABIAS=REAL(DBIAS) 9654 ISEDF=IDF 9655 SESUK1=REAL(DSESU1) 9656 SESUK2=REAL(DSESU2) 9657C 9658 ITITLE=' ' 9659 NCTITL=0 9660 ITITLZ=' ' 9661 NCTITZ=0 9662C 9663 ICNT=1 9664 ITEXT(ICNT)='12. Method:Schiller-Eberhardt' 9665 NCTEXT(ICNT)=29 9666 AVALUE(ICNT)=0.0 9667 IDIGIT(ICNT)=-1 9668C 9669 ICNT=ICNT+1 9670 ITEXT(ICNT)=' Estimate of Consensus Mean:' 9671 NCTEXT(ICNT)=31 9672 AVALUE(ICNT)=XSE 9673 IDIGIT(ICNT)=NUMDIG 9674 ICNT=ICNT+1 9675 ITEXT(ICNT)=' Estimate of Variance of Mean:' 9676 NCTEXT(ICNT)=33 9677 AVALUE(ICNT)=XSES2 9678 IDIGIT(ICNT)=NUMDIG 9679 ICNT=ICNT+1 9680 ITEXT(ICNT)=' Bias Allowance:' 9681 NCTEXT(ICNT)=19 9682 AVALUE(ICNT)=ABIAS 9683 IDIGIT(ICNT)=NUMDIG 9684 ICNT=ICNT+1 9685 ITEXT(ICNT)=' Sigmah (heterogeneity):' 9686 NCTEXT(ICNT)=27 9687 AVALUE(ICNT)=SIGMAH 9688 IDIGIT(ICNT)=NUMDIG 9689 ICNT=ICNT+1 9690 ITEXT(ICNT)=' Degrees of Freedom for Sigmah:' 9691 NCTEXT(ICNT)=34 9692 AVALUE(ICNT)=IDFH 9693 IDIGIT(ICNT)=0 9694 ICNT=ICNT+1 9695 ITEXT(ICNT)=' Standard Uncertainty (k = 1):' 9696 NCTEXT(ICNT)=33 9697 AVALUE(ICNT)=DSESU1 9698 IDIGIT(ICNT)=NUMDIG 9699 ICNT=ICNT+1 9700 ITEXT(ICNT)=' Expanded Uncertainty (k = 2):' 9701 NCTEXT(ICNT)=33 9702 AVALUE(ICNT)=DSESU2 9703 IDIGIT(ICNT)=NUMDIG 9704 ICNT=ICNT+1 9705 ITEXT(ICNT)=' Expanded Uncertainty (k = ):' 9706 WRITE(ITEXT(ICNT)(31:40),'(F10.7)')APPF 9707 NCTEXT(ICNT)=42 9708 AVALUE(ICNT)=DSEU 9709 IDIGIT(ICNT)=NUMDIG 9710 ICNT=ICNT+1 9711 ITEXT(ICNT)=' Degrees of Freedom:' 9712 NCTEXT(ICNT)=23 9713 AVALUE(ICNT)=IDF 9714 IDIGIT(ICNT)=0 9715 ICNT=ICNT+1 9716 ITEXT(ICNT)=' t Percent Point Value (alpha = 0.05):' 9717 NCTEXT(ICNT)=41 9718 AVALUE(ICNT)=APPF 9719 IDIGIT(ICNT)=NUMDIG 9720 ICNT=ICNT+1 9721 ITEXT(ICNT)=' Lower 95% Confidence Limit:' 9722 NCTEXT(ICNT)=31 9723 AVALUE(ICNT)=DLOWSE 9724 IDIGIT(ICNT)=NUMDIG 9725 ICNT=ICNT+1 9726 ITEXT(ICNT)=' Upper 95% Confidence Limit:' 9727 NCTEXT(ICNT)=31 9728 AVALUE(ICNT)=DHIGSE 9729 IDIGIT(ICNT)=NUMDIG 9730 ICNT=ICNT+1 9731 ITEXT(ICNT)=' Note: Schiller-Eberhardt Best Usage:' 9732 NCTEXT(ICNT)=40 9733 AVALUE(ICNT)=0.0 9734 IDIGIT(ICNT)=-1 9735 ICNT=ICNT+1 9736 ITEXT(ICNT)=' 5 or Fewer Labs:' 9737 NCTEXT(ICNT)=26 9738 AVALUE(ICNT)=0.0 9739 IDIGIT(ICNT)=-1 9740C 9741 NUMROW=ICNT 9742 DO310I=1,NUMROW 9743 NTOT(I)=15 9744 310 CONTINUE 9745C 9746 IFRST=.TRUE. 9747 ILAST=.TRUE. 9748 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT, 9749 1 AVALUE,IDIGIT, 9750 1 NTOT,NUMROW, 9751 1 ICAPSW,ICAPTY,ILAST,IFRST, 9752 1 ISUBRO,IBUGA3,IERROR) 9753 ITITLE=' ' 9754 NCTITL=0 9755 ITITLZ=' ' 9756 NCTITZ=0 9757 ITITL9=' ' 9758 NCTIT9=0 9759C 9760C ***************** 9761C ** STEP 90-- ** 9762C ** EXIT ** 9763C ***************** 9764C 9765 9000 CONTINUE 9766 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SCEB')THEN 9767 WRITE(ICOUT,999) 9768 CALL DPWRST('XXX','BUG ') 9769 WRITE(ICOUT,9011) 9770 9011 FORMAT('***** AT THE END OF DPSCEB--') 9771 CALL DPWRST('XXX','BUG ') 9772 WRITE(ICOUT,9012)IERROR 9773 9012 FORMAT('IERROR = ',A4) 9774 CALL DPWRST('XXX','BUG ') 9775 WRITE(ICOUT,9013)NPTS,NLAB 9776 9013 FORMAT('NPTS,NLAB = ',2I8) 9777 CALL DPWRST('XXX','BUG ') 9778 WRITE(ICOUT,9014)XSE,XSES2,DSEU 9779 9014 FORMAT('XSE,XSES2,DSEU = ',3G15.7) 9780 CALL DPWRST('XXX','BUG ') 9781 WRITE(ICOUT,9015)DLOWSE,DHIGSE 9782 9015 FORMAT('DLOWSE,DHIGSE = ',2G15.7) 9783 CALL DPWRST('XXX','BUG ') 9784 ENDIF 9785C 9786 RETURN 9787 END 9788 SUBROUTINE DPSCI2(X1,Y1,X2,Y2,PX,PY, 9789 1 IFIG,ILINPA,ILINCO,PLINTH, 9790 1 AREGBA,IREBLI,IREBCO,PREBTH, 9791 1 IREFSW,IREFCO, 9792 1 IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 9793 1 PTEXHE,PTEXWI,PTEXVG,PTEXHG) 9794C 9795C PURPOSE--DRAW A SEMI-CIRCLE 9796C WITH ONE END OF THE DIAGONAL AT (X1,Y1) 9797C AND THE OTHER END AT (X2,Y2). 9798C NOTE--THE SEMI-CIRCLE WILL BE DRAWN CLOCKWISE. 9799C WRITTEN BY--JAMES J. FILLIBEN 9800C STATISTICAL ENGINEERING DIVISION 9801C INFORMATION TECHNOLOGY LABORATORY 9802C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 9803C GAITHERSBURG, MD 20899-8980 9804C PHONE--301-975-2899 9805C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 9806C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 9807C LANGUAGE--ANSI FORTRAN (1977) 9808C VERSION NUMBER--82/7 9809C ORIGINAL VERSION--APRIL 1981. 9810C UPDATED --MAY 1982. 9811C UPDATED --JANUARY 1989. MODIFY CALLS TO DPDRPL (ALAN) 9812C UPDATED --JANUARY 1989. MODIFY CALL TO DPFIRE (ALAN) 9813C UPDATED --JULY 2019. CREATE SCRATCH STORAGE IN DPSCIR 9814C RATHER THAN DPSCI2 9815C 9816C-----NON-COMMON VARIABLES------------------------------------- 9817C 9818 DIMENSION PX(*) 9819 DIMENSION PY(*) 9820C 9821 CHARACTER*4 IFIG 9822 CHARACTER*4 IPATT2 9823C 9824 CHARACTER*4 ILINPA 9825 CHARACTER*4 ILINCO 9826C 9827 CHARACTER*4 IREBLI 9828 CHARACTER*4 IREBCO 9829 CHARACTER*4 IREFSW 9830 CHARACTER*4 IREFCO 9831 CHARACTER*4 IREPTY 9832 CHARACTER*4 IREPLI 9833 CHARACTER*4 IREPCO 9834C 9835 CHARACTER*4 IPATT 9836 CHARACTER*4 ICOLF 9837 CHARACTER*4 ICOLP 9838 CHARACTER*4 ICOL 9839 CHARACTER*4 IFLAG 9840C 9841 DIMENSION ILINPA(*) 9842 DIMENSION ILINCO(*) 9843 DIMENSION PLINTH(*) 9844C 9845 DIMENSION AREGBA(*) 9846 DIMENSION IREBLI(*) 9847 DIMENSION IREBCO(*) 9848 DIMENSION PREBTH(*) 9849 DIMENSION IREFSW(*) 9850 DIMENSION IREFCO(*) 9851 DIMENSION IREPTY(*) 9852 DIMENSION IREPLI(*) 9853 DIMENSION IREPCO(*) 9854 DIMENSION PREPTH(*) 9855 DIMENSION PREPSP(*) 9856C 9857C-----COMMON---------------------------------------------------------- 9858C 9859 INCLUDE 'DPCOGR.INC' 9860 INCLUDE 'DPCOBE.INC' 9861 INCLUDE 'DPCOP2.INC' 9862C 9863C-----START POINT----------------------------------------------------- 9864C 9865 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCI2')THEN 9866 WRITE(ICOUT,999) 9867 999 FORMAT(1X) 9868 CALL DPWRST('XXX','BUG ') 9869 WRITE(ICOUT,51) 9870 51 FORMAT('***** AT THE BEGINNING OF DPSCI2--') 9871 CALL DPWRST('XXX','BUG ') 9872 WRITE(ICOUT,53)X1,Y1,X2,Y2 9873 53 FORMAT('X1,Y1,X2,Y2 = ',4G15.7) 9874 CALL DPWRST('XXX','BUG ') 9875 WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1) 9876 61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,G15.7) 9877 CALL DPWRST('XXX','BUG ') 9878 WRITE(ICOUT,62)IFIG,AREGBA(1) 9879 62 FORMAT('IFIG,AREGBA(1) = ',A4,2X,G15.7) 9880 CALL DPWRST('XXX','BUG ') 9881 WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1) 9882 63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',2(A4,2X),G15.7) 9883 CALL DPWRST('XXX','BUG ') 9884 WRITE(ICOUT,64)IREFSW(1),IREFCO(1) 9885 64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4) 9886 CALL DPWRST('XXX','BUG ') 9887 WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) 9888 65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ', 9889 1 3(A4,2X),2G15.7) 9890 CALL DPWRST('XXX','BUG ') 9891 WRITE(ICOUT,69)PTEXHE,PTEXWI,PTEXVG,PTEXHG 9892 69 FORMAT('PTEXHE,PTEXWI,PTEXVG,PTEXHG = ',4G15.7) 9893 CALL DPWRST('XXX','BUG ') 9894 WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4 9895 79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',2(A4,2X),A4) 9896 CALL DPWRST('XXX','BUG ') 9897 ENDIF 9898C 9899C ********************************* 9900C ** STEP 1-- ** 9901C ** DETERMINE THE COORDINATES ** 9902C ** FOR THE SEMI-CIRCLE ** 9903C ********************************* 9904C 9905 DELX=X2-X1 9906 DELY=Y2-Y1 9907 ALEN=0.0 9908 TERM=(X2-X1)**2+(Y2-Y1)**2 9909 IF(TERM.GT.0.0)ALEN=SQRT(TERM) 9910 RADIUS=ALEN/2.0 9911 IF(ABS(DELX).GE.0.00001)THETA=ATAN(DELY/DELX) 9912 IF(ABS(DELX).LT.0.00001.AND.DELY.GE.0.0)THETA=3.1415926/2.0 9913 IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0)THETA=-3.1415926/2.0 9914C 9915 XCENT=(X1+X2)/2.0 9916 YCENT=(Y1+Y2)/2.0 9917C 9918 K=0 9919C 9920 X=0.0 9921 Y=0.0 9922 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) 9923 K=K+1 9924 PX(K)=XP 9925 PY(K)=YP 9926C 9927 DO3010I=1,181,5 9928 IREV=181-I+1 9929 PHI2=IREV-1 9930 PHI2=PHI2*(2.0*3.1415926)/360.0 9931 X=RADIUS*COS(PHI2)+RADIUS 9932 Y=RADIUS*SIN(PHI2) 9933 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) 9934 K=K+1 9935 PX(K)=XP 9936 PY(K)=YP 9937 3010 CONTINUE 9938C 9939 NP=K 9940C 9941C *********************** 9942C ** STEP 2-- ** 9943C ** FILL THE FIGURE ** 9944C ** (IF CALLED FOR) ** 9945C *********************** 9946C 9947 IF(IREFSW(1).EQ.'OFF')GOTO2190 9948 IPATT=IREPTY(1) 9949 IPATT2='SOLI' 9950 PTHICK=PREPTH(1) 9951 PXGAP=PREPSP(1) 9952 PYGAP=PREPSP(1) 9953 ICOLF=IREFCO(1) 9954 ICOLP=IREPCO(1) 9955 CALL DPFIRE(PX,PY,NP, 9956 1 IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2) 9957 2190 CONTINUE 9958C 9959C *************************** 9960C ** STEP 3-- ** 9961C ** DRAW OUT THE FIGURE ** 9962C *************************** 9963C 9964 IPATT=ILINPA(1) 9965 PTHICK=PLINTH(1) 9966 ICOL=ILINCO(1) 9967 IFLAG='ON' 9968 CALL DPDRPL(PX,PY,NP, 9969 1 IFIG,IPATT,PTHICK,ICOL, 9970 1 JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 9971C 9972C ***************** 9973C ** STEP 90-- ** 9974C ** EXIT ** 9975C ***************** 9976C 9977 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCI2')THEN 9978 WRITE(ICOUT,999) 9979 CALL DPWRST('XXX','BUG ') 9980 WRITE(ICOUT,9011) 9981 9011 FORMAT('***** AT THE END OF DPSCI2--') 9982 CALL DPWRST('XXX','BUG ') 9983 WRITE(ICOUT,9014)NP,IERRG4 9984 9014 FORMAT('NP,IERRG4 = ',A4,2X,I8) 9985 CALL DPWRST('XXX','BUG ') 9986 DO9015I=1,NP 9987 WRITE(ICOUT,9016)I,PX(I),PY(I) 9988 9016 FORMAT('I,PX(I),PY(I) = ',I8,2G15.7) 9989 CALL DPWRST('XXX','BUG ') 9990 9015 CONTINUE 9991 ENDIF 9992C 9993 RETURN 9994 END 9995 SUBROUTINE DPSCIR(IHARG,IARGT,ARG,NUMARG, 9996 1 PXSTAR,PYSTAR,PXEND,PYEND, 9997 1 ILINPA,ILINCO,PLINTH, 9998 1 AREGBA,IREBLI,IREBCO,PREBTH, 9999 1 IREFSW,IREFCO, 10000 1 IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 10001 1 PTEXHE,PTEXWI,PTEXVG,PTEXHG, 10002 1 IGRASW,IDIASW, 10003 1 PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 10004 1 PDIAHE,PDIAWI,PDIAVG,PDIAHG, 10005 1 NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3, 10006 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 10007 1 IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL, 10008 1 IBUGD2,IFOUND,IERROR) 10009C 10010C PURPOSE--DRAW ONE OR MORE SEMI-CIRCLES (DEPENDING ON HOW MANY 10011C NUMBERS ARE PROVIDED). THE COORDINATES ARE IN 10012C STANDARDIZED UNITS OF 0 TO 100. 10013C NOTE--THE SEMI-CIRCLE WILL BE DRAWN CLOCKWISE. 10014C NOTE--THE INPUT COORDINATES DEFINE THE ENDS OF THE DIAMETER 10015C OF THE SEMI-CIRCLE. 10016C NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 2 10017C AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*2 = 4. 10018C NOTE--IF 2 NUMBERS ARE PROVIDED, THEN THE DRAWN SEMI-CIRCLE WILL 10019C GO FROM THE LAST CURSOR POSITION TO THE (X,Y) POINT (EITHER 10020C ABSOLUTE OR RELATIVE) AS DEFINED BY THE 2 NUMBERS. 10021C NOTE--IF 4 NUMBERS ARE PROVIDED, THEN THE DRAWN SEMI-CIRCLE WILL 10022C GO FROM THE ABSOLUTE (X,Y) POSITION AS DEFINED BY THE FIRST 10023C 2 NUMBERS TO THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) 10024C AS DEFINED BY THE THIRD AND FOURTH NUMBERS. 10025C NOTE--IF 6 NUMBERS ARE PROVIDED, THEN THE DRAWN SEMI-CIRCLE WILL 10026C GO FROM THE (X,Y) POSITION AS RESULTING FROM THE THIRD AND 10027C FOURTH NUMBERS TO THE (X,Y) POINT (EITHER ABSOLUTE OR 10028C RELATIVE) AS DEFINED BY THE FIFTH AND SIXTH NUMBERS. 10029C NOTE--AND SO FORTH FOR 8, 10, 12, ... NUMBERS. 10030C INPUT ARGUMENTS--IHARG 10031C --IARGT 10032C --ARG 10033C --NUMARG 10034C --PXSTAR 10035C --PYSTAR 10036C OUTPUT ARGUMENTS--PXEND 10037C --PYEND 10038C --IFOUND ('YES' OR 'NO' ) 10039C --IERROR ('YES' OR 'NO' ) 10040C WRITTEN BY--JAMES J. FILLIBEN 10041C STATISTICAL ENGINEERING DIVISION 10042C INFORMATION TECHNOLOGY LABORATORY 10043C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10044C GAITHERSBURG, MD 20899-8980 10045C PHONE--301-975-2899 10046C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 10047C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 10048C LANGUAGE--ANSI FORTRAN (1977) 10049C VERSION NUMBER--82/7 10050C ORIGINAL VERSION--APRIL 1981. 10051C UPDATED --MARCH 1982. 10052C UPDATED --MAY 1982. 10053C UPDATED --NOVEMBER 1982. 10054C UPDATED --JANUARY 1989. CALL LIST FOR OFFSET VAR (ALAN) 10055C UPDATED --MARCH 1997. SUPPORT FOR DEVICE FONT (ALAN) 10056C UPDATED --JULY 1997. SUPPORT FOR "DATA" UNITS (ALAN) 10057C UPDATED --DECEMBER 2018. CHECK FOR NULL OR NONE DEVICE 10058C UPDATED --DECEMBER 2018. SUPPORT FOR "DEVICE ... SCALE" 10059C COMMAND 10060C UPDATED --JULY 2019. MOVE CREATION OF SCRATCH 10061C STORAGE FROM DPSCI2 TO DPSCIR 10062C 10063C-----NON-COMMON VARIABLES----------------------------------------- 10064C 10065 CHARACTER*4 IHARG 10066 CHARACTER*4 IARGT 10067C 10068 CHARACTER*4 ILINPA 10069 CHARACTER*4 ILINCO 10070C 10071 CHARACTER*4 IREBLI 10072 CHARACTER*4 IREBCO 10073 CHARACTER*4 IREFSW 10074 CHARACTER*4 IREFCO 10075 CHARACTER*4 IREPTY 10076 CHARACTER*4 IREPLI 10077 CHARACTER*4 IREPCO 10078C 10079 CHARACTER*4 IGRASW 10080 CHARACTER*4 IDIASW 10081C 10082 CHARACTER*4 IDMANU 10083 CHARACTER*4 IDMODE 10084 CHARACTER*4 IDMOD2 10085 CHARACTER*4 IDMOD3 10086 CHARACTER*4 IDPOWE 10087 CHARACTER*4 IDCONT 10088 CHARACTER*4 IDCOLO 10089 CHARACTER*4 IDFONT 10090 CHARACTER*4 UNITSW 10091C 10092 CHARACTER*4 IFOUND 10093 CHARACTER*4 IBUGD2 10094 CHARACTER*4 IERROR 10095 CHARACTER*4 ISUBRO 10096C 10097 CHARACTER*4 IFIG 10098 CHARACTER*4 IBELSW 10099 CHARACTER*4 IERASW 10100 CHARACTER*4 IBACCO 10101 CHARACTER*4 ICOPSW 10102 CHARACTER*4 ITYPEO 10103C 10104 DIMENSION IHARG(*) 10105 DIMENSION IARGT(*) 10106 DIMENSION ARG(*) 10107C 10108 DIMENSION ILINPA(*) 10109 DIMENSION ILINCO(*) 10110 DIMENSION PLINTH(*) 10111C 10112 DIMENSION AREGBA(*) 10113 DIMENSION IREBLI(*) 10114 DIMENSION IREBCO(*) 10115 DIMENSION PREBTH(*) 10116 DIMENSION IREFSW(*) 10117 DIMENSION IREFCO(*) 10118 DIMENSION IREPTY(*) 10119 DIMENSION IREPLI(*) 10120 DIMENSION IREPCO(*) 10121 DIMENSION PREPTH(*) 10122 DIMENSION PREPSP(*) 10123 DIMENSION PDSCAL(*) 10124C 10125 DIMENSION IDMANU(*) 10126 DIMENSION IDMODE(*) 10127 DIMENSION IDMOD2(*) 10128 DIMENSION IDMOD3(*) 10129 DIMENSION IDPOWE(*) 10130 DIMENSION IDCONT(*) 10131 DIMENSION IDCOLO(*) 10132 DIMENSION IDFONT(*) 10133 DIMENSION IDNVPP(*) 10134 DIMENSION IDNHPP(*) 10135 DIMENSION IDUNIT(*) 10136 DIMENSION IDNVOF(*) 10137 DIMENSION IDNHOF(*) 10138C 10139C-----COMMON---------------------------------------------------------- 10140C 10141 INCLUDE 'DPCOPA.INC' 10142 INCLUDE 'DPCOZZ.INC' 10143 DIMENSION PX(1000) 10144 DIMENSION PY(1000) 10145 EQUIVALENCE (GARBAG(IGARB1),PX(1)) 10146 EQUIVALENCE (GARBAG(IGARB2),PY(1)) 10147C 10148C-----COMMON VARIABLES (GENERAL)-------------------------------------- 10149C 10150 INCLUDE 'DPCOGR.INC' 10151 INCLUDE 'DPCOBE.INC' 10152 INCLUDE 'DPCOP2.INC' 10153C 10154C-----START POINT----------------------------------------------------- 10155C 10156 IFOUND='NO' 10157 IERROR='NO' 10158 IERRG4=IERROR 10159C 10160 ILOCFN=0 10161 NUMNUM=0 10162C 10163 X1=0.0 10164 Y1=0.0 10165 X2=0.0 10166 Y2=0.0 10167C 10168 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCIR')THEN 10169 WRITE(ICOUT,999) 10170 999 FORMAT(1X) 10171 CALL DPWRST('XXX','BUG ') 10172 WRITE(ICOUT,51) 10173 51 FORMAT('***** AT THE BEGINNING OF DPSCIR--') 10174 CALL DPWRST('XXX','BUG ') 10175 WRITE(ICOUT,53)NUMARG,NUMDEV 10176 53 FORMAT('NUMARG,NUMDEV = ',2I8) 10177 CALL DPWRST('XXX','BUG ') 10178 DO55I=1,NUMARG 10179 WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I) 10180 56 FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2(2X,A4),G15.7) 10181 CALL DPWRST('XXX','BUG ') 10182 55 CONTINUE 10183 WRITE(ICOUT,57)PXSTAR,PYSTAR,PXEND,PYEND 10184 57 FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4G15.7) 10185 CALL DPWRST('XXX','BUG ') 10186 WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1) 10187 61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',2(A4,2X),G15.7) 10188 CALL DPWRST('XXX','BUG ') 10189 WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1),AREGBA(1) 10190 63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1),AREGBA(1) = ', 10191 1 2(A4,2X),2G15.7) 10192 CALL DPWRST('XXX','BUG ') 10193 WRITE(ICOUT,64)IREFSW(1),IREFCO(1) 10194 64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4) 10195 CALL DPWRST('XXX','BUG ') 10196 WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) 10197 65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ', 10198 1 3(A4,2X),2G15.7) 10199 CALL DPWRST('XXX','BUG ') 10200 WRITE(ICOUT,69)PTEXHE,PTEXWI,PTEXVG,PTEXHG 10201 69 FORMAT('PTEXHE,PTEXWI,PTEXVG,PTEXHG= ',4G15.7) 10202 CALL DPWRST('XXX','BUG ') 10203 WRITE(ICOUT,76)IGRASW,IDIASW 10204 76 FORMAT('IGRASW,IDIASW = ',A4,2X,A4) 10205 CALL DPWRST('XXX','BUG ') 10206 WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC 10207 77 FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4G15.7) 10208 CALL DPWRST('XXX','BUG ') 10209 WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG 10210 78 FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4G15.7) 10211 CALL DPWRST('XXX','BUG ') 10212 DO81I=1,NUMDEV 10213 WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) 10214 82 FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ', 10215 1 3(A4,2X),A4) 10216 CALL DPWRST('XXX','BUG ') 10217 WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I) 10218 83 FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ',2(A4,2X),A4) 10219 CALL DPWRST('XXX','BUG ') 10220 WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I) 10221 84 FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ',3I8) 10222 CALL DPWRST('XXX','BUG ') 10223 81 CONTINUE 10224 WRITE(ICOUT,88)IBUGG4,IBUGD2,ISUBG4,IERRG4,IFOUND,IERROR 10225 88 FORMAT('IBUGG4,IBUGD2,ISUBG4,IERRG4,IFOUND,IERROR = ', 10226 1 5(A4,2X),A4) 10227 CALL DPWRST('XXX','BUG ') 10228 ENDIF 10229C 10230 IFIG='SCIR' 10231 NUMPT=2 10232 NUMPT2=2*NUMPT 10233C 10234C ******************************** 10235C ** STEP 0-- ** 10236C ** STEP THROUGH EACH DEVICE ** 10237C ******************************** 10238C 10239 IF(NUMDEV.LE.0)GOTO9000 10240 DO8000IDEVIC=1,NUMDEV 10241C 10242 IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000 10243 IF(IDMANU(IDEVIC).EQ.'OFF')GOTO8000 10244 IF(IDMANU(IDEVIC).EQ.'NULL')GOTO8000 10245 IF(IDMANU(IDEVIC).EQ.'NONE')GOTO8000 10246 IF(IDMANU(IDEVIC).EQ.'DISC')GOTO8000 10247C 10248 IMANUF=IDMANU(IDEVIC) 10249 IMODEL=IDMODE(IDEVIC) 10250 IMODE2=IDMOD2(IDEVIC) 10251 IMODE3=IDMOD3(IDEVIC) 10252 IGCONT=IDCONT(IDEVIC) 10253 IGCOLO=IDCOLO(IDEVIC) 10254 IGFONT=IDFONT(IDEVIC) 10255 NUMVPP=IDNVPP(IDEVIC) 10256 NUMHPP=IDNHPP(IDEVIC) 10257 ANUMVP=NUMVPP 10258 ANUMHP=NUMHPP 10259 IOFFSV=IDNVOF(IDEVIC) 10260 IOFFSH=IDNHOF(IDEVIC) 10261 IGUNIT=IDUNIT(IDEVIC) 10262 PCHSCA=PDSCAL(IDEVIC) 10263C 10264C ************************************ 10265C ** STEP 1-- ** 10266C ** CARRY OUT OPENING OPERATIONS ** 10267C ** ON THE GRAPHICS DEVICES ** 10268C ************************************ 10269C 10270 CALL DPOPDE 10271C 10272 IBELSW='OFF' 10273 NUMRIN=0 10274 IERASW='OFF' 10275 IBACCO='JUNK' 10276C 10277 CALL DPOPPL(IGRASW,IBELSW,NUMRIN,IERASW,IBACCO) 10278C 10279C ***************************************** 10280C ** STEP 2-- ** 10281C ** SEARCH FOR COMMAND SPECIFICATIONS ** 10282C ***************************************** 10283C 10284 IF(NUMARG.GE.3.AND. 10285 1 IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')THEN 10286 ITYPEO='ABSO' 10287 ILOCFN=2 10288 ELSEIF(NUMARG.GE.4.AND.IHARG(2).EQ.'ABSO'.AND. 10289 1 IARGT(3).EQ.'NUMB'.AND.IARGT(4).EQ.'NUMB')THEN 10290 ITYPEO='ABSO' 10291 ILOCFN=3 10292 ELSEIF(NUMARG.GE.4.AND.IHARG(2).EQ.'RELA'.AND. 10293 1 IARGT(3).EQ.'NUMB'.AND.IARGT(4).EQ.'NUMB')THEN 10294 ITYPEO='RELA' 10295 ILOCFN=3 10296 ELSE 10297 GOTO1130 10298 ENDIF 10299C 10300 IF(ILOCFN.GT.NUMARG)GOTO1130 10301 DO1120I=ILOCFN,NUMARG 10302 IF(IARGT(I).NE.'NUMB')GOTO1130 10303 1120 CONTINUE 10304 IFOUND='YES' 10305C 10306C **************************** 10307C ** STEP 3-- ** 10308C ** DRAW OUT THE LINE(S) ** 10309C **************************** 10310C 10311 NUMNUM=NUMARG-ILOCFN+1 10312 IF(NUMNUM.LT.NUMPT2)THEN 10313 J=ILOCFN-1 10314 X1=PXSTAR 10315 Y1=PYSTAR 10316 ELSE 10317 J=ILOCFN 10318 IF(J.GT.NUMARG)GOTO1190 10319 X1=ARG(J) 10320 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1, 10321 1 IBUGD2,ISUBRO,IERROR) 10322 J=J+1 10323 IF(J.GT.NUMARG)GOTO1190 10324 Y1=ARG(J) 10325 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1, 10326 1 IBUGD2,ISUBRO,IERROR) 10327 ENDIF 10328C 10329 1160 CONTINUE 10330 J=J+1 10331 IF(J.GT.NUMARG)GOTO1190 10332 X2=ARG(J) 10333 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR) 10334 IF(ITYPEO.EQ.'RELA')X2=X1+X2 10335 J=J+1 10336 IF(J.GT.NUMARG)GOTO1190 10337 Y2=ARG(J) 10338 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR) 10339 IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2 10340C 10341 CALL DPSCI2(X1,Y1,X2,Y2,PX,PY, 10342 1 IFIG,ILINPA,ILINCO,PLINTH, 10343 1 AREGBA,IREBLI,IREBCO,PREBTH, 10344 1 IREFSW,IREFCO, 10345 1 IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 10346 1 PTEXHE,PTEXWI,PTEXVG,PTEXHG) 10347C 10348 X1=X2 10349 Y1=Y2 10350C 10351 GOTO1160 10352 1190 CONTINUE 10353C 10354 PXEND=X2 10355 PYEND=Y2 10356C 10357C ************************************ 10358C ** STEP 4-- ** 10359C ** CARRY OUT CLOSING OPERATIONS ** 10360C ** ON THE GRAPHICS DEVICES ** 10361C ************************************ 10362C 10363 ICOPSW='OFF' 10364 NUMCOP=0 10365 CALL DPCLPL(ICOPSW,NUMCOP, 10366 1 PGRAXF,PGRAYF, 10367 1 IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 10368 1 PDIAHE,PDIAWI,PDIAVG,PDIAHG) 10369C 10370 CALL DPCLDE 10371C 10372 8000 CONTINUE 10373 GOTO9000 10374C 10375 1130 CONTINUE 10376 IERRG4='YES' 10377 WRITE(ICOUT,1131) 10378 1131 FORMAT('***** ERROR IN SEMI-CIRCLE (DPSCIR)--') 10379 CALL DPWRST('XXX','BUG ') 10380 WRITE(ICOUT,1132) 10381 1132 FORMAT(' ILLEGAL FORM FOR SEMI-CIRCLE COMMAND.') 10382 CALL DPWRST('XXX','BUG ') 10383 WRITE(ICOUT,1134) 10384 1134 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE PROPER FORM--') 10385 CALL DPWRST('XXX','BUG ') 10386 WRITE(ICOUT,1135) 10387 1135 FORMAT(' SUPPOSE IT IS DESIRED TO DRAW A SEMI-CIRCLE ') 10388 CALL DPWRST('XXX','BUG ') 10389 WRITE(ICOUT,1136) 10390 1136 FORMAT(' WITH ONE END OF A DIAGONAL AT 20 20 ') 10391 CALL DPWRST('XXX','BUG ') 10392 WRITE(ICOUT,1137) 10393 1137 FORMAT(' AND THE OTHER END OF THE DIAGONAL AT 40 60,') 10394 CALL DPWRST('XXX','BUG ') 10395 WRITE(ICOUT,1141) 10396 1141 FORMAT(' THEN ALLOWABLE FORMS ARE--') 10397 CALL DPWRST('XXX','BUG ') 10398 WRITE(ICOUT,1142) 10399 1142 FORMAT(' SEMI-CIRCLE 20 20 40 60') 10400 CALL DPWRST('XXX','BUG ') 10401 WRITE(ICOUT,1143) 10402 1143 FORMAT(' SEMI-CIRCLE ABSOLUTE 20 20 40 60') 10403 CALL DPWRST('XXX','BUG ') 10404 WRITE(ICOUT,1145) 10405 1145 FORMAT(' SEMI-CIRCLE RELATIVE 20 20 40 60') 10406 CALL DPWRST('XXX','BUG ') 10407C 10408C ***************** 10409C ** STEP 90-- ** 10410C ** EXIT ** 10411C ***************** 10412C 10413 9000 CONTINUE 10414 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCIR')THEN 10415 WRITE(ICOUT,999) 10416 CALL DPWRST('XXX','BUG ') 10417 WRITE(ICOUT,9011) 10418 9011 FORMAT('***** AT THE END OF DPSCIR--') 10419 CALL DPWRST('XXX','BUG ') 10420 WRITE(ICOUT,9012)IFOUND,IERROR,ILOCFN,NUMNUM 10421 9012 FORMAT('IFOUND,IERROR,ILOCFN,NUMNUM = ',2(A4,2X),2I8) 10422 CALL DPWRST('XXX','BUG ') 10423 WRITE(ICOUT,9013)X1,Y1,X2,Y2,X3,Y3 10424 9013 FORMAT('X1,Y1,X2,Y2,X3,Y3 = ',6G15.7) 10425 CALL DPWRST('XXX','BUG ') 10426 WRITE(ICOUT,9015)PXSTAR,PYSTAR,PXEND,PYEND 10427 9015 FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4G15.7) 10428 CALL DPWRST('XXX','BUG ') 10429 ENDIF 10430C 10431 RETURN 10432 END 10433 SUBROUTINE DPSCR7(ISTRIN,NUMCHA,X0,Y0, 10434 1 IFONT,ICASE,IJUST,ANGLE,HMAX,VMAX,AMAX, 10435 1 WIDTH,HEIGHT, 10436 1 PHEIGH,PWIDTH,PVEGAP,PHOGAP, 10437 1 PHEIG2,PWIDT2,PVEGA2,PHOGA2, 10438 1 ANUMHP,ANUMVP, 10439 1 IPATT,PTHICK,ICOL, 10440 1 JPATT,JTHICK,PTHIC2,JCOL, 10441 1 ISYMBL,ISPAC,IFILL, 10442 1 IMPSW2,AMPSCH,AMPSCW, 10443 1 XEND,YEND,IFOUND,IBUGD2,IERROR) 10444C 10445C WRITTEN BY--JAMES J. FILLIBEN 10446C STATISTICAL ENGINEERING DIVISION 10447C INFORMATION TECHNOLOGY LABORATORY 10448C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10449C GAITHERSBURG, MD 20899-8980 10450C PHONE--301-975-2899 10451C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 10452C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 10453C LANGUAGE--ANSI FORTRAN (1977) 10454C VERSION NUMBER--82/7 10455C ORIGINAL VERSION--JANUARY 1981. 10456C UPDATED --OCTOBER 1981. 10457C UPDATED --MAY 1982. 10458C UPDATED --OCTOBER 1993. HANDLE LOWER CASE CHARACTERS 10459C 10460C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10461C 10462 CHARACTER*4 ISTRIN 10463C 10464 CHARACTER*4 IPATT 10465 CHARACTER*4 IFONT 10466 CHARACTER*4 ICASE 10467 CHARACTER*4 IJUST 10468 CHARACTER*4 ICOL 10469C 10470 CHARACTER*24 ISYMBL 10471 CHARACTER*4 ISPAC 10472 CHARACTER*4 IFILL 10473C 10474 CHARACTER*4 IFOUND 10475 CHARACTER*4 IBUGD2 10476 CHARACTER*4 IERROR 10477C 10478 CHARACTER*4 ISEQUE 10479 CHARACTER*4 ISUBSU 10480 CHARACTER*4 IDRAW 10481 CHARACTER*4 IFOUNO 10482 CHARACTER*4 IFONSV 10483 CHARACTER*4 ICASSV 10484 CHARACTER*4 ICHAR2 10485 CHARACTER*4 IOP 10486 CHARACTER*4 IFOUNC 10487CCCCC OCTOBER 1993. ADD FOLLOWING LINE 10488 CHARACTER*4 ICASE2 10489C 10490C--------------------------------------------------------------------- 10491C 10492 DIMENSION ISTRIN(*) 10493C 10494C-----COMMON---------------------------------------------------------- 10495C 10496C 10497 CHARACTER*4 IMPSW2 10498C 10499C-----COMMON VARIABLES (GENERAL)-------------------------------------- 10500C 10501 INCLUDE 'DPCOBE.INC' 10502 INCLUDE 'DPCOP2.INC' 10503C 10504C-----START POINT----------------------------------------------------- 10505C 10506CCCCC OCTOBER 1993. ADD FOLLOWING LINE 10507 ICASE2='UPPE' 10508 ISEQUE='ON' 10509 ISUBSU='OFF' 10510C 10511C 10512 X02=50.0 10513 Y02=50.0 10514C 10515 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SCR7')GOTO90 10516 WRITE(ICOUT,999) 10517 999 FORMAT(1X) 10518 CALL DPWRST('XXX','BUG ') 10519 WRITE(ICOUT,51) 10520 51 FORMAT('***** AT THE BEGINNING OF DPSCR7--') 10521 CALL DPWRST('XXX','BUG ') 10522 WRITE(ICOUT,52)X0,Y0,IFONT,ICASE,IJUST,ANGLE 10523 52 FORMAT('X0,Y0,IFONT,ICASE,IJUST,ANGLE = ', 10524 1E15.7,E15.7,2X,A4,2X,A4,2X,A4,E15.7) 10525 CALL DPWRST('XXX','BUG ') 10526 WRITE(ICOUT,53)HMAX,VMAX,AMAX,WIDTH,HEIGHT 10527 53 FORMAT('HMAX,VMAX,AMAX,WIDTH,HEIGHT = ',5E15.7) 10528 CALL DPWRST('XXX','BUG ') 10529 WRITE(ICOUT,54)ANUMHP,ANUMVP 10530 54 FORMAT('ANUMHP,ANUMVP = ',2E15.7) 10531 CALL DPWRST('XXX','BUG ') 10532 WRITE(ICOUT,55)XEND,YEND,IBUGD2 10533 55 FORMAT('XEND,YEND,IBUGD2 = ',E15.7,E15.7,2X,A4) 10534 CALL DPWRST('XXX','BUG ') 10535 WRITE(ICOUT,56)NUMCHA 10536 56 FORMAT('NUMCHA = ',I8) 10537 CALL DPWRST('XXX','BUG ') 10538 DO57I=1,NUMCHA 10539 WRITE(ICOUT,58)I,ISTRIN(I) 10540 58 FORMAT('I,ISTRIN(I) = ',I8,2X,A4) 10541 CALL DPWRST('XXX','BUG ') 10542 57 CONTINUE 10543 WRITE(ICOUT,59)IBUGG4,ISUBG4 10544 59 FORMAT('IBUGG4,ISUBG4 = ',A4,2X,A4) 10545 CALL DPWRST('XXX','BUG ') 10546 WRITE(ICOUT,60)ICOL,JCOL,PTHICK,JTHICK,PTHIC2 10547 60 FORMAT('ICOL,JCOL,PTHICK,JTHICK,PTHIC2 = ', 10548 1A4,I8,E15.7,I8,E15.7) 10549 CALL DPWRST('XXX','BUG ') 10550 WRITE(ICOUT,61)IPATT,JPATT 10551 61 FORMAT('IPATT,JPATT = ',A4,I8) 10552 CALL DPWRST('XXX','BUG ') 10553 WRITE(ICOUT,62)PHEIGH,PWIDTH,PVEGAP,PHOGAP 10554 62 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4E15.7) 10555 CALL DPWRST('XXX','BUG ') 10556 WRITE(ICOUT,63)PHEIG2,PWIDT2,PVEGA2,PHOGA2 10557 63 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4E15.7) 10558 CALL DPWRST('XXX','BUG ') 10559 WRITE(ICOUT,65)ISYMBL,ISPAC 10560 65 FORMAT('ISYMBL,ISPAC = ',A24,2X,A4) 10561 CALL DPWRST('XXX','BUG ') 10562 WRITE(ICOUT,66)IFILL 10563 66 FORMAT('IFILL = ',A4) 10564 CALL DPWRST('XXX','BUG ') 10565 WRITE(ICOUT,68)IFOUND,IBUGD2,IERROR 10566 68 FORMAT('IFOUND,IBUGD2,IERROR = ',A4,2X,A4,2X,A4) 10567 CALL DPWRST('XXX','BUG ') 10568 WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4 10569 69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 10570 CALL DPWRST('XXX','BUG ') 10571 90 CONTINUE 10572C 10573C ************************* 10574C ** STEP XX-- ** 10575C ** SAVE INPUT VALUES ** 10576C ************************* 10577C 10578 IFONSV=IFONT 10579 ICASSV=ICASE 10580 HEIGSV=HEIGHT 10581 WIDTSV=WIDTH 10582C 10583 PHEISV=PHEIGH 10584 PWIDSV=PWIDTH 10585 PVEGSV=PVEGAP 10586 PHOGSV=PHOGAP 10587C 10588 PHE2SV=PHEIG2 10589 PWI2SV=PWIDT2 10590 PVG2SV=PVEGA2 10591 PHG2SV=PHOGA2 10592C 10593 IF(IMPSW2.EQ.'ON')THEN 10594 PHEIGH=PHEIGH*AMPSCH 10595 PVEGAP=PVEGAP*AMPSCH 10596 PWIDTH=PWIDTH*AMPSCW 10597 PHOGAP=PHOGAP*AMPSCW 10598 PHEIG2=PHEIG2*AMPSCH 10599 PVEGA2=PVEGA2*AMPSCH 10600 PWIDT2=PWIDT2*AMPSCW 10601 PHOGA2=PHOGA2*AMPSCW 10602 HEIGHT=HEIGHT*AMPSCH 10603 WIDTH=WIDTH*AMPSCW 10604 ENDIF 10605C 10606C ********************************************* 10607C ** STEP XX-- ** 10608C ** DETERMINE THE LOCATION ** 10609C ** OF THE RIGHT-MOST NON-BLANK CHARACTER ** 10610C ********************************************* 10611C 10612 DO300I=1,NUMCHA 10613 IREV=NUMCHA-I+1 10614 IF(ISTRIN(IREV).NE.' ')GOTO305 10615 300 CONTINUE 10616 NUMCHS=0 10617 GOTO309 10618 305 CONTINUE 10619 NUMCHS=IREV 10620 309 CONTINUE 10621C 10622C ************************************* 10623C ** STEP XX-- ** 10624C ** DETERMINE THE LOCATION ** 10625C ** OF THE RIGHT-MOST PARENTHESIS ** 10626C ************************************* 10627C 10628 ILOCR2=0 10629 DO600I=1,NUMCHS 10630 IREV=NUMCHS-I+1 10631 IF(ISTRIN(IREV).EQ.')')GOTO610 10632 600 CONTINUE 10633 GOTO690 10634 610 CONTINUE 10635 ILOCR2=IREV 10636 GOTO690 10637 690 CONTINUE 10638C 10639C *********************************************** 10640C ** STEP XX-- ** 10641C ** PROCEED SEQUENTIALLY THROUGH THE STRING ** 10642C *********************************************** 10643C 10644 IF(IJUST.EQ.'LEFT')GOTO1100 10645 IF(IJUST.EQ.'LEBO')GOTO1100 10646 IF(IJUST.EQ.'LECE')GOTO1100 10647 IF(IJUST.EQ.'LETO')GOTO1100 10648C 10649 IF(IJUST.EQ.'CENT')GOTO1200 10650 IF(IJUST.EQ.'CEBO')GOTO1200 10651 IF(IJUST.EQ.'CECE')GOTO1200 10652 IF(IJUST.EQ.'CETO')GOTO1200 10653C 10654 IF(IJUST.EQ.'RIGH')GOTO1200 10655 IF(IJUST.EQ.'RIBO')GOTO1200 10656 IF(IJUST.EQ.'RICE')GOTO1200 10657 IF(IJUST.EQ.'RITO')GOTO1200 10658C 10659 GOTO1100 10660C 10661C ***************************************** 10662C ** STEP 11-- ** 10663C ** TREAT THE LEFT-JUSTIFICATION CASE ** 10664C ***************************************** 10665C 10666 1100 CONTINUE 10667C 10668 IEND=0 10669C 10670 XEND=X0 10671 YEND=Y0 10672 IF(IJUST.EQ.'LECE')YEND=Y0-PHEIGH/2.0 10673 IF(IJUST.EQ.'LETO')YEND=Y0-PHEIGH 10674C 10675 1110 CONTINUE 10676 ISTART=IEND+1 10677 IF(ISTART.GT.NUMCHS)GOTO1190 10678C 10679C ************************************ 10680C ** STEP 12-- ** 10681C ** DECODE THE NEXT CHARACTER ** 10682C ** (OR THE NEXT FEW CHARACTERS) ** 10683C ************************************ 10684C 10685 CALL DPSCAN(ISTART,ISTRIN,NUMCHS,ILOCR2, 10686 1ICHAR2,IOP,IFONT,ICASE,IJUST,ISEQUE,ISUBSU, 10687 1HMAX,VMAX,AMAX,X0,Y0,ANGLE,WIDTH,HEIGHT, 10688 1IEND,IFOUNC,IFOUNO,IBUGD2,IERROR) 10689 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR7') 10690 1WRITE(ICOUT,1112)ICHAR2,IOP,ISTART,IEND,IFOUNC, 10691 1IFOUNO 10692 1112 FORMAT('ICHAR2,IOP,ISTART,IEND,IFOUNC,IFOUNO = ', 10693 1A4,2X,A4,I8,I8,2X,A4,2X,A4) 10694 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR7') 10695 1CALL DPWRST('XXX','BUG ') 10696C 10697C ****************************** 10698C ** STEP 13-- ** 10699C ** DRAW OUT THE CHARACTER ** 10700C ****************************** 10701C 10702 CALL DPSBSP(IFOUNO,IOP,XEND,YEND,HEIGHT,WIDTH, 10703 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 10704 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 10705 1ANGLE,AMAX, 10706 1IBUGD2,IERROR) 10707 IF(IFOUNO.EQ.'YES')GOTO1180 10708C 10709 XSTART=XEND 10710 YSTART=YEND 10711C 10712 IDRAW='ON' 10713CCCCC OCTOBER 1993. HANDLE CASE IF ICHAR2 IS LOWER CASE. 10714 ICASE2=ICASE 10715 CALL DPCOAN(ICHAR2(1:1),IVAL) 10716 IF(IVAL.GE.97.AND.IVAL.LE.122)THEN 10717 IVAL=IVAL-32 10718 CALL DPCONA(IVAL,ICHAR2(1:1)) 10719 IF(ICASE.EQ.'LOWE'.OR.ICASE.EQ.'ASIS')ICASE2='LOWE' 10720 ELSE 10721 IF(ICASE.EQ.'ASIS')ICASE2='UPPE' 10722 END IF 10723CCCCC END CHANGE 10724C 10725 CALL DPSCR8(ICHAR2,XSTART,YSTART,IDRAW, 10726CCCCC1IFONT,ICASE,ANGLE,HMAX,VMAX,AMAX,WIDTH,HEIGHT, 10727 1IFONT,ICASE2,ANGLE,HMAX,VMAX,AMAX,WIDTH,HEIGHT, 10728 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 10729 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 10730 1ANUMHP,ANUMVP, 10731 1IPATT,PTHICK,ICOL, 10732 1JPATT,JTHICK,PTHIC2,JCOL, 10733 1XEND,YEND, 10734 1ISPAC, 10735 1IFILL, 10736 1IFOUND,IBUGD2,IERROR) 10737C 10738 1180 CONTINUE 10739 GOTO1110 10740C 10741 1190 CONTINUE 10742 IF(IJUST.EQ.'LECE')YEND=YEND+PHEIGH/2.0 10743 IF(IJUST.EQ.'LETO')YEND=YEND+PHEIGH 10744 GOTO8000 10745C 10746C ***************************************** 10747C ** STEP 21-- ** 10748C ** TREAT THE CENTER-JUSTIFICATION ** 10749C ** AND THE RIGHT-JUSTIFICATION CASES ** 10750C ***************************************** 10751C 10752 1200 CONTINUE 10753C 10754 XLEN=0.0 10755 YLEN=0.0 10756C 10757 IEND=0 10758C 10759 IDRAW='OFF' 10760C 10761 XEND99=X0 10762 YEND99=Y0 10763C 10764 1210 CONTINUE 10765 ISTART=IEND+1 10766 IF(ISTART.GT.NUMCHS)GOTO1250 10767C 10768C ************************************ 10769C ** STEP 22-- ** 10770C ** DECODE THE NEXT CHARACTER ** 10771C ** (OR THE NEXT FEW CHARACTERS) ** 10772C ************************************ 10773C 10774 CALL DPSCAN(ISTART,ISTRIN,NUMCHS,ILOCR2, 10775 1ICHAR2,IOP,IFONT,ICASE,IJUST,ISEQUE,ISUBSU, 10776 1HMAX,VMAX,AMAX,X0,Y0,ANGLE,WIDTH,HEIGHT, 10777 1IEND,IFOUNC,IFOUNO,IBUGD2,IERROR) 10778 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR7') 10779 1WRITE(ICOUT,1212)ICHAR2,IOP,ISTART,IEND,IFOUNC, 10780 1IFOUNO 10781 1212 FORMAT('ICHAR2,IOP,ISTART,IEND,IFOUNC,IFOUNO = ', 10782 1A4,2X,A4,I8,I8,2X,A4,2X,A4) 10783 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR7') 10784 1CALL DPWRST('XXX','BUG ') 10785C 10786C ********************************************* 10787C ** STEP 23-- ** 10788C ** DETERMINE THE LENGTH OF THE CHARACTER ** 10789C ********************************************* 10790C 10791 CALL DPSBSP(IFOUNO,IOP,XEND99,YEND99,HEIGHT,WIDTH, 10792 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 10793 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 10794 1ANGLE,AMAX, 10795 1IBUGD2,IERROR) 10796 IF(IFOUNO.EQ.'YES')GOTO1240 10797C 10798 XSTA99=XEND99 10799 YSTA99=YEND99 10800CCCCC OCTOBER 1993. HANDLE CASE IF ICHAR2 IS LOWER CASE. 10801 ICASE2=ICASE 10802 CALL DPCOAN(ICHAR2(1:1),IVAL) 10803 IF(IVAL.GE.97.AND.IVAL.LE.122)THEN 10804 IVAL=IVAL-32 10805 CALL DPCONA(IVAL,ICHAR2(1:1)) 10806 IF(ICASE.EQ.'LOWE'.OR.ICASE.EQ.'ASIS')ICASE2='LOWE' 10807 ELSE 10808 IF(ICASE.EQ.'ASIS')ICASE2='UPPE' 10809 END IF 10810CCCCC END CHANGE 10811C 10812 CALL DPSCR8(ICHAR2,XSTA99,YSTA99,IDRAW, 10813CCCCC1IFONT,ICASE,ANGLE,HMAX,VMAX,AMAX,WIDTH,HEIGHT, 10814 1IFONT,ICASE2,ANGLE,HMAX,VMAX,AMAX,WIDTH,HEIGHT, 10815 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 10816 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 10817 1ANUMHP,ANUMVP, 10818 1IPATT,PTHICK,ICOL, 10819 1JPATT,JTHICK,PTHIC2,JCOL, 10820 1XEND99,YEND99, 10821 1ISPAC, 10822 1IFILL, 10823 1IFOUND,IBUGD2,IERROR) 10824C 10825 1240 CONTINUE 10826 GOTO1210 10827C 10828 1250 CONTINUE 10829 XLEN=XEND99-X0 10830 YLEN=YEND99-Y0 10831C 10832C *************************************** 10833C ** STEP 24-- ** 10834C ** RESTORE VALUES TO THOSE AT TIME ** 10835C ** OF INPUT TO THIS SUBROUTINE ** 10836C *************************************** 10837C 10838 IFONT=IFONSV 10839 ICASE=ICASSV 10840 HEIGHT=HEIGSV 10841 WIDTH=WIDTSV 10842C 10843 PHEIGH=PHEISV 10844 PWIDTH=PWIDSV 10845 PVEGAP=PVEGSV 10846 PHOGAP=PHOGSV 10847C 10848 PHEIG2=PHE2SV 10849 PWIDT2=PWI2SV 10850 PVEGA2=PVG2SV 10851 PHOGA2=PHG2SV 10852C 10853 IF(IMPSW2.EQ.'ON')THEN 10854 PHEIGH=PHEIGH*AMPSCH 10855 PVEGAP=PVEGAP*AMPSCH 10856 PWIDTH=PWIDTH*AMPSCW 10857 PHOGAP=PHOGAP*AMPSCW 10858 PHEIG2=PHEIG2*AMPSCH 10859 PVEGA2=PVEGA2*AMPSCH 10860 PWIDT2=PWIDT2*AMPSCW 10861 PHOGA2=PHOGA2*AMPSCW 10862 HEIGHT=HEIGHT*AMPSCH 10863 WIDTH=WIDTH*AMPSCW 10864 ENDIF 10865C ************************************************ 10866C ** STEP 25-- ** 10867C ** COMPUTE STARTING POINT ** 10868C ** FOR THE CENTER- OR RIGHT-JUSTIFIED STRING ** 10869C ************************************************ 10870C 10871CCCCC IF(IJUST.EQ.'CENT')X02=X0-(XLEN/2.0) 10872 IF(IJUST.EQ.'CENT')X02=X0-(XLEN/2.0)+(PHOGAP/2.0) 10873 IF(IJUST.EQ.'CENT')Y02=Y0-(YLEN/2.0) 10874C 10875CCCCC IF(IJUST.EQ.'CEBO')X02=X0-(XLEN/2.0) 10876 IF(IJUST.EQ.'CEBO')X02=X0-(XLEN/2.0)+(PHOGAP/2.0) 10877 IF(IJUST.EQ.'CEBO')Y02=Y0-(YLEN/2.0) 10878C 10879CCCCC IF(IJUST.EQ.'CECE')X02=X0-(XLEN/2.0) 10880 IF(IJUST.EQ.'CECE')X02=X0-(XLEN/2.0)+(PHOGAP/2.0) 10881 IF(IJUST.EQ.'CECE')Y02=Y0-(YLEN/2.0)-PHEIGH/2.0 10882C 10883CCCCC IF(IJUST.EQ.'CETO')X02=X0-(XLEN/2.0) 10884 IF(IJUST.EQ.'CETO')X02=X0-(XLEN/2.0)+(PHOGAP/2.0) 10885 IF(IJUST.EQ.'CETO')Y02=Y0-(YLEN/2.0)-PHEIGH 10886C 10887 IF(IJUST.EQ.'RIGH')X02=X0-XLEN 10888 IF(IJUST.EQ.'RIGH')Y02=Y0-YLEN 10889C 10890 IF(IJUST.EQ.'RIBO')X02=X0-XLEN 10891 IF(IJUST.EQ.'RIBO')Y02=Y0-YLEN 10892C 10893 IF(IJUST.EQ.'RICE')X02=X0-XLEN 10894 IF(IJUST.EQ.'RICE')Y02=Y0-YLEN-PHEIGH/2.0 10895C 10896 IF(IJUST.EQ.'RITO')X02=X0-XLEN 10897 IF(IJUST.EQ.'RITO')Y02=Y0-YLEN-PHEIGH 10898C 10899 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SCR7')GOTO1259 10900 WRITE(ICOUT,999) 10901 CALL DPWRST('XXX','BUG ') 10902 WRITE(ICOUT,1251) 10903 1251 FORMAT('***** FROM THE MIDDLE OF DPSCR7--') 10904 CALL DPWRST('XXX','BUG ') 10905 WRITE(ICOUT,1252)IJUST,XLEN,YLEN,PWIDT2,PHEIG2 10906 1252 FORMAT('IJUST,XLEN,YLEN,PWIDT2,PHEIG2 = ',A4,4E15.7) 10907 CALL DPWRST('XXX','BUG ') 10908 WRITE(ICOUT,1253)X0,Y0,X02,Y02 10909 1253 FORMAT('X0,Y0,X02,Y02 = ',4E15.7) 10910 CALL DPWRST('XXX','BUG ') 10911 1259 CONTINUE 10912C 10913 IEND=0 10914C 10915 XEND=X02 10916 YEND=Y02 10917C 10918 IDRAW='ON' 10919C 10920 1260 CONTINUE 10921 ISTART=IEND+1 10922 IF(ISTART.GT.NUMCHS)GOTO1290 10923C 10924C ************************************ 10925C ** STEP 26-- ** 10926C ** DECODE THE NEXT CHARACTER ** 10927C ** (OR THE NEXT FEW CHARACTERS) ** 10928C ************************************ 10929C 10930 CALL DPSCAN(ISTART,ISTRIN,NUMCHS,ILOCR2, 10931 1ICHAR2,IOP,IFONT,ICASE,IJUST,ISEQUE,ISUBSU, 10932 1HMAX,VMAX,AMAX,X0,Y0,ANGLE,WIDTH,HEIGHT, 10933 1IEND,IFOUNC,IFOUNO,IBUGD2,IERROR) 10934 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR7') 10935 1WRITE(ICOUT,1262)ICHAR2,IOP,ISTART,IEND,IFOUNC, 10936 1IFOUNO 10937 1262 FORMAT('ICHAR2,IOP,ISTART,IEND,IFOUNC,IFOUNO = ', 10938 1A4,2X,A4,I8,I8,2X,A4,2X,A4) 10939 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR7') 10940 1CALL DPWRST('XXX','BUG ') 10941C 10942C ****************************** 10943C ** STEP 27-- ** 10944C ** DRAW OUT THE CHARACTER ** 10945C ****************************** 10946C 10947 CALL DPSBSP(IFOUNO,IOP,XEND,YEND,HEIGHT,WIDTH, 10948 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 10949 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 10950 1ANGLE,AMAX, 10951 1IBUGD2,IERROR) 10952 IF(IFOUNO.EQ.'YES')GOTO1280 10953C 10954 XSTART=XEND 10955 YSTART=YEND 10956CCCCC OCTOBER 1993. HANDLE CASE IF ICHAR2 IS LOWER CASE. 10957 ICASE2=ICASE 10958 CALL DPCOAN(ICHAR2(1:1),IVAL) 10959 IF(IVAL.GE.97.AND.IVAL.LE.122)THEN 10960 IVAL=IVAL-32 10961 CALL DPCONA(IVAL,ICHAR2(1:1)) 10962 IF(ICASE.EQ.'LOWE'.OR.ICASE.EQ.'ASIS')ICASE2='LOWE' 10963 ELSE 10964 IF(ICASE.EQ.'ASIS')ICASE2='UPPE' 10965 END IF 10966CCCCC END CHANGE 10967C 10968 CALL DPSCR8(ICHAR2,XSTART,YSTART,IDRAW, 10969CCCCC1IFONT,ICASE,ANGLE,HMAX,VMAX,AMAX,WIDTH,HEIGHT, 10970 1IFONT,ICASE2,ANGLE,HMAX,VMAX,AMAX,WIDTH,HEIGHT, 10971 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 10972 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 10973 1ANUMHP,ANUMVP, 10974 1IPATT,PTHICK,ICOL, 10975 1JPATT,JTHICK,PTHIC2,JCOL, 10976 1XEND,YEND, 10977 1ISPAC, 10978 1IFILL, 10979 1IFOUND,IBUGD2,IERROR) 10980C 10981 1280 CONTINUE 10982 GOTO1260 10983C 10984 1290 CONTINUE 10985 IF(IJUST.EQ.'CECE')YEND=YEND+PHEIGH/2.0 10986 IF(IJUST.EQ.'CETO')YEND=YEND+PHEIGH 10987 IF(IJUST.EQ.'RICE')YEND=YEND+PHEIGH/2.0 10988 IF(IJUST.EQ.'RITO')YEND=YEND+PHEIGH 10989 GOTO8000 10990C 10991C *************************************** 10992C ** STEP 28-- ** 10993C ** RESTORE VALUES TO THOSE AT TIME ** 10994C ** OF INPUT TO THIS SUBROUTINE ** 10995C *************************************** 10996C 10997 8000 CONTINUE 10998 IFONT=IFONSV 10999 ICASE=ICASSV 11000 WIDTH=WIDTSV 11001 HEIGHT=HEIGSV 11002C 11003 PHEIGH=PHEISV 11004 PWIDTH=PWIDSV 11005 PVEGAP=PVEGSV 11006 PHOGAP=PHOGSV 11007C 11008 PHEIG2=PHE2SV 11009 PWIDT2=PWI2SV 11010 PVEGA2=PVG2SV 11011 PHOGA2=PHG2SV 11012 GOTO9000 11013C 11014C ***************** 11015C ** STEP 90-- ** 11016C ** EXIT ** 11017C ***************** 11018C 11019 9000 CONTINUE 11020 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SCR7')GOTO9090 11021 WRITE(ICOUT,999) 11022 CALL DPWRST('XXX','BUG ') 11023 WRITE(ICOUT,9011) 11024 9011 FORMAT('***** AT THE END OF DPSCR7--') 11025 CALL DPWRST('XXX','BUG ') 11026 WRITE(ICOUT,9012)XEND,YEND 11027 9012 FORMAT('XEND,YEND = ',2E15.7) 11028 CALL DPWRST('XXX','BUG ') 11029 WRITE(ICOUT,9013)IPATT,JPATT 11030 9013 FORMAT('IPATT,JPATT = ',A4,I8) 11031 CALL DPWRST('XXX','BUG ') 11032 WRITE(ICOUT,9020)ICOL,JCOL,PTHICK,JTHICK,PTHIC2 11033 9020 FORMAT('ICOL,JCOL,PTHICK,JTHICK,PTHIC2 = ', 11034 1A4,I8,E15.7,I8,E15.7) 11035 CALL DPWRST('XXX','BUG ') 11036 WRITE(ICOUT,9022)PHEIGH,PWIDTH,PVEGAP,PHOGAP 11037 9022 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4E15.7) 11038 CALL DPWRST('XXX','BUG ') 11039 WRITE(ICOUT,9023)PHEIG2,PWIDT2,PVEGA2,PHOGA2 11040 9023 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4E15.7) 11041 CALL DPWRST('XXX','BUG ') 11042 WRITE(ICOUT,9025)ISYMBL,ISPAC 11043 9025 FORMAT('ISYMBL,ISPAC = ',A24,2X,A4) 11044 CALL DPWRST('XXX','BUG ') 11045 WRITE(ICOUT,9026)IFILL 11046 9026 FORMAT('IFILL = ',A4) 11047 CALL DPWRST('XXX','BUG ') 11048 WRITE(ICOUT,9028)IFOUND,IBUGD2,IERROR 11049 9028 FORMAT('IFOUND,IBUGD2,IERROR = ',A4,2X,A4,2X,A4) 11050 CALL DPWRST('XXX','BUG ') 11051 WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4 11052 9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 11053 CALL DPWRST('XXX','BUG ') 11054 9090 CONTINUE 11055C 11056 RETURN 11057 END 11058 SUBROUTINE DPSCR8(ICHAR2,XSTART,YSTART,IDRAW, 11059 1IFONT,ICASE,ANGLE,HMAX,VMAX,AMAX,WIDTH,HEIGHT, 11060 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 11061 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 11062 1ANUMHP,ANUMVP, 11063 1IPATT,PTHICK,ICOL, 11064 1JPATT,JTHICK,PTHIC2,JCOL, 11065 1XEND,YEND, 11066 1ISPAC, 11067 1IFILL, 11068 1IFOUND,IBUG,IERROR) 11069C 11070C PURPOSE--SCRIBE OUT THE SINGLE CHARACTER 11071C IN THE HOLLERITH VARIABLE ICHAR2. 11072C NOTE--ICHAR2 SHOULD CONTAIN A SINGLE CHARACTER 11073C OR SHOULD CONTAIN AN ABBREVIATED 11074C STRING (4 CHARACTERS AT MOST) INDICATING A DESIRED 11075C MATH OPERATION, GREEK LETTER, ETC. 11076C THE ABBREVIATED STRING HAS HAD () REMOVED. 11077C THE PRE-CHECKING AND FORMATION OF A VALID ICHAR2 11078C WAS DONE IN DPSCAN. 11079C INPUT ARGUMENTS--ICHAR2 = THE HOLLERITH VARIABLE 11080C CONTAINING THE CHARACTER OF INTEREST. 11081C XSTART = THE STARTING HORIZONTAL COORDINATE; 11082C THE HORIZONTAL COORDINATE OF THE 11083C BOTTOM LEFT POINT OF THE FIRST CHARACTER. 11084C XSTART MAY BE IN ANY UNITS, BUT IS USUALLY 11085C GIVEN IN % UNITS, INCHES, CENTIMETERS, OR 11086C TEKTRONIX PICTURE POINTS. 11087C YSTART = THE STARTING VERTICAL COORDINATE; 11088C THE VERTICAL COORDINATE OF THE 11089C BOTTOM LEFT POINT OF THE FIRST CHARACTER. 11090C YSTART MAY BE IN ANY UNITS, BUT IS USUALLY 11091C GIVEN IN % UNITS, INCHES, CENTIMETERS, OR 11092C TEKTRONIX PICTURE POINTS. 11093C HEIGHT = THE HEIGHT OF THE CHARACTERS (INCLUDING GAP); 11094C THE HEIGHT OF A CHARACTER 11095C MAY BE IN ANY UNITS, BUT IS USUALLY 11096C GIVEN IN % UNITS, INCHES, CENTIMETERS, OR 11097C TEKTRONIX PICTURE POINTS. 11098C 11099C WIDTH = THE WIDTH OF THE CHARACTERS (INCLUDING GAP); 11100C THE WIDTH OF A CHARACTER 11101C MAY BE IN ANY UNITS, BUT IS USUALLY 11102C GIVEN IN % UNITS, INCHES, CENTIMETERS, OR 11103C TEKTRONIX PICTURE POINTS. 11104C 11105C WRITTEN BY--JAMES J. FILLIBEN 11106C STATISTICAL ENGINEERING DIVISION 11107C INFORMATION TECHNOLOGY LABORATORY 11108C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11109C GAITHERSBURG, MD 20899-8980 11110C PHONE--301-975-2899 11111C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11112C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11113C LANGUAGE--ANSI FORTRAN (1977) 11114C VERSION NUMBER--82/7 11115C ORIGINAL VERSION-- 11116C UPDATED --SEPTEMBER 1981. 11117C UPDATED --MARCH 1982. 11118C UPDATED --MAY 1982. 11119C UPDATED --OCTOBER 1991. ADDED SOME ABBREVIATIONS FOR CHARACTER 11120C FILL. ALAN 11121C UPDATED --AUGUST 1992. ADD SOME CHAR FILL (ALAN) 11122C 11123C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11124C 11125 CHARACTER*4 ICHAR2 11126 CHARACTER*4 IDRAW 11127 CHARACTER*4 IPATT 11128 CHARACTER*4 IFONT 11129 CHARACTER*4 ICASE 11130 CHARACTER*4 ICOL 11131 CHARACTER*4 ISPAC 11132 CHARACTER*4 IFILL 11133C 11134 CHARACTER*4 IFOUND 11135 CHARACTER*4 IBUG 11136 CHARACTER*4 IERROR 11137C 11138 CHARACTER*4 IOP 11139 CHARACTER*4 IFIG 11140 CHARACTER*4 IMATH 11141 CHARACTER*4 ICHAR3 11142 CHARACTER*4 IHORPA 11143 CHARACTER*4 IVERPA 11144 CHARACTER*4 IDUPPA 11145 CHARACTER*4 IDDOPA 11146C 11147 CHARACTER*4 ICOLF 11148 CHARACTER*4 ICOLP 11149 CHARACTER*4 IFLAG 11150C 11151 CHARACTER*4 IPATT2 11152C 11153C--------------------------------------------------------------------- 11154C 11155 DIMENSION IOP(100) 11156 DIMENSION X(100) 11157 DIMENSION Y(100) 11158C 11159 DIMENSION PX(100) 11160 DIMENSION PY(100) 11161C 11162CCCCC DIMENSION PX3(100) 11163CCCCC DIMENSION PY3(100) 11164C 11165C-----COMMON---------------------------------------------------------- 11166C 11167 INCLUDE 'DPCOBE.INC' 11168 INCLUDE 'DPCOP2.INC' 11169C 11170C-----START POINT----------------------------------------------------- 11171C 11172 IPATT2='SOLI' 11173 IMATH='NO' 11174C 11175 XFACHP=1.0 11176 YFACHP=1.0 11177 XMINC=0.0 11178 XMAXC=0.0 11179 XMINC2=0.0 11180 XMAXC2=0.0 11181 YMINC2=0.0 11182 YMAXC2=0.0 11183 X2=0.0 11184 X3=0.0 11185 X4=0.0 11186 XEND2=(-999.0) 11187 YEND2=(-999.0) 11188 I2=(-999) 11189 PPENTH=(-999.0) 11190 NLOOP=(-999) 11191C 11192 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SCR8')GOTO90 11193 WRITE(ICOUT,999) 11194 999 FORMAT(1X) 11195 CALL DPWRST('XXX','BUG ') 11196 WRITE(ICOUT,51) 11197 51 FORMAT('****** AT THE BEGINNING OF DPSCR8--') 11198 CALL DPWRST('XXX','BUG ') 11199 WRITE(ICOUT,52)ICHAR2,XSTART,YSTART,IDRAW,WIDTH,HEIGHT 11200 52 FORMAT('ICHAR2,XSTART,YSTART,IDRAW,WIDTH,HEIGHT = ', 11201 1A4,2E15.7,2X,A4,2E15.7) 11202 CALL DPWRST('XXX','BUG ') 11203 WRITE(ICOUT,53)IFONT,ICASE,ANGLE 11204 53 FORMAT('IFONT,ICASE,ANGLE = ',A4,2X,A4,E15.7) 11205 CALL DPWRST('XXX','BUG ') 11206 WRITE(ICOUT,54)HMAX,VMAX,AMAX 11207 54 FORMAT('HMAX,VMAX,AMAX = ',3E15.7) 11208 CALL DPWRST('XXX','BUG ') 11209 WRITE(ICOUT,55)ANUMHP,ANUMVP 11210 55 FORMAT('ANUMHP,ANUMVP = ',2E15.7) 11211 CALL DPWRST('XXX','BUG ') 11212 WRITE(ICOUT,56)ISPAC 11213 56 FORMAT('ISPAC = ',A4) 11214 CALL DPWRST('XXX','BUG ') 11215 WRITE(ICOUT,57)IFILL 11216 57 FORMAT('IFILL = ',A4) 11217 CALL DPWRST('XXX','BUG ') 11218 WRITE(ICOUT,58)XEND,YEND 11219 58 FORMAT('XEND,YEND = ',2E15.7) 11220 CALL DPWRST('XXX','BUG ') 11221 WRITE(ICOUT,59)IPATT,JPATT 11222 59 FORMAT('IPATT,JPATT = ',A4,I8) 11223 CALL DPWRST('XXX','BUG ') 11224 WRITE(ICOUT,60)ICOL,JCOL,PTHICK,JTHICK,PTHIC2 11225 60 FORMAT('ICOL,JCOL,PTHICK,JTHICK,PTHIC2 = ', 11226 1A4,I8,E15.7,I8,E15.7) 11227 CALL DPWRST('XXX','BUG ') 11228 WRITE(ICOUT,62)PHEIGH,PWIDTH,PVEGAP,PHOGAP 11229 62 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4E15.7) 11230 CALL DPWRST('XXX','BUG ') 11231 WRITE(ICOUT,63)PHEIG2,PWIDT2,PVEGA2,PHOGA2 11232 63 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4E15.7) 11233 CALL DPWRST('XXX','BUG ') 11234 WRITE(ICOUT,69)IFOUND,IBUGG4,ISUBG4,IERROR 11235 69 FORMAT('IFOUND,IBUGG4,ISUBG4,IERROR = ',A4,2X,A4,2X,A4,2X,A4) 11236 CALL DPWRST('XXX','BUG ') 11237 90 CONTINUE 11238C 11239CCCCC ****************************************************** 11240CCCCC ** STEP 3.0-- ** 11241CCCCC ** COPY OVER VALUES FOR THE USUAL CASE (= 1 PASS) ** 11242CCCCC ****************************************************** 11243CCCCC 11244CCCCC ISTART = LOCATION (1 TO 4) OF FIRST CHARACTER IN ICHAR2 11245CCCCC (IF FIRST CHARACTER IS BLANK, THEN ISTART STILL = 1) 11246CCCCC ISTOP = LOCATION (1 TO 4) OF LAST NON-BLANK CHARACTER IN ICHAR2 11247CCCCC OR OF LAST CHARACTER BEFORE ( 11248CCCCC (UNLESS ( IS IN LOCATION 1) 11249CCCCC IPOINT = LOCATION (1 TO 4) OF CURRENTLOCATION OF ITNTEREST. 11250CCCCC ICHAR3 EITHER HAS ELEMENTS IPOINT TO ISTOP OF ICHAR2 11251CCCCC OR (IF NO MATCH WAS FOUND), 11252CCCCC ELEMENTS IPOINT OT IPOINT OF ICHAR2. 11253CCCCC ISTART AND ISTOP DO NOT CHANGE. 11254CCCCC IPOINT MAY CHANGE (INCREASE) IF NO MATCH 11255CCCCC 11256CCCCC ISTART=1 11257CCCCC ISTOP=4 11258CCCCC ICTEMP=ICHAR2(4:4) 11259CCCCC IF(ICTEMP.EQ.' ')ISTOP=3 11260CCCCC IF(ICTEMP.EQ.'(')ISTOP=3 11261CCCCC ICTEMP=ICHAR2(3:3) 11262CCCCC IF(ICTEMP.EQ.' ')ISTOP=2 11263CCCCC IF(ICTEMP.EQ.'(')ISTOP=2 11264CCCCC ICTEMP=ICHAR2(2:2) 11265CCCCC IF(ICTEMP.EQ.' ')ISTOP=1 11266CCCCC IF(ICTEMP.EQ.'(')ISTOP=1 11267CCCCC 11268CCCCC IPOINT=ISTART 11269C 11270 ICHAR3=ICHAR2 11271 XSTAR2=XSTART 11272 YSTAR2=YSTART 11273C 11274C ********************************************** 11275C ** STEP 3.1-- ** 11276C ** TREAT THE ROMAN ALPHABET, NUMERIC, AND ** 11277C ** STANDARD SYMBOLS CASE ** 11278C ********************************************** 11279C 11280 IF(IBUGG4.EQ.'ON' .OR. ISUBG4.EQ.'SCR8')THEN 11281 WRITE(ICOUT,1201) 11282 1201 FORMAT('***** FROM NEAR BEGINNING OF DPSCR8--') 11283 CALL DPWRST('XXX','BUG ') 11284 WRITE(ICOUT,1202)ICHAR2,ICHAR3 11285 1202 FORMAT('ICHAR2,ICHAR3 = ',A4,2X,A4) 11286 CALL DPWRST('XXX','BUG ') 11287CCCCC WRITE(ICOUT,1203)I2,ISTART,ISTOP 11288C1203 FORMAT('I2,ISTART,ISTOP = ',3I8) 11289CCCCC CALL DPWRST('XXX','BUG ') 11290 ENDIF 11291C 11292 IF(IFONT.EQ.'SIMP')GOTO1210 11293 IF(IFONT.EQ.'DUPL')GOTO1220 11294 IF(IFONT.EQ.'TRIP')GOTO1230 11295 IF(IFONT.EQ.'COMP')GOTO1240 11296 IF(IFONT.EQ.'TRII')GOTO1250 11297 IF(IFONT.EQ.'COMI')GOTO1260 11298 IF(IFONT.EQ.'SIMS')GOTO1270 11299 IF(IFONT.EQ.'COMS')GOTO1280 11300 GOTO1240 11301C 11302 1210 CONTINUE 11303 IFOUND='NO' 11304 IF(ICASE.EQ.'UPPE') 11305 1CALL DPRSU(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11306 1IBUG,IFOUND,IERROR) 11307 IF(ICASE.EQ.'LOWE') 11308 1CALL DPRSL(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11309 1IBUG,IFOUND,IERROR) 11310 IF(IFOUND.EQ.'NO') 11311 1CALL DPRSN(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11312 1IBUG,IFOUND,IERROR) 11313 IF(IFOUND.EQ.'NO') 11314 1CALL DPRSS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11315 1IBUG,IFOUND,IERROR) 11316 IF(IFOUND.EQ.'NO')GOTO1290 11317 GOTO1900 11318C 11319 1220 CONTINUE 11320 IFOUND='NO' 11321 IF(ICASE.EQ.'UPPE') 11322 1CALL DPRDU(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11323 1IBUG,IFOUND,IERROR) 11324 IF(ICASE.EQ.'LOWE') 11325 1CALL DPRDL(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11326 1IBUG,IFOUND,IERROR) 11327 IF(IFOUND.EQ.'NO') 11328 1CALL DPRDN(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11329 1IBUG,IFOUND,IERROR) 11330 IF(IFOUND.EQ.'NO') 11331 1CALL DPRDS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11332 1IBUG,IFOUND,IERROR) 11333 IF(IFOUND.EQ.'NO')GOTO1290 11334 GOTO1900 11335C 11336 1230 CONTINUE 11337 IFOUND='NO' 11338 IF(ICASE.EQ.'UPPE') 11339 1CALL DPRTU(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11340 1IBUG,IFOUND,IERROR) 11341 IF(ICASE.EQ.'LOWE') 11342 1CALL DPRTL(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11343 1IBUG,IFOUND,IERROR) 11344 IF(IFOUND.EQ.'NO') 11345 1CALL DPRTN(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11346 1IBUG,IFOUND,IERROR) 11347 IF(IFOUND.EQ.'NO') 11348 1CALL DPRTS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11349 1IBUG,IFOUND,IERROR) 11350 IF(IFOUND.EQ.'NO')GOTO1290 11351 GOTO1900 11352C 11353 1240 CONTINUE 11354 IFOUND='NO' 11355 IF(ICASE.EQ.'UPPE') 11356 1CALL DPRCU(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11357 1IBUG,IFOUND,IERROR) 11358 IF(ICASE.EQ.'LOWE') 11359 1CALL DPRCL(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11360 1IBUG,IFOUND,IERROR) 11361 IF(IFOUND.EQ.'NO') 11362 1CALL DPRCN(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11363 1IBUG,IFOUND,IERROR) 11364 IF(IFOUND.EQ.'NO') 11365 1CALL DPRCS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11366 1IBUG,IFOUND,IERROR) 11367 IF(IFOUND.EQ.'NO')GOTO1290 11368 GOTO1900 11369C 11370 1250 CONTINUE 11371 IFOUND='NO' 11372 IF(ICASE.EQ.'UPPE') 11373 1CALL DPRTIU(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11374 1IBUG,IFOUND,IERROR) 11375 IF(ICASE.EQ.'LOWE') 11376 1CALL DPRTIL(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11377 1IBUG,IFOUND,IERROR) 11378 IF(IFOUND.EQ.'NO') 11379 1CALL DPRTIN(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11380 1IBUG,IFOUND,IERROR) 11381CCCCC IF(IFOUND.EQ.'NO') 11382CCCCC1CALL DPRTIS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11383CCCCC1IBUG,IFOUND,IERROR) 11384 IF(IFOUND.EQ.'NO') 11385 1CALL DPRTS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11386 1IBUG,IFOUND,IERROR) 11387 IF(IFOUND.EQ.'NO')GOTO1290 11388 GOTO1900 11389C 11390 1260 CONTINUE 11391 IFOUND='NO' 11392 IF(ICASE.EQ.'UPPE') 11393 1CALL DPRCIU(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11394 1IBUG,IFOUND,IERROR) 11395 IF(ICASE.EQ.'LOWE') 11396 1CALL DPRCIL(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11397 1IBUG,IFOUND,IERROR) 11398 IF(IFOUND.EQ.'NO') 11399 1CALL DPRCIN(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11400 1IBUG,IFOUND,IERROR) 11401CCCCC IF(IFOUND.EQ.'NO') 11402CCCCC1CALL DPRCIS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11403CCCCC1IBUG,IFOUND,IERROR) 11404 IF(IFOUND.EQ.'NO') 11405 1CALL DPRCS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11406 1IBUG,IFOUND,IERROR) 11407 IF(IFOUND.EQ.'NO')GOTO1290 11408 GOTO1900 11409C 11410 1270 CONTINUE 11411 IFOUND='NO' 11412 IF(ICASE.EQ.'UPPE') 11413 1CALL DPRSSU(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11414 1IBUG,IFOUND,IERROR) 11415 IF(ICASE.EQ.'LOWE') 11416 1CALL DPRSSL(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11417 1IBUG,IFOUND,IERROR) 11418CCCCC IF(IFOUND.EQ.'NO') 11419CCCCC1CALL DPRSSN(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11420CCCCC1IBUG,IFOUND,IERROR) 11421 IF(IFOUND.EQ.'NO') 11422 1CALL DPRSN(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11423 1IBUG,IFOUND,IERROR) 11424CCCCC IF(IFOUND.EQ.'NO') 11425CCCCC1CALL DPRSSS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11426CCCCC1IBUG,IFOUND,IERROR) 11427 IF(IFOUND.EQ.'NO') 11428 1CALL DPRSS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11429 1IBUG,IFOUND,IERROR) 11430 IF(IFOUND.EQ.'NO')GOTO1290 11431 GOTO1900 11432C 11433 1280 CONTINUE 11434 IFOUND='NO' 11435 IF(ICASE.EQ.'UPPE') 11436 1CALL DPRCSU(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11437 1IBUG,IFOUND,IERROR) 11438 IF(ICASE.EQ.'LOWE') 11439 1CALL DPRCSL(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11440 1IBUG,IFOUND,IERROR) 11441 IF(IFOUND.EQ.'NO') 11442 1CALL DPRCSN(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11443 1IBUG,IFOUND,IERROR) 11444CCCCC IF(IFOUND.EQ.'NO') 11445CCCCC1CALL DPRCSS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11446CCCCC1IBUG,IFOUND,IERROR) 11447 IF(IFOUND.EQ.'NO') 11448 1CALL DPRCS(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11449 1IBUG,IFOUND,IERROR) 11450 IF(IFOUND.EQ.'NO')GOTO1290 11451 GOTO1900 11452C 11453 1290 CONTINUE 11454C 11455C ************************************* 11456C ** STEP 3.2-- ** 11457C ** TREAT THE GREEK ALPHABET CASE ** 11458C ************************************* 11459C 11460 IF(IFONT.EQ.'SIMP')GOTO1310 11461 GOTO1340 11462C 11463 1310 CONTINUE 11464 IFOUND='NO' 11465 IF(ICASE.EQ.'UPPE') 11466 1CALL DPGSU(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11467 1IBUG,IFOUND,IERROR) 11468 IF(ICASE.EQ.'LOWE') 11469 1CALL DPGSL(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11470 1IBUG,IFOUND,IERROR) 11471 IF(IFOUND.EQ.'NO')GOTO1390 11472 GOTO1900 11473C 11474 1340 CONTINUE 11475 IFOUND='NO' 11476 IF(ICASE.EQ.'UPPE') 11477 1CALL DPGCU(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11478 1IBUG,IFOUND,IERROR) 11479 IF(ICASE.EQ.'LOWE') 11480 1CALL DPGCL(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11481 1IBUG,IFOUND,IERROR) 11482 IF(IFOUND.EQ.'NO')GOTO1390 11483 GOTO1900 11484C 11485 1390 CONTINUE 11486C 11487C *********************************** 11488C ** STEP 3.3-- ** 11489C ** TREAT THE MATH SYMBOLS CASE ** 11490C *********************************** 11491C 11492 IFOUND='NO' 11493 CALL DPMATH(ICHAR3,IOP,X,Y,NUMCO,IXMINC,IXMAXC,IXDELC, 11494 1 IBUG,IFOUND,IERROR) 11495 IF(IFOUND.EQ.'YES')IMATH='YES' 11496 IF(IFOUND.EQ.'NO')GOTO1490 11497 GOTO1900 11498C 11499 1490 CONTINUE 11500C 11501CCCCC **************************************** 11502CCCCC ** STEP 3.4-- ** 11503CCCCC ** IF NO MATCH FOUND, ** 11504CCCCC ** THEN WRITE OUT AN ERROR MESSAGE. ** 11505CCCCC **************************************** 11506C 11507C1500 CONTINUE 11508CCCCC WRITE(ICOUT,999) 11509CCCCC CALL DPWRST('XXX','BUG ') 11510CCCCC WRITE(ICOUT,1511) 11511C1511 FORMAT('***** ERROR IN DPSCR8--') 11512CCCCC CALL DPWRST('XXX','BUG ') 11513CCCCC WRITE(ICOUT,1512) 11514C1512 FORMAT(' NO MATCH FOUND IN AVAILABLE HERSHEY ') 11515CCCCC CALL DPWRST('XXX','BUG ') 11516CCCCC WRITE(ICOUT,1513) 11517C1513 FORMAT(' SYMBOL SETS FOR THE GIVEN INPUT CHARACTER.') 11518CCCCC CALL DPWRST('XXX','BUG ') 11519CCCCC WRITE(ICOUT,1514)ICHAR2 11520C1514 FORMAT(' INPUT CHARACTER = ',A4) 11521CCCCC CALL DPWRST('XXX','BUG ') 11522CCCCC WRITE(ICOUT,1515)IFONT 11523C1515 FORMAT(' INPUT FONT = ',A4) 11524CCCCC CALL DPWRST('XXX','BUG ') 11525CCCCC WRITE(ICOUT,1516)ICASE 11526C1516 FORMAT(' INPUT CASE = ',A4) 11527CCCCC CALL DPWRST('XXX','BUG ') 11528 IERROR='YES' 11529 GOTO9000 11530C 11531C 11532CCCCC STEP 3.4-- 11533CCCCC IF NO MATCH FOUND, 11534CCCCC THEN DECOMPOSE ICHAR2-- 11535CCCCC STRIP OFF CURRENT LEAD CHARACTER AND PROCESS IT. 11536CCCCC 11537C1500 CONTINUE 11538CCCCC IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SCR8')GOTO1589 11539CCCCC WRITE(ICOUT,1581) 11540C1581 FORMAT('***** FROM THE MIDDLE OF DPSCR--') 11541CCCCC CALL DPWRST('XXX','BUG ') 11542CCCCC WRITE(ICOUT,1582) 11543C1582 FORMAT(' NO MATCH FOUND IN EXAMINING ICHAR3 = ',A4) 11544CCCCC CALL DPWRST('XXX','BUG ') 11545CCCCC WRITE(ICOUT,1583)ICHAR2,ICHAR3 11546C1583 FORMAT('ICHAR2,ICHAR3 = ',A4,2X,A4) 11547CCCCC CALL DPWRST('XXX','BUG ') 11548CCCCC WRITE(ICOUT,1584)I2,ISTART,ISTOP,IPOINT,ISTOP 11549C1584 FORMAT('I2,ISTART,ISTOP,IPOINT,ISTOP = ',5I8) 11550CCCCC CALL DPWRST('XXX','BUG ') 11551C1589 CONTINUE 11552CC 11553CCCCC IF(IPOINT.GE.ISTOP)GOTO1570 11554CCCCC GOTO1580 11555CC 11556C1570 CONTINUE 11557CCCCC IERROR='YES' 11558CCCCC GOTO9000 11559C1580 CONTINUE 11560CCCCC ICHAR3=' ' 11561CCCCC ICHAR3(1:1)=ICHAR2(IPOINT:IPOINT) 11562CCCCC IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SCR8')GOTO1599 11563CCCCC WRITE(ICOUT,1591) 11564C1591 FORMAT('***** FROM THE MIDDLE+ OF DPSCR--') 11565CCCCC CALL DPWRST('XXX','BUG ') 11566CCCCC WRITE(ICOUT,1592)ICHAR2,ICHAR3 11567C1592 FORMAT('ICHAR2,ICHAR3 = ',A4,2X,A4) 11568CCCCC CALL DPWRST('XXX','BUG ') 11569CCCCC WRITE(ICOUT,1593)I2,ISTART,ISTOP 11570C1593 FORMAT('I2,ISTART,ISTOP = ',3I8) 11571CCCCC CALL DPWRST('XXX','BUG ') 11572C1599 CONTINUE 11573CCCCC GOTO1200 11574C1590 CONTINUE 11575C 11576C **************************************************** 11577C ** STEP XX-- ** 11578C ** BRANCH POINT FOR A SUCCESSFUL FIND ** 11579C ** (IN THE VARIOUS FONTS) OF ICHAR2 FROM ABOVE. ** 11580C **************************************************** 11581C 11582 1900 CONTINUE 11583C 11584C **************************************************************** 11585C ** STEP XX-- 11586C ** DRAW OUT THE CHARACTER (IF IDRAW IS ON). 11587C ** INVISIBLY DRAW OUT THE CHARACTER (TO DETERMINE LENGTH) (IF I 11588C ** INDEX I IS THE POSITION IN THE COORDINATE VECTOR 11589C ** INDEX J IS THE VERTEX NUMBER WITHIN A SUB-TRACE 11590C ** 11591C ** NOTE--(XMAXC2-XMINC2) (= 20) HERSHEY UNITS = PWIDTH (= %) DA 11592C ** FOR BOTH FIXED SPACING AND PROPORTIONAL SPACING. 11593C ** THEREFORE TO TRANSLATE A HERSHEY DIFFERENCE 11594C ** INTO A DATAPLOT (0 TO 100% UNITS) DIFFERENCE, 11595C ** MULTIPLY THE HERSHEY DIFFERENCE BY PWIDTH/(XMAXC2-XMINC2) 11596C ** = PWIDTH/20 11597C **************************************************************** 11598C 11599C NOTE--THE VALUES -8 TO 8 ARE THE ACTUAL HERSHEY 11600C WIDTH OF THE ROMAN SIMPLEX UPPER CASE A 11601C AND -9 TO 12 ARE THE ACTUAL HERESHEY HEIGHT 11602C OF THE ROMAN SIMPLEX UPPER CASE A. 11603C 11604 XMINC=IXMINC 11605 XMAXC=IXMAXC 11606C 11607CCCCC XMINC2=(-10.0) 11608CCCCC XMAXC2=10.0 11609 XMINC2=(-8.0) 11610 XMAXC2=8.0 11611 IF(IMATH.EQ.'YES')XMINC2=XMINC 11612 IF(IMATH.EQ.'YES')XMAXC2=XMAXC 11613 YMINC2=(-9.0) 11614 YMAXC2=12.0 11615CCCCC IF(IMATH.EQ.'YES')YMINC2=(-10.0) 11616CCCCC IF(IMATH.EQ.'YES')YMAXC2=10.0 11617 IF(IMATH.EQ.'YES')YMINC2=XMINC 11618 IF(IMATH.EQ.'YES')YMAXC2=XMAXC 11619C 11620 XFACHP=PWIDTH/(XMAXC2-XMINC2) 11621 YFACHP=PHEIGH/(YMAXC2-YMINC2) 11622C 11623 I=0 11624 J=0 11625 2500 CONTINUE 11626 I=I+1 11627 IF(I.GT.NUMCO)GOTO2580 11628 IF(IOP(I).EQ.'MOVE')GOTO2510 11629 GOTO2530 11630C 11631 2510 CONTINUE 11632 NPTEMP=J 11633 IFIG='LINE' 11634 IF(J.GE.1.AND.IDRAW.EQ.'ON')GOTO2520 11635 GOTO2529 11636 2520 CONTINUE 11637 IFLAG='ON' 11638CCCCC CALL GRDRPL(PX,PY,NPTEMP, 11639CCCCC1IFIG,IPATT,PTHICK,ICOL, 11640CCCCC1JPATT,JTHICK,PTHIC2,JCOL) 11641 CALL DPDRPL(PX,PY,NPTEMP, 11642 1IFIG,IPATT,PTHICK,ICOL, 11643 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 11644C 11645CCCCC NP=NPTEMP 11646CCCCC PPENTH=0.1 11647CCCCC NLOOP=((PTHICK/(2.0*PPENTH))-1.0)+0.1 11648CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR8') 11649CCCCC1WRITE(ICOUT,3521)PPENTH,NLOOP 11650C3521 FORMAT('PPENTH,NLOOP = ',E15.7,I8) 11651CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR8') 11652CCCCC1CALL DPWRST('XXX','BUG ') 11653CCCCC IF(NLOOP.LE.0)GOTO3529 11654CCCCC DO3522K=1,NLOOP 11655CCCCC AK=K 11656CCCCC DEL=PPENTH*AK 11657CCCCC CALL GRDEPL(PX,PY,NP,DEL,PX3,PY3,NP3) 11658CCCCC CALL GRDRPL(PX3,PY3,NP3, 11659CCCCC1IFIG,IPATT,PTHICK,ICOL, 11660CCCCC1JPATT,JTHICK,PTHIC2,JCOL) 11661CCCCC DEL=(-PPENTH*AK) 11662CCCCC CALL GRDEPL(PX,PY,NP,DEL,PX3,PY3,NP3) 11663CCCCC CALL GRDRPL(PX3,PY3,NP3, 11664CCCCC1IFIG,IPATT,PTHICK,ICOL, 11665CCCCC1JPATT,JTHICK,PTHIC2,JCOL) 11666C3522 CONTINUE 11667C3529 CONTINUE 11668C 11669C ********************************* 11670C ** FILL (CERTAIN) CHARACTERS ** 11671C ********************************* 11672C 11673 IF(IFILL.EQ.'OFF')GOTO2528 11674 NPTEM2=NPTEMP 11675C OCTOBER 1991. FOLLOWING CODE MODIFIED TO RECOGNIZE CHARACTER ABREVIATIONS. 11676C SPECIFICALLY, ADDED TR, SQ, DI 11677 IF(ICHAR2.EQ.'TRIA')GOTO2521 11678 IF(ICHAR2.EQ.'TR')GOTO2521 11679 IF(ICHAR2.EQ.'SQUA')GOTO2521 11680 IF(ICHAR2.EQ.'SQ')GOTO2521 11681 IF(ICHAR2.EQ.'DIAM')GOTO2521 11682 IF(ICHAR2.EQ.'DI')GOTO2521 11683 IF(ICHAR2.EQ.'HEXA')GOTO2521 11684 IF(ICHAR2.EQ.'CIRC')GOTO2521 11685 IF(ICHAR2.EQ.'CI')GOTO2521 11686 IF(ICHAR2.EQ.'CUBE')NPTEM2=5 11687 IF(ICHAR2.EQ.'CUBE')GOTO2521 11688 IF(ICHAR2.EQ.'PYRA')NPTEM2=4 11689 IF(ICHAR2.EQ.'PYRA')GOTO2521 11690C 11691C FOLLOWING 6 LINES ADDED AUGUST 1992. 11692 IF(ICHAR2.EQ.'REVT')GOTO2521 11693 IF(ICHAR2.EQ.'TRIR')GOTO2521 11694 IF(ICHAR2.EQ.'TRII')GOTO2521 11695 IF(ICHAR2.EQ.'RT ')GOTO2521 11696 IF(ICHAR2.EQ.'ARRO')GOTO2521 11697 IF(ICHAR2.EQ.'ARRH')GOTO2521 11698 GOTO2528 11699C 11700 2521 CONTINUE 11701CCCCC NP=NPTEMP ???? APRIL 28, 1987 11702 NP=NPTEM2 11703 IFLAG='LOOP' 11704CCCCC PPENTH=0.1 11705CCCCC NLOOP=((PHEIGH/(2.0*PPENTH))-1.0)+0.1 11706 CALL DPDRPL(PX,PY,NPTEM2, 11707 1IFIG,IPATT,PTHICK,ICOL, 11708 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 11709C 11710CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR8') 11711CCCCC1WRITE(ICOUT,2522)PWIDTH,PPENTH,NLOOP 11712C2522 FORMAT('PWIDTH,PPENTH,NLOOP = ',2E15.7,I8) 11713CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR8') 11714CCCCC1CALL DPWRST('XXX','BUG ') 11715C 11716CCCCC IF(NLOOP.LE.0)GOTO2528 11717CCCCC DO2523I=1,NLOOP 11718CCCCC AI=I 11719CCCCC DEL=PPENTH*AI 11720CCCCC CALL GRDEPL(PX,PY,NPTEMP,DEL,PX3,PY3,NP3) ???? APRIL 28, 1987 11721C CALL GRDEPL(PX,PY,NPTEM2,DEL,PX3,PY3,NP3) (THIS IS THE GOOD ONE) 11722CCCCC CALL GRDRPL(PX3,PY3,NP3, 11723CCCCC1IFIG,IPATT,PTHICK,ICOL, 11724CCCCC1JPATT,JTHICK,PTHIC2,JCOL) 11725C2523 CONTINUE 11726 2528 CONTINUE 11727C 11728 2529 CONTINUE 11729 J=0 11730 GOTO2530 11731C 11732 2530 CONTINUE 11733 J=J+1 11734CCCCC X2=X(I)-XMINC2 11735CCCCC IF(ISPAC.EQ.'PROP')X2=X(I)-XMINC 11736 X2=X(I)-XMINC 11737 Y2=Y(I)-YMINC2 11738 X3=X2*XFACHP 11739 Y3=Y2*YFACHP 11740 X5=XSTAR2+X3 11741 Y5=YSTAR2+Y3 11742 CALL DPROTA(X5,Y5,XSTAR2,YSTAR2,ANGLE,AMAX,X6,Y6) 11743 PX(J)=X6 11744 PY(J)=Y6 11745 GOTO2500 11746C 11747 2580 CONTINUE 11748 NPTEMP=J 11749 IF(J.GE.1.AND.IDRAW.EQ.'ON')GOTO2590 11750 GOTO2599 11751 2590 CONTINUE 11752 IFLAG='ON' 11753CCCCC CALL GRDRPL(PX,PY,NPTEMP, 11754CCCCC1IFIG,IPATT,PTHICK,ICOL, 11755CCCCC1JPATT,JTHICK,PTHIC2,JCOL) 11756 CALL DPDRPL(PX,PY,NPTEMP, 11757 1IFIG,IPATT,PTHICK,ICOL, 11758 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 11759C 11760CCCCC NP=NPTEMP 11761CCCCC PPENTH=0.1 11762CCCCC NLOOP=((PTHICK/(2.0*PPENTH))-1.0)+0.1 11763CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR8') 11764CCCCC1WRITE(ICOUT,4521)PPENTH,NLOOP 11765C4521 FORMAT('PPENTH,NLOOP = ',E15.7,I8) 11766CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'SCR8') 11767CCCCC1CALL DPWRST('XXX','BUG ') 11768CCCCC IF(NLOOP.LE.0)GOTO4529 11769CCCCC DO4522K=1,NLOOP 11770CCCCC AK=K 11771CCCCC DEL=PPENTH*AK 11772CCCCC CALL GRDEPL(PX,PY,NP,DEL,PX3,PY3,NP3) 11773CCCCC CALL GRDRPL(PX3,PY3,NP3, 11774CCCCC1IFIG,IPATT,PTHICK,ICOL, 11775CCCC 1JPATT,JTHICK,PTHIC2,JCOL) 11776CCCCC DEL=(-PPENTH*AK) 11777CCCCC CALL GRDEPL(PX,PY,NP,DEL,PX3,PY3,NP3) 11778CCCCC CALL GRDRPL(PX3,PY3,NP3, 11779CCCCC1IFIG,IPATT,PTHICK,ICOL, 11780CCCCC1JPATT,JTHICK,PTHIC2,JCOL) 11781C4522 CONTINUE 11782C 11783C ********************************* 11784C ** FILL (CERTAIN) CHARACTERS ** 11785C ********************************* 11786C 11787C OCTOBER 1991. FOLLOWING CODE MODIFIED TO RECOGNIZE CHARACTER 11788C ABREVIATIONS. SPECIFICALLY, ADDED TR, SQ, DI 11789C 11790 IF(IFILL.EQ.'OFF')GOTO2598 11791 NPTEM2=NPTEMP 11792 IF(ICHAR2.EQ.'TRIA')GOTO2591 11793 IF(ICHAR2.EQ.'TR')GOTO2591 11794 IF(ICHAR2.EQ.'SQUA')GOTO2591 11795 IF(ICHAR2.EQ.'SQ')GOTO2591 11796 IF(ICHAR2.EQ.'DIAM')GOTO2591 11797 IF(ICHAR2.EQ.'DI')GOTO2591 11798 IF(ICHAR2.EQ.'HEXA')GOTO2591 11799 IF(ICHAR2.EQ.'CIRC')GOTO2591 11800 IF(ICHAR2.EQ.'CI')GOTO2591 11801 IF(ICHAR2.EQ.'CUBE')NPTEM2=5 11802 IF(ICHAR2.EQ.'CUBE')GOTO2591 11803 IF(ICHAR2.EQ.'PYRA')NPTEM2=4 11804 IF(ICHAR2.EQ.'PYRA')GOTO2591 11805C 11806C FOLLOWING 6 LINES ADDED AUGUST 1992. 11807 IF(ICHAR2.EQ.'REVT')GOTO2591 11808 IF(ICHAR2.EQ.'TRIR')GOTO2591 11809 IF(ICHAR2.EQ.'TRII')GOTO2591 11810 IF(ICHAR2.EQ.'RT ')GOTO2591 11811 IF(ICHAR2.EQ.'ARRO')GOTO2591 11812 IF(ICHAR2.EQ.'ARRH')GOTO2591 11813 GOTO2598 11814C 11815 2591 CONTINUE 11816 IHORPA='OFF' 11817 IVERPA='ON' 11818 IDUPPA='OFF' 11819 IDDOPA='OFF' 11820 PXSPA2=0.1 11821 PYSPA2=0.1 11822 ICOLF=ICOL 11823 JCOLF=JCOL 11824 ICOLP=ICOL 11825 JCOLP=JCOL 11826CCCCC CALL GRFIRE(PX,PY,NPTEMP,IFIG, 11827CCCCC1IPATT,JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2, 11828CCCCC1PTHICK,JTHICK,PTHIC2, 11829CCCCC1ICOLF,JCOLF,ICOLP,JCOLP) 11830 CALL GRFIRE(PX,PY,NPTEM2,IFIG, 11831 1IPATT,JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2, 11832 1PTHICK,JTHICK,PTHIC2, 11833 1ICOLF,JCOLF,ICOLP,JCOLP, 11834 1IPATT2) 11835 2598 CONTINUE 11836C 11837 2599 CONTINUE 11838C 11839C X2 IS THE WIDTH OF THE CHARACTER (NO SPACING) IN HERSHEY UNITS 11840C X3 IS THE WIDTH OF THE CHARACTER (NO SPACING) IN DATAPLOT UNITS 11841C X4 IS THE WIDHT OF THE CHARACTER + SPACING IN DATAPLOT UNITS 11842C 11843 X2=XMAXC2-XMINC2 11844 IF(ISPAC.EQ.'PROP')X2=XMAXC-XMINC 11845 X3=X2*XFACHP 11846 X4=X3+PHOGAP 11847 X5=XSTAR2+X4 11848 Y5=YSTAR2 11849 CALL DPROTA(X5,Y5,XSTAR2,YSTAR2,ANGLE,AMAX,X6,Y6) 11850 XEND2=X6 11851 YEND2=Y6 11852C 11853C ******************************************************** 11854C ** STEP 3.6-- ** 11855C ** ARE WE DECOMPOSING ICHAR2 CHARACTER BY CHARACTER? ** 11856C ** (USUALLY N) IF NOT, THEN EXIT. ** 11857C ** IF SO, ARE WE DONE? ** 11858C ******************************************************** 11859C 11860CCCCC IF(ISTART.GE.ISTOP)GOTO2690 11861CCCCC ISTART=ISTART+1 11862CCCCC ICHAR3(1:1)=ICHAR2(ISTART:ISTART) 11863CCCCC XSTAR2=XEND2 11864CCCCC YSTAR2=YEND2 11865CCCCC GOTO1200 11866C2690 CONTINUE 11867 XEND=XEND2 11868 YEND=YEND2 11869C 11870C ***************** 11871C ** STEP 90-- ** 11872C ** EXIT ** 11873C ***************** 11874C 11875C 11876 9000 CONTINUE 11877C 11878 IF(IBUGG4.EQ.'ON' .OR. ISUBG4.EQ.'SCR8')THEN 11879 WRITE(ICOUT,999) 11880 CALL DPWRST('XXX','BUG ') 11881 WRITE(ICOUT,9011) 11882 9011 FORMAT('****** AT THE END OF DPSCR8--') 11883 CALL DPWRST('XXX','BUG ') 11884 WRITE(ICOUT,9012)XSTART,YSTART,XEND,YEND 11885 9012 FORMAT('XSTART,YSTART,XEND,YEND = ',4G15.7) 11886 CALL DPWRST('XXX','BUG ') 11887 WRITE(ICOUT,9019)ANUMHP,ANUMVP,ANGLE,AMAX 11888 9019 FORMAT('ANUMHP,ANUMVP,ANGLE,AMAX = ',4G15.7) 11889 CALL DPWRST('XXX','BUG ') 11890 WRITE(ICOUT,9020)ICOL,JCOL,PTHICK,JTHICK,PTHIC2 11891 9020 FORMAT('ICOL,JCOL,PTHICK,JTHICK,PTHIC2 = ', 11892 1 A4,I8,G15.7,I8,G15.7) 11893 CALL DPWRST('XXX','BUG ') 11894 WRITE(ICOUT,9024)ICHAR2,IDRAW,IFONT,ICASE 11895 9024 FORMAT('ICHAR2,IDRAW,IFONT,ICASE = ',3(A4,2X),A4) 11896 CALL DPWRST('XXX','BUG ') 11897 WRITE(ICOUT,9035)ISPAC,IFILL,IPATT,JPATT 11898 9035 FORMAT('ISPAC,IFILL,IPATT,JPATT = ',3(A4,2X),I8) 11899 CALL DPWRST('XXX','BUG ') 11900 WRITE(ICOUT,9038)PHEIGH,PWIDTH,PVEGAP,PHOGAP 11901 9038 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4G15.7) 11902 CALL DPWRST('XXX','BUG ') 11903 WRITE(ICOUT,9039)PHEIG2,PWIDT2,PVEGA2,PHOGA2 11904 9039 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4G15.7) 11905 CALL DPWRST('XXX','BUG ') 11906 WRITE(ICOUT,9041)IMATH,XMINC,XMAXC 11907 9041 FORMAT('IMATH,XMINC,XMAXC = ',A4,2X,2G15.7) 11908 CALL DPWRST('XXX','BUG ') 11909 WRITE(ICOUT,9042)XMINC2,XMAXC2,YMINC2,YMAXC2 11910 9042 FORMAT('XMINC2,XMAXC2,YMINC2,YMAXC2 = ',4G15.7) 11911 CALL DPWRST('XXX','BUG ') 11912 WRITE(ICOUT,9043)XFACHP,YFACHP,Y5,Y6 11913 9043 FORMAT('XFACHP,YFACHP,Y5,Y6 = ',4G15.7) 11914 CALL DPWRST('XXX','BUG ') 11915 WRITE(ICOUT,9044)X2,X3,X4,X5,X6 11916 9044 FORMAT('X2,X3,X4,X5,X6 = ',5G15.7) 11917 CALL DPWRST('XXX','BUG ') 11918 WRITE(ICOUT,9046)XSTART,XEND,YSTART,YEND 11919 9046 FORMAT('XSTART,XEND,YSTART,YEND = ',4G15.7) 11920 CALL DPWRST('XXX','BUG ') 11921 WRITE(ICOUT,9051)XSTAR2,XEND2,YSTAR2,YEND2 11922 9051 FORMAT('XSTAR2,XEND2,YSTAR2,YEND2 = ',4G15.7) 11923 CALL DPWRST('XXX','BUG ') 11924 WRITE(ICOUT,9053)ICHAR2,ICHAR3 11925 9053 FORMAT('ICHAR2,ICHAR3 = ',A4,2X,A4) 11926 CALL DPWRST('XXX','BUG ') 11927 WRITE(ICOUT,9056)PWIDTH,PPENTH,NLOOP 11928 9056 FORMAT('PWIDTH,PPENTH,NLOOP = ',2G15.7,I8) 11929 CALL DPWRST('XXX','BUG ') 11930 WRITE(ICOUT,9059)IFOUND,IBUGG4,ISUBG4,IERROR 11931 9059 FORMAT('IFOUND,IBUGG4,ISUBG4,IERROR = ',3(A4,2X),A4) 11932 CALL DPWRST('XXX','BUG ') 11933 ENDIF 11934C 11935 RETURN 11936 END 11937 SUBROUTINE DPSDCL(IHARG,NUMARG,IDSDCO,ISDFCO,IFOUND,IERROR) 11938C 11939C PURPOSE--DEFINE THE COLOR FOR THE 3-D SIDEFACE. 11940C THE COLOR FOR THE SIDEFACE WILL BE PLACED 11941C IN THE CHARACTER VARIABLE ISDFCO. 11942C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 11943C --NUMARG 11944C --IDSDCO 11945C OUTPUT ARGUMENTS--ISDFCO 11946C --IFOUND ('YES' OR 'NO' ) 11947C --IERROR ('YES' OR 'NO' ) 11948C NOTE--THIS SUBROUTINE ASSUMES A 11949C COMPLICATED-TO-SIMPLE CHECKING ORDER 11950C (IN MAIPC4) OF THE VARIOUS SIDEFACE COMMANDS. 11951C WRITTEN BY--JAMES J. FILLIBEN 11952C STATISTICAL ENGINEERING DIVISION 11953C INFORMATION TECHNOLOGY LABORATORY 11954C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11955C GAITHERSBURG, MD 20899-8980 11956C PHONE--301-975-2899 11957C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11958C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11959C LANGUAGE--ANSI FORTRAN (1977) 11960C VERSION NUMBER--88/10 11961C ORIGINAL VERSION--SEPTEMBER 1988. 11962C 11963C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11964C 11965 CHARACTER*4 IHARG 11966 CHARACTER*4 IDSDCO 11967 CHARACTER*4 ISDFCO 11968 CHARACTER*4 IFOUND 11969 CHARACTER*4 IERROR 11970C 11971C--------------------------------------------------------------------- 11972C 11973 DIMENSION IHARG(*) 11974C 11975C-----COMMON---------------------------------------------------------- 11976C 11977 INCLUDE 'DPCOP2.INC' 11978C 11979C-----START POINT----------------------------------------------------- 11980C 11981 IFOUND='NO' 11982 IERROR='NO' 11983C 11984 IF(NUMARG.EQ.0)GOTO1199 11985 IF(NUMARG.EQ.1)GOTO1150 11986C 11987 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 11988 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 11989 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 11990 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 11991 GOTO1160 11992C 11993 1150 CONTINUE 11994 ISDFCO=IDSDCO 11995 GOTO1180 11996C 11997 1160 CONTINUE 11998 ISDFCO=IHARG(NUMARG) 11999 GOTO1180 12000C 12001 1180 CONTINUE 12002 IFOUND='YES' 12003C 12004 IF(IFEEDB.EQ.'OFF')GOTO1189 12005 WRITE(ICOUT,999) 12006 999 FORMAT(1X) 12007 CALL DPWRST('XXX','BUG ') 12008 WRITE(ICOUT,1181)ISDFCO 12009 1181 FORMAT('THE (3-D) SIDEFACE COLOR ', 12010 1'HAS JUST BEEN SET TO ',A4) 12011 CALL DPWRST('XXX','BUG ') 12012 1189 CONTINUE 12013 GOTO1199 12014C 12015 1199 CONTINUE 12016 RETURN 12017 END 12018 SUBROUTINE DPSDCI(XTEMP1,XTEMP2,MAXNXT,ICASAN, 12019 1 ICAPSW,IFORSW,IMULT,IREPL, 12020 1 ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) 12021C 12022C PURPOSE--GENERATE A CONFIDENCE INTERVAL FOR THE STANDARD 12023C DEVIATION FOR NORMALLY DISTRIBUTED DATA. 12024C WRITTEN BY--ALAN HECKERT 12025C STATISTICAL ENGINEERING DIVISION 12026C INFORMATION TECHNOLOGY LABORATORY 12027C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 12028C GAITHERSBURG, MD 20899-8980 12029C PHONE--301-975-2899 12030C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12031C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 12032C LANGUAGE--ANSI FORTRAN (1977) 12033C VERSION NUMBER--2013/4 12034C ORIGINAL VERSION--APRIL 2013. 12035C UPDATED --DECEMBER 2017. ADD BONETT'S INTERVAL FOR 12036C NON-NORMAL DATA 12037C UPDATED --AUGUST 2019. ADD CTL999, CTU999 12038C 12039C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12040C 12041 CHARACTER*4 ICAPSW 12042 CHARACTER*4 IFORSW 12043 CHARACTER*4 ISUBRO 12044 CHARACTER*4 IBUGA2 12045 CHARACTER*4 IBUGA3 12046 CHARACTER*4 IBUGQ 12047 CHARACTER*4 IFOUND 12048 CHARACTER*4 IERROR 12049C 12050 CHARACTER*4 IHWUSE 12051 CHARACTER*4 MESSAG 12052 CHARACTER*4 IH 12053 CHARACTER*4 IH2 12054 CHARACTER*4 ICASAN 12055 CHARACTER*4 ICASA2 12056 CHARACTER*4 ICASA3 12057 CHARACTER*4 ICASA4 12058 CHARACTER*4 ICASE 12059 CHARACTER*4 ISUBN1 12060 CHARACTER*4 ISUBN2 12061 CHARACTER*4 ISTEPN 12062 CHARACTER*4 IFLAGU 12063C 12064 LOGICAL IFRST 12065 LOGICAL ILAST 12066C 12067 CHARACTER*4 IREPL 12068 CHARACTER*4 IMULT 12069 CHARACTER*4 ICTMP0 12070 CHARACTER*4 ICTMP1 12071 CHARACTER*4 ICTMP2 12072 CHARACTER*4 ICTMP3 12073 CHARACTER*4 ICTMP4 12074C 12075 CHARACTER*40 INAME 12076 PARAMETER (MAXSPN=30) 12077 CHARACTER*4 IVARN1(MAXSPN) 12078 CHARACTER*4 IVARN2(MAXSPN) 12079 CHARACTER*4 IVARTY(MAXSPN) 12080 CHARACTER*4 IVARID(MAXSPN) 12081 CHARACTER*4 IVARI2(MAXSPN) 12082 REAL PVAR(MAXSPN) 12083 REAL PID(MAXSPN) 12084 INTEGER ILIS(MAXSPN) 12085 INTEGER NRIGHT(MAXSPN) 12086 INTEGER ICOLR(MAXSPN) 12087C 12088C--------------------------------------------------------------------- 12089C 12090 INCLUDE 'DPCOPA.INC' 12091C 12092 DIMENSION XTEMP1(*) 12093 DIMENSION XTEMP2(*) 12094 DIMENSION TEMP1(MAXOBV) 12095 DIMENSION TEMP2(MAXOBV) 12096 DIMENSION TEMP3(MAXOBV) 12097C 12098 DIMENSION XDESGN(MAXOBV,6) 12099 DIMENSION XIDTEM(MAXOBV) 12100 DIMENSION XIDTE2(MAXOBV) 12101 DIMENSION XIDTE3(MAXOBV) 12102 DIMENSION XIDTE4(MAXOBV) 12103 DIMENSION XIDTE5(MAXOBV) 12104 DIMENSION XIDTE6(MAXOBV) 12105C 12106 INCLUDE 'DPCOZZ.INC' 12107 EQUIVALENCE (GARBAG(IGARB1),XIDTEM(1)) 12108 EQUIVALENCE (GARBAG(IGARB2),XIDTE2(1)) 12109 EQUIVALENCE (GARBAG(IGARB3),XIDTE3(1)) 12110 EQUIVALENCE (GARBAG(IGARB4),XIDTE4(1)) 12111 EQUIVALENCE (GARBAG(IGARB5),XIDTE5(1)) 12112 EQUIVALENCE (GARBAG(IGARB6),XIDTE6(1)) 12113 EQUIVALENCE (GARBAG(IGARB7),TEMP1(1)) 12114 EQUIVALENCE (GARBAG(IGARB8),TEMP2(1)) 12115 EQUIVALENCE (GARBAG(IGARB9),TEMP3(1)) 12116 EQUIVALENCE (GARBAG(IGAR10),XDESGN(1,1)) 12117C 12118C-----COMMON---------------------------------------------------------- 12119C 12120 INCLUDE 'DPCOHK.INC' 12121 INCLUDE 'DPCOSU.INC' 12122 INCLUDE 'DPCODA.INC' 12123 INCLUDE 'DPCOHO.INC' 12124 INCLUDE 'DPCOST.INC' 12125 INCLUDE 'DPCOP2.INC' 12126C 12127C-----START POINT----------------------------------------------------- 12128C 12129 ISUBN1='DPSD' 12130 ISUBN2='CI ' 12131 IFOUND='YES' 12132 IERROR='NO' 12133C 12134 MAXCP1=MAXCOL+1 12135 MAXCP2=MAXCOL+2 12136 MAXCP3=MAXCOL+3 12137 MAXCP4=MAXCOL+4 12138 MAXCP5=MAXCOL+5 12139 MAXCP6=MAXCOL+6 12140C 12141C ******************************************* 12142C ** TREAT THE SD CONFIDENCE LIMITS CASE ** 12143C ******************************************* 12144C 12145 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'SDCI')THEN 12146 WRITE(ICOUT,999) 12147 999 FORMAT(1X) 12148 CALL DPWRST('XXX','BUG ') 12149 WRITE(ICOUT,51) 12150 51 FORMAT('***** AT THE BEGINNING OF DPSDCI--') 12151 CALL DPWRST('XXX','BUG ') 12152 WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT 12153 52 FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT = ',4(A4,2X),I8) 12154 CALL DPWRST('XXX','BUG ') 12155 ENDIF 12156C 12157C ********************************* 12158C ** STEP 1-- ** 12159C ** EXTRACT THE COMMAND ** 12160C ********************************* 12161C 12162 ISTEPN='1' 12163 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SDCI') 12164 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12165C 12166C THE FOLLOWING COMMANDS ARE ACCEPTED: 12167C 12168C STANDARD DEVIATION CONFIDENCE LIMITS Y (TWO SIDED) 12169C LOWER STANDARD DEVIATION CONFIDENCE LIMITS Y (ONE SIDED) 12170C UPPER STANDARD DEVIATION CONFIDENCE LIMITS Y (ONE SIDED) 12171C 12172C 12173C IN ADDITION, CHECK FOR THE "MULTIPLE" AND "REPLICATION" OPTIONS. 12174C 12175 ILASTZ=9999 12176 IFOUND='NO' 12177 ICASAN='LIMI' 12178 ICASA2='UPPE' 12179 ICASA3='RAW' 12180 ICASA4='TWOS' 12181C 12182 DO100I=0,NUMARG-1 12183C 12184 ICTMP0='XXXX' 12185 IF(I.EQ.0)THEN 12186 ICTMP1=ICOM 12187 ICTMP2=IHARG(I+1) 12188 ICTMP3=IHARG(I+2) 12189 ICTMP4=IHARG(I+3) 12190 ELSE 12191 IF(I.GE.2)ICTMP0=IHARG(I-1) 12192 ICTMP1=IHARG(I) 12193 ICTMP2=IHARG(I+1) 12194 ICTMP3=IHARG(I+2) 12195 ICTMP4=IHARG(I+3) 12196 ENDIF 12197C 12198 IF(ICTMP1.EQ.'SD ' .AND. ICTMP2.EQ.'CONF' .AND. 12199 1 ICTMP3.EQ.'LIMI')THEN 12200 IFOUND='YES' 12201 ILASTZ=I+2 12202 ICASAN='SDLI' 12203 GOTO109 12204 ELSEIF(ICTMP1.EQ.'SD ' .AND. ICTMP2.EQ.'CONF' .AND. 12205 1 ICTMP3.EQ.'INTE')THEN 12206 IFOUND='YES' 12207 ILASTZ=I+2 12208 ICASAN='SDLI' 12209 GOTO109 12210 ELSEIF(ICTMP1.EQ.'STAN' .AND. ICTMP2.EQ.'DEVI' .AND. 12211 1 ICTMP3.EQ.'CONF' .AND. ICTMP4.EQ.'LIMI')THEN 12212 IFOUND='YES' 12213 ILASTZ=I+3 12214 ICASAN='SDLI' 12215 GOTO109 12216 ELSEIF(ICTMP1.EQ.'STAN' .AND. ICTMP2.EQ.'DEVI' .AND. 12217 1 ICTMP3.EQ.'CONF' .AND. ICTMP4.EQ.'INTE')THEN 12218 IFOUND='YES' 12219 ILASTZ=I+3 12220 ICASAN='SDLI' 12221 GOTO109 12222 ELSEIF(ICTMP1.EQ.'LOWE')THEN 12223 ICASA4='ONES' 12224 ICASA2='LOWE' 12225 ELSEIF(ICTMP1.EQ.'UPPE')THEN 12226 ICASA4='ONES' 12227 ICASA2='UPPE' 12228 ELSEIF(ICTMP1.EQ.'ONE ' .AND. ICTMP2.EQ.'SIDE')THEN 12229 ICASA4='ONES' 12230 ELSEIF(ICTMP1.EQ.'REPL')THEN 12231 IREPL='ON' 12232 ELSEIF(ICTMP1.EQ.'MULT')THEN 12233 IMULT='ON' 12234 ENDIF 12235 100 CONTINUE 12236 109 CONTINUE 12237C 12238 IF(IFOUND.EQ.'NO')GOTO9000 12239 ISHIFT=ILASTZ 12240 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 12241 1 IBUGA2,IERROR) 12242C 12243 IF(IMULT.EQ.'ON')THEN 12244 IF(IREPL.EQ.'ON')THEN 12245 WRITE(ICOUT,999) 12246 CALL DPWRST('XXX','BUG ') 12247 WRITE(ICOUT,101) 12248 101 FORMAT('***** ERROR IN STANDARD DEVIATION CONFIDENCE ', 12249 1 'LIMITS--') 12250 CALL DPWRST('XXX','BUG ') 12251 WRITE(ICOUT,102) 12252 102 FORMAT(' YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ', 12253 1 '"REPLICATION" FOR THIS COMMAND.') 12254 CALL DPWRST('XXX','BUG ') 12255 IERROR='YES' 12256 GOTO9000 12257 ENDIF 12258 ENDIF 12259C 12260C ********************************* 12261C ** STEP 2-- ** 12262C ** EXTRACT THE VARIABLE LIST ** 12263C ********************************* 12264C 12265 ISTEPN='2' 12266 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SDCI') 12267 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12268C 12269 INAME='SD CONFIDENCE LIMITS' 12270 MAXNA=100 12271 MINNVA=1 12272 MAXNVA=100 12273 MINNA=1 12274 IFLAGE=1 12275 IFLAGM=1 12276 IF(IREPL.EQ.'ON')THEN 12277 MAXNVA=7 12278 IFLAGM=0 12279 ELSE 12280 MAXNVA=30 12281 IFLAGE=0 12282 ENDIF 12283 MINN2=4 12284 IFLAGP=0 12285 JMIN=1 12286 JMAX=NUMARG 12287C 12288 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 12289 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 12290 1 JMIN,JMAX, 12291 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 12292 1 IVARN1,IVARN2,IVARTY,PVAR, 12293 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 12294 1 MINNVA,MAXNVA, 12295 1 IFLAGM,IFLAGP, 12296 1 IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 12297 IF(IERROR.EQ.'YES')GOTO9000 12298C 12299 IF(NUMVAR.GT.1 .AND. IREPL.EQ.'OFF')IMULT='ON' 12300C 12301 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SDCI')THEN 12302 WRITE(ICOUT,999) 12303 CALL DPWRST('XXX','BUG ') 12304 WRITE(ICOUT,181) 12305 181 FORMAT('***** AFTER CALL DPPARS--') 12306 CALL DPWRST('XXX','BUG ') 12307 WRITE(ICOUT,182)NQ,NUMVAR,IMULT,IREPL 12308 182 FORMAT('NQ,NUMVAR,IMULT,IREPL = ',2I8,2(2X,A4)) 12309 CALL DPWRST('XXX','BUG ') 12310 IF(NUMVAR.GT.0)THEN 12311 DO185I=1,NUMVAR 12312 WRITE(ICOUT,187)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 12313 1 ICOLR(I) 12314 187 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 12315 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 12316 CALL DPWRST('XXX','BUG ') 12317 185 CONTINUE 12318 ENDIF 12319 ENDIF 12320C 12321C *********************************************** 12322C ** STEP 2-- ** 12323C ** DETERMINE: ** 12324C ** 1) NUMBER OF REPLICATION VARIABLES (0-6) ** 12325C ** 2) NUMBER OF RESPONSE VARIABLES (>= 1)** 12326C *********************************************** 12327C 12328 ISTEPN='2' 12329 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SDCI') 12330 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12331C 12332 NRESP=0 12333 NREPL=0 12334C 12335 IF(IMULT.EQ.'ON')THEN 12336 NRESP=NUMVAR 12337 ELSEIF(IREPL.EQ.'ON')THEN 12338 NRESP=1 12339 NREPL=NUMVAR-NRESP 12340 IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN 12341 WRITE(ICOUT,999) 12342 CALL DPWRST('XXX','BUG ') 12343 WRITE(ICOUT,101) 12344 CALL DPWRST('XXX','BUG ') 12345 WRITE(ICOUT,211) 12346 211 FORMAT(' FOR THE REPLICATION CASE, THE NUMBER OF ', 12347 1 'REPLICATION VARIABLES') 12348 CALL DPWRST('XXX','BUG ') 12349 WRITE(ICOUT,212) 12350 212 FORMAT(' MUST BE BETWEEN ONE AND SIX.') 12351 CALL DPWRST('XXX','BUG ') 12352 WRITE(ICOUT,213)NREPL 12353 213 FORMAT(' THE NUMBER OF REPLICATION VARIABLES = ',I5) 12354 CALL DPWRST('XXX','BUG ') 12355 IERROR='YES' 12356 GOTO9000 12357 ENDIF 12358 ELSE 12359 NRESP=1 12360 ENDIF 12361C 12362 IH='NNEW' 12363 IH2=' ' 12364 IHWUSE='P' 12365 MESSAG='NO' 12366 CALL CHECKN(IH,IH2,IHWUSE, 12367 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 12368 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 12369 IF(IERROR.EQ.'YES')THEN 12370 NNEW=1 12371 ELSE 12372 NNEW=INT(VALUE(ILOCV)+0.5) 12373 IF(NNEW.LT.1)NNEW=1 12374 ENDIF 12375C 12376 IH='N0 ' 12377 IH2=' ' 12378 IHWUSE='P' 12379 MESSAG='NO' 12380 CALL CHECKN(IH,IH2,IHWUSE, 12381 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 12382 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 12383 IF(IERROR.EQ.'NO')THEN 12384 N0=INT(VALUE(ILOCP)+0.5) 12385 ELSE 12386 N0=0 12387 ENDIF 12388C 12389 IH='KURT' 12390 IH2='OSIS' 12391 IHWUSE='P' 12392 MESSAG='NO' 12393 CALL CHECKN(IH,IH2,IHWUSE, 12394 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 12395 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 12396 IF(IERROR.EQ.'NO')THEN 12397 AKURT=VALUE(ILOCP) 12398 ELSE 12399 AKURT=CPUMIN 12400 ENDIF 12401C 12402 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SDCI')THEN 12403 WRITE(ICOUT,221)NRESP,NREPL,NNEW,N0,AKURT 12404 221 FORMAT('NRESP,NREPL,NNEW,N0,AKURT = ',4I5,G15.7) 12405 CALL DPWRST('XXX','BUG ') 12406 ENDIF 12407C 12408C ****************************************************** 12409C ** STEP 3-- ** 12410C ** GENERATE THE PREDICTION LIMITS FOR THE VARIOUS ** 12411C ** CASES ** 12412C ****************************************************** 12413C 12414 ISTEPN='3' 12415 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SDCI') 12416 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12417C 12418C ***************************************** 12419C ** STEP 3A-- ** 12420C ** CASE 1: NO REPLICATION ** 12421C ***************************************** 12422C 12423 IF(NREPL.EQ.0)THEN 12424 ISTEPN='3A' 12425 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SDCI') 12426 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12427C 12428C LOOP THROUGH EACH OF THE RESPONSE VARIABLES 12429C 12430 NCURVE=0 12431 DO410IRESP=1,NRESP 12432 NCURVE=NCURVE+1 12433C 12434 IINDX=ICOLR(IRESP) 12435 PID(1)=CPUMIN 12436 IVARID(1)=IVARN1(IRESP) 12437 IVARI2(1)=IVARN2(IRESP) 12438C 12439 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SDCI')THEN 12440 WRITE(ICOUT,999) 12441 CALL DPWRST('XXX','BUG ') 12442 WRITE(ICOUT,411)IRESP,NCURVE 12443 411 FORMAT('IRESP,NCURVE = ',2I5) 12444 CALL DPWRST('XXX','BUG ') 12445 ENDIF 12446C 12447 ICOL=IRESP 12448 NUMVA2=1 12449 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 12450 1 INAME,IVARN1,IVARN2,IVARTY, 12451 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 12452 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 12453 1 MAXCP4,MAXCP5,MAXCP6, 12454 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 12455 1 Y,XTEMP1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE, 12456 1 IBUGA3,ISUBRO,IFOUND,IERROR) 12457 IF(IERROR.EQ.'YES')GOTO9000 12458C 12459C ***************************************************** 12460C ** STEP 4B-- ** 12461C ***************************************************** 12462C 12463 ISTEPN='4B' 12464 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SDCI') 12465 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12466C 12467 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'SDCI')THEN 12468 WRITE(ICOUT,999) 12469 CALL DPWRST('XXX','BUG ') 12470 WRITE(ICOUT,422) 12471 422 FORMAT('***** FROM THE MIDDLE OF DPSDCI--') 12472 CALL DPWRST('XXX','BUG ') 12473 WRITE(ICOUT,423)ICASAN,NUMVAR,NLOCAL,IRESP 12474 423 FORMAT('ICASAN,NUMVAR,NLOCAL,IRESP = ',A4,3I8) 12475 CALL DPWRST('XXX','BUG ') 12476 IF(NLOCAL.GE.1)THEN 12477 DO425I=1,NLOCAL 12478 WRITE(ICOUT,426)I,Y(I) 12479 426 FORMAT('I,Y(I) = ',I8,F12.5) 12480 CALL DPWRST('XXX','BUG ') 12481 425 CONTINUE 12482 ENDIF 12483 ENDIF 12484C 12485 CALL DPSDC2(Y,NLOCAL,ICASAN,ICASA2,ICASA3,ICASA4, 12486 1 PID,IVARID,IVARI2,NREPL, 12487 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 12488 1 CTL999,CTU999, 12489 1 ICAPSW,ICAPTY,IFORSW,IBONSD,IBONAD, 12490 1 TEMP3,MAXNXT,AKURT,N0, 12491 1 ISUBRO,IBUGA3,IERROR) 12492C 12493 IFLAGU='FILE' 12494 IFRST=.FALSE. 12495 ILAST=.FALSE. 12496 IF(IRESP.EQ.1)IFRST=.TRUE. 12497 IF(IRESP.EQ.NRESP)ILAST=.TRUE. 12498 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 12499 1 CTL999,CTU999, 12500 1 IFLAGU,IFRST,ILAST,ICASAN, 12501 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 12502C 12503 410 CONTINUE 12504C 12505C **************************************************** 12506C ** STEP 5A-- ** 12507C ** CASE 3: ONE OR MORE REPLICATION VARIABLES. ** 12508C ** FOR THIS CASE, ALL VARIABLES MUST ** 12509C ** HAVE THE SAME LENGTH. ** 12510C **************************************************** 12511C 12512 ELSEIF(IREPL.EQ.'ON')THEN 12513 ISTEPN='5A' 12514 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SDCI') 12515 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12516C 12517 J=0 12518 IMAX=NRIGHT(1) 12519 IF(NQ.LT.NRIGHT(1))IMAX=NQ 12520 DO510I=1,IMAX 12521 IF(ISUB(I).EQ.0)GOTO510 12522 J=J+1 12523C 12524C RESPONSE VARIABLE IN Y 12525C 12526 ICOLC=1 12527 IJ=MAXN*(ICOLR(ICOLC)-1)+I 12528 IF(ICOLR(ICOLC).LE.MAXCOL)Y(J)=V(IJ) 12529 IF(ICOLR(ICOLC).EQ.MAXCP1)Y(J)=PRED(I) 12530 IF(ICOLR(ICOLC).EQ.MAXCP2)Y(J)=RES(I) 12531 IF(ICOLR(ICOLC).EQ.MAXCP3)Y(J)=YPLOT(I) 12532 IF(ICOLR(ICOLC).EQ.MAXCP4)Y(J)=XPLOT(I) 12533 IF(ICOLR(ICOLC).EQ.MAXCP5)Y(J)=X2PLOT(I) 12534 IF(ICOLR(ICOLC).EQ.MAXCP6)Y(J)=TAGPLO(I) 12535C 12536 IF(NREPL.GE.1)THEN 12537 DO520IR=1,MIN(NREPL,6) 12538 ICOLC=ICOLC+1 12539 ICOLT=ICOLR(ICOLC) 12540 IJ=MAXN*(ICOLT-1)+I 12541 IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ) 12542 IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I) 12543 IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I) 12544 IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I) 12545 IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I) 12546 IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I) 12547 IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I) 12548 520 CONTINUE 12549 ENDIF 12550C 12551 510 CONTINUE 12552 NLOCAL=J 12553C 12554 ISTEPN='5B' 12555 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SDCI') 12556 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12557C 12558 PID(1)=CPUMIN 12559 IVARID(1)=IVARN1(1) 12560 IVARI2(1)=IVARN2(1) 12561 IADD=1 12562 DO540II=1,NREPL 12563 IVARID(II+IADD)=IVARN1(II+IADD) 12564 IVARI2(II+IADD)=IVARN2(II+IADD) 12565 540 CONTINUE 12566C 12567C ***************************************************** 12568C ** STEP 5C-- ** 12569C ** ** 12570C ** FOR THIS CASE, WE NEED TO LOOP THROUGH THE ** 12571C ** VARIOUS REPLICATIONS. ** 12572C ***************************************************** 12573C 12574 ISTEPN='5C' 12575 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SDCI') 12576 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12577C 12578 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'SDCI')THEN 12579 WRITE(ICOUT,999) 12580 CALL DPWRST('XXX','BUG ') 12581 WRITE(ICOUT,541) 12582 541 FORMAT('***** FROM THE MIDDLE OF DPSDCL--') 12583 CALL DPWRST('XXX','BUG ') 12584 WRITE(ICOUT,542)ICASAN,NUMVAR,NLOCAL,NLOCA2,NREPL 12585 542 FORMAT('ICASAN,NUMVAR,NLOCAL,NLOCA2,NREPL = ',A4,2X,4I8) 12586 CALL DPWRST('XXX','BUG ') 12587 IF(NLOCAL.GE.1)THEN 12588 DO545I=1,NLOCAL 12589 WRITE(ICOUT,546)I,Y(I),X(I),XDESGN(I,1),XDESGN(I,2) 12590 546 FORMAT('I,Y(I),X(I),XDESGN(I,1),XDESGN(I,2) = ', 12591 1 I8,4F12.5) 12592 CALL DPWRST('XXX','BUG ') 12593 545 CONTINUE 12594 ENDIF 12595 ENDIF 12596C 12597C ***************************************************** 12598C ** STEP 5C-- ** 12599C ** FIND THE DISTINCT VALUES IN EACH OF THE ** 12600C ** REPLICATION VARIABLES. ** 12601C ***************************************************** 12602C 12603 CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3), 12604 1 XDESGN(1,4),XDESGN(1,5),XDESGN(1,6), 12605 1 NREPL,NLOCAL,MAXOBV, 12606 1 XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6, 12607 1 XTEMP1,XTEMP2, 12608 1 NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6, 12609 1 IBUGA3,ISUBRO,IERROR) 12610C 12611C ***************************************************** 12612C ** STEP 5D-- ** 12613C ** NOW LOOP THROUGH THE VARIOUS REPLICATIONS ** 12614C ***************************************************** 12615C 12616 NPLOTP=0 12617 NCURVE=0 12618 IF(NREPL.EQ.1)THEN 12619 J=0 12620 DO1110ISET1=1,NUMSE1 12621 K=0 12622 PID(IADD+1)=XIDTEM(ISET1) 12623 DO1130I=1,NLOCAL 12624 IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN 12625 K=K+1 12626 TEMP1(K)=Y(I) 12627 TEMP2(K)=X(I) 12628 ENDIF 12629 1130 CONTINUE 12630 NTEMP=K 12631 NCURVE=NCURVE+1 12632 IF(NTEMP.GT.0)THEN 12633 CALL DPSDC2(TEMP1,NTEMP,ICASAN,ICASA2,ICASA3,ICASA4, 12634 1 PID,IVARID,IVARI2,NREPL, 12635 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 12636 1 CTL999,CTU999, 12637 1 ICAPSW,ICAPTY,IFORSW,IBONSD,IBONAD, 12638 1 TEMP3,MAXOBV,AKURT,N0, 12639 1 ISUBRO,IBUGA3,IERROR) 12640 ENDIF 12641C 12642 IFLAGU='FILE' 12643 IFRST=.FALSE. 12644 ILAST=.FALSE. 12645 IF(NCURVE.EQ.1)IFRST=.TRUE. 12646 IF(NCURVE.EQ.NUMSE1)ILAST=.TRUE. 12647 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 12648 1 CTL999,CTU999, 12649 1 IFLAGU,IFRST,ILAST,ICASAN, 12650 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 12651 1110 CONTINUE 12652 ELSEIF(NREPL.EQ.2)THEN 12653 J=0 12654 NTOT=NUMSE1*NUMSE2 12655 DO1210ISET1=1,NUMSE1 12656 DO1220ISET2=1,NUMSE2 12657 K=0 12658 PID(1+IADD)=XIDTEM(ISET1) 12659 PID(2+IADD)=XIDTE2(ISET2) 12660 DO1290I=1,NLOCAL 12661 IF( 12662 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 12663 1 XIDTE2(ISET2).EQ.XDESGN(I,2) 12664 1 )THEN 12665 K=K+1 12666 TEMP1(K)=Y(I) 12667 TEMP2(K)=X(I) 12668 ENDIF 12669 1290 CONTINUE 12670 NTEMP=K 12671 NCURVE=NCURVE+1 12672 NPLOT1=NPLOTP 12673 IF(NTEMP.GT.0)THEN 12674 CALL DPSDC2(TEMP1,NTEMP,ICASAN,ICASA2,ICASA3,ICASA4, 12675 1 PID,IVARID,IVARI2,NREPL, 12676 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 12677 1 CTL999,CTU999, 12678 1 ICAPSW,ICAPTY,IFORSW,IBONSD,IBONAD, 12679 1 TEMP3,MAXOBV,AKURT,N0, 12680 1 ISUBRO,IBUGA3,IERROR) 12681 ENDIF 12682 NPLOT2=NPLOTP 12683 IFLAGU='FILE' 12684 IFRST=.FALSE. 12685 ILAST=.FALSE. 12686 IF(NCURVE.EQ.1)IFRST=.TRUE. 12687 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 12688 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 12689 1 CTL999,CTU999, 12690 1 IFLAGU,IFRST,ILAST,ICASAN, 12691 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 12692 1220 CONTINUE 12693 1210 CONTINUE 12694 ELSEIF(NREPL.EQ.3)THEN 12695 J=0 12696 NTOT=NUMSE1*NUMSE2*NUMSE3 12697 DO1310ISET1=1,NUMSE1 12698 DO1320ISET2=1,NUMSE2 12699 DO1330ISET3=1,NUMSE3 12700 K=0 12701 PID(1+IADD)=XIDTEM(ISET1) 12702 PID(2+IADD)=XIDTE2(ISET2) 12703 PID(3+IADD)=XIDTE3(ISET3) 12704 DO1390I=1,NLOCAL 12705 IF( 12706 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 12707 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 12708 1 XIDTE3(ISET3).EQ.XDESGN(I,3) 12709 1 )THEN 12710 K=K+1 12711 TEMP1(K)=Y(I) 12712 TEMP2(K)=X(I) 12713 ENDIF 12714 1390 CONTINUE 12715 NTEMP=K 12716 NCURVE=NCURVE+1 12717 IF(NTEMP.GT.0)THEN 12718 CALL DPSDC2(TEMP1,NTEMP,ICASAN,ICASA2,ICASA3,ICASA4, 12719 1 PID,IVARID,IVARI2,NREPL, 12720 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 12721 1 CTL999,CTU999, 12722 1 ICAPSW,ICAPTY,IFORSW,IBONSD,IBONAD, 12723 1 TEMP3,MAXOBV,AKURT,N0, 12724 1 ISUBRO,IBUGA3,IERROR) 12725 ENDIF 12726 IFLAGU='FILE' 12727 IFRST=.FALSE. 12728 ILAST=.FALSE. 12729 IF(NCURVE.EQ.1)IFRST=.TRUE. 12730 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 12731 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 12732 1 CTL999,CTU999, 12733 1 IFLAGU,IFRST,ILAST,ICASAN, 12734 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 12735 1330 CONTINUE 12736 1320 CONTINUE 12737 1310 CONTINUE 12738 ELSEIF(NREPL.EQ.4)THEN 12739 J=0 12740 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4 12741 DO1410ISET1=1,NUMSE1 12742 DO1420ISET2=1,NUMSE2 12743 DO1430ISET3=1,NUMSE3 12744 DO1440ISET4=1,NUMSE4 12745 K=0 12746 PID(1+IADD)=XIDTEM(ISET1) 12747 PID(2+IADD)=XIDTE2(ISET2) 12748 PID(3+IADD)=XIDTE3(ISET3) 12749 PID(4+IADD)=XIDTE4(ISET4) 12750 DO1490I=1,NLOCAL 12751 IF( 12752 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 12753 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 12754 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 12755 1 XIDTE4(ISET4).EQ.XDESGN(I,4) 12756 1 )THEN 12757 K=K+1 12758 TEMP1(K)=Y(I) 12759 TEMP2(K)=X(I) 12760 ENDIF 12761 1490 CONTINUE 12762 NTEMP=K 12763 NCURVE=NCURVE+1 12764 IF(NTEMP.GT.0)THEN 12765 CALL DPSDC2(TEMP1,NTEMP,ICASAN,ICASA2,ICASA3,ICASA4, 12766 1 PID,IVARID,IVARI2,NREPL, 12767 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 12768 1 CTL999,CTU999, 12769 1 ICAPSW,ICAPTY,IFORSW,IBONSD,IBONAD, 12770 1 TEMP3,MAXOBV,AKURT,N0, 12771 1 ISUBRO,IBUGA3,IERROR) 12772 ENDIF 12773 IFLAGU='FILE' 12774 IFRST=.FALSE. 12775 ILAST=.FALSE. 12776 IF(NCURVE.EQ.1)IFRST=.TRUE. 12777 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 12778 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 12779 1 CTL999,CTU999, 12780 1 IFLAGU,IFRST,ILAST,ICASAN, 12781 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 12782 1440 CONTINUE 12783 1430 CONTINUE 12784 1420 CONTINUE 12785 1410 CONTINUE 12786 ELSEIF(NREPL.EQ.5)THEN 12787 J=0 12788 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5 12789 DO1510ISET1=1,NUMSE1 12790 DO1520ISET2=1,NUMSE2 12791 DO1530ISET3=1,NUMSE3 12792 DO1540ISET4=1,NUMSE4 12793 DO1550ISET5=1,NUMSE5 12794 K=0 12795 PID(1+IADD)=XIDTEM(ISET1) 12796 PID(2+IADD)=XIDTE2(ISET2) 12797 PID(3+IADD)=XIDTE3(ISET3) 12798 PID(4+IADD)=XIDTE4(ISET4) 12799 PID(5+IADD)=XIDTE5(ISET4) 12800 DO1590I=1,NLOCAL 12801 IF( 12802 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 12803 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 12804 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 12805 1 XIDTE4(ISET4).EQ.XDESGN(I,4) .AND. 12806 1 XIDTE5(ISET5).EQ.XDESGN(I,5) 12807 1 )THEN 12808 K=K+1 12809 TEMP1(K)=Y(I) 12810 TEMP2(K)=X(I) 12811 ENDIF 12812 1590 CONTINUE 12813 NTEMP=K 12814 NCURVE=NCURVE+1 12815 IF(NTEMP.GT.0)THEN 12816 CALL DPSDC2(TEMP1,NTEMP,ICASAN,ICASA2,ICASA3,ICASA4, 12817 1 PID,IVARID,IVARI2,NREPL, 12818 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 12819 1 CTL999,CTU999, 12820 1 ICAPSW,ICAPTY,IFORSW,IBONSD,IBONAD, 12821 1 TEMP3,MAXOBV,AKURT,N0, 12822 1 ISUBRO,IBUGA3,IERROR) 12823 ENDIF 12824 IFLAGU='FILE' 12825 IFRST=.FALSE. 12826 ILAST=.FALSE. 12827 IF(NCURVE.EQ.1)IFRST=.TRUE. 12828 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 12829 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 12830 1 CTL999,CTU999, 12831 1 IFLAGU,IFRST,ILAST,ICASAN, 12832 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 12833 1550 CONTINUE 12834 1540 CONTINUE 12835 1530 CONTINUE 12836 1520 CONTINUE 12837 1510 CONTINUE 12838 ELSEIF(NREPL.EQ.6)THEN 12839 J=0 12840 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6 12841 DO1610ISET1=1,NUMSE1 12842 DO1620ISET2=1,NUMSE2 12843 DO1630ISET3=1,NUMSE3 12844 DO1640ISET4=1,NUMSE4 12845 DO1650ISET5=1,NUMSE5 12846 DO1660ISET6=1,NUMSE6 12847 K=0 12848 PID(1+IADD)=XIDTEM(ISET1) 12849 PID(2+IADD)=XIDTE2(ISET2) 12850 PID(3+IADD)=XIDTE3(ISET3) 12851 PID(4+IADD)=XIDTE4(ISET4) 12852 PID(5+IADD)=XIDTE5(ISET4) 12853 PID(6+IADD)=XIDTE6(ISET4) 12854 DO1690I=1,NLOCAL 12855 IF( 12856 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 12857 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 12858 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 12859 1 XIDTE4(ISET4).EQ.XDESGN(I,4) .AND. 12860 1 XIDTE5(ISET5).EQ.XDESGN(I,5) .AND. 12861 1 XIDTE6(ISET6).EQ.XDESGN(I,6) 12862 1 )THEN 12863 K=K+1 12864 TEMP1(K)=Y(I) 12865 TEMP2(K)=X(I) 12866 ENDIF 12867 1690 CONTINUE 12868 NTEMP=K 12869 NCURVE=NCURVE+1 12870 IF(NTEMP.GT.0)THEN 12871 CALL DPSDC2(TEMP1,NTEMP,ICASAN,ICASA2,ICASA3,ICASA4, 12872 1 PID,IVARID,IVARI2,NREPL, 12873 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 12874 1 CTL999,CTU999, 12875 1 ICAPSW,ICAPTY,IFORSW,IBONSD,IBONAD, 12876 1 TEMP3,MAXOBV,AKURT,N0, 12877 1 ISUBRO,IBUGA3,IERROR) 12878 ENDIF 12879 IFLAGU='FILE' 12880 IFRST=.FALSE. 12881 ILAST=.FALSE. 12882 IF(NCURVE.EQ.1)IFRST=.TRUE. 12883 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 12884 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 12885 1 CTL999,CTU999, 12886 1 IFLAGU,IFRST,ILAST,ICASAN, 12887 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 12888 1660 CONTINUE 12889 1650 CONTINUE 12890 1640 CONTINUE 12891 1630 CONTINUE 12892 1620 CONTINUE 12893 1610 CONTINUE 12894 ENDIF 12895C 12896 ENDIF 12897C 12898C ***************** 12899C ** STEP 90-- ** 12900C ** EXIT ** 12901C ***************** 12902C 12903 9000 CONTINUE 12904 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'SDCI')THEN 12905 WRITE(ICOUT,999) 12906 CALL DPWRST('XXX','BUG ') 12907 WRITE(ICOUT,9011) 12908 9011 FORMAT('***** AT THE END OF DPSDCL--') 12909 CALL DPWRST('XXX','BUG ') 12910 WRITE(ICOUT,9016)IFOUND,IERROR 12911 9016 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 12912 CALL DPWRST('XXX','BUG ') 12913 ENDIF 12914C 12915 RETURN 12916 END 12917 SUBROUTINE DPSDC2(Y,N,ICASAN,ICASA2,ICASA3,ICASA4, 12918 1 PID,IVARID,IVARI2,NREPL, 12919 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 12920 1 CTL999,CTU999, 12921 1 ICAPSW,ICAPTY,IFORSW,IBONSD,IBONAD, 12922 1 TEMP1,MAXNXT,AKURT,N0, 12923 1 ISUBRO,IBUGA3,IERROR) 12924C 12925C PURPOSE--GENERATE A CONFIDENCE INTERVAL FOR THE STANDARD 12926C DEVIATION FOR NORMALLY DISTRIBUTED DATA. 12927C 12928C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR OF 12929C ORIGINAL OBSERVATIONS. 12930C N = THE INTEGER NUMBER OF OBSERVATIONS 12931C IN THE VECTOR Y. 12932C WRITTEN BY--ALAN HECKERT 12933C STATISTICAL ENGINEERING DIVISION 12934C INFORMATION TECHNOLOGY LABORATORY 12935C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 12936C GAITHERSBURG, MD 20899-8980 12937C PHONE--301-975-2899 12938C REFERENCES--HAHN AND MEEKER (1991), "STATISTICAL INTERVALS: A 12939C GUIDE FOR PRACTIONERS", WILEY, PP. 55-56. 12940C --BONETT (2006), "APPROXIMATE CONFIDENCE INTERVAL FOR 12941C STANDARD DEVIATION OF NONNORMAL DISTRIBUTIONS", 12942C COMPUTATIONAL STATISTICS AND DATA ANALYSIS, 12943C VOL. 50, PP. 775 - 782. 12944C --NIWITPONG AND KIRDWICHAI (2008), "ADJUSTED BONETT 12945C CONFIDENCE INTERVAL FOR STANDARD DEVIATION OF 12946C NON-NORMAL DISTRIBUTIONS", THAILAND STATISTICIAN, 12947C VOL. 6, NO. 1, PP. 1-6. 12948C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12949C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 12950C LANGUAGE--ANSI FORTRAN (1977) 12951C VERSION NUMBER--2013/4 12952C ORIGINAL VERSION--APRIL 2013. 12953C UPDATED --DECEMBER 2017. ADD BONETT'S INTERVAL FOR 12954C NON-NORMAL DATA 12955C UPDATED --AUGUST 2019. ADD CTL999, CTU999 12956C 12957C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12958C 12959 CHARACTER*4 ICASAN 12960 CHARACTER*4 ICASA2 12961 CHARACTER*4 ICASA3 12962 CHARACTER*4 ICASA4 12963 CHARACTER*4 ICAPSW 12964 CHARACTER*4 ICAPTY 12965 CHARACTER*4 IFORSW 12966 CHARACTER*4 IBONSD 12967 CHARACTER*4 IBONAD 12968 CHARACTER*4 ISUBRO 12969 CHARACTER*4 IBUGA3 12970 CHARACTER*4 IERROR 12971C 12972 CHARACTER*4 IVARID(*) 12973 CHARACTER*4 IVARI2(*) 12974C 12975 CHARACTER*4 IWRITE 12976 CHARACTER*4 ISUBN1 12977 CHARACTER*4 ISUBN2 12978 CHARACTER*4 ISTEPN 12979C 12980C--------------------------------------------------------------------- 12981C 12982 DIMENSION Y(*) 12983 DIMENSION TEMP1(*) 12984 DIMENSION PID(*) 12985C 12986 PARAMETER (NUMALP=6) 12987 REAL ALPHA(NUMALP) 12988 REAL CONF(NUMALP) 12989C 12990 DIMENSION ALOWLM(NUMALP) 12991 DIMENSION AUPPLM(NUMALP) 12992C 12993 PARAMETER(NUMCLI=4) 12994 PARAMETER(MAXLIN=2) 12995 PARAMETER (MAXROW=20) 12996 CHARACTER*60 ITITLE 12997 CHARACTER*60 ITITLZ 12998 CHARACTER*40 ITITL9 12999 CHARACTER*60 ITEXT(MAXROW) 13000 CHARACTER*4 ALIGN(NUMCLI) 13001 CHARACTER*4 VALIGN(NUMCLI) 13002 CHARACTER*4 ITYPCO(NUMCLI) 13003 CHARACTER*20 ITITL2(MAXLIN,NUMCLI) 13004 CHARACTER*4 IVALUE(MAXROW,NUMCLI) 13005 REAL AVALUE(MAXROW) 13006 REAL AMAT(MAXROW,NUMCLI) 13007 INTEGER NCVALU(MAXROW,NUMCLI) 13008 INTEGER NCTIT2(MAXLIN,NUMCLI) 13009 INTEGER NCTEXT(MAXROW) 13010 INTEGER IDIGIT(MAXROW) 13011 INTEGER NTOT(MAXROW) 13012 INTEGER IWHTML(NUMCLI) 13013 INTEGER IWRTF(NUMCLI) 13014 LOGICAL IFRST 13015 LOGICAL ILAST 13016C 13017C--------------------------------------------------------------------- 13018C 13019 INCLUDE 'DPCOP2.INC' 13020C 13021C-----START POINT----------------------------------------------------- 13022C 13023 DATA ALPHA /0.50, 0.80, 0.90, 0.95, 0.99, 0.999/ 13024C 13025 ISUBN1='DPSD' 13026 ISUBN2='C2 ' 13027 IERROR='NO' 13028 IWRITE='OFF' 13029C 13030 NUMDIG=7 13031 IF(IFORSW.EQ.'1')NUMDIG=1 13032 IF(IFORSW.EQ.'2')NUMDIG=2 13033 IF(IFORSW.EQ.'3')NUMDIG=3 13034 IF(IFORSW.EQ.'4')NUMDIG=4 13035 IF(IFORSW.EQ.'5')NUMDIG=5 13036 IF(IFORSW.EQ.'6')NUMDIG=6 13037 IF(IFORSW.EQ.'7')NUMDIG=7 13038 IF(IFORSW.EQ.'8')NUMDIG=8 13039 IF(IFORSW.EQ.'9')NUMDIG=9 13040 IF(IFORSW.EQ.'0')NUMDIG=0 13041 IF(IFORSW.EQ.'E')NUMDIG=-2 13042 IF(IFORSW.EQ.'-2')NUMDIG=-2 13043 IF(IFORSW.EQ.'-3')NUMDIG=-3 13044 IF(IFORSW.EQ.'-4')NUMDIG=-4 13045 IF(IFORSW.EQ.'-5')NUMDIG=-5 13046 IF(IFORSW.EQ.'-6')NUMDIG=-6 13047 IF(IFORSW.EQ.'-7')NUMDIG=-7 13048 IF(IFORSW.EQ.'-8')NUMDIG=-8 13049 IF(IFORSW.EQ.'-9')NUMDIG=-9 13050C 13051 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SDC2')THEN 13052 WRITE(ICOUT,999) 13053 999 FORMAT(1X) 13054 CALL DPWRST('XXX','WRIT') 13055 WRITE(ICOUT,51) 13056 51 FORMAT('**** AT THE BEGINNING OF DPSDC2--') 13057 CALL DPWRST('XXX','WRIT') 13058 WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASAN,ICASA2,ICASA3,ICASA4 13059 52 FORMAT('IBUGA3,ISUBRO,ICASAN,ICASA2,ICASA3,ICASA4 = ', 13060 1 5(A4,2X),A4) 13061 CALL DPWRST('XXX','WRIT') 13062 WRITE(ICOUT,54)N,IBONSD,IBONAD,AKURT,N0 13063 54 FORMAT('N,IBONSD,IBONAD,AKURT,N0 = ',I8,2(2X,A4),G15.7,I8) 13064 CALL DPWRST('XXX','WRIT') 13065 DO56I=1,N 13066 WRITE(ICOUT,57)I,Y(I) 13067 57 FORMAT('I,Y(I) = ',I8,G15.7) 13068 CALL DPWRST('XXX','WRIT') 13069 56 CONTINUE 13070 ENDIF 13071C 13072C ******************************************** 13073C ** STEP 1-- ** 13074C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 13075C ******************************************** 13076C 13077 ISTEPN='1' 13078 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SDC2') 13079 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 13080C 13081 IF(N.LE.1)THEN 13082 WRITE(ICOUT,999) 13083 CALL DPWRST('XXX','WRIT') 13084 WRITE(ICOUT,101) 13085 101 FORMAT('***** ERROR IN STANDARD DEVIATION CONFIDENCE LIMITS--') 13086 CALL DPWRST('XXX','WRIT') 13087 WRITE(ICOUT,103) 13088 103 FORMAT(' THE NUMBER OF OBSERVATIONS IN THE RESPONSE ', 13089 1 'VARIABLE IS LESS THAN TWO.') 13090 CALL DPWRST('XXX','WRIT') 13091 WRITE(ICOUT,105)N 13092 105 FORMAT('SAMPLE SIZE = ',I8) 13093 CALL DPWRST('XXX','WRIT') 13094 IERROR='YES' 13095 GOTO9000 13096 ENDIF 13097C 13098 HOLD=Y(1) 13099 DO135I=2,N 13100 IF(Y(I).NE.HOLD)GOTO139 13101 135 CONTINUE 13102 WRITE(ICOUT,999) 13103 CALL DPWRST('XXX','WRIT') 13104 WRITE(ICOUT,101) 13105 CALL DPWRST('XXX','WRIT') 13106 WRITE(ICOUT,131)HOLD 13107 131 FORMAT(' THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7) 13108 CALL DPWRST('XXX','WRIT') 13109 GOTO9000 13110 139 CONTINUE 13111C 13112C *************************************** 13113C ** STEP 3-- ** 13114C ** COMPUTE CONFIDENCE LIMITS ** 13115C ** FOR VARIOUS PROBABILITY VALUES. ** 13116C *************************************** 13117C 13118 ISTEPN='4' 13119 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SDC2') 13120 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 13121C 13122C ICASAN - LIMI => CONFIDENCE LIMIT FOR THE SD 13123C ICASA2: LOWE => LOWER LIMIT 13124C UPPE => UPPER LIMIT 13125C ICASA3: RAW => RAW DATA 13126C SUMM => SUMMARY DATA 13127C ICASA4: ONES => ONE-SIDED LIMIT 13128C TWOS => TWO-SIDED LIMIT 13129C 13130C DO STANDARD INTERVAL ON PASS ONE, THEN IF REQUESTED 13131C DO BONETT'S INTERVAL ON PASS TWO. 13132C 13133 AN=N 13134 ICASA3='RAW' 13135 IPASS=0 13136C 13137 400 CONTINUE 13138C 13139 IPASS=IPASS+1 13140 IF(IPASS.EQ.2)THEN 13141 IF(IBONSD.EQ.'OFF')GOTO9000 13142 ELSEIF(IPASS.GT.2)THEN 13143 GOTO9000 13144 ENDIF 13145C 13146 IF(IPASS.EQ.1)THEN 13147 CALL MEAN(Y,N,IWRITE,YMEAN,IBUGA3,IERROR) 13148 CALL DPSDC3(Y,N,ICASAN,ICASA2,ICASA3,ICASA4, 13149 1 YSD, 13150 1 ALPHA,NUMALP,ALOWLM,AUPPLM, 13151 1 ISUBRO,IBUGA3,IERROR) 13152 ELSE 13153 CALL MEAN(Y,N,IWRITE,YMEAN,IBUGA3,IERROR) 13154 CALL DPSDR3(Y,N,ICASA2,ICASA4,MAXNXT, 13155 1 TEMP1,AKURT,N0,IBONAD, 13156 1 YSD, 13157 1 ALPHA,NUMALP,ALOWLM,AUPPLM, 13158 1 ISUBRO,IBUGA3,IERROR) 13159 ENDIF 13160C 13161 CUTL90=ALOWLM(3) 13162 CUTU90=AUPPLM(3) 13163 CUTL95=ALOWLM(4) 13164 CUTU95=AUPPLM(4) 13165 CUTL99=ALOWLM(5) 13166 CUTU99=AUPPLM(5) 13167 CTL999=ALOWLM(6) 13168 CTU999=AUPPLM(6) 13169 NALP=NUMALP 13170 DO420I=1,NUMALP 13171 CONF(I)=100.0*ALPHA(I) + 0.0001 13172 420 CONTINUE 13173C 13174C **************************** 13175C ** STEP 5-- ** 13176C ** WRITE EVERYTHING OUT ** 13177C **************************** 13178C 13179 ISTEPN='5' 13180 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SDC2') 13181 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 13182C 13183 IF(IPRINT.EQ.'OFF')GOTO9000 13184C 13185 IF(ICASA4.EQ.'TWOS')THEN 13186 ITITLE='Two-Sided Confidence Limits for the SD' 13187 NCTITL=38 13188 IF(IPASS.EQ.2)THEN 13189 IF(IBONAD.EQ.'ON')THEN 13190 ITITLZ='Bonett Interval (Adjusted) for Non-Normality' 13191 NCTITZ=44 13192 ELSE 13193 ITITLZ='Bonett Interval for Non-Normality' 13194 NCTITZ=33 13195 ENDIF 13196 ELSE 13197 ITITLZ=' ' 13198 NCTITZ=0 13199 ENDIF 13200 ELSEIF(ICASA4.EQ.'ONES')THEN 13201 IF(ICASA2.EQ.'LOWE')THEN 13202 ITITLE='One-Sided Lower Confidence Limits for the SD' 13203 NCTITL=44 13204 IF(IPASS.EQ.2)THEN 13205 IF(IBONAD.EQ.'ON')THEN 13206 ITITLZ='Bonett Interval (Adjusted) for Non-Normality' 13207 NCTITZ=44 13208 ELSE 13209 ITITLZ='Bonett Interval for Non-Normality' 13210 NCTITZ=33 13211 ENDIF 13212 ELSE 13213 ITITLZ=' ' 13214 NCTITZ=0 13215 ENDIF 13216 ELSEIF(ICASA2.EQ.'UPPE')THEN 13217 ITITLE='One-Sided Upper Confidence Limits for the SD' 13218 NCTITL=44 13219 IF(IPASS.EQ.2)THEN 13220 IF(IBONAD.EQ.'ON')THEN 13221 ITITLZ='Bonett Interval (Adjusted) for Non-Normality' 13222 NCTITZ=44 13223 ELSE 13224 ITITLZ='Bonett Interval for Non-Normality' 13225 NCTITZ=33 13226 ENDIF 13227 ELSE 13228 ITITLZ=' ' 13229 NCTITZ=0 13230 ENDIF 13231 ENDIF 13232 ENDIF 13233C 13234 ICNT=1 13235 ITEXT(ICNT)=' ' 13236 NCTEXT(ICNT)=0 13237 AVALUE(ICNT)=0.0 13238 IDIGIT(ICNT)=-1 13239 ICNT=ICNT+1 13240 ITEXT(ICNT)='Response Variable: ' 13241 WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4) 13242 WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4) 13243 NCTEXT(ICNT)=27 13244 AVALUE(ICNT)=0.0 13245 IDIGIT(ICNT)=-1 13246C 13247 IF(NREPL.GT.0)THEN 13248 NRESP=1 13249 DO4101I=1,NREPL 13250 ICNT=ICNT+1 13251 ITEMP=I+NRESP 13252 ITEXT(ICNT)='Factor Variable : ' 13253 WRITE(ITEXT(ICNT)(17:17),'(I1)')I 13254 WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4) 13255 WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4) 13256 NCTEXT(ICNT)=27 13257 AVALUE(ICNT)=PID(ITEMP) 13258 IDIGIT(ICNT)=NUMDIG 13259 4101 CONTINUE 13260 ENDIF 13261C 13262 ICNT=ICNT+1 13263 ITEXT(ICNT)=' ' 13264 NCTEXT(ICNT)=1 13265 AVALUE(ICNT)=0.0 13266 IDIGIT(ICNT)=-1 13267C 13268 ICNT=ICNT+1 13269 ITEXT(ICNT)='Summary Statistics:' 13270 NCTEXT(ICNT)=19 13271 AVALUE(ICNT)=0.0 13272 IDIGIT(ICNT)=-1 13273 ICNT=ICNT+1 13274 ITEXT(ICNT)='Number of Observations:' 13275 NCTEXT(ICNT)=23 13276 AVALUE(ICNT)=REAL(N) 13277 IDIGIT(ICNT)=0 13278 ICNT=ICNT+1 13279 ITEXT(ICNT)='Sample Mean:' 13280 NCTEXT(ICNT)=12 13281 AVALUE(ICNT)=YMEAN 13282 IDIGIT(ICNT)=NUMDIG 13283 ICNT=ICNT+1 13284 ITEXT(ICNT)='Sample Standard Deviation:' 13285 NCTEXT(ICNT)=26 13286 AVALUE(ICNT)=YSD 13287 IDIGIT(ICNT)=NUMDIG 13288 ICNT=ICNT+1 13289 ITEXT(ICNT)=' ' 13290 NCTEXT(ICNT)=1 13291 AVALUE(ICNT)=0.0 13292 IDIGIT(ICNT)=-1 13293C 13294 NUMROW=ICNT 13295 DO4210I=1,NUMROW 13296 NTOT(I)=15 13297 4210 CONTINUE 13298C 13299 IFRST=.TRUE. 13300 ILAST=.TRUE. 13301C 13302 ISTEPN='5A' 13303 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SDC2') 13304 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 13305C 13306 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT, 13307 1 AVALUE,IDIGIT, 13308 1 NTOT,NUMROW, 13309 1 ICAPSW,ICAPTY,ILAST,IFRST, 13310 1 ISUBRO,IBUGA3,IERROR) 13311C 13312 DO4215J=1,NUMCLI 13313 DO4218I=1,MAXLIN 13314 ITITL2(I,J)=' ' 13315 NCTIT2(I,J)=0 13316 4218 CONTINUE 13317 DO4219I=1,MAXROW 13318 NCVALU(I,J)=0 13319 IVALUE(I,J)=' ' 13320 AMAT(I,J)=0.0 13321 4219 CONTINUE 13322 4215 CONTINUE 13323C 13324 ITITL2(1,1)='Confidence' 13325 NCTIT2(1,1)=10 13326 ITITL2(2,1)='Value (%)' 13327 NCTIT2(2,1)=9 13328 ITITL2(1,2)='Standard' 13329 NCTIT2(1,2)=8 13330 ITITL2(2,2)='Deviation' 13331 NCTIT2(2,2)=9 13332 ICOL=2 13333C 13334 IF(ICASA4.EQ.'TWOS' .OR. 13335 1 (ICASA4.EQ.'ONES' .AND. ICASA2.EQ.'LOWE'))THEN 13336 ICOL=ICOL+1 13337 ITITL2(1,ICOL)='Lower' 13338 NCTIT2(1,ICOL)=5 13339 ITITL2(2,ICOL)='Limit' 13340 NCTIT2(2,ICOL)=5 13341 ENDIF 13342C 13343 IF(ICASA4.EQ.'TWOS' .OR. 13344 1 (ICASA4.EQ.'ONES' .AND. ICASA2.EQ.'UPPE'))THEN 13345 ICOL=ICOL+1 13346 ITITL2(1,ICOL)='Upper' 13347 NCTIT2(1,ICOL)=5 13348 ITITL2(2,ICOL)='Limit' 13349 NCTIT2(2,ICOL)=5 13350 ENDIF 13351C 13352 NUMLIN=2 13353 NUMCOL=ICOL 13354 NUMROW=NALP 13355 NMAX=0 13356 DO4221I=1,NUMCOL 13357 VALIGN(I)='b' 13358 ALIGN(I)='r' 13359 NTOT(I)=15 13360 IDIGIT(I)=NUMDIG 13361 ITYPCO(I)='NUME' 13362 IWHTML(I)=150 13363 IF(I.EQ.1)THEN 13364 NTOT(I)=12 13365 IDIGIT(I)=1 13366 IWHTML(1)=75 13367 IWRTF(1)=2000 13368 ELSE 13369 IWRTF(I)=IWRTF(I-1)+2000 13370 ENDIF 13371 NMAX=NMAX+NTOT(I) 13372 4221 CONTINUE 13373C 13374 DO4223I=1,NUMROW 13375 AMAT(I,1)=CONF(I) 13376 AMAT(I,2)=YSD 13377 JCNT=2 13378 IF(ICASA4.EQ.'TWOS' .OR. 13379 1 (ICASA4.EQ.'ONES' .AND. ICASA2.EQ.'LOWE'))THEN 13380 JCNT=JCNT+1 13381 AMAT(I,JCNT)=ALOWLM(I) 13382 ENDIF 13383 IF(ICASA4.EQ.'TWOS' .OR. 13384 1 (ICASA4.EQ.'ONES' .AND. ICASA2.EQ.'UPPE'))THEN 13385 JCNT=JCNT+1 13386 AMAT(I,JCNT)=AUPPLM(I) 13387 ENDIF 13388 4223 CONTINUE 13389C 13390 IFRST=.TRUE. 13391 ILAST=.TRUE. 13392 ITITL9=' ' 13393 ITITLE=' ' 13394 NCTIT9=0 13395 NCTITL=0 13396C 13397 CALL DPDTA4(ITITL9,NCTIT9, 13398 1 ITITLE,NCTITL,ITITL2,NCTIT2, 13399 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 13400 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW, 13401 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 13402 1 ICAPSW,ICAPTY,IFRST,ILAST, 13403 1 ISUBRO,IBUGA3,IERROR) 13404C 13405 GOTO400 13406C 13407C ***************** 13408C ** STEP 90-- ** 13409C ** EXIT ** 13410C ***************** 13411C 13412 9000 CONTINUE 13413 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SDC2')THEN 13414 WRITE(ICOUT,999) 13415 CALL DPWRST('XXX','WRIT') 13416 WRITE(ICOUT,9011) 13417 9011 FORMAT('***** AT THE END OF DPSDC2--') 13418 CALL DPWRST('XXX','WRIT') 13419 WRITE(ICOUT,9012)IERROR 13420 9012 FORMAT('IERROR = ',A4) 13421 CALL DPWRST('XXX','WRIT') 13422 ENDIF 13423C 13424 RETURN 13425 END 13426 SUBROUTINE DPSDC3(Y,N,ICASAN,ICASA2,ICASA3,ICASA4, 13427 1 YSD, 13428 1 ALPHA,NALPHA,ALOWLM,AUPPLM, 13429 1 ISUBRO,IBUGA3,IERROR) 13430C 13431C PURPOSE--THIS SUBROUTINE COMPUTES CONFIDENCE LIMITS FOR THE 13432C STANDARD DEVIATION ASSUMING A NORMAL DISTRIBUTION 13433C 13434C THE FOLLOWING CASES ARE SUPPORTED: 13435C 13436C LET A = LOWER SD CONFIDENCE LIMIT Y 13437C LET A = UPPER SD CONFIDENCE LIMIT Y 13438C LET A = ONE SIDED LOWER SD CONFIDENCE INTERVAL Y 13439C LET A = ONE SIDED UPPER SD CONFIDENCE INTERVAL Y 13440C 13441C THE DATA CONSISTS OF N OBSERVATIONS IN Y. 13442C 13443C FOR ALL OF THE CASES ABOVE, THERE IS A "SUMMARY" CASE 13444C WHERE WE SPECIFY THE MEAN, STANDARD DEVIATION, AND SAMPLE 13445C SIZE FOR THE FIRST SAMPLE. FOR EXAMPLE, 13446C 13447C LET A = SUMMARY LOWER SD CONFIDENCE INTERVAL YMEAN YSD N 13448C 13449C A TWO-SIDED CONFIDENCE INTERVAL FOR THE STANDARD 13450C DEVIATION IS: 13451C 13452C [s(lower),s(upper)] = [s*SQRT((n-1)/CHSPPF(1-alpha/2;n-1)), 13453C s*SQRT((n-1)/CHSPPF(1-alpha/2;n-1))] 13454C 13455C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR OF 13456C (UNSORTED OR SORTED) OBSERVATIONS. 13457C --N = THE INTEGER NUMBER OF OBSERVATIONS 13458C IN THE VECTOR Y. 13459C --ALPHA = THE SINGLE PRECISION VECTOR OF CONFIDENCE 13460C LEVELS 13461C NALPHA = THE INTEGER NUMBER OF ALPHA VALUES 13462C OUTPUT ARGUMENTS-ALOWLM = THE SINGLE PRECISION VECTOR OF LOWER LIMIT 13463C VALUES 13464C -AUPPLM = THE SINGLE PRECISION VECTOR OF UPPER LIMIT 13465C VALUES 13466C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 13467C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. 13468C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 13469C LANGUAGE--ANSI FORTRAN. 13470C REFERENCES--HAHN AND MEEKER (1991), "STATISTICAL INTERVALS: A 13471C GUIDE FOR PRACTIONERS", WILEY, PP. 55-56. 13472C WRITTEN BY--ALAN HECKERT 13473C STATISTICAL ENGINEERING LABORATORY 13474C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13475C GAITHERSBURG, MD 20899-8980 13476C PHONE--301-975-2899 13477C ORIGINAL VERSION--APRIL 2013. 13478C 13479C--------------------------------------------------------------------- 13480C 13481 DIMENSION Y(*) 13482 DIMENSION ALOWLM(*) 13483 DIMENSION AUPPLM(*) 13484 DIMENSION ALPHA(*) 13485C 13486 CHARACTER*4 ICASAN 13487 CHARACTER*4 ICASA2 13488 CHARACTER*4 ICASA3 13489 CHARACTER*4 ICASA4 13490 CHARACTER*4 ISUBRO 13491 CHARACTER*4 IBUGA3 13492 CHARACTER*4 IERROR 13493C 13494 CHARACTER*4 IWRITE 13495 CHARACTER*4 ISUBN1 13496 CHARACTER*4 ISUBN2 13497 CHARACTER*4 ISTEPN 13498C 13499C-----COMMON---------------------------------------------------------- 13500C 13501 INCLUDE 'DPCOP2.INC' 13502C 13503C-----START POINT----------------------------------------------------- 13504C 13505 ISUBN1='SDC3' 13506 ISUBN2=' ' 13507 IWRITE='OFF' 13508 IERROR='NO' 13509C 13510 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SDC3')THEN 13511 WRITE(ICOUT,999) 13512 999 FORMAT(1X) 13513 CALL DPWRST('XXX','WRIT') 13514 WRITE(ICOUT,51) 13515 51 FORMAT('**** AT THE BEGINNING OF DPSDC3--') 13516 CALL DPWRST('XXX','WRIT') 13517 WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASAN,ICASA2,ICASA3,ICASA4 13518 52 FORMAT('IBUGA3,ISUBRO,ICASAN,ICASA2,ICASA3,ICASA4 = ', 13519 1 5(A4,2X),A4) 13520 CALL DPWRST('XXX','WRIT') 13521 WRITE(ICOUT,53)N,NALPHA,YSD,ALPHA(1) 13522 53 FORMAT('N,NALPHA,YSD,ALPHA(1) = ',2I8,2G15.7) 13523 CALL DPWRST('XXX','WRIT') 13524 IF(ICASA3.EQ.'RAW')THEN 13525 DO56I=1,N 13526 WRITE(ICOUT,57)I,Y(I) 13527 57 FORMAT('I,Y(I) = ',I8,G15.7) 13528 CALL DPWRST('XXX','WRIT') 13529 56 CONTINUE 13530 ENDIF 13531 DO76I=1,NALPHA 13532 WRITE(ICOUT,77)I,ALPHA(I) 13533 77 FORMAT('I,ALPHA(I) = ',I8,G15.7) 13534 CALL DPWRST('XXX','WRIT') 13535 76 CONTINUE 13536 ENDIF 13537C 13538C ******************************************** 13539C ** STEP 11-- ** 13540C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 13541C ******************************************** 13542C 13543 ISTEPN='11' 13544 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SDC3') 13545 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 13546C 13547 IF(N.LT.2)THEN 13548 WRITE(ICOUT,999) 13549 CALL DPWRST('XXX','WRIT') 13550 WRITE(ICOUT,101) 13551 101 FORMAT('***** ERROR: STANDARD DEVIATION CONFIDENCE LIMITS--') 13552 CALL DPWRST('XXX','WRIT') 13553 WRITE(ICOUT,102) 13554 102 FORMAT(' THE NUMBER OF ORIGINAL OBSERVATIONS IS LESS ', 13555 1 'THAN TWO.') 13556 CALL DPWRST('XXX','WRIT') 13557 WRITE(ICOUT,103)N 13558 103 FORMAT(' SAMPLE SIZE = ',I8) 13559 CALL DPWRST('XXX','WRIT') 13560 IERROR='YES' 13561 GOTO9000 13562 ENDIF 13563C 13564C ******************************************** 13565C ** STEP 21-- ** 13566C ** CARRY OUT CALCULATIONS FOR PREDICTION ** 13567C ** LIMITS. ** 13568C ******************************************** 13569C 13570 ISTEPN='21' 13571 IF(IBUGA3.EQ.'ON'.AND.ISUBRO.EQ.'SDC3') 13572 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 13573C 13574C ICASAN: LIMI => CONFIDENCE LIMIT FOR SD 13575C ICASA2: LOWE => LOWER LIMIT 13576C UPPE => UPPER LIMIT 13577C ICASA3: RAW => RAW DATA IN Y1 13578C SUMM => SUMMARY DATA IN YMEAN AND YSD 13579C ICASA4: ONES => ONE-SIDED LIMIT 13580C TWOS => TWO-SIDED LIMIT 13581C 13582C COMPUTE STANDARD DEVIATION 13583C 13584 DO210I=1,NALPHA 13585 ALOWLM(I)=CPUMIN 13586 AUPPLM(I)=CPUMIN 13587 210 CONTINUE 13588C 13589 IF(ICASA3.EQ.'RAW')THEN 13590 CALL SD(Y,N,IWRITE,YSD,IBUGA3,IERROR) 13591 ENDIF 13592C 13593 IF(YSD.LE.0.0)THEN 13594 WRITE(ICOUT,999) 13595 CALL DPWRST('XXX','WRIT') 13596 WRITE(ICOUT,101) 13597 CALL DPWRST('XXX','WRIT') 13598 WRITE(ICOUT,212) 13599 212 FORMAT(' THE STANDARD DEVIATION OF THE ORIGINAL ', 13600 1 'OBSERVATIONS IS NON-POSITIVE.') 13601 CALL DPWRST('XXX','WRIT') 13602 IERROR='YES' 13603 GOTO9000 13604 ENDIF 13605C 13606 NU1=N-1 13607 ANU=REAL(NU1) 13608C 13609C 2016/07: ISSUE WITH CHSPPF WHEN DEGREES OF FREEDOM IS LARGE. 13610C FOR NOW, TRUNCATE DEGREES OF FREEDOM AT 150,000. 13611C 13612 NU1TMP=NU1 13613 IF(NU1TMP.GT.150000)THEN 13614 NU1TMP=150000 13615 ANU=REAL(NU1TMP) 13616 ENDIF 13617C 13618 IF(ICASA4.EQ.'ONES')THEN 13619 DO460I=1,NALPHA 13620 ALPHAT=ALPHA(I) 13621 IF(ALPHAT.GE.1.0 .AND. ALPHAT.LT.100.0)ALPHAT=ALPHAT/100. 13622 IF(ALPHAT.LE.0.0 .OR. ALPHAT.GE.1.0)GOTO8000 13623 IF(ALPHAT.GT.0.5)ALPHAT=1.0 - ALPHAT 13624 CALL CHSPPF(ALPHAT,NU1TMP,PPF) 13625 AUPPLM(I)=YSD*SQRT(ANU/PPF) 13626 ALPHAT=1.0 - ALPHAT 13627 CALL CHSPPF(ALPHAT,NU1TMP,PPF) 13628 ALOWLM(I)=YSD*SQRT(ANU/PPF) 13629 460 CONTINUE 13630 ELSEIF(ICASA4.EQ.'TWOS')THEN 13631 DO465I=1,NALPHA 13632 ALPHAT=ALPHA(I) 13633 IF(ALPHAT.GE.1.0 .AND. ALPHAT.LT.100.0)ALPHAT=ALPHAT/100. 13634 IF(ALPHAT.LE.0.0 .OR. ALPHAT.GE.1.0)GOTO8000 13635 IF(ALPHAT.GT.0.5)ALPHAT=1.0 - ALPHAT 13636 ALPHAT=ALPHAT/2.0 13637 CALL CHSPPF(ALPHAT,NU1TMP,PPF) 13638 AUPPLM(I)=YSD*SQRT(ANU/PPF) 13639 ALPHAT=1.0 - ALPHAT 13640 CALL CHSPPF(ALPHAT,NU1TMP,PPF) 13641 ALOWLM(I)=YSD*SQRT(ANU/PPF) 13642 465 CONTINUE 13643 ENDIF 13644C 13645 GOTO9000 13646C 13647 8000 CONTINUE 13648 WRITE(ICOUT,999) 13649 CALL DPWRST('XXX','WRIT') 13650 WRITE(ICOUT,101) 13651 CALL DPWRST('XXX','WRIT') 13652 WRITE(ICOUT,8001)I 13653 8001 FORMAT(' ROW ',I8,' OF ALPHA VALUES IS OUT OF RANGE.') 13654 CALL DPWRST('XXX','WRIT') 13655 WRITE(ICOUT,8003)ALPHA(I) 13656 8003 FORMAT(' THE VALUE OF ALPHA IS ',G15.7) 13657 CALL DPWRST('XXX','WRIT') 13658 IERROR='YES' 13659 GOTO9000 13660C 13661 9000 CONTINUE 13662 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SDC3')THEN 13663 WRITE(ICOUT,999) 13664 CALL DPWRST('XXX','WRIT') 13665 WRITE(ICOUT,9051) 13666 9051 FORMAT('**** AT THE END OF DPSDC3--') 13667 CALL DPWRST('XXX','WRIT') 13668 WRITE(ICOUT,9052)YSD,PPF,ALPHA(NALPHA),ALPHAT,ANU,PPF 13669 9052 FORMAT('YSD,PPF,ALPHA(NALPHA),ALPHAT,ANU,PPF = ',6G15.7) 13670 CALL DPWRST('XXX','WRIT') 13671 ENDIF 13672C 13673 RETURN 13674 END 13675 SUBROUTINE DPSDF(IHARG,NUMARG,ISDFSW,IFOUND,IERROR) 13676C 13677C PURPOSE--DEFINE THE 3-D SIDEFACE SWITCH ISDFSW. 13678C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 13679C --NUMARG 13680C OUTPUT ARGUMENTS--ISDFSW ('ON' OR 'OFF') 13681C --IFOUND ('YES' OR 'NO' ) 13682C --IERROR ('YES' OR 'NO' ) 13683C NOTE--THIS SUBROUTINE ASSUMES A 13684C COMPLICATED-TO-SIMPLE CHECKING ORDER 13685C (IN MAIPC4) OF THE VARIOUS SIDEFACE COMMANDS. 13686C WRITTEN BY--JAMES J. FILLIBEN 13687C STATISTICAL ENGINEERING DIVISION 13688C INFORMATION TECHNOLOGY LABORATORY 13689C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13690C GAITHERSBURG, MD 20899-8980 13691C PHONE--301-975-2899 13692C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13693C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13694C LANGUAGE--ANSI FORTRAN (1977) 13695C VERSION NUMBER--88/10 13696C ORIGINAL VERSION--SEPTEMBER 1988. 13697C 13698C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13699C 13700 CHARACTER*4 IHARG 13701 CHARACTER*4 ISDFSW 13702 CHARACTER*4 IFOUND 13703 CHARACTER*4 IERROR 13704C 13705C--------------------------------------------------------------------- 13706C 13707 DIMENSION IHARG(*) 13708C 13709C-----COMMON---------------------------------------------------------- 13710C 13711 INCLUDE 'DPCOP2.INC' 13712C 13713C-----START POINT----------------------------------------------------- 13714C 13715 IFOUND='NO' 13716 IERROR='NO' 13717C 13718 IF(NUMARG.EQ.0)GOTO1150 13719C 13720 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 13721 IF(IHARG(NUMARG).EQ.'OFF')GOTO1160 13722 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 13723 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1160 13724 GOTO1199 13725C 13726 1150 CONTINUE 13727 ISDFSW='ON' 13728 GOTO1180 13729C 13730 1160 CONTINUE 13731 ISDFSW='OFF' 13732 GOTO1180 13733C 13734 1180 CONTINUE 13735 IFOUND='YES' 13736C 13737 IF(IFEEDB.EQ.'OFF')GOTO1189 13738 WRITE(ICOUT,999) 13739 999 FORMAT(1X) 13740 CALL DPWRST('XXX','BUG ') 13741 WRITE(ICOUT,1181)ISDFSW 13742 1181 FORMAT('THE (3-D) SIDEFACE SWITCH ', 13743 1'HAS JUST BEEN SET TO ',A4) 13744 CALL DPWRST('XXX','BUG ') 13745 1189 CONTINUE 13746 GOTO1199 13747C 13748 1199 CONTINUE 13749 RETURN 13750 END 13751 SUBROUTINE DPSDGC(IHARG,NUMARG,IDSDGC,ISDFGC,IFOUND,IERROR) 13752C 13753C PURPOSE--DEFINE THE COLOR FOR THE 3-D SIDEFACE GRID. 13754C THE COLOR FOR THE SIDEFACE GRID WILL BE PLACED 13755C IN THE CHARACTER VARIABLE ISDFGC. 13756C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 13757C --NUMARG 13758C --IDSDGC 13759C OUTPUT ARGUMENTS--ISDFGC 13760C --IFOUND ('YES' OR 'NO' ) 13761C --IERROR ('YES' OR 'NO' ) 13762C NOTE--THIS SUBROUTINE ASSUMES A 13763C COMPLICATED-TO-SIMPLE CHECKING ORDER 13764C (IN MAIPC4) OF THE VARIOUS SIDEFACE COMMANDS. 13765C WRITTEN BY--JAMES J. FILLIBEN 13766C STATISTICAL ENGINEERING DIVISION 13767C INFORMATION TECHNOLOGY LABORATORY 13768C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13769C WASHINGPON, D. C. 20234 13770C PHONE--301-975-2899 13771C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13772C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13773C LANGUAGE--ANSI FORTRAN (1977) 13774C VERSION NUMBER--88/10 13775C ORIGINAL VERSION--SEPTEMBER 1988. 13776C 13777C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13778C 13779 CHARACTER*4 IHARG 13780 CHARACTER*4 IDSDGC 13781 CHARACTER*4 ISDFGC 13782 CHARACTER*4 IFOUND 13783 CHARACTER*4 IERROR 13784C 13785C--------------------------------------------------------------------- 13786C 13787 DIMENSION IHARG(*) 13788C 13789C-----COMMON---------------------------------------------------------- 13790C 13791 INCLUDE 'DPCOP2.INC' 13792C 13793C-----START POINT----------------------------------------------------- 13794C 13795 IFOUND='NO' 13796 IERROR='NO' 13797C 13798 IF(NUMARG.LE.1)GOTO1199 13799 IF(NUMARG.EQ.2)GOTO1150 13800C 13801 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 13802 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 13803 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 13804 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 13805 GOTO1160 13806C 13807 1150 CONTINUE 13808 ISDFGC=IDSDGC 13809 GOTO1180 13810C 13811 1160 CONTINUE 13812 ISDFGC=IHARG(NUMARG) 13813 GOTO1180 13814C 13815 1180 CONTINUE 13816 IFOUND='YES' 13817C 13818 IF(IFEEDB.EQ.'OFF')GOTO1189 13819 WRITE(ICOUT,999) 13820 999 FORMAT(1X) 13821 CALL DPWRST('XXX','BUG ') 13822 WRITE(ICOUT,1181)ISDFGC 13823 1181 FORMAT('THE (3-D) SIDEFACE GRID COLOR ', 13824 1'HAS JUST BEEN SET TO ',A4) 13825 CALL DPWRST('XXX','BUG ') 13826 1189 CONTINUE 13827 GOTO1199 13828C 13829 1199 CONTINUE 13830 RETURN 13831 END 13832 SUBROUTINE DPSDGP(IHARG,NUMARG,IDSDGP,ISDFGP,IFOUND,IERROR) 13833C 13834C PURPOSE--DEFINE THE PATTERN FOR THE 3-D SIDEFACE GRID. 13835C THE PATTERN FOR THE SIDEFACE GRID WILL BE PLACED 13836C IN THE CHARACTER VARIABLE ISDFGP. 13837C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 13838C --NUMARG 13839C --IDSDGP 13840C OUTPUT ARGUMENTS--ISDFGP 13841C --IFOUND ('YES' OR 'NO' ) 13842C --IERROR ('YES' OR 'NO' ) 13843C NOTE--THIS SUBROUTINE ASSUMES A 13844C COMPLICATED-TO-SIMPLE CHECKING ORDER 13845C (IN MAIPC4) OF THE VARIOUS SIDEFACE COMMANDS. 13846C WRITTEN BY--JAMES J. FILLIBEN 13847C STATISTICAL ENGINEERING DIVISION 13848C INFORMATION TECHNOLOGY LABORATORY 13849C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13850C WASHINGPON, D. C. 20234 13851C PHONE--301-975-2899 13852C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13853C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13854C LANGUAGE--ANSI FORTRAN (1977) 13855C VERSION NUMBER--88/10 13856C ORIGINAL VERSION--SEPTEMBER 1988. 13857C 13858C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13859C 13860 CHARACTER*4 IHARG 13861 CHARACTER*4 IDSDGP 13862 CHARACTER*4 ISDFGP 13863 CHARACTER*4 IFOUND 13864 CHARACTER*4 IERROR 13865C 13866C--------------------------------------------------------------------- 13867C 13868 DIMENSION IHARG(*) 13869C 13870C-----COMMON---------------------------------------------------------- 13871C 13872 INCLUDE 'DPCOP2.INC' 13873C 13874C-----START POINT----------------------------------------------------- 13875C 13876 IFOUND='NO' 13877 IERROR='NO' 13878C 13879 IF(NUMARG.LE.1)GOTO1199 13880 IF(NUMARG.EQ.2)GOTO1160 13881C 13882 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 13883 IF(IHARG(NUMARG).EQ.'OFF')GOTO1160 13884 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 13885 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1170 13886 GOTO1175 13887C 13888 1150 CONTINUE 13889 ISDFGP='SOLI' 13890 GOTO1180 13891C 13892 1160 CONTINUE 13893 ISDFGP='BLAN' 13894 GOTO1180 13895C 13896 1170 CONTINUE 13897 ISDFGP=IDSDGP 13898 GOTO1180 13899C 13900 1175 CONTINUE 13901 ISDFGP=IHARG(NUMARG) 13902 GOTO1180 13903C 13904 1180 CONTINUE 13905 IFOUND='YES' 13906C 13907 IF(IFEEDB.EQ.'OFF')GOTO1189 13908 WRITE(ICOUT,999) 13909 999 FORMAT(1X) 13910 CALL DPWRST('XXX','BUG ') 13911 WRITE(ICOUT,1181)ISDFGP 13912 1181 FORMAT('THE (3-D) SIDEFACE GRID PATTERN ', 13913 1'HAS JUST BEEN SET TO ',A4) 13914 CALL DPWRST('XXX','BUG ') 13915 1189 CONTINUE 13916 GOTO1199 13917C 13918 1199 CONTINUE 13919 RETURN 13920 END 13921 SUBROUTINE DPSDGR(IHARG,NUMARG,IDSDGR,ISDFGR,IFOUND,IERROR) 13922C 13923C PURPOSE--DEFINE THE 3-D SIDEFACE GRID SWITCH ISDFGR. 13924C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 13925C --NUMARG 13926C --IDSDGR 13927C OUTPUT ARGUMENTS--ISDFGR ('ON' OR 'OFF') 13928C --IFOUND ('YES' OR 'NO' ) 13929C --IERROR ('YES' OR 'NO' ) 13930C NOTE--THIS SUBROUTINE ASSUMES A 13931C COMPLICATED-TO-SIMPLE CHECKING ORDER 13932C (IN MAIPC4) OF THE VARIOUS SIDEFACE COMMANDS. 13933C WRITTEN BY--JAMES J. FILLIBEN 13934C STATISTICAL ENGINEERING DIVISION 13935C INFORMATION TECHNOLOGY LABORATORY 13936C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13937C GAITHERSBURG, MD 20899-8980 13938C PHONE--301-975-2899 13939C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13940C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13941C LANGUAGE--ANSI FORTRAN (1977) 13942C VERSION NUMBER--88/10 13943C ORIGINAL VERSION--SEPTEMBER 1988. 13944C 13945C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13946C 13947 CHARACTER*4 IHARG 13948 CHARACTER*4 IDSDGR 13949 CHARACTER*4 ISDFGR 13950 CHARACTER*4 IFOUND 13951 CHARACTER*4 IERROR 13952C 13953C--------------------------------------------------------------------- 13954C 13955 DIMENSION IHARG(*) 13956C 13957C-----COMMON---------------------------------------------------------- 13958C 13959 INCLUDE 'DPCOP2.INC' 13960C 13961C-----START POINT----------------------------------------------------- 13962C 13963 IFOUND='NO' 13964 IERROR='NO' 13965C 13966 IF(NUMARG.EQ.0)GOTO1199 13967 IF(NUMARG.EQ.1)GOTO1150 13968C 13969 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 13970 IF(IHARG(NUMARG).EQ.'OFF')GOTO1160 13971 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 13972 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1170 13973 GOTO1199 13974C 13975 1150 CONTINUE 13976 ISDFGR='ON' 13977 GOTO1180 13978C 13979 1160 CONTINUE 13980 ISDFGR='OFF' 13981 GOTO1180 13982C 13983 1170 CONTINUE 13984 ISDFGR=IDSDGR 13985 GOTO1180 13986C 13987 1180 CONTINUE 13988 IFOUND='YES' 13989C 13990 IF(IFEEDB.EQ.'OFF')GOTO1189 13991 WRITE(ICOUT,999) 13992 999 FORMAT(1X) 13993 CALL DPWRST('XXX','BUG ') 13994 WRITE(ICOUT,1181)ISDFGR 13995 1181 FORMAT('THE (3-D) SIDEFACE GRID SWITCH ', 13996 1'HAS JUST BEEN SET TO ',A4) 13997 CALL DPWRST('XXX','BUG ') 13998 1189 CONTINUE 13999 GOTO1199 14000C 14001 1199 CONTINUE 14002 RETURN 14003 END 14004 SUBROUTINE DPSDPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 14005 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 14006C 14007C PURPOSE--GENERATE A SPATIAL DISTRIBUTION PLOT. 14008C 14009C GIVEN A RECTANGULAR ARRAY OF POINTS, THERE 14010C ARE 3 COMMON PATTERNS OF CLUSTERING: 14011C 14012C 1) UNIFORM - 14013C 14014C MODEL WITH A DISCRETE UNIFORM DISTRIBUTION 14015C 14016C 2) XX - 14017C 14018C MODEL WITH A POISSON DISTRIBUTION 14019C 14020C 3) XX - 14021C 14022C MODEL WITH A NEGATIVE BINOMIAL DISTRIBUTION 14023C 14024C IT IS ASSUMED THAT EACH POINT IS EITHER ON OR 14025C OFF (I.E., <0/1>). IF THE RESPONSE DATA IS 14026C A GREY-SCALE VALUE, POINTS ABOVE SOME 14027C USER-SPECIFIED THRESHOLD VALUE ARE CONSIDERED 14028C "ON" AND THOSE BELOW THE THRESHOLD ARE 14029C CONSIDERED OFF. 14030C 14031C THE POINT OF THIS PLOT IS TO SEE WHICH OF 14032C THE THREE ABOVE DISTRIBUTIONS BEST FITS THE 14033C DATA AT VARIOUS PARTITION SIZES. 14034C 14035C THAT IS, WE PICK A PARTITION SIZE. FOR EXAMPLE, 14036C FOR A 512x512 ARRAY, WE MIGHT START WITH A 14037C PARTITION CONSISTING OF 8x8 SQUARES. WITHIN EACH 14038C SQUARE, WE SUM THE NUMBER OF "1's". WE THEN 14039C MODEL THE DISTRIBUTION OF THESE SUMS. SPECIFICALLY, 14040C 14041C 1) FOR THE DISCRETE UNIFORM, GENERATE A 14042C PROBABILITY PLOT. 14043C 14044C 2) FOR THE POISSON DISTRIBUTION, GENERATE A 14045C "POISSONESS" PLOT. 14046C 14047C 3) FOR THE NEGATIVE BINOMIAL, GENERATE A 14048C "NEGATIVE BINOMIALNESS" PLOT. 14049C 14050C IN EACH CASE, THE LINEARITY OF THE PLOT IS AN 14051C INDICATION OF GOODNESS OF FIT. WE WILL USE THE 14052C CORRELATION COEFFICIENT AS THE MEASURE OF GOODNESS OF 14053C FIT. THE SPATIAL DISTRIBUTION PLOT THEN CONSISTS OF: 14054C 14055C X-AXIS - SIZE OF PARTITION 14056C Y-AXIS - CORRELATION COEFFICIENT FOR EACH OF 14057C THE THREE DISTRIBUTIONS 14058C 14059C 14060C EXAMPLES--SPATIAL DISTRIBUTION PLOT M 14061C SPATIAL DISTRIBUTION PLOT M PART 14062C SPATIAL DISTRIBUTION PLOT Y ROWID COLID 14063C SPATIAL DISTRIBUTION PLOT Y ROWID COLID PART 14064C WRITTEN BY--JAMES J. FILLIBEN 14065C STATISTICAL ENGINEERING DIVISION 14066C INFORMATION TECHNOLOGY LABORATORY 14067C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 14068C GAITHERSBURG, MD 20899-8980 14069C PHONE--301-975-2899 14070C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 14071C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 14072C LANGUAGE--ANSI FORTRAN (1977) 14073C VERSION NUMBER--2008/4 14074C ORIGINAL VERSION--APRIL 2008. 14075C 14076C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 14077C 14078 CHARACTER*4 ICASPL 14079 CHARACTER*4 IAND1 14080 CHARACTER*4 IAND2 14081 CHARACTER*4 IBUGG2 14082 CHARACTER*4 IBUGG3 14083 CHARACTER*4 IBUGQ 14084 CHARACTER*4 ISUBRO 14085 CHARACTER*4 IFOUND 14086 CHARACTER*4 IERROR 14087C 14088 CHARACTER*4 ICASE 14089 CHARACTER*4 IH11 14090 CHARACTER*4 IH12 14091 CHARACTER*4 IH21 14092 CHARACTER*4 IH22 14093 CHARACTER*4 IH31 14094 CHARACTER*4 IH32 14095 CHARACTER*4 IH41 14096 CHARACTER*4 IH42 14097 CHARACTER*4 IHWUSE 14098 CHARACTER*4 MESSAG 14099 CHARACTER*4 IHP 14100 CHARACTER*4 IHP2 14101 CHARACTER*4 IUSE1 14102 CHARACTER*4 IUSE2 14103 CHARACTER*4 IUSE3 14104 CHARACTER*4 ICASEQ 14105 CHARACTER*4 ISUBN1 14106 CHARACTER*4 ISUBN2 14107 CHARACTER*4 ISTEPN 14108C 14109C-----COMMON---------------------------------------------------------- 14110C 14111 INCLUDE 'DPCOPA.INC' 14112 INCLUDE 'DPCOCP.INC' 14113 INCLUDE 'DPCOHK.INC' 14114 INCLUDE 'DPCODA.INC' 14115 INCLUDE 'DPCOST.INC' 14116C 14117C--------------------------------------------------------------------- 14118C 14119 DIMENSION YRESP(MAXOBV) 14120 DIMENSION PART(MAXOBV) 14121 DIMENSION ROWID(MAXOBV) 14122 DIMENSION COLID(MAXOBV) 14123 DIMENSION TEMP1(MAXOBV) 14124 DIMENSION TEMP2(MAXOBV) 14125 DIMENSION TEMP3(MAXOBV) 14126 DIMENSION TEMP4(MAXOBV) 14127 INCLUDE 'DPCOZZ.INC' 14128 EQUIVALENCE (GARBAG(IGARB1),YRESP(1)) 14129 EQUIVALENCE (GARBAG(IGARB2),PART(1)) 14130 EQUIVALENCE (GARBAG(IGARB3),ROWID(1)) 14131 EQUIVALENCE (GARBAG(IGARB4),COLID(1)) 14132 EQUIVALENCE (GARBAG(IGARB5),TEMP1(1)) 14133 EQUIVALENCE (GARBAG(IGARB6),TEMP2(1)) 14134 EQUIVALENCE (GARBAG(IGARB7),TEMP3(1)) 14135 EQUIVALENCE (GARBAG(IGARB8),TEMP4(1)) 14136C 14137C-----COMMON VARIABLES (GENERAL)-------------------------------------- 14138C 14139 INCLUDE 'DPCOP2.INC' 14140C 14141C-----START POINT----------------------------------------------------- 14142C 14143 ISUBN1='DPSD' 14144 ISUBN2='PL ' 14145 ICASE='VARI' 14146 ICASPL='SDPL' 14147 IFOUND='NO' 14148 IERROR='NO' 14149C 14150 MAXCP1=MAXCOL+1 14151 MAXCP2=MAXCOL+2 14152 MAXCP3=MAXCOL+3 14153 MAXCP4=MAXCOL+4 14154 MAXCP5=MAXCOL+5 14155 MAXCP6=MAXCOL+6 14156 MINN2=16 14157 ICOL4=0 14158C 14159 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SDPL')THEN 14160 WRITE(ICOUT,999) 14161 999 FORMAT(1X) 14162 CALL DPWRST('XXX','BUG ') 14163 WRITE(ICOUT,51) 14164 51 FORMAT('***** AT THE BEGINNING OF DPSDPL--') 14165 CALL DPWRST('XXX','BUG ') 14166 WRITE(ICOUT,52)NPLOTV,NPLOTP,NS 14167 52 FORMAT('NPLOTV,NPLOTP,NS = ',3I8) 14168 CALL DPWRST('XXX','BUG ') 14169 WRITE(ICOUT,53)ICASPL,IAND1,IAND2 14170 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) 14171 CALL DPWRST('XXX','BUG ') 14172 WRITE(ICOUT,56)ICASPL,MAXN 14173 56 FORMAT('ICASPL,MAXN = ',A4,I8) 14174 CALL DPWRST('XXX','BUG ') 14175 WRITE(ICOUT,57)IFOUND,IERROR 14176 57 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 14177 CALL DPWRST('XXX','BUG ') 14178 WRITE(ICOUT,58)MAXNPP 14179 58 FORMAT('MAXNPP = ',I8) 14180 CALL DPWRST('XXX','BUG ') 14181 ENDIF 14182C 14183C ************************************************** 14184C ** TREAT THE SPATIAL DISTRIBUTION PLOT CASE ** 14185C ************************************************** 14186C 14187 IFOUND='YES' 14188 ICASPL='SDPL' 14189C 14190C ******************************************************* 14191C ** STEP 10-- ** 14192C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** 14193C ******************************************************* 14194C 14195 ISTEPN='10' 14196 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SDPL') 14197 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14198C 14199 MINNA=1 14200 MAXNA=100 14201 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) 14202 IF(IERROR.EQ.'YES')GOTO9000 14203C 14204C ***************************************** 14205C ** STEP 11-- ** 14206C ** CHECK THE VALIDITY OF ARGUMENT 1 ** 14207C ** (THIS SHULD BE EITHER A VARIABLE ** 14208C ** OR A MATRIX. ** 14209C ** ** 14210C ** IF A VARIABLE, THEN 3 OR 4 ** 14211C ** INPUT VARIABLES ARE EXPECTED. IF ** 14212C ** IF A MATRIX, THEN ONE MATRIX ** 14213C ** EXPECTED AND ONE OPTIONAL VARIABLE.** 14214C ***************************************** 14215C 14216 ISTEPN='11' 14217 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SDPL') 14218 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14219C 14220 IH11=IHARG(1) 14221 IH12=IHARG2(1) 14222 IHWUSE='V' 14223 MESSAG='YES' 14224C 14225 DO1100I=1,NUMNAM 14226 I2=I 14227 IF(IH11.EQ.IHNAME(I).AND.IH12.EQ.IHNAM2(I).AND. 14228 1 (IUSE(I).EQ.'P'.OR.IUSE(I).EQ.'F'))THEN 14229 GOTO1109 14230 ELSEIF(IH11.EQ.IHNAME(I).AND.IH12.EQ.IHNAM2(I).AND. 14231 1 IUSE(I).EQ.'V')THEN 14232 ICASE='VARI' 14233 GOTO3000 14234 ELSEIF(IH11.EQ.IHNAME(I).AND.IH12.EQ.IHNAM2(I).AND. 14235 1 IUSE(I).EQ.'M')THEN 14236 ICASE='MATR' 14237 ILISR=I2 14238 ICOL1=IVALUE(ILISR) 14239 ICOL2=IVALU2(ILISR) 14240 N1=IN(ILISR) 14241 NCOL=(ICOL2 - ICOL1) + 1 14242 GOTO5000 14243 ENDIF 14244 1100 CONTINUE 14245 GOTO1109 14246C 14247 1109 CONTINUE 14248 WRITE(ICOUT,999) 14249 CALL DPWRST('XXX','BUG ') 14250 WRITE(ICOUT,1191) 14251 1191 FORMAT('***** ERROR IN SPATIAL DISTRIBUTION PLOT--') 14252 CALL DPWRST('XXX','BUG ') 14253 WRITE(ICOUT,1192) 14254 1192 FORMAT(' THE FIRST ARGUMENT WAS EITHER NOT FOUND OR WAS') 14255 CALL DPWRST('XXX','BUG ') 14256 WRITE(ICOUT,1193) 14257 1193 FORMAT(' FOUND AS A PARAMETER, SCALAR OR FUNCTION (AS') 14258 CALL DPWRST('XXX','BUG ') 14259 WRITE(ICOUT,1194) 14260 1194 FORMAT(' OPPOSSED TO A VARIABLE OR A MATRIX).') 14261 CALL DPWRST('XXX','BUG ') 14262 WRITE(ICOUT,1196) 14263 1196 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') 14264 CALL DPWRST('XXX','BUG ') 14265 IF(IWIDTH.GE.1)THEN 14266 WRITE(ICOUT,1197)(IANS(I),I=1,MIN(IWIDTH,80)) 14267 1197 FORMAT(80A1) 14268 CALL DPWRST('XXX','BUG ') 14269 ENDIF 14270 IERROR='YES' 14271 GOTO9000 14272C 14273 3000 CONTINUE 14274C 14275C **************************************** 14276C ** STEP 30-- ** 14277C ** CHECK THE VALIDITY OF ARGUMENT 1 ** 14278C ** (THIS SHOULD BE A VARIABLE.) ** 14279C **************************************** 14280C 14281 ISTEPN='30' 14282 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SDPL') 14283 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14284C 14285 IH11=IHARG(1) 14286 IH12=IHARG2(1) 14287 IHWUSE='V' 14288 MESSAG='YES' 14289 CALL CHECKN(IH11,IH12,IHWUSE, 14290 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 14291 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 14292C 14293 IF(IERROR.EQ.'YES')THEN 14294 WRITE(ICOUT,999) 14295 CALL DPWRST('XXX','BUG ') 14296 WRITE(ICOUT,3011) 14297 3011 FORMAT('***** ERROR IN SPATIAL DISTRIBUTION PLOT--') 14298 CALL DPWRST('XXX','BUG ') 14299 WRITE(ICOUT,3012) 14300 3012 FORMAT(' FOR THE SPATIAL DISTRIBUTION PLOT, ALL ', 14301 1 'ARGUMENTS MUST') 14302 CALL DPWRST('XXX','BUG ') 14303 WRITE(ICOUT,3015) 14304 3015 FORMAT(' BE VARIABLES (AS OPPOSSED TO A PARAMETER OR A') 14305 CALL DPWRST('XXX','BUG ') 14306 WRITE(ICOUT,3016) 14307 3016 FORMAT(' FUNCTION). ARGUMENT ONE WAS NOT A VARIABLE ', 14308 1 'HERE.') 14309 CALL DPWRST('XXX','BUG ') 14310 WRITE(ICOUT,3018) 14311 3018 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') 14312 CALL DPWRST('XXX','BUG ') 14313 IF(IWIDTH.GE.1)THEN 14314 WRITE(ICOUT,3019)(IANS(I),I=1,MIN(IWIDTH,80)) 14315 3019 FORMAT(80A1) 14316 CALL DPWRST('XXX','BUG ') 14317 ENDIF 14318 IERROR='YES' 14319 GOTO9000 14320 ENDIF 14321C 14322 IUSE1=IUSE(ILOCV) 14323 ICOL1=IVALUE(ILOCV) 14324 N1=IN(ILOCV) 14325C 14326 ICASE='VARI' 14327C 14328C ****************************************************** 14329C ** STEP 31-- ** 14330C ** IF ARGUMENT ONE IS A VARIABLE, CHECK THAT THE ** 14331C ** INPUT NUMBER OF OBSERVATIONS (N1) FOR ARGUMENT ** 14332C ** ONE IS TWO OR MORE. ** 14333C ****************************************************** 14334C 14335 ISTEPN='31' 14336 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SDPL') 14337 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14338C 14339 IF(N1.LT.MINN2)THEN 14340 WRITE(ICOUT,999) 14341 CALL DPWRST('XXX','BUG ') 14342 WRITE(ICOUT,3011) 14343 CALL DPWRST('XXX','BUG ') 14344 WRITE(ICOUT,3022) 14345 3022 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR THE') 14346 CALL DPWRST('XXX','BUG ') 14347 WRITE(ICOUT,3023)MINN2 14348 3023 FORMAT(' SPATIAL DISTRIBUTION PLOT MUST BE ',I8, 14349 1 ' OR LARGER.') 14350 CALL DPWRST('XXX','BUG ') 14351 WRITE(ICOUT,3025) 14352 3025 FORMAT(' SUCH WAS NOT THE CASE HERE;') 14353 CALL DPWRST('XXX','BUG ') 14354 WRITE(ICOUT,3027)IH11,IH12,N1 14355 3027 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS.') 14356 CALL DPWRST('XXX','BUG ') 14357 WRITE(ICOUT,3018) 14358 CALL DPWRST('XXX','BUG ') 14359 IF(IWIDTH.GE.1)THEN 14360 WRITE(ICOUT,3019)(IANS(I),I=1,MIN(IWIDTH,80)) 14361 CALL DPWRST('XXX','BUG ') 14362 ENDIF 14363 IERROR='YES' 14364 GOTO9000 14365 ENDIF 14366C 14367C **************************************** 14368C ** STEP 32-- ** 14369C ** CHECK THE VALIDITY OF ARGUMENT 2 ** 14370C ** (THIS SHOULD BE A VARIABLE) ** 14371C **************************************** 14372C 14373 ISTEPN='31B' 14374 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SDPL') 14375 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14376C 14377 IH21=IHARG(2) 14378 IH22=IHARG2(2) 14379 IHWUSE='V' 14380 MESSAG='YES' 14381 CALL CHECKN(IH21,IH22,IHWUSE, 14382 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 14383 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 14384C 14385 IF(IERROR.EQ.'YES')THEN 14386 WRITE(ICOUT,999) 14387 CALL DPWRST('XXX','BUG ') 14388 WRITE(ICOUT,3011) 14389 CALL DPWRST('XXX','BUG ') 14390 WRITE(ICOUT,3112) 14391 3112 FORMAT(' FOR THE SPATIAL DISTRIBUTION PLOT, WHEN THE ', 14392 1 'FIRST ARGUMENT IS A VARIABLE') 14393 CALL DPWRST('XXX','BUG ') 14394 WRITE(ICOUT,3115) 14395 3115 FORMAT(' THERE MUST BE AT LEAST THREE VARIABLES ', 14396 1 'ENTERED.') 14397 CALL DPWRST('XXX','BUG ') 14398 WRITE(ICOUT,3116) 14399 3116 FORMAT(' ONLY ONE VARIABLE WAS GIVEN.') 14400 CALL DPWRST('XXX','BUG ') 14401 WRITE(ICOUT,3118) 14402 3118 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') 14403 CALL DPWRST('XXX','BUG ') 14404 IF(IWIDTH.GE.1)THEN 14405 WRITE(ICOUT,3019)(IANS(I),I=1,MIN(IWIDTH,80)) 14406 CALL DPWRST('XXX','BUG ') 14407 ENDIF 14408 IERROR='YES' 14409 GOTO9000 14410 ENDIF 14411C 14412 IUSE2=IUSE(ILOCV) 14413 ICOL2=IVALUE(ILOCV) 14414 N2=IN(ILOCV) 14415 NVAR=2 14416C 14417 IF(N2.LT.N1)THEN 14418 WRITE(ICOUT,999) 14419 CALL DPWRST('XXX','BUG ') 14420 WRITE(ICOUT,3011) 14421 CALL DPWRST('XXX','BUG ') 14422 WRITE(ICOUT,3122) 14423 3122 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE SECOND') 14424 CALL DPWRST('XXX','BUG ') 14425 WRITE(ICOUT,3123) 14426 3123 FORMAT(' VARIABLE IS NOT EQUAL TO THE NUMBER OF ', 14427 1 'OBSERVATIONS') 14428 CALL DPWRST('XXX','BUG ') 14429 WRITE(ICOUT,3125) 14430 3125 FORMAT(' FOR THE FIRST VARIABLE.') 14431 CALL DPWRST('XXX','BUG ') 14432 WRITE(ICOUT,3127)IH11,IH12,N1 14433 3127 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS.') 14434 CALL DPWRST('XXX','BUG ') 14435 WRITE(ICOUT,3027)IH21,IH22,N2 14436 CALL DPWRST('XXX','BUG ') 14437 WRITE(ICOUT,3018) 14438 CALL DPWRST('XXX','BUG ') 14439 IF(IWIDTH.GE.1)THEN 14440 WRITE(ICOUT,3019)(IANS(I),I=1,MIN(IWIDTH,80)) 14441 CALL DPWRST('XXX','BUG ') 14442 ENDIF 14443 IERROR='YES' 14444 GOTO9000 14445 ENDIF 14446C 14447C **************************************** 14448C ** STEP 32-- ** 14449C ** CHECK THE VALIDITY OF ARGUMENT 3 ** 14450C ** (THIS SHOULD BE A VARIABLE) ** 14451C **************************************** 14452C 14453 ISTEPN='32' 14454 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SDPL') 14455 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14456C 14457 IH31=IHARG(3) 14458 IH32=IHARG2(3) 14459 IHWUSE='V' 14460 MESSAG='YES' 14461 CALL CHECKN(IH31,IH32,IHWUSE, 14462 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 14463 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 14464C 14465 IF(IERROR.EQ.'YES')THEN 14466 WRITE(ICOUT,999) 14467 CALL DPWRST('XXX','BUG ') 14468 WRITE(ICOUT,3011) 14469 CALL DPWRST('XXX','BUG ') 14470 WRITE(ICOUT,3212) 14471 3212 FORMAT(' FOR THE SPATIAL DISTRIBUTION PLOT, WHEN THE ', 14472 1 'FIRST ARGUMENT IS A VARIABLE') 14473 CALL DPWRST('XXX','BUG ') 14474 WRITE(ICOUT,3115) 14475 CALL DPWRST('XXX','BUG ') 14476 WRITE(ICOUT,3216) 14477 3216 FORMAT(' ONLY TWO VARIABLE WERE GIVEN.') 14478 CALL DPWRST('XXX','BUG ') 14479 WRITE(ICOUT,3118) 14480 CALL DPWRST('XXX','BUG ') 14481 IF(IWIDTH.GE.1)THEN 14482 WRITE(ICOUT,3019)(IANS(I),I=1,MIN(IWIDTH,80)) 14483 CALL DPWRST('XXX','BUG ') 14484 ENDIF 14485 IERROR='YES' 14486 GOTO9000 14487 ENDIF 14488C 14489C 14490 IUSE3=IUSE(ILOCV) 14491 ICOL3=IVALUE(ILOCV) 14492 N3=IN(ILOCV) 14493 NVAR=3 14494C 14495C ****************************************************** 14496C ** STEP 32B-- ** 14497C ** IF ARGUMENT THREE IS A VARIABLE, CHECK THAT THE ** 14498C ** INPUT NUMBER OF OBSERVATIONS (N3) FOR ARGUMENT ** 14499C ** THREE IS EQUAL TO THE NUMBER OF OBSERVATIONS ** 14500C ** FOR VARIABLE ONE. ** 14501C ****************************************************** 14502C 14503 ISTEPN='32B' 14504 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SDPL') 14505 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14506C 14507 IF(N3.NE.N1)THEN 14508 WRITE(ICOUT,999) 14509 CALL DPWRST('XXX','BUG ') 14510 WRITE(ICOUT,3011) 14511 CALL DPWRST('XXX','BUG ') 14512 WRITE(ICOUT,3222) 14513 3222 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE THIRD') 14514 CALL DPWRST('XXX','BUG ') 14515 WRITE(ICOUT,3123) 14516 CALL DPWRST('XXX','BUG ') 14517 WRITE(ICOUT,3125) 14518 CALL DPWRST('XXX','BUG ') 14519 WRITE(ICOUT,3027)IH11,IH12,N1 14520 CALL DPWRST('XXX','BUG ') 14521 WRITE(ICOUT,3027)IH31,IH32,N3 14522 CALL DPWRST('XXX','BUG ') 14523 WRITE(ICOUT,3018) 14524 CALL DPWRST('XXX','BUG ') 14525 IF(IWIDTH.GE.1)THEN 14526 WRITE(ICOUT,3019)(IANS(I),I=1,MIN(IWIDTH,80)) 14527 CALL DPWRST('XXX','BUG ') 14528 ENDIF 14529 IERROR='YES' 14530 GOTO9000 14531 ENDIF 14532C 14533C **************************************** 14534C ** STEP 33-- ** 14535C ** CHECK THE VALIDITY OF ARGUMENT 4 ** 14536C ** (THIS SHOULD BE A VARIABLE IF IT ** 14537C ** EXISTS) ** 14538C **************************************** 14539C 14540 ISTEPN='33' 14541 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SDPL') 14542 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14543C 14544 IH41=IHARG(4) 14545 IH42=IHARG2(4) 14546 IHWUSE='V' 14547 MESSAG='NO' 14548 CALL CHECKN(IH41,IH42,IHWUSE, 14549 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 14550 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 14551C 14552 IF(IERROR.EQ.'YES')THEN 14553 IERROR='NO' 14554 N4=0 14555 GOTO3999 14556 ELSE 14557 IUSE3=IUSE(ILOCV) 14558 ICOL4=IVALUE(ILOCV) 14559 N4=IN(ILOCV) 14560 NVAR=4 14561 ENDIF 14562C 14563 NPART=N4 14564C 14565C ****************************************************** 14566C ** STEP 33B- ** 14567C ** IF ARGUMENT FOUR IS A VARIABLE, THIS DENOTES ** 14568C ** THE "PARTITION" VALUES, SO THE NUMBER OF ** 14569C ** OBSERVATIONS NEED NOT MATCH THE NUMBER OF ** 14570C ** OBSERVATIONS FOR VARIABLE ONE. ** 14571C ****************************************************** 14572C 14573C ***************************************** 14574C ** STEP 40-- ** 14575C ** CHECK TO SEE THE TYPE CASE-- ** 14576C ** 1) UNQUALIFIED (THAT IS, FULL); ** 14577C ** 2) SUBSET/EXCEPT; OR ** 14578C ** 3) FOR. ** 14579C ***************************************** 14580C 14581 3999 CONTINUE 14582C 14583 ISTEPN='40' 14584 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SDPL') 14585 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14586C 14587 ICASEQ='FULL' 14588 ILOCQ=NUMARG+1 14589 IF(NUMARG.LT.1)GOTO4090 14590 DO4000J=1,NUMARG 14591 J1=J 14592 IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO4010 14593 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO4010 14594 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO4020 14595 4000 CONTINUE 14596 GOTO4090 14597 4010 CONTINUE 14598 ICASEQ='SUBS' 14599 ILOCQ=J1 14600 GOTO4090 14601 4020 CONTINUE 14602 ICASEQ='FOR' 14603 ILOCQ=J1 14604 GOTO4090 14605 4090 CONTINUE 14606C 14607 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SDPL')THEN 14608 WRITE(ICOUT,4091)NUMARG,ILOCQ 14609 4091 FORMAT('NUMARG,ILOCQ = ',2I8) 14610 CALL DPWRST('XXX','BUG ') 14611 ENDIF 14612C 14613C *********************************************** 14614C ** STEP 41-- ** 14615C ** TEMPORARILY FORM THE VARIABLE Y(.) ** 14616C ** WHICH WILL HOLD THE DATA FROM SAMPLE 1. ** 14617C ** FORM THIS VARIABLE BY ** 14618C ** BRANCHING TO THE APPROPRIATE SUBCASE ** 14619C ** (FULL, SUBSET, OR FOR). ** 14620C *********************************************** 14621C 14622 ISTEPN='41' 14623 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SDPL') 14624 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14625C 14626 IF(ICASEQ.EQ.'FULL')GOTO4110 14627 IF(ICASEQ.EQ.'SUBS')GOTO4120 14628 IF(ICASEQ.EQ.'FOR')GOTO4130 14629C 14630 4110 CONTINUE 14631 DO4115I=1,N1 14632 ISUB(I)=1 14633 4115 CONTINUE 14634 NQ=N1 14635 GOTO4150 14636C 14637 4120 CONTINUE 14638 NIOLD=N1 14639 CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) 14640 NQ=NIOLD 14641 GOTO4150 14642C 14643 4130 CONTINUE 14644 NIOLD=N1 14645 CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 14646 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) 14647 NQ=NFOR 14648 GOTO4150 14649C 14650 4150 CONTINUE 14651 IF(NQ.LT.MINN2)THEN 14652 WRITE(ICOUT,999) 14653 CALL DPWRST('XXX','BUG ') 14654 WRITE(ICOUT,3011) 14655 CALL DPWRST('XXX','BUG ') 14656 WRITE(ICOUT,4152) 14657 4152 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 14658 1 'EXTRACTED,') 14659 CALL DPWRST('XXX','BUG ') 14660 WRITE(ICOUT,4153)IH11,IH12 14661 4153 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING FROM ', 14662 1 'VARIABLE ',A4,A4) 14663 CALL DPWRST('XXX','BUG ') 14664 WRITE(ICOUT,4154) 14665 4154 FORMAT(' (FOR WHICH THE SPATIAL DISTRIBUTION PLOT ') 14666 CALL DPWRST('XXX','BUG ') 14667 WRITE(ICOUT,4155)MINN2 14668 4155 FORMAT(' IS TO BE CARRIED OUT) MUST BE AT LEAST ',I8) 14669 CALL DPWRST('XXX','BUG ') 14670 WRITE(ICOUT,4157)NQ 14671 4157 FORMAT(' SUCH WAS NOT THE CASE HERE. (N = ',I8,')') 14672 CALL DPWRST('XXX','BUG ') 14673 WRITE(ICOUT,3018) 14674 CALL DPWRST('XXX','BUG ') 14675 IF(IWIDTH.GE.1)THEN 14676 WRITE(ICOUT,3019)(IANS(I),I=1,MIN(IWIDTH,80)) 14677 CALL DPWRST('XXX','BUG ') 14678 ENDIF 14679 IERROR='YES' 14680 GOTO9000 14681 ENDIF 14682C 14683 J=0 14684 IMAX=N1 14685 IF(NQ.LT.N1)IMAX=NQ 14686 DO4170I=1,IMAX 14687 IF(ISUB(I).EQ.0)GOTO4170 14688 J=J+1 14689C 14690 IJ=MAXN*(ICOL1-1)+I 14691 IF(ICOL1.LE.MAXCOL)YRESP(J)=V(IJ) 14692 IF(ICOL1.EQ.MAXCP1)YRESP(J)=PRED(I) 14693 IF(ICOL1.EQ.MAXCP2)YRESP(J)=RES(I) 14694 IF(ICOL1.EQ.MAXCP3)YRESP(J)=YPLOT(I) 14695 IF(ICOL1.EQ.MAXCP4)YRESP(J)=XPLOT(I) 14696 IF(ICOL1.EQ.MAXCP5)YRESP(J)=X2PLOT(I) 14697 IF(ICOL1.EQ.MAXCP6)YRESP(J)=TAGPLO(I) 14698C 14699 IJ=MAXN*(ICOL2-1)+I 14700 IF(ICOL2.LE.MAXCOL)ROWID(J)=V(IJ) 14701 IF(ICOL2.EQ.MAXCP1)ROWID(J)=PRED(I) 14702 IF(ICOL2.EQ.MAXCP2)ROWID(J)=RES(I) 14703 IF(ICOL2.EQ.MAXCP3)ROWID(J)=YPLOT(I) 14704 IF(ICOL2.EQ.MAXCP4)ROWID(J)=XPLOT(I) 14705 IF(ICOL2.EQ.MAXCP5)ROWID(J)=X2PLOT(I) 14706 IF(ICOL2.EQ.MAXCP6)ROWID(J)=TAGPLO(I) 14707C 14708 IJ=MAXN*(ICOL3-1)+I 14709 IF(ICOL3.LE.MAXCOL)COLID(J)=V(IJ) 14710 IF(ICOL3.EQ.MAXCP1)COLID(J)=PRED(I) 14711 IF(ICOL3.EQ.MAXCP2)COLID(J)=RES(I) 14712 IF(ICOL3.EQ.MAXCP3)COLID(J)=YPLOT(I) 14713 IF(ICOL3.EQ.MAXCP4)COLID(J)=XPLOT(I) 14714 IF(ICOL3.EQ.MAXCP5)COLID(J)=X2PLOT(I) 14715 IF(ICOL3.EQ.MAXCP6)COLID(J)=TAGPLO(I) 14716C 14717 4170 CONTINUE 14718 NS=J 14719C 14720 IF(NPART.GT.0)THEN 14721 DO4180I=1,NPART 14722 IJ=MAXN*(ICOL4-1)+I 14723 IF(ICOL4.LE.MAXCOL)PART(I)=V(IJ) 14724 IF(ICOL4.EQ.MAXCP1)PART(I)=PRED(I) 14725 IF(ICOL4.EQ.MAXCP2)PART(I)=RES(I) 14726 IF(ICOL4.EQ.MAXCP3)PART(I)=YPLOT(I) 14727 IF(ICOL4.EQ.MAXCP4)PART(I)=XPLOT(I) 14728 IF(ICOL4.EQ.MAXCP5)PART(I)=X2PLOT(I) 14729 IF(ICOL4.EQ.MAXCP6)PART(I)=TAGPLO(I) 14730 4180 CONTINUE 14731 ENDIF 14732C 14733 GOTO6000 14734C 14735 5000 CONTINUE 14736C 14737C 14738C ****************************************************** 14739C ** STEP 51-- ** 14740C ** IF ARGUMENT ONE IS A MATRIX, CHECK THAT THE ** 14741C ** INPUT NUMBER OF OBSERVATIONS (N1) FOR ARGUMENT ** 14742C ** ONE IS 16 OR MORE. ** 14743C ****************************************************** 14744C 14745 ISTEPN='51' 14746 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SDPL') 14747 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14748C 14749 IF(N1.LT.MINN2)THEN 14750 WRITE(ICOUT,999) 14751 CALL DPWRST('XXX','BUG ') 14752 WRITE(ICOUT,3011) 14753 CALL DPWRST('XXX','BUG ') 14754 WRITE(ICOUT,5022) 14755 5022 FORMAT(' THE INPUT NUMBER OF ROWS FOR THE') 14756 CALL DPWRST('XXX','BUG ') 14757 WRITE(ICOUT,5023)MINN2 14758 5023 FORMAT(' SPATIAL DISTRIBUTION PLOT MUST BE ',I8, 14759 1 ' OR LARGER.') 14760 CALL DPWRST('XXX','BUG ') 14761 WRITE(ICOUT,5025) 14762 5025 FORMAT(' SUCH WAS NOT THE CASE HERE;') 14763 CALL DPWRST('XXX','BUG ') 14764 WRITE(ICOUT,5027)IH11,IH12,N1 14765 5027 FORMAT(' MATRIX ',A4,A4,' HAS ',I8,' ROWS.') 14766 CALL DPWRST('XXX','BUG ') 14767 WRITE(ICOUT,5018) 14768 5018 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') 14769 CALL DPWRST('XXX','BUG ') 14770 IF(IWIDTH.GE.1)THEN 14771 WRITE(ICOUT,5019)(IANS(I),I=1,MIN(IWIDTH,80)) 14772 5019 FORMAT(80A1) 14773 CALL DPWRST('XXX','BUG ') 14774 ENDIF 14775 IERROR='YES' 14776 GOTO9000 14777 ENDIF 14778C 14779C 14780C ******************************************************** 14781C ** STEP 52-- ** 14782C ** CHECK IF ARGUMENT TWO IS A VARIABLE (IF IT EXISTS)** 14783C ******************************************************** 14784C 14785 ISTEPN='52' 14786 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SDPL') 14787 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14788C 14789 IH21=IHARG(2) 14790 IH22=IHARG2(2) 14791 IHWUSE='V' 14792 MESSAG='NO' 14793 CALL CHECKN(IH21,IH22,IHWUSE, 14794 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 14795 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 14796C 14797 IF(IERROR.EQ.'YES')THEN 14798 NPART=0 14799 ELSE 14800 ILISR=ILOCV 14801 ICOL21=IVALUE(ILISR) 14802 NPART=IN(ILISR) 14803 ENDIF 14804C 14805C ***************************************** 14806C ** STEP 56-- ** 14807C ** CHECK TO SEE THE TYPE CASE-- ** 14808C ** 1) UNQUALIFIED (THAT IS, FULL); ** 14809C ** 2) SUBSET/EXCEPT; OR ** 14810C ** 3) FOR. ** 14811C ***************************************** 14812C 14813 ISTEPN='56' 14814 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SDPL') 14815 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14816C 14817 ICASEQ='FULL' 14818 ILOCQ=NUMARG+1 14819 IF(NUMARG.LT.1)GOTO5609 14820 DO5600J=1,NUMARG 14821 J1=J 14822 IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO5601 14823 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO5601 14824 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO5602 14825 5600 CONTINUE 14826 GOTO5609 14827 5601 CONTINUE 14828 ICASEQ='SUBS' 14829 ILOCQ=J1 14830 GOTO5609 14831 5602 CONTINUE 14832 ICASEQ='FOR' 14833 ILOCQ=J1 14834 GOTO5609 14835 5609 CONTINUE 14836C 14837 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SDPL')THEN 14838 WRITE(ICOUT,5038)NUMARG,ILOCQ 14839 5038 FORMAT('NUMARG,ILOCQ = ',2I8) 14840 CALL DPWRST('XXX','BUG ') 14841 ENDIF 14842C 14843C *********************************************** 14844C ** STEP 56B-- ** 14845C ** TEMPORARILY FORM THE VARIABLE Y(.) ** 14846C ** WHICH WILL HOLD THE DATA FROM SAMPLE 1. ** 14847C ** FORM THIS VARIABLE BY ** 14848C ** BRANCHING TO THE APPROPRIATE SUBCASE ** 14849C ** (FULL, SUBSET, OR FOR). ** 14850C *********************************************** 14851C 14852 ISTEPN='56B' 14853 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SDPL') 14854 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14855C 14856 IF(ICASEQ.EQ.'FULL')GOTO5610 14857 IF(ICASEQ.EQ.'SUBS')GOTO5620 14858 IF(ICASEQ.EQ.'FOR')GOTO5630 14859C 14860 5610 CONTINUE 14861 DO5615I=1,N1 14862 ISUB(I)=1 14863 5615 CONTINUE 14864 NQ=N1 14865 GOTO5650 14866C 14867 5620 CONTINUE 14868 NIOLD=N1 14869 CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) 14870 NQ=NIOLD 14871 GOTO5650 14872C 14873 5630 CONTINUE 14874 NIOLD=N1 14875 CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 14876 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) 14877 NQ=NFOR 14878 GOTO5650 14879C 14880 5650 CONTINUE 14881 IF(NQ.LT.MINN2)THEN 14882 WRITE(ICOUT,999) 14883 CALL DPWRST('XXX','BUG ') 14884 WRITE(ICOUT,5651) 14885 5651 FORMAT('***** ERROR IN THE SPATIAL DISTRIBUTION PLOT--') 14886 CALL DPWRST('XXX','BUG ') 14887 WRITE(ICOUT,5652) 14888 5652 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 14889 1 'EXTRACTED,') 14890 CALL DPWRST('XXX','BUG ') 14891 WRITE(ICOUT,5653)IH11,IH12 14892 5653 FORMAT(' THE NUMBER OF ROWS REMAINING FROM MATRIX ', 14893 1 A4,A4) 14894 CALL DPWRST('XXX','BUG ') 14895 WRITE(ICOUT,5654) 14896 5654 FORMAT(' (FOR WHICH THE SPATIAL DISTRIBUTION PLOT IS ', 14897 1 'TO BE CARRIED') 14898 CALL DPWRST('XXX','BUG ') 14899 WRITE(ICOUT,5655)MINN2 14900 5655 FORMAT(' OUT) MUST BE AT LEAST ',I8,'.') 14901 CALL DPWRST('XXX','BUG ') 14902 WRITE(ICOUT,5657)NQ 14903 5657 FORMAT(' SUCH WAS NOT THE CASE HERE. (NROWS = ',I8,')') 14904 CALL DPWRST('XXX','BUG ') 14905 WRITE(ICOUT,3018) 14906 CALL DPWRST('XXX','BUG ') 14907 IF(IWIDTH.GE.1)THEN 14908 WRITE(ICOUT,5019)(IANS(I),I=1,MIN(IWIDTH,80)) 14909 CALL DPWRST('XXX','BUG ') 14910 ENDIF 14911 IERROR='YES' 14912 GOTO9000 14913 ENDIF 14914C 14915 ICASE='MATR' 14916C 14917 NLOOP=NCOL 14918 IF(NLOOP.LT.1)NLOOP=1 14919 IMAX=N1 14920 IF(NQ.LT.N1)IMAX=NQ 14921C 14922 NCOL=0 14923 J=0 14924 DO5671JLOOP=1,NLOOP 14925 NCOL=NCOL+1 14926 NROW=0 14927 DO5670I=1,IMAX 14928 IF(ISUB(I).EQ.0)GOTO5670 14929 NROW=NROW+1 14930 J=J+1 14931 ICOLT=ICOL1+JLOOP-1 14932 IJ=MAXN*(ICOLT-1)+I 14933C 14934 IF(ICOLT.LE.MAXCOL)YRESP(J)=V(IJ) 14935 IF(ICOLT.EQ.MAXCP1)YRESP(J)=PRED(I) 14936 IF(ICOLT.EQ.MAXCP2)YRESP(J)=RES(I) 14937 IF(ICOLT.EQ.MAXCP3)YRESP(J)=YPLOT(I) 14938 IF(ICOLT.EQ.MAXCP4)YRESP(J)=XPLOT(I) 14939 IF(ICOLT.EQ.MAXCP5)YRESP(J)=X2PLOT(I) 14940 IF(ICOLT.EQ.MAXCP6)YRESP(J)=TAGPLO(I) 14941 ROWID(J)=REAL(NROW) 14942 COLID(J)=REAL(NCOL) 14943C 14944 5670 CONTINUE 14945 5671 CONTINUE 14946C 14947 NS=J 14948C 14949 IF(NPART.GT.0)THEN 14950 DO5680I=1,NPART 14951 IJ=MAXN*(ICOL2-1)+I 14952 IF(ICOL2.LE.MAXCOL)PART(I)=V(IJ) 14953 IF(ICOL2.EQ.MAXCP1)PART(I)=PRED(I) 14954 IF(ICOL2.EQ.MAXCP2)PART(I)=RES(I) 14955 IF(ICOL2.EQ.MAXCP3)PART(I)=YPLOT(I) 14956 IF(ICOL2.EQ.MAXCP4)PART(I)=XPLOT(I) 14957 IF(ICOL2.EQ.MAXCP5)PART(I)=X2PLOT(I) 14958 IF(ICOL2.EQ.MAXCP6)PART(I)=TAGPLO(I) 14959 5680 CONTINUE 14960 ENDIF 14961C 14962 GOTO6000 14963C 14964 6000 CONTINUE 14965C 14966C ******************************************************** 14967C ** STEP 61-- * 14968C ** FORM THE VERTICAL AND HORIZONTAL AXIS VARIABLES * 14969C ** (Y(.) AND X(.), RESPECTIVELY) FOR THE PLOT. * 14970C ** FORM THE CURVE DESIGNATION VARIABLE D(.) . * 14971C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). * 14972C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). * 14973C ******************************************************** 14974C 14975 ISTEPN='61' 14976 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SDPL') 14977 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14978C 14979 IHP ='THRE' 14980 IHP2='SHOL' 14981 IHWUSE='P' 14982 MESSAG='NO' 14983 CALL CHECKN(IHP,IHP2,IHWUSE, 14984 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 14985 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 14986 IF(IERROR.EQ.'YES')THEN 14987 THRESH=CPUMIN 14988 ELSE 14989 THRESH=VALUE(ILOCP) 14990 ENDIF 14991C 14992 CALL DPSDP2(YRESP,ROWID,COLID,NS,PART,NPART, 14993 1THRESH, 14994 1TEMP1,TEMP2,TEMP3,TEMP4,MAXOBV, 14995 1Y,X,D,NPLOTP,NPLOTV, 14996 1IBUGG3,ISUBRO,IERROR) 14997C 14998C ***************** 14999C ** STEP 90-- ** 15000C ** EXIT ** 15001C ***************** 15002C 15003 9000 CONTINUE 15004 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SDPL')THEN 15005 WRITE(ICOUT,999) 15006 CALL DPWRST('XXX','BUG ') 15007 WRITE(ICOUT,9011) 15008 9011 FORMAT('***** AT THE END OF DPSDPL--') 15009 CALL DPWRST('XXX','BUG ') 15010 WRITE(ICOUT,9012)IFOUND,IERROR 15011 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 15012 CALL DPWRST('XXX','BUG ') 15013 WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 15014 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 15015 1 I8,I8,I8,2X,A4,2X,A4,2X,A4) 15016 CALL DPWRST('XXX','BUG ') 15017 WRITE(ICOUT,9014)ICASPL,MAXN 15018 9014 FORMAT('ICASPL,MAXN = ',A4,I8) 15019 CALL DPWRST('XXX','BUG ') 15020 IF(NPLOTP.GE.1)THEN 15021 DO9020I=1,MIN(NPLOTP,200) 15022 WRITE(ICOUT,9021)I,Y(I),X(I),D(I) 15023 9021 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) 15024 CALL DPWRST('XXX','BUG ') 15025 9020 CONTINUE 15026 ENDIF 15027 ENDIF 15028C 15029 RETURN 15030 END 15031 SUBROUTINE DPSDP2(Y,ROWID,COLID,N,PART,NPART, 15032 1THRESH, 15033 1TEMP1,TEMP2,TEMP3,TEMP4,MAXOBV, 15034 1Y2,X2,D2,NPLOTP,NPLOTV, 15035 1IBUGG3,ISUBRO,IERROR) 15036C 15037C PURPOSE--FORM A SPATIAL DISTRIBUTION PLOT. 15038C EXAMPLE--SPATIAL DISTRIBUTION PLOT Y ROWID COLID PART 15039C WRITTEN BY--JAMES J. FILLIBEN 15040C STATISTICAL ENGINEERING DIVISION 15041C INFORMATION TECHNOLOGY LABORATORY 15042C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 15043C GAITHERSBURG, MD 20899-8980 15044C PHONE--301-975-2899 15045C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 15046C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 15047C LANGUAGE--ANSI FORTRAN (1977) 15048C VERSION NUMBER--2008/4 15049C ORIGINAL VERSION--APRIL 2008. 15050C 15051C-----COMMON---------------------------------------------------------- 15052C 15053C--------------------------------------------------------------------- 15054C 15055 CHARACTER*4 IBUGG3 15056 CHARACTER*4 ISUBRO 15057 CHARACTER*4 IERROR 15058C 15059 CHARACTER*4 ISTEPN 15060 CHARACTER*4 ISUBN1 15061 CHARACTER*4 ISUBN2 15062 CHARACTER*4 IWRITE 15063 CHARACTER*4 IRELAT 15064 CHARACTER*4 IRHSTG 15065C 15066 DIMENSION Y(*) 15067 DIMENSION ROWID(*) 15068 DIMENSION COLID(*) 15069 DIMENSION PART(*) 15070 DIMENSION Y2(*) 15071 DIMENSION X2(*) 15072 DIMENSION D2(*) 15073 DIMENSION TEMP1(*) 15074 DIMENSION TEMP2(*) 15075 DIMENSION TEMP3(*) 15076 DIMENSION TEMP4(*) 15077C 15078 DOUBLE PRECISION DTERM1 15079 DOUBLE PRECISION DTERM2 15080 DOUBLE PRECISION DTERM3 15081 DOUBLE PRECISION DLNGAM 15082 DOUBLE PRECISION DBINLN 15083C 15084 EXTERNAL DLNGAM 15085 EXTERNAL DBINLN 15086C 15087C--------------------------------------------------------------------- 15088C 15089 INCLUDE 'DPCOP2.INC' 15090C 15091C-----START POINT----------------------------------------------------- 15092C 15093C 15094 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'SDP2')THEN 15095 WRITE(ICOUT,999) 15096 999 FORMAT(1X) 15097 CALL DPWRST('XXX','BUG ') 15098 WRITE(ICOUT,51) 15099 51 FORMAT('***** AT THE BEGINNING OF DPSDP2--') 15100 CALL DPWRST('XXX','BUG ') 15101 WRITE(ICOUT,52)IBUGG3,ISUBRO,N,NPART 15102 52 FORMAT('IBUGG3,ISUBRO,N,NPART = ',A4,2X,A4,2X,I8,2X,I8) 15103 CALL DPWRST('XXX','BUG ') 15104 DO55I=1,MIN(N,100) 15105 WRITE(ICOUT,56)I,Y(I),ROWID(I),COLID(I) 15106 56 FORMAT('I,Y(I),ROWID(I),COLID(I) = ',I8,3G12.4) 15107 CALL DPWRST('XXX','BUG ') 15108 55 CONTINUE 15109 IF(NPART.GT.0)THEN 15110 DO58I=1,MIN(NPART,100) 15111 WRITE(ICOUT,59)I,PART(I) 15112 59 FORMAT('I,PART(I) = ',I8,G12.4) 15113 CALL DPWRST('XXX','BUG ') 15114 58 CONTINUE 15115 ENDIF 15116 ENDIF 15117C 15118C ******************************************************* 15119C ** STEP 1-- ** 15120C ** CHECK INPUT ARRAYS FOR ERRORS ** 15121C ******************************************************* 15122C 15123 ISTEPN='1' 15124 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'SDP2') 15125 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 15126C 15127C STEP 1A: RESPONSE ARRAY SHOULD BE EITHER 0/1 OR 15128C THERE SHOULD BE A USER-DEFINED THRESHOLD 15129C TO CREATE 0/1 ARRAY. 15130C 15131 IWRITE='OFF' 15132 CALL DISTIN(Y,N,IWRITE,TEMP1,NDIST,IBUGG3,IERROR) 15133 IF(NDIST.EQ.2)THEN 15134 AVAL1=TEMP1(1) 15135 AVAL2=TEMP1(2) 15136 ALOW=MIN(AVAL1,AVAL2) 15137 AHIGH=MAX(AVAL1,AVAL2) 15138 DO110I=1,N 15139 IF(Y(I).EQ.ALOW)THEN 15140 Y(I)=0.0 15141 ELSE 15142 Y(I)=1.0 15143 ENDIF 15144 110 CONTINUE 15145 ELSE 15146 IF(THRESH.NE.CPUMIN)THEN 15147 DO210I=1,N 15148 IF(Y(I).LE.THRESH)THEN 15149 Y(I)=0.0 15150 ELSE 15151 Y(I)=1.0 15152 ENDIF 15153 210 CONTINUE 15154 ELSE 15155 WRITE(ICOUT,999) 15156 CALL DPWRST('XXX','BUG ') 15157 WRITE(ICOUT,260) 15158 260 FORMAT('***** ERROR IN SPATIAL DISTRIBUTION PLOT--') 15159 CALL DPWRST('XXX','BUG ') 15160 WRITE(ICOUT,261) 15161 261 FORMAT(' THERE ARE MORE THAN TWO DISTINCT VALUES FOUND') 15162 CALL DPWRST('XXX','BUG ') 15163 WRITE(ICOUT,263) 15164 263 FORMAT(' IN THE RESPONSE VARIABLE, BUT NO THRESHOLD ', 15165 1 'WAS SPECIFIED.') 15166 CALL DPWRST('XXX','BUG ') 15167 IERROR='YES' 15168 GOTO9000 15169 ENDIF 15170 ENDIF 15171C 15172C STEP 1B: CHECK THAT THE NUMBER OR ROWS TIMES THE NUMBER OF 15173C COLUMNS EQUALS THE NUMBER OF RESPONSE VALUES. ALSO 15174C CODE THE ROWID AND COLID TO 1, 2, ..., <NROW/NCOL>. 15175C 15176 CALL CODE(ROWID,N,IWRITE,TEMP1,TEMP2,MAXOBV,IBUGG3,IERROR) 15177 DO310I=1,N 15178 ROWID(I)=TEMP1(I) 15179 310 CONTINUE 15180 CALL DISTIN(ROWID,N,IWRITE,TEMP1,NROWS,IBUGG3,IERROR) 15181C 15182 CALL CODE(COLID,N,IWRITE,TEMP1,TEMP2,MAXOBV,IBUGG3,IERROR) 15183 DO320I=1,N 15184 COLID(I)=TEMP1(I) 15185 320 CONTINUE 15186 CALL DISTIN(COLID,N,IWRITE,TEMP1,NCOLS,IBUGG3,IERROR) 15187C 15188 IF(NROWS*NCOLS.NE.N)THEN 15189 WRITE(ICOUT,999) 15190 CALL DPWRST('XXX','BUG ') 15191 WRITE(ICOUT,260) 15192 CALL DPWRST('XXX','BUG ') 15193 WRITE(ICOUT,361) 15194 361 FORMAT(' THE NUMBER OF ROWS TIMES THE NUMBER OF ', 15195 1 'COLUMNS') 15196 CALL DPWRST('XXX','BUG ') 15197 WRITE(ICOUT,363) 15198 363 FORMAT(' WAS NOT EQUAL TO THE TOTAL NUMBER OF VALUES.') 15199 CALL DPWRST('XXX','BUG ') 15200 IERROR='YES' 15201 GOTO9000 15202 ENDIF 15203C 15204C STEP 1C: DEFINE THE PARTITIONING. 15205C 15206C FOR THIS PLOT TO MAKE SENSE, THERE MUST BE AT 15207C LEAST TWO PARTITIONS, SO THE MINIMUM OF THE 15208C NUMBER OF ROWS AND NUMBER OF COLUMNS MUST BE 15209C AT LEAST 16. 15210C 15211 NMIN=MIN(NROWS,NCOLS) 15212 IF(NMIN.LT.16)THEN 15213 WRITE(ICOUT,999) 15214 CALL DPWRST('XXX','BUG ') 15215 WRITE(ICOUT,260) 15216 CALL DPWRST('XXX','BUG ') 15217 WRITE(ICOUT,401) 15218 401 FORMAT(' THE MINIMUM OF THE NUMBER OF ROWS AND THE ', 15219 1 'NUMBER OF COLUMNS') 15220 CALL DPWRST('XXX','BUG ') 15221 WRITE(ICOUT,403) 15222 403 FORMAT(' IS LESS THAN 16.') 15223 CALL DPWRST('XXX','BUG ') 15224 IERROR='YES' 15225 GOTO9000 15226 ENDIF 15227C 15228C IF THE USER DID NOT SPECIFY A PARTITION, THEN 15229C CREATE ONE. THE MINIMUM PARTITION WILL BE 8x8 15230C AND THE MAXIMUM PARTITION WILL BE N/8. 15231C 15232 IF(NPART.EQ.0)THEN 15233 NSTART=8 15234 NLAST=N/8 15235 DO510I=NSTART,NLAST 15236 PART(I)=REAL(I) 15237 510 CONTINUE 15238 ELSE 15239 CALL SORT(PART,NPART,PART) 15240 NLOW=4 15241 NHIGH=N/4 15242 ICNT=0 15243 DO520I=1,NPART 15244 NTEMP=INT(PART(I) + 0.01) 15245 IF(NTEMP.GE.NLOW .AND. NTEMP.LE.NHIGH)THEN 15246 ICNT=ICNT+1 15247 PART(ICNT)=REAL(NTEMP) 15248 ENDIF 15249 520 CONTINUE 15250 IF(ICNT.LT.2)THEN 15251 NSTART=8 15252 NLAST=N/8 15253 ICNT=0 15254 DO530I=NSTART,NLAST 15255 ICNT=ICNT+1 15256 PART(ICNT)=REAL(I) 15257 530 CONTINUE 15258 NPART=ICNT 15259 ELSE 15260 NPART=ICNT 15261 ENDIF 15262 ENDIF 15263C 15264C ******************************************************* 15265C ** STEP 2-- ** 15266C ** NOW LOOP OVER THE PARTITIONS ** 15267C ******************************************************* 15268C 15269 ISTEPN='2' 15270 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'SDP2') 15271 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 15272C 15273 ICNT=0 15274 ICNT2=0 15275 ICNT3=0 15276 ICNT4=0 15277C 15278 DO1000IPART=1,NPART 15279 APART=PART(IPART) 15280 ISIZE=INT(PART(INT(IPART + 0.01))) 15281 NHOR=NROWS/ISIZE 15282 NVERT=NCOLS/ISIZE 15283 ICNT2=0 15284C 15285 IF(IFEEDB.EQ.'ON')THEN 15286 WRITE(ICOUT,1003)INT(APART+0.01) 15287 1003 FORMAT('PROCESSING PARTITION SIZE ',I8,' ...') 15288 CALL DPWRST('XXX','BUG ') 15289 ENDIF 15290C 15291 DO1010IROW=1,NHOR 15292 IROW1=(IROW-1)*ISIZE + 1 15293 IROW2=IROW*ISIZE 15294 DO1020ICOL=1,NVERT 15295 ICOL1=(ICOL-1)*ISIZE + 1 15296 ICOL2=ICOL*ISIZE 15297 SUM1=0.0 15298 ICNT=0 15299C 15300 DO1030I=1,N 15301 IROWC=INT(ROWID(I)+0.01) 15302 ICOLC=INT(COLID(I)+0.01) 15303 IF((IROWC.GE.IROW1 .AND. IROWC.LE.IROW2) .AND. 15304 1 (ICOLC.GE.ICOL1 .AND. ICOLC.LE.ICOL2))THEN 15305 ICNT=ICNT+1 15306 SUM1=SUM1 + Y(I) 15307 ENDIF 15308 1030 CONTINUE 15309 IF(ICNT.NE.ISIZE*ISIZE)THEN 15310 WRITE(ICOUT,999) 15311 CALL DPWRST('XXX','BUG ') 15312 WRITE(ICOUT,260) 15313 CALL DPWRST('XXX','BUG ') 15314 WRITE(ICOUT,1031)IROW,ICOL 15315 1031 FORMAT(' FOR PARTITION: ROW = ',I8,' COLUM = ',I8) 15316 CALL DPWRST('XXX','BUG ') 15317 WRITE(ICOUT,1033)ISIZE*ISIZE 15318 1033 FORMAT(' THE EXPECTED NUMBER OF VALUES = ',I8) 15319 CALL DPWRST('XXX','BUG ') 15320 WRITE(ICOUT,1035)ICNT 15321 1035 FORMAT(' THE NUMBER OF VALUES FOUND = ',I8) 15322 CALL DPWRST('XXX','BUG ') 15323 IERROR='YES' 15324 GOTO9000 15325 ENDIF 15326 ICNT2=ICNT2+1 15327 TEMP1(ICNT2)=SUM1 15328C 15329 1020 CONTINUE 15330 1010 CONTINUE 15331C 15332C NOW FIT DISCRETE UNIFORM, POISSON, AND NEGATIVE BINOMIAL 15333C TO THE ARRAY OF SUMS. 15334C 15335C DISCRETE UNIFORM PROBABILITY PLOT 15336C 15337 CALL MEAN(TEMP1,ICNT2,IWRITE,XMEAN,IBUGG3,IERROR) 15338 CALL SD(TEMP1,ICNT2,IWRITE,XSD,IBUGG3,IERROR) 15339 CALL SORT(TEMP1,ICNT2,TEMP1) 15340 XMIN=TEMP1(1) 15341 XMAX=TEMP1(ICNT2) 15342 NDUN=INT(XMAX+0.01) 15343 CALL UNIMED(ICNT2,TEMP2) 15344C 15345 DO2010I=1,ICNT2 15346 CALL DISPPF(TEMP2(I),NDUN,X2OUT) 15347 TEMP2(I)=X2OUT 15348 2010 CONTINUE 15349 CALL CORR(TEMP2,TEMP1,ICNT2,IWRITE,PPCC,IBUGG3,IERROR) 15350 ICNT4=ICNT4+1 15351 X2(ICNT4)=APART 15352 Y2(ICNT4)=PPCC 15353 D2(ICNT4)=1.0 15354C 15355C BIN THE DATA AND REMOVE ZERO-FREQUENCY CLASSES 15356C 15357 IRELAT='OFF' 15358 IRHSTG='OFF' 15359 XMIN=TEMP1(1) 15360 XMAX=TEMP1(ICNT2) 15361 XSTART=XMIN-0.5 15362 XSTOP=XMAX+0.5 15363 CLWID=1.0 15364 CALL DPBINI(TEMP1,ICNT2,IRELAT,CLWID,XSTART,XSTOP,IRHSTG, 15365 1 TEMP4,TEMP3,N2,IBUGG3,IERROR) 15366 IF(IERROR.EQ.'YES')GOTO9000 15367 NTOT=ICNT2 15368 ICNT3=0 15369 DO2101I=1,N2 15370 IF(INT(TEMP4(I)+0.01).GT.0)THEN 15371 ICNT3=ICNT3+1 15372 TEMP2(ICNT3)=TEMP4(I) 15373 TEMP1(ICNT3)=TEMP3(I) 15374 ENDIF 153752101 CONTINUE 15376 N2=ICNT3 15377C 15378C POISSON PLOT 15379C 15380 ICNT3=0 15381 DTERM1=DLOG(DBLE(NTOT)) 15382 DO2200I=1,N2 15383 AK=TEMP1(I) 15384 IK=INT(AK+0.1) 15385 ANK=TEMP2(I) 15386 IF(ANK.GT.0.0)THEN 15387 ICNT3=ICNT3+1 15388 DTERM2=DLOG(DBLE(ANK)) 15389 IF(IK.EQ.0 .OR. IK.EQ.1)THEN 15390 DTERM3=DLOG(1.0D0) 15391 ELSEIF(IK.EQ.2)THEN 15392 DTERM3=DLOG(2.0D0) 15393 ELSE 15394 DTERM3=DLNGAM(DBLE(AK+1.0)) 15395 ENDIF 15396 TEMP4(ICNT3)=REAL(DTERM2 + DTERM3 - DTERM1) 15397 TEMP3(ICNT3)=AK 15398 ENDIF 15399C 15400 2200 CONTINUE 15401 NTEMP=ICNT3 15402 CALL CORR(TEMP4,TEMP3,NTEMP,IWRITE,PPCC,IBUGG3,IERROR) 15403 ICNT4=ICNT4+1 15404 X2(ICNT4)=APART 15405 Y2(ICNT4)=PPCC 15406 D2(ICNT4)=2.0 15407C 15408C NEGATIVE BINOMIAL PLOT 15409C 15410 AKNB=XMEAN**2/(XSD**2 - XMEAN) 15411 ICNT3=0 15412 DTERM1=DLOG(DBLE(NTOT)) 15413 DO2300I=1,N2 15414 AK=TEMP1(I) 15415 IK=INT(AK+0.1) 15416 ANK=TEMP2(I) 15417 INK=INT(ANK+0.1) 15418 IF(ANK.GT.0.0)THEN 15419 ICNT3=ICNT3+1 15420 DTERM2=DLOG(DBLE(ANK)) 15421 ITEMP1=INT(AKNB+0.5)+IK-1 15422 ITEMP2=IK 15423 DTERM3=DBINLN(ITEMP1,ITEMP2) 15424 TEMP4(ICNT3)=REAL(DTERM2 - DTERM1 - DTERM3) 15425C 15426 TEMP3(ICNT3)=AK 15427 ENDIF 15428C 15429 2300 CONTINUE 15430 NTEMP=ICNT3 15431 CALL CORR(TEMP4,TEMP3,NTEMP,IWRITE,PPCC,IBUGG3,IERROR) 15432 ICNT4=ICNT4+1 15433 X2(ICNT4)=APART 15434 Y2(ICNT4)=PPCC 15435 D2(ICNT4)=3.0 15436C 15437 1000 CONTINUE 15438C 15439 NPLOTP=ICNT4 15440 NPLOTV=2 15441C 15442C ***************** 15443C ** STEP 90-- ** 15444C ** EXIT ** 15445C ***************** 15446C 15447 9000 CONTINUE 15448 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'SDP2')THEN 15449 WRITE(ICOUT,999) 15450 CALL DPWRST('XXX','BUG ') 15451 WRITE(ICOUT,9011) 15452 9011 FORMAT('***** AT THE END OF DPSDP2--') 15453 CALL DPWRST('XXX','BUG ') 15454 WRITE(ICOUT,9012)IBUGG3,ISUBRO 15455 9012 FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4) 15456 CALL DPWRST('XXX','BUG ') 15457 WRITE(ICOUT,9013)NPLOTP,NPLOTV 15458 9013 FORMAT('NPLOTP,NPLOTV = ',2I8) 15459 CALL DPWRST('XXX','BUG ') 15460 IF(NPLOTP.GE.1)THEN 15461 DO9015I=1,MIN(200,NPLOTP) 15462 WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I) 15463 9016 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,3F10.5) 15464 CALL DPWRST('XXX','BUG ') 15465 9015 CONTINUE 15466 ENDIF 15467 ENDIF 15468C 15469 RETURN 15470 END 15471 SUBROUTINE DPSDR3(Y,N,ICASA2,ICASA4,MAXNXT, 15472 1 TEMP1,AKURT,N0,IBONAD, 15473 1 YSD, 15474 1 ALPHA,NALPHA,ALOWLM,AUPPLM, 15475 1 ISUBRO,IBUGA3,IERROR) 15476C 15477C PURPOSE--THIS SUBROUTINE COMPUTES CONFIDENCE LIMITS FOR THE 15478C STANDARD DEVIATION ASSUMING A NON-NORMAL DISTRIBUTION 15479C 15480C THE FOLLOWING CASES ARE SUPPORTED: 15481C 15482C LET A = LOWER ROBUST SD CONFIDENCE LIMIT Y 15483C LET A = UPPER ROBUST SD CONFIDENCE LIMIT Y 15484C LET A = ONE SIDED LOWER ROBUST SD CONFIDENCE INTERVAL Y 15485C LET A = ONE SIDED UPPER ROBUST SD CONFIDENCE INTERVAL Y 15486C 15487C THE DATA CONSISTS OF N OBSERVATIONS IN Y. 15488C 15489C THE METHOD HERE IS FROM THE BONETT PAPER. THIS INTERVAL 15490C PROVIDES A NEARLY EXACT INTERVAL FOR NORMALLY DISTRIBUTED 15491C DATA, BUT ALSO PROVIDES GOOD PERFORMANCE FOR MODERATE 15492C NON-NORMALITY. 15493C 15494C THE INTERVAL FOR THE VARIANCE IS 15495C 15496C EXP{LOG(C*SIGMAHAT**2) +/- Z(ALPHA/2)*SE} 15497C 15498C WHERE 15499C 15500C SIGMAHAT = SAMPLE STANDARD DEVIATION 15501C Z = NORMAL PERCENT POINT FUNCTION 15502C SE = C*SQRT[{GAMMA4HAT - (N-3)/N}/(N-1)] 15503C C = N/(N - Z(ALPHA/2)) 15504C GAMMA4HAT = AN ADJUSTED ESTIMATE OF KURTOSIS 15505C (SEE BELOW FOR DETAILS) 15506C 15507C C IS A SMALL SAMPLE ADJUSTMENT FACTOR TO EQUALIZE TAIL 15508C PROBABILITIES. 15509C 15510C FOR THE STANDARD DEVIATION, TAKE THE SQUARE ROOT OF THE 15511C ABOVE INTERVAL. 15512C 15513C NIWITPONG AND KIRDWICHAI ADJUST THIS STATISTIC BY 15514C USING THE MEDIAN RATHER THAN THE TRIMMED MEAN TO 15515C COMPUTE THE ADJUSTED KURTOSIS AND THEY ALSO USE 15516C t-INTERVALS RATHER THAN THE NORMAL INTERVALS. THESE 15517C ADJUSTMENTS RESULT IN A MORE CONSERVATIVE INTERVAL, 15518C BUT ONES THAT ARE MORE LIKELY TO MEET THE NOMINAL 15519C COVERAGE IN MORE EXTREME CASES OF NON-NORMALITY. 15520C 15521C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR OF 15522C (UNSORTED OR SORTED) OBSERVATIONS. 15523C --N = THE INTEGER NUMBER OF OBSERVATIONS 15524C IN THE VECTOR Y. 15525C --ALPHA = THE SINGLE PRECISION VECTOR OF CONFIDENCE 15526C LEVELS 15527C --NALPHA = THE INTEGER NUMBER OF ALPHA VALUES 15528C --AKURT = PRIOR ESTIMATE OF KURTOSIS 15529C OUTPUT ARGUMENTS-ALOWLM = THE SINGLE PRECISION VECTOR OF LOWER LIMIT 15530C VALUES 15531C -AUPPLM = THE SINGLE PRECISION VECTOR OF UPPER LIMIT 15532C VALUES 15533C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 15534C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. 15535C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 15536C LANGUAGE--ANSI FORTRAN. 15537C REFERENCES--BONETT (2006), "APPROXIMATE CONFIDENCE INTERVAL FOR 15538C STANDARD DEVIATION OF NONNORMAL DISTRIBUTIONS", 15539C COMPUTATIONAL STATISTICS AND DATA ANALYSIS, 15540C VOL. 50, PP. 775 - 782. 15541C --NIWITPONG AND KIRDWICHAI (2008), "ADJUSTED BONETT 15542C CONFIDENCE INTERVAL FOR STANDARD DEVIATION OF 15543C NON-NORMAL DISTRIBUTIONS", THAILAND STATISTICIAN, 15544C VOL. 6, NO. 1, PP. 1-6. 15545C WRITTEN BY--ALAN HECKERT 15546C STATISTICAL ENGINEERING LABORATORY 15547C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 15548C GAITHERSBURG, MD 20899-8980 15549C PHONE--301-975-2899 15550C ORIGINAL VERSION--DECEMBER 2017. 15551C 15552C--------------------------------------------------------------------- 15553C 15554 DIMENSION Y(*) 15555 DIMENSION TEMP1(*) 15556 DIMENSION ALOWLM(*) 15557 DIMENSION AUPPLM(*) 15558 DIMENSION ALPHA(*) 15559C 15560 CHARACTER*4 IBONAD 15561 CHARACTER*4 ICASA2 15562 CHARACTER*4 ICASA4 15563 CHARACTER*4 ISUBRO 15564 CHARACTER*4 IBUGA3 15565 CHARACTER*4 IERROR 15566C 15567 DOUBLE PRECISION DSUM1 15568 DOUBLE PRECISION DSUM2 15569 DOUBLE PRECISION DTERM1 15570C 15571 CHARACTER*4 IWRITE 15572 CHARACTER*4 ISUBN1 15573 CHARACTER*4 ISUBN2 15574 CHARACTER*4 ISTEPN 15575C 15576C-----COMMON---------------------------------------------------------- 15577C 15578 INCLUDE 'DPCOP2.INC' 15579C 15580C-----START POINT----------------------------------------------------- 15581C 15582 ISUBN1='SDR3' 15583 ISUBN2=' ' 15584 IWRITE='OFF' 15585 IERROR='NO' 15586C 15587 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SDR3')THEN 15588 WRITE(ICOUT,999) 15589 999 FORMAT(1X) 15590 CALL DPWRST('XXX','WRIT') 15591 WRITE(ICOUT,51) 15592 51 FORMAT('**** AT THE BEGINNING OF DPSDR3--') 15593 CALL DPWRST('XXX','WRIT') 15594 WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASA2,ICASA3,ICASA4 15595 52 FORMAT('IBUGA3,ISUBRO,ICASA2,ICASA3,ICASA4 = ', 15596 1 4(A4,2X),A4) 15597 CALL DPWRST('XXX','WRIT') 15598 WRITE(ICOUT,53)N,NALPHA,ALPHA(1) 15599 53 FORMAT('N,NALPHA,ALPHA(1) = ',2I8,G15.7) 15600 CALL DPWRST('XXX','WRIT') 15601 WRITE(ICOUT,54)AKURT,N0,IBONAD 15602 54 FORMAT('AKURT,N0,IBONAD = ',G15.7,I8,2X,A4) 15603 CALL DPWRST('XXX','WRIT') 15604 DO56I=1,N 15605 WRITE(ICOUT,57)I,Y(I) 15606 57 FORMAT('I,Y(I) = ',I8,G15.7) 15607 CALL DPWRST('XXX','WRIT') 15608 56 CONTINUE 15609 DO76I=1,NALPHA 15610 WRITE(ICOUT,77)I,ALPHA(I) 15611 77 FORMAT('I,ALPHA(I) = ',I8,G15.7) 15612 CALL DPWRST('XXX','WRIT') 15613 76 CONTINUE 15614 ENDIF 15615C 15616C ******************************************** 15617C ** STEP 11-- ** 15618C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 15619C ******************************************** 15620C 15621 ISTEPN='11' 15622 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SDR3') 15623 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 15624C 15625 IF(N.LT.5)THEN 15626 WRITE(ICOUT,999) 15627 CALL DPWRST('XXX','WRIT') 15628 WRITE(ICOUT,101) 15629 101 FORMAT('***** ERROR: ROBUST STANDARD DEVIATION CONFIDENCE ', 15630 1 'LIMITS--') 15631 CALL DPWRST('XXX','WRIT') 15632 WRITE(ICOUT,102) 15633 102 FORMAT(' THE NUMBER OF ORIGINAL OBSERVATIONS IS LESS ', 15634 1 'THAN FIVE.') 15635 CALL DPWRST('XXX','WRIT') 15636 WRITE(ICOUT,103)N 15637 103 FORMAT(' SAMPLE SIZE = ',I8) 15638 CALL DPWRST('XXX','WRIT') 15639 IERROR='YES' 15640 GOTO9000 15641 ENDIF 15642C 15643C ******************************************** 15644C ** STEP 21-- ** 15645C ** CARRY OUT CALCULATIONS FOR SD ** 15646C ** CONFIDENCE LIMITS. ** 15647C ******************************************** 15648C 15649 ISTEPN='21' 15650 IF(IBUGA3.EQ.'ON'.AND.ISUBRO.EQ.'SDR3') 15651 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 15652C 15653C ICASA2: LOWE => LOWER LIMIT 15654C UPPE => UPPER LIMIT 15655C ICASA4: ONES => ONE-SIDED LIMIT 15656C TWOS => TWO-SIDED LIMIT 15657C 15658C COMPUTE STANDARD DEVIATION 15659C 15660 DO210I=1,NALPHA 15661 ALOWLM(I)=CPUMIN 15662 AUPPLM(I)=CPUMIN 15663 210 CONTINUE 15664C 15665 CALL SORT(Y,N,Y) 15666 CALL MEAN(Y,N,IWRITE,YMEAN,IBUGA3,IERROR) 15667 CALL SD(Y,N,IWRITE,YSD,IBUGA3,IERROR) 15668 AN=REAL(N) 15669C 15670 IF(YSD.LE.0.0)THEN 15671 WRITE(ICOUT,999) 15672 CALL DPWRST('XXX','WRIT') 15673 WRITE(ICOUT,101) 15674 CALL DPWRST('XXX','WRIT') 15675 WRITE(ICOUT,212) 15676 212 FORMAT(' THE STANDARD DEVIATION OF THE ORIGINAL ', 15677 1 'OBSERVATIONS IS NON-POSITIVE.') 15678 CALL DPWRST('XXX','WRIT') 15679 IERROR='YES' 15680 GOTO9000 15681 ENDIF 15682C 15683C COMPUTE ADJUSTED KURTOSIS 15684C 15685 IF(IBONAD.EQ.'ON' .OR. N.LE.6)THEN 15686 CALL MEDIAN(Y,N,IWRITE,TEMP1,MAXNXT,ADJMEA,IBUGA3,IERROR) 15687 ELSE 15688C 15689C COMPUTE TRIMMED MEAN. TRIM AT LEAST ONE FROM EACH END. 15690C 15691 APERC=1.0/(2.0*SQRT(AN-4.0)) 15692 NTRIM=INT(AN*APERC + 0.5) 15693 IF(NTRIM.EQ.0)NTRIM=1 15694 NSTRT=NTRIM+1 15695 NSTOP=N-NTRIM 15696 NTEMP=N - 2*NTRIM 15697 DSUM1=0.0D0 15698 DO230I=NSTRT,NSTOP 15699 DSUM1=DSUM1 + DBLE(Y(I)) 15700 230 CONTINUE 15701 DTERM1=DSUM1/DBLE(NTEMP) 15702 ADJMEA=REAL(DTERM1) 15703 ENDIF 15704C 15705 DSUM1=0.0D0 15706 DSUM2=0.0D0 15707 DO240I=1,N 15708 DSUM1=DSUM1 + (DBLE(Y(I) - ADJMEA)**4) 15709 DSUM2=DSUM2 + (DBLE(Y(I) - YMEAN)**2) 15710 240 CONTINUE 15711 DTERM1=DBLE(N)*DSUM1/(DSUM2**2) 15712 AKURTS=REAL(DTERM1) 15713C 15714C POOL SAMPLE KURTOSIS WITH PRIOR MEASURE OF KURTOSIS 15715C (IF GIVEN) 15716C 15717 IF(AKURT.NE.CPUMIN .AND. N0.GT.0)THEN 15718 AKURTS=(AN*AKURTS + REAL(N0)*AKURT)/REAL(N+N0) 15719 ENDIF 15720 TERM1=AKURTS - ((AN-3.0)/AN) 15721 SE=TERM1/(AN-1.0) 15722 SE=SQRT(SE) 15723C 15724 IF(ICASA4.EQ.'ONES')THEN 15725 DO460I=1,NALPHA 15726 ALPHAT=ALPHA(I) 15727 IF(ALPHAT.GE.1.0 .AND. ALPHAT.LT.100.0)ALPHAT=ALPHAT/100. 15728 IF(ALPHAT.LE.0.0 .OR. ALPHAT.GE.1.0)GOTO8000 15729 IF(ALPHAT.LT.0.5)ALPHAT=1.0 - ALPHAT 15730 IF(IBONAD.EQ.'OFF')THEN 15731 CALL NORPPF(ALPHAT,Z) 15732 ELSE 15733 IDF=N-1 15734 ANU=REAL(IDF) 15735 CALL TPPF(ALPHAT,ANU,Z) 15736 ENDIF 15737 C=AN/(AN+Z) 15738 TERM1=Z*C*SE 15739 TERM2=LOG(C*YSD**2) 15740 ALOWLM(I)=SQRT(EXP(TERM2 + TERM1)) 15741 AUPPLM(I)=SQRT(EXP(TERM2 - TERM1)) 15742 460 CONTINUE 15743 ELSEIF(ICASA4.EQ.'TWOS')THEN 15744 DO465I=1,NALPHA 15745 ALPHAT=ALPHA(I) 15746 IF(ALPHAT.GE.1.0 .AND. ALPHAT.LT.100.0)ALPHAT=ALPHAT/100. 15747 IF(ALPHAT.LE.0.0 .OR. ALPHAT.GE.1.0)GOTO8000 15748 IF(ALPHAT.GT.0.5)ALPHAT=1.0 - ALPHAT 15749 ALPHAT=ALPHAT/2.0 15750 IF(IBONAD.EQ.'OFF')THEN 15751 CALL NORPPF(ALPHAT,Z) 15752 ELSE 15753 IDF=N-1 15754 ANU=REAL(IDF) 15755 CALL TPPF(ALPHAT,ANU,Z) 15756 ENDIF 15757 C=AN/(AN+Z) 15758 TERM1=Z*C*SE 15759 TERM2=LOG(C*YSD**2) 15760 ALOWLM(I)=SQRT(EXP(TERM2 + TERM1)) 15761 AUPPLM(I)=SQRT(EXP(TERM2 - TERM1)) 15762C 15763 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SDR3')THEN 15764 WRITE(ICOUT,471)I,Z,C,SE,TERM1,TERM2 15765 471 FORMAT('I,Z,C,SE,TERM1,TERM2 = ',I5,5G15.7) 15766 CALL DPWRST('XXX','WRIT') 15767 WRITE(ICOUT,473)ALOWLM(I),AUPPLM(I) 15768 473 FORMAT('ALOWLM(I),AUPPLM(I) = ',2G15.7) 15769 CALL DPWRST('XXX','WRIT') 15770 ENDIF 15771C 15772 465 CONTINUE 15773 ENDIF 15774C 15775 GOTO9000 15776C 15777 8000 CONTINUE 15778 WRITE(ICOUT,999) 15779 CALL DPWRST('XXX','WRIT') 15780 WRITE(ICOUT,101) 15781 CALL DPWRST('XXX','WRIT') 15782 WRITE(ICOUT,8001)I 15783 8001 FORMAT(' ROW ',I8,' OF ALPHA VALUES IS OUT OF RANGE.') 15784 CALL DPWRST('XXX','WRIT') 15785 WRITE(ICOUT,8003)ALPHA(I) 15786 8003 FORMAT(' THE VALUE OF ALPHA IS ',G15.7) 15787 CALL DPWRST('XXX','WRIT') 15788 IERROR='YES' 15789 GOTO9000 15790C 15791 9000 CONTINUE 15792 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SDR3')THEN 15793 WRITE(ICOUT,999) 15794 CALL DPWRST('XXX','WRIT') 15795 WRITE(ICOUT,9051) 15796 9051 FORMAT('**** AT THE END OF DPSDR3--') 15797 CALL DPWRST('XXX','WRIT') 15798 WRITE(ICOUT,9052)YMEAN,YSD,ADJMEA,AKURTS 15799 9052 FORMAT('YMEAN,YSD,ADJMEAN,AKURTS = ',4G15.7) 15800 CALL DPWRST('XXX','WRIT') 15801 ENDIF 15802C 15803 RETURN 15804 END 15805 SUBROUTINE DPSEAR(IANS,IANSLC,IWIDTH,ICOM,IHARG,IHARG2,NUMARG, 15806 1 ISEART, 15807CCCCC FEBRUARY 2003: ADD FOLLOWING LINE TO CALL LIST 15808 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 15809 1 IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR) 15810C 15811C PURPOSE--SEARCH A USER-DEFINED FILE FOR A USER-DEFINED STRING 15812C AND PRINT ALL LINES WHERE THAT STRING OCCURS. 15813C ALSO--IF CALLED FOR, SEARCH THE MASTER REFERENCE FILE (WHICH IS A 15814C FILE CONTAINING LISTS OF FILE NAMES) FOR DATA FILE NAMES, 15815C FOR REFERENCE FILE NAMES, AND FOR MACRO FILE NAMES. 15816C ALSO--IF CALLED FOR, SEARCH THE DICTIONARY FILE (WHICH IS A FILE 15817C CONTAINING THE LIST OF COMMANDS, FUNCTIONS, LET SUBCOMMANDS, 15818C AND OTHER KEYWORDS.) 15819C NOTE--THIS SUBROUTINE USES THE SAME FILE AS LIST. 15820C WRITTEN BY--JAMES J. FILLIBEN 15821C STATISTICAL ENGINEERING DIVISION 15822C INFORMATION TECHNOLOGY LABORATORY 15823C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 15824C GAITHERSBURG, MD 20899-8980 15825C PHONE--301-975-2899 15826C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 15827C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 15828C LANGUAGE--ANSI FORTRAN (1977) 15829C VERSION NUMBER--88/1 15830C ORIGINAL VERSION--JANUARY 1988. 15831C UPDATED --AUGUST 1988. (CHANGE DPMASF TO DPDIRF) 15832C UPDATED --AUGUST 1988. (DICTIONARY FILE) 15833C UPDATED --JANUARY 1994. SEARCH1 (1LIN) 15834C UPDATED --FEBRUARY 2003. STORE LINE NUMBER OF FIRST MATCH 15835C IN INTERNAL PARAMETER "LINENUMB". 15836C UPDATED --APRIL 2018. ADD "REFMAN.TEX" AND 15837C "HANDBK.TEX" SEARCHES 15838C UPDATED --APRIL 2018. ADD VARIOUS SYNONYMS 15839C UPDATED --APRIL 2018. SUPPORT MORE THAN ONE 15840C WORD FOR STRING TO MATCH 15841C UPDATED --SEPTEMBER 2019. ADD "GREP" OPTION TO USE 15842C AN OPERATING SYSTEM BASED 15843C SEARCH 15844C 15845C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 15846C 15847 INCLUDE 'DPCOPA.INC' 15848C 15849 CHARACTER*4 IANSLC(*) 15850 CHARACTER*4 IANS(*) 15851 CHARACTER*4 ICOM 15852 CHARACTER*4 IHARG(*) 15853 CHARACTER*4 IHARG2(*) 15854C 15855 CHARACTER*4 IHNAME(*) 15856 CHARACTER*4 IHNAM2(*) 15857 CHARACTER*4 IUSE(*) 15858C 15859 CHARACTER*4 ISEART 15860 CHARACTER*4 IBUGS2 15861 CHARACTER*4 IBUGQ 15862 CHARACTER*4 ISUBRO 15863 CHARACTER*4 IFOUND 15864 CHARACTER*4 IERROR 15865C 15866CCCCC CHARACTER*80 IFILE 15867 CHARACTER (LEN=MAXFNC) :: IFILE 15868 CHARACTER*12 ISTAT 15869 CHARACTER*12 IFORM 15870 CHARACTER*12 IACCES 15871 CHARACTER*12 IPROT 15872 CHARACTER*12 ICURST 15873 CHARACTER*4 IENDFI 15874 CHARACTER*4 IREWIN 15875 CHARACTER*4 ISUBN0 15876 CHARACTER*4 IERRFI 15877C 15878 CHARACTER*4 ISUBN1 15879 CHARACTER*4 ISUBN2 15880 CHARACTER*4 ISTEPN 15881 CHARACTER*4 ICASEQ 15882 CHARACTER*4 IANSI 15883CCCCC CHARACTER*100 ICANS 15884CCCCC CHARACTER*100 ISTRIN 15885CCCCC CHARACTER*100 ISTRIU 15886CCCCC CHARACTER*100 ITAST 15887CCCCC CHARACTER*100 ITASTU 15888CCCCC CHARACTER*255 IAOUT 15889 CHARACTER (LEN=MAXSTR) :: IAOUT 15890 CHARACTER (LEN=MAXSTR) :: ICANS 15891 CHARACTER (LEN=MAXSTR) :: ISTRIN 15892 CHARACTER (LEN=MAXSTR) :: ISTRIU 15893 CHARACTER (LEN=MAXSTR) :: ITAST 15894 CHARACTER (LEN=MAXSTR) :: ITASTU 15895 CHARACTER*4 IHIT 15896 CHARACTER*4 IGO 15897 CHARACTER*4 IH 15898 CHARACTER*4 IH2 15899 CHARACTER*4 ISSAV1 15900 CHARACTER*4 ISSAV2 15901C 15902 DIMENSION VALUE(*) 15903 DIMENSION IVALUE(*) 15904C 15905C-----COMMON---------------------------------------------------------- 15906C 15907 INCLUDE 'DPCODA.INC' 15908 INCLUDE 'DPCOF2.INC' 15909 INCLUDE 'DPCOST.INC' 15910 INCLUDE 'DPCOHO.INC' 15911 INCLUDE 'DPCOP2.INC' 15912C 15913C-----START POINT----------------------------------------------------- 15914C 15915 ISUBN1='DPSE' 15916 ISUBN2='AR ' 15917 IFOUND='YES' 15918 IERROR='NO' 15919 IHIT='NO' 15920 IGO='NO' 15921 IAOUT=' ' 15922C 15923 ILISAV=1 15924 MINN2=1 15925 NCSTRI=(-999) 15926 MAXLEN=9999 15927 NQ=0 15928C 15929 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR')THEN 15930 WRITE(ICOUT,999) 15931 999 FORMAT(1X) 15932 CALL DPWRST('XXX','BUG ') 15933 WRITE(ICOUT,51) 15934 51 FORMAT('***** AT THE BEGINNING OF DPSEAR--') 15935 CALL DPWRST('XXX','BUG ') 15936 WRITE(ICOUT,53)IWIDTH,IBUGS2,ISUBRO,IERROR,ISEART,ICOM 15937 53 FORMAT('IWIDTH,IBUGS2,ISUBRO,IERROR,ISEART,ICOM = ', 15938 1 I5,5(2X,A4)) 15939 CALL DPWRST('XXX','BUG ') 15940 IF(IWIDTH.GE.1)THEN 15941 WRITE(ICOUT,55)(IANSLC(I),I=1,MIN(100,IWIDTH)) 15942 55 FORMAT('(IANSLC(I),I=1,IWIDTH) = ',100A1) 15943 CALL DPWRST('XXX','BUG ') 15944 ENDIF 15945 WRITE(ICOUT,61)ILISNU,IDIRNU,IDICNU 15946 61 FORMAT('ILISNU,IDIRNU,IDICNU = ',3I8) 15947 CALL DPWRST('XXX','BUG ') 15948 WRITE(ICOUT,62)ILISNA(1:80) 15949 62 FORMAT('ILISNA = ',A80) 15950 CALL DPWRST('XXX','BUG ') 15951 WRITE(ICOUT,63)ILISST,ILISFO,ILISAC,ILISFO,ILISCS 15952 63 FORMAT('ILISST,ILISFO,ILISAC,ILISFO,ILISCS = ', 15953 1 4(A12,2X),A12) 15954 CALL DPWRST('XXX','BUG ') 15955 WRITE(ICOUT,72)IDIRNA(1:80) 15956 72 FORMAT('IDIRNA = ',A80) 15957 CALL DPWRST('XXX','BUG ') 15958 WRITE(ICOUT,73)IDIRST,IDIRFO,IDIRAC,IDIRFO,IDIRCS 15959 73 FORMAT('IDIRST,IDIRFO,IDIRAC,IDIRFO,IDIRCS = ', 15960 1 4(A12,2X),A12) 15961 CALL DPWRST('XXX','BUG ') 15962 WRITE(ICOUT,82)IDICNA(1:80) 15963 82 FORMAT('IDICNA = ',A80) 15964 CALL DPWRST('XXX','BUG ') 15965 WRITE(ICOUT,83)IDICST,IDICFO,IDICAC,IDICFO,IDICCS 15966 83 FORMAT('IDICST,IDICFO,IDICAC,IDICFO,IDICCS = ', 15967 1 4(A12,2X),A12) 15968 CALL DPWRST('XXX','BUG ') 15969 ENDIF 15970C 15971C ************************************************* 15972C ** STEP 10-- ** 15973C ** PERFORM AN OPERATION SYSTEM BASED SEARCH ** 15974C ************************************************* 15975C 15976C 2019/09: THE "GREP" VARIANT WILL DO AN OPERATIONG SYSTEM 15977C BASED SEARCH. 15978C 15979C 1. FOR LINUX/UNIX (AND MACOS) SYSTEMS, USE THE 15980C GREP COMMAND. 15981C 15982C 2. FOR WINDOWS SYSTEMS, USE THE FINDSTR COMMAND. 15983C 15984C NOTE THAT WHILE THIS CAN EASILY BE DONE JUST USING 15985C THE "SYSTEM" COMMAND, IMPLEMENTING THIS AS A DISTINCT 15986C COMMAND ALLOWS GENERAL PURPOSE MACROS TO BE WRITTEN 15987C THAT DON'T REQUIRE SPECIAL CODING BASED ON THE HOST 15988C OPERATING SYSTEM. 15989C 15990 ISTEPN='10' 15991 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR') 15992 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 15993C 15994 IF(ISEART.EQ.'GREP' .OR. ISEART.EQ.'FIND')THEN 15995C 15996C STEP 1: FIND FIRST NON-BLANK CHARACTER AFTER "GREP " 15997C OR "FINDSTR ". 15998C 15999 ISTRT=-1 16000 IF(ISEART.EQ.'GREP')THEN 16001 DO101II=1,MIN(250,IWIDTH-5) 16002 IF(IANS(II)(1:1) .EQ.'G' .AND. IANS(II+1)(1:1).EQ.'R' .AND. 16003 1 IANS(II+2)(1:1).EQ.'E' .AND. IANS(II+3)(1:1).EQ.'P' .AND. 16004 1 IANS(II+4)(1:1).EQ.' ')THEN 16005 ISTRT=II+5 16006 GOTO109 16007 ENDIF 16008 101 CONTINUE 16009 WRITE(ICOUT,999) 16010 CALL DPWRST('XXX','BUG ') 16011 WRITE(ICOUT,1211) 16012 CALL DPWRST('XXX','BUG ') 16013 WRITE(ICOUT,103) 16014 103 FORMAT(' GREP NOT FOUND AT BEGINNING OF COMMAND LINE.') 16015 CALL DPWRST('XXX','BUG ') 16016 IERROR='YES' 16017 GOTO9000 16018 109 CONTINUE 16019 ELSEIF(ISEART.EQ.'FIND')THEN 16020 DO111II=1,MIN(247,IWIDTH-8) 16021 IF(IANS(II)(1:1) .EQ.'F' .AND. IANS(II+1)(1:1).EQ.'I' .AND. 16022 1 IANS(II+2)(1:1).EQ.'N' .AND. IANS(II+3)(1:1).EQ.'D' .AND. 16023 1 IANS(II+4)(1:1).EQ.'S' .AND. IANS(II+5)(1:1).EQ.'T' .AND. 16024 1 IANS(II+6)(1:1).EQ.'R' .AND. IANS(II+7)(1:1).EQ.' ')THEN 16025 ISTRT=II+8 16026 GOTO119 16027 ENDIF 16028 111 CONTINUE 16029 WRITE(ICOUT,999) 16030 CALL DPWRST('XXX','BUG ') 16031 WRITE(ICOUT,1211) 16032 CALL DPWRST('XXX','BUG ') 16033 WRITE(ICOUT,113) 16034 113 FORMAT(' FINDSTR NOT FOUND AT BEGINNING OF COMMAND ', 16035 1 'LINE.') 16036 CALL DPWRST('XXX','BUG ') 16037 IERROR='YES' 16038 GOTO9000 16039 119 CONTINUE 16040C 16041 DO121II=ISTRT,IWIDTH 16042 IF(IANS(II)(1:1).NE.' ')THEN 16043 ISTRT=II 16044 GOTO129 16045 ENDIF 16046 121 CONTINUE 16047 WRITE(ICOUT,999) 16048 CALL DPWRST('XXX','BUG ') 16049 WRITE(ICOUT,1211) 16050 CALL DPWRST('XXX','BUG ') 16051 WRITE(ICOUT,123) 16052 123 FORMAT(' NO TEXT FOUND AFTER GREP (OR FINDSTR) ', 16053 1 'ON THE COMMAND LINE.') 16054 CALL DPWRST('XXX','BUG ') 16055 IERROR='YES' 16056 GOTO9000 16057 129 CONTINUE 16058 ENDIF 16059C 16060C STEP 2: FIND LAST NON-BLANK CHARACTER 16061C 16062 ILAST=ISTRT 16063 DO131II=IWIDTH,ISTRT,-1 16064 IF(IANS(II)(1:1).NE.' ')THEN 16065 ILAST=II 16066 GOTO139 16067 ENDIF 16068 131 CONTINUE 16069 139 CONTINUE 16070C 16071C STEP 3: CREATE STRING TO BE SENT TO SYSTEM COMMAND. 16072C NOTE THAT DATAPLOT DOES NO ERROR CHECKING, IT 16073C JUST PASSES WHAT THE USER ENTERED. 16074C 16075 IF(IHOST1.EQ.'IBM-')THEN 16076 IF(IGRPCA.EQ.'IGNO')THEN 16077 NCSTR=11 16078 IAOUT(1:NCSTR)='FINDSTR /I ' 16079 ELSE 16080 NCSTR=8 16081 IAOUT(1:NCSTR)='FINDSTR ' 16082 ENDIF 16083 IF(IGRPRE.EQ.'ON')THEN 16084 IAOUT(NCSTR+1:NCSTR+3)='/S ' 16085 NCSTR=NCSTR+3 16086 ENDIF 16087 IF(IGRPLN.EQ.'ON')THEN 16088 IAOUT(NCSTR+1:NCSTR+3)='/N ' 16089 NCSTR=NCSTR+3 16090 ENDIF 16091 IF(IGRPEM.EQ.'ON')THEN 16092 IAOUT(NCSTR+1:NCSTR+3)='/X ' 16093 NCSTR=NCSTR+3 16094 ENDIF 16095 IF(IGRPNM.EQ.'ON')THEN 16096 IAOUT(NCSTR+1:NCSTR+3)='/V ' 16097 NCSTR=NCSTR+3 16098 ENDIF 16099 IF(IGRPFN.EQ.'ON')THEN 16100 IAOUT(NCSTR+1:NCSTR+3)='/M ' 16101 NCSTR=NCSTR+3 16102 ENDIF 16103 ELSE 16104 IF(IGRPCA.EQ.'IGNO')THEN 16105 NCSTR=8 16106 IAOUT(1:NCSTR)='grep -i ' 16107 ELSE 16108 NCSTR=5 16109 IAOUT(1:NCSTR)='grep ' 16110 ENDIF 16111 IF(IGRPRE.EQ.'ON')THEN 16112 IAOUT(NCSTR+1:NCSTR+3)='-r ' 16113 NCSTR=NCSTR+3 16114 ENDIF 16115 IF(IGRPLN.EQ.'ON')THEN 16116 IAOUT(NCSTR+1:NCSTR+3)='-n ' 16117 NCSTR=NCSTR+3 16118 ENDIF 16119 IF(IGRPEM.EQ.'ON')THEN 16120 IAOUT(NCSTR+1:NCSTR+3)='-x ' 16121 NCSTR=NCSTR+3 16122 ENDIF 16123 IF(IGRPNM.EQ.'ON')THEN 16124 IAOUT(NCSTR+1:NCSTR+3)='-v ' 16125 NCSTR=NCSTR+3 16126 ENDIF 16127 IF(IGRPFN.EQ.'ON')THEN 16128 IAOUT(NCSTR+1:NCSTR+3)='-l ' 16129 NCSTR=NCSTR+3 16130 ENDIF 16131 ENDIF 16132C 16133 MAXNCH=MAXSTR 16134 DO141II=ISTRT,ILAST 16135 NCSTR=NCSTR+1 16136 IF(NCSTR.GT.MAXNCH)THEN 16137 WRITE(ICOUT,999) 16138 CALL DPWRST('XXX','BUG ') 16139 WRITE(ICOUT,1211) 16140 CALL DPWRST('XXX','BUG ') 16141 WRITE(ICOUT,1291)MAXNCH 16142 1291 FORMAT(' MAXIMUM NUMBER OF CHARACTERS (',I3, 16143 1 ') EXCEEDED.') 16144 CALL DPWRST('XXX','BUG ') 16145 IERROR='YES' 16146 GOTO9000 16147 ENDIF 16148 IAOUT(NCSTR:NCSTR)=IANSLC(II)(1:1) 16149 141 CONTINUE 16150C 16151 ISSAV1=ISYSPE 16152 ISSAV2=ISYSHI 16153 ISYSPE='ON' 16154 ISYSHI='OFF' 16155 CALL DPSYS2(IAOUT,NCSTR,ISUBRO,IERROR) 16156 ISYSPE=ISSAV1 16157 ISYSHI=ISSAV2 16158C 16159 GOTO9000 16160 ENDIF 16161C 16162C ************************** 16163C ** STEP 11-- ** 16164C ** COPY OVER VARIABLES ** 16165C ************************** 16166C 16167 ISTEPN='11' 16168 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR') 16169 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16170C 16171 IOUNIT=ILISNU 16172 IFILE=ILISNA 16173 ISTAT=ILISST 16174 IFORM=ILISFO 16175 IACCES=ILISAC 16176 IPROT=ILISPR 16177 ICURST=ILISCS 16178C 16179 ISUBN0='SEAR' 16180 IERRFI='NO' 16181C 16182 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR')THEN 16183 WRITE(ICOUT,1193)IOUNIT,ISUBN0,IERRFI 16184 1193 FORMAT('IOUNIT,ISUBN0,IERRFI = ',I8,2(2X,A4)) 16185 CALL DPWRST('XXX','BUG ') 16186 WRITE(ICOUT,1194)IFILE 16187 1194 FORMAT('IFILE = ',A80) 16188 CALL DPWRST('XXX','BUG ') 16189 WRITE(ICOUT,1195)ISTAT,IFORM,IACCES,IPROT,ICURST 16190 1195 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ', 16191 1 4(A12,2X),A12) 16192 CALL DPWRST('XXX','BUG ') 16193 ENDIF 16194C 16195C *********************************************** 16196C ** STEP 12-- ** 16197C ** CHECK TO SEE IF THE LIST FILE MAY EXIST ** 16198C *********************************************** 16199C 16200 ISTEPN='12' 16201 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR') 16202 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16203C 16204 IF(ISTAT.EQ.'NONE')THEN 16205 IERROR='YES' 16206 WRITE(ICOUT,999) 16207 CALL DPWRST('XXX','BUG ') 16208 WRITE(ICOUT,1211) 16209 1211 FORMAT('***** ERROR IN SEARCH COMMAND--') 16210 CALL DPWRST('XXX','BUG ') 16211 WRITE(ICOUT,1212) 16212 1212 FORMAT(' THE DESIRED SEARCHING CANNOT BE CARRIED OUT') 16213 CALL DPWRST('XXX','BUG ') 16214 WRITE(ICOUT,1214) 16215 1214 FORMAT(' BECAUSE THE INTERNAL VARIABLE ILISST WHICH') 16216 CALL DPWRST('XXX','BUG ') 16217 WRITE(ICOUT,1215) 16218 1215 FORMAT(' ALLOWS SUCH SEARCHING HAS BEEN SET TO NONE.') 16219 CALL DPWRST('XXX','BUG ') 16220 WRITE(ICOUT,1217)ISTAT,ILISST 16221 1217 FORMAT('ISTAT,ILISST = ',A12,2X,A12) 16222 CALL DPWRST('XXX','BUG ') 16223 GOTO9000 16224 ENDIF 16225C 16226C ******************************** 16227C ** STEP 13-- ** 16228C ** EXTRACT THE FILE NAME. ** 16229C ** DO THE GENERAL CASE OF ** 16230C ** SEARCHING GENERAL FILES. ** 16231C ** DO ALSO THE SPECIAL CASE ** 16232C ** OF SEARCHING THE ** 16233C ** MASTER DIRECTORY FILE. ** 16234C ** DO ALSO THE SPECIAL CASE ** 16235C ** OF SEARCHING THE ** 16236C ** DICTIONARY FILE. ** 16237C ******************************** 16238C 16239 ISTEPN='13' 16240 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR') 16241 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16242C 16243 DO1310I=1,MAXSTR 16244 IANSI=IANSLC(I) 16245 ICANS(I:I)=IANSI(1:1) 16246 1310 CONTINUE 16247C 16248 IFLAGZ=0 16249 ISTART=1 16250 ISTOP=IWIDTH 16251 IWORD=2 16252 NCFILE=0 16253 IF(ICOM.NE.'? ' .AND. ICOM.NE.'??? ')THEN 16254 CALL DPEXWO(ICANS,ISTART,ISTOP,IWORD, 16255 1 ICOL1,ICOL2,IFILE,NCFILE, 16256 1 IBUGS2,ISUBRO,IERROR) 16257 IF(IERROR.EQ.'YES')GOTO9000 16258 ELSEIF(ICOM.EQ.'? ' .AND. NUMARG.EQ.0)THEN 16259 IFILE='dp_question_mark_examples.txt' 16260 NCFILE=29 16261 IFLAGZ=1 16262 ICASEQ='FULL' 16263 GOTO2190 16264 ENDIF 16265C 16266 IFLAGF=1 16267C 16268 IF((NCFILE.EQ.9.AND.IFILE.EQ.'DIRECTORY') .OR. 16269 1 (NCFILE.EQ.9.AND.IFILE.EQ.'directory') .OR. 16270 1 (NCFILE.EQ.3.AND.IFILE.EQ.'DIR') .OR. 16271 1 (NCFILE.EQ.3.AND.IFILE.EQ.'dir') .OR. 16272 1 (NCFILE.EQ.4.AND.IFILE.EQ.'DIRE') .OR. 16273 1 (NCFILE.EQ.4.AND.IFILE.EQ.'dire') .OR. 16274 1 (NCFILE.EQ.1.AND.IFILE.EQ.'M') .OR. 16275 1 (NCFILE.EQ.1.AND.IFILE.EQ.'m') .OR. 16276 1 (NCFILE.EQ.6.AND.IFILE.EQ.'MASTER') .OR. 16277 1 (NCFILE.EQ.6.AND.IFILE.EQ.'master'))THEN 16278 IFILE=IDIRNA 16279 ELSEIF((NCFILE.EQ.10.AND.IFILE.EQ.'DICTIONARY') .OR. 16280 1 (NCFILE.EQ.10.AND.IFILE.EQ.'dictionary') .OR. 16281 1 (NCFILE.EQ.3.AND.IFILE.EQ.'DIC') .OR. 16282 1 (NCFILE.EQ.3.AND.IFILE.EQ.'dic') .OR. 16283 1 (NCFILE.EQ.4.AND.IFILE.EQ.'DICT') .OR. 16284 1 (NCFILE.EQ.4.AND.IFILE.EQ.'dict'))THEN 16285 IFILE=IDICNA 16286 ELSEIF((NCFILE.EQ.8.AND.IFILE.EQ.'HANDBOOK') .OR. 16287 1 (NCFILE.EQ.8.AND.IFILE.EQ.'handbook') .OR. 16288 1 (NCFILE.EQ.2.AND.IFILE.EQ.'HB') .OR. 16289 1 (NCFILE.EQ.2.AND.IFILE.EQ.'hb') .OR. 16290 1 (NCFILE.EQ.6.AND.IFILE.EQ.'HANDBK') .OR. 16291 1 (NCFILE.EQ.6.AND.IFILE.EQ.'handbk') .OR. 16292 1 (ICOM.EQ.'??? '))THEN 16293 IFILE='handbk.tex' 16294 NCFILE=10 16295 ELSEIF((NCFILE.EQ.9.AND.IFILE.EQ.'REFERENCE') .OR. 16296 1 (NCFILE.EQ.9.AND.IFILE.EQ.'reference') .OR. 16297 1 (NCFILE.EQ.2.AND.IFILE.EQ.'RM') .OR. 16298 1 (NCFILE.EQ.2.AND.IFILE.EQ.'rm') .OR. 16299 1 (ICOM.EQ.'? '))THEN 16300 IFILE='refman.tex' 16301 NCFILE=10 16302 MAXLEN=40 16303 ELSE 16304C 16305C 2018/04: CHECK IF FIRST ARGUMENT IS A FILE NAME (I.E., 16306C DOES IT CONTAIN A "."). 16307C 16308 DO1360II=1,NCFILE 16309 IF(IFILE(II:II).EQ.'.')GOTO1369 16310 1360 CONTINUE 16311 IFLAGF=0 16312 IFILE='refman.tex' 16313 NCFILE=10 16314 1369 CONTINUE 16315 ENDIF 16316C 16317 IF(NCFILE.LT.1)THEN 16318 IERROR='YES' 16319 WRITE(ICOUT,999) 16320 CALL DPWRST('XXX','BUG ') 16321 WRITE(ICOUT,1211) 16322 CALL DPWRST('XXX','BUG ') 16323 WRITE(ICOUT,1372) 16324 1372 FORMAT(' A USER FILE NAME IS REQUIRED IN THE SEARCH ', 16325 1 'COMMAND') 16326 CALL DPWRST('XXX','BUG ') 16327 WRITE(ICOUT,1374) 16328 1374 FORMAT(' (FOR EXAMPLE, SEARCH PROG7.DP)') 16329 CALL DPWRST('XXX','BUG ') 16330 WRITE(ICOUT,1375) 16331 1375 FORMAT(' BUT NONE WAS GIVEN HERE.') 16332 CALL DPWRST('XXX','BUG ') 16333 WRITE(ICOUT,1376) 16334 1376 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') 16335 CALL DPWRST('XXX','BUG ') 16336 IF(IWIDTH.GE.1)THEN 16337 WRITE(ICOUT,1377)(IANSLC(I),I=1,MIN(80,IWIDTH)) 16338 1377 FORMAT(' ',80A1) 16339 CALL DPWRST('XXX','BUG ') 16340 ELSE 16341 WRITE(ICOUT,999) 16342 CALL DPWRST('XXX','BUG ') 16343 ENDIF 16344 GOTO9000 16345 ENDIF 16346C 16347C ************************************************ 16348C ** STEP 14-- ** 16349C ** EXTRACT THE STRING TO BE SEARCHED FOR. ** 16350C ************************************************ 16351C 16352 ISTEPN='14' 16353 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR') 16354 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16355C 16356 ISTART=1 16357 ISTOP=IWIDTH 16358 IWORD=3 16359 IF(ICOM.EQ.'? ' .OR. ICOM.EQ.'??? ')THEN 16360 IWORD=2 16361 ELSE 16362 IWORD=3 16363 IF(IFLAGF.EQ.0)IWORD=IWORD-1 16364 ENDIF 16365C 16366C 2018/04: USE DPEXW3 INSTEAD OF DPEXWO SO THAT 16367C THE STRING IS EXTRACTED IS TO THE END 16368C OF THE COMMAND LINE INSTEAD OF JUST A 16369C SINGLE WORD. SO "SEARCH REFERENCE MEAN PLOT" 16370C WILL MATCH "MEAN PLOT" INSTEAD OF JUST 16371C "MEAN". 16372C 16373 CALL DPEXW3(ICANS,ISTART,ISTOP,IWORD, 16374 1 ICOLS1,ICOLS2,ITAST,NCTAST, 16375 1 IBUGS2,ISUBRO,IERROR) 16376 IF(IERROR.EQ.'YES')GOTO9000 16377C 16378 NMAX=MAXSTR 16379 CALL DPUP80(ITAST,ITASTU,NMAX,IBUGS2,IERROR) 16380 IF(IERROR.EQ.'YES')GOTO9000 16381C 16382 IF(NCTAST.LT.1)THEN 16383 IERROR='YES' 16384 WRITE(ICOUT,999) 16385 CALL DPWRST('XXX','BUG ') 16386 WRITE(ICOUT,1211) 16387 CALL DPWRST('XXX','BUG ') 16388 WRITE(ICOUT,1442) 16389 1442 FORMAT(' A TARGET STRING IS REQUIRED IN THE SEARCH ', 16390 1 'COMMAND') 16391 CALL DPWRST('XXX','BUG ') 16392 WRITE(ICOUT,1444) 16393 1444 FORMAT(' (FOR EXAMPLE, SEARCH PHONE.TEX JONES)') 16394 CALL DPWRST('XXX','BUG ') 16395 WRITE(ICOUT,1445) 16396 1445 FORMAT(' BUT NONE WAS GIVEN HERE.') 16397 CALL DPWRST('XXX','BUG ') 16398 IF(IWIDTH.GE.1)THEN 16399 WRITE(ICOUT,1377)(IANSLC(I),I=1,MIN(80,IWIDTH)) 16400 CALL DPWRST('XXX','BUG ') 16401 ELSE 16402 WRITE(ICOUT,999) 16403 CALL DPWRST('XXX','BUG ') 16404 ENDIF 16405 GOTO9000 16406 ENDIF 16407C 16408C ***************************************** 16409C ** STEP 21-- ** 16410C ** CHECK TO SEE THE TYPE CASE-- ** 16411C ** 1) UNQUALIFIED (THAT IS, FULL); ** 16412C ** 2) SUBSET/EXCEPT; OR ** 16413C ** 3) FOR. ** 16414C ***************************************** 16415C 16416 ISTEPN='21' 16417 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR') 16418 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16419C 16420 ICASEQ='FULL' 16421 ILOCQ=NUMARG+1 16422 IF(NUMARG.LT.1)GOTO2190 16423 DO2100J=1,NUMARG 16424 J1=J 16425 IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')THEN 16426 ICASEQ='SUBS' 16427 ILOCQ=J1 16428 GOTO2190 16429 ELSEIF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')THEN 16430 ICASEQ='SUBS' 16431 ILOCQ=J1 16432 GOTO2190 16433 ELSEIF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')THEN 16434 ICASEQ='FOR' 16435 ILOCQ=J1 16436 GOTO2190 16437 ENDIF 16438 2100 CONTINUE 16439 2190 CONTINUE 16440C 16441 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR')THEN 16442 WRITE(ICOUT,2191)NUMARG,ILOCQ,NCFILE 16443 2191 FORMAT('NUMARG,ILOCQ,NCFILE = ',3I8) 16444 CALL DPWRST('XXX','BUG ') 16445 IF(NCFILE.GT.0)THEN 16446 WRITE(ICOUT,2192)IFILE(1:NCFILE) 16447 2192 FORMAT('IFILE(1:NCFILE) = ',A80) 16448 CALL DPWRST('XXX','BUG ') 16449 ENDIF 16450 ENDIF 16451C 16452C ********************************************* 16453C ** STEP 22-- ** 16454C ** BRANCH TO THE APPROPRIATE SUBCASE ** 16455C ** (FULL, SUBSET, OR FOR). ** 16456C ********************************************* 16457C 16458 ISTEPN='22' 16459 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR') 16460 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16461C 16462 IF(ICASEQ.EQ.'FULL')THEN 16463 DO2215I=1,MAXN 16464 ISUB(I)=1 16465 2215 CONTINUE 16466 NQ=MAXN 16467 ELSEIF(ICASEQ.EQ.'SUBS')THEN 16468 NIOLD=MAXN 16469 CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) 16470 NQ=NIOLD 16471 ELSEIF(ICASEQ.EQ.'FOR')THEN 16472 NIOLD=MAXN 16473 CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 16474 1 NLOCAL,ILOCS,NS,IBUGQ,IERROR) 16475 NQ=NFOR 16476 NMXFOR=IROWN 16477 ENDIF 16478C 16479 IF(NQ.LT.MINN2)THEN 16480 WRITE(ICOUT,999) 16481 CALL DPWRST('XXX','BUG ') 16482 WRITE(ICOUT,1211) 16483 CALL DPWRST('XXX','BUG ') 16484 WRITE(ICOUT,2272) 16485 2272 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN EXTRACTED,') 16486 CALL DPWRST('XXX','BUG ') 16487 WRITE(ICOUT,2273) 16488 2273 FORMAT(' THE NUMBER OF SPECIFIED FILE LINES TO BE LISTED') 16489 CALL DPWRST('XXX','BUG ') 16490 WRITE(ICOUT,2276)MINN2 16491 2276 FORMAT(' MUST BE ',I8,' OR LARGER; SUCH WAS NOT THE ', 16492 1 'CASE HERE.') 16493 CALL DPWRST('XXX','BUG ') 16494 IF(IWIDTH.GE.1)THEN 16495 WRITE(ICOUT,1377)(IANSLC(I),I=1,MIN(80,IWIDTH)) 16496 CALL DPWRST('XXX','BUG ') 16497 ELSE 16498 WRITE(ICOUT,999) 16499 CALL DPWRST('XXX','BUG ') 16500 ENDIF 16501 IERROR='YES' 16502 GOTO9000 16503 ENDIF 16504 NS=NQ 16505C 16506C ************************** 16507C ** STEP 51-- ** 16508C ** OPEN THE FILE ** 16509C ************************** 16510C 16511 ISTEPN='31' 16512 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR')THEN 16513 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16514 WRITE(ICOUT,3111)IFILE 16515 3111 FORMAT('IFILE = ',A80) 16516 CALL DPWRST('XXX','BUG ') 16517 ENDIF 16518C 16519 IREWIN='ON' 16520 CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 16521 1 IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 16522 IF(IERRFI.EQ.'YES')GOTO9000 16523C 16524C ************************************* 16525C ** STEP 41-- ** 16526C ** READ A GENERAL FILE. ** 16527C ** SEARCH FOR THE STRING. ** 16528C ** IF FOUND, PRINT THE LINE OUT. ** 16529C ** PRINT ALL LINES ON WHICH THE ** 16530C ** STRING OCCURS. ** 16531C ************************************* 16532C 16533 ISTEPN='41' 16534 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR') 16535 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16536C 16537 IMAX=1000000 16538 IF(ICASEQ.EQ.'SUBS')IMAX=MAXN 16539 IF(ICASEQ.EQ.'FOR')IMAX=IROWN 16540C 16541 ILISAV=-1 16542C 16543 NMAX=MAXLEN 16544 IF(MAXLEN.GT.255)NMAX=255 16545CCCCC NMAX=100 16546 DO4110I=1,IMAX 16547C 16548 ILICUR=I 16549C 16550 ISTRIN=' ' 16551 READ(IOUNIT,4111,END=4190)(ISTRIN(J:J),J=1,NMAX) 16552 4111 FORMAT(255A1) 16553C 16554 IF(IFLAGZ.EQ.1)THEN 16555 DO44111JJ=NMAX,1,-1 16556 IF(ISTRIN(JJ:JJ).NE.' ')THEN 16557 WRITE(ICOUT,4117)(ISTRIN(J:J),J=1,JJ) 16558 CALL DPWRST('XXX','BUG ') 16559 GOTO4110 16560 ENDIF 1656144111 CONTINUE 16562 WRITE(ICOUT,'(A1)')ISTRIN(1:1) 16563 CALL DPWRST('XXX','BUG ') 16564 GOTO4110 16565 ENDIF 16566C 16567 CALL DPDB80(ISTRIN,JMAX,NMAX,IBUGS2,ISUBRO,IERROR) 16568 NCSTRI=JMAX 16569C 16570 CALL DPUP80(ISTRIN,ISTRIU,NMAX,IBUGS2,IERROR) 16571C 16572 IF(NCSTRI.EQ.3.AND.ISTRIN(1:3).EQ.'EOF')GOTO4190 16573 IF(ICASEQ.EQ.'FULL' .OR. 16574 1 (ICASEQ.EQ.'SUBS' .OR.ICASEQ.EQ.'FOR'.AND.ISUB(I).EQ.1))THEN 16575 IHIT='NO' 16576 IF(ISEART.EQ.'1LIN')IGO='NO' 16577 IF(ISEART.EQ.'FIRS')IGO='NO' 16578 IF(ISEART.EQ.'BLAN'.AND.NCSTRI.LE.0)IGO='NO' 16579 IF(ISEART.EQ.'----'.AND.ISTRIN(1:4).EQ.'----')IGO='NO' 16580 IF(IGO.EQ.'YES')GOTO4129 16581C 16582 IF(NCSTRI.LE.0)GOTO4129 16583 DO4120I1=1,NCSTRI 16584 I2=I1+NCTAST-1 16585 IF(I2.GT.NCSTRI)GOTO4129 16586 IF(ISTRIN(I1:I2).EQ.ITAST(1:NCTAST))IHIT='YES' 16587 IF(ISTRIU(I1:I2).EQ.ITASTU(1:NCTAST))IHIT='YES' 16588 IF(IHIT.EQ.'YES')IGO='YES' 16589 IF(IHIT.EQ.'YES'.AND.ILISAV.LT.0)ILISAV=ILICUR 16590 IF(IHIT.EQ.'YES')GOTO4129 16591 4120 CONTINUE 16592 4129 CONTINUE 16593C 16594 IF(IHIT.EQ.'YES'.OR.IGO.EQ.'YES')THEN 16595 WRITE(ICOUT,4117)(ISTRIN(J:J),J=1,MIN(100,NCSTRI)) 16596 4117 FORMAT(100A1) 16597 CALL DPWRST('XXX','BUG ') 16598 ENDIF 16599C 16600 IF(IHIT.EQ.'YES'.AND.ISEART.EQ.'FIRS')GOTO4190 16601 ENDIF 16602C 16603 4110 CONTINUE 16604C 16605 4190 CONTINUE 16606C 16607 IH='LINE' 16608 IH2='NUMB' 16609 VALUE0=REAL(ILISAV) 16610 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 16611 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 16612 1 IANSLC,IWIDTH,IBUGS2,IERROR) 16613C 16614C ************************** 16615C ** STEP 51-- ** 16616C ** CLOSE THE FILE ** 16617C ************************** 16618C 16619 ISTEPN='51' 16620 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR') 16621 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16622C 16623 IENDFI='OFF' 16624 IREWIN='ON' 16625 CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 16626 1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 16627C 16628C **************** 16629C ** STEP 90-- ** 16630C ** EXIT. ** 16631C **************** 16632C 16633 9000 CONTINUE 16634 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SEAR')THEN 16635 WRITE(ICOUT,999) 16636 CALL DPWRST('XXX','BUG ') 16637 WRITE(ICOUT,9011) 16638 9011 FORMAT('***** AT THE END OF DPSEAR--') 16639 CALL DPWRST('XXX','BUG ') 16640 WRITE(ICOUT,9012)IERROR,IERRFI,IOUNIT 16641 9012 FORMAT('IERROR,IERRFI,IOUNIT = ',2(A4,2X),I5) 16642 CALL DPWRST('XXX','BUG ') 16643 WRITE(ICOUT,9022)IFILE(1:80) 16644 9022 FORMAT('IFILE = ',A80) 16645 CALL DPWRST('XXX','BUG ') 16646 WRITE(ICOUT,9023)ISTAT,IFORM,IACCES,IPROT,ICURST 16647 9023 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',4(A12,2X),A12) 16648 CALL DPWRST('XXX','BUG ') 16649 WRITE(ICOUT,9028)IENDFI,IREWIN 16650 9028 FORMAT('IENDFI,IREWIN = ',A4,2X,A4) 16651 CALL DPWRST('XXX','BUG ') 16652 WRITE(ICOUT,9041)ICASEQ,NQ,NS,JMAX,NCSTRI 16653 9041 FORMAT('ICASEQ,NQ,NS,JMAX,NCSTRI = ',A4,4I8) 16654 CALL DPWRST('XXX','BUG ') 16655 ENDIF 16656C 16657 RETURN 16658 END 16659 SUBROUTINE DPSECL(IHARG,IARGT,IARG,NUMARG,IDEFCO, 16660 1 MAXSEG,ISEGCO,IFOUND,IERROR) 16661C 16662C PURPOSE--DEFINE THE COLOR FOR A SEGMENT. 16663C THE COLOR FOR SEGMENT I WILL BE PLACED 16664C IN THE I-TH ELEMENT OF THE HOLLERITH 16665C VECTOR ISEGCO(.). 16666C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 16667C --IARGT (A HOLLERITH VECTOR) 16668C --IARG (A HOLLERITH VECTOR) 16669C --NUMARG 16670C --IDEFCO 16671C --MAXSEG 16672C OUTPUT ARGUMENTS--ISEGCO (A HOLLERITH VECTOR 16673C WHOSE I-TH ELEMENT CONTAINS THE 16674C COLOR FOR SEGMENT I. 16675C --IFOUND ('YES' OR 'NO' ) 16676C --IERROR ('YES' OR 'NO' ) 16677C WRITTEN BY--JAMES J. FILLIBEN 16678C STATISTICAL ENGINEERING DIVISION 16679C INFORMATION TECHNOLOGY LABORATORY 16680C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 16681C GAITHERSBURG, MD 20899-8980 16682C PHONE--301-975-2899 16683C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16684C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 16685C LANGUAGE--ANSI FORTRAN (1977) 16686C VERSION NUMBER--82/7 16687C ORIGINAL VERSION--SEPTEMBER 1980. 16688C UPDATED --MAY 1982. 16689C 16690C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16691C 16692 CHARACTER*4 IHARG 16693 CHARACTER*4 IARGT 16694 CHARACTER*4 IDEFCO 16695 CHARACTER*4 ISEGCO 16696 CHARACTER*4 IFOUND 16697 CHARACTER*4 IERROR 16698C 16699 CHARACTER*4 IHOLD 16700C 16701C--------------------------------------------------------------------- 16702C 16703 DIMENSION IHARG(*) 16704 DIMENSION IARGT(*) 16705 DIMENSION IARG(*) 16706C 16707 DIMENSION ISEGCO(*) 16708C 16709C-----COMMON---------------------------------------------------------- 16710C 16711 INCLUDE 'DPCOP2.INC' 16712C 16713C-----START POINT----------------------------------------------------- 16714C 16715 IFOUND='NO' 16716 IERROR='NO' 16717C 16718 IF(NUMARG.EQ.0)GOTO1199 16719 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO1110 16720 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'COLO')GOTO1140 16721 GOTO1199 16722C 16723 1110 CONTINUE 16724 IF(NUMARG.LE.1)GOTO1120 16725 IF(IHARG(2).EQ.'ON')GOTO1120 16726 IF(IHARG(2).EQ.'OFF')GOTO1120 16727 IF(IHARG(2).EQ.'AUTO')GOTO1120 16728 IF(IHARG(2).EQ.'DEFA')GOTO1120 16729 GOTO1125 16730C 16731 1120 CONTINUE 16732 IHOLD=IDEFCO 16733 GOTO1130 16734C 16735 1125 CONTINUE 16736 IHOLD=IHARG(2) 16737 GOTO1130 16738C 16739 1130 CONTINUE 16740 IFOUND='YES' 16741 DO1135I=1,MAXSEG 16742 ISEGCO(I)=IHOLD 16743 1135 CONTINUE 16744C 16745 IF(IFEEDB.EQ.'OFF')GOTO1149 16746 WRITE(ICOUT,999) 16747 999 FORMAT(1X) 16748 CALL DPWRST('XXX','BUG ') 16749 I=1 16750 WRITE(ICOUT,1136)ISEGCO(I) 16751 1136 FORMAT('ALL SEGMENT COLORS HAVE JUST BEEN SET TO ', 16752 1A4) 16753 CALL DPWRST('XXX','BUG ') 16754 1149 CONTINUE 16755 GOTO1199 16756C 16757 1140 CONTINUE 16758 IF(IARGT(1).EQ.'NUMB')GOTO1150 16759 IERROR='YES' 16760 WRITE(ICOUT,999) 16761 CALL DPWRST('XXX','BUG ') 16762 WRITE(ICOUT,1141) 16763 1141 FORMAT('***** ERROR IN DPSECL--') 16764 CALL DPWRST('XXX','BUG ') 16765 WRITE(ICOUT,1142) 16766 1142 FORMAT(' IN THE SEGMENT ... COLOR COMMAND,') 16767 CALL DPWRST('XXX','BUG ') 16768 WRITE(ICOUT,1143) 16769 1143 FORMAT(' THE SEGMENT IS IDENTIFIED BY A NUMBER, AS IN--') 16770 CALL DPWRST('XXX','BUG ') 16771 WRITE(ICOUT,1144) 16772 1144 FORMAT(' SEGMENT 3 COLOR GREEN') 16773 CALL DPWRST('XXX','BUG ') 16774 GOTO1199 16775C 16776 1150 CONTINUE 16777 I=IARG(1) 16778 IF(1.LE.I.AND.I.LE.MAXSEG)GOTO1160 16779 IERROR='YES' 16780 WRITE(ICOUT,999) 16781 CALL DPWRST('XXX','BUG ') 16782 WRITE(ICOUT,1151) 16783 1151 FORMAT('***** ERROR IN DPSECL--') 16784 CALL DPWRST('XXX','BUG ') 16785 WRITE(ICOUT,1152) 16786 1152 FORMAT(' IN THE SEGMENT ... COLOR COMMAND,') 16787 CALL DPWRST('XXX','BUG ') 16788 WRITE(ICOUT,1153) 16789 1153 FORMAT(' THE NUMBER OF SEGMENTS MUST BE ') 16790 CALL DPWRST('XXX','BUG ') 16791 WRITE(ICOUT,1154)MAXSEG 16792 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') 16793 CALL DPWRST('XXX','BUG ') 16794 WRITE(ICOUT,1155) 16795 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') 16796 CALL DPWRST('XXX','BUG ') 16797 WRITE(ICOUT,1156)I 16798 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 16799 1'SEGMENT.') 16800 CALL DPWRST('XXX','BUG ') 16801 GOTO1199 16802C 16803 1160 CONTINUE 16804 IF(NUMARG.LE.2)GOTO1170 16805 IF(IHARG(3).EQ.'ON')GOTO1170 16806 IF(IHARG(3).EQ.'OFF')GOTO1170 16807 IF(IHARG(3).EQ.'AUTO')GOTO1170 16808 IF(IHARG(3).EQ.'DEFA')GOTO1170 16809 GOTO1175 16810C 16811 1170 CONTINUE 16812 IHOLD=IDEFCO 16813 GOTO1180 16814C 16815 1175 CONTINUE 16816 IHOLD=IHARG(3) 16817 GOTO1180 16818C 16819 1180 CONTINUE 16820 IFOUND='YES' 16821 ISEGCO(I)=IHOLD 16822C 16823 IF(IFEEDB.EQ.'OFF')GOTO1189 16824 WRITE(ICOUT,999) 16825 CALL DPWRST('XXX','BUG ') 16826 WRITE(ICOUT,1186)I,ISEGCO(I) 16827 1186 FORMAT('THE COLOR FOR SEGMENT ',I8, 16828 1' HAS JUST BEEN SET TO ',A4) 16829 CALL DPWRST('XXX','BUG ') 16830 1189 CONTINUE 16831 GOTO1199 16832C 16833 1199 CONTINUE 16834 RETURN 16835 END 16836 SUBROUTINE DPSECO(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 16837 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,IANS,IWIDTH, 16838 1MAXSEG,PSEGXC,PSEGYC,NUMSEG,IBUGP2,IFOUND,IERROR) 16839C 16840C PURPOSE--DEFINE THE 2 PAIRS OF (X,Y) COORDINATES 16841C FOR A LINE SEGMENT. 16842C THE FIRST PAIR WILL BE FOR THE TAIL OF THE SEGMENT; 16843C THE SECOND PAIR WILL BE FOR THE HEAD OF THE SEGMENT. 16844C THE (X1,Y1), (X2,Y2) COORDINATES WILL BE PLACED IN THE 16845C FIRST AND SECOND ELEMENTS (RESPECTIVELY) OF 16846C THE 2 SEGAYS PSEGXC(.,.) AND PSEGYC(.,.) 16847C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 16848C --IARGT (A HOLLERITH VECTOR) 16849C --IARG (A HOLLERITH VECTOR) 16850C --ARG (A HOLLERITH VECTOR) 16851C --NUMARG 16852C --MAXSEG 16853C OUTPUT ARGUMENTS--PSEGXC (A FLOATING POINT VECTOR 16854C WHOSE (I,1)-TH ELEMENT CONTAINS THE 16855C X COORDINATE FOR THE TAIL OF SEGMENT I; 16856C WHOSE (I,2)-TH ELEMENT CONTAINS THE 16857C X COORDINATE FOR THE HEAD OF SEGMENT I; 16858C --PSEGYC (A FLOATING POINT VECTOR 16859C WHOSE (I,1)-TH ELEMENT CONTAINS THE 16860C Y COORDINATE FOR THE TAIL OF SEGMENT I; 16861C WHOSE (I,2)-TH ELEMENT CONTAINS THE 16862C Y COORDINATE FOR THE HEAD OF SEGMENT I; 16863C --NUMSEG = THE NUMBER OF SEGMENTS DEFINED SO FAR 16864C (ACTUALLY, THE HIGHEST REFERENCED SEGMENT SO FAR) 16865C --IFOUND ('YES' OR 'NO' ) 16866C --IERROR ('YES' OR 'NO' ) 16867C WRITTEN BY--JAMES J. FILLIBEN 16868C STATISTICAL ENGINEERING DIVISION 16869C INFORMATION TECHNOLOGY LABORATORY 16870C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 16871C GAITHERSBURG, MD 20899-8980 16872C PHONE--301-975-2899 16873C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16874C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 16875C LANGUAGE--ANSI FORTRAN (1977) 16876C VERSION NUMBER--82/7 16877C ORIGINAL VERSION--SEPTEMBER 1980. 16878C UPDATED --MARCH 1981. 16879C UPDATED --MAY 1982. 16880C 16881C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16882C 16883 CHARACTER*4 IHARG 16884 CHARACTER*4 IHARG2 16885 CHARACTER*4 IARGT 16886 CHARACTER*4 IHNAME 16887 CHARACTER*4 IHNAM2 16888 CHARACTER*4 IUSE 16889 CHARACTER*4 IANS 16890 CHARACTER*4 IBUGP2 16891 CHARACTER*4 IFOUND 16892 CHARACTER*4 IERROR 16893C 16894 CHARACTER*4 IHWUSE 16895 CHARACTER*4 MESSAG 16896 CHARACTER*4 IHWORD 16897 CHARACTER*4 IHWOR2 16898C 16899 CHARACTER*4 ISUBN1 16900 CHARACTER*4 ISUBN2 16901C 16902C--------------------------------------------------------------------- 16903C 16904 DIMENSION IHARG(*) 16905 DIMENSION IHARG2(*) 16906 DIMENSION IARGT(*) 16907 DIMENSION IARG(*) 16908 DIMENSION ARG(*) 16909C 16910 DIMENSION IHNAME(*) 16911 DIMENSION IHNAM2(*) 16912 DIMENSION IUSE(*) 16913 DIMENSION IN(*) 16914 DIMENSION IVALUE(*) 16915 DIMENSION VALUE(*) 16916 DIMENSION IANS(*) 16917C 16918 DIMENSION PSEGXC(100,2) 16919 DIMENSION PSEGYC(100,2) 16920C 16921C-----COMMON---------------------------------------------------------- 16922C 16923 INCLUDE 'DPCOP2.INC' 16924C 16925C-----START POINT----------------------------------------------------- 16926C 16927 ISUBN1='DPAR' 16928 ISUBN2='CO ' 16929 IFOUND='NO' 16930 IERROR='NO' 16931C 16932 HOLD1=0.0 16933 HOLD2=0.0 16934 HOLD3=0.0 16935 HOLD4=0.0 16936C 16937 IF(NUMARG.EQ.0)GOTO9000 16938 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COOR')GOTO1110 16939 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'COOR')GOTO1140 16940 GOTO9000 16941C 16942 1110 CONTINUE 16943 IF(NUMARG.LE.1)GOTO1120 16944 IF(IHARG(2).EQ.'ON')GOTO1120 16945 IF(IHARG(2).EQ.'OFF')GOTO1120 16946 IF(IHARG(2).EQ.'AUTO')GOTO1120 16947 IF(IHARG(2).EQ.'DEFA')GOTO1120 16948 IF(NUMARG.GE.5)GOTO1125 16949C 16950 IERROR='YES' 16951 WRITE(ICOUT,999) 16952 999 FORMAT(1X) 16953 CALL DPWRST('XXX','BUG ') 16954 WRITE(ICOUT,1111) 16955 1111 FORMAT('***** ERROR IN DPSECO--') 16956 CALL DPWRST('XXX','BUG ') 16957 WRITE(ICOUT,1112) 16958 1112 FORMAT(' IN THE SEGMENT ... COORDINATES COMMAND,') 16959 CALL DPWRST('XXX','BUG ') 16960 WRITE(ICOUT,1113) 16961 1113 FORMAT(' THE COORDINATES ARE SPECIFIED BY 4 NUMBERS, ', 16962 1'AS IN--') 16963 CALL DPWRST('XXX','BUG ') 16964 WRITE(ICOUT,1114) 16965 1114 FORMAT(' SEGMENT 3 COORDINATES 30 80 31 79') 16966 CALL DPWRST('XXX','BUG ') 16967 GOTO9000 16968C 16969 1120 CONTINUE 16970 HOLD1=CPUMIN 16971 HOLD2=CPUMIN 16972 HOLD3=CPUMIN 16973 HOLD4=CPUMIN 16974 NUMSEG=0 16975 GOTO1130 16976C 16977 1125 CONTINUE 16978 DO1126J=2,5 16979 IF(IARGT(J).EQ.'NUMB')GOTO1127 16980 GOTO1128 16981 1127 CONTINUE 16982 IF(J.EQ.2)HOLD1=ARG(J) 16983 IF(J.EQ.3)HOLD2=ARG(J) 16984 IF(J.EQ.4)HOLD3=ARG(J) 16985 IF(J.EQ.5)HOLD4=ARG(J) 16986 GOTO1126 16987 1128 CONTINUE 16988 IHWORD=IHARG(J) 16989 IHWOR2=IHARG2(J) 16990 IHWUSE='P' 16991 MESSAG='YES' 16992 CALL CHECKN(IHWORD,IHWOR2,IHWUSE, 16993 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 16994 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) 16995 IF(IERROR.EQ.'YES')GOTO9000 16996 IF(J.EQ.2)HOLD1=VALUE(ILOC) 16997 IF(J.EQ.3)HOLD2=VALUE(ILOC) 16998 IF(J.EQ.4)HOLD3=VALUE(ILOC) 16999 IF(J.EQ.5)HOLD4=VALUE(ILOC) 17000 1126 CONTINUE 17001 NUMSEG=MAXSEG 17002 GOTO1130 17003C 17004 1130 CONTINUE 17005 IFOUND='YES' 17006 DO1135I=1,MAXSEG 17007 PSEGXC(I,1)=HOLD1 17008 PSEGYC(I,1)=HOLD2 17009 PSEGXC(I,2)=HOLD3 17010 PSEGYC(I,2)=HOLD4 17011 1135 CONTINUE 17012C 17013 IF(IFEEDB.EQ.'OFF')GOTO1139 17014 WRITE(ICOUT,999) 17015 CALL DPWRST('XXX','BUG ') 17016 I=1 17017 WRITE(ICOUT,1136) 17018 1136 FORMAT('ALL SEGMENT COORDINATES HAVE JUST BEEN SET TO--') 17019 CALL DPWRST('XXX','BUG ') 17020 WRITE(ICOUT,1137)PSEGXC(I,1),PSEGYC(I,1) 17021 1137 FORMAT(' (X,Y) FOR TAIL OF SEGMENT = ',2E15.7) 17022 CALL DPWRST('XXX','BUG ') 17023 WRITE(ICOUT,1138)PSEGXC(I,2),PSEGYC(I,2) 17024 1138 FORMAT(' (X,Y) FOR HEAD OF SEGMENT = ',2E15.7) 17025 CALL DPWRST('XXX','BUG ') 17026 1139 CONTINUE 17027 GOTO9000 17028C 17029 1140 CONTINUE 17030 IF(IARGT(1).EQ.'NUMB')GOTO1150 17031 IERROR='YES' 17032 WRITE(ICOUT,999) 17033 CALL DPWRST('XXX','BUG ') 17034 WRITE(ICOUT,1141) 17035 1141 FORMAT('***** ERROR IN DPSECO--') 17036 CALL DPWRST('XXX','BUG ') 17037 WRITE(ICOUT,1142) 17038 1142 FORMAT(' IN THE SEGMENT ... COORDINATES COMMAND,') 17039 CALL DPWRST('XXX','BUG ') 17040 WRITE(ICOUT,1143) 17041 1143 FORMAT(' THE SEGMENT IS IDENTIFIED BY A NUMBER, AS IN--') 17042 CALL DPWRST('XXX','BUG ') 17043 WRITE(ICOUT,1144) 17044 1144 FORMAT(' SEGMENT 3 COORDINATES 30 80 31 79') 17045 CALL DPWRST('XXX','BUG ') 17046 GOTO9000 17047C 17048 1150 CONTINUE 17049 I=IARG(1) 17050 IF(1.LE.I.AND.I.LE.MAXSEG)GOTO1160 17051 IERROR='YES' 17052 WRITE(ICOUT,999) 17053 CALL DPWRST('XXX','BUG ') 17054 WRITE(ICOUT,1151) 17055 1151 FORMAT('***** ERROR IN DPSECO--') 17056 CALL DPWRST('XXX','BUG ') 17057 WRITE(ICOUT,1152) 17058 1152 FORMAT(' IN THE SEGMENT ... COORDINATES COMMAND,') 17059 CALL DPWRST('XXX','BUG ') 17060 WRITE(ICOUT,1153) 17061 1153 FORMAT(' THE NUMBER OF SEGMENTS MUST BE ') 17062 CALL DPWRST('XXX','BUG ') 17063 WRITE(ICOUT,1154)MAXSEG 17064 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') 17065 CALL DPWRST('XXX','BUG ') 17066 WRITE(ICOUT,1155) 17067 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') 17068 CALL DPWRST('XXX','BUG ') 17069 WRITE(ICOUT,1156)I 17070 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 17071 1'SEGMENT.') 17072 CALL DPWRST('XXX','BUG ') 17073 GOTO9000 17074C 17075 1160 CONTINUE 17076 IF(NUMARG.LE.2)GOTO1170 17077 IF(IHARG(3).EQ.'ON')GOTO1170 17078 IF(IHARG(3).EQ.'OFF')GOTO1170 17079 IF(IHARG(3).EQ.'AUTO')GOTO1170 17080 IF(IHARG(3).EQ.'DEFA')GOTO1170 17081 IF(NUMARG.GE.6)GOTO1175 17082 IERROR='YES' 17083 WRITE(ICOUT,999) 17084 CALL DPWRST('XXX','BUG ') 17085 WRITE(ICOUT,1111) 17086 CALL DPWRST('XXX','BUG ') 17087 WRITE(ICOUT,1112) 17088 CALL DPWRST('XXX','BUG ') 17089 WRITE(ICOUT,1113) 17090 CALL DPWRST('XXX','BUG ') 17091 WRITE(ICOUT,1114) 17092 CALL DPWRST('XXX','BUG ') 17093 GOTO9000 17094C 17095 1170 CONTINUE 17096 HOLD1=CPUMIN 17097 HOLD2=CPUMIN 17098 HOLD3=CPUMIN 17099 HOLD4=CPUMIN 17100 IF(I.EQ.NUMSEG)NUMSEG=I-1 17101 GOTO1180 17102C 17103 1175 CONTINUE 17104 DO1176J=3,6 17105 IF(IARGT(J).EQ.'NUMB')GOTO1177 17106 GOTO1178 17107 1177 CONTINUE 17108 IF(J.EQ.3)HOLD1=ARG(J) 17109 IF(J.EQ.4)HOLD2=ARG(J) 17110 IF(J.EQ.5)HOLD3=ARG(J) 17111 IF(J.EQ.6)HOLD4=ARG(J) 17112 GOTO1176 17113 1178 CONTINUE 17114 IHWORD=IHARG(J) 17115 IHWOR2=IHARG2(J) 17116 IHWUSE='P' 17117 MESSAG='YES' 17118 CALL CHECKN(IHWORD,IHWOR2,IHWUSE, 17119 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 17120 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) 17121 IF(IERROR.EQ.'YES')GOTO9000 17122 IF(J.EQ.3)HOLD1=VALUE(ILOC) 17123 IF(J.EQ.4)HOLD2=VALUE(ILOC) 17124 IF(J.EQ.5)HOLD3=VALUE(ILOC) 17125 IF(J.EQ.6)HOLD4=VALUE(ILOC) 17126 1176 CONTINUE 17127 IF(I.GT.NUMSEG)NUMSEG=I 17128 GOTO1180 17129C 17130 1180 CONTINUE 17131 IFOUND='YES' 17132 PSEGXC(I,1)=HOLD1 17133 PSEGYC(I,1)=HOLD2 17134 PSEGXC(I,2)=HOLD3 17135 PSEGYC(I,2)=HOLD4 17136C 17137 IF(IFEEDB.EQ.'OFF')GOTO1189 17138 WRITE(ICOUT,999) 17139 CALL DPWRST('XXX','BUG ') 17140 WRITE(ICOUT,1186)I 17141 1186 FORMAT('THE COORDINATES FOR SEGMENT ',I8, 17142 1' HAVE JUST BEEN SET TO--') 17143 CALL DPWRST('XXX','BUG ') 17144 WRITE(ICOUT,1137)PSEGXC(I,1),PSEGYC(I,1) 17145 CALL DPWRST('XXX','BUG ') 17146 WRITE(ICOUT,1138)PSEGXC(I,2),PSEGYC(I,2) 17147 CALL DPWRST('XXX','BUG ') 17148 1189 CONTINUE 17149 GOTO9000 17150C 17151C ***************** 17152C ** STEP 90-- ** 17153C ** EXIT ** 17154C ***************** 17155C 17156 9000 CONTINUE 17157 IF(IBUGP2.EQ.'OFF')GOTO9090 17158 WRITE(ICOUT,999) 17159 CALL DPWRST('XXX','BUG ') 17160 WRITE(ICOUT,9011) 17161 9011 FORMAT('***** AT THE END OF DPSECO--') 17162 CALL DPWRST('XXX','BUG ') 17163 WRITE(ICOUT,9012)IFOUND,IERROR 17164 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 17165 CALL DPWRST('XXX','BUG ') 17166 9090 CONTINUE 17167C 17168 RETURN 17169 END 17170 SUBROUTINE DPSEED(IHARG,IARGT,IARG,NUMARG,IDEFSE, 17171 1ISEED,IFOUND,IERROR) 17172C 17173C PURPOSE--DEFINE THE SEED (AN INTEGER) 17174C WHICH IS USED AS INPUT IN UNIFORM RANDOM NUMBER GENERATION AND 17175C WHICH IN TURN SERVES AS THE BASIS FOR ALL RANDOM NUMBER GENERATIO 17176C THE SPECIFIED SEED VALUE WILL BE PLACED 17177C IN THE INTEGER VARIABLE ISEED. 17178C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 17179C --IARGT (A HOLLERITH VECTOR) 17180C --ARG (A FLOATING POINT VECTOR) 17181C --NUMARG (AN INTEGER VARIABLE) 17182C --IDEFSE (A FLOATING POINT VARIABLE) 17183C OUTPUT ARGUMENTS--ISEED (AN INTEGER VARIABLE) 17184C --IFOUND ('YES' OR 'NO' ) 17185C --IERROR ('YES' OR 'NO' ) 17186C WRITTEN BY--JAMES J. FILLIBEN 17187C STATISTICAL ENGINEERING DIVISION 17188C INFORMATION TECHNOLOGY LABORATORY 17189C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 17190C GAITHERSBURG, MD 20899-8980 17191C PHONE--301-975-2899 17192C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 17193C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 17194C LANGUAGE--ANSI FORTRAN (1977) 17195C VERSION NUMBER--82/7 17196C ORIGINAL VERSION--APRIL 1982. 17197C UPDATED --MAY 1982. 17198C 17199C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 17200C 17201 CHARACTER*4 IHARG 17202 CHARACTER*4 IARGT 17203 CHARACTER*4 IFOUND 17204 CHARACTER*4 IERROR 17205C 17206C--------------------------------------------------------------------- 17207C 17208 DIMENSION IHARG(*) 17209 DIMENSION IARGT(*) 17210 DIMENSION IARG(*) 17211C 17212C-----COMMON---------------------------------------------------------- 17213C 17214 INCLUDE 'DPCOP2.INC' 17215C 17216C-----START POINT----------------------------------------------------- 17217C 17218 IFOUND='NO' 17219 IERROR='NO' 17220C 17221 IF(NUMARG.LE.0)GOTO1150 17222 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 17223 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 17224 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 17225 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 17226 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 17227 GOTO1120 17228C 17229 1120 CONTINUE 17230 IERROR='YES' 17231 WRITE(ICOUT,999) 17232 999 FORMAT(1X) 17233 CALL DPWRST('XXX','BUG ') 17234 WRITE(ICOUT,1121) 17235 1121 FORMAT('***** ERROR IN DPSEED--') 17236 CALL DPWRST('XXX','BUG ') 17237 WRITE(ICOUT,1122) 17238 1122 FORMAT(' ILLEGAL FORM FOR SEED ', 17239 1'COMMAND.') 17240 CALL DPWRST('XXX','BUG ') 17241 WRITE(ICOUT,1124) 17242 1124 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 17243 1'PROPER FORM--') 17244 CALL DPWRST('XXX','BUG ') 17245 WRITE(ICOUT,1125) 17246 1125 FORMAT(' SUPPOSE THE ANALYST DESIRES THE ') 17247 CALL DPWRST('XXX','BUG ') 17248 WRITE(ICOUT,1126) 17249 1126 FORMAT(' SEED VALUE FOR RANDOM NUMBER GENERATION') 17250 CALL DPWRST('XXX','BUG ') 17251 WRITE(ICOUT,1127) 17252 1127 FORMAT(' TO BE 735679238,') 17253 CALL DPWRST('XXX','BUG ') 17254 WRITE(ICOUT,1129) 17255 1129 FORMAT(' THEN THE ALLOWABLE FORM IS--') 17256 CALL DPWRST('XXX','BUG ') 17257 WRITE(ICOUT,1130) 17258 1130 FORMAT(' SEED 735679238 ') 17259 CALL DPWRST('XXX','BUG ') 17260 GOTO1199 17261C 17262 1150 CONTINUE 17263 IHOLD=IDEFSE 17264 GOTO1180 17265C 17266 1160 CONTINUE 17267 IHOLD=IARG(NUMARG) 17268 GOTO1180 17269C 17270 1180 CONTINUE 17271 IFOUND='YES' 17272 ISEED=IHOLD 17273C 17274 IF(IFEEDB.EQ.'OFF')GOTO1189 17275 WRITE(ICOUT,999) 17276 CALL DPWRST('XXX','BUG ') 17277 WRITE(ICOUT,1181)ISEED 17278 1181 FORMAT('THE RANDOM NUMBER SEED HAS JUST BEEN SET TO ', 17279 1I11) 17280 CALL DPWRST('XXX','BUG ') 17281 1189 CONTINUE 17282 GOTO1199 17283C 17284 1199 CONTINUE 17285 RETURN 17286 END 17287