1 SUBROUTINE DPC4HI(IHVAL,IVAL,IBUGA3,IERROR) 2C 3C PURPOSE--CONVERT A CHARACTER VARIABLE 4C INTO THE CORRESPONDING INTEGER VALUE. 5C NOTE--INASMUCH AS THE ASSUMED INPUT WORD HAS 4 CHARACTERS AT MOST, 6C THEN THE VALID RANGE OF THE OUTPUT INTEGER VARIABLE 7C IS -999 TO 9999 . 8C 9C WRITTEN BY--JAMES J. FILLIBEN 10C STATISTICAL ENGINEERING DIVISION 11C INFORMATION TECHNOLOGY LABORATORY 12C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13C GAITHERSBURG, MD 20899-8980 14C PHONE--301-975-2899 15C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 17C LANGUAGE--ANSI FORTRAN (1977) 18C VERSION NUMBER--82/7 19C ORIGINAL VERSION--JANUARY 1981. 20C UPDATED --MAY 1982. 21C 22C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 23C 24 CHARACTER*4 IHVAL 25 CHARACTER*4 IBUGA3 26 CHARACTER*4 IERROR 27C 28 CHARACTER*4 IHTEMP 29 CHARACTER*4 ISIGN 30C 31C--------------------------------------------------------------------- 32C 33 DIMENSION IHTEMP(4) 34C 35C--------------------------------------------------------------------- 36C 37 INCLUDE 'DPCOP2.INC' 38C 39C-----START POINT----------------------------------------------------- 40C 41 IERROR='NO' 42 NUMASC=4 43 IVAL=0 44C 45 ITERM=0 46C 47 IF(IBUGA3.EQ.'OFF')GOTO90 48 WRITE(ICOUT,999) 49 CALL DPWRST('XXX','BUG ') 50 WRITE(ICOUT,51) 51 51 FORMAT('***** AT THE BEGINNING OF DPC4HI--') 52 CALL DPWRST('XXX','BUG ') 53 WRITE(ICOUT,52)IHVAL,IBUGA3,IERROR 54 52 FORMAT('IHVAL,IBUGA3,IERROR = ',A4,2X,A4,2X,A4) 55 CALL DPWRST('XXX','BUG ') 56 90 CONTINUE 57C 58C ******************************************* 59C ** STEP 1-- ** 60C ** DECOMPOSE THE 4-CHARACTERS IN IHVAL ** 61C ** INTO 4 1-CHARACTER WORDS. ** 62C ******************************************* 63C 64 DO200J=1,NUMASC 65 IHTEMP(J)=' ' 66 ISTAR1=NUMBPC*(J-1) 67 CALL DPCHEX(ISTAR1,NUMBPC,IHVAL,0,NUMBPC,IHTEMP(J)) 68 200 CONTINUE 69C 70C ****************************************************** 71C ** STEP 2-- ** 72C ** CARRY OUT THE HOLLERITH TO INTEGER CONVERSION. ** 73C ****************************************************** 74C 75 ISIGN='+' 76 NUMSIG=0 77 IDIGI=0 78 ISUM=0 79 DO400I=1,NUMASC 80 IREV=NUMASC-I+1 81 IF(IHTEMP(IREV).EQ.' ')GOTO400 82 IF(IHTEMP(IREV).EQ.'0')GOTO410 83 IF(IHTEMP(IREV).EQ.'1')GOTO411 84 IF(IHTEMP(IREV).EQ.'2')GOTO412 85 IF(IHTEMP(IREV).EQ.'3')GOTO413 86 IF(IHTEMP(IREV).EQ.'4')GOTO414 87 IF(IHTEMP(IREV).EQ.'5')GOTO415 88 IF(IHTEMP(IREV).EQ.'6')GOTO416 89 IF(IHTEMP(IREV).EQ.'7')GOTO417 90 IF(IHTEMP(IREV).EQ.'8')GOTO418 91 IF(IHTEMP(IREV).EQ.'9')GOTO419 92 IF(IHTEMP(IREV).EQ.'+')GOTO420 93 IF(IHTEMP(IREV).EQ.'-')GOTO421 94C 95 WRITE(ICOUT,999) 96 CALL DPWRST('XXX','BUG ') 97 WRITE(ICOUT,431) 98 431 FORMAT('***** ERROR IN DPC4HI--') 99 CALL DPWRST('XXX','BUG ') 100 WRITE(ICOUT,432) 101 432 FORMAT(' CHARACTER ENCOUNTERED IN THE CONVERSION') 102 CALL DPWRST('XXX','BUG ') 103 WRITE(ICOUT,433) 104 433 FORMAT(' WHICH WAS NOT 0 THROUGH 9, +, - OR SPACE.') 105 CALL DPWRST('XXX','BUG ') 106 WRITE(ICOUT,434)IHTEMP(IREV) 107 434 FORMAT(' CHARACTER IN QUESTION IHTEMP(IREV) = ',A4) 108 CALL DPWRST('XXX','BUG ') 109 WRITE(ICOUT,435)IHVAL 110 435 FORMAT(' IHVAL = ',A4) 111 CALL DPWRST('XXX','BUG ') 112 IERROR='YES' 113 GOTO9000 114C 115 410 ITERM=0 116 GOTO425 117 411 ITERM=1 118 GOTO425 119 412 ITERM=2 120 GOTO425 121 413 ITERM=3 122 GOTO425 123 414 ITERM=4 124 GOTO425 125 415 ITERM=5 126 GOTO425 127 416 ITERM=6 128 GOTO425 129 417 ITERM=7 130 GOTO425 131 418 ITERM=8 132 GOTO425 133 419 ITERM=9 134 GOTO425 135 420 NUMSIG=NUMSIG+1 136 GOTO400 137 421 NUMSIG=NUMSIG+1 138 ISIGN='-' 139 GOTO400 140 425 IDIGI=IDIGI+1 141 IEXP=IDIGI-1 142CCCCC ISUM=ISUM+ITERM*(10**IEXP) 143 IJUNK=INT(10.0**IEXP + 0.01) 144 ISUM=ISUM+ITERM*IJUNK 145 400 CONTINUE 146C 147 IF(NUMSIG.LE.1)GOTO459 148 WRITE(ICOUT,999) 149 CALL DPWRST('XXX','BUG ') 150 WRITE(ICOUT,451) 151 451 FORMAT('***** ERROR IN DPC4HI--') 152 CALL DPWRST('XXX','BUG ') 153 WRITE(ICOUT,452) 154 452 FORMAT(' MULTIPLE SIGNS (+/-) ENCOUNTERED') 155 CALL DPWRST('XXX','BUG ') 156 WRITE(ICOUT,453) 157 453 FORMAT(' IN THE CONVERSION.') 158 CALL DPWRST('XXX','BUG ') 159 WRITE(ICOUT,454)NUMSIG 160 454 FORMAT(' NUMBER OF SIGNS NUMSIG = ',I8) 161 CALL DPWRST('XXX','BUG ') 162 WRITE(ICOUT,456)(IHTEMP(J),J=1,NUMASC) 163 456 FORMAT(' (IHTEMP(J),J=1,NUMASC) = ',4A4) 164 CALL DPWRST('XXX','BUG ') 165 WRITE(ICOUT,457)IHVAL 166 457 FORMAT(' IHVAL = ',A4) 167 CALL DPWRST('XXX','BUG ') 168 IERROR='YES' 169 GOTO9000 170 459 CONTINUE 171 IF(ISIGN.EQ.'-')ISUM=-ISUM 172 IVAL=ISUM 173C 174C **************** 175C ** STEP 90-- ** 176C ** EXIT. ** 177C **************** 178C 179 9000 CONTINUE 180 IF(IBUGA3.EQ.'OFF')GOTO9090 181 WRITE(ICOUT,999) 182 999 FORMAT(1X) 183 CALL DPWRST('XXX','BUG ') 184 WRITE(ICOUT,9011) 185 9011 FORMAT('***** AT THE END OF DPC4HI--') 186 CALL DPWRST('XXX','BUG ') 187 WRITE(ICOUT,9012)IHVAL 188 9012 FORMAT('IHVAL = ',A4) 189 CALL DPWRST('XXX','BUG ') 190 WRITE(ICOUT,9014)(IHTEMP(J),J=1,NUMASC) 191 9014 FORMAT('(IHTEMP(J),J=1,NUMASC) = ',4A4) 192 CALL DPWRST('XXX','BUG ') 193 WRITE(ICOUT,9015)NUMASC,ISIGN,NUMSIG,ISUM,ITERM 194 9015 FORMAT('NUMASC,ISIGN,NUMSIG,ISUM,ITERM = ',I8,2X,A4,3I8) 195 CALL DPWRST('XXX','BUG ') 196 WRITE(ICOUT,9016)IBUGA3,IERROR 197 9016 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 198 CALL DPWRST('XXX','BUG ') 199 WRITE(ICOUT,9017)IVAL 200 9017 FORMAT('IVAL = ',I8) 201 CALL DPWRST('XXX','BUG ') 202 9090 CONTINUE 203C 204 RETURN 205 END 206 SUBROUTINE DPC4IH(IVAL,IHVAL,IBUGA3,IERROR) 207C 208C PURPOSE--CONVERT AN INTEGER VARIABLE 209C TO A 4-CHARACTER-PER-WORD HOLLERITH STRING. 210C NOTE--CONVERT ONLY THE FIRST 4 CHARACTERS OF THE 211C INTEGER VARIABLE (INCLUDING THE NEGATIVE 212C SIGN, IF EXISTENT). 213C NOTE--INCORRECT VALUERS WILL RESULT IF THE INPUT INTEGER 214C IS LARGER THAN 9999 OR SMALLER THAN -999 . 215C 216C WRITTEN BY--JAMES J. FILLIBEN 217C STATISTICAL ENGINEERING DIVISION 218C INFORMATION TECHNOLOGY LABORATORY 219C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 220C GAITHERSBURG, MD 20899-8980 221C PHONE--301-975-2899 222C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 223C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 224C LANGUAGE--ANSI FORTRAN (1977) 225C VERSION NUMBER--82/7 226C ORIGINAL VERSION--JANUARY 1981. 227C UPDATED --MARCH 1982. 228C UPDATED --MAY 1982. 229C 230C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 231C 232 CHARACTER*4 IHVAL 233 CHARACTER*4 IBUGA3 234 CHARACTER*4 IERROR 235C 236 CHARACTER*4 IHTEMP 237 CHARACTER*4 ISIGN 238 CHARACTER*4 IHDIG 239C 240C--------------------------------------------------------------------- 241C 242 DIMENSION IHTEMP(4) 243C 244C--------------------------------------------------------------------- 245C 246 INCLUDE 'DPCOP2.INC' 247C 248C-----START POINT----------------------------------------------------- 249C 250 IERROR='NO' 251 NUMASC=4 252 IVAL2=IVAL 253 IHVAL=' ' 254C 255 IF(IBUGA3.EQ.'OFF')GOTO90 256 WRITE(ICOUT,999) 257 CALL DPWRST('XXX','BUG ') 258 WRITE(ICOUT,51) 259 51 FORMAT('***** AT THE BEGINNING OF DPC4IH--') 260 CALL DPWRST('XXX','BUG ') 261 WRITE(ICOUT,52)IVAL,IBUGA3,IERROR 262 52 FORMAT('IVAL,IBUGA3,IERROR = ',I8,2X,A4,2X,A4) 263 CALL DPWRST('XXX','BUG ') 264 90 CONTINUE 265C 266C *********************** 267C ** STEP 2-- ** 268C ** DETERMINE SIGN. ** 269C *********************** 270C 271 ISIGN='+' 272 IF(IVAL2.LT.0)ISIGN='-' 273 IVAL2=IABS(IVAL2) 274C 275C *********************************** 276C ** STEP 3-- ** 277C ** DETERMINE NUMBER OF DIGITS. ** 278C *********************************** 279C 280 IMIN=1 281 IMAX=NUMASC 282 DO300I=IMIN,IMAX 283 IREV=IMAX-I+IMIN 284 IDIV=INT(10.0**(IREV-1) + 0.01) 285 IDIG=IVAL2/IDIV 286 IF(IDIG.NE.0)GOTO350 287 300 CONTINUE 288 NUMDIG=1 289 GOTO390 290 350 CONTINUE 291 NUMDIG=IREV 292 390 CONTINUE 293C 294C *************************************** 295C ** STEP 4-- ** 296C ** IF NEGATIVE, ** 297C ** INSERT SIGN INTO OUTPUT VECTOR. ** 298C *************************************** 299C 300 J=0 301 IF(ISIGN.EQ.'-')J=J+1 302 IF(ISIGN.EQ.'-')IHTEMP(J)='-' 303C 304C ************************** 305C ** STEP 5-- ** 306C ** INSERT DIGITS INTO ** 307C ** OUTPUT VECTOR. ** 308C ************************** 309C 310 IMIN=1 311 IMAX=NUMDIG 312 IF(IMAX.GE.NUMASC.AND.ISIGN.EQ.'-')IMAX=NUMASC-1 313 IF(IMAX.GE.NUMASC.AND.ISIGN.EQ.'+')IMAX=NUMASC 314 DO500I=IMIN,IMAX 315 IREV=IMAX-I+IMIN 316 IDIV=INT(10.0**(IREV-1) + 0.01) 317 IDIG=IVAL2/IDIV 318C 319 IF(IDIG.EQ.0)GOTO510 320 IF(IDIG.EQ.1)GOTO511 321 IF(IDIG.EQ.2)GOTO512 322 IF(IDIG.EQ.3)GOTO513 323 IF(IDIG.EQ.4)GOTO514 324 IF(IDIG.EQ.5)GOTO515 325 IF(IDIG.EQ.6)GOTO516 326 IF(IDIG.EQ.7)GOTO517 327 IF(IDIG.EQ.8)GOTO518 328 IF(IDIG.EQ.9)GOTO519 329 510 CONTINUE 330 IHDIG='0' 331 GOTO529 332 511 CONTINUE 333 IHDIG='1' 334 GOTO529 335 512 CONTINUE 336 IHDIG='2' 337 GOTO529 338 513 CONTINUE 339 IHDIG='3' 340 GOTO529 341 514 CONTINUE 342 IHDIG='4' 343 GOTO529 344 515 CONTINUE 345 IHDIG='5' 346 GOTO529 347 516 CONTINUE 348 IHDIG='6' 349 GOTO529 350 517 CONTINUE 351 IHDIG='7' 352 GOTO529 353 518 CONTINUE 354 IHDIG='8' 355 GOTO529 356 519 CONTINUE 357 IHDIG='9' 358 GOTO529 359 529 CONTINUE 360C 361 J=J+1 362 IF(J.GT.NUMASC)GOTO550 363 IHTEMP(J)=IHDIG 364 IVAL2=IVAL2-IDIG*IDIV 365 500 CONTINUE 366C 367 NTEMP=J 368 GOTO590 369C 370 550 CONTINUE 371 NTEMP=J-1 372 GOTO590 373C 374 590 CONTINUE 375C 376C *************************************** 377C ** STEP 6-- ** 378C ** PACK THE CHARACTERS INTO 1 WORD ** 379C *************************************** 380C 381 IHVAL=' ' 382 IMAX=NUMASC 383 IF(NTEMP.LE.IMAX)IMAX=NTEMP 384 IF(IMAX.LE.0)GOTO690 385 DO600J=1,IMAX 386 ISTAR2=NUMBPC*(J-1) 387 CALL DPCHEX(0,NUMBPC,IHTEMP(J),ISTAR2,NUMBPC,IHVAL) 388 600 CONTINUE 389 690 CONTINUE 390C 391C **************** 392C ** STEP 90-- ** 393C ** EXIT. ** 394C **************** 395C 396 IF(IBUGA3.EQ.'ON')THEN 397 WRITE(ICOUT,999) 398 999 FORMAT(1X) 399 CALL DPWRST('XXX','BUG ') 400 WRITE(ICOUT,9011) 401 9011 FORMAT('***** AT THE END OF DPC4IH--') 402 CALL DPWRST('XXX','BUG ') 403 WRITE(ICOUT,9013)ISIGN,NUMDIG,NUMASC,IMAX,IVAL,NTEMP 404 9013 FORMAT('ISIGN,NUMDIG,NUMASC,IMAX,IVAL,NTEMP = ',A4,5I8) 405 CALL DPWRST('XXX','BUG ') 406 WRITE(ICOUT,9015)(IHTEMP(I),I=1,NTEMP) 407 9015 FORMAT('IHTEMP(.) = ',80A1) 408 CALL DPWRST('XXX','BUG ') 409 WRITE(ICOUT,9016)ISTAR2,IHVAL 410 9016 FORMAT('ISTAR2,IHVAL = ',I8,2X,A4) 411 CALL DPWRST('XXX','BUG ') 412 WRITE(ICOUT,9017)IBUGA3,IERROR 413 9017 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 414 CALL DPWRST('XXX','BUG ') 415 ENDIF 416C 417 RETURN 418 END 419 SUBROUTINE DPCAAN(XTEMP1,MAXNXT, 420 1 ICASAN,ICAPSW,IFORSW, 421 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 422C 423C PURPOSE--GENERATE A TABLE OF CAPABILITY ANALYSIS STATISTICS 424C WRITTEN BY--JAMES J. FILLIBEN 425C STATISTICAL ENGINEERING DIVISION 426C INFORMATION TECHNOLOGY LABORATORY 427C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 428C GAITHERSBURG, MD 20899-8980 429C PHONE--301-975-2899 430C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 431C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 432C LANGUAGE--ANSI FORTRAN (1977) 433C VERSION NUMBER--90/9 434C ORIGINAL VERSION--SEPTEMBER 1990. 435C UPDATED --APRIL 2001. 1) ARGUMENT LIST TO DPCAA2 436C 2) SAVE RESULTS FROM DPCAA2 437C AS INTERNAL PARAMETERS 438C UPDATED --MAY 2011. USE DPPARS 439C UPDATED --MAY 2011. SUPPORT FOR "MULTIPLE" AND 440C "REPLICATION" OPTIONS 441C UPDATED --JUNE 2019. TWEAK TO SCRATCH ARRAYS 442C 443C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 444C 445 CHARACTER*4 ICASAN 446 CHARACTER*4 ICAPSW 447 CHARACTER*4 IFORSW 448 CHARACTER*4 IBUGA2 449 CHARACTER*4 IBUGA3 450 CHARACTER*4 IBUGQ 451 CHARACTER*4 ISUBRO 452 CHARACTER*4 IFOUND 453 CHARACTER*4 IERROR 454C 455 CHARACTER*4 IHWUSE 456 CHARACTER*4 MESSAG 457 CHARACTER*4 IH 458 CHARACTER*4 IH2 459 CHARACTER*4 ISUBN1 460 CHARACTER*4 ISUBN2 461 CHARACTER*4 ISTEPN 462 CHARACTER*4 IREPL 463 CHARACTER*4 IMULT 464 CHARACTER*4 ICTMP1 465 CHARACTER*4 ICTMP2 466 CHARACTER*4 ICTMP3 467 CHARACTER*4 ICTMP4 468 CHARACTER*4 ICASE 469C 470C 471 CHARACTER*4 IFLAGU 472 LOGICAL IFRST 473 LOGICAL ILAST 474C 475 CHARACTER*40 INAME 476 PARAMETER (MAXSPN=30) 477 CHARACTER*4 IVARN1(MAXSPN) 478 CHARACTER*4 IVARN2(MAXSPN) 479 CHARACTER*4 IVARTY(MAXSPN) 480 CHARACTER*4 IVARID(1) 481 CHARACTER*4 IVARI2(1) 482 REAL PVAR(MAXSPN) 483 REAL PID(MAXSPN) 484 INTEGER ILIS(MAXSPN) 485 INTEGER NRIGHT(MAXSPN) 486 INTEGER ICOLR(MAXSPN) 487C 488C--------------------------------------------------------------------- 489C 490 INCLUDE 'DPCOPA.INC' 491C 492 DIMENSION XTEMP1(*) 493 DIMENSION W(MAXOBV) 494C 495 DIMENSION XDESGN(MAXOBV,7) 496 DIMENSION XIDTEM(MAXOBV) 497 DIMENSION XIDTE2(MAXOBV) 498 DIMENSION XIDTE3(MAXOBV) 499 DIMENSION XIDTE4(MAXOBV) 500 DIMENSION XIDTE5(MAXOBV) 501 DIMENSION XIDTE6(MAXOBV) 502C 503 DIMENSION TEMP1(MAXOBV) 504 DIMENSION TEMP2(MAXOBV) 505C 506 INCLUDE 'DPCOZZ.INC' 507C 508 EQUIVALENCE (GARBAG(IGARB1),TEMP1(1)) 509 EQUIVALENCE (GARBAG(IGARB2),XIDTEM(1)) 510 EQUIVALENCE (GARBAG(IGARB3),XIDTE2(1)) 511 EQUIVALENCE (GARBAG(IGARB4),XIDTE3(1)) 512 EQUIVALENCE (GARBAG(IGARB5),XIDTE4(1)) 513 EQUIVALENCE (GARBAG(IGARB6),XIDTE5(1)) 514 EQUIVALENCE (GARBAG(IGARB7),XIDTE6(1)) 515 EQUIVALENCE (GARBAG(IGARB8),TEMP2(1)) 516 EQUIVALENCE (GARBAG(IGARB9),W(1)) 517 EQUIVALENCE (GARBAG(IGAR10),XDESGN(1,1)) 518C 519C-----COMMON---------------------------------------------------------- 520C 521 INCLUDE 'DPCOHK.INC' 522 INCLUDE 'DPCODA.INC' 523 INCLUDE 'DPCOSU.INC' 524 INCLUDE 'DPCOST.INC' 525C 526C-----COMMON VARIABLES (GENERAL)-------------------------------------- 527C 528 INCLUDE 'DPCOP2.INC' 529C 530C-----START POINT----------------------------------------------------- 531C 532 IERROR='NO' 533 IFOUND='NO' 534 ICASAN='CAAN' 535 IREPL='OFF' 536 IMULT='OFF' 537 ISUBN1='DPCA' 538 ISUBN2='AN ' 539C 540 MAXCP1=MAXCOL+1 541 MAXCP2=MAXCOL+2 542 MAXCP3=MAXCOL+3 543 MAXCP4=MAXCOL+4 544 MAXCP5=MAXCOL+5 545 MAXCP6=MAXCOL+6 546C 547C *********************************************** 548C ** TREAT THE CAPABILITY ANALYSIS CASE ** 549C *********************************************** 550C 551 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CAAN')THEN 552 WRITE(ICOUT,999) 553 999 FORMAT(1X) 554 CALL DPWRST('XXX','BUG ') 555 WRITE(ICOUT,51) 556 51 FORMAT('***** AT THE BEGINNING OF DPCAAN--') 557 CALL DPWRST('XXX','BUG ') 558 WRITE(ICOUT,53)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT 559 53 FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT = ',4(A4,2X),I8) 560 CALL DPWRST('XXX','BUG ') 561 ENDIF 562C 563C ******************************************************** 564C ** STEP 1-- ** 565C ** EXTRACT THE COMMAND ** 566C ** LOOK FOR ONE OF THE FOLLOWING COMMANDS: ** 567C ** 1) CAPABILITY ANALYSIS Y ** 568C ** 2) MULTIPLE CAPABILITY ANALYSIS Y1 ... YK ** 569C ** 3) REPLICATED CAPABILITY ANALYSIS Y X1 ... XK ** 570C ******************************************************** 571C 572 ISTEPN='1' 573 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN') 574 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 575C 576 ILASTC=9999 577 ILASTZ=9999 578 ICASAN='CAAN' 579C 580 DO100I=0,NUMARG-1 581C 582 IF(I.EQ.0)THEN 583 ICTMP1=ICOM 584 ELSE 585 ICTMP1=IHARG(I) 586 ENDIF 587 ICTMP2=IHARG(I+1) 588 ICTMP3=IHARG(I+2) 589 ICTMP4=IHARG(I+3) 590C 591 IF(ICTMP1.EQ.'=')THEN 592 IFOUND='NO' 593 GOTO9000 594 ELSEIF(ICTMP1.EQ.'CAPA' .AND. ICTMP2.EQ.'ANAL')THEN 595 IFOUND='YES' 596 ICASAN='CAAN' 597 ILASTC=I+1 598 ILASTZ=I+1 599 ELSEIF(ICTMP1.EQ.'CAPA' .OR. ICTMP1.EQ.'CP' .OR. 600 1 ICTMP1.EQ.'CPK')THEN 601 IFOUND='YES' 602 ICASAN='CAAN' 603 ILASTC=I 604 ILASTZ=I 605 ELSEIF(ICTMP1.EQ.'REPL')THEN 606 IREPL='ON' 607 ILASTC=MIN(ILASTC,I) 608 ILASTZ=MAX(ILASTZ,I) 609 ELSEIF(ICTMP1.EQ.'MULT')THEN 610 IMULT='ON' 611 ILASTC=MIN(ILASTC,I) 612 ILASTZ=MAX(ILASTZ,I) 613 ENDIF 614 100 CONTINUE 615C 616 IF(IFOUND.EQ.'NO')GOTO9000 617C 618 ISHIFT=ILASTZ 619 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 620 1 IBUGA2,IERROR) 621C 622 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN')THEN 623 WRITE(ICOUT,91)ICASAN,IMULT,IREPL,ISHIFT 624 91 FORMAT('DPCAAN: ICASAN,IMULT,IREPL,ISHIFT = ',3(A4,2X),I5) 625 CALL DPWRST('XXX','BUG ') 626 ENDIF 627C 628 IF(IMULT.EQ.'ON')THEN 629 IF(IREPL.EQ.'ON')THEN 630 WRITE(ICOUT,999) 631 CALL DPWRST('XXX','BUG ') 632 WRITE(ICOUT,101) 633 101 FORMAT('***** ERROR IN CAPABILITY ANALYSIS--') 634 CALL DPWRST('XXX','BUG ') 635 WRITE(ICOUT,103) 636 103 FORMAT(' YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ', 637 1 '"REPLICATION"') 638 CALL DPWRST('XXX','BUG ') 639 WRITE(ICOUT,104) 640 104 FORMAT(' FOR THE CAPABILITY ANALYSIS COMMAND.') 641 CALL DPWRST('XXX','BUG ') 642 IERROR='YES' 643 GOTO9000 644 ENDIF 645 ENDIF 646C 647C ********************************* 648C ** STEP 4-- ** 649C ** EXTRACT THE VARIABLE LIST ** 650C ********************************* 651C 652 ISTEPN='4' 653 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN') 654 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 655C 656 INAME='CAPABILITY ANALYSIS' 657 MINNA=1 658 MAXNA=100 659 MINN2=2 660 IFLAGE=0 661 IFLAGM=1 662 IF(IREPL.EQ.'ON')THEN 663 IFLAGM=0 664 IFLAGE=1 665 ENDIF 666 IFLAGP=0 667 JMIN=1 668 JMAX=NUMARG 669 MINNVA=1 670 MAXNVA=MAXSPN 671C 672 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 673 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 674 1 JMIN,JMAX, 675 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 676 1 IVARN1,IVARN2,IVARTY,PVAR, 677 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 678 1 MINNVA,MAXNVA, 679 1 IFLAGM,IFLAGP, 680 1 IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 681 IF(IERROR.EQ.'YES')GOTO9000 682C 683 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN')THEN 684 WRITE(ICOUT,999) 685 CALL DPWRST('XXX','BUG ') 686 WRITE(ICOUT,281) 687 281 FORMAT('***** AFTER CALL DPPARS--') 688 CALL DPWRST('XXX','BUG ') 689 WRITE(ICOUT,282)NQ,NUMVAR 690 282 FORMAT('NQ,NUMVAR = ',2I8) 691 CALL DPWRST('XXX','BUG ') 692 IF(NUMVAR.GT.0)THEN 693 DO285I=1,NUMVAR 694 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 695 1 ICOLR(I) 696 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 697 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 698 CALL DPWRST('XXX','BUG ') 699 285 CONTINUE 700 ENDIF 701 ENDIF 702C 703C *********************************************** 704C ** STEP 5-- ** 705C ** DETERMINE: ** 706C ** 1) NUMBER OF REPLICATION VARIABLES (0-6) ** 707C ** 2) NUMBER OF RESPONSE VARIABLES (>= 1)** 708C *********************************************** 709C 710 ISTEPN='5' 711 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN') 712 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 713C 714 NREPL=0 715 NRESP=0 716 IF(IREPL.EQ.'ON')THEN 717 NRESP=1 718 NREPL=NUMVAR-NRESP 719 IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN 720 WRITE(ICOUT,999) 721 CALL DPWRST('XXX','BUG ') 722 WRITE(ICOUT,101) 723 CALL DPWRST('XXX','BUG ') 724 WRITE(ICOUT,511) 725 511 FORMAT(' FOR THE REPLICATION CASE, THE NUMBER OF ', 726 1 'REPLICATION VARIABLES') 727 CALL DPWRST('XXX','BUG ') 728 WRITE(ICOUT,512) 729 512 FORMAT(' MUST BE BETWEEN ONE AND SIX.') 730 CALL DPWRST('XXX','BUG ') 731 WRITE(ICOUT,513)NREPL 732 513 FORMAT(' THE NUMBER OF REPLICATION VARIABLES = ',I5) 733 CALL DPWRST('XXX','BUG ') 734 IERROR='YES' 735 GOTO9000 736 ENDIF 737 ELSE 738 NRESP=NUMVAR 739 IMULT='ON' 740 ENDIF 741C 742 DO519I=1,MAXOBV 743 W(I)=1.0 744 519 CONTINUE 745C 746 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN')THEN 747 WRITE(ICOUT,521)NRESP,NREPL 748 521 FORMAT('NRESP,NREPL = ',2I5) 749 CALL DPWRST('XXX','BUG ') 750 ENDIF 751C 752C ********************************************* 753C ** STEP 7-- ** 754C ** DETERMINE IF THE ANALYST ** 755C ** HAS SPECIFIED ** 756C ** LSL (LOWER SPEC LIMIT) ** 757C ** USL (UPPER SPEC LIMIT) ** 758C ** USLCOST (UPPER SPEC LIMIT COST) ** 759C ** TARGET ** 760C ********************************************* 761C 762 ISTEPN='7' 763 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN') 764 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 765C 766 CCLSL=CPUMIN 767 IH='LSL ' 768 IH2=' ' 769 IHWUSE='P' 770 MESSAG='NO' 771 CALL CHECKN(IH,IH2,IHWUSE, 772 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 773 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 774 IF(IERROR.EQ.'NO')CCLSL=VALUE(ILOCP) 775C 776 CCUSL=CPUMIN 777 IH='USL ' 778 IH2=' ' 779 IHWUSE='P' 780 MESSAG='NO' 781 CALL CHECKN(IH,IH2,IHWUSE, 782 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 783 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 784 IF(IERROR.EQ.'NO')CCUSL=VALUE(ILOCP) 785C 786 CCTARG=CPUMIN 787 IH='TARG' 788 IH2='ET ' 789 IHWUSE='P' 790 MESSAG='NO' 791 CALL CHECKN(IH,IH2,IHWUSE, 792 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 793 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 794 IF(IERROR.EQ.'NO')CCTARG=VALUE(ILOCP) 795C 796 CCUSLC=CPUMIN 797 IH='USLC' 798 IH2='OST ' 799 IHWUSE='P' 800 MESSAG='NO' 801 CALL CHECKN(IH,IH2,IHWUSE, 802 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 803 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 804 IF(IERROR.EQ.'NO')CCUSLC=VALUE(ILOCP) 805C 806C ********************************************************* 807C ** STEP 6-- ** 808C ** GENERATE THE CAPABILITY ANALYSIS FOR VARIOUS CASES ** 809C ********************************************************* 810C 811 ISTEPN='6' 812 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN') 813 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 814C 815C ****************************************** 816C ** STEP 8A-- ** 817C ** CASE 1: NO REPLICATION VARIABLES ** 818C ****************************************** 819C 820 IF(NREPL.LT.1)THEN 821 ISTEPN='8A' 822 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN') 823 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 824C 825C LOOP THROUGH EACH OF THE RESPONSE VARIABLES 826C 827 NCURVE=0 828 DO810IRESP=1,NRESP 829 NCURVE=NCURVE+1 830C 831 IINDX=ICOLR(IRESP) 832 PID(1)=CPUMIN 833 IVARID(1)=IVARN1(IRESP) 834 IVARI2(1)=IVARN2(IRESP) 835C 836 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN')THEN 837 WRITE(ICOUT,999) 838 CALL DPWRST('XXX','BUG ') 839 WRITE(ICOUT,811)IRESP,NCURVE 840 811 FORMAT('IRESP,NCURVE = ',2I5) 841 CALL DPWRST('XXX','BUG ') 842 ENDIF 843C 844 ICOL=IRESP 845 NUMVA2=1 846 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 847 1 INAME,IVARN1,IVARN2,IVARTY, 848 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 849 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 850 1 MAXCP4,MAXCP5,MAXCP6, 851 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 852 1 Y,XTEMP1,XTEMP1,NS1,NLOCA2,NLOCA3,ICASE, 853 1 IBUGA3,ISUBRO,IFOUND,IERROR) 854 IF(IERROR.EQ.'YES')GOTO9000 855C 856C ***************************************************** 857C ** STEP 8B-- ** 858C ***************************************************** 859C 860 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CAAN')THEN 861 ISTEPN='8B' 862 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 863 WRITE(ICOUT,999) 864 CALL DPWRST('XXX','BUG ') 865 WRITE(ICOUT,822) 866 822 FORMAT('***** FROM THE MIDDLE OF DPCAAN--') 867 CALL DPWRST('XXX','BUG ') 868 WRITE(ICOUT,823)ICASAN,NUMVAR,NS1 869 823 FORMAT('ICASAN,NUMVAR,NQ = ',A4,2I8) 870 CALL DPWRST('XXX','BUG ') 871 IF(NS1.GE.1)THEN 872 DO825I=1,NS1 873 WRITE(ICOUT,826)I,Y(I) 874 826 FORMAT('I,Y(I) = ',I8,G15.7) 875 CALL DPWRST('XXX','BUG ') 876 825 CONTINUE 877 ENDIF 878 ENDIF 879C 880 CALL DPCAA2(Y,W,NS1,XTEMP1,MAXNXT, 881 1 CCLSL,CCUSL,CCTARG,CCUSLC, 882 1 YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL, 883 1 YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL, 884 1 YCNPK,YCPM,YCPMLL,YCPMUL,YCC, 885 1 YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO, 886 1 ICAPSW,ICAPTY,IFORSW,ICNPKD, 887 1 PID,IVARID,IVARI2,NREPL, 888 1 IBUGA3,ISUBRO,IERROR) 889C 890C *************************************** 891C ** STEP 8C-- ** 892C ** UPDATE INTERNAL DATAPLOT TABLES ** 893C *************************************** 894C 895 ISTEPN='8C' 896 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN') 897 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 898C 899 IF(NRESP.GT.1)THEN 900 IFLAGU='FILE' 901 ELSE 902 IFLAGU='ON' 903 ENDIF 904 IFRST=.FALSE. 905 ILAST=.FALSE. 906 IF(IRESP.EQ.1)IFRST=.TRUE. 907 IF(IRESP.EQ.NRESP)ILAST=.TRUE. 908 CALL DPCAA5(CCLSL,CCUSL,CCTARG,CCUSLC, 909 1 YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL, 910 1 YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL, 911 1 YCNPK,YCPM,YCPMLL,YCPMUL,YCC, 912 1 YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO, 913 1 IFLAGU,IFRST,ILAST, 914 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 915 810 CONTINUE 916C 917C **************************************************** 918C ** STEP 9A-- ** 919C ** CASE 3: ONE OR MORE REPLICATION VARIABLES. ** 920C ** FOR THIS CASE, THE NUMBER OF RESPONSE ** 921C ** VARIABLES MUST BE EXACTLY 1. ** 922C ** FOR THIS CASE, ALL VARIABLES MUST ** 923C ** HAVE THE SAME LENGTH. ** 924C **************************************************** 925C 926 ELSEIF(NREPL.GE.1)THEN 927 ISTEPN='9A' 928 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CAAN') 929 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 930C 931 J=0 932 IMAX=NRIGHT(1) 933 IF(NQ.LT.NRIGHT(1))IMAX=NQ 934 DO910I=1,IMAX 935 IF(ISUB(I).EQ.0)GOTO910 936 J=J+1 937C 938C RESPONSE VARIABLE IN Y 939C 940 ICOLC=1 941 IJ=MAXN*(ICOLR(ICOLC)-1)+I 942 IF(ICOLR(ICOLC).LE.MAXCOL)Y(J)=V(IJ) 943 IF(ICOLR(ICOLC).EQ.MAXCP1)Y(J)=PRED(I) 944 IF(ICOLR(ICOLC).EQ.MAXCP2)Y(J)=RES(I) 945 IF(ICOLR(ICOLC).EQ.MAXCP3)Y(J)=YPLOT(I) 946 IF(ICOLR(ICOLC).EQ.MAXCP4)Y(J)=XPLOT(I) 947 IF(ICOLR(ICOLC).EQ.MAXCP5)Y(J)=X2PLOT(I) 948 IF(ICOLR(ICOLC).EQ.MAXCP6)Y(J)=TAGPLO(I) 949C 950 IF(NREPL.GE.1)THEN 951 DO920IR=1,MIN(NREPL,6) 952 ICOLC=ICOLC+1 953 ICOLT=ICOLR(ICOLC) 954 IJ=MAXN*(ICOLT-1)+I 955 IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ) 956 IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I) 957 IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I) 958 IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I) 959 IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I) 960 IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I) 961 IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I) 962 920 CONTINUE 963 ENDIF 964C 965 910 CONTINUE 966 NLOCAL=J 967C 968C ***************************************************** 969C ** STEP 9B-- ** 970C ** CALL DPSUM2 TO PERFORM SUMMARY. ** 971C ***************************************************** 972C 973C 974 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CAAN')THEN 975 ISTEPN='9C' 976 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 977 WRITE(ICOUT,999) 978 CALL DPWRST('XXX','BUG ') 979 WRITE(ICOUT,941) 980 941 FORMAT('***** FROM THE MIDDLE OF DPCAAN--') 981 CALL DPWRST('XXX','BUG ') 982 WRITE(ICOUT,942)ICASAN,NUMVAR,NLOCAL,NREPL 983 942 FORMAT('ICASAN,NUMVAR,NLOCAL,NREPL = ', 984 1 A4,3I8) 985 CALL DPWRST('XXX','BUG ') 986 IF(NLOCAL.GE.1)THEN 987 DO945I=1,NLOCAL 988 WRITE(ICOUT,946)I,Y(I),XDESGN(I,1),XDESGN(I,2) 989 946 FORMAT('I,Y(I),XDESGN(I,1),XDESGN(I,2) = ', 990 1 I8,4F12.5) 991 CALL DPWRST('XXX','BUG ') 992 945 CONTINUE 993 ENDIF 994 ENDIF 995C 996C ***************************************************** 997C ** STEP 9C-- ** 998C ** FIND THE DISTINCT VALUES IN EACH OF THE ** 999C ** REPLICATION VARIABLES. ** 1000C ***************************************************** 1001C 1002 CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3), 1003 1 XDESGN(1,4),XDESGN(1,5),XDESGN(1,6), 1004 1 NREPL,NLOCAL,MAXOBV, 1005 1 XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6, 1006 1 XTEMP1,TEMP2, 1007 1 NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6, 1008 1 IBUGA3,ISUBRO,IERROR) 1009C 1010C ***************************************************** 1011C ** STEP 9D-- ** 1012C ** NOW LOOP THROUGH THE VARIOUS REPLICATIONS ** 1013C ***************************************************** 1014C 1015 NCURVE=0 1016 IADD=1 1017C 1018 IF(NREPL.EQ.1)THEN 1019 J=0 1020 NTOT=NUMSE1 1021 DO1110ISET1=1,NUMSE1 1022 K=0 1023 PID(IADD+1)=XIDTEM(ISET1) 1024 DO1130I=1,NLOCAL 1025 IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN 1026 K=K+1 1027 TEMP1(K)=Y(I) 1028 ENDIF 1029 1130 CONTINUE 1030 NTEMP=K 1031 NCURVE=NCURVE+1 1032 IF(NTEMP.GT.0)THEN 1033 CALL DPCAA2(TEMP1,W,NTEMP,XTEMP1,MAXNXT, 1034 1 CCLSL,CCUSL,CCTARG,CCUSLC, 1035 1 YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL, 1036 1 YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL, 1037 1 YCNPK,YCPM,YCPMLL,YCPMUL,YCC, 1038 1 YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO, 1039 1 ICAPSW,ICAPTY,IFORSW,ICNPKD, 1040 1 PID,IVARN1,IVARN2,NREPL, 1041 1 IBUGA3,ISUBRO,IERROR) 1042 ENDIF 1043 IFLAGU='FILE' 1044 IFRST=.FALSE. 1045 ILAST=.FALSE. 1046 IF(NCURVE.EQ.1)IFRST=.TRUE. 1047 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 1048 CALL DPCAA5(CCLSL,CCUSL,CCTARG,CCUSLC, 1049 1 YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL, 1050 1 YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL, 1051 1 YCNPK,YCPM,YCPMLL,YCPMUL,YCC, 1052 1 YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO, 1053 1 IFLAGU,IFRST,ILAST, 1054 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 1055 1110 CONTINUE 1056 ELSEIF(NREPL.EQ.2)THEN 1057 J=0 1058 NTOT=NUMSE1*NUMSE2 1059 DO1210ISET1=1,NUMSE1 1060 DO1220ISET2=1,NUMSE2 1061 K=0 1062 PID(1+IADD)=XIDTEM(ISET1) 1063 PID(2+IADD)=XIDTE2(ISET2) 1064 DO1290I=1,NLOCAL 1065 IF( 1066 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 1067 1 XIDTE2(ISET2).EQ.XDESGN(I,2) 1068 1 )THEN 1069 K=K+1 1070 TEMP1(K)=Y(I) 1071 ENDIF 1072 1290 CONTINUE 1073 NTEMP=K 1074 NCURVE=NCURVE+1 1075 IF(NTEMP.GT.0)THEN 1076 CALL DPCAA2(TEMP1,W,NTEMP,XTEMP1,MAXNXT, 1077 1 CCLSL,CCUSL,CCTARG,CCUSLC, 1078 1 YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL, 1079 1 YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL, 1080 1 YCNPK,YCPM,YCPMLL,YCPMUL,YCC, 1081 1 YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO, 1082 1 ICAPSW,ICAPTY,IFORSW,ICNPKD, 1083 1 PID,IVARN1,IVARN2,NREPL, 1084 1 IBUGA3,ISUBRO,IERROR) 1085 ENDIF 1086 IFLAGU='FILE' 1087 IFRST=.FALSE. 1088 ILAST=.FALSE. 1089 IF(NCURVE.EQ.1)IFRST=.TRUE. 1090 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 1091 CALL DPCAA5(CCLSL,CCUSL,CCTARG,CCUSLC, 1092 1 YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL, 1093 1 YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL, 1094 1 YCNPK,YCPM,YCPMLL,YCPMUL,YCC, 1095 1 YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO, 1096 1 IFLAGU,IFRST,ILAST, 1097 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 1098 1220 CONTINUE 1099 1210 CONTINUE 1100 ELSEIF(NREPL.EQ.3)THEN 1101 J=0 1102 NTOT=NUMSE1*NUMSE2*NUMSE3 1103 DO1310ISET1=1,NUMSE1 1104 DO1320ISET2=1,NUMSE2 1105 DO1330ISET3=1,NUMSE3 1106 K=0 1107 PID(1+IADD)=XIDTEM(ISET1) 1108 PID(2+IADD)=XIDTE2(ISET2) 1109 PID(3+IADD)=XIDTE3(ISET3) 1110 DO1390I=1,NLOCAL 1111 IF( 1112 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 1113 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 1114 1 XIDTE3(ISET3).EQ.XDESGN(I,3) 1115 1 )THEN 1116 K=K+1 1117 TEMP1(K)=Y(I) 1118 ENDIF 1119 1390 CONTINUE 1120 NTEMP=K 1121 NCURVE=NCURVE+1 1122 NPLOT1=NPLOTP 1123 IF(NTEMP.GT.0)THEN 1124 CALL DPCAA2(TEMP1,W,NTEMP,XTEMP1,MAXNXT, 1125 1 CCLSL,CCUSL,CCTARG,CCUSLC, 1126 1 YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL, 1127 1 YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL, 1128 1 YCNPK,YCPM,YCPMLL,YCPMUL,YCC, 1129 1 YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO, 1130 1 ICAPSW,ICAPTY,IFORSW,ICNPKD, 1131 1 PID,IVARN1,IVARN2,NREPL, 1132 1 IBUGA3,ISUBRO,IERROR) 1133 ENDIF 1134 IFLAGU='FILE' 1135 IFRST=.FALSE. 1136 ILAST=.FALSE. 1137 IF(NCURVE.EQ.1)IFRST=.TRUE. 1138 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 1139 CALL DPCAA5(CCLSL,CCUSL,CCTARG,CCUSLC, 1140 1 YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL, 1141 1 YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL, 1142 1 YCNPK,YCPM,YCPMLL,YCPMUL,YCC, 1143 1 YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO, 1144 1 IFLAGU,IFRST,ILAST, 1145 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 1146 1330 CONTINUE 1147 1320 CONTINUE 1148 1310 CONTINUE 1149 ELSEIF(NREPL.EQ.4)THEN 1150 J=0 1151 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4 1152 DO1410ISET1=1,NUMSE1 1153 DO1420ISET2=1,NUMSE2 1154 DO1430ISET3=1,NUMSE3 1155 DO1440ISET4=1,NUMSE4 1156 K=0 1157 PID(1+IADD)=XIDTEM(ISET1) 1158 PID(2+IADD)=XIDTE2(ISET2) 1159 PID(3+IADD)=XIDTE3(ISET3) 1160 PID(4+IADD)=XIDTE4(ISET4) 1161 DO1490I=1,NLOCAL 1162 IF( 1163 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 1164 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 1165 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 1166 1 XIDTE4(ISET4).EQ.XDESGN(I,4) 1167 1 )THEN 1168 K=K+1 1169 TEMP1(K)=Y(I) 1170 ENDIF 1171 1490 CONTINUE 1172 NTEMP=K 1173 NCURVE=NCURVE+1 1174 NPLOT1=NPLOTP 1175 IF(NTEMP.GT.0)THEN 1176 CALL DPCAA2(TEMP1,W,NTEMP,XTEMP1,MAXNXT, 1177 1 CCLSL,CCUSL,CCTARG,CCUSLC, 1178 1 YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL, 1179 1 YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL, 1180 1 YCNPK,YCPM,YCPMLL,YCPMUL,YCC, 1181 1 YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO, 1182 1 ICAPSW,ICAPTY,IFORSW,ICNPKD, 1183 1 PID,IVARN1,IVARN2,NREPL, 1184 1 IBUGA3,ISUBRO,IERROR) 1185 ENDIF 1186 IFLAGU='FILE' 1187 IFRST=.FALSE. 1188 ILAST=.FALSE. 1189 IF(NCURVE.EQ.1)IFRST=.TRUE. 1190 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 1191 CALL DPCAA5(CCLSL,CCUSL,CCTARG,CCUSLC, 1192 1 YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL, 1193 1 YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL, 1194 1 YCNPK,YCPM,YCPMLL,YCPMUL,YCC, 1195 1 YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO, 1196 1 IFLAGU,IFRST,ILAST, 1197 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 1198 1440 CONTINUE 1199 1430 CONTINUE 1200 1420 CONTINUE 1201 1410 CONTINUE 1202 ELSEIF(NREPL.EQ.5)THEN 1203 J=0 1204 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5 1205 DO1510ISET1=1,NUMSE1 1206 DO1520ISET2=1,NUMSE2 1207 DO1530ISET3=1,NUMSE3 1208 DO1540ISET4=1,NUMSE4 1209 DO1550ISET5=1,NUMSE5 1210 K=0 1211 PID(1+IADD)=XIDTEM(ISET1) 1212 PID(2+IADD)=XIDTE2(ISET2) 1213 PID(3+IADD)=XIDTE3(ISET3) 1214 PID(4+IADD)=XIDTE4(ISET4) 1215 PID(5+IADD)=XIDTE5(ISET4) 1216 DO1590I=1,NLOCAL 1217 IF( 1218 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 1219 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 1220 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 1221 1 XIDTE4(ISET4).EQ.XDESGN(I,4) .AND. 1222 1 XIDTE5(ISET5).EQ.XDESGN(I,5) 1223 1 )THEN 1224 K=K+1 1225 TEMP1(K)=Y(I) 1226 ENDIF 1227 1590 CONTINUE 1228 NTEMP=K 1229 NCURVE=NCURVE+1 1230 NPLOT1=NPLOTP 1231 IF(NTEMP.GT.0)THEN 1232 CALL DPCAA2(TEMP1,W,NTEMP,XTEMP1,MAXNXT, 1233 1 CCLSL,CCUSL,CCTARG,CCUSLC, 1234 1 YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL, 1235 1 YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL, 1236 1 YCNPK,YCPM,YCPMLL,YCPMUL,YCC, 1237 1 YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO, 1238 1 ICAPSW,ICAPTY,IFORSW,ICNPKD, 1239 1 PID,IVARN1,IVARN2,NREPL, 1240 1 IBUGA3,ISUBRO,IERROR) 1241 ENDIF 1242 IFLAGU='FILE' 1243 IFRST=.FALSE. 1244 ILAST=.FALSE. 1245 IF(NCURVE.EQ.1)IFRST=.TRUE. 1246 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 1247 CALL DPCAA5(CCLSL,CCUSL,CCTARG,CCUSLC, 1248 1 YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL, 1249 1 YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL, 1250 1 YCNPK,YCPM,YCPMLL,YCPMUL,YCC, 1251 1 YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO, 1252 1 IFLAGU,IFRST,ILAST, 1253 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 1254 1550 CONTINUE 1255 1540 CONTINUE 1256 1530 CONTINUE 1257 1520 CONTINUE 1258 1510 CONTINUE 1259 ELSEIF(NREPL.EQ.6)THEN 1260 J=0 1261 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6 1262 DO1610ISET1=1,NUMSE1 1263 DO1620ISET2=1,NUMSE2 1264 DO1630ISET3=1,NUMSE3 1265 DO1640ISET4=1,NUMSE4 1266 DO1650ISET5=1,NUMSE5 1267 DO1660ISET6=1,NUMSE6 1268 K=0 1269 PID(1+IADD)=XIDTEM(ISET1) 1270 PID(2+IADD)=XIDTE2(ISET2) 1271 PID(3+IADD)=XIDTE3(ISET3) 1272 PID(4+IADD)=XIDTE4(ISET4) 1273 PID(5+IADD)=XIDTE5(ISET4) 1274 PID(6+IADD)=XIDTE6(ISET4) 1275 DO1690I=1,NLOCAL 1276 IF( 1277 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 1278 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 1279 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 1280 1 XIDTE4(ISET4).EQ.XDESGN(I,4) .AND. 1281 1 XIDTE5(ISET5).EQ.XDESGN(I,5) .AND. 1282 1 XIDTE6(ISET6).EQ.XDESGN(I,6) 1283 1 )THEN 1284 K=K+1 1285 TEMP1(K)=Y(I) 1286 ENDIF 1287 1690 CONTINUE 1288 NTEMP=K 1289 NCURVE=NCURVE+1 1290 NPLOT1=NPLOTP 1291 IF(NTEMP.GT.0)THEN 1292 CALL DPCAA2(TEMP1,W,NTEMP,XTEMP1,MAXNXT, 1293 1 CCLSL,CCUSL,CCTARG,CCUSLC, 1294 1 YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL, 1295 1 YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL, 1296 1 YCNPK,YCPM,YCPMLL,YCPMUL,YCC, 1297 1 YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO, 1298 1 ICAPSW,ICAPTY,IFORSW,ICNPKD, 1299 1 PID,IVARN1,IVARN2,NREPL, 1300 1 IBUGA3,ISUBRO,IERROR) 1301 ENDIF 1302 IFLAGU='FILE' 1303 IFRST=.FALSE. 1304 ILAST=.FALSE. 1305 IF(NCURVE.EQ.1)IFRST=.TRUE. 1306 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 1307 CALL DPCAA5(CCLSL,CCUSL,CCTARG,CCUSLC, 1308 1 YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL, 1309 1 YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL, 1310 1 YCNPK,YCPM,YCPMLL,YCPMUL,YCC, 1311 1 YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO, 1312 1 IFLAGU,IFRST,ILAST, 1313 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 1314 1660 CONTINUE 1315 1650 CONTINUE 1316 1640 CONTINUE 1317 1630 CONTINUE 1318 1620 CONTINUE 1319 1610 CONTINUE 1320 ENDIF 1321C 1322 ENDIF 1323C 1324C ***************** 1325C ** STEP 90-- ** 1326C ** EXIT ** 1327C ***************** 1328C 1329 9000 CONTINUE 1330C 1331 IF(IERROR.EQ.'YES')THEN 1332 IF(IWIDTH.GE.1)THEN 1333 WRITE(ICOUT,9001)(IANS(I),I=1,MIN(100,IWIDTH)) 1334 9001 FORMAT(100A1) 1335 CALL DPWRST('XXX','BUG ') 1336 ENDIF 1337 ENDIF 1338C 1339 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CAAN')THEN 1340 WRITE(ICOUT,999) 1341 CALL DPWRST('XXX','BUG ') 1342 WRITE(ICOUT,9011) 1343 9011 FORMAT('***** AT THE END OF DPCAAN--') 1344 CALL DPWRST('XXX','BUG ') 1345 WRITE(ICOUT,9012)IFOUND,IERROR,ICASAN 1346 9012 FORMAT('IFOUND,IERROR,ICASAN = ',2(A4,2X),A4) 1347 CALL DPWRST('XXX','BUG ') 1348 ENDIF 1349C 1350 RETURN 1351 END 1352 SUBROUTINE DPCAA2(Y,W,N,XTEMP1,MAXNXT, 1353 1 CCLSL,CCUSL,CCTARG,CCUSLC, 1354 1 YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL, 1355 1 YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL, 1356 1 YCNPK,YCPM,YCPMLL,YCPMUL,YCC, 1357 1 YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO, 1358 1 ICAPSW,ICAPTY,IFORSW,ICNPKD, 1359 1 PID,IVARID,IVARI2,NREPL, 1360 1 IBUGA3,ISUBRO,IERROR) 1361C 1362C PURPOSE--THIS ROUTINE GENERATES A CAPABILITY ANALYSIS 1363C TABULATION THE DATA IN THE INPUT VECTOR Y. 1364C NOTE--NORMALITY IS ASSUMED 1365C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR 1366C OF EQUALLY-SPACED OBSERVATIONS 1367C TO BE SMOOTHED. 1368C N = THE INTEGER NUMBER OF 1369C OBSERVATIONS IN THE VECTOR Y. 1370C WRITTEN BY--JAMES J. FILLIBEN 1371C STATISTICAL ENGINEERING DIVISION 1372C INFORMATION TECHNOLOGY LABORATORY 1373C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 1374C GAITHERSBURG, MD 20899-8980 1375C PHONE--301-975-2899 1376C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 1377C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 1378C LANGUAGE--ANSI FORTRAN (1977) 1379C VERSION NUMBER--90/9 1380C ORIGINAL VERSION--SEPTEMBER 1990. 1381C UPDATED --APRIL 2001. EXPAND TABLE: 1382C 1) ADD CC, CPM, CPL, CPU, 1383C CNPK 1384C 2) 95% CONFIDENCE INTERVAL 1385C FOR CP, CPK, CPL, CPU, CPM 1386C 3) ADD COMPUTED STATS TO 1387C CALL LIST SO THEY CAN BE 1388C SAVED AS INTERNAL 1389C PARAMETERS 1390C UPDATED --MAY 2011. USE DPDTA1 AND DPDTA5 TO PRINT 1391C TABLES 1392C UPDATED --APRIL 2015. ADD "ICNPKD" TO CNPK CALL LIST 1393C UPDATED --APRIL 2015. ADDITIONAL CAPABILITY STATISTICS 1394C UPDATED --APRIL 2015. ADD CONFIDENCE LIMITS TABLES 1395C 1396C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 1397C 1398 CHARACTER*4 IVARID(*) 1399 CHARACTER*4 IVARI2(*) 1400C 1401 CHARACTER*4 ICAPSW 1402 CHARACTER*4 ICAPTY 1403 CHARACTER*4 IFORSW 1404 CHARACTER*4 ICNPKD 1405C 1406 CHARACTER*4 ISUBRO 1407 CHARACTER*4 IBUGA3 1408 CHARACTER*4 IERROR 1409C 1410 CHARACTER*4 IWRITE 1411 CHARACTER*4 IFLAG 1412 CHARACTER*4 ISUBN1 1413 CHARACTER*4 ISUBN2 1414 CHARACTER*4 ISTEPN 1415C 1416C--------------------------------------------------------------------- 1417C 1418 DIMENSION Y(*) 1419 DIMENSION W(*) 1420 DIMENSION XTEMP1(*) 1421 DIMENSION PID(*) 1422C 1423 PARAMETER (NUMALP=5) 1424 PARAMETER (MAXROW=60) 1425 PARAMETER (NUMCLI=60) 1426 PARAMETER (MAXLIN=2) 1427 CHARACTER*60 ITITLE 1428 CHARACTER*60 ITITLZ 1429 CHARACTER*60 ITITL9 1430 CHARACTER*40 ITEXT(MAXROW) 1431 CHARACTER*4 ALIGN(NUMCLI) 1432 CHARACTER*4 VALIGN(NUMCLI) 1433 REAL AVALUE(MAXROW) 1434 REAL ALPHA(NUMALP) 1435 INTEGER NCTEXT(MAXROW) 1436 INTEGER IDIGIT(MAXROW) 1437 INTEGER NTOT(MAXROW) 1438 INTEGER IWHTML(NUMCLI) 1439 INTEGER IWRTF(NUMCLI) 1440 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 1441 CHARACTER*15 IVALUE(MAXROW,NUMCLI) 1442 CHARACTER*4 ITYPCO(NUMCLI) 1443 INTEGER NCTIT2(MAXLIN,NUMCLI) 1444 INTEGER NCVALU(MAXROW,NUMCLI) 1445 REAL AMAT(MAXROW,NUMCLI) 1446 LOGICAL IFRST 1447 LOGICAL ILAST 1448C 1449C--------------------------------------------------------------------- 1450C 1451 INCLUDE 'DPCOP2.INC' 1452C 1453 DATA ALPHA /50.0, 80.0, 90.0, 95.0, 99.0/ 1454C 1455C-----START POINT----------------------------------------------------- 1456C 1457 ISUBN1='DPCA' 1458 ISUBN2='A2 ' 1459C 1460 IERROR='NO' 1461 IWRITE='OFF' 1462C 1463C 1464 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CAA2')THEN 1465 WRITE(ICOUT,999) 1466 999 FORMAT(1X) 1467 CALL DPWRST('XXX','BUG ') 1468 WRITE(ICOUT,51) 1469 51 FORMAT('**** AT THE BEGINNING OF DPCAA2--') 1470 CALL DPWRST('XXX','BUG ') 1471 WRITE(ICOUT,52)IBUGA3,ISUBRO,N,MAXNXT 1472 52 FORMAT('IBUGA3,ISUBRO,N,MAXNXT = ',2(A4,2X),2I8) 1473 CALL DPWRST('XXX','BUG ') 1474 WRITE(ICOUT,54)CCLSL,CCUSL,CCTARG,CCUSLC 1475 54 FORMAT('CCLSL,CCUSL,CCTARG,CCUSLC = ',4G15.7) 1476 CALL DPWRST('XXX','BUG ') 1477 DO56I=1,N 1478 WRITE(ICOUT,57)I,Y(I),W(I) 1479 57 FORMAT('I,Y(I),W(I) = ',I8,2G15.7) 1480 CALL DPWRST('XXX','BUG ') 1481 56 CONTINUE 1482 ENDIF 1483C 1484C ******************************************** 1485C ** STEP 1-- ** 1486C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 1487C ******************************************** 1488C 1489 ISTEPN='1' 1490 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CAA2') 1491 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1492C 1493 IF(N.LT.2)THEN 1494 WRITE(ICOUT,999) 1495 CALL DPWRST('XXX','BUG ') 1496 WRITE(ICOUT,111) 1497 111 FORMAT('***** ERROR IN CAPABILITY ANALYSIS--') 1498 CALL DPWRST('XXX','BUG ') 1499 WRITE(ICOUT,112) 1500 112 FORMAT(' THE NUMBER OF OBSERVATIONS IN THE RESPONSE ', 1501 1 'VARIABLE IS LESS THAN TWO.') 1502 CALL DPWRST('XXX','BUG ') 1503 WRITE(ICOUT,113)N 1504 113 FORMAT('SAMPLE SIZE = ',I8) 1505 CALL DPWRST('XXX','BUG ') 1506 IERROR='YES' 1507 GOTO9000 1508 ENDIF 1509C 1510 HOLD=Y(1) 1511 DO135I=2,N 1512 IF(Y(I).NE.HOLD)GOTO139 1513 135 CONTINUE 1514 WRITE(ICOUT,999) 1515 CALL DPWRST('XXX','BUG ') 1516 WRITE(ICOUT,111) 1517 CALL DPWRST('XXX','BUG ') 1518 WRITE(ICOUT,131)HOLD 1519 131 FORMAT(' THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7) 1520 CALL DPWRST('XXX','BUG ') 1521 IERROR='YES' 1522 GOTO9000 1523 139 CONTINUE 1524C 1525C ********************************************** 1526C ** STEP 3-- ** 1527C ** COMPUTE VARIOUS CAPABILITY STATISTICS-- ** 1528C ** 1) CP ** 1529C ** 2) CPK ** 1530C ** 3) PERCENT DEFECTIVE ** 1531C ** 4) EXPECTED LOSS ** 1532C ********************************************** 1533C 1534 ISTEPN='3' 1535 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CAA2') 1536 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1537C 1538 IFLAG='BOTH' 1539C 1540 CALL MEAN(Y,N,IWRITE,XMEAN,IBUGA3,IERROR) 1541 CALL SD(Y,N,IWRITE,XSD,IBUGA3,IERROR) 1542C 1543 CALL MEDIAN(Y,N,IWRITE,XTEMP1,MAXNXT,XMED,IBUGA3,IERROR) 1544 IF(ICNPKD.EQ.'PEAR')THEN 1545 P=99.865 1546 CALL PERCEN(P,Y,N,IWRITE,XTEMP1,MAXNXT,P995,IBUGA3,IERROR) 1547 P=0.135 1548 CALL PERCEN(P,Y,N,IWRITE,XTEMP1,MAXNXT,P005,IBUGA3,IERROR) 1549 ELSE 1550 P=99.5 1551 CALL PERCEN(P,Y,N,IWRITE,XTEMP1,MAXNXT,P995,IBUGA3,IERROR) 1552 P=0.5 1553 CALL PERCEN(P,Y,N,IWRITE,XTEMP1,MAXNXT,P005,IBUGA3,IERROR) 1554 ENDIF 1555C 1556 YCP=CPUMIN 1557 YCPLL=CPUMIN 1558 YCPUL=CPUMIN 1559 YCPK=CPUMIN 1560 YCPKLL=CPUMIN 1561 YCPKUL=CPUMIN 1562 YCNPK=CPUMIN 1563 YCPL=CPUMIN 1564 YCPLLL=CPUMIN 1565 YCPLUL=CPUMIN 1566 YCPU=CPUMIN 1567 YCPULL=CPUMIN 1568 YCPUUL=CPUMIN 1569 YCC=CPUMIN 1570 YCPM=CPUMIN 1571 YCPMLL=CPUMIN 1572 YCPMUL=CPUMIN 1573 YTHEPD=CPUMIN 1574 YTHEL=CPUMIN 1575 YTHEU=CPUMIN 1576 YACTPD=CPUMIN 1577 YACTL=CPUMIN 1578 YACTU=CPUMIN 1579 YEXPLO=CPUMIN 1580C 1581 IF(CCLSL.NE.CPUMIN.AND.CCUSL.NE.CPUMIN)THEN 1582 CALL CP(Y,N,CCLSL,CCUSL,IWRITE,YCP,YCPLL,YCPUL, 1583 1 IBUGA3,IERROR) 1584 CALL CPL(Y,N,CCLSL,CCUSL,IWRITE,YCPL,YCPLLL,YCPLUL, 1585 1 IBUGA3,IERROR) 1586 CALL CPU(Y,N,CCLSL,CCUSL,IWRITE,YCPU,YCPULL,YCPUUL, 1587 1 IBUGA3,IERROR) 1588 CALL CPK(Y,N,CCLSL,CCUSL,IWRITE,YCPK,YCPKLL,YCPKUL, 1589 1 IBUGA3,IERROR) 1590 CALL CPM(Y,N,CCLSL,CCUSL,CCTARG,IWRITE,YCPM,YCPMLL,YCPMUL, 1591 1 IBUGA3,IERROR) 1592 CALL CPMK(Y,N,CCLSL,CCUSL,CCTARG,IWRITE,YCPMK,YCPMLL,YCPMUL, 1593 1 IBUGA3,IERROR) 1594 CALL CC(Y,N,CCLSL,CCUSL,CCTARG,IWRITE,YCC, 1595 1 IBUGA3,IERROR) 1596 CALL CNP(Y,N,XTEMP1,MAXNXT,CCLSL,CCUSL,IWRITE,ICNPKD, 1597 1 YCNP,IBUGA3,IERROR) 1598 CALL CNPK(Y,N,XTEMP1,MAXNXT,CCLSL,CCUSL,IWRITE,ICNPKD, 1599 1 YCNPK,IBUGA3,IERROR) 1600 CALL CNPM(Y,N,XTEMP1,MAXNXT,CCLSL,CCUSL,CCTARG,IWRITE,ICNPKD, 1601 1 YCNPM,IBUGA3,IERROR) 1602 CALL CNPMK(Y,N,XTEMP1,MAXNXT,CCLSL,CCUSL,CCTARG,IWRITE,ICNPKD, 1603 1 YCNPMK,IBUGA3,IERROR) 1604 CALL PERDEF(Y,N,CCLSL,CCUSL,IWRITE,YACTPD,YTHEPD, 1605 1 YACTL,YTHEL,YACTU,YTHEU, 1606 1 IFLAG,IBUGA3,IERROR) 1607 CALL EXPLOS(Y,N,CCLSL,CCUSL,CCUSLC,IWRITE,YEXPLO, 1608 1 IBUGA3,IERROR) 1609 ENDIF 1610C 1611C **************************** 1612C ** STEP 7-- ** 1613C ** WRITE EVERYTHING OUT ** 1614C **************************** 1615C 1616 ISTEPN='7' 1617 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CAA2') 1618 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1619C 1620 IF(IPRINT.EQ.'OFF')GOTO9000 1621C 1622 NUMDIG=7 1623 IF(IFORSW.EQ.'1')NUMDIG=1 1624 IF(IFORSW.EQ.'2')NUMDIG=2 1625 IF(IFORSW.EQ.'3')NUMDIG=3 1626 IF(IFORSW.EQ.'4')NUMDIG=4 1627 IF(IFORSW.EQ.'5')NUMDIG=5 1628 IF(IFORSW.EQ.'6')NUMDIG=6 1629 IF(IFORSW.EQ.'7')NUMDIG=7 1630 IF(IFORSW.EQ.'8')NUMDIG=8 1631 IF(IFORSW.EQ.'9')NUMDIG=9 1632 IF(IFORSW.EQ.'0')NUMDIG=0 1633 IF(IFORSW.EQ.'E')NUMDIG=-2 1634 IF(IFORSW.EQ.'-2')NUMDIG=-2 1635 IF(IFORSW.EQ.'-3')NUMDIG=-3 1636 IF(IFORSW.EQ.'-4')NUMDIG=-4 1637 IF(IFORSW.EQ.'-5')NUMDIG=-5 1638 IF(IFORSW.EQ.'-6')NUMDIG=-6 1639 IF(IFORSW.EQ.'-7')NUMDIG=-7 1640 IF(IFORSW.EQ.'-8')NUMDIG=-8 1641 IF(IFORSW.EQ.'-9')NUMDIG=-9 1642C 1643 ITITLE='Capability Analysis' 1644 NCTITL=19 1645 ITITLZ=' ' 1646 NCTITZ=0 1647C 1648 ICNT=1 1649 ITEXT(ICNT)=' ' 1650 NCTEXT(ICNT)=0 1651 AVALUE(ICNT)=0.0 1652 IDIGIT(ICNT)=-1 1653C 1654 ICNT=ICNT+1 1655 ITEXT(ICNT)='Response Variable: ' 1656 WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4) 1657 WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4) 1658 NCTEXT(ICNT)=27 1659 AVALUE(ICNT)=0.0 1660 IDIGIT(ICNT)=-1 1661C 1662 IF(NREPL.GT.0)THEN 1663 IADD=1 1664 DO2101I=1,NREPL 1665 ICNT=ICNT+1 1666 ITEMP=I+IADD 1667 ITEXT(ICNT)='Factor Variable : ' 1668 WRITE(ITEXT(ICNT)(17:17),'(I1)')I 1669 WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4) 1670 WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4) 1671 NCTEXT(ICNT)=27 1672 AVALUE(ICNT)=PID(ITEMP) 1673 IDIGIT(ICNT)=NUMDIG 1674 2101 CONTINUE 1675 ENDIF 1676C 1677 ICNT=ICNT+1 1678 ITEXT(ICNT)=' ' 1679 NCTEXT(ICNT)=1 1680 AVALUE(ICNT)=0.0 1681 IDIGIT(ICNT)=-1 1682C 1683 ICNT=ICNT+1 1684 ITEXT(ICNT)=' ' 1685 NCTEXT(ICNT)=1 1686 AVALUE(ICNT)=0.0 1687 IDIGIT(ICNT)=-1 1688 ICNT=ICNT+1 1689 ITEXT(ICNT)='Summary Statistics:' 1690 NCTEXT(ICNT)=19 1691 AVALUE(ICNT)=0.0 1692 IDIGIT(ICNT)=-1 1693 ICNT=ICNT+1 1694 ITEXT(ICNT)='Number of Observations:' 1695 NCTEXT(ICNT)=23 1696 AVALUE(ICNT)=REAL(N) 1697 IDIGIT(ICNT)=0 1698 ICNT=ICNT+1 1699 ITEXT(ICNT)='Mean:' 1700 NCTEXT(ICNT)=5 1701 AVALUE(ICNT)=XMEAN 1702 IDIGIT(ICNT)=NUMDIG 1703 ICNT=ICNT+1 1704 ITEXT(ICNT)='Standard Deviation:' 1705 NCTEXT(ICNT)=19 1706 AVALUE(ICNT)=XSD 1707 IDIGIT(ICNT)=NUMDIG 1708 ICNT=ICNT+1 1709 ITEXT(ICNT)='Median:' 1710 NCTEXT(ICNT)=7 1711 AVALUE(ICNT)=XMED 1712 IDIGIT(ICNT)=NUMDIG 1713 IF(ICNPKD.EQ.'PEAR')THEN 1714 ICNT=ICNT+1 1715 ITEXT(ICNT)='0.135 Percentile:' 1716 NCTEXT(ICNT)=17 1717 AVALUE(ICNT)=P005 1718 IDIGIT(ICNT)=NUMDIG 1719 ICNT=ICNT+1 1720 ITEXT(ICNT)='99.865 Percentile:' 1721 NCTEXT(ICNT)=18 1722 AVALUE(ICNT)=P995 1723 IDIGIT(ICNT)=NUMDIG 1724 ELSE 1725 ICNT=ICNT+1 1726 ITEXT(ICNT)='0.5 Percentile:' 1727 NCTEXT(ICNT)=15 1728 AVALUE(ICNT)=P005 1729 IDIGIT(ICNT)=NUMDIG 1730 ICNT=ICNT+1 1731 ITEXT(ICNT)='99.5 Percentile:' 1732 NCTEXT(ICNT)=16 1733 AVALUE(ICNT)=P995 1734 IDIGIT(ICNT)=NUMDIG 1735 ENDIF 1736C 1737 ICNT=ICNT+1 1738 ITEXT(ICNT)=' ' 1739 NCTEXT(ICNT)=1 1740 AVALUE(ICNT)=0.0 1741 IDIGIT(ICNT)=-1 1742 ICNT=ICNT+1 1743 ITEXT(ICNT)='User Specified Parameters:' 1744 NCTEXT(ICNT)=26 1745 AVALUE(ICNT)=0.0 1746 IDIGIT(ICNT)=-1 1747 ICNT=ICNT+1 1748 ITEXT(ICNT)='Lower Specification Limit (LSL):' 1749 NCTEXT(ICNT)=32 1750 AVALUE(ICNT)=CCLSL 1751 IDIGIT(ICNT)=NUMDIG 1752 ICNT=ICNT+1 1753 ITEXT(ICNT)='Upper Specification Limit (USL):' 1754 NCTEXT(ICNT)=32 1755 AVALUE(ICNT)=CCUSL 1756 IDIGIT(ICNT)=NUMDIG 1757 ICNT=ICNT+1 1758 ITEXT(ICNT)='Target (Target):' 1759 NCTEXT(ICNT)=16 1760 AVALUE(ICNT)=CCTARG 1761 IDIGIT(ICNT)=NUMDIG 1762 ICNT=ICNT+1 1763 ITEXT(ICNT)='USL Cost (USLCOST):' 1764 NCTEXT(ICNT)=19 1765 AVALUE(ICNT)=CCUSLC 1766 IDIGIT(ICNT)=NUMDIG 1767 ICNT=ICNT+1 1768 ITEXT(ICNT)=' ' 1769 NCTEXT(ICNT)=1 1770 AVALUE(ICNT)=0.0 1771 IDIGIT(ICNT)=-1 1772C 1773 ICNT=ICNT+1 1774 ITEXT(ICNT)='Normal-Based Capability Statistics:' 1775 NCTEXT(ICNT)=35 1776 AVALUE(ICNT)=0.0 1777 IDIGIT(ICNT)=-1 1778 ICNT=ICNT+1 1779 ITEXT(ICNT)='CP:' 1780 NCTEXT(ICNT)=3 1781 AVALUE(ICNT)=YCP 1782 IDIGIT(ICNT)=NUMDIG 1783 ICNT=ICNT+1 1784 ITEXT(ICNT)='CPL:' 1785 NCTEXT(ICNT)=4 1786 AVALUE(ICNT)=YCPL 1787 IDIGIT(ICNT)=NUMDIG 1788 ICNT=ICNT+1 1789 ITEXT(ICNT)='CPU:' 1790 NCTEXT(ICNT)=4 1791 AVALUE(ICNT)=YCPU 1792 IDIGIT(ICNT)=NUMDIG 1793 ICNT=ICNT+1 1794 ITEXT(ICNT)='CPK:' 1795 NCTEXT(ICNT)=4 1796 AVALUE(ICNT)=YCPK 1797 IDIGIT(ICNT)=NUMDIG 1798 ICNT=ICNT+1 1799 ITEXT(ICNT)='CPM:' 1800 NCTEXT(ICNT)=4 1801 AVALUE(ICNT)=YCPM 1802 IDIGIT(ICNT)=NUMDIG 1803 ICNT=ICNT+1 1804 ITEXT(ICNT)='CPMK:' 1805 NCTEXT(ICNT)=5 1806 AVALUE(ICNT)=YCPMK 1807 IDIGIT(ICNT)=NUMDIG 1808 ICNT=ICNT+1 1809 ITEXT(ICNT)='CC:' 1810 NCTEXT(ICNT)=3 1811 AVALUE(ICNT)=YCC 1812 IDIGIT(ICNT)=NUMDIG 1813 ICNT=ICNT+1 1814 ITEXT(ICNT)=' ' 1815 NCTEXT(ICNT)=1 1816 AVALUE(ICNT)=0.0 1817 IDIGIT(ICNT)=-1 1818 ICNT=ICNT+1 1819 ITEXT(ICNT)='Actual Percent Defective:' 1820 NCTEXT(ICNT)=25 1821 AVALUE(ICNT)=YACTPD 1822 IDIGIT(ICNT)=NUMDIG 1823 ICNT=ICNT+1 1824 ITEXT(ICNT)='Theoretical Percent Defective:' 1825 NCTEXT(ICNT)=30 1826 AVALUE(ICNT)=YTHEPD 1827 IDIGIT(ICNT)=NUMDIG 1828 ICNT=ICNT+1 1829 ITEXT(ICNT)='Actual (Below) Percent Defective:' 1830 NCTEXT(ICNT)=33 1831 AVALUE(ICNT)=YACTL 1832 IDIGIT(ICNT)=NUMDIG 1833 ICNT=ICNT+1 1834 ITEXT(ICNT)='Theoretical (Below) Percent Defective:' 1835 NCTEXT(ICNT)=38 1836 AVALUE(ICNT)=YTHEL 1837 IDIGIT(ICNT)=NUMDIG 1838 ICNT=ICNT+1 1839 ITEXT(ICNT)='Actual (Above) Percent Defective:' 1840 NCTEXT(ICNT)=33 1841 AVALUE(ICNT)=YACTU 1842 IDIGIT(ICNT)=NUMDIG 1843 ICNT=ICNT+1 1844 ITEXT(ICNT)='Theoretical (Above) Percent Defective:' 1845 NCTEXT(ICNT)=38 1846 AVALUE(ICNT)=YTHEU 1847 IDIGIT(ICNT)=NUMDIG 1848 ICNT=ICNT+1 1849 ITEXT(ICNT)='Expected Loss:' 1850 NCTEXT(ICNT)=14 1851 AVALUE(ICNT)=YEXPLO 1852 IDIGIT(ICNT)=NUMDIG 1853 ICNT=ICNT+1 1854 ITEXT(ICNT)=' ' 1855 NCTEXT(ICNT)=1 1856 AVALUE(ICNT)=0.0 1857 IDIGIT(ICNT)=-1 1858C 1859 ICNT=ICNT+1 1860 ITEXT(ICNT)='Nonparametric Capability Statistics:' 1861 NCTEXT(ICNT)=36 1862 AVALUE(ICNT)=0.0 1863 IDIGIT(ICNT)=-1 1864 ICNT=ICNT+1 1865 ITEXT(ICNT)='CNP:' 1866 NCTEXT(ICNT)=4 1867 AVALUE(ICNT)=YCNP 1868 IDIGIT(ICNT)=NUMDIG 1869 ICNT=ICNT+1 1870 ITEXT(ICNT)='CNPK:' 1871 NCTEXT(ICNT)=5 1872 AVALUE(ICNT)=YCNPK 1873 IDIGIT(ICNT)=NUMDIG 1874 ICNT=ICNT+1 1875 ITEXT(ICNT)='CNPM:' 1876 NCTEXT(ICNT)=5 1877 AVALUE(ICNT)=YCNPM 1878 IDIGIT(ICNT)=NUMDIG 1879 ICNT=ICNT+1 1880 ITEXT(ICNT)='CNPMK:' 1881 NCTEXT(ICNT)=6 1882 AVALUE(ICNT)=YCNPMK 1883 IDIGIT(ICNT)=NUMDIG 1884C 1885 NUMROW=ICNT 1886 DO2110I=1,NUMROW 1887 NTOT(I)=15 1888 2110 CONTINUE 1889C 1890 IFRST=.TRUE. 1891 ILAST=.TRUE. 1892C 1893 ISTEPN='42A' 1894 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRT2') 1895 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1896C 1897 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT, 1898 1 AVALUE,IDIGIT, 1899 1 NTOT,NUMROW, 1900 1 ICAPSW,ICAPTY,ILAST,IFRST, 1901 1 ISUBRO,IBUGA3,IERROR) 1902C 1903C CONFIDENCE LIMITS TABLE FOR CP 1904C 1905 ITITLE=' ' 1906 NCTITL=0 1907 ITITL9=' ' 1908 NCTIT9=0 1909 NUMLIN=2 1910 NUMROW=NUMALP 1911 NUMCOL=4 1912C 1913 ITITL9='Confidence Limits for Cp Statistic' 1914 NCTIT9=34 1915C 1916 ITITL2(1,1)='Confidence' 1917 NCTIT2(1,1)=10 1918 ITITL2(2,1)='Value (%)' 1919 NCTIT2(2,1)=9 1920 ITITL2(1,2)='Value' 1921 NCTIT2(1,2)=5 1922 ITITL2(2,2)='of Cp' 1923 NCTIT2(2,2)=5 1924 ITITL2(1,3)='Lower' 1925 NCTIT2(1,3)=5 1926 ITITL2(2,3)='Limit' 1927 NCTIT2(2,3)=5 1928 ITITL2(1,4)='Lower' 1929 NCTIT2(1,4)=5 1930 ITITL2(2,4)='Limit' 1931 NCTIT2(2,4)=5 1932C 1933 NMAX=0 1934 DO4221I=1,NUMCOL 1935 VALIGN(I)='b' 1936 ALIGN(I)='r' 1937 NTOT(I)=15 1938 IDIGIT(I)=NUMDIG 1939 ITYPCO(I)='NUME' 1940 IWHTML(I)=150 1941 IF(I.EQ.1)THEN 1942 NTOT(I)=12 1943 IDIGIT(I)=3 1944 IWHTML(1)=75 1945 ENDIF 1946 NMAX=NMAX+NTOT(I) 1947 4221 CONTINUE 1948C 1949 AN=REAL(N) 1950 NV=N-1 1951 AV=REAL(NV) 1952C 1953 DO4223I=1,NUMROW 1954 DO4225J=1,NUMCOL 1955 NCVALU(I,J)=0 1956 IVALUE(I,J)=' ' 1957 AMAT(I,J)=0.0 1958 4225 CONTINUE 1959C 1960 PTEMP=ALPHA(I)/100.0 1961 PTEMPL=(1.0 - PTEMP)/2.0 1962 PTEMPU=1.0 - PTEMPL 1963 CALL CHSPPF(PTEMPL,NV,PPFL) 1964 ALOWER=0.0 1965 IF((PPFL/AV).GT.0.0)ALOWER=YCP*SQRT(PPFL/AV) 1966 CALL CHSPPF(PTEMPU,NV,PPFU) 1967 AUPPER=0.0 1968 IF((PPFU/AV).GT.0.0)AUPPER=YCP*SQRT(PPFU/AV) 1969 AMAT(I,1)=ALPHA(I) 1970 AMAT(I,2)=YCP 1971 AMAT(I,3)=ALOWER 1972 AMAT(I,4)=AUPPER 1973 4223 CONTINUE 1974C 1975 IWRTF(1)=800 1976 IWRTF(2)=IWRTF(1)+2000 1977 IWRTF(3)=IWRTF(2)+2000 1978 IWRTF(4)=IWRTF(2)+2000 1979 IFRST=.TRUE. 1980 ILAST=.TRUE. 1981C 1982 ISTEPN='5C' 1983 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CAA2') 1984 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1985C 1986 CALL DPDTA4(ITITL9,NCTIT9, 1987 1 ITITLE,NCTITL,ITITL2,NCTIT2, 1988 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 1989 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW, 1990 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 1991 1 ICAPSW,ICAPTY,IFRST,ILAST, 1992 1 ISUBRO,IBUGA3,IERROR) 1993C 1994C CONFIDENCE LIMITS TABLE FOR CPL 1995C 1996 ITITL9='Confidence Limits for Cpl Statistic' 1997 NCTIT9=35 1998 ITITL2(2,2)='of Cpl' 1999 NCTIT2(2,2)=6 2000C 2001 DO4323I=1,NUMROW 2002 DO4325J=1,NUMCOL 2003 NCVALU(I,J)=0 2004 IVALUE(I,J)=' ' 2005 AMAT(I,J)=0.0 2006 4325 CONTINUE 2007C 2008 PTEMP=ALPHA(I)/100.0 2009 PTEMPL=(1.0 - PTEMP)/2.0 2010 PTEMPU=1.0 - PTEMPL 2011 CALL NORPPF(PTEMPU,PPFU) 2012 ALOWER=0.0 2013 AUPPER=0.0 2014 IF(N.GT.1)THEN 2015 ALOWER=YCPL - PPFU*SQRT((1.0/(9.0*AN)) + YCPL/(2.0*(AN-1.0))) 2016 AUPPER=YCPL + PPFU*SQRT((1.0/(9.0*AN)) + YCPL/(2.0*(AN-1.0))) 2017 ENDIF 2018 AMAT(I,1)=ALPHA(I) 2019 AMAT(I,2)=YCPL 2020 AMAT(I,3)=ALOWER 2021 AMAT(I,4)=AUPPER 2022 4323 CONTINUE 2023C 2024 IWRTF(1)=800 2025 IWRTF(2)=IWRTF(1)+2000 2026 IWRTF(3)=IWRTF(2)+2000 2027 IWRTF(4)=IWRTF(2)+2000 2028 IFRST=.TRUE. 2029 ILAST=.TRUE. 2030C 2031 ISTEPN='5C' 2032 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CAA2') 2033 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2034C 2035 CALL DPDTA4(ITITL9,NCTIT9, 2036 1 ITITLE,NCTITL,ITITL2,NCTIT2, 2037 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 2038 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW, 2039 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 2040 1 ICAPSW,ICAPTY,IFRST,ILAST, 2041 1 ISUBRO,IBUGA3,IERROR) 2042C 2043C CONFIDENCE LIMITS TABLE FOR CPU 2044C 2045 ITITL9='Confidence Limits for Cpu Statistic' 2046 NCTIT9=35 2047 ITITL2(2,2)='of Cpu' 2048 NCTIT2(2,2)=6 2049C 2050 DO4423I=1,NUMROW 2051 DO4425J=1,NUMCOL 2052 NCVALU(I,J)=0 2053 IVALUE(I,J)=' ' 2054 AMAT(I,J)=0.0 2055 4425 CONTINUE 2056C 2057 PTEMP=ALPHA(I)/100.0 2058 PTEMPL=(1.0 - PTEMP)/2.0 2059 PTEMPU=1.0 - PTEMPL 2060 CALL NORPPF(PTEMPU,PPFU) 2061 ALOWER=0.0 2062 AUPPER=0.0 2063 IF(N.GT.1)THEN 2064 ALOWER=YCPU - PPFU*SQRT((1.0/(9.0*AN)) + YCPU/(2.0*(AN-1.0))) 2065 AUPPER=YCPU + PPFU*SQRT((1.0/(9.0*AN)) + YCPU/(2.0*(AN-1.0))) 2066 ENDIF 2067 AMAT(I,1)=ALPHA(I) 2068 AMAT(I,2)=YCPU 2069 AMAT(I,3)=ALOWER 2070 AMAT(I,4)=AUPPER 2071 4423 CONTINUE 2072C 2073 IWRTF(1)=800 2074 IWRTF(2)=IWRTF(1)+2000 2075 IWRTF(3)=IWRTF(2)+2000 2076 IWRTF(4)=IWRTF(2)+2000 2077 IFRST=.TRUE. 2078 ILAST=.TRUE. 2079C 2080 ISTEPN='5C' 2081 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CAA2') 2082 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2083C 2084 CALL DPDTA4(ITITL9,NCTIT9, 2085 1 ITITLE,NCTITL,ITITL2,NCTIT2, 2086 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 2087 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW, 2088 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 2089 1 ICAPSW,ICAPTY,IFRST,ILAST, 2090 1 ISUBRO,IBUGA3,IERROR) 2091C 2092C CONFIDENCE LIMITS TABLE FOR CPM 2093C 2094 ITITL9='Confidence Limits for Cpm Statistic' 2095 NCTIT9=35 2096 ITITL2(2,2)='of Cpm' 2097 NCTIT2(2,2)=6 2098C 2099 DO4523I=1,NUMROW 2100 DO4525J=1,NUMCOL 2101 NCVALU(I,J)=0 2102 IVALUE(I,J)=' ' 2103 AMAT(I,J)=0.0 2104 4525 CONTINUE 2105C 2106 PTEMP=ALPHA(I)/100.0 2107 PTEMPL=(1.0 - PTEMP)/2.0 2108 PTEMPU=1.0 - PTEMPL 2109 CALL CHSPPF(PTEMPL,NV,PPFL) 2110 ALOWER=0.0 2111 IF((PPFL/AV).GT.0.0)ALOWER=YCPM*SQRT(PPFL/AV) 2112 CALL CHSPPF(PTEMPU,NV,PPFU) 2113 AUPPER=0.0 2114 IF((PPFU/AV).GT.0.0)AUPPER=YCPM*SQRT(PPFU/AV) 2115 AMAT(I,1)=ALPHA(I) 2116 AMAT(I,2)=YCPM 2117 AMAT(I,3)=ALOWER 2118 AMAT(I,4)=AUPPER 2119 4523 CONTINUE 2120C 2121 IWRTF(1)=800 2122 IWRTF(2)=IWRTF(1)+2000 2123 IWRTF(3)=IWRTF(2)+2000 2124 IWRTF(4)=IWRTF(2)+2000 2125 IFRST=.TRUE. 2126 ILAST=.TRUE. 2127C 2128 ISTEPN='5C' 2129 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CAA2') 2130 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2131C 2132 CALL DPDTA4(ITITL9,NCTIT9, 2133 1 ITITLE,NCTITL,ITITL2,NCTIT2, 2134 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 2135 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW, 2136 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 2137 1 ICAPSW,ICAPTY,IFRST,ILAST, 2138 1 ISUBRO,IBUGA3,IERROR) 2139C 2140C CONFIDENCE LIMITS TABLE FOR CPK 2141C 2142 ITITL9='Confidence Limits for Cpk Statistic' 2143 NCTIT9=35 2144 ITITL2(2,2)='of Cpk' 2145 NCTIT2(2,2)=6 2146C 2147 DO4623I=1,NUMROW 2148 DO4625J=1,NUMCOL 2149 NCVALU(I,J)=0 2150 IVALUE(I,J)=' ' 2151 AMAT(I,J)=0.0 2152 4625 CONTINUE 2153C 2154 PTEMP=ALPHA(I)/100.0 2155 PTEMPL=(1.0 - PTEMP)/2.0 2156 PTEMPU=1.0 - PTEMPL 2157 ALOWER=0.0 2158 AUPPER=0.0 2159 CALL NORPPF(PTEMPU,PPFU) 2160 TERM1=1.0/(9.0*AN) 2161 TERM2=YCPK*YCPK/(2.0*(AN-1.0)) 2162 ALOWER=YCPK - PPFU*SQRT(TERM1 + TERM2) 2163 AUPPER=YCPK + PPFU*SQRT(TERM1 + TERM2) 2164 AMAT(I,1)=ALPHA(I) 2165 AMAT(I,2)=YCPK 2166 AMAT(I,3)=ALOWER 2167 AMAT(I,4)=AUPPER 2168 4623 CONTINUE 2169C 2170 IWRTF(1)=800 2171 IWRTF(2)=IWRTF(1)+2000 2172 IWRTF(3)=IWRTF(2)+2000 2173 IWRTF(4)=IWRTF(2)+2000 2174 IFRST=.TRUE. 2175 ILAST=.TRUE. 2176C 2177 ISTEPN='5C' 2178 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CAA2') 2179 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2180C 2181 CALL DPDTA4(ITITL9,NCTIT9, 2182 1 ITITLE,NCTITL,ITITL2,NCTIT2, 2183 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 2184 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW, 2185 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 2186 1 ICAPSW,ICAPTY,IFRST,ILAST, 2187 1 ISUBRO,IBUGA3,IERROR) 2188C 2189C 2190C ***************** 2191C ** STEP 90-- ** 2192C ** EXIT ** 2193C ***************** 2194C 2195 9000 CONTINUE 2196 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CAA2')THEN 2197 WRITE(ICOUT,999) 2198 CALL DPWRST('XXX','BUG ') 2199 WRITE(ICOUT,9011) 2200 9011 FORMAT('***** AT THE END OF DPCAA2--') 2201 CALL DPWRST('XXX','BUG ') 2202 WRITE(ICOUT,9014)IFLAG 2203 9014 FORMAT('IFLAG = ',A4) 2204 CALL DPWRST('XXX','BUG ') 2205 ENDIF 2206C 2207 RETURN 2208 END 2209 SUBROUTINE DPCAA5(CCLSL,CCUSL,CCTARG,CCUSLC, 2210 1 YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL, 2211 1 YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL, 2212 1 YCNPK,YCPM,YCPMLL,YCPMUL,YCC, 2213 1 YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO, 2214 1 IFLAGU,IFRST,ILAST, 2215 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 2216C 2217C PURPOSE--UTILITY ROUTINE USED BY DPCAAN. THIS ROUTINE 2218C UPDATES VARIOUS PARAMETERS. 2219C WRITTEN BY--ALAN HECKERT 2220C STATISTICAL ENGINEERING DIVISION 2221C INFORMATION TECHNOLOGY LABORAOTRY 2222C NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY 2223C GAITHERSBURG, MD 20899-8980 2224C PHONE--301-975-2899 2225C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 2226C OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY. 2227C LANGUAGE--ANSI FORTRAN (1977) 2228C VERSION NUMBER--2011/5 2229C ORIGINAL VERSION--MAY 2011. 2230C UPDATED --APRIL 2019. USER CAN SPECIFY NUMBER OF 2231C DECIMAL POINTS FOR AUXILLARY 2232C FILES 2233C 2234C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 2235C 2236 CHARACTER*4 IFLAGU 2237 CHARACTER*4 IBUGA2 2238 CHARACTER*4 IBUGA3 2239 CHARACTER*4 ISUBRO 2240 CHARACTER*4 IERROR 2241C 2242 LOGICAL IFRST 2243 LOGICAL ILAST 2244C 2245 CHARACTER*4 IH 2246 CHARACTER*4 IH2 2247 CHARACTER*4 ISUBN0 2248 CHARACTER*4 ISUBN1 2249 CHARACTER*4 ISUBN2 2250 CHARACTER*4 ISTEPN 2251 CHARACTER*4 IOP 2252 CHARACTER*20 IFORMT 2253C 2254C--------------------------------------------------------------------- 2255C 2256 SAVE IOUNI1 2257C 2258C-----COMMON VARIABLES (GENERAL)-------------------------------------- 2259C 2260 INCLUDE 'DPCOPA.INC' 2261 INCLUDE 'DPCOHK.INC' 2262 INCLUDE 'DPCOHO.INC' 2263 INCLUDE 'DPCOST.INC' 2264C 2265 INCLUDE 'DPCOP2.INC' 2266C 2267C-----START POINT----------------------------------------------------- 2268C 2269 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CAA5')THEN 2270 ISTEPN='1' 2271 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2272 WRITE(ICOUT,999) 2273 999 FORMAT(1X) 2274 CALL DPWRST('XXX','BUG ') 2275 WRITE(ICOUT,51) 2276 51 FORMAT('***** AT THE BEGINNING OF DPCAA5--') 2277 CALL DPWRST('XXX','BUG ') 2278 WRITE(ICOUT,53)CCLSL,CCUSL,CCTARG,CCUSLC 2279 53 FORMAT('CCLSL,CCUSL,CCTARG,CCUSLC = ',4G15.7) 2280 CALL DPWRST('XXX','BUG ') 2281 ENDIF 2282C 2283 IF(IFLAGU.EQ.'FILE')THEN 2284C 2285 IF(IFRST)THEN 2286 IOP='OPEN' 2287 IFLAG1=1 2288 IFLAG2=0 2289 IFLAG3=0 2290 IFLAG4=0 2291 IFLAG5=0 2292 CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5, 2293 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 2294 1 IBUGA3,ISUBRO,IERROR) 2295 IF(IERROR.EQ.'YES')GOTO9000 2296C 2297 WRITE(IOUNI1,295) 2298 295 FORMAT(9X,'CPSTAT',11X,'CPLL',11X,'CPUL', 2299 1 8X,'CPKSTAT',10X,'CPKLL',10X,'CPKUL', 2300 1 8X,'CPLSTAT',10X,'CPLLL',10X,'CPLUL', 2301 1 8X,'CPUSTAT',10X,'CPULL',10X,'CPUUL', 2302 1 7X,'CNPKSTAT', 2303 1 8X,'CPMSTAT',10X,'CPMLL',10X,'CPMUL', 2304 1 7X,'ACTUALPD',7X,'ACTUALLL',7X,'ACTUALUL', 2305 1 9X,'CCSTAT',8X,'THEORPD',8X,'THEORLL', 2306 1 8X,'EXPLOSS') 2307 ENDIF 2308C 2309 IFORMT='(23E15.7)' 2310 IF(IAUXDP.NE.7)THEN 2311 IFORMT=' ' 2312 IF(IAUXDP.LE.9)THEN 2313 IFORMT='(23Exx.x)' 2314 ITOT=IAUXDP+8 2315 WRITE(IFORMT(5:6),'(I2)')ITOT 2316 WRITE(IFORMT(8:8),'(I1)')IAUXDP 2317 ELSE 2318 IFORMT='(23Exx.xx)' 2319 ITOT=IAUXDP+8 2320 WRITE(IFORMT(5:6),'(I2)')ITOT 2321 WRITE(IFORMT(8:9),'(I2)')IAUXDP 2322 ENDIF 2323 ENDIF 2324C 2325 WRITE(IOUNI1,IFORMT)YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL, 2326 1 YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL, 2327 1 YCNPK,YCPM,YCPMLL,YCPMUL,YACTPD,YACTLL,YACTUL, 2328 1 YCC,YTHERPD,YTHEL,YEXPLO 2329CC299 FORMAT(23E15.7) 2330 ELSEIF(IFLAGU.EQ.'ON')THEN 2331 IH='CPST' 2332 IH2='AT ' 2333 VALUE0=YCP 2334 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2335 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2336 1 IANS,IWIDTH,IBUGA3,IERROR) 2337C 2338 IH='CPLL' 2339 IH2=' ' 2340 VALUE0=YCPLL 2341 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2342 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2343 1 IANS,IWIDTH,IBUGA3,IERROR) 2344C 2345 IH='CPUL' 2346 IH2=' ' 2347 VALUE0=YCPUL 2348 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2349 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2350 1 IANS,IWIDTH,IBUGA3,IERROR) 2351C 2352 IH='CPKS' 2353 IH2='TAT ' 2354 VALUE0=YCPK 2355 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2356 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2357 1 IANS,IWIDTH,IBUGA3,IERROR) 2358C 2359 IH='CPKL' 2360 IH2='L ' 2361 VALUE0=YCPKLL 2362 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2363 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2364 1 IANS,IWIDTH,IBUGA3,IERROR) 2365C 2366 IH='CPKU' 2367 IH2='L ' 2368 VALUE0=YCPKUL 2369 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2370 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2371 1 IANS,IWIDTH,IBUGA3,IERROR) 2372C 2373 IH='CPLS' 2374 IH2='TAT ' 2375 VALUE0=YCPL 2376 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2377 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2378 1 IANS,IWIDTH,IBUGA3,IERROR) 2379C 2380 IH='CPLL' 2381 IH2='L ' 2382 VALUE0=YCPLLL 2383 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2384 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2385 1 IANS,IWIDTH,IBUGA3,IERROR) 2386C 2387 IH='CPLU' 2388 IH2='L ' 2389 VALUE0=YCPLUL 2390 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2391 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2392 1 IANS,IWIDTH,IBUGA3,IERROR) 2393C 2394 IH='CPUS' 2395 IH2='TAT ' 2396 VALUE0=YCPU 2397 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2398 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2399 1 IANS,IWIDTH,IBUGA3,IERROR) 2400C 2401 IH='CPUL' 2402 IH2='L ' 2403 VALUE0=YCPULL 2404 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2405 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2406 1 IANS,IWIDTH,IBUGA3,IERROR) 2407C 2408 IH='CPUU' 2409 IH2='L ' 2410 VALUE0=YCPUUL 2411 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2412 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2413 1 IANS,IWIDTH,IBUGA3,IERROR) 2414C 2415 IH='CNPK' 2416 IH2='STAT' 2417 VALUE0=YCNPK 2418 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2419 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2420 1 IANS,IWIDTH,IBUGA3,IERROR) 2421C 2422 IH='CPMS' 2423 IH2='TAT ' 2424 VALUE0=YCPM 2425 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2426 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2427 1 IANS,IWIDTH,IBUGA3,IERROR) 2428C 2429 IH='CPML' 2430 IH2='L ' 2431 VALUE0=YCPMLL 2432 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2433 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2434 1 IANS,IWIDTH,IBUGA3,IERROR) 2435C 2436 IH='CPMU' 2437 IH2='L ' 2438 VALUE0=YCPMUL 2439 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2440 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2441 1 IANS,IWIDTH,IBUGA3,IERROR) 2442C 2443 IH='CCST' 2444 IH2='AT ' 2445 VALUE0=YCC 2446 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2447 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2448 1 IANS,IWIDTH,IBUGA3,IERROR) 2449C 2450 IH='ACTU' 2451 IH2='ALPD' 2452 VALUE0=YACTPD 2453 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2454 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2455 1 IANS,IWIDTH,IBUGA3,IERROR) 2456C 2457 IH='THEO' 2458 IH2='RPD ' 2459 VALUE0=YTHEPD 2460 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2461 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2462 1 IANS,IWIDTH,IBUGA3,IERROR) 2463C 2464 IH='ACTU' 2465 IH2='ALLL' 2466 VALUE0=YACTL 2467 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2468 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2469 1 IANS,IWIDTH,IBUGA3,IERROR) 2470C 2471 IH='THEO' 2472 IH2='RLL ' 2473 VALUE0=YTHEL 2474 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2475 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2476 1 IANS,IWIDTH,IBUGA3,IERROR) 2477C 2478 IH='ACTU' 2479 IH2='ALUL' 2480 VALUE0=YACTU 2481 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2482 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2483 1 IANS,IWIDTH,IBUGA3,IERROR) 2484C 2485 IH='THEO' 2486 IH2='RUL ' 2487 VALUE0=YTHEU 2488 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2489 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2490 1 IANS,IWIDTH,IBUGA3,IERROR) 2491C 2492 IH='EXPL' 2493 IH2='OSS ' 2494 VALUE0=YEXPLO 2495 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2496 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2497 1 IANS,IWIDTH,IBUGA3,IERROR) 2498C 2499 ENDIF 2500C 2501 IF(IFLAGU.EQ.'FILE')THEN 2502 IF(ILAST)THEN 2503 IOP='CLOS' 2504 IFLAG1=1 2505 IFLAG2=0 2506 IFLAG3=0 2507 IFLAG4=0 2508 IFLAG5=0 2509 CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5, 2510 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 2511 1 IBUGA3,ISUBRO,IERROR) 2512C 2513 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CAA5')THEN 2514 ISTEPN='3A' 2515 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2516 WRITE(ICOUT,999) 2517 CALL DPWRST('XXX','BUG ') 2518 WRITE(ICOUT,301)IERROR 2519 301 FORMAT('AFTER CALL DPCLFI, IERROR = ',A4) 2520 CALL DPWRST('XXX','BUG ') 2521 ENDIF 2522C 2523 IF(IERROR.EQ.'YES')GOTO9000 2524 ENDIF 2525 ENDIF 2526C 2527C ***************** 2528C ** STEP 90-- ** 2529C ** EXIT ** 2530C ***************** 2531C 2532 9000 CONTINUE 2533C 2534 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CAA5')THEN 2535 WRITE(ICOUT,999) 2536 CALL DPWRST('XXX','BUG ') 2537 WRITE(ICOUT,9011) 2538 9011 FORMAT('***** AT THE END OF DPCAA5--') 2539 CALL DPWRST('XXX','BUG ') 2540 ENDIF 2541C 2542 RETURN 2543 END 2544 SUBROUTINE DPCAPA(IHARG,IARGT,ARG,NUMARG, 2545 1 PXSTAR,PYSTAR,PXEND,PYEND, 2546 1 ILINPA,ILINCO,PLINTH, 2547 1 AREGBA,IREBLI,IREBCO,PREBTH, 2548 1 IREFSW,IREFCO, 2549 1 IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 2550 1 PTEXHE,PTEXWI,PTEXVG,PTEXHG, 2551 1 IGRASW,IDIASW, 2552 1 PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 2553 1 PDIAHE,PDIAWI,PDIAVG,PDIAHG, 2554 1 NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3, 2555 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 2556 1 IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL, 2557 1 IBUGD2,IFOUND,IERROR) 2558C 2559C PURPOSE--DRAW ONE OR MORE CAPACITORS (DEPENDING ON HOW MANY NUMBERS ARE 2560C PROVIDED). THE COORDINATES ARE IN STANDARDIZED UNITS 2561C OF 0 TO 100. 2562C NOTE--THE INPUT COORDINATES DEFINE THE BACK CENTER AND THE FRONT CENTER 2563C OF THE CAPACITOR. 2564C NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 2 2565C AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*2 = 4. 2566C NOTE--IF 2 NUMBERS ARE PROVIDED, THEN THE DRAWN CAPACITOR WILL GO FROM 2567C THE LAST CURSOR POSITION TO THE (X,Y) POINT (EITHER ABSOLUTE OR 2568C RELATIVE) AS DEFINED BY THE 2 NUMBERS. 2569C NOTE--IF 4 NUMBERS ARE PROVIDED, THEN THE DRAWN CAPACITOR WILL GO FROM 2570C THE ABSOLUTE (X,Y) POSITION AS DEFINED BY THE FIRST 2 NUMBERS TO 2571C THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) AS DEFINED BY THE 2572C THIRD AND FOURTH NUMBERS. 2573C NOTE--IF 6 NUMBERS ARE PROVIDED, THEN THE DRAWN CAPACITOR WILL GO FROM 2574C THE (X,Y) POSITION AS RESULTING FROM THE THIRD AND FOURTH NUMBERS 2575C TO THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) AS DEFINED BY 2576C THE FIFTH AND SIXTH NUMBERS. 2577C NOTE--AND SO FORTH FOR 8, 10, 12, ... NUMBERS. 2578C INPUT ARGUMENTS--IHARG 2579C --IARGT 2580C --ARG 2581C --NUMARG 2582C --PXSTAR 2583C --PYSTAR 2584C OUTPUT ARGUMENTS--PXEND 2585C --PYEND 2586C --IFOUND ('YES' OR 'NO' ) 2587C --IERROR ('YES' OR 'NO' ) 2588C WRITTEN BY--JAMES J. FILLIBEN 2589C STATISTICAL ENGINEERING DIVISION 2590C INFORMATION TECHNOLOGY LABORATORY 2591C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 2592C GAITHERSBURG, MD 20899-8980 2593C PHONE--301-975-2899 2594C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 2595C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 2596C LANGUAGE--ANSI FORTRAN (1977) 2597C VERSION NUMBER--82/7 2598C ORIGINAL VERSION--APRIL 1981. 2599C UPDATED --MARCH 1982. 2600C UPDATED --MAY 1982. 2601C UPDATED --NOVEMBER 1982. 2602C UPDATED --JANUARY 1989. CALL LIST FOR OFFSET VAR (ALAN) 2603C UPDATED --MARCH 1997. SUPPORT FOR DEVICE FONT (ALAN) 2604C UPDATED --JULY 1997. SUPPORT FOR "DATA" UNITS (ALAN) 2605C UPDATED --DECEMBER 2018. CHECK FOR DISCRETE, NULL, OR 2606C NONE DEVICE 2607C UPDATED --DECEMBER 2018. SUPPORT FOR "DEVICE ... SCALE" 2608C COMMAND 2609C 2610C-----NON-COMMON VARIABLES----------------------------------------- 2611C 2612 CHARACTER*4 IHARG 2613 CHARACTER*4 IARGT 2614C 2615 CHARACTER*4 ILINPA 2616 CHARACTER*4 ILINCO 2617C 2618 CHARACTER*4 IREBLI 2619 CHARACTER*4 IREBCO 2620 CHARACTER*4 IREFSW 2621 CHARACTER*4 IREFCO 2622 CHARACTER*4 IREPTY 2623 CHARACTER*4 IREPLI 2624 CHARACTER*4 IREPCO 2625C 2626 CHARACTER*4 IGRASW 2627 CHARACTER*4 IDIASW 2628C 2629 CHARACTER*4 IDMANU 2630 CHARACTER*4 IDMODE 2631 CHARACTER*4 IDMOD2 2632 CHARACTER*4 IDMOD3 2633 CHARACTER*4 IDPOWE 2634 CHARACTER*4 IDCONT 2635 CHARACTER*4 IDCOLO 2636CCCCC ADD FOLLOWING LINE MARCH 1997. 2637 CHARACTER*4 IDFONT 2638CCCCC ADD FOLLOWING LINE JULY 1997. 2639 CHARACTER*4 UNITSW 2640C 2641 CHARACTER*4 IFOUND 2642 CHARACTER*4 IBUGD2 2643 CHARACTER*4 IERROR 2644 CHARACTER*4 ISUBRO 2645C 2646 CHARACTER*4 IFIG 2647 CHARACTER*4 IBELSW 2648 CHARACTER*4 IERASW 2649 CHARACTER*4 IBACCO 2650 CHARACTER*4 ICOPSW 2651 CHARACTER*4 ITYPEO 2652C 2653 DIMENSION IHARG(*) 2654 DIMENSION IARGT(*) 2655 DIMENSION ARG(*) 2656C 2657 DIMENSION ILINPA(*) 2658 DIMENSION ILINCO(*) 2659 DIMENSION PLINTH(*) 2660C 2661 DIMENSION AREGBA(*) 2662 DIMENSION IREBLI(*) 2663 DIMENSION IREBCO(*) 2664 DIMENSION PREBTH(*) 2665 DIMENSION IREFSW(*) 2666 DIMENSION IREFCO(*) 2667 DIMENSION IREPTY(*) 2668 DIMENSION IREPLI(*) 2669 DIMENSION IREPCO(*) 2670 DIMENSION PREPTH(*) 2671 DIMENSION PREPSP(*) 2672 DIMENSION PDSCAL(*) 2673C 2674 DIMENSION IDMANU(*) 2675 DIMENSION IDMODE(*) 2676 DIMENSION IDMOD2(*) 2677 DIMENSION IDMOD3(*) 2678 DIMENSION IDPOWE(*) 2679 DIMENSION IDCONT(*) 2680 DIMENSION IDCOLO(*) 2681CCCCC ADD FOLLOWING LINE MARCH 1997. 2682 DIMENSION IDFONT(*) 2683 DIMENSION IDNVPP(*) 2684 DIMENSION IDNHPP(*) 2685 DIMENSION IDUNIT(*) 2686C 2687 DIMENSION IDNVOF(*) 2688 DIMENSION IDNHOF(*) 2689C 2690C-----COMMON---------------------------------------------------------- 2691C 2692 INCLUDE 'DPCOGR.INC' 2693 INCLUDE 'DPCOBE.INC' 2694C 2695C-----COMMON VARIABLES (GENERAL)-------------------------------------- 2696C 2697 INCLUDE 'DPCOP2.INC' 2698C 2699C-----START POINT----------------------------------------------------- 2700C 2701 IFOUND='NO' 2702 IERROR='NO' 2703 IERRG4=IERROR 2704CCCCC IBUGG4=IBUGD2 2705CCCCC ISUBG4=ISUBRO 2706C 2707 ILOCFN=0 2708 NUMNUM=0 2709C 2710 X1=0.0 2711 Y1=0.0 2712 X2=0.0 2713 Y2=0.0 2714C 2715 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CAPA')GOTO90 2716 WRITE(ICOUT,999) 2717 999 FORMAT(1X) 2718 CALL DPWRST('XXX','BUG ') 2719 WRITE(ICOUT,51) 2720 51 FORMAT('***** AT THE BEGINNING OF DPCAPA--') 2721 CALL DPWRST('XXX','BUG ') 2722 WRITE(ICOUT,53)NUMARG 2723 53 FORMAT('NUMARG = ',I8) 2724 CALL DPWRST('XXX','BUG ') 2725 DO55I=1,NUMARG 2726 WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I) 2727 56 FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2X,A4,2X,A4,E15.7) 2728 CALL DPWRST('XXX','BUG ') 2729 55 CONTINUE 2730 WRITE(ICOUT,57)PXSTAR,PYSTAR 2731 57 FORMAT('PXSTAR,PYSTAR = ',2E15.7) 2732 CALL DPWRST('XXX','BUG ') 2733 WRITE(ICOUT,58)PXEND,PYEND 2734 58 FORMAT('PXEND,PYEND = ',2E15.7) 2735 CALL DPWRST('XXX','BUG ') 2736 WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1) 2737 61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7) 2738 CALL DPWRST('XXX','BUG ') 2739 WRITE(ICOUT,62)AREGBA(1) 2740 62 FORMAT('AREGBA(1) = ',E15.7) 2741 CALL DPWRST('XXX','BUG ') 2742 WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1) 2743 63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7) 2744 CALL DPWRST('XXX','BUG ') 2745 WRITE(ICOUT,64)IREFSW(1),IREFCO(1) 2746 64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4) 2747 CALL DPWRST('XXX','BUG ') 2748 WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) 2749 65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ', 2750 1A4,2X,A4,2X,A4,2E15.7) 2751 CALL DPWRST('XXX','BUG ') 2752 WRITE(ICOUT,69)PTEXHE,PTEXWI 2753 69 FORMAT('PTEXHE,PTEXWI= ',2E15.7) 2754 CALL DPWRST('XXX','BUG ') 2755 WRITE(ICOUT,70)PTEXVG,PTEXHG 2756 70 FORMAT('PTEXVG,PTEXHG= ',2E15.6) 2757 CALL DPWRST('XXX','BUG ') 2758 WRITE(ICOUT,76)IGRASW,IDIASW 2759 76 FORMAT('IGRASW,IDIASW = ',A4,2X,A4) 2760 CALL DPWRST('XXX','BUG ') 2761 WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC 2762 77 FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4E15.7) 2763 CALL DPWRST('XXX','BUG ') 2764 WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG 2765 78 FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4E15.7) 2766 CALL DPWRST('XXX','BUG ') 2767 WRITE(ICOUT,80)NUMDEV 2768 80 FORMAT('NUMDEV= ',I8) 2769 CALL DPWRST('XXX','BUG ') 2770 DO81I=1,NUMDEV 2771 WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) 2772 82 FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ', 2773 1A4,2X,A4,2X,A4,2X,A4) 2774 CALL DPWRST('XXX','BUG ') 2775 WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I) 2776 83 FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ', 2777 1A4,2X,A4,2X,A4) 2778 CALL DPWRST('XXX','BUG ') 2779 WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I) 2780 84 FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ', 2781 1I8,I8,I8) 2782 CALL DPWRST('XXX','BUG ') 2783 81 CONTINUE 2784 WRITE(ICOUT,87)IFOUND 2785 87 FORMAT('IFOUND= ',A4) 2786 CALL DPWRST('XXX','BUG ') 2787 WRITE(ICOUT,88)IBUGG4,ISUBG4,IERRG4 2788 88 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 2789 CALL DPWRST('XXX','BUG ') 2790 WRITE(ICOUT,89)IBUGD2,IERROR 2791 89 FORMAT('IBUGD2,IERROR= ',A4,2X,A4) 2792 CALL DPWRST('XXX','BUG ') 2793 90 CONTINUE 2794C 2795 IFIG='CAPA' 2796 NUMPT=2 2797 NUMPT2=2*NUMPT 2798C 2799C ******************************** 2800C ** STEP 0-- ** 2801C ** STEP THROUGH EACH DEVICE ** 2802C ******************************** 2803C 2804 IF(NUMDEV.LE.0)GOTO9000 2805 DO8000IDEVIC=1,NUMDEV 2806C 2807 IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000 2808 IF(IDMANU(IDEVIC).EQ.'OFF')GOTO8000 2809 IF(IDMANU(IDEVIC).EQ.'NULL')GOTO8000 2810 IF(IDMANU(IDEVIC).EQ.'NONE')GOTO8000 2811 IF(IDMANU(IDEVIC).EQ.'DISC')GOTO8000 2812C 2813 IMANUF=IDMANU(IDEVIC) 2814 IMODEL=IDMODE(IDEVIC) 2815 IMODE2=IDMOD2(IDEVIC) 2816 IMODE3=IDMOD3(IDEVIC) 2817 IGCONT=IDCONT(IDEVIC) 2818 IGCOLO=IDCOLO(IDEVIC) 2819 IGFONT=IDFONT(IDEVIC) 2820 NUMVPP=IDNVPP(IDEVIC) 2821 NUMHPP=IDNHPP(IDEVIC) 2822 ANUMVP=NUMVPP 2823 ANUMHP=NUMHPP 2824 IOFFSV=IDNVOF(IDEVIC) 2825 IOFFSH=IDNHOF(IDEVIC) 2826 IGUNIT=IDUNIT(IDEVIC) 2827 PCHSCA=PDSCAL(IDEVIC) 2828C 2829C ************************************ 2830C ** STEP 1-- ** 2831C ** CARRY OUT OPENING OPERATIONS ** 2832C ** ON THE GRAPHICS DEVICES ** 2833C ************************************ 2834C 2835 CALL DPOPDE 2836C 2837 IBELSW='OFF' 2838 NUMRIN=0 2839 IERASW='OFF' 2840 IBACCO='JUNK' 2841C 2842 CALL DPOPPL(IGRASW, 2843 1IBELSW,NUMRIN,IERASW, 2844 1IBACCO) 2845C 2846C ***************************************** 2847C ** STEP 2-- ** 2848C ** SEARCH FOR COMMAND SPECIFICATIONS ** 2849C ***************************************** 2850C 2851 IF(NUMARG.GE.2.AND. 2852 1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB') 2853 1GOTO1111 2854 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND. 2855 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 2856 1GOTO1112 2857 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND. 2858 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 2859 1GOTO1113 2860 GOTO1130 2861C 2862 1111 CONTINUE 2863 ITYPEO='ABSO' 2864 ILOCFN=1 2865 GOTO1119 2866C 2867 1112 CONTINUE 2868 ITYPEO='ABSO' 2869 ILOCFN=2 2870 GOTO1119 2871C 2872 1113 CONTINUE 2873 ITYPEO='RELA' 2874 ILOCFN=2 2875 GOTO1119 2876 1119 CONTINUE 2877C 2878 IF(ILOCFN.GT.NUMARG)GOTO1129 2879 DO1120I=ILOCFN,NUMARG 2880 IF(IARGT(I).EQ.'NUMB')GOTO1120 2881 GOTO1129 2882 1120 CONTINUE 2883 IFOUND='YES' 2884 GOTO1149 2885 1129 CONTINUE 2886 GOTO1130 2887C 2888 1130 CONTINUE 2889 IERRG4='YES' 2890 WRITE(ICOUT,1131) 2891 1131 FORMAT('***** ERROR IN DPCAPA--') 2892 CALL DPWRST('XXX','BUG ') 2893 WRITE(ICOUT,1132) 2894 1132 FORMAT(' ILLEGAL FORM FOR DRAW ', 2895 1'COMMAND.') 2896 CALL DPWRST('XXX','BUG ') 2897 WRITE(ICOUT,1134) 2898 1134 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 2899 1'PROPER FORM--') 2900 CALL DPWRST('XXX','BUG ') 2901 WRITE(ICOUT,1135) 2902 1135 FORMAT(' SUPPOSE IT IS DESIRED TO DRAW A CAPACITOR ') 2903 CALL DPWRST('XXX','BUG ') 2904 WRITE(ICOUT,1136) 2905 1136 FORMAT(' WITH BACK CENTER AT 20 20 ') 2906 CALL DPWRST('XXX','BUG ') 2907 WRITE(ICOUT,1137) 2908 1137 FORMAT(' AND FRONT CENTER AT 40 60') 2909 CALL DPWRST('XXX','BUG ') 2910 WRITE(ICOUT,1141) 2911 1141 FORMAT(' THEN THE ALLOWABLE FORMS ARE--') 2912 CALL DPWRST('XXX','BUG ') 2913 WRITE(ICOUT,1142) 2914 1142 FORMAT(' CAPACITOR 20 20 40 60 ') 2915 CALL DPWRST('XXX','BUG ') 2916 WRITE(ICOUT,1143) 2917 1143 FORMAT(' CAPACITOR ABSOLUTE 20 20 40 60 ') 2918 CALL DPWRST('XXX','BUG ') 2919 GOTO9000 2920 1149 CONTINUE 2921C 2922C **************************** 2923C ** STEP 3-- ** 2924C ** DRAW OUT THE LINE(S) ** 2925C **************************** 2926C 2927 NUMNUM=NUMARG-ILOCFN+1 2928 IF(NUMNUM.LT.NUMPT2)GOTO1151 2929 GOTO1152 2930C 2931 1151 CONTINUE 2932 J=ILOCFN-1 2933 X1=PXSTAR 2934 Y1=PYSTAR 2935 GOTO1159 2936C 2937 1152 CONTINUE 2938 J=ILOCFN 2939 IF(J.GT.NUMARG)GOTO1190 2940 X1=ARG(J) 2941CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 2942 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,IBUGD2,ISUBRO,IERROR) 2943 J=J+1 2944 IF(J.GT.NUMARG)GOTO1190 2945 Y1=ARG(J) 2946CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 2947 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBRO,IERROR) 2948 GOTO1159 2949 1159 CONTINUE 2950C 2951 1160 CONTINUE 2952 J=J+1 2953 IF(J.GT.NUMARG)GOTO1190 2954 X2=ARG(J) 2955CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 2956 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR) 2957 IF(ITYPEO.EQ.'RELA')X2=X1+X2 2958 J=J+1 2959 IF(J.GT.NUMARG)GOTO1190 2960 Y2=ARG(J) 2961CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 2962 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR) 2963 IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2 2964C 2965 CALL DPCAP2(X1,Y1,X2,Y2, 2966 1 IFIG, 2967 1 ILINPA,ILINCO,PLINTH, 2968 1 AREGBA, 2969 1 IREBLI,IREBCO,PREBTH, 2970 1 IREFSW,IREFCO, 2971 1 IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 2972 1 PTEXHE,PTEXWI,PTEXVG,PTEXHG) 2973C 2974 X1=X2 2975 Y1=Y2 2976C 2977 GOTO1160 2978 1190 CONTINUE 2979C 2980 PXEND=X2 2981 PYEND=Y2 2982C 2983C ************************************ 2984C ** STEP 4-- ** 2985C ** CARRY OUT CLOSING OPERATIONS ** 2986C ** ON THE GRAPHICS DEVICES ** 2987C ************************************ 2988C 2989 ICOPSW='OFF' 2990 NUMCOP=0 2991 CALL DPCLPL(ICOPSW,NUMCOP, 2992 1PGRAXF,PGRAYF, 2993 1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 2994 1PDIAHE,PDIAWI,PDIAVG,PDIAHG) 2995C 2996 CALL DPCLDE 2997C 2998 8000 CONTINUE 2999C 3000C ***************** 3001C ** STEP 90-- ** 3002C ** EXIT ** 3003C ***************** 3004C 3005 9000 CONTINUE 3006 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CAPA')GOTO9090 3007 WRITE(ICOUT,999) 3008 CALL DPWRST('XXX','BUG ') 3009 WRITE(ICOUT,9011) 3010 9011 FORMAT('***** AT THE END OF DPCAPA--') 3011 CALL DPWRST('XXX','BUG ') 3012 WRITE(ICOUT,9012)ILOCFN,NUMNUM 3013 9012 FORMAT('ILOCFN,NUMNUM = ',2I8) 3014 CALL DPWRST('XXX','BUG ') 3015 WRITE(ICOUT,9013)X1,Y1,X2,Y2 3016 9013 FORMAT('X1,Y1,X2,Y2 = ',4E15.7) 3017 CALL DPWRST('XXX','BUG ') 3018 WRITE(ICOUT,9015)PXSTAR,PYSTAR 3019 9015 FORMAT('PXSTAR,PYSTAR = ',2E15.7) 3020 CALL DPWRST('XXX','BUG ') 3021 WRITE(ICOUT,9016)PXEND,PYEND 3022 9016 FORMAT('PXEND,PYEND = ',2E15.7) 3023 CALL DPWRST('XXX','BUG ') 3024 WRITE(ICOUT,9017)IFIG 3025 9017 FORMAT('IFIG = ',A4) 3026 CALL DPWRST('XXX','BUG ') 3027 WRITE(ICOUT,9027)IFOUND 3028 9027 FORMAT('IFOUND = ',A4) 3029 CALL DPWRST('XXX','BUG ') 3030 WRITE(ICOUT,9028)IBUGG4,ISUBG4,IERRG4 3031 9028 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4) 3032 CALL DPWRST('XXX','BUG ') 3033 WRITE(ICOUT,9029)IBUGD2,IERROR 3034 9029 FORMAT('IBUGD2,IERROR = ',A4,2X,A4) 3035 CALL DPWRST('XXX','BUG ') 3036 9090 CONTINUE 3037C 3038 RETURN 3039 END 3040 SUBROUTINE DPCAP2(X1,Y1,X2,Y2, 3041 1IFIG, 3042 1ILINPA,ILINCO,PLINTH, 3043 1AREGBA, 3044 1IREBLI,IREBCO,PREBTH, 3045 1IREFSW,IREFCO, 3046 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 3047 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) 3048C 3049C PURPOSE--DRAW AN CAPACITOR 3050C WITH THE BACK CENTER AT (X1,Y1) 3051C AND THE FRONT CENTER AT (X2,Y2). 3052C WRITTEN BY--JAMES J. FILLIBEN 3053C STATISTICAL ENGINEERING DIVISION 3054C INFORMATION TECHNOLOGY LABORATORY 3055C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 3056C GAITHERSBURG, MD 20899-8980 3057C PHONE--301-975-2899 3058C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 3059C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 3060C LANGUAGE--ANSI FORTRAN (1977) 3061C VERSION NUMBER--82/7 3062C ORIGINAL VERSION--APRIL 1981. 3063C UPDATED --MAY 1982. 3064C UPDATED --JANUARY 1989. MODIFY CALLS TO DPDRPL (ALAN) 3065C 3066C-----NON-COMMON VARIABLES------------------------------------- 3067C 3068 CHARACTER*4 IFIG 3069C 3070 CHARACTER*4 ILINPA 3071 CHARACTER*4 ILINCO 3072C 3073 CHARACTER*4 IREBLI 3074 CHARACTER*4 IREBCO 3075 CHARACTER*4 IREFSW 3076 CHARACTER*4 IREFCO 3077 CHARACTER*4 IREPTY 3078 CHARACTER*4 IREPLI 3079 CHARACTER*4 IREPCO 3080C 3081 CHARACTER*4 IPATT 3082CCCCC CHARACTER*4 ICOLF 3083CCCCC CHARACTER*4 ICOLP 3084 CHARACTER*4 ICOL 3085 CHARACTER*4 IFLAG 3086C 3087 DIMENSION PX(10) 3088 DIMENSION PY(10) 3089CCCCC DIMENSION PX3(10) 3090CCCCC DIMENSION PY3(10) 3091C 3092 DIMENSION ILINPA(*) 3093 DIMENSION ILINCO(*) 3094 DIMENSION PLINTH(*) 3095C 3096 DIMENSION AREGBA(*) 3097 DIMENSION IREBLI(*) 3098 DIMENSION IREBCO(*) 3099 DIMENSION PREBTH(*) 3100 DIMENSION IREFSW(*) 3101 DIMENSION IREFCO(*) 3102 DIMENSION IREPTY(*) 3103 DIMENSION IREPLI(*) 3104 DIMENSION IREPCO(*) 3105 DIMENSION PREPTH(*) 3106 DIMENSION PREPSP(*) 3107C 3108C-----COMMON---------------------------------------------------------- 3109C 3110 INCLUDE 'DPCOGR.INC' 3111 INCLUDE 'DPCOBE.INC' 3112C 3113C-----COMMON VARIABLES (GENERAL)-------------------------------------- 3114C 3115 INCLUDE 'DPCOP2.INC' 3116C 3117C-----START POINT----------------------------------------------------- 3118C 3119 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CAP2')GOTO90 3120 WRITE(ICOUT,999) 3121 999 FORMAT(1X) 3122 CALL DPWRST('XXX','BUG ') 3123 WRITE(ICOUT,51) 3124 51 FORMAT('***** AT THE BEGINNING OF DPCAP2--') 3125 CALL DPWRST('XXX','BUG ') 3126 WRITE(ICOUT,53)X1,Y1 3127 53 FORMAT('X1,Y1 = ',2E15.7) 3128 CALL DPWRST('XXX','BUG ') 3129 WRITE(ICOUT,54)X2,Y2 3130 54 FORMAT('X2,Y2 = ',2E15.7) 3131 CALL DPWRST('XXX','BUG ') 3132 WRITE(ICOUT,59)IFIG 3133 59 FORMAT('IFIG = ',A4) 3134 CALL DPWRST('XXX','BUG ') 3135 WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1) 3136 61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7) 3137 CALL DPWRST('XXX','BUG ') 3138 WRITE(ICOUT,62)AREGBA(1) 3139 62 FORMAT('AREGBA(1) = ',E15.7) 3140 CALL DPWRST('XXX','BUG ') 3141 WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1) 3142 63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7) 3143 CALL DPWRST('XXX','BUG ') 3144 WRITE(ICOUT,64)IREFSW(1),IREFCO(1) 3145 64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4) 3146 CALL DPWRST('XXX','BUG ') 3147 WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) 3148 65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ', 3149 1A4,2X,A4,2X,A4,2E15.7) 3150 CALL DPWRST('XXX','BUG ') 3151 WRITE(ICOUT,69)PTEXHE,PTEXWI 3152 69 FORMAT('PTEXHE,PTEXWI= ',2E15.7) 3153 CALL DPWRST('XXX','BUG ') 3154 WRITE(ICOUT,70)PTEXVG,PTEXHG 3155 70 FORMAT('PTEXVG,PTEXHG= ',2E15.6) 3156 CALL DPWRST('XXX','BUG ') 3157 WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4 3158 79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 3159 CALL DPWRST('XXX','BUG ') 3160 90 CONTINUE 3161C 3162C ********************************* 3163C ** STEP 1-- ** 3164C ** DETERMINE THE COORDINATES ** 3165C ** FOR THE CAPACITOR ** 3166C ********************************* 3167C 3168 DELX=X2-X1 3169 DELY=Y2-Y1 3170 LEN=INT(SQRT((X2-X1)**2+(Y2-Y1)**2)) 3171 ALEN=LEN 3172 IF(ABS(DELX).GE.0.00001)THETA=ATAN(DELY/DELX) 3173 IF(ABS(DELX).LT.0.00001.AND.DELY.GE.0.0)THETA=3.1415926/2.0 3174 IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0)THETA=-3.1415926/2.0 3175C 3176 AJXMIN=PTEXWI 3177 AJXDEL=PTEXWI 3178 AJYDEL=PTEXHE 3179 AJXMAX=ALEN-AJXDEL 3180C 3181 XMIN=AJXMIN 3182 XDEL=AJXDEL 3183 YDEL=AJYDEL 3184 XMAX=AJXMAX 3185C 3186 K=0 3187C 3188 X=0 3189CCCCC Y=-ALEN/2.0 3190 Y=(-YDEL/2.0) 3191 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) 3192 K=K+1 3193 PX(K)=XP 3194 PY(K)=YP 3195C 3196 X=0 3197CCCCC Y=ALEN/2.0 3198 Y=YDEL/2.0 3199 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) 3200 K=K+1 3201 PX(K)=XP 3202 PY(K)=YP 3203C 3204 NP=K 3205C 3206 IPATT=ILINPA(1) 3207 PTHICK=PLINTH(1) 3208 ICOL=ILINCO(1) 3209 IFLAG='ON' 3210CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3, 3211CCCCC1IFIG,IPATT,PTHICK,ICOL) 3212 CALL DPDRPL(PX,PY,NP, 3213 1IFIG,IPATT,PTHICK,ICOL, 3214 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 3215C 3216 K=0 3217C 3218 X=ALEN 3219CCCCC Y=-ALEN/2.0 3220 Y=(-YDEL/2.0) 3221 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) 3222 K=K+1 3223 PX(K)=XP 3224 PY(K)=YP 3225C 3226 X=ALEN 3227CCCCC Y=ALEN/2.0 3228 Y=YDEL/2.0 3229 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) 3230 K=K+1 3231 PX(K)=XP 3232 PY(K)=YP 3233C 3234 NP=K 3235C 3236 IFLAG='ON' 3237CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3, 3238CCCCC1IFIG,IPATT,PTHICK,ICOL) 3239 CALL DPDRPL(PX,PY,NP, 3240 1IFIG,IPATT,PTHICK,ICOL, 3241 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 3242C 3243C ***************** 3244C ** STEP 90-- ** 3245C ** EXIT ** 3246C ***************** 3247C 3248 IF(IBUGG4.EQ.'ON' .OR. ISUBG4.EQ.'CAP2')THEN 3249 WRITE(ICOUT,999) 3250 CALL DPWRST('XXX','BUG ') 3251 WRITE(ICOUT,9011) 3252 9011 FORMAT('***** AT THE END OF DPCAP2--') 3253 CALL DPWRST('XXX','BUG ') 3254 DO9015I=1,NP 3255 WRITE(ICOUT,9016)I,PX(I),PY(I) 3256 9016 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7) 3257 CALL DPWRST('XXX','BUG ') 3258 9015 CONTINUE 3259 WRITE(ICOUT,9039)IERRG4,NP 3260 9039 FORMAT('IERRG4,NP = ',A4,2X,I8) 3261 CALL DPWRST('XXX','BUG ') 3262 ENDIF 3263C 3264 RETURN 3265 END 3266 SUBROUTINE DPCAPT(ICOM,ICOM2, 3267 1 ICAPSW,ICAPTY,ICAPSC,IPRDEF, 3268 1 IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,MAXNAM, 3269 1 IANSLC,IANS,IWIDTH, 3270 1 IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 3271 1 IOFILE,IBACCO,IGRASW,IDIASW, 3272 1 PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 3273 1 PDIAHE,PDIAWI,PDIAVG,PDIAHG, 3274 1 NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3, 3275 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 3276 1 IDNVOF,IDNHOF,IDFONT,PDSCAL, 3277 1 IREPCH,IMPSW, 3278 1 IBUGS2,ISUBRO,IFOUND,IERROR) 3279C 3280C PURPOSE--INITIATE/TERMINATE A CAPTURE FILE FOR CAPTURING/REDIRECTING 3281C ALPHANUMERIC OUTPUT (ONLY)--NOT EFFECT GRAPHICS OUTPUT. 3282C THERE ARE 2 CAPABILITITES IN THIS REGARD-- 3283C 1) TURN THE CAPTURE SWITCH 'ON' WHICH WILL 3284C ALLOW A CAPTURE FILE TO BE OPENED. 3285C 2) TURN THE CAPTURE SWITCH 'OFF' WHICH WILL TERMINATE 3286C THE ENTRY OF TEXT OUTPUT INTO THE CAPTURE FILE. 3287C NOTE--THESE CAPABILITITIES WILL ALLOW THE ALPHANUMERIC OUTPUT (NOT 3288C GRAPHICS OUTPUT) FROM ANY DATAPLOT COMMAND TO BE CAPTURED 3289C (OR REDIRECTED) TO ANY FILE. ALL SUBSEQUENT DATAPLOT 3290C ALPHANUMERIC OUTPUT ARE AUTOMATICALLY DIVERTED FROM THE SCREEN 3291C TO THE SPECIFIED SYSTEM FILE OR SUBFILE. WHEN THE CAPTURE 3292C SWITCH IS OFF, NO SUCH DIVERSION IS DONE. THE SPECIFIED 3293C STATUS (ON/OFF) OF THE CAPTURE WILL BE PLACED IN THE VARIABLE 3294C ICAPSW. 3295C INPUT ARGUMENTS--ICOM 3296C --ICOM2 3297C --ICAPSW 3298C --ICAPTY 3299C --IANSLC (A HOLLERITH VECTOR WHOSE 3300C I-TH ELEMENT CONTAINS THE 3301C I-TH CHARACTER OF THE 3302C ORIGINAL INPUT COMMAND LINE. 3303C --IWIDTH (AN INTEGER VARIABLE WHICH 3304C CONTAINS THE NUMBER OF CHARACTERS 3305C IN THE ORIGINAL COMMAND LINE. 3306C --IHARG (A HOLLERITH VECTOR) 3307C --NUMARG (AN INTEGER VARIABLE) 3308C --IBUG (A HOLLERITH VARIABLE 3309C FOR DEBUGGING 3310C PRIMARY CHANGED VARIABLE--IPR (IN COMMON) 3311C OUTPUT ARGUMENTS--ICAPSW (AN INTEGER VARIABLE 3312C WHICH IF 'ON' INDICATES THAT 3313C CURRENT COMMANDS ARE 3314C BEING DIVERTED 3315C TO A CAPTURE TEXT; AND 3316C IF OFF INDICATES THAT 3317C A CAPTURE FILE IS NOT BEING CONSTRUCTED. 3318C --IFOUND ('YES' OR 'NO' ) 3319C --IERROR ('YES' OR 'NO' ) 3320C WRITTEN BY--JAMES J. FILLIBEN 3321C STATISTICAL ENGINEERING DIVISION 3322C INFORMATION TECHNOLOGY LABORATORY 3323C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 3324C GAITHERSBURG, MD 20899-8980 3325C PHONE--301-975-2899 3326C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 3327C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 3328C LANGUAGE--ANSI FORTRAN (1977) 3329C VERSION NUMBER--89/6 3330C ORIGINAL VERSION--JUNE 1989. 3331C UPDATED --JUNE 2002. ADD SUPPORT FOR: 3332C CAPTURE FLUSH 3333C CAPTURE HTML FILE. 3334C CAPTURE LATEX FILE. 3335C UPDATED --JANUARY 2003. FOR CAPTURE HTML, OPTIONALLY 3336C READ HEADER AND FOOTER FILES 3337C UPDATED --JULY 2003. BUG: FILE NAME < 80 3338C CHARACTERS, BUT COMMAND LINE 3339C > 80 CHARACTERS 3340C UPDATED --SEPTEMBER 2003. START IMPLEMENTING THE LATEX 3341C CODE 3342C UPDATED --FEBRUARY 2005. START IMPLEMENTING THE RTF 3343C CODE 3344C UPDATED --DECEMBER 2005. SUSPEND/RESUME CASES 3345C UPDATED --JANUARY 2006. CAPTURE SCREEN <ON/OFF> 3346C UPDATED --FEBRUARY 2006. ADD EPIC, EEPIC, GRAPHICS 3347C PACKAGES TO LATEX PRE-AMBLE 3348C UPDATED --NOVEMBER 2008. INITIALIZE HTML44 COMMON BLOCK 3349C UPDATED --APRIL 2012. CAPTURE SCRIPT 3350C UPDATED --APRIL 2012. CAPTURE FLUSH ERASE <ON/OFF> 3351C UPDATED --AUGUST 2015. CAPTURE FUNCTION BLOCK 3352C UPDATED --DECEMBER 2015. "NONE" OPTION FOR LATEX/HTML 3353C HEADERS AND FOOTERS 3354C UPDATED --DECEMBER 2015. SET CAPTURE SPLIT ON OPTION 3355C UPDATED --AUGUST 2016. CAPTURE STATISTIC BLOCK 3356C UPDATED --DECEMBER 2018. ADD PDSCAL TO CALL LIST TO DPERAS 3357C 3358C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 3359C 3360 CHARACTER*4 ICOM 3361 CHARACTER*4 ICOM2 3362 CHARACTER*4 ICAPSW 3363 CHARACTER*4 ICAPTY 3364 CHARACTER*4 ICAPSC 3365 CHARACTER*4 IHNAME 3366 CHARACTER*4 IHNAM2 3367 CHARACTER*4 IUSE 3368 CHARACTER*4 IANSLC 3369 CHARACTER*4 IANS 3370 CHARACTER*4 IHARG 3371 CHARACTER*4 IHARG2 3372 CHARACTER*4 IARGT 3373 CHARACTER*4 IOFILE 3374C 3375 CHARACTER*240 IATEMP 3376 CHARACTER*1 ITEMP 3377C 3378 CHARACTER*1 IREPCH 3379 CHARACTER*4 IMPSW 3380C 3381 CHARACTER*4 IBUGS2 3382 CHARACTER*4 ISUBRO 3383 CHARACTER*4 IFOUND 3384 CHARACTER*4 IERROR 3385C 3386 INCLUDE 'DPCOPA.INC' 3387C 3388CCCCC CHARACTER*80 IFILE 3389 CHARACTER (LEN=MAXFNC) :: IFILE 3390 CHARACTER*12 ISTAT 3391 CHARACTER*12 IFORM 3392 CHARACTER*12 IACCES 3393 CHARACTER*12 IPROT 3394 CHARACTER*12 ICURST 3395 CHARACTER*4 IENDFI 3396 CHARACTER*4 IREWIN 3397 CHARACTER*4 ISUBN0 3398 CHARACTER*4 IERRFI 3399C 3400CCCCC CHARACTER*80 IFILE2 3401 CHARACTER (LEN=MAXFNC) :: IFILE2 3402 CHARACTER*12 ISTAT2 3403 CHARACTER*12 IFORM2 3404 CHARACTER*12 IACCE2 3405 CHARACTER*12 IPROT2 3406 CHARACTER*12 ICURS2 3407 CHARACTER*4 IERRF2 3408 CHARACTER*4 IENDF2 3409 CHARACTER*4 IREWI2 3410C 3411 CHARACTER*4 IANSI 3412CCCCC CHARACTER*80 ICANS 3413 CHARACTER*200 ICANS 3414C 3415C --------------------------------------------------------------------- 3416C 3417 DIMENSION IANSLC(*) 3418 DIMENSION IANS(*) 3419 DIMENSION IHARG(*) 3420 DIMENSION IHARG2(*) 3421 DIMENSION IARGT(*) 3422 DIMENSION IARG(*) 3423 DIMENSION ARG(*) 3424C 3425 DIMENSION IHNAME(*) 3426 DIMENSION IHNAM2(*) 3427 DIMENSION IUSE(*) 3428 DIMENSION IVALUE(*) 3429 DIMENSION VALUE(*) 3430C 3431 CHARACTER*4 IBACCO 3432 CHARACTER*4 IGRASW 3433 CHARACTER*4 IDIASW 3434C 3435 CHARACTER*4 IDMANU 3436 CHARACTER*4 IDMODE 3437 CHARACTER*4 IDMOD2 3438 CHARACTER*4 IDMOD3 3439C 3440 CHARACTER*4 IDPOWE 3441 CHARACTER*4 IDCONT 3442 CHARACTER*4 IDCOLO 3443 CHARACTER*4 IDFONT 3444C 3445 CHARACTER*4 IFLAG 3446 CHARACTER*4 ISUBN1 3447 CHARACTER*4 ISUBN2 3448 CHARACTER*4 IH 3449 CHARACTER*4 IH2 3450 CHARACTER*4 ISTEPN 3451 CHARACTER*4 IFILQ2 3452 CHARACTER*1 IBASLC 3453C 3454 DIMENSION IDMANU(*) 3455 DIMENSION IDMODE(*) 3456 DIMENSION IDMOD2(*) 3457 DIMENSION IDMOD3(*) 3458 DIMENSION IDPOWE(*) 3459 DIMENSION IDCONT(*) 3460 DIMENSION IDCOLO(*) 3461 DIMENSION IDFONT(*) 3462 DIMENSION IDNVPP(*) 3463 DIMENSION IDNHPP(*) 3464 DIMENSION IDUNIT(*) 3465 DIMENSION IDNVOF(*) 3466 DIMENSION IDNHOF(*) 3467 DIMENSION PDSCAL(*) 3468C 3469C-----COMMON---------------------------------------------------------- 3470C 3471 CHARACTER*4 IRTFMD 3472 COMMON/COMRTF/IRTFMD 3473C 3474 COMMON/HTML44/IFNTSZ 3475 INCLUDE 'DPCOST.INC' 3476 INCLUDE 'DPCOFO.INC' 3477 INCLUDE 'DPCOF2.INC' 3478 INCLUDE 'DPCOFB.INC' 3479 INCLUDE 'DPCOSB.INC' 3480C 3481C-----COMMON VARIABLES (GENERAL)-------------------------------------- 3482C 3483 INCLUDE 'DPCOP2.INC' 3484C 3485C-----START POINT----------------------------------------------------- 3486C 3487 ISUBN1='DPCA' 3488 ISUBN2='PT ' 3489 IFOUND='YES' 3490 IERROR='NO' 3491C 3492 IFILQ2=IFILQU 3493 IFILQU='ON' 3494 IH='UNKN' 3495 IH2='UNKN' 3496C 3497 KMIN=0 3498 KDEL=0 3499 KMAX=0 3500 JP3=0 3501 JP4=0 3502 JP5=0 3503 J12=0 3504 J22=0 3505 J32=0 3506 J42=0 3507 J52=0 3508 J62=0 3509 J72=0 3510 J82=0 3511 J92=0 3512 J102=0 3513 IPAR2=0 3514 IPAR3=0 3515 IPAR4=0 3516 IPAR5=0 3517 IPAR6=0 3518 IPAR7=0 3519 IPAR8=0 3520 IPAR9=0 3521 IPAR10=0 3522C 3523 P2=0.0 3524C 3525 CALL DPCONA(92,IBASLC) 3526C 3527 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')THEN 3528 WRITE(ICOUT,999) 3529 999 FORMAT(1X) 3530 CALL DPWRST('XXX','BUG ') 3531 WRITE(ICOUT,51) 3532 51 FORMAT('***** AT THE BEGINNING OF DPCAPT--') 3533 CALL DPWRST('XXX','BUG ') 3534 WRITE(ICOUT,52)ICAPSW,ICAPTY,ICAPNU,ICAPCS,IPR,IPRDEF,NUMARG 3535 52 FORMAT('ICAPSW,ICAPTY,ICAPNU,ICAPCS,IPR,IPRDEF,NUMARG = ', 3536 1 2(A4,2X),I8,2X,A12,3I8) 3537 CALL DPWRST('XXX','BUG ') 3538 WRITE(ICOUT,54)IBUGS2,IERROR,ICOM,ICOM2,IWIDTH 3539 54 FORMAT('IBUGS2,IERROR,ICOM,ICOM2,IWIDTH = ',4(A4,2X),I8) 3540 CALL DPWRST('XXX','BUG ') 3541 WRITE(ICOUT,55)(IANSLC(I),I=1,MIN(120,IWIDTH)) 3542 55 FORMAT('IANSLC(.) = ',120A1) 3543 CALL DPWRST('XXX','BUG ') 3544 IF(NUMARG.GT.0)THEN 3545 DO57I=1,NUMARG 3546 WRITE(ICOUT,58)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) 3547 58 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ', 3548 1 I8,3(2X,A4),I8,G15.7) 3549 CALL DPWRST('XXX','BUG ') 3550 57 CONTINUE 3551 ENDIF 3552 WRITE(ICOUT,62)NUMNAM,MAXNAM,NUMCHA,ICAPNU 3553 62 FORMAT('NUMNAM,MAXNAM,NUMCHA,ICAPNU = ',4I8) 3554 CALL DPWRST('XXX','BUG ') 3555 DO65I=1,NUMNAM 3556 WRITE(ICOUT,66)I,IHNAME(I),IHNAM2(I),IUSE(I), 3557 1 IVALUE(I),VALUE(I) 3558 66 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) = ', 3559 1 I8,3(2X,A4),I8,G15.7) 3560 CALL DPWRST('XXX','BUG ') 3561 65 CONTINUE 3562 WRITE(ICOUT,73)(IA(I),I=1,MIN(100,NUMCHA)) 3563 73 FORMAT('(IA(I),I=1,NUMCHA) = ',100A1) 3564 CALL DPWRST('XXX','BUG ') 3565 WRITE(ICOUT,82)ICAPNA 3566 82 FORMAT('ICAPNA = ',A80) 3567 CALL DPWRST('XXX','BUG ') 3568 WRITE(ICOUT,83)ICAPST,ICAPFO,ICAPAC,ICAPFO 3569 83 FORMAT('ICAPST,ICAPFO,ICAPAC,ICAPCO = ',3(A12,2X),A12) 3570 CALL DPWRST('XXX','BUG ') 3571 WRITE(ICOUT,85)(IANS(I),I=1,MIN(100,IWIDTH)) 3572 85 FORMAT('IANS(.) = ',100A1) 3573 CALL DPWRST('XXX','BUG ') 3574 ENDIF 3575C 3576C **************************************************** 3577C ** STEP 11-- ** 3578C ** FOR THE SPECIAL CASE WHEN THE CAPTURING ** 3579C ** OF ALPHA TEXT HAS JUST BEEN FINISHED, JUMP ** 3580C ** TO CLOSING THE FILE ** 3581C **************************************************** 3582C 3583 ISTEPN='11' 3584 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 3585 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3586C 3587 IF(ICAPCS.EQ.'CLO2 ')GOTO5000 3588C 3589C *********************************************** 3590C ** STEP 12-- ** 3591C ** FOR THE SPECIAL CASE WHEN HAVE THE ** 3592C ** END CAPTURE COMMAND, OR THE ** 3593C ** END REDIRECT COMMAND, OR THE ** 3594C ** END OF CAPTURE COMMAND, ** 3595C ** END OF REDIRECT COMMAND, ** 3596C ** JUMP IMMEDIATELY TO THE SECTION OF CODE ** 3597C ** WHICH PUTS ON AN END OF FILE AND ** 3598C ** CLOSES THE FILE/SUBFILE. ** 3599C *********************************************** 3600C 3601 ISTEPN='12' 3602 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 3603 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3604C 3605 IF(ICOM.EQ.'END ')THEN 3606 IF(NUMARG.LE.0)GOTO9000 3607 IF(IHARG(1).EQ.'CAPT')GOTO4000 3608 IF(IHARG(1).EQ.'REDI')GOTO4000 3609 IF(IHARG(1).EQ.'DIVE')GOTO4000 3610 IF(IHARG(1).EQ.'PIPE')GOTO4000 3611 IF(NUMARG.LE.1)GOTO9000 3612 IF(IHARG(1).EQ.'OF '.AND.IHARG(2).EQ.'CAPT')GOTO4000 3613 IF(IHARG(1).EQ.'OF '.AND.IHARG(2).EQ.'REDI')GOTO4000 3614 IF(IHARG(1).EQ.'OF '.AND.IHARG(2).EQ.'DIVE')GOTO4000 3615 IF(IHARG(1).EQ.'OF '.AND.IHARG(2).EQ.'PIPE')GOTO4000 3616 GOTO9000 3617 ELSEIF(ICOM.EQ.'FLUS')THEN 3618 IF(NUMARG.LE.0)GOTO1290 3619 IF(IHARG(1).EQ.'CAPT')GOTO6000 3620 ELSEIF(ICOM.EQ.'CAPT')THEN 3621 IF(NUMARG.LE.0)GOTO1290 3622 IF(IHARG(1).EQ.'FLUS')GOTO6000 3623 ENDIF 3624C 3625 1290 CONTINUE 3626C 3627C ******************************************************** 3628C ** STEP 13-- ** 3629C ** DETERMINE THE TYPE CASE-- ** 3630C ** 1) CREATE AN EXPLICIT CAPTURE FILE; ** 3631C ** 2) OMIT THE FILE NAME; ** 3632C ** NOTE--IOFILE WILL EQUAL 'YES' ONLY IN FILE CASE. ** 3633C ** IN OTHER WORDS, THIS STEP MAKES SURE ** 3634C ** THAT A FILE NAME IS EXISTENT AFTER THE ** 3635C ** CAPTURE AND REDIRECT COMMANDS. ** 3636C ******************************************************** 3637C 3638 ISTEPN='13' 3639 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 3640 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3641C 3642 IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'SUSP')GOTO2000 3643 IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'OFF ')GOTO2000 3644 IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'RESU')GOTO2000 3645 IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'ON ')GOTO2000 3646 IF(NUMARG.GE.1 .AND. IHARG(1).EQ.'SCRE')GOTO2000 3647 IF(NUMARG.GE.2 .AND. IHARG(1).EQ.'FUNC' .AND. 3648 1 IHARG(2).EQ.'BLOC')GOTO2000 3649 IF(NUMARG.GE.2 .AND. IHARG(1).EQ.'STAT' .AND. 3650 1 IHARG(2).EQ.'BLOC')GOTO2000 3651C 3652C 2015/11: CHECK IF CAPTURE SWITCH IS ALREADY ON 3653C 3654 IF(ICAPSW.EQ.'ON')THEN 3655 WRITE(ICOUT,999) 3656 CALL DPWRST('XXX','BUG ') 3657 IF(IFEEDB.EQ.'ON')THEN 3658 WRITE(ICOUT,1211) 3659 1211 FORMAT('***** WARNING IN CAPTURE--') 3660 CALL DPWRST('XXX','BUG ') 3661 WRITE(ICOUT,1212) 3662 1212 FORMAT(' THE CAPTURE SWITCH IS ALREADY ON. NOTHING ', 3663 1 'DONE.') 3664 CALL DPWRST('XXX','BUG ') 3665 ENDIF 3666 IERROR='WARN' 3667 GOTO9000 3668 ENDIF 3669C 3670 IWORD=2 3671 IF(IHARG(1).EQ.'HTML'.OR.IHARG(1).EQ.'LATE'.OR. 3672 1 IHARG(1).EQ.'RTF '.OR.IHARG(1).EQ.'SCRI')IWORD=3 3673 CALL DPFILE(IANSLC,IWIDTH,IWORD, 3674 1 IOFILE,IBUGS2,ISUBRO,IERROR) 3675C 3676C ********************************************** 3677C ** STEP 14-- ** 3678C ** IF NO FILE NAME GIVEN, ** 3679C ** THEN GENERATE AN ERROR MESSAGE. ** 3680C ********************************************** 3681C 3682 ISTEPN='14' 3683 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 3684 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3685C 3686 IF(IOFILE.NE.'YES')THEN 3687 IERROR='YES' 3688 WRITE(ICOUT,999) 3689 CALL DPWRST('XXX','BUG ') 3690 WRITE(ICOUT,1411) 3691 1411 FORMAT('***** ERROR IN CAPTURE--') 3692 CALL DPWRST('XXX','BUG ') 3693 WRITE(ICOUT,1412) 3694 1412 FORMAT(' THE DESIRED CAPTURE OPERATION CANNOT BE ', 3695 1 'PERFORMED BECAUSE') 3696 CALL DPWRST('XXX','BUG ') 3697 WRITE(ICOUT,1414) 3698 1414 FORMAT(' NO FILE NAME WAS GIVEN. ILLUSTRATIVE EXAMPLE') 3699 CALL DPWRST('XXX','BUG ') 3700 WRITE(ICOUT,1416) 3701 1416 FORMAT(' TO DEMONSTRATE THE PROPER FORM--') 3702 CALL DPWRST('XXX','BUG ') 3703 WRITE(ICOUT,1417) 3704 1417 FORMAT(' SUPPOSE THE ANALYST WISHES TO CAPTURE TEXT') 3705 CALL DPWRST('XXX','BUG ') 3706 WRITE(ICOUT,1419) 3707 1419 FORMAT(' OUTPUT TO THE FILE TEMP1. ;') 3708 CALL DPWRST('XXX','BUG ') 3709 WRITE(ICOUT,1420) 3710 1420 FORMAT(' THEN THE FOLLOWING COMMAND LINE IS ENTERED--') 3711 CALL DPWRST('XXX','BUG ') 3712 WRITE(ICOUT,1421) 3713 1421 FORMAT(' CAPTURE TEMP1.') 3714 CALL DPWRST('XXX','BUG ') 3715 GOTO9000 3716 ENDIF 3717C 3718C ************************************* 3719C ** STEP 15-- ** 3720C ** IF HAVE THE FILE INPUT CASE ** 3721C ** (WHICH WE MUST HAVE)-- ** 3722C ** COPY OVER VARIABLES ** 3723C ************************************* 3724C 3725 ISTEPN='15' 3726 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 3727 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3728C 3729 IOUNIT=ICAPNU 3730 IFILE=ICAPNA 3731 ISTAT=ICAPST 3732 IF(IFILE.EQ.ISYSNA)ISTAT=ISYSST 3733 IF(IFILE.EQ.ILOGNA)ISTAT=ILOGST 3734 IFORM=ICAPFO 3735 IACCES=ICAPAC 3736 IPROT=ICAPPR 3737C (SEE ADDITIONAL RESETTING OF IPROT BELOW 3738C IF HAVE THE SYSTEM LOGIN AND/OR THE LOCAL LOGIN CAPTURE FILES) 3739 ICURST=ICAPCS 3740C 3741 ISUBN0='CAPT' 3742 IERRFI='NO' 3743C 3744 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')THEN 3745 WRITE(ICOUT,1513)IOUNIT,ISUBN0,IERRFI 3746 1513 FORMAT('IOUNIT,ISUBN0,IERRFI = ',I8,2(2X,A4)) 3747 CALL DPWRST('XXX','BUG ') 3748 WRITE(ICOUT,1514)IFILE 3749 1514 FORMAT('IFILE = ',A80) 3750 CALL DPWRST('XXX','BUG ') 3751 WRITE(ICOUT,1515)ISTAT,IFORM,IACCES,IPROT,ICURST 3752 1515 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',4(A12,2X),A12) 3753 CALL DPWRST('XXX','BUG ') 3754 ENDIF 3755C 3756C *********************************************** 3757C ** STEP 16-- ** 3758C ** IF HAVE THE FILE CASE (WHICH WE MUST ** 3759C ** HAVE)--CHECK TO SEE IF THE CAPTURE FILE ** 3760C ** MAY EXIST ** 3761C *********************************************** 3762C 3763 ISTEPN='16' 3764 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 3765 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3766C 3767 IF(ISTAT.EQ.'NONE')THEN 3768 IERROR='YES' 3769 WRITE(ICOUT,999) 3770 CALL DPWRST('XXX','BUG ') 3771 WRITE(ICOUT,1411) 3772 CALL DPWRST('XXX','BUG ') 3773 WRITE(ICOUT,1412) 3774 CALL DPWRST('XXX','BUG ') 3775 WRITE(ICOUT,1614) 3776 1614 FORMAT(' THE INTERNAL VARIABLE ICAPST WHICH ALLOWS') 3777 CALL DPWRST('XXX','BUG ') 3778 WRITE(ICOUT,1616) 3779 1616 FORMAT(' SUCH CAPTURE OPERATIONS HAS BEEN SET TO NONE.') 3780 CALL DPWRST('XXX','BUG ') 3781 WRITE(ICOUT,1617)ISTAT,ICAPST 3782 1617 FORMAT('ISTAT,ICAPST = ',A12,2X,A12) 3783 CALL DPWRST('XXX','BUG ') 3784 WRITE(ICOUT,1618) 3785 1618 FORMAT(' PLEASE CONTACT YOUR DATAPLOT IMPLEMENTOR') 3786 CALL DPWRST('XXX','BUG ') 3787 WRITE(ICOUT,1619) 3788 1619 FORMAT(' TO CORRECT THE SETTING IN SUBROUTINE INITFO.') 3789 CALL DPWRST('XXX','BUG ') 3790 GOTO9000 3791 ENDIF 3792C 3793C ******************************** 3794C ** STEP 17-- ** 3795C ** EXTRACT THE FILE NAME. ** 3796C ** THIS IS NEEDED FOR MOST ** 3797C ** (BUT NOT ALL) VARIATIONS ** 3798C ** OF THE CAPTURE COMMAND. ** 3799C ******************************** 3800C 3801 ISTEPN='17' 3802 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 3803 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3804C 3805CCCCC JUNE 2002. CHECK TO SEE IF FIRST ARGUMENT IS: 3806CCCCC HTML 3807CCCCC LATEX 3808CCCCC RTF (FEBRUARY 2005) 3809CCCCC SCRIPT (APRIL 2012) 3810C 3811 NSTRT=1 3812C 3813 IF(IHARG(1).EQ.'HTML')THEN 3814 ICAPTY='HTML' 3815 WRITE(ICOUT,999) 3816 CALL DPWRST('XXX','BUG ') 3817 WRITE(ICOUT,1771) 3818 1771 FORMAT('THE CAPTURE OUTPUT WILL BE WRITTEN IN HTML FORMAT.') 3819 CALL DPWRST('XXX','BUG ') 3820 ELSEIF(IHARG(1).EQ.'LATE')THEN 3821 ICAPTY='LATE' 3822 WRITE(ICOUT,999) 3823 CALL DPWRST('XXX','BUG ') 3824 WRITE(ICOUT,1791) 3825 1791 FORMAT('THE CAPTURE OUTPUT WILL BE WRITTEN IN LATEX FORMAT.') 3826 CALL DPWRST('XXX','BUG ') 3827 ELSEIF(IHARG(1).EQ.'RTF ')THEN 3828 ICAPTY='RTF ' 3829 WRITE(ICOUT,999) 3830 CALL DPWRST('XXX','BUG ') 3831 WRITE(ICOUT,1793) 3832 1793 FORMAT('THE CAPTURE OUTPUT WILL BE WRITTEN IN ', 3833 1 'RTF (RICH TEXT FORMAT) FORMAT.') 3834 CALL DPWRST('XXX','BUG ') 3835 ELSEIF(IHARG(1).EQ.'SCRI')THEN 3836 ICAPTY='SCRI' 3837 WRITE(ICOUT,999) 3838 CALL DPWRST('XXX','BUG ') 3839 WRITE(ICOUT,1795) 3840 1795 FORMAT('SCRIPT MODE TURNED ON FOR CAPTURE. ALL ENTERED ', 3841 1 'COMMANDS WILL BE ECHOED, BUT') 3842 CALL DPWRST('XXX','BUG ') 3843 WRITE(ICOUT,1797) 3844 1797 FORMAT('NOT EXECUTED, TO THE CAPTURE FILE UNTIL AN ', 3845 1 'END OF CAPTURE COMMAND IS ENTERED.') 3846 CALL DPWRST('XXX','BUG ') 3847 ENDIF 3848C 3849 DO1710I=1,200 3850 IANSI=IANSLC(I) 3851 ICANS(I:I)=IANSI(1:1) 3852 1710 CONTINUE 3853C 3854 ISTART=1 3855 ISTOP=IWIDTH 3856 IWORD=2 3857 IF(ICAPTY.EQ.'HTML')IWORD=3 3858 IF(ICAPTY.EQ.'LATE')IWORD=3 3859 IF(ICAPTY.EQ.'RTF ')IWORD=3 3860 IF(ICAPTY.EQ.'SCRI')IWORD=3 3861 CALL DPEXWO(ICANS,ISTART,ISTOP,IWORD, 3862 1 ICOL1,ICOL2,IFILE,NCFILE, 3863 1 IBUGS2,ISUBRO,IERROR) 3864 IF(IERROR.EQ.'YES')GOTO9000 3865C 3866 IF(NCFILE.LT.1)THEN 3867 IERROR='YES' 3868 WRITE(ICOUT,999) 3869 CALL DPWRST('XXX','BUG ') 3870 WRITE(ICOUT,1411) 3871 CALL DPWRST('XXX','BUG ') 3872 WRITE(ICOUT,1742) 3873 1742 FORMAT(' A USER FILE NAME IS REQUIRED IN THE ', 3874 1 'CAPTURE/REDIRECT COMMANDS') 3875 CALL DPWRST('XXX','BUG ') 3876 WRITE(ICOUT,1744) 3877 1744 FORMAT(' (FOR EXAMPLE, CAPTURE TEMP1.)') 3878 CALL DPWRST('XXX','BUG ') 3879 WRITE(ICOUT,1745) 3880 1745 FORMAT(' BUT NONE WAS GIVEN HERE.') 3881 CALL DPWRST('XXX','BUG ') 3882 WRITE(ICOUT,1746) 3883 1746 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') 3884 CALL DPWRST('XXX','BUG ') 3885 IF(IWIDTH.GE.1)THEN 3886 WRITE(ICOUT,1747)(IANSLC(I),I=1,MIN(IWIDTH,100)) 3887 1747 FORMAT(' ',100A1) 3888 CALL DPWRST('XXX','BUG ') 3889 ELSE 3890 WRITE(ICOUT,999) 3891 CALL DPWRST('XXX','BUG ') 3892 ENDIF 3893 GOTO9000 3894 ENDIF 3895C 3896 IF(IERROR.EQ.'YES')GOTO9000 3897 IF(IFILE.EQ.ISYSNA)IPROT=ISYSPR 3898 IF(IFILE.EQ.ILOGNA)IPROT=ILOGPR 3899C 3900C ******************************************* 3901C ** STEP 20-- ** 3902C ** CHECK THE DESIRED CAPTURE OPERATION ** 3903C ** (ON, OFF, OR EXECUTE). ** 3904C ******************************************* 3905C 3906 2000 CONTINUE 3907C 3908 ISTEPN='20' 3909 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 3910 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3911C 3912 IF(ICOM.EQ.'CAPT' .OR. ICOM.EQ.'REDI' .OR. ICOM.EQ.'DIVE' .OR. 3913 1 ICOM.EQ.'PIPE')THEN 3914 IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'SUSP')GOTO3800 3915 IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'OFF ')GOTO3800 3916 IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'RESU')GOTO3900 3917 IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'ON ')GOTO3900 3918C 3919C 2015/08: FUNCTION BLOCK CASE 3920C 3921 IF(NUMARG.GE.2 .AND. IHARG(1).EQ.'FUNC' .AND. 3922 1 IHARG(2).EQ.'BLOC')THEN 3923 ICAPTY='FUNB' 3924 IF(IHARG(3).EQ.'1' .OR. IHARG(3).EQ.'ONE')THEN 3925 IFBLSW='1' 3926 ELSEIF(IHARG(3).EQ.'2' .OR. IHARG(3).EQ.'TWO')THEN 3927 IFBLSW='2' 3928 ELSEIF(IHARG(3).EQ.'3' .OR. IHARG(3).EQ.'THREE')THEN 3929 IFBLSW='3' 3930 ELSE 3931 IFBLSW='OFF' 3932 IERROR='YES' 3933 WRITE(ICOUT,2116) 3934 2116 FORMAT('FOR CAPTURE FUNCTION BLOCK COMMAND, THE NEXT') 3935 CALL DPWRST('XXX','BUG ') 3936 WRITE(ICOUT,2117) 3937 2117 FORMAT('ARGUMENT MUST BE ONE OF: ONE (OR 1), TWO (OR 2),', 3938 1 ' OR THREE (OR 3).') 3939 CALL DPWRST('XXX','BUG ') 3940 WRITE(ICOUT,2118)IHARG(4) 3941 2118 FORMAT('THE ENTERED ARGUMENT WAS: ',A4) 3942 CALL DPWRST('XXX','BUG ') 3943 GOTO9000 3944 ENDIF 3945C 3946C NOW PARSE THE ARGUMENTS 3947C 3948C FIRST, RETRIEVE THE NAME OF THE FUNCTION BLOCK. 3949C 3950 IF(NUMARG.GE.4)THEN 3951 IF(IFBLSW.EQ.'1')THEN 3952 IFBNA1(1:4)=IHARG(4) 3953 IFBNA1(5:8)=IHARG2(4) 3954 ELSEIF(IFBLSW.EQ.'2')THEN 3955 IFBNA2(1:4)=IHARG(4) 3956 IFBNA2(5:8)=IHARG2(4) 3957 ELSEIF(IFBLSW.EQ.'3')THEN 3958 IFBNA3(1:4)=IHARG(4) 3959 IFBNA3(5:8)=IHARG2(4) 3960 ENDIF 3961 ELSE 3962 IERROR='YES' 3963 IFBLSW='OFF' 3964 WRITE(ICOUT,22116) 396522116 FORMAT('FOR THE CAPTURE FUNCTION BLOCK COMMAND, NO ', 3966 1 'NAME WAS SPECIFIED.') 3967 CALL DPWRST('XXX','BUG ') 3968 GOTO9000 3969 ENDIF 3970C 3971C NEXT, RETRIEVE THE NAME OF THE PARAMETER/VARIABLE THAT WILL 3972C CONTAIN THE RESPONSE (I.E., THE CALLING ROUTINE WILL EXTRACT 3973C THE VALUE OF THIS PARAMETER/VARIABLE AFTER EXECUTING THE 3974C FUNCTION BLOCK). 3975C 3976 IF(NUMARG.GE.5)THEN 3977 IF(IFBLSW.EQ.'1')THEN 3978 IFBAN1(1:4)=IHARG(5) 3979 IFBAN1(5:8)=IHARG2(5) 3980 ELSEIF(IFBLSW.EQ.'2')THEN 3981 IFBAN2(1:4)=IHARG(5) 3982 IFBAN2(5:8)=IHARG2(5) 3983 ELSEIF(IFBLSW.EQ.'3')THEN 3984 IFBAN3(1:4)=IHARG(5) 3985 IFBAN3(5:8)=IHARG2(5) 3986 ENDIF 3987 ELSE 3988 IERROR='YES' 3989 IFBLSW='OFF' 3990 WRITE(ICOUT,23126) 399123126 FORMAT('FOR THE CAPTURE FUNCTION BLOCK COMMAND, NO ', 3992 1 'RESPONSE PARAMETER/VARIABLE WAS SPECIFIED.') 3993 CALL DPWRST('XXX','BUG ') 3994 GOTO9000 3995 ENDIF 3996C 3997C THE REMAINING ARGUMENTS ARE THE PARAMETERS NEEDED BY THE 3998C FUNCTION BLOCK, 3999C 4000 IF(NUMARG.GE.6)THEN 4001 ICNT=0 4002 DO2150II=6,NUMARG 4003 ICNT=ICNT+1 4004 IF(ICNT.LE.20)THEN 4005 IF(IFBLSW.EQ.'1')THEN 4006 IFBPL1(ICNT)(1:4)=IHARG(II) 4007 IFBPL1(ICNT)(5:8)=IHARG2(II) 4008 IF(II.EQ.NUMARG)IFBCP1=ICNT 4009 ELSEIF(IFBLSW.EQ.'2')THEN 4010 IFBPL2(ICNT)(1:4)=IHARG(II) 4011 IFBPL2(ICNT)(5:8)=IHARG2(II) 4012 IF(II.EQ.NUMARG)IFBCP2=ICNT 4013 ELSEIF(IFBLSW.EQ.'3')THEN 4014 IFBPL3(ICNT)(1:4)=IHARG(II) 4015 IFBPL3(ICNT)(5:8)=IHARG2(II) 4016 IF(II.EQ.NUMARG)IFBCP3=ICNT 4017 ENDIF 4018 ENDIF 4019 2150 CONTINUE 4020 IFBCP1=MIN(ICNT,MAXFBP) 4021 IFBCP2=MIN(ICNT,MAXFBP) 4022 IFBCP3=MIN(ICNT,MAXFBP) 4023 ELSE 4024 IERROR='YES' 4025 IFBLSW='OFF' 4026 WRITE(ICOUT,22136) 402722136 FORMAT('FOR THE CAPTURE FUNCTION BLOCK COMMAND, NO ', 4028 1 'PARAMETER LIST WAS SPECIFIED.') 4029 CALL DPWRST('XXX','BUG ') 4030 GOTO9000 4031 ENDIF 4032C 4033 GOTO9000 4034C 4035C 2016/08: STATISTIC BLOCK CASE 4036C 4037 ELSEIF(NUMARG.GE.2 .AND. IHARG(1).EQ.'STAT' .AND. 4038 1 IHARG(2).EQ.'BLOC')THEN 4039 ICAPTY='STAB' 4040 IF(IHARG(3).EQ.'1' .OR. IHARG(3).EQ.'ONE')THEN 4041 ISBLSW='1' 4042 ELSEIF(IHARG(3).EQ.'2' .OR. IHARG(3).EQ.'TWO')THEN 4043 ISBLSW='2' 4044 ELSEIF(IHARG(3).EQ.'3' .OR. IHARG(3).EQ.'THREE')THEN 4045 ISBLSW='3' 4046 ELSE 4047 ISBLSW='OFF' 4048 IERROR='YES' 4049 WRITE(ICOUT,2126) 4050 2126 FORMAT('FOR CAPTURE STATISTIC BLOCK COMMAND, THE NEXT') 4051 CALL DPWRST('XXX','BUG ') 4052 WRITE(ICOUT,2127) 4053 2127 FORMAT('ARGUMENT MUST BE ONE OF: ONE (OR 1), TWO (OR 2),', 4054 1 ' OR THREE (OR 3).') 4055 CALL DPWRST('XXX','BUG ') 4056 WRITE(ICOUT,2128)IHARG(4) 4057 2128 FORMAT('THE ENTERED ARGUMENT WAS: ',A4) 4058 CALL DPWRST('XXX','BUG ') 4059 GOTO9000 4060 ENDIF 4061C 4062C NOW PARSE THE ARGUMENTS 4063C 4064C FIRST, RETRIEVE THE NAME OF THE STATISTIC BLOCK. 4065C 4066 IF(NUMARG.GE.4)THEN 4067 IF(ISBLSW.EQ.'1')THEN 4068 ISBNA1(1:4)=IHARG(4) 4069 ISBNA1(5:8)=IHARG2(4) 4070 ELSEIF(ISBLSW.EQ.'2')THEN 4071 ISBNA2(1:4)=IHARG(4) 4072 ISBNA2(5:8)=IHARG2(4) 4073 ELSEIF(ISBLSW.EQ.'3')THEN 4074 ISBNA3(1:4)=IHARG(4) 4075 ISBNA3(5:8)=IHARG2(4) 4076 ENDIF 4077 ELSE 4078 IERROR='YES' 4079 ISBLSW='OFF' 4080 WRITE(ICOUT,22126) 408122126 FORMAT('FOR THE CAPTURE STATISTIC BLOCK COMMAND, NO ', 4082 1 'NAME WAS SPECIFIED.') 4083 CALL DPWRST('XXX','BUG ') 4084 GOTO9000 4085 ENDIF 4086C 4087C NEXT, RETRIEVE THE NAME OF THE PARAMETER THAT WILL 4088C CONTAIN THE RESPONSE (I.E., THE CALLING ROUTINE WILL EXTRACT 4089C THE VALUE OF THIS PARAMETER AFTER EXECUTING THE 4090C STATISTIC BLOCK). 4091C 4092 IF(NUMARG.GE.5)THEN 4093 IF(ISBLSW.EQ.'1')THEN 4094 ISBAN1(1:4)=IHARG(5) 4095 ISBAN1(5:8)=IHARG2(5) 4096 ELSEIF(ISBLSW.EQ.'2')THEN 4097 ISBAN2(1:4)=IHARG(5) 4098 ISBAN2(5:8)=IHARG2(5) 4099 ELSEIF(ISBLSW.EQ.'3')THEN 4100 ISBAN3(1:4)=IHARG(5) 4101 ISBAN3(5:8)=IHARG2(5) 4102 ENDIF 4103 ELSE 4104 IERROR='YES' 4105 ISBLSW='OFF' 4106 WRITE(ICOUT,22127) 410722127 FORMAT('FOR THE CAPTURE STATISTIC BLOCK COMMAND, NO ', 4108 1 'RESPONSE PARAMETER WAS SPECIFIED.') 4109 CALL DPWRST('XXX','BUG ') 4110 GOTO9000 4111 ENDIF 4112C 4113C THE REMAINING ARGUMENTS ARE THE PARAMETERS NEEDED BY THE 4114C STATISTIC BLOCK, 4115C 4116 IF(NUMARG.GE.6)THEN 4117 ICNT=0 4118 DO2180II=6,NUMARG 4119 ICNT=ICNT+1 4120 IF(ICNT.LE.20)THEN 4121 IF(ISBLSW.EQ.'1')THEN 4122 ISBPL1(ICNT)(1:4)=IHARG(II) 4123 ISBPL1(ICNT)(5:8)=IHARG2(II) 4124 ISBCP1=ICNT 4125 ELSEIF(ISBLSW.EQ.'2')THEN 4126 ISBPL2(ICNT)(1:4)=IHARG(II) 4127 ISBPL2(ICNT)(5:8)=IHARG2(II) 4128 ISBCP2=ICNT 4129 ELSEIF(ISBLSW.EQ.'3')THEN 4130 ISBPL3(ICNT)(1:4)=IHARG(II) 4131 ISBPL3(ICNT)(5:8)=IHARG2(II) 4132 ISBCP3=ICNT 4133 ENDIF 4134 ENDIF 4135 2180 CONTINUE 4136 ISBCP1=MIN(ICNT,MAXSBP) 4137 ISBCP2=MIN(ICNT,MAXSBP) 4138 ISBCP3=MIN(ICNT,MAXSBP) 4139 ELSE 4140 IERROR='YES' 4141 ISBLSW='OFF' 4142 WRITE(ICOUT,22236) 414322236 FORMAT('FOR THE CAPTURE STATISTIC BLOCK COMMAND, NO ', 4144 1 'PARAMETER LIST WAS SPECIFIED.') 4145 CALL DPWRST('XXX','BUG ') 4146 GOTO9000 4147 ENDIF 4148C 4149 GOTO9000 4150 ENDIF 4151C 4152 IF(NUMARG.GE.1 .AND. IHARG(1).EQ.'SCRE')THEN 4153 ICAPSC='ON' 4154 IF(NUMARG.GE.2 .AND. 4155 1 (IHARG(2).EQ.'OFF ' .OR. IHARG(2).EQ.'END ' .OR. 4156 1 IHARG(2).EQ.'NO ' .OR. IHARG(2).EQ.'NONE' .OR. 4157 1 IHARG(2).EQ.'CLOS'))ICAPSC='OFF ' 4158 WRITE(ICOUT,999) 4159 CALL DPWRST('XXX','BUG ') 4160 IF(IFEEDB.EQ.'ON')THEN 4161 IF(ICAPSC.EQ.'ON')THEN 4162 WRITE(ICOUT,2111) 4163 2111 FORMAT('CAPTURE OUTPUT WILL BE WRITTEN TO BOTH THE ', 4164 1 'CAPTURE FILE AND THE SCREEN.') 4165 ELSE 4166 WRITE(ICOUT,2113) 4167 2113 FORMAT('CAPTURE OUTPUT WILL BE WRITTEN TO THE ', 4168 1 'CAPTURE FILE ONLY.') 4169 ENDIF 4170 CALL DPWRST('XXX','BUG ') 4171 ENDIF 4172 GOTO9000 4173 ENDIF 4174 GOTO3000 4175 ELSEIF(ICOM.EQ.'END '.AND.ICOM2.EQ.' ')THEN 4176 IF(NUMARG.GE.1 .AND. 4177 1 (IHARG(1).EQ.'CAPT' .OR. IHARG(1).EQ.'REDI' .OR. 4178 1 IHARG(1).EQ.'DIVE' .OR. IHARG(1).EQ.'PIPE'))GOTO4000 4179 IF(NUMARG.GE.1 .AND. IHARG(1).EQ.'OF ' .AND. 4180 1 (IHARG(1).EQ.'CAPT' .OR. IHARG(1).EQ.'REDI' .OR. 4181 1 IHARG(1).EQ.'DIVE' .OR. IHARG(1).EQ.'PIPE'))GOTO4000 4182 ENDIF 4183C 4184 IERROR='YES' 4185 WRITE(ICOUT,999) 4186 CALL DPWRST('XXX','BUG ') 4187 WRITE(ICOUT,1411) 4188 CALL DPWRST('XXX','BUG ') 4189 WRITE(ICOUT,1412) 4190 CALL DPWRST('XXX','BUG ') 4191 WRITE(ICOUT,2914) 4192 2914 FORMAT(' SPECIFIED OPERATION WAS ILLEGAL. ILLUSTRATIVE') 4193 CALL DPWRST('XXX','BUG ') 4194 WRITE(ICOUT,2915) 4195 2915 FORMAT(' EXAMPLE TO DEMONSTRATE THE PROPER FORMS--') 4196 CALL DPWRST('XXX','BUG ') 4197 WRITE(ICOUT,2917) 4198 2917 FORMAT(' CAPTURE TEMP1.') 4199 CALL DPWRST('XXX','BUG ') 4200 WRITE(ICOUT,2918) 4201 2918 FORMAT(' END OF CAPTURE') 4202 CALL DPWRST('XXX','BUG ') 4203 GOTO9000 4204C 4205C ******************************************************** 4206C ** STEP 30-- ** 4207C ** TREAT THE CAPTURE CASE. ** 4208C ** CARRY OUT WHATEVER SYSTEM OPERATIONS ARE NEEDED ** 4209C ** IN ORDER TO OPERATE ON THE FILE OR SUBFILE. ** 4210C ** FOR MOST INSTALLATIONS, THIS REQUIRES ** 4211C ** 1) AN OPENING OF THE FILE OR SUBFILE; ** 4212C ** 2) AN EQUIVALENCING OF THE FILE OR SUBFILE; ** 4213C ** 3) A REWINDING OF THE FILE OR SUBFILE. ** 4214C ** THE CODE BELOW OPENS THE FILE OR SUBFILE ** 4215C ** (VIA @ASG,AX ON THE UNIVAC 1108). THE CODE ALSO ** 4216C ** EQUIVALENCES THE FILES OR SUBFILES (VIA @USE O ** 4217C ** UNIVAC 1108) TO THE FORTRAN LOGICAL UNIT NUMBER ** 4218C ** DESIGNATION IN THE VARIABLE ICAPNU (IN THE ** 4219C ** SUBROUINTE INITFO); THE CODE ALSO REWINDS THE ** 4220C ** FILE OR SUBFILE. (VIA @REWIND ON THE UNIVAC 1108).** 4221C ******************************************************** 4222C 4223 3000 CONTINUE 4224 ISTEPN='30' 4225 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 4226 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4227C 4228 ICAPSW='ON' 4229 IOUNIT=ICAPNU 4230C 4231 ICAPNA=IFILE 4232C 4233 IREWIN='ON' 4234 CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 4235 1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 4236 IF(IERRFI.EQ.'YES')GOTO9000 4237 ICAPCS=ICURST 4238C 4239C 2015/12: IF "SET CAPTURE SPLIT ON" IS GIVEN, OPEN A SECONDARY 4240C CAPTURE FILE WITH "_1" APPENDED TO FILE NAME (BEFORE THE 4241C "."). 4242C 4243 IF(ICAPSP.EQ.'ON')THEN 4244 ICAPCN=1 4245 ICAPN2=' ' 4246 ICAPN2(1:80)=ICAPNA(1:80) 4247 ILAST=80 4248 IPEROD=-1 4249 DO3001JJ=80,1,-1 4250 IF(ICAPN2(JJ:JJ).NE.' ')THEN 4251 ILAST=JJ 4252 GOTO3002 4253 ENDIF 4254 3001 CONTINUE 4255 3002 CONTINUE 4256C 4257 DO3006JJ=80,1,-1 4258 IF(ICAPN2(JJ:JJ).EQ.'.')THEN 4259 IPEROD=JJ 4260 GOTO3007 4261 ENDIF 4262 3006 CONTINUE 4263 3007 CONTINUE 4264C 4265 IF(IPEROD.LE.0)THEN 4266 ILAST=ILAST+1 4267 ICAPN2(ILAST:ILAST+1)='.1' 4268 ELSE 4269 DO3008JJ=ILAST,IPEROD,-1 4270 ICAPN2(JJ+2:JJ+2)=ICAPN2(JJ:JJ) 4271 3008 CONTINUE 4272 ICAPN2(IPEROD:IPEROD+1)='_1' 4273 ENDIF 4274 IREWIN='ON' 4275 OPEN(ICPNU2,FILE=ICAPN2,STATUS="UNKNOWN",ACTION="WRITE") 4276 IF(IERRFI.EQ.'YES')GOTO9000 4277 ENDIF 4278C 4279 IF(IFEEDB.EQ.'ON')THEN 4280 IF(ICAPTY.EQ.'RTF ')IRTFMD='OFF' 4281 WRITE(ICOUT,999) 4282 CALL DPWRST('XXX','BUG ') 4283 WRITE(ICOUT,3011) 4284 3011 FORMAT('THE CAPTURE SWITCH HAS JUST BEEN TURNED ON.') 4285 CALL DPWRST('XXX','BUG ') 4286 WRITE(ICOUT,3012)ICAPNA 4287 3012 FORMAT('NAME OF CAPTURE FILE = ',A80) 4288 CALL DPWRST('XXX','BUG ') 4289 WRITE(ICOUT,3013) 4290 3013 FORMAT('ALL SUBSEQUENT TEXT OUTPUT FROM ANY DATAPLOT') 4291 CALL DPWRST('XXX','BUG ') 4292 WRITE(ICOUT,3014) 4293 3014 FORMAT('COMMAND WILL BE CAPTURED/REDIRECTED INTO THIS FILE.') 4294 CALL DPWRST('XXX','BUG ') 4295 WRITE(ICOUT,3015) 4296 3015 FORMAT('ONLY TEXT OUTPUT IS CAPTURED--NOT GRAPHICS OUTPUT.') 4297 CALL DPWRST('XXX','BUG ') 4298 WRITE(ICOUT,3016) 4299 3016 FORMAT('THE CAPTURED INFO WILL OVERWRITE THE PREVIOUS') 4300 CALL DPWRST('XXX','BUG ') 4301 WRITE(ICOUT,3017) 4302 3017 FORMAT('CONTENTS OF THE SPECIFIED FILE.') 4303 CALL DPWRST('XXX','BUG ') 4304 WRITE(ICOUT,3018) 4305 3018 FORMAT('THE TEXT CAPTURING WILL CONTINUE UNTIL YOU ENTER') 4306 CALL DPWRST('XXX','BUG ') 4307 WRITE(ICOUT,3019) 4308 3019 FORMAT('THE COMMAND END OF CAPTURE') 4309 CALL DPWRST('XXX','BUG ') 4310 IF(ICAPTY.EQ.'RTF ')IRTFMD='VERB' 4311 ENDIF 4312C 4313 IPR=ICAPNU 4314C 4315CCCCC JUNE 2002. SPECIAL CASE OF GRAPHICS, LATEK, HTML, RTF OR SCRIPT. 4316CCCCC ADD ANY SPECIAL NEEDED INITIALIZATION CODE HERE. 4317C 4318CCCCC JANUARY 2003. SET HTML HEADER FILE CAN BE USED TO SPECIFY A 4319CCCCC A FILE TO INCORPORATE THE HEADER FILE. 4320C 4321CCCCC DECEMBER 2015. ADD OPTION "NONE" THAT SPECIFIES THAT NO HEADER 4322CCCCC IS GENERATED. THIS IS SLIGHTLY DISTINCT FROM "NULL" WHICH 4323CCCCC GENERATES A MINIMAL HEADER. THE "NONE" OPTION IS INTENDED FOR 4324CCCCC THE CASE WHERE YOU WANT TO INCORPORATE THE HTML CODE INTO A 4325CCCCC LARGER DISTINCT DOCUMENT. 4326C 4327 IF(ICAPTY.EQ.'HTML')THEN 4328 IFNTSZ=0 4329 IF(IHTMHE.EQ.'NONE')THEN 4330 CONTINUE 4331 ELSEIF(IHTMHE.EQ.'NULL')THEN 4332 WRITE(ICOUT,3071) 4333 3071 FORMAT('<HTML>') 4334 CALL DPWRST('XXX','WRIT') 4335 WRITE(ICOUT,3073) 4336 3073 FORMAT('<HEAD>') 4337 CALL DPWRST('XXX','WRIT') 4338 WRITE(ICOUT,3075) 4339 3075 FORMAT('<TITLE>') 4340 CALL DPWRST('XXX','WRIT') 4341 WRITE(ICOUT,3077) 4342 3077 FORMAT('Dataplot Output') 4343 CALL DPWRST('XXX','WRIT') 4344 WRITE(ICOUT,3079) 4345 3079 FORMAT('</TITLE>') 4346 CALL DPWRST('XXX','WRIT') 4347 WRITE(ICOUT,3081) 4348 3081 FORMAT('<META HTTP-EQUIV="Content-Type" CONTENT="text/html;', 4349 1 ' charset=iso-8859-1">') 4350 CALL DPWRST('XXX','WRIT') 4351 WRITE(ICOUT,3083) 4352 3083 FORMAT('</HEAD>') 4353 CALL DPWRST('XXX','WRIT') 4354 WRITE(ICOUT,3085) 4355 3085 FORMAT('<BODY BGCOLOR=#FFFFFF>') 4356 CALL DPWRST('XXX','WRIT') 4357 ELSE 4358 IOUNI2=IST1NU 4359 IFILE2=IHTMHE 4360 ISTAT2='OLD' 4361 IFORM2='FORMATTED' 4362 IACCE2='SEQUENTIAL' 4363 IPROT2='READONLY' 4364 ICURS2='CLOSED' 4365 ISUBN0='CAPT' 4366 IERRF2='NO' 4367C 4368 IREWI2='ON' 4369 CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 4370 1 IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR) 4371 IF(IERRF2.EQ.'YES')GOTO9000 4372C 4373C NOW LOOP THROUGH FILE (ASSUME MAXIMUM OF 1,000 LINES). 4374C 4375 DO3091I=1,1000 4376 IATEMP=' ' 4377 READ(IOUNI2,3092,END=3099,ERR=3099)IATEMP 4378 3092 FORMAT(A240) 4379 ILAST=1 4380 DO3096J=240,1,-1 4381 IF(IATEMP(J:J).NE.' ')THEN 4382 ILAST=J 4383 GOTO3098 4384 ENDIF 4385 3096 CONTINUE 4386 3098 CONTINUE 4387 WRITE(ICOUT,3094)(IATEMP(J:J),J=1,ILAST) 4388 NCOUT=ILAST 4389 3094 FORMAT(240A1) 4390 CALL DPWRST('XXX','WRIT') 4391 3091 CONTINUE 4392 3099 CONTINUE 4393 IENDF2='OFF' 4394 IREWI2='ON' 4395 CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 4396 1 IENDF2,IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR) 4397 IF(IERRF2.EQ.'YES')GOTO9000 4398 ENDIF 4399 WRITE(ICOUT,3087) 4400 3087 FORMAT('<PRE>') 4401 CALL DPWRST('XXX','WRIT') 4402 ELSEIF(ICAPTY.EQ.'LATE')THEN 4403C 4404CCCCC DECEMBER 2015. ADD OPTION "NONE" THAT SPECIFIES THAT NO HEADER 4405CCCCC IS GENERATED. THIS IS SLIGHTLY DISTINCT FROM "NULL" WHICH 4406CCCCC GENERATES A MINIMAL HEADER. THE "NONE" OPTION IS INTENDED FOR 4407CCCCC THE CASE WHERE YOU WANT TO INCORPORATE THE LATEX CODE INTO A 4408CCCCC LARGER DISTINCT DOCUMENT. 4409C 4410 IF(ILATHE.EQ.'NONE')THEN 4411 CONTINUE 4412 ELSEIF(ILATHE.EQ.'NULL')THEN 4413 IF(ILATPS.EQ.12)THEN 4414 WRITE(ICOUT,3171)IBASLC 4415 3171 FORMAT(A1,'documentclass[12pt]{article}') 4416 CALL DPWRST('XXX','WRIT') 4417 ELSE 4418 IF(ILATPS.GE.10)THEN 4419 WRITE(ICOUT,3172)IBASLC,ILATPS 4420 3172 FORMAT(A1,'documentclass[',I2,'pt]{article}') 4421 CALL DPWRST('XXX','WRIT') 4422 ELSE 4423 WRITE(ICOUT,33172)IBASLC,ILATPS 442433172 FORMAT(A1,'documentclass[',I1,'pt]{article}') 4425 CALL DPWRST('XXX','WRIT') 4426 ENDIF 4427 ENDIF 4428 WRITE(ICOUT,999) 4429 CALL DPWRST('XXX','WRIT') 4430 WRITE(ICOUT,3173)IBASLC 4431 3173 FORMAT(A1,'usepackage{epsfig}') 4432 CALL DPWRST('XXX','WRIT') 4433 WRITE(ICOUT,3174)IBASLC 4434 3174 FORMAT(A1,'usepackage{epic,eepic}') 4435 CALL DPWRST('XXX','WRIT') 4436 WRITE(ICOUT,3175)IBASLC 4437 3175 FORMAT(A1,'usepackage{graphics,color}') 4438 CALL DPWRST('XXX','WRIT') 4439 WRITE(ICOUT,999) 4440 CALL DPWRST('XXX','WRIT') 4441 WRITE(ICOUT,13171)IBASLC,IBASLC 444213171 FORMAT(A1,'setlength{',A1,'textwidth}{6.25in}') 4443 CALL DPWRST('XXX','WRIT') 4444 WRITE(ICOUT,13172)IBASLC,IBASLC 444513172 FORMAT(A1,'setlength{',A1,'textheight}{9in}') 4446 CALL DPWRST('XXX','WRIT') 4447 WRITE(ICOUT,13173)IBASLC,IBASLC 444813173 FORMAT(A1,'setlength{',A1,'oddsidemargin}{0.25in}') 4449 CALL DPWRST('XXX','WRIT') 4450 WRITE(ICOUT,13174)IBASLC,IBASLC 445113174 FORMAT(A1,'setlength{',A1,'evensidemargin}{0in}') 4452 CALL DPWRST('XXX','WRIT') 4453 WRITE(ICOUT,13175)IBASLC,IBASLC 445413175 FORMAT(A1,'setlength{',A1,'headheight}{0.5in}') 4455 CALL DPWRST('XXX','WRIT') 4456 WRITE(ICOUT,13176)IBASLC,IBASLC 445713176 FORMAT(A1,'setlength{',A1,'headsep}{0.5in}') 4458 CALL DPWRST('XXX','WRIT') 4459 WRITE(ICOUT,13177)IBASLC,IBASLC 446013177 FORMAT(A1,'setlength{',A1,'topmargin}{-1in}') 4461 CALL DPWRST('XXX','WRIT') 4462 WRITE(ICOUT,13178)IBASLC,IBASLC 446313178 FORMAT(A1,'setlength{',A1,'parindent}{0in}') 4464 CALL DPWRST('XXX','WRIT') 4465 WRITE(ICOUT,13179)IBASLC,IBASLC 446613179 FORMAT(A1,'setlength{',A1,'parskip}{10pt}') 4467 CALL DPWRST('XXX','WRIT') 4468 WRITE(ICOUT,13180)IBASLC,IBASLC 446913180 FORMAT(A1,'setlength{',A1,'textfloatsep}{4ex}') 4470 CALL DPWRST('XXX','WRIT') 4471 WRITE(ICOUT,13181)IBASLC,IBASLC 447213181 FORMAT(A1,'addtolength{',A1,'footskip}{0.25in}') 4473 CALL DPWRST('XXX','WRIT') 4474 WRITE(ICOUT,13182)IBASLC 447513182 FORMAT(A1,'overfullrule=0pt') 4476 CALL DPWRST('XXX','WRIT') 4477 WRITE(ICOUT,13183)IBASLC 447813183 FORMAT(A1,'baselineskip=12pt') 4479 CALL DPWRST('XXX','WRIT') 4480 WRITE(ICOUT,999) 4481 CALL DPWRST('XXX','WRIT') 4482 WRITE(ICOUT,3181)IBASLC,IBASLC,IBASLC 4483 3181 FORMAT(A1,'newcommand{',A1,'PGRAPHIC}[1]{',A1,'begin{figure}', 4484 1 '[h]') 4485 CALL DPWRST('XXX','WRIT') 4486 WRITE(ICOUT,3182)IBASLC 4487 3182 FORMAT(23X,A1,'epsfig{file=#1,width=6.0in}') 4488 CALL DPWRST('XXX','WRIT') 4489 WRITE(ICOUT,3183)IBASLC 4490 3183 FORMAT(23X,A1,'end{figure}}') 4491 CALL DPWRST('XXX','WRIT') 4492 WRITE(ICOUT,3186)IBASLC,IBASLC,IBASLC 4493 3186 FORMAT(A1,'newcommand{',A1,'LGRAPHIC}[1]{',A1,'begin{figure}', 4494 1 '[h]') 4495 CALL DPWRST('XXX','WRIT') 4496 WRITE(ICOUT,3187)IBASLC 4497 3187 FORMAT(23X,A1,'epsfig{file=#1,angle=-90,width=6.0in}') 4498 CALL DPWRST('XXX','WRIT') 4499 WRITE(ICOUT,3188)IBASLC 4500 3188 FORMAT(23X,A1,'end{figure}}') 4501 CALL DPWRST('XXX','WRIT') 4502 WRITE(ICOUT,999) 4503 CALL DPWRST('XXX','WRIT') 4504 WRITE(ICOUT,3191)IBASLC 4505 3191 FORMAT(A1,'begin{document}') 4506 CALL DPWRST('XXX','WRIT') 4507 WRITE(ICOUT,999) 4508 CALL DPWRST('XXX','WRIT') 4509 WRITE(ICOUT,3197)IBASLC 4510 3197 FORMAT(A1,'begin{verbatim}') 4511 CALL DPWRST('XXX','WRIT') 4512 WRITE(ICOUT,999) 4513 CALL DPWRST('XXX','WRIT') 4514 ELSE 4515 IOUNI2=IST1NU 4516 IFILE2=ILATHE 4517 ISTAT2='OLD' 4518 IFORM2='FORMATTED' 4519 IACCE2='SEQUENTIAL' 4520 IPROT2='READONLY' 4521 ICURS2='CLOSED' 4522 ISUBN0='CAPT' 4523 IERRF2='NO' 4524C 4525 IREWI2='ON' 4526 CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 4527 1 IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR) 4528 IF(IERRF2.EQ.'YES')GOTO9000 4529C 4530C NOW LOOP THROUGH FILE (ASSUME MAXIMUM OF 1,000 LINES). 4531C 4532 DO3291I=1,1000 4533 IATEMP=' ' 4534 READ(IOUNI2,3292,END=3299,ERR=3299)IATEMP 4535 3292 FORMAT(A240) 4536 ILAST=1 4537 DO3296J=240,1,-1 4538 IF(IATEMP(J:J).NE.' ')THEN 4539 ILAST=J 4540 GOTO3298 4541 ENDIF 4542 3296 CONTINUE 4543 3298 CONTINUE 4544 WRITE(ICOUT,3294)(IATEMP(J:J),J=1,ILAST) 4545 NCOUT=ILAST 4546 3294 FORMAT(240A1) 4547 CALL DPWRST('WRIT','BUG ') 4548 3291 CONTINUE 4549 3299 CONTINUE 4550 IENDF2='OFF' 4551 IREWI2='ON' 4552 CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 4553 1 IENDF2,IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR) 4554 IF(IERRF2.EQ.'YES')GOTO9000 4555 WRITE(ICOUT,3197)IBASLC 4556 CALL DPWRST('XXX','WRIT') 4557 ENDIF 4558 ELSEIF(ICAPTY.EQ.'RTF ')THEN 4559 IRTFMD='OFF' 4560CCCCC IF(IRTFHE.EQ.'NULL')THEN 4561 WRITE(ICOUT,3351)IBASLC,IBASLC,IBASLC 4562 3351 FORMAT('{',A1,'rtf1',A1,'ansi',A1,'deff0') 4563 CALL DPWRST('XXX','WRIT') 4564 WRITE(ICOUT,3361)IBASLC 4565 3361 FORMAT('{',A1,'fonttbl') 4566 CALL DPWRST('XXX','WRIT') 4567 WRITE(ICOUT,3363)IBASLC,IBASLC 4568 3363 FORMAT('{',A1,'f0',A1,'froman Times New Roman;}') 4569 CALL DPWRST('XXX','WRIT') 4570 WRITE(ICOUT,3367)IBASLC,IBASLC 4571 3367 FORMAT('{',A1,'f1',A1,'fmodern Courier New;}') 4572 CALL DPWRST('XXX','WRIT') 4573 WRITE(ICOUT,3369)IBASLC,IBASLC 4574 3369 FORMAT('{',A1,'f2',A1,'froman Arial;}') 4575 CALL DPWRST('XXX','WRIT') 4576 WRITE(ICOUT,3371)IBASLC,IBASLC 4577 3371 FORMAT('{',A1,'f3',A1,'froman Bookman;}') 4578 CALL DPWRST('XXX','WRIT') 4579 WRITE(ICOUT,3373)IBASLC,IBASLC 4580 3373 FORMAT('{',A1,'f4',A1,'froman Georgia;}') 4581 CALL DPWRST('XXX','WRIT') 4582 WRITE(ICOUT,3375)IBASLC,IBASLC 4583 3375 FORMAT('{',A1,'f5',A1,'fswiss Tahoma;}') 4584 CALL DPWRST('XXX','WRIT') 4585 WRITE(ICOUT,3376)IBASLC,IBASLC 4586 3376 FORMAT('{',A1,'f6',A1,'fswiss Lucida Sans;}') 4587 CALL DPWRST('XXX','WRIT') 4588 WRITE(ICOUT,3377)IBASLC,IBASLC 4589 3377 FORMAT('{',A1,'f7',A1,'fswiss Verdana;}') 4590 CALL DPWRST('XXX','WRIT') 4591 WRITE(ICOUT,3378)IBASLC,IBASLC 4592 3378 FORMAT('{',A1,'f8',A1,'fmodern Lucida Console;}') 4593 CALL DPWRST('XXX','WRIT') 4594 WRITE(ICOUT,3379) 4595 3379 FORMAT('}') 4596 CALL DPWRST('XXX','WRIT') 4597C 4598 WRITE(ICOUT,3384)IBASLC 4599 3384 FORMAT('{',A1,'info') 4600 CALL DPWRST('XXX','WRIT') 4601 WRITE(ICOUT,3385)IBASLC 4602 3385 FORMAT('{',A1,'title Dataplot RTF Document}') 4603 CALL DPWRST('XXX','WRIT') 4604 WRITE(ICOUT,3386)IBASLC 4605 3386 FORMAT('{',A1,'author Alan Heckert}') 4606 CALL DPWRST('XXX','WRIT') 4607 WRITE(ICOUT,3387)IBASLC 4608 3387 FORMAT('{',A1,'company Statistical Engineering Division, ', 4609 1 'NIST}') 4610 CALL DPWRST('XXX','WRIT') 4611 WRITE(ICOUT,3379) 4612 CALL DPWRST('XXX','WRIT') 4613C 4614CCCCC IPTSZ=2*IRTFPS 4615 IPTSZ=IRTFPS 4616 IF(IPTSZ.LT.0 .OR. IPTSZ.GT.99)IPTSZ=20 4617 ITEMP='0' 4618 IF(IRTFFP.EQ.'Arial')ITEMP='2' 4619 IF(IRTFFP.EQ.'Bookman')ITEMP='3' 4620 IF(IRTFFP.EQ.'Georgia')ITEMP='4' 4621 IF(IRTFFP.EQ.'Tahoma')ITEMP='5' 4622 IF(IRTFFP.EQ.'Lucida Sans')ITEMP='6' 4623 IF(IRTFFP.EQ.'Verdana')ITEMP='7' 4624 IF(IPTSZ.LE.9)THEN 4625 WRITE(ICOUT,3381)IBASLC,IBASLC,IBASLC,IBASLC,ITEMP, 4626 1 IBASLC,IPTSZ 4627 3381 FORMAT(A1,'delang1033',A1,'widowctrl',A1,'plain', 4628 1 A1,'f',A1,A1,'fs',I1) 4629 ELSE 4630 WRITE(ICOUT,3382)IBASLC,IBASLC,IBASLC,IBASLC,ITEMP, 4631 1 IBASLC,IPTSZ 4632 3382 FORMAT(A1,'delang1033',A1,'widowctrl',A1,'plain', 4633 1 A1,'f',A1,A1,'fs',I2) 4634 ENDIF 4635 CALL DPWRST('XXX','WRIT') 4636C 4637 WRITE(ICOUT,3389)IBASLC 4638 3389 FORMAT('{',A1,'pard') 4639 CALL DPWRST('XXX','WRIT') 4640 IRTFMD='VERB' 4641CCCCC ELSE 4642CCCCC ENDIF 4643 ELSEIF(ICAPTY.EQ.'SCRI')THEN 4644 CONTINUE 4645 ENDIF 4646C 4647 GOTO9000 4648C 4649C ****************************************************** 4650C ** STEP 38-- ** 4651C ** TREAT THE CAPTURE SUSPEND CASE. ** 4652C ** RESET OUTPUT UNIT TO IPR, BUT DO NOT CLOSE ** 4653C ** THE CAPTURE FILE. ** 4654C ****************************************************** 4655C 4656 3800 CONTINUE 4657 ISTEPN='38' 4658 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 4659 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4660C 4661 IF(ICAPSW.EQ.'OFF')THEN 4662 WRITE(ICOUT,999) 4663 CALL DPWRST('XXX','BUG ') 4664 WRITE(ICOUT,3811) 4665 3811 FORMAT('****** WARNING: THE CAPTURE SWITCH IS CURRENTLY OFF.') 4666 CALL DPWRST('XXX','BUG ') 4667 WRITE(ICOUT,3813) 4668 3813 FORMAT(' CAPTURE SUSPEND COMMAND IGNORED.') 4669 CALL DPWRST('XXX','BUG ') 4670 GOTO9000 4671 ENDIF 4672C 4673 ICAPSW='OFF' 4674 IOUNIT=ICAPNU 4675 IPR=IPRDEF 4676C 4677 GOTO9000 4678C 4679C ****************************************************** 4680C ** STEP 39-- ** 4681C ** TREAT THE CAPTURE RESUME CASE. ** 4682C ** RESET OUTPUT UNIT TO CAPTURE UNIT, BUT DO NOT ** 4683C ** REOPEN THE CAPTURE FILE. ** 4684C ****************************************************** 4685C 4686 3900 CONTINUE 4687 ISTEPN='39' 4688 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 4689 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4690C 4691 IF(ICAPSW.EQ.'ON')THEN 4692 WRITE(ICOUT,999) 4693 CALL DPWRST('XXX','BUG ') 4694 WRITE(ICOUT,3911) 4695 3911 FORMAT('****** WARNING: THE CAPTURE SWITCH IS CURRENTLY ON.') 4696 CALL DPWRST('XXX','BUG ') 4697 WRITE(ICOUT,3913) 4698 3913 FORMAT(' CAPTURE RESUME COMMAND IGNORED.') 4699 CALL DPWRST('XXX','BUG ') 4700 GOTO9000 4701 ENDIF 4702C 4703 ICAPSW='ON' 4704 IPR=ICAPNU 4705C 4706 GOTO9000 4707C 4708C ********************************************************** 4709C ** STEP 40-- ** 4710C ** TREAT THE END OF CAPTURE CASE. CARRY OUT WHATEVER ** 4711C ** SYSTEM OPERATIONS ARE NEEDED IN ORDER TO OPERATE ** 4712C ** ON THE FILE OR SUBFILE. FOR MOST INSTALLATIONS, ** 4713C ** THIS REQUIRES ** 4714C ** 1) A PLACING OF AN END MARK OF THE FILE OR ** 4715C ** SUBFILE; ** 4716C ** 2) A FREEING (DEASSIGNING) OF THE FILE OR ** 4717C ** SUBFILE; ** 4718C ********************************************************** 4719C 4720 4000 CONTINUE 4721 ISTEPN='40' 4722 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 4723 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4724C 4725 ICAPSW='OFF' 4726C 4727 IF(IFBLSW.NE.'OFF')THEN 4728 ICAPTY='TEXT' 4729 IFBLSW='OFF' 4730 GOTO4090 4731 ENDIF 4732C 4733 IF(ISBLSW.NE.'OFF')THEN 4734 ICAPTY='TEXT' 4735 ISBLSW='OFF' 4736 GOTO4090 4737 ENDIF 4738C 4739CCCCC JUNE 2002. SPECIAL CASE OF GRAPHICS, LATEK, OR HTML. ADD 4740CCCCC ANY SPECIAL NEED TERMINATION CODE HERE. 4741C 4742CCCCC DECEMBER 2015. FOR HTML AND LATEX, ADD "NONE" OPTION FOR FOOTER. 4743CCCCC THIS IS DISTINCT FROM "NULL" WHICH ADDS A MINIMAL FOOTER. THE 4744CCCCC "NONE" OPTION IS INTENDED FOR THE CASE WHERE THE HTML OR LATEX 4745CCCCC CODE IS TO BE INCORPORATED INTO A LARGER HTML OR LATEX DOCUMENT. 4746C 4747 IF(ICAPTY.EQ.'HTML')THEN 4748 WRITE(ICOUT,4110) 4749 4110 FORMAT('</PRE>') 4750 CALL DPWRST('XXX','WRIT') 4751 IF(IHTMFO.EQ.'NONE')THEN 4752 CONTINUE 4753 ELSEIF(IHTMFO.EQ.'NULL')THEN 4754 WRITE(ICOUT,4112) 4755 4112 FORMAT('</BODY>') 4756 CALL DPWRST('XXX','WRIT') 4757 WRITE(ICOUT,4114) 4758 4114 FORMAT('</HTML>') 4759 CALL DPWRST('XXX','WRIT') 4760 ELSE 4761 IOUNI2=IST1NU 4762 IFILE2=IHTMFO 4763 ISTAT2='OLD' 4764 IFORM2='FORMATTED' 4765 IACCE2='SEQUENTIAL' 4766 IPROT2='READONLY' 4767 ICURS2='CLOSED' 4768 ISUBN0='CAPT' 4769 IERRF2='NO' 4770C 4771 IREWI2='ON' 4772 CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 4773 1 IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR) 4774 IF(IERRF2.EQ.'YES')GOTO9000 4775C 4776C NOW LOOP THROUGH FILE (ASSUME MAXIMUM OF 1,000 LINES). 4777C 4778 DO4121I=1,1000 4779 IATEMP=' ' 4780 READ(IOUNI2,4122,END=4129,ERR=4129)IATEMP 4781 4122 FORMAT(A240) 4782 ILAST=1 4783 DO4126J=240,1,-1 4784 IF(IATEMP(J:J).NE.' ')THEN 4785 ILAST=J 4786 GOTO4128 4787 ENDIF 4788 4126 CONTINUE 4789 4128 CONTINUE 4790 WRITE(ICOUT,4124)(IATEMP(J:J),J=1,ILAST) 4791 NCOUT=ILAST 4792 4124 FORMAT(240A1) 4793 CALL DPWRST('XXX','WRIT') 4794 4121 CONTINUE 4795 4129 CONTINUE 4796 IENDF2='OFF' 4797 IREWI2='ON' 4798 CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 4799 1 IENDF2,IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR) 4800 IF(IERRF2.EQ.'YES')GOTO9000 4801 ENDIF 4802 ELSEIF(ICAPTY.EQ.'LATE')THEN 4803 WRITE(ICOUT,999) 4804 CALL DPWRST('XXX','WRIT') 4805 WRITE(ICOUT,4208)IBASLC 4806 4208 FORMAT(A1,'end{verbatim}') 4807 CALL DPWRST('XXX','WRIT') 4808 IF(ILATFO.EQ.'NONE')THEN 4809 CONTINUE 4810 ELSEIF(ILATFO.EQ.'NULL')THEN 4811 WRITE(ICOUT,999) 4812 CALL DPWRST('XXX','WRIT') 4813 WRITE(ICOUT,4210)IBASLC 4814 4210 FORMAT(A1,'end{document}') 4815 CALL DPWRST('XXX','WRIT') 4816 ELSE 4817 IOUNI2=IST1NU 4818 IFILE2=ILATFO 4819 ISTAT2='OLD' 4820 IFORM2='FORMATTED' 4821 IACCE2='SEQUENTIAL' 4822 IPROT2='READONLY' 4823 ICURS2='CLOSED' 4824 ISUBN0='CAPT' 4825 IERRF2='NO' 4826C 4827 IREWI2='ON' 4828 CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 4829 1 IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR) 4830 IF(IERRF2.EQ.'YES')GOTO9000 4831C 4832C NOW LOOP THROUGH FILE (ASSUME MAXIMUM OF 1,000 LINES). 4833C 4834 DO4221I=1,1000 4835 IATEMP=' ' 4836 READ(IOUNI2,4222,END=4229,ERR=4229)IATEMP 4837 4222 FORMAT(A240) 4838 ILAST=1 4839 DO4226J=240,1,-1 4840 IF(IATEMP(J:J).NE.' ')THEN 4841 ILAST=J 4842 GOTO4228 4843 ENDIF 4844 4226 CONTINUE 4845 4228 CONTINUE 4846 WRITE(ICOUT,4224)(IATEMP(J:J),J=1,ILAST) 4847 NCOUT=ILAST 4848 4224 FORMAT(240A1) 4849 CALL DPWRST('XXX','WRIT') 4850 4221 CONTINUE 4851 4229 CONTINUE 4852 IENDF2='OFF' 4853 IREWI2='ON' 4854 CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 4855 1 IENDF2,IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR) 4856 IF(IERRF2.EQ.'YES')GOTO9000 4857 ENDIF 4858 ELSEIF(ICAPTY.EQ.'RTF ')THEN 4859 IRTFMD='OFF' 4860 WRITE(ICOUT,4301)IBASLC 4861 4301 FORMAT(A1,'par}') 4862 CALL DPWRST('XXX','WRIT') 4863 WRITE(ICOUT,4303) 4864 4303 FORMAT('}') 4865 CALL DPWRST('XXX','WRIT') 4866 ENDIF 4867C 4868 ICAPTY='TEXT' 4869 IOUNIT=ICAPNU 4870 IPR=IPRDEF 4871C 4872 IENDFI='ON' 4873 IREWIN='ON' 4874 CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 4875 1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 4876 IF(IERRFI.EQ.'YES')GOTO9000 4877C 4878 4090 CONTINUE 4879 IF(IFEEDB.EQ.'ON')THEN 4880 IF(ICAPTY.EQ.'RTF ')IRTFMD='OFF' 4881 WRITE(ICOUT,999) 4882 CALL DPWRST('XXX','BUG ') 4883 WRITE(ICOUT,4011) 4884 4011 FORMAT('THE CAPTURE SWITCH HAS JUST BEEN TURNED OFF.') 4885 CALL DPWRST('XXX','BUG ') 4886 WRITE(ICOUT,4012)ICAPNA 4887 4012 FORMAT('NAME OF (JUST-CLOSED) CAPTURE FILE = ',A80) 4888 CALL DPWRST('XXX','BUG ') 4889 WRITE(ICOUT,4013) 4890 4013 FORMAT('ALL FUTURE TEXT OUTPUT WILL NOW REVERT TO ', 4891 1 'THE SCREEN.') 4892 CALL DPWRST('XXX','BUG ') 4893 IF(ICAPTY.EQ.'RTF ')IRTFMD='VERB' 4894 ENDIF 4895 GOTO9000 4896C 4897C **************************************************************** 4898C ** STEP 50-- 4899C ** TREAT THE CAPTURE FILE CLOSE CASE. 4900C **************************************************************** 4901C 4902 5000 CONTINUE 4903 ISTEPN='50' 4904 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 4905 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4906C 4907CCCCC ICAPSW='OFF' 4908CCCCC JUNE 2002. SUPPORT FOR SPECIAL CAPTURE OPERATIONS. 4909CCCCC IF(ICAPTY.EQ.'GRAP')THEN 4910CCCCC IPR=IPRDEF 4911 IF(ICAPTY.EQ.'HTML')THEN 4912 WRITE(ICOUT,999) 4913 CALL DPWRST('XXX','WRIT') 4914 WRITE(ICOUT,5111) 4915 5111 FORMAT('</PRE>') 4916 CALL DPWRST('XXX','WRIT') 4917 WRITE(ICOUT,5113) 4918 5113 FORMAT('</BODY>') 4919 CALL DPWRST('XXX','WRIT') 4920 WRITE(ICOUT,5115) 4921 5115 FORMAT('</HTML>') 4922 CALL DPWRST('XXX','WRIT') 4923 ELSEIF(ICAPTY.EQ.'LATE')THEN 4924 WRITE(ICOUT,999) 4925 CALL DPWRST('XXX','WRIT') 4926 WRITE(ICOUT,5208)IBASLC 4927 5208 FORMAT(A1,'end{verbatim}') 4928 CALL DPWRST('XXX','WRIT') 4929 WRITE(ICOUT,999) 4930 CALL DPWRST('XXX','WRIT') 4931 WRITE(ICOUT,5210)IBASLC 4932 5210 FORMAT(A1,'end{document}') 4933 CALL DPWRST('XXX','WRIT') 4934 ELSEIF(ICAPTY.EQ.'RTF ')THEN 4935 IRTFMD='OFF' 4936 WRITE(ICOUT,5301)IBASLC 4937 5301 FORMAT(A1,'par}') 4938 CALL DPWRST('XXX','WRIT') 4939 WRITE(ICOUT,5303) 4940 5303 FORMAT('}') 4941 CALL DPWRST('XXX','WRIT') 4942 ENDIF 4943C 4944 ICAPTY='TEXT' 4945 IOUNIT=ICAPNU 4946C 4947 IENDFI='OFF' 4948C ***** DO WE NEED THE FOLLOWING REWIND ????? ***** 4949 IREWIN='ON' 4950 CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 4951 1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 4952 IF(IERRFI.EQ.'YES')GOTO9000 4953C 4954 IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'CAPT')GOTO5019 4955 WRITE(ICOUT,999) 4956 CALL DPWRST('XXX','BUG ') 4957 WRITE(ICOUT,5011)ICAPNU 4958 5011 FORMAT('THE CAPTURE FILE NUMBER ',I8,' HAS JUST BEEN CLOSED') 4959 CALL DPWRST('XXX','BUG ') 4960 WRITE(ICOUT,5012)ICAPNA 4961 5012 FORMAT('NAME OF (JUST-CLOSED) CAPTURE FILE = ',A80) 4962 CALL DPWRST('XXX','BUG ') 4963 5019 CONTINUE 4964 GOTO9000 4965C 4966C ********************************************************** 4967C ** STEP 60-- ** 4968C ** TREAT THE FLUSH CAPTURE CASE. ** 4969C ** 1) CLEAR GRAPHICS SCREEN (DPERAS) ** 4970C ** 2) CLOSE CAPTURE FILE (IF CURRENTLY OPEN) ** 4971C ** 3) OPEN THE CAPTURE FILE ** 4972C ** 4) LOOP THROUGH THE FILE AND CALL DPWRSG ** 4973C ** 5) CLOSE THE CAPTURE FILE ** 4974C ** 6) RE-OPEN THE CAPTURE FILE ** 4975C ********************************************************** 4976C 4977 6000 CONTINUE 4978 ISTEPN='40' 4979 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 4980 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4981C 4982C 4983C STEP 2: CLEAR THE GRAPHICS SCREEN 4984C (SKIP IF MULTIPLOTTING ON) 4985C 4986 IF(IMPSW.NE.'ON' .AND. ICAPFE.EQ.'ON')THEN 4987 CALL DPERAS(IHARG,IARGT,IARG,NUMARG, 4988 1 IBACCO,IGRASW,IDIASW, 4989 1 PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 4990 1 PDIAHE,PDIAWI,PDIAVG,PDIAHG, 4991 1 NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3, 4992 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 4993 1 IDNVOF,IDNHOF,IDFONT,PDSCAL, 4994 1 ICAPSW,IBUGS2,ISUBRO,IFOUND,IERROR) 4995 ENDIF 4996C 4997C STEP 2: CLOSE THE FILE 4998C 4999 IOUNIT=ICAPNU 5000 IFILE=ICAPNA 5001 ISTAT=ICAPST 5002 IFORM=ICAPFO 5003 IACCES=ICAPAC 5004 IPROT=ICAPPR 5005 ICURST=ICAPCS 5006 ICURST=ICAPCS 5007 IF(ICAPCS.EQ.'CLOSED')GOTO6090 5008 IENDFI='ON' 5009 IREWIN='ON' 5010 CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 5011 1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 5012 IF(IERRFI.EQ.'YES')GOTO9000 5013C 5014 6090 CONTINUE 5015C 5016C STEP 3: RE-OPEN THE FILE 5017C 5018 IREWIN='ON' 5019 CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 5020 1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 5021 IF(IERRFI.EQ.'YES')GOTO9000 5022 ICAPCS=ICURST 5023C 5024C STEP 4: LOOP THROUGH THE FILE 5025C 5026 ILINE=0 5027 ICOUNT=1 5028 DO6110I=1,10000 5029 ICOUT=' ' 5030 READ(ICAPNU,'(A120)',END=6129,ERR=6119)ICOUT 5031 ILINE=ILINE+1 5032 IF(ILINE.GT.ICAPLI(ICOUNT).AND.IMPSW.NE.'ON')THEN 5033 CALL DPERAS(IHARG,IARGT,IARG,NUMARG, 5034 1 IBACCO,IGRASW,IDIASW, 5035 1 PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 5036 1 PDIAHE,PDIAWI,PDIAVG,PDIAHG, 5037 1 NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3, 5038 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 5039 1 IDNVOF,IDNHOF,IDFONT,PDSCAL, 5040 1 ICAPSW,IBUGS2,ISUBRO,IFOUND,IERROR) 5041 ILINE=1 5042 ICOUNT=ICOUNT+1 5043 IF(ICOUNT.GT.MAXCLI)ICOUNT=1 5044 ENDIF 5045 IF(I.EQ.1)THEN 5046 IFLAG='INIT' 5047 ELSEIF(ILINE.EQ.1)THEN 5048 IFLAG='NEW' 5049 ELSE 5050 IFLAG='OLD' 5051 ENDIF 5052 CALL DPWRSG('XXXX','BUG ',IREPCH,IMPSW,IFLAG,ICAPNM,ICAPBX, 5053 1 ILINE) 5054 6110 CONTINUE 5055 6119 CONTINUE 5056 6129 CONTINUE 5057C 5058C STEP 5: CLOSE THE FILE 5059C 5060 IENDFI='ON' 5061 IREWIN='ON' 5062 CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 5063 1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 5064 ICAPCS=ICURST 5065 IF(IERRFI.EQ.'YES')GOTO9000 5066C 5067C STEP 6: RE-OPEN THE FILE 5068C 5069 IFILE=ICAPNA 5070 IOUNIT=ICAPNU 5071 IREWIN='ON' 5072 CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 5073 1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 5074 IF(IERRFI.EQ.'YES')GOTO9000 5075 ICAPCS=ICURST 5076C 5077 GOTO9000 5078C 5079C **************** 5080C ** STEP 90-- ** 5081C ** EXIT. ** 5082C **************** 5083C 5084 9000 CONTINUE 5085C 5086 IFILQU=IFILQ2 5087C 5088 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')THEN 5089 WRITE(ICOUT,999) 5090 CALL DPWRST('XXX','BUG ') 5091 WRITE(ICOUT,9011) 5092 9011 FORMAT('***** AT THE END OF DPCAPT--') 5093 CALL DPWRST('XXX','BUG ') 5094 WRITE(ICOUT,9013)IBUGS2,IFOUND,IERROR 5095 9013 FORMAT('IBUGS2,IFOUND,IERROR = ',2(A4,2X),A4) 5096 CALL DPWRST('XXX','BUG ') 5097 WRITE(ICOUT,9015)ICOM,ICOM2,IOFILE,IWIDTH,IOUNIT 5098 9015 FORMAT('ICOM,ICOM2,IOFILE,IWIDTH,IOUNIT = ',3(A4,2X),2I8) 5099 CALL DPWRST('XXX','BUG ') 5100 WRITE(ICOUT,9017)(IANSLC(I),I=1,MIN(120,IWIDTH)) 5101 9017 FORMAT('IANSLC(.) = ',120A1) 5102 CALL DPWRST('XXX','BUG ') 5103 WRITE(ICOUT,9031)JP3,JP4,JP5,KMIN,KDEL,KMAX 5104 9031 FORMAT('JP2,JP3,JP4,KMIN,KDEL,KMAX = ',6I8) 5105 CALL DPWRST('XXX','BUG ') 5106 WRITE(ICOUT,9052)IFILE 5107 9052 FORMAT('IFILE = ',A80) 5108 CALL DPWRST('XXX','BUG ') 5109 WRITE(ICOUT,9053)ISTAT,IFORM,IACCES,IPROT,ICURST 5110 9053 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',4(A12,2X),A12) 5111 CALL DPWRST('XXX','BUG ') 5112 WRITE(ICOUT,9058)IENDFI,IREWIN,ISUBN0,IERRFI 5113 9058 FORMAT('IENDFI,IREWIN,ISUBN0,IERRFI = ',2(A4,2X),A12,2X,A12) 5114 CALL DPWRST('XXX','BUG ') 5115 ENDIF 5116C 5117 RETURN 5118 END 5119 SUBROUTINE DPCASE(ICOM,IHARG,NUMARG, 5120 1IDEFCA, 5121 1ITEXCA, 5122 1IBUGD2,ISUBRO,IFOUND,IERROR) 5123C 5124C PURPOSE--DEFINE THE CASE (UPPER OR LOWER) TYPE FOR 5125C TITLE, LABEL, AND LEGEND SCRIPT 5126C ON A PLOT. 5127C THE CASE (UPPER OR LOWER) FOR THE SCRIPT WILL BE PLACED 5128C IN THE CHARACTER VARIABLE ITEXCA. 5129C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 5130C --NUMARG 5131C --IDEFCA 5132C --IBUGD2 5133C OUTPUT ARGUMENTS--ITEXCA 5134C --IFOUND ('YES' OR 'NO' ) 5135C --IERROR ('YES' OR 'NO' ) 5136C WRITTEN BY--JAMES J. FILLIBEN 5137C STATISTICAL ENGINEERING DIVISION 5138C INFORMATION TECHNOLOGY LABORATORY 5139C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5140C GAITHERSBURG, MD 20899-8980 5141C PHONE--301-975-2899 5142C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5143C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5144C LANGUAGE--ANSI FORTRAN (1977) 5145C VERSION NUMBER--82/7 5146C ORIGINAL VERSION--APRIL 1981. 5147C UPDATED --MAY 1982. 5148C UPDATED --OCTOBER 1993. ACCEPT "ASIS" AS ARGUMENT 5149C 5150C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5151C 5152 CHARACTER*4 ICOM 5153 CHARACTER*4 IHARG 5154 CHARACTER*4 IDEFCA 5155 CHARACTER*4 ITEXCA 5156 CHARACTER*4 IBUGD2 5157 CHARACTER*4 ISUBRO 5158 CHARACTER*4 IFOUND 5159 CHARACTER*4 IERROR 5160C 5161C--------------------------------------------------------------------- 5162C 5163 DIMENSION IHARG(*) 5164C 5165C--------------------------------------------------------------------- 5166C 5167 INCLUDE 'DPCOP2.INC' 5168C 5169C-----START POINT----------------------------------------------------- 5170C 5171 IFOUND='NO' 5172 IERROR='NO' 5173C 5174 IF(IBUGD2.EQ.'OFF')GOTO90 5175 WRITE(ICOUT,999) 5176 999 FORMAT(1X) 5177 CALL DPWRST('XXX','BUG ') 5178 WRITE(ICOUT,51) 5179 51 FORMAT('***** AT THE BEGINNING OF DPCASE--') 5180 CALL DPWRST('XXX','BUG ') 5181 WRITE(ICOUT,53)ICOM,NUMARG,IDEFCA 5182 53 FORMAT('ICOM,NUMARG,IDEFCA = ',A4,2X,I8,2X,A4) 5183 CALL DPWRST('XXX','BUG ') 5184 DO55I=1,NUMARG 5185 WRITE(ICOUT,56)I,IHARG(I) 5186 56 FORMAT('I,IHARG(I) = ',I8,2X,A4) 5187 CALL DPWRST('XXX','BUG ') 5188 55 CONTINUE 5189 90 CONTINUE 5190C 5191C ************************************************ 5192C ** TREAT THE CASE (UPPER VERSUS LOWER) CASE ** 5193C ************************************************ 5194C 5195 IF(ICOM.EQ.'CASE')GOTO1120 5196 IF(ICOM.EQ.'UPPE')GOTO1130 5197 IF(ICOM.EQ.'LOWE')GOTO1140 5198CCCCC OCTOBER 1993. ADD FOLLOWING LINE 5199 IF(ICOM.EQ.'ASIS')GOTO1150 5200 GOTO9000 5201C 5202 1120 CONTINUE 5203 IF(NUMARG.LE.0)GOTO1161 5204 IF(IHARG(NUMARG).EQ.'ON')GOTO1161 5205 IF(IHARG(NUMARG).EQ.'OFF')GOTO1162 5206 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1161 5207 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165 5208 IF(IHARG(NUMARG).EQ.'UPPE')GOTO1161 5209 IF(IHARG(NUMARG).EQ.'LOWE')GOTO1162 5210CCCCC OCTOBER 1993. ADD FOLLOWING LINE 5211 IF(IHARG(NUMARG).EQ.'ASIS')GOTO1163 5212 IF(IHARG(NUMARG).EQ.'?')GOTO8100 5213 GOTO1170 5214C 5215 1130 CONTINUE 5216 IF(NUMARG.LE.0)GOTO9000 5217 IF(IHARG(1).NE.'CASE')GOTO9000 5218 IF(NUMARG.LE.1)GOTO1161 5219 IF(IHARG(NUMARG).EQ.'ON')GOTO1161 5220 IF(IHARG(NUMARG).EQ.'OFF')GOTO1162 5221 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1161 5222 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165 5223 GOTO9000 5224C 5225 1140 CONTINUE 5226 IF(NUMARG.LE.0)GOTO9000 5227 IF(IHARG(1).NE.'CASE')GOTO9000 5228 IF(NUMARG.LE.1)GOTO1162 5229 IF(IHARG(NUMARG).EQ.'ON')GOTO1162 5230 IF(IHARG(NUMARG).EQ.'OFF')GOTO1161 5231 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1162 5232 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165 5233 GOTO9000 5234CCCCC OCTOBER 1993. ADD FOLLOWING SECTION 5235C 5236 1150 CONTINUE 5237 IF(NUMARG.LE.0)GOTO9000 5238 IF(IHARG(1).NE.'CASE')GOTO9000 5239 IF(NUMARG.LE.1)GOTO1163 5240 IF(IHARG(NUMARG).EQ.'ON')GOTO1162 5241 IF(IHARG(NUMARG).EQ.'OFF')GOTO1161 5242 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1162 5243 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165 5244 GOTO9000 5245C 5246 1161 CONTINUE 5247 ITEXCA='UPPE' 5248 GOTO1180 5249C 5250 1162 CONTINUE 5251 ITEXCA='LOWE' 5252 GOTO1180 5253CCCCC OCTOBER 1993. ADD FOLLOWING SECTION 5254C 5255 1163 CONTINUE 5256 ITEXCA='ASIS' 5257 GOTO1180 5258C 5259 1165 CONTINUE 5260 ITEXCA=IDEFCA 5261 GOTO1180 5262C 5263 1170 CONTINUE 5264 IERROR='YES' 5265 WRITE(ICOUT,1171) 5266 1171 FORMAT('***** ERROR IN DPCASE--') 5267 CALL DPWRST('XXX','BUG ') 5268 WRITE(ICOUT,1172) 5269 1172 FORMAT(' ILLEGAL ENTRY FOR CASE ', 5270 1'COMMAND.') 5271 CALL DPWRST('XXX','BUG ') 5272 WRITE(ICOUT,1173) 5273 1173 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 5274 1'PROPER FORM--') 5275 CALL DPWRST('XXX','BUG ') 5276 WRITE(ICOUT,1174) 5277 1174 FORMAT(' SUPPOSE THE THE ANALYST WISHES TO HAVE CASE ') 5278 CALL DPWRST('XXX','BUG ') 5279 WRITE(ICOUT,1175) 5280 1175 FORMAT(' FOR ALL PLOT TITLES, LABELS, AND LEGENDS,') 5281 CALL DPWRST('XXX','BUG ') 5282 WRITE(ICOUT,1176) 5283 1176 FORMAT(' THEN ALLOWABLE FORMS ARE--') 5284 CALL DPWRST('XXX','BUG ') 5285 WRITE(ICOUT,1177) 5286 1177 FORMAT(' CASE UPPER') 5287 CALL DPWRST('XXX','BUG ') 5288 WRITE(ICOUT,1178) 5289 1178 FORMAT(' UPPER CASE') 5290 CALL DPWRST('XXX','BUG ') 5291 WRITE(ICOUT,1179) 5292 1179 FORMAT(' CASE') 5293 CALL DPWRST('XXX','BUG ') 5294 GOTO9000 5295C 5296 1180 CONTINUE 5297 IFOUND='YES' 5298C 5299 IF(IFEEDB.EQ.'OFF')GOTO1189 5300 WRITE(ICOUT,999) 5301 CALL DPWRST('XXX','BUG ') 5302 WRITE(ICOUT,1181) 5303 1181 FORMAT('THE CASE (FOR PLOT SCRIPT AND TEXT) ') 5304 CALL DPWRST('XXX','BUG ') 5305 WRITE(ICOUT,1182)ITEXCA 5306 1182 FORMAT('HAS JUST BEEN SET TO ',A4) 5307 CALL DPWRST('XXX','BUG ') 5308 1189 CONTINUE 5309 GOTO9000 5310C 5311C ******************************************** 5312C ** STEP 81-- ** 5313C ** TREAT THE ? CASE-- ** 5314C ** DUMP OUT CURRENT AND DEFAULT VALUES. ** 5315C ******************************************** 5316C 5317 8100 CONTINUE 5318 IFOUND='YES' 5319 WRITE(ICOUT,999) 5320 CALL DPWRST('XXX','BUG ') 5321 WRITE(ICOUT,8111)ITEXCA 5322 8111 FORMAT('THE CURRENT CASE IS ',A4) 5323 CALL DPWRST('XXX','BUG ') 5324 WRITE(ICOUT,8112)IDEFCA 5325 8112 FORMAT('THE DEFAULT CASE IS ',A4) 5326 CALL DPWRST('XXX','BUG ') 5327 GOTO9000 5328C 5329C ***************** 5330C ** STEP 90-- ** 5331C ** EXIT ** 5332C ***************** 5333C 5334 9000 CONTINUE 5335 IF(IBUGD2.EQ.'OFF')GOTO9090 5336 WRITE(ICOUT,999) 5337 CALL DPWRST('XXX','BUG ') 5338 WRITE(ICOUT,9011) 5339 9011 FORMAT('***** AT THE END OF DPCASE--') 5340 CALL DPWRST('XXX','BUG ') 5341 WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR 5342 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 5343 CALL DPWRST('XXX','BUG ') 5344 WRITE(ICOUT,9013)ITEXCA,IDEFCA 5345 9013 FORMAT('ITEXCA,IDEFCA = ',A4,2X,A4) 5346 CALL DPWRST('XXX','BUG ') 5347 9090 CONTINUE 5348C 5349 RETURN 5350 END 5351 SUBROUTINE DPCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 5352 1 ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 5353C 5354C PURPOSE--GENERATE ONE OF THE FOLLOWING 12 CONTROL CHARTS-- 5355C 1) MEAN 5356C 2) RANGE 5357C 3) STANDARD DEVIATION 5358C 4) CUSUM 5359C 5) P 5360C 6) PN 5361C 7) C 5362C 8) U 5363C 9) EWMA (EXPONENTIALLY WEIGHTED MOVING AVERAGE) 5364C 10) MOVING AVERAGE 5365C 11) MOVING RANGE 5366C 12) MOVING STANDARD DEVIATION 5367C 13) ISO 13528 5368C 14) ISO 13528 CUSUM 5369C WRITTEN BY--JAMES J. FILLIBEN 5370C STATISTICAL ENGINEERING DIVISION 5371C INFORMATION TECHNOLOGY LABORATORY 5372C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5373C GAITHERSBURG, MD 20899-8980 5374C PHONE--301-975-2899 5375C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5376C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5377C LANGUAGE--ANSI FORTRAN (1977) 5378C VERSION NUMBER--82/7 5379C ORIGINAL VERSION--JUNE 1978. 5380C UPDATED --JULY 1978. 5381C UPDATED --AUGUST 1981. 5382C UPDATED --MAY 1982. 5383C UPDATED --JANUARY 1988. (P, PN, C, AND U CHARTS) 5384C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON 5385C UPDATED --JULY 1990. ADD R CHART CHECK 5386C UPDATED --JULY 1990. FIX P, NP, C, & U CHARTS 5387C UPDATED --SEPTEMBER 1990. LSL, USL, TARGET 5388C UPDATED --AUGUST 1991. TURN OFF MESS.--LSL/USL/TARGET 5389C UPDATED --MARCH 1997. EWMA, ACTIVATE CUSUM 5390C UPDATED --MARCH 1997. MOVING AVERAGE 5391C UPDATED --MARCH 1997. MOVING RANGE 5392C UPDATED --MARCH 1997. MOVING STANDARD DEVIATION 5393C UPDATED --SEPTEMBER 1998. ACTIVATED CUSUM MEAN CHART 5394C UPDATED --AUGUST 2010. USE DPPARS 5395C UPDATED --JANUARY 2012. SUPPORT HIGHLIGHTED OPTION 5396C UPDATED --JANUARY 2012. "MAXSET" OPTION 5397C UPDATED --FEBRUARY 2012. ISO 13528 5398C UPDATED --FEBRUARY 2012. ISO 13528 CUSUM 5399C UPDATED --FEBRUARY 2018. CONFLICT WITH 5400C "MEAN CHARACTER PLOT" 5401C 5402C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5403C 5404 CHARACTER*4 ICASPL 5405 CHARACTER*4 ICASP2 5406 CHARACTER*4 IAND1 5407 CHARACTER*4 IAND2 5408 CHARACTER*4 ICONT 5409 CHARACTER*4 IBUGG2 5410 CHARACTER*4 IBUGG3 5411 CHARACTER*4 IBUGQ 5412 CHARACTER*4 ISUBRO 5413 CHARACTER*4 IFOUND 5414 CHARACTER*4 IERROR 5415C 5416 CHARACTER*4 IHWUSE 5417 CHARACTER*4 MESSAG 5418 CHARACTER*4 IH 5419 CHARACTER*4 IH2 5420 CHARACTER*4 IERRO2 5421 CHARACTER*4 ISUBN1 5422 CHARACTER*4 ISUBN2 5423 CHARACTER*4 ISTEPN 5424 CHARACTER*4 CARG0 5425 CHARACTER*4 CARG1 5426 CHARACTER*4 CARG2 5427 CHARACTER*4 CARG3 5428 CHARACTER*4 CARG4 5429 CHARACTER*4 CARG11 5430C 5431 CHARACTER*4 IHIGH 5432 CHARACTER*4 IFOUN1 5433 CHARACTER*4 IFOUN2 5434 CHARACTER*40 INAME 5435 PARAMETER (MAXSPN=10) 5436 CHARACTER*4 IVARN1(MAXSPN) 5437 CHARACTER*4 IVARN2(MAXSPN) 5438 CHARACTER*4 IVARTY(MAXSPN) 5439 REAL PVAR(MAXSPN) 5440 INTEGER ILIS(MAXSPN) 5441 INTEGER NRIGHT(MAXSPN) 5442 INTEGER ICOLR(MAXSPN) 5443C 5444C--------------------------------------------------------------------- 5445C 5446 INCLUDE 'DPCOPA.INC' 5447 INCLUDE 'DPCOZZ.INC' 5448C 5449 DIMENSION Y1(MAXOBV) 5450 DIMENSION Y2(MAXOBV) 5451 DIMENSION X1(MAXOBV) 5452 DIMENSION XIDTEM(MAXOBV) 5453 DIMENSION TEMP(MAXOBV) 5454 DIMENSION TEMP2(MAXOBV) 5455 DIMENSION XHIGH(MAXOBV) 5456 DIMENSION YPREV(MAXOBV) 5457C 5458 EQUIVALENCE (GARBAG(IGARB1),X1(1)) 5459 EQUIVALENCE (GARBAG(IGARB2),Y1(1)) 5460 EQUIVALENCE (GARBAG(IGARB3),Y2(1)) 5461 EQUIVALENCE (GARBAG(IGARB4),XIDTEM(1)) 5462 EQUIVALENCE (GARBAG(IGARB5),TEMP(1)) 5463 EQUIVALENCE (GARBAG(IGARB6),TEMP2(1)) 5464 EQUIVALENCE (GARBAG(IGARB7),XHIGH(1)) 5465 EQUIVALENCE (GARBAG(IGARB8),YPREV(1)) 5466C 5467C-----COMMON---------------------------------------------------------- 5468C 5469CCCCC ADD FOLLOWING LINE APRIL 1997 5470 INCLUDE 'DPCOST.INC' 5471 INCLUDE 'DPCOHK.INC' 5472 INCLUDE 'DPCODA.INC' 5473C 5474C-----COMMON VARIABLES (GENERAL)-------------------------------------- 5475C 5476 INCLUDE 'DPCOP2.INC' 5477C 5478C-----START POINT----------------------------------------------------- 5479C 5480 IERROR='NO' 5481 IFOUND='NO' 5482C 5483 ISUBN1='DPCC' 5484 ISUBN2=' ' 5485C 5486 MAXCP1=MAXCOL+1 5487 MAXCP2=MAXCOL+2 5488 MAXCP3=MAXCOL+3 5489 MAXCP4=MAXCOL+4 5490 MAXCP5=MAXCOL+5 5491 MAXCP6=MAXCOL+6 5492C 5493 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'DPCC')THEN 5494 WRITE(ICOUT,999) 5495 999 FORMAT(1X) 5496 CALL DPWRST('XXX','BUG ') 5497 WRITE(ICOUT,51) 5498 51 FORMAT('***** AT THE BEGINNING OF DPCC--') 5499 CALL DPWRST('XXX','BUG ') 5500 WRITE(ICOUT,52)ICASPL,IAND1,IAND2 5501 52 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) 5502 CALL DPWRST('XXX','BUG ') 5503 WRITE(ICOUT,53)ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO 5504 53 FORMAT('ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',4(A4,2X),A4) 5505 CALL DPWRST('XXX','BUG ') 5506 ENDIF 5507C 5508C *************************** 5509C ** STEP 1-- ** 5510C ** EXTRACT THE COMMAND ** 5511C *************************** 5512C 5513C ************************************************* 5514C ** TREAT THE CONTROL CHART CASE: ** 5515C ** 1) MEAN CONTROL CHART ** 5516C ** 2) SD CONTROL CHART ** 5517C ** 3) RANGE CONTROL CHART ** 5518C ** 4) CUSUM CONTROL CHART ** 5519C ** 5) P CONTROL CHART ** 5520C ** 6) PN CONTROL CHART ** 5521C ** 7) C CONTROL CHART ** 5522C ** 8) U CONTROL CHART ** 5523C ** 9) EWMA CONTROL CHART ** 5524C ** 10) MOVING AVERAGE CONTROL CHART ** 5525C ** 11) MOVING RANGE CONTROL CHART ** 5526C ** 12) MOVING SD CONTROL CHART ** 5527C ** 13) ISO 13528 CONTROL CHART ** 5528C ** 14) ISO 13528 CUSUM CONTROL CHART ** 5529C ************************************************* 5530C 5531 ISTEPN='1' 5532 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCC') 5533 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5534C 5535C CHECK FOR NAME CONFLICTS 5536C 5537 IF(ICOM.EQ.'FLUC')GOTO9000 5538 IF(ICOM.EQ.'TABU')GOTO9000 5539 IF(ICOM.EQ.'JACK')GOTO9000 5540 IF(ICOM.EQ.'BOOT')GOTO9000 5541 IF(ICOM.EQ.'DEX ')GOTO9000 5542 IF(ICOM.EQ.'DEXP')GOTO9000 5543 IF(ICOM.EQ.'DOE ')GOTO9000 5544 IF(ICOM.EQ.'DOX ')GOTO9000 5545 IF(ICOM.EQ.'CROS' .AND. IHARG(1).EQ.'TABU')GOTO9000 5546C 5547 IHIGH='OFF' 5548 IFOUN1='OFF' 5549 IFOUN2='OFF' 5550 IF(ICOM.EQ.'HIGH' .OR. ICOM.EQ.'SUBS')IHIGH='ON' 5551 ILASTC=-9999 5552C 5553 ISTOP=NUMARG-1 5554 DO90I=1,NUMARG 5555 IF(IHARG(I).EQ.'PLOT' .OR. IHARG(I).EQ.'CHAR')THEN 5556 IF(IHARG2(I).EQ.'ACTE')GOTO9000 5557 ISTOP=I 5558 GOTO99 5559 ENDIF 5560 90 CONTINUE 5561 99 CONTINUE 5562C 5563 ICASP2='NONE' 5564 DO100I=0,ISTOP 5565C 5566 IF(I.EQ.0)THEN 5567 CARG0=' ' 5568 CARG1=ICOM 5569 CARG2=IHARG(I+1) 5570 CARG3=IHARG(I+2) 5571 CARG4=IHARG(I+3) 5572 ELSE 5573 IF(I.EQ.1)THEN 5574 CARG0=ICOM 5575 ELSE 5576 CARG0=IHARG(I-1) 5577 ENDIF 5578 CARG1=IHARG(I) 5579 CARG11=IHARG2(I) 5580 CARG2=IHARG(I+1) 5581 CARG3=IHARG(I+2) 5582 CARG4=IHARG(I+3) 5583 ENDIF 5584C 5585 IF(IHARG(I).EQ.'=')THEN 5586 IFOUND='NO' 5587 GOTO9000 5588 ELSEIF((CARG1.EQ.'X ' .OR. CARG1.EQ.'XBAR' .OR. 5589 1 CARG1.EQ.'MEAN' .OR. CARG1.EQ.'AVER') .AND. 5590 1 CARG2.NE.'CUSU' .AND. CARG2.NE.'CUMU' .AND. 5591 1 CARG0.NE.'MOVI')THEN 5592 IFOUN1='YES' 5593 ICASPL='MECC' 5594 ELSEIF((CARG1.EQ.'SD ' .OR. CARG1.EQ.'S ') .AND. 5595 1 CARG2.NE.'CUSU' .AND. CARG2.NE.'CUMU' .AND. 5596 1 CARG0.NE.'MOVI')THEN 5597 IFOUN1='YES' 5598 ICASPL='SDCC' 5599 ELSEIF(CARG1.EQ.'STAN' .AND. CARG2.EQ.'DEVI' .AND. 5600 1 CARG3.NE.'CUSU' .AND. CARG3.NE.'CUMU' .AND. 5601 1 CARG0.NE.'MOVI')THEN 5602 IFOUN1='YES' 5603 ICASPL='SDCC' 5604 ELSEIF((CARG1.EQ.'RANG' .OR. CARG1.EQ.'R ') .AND. 5605 1 CARG2.NE.'CUSU' .AND. CARG2.NE.'CUMU' .AND. 5606 1 CARG0.NE.'MOVI')THEN 5607 IFOUN1='YES' 5608 ICASPL='RACC' 5609 ELSEIF((CARG1.EQ.'MEAN' .OR. CARG1.EQ.'AVER' .OR. 5610 1 CARG1.EQ.'X ') .AND. 5611 1 (CARG2.EQ.'CUSU' .OR. 5612 1 (CARG2.EQ.'CUMU' .AND. CARG3.EQ.'SUM ')))THEN 5613 IFOUN1='YES' 5614 ICASPL='CUCC' 5615 ICASP2='MEAN' 5616 ELSEIF((CARG1.EQ.'SD ' .OR. CARG1.EQ.'S ') .AND. 5617 1 (CARG2.EQ.'CUSU' .OR. 5618 1 (CARG2.EQ.'CUMU' .AND. CARG3.EQ.'SUM ')))THEN 5619 IFOUN1='YES' 5620 ICASPL='CUCC' 5621 ICASP2='SD ' 5622 ELSEIF(CARG1.EQ.'STAN' .AND. CARG2.EQ.'DEVI' .AND. 5623 1 (CARG3.EQ.'CUSU' .OR. 5624 1 (CARG3.EQ.'CUMU' .AND. CARG4.EQ.'SUM ')))THEN 5625 IFOUN1='YES' 5626 ICASPL='CUCC' 5627 ICASP2='SD ' 5628 ELSEIF((CARG1.EQ.'RANG' .OR. CARG1.EQ.'R ') .AND. 5629 1 (CARG2.EQ.'CUSU' .OR. 5630 1 (CARG2.EQ.'CUMU' .AND. CARG3.EQ.'SUM ')))THEN 5631 IFOUN1='YES' 5632 ICASPL='CUCC' 5633 ICASP2='RANG' 5634 ELSEIF(CARG1.EQ.'CUSU' .AND. ICASPL.NE.'1CUS')THEN 5635 IFOUN1='YES' 5636 ICASPL='CUCC' 5637 ELSEIF(CARG1.EQ.'CUMU' .AND. CARG2.EQ.'SUM ')THEN 5638 IFOUN1='YES' 5639 ICASPL='CUCC' 5640 ELSEIF(CARG1.EQ.'P ')THEN 5641 IFOUN1='YES' 5642 ICASPL='PCC' 5643 ELSEIF(CARG1.EQ.'PN ' .OR. CARG1.EQ.'NP ')THEN 5644 IFOUN1='YES' 5645 ICASPL='PNCC' 5646 ELSEIF(CARG1.EQ.'C ')THEN 5647 IFOUN1='YES' 5648 ICASPL='CCC' 5649 ELSEIF(CARG1.EQ.'U ')THEN 5650 IFOUN1='YES' 5651 ICASPL='UCC' 5652 ELSEIF(CARG1.EQ.'EXPO' .AND. CARG2.EQ.'WEIG' .AND. 5653 1 CARG3.EQ.'MOVI' .AND. CARG4.EQ.'AVER')THEN 5654 IFOUN1='YES' 5655 ICASPL='EWCC' 5656 ELSEIF(CARG1.EQ.'EWMA')THEN 5657 IFOUN1='YES' 5658 ICASPL='EWCC' 5659 ELSEIF(CARG1.EQ.'EXPO' .AND. CARG2.EQ.'MOVI' .AND. 5660 1 CARG3.EQ.'AVER')THEN 5661 IFOUN1='YES' 5662 ICASPL='EWCC' 5663 ELSEIF(CARG1.EQ.'EXPO' .AND. CARG2.EQ.'WEIG' .AND. 5664 1 CARG3.EQ.'MOVI')THEN 5665 IFOUN1='YES' 5666 ICASPL='EWCC' 5667 ELSEIF(CARG1.EQ.'EXPO' .AND. CARG2.EQ.'WEIG')THEN 5668 IFOUN1='YES' 5669 ICASPL='EWCC' 5670 ELSEIF(CARG1.EQ.'MOVI' .AND. 5671 1 (CARG2.EQ.'AVER' .OR. CARG2.EQ.'MEAN') .AND. 5672 1 CARG0.NE.'EXPO' .AND. CARG0.NE.'WEIG')THEN 5673 IFOUN1='YES' 5674 ICASPL='MACC' 5675 ELSEIF(CARG1.EQ.'MOVI' .AND. CARG2.EQ.'RANG')THEN 5676 IFOUN1='YES' 5677 ICASPL='MRCC' 5678 ELSEIF(CARG1.EQ.'MOVI' .AND. 5679 1 (CARG2.EQ.'SD ' .OR. CARG2.EQ.'MSD' .OR. 5680 1 CARG2.EQ.'S '))THEN 5681 IFOUN1='YES' 5682 ICASPL='MSCC' 5683 ELSEIF(CARG1.EQ.'MOVI' .AND. CARG2.EQ.'STAN' .AND. 5684 1 CARG3.EQ.'DEVI')THEN 5685 IFOUN1='YES' 5686 ICASPL='MSCC' 5687 ELSEIF(CARG1.EQ.'ISO ' .AND. CARG2.EQ.'1352')THEN 5688 IF(CARG3.EQ.'CUSU')THEN 5689 IFOUN1='YES' 5690 ICASPL='1CUS' 5691 ELSE 5692 IFOUN1='YES' 5693 ICASPL='1352' 5694 ENDIF 5695 ELSEIF(CARG1.EQ.'CONT' .AND. CARG2.EQ.'CHAR')THEN 5696 IFOUN2='YES' 5697 ILASTC=MAX(ILASTC,I+1) 5698 ELSEIF(CARG1.EQ.'CONT' .AND. CARG2.EQ.'PLOT')THEN 5699 IFOUN2='YES' 5700 ILASTC=MAX(ILASTC,I+1) 5701 ELSEIF(CARG1.EQ.'CHAR' .AND. CARG0.NE.'CONT')THEN 5702 IF(CARG11.EQ.'ACTE')GOTO9000 5703 IFOUN2='YES' 5704 ILASTC=MAX(ILASTC,I) 5705 ENDIF 5706C 5707 100 CONTINUE 5708C 5709 IF(IFOUN1.EQ.'NO' .AND. IFOUN2.EQ.'YES')THEN 5710 ICASPL='MECC' 5711 IFOUN1='YES' 5712 ENDIF 5713 IF(IFOUN1.EQ.'YES' .AND. IFOUN2.EQ.'YES')IFOUND='YES' 5714 IF(IFOUND.EQ.'NO')GOTO9000 5715C 5716 IF(ILASTC.GE.1)THEN 5717 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 5718 ILASTC=0 5719 ENDIF 5720C 5721C 5722C **************************************** 5723C ** STEP 2-- ** 5724C ** EXTRACT THE VARIABLE LIST ** 5725C **************************************** 5726C 5727 ISTEPN='2' 5728 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCC') 5729 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5730C 5731 INAME='CONTROL CHART' 5732 IF(ICASPL.EQ.'MECC')INAME='MEAN CONTROL CHART' 5733 IF(ICASPL.EQ.'SDCC')INAME='SD CONTROL CHART' 5734 IF(ICASPL.EQ.'RACC')INAME='RANGE CONTROL CHART' 5735 IF(ICASPL.EQ.'CUCC')INAME='CUSUM CONTROL CHART' 5736 IF(ICASPL.EQ.'PCC')INAME='P CONTROL CHART' 5737 IF(ICASPL.EQ.'PNCC')INAME='NP CONTROL CHART' 5738 IF(ICASPL.EQ.'CCC')INAME='C CONTROL CHART' 5739 IF(ICASPL.EQ.'UCC')INAME='U CONTROL CHART' 5740 IF(ICASPL.EQ.'EWCC')INAME='EWMA CONTROL CHART' 5741 IF(ICASPL.EQ.'MACC')INAME='MOVING AVERAGE CONTROL CHART' 5742 IF(ICASPL.EQ.'MRCC')INAME='MOVING RANGE CONTROL CHART' 5743 IF(ICASPL.EQ.'MSCC')INAME='MOVING SD CONTROL CHART' 5744 IF(ICASPL.EQ.'1352')INAME='ISO 13528 CONTROL CHART' 5745 IF(ICASPL.EQ.'1CUS')INAME='ISO 13528 CUSUM CONTROL CHART' 5746 MINNA=1 5747 MAXNA=100 5748 MINN2=2 5749 IFLAGE=1 5750 IFLAGM=0 5751 IF(ICASPL.EQ.'MACC')IFLAGM=1 5752 IF(ICASPL.EQ.'MRCC')IFLAGM=1 5753 IF(ICASPL.EQ.'MSCC')IFLAGM=1 5754 IFLAGP=0 5755 JMIN=1 5756 JMAX=NUMARG 5757 MINNVA=1 5758 MAXNVA=3 5759 IF(IHIGH.EQ.'ON')MAXNVA=MAXNVA+1 5760C 5761 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 5762 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 5763 1 JMIN,JMAX, 5764 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 5765 1 IVARN1,IVARN2,IVARTY,PVAR, 5766 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 5767 1 MINNVA,MAXNVA, 5768 1 IFLAGM,IFLAGP, 5769 1 IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 5770 IF(IERROR.EQ.'YES')GOTO9000 5771C 5772 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCC')THEN 5773 WRITE(ICOUT,999) 5774 CALL DPWRST('XXX','BUG ') 5775 WRITE(ICOUT,281) 5776 281 FORMAT('***** AFTER CALL DPPARS--') 5777 CALL DPWRST('XXX','BUG ') 5778 WRITE(ICOUT,282)NQ,NUMVAR,IHIGH,ICASPL 5779 282 FORMAT('NQ,NUMVAR,IHIGH,ICASPL = ',2I8,2(2X,A4)) 5780 CALL DPWRST('XXX','BUG ') 5781 IF(NUMVAR.GT.0)THEN 5782 DO285I=1,NUMVAR 5783 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 5784 1 ICOLR(I),IVARTY(I) 5785 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 5786 1 'ICOLR(I),IVARTY(I) = ',I8,2X,A4,A4,2X,3I8,2X,A4) 5787 CALL DPWRST('XXX','BUG ') 5788 285 CONTINUE 5789 ENDIF 5790 ENDIF 5791C 5792 ICOL=1 5793 IF(IHIGH.EQ.'OFF')THEN 5794 CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 5795 1 INAME,IVARN1,IVARN2,IVARTY, 5796 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 5797 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 5798 1 MAXCP4,MAXCP5,MAXCP6, 5799 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 5800 1 Y1,Y2,X1,TEMP,TEMP2,TEMP2,TEMP2,NLOCAL, 5801 1 IBUGG3,ISUBRO,IFOUND,IERROR) 5802 IF(IERROR.EQ.'YES')GOTO9000 5803C 5804 IF(NUMVAR.EQ.2)THEN 5805 DO292II=1,NLOCAL 5806 X1(II)=Y2(II) 5807 292 CONTINUE 5808 ENDIF 5809 ELSE 5810 CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 5811 1 INAME,IVARN1,IVARN2,IVARTY, 5812 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 5813 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 5814 1 MAXCP4,MAXCP5,MAXCP6, 5815 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 5816 1 Y1,Y2,X1,XHIGH,TEMP2,TEMP2,TEMP2,NLOCAL, 5817 1 IBUGG3,ISUBRO,IFOUND,IERROR) 5818 IF(IERROR.EQ.'YES')GOTO9000 5819C 5820 IF(NUMVAR.EQ.3)THEN 5821 DO294II=1,NLOCAL 5822 XHIGH(II)=X1(II) 5823 X1(II)=Y2(II) 5824 294 CONTINUE 5825 ELSEIF(NUMVAR.EQ.2)THEN 5826 DO296II=1,NLOCAL 5827 XHIGH(II)=Y2(II) 5828 296 CONTINUE 5829 ENDIF 5830 ENDIF 5831C 5832C ******************************************************* 5833C ** STEP 7-- ** 5834C ** FOR THE 1-VARIABLE CASE ONLY, ** 5835C ** DETERMINE IF THE ANALYST ** 5836C ** HAS SPECIFIED THE GROUP SIZE, ** 5837C ** FOR THE CONTROL CHART ANALYSIS. ** 5838C ** THE GROUP SIZE SETTING IS DEFINED BY SEARCHING ** 5839C ** THE INTERNAL TABLE FOR THE PARAMETER NAME NI ; ** 5840C ** IF FOUND, USE THE SPECIFIED VALUE. ** 5841C ** IF NOT FOUND, GENERATE AN ERROR MESSAGE. ** 5842C ******************************************************* 5843C 5844 ISTEPN='7' 5845 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCC') 5846 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5847C 5848 ISIZE=1 5849 IF((IHIGH.EQ.'OFF'.AND.NUMVAR.LE.1) .OR. 5850 1 (IHIGH.EQ.'ON'.AND.NUMVAR.LE.2))THEN 5851 IH='NI ' 5852 IH2=' ' 5853 IHWUSE='P' 5854 MESSAG='NO' 5855 CALL CHECKN(IH,IH2,IHWUSE, 5856 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 5857 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) 5858 IF(IERRO2.EQ.'YES')THEN 5859 ISIZE=1 5860 ELSE 5861 ISIZE=INT(VALUE(ILOCP)+0.5) 5862 ENDIF 5863 ENDIF 5864C 5865CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEBMER 1990 5866C ******************************************************** 5867C ** STEP 8-- ** 5868C ** DETERMINE IF THE ANALYST ** 5869C ** HAS SPECIFIED ** 5870C ** LSL (LOWER SPEC LIMIT) ** 5871C ** USL (UPPER SPEC LIMIT) ** 5872C ** USLCOST (UPPER SPEC LIMIT COST) ** 5873C ** TARGET ** 5874C ** P (FOR EWMA CHARTS) ** 5875C ** K (FOR UNGROUPED DATA, FILTER WIDTH) ** 5876C ** WIDTH AS ALTERNATIVE TO K ** 5877C ** WEIGHT AS ALTERNATIVE TO P ** 5878C ** FOR THE CONTROL CHART ANALYSIS. ** 5879C ******************************************************** 5880C 5881 ISTEPN='8' 5882 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCC') 5883 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5884C 5885 CCLSL=CPUMIN 5886 IH='LSL ' 5887 IH2=' ' 5888 IHWUSE='P' 5889 MESSAG='NO' 5890 CALL CHECKN(IH,IH2,IHWUSE, 5891 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 5892 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) 5893 IF(IERRO2.EQ.'NO')CCLSL=VALUE(ILOCP) 5894C 5895 CCUSL=CPUMIN 5896 IH='USL ' 5897 IH2=' ' 5898 IHWUSE='P' 5899 MESSAG='NO' 5900 CALL CHECKN(IH,IH2,IHWUSE, 5901 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 5902 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) 5903 IF(IERRO2.EQ.'NO')CCUSL=VALUE(ILOCP) 5904C 5905 CCTARG=CPUMIN 5906 IH='TARG' 5907 IH2='ET ' 5908 IHWUSE='P' 5909 MESSAG='NO' 5910 CALL CHECKN(IH,IH2,IHWUSE, 5911 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 5912 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) 5913 IF(IERRO2.EQ.'NO')CCTARG=VALUE(ILOCP) 5914C 5915 P=CPUMIN 5916 IH='P ' 5917 IH2=' ' 5918 IHWUSE='P' 5919 MESSAG='NO' 5920 CALL CHECKN(IH,IH2,IHWUSE, 5921 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 5922 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) 5923 IF(IERRO2.EQ.'NO')THEN 5924 P=VALUE(ILOCP) 5925 ELSE 5926 IH='WEIG' 5927 IH2='HT ' 5928 IHWUSE='P' 5929 MESSAG='NO' 5930 CALL CHECKN(IH,IH2,IHWUSE, 5931 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 5932 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) 5933 IF(IERRO2.EQ.'NO')P=VALUE(ILOCP) 5934 ENDIF 5935C 5936 KWIDTH=3 5937 IH='K ' 5938 IH2=' ' 5939 IHWUSE='P' 5940 MESSAG='NO' 5941 CALL CHECKN(IH,IH2,IHWUSE, 5942 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 5943 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) 5944 IF(IERRO2.EQ.'NO')THEN 5945 KWIDTH=INT(VALUE(ILOCP)+0.5) 5946 ELSE 5947 IH='WIDT' 5948 IH2='H ' 5949 IHWUSE='P' 5950 MESSAG='NO' 5951 CALL CHECKN(IH,IH2,IHWUSE, 5952 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 5953 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) 5954 IF(IERRO2.EQ.'NO')KWIDTH=INT(VALUE(ILOCP)+0.5) 5955 ENDIF 5956C 5957 USRSIG=CPUMIN 5958 IH='SIGM' 5959 IH2='AE ' 5960 IHWUSE='P' 5961 MESSAG='NO' 5962 CALL CHECKN(IH,IH2,IHWUSE, 5963 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 5964 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) 5965 IF(IERRO2.EQ.'NO')USRSIG=VALUE(ILOCP) 5966C 5967 AK=0.5 5968 IH='K ' 5969 IH2=' ' 5970 IHWUSE='P' 5971 MESSAG='NO' 5972 CALL CHECKN(IH,IH2,IHWUSE, 5973 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 5974 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) 5975 IF(IERRO2.EQ.'NO')AK=VALUE(ILOCP) 5976C 5977 H=5.0 5978 IH='H ' 5979 IH2=' ' 5980 IHWUSE='P' 5981 MESSAG='NO' 5982 CALL CHECKN(IH,IH2,IHWUSE, 5983 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 5984 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) 5985 IF(IERRO2.EQ.'NO')H=VALUE(ILOCP) 5986C 5987 H=5.0 5988 IH='H ' 5989 IH2=' ' 5990 IHWUSE='P' 5991 MESSAG='NO' 5992 CALL CHECKN(IH,IH2,IHWUSE, 5993 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 5994 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) 5995 IF(IERRO2.EQ.'NO')H=VALUE(ILOCP) 5996C 5997 SHI=CPUMIN 5998 IH='SHI ' 5999 IH2=' ' 6000 IHWUSE='P' 6001 MESSAG='NO' 6002 CALL CHECKN(IH,IH2,IHWUSE, 6003 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 6004 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) 6005 IF(IERRO2.EQ.'NO')SHI=VALUE(ILOCP) 6006C 6007 SLI=CPUMIN 6008 IH='SLI ' 6009 IH2=' ' 6010 IHWUSE='P' 6011 MESSAG='NO' 6012 CALL CHECKN(IH,IH2,IHWUSE, 6013 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 6014 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) 6015 IF(IERRO2.EQ.'NO')SLI=VALUE(ILOCP) 6016C 6017 MAXSET=-99 6018 IH='MAXS' 6019 IH2='ET ' 6020 IHWUSE='P' 6021 MESSAG='NO' 6022 CALL CHECKN(IH,IH2,IHWUSE, 6023 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 6024 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) 6025 IF(IERRO2.EQ.'NO')MAXSET=INT(VALUE(ILOCP)+0.5) 6026C 6027C ******************************************************* 6028C ** STEP 9-- ** 6029C ** COMPUTE THE APPROPRIATE CONTROL CHART STATISTIC--** 6030C ** MEAN, STANDARD DEVIATION, RANGE, CUSUM, ** 6031C ** P, NP, C, U. ** 6032C ** COMPUTE CONFIDENCE LINES. ** 6033C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** 6034C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** 6035C ** DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S ** 6036C ** FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE LINE,** 6037C ** AND THE UPPER CONFIDENCE LINE. ** 6038C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** 6039C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** 6040C ******************************************************* 6041C 6042 ISTEPN='8' 6043 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCC') 6044 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6045C 6046 CALL DPCC2(Y1,Y2,X1,XHIGH,NLOCAL,NUMVAR,ICASPL,IHIGH,ISIZE,ICONT, 6047 1 XIDTEM,TEMP,TEMP2,YPREV, 6048 1 CCLSL,CCUSL,CCTARG,P,KWIDTH, 6049 1 ICCHPR,ICCHWT,ICONWC,USRSIG, 6050 1 AK,H,SHI,SLI,MAXSET, 6051 1 Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 6052C 6053C ***************** 6054C ** STEP 90-- ** 6055C ** EXIT ** 6056C ***************** 6057C 6058 9000 CONTINUE 6059 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'DPCC')THEN 6060 WRITE(ICOUT,999) 6061 CALL DPWRST('XXX','BUG ') 6062 WRITE(ICOUT,9011) 6063 9011 FORMAT('***** AT THE END OF DPCC--') 6064 CALL DPWRST('XXX','BUG ') 6065 WRITE(ICOUT,9012)IFOUND,IERROR,ISIZE 6066 9012 FORMAT('IFOUND,IERROR,ISIZE = ',A4,2X,A4,2X,I8) 6067 CALL DPWRST('XXX','BUG ') 6068 IF(IFOUND.EQ.'YES')THEN 6069 WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 6070 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',3I8,3(2X,A4)) 6071 CALL DPWRST('XXX','BUG ') 6072 IF(NPLOTP.GE.1)THEN 6073 DO9015I=1,NPLOTP 6074 WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 6075 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) 6076 CALL DPWRST('XXX','BUG ') 6077 9015 CONTINUE 6078 ENDIF 6079 ENDIF 6080 ENDIF 6081C 6082 RETURN 6083 END 6084 SUBROUTINE DPCC2(Y,YN,X,XHIGH,N,NUMV2,ICASPL,IHIGH,ISIZE,ICONT, 6085 1 XIDTEM,TEMP,TEMP2,YPREV, 6086 1 CCLSL,CCUSL,CCTARG,P,KWIDTH, 6087 1 ICCHPR,ICCHWT,ICONWC,USRSIG, 6088 1 AK,H,SHI,SLI,MAXSET, 6089 1 Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR) 6090C 6091C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS 6092C THAT WILL DEFINE A CONTROL CHART 6093C OF THE FOLLOWING TYPES-- 6094C 1) MEAN CONTROL CHART Y X 6095C 2) STANDARD DEVIATION CONTROL CHART Y X 6096C 3) RANGE CONTROL CHART Y X 6097C 4) CUSUM CONTROL CHART Y X 6098C 5) P CONTROL CHART NUMDEF NUMTOT X 6099C 6) PN CONTROL CHART NUMDEF NUMTOT X 6100C 7) U CONTROL CHART NUMDEF SIZE X 6101C 8) P CONTROL CHART NUMDEF SIZE X 6102C 9) EWMA CONTROL CHART Y X 6103C 10) MOVING AVERAGE CONTROL CHART Y X 6104C 11) MOVING RANGE CONTROL CHART Y X 6105C 12) MOVING STANDARD DEVIATION CONTROL CHART Y X 6106C 13) ISO 13528 CONTROL CHART Y X 6107C 14) ISO 13528 CUSUM CONTROL CHART Y X 6108C NOTE--USE P AND PN CHARTS IF KNOW HOW MANY ITEMS HAVE DEFECTS 6109C --USE U AND C CHARTS IF KNOW HOW MANY DEFECTS 6110C WRITTEN BY--JAMES J. FILLIBEN 6111C STATISTICAL ENGINEERING DIVISION 6112C INFORMATION TECHNOLOGY LABORATORY 6113C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 6114C GAITHERSBURG, MD 20899-8980 6115C PHONE--301-975-2899 6116C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 6117C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 6118C REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105 6119C REFERENCE--ISHIKAWA, GUIDE TO QUALITY CONTROL 6120C LANGUAGE--ANSI FORTRAN (1977) 6121C VERSION NUMBER--82/7 6122C ORIGINAL VERSION--JUNE 1978. 6123C UPDATED --OCTOBER 1978. 6124C UPDATED --JANUARY 1981. 6125C UPDATED --DECEMBER 1981. 6126C UPDATED --APRIL 1982. 6127C UPDATED --MAY 1982. 6128C UPDATED --JANUARY 1988. P, PN, U, AND C CHARTS 6129C UPDATED --JULY 1990. FIX P, PN, U, & C CHARTS 6130C UPDATED --SEPTEMBER 1990. LSL, USL, TARGET 6131C UPDATED --MARCH 1997. EWMA CHART, ACTIVATE CUSUM 6132C UPDATED --MARCH 1997. MOVING AVERAGE CHART 6133C UPDATED --MARCH 1997. MOVING RANGE CHART 6134C UPDATED --MARCH 1997. MOVING STANDARD DEVIATION CHART 6135C UPDATED --JANUARY 2012. SUPPORT FOR HIGHLIGHTING OPTION 6136C UPDATED --JANUARY 2012. SUPPORT FOR WECO AND ISO 13528 6137C CONTROL LIMITS 6138C UPDATED --JANUARY 2012. SUPPORT FOR "MAXSET" OPTION 6139C UPDATED --FEBRUARY 2012. ISO 13528 CONTROL CHART 6140C UPDATED --FEBRUARY 2012. ISO 13528 CUSUM CONTROL CHART 6141C 6142C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 6143C 6144 CHARACTER*4 ICASPL 6145 CHARACTER*4 IHIGH 6146 CHARACTER*4 ICONT 6147 CHARACTER*4 ICCHPR 6148 CHARACTER*4 ICCHWT 6149 CHARACTER*4 ICONWC 6150 CHARACTER*4 IBUGG3 6151 CHARACTER*4 ISUBRO 6152 CHARACTER*4 IERROR 6153C 6154 CHARACTER*4 ISUBN1 6155 CHARACTER*4 ISUBN2 6156 CHARACTER*4 ISTEPN 6157 CHARACTER*4 IWRITE 6158C 6159C--------------------------------------------------------------------- 6160C 6161 DIMENSION Y(*) 6162 DIMENSION YN(*) 6163 DIMENSION X(*) 6164 DIMENSION Y2(*) 6165 DIMENSION X2(*) 6166 DIMENSION D2(*) 6167 DIMENSION XHIGH(*) 6168 DIMENSION YPREV(*) 6169C 6170 DIMENSION XIDTEM(*) 6171 DIMENSION TEMP(*) 6172CCCCC THE FOLLOWING LINE WAS ADDED JULY 1990 6173 DIMENSION TEMP2(*) 6174C 6175 DIMENSION A3(30) 6176 DIMENSION C4(30) 6177 DIMENSION B3(30) 6178 DIMENSION B4(30) 6179 DIMENSION E2(30) 6180 DIMENSION D22(30) 6181 DIMENSION D3(30) 6182 DIMENSION D4(30) 6183C 6184C--------------------------------------------------------------------- 6185C 6186 INCLUDE 'DPCOP2.INC' 6187C 6188C-----DATA STATEMENTS------------------------------------------------- 6189C 6190CCCCC DATA(A(I),I= 1, 25) 6191CCCCC1/9.999,2.121,1.732,1.500,1.342,1.225,1.134,1.061,1.000,0.945, 6192CCCCC1 0.905,0.866,0.832,0.802,0.775,0.750,0.723,0.707,0.688,0.671, 6193CCCCC1 0.655,0.640,0.626,0.612,0.600/ 6194CCCCC DATA(A0(I),I= 1, 25) 6195CCCCC1/9.999,3.760,3.070,2.914,2.884,2.899,2.935,2.980,3.030,3.085, 6196CCCCC1 3.136,3.189,3.242,3.295,3.347,3.398,3.448,3.497,3.545,3.592, 6197CCCCC1 3.639,3.684,3.729,3.773,3.816/ 6198CCCCC DATA(A1(I),I= 1, 25) 6199CCCCC1/9.999,3.760,2.394,1.880,1.596,1.410,1.277,1.175,1.094,1.028, 6200CCCCC1 0.973,0.925,0.884,0.848,0.816,0.788,0.762,0.738,0.717,0.697, 6201CCCCC1 0.679,0.662,0.647,0.632,0.619/ 6202CCCCC DATA(A2(I),I= 1, 25) 6203CCCCC1/9.999,1.880,1.023,0.729,0.577,0.483,0.419,0.373,0.337,0.308, 6204CCCCC1 0.285,0.266,0.249,0.235,0.223,0.212,0.203,0.194,0.187,0.180, 6205CCCCC1 0.173,0.167,0.162,0.157,0.153/ 6206CCCCC DATA(C2(I),I= 1, 25) 6207CCCCC1/9.9999,0.5642,0.7236,0.7979,0.8407, 6208CCCCC1 0.8686,0.8882,0.9027,0.9139,0.9227, 6209CCCCC1 0.9300,0.9359,0.9410,0.9453,0.9490, 6210CCCCC1 0.9523,0.9551,0.9576,0.9599,0.9619, 6211CCCCC1 0.9638,0.9655,0.9670,0.9684,0.9696/ 6212CCCCC DATA(B1(I),I= 1, 25) 6213CCCCC1/0.000,0.000,0.000,0.000,0.000,0.026,0.105,0.167,0.219,0.262, 6214CCCCC1 0.299,0.331,0.359,0.384,0.406,0.427,0.445,0.461,0.477,0.491, 6215CCCCC1 0.504,0.516,0.527,0.538,0.548/ 6216CCCCC DATA(B2(I),I= 1, 25) 6217CCCCC1/9.999,1.843,1.858,1.808,1.756,1.711,1.672,1.638,1.609,1.584, 6218CCCCC1 1.561,1.541,1.523,1.507,1.492,1.478,1.465,1.454,1.443,1.433, 6219CCCCC1 1.424,1.415,1.407,1.399,1.392/ 6220CCCCC DATA(D1(I),I= 1, 25) 6221CCCCC1/0.000,0.000,0.000,0.000,0.000,0.000,0.205,0.387,0.546,0.687, 6222CCCCC1 0.812,0.924,1.026,1.121,1.207,1.285,1.359,1.426,1.490,1.548, 6223CCCCC1 1.606,1.659,1.710,1.759,1.804/ 6224C 6225 DATA(A3(I),I= 1, 25) 6226 1/9.999,2.659,1.954,1.628,1.427, 6227 1 1.287,1.182,1.099,1.032,0.975, 6228 1 0.927,0.886,0.850,0.817,0.789, 6229 1 0.763,0.739,0.718,0.698,0.680, 6230 1 0.663,0.647,0.633,0.619,0.606/ 6231 DATA(C4(I),I= 1, 25) 6232 1/9.9999,0.7979,0.8862,0.9213,0.9400, 6233 1 0.9515,0.9594,0.9650,0.9693,0.9727, 6234 1 0.9754,0.9776,0.9794,0.9810,0.9823, 6235 1 0.9835,0.9845,0.9854,0.9862,0.9869, 6236 1 0.9876,0.9882,0.9887,0.9892,0.9896/ 6237 DATA(B3(I),I= 1, 25) 6238 1/0.000,0.000,0.000,0.000,0.000,0.030,0.118,0.185,0.239,0.284, 6239 1 0.321,0.354,0.382,0.406,0.428,0.448,0.466,0.482,0.497,0.510, 6240 1 0.523,0.534,0.545,0.555,0.565/ 6241 DATA(B4(I),I= 1, 25) 6242 1/9.999,3.267,2.568,2.266,2.089,1.970,1.882,1.815,1.761,1.716, 6243 1 1.679,1.646,1.618,1.594,1.572,1.552,1.534,1.518,1.503,1.490, 6244 1 1.477,1.466,1.455,1.445,1.435/ 6245 DATA(E2(I),I= 1, 25) 6246 1/9.999,1.128,1.693,2.059,2.326,2.534,2.704,2.847,2.970,3.078, 6247 1 3.173,3.258,3.336,3.407,3.472,3.532,3.588,3.640,3.689,3.735, 6248 1 3.778,3.819,3.858,3.895,3.931/ 6249 DATA(D22(I),I= 1, 25) 6250 1/9.999,3.686,4.358,4.698,4.918,5.078,5.203,5.307,5.394,5.469, 6251 1 5.534,5.592,5.646,5.693,5.737,5.779,5.817,5.854,5.888,5.922, 6252 1 5.950,5.979,6.006,6.031,6.058/ 6253 DATA(D3(I),I= 1, 25) 6254 1/0.000,0.000,0.000,0.000,0.000,0.000,0.076,0.136,0.184,0.223, 6255 1 0.256,0.284,0.308,0.329,0.348,0.364,0.379,0.392,0.404,0.414, 6256 1 0.425,0.434,0.443,0.452,0.459/ 6257 DATA(D4(I),I= 1, 25) 6258 1/9.999,3.267,2.575,2.282,2.115,2.004,1.924,1.864,1.816,1.777, 6259 1 1.744,1.716,1.692,1.671,1.652,1.636,1.621,1.608,1.596,1.586, 6260 1 1.575,1.566,1.557,1.548,1.541/ 6261C 6262C-----START POINT----------------------------------------------------- 6263C 6264 ISUBN1='DPCC' 6265 ISUBN2='2 ' 6266 IWRITE='OFF' 6267C 6268 XTMAX=0.0 6269 XTMIN=0.0 6270 D3FACT=0.0D0 6271 D4FACT=0.0D0 6272C 6273 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN 6274 WRITE(ICOUT,70) 6275 70 FORMAT('AT THE BEGINNING OF DPCC2--') 6276 CALL DPWRST('XXX','BUG ') 6277 WRITE(ICOUT,71)N,NUMV2,ISIZE,MAXSET,ICASPL,ICONT 6278 71 FORMAT('N,NUMV2,ISIZE,MAXSET,ICASPL,ICONT = ',4I8,2(2X,A4)) 6279 CALL DPWRST('XXX','BUG ') 6280 WRITE(ICOUT,75)ICCHPR,ICCHWT,ICONWC,USRSIG 6281 75 FORMAT('ICCHPR,ICCHWT,ICONWC,USRSIG = ',3(A4,2X),G15.7) 6282 CALL DPWRST('XXX','BUG ') 6283 DO72I=1,N 6284 WRITE(ICOUT,73)I,Y(I),YN(I),X(I),XHIGH(I) 6285 73 FORMAT('I,Y(I),YN(I),X(I),XHIGH(I) = ',I8,4G15.7) 6286 CALL DPWRST('XXX','BUG ') 6287 72 CONTINUE 6288 ENDIF 6289C 6290 I2=0 6291 ISIZE2=0 6292C 6293 AN=0.0 6294 XBARG=0.0 6295 SDG=0.0 6296 RANGEG=0.0 6297 YUPPER=0.0 6298 YLOWER=0.0 6299C 6300 ANUMSE=0.0 6301 SDI=0.0 6302 SIGMAE=0.0 6303 RANGEE=0.0 6304 SADJ=0.0 6305 RADJ=0.0 6306C 6307C CHECK THE INPUT ARGUMENTS FOR ERRORS 6308C 6309 IF(N.LE.1)THEN 6310 WRITE(ICOUT,999) 6311 999 FORMAT(1X) 6312 CALL DPWRST('XXX','BUG ') 6313 WRITE(ICOUT,31) 6314 31 FORMAT('***** ERROR IN CONTROL CHART--') 6315 CALL DPWRST('XXX','BUG ') 6316 WRITE(ICOUT,32) 6317 32 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2;') 6318 CALL DPWRST('XXX','BUG ') 6319 WRITE(ICOUT,34)N 6320 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) 6321 CALL DPWRST('XXX','BUG ') 6322 WRITE(ICOUT,999) 6323 CALL DPWRST('XXX','BUG ') 6324 IERROR='YES' 6325 GOTO9000 6326 ENDIF 6327C 6328 HOLD=Y(1) 6329 DO60I=1,N 6330 IF(Y(I).NE.HOLD)GOTO69 6331 60 CONTINUE 6332 WRITE(ICOUT,999) 6333 CALL DPWRST('XXX','BUG ') 6334 WRITE(ICOUT,31) 6335 CALL DPWRST('XXX','BUG ') 6336 WRITE(ICOUT,62)HOLD 6337 62 FORMAT(' ALL RESPONSE VARIABLE ELEMENTS ARE IDENTICALLY ', 6338 1 'EQUAL TO ',G15.7) 6339 CALL DPWRST('XXX','BUG ') 6340 WRITE(ICOUT,999) 6341 CALL DPWRST('XXX','BUG ') 6342 IERROR='YES' 6343 GOTO9000 6344 69 CONTINUE 6345C 6346C ******************************************************** 6347C ** STEP 1-- ** 6348C ** DETERMINE THE NUMBER OF DISTINCT VALUES ** 6349C ** FOR VARIABLE 2 (THE GROUP VARIABLE). ** 6350C ** IF ALL VALUES ARE DISTINCT, THEN THIS ** 6351C ** IMPLIES WE HAVE THE NO REPLICATION CASE ** 6352C ** WHICH IS AN ERROR CONDITION FOR A CONTROL CHART. ** 6353C ******************************************************** 6354C 6355 ISTEPN='1' 6356 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2') 6357 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6358C 6359 IF((IHIGH.EQ.'OFF'.AND.NUMV2.EQ.1) .OR. 6360 1 (IHIGH.EQ.'ON'.AND.NUMV2.EQ.2))THEN 6361C 6362C WHEN THERE IS NO GROUP-ID VARIABLE, CREATE ONE (BASED ON 6363C ISIZE). 6364C 6365 NUMSET=0 6366 IF(ISIZE.EQ.1)THEN 6367 DO120I=1,N 6368 XIDTEM(I)=REAL(I) 6369 X(I)=XIDTEM(I) 6370 120 CONTINUE 6371 ELSE 6372 NUMSET=0 6373 ILOOP=N/ISIZE 6374 DO145I=1,ILOOP 6375 NUMSET=NUMSET+1 6376 XIDTEM(NUMSET)=REAL(NUMSET) 6377 ISTART=(I-1)*ISIZE+1 6378 ISTOP=I*ISIZE 6379 DO147J=ISTART,ISTOP 6380 X(J)=XIDTEM(NUMSET) 6381 147 CONTINUE 6382 145 CONTINUE 6383 ILEFT=MOD(N,ISIZE) 6384 IF(ILEFT.NE.0)THEN 6385 ISTART=ILOOP*ISIZE+1 6386 NUMSET=NUMSET+1 6387 XIDTEM(NUMSET)=REAL(NUMSET) 6388 DO148J=ISTART,N 6389 X(J)=XIDTEM(NUMSET) 6390 148 CONTINUE 6391 ENDIF 6392 ENDIF 6393 ENDIF 6394C 6395C WHEN THERE IS A GROUP-ID VARIABLE, EXTRACT UNIQUE VALUES 6396C 6397 CALL DISTIN(X,N,IWRITE,XIDTEM,NUMSET,IBUGG3,IERROR) 6398C 6399 IF(NUMSET.LT.1)THEN 6400 WRITE(ICOUT,999) 6401 CALL DPWRST('XXX','BUG ') 6402 WRITE(ICOUT,31) 6403 CALL DPWRST('XXX','BUG ') 6404 WRITE(ICOUT,192) 6405 192 FORMAT(' THE NUMBER OF SETS IS EQUAL TO ZERO.') 6406 CALL DPWRST('XXX','BUG ') 6407 IERROR='YES' 6408 GOTO9000 6409 ENDIF 6410C 6411 CALL SORT(XIDTEM,NUMSET,XIDTEM) 6412C 6413 IF((ICASPL.EQ.'MECC' .OR. ICASPL.EQ.'SDCC' .OR. 6414 1 ICASPL.EQ.'RACC') .AND.NUMSET.EQ.N)THEN 6415 WRITE(ICOUT,999) 6416 CALL DPWRST('XXX','BUG ') 6417 WRITE(ICOUT,31) 6418 CALL DPWRST('XXX','BUG ') 6419 WRITE(ICOUT,196) 6420 196 FORMAT(' THE NUMBER OF SETS IS IDENTICAL TO THE NUMBER ', 6421 1 'OF OBSERVATIONS.') 6422 CALL DPWRST('XXX','BUG ') 6423 WRITE(ICOUT,198)NUMSET 6424 198 FORMAT(' THEN NUMBER OF SETS/OBSERVATIONS = ',I8) 6425 CALL DPWRST('XXX','BUG ') 6426 IERROR='YES' 6427 GOTO9000 6428 ENDIF 6429C 6430 AN=N 6431 ANUMSE=NUMSET 6432C 6433C ******************************************* 6434C ** STEP 3.0-- ** 6435C ** DETERMINE STATISTICS FOR THE ENTIRE ** 6436C ** DATA SET ** 6437C ******************************************* 6438C 6439C NOTE 2012/1: IN SOME CASES, WE MAY WANT TO BASE CONTROL 6440C LIMITS ON PORTION OF PLOT THAT IS KNOWN TO 6441C BE IN CONTROL (E.G., HISTORICAL DATA). IF 6442C USER HAS SPECIFIED "MAXSET", ONLY USE SETS 6443C FROM 1 TO MAXSET IN COMPUTING THESE STATISTICS. 6444C 6445C FOR NOW, LIMIT THIS OPTION TO THE SHEWHART 6446C CHARTS (MEAN, SD, RANGE). 6447C 6448 ISTEPN='3.0' 6449 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2') 6450 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6451C 6452 SUMXBG=0.0 6453 SUMSDG=0.0 6454 SUMRAG=0.0 6455 SUMSIE=0.0 6456 SUMRIE=0.0 6457C 6458 NUMTMP=NUMSET 6459 IF(MAXSET.GE.1 .AND. MAXSET.LT.NUMSET)THEN 6460 IF(ICASPL.EQ.'MECC' .OR. ICASPL.EQ.'RACC' .OR. 6461 1 ICASPL.EQ.'SDCC' .OR. ICASPL.EQ.'MACC' .OR. 6462 1 ICASPL.EQ.'MSCC' .OR. ICASPL.EQ.'MRCC')THEN 6463 6464 NUMTMP=MAXSET 6465 ENDIF 6466 ENDIF 6467C 6468 J=0 6469 ANTMP=0.0 6470 DO1010ISET=1,NUMTMP 6471 J=J+1 6472C 6473 K=0 6474 DO1020I=1,N 6475 IF(X(I).EQ.XIDTEM(ISET))K=K+1 6476 IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I) 6477 1020 CONTINUE 6478 NI=K 6479 ANI=NI 6480C 6481 SUM=0.0 6482C 6483 IF(NI.LE.0)THEN 6484 WRITE(ICOUT,999) 6485 CALL DPWRST('XXX','BUG ') 6486 WRITE(ICOUT,31) 6487 CALL DPWRST('XXX','BUG ') 6488 WRITE(ICOUT,1042) 6489 1042 FORMAT('NI FOR SOME CLASS = 0') 6490 CALL DPWRST('XXX','BUG ') 6491 WRITE(ICOUT,1043)ISET,XIDTEM(ISET),NI 6492 1043 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,G15.7,I8) 6493 CALL DPWRST('XXX','BUG ') 6494 IERROR='YES' 6495 GOTO9000 6496 ENDIF 6497C 6498 ANTMP=ANTMP+REAL(NI) 6499 CALL MEAN(TEMP,NI,IWRITE,XBARI,IBUGG3,IERROR) 6500 VARI=0.0 6501 IF(NI.GE.2)THEN 6502 CALL VAR(TEMP,NI,IWRITE,VARI,IBUGG3,IERROR) 6503 ENDIF 6504 SDI=0.0 6505 IF(VARI.GT.0.0)SDI=SQRT(VARI) 6506 XTMIN=TEMP(1) 6507 XTMAX=TEMP(1) 6508 DO1034I=1,NI 6509 IF(TEMP(I).LT.XTMIN)XTMIN=TEMP(I) 6510 IF(TEMP(I).GT.XTMAX)XTMAX=TEMP(I) 6511 1034 CONTINUE 6512 RANGEI=XTMAX-XTMIN 6513 SUMXBG=SUMXBG+ANI*XBARI 6514 SUMSDG=SUMSDG+ANI*SDI 6515 SUMRAG=SUMRAG+ANI*RANGEI 6516C 6517 IF(NI.LE.25)THEN 6518 SUMSIE=SUMSIE+SDI/C4(NI) 6519 SUMRIE=SUMRIE+RANGEI/D22(NI) 6520 AJUNK1=C4(NI) 6521 AJUNK2=D22(NI) 6522 ELSE 6523 C4LARG=1.0 6524 D22LAR=2.0*SQRT(2.0*LOG(2.0*ANI)) 6525 SUMSIE=SUMSIE+SDI/C4LARG 6526 SUMRIE=SUMRIE+RANGEI/D22LAR 6527 AJUNK1=C4LARG 6528 AJUNK2=D22LAR 6529 ENDIF 6530C 6531 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN 6532 WRITE(ICOUT,1061)ISET,NI,ANI,XBARI 6533 1061 FORMAT('ISET,NI,ANI,XBARI = ',2I8,2G15.7) 6534 CALL DPWRST('XXX','BUG ') 6535 WRITE(ICOUT,1063)SDI,AJUNK1,SUMSIE 6536 1063 FORMAT('SDI,C4,SUMSIE = ',3G15.7) 6537 CALL DPWRST('XXX','BUG ') 6538 WRITE(ICOUT,1064)RANGEI,AJUNK2,SUMRIE 6539 1064 FORMAT('RANGEI,D22,SUMRIE = ',3G15.7) 6540 CALL DPWRST('XXX','BUG ') 6541 ENDIF 6542C 6543 1010 CONTINUE 6544C 6545 XBARG=SUMXBG/ANTMP 6546 SDG=SUMSDG/ANTMP 6547 RANGEG=SUMRAG/ANTMP 6548CCCCC SIGMAE=SUMSIE/REAL(MAXSET) 6549CCCCC RANGEE=SUMRIE/REAL(MAXSET) 6550 SIGMAE=SUMSIE/REAL(NUMTMP) 6551 RANGEE=SUMRIE/REAL(NUMTMP) 6552C 6553C FOR UNGROUPED DATA, USE THE MOVING RANGE OR THE MOVING STANDARD 6554C DEVIATION TO COMPUTE AN ESTIMATE FOR SIGMAE. MARCH 1997. 6555C 6556 RANGEM=0.0 6557 SDM=0.0 6558 IF(N.EQ.NUMSET .AND. ICASPL.NE.'1352' .AND. ICASPL.NE.'1CUS')THEN 6559 IF(KWIDTH.LT.2)KWIDTH=2 6560 IF(KWIDTH.GT.N-1)KWIDTH=N-1 6561 NBEF=KWIDTH/2 6562 NAFT=NBEF 6563 IF(MOD(KWIDTH,2).EQ.0)NAFT=NBEF-1 6564 IF(1+NBEF.GT.NUMSET-NAFT)THEN 6565 WRITE(ICOUT,999) 6566 CALL DPWRST('XXXX','BUG ') 6567 WRITE(ICOUT,31) 6568 CALL DPWRST('XXXX','BUG ') 6569 WRITE(ICOUT,1071) 6570 1071 FORMAT(' THERE ARE NOT ENOUGH DATA POINTS TO FORM THE ', 6571 1 'MOVING RANGE ESTIMATE') 6572 CALL DPWRST('XXXX','BUG ') 6573 WRITE(ICOUT,1072) 6574 1072 FORMAT(' OF THE ERROR STANDARD DEVIATION FOR UNGROUPED ', 6575 1 'DATA. YOU PROBABLY') 6576 CALL DPWRST('XXXX','BUG ') 6577 WRITE(ICOUT,1073) 6578 1073 FORMAT(' NEED TO SET A SMALLER VALUE FOR THE FILTER ', 6579 1 'WIDTH. FOR EXAMPLE,') 6580 CALL DPWRST('XXXX','BUG ') 6581 WRITE(ICOUT,999) 6582 CALL DPWRST('XXXX','BUG ') 6583 WRITE(ICOUT,1074) 6584 1074 FORMAT(' LET K = 3') 6585 CALL DPWRST('XXXX','BUG ') 6586 WRITE(ICOUT,999) 6587 CALL DPWRST('XXXX','BUG ') 6588 WRITE(ICOUT,1075) 6589 1075 FORMAT(' THE PARAMETER K DEFINES HOW MANY VALUES ARE ', 6590 1 'USED TO COMUTE THE') 6591 CALL DPWRST('XXXX','BUG ') 6592 WRITE(ICOUT,1076) 6593 1076 FORMAT(' MOVING RANGE (3 IS THE TYPICAL VALUE). THE ', 6594 1 'CURRENT VALUE') 6595 CALL DPWRST('XXXX','BUG ') 6596 WRITE(ICOUT,1077)KWIDTH 6597 1077 FORMAT(' OF K IS ',I5,'.') 6598 CALL DPWRST('XXXX','BUG ') 6599 IERROR='YES' 6600 GOTO9000 6601 ENDIF 6602C 6603 SUM=0.0 6604 SUM2=0.0 6605 ICOUNT=0 6606CCCCC DO1083I=1+NBEF,MAXSET-NAFT 6607 DO1083I=1+NBEF,NUMTMP-NAFT 6608 ICOUNT=ICOUNT+1 6609 SUM1=0.0 6610 XTMIN=Y(I-NBEF) 6611 XTMAX=Y(I+NAFT) 6612 DO1086II=I-NBEF,I+NAFT 6613 IF(Y(II).LT.XTMIN)XTMIN=Y(II) 6614 IF(Y(II).GT.XTMAX)XTMAX=Y(II) 6615 SUM1=SUM1+Y(II) 6616 1086 CONTINUE 6617 SUM=SUM+(XTMAX-XTMIN) 6618 XMEAN=SUM1/REAL(KWIDTH) 6619 SUM1=0.0 6620 DO1087II=I-NBEF,I+NAFT 6621 SUM1=SUM1+(Y(II)-XMEAN)**2 6622 1087 CONTINUE 6623 SUM2=SUM2+SQRT(SUM1/REAL(KWIDTH-1)) 6624 1083 CONTINUE 6625 RANGEM=SUM/REAL(ICOUNT) 6626 SDM=SUM2/REAL(ICOUNT) 6627 ENDIF 6628C 6629C ********************************************************* 6630C ** STEP 4-- ** 6631C ** IN ORDER TO DETERMINE THE PROPER PLOT COOORDINATES ** 6632C ** FOR THE DESIRED PLOT, ** 6633C ** BRANCH TO THE PROPER SUBCASE-- ** 6634C ** 1) MEAN CONTROL CHART ** 6635C ** 2) STANDARD DEVIATION CONTROL CHART ** 6636C ** 3) RANGE CONTROL CHART ** 6637C ** 4) CUSUM CONTROL CHART ** 6638C ** 5) P CONTROL CHART ** 6639C ** 6) PN CONTROL CHART ** 6640C ** 7) C CONTROL CHART ** 6641C ** 8) U CONTROL CHART ** 6642C ** 9) EWMA CONTROL CHART ** 6643C ** 10) MOVING AVERAGE CONTROL CHART ** 6644C ** 11) MOVING RANGE CONTROL CHART ** 6645C ** 12) MOVING SD CONTROL CHART ** 6646C ** 13) ISO 13528 CONTROL CHART ** 6647C ** 14) ISO 13528 CUSUM CONTROL CHART ** 6648C ********************************************************* 6649C 6650 ISTEPN='4' 6651 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2') 6652 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6653C 6654 NPREV=0 6655 IF(ICASPL.EQ.'MECC')THEN 6656C 6657C ***************************************** 6658C ** STEP 5.1-- ** 6659C ** TREAT THE MEAN CONTROL CHART CASE ** 6660C ***************************************** 6661C 6662 ISTEPN='5.1' 6663 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2') 6664 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6665C 6666 J=0 6667 DO1110ISET=1,NUMSET 6668C 6669 XTAG=0.0 6670 K=0 6671 DO1120I=1,N 6672 IF(X(I).EQ.XIDTEM(ISET))THEN 6673 K=K+1 6674 TEMP(K)=Y(I) 6675 IF(XHIGH(I).GE.0.5)XTAG=1.0 6676 ENDIF 6677 1120 CONTINUE 6678 NI=K 6679 ANI=NI 6680C 6681 IF(NI.LT.1)THEN 6682 WRITE(ICOUT,999) 6683 CALL DPWRST('XXX','BUG ') 6684 WRITE(ICOUT,31) 6685 CALL DPWRST('XXX','BUG ') 6686 WRITE(ICOUT,1132) 6687 1132 FORMAT('FOR SOME CLASS NI= 0') 6688 CALL DPWRST('XXX','BUG ') 6689 WRITE(ICOUT,1133)ISET,XIDTEM(ISET),NI 6690 1133 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,G15.7,I8) 6691 CALL DPWRST('XXX','BUG ') 6692 IERROR='YES' 6693 GOTO9000 6694 ENDIF 6695C 6696 SUM=0.0 6697 DO1140I=1,NI 6698 SUM=SUM+TEMP(I) 6699 1140 CONTINUE 6700 XBARI=SUM/ANI 6701 YMID=XBARG 6702C 6703 IF(NI.GE.26)THEN 6704 C4LARG=1.0 6705 SADJ=C4LARG*SIGMAE 6706 A3LARG=3.0/SQRT(ANI) 6707 YUPPER=XBARG+A3LARG*SADJ 6708 YLOWER=XBARG-A3LARG*SADJ 6709 AJUNK1=C4LARG 6710 AJUNK2=A3LARG 6711 ELSE 6712 SADJ=C4(NI)*SIGMAE 6713 YUPPER=XBARG+A3(NI)*SADJ 6714 YLOWER=XBARG-A3(NI)*SADJ 6715 AJUNK1=C4(NI) 6716 AJUNK2=A3(NI) 6717 ENDIF 6718C 6719 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN 6720 WRITE(ICOUT,1161)ISET,NI,ANI,XBARI,XBARG 6721 1161 FORMAT('ISET,NI,ANI,XBARI,XBARG = ',2I8,3G15.7) 6722 CALL DPWRST('XXX','BUG ') 6723 WRITE(ICOUT,1163)SDI,AJUNK1,SIGMAE,SADJ 6724 1163 FORMAT('SDI,AJUNK1,SIGMAE,SADJ = ',4G15.7) 6725 CALL DPWRST('XXX','BUG ') 6726 WRITE(ICOUT,1165)YMID,AJUNK2,YUPPER,YLOWER 6727 1165 FORMAT('YMID,A3,YUPPER,YLOWER = ',4G15.7) 6728 CALL DPWRST('XXX','BUG ') 6729 ENDIF 6730C 6731 CALL DPCC3(ICASPL,J,XBARI,YMID,YLOWER,YUPPER, 6732 1 Y2,X2,D2,XIDTEM(ISET), 6733 1 YPREV,NPREV,IHIGH,XTAG,SIGMAE, 6734 1 CCLSL,CCUSL,CCTARG,ICONWC, 6735 1 IBUGG3,ISUBRO,IERROR) 6736C 6737 1110 CONTINUE 6738 ELSEIF(ICASPL.EQ.'SDCC')THEN 6739C 6740C ******************************************************** 6741C ** STEP 5.2-- ** 6742C ** TREAT THE STANDARD DEVIATION CONTROL CHART CASE ** 6743C ******************************************************** 6744C 6745 ISTEPN='5.2' 6746 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2') 6747 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6748C 6749 J=0 6750 DO1210ISET=1,NUMSET 6751C 6752 XTAG=0.0 6753 K=0 6754 DO1220I=1,N 6755 IF(X(I).EQ.XIDTEM(ISET))THEN 6756 K=K+1 6757 TEMP(K)=Y(I) 6758 IF(XHIGH(I).GE.0.5)XTAG=1.0 6759 ENDIF 6760 1220 CONTINUE 6761 NI=K 6762 ANI=NI 6763C 6764 IF(NI.LT.1)THEN 6765 WRITE(ICOUT,999) 6766 CALL DPWRST('XXX','BUG ') 6767 WRITE(ICOUT,31) 6768 CALL DPWRST('XXX','BUG ') 6769 WRITE(ICOUT,1132) 6770 CALL DPWRST('XXX','BUG ') 6771 WRITE(ICOUT,1133)ISET,XIDTEM(ISET),NI 6772 CALL DPWRST('XXX','BUG ') 6773 IERROR='YES' 6774 GOTO9000 6775 ENDIF 6776C 6777 SUM=0.0 6778 DO1240I=1,NI 6779 SUM=SUM+TEMP(I) 6780 1240 CONTINUE 6781 XBARI=SUM/ANI 6782C 6783 IF(NI.LE.1)GOTO1210 6784C 6785 SUM=0.0 6786 DO1250I=1,NI 6787 SUM=SUM+(TEMP(I)-XBARI)**2 6788 1250 CONTINUE 6789 DENOM=ANI-1.0 6790 VARI=0.0 6791 IF(NI.GE.2)VARI=SUM/DENOM 6792 SDI=0.0 6793 IF(VARI.GT.0.0)SDI=SQRT(VARI) 6794C 6795 IF(NI.GE.26)THEN 6796 C4LARG=1.0 6797 SADJ=C4LARG*SIGMAE 6798 B4LARG=1.0+3.0/SQRT(2.0*(ANI-1.0)) 6799 B3LARG=1.0-3.0/SQRT(2.0*(ANI-1.0)) 6800 YUPPER=B4LARG*SADJ 6801 YLOWER=B3LARG*SADJ 6802 AJUNK1=C4LARG 6803 AJUNK2=B4LARG 6804 AJUNK3=B3LARG 6805 ELSE 6806 SADJ=C4(NI)*SIGMAE 6807 YUPPER=B4(NI)*SADJ 6808 YLOWER=B3(NI)*SADJ 6809 AJUNK1=C4(NI) 6810 AJUNK2=B4(NI) 6811 AJUNK3=B3(NI) 6812 ENDIF 6813C 6814 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN 6815 WRITE(ICOUT,1261)ISET,NI,ANI,XBARI 6816 1261 FORMAT('ISET,NI,ANI,XBARI = ',2I8,2G15.7) 6817 CALL DPWRST('XXX','BUG ') 6818 WRITE(ICOUT,1263)SDI,AJUNK1,SIGMAE,SADJ,YMID 6819 1263 FORMAT('SDI,C4,SIGMAE,SADJ,YMID = ',5G15.7) 6820 CALL DPWRST('XXX','BUG ') 6821 WRITE(ICOUT,1265)YMID,AJUNK2,AJUNK3,YUPPER,YLOWER 6822 1265 FORMAT('YMID,B4,YUPPER,B3,YLOWER = ',4G15.7) 6823 CALL DPWRST('XXX','BUG ') 6824 ENDIF 6825C 6826 CALL DPCC3(ICASPL,J,SDI,SADJ,YLOWER,YUPPER, 6827 1 Y2,X2,D2,XIDTEM(ISET), 6828 1 YPREV,NPREV,IHIGH,XTAG,SIGMAE, 6829 1 CCLSL,CCUSL,CCTARG,ICONWC, 6830 1 IBUGG3,ISUBRO,IERROR) 6831C 6832 1210 CONTINUE 6833 ELSEIF(ICASPL.EQ.'RACC')THEN 6834C 6835C ****************************************** 6836C ** STEP 5.3-- ** 6837C ** TREAT THE RANGE CONTROL CHART CASE ** 6838C ****************************************** 6839C 6840 ISTEPN='5.3' 6841 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2') 6842 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6843C 6844 D4FACT=1.25 6845 D3FACT=1.0/1.25 6846C 6847 J=0 6848 DO1310ISET=1,NUMSET 6849C 6850 XTAG=0.0 6851 K=0 6852 DO1320I=1,N 6853 IF(X(I).EQ.XIDTEM(ISET))THEN 6854 K=K+1 6855 TEMP(K)=Y(I) 6856 IF(XHIGH(I).GE.0.5)XTAG=1.0 6857 ENDIF 6858 1320 CONTINUE 6859 NI=K 6860 ANI=NI 6861C 6862 IF(NI.LT.1)THEN 6863 WRITE(ICOUT,999) 6864 CALL DPWRST('XXX','BUG ') 6865 WRITE(ICOUT,31) 6866 CALL DPWRST('XXX','BUG ') 6867 WRITE(ICOUT,1132) 6868 CALL DPWRST('XXX','BUG ') 6869 WRITE(ICOUT,1133)ISET,XIDTEM(ISET),NI 6870 CALL DPWRST('XXX','BUG ') 6871 IERROR='YES' 6872 GOTO9000 6873 ENDIF 6874C 6875 IF(NI.LE.1)GOTO1310 6876C 6877 XTMIN=TEMP(1) 6878 XTMAX=TEMP(1) 6879 DO1340I=1,NI 6880 IF(TEMP(I).LT.XTMIN)XTMIN=TEMP(I) 6881 IF(TEMP(I).GT.XTMAX)XTMAX=TEMP(I) 6882 1340 CONTINUE 6883 RANGEI=XTMAX-XTMIN 6884C 6885 IF(NI.GE.26)THEN 6886 D22LAR=2.0*SQRT(2.0*LOG(2.0*ANI)) 6887 RADJ=D22LAR*RANGEE 6888 D4LARG=1.0+3.0*D4FACT/SQRT(2.0*(ANI-1.0)) 6889 D3LARG=1.0-3.0*D3FACT/SQRT(2.0*(ANI-1.0)) 6890 YUPPER=D4LARG*RADJ 6891 YLOWER=D3LARG*RADJ 6892 AJUNK1=D22LAR 6893 AJUNK2=D4LARG 6894 AJUNK3=D3LARG 6895 ELSE 6896 RADJ=D22(NI)*RANGEE 6897 YUPPER=D4(NI)*RADJ 6898 YLOWER=D3(NI)*RADJ 6899 AJUNK1=D22(NI) 6900 AJUNK2=D4(NI) 6901 AJUNK3=D3(NI) 6902 ENDIF 6903 YMID=RADJ 6904C 6905 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN 6906 WRITE(ICOUT,1361)ISET,NI,ANI,RANGEI,YMID 6907 1361 FORMAT('ISET,NI,ANI,YMID = ',2I8,3G15.7) 6908 CALL DPWRST('XXX','BUG ') 6909 WRITE(ICOUT,1363)RANGEI,AJUNK1,RANGEE,SADJ,RADJ 6910 1363 FORMAT('RANGEI,D22,RANGEE,SADJ,RADJ = ',5G15.7) 6911 CALL DPWRST('XXX','BUG ') 6912 WRITE(ICOUT,1365)NI,ANI,AJUNK2,YUPPER,AJUNK3,YLOWER 6913 1365 FORMAT('NI,ANI,D4,YUPPER,D3,YLOWER = ',I8,5G15.7) 6914 CALL DPWRST('XXX','BUG ') 6915 ENDIF 6916C 6917 CALL DPCC3(ICASPL,J,RANGEI,YMID,YLOWER,YUPPER, 6918 1 Y2,X2,D2,XIDTEM(ISET), 6919 1 YPREV,NPREV,IHIGH,XTAG,RANGEE, 6920 1 CCLSL,CCUSL,CCTARG,ICONWC, 6921 1 IBUGG3,ISUBRO,IERROR) 6922C 6923 1310 CONTINUE 6924 ELSEIF(ICASPL.EQ.'CUCC')THEN 6925C 6926C ****************************************************** 6927C ** STEP 5.4-- ** 6928C ** DETERMINE PLOT COORDINATES ** 6929C ** FOR THE CUSUM CONTROL CHART PLOT SUBCASE. ** 6930C ****************************************************** 6931C 6932 ISTEPN='5.4' 6933 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2') 6934 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6935C 6936 J=0 6937C 6938 SUMH=0.0 6939 SUML=0.0 6940 IF(SHI.NE.CPUMIN)SUMH=SHI 6941 IF(SLI.NE.CPUMIN)SUML=SLI 6942 ZHIGH=3.5 6943 IF(CCUSL.NE.CPUMIN)ZHIGH=CCUSL 6944C 6945 DO1410ISET=1,NUMSET 6946C 6947 K=0 6948 XTAG=0.0 6949 DO1420I=1,N 6950 IF(X(I).EQ.XIDTEM(ISET))K=K+1 6951 IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I) 6952 IF(XHIGH(I).GE.0.5)XTAG=1.0 6953 1420 CONTINUE 6954 NI=K 6955 ANI=NI 6956C 6957 IF(NI.LT.1)THEN 6958 WRITE(ICOUT,999) 6959 CALL DPWRST('XXX','BUG ') 6960 WRITE(ICOUT,31) 6961 CALL DPWRST('XXX','BUG ') 6962 WRITE(ICOUT,1132) 6963 CALL DPWRST('XXX','BUG ') 6964 WRITE(ICOUT,1133)ISET,XIDTEM(ISET),NI 6965 CALL DPWRST('XXX','BUG ') 6966 IERROR='YES' 6967 GOTO9000 6968 ENDIF 6969C 6970 IF(NI.EQ.1)THEN 6971 ZI=(TEMP(1)-XBARG)/RANGEM 6972 ELSE 6973 SUM=0.0 6974 DO1441I=1,NI 6975 SUM=SUM+TEMP(I) 6976 1441 CONTINUE 6977 XBARI=SUM/ANI 6978 ZI=(XBARI-XBARG)/SIGMAE 6979 ENDIF 6980C 6981 SUMH=MAX(0.0,SUMH+(ZI-AK)) 6982 SUML=MAX(0.0,SUML+(-ZI-AK)) 6983C 6984 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN 6985 WRITE(ICOUT,1461)ISET,NI,ANI,XBARI 6986 1461 FORMAT('ISET,NI,ANI,XBARI = ',2I8,2G15.7) 6987 CALL DPWRST('XXX','BUG ') 6988 WRITE(ICOUT,1463)ZI,SUMH,SUML 6989 1463 FORMAT('ZI,SUMH,SUML = ',3G15.7) 6990 CALL DPWRST('XXX','BUG ') 6991 ENDIF 6992C 6993 YUPPER=H 6994 YLOWER=-H 6995C 6996 J=J+1 6997 Y2(J)=SUMH 6998 X2(J)=XIDTEM(ISET) 6999 D2(J)=1.0 7000C 7001 J=J+1 7002 Y2(J)=-SUML 7003 X2(J)=XIDTEM(ISET) 7004 D2(J)=2.0 7005C 7006 J=J+1 7007 Y2(J)=0.0 7008 X2(J)=XIDTEM(ISET) 7009 D2(J)=3.0 7010C 7011 J=J+1 7012 Y2(J)=YUPPER 7013 X2(J)=XIDTEM(ISET) 7014 D2(J)=4.0 7015C 7016 J=J+1 7017 Y2(J)=YLOWER 7018 X2(J)=XIDTEM(ISET) 7019 D2(J)=5.0 7020C 7021 IF(ZI.LE.ZHIGH)GOTO1472 7022 J=J+1 7023 Y2(J)=SUMH 7024 X2(J)=XIDTEM(ISET) 7025 D2(J)=6.0 7026 J=J+1 7027 Y2(J)=SUML 7028 X2(J)=XIDTEM(ISET) 7029 D2(J)=7.0 7030 1472 CONTINUE 7031C 7032 1410 CONTINUE 7033 ELSEIF(ICASPL.EQ.'PCC')THEN 7034C 7035C ******************************************************** 7036C ** STEP 5.5-- ** 7037C ** TREAT THE P CONTROL CHART CASE ** 7038C ** PROPORTION DEFECTIVE PER BATCH (SUBSAMPLE) ** 7039C ** NUMBER DEFECTIVE PER BATCH / TOTAL NUMBER IN BATCH** 7040C ** THE INPUT IS A DUAL SERIES-- ** 7041C ** 1) NUMBER OF DEFECTIVE ITEMS IN THE SUBSAMPLE ** 7042C ** 2) TOTAL NUMBER OF ITEMS IN THE SAMPLE ** 7043C ** THE CONFIDENCE BAND IS GOTTEN BY ASSUMING BINOMIAL** 7044C ******************************************************** 7045C 7046 ISTEPN='5.5' 7047 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2') 7048 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7049C 7050 SUM1=0.0 7051 SUM2=0.0 7052 DO1510ISET=1,NUMSET 7053 SUM1=SUM1+Y(ISET) 7054 SUM2=SUM2+YN(ISET) 7055 1510 CONTINUE 7056 CTOTAL=SUM1 7057 ANTOT=SUM2 7058 PBARG=CTOTAL/ANTOT 7059 PRBARG=100.0*PBARG 7060C 7061 J=0 7062 XTAG=0.0 7063 DO1550ISET=1,NUMSET 7064C 7065 CI=Y(ISET) 7066 ANI=YN(ISET) 7067 NI=INT(ANI+0.5) 7068 IF(NI.LE.0)GOTO1550 7069C 7070 PI=CI/ANI 7071 PROPI=100.0*PI 7072 YMID=PRBARG 7073 VARPI=0.0 7074 IF(ANI.GT.0.0)VARPI=PBARG*(1.0-PBARG)/ANI 7075 SDPI=0.0 7076 IF(VARPI.GT.0.0)SDPI=SQRT(VARPI) 7077 SDPRI=100.0*SDPI 7078 YUPPER=YMID+3.0*SDPRI 7079 IF(YUPPER.GT.100.0)YUPPER=100.0 7080 YLOWER=YMID-3.0*SDPRI 7081 IF(YLOWER.LT.0.0)YLOWER=0.0 7082C 7083 CALL DPCC3(ICASPL,J,PROPI,YMID,YLOWER,YUPPER, 7084 1 Y2,X2,D2,XIDTEM(ISET), 7085 1 YPREV,NPREV,IHIGH,XTAG,SIGMAE, 7086 1 CCLSL,CCUSL,CCTARG,ICONWC, 7087 1 IBUGG3,ISUBRO,IERROR) 7088C 7089 1550 CONTINUE 7090C 7091 ELSEIF(ICASPL.EQ.'PNCC')THEN 7092C 7093C ************************************************************* 7094C ** STEP 5.6-- ** 7095C ** TREAT THE PN CONTROL CHART CASE ** 7096C ** TOTAL NUMBER DEFECTIVE IN A BATCH (SUBSAMPLE) ** 7097C ** SUM UP THE NUMBER OF DEFECTIVES PER BATCH (SUBSAMPLE) ** 7098C ** THE NUMBER WILL BE A NON-NEGATIVE INTEGER ** 7099C ** THE INPUT IS A DUAL SERIES-- ** 7100C ** 1) NUMBER OF DEFECTIVE ITEMS IN THE SUBSAMPLE ** 7101C ** 2) TOTAL NUMBER OF ITEMS IN THE SAMPLE ** 7102C ** THE CONFIDENCE BAND IS GOTTEN BY ASSUMING BINOMIAL ** 7103C ** NOTE--THE PN CHART SHOULD BE USED ONLY WHEN ** 7104C ** THE SUBSAMPLE SIZE IS CONSTANT. ** 7105C ** FOR VARYING SUBSAMPLE SIZE, USE THE P CHART ** 7106C ** (ISHIKAWA, GUIDE TO QUALITY CONTROL, PAGE 77) ** 7107C ************************************************************* 7108C 7109 ISTEPN='5.6' 7110 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2') 7111 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7112C 7113 XTAG=0.0 7114 SUM1=0.0 7115 SUM2=0.0 7116 ANUMSE=NUMSET 7117 DO1610ISET=1,NUMSET 7118 SUM1=SUM1+Y(ISET) 7119 SUM2=SUM2+YN(ISET) 7120 1610 CONTINUE 7121 CTOTAL=SUM1 7122 ANTOT=SUM2 7123 PBARG=CTOTAL/ANTOT 7124 ANBARG=ANTOT/ANUMSE 7125 CBARG=PBARG*ANBARG 7126C 7127 J=0 7128 DO1650ISET=1,NUMSET 7129C 7130 CI=Y(ISET) 7131 ANI=YN(ISET) 7132 NI=INT(ANI+0.5) 7133 IF(NI.LE.0)GOTO1650 7134C 7135 PI=CI/ANI 7136 TAGI=XIDTEM(ISET) 7137 YMID=CBARG 7138 VARCI=0.0 7139 IF(ANBARG.GT.0.0)VARCI=ANBARG*PBARG*(1.0-PBARG) 7140 SDCI=0.0 7141 IF(VARCI.GT.0.0)SDCI=SQRT(VARCI) 7142 YUPPER=YMID+3.0*SDCI 7143 YLOWER=YMID-3.0*SDCI 7144 IF(YLOWER.LT.0.0)YLOWER=0.0 7145C 7146 CALL DPCC3(ICASPL,J,CI,YMID,YLOWER,YUPPER, 7147 1 Y2,X2,D2,XIDTEM(ISET), 7148 1 YPREV,NPREV,IHIGH,XTAG,SIGMAE, 7149 1 CCLSL,CCUSL,CCTARG,ICONWC, 7150 1 IBUGG3,ISUBRO,IERROR) 7151C 7152 1650 CONTINUE 7153 ELSEIF(ICASPL.EQ.'UCC')THEN 7154C 7155C ********************************************************* 7156C ** STEP 5.7-- ** 7157C ** TREAT THE U CONTROL CHART CASE (POISSON) ** 7158C ** DEFECTIVE PER UNIT ** 7159C ** DEFECTIVE PER UNIT AREA ** 7160C ** NUMBER DEFECTIVE PER SUB-BATCH / LENGTH OR AREA ** 7161C ** THE INPUT IS A DUAL SERIES-- ** 7162C ** 1) NUMBER OF DEFECTIVE ITEMS IN THE SUBSAMPLE ** 7163C ** 2) LENGTH OR AREA OF THE ITEM ** 7164C ** THE CONFIDENCE BAND IS GOTTEN BY ASSUMING POISSON ** 7165C ********************************************************* 7166C 7167 ISTEPN='5.7' 7168 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2') 7169 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7170C 7171 XTAG=0.0 7172 SUM1=0.0 7173 SUM2=0.0 7174 DO1710ISET=1,NUMSET 7175 SUM1=SUM1+Y(ISET) 7176 SUM2=SUM2+YN(ISET) 7177 1710 CONTINUE 7178 CTOTAL=SUM1 7179 SIZTOT=SUM2 7180 CBARG=CTOTAL/SIZTOT 7181C 7182 J=0 7183 DO1750ISET=1,NUMSET 7184C 7185 CI=Y(ISET) 7186 SIZEI=YN(ISET) 7187 NSIZEI=INT(SIZEI+0.5) 7188 IF(NSIZEI.LE.0)GOTO1750 7189 STAT=-1.0 7190 IF(SIZEI.NE.0.0)STAT=CI/SIZEI 7191 YMID=CBARG 7192 VARCI=0.0 7193 IF(ANI.GT.0.0)VARCI=CBARG/SIZEI 7194 SDCI=0.0 7195 IF(VARCI.GT.0.0)SDCI=SQRT(VARCI) 7196 YUPPER=YMID+3.0*SDCI 7197 YLOWER=YMID-3.0*SDCI 7198 IF(YLOWER.LT.0.0)YLOWER=0.0 7199C 7200 CALL DPCC3(ICASPL,J,STAT,YMID,YLOWER,YUPPER, 7201 1 Y2,X2,D2,XIDTEM(ISET), 7202 1 YPREV,NPREV,IHIGH,XTAG,SIGMAE, 7203 1 CCLSL,CCUSL,CCTARG,ICONWC, 7204 1 IBUGG3,ISUBRO,IERROR) 7205C 7206 1750 CONTINUE 7207 ELSEIF(ICASPL.EQ.'CCC')THEN 7208C 7209C ******************************************************** 7210C ** STEP 5.8-- ** 7211C ** TREAT THE C CONTROL CHART CASE (POISSON) ** 7212C ** TOTAL NUMBER DEFECTIVE IN A BATCH (SUBSAMPLE) ** 7213C ** SUM OF DEFECTIVES IN A BATCH (SUBSAMPLE) ** 7214C ** THE INPUT IS USUALLY A SERIES OF INTEGERS ** 7215C ** THE VALUE WILL BE A NON-NEGATIVE INTEGER ** 7216C ** THE CONFIDENCE BAND IS GOTTEN BY ASSUMING POISSON ** 7217C ** NOTE--THE C CHART SHOULD BE USED ONLY WHEN ** 7218C ** THE SUBSAMPLE SIZE IS CONSTANT. ** 7219C ** FOR VARYING SUBSAMPLE SIZE, USE THE U CHART ** 7220C ** (ISHIKAWA, GUIDE TO QUALITY CONTROL, PAGE 77)* 7221C ******************************************************** 7222C 7223 ISTEPN='5.8' 7224 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2') 7225 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7226C 7227 XTAG=0.0 7228 SUM1=0.0 7229 SUM2=0.0 7230 ANUMSE=NUMSET 7231 DO1810ISET=1,NUMSET 7232 SUM1=SUM1+Y(ISET) 7233 IF(NUMV2.LE.2)SUM2=SUM2+1 7234 IF(NUMV2.GE.3)SUM2=SUM2+YN(ISET) 7235 1810 CONTINUE 7236 CTOTAL=SUM1 7237 CBARG=CTOTAL/ANUMSE 7238C 7239 J=0 7240 DO1850ISET=1,NUMSET 7241C 7242 CI=Y(ISET) 7243 SIZEI=YN(ISET) 7244 NSIZEI=INT(SIZEI+0.5) 7245 IF(NSIZEI.LE.0)GOTO1850 7246 YMID=CBARG 7247 VARCI=0.0 7248 IF(ANI.GT.0.0)VARCI=CBARG 7249 SDCI=0.0 7250 IF(VARCI.GT.0.0)SDCI=SQRT(VARCI) 7251 YUPPER=YMID+3.0*SDCI 7252 YLOWER=YMID-3.0*SDCI 7253 IF(YLOWER.LT.0.0)YLOWER=0.0 7254C 7255 CALL DPCC3(ICASPL,J,CI,YMID,YLOWER,YUPPER, 7256 1 Y2,X2,D2,XIDTEM(ISET), 7257 1 YPREV,NPREV,IHIGH,XTAG,SIGMAE, 7258 1 CCLSL,CCUSL,CCTARG,ICONWC, 7259 1 IBUGG3,ISUBRO,IERROR) 7260C 7261 1850 CONTINUE 7262 ELSEIF(ICASPL.EQ.'EWCC')THEN 7263C 7264C ***************************************** 7265C ** STEP 5.9-- ** 7266C ** TREAT THE EXPONETIALLY WEIGHTED ** 7267C ** CONTROL CHART CASE ** 7268C ***************************************** 7269C 7270 ISTEPN='5.9' 7271 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2') 7272 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7273C 7274 IF(P.GE.1.0 .AND. P.LE.100.)P=P/100. 7275 IF(P.LE.0.0 .OR. P.GE.1.0)THEN 7276 WRITE(ICOUT,999) 7277 CALL DPWRST('XXX','BUG ') 7278 WRITE(ICOUT,31) 7279 CALL DPWRST('XXX','BUG ') 7280 WRITE(ICOUT,1901) 7281 1901 FORMAT(' FOR THE EWMA CONTROL CHARTS, THE WEIGHTING', 7282 1 ' PARAMETER P MUST BE SPECIFIED') 7283 CALL DPWRST('XXX','BUG ') 7284 WRITE(ICOUT,1902) 7285 1902 FORMAT(' AND IN THE RANGE (0,1). IT IS TYPICALLY ', 7286 1 ' BETWEEN 0.1 AND 0.5 .') 7287 CALL DPWRST('XXX','BUG ') 7288 WRITE(ICOUT,1903) 7289 1903 FORMAT(' FOR EXAMPLE: LET P = 0.2 ') 7290 CALL DPWRST('XXX','BUG ') 7291 IERROR='YES' 7292 GOTO9000 7293 ENDIF 7294C 7295 J=0 7296 IF(CCTARG.NE.CPUMIN)THEN 7297 AK0=CCTARG 7298 ELSE 7299 AK0=XBARG 7300 ENDIF 7301 YMID=AK0 7302C 7303 DO1910ISET=1,NUMSET 7304C 7305 K=0 7306 XTAG=0.0 7307 DO1920I=1,N 7308 IF(X(I).EQ.XIDTEM(ISET))K=K+1 7309 IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I) 7310 IF(XHIGH(I).GE.0.5)XTAG=1.0 7311 1920 CONTINUE 7312 NI=K 7313 ANI=NI 7314C 7315 IF(NI.LT.1)THEN 7316 WRITE(ICOUT,999) 7317 CALL DPWRST('XXX','BUG ') 7318 WRITE(ICOUT,31) 7319 CALL DPWRST('XXX','BUG ') 7320 WRITE(ICOUT,1132) 7321 CALL DPWRST('XXX','BUG ') 7322 WRITE(ICOUT,1133)ISET,XIDTEM(ISET),NI 7323 CALL DPWRST('XXX','BUG ') 7324 IERROR='YES' 7325 GOTO9000 7326 ENDIF 7327C 7328 SUM=0.0 7329 DO1940I=1,NI 7330 SUM=SUM+TEMP(I) 7331 1940 CONTINUE 7332 XBARI=SUM/ANI 7333C 7334 AK1=P*XBARI + (1.0-P)*AK0 7335 IF(N.NE.NUMSET)THEN 7336 SADJ=SIGMAE*3.0902*SQRT(P/(ANI*(2.0-P))) 7337 ELSE 7338 IF(KWIDTH.LE.25)THEN 7339 SADJ=(RANGEM/E2(KWIDTH))*3.0902*SQRT(P/(ANI*(2.0-P))) 7340 ELSE 7341 SADJ=(RANGEM/E2(25))*3.0902*SQRT(P/(ANI*(2.0-P))) 7342 ENDIF 7343 ENDIF 7344 YUPPER=XBARG+SADJ 7345 YLOWER=XBARG-SADJ 7346C 7347 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN 7348 WRITE(ICOUT,1961)ISET,NI,ANI,XBARI 7349 1961 FORMAT('ISET,NI,ANI,XBARI = ',2I8,2G15.7) 7350 CALL DPWRST('XXX','BUG ') 7351 WRITE(ICOUT,1963)SDI,SIGMAE,SADJ,XBARG 7352 1963 FORMAT('SDI,SIGMAE,SADJ,XBARG = ',4G15.7) 7353 CALL DPWRST('XXX','BUG ') 7354 WRITE(ICOUT,1964)AK0,AK1,YLOWER,YUPPER 7355 1964 FORMAT('AK0,AK1,YLOWER,YUPPER = ',4G15.7) 7356 CALL DPWRST('XXX','BUG ') 7357 ENDIF 7358C 7359 CALL DPCC3(ICASPL,J,AK1,XBARG,YLOWER,YUPPER, 7360 1 Y2,X2,D2,XIDTEM(ISET), 7361 1 YPREV,NPREV,IHIGH,XTAG,SIGMAE, 7362 1 CCLSL,CCUSL,CCTARG,ICONWC, 7363 1 IBUGG3,ISUBRO,IERROR) 7364C 7365 AK0=AK1 7366C 7367 1910 CONTINUE 7368 ELSEIF(ICASPL.EQ.'MACC')THEN 7369C 7370C ***************************************** 7371C ** STEP 5.10-- ** 7372C ** TREAT THE MOVING AVERAGE ** 7373C ** CONTROL CHART CASE ** 7374C ***************************************** 7375C 7376 ISTEPN='5.10' 7377 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2') 7378 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7379C 7380 IF(KWIDTH.LT.2)KWIDTH=2 7381 IF(KWIDTH.GT.N-1)KWIDTH=N-1 7382 AK=REAL(KWIDTH) 7383 NBEF=KWIDTH/2 7384 NAFT=NBEF 7385 IF(MOD(KWIDTH,2).EQ.0)NAFT=NBEF-1 7386C 7387 J=0 7388 XTAG=0.0 7389C 7390C 2 CASES: 7391C 1) UNGROUPED DATA (N=NUMSET) 7392C 2) GROUPED DATA (N> NUMSET). FOR GROUPED DATA, EACH GROUP 7393C SHOULD HAVE AT LEAST 2 VALUES. 7394C 7395C UNGROUPED CASE 7396C 7397 IF(N.EQ.NUMSET)THEN 7398 DO2002ISET=1,N 7399 TEMP2(ISET)=Y(ISET) 7400 2002 CONTINUE 7401 ELSE 7402C 7403C GROUPED CASE 7404C 7405 DO2010ISET=1,NUMSET 7406C 7407 K=0 7408 DO2020I=1,N 7409 IF(X(I).EQ.XIDTEM(ISET))THEN 7410 K=K+1 7411 TEMP(K)=Y(I) 7412 ENDIF 7413 2020 CONTINUE 7414 NI=K 7415 ANI=NI 7416C 7417 IF(NI.LT.1)THEN 7418 WRITE(ICOUT,999) 7419 CALL DPWRST('XXX','BUG ') 7420 WRITE(ICOUT,31) 7421 CALL DPWRST('XXX','BUG ') 7422 WRITE(ICOUT,2032) 7423 2032 FORMAT('FOR MOVING AVERAGE, FOR SOME CLASS NI < 1') 7424 CALL DPWRST('XXX','BUG ') 7425 WRITE(ICOUT,1133)ISET,XIDTEM(ISET),NI 7426 CALL DPWRST('XXX','BUG ') 7427 IERROR='YES' 7428 GOTO9000 7429 ENDIF 7430C 7431 IF(NI.EQ.1)THEN 7432 TEMP2(ISET)=TEMP(1) 7433 ELSE 7434 SUM=0.0 7435 DO2040I=1,NI 7436 SUM=SUM+TEMP(I) 7437 2040 CONTINUE 7438 TEMP2(ISET)=SUM/ANI 7439 ENDIF 7440C 7441 2010 CONTINUE 7442 ENDIF 7443C 7444 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN 7445 WRITE(ICOUT,2061)ISET,NI,ANI,XBARI,XBARG 7446 2061 FORMAT('ISET,NI,ANI,XBARI,XBARG = ',2I8,3G15.7) 7447 CALL DPWRST('XXX','BUG ') 7448 WRITE(ICOUT,2063)SDI,SIGMAE,SADJ 7449 2063 FORMAT('SDI,SIGMAE,SADJ = ',3G15.7) 7450 CALL DPWRST('XXX','BUG ') 7451 WRITE(ICOUT,2064)AK0,AK1,YLOWER,YUPPER 7452 2064 FORMAT('AK0,AK1,YLOWER,YUPPER = ',4G15.7) 7453 CALL DPWRST('XXX','BUG ') 7454 ENDIF 7455C 7456 IF(1+NBEF.GT.NUMSET-NAFT)THEN 7457 WRITE(ICOUT,999) 7458 CALL DPWRST('XXX','BUG ') 7459 WRITE(ICOUT,31) 7460 CALL DPWRST('XXX','BUG ') 7461 WRITE(ICOUT,2065) 7462 2065 FORMAT(' THERE ARE NOT ENOUGH GROUPS TO FORM THE ', 7463 1 'MOVING AVERAGE PLOT.') 7464 CALL DPWRST('XXX','BUG ') 7465 WRITE(ICOUT,2268)KWIDTH,NUMSET 7466 CALL DPWRST('XXX','BUG ') 7467 IERROR='YES' 7468 GOTO9000 7469 ENDIF 7470C 7471 DO2090ISET=1,NUMSET 7472C 7473 IF(N.EQ.NUMSET)THEN 7474 XTAG=0.0 7475 IF(XHIGH(ISET).GE.0.5)XTAG=1.0 7476 ENDIF 7477C 7478 SUM=0.0 7479 ISTRT=ISET-NBEF 7480 ISTOP=ISET+NAFT 7481 DENOM=AK 7482 IF(ISET.LT.1+NBEF)THEN 7483 ISTRT=1 7484 DENOM=REAL(ISET+NAFT) 7485 ELSEIF(ISET.GT.NUMSET-NAFT)THEN 7486 ISTOP=NUMSET 7487 DENOM=REAL(NUMSET-(ISET-NBEF)+1) 7488 ENDIF 7489 DO2092II=ISTRT,ISTOP 7490 SUM=SUM+TEMP2(II) 7491 2092 CONTINUE 7492 YVAL=SUM/DENOM 7493 XVAL=XIDTEM(ISET) 7494 IF(NBEF.NE.NAFT)THEN 7495 IF(ISET.GT.1)THEN 7496 XVAL=(XIDTEM(ISET)+XIDTEM(ISET-1))/2.0 7497 ELSE 7498 XVAL=XIDTEM(1) 7499 ENDIF 7500 ENDIF 7501C 7502 IF(N.NE.NUMSET)THEN 7503 YUPPER=XBARG+3.09*SIGMAE/SQRT(AK) 7504 YLOWER=XBARG-3.09*SIGMAE/SQRT(AK) 7505 ELSE 7506 IF(KWIDTH.LE.25)THEN 7507 YUPPER=XBARG+3.09*RANGEM/(E2(KWIDTH)*SQRT(AK)) 7508 YLOWER=XBARG-3.09*RANGEM/(E2(KWIDTH)*SQRT(AK)) 7509 ELSE 7510 YUPPER=XBARG+3.09*RANGEM/(E2(25)*SQRT(AK)) 7511 YLOWER=XBARG-3.09*RANGEM/(E2(25)*SQRT(AK)) 7512 ENDIF 7513 ENDIF 7514C 7515 CALL DPCC3(ICASPL,J,YVAL,XBARG,YLOWER,YUPPER, 7516 1 Y2,X2,D2,XVAL, 7517 1 YPREV,NPREV,IHIGH,XTAG,SIGMAE, 7518 1 CCLSL,CCUSL,CCTARG,ICONWC, 7519 1 IBUGG3,ISUBRO,IERROR) 7520C 7521 2090 CONTINUE 7522 ELSEIF(ICASPL.EQ.'MRCC')THEN 7523C 7524C ***************************************** 7525C ** STEP 5.11-- ** 7526C ** TREAT THE MOVING RANGE ** 7527C ** CONTROL CHART CASE ** 7528C ***************************************** 7529C 7530 ISTEPN='5.11' 7531 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2') 7532 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7533C 7534 IF(KWIDTH.LT.2)KWIDTH=2 7535 IF(KWIDTH.GT.N-1)KWIDTH=N-1 7536 AK=REAL(KWIDTH) 7537 NBEF=KWIDTH/2 7538 NAFT=NBEF 7539 IF(MOD(KWIDTH,2).EQ.0)NAFT=NBEF-1 7540C 7541 J=0 7542 XTAG=0.0 7543C 7544C 2 CASES: 7545C 1) UNGROUPED DATA (N=NUMSET) 7546C 2) GROUPED DATA (N> NUMSET). FOR GROUPED DATA, EACH GROUP 7547C SHOULD HAVE AT LEAST 2 VALUES. 7548C 7549C UNGROUPED CASE 7550C 7551 IF(N.EQ.NUMSET)THEN 7552 DO2102ISET=1,N 7553 TEMP2(ISET)=Y(ISET) 7554 2102 CONTINUE 7555 ELSE 7556C 7557C GROUPED CASE 7558C 7559 DO2110ISET=1,NUMSET 7560C 7561 K=0 7562 DO2120I=1,N 7563 IF(X(I).EQ.XIDTEM(ISET))THEN 7564 K=K+1 7565 TEMP(K)=Y(I) 7566 ENDIF 7567 2120 CONTINUE 7568 NI=K 7569 ANI=NI 7570C 7571 IF(NI.LT.2)THEN 7572 WRITE(ICOUT,999) 7573 CALL DPWRST('XXX','BUG ') 7574 WRITE(ICOUT,31) 7575 CALL DPWRST('XXX','BUG ') 7576 WRITE(ICOUT,2132) 7577 2132 FORMAT('FOR MOVING RANGE, FOR SOME CLASS NI < 2') 7578 CALL DPWRST('XXX','BUG ') 7579 WRITE(ICOUT,1133)ISET,XIDTEM(ISET),NI 7580 CALL DPWRST('XXX','BUG ') 7581 IERROR='YES' 7582 GOTO9000 7583 ENDIF 7584C 7585 XTMIN=TEMP(1) 7586 XTMAX=TEMP(1) 7587 DO2140I=1,NI 7588 IF(TEMP(I).LT.XTMIN)XTMIN=TEMP(I) 7589 IF(TEMP(I).GT.XTMAX)XTMAX=TEMP(I) 7590 2140 CONTINUE 7591 TEMP2(ISET)=XTMAX-XTMIN 7592 2110 CONTINUE 7593 ENDIF 7594C 7595 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN 7596 WRITE(ICOUT,2161)ISET,NI,ANI,XBARI,XBARG 7597 2161 FORMAT('ISET,NI,ANI,XBARI,XBARG = ',2I8,3G15.7) 7598 CALL DPWRST('XXX','BUG ') 7599 WRITE(ICOUT,2163)SDI,SIGMAE,SADJ 7600 2163 FORMAT('SDI,SIGMAE,SADJ = ',3G15.7) 7601 CALL DPWRST('XXX','BUG ') 7602 WRITE(ICOUT,2164)AK0,AK1,YLOWER,YUPPER 7603 2164 FORMAT('AK0,AK1,YLOWER,YUPPER = ',4G15.7) 7604 CALL DPWRST('XXX','BUG ') 7605 ENDIF 7606C 7607 IF(1+NBEF.GT.NUMSET-NAFT)THEN 7608 WRITE(ICOUT,999) 7609 CALL DPWRST('XXX','BUG ') 7610 WRITE(ICOUT,31) 7611 CALL DPWRST('XXX','BUG ') 7612 WRITE(ICOUT,2165) 7613 2165 FORMAT(' THERE ARE NOT ENOUGH GROUPS TO FORM THE ', 7614 1 'MOVING RANGE PLOT.') 7615 CALL DPWRST('XXX','BUG ') 7616 WRITE(ICOUT,2268)KWIDTH,NUMSET 7617 CALL DPWRST('XXX','BUG ') 7618 IERROR='YES' 7619 GOTO9000 7620 ENDIF 7621C 7622 SUM2=0.0 7623 NUMRAN=0 7624 DO2190ISET=1,NUMSET 7625C 7626C GROUPED DATA 7627C 7628 IF(N.NE.NUMSET)THEN 7629 SUM=0.0 7630 ISTRT=ISET-NBEF 7631 ISTOP=ISET+NAFT 7632 DENOM=AK 7633 IF(ISET.LT.1+NBEF)THEN 7634 ISTRT=1 7635 DENOM=REAL(ISET+NAFT) 7636 ELSEIF(ISET.GT.NUMSET-NAFT)THEN 7637 ISTOP=NUMSET 7638 DENOM=REAL(NUMSET-(ISET-NBEF)+1) 7639 ENDIF 7640 DO2192II=ISTRT,ISTOP 7641 SUM=SUM+TEMP2(II) 7642 2192 CONTINUE 7643 YVAL=SUM/DENOM 7644C 7645C UNGROUPED DATA 7646C 7647 ELSE 7648 ISTRT=ISET-NBEF 7649 ISTOP=ISET+NAFT 7650 IF(ISET.LT.1+NBEF)THEN 7651 ISTRT=1 7652 ELSEIF(ISET.GT.NUMSET-NAFT)THEN 7653 ISTOP=NUMSET 7654 ENDIF 7655 XTMIN=TEMP2(ISTRT) 7656 XTMMAX=TEMP2(ISTRT) 7657 DO2182II=ISTRT,ISTOP 7658 IF(TEMP2(II).LT.XTMIN)XTMIN=TEMP2(II) 7659 IF(TEMP2(II).GT.XTMAX)XTMAX=TEMP2(II) 7660 2182 CONTINUE 7661 YVAL=XTMAX-XTMIN 7662 XTAG=0.0 7663 IF(XHIGH(ISET).GE.0.5)XTAG=1.0 7664 ENDIF 7665 XVAL=XIDTEM(ISET) 7666 IF(NBEF.NE.NAFT)XVAL=(XIDTEM(ISET)+XIDTEM(ISET-1))/2.0 7667 IF(KWIDTH.LE.25)THEN 7668 YUPPER=D4(KWIDTH)*RANGEM 7669 YLOWER=D3(KWIDTH)*RANGEM 7670 ELSE 7671 YUPPER=(1.0+3.0*D4FACT/SQRT(2.0*(REAL(KWIDTH)-1.0)))*RANGEM 7672 1 /E2(25) 7673 YLOWER=(1.0-3.0*D3FACT/SQRT(2.0*(REAL(KWIDTH)-1.0)))*RANGEM 7674 1 /E2(25) 7675 ENDIF 7676 IF(YLOWER.LT.0.0)YLOWER=0.0 7677C 7678 CALL DPCC3(ICASPL,J,YVAL,RANGEM,YLOWER,YUPPER, 7679 1 Y2,X2,D2,XVAL, 7680 1 YPREV,NPREV,IHIGH,XTAG,RANGEM, 7681 1 CCLSL,CCUSL,CCTARG,ICONWC, 7682 1 IBUGG3,ISUBRO,IERROR) 7683C 7684 2190 CONTINUE 7685 ELSEIF(ICASPL.EQ.'MSCC')THEN 7686C 7687C ***************************************** 7688C ** STEP 5.12-- ** 7689C ** TREAT THE MOVING STANDARD DEVIATION** 7690C ** CONTROL CHART CASE ** 7691C ***************************************** 7692C 7693 ISTEPN='5.12' 7694 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2') 7695 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7696C 7697 IF(KWIDTH.LT.2)KWIDTH=2 7698 IF(KWIDTH.GT.N-1)KWIDTH=N-1 7699 AK=REAL(KWIDTH) 7700 NBEF=KWIDTH/2 7701 NAFT=NBEF 7702 IF(MOD(KWIDTH,2).EQ.0)NAFT=NBEF-1 7703C 7704 J=0 7705 XTAG=0.0 7706C 7707C 2 CASES: 7708C 1) UNGROUPED DATA (N=NUMSET) 7709C 2) GROUPED DATA (N> NUMSET). FOR GROUPED DATA, EACH GROUP 7710C SHOULD HAVE AT LEAST 2 VALUES. 7711C 7712C UNGROUPED CASE 7713C 7714 IF(N.EQ.NUMSET)THEN 7715 DO2202ISET=1,N 7716 TEMP2(ISET)=Y(ISET) 7717 2202 CONTINUE 7718 ELSE 7719C 7720C GROUPED CASE 7721C 7722 DO2210ISET=1,NUMSET 7723C 7724 K=0 7725 XTAG=0.0 7726 DO2220I=1,N 7727 IF(X(I).EQ.XIDTEM(ISET))K=K+1 7728 IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I) 7729 2220 CONTINUE 7730 NI=K 7731 ANI=NI 7732C 7733 IF(NI.LT.2)THEN 7734 WRITE(ICOUT,999) 7735 CALL DPWRST('XXX','BUG ') 7736 WRITE(ICOUT,31) 7737 CALL DPWRST('XXX','BUG ') 7738 WRITE(ICOUT,2232) 7739 2232 FORMAT('FOR MOVING STANDARD DEVIATION, FOR SOME CLASS ', 7740 1 'NI < 2') 7741 CALL DPWRST('XXX','BUG ') 7742 WRITE(ICOUT,1133)ISET,XIDTEM(ISET),NI 7743 CALL DPWRST('XXX','BUG ') 7744 IERROR='YES' 7745 GOTO9000 7746 ENDIF 7747C 7748 SUM1=0.0 7749 DO2240I=1,NI 7750 SUM1=SUM1+TEMP(I) 7751 2240 CONTINUE 7752 XMEAN=SUM1/ANI 7753 SUM1=0.0 7754 DO2242I=1,NI 7755 SUM1=SUM1+(TEMP(I)-XMEAN)**2 7756 2242 CONTINUE 7757 SD=SQRT(SUM1/(ANI-1.0)) 7758 TEMP2(ISET)=SD 7759 2210 CONTINUE 7760 ENDIF 7761C 7762 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN 7763 WRITE(ICOUT,2261)ISET,NI,ANI,XBARI,XBARG 7764 2261 FORMAT('ISET,NI,ANI,XBARI,XBARG = ',2I8,3G15.7) 7765 CALL DPWRST('XXX','BUG ') 7766 WRITE(ICOUT,2263)SD,SIGMAE,SADJ 7767 2263 FORMAT('SD,SIGMAE,SADJ = ',3G15.7) 7768 CALL DPWRST('XXX','BUG ') 7769 WRITE(ICOUT,2264)AK0,AK1,YLOWER,YUPPER 7770 2264 FORMAT('AK0,AK1,YLOWER,YUPPER = ',4G15.7) 7771 CALL DPWRST('XXX','BUG ') 7772 ENDIF 7773C 7774 IF(1+NBEF.GT.NUMSET-NAFT)THEN 7775 WRITE(ICOUT,999) 7776 CALL DPWRST('XXX','BUG ') 7777 WRITE(ICOUT,31) 7778 CALL DPWRST('XXX','BUG ') 7779 WRITE(ICOUT,2265) 7780 2265 FORMAT(' THERE ARE NOT ENOUGH GROUPS TO FORM THE ', 7781 1 'MOVING STANDARD DEVAITION PLOT.') 7782 CALL DPWRST('XXX','BUG ') 7783 WRITE(ICOUT,2268)KWIDTH,NUMSET 7784 2268 FORMAT(' THE FILTER WIDTH IS ',I5,' AND THE NUMBER OF ', 7785 1 'GROUPS IS ',I5,'.') 7786 CALL DPWRST('XXX','BUG ') 7787 IERROR='YES' 7788 GOTO9000 7789 ENDIF 7790C 7791 SUM2=0.0 7792 NUMSD=0 7793 DO2290ISET=1,NUMSET 7794C 7795C GROUPED DATA 7796C 7797 IF(N.NE.NUMSET)THEN 7798 SUM=0.0 7799 ISTRT=ISET-NBEF 7800 ISTOP=ISET+NAFT 7801 DENOM=AK 7802 IF(ISET.LT.1+NBEF)THEN 7803 ISTRT=1 7804 DENOM=REAL(ISET+NAFT) 7805 ELSEIF(ISET.GT.NUMSET-NAFT)THEN 7806 ISTOP=NUMSET 7807 DENOM=REAL(NUMSET-(ISET-NBEF)+1) 7808 ENDIF 7809 DO2292II=ISTRT,ISTOP 7810 SUM=SUM+TEMP2(II) 7811 2292 CONTINUE 7812 YVAL=SUM/DENOM 7813C 7814C UNGROUPED DATA 7815C 7816 ELSE 7817 ISTRT=ISET-NBEF 7818 ISTOP=ISET+NAFT 7819 IF(ISET.LT.1+NBEF)THEN 7820 ISTRT=1 7821 ELSEIF(ISET.GT.NUMSET-NAFT)THEN 7822 ISTOP=NUMSET 7823 ENDIF 7824 SUM1=0.0 7825 ICOUNT=0 7826 DO2282II=ISTRT,ISTOP 7827 ICOUNT=ICOUNT+1 7828 SUM1=SUM1+TEMP2(II) 7829 2282 CONTINUE 7830 XMEAN=SUM1/REAL(ICOUNT) 7831 SUM1=0.0 7832 DO2283II=ISTRT,ISTOP 7833 SUM1=SUM1+(TEMP2(II)-XMEAN)**2 7834 2283 CONTINUE 7835 IF(ICOUNT.LT.2)GOTO2290 7836 YVAL=SQRT(SUM1/REAL(ICOUNT-1)) 7837 XTAG=0.0 7838 IF(XHIGH(ISET).GE.0.5)XTAG=1.0 7839 ENDIF 7840C 7841 XVAL=XIDTEM(ISET) 7842 IF(NBEF.NE.NAFT)XVAL=(XIDTEM(ISET)+XIDTEM(ISET-1))/2.0 7843 IF(KWIDTH.LE.25)THEN 7844 YUPPER=B4(KWIDTH)*SDM 7845 YLOWER=B3(KWIDTH)*SDM 7846 ELSE 7847 YUPPER=(1.0+3.0/SQRT(2.0*(REAL(KWIDTH)-1.0)))*SDM 7848 YLOWER=(1.0-3.0/SQRT(2.0*(REAL(KWIDTH)-1.0)))*SDM 7849 ENDIF 7850 IF(YLOWER.LT.0.0)YLOWER=0.0 7851C 7852 CALL DPCC3(ICASPL,J,YVAL,SDM,YLOWER,YUPPER, 7853 1 Y2,X2,D2,XVAL, 7854 1 YPREV,NPREV,IHIGH,XTAG,SDM, 7855 1 CCLSL,CCUSL,CCTARG,ICONWC, 7856 1 IBUGG3,ISUBRO,IERROR) 7857C 7858 2290 CONTINUE 7859C 7860 ELSEIF(ICASPL.EQ.'1352')THEN 7861C 7862C ********************************************** 7863C ** STEP 5.13-- ** 7864C ** TREAT THE ISO 13528 CONTROL CHART CASE ** 7865C ********************************************** 7866C 7867C THE ISO 13528 CONTROL CHART IS BASED ON THE FOLLOWING: 7868C 7869C 1) USE A Z-SCORE AS THE RESPONSE. SINCE THE STANDARD 7870C PROVIDES FOR VARIOUS WAYS TO COMPUTE THE Z-SCORE, 7871C ASSUME THAT THE RESPONSE IS ALREADY IN Z-SCORE FORMAT. 7872C 7873C 2) IF THERE IS REPLICATION, COMPUTE A MEAN FOR EACH 7874C GROUP. IF THERE IS NO REPLICATION, THEN JUST USE 7875C THE DATA VALUE. UNLIKE THE STANDARD MEAN CONTROL 7876C CHART, WE DO NOT AVERAGE OVER SEVERAL VALUES FOR 7877C INDIVIDUAL OBSERVATIONS. 7878C 7879C 3) CONTROL LIMITS ARE AT +/-2 AND +/-3. 7880C 7881C 4) ONE VERSION OF THIS PLOT ALSO PLOTS THE RAW DATA 7882C VALUES. 7883C 7884C 5) THE MATERIAL-ID CAN BE TREATED AS A "HIGHLIGHTING" 7885C VARIABLE. THEREFORE, LET THE HIGHLIGHT VARIABLE 7886C SPECIFY THE MATERIAL ID RATHER THAN JUST 0/1. 7887C 7888 ISTEPN='5.13' 7889 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2') 7890 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7891C 7892 J=0 7893 ICNT=0 7894 DO2310ISET=1,NUMSET 7895C 7896 K=0 7897 DO2320I=1,N 7898 IF(X(I).EQ.XIDTEM(ISET))THEN 7899 K=K+1 7900 TEMP(K)=Y(I) 7901 TEMP2(K)=XHIGH(I) 7902 ENDIF 7903 2320 CONTINUE 7904 NI=K 7905 ANI=NI 7906C 7907 IF(NI.LT.1)THEN 7908 WRITE(ICOUT,999) 7909 CALL DPWRST('XXX','BUG ') 7910 WRITE(ICOUT,31) 7911 CALL DPWRST('XXX','BUG ') 7912 WRITE(ICOUT,1132) 7913 CALL DPWRST('XXX','BUG ') 7914 WRITE(ICOUT,1133)ISET,XIDTEM(ISET),NI 7915 CALL DPWRST('XXX','BUG ') 7916 IERROR='YES' 7917 GOTO9000 7918 ENDIF 7919C 7920 SUM=0.0 7921 DO2340I=1,NI 7922 SUM=SUM+TEMP(I) 7923 2340 CONTINUE 7924 STAT=SUM/ANI 7925C 7926 ICNT=1 7927 J=J+1 7928 Y2(J)=STAT 7929 X2(J)=XIDTEM(ISET) 7930 D2(J)=REAL(ICNT) 7931C 7932 ICNT=ICNT+1 7933 J=J+1 7934 Y2(J)=0.0 7935 X2(J)=XIDTEM(ISET) 7936 D2(J)=REAL(ICNT) 7937C 7938 ICNT=ICNT+1 7939 J=J+1 7940 Y2(J)=2.0 7941 X2(J)=XIDTEM(ISET) 7942 D2(J)=REAL(ICNT) 7943C 7944 ICNT=ICNT+1 7945 J=J+1 7946 Y2(J)=-2.0 7947 X2(J)=XIDTEM(ISET) 7948 D2(J)=REAL(ICNT) 7949C 7950 ICNT=ICNT+1 7951 J=J+1 7952 Y2(J)=3.0 7953 X2(J)=XIDTEM(ISET) 7954 D2(J)=REAL(ICNT) 7955C 7956 ICNT=ICNT+1 7957 J=J+1 7958 Y2(J)=-3.0 7959 X2(J)=XIDTEM(ISET) 7960 D2(J)=REAL(ICNT) 7961C 7962 ICNT=ICNT+1 7963 DO2350II=1,NI 7964 J=J+1 7965 Y2(J)=TEMP(II) 7966 X2(J)=XIDTEM(ISET) 7967 IF(IHIGH.EQ.'ON')THEN 7968 D2(J)=REAL(ICNT) + TEMP2(II) - 1.0 7969 ELSE 7970 D2(J)=REAL(ICNT) 7971 ENDIF 7972 2350 CONTINUE 7973C 7974 2310 CONTINUE 7975 ELSEIF(ICASPL.EQ.'1CUS')THEN 7976C 7977C **************************************************** 7978C ** STEP 5.14-- ** 7979C ** TREAT THE ISO 13528 CUSUM CONTROL CHART CASE ** 7980C **************************************************** 7981C 7982C THE ISO 13528 CUSUM CONTROL CHART IS BASED ON THE FOLLOWING: 7983C 7984C 1) USE A Z-SCORE AS THE RESPONSE. SINCE THE STANDARD 7985C PROVIDES FOR VARIOUS WAYS TO COMPUTE THE Z-SCORE, 7986C ASSUME THAT THE RESPONSE IS ALREADY IN Z-SCORE FORMAT. 7987C 7988C 2) IF THERE IS REPLICATION, COMPUTE A MEAN FOR EACH 7989C GROUP. IF THERE IS NO REPLICATION, THEN JUST USE 7990C THE DATA VALUE. 7991C 7992C 3) SIMPLY PLOT THE CUMULATIVE SUM OF THE Z-SCORES. 7993C THE TARGET VALUE IS ZERO. 7994C 7995C 4) THERE ARE NO CONTROL LIMITS FOR THIS PLOT. 7996C 7997C 5) THE MATERIAL-ID CAN BE TREATED AS A "HIGHLIGHTING" 7998C VARIABLE. THEREFORE, LET THE HIGHLIGHT VARIABLE 7999C SPECIFY THE MATERIAL ID RATHER THAN JUST 0/1. 8000C 8001 ISTEPN='5.13' 8002 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PCC2') 8003 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8004C 8005 J=0 8006 ICNT=0 8007 CUSUM=0.0 8008 DO2410ISET=1,NUMSET 8009C 8010 K=0 8011 DO2420I=1,N 8012 IF(X(I).EQ.XIDTEM(ISET))THEN 8013 K=K+1 8014 TEMP(K)=Y(I) 8015 TEMP2(K)=XHIGH(I) 8016 ENDIF 8017 2420 CONTINUE 8018 NI=K 8019 ANI=NI 8020C 8021 IF(NI.LT.1)THEN 8022 WRITE(ICOUT,999) 8023 CALL DPWRST('XXX','BUG ') 8024 WRITE(ICOUT,31) 8025 CALL DPWRST('XXX','BUG ') 8026 WRITE(ICOUT,1132) 8027 CALL DPWRST('XXX','BUG ') 8028 WRITE(ICOUT,1133)ISET,XIDTEM(ISET),NI 8029 CALL DPWRST('XXX','BUG ') 8030 IERROR='YES' 8031 GOTO9000 8032 ENDIF 8033C 8034 SUM=0.0 8035 DO2440I=1,NI 8036 SUM=SUM+TEMP(I) 8037 2440 CONTINUE 8038 CUSUM=CUSUM + (SUM/ANI) 8039C 8040 ICNT=1 8041 J=J+1 8042 Y2(J)=CUSUM 8043 X2(J)=XIDTEM(ISET) 8044 D2(J)=REAL(ICNT) 8045C 8046 ICNT=ICNT+1 8047 J=J+1 8048 Y2(J)=0.0 8049 X2(J)=XIDTEM(ISET) 8050 D2(J)=REAL(ICNT) 8051C 8052 2410 CONTINUE 8053 ELSE 8054 WRITE(ICOUT,999) 8055 CALL DPWRST('XXX','BUG ') 8056 WRITE(ICOUT,31) 8057 CALL DPWRST('XXX','BUG ') 8058 WRITE(ICOUT,1053) 8059 1053 FORMAT(' ICASPL NOT EQUAL ONE OF THE ALLOWABLE 12--') 8060 CALL DPWRST('XXX','BUG ') 8061 WRITE(ICOUT,1054) 8062 1054 FORMAT(' MECC, SDCC, RACC, CSCC, PCC, PNCC, UCC, CCC, ', 8063 1 'EWMA, MACC, MSCC, OR MRCC.') 8064 CALL DPWRST('XXX','BUG ') 8065 WRITE(ICOUT,1056)ICASPL 8066 1056 FORMAT(' ICASPL = ',A4) 8067 CALL DPWRST('XXX','BUG ') 8068 IERROR='YES' 8069 GOTO9000 8070 ENDIF 8071C 8072 N2=J 8073 NPLOTV=3 8074C 8075C ****************** 8076C ** STEP 90-- ** 8077C ** EXIT ** 8078C ****************** 8079C 8080 9000 CONTINUE 8081 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC2')THEN 8082 WRITE(ICOUT,999) 8083 CALL DPWRST('XXX','BUG ') 8084 WRITE(ICOUT,9011) 8085 9011 FORMAT('***** AT THE END OF DPCC2--') 8086 CALL DPWRST('XXX','BUG ') 8087 WRITE(ICOUT,9012)IERROR,ICASPL,N,NUMSET,N2 8088 9012 FORMAT('IERROR,ICASPL,N,NUMSET,N2 = ',2(A4,2X),3I8) 8089 CALL DPWRST('XXX','BUG ') 8090 WRITE(ICOUT,9013)NUMV2,ISIZE 8091 9013 FORMAT('NUMV2,ISIZE = ',2I8) 8092 CALL DPWRST('XXX','BUG ') 8093 WRITE(ICOUT,9014)AN,XBARG,SDG,RANGEG 8094 9014 FORMAT('AN,XBARG,SDG,RANGEG = ',4G15.7) 8095 CALL DPWRST('XXX','BUG ') 8096 WRITE(ICOUT,9015)ANUMSE,SIGMAE,RANGEE 8097 9015 FORMAT('ANUMSE,SIGMAE,RANGEE = ',3G15.7) 8098 CALL DPWRST('XXX','BUG ') 8099 DO9020I=1,N2 8100 WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I) 8101 9021 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,3G15.7) 8102 CALL DPWRST('XXX','BUG ') 8103 9020 CONTINUE 8104 ENDIF 8105C 8106 RETURN 8107 END 8108 SUBROUTINE DPCC3(ICASPL,J,STAT,YMID,YLOWER,YUPPER, 8109 1 Y2,X2,D2,XVAL, 8110 1 YPREV,NPREV,IHIGH,XHIGH,SIGMA, 8111 1 CCLSL,CCUSL,CCTARG,ICONWC, 8112 1 IBUGG3,ISUBRO,IERROR) 8113C 8114C PURPOSE-UTIITY ROUTINE USED BY DPCC. 8115C WRITTEN BY--JAMES J. FILLIBEN 8116C STATISTICAL ENGINEERING DIVISION 8117C INFORMATION TECHNOLOGY LABORATORY 8118C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 8119C GAITHERSBURG, MD 20899-8980 8120C PHONE--301-975-2899 8121C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 8122C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 8123C LANGUAGE--ANSI FORTRAN (1977) 8124C VERSION NUMBER--2012/1 8125C ORIGINAL VERSION--JANUARY 2012. EXTRACTED FROM DPCC2 8126C 8127C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 8128C 8129 CHARACTER*4 ICASPL 8130 CHARACTER*4 ICONWC 8131 CHARACTER*4 IHIGH 8132 CHARACTER*4 IBUGG3 8133 CHARACTER*4 ISUBRO 8134 CHARACTER*4 IERROR 8135C 8136C--------------------------------------------------------------------- 8137C 8138 DIMENSION Y2(*) 8139 DIMENSION X2(*) 8140 DIMENSION D2(*) 8141 DIMENSION YPREV(*) 8142C 8143C--------------------------------------------------------------------- 8144C 8145 INCLUDE 'DPCOP2.INC' 8146C 8147C-----START POINT----------------------------------------------------- 8148C 8149 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC3')THEN 8150 WRITE(ICOUT,999) 8151 999 FORMAT(1X) 8152 CALL DPWRST('XXX','BUG ') 8153 WRITE(ICOUT,70) 8154 70 FORMAT('AT THE BEGINNING OF DPCC3--') 8155 CALL DPWRST('XXX','BUG ') 8156 WRITE(ICOUT,71)J,STAT,XVAL,ICASPL,ICONWC,ISUBRO 8157 71 FORMAT('J,STAT,XVAL,ICASPL,ICONWC,ISUBRO = ',I8,2G15.7,3(2X,A4)) 8158 CALL DPWRST('XXX','BUG ') 8159 WRITE(ICOUT,74)IHIGH,XHIGH,SIGMA 8160 74 FORMAT('IHIGH,XHIGH,SIGMA = ',A4,2X,2G15.7) 8161 CALL DPWRST('XXX','BUG ') 8162 ENDIF 8163C 8164 IERROR='NO' 8165C 8166 ICNT=1 8167 J=J+1 8168 Y2(J)=STAT 8169 X2(J)=XVAL 8170 D2(J)=REAL(ICNT) 8171C 8172C IF "ISO 13528" CONTROL LIMITS REQUESTED, SPECIFY LIMITS 8173C AT +/-2 AND +/-3. THESE ONLY APPLY TO "MEAN CONTROL" 8174C CHART. 8175C 8176 IF(ICONWC.EQ.'ISO' .AND. 8177 1 (ICASPL.EQ.'MECC' .OR. ICASPL.EQ.'MACC'))THEN 8178C 8179 ICNT=ICNT+1 8180 J=J+1 8181 Y2(J)=0.0 8182 X2(J)=XVAL 8183 D2(J)=REAL(ICNT) 8184C 8185 ICNT=ICNT+1 8186 J=J+1 8187 Y2(J)=2.0 8188 X2(J)=XVAL 8189 D2(J)=REAL(ICNT) 8190C 8191 ICNT=ICNT+1 8192 J=J+1 8193 Y2(J)=-2.0 8194 X2(J)=XVAL 8195 D2(J)=REAL(ICNT) 8196C 8197 ICNT=ICNT+1 8198 J=J+1 8199 Y2(J)=3.0 8200 X2(J)=XVAL 8201 D2(J)=REAL(ICNT) 8202C 8203 ICNT=ICNT+1 8204 J=J+1 8205 Y2(J)=-3.0 8206 X2(J)=XVAL 8207 D2(J)=REAL(ICNT) 8208C 8209 ELSE 8210 ICNT=ICNT+1 8211 J=J+1 8212 Y2(J)=YMID 8213 X2(J)=XVAL 8214 D2(J)=REAL(ICNT) 8215C 8216 ICNT=ICNT+1 8217 J=J+1 8218 Y2(J)=YUPPER 8219 X2(J)=XVAL 8220 D2(J)=REAL(ICNT) 8221C 8222 ICNT=ICNT+1 8223 J=J+1 8224 Y2(J)=YLOWER 8225 X2(J)=XVAL 8226 D2(J)=REAL(ICNT) 8227C 8228C IMPLEMENT WECO (WESTERN ELECTRIC) RULES FOR MEAN, SD, 8229C AND RANGE CONTROL CHARTS. THESE ARE TYPICALLY USED IN 8230C ADDITION TO THE STANDARD CONTROL LIMITS. ONE DRAWBACK TO 8231C THESE RULES IS THAT THEY CAN LEAD TO AN EXCESSIVE NUMBER 8232C OF FALSE POSITIVES. 8233C 8234C THESE RULES FLAG THE FOLLOWING (THESE ARE LISTED FOR 8235C POINTS ABOVE THE CENTER LINE (I.E., YMID). THERE ARE 8236C SIMILAR RULES FOR POINTS BELOW THE CENTER LINE. 8237C 8238C 1) ANY POINT > 3*SIGMA 8239C 2) 2 OUT OF LAST 3 POINTS > 2*SIGMA 8240C 3) 4 OUT OF LAST 5 POINTS > 1*SIGMA 8241C 4) 8 CONSECUTIVE POINTS ABOVE CENTER LINE 8242C 8243C FOR RULE 1, WE DO NOT NEED ANY PAST DATA. FOR THE OTHERS, 8244C PASS IN AN ARRAY THAT CONTAINS THE PREVIOUS DATA. 8245C 8246 IF(ICONWC.EQ.'WECO' .AND. 8247 1 (ICASPL.EQ.'MECC' .OR. ICASPL.EQ.'MACC' .OR. 8248 1 ICASPL.EQ.'RACC' .OR. ICASPL.EQ.'MRCC' .OR. 8249 1 ICASPL.EQ.'SDCC' .OR. ICASPL.EQ.'MSCC'))THEN 8250C 8251 ITAG=0 8252 NPREV=NPREV+1 8253 YPREV(NPREV)=STAT 8254C 8255 IF(STAT.GT.YMID + 3.0*SIGMA)THEN 8256 ITAG=1 8257 ELSEIF(STAT.LT.YMID - 3.0*SIGMA)THEN 8258 ITAG=1 8259 ENDIF 8260C 8261 IF(NPREV.GE.3)THEN 8262 ISTRT=NPREV-2 8263 ICNT1=0 8264 ICNT2=0 8265 DO1020I=ISTRT,NPREV 8266 IF(YPREV(I).GT.YMID + 2.0*SIGMA)ICNT1=ICNT1+1 8267 IF(YPREV(I).LT.YMID - 2.0*SIGMA)ICNT2=ICNT2+1 8268 1020 CONTINUE 8269 IF(ICNT1.GE.2 .OR. ICNT2.GE.2)ITAG=1 8270 ENDIF 8271C 8272 IF(NPREV.GE.5)THEN 8273 ISTRT=NPREV-4 8274 ICNT1=0 8275 ICNT2=0 8276 DO1030I=ISTRT,NPREV 8277 IF(YPREV(I).GT.YMID + SIGMA)ICNT1=ICNT1+1 8278 IF(YPREV(I).LT.YMID - SIGMA)ICNT2=ICNT2+1 8279 1030 CONTINUE 8280 IF(ICNT1.GE.2 .OR. ICNT2.GE.2)ITAG=1 8281 ENDIF 8282C 8283 IF(NPREV.GE.8)THEN 8284 ISTRT=NPREV-7 8285 IFLAG=1 8286 IF(STAT.GT.YMID)THEN 8287 DO1040I=ISTRT,NPREV-1 8288 IF(YPREV(I).LT.YMID)IFLAG=0 8289 1040 CONTINUE 8290 ELSEIF(STAT.LT.YMID)THEN 8291 DO1045I=ISTRT,NPREV-1 8292 IF(YPREV(I).GT.YMID)IFLAG=0 8293 1045 CONTINUE 8294 ENDIF 8295 IF(IFLAG.EQ.1)ITAG=1 8296 ENDIF 8297C 8298 IF(ITAG.EQ.1)THEN 8299 ICNT=ICNT+1 8300 J=J+1 8301 Y2(J)=STAT 8302 X2(J)=XVAL 8303 D2(J)=REAL(ICNT) 8304 ENDIF 8305 ENDIF 8306C 8307 ENDIF 8308C 8309 IF(CCTARG.NE.CPUMIN)THEN 8310 ICNT=ICNT+1 8311 J=J+1 8312 Y2(J)=CCTARG 8313 X2(J)=XVAL 8314 D2(J)=REAL(ICNT) 8315 ENDIF 8316C 8317 IF(CCUSL.NE.CPUMIN)THEN 8318 ICNT=ICNT+1 8319 J=J+1 8320 Y2(J)=CCUSL 8321 X2(J)=XVAL 8322 D2(J)=REAL(ICNT) 8323 ENDIF 8324C 8325 IF(CCLSL.NE.CPUMIN)THEN 8326 ICNT=ICNT+1 8327 J=J+1 8328 Y2(J)=CCLSL 8329 X2(J)=XVAL 8330 D2(J)=REAL(ICNT) 8331 ENDIF 8332C 8333 IF(IHIGH.EQ.'ON' .AND. XHIGH.GE.0.5)THEN 8334 ICNT=ICNT+1 8335 J=J+1 8336 Y2(J)=STAT 8337 X2(J)=XVAL 8338 D2(J)=REAL(ICNT) 8339 ENDIF 8340C 8341C ****************** 8342C ** STEP 90-- ** 8343C ** EXIT ** 8344C ****************** 8345C 8346 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCC3')THEN 8347 WRITE(ICOUT,999) 8348 CALL DPWRST('XXX','BUG ') 8349 WRITE(ICOUT,9011) 8350 9011 FORMAT('***** AT THE END OF DPCC3--') 8351 CALL DPWRST('XXX','BUG ') 8352 ENDIF 8353C 8354 RETURN 8355 END 8356 SUBROUTINE DPCD(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 8357 1 IANGLU,DEMOFR,DEMODF, 8358 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 8359C 8360C PURPOSE--GENERATE ONE OF THE FOLLOWING 2 8361C COMPLEX DEMODULATION PLOTS-- 8362C 1) AMPLITUDE; 8363C 2) PHASE; 8364C WRITTEN BY--JAMES J. FILLIBEN 8365C STATISTICAL ENGINEERING DIVISION 8366C INFORMATION TECHNOLOGY LABORATORY 8367C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 8368C GAITHERSBURG, MD 20899-8980 8369C PHONE--301-975-2899 8370C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 8371C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 8372C LANGUAGE--ANSI FORTRAN (1977) 8373C VERSION NUMBER--82/7 8374C ORIGINAL VERSION--JUNE 1978. 8375C UPDATED --JULY 1981. 8376C UPDATED --JANUARY 1981. 8377C UPDATED --NOVEMBER 1981. 8378C UPDATED --MARCH 1982. 8379C UPDATED --MAY 1982. 8380C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON 8381C UPDATED --MARCH 2011. USE DPPARS AND DPPAR3 8382C 8383C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 8384C 8385 CHARACTER*4 ICASPL 8386 CHARACTER*4 IAND1 8387 CHARACTER*4 IAND2 8388 CHARACTER*4 IANGLU 8389 CHARACTER*4 IBUGG2 8390 CHARACTER*4 IBUGG3 8391 CHARACTER*4 IBUGQ 8392 CHARACTER*4 ISUBRO 8393 CHARACTER*4 IFOUND 8394 CHARACTER*4 IERROR 8395C 8396 CHARACTER*4 ISUBN1 8397 CHARACTER*4 ISUBN2 8398 CHARACTER*4 ISTEPN 8399C 8400 CHARACTER*4 ICASE 8401 PARAMETER (MAXSPN=10) 8402 CHARACTER*40 INAME 8403 CHARACTER*4 IVARN1(MAXSPN) 8404 CHARACTER*4 IVARN2(MAXSPN) 8405 CHARACTER*4 IVARTY(MAXSPN) 8406 REAL PVAR(MAXSPN) 8407 INTEGER ILIS(MAXSPN) 8408 INTEGER NRIGHT(MAXSPN) 8409 INTEGER ICOLR(MAXSPN) 8410C 8411C--------------------------------------------------------------------- 8412C 8413 INCLUDE 'DPCOPA.INC' 8414C 8415 DIMENSION Y1(MAXOBV) 8416CCCCC FOLLOWING LINES ADDED JUNE, 1990 8417 INCLUDE 'DPCOZZ.INC' 8418 EQUIVALENCE (GARBAG(IGARB1),Y1(1)) 8419CCCCC END CHANGE 8420C 8421C-----COMMON---------------------------------------------------------- 8422C 8423 INCLUDE 'DPCOHK.INC' 8424 INCLUDE 'DPCODA.INC' 8425C 8426C-----COMMON VARIABLES (GENERAL)-------------------------------------- 8427C 8428 INCLUDE 'DPCOP2.INC' 8429C 8430C-----DATA STATEMENTS------------------------------------------------- 8431C 8432 DATA PI/3.141592653/ 8433C 8434C-----START POINT----------------------------------------------------- 8435C 8436 IERROR='NO' 8437C 8438 ISUBN1='DPCD' 8439 ISUBN2=' ' 8440C 8441 MAXCP1=MAXCOL+1 8442 MAXCP2=MAXCOL+2 8443 MAXCP3=MAXCOL+3 8444 MAXCP4=MAXCOL+4 8445 MAXCP5=MAXCOL+5 8446 MAXCP6=MAXCOL+6 8447C 8448C *********************************************** 8449C ** TREAT THE COMPLEX DEMODULATION CASE ** 8450C *********************************************** 8451C 8452 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'DPCD')THEN 8453 WRITE(ICOUT,999) 8454 999 FORMAT(1X) 8455 CALL DPWRST('XXX','BUG ') 8456 WRITE(ICOUT,51) 8457 51 FORMAT('***** AT THE BEGINNING OF DPCD--') 8458 CALL DPWRST('XXX','BUG ') 8459 WRITE(ICOUT,52)ICASPL,IAND1,IAND2,IANGLU,DEMODF 8460 52 FORMAT('ICASPL,IAND1,IAND2,IANGLU,DEMODF = ',4(A4,2X),G15.7) 8461 CALL DPWRST('XXX','BUG ') 8462 WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO 8463 53 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4) 8464 CALL DPWRST('XXX','BUG ') 8465 ENDIF 8466C 8467C *************************** 8468C ** STEP 1-- ** 8469C ** EXTRACT THE COMMAND ** 8470C *************************** 8471C 8472 ISTEPN='1' 8473 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCD') 8474 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8475C 8476 IF(NUMARG.GE.3 .AND. ICOM.EQ.'COMP' .AND. 8477 1 IHARG(1).EQ.'DEMO' .AND. IHARG(2).EQ.'AMPL' .AND. 8478 1 IHARG(3).EQ.'PLOT')THEN 8479 ICASPL='CDAM' 8480 ILASTC=3 8481 ELSEIF(NUMARG.GE.3 .AND. ICOM.EQ.'COMP' .AND. 8482 1 IHARG(1).EQ.'DEMO' .AND. IHARG(2).EQ.'PHAS' .AND. 8483 1 IHARG(3).EQ.'PLOT')THEN 8484 ICASPL='CDPH' 8485 ILASTC=3 8486 ELSE 8487 IFOUND='NO' 8488 GOTO9000 8489 ENDIF 8490C 8491 IFOUND='YES' 8492 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 8493C 8494C **************************************** 8495C ** STEP 2-- ** 8496C ** EXTRACT THE VARIABLE LIST ** 8497C **************************************** 8498C 8499 ISTEPN='2' 8500 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCD') 8501 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8502C 8503 INAME='COMPLEX DEMODULATION PLOT' 8504 MINNA=1 8505 MAXNA=100 8506 MINN2=2 8507 IFLAGE=1 8508 IFLAGM=1 8509 IFLAGP=0 8510 JMIN=1 8511 JMAX=NUMARG 8512 MINNVA=1 8513 MAXNVA=1 8514C 8515 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 8516 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 8517 1 JMIN,JMAX, 8518 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 8519 1 IVARN1,IVARN2,IVARTY,PVAR, 8520 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 8521 1 MINNVA,MAXNVA, 8522 1 IFLAGM,IFLAGP, 8523 1 IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 8524 IF(IERROR.EQ.'YES')GOTO9000 8525C 8526 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCD')THEN 8527 WRITE(ICOUT,999) 8528 CALL DPWRST('XXX','BUG ') 8529 WRITE(ICOUT,281) 8530 281 FORMAT('***** AFTER CALL DPPARS--') 8531 CALL DPWRST('XXX','BUG ') 8532 WRITE(ICOUT,282)NQ,NUMVAR,ICASPL 8533 282 FORMAT('NQ,NUMVAR,ICASPL = ',2I8,2X,A4) 8534 CALL DPWRST('XXX','BUG ') 8535 IF(NUMVAR.GT.0)THEN 8536 DO285I=1,NUMVAR 8537 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 8538 1 ICOLR(I) 8539 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 8540 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 8541 CALL DPWRST('XXX','BUG ') 8542 285 CONTINUE 8543 ENDIF 8544 ENDIF 8545C 8546C EXTRACT THE VARIABLE. 8547C 8548 ICOL=1 8549 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 8550 1 INAME,IVARN1,IVARN2,IVARTY, 8551 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 8552 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 8553 1 MAXCP4,MAXCP5,MAXCP6, 8554 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 8555 1 Y1,Y1,Y1,NLEFT,NLOCAL,NLOCAL,ICASE, 8556 1 IBUGG3,ISUBRO,IFOUND,IERROR) 8557 IF(IERROR.EQ.'YES')GOTO9000 8558C 8559C ****************************************************** 8560C ** STEP 7-- ** 8561C ** DETERMINE IF THE ANALYST ** 8562C ** HAS SPECIFIED THE DEMODULATION FREQUENCY ** 8563C ** FOR THE COMPLEX DEMODULATION ANALYSIS. ** 8564C ** THE FREQUENCY SETTING IS DEFINED BY PRE-USE ** 8565C ** OF THE DEMODULATION FREQUENCY COMMAND. ** 8566C ** IF FOUND, USE THE SPECIFIED VALUE. ** 8567C ** IF NOT FOUND, GENERATE AN ERROR MESSAGE. ** 8568C ****************************************************** 8569C 8570 ISTEPN='7' 8571 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCD') 8572 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8573C 8574 DEMOF2=DEMOFR 8575 IF(IANGLU.EQ.'DEGR')DEMOF2=DEMOF2*PI/180.0 8576 IF(IANGLU.EQ.'GRAD')DEMOF2=DEMOF2*PI/200.0 8577CCCCC IF(0.0.LT.DEMOF2.AND.DEMOF2.LT.0.5)GOTO790 8578C 8579 IF(DEMOF2.LE.0.0 .OR. DEMOF2.GE.0.5)THEN 8580 WRITE(ICOUT,999) 8581 CALL DPWRST('XXX','BUG ') 8582 WRITE(ICOUT,741) 8583 741 FORMAT('****** ERROR IN COMPLEX DEMODULATION PLOT--') 8584 CALL DPWRST('XXX','BUG ') 8585 IF(ICASPL.EQ.'CDAM')THEN 8586 WRITE(ICOUT,742) 8587 742 FORMAT(' FOR A COMPLEX DEMODULATION AMPLITUDE PLOT,') 8588 CALL DPWRST('XXX','BUG ') 8589 ELSEIF(ICASPL.EQ.'CDPH')THEN 8590 WRITE(ICOUT,743) 8591 743 FORMAT(' FOR A COMPLEX DEMODULATION PHASE PLOT,') 8592 CALL DPWRST('XXX','BUG ') 8593 ENDIF 8594 WRITE(ICOUT,744) 8595 744 FORMAT(' THE FREQUENCY AT WHICH THE DEMODULATION IS TO') 8596 CALL DPWRST('XXX','BUG ') 8597 WRITE(ICOUT,746) 8598 746 FORMAT(' PERFORMED MUST BE PRE-SPECIFIED BY THE ANALYST,') 8599 CALL DPWRST('XXX','BUG ') 8600 WRITE(ICOUT,747) 8601 747 FORMAT(' AND MUST BE BETWEEN 0 AND 0.5 RADIANS;') 8602 CALL DPWRST('XXX','BUG ') 8603 WRITE(ICOUT,748) 8604 748 FORMAT(' SUCH WAS NOT THE CASE HERE.') 8605 CALL DPWRST('XXX','BUG ') 8606 WRITE(ICOUT,749)DEMOFR,IANGLU 8607 749 FORMAT(' THE DEMODULATION FREQUENCY = ',G15.7,2X,A4) 8608 CALL DPWRST('XXX','BUG ') 8609 IF(IANGLU.NE.'RADI')THEN 8610 WRITE(ICOUT,750)DEMOF2 8611 750 FORMAT(' THE DEMODULATION FREQUENCY = ',G15.7,2X, 8612 1 'RADIANS') 8613 CALL DPWRST('XXX','BUG ') 8614 ENDIF 8615 WRITE(ICOUT,751) 8616 751 FORMAT(' TO DEFINE THE DEMODULATION FREQUENCY, USE THE') 8617 CALL DPWRST('XXX','BUG ') 8618 WRITE(ICOUT,753) 8619 753 FORMAT(' DEMODULATION FREQUENCY COMMAND, AS IN--') 8620 CALL DPWRST('XXX','BUG ') 8621 WRITE(ICOUT,754) 8622 754 FORMAT(' DEMODULATION FREQUENCY 0.3') 8623 CALL DPWRST('XXX','BUG ') 8624 WRITE(ICOUT,755) 8625 755 FORMAT(' DEMODULATION FREQUENCY 0.155') 8626 CALL DPWRST('XXX','BUG ') 8627 IERROR='YES' 8628 GOTO9000 8629 ENDIF 8630C 8631C ******************************************************** 8632C ** STEP 8-- * 8633C ** COMPUTE THE APPROPRIATE COMPLEX DEMODULATION * 8634C ** PLOT (AMPLITUDE OR PHASE). * 8635C ** FORM THE VERTICAL AND HORIZONTAL AXIS * 8636C ** VALUES Y(.) AND X(.) FOR THE PLOT. * 8637C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). * 8638C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). * 8639C ******************************************************** 8640C 8641 ISTEPN='8' 8642 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPCD') 8643 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8644C 8645 CALL DPCD2(Y1,NLEFT,ICASPL,DEMOF2,DEMODF, 8646 1 Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 8647C 8648C ***************** 8649C ** STEP 90-- ** 8650C ** EXIT ** 8651C ***************** 8652C 8653 9000 CONTINUE 8654 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'DPCD')THEN 8655 WRITE(ICOUT,999) 8656 CALL DPWRST('XXX','BUG ') 8657 WRITE(ICOUT,9011) 8658 9011 FORMAT('***** AT THE END OF DPHIST--') 8659 CALL DPWRST('XXX','BUG ') 8660 WRITE(ICOUT,9012)IFOUND,IERROR 8661 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 8662 CALL DPWRST('XXX','BUG ') 8663 WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 8664 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 8665 1 3I8,2X,2(A4,2X),A4) 8666 CALL DPWRST('XXX','BUG ') 8667 WRITE(ICOUT,9014)DEMOFR,IANGLU,DEMOF2 8668 9014 FORMAT('DEMOFR,IANGLU,DEMOF2 = ',G15.7,2X,A4,2X,G15.7) 8669 CALL DPWRST('XXX','BUG ') 8670 IF(NPLOTP.GT.0)THEN 8671 DO9015I=1,NPLOTP 8672 WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 8673 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3G15.7) 8674 CALL DPWRST('XXX','BUG ') 8675 9015 CONTINUE 8676 ENDIF 8677 ENDIF 8678C 8679 RETURN 8680 END 8681 SUBROUTINE DPCD2(Y,N,ICASPL,F,DEMODF, 8682 1 Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR) 8683C 8684C PURPOSE--THIS SUBROUTINE PERFORMS A COMPLEX DEMODULATION 8685C ON THE DATA IN THE INPUT VECTOR X 8686C AT THE INPUT DEMODULATION FREQUENCY = F. 8687C THE COMPLEX DEMODULATION CONSISTS OF THE FOLLOWING-- 8688C 1) AN AMPLITUDE VERSUS TIME PLOT; 8689C 2) A PHASE VERSUS TIME PLOT; 8690C 3) AN UPDATED DEMODULATION FREQUENCY ESTIMATE 8691C TO ASSIST THE ANALYST IN DETERMINING A 8692C MORE APPROPRIATE FREQUENCY AT WHICH 8693C TO DEMODULATE IN CASE THE SPECIFIED 8694C INPUT DEMODULATION FREQUENCY F 8695C DOES NOT FLATTEN SUFFICIENTLY THE 8696C PHASE PLOT. 8697C 8698C THE ALLOWABLE RANGE OF THE INPUT DEMODULATION 8699C FREQUENCY F IS 0.0 TO 0.5 (EXCLUSIVELY). 8700C THE INPUT DEMODULATION FREQUENCY F IS MEASURED OF 8701C IN UNITS OF CYCLES PER 'DATA POINT' OR, 8702C MORE PRECISELY, IN CYCLES PER UNIT TIME WHERE 8703C 'UNIT TIME' IS DEFINED AS THE 8704C ELAPSED TIME BETWEEN ADJACENT OBSERVATIONS. 8705C 8706C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR OF 8707C (UNSORTED) OBSERVATIONS. 8708C N = THE INTEGER NUMBER OF OBSERVATIONS 8709C IN THE VECTOR X. 8710C FREQ = THE SINGLE PRECISION 8711C DEMODULATION FREQUENCY. 8712C F IS IN UNITS OF CYCLES PER DATA POINT. 8713C F IS BETWEEN 0.0 AND 0.5 (EXCLUSIVELY). 8714C OUTPUT--2 PAGES OF AUTOMATIC PRINTOUT-- 8715C 1) AN AMPLITUDE PLOT; 8716C 2) A PHASE PLOT; AND 8717C 3) AN UPDATED DEMODULATION FREQUENCY ESTIMATE. 8718C PRINTING--YES. 8719C RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N 8720C FOR THIS SUBROUTINE IS 5000. 8721C --THE SAMPLE SIZE N MUST BE GREATER 8722C THAN OR EQUAL TO 3. 8723C --THE INPUT FREQUENCY F MUST BE 8724C GREATER THAN OR EQUAL TO 2/(N-2). 8725C --THE INPUT FREQUENCY F MUST BE 8726C SMALLER THAN 0.5. 8727C OTHER DATAPAC SUBROUTINES NEEDED--PLOTX. 8728C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, SIN, COS, ATAN. 8729C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 8730C LANGUAGE--ANSI FORTRAN (1977) 8731C COMMENT--IN ORDER THAT THE RESULTS OF THE COMPLEX DEMODULATION 8732C BE VALID AND PROPERLY INTERPRETED, THE INPUT DATA 8733C IN X SHOULD BE EQUI-SPACED IN TIME 8734C (OR WHATEVER VARIABLE CORRESPONDS TO TIME). 8735C --IF THE INPUT OBSERVATIONS IN X ARE CONSIDERED 8736C TO HAVE BEEN COLLECTED 1 SECOND APART IN TIME, 8737C THEN THE DEMODULATION FREQUENCY F 8738C WOULD BE IN UNITS OF HERTZ 8739C (= CYCLES PER SECOND). 8740C --A FREQUENCY OF 0.0 CORRESPONDS TO A CYCLE 8741C IN THE DATA OF INFINITE (= 1/(0.0)) 8742C LENGTH OR PERIOD. 8743C A FREQUENCY OF 0.5 CORRESPONDS TO A CYCLE 8744C IN THE DATA OF LENGTH = 1/(0.5) = 2 DATA POINTS. 8745C --IN EXAMINING THE AMPLITUDE AND PHASE PLOTS, 8746C ATTENTION SHOULD BE PAID NOT ONLY TO THE 8747C STRUCTURE OF THE PHASE PLOT 8748C (NEAR-ZERO SLOPE VERSUS NON-ZERO SLOPE) 8749C BUT ALSO TO THE RANGE 8750C OF VALUES ON THE VERTICAL AXIS. 8751C A PLOT WITH MUCH STRUCTURE BUT 8752C WITH A SMALL RANGE ON THE VERTICAL AXIS 8753C IS USUALLY MORE INDICATIVE OF A 8754C DEFINITE CYCLIC COMPONENT AT THE 8755C SPECIFIED INPUT DEMODULATION FREQUENCY, 8756C THAN IS A PLOT WITH LESS STRUCTURE BUT 8757C A WIDER RANGE ON THE VERTICAL AXIS. 8758C --INTERNAL TO THIS SUBROUTINE, 2 MOVING 8759C AVERAGES ARE APPLIED, EACH OF LENGTH 1/F. 8760C HENCE THE AMPLITUDE AND PHASE PLOTS 8761C HAVE N - 2/F VALUES 8762C (RATHER THAN N VALUES) ALONG THE 8763C HORIZONTAL (TIME) AXIS. 8764C IN ORDER THAT THE AMPLITUDE AND PHASE 8765C PLOTS BE NON-EMPTY, AN INPUT 8766C REQUIREMENT ON F FOR THIS SUBROUTINE 8767C IS THAT THE SAMPLE SIZE N 8768C AND THE DEMODULATION FREQUENCY F 8769C MUST BE SUCH THAT 8770C N - 2/F BE GREATER THAN ZERO. 8771C FURTHER, SINCE A PLOT WITH BUT 8772C 1 POINT IS MEANINGLESS 8773C AND OUGHT ALSO BE EXCLUDED, 8774C THE REQUIREMENT IS EXTENDED 8775C SO THAT N - 2/F MUST BE GREATER THAN 1. 8776C REFERENCES--GRANGER AND HATANAKA, PAGES 170 TO 189, 8777C ESPECIALLY PAGES 173, 177, AND 182. 8778C WRITTEN BY--JAMES J. FILLIBEN 8779C STATISTICAL ENGINEERING DIVISION 8780C INFORMATION TECHNOLOGY LABORATORY 8781C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 8782C GAITHERSBURG, MD 20899-8980 8783C PHONE--301-975-2899 8784C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 8785C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 8786C LANGUAGE--ANSI FORTRAN (1966) 8787C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS 8788C DENOTED BY QUOTES RATHER THAN NH. 8789C VERSION NUMBER--82/7 8790C ORIGINAL VERSION--NOVEMBER 1972. 8791C UPDATED --NOVEMBER 1975. 8792C UPDATED --FEBRUARY 1976. 8793C UPDATED --JUNE 1978. 8794C UPDATED --JANUARY 1981. 8795C UPDATED --MAY 1982. 8796C 8797C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 8798C 8799 CHARACTER*4 ICASPL 8800 CHARACTER*4 IBUGG3 8801 CHARACTER*4 ISUBRO 8802 CHARACTER*4 IERROR 8803C 8804 CHARACTER*4 ISUBN1 8805 CHARACTER*4 ISUBN2 8806C 8807C--------------------------------------------------------------------- 8808C 8809 INCLUDE 'DPCOPA.INC' 8810C 8811 DIMENSION Y(*) 8812C 8813 DIMENSION Y2(*) 8814 DIMENSION X2(*) 8815 DIMENSION D2(*) 8816C 8817C--------------------------------------------------------------------- 8818C 8819 INCLUDE 'DPCOP2.INC' 8820C 8821C-----DATA STATEMENTS------------------------------------------------- 8822C 8823 DATA PI/3.141592653/ 8824C 8825C-----START POINT----------------------------------------------------- 8826C 8827 ISUBN1='DPCD' 8828 ISUBN2='2 ' 8829C 8830 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PCD2')THEN 8831 WRITE(ICOUT,999) 8832 999 FORMAT(1X) 8833 CALL DPWRST('XXX','BUG ') 8834 WRITE(ICOUT,51) 8835 51 FORMAT('***** AT THE BEGINNING OF DPCD2--') 8836 CALL DPWRST('XXX','BUG ') 8837 WRITE(ICOUT,52)N,ICASPL 8838 52 FORMAT('N,ICASPL = ',I8,2X,A4) 8839 CALL DPWRST('XXX','BUG ') 8840 ENDIF 8841C 8842 ILOWER=3 8843 IUPPER=MAXOBV 8844 AN=N 8845 FMIN=2.0/(AN-2.0) 8846C 8847C ******************************************** 8848C ** STEP 0-- ** 8849C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 8850C ******************************************** 8851C 8852 IF(N.LT.ILOWER.OR.N.GT.IUPPER)GOTO50 8853 IF(F.LE.FMIN.OR.F.GE.0.5)GOTO60 8854 HOLD=Y(1) 8855 DO65I=2,N 8856 IF(Y(I).NE.HOLD)GOTO95 8857 65 CONTINUE 8858 WRITE(ICOUT, 9)HOLD 8859 CALL DPWRST('XXX','BUG ') 8860 GOTO9000 8861 50 WRITE(ICOUT,17)ILOWER,IUPPER 8862 CALL DPWRST('XXX','BUG ') 8863 WRITE(ICOUT,47)N 8864 CALL DPWRST('XXX','BUG ') 8865 GOTO9000 8866 60 WRITE(ICOUT,27)FMIN 8867 CALL DPWRST('XXX','BUG ') 8868 WRITE(ICOUT,46)F 8869 CALL DPWRST('XXX','BUG ') 8870 WRITE(ICOUT,28)FMIN,N 8871 CALL DPWRST('XXX','BUG ') 8872 GOTO9000 8873 95 CONTINUE 8874 9 FORMAT('***** WARNING--THE FIRST ARGUMENT ', 8875 1'(A VECTOR) TO THE DPCD2 SUBROUTINE HAS ALL ELEMENTS = ', 8876 1G15.7) 8877 17 FORMAT('***** ERROR--THE SECOND ARGUMENT TO THE ', 8878 1'DPCD2 SUBROUTINE IS OUTSIDE THE ALLOWABLE (',I6,',',I6,') ', 8879 1'INTERVAL') 8880 27 FORMAT('***** ERROR--THE THIRD ARGUMENT TO THE ', 8881 1'DPCD2 SUBROUTINE IS OUTSIDE THE ALLOWABLE (',I6,'0.5) ', 8882 1'INTERVAL') 8883 28 FORMAT(' THE ABOVE LOWER LIMIT (',F11.8, 8884 1') = 2/(N-2) WHERE N = THE INPUT SAMPLE SIZE = ',I8) 8885 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.8) 8886 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 8887C 8888C ****************************** 8889C ** STEP 1-- ** 8890C ** FORM THE COSINE SERIES ** 8891C ****************************** 8892C 8893 DO100I=1,N 8894 AI=I 8895 Y2(I)=Y(I)*COS(2.0*PI*F*AI) 8896 100 CONTINUE 8897C 8898C DEFINE THE LENGTH OF THE 2 MOVING AVERAGES 8899C 8900 LENMA1=INT(1.0/F) 8901 LENMA2=INT(1.0/F) 8902 ALEN1=REAL(LENMA1) 8903 ALEN2=REAL(LENMA2) 8904 IMAX1=N-LENMA1 8905 IMAX2=IMAX1-LENMA2 8906C 8907C ********************************************************* 8908C ** STEP 2-- ** 8909C ** FORM THE FIRST MOVING AVERAGE FOR THE COSINE SERIES** 8910C ********************************************************* 8911C 8912 DO200I=1,IMAX1 8913 ISTART=I+1 8914 IEND=I+LENMA1-1 8915 IENDP1=I+LENMA1 8916 SUM=0.0 8917 DO300J=ISTART,IEND 8918 SUM=SUM+Y2(J) 8919 300 CONTINUE 8920 SUM=SUM+Y2(I)/2.0+Y2(IENDP1)/2.0 8921 D2(I)=SUM/ALEN1 8922 200 CONTINUE 8923C 8924C ************************************************************ 8925C ** STEP 3-- ** 8926C ** FORM THE SECOND MOVING AVERAGE FOR THE COSINE SERIES ** 8927C ************************************************************ 8928C 8929 DO400I=1,IMAX2 8930 ISTART=I+1 8931 IEND=I+LENMA2-1 8932 IENDP1=I+LENMA2 8933 SUM=0.0 8934 DO500J=ISTART,IEND 8935 SUM=SUM+D2(J) 8936 500 CONTINUE 8937 SUM=SUM+D2(I)/2.0+D2(IENDP1)/2.0 8938 Y2(I)=SUM/ALEN2 8939 400 CONTINUE 8940C 8941C **************************** 8942C ** STEP 4-- ** 8943C ** FORM THE SINE SERIES ** 8944C **************************** 8945C 8946 DO700I=1,N 8947 AI=I 8948 X2(I)=Y(I)*SIN(2.0*PI*F*AI) 8949 700 CONTINUE 8950C 8951C ********************************************************* 8952C ** STEP 5-- ** 8953C ** FORM THE FIRST MOVING AVERAGE FOR THE SINE SERIES ** 8954C ********************************************************* 8955C 8956 DO800I=1,IMAX1 8957 ISTART=I+1 8958 IEND=I+LENMA1-1 8959 IENDP1=I+LENMA1 8960 SUM=0.0 8961 DO900J=ISTART,IEND 8962 SUM=SUM+X2(J) 8963 900 CONTINUE 8964 SUM=SUM+X2(I)/2.0+X2(IENDP1)/2.0 8965 D2(I)=SUM/ALEN1 8966 800 CONTINUE 8967C 8968C ********************************************************** 8969C ** STEP 6-- ** 8970C ** FORM THE SECOND MOVING AVERAGE FOR THE SINE SERIES ** 8971C ********************************************************** 8972C 8973 DO1000I=1,IMAX2 8974 ISTART=I+1 8975 IEND=I+LENMA1-1 8976 IENDP1=I+LENMA1 8977 SUM=0.0 8978 DO1100J=ISTART,IEND 8979 SUM=SUM+D2(J) 8980 1100 CONTINUE 8981 SUM=SUM+D2(I)/2.0+D2(IENDP1)/2.0 8982 X2(I)=SUM/ALEN2 8983 1000 CONTINUE 8984C 8985C CHECK FOR DESIRED CASE 8986C AND BRANCH ACCORDINGLY. 8987C 8988 IF(ICASPL.EQ.'CDAM')GOTO1400 8989 IF(ICASPL.EQ.'CDPH')GOTO1700 8990C 8991 WRITE(ICOUT,999) 8992 CALL DPWRST('XXX','BUG ') 8993 WRITE(ICOUT,1311) 8994 1311 FORMAT('***** INTERNAL ERROR IN DPCD2 ', 8995 1'AT BRANCH POINT 1311--') 8996 CALL DPWRST('XXX','BUG ') 8997 WRITE(ICOUT,1312) 8998 1312 FORMAT(' ICASPL SHOULD BE EITHER') 8999 CALL DPWRST('XXX','BUG ') 9000 WRITE(ICOUT,1313) 9001 1313 FORMAT(' CDAM OR CDPH, BUT IS NEITHER.') 9002 CALL DPWRST('XXX','BUG ') 9003 WRITE(ICOUT,1314)ICASPL 9004 1314 FORMAT(' ICASPL = ',A4) 9005 CALL DPWRST('XXX','BUG ') 9006 IERROR='YES' 9007 GOTO9000 9008C 9009C ***************************************** 9010C ** STEP 7-- ** 9011C ** FORM THE AMPLITUDES AND PLOT THEM ** 9012C ***************************************** 9013C 9014 1400 CONTINUE 9015 DO1450I=1,IMAX2 9016 Y2(I)=2.0*SQRT(Y2(I)*Y2(I)+X2(I)*X2(I)) 9017 X2(I)=I 9018 D2(I)=1.0 9019 1450 CONTINUE 9020 N2=IMAX2 9021 NPLOTV=2 9022CCCCC WRITE(ICOUT,1451)F 9023C1451 FORMAT(30X, 48HAMPLITUDE PLOT FOR THE DEMODULATION FREQUENCY = 9024CCCCC1 ,F8.6,21H CYCLES PER UNIT TIME) 9025CCCCC CALL DPWRST('XXX','BUG ') 9026C 9027C COMPUTE THE DIFFERENCE BETWEEN THE MAX AND MIN AMPLITUDES AND WRITE IT OUT 9028C 9029 Y2MIN=Y2(1) 9030 Y2MAX=Y2(1) 9031 DO1600I=1,IMAX2 9032 IF(Y2(I).LT.Y2MIN)Y2MIN=Y2(I) 9033 IF(Y2(I).GT.Y2MAX)Y2MAX=Y2(I) 9034 1600 CONTINUE 9035 RANGE=Y2MAX-Y2MIN 9036CCCCC WRITE(ICOUT,1651)Y2MIN,Y2MAX,RANGE 9037C1651 FORMAT(9X,20HMINIMUM AMPLITUDE = ,E15.8,5X,20HMAXIMUM AMPLITUD 9038CCCCC1E = ,E15.8,5X,22HRANGE OF AMPLITUDES = ,E15.8) 9039CCCCC CALL DPWRST('XXX','BUG ') 9040 GOTO9000 9041C 9042C ************************************* 9043C ** STEP 8-- ** 9044C ** FORM THE PHASES AND PLOT THEM ** 9045C ************************************* 9046C 9047 1700 CONTINUE 9048 DO1750I=1,IMAX2 9049 Y2(I)=ATAN(Y2(I)/X2(I)) 9050 X2(I)=I 9051 D2(I)=1.0 9052 1750 CONTINUE 9053 N2=IMAX2 9054 NPLOTV=2 9055C 9056CCCCC WRITE(ICOUT,1751)F 9057C1751 FORMAT(32X, 44HPHASE PLOT FOR THE DEMODULATION FREQUENCY = ,F8 9058CCCCC1.6,21H CYCLES PER UNIT TIME) 9059CCCCC CALL DPWRST('XXX','BUG ') 9060C 9061C COMPUTE A NEW ESTIMATE FOR THE DEMODULATION FREQUENCY AND WRITE IT OUT 9062C 9063 AIMAX2=IMAX2 9064 IMAX2M=IMAX2-1 9065 IFLAG=0 9066 Y2MIN=Y2(1) 9067 Y2MAX=Y2(1) 9068 DO1800I=1,IMAX2M 9069 IP1=I+1 9070 DEL=Y2(IP1)-Y2(I) 9071 IF(DEL.GT.2.5)IFLAG=IFLAG-1 9072 IF(DEL.LT.-2.5)IFLAG=IFLAG+1 9073 AIFLAG=REAL(IFLAG) 9074 Y2NEW=Y2(IP1)+AIFLAG*PI 9075 IF(Y2NEW.LT.Y2MIN)Y2MIN=Y2NEW 9076 IF(Y2NEW.GT.Y2MAX)Y2MAX=Y2NEW 9077 1800 CONTINUE 9078 RANGE=Y2MAX-Y2MIN 9079 SLOPER=RANGE/AIMAX2 9080 SLOPEH=SLOPER/(2.0*PI) 9081 FEST=F+SLOPEH 9082 DEMODF=FEST 9083CCCCC WRITE(ICOUT,2025)Y2MIN,Y2MAX,RANGE 9084C2025 FORMAT(3X,16HMINIMUM PHASE = ,E15.8,11H RADIANS ,16HMAXIMUM 9085CCCCC1PHASE = ,E15.8,11H RADIANS ,18HRANGE OF PHASES = ,E15.8,8H RADIA 9086CCCCC1NS) 9087CCCCC CALL DPWRST('XXX','BUG ') 9088CCCCC WRITE(ICOUT,2030)SLOPER,SLOPEH,FEST 9089C2030 FORMAT(8HSLOPE = ,E14.8,11H RADIANS = ,E14.6,52H CYCLES PER UN 9090CCCCC1IT TIME EST. OF NEW DEMOD. FREQ. = ,E15.8,15H CYC./UNIT TIME) 9091CCCCC CALL DPWRST('XXX','BUG ') 9092C 9093C ***************** 9094C ** STEP 90-- ** 9095C ** EXIT ** 9096C ***************** 9097C 9098 9000 CONTINUE 9099 RETURN 9100 END 9101 SUBROUTINE DPCDC3(Y,N,ICASA2,ICASA4,ISEED,MAXNXT, 9102 1 TEMP1,ALPHA,NALPHA,ALOWLM,AUPPLM, 9103 1 CD,YMED,YAAD, 9104 1 ISUBRO,IBUGA3,IERROR) 9105C 9106C PURPOSE--THIS SUBROUTINE COMPUTES CONFIDENCE LIMITS FOR THE 9107C COEFFIENT OF DISPERSION. THE COEFFICIENT OF DISPERSION 9108C IS AN ALTERNATIVE TO THE COEFFICIENT OF VARIATION FOR 9109C NON-NORMAL DATA. 9110C 9111C THE FOLLOWING CASES ARE SUPPORTED: 9112C 9113C LET A = LOWER COEFFICIENT OF DISPERSION CONFIDENCE LIMIT Y 9114C LET A = UPPER COEFFICIENT OF DISPERSION CONFIDENCE LIMIT Y 9115C LET A = ONE SIDED LOWER COEFFICIENT OF DISPERSION CONFIDENCE LIMIT Y 9116C LET A = ONE SIDED UPPER COEFFICIENT OF DISPERSION CONFIDENCE LIMIT Y 9117C 9118C THE DATA CONSISTS OF N OBSERVATIONS IN Y. 9119C 9120C THIS ALGORITHM IS FROM THE BONETT AND SEIER PAPER. 9121C 9122C THE COEFFICIENT OF DISPERSION IS DEFINED AS: 9123C 9124C CD = MEAN ABSOLUTE DEVIATION/MEDIAN 9125C 9126C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR OF 9127C (UNSORTED OR SORTED) OBSERVATIONS. 9128C --N = THE INTEGER NUMBER OF OBSERVATIONS 9129C IN THE VECTOR Y. 9130C --ALPHA = THE SINGLE PRECISION VECTOR OF CONFIDENCE 9131C LEVELS 9132C NALPHA = THE INTEGER NUMBER OF ALPHA VALUES 9133C OUTPUT ARGUMENTS-ALOWLM = THE SINGLE PRECISION VECTOR OF LOWER 9134C CONFIDENCE LIMIT VALUES 9135C -AUPPLM = THE SINGLE PRECISION VECTOR OF UPPER 9136C CONFIDENCE LIMIT VALUES 9137C OTHER DATAPAC SUBROUTINES NEEDED--MEDIAN, MEAN, VAR, AAD, SORT. 9138C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. 9139C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 9140C LANGUAGE--ANSI FORTRAN. 9141C REFERENCES--BONETT AND SEIER (2006), "CONFIDENCE INTERVAL FOR A 9142C COEFFICIENT OF DISPERSION", BIOMETRICAL JOURNAL, 9143C VOL. 48, NO. 1, PP. 144-148. 9144C WRITTEN BY--ALAN HECKERT 9145C STATISTICAL ENGINEERING LABORATORY 9146C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 9147C GAITHERSBURG, MD 20899-8980 9148C PHONE--301-975-2899 9149C ORIGINAL VERSION--NOVEMBER 2017. 9150C 9151C--------------------------------------------------------------------- 9152C 9153 DIMENSION Y(*) 9154 DIMENSION TEMP1(*) 9155 DIMENSION ALOWLM(*) 9156 DIMENSION AUPPLM(*) 9157 DIMENSION ALPHA(*) 9158C 9159 INTEGER ASTAR 9160 INTEGER BSTAR 9161C 9162 CHARACTER*4 ICASA2 9163 CHARACTER*4 ICASA4 9164 CHARACTER*4 ISUBRO 9165 CHARACTER*4 IBUGA3 9166 CHARACTER*4 IERROR 9167C 9168 CHARACTER*4 IWRITE 9169 CHARACTER*4 ISUBN1 9170 CHARACTER*4 ISUBN2 9171 CHARACTER*4 ISTEPN 9172C 9173 INCLUDE 'DPCOP2.INC' 9174C 9175C-----START POINT----------------------------------------------------- 9176C 9177 ISUBN1='CDC3' 9178 ISUBN2=' ' 9179 IWRITE='OFF' 9180 IERROR='NO' 9181C 9182 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CDC3')THEN 9183 WRITE(ICOUT,999) 9184 999 FORMAT(1X) 9185 CALL DPWRST('XXX','WRIT') 9186 WRITE(ICOUT,51) 9187 51 FORMAT('**** AT THE BEGINNING OF DPCDC3--') 9188 CALL DPWRST('XXX','WRIT') 9189 WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASA2,ICASA4 9190 52 FORMAT('IBUGA3,ISUBRO,ICASA2,ICASA4 = ',3(A4,2X),A4) 9191 CALL DPWRST('XXX','WRIT') 9192 WRITE(ICOUT,53)N,NALPHA,ISEED,ALPHA(1) 9193 53 FORMAT('N,NALPHA,ISEED,ALPHA(1) = ',3I8,G15.7) 9194 CALL DPWRST('XXX','WRIT') 9195 DO56I=1,N 9196 WRITE(ICOUT,57)I,Y(I) 9197 57 FORMAT('I,Y(I) = ',I8,G15.7) 9198 CALL DPWRST('XXX','WRIT') 9199 56 CONTINUE 9200 DO76I=1,NALPHA 9201 WRITE(ICOUT,77)I,ALPHA(I) 9202 77 FORMAT('I,ALPHA(I) = ',I8,G15.7) 9203 CALL DPWRST('XXX','WRIT') 9204 76 CONTINUE 9205 ENDIF 9206C 9207C ******************************************** 9208C ** STEP 11-- ** 9209C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 9210C ******************************************** 9211C 9212 ISTEPN='11' 9213 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CDC3') 9214 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9215C 9216 DO110I=1,NALPHA 9217 ALOWLM(I)=CPUMIN 9218 AUPPLM(I)=CPUMIN 9219 110 CONTINUE 9220C 9221 IF(N.LT.3)THEN 9222 WRITE(ICOUT,999) 9223 CALL DPWRST('XXX','WRIT') 9224 WRITE(ICOUT,101) 9225 101 FORMAT('***** ERROR: COEFFICIENT OF DISPERSION CONFIDENCE ', 9226 1 'LIMITS--') 9227 CALL DPWRST('XXX','WRIT') 9228 WRITE(ICOUT,102) 9229 102 FORMAT(' THE NUMBER OF ORIGINAL OBSERVATIONS IS LESS ', 9230 1 'THAN THREE.') 9231 CALL DPWRST('XXX','WRIT') 9232 WRITE(ICOUT,103)N 9233 103 FORMAT(' SAMPLE SIZE = ',I8) 9234 CALL DPWRST('XXX','WRIT') 9235 IERROR='YES' 9236 GOTO9000 9237 ENDIF 9238C 9239C ******************************************** 9240C ** STEP 21-- ** 9241C ** CARRY OUT CALCULATIONS FOR CONFIDENCE ** 9242C ** LIMITS. ** 9243C ******************************************** 9244C 9245 ISTEPN='21' 9246 IF(IBUGA3.EQ.'ON'.AND.ISUBRO.EQ.'CDC3') 9247 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9248C 9249C ICASA2: LOWE => LOWER LIMIT 9250C UPPE => UPPER LIMIT 9251C ICASA4: ONES => ONE-SIDED LIMIT 9252C TWOS => TWO-SIDED LIMIT 9253C 9254C COMPUTE MEDIAN AND MEAN ABSOLUTE DEVIATION FROM MEDIAN 9255C 9256 CALL MEDIAN(Y,N,IWRITE,TEMP1,MAXNXT,YMED,IBUGA3,IERROR) 9257 CALL AAD(Y,N,IWRITE,TEMP1,MAXNXT,YAAD,'MEDI',IBUGA3,IERROR) 9258C 9259 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CDC3')THEN 9260 WRITE(ICOUT,201)YMED,YAAD 9261 201 FORMAT('YMED,YAAD = ',2G15.7) 9262 CALL DPWRST('XXX','WRIT') 9263 ENDIF 9264C 9265 IF(YAAD.EQ.0.0)THEN 9266 WRITE(ICOUT,999) 9267 CALL DPWRST('XXX','WRIT') 9268 WRITE(ICOUT,101) 9269 CALL DPWRST('XXX','WRIT') 9270 WRITE(ICOUT,207) 9271 207 FORMAT(' THE MEAN ABSOLUTE DEVIATION FROM THE MEDIAN IS ', 9272 1 'ZERO.') 9273 CALL DPWRST('XXX','WRIT') 9274 WRITE(ICOUT,209) 9275 209 FORMAT(' THE COEFFICIENT OF DISPERSION CONFIDENCE LIMIT ', 9276 1 'IS NOT COMPUTED IN THIS CASE.') 9277 CALL DPWRST('XXX','WRIT') 9278 IERROR='YES' 9279 GOTO9000 9280 ELSEIF(YMED.LE.0.0)THEN 9281 WRITE(ICOUT,999) 9282 CALL DPWRST('XXX','WRIT') 9283 WRITE(ICOUT,101) 9284 CALL DPWRST('XXX','WRIT') 9285 WRITE(ICOUT,217) 9286 217 FORMAT(' THE MEDIAN OF THE OBSERVATIONS IS NON-POSITIVE.') 9287 CALL DPWRST('XXX','WRIT') 9288 WRITE(ICOUT,209) 9289 CALL DPWRST('XXX','WRIT') 9290 IERROR='YES' 9291 GOTO9000 9292 ENDIF 9293C 9294 CD=YAAD/YMED 9295C 9296 CALL MEAN(Y,N,IWRITE,U,IBUGA3,IERROR) 9297 CALL VAR(Y,N,IWRITE,V,IBUGA3,IERROR) 9298C 9299 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CDC3')THEN 9300 WRITE(ICOUT,220)CD,U,V 9301 220 FORMAT('CD,U,V = ',3G15.7) 9302 CALL DPWRST('XXX','WRIT') 9303 ENDIF 9304C 9305 AN=REAL(N) 9306 DEL=(U-YMED)/YAAD 9307 GAM=V/(YAAD**2) 9308 CALL SORT(Y,N,Y) 9309 C=AN/(AN-1.0) 9310 TERM1=(AN+1.0)/2.0 - SQRT(AN) 9311 ASTAR=INT(TERM1+0.5) 9312 BSTAR=N-ASTAR+1 9313 TERM1=LOG(Y(ASTAR)) - LOG(Y(BSTAR)) 9314 VRLETA=(TERM1/4.0)**2 9315 SE1=SQRT(VRLETA) 9316 VRLTAU=(GAM + (DEL**2) - 1.0)/AN 9317 SE2=SQRT(VRLTAU) 9318 CVLTLE=(DEL*SQRT(VRLETA))/SQRT(AN) 9319 AK=SQRT(VRLETA + VRLTAU - 2.0*CVLTLE)/(SE1 + SE2) 9320C 9321 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CDC3')THEN 9322 WRITE(ICOUT,223)DEL,GAMC,VRLETA,SE1,VRLTAU,SE2 9323 223 FORMAT('DEL,GAMC,VRLETA,SE1,VRLTAU,SE2 = ',6G15.7) 9324 CALL DPWRST('XXX','WRIT') 9325 WRITE(ICOUT,225)ASTAR,BSTAR,CVLTLE,AK 9326 225 FORMAT('ASTAR,BSTAR,CVLTLE,AK = ',2I8,2G15.7) 9327 CALL DPWRST('XXX','WRIT') 9328 ENDIF 9329C 9330 DO300I=1,NALPHA 9331C 9332C GET NORMAL CRITICAL VALUE 9333C 9334 ALP=ALPHA(I) 9335 IF(ALP.GE.1.0 .AND. ALP.LE.100.)ALP=ALP/100. 9336 IF(ALP.LE.0.0 .OR. ALP.GE.1.0)THEN 9337 IF(ICASA4.EQ.'ONES')THEN 9338 Z=1.645 9339 ELSE 9340 Z=1.96 9341 ENDIF 9342 ELSE 9343 IF(ALP.LT.0.5)THEN 9344 ALP=1.0-ALP 9345 ENDIF 9346 ALP=1.0 - ALP 9347 IF(ICASA4.EQ.'ONES')THEN 9348 P1=ALP 9349 P2=1.0-ALP 9350 CALL NORPPF(P2,Z) 9351 ELSE 9352 P1=ALP/2.0 9353 P2=1.0-(ALP/2.0) 9354 CALL NORPPF(P2,Z) 9355 ENDIF 9356 ENDIF 9357C 9358 A=(AN+1)/2.0 - AK*Z*SQRT(AN/4.0) 9359 IA=INT(A+0.5) 9360 IF(IA.LE.0)THEN 9361 ALOWLM(I)=EXP(AL1-AU2STR) 9362 AUPPLM(I)=EXP(AU1 -AL2STR) 9363 ELSE 9364 IB=N - IA + 1 9365 AL2STR=LOG(Y(IA)) 9366 AU2STR=LOG(Y(IB)) 9367 AL1=LOG(C*YAAD) - AK*Z*SE2 9368 AU1=LOG(C*YAAD) + AK*Z*SE2 9369C 9370C COMPUTE BOTH UPPER AND LOWER LIMIT. LET CALLING ROUTINE 9371C DETERMINE WHICH TO USE. 9372C 9373 ALOWLM(I)=EXP(AL1-AU2STR) 9374 AUPPLM(I)=EXP(AU1 -AL2STR) 9375 ENDIF 9376C 9377 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CDC3')THEN 9378 WRITE(ICOUT,311)I,IA,IB,Z,AL2STR,AU2STR 9379 311 FORMAT('I,IA,IB,Z,AL2STR,AU2STR = ',3I8,3G15.7) 9380 CALL DPWRST('XXX','WRIT') 9381 WRITE(ICOUT,313)AL1,AU1,ALOWLM(I),AUPPLM(I) 9382 313 FORMAT('AL1,AU1,ALOWLM(I),AUPPLM(I) = ',4G15.7) 9383 CALL DPWRST('XXX','WRIT') 9384 ENDIF 9385C 9386 300 CONTINUE 9387C 9388 9000 CONTINUE 9389 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CDC3')THEN 9390 WRITE(ICOUT,999) 9391 CALL DPWRST('XXX','WRIT') 9392 WRITE(ICOUT,9051) 9393 9051 FORMAT('**** AT THE END OF DPCDC3--') 9394 CALL DPWRST('XXX','WRIT') 9395 ENDIF 9396C 9397 RETURN 9398 END 9399 SUBROUTINE DPCDF1(Y,Y2,N,ICASPL,IFLAGD, 9400 1 SHAPE1,SHAPE2,SHAPE3,SHAPE4, 9401 1 SHAPE5,SHAPE6,SHAPE7, 9402 1 YLOWLM,YUPPLM,A,B,MINMAX, 9403 1 ICAPSW,ICAPTY, 9404 1 IADEDF,IGEPDF,IMAKDF,IBEIDF, 9405 1 ILGADF,ISKNDF,IGLDDF,IBGEDF, 9406 1 IGETDF,ICONDF,IGOMDF,IKATDF, 9407 1 IGIGDF,IGEODF, 9408 1 KSLOC,KSSCAL, 9409 1 IBUGA3,ISUBRO,IERROR) 9410C 9411C PURPOSE--COMPUTE THE CDF VALUE AT GIVEN SET OF POINTS. THIS 9412C WILL BE USED BY VARIOUS K-S AND ANDERSON DARLING 9413C ROUTINES. THIS ROUTINE SIMPLY RETURNS THE ARRAY 9414C OF COMPUTED CDF VALUES. THE CALLING ROUTINE IS 9415C RESPONSIBLE FOR CONVERTING THAT INTO A K-S, 9416C ANDERSON-DARLING, OR SOME OTHER RELEVANT STATISTIC. 9417C 9418C THIS ROUTINE HANDLES THE UNGROUPED, UNCENSORED CASE. 9419C IF IFLAGD = 1, THEN DISCRETE DISTRIBUTIONS WILL 9420C BE SKIPPED. 9421C 9422C WRITTEN BY--ALAN HECKERT 9423C STATISTICAL ENGINEERING DIVISION 9424C INFORMATION TECHNOLOGY LABORATORY 9425C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 9426C GAITHERSBURG, MD 20899-8980 9427C PHONE--301-975-2899 9428C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 9429C OF THE NATIONAL BUREAU OF STANDARDS. 9430C LANGUAGE--ANSI FORTRAN (1977) 9431C VERSION NUMBER--2009/9 9432C ORIGINAL VERSION--SEPTEMBER 2009. 9433C UPDATED --JULY 2010. END EFFECTS WEIBULL 9434C UPDATED --AUGUST 2010. BRITTLE FIBER WEIBULL 9435C UPDATED --MARCH 2013. COSINE 9436C UPDATED --MAY 2014. 3-PARAMETER INVERSE GAUSSIAN 9437C 9438C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 9439C 9440 LOGICAL HYPPNT 9441C 9442 CHARACTER*4 ICASPL 9443 CHARACTER*4 ICAPSW 9444 CHARACTER*4 ICAPTY 9445 CHARACTER*4 IADEDF 9446 CHARACTER*4 IGEPDF 9447 CHARACTER*4 IMAKDF 9448 CHARACTER*4 IBEIDF 9449 CHARACTER*4 ILGADF 9450 CHARACTER*4 ISKNDF 9451 CHARACTER*4 IGLDDF 9452 CHARACTER*4 IBGEDF 9453 CHARACTER*4 IGETDF 9454 CHARACTER*4 ICONDF 9455 CHARACTER*4 IGOMDF 9456 CHARACTER*4 IKATDF 9457 CHARACTER*4 IGIGDF 9458 CHARACTER*4 IGEODF 9459 CHARACTER*4 IBUGA3 9460 CHARACTER*4 ISUBRO 9461 CHARACTER*4 IERROR 9462C 9463 CHARACTER*4 IWRITE 9464 CHARACTER*4 ISUBN1 9465 CHARACTER*4 ISUBN2 9466C 9467 REAL KSLOC 9468 REAL KSSCAL 9469C 9470 DOUBLE PRECISION DXOUT 9471 DOUBLE PRECISION DCDF 9472 DOUBLE PRECISION CDFGLO 9473 DOUBLE PRECISION CDFWAK 9474 DOUBLE PRECISION LANCDF 9475 DOUBLE PRECISION XPAR(5) 9476C 9477C--------------------------------------------------------------------- 9478C 9479 DIMENSION Y(*) 9480 DIMENSION Y2(*) 9481C 9482C--------------------------------------------------------------------- 9483C 9484 INCLUDE 'DPCOP2.INC' 9485C 9486C-----START POINT----------------------------------------------------- 9487C 9488C 9489 ISUBN1='DPCD' 9490 ISUBN2='F1 ' 9491 IERROR='NO' 9492C 9493C ******************************************** 9494C ** STEP 1-- ** 9495C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 9496C ******************************************** 9497C 9498CCCCC 2013/07: ALLOW ONE VALUE (FOR CALL FROM DPBEF2). 9499C 9500CCCCC IF(N.LT.2)THEN 9501 NMIN=1 9502 IF(N.LT.NMIN)THEN 9503 WRITE(ICOUT,999) 9504 999 FORMAT(1X) 9505 CALL DPWRST('XXX','BUG ') 9506 WRITE(ICOUT,31) 9507 31 FORMAT('***** ERROR IN DPCDF1--') 9508 CALL DPWRST('XXX','BUG ') 9509 WRITE(ICOUT,32)NMIN 9510 32 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST ', 9511 1 I1,'.') 9512 CALL DPWRST('XXX','BUG ') 9513 WRITE(ICOUT,34)N 9514 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I5) 9515 CALL DPWRST('XXX','BUG ') 9516 WRITE(ICOUT,999) 9517 CALL DPWRST('XXX','BUG ') 9518 IERROR='YES' 9519 GOTO9000 9520 ENDIF 9521C 9522 IF(N.GT.1)THEN 9523 HOLD=Y(1) 9524 DO60I=1,N 9525 IF(Y(I).NE.HOLD)GOTO69 9526 60 CONTINUE 9527 WRITE(ICOUT,999) 9528 CALL DPWRST('XXX','BUG ') 9529 WRITE(ICOUT,31) 9530 CALL DPWRST('XXX','BUG ') 9531 WRITE(ICOUT,62) 9532 62 FORMAT(' ALL ELEMENTS IN THE RESPONSE VARIABLE ARE ', 9533 1 'IDENTICALLY EQUAL TO ',G15.7) 9534 CALL DPWRST('XXX','BUG ') 9535 WRITE(ICOUT,999) 9536 CALL DPWRST('XXX','BUG ') 9537 IERROR='YES' 9538 GOTO9000 9539 69 CONTINUE 9540 ENDIF 9541C 9542 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CDF1')THEN 9543 WRITE(ICOUT,999) 9544 CALL DPWRST('XXX','BUG ') 9545 WRITE(ICOUT,71) 9546 71 FORMAT('***** AT THE BEGINNING OF DPCDF1--') 9547 CALL DPWRST('XXX','BUG ') 9548 WRITE(ICOUT,72)ICASPL,ICAPSW,ICAPTY,N,MINMAX 9549 72 FORMAT('ICASPL,ICAPSW,ICAPTY,N,MINMAX = ',3(A4,2X),2I8) 9550 CALL DPWRST('XXX','BUG ') 9551 WRITE(ICOUT,74)KSLOC,KSSCAL,SHAPE1,SHAPE2 9552 74 FORMAT('KSLOC,KSSCAL,SHAPE1,SHAPE2 = ',4G15.7) 9553 CALL DPWRST('XXX','BUG ') 9554 DO85I=1,N 9555 WRITE(ICOUT,86)I,Y(I) 9556 86 FORMAT('I,Y(I) = ',I8,G15.7) 9557 CALL DPWRST('XXX','BUG ') 9558 85 CONTINUE 9559 ENDIF 9560C 9561C ************************************************ 9562C ** STEP 2.1-- ** 9563C ** COMPUTE CDF VALUE AT GIVEN POINTS ** 9564C ************************************************ 9565C 9566 ZSCALE=B - A 9567 ZLOC=A 9568 IWRITE='OFF' 9569 CALL MINIM(Y,N,IWRITE,XMIN,IBUGA3,IERROR) 9570 CALL MAXIM(Y,N,IWRITE,XMAX,IBUGA3,IERROR) 9571C 9572 IF(ICASPL.EQ.'UNIF')THEN 9573 DO1010I=1,N 9574 XL=(Y(I) - ZLOC)/ZSCALE 9575 CALL UNICDF(XL,Y2(I)) 9576 1010 CONTINUE 9577C 9578 ELSEIF(ICASPL.EQ.'NORM')THEN 9579 DO1020I=1,N 9580 XL=(Y(I) - KSLOC)/KSSCAL 9581 CALL NODCDF(DBLE(XL),DXOUT) 9582 Y2(I)=REAL(DXOUT) 9583 1020 CONTINUE 9584C 9585 ELSEIF(ICASPL.EQ.'LOGI')THEN 9586 DO1030I=1,N 9587 XL=(Y(I) - KSLOC)/KSSCAL 9588 CALL LOGCDF(XL,Y2(I)) 9589 1030 CONTINUE 9590C 9591 ELSEIF(ICASPL.EQ.'DEXP')THEN 9592 DO1040I=1,N 9593 XL=(Y(I) - KSLOC)/KSSCAL 9594 CALL DEXCDF(XL,Y2(I)) 9595 1040 CONTINUE 9596C 9597 ELSEIF(ICASPL.EQ.'CAUC')THEN 9598 DO1050I=1,N 9599 XL=(Y(I) - KSLOC)/KSSCAL 9600 CALL CAUCDF(XL,Y2(I)) 9601 1050 CONTINUE 9602C 9603 ELSEIF(ICASPL.EQ.'TULA')THEN 9604 DO1060I=1,N 9605 XL=(Y(I) - KSLOC)/KSSCAL 9606 CALL LAMCDF(XL,SHAPE1,Y2(I)) 9607 1060 CONTINUE 9608C 9609 ELSEIF(ICASPL.EQ.'LOGN' .OR. ICASPL.EQ.'3LGN')THEN 9610 DO1070I=1,N 9611 XL=(Y(I) - KSLOC)/KSSCAL 9612 CALL LGNCDF(XL,SHAPE1,Y2(I)) 9613 1070 CONTINUE 9614C 9615 ELSEIF(ICASPL.EQ.'HNOR' .OR. ICASPL.EQ.'1HNO')THEN 9616 DO1080I=1,N 9617 XL=(Y(I) - KSLOC)/KSSCAL 9618 CALL HFNCDF(XL,Y2(I)) 9619 1080 CONTINUE 9620C 9621 ELSEIF(ICASPL.EQ.'TPP')THEN 9622 DO1090I=1,N 9623 XL=(Y(I) - KSLOC)/KSSCAL 9624 CALL TCDF(XL,SHAPE1,Y2(I)) 9625 1090 CONTINUE 9626C 9627 ELSEIF(ICASPL.EQ.'CHIS')THEN 9628 DO1100I=1,N 9629 XL=(Y(I) - KSLOC)/KSSCAL 9630 CALL CHSCDF(XL,INT(SHAPE1+0.1),Y2(I)) 9631 1100 CONTINUE 9632C 9633 ELSEIF(ICASPL.EQ.'FPP')THEN 9634 DO1110I=1,N 9635 XL=(Y(I) - KSLOC)/KSSCAL 9636 CALL FCDF(XL,INT(SHAPE1+0.1),INT(SHAPE2+0.1),Y2(I)) 9637 1110 CONTINUE 9638C 9639 ELSEIF(ICASPL.EQ.'EXPO')THEN 9640 DO1120I=1,N 9641 XL=(Y(I) - KSLOC)/KSSCAL 9642 CALL EXPCDF(XL,Y2(I)) 9643 1120 CONTINUE 9644C 9645 ELSEIF(ICASPL.EQ.'GAMM' .OR. ICASPL.EQ.'3GAM')THEN 9646 DO1130I=1,N 9647 XL=(Y(I) - KSLOC)/KSSCAL 9648 CALL GAMCDF(XL,SHAPE1,Y2(I)) 9649 1130 CONTINUE 9650C 9651 ELSEIF(ICASPL.EQ.'BETA' .OR. ICASPL.EQ.'4BET')THEN 9652 DO1140I=1,N 9653 XL=(Y(I) - ZLOC)/ZSCALE 9654 CALL BETCDF(XL,SHAPE1,SHAPE2,Y2(I)) 9655 1140 CONTINUE 9656C 9657 ELSEIF(ICASPL.EQ.'WEIB' .OR. ICASPL.EQ.'3WEI')THEN 9658 DO1150I=1,N 9659 XL=(Y(I) - KSLOC)/KSSCAL 9660 CALL WEICDF(XL,SHAPE1,MINMAX,Y2(I)) 9661 1150 CONTINUE 9662C 9663 ELSEIF(ICASPL.EQ.'EV1 ')THEN 9664 DO1160I=1,N 9665 XL=(Y(I) - KSLOC)/KSSCAL 9666 CALL EV1CDF(XL,MINMAX,Y2(I)) 9667 1160 CONTINUE 9668C 9669 ELSEIF(ICASPL.EQ.'EV2 ' .OR. ICASPL.EQ.'3EV2')THEN 9670 DO1170I=1,N 9671 XL=(Y(I) - KSLOC)/KSSCAL 9672 CALL EV2CDF(XL,SHAPE1,MINMAX,Y2(I)) 9673 1170 CONTINUE 9674C 9675 ELSEIF(ICASPL.EQ.'PARE')THEN 9676 ZLOC=SHAPE2 9677 IF(ZLOC.GT.XMIN)ZLOC=XMIN 9678 DO1180I=1,N 9679 XL=(Y(I) - KSLOC)/KSSCAL 9680 CALL PARCDF(XL,SHAPE1,ZLOC,Y2(I)) 9681 1180 CONTINUE 9682C 9683 ELSEIF(ICASPL.EQ.'BINO')THEN 9684 IF(IFLAGD.EQ.1)GOTO8000 9685 DO1190I=1,N 9686 XL=Y(I) 9687 CALL BINCDF(DBLE(XL),DBLE(SHAPE1),INT(SHAPE2+0.1),DXOUT) 9688 Y2(I)=REAL(DXOUT) 9689 1190 CONTINUE 9690C 9691 ELSEIF(ICASPL.EQ.'GEOM')THEN 9692 IF(IFLAGD.EQ.1)GOTO8000 9693 IF(IGEODF.EQ.'DLMF')THEN 9694 DO1200I=1,N 9695 XL=Y(I) 9696 CALL GE2CDF(DBLE(XL),DBLE(SHAPE1),DXOUT) 9697 Y2(I)=REAL(DXOUT) 9698 1200 CONTINUE 9699 ELSE 9700 DO1205I=1,N 9701 XL=Y(I) 9702 CALL GEOCDF(DBLE(XL),DBLE(SHAPE1),DXOUT) 9703 Y2(I)=REAL(DXOUT) 9704 1205 CONTINUE 9705 ENDIF 9706C 9707 ELSEIF(ICASPL.EQ.'POIS')THEN 9708 IF(IFLAGD.EQ.1)GOTO8000 9709 DO1210I=1,N 9710 XL=Y(I) 9711 CALL POICDF(XL,SHAPE1,Y2(I)) 9712 1210 CONTINUE 9713C 9714 ELSEIF(ICASPL.EQ.'NEBI')THEN 9715 IF(IFLAGD.EQ.1)GOTO8000 9716 DO1220I=1,N 9717 XL=Y(I) 9718 CALL NBCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT) 9719 Y2(I)=REAL(DXOUT) 9720 1220 CONTINUE 9721C 9722 ELSEIF(ICASPL.EQ.'SEMI')THEN 9723 DO1230I=1,N 9724 XL=Y(I) - KSLOC 9725 CALL SEMCDF(XL,KSSCAL,Y2(I)) 9726 1230 CONTINUE 9727C 9728 ELSEIF(ICASPL.EQ.'TRIA')THEN 9729 IF(A.EQ.CPUMIN .OR. B.EQ.CPUMAX)THEN 9730 ZLOWLM=-1.0 9731 ZUPPLM=1.0 9732 ELSE 9733 ZLOWLM=MIN(A,B) 9734 ZUPPLM=MAX(A,B) 9735 ENDIF 9736 IF(ZLOWLM.GT.XMIN)ZLOWLM=XMIN 9737 IF(ZUPPLM.LT.XMAX)ZUPPLM=XMAX 9738 IF(SHAPE1.LT.ZLOWLM .OR. SHAPE1.GT.ZUPPLM)THEN 9739 WRITE(ICOUT,999) 9740 CALL DPWRST('XXX','BUG ') 9741 WRITE(ICOUT,31) 9742 CALL DPWRST('XXX','BUG ') 9743 WRITE(ICOUT,1343) 9744 1343 FORMAT(' FOR THE TRIANGULAR DISTRIBUTION, THE VALUE') 9745 CALL DPWRST('XXX','BUG ') 9746 WRITE(ICOUT,1344) 9747 1344 FORMAT(' OF THE SHAPE PARAMETER IS OUTSIDE THE ', 9748 1 'INTERVAL') 9749 CALL DPWRST('XXX','BUG ') 9750 WRITE(ICOUT,1345) 9751 1345 FORMAT(' OF THE LOWER AND UPPER LIMIT PARAMETERS.') 9752 CALL DPWRST('XXX','BUG ') 9753 WRITE(ICOUT,1346)SHAPE1 9754 1346 FORMAT(' THE VALUE OF THE SHAPE PARAMETER = ', 9755 1 G15.7) 9756 CALL DPWRST('XXX','BUG ') 9757 WRITE(ICOUT,1347)ZLOWLM 9758 1347 FORMAT(' THE VALUE OF THE LOWER LIMIT PARAMETER = ', 9759 1 G15.7) 9760 CALL DPWRST('XXX','BUG ') 9761 WRITE(ICOUT,1348)ZUPPLM 9762 1348 FORMAT(' THE VALUE OF THE LOWER LIMIT PARAMETER = ', 9763 1 G15.7) 9764 CALL DPWRST('XXX','BUG ') 9765 IERROR='YES' 9766 GOTO9000 9767 ENDIF 9768C 9769 DO1240I=1,N 9770 XL=Y(I) 9771 CALL TRICDF(XL,SHAPE1,ZLOWLM,ZUPPLM,Y2(I)) 9772 1240 CONTINUE 9773C 9774 ELSEIF(ICASPL.EQ.'INGA' .OR. ICASPL.EQ.'3IGA')THEN 9775 DO1250I=1,N 9776 XL=(Y(I) - KSLOC)/KSSCAL 9777 CALL IGCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DCDF) 9778 Y2(I)=REAL(DCDF) 9779 1250 CONTINUE 9780C 9781 ELSEIF(ICASPL.EQ.'WALD')THEN 9782 AMU=1.0 9783 DO1260I=1,N 9784 XL=(Y(I) - KSLOC)/KSSCAL 9785 CALL IGCDF(DBLE(XL),DBLE(SHAPE1),DBLE(AMU),DCDF) 9786 Y2(I)=REAL(DCDF) 9787 1260 CONTINUE 9788C 9789 ELSEIF(ICASPL.EQ.'RIGA')THEN 9790 DO1270I=1,N 9791 XL=(Y(I) - KSLOC)/KSSCAL 9792 CALL RIGCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DCDF) 9793 Y2(I)=REAL(DCDF) 9794 1270 CONTINUE 9795C 9796 ELSEIF(ICASPL.EQ.'FATL')THEN 9797 DO1280I=1,N 9798 XL=(Y(I) - KSLOC)/KSSCAL 9799 CALL FLCDF(XL,SHAPE1,Y2(I)) 9800 1280 CONTINUE 9801C 9802 ELSEIF(ICASPL.EQ.'GPAR')THEN 9803 DO1290I=1,N 9804 XL=(Y(I) - KSLOC)/KSSCAL 9805 CALL GEPCDF(XL,SHAPE1,MINMAX,IGEPDF,Y2(I)) 9806 1290 CONTINUE 9807C 9808 ELSEIF(ICASPL.EQ.'DUNI')THEN 9809 IF(IFLAGD.EQ.1)GOTO8000 9810 DO1300I=1,N 9811 XL=Y(I) 9812 IXL=INT(XL+0.1) 9813 CALL DISCDF(IXL,INT(SHAPE1+0.1),Y2(I)) 9814 1300 CONTINUE 9815C 9816 ELSEIF(ICASPL.EQ.'NCT ')THEN 9817 DO1310I=1,N 9818 XL=(Y(I) - KSLOC)/KSSCAL 9819 CALL NCTCDF(XL,SHAPE1,SHAPE2,Y2(I)) 9820 1310 CONTINUE 9821C 9822 ELSEIF(ICASPL.EQ.'NCF ')THEN 9823 DO1320I=1,N 9824 XL=(Y(I) - KSLOC)/KSSCAL 9825 CALL NCFCDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I)) 9826 1320 CONTINUE 9827C 9828 ELSEIF(ICASPL.EQ.'NCCS')THEN 9829 DO1330I=1,N 9830 XL=(Y(I) - KSLOC)/KSSCAL 9831 CALL NCCCDF(XL,SHAPE1,SHAPE2,Y2(I)) 9832 1330 CONTINUE 9833C 9834 ELSEIF(ICASPL.EQ.'NCBE')THEN 9835 DO1340I=1,N 9836 XL=(Y(I) - ZLOC)/ZSCALE 9837 CALL NCBCDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I)) 9838 1340 CONTINUE 9839C 9840 ELSEIF(ICASPL.EQ.'DNCT')THEN 9841 DO1350I=1,N 9842 XL=(Y(I) - KSLOC)/KSSCAL 9843 CALL DNTCDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I)) 9844 1350 CONTINUE 9845C 9846 ELSEIF(ICASPL.EQ.'DNCF')THEN 9847 DO1360I=1,N 9848 XL=(Y(I) - KSLOC)/KSSCAL 9849 CALL DNFCDF(XL,SHAPE1,SHAPE2,SHAPE3,SHAPE4,Y2(I)) 9850 1360 CONTINUE 9851C 9852 ELSEIF(ICASPL.EQ.'HYPG')THEN 9853 IF(IFLAGD.EQ.1)GOTO8000 9854 HYPPNT=.FALSE. 9855 DO1365I=1,N 9856 XL=Y(I) 9857 CALL HYPCDF(INT(XL+0.1),INT(SHAPE1+0.1),INT(SHAPE2+0.1), 9858 1 INT(SHAPE3+0.1),HYPPNT,Y2(I)) 9859 1365 CONTINUE 9860C 9861 ELSEIF(ICASPL.EQ.'VONM')THEN 9862 DO1370I=1,N 9863 XL=(Y(I) - KSLOC)/KSSCAL 9864 CALL VONCDF(XL,SHAPE1,Y2(I)) 9865 1370 CONTINUE 9866C 9867 ELSEIF(ICASPL.EQ.'POWN')THEN 9868 DO1380I=1,N 9869 XL=(Y(I) - KSLOC)/KSSCAL 9870 CALL PNRCDF(XL,SHAPE1,Y2(I)) 9871 1380 CONTINUE 9872C 9873 ELSEIF(ICASPL.EQ.'PLGN')THEN 9874 DO1390I=1,N 9875 XL=(Y(I) - KSLOC)/KSSCAL 9876 CALL PLNCDF(XL,SHAPE1,SHAPE2,Y2(I)) 9877 1390 CONTINUE 9878C 9879 ELSEIF(ICASPL.EQ.'ALPH')THEN 9880 DO1400I=1,N 9881 XL=(Y(I) - KSLOC)/KSSCAL 9882 CALL ALPCDF(DBLE(XL),DBLE(SHAPE1),DXOUT) 9883 Y2(I)=REAL(DXOUT) 9884 1400 CONTINUE 9885C 9886 ELSEIF(ICASPL.EQ.'COSI')THEN 9887 DO1410I=1,N 9888 XL=(Y(I) - KSLOC)/KSSCAL 9889 CALL COSCDF(XL,Y2(I)) 9890 1410 CONTINUE 9891C 9892 ELSEIF(ICASPL.EQ.'SINE')THEN 9893 DO1415I=1,N 9894 XL=(Y(I) - KSLOC)/KSSCAL 9895 CALL SINCDF(XL,Y2(I)) 9896 1415 CONTINUE 9897C 9898 ELSEIF(ICASPL.EQ.'POWF')THEN 9899 DO1420I=1,N 9900 XL=(Y(I) - ZLOC)/ZSCALE 9901 CALL POWCDF(XL,SHAPE1,Y2(I)) 9902 1420 CONTINUE 9903C 9904 ELSEIF(ICASPL.EQ.'CHI ')THEN 9905 DO1430I=1,N 9906 XL=(Y(I) - KSLOC)/KSSCAL 9907 CALL CHCDF(XL,SHAPE1,Y2(I)) 9908 1430 CONTINUE 9909C 9910 ELSEIF(ICASPL.EQ.'LOGS')THEN 9911 IF(IFLAGD.EQ.1)GOTO8000 9912 DO1435I=1,N 9913 XL=Y(I) 9914 CALL DLGCDF(XL,SHAPE1,Y2(I)) 9915 1435 CONTINUE 9916C 9917 ELSEIF(ICASPL.EQ.'LOGL')THEN 9918 DO1440I=1,N 9919 XL=(Y(I) - KSLOC)/KSSCAL 9920 CALL LLGCDF(XL,SHAPE1,Y2(I)) 9921 1440 CONTINUE 9922C 9923 ELSEIF(ICASPL.EQ.'GGAM')THEN 9924 DO1450I=1,N 9925 XL=(Y(I) - KSLOC)/KSSCAL 9926 CALL GGDCDF(XL,SHAPE1,SHAPE2,Y2(I)) 9927 1450 CONTINUE 9928C 9929 ELSEIF(ICASPL.EQ.'WARI')THEN 9930 IF(IFLAGD.EQ.1)GOTO8000 9931 DO1460I=1,N 9932 XL=Y(I) 9933CCCCC CALL WARCDF(XL,SHAPE1,SHAPE2,Y2(I),'NOTR') 9934 CALL WARCDF(XL,SHAPE1,SHAPE2,Y2(I)) 9935 1460 CONTINUE 9936C 9937 ELSEIF(ICASPL.EQ.'YULE')THEN 9938 IF(IFLAGD.EQ.1)GOTO8000 9939 DO1470I=1,N 9940 XL=Y(I) 9941 CALL YULCDF(DBLE(XL),DBLE(SHAPE1),DXOUT) 9942 Y2(I)=REAL(DXOUT) 9943 1470 CONTINUE 9944C 9945 ELSEIF(ICASPL.EQ.'ANGL')THEN 9946 DO1480I=1,N 9947 XL=(Y(I) - KSLOC)/KSSCAL 9948 CALL ANGCDF(XL,Y2(I)) 9949 1480 CONTINUE 9950C 9951 ELSEIF(ICASPL.EQ.'ARSI')THEN 9952 DO1490I=1,N 9953 XL=(Y(I) - KSLOC)/KSSCAL 9954 CALL ARSCDF(XL,Y2(I)) 9955 1490 CONTINUE 9956C 9957 ELSEIF(ICASPL.EQ.'FNOR')THEN 9958C 9959C FOR FOLDED NORMAL, ARE PARAMETERS GIVEN AS LOCATION/SCALE 9960C OR SHAPE1 AND SHAPE2? 9961C 9962 IF(SHAPE1.NE.CPUMIN .AND. SHAPE2.NE.CPUMIN)THEN 9963 AVAL1=SHAPE1 9964 AVAL2=SHAPE2 9965 ELSEIF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)THEN 9966 AVAL1=KSLOC 9967 AVAL2=KSSCAL 9968 ELSE 9969 AVAL1=0.0 9970 AVAL2=1.0 9971 ENDIF 9972C 9973 DO1500I=1,N 9974CCCCC XL=(Y(I) - KSLOC)/KSSCAL 9975CCCCC CALL FNRCDF(XL,KSLOC,KSSCAL,Y2(I)) 9976 XL=Y(I) 9977 CALL FNRCDF(XL,AVAL1,AVAL2,Y2(I)) 9978 1500 CONTINUE 9979C 9980 ELSEIF(ICASPL.EQ.'TNOR')THEN 9981 DO1510I=1,N 9982 XL=Y(I) 9983 CALL TNRCDF(DBLE(XL),DBLE(A),DBLE(B), 9984 1 DBLE(SHAPE1),DBLE(SHAPE2),DXOUT) 9985 Y2(I)=REAL(DXOUT) 9986 1510 CONTINUE 9987C 9988 ELSEIF(ICASPL.EQ.'LGAM')THEN 9989 DO1520I=1,N 9990 XL=(Y(I) - KSLOC)/KSSCAL 9991 CALL LGACDF(XL,SHAPE1,ILGADF,Y2(I)) 9992 1520 CONTINUE 9993C 9994 ELSEIF(ICASPL.EQ.'HSEC')THEN 9995 DO1530I=1,N 9996 XL=(Y(I) - KSLOC)/KSSCAL 9997 CALL HSECDF(XL,Y2(I)) 9998 1530 CONTINUE 9999C 10000 ELSEIF(ICASPL.EQ.'GOMP')THEN 10001 DO1540I=1,N 10002 XL=(Y(I) - KSLOC)/KSSCAL 10003 CALL GOMCDF(XL,SHAPE1,SHAPE2,IGOMDF,Y2(I)) 10004 1540 CONTINUE 10005C 10006 ELSEIF(ICASPL.EQ.'HCAU')THEN 10007 DO1550I=1,N 10008 XL=(Y(I) - KSLOC)/KSSCAL 10009 CALL HFCCDF(XL,Y2(I)) 10010 1550 CONTINUE 10011C 10012 ELSEIF(ICASPL.EQ.'HALO')THEN 10013 SHAPE1=-1.0 10014 DO1560I=1,N 10015 XL=(Y(I) - KSLOC)/KSSCAL 10016 CALL HFLCDF(XL,SHAPE1,Y2(I)) 10017 1560 CONTINUE 10018C 10019 ELSEIF(ICASPL.EQ.'GHLO')THEN 10020 DO1570I=1,N 10021 XL=(Y(I) - KSLOC)/KSSCAL 10022 CALL HFLCDF(XL,SHAPE1,Y2(I)) 10023 1570 CONTINUE 10024C 10025 ELSEIF(ICASPL.EQ.'GEV ')THEN 10026 DO1580I=1,N 10027 XL=(Y(I) - KSLOC)/KSSCAL 10028 CALL GEVCDF(XL,SHAPE1,MINMAX,Y2(I)) 10029 1580 CONTINUE 10030C 10031 ELSEIF(ICASPL.EQ.'PAR2')THEN 10032 ZLOC=SHAPE2 10033 IF(ZLOC.GT.XMIN)ZLOC=XMIN 10034 DO1590I=1,N 10035 XL=(Y(I) - KSLOC)/KSSCAL 10036 CALL PA2CDF(XL,SHAPE1,ZLOC,Y2(I)) 10037 1590 CONTINUE 10038C 10039 ELSEIF(ICASPL.EQ.'DWEI')THEN 10040 DO1600I=1,N 10041 XL=(Y(I) - KSLOC)/KSSCAL 10042 CALL DWECDF(XL,SHAPE1,Y2(I)) 10043 1600 CONTINUE 10044C 10045 ELSEIF(ICASPL.EQ.'WCAU')THEN 10046 DO1610I=1,N 10047 XL=(Y(I) - KSLOC)/KSSCAL 10048 CALL WCACDF(XL,SHAPE1,Y2(I)) 10049 1610 CONTINUE 10050C 10051 ELSEIF(ICASPL.EQ.'EWEI')THEN 10052 IARG1=1 10053 DO1620I=1,N 10054 XL=(Y(I) - KSLOC)/KSSCAL 10055 CALL EWECDF(XL,SHAPE1,SHAPE2,IARG1,Y2(I)) 10056 1620 CONTINUE 10057C 10058 ELSEIF(ICASPL.EQ.'TEXP')THEN 10059 DO1630I=1,N 10060 XL=(Y(I) - KSLOC)/KSSCAL 10061 CALL TNECDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I)) 10062 1630 CONTINUE 10063C 10064 ELSEIF(ICASPL.EQ.'GLOG')THEN 10065 DO1640I=1,N 10066 XL=(Y(I) - KSLOC)/KSSCAL 10067 CALL GLOCDF(XL,SHAPE1,Y2(I)) 10068 1640 CONTINUE 10069C 10070 ELSEIF(ICASPL.EQ.'PEXP')THEN 10071 DO1650I=1,N 10072 XL=(Y(I) - KSLOC)/KSSCAL 10073 CALL PEXCDF(DBLE(XL),DBLE(SHAPE1),DXOUT) 10074 Y2(I)=REAL(DXOUT) 10075 1650 CONTINUE 10076C 10077 ELSEIF(ICASPL.EQ.'DGAM')THEN 10078 DO1660I=1,N 10079 XL=(Y(I) - KSLOC)/KSSCAL 10080 CALL DGACDF(XL,SHAPE1,Y2(I)) 10081 1660 CONTINUE 10082C 10083 ELSEIF(ICASPL.EQ.'MBKA')THEN 10084 DO1670I=1,N 10085 XL=(Y(I) - KSLOC)/KSSCAL 10086 CALL MIECDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT) 10087 Y2(I)=REAL(DXOUT) 10088 1670 CONTINUE 10089C 10090 ELSEIF(ICASPL.EQ.'FCAU')THEN 10091 DO1680I=1,N 10092 XL=(Y(I) - KSLOC)/KSSCAL 10093 CALL FCACDF(XL,SHAPE1,SHAPE2,Y2(I)) 10094 1680 CONTINUE 10095C 10096 ELSEIF(ICASPL.EQ.'BBIN')THEN 10097 IF(IFLAGD.EQ.1)GOTO8000 10098 DO1690I=1,N 10099 XL=Y(I) 10100 CALL BBNCDF(XL,SHAPE1,SHAPE2,INT(SHAPE3+0.1),Y2(I)) 10101 1690 CONTINUE 10102C 10103 ELSEIF(ICASPL.EQ.'BRAD')THEN 10104 DO1700I=1,N 10105 XL=(Y(I) - KSLOC)/KSSCAL 10106 CALL BRACDF(XL,SHAPE1,Y2(I)) 10107 1700 CONTINUE 10108C 10109 ELSEIF(ICASPL.EQ.'GEXP')THEN 10110 DO1710I=1,N 10111 XL=(Y(I) - KSLOC)/KSSCAL 10112 CALL GEXCDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I)) 10113 1710 CONTINUE 10114C 10115 ELSEIF(ICASPL.EQ.'RECI')THEN 10116 DO1715I=1,N 10117 XL=(Y(I) - KSLOC)/KSSCAL 10118 CALL RECCDF(XL,SHAPE1,Y2(I)) 10119 1715 CONTINUE 10120C 10121 ELSEIF(ICASPL.EQ.'NORX')THEN 10122 DO1720I=1,N 10123 XL=Y(I) 10124 CALL NMXCDF(XL,SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5, 10125 1 Y2(I)) 10126 1720 CONTINUE 10127C 10128 ELSEIF(ICASPL.EQ.'IGAM')THEN 10129 DO1730I=1,N 10130 XL=(Y(I) - KSLOC)/KSSCAL 10131 CALL IGACDF(XL,SHAPE1,Y2(I)) 10132 1730 CONTINUE 10133C 10134 ELSEIF(ICASPL.EQ.'GTLA')THEN 10135 DO1740I=1,N 10136 XL=(Y(I) - KSLOC)/KSSCAL 10137 CALL GLDCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT, 10138 1 IGLDDF,IWRITE) 10139 Y2(I)=REAL(DXOUT) 10140 1740 CONTINUE 10141C 10142 ELSEIF(ICASPL.EQ.'JOSB')THEN 10143 DO1750I=1,N 10144 XL=(Y(I) - ZLOC)/ZSCALE 10145 CALL JSBCDF(XL,SHAPE1,SHAPE2,Y2(I)) 10146 1750 CONTINUE 10147C 10148 ELSEIF(ICASPL.EQ.'JOSU')THEN 10149 DO1760I=1,N 10150 XL=(Y(I) - KSLOC)/KSSCAL 10151 CALL JSUCDF(XL,SHAPE1,SHAPE2,Y2(I)) 10152 1760 CONTINUE 10153C 10154 ELSEIF(ICASPL.EQ.'IWEI')THEN 10155 DO1770I=1,N 10156 XL=(Y(I) - KSLOC)/KSSCAL 10157 CALL IWECDF(XL,SHAPE1,Y2(I)) 10158 1770 CONTINUE 10159C 10160 ELSEIF(ICASPL.EQ.'LDEX')THEN 10161 DO1780I=1,N 10162 XL=(Y(I) - KSLOC)/KSSCAL 10163 CALL LDECDF(XL,SHAPE1,Y2(I)) 10164 1780 CONTINUE 10165C 10166 ELSEIF(ICASPL.EQ.'GEEX')THEN 10167 DO1790I=1,N 10168 XL=(Y(I) - KSLOC)/KSSCAL 10169 CALL GEECDF(XL,SHAPE1,Y2(I)) 10170 1790 CONTINUE 10171C 10172 ELSEIF(ICASPL.EQ.'TSPO')THEN 10173 IF(A.EQ.CPUMIN .OR. B.EQ.CPUMAX)THEN 10174 ZLOWLM=0.0 10175 ZUPPLM=1.0 10176 ELSE 10177 ZLOWLM=MIN(A,B) 10178 ZUPPLM=MAX(A,B) 10179 ENDIF 10180 IF(ZLOWLM.GT.XMIN)ZLOWLM=XMIN 10181 IF(ZUPPLM.LT.XMAX)ZUPPLM=XMAX 10182 IF(SHAPE1.LT.ZLOWLM .OR. SHAPE1.GT.ZUPPLM)THEN 10183 WRITE(ICOUT,999) 10184 CALL DPWRST('XXX','BUG ') 10185 WRITE(ICOUT,31) 10186 CALL DPWRST('XXX','BUG ') 10187 WRITE(ICOUT,1943) 10188 1943 FORMAT(' FOR THE TWO-SIDED POWER DISTRIBUTION, THE') 10189 CALL DPWRST('XXX','BUG ') 10190 WRITE(ICOUT,1944) 10191 1944 FORMAT(' VALUE OF THE THETA SHAPE PARAMETER IS ', 10192 1 'OUTSIDE') 10193 CALL DPWRST('XXX','BUG ') 10194 WRITE(ICOUT,1945) 10195 1945 FORMAT(' INTERVAL OF THE LOWER AND UPPER LIMIT ', 10196 1 'PARAMETERS.') 10197 CALL DPWRST('XXX','BUG ') 10198 WRITE(ICOUT,1946)SHAPE1 10199 1946 FORMAT(' THE VALUE OF THE THETA SHAPE PARAMETER = ', 10200 1 G15.7) 10201 CALL DPWRST('XXX','BUG ') 10202 WRITE(ICOUT,1947)ZLOWLM 10203 1947 FORMAT(' THE VALUE OF THE LOWER LIMIT PARAMETER = ', 10204 1 G15.7) 10205 CALL DPWRST('XXX','BUG ') 10206 WRITE(ICOUT,1948)ZUPPLM 10207 1948 FORMAT(' THE VALUE OF THE LOWER LIMIT PARAMETER = ', 10208 1 G15.7) 10209 CALL DPWRST('XXX','BUG ') 10210 IERROR='YES' 10211 GOTO9000 10212 ENDIF 10213C 10214 DO1800I=1,N 10215 XL=Y(I) 10216 CALL TSPCDF(XL,SHAPE1,SHAPE2,A,B,Y2(I)) 10217 1800 CONTINUE 10218C 10219 ELSEIF(ICASPL.EQ.'BWEI')THEN 10220 DO1810I=1,N 10221 XL=(Y(I) - KSLOC)/KSSCAL 10222 CALL BWECDF(XL,SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5, 10223 1 Y2(I),DXOUT) 10224 1810 CONTINUE 10225C 10226 ELSEIF(ICASPL.EQ.'GHPP')THEN 10227 DO1820I=1,N 10228 XL=(Y(I) - KSLOC)/KSSCAL 10229 CALL GHCDF(XL,SHAPE1,SHAPE2,Y2(I)) 10230 1820 CONTINUE 10231C 10232 ELSEIF(ICASPL.EQ.'GPP')THEN 10233 HTEMP=0.0 10234 DO1821I=1,N 10235 XL=(Y(I) - KSLOC)/KSSCAL 10236 CALL GHCDF(XL,SHAPE1,HTEMP,Y2(I)) 10237 1821 CONTINUE 10238C 10239 ELSEIF(ICASPL.EQ.'HPP')THEN 10240 GTEMP=0.0 10241 DO1823I=1,N 10242 XL=(Y(I) - KSLOC)/KSSCAL 10243 CALL GHCDF(XL,GTEMP,SHAPE1,Y2(I)) 10244 1823 CONTINUE 10245C 10246 ELSEIF(ICASPL.EQ.'LAND')THEN 10247 DO1830I=1,N 10248 XL=(Y(I) - KSLOC)/KSSCAL 10249 DXOUT=LANCDF(DBLE(XL)) 10250 Y2(I)=REAL(DXOUT) 10251 1830 CONTINUE 10252C 10253 ELSEIF(ICASPL.EQ.'ERRO')THEN 10254 DO1840I=1,N 10255 XL=(Y(I) - KSLOC)/KSSCAL 10256 CALL ERRCDF(XL,SHAPE1,Y2(I)) 10257 1840 CONTINUE 10258C 10259 ELSEIF(ICASPL.EQ.'TRAP')THEN 10260 DO1850I=1,N 10261 XL=(Y(I) - KSLOC)/KSSCAL 10262 CALL TRACDF(XL,SHAPE1,SHAPE2,SHAPE3,SHAPE4,Y2(I)) 10263 1850 CONTINUE 10264C 10265 ELSEIF(ICASPL.EQ.'GTRA')THEN 10266 DO1860I=1,N 10267 XL=(Y(I) - KSLOC)/KSSCAL 10268 CALL GTRCDF(XL,SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5, 10269 1 SHAPE6,SHAPE7,Y2(I)) 10270 1860 CONTINUE 10271C 10272 ELSEIF(ICASPL.EQ.'FT ')THEN 10273 DO1870I=1,N 10274 XL=(Y(I) - KSLOC)/KSSCAL 10275 CALL FTCDF(XL,INT(SHAPE1+0.1),Y2(I)) 10276 1870 CONTINUE 10277C 10278 ELSEIF(ICASPL.EQ.'SLAS')THEN 10279 DO1880I=1,N 10280 XL=(Y(I) - KSLOC)/KSSCAL 10281 CALL SLACDF(XL,Y2(I)) 10282 1880 CONTINUE 10283C 10284 ELSEIF(ICASPL.EQ.'SNOR')THEN 10285 DO1890I=1,N 10286 XL=(Y(I) - KSLOC)/KSSCAL 10287 CALL SNCDF(XL,SHAPE1,ISKNDF,Y2(I)) 10288 1890 CONTINUE 10289C 10290 ELSEIF(ICASPL.EQ.'TSKE')THEN 10291 DO1900I=1,N 10292 XL=(Y(I) - KSLOC)/KSSCAL 10293 CALL STCDF(XL,INT(SHAPE1+0.1),SHAPE2,Y2(I)) 10294 1900 CONTINUE 10295C 10296 ELSEIF(ICASPL.EQ.'IBET')THEN 10297 DO1910I=1,N 10298 XL=(Y(I) - KSLOC)/KSSCAL 10299 CALL IBCDF(XL,SHAPE1,SHAPE2,Y2(I)) 10300 1910 CONTINUE 10301C 10302 ELSEIF(ICASPL.EQ.'GOMM')THEN 10303 IF(IMAKDF.EQ.'DLMF')THEN 10304 DO1930I=1,N 10305 XL=(Y(I) - KSLOC)/KSSCAL 10306 CALL MAKCDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I)) 10307 1930 CONTINUE 10308 ELSEIF(IMAKDF.EQ.'MEEK')THEN 10309 XI=SHAPE1/SHAPE3 10310 THETA=SHAPE2/SHAPE1 10311 ALAMB=SHAPE3 10312 DO1935I=1,N 10313 XL=(Y(I) - KSLOC)/KSSCAL 10314 CALL MAKCDF(XL,XI,ALAMBA,THETA,Y2(I)) 10315 1935 CONTINUE 10316 ELSEIF(IMAKDF.EQ.'REPA')THEN 10317 DO1938I=1,N 10318 XL=(Y(I) - KSLOC)/KSSCAL 10319 CALL MA2CDF(XL,SHAPE1,SHAPE2,Y2(I)) 10320 1938 CONTINUE 10321 ENDIF 10322C 10323 ELSEIF(ICASPL.EQ.'LSNO')THEN 10324 DO1940I=1,N 10325 XL=(Y(I) - KSLOC)/KSSCAL 10326 CALL LSNCDF(XL,SHAPE1,SHAPE2,Y2(I)) 10327 1940 CONTINUE 10328C 10329 ELSEIF(ICASPL.EQ.'LSKT')THEN 10330 DO1950I=1,N 10331 XL=(Y(I) - KSLOC)/KSSCAL 10332 CALL LSTCDF(XL,INT(SHAPE1+0.1),SHAPE2,SHAPE3,Y2(I)) 10333 1950 CONTINUE 10334C 10335 ELSEIF(ICASPL.EQ.'POLY')THEN 10336 DO1960I=1,N 10337 XL=(Y(I) - KSLOC)/KSSCAL 10338 CALL POLCDF(XL,SHAPE1,SHAPE2,INT(SHAPE3+0.1),Y2(I)) 10339 1960 CONTINUE 10340C 10341 ELSEIF(ICASPL.EQ.'HERM')THEN 10342 IF(IFLAGD.EQ.1)GOTO8000 10343 DO1970I=1,N 10344 XL=(Y(I) - KSLOC)/KSSCAL 10345 CALL HERCDF(XL,SHAPE1,SHAPE2,Y2(I)) 10346 1970 CONTINUE 10347C 10348 ELSEIF(ICASPL.EQ.'SDEX')THEN 10349 DO1980I=1,N 10350 XL=(Y(I) - KSLOC)/KSSCAL 10351 CALL SDECDF(XL,SHAPE1,Y2(I)) 10352 1980 CONTINUE 10353C 10354 ELSEIF(ICASPL.EQ.'ADEX')THEN 10355 DO1990I=1,N 10356 XL=(Y(I) - KSLOC)/KSSCAL 10357 CALL ADECDF(XL,SHAPE1,IADEDF,Y2(I)) 10358 1990 CONTINUE 10359C 10360 ELSEIF(ICASPL.EQ.'MAXW' .OR. ICASPL.EQ.'1MAX')THEN 10361 AVAL1=KSLOC 10362 IF(ICASPL.EQ.'1MAX')AVAL1=0.0 10363 DO2000I=1,N 10364 XL=(Y(I) - KSLOC)/KSSCAL 10365 CALL MAXCDF(XL,Y2(I)) 10366 2000 CONTINUE 10367C 10368 ELSEIF(ICASPL.EQ.'RAYL')THEN 10369 DO2010I=1,N 10370 XL=(Y(I) - KSLOC)/KSSCAL 10371 CALL RAYCDF(XL,Y2(I)) 10372 2010 CONTINUE 10373C 10374 ELSEIF(ICASPL.EQ.'GIGA')THEN 10375 IF(IGIGDF.EQ.'2PAR')THEN 10376 DO2020I=1,N 10377 XL=(Y(I) - KSLOC)/KSSCAL 10378 CALL GI2CDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT) 10379 Y2(I)=REAL(DXOUT) 10380 2020 CONTINUE 10381 ELSE 10382 DO2030I=1,N 10383 XL=(Y(I) - KSLOC)/KSSCAL 10384 CALL GIGCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2), 10385 1 DBLE(SHAPE3),DXOUT) 10386 Y2(I)=REAL(DXOUT) 10387 2030 CONTINUE 10388 ENDIF 10389C 10390 ELSEIF(ICASPL.EQ.'GALP')THEN 10391 DO2040I=1,N 10392 XL=(Y(I) - KSLOC)/KSSCAL 10393 CALL GALCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),IADEDF,DXOUT) 10394 Y2(I)=REAL(DXOUT) 10395 2040 CONTINUE 10396C 10397 ELSEIF(ICASPL.EQ.'MCLE')THEN 10398 DO2050I=1,N 10399 XL=(Y(I) - KSLOC)/KSSCAL 10400 CALL MCLCDF(DBLE(XL),DBLE(SHAPE1),DXOUT) 10401 Y2(I)=REAL(DXOUT) 10402 2050 CONTINUE 10403C 10404 ELSEIF(ICASPL.EQ.'BEIP')THEN 10405 DO2060I=1,N 10406 XL=(Y(I) - KSLOC)/KSSCAL 10407 CALL BEICDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DBLE(SHAPE3), 10408 1 IBEIDF,DXOUT) 10409 Y2(I)=REAL(DXOUT) 10410 2060 CONTINUE 10411C 10412 ELSEIF(ICASPL.EQ.'BEIK')THEN 10413 DO2070I=1,N 10414 XL=(Y(I) - KSLOC)/KSSCAL 10415CCCCC CALL BEKCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DBLE(SHAPE3), 10416CCCCC1 IBEIDF,DXOUT) 10417CCCCC Y2(I)=REAL(DXOUT) 10418 Y2(I)=0.0 10419 2070 CONTINUE 10420C 10421 ELSEIF(ICASPL.EQ.'GMCL')THEN 10422 DO2080I=1,N 10423 XL=(Y(I) - KSLOC)/KSSCAL 10424 CALL GMCCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT) 10425 Y2(I)=REAL(DXOUT) 10426 2080 CONTINUE 10427C 10428 ELSEIF(ICASPL.EQ.'G5LO')THEN 10429 XPAR(1)=DBLE(KSLOC) 10430 XPAR(2)=DBLE(KSSCAL) 10431 XPAR(3)=DBLE(SHAPE1) 10432 DO2090I=1,N 10433 XL=Y(I) 10434 DXOUT=CDFGLO(DBLE(XL),XPAR) 10435 Y2(I)=REAL(DXOUT) 10436 2090 CONTINUE 10437C 10438 ELSEIF(ICASPL.EQ.'WAKE')THEN 10439 XPAR(1)=DBLE(KSLOC) 10440 XPAR(2)=DBLE(KSSCAL) 10441 XPAR(3)=DBLE(SHAPE1) 10442 XPAR(4)=DBLE(SHAPE2) 10443 XPAR(5)=DBLE(SHAPE3) 10444 DO2100I=1,N 10445 XL=Y(I) 10446 DXOUT=CDFWAK(DBLE(XL),XPAR) 10447 Y2(I)=REAL(DXOUT) 10448 2100 CONTINUE 10449C 10450 ELSEIF(ICASPL.EQ.'BNOR')THEN 10451 DO2110I=1,N 10452 XL=(Y(I) - KSLOC)/KSSCAL 10453 CALL BNOCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT) 10454 Y2(I)=REAL(DXOUT) 10455 2110 CONTINUE 10456C 10457 ELSEIF(ICASPL.EQ.'G2LO')THEN 10458 DO2120I=1,N 10459 XL=(Y(I) - KSLOC)/KSSCAL 10460 CALL GL2CDF(DBLE(XL),DBLE(SHAPE1),DXOUT) 10461 Y2(I)=REAL(DXOUT) 10462 2120 CONTINUE 10463C 10464 ELSEIF(ICASPL.EQ.'G3LO')THEN 10465 DO2130I=1,N 10466 XL=(Y(I) - KSLOC)/KSSCAL 10467 CALL GL3CDF(DBLE(XL),DBLE(SHAPE1),DXOUT) 10468 Y2(I)=REAL(DXOUT) 10469 2130 CONTINUE 10470C 10471 ELSEIF(ICASPL.EQ.'G4LO')THEN 10472 DO2140I=1,N 10473 XL=(Y(I) - KSLOC)/KSSCAL 10474 CALL GL4CDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT) 10475 Y2(I)=REAL(DXOUT) 10476 2140 CONTINUE 10477C 10478 ELSEIF(ICASPL.EQ.'ALDE')THEN 10479 DO2150I=1,N 10480 XL=(Y(I) - KSLOC)/KSSCAL 10481 CALL ALDCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT) 10482 Y2(I)=REAL(DXOUT) 10483 2150 CONTINUE 10484C 10485 ELSEIF(ICASPL.EQ.'BGEO')THEN 10486 IF(IFLAGD.EQ.1)GOTO8000 10487 IF(IBGEDF.EQ.'UNSH')THEN 10488 DO2160I=1,N 10489 XL=Y(I) 10490 CALL BGECDF(XL,SHAPE1,SHAPE2,Y2(I)) 10491 2160 CONTINUE 10492 ELSE 10493 DO2165I=1,N 10494 XL=Y(I) 10495 CALL BG2CDF(XL,SHAPE1,SHAPE2,Y2(I)) 10496 2165 CONTINUE 10497 ENDIF 10498C 10499 ELSEIF(ICASPL.EQ.'ZETA')THEN 10500 IF(IFLAGD.EQ.1)GOTO8000 10501 DO2170I=1,N 10502 XL=Y(I) 10503 CALL ZETCDF(XL,SHAPE1,Y2(I)) 10504 2170 CONTINUE 10505C 10506 ELSEIF(ICASPL.EQ.'ZIPF')THEN 10507 IF(IFLAGD.EQ.1)GOTO8000 10508 DO2180I=1,N 10509 XL=Y(I) 10510 CALL ZIPCDF(XL,SHAPE1,INT(SHAPE2+0.1),Y2(I)) 10511 2180 CONTINUE 10512C 10513 ELSEIF(ICASPL.EQ.'BTAN')THEN 10514 IF(IFLAGD.EQ.1)GOTO8000 10515 DO2190I=1,N 10516 XL=Y(I) 10517 CALL BTACDF(XL,SHAPE1,SHAPE2,Y2(I)) 10518 2190 CONTINUE 10519C 10520 ELSEIF(ICASPL.EQ.'BNBI')THEN 10521 IF(IFLAGD.EQ.1)GOTO8000 10522 DO2200I=1,N 10523 XL=Y(I) 10524 CALL GWACDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2), 10525 1 DBLE(SHAPE3),DXOUT) 10526 Y2(I)=REAL(DXOUT) 10527 2200 CONTINUE 10528C 10529 ELSEIF(ICASPL.EQ.'LPOI')THEN 10530 IF(IFLAGD.EQ.1)GOTO8000 10531 DO2210I=1,N 10532 XL=Y(I) 10533 CALL LPOCDF(XL,SHAPE1,SHAPE2,Y2(I)) 10534 2210 CONTINUE 10535C 10536 ELSEIF(ICASPL.EQ.'LICT')THEN 10537 IF(IFLAGD.EQ.1)GOTO8000 10538 DO2220I=1,N 10539 XL=Y(I) 10540 CALL LCTCDF(XL,INT(SHAPE1+0.1),Y2(I)) 10541 2220 CONTINUE 10542C 10543 ELSEIF(ICASPL.EQ.'MATC')THEN 10544 IF(IFLAGD.EQ.1)GOTO8000 10545 DO2230I=1,N 10546 XL=Y(I) 10547 CALL MATCDF(XL,INT(SHAPE1+0.1),Y2(I)) 10548 2230 CONTINUE 10549C 10550 ELSEIF(ICASPL.EQ.'LBET')THEN 10551 YLOWLM=SHAPE3 10552 YUPPLM=SHAPE4 10553 EPS=(XMAX-XMIN)*0.01 10554 IF(YLOWLM.GT.XMIN)YLOWLM=XMIN-EPS 10555 IF(YUPPLM.LT.XMAX)YUPPLM=XMAX+EPS 10556 DO2240I=1,N 10557 XL=(Y(I) - KSLOC)/KSSCAL 10558 CALL LBECDF(XL,SHAPE1,SHAPE2,YLOWLM,YUPPLM,Y2(I)) 10559 2240 CONTINUE 10560C 10561 ELSEIF(ICASPL.EQ.'AEPP')THEN 10562 IF(IFLAGD.EQ.1)GOTO8000 10563 DO2250I=1,N 10564 XL=Y(I) 10565 CALL PAPCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT) 10566 Y2(I)=REAL(DXOUT) 10567 2250 CONTINUE 10568C 10569 ELSEIF(ICASPL.EQ.'GLOS')THEN 10570 IF(IFLAGD.EQ.1)GOTO8000 10571 DO2270I=1,N 10572 XL=Y(I) 10573 CALL GLSCDF(XL,SHAPE1,SHAPE2,Y2(I)) 10574 2270 CONTINUE 10575C 10576 ELSEIF(ICASPL.EQ.'GNBI')THEN 10577 IF(IFLAGD.EQ.1)GOTO8000 10578 DO2280I=1,N 10579 XL=Y(I) 10580 CALL GNBCDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I)) 10581 2280 CONTINUE 10582C 10583 ELSEIF(ICASPL.EQ.'GEET')THEN 10584 IF(IFLAGD.EQ.1)GOTO8000 10585 DO2290I=1,N 10586 XL=Y(I) 10587 CALL GETCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2), 10588 1 IGETDF,DXOUT) 10589 Y2(I)=REAL(DXOUT) 10590 2290 CONTINUE 10591C 10592 ELSEIF(ICASPL.EQ.'QBIN')THEN 10593 IF(IFLAGD.EQ.1)GOTO8000 10594 DO2300I=1,N 10595 XL=Y(I) 10596 CALL QBICDF(XL,SHAPE1,SHAPE2,SHAPE3,Y2(I)) 10597 2300 CONTINUE 10598C 10599 ELSEIF(ICASPL.EQ.'CONS')THEN 10600 IF(IFLAGD.EQ.1)GOTO8000 10601 DO2310I=1,N 10602 XL=Y(I) 10603 CALL CONCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2), 10604 1 ICONDF,DXOUT) 10605 Y2(I)=REAL(DXOUT) 10606 2310 CONTINUE 10607C 10608 ELSEIF(ICASPL.EQ.'LKAT')THEN 10609 IF(IFLAGD.EQ.1)GOTO8000 10610 DO2320I=1,N 10611 XL=Y(I) 10612 CALL LKCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2), 10613 1 DBLE(SHAPE3),DXOUT) 10614 Y2(I)=REAL(DXOUT) 10615 2320 CONTINUE 10616C 10617 ELSEIF(ICASPL.EQ.'KATZ')THEN 10618 IF(IFLAGD.EQ.1)GOTO8000 10619 DO2330I=1,N 10620 XL=Y(I) 10621 CALL KATCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),IKATDF,DXOUT) 10622 Y2(I)=REAL(DXOUT) 10623 2330 CONTINUE 10624C 10625 ELSEIF(ICASPL.EQ.'DISW')THEN 10626 IF(IFLAGD.EQ.1)GOTO8000 10627 DO2340I=1,N 10628 XL=Y(I) 10629 CALL DIWCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT) 10630 Y2(I)=REAL(DXOUT) 10631 2340 CONTINUE 10632C 10633 ELSEIF(ICASPL.EQ.'GLGP')THEN 10634 IF(IFLAGD.EQ.1)GOTO8000 10635 DO2350I=1,N 10636 XL=Y(I) 10637 CALL GLGCDF(XL,SHAPE1,INT(SHAPE2+0.1),SHAPE3,Y2(I)) 10638 2350 CONTINUE 10639C 10640 ELSEIF(ICASPL.EQ.'TGNB')THEN 10641 IF(IFLAGD.EQ.1)GOTO8000 10642 DO2360I=1,N 10643 XL=Y(I) 10644 CALL GNTCDF(XL,SHAPE1,SHAPE2,SHAPE3,INT(SHAPE4+0.1),Y2(I)) 10645 2360 CONTINUE 10646C 10647 ELSEIF(ICASPL.EQ.'TOPL')THEN 10648 DO2370I=1,N 10649 XL=(Y(I) - KSLOC)/KSSCAL 10650 CALL TOPCDF(DBLE(XL),DBLE(SHAPE1),DXOUT) 10651 Y2(I)=REAL(DXOUT) 10652 2370 CONTINUE 10653C 10654 ELSEIF(ICASPL.EQ.'GTOL')THEN 10655 DO2380I=1,N 10656 XL=Y(I) 10657 CALL GTLCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2), 10658 1 DBLE(A),DBLE(B),DXOUT) 10659 Y2(I)=REAL(DXOUT) 10660 2380 CONTINUE 10661C 10662 ELSEIF(ICASPL.EQ.'RGTL')THEN 10663 DO2390I=1,N 10664 XL=Y(I) 10665 CALL RGTCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2), 10666 1 DBLE(A),DBLE(B),DXOUT) 10667 Y2(I)=REAL(DXOUT) 10668 2390 CONTINUE 10669C 10670 ELSEIF(ICASPL.EQ.'SLOP')THEN 10671 DO2400I=1,N 10672 XL=(Y(I) - ZLOC)/ZSCALE 10673 CALL SLOCDF(XL,SHAPE1,Y2(I)) 10674 2400 CONTINUE 10675C 10676 ELSEIF(ICASPL.EQ.'OGIV')THEN 10677 DO2410I=1,N 10678 XL=(Y(I) - ZLOC)/ZSCALE 10679 CALL OGICDF(DBLE(XL),DBLE(SHAPE1),DXOUT) 10680 Y2(I)=REAL(DXOUT) 10681 2410 CONTINUE 10682C 10683 ELSEIF(ICASPL.EQ.'TSSL')THEN 10684 DO2420I=1,N 10685 XL=Y(I) 10686 CALL TSSCDF(XL,SHAPE1,SHAPE2, 10687 1 A,B,Y2(I)) 10688 2420 CONTINUE 10689C 10690 ELSEIF(ICASPL.EQ.'TSOG')THEN 10691 DO2430I=1,N 10692 XL=Y(I) 10693 CALL TSOCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2), 10694 1 DBLE(A),DBLE(B),DXOUT) 10695 Y2(I)=REAL(DXOUT) 10696 2430 CONTINUE 10697C 10698 ELSEIF(ICASPL.EQ.'BUR2')THEN 10699 DO2450I=1,N 10700 XL=(Y(I) - KSLOC)/KSSCAL 10701 CALL BU2CDF(DBLE(XL),DBLE(SHAPE1),DXOUT) 10702 Y2(I)=REAL(DXOUT) 10703 2450 CONTINUE 10704C 10705 ELSEIF(ICASPL.EQ.'BUR3')THEN 10706 DO2460I=1,N 10707 XL=(Y(I) - KSLOC)/KSSCAL 10708 CALL BU3CDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT) 10709 Y2(I)=REAL(DXOUT) 10710 2460 CONTINUE 10711C 10712 ELSEIF(ICASPL.EQ.'BUR4')THEN 10713 DO2470I=1,N 10714 XL=(Y(I) - KSLOC)/KSSCAL 10715 CALL BU4CDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT) 10716 Y2(I)=REAL(DXOUT) 10717 2470 CONTINUE 10718C 10719 ELSEIF(ICASPL.EQ.'BUR5')THEN 10720 DO2480I=1,N 10721 XL=(Y(I) - KSLOC)/KSSCAL 10722 CALL BU5CDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT) 10723 Y2(I)=REAL(DXOUT) 10724 2480 CONTINUE 10725C 10726 ELSEIF(ICASPL.EQ.'BUR6')THEN 10727 DO2490I=1,N 10728 XL=(Y(I) - KSLOC)/KSSCAL 10729 CALL BU6CDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT) 10730 Y2(I)=REAL(DXOUT) 10731 2490 CONTINUE 10732C 10733 ELSEIF(ICASPL.EQ.'BUR7')THEN 10734 DO2500I=1,N 10735 XL=(Y(I) - KSLOC)/KSSCAL 10736 CALL BU7CDF(DBLE(XL),DBLE(SHAPE1),DXOUT) 10737 Y2(I)=REAL(DXOUT) 10738 2500 CONTINUE 10739C 10740 ELSEIF(ICASPL.EQ.'BUR8')THEN 10741 DO2510I=1,N 10742 XL=(Y(I) - KSLOC)/KSSCAL 10743 CALL BU8CDF(DBLE(XL),DBLE(SHAPE1),DXOUT) 10744 Y2(I)=REAL(DXOUT) 10745 2510 CONTINUE 10746C 10747 ELSEIF(ICASPL.EQ.'BUR9')THEN 10748 DO2520I=1,N 10749 XL=(Y(I) - KSLOC)/KSSCAL 10750 CALL BU9CDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT) 10751 Y2(I)=REAL(DXOUT) 10752 2520 CONTINUE 10753C 10754 ELSEIF(ICASPL.EQ.'BU10' .OR. ICASPL.EQ.'B10' .OR. 10755 1 ICASPL.EQ.'3B10')THEN 10756 DO2530I=1,N 10757 XL=(Y(I) - KSLOC)/KSSCAL 10758 CALL B10CDF(DBLE(XL),DBLE(SHAPE1),DXOUT) 10759 Y2(I)=REAL(DXOUT) 10760 2530 CONTINUE 10761C 10762 ELSEIF(ICASPL.EQ.'BU11')THEN 10763 DO2540I=1,N 10764 XL=(Y(I) - KSLOC)/KSSCAL 10765 CALL B11CDF(DBLE(XL),DBLE(SHAPE1),DXOUT) 10766 Y2(I)=REAL(DXOUT) 10767 2540 CONTINUE 10768C 10769 ELSEIF(ICASPL.EQ.'BU12')THEN 10770 DO2550I=1,N 10771 XL=(Y(I) - KSLOC)/KSSCAL 10772 CALL B12CDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT) 10773 Y2(I)=REAL(DXOUT) 10774 2550 CONTINUE 10775C 10776 ELSEIF(ICASPL.EQ.'DPUN')THEN 10777 DO2560I=1,N 10778 XL=(Y(I) - KSLOC)/KSSCAL 10779 CALL DPUCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2), 10780 1 DBLE(SHAPE3),DBLE(SHAPE4),DXOUT) 10781 Y2(I)=REAL(DXOUT) 10782 2560 CONTINUE 10783C 10784 ELSEIF(ICASPL.EQ.'KUMA')THEN 10785 DO2570I=1,N 10786 XL=(Y(I) - ZLOC)/ZSCALE 10787 CALL KUMCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT) 10788 Y2(I)=REAL(DXOUT) 10789 2570 CONTINUE 10790C 10791 ELSEIF(ICASPL.EQ.'RPOW')THEN 10792 DO2580I=1,N 10793 XL=(Y(I) - ZLOC)/ZSCALE 10794 CALL RPOCDF(XL,SHAPE1,Y2(I)) 10795 2580 CONTINUE 10796C 10797 ELSEIF(ICASPL.EQ.'UTSP')THEN 10798 DO2590I=1,N 10799 XL=Y(I) 10800 CALL UTSCDF(XL,SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5, 10801 1 SHAPE6,Y2(I)) 10802 2590 CONTINUE 10803C 10804 ELSEIF(ICASPL.EQ.'MUTH')THEN 10805 DO2600I=1,N 10806 XL=(Y(I) - KSLOC)/KSSCAL 10807 CALL MUTCDF(DBLE(XL),DBLE(SHAPE1),DXOUT) 10808 Y2(I)=REAL(DXOUT) 10809 2600 CONTINUE 10810C 10811 ELSEIF(ICASPL.EQ.'LEXP')THEN 10812 DO2610I=1,N 10813 XL=(Y(I) - KSLOC)/KSSCAL 10814 CALL LEXCDF(DBLE(XL),DBLE(SHAPE1),DXOUT) 10815 Y2(I)=REAL(DXOUT) 10816 2610 CONTINUE 10817C 10818 ELSEIF(ICASPL.EQ.'TPAR')THEN 10819 DO2620I=1,N 10820 XL=(Y(I) - KSLOC)/KSSCAL 10821 CALL TNPCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2), 10822 1 DBLE(SHAPE3),DXOUT) 10823 Y2(I)=REAL(DXOUT) 10824 2620 CONTINUE 10825C 10826 ELSEIF(ICASPL.EQ.'BFRA')THEN 10827 DO2630I=1,N 10828 XL=(Y(I) - KSLOC)/KSSCAL 10829 CALL BFRCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2), 10830 1 DBLE(SHAPE3),DXOUT) 10831 Y2(I)=REAL(DXOUT) 10832 2630 CONTINUE 10833C 10834 ELSEIF(ICASPL.EQ.'L3EX')THEN 10835 DO2640I=1,N 10836 XL=(Y(I) - KSLOC)/KSSCAL 10837 CALL LE3CDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2), 10838 1 DBLE(SHAPE3),DXOUT) 10839 Y2(I)=REAL(DXOUT) 10840 2640 CONTINUE 10841C 10842 ELSEIF(ICASPL.EQ.'KAPP')THEN 10843 DO2650I=1,N 10844 XL=(Y(I) - KSLOC)/KSSCAL 10845 CALL KAPCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2), 10846 1 DBLE(KSLOC),DBLE(KSSCAL),DXOUT) 10847 Y2(I)=REAL(DXOUT) 10848 2650 CONTINUE 10849C 10850 ELSEIF(ICASPL.EQ.'PEA3')THEN 10851 DO2660I=1,N 10852 XL=(Y(I) - KSLOC)/KSSCAL 10853 CALL PE3CDF(DBLE(XL),DBLE(SHAPE1), 10854 1 DBLE(KSLOC),DBLE(KSSCAL),DXOUT) 10855 Y2(I)=REAL(DXOUT) 10856 2660 CONTINUE 10857C 10858 ELSEIF(ICASPL.EQ.'EEWE')THEN 10859 DO2670I=1,N 10860 XL=Y(I) 10861 CALL EEWCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DBLE(SHAPE3), 10862 1 DBLE(SHAPE4),DBLE(SHAPE5),DXOUT) 10863 Y2(I)=REAL(DXOUT) 10864 2670 CONTINUE 10865C 10866 ELSEIF(ICASPL.EQ.'BFWE')THEN 10867 DO2680I=1,N 10868 XL=(Y(I) - KSLOC)/KSSCAL 10869 CALL BFWCDF(DBLE(XL),DBLE(SHAPE1),DBLE(SHAPE2),DXOUT) 10870 Y2(I)=REAL(DXOUT) 10871 2680 CONTINUE 10872 ELSE 10873 WRITE(ICOUT,999) 10874 CALL DPWRST('XXX','BUG ') 10875 WRITE(ICOUT,31) 10876 CALL DPWRST('XXX','BUG ') 10877 WRITE(ICOUT,8011)ICASPL 10878 8011 FORMAT(' UNKNOWN DISTRIBUTION -- ',A40) 10879 CALL DPWRST('XXX','BUG ') 10880 IERROR='YES' 10881 GOTO9000 10882 ENDIF 10883C 10884 GOTO9000 10885C 10886C SET AN ERROR FLAG TO INDICATE A DISCRETE DISTRIBUTION 10887C IS NOT TO BE PROCESSED. 10888C 10889 8000 CONTINUE 10890 IFLAGD=99 10891 GOTO9000 10892C 10893C ***************** 10894C ** STEP 90-- ** 10895C ** EXIT ** 10896C ***************** 10897C 10898 9000 CONTINUE 10899 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CDF1')THEN 10900 WRITE(ICOUT,999) 10901 CALL DPWRST('XXX','BUG ') 10902 WRITE(ICOUT,9011) 10903 9011 FORMAT('***** AT THE END OF DPCDF1--') 10904 CALL DPWRST('XXX','BUG ') 10905 WRITE(ICOUT,9012)ICASPL,N,MINMAX,IERROR 10906 9012 FORMAT('ICASPL,N,MINMAX,IERROR = ',A4,2X,2I8,2X,A4) 10907 CALL DPWRST('XXX','BUG ') 10908 DO9020I=1,N 10909 WRITE(ICOUT,9021)I,Y(I),Y2(I) 10910 9021 FORMAT('I,Y(I),Y2(I), = ',I8,2G15.7) 10911 CALL DPWRST('XXX','BUG ') 10912 9020 CONTINUE 10913 ENDIF 10914C 10915 RETURN 10916 END 10917 SUBROUTINE DPCHAL(ICHAR2,ICHARN,IBUGXX,IFOUND) 10918C 10919C PURPOSE--CONVERT AN ALPHABETIC CHARACTER 10920C (A TO Z) INTO A NUMERIC VALUE 10921C (1 TO 26). 10922C INPUT ARGUMENTS--ICHAR2 (A HOLLERITH VARIABLE 10923C CONTAINING THE HOLLERITH 10924C CHARACTER(S) OF INTEREST. 10925C OUTPUT ARGUMENTS--ICHARN (AN INTEGER VARIABLE 10926C CONTAINING THE NUMERIC 10927C DESIGNATION FOR THE 10928C ALPHABETIC CHARACTER. 10929C WRITTEN BY--JAMES J. FILLIBEN 10930C STATISTICAL ENGINEERING DIVISION 10931C INFORMATION TECHNOLOGY LABORATORY 10932C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10933C GAITHERSBURG, MD 20899-8980 10934C PHONE--301-975-2899 10935C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 10936C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 10937C LANGUAGE--ANSI FORTRAN (1977) 10938C VERSION NUMBER--82/7 10939C ORIGINAL VERSION--MARCH 1981. 10940C UPDATED --NOVEMBER 1981. 10941C UPDATED --MAY 1982. 10942C 10943C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10944C 10945 CHARACTER*4 ICHAR2 10946 CHARACTER*4 IBUGXX 10947 CHARACTER*4 IFOUND 10948C 10949 CHARACTER*1 ICH1 10950 CHARACTER*1 ICH2 10951C 10952C-----COMMON---------------------------------------------------------- 10953C 10954 INCLUDE 'DPCOBE.INC' 10955C 10956C-----COMMON VARIABLES (GENERAL)-------------------------------------- 10957C 10958 INCLUDE 'DPCOP2.INC' 10959C 10960C-----START POINT----------------------------------------------------- 10961C 10962 IFOUND='NO' 10963 ICH1='-' 10964 ICH2='-' 10965C 10966 ICH1N=(-999) 10967 ICH2N=(-999) 10968C 10969 IF(IBUGXX.EQ.'ON' .OR. ISUBG4.EQ.'CHAL')THEN 10970 WRITE(ICOUT,999) 10971 999 FORMAT(1X) 10972 CALL DPWRST('XXX','BUG ') 10973 WRITE(ICOUT,51) 10974 51 FORMAT('***** AT THE BEGINNING OF DPCHAL--') 10975 CALL DPWRST('XXX','BUG ') 10976 WRITE(ICOUT,59)IBUGXX,IBUGG4,ISUBG4,ICHAR2 10977 59 FORMAT('IBUGXX,IBUGXX,ISUBG4,ICHAR2 = ',2(A4,2X),A4) 10978 CALL DPWRST('XXX','BUG ') 10979 ENDIF 10980C 10981C ********************************** 10982C ** STEP 1-- ** 10983C ** CONVERT THE CHARACTER ** 10984C ********************************** 10985C 10986 ICH2(1:1)=ICHAR2(2:2) 10987CCCCC ICH2N=ICHAR(ICH2) 10988 CALL DPCOAN(ICH2,ICH2N) 10989 IF(ICH2N.EQ.32)GOTO1100 10990 GOTO7900 10991C 10992 1100 CONTINUE 10993 ICH1(1:1)=ICHAR2(1:1) 10994CCCCC ICH1N=ICHAR(ICH1) 10995 CALL DPCOAN(ICH1,ICH1N) 10996 ICHARN=ICH1N-64 10997 IF(1.LE.ICHARN.AND.ICHARN.LE.26)GOTO8000 10998 GOTO7900 10999C 11000 7900 CONTINUE 11001CCCCC WRITE(ICOUT,999) 11002CCCCC CALL DPWRST('XXX','BUG ') 11003CCCCC WRITE(ICOUT,7911) 11004C7911 FORMAT('***** ERROR IN DPCHAL--') 11005CCCCC CALL DPWRST('XXX','BUG ') 11006CCCCC WRITE(ICOUT,7912) 11007C7912 FORMAT(' NO MATCH FOUND FOR INPUT CHARACTER.') 11008CCCCC CALL DPWRST('XXX','BUG ') 11009CCCCC WRITE(ICOUT,7913)ICHAR 11010C7913 FORMAT(' INPUT CHARACTER = ',A4) 11011CCCCC CALL DPWRST('XXX','BUG ') 11012 IFOUND='NO' 11013 GOTO9000 11014C 11015 8000 CONTINUE 11016 IFOUND='YES' 11017 GOTO9000 11018C 11019C ***************** 11020C ** STEP 90-- ** 11021C ** EXIT ** 11022C ***************** 11023C 11024 9000 CONTINUE 11025 IF(IBUGXX.EQ.'ON' .OR. ISUBG4.EQ.'CHAL')THEN 11026 WRITE(ICOUT,999) 11027 CALL DPWRST('XXX','BUG ') 11028 WRITE(ICOUT,9011) 11029 9011 FORMAT('***** AT THE END OF DPCHAL--') 11030 CALL DPWRST('XXX','BUG ') 11031 WRITE(ICOUT,9012)ICH1,ICH1N,ICH2,ICH2N 11032 9012 FORMAT('ICH1,ICH1N,ICH2,ICH2N = ',A1,2X,I8,2X,A1,2X,I8) 11033 CALL DPWRST('XXX','BUG ') 11034 WRITE(ICOUT,9014)IFOUND,ICHAR2,ICHARN 11035 9014 FORMAT('IFOUND,ICHAR2,ICHARN = ',2(A4,2X),I8) 11036 CALL DPWRST('XXX','BUG ') 11037 ENDIF 11038C 11039 RETURN 11040 END 11041 SUBROUTINE DPCHAN(MAXCHA,ACHAAN, 11042 1IBUGP2,IBUGQ,IFOUND,IERROR) 11043C 11044C PURPOSE--DEFINE PLOT CHARACTER ANGLES FOR USE IN MULTI-TRACE PLOTS. 11045C THE ANGLE FOR THE CHARACTER FOR THE I-TH TRACE 11046C WILL BE PLACED 11047C IN THE I-TH ELEMENT OF THE FLOATING POINT 11048C VECTOR ACHAAN(.). 11049C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 11050C --IARGT (A HOLLERITH VECTOR) 11051C --ARG (A HOLLERITH VECTOR) 11052C --NUMARG 11053C --MAXCHA 11054C OUTPUT ARGUMENTS--ACHAAN (A FLOATING POINT VECTOR 11055C WHOSE I-TH ELEMENT IS THE ANGLE 11056C FOR THE CHARACTER 11057C ASSIGNED TO THE I-TH TRACE IN 11058C A MULTI-TRACE PLOT. 11059C --ACHAAN = CHARACTER ANGLE 11060C --IFOUND ('YES' OR 'NO' ) 11061C --IERROR ('YES' OR 'NO' ) 11062C WRITTEN BY--JAMES J. FILLIBEN 11063C STATISTICAL ENGINEERING DIVISION 11064C INFORMATION TECHNOLOGY LABORATORY 11065C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11066C GAITHERSBURG, MD 20899-8980 11067C PHONE--301-975-2899 11068C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11069C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11070C LANGUAGE--ANSI FORTRAN (1977) 11071C VERSION NUMBER--86/11 11072C ORIGINAL VERSION--NOVEMBER 1986. 11073C 11074C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11075C 11076CCCCC CHARACTER*4 IHARG DECEMBER 1986 11077CCCCC CHARACTER*4 IARGT DECEMBER 1986 11078C 11079 CHARACTER*4 IBUGP2 11080 CHARACTER*4 IBUGQ 11081 CHARACTER*4 IFOUND 11082 CHARACTER*4 IERROR 11083C 11084 CHARACTER*4 IHLEFT 11085 CHARACTER*4 IHLEF2 11086 CHARACTER*4 IHWUSE 11087 CHARACTER*4 MESSAG 11088 CHARACTER*4 ISTEPN 11089 CHARACTER*4 ISUBN1 11090 CHARACTER*4 ISUBN2 11091 CHARACTER*4 ICASEQ 11092 CHARACTER*4 IWRITE 11093C 11094C--------------------------------------------------------------------- 11095C 11096CCCCC DIMENSION IHARG(*) DECEMBER 1986 11097CCCCC DIMENSION IARGT(*) DECEMBER 1986 11098CCCCC DIMENSION IARG(*) DECEMBER 1986 11099CCCCC DIMENSION ARG(*) DECEMBER 1986 11100C 11101 DIMENSION ACHAAN(*) 11102C 11103C-----COMMON---------------------------------------------------------- 11104C 11105 INCLUDE 'DPCOPA.INC' 11106 INCLUDE 'DPCOHK.INC' 11107 INCLUDE 'DPCODA.INC' 11108C 11109C--------------------------------------------------------------------- 11110C 11111 INCLUDE 'DPCOP2.INC' 11112C 11113C-----START POINT----------------------------------------------------- 11114C 11115 ISUBN1='DPCH' 11116 ISUBN2='AN ' 11117 IFOUND='NO' 11118 IERROR='NO' 11119C 11120 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'ANGL')GOTO1160 11121 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'ANGL')GOTO1105 11122 GOTO9000 11123C 11124 1105 CONTINUE 11125 IF(IHARG(NUMARG).EQ.'ON')GOTO1110 11126 IF(IHARG(NUMARG).EQ.'OFF')GOTO1110 11127 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 11128 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 11129C 11130 IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160 11131 IF(NUMARG.EQ.2)GOTO1120 11132 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130 11133 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140 11134C 11135 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'AUTO')GOTO3000 11136C 11137 GOTO1150 11138C 11139 1110 CONTINUE 11140 DO1115I=1,MAXCHA 11141 ACHAAN(I)=0.0 11142 1115 CONTINUE 11143C 11144 IF(IFEEDB.EQ.'OFF')GOTO1119 11145 WRITE(ICOUT,999) 11146 999 FORMAT(1X) 11147 CALL DPWRST('XXX','BUG ') 11148 I=1 11149 WRITE(ICOUT,1116)ACHAAN(I) 11150 1116 FORMAT('ALL CHARACTER ANGLES HAVE JUST BEEN SET TO ', 11151 1E15.7) 11152 CALL DPWRST('XXX','BUG ') 11153 1119 CONTINUE 11154 GOTO8000 11155C 11156 1120 CONTINUE 11157 I=1 11158 IF(IARGT(2).NE.'NUMB')GOTO1180 11159 ACHAAN(1)=ARG(2) 11160C 11161 IF(IFEEDB.EQ.'OFF')GOTO1129 11162 WRITE(ICOUT,999) 11163 CALL DPWRST('XXX','BUG ') 11164 I=1 11165 WRITE(ICOUT,1126)I,ACHAAN(I) 11166 1126 FORMAT('THE ANGLE FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ', 11167 1E15.7) 11168 CALL DPWRST('XXX','BUG ') 11169 1129 CONTINUE 11170 GOTO8000 11171C 11172 1130 CONTINUE 11173 I=1 11174 IF(IARGT(3).NE.'NUMB')GOTO1180 11175 DO1135I=1,MAXCHA 11176 ACHAAN(I)=ARG(3) 11177 1135 CONTINUE 11178C 11179 IF(IFEEDB.EQ.'OFF')GOTO1139 11180 WRITE(ICOUT,999) 11181 CALL DPWRST('XXX','BUG ') 11182 I=1 11183 WRITE(ICOUT,1116)ACHAAN(I) 11184 CALL DPWRST('XXX','BUG ') 11185 1139 CONTINUE 11186 GOTO8000 11187C 11188 1140 CONTINUE 11189 I=1 11190 IF(IARGT(2).NE.'NUMB')GOTO1180 11191 DO1145I=1,MAXCHA 11192 ACHAAN(I)=ARG(2) 11193 1145 CONTINUE 11194C 11195 IF(IFEEDB.EQ.'OFF')GOTO1149 11196 WRITE(ICOUT,999) 11197 CALL DPWRST('XXX','BUG ') 11198 I=1 11199 WRITE(ICOUT,1116)ACHAAN(I) 11200 CALL DPWRST('XXX','BUG ') 11201 1149 CONTINUE 11202 GOTO8000 11203C 11204 1150 CONTINUE 11205 IMAX=NUMARG-1 11206 IF(MAXCHA.LT.IMAX)IMAX=MAXCHA 11207 DO1155I=1,IMAX 11208 IP1=I+1 11209 IF(IARGT(IP1).NE.'NUMB')GOTO1180 11210 ACHAAN(I)=ARG(IP1) 11211 1155 CONTINUE 11212C 11213 IF(IFEEDB.EQ.'OFF')GOTO1159 11214 WRITE(ICOUT,999) 11215 CALL DPWRST('XXX','BUG ') 11216 DO1156I=1,IMAX 11217 WRITE(ICOUT,1126)I,ACHAAN(I) 11218 CALL DPWRST('XXX','BUG ') 11219 1156 CONTINUE 11220 1159 CONTINUE 11221 GOTO8000 11222C 11223 1160 CONTINUE 11224 DO1165I=1,MAXCHA 11225 ACHAAN(I)=0.0 11226 1165 CONTINUE 11227C 11228 IF(IFEEDB.EQ.'OFF')GOTO1169 11229 WRITE(ICOUT,999) 11230 CALL DPWRST('XXX','BUG ') 11231 I=1 11232 WRITE(ICOUT,1116)ACHAAN(I) 11233 CALL DPWRST('XXX','BUG ') 11234 1169 CONTINUE 11235 GOTO8000 11236C 11237 1180 CONTINUE 11238 IERROR='YES' 11239 WRITE(ICOUT,999) 11240 CALL DPWRST('XXX','BUG ') 11241 WRITE(ICOUT,1181) 11242 1181 FORMAT('***** ERROR IN DPCHAN--') 11243 CALL DPWRST('XXX','BUG ') 11244 WRITE(ICOUT,1182) 11245 1182 FORMAT('CHARACTER ANGLES MUST BE NUMERIC;') 11246 CALL DPWRST('XXX','BUG ') 11247 WRITE(ICOUT,1183) 11248 1183 FORMAT('HOWEVER, THE SPECIFIED CHARACTER ANGLE') 11249 CALL DPWRST('XXX','BUG ') 11250 WRITE(ICOUT,1184)I 11251 1184 FORMAT('FOR CHARACTER ',I6,' WAS NON-NUMERIC.') 11252 CALL DPWRST('XXX','BUG ') 11253 GOTO9000 11254C 11255C *********************************************************** 11256C ** STEP 30-- ** 11257C ** TREAT THE CHARACTER ANGLE AUTOMATIC <VARIABLE> CASE ** 11258C *********************************************************** 11259C 11260 3000 CONTINUE 11261C 11262C ******************************************** 11263C ** STEP 31-- ** 11264C ** CHECK THE VALIDITY OF ARGUMENT 3 ** 11265C ** (THIS WILL BE THE RESPONSE VARIABLE) ** 11266C ******************************************** 11267C 11268 ISTEPN='31' 11269 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 11270C 11271 IHLEFT=IHARG(3) 11272 IHLEF2=IHARG2(3) 11273 IHWUSE='V' 11274 MESSAG='YES' 11275 CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 11276 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 11277 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 11278 IF(IERROR.EQ.'YES')GOTO9000 11279 ICOLL=IVALUE(ILOCV) 11280 NLEFT=IN(ILOCV) 11281C 11282C ***************************************** 11283C ** STEP 32-- ** 11284C ** CHECK TO SEE THE TYPE CASE-- ** 11285C ** 1) UNQUALIFIED (THAT IS, FULL); ** 11286C ** 2) SUBSET/EXCEPT; OR ** 11287C ** 3) FOR. ** 11288C ***************************************** 11289C 11290 ISTEPN='32' 11291 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 11292C 11293 ICASEQ='FULL' 11294 ILOCQ=NUMARG+1 11295 IF(NUMARG.LT.1)GOTO3290 11296 DO3200J=1,NUMARG 11297 J1=J 11298 IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO3210 11299 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO3210 11300 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO3220 11301 3200 CONTINUE 11302 GOTO3290 11303 3210 CONTINUE 11304 ICASEQ='SUBS' 11305 ILOCQ=J1 11306 GOTO3290 11307 3220 CONTINUE 11308 ICASEQ='FOR' 11309 ILOCQ=J1 11310 GOTO3290 11311 3290 CONTINUE 11312 IF(IBUGP2.EQ.'OFF')GOTO3295 11313 WRITE(ICOUT,3291)NUMARG,ILOCQ 11314 3291 FORMAT('NUMARG,ILOCQ = ',2I8) 11315 CALL DPWRST('XXX','BUG ') 11316 3295 CONTINUE 11317C 11318C ********************************************* 11319C ** STEP 33-- ** 11320C ** TEMPORARILY FORM THE VARIABLE Y(.) ** 11321C ** WHICH WILL HOLD THE RESPONSE VARIABLE. ** 11322C ** FORM THIS VARIABLE BY ** 11323C ** BRANCHING TO THE APPROPRIATE SUBCASE ** 11324C ** (FULL, SUBSET, OR FOR). ** 11325C ********************************************* 11326C 11327 ISTEPN='33' 11328 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 11329C 11330 IF(ICASEQ.EQ.'FULL')GOTO3310 11331 IF(ICASEQ.EQ.'SUBS')GOTO3320 11332 IF(ICASEQ.EQ.'FOR')GOTO3330 11333C 11334 3310 CONTINUE 11335 DO3315I=1,NLEFT 11336 ISUB(I)=1 11337 3315 CONTINUE 11338 NQ=NLEFT 11339 GOTO3350 11340C 11341 3320 CONTINUE 11342 NIOLD=NLEFT 11343 CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) 11344 NQ=NIOLD 11345 GOTO3350 11346C 11347 3330 CONTINUE 11348 NIOLD=NLEFT 11349 CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 11350 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) 11351 NQ=NFOR 11352 GOTO3350 11353C 11354 3350 CONTINUE 11355 MINN2=1 11356 IF(NQ.GE.MINN2)GOTO3360 11357 WRITE(ICOUT,999) 11358 CALL DPWRST('XXX','BUG ') 11359 WRITE(ICOUT,3351) 11360 3351 FORMAT('***** ERROR IN DPCHAN--') 11361 CALL DPWRST('XXX','BUG ') 11362 WRITE(ICOUT,3352) 11363 3352 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 11364 1'EXTRACTED,') 11365 CALL DPWRST('XXX','BUG ') 11366 WRITE(ICOUT,3353)IHLEFT,IHLEF2 11367 3353 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 11368 1'FROM VARIABLE ',A4,A4) 11369 CALL DPWRST('XXX','BUG ') 11370 WRITE(ICOUT,3354) 11371 3354 FORMAT(' (FOR WHICH CHARACTER ANGLES ') 11372 CALL DPWRST('XXX','BUG ') 11373 WRITE(ICOUT,3355) 11374 3355 FORMAT(' ARE TO BE GENERATED)') 11375 CALL DPWRST('XXX','BUG ') 11376 WRITE(ICOUT,3356)MINN2 11377 3356 FORMAT(' MUST BE ',I8,' OR LARGER;') 11378 CALL DPWRST('XXX','BUG ') 11379 WRITE(ICOUT,3357) 11380 3357 FORMAT(' SUCH WAS NOT THE CASE HERE.') 11381 CALL DPWRST('XXX','BUG ') 11382 WRITE(ICOUT,3358) 11383 3358 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') 11384 CALL DPWRST('XXX','BUG ') 11385 IF(IWIDTH.GE.1)WRITE(ICOUT,3359)(IANS(I),I=1,IWIDTH) 11386 3359 FORMAT(' ',80A1) 11387 IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') 11388 IERROR='YES' 11389 GOTO9000 11390C 11391 3360 CONTINUE 11392 MAXCP1=MAXCOL+1 11393 MAXCP2=MAXCOL+2 11394 MAXCP3=MAXCOL+3 11395 MAXCP4=MAXCOL+4 11396 MAXCP5=MAXCOL+5 11397 MAXCP6=MAXCOL+6 11398 J=0 11399 IMAX=NLEFT 11400 IF(NQ.LT.NLEFT)IMAX=NQ 11401 DO3370I=1,IMAX 11402 IF(ISUB(I).EQ.0)GOTO3370 11403 J=J+1 11404C 11405 IJ=MAXN*(ICOLL-1)+I 11406 IF(ICOLL.LE.MAXCOL)Y(J)=V(IJ) 11407 IF(ICOLL.EQ.MAXCP1)Y(J)=PRED(I) 11408 IF(ICOLL.EQ.MAXCP2)Y(J)=RES(I) 11409 IF(ICOLL.EQ.MAXCP3)Y(J)=YPLOT(I) 11410 IF(ICOLL.EQ.MAXCP4)Y(J)=XPLOT(I) 11411 IF(ICOLL.EQ.MAXCP5)Y(J)=X2PLOT(I) 11412 IF(ICOLL.EQ.MAXCP6)Y(J)=TAGPLO(I) 11413C 11414 3370 CONTINUE 11415 NS=J 11416 NY=J 11417C 11418C ***************************************** 11419C ** STEP 34-- ** 11420C ** EXTRACT THE DISTINCT VALUES ** 11421C ** FROM THE TARGET VARIABLE Y(.) . ** 11422C ** STORE THEM IN X(.) . ** 11423C ***************************************** 11424C 11425 IWRITE='OFF' 11426 CALL DISTIN(Y,NY,IWRITE,X,NX,IBUGP2,IERROR) 11427C 11428C *********************************** 11429C ** STEP 35-- ** 11430C ** SORT THESE DISTINCT VALUES ** 11431C ** (IN PLACE). ** 11432C *********************************** 11433C 11434 CALL SORT(X,NX,X) 11435C 11436C ****************************************** 11437C ** STEP 36-- ** 11438C ** COPY THE NUMERIC VALUES IN X(.) ** 11439C ** INTO INDIVIDUAL ELEMENTS ** 11440C ** OF ACHAAN(.) ** 11441C ** NOTE--MAX NUMBER OF VALUES = 100 ** 11442C ****************************************** 11443C 11444 IMAX=NX 11445 IF(IMAX.GT.MAXCHA)IMAX=MAXCHA 11446 DO3650I=1,IMAX 11447 ACHAAN(I)=X(I) 11448 3650 CONTINUE 11449C 11450 IF(IFEEDB.EQ.'OFF')GOTO3679 11451 WRITE(ICOUT,999) 11452 CALL DPWRST('XXX','BUG ') 11453 DO3675I=1,IMAX 11454 WRITE(ICOUT,3676)I,ACHAAN(I) 11455 3676 FORMAT('CHARACTER ANGLE ',I6,' HAS JUST BEEN SET TO ', 11456 1E15.7) 11457 CALL DPWRST('XXX','BUG ') 11458 3675 CONTINUE 11459 3679 CONTINUE 11460 GOTO8000 11461C 11462 8000 CONTINUE 11463 IFOUND='YES' 11464 GOTO9000 11465C 11466C ***************** 11467C ** STEP 90-- ** 11468C ** EXIT ** 11469C ***************** 11470C 11471 9000 CONTINUE 11472 IF(IBUGP2.EQ.'OFF')GOTO9090 11473 WRITE(ICOUT,999) 11474 CALL DPWRST('XXX','BUG ') 11475 WRITE(ICOUT,9011) 11476 9011 FORMAT('***** AT THE END OF DPCHAR--') 11477 CALL DPWRST('XXX','BUG ') 11478 WRITE(ICOUT,9012)IBUGP2 11479 9012 FORMAT('IBUGP2 = ',A4) 11480 CALL DPWRST('XXX','BUG ') 11481 WRITE(ICOUT,9013)IFOUND,IERROR 11482 9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 11483 CALL DPWRST('XXX','BUG ') 11484 WRITE(ICOUT,9014)IMAX 11485 9014 FORMAT('IMAX = ',I8) 11486 CALL DPWRST('XXX','BUG ') 11487 WRITE(ICOUT,9021)NY 11488 9021 FORMAT('NY = ',I8) 11489 CALL DPWRST('XXX','BUG ') 11490 IF(NY.LE.0)GOTO9022 11491 DO9023I=1,NY 11492 WRITE(ICOUT,9024)I,Y(I) 11493 9024 FORMAT('I,Y(I) = ',I8,E15.7) 11494 CALL DPWRST('XXX','BUG ') 11495 9023 CONTINUE 11496 9022 CONTINUE 11497 WRITE(ICOUT,9031)NX 11498 9031 FORMAT('NX = ',I8) 11499 CALL DPWRST('XXX','BUG ') 11500 IF(NX.LE.0)GOTO9032 11501 DO9033I=1,NX 11502 WRITE(ICOUT,9034)I,X(I) 11503 9034 FORMAT('I,X(I) = ',I8,E15.7) 11504 CALL DPWRST('XXX','BUG ') 11505 9033 CONTINUE 11506 9032 CONTINUE 11507 WRITE(ICOUT,9041)MAXCHA 11508 9041 FORMAT('MAXCHA = ',I8) 11509 CALL DPWRST('XXX','BUG ') 11510 IF(NX.LE.0)GOTO9042 11511 DO9043I=1,NX 11512 WRITE(ICOUT,9044)I,ACHAAN(I) 11513 9044 FORMAT('I,ACHAAN(I) = ',I8,2X,A4) 11514 CALL DPWRST('XXX','BUG ') 11515 9043 CONTINUE 11516 9042 CONTINUE 11517 9090 CONTINUE 11518 RETURN 11519 END 11520 SUBROUTINE DPCHAR(MAXCHA,ICHAPA,ICHAPO, 11521 1 IBUGP2,IBUGQ,ISUBRO,IFOUND,IERROR) 11522C 11523C PURPOSE--DEFINE PLOT CHARACTERS FOR USE IN MULTI-TRACE PLOTS. 11524C THE CHARACTER FOR THE I-TH TRACE WILL BE PLACED 11525C IN THE I-TH ELEMENT OF THE HOLLERITH 11526C VECTOR ICHAPA(.). 11527C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 11528C --NUMARG 11529C --MAXCHA 11530C OUTPUT ARGUMENTS--ICHAPA (A HOLLERITH VECTOR 11531C WHOSE I-TH ELEMENT IS THE CHARACTER 11532C ASSIGNED TO THE I-TH TRACE IN 11533C A MULTI-TRACE PLOT. 11534C --IFOUND ('YES' OR 'NO' ) 11535C --IERROR ('YES' OR 'NO' ) 11536C WRITTEN BY--JAMES J. FILLIBEN 11537C STATISTICAL ENGINEERING DIVISION 11538C INFORMATION TECHNOLOGY LABORATORY 11539C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11540C GAITHERSBURG, MD 20899-8980 11541C PHONE--301-975-2899 11542C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11543C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11544C LANGUAGE--ANSI FORTRAN (1977) 11545C VERSION NUMBER--82/7 11546C ORIGINAL VERSION--DECEMBER 1977 11547C UPDATED --SEPTEMBER 1980 11548C UPDATED --MARCH 1982 11549C UPDATED --MAY 1982 11550C UPDATED --JULY 1983 11551C UPDATED --NOVEMBER 1986 11552C UPDATED --JANAURY 1988 (OMIT SORTING FOR CHAR AUTOMATIC) 11553C UPDATED --AUGUST 1987 TUFTE BOX PLOT 11554C UPDATED --NOVEMBER 1988 ERROR BAR PLOT 11555C UPDATED --JUNE 1989 CHAR AUTOMATIC DISTINCT 11556C UPDATED --SEPTEMBER 1990 AUGMENT CONTROL CHART 11557C UPDATED --NOVEMBER 1995 SUPPORT CASE ASIS 11558C UPDATED --FEBRUARY 1998 CHAR <SAVE/RESTORE> 11559C UPDATED --JANUARY 2001 CHAR AUTOMATIC SIGN 11560C UPDATED --FEBRUARY 2003 CHAR VIOLIN PLOT 11561C UPDATED --JUNE 2010 ALLOW 16 CHARACTERS FOR CHARACTER 11562C PATTERN 11563C UPDATED --DECEMBER 2011 CHARACTER AUTOMATIC OFFSET 11564C UPDATED --JULY 2012 CHARACTER AUTOMATIC DYNAMIC 11565C UPDATED --APRIL 2018 ALLOW 24 CHARACTERS FOR CHARACTER 11566C 11567C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11568C 11569CCCCC CHARACTER*4 IHARG DECEMBER 1986 11570CCCCC CHARACTER*4 ICHAPA 11571CCCCC CHARACTER*4 ICHAPO 11572 CHARACTER*24 ICHAPA 11573 CHARACTER*24 ICHAPO 11574 CHARACTER*4 IBUGP2 11575 CHARACTER*4 IBUGQ 11576 CHARACTER*4 ISUBRO 11577 CHARACTER*4 IFOUND 11578 CHARACTER*4 IERROR 11579C 11580 CHARACTER*4 IHLEFT 11581 CHARACTER*4 IHLEF2 11582 CHARACTER*4 IHWUSE 11583 CHARACTER*4 MESSAG 11584 CHARACTER*4 ISTEPN 11585 CHARACTER*4 ISUBN1 11586 CHARACTER*4 ISUBN2 11587 CHARACTER*4 ICASEQ 11588 CHARACTER*4 IWRITE 11589 CHARACTER*4 ICTEXT 11590CCCCC FOLLOWING LINE JANAURY 2001 11591 CHARACTER*4 ISIGNF 11592 CHARACTER*4 IHYPSV 11593C 11594 CHARACTER*80 ISTRIN 11595 CHARACTER*80 ISTRCH 11596C 11597C--------------------------------------------------------------------- 11598C 11599CCCCC DIMENSION IHARG(*) DECEMBER 1986 11600 DIMENSION ICHAPA(*) 11601CCCCC ADD FOLLOWING LINE FEBRUARY 1998. 11602 DIMENSION ICHAPO(*) 11603 DIMENSION ICTEXT(100) 11604C 11605C 11606C-----COMMON---------------------------------------------------------- 11607C 11608 INCLUDE 'DPCOPA.INC' 11609 INCLUDE 'DPCOHK.INC' 11610 INCLUDE 'DPCODA.INC' 11611 INCLUDE 'DPCOST.INC' 11612C 11613C--------------------------------------------------------------------- 11614C 11615 INCLUDE 'DPCOP2.INC' 11616C 11617C-----START POINT----------------------------------------------------- 11618C 11619 ISUBN1='DPCH' 11620 ISUBN2='AR ' 11621 IFOUND='NO' 11622 IERROR='NO' 11623 ICHAVN='NULL' 11624 IHYPSV=IHYPSW 11625 IHYPSW='OFF' 11626C 11627 NCCHAR=0 11628C 11629 IF(IBUGP2.EQ.'ON' .OR. ISUBRO.EQ.'CHAR')THEN 11630 WRITE(ICOUT,11)ICOM,IHARG(1),IHARG(2),IHARG(3),NUMARG 11631 11 FORMAT('IN DPCHAR: ICOM,IHARG(1),IHARG(2),IHARG(3),NUMARG = ', 11632 1 4(2X,A4),I8) 11633 CALL DPWRST('XXX','BUG ') 11634 ENDIF 11635C 11636 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO9000 11637 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SIZE')GOTO9000 11638 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FILL')GOTO9000 11639 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TYPE')GOTO9000 11640 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TABU')GOTO9000 11641C 11642 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SAVE')THEN 11643 DO2163I=1,MAXCHA 11644 ICHAPO(I)=ICHAPA(I) 11645 2163 CONTINUE 11646 IF(IFEEDB.EQ.'ON')THEN 11647 WRITE(ICOUT,999) 11648 CALL DPWRST('XXX','BUG ') 11649 WRITE(ICOUT,2164) 11650 2164 FORMAT('THE CURRENT CHARACTER SETTINGS HAVE BEEN SAVED.') 11651 CALL DPWRST('XXX','BUG ') 11652 ENDIF 11653 IFOUND='YES' 11654 GOTO9000 11655 ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'REST')THEN 11656 DO2168I=1,MAXCHA 11657 ICHAPA(I)=ICHAPO(I) 11658 2168 CONTINUE 11659 IF(IFEEDB.EQ.'ON')THEN 11660 WRITE(ICOUT,999) 11661 CALL DPWRST('XXX','BUG ') 11662 WRITE(ICOUT,2169) 11663 2169 FORMAT('THE SAVED CHARACTER SETTINGS HAVE BEEN RESTORED.') 11664 CALL DPWRST('XXX','BUG ') 11665 ENDIF 11666 IFOUND='YES' 11667 GOTO9000 11668 ELSEIF((NUMARG.GE.2.AND.IHARG(1).EQ.'BOX'.AND. 11669 1 IHARG(2).EQ.'PLOT') .OR. 11670 1 (NUMARG.GE.3.AND.IHARG(2).EQ.'BOX'.AND. 11671 1 IHARG(3).EQ.'PLOT'))THEN 11672 IMAX=24 11673 ICHAPA(1)='X' 11674 ICHAPA(2)=' ' 11675 ICHAPA(3)=' ' 11676 ICHAPA(4)='X' 11677 ICHAPA(5)=' ' 11678 ICHAPA(6)=' ' 11679 ICHAPA(7)='X' 11680 ICHAPA(8)=' ' 11681 ICHAPA(9)=' ' 11682 ICHAPA(10)=' ' 11683 ICHAPA(11)=' ' 11684 ICHAPA(12)=' ' 11685 ICHAPA(13)=' ' 11686 ICHAPA(14)=' ' 11687 ICHAPA(15)=' ' 11688 ICHAPA(16)=' ' 11689 ICHAPA(17)=' ' 11690 ICHAPA(18)=' ' 11691 ICHAPA(19)=' ' 11692 ICHAPA(20)=' ' 11693 ICHAPA(21)='CIRC' 11694 ICHAPA(22)='CIRC' 11695 ICHAPA(23)='CIRC' 11696 ICHAPA(24)='CIRC' 11697 GOTO2170 11698 ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'TUFT'.AND. 11699 1 IHARG(2).EQ.'BOX'.AND.IHARG(3).EQ.'PLOT')THEN 11700 IMAX=24 11701 ICHAPA(1)=' ' 11702 ICHAPA(2)=' ' 11703 ICHAPA(3)=' ' 11704 ICHAPA(4)='X' 11705 ICHAPA(5)=' ' 11706 ICHAPA(6)=' ' 11707 ICHAPA(7)=' ' 11708 ICHAPA(8)=' ' 11709 ICHAPA(9)=' ' 11710 ICHAPA(10)=' ' 11711 ICHAPA(11)=' ' 11712 ICHAPA(12)=' ' 11713 ICHAPA(13)=' ' 11714 ICHAPA(14)=' ' 11715 ICHAPA(15)=' ' 11716 ICHAPA(16)=' ' 11717 ICHAPA(17)=' ' 11718 ICHAPA(18)=' ' 11719 ICHAPA(19)=' ' 11720 ICHAPA(20)=' ' 11721 ICHAPA(21)='CIRC' 11722 ICHAPA(22)='CIRC' 11723 ICHAPA(23)='CIRC' 11724 ICHAPA(24)='CIRC' 11725 GOTO2170 11726 ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'ERRO'.AND. 11727 1 IHARG(2).EQ.'BAR'.AND.IHARG(3).EQ.'PLOT')THEN 11728 IMAX=7 11729 ICHAPA(1)='CIRC' 11730 ICHAPA(2)='-' 11731 ICHAPA(3)='-' 11732 ICHAPA(4)='|' 11733 ICHAPA(5)='|' 11734 ICHAPA(6)=' ' 11735 ICHAPA(7)=' ' 11736 GOTO2170 11737 ELSEIF((NUMARG.GE.2.AND.IHARG(1).EQ.'I'.AND. 11738 1 IHARG(2).EQ.'PLOT') .OR. 11739 1 (NUMARG.GE.3.AND.IHARG(2).EQ.'I'.AND. 11740 1 IHARG(3).EQ.'PLOT'))THEN 11741 IMAX=5 11742 ICHAPA(1)='-' 11743 ICHAPA(2)='X' 11744 ICHAPA(3)='-' 11745 ICHAPA(4)=' ' 11746 ICHAPA(5)=' ' 11747 GOTO2170 11748 ELSEIF((NUMARG.GE.2.AND.IHARG(1).EQ.'CONT'.AND. 11749 1 IHARG(2).EQ.'CHAR') .OR. 11750 1 (NUMARG.GE.3.AND.IHARG(2).EQ.'CONT'.AND. 11751 1 IHARG(3).EQ.'CHAR'))THEN 11752 IMAX=7 11753 ICHAPA(1)='CIRC' 11754 ICHAPA(2)=' ' 11755 ICHAPA(3)=' ' 11756 ICHAPA(4)=' ' 11757 ICHAPA(5)=' ' 11758 ICHAPA(6)=' ' 11759 ICHAPA(7)=' ' 11760 GOTO2170 11761 ELSEIF((NUMARG.GE.2.AND.IHARG(1).EQ.'VIOL'.AND. 11762 1 IHARG(2).EQ.'PLOT') .OR. 11763 1 (NUMARG.GE.4.AND.IHARG(1).EQ.'VIOL'.AND. 11764 1 IHARG(2).EQ.'TUFT'.AND.IHARG(3).EQ.'BOX'.AND. 11765 1 IHARG(4).EQ.'PLOT'))THEN 11766 IMAX=25 11767 ICHAPA(1)=' ' 11768 ICHAPA(2)=' ' 11769 ICHAPA(3)=' ' 11770 ICHAPA(4)=' ' 11771 ICHAPA(5)='X' 11772 ICHAPA(6)=' ' 11773 ICHAPA(7)=' ' 11774 ICHAPA(8)=' ' 11775 ICHAPA(9)=' ' 11776 ICHAPA(10)=' ' 11777 ICHAPA(11)=' ' 11778 ICHAPA(12)=' ' 11779 ICHAPA(13)=' ' 11780 ICHAPA(14)=' ' 11781 ICHAPA(15)=' ' 11782 ICHAPA(16)=' ' 11783 ICHAPA(17)=' ' 11784 ICHAPA(18)=' ' 11785 ICHAPA(19)=' ' 11786 ICHAPA(20)=' ' 11787 ICHAPA(21)=' ' 11788 ICHAPA(22)='CIRC' 11789 ICHAPA(23)='CIRC' 11790 ICHAPA(24)='CIRC' 11791 ICHAPA(25)='CIRC' 11792 GOTO2170 11793 ELSEIF(NUMARG.GE.4.AND.IHARG(1).EQ.'VIOL'.AND. 11794 1 IHARG(2).EQ.'BOX'.AND.IHARG(4).EQ.'PLOT')THEN 11795 IMAX=25 11796 ICHAPA(1)=' ' 11797 ICHAPA(2)='X' 11798 ICHAPA(3)=' ' 11799 ICHAPA(4)=' ' 11800 ICHAPA(5)='X' 11801 ICHAPA(6)=' ' 11802 ICHAPA(7)=' ' 11803 ICHAPA(8)='X' 11804 ICHAPA(9)=' ' 11805 ICHAPA(10)=' ' 11806 ICHAPA(11)=' ' 11807 ICHAPA(12)=' ' 11808 ICHAPA(13)=' ' 11809 ICHAPA(14)=' ' 11810 ICHAPA(15)=' ' 11811 ICHAPA(16)=' ' 11812 ICHAPA(17)=' ' 11813 ICHAPA(18)=' ' 11814 ICHAPA(19)=' ' 11815 ICHAPA(20)=' ' 11816 ICHAPA(21)=' ' 11817 ICHAPA(22)='CIRC' 11818 ICHAPA(23)='CIRC' 11819 ICHAPA(24)='CIRC' 11820 ICHAPA(25)='CIRC' 11821 GOTO2170 11822 ENDIF 11823 GOTO1101 11824C 11825 2170 CONTINUE 11826 IF(IFEEDB.EQ.'ON')THEN 11827 WRITE(ICOUT,999) 11828 CALL DPWRST('XXX','BUG ') 11829 DO2175I=1,IMAX 11830 WRITE(ICOUT,2176)I,ICHAPA(I)(1:8) 11831 2176 FORMAT('CHARACTER ',I6,' HAS JUST BEEN SET TO ',A8) 11832 CALL DPWRST('XXX','BUG ') 11833 2175 CONTINUE 11834 ENDIF 11835 GOTO8000 11836C 11837 1101 CONTINUE 11838C 11839 IF(NUMARG.LE.0 .OR. 11840 1 (NUMARG.EQ.1.AND.IHARG(1).EQ.'ALL') .OR. 11841 1 (IHARG(NUMARG).EQ.'OFF') .OR. 11842 1 (IHARG(NUMARG).EQ.'DEFA'))THEN 11843 DO1165I=1,MAXCHA 11844 ICHAPA(I)=' ' 11845 1165 CONTINUE 11846C 11847 IF(IFEEDB.EQ.'ON')THEN 11848 WRITE(ICOUT,999) 11849 CALL DPWRST('XXX','BUG ') 11850 I=1 11851 WRITE(ICOUT,1116)ICHAPA(I)(1:8) 11852 CALL DPWRST('XXX','BUG ') 11853 ENDIF 11854 GOTO8000 11855 ELSEIF(IHARG(NUMARG).EQ.'ON' .OR. IHARG(NUMARG).EQ.'AUTO')THEN 11856 DO1115I=1,MAXCHA 11857 ICHAPA(I)='X' 11858 1115 CONTINUE 11859C 11860 IF(IFEEDB.EQ.'ON')THEN 11861 WRITE(ICOUT,999) 11862 999 FORMAT(1X) 11863 CALL DPWRST('XXX','BUG ') 11864 I=1 11865 WRITE(ICOUT,1116)ICHAPA(I)(1:24) 11866 1116 FORMAT('ALL CHARACTERS HAVE JUST BEEN SET TO ',A24) 11867 CALL DPWRST('XXX','BUG ') 11868 ENDIF 11869 GOTO8000 11870C 11871 ELSEIF(NUMARG.EQ.1)THEN 11872 IF(NUMARG.EQ.0)ICHAPA(1)=' ' 11873 IF(NUMARG.GE.1)THEN 11874 IF(IHARG(1).EQ.'BOX')THEN 11875 ICHAPA(1)='SQUA' 11876 ELSE 11877 ICHAPA(1)=' ' 11878CCCCC ICHAPA(1)(1:4)=IHARLC(1) 11879CCCCC ICHAPA(1)(5:8)=IHARL2(1) 11880 ISTART=1 11881 ISTOP=IWIDTH 11882 IWORD=2 11883 NCCHAR=0 11884 ISTRIN=' ' 11885 ISTRCH=' ' 11886 DO6001II=1,IWIDTH 11887 ISTRIN(II:II)=IANSLC(II)(1:1) 11888 6001 CONTINUE 11889 CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD, 11890 1 ICOL1,ICOL2,ISTRCH,NCCHAR, 11891 1 IBUGP2,ISUBRO,IERROR) 11892 IF(NCCHAR.GT.24)NCCHAR=24 11893 ICHAPA(1)=' ' 11894 ICHAPA(1)(1:NCCHAR)=ISTRCH(1:NCCHAR) 11895 ENDIF 11896 ENDIF 11897C 11898 IF(IFEEDB.EQ.'ON')THEN 11899 WRITE(ICOUT,999) 11900 CALL DPWRST('XXX','BUG ') 11901 I=1 11902 WRITE(ICOUT,1126)I,ICHAPA(I) 11903 1126 FORMAT('CHARACTER ',I6,' HAS JUST BEEN SET TO ',A24) 11904 CALL DPWRST('XXX','BUG ') 11905 ENDIF 11906 GOTO8000 11907 ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'ALL')THEN 11908 DO1135I=1,MAXCHA 11909 ICHAPA(I)=' ' 11910 IF(IHARG(2).EQ.'BOX')THEN 11911 ICHAPA(I)='SQUA' 11912 ELSE 11913CCCCC ICHAPA(I)(1:4)=IHARLC(2) 11914CCCCC ICHAPA(I)(5:8)=IHARL2(2) 11915 ISTART=1 11916 ISTOP=IWIDTH 11917 IWORD=3 11918 NCCHAR=0 11919 ISTRIN=' ' 11920 ISTRCH=' ' 11921 DO6003II=1,IWIDTH 11922 ISTRIN(II:II)=IANSLC(II)(1:1) 11923 6003 CONTINUE 11924 CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD, 11925 1 ICOL1,ICOL2,ISTRCH,NCCHAR, 11926 1 IBUGP2,ISUBRO,IERROR) 11927 IF(NCCHAR.GT.24)NCCHAR=24 11928 ICHAPA(I)=' ' 11929 ICHAPA(I)(1:NCCHAR)=ISTRCH(1:NCCHAR) 11930 ENDIF 11931 1135 CONTINUE 11932C 11933 IF(IFEEDB.EQ.'ON')THEN 11934 WRITE(ICOUT,999) 11935 CALL DPWRST('XXX','BUG ') 11936 I=1 11937 WRITE(ICOUT,1116)ICHAPA(I) 11938 CALL DPWRST('XXX','BUG ') 11939 ENDIF 11940 GOTO8000 11941 ELSEIF(NUMARG.GE.2.AND.IHARG(2).EQ.'ALL')THEN 11942 DO1145I=1,MAXCHA 11943 ICHAPA(I)=' ' 11944 IF(IHARG(1).EQ.'BOX')THEN 11945 ICHAPA(I)='SQUA' 11946 ELSE 11947CCCCC ICHAPA(I)(1:4)=IHARLC(1) 11948CCCCC ICHAPA(I)(5:8)=IHARL2(1) 11949 ISTART=1 11950 ISTOP=IWIDTH 11951 IWORD=2 11952 NCCHAR=0 11953 ISTRIN=' ' 11954 ISTRCH=' ' 11955 DO6005II=1,IWIDTH 11956 ISTRIN(II:II)=IANSLC(II)(1:1) 11957 6005 CONTINUE 11958 CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD, 11959 1 ICOL1,ICOL2,ISTRCH,NCCHAR, 11960 1 IBUGP2,ISUBRO,IERROR) 11961 IF(NCCHAR.GT.24)NCCHAR=24 11962 ICHAPA(I)=' ' 11963 ICHAPA(I)(1:NCCHAR)=ISTRCH(1:NCCHAR) 11964 ENDIF 11965 1145 CONTINUE 11966C 11967 IF(IFEEDB.EQ.'ON')THEN 11968 WRITE(ICOUT,999) 11969 CALL DPWRST('XXX','BUG ') 11970 I=1 11971 WRITE(ICOUT,1116)ICHAPA(I) 11972 CALL DPWRST('XXX','BUG ') 11973 ENDIF 11974 GOTO8000 11975 ELSEIF((NUMARG.GE.2.AND.IHARG(2).EQ.'SUBS'.AND. 11976 1 IHARG2(2).EQ.'ET ') .OR. 11977 1 (NUMARG.GE.2.AND.IHARG(2).EQ.'EXCE'.AND. 11978 1 IHARG2(2).EQ.'PT '))THEN 11979 ICASEQ='SUBS' 11980 GOTO4190 11981 ELSEIF(NUMARG.GE.2.AND.IHARG(2).EQ.'FOR '.AND. 11982 1 IHARG2(2).EQ.' ')THEN 11983 ICASEQ='FOR' 11984 GOTO4190 11985 ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'AUTO')THEN 11986C 11987C *********************************************************** 11988C ** STEP 30-- ** 11989C ** TREAT THE CHARACTERS AUTOMATIC <VARIABLE> CASE ** 11990C *********************************************************** 11991C 11992C NOTE 2012/07: IF A "SET CHARACTER AUTOMATIC DYNAMIC ON" HAS BEEN 11993C ENTERED, JUST STORE THE VARIABLE NAME. 11994C 11995C ******************************************** 11996C ** STEP 31-- ** 11997C ** CHECK THE VALIDITY OF ARGUMENT 2 (OR 3)** 11998C ** (THIS WILL BE THE RESPONSE VARIABLE) ** 11999C ******************************************** 12000C 12001 ISTEPN='31' 12002 IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR') 12003 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12004C 12005 IHLEFT=IHARG(2) 12006 IHLEF2=IHARG2(2) 12007 IF(IHARG(2).EQ.'DIST'.AND.IHARG2(2).EQ.'INCT')IHLEFT=IHARG(3) 12008 IF(IHARG(2).EQ.'DIST'.AND.IHARG2(2).EQ.'INCT')IHLEF2=IHARG2(3) 12009 ISIGNF='OFF' 12010 IF(IHARG(2).EQ.'SIGN'.AND.IHARG2(2).EQ.' ')ISIGNF='ON' 12011 IF(IHARG(2).EQ.'SIGN'.AND.IHARG2(2).EQ.' ')IHLEFT=IHARG(3) 12012 IF(IHARG(2).EQ.'SIGN'.AND.IHARG2(2).EQ.' ')IHLEF2=IHARG2(3) 12013 IHWUSE='V' 12014 MESSAG='YES' 12015 CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 12016 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 12017 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 12018 IF(IERROR.EQ.'YES')GOTO9000 12019C 12020 IF(ICHADY.EQ.'ON')THEN 12021 WRITE(ICOUT,3010)ICOLL,NLEFT 12022 3010 FORMAT('CHARACTER AUTOMATIC: ICOLL,NLEFT = ',2I8) 12023 CALL DPWRST('XXX','BUG ') 12024 ICHAVN(1:4)=IHLEFT 12025 ICHAVN(5:8)=IHLEF2 12026 IF(IFEEDB.EQ.'OFF')THEN 12027 WRITE(ICOUT,999) 12028 CALL DPWRST('XXX','BUG ') 12029 WRITE(ICOUT,3003) 12030 3003 FORMAT('CHARACTER SETTINGS WILL BE EXTRACTED FROM ') 12031 CALL DPWRST('XXX','BUG ') 12032 WRITE(ICOUT,3005)ICHAVN 12033 3005 FORMAT('VARIABLE ',A8,' WHEN THE PLOT IS GENERATED.') 12034 CALL DPWRST('XXX','BUG ') 12035 ENDIF 12036 GOTO9000 12037 ENDIF 12038C 12039 ICOLL=IVALUE(ILOCV) 12040 NLEFT=IN(ILOCV) 12041C 12042 IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR')THEN 12043 WRITE(ICOUT,3090)ICOLL,NLEFT 12044 3090 FORMAT('CHARACTER AUTOMATIC: ICOLL,NLEFT = ',2I8) 12045 CALL DPWRST('XXX','BUG ') 12046 ENDIF 12047C 12048C ***************************************** 12049C ** STEP 32-- ** 12050C ** CHECK TO SEE THE TYPE CASE-- ** 12051C ** 1) UNQUALIFIED (THAT IS, FULL); ** 12052C ** 2) SUBSET/EXCEPT; OR ** 12053C ** 3) FOR. ** 12054C ***************************************** 12055C 12056 ISTEPN='32' 12057 IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR') 12058 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12059C 12060 ICASEQ='FULL' 12061 ILOCQ=NUMARG+1 12062 IF(NUMARG.LT.1)GOTO3290 12063 DO3200J=1,NUMARG 12064 J1=J 12065 IF((IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') .OR. 12066 1 (IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT '))THEN 12067 ICASEQ='SUBS' 12068 ILOCQ=J1 12069 GOTO3290 12070 ELSEIF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')THEN 12071 ICASEQ='FOR' 12072 ILOCQ=J1 12073 GOTO3290 12074 ENDIF 12075 3200 CONTINUE 12076C 12077 3290 CONTINUE 12078 IF(IBUGP2.EQ.'OFF')THEN 12079 WRITE(ICOUT,3291)NUMARG,ILOCQ 12080 3291 FORMAT('NUMARG,ILOCQ = ',2I8) 12081 CALL DPWRST('XXX','BUG ') 12082 ENDIF 12083C 12084C ********************************************* 12085C ** STEP 33-- ** 12086C ** TEMPORARILY FORM THE VARIABLE Y(.) ** 12087C ** WHICH WILL HOLD THE RESPONSE VARIABLE. ** 12088C ** FORM THIS VARIABLE BY ** 12089C ** BRANCHING TO THE APPROPRIATE SUBCASE ** 12090C ** (FULL, SUBSET, OR FOR). ** 12091C ********************************************* 12092C 12093 ISTEPN='33' 12094 IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR') 12095 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12096C 12097 IF(ICASEQ.EQ.'SUBS')THEN 12098 NIOLD=NLEFT 12099 CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) 12100 NQ=NIOLD 12101 ELSEIF(ICASEQ.EQ.'FOR')THEN 12102 NIOLD=NLEFT 12103 CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 12104 1 NLOCAL,ILOCS,NS,IBUGQ,IERROR) 12105 NQ=NFOR 12106 ELSE 12107 DO3315I=1,NLEFT 12108 ISUB(I)=1 12109 3315 CONTINUE 12110 NQ=NLEFT 12111 ENDIF 12112C 12113 MINN2=1 12114 IF(NQ.LT.MINN2)THEN 12115 WRITE(ICOUT,999) 12116 CALL DPWRST('XXX','BUG ') 12117 WRITE(ICOUT,3351) 12118 3351 FORMAT('***** ERROR IN DPCHAR--') 12119 CALL DPWRST('XXX','BUG ') 12120 WRITE(ICOUT,3352) 12121 3352 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 12122 1 'EXTRACTED,') 12123 CALL DPWRST('XXX','BUG ') 12124 WRITE(ICOUT,3353)IHLEFT,IHLEF2 12125 3353 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 12126 1 'FROM VARIABLE ',A4,A4) 12127 CALL DPWRST('XXX','BUG ') 12128 WRITE(ICOUT,3354) 12129 3354 FORMAT(' (FOR WHICH CHARACTER DEFINITIONS ARE TO BE ', 12130 1 'GENERATED)') 12131 CALL DPWRST('XXX','BUG ') 12132 WRITE(ICOUT,3356)MINN2 12133 3356 FORMAT(' MUST BE ',I8,' OR LARGER; SUCH WAS NOT THE ', 12134 1 'CASE HERE.') 12135 CALL DPWRST('XXX','BUG ') 12136 WRITE(ICOUT,3358) 12137 3358 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') 12138 CALL DPWRST('XXX','BUG ') 12139 IF(IWIDTH.GE.1)THEN 12140 WRITE(ICOUT,3359)(IANS(I),I=1,MIN(IWIDTH,80)) 12141 3359 FORMAT(' ',80A1) 12142 CALL DPWRST('XXX','BUG ') 12143 ENDIF 12144 IERROR='YES' 12145 GOTO9000 12146 ENDIF 12147C 12148 MAXCP1=MAXCOL+1 12149 MAXCP2=MAXCOL+2 12150 MAXCP3=MAXCOL+3 12151 MAXCP4=MAXCOL+4 12152 MAXCP5=MAXCOL+5 12153 MAXCP6=MAXCOL+6 12154 J=0 12155 IMAX=NLEFT 12156 IF(NQ.LT.NLEFT)IMAX=NQ 12157 DO3370I=1,IMAX 12158 IF(ISUB(I).EQ.0)GOTO3370 12159 J=J+1 12160C 12161 IJ=MAXN*(ICOLL-1)+I 12162 IF(ICOLL.LE.MAXCOL)Y(J)=V(IJ) 12163 IF(ICOLL.EQ.MAXCP1)Y(J)=PRED(I) 12164 IF(ICOLL.EQ.MAXCP2)Y(J)=RES(I) 12165 IF(ICOLL.EQ.MAXCP3)Y(J)=YPLOT(I) 12166 IF(ICOLL.EQ.MAXCP4)Y(J)=XPLOT(I) 12167 IF(ICOLL.EQ.MAXCP5)Y(J)=X2PLOT(I) 12168 IF(ICOLL.EQ.MAXCP6)Y(J)=TAGPLO(I) 12169 IF(ISIGNF.EQ.'ON')THEN 12170 IF(Y(J).GT.0.0)THEN 12171 ICHAPA(J)='+ ' 12172 ELSEIF(Y(J).LT.0.0)THEN 12173 ICHAPA(J)='- ' 12174 ELSEIF(Y(J).EQ.0.0)THEN 12175 ICHAPA(J)='0 ' 12176 ELSE 12177 ICHAPA(J)='0 ' 12178 ENDIF 12179 ENDIF 12180C 12181 IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR')THEN 12182 WRITE(ICOUT,3365)ISIGNF,J,Y(J),ICHAPA(J) 12183 3365 FORMAT('ISIGNF,J,Y(J),ICHAPA(J) = ',A4,2X,I5,G15.7,2X,A24) 12184 CALL DPWRST('XXX','BUG ') 12185 ENDIF 12186C 12187 3370 CONTINUE 12188 NS=J 12189 NY=J 12190 IF(ISIGNF.EQ.'ON')GOTO8000 12191C 12192C ***************************************** 12193C ** STEP 34-- ** 12194C ** IF HAVE THE FORM-- ** 12195C ** CHARACTERS AUTOMATIC DISTINCT X ** 12196C ** EXTRACT THE DISTINCT VALUES ** 12197C ** FROM THE TARGET VARIABLE Y(.) . ** 12198C ** STORE THEM IN X(.) . ** 12199C ** IF HAVE THE FORM-- ** 12200C ** CHARACTERS AUTOMATIC X ** 12201C ** DO NOTHING ** 12202C ***************************************** 12203C 12204 ISTEPN='34' 12205 IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR') 12206 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12207C 12208 IF(IHARG(2).EQ.'DIST'.AND.IHARG2(2).EQ.'INCT')THEN 12209 IWRITE='OFF' 12210 CALL DISTIN(Y,NY,IWRITE,X,NX,IBUGP2,IERROR) 12211 ELSE 12212 DO3411I=1,NY 12213 X(I)=Y(I) 12214 3411 CONTINUE 12215 NX=NY 12216 ENDIF 12217C 12218C *********************************** 12219C ** STEP 35-- ** 12220C ** SORT THESE DISTINCT VALUES ** 12221C ** (IN PLACE). ** 12222C *********************************** 12223C 12224CCCCC CALL SORT(X,NX,X) 12225C 12226C ****************************************** 12227C ** STEP 36-- ** 12228C ** CONVERT THE NUMERIC VALUES IN X(.) ** 12229C ** TO CHARACTER STRINGS. ** 12230C ** THEN LOAD THESE STRINGS ** 12231C ** INTO INDIVIDUAL ELEMENTS ** 12232C ** OF ICHAPA(.) ** 12233C ** NOTE--MAX CHARACTERS/STRING = 4 ** 12234C ** MAX NUMBER OF STRINGS = 100 ** 12235C ****************************************** 12236C 12237 ISTEPN='36' 12238 IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR') 12239 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12240C 12241 IMAX=NX 12242 IF(IMAX+ICHAOF.GT.MAXCHA)IMAX=MAXCHA-ICHAOF 12243 DO3650I=1,IMAX 12244 ICHAPA(I+ICHAOF)=' ' 12245 VAL=X(I) 12246 IVAL=INT(VAL+0.5) 12247 IF(VAL.LT.0.0)IVAL=INT(VAL-0.5) 12248 NUMDID=(-1) 12249 CALL DPCON2(IVAL,VAL,ICTEXT,NCTEXT,NUMDID,IBUGP2,IERROR) 12250 JMAX=NCTEXT 12251 IF(JMAX.GT.24)JMAX=24 12252 DO3660J=1,JMAX 12253 ICHAPA(I+ICHAOF)(J:J)=ICTEXT(J)(1:1) 12254 3660 CONTINUE 12255C 12256 IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR')THEN 12257 WRITE(ICOUT,3665)I,ICHAOF,ICHAPA(I+ICHAOF) 12258 3665 FORMAT('I,ICHAOF,ICHAPA(I+ICHAOF) = ',2I6,2X,A24) 12259 CALL DPWRST('XXX','BUG ') 12260 ENDIF 12261C 12262 3650 CONTINUE 12263C 12264 IF(IFEEDB.EQ.'ON')THEN 12265 WRITE(ICOUT,999) 12266 CALL DPWRST('XXX','BUG ') 12267 DO3675I=1,IMAX 12268 WRITE(ICOUT,3676)I+ICHAOF,ICHAPA(I+ICHAOF) 12269 3676 FORMAT('CHARACTER ',I6,' HAS JUST BEEN SET TO ',A24) 12270 CALL DPWRST('XXX','BUG ') 12271 3675 CONTINUE 12272 ENDIF 12273 GOTO8000 12274 ELSE 12275 IMAX=NUMARG 12276 IF(MAXCHA.LT.IMAX)IMAX=MAXCHA 12277 DO1155I=1,IMAX 12278 ICHAPA(I)=' ' 12279 IF(IHARG(I).EQ.'BOX')THEN 12280 ICHAPA(I)='SQUA' 12281 ELSE 12282CCCCC ICHAPA(I)(1:4)=IHARLC(I) 12283CCCCC ICHAPA(I)(5:8)=IHARL2(I) 12284 ISTART=1 12285 ISTOP=IWIDTH 12286 IWORD=I+1 12287 NCCHAR=0 12288 ISTRIN=' ' 12289 ISTRCH=' ' 12290 DO6007II=1,IWIDTH 12291 ISTRIN(II:II)=IANSLC(II)(1:1) 12292 6007 CONTINUE 12293 CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD, 12294 1 ICOL1,ICOL2,ISTRCH,NCCHAR, 12295 1 IBUGP2,ISUBRO,IERROR) 12296 IF(NCCHAR.GT.24)NCCHAR=24 12297 ICHAPA(I)=' ' 12298 ICHAPA(I)(1:NCCHAR)=ISTRCH(1:NCCHAR) 12299 ENDIF 12300 1155 CONTINUE 12301C 12302 IF(IFEEDB.EQ.'ON')THEN 12303 WRITE(ICOUT,999) 12304 CALL DPWRST('XXX','BUG ') 12305 DO1156I=1,IMAX 12306 WRITE(ICOUT,1126)I,ICHAPA(I) 12307 CALL DPWRST('XXX','BUG ') 12308 1156 CONTINUE 12309 ENDIF 12310 GOTO8000 12311 ENDIF 12312C 12313C *********************************************************** 12314C ** STEP 40-- ** 12315C ** TREAT THE CHARACTERS ... SUBSET/EXCEPT/FOR CASE ** 12316C ** FOR REDEFINING SPECIFIED CHARACTERS ** 12317C *********************************************************** 12318C 12319C ***************************************** 12320C ** STEP 41-- ** 12321C ** DEFINE THE TYPE CASE-- ** 12322C ** 1) SUBSET/EXCEPT ** 12323C ** 2) FOR. ** 12324C ***************************************** 12325C 12326 4190 CONTINUE 12327C 12328 ISTEPN='41' 12329 IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR') 12330 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12331C 12332 ILOCQ=2 12333C 12334 IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR')THEN 12335 WRITE(ICOUT,4191)ICASEQ,ILOCQ,NUMARG 12336 4191 FORMAT('ICASEQ,ILOCQ,NUMARG = ',3I8) 12337 CALL DPWRST('XXX','BUG ') 12338 ENDIF 12339C 12340C ********************************************* 12341C ** STEP 42-- ** 12342C ** DETERMINE WHICH ELEMENTS ARE ** 12343C ** TO BE REDEFINED. ** 12344C ********************************************* 12345C 12346 ISTEPN='42' 12347 IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR') 12348 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12349C 12350 NQ=0 12351 IF(ICASEQ.EQ.'SUBS')THEN 12352 NIOLD=MAXCHA 12353 CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) 12354 NQ=NIOLD 12355 ELSEIF(ICASEQ.EQ.'FOR')THEN 12356 NIOLD=MAXCHA 12357 CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 12358 1 NLOCAL,ILOCS,NS,IBUGQ,IERROR) 12359 NQ=NFOR 12360 ENDIF 12361C 12362 IF(NQ.LT.1)THEN 12363 WRITE(ICOUT,999) 12364 CALL DPWRST('XXX','BUG ') 12365 WRITE(ICOUT,3351) 12366 CALL DPWRST('XXX','BUG ') 12367 WRITE(ICOUT,4252) 12368 4252 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 12369 1 'EXTRACTED,') 12370 CALL DPWRST('XXX','BUG ') 12371 WRITE(ICOUT,4253)IHLEFT,IHLEF2 12372 4253 FORMAT(' EXTRACTED, NO CHARACTER ELEMENTS ', 12373 1 'FROM VARIABLE ',A4,A4) 12374 CALL DPWRST('XXX','BUG ') 12375 WRITE(ICOUT,4254) 12376 4254 FORMAT(' REMAINED TO BE REDEFINED. ') 12377 CALL DPWRST('XXX','BUG ') 12378 WRITE(ICOUT,4255)ICASEQ 12379 4255 FORMAT('ICASEQ = ',A4) 12380 CALL DPWRST('XXX','BUG ') 12381 WRITE(ICOUT,4258) 12382 4258 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') 12383 CALL DPWRST('XXX','BUG ') 12384 IF(IWIDTH.GE.1)THEN 12385 WRITE(ICOUT,4259)(IANS(I),I=1,MIN(80,IWIDTH)) 12386 4259 FORMAT(' ',80A1) 12387 CALL DPWRST('XXX','BUG ') 12388 ENDIF 12389 IERROR='YES' 12390 GOTO9000 12391 ENDIF 12392C 12393C ********************************************* 12394C ** STEP 43-- ** 12395C ** REDEFINE THE DESIGNATED CHARACTERS. ** 12396C ********************************************* 12397C 12398 ISTEPN='43' 12399 IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR') 12400 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12401C 12402 IMAX=MAXCHA 12403 IF(NQ.LT.MAXCHA)IMAX=NQ 12404 DO4310I=1,IMAX 12405 IF(ISUB(I).EQ.0)GOTO4310 12406 ICHAPA(I)=' ' 12407CCCCC ICHAPA(I)(1:4)=IHARLC(1) 12408CCCCC ICHAPA(I)(5:8)=IHARL2(1) 12409 ISTART=1 12410 ISTOP=IWIDTH 12411 IWORD=2 12412 NCCHAR=0 12413 ISTRIN=' ' 12414 ISTRCH=' ' 12415 DO6008II=1,IWIDTH 12416 ISTRIN(II:II)=IANSLC(II)(1:1) 12417 6008 CONTINUE 12418 CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD, 12419 1 ICOL1,ICOL2,ISTRCH,NCCHAR, 12420 1 IBUGP2,ISUBRO,IERROR) 12421 IF(NCCHAR.GT.24)NCCHAR=24 12422 ICHAPA(I)=' ' 12423 ICHAPA(I)(1:NCCHAR)=ISTRCH(1:NCCHAR) 12424 4310 CONTINUE 12425C 12426C ********************************************* 12427C ** STEP 44-- ** 12428C ** IF CALLED FOR, ** 12429C ** PRINT OUT A MESSAGE. ** 12430C ********************************************* 12431C 12432 ISTEPN='44' 12433 IF(IBUGP2.EQ.'ON'.OR.ISUBRO.EQ.'CHAR') 12434 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12435C 12436 IF(IFEEDB.EQ.'OFF')THEN 12437 WRITE(ICOUT,999) 12438 CALL DPWRST('XXX','BUG ') 12439 DO4410I=1,IMAX 12440 IF(ISUB(I).EQ.0)GOTO4410 12441 WRITE(ICOUT,4411)I,ICHAPA(I) 12442 4411 FORMAT('CHARACTER ',I6,' HAS JUST BEEN SET TO ',A24) 12443 CALL DPWRST('XXX','BUG ') 12444 4410 CONTINUE 12445 ENDIF 12446 GOTO8000 12447C 12448 8000 CONTINUE 12449 IFOUND='YES' 12450 DO8010I=1,MAXCHA 12451 IF(ICHAPA(I)(1:4).EQ.'BLAN')ICHAPA(I)='BLAN' 12452 IF(ICHAPA(I)(1:4).EQ.'blan')ICHAPA(I)='BLAN' 12453 IF(ICHAPA(I)(1:4).EQ.'NONE')ICHAPA(I)='BLAN' 12454 IF(ICHAPA(I).EQ.'BL')ICHAPA(I)='BLAN' 12455 IF(ICHAPA(I).EQ.'bl')ICHAPA(I)='BLAN' 12456 IF(ICHAPA(I).EQ.'NO')ICHAPA(I)='BLAN' 12457 8010 CONTINUE 12458 GOTO9000 12459C 12460C ***************** 12461C ** STEP 90-- ** 12462C ** EXIT ** 12463C ***************** 12464C 12465 9000 CONTINUE 12466C 12467 IHYPSW=IHYPSV 12468C 12469 IF(IBUGP2.EQ.'ON' .OR. ISUBRO.EQ.'CHAR')THEN 12470 WRITE(ICOUT,999) 12471 CALL DPWRST('XXX','BUG ') 12472 WRITE(ICOUT,9011) 12473 9011 FORMAT('***** AT THE END OF DPCHAR--') 12474 CALL DPWRST('XXX','BUG ') 12475 WRITE(ICOUT,9013)IBUGP2,IFOUND,IERROR 12476 9013 FORMAT('IBUGP2,IFOUND,IERROR = ',2(A4,2X),A4) 12477 CALL DPWRST('XXX','BUG ') 12478 WRITE(ICOUT,9014)IMAX,NY,NX,MAXCHA,ICHAOF 12479 9014 FORMAT('IMAX,NY,NX,MAXCHA,ICHAOF = ',5I8) 12480 CALL DPWRST('XXX','BUG ') 12481 IF(NY.GT.0)THEN 12482 DO9023I=1,NY 12483 WRITE(ICOUT,9024)I,Y(I) 12484 9024 FORMAT('I,Y(I) = ',I8,E15.7) 12485 CALL DPWRST('XXX','BUG ') 12486 9023 CONTINUE 12487 ENDIF 12488 IF(NX.GT.0)THEN 12489 DO9033I=1,NX 12490 WRITE(ICOUT,9034)I,X(I),ICHAPA(I) 12491 9034 FORMAT('I,X(I),ICHAPA(I) = ',I8,G15.7,2X,A24) 12492 CALL DPWRST('XXX','BUG ') 12493 9033 CONTINUE 12494 ENDIF 12495 ENDIF 12496C 12497 RETURN 12498 END 12499 SUBROUTINE DPCHCA(IHARG,NUMARG,IDEFCA,MAXCHA,ICHACA,IFOUND,IERROR) 12500C 12501C PURPOSE--DEFINE PLOT CHARACTER CASES FOR USE IN MULTI-TRACE PLOTS. 12502C THE CASE FOR THE CHARACTER FOR THE I-TH TRACE 12503C WILL BE PLACED 12504C IN THE I-TH ELEMENT OF THE HOLLERITH 12505C VECTOR ICHACA(.). 12506C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 12507C --NUMARG 12508C --IDEFCA 12509C --MAXCHA 12510C OUTPUT ARGUMENTS--ICHACA (A HOLLERITH VECTOR 12511C WHOSE I-TH ELEMENT IS THE CASE 12512C FOR THE CHARACTER 12513C ASSIGNED TO THE I-TH TRACE IN 12514C A MULTI-TRACE PLOT. 12515C --IFOUND ('YES' OR 'NO' ) 12516C --IERROR ('YES' OR 'NO' ) 12517C WRITTEN BY--ALAN HECKERT 12518C COMPUTER SERVICES DIVISION 12519C INFORMATION TECHNOLOGY LABORATORY 12520C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 12521C GAITHERSBURG, MD 20899-8980 12522C PHONE--301-975-2899 12523C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12524C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 12525C LANGUAGE--ANSI FORTRAN (1977) 12526C VERSION NUMBER--82/7 12527C ORIGINAL VERSION--DECEMBER 1977. 12528C UPDATED --SEPTEMBER 1980. 12529C UPDATED --MARCH 1982. 12530C UPDATED --MAY 1982. 12531C 12532C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12533C 12534 CHARACTER*4 IHARG 12535 CHARACTER*4 IDEFCA 12536 CHARACTER*4 ICHACA 12537 CHARACTER*4 IFOUND 12538 CHARACTER*4 IERROR 12539C 12540C--------------------------------------------------------------------- 12541C 12542 DIMENSION IHARG(*) 12543 DIMENSION ICHACA(*) 12544C 12545C--------------------------------------------------------------------- 12546C 12547 INCLUDE 'DPCOP2.INC' 12548C 12549C-----START POINT----------------------------------------------------- 12550C 12551 IFOUND='NO' 12552 IERROR='NO' 12553C 12554 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'CASE')GOTO1160 12555 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CASE')GOTO1105 12556 GOTO1199 12557C 12558 1105 CONTINUE 12559 IF(IHARG(NUMARG).EQ.'ON')GOTO1110 12560 IF(IHARG(NUMARG).EQ.'OFF')GOTO1110 12561 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 12562 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 12563C 12564 IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160 12565 IF(NUMARG.EQ.2)GOTO1120 12566 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130 12567 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140 12568C 12569 GOTO1150 12570C 12571 1110 CONTINUE 12572 DO1115I=1,MAXCHA 12573 ICHACA(I)=IDEFCA 12574 1115 CONTINUE 12575C 12576 IF(IFEEDB.EQ.'OFF')GOTO1119 12577 WRITE(ICOUT,999) 12578 999 FORMAT(1X) 12579 CALL DPWRST('XXX','BUG ') 12580 I=1 12581 WRITE(ICOUT,1116)ICHACA(I) 12582 1116 FORMAT('ALL CHARACTER CASES HAVE JUST BEEN SET TO ', 12583 1A4) 12584 CALL DPWRST('XXX','BUG ') 12585 1119 CONTINUE 12586 GOTO1190 12587C 12588 1120 CONTINUE 12589 ICHACA(1)=IHARG(2) 12590C 12591 IF(IFEEDB.EQ.'OFF')GOTO1129 12592 WRITE(ICOUT,999) 12593 CALL DPWRST('XXX','BUG ') 12594 I=1 12595 WRITE(ICOUT,1126)I,ICHACA(I) 12596 1126 FORMAT('THE CASE FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ', 12597 1A4) 12598 CALL DPWRST('XXX','BUG ') 12599 1129 CONTINUE 12600 GOTO1190 12601C 12602 1130 CONTINUE 12603 DO1135I=1,MAXCHA 12604 ICHACA(I)=IHARG(3) 12605 1135 CONTINUE 12606C 12607 IF(IFEEDB.EQ.'OFF')GOTO1139 12608 WRITE(ICOUT,999) 12609 CALL DPWRST('XXX','BUG ') 12610 I=1 12611 WRITE(ICOUT,1116)ICHACA(I) 12612 CALL DPWRST('XXX','BUG ') 12613 1139 CONTINUE 12614 GOTO1190 12615C 12616 1140 CONTINUE 12617 DO1145I=1,MAXCHA 12618 ICHACA(I)=IHARG(2) 12619 1145 CONTINUE 12620C 12621 IF(IFEEDB.EQ.'OFF')GOTO1149 12622 WRITE(ICOUT,999) 12623 CALL DPWRST('XXX','BUG ') 12624 I=1 12625 WRITE(ICOUT,1116)ICHACA(I) 12626 CALL DPWRST('XXX','BUG ') 12627 1149 CONTINUE 12628 GOTO1190 12629C 12630 1150 CONTINUE 12631 IMAX=NUMARG-1 12632 IF(MAXCHA.LT.IMAX)IMAX=MAXCHA 12633 DO1155I=1,IMAX 12634 IP1=I+1 12635 ICHACA(I)=IHARG(IP1) 12636 1155 CONTINUE 12637C 12638 IF(IFEEDB.EQ.'OFF')GOTO1159 12639 WRITE(ICOUT,999) 12640 CALL DPWRST('XXX','BUG ') 12641 DO1156I=1,IMAX 12642 WRITE(ICOUT,1126)I,ICHACA(I) 12643 CALL DPWRST('XXX','BUG ') 12644 1156 CONTINUE 12645 1159 CONTINUE 12646 GOTO1190 12647C 12648 1160 CONTINUE 12649 DO1165I=1,MAXCHA 12650 ICHACA(I)=IDEFCA 12651 1165 CONTINUE 12652C 12653 IF(IFEEDB.EQ.'OFF')GOTO1169 12654 WRITE(ICOUT,999) 12655 CALL DPWRST('XXX','BUG ') 12656 I=1 12657 WRITE(ICOUT,1116)ICHACA(I) 12658 CALL DPWRST('XXX','BUG ') 12659 1169 CONTINUE 12660 GOTO1190 12661C 12662 1190 CONTINUE 12663 IFOUND='YES' 12664C 12665 1199 CONTINUE 12666 RETURN 12667 END 12668 SUBROUTINE DPCHCL(IHARG,NUMARG,IDEFCO,MAXCHA,ICHACO,IFOUND,IERROR) 12669C 12670C PURPOSE--DEFINE PLOT CHARACTER COLORS FOR USE IN MULTI-TRACE PLOTS. 12671C THE COLOR FOR THE CHARACTER FOR THE I-TH TRACE 12672C WILL BE PLACED 12673C IN THE I-TH ELEMENT OF THE HOLLERITH 12674C VECTOR ICHACO(.). 12675C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 12676C --NUMARG 12677C --IDEFCO 12678C --MAXCHA 12679C OUTPUT ARGUMENTS--ICHACO (A HOLLERITH VECTOR 12680C WHOSE I-TH ELEMENT IS THE COLOR 12681C FOR THE CHARACTER 12682C ASSIGNED TO THE I-TH TRACE IN 12683C A MULTI-TRACE PLOT. 12684C --IFOUND ('YES' OR 'NO' ) 12685C --IERROR ('YES' OR 'NO' ) 12686C WRITTEN BY--JAMES J. FILLIBEN 12687C STATISTICAL ENGINEERING DIVISION 12688C INFORMATION TECHNOLOGY LABORATORY 12689C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 12690C GAITHERSBURG, MD 20899-8980 12691C PHONE--301-975-2899 12692C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12693C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 12694C LANGUAGE--ANSI FORTRAN (1977) 12695C VERSION NUMBER--82/7 12696C ORIGINAL VERSION--DECEMBER 1977. 12697C UPDATED --SEPTEMBER 1980. 12698C UPDATED --MARCH 1982. 12699C UPDATED --MAY 1982. 12700C 12701C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12702C 12703 CHARACTER*4 IHARG 12704 CHARACTER*4 IDEFCO 12705 CHARACTER*4 ICHACO 12706 CHARACTER*4 IFOUND 12707 CHARACTER*4 IERROR 12708C 12709C--------------------------------------------------------------------- 12710C 12711 DIMENSION IHARG(*) 12712 DIMENSION ICHACO(*) 12713C 12714C--------------------------------------------------------------------- 12715C 12716 INCLUDE 'DPCOP2.INC' 12717C 12718C-----START POINT----------------------------------------------------- 12719C 12720 IFOUND='NO' 12721 IERROR='NO' 12722C 12723 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'COLO')GOTO1160 12724 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'COLO')GOTO1105 12725 GOTO1199 12726C 12727 1105 CONTINUE 12728 IF(IHARG(NUMARG).EQ.'ON')GOTO1110 12729 IF(IHARG(NUMARG).EQ.'OFF')GOTO1110 12730 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 12731 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 12732C 12733 IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160 12734 IF(NUMARG.EQ.2)GOTO1120 12735 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130 12736 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140 12737C 12738 GOTO1150 12739C 12740 1110 CONTINUE 12741 DO1115I=1,MAXCHA 12742 ICHACO(I)=IDEFCO 12743 1115 CONTINUE 12744C 12745 IF(IFEEDB.EQ.'OFF')GOTO1119 12746 WRITE(ICOUT,999) 12747 999 FORMAT(1X) 12748 CALL DPWRST('XXX','BUG ') 12749 I=1 12750 WRITE(ICOUT,1116)ICHACO(I) 12751 1116 FORMAT('ALL CHARACTER COLORS HAVE JUST BEEN SET TO ', 12752 1A4) 12753 CALL DPWRST('XXX','BUG ') 12754 1119 CONTINUE 12755 GOTO1190 12756C 12757 1120 CONTINUE 12758 ICHACO(1)=IHARG(2) 12759C 12760 IF(IFEEDB.EQ.'OFF')GOTO1129 12761 WRITE(ICOUT,999) 12762 CALL DPWRST('XXX','BUG ') 12763 I=1 12764 WRITE(ICOUT,1126)I,ICHACO(I) 12765 1126 FORMAT('THE COLOR FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ', 12766 1A4) 12767 CALL DPWRST('XXX','BUG ') 12768 1129 CONTINUE 12769 GOTO1190 12770C 12771 1130 CONTINUE 12772 DO1135I=1,MAXCHA 12773 ICHACO(I)=IHARG(3) 12774 1135 CONTINUE 12775C 12776 IF(IFEEDB.EQ.'OFF')GOTO1139 12777 WRITE(ICOUT,999) 12778 CALL DPWRST('XXX','BUG ') 12779 I=1 12780 WRITE(ICOUT,1116)ICHACO(I) 12781 CALL DPWRST('XXX','BUG ') 12782 1139 CONTINUE 12783 GOTO1190 12784C 12785 1140 CONTINUE 12786 DO1145I=1,MAXCHA 12787 ICHACO(I)=IHARG(2) 12788 1145 CONTINUE 12789C 12790 IF(IFEEDB.EQ.'OFF')GOTO1149 12791 WRITE(ICOUT,999) 12792 CALL DPWRST('XXX','BUG ') 12793 I=1 12794 WRITE(ICOUT,1116)ICHACO(I) 12795 CALL DPWRST('XXX','BUG ') 12796 1149 CONTINUE 12797 GOTO1190 12798C 12799 1150 CONTINUE 12800 IMAX=NUMARG-1 12801 IF(MAXCHA.LT.IMAX)IMAX=MAXCHA 12802 DO1155I=1,IMAX 12803 IP1=I+1 12804 ICHACO(I)=IHARG(IP1) 12805 1155 CONTINUE 12806C 12807 IF(IFEEDB.EQ.'OFF')GOTO1159 12808 WRITE(ICOUT,999) 12809 CALL DPWRST('XXX','BUG ') 12810 DO1156I=1,IMAX 12811 WRITE(ICOUT,1126)I,ICHACO(I) 12812 CALL DPWRST('XXX','BUG ') 12813 1156 CONTINUE 12814 1159 CONTINUE 12815 GOTO1190 12816C 12817 1160 CONTINUE 12818 DO1165I=1,MAXCHA 12819 ICHACO(I)=IDEFCO 12820 1165 CONTINUE 12821C 12822 IF(IFEEDB.EQ.'OFF')GOTO1169 12823 WRITE(ICOUT,999) 12824 CALL DPWRST('XXX','BUG ') 12825 I=1 12826 WRITE(ICOUT,1116)ICHACO(I) 12827 CALL DPWRST('XXX','BUG ') 12828 1169 CONTINUE 12829 GOTO1190 12830C 12831 1190 CONTINUE 12832 IFOUND='YES' 12833C 12834 1199 CONTINUE 12835 RETURN 12836 END 12837 SUBROUTINE DPCHEC(K,IHOL,IHOL2, 12838 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 12839 1INT1,FLOAT1,IBUGA3,IERROR) 12840C 12841C PURPOSE--EXAMINE COMPONENT K OF IHOL(.) AND IHOL2(.). 12842C IF IT IS A PARAMETER NAME, DETERMINE THE VALUE 12843C OF THE PARAMETER AND PLACE THIS VALUE 12844C IN INT1(K) AND FLOAT1(K). 12845C IF OTHERWISE, DO NOTHING. 12846C WRITTEN BY--JAMES J. FILLIBEN 12847C STATISTICAL ENGINEERING DIVISION 12848C INFORMATION TECHNOLOGY LABORATORY 12849C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 12850C GAITHERSBURG, MD 20899-8980 12851C PHONE--301-975-2899 12852C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12853C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 12854C LANGUAGE--ANSI FORTRAN (1977) 12855C VERSION NUMBER--82/7 12856C ORIGINAL VERSION--JANUARY 1982. 12857C UPDATED --MAY 1982. 12858C 12859C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12860C 12861 CHARACTER*4 IHOL 12862 CHARACTER*4 IHOL2 12863 CHARACTER*4 IHNAME 12864 CHARACTER*4 IHNAM2 12865 CHARACTER*4 IUSE 12866 CHARACTER*4 IBUGA3 12867 CHARACTER*4 IERROR 12868C 12869 CHARACTER*4 IH 12870 CHARACTER*4 IH2 12871C 12872C--------------------------------------------------------------------- 12873C 12874 DIMENSION IHOL(*) 12875 DIMENSION IHOL2(*) 12876C 12877 DIMENSION IHNAME(*) 12878 DIMENSION IHNAM2(*) 12879 DIMENSION IUSE(*) 12880 DIMENSION IVALUE(*) 12881 DIMENSION VALUE(*) 12882C 12883 DIMENSION INT1(*) 12884 DIMENSION FLOAT1(*) 12885C 12886C--------------------------------------------------------------------- 12887C 12888 INCLUDE 'DPCOP2.INC' 12889C 12890C-----START POINT----------------------------------------------------- 12891C 12892 IERROR='NO' 12893C 12894 IF(IBUGA3.EQ.'OFF')GOTO90 12895 WRITE(ICOUT,999) 12896 999 FORMAT(1X) 12897 CALL DPWRST('XXX','BUG ') 12898 WRITE(ICOUT,51) 12899 51 FORMAT('****** AT THE BEGINNING OF DPCHEC--') 12900 CALL DPWRST('XXX','BUG ') 12901 WRITE(ICOUT,52)K,IHOL(K),IHOL2(K) 12902 52 FORMAT('K,IHOL(K),IHOL2(K) = ',I8,2X,A4,2X,A4) 12903 CALL DPWRST('XXX','BUG ') 12904 WRITE(ICOUT,53)NUMNAM,IBUGA3,IERROR 12905 53 FORMAT('NUMNAM,IBUGA3,IERROR = ',I8,2X,A4,2X,A4) 12906 CALL DPWRST('XXX','BUG ') 12907 DO55I=1,NUMNAM 12908 WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) 12909 56 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) = ', 12910 1I8,2X,A4,2X,A4,2X,A4,I8,E15.7) 12911 CALL DPWRST('XXX','BUG ') 12912 55 CONTINUE 12913 WRITE(ICOUT,57)K,INT1(K),FLOAT1(K) 12914 57 FORMAT('K,INT1(K),FLOAT1(K) = ',I8,I8,E15.7) 12915 CALL DPWRST('XXX','BUG ') 12916 90 CONTINUE 12917C 12918 IH=IHOL(K) 12919 IH2=IHOL2(K) 12920 IF(NUMNAM.LE.0)GOTO2799 12921 DO2795I=1,NUMNAM 12922 IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND. 12923 1IUSE(I).EQ.'P')GOTO2796 12924 GOTO2795 12925 2796 CONTINUE 12926 INT1(K)=IVALUE(I) 12927 FLOAT1(K)=VALUE(I) 12928 GOTO2799 12929 2795 CONTINUE 12930 2799 CONTINUE 12931C 12932C ***************** 12933C ** STEP 90-- ** 12934C ** EXIT. ** 12935C ***************** 12936C 12937 IF(IBUGA3.EQ.'OFF')GOTO9090 12938 WRITE(ICOUT,999) 12939 CALL DPWRST('XXX','BUG ') 12940 WRITE(ICOUT,9011) 12941 9011 FORMAT('****** AT THE END OF DPCHEC--') 12942 CALL DPWRST('XXX','BUG ') 12943 WRITE(ICOUT,9012)K,IHOL(K),IHOL2(K) 12944 9012 FORMAT('K,IHOL(K),IHOL2(K) = ',I8,2X,A4,2X,A4) 12945 CALL DPWRST('XXX','BUG ') 12946 WRITE(ICOUT,9013)NUMNAM,IBUGA3,IERROR 12947 9013 FORMAT('NUMNAM,IBUGA3,IERROR = ',I8,2X,A4,2X,A4) 12948 CALL DPWRST('XXX','BUG ') 12949 DO9015I=1,NUMNAM 12950 WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) 12951 9016 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) = ', 12952 1I8,2X,A4,2X,A4,2X,A4,I8,E15.7) 12953 CALL DPWRST('XXX','BUG ') 12954 9015 CONTINUE 12955 WRITE(ICOUT,9017)K,INT1(K),FLOAT1(K) 12956 9017 FORMAT('K,INT1(K),FLOAT1(K) = ',I8,I8,E15.7) 12957 CALL DPWRST('XXX','BUG ') 12958 9090 CONTINUE 12959C 12960 RETURN 12961 END 12962 SUBROUTINE DPCHEX(ISTAR1,ILEN1,IX1,ISTAR2,ILEN2,IX2) 12963C 12964C PURPOSE--CHARACTER EXTRACTION-- 12965C GIVEN A CHARACTER STRING IN A WORD (IX1), 12966C MOVE THE BIT STRING WHICH STARTS IN BIT ISTAR1 12967C (ISTAR1 RANGES FROM 0 TO 35 IN A UNIVAC 1108, 12968C 0 TO 31 IN AN IBM 3033, 12969C 0 TO 59 IN A CDC 7600, ETC. 12970C AND IS OF LENGTH ILEN1 BITS) 12971C INTO BITS STARTING AT ISTAR2 OF LENGTH ILEN2 12972C (HERE ILEN2 USUALLY = ILEN1) IN THE WORD IX2. 12973C OUTPUT THE NEW CHARACTER VARIABLE (IX2). 12974C NOTE--0 DENOTES THE LEFT-MOST (THAT IS, THE HIGH-ORDER) BIT. 12975C NOTE--ISTAR1 AND ISTAR2 RANGE FROM 0 TO NUMBPW-1 12976C THAT IS, FROM 0 TO ONE LESS THAN THE TOTLA NUMBER OF BITS PER WORD. 12977C (FOR EXAMPLE, ON UNIVAC 1100/82--FROM 0 TO 35 12978C ON VAX 11/780 --FROM 0 TO 31) 12979C NOTE--IX1 AND IX2 ARE CHARACTER*4 VARIABLES. 12980C NOTE--THIS SUBROUTINE HAS BEEN CONSTRAINED SO THAT 12981C NEITHER ILEN1 NOR ILEN2 ARE EXPLICITELY USED. 12982C THIS SUBROUTINE, AS CODED, OPERATES ON THE ASSUMPTIONS THAT 12983C 1) ILEN1 = NUMBPC (THAT IS, THE LENGTH 12984C OF THE BIT STRING BEING MOVED IS IDENTICAL 12985C TO THE NUMBER OF BITS PER CHARACTER ON 12986C YOUR COMPUTER). 12987C 2) ILEN2 = ILEN1 (THAT IS, THE LENGTH OF THE OUTPUT STRING = 12988C THE LENGTH OF THE INPUT STRING), 12989C 3) ISTAR1 IS SUCH THAT THE START OF THE BIT STRING 12990C IS ALWAYS AT THE BEGINNING OF A CHARACTER 12991C THE NET RESULT IS THAT THIS SUBROUTINE, AS CODED, 12992C EXTRACTS EXACTLY 1 CHARACTER AND 12993C MOVES IT TO THE POSITION OF ANOTHER CHARACTER. 12994C THESE CONSTRAINTS WILL BE ACCEPTABLE FOR ALL USES 12995C OF THIS SUBROUTINE BY ANY OTHER DATAPLOT SUBROUTINE. 12996C NOTE--THE VALUES FOR NUMBPC (NUMBER OF BITS PER CHARACTER) 12997C AND NUMBPW (NUMBER OF BITS PER WORD) ARE SET 12998C FOR YOUR COMPUTER IN DATAPLOT SUBROUTINE INITMC. 12999C NOTE--ALGORITHM PROVIDED BY MICHAEL VOGT 13000C INFORMATION TECHNOLOGY LABORATORY 13001C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13002C 13003C WRITTEN BY--JAMES J. FILLIBEN 13004C STATISTICAL ENGINEERING DIVISION 13005C INFORMATION TECHNOLOGY LABORATORY 13006C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13007C GAITHERSBURG, MD 20899-8980 13008C PHONE--301-975-2899 13009C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13010C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13011C LANGUAGE--ANSI FORTRAN (1977) 13012C VERSION NUMBER--82/7 13013C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--OCTOBER 1978. 13014C UPDATED --JUNE 1981. 13015C UPDATED --OCTOBER 1981. 13016C UPDATED --MAY 1982. 13017C 13018C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13019C 13020 CHARACTER*4 IX1 13021 CHARACTER*4 IX2 13022C 13023C--------------------------------------------------------------------- 13024C 13025C--------------------------------------------------------------------- 13026C 13027 INCLUDE 'DPCOBE.INC' 13028 INCLUDE 'DPCOP2.INC' 13029C 13030C-----START POINT----------------------------------------------------- 13031C 13032C ******************************************************** 13033C ** THE FOLLOWING CODE WILL CARRY OUT ** 13034C ** THE CHARACTER EXTRACTION FOR ALL COMPUTERS ** 13035C ** WITH AN ANSI 77 FORTRAN COMPILER--IT MAKES ** 13036C ** USE OF THE ANSI FORTRAN 77 CONSTRUCT-- ** 13037C ** IY(IC:ID)=IX(IA:IB) ** 13038C ** WHERE IX AND IY ARE CHARACTER*4 VARIABLES, ** 13039C ** WHERE IA, IB, IC, AND ID ARE INTEGER VARIABLES, ** 13040C ** AND WHERE IY(IC:ID)=IX(IA:IB) MEANS ** 13041C ** TO COPY CHARACTERS IA THROUGH IB OF VARIABLE IX AND 13042C ** PLACE THEM INTO CHARACTERS IC THROUGH ID OF VARIABLE IY. 13043C ** WITH ALL OTHER CHARACTERS IN IY BEING UNAFFECTED. ** 13044C ** USUALLY IA, IB, IC, AND ID RANGE FROM 1 TO 4. ** 13045C ******************************************************** 13046C 13047 IF(ISUBG4.EQ.'CHEX')THEN 13048 WRITE(ICOUT,51)ISTAR1,ILEN1,IX1,ISTAR2,ILEN2,IX2 13049 51 FORMAT('FROM DPCHEX: ISTAR1,ILEN1,IX1,ISTAR2,ILEN2,IX2 = ',6I5) 13050 CALL DPWRST('XXX','BUG ') 13051 ENDIF 13052C 13053 IBYTE1=(ISTAR1+NUMBPC)/NUMBPC 13054 IBYTE2=(ISTAR2+NUMBPC)/NUMBPC 13055 IX2(IBYTE2:IBYTE2)=IX1(IBYTE1:IBYTE1) 13056 GOTO9000 13057C 13058C **************************************************************** 13059C ** CHARACTER EXTRACTION FOR THE UNIVAC 1100 SERIES. FOR COMPILE 13060C ** (FORTRAN 1966 COMPILER) 13061C **************************************************************** 13062C 13063CCCCC ISTAR1=IABS(ISTAR1) 13064CCCCC ISTAR2=IABS(ISTAR2) 13065C 13066CCCCC FLD(ISTAR2,ILEN2,IX2)=FLD(ISTAR1,ILEN1,IX1) 13067C 13068C **************************************************************** 13069C ** CHARACTER EXTRACTION FOR THE UNIVAC 1100 SERIES. FTN COMPILE 13070C ** (FORTRAN 1977 COMPILER) 13071C **************************************************************** 13072C 13073CCCCC ISTR1P=ISTAR1+1 13074CCCCC ISTR2P=ISTAR2+1 13075C 13076CCCCC BITS(IX2,ISTR2P,ILEN2)=BITS(IX1,ISTR1P,ILEN1) 13077C 13078C *********************************************** 13079C ** CHARACTER EXTRACTION FOR THE VAX-11/780 ** 13080C ** (FORTRAN 1966 COMPILER) 13081C *********************************************** 13082C 13083CCCCC LOGICAL*1 IX1(4) 13084CCCCC LOGICAL*1 IX2(4) 13085C 13086CCCCC I1=(ISTAR1+8)/8 13087CCCCC I2=(ISTAR2+8)/8 13088CCCCC IX2(I2)=IX1(I1) 13089C 13090C ***************** 13091C ** STEP 90-- ** 13092C ** EXIT ** 13093C ***************** 13094C 13095 9000 CONTINUE 13096 RETURN 13097 END 13098 SUBROUTINE DPCHFI(IHARG,NUMARG,IDEFFI,MAXCHA,ICHAFI,IFOUND,IERROR) 13099C 13100C PURPOSE--DEFINE PLOT CHARACTER FILL SWITCH FOR USE IN MULTI-TRACE PLOTS. 13101C THE FILL SWITCH FOR THE CHARACTER FOR THE I-TH TRACE 13102C WILL BE PLACED 13103C IN THE I-TH ELEMENT OF THE HOLLERITH 13104C VECTOR ICHAFI(.). 13105C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 13106C --NUMARG 13107C --IDEFFI 13108C --MAXCHA 13109C OUTPUT ARGUMENTS--ICHAFI (A HOLLERITH VECTOR 13110C WHOSE I-TH ELEMENT IS THE FILL SWITCH 13111C FOR THE CHARACTER 13112C ASSIGNED TO THE I-TH TRACE IN 13113C A MULTI-TRACE PLOT. 13114C --IFOUND ('YES' OR 'NO' ) 13115C --IERROR ('YES' OR 'NO' ) 13116C WRITTEN BY--JAMES J. FILLIBEN 13117C STATISTICAL ENGINEERING DIVISION 13118C INFORMATION TECHNOLOGY LABORATORY 13119C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13120C GAITHERSBURG, MD 20899-8980 13121C PHONE--301-975-2899 13122C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13123C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13124C LANGUAGE--ANSI FORTRAN (1977) 13125C VERSION NUMBER--82/7 13126C ORIGINAL VERSION--DECEMBER 1977. 13127C UPDATED --SEPTEMBER 1980. 13128C UPDATED --MARCH 1982. 13129C UPDATED --MAY 1982. 13130C UPDATED --JUNE 1998. CHECK FOR CHARCTER FILL COLOR 13131C (SKIP IF ABOVE FOUND) 13132C 13133C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13134C 13135 CHARACTER*4 IHARG 13136 CHARACTER*4 IDEFFI 13137 CHARACTER*4 ICHAFI 13138 CHARACTER*4 IFOUND 13139 CHARACTER*4 IERROR 13140C 13141C--------------------------------------------------------------------- 13142C 13143 DIMENSION IHARG(*) 13144 DIMENSION ICHAFI(*) 13145C 13146C--------------------------------------------------------------------- 13147C 13148 INCLUDE 'DPCOP2.INC' 13149C 13150C-----START POINT----------------------------------------------------- 13151C 13152 IFOUND='NO' 13153 IERROR='NO' 13154C 13155 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'FILL')GOTO1160 13156 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'FILL')GOTO1105 13157 GOTO1199 13158C 13159 1105 CONTINUE 13160CCCCC IF(IHARG(NUMARG).EQ.'ON')GOTO1110 13161CCCCC IF(IHARG(NUMARG).EQ.'OFF')GOTO1110 13162 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 13163 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 13164CCCCC ADD FOLLOWING LINE JUNE 1998 13165 IF(IHARG(NUMARG).EQ.'COLO')GOTO1199 13166C 13167 IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160 13168 IF(NUMARG.EQ.2)GOTO1120 13169 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130 13170 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140 13171C 13172 GOTO1150 13173C 13174 1110 CONTINUE 13175 DO1115I=1,MAXCHA 13176 ICHAFI(I)=IDEFFI 13177 IF(IHARG(NUMARG).EQ.'ON')ICHAFI(I)='ON' 13178 IF(IHARG(NUMARG).EQ.'OFF')ICHAFI(I)='OFF' 13179 IF(IHARG(NUMARG).EQ.'AUTO')ICHAFI(I)='ON' 13180 1115 CONTINUE 13181C 13182 IF(IFEEDB.EQ.'OFF')GOTO1119 13183 WRITE(ICOUT,999) 13184 999 FORMAT(1X) 13185 CALL DPWRST('XXX','BUG ') 13186 I=1 13187 WRITE(ICOUT,1116)ICHAFI(I) 13188 1116 FORMAT('ALL CHARACTER FILL SWITCHES HAVE JUST BEEN SET TO ', 13189 1A4) 13190 CALL DPWRST('XXX','BUG ') 13191 1119 CONTINUE 13192 GOTO1190 13193C 13194 1120 CONTINUE 13195 ICHAFI(1)=IHARG(2) 13196C 13197 IF(IFEEDB.EQ.'OFF')GOTO1129 13198 WRITE(ICOUT,999) 13199 CALL DPWRST('XXX','BUG ') 13200 I=1 13201 WRITE(ICOUT,1126)I,ICHAFI(I) 13202 1126 FORMAT('THE FILL SWITCH FOR CHARACTER ',I6, 13203 1' HAS JUST BEEN SET TO ',A4) 13204 CALL DPWRST('XXX','BUG ') 13205 1129 CONTINUE 13206 GOTO1190 13207C 13208 1130 CONTINUE 13209 DO1135I=1,MAXCHA 13210 ICHAFI(I)=IHARG(3) 13211 1135 CONTINUE 13212C 13213 IF(IFEEDB.EQ.'OFF')GOTO1139 13214 WRITE(ICOUT,999) 13215 CALL DPWRST('XXX','BUG ') 13216 I=1 13217 WRITE(ICOUT,1116)ICHAFI(I) 13218 CALL DPWRST('XXX','BUG ') 13219 1139 CONTINUE 13220 GOTO1190 13221C 13222 1140 CONTINUE 13223 DO1145I=1,MAXCHA 13224 ICHAFI(I)=IHARG(2) 13225 1145 CONTINUE 13226C 13227 IF(IFEEDB.EQ.'OFF')GOTO1149 13228 WRITE(ICOUT,999) 13229 CALL DPWRST('XXX','BUG ') 13230 I=1 13231 WRITE(ICOUT,1116)ICHAFI(I) 13232 CALL DPWRST('XXX','BUG ') 13233 1149 CONTINUE 13234 GOTO1190 13235C 13236 1150 CONTINUE 13237 IMAX=NUMARG-1 13238 IF(MAXCHA.LT.IMAX)IMAX=MAXCHA 13239 DO1155I=1,IMAX 13240 IP1=I+1 13241 ICHAFI(I)=IHARG(IP1) 13242 1155 CONTINUE 13243C 13244 IF(IFEEDB.EQ.'OFF')GOTO1159 13245 WRITE(ICOUT,999) 13246 CALL DPWRST('XXX','BUG ') 13247 DO1156I=1,IMAX 13248 WRITE(ICOUT,1126)I,ICHAFI(I) 13249 CALL DPWRST('XXX','BUG ') 13250 1156 CONTINUE 13251 1159 CONTINUE 13252 GOTO1190 13253C 13254 1160 CONTINUE 13255 DO1165I=1,MAXCHA 13256 ICHAFI(I)=IDEFFI 13257 IF(IHARG(1).EQ.'ON')ICHAFI(I)='ON' 13258 IF(IHARG(1).EQ.'OFF')ICHAFI(I)='OFF' 13259 IF(IHARG(1).EQ.'AUTO')ICHAFI(I)='ON' 13260 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'FILL')ICHAFI(I)='ON' 13261 1165 CONTINUE 13262C 13263 IF(IFEEDB.EQ.'OFF')GOTO1169 13264 WRITE(ICOUT,999) 13265 CALL DPWRST('XXX','BUG ') 13266 I=1 13267 WRITE(ICOUT,1116)ICHAFI(I) 13268 CALL DPWRST('XXX','BUG ') 13269 1169 CONTINUE 13270 GOTO1190 13271C 13272 1190 CONTINUE 13273 IFOUND='YES' 13274C 13275 1199 CONTINUE 13276 RETURN 13277 END 13278 SUBROUTINE DPCHFO(IHARG,NUMARG,IDEFFO,MAXCHA,ICHAFO,IFOUND,IERROR) 13279C 13280C PURPOSE--DEFINE PLOT CHARACTER FONTS FOR USE IN MULTI-TRACE PLOTS. 13281C THE FONT FOR THE CHARACTER FOR THE I-TH TRACE 13282C WILL BE PLACED 13283C IN THE I-TH ELEMENT OF THE HOLLERITH 13284C VECTOR ICHAFO(.). 13285C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 13286C --NUMARG 13287C --IDEFFO 13288C --MAXCHA 13289C OUTPUT ARGUMENTS--ICHAFO (A HOLLERITH VECTOR 13290C WHOSE I-TH ELEMENT IS THE FONT 13291C FOR THE CHARACTER 13292C ASSIGNED TO THE I-TH TRACE IN 13293C A MULTI-TRACE PLOT. 13294C --IFOUND ('YES' OR 'NO' ) 13295C --IERROR ('YES' OR 'NO' ) 13296C WRITTEN BY--ALAN HECKERT 13297C COMPUTER SERVICES DIVISION 13298C INFORMATION TECHNOLOGY LABORATORY 13299C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13300C GAITHERSBURG, MD 20899-8980 13301C PHONE--301-975-2899 13302C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13303C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13304C LANGUAGE--ANSI FORTRAN (1977) 13305C VERSION NUMBER--82/7 13306C ORIGINAL VERSION--DECEMBER 1977. 13307C UPDATED --SEPTEMBER 1980. 13308C UPDATED --MARCH 1982. 13309C UPDATED --MAY 1982. 13310C 13311C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13312C 13313 CHARACTER*4 IHARG 13314 CHARACTER*4 IDEFFO 13315 CHARACTER*4 ICHAFO 13316 CHARACTER*4 IFOUND 13317 CHARACTER*4 IERROR 13318C 13319C--------------------------------------------------------------------- 13320C 13321 DIMENSION IHARG(*) 13322 DIMENSION ICHAFO(*) 13323C 13324C--------------------------------------------------------------------- 13325C 13326 INCLUDE 'DPCOP2.INC' 13327C 13328C-----START POINT----------------------------------------------------- 13329C 13330 IFOUND='NO' 13331 IERROR='NO' 13332C 13333 IF((NUMARG.EQ.1.AND.IHARG(1).EQ.'FONT') .OR. 13334 1 (NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL'))THEN 13335 DO1165I=1,MAXCHA 13336 ICHAFO(I)=IDEFFO 13337 1165 CONTINUE 13338C 13339 IF(IFEEDB.EQ.'ON')THEN 13340 WRITE(ICOUT,999) 13341 CALL DPWRST('XXX','BUG ') 13342 I=1 13343 WRITE(ICOUT,1116)ICHAFO(I) 13344 CALL DPWRST('XXX','BUG ') 13345 ENDIF 13346 ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'FONT')THEN 13347 IF(IHARG(NUMARG).EQ.'ON' .OR. IHARG(NUMARG).EQ.'OFF' .OR. 13348 1 IHARG(NUMARG).EQ.'AUTO' .OR. IHARG(NUMARG).EQ.'DEFA')THEN 13349 DO1115I=1,MAXCHA 13350 ICHAFO(I)=IDEFFO 13351 1115 CONTINUE 13352C 13353 IF(IFEEDB.EQ.'ON')THEN 13354 WRITE(ICOUT,999) 13355 999 FORMAT(1X) 13356 CALL DPWRST('XXX','BUG ') 13357 I=1 13358 WRITE(ICOUT,1116)ICHAFO(I) 13359 1116 FORMAT('ALL CHARACTER FONTS HAVE JUST BEEN SET TO ',A4) 13360 CALL DPWRST('XXX','BUG ') 13361 ENDIF 13362 ELSEIF(NUMARG.EQ.2)THEN 13363 ICHAFO(1)=IHARG(2) 13364C 13365 IF(IFEEDB.EQ.'ON')THEN 13366 WRITE(ICOUT,999) 13367 CALL DPWRST('XXX','BUG ') 13368 I=1 13369 WRITE(ICOUT,1126)I,ICHAFO(I) 13370 1126 FORMAT('THE FONT FOR CHARACTER ',I6, 13371 1 ' HAS JUST BEEN SET TO ',A4) 13372 CALL DPWRST('XXX','BUG ') 13373 ENDIF 13374 ELSEIF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')THEN 13375 DO1135I=1,MAXCHA 13376 ICHAFO(I)=IHARG(3) 13377 1135 CONTINUE 13378C 13379 IF(IFEEDB.EQ.'ON')THEN 13380 WRITE(ICOUT,999) 13381 CALL DPWRST('XXX','BUG ') 13382 I=1 13383 WRITE(ICOUT,1116)ICHAFO(I) 13384 CALL DPWRST('XXX','BUG ') 13385 ENDIF 13386 ELSEIF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')THEN 13387 DO1145I=1,MAXCHA 13388 ICHAFO(I)=IHARG(2) 13389 1145 CONTINUE 13390C 13391 IF(IFEEDB.EQ.'ON')THEN 13392 WRITE(ICOUT,999) 13393 CALL DPWRST('XXX','BUG ') 13394 I=1 13395 WRITE(ICOUT,1116)ICHAFO(I) 13396 CALL DPWRST('XXX','BUG ') 13397 ENDIF 13398C 13399 ELSE 13400 IMAX=NUMARG-1 13401 IF(MAXCHA.LT.IMAX)IMAX=MAXCHA 13402 DO1155I=1,IMAX 13403 IP1=I+1 13404 ICHAFO(I)=IHARG(IP1) 13405 1155 CONTINUE 13406C 13407 IF(IFEEDB.EQ.'ON')THEN 13408 WRITE(ICOUT,999) 13409 CALL DPWRST('XXX','BUG ') 13410 DO1156I=1,IMAX 13411 WRITE(ICOUT,1126)I,ICHAFO(I) 13412 CALL DPWRST('XXX','BUG ') 13413 1156 CONTINUE 13414 ENDIF 13415 ENDIF 13416 ENDIF 13417C 13418 IFOUND='YES' 13419C 13420 RETURN 13421 END 13422 SUBROUTINE DPCHGR(ICHAR2,ICHARN,IBUG,IFOUND) 13423C 13424C PURPOSE--NUMERICALLY CONVERT A GREEK ALPHABETIC CHARACTER. 13425C CONVERT A PACKED ALPHABETIC STRING 13426C (PACKED INTO 1 COMPUTER WORD 13427C WITH ONLY THE FIRST 4 CHARACTERS BEING SIGNIFICANT) 13428C (ALPH... TO OMEG...) INTO A NUMERIC VALUE 13429C (1 TO 24). 13430C INPUT ARGUMENTS--ICHAR2 (A HOLLERITH VARIABLE 13431C CONTAINING THE HOLLERITH 13432C CHARACTER(S) OF INTEREST. 13433C OUTPUT ARGUMENTS--ICHARN (AN INTEGER VARIABLE 13434C CONTAINING THE NUMERIC 13435C DESIGNATION FOR THE 13436C ALPHABETIC CHARACTER. 13437C WRITTEN BY--JAMES J. FILLIBEN 13438C STATISTICAL ENGINEERING DIVISION 13439C INFORMATION TECHNOLOGY LABORATORY 13440C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13441C GAITHERSBURG, MD 20899-8980 13442C PHONE--301-975-2899 13443C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13444C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13445C LANGUAGE--ANSI FORTRAN (1977) 13446C VERSION NUMBER--82/7 13447C ORIGINAL VERSION--MARCH 1981. 13448C UPDATED --NOVEMBER 1981. 13449C UPDATED --MAY 1982. 13450C 13451C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13452C 13453 CHARACTER*4 ICHAR2 13454 CHARACTER*4 IBUG 13455 CHARACTER*4 IFOUND 13456C 13457C-----COMMON VARIABLES (BUGS & ERROR)--------------------------------- 13458C 13459 CHARACTER*4 IBUGG4 13460 CHARACTER*4 ISUBG4 13461 CHARACTER*4 IERRG4 13462C 13463 COMMON /ICOMBE/IBUGG4,ISUBG4,IERRG4 13464C 13465C--------------------------------------------------------------------- 13466C 13467 INCLUDE 'DPCOP2.INC' 13468C 13469C-----START POINT----------------------------------------------------- 13470C 13471 IFOUND='NO' 13472C 13473 IF(IBUG.EQ.'ON' .OR. ISUBG4.EQ.'CHGR')THEN 13474 WRITE(ICOUT,999) 13475 999 FORMAT(1X) 13476 CALL DPWRST('XXX','BUG ') 13477 WRITE(ICOUT,51) 13478 51 FORMAT('***** AT THE BEGINNING OF DPCHGR--') 13479 CALL DPWRST('XXX','BUG ') 13480 WRITE(ICOUT,59)ICHAR2,IBUG,ISUBG4 13481 59 FORMAT('ICHAR2,IBUG,ISUBG4 = ',2(A4,2X),A4) 13482 CALL DPWRST('XXX','BUG ') 13483 ENDIF 13484C 13485C ********************************** 13486C ** STEP 1-- ** 13487C ** CONVERT THE CHARACTER ** 13488C ********************************** 13489C 13490 IF(ICHAR2.EQ.'ALPH')GOTO100 13491 IF(ICHAR2.EQ.'BETA')GOTO200 13492 IF(ICHAR2.EQ.'GAMM')GOTO300 13493 IF(ICHAR2.EQ.'DELT')GOTO400 13494 IF(ICHAR2.EQ.'EPSI')GOTO500 13495 IF(ICHAR2.EQ.'ZETA')GOTO600 13496 IF(ICHAR2.EQ.'ETA')GOTO700 13497 IF(ICHAR2.EQ.'THET')GOTO800 13498 IF(ICHAR2.EQ.'IOTA')GOTO900 13499 IF(ICHAR2.EQ.'KAPP')GOTO1000 13500 IF(ICHAR2.EQ.'LAMB')GOTO1100 13501 IF(ICHAR2.EQ.'MU')GOTO1200 13502 IF(ICHAR2.EQ.'NU')GOTO1300 13503 IF(ICHAR2.EQ.'XI')GOTO1400 13504 IF(ICHAR2.EQ.'OMIC')GOTO1500 13505 IF(ICHAR2.EQ.'PI')GOTO1600 13506 IF(ICHAR2.EQ.'RHO')GOTO1700 13507 IF(ICHAR2.EQ.'SIGM')GOTO1800 13508 IF(ICHAR2.EQ.'TAU')GOTO1900 13509 IF(ICHAR2.EQ.'UPSI')GOTO2000 13510 IF(ICHAR2.EQ.'PHI')GOTO2100 13511 IF(ICHAR2.EQ.'CHI')GOTO2200 13512 IF(ICHAR2.EQ.'PSI')GOTO2300 13513 IF(ICHAR2.EQ.'OMEG')GOTO2400 13514 GOTO7900 13515C 13516 100 CONTINUE 13517 ICHARN=1 13518 GOTO8000 13519C 13520 200 CONTINUE 13521 ICHARN=2 13522 GOTO8000 13523C 13524 300 CONTINUE 13525 ICHARN=3 13526 GOTO8000 13527C 13528 400 CONTINUE 13529 ICHARN=4 13530 GOTO8000 13531C 13532 500 CONTINUE 13533 ICHARN=5 13534 GOTO8000 13535C 13536 600 CONTINUE 13537 ICHARN=6 13538 GOTO8000 13539C 13540 700 CONTINUE 13541 ICHARN=7 13542 GOTO8000 13543C 13544 800 CONTINUE 13545 ICHARN=8 13546 GOTO8000 13547C 13548 900 CONTINUE 13549 ICHARN=9 13550 GOTO8000 13551C 13552 1000 CONTINUE 13553 ICHARN=10 13554 GOTO8000 13555C 13556 1100 CONTINUE 13557 ICHARN=11 13558 GOTO8000 13559C 13560 1200 CONTINUE 13561 ICHARN=12 13562 GOTO8000 13563C 13564 1300 CONTINUE 13565 ICHARN=13 13566 GOTO8000 13567C 13568 1400 CONTINUE 13569 ICHARN=14 13570 GOTO8000 13571C 13572 1500 CONTINUE 13573 ICHARN=15 13574 GOTO8000 13575C 13576 1600 CONTINUE 13577 ICHARN=16 13578 GOTO8000 13579C 13580 1700 CONTINUE 13581 ICHARN=17 13582 GOTO8000 13583C 13584 1800 CONTINUE 13585 ICHARN=18 13586 GOTO8000 13587C 13588 1900 CONTINUE 13589 ICHARN=19 13590 GOTO8000 13591C 13592 2000 CONTINUE 13593 ICHARN=20 13594 GOTO8000 13595C 13596 2100 CONTINUE 13597 ICHARN=21 13598 GOTO8000 13599C 13600 2200 CONTINUE 13601 ICHARN=22 13602 GOTO8000 13603C 13604 2300 CONTINUE 13605 ICHARN=23 13606 GOTO8000 13607C 13608 2400 CONTINUE 13609 ICHARN=24 13610 GOTO8000 13611C 13612 7900 CONTINUE 13613CCCCC WRITE(ICOUT,999) 13614CCCCC CALL DPWRST('XXX','BUG ') 13615CCCCC WRITE(ICOUT,7911) 13616C7911 FORMAT('***** ERROR IN DPCHNU--') 13617CCCCC CALL DPWRST('XXX','BUG ') 13618CCCCC WRITE(ICOUT,7912) 13619C7912 FORMAT(' NO MATCH FOUND FOR INPUT CHARACTER.') 13620CCCCC CALL DPWRST('XXX','BUG ') 13621CCCCC WRITE(ICOUT,7913)ICHAR2 13622C7913 FORMAT(' INPUT CHAR2ACTER = ',A4) 13623CCCCC CALL DPWRST('XXX','BUG ') 13624 IFOUND='NO' 13625 GOTO9000 13626C 13627 8000 CONTINUE 13628 IFOUND='YES' 13629 GOTO9000 13630C 13631C ***************** 13632C ** STEP 90-- ** 13633C ** EXIT ** 13634C ***************** 13635C 13636 9000 CONTINUE 13637 IF(IBUG.EQ.'ON' .OR. ISUBG4.EQ.'CHGR')THEN 13638 WRITE(ICOUT,999) 13639 CALL DPWRST('XXX','BUG ') 13640 WRITE(ICOUT,9011) 13641 9011 FORMAT('***** AT THE END OF DPCHGR--') 13642 CALL DPWRST('XXX','BUG ') 13643 WRITE(ICOUT,9013)IFOUND,ICHAR2,ICHARN 13644 9013 FORMAT('IFOUND,ICHAR2,ICHARN = ',2(A4,2X),I8) 13645 CALL DPWRST('XXX','BUG ') 13646 ENDIF 13647C 13648 RETURN 13649 END 13650 SUBROUTINE DPCHHW(IHARG,IARGT,ARG,NUMARG, 13651 1 MAXCHA, 13652 1 PCHAHE,PCHAWI,PDEFHE,PDEFWI, 13653 1 IFOUND,IERROR) 13654C 13655C PURPOSE--DEFINE PLOT CHARACTER HEIGHT AND WIDTH 13656C FOR USE IN MULTI-TRACE PLOTS. 13657C THE HEIGHT AND WIDTH FOR THE CHARACTER FOR THE I-TH TRACE 13658C WILL BE PLACED 13659C IN THE I-TH ELEMENT OF THE FLOATING POINT 13660C VECTORS PCHAHE(.) AND PCHAWI(.). 13661C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 13662C --IARGT (A HOLLERITH VECTOR) 13663C --ARG (A HOLLERITH VECTOR) 13664C --NUMARG 13665C --MAXCHA 13666C OUTPUT ARGUMENTS--PCHAHE (A FLOATING POINT VECTOR 13667C WHOSE I-TH ELEMENT IS THE HEIGHT 13668C FOR THE CHARACTER 13669C ASSIGNED TO THE I-TH TRACE IN 13670C A MULTI-TRACE PLOT. 13671C --PCHAWI (A FLOATING POINT VECTOR 13672C WHOSE I-TH ELEMENT IS THE WIDTH 13673C FOR THE CHARACTER 13674C ASSIGNED TO THE I-TH TRACE IN 13675C A MULTI-TRACE PLOT. 13676C --PDEFHE = DEFAULT CHARACTER HEIGHT 13677C --PDEFWI = DEFAULT CHARACTER WIDTH 13678C --IFOUND ('YES' OR 'NO' ) 13679C --IERROR ('YES' OR 'NO' ) 13680C WRITTEN BY--JAMES J. FILLIBEN 13681C STATISTICAL ENGINEERING DIVISION 13682C INFORMATION TECHNOLOGY LABORATORY 13683C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13684C GAITHERSBURG, MD 20899-8980 13685C PHONE--301-975-2899 13686C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13687C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13688C LANGUAGE--ANSI FORTRAN (1977) 13689C VERSION NUMBER--88/8 13690C ORIGINAL VERSION--AUGUST 1988. 13691C UPDATED --JANUARY 1995. ALLOW ? AS ARGUMENT (FOR HELP) 13692C 13693C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13694C 13695 CHARACTER*4 IHARG 13696 CHARACTER*4 IARGT 13697 CHARACTER*4 IFOUND 13698 CHARACTER*4 IERROR 13699C 13700C--------------------------------------------------------------------- 13701C 13702 DIMENSION IHARG(*) 13703 DIMENSION IARGT(*) 13704 DIMENSION ARG(*) 13705C 13706 DIMENSION PCHAHE(*) 13707 DIMENSION PCHAWI(*) 13708C 13709C--------------------------------------------------------------------- 13710C 13711 INCLUDE 'DPCOP2.INC' 13712C 13713C-----START POINT----------------------------------------------------- 13714C 13715 IFOUND='NO' 13716 IERROR='NO' 13717C 13718 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'HW')GOTO1160 13719 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'HW')GOTO1105 13720 GOTO9000 13721C 13722 1105 CONTINUE 13723 IF(IHARG(NUMARG).EQ.'ON')GOTO1110 13724 IF(IHARG(NUMARG).EQ.'OFF')GOTO1110 13725 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 13726 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 13727 IF(IHARG(NUMARG).EQ.'?')GOTO1200 13728C 13729 IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160 13730 IF(NUMARG.EQ.3)GOTO1120 13731 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'ALL')GOTO1130 13732 IF(NUMARG.GE.4.AND.IHARG(4).EQ.'ALL')GOTO1140 13733C 13734 GOTO1150 13735C 13736 1110 CONTINUE 13737 DO1115I=1,MAXCHA 13738 PCHAWI(I)=PDEFHE 13739 PCHAHE(I)=PDEFWI 13740 1115 CONTINUE 13741C 13742 IF(IFEEDB.EQ.'OFF')GOTO1119 13743 WRITE(ICOUT,999) 13744 999 FORMAT(1X) 13745 CALL DPWRST('XXX','BUG ') 13746 I=1 13747 WRITE(ICOUT,1116) 13748 1116 FORMAT('THE HEIGHTS AND WIDTHS OF ALL CHARACTERS') 13749 CALL DPWRST('XXX','BUG ') 13750 WRITE(ICOUT,1117)PCHAHE(I),PCHAWI(I) 13751 1117 FORMAT(' HAVE JUST BEEN SET TO ',2E15.7) 13752 CALL DPWRST('XXX','BUG ') 13753 1119 CONTINUE 13754 GOTO2190 13755C 13756 1120 CONTINUE 13757 I=1 13758 IF(IARGT(2).NE.'NUMB'.OR.IARGT(3).NE.'NUMB')GOTO1180 13759 PCHAHE(1)=ARG(2) 13760 PCHAWI(1)=ARG(3) 13761C 13762 IF(IFEEDB.EQ.'OFF')GOTO1129 13763 WRITE(ICOUT,999) 13764 CALL DPWRST('XXX','BUG ') 13765 I=1 13766 WRITE(ICOUT,1126)I 13767 1126 FORMAT('THE HEIGHT AND WIDTH OF CHARACTER ',I6) 13768 CALL DPWRST('XXX','BUG ') 13769 WRITE(ICOUT,1127)PCHAHE(I),PCHAWI(I) 13770 1127 FORMAT(' HAS JUST BEEN SET TO ',2E15.7) 13771 CALL DPWRST('XXX','BUG ') 13772 1129 CONTINUE 13773 GOTO2190 13774C 13775 1130 CONTINUE 13776 I=1 13777 IF(IARGT(3).NE.'NUMB'.OR.IARGT(4).NE.'NUMB')GOTO1180 13778 DO1135I=1,MAXCHA 13779 PCHAHE(I)=ARG(3) 13780 PCHAWI(I)=ARG(4) 13781 1135 CONTINUE 13782C 13783 IF(IFEEDB.EQ.'OFF')GOTO1139 13784 WRITE(ICOUT,999) 13785 CALL DPWRST('XXX','BUG ') 13786 I=1 13787 WRITE(ICOUT,1116) 13788 CALL DPWRST('XXX','BUG ') 13789 WRITE(ICOUT,1117)PCHAHE(I),PCHAWI(I) 13790 CALL DPWRST('XXX','BUG ') 13791 1139 CONTINUE 13792 GOTO2190 13793C 13794 1140 CONTINUE 13795 I=1 13796 IF(IARGT(2).NE.'NUMB'.OR.IARGT(3).NE.'NUMB')GOTO1180 13797 DO1145I=1,MAXCHA 13798 PCHAHE(I)=ARG(2) 13799 PCHAWI(I)=ARG(3) 13800 1145 CONTINUE 13801C 13802 IF(IFEEDB.EQ.'OFF')GOTO1149 13803 WRITE(ICOUT,999) 13804 CALL DPWRST('XXX','BUG ') 13805 I=1 13806 WRITE(ICOUT,1116) 13807 CALL DPWRST('XXX','BUG ') 13808 WRITE(ICOUT,1117)PCHAHE(I),PCHAWI(I) 13809 CALL DPWRST('XXX','BUG ') 13810 1149 CONTINUE 13811 GOTO2190 13812C 13813 1150 CONTINUE 13814 IMAX=NUMARG-1 13815 IF(MAXCHA.LT.IMAX)IMAX=MAXCHA 13816 J=0 13817 DO1155I=1,IMAX,2 13818 IP1=I+1 13819 IP2=I+2 13820 IF(IARGT(IP1).NE.'NUMB')GOTO1180 13821 IF(IARGT(IP2).NE.'NUMB')GOTO1180 13822 J=J+1 13823 PCHAHE(J)=ARG(IP1) 13824 PCHAWI(J)=ARG(IP2) 13825 1155 CONTINUE 13826 JMAX=J 13827C 13828 IF(IFEEDB.EQ.'OFF')GOTO1159 13829 WRITE(ICOUT,999) 13830 CALL DPWRST('XXX','BUG ') 13831 DO1156I=1,JMAX 13832 WRITE(ICOUT,1126)I 13833 CALL DPWRST('XXX','BUG ') 13834 WRITE(ICOUT,1127)PCHAHE(I),PCHAWI(I) 13835 CALL DPWRST('XXX','BUG ') 13836 1156 CONTINUE 13837 1159 CONTINUE 13838 GOTO2190 13839C 13840 1160 CONTINUE 13841 DO1165I=1,MAXCHA 13842 PCHAHE(I)=PDEFHE 13843 PCHAWI(I)=PDEFWI 13844 1165 CONTINUE 13845C 13846 IF(IFEEDB.EQ.'OFF')GOTO1169 13847 WRITE(ICOUT,999) 13848 CALL DPWRST('XXX','BUG ') 13849 I=1 13850 WRITE(ICOUT,1116) 13851 CALL DPWRST('XXX','BUG ') 13852 WRITE(ICOUT,1117)PCHAHE(I),PCHAWI(I) 13853 CALL DPWRST('XXX','BUG ') 13854 1169 CONTINUE 13855 GOTO2190 13856C 13857 1180 CONTINUE 13858 IERROR='YES' 13859 WRITE(ICOUT,999) 13860 CALL DPWRST('XXX','BUG ') 13861 WRITE(ICOUT,1181) 13862 1181 FORMAT('***** ERROR IN DPCHHW--') 13863 CALL DPWRST('XXX','BUG ') 13864 WRITE(ICOUT,1182) 13865 1182 FORMAT('THE HEIGHTS AND WIDTHS OF CHARACTERS MUST BE NUMERIC') 13866 CALL DPWRST('XXX','BUG ') 13867 WRITE(ICOUT,1183) 13868 1183 FORMAT('HOWEVER, THE SPECIFIED CHARACTER HEIGHT AND WIDTH') 13869 CALL DPWRST('XXX','BUG ') 13870 WRITE(ICOUT,1184)I 13871 1184 FORMAT('FOR CHARACTER ',I6,' WAS NON-NUMERIC.') 13872 CALL DPWRST('XXX','BUG ') 13873 GOTO9000 13874C 13875CCCCC THE FOLLOWING SECTION WAS ADDED JANUARY 1995 13876 1200 CONTINUE 13877 IFOUND='YES' 13878 IF(IFEEDB.EQ.'OFF')GOTO1229 13879 WRITE(ICOUT,999) 13880 CALL DPWRST('XXX','BUG ') 13881 I=1 13882 WRITE(ICOUT,1221)I,PCHAHE(I) 13883 1221 FORMAT('THE CURRENT HEIGHT FOR CHARACTER ',I6,' IS ',E15.7) 13884 CALL DPWRST('XXX','BUG ') 13885 WRITE(ICOUT,1222)I,PCHAWI(I) 13886 1222 FORMAT('THE CURRENT WIDTH FOR CHARACTER ',I6,' IS ',E15.7) 13887 CALL DPWRST('XXX','BUG ') 13888 WRITE(ICOUT,999) 13889 CALL DPWRST('XXX','BUG ') 13890 WRITE(ICOUT,1223)I,PDEFHE 13891 1223 FORMAT('THE DEFAULT HEIGHT FOR CHARACTER ',I6,' IS ',E15.7) 13892 CALL DPWRST('XXX','BUG ') 13893 WRITE(ICOUT,1224)I,PDEFWI 13894 1224 FORMAT('THE DEFAULT WIDTH FOR CHARACTER ',I6,' IS ',E15.7) 13895 CALL DPWRST('XXX','BUG ') 13896 1229 CONTINUE 13897 GOTO9000 13898C 13899 2190 CONTINUE 13900 IFOUND='YES' 13901C 13902 9000 CONTINUE 13903 RETURN 13904 END 13905 SUBROUTINE DPCHJU(IHARG,NUMARG,MAXCHA,ICHAJU,IFOUND,IERROR) 13906C 13907C PURPOSE--DEFINE PLOT CHARACTER JUSTIFICATION FOR USE IN MULTI-TRACE PLOTS. 13908C THE JUSTIFICATION FOR THE CHARACTER FOR THE I-TH TRACE 13909C WILL BE PLACED 13910C IN THE I-TH ELEMENT OF THE HOLLERITH 13911C VECTOR ICHAJU(.). 13912C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 13913C --NUMARG 13914C --MAXCHA 13915C OUTPUT ARGUMENTS--ICHAJU (A HOLLERITH VECTOR 13916C WHOSE I-TH ELEMENT IS THE JUSTIFICATION 13917C FOR THE CHARACTER 13918C ASSIGNED TO THE I-TH TRACE IN 13919C A MULTI-TRACE PLOT. 13920C --IFOUND ('YES' OR 'NO' ) 13921C --IERROR ('YES' OR 'NO' ) 13922C WRITTEN BY--JAMES J. FILLIBEN 13923C STATISTICAL ENGINEERING DIVISION 13924C INFORMATION TECHNOLOGY LABORATORY 13925C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13926C GAITHERSBURG, MD 20899-8980 13927C PHONE--301-975-2899 13928C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13929C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13930C LANGUAGE--ANSI FORTRAN (1977) 13931C VERSION NUMBER--82/7 13932C ORIGINAL VERSION--NOVEMBER 1986. 13933C 13934C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13935C 13936 CHARACTER*4 IHARG 13937 CHARACTER*4 ICHAJU 13938 CHARACTER*4 IFOUND 13939 CHARACTER*4 IERROR 13940C 13941C--------------------------------------------------------------------- 13942C 13943 DIMENSION IHARG(*) 13944 DIMENSION ICHAJU(*) 13945C 13946C--------------------------------------------------------------------- 13947C 13948 INCLUDE 'DPCOP2.INC' 13949C 13950C-----START POINT----------------------------------------------------- 13951C 13952 IFOUND='NO' 13953 IERROR='NO' 13954C 13955 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'JUST')GOTO1160 13956 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'JUST')GOTO1105 13957 GOTO1199 13958C 13959 1105 CONTINUE 13960 IF(IHARG(NUMARG).EQ.'ON')GOTO1110 13961 IF(IHARG(NUMARG).EQ.'OFF')GOTO1110 13962 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 13963 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 13964C 13965 IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160 13966 IF(NUMARG.EQ.2)GOTO1120 13967 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130 13968 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140 13969C 13970 GOTO1150 13971C 13972 1110 CONTINUE 13973 DO1115I=1,MAXCHA 13974 ICHAJU(I)='CENT' 13975 1115 CONTINUE 13976C 13977 IF(IFEEDB.EQ.'OFF')GOTO1119 13978 WRITE(ICOUT,999) 13979 999 FORMAT(1X) 13980 CALL DPWRST('XXX','BUG ') 13981 I=1 13982 WRITE(ICOUT,1116)ICHAJU(I) 13983 1116 FORMAT('ALL CHARACTER JUSTIFICATIONS HAVE JUST BEEN SET TO ', 13984 1A4) 13985 CALL DPWRST('XXX','BUG ') 13986 1119 CONTINUE 13987 GOTO1190 13988C 13989 1120 CONTINUE 13990 ICHAJU(1)=IHARG(2) 13991C 13992 IF(IFEEDB.EQ.'OFF')GOTO1129 13993 WRITE(ICOUT,999) 13994 CALL DPWRST('XXX','BUG ') 13995 I=1 13996 WRITE(ICOUT,1126)I,ICHAJU(I) 13997 1126 FORMAT('THE JUSTIFICATION FOR CHARACTER ',I6, 13998 1' HAS JUST BEEN SET TO ',A4) 13999 CALL DPWRST('XXX','BUG ') 14000 1129 CONTINUE 14001 GOTO1190 14002C 14003 1130 CONTINUE 14004 DO1135I=1,MAXCHA 14005 ICHAJU(I)=IHARG(3) 14006 1135 CONTINUE 14007C 14008 IF(IFEEDB.EQ.'OFF')GOTO1139 14009 WRITE(ICOUT,999) 14010 CALL DPWRST('XXX','BUG ') 14011 I=1 14012 WRITE(ICOUT,1116)ICHAJU(I) 14013 CALL DPWRST('XXX','BUG ') 14014 1139 CONTINUE 14015 GOTO1190 14016C 14017 1140 CONTINUE 14018 DO1145I=1,MAXCHA 14019 ICHAJU(I)=IHARG(2) 14020 1145 CONTINUE 14021C 14022 IF(IFEEDB.EQ.'OFF')GOTO1149 14023 WRITE(ICOUT,999) 14024 CALL DPWRST('XXX','BUG ') 14025 I=1 14026 WRITE(ICOUT,1116)ICHAJU(I) 14027 CALL DPWRST('XXX','BUG ') 14028 1149 CONTINUE 14029 GOTO1190 14030C 14031 1150 CONTINUE 14032 IMAX=NUMARG-1 14033 IF(MAXCHA.LT.IMAX)IMAX=MAXCHA 14034 DO1155I=1,IMAX 14035 IP1=I+1 14036 ICHAJU(I)=IHARG(IP1) 14037 1155 CONTINUE 14038C 14039 IF(IFEEDB.EQ.'OFF')GOTO1159 14040 WRITE(ICOUT,999) 14041 CALL DPWRST('XXX','BUG ') 14042 DO1156I=1,IMAX 14043 WRITE(ICOUT,1126)I,ICHAJU(I) 14044 CALL DPWRST('XXX','BUG ') 14045 1156 CONTINUE 14046 1159 CONTINUE 14047 GOTO1190 14048C 14049 1160 CONTINUE 14050 DO1165I=1,MAXCHA 14051 ICHAJU(I)='CENT' 14052 1165 CONTINUE 14053C 14054 IF(IFEEDB.EQ.'OFF')GOTO1169 14055 WRITE(ICOUT,999) 14056 CALL DPWRST('XXX','BUG ') 14057 I=1 14058 WRITE(ICOUT,1116)ICHAJU(I) 14059 CALL DPWRST('XXX','BUG ') 14060 1169 CONTINUE 14061 GOTO1190 14062C 14063 1190 CONTINUE 14064 IFOUND='YES' 14065C 14066 1199 CONTINUE 14067 RETURN 14068 END 14069 SUBROUTINE DPCHLI(ICONT,NUMCPL,YSTART,YSTOP,XSTART,XSTOP, 14070 1J,JD,Y2,X2,D2,IERROR) 14071C 14072C PURPOSE--GENERATE PLOT COORDINATES FOR A POINT 14073C OR FOR A LINE. 14074C WRITTEN BY--JAMES J. FILLIBEN 14075C STATISTICAL ENGINEERING DIVISION 14076C INFORMATION TECHNOLOGY LABORATORY 14077C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 14078C GAITHERSBURG, MD 20899-8980 14079C PHONE--301-975-2899 14080C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 14081C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 14082C LANGUAGE--ANSI FORTRAN (1977) 14083C VERSION NUMBER--82/7 14084C ORIGINAL VERSION--JANUARY 1981. 14085C UPDATED --MAY 1982. 14086C 14087C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 14088C 14089 CHARACTER*4 ICONT 14090 CHARACTER*4 IERROR 14091C 14092C--------------------------------------------------------------------- 14093C 14094 DIMENSION Y2(*) 14095 DIMENSION X2(*) 14096 DIMENSION D2(*) 14097C 14098C--------------------------------------------------------------------- 14099C 14100 INCLUDE 'DPCOP2.INC' 14101C 14102C-----START POINT----------------------------------------------------- 14103C 14104 IERROR='NO' 14105C 14106 NUMCP2=NUMCPL 14107 IF(ICONT.EQ.'ON')NUMCP2=2 14108 ANUMC2=NUMCP2 14109C 14110 IF(YSTART.EQ.YSTOP)GOTO200 14111 IF(XSTART.EQ.XSTOP)GOTO1300 14112 GOTO1400 14113C 14114 200 CONTINUE 14115 IF(XSTART.EQ.XSTOP)GOTO1100 14116 GOTO1200 14117C 14118C *************************** 14119C ** STEP 2.1-- ** 14120C ** TREAT THE CASE WHEN ** 14121C ** Y HAS NO CHANGE ** 14122C ** X HAS NO CHANGE ** 14123C *************************** 14124C 14125 1100 CONTINUE 14126 J=J+1 14127 JD=JD+1 14128 Y2(J)=YSTART 14129 X2(J)=XSTART 14130 D2(J)=JD 14131 GOTO9000 14132C 14133C *************************** 14134C ** STEP 2.2-- ** 14135C ** TREAT THE CASE WHEN ** 14136C ** Y HAS NO CHANGE ** 14137C ** X HAS CHANGE ** 14138C *************************** 14139C 14140 1200 CONTINUE 14141 JD=JD+1 14142 XDEL=XSTOP-XSTART 14143 DO1210I=1,NUMCP2 14144 J=J+1 14145 AI=I 14146 P=(AI-1.0)/(ANUMC2-1.0) 14147 XP=XSTART+P*XDEL 14148 Y2(J)=YSTART 14149 X2(J)=XP 14150 D2(J)=JD 14151 1210 CONTINUE 14152 GOTO9000 14153C 14154C *************************** 14155C ** STEP 2.3-- ** 14156C ** TREAT THE CASE WHEN ** 14157C ** Y HAS CHANGE ** 14158C ** X HAS NO CHANGE ** 14159C *************************** 14160C 14161 1300 CONTINUE 14162 JD=JD+1 14163 YDEL=YSTOP-YSTART 14164 DO1310I=1,NUMCP2 14165 J=J+1 14166 AI=I 14167 P=(AI-1.0)/(ANUMC2-1.0) 14168 YP=YSTART+P*YDEL 14169 Y2(J)=YP 14170 X2(J)=XSTART 14171 D2(J)=JD 14172 1310 CONTINUE 14173 GOTO9000 14174C 14175C *************************** 14176C ** STEP 2.4-- ** 14177C ** TREAT THE CASE WHEN ** 14178C ** Y HAS CHANGE ** 14179C ** X HAS CHANGE ** 14180C *************************** 14181C 14182 1400 CONTINUE 14183 JD=JD+1 14184 XDEL=XSTOP-XSTART 14185 YDEL=YSTOP-YSTART 14186 DO1410I=1,NUMCP2 14187 J=J+1 14188 AI=I 14189 P=(AI-1.0)/(ANUMC2-1.0) 14190 XP=XSTART+P*XDEL 14191 YP=YSTART+P*YDEL 14192 Y2(J)=YP 14193 X2(J)=XP 14194 D2(J)=JD 14195 1410 CONTINUE 14196 GOTO9000 14197C 14198C ***************** 14199C ** STEP 90-- ** 14200C ** EXIT ** 14201C ***************** 14202C 14203 9000 CONTINUE 14204 RETURN 14205 END 14206 SUBROUTINE DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUG,IERROR) 14207C 14208C PURPOSE--CHECK FOR A LEFT AND RIGHT PARENTHESIS. 14209C CHECK FOR A LEFT PARENTHESIS IN LOCATION ILOCLP. 14210C CHECK FOR A RIGHT PARENTHESIS IN LOCATION ILOCRP. 14211C WRITTEN BY--JAMES J. FILLIBEN 14212C STATISTICAL ENGINEERING DIVISION 14213C INFORMATION TECHNOLOGY LABORATORY 14214C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 14215C GAITHERSBURG, MD 20899-8980 14216C PHONE--301-975-2899 14217C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 14218C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 14219C LANGUAGE--ANSI FORTRAN (1977) 14220C VERSION NUMBER--82/7 14221C ORIGINAL VERSION--APRIL 1981. 14222C UPDATED --FEBRUARY 1982. 14223C UPDATED --MAY 1982. 14224C 14225C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 14226C 14227 CHARACTER*4 ISTRIN 14228 CHARACTER*4 IFOULR 14229 CHARACTER*4 IBUG 14230 CHARACTER*4 IERROR 14231C 14232C--------------------------------------------------------------------- 14233C 14234 DIMENSION ISTRIN(*) 14235C 14236C-----COMMON---------------------------------------------------------- 14237C 14238 INCLUDE 'DPCOBE.INC' 14239 INCLUDE 'DPCOP2.INC' 14240C 14241C-----START POINT----------------------------------------------------- 14242C 14243 IFOULR='NO' 14244 IERROR='NO' 14245C 14246 IF(IBUG.EQ.'ON' .OR. ISUBG4.EQ.'CHLR')THEN 14247 WRITE(ICOUT,999) 14248 999 FORMAT(1X) 14249 CALL DPWRST('XXX','BUG ') 14250 WRITE(ICOUT,51) 14251 51 FORMAT('***** AT THE BEGINNING OF DPCHLR--') 14252 CALL DPWRST('XXX','BUG ') 14253 WRITE(ICOUT,52)NUMCHS,ILOCLP,ILOCRP 14254 52 FORMAT('NUMCHS,ILOCLP,ILOCRP = ',3I8) 14255 CALL DPWRST('XXX','BUG ') 14256 WRITE(ICOUT,53)(ISTRIN(I),I=1,MIN(100,NUMCHS)) 14257 53 FORMAT('(ISTRIN(I),I=1,NUMCHS) = ',100A1) 14258 CALL DPWRST('XXX','BUG ') 14259 WRITE(ICOUT,59)IBUG,ISUBG4,IERRG4 14260 59 FORMAT('IBUG,ISUBG4,IERRG4 = ',2(A4,2X),A4) 14261 CALL DPWRST('XXX','BUG ') 14262 ENDIF 14263C 14264 IF(ILOCLP.LT.1)GOTO1200 14265 IF(ILOCLP.GT.NUMCHS)GOTO1200 14266C 14267 IF(ILOCRP.LT.1)GOTO1200 14268 IF(ILOCRP.GT.NUMCHS)GOTO1200 14269C 14270 IF(ISTRIN(ILOCLP).NE.'(')GOTO1200 14271 IF(ISTRIN(ILOCRP).NE.')')GOTO1200 14272C 14273 IFOULR='YES' 14274 GOTO9000 14275C 14276 1200 CONTINUE 14277 IFOULR='NO' 14278 GOTO9000 14279C 14280C ***************** 14281C ** STEP 90-- ** 14282C ** EXIT ** 14283C ***************** 14284C 14285 9000 CONTINUE 14286 IF(IBUG.EQ.'ON' .OR. ISUBG4.EQ.'CHLR')THEN 14287 WRITE(ICOUT,999) 14288 CALL DPWRST('XXX','BUG ') 14289 WRITE(ICOUT,9011) 14290 9011 FORMAT('***** AT THE END OF DPCHLR--') 14291 CALL DPWRST('XXX','BUG ') 14292 WRITE(ICOUT,9012)IFOULR,IERRG4 14293 9012 FORMAT('IFOULR,IERRG4 = ',A4,2X,A4) 14294 CALL DPWRST('XXX','BUG ') 14295 ENDIF 14296C 14297 RETURN 14298 END 14299 SUBROUTINE DPCHMA(ICHAR2,ICHARN,IBUG,IFOUND) 14300C 14301C PURPOSE--CONVERT A MATHEMATICAL SYMBOL 14302C INTO A NUMERIC VALUE 14303C (1 TO 66). 14304C INPUT ARGUMENTS--ICHAR2 (A HOLLERITH VARIABLE 14305C CONTAINING THE HOLLERITH 14306C CHARACTER(S) OF INTEREST. 14307C OUTPUT ARGUMENTS--ICHARN (AN INTEGER VARIABLE 14308C CONTAINING THE NUMERIC 14309C DESIGNATION FOR THE 14310C ALPHABETIC CHARACTER. 14311C WRITTEN BY--JAMES J. FILLIBEN 14312C STATISTICAL ENGINEERING DIVISION 14313C INFORMATION TECHNOLOGY LABORATORY 14314C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 14315C GAITHERSBURG, MD 20899-8980 14316C PHONE--301-975-2899 14317C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 14318C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 14319C LANGUAGE--ANSI FORTRAN (1977) 14320C VERSION NUMBER--82/7 14321C ORIGINAL VERSION--MARCH 1981. 14322C UPDATED --NOVEMBER 1981. 14323C UPDATED --MAY 1982. 14324C UPDATED --APRIL 1987. 14325C UPDATED --AUGUST 1992. ADD SYNONYMS FOR REVERSE 14326C TRIANGLE (TO AGREE WITH 14327C DOCUMENTATION), ADD ARROW CASE 14328C 14329C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 14330C 14331 CHARACTER*4 ICHAR2 14332 CHARACTER*4 IBUG 14333 CHARACTER*4 IFOUND 14334C 14335 CHARACTER*1 IBASLC 14336C 14337C-----COMMON---------------------------------------------------------- 14338C 14339 INCLUDE 'DPCOBE.INC' 14340C 14341C-----COMMON VARIABLES (GENERAL)-------------------------------------- 14342C 14343 INCLUDE 'DPCOP2.INC' 14344C 14345C-----START POINT----------------------------------------------------- 14346C 14347 IFOUND='NO' 14348C 14349 IF(IBUG.EQ.'ON' .OR. ISUBG4.EQ.'CHMA')THEN 14350 WRITE(ICOUT,999) 14351 999 FORMAT(1X) 14352 CALL DPWRST('XXX','BUG ') 14353 WRITE(ICOUT,51) 14354 51 FORMAT('***** AT THE BEGINNING OF DPCHMA--') 14355 CALL DPWRST('XXX','BUG ') 14356 WRITE(ICOUT,59)ICHAR2,IBUGG4,ISUBG4 14357 59 FORMAT('ICHAR2,IBUGG4,ISUBG4 = ',2(A4,2X),A4) 14358 CALL DPWRST('XXX','BUG ') 14359 ENDIF 14360C 14361C ********************************** 14362C ** STEP 1-- ** 14363C ** CONVERT THE CHARACTER ** 14364C ********************************** 14365C 14366 IF(ICHAR2.EQ.'/ ')GOTO100 14367 IF(ICHAR2.EQ.'( ')GOTO200 14368 IF(ICHAR2.EQ.') ')GOTO300 14369 IF(ICHAR2.EQ.'[ ')GOTO400 14370 IF(ICHAR2.EQ.'LBRA')GOTO400 14371 IF(ICHAR2.EQ.'] ')GOTO500 14372 IF(ICHAR2.EQ.'RBRA')GOTO500 14373 IF(ICHAR2.EQ.'{ ')GOTO600 14374 IF(ICHAR2.EQ.'LCBR')GOTO600 14375 IF(ICHAR2.EQ.'} ')GOTO700 14376 IF(ICHAR2.EQ.'RCBR')GOTO700 14377 IF(ICHAR2.EQ.'LELB')GOTO800 14378 IF(ICHAR2.EQ.'RELB')GOTO900 14379 IF(ICHAR2.EQ.'| ')GOTO1000 14380 IF(ICHAR2.EQ.'VBAR')GOTO1000 14381 IF(ICHAR2.EQ.': ')GOTO1100 14382 IF(ICHAR2.EQ.'DVBA')GOTO1100 14383 IF(ICHAR2.EQ.'COLO')GOTO1100 14384 IF(ICHAR2.EQ.'- ')GOTO1200 14385 IF(ICHAR2.EQ.'MINU')GOTO1200 14386 IF(ICHAR2.EQ.'+ ')GOTO1300 14387 IF(ICHAR2.EQ.'PLUS')GOTO1300 14388 IF(ICHAR2.EQ.'CROS')GOTO1300 14389 IF(ICHAR2.EQ.'+- ')GOTO1400 14390 IF(ICHAR2.EQ.'-+ ')GOTO1500 14391 IF(ICHAR2.EQ.'TIME')GOTO1600 14392 IF(ICHAR2.EQ.'DOTP')GOTO1700 14393 IF(ICHAR2.EQ.'/ ')GOTO1800 14394 IF(ICHAR2.EQ.'DIVI')GOTO1800 14395 IF(ICHAR2.EQ.'SLAS')GOTO1800 14396 IF(ICHAR2.EQ.'= ')GOTO1900 14397 IF(ICHAR2.EQ.'EQUA')GOTO1900 14398 IF(ICHAR2.EQ.'NOT=')GOTO2000 14399 IF(ICHAR2.EQ.'<>')GOTO2000 14400 IF(ICHAR2.EQ.'><')GOTO2000 14401 IF(ICHAR2.EQ.'EQUI')GOTO2100 14402 IF(ICHAR2.EQ.'< ')GOTO2200 14403 IF(ICHAR2.EQ.'LT ')GOTO2200 14404 IF(ICHAR2.EQ.'> ')GOTO2300 14405 IF(ICHAR2.EQ.'GT ')GOTO2300 14406 IF(ICHAR2.EQ.'<= ')GOTO2400 14407 IF(ICHAR2.EQ.'=< ')GOTO2400 14408 IF(ICHAR2.EQ.'LTEQ')GOTO2400 14409 IF(ICHAR2.EQ.'>= ')GOTO2500 14410 IF(ICHAR2.EQ.'=> ')GOTO2500 14411 IF(ICHAR2.EQ.'GTEQ')GOTO2500 14412 IF(ICHAR2.EQ.'VARI')GOTO2600 14413 IF(ICHAR2.EQ.'APPR')GOTO2700 14414 IF(ICHAR2.EQ.'~ ')GOTO2700 14415 IF(ICHAR2.EQ.'TILD')GOTO2700 14416 IF(ICHAR2.EQ.'CARA')GOTO2800 14417 IF(ICHAR2.EQ.'PRIM')GOTO2900 14418 IF(ICHAR2.EQ.'` ')GOTO3000 14419 IF(ICHAR2.EQ.'LACC')GOTO3000 14420 IF(ICHAR2.EQ.'BREV')GOTO3100 14421 IF(ICHAR2.EQ.'RQUO')GOTO3200 14422 IF(ICHAR2.EQ.'LQUO')GOTO3300 14423 IF(ICHAR2.EQ.'NASP')GOTO3400 14424 IF(ICHAR2.EQ.'IASP')GOTO3500 14425 IF(ICHAR2.EQ.'RADI')GOTO3600 14426 IF(ICHAR2.EQ.'SUBS')GOTO3700 14427 IF(ICHAR2.EQ.'UNIO')GOTO3800 14428 IF(ICHAR2.EQ.'SUPE')GOTO3900 14429 IF(ICHAR2.EQ.'INTR')GOTO4000 14430 IF(ICHAR2.EQ.'ELEM')GOTO4100 14431 IF(ICHAR2.EQ.'RARR')GOTO4200 14432 IF(ICHAR2.EQ.'^ ')GOTO4300 14433 IF(ICHAR2.EQ.'UARR')GOTO4300 14434 IF(ICHAR2.EQ.'LARR')GOTO4400 14435 IF(ICHAR2.EQ.'DARR')GOTO4500 14436 IF(ICHAR2.EQ.'PART')GOTO4600 14437 IF(ICHAR2.EQ.'DEL ')GOTO4700 14438 IF(ICHAR2.EQ.'LRAD')GOTO4800 14439 IF(ICHAR2.EQ.'INTE')GOTO4900 14440 IF(ICHAR2.EQ.'CINT')GOTO5000 14441 IF(ICHAR2.EQ.'INFI')GOTO5100 14442 IF(ICHAR2.EQ.'% ')GOTO5200 14443 IF(ICHAR2.EQ.'& ')GOTO5300 14444 IF(ICHAR2.EQ.'@ ')GOTO5400 14445 IF(ICHAR2.EQ.'$ ')GOTO5500 14446 IF(ICHAR2.EQ.'# ')GOTO5600 14447 IF(ICHAR2.EQ.'PARA')GOTO5700 14448 IF(ICHAR2.EQ.'DAGG')GOTO5800 14449 IF(ICHAR2.EQ.'DDAG')GOTO5900 14450 IF(ICHAR2.EQ.'THEX')GOTO6000 14451 IF(ICHAR2.EQ.'PROD')GOTO6100 14452 IF(ICHAR2.EQ.'SUMM')GOTO6200 14453 IF(ICHAR2.EQ.'THFO')GOTO6300 14454 IF(ICHAR2.EQ.'LVBA')GOTO6400 14455 IF(ICHAR2.EQ.'HBAR')GOTO6500 14456 IF(ICHAR2.EQ.'LHBA')GOTO6600 14457C 14458 IF(ICHAR2.EQ.'. ')GOTO10100 14459 IF(ICHAR2.EQ.'POIN')GOTO10100 14460 IF(ICHAR2.EQ.'PO ')GOTO10100 14461 IF(ICHAR2.EQ.'PT ')GOTO10100 14462 IF(ICHAR2.EQ.'CIRC')GOTO10200 14463 IF(ICHAR2.EQ.'CI ')GOTO10200 14464 IF(ICHAR2.EQ.'SQUA')GOTO10300 14465 IF(ICHAR2.EQ.'SQ ')GOTO10300 14466 IF(ICHAR2.EQ.'TRIA')GOTO10400 14467 IF(ICHAR2.EQ.'TR ')GOTO10400 14468 IF(ICHAR2.EQ.'DIAM')GOTO10500 14469 IF(ICHAR2.EQ.'DI ')GOTO10500 14470 IF(ICHAR2.EQ.'STAR')GOTO10600 14471 IF(ICHAR2.EQ.'ST ')GOTO10600 14472 IF(ICHAR2.EQ.'* ')GOTO10700 14473 IF(ICHAR2.EQ.'ASTE')GOTO10700 14474 IF(ICHAR2.EQ.'AS ')GOTO10700 14475 IF(ICHAR2.EQ.'TRIR')GOTO10800 14476 IF(ICHAR2.EQ.'TRII')GOTO10800 14477C AUGUST 1992. ADD FOLLOWING 2 LINES (TO MAKE DOCUMENTATION CORRECT) 14478 IF(ICHAR2.EQ.'REVT')GOTO10800 14479 IF(ICHAR2.EQ.'RT ')GOTO10800 14480C 14481 IF(ICHAR2.EQ.'BARU')GOTO10900 14482 IF(ICHAR2.EQ.'BU ')GOTO10900 14483 IF(ICHAR2.EQ.'BARV')GOTO10900 14484 IF(ICHAR2.EQ.'BV ')GOTO10900 14485 IF(ICHAR2.EQ.'BARH')GOTO11000 14486 IF(ICHAR2.EQ.'BH ')GOTO11000 14487 IF(ICHAR2.EQ.'ARRU')GOTO11100 14488 IF(ICHAR2.EQ.'AU ')GOTO11100 14489 IF(ICHAR2.EQ.'ARRD')GOTO11200 14490 IF(ICHAR2.EQ.'AD ')GOTO11200 14491 IF(ICHAR2.EQ.'ARRL')GOTO11300 14492 IF(ICHAR2.EQ.'AL ')GOTO11300 14493 IF(ICHAR2.EQ.'ARRR')GOTO11400 14494 IF(ICHAR2.EQ.'AR ')GOTO11400 14495 CALL DPCONA(92,IBASLC) 14496 IF(ICHAR2.EQ.IBASLC)GOTO11500 14497 IF(ICHAR2.EQ.'BASL')GOTO11500 14498 IF(ICHAR2.EQ.'BACK')GOTO11500 14499 IF(ICHAR2.EQ.'BS ')GOTO11500 14500 IF(ICHAR2.EQ.'_ ')GOTO11600 14501 IF(ICHAR2.EQ.'UNDE')GOTO11600 14502 IF(ICHAR2.EQ.'CUBE')GOTO11700 14503 IF(ICHAR2.EQ.'PYRA')GOTO11800 14504C AUGUST 1992. ADD AN ARROW OPTION 14505 IF(ICHAR2.EQ.'ARRO')GOTO11900 14506 IF(ICHAR2.EQ.'ARRH')GOTO11900 14507 IF(ICHAR2.EQ.'VECT')GOTO11900 14508C 14509 GOTO17900 14510C 14511 100 CONTINUE 14512 ICHARN=1 14513 GOTO18000 14514C 14515 200 CONTINUE 14516 ICHARN=2 14517 GOTO18000 14518C 14519 300 CONTINUE 14520 ICHARN=3 14521 GOTO18000 14522C 14523 400 CONTINUE 14524 ICHARN=4 14525 GOTO18000 14526C 14527 500 CONTINUE 14528 ICHARN=5 14529 GOTO18000 14530C 14531 600 CONTINUE 14532 ICHARN=6 14533 GOTO18000 14534C 14535 700 CONTINUE 14536 ICHARN=7 14537 GOTO18000 14538C 14539 800 CONTINUE 14540 ICHARN=8 14541 GOTO18000 14542C 14543 900 CONTINUE 14544 ICHARN=9 14545 GOTO18000 14546C 14547 1000 CONTINUE 14548 ICHARN=10 14549 GOTO18000 14550C 14551 1100 CONTINUE 14552 ICHARN=11 14553 GOTO18000 14554C 14555 1200 CONTINUE 14556 ICHARN=12 14557 GOTO18000 14558C 14559 1300 CONTINUE 14560 ICHARN=13 14561 GOTO18000 14562C 14563 1400 CONTINUE 14564 ICHARN=14 14565 GOTO18000 14566C 14567 1500 CONTINUE 14568 ICHARN=15 14569 GOTO18000 14570C 14571 1600 CONTINUE 14572 ICHARN=16 14573 GOTO18000 14574C 14575 1700 CONTINUE 14576 ICHARN=17 14577 GOTO18000 14578C 14579 1800 CONTINUE 14580 ICHARN=18 14581 GOTO18000 14582C 14583 1900 CONTINUE 14584 ICHARN=19 14585 GOTO18000 14586C 14587 2000 CONTINUE 14588 ICHARN=20 14589 GOTO18000 14590C 14591 2100 CONTINUE 14592 ICHARN=21 14593 GOTO18000 14594C 14595 2200 CONTINUE 14596 ICHARN=22 14597 GOTO18000 14598C 14599 2300 CONTINUE 14600 ICHARN=23 14601 GOTO18000 14602C 14603 2400 CONTINUE 14604 ICHARN=24 14605 GOTO18000 14606C 14607 2500 CONTINUE 14608 ICHARN=25 14609 GOTO18000 14610C 14611 2600 CONTINUE 14612 ICHARN=26 14613 GOTO18000 14614C 14615 2700 CONTINUE 14616 ICHARN=27 14617 GOTO18000 14618C 14619 2800 CONTINUE 14620 ICHARN=28 14621 GOTO18000 14622C 14623 2900 CONTINUE 14624 ICHARN=29 14625 GOTO18000 14626C 14627 3000 CONTINUE 14628 ICHARN=30 14629 GOTO18000 14630C 14631 3100 CONTINUE 14632 ICHARN=31 14633 GOTO18000 14634C 14635 3200 CONTINUE 14636 ICHARN=32 14637 GOTO18000 14638C 14639 3300 CONTINUE 14640 ICHARN=33 14641 GOTO18000 14642C 14643 3400 CONTINUE 14644 ICHARN=34 14645 GOTO18000 14646C 14647 3500 CONTINUE 14648 ICHARN=35 14649 GOTO18000 14650C 14651 3600 CONTINUE 14652 ICHARN=36 14653 GOTO18000 14654C 14655 3700 CONTINUE 14656 ICHARN=37 14657 GOTO18000 14658C 14659 3800 CONTINUE 14660 ICHARN=38 14661 GOTO18000 14662C 14663 3900 CONTINUE 14664 ICHARN=39 14665 GOTO18000 14666C 14667 4000 CONTINUE 14668 ICHARN=40 14669 GOTO18000 14670C 14671 4100 CONTINUE 14672 ICHARN=41 14673 GOTO18000 14674C 14675 4200 CONTINUE 14676 ICHARN=42 14677 GOTO18000 14678C 14679 4300 CONTINUE 14680 ICHARN=43 14681 GOTO18000 14682C 14683 4400 CONTINUE 14684 ICHARN=44 14685 GOTO18000 14686C 14687 4500 CONTINUE 14688 ICHARN=45 14689 GOTO18000 14690C 14691 4600 CONTINUE 14692 ICHARN=46 14693 GOTO18000 14694C 14695 4700 CONTINUE 14696 ICHARN=47 14697 GOTO18000 14698C 14699 4800 CONTINUE 14700 ICHARN=48 14701 GOTO18000 14702C 14703 4900 CONTINUE 14704 ICHARN=49 14705 GOTO18000 14706C 14707 5000 CONTINUE 14708 ICHARN=50 14709 GOTO18000 14710C 14711 5100 CONTINUE 14712 ICHARN=51 14713 GOTO18000 14714C 14715 5200 CONTINUE 14716 ICHARN=52 14717 GOTO18000 14718C 14719 5300 CONTINUE 14720 ICHARN=53 14721 GOTO18000 14722C 14723 5400 CONTINUE 14724 ICHARN=54 14725 GOTO18000 14726C 14727 5500 CONTINUE 14728 ICHARN=55 14729 GOTO18000 14730C 14731 5600 CONTINUE 14732 ICHARN=56 14733 GOTO18000 14734C 14735 5700 CONTINUE 14736 ICHARN=57 14737 GOTO18000 14738C 14739 5800 CONTINUE 14740 ICHARN=58 14741 GOTO18000 14742C 14743 5900 CONTINUE 14744 ICHARN=59 14745 GOTO18000 14746C 14747 6000 CONTINUE 14748 ICHARN=60 14749 GOTO18000 14750C 14751 6100 CONTINUE 14752 ICHARN=61 14753 GOTO18000 14754C 14755 6200 CONTINUE 14756 ICHARN=62 14757 GOTO18000 14758C 14759 6300 CONTINUE 14760 ICHARN=63 14761 GOTO18000 14762C 14763 6400 CONTINUE 14764 ICHARN=64 14765 GOTO18000 14766C 14767 6500 CONTINUE 14768 ICHARN=65 14769 GOTO18000 14770C 14771 6600 CONTINUE 14772 ICHARN=66 14773 GOTO18000 14774C 1477510100 CONTINUE 14776 ICHARN=101 14777 GOTO18000 14778C 1477910200 CONTINUE 14780 ICHARN=102 14781 GOTO18000 14782C 1478310300 CONTINUE 14784 ICHARN=103 14785 GOTO18000 14786C 1478710400 CONTINUE 14788 ICHARN=104 14789 GOTO18000 14790C 1479110500 CONTINUE 14792 ICHARN=105 14793 GOTO18000 14794C 1479510600 CONTINUE 14796 ICHARN=106 14797 GOTO18000 14798C 1479910700 CONTINUE 14800 ICHARN=107 14801 GOTO18000 14802C 1480310800 CONTINUE 14804 ICHARN=108 14805 GOTO18000 14806C 1480710900 CONTINUE 14808 ICHARN=109 14809 GOTO18000 14810C 1481111000 CONTINUE 14812 ICHARN=110 14813 GOTO18000 14814C 1481511100 CONTINUE 14816 ICHARN=111 14817 GOTO18000 14818C 1481911200 CONTINUE 14820 ICHARN=112 14821 GOTO18000 14822C 1482311300 CONTINUE 14824 ICHARN=113 14825 GOTO18000 14826C 1482711400 CONTINUE 14828 ICHARN=114 14829 GOTO18000 14830C 1483111500 CONTINUE 14832 ICHARN=115 14833 GOTO18000 14834C 1483511600 CONTINUE 14836 ICHARN=116 14837 GOTO18000 14838C 1483911700 CONTINUE 14840 ICHARN=117 14841 GOTO18000 14842C 1484311800 CONTINUE 14844 ICHARN=118 14845 GOTO18000 14846C AUGUST 1992. ADDED FOLLOWING 3 LINES 1484711900 CONTINUE 14848 ICHARN=119 14849 GOTO18000 14850C 1485117900 CONTINUE 14852CCCCC WRITE(ICOUT,999) 14853CCCCC CALL DPWRST('XXX','BUG ') 14854CCCCC WRITE(ICOUT,7911) 14855C7911 FORMAT('***** ERROR IN DPCHMA--') 14856CCCCC CALL DPWRST('XXX','BUG ') 14857CCCCC WRITE(ICOUT,7912) 14858C7912 FORMAT(' NO MATCH FOUND FOR INPUT CHARACTER.') 14859CCCCC CALL DPWRST('XXX','BUG ') 14860CCCCC WRITE(ICOUT,7913)ICHAR2 14861C7913 FORMAT(' INPUT CHARACTER = ',A4) 14862CCCCC CALL DPWRST('XXX','BUG ') 14863 IFOUND='NO' 14864 GOTO19000 14865C 1486618000 CONTINUE 14867 IFOUND='YES' 14868 GOTO19000 14869C 14870C ***************** 14871C ** STEP 90-- ** 14872C ** EXIT ** 14873C ***************** 14874C 1487519000 CONTINUE 14876 IF(IBUG.EQ.'ON' .OR. ISUBG4.EQ.'CHMA')THEN 14877 WRITE(ICOUT,999) 14878 CALL DPWRST('XXX','BUG ') 14879 WRITE(ICOUT,19011) 1488019011 FORMAT('***** AT THE END OF DPCHMA--') 14881 CALL DPWRST('XXX','BUG ') 14882 WRITE(ICOUT,19013)IFOUND,ICHAR2,ICHARN 1488319013 FORMAT('IFOUND,ICHAR2,ICHARN = ',2(A4,2X),I8) 14884 CALL DPWRST('XXX','BUG ') 14885 ENDIF 14886C 14887 RETURN 14888 END 14889 SUBROUTINE DPCHNU(ICHAR2,ICHARN,IBUG,IFOUND) 14890C 14891C PURPOSE--CONVERT AN ALPHABETIC CHARACTER 14892C (0 TO 9) INTO A NUMERIC VALUE 14893C (1 TO 10). 14894C INPUT ARGUMENTS--ICHAR2 (A HOLLERITH VARIABLE 14895C CONTAINING THE HOLLERITH 14896C CHARACTER(S) OF INTEREST. 14897C OUTPUT ARGUMENTS--ICHARN (AN INTEGER VARIABLE 14898C CONTAINING THE NUMERIC 14899C DESIGNATION FOR THE 14900C ALPHABETIC CHARACTER. 14901C WRITTEN BY--JAMES J. FILLIBEN 14902C STATISTICAL ENGINEERING DIVISION 14903C INFORMATION TECHNOLOGY LABORATORY 14904C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 14905C GAITHERSBURG, MD 20899-8980 14906C PHONE--301-975-2899 14907C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 14908C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 14909C LANGUAGE--ANSI FORTRAN (1977) 14910C VERSION NUMBER--82/7 14911C ORIGINAL VERSION--MARCH 1981. 14912C UPDATED --NOVEMBER 1981. 14913C UPDATED --MAY 1982. 14914C 14915C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 14916C 14917 CHARACTER*4 ICHAR2 14918 CHARACTER*4 IBUG 14919 CHARACTER*4 IFOUND 14920C 14921 CHARACTER*1 ICH1 14922 CHARACTER*1 ICH2 14923C 14924C-----COMMON---------------------------------------------------------- 14925C 14926 INCLUDE 'DPCOBE.INC' 14927C 14928C-----COMMON VARIABLES (GENERAL)-------------------------------------- 14929C 14930 INCLUDE 'DPCOP2.INC' 14931C 14932C-----START POINT----------------------------------------------------- 14933C 14934 IFOUND='NO' 14935C 14936 ICH1='-' 14937 ICH2='-' 14938C 14939 ICH1N=(-999) 14940 ICH2N=(-999) 14941C 14942 IF(IBUG.EQ.'ON' .OR. ISUBG4.EQ.'CHNU')THEN 14943 WRITE(ICOUT,999) 14944 999 FORMAT(1X) 14945 CALL DPWRST('XXX','BUG ') 14946 WRITE(ICOUT,51) 14947 51 FORMAT('***** AT THE BEGINNING OF DPCHNU--') 14948 CALL DPWRST('XXX','BUG ') 14949 WRITE(ICOUT,59)ICHAR2,IBUGG4,ISUBG4 14950 59 FORMAT('ICHAR2,IBUGG4,ISUBG4 = ',2(A4,2X),A4) 14951 CALL DPWRST('XXX','BUG ') 14952 ENDIF 14953C 14954C ********************************** 14955C ** STEP 1-- ** 14956C ** CONVERT THE CHARACTER ** 14957C ********************************** 14958C 14959 ICH2(1:1)=ICHAR2(2:2) 14960CCCCC ICH2N=ICHAR(ICH2) 14961 CALL DPCOAN(ICH2,ICH2N) 14962 IF(ICH2N.EQ.32)GOTO1100 14963 GOTO7900 14964C 14965 1100 CONTINUE 14966 ICH1(1:1)=ICHAR2(1:1) 14967CCCCC ICH1N=ICHAR(ICH1) 14968 CALL DPCOAN(ICH1,ICH1N) 14969 ICHARN=ICH1N-47 14970 IF(1.LE.ICHARN.AND.ICHARN.LE.10)GOTO8000 14971 GOTO7900 14972C 14973 7900 CONTINUE 14974CCCCC WRITE(ICOUT,999) 14975CCCCC CALL DPWRST('XXX','BUG ') 14976CCCCC WRITE(ICOUT,7911) 14977C7911 FORMAT('***** ERROR IN DPCHNU--') 14978CCCCC CALL DPWRST('XXX','BUG ') 14979CCCCC WRITE(ICOUT,7912) 14980C7912 FORMAT(' NO MATCH FOUND FOR INPUT CHARACTER.') 14981CCCCC CALL DPWRST('XXX','BUG ') 14982CCCCC WRITE(ICOUT,7913)ICHAR 14983C7913 FORMAT(' INPUT CHARACTER = ',A4) 14984CCCCC CALL DPWRST('XXX','BUG ') 14985 IFOUND='NO' 14986 GOTO9000 14987C 14988 8000 CONTINUE 14989 IFOUND='YES' 14990 GOTO9000 14991C 14992C ***************** 14993C ** STEP 90-- ** 14994C ** EXIT ** 14995C ***************** 14996C 14997 9000 CONTINUE 14998 IF(IBUG.EQ.'ON' .OR. ISUBG4.EQ.'CHNU')THEN 14999 WRITE(ICOUT,999) 15000 CALL DPWRST('XXX','BUG ') 15001 WRITE(ICOUT,9011) 15002 9011 FORMAT('***** AT THE END OF DPCHAL--') 15003 CALL DPWRST('XXX','BUG ') 15004 WRITE(ICOUT,9012)ICH1,ICH1N,ICH2,ICH2N 15005 9012 FORMAT('ICH1,ICH1N,ICH2,ICH2N = ',A1,2X,I8,2X,A1,2X,I8) 15006 CALL DPWRST('XXX','BUG ') 15007 WRITE(ICOUT,9014)IFOUND,ICHAR2,ICHARN 15008 9014 FORMAT('IFOUND,ICHAR2,ICHARN = ',2(A4,2X),I8) 15009 CALL DPWRST('XXX','BUG ') 15010 ENDIF 15011C 15012 RETURN 15013 END 15014 SUBROUTINE DPCHOF(IHARG,IARGT,ARG,NUMARG, 15015 1 MAXCHA, 15016 1 PCHAHO,PCHAVO, 15017 1 IFOUND,IERROR) 15018C 15019C PURPOSE--DEFINE PLOT CHARACTER (HORIZONTAL AND VERTICAL) OFFSET 15020C FOR USE IN MULTI-TRACE PLOTS. 15021C THE OFFSET FOR THE CHARACTER FOR THE I-TH TRACE 15022C WILL BE PLACED 15023C IN THE I-TH ELEMENT OF THE FLOATING POINT 15024C VECTORS PCHAHO(.) AND PCHAVO(.). 15025C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 15026C --IARGT (A HOLLERITH VECTOR) 15027C --ARG (A HOLLERITH VECTOR) 15028C --NUMARG 15029C --MAXCHA 15030C OUTPUT ARGUMENTS--PCHAHO (A FLOATING POINT VECTOR 15031C WHOSE I-TH ELEMENT IS THE HORIZONTAL OFFSET 15032C FOR THE CHARACTER 15033C ASSIGNED TO THE I-TH TRACE IN 15034C A MULTI-TRACE PLOT. 15035C --PCHAVO (A FLOATING POINT VECTOR 15036C WHOSE I-TH ELEMENT IS THE VERTICAL OFFSET 15037C FOR THE CHARACTER 15038C ASSIGNED TO THE I-TH TRACE IN 15039C A MULTI-TRACE PLOT. 15040C --PCHAHO = CHARACTER WIDTH 15041C --PCHAVG = VERTICAL GAP BETWEEN CHARACTERS 15042C --PCHAHG = HORIZONTAL GAP BETWEEN CHARACTERS 15043C --IFOUND ('YES' OR 'NO' ) 15044C --IERROR ('YES' OR 'NO' ) 15045C WRITTEN BY--JAMES J. FILLIBEN 15046C STATISTICAL ENGINEERING DIVISION 15047C INFORMATION TECHNOLOGY LABORATORY 15048C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 15049C GAITHERSBURG, MD 20899-8980 15050C PHONE--301-975-2899 15051C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 15052C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 15053C LANGUAGE--ANSI FORTRAN (1977) 15054C VERSION NUMBER--82/7 15055C ORIGINAL VERSION--NOVEMBER 1986. 15056C UPDATED --AUGUST 1988. CORRECTED FORMAT STATEMENT 15057C UPDATED --AUGUST 1988. CORRECTED LOOP LOGIC 15058C 15059C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 15060C 15061 CHARACTER*4 IHARG 15062 CHARACTER*4 IARGT 15063 CHARACTER*4 IFOUND 15064 CHARACTER*4 IERROR 15065C 15066C--------------------------------------------------------------------- 15067C 15068 DIMENSION IHARG(*) 15069 DIMENSION IARGT(*) 15070 DIMENSION ARG(*) 15071C 15072 DIMENSION PCHAHO(*) 15073 DIMENSION PCHAVO(*) 15074C 15075C--------------------------------------------------------------------- 15076C 15077 INCLUDE 'DPCOP2.INC' 15078C 15079C-----START POINT----------------------------------------------------- 15080C 15081 IFOUND='NO' 15082 IERROR='NO' 15083C 15084 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'OFFS')GOTO1160 15085 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'DISP')GOTO1160 15086 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'OFFS')GOTO1105 15087 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'DISP')GOTO1105 15088 GOTO2199 15089C 15090 1105 CONTINUE 15091 IF(IHARG(NUMARG).EQ.'ON')GOTO1110 15092 IF(IHARG(NUMARG).EQ.'OFF')GOTO1110 15093 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 15094 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 15095C 15096 IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160 15097 IF(NUMARG.EQ.3)GOTO1120 15098 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'ALL')GOTO1130 15099 IF(NUMARG.GE.4.AND.IHARG(4).EQ.'ALL')GOTO1140 15100C 15101 GOTO1150 15102C 15103 1110 CONTINUE 15104 DO1115I=1,MAXCHA 15105 PCHAVO(I)=0.0 15106 PCHAHO(I)=0.0 15107 1115 CONTINUE 15108C 15109 IF(IFEEDB.EQ.'OFF')GOTO1119 15110 WRITE(ICOUT,999) 15111 999 FORMAT(1X) 15112 CALL DPWRST('XXX','BUG ') 15113 I=1 15114 WRITE(ICOUT,1116) 15115 1116 FORMAT('ALL CHARACTER (HORIZ. AND VERT.) OFFSETS') 15116 CALL DPWRST('XXX','BUG ') 15117 WRITE(ICOUT,1117)PCHAHO(I),PCHAVO(I) 15118 1117 FORMAT(' HAVE JUST BEEN SET TO ',2E15.7) 15119 CALL DPWRST('XXX','BUG ') 15120 1119 CONTINUE 15121 GOTO2190 15122C 15123 1120 CONTINUE 15124 I=1 15125 IF(IARGT(2).NE.'NUMB'.OR.IARGT(3).NE.'NUMB')GOTO1180 15126 PCHAHO(1)=ARG(2) 15127 PCHAVO(1)=ARG(3) 15128C 15129 IF(IFEEDB.EQ.'OFF')GOTO1129 15130 WRITE(ICOUT,999) 15131 CALL DPWRST('XXX','BUG ') 15132 I=1 15133 WRITE(ICOUT,1126)I 15134 1126 FORMAT('THE (HORIZ. AND VERT.) OFFSET FOR CHARACTER ',I6) 15135 CALL DPWRST('XXX','BUG ') 15136 WRITE(ICOUT,1127)PCHAHO(I),PCHAVO(I) 15137 1127 FORMAT(' HAS JUST BEEN SET TO ',2E15.7) 15138 CALL DPWRST('XXX','BUG ') 15139 1129 CONTINUE 15140 GOTO2190 15141C 15142 1130 CONTINUE 15143 I=1 15144 IF(IARGT(3).NE.'NUMB'.OR.IARGT(4).NE.'NUMB')GOTO1180 15145 DO1135I=1,MAXCHA 15146 PCHAHO(I)=ARG(3) 15147 PCHAVO(I)=ARG(4) 15148 1135 CONTINUE 15149C 15150 IF(IFEEDB.EQ.'OFF')GOTO1139 15151 WRITE(ICOUT,999) 15152 CALL DPWRST('XXX','BUG ') 15153 I=1 15154 WRITE(ICOUT,1116) 15155 CALL DPWRST('XXX','BUG ') 15156 WRITE(ICOUT,1117)PCHAHO(I),PCHAVO(I) 15157 CALL DPWRST('XXX','BUG ') 15158 1139 CONTINUE 15159 GOTO2190 15160C 15161 1140 CONTINUE 15162 I=1 15163 IF(IARGT(2).NE.'NUMB'.OR.IARGT(3).NE.'NUMB')GOTO1180 15164 DO1145I=1,MAXCHA 15165 PCHAHO(I)=ARG(2) 15166 PCHAVO(I)=ARG(3) 15167 1145 CONTINUE 15168C 15169 IF(IFEEDB.EQ.'OFF')GOTO1149 15170 WRITE(ICOUT,999) 15171 CALL DPWRST('XXX','BUG ') 15172 I=1 15173 WRITE(ICOUT,1116) 15174 CALL DPWRST('XXX','BUG ') 15175 WRITE(ICOUT,1117)PCHAHO(I),PCHAVO(I) 15176 CALL DPWRST('XXX','BUG ') 15177 1149 CONTINUE 15178 GOTO2190 15179C 15180 1150 CONTINUE 15181 IMAX=NUMARG-1 15182 IF(MAXCHA.LT.IMAX)IMAX=MAXCHA 15183CCCCC THE FOLLOWING 1 LINE WAS INSERTED IN AUGUST 1988 15184 J=0 15185 DO1155I=1,IMAX,2 15186 IP1=I+1 15187 IP2=I+2 15188 IF(IARGT(IP1).NE.'NUMB')GOTO1180 15189 IF(IARGT(IP2).NE.'NUMB')GOTO1180 15190CCCCC PCHAHO(I)=ARG(IP1) AUGUST 1988 15191CCCCC PCHAVO(I)=ARG(IP2) AUGUST 1988 15192CCCCC THE FOLLOWING 3 LINES WERE INSERTED IN AUGUST 1988 15193 J=J+1 15194 PCHAHO(J)=ARG(IP1) 15195 PCHAVO(J)=ARG(IP2) 15196 1155 CONTINUE 15197CCCCC THE FOLLOWING 1 LINE WAS INSERTED IN AUGUST 1988 15198 JMAX=J 15199C 15200 IF(IFEEDB.EQ.'OFF')GOTO1159 15201 WRITE(ICOUT,999) 15202 CALL DPWRST('XXX','BUG ') 15203CCCCC DO1156I=1,IMAX AUGUST 1988 15204CCCCC THE FOLLOWING 1 LINE WAS INSERTED IN AUGUST 1988 15205 DO1156I=1,JMAX 15206 WRITE(ICOUT,1126)I 15207 CALL DPWRST('XXX','BUG ') 15208CCCCC WRITE(ICOUT,1127)I,PCHAHO(I),PCHAVO(I) AUGUST 1988 15209CCCCC CALL DPWRST('XXX','BUG ') 15210 WRITE(ICOUT,1127)PCHAHO(I),PCHAVO(I) 15211 CALL DPWRST('XXX','BUG ') 15212 1156 CONTINUE 15213 1159 CONTINUE 15214 GOTO2190 15215C 15216 1160 CONTINUE 15217 DO1165I=1,MAXCHA 15218 PCHAHO(I)=0.0 15219 PCHAVO(I)=0.0 15220 1165 CONTINUE 15221C 15222 IF(IFEEDB.EQ.'OFF')GOTO1169 15223 WRITE(ICOUT,999) 15224 CALL DPWRST('XXX','BUG ') 15225 I=1 15226 WRITE(ICOUT,1116) 15227 CALL DPWRST('XXX','BUG ') 15228 WRITE(ICOUT,1117)PCHAHO(I),PCHAVO(I) 15229 CALL DPWRST('XXX','BUG ') 15230 1169 CONTINUE 15231 GOTO2190 15232C 15233 1180 CONTINUE 15234 IERROR='YES' 15235 WRITE(ICOUT,999) 15236 CALL DPWRST('XXX','BUG ') 15237 WRITE(ICOUT,1181) 15238 1181 FORMAT('***** ERROR IN DPCHOF--') 15239 CALL DPWRST('XXX','BUG ') 15240 WRITE(ICOUT,1182) 15241 1182 FORMAT('CHARACTER (HORIZ. AND VERT.) OFFSETS MUST BE NUMERIC') 15242 CALL DPWRST('XXX','BUG ') 15243 WRITE(ICOUT,1183) 15244 1183 FORMAT('HOWEVER, THE SPECIFIED CHARACTER OFFSET') 15245 CALL DPWRST('XXX','BUG ') 15246 WRITE(ICOUT,1184)I 15247 1184 FORMAT('FOR CHARACTER ',I6,' WAS NON-NUMERIC.') 15248 CALL DPWRST('XXX','BUG ') 15249 GOTO2199 15250C 15251 2190 CONTINUE 15252 IFOUND='YES' 15253C 15254 2199 CONTINUE 15255 RETURN 15256 END 15257 SUBROUTINE DPCHS3(ICASPL,IDIST,NUMSHA,IFORSW,ICASP3, 15258 1 PID,IVARID,IVARI2,NREPL, 15259 1 N,XMEAN,XSD,XMIN,XMAX, 15260 1 A,B,MINMAX, 15261 1 SHAPE1,SHAPE2,SHAPE3,SHAPE4, 15262 1 SHAPE5,SHAPE6,SHAPE7, 15263 1 KSLOC,KSSCAL,ICAPSW,ICAPTY, 15264 1 STATVA,STATCD,PVAL,NCELLS,IDF,IDISFL,MINSZ, 15265 1 CDF1,CDF2,CDF3,CDF4, 15266 1 IBUGA3,ISUBRO,IERROR) 15267C 15268C PURPOSE--PRINT THE OUTPUT FOR THE CHI-SQUARE TEST (GROUPED, 15269C UNCENSORED CASE) IN ASCII, HTML, LATEX, OR RTF FORMAT 15270C WRITTEN BY--ALAN HECKERT 15271C STATISTICAL ENGINEERING DIVISION 15272C INFORMATION TECHNOLOGY LABORATORY 15273C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 15274C GAITHERSBURG, MD 20899-8980 15275C PHONE--301-975-2899 15276C --DATAPLOT IS A REGISTERED TRADEMARK 15277C OF THE NATIONAL BUREAU OF STANDARDS. 15278C LANGUAGE--ANSI FORTRAN (1977) 15279C VERSION NUMBER--2009/12 15280C ORIGINAL VERSION--DECEMBER 2009. 15281C 15282C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 15283C 15284 REAL PID(*) 15285C 15286 CHARACTER*4 IVARID(*) 15287 CHARACTER*4 IVARI2(*) 15288C 15289 CHARACTER*4 ICASPL 15290 CHARACTER*4 ICASP3 15291 CHARACTER*4 ICAPSW 15292 CHARACTER*4 ICAPTY 15293 CHARACTER*4 IDISFL 15294 CHARACTER*4 IFORSW 15295 CHARACTER*4 IBUGA3 15296 CHARACTER*4 ISUBRO 15297 CHARACTER*4 IWRITE 15298 CHARACTER*4 IERROR 15299C 15300 CHARACTER*60 IDIST 15301C 15302 CHARACTER*4 IRTFMD 15303 COMMON/COMRTF/IRTFMD 15304C 15305 CHARACTER*4 ISUBN1 15306 CHARACTER*4 ISUBN2 15307 CHARACTER*4 ISTEPN 15308C 15309 REAL KSLOC 15310 REAL KSSCAL 15311C 15312C--------------------------------------------------------------------- 15313C 15314 PARAMETER (NUMALP=8) 15315 REAL ALPHA(NUMALP) 15316C 15317CCCCC INCLUDE 'DPCOST.INC' 15318C 15319 CHARACTER*1 IBASLC 15320 PARAMETER(NUMCLI=4) 15321 PARAMETER(MAXLIN=2) 15322 PARAMETER (MAXROW=50) 15323 CHARACTER*60 ITITLE 15324 CHARACTER*60 ITITLZ 15325 CHARACTER*60 ITITL9 15326 CHARACTER*60 ITEXT(MAXROW) 15327 CHARACTER*4 ALIGN(NUMCLI) 15328 CHARACTER*4 VALIGN(NUMCLI) 15329 REAL AVALUE(MAXROW) 15330 INTEGER NCTEXT(MAXROW) 15331 INTEGER IDIGIT(MAXROW) 15332 INTEGER NTOT(MAXROW) 15333 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 15334 CHARACTER*15 IVALUE(MAXROW,NUMCLI) 15335 CHARACTER*4 ITYPCO(NUMCLI) 15336 INTEGER NCTIT2(MAXLIN,NUMCLI) 15337 INTEGER NCVALU(MAXROW,NUMCLI) 15338 INTEGER IWHTML(NUMCLI) 15339 INTEGER IWRTF(NUMCLI) 15340 REAL AMAT(MAXROW,NUMCLI) 15341 LOGICAL IFRST 15342 LOGICAL ILAST 15343C 15344C--------------------------------------------------------------------- 15345C 15346 INCLUDE 'DPCOP2.INC' 15347C 15348 DATA ALPHA/ 15349 1 0.0, 50.0, 75.0, 90.0, 95.0, 97.5, 99.0, 99.5/ 15350C 15351C-----START POINT----------------------------------------------------- 15352C 15353C 15354 ISUBN1='DPCH' 15355 ISUBN2='SQ ' 15356 IERROR='NO' 15357 IWRITE='OFF' 15358 CALL DPCONA(92,IBASLC) 15359C 15360 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CHS3')THEN 15361 WRITE(ICOUT,999) 15362 999 FORMAT(1X) 15363 CALL DPWRST('XXX','BUG ') 15364 WRITE(ICOUT,71) 15365 71 FORMAT('***** AT THE BEGINNING OF DPCHS3--') 15366 CALL DPWRST('XXX','BUG ') 15367 WRITE(ICOUT,72)ICASPL,IDIST 15368 72 FORMAT('ICASPL,IDIST = ',A4,2X,A60) 15369 CALL DPWRST('XXX','BUG ') 15370 WRITE(ICOUT,73)N,MINMAX,XMIN,XMAX,XMEAN,XSD 15371 73 FORMAT('N,MINMAX,XMIN,XMAX,XMEAN,XSD = ',2I8,4G15.7) 15372 CALL DPWRST('XXX','BUG ') 15373 WRITE(ICOUT,75)STATVA,STATCD,PVAL 15374 75 FORMAT('STATVA,STATCD,PVAL = ',3G15.7) 15375 CALL DPWRST('XXX','BUG ') 15376 ENDIF 15377C 15378C ******************************************* 15379C ** STEP 41-- ** 15380C ** WRITE OUT INITIAL HEADER TABLE ** 15381C ******************************************* 15382C 15383 ISTEPN='41' 15384 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CHS3') 15385 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 15386C 15387 IF(IPRINT.EQ.'OFF')GOTO9000 15388C 15389 NUMDIG=7 15390 IF(IFORSW.EQ.'1')NUMDIG=1 15391 IF(IFORSW.EQ.'2')NUMDIG=2 15392 IF(IFORSW.EQ.'3')NUMDIG=3 15393 IF(IFORSW.EQ.'4')NUMDIG=4 15394 IF(IFORSW.EQ.'5')NUMDIG=5 15395 IF(IFORSW.EQ.'6')NUMDIG=6 15396 IF(IFORSW.EQ.'7')NUMDIG=7 15397 IF(IFORSW.EQ.'8')NUMDIG=8 15398 IF(IFORSW.EQ.'9')NUMDIG=9 15399 IF(IFORSW.EQ.'0')NUMDIG=0 15400 IF(IFORSW.EQ.'E')NUMDIG=-2 15401 IF(IFORSW.EQ.'-2')NUMDIG=-2 15402 IF(IFORSW.EQ.'-3')NUMDIG=-3 15403 IF(IFORSW.EQ.'-4')NUMDIG=-4 15404 IF(IFORSW.EQ.'-5')NUMDIG=-5 15405 IF(IFORSW.EQ.'-6')NUMDIG=-6 15406 IF(IFORSW.EQ.'-7')NUMDIG=-7 15407 IF(IFORSW.EQ.'-8')NUMDIG=-8 15408 IF(IFORSW.EQ.'-9')NUMDIG=-9 15409C 15410 ITITLE='Chi-Square Goodness of Fit Test' 15411 NCTITL=31 15412C 15413 ICNT=1 15414 ITEXT(ICNT)=' ' 15415 NCTEXT(ICNT)=0 15416 AVALUE(ICNT)=0.0 15417 IDIGIT(ICNT)=-1 15418 IF(ICASP3.EQ.'RAW')THEN 15419 ICNT=ICNT+1 15420 ITEXT(ICNT)='Response Variable: ' 15421 WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4) 15422 WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4) 15423 NCTEXT(ICNT)=27 15424 AVALUE(ICNT)=0.0 15425 IDIGIT(ICNT)=-1 15426 ELSEIF(ICASP3.EQ.'FREQ')THEN 15427 ICNT=ICNT+1 15428 ITEXT(ICNT)='Bin Frequency Variable: ' 15429 WRITE(ITEXT(ICNT)(25:28),'(A4)')IVARID(1)(1:4) 15430 WRITE(ITEXT(ICNT)(29:32),'(A4)')IVARI2(1)(1:4) 15431 NCTEXT(ICNT)=32 15432 AVALUE(ICNT)=0.0 15433 IDIGIT(ICNT)=-1 15434 ICNT=ICNT+1 15435 ITEXT(ICNT)='Bin Midpoint Variable: ' 15436 WRITE(ITEXT(ICNT)(25:28),'(A4)')IVARID(2)(1:4) 15437 WRITE(ITEXT(ICNT)(29:32),'(A4)')IVARI2(2)(1:4) 15438 NCTEXT(ICNT)=32 15439 AVALUE(ICNT)=0.0 15440 IDIGIT(ICNT)=-1 15441 ELSEIF(ICASP3.EQ.'FRE2')THEN 15442 ICNT=ICNT+1 15443 ITEXT(ICNT)='Bin Frequency Variable: ' 15444 WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARID(1)(1:4) 15445 WRITE(ITEXT(ICNT)(35:38),'(A4)')IVARI2(1)(1:4) 15446 NCTEXT(ICNT)=38 15447 AVALUE(ICNT)=0.0 15448 IDIGIT(ICNT)=-1 15449 ICNT=ICNT+1 15450 ITEXT(ICNT)='Bin Lower Boundary Variable: ' 15451 WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARID(2)(1:4) 15452 WRITE(ITEXT(ICNT)(35:38),'(A4)')IVARI2(2)(1:4) 15453 NCTEXT(ICNT)=38 15454 AVALUE(ICNT)=0.0 15455 IDIGIT(ICNT)=-1 15456 ICNT=ICNT+1 15457 ITEXT(ICNT)='Bin Upper Boundary Variable: ' 15458 WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARID(3)(1:4) 15459 WRITE(ITEXT(ICNT)(35:38),'(A4)')IVARI2(3)(1:4) 15460 NCTEXT(ICNT)=38 15461 AVALUE(ICNT)=0.0 15462 IDIGIT(ICNT)=-1 15463 ENDIF 15464C 15465 DO4101I=1,NREPL 15466 ICNT=ICNT+1 15467 ITEXT(ICNT)='Factor Variable : ' 15468 WRITE(ITEXT(ICNT)(17:17),'(I1)')I 15469 WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(I+1)(1:4) 15470 WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(I+1)(1:4) 15471 NCTEXT(ICNT)=27 15472 AVALUE(ICNT)=PID(I+1) 15473 IDIGIT(ICNT)=NUMDIG 15474 4101 CONTINUE 15475C 15476 ICNT=ICNT+1 15477 ITEXT(ICNT)=' ' 15478 NCTEXT(ICNT)=1 15479 AVALUE(ICNT)=0.0 15480 IDIGIT(ICNT)=-1 15481C 15482 ICNT=ICNT+1 15483 ITEXT(ICNT)='H0: The distribution fits the data' 15484 NCTEXT(ICNT)=34 15485 AVALUE(ICNT)=0.0 15486 IDIGIT(ICNT)=-1 15487 ICNT=ICNT+1 15488 ITEXT(ICNT)='Ha: The distribution does not fit the data' 15489 NCTEXT(ICNT)=43 15490 AVALUE(ICNT)=0.0 15491 IDIGIT(ICNT)=-1 15492C 15493 IEND=46 15494 DO4111I=46,1,-1 15495 IF(IDIST(I:I).NE.' ')THEN 15496 IEND=I 15497 GOTO4119 15498 ENDIF 15499 4111 CONTINUE 15500 IEND=1 15501 4119 CONTINUE 15502 CALL EXTBOU(ICASPL,IBOUND) 15503C 15504 ICNT=ICNT+1 15505 ITEXT(ICNT)=' ' 15506 NCTEXT(ICNT)=1 15507 AVALUE(ICNT)=0.0 15508 IDIGIT(ICNT)=-1 15509 ICNT=ICNT+1 15510 ITEXT(ICNT)(1:14)='Distribution: ' 15511 ISTRT=15 15512 ISTOP=15+IEND-1 15513 ITEXT(ICNT)(ISTRT:ISTOP)=IDIST(1:IEND) 15514 NCTEXT(ICNT)=ISTOP 15515 AVALUE(ICNT)=0.0 15516 IDIGIT(ICNT)=-1 15517C 15518 IF(IDISFL.EQ.'CONT')THEN 15519 IF(IBOUND.EQ.0)THEN 15520 ICNT=ICNT+1 15521 ITEXT(ICNT)='Location Parameter:' 15522 NCTEXT(ICNT)=19 15523 AVALUE(ICNT)=KSLOC 15524 IDIGIT(ICNT)=NUMDIG 15525 ICNT=ICNT+1 15526 ITEXT(ICNT)='Scale Parameter:' 15527 NCTEXT(ICNT)=16 15528 AVALUE(ICNT)=KSSCAL 15529 IDIGIT(ICNT)=NUMDIG 15530 ELSE 15531 ICNT=ICNT+1 15532 ITEXT(ICNT)='Lower Limit Parameter:' 15533 NCTEXT(ICNT)=22 15534 AVALUE(ICNT)=A 15535 IDIGIT(ICNT)=NUMDIG 15536 ICNT=ICNT+1 15537 ITEXT(ICNT)='Upper Limit Parameter:' 15538 NCTEXT(ICNT)=22 15539 AVALUE(ICNT)=B 15540 IDIGIT(ICNT)=NUMDIG 15541 ENDIF 15542 ENDIF 15543C 15544 IF(NUMSHA.GE.1)THEN 15545 DO4140I=1,NUMSHA 15546 ICNT=ICNT+1 15547 ITEXT(ICNT)='Shape Parameter :' 15548 WRITE(ITEXT(ICNT)(17:17),'(I1)')I 15549 NCTEXT(ICNT)=18 15550 IF(I.EQ.1)THEN 15551 AVALUE(ICNT)=SHAPE1 15552 ELSEIF(I.EQ.2)THEN 15553 AVALUE(ICNT)=SHAPE2 15554 ELSEIF(I.EQ.3)THEN 15555 AVALUE(ICNT)=SHAPE3 15556 ELSEIF(I.EQ.4)THEN 15557 AVALUE(ICNT)=SHAPE4 15558 ELSEIF(I.EQ.5)THEN 15559 AVALUE(ICNT)=SHAPE5 15560 ELSEIF(I.EQ.6)THEN 15561 AVALUE(ICNT)=SHAPE6 15562 ELSEIF(I.EQ.7)THEN 15563 AVALUE(ICNT)=SHAPE7 15564 ENDIF 15565 IDIGIT(ICNT)=NUMDIG 15566 4140 CONTINUE 15567 ENDIF 15568C 15569 ICNT=ICNT+1 15570 ITEXT(ICNT)=' ' 15571 NCTEXT(ICNT)=1 15572 AVALUE(ICNT)=0.0 15573 IDIGIT(ICNT)=-1 15574 ICNT=ICNT+1 15575 ITEXT(ICNT)='Summary Statistics:' 15576 NCTEXT(ICNT)=19 15577 AVALUE(ICNT)=0.0 15578 IDIGIT(ICNT)=-1 15579 ICNT=ICNT+1 15580 ITEXT(ICNT)='Total Number of Observations:' 15581 NCTEXT(ICNT)=29 15582 AVALUE(ICNT)=REAL(N) 15583 IDIGIT(ICNT)=0 15584 ICNT=ICNT+1 15585 ITEXT(ICNT)='Minimum Class Frequency' 15586 NCTEXT(ICNT)=24 15587 AVALUE(ICNT)=REAL(MINSZ) 15588 IDIGIT(ICNT)=0 15589 ICNT=ICNT+1 15590 ITEXT(ICNT)='Number of Non-Empty Cells' 15591 NCTEXT(ICNT)=25 15592 AVALUE(ICNT)=REAL(NCELLS) 15593 IDIGIT(ICNT)=0 15594 ICNT=ICNT+1 15595 ITEXT(ICNT)='Degress of Freedom' 15596 NCTEXT(ICNT)=18 15597 AVALUE(ICNT)=REAL(IDF) 15598 IDIGIT(ICNT)=0 15599 ICNT=ICNT+1 15600 ITEXT(ICNT)='Sample Minimum:' 15601 NCTEXT(ICNT)=15 15602 AVALUE(ICNT)=XMIN 15603 IDIGIT(ICNT)=NUMDIG 15604 ICNT=ICNT+1 15605 ITEXT(ICNT)='Sample Maximum:' 15606 NCTEXT(ICNT)=15 15607 AVALUE(ICNT)=XMAX 15608 IDIGIT(ICNT)=NUMDIG 15609 ICNT=ICNT+1 15610 ITEXT(ICNT)='Sample Mean:' 15611 NCTEXT(ICNT)=12 15612 AVALUE(ICNT)=XMEAN 15613 IDIGIT(ICNT)=NUMDIG 15614 ICNT=ICNT+1 15615 ITEXT(ICNT)='Sample SD:' 15616 NCTEXT(ICNT)=10 15617 AVALUE(ICNT)=XSD 15618 IDIGIT(ICNT)=NUMDIG 15619 ICNT=ICNT+1 15620 ITEXT(ICNT)=' ' 15621 NCTEXT(ICNT)=1 15622 AVALUE(ICNT)=0.0 15623 IDIGIT(ICNT)=-1 15624 ICNT=ICNT+1 15625 ITEXT(ICNT)='Chi-Square Test Statistic Value:' 15626 NCTEXT(ICNT)=32 15627 AVALUE(ICNT)=STATVA 15628 IDIGIT(ICNT)=NUMDIG 15629 ICNT=ICNT+1 15630 ITEXT(ICNT)='CDF Value:' 15631 NCTEXT(ICNT)=10 15632 AVALUE(ICNT)=STATCD 15633 IDIGIT(ICNT)=NUMDIG 15634 ICNT=ICNT+1 15635 ITEXT(ICNT)='P-Value:' 15636 NCTEXT(ICNT)=7 15637 AVALUE(ICNT)=PVAL 15638 IDIGIT(ICNT)=NUMDIG 15639 ICNT=ICNT+1 15640 ITEXT(ICNT)=' ' 15641 NCTEXT(ICNT)=1 15642 AVALUE(ICNT)=0.0 15643 IDIGIT(ICNT)=-1 15644C 15645 NUMROW=ICNT 15646 DO2310I=1,NUMROW 15647 NTOT(I)=15 15648 2310 CONTINUE 15649C 15650 ITITLZ=' ' 15651 NCTITZ=0 15652 IFRST=.TRUE. 15653 ILAST=.TRUE. 15654 NCTITZ=0 15655 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT, 15656 1 AVALUE,IDIGIT, 15657 1 NTOT,NUMROW, 15658 1 ICAPSW,ICAPTY,ILAST,IFRST, 15659 1 ISUBRO,IBUGA3,IERROR) 15660 ITITLE=' ' 15661 NCTITL=0 15662 ITITL9=' ' 15663 NCTIT9=0 15664C 15665 ITITLE(1:44)='Percent Points of the Reference Distribution' 15666 NCTITL=44 15667 NUMLIN=1 15668 NUMROW=8 15669 NUMCOL=3 15670 ITITL2(1,1)='Percent Point' 15671 ITITL2(1,2)=' ' 15672 ITITL2(1,3)='Value' 15673 NCTIT2(1,1)=13 15674 NCTIT2(1,2)=1 15675 NCTIT2(1,3)=5 15676C 15677 NMAX=0 15678 DO2521I=1,NUMCOL 15679 VALIGN(I)='b' 15680 ALIGN(I)='r' 15681 NTOT(I)=15 15682 IF(I.EQ.2)NTOT(I)=5 15683 NMAX=NMAX+NTOT(I) 15684 IDIGIT(I)=NUMDIG 15685 ITYPCO(I)='NUME' 15686 2521 CONTINUE 15687 ITYPCO(2)='ALPH' 15688 IDIGIT(1)=1 15689 IDIGIT(3)=3 15690 DO2523I=1,NUMROW 15691 DO2525J=1,NUMCOL 15692 NCVALU(I,J)=0 15693 IVALUE(I,J)=' ' 15694 NCVALU(I,J)=0 15695 AMAT(I,J)=0.0 15696 IF(J.EQ.1)THEN 15697 AMAT(I,J)=ALPHA(I) 15698 ELSEIF(J.EQ.2)THEN 15699 IVALUE(I,J)='=' 15700 NCVALU(I,J)=1 15701 ELSEIF(J.EQ.3)THEN 15702 IF(I.GE.2)THEN 15703 P100=ALPHA(I)/100.0 15704 CALL CHSPPF(P100,IDF,XPERC) 15705 XPERC2=RND(XPERC,3) 15706 AMAT(I,J)=XPERC2 15707 ELSE 15708 XPERC=0.0 15709 XPERC2=RND(XPERC,3) 15710 AMAT(I,J)=XPERC2 15711 ENDIF 15712 ENDIF 15713 2525 CONTINUE 15714 2523 CONTINUE 15715C 15716 IWHTML(1)=150 15717 IWHTML(2)=50 15718 IWHTML(3)=150 15719 IWRTF(1)=2000 15720 IWRTF(2)=IWRTF(1)+500 15721 IWRTF(3)=IWRTF(2)+2000 15722 IFRST=.TRUE. 15723 ILAST=.FALSE. 15724C 15725 CALL DPDTA4(ITITL9,NCTIT9, 15726 1 ITITLE,NCTITL,ITITL2,NCTIT2, 15727 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 15728 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW, 15729 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 15730 1 ICAPSW,ICAPTY,IFRST,ILAST, 15731 1 ISUBRO,IBUGA3,IERROR) 15732C 15733 ITITL9=' ' 15734 NCTIT9=0 15735 ITITLE='Conclusions (Upper 1-Tailed Test)' 15736 NCTITL=33 15737 NUMLIN=1 15738 NUMROW=4 15739 NUMCOL=4 15740 ITITL2(1,1)='Alpha' 15741 ITITL2(1,2)='CDF' 15742 ITITL2(1,3)='Critical Value' 15743 ITITL2(1,4)='Conclusion' 15744 NCTIT2(1,1)=5 15745 NCTIT2(1,2)=3 15746 NCTIT2(1,3)=14 15747 NCTIT2(1,4)=10 15748C 15749 NMAX=0 15750 DO2821I=1,NUMCOL 15751 VALIGN(I)='b' 15752 ALIGN(I)='r' 15753 NTOT(I)=15 15754 IF(I.EQ.1 .OR. I.EQ.2)NTOT(I)=7 15755 IF(I.EQ.3)NTOT(I)=17 15756 NMAX=NMAX+NTOT(I) 15757CCCCC IDIGIT(I)=NUMDIG 15758 IDIGIT(I)=3 15759 ITYPCO(I)='ALPH' 15760 2821 CONTINUE 15761 ITYPCO(3)='NUME' 15762 IDIGIT(1)=0 15763 IDIGIT(2)=0 15764 DO2823I=1,NUMROW 15765 DO2825J=1,NUMCOL 15766 NCVALU(I,J)=0 15767 IVALUE(I,J)=' ' 15768 NCVALU(I,J)=0 15769 AMAT(I,J)=0.0 15770 2825 CONTINUE 15771 2823 CONTINUE 15772 IVALUE(1,1)='10%' 15773 IVALUE(2,1)='5%' 15774 IVALUE(3,1)='2.5%' 15775 IVALUE(4,1)='1%' 15776 IVALUE(1,2)='90%' 15777 IVALUE(2,2)='95%' 15778 IVALUE(3,2)='97.5%' 15779 IVALUE(4,2)='99%' 15780 NCVALU(1,1)=3 15781 NCVALU(2,1)=2 15782 NCVALU(3,1)=4 15783 NCVALU(4,1)=2 15784 NCVALU(1,2)=3 15785 NCVALU(2,2)=3 15786 NCVALU(3,2)=5 15787 NCVALU(4,2)=3 15788 IVALUE(1,4)='Accept H0' 15789 IVALUE(2,4)='Accept H0' 15790 IVALUE(3,4)='Accept H0' 15791 IVALUE(4,4)='Accept H0' 15792 NCVALU(1,4)=9 15793 NCVALU(2,4)=9 15794 NCVALU(3,4)=9 15795 NCVALU(4,4)=9 15796 CALL CHSPPF(0.90,IDF,CDF1) 15797 CALL CHSPPF(0.95,IDF,CDF2) 15798 CALL CHSPPF(0.975,IDF,CDF3) 15799 CALL CHSPPF(0.99,IDF,CDF4) 15800 IF(STATVA.GT.CDF1)IVALUE(1,4)='Reject H0' 15801 IF(STATVA.GT.CDF2)IVALUE(2,4)='Reject H0' 15802 IF(STATVA.GT.CDF3)IVALUE(3,4)='Reject H0' 15803 IF(STATVA.GT.CDF4)IVALUE(4,4)='Reject H0' 15804 AMAT(1,3)=RND(CDF1,IDIGIT(3)) 15805 AMAT(2,3)=RND(CDF2,IDIGIT(3)) 15806 AMAT(3,3)=RND(CDF3,IDIGIT(3)) 15807 AMAT(4,3)=RND(CDF4,IDIGIT(3)) 15808C 15809 IWHTML(1)=150 15810 IWHTML(2)=150 15811 IWHTML(3)=150 15812 IWHTML(4)=150 15813 IWRTF(1)=1500 15814 IWRTF(2)=IWRTF(1)+1500 15815 IWRTF(3)=IWRTF(2)+2000 15816 IWRTF(4)=IWRTF(3)+2000 15817 IFRST=.FALSE. 15818C 15819C FOR LATEX, WE WANT TO ENSURE THAT TRAILING LINE IS PART 15820C OF THE TABLE SO THAT IT WILL BE PRINTED IN THE PROPER PLACE. 15821C 15822 IF(ICAPTY.EQ.'LATE')THEN 15823 ILAST=.FALSE. 15824 ELSE 15825 ILAST=.TRUE. 15826 ENDIF 15827C 15828 CALL DPDTA4(ITITL9,NCTIT9, 15829 1 ITITLE,NCTITL,ITITL2,NCTIT2, 15830 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 15831 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW, 15832 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 15833 1 ICAPSW,ICAPTY,IFRST,ILAST, 15834 1 ISUBRO,IBUGA3,IERROR) 15835C 15836C ***************** 15837C ** STEP 90-- ** 15838C ** EXIT ** 15839C ***************** 15840C 15841 9000 CONTINUE 15842 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CHS3')THEN 15843 WRITE(ICOUT,999) 15844 CALL DPWRST('XXX','BUG ') 15845 WRITE(ICOUT,9011) 15846 9011 FORMAT('***** AT THE END OF DPCHS3--') 15847 CALL DPWRST('XXX','BUG ') 15848 ENDIF 15849C 15850 RETURN 15851 END 15852 SUBROUTINE DPCHSY(ICHAR2,ICHARN,IBUG,IFOUND) 15853C 15854C PURPOSE--CONVERT A KEYBOARD SYMBOL 15855C (. , ; : ETC.) INTO A NUMERIC VALUE 15856C (1 TO 23). 15857C (1 TO 24). 15858C INPUT ARGUMENTS--ICHAR2 (A HOLLERITH VARIABLE 15859C CONTAINING THE HOLLERITH 15860C CHARACTER(S) OF INTEREST. 15861C OUTPUT ARGUMENTS--ICHARN (AN INTEGER VARIABLE 15862C CONTAINING THE NUMERIC 15863C DESIGNATION FOR THE 15864C ALPHABETIC CHARACTER. 15865C WRITTEN BY--JAMES J. FILLIBEN 15866C STATISTICAL ENGINEERING DIVISION 15867C INFORMATION TECHNOLOGY LABORATORY 15868C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 15869C GAITHERSBURG, MD 20899-8980 15870C PHONE--301-975-2899 15871C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 15872C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 15873C LANGUAGE--ANSI FORTRAN (1977) 15874C VERSION NUMBER--82/7 15875C ORIGINAL VERSION--MARCH 1981. 15876C UPDATED --NOVEMBER 1981. 15877C UPDATED --MAY 1982. 15878C UPDATED --MAY 1987. 15879C 15880C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 15881C 15882 CHARACTER*4 ICHAR2 15883 CHARACTER*4 IBUG 15884 CHARACTER*4 IFOUND 15885C 15886C-----COMMON---------------------------------------------------------- 15887C 15888 INCLUDE 'DPCOBE.INC' 15889C 15890C-----COMMON VARIABLES (GENERAL)-------------------------------------- 15891C 15892 INCLUDE 'DPCOP2.INC' 15893C 15894C-----START POINT----------------------------------------------------- 15895C 15896 IFOUND='NO' 15897C 15898 IF(IBUG.EQ.'ON' .OR. ISUBG4.EQ.'CHSY')THEN 15899 WRITE(ICOUT,999) 15900 999 FORMAT(1X) 15901 CALL DPWRST('XXX','BUG ') 15902 WRITE(ICOUT,51) 15903 51 FORMAT('***** AT THE BEGINNING OF DPCHSY--') 15904 CALL DPWRST('XXX','BUG ') 15905 WRITE(ICOUT,59)ICHAR2,IBUGG4,ISUBG4 15906 59 FORMAT('ICHAR2,IBUGG4,ISUBG4 = ',2(A4,2X),A4) 15907 CALL DPWRST('XXX','BUG ') 15908 ENDIF 15909C 15910C ********************************** 15911C ** STEP 1-- ** 15912C ** CONVERT THE CHARACTER ** 15913C ********************************** 15914C 15915 IF(ICHAR2.EQ.'.')GOTO100 15916 IF(ICHAR2.EQ.',')GOTO200 15917 IF(ICHAR2.EQ.':')GOTO300 15918 IF(ICHAR2.EQ.';')GOTO400 15919 IF(ICHAR2.EQ.'!')GOTO500 15920 IF(ICHAR2.EQ.'?')GOTO600 15921 IF(ICHAR2.EQ.'&')GOTO700 15922 IF(ICHAR2.EQ.'$')GOTO800 15923 IF(ICHAR2.EQ.'/')GOTO900 15924 IF(ICHAR2.EQ.'(')GOTO1000 15925 IF(ICHAR2.EQ.')')GOTO1100 15926 IF(ICHAR2.EQ.'*')GOTO1200 15927 IF(ICHAR2.EQ.'-')GOTO1300 15928 IF(ICHAR2.EQ.'+')GOTO1400 15929 IF(ICHAR2.EQ.'=')GOTO1500 15930 IF(ICHAR2.EQ.'''')GOTO1600 15931 IF(ICHAR2.EQ.'"')GOTO1700 15932 IF(ICHAR2.EQ.'DEGR')GOTO1800 15933 IF(ICHAR2.EQ.'NOSP')GOTO1900 15934 IF(ICHAR2.EQ.'HASP')GOTO2000 15935 IF(ICHAR2.EQ.' ')GOTO2100 15936 IF(ICHAR2.EQ.'LAPO')GOTO2200 15937 IF(ICHAR2.EQ.'RAPO')GOTO2300 15938 IF(ICHAR2.EQ.'|')GOTO2400 15939 GOTO7900 15940C 15941 100 CONTINUE 15942 ICHARN=1 15943 GOTO8000 15944C 15945 200 CONTINUE 15946 ICHARN=2 15947 GOTO8000 15948C 15949 300 CONTINUE 15950 ICHARN=3 15951 GOTO8000 15952C 15953 400 CONTINUE 15954 ICHARN=4 15955 GOTO8000 15956C 15957 500 CONTINUE 15958 ICHARN=5 15959 GOTO8000 15960C 15961 600 CONTINUE 15962 ICHARN=6 15963 GOTO8000 15964C 15965 700 CONTINUE 15966 ICHARN=7 15967 GOTO8000 15968C 15969 800 CONTINUE 15970 ICHARN=8 15971 GOTO8000 15972C 15973 900 CONTINUE 15974 ICHARN=9 15975 GOTO8000 15976C 15977 1000 CONTINUE 15978 ICHARN=10 15979 GOTO8000 15980C 15981 1100 CONTINUE 15982 ICHARN=11 15983 GOTO8000 15984C 15985 1200 CONTINUE 15986 ICHARN=12 15987 GOTO8000 15988C 15989 1300 CONTINUE 15990 ICHARN=13 15991 GOTO8000 15992C 15993 1400 CONTINUE 15994 ICHARN=14 15995 GOTO8000 15996C 15997 1500 CONTINUE 15998 ICHARN=15 15999 GOTO8000 16000C 16001 1600 CONTINUE 16002 ICHARN=16 16003 GOTO8000 16004C 16005 1700 CONTINUE 16006 ICHARN=17 16007 GOTO8000 16008C 16009 1800 CONTINUE 16010 ICHARN=18 16011 GOTO8000 16012C 16013 1900 CONTINUE 16014 ICHARN=19 16015 GOTO8000 16016C 16017 2000 CONTINUE 16018 ICHARN=20 16019 GOTO8000 16020C 16021 2100 CONTINUE 16022 ICHARN=21 16023 GOTO8000 16024C 16025 2200 CONTINUE 16026 ICHARN=22 16027 GOTO8000 16028C 16029 2300 CONTINUE 16030 ICHARN=23 16031 GOTO8000 16032C 16033 2400 CONTINUE 16034 ICHARN=24 16035 GOTO8000 16036C 16037 7900 CONTINUE 16038CCCCC WRITE(ICOUT,999) 16039CCCCC CALL DPWRST('XXX','BUG ') 16040CCCCC WRITE(ICOUT,7911) 16041C7911 FORMAT('***** ERROR IN DPCHSY--') 16042CCCCC CALL DPWRST('XXX','BUG ') 16043CCCCC WRITE(ICOUT,7912) 16044C7912 FORMAT(' NO MATCH FOUND FOR INPUT CHARACTER.') 16045CCCCC CALL DPWRST('XXX','BUG ') 16046CCCCC WRITE(ICOUT,7913)ICHAR2 16047C7913 FORMAT(' INPUT CHARACTER = ',A4) 16048CCCCC CALL DPWRST('XXX','BUG ') 16049 IFOUND='NO' 16050 GOTO9000 16051C 16052 8000 CONTINUE 16053 IFOUND='YES' 16054 GOTO9000 16055C 16056C ***************** 16057C ** STEP 90-- ** 16058C ** EXIT ** 16059C ***************** 16060C 16061 9000 CONTINUE 16062 IF(IBUG.EQ.'ON' .OR. ISUBG4.EQ.'CHSY')THEN 16063 WRITE(ICOUT,999) 16064 CALL DPWRST('XXX','BUG ') 16065 WRITE(ICOUT,9011) 16066 9011 FORMAT('***** AT THE END OF DPCHSY--') 16067 CALL DPWRST('XXX','BUG ') 16068 WRITE(ICOUT,9013)IFOUND,ICHAR2,ICHARN 16069 9013 FORMAT('IFOUND,ICHAR2,ICHARN = ',2(A4,2X),I8) 16070 CALL DPWRST('XXX','BUG ') 16071 ENDIF 16072C 16073 RETURN 16074 END 16075 SUBROUTINE DPCHSZ(PDEFHE,MAXCHA, 16076 1PCHAHE,PCHAWI,PCHAVG,PCHAHG, 16077 1IBUGP2,IBUGQ,IFOUND,IERROR) 16078C 16079C PURPOSE--DEFINE PLOT CHARACTER SIZES FOR USE IN MULTI-TRACE PLOTS. 16080C THE SIZE FOR THE CHARACTER FOR THE I-TH TRACE 16081C WILL BE PLACED 16082C IN THE I-TH ELEMENT OF THE FLOATING POINT 16083C VECTOR PCHAHE(.). 16084C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 16085C --IARGT (A HOLLERITH VECTOR) 16086C --ARG (A HOLLERITH VECTOR) 16087C --NUMARG 16088C --PDEFHE 16089C --MAXCHA 16090C OUTPUT ARGUMENTS--PCHAHE (A FLOATING POINT VECTOR 16091C WHOSE I-TH ELEMENT IS THE SIZE (= HEIGHT) 16092C FOR THE CHARACTER 16093C ASSIGNED TO THE I-TH TRACE IN 16094C A MULTI-TRACE PLOT. 16095C --PCHAWI = CHARACTER WIDTH 16096C --PCHAVG = VERTICAL GAP BETWEEN CHARACTERS 16097C --PCHAHG = HORIZONTAL GAP BETWEEN CHARACTERS 16098C --IFOUND ('YES' OR 'NO' ) 16099C --IERROR ('YES' OR 'NO' ) 16100C WRITTEN BY--JAMES J. FILLIBEN 16101C STATISTICAL ENGINEERING DIVISION 16102C INFORMATION TECHNOLOGY LABORATORY 16103C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 16104C GAITHERSBURG, MD 20899-8980 16105C PHONE--301-975-2899 16106C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16107C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 16108C LANGUAGE--ANSI FORTRAN (1977) 16109C VERSION NUMBER--82/7 16110C ORIGINAL VERSION--DECEMBER 1977. 16111C UPDATED --SEPTEMBER 1980. 16112C UPDATED --MARCH 1982. 16113C UPDATED --MAY 1982. 16114C UPDATED --DECEMBER 1982. 16115C UPDATED --JANUARY 1995. ALLOW ? AS ARGUMENT (FOR HELP) 16116C 16117C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16118C 16119CCCCC CHARACTER*4 IHARG DECEMBER 1986 16120CCCCC CHARACTER*4 IARGT DECEMBER 1986 16121C 16122 CHARACTER*4 IBUGP2 16123 CHARACTER*4 IBUGQ 16124 CHARACTER*4 IFOUND 16125 CHARACTER*4 IERROR 16126C 16127 CHARACTER*4 IHLEFT 16128 CHARACTER*4 IHLEF2 16129 CHARACTER*4 IHWUSE 16130 CHARACTER*4 MESSAG 16131 CHARACTER*4 ISTEPN 16132 CHARACTER*4 ISUBN1 16133 CHARACTER*4 ISUBN2 16134 CHARACTER*4 ICASEQ 16135 CHARACTER*4 IWRITE 16136C 16137C--------------------------------------------------------------------- 16138C 16139CCCCC DIMENSION IHARG(*) DECEMBER 1986 16140CCCCC DIMENSION IARGT(*) DECEMBER 1986 16141CCCCC DIMENSION IARG(*) DECEMBER 1986 16142CCCCC DIMENSION ARG(*) DECEMBER 1986 16143C 16144 DIMENSION PCHAHE(*) 16145 DIMENSION PCHAWI(*) 16146 DIMENSION PCHAVG(*) 16147 DIMENSION PCHAHG(*) 16148C 16149C-----COMMON---------------------------------------------------------- 16150C 16151 INCLUDE 'DPCOPA.INC' 16152 INCLUDE 'DPCOHK.INC' 16153 INCLUDE 'DPCODA.INC' 16154C 16155C--------------------------------------------------------------------- 16156C 16157 INCLUDE 'DPCOP2.INC' 16158C 16159C-----START POINT----------------------------------------------------- 16160C 16161 ISUBN1='DPCH' 16162 ISUBN2='SZ ' 16163 IFOUND='NO' 16164 IERROR='NO' 16165C 16166 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'SIZE'.AND. 16167 1IHARG(2).EQ.'BOX'.AND.IHARG(3).EQ.'PLOT')GOTO2110 16168 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'HEIG'.AND. 16169 1IHARG(2).EQ.'BOX'.AND.IHARG(3).EQ.'PLOT')GOTO2110 16170 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'SIZE'.AND. 16171 1IHARG(3).EQ.'BOX'.AND.IHARG(4).EQ.'PLOT')GOTO2110 16172 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'HEIG'.AND. 16173 1IHARG(3).EQ.'BOX'.AND.IHARG(4).EQ.'PLOT')GOTO2110 16174C 16175 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'SIZE')GOTO1160 16176 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'HEIG')GOTO1160 16177 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SIZE')GOTO1105 16178 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'HEIG')GOTO1105 16179 GOTO9000 16180C 16181 1105 CONTINUE 16182 IF(IHARG(NUMARG).EQ.'ON')GOTO1110 16183 IF(IHARG(NUMARG).EQ.'OFF')GOTO1110 16184 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 16185 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 16186CCCCC THE FOLLOWING LINE WAS ADDED JANUARY 1995 16187 IF(IHARG(NUMARG).EQ.'?')GOTO1200 16188C 16189 IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160 16190 IF(NUMARG.EQ.2)GOTO1120 16191 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130 16192 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140 16193C 16194 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'AUTO')GOTO3000 16195C 16196 GOTO1150 16197C 16198 1110 CONTINUE 16199 DO1115I=1,MAXCHA 16200 PCHAHE(I)=PDEFHE 16201 1115 CONTINUE 16202C 16203 IF(IFEEDB.EQ.'OFF')GOTO1119 16204 WRITE(ICOUT,999) 16205 999 FORMAT(1X) 16206 CALL DPWRST('XXX','BUG ') 16207 I=1 16208 WRITE(ICOUT,1116)PCHAHE(I) 16209 1116 FORMAT('ALL CHARACTER SIZES HAVE JUST BEEN SET TO ', 16210 1E15.7) 16211 CALL DPWRST('XXX','BUG ') 16212 1119 CONTINUE 16213 GOTO8000 16214C 16215 1120 CONTINUE 16216 I=1 16217 IF(IARGT(2).NE.'NUMB')GOTO1180 16218 PCHAHE(1)=ARG(2) 16219C 16220 IF(IFEEDB.EQ.'OFF')GOTO1129 16221 WRITE(ICOUT,999) 16222 CALL DPWRST('XXX','BUG ') 16223 I=1 16224 WRITE(ICOUT,1126)I,PCHAHE(I) 16225 1126 FORMAT('THE SIZE FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ', 16226 1E15.7) 16227 CALL DPWRST('XXX','BUG ') 16228 1129 CONTINUE 16229 GOTO8000 16230C 16231 1130 CONTINUE 16232 I=1 16233 IF(IARGT(3).NE.'NUMB')GOTO1180 16234 DO1135I=1,MAXCHA 16235 PCHAHE(I)=ARG(3) 16236 1135 CONTINUE 16237C 16238 IF(IFEEDB.EQ.'OFF')GOTO1139 16239 WRITE(ICOUT,999) 16240 CALL DPWRST('XXX','BUG ') 16241 I=1 16242 WRITE(ICOUT,1116)PCHAHE(I) 16243 CALL DPWRST('XXX','BUG ') 16244 1139 CONTINUE 16245 GOTO8000 16246C 16247 1140 CONTINUE 16248 I=1 16249 IF(IARGT(2).NE.'NUMB')GOTO1180 16250 DO1145I=1,MAXCHA 16251 PCHAHE(I)=ARG(2) 16252 1145 CONTINUE 16253C 16254 IF(IFEEDB.EQ.'OFF')GOTO1149 16255 WRITE(ICOUT,999) 16256 CALL DPWRST('XXX','BUG ') 16257 I=1 16258 WRITE(ICOUT,1116)PCHAHE(I) 16259 CALL DPWRST('XXX','BUG ') 16260 1149 CONTINUE 16261 GOTO8000 16262C 16263 1150 CONTINUE 16264 IMAX=NUMARG-1 16265 IF(MAXCHA.LT.IMAX)IMAX=MAXCHA 16266 DO1155I=1,IMAX 16267 IP1=I+1 16268 IF(IARGT(IP1).NE.'NUMB')GOTO1180 16269 PCHAHE(I)=ARG(IP1) 16270 1155 CONTINUE 16271C 16272 IF(IFEEDB.EQ.'OFF')GOTO1159 16273 WRITE(ICOUT,999) 16274 CALL DPWRST('XXX','BUG ') 16275 DO1156I=1,IMAX 16276 WRITE(ICOUT,1126)I,PCHAHE(I) 16277 CALL DPWRST('XXX','BUG ') 16278 1156 CONTINUE 16279 1159 CONTINUE 16280 GOTO8000 16281C 16282 1160 CONTINUE 16283 DO1165I=1,MAXCHA 16284 PCHAHE(I)=PDEFHE 16285 1165 CONTINUE 16286C 16287 IF(IFEEDB.EQ.'OFF')GOTO1169 16288 WRITE(ICOUT,999) 16289 CALL DPWRST('XXX','BUG ') 16290 I=1 16291 WRITE(ICOUT,1116)PCHAHE(I) 16292 CALL DPWRST('XXX','BUG ') 16293 1169 CONTINUE 16294 GOTO8000 16295C 16296 1180 CONTINUE 16297 IERROR='YES' 16298 WRITE(ICOUT,999) 16299 CALL DPWRST('XXX','BUG ') 16300 WRITE(ICOUT,1181) 16301 1181 FORMAT('***** ERROR IN DPCHSZ--') 16302 CALL DPWRST('XXX','BUG ') 16303 WRITE(ICOUT,1182) 16304 1182 FORMAT('CHARACTER SIZES MUST BE NUMERIC;') 16305 CALL DPWRST('XXX','BUG ') 16306 WRITE(ICOUT,1183) 16307 1183 FORMAT('HOWEVER, THE SPECIFIED CHARACTER SIZE') 16308 CALL DPWRST('XXX','BUG ') 16309 WRITE(ICOUT,1184)I 16310 1184 FORMAT('FOR CHARACTER ',I6,' WAS NON-NUMERIC.') 16311 CALL DPWRST('XXX','BUG ') 16312 GOTO9000 16313C 16314CCCCC THE FOLLOWING SECTION WAS ADDED JANUARY 1995 16315 1200 CONTINUE 16316 IFOUND='YES' 16317 IF(IFEEDB.EQ.'OFF')GOTO1229 16318 WRITE(ICOUT,999) 16319 CALL DPWRST('XXX','BUG ') 16320 I=1 16321 WRITE(ICOUT,1226)I,PCHAHE(I) 16322 1226 FORMAT('THE CURRENT SIZE FOR CHARACTER ',I6,' IS ',E15.7) 16323 CALL DPWRST('XXX','BUG ') 16324 WRITE(ICOUT,1227)I,PDEFHE 16325 1227 FORMAT('THE DEFAULT SIZE FOR CHARACTER ',I6,' IS ',E15.7) 16326 CALL DPWRST('XXX','BUG ') 16327 1229 CONTINUE 16328 GOTO9000 16329C 16330 2110 CONTINUE 16331 IMAX=24 16332 PCHAHE(1)=2.0 16333 PCHAHE(2)=2.0 16334 PCHAHE(3)=2.0 16335 PCHAHE(4)=2.0 16336 PCHAHE(5)=2.0 16337 PCHAHE(6)=2.0 16338 PCHAHE(7)=2.0 16339 PCHAHE(8)=2.0 16340 PCHAHE(9)=2.0 16341 PCHAHE(10)=2.0 16342 PCHAHE(11)=2.0 16343 PCHAHE(12)=2.0 16344 PCHAHE(13)=2.0 16345 PCHAHE(14)=2.0 16346 PCHAHE(15)=2.0 16347 PCHAHE(16)=2.0 16348 PCHAHE(17)=2.0 16349 PCHAHE(18)=2.0 16350 PCHAHE(19)=2.0 16351 PCHAHE(20)=2.0 16352 PCHAHE(21)=3.0 16353 PCHAHE(22)=2.0 16354 PCHAHE(23)=2.0 16355 PCHAHE(24)=3.0 16356 GOTO2170 16357C 16358 2170 CONTINUE 16359 IF(IFEEDB.EQ.'OFF')GOTO2179 16360 WRITE(ICOUT,999) 16361 CALL DPWRST('XXX','BUG ') 16362 DO2175I=1,IMAX 16363 WRITE(ICOUT,2176)I,PCHAHE(I) 16364 2176 FORMAT('THE SIZE FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ', 16365 1E15.7) 16366 CALL DPWRST('XXX','BUG ') 16367 2175 CONTINUE 16368 2179 CONTINUE 16369 GOTO8000 16370C 16371C *********************************************************** 16372C ** STEP 30-- ** 16373C ** TREAT THE CHARACTER SIZE AUTOMATIC <VARIABLE> CASE ** 16374C *********************************************************** 16375C 16376 3000 CONTINUE 16377C 16378C ******************************************** 16379C ** STEP 31-- ** 16380C ** CHECK THE VALIDITY OF ARGUMENT 3 ** 16381C ** (THIS WILL BE THE RESPONSE VARIABLE) ** 16382C ******************************************** 16383C 16384 ISTEPN='31' 16385 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16386C 16387 IHLEFT=IHARG(3) 16388 IHLEF2=IHARG2(3) 16389 IHWUSE='V' 16390 MESSAG='YES' 16391 CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 16392 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 16393 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 16394 IF(IERROR.EQ.'YES')GOTO9000 16395 ICOLL=IVALUE(ILOCV) 16396 NLEFT=IN(ILOCV) 16397C 16398C ***************************************** 16399C ** STEP 32-- ** 16400C ** CHECK TO SEE THE TYPE CASE-- ** 16401C ** 1) UNQUALIFIED (THAT IS, FULL); ** 16402C ** 2) SUBSET/EXCEPT; OR ** 16403C ** 3) FOR. ** 16404C ***************************************** 16405C 16406 ISTEPN='32' 16407 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16408C 16409 ICASEQ='FULL' 16410 ILOCQ=NUMARG+1 16411 IF(NUMARG.LT.1)GOTO3290 16412 DO3200J=1,NUMARG 16413 J1=J 16414 IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO3210 16415 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO3210 16416 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO3220 16417 3200 CONTINUE 16418 GOTO3290 16419 3210 CONTINUE 16420 ICASEQ='SUBS' 16421 ILOCQ=J1 16422 GOTO3290 16423 3220 CONTINUE 16424 ICASEQ='FOR' 16425 ILOCQ=J1 16426 GOTO3290 16427 3290 CONTINUE 16428 IF(IBUGP2.EQ.'OFF')GOTO3295 16429 WRITE(ICOUT,3291)NUMARG,ILOCQ 16430 3291 FORMAT('NUMARG,ILOCQ = ',2I8) 16431 CALL DPWRST('XXX','BUG ') 16432 3295 CONTINUE 16433C 16434C ********************************************* 16435C ** STEP 33-- ** 16436C ** TEMPORARILY FORM THE VARIABLE Y(.) ** 16437C ** WHICH WILL HOLD THE RESPONSE VARIABLE. ** 16438C ** FORM THIS VARIABLE BY ** 16439C ** BRANCHING TO THE APPROPRIATE SUBCASE ** 16440C ** (FULL, SUBSET, OR FOR). ** 16441C ********************************************* 16442C 16443 ISTEPN='33' 16444 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16445C 16446 IF(ICASEQ.EQ.'FULL')GOTO3310 16447 IF(ICASEQ.EQ.'SUBS')GOTO3320 16448 IF(ICASEQ.EQ.'FOR')GOTO3330 16449C 16450 3310 CONTINUE 16451 DO3315I=1,NLEFT 16452 ISUB(I)=1 16453 3315 CONTINUE 16454 NQ=NLEFT 16455 GOTO3350 16456C 16457 3320 CONTINUE 16458 NIOLD=NLEFT 16459 CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) 16460 NQ=NIOLD 16461 GOTO3350 16462C 16463 3330 CONTINUE 16464 NIOLD=NLEFT 16465 CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 16466 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) 16467 NQ=NFOR 16468 GOTO3350 16469C 16470 3350 CONTINUE 16471 MINN2=1 16472 IF(NQ.GE.MINN2)GOTO3360 16473 WRITE(ICOUT,999) 16474 CALL DPWRST('XXX','BUG ') 16475 WRITE(ICOUT,3351) 16476 3351 FORMAT('***** ERROR IN DPCHSZ--') 16477 CALL DPWRST('XXX','BUG ') 16478 WRITE(ICOUT,3352) 16479 3352 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 16480 1'EXTRACTED,') 16481 CALL DPWRST('XXX','BUG ') 16482 WRITE(ICOUT,3353)IHLEFT,IHLEF2 16483 3353 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 16484 1'FROM VARIABLE ',A4,A4) 16485 CALL DPWRST('XXX','BUG ') 16486 WRITE(ICOUT,3354) 16487 3354 FORMAT(' (FOR WHICH CHARACTER SIZES ') 16488 CALL DPWRST('XXX','BUG ') 16489 WRITE(ICOUT,3355) 16490 3355 FORMAT(' ARE TO BE GENERATED)') 16491 CALL DPWRST('XXX','BUG ') 16492 WRITE(ICOUT,3356)MINN2 16493 3356 FORMAT(' MUST BE ',I8,' OR LARGER;') 16494 CALL DPWRST('XXX','BUG ') 16495 WRITE(ICOUT,3357) 16496 3357 FORMAT(' SUCH WAS NOT THE CASE HERE.') 16497 CALL DPWRST('XXX','BUG ') 16498 WRITE(ICOUT,3358) 16499 3358 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') 16500 CALL DPWRST('XXX','BUG ') 16501 IF(IWIDTH.GE.1)WRITE(ICOUT,3359)(IANS(I),I=1,IWIDTH) 16502 3359 FORMAT(' ',80A1) 16503 IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') 16504 IERROR='YES' 16505 GOTO9000 16506C 16507 3360 CONTINUE 16508 MAXCP1=MAXCOL+1 16509 MAXCP2=MAXCOL+2 16510 MAXCP3=MAXCOL+3 16511 MAXCP4=MAXCOL+4 16512 MAXCP5=MAXCOL+5 16513 MAXCP6=MAXCOL+6 16514 J=0 16515 IMAX=NLEFT 16516 IF(NQ.LT.NLEFT)IMAX=NQ 16517 DO3370I=1,IMAX 16518 IF(ISUB(I).EQ.0)GOTO3370 16519 J=J+1 16520C 16521 IJ=MAXN*(ICOLL-1)+I 16522 IF(ICOLL.LE.MAXCOL)Y(J)=V(IJ) 16523 IF(ICOLL.EQ.MAXCP1)Y(J)=PRED(I) 16524 IF(ICOLL.EQ.MAXCP2)Y(J)=RES(I) 16525 IF(ICOLL.EQ.MAXCP3)Y(J)=YPLOT(I) 16526 IF(ICOLL.EQ.MAXCP4)Y(J)=XPLOT(I) 16527 IF(ICOLL.EQ.MAXCP5)Y(J)=X2PLOT(I) 16528 IF(ICOLL.EQ.MAXCP6)Y(J)=TAGPLO(I) 16529C 16530 3370 CONTINUE 16531 NS=J 16532 NY=J 16533C 16534C ***************************************** 16535C ** STEP 34-- ** 16536C ** EXTRACT THE DISTINCT VALUES ** 16537C ** FROM THE TARGET VARIABLE Y(.) . ** 16538C ** STORE THEM IN X(.) . ** 16539C ***************************************** 16540C 16541 IWRITE='OFF' 16542 CALL DISTIN(Y,NY,IWRITE,X,NX,IBUGP2,IERROR) 16543C 16544C *********************************** 16545C ** STEP 35-- ** 16546C ** SORT THESE DISTINCT VALUES ** 16547C ** (IN PLACE). ** 16548C *********************************** 16549C 16550 CALL SORT(X,NX,X) 16551C 16552C ****************************************** 16553C ** STEP 36-- ** 16554C ** COPY THE NUMERIC VALUES IN X(.) ** 16555C ** INTO INDIVIDUAL ELEMENTS ** 16556C ** OF PCHAHE(.) ** 16557C ** NOTE--MAX NUMBER OF VALUES = 100 ** 16558C ****************************************** 16559C 16560 IMAX=NX 16561 IF(IMAX.GT.MAXCHA)IMAX=MAXCHA 16562 DO3650I=1,IMAX 16563 PCHAHE(I)=X(I) 16564 3650 CONTINUE 16565C 16566 IF(IFEEDB.EQ.'OFF')GOTO3679 16567 WRITE(ICOUT,999) 16568 CALL DPWRST('XXX','BUG ') 16569 DO3675I=1,IMAX 16570 WRITE(ICOUT,3676)I,PCHAHE(I) 16571 3676 FORMAT('CHARACTER SIZE ',I6,' HAS JUST BEEN SET TO ', 16572 1E15.7) 16573 CALL DPWRST('XXX','BUG ') 16574 3675 CONTINUE 16575 3679 CONTINUE 16576 GOTO8000 16577C 16578 8000 CONTINUE 16579 IFOUND='YES' 16580 DO8010I=1,MAXCHA 16581 PCHAWI(I)=PCHAHE(I)*0.5 16582 PCHAVG(I)=PCHAHE(I)*0.5 16583 PCHAHG(I)=PCHAWI(I)*0.5 16584 8010 CONTINUE 16585 GOTO9000 16586C 16587C ***************** 16588C ** STEP 90-- ** 16589C ** EXIT ** 16590C ***************** 16591C 16592 9000 CONTINUE 16593 IF(IBUGP2.EQ.'OFF')GOTO9090 16594 WRITE(ICOUT,999) 16595 CALL DPWRST('XXX','BUG ') 16596 WRITE(ICOUT,9011) 16597 9011 FORMAT('***** AT THE END OF DPCHAR--') 16598 CALL DPWRST('XXX','BUG ') 16599 WRITE(ICOUT,9012)IBUGP2 16600 9012 FORMAT('IBUGP2 = ',A4) 16601 CALL DPWRST('XXX','BUG ') 16602 WRITE(ICOUT,9013)IFOUND,IERROR 16603 9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 16604 CALL DPWRST('XXX','BUG ') 16605 WRITE(ICOUT,9014)PDEFHE,IMAX 16606 9014 FORMAT('PDEFHE,IMAX = ',E15.7,I8) 16607 CALL DPWRST('XXX','BUG ') 16608 WRITE(ICOUT,9021)NY 16609 9021 FORMAT('NY = ',I8) 16610 CALL DPWRST('XXX','BUG ') 16611 IF(NY.LE.0)GOTO9022 16612 DO9023I=1,NY 16613 WRITE(ICOUT,9024)I,Y(I) 16614 9024 FORMAT('I,Y(I) = ',I8,E15.7) 16615 CALL DPWRST('XXX','BUG ') 16616 9023 CONTINUE 16617 9022 CONTINUE 16618 WRITE(ICOUT,9031)NX 16619 9031 FORMAT('NX = ',I8) 16620 CALL DPWRST('XXX','BUG ') 16621 IF(NX.LE.0)GOTO9032 16622 DO9033I=1,NX 16623 WRITE(ICOUT,9034)I,X(I) 16624 9034 FORMAT('I,X(I) = ',I8,E15.7) 16625 CALL DPWRST('XXX','BUG ') 16626 9033 CONTINUE 16627 9032 CONTINUE 16628 WRITE(ICOUT,9041)MAXCHA 16629 9041 FORMAT('MAXCHA = ',I8) 16630 CALL DPWRST('XXX','BUG ') 16631 IF(NX.LE.0)GOTO9042 16632 DO9043I=1,NX 16633 WRITE(ICOUT,9044)I,PCHAHE(I),PCHAWI(I),PCHAVG(I),PCHAHG(I) 16634 9044 FORMAT('I,PCHAHE(I),PCHAWI(I),PCHAVG(I),PCHAHG(I) = ',I8,2X, 16635 14E15.7) 16636 CALL DPWRST('XXX','BUG ') 16637 9043 CONTINUE 16638 9042 CONTINUE 16639 9090 CONTINUE 16640 RETURN 16641 END 16642 SUBROUTINE DPCHTH(IHARG,ARG,NUMARG,PDEFTH,MAXCHA,PCHATH, 16643 1IFOUND,IERROR) 16644C 16645C PURPOSE--DEFINE PLOT CHARACTER THICKNESSS FOR USE IN MULTI-TRACE PLOTS. 16646C THE THICKNESS FOR THE CHARACTER FOR THE I-TH TRACE 16647C WILL BE PLACED 16648C IN THE I-TH ELEMENT OF THE HOLLERITH 16649C VECTOR PCHATH(.). 16650C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 16651C --ARG (A REAL VECTOR) 16652C --NUMARG 16653C --PDEFTH 16654C --MAXCHA 16655C OUTPUT ARGUMENTS--PCHATH (A REAL VECTOR 16656C WHOSE I-TH ELEMENT IS THE THICKNESS 16657C FOR THE CHARACTER 16658C ASSIGNED TO THE I-TH TRACE IN 16659C A MULTI-TRACE PLOT. 16660C --IFOUND ('YES' OR 'NO' ) 16661C --IERROR ('YES' OR 'NO' ) 16662C WRITTEN BY--ALAN HECKERT 16663C COMPUTER SERVICES DIVISION 16664C INFORMATION TECHNOLOGY LABORATORY 16665C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 16666C GAITHERSBURG, MD 20899-8980 16667C PHONE--301-975-2899 16668C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16669C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 16670C LANGUAGE--ANSI FORTRAN (1977) 16671C VERSION NUMBER--82/7 16672C ORIGINAL VERSION--DECEMBER 1977. 16673C UPDATED --SEPTEMBER 1980. 16674C UPDATED --MARCH 1982. 16675C UPDATED --MAY 1982. 16676C 16677C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16678C 16679 CHARACTER*4 IHARG 16680 CHARACTER*4 IFOUND 16681 CHARACTER*4 IERROR 16682C 16683C--------------------------------------------------------------------- 16684C 16685 DIMENSION IHARG(*) 16686 DIMENSION ARG(*) 16687 DIMENSION PCHATH(*) 16688C 16689C--------------------------------------------------------------------- 16690C 16691 INCLUDE 'DPCOP2.INC' 16692C 16693C-----START POINT----------------------------------------------------- 16694C 16695 IFOUND='NO' 16696 IERROR='NO' 16697C 16698 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'THIC')GOTO1160 16699 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'THIC')GOTO1105 16700 GOTO1199 16701C 16702 1105 CONTINUE 16703 IF(IHARG(NUMARG).EQ.'ON')GOTO1110 16704 IF(IHARG(NUMARG).EQ.'OFF')GOTO1110 16705 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 16706 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 16707C 16708 IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160 16709 IF(NUMARG.EQ.2)GOTO1120 16710 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130 16711 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140 16712C 16713 GOTO1150 16714C 16715 1110 CONTINUE 16716 DO1115I=1,MAXCHA 16717 PCHATH(I)=PDEFTH 16718 1115 CONTINUE 16719C 16720 IF(IFEEDB.EQ.'OFF')GOTO1119 16721 WRITE(ICOUT,999) 16722 999 FORMAT(1X) 16723 CALL DPWRST('XXX','BUG ') 16724 I=1 16725 WRITE(ICOUT,1116)PCHATH(I) 16726 1116 FORMAT('ALL CHARACTER THICKNESSS HAVE JUST BEEN SET TO ', 16727 1E15.7) 16728 CALL DPWRST('XXX','BUG ') 16729 1119 CONTINUE 16730 GOTO1190 16731C 16732 1120 CONTINUE 16733 PCHATH(1)=ARG(2) 16734C 16735 IF(IFEEDB.EQ.'OFF')GOTO1129 16736 WRITE(ICOUT,999) 16737 CALL DPWRST('XXX','BUG ') 16738 I=1 16739 WRITE(ICOUT,1126)I,PCHATH(I) 16740 1126 FORMAT('THE THICKNESS FOR CHARACTER ',I6,' HAS JUST BEEN ', 16741 1'SET TO ',E15.7) 16742 CALL DPWRST('XXX','BUG ') 16743 1129 CONTINUE 16744 GOTO1190 16745C 16746 1130 CONTINUE 16747 DO1135I=1,MAXCHA 16748 PCHATH(I)=ARG(3) 16749 1135 CONTINUE 16750C 16751 IF(IFEEDB.EQ.'OFF')GOTO1139 16752 WRITE(ICOUT,999) 16753 CALL DPWRST('XXX','BUG ') 16754 I=1 16755 WRITE(ICOUT,1116)PCHATH(I) 16756 CALL DPWRST('XXX','BUG ') 16757 1139 CONTINUE 16758 GOTO1190 16759C 16760 1140 CONTINUE 16761 DO1145I=1,MAXCHA 16762 PCHATH(I)=ARG(2) 16763 1145 CONTINUE 16764C 16765 IF(IFEEDB.EQ.'OFF')GOTO1149 16766 WRITE(ICOUT,999) 16767 CALL DPWRST('XXX','BUG ') 16768 I=1 16769 WRITE(ICOUT,1116)PCHATH(I) 16770 CALL DPWRST('XXX','BUG ') 16771 1149 CONTINUE 16772 GOTO1190 16773C 16774 1150 CONTINUE 16775 IMAX=NUMARG-1 16776 IF(MAXCHA.LT.IMAX)IMAX=MAXCHA 16777 DO1155I=1,IMAX 16778 IP1=I+1 16779 PCHATH(I)=ARG(IP1) 16780 1155 CONTINUE 16781C 16782 IF(IFEEDB.EQ.'OFF')GOTO1159 16783 WRITE(ICOUT,999) 16784 CALL DPWRST('XXX','BUG ') 16785 DO1156I=1,IMAX 16786 WRITE(ICOUT,1126)I,PCHATH(I) 16787 CALL DPWRST('XXX','BUG ') 16788 1156 CONTINUE 16789 1159 CONTINUE 16790 GOTO1190 16791C 16792 1160 CONTINUE 16793 DO1165I=1,MAXCHA 16794 PCHATH(I)=PDEFTH 16795 1165 CONTINUE 16796C 16797 IF(IFEEDB.EQ.'OFF')GOTO1169 16798 WRITE(ICOUT,999) 16799 CALL DPWRST('XXX','BUG ') 16800 I=1 16801 WRITE(ICOUT,1116)PCHATH(I) 16802 CALL DPWRST('XXX','BUG ') 16803 1169 CONTINUE 16804 GOTO1190 16805C 16806 1190 CONTINUE 16807 IFOUND='YES' 16808C 16809 1199 CONTINUE 16810 RETURN 16811 END 16812 SUBROUTINE DPCHUN(IHARG,NUMARG,MAXCHA,ICHATY,IFOUND,IERROR) 16813C 16814C PURPOSE--DEFINE PLOT CHARACTER UNITS (DATA OR SCREEN) FOR USE IN 16815C MULTI-TRACE PLOTS. THE UNITS FOR THE CHARACTER FOR THE 16816C I-TH TRACE WILL BE PLACED IN THE I-TH ELEMENT OF THE 16817C HOLLERITH VECTOR ICHATY(.). 16818C 16819C THE UNITS ARE SPECIFIED AS: 16820C 16821C DD => X AXIS = DATA UNITS, Y AXIS = DATA UNITS 16822C DS => X AXIS = DATA UNITS, Y AXIS = SCREEN UNITS 16823C SD => X AXIS = SCREEN UNITS, Y AXIS = DATA UNITS 16824C SS => X AXIS = SCREEN UNITS, Y AXIS = SCREEN UNITS 16825C DATA => X AXIS = DATA UNITS, Y AXIS = DATA UNITS 16826C SCREEN => X AXIS = SCREEN UNITS, Y AXIS = SCREEN UNITS 16827C 16828C THE DEFAULT IS DATA UNITS FOR BOTH AXES. 16829C 16830C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 16831C --NUMARG 16832C --MAXCHA 16833C OUTPUT ARGUMENTS--ICHATY (A HOLLERITH VECTOR WHOSE I-TH ELEMENT 16834C IS THE UNITS FOR THE CHARACTER ASSIGNED TO THE 16835C I-TH TRACE IN A MULTI-TRACE PLOT. 16836C --IFOUND ('YES' OR 'NO' ) 16837C --IERROR ('YES' OR 'NO' ) 16838C WRITTEN BY--ALAN HECKERT 16839C STATISTICAL ENGINEERING DIVISION 16840C INFORMATION TECHNOLOGY LABORATORY 16841C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 16842C GAITHERSBURG, MD 20899-8980 16843C PHONE--301-975-2899 16844C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16845C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 16846C LANGUAGE--ANSI FORTRAN (1977) 16847C VERSION NUMBER--2018/01 16848C ORIGINAL VERSION--JANUARY 2018. 16849C 16850C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16851C 16852 CHARACTER*4 IHARG 16853 CHARACTER*4 ICHATY 16854 CHARACTER*4 IFOUND 16855 CHARACTER*4 IERROR 16856C 16857 CHARACTER*4 IDEFTY 16858C 16859C--------------------------------------------------------------------- 16860C 16861 DIMENSION IHARG(*) 16862 DIMENSION ICHATY(*) 16863C 16864C--------------------------------------------------------------------- 16865C 16866 INCLUDE 'DPCOP2.INC' 16867C 16868C-----START POINT----------------------------------------------------- 16869C 16870 IFOUND='YES' 16871 IERROR='NO' 16872 IDEFTY='DD' 16873C 16874 IF((NUMARG.EQ.1.AND.IHARG(1).EQ.'UNIT') .OR. 16875 1 (NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL'))THEN 16876 DO1165I=1,MAXCHA 16877 ICHATY(I)=IDEFTY 16878 1165 CONTINUE 16879C 16880 IF(IFEEDB.EQ.'ON')THEN 16881 WRITE(ICOUT,999) 16882 CALL DPWRST('XXX','BUG ') 16883 I=1 16884 WRITE(ICOUT,1116)ICHATY(I) 16885 CALL DPWRST('XXX','BUG ') 16886 ENDIF 16887 ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'UNIT')THEN 16888 IF(IHARG(NUMARG).EQ.'ON' .OR. IHARG(NUMARG).EQ.'OFF' .OR. 16889 1 IHARG(NUMARG).EQ.'AUTO' .OR. IHARG(NUMARG).EQ.'DEFA')THEN 16890 DO1115I=1,MAXCHA 16891 ICHATY(I)=IDEFTY 16892 1115 CONTINUE 16893C 16894 IF(IFEEDB.EQ.'ON')THEN 16895 WRITE(ICOUT,999) 16896 999 FORMAT(1X) 16897 CALL DPWRST('XXX','BUG ') 16898 I=1 16899 WRITE(ICOUT,1116)ICHATY(I) 16900 1116 FORMAT('ALL CHARACTER UNITS HAVE JUST BEEN SET TO ',A4) 16901 CALL DPWRST('XXX','BUG ') 16902 ENDIF 16903 ELSEIF(NUMARG.EQ.2)THEN 16904 ICHATY(1)=IHARG(2) 16905 IF(ICHATY(1).EQ.'SCRE' .OR. ICHATY(1).EQ.'SS ')THEN 16906 ICHATY(1)='SS ' 16907 ELSEIF(ICHATY(1).EQ.'DATA' .OR. ICHATY(1).EQ.'DD ')THEN 16908 ICHATY(1)='DD ' 16909 ELSE 16910 IF(ICHATY(1).NE.'DS ' .AND. ICHATY(1).NE.'SD ')THEN 16911 ICHATY(1)='DD' 16912 ENDIF 16913 ENDIF 16914C 16915 IF(IFEEDB.EQ.'ON')THEN 16916 WRITE(ICOUT,999) 16917 CALL DPWRST('XXX','BUG ') 16918 I=1 16919 WRITE(ICOUT,1126)I,ICHATY(I) 16920 1126 FORMAT('THE UNITS FOR CHARACTER ',I6, 16921 1 ' HAS JUST BEEN SET TO ',A4) 16922 CALL DPWRST('XXX','BUG ') 16923 ENDIF 16924 ELSEIF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')THEN 16925 DO1135I=1,MAXCHA 16926 ICHATY(I)=IHARG(3) 16927 IF(ICHATY(I).EQ.'SCRE' .OR. ICHATY(I).EQ.'SS ')THEN 16928 ICHATY(I)='SS ' 16929 ELSEIF(ICHATY(I).EQ.'DATA' .OR. ICHATY(I).EQ.'DD ')THEN 16930 ICHATY(I)='DD ' 16931 ELSE 16932 IF(ICHATY(I).NE.'DS ' .AND. ICHATY(I).NE.'SD ')THEN 16933 ICHATY(I)='DD' 16934 ENDIF 16935 ENDIF 16936 1135 CONTINUE 16937C 16938 IF(IFEEDB.EQ.'ON')THEN 16939 WRITE(ICOUT,999) 16940 CALL DPWRST('XXX','BUG ') 16941 I=1 16942 WRITE(ICOUT,1116)ICHATY(I) 16943 CALL DPWRST('XXX','BUG ') 16944 ENDIF 16945 ELSEIF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')THEN 16946 DO1145I=1,MAXCHA 16947 ICHATY(I)=IHARG(2) 16948 IF(ICHATY(I).EQ.'SCRE' .OR. ICHATY(I).EQ.'SS ')THEN 16949 ICHATY(I)='SS ' 16950 ELSEIF(ICHATY(I).EQ.'DATA' .OR. ICHATY(I).EQ.'DD ')THEN 16951 ICHATY(I)='DD ' 16952 ELSE 16953 IF(ICHATY(I).NE.'DS ' .AND. ICHATY(I).NE.'SD ')THEN 16954 ICHATY(I)='DD' 16955 ENDIF 16956 ENDIF 16957 1145 CONTINUE 16958C 16959 IF(IFEEDB.EQ.'ON')THEN 16960 WRITE(ICOUT,999) 16961 CALL DPWRST('XXX','BUG ') 16962 I=1 16963 WRITE(ICOUT,1116)ICHATY(I) 16964 CALL DPWRST('XXX','BUG ') 16965 ENDIF 16966C 16967 ELSE 16968 IMAX=NUMARG-1 16969 IF(MAXCHA.LT.IMAX)IMAX=MAXCHA 16970 DO1155I=1,IMAX 16971 IP1=I+1 16972 ICHATY(I)=IHARG(IP1) 16973 IF(ICHATY(I).EQ.'SCRE' .OR. ICHATY(I).EQ.'SS ')THEN 16974 ICHATY(I)='SS ' 16975 ELSEIF(ICHATY(I).EQ.'DATA' .OR. ICHATY(I).EQ.'DD ')THEN 16976 ICHATY(I)='DD ' 16977 ELSE 16978 IF(ICHATY(I).NE.'DS ' .AND. ICHATY(I).NE.'SD ')THEN 16979 ICHATY(I)='DD' 16980 ENDIF 16981 ENDIF 16982 1155 CONTINUE 16983C 16984 IF(IFEEDB.EQ.'ON')THEN 16985 WRITE(ICOUT,999) 16986 CALL DPWRST('XXX','BUG ') 16987 DO1156I=1,IMAX 16988 WRITE(ICOUT,1126)I,ICHATY(I) 16989 CALL DPWRST('XXX','BUG ') 16990 1156 CONTINUE 16991 ENDIF 16992 ENDIF 16993 ELSE 16994 IFOUND='NO' 16995 ENDIF 16996C 16997 RETURN 16998 END 16999 SUBROUTINE DPCHIS(MAXNXT, 17000 1 ICASAN,ICAPSW,IFORSW, 17001 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 17002C 17003C PURPOSE--COMPUTE THE CHI-SQUARE TEST FOR INDEPENDENCE 17004C EXAMPLE--CHI-SQUARE INDEPENDENCE TEST Y1 Y2 17005C --CHI-SQUARE INDEPENDENCE TEST N11 N21 N12 N22 17006C --CHI-SQUARE INDEPENDENCE TEST M 17007C REFERENCE--CONOVER (1999), "PRACTICAL NONPARAMETRIC 17008C STATISTICS", THIRD EDITION, WILEY, PP. 204-216. 17009C WRITTEN BY--ALAN HECKERT 17010C STATISTICAL ENGINEERING DIVISION 17011C INFORMATION TECHNOLOGY LABORATORY 17012C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 17013C GAITHERSBURG, MD 20899-8980 17014C PHONE--301-975-2899 17015C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 17016C OF THE NATIONAL BUREAU OF STANDARDS. 17017C LANGUAGE--ANSI FORTRAN (1977) 17018C VERSION NUMBER--2007/3 17019C ORIGINAL VERSION--MARCH 2007. 17020C UPDATED --JANUARY 2011. USE DPPARS, DPPAR3, DPPAR6 17021C UPDATED --JUNE 2019. TWEAK TO SCRATCH STORAGE 17022C 17023C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 17024C 17025 CHARACTER*4 ICASAN 17026 CHARACTER*4 ICAPSW 17027 CHARACTER*4 IFORSW 17028C 17029 CHARACTER*4 IBUGA2 17030 CHARACTER*4 IBUGA3 17031 CHARACTER*4 IBUGQ 17032 CHARACTER*4 ISUBRO 17033 CHARACTER*4 IFOUND 17034 CHARACTER*4 IERROR 17035C 17036 CHARACTER*4 ICASEQ 17037 CHARACTER*4 ISUBN1 17038 CHARACTER*4 ISUBN2 17039 CHARACTER*4 ISTEPN 17040 CHARACTER*4 IH 17041 CHARACTER*4 IH2 17042 CHARACTER*4 IHOST1 17043 CHARACTER*4 ISUBN0 17044 CHARACTER*4 ICASE 17045C 17046 CHARACTER*40 INAME 17047C 17048 PARAMETER (MAXSPN=20) 17049 CHARACTER*4 IVARN1(MAXSPN) 17050 CHARACTER*4 IVARN2(MAXSPN) 17051 CHARACTER*4 IVARTY(MAXSPN) 17052 REAL PVAR(MAXSPN) 17053 INTEGER ILIS(MAXSPN) 17054 INTEGER NRIGHT(MAXSPN) 17055 INTEGER ICOLR(MAXSPN) 17056C 17057C--------------------------------------------------------------------- 17058C 17059 PARAMETER(MAXLEV=1000) 17060C 17061 INCLUDE 'DPCOPA.INC' 17062 INCLUDE 'DPCOZZ.INC' 17063 INCLUDE 'DPCOZD.INC' 17064C 17065 REAL TEMP1(MAXOBV) 17066 REAL TEMP2(MAXOBV) 17067 REAL TEMP3(MAXOBV) 17068 REAL XIDTEM(MAXOBV) 17069 REAL XIDTE2(MAXOBV) 17070 REAL XMAT(MAXLEV,MAXLEV) 17071C 17072 DOUBLE PRECISION ROWTOT(MAXOBV) 17073 DOUBLE PRECISION COLTOT(MAXOBV) 17074C 17075 EQUIVALENCE (GARBAG(IGARB1),TEMP1(1)) 17076 EQUIVALENCE (GARBAG(IGARB2),TEMP2(1)) 17077 EQUIVALENCE (GARBAG(IGARB3),TEMP3(1)) 17078 EQUIVALENCE (GARBAG(IGARB4),XIDTEM(1)) 17079 EQUIVALENCE (GARBAG(IGARB5),XIDTE2(1)) 17080 EQUIVALENCE (GARBAG(IGARB6),XMAT(1,1)) 17081C 17082 EQUIVALENCE (DGARBG(IDGAR1),ROWTOT(1)) 17083 EQUIVALENCE (DGARBG(IDGAR2),COLTOT(1)) 17084C 17085C 17086C-----COMMON---------------------------------------------------------- 17087C 17088 INCLUDE 'DPCOHK.INC' 17089 INCLUDE 'DPCOSU.INC' 17090 INCLUDE 'DPCOST.INC' 17091 INCLUDE 'DPCODA.INC' 17092C 17093C-----COMMON VARIABLES (GENERAL)-------------------------------------- 17094C 17095 INCLUDE 'DPCOP2.INC' 17096C 17097C-----START POINT----------------------------------------------------- 17098C 17099 ISUBN1='DPCH' 17100 ISUBN2='IS ' 17101C 17102 MAXCP1=MAXCOL+1 17103 MAXCP2=MAXCOL+2 17104 MAXCP3=MAXCOL+3 17105 MAXCP4=MAXCOL+4 17106 MAXCP5=MAXCOL+5 17107 MAXCP6=MAXCOL+6 17108C 17109 IFOUND='NO' 17110 IERROR='NO' 17111C 17112 N11=(-999) 17113 N21=(-999) 17114 N12=(-999) 17115 N22=(-999) 17116 AN11=0.0 17117 AN12=0.0 17118 AN21=0.0 17119 AN22=0.0 17120C 17121 NS1=(-999) 17122 NS2=(-999) 17123 NS3=(-999) 17124 NS4=(-999) 17125C 17126 ICASE='PARA' 17127 MINN2=2 17128C 17129 IFOUND='YES' 17130 ICASEQ='UNKN' 17131C 17132C *************************************************** 17133C ** TREAT THE CHI-SQUARE INDEPENDENCE TEST CASE ** 17134C *************************************************** 17135C 17136 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CHIS')THEN 17137 WRITE(ICOUT,999) 17138 999 FORMAT(1X) 17139 CALL DPWRST('XXX','BUG ') 17140 WRITE(ICOUT,51) 17141 51 FORMAT('***** AT THE BEGINNING OF DPCHIS--') 17142 CALL DPWRST('XXX','BUG ') 17143 WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ICASAN 17144 52 FORMAT('IBUGA2,IBUGA3,IBUGQ,ICASAN = ',3(A4,2X),A4) 17145 CALL DPWRST('XXX','BUG ') 17146 WRITE(ICOUT,55)MAXNXT,NUMARG 17147 55 FORMAT('MAXNXT,NUMARG = ',2I8) 17148 CALL DPWRST('XXX','BUG ') 17149 DO59I=1,NUMARG 17150 WRITE(ICOUT,57)I,IHARG(I),IHARG2(I),ARG(I) 17151 57 FORMAT('I,IHARG(I),IHARG2(I),ARG(I) = ',I5,A4,A4,G15.7) 17152 59 CONTINUE 17153 ENDIF 17154C 17155C ********************************* 17156C ** STEP 4-- ** 17157C ** EXTRACT THE VARIABLE LIST ** 17158C ********************************* 17159C 17160 ISTEPN='4' 17161 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CHIS') 17162 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17163C 17164 INAME='CHI-SQUARE INDEPENDENCE TEST' 17165 MINNA=1 17166 MAXNA=100 17167 MINN2=2 17168 IFLAGE=0 17169 IFLAGM=9 17170 IFLAGP=9 17171 JMIN=1 17172 JMAX=NUMARG 17173 MINNVA=1 17174 MAXNVA=4 17175C 17176 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 17177 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 17178 1 JMIN,JMAX, 17179 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 17180 1 IVARN1,IVARN2,IVARTY,PVAR, 17181 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 17182 1 MINNVA,MAXNVA, 17183 1 IFLAGM,IFLAGP, 17184 1 IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 17185 IF(IERROR.EQ.'YES')GOTO9000 17186C 17187 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CHIS')THEN 17188 WRITE(ICOUT,999) 17189 CALL DPWRST('XXX','BUG ') 17190 WRITE(ICOUT,281) 17191 281 FORMAT('***** AFTER CALL DPPARS--') 17192 CALL DPWRST('XXX','BUG ') 17193 WRITE(ICOUT,282)NQ,NUMVAR 17194 282 FORMAT('NQ,NUMVAR = ',2I8) 17195 CALL DPWRST('XXX','BUG ') 17196 IF(NUMVAR.GT.0)THEN 17197 DO285I=1,NUMVAR 17198 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 17199 1 ICOLR(I),PVAR(I) 17200 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 17201 1 'ICOLR(I),PVAR(I) = ',I8,2X,A4,A4,2X,3I8,G15.7) 17202 CALL DPWRST('XXX','BUG ') 17203 285 CONTINUE 17204 ENDIF 17205 ENDIF 17206C 17207C *********************************** 17208C ** STEP 22-- ** 17209C ** CHECK FOR PROPER VALUES FOR ** 17210C ** INPUT PARAMETERS ** 17211C *********************************** 17212C 17213 IF(IVARTY(1).EQ.'PARA' .OR. IVARTY(1).EQ.'NUMB')THEN 17214 N11=INT(PVAR(1)+0.5) 17215 N21=INT(PVAR(2)+0.5) 17216 N12=INT(PVAR(3)+0.5) 17217 N22=INT(PVAR(4)+0.5) 17218 AN11=REAL(N11) 17219 AN21=REAL(N21) 17220 AN12=REAL(N12) 17221 AN22=REAL(N22) 17222 ICASE='PARA' 17223C 17224 ISTEPN='22' 17225 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CHIS') 17226 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17227C 17228 IF(N11.LT.0)THEN 17229 WRITE(ICOUT,999) 17230 CALL DPWRST('XXX','BUG ') 17231 WRITE(ICOUT,2201) 17232 2201 FORMAT('***** ERROR FROM CHI-SQUARE INDEPENDENCE TEST--') 17233 CALL DPWRST('XXX','BUG ') 17234 WRITE(ICOUT,2203) 17235 2203 FORMAT(' THE VALUE OF THE FIRST PARAMETER (N11 = THE ', 17236 1 'NUMBER OF SUCCESSES') 17237 CALL DPWRST('XXX','BUG ') 17238 WRITE(ICOUT,2204) 17239 2204 FORMAT(' FOR THE FIRST VARIABLE MUST BE NON-NEGATIVE.') 17240 CALL DPWRST('XXX','BUG ') 17241 WRITE(ICOUT,2205)N11 17242 2205 FORMAT(' N11 = ',I8) 17243 CALL DPWRST('XXX','BUG ') 17244 IERROR='YES' 17245 GOTO9000 17246C 17247 ELSEIF(N21.LT.0)THEN 17248 WRITE(ICOUT,999) 17249 CALL DPWRST('XXX','BUG ') 17250 WRITE(ICOUT,2201) 17251 CALL DPWRST('XXX','BUG ') 17252 WRITE(ICOUT,2303) 17253 2303 FORMAT(' THE VALUE OF THE SECOND PARAMETER (N21 = THE ', 17254 1 'NUMBER OF FAILURES') 17255 CALL DPWRST('XXX','BUG ') 17256 WRITE(ICOUT,2304) 17257 2304 FORMAT(' FOR THE FIRST VARIABLE MUST BE NON-NEGATIVE.') 17258 CALL DPWRST('XXX','BUG ') 17259 WRITE(ICOUT,2305)N21 17260 2305 FORMAT(' N21 = ',I8) 17261 CALL DPWRST('XXX','BUG ') 17262 IERROR='YES' 17263 GOTO9000 17264C 17265 ELSEIF(N12.LT.0)THEN 17266 WRITE(ICOUT,999) 17267 CALL DPWRST('XXX','BUG ') 17268 WRITE(ICOUT,2201) 17269 CALL DPWRST('XXX','BUG ') 17270 WRITE(ICOUT,2403) 17271 2403 FORMAT(' THE VALUE OF THE THIRD PARAMETER (N12 = THE ', 17272 1 'NUMBER OF SUCCESSES') 17273 CALL DPWRST('XXX','BUG ') 17274 WRITE(ICOUT,2404) 17275 2404 FORMAT(' FOR THE SECOND VARIABLE MUST BE NON-NEGATIVE.') 17276 CALL DPWRST('XXX','BUG ') 17277 WRITE(ICOUT,2405)N12 17278 2405 FORMAT(' N12 = ',I8) 17279 CALL DPWRST('XXX','BUG ') 17280 IERROR='YES' 17281 GOTO9000 17282C 17283 ELSEIF(N22.LT.0)THEN 17284 WRITE(ICOUT,999) 17285 CALL DPWRST('XXX','BUG ') 17286 WRITE(ICOUT,2201) 17287 CALL DPWRST('XXX','BUG ') 17288 WRITE(ICOUT,2503) 17289 2503 FORMAT(' THE VALUE OF THE FOURTH PARAMETER (N22 = THE ', 17290 1 'NUMBER OF FAILURES') 17291 CALL DPWRST('XXX','BUG ') 17292 WRITE(ICOUT,2504) 17293 2504 FORMAT(' FOR THE SECOND VARIABLE MUST BE NON-NEGATIVE.') 17294 CALL DPWRST('XXX','BUG ') 17295 WRITE(ICOUT,2505)N22 17296 2505 FORMAT(' N22 = ',I8) 17297 CALL DPWRST('XXX','BUG ') 17298 IERROR='YES' 17299 GOTO9000 17300 ENDIF 17301C 17302 ELSEIF(IVARTY(1).EQ.'VARI')THEN 17303C 17304 ICASE='VARI' 17305 ICOL=1 17306 IF(NUMVAR.GT.2)THEN 17307 WRITE(ICOUT,999) 17308 CALL DPWRST('XXX','BUG ') 17309 WRITE(ICOUT,2201) 17310 CALL DPWRST('XXX','BUG ') 17311 WRITE(ICOUT,2603) 17312 2603 FORMAT(' MORE THAN TWO VARIABLES GIVEN.') 17313 CALL DPWRST('XXX','BUG ') 17314 WRITE(ICOUT,2605)NUMVAR 17315 2605 FORMAT(' THE NUMBER OF VARIABLES GIVEN = ',I5) 17316 CALL DPWRST('XXX','BUG ') 17317 IERROR='YES' 17318 GOTO9000 17319 ENDIF 17320 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 17321 1 INAME,IVARN1,IVARN2,IVARTY, 17322 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 17323 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 17324 1 MAXCP4,MAXCP5,MAXCP6, 17325 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 17326 1 Y,X,X,NLOCAL,NLOCA2,NLOCA3,ICASE, 17327 1 IBUGA3,ISUBRO,IFOUND,IERROR) 17328 IF(IERROR.EQ.'YES')GOTO9000 17329 NS1=NLOCAL 17330 NS2=NLOCA2 17331C 17332 ELSEIF(IVARTY(1).EQ.'MATR')THEN 17333 ICASE='MATR' 17334 ICOL=1 17335 NUMVAR=1 17336 CALL DPPAR6(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 17337 1 INAME,IVARN1,IVARN2,IVARTY, 17338 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 17339 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 17340 1 MAXCP4,MAXCP5,MAXCP6, 17341 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 17342 1 XMAT,MAXLEV,NROW,NCOL,ICASE, 17343 1 IBUGA3,ISUBRO,IFOUND,IERROR) 17344 ICASE='TABL' 17345 IF(IERROR.EQ.'YES')GOTO9000 17346 ENDIF 17347C 17348C *********************************** 17349C ** STEP 61-- ** 17350C ** COMPUTE THE CHI-SQUARE TEST ** 17351C *********************************** 17352C 17353 ISTEPN='61' 17354 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CHIS') 17355 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17356C 17357 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CHIS')THEN 17358 WRITE(ICOUT,999) 17359 CALL DPWRST('XXX','BUG ') 17360 WRITE(ICOUT,6111) 17361 6111 FORMAT('***** FROM DPCHIS--READY TO COMPUTE TEST') 17362 CALL DPWRST('XXX','BUG ') 17363 WRITE(ICOUT,6112)AN11,AN21,AN12,AN22 17364 6112 FORMAT('AN11,AN21,AN12,AN22 = ',4G15.7) 17365 CALL DPWRST('XXX','BUG ') 17366 ENDIF 17367C 17368 CALL DPCHI2(Y,NS1,X,NS2, 17369 1 AN11,AN21,AN12,AN22, 17370 1 XMAT,MAXLEV,NROW,NCOL, 17371 1 XIDTEM,XIDTE2,TEMP1,TEMP2,TEMP3,MAXOBW, 17372 1 ROWTOT,COLTOT, 17373 1 ICASE, 17374 1 ICAPSW,ICAPTY,IFORSW, 17375 1 STATVA,CDF,STATV2,CDF2, 17376 1 ISUBRO,IBUGA3,IERROR) 17377C 17378C *************************************** 17379C ** STEP 62-- ** 17380C ** UPDATE INTERNAL DATAPLOT TABLES ** 17381C *************************************** 17382C 17383 ISTEPN='62' 17384 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CHIS') 17385 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17386C 17387 ISUBN0='CHIS' 17388C 17389 IH='STAT' 17390 IH2='VAL ' 17391 VALUE0=STATVA 17392 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 17393 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 17394 1IANS,IWIDTH,IBUGA3,IERROR) 17395C 17396 IH='STAT' 17397 IH2='CDF ' 17398 VALUE0=CDF 17399 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 17400 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 17401 1IANS,IWIDTH,IBUGA3,IERROR) 17402C 17403 IH='STAT' 17404 IH2='VAL2' 17405 VALUE0=STATV2 17406 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 17407 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 17408 1IANS,IWIDTH,IBUGA3,IERROR) 17409C 17410 IH='STAT' 17411 IH2='CDF2' 17412 VALUE0=CDF2 17413 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 17414 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 17415 1IANS,IWIDTH,IBUGA3,IERROR) 17416C 17417C ***************** 17418C ** STEP 90-- ** 17419C ** EXIT ** 17420C ***************** 17421C 17422 9000 CONTINUE 17423 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CHIS')THEN 17424 WRITE(ICOUT,999) 17425 CALL DPWRST('XXX','BUG ') 17426 WRITE(ICOUT,9011) 17427 9011 FORMAT('***** AT THE END OF DPCHIS--') 17428 CALL DPWRST('XXX','BUG ') 17429 WRITE(ICOUT,9012)IBUGA2,IBUGA3 17430 9012 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) 17431 CALL DPWRST('XXX','BUG ') 17432 WRITE(ICOUT,9016)IERROR 17433 9016 FORMAT('IERROR = ',A4,2X,A4) 17434 CALL DPWRST('XXX','BUG ') 17435 ENDIF 17436C 17437 RETURN 17438 END 17439 SUBROUTINE DPCHI2(Y1,N1,Y2,N2, 17440 1 AN11,AN21,AN12,AN22, 17441 1 XMAT,MAXLEV,NROW,NCOL, 17442 1 XIDTEM,XIDTE2,TEMP1,TEMP2,TEMP3,MAXNXT, 17443 1 ROWTOT,COLTOT, 17444 1 ICASE, 17445 1 ICAPSW,ICAPTY,IFORSW, 17446 1 STATVA,CDF,STATV2,CDF2, 17447 1 ISUBRO,IBUGA3,IERROR) 17448C 17449C PURPOSE--PERFORM A CHI-SQUARE TEST FOR INDEPENDENCE. 17450C THE INPUT CAN BE ENTERED IN THE FOLLOWING WAYS: 17451C 17452C 1) THE COMMON CASE OF A 2X2 TABLE CAN BE 17453C ENTERED AS 4 PARAMETERS: 17454C 17455C N11 = NUMBER OF SUCCESSES FOR VARIABLE 1 17456C N21 = NUMBER OF FAILURES FOR VARIABLE 1 17457C N12 = NUMBER OF SUCCESSES FOR VARIABLE 2 17458C N22 = NUMBER OF SUCCESSES FOR VARIABLE 2 17459C 17460C 2) AS RAW DATA, THAT IS TWO VARIABLES. A 17461C CROSS-TABULATION IS PERFORMED TO GENERATE 17462C AN RXC TABLE OF COUNTS. 17463C 17464C 3) AS A MATRIX, I.E., THE RXC TABLE HAS ALREADY 17465C BEEN GENERATED. 17466C 17467C THE CHI-SQUARE TEST CAN THEN BE COMPUTED AS: 17468C 17469C CHI-SQUARE = SUM[(f - F)**2/F 17470C 17471C WHERE THE SUMMATION IS OVER ALL CELLS IN THE 17472C TABLE AND WHERE 17473C 17474C f = OBSERVED FFEQUENCY OF THE CELL 17475C F = EXPECTED FREQUENCY OF THE CELL 17476C = (ROW TOTAL)*(COLUMN TOTAL)/(GRAND TOTAL) 17477C 17478C SOME ANALYSTS PREFER TO USE THE YATES CONTINUITY 17479C CORRECTION. IN THIS CORRECTON, 0.5 IS ADDED TO 17480C EACH CELL. DATAPLOT WILL GENERATE THE TEST STATISTIC 17481C FOR BOTH THE UNCORRECTED AND CORRECTED CASES. 17482C 17483C EXAMPLE--CHI-SQUARE INDEPENDENCE TEST Y1 Y2 17484C --CHI-SQUARE INDEPENDENCE TEST N11 N21 N12 N22 17485C --CHI-SQUARE INDEPENDENCE TEST M 17486C WRITTEN BY--ALAN HECKERT 17487C STATISTICAL ENGINEERING DIVISION 17488C INFORMATION TECHNOLOGYU LABORATORY 17489C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 17490C GAITHERSBURG, MD 20899-8980 17491C PHONE--301-975-2899 17492C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 17493C OF THE NATIONAL BUREAU OF STANDARDS. 17494C LANGUAGE--ANSI FORTRAN (1977) 17495C VERSION NUMBER--2007/3 17496C ORIGINAL VERSION--MARCH 2007. 17497C UPDATED --JANUARY 2011. USE DPAUFI TO OPEN/CLOSE 17498C AUXILLARY FILES 17499C UPDATED --JANUARY 2011. USE DPDTA1, DPDT5B TO PRINT 17500C TABLES 17501C UPDATED --APRIL 2019. USER CAN SPECIFY NUMBER OF 17502C DECIMAL POINTS FOR AUXILLARY 17503C FILES 17504C 17505C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 17506C 17507 CHARACTER*4 ISUBRO 17508 CHARACTER*4 IBUGA3 17509 CHARACTER*4 IERROR 17510 CHARACTER*4 ICASE 17511 CHARACTER*4 ICAPSW 17512 CHARACTER*4 ICAPTY 17513 CHARACTER*4 IFORSW 17514C 17515 CHARACTER*4 IWRITE 17516 CHARACTER*6 ICONC1 17517 CHARACTER*6 ICONC2 17518 CHARACTER*6 ICONC3 17519 CHARACTER*6 ICONC4 17520 CHARACTER*6 ICONC5 17521 CHARACTER*6 ICONC6 17522 CHARACTER*6 KCONC1 17523 CHARACTER*6 KCONC2 17524 CHARACTER*6 KCONC3 17525 CHARACTER*6 KCONC4 17526 CHARACTER*6 KCONC5 17527 CHARACTER*6 KCONC6 17528C 17529 CHARACTER*4 ISUBN1 17530 CHARACTER*4 ISUBN2 17531 CHARACTER*4 ISTEPN 17532C 17533 CHARACTER*4 IOP 17534 CHARACTER*20 IFORMT 17535C 17536C--------------------------------------------------------------------- 17537C 17538 DIMENSION Y1(*) 17539 DIMENSION Y2(*) 17540 DIMENSION TEMP1(*) 17541 DIMENSION TEMP2(*) 17542 DIMENSION TEMP3(*) 17543 DIMENSION XIDTEM(*) 17544 DIMENSION XIDTE2(*) 17545C 17546 DIMENSION XMAT(MAXLEV,MAXLEV) 17547C 17548 DOUBLE PRECISION ROWTOT(*) 17549 DOUBLE PRECISION COLTOT(*) 17550C 17551 PARAMETER (NUMALP=6) 17552CCCCC DIMENSION SIGVAL(NUMALP) 17553CCCCC DIMENSION ALOWCL(NUMALP) 17554CCCCC DIMENSION AUPPCL(NUMALP) 17555CCCCC DIMENSION ALOWC2(NUMALP) 17556CCCCC DIMENSION AUPPC2(NUMALP) 17557C 17558 DOUBLE PRECISION GTOTAL 17559 DOUBLE PRECISION VALTMP 17560 DOUBLE PRECISION EXP 17561 DOUBLE PRECISION CHISQ1 17562 DOUBLE PRECISION CHISQ2 17563C 17564 PARAMETER(NUMCLI=5) 17565 PARAMETER(MAXLIN=3) 17566 PARAMETER (MAXROW=NUMALP) 17567 PARAMETER (MAXRO2=30) 17568 CHARACTER*60 ITITLE 17569 CHARACTER*60 ITITLZ 17570 CHARACTER*60 ITITL9 17571 CHARACTER*60 ITEXT(MAXRO2) 17572 CHARACTER*4 ALIGN(NUMCLI) 17573 CHARACTER*4 VALIGN(NUMCLI) 17574 REAL AVALUE(MAXRO2) 17575 INTEGER NCTEXT(MAXRO2) 17576 INTEGER IDIGIT(MAXRO2) 17577 INTEGER NTOT(MAXRO2) 17578 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 17579 CHARACTER*15 IVALUE(MAXROW,NUMCLI) 17580 CHARACTER*4 ITYPCO(NUMCLI) 17581 INTEGER NCTIT2(MAXLIN,NUMCLI) 17582 INTEGER NCVALU(MAXROW,NUMCLI) 17583 INTEGER IWHTML(NUMCLI) 17584 INTEGER IWRTF(NUMCLI) 17585 REAL AMAT(MAXROW,NUMCLI) 17586 LOGICAL IFRST 17587 LOGICAL ILAST 17588 LOGICAL IFLAGS 17589 LOGICAL IFLAGE 17590C 17591 INCLUDE 'DPCOST.INC' 17592C 17593C--------------------------------------------------------------------- 17594C 17595 INCLUDE 'DPCOP2.INC' 17596C 17597CCCCC DATA SIGVAL /0.50, 0.80, 0.90, 0.95, 0.975, 0.99/ 17598C 17599C-----START POINT----------------------------------------------------- 17600C 17601 ISUBN1='DPCH' 17602 ISUBN2='I2 ' 17603 IERROR='NO' 17604 IWRITE='NO' 17605C 17606 ICONC1='ACCEPT' 17607 ICONC2='ACCEPT' 17608 ICONC3='ACCEPT' 17609 ICONC4='ACCEPT' 17610 ICONC5='ACCEPT' 17611 ICONC6='ACCEPT' 17612C 17613 IOP='OPEN' 17614 IFLAG1=1 17615 IFLAG2=0 17616 IFLAG3=0 17617 IFLAG4=0 17618 IFLAG5=0 17619 CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5, 17620 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 17621 1 IBUGA3,ISUBRO,IERROR) 17622 IF(IERROR.EQ.'YES')GOTO9000 17623C 17624 WRITE(IOUNI1,41) 17625 41 FORMAT(5X,'ROW COLUMN',9X,'ROWTOT',9X,'COLTOT',6X,'EXPECTED', 17626 1 8X,'OBSERVED') 17627C 17628 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CHI2')THEN 17629 WRITE(ICOUT,999) 17630 999 FORMAT(1X) 17631 CALL DPWRST('XXX','WRIT') 17632 WRITE(ICOUT,51) 17633 51 FORMAT('**** AT THE BEGINNING OF DPCHI2--') 17634 CALL DPWRST('XXX','WRIT') 17635 WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASE,MAXNXT 17636 52 FORMAT('IBUGA3,ISUBRO,ICASE,MAXNXT = ',4(A4,2X),I8) 17637 CALL DPWRST('XXX','WRIT') 17638 IF(ICASE.EQ.'VARI')THEN 17639 WRITE(ICOUT,55)N1 17640 55 FORMAT('N1 = ',I8) 17641 CALL DPWRST('XXX','WRIT') 17642 DO56I=1,N1 17643 WRITE(ICOUT,57)I,Y1(I) 17644 57 FORMAT('I,Y1(I) = ',I8,E15.7) 17645 CALL DPWRST('XXX','WRIT') 17646 56 CONTINUE 17647 WRITE(ICOUT,65)N2 17648 65 FORMAT('N2 = ',I8) 17649 CALL DPWRST('XXX','WRIT') 17650 DO66I=1,N2 17651 WRITE(ICOUT,67)I,Y2(I) 17652 67 FORMAT('I,Y2(I) = ',I8,E15.7) 17653 CALL DPWRST('XXX','WRIT') 17654 66 CONTINUE 17655 ELSE 17656 WRITE(ICOUT,75)AN11,AN21,AN12,AN22 17657 75 FORMAT('AN11,AN21,AN12,AN22 = ',4G15.7) 17658 CALL DPWRST('XXX','WRIT') 17659 ENDIF 17660 ENDIF 17661 17662C ******************************************** 17663C ** STEP 0-- ** 17664C ** BRANCH TO APPROPRIATE CASE (PARAMETER ** 17665C ** OR VARIABLE) ** 17666C ******************************************** 17667C 17668 ISTEPN='00' 17669 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2') 17670 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17671C 17672 IF(ICASE.EQ.'PARA')GOTO1000 17673 IF(ICASE.EQ.'VARI')GOTO2000 17674 IF(ICASE.EQ.'TABL')GOTO3000 17675C 17676C ******************************************** 17677C ** STEP 11-- ** 17678C ** PARAMETER CASE ** 17679C ******************************************** 17680C 17681 1000 CONTINUE 17682C 17683 ISTEPN='11' 17684 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2') 17685 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17686C 17687C ******************************************** 17688C ** STEP 12-- ** 17689C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 17690C ******************************************** 17691C 17692 N11=INT(AN11+0.5) 17693 N21=INT(AN21+0.5) 17694 N12=INT(AN12+0.5) 17695 N22=INT(AN22+0.5) 17696C 17697 ISTEPN='12' 17698 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2') 17699 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17700C 17701 IF(N11.LT.0)THEN 17702 WRITE(ICOUT,999) 17703 CALL DPWRST('XXX','BUG ') 17704 WRITE(ICOUT,1201) 17705 1201 FORMAT('***** ERROR FROM THE CHI-SQUARE INDEPENDENCE TEST--') 17706 CALL DPWRST('XXX','BUG ') 17707 WRITE(ICOUT,1203) 17708 1203 FORMAT(' THE VALUE OF THE FIRST PARAMETER (N11 = THE ', 17709 1 'NUMBER OF SUCCESSES') 17710 CALL DPWRST('XXX','BUG ') 17711 WRITE(ICOUT,1204) 17712 1204 FORMAT(' FOR THE FIRST VARIABLE MUST BE NON-NEGATIVE.') 17713 CALL DPWRST('XXX','BUG ') 17714 WRITE(ICOUT,1205)N11 17715 1205 FORMAT(' N11 = ',I8) 17716 CALL DPWRST('XXX','BUG ') 17717 IERROR='YES' 17718 GOTO9000 17719 ENDIF 17720C 17721 IF(N21.LT.0)THEN 17722 WRITE(ICOUT,999) 17723 CALL DPWRST('XXX','BUG ') 17724 WRITE(ICOUT,1201) 17725 CALL DPWRST('XXX','BUG ') 17726 WRITE(ICOUT,1303) 17727 1303 FORMAT(' THE VALUE OF THE SECOND PARAMETER (N21 = THE ', 17728 1 'NUMBER OF FAILURES') 17729 CALL DPWRST('XXX','BUG ') 17730 WRITE(ICOUT,1304) 17731 1304 FORMAT(' FOR THE FIRST VARIABLE MUST BE NON-NEGATIVE.') 17732 CALL DPWRST('XXX','BUG ') 17733 WRITE(ICOUT,1305)N21 17734 1305 FORMAT(' N21 = ',I8) 17735 CALL DPWRST('XXX','BUG ') 17736 IERROR='YES' 17737 GOTO9000 17738 ENDIF 17739C 17740 IF(N12.LT.0)THEN 17741 WRITE(ICOUT,999) 17742 CALL DPWRST('XXX','BUG ') 17743 WRITE(ICOUT,1201) 17744 CALL DPWRST('XXX','BUG ') 17745 WRITE(ICOUT,1403) 17746 1403 FORMAT(' THE VALUE OF THE THIRD PARAMETER (N12 = THE ', 17747 1 'NUMBER OF SUCCESSES') 17748 CALL DPWRST('XXX','BUG ') 17749 WRITE(ICOUT,1404) 17750 1404 FORMAT(' FOR THE SECOND VARIABLE MUST BE NON-NEGATIVE.') 17751 CALL DPWRST('XXX','BUG ') 17752 WRITE(ICOUT,1405)N12 17753 1405 FORMAT(' N12 = ',I8) 17754 CALL DPWRST('XXX','BUG ') 17755 IERROR='YES' 17756 GOTO9000 17757 ENDIF 17758C 17759 IF(N22.LT.0)THEN 17760 WRITE(ICOUT,999) 17761 CALL DPWRST('XXX','BUG ') 17762 WRITE(ICOUT,1201) 17763 CALL DPWRST('XXX','BUG ') 17764 WRITE(ICOUT,1503) 17765 1503 FORMAT(' THE VALUE OF THE FOURTH PARAMETER (N22 = THE ', 17766 1 'NUMBER OF FAILURES') 17767 CALL DPWRST('XXX','BUG ') 17768 WRITE(ICOUT,1504) 17769 1504 FORMAT(' FOR THE SECOND VARIABLE MUST BE NON-NEGATIVE.') 17770 CALL DPWRST('XXX','BUG ') 17771 WRITE(ICOUT,1505)N22 17772 1505 FORMAT(' N22 = ',I8) 17773 CALL DPWRST('XXX','BUG ') 17774 IERROR='YES' 17775 GOTO9000 17776 ENDIF 17777C 17778C ******************************************** 17779C ** STEP 12-- ** 17780C ** COMPUTE THE CHI-SQUARE TEST ** 17781C ******************************************** 17782C 17783C 17784 ROWTOT(1)=DBLE(AN11 + AN12) 17785 ROWTOT(2)=DBLE(AN21 + AN22) 17786 COLTOT(1)=DBLE(AN11 + AN21) 17787 COLTOT(2)=DBLE(AN12 + AN22) 17788 GTOTAL=ROWTOT(1) + ROWTOT(2) 17789 TEMP1(1)=AN11 17790 TEMP1(2)=AN21 17791 TEMP1(3)=AN12 17792 TEMP1(4)=AN22 17793 N1=N11 + N21 17794 N2=N12 + N22 17795 AN1=REAL(N1) 17796 AN2=REAL(N2) 17797C 17798 IFORMT='(2I8,4E15.7)' 17799 IF(IAUXDP.NE.7)THEN 17800 IFORMT=' ' 17801 IF(IAUXDP.LE.9)THEN 17802 IFORMT='(2I8,4Exx.x)' 17803 ITOT=IAUXDP+8 17804 WRITE(IFORMT(8:9),'(I2)')ITOT 17805 WRITE(IFORMT(11:11),'(I1)')IAUXDP 17806 ELSE 17807 IFORMT='(2I8,4Exx.xx)' 17808 ITOT=IAUXDP+8 17809 WRITE(IFORMT(8:9),'(I2)')ITOT 17810 WRITE(IFORMT(11:12),'(I2)')IAUXDP 17811 ENDIF 17812 ENDIF 17813C 17814 IINDX=0 17815 CHISQ1=0.0D0 17816 CHISQ2=0.0D0 17817 DO1600J=1,2 17818 DO1610I=1,2 17819 IINDX=IINDX+1 17820 EXP=ROWTOT(I)*COLTOT(J)/GTOTAL 17821 VALTMP=DBLE(TEMP1(IINDX)) 17822 CHISQ1=CHISQ1 + (VALTMP - EXP)**2/EXP 17823 VALTMP=DABS(DBLE(TEMP1(IINDX)) - EXP) 17824 VALTMP=(VALTMP - 0.5D0)**2/EXP 17825 CHISQ2=CHISQ2 + VALTMP 17826C 17827 WRITE(IOUNI1,IFORMT)I,J,ROWTOT(I),COLTOT(J),EXP,TEMP1(IINDX) 17828C1605 FORMAT(I8,I8,4E15.7) 17829C 17830 1610 CONTINUE 17831 1600 CONTINUE 17832 NROW=2 17833 NCOL=2 17834C 17835 GOTO4000 17836C 17837C ******************************************** 17838C ** STEP 20-- ** 17839C ** VARIABLE CASE ** 17840C ******************************************** 17841C 17842 2000 CONTINUE 17843C 17844C ******************************************** 17845C ** STEP 21-- ** 17846C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 17847C ******************************************** 17848C 17849 ISTEPN='21' 17850 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2') 17851 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17852C 17853 IF(N1.LT.2)THEN 17854 WRITE(ICOUT,999) 17855 CALL DPWRST('XXX','WRIT') 17856 WRITE(ICOUT,1201) 17857 CALL DPWRST('XXX','WRIT') 17858 WRITE(ICOUT,2101) 17859 2101 FORMAT(' THE NUMBER OF OBSERVATIONS FOR VARIABLE 1 ', 17860 1 'IS NON-POSITIVE') 17861 CALL DPWRST('XXX','WRIT') 17862 WRITE(ICOUT,2103)N1 17863 2103 FORMAT('SAMPLE SIZE = ',I8) 17864 CALL DPWRST('XXX','WRIT') 17865 IERROR='YES' 17866 GOTO9000 17867 ENDIF 17868C 17869 IF(N2.LT.2)THEN 17870 WRITE(ICOUT,999) 17871 CALL DPWRST('XXX','WRIT') 17872 WRITE(ICOUT,1201) 17873 CALL DPWRST('XXX','WRIT') 17874 WRITE(ICOUT,2106) 17875 2106 FORMAT(' THE NUMBER OF OBSERVATIONS FOR VARIABLE 2 ', 17876 1 'IS NON-POSITIVE') 17877 CALL DPWRST('XXX','WRIT') 17878 WRITE(ICOUT,2103)N2 17879 CALL DPWRST('XXX','WRIT') 17880 IERROR='YES' 17881 GOTO9000 17882 ENDIF 17883C 17884C ****************************************************** 17885C ** STEP 2.2-- ** 17886C ** DETERMINE THE NUMBER OF DISTINCT VALUES ** 17887C ** FOR THE GROUP VARIABLES (Y1, Y2). ** 17888C ****************************************************** 17889C 17890 ISTEPN='22' 17891 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2') 17892 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17893C 17894 CALL DISTIN(Y1,N1,IWRITE,XIDTEM,NUMSE1,IBUGA3,IERROR) 17895 CALL SORT(XIDTEM,NUMSE1,XIDTEM) 17896 CALL DISTIN(Y2,N2,IWRITE,XIDTE2,NUMSE2,IBUGA3,IERROR) 17897 CALL SORT(XIDTE2,NUMSE2,XIDTE2) 17898C 17899 IF(NUMSE1.LT.1)THEN 17900 WRITE(ICOUT,999) 17901 CALL DPWRST('XXX','BUG ') 17902 WRITE(ICOUT,2201) 17903 2201 FORMAT('***** ERROR IN CHI-SQUARE INDEPENDENCE TEST--') 17904 CALL DPWRST('XXX','BUG ') 17905 WRITE(ICOUT,2202) 17906 2202 FORMAT(' NUMBER OF SETS NUMSE1 = 0 ') 17907 CALL DPWRST('XXX','BUG ') 17908 IERROR='YES' 17909 GOTO9000 17910 ENDIF 17911C 17912 IF(NUMSE2.LT.1)THEN 17913 WRITE(ICOUT,999) 17914 CALL DPWRST('XXX','BUG ') 17915 WRITE(ICOUT,2201) 17916 CALL DPWRST('XXX','BUG ') 17917 WRITE(ICOUT,2204) 17918 2204 FORMAT(' NUMBER OF SETS NUMSE2 = 0 ') 17919 CALL DPWRST('XXX','BUG ') 17920 IERROR='YES' 17921 GOTO9000 17922 ENDIF 17923C 17924 AN1=N1 17925 AN2=N2 17926 ANUMS1=NUMSE1 17927 ANUMS2=NUMSE2 17928C 17929C *********************************************** 17930C ** STEP 2.3-- ** 17931C ** COMPUTE THE CHI-SQUARE STATISTIC ** 17932C *********************************************** 17933C 17934 ISTEPN='23' 17935 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2') 17936 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17937C 17938 IWRITE='OFF' 17939C 17940C COMPUTE COUNTS FOR EACH CELL 17941C 17942 J=0 17943 DO2310ISET1=1,NUMSE1 17944 DO2320ISET2=1,NUMSE2 17945C 17946 K=0 17947 DO2330I=1,N1 17948 IF(XIDTEM(ISET1).EQ.Y1(I).AND.XIDTE2(ISET2).EQ.Y2(I))THEN 17949C 17950 K=K+1 17951 ENDIF 17952 2330 CONTINUE 17953 NTEMP=K 17954 J=J+1 17955 TEMP1(J)=REAL(K) 17956 TEMP2(J)=XIDTEM(ISET1) 17957 TEMP3(J)=XIDTE2(ISET2) 17958C 17959 2320 CONTINUE 17960 2310 CONTINUE 17961 NTEMP2=J 17962C 17963C COMPUTE ROW AND COLUMN TOTALS AND GRAND TOTAL. 17964C 17965 J=0 17966 GTOTAL=0.0D0 17967C 17968 DO2340ISET1=1,NUMSE1 17969 ROWTOT(ISET1)=0.0D0 17970 DO2350ISET2=1,NUMSE2 17971 J=J+1 17972 ROWTOT(ISET1)=ROWTOT(ISET1) + DBLE(TEMP1(J)) 17973 GTOTAL=GTOTAL + DBLE(TEMP1(J)) 17974 2350 CONTINUE 17975C 17976 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2')THEN 17977 WRITE(ICOUT,2352)ISET1,ROWTOT(ISET1) 17978 2352 FORMAT('ISET1,ROWTOT(ISET1)=',I5,1X,G15.7) 17979 CALL DPWRST('XXX','BUG ') 17980 ENDIF 17981 2340 CONTINUE 17982C 17983 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2')THEN 17984 WRITE(ICOUT,2355)GTOTAL 17985 2355 FORMAT('GTOTAL=',G15.7) 17986 CALL DPWRST('XXX','BUG ') 17987 ENDIF 17988C 17989 DO2360ISET2=1,NUMSE2 17990 COLTOT(ISET2)=0.0D0 17991 VALTMP=XIDTE2(ISET2) 17992 DO2370J=1,NTEMP2 17993 IF(TEMP3(J).EQ.XIDTE2(ISET2))THEN 17994 COLTOT(ISET2)=COLTOT(ISET2) + DBLE(TEMP1(J)) 17995 ENDIF 17996 2370 CONTINUE 17997C 17998 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2')THEN 17999 WRITE(ICOUT,2372)ISET2,COLTOT(ISET2) 18000 2372 FORMAT('ISET2,COLTOT(ISET2)=',I5,1X,G15.7) 18001 CALL DPWRST('XXX','BUG ') 18002 ENDIF 18003C 18004 2360 CONTINUE 18005C 18006C NOW COMPUTE THE CHI-SQUARE TEST STATISTIC 18007C 18008 CHISQ1=0.0D0 18009 CHISQ2=0.0D0 18010 J=0 18011C 18012 IFORMT='(2I8,4E15.7)' 18013 IF(IAUXDP.NE.7)THEN 18014 IFORMT=' ' 18015 IF(IAUXDP.LE.9)THEN 18016 IFORMT='(2I8,4Exx.x)' 18017 ITOT=IAUXDP+8 18018 WRITE(IFORMT(8:9),'(I2)')ITOT 18019 WRITE(IFORMT(11:11),'(I1)')IAUXDP 18020 ELSE 18021 IFORMT='(2I8,4Exx.xx)' 18022 ITOT=IAUXDP+8 18023 WRITE(IFORMT(8:9),'(I2)')ITOT 18024 WRITE(IFORMT(11:12),'(I2)')IAUXDP 18025 ENDIF 18026 ENDIF 18027C 18028 DO2380ISET1=1,NUMSE1 18029 DO2390ISET2=1,NUMSE2 18030 J=J+1 18031 EXP=ROWTOT(ISET1)*COLTOT(ISET2)/GTOTAL 18032 VALTMP=(DBLE(TEMP1(J)) - EXP)**2/EXP 18033 CHISQ1=CHISQ1 + VALTMP 18034 VALTMP=DABS(DBLE(TEMP1(J)) - EXP) 18035 VALTMP=(VALTMP - 0.5D0)**2/EXP 18036 CHISQ2=CHISQ2 + VALTMP 18037 WRITE(IOUNI1,IFORMT)ISET1,ISET2,ROWTOT(ISET1),COLTOT(ISET2), 18038 1 EXP,TEMP1(J) 18039C2385 FORMAT(I8,I8,E15.7,E15.7,E15.7,E15.7) 18040 2390 CONTINUE 18041 2380 CONTINUE 18042 NROW=NUMSE1 18043 NCOL=NUMSE2 18044C 18045 GOTO4000 18046C 18047 3000 CONTINUE 18048C 18049C ******************************************** 18050C ** STEP 31-- ** 18051C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 18052C ** ALL TABLE ENTRIES SHOULD BE ** 18053C ** NON-NEGATIVE INTEGERS. NEGATIVE ** 18054C ** VALUES WILL BE FLAGGED AS ERRORS ** 18055C ** WHILE NON-INTEGER VALUES WILL BE ** 18056C ** ROUNDED TO NEAREST INTEGER. ** 18057C ** SINCE WE ARE SCANNING TABLE, COMPUTE ** 18058C ** ROW AND COLUMN TOTALS. ** 18059C ******************************************** 18060C 18061 ISTEPN='31' 18062 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2') 18063 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18064C 18065 IERROR='NO' 18066 NUMERR=0 18067 MAXERR=10 18068C 18069 DO3001I=1,NROW 18070 ROWTOT(I)=0.0D0 18071 3001 CONTINUE 18072 GTOTAL=0.0D0 18073C 18074 DO3010J=1,NCOL 18075 COLTOT(J)=0.0D0 18076 DO3020I=1,NROW 18077 IF(XMAT(I,J).LT.0.0)THEN 18078 NUMERR=NUMERR+1 18079 IF(NUMERR.GT.MAXERR)GOTO9000 18080 IERROR='YES' 18081 WRITE(ICOUT,999) 18082 CALL DPWRST('XXX','WRIT') 18083 WRITE(ICOUT,1201) 18084 CALL DPWRST('XXX','WRIT') 18085 WRITE(ICOUT,3021)I,J 18086 3021 FORMAT(' ROW ',I8,' AND COLUMN ',I8, 18087 1 ' OF THE INPUT TABLE') 18088 CALL DPWRST('XXX','WRIT') 18089 WRITE(ICOUT,3023)XMAT(I,J) 18090 3023 FORMAT(' IS NEGATIVE. THE VALIE IS ',G15.7) 18091 CALL DPWRST('XXX','WRIT') 18092 ELSE 18093 ITEMP=INT(XMAT(I,J)+0.5) 18094 XMAT(I,J)=REAL(ITEMP) 18095 COLTOT(J)=COLTOT(J) + DBLE(XMAT(I,J)) 18096 ROWTOT(I)=ROWTOT(I) + DBLE(XMAT(I,J)) 18097 GTOTAL=GTOTAL + DBLE(XMAT(I,J)) 18098 ENDIF 18099 3020 CONTINUE 18100 3010 CONTINUE 18101C 18102 IF(IERROR.EQ.'YES')GOTO9000 18103C 18104C ******************************************** 18105C ** STEP 32-- ** 18106C ** COMPUTE THE CHI-SQUARE TEST STATISTIC ** 18107C ******************************************** 18108C 18109 ISTEPN='32' 18110 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2') 18111 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18112C 18113 CHISQ1=0.0D0 18114 CHISQ2=0.0D0 18115 ICNT=0 18116C 18117 IFORMT='(2I8,4E15.7)' 18118 IF(IAUXDP.NE.7)THEN 18119 IFORMT=' ' 18120 IF(IAUXDP.LE.9)THEN 18121 IFORMT='(2I8,4Exx.x)' 18122 ITOT=IAUXDP+8 18123 WRITE(IFORMT(8:9),'(I2)')ITOT 18124 WRITE(IFORMT(11:11),'(I1)')IAUXDP 18125 ELSE 18126 IFORMT='(2I8,4Exx.xx)' 18127 ITOT=IAUXDP+8 18128 WRITE(IFORMT(8:9),'(I2)')ITOT 18129 WRITE(IFORMT(11:12),'(I2)')IAUXDP 18130 ENDIF 18131 ENDIF 18132C 18133 DO3110J=1,NCOL 18134 DO3120I=1,NROW 18135 ICNT=ICNT+1 18136 EXP=ROWTOT(I)*COLTOT(J)/GTOTAL 18137 VALTMP=(DBLE(XMAT(I,J)) - EXP)**2/EXP 18138 CHISQ1=CHISQ1 + VALTMP 18139 VALTMP=DABS(DBLE(XMAT(I,J)) - EXP) 18140 VALTMP=(VALTMP - 0.5D0)**2/EXP 18141 CHISQ2=CHISQ2 + VALTMP 18142 WRITE(IOUNI1,IFORMT)I,J,ROWTOT(I),COLTOT(J),EXP,XMAT(I,J) 18143C3115 FORMAT(2I8,4E15.7) 18144 3120 CONTINUE 18145 3110 CONTINUE 18146C 18147 AN1=REAL(GTOTAL) 18148 AN2=REAL(GTOTAL) 18149C 18150 GOTO4000 18151C 18152C ******************************************** 18153C ** STEP 41-- ** 18154C ** FOR ALL INPUT METHODS (SCALAR, ** 18155C ** TWO VARIABLES, TABLE), COMPUTE THE ** 18156C ** CRITIVAL VALUES AND PRINT THE RESULTS.** 18157C ******************************************** 18158C 18159 4000 CONTINUE 18160C 18161 ISTEPN='41' 18162 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2') 18163 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18164C 18165 IOP='CLOS' 18166 CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5, 18167 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 18168 1 IBUGA3,ISUBRO,IERROR) 18169 IF(IERROR.EQ.'YES')GOTO9000 18170C 18171 STATVA=CHISQ1 18172 STATV2=CHISQ2 18173C 18174 IDF=(NROW-1)*(NCOL-1) 18175 CALL CHSCDF(STATVA,IDF,CDF) 18176 CALL CHSCDF(STATV2,IDF,CDF2) 18177C 18178 IWRITE='OFF' 18179C 18180 ICONC1='REJECT' 18181 ICONC2='REJECT' 18182 ICONC3='REJECT' 18183 ICONC4='REJECT' 18184 ICONC5='REJECT' 18185 ICONC6='REJECT' 18186 KCONC1='REJECT' 18187 KCONC2='REJECT' 18188 KCONC3='REJECT' 18189 KCONC4='REJECT' 18190 KCONC5='REJECT' 18191 KCONC6='REJECT' 18192C 18193 ALPHA=0.50 18194 CALL CHSPPF(ALPHA,IDF,CV1) 18195 ALPHA=0.80 18196 CALL CHSPPF(ALPHA,IDF,CV2) 18197 ALPHA=0.90 18198 CALL CHSPPF(ALPHA,IDF,CV3) 18199 ALPHA=0.95 18200 CALL CHSPPF(ALPHA,IDF,CV4) 18201 ALPHA=0.975 18202 CALL CHSPPF(ALPHA,IDF,CV5) 18203 ALPHA=0.99 18204 CALL CHSPPF(ALPHA,IDF,CV6) 18205C 18206 IF(0.000.LE.CDF.AND.CDF.LE.0.50)ICONC1='ACCEPT' 18207 IF(0.000.LE.CDF.AND.CDF.LE.0.80)ICONC2='ACCEPT' 18208 IF(0.000.LE.CDF.AND.CDF.LE.0.90)ICONC3='ACCEPT' 18209 IF(0.000.LE.CDF.AND.CDF.LE.0.95)ICONC4='ACCEPT' 18210 IF(0.000.LE.CDF.AND.CDF.LE.0.975)ICONC5='ACCEPT' 18211 IF(0.000.LE.CDF.AND.CDF.LE.0.99)ICONC6='ACCEPT' 18212C 18213 IF(0.000.LE.CDF2.AND.CDF2.LE.0.50)KCONC1='ACCEPT' 18214 IF(0.000.LE.CDF2.AND.CDF2.LE.0.80)KCONC2='ACCEPT' 18215 IF(0.000.LE.CDF2.AND.CDF2.LE.0.90)KCONC3='ACCEPT' 18216 IF(0.000.LE.CDF2.AND.CDF2.LE.0.95)KCONC4='ACCEPT' 18217 IF(0.000.LE.CDF2.AND.CDF2.LE.0.975)KCONC5='ACCEPT' 18218 IF(0.000.LE.CDF2.AND.CDF2.LE.0.99)KCONC6='ACCEPT' 18219C 18220C ****************************** 18221C ** STEP 42-- ** 18222C ** WRITE OUT EVERYTHING ** 18223C ** FOR CHI-SQUARE TEST ** 18224C ****************************** 18225C 18226 ISTEPN='42' 18227 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CHI2') 18228 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18229C 18230C PRINT SUMMARY STATISTICS TABLE 18231C 18232 IF(IPRINT.EQ.'OFF')GOTO9000 18233C 18234 NUMDIG=7 18235 IF(IFORSW.EQ.'1')NUMDIG=1 18236 IF(IFORSW.EQ.'2')NUMDIG=2 18237 IF(IFORSW.EQ.'3')NUMDIG=3 18238 IF(IFORSW.EQ.'4')NUMDIG=4 18239 IF(IFORSW.EQ.'5')NUMDIG=5 18240 IF(IFORSW.EQ.'6')NUMDIG=6 18241 IF(IFORSW.EQ.'7')NUMDIG=7 18242 IF(IFORSW.EQ.'8')NUMDIG=8 18243 IF(IFORSW.EQ.'9')NUMDIG=9 18244 IF(IFORSW.EQ.'0')NUMDIG=0 18245 IF(IFORSW.EQ.'E')NUMDIG=-2 18246 IF(IFORSW.EQ.'-2')NUMDIG=-2 18247 IF(IFORSW.EQ.'-3')NUMDIG=-3 18248 IF(IFORSW.EQ.'-4')NUMDIG=-4 18249 IF(IFORSW.EQ.'-5')NUMDIG=-5 18250 IF(IFORSW.EQ.'-6')NUMDIG=-6 18251 IF(IFORSW.EQ.'-7')NUMDIG=-7 18252 IF(IFORSW.EQ.'-8')NUMDIG=-8 18253 IF(IFORSW.EQ.'-9')NUMDIG=-9 18254C 18255 ITITLE='Chi-Square Test for Independence (RxC Table)' 18256 NCTITL=44 18257 ITITLZ=' ' 18258 NCTITZ=0 18259C 18260 ICNT=0 18261 ICNT=ICNT+1 18262 ITEXT(ICNT)=' ' 18263 NCTEXT(ICNT)=0 18264 AVALUE(ICNT)=0.0 18265 IDIGIT(ICNT)=-1 18266 ICNT=ICNT+1 18267 ITEXT(ICNT)='H0: The Two Variables Are Independent' 18268 NCTEXT(ICNT)=38 18269 AVALUE(ICNT)=0.0 18270 IDIGIT(ICNT)=-1 18271 ICNT=ICNT+1 18272 ITEXT(ICNT)='Ha: The Two Variables Are Not Independent' 18273 NCTEXT(ICNT)=42 18274 AVALUE(ICNT)=0.0 18275 IDIGIT(ICNT)=-1 18276 ICNT=ICNT+1 18277 ITEXT(ICNT)=' ' 18278 NCTEXT(ICNT)=0 18279 AVALUE(ICNT)=0.0 18280 IDIGIT(ICNT)=-1 18281C 18282 ICNT=ICNT+1 18283 ITEXT(ICNT)='Sample 1:' 18284 NCTEXT(ICNT)=9 18285 AVALUE(ICNT)=0.0 18286 IDIGIT(ICNT)=-1 18287 ICNT=ICNT+1 18288 ITEXT(ICNT)='Number of Observations:' 18289 NCTEXT(ICNT)=23 18290 AVALUE(ICNT)=AN1 18291 IDIGIT(ICNT)=0 18292 ICNT=ICNT+1 18293 ITEXT(ICNT)='Number of Levels (Rows):' 18294 NCTEXT(ICNT)=24 18295 AVALUE(ICNT)=REAL(NROW) 18296 IDIGIT(ICNT)=0 18297 ICNT=ICNT+1 18298 ITEXT(ICNT)=' ' 18299 NCTEXT(ICNT)=0 18300 AVALUE(ICNT)=0.0 18301 IDIGIT(ICNT)=-1 18302C 18303 ICNT=ICNT+1 18304 ITEXT(ICNT)='Sample 2:' 18305 NCTEXT(ICNT)=9 18306 AVALUE(ICNT)=0.0 18307 IDIGIT(ICNT)=-1 18308 ICNT=ICNT+1 18309 ITEXT(ICNT)='Number of Observations:' 18310 NCTEXT(ICNT)=23 18311 AVALUE(ICNT)=AN2 18312 IDIGIT(ICNT)=0 18313 ICNT=ICNT+1 18314 ITEXT(ICNT)='Number of Levels (Columns):' 18315 NCTEXT(ICNT)=27 18316 AVALUE(ICNT)=REAL(NCOL) 18317 IDIGIT(ICNT)=0 18318 ICNT=ICNT+1 18319 ITEXT(ICNT)=' ' 18320 NCTEXT(ICNT)=0 18321 AVALUE(ICNT)=0.0 18322 IDIGIT(ICNT)=-1 18323C 18324 ICNT=ICNT+1 18325 ITEXT(ICNT)='Without Yates Continuity Correction:' 18326 NCTEXT(ICNT)=36 18327 AVALUE(ICNT)=0.0 18328 IDIGIT(ICNT)=-1 18329 ICNT=ICNT+1 18330 ITEXT(ICNT)='Chi-Square Test Statistic:' 18331 NCTEXT(ICNT)=26 18332 AVALUE(ICNT)=STATVA 18333 IDIGIT(ICNT)=NUMDIG 18334 ICNT=ICNT+1 18335 ITEXT(ICNT)='Degrees of Freedom:' 18336 NCTEXT(ICNT)=19 18337 AVALUE(ICNT)=REAL(IDF) 18338 IDIGIT(ICNT)=0 18339 ICNT=ICNT+1 18340 ITEXT(ICNT)='CDF Value of Test Statistic:' 18341 NCTEXT(ICNT)=28 18342 AVALUE(ICNT)=CDF 18343 IDIGIT(ICNT)=NUMDIG 18344 ICNT=ICNT+1 18345 ITEXT(ICNT)=' ' 18346 NCTEXT(ICNT)=0 18347 AVALUE(ICNT)=0.0 18348 IDIGIT(ICNT)=-1 18349C 18350 ICNT=ICNT+1 18351 ITEXT(ICNT)='With Yates Continuity Correction:' 18352 NCTEXT(ICNT)=33 18353 AVALUE(ICNT)=0.0 18354 IDIGIT(ICNT)=-1 18355 ICNT=ICNT+1 18356 ITEXT(ICNT)='Chi-Square Test Statistic:' 18357 NCTEXT(ICNT)=26 18358 AVALUE(ICNT)=STATV2 18359 IDIGIT(ICNT)=NUMDIG 18360 ICNT=ICNT+1 18361 ITEXT(ICNT)='Degrees of Freedom:' 18362 NCTEXT(ICNT)=19 18363 AVALUE(ICNT)=REAL(IDF) 18364 IDIGIT(ICNT)=0 18365 ICNT=ICNT+1 18366 ITEXT(ICNT)='CDF Value of Test Statistic:' 18367 NCTEXT(ICNT)=28 18368 AVALUE(ICNT)=CDF2 18369 IDIGIT(ICNT)=NUMDIG 18370 ICNT=ICNT+1 18371 ITEXT(ICNT)=' ' 18372 NCTEXT(ICNT)=0 18373 AVALUE(ICNT)=0.0 18374 IDIGIT(ICNT)=-1 18375C 18376 NUMROW=ICNT 18377 DO7310I=1,NUMROW 18378 NTOT(I)=15 18379 7310 CONTINUE 18380C 18381 IFRST=.TRUE. 18382 ILAST=.TRUE. 18383 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT, 18384 1 NCTEXT,AVALUE,IDIGIT, 18385 1 NTOT,NUMROW, 18386 1 ICAPSW,ICAPTY,ILAST,IFRST, 18387 1 ISUBRO,IBUGA3,IERROR) 18388C 18389 ITITLE(1:25)='Without Yates Correction:' 18390 NCTITL=25 18391 ITITL9=' ' 18392 NCTIT9=0 18393C 18394 ITITL2(1,1)=' ' 18395 NCTIT2(1,1)=0 18396 ITITL2(2,1)='Null' 18397 NCTIT2(2,1)=4 18398 ITITL2(3,1)='Hypothesis' 18399 NCTIT2(3,1)=10 18400 ITITL2(1,2)=' ' 18401 NCTIT2(1,2)=0 18402 ITITL2(2,2)='Confidence' 18403 NCTIT2(2,2)=10 18404 ITITL2(3,2)='Level' 18405 NCTIT2(3,2)=5 18406 ITITL2(1,3)=' ' 18407 NCTIT2(1,3)=0 18408 ITITL2(2,3)='Critical' 18409 NCTIT2(2,3)=8 18410 ITITL2(3,3)='Value' 18411 NCTIT2(3,3)=5 18412 ITITL2(1,4)='Null Hypothesis' 18413 NCTIT2(1,4)=15 18414 ITITL2(2,4)='Acceptance' 18415 NCTIT2(2,4)=10 18416 ITITL2(3,4)='Interval' 18417 NCTIT2(3,4)=8 18418 ITITL2(1,5)='Null' 18419 NCTIT2(1,5)=4 18420 ITITL2(2,5)='Hypothesis' 18421 NCTIT2(2,5)=10 18422 ITITL2(3,5)='Conclusion' 18423 NCTIT2(3,5)=10 18424C 18425 NMAX=0 18426 NUMCOL=5 18427 DO7410I=1,NUMCOL 18428 VALIGN(I)='b' 18429 ALIGN(I)='r' 18430 NTOT(I)=15 18431 NMAX=NMAX+NTOT(I) 18432 IF(I.EQ.3)THEN 18433 ITYPCO(I)='NUME' 18434 ELSE 18435 ITYPCO(I)='ALPH' 18436 ENDIF 18437 IF(I.EQ.2)THEN 18438 IDIGIT(I)=1 18439 ELSEIF(I.EQ.3)THEN 18440 IDIGIT(I)=2 18441 ELSE 18442 IDIGIT(I)=NUMDIG 18443 ENDIF 18444 IWHTML(1)=150 18445 IWHTML(2)=125 18446 IWHTML(3)=125 18447 IWHTML(4)=150 18448 IWHTML(5)=150 18449 IINC=1600 18450 IINC2=1400 18451 IINC3=2200 18452 IWRTF(1)=IINC 18453 IWRTF(2)=IWRTF(1)+IINC 18454 IWRTF(3)=IWRTF(2)+IINC2 18455 IWRTF(4)=IWRTF(3)+IINC3 18456 IWRTF(5)=IWRTF(4)+IINC2 18457C 18458 DO7489J=1,NUMALP 18459 NCVALU(J,1)=0 18460 NCVALU(J,2)=0 18461 NCVALU(J,3)=0 18462 NCVALU(J,4)=0 18463 NCVALU(J,5)=0 18464 IVALUE(J,1)=' ' 18465 IVALUE(J,2)=' ' 18466 IVALUE(J,3)=' ' 18467 IVALUE(J,4)=' ' 18468 IVALUE(J,5)=' ' 18469 IF(J.EQ.1)THEN 18470 IVALUE(J,2)='50.0%' 18471 NCVALU(J,2)=5 18472 AMAT(J,3)=CV1 18473 IVALUE(J,5)(1:6)=ICONC1(1:6) 18474 NCVALU(J,5)=6 18475 IVALUE(J,4)='(0,0.500)' 18476 NCVALU(J,4)=9 18477 ELSEIF(J.EQ.2)THEN 18478 IVALUE(J,2)='80.0%' 18479 NCVALU(J,2)=5 18480 AMAT(J,3)=CV2 18481 IVALUE(J,5)(1:6)=ICONC2(1:6) 18482 NCVALU(J,5)=6 18483 IVALUE(J,4)='(0,0.800)' 18484 NCVALU(J,4)=9 18485 ELSEIF(J.EQ.3)THEN 18486 IVALUE(J,2)='90.0%' 18487 NCVALU(J,2)=5 18488 AMAT(J,3)=CV3 18489 IVALUE(J,5)(1:6)=ICONC3(1:6) 18490 NCVALU(J,5)=6 18491 IVALUE(J,4)='(0,0.900)' 18492 NCVALU(J,4)=9 18493 ELSEIF(J.EQ.4)THEN 18494 IVALUE(J,2)='95.0%' 18495 NCVALU(J,2)=5 18496 AMAT(J,3)=CV4 18497 IVALUE(J,5)(1:6)=ICONC4(1:6) 18498 NCVALU(J,5)=6 18499 IVALUE(J,4)='(0,0.950)' 18500 NCVALU(J,4)=9 18501 ELSEIF(J.EQ.5)THEN 18502 IVALUE(J,2)='97.5%' 18503 NCVALU(J,2)=5 18504 AMAT(J,3)=CV5 18505 IVALUE(J,5)(1:6)=ICONC5(1:6) 18506 NCVALU(J,5)=6 18507 IVALUE(J,4)='(0,0.975)' 18508 NCVALU(J,4)=9 18509 ELSEIF(J.EQ.6)THEN 18510 IVALUE(J,2)='99.0%' 18511 NCVALU(J,2)=5 18512 AMAT(J,3)=CV6 18513 IVALUE(J,5)(1:6)=ICONC6(1:6) 18514 NCVALU(J,5)=6 18515 IVALUE(J,4)='(0,0.990)' 18516 NCVALU(J,4)=9 18517 ENDIF 18518 AMAT(J,1)=0.0 18519 AMAT(J,2)=0.0 18520 AMAT(J,4)=0.0 18521 AMAT(J,5)=0.0 18522 IVALUE(J,1)='Independent' 18523 NCVALU(J,1)=11 18524 7489 CONTINUE 18525C 18526 7410 CONTINUE 18527C 18528 ICNT=NUMALP 18529 NUMLIN=3 18530 NUMCOL=5 18531 IFRST=.TRUE. 18532 ILAST=.TRUE. 18533 IFLAGS=.TRUE. 18534 IFLAGE=.TRUE. 18535 CALL DPDTA5(ITITLE,NCTITL, 18536 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 18537 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 18538 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 18539 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 18540 1 ICAPSW,ICAPTY,IFRST,ILAST, 18541 1 IFLAGS,IFLAGE, 18542 1 ISUBRO,IBUGA3,IERROR) 18543C 18544 ITITLE(1:30)='With Yates Bias Correction:' 18545 NCTITL=30 18546C 18547 NUMCOL=5 18548 DO7510I=1,NUMCOL 18549C 18550 DO7589J=1,NUMALP 18551 IF(J.EQ.1)THEN 18552 IVALUE(J,5)(1:6)=KCONC1(1:6) 18553 NCVALU(J,5)=6 18554 ELSEIF(J.EQ.2)THEN 18555 IVALUE(J,5)(1:6)=KCONC2(1:6) 18556 NCVALU(J,5)=6 18557 ELSEIF(J.EQ.3)THEN 18558 IVALUE(J,5)(1:6)=KCONC3(1:6) 18559 NCVALU(J,5)=6 18560 ELSEIF(J.EQ.4)THEN 18561 IVALUE(J,5)(1:6)=KCONC4(1:6) 18562 NCVALU(J,5)=6 18563 ELSEIF(J.EQ.5)THEN 18564 IVALUE(J,5)(1:6)=KCONC5(1:6) 18565 NCVALU(J,5)=6 18566 ELSEIF(J.EQ.6)THEN 18567 IVALUE(J,5)(1:6)=KCONC6(1:6) 18568 NCVALU(J,5)=6 18569 ENDIF 18570 7589 CONTINUE 18571C 18572 7510 CONTINUE 18573C 18574 ICNT=NUMALP 18575 NUMLIN=3 18576 NUMCOL=5 18577 IFRST=.TRUE. 18578 ILAST=.TRUE. 18579 IFLAGS=.TRUE. 18580 IFLAGE=.TRUE. 18581 CALL DPDTA5(ITITLE,NCTITL, 18582 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 18583 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 18584 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 18585 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 18586 1 ICAPSW,ICAPTY,IFRST,ILAST, 18587 1 IFLAGS,IFLAGE, 18588 1 ISUBRO,IBUGA3,IERROR) 18589C 18590C ***************** 18591C ** STEP 90-- ** 18592C ** EXIT ** 18593C ***************** 18594C 18595 9000 CONTINUE 18596 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CHI2')THEN 18597 WRITE(ICOUT,999) 18598 CALL DPWRST('XXX','WRIT') 18599 WRITE(ICOUT,9011) 18600 9011 FORMAT('***** AT THE END OF DPCHI2--') 18601 CALL DPWRST('XXX','WRIT') 18602 WRITE(ICOUT,9013)AN11,AN21,AN12,AN22 18603 9013 FORMAT('AN11,AN21,AN12,AN22=',4G15.7) 18604 CALL DPWRST('XXX','WRIT') 18605 WRITE(ICOUT,9015)AN1,AN2 18606 9015 FORMAT('AN1,AN2=',2G15.7) 18607 CALL DPWRST('XXX','WRIT') 18608 WRITE(ICOUT,9017)N11,N21,N12,N22 18609 9017 FORMAT('N11,N21,N12,N22=',4I8) 18610 CALL DPWRST('XXX','WRIT') 18611 ENDIF 18612C 18613 RETURN 18614 END 18615 SUBROUTINE DPCHWI(IHARG,IARGT,ARG,NUMARG, 18616 1 PDEFWI, 18617 1 MAXCHA, 18618 1 PCHAWI,PCHAHG, 18619 1 IFOUND,IERROR) 18620C 18621C PURPOSE--DEFINE PLOT CHARACTER WIDTHS FOR USE IN MULTI-TRACE PLOTS. 18622C THE WIDTH FOR THE CHARACTER FOR THE I-TH TRACE 18623C WILL BE PLACED 18624C IN THE I-TH ELEMENT OF THE FLOATING POINT 18625C VECTOR PCHAWI(.). 18626C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 18627C --IARGT (A HOLLERITH VECTOR) 18628C --ARG (A HOLLERITH VECTOR) 18629C --NUMARG 18630C --PDEFWI 18631C --MAXCHA 18632C OUTPUT ARGUMENTS--PCHAWI (A FLOATING POINT VECTOR 18633C WHOSE I-TH ELEMENT IS THE WIDTH (= WIDTHT) 18634C FOR THE CHARACTER 18635C ASSIGNED TO THE I-TH TRACE IN 18636C A MULTI-TRACE PLOT. 18637C --PCHAWI = CHARACTER WIDTH 18638C --PCHAHG = HORIZONTAL GAP BETWEEN CHARACTERS 18639C --IFOUND ('YES' OR 'NO' ) 18640C --IERROR ('YES' OR 'NO' ) 18641C WRITTEN BY--JAMES J. FILLIBEN 18642C STATISTICAL ENGINEERING DIVISION 18643C INFORMATION TECHNOLOGY LABORATORY 18644C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 18645C GAITHERSBURG, MD 20899-8980 18646C PHONE--301-975-2899 18647C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 18648C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 18649C LANGUAGE--ANSI FORTRAN (1977) 18650C VERSION NUMBER--82/7 18651C ORIGINAL VERSION--DECEMBER 1977. 18652C UPDATED --SEPTEMBER 1980. 18653C UPDATED --MARCH 1982. 18654C UPDATED --MAY 1982. 18655C 18656C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 18657C 18658 CHARACTER*4 IHARG 18659 CHARACTER*4 IARGT 18660 CHARACTER*4 IFOUND 18661 CHARACTER*4 IERROR 18662C 18663C--------------------------------------------------------------------- 18664C 18665 DIMENSION IHARG(*) 18666 DIMENSION IARGT(*) 18667 DIMENSION ARG(*) 18668C 18669 DIMENSION PCHAWI(*) 18670 DIMENSION PCHAHG(*) 18671C 18672C--------------------------------------------------------------------- 18673C 18674 INCLUDE 'DPCOP2.INC' 18675C 18676C-----START POINT----------------------------------------------------- 18677C 18678 IFOUND='NO' 18679 IERROR='NO' 18680C 18681 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'WIDTH'.AND. 18682 1IHARG(2).EQ.'BOX'.AND.IHARG(3).EQ.'PLOT')GOTO2110 18683 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'WIDT'.AND. 18684 1IHARG(2).EQ.'BOX'.AND.IHARG(3).EQ.'PLOT')GOTO2110 18685 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'WIDTH'.AND. 18686 1IHARG(3).EQ.'BOX'.AND.IHARG(4).EQ.'PLOT')GOTO2110 18687 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'WIDT'.AND. 18688 1IHARG(3).EQ.'BOX'.AND.IHARG(4).EQ.'PLOT')GOTO2110 18689C 18690 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'WIDTH')GOTO1160 18691 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'WIDT')GOTO1160 18692 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'WIDTH')GOTO1105 18693 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'WIDT')GOTO1105 18694 GOTO2199 18695C 18696 1105 CONTINUE 18697 IF(IHARG(NUMARG).EQ.'ON')GOTO1110 18698 IF(IHARG(NUMARG).EQ.'OFF')GOTO1110 18699 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 18700 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 18701C 18702 IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160 18703 IF(NUMARG.EQ.2)GOTO1120 18704 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130 18705 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140 18706C 18707 GOTO1150 18708C 18709 1110 CONTINUE 18710 DO1115I=1,MAXCHA 18711 PCHAWI(I)=PDEFWI 18712 1115 CONTINUE 18713C 18714 IF(IFEEDB.EQ.'OFF')GOTO1119 18715 WRITE(ICOUT,999) 18716 999 FORMAT(1X) 18717 CALL DPWRST('XXX','BUG ') 18718 I=1 18719 WRITE(ICOUT,1116)PCHAWI(I) 18720 1116 FORMAT('ALL CHARACTER WIDTHS HAVE JUST BEEN SET TO ', 18721 1E15.7) 18722 CALL DPWRST('XXX','BUG ') 18723 1119 CONTINUE 18724 GOTO2190 18725C 18726 1120 CONTINUE 18727 I=1 18728 IF(IARGT(2).NE.'NUMB')GOTO1180 18729 PCHAWI(1)=ARG(2) 18730C 18731 IF(IFEEDB.EQ.'OFF')GOTO1129 18732 WRITE(ICOUT,999) 18733 CALL DPWRST('XXX','BUG ') 18734 I=1 18735 WRITE(ICOUT,1126)I,PCHAWI(I) 18736 1126 FORMAT('THE WIDTH FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ', 18737 1E15.7) 18738 CALL DPWRST('XXX','BUG ') 18739 1129 CONTINUE 18740 GOTO2190 18741C 18742 1130 CONTINUE 18743 I=1 18744 IF(IARGT(3).NE.'NUMB')GOTO1180 18745 DO1135I=1,MAXCHA 18746 PCHAWI(I)=ARG(3) 18747 1135 CONTINUE 18748C 18749 IF(IFEEDB.EQ.'OFF')GOTO1139 18750 WRITE(ICOUT,999) 18751 CALL DPWRST('XXX','BUG ') 18752 I=1 18753 WRITE(ICOUT,1116)PCHAWI(I) 18754 CALL DPWRST('XXX','BUG ') 18755 1139 CONTINUE 18756 GOTO2190 18757C 18758 1140 CONTINUE 18759 I=1 18760 IF(IARGT(2).NE.'NUMB')GOTO1180 18761 DO1145I=1,MAXCHA 18762 PCHAWI(I)=ARG(2) 18763 1145 CONTINUE 18764C 18765 IF(IFEEDB.EQ.'OFF')GOTO1149 18766 WRITE(ICOUT,999) 18767 CALL DPWRST('XXX','BUG ') 18768 I=1 18769 WRITE(ICOUT,1116)PCHAWI(I) 18770 CALL DPWRST('XXX','BUG ') 18771 1149 CONTINUE 18772 GOTO2190 18773C 18774 1150 CONTINUE 18775 IMAX=NUMARG-1 18776 IF(MAXCHA.LT.IMAX)IMAX=MAXCHA 18777 DO1155I=1,IMAX 18778 IP1=I+1 18779 IF(IARGT(IP1).NE.'NUMB')GOTO1180 18780 PCHAWI(I)=ARG(IP1) 18781 1155 CONTINUE 18782C 18783 IF(IFEEDB.EQ.'OFF')GOTO1159 18784 WRITE(ICOUT,999) 18785 CALL DPWRST('XXX','BUG ') 18786 DO1156I=1,IMAX 18787 WRITE(ICOUT,1126)I,PCHAWI(I) 18788 CALL DPWRST('XXX','BUG ') 18789 1156 CONTINUE 18790 1159 CONTINUE 18791 GOTO2190 18792C 18793 1160 CONTINUE 18794 DO1165I=1,MAXCHA 18795 PCHAWI(I)=PDEFWI 18796 1165 CONTINUE 18797C 18798 IF(IFEEDB.EQ.'OFF')GOTO1169 18799 WRITE(ICOUT,999) 18800 CALL DPWRST('XXX','BUG ') 18801 I=1 18802 WRITE(ICOUT,1116)PCHAWI(I) 18803 CALL DPWRST('XXX','BUG ') 18804 1169 CONTINUE 18805 GOTO2190 18806C 18807 1180 CONTINUE 18808 IERROR='YES' 18809 WRITE(ICOUT,999) 18810 CALL DPWRST('XXX','BUG ') 18811 WRITE(ICOUT,1181) 18812 1181 FORMAT('***** ERROR IN DPCHWI--') 18813 CALL DPWRST('XXX','BUG ') 18814 WRITE(ICOUT,1182) 18815 1182 FORMAT('CHARACTER WIDTHS MUST BE NUMERIC;') 18816 CALL DPWRST('XXX','BUG ') 18817 WRITE(ICOUT,1183) 18818 1183 FORMAT('HOWEVER, THE SPECIFIED CHARACTER WIDTH') 18819 CALL DPWRST('XXX','BUG ') 18820 WRITE(ICOUT,1184)I 18821 1184 FORMAT('FOR CHARACTER ',I6,' WAS NON-NUMERIC.') 18822 CALL DPWRST('XXX','BUG ') 18823 GOTO2199 18824C 18825 2110 CONTINUE 18826 IMAX=24 18827 PCHAWI(1)=1.0 18828 PCHAWI(2)=1.0 18829 PCHAWI(3)=1.0 18830 PCHAWI(4)=1.0 18831 PCHAWI(5)=1.0 18832 PCHAWI(6)=1.0 18833 PCHAWI(7)=1.0 18834 PCHAWI(8)=1.0 18835 PCHAWI(9)=1.0 18836 PCHAWI(10)=1.0 18837 PCHAWI(11)=1.0 18838 PCHAWI(12)=1.0 18839 PCHAWI(13)=1.0 18840 PCHAWI(14)=1.0 18841 PCHAWI(15)=1.0 18842 PCHAWI(16)=1.0 18843 PCHAWI(17)=1.0 18844 PCHAWI(18)=1.0 18845 PCHAWI(19)=1.0 18846 PCHAWI(20)=1.0 18847 PCHAWI(21)=1.5 18848 PCHAWI(22)=1.0 18849 PCHAWI(23)=1.0 18850 PCHAWI(24)=1.5 18851 GOTO2170 18852C 18853 2170 CONTINUE 18854 IF(IFEEDB.EQ.'OFF')GOTO2179 18855 WRITE(ICOUT,999) 18856 CALL DPWRST('XXX','BUG ') 18857 DO2175I=1,IMAX 18858 WRITE(ICOUT,2176)I,PCHAWI(I) 18859 2176 FORMAT('THE WIDTH FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ', 18860 1E15.7) 18861 CALL DPWRST('XXX','BUG ') 18862 2175 CONTINUE 18863 2179 CONTINUE 18864 GOTO2180 18865C 18866 2180 CONTINUE 18867 IFOUND='YES' 18868 GOTO2190 18869C 18870 2190 CONTINUE 18871 IFOUND='YES' 18872 DO2191I=1,MAXCHA 18873 PCHAHG(I)=PCHAWI(I)*0.25 18874 2191 CONTINUE 18875C 18876 2199 CONTINUE 18877 RETURN 18878 END 18879 SUBROUTINE DPCMAP(IHARG,NUMARG,IDCMAP,ICHMAP,IFOUND,IERROR) 18880C 18881C PURPOSE--DEFINE PLOT CHARACTER MAPPING 18882C (BY RANK OR BY EXACT) 18883C WHICH LINKS TRACE ID AND CHARACTER 18884C (THE CURRENT DEFAULT IS BY RANK). 18885C EXAMPLE--IF HAVE DATA: X: 1 1 2 2 3 3 18886C Y: 1 2 3 4 5 6 18887C TAG: 1 1 3 3 5 5 18888C AND CHARACTERS 1 2 3 4 5 18889C AND DESIRE TO HAVE THE TRACES SHOW 1 3 AND 5 18890C THEN CURRENTLY BY DEFAULT WOULD GET 18891C TRACES SHOWING 1 2 3 (SINCE MAP VIA RANK) 18892C BUT IF ENTER CHARACTER MAP EXACT 18893C THEN WOULD GET TRACES SHOWING 1 3 5 (AS DESIRED) 18894C COMMAND EXAMPLE--CHARACTER MAP RANK (= DEFAULT) 18895C CHARACTER MAP EXACT 18896C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 18897C --NUMARG 18898C --IDCMAP 18899C OUTPUT ARGUMENTS--ICHMAP (A CHARACTER VARIABLE 18900C WHICH DEFINES THE MAP 18901C (RANK OR EXAC) 18902C --IFOUND ('YES' OR 'NO' ) 18903C --IERROR ('YES' OR 'NO' ) 18904C WRITTEN BY--JAMES J. FILLIBEN 18905C STATISTICAL ENGINEERING DIVISION 18906C INFORMATION TECHNOLOGY LABORATORY 18907C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 18908C GAITHERSBURG, MD 20899-8980 18909C PHONE--301-975-2855 18910C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 18911C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 18912C LANGUAGE--ANSI FORTRAN (1977) 18913C VERSION NUMBER--94/12 18914C ORIGINAL VERSION--DECEMBER 1994. 18915C 18916C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 18917C 18918 CHARACTER*4 IHARG 18919 CHARACTER*4 IDCMAP 18920 CHARACTER*4 ICHMAP 18921 CHARACTER*4 IFOUND 18922 CHARACTER*4 IERROR 18923C 18924C--------------------------------------------------------------------- 18925C 18926 DIMENSION IHARG(*) 18927C 18928C--------------------------------------------------------------------- 18929C 18930 INCLUDE 'DPCOP2.INC' 18931C 18932C-----START POINT----------------------------------------------------- 18933C 18934 IFOUND='NO' 18935 IERROR='NO' 18936C 18937 IF(NUMARG.EQ.1)THEN 18938 ICHMAP=IDCMAP 18939 GOTO1150 18940 ENDIF 18941C 18942 IF(NUMARG.GE.2)THEN 18943 IF(IHARG(NUMARG).EQ.'ON'.OR. 18944 1 IHARG(NUMARG).EQ.'OFF'.OR. 18945 1 IHARG(NUMARG).EQ.'AUTO'.OR. 18946 1 IHARG(NUMARG).EQ.'DEFA')THEN 18947 ICHMAP=IDCMAP 18948 GOTO1150 18949 ELSE IF(IHARG(NUMARG).EQ.'EXAC'.OR. 18950 1 IHARG(NUMARG).EQ.'1TO1')THEN 18951 ICHMAP='EXAC' 18952 GOTO1150 18953 ELSE IF(IHARG(NUMARG).EQ.'?')THEN 18954 GOTO1160 18955 ELSE 18956 ICHMAP=IHARG(2) 18957 GOTO1150 18958 ENDIF 18959 ENDIF 18960C 18961 1150 CONTINUE 18962 IF(IFEEDB.EQ.'ON')THEN 18963 WRITE(ICOUT,999) 18964 999 FORMAT(1X) 18965 CALL DPWRST('XXX','BUG ') 18966 WRITE(ICOUT,1151)ICHMAP 18967 1151 FORMAT('THE CHARACTER MAPPING HAS JUST BEEN SET TO ', 18968 1 A4) 18969 CALL DPWRST('XXX','BUG ') 18970 ENDIF 18971 IFOUND='YES' 18972 GOTO9000 18973C 18974 1160 CONTINUE 18975 WRITE(ICOUT,999) 18976 CALL DPWRST('XXX','BUG ') 18977 WRITE(ICOUT,1161) 18978 1161 FORMAT('CHARACTER MAPPING HAS 2 POSSIBLE SETTINGS:') 18979 CALL DPWRST('XXX','BUG ') 18980 WRITE(ICOUT,1162) 18981 1162 FORMAT(' RANK AND EXACT') 18982 CALL DPWRST('XXX','BUG ') 18983 WRITE(ICOUT,1163)ICHMAP 18984 1163 FORMAT('THE CURRENT CHARACTER MAPPING IS ',A4) 18985 CALL DPWRST('XXX','BUG ') 18986 IFOUND='YES' 18987 GOTO9000 18988C 18989 9000 CONTINUE 18990 RETURN 18991 END 18992 SUBROUTINE DPCONC(IHARG,NUMARG, 18993 1IDEFCC, 18994 1ICONCH, 18995 1IBUGS2,IFOUND,IERROR) 18996C 18997C PURPOSE--DEFINE THE CONTINUE CHARACTOR WHICH MAY 18998C BE USED TO CONTINUE A COMMAND TO A SECOND 18999C LINE (NO MORE THAN 2 LINES ALLOWED) 19000C ABOUT THE ONLY PLACE THIS IS NECCESSARY 19001C IN DATAPLOT IS IN ENTERING TITLES, ESPECIALLY 19002C IF MANY SHIFTS ARE INCLUDED FOR UPPER, LOWER CASE 19003C AND SPECIAL SYMBOLS 19004C 19005C THE CONTINUE CHARACTER CAN BE UP TO 4 CHARACTERS LONG 19006C 19007C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 19008C --NUMARG (AN INTEGER VARIABLE) 19009C --IDEFCC (A CHARACTER VARIABLE) 19010C --IBUGS2 (A CHARACTER VARIABLE) 19011C OUTPUT ARGUMENTS--ICONCH (A CHARACTER VARIABLE) 19012C --IFOUND ('YES' OR 'NO' ) 19013C --IERROR ('YES' OR 'NO' ) 19014C WRITTEN BY--ALAN HECKERT 19015C COMPUTER SERVICES DIVISION 19016C INFORMATION TECHNOLOGY LABORATORY 19017C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 19018C GAITHERSBURG, MD 20899-8980 19019C PHONE--301-975-2899 19020C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 19021C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 19022C LANGUAGE--ANSI FORTRAN (1977) 19023C VERSION NUMBER--82/7 19024C ORIGINAL VERSION--NOVEMBER 1980. 19025C UPDATED --MAY 1982. 19026C 19027C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19028C 19029 CHARACTER*4 IHARG 19030 CHARACTER*4 IDEFCC 19031 CHARACTER*4 ICONCH 19032 CHARACTER*4 IBUGS2 19033 CHARACTER*4 IFOUND 19034 CHARACTER*4 IERROR 19035C 19036 CHARACTER*4 IHOLD 19037C 19038C--------------------------------------------------------------------- 19039C 19040 DIMENSION IHARG(*) 19041C 19042C--------------------------------------------------------------------- 19043C 19044 INCLUDE 'DPCOP2.INC' 19045C 19046C-----START POINT----------------------------------------------------- 19047C 19048 IF(IBUGS2.EQ.'OFF')GOTO90 19049 WRITE(ICOUT,999) 19050 999 FORMAT(1X) 19051 CALL DPWRST('XXX','BUG ') 19052 WRITE(ICOUT,51) 19053 51 FORMAT('***** AT THE BEGINNING OF DPCONC--') 19054 CALL DPWRST('XXX','BUG ') 19055 WRITE(ICOUT,53)IDEFCC 19056 53 FORMAT('IDEFCC = ',A4) 19057 CALL DPWRST('XXX','BUG ') 19058 WRITE(ICOUT,54)NUMARG 19059 54 FORMAT('NUMARG = ',I8) 19060 CALL DPWRST('XXX','BUG ') 19061 DO55I=1,NUMARG 19062 WRITE(ICOUT,56)I,IHARG(I) 19063 56 FORMAT('I,IHARG(I) = ',I8,2X,A4) 19064 CALL DPWRST('XXX','BUG ') 19065 55 CONTINUE 19066 90 CONTINUE 19067C 19068 IFOUND='NO' 19069 IERROR='NO' 19070C 19071 IF(NUMARG.LE.0)GOTO1150 19072 GOTO1110 19073C 19074 1110 CONTINUE 19075 IF(NUMARG.LE.1)GOTO1150 19076 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 19077 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 19078 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 19079 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 19080 GOTO1160 19081C 19082 1150 CONTINUE 19083 IHOLD=IDEFCC 19084 GOTO1180 19085C 19086 1160 CONTINUE 19087 IHOLD=IHARG(NUMARG) 19088 GOTO1180 19089C 19090 1180 CONTINUE 19091 IFOUND='YES' 19092 ICONCH=IHOLD 19093C 19094 IF(IFEEDB.EQ.'OFF')GOTO1189 19095 WRITE(ICOUT,999) 19096 CALL DPWRST('XXX','BUG ') 19097 WRITE(ICOUT,1181)ICONCH 19098 1181 FORMAT('THE CONTINUE CHARACTER HAS JUST BEEN SET TO ', 19099 1A4) 19100 CALL DPWRST('XXX','BUG ') 19101 1189 CONTINUE 19102 GOTO9000 19103C 19104 9000 CONTINUE 19105 IF(IBUGS2.EQ.'OFF')GOTO9090 19106 WRITE(ICOUT,999) 19107 CALL DPWRST('XXX','BUG ') 19108 WRITE(ICOUT,9011) 19109 9011 FORMAT('***** AT THE END OF DPCONC-') 19110 CALL DPWRST('XXX','BUG ') 19111 WRITE(ICOUT,9012)IBUGS2,IFOUND,IERROR 19112 9012 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 19113 CALL DPWRST('XXX','BUG ') 19114 WRITE(ICOUT,9013)IDEFCC,ICONCH 19115 9013 FORMAT('IDEFCC,ICONCH = ',A4,2X,A4) 19116 CALL DPWRST('XXX','BUG ') 19117 9090 CONTINUE 19118C 19119 RETURN 19120 END 19121