1 SUBROUTINE DPDIA2(X1,Y1,X2,Y2,X3,Y3, 2 1 IFIG,ILINPA,ILINCO,PLINTH, 3 1 AREGBA,IREBLI,IREBCO,PREBTH, 4 1 IREFSW,IREFCO, 5 1 IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 6 1 PTEXHE,PTEXWI,PTEXVG,PTEXHG) 7C 8C PURPOSE--DRAW A DIAMOND WITH ONE END OF THE MAJOR AXIS AT 9C (X1,Y1) WITH ONE END OF THE MINOR AXIS AT (X2,Y2) 10C AND THE OTHER END OF MAJOR AXIS AT (X3,Y3). 11C WRITTEN BY--JAMES J. FILLIBEN 12C STATISTICAL ENGINEERING DIVISION 13C INFORMATION TECHNOLOGY LABORATORY 14C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 15C GAITHERSBURG, MD 20899-8980 16C PHONE--301-975-2855 17C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 18C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 19C LANGUAGE--ANSI FORTRAN (1977) 20C VERSION NUMBER--82/7 21C ORIGINAL VERSION--APRIL 1981. 22C UPDATED --MAY 1982. 23C UPDATED --JANUARY 1989. MODIFY CALLS TO DPDRPL (ALAN) 24C UPDATED --JANUARY 1989. MODIFY CALL TO DPFIRE (ALAN) 25C 26C-----NON-COMMON VARIABLES------------------------------------- 27C 28 CHARACTER*4 IFIG 29 CHARACTER*4 IPATT2 30C 31 CHARACTER*4 ILINPA 32 CHARACTER*4 ILINCO 33C 34 CHARACTER*4 IREBLI 35 CHARACTER*4 IREBCO 36 CHARACTER*4 IREFSW 37 CHARACTER*4 IREFCO 38 CHARACTER*4 IREPTY 39 CHARACTER*4 IREPLI 40 CHARACTER*4 IREPCO 41C 42 CHARACTER*4 IPATT 43 CHARACTER*4 ICOLF 44 CHARACTER*4 ICOLP 45 CHARACTER*4 ICOL 46 CHARACTER*4 IFLAG 47C 48 DIMENSION PX(10) 49 DIMENSION PY(10) 50CCCCC DIMENSION PX3(10) 51CCCCC DIMENSION PY3(10) 52C 53 DIMENSION ILINPA(*) 54 DIMENSION ILINCO(*) 55 DIMENSION PLINTH(*) 56C 57 DIMENSION AREGBA(*) 58 DIMENSION IREBLI(*) 59 DIMENSION IREBCO(*) 60 DIMENSION PREBTH(*) 61 DIMENSION IREFSW(*) 62 DIMENSION IREFCO(*) 63 DIMENSION IREPTY(*) 64 DIMENSION IREPLI(*) 65 DIMENSION IREPCO(*) 66 DIMENSION PREPTH(*) 67 DIMENSION PREPSP(*) 68C 69C-----COMMON---------------------------------------------------------- 70C 71 INCLUDE 'DPCOGR.INC' 72 INCLUDE 'DPCOBE.INC' 73 INCLUDE 'DPCOP2.INC' 74C 75C-----START POINT----------------------------------------------------- 76C 77 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DIA2')THEN 78 WRITE(ICOUT,999) 79 999 FORMAT(1X) 80 CALL DPWRST('XXX','BUG ') 81 WRITE(ICOUT,51) 82 51 FORMAT('***** AT THE BEGINNING OF DPDIA2--') 83 CALL DPWRST('XXX','BUG ') 84 WRITE(ICOUT,53)X1,Y1,X2,Y2 85 53 FORMAT('X1,Y1,X2,Y2 = ',4G15.7) 86 CALL DPWRST('XXX','BUG ') 87 WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1) 88 61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,G15.7) 89 CALL DPWRST('XXX','BUG ') 90 WRITE(ICOUT,62)IFIG,AREGBA(1) 91 62 FORMAT('IFIG,AREGBA(1) = ',A4,2X,G15.7) 92 CALL DPWRST('XXX','BUG ') 93 WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1) 94 63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',2(A4,2X),G15.7) 95 CALL DPWRST('XXX','BUG ') 96 WRITE(ICOUT,64)IREFSW(1),IREFCO(1) 97 64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4) 98 CALL DPWRST('XXX','BUG ') 99 WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) 100 65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ', 101 1 3(A4,2X),2G15.7) 102 CALL DPWRST('XXX','BUG ') 103 WRITE(ICOUT,69)PTEXHE,PTEXWI,PTEXHG,PTEXVG 104 69 FORMAT('PTEXHE,PTEXWI,PTEXHG,PTEXVG = ',4G15.7) 105 CALL DPWRST('XXX','BUG ') 106 WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4 107 79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',2(A4,2X),A4) 108 CALL DPWRST('XXX','BUG ') 109 ENDIF 110C 111C ********************************* 112C ** STEP 1-- ** 113C ** DETERMINE THE COORDINATES ** 114C ** FOR THE DIAMOND ** 115C ********************************* 116C 117 XC=(X1+X3)/2.0 118 YC=(Y1+Y3)/2.0 119C 120 XDEL=XC-X2 121 YDEL=YC-Y2 122C 123 X4=XC+XDEL 124 Y4=YC+YDEL 125C 126 PX(1)=X1 127 PY(1)=Y1 128C 129 PX(2)=X2 130 PY(2)=Y2 131C 132 PX(3)=X3 133 PY(3)=Y3 134C 135 PX(4)=X4 136 PY(4)=Y4 137C 138 PX(5)=X1 139 PY(5)=Y1 140C 141 NP=5 142C 143C 144C *********************** 145C ** STEP 2-- ** 146C ** FILL THE FIGURE ** 147C ** (IF CALLED FOR) ** 148C *********************** 149C 150 IF(IREFSW(1).EQ.'OFF')GOTO2190 151 IPATT=IREPTY(1) 152 IPATT2='SOLI' 153 PTHICK=PREPTH(1) 154 PXGAP=PREPSP(1) 155 PYGAP=PREPSP(1) 156 ICOLF=IREFCO(1) 157 ICOLP=IREPCO(1) 158 CALL DPFIRE(PX,PY,NP, 159 1 IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2) 160 2190 CONTINUE 161C 162C *************************** 163C ** STEP 3-- ** 164C ** DRAW OUT THE FIGURE ** 165C *************************** 166C 167 IPATT=ILINPA(1) 168 PTHICK=PLINTH(1) 169 ICOL=ILINCO(1) 170 IFLAG='ON' 171 CALL DPDRPL(PX,PY,NP, 172 1 IFIG,IPATT,PTHICK,ICOL, 173 1 JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 174C 175C ***************** 176C ** STEP 90-- ** 177C ** EXIT ** 178C ***************** 179C 180 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DIA2')THEN 181 WRITE(ICOUT,999) 182 CALL DPWRST('XXX','BUG ') 183 WRITE(ICOUT,9011) 184 9011 FORMAT('***** AT THE END OF DPDIA2--') 185 CALL DPWRST('XXX','BUG ') 186 WRITE(ICOUT,9012)XC,YC,XDEL,YDEL,IERRG4 187 9012 FORMAT('XC,YC,XDEL,YDEL,IERRG4 = ',4G15.7,2X,A4) 188 CALL DPWRST('XXX','BUG ') 189 DO9015I=1,NP 190 WRITE(ICOUT,9016)I,PX(I),PY(I) 191 9016 FORMAT('I,PX(I),PY(I) = ',I8,2G15.7) 192 CALL DPWRST('XXX','BUG ') 193 9015 CONTINUE 194 ENDIF 195C 196 RETURN 197 END 198 SUBROUTINE DPDIAM(IHARG,IARGT,ARG,NUMARG, 199 1 PXSTAR,PYSTAR,PXEND,PYEND, 200 1 ILINPA,ILINCO,PLINTH, 201 1 AREGBA,IREBLI,IREBCO,PREBTH, 202 1 IREFSW,IREFCO, 203 1 IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 204 1 PTEXHE,PTEXWI,PTEXVG,PTEXHG, 205 1 IGRASW, 206 1 PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 207 1 PDIAHE,PDIAWI,PDIAVG,PDIAHG, 208 1 NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3, 209 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 210 1 IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL, 211 1 IBUGD2,IFOUND,IERROR) 212C 213C PURPOSE--DRAW ONE OR MORE DIAMONDS (DEPENDING ON HOW MANY NUMBERS 214C ARE PROVIDED). THE COORDINATES ARE IN STANDARDIZED 215C UNITS OF 0 TO 100. 216C NOTE--THE INPUT COORDINATES DEFINE 3 SUCCESSIVE POINTS 217C AROUND THE DIAMOND. 218C NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 3 219C AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*3 = 6. 220C NOTE--IF 4 NUMBERS ARE PROVIDED, THEN THE DRAWN DIAMOND WILL GO FROM THE 221C LAST CURSOR POSITION (ASSUMED TO BE AT ONE END OF MAJOR AXIS) 222C THROUGH THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) AS DEFINED BY 223C THE FIRST AND SECOND NUMBERS (ASSUMED TO BE AT ONE END OF MINOR 224C AXIS), TO THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) AS DEFINED 225C BY THE THIRD AND FOURTH NUMBERS (ASSUMED TO BE AT THE OTHER END OF 226C MAJOR AXIS), AND THEN BACK TO THE OTHER END OF THE MINOR AXIS, 227C AND CONTINUING BACK THE START POINT TO CLOSE THE DIAMOND. 228C NOTE--IF 6 NUMBERS ARE PROVIDED, THEN THE DRAWN DIAMOND WILL GO FROM THE 229C ABSOLUTE (X,Y) POSITION AS RESULTING FORM THE FIRST AND SECOND 230C NUMBERS (ASSUMED TO BE AT ONE END OF MAJOR AXIS), THROUGH THE (X,Y) 231C POINT (EITHER ABSOLUTE OR RELATIVE) AS DEFINED BY THE THIRD AND 232C FOURTH NUMBERS (ASSUMED TO BE AT ONE END OF MINOR AXIS), TO THE 233C (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) AS DEFINED BY THE FIFTH 234C AND SIXTH NUMBERS (ASSUMED TO BE AT THE OTHER END OF MAJOR AXIS), 235C AND THEN BACK TO THE OTHER END OF THE MINOR AXIS, 236C AND CONTINUING BACK THE START POINT TO CLOSE THE DIAMOND. 237C NOTE--AND SO FORTH FOR 10, 14, 18, ... NUMBERS. 238C INPUT ARGUMENTS--IHARG 239C --IARGT 240C --ARG 241C --NUMARG 242C --PXSTAR 243C --PYSTAR 244C OUTPUT ARGUMENTS--PXEND 245C --PYEND 246C --IFOUND ('YES' OR 'NO' ) 247C --IERROR ('YES' OR 'NO' ) 248C WRITTEN BY--JAMES J. FILLIBEN 249C STATISTICAL ENGINEERING DIVISION 250C INFORMATION TECHNOLOGY LABORATORY 251C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 252C GAITHERSBURG, MD 20899-8980 253C PHONE--301-975-2855 254C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 255C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 256C LANGUAGE--ANSI FORTRAN (1977) 257C VERSION NUMBER--82/7 258C ORIGINAL VERSION--APRIL 1981. 259C UPDATED --MARCH 1982. 260C UPDATED --MAY 1982. 261C UPDATED --NOVEMBER 1982. 262C UPDATED --JANUARY 1989. CALL LIST FOR OFFSET VAR (ALAN) 263C UPDATED --JANUARY 1989. SEP. UNITS FOR GR & ALPHA I/O (ALAN) 264C UPDATED --MARCH 1997. SUPPORT FOR DEVICE FONT (ALAN) 265C UPDATED --JULY 1997. SUPPORT FOR "DATA" UNITS (ALAN) 266C UPDATED --DECEMBER 2018. CHECK FOR DISCRETE, NULL, OR 267C NONE DEVICE 268C UPDATED --DECEMBER 2018. SUPPORT FOR "DEVICE ... SCALE" 269C COMMAND 270C 271C-----NON-COMMON VARIABLES----------------------------------------- 272C 273 CHARACTER*4 IHARG 274 CHARACTER*4 IARGT 275C 276 CHARACTER*4 ILINPA 277 CHARACTER*4 ILINCO 278C 279 CHARACTER*4 IREBLI 280 CHARACTER*4 IREBCO 281 CHARACTER*4 IREFSW 282 CHARACTER*4 IREFCO 283 CHARACTER*4 IREPTY 284 CHARACTER*4 IREPLI 285 CHARACTER*4 IREPCO 286C 287 CHARACTER*4 IGRASW 288 CHARACTER*4 IDMANU 289 CHARACTER*4 IDMODE 290 CHARACTER*4 IDMOD2 291 CHARACTER*4 IDMOD3 292 CHARACTER*4 IDPOWE 293 CHARACTER*4 IDCONT 294 CHARACTER*4 IDCOLO 295 CHARACTER*4 IDFONT 296 CHARACTER*4 UNITSW 297C 298 CHARACTER*4 IFOUND 299 CHARACTER*4 IBUGD2 300 CHARACTER*4 IERROR 301 CHARACTER*4 ISUBRO 302C 303 CHARACTER*4 IFIG 304 CHARACTER*4 IBELSW 305 CHARACTER*4 IERASW 306 CHARACTER*4 IBACCO 307 CHARACTER*4 ICOPSW 308 CHARACTER*4 ITYPEO 309C 310 DIMENSION IHARG(*) 311 DIMENSION IARGT(*) 312 DIMENSION ARG(*) 313C 314 DIMENSION ILINPA(*) 315 DIMENSION ILINCO(*) 316 DIMENSION PLINTH(*) 317C 318 DIMENSION AREGBA(*) 319 DIMENSION IREBLI(*) 320 DIMENSION IREBCO(*) 321 DIMENSION PREBTH(*) 322 DIMENSION IREFSW(*) 323 DIMENSION IREFCO(*) 324 DIMENSION IREPTY(*) 325 DIMENSION IREPLI(*) 326 DIMENSION IREPCO(*) 327 DIMENSION PREPTH(*) 328 DIMENSION PREPSP(*) 329 DIMENSION PDSCAL(*) 330C 331 DIMENSION IDMANU(*) 332 DIMENSION IDMODE(*) 333 DIMENSION IDMOD2(*) 334 DIMENSION IDMOD3(*) 335 DIMENSION IDPOWE(*) 336 DIMENSION IDCONT(*) 337 DIMENSION IDCOLO(*) 338 DIMENSION IDFONT(*) 339 DIMENSION IDNVPP(*) 340 DIMENSION IDNHPP(*) 341 DIMENSION IDUNIT(*) 342 DIMENSION IDNVOF(*) 343 DIMENSION IDNHOF(*) 344C 345C-----COMMON---------------------------------------------------------- 346C 347 INCLUDE 'DPCOGR.INC' 348 INCLUDE 'DPCOBE.INC' 349 INCLUDE 'DPCOP2.INC' 350C 351C-----START POINT----------------------------------------------------- 352C 353 IFOUND='NO' 354 IERROR='NO' 355 IERRG4=IERROR 356C 357 ILOCFN=0 358 NUMNUM=0 359C 360 X1=0.0 361 Y1=0.0 362 X2=0.0 363 Y2=0.0 364C 365 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DIAM')THEN 366 WRITE(ICOUT,999) 367 999 FORMAT(1X) 368 CALL DPWRST('XXX','BUG ') 369 WRITE(ICOUT,51) 370 51 FORMAT('***** AT THE BEGINNING OF DPDIAM--') 371 CALL DPWRST('XXX','BUG ') 372 ENDIF 373C 374 IFIG='DIAM' 375 NUMPT=3 376 NUMPT2=2*NUMPT 377C 378C ******************************** 379C ** STEP 0-- ** 380C ** STEP THROUGH EACH DEVICE ** 381C ******************************** 382C 383 IF(NUMDEV.LE.0)GOTO9000 384 DO8000IDEVIC=1,NUMDEV 385C 386 IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000 387 IF(IDMANU(IDEVIC).EQ.'OFF')GOTO8000 388 IF(IDMANU(IDEVIC).EQ.'NULL')GOTO8000 389 IF(IDMANU(IDEVIC).EQ.'NONE')GOTO8000 390 IF(IDMANU(IDEVIC).EQ.'DISC')GOTO8000 391C 392 IMANUF=IDMANU(IDEVIC) 393 IMODEL=IDMODE(IDEVIC) 394 IMODE2=IDMOD2(IDEVIC) 395 IMODE3=IDMOD3(IDEVIC) 396 IGCONT=IDCONT(IDEVIC) 397 IGCOLO=IDCOLO(IDEVIC) 398 IGFONT=IDFONT(IDEVIC) 399 NUMVPP=IDNVPP(IDEVIC) 400 NUMHPP=IDNHPP(IDEVIC) 401 ANUMVP=NUMVPP 402 ANUMHP=NUMHPP 403 IOFFSV=IDNVOF(IDEVIC) 404 IOFFSH=IDNHOF(IDEVIC) 405 IGUNIT=IDUNIT(IDEVIC) 406 PCHSCA=PDSCAL(IDEVIC) 407C 408C ************************************ 409C ** STEP 1-- ** 410C ** CARRY OUT OPENING OPERATIONS ** 411C ** ON THE GRAPHICS DEVICES ** 412C ************************************ 413C 414 CALL DPOPDE 415C 416 IBELSW='OFF' 417 NUMRIN=0 418 IERASW='OFF' 419 IBACCO='JUNK' 420C 421 CALL DPOPPL(IGRASW,IBELSW,NUMRIN,IERASW,IBACCO) 422C 423C ***************************************** 424C ** STEP 2-- ** 425C ** SEARCH FOR COMMAND SPECIFICATIONS ** 426C ***************************************** 427C 428 IF(NUMARG.GE.2.AND. 429 1 IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB')THEN 430 ITYPEO='ABSO' 431 ILOCFN=1 432 ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND. 433 1 IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')THEN 434 ITYPEO='ABSO' 435 ILOCFN=2 436 ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND. 437 1 IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')THEN 438 ITYPEO='RELA' 439 ILOCFN=2 440 ELSE 441 GOTO1130 442 ENDIF 443C 444 IF(ILOCFN.GT.NUMARG)GOTO1130 445 DO1120I=ILOCFN,NUMARG 446 IF(IARGT(I).NE.'NUMB')GOTO1130 447 1120 CONTINUE 448 IFOUND='YES' 449C 450C **************************** 451C ** STEP 3-- ** 452C ** DRAW OUT THE LINE(S) ** 453C **************************** 454C 455 NUMNUM=NUMARG-ILOCFN+1 456 IF(NUMNUM.LT.NUMPT2)THEN 457 J=ILOCFN-1 458 X1=PXSTAR 459 Y1=PYSTAR 460 ELSE 461 J=ILOCFN 462 IF(J.GT.NUMARG)GOTO1190 463 X1=ARG(J) 464 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1, 465 1 IBUGD2,ISUBRO,IERROR) 466 J=J+1 467 IF(J.GT.NUMARG)GOTO1190 468 Y1=ARG(J) 469 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1, 470 1 IBUGD2,ISUBRO,IERROR) 471 ENDIF 472C 473 1160 CONTINUE 474 J=J+1 475 IF(J.GT.NUMARG)GOTO1190 476 X2=ARG(J) 477 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR) 478 IF(ITYPEO.EQ.'RELA')X2=X1+X2 479 J=J+1 480 IF(J.GT.NUMARG)GOTO1190 481 Y2=ARG(J) 482 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR) 483 IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2 484C 485 J=J+1 486 IF(J.GT.NUMARG)GOTO1190 487 X3=ARG(J) 488 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X3,X3,IBUGD2,ISUBRO,IERROR) 489 IF(ITYPEO.EQ.'RELA')X3=X2+X3 490 J=J+1 491 IF(J.GT.NUMARG)GOTO1190 492 Y3=ARG(J) 493 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y3,Y3,IBUGD2,ISUBRO,IERROR) 494 IF(ITYPEO.EQ.'RELA')Y3=Y2+Y3 495C 496 CALL DPDIA2(X1,Y1,X2,Y2,X3,Y3, 497 1 IFIG,ILINPA,ILINCO,PLINTH, 498 1 AREGBA,IREBLI,IREBCO,PREBTH, 499 1 IREFSW,IREFCO, 500 1 IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 501 1 PTEXHE,PTEXWI,PTEXVG,PTEXHG) 502C 503 X1=X3 504 Y1=Y3 505C 506 GOTO1160 507 1190 CONTINUE 508C 509 PXEND=X3 510 PYEND=Y3 511C 512C ************************************ 513C ** STEP 4-- ** 514C ** CARRY OUT CLOSING OPERATIONS ** 515C ** ON THE GRAPHICS DEVICES ** 516C ************************************ 517C 518 ICOPSW='OFF' 519 NUMCOP=0 520 CALL DPCLPL(ICOPSW,NUMCOP, 521 1 PGRAXF,PGRAYF, 522 1 IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 523 1 PDIAHE,PDIAWI,PDIAVG,PDIAHG) 524C 525 CALL DPCLDE 526C 527 8000 CONTINUE 528 GOTO9000 529C 530 1130 CONTINUE 531 IERRG4='YES' 532 WRITE(ICOUT,1131) 533 1131 FORMAT('***** ERROR IN DIAMOND (DPDIAM)--') 534 CALL DPWRST('XXX','BUG ') 535 WRITE(ICOUT,1132) 536 1132 FORMAT(' ILLEGAL FORM FOR THE DIAMOND COMMAND.') 537 CALL DPWRST('XXX','BUG ') 538 WRITE(ICOUT,1134) 539 1134 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE PROPER FORM--') 540 CALL DPWRST('XXX','BUG ') 541 WRITE(ICOUT,1135) 542 1135 FORMAT(' SUPPOSE IT IS DESIRED TO DRAW A DIAMOND ') 543 CALL DPWRST('XXX','BUG ') 544 WRITE(ICOUT,1136) 545 1136 FORMAT(' WITH ONE END OF MAJOR AXIS AT THE POINT 20 20 ') 546 CALL DPWRST('XXX','BUG ') 547 WRITE(ICOUT,1137) 548 1137 FORMAT(' ONE END OF THE MINOR AXIS AT THE POINT 30 10') 549 CALL DPWRST('XXX','BUG ') 550 WRITE(ICOUT,1138) 551 1138 FORMAT(' AND WITH THE OTHER END OF THE MAJOR AXIS') 552 CALL DPWRST('XXX','BUG ') 553 WRITE(ICOUT,1139) 554 1139 FORMAT(' AT THE POINT 40 20') 555 CALL DPWRST('XXX','BUG ') 556 WRITE(ICOUT,1141) 557 1141 FORMAT(' THEN THE ALLOWABLE FORMS ARE--') 558 CALL DPWRST('XXX','BUG ') 559 WRITE(ICOUT,1142) 560 1142 FORMAT(' DIAMOND 20 20 30 10 40 20 ') 561 CALL DPWRST('XXX','BUG ') 562 WRITE(ICOUT,1143) 563 1143 FORMAT(' DIAMOND ABSOLUTE 20 20 30 10 40 20 ') 564 CALL DPWRST('XXX','BUG ') 565 WRITE(ICOUT,1145) 566 1145 FORMAT(' DIAMOND RELATIVE 20 20 30 10 40 20 ') 567 CALL DPWRST('XXX','BUG ') 568 GOTO9000 569C ***************** 570C ** STEP 90-- ** 571C ** EXIT ** 572C ***************** 573C 574 9000 CONTINUE 575 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DIAM')THEN 576 WRITE(ICOUT,999) 577 CALL DPWRST('XXX','BUG ') 578 WRITE(ICOUT,9011) 579 9011 FORMAT('***** AT THE END OF DPDIAM--') 580 CALL DPWRST('XXX','BUG ') 581 WRITE(ICOUT,9012)IFOUND,IERROR,ILOCFN,NUMNUM 582 9012 FORMAT('IFOUND,IERROR,ILOCFN,NUMNUM = ',2(A4,2X),2I8) 583 CALL DPWRST('XXX','BUG ') 584 WRITE(ICOUT,9013)X1,Y1,X2,Y2,X3,Y3 585 9013 FORMAT('X1,Y1,X2,Y2,X3,Y3 = ',6G15.7) 586 CALL DPWRST('XXX','BUG ') 587 WRITE(ICOUT,9015)PXSTAR,PYSTAR,PXEND,PYEND 588 9015 FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4G15.7) 589 CALL DPWRST('XXX','BUG ') 590 ENDIF 591C 592 RETURN 593 END 594 SUBROUTINE DPDIME(IANS,IHARG,IARGT,IARG,NUMARG,IDEMXN,IDEMXC, 595 1IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,IVALUE,VALUE,NUMNAM,MAXNAM, 596 1V,MAXNK,NUMN,MAXN,MAXNXT, 597CCCCC JANUARY 1998. ADD FOLLOWING LINE. 598 1MAXTOM,MAXROM,MAXCOM,MAXOBV, 599 1NUMCOL,MAXCOL,IFOUND,IERROR,IBUGS2) 600C 601C PURPOSE--DEFINE THE MAXIMUM NUMBER OF ROWS (MAXN) 602C AND COLUMNS (MAXCOL) IN THE INTERNAL DATAPLOT 603C DATA ARRAY. 604C THE MAXIMUM NUMBER OF ROWS WILL BE PLACED 605C IN THE VARIABLE MAXN. 606C THE MAXIMUM NUMBER OF COLUMNS WILL BE PLACED 607C IN THE VARIABLE MAXCOL. 608C NOTE THAT THE PRODUCT OF MAXN AND MAXCOL SHOULD 609C NOT EXCEED THE VALUE OF MAXNK. 610C MAXNK DIFFERS AT DIFFERENT COMPUTER 611C INSTALLATIONS DEPENDENDING ON AVAILABLE MEMORY. 612C A TYPICAL VALUE FOR MAXNK IS 10000 . 613C MAXNK IS DEFINED IN THE SUBROUTINE INITDA. 614C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 615C --IARGT (A HOLLERITH VECTOR) 616C --IARG (A HOLLERITH VECTOR) 617C --NUMARG (AN INTEGER VARIABLE) 618C --IDEMXN (AN INTEGER VARIABLE) 619C --IDEMXC (AN INTEGER VARIABLE) 620C --IHNAME (A HOLLERITH VECTOR) 621C --IHNAM2 (A HOLLERITH VECTOR) 622C --IUSE (A HOLLERITH VECTOR) 623C --IN (AN INTEGER VECTOR) 624C --IVSTAR (AN INTEGER VECTOR) 625C --IVSTOP (AN INTEGER VECTOR) 626C --IVALUE (AN INTEGER VECTOR) 627C --VALUE (A FLOATING POINT VECTOR) 628C --NUMNAM (AN INTEGER VARIABLE) 629C --MAXNAM (AN INTEGER VARIABLE) 630C --V (A FLOATING POINT VECTOR) 631C --MAXNK (AN INTEGER VARIABLE) 632C --NUMN (AN INTEGER VARIABLE) 633C --NUMCOL (AN INTEGER VARIABLE) 634C OUTPUT ARGUMENTS--MAXN (AN INTEGER VARIABLE 635C WHICH SPECIFIES THE MAXIMUM 636C NUMBER OF ROWS FOR A GIVEN COLUMN 637C (THAT IS, THE MAXIMUM NUMBER OF 638C OBSERVATIONS FOR A GIVEN VARIABLE). 639C --MAXCOL (AN INTEGER VARIABLE 640C WHICH SPECIFIES THE MAXIMUM 641C NUMBER OF COLUMNS 642C (THAT IS, THE MAXIMUM NUMBER OF 643C VARIABLES) 644C --IFOUND ('YES' OR 'NO' ) 645C --IERROR ('YES' OR 'NO' ) 646C WRITTEN BY--JAMES J. FILLIBEN 647C STATISTICAL ENGINEERING DIVISION 648C INFORMATION TECHNOLOGY LABORATORY 649C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 650C GAITHERSBURG, MD 20899-8980 651C PHONE--301-975-2855 652C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 653C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 654C LANGUAGE--ANSI FORTRAN (1977) 655C VERSION NUMBER--82/7 656C ORIGINAL VERSION--OCTOBER 1980. 657C UPDATED --FEBRUARY 1982. 658C UPDATED --MAY 1982. 659C UPDATED --APRIL 1985. 660C UPDATED --JUNE 1989. ALLOW FACTOR 661C UPDATED --JULY 1989. MAXCP1/2/3/4/5/6 662C UPDATED --OCTOBER 1991. MOVE COMMENT LINE 663C UPDATED --JANUARY 1998. ADD DIMENSION MATRIX 664C <ROWS/COLUMNS> <VALUE> 665C UPDATED --JULY 1998. SAVE AS INTERNAL PARAMETERS: 666C MAXROWS, MAXCOLS 667C MAXROWMT, MAXCOLMT 668C 669C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 670C 671 CHARACTER*4 IANS 672 CHARACTER*4 IHARG 673 CHARACTER*4 IARGT 674 CHARACTER*4 IHNAME 675 CHARACTER*4 IHNAM2 676 CHARACTER*4 IUSE 677 CHARACTER*4 IFOUND 678 CHARACTER*4 IERROR 679 CHARACTER*4 IBUGS2 680C 681 CHARACTER*4 ITRUND 682 CHARACTER*4 ITRUNV 683 CHARACTER*4 IDONE 684C 685 CHARACTER*4 IH 686 CHARACTER*4 IH2 687 CHARACTER*4 ISUBN0 688C 689C--------------------------------------------------------------------- 690C 691 DIMENSION IHARG(*) 692 DIMENSION IARGT(*) 693 DIMENSION IARG(*) 694C 695 DIMENSION IANS(*) 696 DIMENSION IHNAME(*) 697 DIMENSION IHNAM2(*) 698 DIMENSION IUSE(*) 699 DIMENSION IN(*) 700 DIMENSION IVSTAR(*) 701 DIMENSION IVSTOP(*) 702 DIMENSION IVALUE(*) 703 DIMENSION VALUE(*) 704C 705 DIMENSION V(*) 706C 707CCCCC THE FOLLOWING LINE WAS ADDED JULY 1989 708 INCLUDE 'DPCOM2.INC' 709CCCCC THE FOLLOWING LINE WAS ADDED JULY 1998 710 INCLUDE 'DPCOHO.INC' 711 INCLUDE 'DPCOP2.INC' 712C 713C-----START POINT----------------------------------------------------- 714C 715 IFOUND='YES' 716 IERROR='NO' 717C 718 ISUBN0='DIME' 719 IANS(1)=' ' 720 IWIDTH=1 721C 722 ITEMPR=(-999) 723 ITEMPC=(-999) 724 ITEMRC=(-999) 725C 726 MINR=MAXNK/MAXNAM 727 MAXR=MAXNXT 728C 729 MINC=MAXNK/MAXNXT 730 MAXC=MAXNAM 731C 732 MINRC=1 733 MAXRC=MAXNK 734C 735 NNEW=0 736 IV1NEW=0 737 IV2NEW=0 738C 739 IF(IBUGS2.EQ.'ON')THEN 740 WRITE(ICOUT,999) 741 999 FORMAT(1X) 742 CALL DPWRST('XXX','BUG ') 743 WRITE(ICOUT,51) 744 51 FORMAT('AT THE BEGINNING OF DPDIME--') 745 CALL DPWRST('XXX','BUG ') 746 WRITE(ICOUT,53)NUMNAM,MAXNAM,MAXNK,IBUGS2 747 53 FORMAT('NUMNAM,MAXNAM,MAXNK,IBUGS2 = ',3I8,2X,A4) 748 CALL DPWRST('XXX','BUG ') 749 WRITE(ICOUT,55)NUMN,MAXN,MAXNXT,NUMCOL,MAXCOL 750 55 FORMAT('NUMN,MAXN,MAXNXT,NUMCOL,MAXCOL = ',5I8) 751 CALL DPWRST('XXX','BUG ') 752 WRITE(ICOUT,57)MINR,MAXR,MINC,MAXC,MINRC,MAXRC 753 57 FORMAT('MINR,MAXR,MINC,MAXC,MINRC,MAXRC = ',6I8) 754 CALL DPWRST('XXX','BUG ') 755 WRITE(ICOUT,61) 756 61 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),', 757 1 'IVSTAR(I),IVSTOP(I),IVALUE(I),VALUE(I)') 758 CALL DPWRST('XXX','BUG ') 759 IF(NUMNAM.GE.1)THEN 760 DO62I=1,NUMNAM 761 WRITE(ICOUT,63)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I), 762 1 IVSTAR(I),IVSTOP(I),IVALUE(I),VALUE(I) 763 63 FORMAT(I8,2X,A4,2X,A4,2X,A4,4I8,E15.7) 764 CALL DPWRST('XXX','BUG ') 765 62 CONTINUE 766 ENDIF 767 ENDIF 768C 769C **************************************** 770C ** STEP 11-- ** 771C ** DETERMINE THE DESIRED DIMENSIONS ** 772C **************************************** 773C 774 IF(NUMARG.LE.1)GOTO1130 775C 776CCCCC JANUARY 1998. ADD FOLLOWING FOR MATRIX DIMENSIONS 777C 778 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MATR')THEN 779 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'COLU')THEN 780 IF(NUMARG.GE.3.AND.IARGT(3).EQ.'NUMB')THEN 781 MAXCOM=IARG(3) 782 IF(MAXCOM.GT.SQRT(REAL(MAXTOM))) 783 1 MAXCOM=INT(SQRT(REAL(MAXTOM))) 784 IF(MAXCOM.LT.MAXTOM/MAXOBV)MAXCOM=MAXTOM/MAXOBV 785 MAXROM=MAXTOM/MAXCOM 786 IF(MAXROM.GT.MAXN)MAXROM=MAXN 787 WRITE(ICOUT,999) 788 CALL DPWRST('XXX','BUG ') 789 WRITE(ICOUT,901)MAXROM 790 CALL DPWRST('XXX','BUG ') 791 WRITE(ICOUT,902)MAXCOM 792 CALL DPWRST('XXX','BUG ') 793 GOTO950 794 ELSE 795 GOTO990 796 ENDIF 797 ELSEIF(NUMARG.GE.3.AND.IHARG(3).EQ.'COLU')THEN 798 IF(IARGT(2).EQ.'NUMB')THEN 799 MAXCOM=IARG(2) 800 IF(MAXCOM.GT.INT(SQRT(REAL(MAXTOM)))) 801 1 MAXCOM=INT(SQRT(REAL(MAXTOM))) 802 IF(MAXCOM.LT.MAXTOM/MAXOBV)MAXCOM=MAXTOM/MAXOBV 803 MAXROM=MAXTOM/MAXCOM 804 IF(MAXROM.GT.MAXN)MAXROM=MAXN 805 WRITE(ICOUT,999) 806 CALL DPWRST('XXX','BUG ') 807 WRITE(ICOUT,901)MAXROM 808 CALL DPWRST('XXX','BUG ') 809 WRITE(ICOUT,902)MAXCOM 810 CALL DPWRST('XXX','BUG ') 811 GOTO950 812 ELSE 813 GOTO990 814 ENDIF 815 ELSEIF(NUMARG.GE.2.AND.IHARG(2)(1:3).EQ.'ROW')THEN 816 IF(NUMARG.GE.3.AND.IARGT(3).EQ.'NUMB')THEN 817 MAXROM=IARG(3) 818 IF(MAXROM.GT.MAXOBV)MAXROM=MAXOBV 819 IF(MAXROM.LT.INT(SQRT(REAL(MAXTOM)))) 820 1 MAXROM=INT(SQRT(REAL(MAXTOM))) 821 IF(MAXROM.GT.MAXN)MAXROM=MAXN 822 MAXCOM=MAXTOM/MAXROM 823 WRITE(ICOUT,999) 824 CALL DPWRST('XXX','BUG ') 825 WRITE(ICOUT,901)MAXROM 826 CALL DPWRST('XXX','BUG ') 827 WRITE(ICOUT,902)MAXCOM 828 CALL DPWRST('XXX','BUG ') 829 GOTO950 830 ELSE 831 GOTO990 832 ENDIF 833 ELSEIF(NUMARG.GE.3.AND.IHARG(3)(1:3).EQ.'ROW')THEN 834 IF(IARGT(2).EQ.'NUMB')THEN 835 MAXROM=IARG(2) 836 IF(MAXROM.GT.MAXOBV)MAXROM=MAXOBV 837 IF(MAXROM.LT.SQRT(REAL(MAXTOM))) 838 1 MAXROM=INT(SQRT(REAL(MAXTOM))) 839 IF(MAXROM.GT.MAXN)MAXROM=MAXN 840 MAXCOM=MAXTOM/MAXROM 841 WRITE(ICOUT,999) 842 CALL DPWRST('XXX','BUG ') 843 WRITE(ICOUT,901)MAXROM 844 CALL DPWRST('XXX','BUG ') 845 WRITE(ICOUT,902)MAXCOM 846 CALL DPWRST('XXX','BUG ') 847 GOTO950 848 ELSE 849 GOTO990 850 ENDIF 851 ELSE 852 GOTO990 853 ENDIF 854 ENDIF 855 GOTO980 856C 857 950 CONTINUE 858 IH='MAXR' 859 IH2='OWMT' 860 VALUE0=MAXROM 861 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 862 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 863 1IANS,IWIDTH,IBUGS2,IERROR) 864C 865 IH='MAXC' 866 IH2='OLMT' 867 VALUE0=MAXCOM 868 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 869 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 870 1IANS,IWIDTH,IBUGS2,IERROR) 871C 872 GOTO9000 873C 874 901 FORMAT('THE MAXIMUM NUMBER OF MAXTRIX ROWS SET TO ',I8) 875 902 FORMAT('THE MAXIMUM NUMBER OF MAXTRIX COLUMNS SET TO ',I8) 876C 877 980 CONTINUE 878 IF(NUMARG.LE.2.AND.IARGT(1).EQ.'NUMB'.AND. 879 1IARGT(2).EQ.'NUMB')GOTO1140 880 IF(NUMARG.LE.2.AND.IARGT(1).EQ.'NUMB'.AND. 881 1IARGT(2).NE.'NUMB')GOTO1150 882C 883 IF(NUMARG.LE.4.AND.IARGT(1).EQ.'NUMB'.AND. 884 1IARGT(2).NE.'NUMB'.AND.IARGT(3).EQ.'NUMB'.AND. 885 1IARGT(4).NE.'NUMB')GOTO1160 886C 887 990 CONTINUE 888 WRITE(ICOUT,999) 889 CALL DPWRST('XXX','BUG ') 890 WRITE(ICOUT,1111) 891 1111 FORMAT('***** ERROR IN DPDIME--') 892 CALL DPWRST('XXX','BUG ') 893 WRITE(ICOUT,1112) 894 1112 FORMAT(' ILLEGAL FORM FOR THE DIMENSION COMMAND.') 895 CALL DPWRST('XXX','BUG ') 896 WRITE(ICOUT,1113) 897 1113 FORMAT(' RECOMMENDED FORMS--') 898 CALL DPWRST('XXX','BUG ') 899 WRITE(ICOUT,1114) 900 1114 FORMAT(' DIMENSION 1000 OBSERVATIONS') 901 CALL DPWRST('XXX','BUG ') 902 WRITE(ICOUT,1115) 903 1115 FORMAT(' DIMENSION 10 VARIABLES') 904 CALL DPWRST('XXX','BUG ') 905 WRITE(ICOUT,1121) 906 1121 FORMAT(' OTHER ALLOWABLE FORMS--') 907 CALL DPWRST('XXX','BUG ') 908 WRITE(ICOUT,1122) 909 1122 FORMAT(' DIMENSION 1000 ROWS') 910 CALL DPWRST('XXX','BUG ') 911 WRITE(ICOUT,1123) 912 1123 FORMAT(' DIMENSION 10 COLUMNS') 913 CALL DPWRST('XXX','BUG ') 914 WRITE(ICOUT,1124) 915 1124 FORMAT(' DIMENSION 1000 OBSERVATIONS 10 VARIABLES') 916 CALL DPWRST('XXX','BUG ') 917 WRITE(ICOUT,1125) 918 1125 FORMAT(' DIMENSION 10 VARIABLES 1000 OBSERVATIONS') 919 CALL DPWRST('XXX','BUG ') 920 WRITE(ICOUT,1126) 921 1126 FORMAT(' DIMENSION 1000 ROWS 10 COLUMNS') 922 CALL DPWRST('XXX','BUG ') 923 WRITE(ICOUT,1127) 924 1127 FORMAT(' DIMENSION 10 COLUMNS 1000 ROWS') 925 CALL DPWRST('XXX','BUG ') 926 WRITE(ICOUT,1128) 927 1128 FORMAT(' DIMENSION 1000 10') 928 CALL DPWRST('XXX','BUG ') 929 IERROR='YES' 930 GOTO9000 931C 932 1130 CONTINUE 933 ITEMPR=IDEMXN 934 ITEMPC=IDEMXC 935 GOTO1190 936C 937 1140 CONTINUE 938 ITEMPR=IARG(1) 939 ITEMPC=IARG(2) 940 GOTO1190 941C 942 1150 CONTINUE 943 IF(IHARG(2).EQ.'ROW')GOTO1151 944 IF(IHARG(2).EQ.'ROWS')GOTO1151 945 IF(IHARG(2).EQ.'LINE')GOTO1151 946 IF(IHARG(2).EQ.'OBSE')GOTO1151 947 IF(IHARG(2).EQ.'COLU')GOTO1152 948 IF(IHARG(2).EQ.'VARI')GOTO1152 949 GOTO1151 950 1151 CONTINUE 951 ITEMPR=IARG(1) 952 IF(ITEMPR.LE.1)ITEMPR=1 953 ITEMPC=MAXNK/ITEMPR 954 GOTO1190 955 1152 CONTINUE 956 ITEMPC=IARG(1) 957 IF(ITEMPC.LE.1)ITEMPC=1 958 ITEMPR=MAXNK/ITEMPC 959 GOTO1190 960C 961 1160 CONTINUE 962 IF(IHARG(2).EQ.'ROW')GOTO1161 963 IF(IHARG(2).EQ.'ROWS')GOTO1161 964 IF(IHARG(2).EQ.'LINE')GOTO1161 965 IF(IHARG(2).EQ.'OBSE')GOTO1161 966 IF(IHARG(2).EQ.'COLU')GOTO1162 967 IF(IHARG(2).EQ.'VARI')GOTO1162 968CCCCC THE FOLLOWING LINE WAS ADDED JULY 1989 969 IF(IHARG(2).EQ.'FACT')GOTO1162 970 GOTO1161 971 1161 CONTINUE 972 ITEMPR=IARG(1) 973 ITEMPC=IARG(3) 974 GOTO1190 975 1162 CONTINUE 976 ITEMPC=IARG(1) 977 ITEMPR=IARG(3) 978 GOTO1190 979C 980 1190 CONTINUE 981 ITEMRC=ITEMPR*ITEMPC 982C 983C ************************************* 984C ** STEP 12-- ** 985C ** DETERMINE IF THE SPECIFIED ** 986C ** OBSERVATIONS(= ROW) DIMENSION ** 987C ** IS TOO SMALL OR LARGE. ** 988C ************************************* 989C 990 IF(MINR.LE.ITEMPR.AND.ITEMPR.LE.MAXR)GOTO1290 991 WRITE(ICOUT,999) 992 CALL DPWRST('XXX','BUG ') 993 WRITE(ICOUT,1211) 994 1211 FORMAT('***** ERROR IN DPDIME--') 995 CALL DPWRST('XXX','BUG ') 996 WRITE(ICOUT,1212) 997 1212 FORMAT(' THE OBSERVATIONS (= ROW) DIMENSION') 998 CALL DPWRST('XXX','BUG ') 999 IF(ITEMPR.LT.MINR) 1000 1WRITE(ICOUT,1213) 1001 1213 FORMAT(' IS TOO SMALL.') 1002 IF(ITEMPR.LT.MINR) 1003 1CALL DPWRST('XXX','BUG ') 1004 IF(ITEMPR.GT.MAXR) 1005 1WRITE(ICOUT,1214) 1006 1214 FORMAT(' IS TOO LARGE.') 1007 IF(ITEMPR.GT.MAXR) 1008 1CALL DPWRST('XXX','BUG ') 1009 WRITE(ICOUT,1215)MINR,MAXR 1010 1215 FORMAT(' IT MUST BE BETWEEN ',I8,' & ',I8,' (INCLUSIVE)') 1011 CALL DPWRST('XXX','BUG ') 1012 WRITE(ICOUT,1216)ITEMPR 1013 1216 FORMAT(' THE SPECIFIED VALUE IS ',I8) 1014 CALL DPWRST('XXX','BUG ') 1015 WRITE(ICOUT,1217) 1016 1217 FORMAT(' NO REDIMENSIONING WAS CARRIED OUT.') 1017 CALL DPWRST('XXX','BUG ') 1018 IERROR='YES' 1019 GOTO9000 1020 1290 CONTINUE 1021C 1022C ************************************* 1023C ** STEP 13-- ** 1024C ** DETERMINE IF THE SPECIFIED ** 1025C ** VARIABLES(= COLUMN) DIMENSION ** 1026C ** IS TOO LARGE. ** 1027C ************************************* 1028C 1029 IF(MINC.LE.ITEMPC.AND.ITEMPC.LE.MAXC)GOTO1390 1030 WRITE(ICOUT,999) 1031 CALL DPWRST('XXX','BUG ') 1032 WRITE(ICOUT,1311) 1033 1311 FORMAT('***** ERROR IN DPDIME--') 1034 CALL DPWRST('XXX','BUG ') 1035 WRITE(ICOUT,1312) 1036 1312 FORMAT(' THE VARIABLES (= COLUMN) DIMENSION') 1037 CALL DPWRST('XXX','BUG ') 1038 IF(ITEMPC.LT.MINC) 1039 1WRITE(ICOUT,1313) 1040 1313 FORMAT(' IS TOO SMALL.') 1041 IF(ITEMPC.LT.MINC) 1042 1CALL DPWRST('XXX','BUG ') 1043 IF(ITEMPC.GT.MAXC) 1044 1WRITE(ICOUT,1314) 1045 1314 FORMAT(' IS TOO LARGE.') 1046 IF(ITEMPC.GT.MAXC) 1047 1CALL DPWRST('XXX','BUG ') 1048 WRITE(ICOUT,1315)MINC,MAXC 1049 1315 FORMAT(' IT MUST BE BETWEEN ',I8,' & ',I8,' (INCLUSIVE)') 1050 CALL DPWRST('XXX','BUG ') 1051 WRITE(ICOUT,1316)ITEMPC 1052 1316 FORMAT(' THE SPECIFIED VALUE IS ',I8) 1053 CALL DPWRST('XXX','BUG ') 1054 WRITE(ICOUT,1317) 1055 1317 FORMAT(' NO REDIMENSIONING WAS CARRIED OUT.') 1056 CALL DPWRST('XXX','BUG ') 1057 IERROR='YES' 1058 GOTO9000 1059 1390 CONTINUE 1060C 1061C ************************************* 1062C ** STEP 14-- ** 1063C ** DETERMINE IF THE COMBINED ** 1064C ** DIMENSION (= ROW X COLUMN) ** 1065C ** IS TOO LARGE. ** 1066C ************************************* 1067C 1068 IF(MINRC.LE.ITEMRC.AND.ITEMRC.LE.MAXRC)GOTO1490 1069 WRITE(ICOUT,999) 1070 CALL DPWRST('XXX','BUG ') 1071 WRITE(ICOUT,1411) 1072 1411 FORMAT('***** ERROR IN DPDIME--') 1073 CALL DPWRST('XXX','BUG ') 1074 WRITE(ICOUT,1412) 1075 1412 FORMAT(' THE JOINT ROW AND COLUMN DIMENSIONS') 1076 CALL DPWRST('XXX','BUG ') 1077 IF(ITEMRC.LT.MINRC) 1078 1WRITE(ICOUT,1413) 1079 1413 FORMAT(' IS TOO SMALL.') 1080 IF(ITEMRC.LT.MINRC) 1081 1CALL DPWRST('XXX','BUG ') 1082 IF(ITEMRC.GT.MAXRC) 1083 1WRITE(ICOUT,1414) 1084 1414 FORMAT(' IS TOO LARGE.') 1085 IF(ITEMRC.GT.MAXRC) 1086 1CALL DPWRST('XXX','BUG ') 1087 WRITE(ICOUT,1415) 1088 1415 FORMAT(' THEIR PRODUCT MUST') 1089 CALL DPWRST('XXX','BUG ') 1090 WRITE(ICOUT,1416)MINRC,MAXRC 1091 1416 FORMAT(' BE BETWEEN ',I8,' & ',I8,' (INCLUSIVE)') 1092 CALL DPWRST('XXX','BUG ') 1093 WRITE(ICOUT,1417)ITEMRC 1094 1417 FORMAT(' THEIR PRODUCT IS ',I8) 1095 CALL DPWRST('XXX','BUG ') 1096 WRITE(ICOUT,1418) 1097 1418 FORMAT(' NO REDIMENSIONING WAS CARRIED OUT.') 1098 CALL DPWRST('XXX','BUG ') 1099 IERROR='YES' 1100 GOTO9000 1101 1490 CONTINUE 1102C 1103C ***************************** 1104C ** STEP 15-- ** 1105C ** SET THE DIMENSIONS ** 1106C ** TO THE DESIRED VALUES ** 1107C ***************************** 1108C 1109 MAXNOL=MAXN 1110 MAXN=ITEMPR 1111 MAXCOL=ITEMPC 1112 MAXNNE=MAXN 1113C 1114CCCCC THE FOLLOWING 6 LINES WERE ADDED JULY 1989 1115 MAXCP1=MAXCOL+1 1116 MAXCP2=MAXCOL+2 1117 MAXCP3=MAXCOL+3 1118 MAXCP4=MAXCOL+4 1119 MAXCP5=MAXCOL+5 1120 MAXCP6=MAXCOL+6 1121C 1122C ******************************** 1123C ** STEP 16-- ** 1124C ** PRINT OUT THE DIMENSIONS ** 1125C ******************************** 1126C 1127 IF(IFEEDB.EQ.'OFF')GOTO1619 1128 WRITE(ICOUT,999) 1129 CALL DPWRST('XXX','BUG ') 1130 WRITE(ICOUT,1613) 1131 1613 FORMAT('DIMENSION INFORMATION--') 1132 CALL DPWRST('XXX','BUG ') 1133 WRITE(ICOUT,1614)MAXNK 1134 1614 FORMAT(' MAXIMUM DATA ARRAY SIZE = ',I8) 1135 CALL DPWRST('XXX','BUG ') 1136 WRITE(ICOUT,1615)MAXN 1137 1615 FORMAT(' MAXIMUM NUMBER OBS/VARIABLE (ROWS) = ',I8) 1138 CALL DPWRST('XXX','BUG ') 1139 WRITE(ICOUT,1616)MAXCOL 1140 1616 FORMAT(' MAXIMUM NUMBER VARIABLES (COLUMNS) = ',I8) 1141 CALL DPWRST('XXX','BUG ') 1142 1619 CONTINUE 1143C 1144 IH='MAXR' 1145 IH2='OWS ' 1146 VALUE0=MAXN 1147 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1148 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1149 1IANS,IWIDTH,IBUGS2,IERROR) 1150C 1151 IH='MAXC' 1152 IH2='OLS ' 1153 VALUE0=MAXCOL 1154 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1155 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1156 1IANS,IWIDTH,IBUGS2,IERROR) 1157C 1158C 1159C ************************************* 1160C ** STEP 13-- ** 1161C ** DETERMINE IF ANY OBSERVATIONS ** 1162C ** NEED TO BE TRUNCATED ** 1163C ************************************* 1164C 1165 ITRUND='NO' 1166C 1167CCCCC THE FOLLOWING LINE WAS COMMENTED OUT OCTOBER 1991 1168CCCCC WRITE(ICOUT,999) 1169CCCCC CALL DPWRST('XXX','BUG ') 1170 IF(IBUGS2.EQ.'OFF')GOTO2009 1171CCCCC THE FOLLOWING LINE WAS ADDED OCTOBER 1991 1172 WRITE(ICOUT,999) 1173 CALL DPWRST('XXX','BUG ') 1174 WRITE(ICOUT,2001) 1175 2001 FORMAT('FROM THE MIDDLE OF DPDIME--') 1176 CALL DPWRST('XXX','BUG ') 1177 WRITE(ICOUT,2002)NUMCOL,NUMNAM,IBUGS2 1178 2002 FORMAT('NUMCOL,NUMNAM,IBUGS2 = ',I8,I8,2X,A4) 1179 CALL DPWRST('XXX','BUG ') 1180 2009 CONTINUE 1181C 1182 IF(NUMCOL.LE.0)GOTO2190 1183 DO2100ICOL=1,NUMCOL 1184 ICOLTG=ICOL 1185 IF(MAXNNE.GT.MAXNOL)ICOLTG=NUMCOL-ICOL+1 1186 IF(IBUGS2.EQ.'ON')WRITE(ICOUT,999) 1187 IF(IBUGS2.EQ.'ON')CALL DPWRST('XXX','BUG ') 1188 IF(IBUGS2.EQ.'ON')WRITE(ICOUT,2101)MAXNNE,MAXNOL,ICOL,ICOLTG 1189 2101 FORMAT('MAXNNE,MAXNOL,ICOL,ICOLTG = ',4I8) 1190 IF(IBUGS2.EQ.'ON')CALL DPWRST('XXX','BUG ') 1191C 1192 IDONE='NO' 1193 IF(NUMNAM.LE.0)GOTO2190 1194 DO2200INAM=1,NUMNAM 1195 IF(IVALUE(INAM).EQ.ICOLTG.AND.IUSE(INAM).EQ.'V')GOTO2210 1196 GOTO2200 1197 2210 CONTINUE 1198C 1199 IF(IDONE.EQ.'YES')GOTO2390 1200 NOLD=IN(INAM) 1201 IV1OLD=IVSTAR(INAM) 1202 IV2OLD=IVSTOP(INAM) 1203C 1204 IF(NOLD.LE.MAXNNE)NNEW=NOLD 1205 IF(NOLD.GT.MAXNNE)NNEW=MAXNNE 1206 IF(NOLD.LE.MAXNNE)GOTO2219 1207 IF(IFEEDB.EQ.'OFF')GOTO2218 1208 WRITE(ICOUT,2211)IHNAME(INAM),IHNAM2(INAM),ICOLTG 1209 2211 FORMAT(' NOTE--VARIABLE ',A4,A4,' (COLUMN ',I8,')') 1210 CALL DPWRST('XXX','BUG ') 1211 WRITE(ICOUT,2212)NOLD,MAXNNE 1212 2212 FORMAT(' TRUNCATED FROM ',I8,' TO ',I8, 1213 1' OBSERVATIONS') 1214 CALL DPWRST('XXX','BUG ') 1215 WRITE(ICOUT,2213) 1216 2213 FORMAT(' IN THE PROCESS OF REDIMENSIONING') 1217 CALL DPWRST('XXX','BUG ') 1218 2218 CONTINUE 1219 ITRUND='YES' 1220 2219 CONTINUE 1221C 1222 IV1NEW=MAXNNE*(ICOLTG-1)+1 1223 IV2NEW=MAXNNE*(ICOLTG-1)+NNEW 1224 IF(IBUGS2.EQ.'ON')WRITE(ICOUT,2221)NOLD,MAXNNE,NNEW 1225 2221 FORMAT('NOLD,MAXNNE,NNEW = ',3I8) 1226 IF(IBUGS2.EQ.'ON')CALL DPWRST('XXX','BUG ') 1227 IF(IBUGS2.EQ.'ON')WRITE(ICOUT,2222)IV1OLD,IV2OLD,IV1NEW,IV2NEW 1228 2222 FORMAT('IV1OLD,IV2OLD,IV1NEW,IV2NEW = ',4I8) 1229 IF(IBUGS2.EQ.'ON')CALL DPWRST('XXX','BUG ') 1230C 1231 J=IV1OLD-1 1232 IF(IV1NEW.GT.IV1OLD)GOTO2390 1233 DO2300I=IV1NEW,IV2NEW 1234 J=J+1 1235 V(I)=V(J) 1236 2300 CONTINUE 1237 IDONE='YES' 1238 2390 CONTINUE 1239C 1240 IVSTAR(INAM)=IV1NEW 1241 IVSTOP(INAM)=IV2NEW 1242 IN(INAM)=NNEW 1243 IF(IBUGS2.EQ.'ON')WRITE(ICOUT,2391)INAM,IVSTAR(INAM),IVSTOP(INAM), 1244 1IN(INAM) 1245 2391 FORMAT('INAM,IVSTAR(INAM),IVSTOP(INAM),IN(INAM) = ',4I8) 1246 IF(IBUGS2.EQ.'ON')CALL DPWRST('XXX','BUG ') 1247 2200 CONTINUE 1248C 1249 2100 CONTINUE 1250 2190 CONTINUE 1251C 1252 IF(ITRUND.EQ.'YES')GOTO2199 1253 IF(IFEEDB.EQ.'OFF')GOTO2199 1254 WRITE(ICOUT,2191) 1255 2191 FORMAT(' NOTE--NO DATA TRUNCATION OCCURRED FOR ANY ', 1256 1'VARIABLES') 1257 CALL DPWRST('XXX','BUG ') 1258 WRITE(ICOUT,2192) 1259 2192 FORMAT(' (COLUMNS) IN THE PROCESS OF REDIMENSIONING') 1260 CALL DPWRST('XXX','BUG ') 1261 2199 CONTINUE 1262C 1263C ********************************** 1264C ** STEP 14-- ** 1265C ** DETERMINE IF ANY VARIABLES ** 1266C ** NEED TO BE TRUNCRATED ** 1267C ********************************** 1268C 1269 ITRUNV='NO' 1270C 1271 IF(NUMCOL.LE.MAXCOL)GOTO3190 1272 NUMCOL=MAXCOL 1273 IDONE='NO' 1274C 1275 IF(NUMNAM.LE.0)GOTO3190 1276 INAM=0 1277 INAM=INAM+1 1278 IF(INAM.GT.NUMNAM)GOTO3200 1279 IF(IUSE(INAM).EQ.'V'.AND.IVALUE(INAM).GT.MAXCOL)GOTO3210 1280 GOTO3200 1281C 1282 3210 CONTINUE 1283 NUMNAM=NUMNAM-1 1284 ICOLV=IVALUE(INAM) 1285 IF(IFEEDB.EQ.'OFF')GOTO3219 1286 WRITE(ICOUT,3211)IHNAME(INAM),IHNAM2(INAM),ICOLV 1287 3211 FORMAT(' NOTE--VARIABLE ',A4,A4,' (COLUMN ',I8,')') 1288 CALL DPWRST('XXX','BUG ') 1289 WRITE(ICOUT,3212) 1290 3212 FORMAT(' DELETED IN THE PROCESS OF REDIMENSIONING') 1291 CALL DPWRST('XXX','BUG ') 1292 3219 CONTINUE 1293 ITRUNV='YES' 1294C 1295 NUMNM1=NUMNAM-1 1296 IF(INAM.GT.NUMNM1)GOTO3229 1297 DO3220I=INAM,NUMNM1 1298 IP1=I+1 1299 IHNAME(I)=IHNAME(IP1) 1300 IHNAM2(I)=IHNAM2(IP1) 1301 IUSE(I)=IUSE(IP1) 1302 IN(I)=IN(IP1) 1303 IVSTAR(I)=IVSTAR(IP1) 1304 IVSTOP(I)=IVSTOP(IP1) 1305 IVALUE(I)=IVALUE(IP1) 1306 VALUE(I)=VALUE(IP1) 1307 3220 CONTINUE 1308 3229 CONTINUE 1309 NUMNAM=NUMNAM-1 1310C 1311 3200 CONTINUE 1312C 1313 3190 CONTINUE 1314C 1315 IF(ITRUNV.EQ.'YES')GOTO3199 1316 IF(IFEEDB.EQ.'OFF')GOTO3199 1317 WRITE(ICOUT,3191) 1318 3191 FORMAT(' NOTE--NO VARIABLES WERE DELETED') 1319 CALL DPWRST('XXX','BUG ') 1320 WRITE(ICOUT,3192) 1321 3192 FORMAT(' IN THE PROCESS OF REDIMENSIONING') 1322 CALL DPWRST('XXX','BUG ') 1323 3199 CONTINUE 1324C 1325C *************************************** 1326C ** STEP 15-- ** 1327C ** REDEFINE THE COLUMN DESIGNATION ** 1328C ** FOR PRED (PREDICTED VALUE) ** 1329C ** RES (RESIDUALS) ** 1330C ** YPLOT ** 1331C ** XPLOT ** 1332C ** X2PLOT ** 1333C ** TAGPLOT ** 1334C *************************************** 1335C 1336 IF(NUMNAM.LE.0)GOTO4900 1337C 1338 DO4100I=1,NUMNAM 1339 I2=I 1340 IF(IHNAME(I).EQ.'PRED'.AND.IHNAM2(I).EQ.' ')GOTO4150 1341 4100 CONTINUE 1342 GOTO4190 1343 4150 CONTINUE 1344 IVALUE(I2)=MAXCOL+1 1345 VALUE(I2)=IVALUE(I2) 1346 GOTO4190 1347 4190 CONTINUE 1348C 1349 DO4200I=1,NUMNAM 1350 I2=I 1351 IF(IHNAME(I).EQ.'RES '.AND.IHNAM2(I).EQ.' ')GOTO4250 1352 4200 CONTINUE 1353 GOTO4290 1354 4250 CONTINUE 1355 IVALUE(I2)=MAXCOL+2 1356 VALUE(I2)=IVALUE(I2) 1357 GOTO4290 1358 4290 CONTINUE 1359C 1360 DO4300I=1,NUMNAM 1361 I2=I 1362 IF(IHNAME(I).EQ.'YPLO'.AND.IHNAM2(I).EQ.'T ')GOTO4350 1363 4300 CONTINUE 1364 GOTO4390 1365 4350 CONTINUE 1366 IVALUE(I2)=MAXCOL+3 1367 VALUE(I2)=IVALUE(I2) 1368 GOTO4390 1369 4390 CONTINUE 1370C 1371 DO4400I=1,NUMNAM 1372 I2=I 1373 IF(IHNAME(I).EQ.'XPLO'.AND.IHNAM2(I).EQ.'T ')GOTO4450 1374 4400 CONTINUE 1375 GOTO4490 1376 4450 CONTINUE 1377 IVALUE(I2)=MAXCOL+4 1378 VALUE(I2)=IVALUE(I2) 1379 GOTO4490 1380 4490 CONTINUE 1381C 1382 DO4500I=1,NUMNAM 1383 I2=I 1384 IF(IHNAME(I).EQ.'X2PL'.AND.IHNAM2(I).EQ.'OT ')GOTO4550 1385 4500 CONTINUE 1386 GOTO4590 1387 4550 CONTINUE 1388 IVALUE(I2)=MAXCOL+5 1389 VALUE(I2)=IVALUE(I2) 1390 GOTO4590 1391 4590 CONTINUE 1392C 1393 DO4600I=1,NUMNAM 1394 I2=I 1395 IF(IHNAME(I).EQ.'TAGP'.AND.IHNAM2(I).EQ.'LOT ')GOTO4650 1396 4600 CONTINUE 1397 GOTO4690 1398 4650 CONTINUE 1399 IVALUE(I2)=MAXCOL+6 1400 VALUE(I2)=IVALUE(I2) 1401 GOTO4690 1402 4690 CONTINUE 1403C 1404 4900 CONTINUE 1405C 1406C ***************** 1407C ** STEP 90-- ** 1408C ** EXIT. ** 1409C ***************** 1410C 1411 9000 CONTINUE 1412 IF(IBUGS2.EQ.'OFF')GOTO9090 1413 WRITE(ICOUT,999) 1414 CALL DPWRST('XXX','BUG ') 1415 WRITE(ICOUT,9011) 1416 9011 FORMAT('AT THE END OF DPDIME--') 1417 CALL DPWRST('XXX','BUG ') 1418 WRITE(ICOUT,9012)IBUGS2 1419 9012 FORMAT('IBUGS2 = ',A4) 1420 CALL DPWRST('XXX','BUG ') 1421 WRITE(ICOUT,9013)NUMNAM,MAXNAM 1422 9013 FORMAT('NUMNAM,MAXNAM = ',2I8) 1423 CALL DPWRST('XXX','BUG ') 1424 WRITE(ICOUT,9014)MAXNK 1425 9014 FORMAT('MAXNK = ',I8) 1426 CALL DPWRST('XXX','BUG ') 1427 WRITE(ICOUT,9015)NUMN,MAXN,MAXNXT 1428 9015 FORMAT('NUMN,MAXN,MAXNXT = ',3I8) 1429 CALL DPWRST('XXX','BUG ') 1430 WRITE(ICOUT,9016)NUMCOL,MAXCOL 1431 9016 FORMAT('NUMCOL,MAXCOL = ',2I8) 1432 CALL DPWRST('XXX','BUG ') 1433 WRITE(ICOUT,9017)MINR,MAXR,MINC,MAXC,MINRC,MAXRC 1434 9017 FORMAT('MINR,MAXR,MINC,MAXC,MINRC,MAXRC = ',6I8) 1435 CALL DPWRST('XXX','BUG ') 1436 WRITE(ICOUT,9018)ITEMPR,ITEMPC,ITEMRC 1437 9018 FORMAT('ITEMPR,ITEMPC,ITEMRC = ',3I8) 1438 CALL DPWRST('XXX','BUG ') 1439 WRITE(ICOUT,9021) 1440 9021 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),', 1441 1'IVSTAR(I),IVSTOP(I),IVALUE(I),VALUE(I)') 1442 CALL DPWRST('XXX','BUG ') 1443 IF(NUMNAM.LE.0)GOTO9024 1444 DO9022I=1,NUMNAM 1445 WRITE(ICOUT,9023)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I), 1446 1IVSTAR(I),IVSTOP(I),IVALUE(I),VALUE(I) 1447 9023 FORMAT(I8,2X,A4,2X,A4,2X,A4,4I8,E15.7) 1448 CALL DPWRST('XXX','BUG ') 1449 9022 CONTINUE 1450 9024 CONTINUE 1451 9090 CONTINUE 1452C 1453 RETURN 1454 END 1455 SUBROUTINE DPDIRE(ICOM,IHARG,NUMARG,IDEFDI,ITEXDI, 1456 1 IBUGD2,ISUBRO,IFOUND,IERROR) 1457C 1458C PURPOSE--DEFINE THE DIRECTION (HORIZONTAL OR VERTICAL) TYPE FOR 1459C THE TEXT COMMAND. THE DIRECTION (HORIZONTAL OR VERTICAL) 1460C FOR THE SCRIPT WILL BE PLACED IN THE CHARACTER VARIABLE 1461C ITEXDI. 1462C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 1463C --NUMARG 1464C --IDEFDI 1465C --IBUGD2 1466C OUTPUT ARGUMENTS--ITEXDI 1467C --IFOUND ('YES' OR 'NO' ) 1468C --IERROR ('YES' OR 'NO' ) 1469C WRITTEN BY--JAMES J. FILLIBEN 1470C STATISTICAL ENGINEERING DIVISION 1471C INFORMATION TECHNOLOGY LABORATORY 1472C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 1473C GAITHERSBURG, MD 20899-8980 1474C PHONE--301-975-2899 1475C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 1476C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 1477C LANGUAGE--ANSI FORTRAN (1977) 1478C VERSION NUMBER--2009/4 1479C ORIGINAL VERSION--APRIL 2009. 1480C 1481C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 1482C 1483 CHARACTER*4 ICOM 1484 CHARACTER*4 IHARG 1485 CHARACTER*4 IDEFDI 1486 CHARACTER*4 ITEXDI 1487 CHARACTER*4 IBUGD2 1488 CHARACTER*4 ISUBRO 1489 CHARACTER*4 IFOUND 1490 CHARACTER*4 IERROR 1491C 1492C--------------------------------------------------------------------- 1493C 1494 DIMENSION IHARG(*) 1495C 1496C--------------------------------------------------------------------- 1497C 1498 INCLUDE 'DPCOP2.INC' 1499C 1500C-----START POINT----------------------------------------------------- 1501C 1502 IFOUND='NO' 1503 IERROR='NO' 1504C 1505 IF(IBUGD2.EQ.'ON' .OR. ISUBRO.EQ.'DIRE')THEN 1506 WRITE(ICOUT,999) 1507 999 FORMAT(1X) 1508 CALL DPWRST('XXX','BUG ') 1509 WRITE(ICOUT,51) 1510 51 FORMAT('***** AT THE BEGINNING OF DPDIRE--') 1511 CALL DPWRST('XXX','BUG ') 1512 WRITE(ICOUT,53)ICOM,NUMARG,IDEFDI 1513 53 FORMAT('ICOM,NUMARG,IDEFDI = ',A4,2X,I8,2X,A4) 1514 CALL DPWRST('XXX','BUG ') 1515 DO55I=1,NUMARG 1516 WRITE(ICOUT,56)I,IHARG(I) 1517 56 FORMAT('I,IHARG(I) = ',I8,2X,A4) 1518 CALL DPWRST('XXX','BUG ') 1519 55 CONTINUE 1520 ENDIF 1521C 1522C ************************************************ 1523C ** TREAT THE CASE (UPPER VERSUS LOWER) CASE ** 1524C ************************************************ 1525C 1526 IF(ICOM.EQ.'DIRE')THEN 1527 IF(NUMARG.LE.0)GOTO1161 1528 IF(IHARG(NUMARG).EQ.'ON')GOTO1161 1529 IF(IHARG(NUMARG).EQ.'OFF')GOTO1162 1530 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1161 1531 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165 1532 IF(IHARG(NUMARG).EQ.'HORI')GOTO1161 1533 IF(IHARG(NUMARG).EQ.'VERT')GOTO1162 1534 IF(IHARG(NUMARG).EQ.'?')GOTO8100 1535 IF(IHARG(NUMARG).EQ.'HELP')GOTO8100 1536 GOTO1170 1537 ELSEIF(ICOM.EQ.'HORI')THEN 1538 IF(NUMARG.LE.0)GOTO9000 1539 IF(NUMARG.LE.0)GOTO1161 1540 IF(IHARG(NUMARG).EQ.'DIRE')GOTO1161 1541 IF(IHARG(NUMARG).EQ.'ON')GOTO1161 1542 IF(IHARG(NUMARG).EQ.'OFF')GOTO1162 1543 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1161 1544 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165 1545 ELSEIF(ICOM.EQ.'VERT')THEN 1546 IF(NUMARG.LE.0)GOTO9000 1547 IF(IHARG(1).NE.'CASE')GOTO9000 1548 IF(NUMARG.LE.1)GOTO1162 1549 IF(IHARG(NUMARG).EQ.'ON')GOTO1162 1550 IF(IHARG(NUMARG).EQ.'OFF')GOTO1161 1551 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1162 1552 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165 1553 ENDIF 1554 GOTO9000 1555C 1556 1161 CONTINUE 1557 ITEXDI='HORI' 1558 GOTO1180 1559C 1560 1162 CONTINUE 1561 ITEXDI='VERT' 1562 GOTO1180 1563C 1564 1165 CONTINUE 1565 ITEXDI=IDEFDI 1566 GOTO1180 1567C 1568 1170 CONTINUE 1569 IERROR='YES' 1570 WRITE(ICOUT,1171) 1571 1171 FORMAT('***** ERROR IN DIRECTION COMMAND--') 1572 CALL DPWRST('XXX','BUG ') 1573 WRITE(ICOUT,1172) 1574 1172 FORMAT(' UNKNOWN ENTRY FOR DIRECTION COMMAND. THE DIRECTION') 1575 CALL DPWRST('XXX','BUG ') 1576 WRITE(ICOUT,1173) 1577 1173 FORMAT(' SHOULD BE EITHER HORIZONTAL OR VERTICAL. FOR ', 1578 1 'EXAMPLE:') 1579 CALL DPWRST('XXX','BUG ') 1580 WRITE(ICOUT,1177) 1581 1177 FORMAT(' DIRECTION HORIZONTAL') 1582 CALL DPWRST('XXX','BUG ') 1583 WRITE(ICOUT,1178) 1584 1178 FORMAT(' DIRECTION VERTICAL') 1585 CALL DPWRST('XXX','BUG ') 1586 GOTO9000 1587C 1588 1180 CONTINUE 1589 IFOUND='YES' 1590C 1591 IF(IFEEDB.EQ.'ON')THEN 1592 WRITE(ICOUT,999) 1593 CALL DPWRST('XXX','BUG ') 1594 WRITE(ICOUT,1181) 1595 1181 FORMAT('THE CASE (FOR PLOT SCRIPT AND TEXT) ') 1596 CALL DPWRST('XXX','BUG ') 1597 WRITE(ICOUT,1182)ITEXDI 1598 1182 FORMAT('HAS JUST BEEN SET TO ',A4) 1599 CALL DPWRST('XXX','BUG ') 1600 ENDIF 1601 GOTO9000 1602C 1603C ******************************************** 1604C ** STEP 81-- ** 1605C ** TREAT THE ? CASE-- ** 1606C ** DUMP OUT CURRENT AND DEFAULT VALUES. ** 1607C ******************************************** 1608C 1609 8100 CONTINUE 1610 IFOUND='YES' 1611 WRITE(ICOUT,999) 1612 CALL DPWRST('XXX','BUG ') 1613 WRITE(ICOUT,8111)ITEXDI 1614 8111 FORMAT('THE CURRENT DIRECTION IS ',A4) 1615 CALL DPWRST('XXX','BUG ') 1616 WRITE(ICOUT,8112)IDEFDI 1617 8112 FORMAT('THE DEFAULT DIRECTION IS ',A4) 1618 CALL DPWRST('XXX','BUG ') 1619 GOTO9000 1620C 1621C ***************** 1622C ** STEP 90-- ** 1623C ** EXIT ** 1624C ***************** 1625C 1626 9000 CONTINUE 1627 IF(IBUGD2.EQ.'ON' .OR. ISUBRO.EQ.'DIRE')THEN 1628 WRITE(ICOUT,999) 1629 CALL DPWRST('XXX','BUG ') 1630 WRITE(ICOUT,9011) 1631 9011 FORMAT('***** AT THE END OF DPDIRE--') 1632 CALL DPWRST('XXX','BUG ') 1633 WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR 1634 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 1635 CALL DPWRST('XXX','BUG ') 1636 WRITE(ICOUT,9013)ITEXDI,IDEFDI 1637 9013 FORMAT('ITEXDI,IDEFDI = ',A4,2X,A4) 1638 CALL DPWRST('XXX','BUG ') 1639 ENDIF 1640C 1641 RETURN 1642 END 1643 SUBROUTINE DPDIXO(XTEMP1,MAXNXT, 1644 1 ICAPSW,ICASAN,IFORSW,ISEED, 1645 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 1646C 1647C PURPOSE--PERFORM DIXON TEST FOR UNIVARIATE OUTLIERS (DIXON 1648C TEST LOOKS FOR A SINGLE OUTLIER AND ASSUMES THE 1649C DATA FOLLOWS AN APPROXIMATELY NORMAL DISRIBUTION). 1650C WRITTEN BY--ALAN HECKERT 1651C STATISTICAL ENGINEERING DIVISION 1652C INFORMATION TECHNOLOGY LABORAOTRY 1653C NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY 1654C GAITHERSBURG, MD 20899-8980 1655C PHONE--301-975-2899 1656C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 1657C OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY. 1658C LANGUAGE--ANSI FORTRAN (1977) 1659C VERSION NUMBER--2009/11 1660C ORIGINAL VERSION--NOVEMBER 2009. 1661C UPDATED --JULY 2019. TWEAK SCRATCH STORAGE 1662C 1663C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 1664C 1665 CHARACTER*4 ICASAN 1666 CHARACTER*4 ICAPSW 1667 CHARACTER*4 IFORSW 1668 CHARACTER*4 IBUGA2 1669 CHARACTER*4 IBUGA3 1670 CHARACTER*4 IBUGQ 1671 CHARACTER*4 ISUBRO 1672 CHARACTER*4 IFOUND 1673 CHARACTER*4 IERROR 1674C 1675 CHARACTER*4 IWRITE 1676 CHARACTER*4 ICASP2 1677 CHARACTER*4 IRANSV 1678 CHARACTER*4 IDATSW 1679 CHARACTER*4 ISUBN1 1680 CHARACTER*4 ISUBN2 1681 CHARACTER*4 ISTEPN 1682C 1683 CHARACTER*4 IFLAGU 1684 LOGICAL IFRST 1685 LOGICAL ILAST 1686C 1687 CHARACTER*4 IREPL 1688 CHARACTER*4 IMULT 1689 CHARACTER*4 ICTMP1 1690 CHARACTER*4 ICTMP2 1691 CHARACTER*4 ICASE 1692 CHARACTER*4 IOP 1693C 1694 CHARACTER*40 INAME 1695 PARAMETER (MAXSPN=30) 1696 CHARACTER*4 IVARN1(MAXSPN) 1697 CHARACTER*4 IVARN2(MAXSPN) 1698 CHARACTER*4 IVARTY(MAXSPN) 1699 CHARACTER*4 IVARID(MAXSPN) 1700 CHARACTER*4 IVARI2(MAXSPN) 1701 REAL PVAR(MAXSPN) 1702 REAL PID(MAXSPN) 1703 INTEGER ILIS(MAXSPN) 1704 INTEGER NRIGHT(MAXSPN) 1705 INTEGER ICOLR(MAXSPN) 1706C 1707C--------------------------------------------------------------------- 1708C 1709 INCLUDE 'DPCOPA.INC' 1710 INCLUDE 'DPCOZZ.INC' 1711C 1712 DIMENSION Y1(MAXOBV) 1713 DIMENSION X1(MAXOBV) 1714 DIMENSION XTEMP1(MAXOBV) 1715 DIMENSION XTEMP2(MAXOBV) 1716 DIMENSION XTEMP3(MAXOBV) 1717 DIMENSION YSTAT(MAXOBV) 1718 DIMENSION XIDTEM(MAXOBV) 1719 DIMENSION XIDTE2(MAXOBV) 1720 DIMENSION XIDTE3(MAXOBV) 1721 DIMENSION XIDTE4(MAXOBV) 1722 DIMENSION XIDTE5(MAXOBV) 1723 DIMENSION XIDTE6(MAXOBV) 1724 DIMENSION TEMP1(MAXOBV) 1725 DIMENSION TEMP2(MAXOBV) 1726 DIMENSION XDESGN(MAXOBV,7) 1727C 1728 EQUIVALENCE (GARBAG(IGARB1),Y1(1)) 1729 EQUIVALENCE (GARBAG(IGARB2),X1(1)) 1730 EQUIVALENCE (GARBAG(IGARB4),XTEMP2(1)) 1731 EQUIVALENCE (GARBAG(IGARB5),XTEMP3(1)) 1732 EQUIVALENCE (GARBAG(IGARB6),TEMP1(1)) 1733 EQUIVALENCE (GARBAG(IGARB7),TEMP2(1)) 1734 EQUIVALENCE (GARBAG(IGARB8),XIDTEM(1)) 1735 EQUIVALENCE (GARBAG(IGARB9),XIDTE2(1)) 1736 EQUIVALENCE (GARBAG(IGAR10),XIDTE3(1)) 1737 EQUIVALENCE (GARBAG(IGAR11),XIDTE4(1)) 1738 EQUIVALENCE (GARBAG(JGAR12),XIDTE5(1)) 1739 EQUIVALENCE (GARBAG(JGAR13),XIDTE6(1)) 1740 EQUIVALENCE (GARBAG(JGAR14),YSTAT(1)) 1741 EQUIVALENCE (GARBAG(JGAR15),XDESGN(1,1)) 1742C 1743C-----COMMON---------------------------------------------------------- 1744C 1745 INCLUDE 'DPCOHK.INC' 1746 INCLUDE 'DPCODA.INC' 1747 INCLUDE 'DPCOSU.INC' 1748 INCLUDE 'DPCOS2.INC' 1749 INCLUDE 'DPCOHO.INC' 1750 INCLUDE 'DPCOMC.INC' 1751 INCLUDE 'DPCOST.INC' 1752 INCLUDE 'DPCOF2.INC' 1753C 1754 COMMON/ISED/ISED1,ISED2,ISED3,ISED4,ISED5,ISED6, 1755 1 ISED7,ISED8,ISED9,ISED10,ISED11 1756C 1757C-----COMMON VARIABLES (GENERAL)-------------------------------------- 1758C 1759 INCLUDE 'DPCOP2.INC' 1760C 1761C-----START POINT----------------------------------------------------- 1762C 1763 IERROR='NO' 1764 ICASAN=' ' 1765 IREPL='OFF' 1766 IMULT='OFF' 1767 IRANSV=IRANAL 1768 IRANAL='FINC' 1769 ISEESV=ISEED 1770 ISEED=2503 1771 ISUBN1='DPDI' 1772 ISUBN2='XO ' 1773C 1774 MAXCP1=MAXCOL+1 1775 MAXCP2=MAXCOL+2 1776 MAXCP3=MAXCOL+3 1777 MAXCP4=MAXCOL+4 1778 MAXCP5=MAXCOL+5 1779 MAXCP6=MAXCOL+6 1780C 1781 MINN2=3 1782C 1783C *************************************************** 1784C ** TREAT THE GRUBB TEST CASE ** 1785C *************************************************** 1786C 1787 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'DIXO')THEN 1788 WRITE(ICOUT,999) 1789 999 FORMAT(1X) 1790 CALL DPWRST('XXX','BUG ') 1791 WRITE(ICOUT,51) 1792 51 FORMAT('***** AT THE BEGINNING OF DPDIXO--') 1793 CALL DPWRST('XXX','BUG ') 1794 WRITE(ICOUT,52)ICASAN,MAXNXT 1795 52 FORMAT('ICASAN,MAXNXT = ',A4,2X,I8) 1796 CALL DPWRST('XXX','BUG ') 1797 WRITE(ICOUT,53)IBUGA2,IBUGA3,IBUGQ 1798 53 FORMAT('IBUGA2,IBUGA3,IBUGQ = ',2(A4,2X),A4) 1799 CALL DPWRST('XXX','BUG ') 1800 ENDIF 1801C 1802C ********************************************************* 1803C ** STEP 1-- ** 1804C ** EXTRACT THE COMMAND ** 1805C ** LOOK FOR ONE OF THE FOLLOWING COMMANDS: ** 1806C ** 1) DIXON TEST Y ** 1807C ** 2) DIXON TEST Y LABID ** 1808C ** 3) MULTIPLE DIXON TEST Y1 ... YK ** 1809C ** 4) REPLICATED DIXON TEST Y X1 ... XK ** 1810C ** 5) REPLICATED DIXON TEST Y LABID X1 ... XK ** 1811C ** REPLICATED DIXON TEST Y X1 ... XK LABID ** 1812C ********************************************************* 1813C 1814 ISTEPN='1' 1815 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DIXO') 1816 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1817C 1818 ILASTC=9999 1819 ILASTZ=9999 1820 IFOUND='NO' 1821 ICASAN='DI2S' 1822C 1823 DO100I=0,NUMARG-1 1824C 1825 IF(I.EQ.0)THEN 1826 ICTMP1=ICOM 1827 ICTMP2=IHARG(I+1) 1828 ELSE 1829 ICTMP1=IHARG(I) 1830 ICTMP2=IHARG(I+1) 1831 ENDIF 1832C 1833 IF(ICTMP1.EQ.'DIXO' .AND. ICTMP2.EQ.'TEST')THEN 1834 IFOUND='YES' 1835 ILASTC=I 1836 ILASTZ=I+1 1837 ELSEIF(ICTMP1.EQ.'DIXO')THEN 1838 IFOUND='YES' 1839 ILASTC=I 1840 ILASTZ=I 1841 ELSEIF(ICTMP1.EQ.'TEST')THEN 1842 ILASTC=I 1843 ILASTZ=MAX(ILASTZ,I) 1844 ELSEIF(ICTMP1.EQ.'MINI')THEN 1845 ICASAN='MINI' 1846 ILASTC=MIN(ILASTC,I) 1847 ILASTZ=MAX(ILASTZ,I) 1848 ELSEIF(ICTMP1.EQ.'MAXI')THEN 1849 ICASAN='MAXI' 1850 ILASTC=MIN(ILASTC,I) 1851 ILASTZ=MAX(ILASTZ,I) 1852 ELSEIF(ICTMP1.EQ.'REPL')THEN 1853 IREPL='ON' 1854 ILASTC=MIN(ILASTC,I) 1855 ILASTZ=MAX(ILASTZ,I) 1856 ELSEIF(ICTMP1.EQ.'MULT')THEN 1857 IMULT='ON' 1858 ILASTC=MIN(ILASTC,I) 1859 ILASTZ=MAX(ILASTZ,I) 1860 ENDIF 1861 100 CONTINUE 1862C 1863 ISHIFT=ILASTZ 1864 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1865 1 IBUGA2,IERROR) 1866C 1867 IF(IFOUND.EQ.'NO')GOTO9000 1868 IF(IMULT.EQ.'ON')THEN 1869 IF(IREPL.EQ.'ON')THEN 1870 WRITE(ICOUT,999) 1871 CALL DPWRST('XXX','BUG ') 1872 WRITE(ICOUT,101) 1873 101 FORMAT('***** ERROR IN DIXON TEST--') 1874 CALL DPWRST('XXX','BUG ') 1875 WRITE(ICOUT,102) 1876 102 FORMAT(' YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ', 1877 1 '"REPLICATION" FOR THE DIXON TEST COMMAND.') 1878 CALL DPWRST('XXX','BUG ') 1879 IERROR='YES' 1880 GOTO9000 1881 ENDIF 1882 ENDIF 1883C 1884C ********************************* 1885C ** STEP 4-- ** 1886C ** EXTRACT THE VARIABLE LIST ** 1887C ********************************* 1888C 1889 ISTEPN='4' 1890 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DIXO') 1891 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1892C 1893 INAME='DIXON TEST FOR OUTLIERS' 1894 MINNA=1 1895 MAXNA=100 1896 MINN2=2 1897 IFLAGE=1 1898 IF(IMULT.EQ.'ON')IFLAGE=0 1899 IFLAGM=1 1900 IF(IREPL.EQ.'ON')IFLAGM=0 1901 IFLAGP=0 1902 JMIN=1 1903 JMAX=NUMARG 1904 MINNVA=-99 1905 MAXNVA=-99 1906C 1907 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 1908 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 1909 1 JMIN,JMAX, 1910 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 1911 1 IVARN1,IVARN2,IVARTY,PVAR, 1912 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 1913 1 MINNVA,MAXNVA, 1914 1 IFLAGM,IFLAGP, 1915 1 IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 1916 IF(IERROR.EQ.'YES')GOTO9000 1917C 1918 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DIXO')THEN 1919 WRITE(ICOUT,999) 1920 CALL DPWRST('XXX','BUG ') 1921 WRITE(ICOUT,281) 1922 281 FORMAT('***** AFTER CALL DPPARS--') 1923 CALL DPWRST('XXX','BUG ') 1924 WRITE(ICOUT,282)NQ,NUMVAR 1925 282 FORMAT('NQ,NUMVAR = ',2I8) 1926 CALL DPWRST('XXX','BUG ') 1927 IF(NUMVAR.GT.0)THEN 1928 DO285I=1,NUMVAR 1929 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 1930 1 ICOLR(I) 1931 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 1932 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 1933 CALL DPWRST('XXX','BUG ') 1934 285 CONTINUE 1935 ENDIF 1936 ENDIF 1937C 1938C *********************************************** 1939C ** STEP 5-- ** 1940C ** DETERMINE: ** 1941C ** 1) NUMBER OF REPLICATION VARIABLES (0-6) ** 1942C ** 2) NUMBER OF RESPONSE VARIABLES (>= 1)** 1943C *********************************************** 1944C 1945 ISTEPN='5' 1946 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DIXO') 1947 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1948C 1949 NRESP=0 1950 NREPL=0 1951 NLABID=0 1952 IF(IMULT.EQ.'ON')THEN 1953 NRESP=NUMVAR 1954 ELSEIF(IREPL.EQ.'ON')THEN 1955 NRESP=1 1956 IF(NUMVAR.EQ.2)THEN 1957 NLABID=0 1958 NREPL=1 1959 ELSE 1960 NLABID=1 1961 NREPL=NUMVAR-NRESP-NLABID 1962 ENDIF 1963 IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN 1964 WRITE(ICOUT,999) 1965 CALL DPWRST('XXX','BUG ') 1966 WRITE(ICOUT,101) 1967 CALL DPWRST('XXX','BUG ') 1968 WRITE(ICOUT,511) 1969 511 FORMAT(' FOR THE REPLICATION CASE, THE NUMBER OF ', 1970 1 'REPLICATION VARIABLES') 1971 CALL DPWRST('XXX','BUG ') 1972 WRITE(ICOUT,513)NREPL 1973 513 FORMAT(' THE NUMBER OF REPLICATION VARIABLES = ',I5) 1974 CALL DPWRST('XXX','BUG ') 1975 IERROR='YES' 1976 GOTO9000 1977 ENDIF 1978 ELSE 1979 NRESP=1 1980 NLABID=NUMVAR-NRESP 1981 IF(NLABID.GT.1)NLABID=1 1982 ENDIF 1983C 1984 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DIXO')THEN 1985 WRITE(ICOUT,521)NRESP,NLABID,NREPL 1986 521 FORMAT('NRESP,NLABID,NREPL = ',3I5) 1987 CALL DPWRST('XXX','BUG ') 1988 ENDIF 1989C 1990 IOP='OPEN' 1991 IFLAG1=0 1992 IFLAG2=1 1993 IFLAG3=0 1994 IFLAG4=0 1995 IFLAG5=0 1996 CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5, 1997 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 1998 1 IBUGA3,ISUBRO,IERROR) 1999 IF(IERROR.EQ.'YES')GOTO9000 2000C 2001C 2002C ****************************************************** 2003C ** STEP 6-- ** 2004C ** GENERATE THE DIXON TEST FOR THE VARIOUS CASES ** 2005C ****************************************************** 2006C 2007 ISTEPN='6' 2008 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DIXO') 2009 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2010C 2011C ***************************************** 2012C ** STEP 7A-- ** 2013C ** CASE 1: SINGLE RESPONSE VARIABLE ** 2014C ** WITH NO REPLICATION ** 2015C ***************************************** 2016C 2017 IF(NRESP.EQ.1 .AND. NREPL.EQ.0)THEN 2018 ISTEPN='7A' 2019 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DIXO') 2020 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2021C 2022 PID(1)=CPUMIN 2023 IVARID(1)=IVARN1(1) 2024 IVARI2(1)=IVARN2(1) 2025C 2026 ICOL=1 2027 NUMVA2=1 2028 IF(NLABID.GE.1)NUMVA2=2 2029 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 2030 1 INAME,IVARN1,IVARN2,IVARTY, 2031 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 2032 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 2033 1 MAXCP4,MAXCP5,MAXCP6, 2034 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 2035 1 Y1,X1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE, 2036 1 IBUGA3,ISUBRO,IFOUND,IERROR) 2037 IF(IERROR.EQ.'YES')GOTO9000 2038C 2039C ***************************************************** 2040C ** STEP 7B-- ** 2041C ** CALL DPDIX2 TO PERFORM THE DIXON TEST. ** 2042C ***************************************************** 2043C 2044C 2045 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'DIXO')THEN 2046 ISTEPN='7B' 2047 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2048 WRITE(ICOUT,999) 2049 CALL DPWRST('XXX','BUG ') 2050 WRITE(ICOUT,711) 2051 711 FORMAT('***** FROM THE MIDDLE OF DPDIXO--') 2052 CALL DPWRST('XXX','BUG ') 2053 WRITE(ICOUT,712)ICASAN,NUMVAR,IDATSW,NLOCAL 2054 712 FORMAT('ICASAN,NUMVAR,IDATSW,NLOCAL = ', 2055 1 A4,I8,2X,A4,I8) 2056 CALL DPWRST('XXX','BUG ') 2057 IF(NLOCAL.GE.1)THEN 2058 DO715I=1,NLOCAL 2059 WRITE(ICOUT,716)I,Y1(I),X1(I) 2060 716 FORMAT('I,Y1(I),X1(I) = ',I8,2F12.5) 2061 CALL DPWRST('XXX','BUG ') 2062 715 CONTINUE 2063 ENDIF 2064 ENDIF 2065C 2066 NCURVE=1 2067 CALL DPDIX2(Y1,X1,NLOCAL,ICASAN,MAXOBV, 2068 1 YSTAT,XTEMP1,XTEMP2,XTEMP3, 2069 1 PID,IVARID,IVARI2,NCURVE,NREPL,NLABID, 2070 1 IOUNI2,ISEED, 2071 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 2072 1 STATVA,STATCD,PVAL, 2073 1 CUT0,CUT25,CUT50,CUT75,CUT80,CUT90, 2074 1 CUT95,CUT975,CUT99,CUT995,CUT100, 2075 1 ISUBRO,IBUGA3,IERROR) 2076C 2077C *************************************** 2078C ** STEP 7C-- ** 2079C ** COMPUTE DIXON STAT ** 2080C ** UPDATE INTERNAL DATAPLOT TABLES ** 2081C *************************************** 2082C 2083 ISTEPN='7C' 2084 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DIXO') 2085 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2086C 2087 IFLAGU='ON' 2088 IFRST=.FALSE. 2089 ILAST=.FALSE. 2090 CALL DPGRU4(STATVA,STATCD,PVAL, 2091 1 CUT0,CUT50,CUT75,CUT90,CUT95,CUT975,CUT99,CUT100, 2092 1 IFLAGU,IFRST,ILAST,ICASP2, 2093 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 2094C 2095C ****************************************** 2096C ** STEP 8A-- ** 2097C ** CASE 2: MULTIPLE RESPONSE VARIABLES ** 2098C ** NOTE THAT A LABID VARIABLE ** 2099C ** IS NOT SUPPORTED FOR THIS ** 2100C ** CASE. ** 2101C ****************************************** 2102C 2103 ELSEIF(NRESP.GT.1)THEN 2104 ISTEPN='8A' 2105 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DIXO') 2106 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2107C 2108C LOOP THROUGH EACH OF THE RESPONSE VARIABLES 2109C 2110 NCURVE=0 2111 DO810IRESP=1,NRESP 2112 NCURVE=NCURVE+1 2113C 2114 IINDX=ICOLR(IRESP) 2115 PID(1)=CPUMIN 2116 IVARID(1)=IVARN1(IRESP) 2117 IVARI2(1)=IVARN2(IRESP) 2118C 2119 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DIXO')THEN 2120 WRITE(ICOUT,999) 2121 CALL DPWRST('XXX','BUG ') 2122 WRITE(ICOUT,811)IRESP,NCURVE 2123 811 FORMAT('IRESP,NCURVE = ',2I5) 2124 CALL DPWRST('XXX','BUG ') 2125 ENDIF 2126C 2127 ICOL=IRESP 2128 NUMVA2=1 2129 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 2130 1 INAME,IVARN1,IVARN2,IVARTY, 2131 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 2132 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 2133 1 MAXCP4,MAXCP5,MAXCP6, 2134 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 2135 1 Y1,XTEMP1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE, 2136 1 IBUGA3,ISUBRO,IFOUND,IERROR) 2137 IF(IERROR.EQ.'YES')GOTO9000 2138 DO820I=1,NLOCAL 2139 X1(I)=REAL(I) 2140 820 CONTINUE 2141C 2142C ***************************************************** 2143C ** STEP 8B-- ** 2144C ** CALL DPDIX2 TO PERFORM THE DIXON TEST ** 2145C ***************************************************** 2146C 2147 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'DIXO')THEN 2148 ISTEPN='8B' 2149 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2150 WRITE(ICOUT,999) 2151 CALL DPWRST('XXX','BUG ') 2152 WRITE(ICOUT,822) 2153 822 FORMAT('***** FROM THE MIDDLE OF DPDIXO--') 2154 CALL DPWRST('XXX','BUG ') 2155 WRITE(ICOUT,823)ICASAN,NUMVAR,IDATSW,NLOCAL 2156 823 FORMAT('ICASAN,NUMVAR,IDATSW,NQ = ', 2157 1 A4,I8,2X,A4,I8) 2158 CALL DPWRST('XXX','BUG ') 2159 IF(NLOCAL.GE.1)THEN 2160 DO825I=1,NLOCAL 2161 WRITE(ICOUT,826)I,Y1(I),X1(I) 2162 826 FORMAT('I,Y1(I),X1(I) = ',I8,2F12.5) 2163 CALL DPWRST('XXX','BUG ') 2164 825 CONTINUE 2165 ENDIF 2166 ENDIF 2167C 2168 CALL DPDIX2(Y1,X1,NLOCAL,ICASAN,MAXOBV, 2169 1 YSTAT,XTEMP1,XTEMP2,XTEMP3, 2170 1 PID,IVARID,IVARI2,NCURVE,NREPL,NLABID, 2171 1 IOUNI2,ISEED, 2172 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 2173 1 STATVA,STATCD,PVAL, 2174 1 CUT0,CUT25,CUT50,CUT75,CUT80,CUT90, 2175 1 CUT95,CUT975,CUT99,CUT995,CUT100, 2176 1 ISUBRO,IBUGA3,IERROR) 2177C 2178C *************************************** 2179C ** STEP 8C-- ** 2180C ** COMPUTE GRUBB STAT ** 2181C ** UPDATE INTERNAL DATAPLOT TABLES ** 2182C *************************************** 2183C 2184 ISTEPN='8C' 2185 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DIXO') 2186 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2187C 2188 IFLAGU='FILE' 2189 IFRST=.FALSE. 2190 ILAST=.FALSE. 2191 IF(IRESP.EQ.1)IFRST=.TRUE. 2192 IF(IRESP.EQ.NRESP)ILAST=.TRUE. 2193 IFLAGU='ON' 2194 IFRST=.FALSE. 2195 ILAST=.FALSE. 2196 CALL DPGRU4(STATVA,STATCD,PVAL, 2197 1 CUT0,CUT50,CUT75,CUT90,CUT95,CUT975,CUT99,CUT100, 2198 1 IFLAGU,IFRST,ILAST,ICASP2, 2199 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 2200C 2201 810 CONTINUE 2202C 2203C **************************************************** 2204C ** STEP 9A-- ** 2205C ** CASE 3: ONE OR MORE REPLICATION VARIABLES. ** 2206C ** FOR THIS CASE, THE NUMBER OF RESPONSE ** 2207C ** VARIABLES MUST BE EXACTLY 1. ** 2208C ** FOR THIS CASE, ALL VARIABLES MUST ** 2209C ** HAVE THE SAME LENGTH. ** 2210C **************************************************** 2211C 2212 ELSEIF(IREPL.EQ.'ON')THEN 2213 ISTEPN='9A' 2214 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DIXO') 2215 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2216C 2217 J=0 2218 IMAX=NRIGHT(1) 2219 IF(NQ.LT.NRIGHT(1))IMAX=NQ 2220 DO910I=1,IMAX 2221 IF(ISUB(I).EQ.0)GOTO910 2222 J=J+1 2223C 2224C RESPONSE VARIABLE IN Y1 2225C 2226 ICOLC=1 2227 IJ=MAXN*(ICOLR(ICOLC)-1)+I 2228 IF(ICOLR(ICOLC).LE.MAXCOL)Y1(J)=V(IJ) 2229 IF(ICOLR(ICOLC).EQ.MAXCP1)Y1(J)=PRED(I) 2230 IF(ICOLR(ICOLC).EQ.MAXCP2)Y1(J)=RES(I) 2231 IF(ICOLR(ICOLC).EQ.MAXCP3)Y1(J)=YPLOT(I) 2232 IF(ICOLR(ICOLC).EQ.MAXCP4)Y1(J)=XPLOT(I) 2233 IF(ICOLR(ICOLC).EQ.MAXCP5)Y1(J)=X2PLOT(I) 2234 IF(ICOLR(ICOLC).EQ.MAXCP6)Y1(J)=TAGPLO(I) 2235C 2236C LABID VARIABLE IN X1 2237C 2238 IF(NLABID.GE.1)THEN 2239 ICOLC=ICOLC+1 2240 ICOLT=ICOLR(ICOLC) 2241 IJ=MAXN*(ICOLT-1)+I 2242 IF(ICOLT.LE.MAXCOL)X1(J)=V(IJ) 2243 IF(ICOLT.EQ.MAXCP1)X1(J)=PRED(I) 2244 IF(ICOLT.EQ.MAXCP2)X1(J)=RES(I) 2245 IF(ICOLT.EQ.MAXCP3)X1(J)=YPLOT(I) 2246 IF(ICOLT.EQ.MAXCP4)X1(J)=XPLOT(I) 2247 IF(ICOLT.EQ.MAXCP5)X1(J)=X2PLOT(I) 2248 IF(ICOLT.EQ.MAXCP6)X1(J)=TAGPLO(I) 2249 ELSE 2250 X1(J)=REAL(I) 2251 ENDIF 2252C 2253 IF(NREPL.GE.1)THEN 2254 DO920IR=1,MIN(NREPL,6) 2255 ICOLC=ICOLC+1 2256 ICOLT=ICOLR(ICOLC) 2257 IJ=MAXN*(ICOLT-1)+I 2258 IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ) 2259 IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I) 2260 IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I) 2261 IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I) 2262 IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I) 2263 IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I) 2264 IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I) 2265 920 CONTINUE 2266 ENDIF 2267C 2268 910 CONTINUE 2269 NLOCAL=J 2270C 2271 ISTEPN='9B' 2272 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DIXO') 2273 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2274C 2275C NOTE: CHECK TO SEE IF X1 HAS ALL UNIQUE ELEMENTS. IF NOT, 2276C THEN INTERPRET THIS AS A REPLICATION VARIABLE. 2277C 2278 CALL DISTIN(X1,NLOCAL,IWRITE,XTEMP2,NDIST,IBUGA3,IERROR) 2279 IF(NLOCAL.NE.NDIST)THEN 2280 NLABID=0 2281 IF(NREPL.GT.6)NREPL=6 2282 IF(NREPL.GE.1)THEN 2283 DO930J=1,NREPL-1 2284 DO935I=1,NLOCAL 2285 XDESGN(I,J+1)=XDESGN(I,J) 2286 935 CONTINUE 2287 930 CONTINUE 2288 ENDIF 2289 NREPL=NREPL+1 2290 DO938I=1,NLOCAL 2291 XDESGN(I,1)=X1(I) 2292 X1(I)=REAL(I) 2293 938 CONTINUE 2294 ENDIF 2295C 2296 PID(1)=CPUMIN 2297 IVARID(1)=IVARN1(1) 2298 IVARI2(1)=IVARN2(1) 2299 IF(NLABID.EQ.1)THEN 2300 PID(2)=CPUMIN 2301 IVARID(2)=IVARN1(2) 2302 IVARI2(2)=IVARN2(2) 2303 ENDIF 2304 IADD=NRESP+NLABID 2305 DO940II=1,NREPL 2306 IVARID(II+IADD)=IVARN1(II+IADD) 2307 IVARI2(II+IADD)=IVARN2(II+IADD) 2308 940 CONTINUE 2309C 2310C ***************************************************** 2311C ** STEP 9B-- ** 2312C ** CALL DPDIX2 TO PERFORM THE DIXON TEST. ** 2313C ***************************************************** 2314C 2315C 2316 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'DIXO')THEN 2317 ISTEPN='9C' 2318 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2319 WRITE(ICOUT,999) 2320 CALL DPWRST('XXX','BUG ') 2321 WRITE(ICOUT,941) 2322 941 FORMAT('***** FROM THE MIDDLE OF DPDIXO--') 2323 CALL DPWRST('XXX','BUG ') 2324 WRITE(ICOUT,942)ICASAN,NUMVAR,IDATSW,NLOCAL,NREPL 2325 942 FORMAT('ICASAN,NUMVAR,IDATSW,NLOCAL,NREPL = ', 2326 1 A4,I8,2X,A4,2I8) 2327 CALL DPWRST('XXX','BUG ') 2328 IF(NLOCAL.GE.1)THEN 2329 DO945I=1,NLOCAL 2330 WRITE(ICOUT,946)I,Y1(I),X1(I),XDESGN(I,1),XDESGN(I,2) 2331 946 FORMAT('I,Y1(I),X1(I),XDESGN(I,1),XDESGN(I,2) = ', 2332 1 I8,4F12.5) 2333 CALL DPWRST('XXX','BUG ') 2334 945 CONTINUE 2335 ENDIF 2336 ENDIF 2337C 2338C ***************************************************** 2339C ** STEP 9C-- ** 2340C ** FIND THE DISTINCT VALUES IN EACH OF THE ** 2341C ** REPLICATION VARIABLES. ** 2342C ***************************************************** 2343C 2344 CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3), 2345 1 XDESGN(1,4),XDESGN(1,5),XDESGN(1,6), 2346 1 NREPL,NLOCAL,MAXOBV, 2347 1 XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6, 2348 1 XTEMP1,XTEMP2, 2349 1 NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6, 2350 1 IBUGA3,ISUBRO,IERROR) 2351C 2352C ***************************************************** 2353C ** STEP 9D-- ** 2354C ** NOW LOOP THROUGH THE VARIOUS REPLICATIONS ** 2355C ***************************************************** 2356C 2357 NPLOTP=0 2358 NCURVE=0 2359 IF(NREPL.EQ.1)THEN 2360 J=0 2361 DO1110ISET1=1,NUMSE1 2362 K=0 2363 PID(IADD+1)=XIDTEM(ISET1) 2364 DO1130I=1,NLOCAL 2365 IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN 2366 K=K+1 2367 TEMP1(K)=Y1(I) 2368 TEMP2(K)=X1(I) 2369 ENDIF 2370 1130 CONTINUE 2371 NTEMP=K 2372 NCURVE=NCURVE+1 2373 NPLOT1=NPLOTP 2374 IF(NTEMP.GT.0)THEN 2375 CALL DPDIX2(TEMP1,TEMP2,NTEMP,ICASAN,MAXOBV, 2376 1 YSTAT,XTEMP1,XTEMP2,XTEMP3, 2377 1 PID,IVARID,IVARI2,NCURVE,NREPL,NLABID, 2378 1 IOUNI2,ISEED, 2379 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 2380 1 STATVA,STATCD,PVAL, 2381 1 CUT0,CUT25,CUT50,CUT75,CUT80,CUT90, 2382 1 CUT95,CUT975,CUT99,CUT995,CUT100, 2383 1 ISUBRO,IBUGA3,IERROR) 2384 ENDIF 2385 NPLOT2=NPLOTP 2386 IFLAGU='FILE' 2387 IFRST=.FALSE. 2388 ILAST=.FALSE. 2389 IF(NCURVE.EQ.1)IFRST=.TRUE. 2390 IF(NCURVE.EQ.NUMSE1)ILAST=.TRUE. 2391 NPTEMP=NPLOT2-NPLOT1 2392 CALL DPGRU4(STATVA,STATCD,PVAL, 2393 1 CUT0,CUT50,CUT75,CUT90,CUT95, 2394 1 CUT975,CUT99,CUT100, 2395 1 IFLAGU,IFRST,ILAST,ICASP2, 2396 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 2397 1110 CONTINUE 2398 ELSEIF(NREPL.EQ.2)THEN 2399 J=0 2400 NTOT=NUMSE1*NUMSE2 2401 DO1210ISET1=1,NUMSE1 2402 DO1220ISET2=1,NUMSE2 2403 K=0 2404 PID(1+IADD)=XIDTEM(ISET1) 2405 PID(2+IADD)=XIDTE2(ISET2) 2406 DO1290I=1,NLOCAL 2407 IF( 2408 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 2409 1 XIDTE2(ISET2).EQ.XDESGN(I,2) 2410 1 )THEN 2411 K=K+1 2412 TEMP1(K)=Y1(I) 2413 TEMP2(K)=X1(I) 2414 ENDIF 2415 1290 CONTINUE 2416 NTEMP=K 2417 NCURVE=NCURVE+1 2418 NPLOT1=NPLOTP 2419 IF(NTEMP.GT.0)THEN 2420 CALL DPDIX2(TEMP1,TEMP2,NTEMP,ICASAN,MAXOBV, 2421 1 YSTAT,XTEMP1,XTEMP2,XTEMP3, 2422 1 PID,IVARID,IVARI2,NCURVE,NREPL,NLABID, 2423 1 IOUNI2,ISEED, 2424 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 2425 1 STATVA,STATCD,PVAL, 2426 1 CUT0,CUT25,CUT50,CUT75,CUT80,CUT90, 2427 1 CUT95,CUT975,CUT99,CUT995,CUT100, 2428 1 ISUBRO,IBUGA3,IERROR) 2429 ENDIF 2430 NPLOT2=NPLOTP 2431 IFLAGU='FILE' 2432 IFRST=.FALSE. 2433 ILAST=.FALSE. 2434 IF(NCURVE.EQ.1)IFRST=.TRUE. 2435 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 2436 NPTEMP=NPLOT2-NPLOT1 2437 CALL DPGRU4(STATVA,STATCD,PVAL, 2438 1 CUT0,CUT50,CUT75,CUT90,CUT95, 2439 1 CUT975,CUT99,CUT100, 2440 1 IFLAGU,IFRST,ILAST,ICASP2, 2441 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 2442 1220 CONTINUE 2443 1210 CONTINUE 2444 ELSEIF(NREPL.EQ.3)THEN 2445 J=0 2446 NTOT=NUMSE1*NUMSE2*NUMSE3 2447 DO1310ISET1=1,NUMSE1 2448 DO1320ISET2=1,NUMSE2 2449 DO1330ISET3=1,NUMSE3 2450 K=0 2451 PID(1+IADD)=XIDTEM(ISET1) 2452 PID(2+IADD)=XIDTE2(ISET2) 2453 PID(3+IADD)=XIDTE3(ISET3) 2454 DO1390I=1,NLOCAL 2455 IF( 2456 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 2457 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 2458 1 XIDTE3(ISET3).EQ.XDESGN(I,3) 2459 1 )THEN 2460 K=K+1 2461 TEMP1(K)=Y1(I) 2462 TEMP2(K)=X1(I) 2463 ENDIF 2464 1390 CONTINUE 2465 NTEMP=K 2466 NCURVE=NCURVE+1 2467 NPLOT1=NPLOTP 2468 IF(NTEMP.GT.0)THEN 2469 CALL DPDIX2(TEMP1,TEMP2,NTEMP,ICASAN,MAXOBV, 2470 1 YSTAT,XTEMP1,XTEMP2,XTEMP3, 2471 1 PID,IVARID,IVARI2,NCURVE,NREPL,NLABID, 2472 1 IOUNI2,ISEED, 2473 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 2474 1 STATVA,STATCD,PVAL, 2475 1 CUT0,CUT25,CUT50,CUT75,CUT80,CUT90, 2476 1 CUT95,CUT975,CUT99,CUT995,CUT100, 2477 1 ISUBRO,IBUGA3,IERROR) 2478 ENDIF 2479 NPLOT2=NPLOTP 2480 IFLAGU='FILE' 2481 IFRST=.FALSE. 2482 ILAST=.FALSE. 2483 IF(NCURVE.EQ.1)IFRST=.TRUE. 2484 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 2485 NPTEMP=NPLOT2-NPLOT1 2486 CALL DPGRU4(STATVA,STATCD,PVAL, 2487 1 CUT0,CUT50,CUT75,CUT90,CUT95, 2488 1 CUT975,CUT99,CUT100, 2489 1 IFLAGU,IFRST,ILAST,ICASP2, 2490 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 2491 1330 CONTINUE 2492 1320 CONTINUE 2493 1310 CONTINUE 2494 ELSEIF(NREPL.EQ.4)THEN 2495 J=0 2496 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4 2497 DO1410ISET1=1,NUMSE1 2498 DO1420ISET2=1,NUMSE2 2499 DO1430ISET3=1,NUMSE3 2500 DO1440ISET4=1,NUMSE4 2501 K=0 2502 PID(1+IADD)=XIDTEM(ISET1) 2503 PID(2+IADD)=XIDTE2(ISET2) 2504 PID(3+IADD)=XIDTE3(ISET3) 2505 PID(4+IADD)=XIDTE4(ISET4) 2506 DO1490I=1,NLOCAL 2507 IF( 2508 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 2509 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 2510 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 2511 1 XIDTE4(ISET4).EQ.XDESGN(I,4) 2512 1 )THEN 2513 K=K+1 2514 TEMP1(K)=Y1(I) 2515 TEMP2(K)=X1(I) 2516 ENDIF 2517 1490 CONTINUE 2518 NTEMP=K 2519 NCURVE=NCURVE+1 2520 NPLOT1=NPLOTP 2521 IF(NTEMP.GT.0)THEN 2522 CALL DPDIX2(TEMP1,TEMP2,NTEMP,ICASAN,MAXOBV, 2523 1 YSTAT,XTEMP1,XTEMP2,XTEMP3, 2524 1 PID,IVARID,IVARI2,NCURVE,NREPL,NLABID, 2525 1 IOUNI2,ISEED, 2526 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 2527 1 STATVA,STATCD,PVAL, 2528 1 CUT0,CUT25,CUT50,CUT75,CUT80,CUT90, 2529 1 CUT95,CUT975,CUT99,CUT995,CUT100, 2530 1 ISUBRO,IBUGA3,IERROR) 2531 ENDIF 2532 NPLOT2=NPLOTP 2533 IFLAGU='FILE' 2534 IFRST=.FALSE. 2535 ILAST=.FALSE. 2536 IF(NCURVE.EQ.1)IFRST=.TRUE. 2537 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 2538 NPTEMP=NPLOT2-NPLOT1 2539 CALL DPGRU4(STATVA,STATCD,PVAL, 2540 1 CUT0,CUT50,CUT75,CUT90,CUT95, 2541 1 CUT975,CUT99,CUT100, 2542 1 IFLAGU,IFRST,ILAST,ICASP2, 2543 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 2544 1440 CONTINUE 2545 1430 CONTINUE 2546 1420 CONTINUE 2547 1410 CONTINUE 2548 ELSEIF(NREPL.EQ.5)THEN 2549 J=0 2550 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5 2551 DO1510ISET1=1,NUMSE1 2552 DO1520ISET2=1,NUMSE2 2553 DO1530ISET3=1,NUMSE3 2554 DO1540ISET4=1,NUMSE4 2555 DO1550ISET5=1,NUMSE5 2556 K=0 2557 PID(1+IADD)=XIDTEM(ISET1) 2558 PID(2+IADD)=XIDTE2(ISET2) 2559 PID(3+IADD)=XIDTE3(ISET3) 2560 PID(4+IADD)=XIDTE4(ISET4) 2561 PID(5+IADD)=XIDTE5(ISET4) 2562 DO1590I=1,NLOCAL 2563 IF( 2564 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 2565 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 2566 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 2567 1 XIDTE4(ISET4).EQ.XDESGN(I,4) .AND. 2568 1 XIDTE5(ISET5).EQ.XDESGN(I,5) 2569 1 )THEN 2570 K=K+1 2571 TEMP1(K)=Y1(I) 2572 TEMP2(K)=X1(I) 2573 ENDIF 2574 1590 CONTINUE 2575 NTEMP=K 2576 NCURVE=NCURVE+1 2577 NPLOT1=NPLOTP 2578 IF(NTEMP.GT.0)THEN 2579 CALL DPDIX2(TEMP1,TEMP2,NTEMP,ICASAN,MAXOBV, 2580 1 YSTAT,XTEMP1,XTEMP2,XTEMP3, 2581 1 PID,IVARID,IVARI2,NCURVE,NREPL,NLABID, 2582 1 IOUNI2,ISEED, 2583 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 2584 1 STATVA,STATCD,PVAL, 2585 1 CUT0,CUT25,CUT50,CUT75,CUT80,CUT90, 2586 1 CUT95,CUT975,CUT99,CUT995,CUT100, 2587 1 ISUBRO,IBUGA3,IERROR) 2588 ENDIF 2589 NPLOT2=NPLOTP 2590 IFLAGU='FILE' 2591 IFRST=.FALSE. 2592 ILAST=.FALSE. 2593 IF(NCURVE.EQ.1)IFRST=.TRUE. 2594 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 2595 NPTEMP=NPLOT2-NPLOT1 2596 CALL DPGRU4(STATVA,STATCD,PVAL, 2597 1 CUT0,CUT50,CUT75,CUT90,CUT95, 2598 1 CUT975,CUT99,CUT100, 2599 1 IFLAGU,IFRST,ILAST,ICASP2, 2600 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 2601 1550 CONTINUE 2602 1540 CONTINUE 2603 1530 CONTINUE 2604 1520 CONTINUE 2605 1510 CONTINUE 2606 ELSEIF(NREPL.EQ.6)THEN 2607 J=0 2608 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6 2609 DO1610ISET1=1,NUMSE1 2610 DO1620ISET2=1,NUMSE2 2611 DO1630ISET3=1,NUMSE3 2612 DO1640ISET4=1,NUMSE4 2613 DO1650ISET5=1,NUMSE5 2614 DO1660ISET6=1,NUMSE6 2615 K=0 2616 PID(1+IADD)=XIDTEM(ISET1) 2617 PID(2+IADD)=XIDTE2(ISET2) 2618 PID(3+IADD)=XIDTE3(ISET3) 2619 PID(4+IADD)=XIDTE4(ISET4) 2620 PID(5+IADD)=XIDTE5(ISET4) 2621 PID(6+IADD)=XIDTE6(ISET4) 2622 DO1690I=1,NLOCAL 2623 IF( 2624 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 2625 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 2626 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 2627 1 XIDTE4(ISET4).EQ.XDESGN(I,4) .AND. 2628 1 XIDTE5(ISET5).EQ.XDESGN(I,5) .AND. 2629 1 XIDTE6(ISET6).EQ.XDESGN(I,6) 2630 1 )THEN 2631 K=K+1 2632 TEMP1(K)=Y1(I) 2633 TEMP2(K)=X1(I) 2634 ENDIF 2635 1690 CONTINUE 2636 NTEMP=K 2637 NCURVE=NCURVE+1 2638 NPLOT1=NPLOTP 2639 IF(NTEMP.GT.0)THEN 2640 CALL DPDIX2(TEMP1,TEMP2,NTEMP,ICASAN,MAXOBV, 2641 1 YSTAT,XTEMP1,XTEMP2,XTEMP3, 2642 1 PID,IVARID,IVARI2,NCURVE,NREPL,NLABID, 2643 1 IOUNI2,ISEED, 2644 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 2645 1 STATVA,STATCD,PVAL, 2646 1 CUT0,CUT25,CUT50,CUT75,CUT80,CUT90, 2647 1 CUT95,CUT975,CUT99,CUT995,CUT100, 2648 1 ISUBRO,IBUGA3,IERROR) 2649 ENDIF 2650 NPLOT2=NPLOTP 2651 IFLAGU='FILE' 2652 IFRST=.FALSE. 2653 ILAST=.FALSE. 2654 IF(NCURVE.EQ.1)IFRST=.TRUE. 2655 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 2656 NPTEMP=NPLOT2-NPLOT1 2657 CALL DPGRU4(STATVA,STATCD,PVAL, 2658 1 CUT0,CUT50,CUT75,CUT90,CUT95, 2659 1 CUT975,CUT99,CUT100, 2660 1 IFLAGU,IFRST,ILAST,ICASP2, 2661 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 2662 1660 CONTINUE 2663 1650 CONTINUE 2664 1640 CONTINUE 2665 1630 CONTINUE 2666 1620 CONTINUE 2667 1610 CONTINUE 2668 ENDIF 2669C 2670 ENDIF 2671C 2672C ***************** 2673C ** STEP 90-- ** 2674C ** EXIT ** 2675C ***************** 2676C 2677 9000 CONTINUE 2678C 2679 IRANAL=IRANSV 2680 ISEED=ISEESV 2681C 2682 IOP='CLOS' 2683 CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5, 2684 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 2685 1 IBUGA3,ISUBRO,IERROR) 2686C 2687 IF(IERROR.EQ.'YES')THEN 2688 IF(IWIDTH.GE.1)THEN 2689 WRITE(ICOUT,9001)(IANS(I),I=1,MIN(100,IWIDTH)) 2690 9001 FORMAT(100A1) 2691 CALL DPWRST('XXX','BUG ') 2692 ENDIF 2693 ENDIF 2694C 2695 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'DIXO')THEN 2696 WRITE(ICOUT,999) 2697 CALL DPWRST('XXX','BUG ') 2698 WRITE(ICOUT,9011) 2699 9011 FORMAT('***** AT THE END OF DPDIXO--') 2700 CALL DPWRST('XXX','BUG ') 2701 WRITE(ICOUT,9012)IFOUND,IERROR 2702 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 2703 CALL DPWRST('XXX','BUG ') 2704 WRITE(ICOUT,9013)NPLOTP,NS,ICASAN 2705 9013 FORMAT('NPLOTP,NS,ICASAN = ',I8,I8,2X,A4) 2706 CALL DPWRST('XXX','BUG ') 2707 ENDIF 2708C 2709 RETURN 2710 END 2711 SUBROUTINE DPDIX2(Y,X,N,ICASAN,MAXNXT, 2712 1 YSTAT,TEMP1,TEMP2,TEMP3, 2713 1 PID,IVARID,IVARI2,NCURVE,NREPL,NLABID, 2714 1 IOUNI2,ISEED, 2715 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 2716 1 STATVA,STATCD,PVAL, 2717 1 CUT0,CUT25,CUT50,CUT75,CUT80,CUT90, 2718 1 CUT95,CUT975,CUT99,CUT995,CUT100, 2719 1 ISUBRO,IBUGA3,IERROR) 2720C 2721C PURPOSE--THIS ROUTINE CARRIES OUT THE DIXON TEST FOR UNIVARIATE 2722C OUTLIERS (DATA ASSUMED TO FOLLOW AN APPROXIMATELY NORMAL 2723C DISTRIBUTION). 2724C EXAMPLE--DIXON TEST Y 2725C REFERENCES--DIXON (1953), "PROCESSING DATA FOR OUTLIERS", 2726C BIOMETRICS, VOL. 9, NO. 1, PP. 74-89. 2727C WRITTEN BY--ALAN HECKERT 2728C STATISTICAL ENGINEERING DIVISION 2729C INFORMATION TECHNOLOGY LABORATORY 2730C NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY 2731C GAITHERSBURG, MD 20899-8980 2732C PHONE--301-975-2899 2733C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 2734C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 2735C LANGUAGE--ANSI FORTRAN (1977) 2736C VERSION NUMBER--2009/11 2737C ORIGINAL VERSION--NOVEMBER 2009. 2738C UPDATED --JULY 2014. ADD SKEWNESS AND KURTOSIS TO 2739C SUMMARY STATISTICS 2740C 2741C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 2742C 2743 CHARACTER*4 ISUBRO 2744 CHARACTER*4 IBUGA3 2745 CHARACTER*4 IERROR 2746 CHARACTER*4 IVARID(*) 2747 CHARACTER*4 IVARI2(*) 2748 CHARACTER*4 ICAPSW 2749 CHARACTER*4 ICAPTY 2750 CHARACTER*4 IFORSW 2751 CHARACTER*4 IDIR 2752 CHARACTER*4 ICASAN 2753C 2754 CHARACTER*40 IRTFFF 2755 CHARACTER*40 IRTFFP 2756C 2757 CHARACTER*4 IWRITE 2758 CHARACTER*1 IBASLC 2759C 2760 CHARACTER*4 ISUBN1 2761 CHARACTER*4 ISUBN2 2762 CHARACTER*4 ISTEPN 2763C 2764 CHARACTER*4 IRTFMD 2765 COMMON/COMRTF/IRTFMD 2766C 2767 PARAMETER (NUMALP=11) 2768 REAL ALPHA(NUMALP) 2769C 2770 PARAMETER(NUMCLI=4) 2771 PARAMETER(MAXLIN=2) 2772 PARAMETER (MAXROW=50) 2773 CHARACTER*60 ITITLE 2774 CHARACTER*60 ITITLZ 2775 CHARACTER*1 ITITL9 2776 CHARACTER*60 ITEXT(MAXROW) 2777 CHARACTER*4 ALIGN(NUMCLI) 2778 CHARACTER*4 VALIGN(NUMCLI) 2779 REAL AVALUE(MAXROW) 2780 INTEGER NCTEXT(MAXROW) 2781 INTEGER IDIGIT(MAXROW) 2782 INTEGER NTOT(MAXROW) 2783 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 2784 CHARACTER*15 IVALUE(MAXROW,NUMCLI) 2785 CHARACTER*4 ITYPCO(NUMCLI) 2786 INTEGER NCTIT2(MAXLIN,NUMCLI) 2787 INTEGER NCVALU(MAXROW,NUMCLI) 2788 INTEGER IWHTML(NUMCLI) 2789 INTEGER IWRTF(NUMCLI) 2790 REAL AMAT(MAXROW,NUMCLI) 2791 LOGICAL IFRST 2792 LOGICAL ILAST 2793 LOGICAL IFLAG1 2794 LOGICAL IFLAG2 2795 LOGICAL IFLAG3 2796C 2797C--------------------------------------------------------------------- 2798C 2799 DIMENSION Y(*) 2800 DIMENSION X(*) 2801 DIMENSION YSTAT(*) 2802 DIMENSION TEMP1(*) 2803 DIMENSION TEMP2(*) 2804 DIMENSION TEMP3(*) 2805 DIMENSION PID(*) 2806C 2807C--------------------------------------------------------------------- 2808C 2809 INCLUDE 'DPCOP2.INC' 2810C 2811 DATA ALPHA/ 2812 1 0.0, 25.0, 50.0, 75.0, 80.0, 90.0, 95.0, 2813 1 97.5, 99.0, 99.5, 100.0/ 2814C 2815C-----START POINT----------------------------------------------------- 2816C 2817 ISUBN1='DPDI' 2818 ISUBN2='X2 ' 2819 IERROR='NO' 2820 STATVA=CPUMIN 2821 STATCD=CPUMIN 2822 PVAL=CPUMIN 2823 CUT0=CPUMIN 2824 CUT25=CPUMIN 2825 CUT50=CPUMIN 2826 CUT75=CPUMIN 2827 CUT80=CPUMIN 2828 CUT90=CPUMIN 2829 CUT95=CPUMIN 2830 CUT975=CPUMIN 2831 CUT99=CPUMIN 2832 CUT995=CPUMIN 2833 CUT100=CPUMIN 2834C 2835 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DIX2')THEN 2836 WRITE(ICOUT,999) 2837 999 FORMAT(1X) 2838 CALL DPWRST('XXX','WRIT') 2839 WRITE(ICOUT,51) 2840 51 FORMAT('**** AT THE BEGINNING OF DPDIX2--') 2841 CALL DPWRST('XXX','WRIT') 2842 WRITE(ICOUT,52)ISUBRO,IBUGA3,ICASAN 2843 52 FORMAT('ISUBRO,IBUGA3,ICASAN = ',3(A4,2X)) 2844 CALL DPWRST('XXX','WRIT') 2845 WRITE(ICOUT,55)N,MAXNXT 2846 55 FORMAT('N,MAXNXT = ',2I8) 2847 CALL DPWRST('XXX','WRIT') 2848 DO56I=1,MIN(N,100) 2849 WRITE(ICOUT,57)I,Y(I),X(I) 2850 57 FORMAT('I,Y(I),X(I) = ',I8,2G15.7) 2851 CALL DPWRST('XXX','WRIT') 2852 56 CONTINUE 2853 ENDIF 2854C 2855C ******************************************** 2856C ** STEP 11-- ** 2857C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 2858C ******************************************** 2859C 2860 ISTEPN='11' 2861 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DIX2') 2862 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2863C 2864 IF(N.LT.3)THEN 2865 WRITE(ICOUT,999) 2866 CALL DPWRST('XXX','WRIT') 2867 WRITE(ICOUT,1111) 2868 1111 FORMAT('***** ERROR IN DIXON OUTLIER TEST--') 2869 CALL DPWRST('XXX','WRIT') 2870 WRITE(ICOUT,1113) 2871 1113 FORMAT(' THE NUMBER OF OBSERVATIONS IS LESS THAN 3.') 2872 CALL DPWRST('XXX','WRIT') 2873 WRITE(ICOUT,1114)N 2874 1114 FORMAT('SAMPLE SIZE = ',I8) 2875 CALL DPWRST('XXX','WRIT') 2876 IERROR='YES' 2877 GOTO9000 2878 ENDIF 2879C 2880 HOLD=Y(1) 2881 DO1135I=2,N 2882 IF(Y(I).NE.HOLD)GOTO1139 2883 1135 CONTINUE 2884 WRITE(ICOUT,999) 2885 CALL DPWRST('XXX','WRIT') 2886 WRITE(ICOUT,1111) 2887 CALL DPWRST('XXX','WRIT') 2888 WRITE(ICOUT,1131)HOLD 2889 1131 FORMAT(' THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7) 2890 CALL DPWRST('XXX','WRIT') 2891 IERROR='YES' 2892 GOTO9000 2893 1139 CONTINUE 2894C 2895C ****************************** 2896C ** STEP 21-- ** 2897C ** CARRY OUT CALCULATIONS ** 2898C ** FOR DIXON OUTLIER TEST ** 2899C ****************************** 2900C 2901 ISTEPN='21' 2902 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DIX2') 2903 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2904C 2905 IWRITE='OFF' 2906 CALL MINIM(Y,N,IWRITE,YMIN,IBUGA3,IERROR) 2907 CALL MAXIM(Y,N,IWRITE,YMAX,IBUGA3,IERROR) 2908 CALL MEAN(Y,N,IWRITE,YMEAN,IBUGA3,IERROR) 2909 CALL SD(Y,N,IWRITE,YSD,IBUGA3,IERROR) 2910 CALL RANGDP(Y,N,IWRITE,YRANGE,IBUGA3,IERROR) 2911 CALL STMOM3(Y,N,IWRITE,YSKEW,IBUGA3,IERROR) 2912 CALL STMOM4(Y,N,IWRITE,YKURT,IBUGA3,IERROR) 2913C 2914 INDMIN=-99 2915 INDMAX=99 2916 DO2105I=1,N 2917 IF(Y(I).EQ.YMIN)INDMIN=I 2918 IF(Y(I).EQ.YMAX)INDMAX=I 2919 2105 CONTINUE 2920C 2921 CALL DPDIX3(Y,X,N,TEMP1,IWRITE,ICASAN, 2922 1 STATVA, 2923 1 ISUBRO,IBUGA3,IERROR) 2924C 2925 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DIX2')THEN 2926 WRITE(ICOUT,2211)STATVA 2927 2211 FORMAT('STATVA = ',G15.7) 2928 CALL DPWRST('XXX','BUG ') 2929 WRITE(ICOUT,2213)YMIN,YMAX,YMEAN,YSD 2930 2213 FORMAT('YMIN,YMAX,YMEAN,YSD = ',4G15.7) 2931 CALL DPWRST('XXX','BUG ') 2932 ENDIF 2933C 2934C ************************************ 2935C ** STEP 22-- ** 2936C ** COMPUTE CRITICAL VALUES VIA ** 2937C ** MONTE-CARLO SIMULATION ** 2938C ************************************ 2939C 2940 ISTEPN='22' 2941 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DIX2') 2942 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2943C 2944CCCCC NMCSAM=10000 2945 NMCSAM=25000 2946 NTEMP=N 2947 DO2210I=1,NMCSAM 2948C 2949 DO2212J=1,NTEMP 2950 TEMP3(J)=REAL(J) 2951 2212 CONTINUE 2952C 2953 CALL NORRAN(NTEMP,ISEED,TEMP2) 2954 CALL DPDIX3(TEMP2,TEMP3,NTEMP,TEMP1,IWRITE,ICASAN, 2955 1 STATV2, 2956 1 ISUBRO,IBUGA3,IERROR) 2957 YSTAT(I)=STATV2 2958 WRITE(IOUNI2,'(3I8,2X,E15.7)')NCURVE,NREPL,I,YSTAT(I) 2959 2210 CONTINUE 2960 IDIR='LOWE' 2961 CALL DPGOF8(YSTAT,NMCSAM,STATVA,PVAL,IDIR, 2962 1 IBUGA3,ISUBRO,IERROR) 2963 STATCD=PVAL 2964 PVAL=1.0 - STATCD 2965 CUT0=YSTAT(1) 2966 CUT100=YSTAT(NMCSAM) 2967 IWRITE='OFF' 2968 DO2220I=2,NUMALP-1 2969 P100=ALPHA(I) 2970 CALL PERCEN(P100,YSTAT,NMCSAM,IWRITE,TEMP1,NMCSAM, 2971 1 XSTAT,IBUGA3,IERROR) 2972 IF(I.EQ.2)CUT25=XSTAT 2973 IF(I.EQ.3)CUT50=XSTAT 2974 IF(I.EQ.4)CUT75=XSTAT 2975 IF(I.EQ.5)CUT80=XSTAT 2976 IF(I.EQ.6)CUT90=XSTAT 2977 IF(I.EQ.7)CUT95=XSTAT 2978 IF(I.EQ.8)CUT975=XSTAT 2979 IF(I.EQ.9)CUT99=XSTAT 2980 IF(I.EQ.10)CUT995=XSTAT 2981 2220 CONTINUE 2982C 2983 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DIX2')THEN 2984 WRITE(ICOUT,2231)PVAL,STATCD,CUT0,CUT25,CUT50,CUT75 2985 2231 FORMAT('PVAL,STATCD,CUT0,CUT25,CUT50,CUT75 = ',6G15.7) 2986 CALL DPWRST('XXX','WRIT') 2987 WRITE(ICOUT,2233)CUT80,CUT90,CUT95,CUT975,CUT99,CUT995,CUT100 2988 2233 FORMAT('CUT80,CUT90,CUT95,CUT975,CUT99,CUT995,CUT100 = ',7G15.7) 2989 CALL DPWRST('XXX','WRIT') 2990 ENDIF 2991C 2992C ********************************* 2993C ** STEP 42-- ** 2994C ** WRITE OUT EVERYTHING ** 2995C ** FOR DIXON TEST ** 2996C ********************************* 2997C 2998 ISTEPN='42' 2999 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DIX2') 3000 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3001C 3002 IF(IPRINT.EQ.'OFF')GOTO9000 3003C 3004 NUMDIG=7 3005 IF(IFORSW.EQ.'1')NUMDIG=1 3006 IF(IFORSW.EQ.'2')NUMDIG=2 3007 IF(IFORSW.EQ.'3')NUMDIG=3 3008 IF(IFORSW.EQ.'4')NUMDIG=4 3009 IF(IFORSW.EQ.'5')NUMDIG=5 3010 IF(IFORSW.EQ.'6')NUMDIG=6 3011 IF(IFORSW.EQ.'7')NUMDIG=7 3012 IF(IFORSW.EQ.'8')NUMDIG=8 3013 IF(IFORSW.EQ.'9')NUMDIG=9 3014 IF(IFORSW.EQ.'0')NUMDIG=0 3015 IF(IFORSW.EQ.'E')NUMDIG=-2 3016 IF(IFORSW.EQ.'-2')NUMDIG=-2 3017 IF(IFORSW.EQ.'-3')NUMDIG=-3 3018 IF(IFORSW.EQ.'-4')NUMDIG=-4 3019 IF(IFORSW.EQ.'-5')NUMDIG=-5 3020 IF(IFORSW.EQ.'-6')NUMDIG=-6 3021 IF(IFORSW.EQ.'-7')NUMDIG=-7 3022 IF(IFORSW.EQ.'-8')NUMDIG=-8 3023 IF(IFORSW.EQ.'-9')NUMDIG=-9 3024C 3025 IF(ICASAN.EQ.'DI2S')THEN 3026 ITITLE= 3027 1 'Dixon Test for a Single Outlier: Two-Sided Case' 3028 NCTITL=47 3029 ELSEIF(ICASAN.EQ.'MINI')THEN 3030 ITITLE='Dixon Test for a Single Outlier: Minimum Case' 3031 NCTITL=52 3032 ELSEIF(ICASAN.EQ.'MAXI')THEN 3033 ITITLE='Dixon Test for a Single Outlier: Maximum Case' 3034 NCTITL=52 3035 ENDIF 3036 ITITLZ='(Assumption: Normality)' 3037 NCTITZ=23 3038C 3039 ICNT=1 3040 ITEXT(ICNT)=' ' 3041 NCTEXT(ICNT)=0 3042 AVALUE(ICNT)=0.0 3043 IDIGIT(ICNT)=-1 3044 ICNT=ICNT+1 3045 ITEXT(ICNT)='Response Variable: ' 3046 WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4) 3047 WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4) 3048 NCTEXT(ICNT)=27 3049 AVALUE(ICNT)=0.0 3050 IDIGIT(ICNT)=-1 3051C 3052 IF(NREPL.GT.0)THEN 3053 NRESP=1 3054 IADD=NLABID+NRESP 3055 DO4101I=1,NREPL 3056 ICNT=ICNT+1 3057 ITEMP=I+IADD 3058 ITEXT(ICNT)='Factor Variable : ' 3059 WRITE(ITEXT(ICNT)(17:17),'(I1)')I 3060 WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4) 3061 WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4) 3062 NCTEXT(ICNT)=27 3063 AVALUE(ICNT)=PID(ITEMP) 3064 IDIGIT(ICNT)=NUMDIG 3065 4101 CONTINUE 3066 ENDIF 3067C 3068 ICNT=ICNT+1 3069 ITEXT(ICNT)=' ' 3070 NCTEXT(ICNT)=1 3071 AVALUE(ICNT)=0.0 3072 IDIGIT(ICNT)=-1 3073C 3074 ICNT=ICNT+1 3075 ITEXT(ICNT)='H0: There are no outliers' 3076 NCTEXT(ICNT)=25 3077 AVALUE(ICNT)=0.0 3078 IDIGIT(ICNT)=-1 3079 ICNT=ICNT+1 3080C 3081 ITEXT(ICNT)=' ' 3082 IF(ICASAN.EQ.'DI2S')THEN 3083 ITEXT(ICNT)(1:40)='Ha: The most extreme point is an outlier' 3084 NCTEXT(ICNT)=40 3085 ELSEIF(ICASAN.EQ.'MINI')THEN 3086 ITEXT(ICNT)(1:35)='Ha: The minimum point is an outlier' 3087 NCTEXT(ICNT)=35 3088 ELSEIF(ICASAN.EQ.'MAXI')THEN 3089 ITEXT(ICNT)(1:35)='Ha: The maximum point is an outlier' 3090 NCTEXT(ICNT)=35 3091 ENDIF 3092 AVALUE(ICNT)=0.0 3093 IDIGIT(ICNT)=-1 3094C 3095 ICNT=ICNT+1 3096 ITEXT(ICNT)=' ' 3097 NCTEXT(ICNT)=1 3098 AVALUE(ICNT)=0.0 3099 IDIGIT(ICNT)=-1 3100 ICNT=ICNT+1 3101 ITEXT(ICNT)='Summary Statistics:' 3102 NCTEXT(ICNT)=19 3103 AVALUE(ICNT)=0.0 3104 IDIGIT(ICNT)=-1 3105 ICNT=ICNT+1 3106 ITEXT(ICNT)='Number of Observations:' 3107 NCTEXT(ICNT)=23 3108 AVALUE(ICNT)=REAL(N) 3109 IDIGIT(ICNT)=0 3110 ICNT=ICNT+1 3111 ITEXT(ICNT)='Sample Minimum:' 3112 NCTEXT(ICNT)=15 3113 AVALUE(ICNT)=YMIN 3114 IDIGIT(ICNT)=NUMDIG 3115 ICNT=ICNT+1 3116 ITEXT(ICNT)='ID for Sample Minimum:' 3117 NCTEXT(ICNT)=22 3118 AVALUE(ICNT)=X(INDMIN) 3119 IDIGIT(ICNT)=0 3120 ICNT=ICNT+1 3121 ITEXT(ICNT)='Sample Maximum:' 3122 NCTEXT(ICNT)=15 3123 AVALUE(ICNT)=YMAX 3124 IDIGIT(ICNT)=NUMDIG 3125 ICNT=ICNT+1 3126 ITEXT(ICNT)='ID for Sample Maximum:' 3127 NCTEXT(ICNT)=22 3128 AVALUE(ICNT)=X(INDMAX) 3129 IDIGIT(ICNT)=0 3130 ICNT=ICNT+1 3131 ITEXT(ICNT)='Sample Mean:' 3132 NCTEXT(ICNT)=12 3133 AVALUE(ICNT)=YMEAN 3134 IDIGIT(ICNT)=NUMDIG 3135 ICNT=ICNT+1 3136 ITEXT(ICNT)='Sample SD:' 3137 NCTEXT(ICNT)=10 3138 AVALUE(ICNT)=YSD 3139 IDIGIT(ICNT)=NUMDIG 3140 ICNT=ICNT+1 3141 ITEXT(ICNT)='Sample Range:' 3142 NCTEXT(ICNT)=13 3143 AVALUE(ICNT)=YRANGE 3144 IDIGIT(ICNT)=NUMDIG 3145 ICNT=ICNT+1 3146 ITEXT(ICNT)='Sample Skewness:' 3147 NCTEXT(ICNT)=16 3148 AVALUE(ICNT)=YSKEW 3149 IDIGIT(ICNT)=NUMDIG 3150 ICNT=ICNT+1 3151 ITEXT(ICNT)='Sample Kurtosis:' 3152 NCTEXT(ICNT)=16 3153 AVALUE(ICNT)=YKURT 3154 IDIGIT(ICNT)=NUMDIG 3155 ICNT=ICNT+1 3156 ITEXT(ICNT)=' ' 3157 NCTEXT(ICNT)=1 3158 AVALUE(ICNT)=0.0 3159 IDIGIT(ICNT)=-1 3160 ICNT=ICNT+1 3161 ITEXT(ICNT)='Dixon Test Statistic Value:' 3162 NCTEXT(ICNT)=27 3163 AVALUE(ICNT)=STATVA 3164 IDIGIT(ICNT)=NUMDIG 3165C 3166 ICNT=ICNT+1 3167 ITEXT(ICNT)='CDF Value:' 3168 NCTEXT(ICNT)=10 3169 AVALUE(ICNT)=STATCD 3170 IDIGIT(ICNT)=NUMDIG 3171 ICNT=ICNT+1 3172 ITEXT(ICNT)='P-Value:' 3173 NCTEXT(ICNT)=7 3174 AVALUE(ICNT)=PVAL 3175 IDIGIT(ICNT)=NUMDIG 3176 ICNT=ICNT+1 3177 ITEXT(ICNT)=' ' 3178 NCTEXT(ICNT)=1 3179 AVALUE(ICNT)=0.0 3180 IDIGIT(ICNT)=-1 3181C 3182 NUMROW=ICNT 3183 DO4210I=1,NUMROW 3184 NTOT(I)=15 3185 4210 CONTINUE 3186C 3187 IFRST=.TRUE. 3188 ILAST=.TRUE. 3189C 3190 ISTEPN='42A' 3191 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DIX2') 3192 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3193C 3194 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT, 3195 1 AVALUE,IDIGIT, 3196 1 NTOT,NUMROW, 3197 1 ICAPSW,ICAPTY,ILAST,IFRST, 3198 1 ISUBRO,IBUGA3,IERROR) 3199C 3200 ISTEPN='42B' 3201 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DIX2') 3202 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3203C 3204 ITITLE=' ' 3205 NCTITL=0 3206C 3207 ITITL9=' ' 3208 NCTIT9=0 3209 ITITLE(1:44)='Percent Points of the Reference Distribution' 3210 NCTITL=44 3211 NUMLIN=1 3212 NUMROW=NUMALP 3213 NUMCOL=3 3214 ITITL2(1,1)='Percent Point' 3215 ITITL2(1,2)=' ' 3216 ITITL2(1,3)='Value' 3217 NCTIT2(1,1)=13 3218 NCTIT2(1,2)=1 3219 NCTIT2(1,3)=5 3220C 3221 NMAX=0 3222 DO4221I=1,NUMCOL 3223 VALIGN(I)='b' 3224 ALIGN(I)='r' 3225 NTOT(I)=15 3226 IF(I.EQ.2)NTOT(I)=5 3227 NMAX=NMAX+NTOT(I) 3228 IDIGIT(I)=NUMDIG 3229 ITYPCO(I)='NUME' 3230 4221 CONTINUE 3231 ITYPCO(2)='ALPH' 3232 IDIGIT(1)=1 3233 IDIGIT(3)=3 3234 DO4223I=1,NUMROW 3235 DO4225J=1,NUMCOL 3236 NCVALU(I,J)=0 3237 IVALUE(I,J)=' ' 3238 NCVALU(I,J)=0 3239 AMAT(I,J)=0.0 3240 IF(J.EQ.1)THEN 3241 AMAT(I,J)=ALPHA(I) 3242 ELSEIF(J.EQ.2)THEN 3243 IVALUE(I,J)='=' 3244 NCVALU(I,J)=1 3245 ELSEIF(J.EQ.3)THEN 3246 IF(I.EQ.1)THEN 3247 AMAT(I,J)=RND(CUT0,IDIGIT(J)) 3248 ELSEIF(I.EQ.2)THEN 3249 AMAT(I,J)=RND(CUT25,IDIGIT(J)) 3250 ELSEIF(I.EQ.3)THEN 3251 AMAT(I,J)=RND(CUT50,IDIGIT(J)) 3252 ELSEIF(I.EQ.4)THEN 3253 AMAT(I,J)=RND(CUT75,IDIGIT(J)) 3254 ELSEIF(I.EQ.5)THEN 3255 AMAT(I,J)=RND(CUT80,IDIGIT(J)) 3256 ELSEIF(I.EQ.6)THEN 3257 AMAT(I,J)=RND(CUT90,IDIGIT(J)) 3258 ELSEIF(I.EQ.7)THEN 3259 AMAT(I,J)=RND(CUT95,IDIGIT(J)) 3260 ELSEIF(I.EQ.8)THEN 3261 AMAT(I,J)=RND(CUT975,IDIGIT(J)) 3262 ELSEIF(I.EQ.9)THEN 3263 AMAT(I,J)=RND(CUT99,IDIGIT(J)) 3264 ELSEIF(I.EQ.10)THEN 3265 AMAT(I,J)=RND(CUT995,IDIGIT(J)) 3266 ELSEIF(I.EQ.11)THEN 3267 AMAT(I,J)=RND(CUT100,IDIGIT(J)) 3268 ENDIF 3269 ENDIF 3270 4225 CONTINUE 3271 4223 CONTINUE 3272C 3273 IWHTML(1)=150 3274 IWHTML(2)=50 3275 IWHTML(3)=150 3276 IWRTF(1)=2000 3277 IWRTF(2)=IWRTF(1)+500 3278 IWRTF(3)=IWRTF(2)+2000 3279 IFRST=.TRUE. 3280 ILAST=.FALSE. 3281C 3282 ISTEPN='42C' 3283 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DIX2') 3284 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3285C 3286 CALL DPDTA4(ITITL9,NCTIT9, 3287 1 ITITLE,NCTITL,ITITL2,NCTIT2, 3288 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 3289 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW, 3290 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 3291 1 ICAPSW,ICAPTY,IFRST,ILAST, 3292 1 ISUBRO,IBUGA3,IERROR) 3293C 3294 ISTEPN='42D' 3295 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DIX2') 3296 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3297C 3298 CDF1=CUT90 3299 CDF2=CUT95 3300 CDF3=CUT975 3301 CDF4=CUT99 3302C 3303 ITITL9=' ' 3304 NCTIT9=0 3305 ITITLE='Conclusions (Upper 1-Tailed Test)' 3306 NCTITL=33 3307 NUMLIN=1 3308 NUMROW=4 3309 NUMCOL=4 3310 ITITL2(1,1)='Alpha' 3311 ITITL2(1,2)='CDF' 3312 ITITL2(1,3)='Critical Value' 3313 ITITL2(1,4)='Conclusion' 3314 NCTIT2(1,1)=5 3315 NCTIT2(1,2)=3 3316 NCTIT2(1,3)=14 3317 NCTIT2(1,4)=10 3318C 3319 NMAX=0 3320 DO4321I=1,NUMCOL 3321 VALIGN(I)='b' 3322 ALIGN(I)='r' 3323 NTOT(I)=15 3324 IF(I.EQ.1 .OR. I.EQ.2)NTOT(I)=7 3325 IF(I.EQ.3)NTOT(I)=17 3326 NMAX=NMAX+NTOT(I) 3327 IDIGIT(I)=3 3328 ITYPCO(I)='ALPH' 3329 4321 CONTINUE 3330 ITYPCO(3)='NUME' 3331 IDIGIT(1)=0 3332 IDIGIT(2)=0 3333 DO4323I=1,NUMROW 3334 DO4325J=1,NUMCOL 3335 NCVALU(I,J)=0 3336 IVALUE(I,J)=' ' 3337 NCVALU(I,J)=0 3338 AMAT(I,J)=0.0 3339 4325 CONTINUE 3340 4323 CONTINUE 3341 IVALUE(1,1)='10%' 3342 IVALUE(2,1)='5%' 3343 IVALUE(3,1)='2.5%' 3344 IVALUE(4,1)='1%' 3345 NCVALU(1,1)=3 3346 NCVALU(2,1)=2 3347 NCVALU(3,1)=4 3348 NCVALU(4,1)=2 3349 IVALUE(1,2)='90%' 3350 IVALUE(2,2)='95%' 3351 IVALUE(3,2)='97.5%' 3352 IVALUE(4,2)='99%' 3353 NCVALU(1,2)=3 3354 NCVALU(2,2)=3 3355 NCVALU(3,2)=4 3356 NCVALU(4,2)=3 3357 IVALUE(1,4)='Accept H0' 3358 IVALUE(2,4)='Accept H0' 3359 IVALUE(3,4)='Accept H0' 3360 IVALUE(4,4)='Accept H0' 3361 NCVALU(1,4)=9 3362 NCVALU(2,4)=9 3363 NCVALU(3,4)=9 3364 NCVALU(4,4)=9 3365 IF(STATVA.GT.CDF1)IVALUE(1,4)='Reject H0' 3366 IF(STATVA.GT.CDF2)IVALUE(2,4)='Reject H0' 3367 IF(STATVA.GT.CDF3)IVALUE(3,4)='Reject H0' 3368 IF(STATVA.GT.CDF4)IVALUE(4,4)='Reject H0' 3369 AMAT(1,3)=RND(CDF1,IDIGIT(3)) 3370 AMAT(2,3)=RND(CDF2,IDIGIT(3)) 3371 AMAT(3,3)=RND(CDF3,IDIGIT(3)) 3372 AMAT(4,3)=RND(CDF4,IDIGIT(3)) 3373C 3374 IWHTML(1)=150 3375 IWHTML(2)=150 3376 IWHTML(3)=150 3377 IWHTML(4)=150 3378 IWRTF(1)=1500 3379 IWRTF(2)=IWRTF(1)+1500 3380 IWRTF(3)=IWRTF(2)+2000 3381 IWRTF(4)=IWRTF(3)+2000 3382 IFRST=.FALSE. 3383C 3384C FOR LATEX, WE WANT TO ENSURE THAT TRAILING LINE IS PART 3385C OF THE TABLE SO THAT IT WILL BE PRINTED IN THE PROPER PLACE. 3386C 3387 IF(ICAPTY.EQ.'LATE')THEN 3388 ILAST=.FALSE. 3389 ELSE 3390 ILAST=.TRUE. 3391 ENDIF 3392C 3393 ISTEPN='42E' 3394 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DIX2') 3395 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3396C 3397 CALL DPDTA4(ITITL9,NCTIT9, 3398 1 ITITLE,NCTITL,ITITL2,NCTIT2, 3399 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 3400 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW, 3401 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 3402 1 ICAPSW,ICAPTY,IFRST,ILAST, 3403 1 ISUBRO,IBUGA3,IERROR) 3404C 3405 ITITLE(1:26)='*Critical Values Based on ' 3406 WRITE(ITITLE(27:34),'(I8)')NMCSAM 3407 ITITLE(35:58)=' Monte Carlo Simulations' 3408 NCTITL=58 3409C 3410 IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN 3411 CALL DPHTMV(ITITLE,NCTITL,CPUMIN,NUMDIG) 3412 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN 3413 CALL DPLATV(ITITLE,NCTITL,CPUMIN,NUMDIG) 3414 IFLAG1=.FALSE. 3415 IFLAG2=.TRUE. 3416 IFLAG3=.TRUE. 3417 CALL DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD) 3418 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF ')THEN 3419C 3420 CALL DPCONA(92,IBASLC) 3421 IRTFMD='OFF' 3422 IPTSZ=14 3423 WRITE(ICOUT,8199)IBASLC,IPTSZ 3424 8199 FORMAT(A1,'fs',I2) 3425 CALL DPWRST(ICOUT,'WRIT') 3426 IF(IRTFFF.EQ.'Courier New')THEN 3427 ITEMP=1 3428 ELSEIF(IRTFFF.EQ.'Lucida Console')THEN 3429 ITEMP=8 3430 ENDIF 3431 WRITE(ICOUT,8301)IBASLC,ITEMP 3432 CALL DPWRST(ICOUT,'WRIT') 3433 CALL DPRTFZ(ITITLE,NCTITL,CPUMIN,NUMDIG) 3434 IF(IRTFFP.EQ.'Times New Roman')THEN 3435 ITEMP=0 3436 ELSEIF(IRTFFP.EQ.'Lucida Sans')THEN 3437 ITEMP=6 3438 ELSEIF(IRTFFP.EQ.'Arial')THEN 3439 ITEMP=2 3440 ELSEIF(IRTFFP.EQ.'Bookman')THEN 3441 ITEMP=3 3442 ELSEIF(IRTFFP.EQ.'Georgia')THEN 3443 ITEMP=4 3444 ELSEIF(IRTFFP.EQ.'Tahoma')THEN 3445 ITEMP=5 3446 ELSEIF(IRTFFP.EQ.'Verdana')THEN 3447 ITEMP=7 3448 ENDIF 3449 WRITE(ICOUT,8301)IBASLC,ITEMP 3450 8301 FORMAT(A1,'f',I1) 3451 CALL DPWRST(ICOUT,'WRIT') 3452C 3453C END TABLE AND RESET "ASIS" MODE 3454C 3455 IF(IRTFFF.EQ.'Courier New')THEN 3456 ITEMP=1 3457 ELSEIF(IRTFFF.EQ.'Lucida Console')THEN 3458 ITEMP=8 3459 ENDIF 3460 WRITE(ICOUT,8091)IBASLC,ITEMP 3461 8091 FORMAT(A1,'f',I1) 3462 CALL DPWRST(ICOUT,'WRIT') 3463C 3464 CALL DPRTF6(NHEAD) 3465 CALL DPRTF6(NHEAD) 3466 IRTFMD='VERB' 3467 ELSE 3468 WRITE(ICOUT,2589)ITITLE(1:58) 3469 2589 FORMAT(A60) 3470 CALL DPWRST('XXX','BUG ') 3471 ENDIF 3472C 3473C ***************** 3474C ** STEP 90-- ** 3475C ** EXIT ** 3476C ***************** 3477C 3478 9000 CONTINUE 3479 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DIX2')THEN 3480 WRITE(ICOUT,999) 3481 CALL DPWRST('XXX','WRIT') 3482 WRITE(ICOUT,9011) 3483 9011 FORMAT('***** AT THE END OF DPDIX2--') 3484 CALL DPWRST('XXX','WRIT') 3485 WRITE(ICOUT,9012)N,IERROR 3486 9012 FORMAT('N,IERROR = ',I8,2X,A4) 3487 CALL DPWRST('XXX','WRIT') 3488 WRITE(ICOUT,9013)STATVA,STATCD,PVAL 3489 9013 FORMAT('STATVA,STATCD,PVAL = ',3G15.7) 3490 CALL DPWRST('XXX','WRIT') 3491 ENDIF 3492C 3493 RETURN 3494 END 3495 SUBROUTINE DPDIX3(Y,X,N,TEMP1,IWRITE,ICASAN, 3496 1 XDIXON, 3497 1 ISUBRO,IBUGA3,IERROR) 3498C 3499C PURPOSE--THIS SUBROUTINE COMPUTES THE DIXON STATISTIC. 3500C THE DIXON STATISTIC DETERMINES WHETHER THE 3501C MINIMUM (OR MAXIMUM) IS AN OUTLIER. IT IS ASSUMMED 3502C THE UNDERLYING DATA IS APPROXIMATELY NORMAL. THIS 3503C TEST IS PRIMARILY RECOMMNEDED FOR SMALL SAMPLES 3504C (SAY N <= 30). 3505C REFERENCES--DIXON (1953), "PROCESSING DATA FOR OUTLIERS", 3506C BIOMETRICS, VOL. 9, NO. 1, PP. 74-89. 3507C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR OF 3508C (UNSORTED OR SORTED) OBSERVATIONS. 3509C --X = THE LAB-ID VARIABLE 3510C --N = THE INTEGER NUMBER OF OBSERVATIONS 3511C IN THE VECTOR Y. 3512C --ICASAN = SPECIFIES WHETHER MINIMUM OR MAXIMUM 3513C CASE IS DESIRED. 3514C OUTPUT ARGUMENTS--XDIXON = THE SINGLE PRECISION VALUE OF THE 3515C COMPUTED DIXON STATISTIC. 3516C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE 3517C DIXON STATISTIC. 3518C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 3519C OF N FOR THIS SUBROUTINE. 3520C OTHER DATAPAC SUBROUTINES NEEDED--SORT. 3521C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 3522C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 3523C LANGUAGE--ANSI FORTRAN (1977) 3524C WRITTEN BY--ALAN HECKERT 3525C STATISTICAL ENGINEERING DIVISION 3526C INFORMATION TECHNOLOGY LABORATORY 3527C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 3528C GAITHERSBURG, MD 20899-8980 3529C PHONE--301-975-2899 3530C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 3531C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 3532C LANGUAGE--ANSI FORTRAN (1977) 3533C VERSION NUMBER--2009.11 3534C ORIGINAL VERSION--NOVEMBER 2009. 3535C 3536C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 3537C 3538 CHARACTER*4 IWRITE 3539 CHARACTER*4 ICASAN 3540 CHARACTER*4 IWRTSV 3541 CHARACTER*4 ISUBRO 3542 CHARACTER*4 IBUGA3 3543 CHARACTER*4 IERROR 3544C 3545 CHARACTER*4 ISUBN1 3546 CHARACTER*4 ISUBN2 3547C 3548C--------------------------------------------------------------------- 3549C 3550 DIMENSION Y(*) 3551 DIMENSION X(*) 3552 DIMENSION TEMP1(*) 3553C 3554C--------------------------------------------------------------------- 3555C 3556 INCLUDE 'DPCOP2.INC' 3557C 3558C-----START POINT----------------------------------------------------- 3559C 3560 ISUBN1='DPDI' 3561 ISUBN2='X3 ' 3562 IWRTSV=IWRITE 3563 XDIXON=CPUMIN 3564C 3565 IERROR='NO' 3566C 3567 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DIX3')THEN 3568 WRITE(ICOUT,999) 3569 999 FORMAT(1X) 3570 CALL DPWRST('XXX','BUG ') 3571 WRITE(ICOUT,51) 3572 51 FORMAT('***** AT THE BEGINNING OF DPDIX3--') 3573 CALL DPWRST('XXX','BUG ') 3574 WRITE(ICOUT,52)IBUGA3,ICASAN 3575 52 FORMAT('IBUGA3,ICASAN = ',A4,2X,A4) 3576 CALL DPWRST('XXX','BUG ') 3577 WRITE(ICOUT,53)N 3578 53 FORMAT('N = ',I8) 3579 CALL DPWRST('XXX','BUG ') 3580 DO55I=1,N 3581 WRITE(ICOUT,56)I,Y(I),X(I) 3582 56 FORMAT('I,Y(I),X(I) = ',I8,2G15.7) 3583 CALL DPWRST('XXX','BUG ') 3584 55 CONTINUE 3585 ENDIF 3586C 3587C ******************************* 3588C ** COMPUTE DIXON STATISTIC ** 3589C ******************************* 3590C 3591C ******************************************** 3592C ** STEP 1-- ** 3593C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 3594C ******************************************** 3595C 3596 IF(N.LT.3)THEN 3597 IERROR='YES' 3598 WRITE(ICOUT,999) 3599 CALL DPWRST('XXX','BUG ') 3600 WRITE(ICOUT,111) 3601 111 FORMAT('***** ERROR IN DIXON STATISTIC--') 3602 CALL DPWRST('XXX','BUG ') 3603 WRITE(ICOUT,112) 3604 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR THE ', 3605 1 'RESPONSE VARIABLE') 3606 CALL DPWRST('XXX','BUG ') 3607 WRITE(ICOUT,113) 3608 113 FORMAT(' MUST BE 3 OR LARGER. SUCH WAS NOT THE CASE ', 3609 1 'HERE.') 3610 CALL DPWRST('XXX','BUG ') 3611 WRITE(ICOUT,117)N 3612 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS = ',I8, 3613 1 '.') 3614 CALL DPWRST('XXX','BUG ') 3615 GOTO9000 3616 ENDIF 3617C 3618 IF(N.GT.30)THEN 3619 IERROR='YES' 3620 WRITE(ICOUT,999) 3621 CALL DPWRST('XXX','BUG ') 3622 WRITE(ICOUT,111) 3623 CALL DPWRST('XXX','BUG ') 3624 WRITE(ICOUT,122) 3625 122 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR THE ', 3626 1 'RESPONSE VARIABLE') 3627 CALL DPWRST('XXX','BUG ') 3628 WRITE(ICOUT,123) 3629 123 FORMAT(' MUST BE LESS THAN OR EQUAL TO 30. SUCH WAS ', 3630 1 'NOT THE CASE HERE.') 3631 CALL DPWRST('XXX','BUG ') 3632 WRITE(ICOUT,127)N 3633 127 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS = ',I8, 3634 1 '.') 3635 CALL DPWRST('XXX','BUG ') 3636 GOTO9000 3637 ENDIF 3638C ***************************************** 3639C ** STEP 2-- ** 3640C ** COMPUTE THE DIXON STATISTIC. ** 3641C ***************************************** 3642C 3643 CALL SORTC(Y,X,N,Y,TEMP1) 3644 DO130I=1,N 3645 X(I)=TEMP1(I) 3646 130 CONTINUE 3647C 3648 IF(N.GE.3 .AND. N.LE.7)THEN 3649C 3650C CASE 1: 3 <= N <= 7 3651C 3652C MINIMUM: R = (Y(2) - Y(1))/(Y(N) - Y(1)) 3653C MAXIMUM: R = (Y(N) - Y(N-1))/(Y(N) - Y(1)) 3654C 3655 IF(ICASAN.EQ.'MINI')THEN 3656 ANUM=Y(2) - Y(1) 3657 ADEN=Y(N) - Y(1) 3658 IF(ADEN.LE.0.0)GOTO8000 3659 XDIXON=ANUM/ADEN 3660 ELSEIF(ICASAN.EQ.'MAXI')THEN 3661 ANUM=Y(N) - Y(N-1) 3662 ADEN=Y(N) - Y(1) 3663 IF(ADEN.LE.0.0)GOTO8000 3664 XDIXON=ANUM/ADEN 3665 ELSE 3666 ANUM=Y(2) - Y(1) 3667 ADEN=Y(N) - Y(1) 3668 IF(ADEN.LE.0.0)THEN 3669 XDIX1=CPUMIN 3670 ELSE 3671 XDIX1=ANUM/ADEN 3672 ENDIF 3673 ANUM=Y(N) - Y(N-1) 3674 ADEN=Y(N) - Y(1) 3675 IF(ADEN.LE.0.0)THEN 3676 XDIX2=CPUMIN 3677 ELSE 3678 XDIX2=ANUM/ADEN 3679 ENDIF 3680 XDIXON=MAX(XDIX1,XDIX2) 3681 IF(XDIXON.EQ.CPUMIN)GOTO8000 3682 ENDIF 3683C 3684 ELSEIF(N.GE.8 .AND. N.LE.10)THEN 3685C 3686C CASE 2: 8 <= N <= 10 3687C 3688C MINIMUM: R = (Y(2) - Y(1))/(Y(N-1) - Y(1)) 3689C MAXIMUM: R = (Y(N) - Y(N-1))/(Y(N) - Y(2)) 3690C 3691 IF(ICASAN.EQ.'MINI')THEN 3692 ANUM=Y(2) - Y(1) 3693 ADEN=Y(N-1) - Y(1) 3694 IF(ADEN.LE.0.0)GOTO8000 3695 XDIXON=ANUM/ADEN 3696 ELSEIF(ICASAN.EQ.'MAXI')THEN 3697 ANUM=Y(N) - Y(N-1) 3698 ADEN=Y(N) - Y(2) 3699 IF(ADEN.LE.0.0)GOTO8000 3700 XDIXON=ANUM/ADEN 3701 ELSE 3702 ANUM=Y(2) - Y(1) 3703 ADEN=Y(N) - Y(1) 3704 IF(ADEN.LE.0.0)THEN 3705 XDIX1=CPUMIN 3706 ELSE 3707 XDIX1=ANUM/ADEN 3708 ENDIF 3709 ANUM=Y(N) - Y(N-1) 3710 ADEN=Y(N) - Y(1) 3711 IF(ADEN.LE.0.0)THEN 3712 XDIX2=CPUMIN 3713 ELSE 3714 XDIX2=ANUM/ADEN 3715 ENDIF 3716 XDIXON=MAX(XDIX1,XDIX2) 3717 IF(XDIXON.EQ.CPUMIN)GOTO8000 3718 ENDIF 3719C 3720 ELSEIF(N.GE.11 .AND. N.LE.13)THEN 3721C 3722C CASE 3: 11 <= N <= 13 3723C 3724C MINIMUM: R = (Y(3) - Y(1))/(Y(N-1) - Y(1)) 3725C MAXIMUM: R = (Y(N) - Y(N-2))/(Y(N) - Y(2)) 3726C 3727 IF(ICASAN.EQ.'MINI')THEN 3728 ANUM=Y(3) - Y(1) 3729 ADEN=Y(N-1) - Y(1) 3730 IF(ADEN.LE.0.0)GOTO8000 3731 XDIXON=ANUM/ADEN 3732 ELSEIF(ICASAN.EQ.'MAXI')THEN 3733 ANUM=Y(N) - Y(N-2) 3734 ADEN=Y(N) - Y(2) 3735 IF(ADEN.LE.0.0)GOTO8000 3736 XDIXON=ANUM/ADEN 3737 ELSE 3738 ANUM=Y(3) - Y(1) 3739 ADEN=Y(N-1) - Y(1) 3740 IF(ADEN.LE.0.0)THEN 3741 XDIX1=CPUMIN 3742 ELSE 3743 XDIX1=ANUM/ADEN 3744 ENDIF 3745 ANUM=Y(N) - Y(N-2) 3746 ADEN=Y(N) - Y(2) 3747 IF(ADEN.LE.0.0)THEN 3748 XDIX2=CPUMIN 3749 ELSE 3750 XDIX2=ANUM/ADEN 3751 ENDIF 3752 XDIXON=MAX(XDIX1,XDIX2) 3753 ENDIF 3754C 3755 ELSEIF(N.GE.14 .AND. N.LE.30)THEN 3756C 3757C CASE 4: 14 <= N <= 30 3758C 3759C MINIMUM: R = (X(3) - X(1))/(X(N-2) - X(1)) 3760C MAXIMUM: R = (X(N) - X(N-2))/(X(N) - X(3)) 3761C 3762 IF(ICASAN.EQ.'MINI')THEN 3763 ANUM=Y(3) - Y(1) 3764 ADEN=Y(N-2) - Y(1) 3765 IF(ADEN.LE.0.0)GOTO8000 3766 XDIXON=ANUM/ADEN 3767 ELSEIF(ICASAN.EQ.'MAXI')THEN 3768 ANUM=Y(N) - Y(N-2) 3769 ADEN=Y(N) - Y(3) 3770 IF(ADEN.LE.0.0)GOTO8000 3771 XDIXON=ANUM/ADEN 3772 ELSE 3773 ANUM=Y(3) - Y(1) 3774 ADEN=Y(N-2) - Y(1) 3775 IF(ADEN.LE.0.0)THEN 3776 XDIX1=CPUMIN 3777 ELSE 3778 XDIX1=ANUM/ADEN 3779 ENDIF 3780 ANUM=Y(N) - Y(N-2) 3781 ADEN=Y(N) - Y(3) 3782 IF(ADEN.LE.0.0)THEN 3783 XDIX2=CPUMIN 3784 ELSE 3785 XDIX2=ANUM/ADEN 3786 ENDIF 3787 XDIXON=MAX(XDIX1,XDIX2) 3788 ENDIF 3789C 3790 ENDIF 3791C 3792 GOTO9000 3793C 3794 8000 CONTINUE 3795 IERROR='YES' 3796 WRITE(ICOUT,999) 3797 CALL DPWRST('XXX','BUG ') 3798 WRITE(ICOUT,111) 3799 CALL DPWRST('XXX','BUG ') 3800 WRITE(ICOUT,8011) 3801 8011 FORMAT(' THE DENOMINATOR FOR THE DIXON TEST IS ZERO. ', 3802 1 'UNABLE TO') 3803 CALL DPWRST('XXX','BUG ') 3804 WRITE(ICOUT,8013) 3805 8013 FORMAT(' TO COMPUTE THE DIXON STATISTIC.') 3806 CALL DPWRST('XXX','BUG ') 3807 GOTO9000 3808C 3809C ***************** 3810C ** STEP 90-- ** 3811C ** EXIT. ** 3812C ***************** 3813C 3814 9000 CONTINUE 3815C 3816 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DIX3')THEN 3817 WRITE(ICOUT,999) 3818 CALL DPWRST('XXX','BUG ') 3819 WRITE(ICOUT,9011) 3820 9011 FORMAT('***** AT THE END OF DPDIX3--') 3821 CALL DPWRST('XXX','BUG ') 3822 WRITE(ICOUT,9012)IBUGA3,IERROR 3823 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 3824 CALL DPWRST('XXX','BUG ') 3825 WRITE(ICOUT,9013)N 3826 9013 FORMAT('N = ',I8) 3827 CALL DPWRST('XXX','BUG ') 3828 WRITE(ICOUT,9015)ANUM,ADEN,XDIXON 3829 9015 FORMAT('ANUM,ADEN,XDIXON = ',3G15.7) 3830 CALL DPWRST('XXX','BUG ') 3831 WRITE(ICOUT,9016)Y(1),Y(2),Y(3) 3832 9016 FORMAT('Y(1),Y(2),Y(3) = ',3G15.7) 3833 CALL DPWRST('XXX','BUG ') 3834 WRITE(ICOUT,9017)Y(N),Y(N-1),Y(N-2) 3835 9017 FORMAT('Y(N),Y(N-1),Y(N-2) = ',3G15.7) 3836 CALL DPWRST('XXX','BUG ') 3837 ENDIF 3838C 3839 RETURN 3840 END 3841 SUBROUTINE DPDLPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ISEED, 3842 1ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 3843C 3844C PURPOSE--GENERATE A DETECTION LIMIT PLOT 3845C EXAMPLE--DETECTION LIMIT PLOT IMS MASS VAL1 3846C DETECTION LIMIT PLOT IMS MASS VAL1 VAL2 3847C NOTE THAT VAL1 AND VAL2 DENOTE VALUES OF THE 3848C MASS VARIABLE. THERE MUST BE AT LEAST ONE VALUE 3849C GIVEN AND CURRENTLY UP TO 5 VALUES MAY BE SPECIFIED. 3850C REFERENCE--IMPLEMENTS A METHOD SUGGESTED BY 3851C MICHAEL VERKOUTEREN OF THE NIST SURFACE AND 3852C MICROANALYSIS SCIENCE DIVISION 3853C WRITTEN BY--JAMES J. FILLIBEN 3854C STATISTICAL ENGINEERING DIVISION 3855C INFORMATION TECHNOLOGY LABORATROY 3856C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 3857C GAITHERSBURG, MD 20899-8980 3858C PHONE--301-975-2855 3859C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 3860C OF THE NATIONAL BUREAU OF STANDARDS. 3861C LANGUAGE--ANSI FORTRAN (1977) 3862C VERSION NUMBER--2008/12 3863C ORIGINAL VERSION--DECEMBER 2008. 3864C 3865C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 3866C 3867 CHARACTER*4 ICASPL 3868 CHARACTER*4 IAND1 3869 CHARACTER*4 IAND2 3870 CHARACTER*4 ISUBRO 3871 CHARACTER*4 IBUGG2 3872 CHARACTER*4 IBUGG3 3873 CHARACTER*4 IBUGQ 3874 CHARACTER*4 IFOUND 3875 CHARACTER*4 IERROR 3876C 3877 CHARACTER*4 IHWUSE 3878 CHARACTER*4 MESSAG 3879 CHARACTER*4 ICASEQ 3880 CHARACTER*4 IHLEFT 3881 CHARACTER*4 IHLEF2 3882 CHARACTER*4 IHRIGH 3883 CHARACTER*4 IHRIG2 3884 CHARACTER*4 IHBATC 3885 CHARACTER*4 IHBAT2 3886 CHARACTER*4 IERRO4 3887 CHARACTER*4 ISUBN1 3888 CHARACTER*4 ISUBN2 3889 CHARACTER*4 ISTEPN 3890 CHARACTER*4 IH41 3891 CHARACTER*4 IH42 3892 CHARACTER*4 IH 3893 CHARACTER*4 IH2 3894 CHARACTER*4 IHP 3895 CHARACTER*4 IHP2 3896 CHARACTER*4 ISUBN0 3897C 3898 REAL MUML 3899 REAL SDML 3900 REAL MUMLSE 3901 REAL SDMLSE 3902 REAL LOW05 3903C 3904C--------------------------------------------------------------------- 3905C 3906 INCLUDE 'DPCOPA.INC' 3907C 3908 DIMENSION Y1(MAXOBV) 3909 DIMENSION X1(MAXOBV) 3910 DIMENSION TAG1(MAXOBV) 3911 DIMENSION XMATCH(MAXOBV) 3912 DIMENSION TEMP1(MAXOBV) 3913 DIMENSION TEMP2(MAXOBV) 3914 DIMENSION TEMP3(MAXOBV) 3915 DIMENSION TEMP4(MAXOBV) 3916 DIMENSION TEMP5(MAXOBV) 3917 DIMENSION QP(MAXOBV) 3918 DIMENSION XQPHAT(MAXOBV) 3919 DIMENSION XQPLCL(MAXOBV) 3920 DIMENSION XQPUCL(MAXOBV) 3921 INCLUDE 'DPCOZZ.INC' 3922 EQUIVALENCE (GARBAG(IGARB1),X1(1)) 3923 EQUIVALENCE (GARBAG(IGARB2),Y1(1)) 3924 EQUIVALENCE (GARBAG(IGARB3),TAG1(1)) 3925 EQUIVALENCE (GARBAG(IGARB4),XMATCH(1)) 3926 EQUIVALENCE (GARBAG(IGARB5),TEMP1(1)) 3927 EQUIVALENCE (GARBAG(IGARB6),TEMP2(1)) 3928 EQUIVALENCE (GARBAG(IGARB7),TEMP3(1)) 3929 EQUIVALENCE (GARBAG(IGARB8),TEMP4(1)) 3930 EQUIVALENCE (GARBAG(IGARB9),TEMP5(1)) 3931 EQUIVALENCE (GARBAG(IGAR10),QP(1)) 3932 EQUIVALENCE (GARBAG(JGAR11),XQPHAT(1)) 3933 EQUIVALENCE (GARBAG(JGAR12),XQPLCL(1)) 3934 EQUIVALENCE (GARBAG(JGAR13),XQPUCL(1)) 3935C 3936C-----COMMON---------------------------------------------------------- 3937C 3938 INCLUDE 'DPCOST.INC' 3939 INCLUDE 'DPCOHK.INC' 3940 INCLUDE 'DPCODA.INC' 3941 INCLUDE 'DPCOHO.INC' 3942 INCLUDE 'DPCOP2.INC' 3943C 3944C-----START POINT----------------------------------------------------- 3945C 3946 IFOUND='NO' 3947 IERROR='NO' 3948 ISUBN1='DPDL' 3949 ISUBN2='PL ' 3950C 3951 MAXCP1=MAXCOL+1 3952 MAXCP2=MAXCOL+2 3953 MAXCP3=MAXCOL+3 3954 MAXCP4=MAXCOL+4 3955 MAXCP5=MAXCOL+5 3956 MAXCP6=MAXCOL+6 3957C 3958 MAXV2=2 3959 IF(ICASPL.EQ.'BSPL')MAXV2=3 3960 MINN2=2 3961 ICOLR=0 3962C 3963C ********************************************** 3964C ** TREAT THE DETECTION LIMIT PLOT ** 3965C ********************************************** 3966C 3967 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'DLPL')THEN 3968 WRITE(ICOUT,999) 3969 CALL DPWRST('XXX','BUG ') 3970 WRITE(ICOUT,51) 3971 51 FORMAT('***** AT THE BEGINNING OF DPDLPL--') 3972 CALL DPWRST('XXX','BUG ') 3973 WRITE(ICOUT,52)ICASPL,IAND1,IAND2,ISEED 3974 52 FORMAT('ICASPL,IAND1,IAND2,ISEED = ',3(A4,2X),I8) 3975 CALL DPWRST('XXX','BUG ') 3976 WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ 3977 53 FORMAT('IBUGG2,IBUGG3,IBUGQ = ',2(A4,2X),A4) 3978 CALL DPWRST('XXX','BUG ') 3979 ENDIF 3980C 3981C *************************** 3982C ** STEP 1-- ** 3983C ** EXTRACT THE COMMAND ** 3984C *************************** 3985C 3986 ISTEPN='1' 3987 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DLPL') 3988 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3989C 3990 IF(ICOM.EQ.'DETE'.AND.IHARG(1).EQ.'LIMI'.AND. 3991 1 IHARG(2).EQ.'PLOT')THEN 3992 ICASPL='DLPL' 3993 ILASTC=2 3994 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 3995 IFOUND='YES' 3996 ELSEIF(ICOM.EQ.'NORM'.AND.IHARG(1).EQ.'DETE'.AND. 3997 1 IHARG(2).EQ.'LIMI'.AND.IHARG(3).EQ.'PLOT')THEN 3998 ICASPL='DLPL' 3999 ILASTC=3 4000 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 4001 IFOUND='YES' 4002 ELSE 4003 IFOUND='NO' 4004 GOTO9000 4005 ENDIF 4006C 4007C ******************************************************* 4008C ** STEP 2-- ** 4009C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** 4010C ******************************************************* 4011C 4012 ISTEPN='1' 4013 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DLPL') 4014 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4015C 4016 MINNA=3 4017 MAXNA=100 4018 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) 4019 IF(IERROR.EQ.'YES')GOTO9000 4020C 4021C ******************************************** 4022C ** STEP 2-- ** 4023C ** CHECK THE VALIDITY OF ARGUMENT 1 ** 4024C ** (THIS WILL BE THE RESPONSE VARIABLE) ** 4025C ******************************************** 4026C 4027 ISTEPN='2' 4028 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DLPL') 4029 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4030C 4031 IHLEFT=IHARG(1) 4032 IHLEF2=IHARG2(1) 4033 IHWUSE='V' 4034 MESSAG='YES' 4035 CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 4036 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 4037 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 4038 IF(IERROR.EQ.'YES')GOTO9000 4039 ICOLL=IVALUE(ILOCV) 4040 NLEFT=IN(ILOCV) 4041C 4042 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DLPL')THEN 4043 WRITE(ICOUT,211)IHLEFT,IHLEF2,ICOLL,NLEFT 4044 211 FORMAT('IHLEFT,IHLEF2,ICOLL,NLEFT = ',A4,2X,A4,I8,I8) 4045 CALL DPWRST('XXX','BUG ') 4046 ENDIF 4047C 4048C ****************************************************** 4049C ** STEP 3-- ** 4050C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS ** 4051C ** (NLEFT) FOR THE RESPONSE VARIABLE IS POSITIVE. ** 4052C ****************************************************** 4053C 4054 ISTEPN='3' 4055 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DLPL') 4056 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4057C 4058 IF(NLEFT.LT.MINN2)THEN 4059 WRITE(ICOUT,999) 4060 999 FORMAT(1X) 4061 CALL DPWRST('XXX','BUG ') 4062 WRITE(ICOUT,311) 4063 311 FORMAT('***** ERROR IN DETECTION LIMIT PLOT--') 4064 CALL DPWRST('XXX','BUG ') 4065 WRITE(ICOUT,312) 4066 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR WHICH A') 4067 CALL DPWRST('XXX','BUG ') 4068 WRITE(ICOUT,314)MINN2 4069 314 FORMAT(' DETECTION LIMIT PLOT WAS TO HAVE BEEN FORMED ', 4070 1 'MUST BE ',I8) 4071 CALL DPWRST('XXX','BUG ') 4072 WRITE(ICOUT,316) 4073 316 FORMAT(' OR LARGER; SUCH WAS NOT THE CASE HERE.') 4074 CALL DPWRST('XXX','BUG ') 4075 WRITE(ICOUT,317) 4076 317 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') 4077 CALL DPWRST('XXX','BUG ') 4078 IF(IWIDTH.GE.1)THEN 4079 WRITE(ICOUT,318)(IANS(I),I=1,MIN(80,IWIDTH)) 4080 318 FORMAT(80A1) 4081 CALL DPWRST('XXX','BUG ') 4082 ENDIF 4083 IERROR='YES' 4084 GOTO9000 4085 ENDIF 4086C 4087C ***************************************** 4088C ** STEP 4-- ** 4089C ** CHECK TO SEE THE TYPE SUBCASE ** 4090C ** (BASED ON THE QUALIFIER)-- ** 4091C ** 1) UNQUALIFIED (THAT IS, FULL); ** 4092C ** 2) SUBSET/EXCEPT; OR ** 4093C ** 3) FOR. ** 4094C ***************************************** 4095C 4096 ISTEPN='4' 4097 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DLPL') 4098 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4099C 4100 ICASEQ='FULL' 4101 ILOCQ=NUMARG+1 4102 IF(NUMARG.LT.1)GOTO480 4103 DO400J=1,NUMARG 4104 J1=J 4105 IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO410 4106 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO410 4107 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO420 4108 400 CONTINUE 4109 GOTO490 4110 410 CONTINUE 4111 ICASEQ='SUBS' 4112 ILOCQ=J1 4113 GOTO490 4114 420 CONTINUE 4115 ICASEQ='FOR' 4116 ILOCQ=J1 4117 GOTO490 4118C 4119 480 CONTINUE 4120 WRITE(ICOUT,999) 4121 CALL DPWRST('XXX','BUG ') 4122 WRITE(ICOUT,481) 4123 481 FORMAT('***** INTERNAL ERROR IN DPDLPL') 4124 CALL DPWRST('XXX','BUG ') 4125 WRITE(ICOUT,482) 4126 482 FORMAT(' AT BRANCH POINT 481--') 4127 CALL DPWRST('XXX','BUG ') 4128 WRITE(ICOUT,483) 4129 483 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') 4130 CALL DPWRST('XXX','BUG ') 4131 WRITE(ICOUT,484) 4132 484 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') 4133 CALL DPWRST('XXX','BUG ') 4134 WRITE(ICOUT,485)NUMARG 4135 485 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) 4136 CALL DPWRST('XXX','BUG ') 4137 WRITE(ICOUT,317) 4138 CALL DPWRST('XXX','BUG ') 4139 IF(IWIDTH.GE.1)THEN 4140 WRITE(ICOUT,318)(IANS(I),I=1,MIN(80,IWIDTH)) 4141 CALL DPWRST('XXX','BUG ') 4142 ENDIF 4143 IERROR='YES' 4144 GOTO9000 4145C 4146 490 CONTINUE 4147 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'DLPL')THEN 4148 WRITE(ICOUT,491)NUMARG,ILOCQ,ICASEQ 4149 491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) 4150 CALL DPWRST('XXX','BUG ') 4151 ENDIF 4152C 4153C ****************************************************** 4154C ** STEP 5-- ** 4155C ** DETERMINE HOW MANY ARGUMENTS THERE ARE ** 4156C ** NOT INCLUDING <SUBSET/EXCEPT/FOR>. THE ** 4157C ** SECOND ARGUMENT MUST BE A VARIABLE WHILE ** 4158C ** ARGUMENTS THREE AND ABOVE SHOULD BE ** 4159C ** SCALARS. VARIABLE TWO SHOULD BE THE SAME ** 4160C ** SIZE AS VARIABLE ONE. ** 4161C ****************************************************** 4162C 4163 ISTEPN='5' 4164 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DLPL') 4165 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4166C 4167 NUMV2=ILOCQ-1 4168 IF(NUMV2.LT.3)THEN 4169 WRITE(ICOUT,311) 4170 CALL DPWRST('XXX','BUG ') 4171 WRITE(ICOUT,501) 4172 501 FORMAT(' THE NUMBER OF INPUT ARGUMENTS MUST BE AT LEAST') 4173 CALL DPWRST('XXX','BUG ') 4174 WRITE(ICOUT,502)NUMV2 4175 502 FORMAT(' THREE. ONLY ',I5,' ARGUMENTS GIVEN HERE.') 4176 CALL DPWRST('XXX','BUG ') 4177 WRITE(ICOUT,317) 4178 CALL DPWRST('XXX','BUG ') 4179 IF(IWIDTH.GE.1)THEN 4180 WRITE(ICOUT,318)(IANS(I),I=1,MIN(80,IWIDTH)) 4181 CALL DPWRST('XXX','BUG ') 4182 ENDIF 4183 IERROR='YES' 4184 GOTO9000 4185 ENDIF 4186C 4187 IHRIGH=IHARG(2) 4188 IHRIG2=IHARG2(2) 4189 IHWUSE='V' 4190 MESSAG='YES' 4191 CALL CHECKN(IHRIGH,IHRIG2,IHWUSE, 4192 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE, 4193 1 NUMNAM,MAXNAM, 4194 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 4195 IF(IERROR.EQ.'YES')GOTO9000 4196 ICOLR=IVALUE(ILOCV) 4197 NRIGHT=IN(ILOCV) 4198C 4199 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DLPL')THEN 4200 WRITE(ICOUT,511)IHRIGH,IHRIG2,ICOLR,NRIGHT 4201 511 FORMAT('IHRIGH,IHRIG2,ICOLR,NRIGHT = ',A4,2X,A4,2I8) 4202 CALL DPWRST('XXX','BUG ') 4203 ENDIF 4204C 4205 IF(NRIGHT.NE.NLEFT)THEN 4206 WRITE(ICOUT,999) 4207 CALL DPWRST('XXX','BUG ') 4208 WRITE(ICOUT,311) 4209 CALL DPWRST('XXX','BUG ') 4210 WRITE(ICOUT,572) 4211 572 FORMAT(' FOR A DETECTION LIMIT PLOT, WHEN WE HAVE TWO ', 4212 1 'VARIABLES') 4213 CALL DPWRST('XXX','BUG ') 4214 WRITE(ICOUT,579) 4215 579 FORMAT(' SPECIFIED, THE NUMBER OF ELEMENTS IN THE TWO') 4216 CALL DPWRST('XXX','BUG ') 4217 WRITE(ICOUT,581) 4218 581 FORMAT(' VARIABLES MUST BE THE SAME; SUCH WAS NOT ', 4219 1 'THE CASE HERE.') 4220 CALL DPWRST('XXX','BUG ') 4221 WRITE(ICOUT,999) 4222 CALL DPWRST('XXX','BUG ') 4223 WRITE(ICOUT,583) 4224 583 FORMAT(' THE FIRST VARIABLE (FREQUENCIES)--') 4225 CALL DPWRST('XXX','BUG ') 4226 WRITE(ICOUT,584)IHLEFT,IHLEF2,NLEFT 4227 584 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') 4228 CALL DPWRST('XXX','BUG ') 4229 WRITE(ICOUT,585) 4230 585 FORMAT(' THE SECOND VARIABLE (HORIZ. AXIS VALUES)--') 4231 CALL DPWRST('XXX','BUG ') 4232 WRITE(ICOUT,586)IHRIGH,IHRIG2,NRIGHT 4233 586 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') 4234 CALL DPWRST('XXX','BUG ') 4235 WRITE(ICOUT,999) 4236 CALL DPWRST('XXX','BUG ') 4237 WRITE(ICOUT,317) 4238 CALL DPWRST('XXX','BUG ') 4239 IF(IWIDTH.GE.1)THEN 4240 WRITE(ICOUT,318)(IANS(I),I=1,MIN(80,IWIDTH)) 4241 CALL DPWRST('XXX','BUG ') 4242 ENDIF 4243 IERROR='YES' 4244 GOTO9000 4245 ENDIF 4246C 4247C ****************************************************** 4248C ** STEP 6-- ** 4249C ** EXTRACT THE ARGUMENTS 3 AND ABOVE AS SCALARS. ** 4250C ****************************************************** 4251C 4252 NPAR=0 4253 DO610I=3,NUMV2 4254 IHWUSE='P' 4255 MESSAG='YES' 4256 IHBATC=IHARG(I) 4257 IHBAT2=IHARG2(I) 4258 CALL CHECKN(IHBATC,IHBAT2,IHWUSE, 4259 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE, 4260 1 NUMNAM,MAXNAM, 4261 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 4262 IF(IERROR.EQ.'YES')GOTO9000 4263 NPAR=NPAR+1 4264 XMATCH(NPAR)=VALUE(ILOCV) 4265C 4266 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DLPL')THEN 4267 WRITE(ICOUT,611)IHBATC,IHBAT2,NPAR,XMATCH(NPAR) 4268 611 FORMAT('IHBATCH,IHBAT2,NPAR,XMATCH(NPAR) = ',A4,A4,I8,G15.7) 4269 CALL DPWRST('XXX','BUG ') 4270 ENDIF 4271C 4272 610 CONTINUE 4273C 4274C ***************************************** 4275C ** STEP 7-- ** 4276C ** BRANCH TO THE APPROPRIATE SUBCASE; ** 4277C ** (BASED ON THE QUALIFIER) ** 4278C ** THEN FORM THE RESPONSE VARIABLE ** 4279C ** AND THE FACTORS ** 4280C ** AND CARRY OUT THE PLOTS. ** 4281C ***************************************** 4282C 4283 ISTEPN='7' 4284 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DLPL') 4285 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4286C 4287 IF(ICASEQ.EQ.'FULL')GOTO710 4288 IF(ICASEQ.EQ.'SUBS')GOTO720 4289 IF(ICASEQ.EQ.'FOR')GOTO730 4290C 4291 710 CONTINUE 4292 DO715I=1,NLEFT 4293 ISUB(I)=1 4294 715 CONTINUE 4295 NQ=NLEFT 4296 GOTO750 4297C 4298 720 CONTINUE 4299 NIOLD=NLEFT 4300 CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4) 4301 NQ=NIOLD 4302 GOTO750 4303C 4304 730 CONTINUE 4305 NIOLD=NLEFT 4306 CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 4307 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) 4308 NQ=NFOR 4309 GOTO750 4310C 4311 750 CONTINUE 4312C 4313 J=0 4314 IMAX=NLEFT 4315 IF(NQ.LT.NLEFT)IMAX=NQ 4316 DO810I=1,IMAX 4317 IF(ISUB(I).EQ.0)GOTO810 4318 J=J+1 4319 IJ=MAXN*(ICOLL-1)+I 4320 IF(ICOLL.LE.MAXCOL)Y1(J)=V(IJ) 4321 IF(ICOLL.EQ.MAXCP1)Y1(J)=PRED(I) 4322 IF(ICOLL.EQ.MAXCP2)Y1(J)=RES(I) 4323 IF(ICOLL.EQ.MAXCP3)Y1(J)=YPLOT(I) 4324 IF(ICOLL.EQ.MAXCP4)Y1(J)=XPLOT(I) 4325 IF(ICOLL.EQ.MAXCP5)Y1(J)=X2PLOT(I) 4326 IF(ICOLL.EQ.MAXCP6)Y1(J)=TAGPLO(I) 4327C 4328 IJ=MAXN*(ICOLR-1)+I 4329 IF(ICOLR.LE.MAXCOL)X1(J)=V(IJ) 4330 IF(ICOLR.EQ.MAXCP1)X1(J)=PRED(I) 4331 IF(ICOLR.EQ.MAXCP2)X1(J)=RES(I) 4332 IF(ICOLR.EQ.MAXCP3)X1(J)=YPLOT(I) 4333 IF(ICOLR.EQ.MAXCP4)X1(J)=XPLOT(I) 4334 IF(ICOLR.EQ.MAXCP5)X1(J)=X2PLOT(I) 4335 IF(ICOLR.EQ.MAXCP6)X1(J)=TAGPLO(I) 4336C 4337 810 CONTINUE 4338 NLOCAL=J 4339C 4340C ****************************************************** 4341C ** STEP 8B-- ** 4342C ** CHECK TO SEE IF A "PERCENTILES" VARIABLE HAS ** 4343C ** BEEN SPECIFIED (VIA THE SET MAXIMIM LIKELIHOOD ** 4344C ** PERCENTILES COMMAND). IF SO, EXTRACT THE NAME. ** 4345C ****************************************************** 4346C 4347 ISTEPN='8B' 4348 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DLPL') 4349 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4350C 4351 IF(IQUAVR.EQ.'NONE')THEN 4352 NPERC=0 4353 ELSEIF(IQUAVR.EQ.'DEFAULT')THEN 4354 QP(1)=0.5 4355 QP(2)=1.0 4356 QP(3)=5.0 4357 QP(4)=10.0 4358 QP(5)=20.0 4359 QP(6)=30.0 4360 QP(7)=40.0 4361 QP(8)=50.0 4362 QP(9)=60.0 4363 QP(10)=70.0 4364 QP(11)=80.0 4365 QP(12)=90.0 4366 QP(13)=95.0 4367 QP(14)=97.5 4368 QP(15)=99.0 4369 QP(16)=99.5 4370 NPERC=16 4371 ELSE 4372 IH41=IQUAVR(1:4) 4373 IH42=IQUAVR(5:8) 4374 IHWUSE='V' 4375 MESSAG='NO' 4376 CALL CHECKN(IH41,IH42,IHWUSE, 4377 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 4378 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 4379C 4380 IF(IERROR.EQ.'YES')THEN 4381 NPERC=0 4382 ELSE 4383 ICOLQP=IVALUE(ILOCV) 4384 NPERC=IN(ILOCV) 4385 ICNT=0 4386 DO860I=1,NPERC 4387 IJ=MAXN*(ICOLQP-1)+I 4388 ICNT=ICNT+1 4389 IF(ICOLQP.LE.MAXCOL)QP(ICNT)=V(IJ) 4390 IF(ICOLQP.EQ.MAXCP1)QP(ICNT)=PRED(I) 4391 IF(ICOLQP.EQ.MAXCP2)QP(ICNT)=RES(I) 4392 IF(ICOLQP.EQ.MAXCP3)QP(ICNT)=YPLOT(I) 4393 IF(ICOLQP.EQ.MAXCP4)QP(ICNT)=XPLOT(I) 4394 IF(ICOLQP.EQ.MAXCP5)QP(ICNT)=X2PLOT(I) 4395 IF(ICOLQP.EQ.MAXCP6)QP(ICNT)=TAGPLO(I) 4396 IF(QP(ICNT).LE.0.0 .OR. QP(ICNT).GE.100.0)THEN 4397 ICNT=ICNT-1 4398 ENDIF 4399 860 CONTINUE 4400 NPERC=ICNT 4401C 4402 ENDIF 4403 ENDIF 4404C 4405 IHP='ALPH' 4406 IHP2='A ' 4407 IHWUSE='P' 4408 MESSAG='NO' 4409 CALL CHECKN(IHP,IHP2,IHWUSE, 4410 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 4411 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 4412 ALPHA=0.05 4413 IF(IERROR.EQ.'NO')ALPHA=VALUE(ILOCP) 4414 IF(ALPHA.LE.0.0 .OR. ALPHA.GE.1.0)THEN 4415 ALPHA=0.05 4416 ELSEIF(ALPHA.GT.0.50)THEN 4417 ALPHA=1.0-ALPHA 4418 ENDIF 4419C 4420 IHP='THRE' 4421 IHP2='SHHO' 4422 IHWUSE='P' 4423 MESSAG='NO' 4424 CALL CHECKN(IHP,IHP2,IHWUSE, 4425 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 4426 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 4427 THRESH=CPUMIN 4428 IF(IERROR.EQ.'NO')THRESH=VALUE(ILOCP) 4429C 4430C ***************************************************** 4431C ** STEP 9-- ** 4432C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** 4433C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** 4434C ** RESET THE VECTOR D(.) TO ALL ONES. ** 4435C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** 4436C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** 4437C ***************************************************** 4438C 4439 ISTEPN='9' 4440 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'DLPL') 4441 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4442C 4443 CALL DPDLP2(Y1,X1,NLOCAL,XMATCH,NPAR, 4444 1 ICASPL,IHLEFT,IHLEF2,IHRIGH,IHRIG2,ALPHA, 4445 1 TEMP1,TEMP2,TEMP3,TEMP4,TEMP5, 4446 1 QP,XQPHAT,XQPLCL,XQPUCL,XQPSE,NPERC, 4447 1 UPP95,LOW05,CDFTHR, 4448 1 MUML,SDML, 4449 1 MUMLSE,SDMLSE,COVSE,ACORR, 4450 1 NPOS,NZERO, 4451 1 YMEAN1,YSD1,YMIN1,THRESH,PRZERO, 4452 1 Y,X,D,NPLOTP,NPLOTV,ISUBRO,IBUGG3,IERROR) 4453C 4454C *************************************** 4455C ** STEP 10-- ** 4456C ** UPDATE INTERNAL DATAPLOT TABLES ** 4457C *************************************** 4458C 4459 IH='MUML' 4460 IH2=' ' 4461 VALUE0=MUML 4462 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 4463 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 4464 1IANS,IWIDTH,IBUGG3,IERROR) 4465C 4466 IH='MUML' 4467 IH2='SE ' 4468 VALUE0=MUMLSE 4469 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 4470 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 4471 1IANS,IWIDTH,IBUGG3,IERROR) 4472C 4473 IH='SDML' 4474 IH2=' ' 4475 VALUE0=SDML 4476 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 4477 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 4478 1IANS,IWIDTH,IBUGG3,IERROR) 4479C 4480 IH='SDML' 4481 IH2='SE ' 4482 VALUE0=SDMLSE 4483 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 4484 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 4485 1IANS,IWIDTH,IBUGG3,IERROR) 4486C 4487 IH='COVS' 4488 IH2='E ' 4489 VALUE0=COVSE 4490 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 4491 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 4492 1IANS,IWIDTH,IBUGG3,IERROR) 4493C 4494 IH='CORR' 4495 IH2='SE ' 4496 VALUE0=ACORR 4497 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 4498 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 4499 1IANS,IWIDTH,IBUGG3,IERROR) 4500C 4501 IH='TRUN' 4502 IH2='MEAN' 4503 VALUE0=YMEAN1 4504 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 4505 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 4506 1IANS,IWIDTH,IBUGG3,IERROR) 4507C 4508 IH='TRUN' 4509 IH2='SD ' 4510 VALUE0=YSD1 4511 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 4512 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 4513 1IANS,IWIDTH,IBUGG3,IERROR) 4514C 4515 IH='TRUN' 4516 IH2='MINI' 4517 VALUE0=YMIN1 4518 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 4519 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 4520 1IANS,IWIDTH,IBUGG3,IERROR) 4521C 4522 IH='PZER' 4523 IH2='O ' 4524 VALUE0=PRZERO 4525 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 4526 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 4527 1IANS,IWIDTH,IBUGG3,IERROR) 4528C 4529 IH='NUMB' 4530 IH2='TRUN' 4531 VALUE0=NZERO 4532 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 4533 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 4534 1IANS,IWIDTH,IBUGG3,IERROR) 4535C 4536 IH='NUMB' 4537 IH2='POSI' 4538 VALUE0=NPOS 4539 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 4540 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 4541 1IANS,IWIDTH,IBUGG3,IERROR) 4542C 4543 IH='THRE' 4544 IH2='SHOU' 4545 VALUE0=THRESH 4546 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 4547 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 4548 1IANS,IWIDTH,IBUGG3,IERROR) 4549C 4550 IH='UPP9' 4551 IH2='5CV ' 4552 VALUE0=UPP95 4553 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 4554 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 4555 1IANS,IWIDTH,IBUGG3,IERROR) 4556C 4557 IH='LOW0' 4558 IH2='5CV ' 4559 VALUE0=LOW05 4560 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 4561 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 4562 1IANS,IWIDTH,IBUGG3,IERROR) 4563C 4564 IH='CDFT' 4565 IH2='HRES' 4566 VALUE0=CDFTHR 4567 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 4568 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 4569 1IANS,IWIDTH,IBUGG3,IERROR) 4570C 4571C ***************** 4572C ** STEP 90-- ** 4573C ** EXIT ** 4574C ***************** 4575C 4576 9000 CONTINUE 4577 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'DLPL')THEN 4578 WRITE(ICOUT,999) 4579 CALL DPWRST('XXX','BUG ') 4580 WRITE(ICOUT,9011) 4581 9011 FORMAT('***** AT THE END OF DPDLPL--') 4582 CALL DPWRST('XXX','BUG ') 4583 WRITE(ICOUT,9012)IFOUND,IERROR 4584 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 4585 CALL DPWRST('XXX','BUG ') 4586 WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 4587 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 4588 1 I8,I8,I8,2X,A4,2X,A4,2X,A4) 4589 CALL DPWRST('XXX','BUG ') 4590 IF(NPLOTP.GE.1)THEN 4591 DO9015I=1,NPLOTP 4592 WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 4593 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) 4594 CALL DPWRST('XXX','BUG ') 4595 9015 CONTINUE 4596 ENDIF 4597 ENDIF 4598C 4599 RETURN 4600 END 4601 SUBROUTINE DPDLP2(Y,X,N,XMATCH,NPAR, 4602 1 ICASPL, 4603 1 IHLEFT,IHLEF2,IHRIGH,IHRIG2,ALPCV, 4604 1 TEMP1,TEMP2,TEMP3,TEMP4,TEMP5, 4605 1 QP,XQPHAT,XQPLCL,XQPUCL,XQPSE,NPERC, 4606 1 UPP95,LOW05,CDFTHR, 4607 1 MUML,SDML, 4608 1 MUMLSE,SDMLSE,COVSE,ACORR, 4609 1 NPOS,NZERO, 4610 1 YMEAN1,YSD1,YMIN1,THRESH,PRZERO, 4611 1 Y2,X2,D2,N2,NPLOTV,ISUBRO,IBUGG3,IERROR) 4612C 4613C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS 4614C THAT WILL DEFINE A DETECTION LIMIT PLOT. 4615C REFERENCE--CLIFFORD COHEN (1991), "TRUNCATED AND CENSORED 4616C SAMPLES", MARCEL DEKKER INC., CHAPTER 2. 4617C WRITTEN BY--JAMES J. FILLIBEN 4618C STATISTICAL ENGINEERING DIVISION 4619C INFORMATION TECHNOLOGY LABORATORY 4620C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 4621C GAITHERSBURG, MD 20899-8980 4622C PHONE--301-975-2855 4623C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 4624C OF THE NATIONAL BUREAU OF STANDARDS. 4625C LANGUAGE--ANSI FORTRAN (1977) 4626C VERSION NUMBER--2008/12 4627C ORIGINAL VERSION--DECEMBER 2008. 4628C 4629C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 4630C 4631 CHARACTER*4 ICASPL 4632 CHARACTER*4 IHLEFT 4633 CHARACTER*4 IHLEF2 4634 CHARACTER*4 IHRIGH 4635 CHARACTER*4 IHRIG2 4636 CHARACTER*4 ISUBRO 4637 CHARACTER*4 IBUGG3 4638 CHARACTER*4 IERROR 4639C 4640 CHARACTER*4 IWRITE 4641 CHARACTER*4 ISUBN1 4642 CHARACTER*4 ISUBN2 4643 CHARACTER*4 IOP 4644C 4645C--------------------------------------------------------------------- 4646C 4647 DIMENSION Y(*) 4648 DIMENSION X(*) 4649 DIMENSION XMATCH(*) 4650 DIMENSION TEMP1(*) 4651 DIMENSION TEMP2(*) 4652 DIMENSION TEMP3(*) 4653 DIMENSION TEMP4(*) 4654 DIMENSION TEMP5(*) 4655 DIMENSION QP(*) 4656 DIMENSION XQPHAT(*) 4657 DIMENSION XQPLCL(*) 4658 DIMENSION XQPUCL(*) 4659 DIMENSION Y2(*) 4660 DIMENSION X2(*) 4661 DIMENSION D2(*) 4662C 4663 PARAMETER (NUMALP=6) 4664 DIMENSION ALPHA(NUMALP) 4665 DIMENSION ALOWSC(NUMALP) 4666 DIMENSION AUPPSC(NUMALP) 4667 DIMENSION ALOWLO(NUMALP) 4668 DIMENSION AUPPLO(NUMALP) 4669 DIMENSION COV(2,2) 4670 DIMENSION D(2) 4671C 4672 DOUBLE PRECISION DPDF 4673 DOUBLE PRECISION DPPF 4674 DOUBLE PRECISION DP 4675 DOUBLE PRECISION DMU 4676 DOUBLE PRECISION DSD 4677 DOUBLE PRECISION DARG1 4678C 4679 REAL MUML 4680 REAL SDML 4681 REAL MUMLSE 4682 REAL SDMLSE 4683 REAL COVSE 4684 REAL ACORR 4685 REAL THRESH 4686 REAL ALPHA 4687 REAL LOW05 4688C 4689 INCLUDE 'DPCOPA.INC' 4690 INCLUDE 'DPCOF2.INC' 4691 INCLUDE 'DPCOP2.INC' 4692C 4693C-----START POINT----------------------------------------------------- 4694C 4695 DATA ALPHA /0.50, 0.25, 0.10, 0.05, 0.01, 0.001/ 4696C 4697 ISUBN1='DPDL' 4698 ISUBN2='P2 ' 4699 IERROR='NO' 4700 IWRITE='OFF' 4701C 4702C ******************************************** 4703C ** STEP 1-- ** 4704C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 4705C ******************************************** 4706C 4707 IF(N.LE.2)THEN 4708 WRITE(ICOUT,999) 4709 999 FORMAT(1X) 4710 CALL DPWRST('XXX','BUG ') 4711 WRITE(ICOUT,31) 4712 31 FORMAT('***** ERROR IN DETECTION LIMIT PLOT--') 4713 CALL DPWRST('XXX','BUG ') 4714 WRITE(ICOUT,32) 4715 32 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.') 4716 CALL DPWRST('XXX','BUG ') 4717 WRITE(ICOUT,33) 4718 33 FORMAT(' MUST BE AT LEAST 1;') 4719 CALL DPWRST('XXX','BUG ') 4720 WRITE(ICOUT,34)N 4721 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) 4722 CALL DPWRST('XXX','BUG ') 4723 WRITE(ICOUT,999) 4724 CALL DPWRST('XXX','BUG ') 4725 IERROR='YES' 4726 GOTO9000 4727 ENDIF 4728C 4729C CHECK FOR NEGATIVE VALUES IN THE RESPONSE VARIABLE AND 4730C DEFINE VALUE OF TEMP1: 4731C 4732C 1 - POSITIVE VALUE FOR AN INCLUDED GROUP 4733C 2 - ZERO VALUE FOR AN INCLUDED GROUP 4734C 3 - POSITIVE VALUE FOR MEMBER OF EXCLUDED GROUP (USE TO COMPUTE 4735C MAXIMUM VALUE FOR THRESHOLD) 4736C 4 - ZERO VALUE FOR MEMBER OF EXCLUDED GROUP 4737C 4738 EPS=0.000001 4739 DO40I=1,N 4740 IF(Y(I).LT.0.0)THEN 4741 WRITE(ICOUT,999) 4742 CALL DPWRST('XXX','BUG ') 4743 WRITE(ICOUT,31) 4744 CALL DPWRST('XXX','BUG ') 4745 WRITE(ICOUT,41) 4746 41 FORMAT(' A NEGATIVE VALUE WAS ENCOUNTERED IN THE ', 4747 1 'RESPONSE VARIABLE.') 4748 CALL DPWRST('XXX','BUG ') 4749 WRITE(ICOUT,999) 4750 WRITE(ICOUT,43)I,Y(I) 4751 43 FORMAT(' A NEGATIVE VALUE WAS ENCOUNTERED IN THE ', 4752 1 'RESPONSE VARIABLE.') 4753 CALL DPWRST('XXX','BUG ') 4754 IERROR='YES' 4755 GOTO9000 4756 ELSE 4757 TEMP1(I)=1.0 4758 AINC=0.0 4759 IF(ABS(Y(I)).LE.EPS)AINC=1.0 4760 IFLAG=0 4761 DO50J=1,NPAR 4762 IF(X(I).EQ.XMATCH(J))IFLAG=1 4763 50 CONTINUE 4764 IF(IFLAG.EQ.0)TEMP1(I)=3.0 4765 TEMP1(I)=TEMP1(I)+AINC 4766 ENDIF 4767 40 CONTINUE 4768C 4769 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'DLP2')THEN 4770 WRITE(ICOUT,999) 4771 CALL DPWRST('XXX','BUG ') 4772 WRITE(ICOUT,70) 4773 70 FORMAT('***** AT THE BEGINNING OF DPDLP2--') 4774 CALL DPWRST('XXX','BUG ') 4775 WRITE(ICOUT,71)ICASPL,N,NPAR 4776 71 FORMAT('ICASPL,N,NPAR = ',A4,2X,2X,2I8) 4777 CALL DPWRST('XXX','BUG ') 4778 DO73I=1,N 4779 WRITE(ICOUT,74)I,Y(I),X(I),TEMP1(I) 4780 74 FORMAT('I,Y(I),X(I),TEMP1(I) = ',I8,3G15.7) 4781 CALL DPWRST('XXX','BUG ') 4782 73 CONTINUE 4783 DO83I=1,NPAR 4784 WRITE(ICOUT,84)I,XMATCH(I) 4785 84 FORMAT('I,XMATCH(I) = ',I8,G15.7) 4786 CALL DPWRST('XXX','BUG ') 4787 83 CONTINUE 4788 WRITE(ICOUT,85)IHLEFT,IHLEF2,IHRIGH,IHRIG2 4789 85 FORMAT('IHLEFT,IHLEF2,IHRIGH,IHRIG2 = ',3(A4,2X),A4) 4790 CALL DPWRST('XXX','BUG ') 4791 ENDIF 4792C 4793C ********************************************** 4794C ** STEP 2-- ** 4795C ** COMPUTE SUMMARY STATISTICS ** 4796C ********************************************** 4797C 4798C 1 - MEAN OF DATA IN INCLUDED GROUP THAT IS > 0 4799C 2 - SD OF DATA IN INCLUDED GROUP THAT IS > 0 4800C 3 - NUMBER OF NON-ZERO VALUES IN INCLUDED GROUP 4801C 4 - NUMBER OF ZERO VALUES IN INCLUDED GROUP 4802C 5 - MINIMUM OF NON-ZERO DATA FOR ALL GROUPS 4803C 6 - ESTIMATED THRESHOLD 4804C 4805 NZERO=0 4806 NPOS=0 4807 YMIN1=CPUMAX 4808C 4809 ICNT=0 4810 DO1010I=1,N 4811 IF(TEMP1(I).EQ.1.0)THEN 4812 NPOS=NPOS+1 4813 TEMP2(NPOS)=Y(I) 4814 ICNT=ICNT+1 4815 TEMP3(ICNT)=Y(I) 4816 TEMP4(ICNT)=1.0 4817 ELSEIF(TEMP1(I).EQ.2.0)THEN 4818 NZERO=NZERO+1 4819 ICNT=ICNT+1 4820 TEMP3(ICNT)=Y(I) 4821 TEMP4(ICNT)=0.0 4822 ENDIF 4823 IF(Y(I).GT.0.0 .AND. Y(I).LT.YMIN1)YMIN1=Y(I) 4824 IF(Y(I).GT.YMIN1 .AND. Y(I).LT.YMIN2)YMIN2=Y(I) 4825 1010 CONTINUE 4826 NSAMP=ICNT 4827C 4828 YMIN2=CPUMAX 4829 DO1015I=1,N 4830 IF(Y(I).GT.YMIN1 .AND. Y(I).LT.YMIN2)YMIN2=Y(I) 4831 1015 CONTINUE 4832C 4833 IF(NPOS.LT.1)THEN 4834 WRITE(ICOUT,999) 4835 CALL DPWRST('XXX','BUG ') 4836 WRITE(ICOUT,31) 4837 CALL DPWRST('XXX','BUG ') 4838 WRITE(ICOUT,1021) 4839 1021 FORMAT(' NO POSITVE VALUES WERE FOUND IN THE ') 4840 CALL DPWRST('XXX','BUG ') 4841 WRITE(ICOUT,1023) 4842 1023 FORMAT(' INCLUDED GROUP. NOTHING DONE.') 4843 CALL DPWRST('XXX','BUG ') 4844 WRITE(ICOUT,999) 4845 CALL DPWRST('XXX','BUG ') 4846 IERROR='YES' 4847 GOTO9000 4848 ENDIF 4849C 4850 NTOT=NPOS+NZERO 4851 PRZERO=100.0*REAL(NZERO)/REAL(NTOT) 4852 CALL MEAN(TEMP2,NPOS,IWRITE,YMEAN1,IBUGG3,IERROR) 4853 CALL SD(TEMP2,NPOS,IWRITE,YSD1,IBUGG3,IERROR) 4854 IF(THRESH.EQ.CPUMIN .OR. THRESH.GT.YMIN1)THEN 4855 THRESH=YMIN1 - (YMIN2-YMIN1) 4856 ENDIF 4857C 4858C ********************************************** 4859C ** STEP 3-- ** 4860C ** COMPUTE PARAMETER ESTIMATES ** 4861C ********************************************** 4862C 4863 CALL DPDLP3(TEMP3,TEMP4,NSAMP,THRESH, 4864 1 TEMP5, 4865 1 MUML,SDML, 4866 1 MUMLSE,SDMLSE,COVSE,ACORR, 4867 1 ISUBRO,IBUGG3,IERROR) 4868C 4869C ********************************************** 4870C ** STEP 4-- ** 4871C ** COMPUTE SELECT PERCENTILES ** 4872C ********************************************** 4873C 4874 DP=0.95D0 4875 DMU=DBLE(MUML) 4876 DSD=DBLE(SDML) 4877CCCCC CALL TNRPPF(DP,DA,DB,DMU,DSD,DPPF) 4878 CALL NODPPF(DP,DPPF) 4879 DPPF=DMU + DSD*DPPF 4880 UPP95=REAL(DPPF) 4881 DP=0.05D0 4882 CALL NODPPF(DP,DPPF) 4883 DPPF=DMU + DSD*DPPF 4884 LOW05=REAL(DPPF) 4885 DP=DBLE(THRESH) 4886 CALL NODPPF(DP,DPPF) 4887 DPPF=DMU + DSD*DPPF 4888 CDFTHR=REAL(DPPF) 4889C 4890 IF(NPERC.GT.0)THEN 4891 IOP='OPEN' 4892 IFLAG1=1 4893 IFLAG2=0 4894 IFLAG3=0 4895 IFLAG4=0 4896 IFLAG5=0 4897 CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5, 4898 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 4899 1 IBUGG3,ISUBRO,IERROR) 4900 IF(IERROR.EQ.'YES')GOTO9000 4901C 4902 DO1050I=1,NPERC 4903 DP=DBLE(QP(I)/100.0) 4904CCCCC CALL TNRPPF(DP,DA,DB,DMU,DSD,DPPF) 4905 CALL NODPPF(DP,DPPF) 4906 DPPF=DMU + DSD*DPPF 4907 XQPHAT(I)=REAL(DPPF) 4908 WRITE(IOUNI1,'(2E15.7)')QP(I),XQPHAT(I) 4909 1050 CONTINUE 4910C 4911 IOP='CLOS' 4912 CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5, 4913 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 4914 1 IBUGG3,ISUBRO,IERROR) 4915 IF(IERROR.EQ.'YES')GOTO9000 4916 ENDIF 4917C 4918C ********************************************** 4919C ** STEP 5-- ** 4920C ** GENERATE PLOT OF THE TRUNCATED NORMAL ** 4921C ** CURVE BASED ON ESTIMATED PARAMETERS. ** 4922C ********************************************** 4923C 4924 XSTRT=THRESH 4925 XSTOP=MUML + 3.5*SDML 4926 DMU=DBLE(MUML) 4927 DSD=DBLE(SDML) 4928 ICNT=1 4929 X2(ICNT)=0.0 4930 Y2(ICNT)=0.0 4931 D2(ICNT)=1.0 4932 ICNT=ICNT+1 4933 X2(ICNT)=XSTRT 4934 Y2(ICNT)=0.0 4935 D2(ICNT)=1.0 4936 ICNT=ICNT+1 4937 AUPP=CPUMIN 4938CCCCC CALL TNRPDF(DBLE(XSTRT),DBLE(THRESH),DBLE(AUPP),DBLE(MUML), 4939CCCCC1 DBLE(SDML),DPDF) 4940 DARG1=(DBLE(XSTRT)-DMU)/DSD 4941 CALL NODPDF(DARG1,DPDF) 4942 DPDF=DPDF/DSD 4943 Y2(ICNT)=REAL(DPDF) 4944 D2(ICNT)=1.0 4945C 4946 NP=200 4947 XINC=(XSTOP-XSTRT)/REAL(NP) 4948 XVAL=XSTRT 4949 DO2000I=1,NP 4950 XVAL=XVAL+XINC 4951CCCCC CALL TNRPDF(DBLE(XVAL),DBLE(THRESH),DBLE(AUPP),DBLE(MUML), 4952CCCCC1 DBLE(SDML),DPDF) 4953 DARG1=(DBLE(XVAL)-DMU)/DSD 4954 CALL NODPDF(DARG1,DPDF) 4955 DPDF=DPDF/DSD 4956 ICNT=ICNT+1 4957 X2(ICNT)=XVAL 4958 Y2(ICNT)=REAL(DPDF) 4959 D2(ICNT)=1.0 4960 2000 CONTINUE 4961C 4962 ICNT=ICNT+1 4963 X2(ICNT)=0.0 4964 Y2(ICNT)=0.0 4965 D2(ICNT)=2.0 4966 NP=20 4967 XINC=XSTRT/REAL(NP) 4968 XVAL=0.0 4969 DO2010I=1,NP 4970 XVAL=XVAL+XINC 4971CCCCC CALL TNRPDF(DBLE(XVAL),DBLE(THRESH),DBLE(AUPP),DBLE(MUML), 4972CCCCC1 DBLE(SDML),DPDF) 4973 DARG1=(DBLE(XVAL)-DMU)/DSD 4974 CALL NODPDF(DARG1,DPDF) 4975 DPDF=DPDF/DSD 4976 ICNT=ICNT+1 4977 X2(ICNT)=XVAL 4978 Y2(ICNT)=REAL(DPDF) 4979 D2(ICNT)=2.0 4980 2010 CONTINUE 4981C 4982 DO2060I=1,NUMALP 4983C 4984 ALP=ALPHA(I) 4985 P1=ALP/2.0 4986 P2=1.0-(ALP/2.0) 4987 CALL NORPPF(P1,APPF1) 4988 CALL NORPPF(P2,APPF2) 4989 ALOWLO(I)=0.0 4990 AUPPLO(I)=0.0 4991 ALOWSC(I)=0.0 4992 AUPPSC(I)=0.0 4993C 4994 ALOWLO(I)=MUML + APPF1*MUMLSE 4995 AUPPLO(I)=MUML + APPF2*MUMLSE 4996 ALOWSC(I)=SDML + APPF1*SDMLSE 4997 AUPPSC(I)=SDML + APPF2*SDMLSE 4998 2060 CONTINUE 4999C 5000 D(1)=1.0 5001 ALPHL=ALPCV/2.0 5002 ALPHU=1.0 - ALPCV/2.0 5003 CALL NORPPF(ALPHU,ZALPU) 5004C 5005 COV(1,1)=MUMLSE**2 5006 COV(2,2)=SDMLSE**2 5007 COV(1,2)=COVSE 5008 COV(2,1)=COV(1,2) 5009C 5010 DO2160I=1,NPERC 5011 QPTEMP=QP(I)/100.0 5012 CALL NORPPF(QPTEMP,D(2)) 5013 XQPHAT(I)=MUML + SDML*D(2) 5014 DSUM1=0.0D0 5015 DO2170II=1,2 5016 DO2180JJ=1,2 5017 DSUM1=DSUM1 + D(II)*D(JJ)*COV(II,JJ) 5018 2180 CONTINUE 5019 2170 CONTINUE 5020 XQPSE=SQRT(REAL(DSUM1)) 5021 ATEMP1=XQPHAT(I) - ZALPU*XQPSE 5022 ATEMP2=XQPHAT(I) + ZALPU*XQPSE 5023 XQPLCL(I)=MIN(ATEMP1,ATEMP2) 5024 XQPUCL(I)=MAX(ATEMP1,ATEMP2) 5025 2160 CONTINUE 5026C 5027 N2=ICNT 5028 NPLOTV=2 5029C 5030 IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN 5031 WRITE(ICOUT,999) 5032 CALL DPWRST('XXX','BUG ') 5033 WRITE(ICOUT,4001) 5034 4001 FORMAT(12X,'PROBABILITY OF DETECTION - VERKOUTEREN NORMAL ', 5035 1 'DATA METHOD') 5036 CALL DPWRST('XXX','BUG ') 5037 WRITE(ICOUT,999) 5038 CALL DPWRST('XXX','BUG ') 5039C 5040 WRITE(ICOUT,4011) 5041 4011 FORMAT('INCLUDED GROUPS:') 5042 CALL DPWRST('XXX','BUG ') 5043 DO4012I=1,NPAR 5044 WRITE(ICOUT,4015)IHRIGH,IHRIG2,XMATCH(I) 5045 4015 FORMAT(A4,A4,' = ', 5046 1 G15.7) 5047 CALL DPWRST('XXX','BUG ') 5048 4012 CONTINUE 5049 WRITE(ICOUT,999) 5050 CALL DPWRST('XXX','BUG ') 5051C 5052 WRITE(ICOUT,4021) 5053 4021 FORMAT('SUMMARY STATISTICS:') 5054 CALL DPWRST('XXX','BUG ') 5055 WRITE(ICOUT,4022)NPOS 5056 4022 FORMAT('NUMBER OF POSITIVE VALUES IN INCLUDED GROUPS = ',I8) 5057 CALL DPWRST('XXX','BUG ') 5058 WRITE(ICOUT,4023)NZERO 5059 4023 FORMAT('NUMBER OF ZERO VALUES IN INCLUDED GROUPS = ',I8) 5060 CALL DPWRST('XXX','BUG ') 5061 WRITE(ICOUT,4024)YMEAN1 5062 4024 FORMAT('MEAN OF TRUNCATED DATA = ',G15.7) 5063 CALL DPWRST('XXX','BUG ') 5064 WRITE(ICOUT,4025)YSD1 5065 4025 FORMAT('SD OF TRUNCATED DATA = ',G15.7) 5066 CALL DPWRST('XXX','BUG ') 5067 WRITE(ICOUT,999) 5068 CALL DPWRST('XXX','BUG ') 5069 WRITE(ICOUT,4026)YMIN1 5070 4026 FORMAT('MINIMUM FOR NON-ZERO DATA = ',G15.7) 5071 CALL DPWRST('XXX','BUG ') 5072 WRITE(ICOUT,4027)THRESH 5073 4027 FORMAT('THRESHOLD VALUE = ',G15.7) 5074 CALL DPWRST('XXX','BUG ') 5075 WRITE(ICOUT,4029)PRZERO 5076 4029 FORMAT('PERCENTAGE OF ZERO DATA = ',G15.7) 5077 CALL DPWRST('XXX','BUG ') 5078C 5079CCCCC WRITE(ICOUT,999) 5080CCCCC CALL DPWRST('XXX','BUG ') 5081CCCCC WRITE(ICOUT,4031) 5082C4031 FORMAT('MOMENT ESTIMATES (BASED ON THREE MOMENTS):') 5083CCCCC CALL DPWRST('XXX','BUG ') 5084CCCCC WRITE(ICOUT,4032)MUMOME 5085C4032 FORMAT('ESTIMATE OF MU = ',G15.7) 5086CCCCC CALL DPWRST('XXX','BUG ') 5087CCCCC WRITE(ICOUT,4034)SDMOME 5088C4034 FORMAT('ESTIMATE OF SIGMA = ',G15.7) 5089CCCCC CALL DPWRST('XXX','BUG ') 5090C 5091 WRITE(ICOUT,999) 5092 CALL DPWRST('XXX','BUG ') 5093 WRITE(ICOUT,4041) 5094 4041 FORMAT('MAXIMUM LIKELIHOOD ESTIMATES:') 5095 CALL DPWRST('XXX','BUG ') 5096 WRITE(ICOUT,4042)MUML 5097 4042 FORMAT('ESTIMATE OF MU = ',G15.7) 5098 CALL DPWRST('XXX','BUG ') 5099 WRITE(ICOUT,4044)SDML 5100 4044 FORMAT('ESTIMATE OF SIGMA = ',G15.7) 5101 CALL DPWRST('XXX','BUG ') 5102 WRITE(ICOUT,4046)MUMLSE 5103 4046 FORMAT('STANDARD ERROR OF MU = ',G15.7) 5104 CALL DPWRST('XXX','BUG ') 5105 WRITE(ICOUT,4048)SDMLSE 5106 4048 FORMAT('STANDARD ERROR OF SIGMA = ',G15.7) 5107 CALL DPWRST('XXX','BUG ') 5108 WRITE(ICOUT,4049)COVSE 5109 4049 FORMAT('COVARIANCE OF MU AND SIGMA = ',G15.7) 5110 CALL DPWRST('XXX','BUG ') 5111 WRITE(ICOUT,4050)ACORR 5112 4050 FORMAT('CORRELATION BETWEEN MU AND SIGMA = ',G15.7) 5113 CALL DPWRST('XXX','BUG ') 5114C 5115 WRITE(ICOUT,999) 5116 CALL DPWRST('XXX','WRIT') 5117 WRITE(ICOUT,4640) 5118 4640 FORMAT('CONFIDENCE INTERVAL FOR LOCATION PARAMETER') 5119 CALL DPWRST('XXX','WRIT') 5120 WRITE(ICOUT,999) 5121 CALL DPWRST('XXX','WRIT') 5122 WRITE(ICOUT,4643) 5123 4643 FORMAT(' CONFIDENCE LOWER UPPER') 5124 CALL DPWRST('XXX','WRIT') 5125 WRITE(ICOUT,4645) 5126 4645 FORMAT(' VALUE (%) LIMIT LIMIT') 5127 CALL DPWRST('XXX','WRIT') 5128 WRITE(ICOUT,4646) 5129 4646 FORMAT('-------------------------------------------') 5130 CALL DPWRST('XXX','WRIT') 5131C 5132 DO4649I=1,NUMALP 5133 ATEMP=100.0*(1.0 - ALPHA(I)) 5134 WRITE(ICOUT,4647)ATEMP,ALOWLO(I),AUPPLO(I) 5135 4647 FORMAT(' ',F8.3,9X,G13.6,1X,G13.6) 5136 CALL DPWRST('XXX','WRIT') 5137 4649 CONTINUE 5138 WRITE(ICOUT,999) 5139 CALL DPWRST('XXX','WRIT') 5140C 5141 WRITE(ICOUT,4680) 5142 4680 FORMAT('CONFIDENCE INTERVAL FOR SCALE PARAMETER') 5143 CALL DPWRST('XXX','WRIT') 5144 WRITE(ICOUT,999) 5145 CALL DPWRST('XXX','WRIT') 5146 WRITE(ICOUT,4643) 5147 CALL DPWRST('XXX','WRIT') 5148 WRITE(ICOUT,4645) 5149 CALL DPWRST('XXX','WRIT') 5150 WRITE(ICOUT,4646) 5151 CALL DPWRST('XXX','WRIT') 5152C 5153 DO4689I=1,NUMALP 5154 ATEMP=100.0*(1.0 - ALPHA(I)) 5155 WRITE(ICOUT,4647)ATEMP,ALOWSC(I),AUPPSC(I) 5156 CALL DPWRST('XXX','WRIT') 5157 4689 CONTINUE 5158 WRITE(ICOUT,999) 5159 CALL DPWRST('XXX','WRIT') 5160C 5161 IF(NPERC.GT.0)THEN 5162 WRITE(ICOUT,4911) 5163 4911 FORMAT('CONFIDENCE LIMITS FOR SELECTED PERCENTILES:') 5164 CALL DPWRST('XXX','WRIT') 5165 WRITE(ICOUT,4914) 5166 4914 FORMAT('CENSORED CASE (BASED ON NORMAL APPROXIMATION)') 5167 CALL DPWRST('XXX','WRIT') 5168 WRITE(ICOUT,4915)ALPCV 5169 4915 FORMAT('ALPHA = ',F7.4) 5170 CALL DPWRST('XXX','WRIT') 5171 WRITE(ICOUT,4921) 5172 4921 FORMAT(15X,' POINT ',' LOWER ', 5173 1 ' UPPER') 5174 CALL DPWRST('XXX','WRIT') 5175 WRITE(ICOUT,4922) 5176 4922 FORMAT(' PERCENTILE',' ESTIMATE ', 5177 1 'CONFIDENCE LIMIT ',' CONFIDENCE LIMIT') 5178 CALL DPWRST('XXX','WRIT') 5179 WRITE(ICOUT,4924) 5180 4924 FORMAT('---------------','------------------', 5181 1 '-----------------','------------------') 5182 CALL DPWRST('XXX','WRIT') 5183C 5184 DO4930I=1,NPERC 5185 WRITE(ICOUT,4932)QP(I),XQPHAT(I),XQPLCL(I),XQPUCL(I) 5186 4932 FORMAT(F15.3,2X,G15.7,6X,G15.7,4X,G15.7) 5187 CALL DPWRST('XXX','WRIT') 5188 4930 CONTINUE 5189 ENDIF 5190C 5191 WRITE(ICOUT,999) 5192 CALL DPWRST('XXX','BUG ') 5193 ENDIF 5194C 5195C ****************** 5196C ** STEP 90-- ** 5197C ** EXIT ** 5198C ****************** 5199C 5200 9000 CONTINUE 5201 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'DLP2')THEN 5202 WRITE(ICOUT,999) 5203 CALL DPWRST('XXX','BUG ') 5204 WRITE(ICOUT,9011) 5205 9011 FORMAT('***** AT THE END OF DPDLP2--') 5206 CALL DPWRST('XXX','BUG ') 5207 WRITE(ICOUT,9012)ICASPL,IDATSW,PSTRIN,IERROR,N2 5208 9012 FORMAT('ICASPL,IDATSW,PSTRIN,IERROR,N2 = ', 5209 1 A4,2X,A4,2X,G15.7,2X,A4,2X,I8) 5210 CALL DPWRST('XXX','BUG ') 5211 DO9015I=1,N2 5212 WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I) 5213 9016 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) 5214 CALL DPWRST('XXX','BUG ') 5215 9015 CONTINUE 5216 ENDIF 5217C 5218 RETURN 5219 END 5220 SUBROUTINE DPDLP3(Y,X,N,T, 5221 1 TEMP1, 5222 1 MUML,SDML, 5223 1 MUMLSE,SDMLSE,COVSE,ACORR, 5224 1 ISUBRO,IBUGA3,IERROR) 5225C 5226C PURPOSE--THIS ROUTINE ESTIMATES THE PARAMETERS FOR THE 5227C "DETECTION LIMIT PLOT" COMMAND. NOTE THAT THIS 5228C IS ACTUALLY A SINGLY LEFT CENSORED PROBLEM (THE 5229C DISTINCTION BETWEEN CENSORING AND TRUNCATION IS 5230C THAT FOR THE CENSORED CASE WE KNOW HOW MANY 5231C MEASUREMENTS ARE RESTRICTED WHILE FOR THE TRUNCATED 5232C CASE WE DO NOT). 5233C 5234C THE MAXIMUM LIKELIHOOD ESTIMATES ARE: 5235C 5236C SIGMAHAT = SQRT{S**2 + lambda(h,alphahat)*(XBAR - T)**2} 5237C MUHAT = XBAR - lambda(h,alphahat)*(XBAR - T) 5238C 5239C WHERE 5240C 5241C alphahat = S**2/(XBAR - T)**2 5242C h = c/N 5243C N = TOTAL NUMBER OF OBSERVATIONS 5244C n = NUMBER OF NON-TRUNCATED OBSERVATIONS 5245C c = NUMBER OF TRUNCATED OBSERVATIONS 5246C 5247C XBAR AND S ARE THE MEAN AND SD OF THE NON-TRUNCATED 5248C OBSERVATIONS. 5249C 5250C LAMBDA(H,ALPHAHAT) IS A TABULATED VALUE IN THE 5251C COHEN REFERENCE. HOWEVER, WE DETERMINE IT BY 5252C SOLVING THE FUNCTION 5253C 5254C ((1 - OMEGA(h,XI)*(OMEGA(h,XI) - XI))/ 5255C (OMEGA(h,XI) - XI)**2) - S**2/(MU - T)**2 5256C 5257C FOR XI WHERE 5258C 5259C OMEGA(h,XI) = (h/(1-h))*NORPDF(XI)/NORCDF(XI) 5260C 5261C NOTE THAT XI IS THE STANDARDIZED TRUNCATION 5262C POINT. ONCE WE SOLVE FOR XI, WE PLUG IT INTO 5263C THE FUNCTION 5264C 5265C LAMBDA = OMEGA(h,XI)/(OMEGA(h,XI) - XI) 5266C 5267C NOTE THAT THERE MAY BE TWO SOLUTIONS TO THIS 5268C EQUATION. WE PICK THE ONE THAT RESULTS IN A 5269C POSITIVE LAMBDA. 5270C 5271C REFERENCE--CLIFFORD COHEN (1991), "TRUNCATED AND CENSORED 5272C SAMPLES", MARCEL DEKKER INC., CHAPTER 2. 5273C WRITTEN BY--JAMES J. FILLIBEN 5274C STATISTICAL ENGINEERING DIVISION 5275C INFORMATION TECHNOLOGY LABORATORY 5276C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5277C GAITHERSBURG, MD 20899-8980 5278C PHONE--301-975-2855 5279C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5280C OF THE NATIONAL BUREAU OF STANDARDS. 5281C LANGUAGE--ANSI FORTRAN (1977) 5282C VERSION NUMBER--2008/12 5283C ORIGINAL VERSION--DECEMBER 2008. 5284C 5285C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5286C 5287 CHARACTER*4 ISUBRO 5288 CHARACTER*4 IBUGA3 5289 CHARACTER*4 IERROR 5290C 5291 CHARACTER*4 IWRITE 5292 CHARACTER*4 ISUBN1 5293 CHARACTER*4 ISUBN2 5294C 5295C--------------------------------------------------------------------- 5296C 5297 DIMENSION Y(*) 5298 DIMENSION X(*) 5299 DIMENSION TEMP1(*) 5300C 5301 DOUBLE PRECISION DSUM1 5302 DOUBLE PRECISION DMEAN 5303 DOUBLE PRECISION DVARI 5304 DOUBLE PRECISION DT 5305 DOUBLE PRECISION DNTOT 5306 DOUBLE PRECISION DNFULL 5307 DOUBLE PRECISION DPDF 5308 DOUBLE PRECISION DCDF 5309 DOUBLE PRECISION DPDF2 5310 DOUBLE PRECISION DCDF2 5311 DOUBLE PRECISION DTERM1 5312 DOUBLE PRECISION DTERM2 5313 DOUBLE PRECISION DDENOM 5314 DOUBLE PRECISION DOMEGA 5315 DOUBLE PRECISION DLAMB 5316 DOUBLE PRECISION DQ 5317 DOUBLE PRECISION DQ2 5318 DOUBLE PRECISION DPHI11 5319 DOUBLE PRECISION DPHI12 5320 DOUBLE PRECISION DPHI22 5321 DOUBLE PRECISION DU11 5322 DOUBLE PRECISION DU12 5323 DOUBLE PRECISION DU22 5324C 5325 REAL MUML 5326 REAL SDML 5327 REAL MUMLSE 5328 REAL SDMLSE 5329C 5330 DOUBLE PRECISION AE 5331 DOUBLE PRECISION RE 5332 DOUBLE PRECISION XLOW 5333 DOUBLE PRECISION XUP 5334 DOUBLE PRECISION XMID 5335 DOUBLE PRECISION XI 5336C 5337 DOUBLE PRECISION TNRFUN 5338 EXTERNAL TNRFUN 5339C 5340 DOUBLE PRECISION DC1 5341 DOUBLE PRECISION DH 5342 COMMON/TNRCOM/DC1,DH 5343C--------------------------------------------------------------------- 5344C 5345 INCLUDE 'DPCOP2.INC' 5346C 5347C-----START POINT----------------------------------------------------- 5348C 5349 ISUBN1='DPTN' 5350 ISUBN2='S1 ' 5351C 5352 IERROR='NO' 5353 IWRITE='OFF' 5354C 5355C ******************************************** 5356C ** STEP 1-- ** 5357C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 5358C ******************************************** 5359C 5360 IF(N.LE.2)THEN 5361 WRITE(ICOUT,999) 5362 999 FORMAT(1X) 5363 CALL DPWRST('XXX','BUG ') 5364 WRITE(ICOUT,31) 5365 31 FORMAT('***** ERROR IN NORMAL SINGLY LEFT CENSORED ', 5366 1 'PARAMETER ESTIMATION--') 5367 CALL DPWRST('XXX','BUG ') 5368 WRITE(ICOUT,32) 5369 32 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.') 5370 CALL DPWRST('XXX','BUG ') 5371 WRITE(ICOUT,34)N 5372 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) 5373 CALL DPWRST('XXX','BUG ') 5374 WRITE(ICOUT,999) 5375 CALL DPWRST('XXX','BUG ') 5376 IERROR='YES' 5377 GOTO9000 5378 ENDIF 5379C 5380 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DLP3')THEN 5381 WRITE(ICOUT,999) 5382 CALL DPWRST('XXX','BUG ') 5383 WRITE(ICOUT,70) 5384 70 FORMAT('***** AT THE BEGINNING OF DPDLP3--') 5385 CALL DPWRST('XXX','BUG ') 5386 WRITE(ICOUT,71)N 5387 71 FORMAT('N = ',I8) 5388 CALL DPWRST('XXX','BUG ') 5389 DO73I=1,N 5390 WRITE(ICOUT,74)I,Y(I),X(I) 5391 74 FORMAT('I,Y(I),X(I) = ',I8,2G15.7) 5392 CALL DPWRST('XXX','BUG ') 5393 73 CONTINUE 5394 ENDIF 5395C 5396C ********************************************** 5397C ** STEP 2-- ** 5398C ** COMPUTE SUMMARY STATISTICS ** 5399C ********************************************** 5400C 5401 MUML=0.0 5402 SDML=0.0 5403C 5404 NC=0 5405 NFULL=0 5406 YMIN=CPUMAX 5407 DSUM1=0.0D0 5408C 5409 DO1010I=1,N 5410 IF(X(I).GT.0.0)THEN 5411 NFULL=NFULL+1 5412 TEMP1(NFULL)=Y(I) 5413 DSUM1=DSUM1 + DBLE(Y(I)) 5414 IF(Y(I).LT.YMIN)YMIN=Y(I) 5415 ELSE 5416 NC=NC+1 5417 ENDIF 5418 1010 CONTINUE 5419 DNFULL=DBLE(NFULL) 5420 DNC=DBLE(NC) 5421 DNTOT=DBLE(N) 5422 DMEAN=DSUM1/DNFULL 5423 IF(T.GT.CPUMIN .AND. T.LE.YMIN)THEN 5424 DT=DBLE(T) 5425 ELSE 5426 DT=DBLE(YMIN) 5427 ENDIF 5428C 5429 IF(NFULL.LT.2)THEN 5430 WRITE(ICOUT,999) 5431 CALL DPWRST('XXX','BUG ') 5432 WRITE(ICOUT,31) 5433 CALL DPWRST('XXX','BUG ') 5434 WRITE(ICOUT,1012) 5435 1012 FORMAT(' THE NUMBER OF UNCENSORED OBSERVATIONS MUST BE ', 5436 1 'AT LEAST 2.') 5437 CALL DPWRST('XXX','BUG ') 5438 WRITE(ICOUT,1014)NFULL 5439 1014 FORMAT(' THE NUMBER OF UNCENSORED OBSERVATIONS HERE = ', 5440 1 I8) 5441 CALL DPWRST('XXX','BUG ') 5442 WRITE(ICOUT,999) 5443 CALL DPWRST('XXX','BUG ') 5444 IERROR='YES' 5445 GOTO9000 5446 ENDIF 5447C 5448 DVARI=0.0D0 5449 DO1020I=1,NFULL 5450 DVARI=DVARI + (DBLE(TEMP1(I)) - DMEAN)**2/DNFULL 5451 1020 CONTINUE 5452C 5453 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DLP3')THEN 5454 WRITE(ICOUT,999) 5455 CALL DPWRST('XXX','BUG ') 5456 WRITE(ICOUT,1031) 5457 1031 FORMAT('***** DPDLP3: AFTER COMPUTE SUMMARY STATISTICS') 5458 CALL DPWRST('XXX','BUG ') 5459 WRITE(ICOUT,1032)N,NFULL,NC 5460 1032 FORMAT('N,NFULL,NC = ',3I8) 5461 CALL DPWRST('XXX','BUG ') 5462 WRITE(ICOUT,1033)DMEAN,DVARI,DT 5463 1033 FORMAT('DMEAN,DVARI,DT = ',3G15.7) 5464 CALL DPWRST('XXX','BUG ') 5465 ENDIF 5466C 5467C ********************************************** 5468C ** STEP 3-- ** 5469C ** COMPUTE MAXIMUM LIKELIHOOD ESTIMATES ** 5470C ********************************************** 5471C 5472C DEFINE SOME CONSTANTS FOR THE FUNCTION SOLVER 5473C 5474 DH=DNC/DNTOT 5475 DC1=DVARI/(DMEAN - DT)**2 5476C 5477C USE DFZERO TO SOLVE THE LAMBDAHAT FUNCTION 5478C 5479 AE=1.D-7 5480 RE=1.D-7 5481 XLOW=-10.0D0 5482 XUP=10.0D0 5483 IF(DMEAN.GT.DT)THEN 5484 XMID=-1.0D0 5485 ELSE 5486 XMID=1.0D0 5487 ENDIF 5488 ITER=0 5489C 5490 1410 CONTINUE 5491 CALL DFZERO(TNRFUN,XLOW,XUP,XMID,RE,AE,IFLAG) 5492 XI=XLOW 5493C 5494C NOW EVALUATE - CHECK FOR POSITIVE RESULT 5495C 5496 CALL NODPDF(XI,DPDF) 5497 CALL NODCDF(XI,DCDF) 5498 CALL NODPDF(-XI,DPDF2) 5499 CALL NODCDF(-XI,DCDF2) 5500 DOMEGA=(DH/(1.0D0-DH))*DPDF/DCDF 5501 DLAMB=DOMEGA/(DOMEGA - XI) 5502 IF(DLAMB.LT.0.0D0)THEN 5503 IF(ITER.EQ.0)THEN 5504 ITER=1 5505 XLOW=-10.0D0 5506 XUP=XI-0.1D0 5507 XMID=(XLOW+XUP)/2.0D0 5508 GOTO1410 5509 ELSEIF(ITER.EQ.1)THEN 5510 ITER=2 5511 XLOW=XI+0.1D0 5512 XUP=10.0D0 5513 XMID=(XLOW+XUP)/2.0D0 5514 GOTO1410 5515 ELSE 5516 WRITE(ICOUT,999) 5517 CALL DPWRST('XXX','BUG ') 5518 WRITE(ICOUT,31) 5519 CALL DPWRST('XXX','BUG ') 5520 WRITE(ICOUT,1413) 5521 1413 FORMAT(' UNABLE TO DETERMINE MAXIMUM LIKELIHOOD ', 5522 1 'ESTIMATES.') 5523 CALL DPWRST('XXX','BUG ') 5524 GOTO1499 5525 ENDIF 5526 ENDIF 5527C 5528 SDML=REAL(DSQRT(DVARI + DLAMB*(DMEAN - DT)**2)) 5529 MUML=REAL(DMEAN - DLAMB*(DMEAN - DT)) 5530C 5531C NOW COMPUTE STANDARD ERRORS 5532C 5533 IF(DCDF.GE.1.0D0 .OR. DCDF2.GE.1.0D0)THEN 5534 WRITE(ICOUT,999) 5535 CALL DPWRST('XXX','BUG ') 5536 WRITE(ICOUT,1431) 5537 1431 FORMAT('***** WARNING IN NORMAL SINGLY LEFT CENSORED ', 5538 1 'PARAMETER ESTIMATION--') 5539 CALL DPWRST('XXX','BUG ') 5540 WRITE(ICOUT,1433) 5541 1433 FORMAT(' UNABLE TO COMPUTE STANDARD ERRORS OF THE ', 5542 1 'MAXIMUM LIKELIHOOD ESTIMATES.') 5543 CALL DPWRST('XXX','BUG ') 5544 GOTO1499 5545 ENDIF 5546C 5547 DQ=DPDF/(1.0D0 - DCDF) 5548 DQ2=DPDF2/(1.0D0 - DCDF2) 5549 DPHI11=1.0D0 + DQ*(DQ2 + XI) 5550 DPHI12=DQ*(1.0D0 + XI*(DQ2 + XI)) 5551 DPHI22=2.0D0 + XI*DPHI12 5552 DDENOM=DPHI11*DPHI22 - DPHI12**2 5553 DTERM1=1.0D0/(1.0D0 - DCDF) 5554 DU11=DTERM1*DPHI22/DDENOM 5555 DU22=DTERM1*DPHI11/DDENOM 5556 DU12=-DTERM1*DPHI12/DDENOM 5557 DTERM2=DBLE(SDML)**2/DNTOT 5558 MUMLSE=REAL(DSQRT(DTERM2*DU11)) 5559 SDMLSE=REAL(DSQRT(DTERM2*DU22)) 5560 COVSE=REAL(DTERM2*DU12) 5561 ACORR=REAL(DU12/DSQRT(DU11*DU22)) 5562C 5563 1499 CONTINUE 5564C 5565 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DLP3')THEN 5566 WRITE(ICOUT,999) 5567 CALL DPWRST('XXX','BUG ') 5568 WRITE(ICOUT,1111) 5569 1111 FORMAT('***** DPDLP3: AFTER COMPUTE ML ESTIMATES') 5570 CALL DPWRST('XXX','BUG ') 5571 WRITE(ICOUT,1112)DH,XI,DPDF,DCDF,DPDF2,DCDF2 5572 1112 FORMAT('DH,XI,DPDF,DCDF,DPDF2,DCDF2 = ',6G15.7) 5573 CALL DPWRST('XXX','BUG ') 5574 WRITE(ICOUT,1113)DTERM1,DTERM2,DOMEGA,DLAMB 5575 1113 FORMAT('DTERM1,DTERM2,DOMEGA,DLAMB = ',4G15.7) 5576 CALL DPWRST('XXX','BUG ') 5577 WRITE(ICOUT,1114)MUML,SDML 5578 1114 FORMAT('MUML,SDML = ',2G15.7) 5579 CALL DPWRST('XXX','BUG ') 5580 WRITE(ICOUT,1115)DQ,DQ2,DPHI11,DPHI12,DPHI22 5581 1115 FORMAT('DQ,DQ2,DPHI11,DPHI12,DPHI22 = ',4G15.7) 5582 CALL DPWRST('XXX','BUG ') 5583 WRITE(ICOUT,1116)DDENOM,DU11,DU22,DU12 5584 1116 FORMAT('DDENOM,DU11,DU22,DU12 = ',4G15.7) 5585 CALL DPWRST('XXX','BUG ') 5586 ENDIF 5587C 5588C ****************** 5589C ** STEP 90-- ** 5590C ** EXIT ** 5591C ****************** 5592C 5593 9000 CONTINUE 5594 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DLP3')THEN 5595 WRITE(ICOUT,999) 5596 CALL DPWRST('XXX','BUG ') 5597 WRITE(ICOUT,9011) 5598 9011 FORMAT('***** AT THE END OF DPDLP3--') 5599 CALL DPWRST('XXX','BUG ') 5600 ENDIF 5601C 5602 RETURN 5603 END 5604 SUBROUTINE DPDOT(IFOUND,IERROR) 5605C 5606C PURPOSE--THIS IS A SUBROUTINE FOR THE 5607C . COMMAND (A NULL COMMAND). 5608C THIS CAPABILITY IS USEFUL FOR PROVIDING A VISUAL 5609C SEPARATOR BETWEEN SECTIONS OF STORED DATAPLOT 5610C CODE ON MASS STORAGE, OR FOR COMMENTING OUT 5611C A GIVEN LINE OF DATAPLOT CODE. 5612C INPUT ARGUMENTS--NONE 5613C OUTPUT ARGUMENTS--IFOUND ('YES' OR 'NO') 5614C --IERROR ('YES' OR 'NO' ) 5615C WRITTEN BY--JAMES J. FILLIBEN 5616C STATISTICAL ENGINEERING DIVISION 5617C INFORMATION TECHNOLOGY LABORATORY 5618C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5619C GAITHERSBURG, MD 20899-8980 5620C PHONE--301-975-2855 5621C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5622C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5623C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, 5624C MODIFIED, OR OTHERWISE USED IN A CONTEXT 5625C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. 5626C LANGUAGE--ANSI FORTRAN (1977) 5627C VERSION NUMBER--82/7 5628C ORIGINAL VERSION--NOVEMBER 1978. 5629C UPDATED --MARCH 1982. 5630C UPDATED --MAY 1982. 5631C --NOVEMBER 1980. 5632C 5633C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5634C 5635 CHARACTER*4 IFOUND 5636 CHARACTER*4 IERROR 5637C 5638C--------------------------------------------------------------------- 5639C 5640 INCLUDE 'DPCOP2.INC' 5641C 5642C-----START POINT----------------------------------------------------- 5643C 5644 IFOUND='NO' 5645 IERROR='NO' 5646 IFOUND='YES' 5647 GOTO1199 5648C 5649 1199 CONTINUE 5650 RETURN 5651 END 5652 SUBROUTINE DPDOUB(IHARG,NUMARG,IDEFPR,IHMXPR, 5653 1IPREC,IFOUND,IERROR) 5654C 5655C PURPOSE--DEFINE THE PREICSION SWITCH 5656C AS DOUBLE PRECISION. 5657C THIS IN TURN SPECIFIES THAT SUBSEQUENT 5658C CALCULATIONS WILL ALL BE CARRIED OUT 5659C IN DOUBLE PRECISION. 5660C THE SPECIFIED PRECISION SWITCH SPECIFICATION 5661C WILL BE PLACED IN THE HOLLERITH VARIABLE IPREC. 5662C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 5663C --NUMARG (AN INTEGER VARIABLE) 5664C --IDEFPR (A HOLLERITH VARIABLE) 5665C --IHMXPR (A HOLLERITH VARIABLE) 5666C OUTPUT ARGUMENTS--IPREC (A HOLLERITH VARIABLE) 5667C --IFOUND ('YES' OR 'NO' ) 5668C --IERROR ('YES' OR 'NO' ) 5669C WRITTEN BY--JAMES J. FILLIBEN 5670C STATISTICAL ENGINEERING DIVISION 5671C INFORMATION TECHNOLOGY LABORATORY 5672C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5673C GAITHERSBURG, MD 20899-8980 5674C PHONE--301-975-2855 5675C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5676C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5677C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, 5678C MODIFIED, OR OTHERWISE USED IN A CONTEXT 5679C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. 5680C LANGUAGE--ANSI FORTRAN (1977) 5681C VERSION NUMBER--82/7 5682C ORIGINAL VERSION--NOVEMBER 1980. 5683C UPDATED --SEPTEMBER 1981. 5684C UPDATED --MAY 1982. 5685C 5686C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5687C 5688 CHARACTER*4 IHARG 5689 CHARACTER*4 IDEFPR 5690 CHARACTER*4 IHMXPR 5691 CHARACTER*4 IPREC 5692 CHARACTER*4 IFOUND 5693 CHARACTER*4 IERROR 5694C 5695 CHARACTER*4 IHOLD 5696C 5697C--------------------------------------------------------------------- 5698C 5699 DIMENSION IHARG(*) 5700C 5701C--------------------------------------------------------------------- 5702C 5703 INCLUDE 'DPCOP2.INC' 5704C 5705C-----START POINT----------------------------------------------------- 5706C 5707 IERROR='NO' 5708 IFOUND='YES' 5709C 5710 IF(NUMARG.LE.0)GOTO1120 5711 IF(IHARG(NUMARG).EQ.'ON')GOTO1130 5712 IF(IHARG(NUMARG).EQ.'OFF')GOTO1120 5713 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1130 5714 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1120 5715 GOTO1130 5716C 5717 1120 CONTINUE 5718 IHOLD=IDEFPR 5719 GOTO1160 5720C 5721 1130 CONTINUE 5722 IHOLD='DOUB' 5723 GOTO1160 5724C 5725 1160 CONTINUE 5726 IF(IHOLD.EQ.'DOUB'.AND.IHMXPR.EQ.'SING')GOTO1170 5727 IF(IHOLD.EQ.'TRIP'.AND.IHMXPR.EQ.'SING')GOTO1170 5728 IF(IHOLD.EQ.'TRIP'.AND.IHMXPR.EQ.'DOUB')GOTO1170 5729 IF(IHOLD.EQ.'QUAD'.AND.IHMXPR.EQ.'SING')GOTO1170 5730 IF(IHOLD.EQ.'QUAD'.AND.IHMXPR.EQ.'DOUB')GOTO1170 5731 IF(IHOLD.EQ.'QUAD'.AND.IHMXPR.EQ.'TRIP')GOTO1170 5732 GOTO1180 5733C 5734 1170 CONTINUE 5735 IERROR='YES' 5736 WRITE(ICOUT,999) 5737 999 FORMAT(1X) 5738 CALL DPWRST('XXX','BUG ') 5739 WRITE(ICOUT,1172) 5740 1172 FORMAT('***** ERROR IN DPDOUB--') 5741 CALL DPWRST('XXX','BUG ') 5742 WRITE(ICOUT,1173) 5743 1173 FORMAT(' THE DESIRED PRECISION IS HIGHER') 5744 CALL DPWRST('XXX','BUG ') 5745 WRITE(ICOUT,1174) 5746 1174 FORMAT(' THAN PERMITTED ON THIS COMPUTER.') 5747 CALL DPWRST('XXX','BUG ') 5748 WRITE(ICOUT,1175)IHOLD 5749 1175 FORMAT(' DESIRED PRECISION = ',A4) 5750 CALL DPWRST('XXX','BUG ') 5751 WRITE(ICOUT,1176)IHMXPR 5752 1176 FORMAT(' MAXIMUM ALLOWABLE PRECISION = ',A4) 5753 CALL DPWRST('XXX','BUG ') 5754 GOTO1199 5755C 5756 1180 CONTINUE 5757 IPREC=IHOLD 5758C 5759 IF(IFEEDB.EQ.'OFF')GOTO1189 5760 WRITE(ICOUT,999) 5761 CALL DPWRST('XXX','BUG ') 5762 WRITE(ICOUT,1188)IPREC 5763 1188 FORMAT('THE PRECISION SWITCH HAS JUST BEEN SET TO ', 5764 1A4) 5765 CALL DPWRST('XXX','BUG ') 5766 1189 CONTINUE 5767 GOTO1199 5768C 5769 1199 CONTINUE 5770 RETURN 5771 END 5772 SUBROUTINE DPDPCL(P1,N1,P2,N2,ALPHA,IWRITE,PDIFF,ALOWLM,AUPPLM, 5773 1 IBUGA3,IERROR) 5774C 5775C PURPOSE--FOR A GIVEN P1, N1, P2, N2, AND ALPHA, COMPUTE THE 5776C DIFFERENCE OF PROPORTIONS LOWER AND UPPER CONFIDENCE 5777C LIMITS. 5778C WRITTEN BY--JAMES J. FILLIBEN 5779C STATISTICAL ENGINEERING DIVISION 5780C INFORMATION TECHNOLOGY LABORATORY 5781C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5782C GAITHERSBURG, MD 20899-8980 5783C PHONE--301-975-2855 5784C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5785C OF THE NATIONAL BUREAU OF STANDARDS. 5786C LANGUAGE--ANSI FORTRAN (1977) 5787C VERSION NUMBER--2008/8 5788C ORIGINAL VERSION--AUGUST 2008. 5789C UPDATED --OCTOBER 2009. USE "BAYESIAN" CORRECTION 5790C (THIS PRODUCES MEANINGFUL 5791C INTERVALS FOR "0" AND "1" 5792C PROBABILITIES) 5793C 5794C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5795C 5796 CHARACTER*4 IWRITE 5797 CHARACTER*4 IBUGA3 5798 CHARACTER*4 IERROR 5799C 5800 CHARACTER*4 ISUBN1 5801 CHARACTER*4 ISUBN2 5802C 5803C--------------------------------------------------------------------- 5804C 5805 REAL P1 5806 REAL P2 5807 REAL ALPHA 5808 REAL ALOWLM 5809 REAL AUPPLM 5810 INTEGER N1 5811 INTEGER N2 5812C 5813C--------------------------------------------------------------------- 5814C 5815 INCLUDE 'DPCOP2.INC' 5816C 5817C-----START POINT----------------------------------------------------- 5818C 5819 ISUBN1='DPDP' 5820 ISUBN2='CL ' 5821 IERROR='NO' 5822C 5823 IF(IBUGA3.EQ.'ON')THEN 5824 WRITE(ICOUT,999) 5825 999 FORMAT(1X) 5826 CALL DPWRST('XXX','BUG ') 5827 WRITE(ICOUT,51) 5828 51 FORMAT('***** AT THE BEGINNING OF DPDPCL--') 5829 CALL DPWRST('XXX','BUG ') 5830 WRITE(ICOUT,52)IBUGA3,IWRITE 5831 52 FORMAT('IBUGA3,IWRITE = ',A4,2X,A4) 5832 CALL DPWRST('XXX','BUG ') 5833 WRITE(ICOUT,53)P1,N1,P2,N2,ALPHA 5834 53 FORMAT('P1,N1,P2,N2,ALPHA = ',2(G15.7,I8),G15.7) 5835 CALL DPWRST('XXX','BUG ') 5836 WRITE(ICOUT,999) 5837 CALL DPWRST('XXX','BUG ') 5838 ENDIF 5839C 5840C ******************************** 5841C ** STEP 1-- ** 5842C ** CHECK FOR INPUT ERRORS ** 5843C ******************************** 5844C 5845 ALOWLM=0.0 5846 AUPPLM=1.0 5847C 5848 IF(N1.LT.1)THEN 5849 WRITE(ICOUT,999) 5850 CALL DPWRST('XXX','WRIT') 5851 WRITE(ICOUT,111) 5852 111 FORMAT('****** ERROR IN DIFFERENCE OF PROPORTION ', 5853 1 'CONFIDENCE LIMITS--') 5854 CALL DPWRST('XXX','BUG ') 5855 WRITE(ICOUT,113) 5856 113 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE FIRST ', 5857 1 'RESPONSE VARIABLE IS LESS THAN 2.') 5858 CALL DPWRST('XXX','WRIT') 5859 WRITE(ICOUT,114)N1 5860 114 FORMAT('SAMPLE SIZE = ',I8) 5861 CALL DPWRST('XXX','WRIT') 5862 IERROR='YES' 5863 GOTO9000 5864 ENDIF 5865C 5866 IF(N2.LT.2)THEN 5867 WRITE(ICOUT,999) 5868 CALL DPWRST('XXX','WRIT') 5869 WRITE(ICOUT,111) 5870 CALL DPWRST('XXX','BUG ') 5871 WRITE(ICOUT,123) 5872 123 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE ', 5873 1 'SECOND RESPONSE VARIABLE IS LESS THAN 2.') 5874 CALL DPWRST('XXX','WRIT') 5875 WRITE(ICOUT,124)N2 5876 124 FORMAT('SAMPLE SIZE = ',I8) 5877 CALL DPWRST('XXX','WRIT') 5878 IERROR='YES' 5879 GOTO9000 5880 ENDIF 5881C 5882 IF(P1.LT.0.0 .OR. P1.GT.1.0)THEN 5883 IERROR='YES' 5884 WRITE(ICOUT,999) 5885 CALL DPWRST('XXX','BUG ') 5886 WRITE(ICOUT,111) 5887 CALL DPWRST('XXX','BUG ') 5888 WRITE(ICOUT,162) 5889 162 FORMAT(' THE BINOMIAL PROBABILITY OF SUCCESS PARAMETER ', 5890 1 'FOR THE') 5891 CALL DPWRST('XXX','BUG ') 5892 WRITE(ICOUT,164) 5893 164 FORMAT(' FIRST RESPONSE VARIABLE IS OUTSIDE THE ', 5894 1 '(0,1) INTERVAL.') 5895 CALL DPWRST('XXX','BUG ') 5896 WRITE(ICOUT,167)P1 5897 167 FORMAT(' THE PROBABILITY OF SUCCESS PARAMETER = ',G15.7) 5898 CALL DPWRST('XXX','BUG ') 5899 GOTO9000 5900 ENDIF 5901C 5902 IF(P2.LT.0.0 .OR. P2.GT.1.0)THEN 5903 IERROR='YES' 5904 WRITE(ICOUT,999) 5905 CALL DPWRST('XXX','BUG ') 5906 WRITE(ICOUT,111) 5907 CALL DPWRST('XXX','BUG ') 5908 WRITE(ICOUT,162) 5909 CALL DPWRST('XXX','BUG ') 5910 WRITE(ICOUT,174) 5911 174 FORMAT(' SECOND RESPONSE VARIABLE IS OUTSIDE THE ', 5912 1 '(0,1) INTERVAL.') 5913 CALL DPWRST('XXX','BUG ') 5914 WRITE(ICOUT,167)P2 5915 CALL DPWRST('XXX','BUG ') 5916 GOTO9000 5917 ENDIF 5918C 5919 ALPHSV=ALPHA 5920 IF(ALPHA.GT.1.0 .AND. ALPHA.LE.100.0)ALPHA=ALPHA/100.0 5921 IF(ALPHA.LE.0.0 .OR. ALPHA.GE.1.0)THEN 5922 IERROR='YES' 5923 WRITE(ICOUT,999) 5924 CALL DPWRST('XXX','BUG ') 5925 WRITE(ICOUT,111) 5926 CALL DPWRST('XXX','BUG ') 5927 WRITE(ICOUT,182) 5928 182 FORMAT(' THE VALUE OF ALPHA IS OUTSIDE THE (0,1) ', 5929 1 'INTERVAL.') 5930 CALL DPWRST('XXX','BUG ') 5931 WRITE(ICOUT,187)ALPHA 5932 187 FORMAT(' THE VALUE OF ALPHA = ',G15.7) 5933 CALL DPWRST('XXX','BUG ') 5934 GOTO9000 5935 ENDIF 5936C 5937C NOTE: IF VALUE OF ALPHA IS < 0.5, THEN ASSUME 1 - ALPHA 5938C (I.E., 0.05 SHOULD BE 0.95). 5939C 5940 IF(ALPHA.LT.0.5)ALPHA=1.0 - ALPHA 5941C 5942C ******************************************** 5943C ** STEP 2-- ** 5944C ** COMPUTE THE DIFFERENCE OF PROPORTIONS ** 5945C ** CONFIDENCE INTERVAL. ** 5946C ******************************************** 5947C 5948C NOTE: USE PHAT = (V+0.5)/(N+1) WHERE V IS THE 5949C NUMBER OF SUCCESSES. THIS IS THE BAYES ESTIMATOR 5950C OF P CORRESPONDING TO THE NON-INFORMATIVE 5951C (REFERENCE) JEFFREY'S PRIOR DISTRIBUTION. THIS IS 5952C DONE TO BETTER HANDLE THE CASES WHERE P1 OR P2 ARE 5953C ZERO OR ONE (WHICH RESULTS IN A STANDARD ERROR OF 5954C ZERO). 5955C 5956 AN1=REAL(N1) 5957 AN2=REAL(N2) 5958 IX1=INT(AN1*P1 + 0.01) 5959 IX2=INT(AN2*P2 + 0.01) 5960 AX1=REAL(IX1) + 0.5 5961 AX2=REAL(IX2) + 0.5 5962 P1NEW=AX1/REAL(N1+1) 5963 P2NEW=AX2/REAL(N2+1) 5964 PDIFF=P1NEW-P2NEW 5965 PSE=SQRT(P1NEW*(1.0-P1NEW)/REAL(N1)+P2NEW*(1.0-P2NEW)/REAL(N2)) 5966 PCONF=1.0 - ALPHA 5967 PCONF=PCONF/2.0 5968 CDF=1.0-PCONF 5969 CALL NORPPF(CDF,TI) 5970 AUPPLM=PDIFF+PSE*TI 5971CCCCC IF(AUPPLM.GT.1.0)AUPPLM=1.0 5972 ALOWLM=PDIFF-PSE*TI 5973CCCCC IF(ALOWLM.LT.0.0)ALOWLM=0.0 5974C 5975C ***************** 5976C ** STEP 90-- ** 5977C ** EXIT. ** 5978C ***************** 5979C 5980 9000 CONTINUE 5981C 5982 IF(IBUGA3.EQ.'ON')THEN 5983 WRITE(ICOUT,999) 5984 CALL DPWRST('XXX','BUG ') 5985 WRITE(ICOUT,9011) 5986 9011 FORMAT('***** AT THE END OF DPDPCL--') 5987 CALL DPWRST('XXX','BUG ') 5988 WRITE(ICOUT,9012)IBUGA3,IERROR 5989 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 5990 CALL DPWRST('XXX','BUG ') 5991 WRITE(ICOUT,9013)PDIFF,PSE,PCONF,TI 5992 9013 FORMAT('PDIFF,PSE,PCONF,TI = ',4(G15.7,2X)) 5993 CALL DPWRST('XXX','BUG ') 5994 WRITE(ICOUT,9014)ALOWLM,AUPPLM 5995 9014 FORMAT('ALOWLM,AUPPLM = ',G15.7,2X,G15.7) 5996 CALL DPWRST('XXX','BUG ') 5997 WRITE(ICOUT,9015)P1NEW,P2NEW 5998 9015 FORMAT('P1NEW,P2NEW = ',2(G15.7,2X)) 5999 CALL DPWRST('XXX','BUG ') 6000 WRITE(ICOUT,9016)IX1,IX2,AX1,AX2 6001 9016 FORMAT('IX1,IX2,AX1,AX2 = ',2I8,2(G15.7,2X)) 6002 CALL DPWRST('XXX','BUG ') 6003 ENDIF 6004C 6005 RETURN 6006 END 6007 SUBROUTINE DPDRA2(X1,Y1,X2,Y2, 6008 1 IFIG,ILINPA,ILINCO,PLINTH, 6009 1 AREGBA,IREBLI,IREBCO,PREBTH, 6010 1 IREFSW,IREFCO, 6011 1 IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 6012 1 PTEXHE,PTEXWI,PTEXVG,PTEXHG) 6013C 6014C PURPOSE--DRAW A LINE WITH ONE END OF THE LINE AT (X1,Y1) 6015C AND THE OTHER END AT (X2,Y2). 6016C WRITTEN BY--JAMES J. FILLIBEN 6017C STATISTICAL ENGINEERING DIVISION 6018C INFORMATION TECHNOLOGY LABORATORY 6019C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 6020C GAITHERSBURG, MD 20899-8980 6021C PHONE--301-975-2855 6022C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 6023C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 6024C LANGUAGE--ANSI FORTRAN (1977) 6025C VERSION NUMBER--82/7 6026C ORIGINAL VERSION--APRIL 1981. 6027C UPDATED --MAY 1982. 6028C UPDATED --JANUARY 1989. MODIFY CALLS TO DPDRPL (ALAN) 6029C UPDATED --JANUARY 1989. MODIFY CALL TO DPFIRE (ALAN) 6030C 6031C-----NON-COMMON VARIABLES------------------------------------- 6032C 6033 CHARACTER*4 IFIG 6034 CHARACTER*4 IPATT2 6035C 6036 CHARACTER*4 ILINPA 6037 CHARACTER*4 ILINCO 6038C 6039 CHARACTER*4 IREBLI 6040 CHARACTER*4 IREBCO 6041 CHARACTER*4 IREFSW 6042 CHARACTER*4 IREFCO 6043 CHARACTER*4 IREPTY 6044 CHARACTER*4 IREPLI 6045 CHARACTER*4 IREPCO 6046C 6047 CHARACTER*4 IPATT 6048 CHARACTER*4 ICOLF 6049 CHARACTER*4 ICOLP 6050 CHARACTER*4 ICOL 6051 CHARACTER*4 IFLAG 6052C 6053 DIMENSION PX(10) 6054 DIMENSION PY(10) 6055C 6056 DIMENSION ILINPA(*) 6057 DIMENSION ILINCO(*) 6058 DIMENSION PLINTH(*) 6059C 6060 DIMENSION AREGBA(*) 6061 DIMENSION IREBLI(*) 6062 DIMENSION IREBCO(*) 6063 DIMENSION PREBTH(*) 6064 DIMENSION IREFSW(*) 6065 DIMENSION IREFCO(*) 6066 DIMENSION IREPTY(*) 6067 DIMENSION IREPLI(*) 6068 DIMENSION IREPCO(*) 6069 DIMENSION PREPTH(*) 6070 DIMENSION PREPSP(*) 6071C 6072C-----COMMON---------------------------------------------------------- 6073C 6074 INCLUDE 'DPCOGR.INC' 6075 INCLUDE 'DPCOBE.INC' 6076 INCLUDE 'DPCOP2.INC' 6077C 6078C-----START POINT----------------------------------------------------- 6079C 6080 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRA2')THEN 6081 WRITE(ICOUT,999) 6082 999 FORMAT(1X) 6083 CALL DPWRST('XXX','BUG ') 6084 WRITE(ICOUT,51) 6085 51 FORMAT('***** AT THE BEGINNING OF DPDRA2--') 6086 CALL DPWRST('XXX','BUG ') 6087 WRITE(ICOUT,53)X1,Y1,X2,Y2 6088 53 FORMAT('X1,Y1,X2,Y2 = ',4G15.7) 6089 CALL DPWRST('XXX','BUG ') 6090 WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1) 6091 61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7) 6092 CALL DPWRST('XXX','BUG ') 6093 WRITE(ICOUT,62)IFIG,AREGBA(1) 6094 62 FORMAT('IFIG,AREGBA(1) = ',A4,2X,G15.7) 6095 CALL DPWRST('XXX','BUG ') 6096 WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1) 6097 63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7) 6098 CALL DPWRST('XXX','BUG ') 6099 WRITE(ICOUT,64)IREFSW(1),IREFCO(1) 6100 64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4) 6101 CALL DPWRST('XXX','BUG ') 6102 WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) 6103 65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ', 6104 1 3(A4,2X),2G15.7) 6105 CALL DPWRST('XXX','BUG ') 6106 WRITE(ICOUT,67)PTEXHE,PTEXWI,PTEXVG,PTEXHG 6107 67 FORMAT('PTEXHE,PTEXWI,PTEXVG,PTEXHG = ',4G15.7) 6108 CALL DPWRST('XXX','BUG ') 6109 WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4 6110 79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',2(A4,2X),A4) 6111 CALL DPWRST('XXX','BUG ') 6112 ENDIF 6113C 6114C ********************************* 6115C ** STEP 1-- ** 6116C ** DETERMINE THE COORDINATES ** 6117C ** FOR THE LINE ** 6118C ********************************* 6119C 6120 PX(1)=X1 6121 PY(1)=Y1 6122C 6123 PX(2)=X2 6124 PY(2)=Y2 6125C 6126 NP=2 6127C 6128C 6129C *********************** 6130C ** STEP 2-- ** 6131C ** FILL THE FIGURE ** 6132C ** (IF CALLED FOR) ** 6133C *********************** 6134C 6135 IF(IREFSW(1).EQ.'ON')THEN 6136 IPATT=IREPTY(1) 6137 IPATT2='SOLI' 6138 PTHICK=PREPTH(1) 6139 PXGAP=PREPSP(1) 6140 PYGAP=PREPSP(1) 6141 ICOLF=IREFCO(1) 6142 ICOLP=IREPCO(1) 6143 CALL DPFIRE(PX,PY,NP, 6144 1 IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2) 6145 ENDIF 6146C 6147C *************************** 6148C ** STEP 3-- ** 6149C ** DRAW OUT THE FIGURE ** 6150C *************************** 6151C 6152 IPATT=ILINPA(1) 6153 PTHICK=PLINTH(1) 6154 ICOL=ILINCO(1) 6155 IFLAG='ON' 6156 CALL DPDRPL(PX,PY,NP, 6157 1 IFIG,IPATT,PTHICK,ICOL, 6158 1 JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 6159C 6160C ***************** 6161C ** STEP 90-- ** 6162C ** EXIT ** 6163C ***************** 6164C 6165 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRA2')THEN 6166 WRITE(ICOUT,999) 6167 CALL DPWRST('XXX','BUG ') 6168 WRITE(ICOUT,9011) 6169 9011 FORMAT('***** AT THE END OF DPDRA2--') 6170 CALL DPWRST('XXX','BUG ') 6171 WRITE(ICOUT,9013)IERRG4,NP 6172 9013 FORMAT('IERRG4,NP = ',A4,2X,I8) 6173 CALL DPWRST('XXX','BUG ') 6174 DO9015I=1,NP 6175 WRITE(ICOUT,9016)I,PX(I),PY(I) 6176 9016 FORMAT('I,PX(I),PY(I) = ',I8,2G15.7) 6177 CALL DPWRST('XXX','BUG ') 6178 9015 CONTINUE 6179 ENDIF 6180C 6181 RETURN 6182 END 6183 SUBROUTINE DPDRAW(PXSTAR,PYSTAR,PXEND,PYEND, 6184 1 ILINPA,ILINCO,PLINTH, 6185 1 AREGBA,IREBLI,IREBCO,PREBTH,IREFSW,IREFCO, 6186 1 IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 6187 1 PTEXHE,PTEXWI,PTEXVG,PTEXHG, 6188 1 ICHAPA,ICHAFO,ICHACA,ICHAJU,ICHADI,ICHAFI, 6189 1 ICHACO, 6190 1 PCHAHE,PCHAWI,PCHAVG,PCHAHG,PCHATH,ACHAAN, 6191 1 IGRASW, 6192 1 PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 6193 1 PDIAHE,PDIAWI,PDIAVG,PDIAHG, 6194 1 NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3, 6195 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 6196 1 IDNVOF,IDNHOF,IDFONT,PDSCAL, 6197 1 X1UNIT,Y1UNIT,X2UNIT,Y2UNIT, 6198 1 IMPSW2,AMPSCH,AMPSCW,ITEXSP,ITEXSY, 6199 1 IBUGD2,IFOUND,IERROR) 6200C 6201C PURPOSE--DRAW ONE OR MORE LINES (DEPENDING ON HOW MANY NUMBERS ARE 6202C PROVIDED). THE COORDINATES ARE IN STANDARDIZED UNITS 6203C OF 0 TO 100. 6204C NOTE--THE INPUT COORDINATES DEFINE THE ENDS OF THE LINE SEGMENTS. 6205C NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 2 AND THEREFORE THE 6206C USUAL INPUT NUMBER OF NUMBERS IS 2*2 = 4. 6207C NOTE--IF 2 NUMBERS ARE PROVIDED, THEN THE DRAWN LINE WILL GO FROM 6208C THE LAST CURSOR POSITION TO THE (X,Y) POINT (EITHER ABSOLUTE 6209C OR RELATIVE) AS DEFINED BY THE 2 NUMBERS. 6210C NOTE--IF 4 NUMBERS ARE PROVIDED, THEN THE DRAWN LINE WILL GO 6211C FROM THE ABSOLUTE (X,Y) POSITION AS DEFINED BY THE FIRST 2 6212C NUMBERS TO THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) 6213C AS DEFINED BY THE THIRD AND FOURTH NUMBERS. 6214C NOTE--IF 6 NUMBERS ARE PROVIDED, THEN THE DRAWN LINE WILL GO 6215C FROM THE (X,Y) POSITION AS RESULTING FROM THE THIRD AND 6216C FOURTH NUMBERS TO THE (X,Y) POINT (EITHER ABSOLUTE OR 6217C RELATIVE) AS DEFINED BY THE FIFTH AND SIXTH NUMBERS. 6218C NOTE--AND SO FORTH FOR 8, 10, 12, ... NUMBERS. 6219C INPUT ARGUMENTS--IHARG 6220C --IARGT 6221C --ARG 6222C --NUMARG 6223C --PXSTAR 6224C --PYSTAR 6225C OUTPUT ARGUMENTS--PXEND 6226C --PYEND 6227C --IFOUND ('YES' OR 'NO' ) 6228C --IERROR ('YES' OR 'NO' ) 6229C WRITTEN BY--JAMES J. FILLIBEN 6230C STATISTICAL ENGINEERING DIVISION 6231C INFORMATION TECHNOLOGY LABORATORY 6232C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 6233C GAITHERSBURG, MD 20899-8980 6234C PHONE--301-975-2855 6235C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 6236C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 6237C LANGUAGE--ANSI FORTRAN (1977) 6238C VERSION NUMBER--82/7 6239C ORIGINAL VERSION--APRIL 1981. 6240C UPDATED --MARCH 1982. 6241C UPDATED --MAY 1982. 6242C UPDATED --NOVEMBER 1982. 6243C UPDATED --JANUARY 1989. CALL LIST FOR OFFSET VAR (ALAN) 6244C UPDATED --SEPTEMBER 1994. UNITS SWITCH (DATA OR SCREEN) 6245C UPDATED --FEBRUARY 1995. GENERALIZED DRAW.... COMMAND 6246C UPDATED --MARCH 1997. SUPPORT FOR DEVICE FONT (ALAN) 6247C UPDATED --FEBRUARY 2018. SUPPORT FOR VARIABLE ARGUMENTS 6248C UPDATED --FEBRUARY 2018. SUPPORT FOR "DRAW SYMBOL" 6249C UPDATED --DECEMBER 2018. CHECK FOR DISCRETE, NULL, OR 6250C NONE DEVICE 6251C UPDATED --DECEMBER 2018. SUPPORT FOR "DEVICE ... SCALE" 6252C COMMAND 6253C 6254C-----NON-COMMON VARIABLES----------------------------------------- 6255C 6256 CHARACTER*4 ILINPA 6257 CHARACTER*4 ILINCO 6258C 6259 CHARACTER*4 IREBLI 6260 CHARACTER*4 IREBCO 6261 CHARACTER*4 IREFSW 6262 CHARACTER*4 IREFCO 6263 CHARACTER*4 IREPTY 6264 CHARACTER*4 IREPLI 6265 CHARACTER*4 IREPCO 6266C 6267 CHARACTER*4 IGRASW 6268 CHARACTER*4 IDIASW 6269C 6270 CHARACTER*4 IDMANU 6271 CHARACTER*4 IDMODE 6272 CHARACTER*4 IDMOD2 6273 CHARACTER*4 IDMOD3 6274 CHARACTER*4 IDPOWE 6275 CHARACTER*4 IDCONT 6276 CHARACTER*4 IDCOLO 6277 CHARACTER*4 IDFONT 6278C 6279 CHARACTER*4 IMPSW2 6280 CHARACTER*4 IFOUND 6281 CHARACTER*4 IBUGD2 6282 CHARACTER*4 IERROR 6283C 6284 CHARACTER*4 IFIG 6285 CHARACTER*4 IBELSW 6286 CHARACTER*4 IERASW 6287 CHARACTER*4 IBACCO 6288 CHARACTER*4 ICOPSW 6289 CHARACTER*4 ITYPEO 6290 CHARACTER*4 ITEXSY 6291 CHARACTER*4 ITEXSP 6292 CHARACTER*24 ITEXZZ 6293C 6294 CHARACTER*4 X1UNIT 6295 CHARACTER*4 Y1UNIT 6296 CHARACTER*4 X2UNIT 6297 CHARACTER*4 Y2UNIT 6298C 6299 DIMENSION ILINPA(*) 6300 DIMENSION ILINCO(*) 6301 DIMENSION PLINTH(*) 6302C 6303 CHARACTER*24 ICHAPA(*) 6304 CHARACTER*4 ICHAFO(*) 6305 CHARACTER*4 ICHACA(*) 6306 CHARACTER*4 ICHAJU(*) 6307 CHARACTER*4 ICHADI(*) 6308 CHARACTER*4 ICHAFI(*) 6309 CHARACTER*4 ICHACO(*) 6310 DIMENSION PCHAHE(*) 6311 DIMENSION PCHAWI(*) 6312 DIMENSION PCHAVG(*) 6313 DIMENSION PCHAHG(*) 6314 DIMENSION PCHATH(*) 6315 DIMENSION ACHAAN(*) 6316C 6317 DIMENSION AREGBA(*) 6318 DIMENSION IREBLI(*) 6319 DIMENSION IREBCO(*) 6320 DIMENSION PREBTH(*) 6321 DIMENSION IREFSW(*) 6322 DIMENSION IREFCO(*) 6323 DIMENSION IREPTY(*) 6324 DIMENSION IREPLI(*) 6325 DIMENSION IREPCO(*) 6326 DIMENSION PREPTH(*) 6327 DIMENSION PREPSP(*) 6328 DIMENSION PDSCAL(*) 6329C 6330 DIMENSION IDMANU(*) 6331 DIMENSION IDMODE(*) 6332 DIMENSION IDMOD2(*) 6333 DIMENSION IDMOD3(*) 6334 DIMENSION IDPOWE(*) 6335 DIMENSION IDCONT(*) 6336 DIMENSION IDCOLO(*) 6337 DIMENSION IDFONT(*) 6338 DIMENSION IDNVPP(*) 6339 DIMENSION IDNHPP(*) 6340 DIMENSION IDUNIT(*) 6341C 6342 DIMENSION IDNVOF(*) 6343 DIMENSION IDNHOF(*) 6344C 6345 INCLUDE 'DPCOPA.INC' 6346C 6347 DIMENSION X1TEMP(MAXOBV) 6348 DIMENSION Y1TEMP(MAXOBV) 6349 DIMENSION X2TEMP(MAXOBV) 6350 DIMENSION Y2TEMP(MAXOBV) 6351C 6352 PARAMETER (MAXSPN=30) 6353 CHARACTER*4 IVARN1(MAXSPN) 6354 CHARACTER*4 IVARN2(MAXSPN) 6355 CHARACTER*4 IVARTY(MAXSPN) 6356 REAL PVAR(MAXSPN) 6357 INTEGER ILIS(MAXSPN) 6358 INTEGER NRIGHT(MAXSPN) 6359 INTEGER ICOLR(MAXSPN) 6360 CHARACTER*40 INAME 6361C 6362 CHARACTER*4 ICASE 6363 CHARACTER*4 ISYMB 6364C 6365 CHARACTER*4 ICH2PA(24) 6366 CHARACTER*4 IFONT 6367 CHARACTER*4 IJUST 6368 CHARACTER*4 IDIR 6369 CHARACTER*4 IFILL 6370 CHARACTER*4 ICOLCH 6371C 6372C-----COMMON---------------------------------------------------------- 6373C 6374 INCLUDE 'DPCOZZ.INC' 6375 INCLUDE 'DPCOGR.INC' 6376 INCLUDE 'DPCOBE.INC' 6377 INCLUDE 'DPCOHK.INC' 6378 INCLUDE 'DPCODA.INC' 6379C 6380 EQUIVALENCE (GARBAG(IGARB1),X1TEMP(1)) 6381 EQUIVALENCE (GARBAG(IGARB2),Y1TEMP(1)) 6382 EQUIVALENCE (GARBAG(IGARB3),X2TEMP(1)) 6383 EQUIVALENCE (GARBAG(IGARB4),Y2TEMP(1)) 6384C 6385C-----COMMON VARIABLES (GENERAL)-------------------------------------- 6386C 6387 INCLUDE 'DPCOP2.INC' 6388C 6389C-----START POINT----------------------------------------------------- 6390C 6391 IFOUND='NO' 6392 IF(ICOM.EQ.'DRAW')IFOUND='YES' 6393 IERROR='NO' 6394 IERRG4=IERROR 6395 ISYMB='OFF' 6396 IFIG='LINE' 6397C 6398 X1=0.0 6399 Y1=0.0 6400 X2=0.0 6401 Y2=0.0 6402C 6403 MAXCP1=MAXCOL+1 6404 MAXCP2=MAXCOL+2 6405 MAXCP3=MAXCOL+3 6406 MAXCP4=MAXCOL+4 6407 MAXCP5=MAXCOL+5 6408 MAXCP6=MAXCOL+6 6409C 6410C 6411 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRAW')THEN 6412 WRITE(ICOUT,999) 6413 999 FORMAT(1X) 6414 CALL DPWRST('XXX','BUG ') 6415 WRITE(ICOUT,51) 6416 51 FORMAT('***** AT THE BEGINNING OF DPDRAW--') 6417 CALL DPWRST('XXX','BUG ') 6418 WRITE(ICOUT,53)NUMARG,NUMDEV 6419 53 FORMAT('NUMARG,NUMDEV = ',2I8) 6420 CALL DPWRST('XXX','BUG ') 6421 DO55I=1,NUMARG 6422 WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I) 6423 56 FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2X,A4,2X,A4,G15.7) 6424 CALL DPWRST('XXX','BUG ') 6425 55 CONTINUE 6426 WRITE(ICOUT,57)PXSTAR,PYSTAR,PXEND,PYEND 6427 57 FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4G15.7) 6428 CALL DPWRST('XXX','BUG ') 6429 WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1) 6430 61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,G15.7) 6431 CALL DPWRST('XXX','BUG ') 6432 WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1),AREGBA(1) 6433 63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1),AREGBA(1) = ', 6434 1 A4,2X,A4,2G15.7) 6435 CALL DPWRST('XXX','BUG ') 6436 WRITE(ICOUT,64)IREFSW(1),IREFCO(1) 6437 64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4) 6438 CALL DPWRST('XXX','BUG ') 6439 WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) 6440 65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ', 6441 1 3(A4,2X),2G15.7) 6442 CALL DPWRST('XXX','BUG ') 6443 WRITE(ICOUT,69)PTEXHE,PTEXWI,PTEXVG,PTEXHG 6444 69 FORMAT('PTEXHE,PTEXWI,PTEXVG,PTEXHG= ',4G15.7) 6445 CALL DPWRST('XXX','BUG ') 6446 WRITE(ICOUT,76)IGRASW,IDIASW 6447 76 FORMAT('IGRASW,IDIASW = ',A4,2X,A4) 6448 CALL DPWRST('XXX','BUG ') 6449 WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC 6450 77 FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4G15.7) 6451 CALL DPWRST('XXX','BUG ') 6452 WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG 6453 78 FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4G15.7) 6454 CALL DPWRST('XXX','BUG ') 6455 DO81I=1,NUMDEV 6456 WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) 6457 82 FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ', 6458 1 3(A4,2X),A4) 6459 CALL DPWRST('XXX','BUG ') 6460 WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I) 6461 83 FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ',2(A4,2X),A4) 6462 CALL DPWRST('XXX','BUG ') 6463 WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I) 6464 84 FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ',3I8) 6465 CALL DPWRST('XXX','BUG ') 6466 81 CONTINUE 6467 WRITE(ICOUT,85)X1UNIT,Y1UNIT,X2UNIT,Y2UNIT 6468 85 FORMAT('X1UNIT,Y1UNIT,X2UNIT,Y2UNIT= ',4A4) 6469 CALL DPWRST('XXX','BUG ') 6470 WRITE(ICOUT,88)IFOUND,IBUGG4,ISUBG4,IERRG4 6471 88 FORMAT('IFOUND,IBUGG4,ISUBG4,IERRG4 = ',3(A4,2X),A4) 6472 CALL DPWRST('XXX','BUG ') 6473 WRITE(ICOUT,89)IBUGD2,IERROR 6474 89 FORMAT('IBUGD2,IERROR= ',A4,2X,A4) 6475 CALL DPWRST('XXX','BUG ') 6476 ENDIF 6477C 6478C ***************************************** 6479C ** STEP 1-- ** 6480C ** SEARCH FOR COMMAND SPECIFICATIONS ** 6481C ***************************************** 6482C 6483 ISHIFT=0 6484 ITYPEO='ABSO' 6485 ISYMB='OFF' 6486 IF(IHARG(1).EQ.'ABSO')THEN 6487 ITYPEO='ABSO' 6488 ISHIFT=1 6489 IF(IHARG(2).EQ.'SYMB')THEN 6490 ISHIFT=2 6491 ISYMB='ON' 6492 ENDIF 6493 ELSEIF(IHARG(1).EQ.'RELA')THEN 6494 ITYPEO='RELA' 6495 ISHIFT=1 6496 IF(IHARG(2).EQ.'SYMB')THEN 6497 ISHIFT=2 6498 ISYMB='ON' 6499 ENDIF 6500 ELSEIF(IHARG(1).EQ.'SYMB')THEN 6501 ISHIFT=1 6502 ISYMB='ON' 6503 ENDIF 6504C 6505 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRAW')THEN 6506 WRITE(ICOUT,91)IYPEO,ISYMB,ISHIFT 6507 91 FORMAT('ITYPEO,ISYMB,ISHIFT = ',2(A4,2X),I3) 6508 CALL DPWRST('XXX','BUG ') 6509 ENDIF 6510C 6511 IF(ISHIFT.GE.1)THEN 6512 CALL ADJUST(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 6513 ENDIF 6514C 6515C ***************************************************** 6516C ** STEP 2-- ** 6517C ** EXTRACT ARGUMENTS. NOTE THAT THE DRAW COMMAND ** 6518C ** CAN NOW ACCEPT EITHER PARAMETER OR VARIABLE ** 6519C ** ARGUMENTS. ALTHOUGH A MIX OF PARAMETER NAMES ** 6520C ** AND VARIABLE NAMES CAN BE GIVEN, ALL VARIABLES ** 6521C ** MUST BE OF THE SAME LENGTH. ** 6522C ***************************************************** 6523C 6524 INAME='DRAW' 6525 MINNA=2 6526 MAXNA=100 6527 MINN2=1 6528 IFLAGE=0 6529 IFLAGM=0 6530 IFLAGP=1 6531 JMIN=1 6532 JMAX=NUMARG 6533 MINNVA=2 6534 MAXNVA=30 6535 IF(ISYMB.EQ.'ON')THEN 6536 MINNA=3 6537 MINNVA=3 6538 MAXNVA=3 6539 ENDIF 6540C 6541 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 6542 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 6543 1 JMIN,JMAX, 6544 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 6545 1 IVARN1,IVARN2,IVARTY,PVAR, 6546 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 6547 1 MINNVA,MAXNVA, 6548 1 IFLAGM,IFLAGP, 6549 1 IBUGG4,IBUGD2,ISUBG4,IFOUND,IERROR) 6550 IF(IERROR.EQ.'YES')GOTO9000 6551C 6552C EVEN NUMBER OF ARGUMENTS REQUIRED 6553C 6554 IEVEN=MOD(NUMVAR,2) 6555 IF(IEVEN.EQ.1 .AND. ISYMB.EQ.'OFF')THEN 6556 WRITE(ICOUT,999) 6557 CALL DPWRST('XXX','BUG ') 6558 WRITE(ICOUT,211) 6559 CALL DPWRST('XXX','BUG ') 6560 WRITE(ICOUT,203) 6561 203 FORMAT(' AN EVEN NUMBER OF PARAMETER/VARIABLE NAMES ', 6562 1 'REQUIRED.') 6563 CALL DPWRST('XXX','BUG ') 6564 WRITE(ICOUT,205)NUMVAR 6565 205 FORMAT(' THE NUMBER OF NAMES ENTERED IS ',I5) 6566 CALL DPWRST('XXX','BUG ') 6567 IERROR='YES' 6568 GOTO9000 6569 ENDIF 6570C 6571 IF(NUMVAR.GE.5 .AND. ISYMB.EQ.'OFF')THEN 6572 DO210II=5,NUMVAR 6573 IF(IVARTY(II).EQ.'VARI')THEN 6574 WRITE(ICOUT,999) 6575 CALL DPWRST('XXX','BUG ') 6576 WRITE(ICOUT,211) 6577 211 FORMAT('***** ERROR IN DRAW--') 6578 CALL DPWRST('XXX','BUG ') 6579 WRITE(ICOUT,213) 6580 213 FORMAT(' ONLY THE FIRST FOUR ARGUMENTS TO DRAW MAY ', 6581 1 'BE VARIABLE NAMES.') 6582 CALL DPWRST('XXX','BUG ') 6583 WRITE(ICOUT,215)II,IVARN1(II),IVARN2(II) 6584 215 FORMAT(' ARGUMENT ',I3,'(',A4,A4,') IS A VARIABLE ', 6585 1 'NAME.') 6586 CALL DPWRST('XXX','BUG ') 6587 IERROR='YES' 6588 GOTO9000 6589 ENDIF 6590 210 CONTINUE 6591 ENDIF 6592C 6593 IF(IBUGD2.EQ.'ON'.OR.ISUBG4.EQ.'DRAW')THEN 6594 WRITE(ICOUT,999) 6595 CALL DPWRST('XXX','BUG ') 6596 WRITE(ICOUT,281) 6597 281 FORMAT('***** AFTER CALL DPPARS--') 6598 CALL DPWRST('XXX','BUG ') 6599 WRITE(ICOUT,282)NQ,NUMVAR,NLINE 6600 282 FORMAT('NQ,NUMVAR,NLINE = ',3I8) 6601 CALL DPWRST('XXX','BUG ') 6602 IF(NUMVAR.GT.0)THEN 6603 DO285I=1,NUMVAR 6604 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 6605 1 ICOLR(I),IVARTY(I) 6606 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 6607 1 'ICOLR(I),IVARTY(I) = ',I8,2X,A4,A4,2X,3I8,2X,A4) 6608 CALL DPWRST('XXX','BUG ') 6609 285 CONTINUE 6610 ENDIF 6611 ENDIF 6612C 6613C ***************************************************** 6614C ** STEP 3-- ** 6615C ** IF ANY OF ARGUMENTS 1 TO 4 ARE VARIABLES, ** 6616C ** EXTRACT THE DATA. ** 6617C ***************************************************** 6618C 6619 NUMVA2=1 6620 NS1=0 6621 NS2=0 6622 NS3=0 6623 NS4=0 6624 IF(NUMVAR.GE.1 .AND. IVARTY(1).EQ.'VARI')THEN 6625 ICOL=1 6626 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 6627 1 INAME,IVARN1,IVARN2,IVARTY, 6628 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 6629 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 6630 1 MAXCP4,MAXCP5,MAXCP6, 6631 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 6632 1 X1TEMP,X1TEMP,X1TEMP,NS1,NTEMP,NTEMP,ICASE, 6633 1 IBUGD2,ISUBG4,IFOUND,IERROR) 6634 IF(IERROR.EQ.'YES')GOTO9000 6635 ENDIF 6636C 6637 IF(NUMVAR.GE.2 .AND. IVARTY(2).EQ.'VARI')THEN 6638 ICOL=2 6639 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 6640 1 INAME,IVARN1,IVARN2,IVARTY, 6641 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 6642 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 6643 1 MAXCP4,MAXCP5,MAXCP6, 6644 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 6645 1 Y1TEMP,Y1TEMP,Y1TEMP,NS2,NTEMP,NTEMP,ICASE, 6646 1 IBUGD2,ISUBG4,IFOUND,IERROR) 6647 IF(IERROR.EQ.'YES')GOTO9000 6648 ENDIF 6649C 6650 IF(NUMVAR.GE.3 .AND. IVARTY(3).EQ.'VARI')THEN 6651 ICOL=3 6652 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 6653 1 INAME,IVARN1,IVARN2,IVARTY, 6654 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 6655 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 6656 1 MAXCP4,MAXCP5,MAXCP6, 6657 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 6658 1 X2TEMP,X2TEMP,X2TEMP,NS3,NTEMP,NTEMP,ICASE, 6659 1 IBUGD2,ISUBG4,IFOUND,IERROR) 6660 IF(IERROR.EQ.'YES')GOTO9000 6661 ENDIF 6662C 6663 IF(NUMVAR.GE.4 .AND. IVARTY(4).EQ.'VARI')THEN 6664 ICOL=4 6665 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 6666 1 INAME,IVARN1,IVARN2,IVARTY, 6667 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 6668 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 6669 1 MAXCP4,MAXCP5,MAXCP6, 6670 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 6671 1 Y2TEMP,Y2TEMP,Y2TEMP,NS4,NTEMP,NTEMP,ICASE, 6672 1 IBUGD2,ISUBG4,IFOUND,IERROR) 6673 IF(IERROR.EQ.'YES')GOTO9000 6674 ENDIF 6675C 6676 IF(IVARTY(1).EQ.'VARI')THEN 6677 NLINE=NRIGHT(1) 6678 ELSEIF(IVARTY(2).EQ.'VARI')THEN 6679 NLINE=NRIGHT(2) 6680 ELSEIF(IVARTY(3).EQ.'VARI')THEN 6681 NLINE=NRIGHT(3) 6682 ELSEIF(IVARTY(4).EQ.'VARI')THEN 6683 NLINE=NRIGHT(4) 6684 ELSE 6685 NLINE=1 6686 ENDIF 6687C 6688 IFLAG=0 6689 IF(IVARTY(1).EQ.'VARI' .AND. NS1.NE.NLINE)IFLAG=1 6690 IF(IVARTY(2).EQ.'VARI' .AND. NS2.NE.NLINE)IFLAG=1 6691 IF(IVARTY(3).EQ.'VARI' .AND. NS3.NE.NLINE)IFLAG=1 6692 IF(IVARTY(4).EQ.'VARI' .AND. NS4.NE.NLINE .AND. 6693 1 ISYMB.EQ.'OFF')IFLAG=1 6694C 6695 IF(IFLAG.EQ.1)THEN 6696 WRITE(ICOUT,999) 6697 CALL DPWRST('XXX','BUG ') 6698 WRITE(ICOUT,211) 6699 CALL DPWRST('XXX','BUG ') 6700 WRITE(ICOUT,231) 6701 231 FORMAT(' ARGUMENTS THAT ARE VARIABLE NAMES MUST BE OF ', 6702 1 'THE SAME LENGTH.') 6703 CALL DPWRST('XXX','BUG ') 6704 IF(IVARTY(1).EQ.'VARI')THEN 6705 WRITE(ICOUT,232)NS1 6706 232 FORMAT(' ARGUMENT 1 HAS ',I8,' ELEMENTS.') 6707 CALL DPWRST('XXX','BUG ') 6708 ENDIF 6709 IF(IVARTY(2).EQ.'VARI')THEN 6710 WRITE(ICOUT,233)NS2 6711 233 FORMAT(' ARGUMENT 2 HAS ',I8,' ELEMENTS.') 6712 CALL DPWRST('XXX','BUG ') 6713 ENDIF 6714 IF(IVARTY(3).EQ.'VARI')THEN 6715 WRITE(ICOUT,234)NS3 6716 234 FORMAT(' ARGUMENT 3 HAS ',I8,' ELEMENTS.') 6717 CALL DPWRST('XXX','BUG ') 6718 ENDIF 6719 IF(IVARTY(4).EQ.'VARI')THEN 6720 WRITE(ICOUT,235)NS4 6721 235 FORMAT(' ARGUMENT 4 HAS ',I8,' ELEMENTS.') 6722 CALL DPWRST('XXX','BUG ') 6723 ENDIF 6724 IERROR='YES' 6725 GOTO9000 6726 ENDIF 6727C 6728C ******************************** 6729C ** STEP 2-- ** 6730C ** STEP THROUGH EACH DEVICE ** 6731C ******************************** 6732C 6733 IF(NUMDEV.LE.0)GOTO9000 6734 DO8000IDEVIC=1,NUMDEV 6735C 6736 IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000 6737 IF(IDMANU(IDEVIC).EQ.'OFF')GOTO8000 6738 IF(IDMANU(IDEVIC).EQ.'NULL')GOTO8000 6739 IF(IDMANU(IDEVIC).EQ.'NONE')GOTO8000 6740 IF(IDMANU(IDEVIC).EQ.'DISC')GOTO8000 6741C 6742 IMANUF=IDMANU(IDEVIC) 6743 IMODEL=IDMODE(IDEVIC) 6744 IMODE2=IDMOD2(IDEVIC) 6745 IMODE3=IDMOD3(IDEVIC) 6746 IGCONT=IDCONT(IDEVIC) 6747 IGCOLO=IDCOLO(IDEVIC) 6748 IGFONT=IDFONT(IDEVIC) 6749 NUMVPP=IDNVPP(IDEVIC) 6750 NUMHPP=IDNHPP(IDEVIC) 6751 ANUMVP=NUMVPP 6752 ANUMHP=NUMHPP 6753 IOFFSV=IDNVOF(IDEVIC) 6754 IOFFSH=IDNHOF(IDEVIC) 6755 IGUNIT=IDUNIT(IDEVIC) 6756 PCHSCA=PDSCAL(IDEVIC) 6757C 6758C ************************************ 6759C ** STEP 1-- ** 6760C ** CARRY OUT OPENING OPERATIONS ** 6761C ** ON THE GRAPHICS DEVICES ** 6762C ************************************ 6763C 6764 CALL DPOPDE 6765C 6766 IBELSW='OFF' 6767 NUMRIN=0 6768 IERASW='OFF' 6769 IBACCO='JUNK' 6770C 6771 CALL DPOPPL(IGRASW,IBELSW,NUMRIN,IERASW,IBACCO) 6772C 6773C **************************** 6774C ** STEP 3-- ** 6775C ** DRAW OUT THE LINE(S) ** 6776C **************************** 6777C 6778C 2018/02: ACCOMODATE VARIABLE ARGUMENTS, LOOP THROUGH 6779C MORE THAN ONE SET OF POINTS. 6780C 6781C EXTRACT THE COORDINATES FOR THE FIRST 4 SET OF POINTS 6782C 6783 IF(ISYMB.EQ.'OFF')THEN 6784 DO8100ILINE=1,NLINE 6785 IF(NUMVAR.EQ.2)THEN 6786 X1=PXSTAR 6787 Y1=PYSTAR 6788 J=0 6789 ELSE 6790 IF(IVARTY(1).EQ.'VARI')THEN 6791 X1=X1TEMP(ILINE) 6792 ELSE 6793 X1=PVAR(1) 6794 ENDIF 6795 IF(IVARTY(2).EQ.'VARI')THEN 6796 Y1=Y1TEMP(ILINE) 6797 ELSE 6798 Y1=PVAR(2) 6799 ENDIF 6800 J=2 6801 ENDIF 6802C 6803 IF(X1UNIT.EQ.'DATA') 6804 1 CALL DPCODS('X',X1,X1,IBUGD2,ISUBG4,IERROR) 6805 IF(Y1UNIT.EQ.'DATA') 6806 1 CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBG4,IERROR) 6807C 6808 1160 CONTINUE 6809C 6810 J=J+1 6811 IF(J.GT.NUMARG)GOTO1190 6812 IF(J.EQ.1 .AND. NUMVAR.EQ.2)THEN 6813 IF(IVARTY(1).EQ.'VARI')THEN 6814 X2=X1TEMP(ILINE) 6815 ELSE 6816 X2=PVAR(1) 6817 ENDIF 6818 IF(IVARTY(2).EQ.'VARI')THEN 6819 Y2=Y1TEMP(ILINE) 6820 ELSE 6821 Y2=PVAR(2) 6822 ENDIF 6823 ELSEIF(J.EQ.3 .AND. NUMVAR.EQ.4)THEN 6824 IF(IVARTY(3).EQ.'VARI')THEN 6825 X2=X2TEMP(ILINE) 6826 ELSE 6827 X2=PVAR(3) 6828 ENDIF 6829 IF(IVARTY(4).EQ.'VARI')THEN 6830 Y2=Y2TEMP(ILINE) 6831 ELSE 6832 Y2=PVAR(4) 6833 ENDIF 6834 ELSE 6835 X2=ARG(J) 6836 J=J+1 6837 IF(J.GT.NUMARG)GOTO1190 6838 Y2=ARG(J) 6839 ENDIF 6840 IF(X2UNIT.EQ.'DATA') 6841 1 CALL DPCODS('X',X2,X2,IBUGD2,ISUBG4,IERROR) 6842 IF(ITYPEO.EQ.'RELA')X2=X1+X2 6843 IF(Y2UNIT.EQ.'DATA') 6844 1 CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBG4,IERROR) 6845 IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2 6846C 6847 CALL DPDRA2(X1,Y1,X2,Y2, 6848 1 IFIG,ILINPA,ILINCO,PLINTH, 6849 1 AREGBA,IREBLI,IREBCO,PREBTH, 6850 1 IREFSW,IREFCO, 6851 1 IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 6852 1 PTEXHE,PTEXWI,PTEXVG,PTEXHG) 6853C 6854 X1=X2 6855 Y1=Y2 6856C 6857 GOTO1160 6858C 6859 1190 CONTINUE 6860C 6861 8100 CONTINUE 6862C 6863 PXEND=X2 6864 PYEND=Y2 6865C 6866 ELSE 6867C 6868C **************************** 6869C ** STEP 4-- ** 6870C ** DRAW SYMBOL CASE ** 6871C **************************** 6872C 6873C 2018/02: ADD "DRAW SYMBOL" SYNTAX. THIS SYNTAX EXPECTS THREE 6874C ARGUMENTS OF VARIABLE NAMES: 6875C 6876C VARIABLE 1 => X-COORDINATE (X1TEMP) 6877C VARIABLE 2 => Y-COORDINATE (Y1TEMP) 6878C VARIABLE 3 => INDEX INTO CHARACTER SETTINGS (X2TEMP) 6879C 6880 IF(NUMVAR.NE.3)THEN 6881 IERROR='YES' 6882 GOTO9000 6883 ENDIF 6884C 6885 DO8200ILINE=1,NLINE 6886C 6887 IF(IVARTY(3).EQ.'VARI')THEN 6888 INDX=INT(X2TEMP(ILINE)+0.1) 6889 ELSE 6890 INDX=INT(PVAR(3)+0.1) 6891 ENDIF 6892 IF(INDX.LT.1)INDX=1 6893 IF(INDX.GT.100)INDX=100 6894C 6895 IF(IBUGD2.EQ.'ON'.OR.ISUBG4.EQ.'DRAW')THEN 6896 WRITE(ICOUT,8301)ILINE,INDX,ICHAPA(ILINE) 6897 8301 FORMAT('ILINE,INDX,ICHAPA(ILINE) = ',2I8,2X,A24) 6898 CALL DPWRST('XXX','BUG ') 6899 ENDIF 6900C 6901 IF(ICHAPA(INDX)(1:3).EQ.'BL ')GOTO8200 6902 IF(ICHAPA(INDX)(1:6).EQ.'BLANK ')GOTO8200 6903 IF(ICHAPA(INDX)(1:5).EQ.'BLAN ')GOTO8200 6904 NCTEXT=0 6905 DO8201JJ=24,1,-1 6906 IF(ICHAPA(INDX)(JJ:JJ).NE.' ')THEN 6907 NCTEXT=JJ 6908 GOTO8203 6909 ENDIF 6910 8201 CONTINUE 6911 8203 CONTINUE 6912 DO8205JJ=1,NCTEXT 6913 ICH2PA(JJ)=' ' 6914 ICH2PA(JJ)(1:1)=ICHAPA(INDX)(JJ:JJ) 6915 8205 CONTINUE 6916C 6917 IF(IBUGD2.EQ.'ON'.OR.ISUBG4.EQ.'DRAW')THEN 6918 WRITE(ICOUT,8303)NCTEXT 6919 8303 FORMAT('NCTEXT = ',I5) 6920 CALL DPWRST('XXX','BUG ') 6921 DO8305JJ=1,NCTEXT 6922 WRITE(ICOUT,8307)JJ,ICH2PA(JJ) 6923 8307 FORMAT('JJ,ICH2PA(JJ) = ',I5,2X,A4) 6924 CALL DPWRST('XXX','BUG ') 6925 8305 CONTINUE 6926 ENDIF 6927C 6928 IF(NCTEXT.LE.0)GOTO8200 6929 IFONT=ICHAFO(INDX) 6930 ICASE=ICHACA(INDX) 6931 IJUST=ICHAJU(INDX) 6932 IDIR=ICHADI(INDX) 6933 IFILL=ICHAFI(INDX) 6934 ICOLCH=ICHACO(INDX) 6935 ANGLE=ACHAAN(INDX) 6936 PHEIGH=PCHAHE(INDX) 6937 PWIDTH=PCHAWI(INDX) 6938 PHOGAP=PCHAHG(INDX) 6939 PVEGAP=PCHAVG(INDX) 6940 PTHICK=PCHATH(INDX) 6941C 6942 IF(IVARTY(1).EQ.'VARI')THEN 6943 X1=X1TEMP(ILINE) 6944 ELSE 6945 X1=PVAR(1) 6946 ENDIF 6947 IF(IVARTY(2).EQ.'VARI')THEN 6948 Y1=Y1TEMP(ILINE) 6949 ELSE 6950 Y1=PVAR(2) 6951 ENDIF 6952C 6953 IF(X1UNIT.EQ.'DATA') 6954 1 CALL DPCODS('X',X1,X1,IBUGD2,ISUBG4,IERROR) 6955 IF(Y1UNIT.EQ.'DATA') 6956 1 CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBG4,IERROR) 6957C 6958 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRAW')THEN 6959 WRITE(ICOUT,8220) 6960 8220 FORMAT('BEFORE CALL DPWRTE') 6961 CALL DPWRST('XXX','BUG ') 6962 WRITE(ICOUT,8221)ILINE,INDX,X1,Y1 6963 8221 FORMAT('ILINE,INDX,X1,Y1 = ',2I5,2G15.7) 6964 CALL DPWRST('XXX','BUG ') 6965 ENDIF 6966C 6967 ITEXZZ=' ' 6968 ITEXZZ(1:4)=ITEXSY 6969 CALL DPWRTE(X1,Y1,ICH2PA,NCTEXT, 6970 1 IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOLCH, 6971 1 PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK, 6972 1 ITEXZZ,ITEXSP, 6973 1 IMPSW2,AMPSCH,AMPSCW, 6974 1 PXEND,PYEND) 6975C 6976 8200 CONTINUE 6977C 6978 ENDIF 6979C 6980C ************************************ 6981C ** STEP 4-- ** 6982C ** CARRY OUT CLOSING OPERATIONS ** 6983C ** ON THE GRAPHICS DEVICES ** 6984C ************************************ 6985C 6986 ICOPSW='OFF' 6987 NUMCOP=0 6988 CALL DPCLPL(ICOPSW,NUMCOP, 6989 1 PGRAXF,PGRAYF, 6990 1 IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 6991 1 PDIAHE,PDIAWI,PDIAVG,PDIAHG) 6992C 6993 CALL DPCLDE 6994C 6995 8000 CONTINUE 6996C 6997C ***************** 6998C ** STEP 90-- ** 6999C ** EXIT ** 7000C ***************** 7001C 7002 9000 CONTINUE 7003 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRAW')THEN 7004 WRITE(ICOUT,999) 7005 CALL DPWRST('XXX','BUG ') 7006 WRITE(ICOUT,9011) 7007 9011 FORMAT('***** AT THE END OF DPDRAW--') 7008 CALL DPWRST('XXX','BUG ') 7009 WRITE(ICOUT,9013)X1,Y1,X2,Y2,NLINE 7010 9013 FORMAT('X1,Y1,X2,Y2,NLINE = ',4G15.7,I8) 7011 CALL DPWRST('XXX','BUG ') 7012 WRITE(ICOUT,9015)PXSTAR,PYSTAR,PXEND,PYEND 7013 9015 FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4G15.7) 7014 CALL DPWRST('XXX','BUG ') 7015 WRITE(ICOUT,9017)IFIG,IFOUND,IERRG4,IERROR 7016 9017 FORMAT('IFIG,IFOUND,IERRG4,IERROR = ',3(A4,2X),A4) 7017 CALL DPWRST('XXX','BUG ') 7018 IF(NLINE.GT.0)THEN 7019 DO9020I=1,NLINE 7020 WRITE(ICOUT,9022)I,X1TEMP(I),Y1TEMP(I),X2TEMP(I),Y2TEMP(I) 7021 9022 FORMAT('I,X1TEMP(I),Y1TEMP(I),X2TEMP(I),Y2TEMP(I)=', 7022 1 I5,4G15.7) 7023 CALL DPWRST('XXX','BUG ') 7024 9020 CONTINUE 7025 ENDIF 7026 ENDIF 7027C 7028 RETURN 7029 END 7030 SUBROUTINE DPDRBA(Y,X,XHIGH,PY,PX,PZ,NP, 7031CCCCC SUBROUTINE DPDRBA(Y,X,PY,PX,NP, 7032 1ICASPL,ICAS3D, 7033 1ISORSW, 7034 1IBA2SW,ABA2WI,ABA2BA, 7035 1IBA2BL,IBA2BC,PBA2BT, 7036 1IBA2FS,IBA2FC, 7037 1IBA2PT,IBA2PL,IBA2PC,IBA2TY,IBA2DI,PBA2PS,PBA2PT, 7038 1XDELMN, 7039 1PXMIN,PXMAX,PYMIN,PYMAX, 7040 1FX1MIN,FX1MAX,FY1MIN,FY1MAX, 7041 1IX1TSC,IY1TSC) 7042C 7043C PURPOSE--FOR A GENERAL GRAPHICS DEVICE, 7044C AND FOR EACH VALUE IN X(.), DRAW A BAR 7045C (= VERTICAL OR HORIZONTAL BAR) 7046C FROM THE BASE POINT ABA2BA 7047C TO THE POINT Y(.). 7048C DO SO FOR A SPECIFIED BAR LINE TYPE, 7049C LINES COLOR, AND LINE THICKNESS. 7050C NOTE--THE VARIABLES PY(.) AND PX(.) ARE DUMMY VARIABLES 7051C WHICH ARE USED IN THE INTERMEDIATE CALCULATIONS 7052C AND WHOSE DIMENSIONS ARE DEFINED (FOR EASY OF CHANGE) 7053C BACK IN THE MAIN ROUTINE. 7054C 7055C WRITTEN BY--JAMES J. FILLIBEN 7056C STATISTICAL ENGINEERING DIVISION 7057C INFORMATION TECHNOLOGY LABORATORY 7058C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 7059C GAITHERSBURG, MD 20899-8980 7060C PHONE--301-975-2855 7061C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 7062C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 7063C LANGUAGE--ANSI FORTRAN (1977) 7064C VERSION NUMBER--87.5 7065C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. 7066C UPDATED--MAY 1987. 7067C --JANUARY 1989. GLOBAL REPLACE ABA2BA WITH ABA2BA (ALAN) 7068C UPDATED--FEBRUARY 1989. GRDRPL TO DPDRPL (ALAN) 7069C UPDATED--FEBRUARY 1989. EXTRA ARGUMENT IN CALL TO DPFIRE (ALAN) 7070C UPDATED--FEBRUARY 1989. BUG WITH PATTERN ON 1ST BAR ONLY (ALAN) 7071C UPDATED--FEBRUARY 1989. NO SORT IF ICASPL='CONT' 7072C UPDATED--FEBRUARY 1989. RENUMBER 7073C UPDATED--JANUARY 2010. FOR HISTOGRAM, ALLOW FOR UNEQUI-SPACED 7074C CASE (STORE IN XHIGH) 7075C 7076C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- 7077C 7078 CHARACTER*4 ICASPL 7079 CHARACTER*4 ICAS3D 7080C 7081 CHARACTER*4 ISORSW 7082C 7083 CHARACTER*4 IBA2SW 7084 CHARACTER*4 IBA2BL 7085 CHARACTER*4 IBA2BC 7086 CHARACTER*4 IBA2FS 7087 CHARACTER*4 IBA2FC 7088 CHARACTER*4 IBA2PT 7089 CHARACTER*4 IBA2PL 7090 CHARACTER*4 IBA2PC 7091 CHARACTER*4 IBA2TY 7092 CHARACTER*4 IBA2DI 7093C 7094 CHARACTER*4 IX1TSC 7095 CHARACTER*4 IY1TSC 7096C 7097 CHARACTER*4 ITYPE 7098C 7099 CHARACTER*4 IFIG 7100 CHARACTER*4 IPATT 7101 CHARACTER*4 ICOL 7102 CHARACTER*4 ICOLF 7103 CHARACTER*4 ICOLP 7104 CHARACTER*4 IDIR 7105C 7106CCCCC CHARACTER*4 IHORPA 7107CCCCC CHARACTER*4 IVERPA 7108CCCCC CHARACTER*4 IDUPPA 7109CCCCC CHARACTER*4 IDDOPA 7110C 7111 CHARACTER*4 IFIGSV 7112 CHARACTER*4 IFLAG 7113 CHARACTER*4 IPATT2 7114C 7115 DIMENSION Y(*) 7116 DIMENSION X(*) 7117 DIMENSION XHIGH(*) 7118 DIMENSION PY(*) 7119 DIMENSION PX(*) 7120 DIMENSION PZ(*) 7121C 7122 DIMENSION PY2(20) 7123 DIMENSION PX2(20) 7124C 7125C-----COMMON---------------------------------------------------------- 7126C 7127 INCLUDE 'DPCOGR.INC' 7128 INCLUDE 'DPCOBE.INC' 7129 INCLUDE 'DPCOP2.INC' 7130C 7131C-----START POINT----------------------------------------------------- 7132C 7133 HOLD=1.0 7134 ABASE=0.0 7135 PBASE=0.0 7136 PBASE2=0.0 7137 PLEFT=0.0 7138 PRIGHT=0.0 7139 AWIDTH=0.0 7140 PWIDTH=0.0 7141 IFLAGH=0 7142 J=0 7143 IF(ICASPL.EQ.'HIST' .OR. ICASPL.EQ.'CUMH' .OR. 7144 1 ICASPL.EQ.'CUMR')THEN 7145 IF(XHIGH(1).NE.CPUMIN)IFLAGH=1 7146 ENDIF 7147C 7148 FXMIN=FX1MIN 7149 FXMAX=FX1MAX 7150 FYMIN=FY1MIN 7151 FYMAX=FY1MAX 7152C 7153 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRBA')THEN 7154 WRITE(ICOUT,999) 7155 999 FORMAT(1X) 7156 CALL DPWRST('XXX','BUG ') 7157 WRITE(ICOUT,51) 7158 51 FORMAT('***** AT THE BEGINNING OF DPDRBA--') 7159 CALL DPWRST('XXX','BUG ') 7160 WRITE(ICOUT,53)NP,ICASPL,ICAS3D,ISORSW,XDELM 7161 53 FORMAT('NP,ICASPL,ICAS3D,ISORSW,XDELM = ', 7162 1 I8,2X,A4,2X,A4,2X,A4,2X,G15.7) 7163 CALL DPWRST('XXX','BUG ') 7164 IF(NP.GT.1)THEN 7165 DO65I=1,NP 7166 WRITE(ICOUT,66)I,X(I),Y(I),XHIGH(I) 7167 66 FORMAT('I,X(I),Y(I),XHIGH(I) = ',I8,3G15.7) 7168 CALL DPWRST('XXX','BUG ') 7169 65 CONTINUE 7170 ENDIF 7171 WRITE(ICOUT,71)IBA2SW,ABA2WI,ABA2BA 7172 71 FORMAT('IBA2SW,ABA2WI,ABA2BA = ',A4,2X,2E15.7) 7173 CALL DPWRST('XXX','BUG ') 7174 WRITE(ICOUT,72)IBA2BL,IBA2BC,PBA2BT 7175 72 FORMAT('IBA2BL,IBA2BC,PBA2BT = ',A4,2X,A4,2X,E15.7) 7176 CALL DPWRST('XXX','BUG ') 7177 WRITE(ICOUT,73)IBA2FS,IBA2FC,IFLAGH 7178 73 FORMAT('IBA2FS,IBA2FC,IFLAGH = ',A4,2X,A4,2X,I5) 7179 CALL DPWRST('XXX','BUG ') 7180 WRITE(ICOUT,74)IBA2PT,IBA2PL,IBA2PC,IBA2TY,IBA2DI,PBA2PS,PBA2PT 7181 74 FORMAT('IBA2PT,IBA2PL,IBA2PC,IBA2TY,IBA2DI,PBA2PS,PBA2PT = ', 7182 1 A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,2E15.7) 7183 CALL DPWRST('XXX','BUG ') 7184 WRITE(ICOUT,84)PXMIN,PXMAX,PYMIN,PYMAX 7185 84 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4E15.7) 7186 CALL DPWRST('XXX','BUG ') 7187 WRITE(ICOUT,85)FX1MIN,FX1MAX,FY1MIN,FY1MAX 7188 85 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4E15.7) 7189 CALL DPWRST('XXX','BUG ') 7190 WRITE(ICOUT,86)IX1TSC,IY1TSC 7191 86 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4) 7192 CALL DPWRST('XXX','BUG ') 7193 WRITE(ICOUT,89)IBUGG4,ISUBG4,IERRG4 7194 89 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 7195 CALL DPWRST('XXX','BUG ') 7196 ENDIF 7197C 7198C ************************************************* 7199C ** STEP 11-- ** 7200C ** IF CALLED FOR, SORT THE DATA ** 7201C ** ACCORDING TO THE HORIZONTAL AXIS VARIABLE ** 7202C ************************************************* 7203C 7204 IDIR=IBA2DI 7205C 7206 IF(ICASPL.EQ.'TRPL')GOTO9000 7207C 7208 IF(ISORSW.EQ.'OFF' .OR. ICASPL.EQ.'PIEC' .OR. 7209 1 ICASPL.EQ.'ROSE' .OR. ICASPL.EQ.'ON' .OR. 7210 1 ICASPL.EQ.'HIST' .OR. ICASPL.EQ.'CUMH' .OR. 7211 1 ICASPL.EQ.'CUMR' .OR. 7212 1 ICASPL.EQ.'CONT')THEN 7213 DO1160I=1,NP 7214 PX(I)=X(I) 7215 PY(I)=Y(I) 7216 1160 CONTINUE 7217C 7218 IF(IFLAGH.EQ.1)THEN 7219 DO1161I=1,NP 7220 PZ(I)=XHIGH(I) 7221 IF(PZ(I).LE.PX(I))THEN 7222 WRITE(ICOUT,999) 7223 CALL DPWRST('XXX','BUG ') 7224 WRITE(ICOUT,1251) 7225 CALL DPWRST('XXX','BUG ') 7226 WRITE(ICOUT,1171)I 7227 1171 FORMAT(' FOR UNEQUI-SPACED HISTOGRAMS, FOR ROW ',I8) 7228 CALL DPWRST('XXX','BUG ') 7229 WRITE(ICOUT,1172) 7230 1172 FORMAT(' THE UPPER INTERVAL IS LESS THAN OR EQUAL ', 7231 1 'TO THE LOWER INTERVAL.') 7232 CALL DPWRST('XXX','BUG ') 7233 WRITE(ICOUT,1173)PX(I) 7234 1173 FORMAT(' THE VALUE FOR THE LOWER INTERVAL IS ',G15.7) 7235 CALL DPWRST('XXX','BUG ') 7236 WRITE(ICOUT,1174)PZ(I) 7237 1174 FORMAT(' THE VALUE FOR THE UPPER INTERVAL IS ',G15.7) 7238 CALL DPWRST('XXX','BUG ') 7239 GOTO9000 7240 ENDIF 7241 1161 CONTINUE 7242 ENDIF 7243 ELSE 7244 CALL SORTC(X,Y,NP,PX,PY) 7245 ENDIF 7246C 7247 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRBA')THEN 7248 WRITE(ICOUT,1194)IPR 7249 1194 FORMAT('IPR=',I4) 7250 CALL DPWRST('XXX','BUG ') 7251 IF(IFLAGH.EQ.1)THEN 7252 DO1198I=1,10 7253 WRITE(ICOUT,1199) I,PX(I),PY(I),PZ(I) 7254 1199 FORMAT('I,PX(I),PY(I),PZ(I) =',I8,2X,3G15.7) 7255 CALL DPWRST('XXX','BUG ') 7256 1198 CONTINUE 7257 ELSE 7258 DO1192I=1,10 7259 WRITE(ICOUT,1196) I,PX(I),PY(I) 7260 1196 FORMAT('I,PX(I),PY(I) =',I8,2X,2G15.7) 7261 CALL DPWRST('XXX','BUG ') 7262 1192 CONTINUE 7263 ENDIF 7264 ENDIF 7265C 7266C ************************************************ 7267C ** STEP 12-- ** 7268C ** IF A LOG SCALE PLOT IS CALLED FOR, ** 7269C ** CHECK THAT ALL DATA POINTS ARE POSITIVE. ** 7270C ************************************************ 7271C 7272 IF(IX1TSC.EQ.'LOG')THEN 7273 IFLAGN=0 7274 IF(IDIR.EQ.'H')THEN 7275 IF(ABA2BA.LE.0.0)HOLD=ABA2BA 7276 IF(ABA2BA.LE.0.0)IFLAGN=1 7277 GOTO1239 7278 ENDIF 7279C 7280 IF(ISORSW.EQ.'ON')THEN 7281 J=1 7282 IF(PX(J).LE.0.0)IFLAGN=1 7283 ELSE 7284 DO1235I=1,NP 7285 J=I 7286 IF(PX(J).LE.0.0)THEN 7287 IFLAGN=1 7288 GOTO1239 7289 ELSEIF(IFLAGH.EQ.1 .AND. PZ(J).LE.0.0)THEN 7290 IFLAGN=1 7291 GOTO1239 7292 ENDIF 7293 1235 CONTINUE 7294 ENDIF 7295C 7296 1239 CONTINUE 7297 IF(IFLAGN.EQ.1)THEN 7298 WRITE(ICOUT,999) 7299 CALL DPWRST('XXX','BUG ') 7300 WRITE(ICOUT,1251) 7301 1251 FORMAT('***** ERROR IN DPDRBA--') 7302 CALL DPWRST('XXX','BUG ') 7303 WRITE(ICOUT,1252) 7304 1252 FORMAT(' THE LOG OF A NON-POSITIVE DATA VALUE WAS') 7305 CALL DPWRST('XXX','BUG ') 7306 WRITE(ICOUT,1253) 7307 1253 FORMAT(' ENCOUNTERED IN FORMING A PLOT. DATA MAY NOT') 7308 CALL DPWRST('XXX','BUG ') 7309 WRITE(ICOUT,1255) 7310 1255 FORMAT(' BE ZERO OR NEGATIVE WHEN A LOG SCALE PLOT ', 7311 1 'IS USED.') 7312 CALL DPWRST('XXX','BUG ') 7313 WRITE(ICOUT,1256)PX(J) 7314 1256 FORMAT(' THE VALUE = ',G15.7) 7315 CALL DPWRST('XXX','BUG ') 7316 WRITE(ICOUT,1257) 7317 1257 FORMAT(' THIS VALUE CAME FROM THE HORIZONTAL AXIS ', 7318 1 'VARIABLE.') 7319 CALL DPWRST('XXX','BUG ') 7320 WRITE(ICOUT,1259) 7321 1259 FORMAT(' CORRECTIVE ACTION--') 7322 CALL DPWRST('XXX','BUG ') 7323 WRITE(ICOUT,1260) 7324 1260 FORMAT(' CHANGE DATA OR CHANGE LIMITS.') 7325 CALL DPWRST('XXX','BUG ') 7326 IERRG4='YES' 7327 GOTO9000 7328 ENDIF 7329 ENDIF 7330C 7331 IF(IY1TSC.EQ.'LOG')THEN 7332 IFLAGN=0 7333 IF(IDIR.EQ.'V')THEN 7334 IF(ABA2BA.LE.0.0)HOLD=ABA2BA 7335 IF(ABA2BA.LE.0.0)IFLAGN=1 7336 GOTO1339 7337 ENDIF 7338C 7339 IF(ISORSW.EQ.'ON')THEN 7340 J=1 7341 IF(PY(J).LE.0.0)HOLD=PY(J) 7342 IF(PY(J).LE.0.0)IFLAGN=1 7343 ELSE 7344 DO1335I=1,NP 7345 J=I 7346 IF(PY(J).LE.0.0)HOLD=PY(J) 7347 IF(PY(J).LE.0.0)THEN 7348 IFLAGN=1 7349 GOTO1339 7350 ENDIF 7351 1335 CONTINUE 7352 ENDIF 7353C 7354 1339 CONTINUE 7355 IF(IFLAGN.EQ.1)THEN 7356 WRITE(ICOUT,999) 7357 CALL DPWRST('XXX','BUG ') 7358 WRITE(ICOUT,1351) 7359 1351 FORMAT('***** ERROR IN DPDRBA--') 7360 CALL DPWRST('XXX','BUG ') 7361 WRITE(ICOUT,1352) 7362 1352 FORMAT(' THE LOG OF A NON-POSITIVE DATA VALUE WAS') 7363 CALL DPWRST('XXX','BUG ') 7364 WRITE(ICOUT,1353) 7365 1353 FORMAT(' ENCOUNTERED IN FORMING A PLOT. DATA MAY NOT') 7366 CALL DPWRST('XXX','BUG ') 7367 WRITE(ICOUT,1355) 7368 1355 FORMAT(' BE ZERO OR NEGATIVE. WHEN A LOG SCALE PLOT ', 7369 1 'IS USED.') 7370 CALL DPWRST('XXX','BUG ') 7371 WRITE(ICOUT,1356)HOLD 7372 1356 FORMAT(' THE VALUE = ',E15.7) 7373 CALL DPWRST('XXX','BUG ') 7374 WRITE(ICOUT,1357) 7375 1357 FORMAT(' THIS VALUE CAME FROM THE VERTICAL AXIS ', 7376 1 'VARIABLE.') 7377 CALL DPWRST('XXX','BUG ') 7378 WRITE(ICOUT,1259) 7379 CALL DPWRST('XXX','BUG ') 7380 WRITE(ICOUT,1260) 7381 CALL DPWRST('XXX','BUG ') 7382 IERRG4='YES' 7383 GOTO9000 7384 ENDIF 7385 ENDIF 7386C 7387 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRBA')THEN 7388 WRITE(ICOUT,1391) 7389 1391 FORMAT('AT BRANCH POINT 1390') 7390 CALL DPWRST('XXX','BUG ') 7391 ENDIF 7392C 7393C ****************************************** 7394C ** STEP 40-- ** 7395C ** IF A LOG SCALE PLOT IS CALLED FOR, ** 7396C ** TRANSFORM THE DATA ** 7397C ****************************************** 7398C 7399 ABASE=ABA2BA 7400 AWIDTH=ABA2WI 7401C 7402 IF(IDIR.EQ.'V')THEN 7403 IF(AWIDTH.EQ.CPUMIN.AND.XDELMN.LE.0.0)AWIDTH=1.0 7404 IF(AWIDTH.EQ.CPUMIN.AND.XDELMN.GT.0.0)AWIDTH=XDELMN 7405 ELSEIF(IDIR.EQ.'H')THEN 7406 IF(AWIDTH.EQ.CPUMIN.AND.XDELMN.LE.0.0)AWIDTH=1.0 7407 IF(AWIDTH.EQ.CPUMIN.AND.XDELMN.GT.0.0)AWIDTH=XDELMN 7408 ENDIF 7409C 7410 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRBA')THEN 7411 WRITE(ICOUT,4008) ABASE,AWIDTH 7412 4008 FORMAT('ABASE,AWIDTH =',2G15.7) 7413 CALL DPWRST('XXX','BUG ') 7414 ENDIF 7415C 7416 IF(IX1TSC.EQ.'LOG')THEN 7417 IF(IDIR.EQ.'H')ABASE=LOG10(ABASE) 7418 DO4015I=1,NP 7419 PX(I)=LOG10(PX(I)) 7420 4015 CONTINUE 7421 IF(IFLAGH.EQ.1)THEN 7422 DO4016I=1,NP 7423 PZ(I)=LOG10(PZ(I)) 7424 4016 CONTINUE 7425 ENDIF 7426 ENDIF 7427C 7428 IF(IY1TSC.EQ.'LOG')THEN 7429 IF(IDIR.EQ.'V')ABASE=LOG10(ABASE) 7430 DO4025I=1,NP 7431 PY(I)=LOG10(PY(I)) 7432 4025 CONTINUE 7433 ENDIF 7434C 7435C ***************************************************** 7436C ** STEP 50-- ** 7437C ** TRANSLATE THE DATA POINTS ** 7438C ** INTO STANDARDIZED (0.0 TO 100.0) COORDINATES. ** 7439C ***************************************************** 7440C 7441 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRBA')THEN 7442 WRITE(ICOUT,4999) 7443 4999 FORMAT( 'AT 5001 BREAKPOINT') 7444 CALL DPWRST('XXX','BUG ') 7445 ENDIF 7446C 7447 FXMIN=FX1MIN 7448 FXMAX=FX1MAX 7449 IF(IX1TSC.EQ.'LOG')THEN 7450 FXMIN=LOG10(FX1MIN) 7451 FXMAX=LOG10(FX1MAX) 7452 ENDIF 7453C 7454 FYMIN=FY1MIN 7455 FYMAX=FY1MAX 7456 IF(IY1TSC.EQ.'LOG')THEN 7457 FYMIN=LOG10(FY1MIN) 7458 FYMAX=LOG10(FY1MAX) 7459 ENDIF 7460C 7461 FXRANG=FXMAX-FXMIN 7462 FYRANG=FYMAX-FYMIN 7463 PXRANG=PXMAX-PXMIN 7464 PYRANG=PYMAX-PYMIN 7465C 7466 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRBA')THEN 7467 WRITE(ICOUT,4993) FXMIN,FXMAX,FYMIN,FYMAX 7468 4993 FORMAT('FXMIN,FXMAX,FYMIN,FYMAX=',4(E15.7,1X)) 7469 CALL DPWRST('XXX','BUG ') 7470 WRITE(ICOUT,4994) FXRANG,FYRANG,PXRANG,PYRANG 7471 4994 FORMAT('FXRANG,FYRANG,PXRANG,PYRANG=',6(E15.7,1X)) 7472 CALL DPWRST('XXX','BUG ') 7473 ENDIF 7474C 7475 DO5000I=1,NP 7476 FXRATI=(PX(I)-FXMIN)/FXRANG 7477 FYRATI=(PY(I)-FYMIN)/FYRANG 7478 PX(I)=PXMIN+FXRATI*PXRANG 7479 PY(I)=PYMIN+FYRATI*PYRANG 7480 5000 CONTINUE 7481C 7482 IF(IFLAGH.EQ.1)THEN 7483 DO5002I=1,NP 7484 FXRAT2=(PZ(I)-FXMIN)/FXRANG 7485 PZ(I)=PXMIN+FXRAT2*PXRANG 7486 5002 CONTINUE 7487 ENDIF 7488C 7489 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRBA')THEN 7490 DO5004I=1,NP 7491 WRITE(ICOUT,5006) PX(I),PY(I),PZ(I) 7492 5006 FORMAT('PX(I),PY(I),PZ(I)=',3(E15.7,1X)) 7493 CALL DPWRST('XXX','BUG ') 7494 5004 CONTINUE 7495 ENDIF 7496C 7497 IF(IDIR.EQ.'V')THEN 7498 FYRATI=(ABASE-FYMIN)/FYRANG 7499 PBASE=PYMIN+FYRATI*PYRANG 7500 PWIDTH=AWIDTH*(PXRANG/FXRANG) 7501 ELSEIF(IDIR.EQ.'H')THEN 7502 FXRATI=(ABASE-FXMIN)/FXRANG 7503 PBASE=PXMIN+FXRATI*PXRANG 7504 PWIDTH=AWIDTH*(PYRANG/FYRANG) 7505 ENDIF 7506C 7507 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRBA')THEN 7508 WRITE(ICOUT,5038) FXRATI,PBASE,PWIDTH 7509 5038 FORMAT('FXRATI,PBASE,PWIDTH=',3(E15.7,1X)) 7510 CALL DPWRST('XXX','BUG ') 7511 ENDIF 7512C 7513C ******************************* 7514C ** STEP 70-- ** 7515C ** PREPARE TO MAKE VARIOUS ** 7516C ** LINE SETTINGS ** 7517C ******************************* 7518C 7519 ITYPE='LINE' 7520C 7521 IFIG='BOX' 7522 IF(IBA2TY.EQ.'3')IFIG='CUBE' 7523 IFIGSV=IFIG 7524 PBASE2=PBASE 7525C 7526 CALL DPSQUE(PX,PY,NP,PXMIN,PXMAX,PYMIN,PYMAX) 7527C 7528 IF(IFLAGH.EQ.1)THEN 7529 CALL DPSQUE(PX,PZ,NP,PXMIN,PXMAX,PYMIN,PYMAX) 7530 ENDIF 7531C 7532C *************************************** 7533C ** STEP 81-- ** 7534C ** DRAW OUT ALL VERTICAL BARS ** 7535C ** (BUT FILL FIRST, IF CALLED FOR) ** 7536C *************************************** 7537C 7538 IF(IDIR.EQ.'V')GOTO8100 7539 GOTO8190 7540C 7541 8100 CONTINUE 7542C SEPTEMBER, 1987 - MOVE SETTINGS INSIDE THE LOOP 7543CCCCC IPATT=IBA2PT 7544CCCCC PTHICK=PBA2PT 7545CCCCC PXGAP=PBA2PS 7546CCCCC PYGAP=PBA2PS 7547CCCCC ICOLF=IBA2FC 7548CCCCC ICOLP=IBA2PC 7549C 7550 IF(PBASE2.LT.PYMIN.AND.(PYMIN-PBASE2).LE.0.0001)PBASE2=PYMIN 7551 IF(PBASE2.GT.PYMAX.AND.(PBASE2-PYMAX).LE.0.0001)PBASE2=PYMAX 7552C 7553 DO8105I=1,NP 7554C 7555 IPATT=IBA2PT 7556 IPATT2=IBA2PL 7557 PTHICK=PBA2PT 7558 PXGAP=PBA2PS 7559 PYGAP=PBA2PS 7560 ICOLF=IBA2FC 7561 ICOLP=IBA2PC 7562C 7563 IF(IFLAGH.EQ.1)THEN 7564 PLEFT=PX(I) 7565 PRIGHT=PZ(I) 7566 ELSE 7567 PLEFT=PX(I)-PWIDTH/2.0 7568 PRIGHT=PX(I)+PWIDTH/2.0 7569 ENDIF 7570 IF(PLEFT.LT.PXMIN.AND.(PXMIN-PLEFT).LE.0.0001)PLEFT=PXMIN 7571 IF(PRIGHT.GT.PXMAX.AND.(PRIGHT-PXMAX).LE.0.0001)PRIGHT=PXMAX 7572C 7573 IF(PRIGHT.LT.PXMIN)GOTO8105 7574 IF(PLEFT.GT.PXMAX)GOTO8105 7575 IF(PY(I).LT.PYMIN.AND.PBASE2.LT.PYMIN)GOTO8105 7576 IF(PY(I).GT.PYMAX.AND.PBASE2.GT.PYMAX)GOTO8105 7577C 7578 X1=PLEFT 7579 Y1=PBASE2 7580 X2=PRIGHT 7581 Y2=PY(I) 7582C 7583 DELX=ABS(X2-X1) 7584 DELY=ABS(Y2-Y1) 7585 DELMIN=DELX 7586CCCCC IF(DELY.LT.DELX)DELMIN=DELY 7587 P3D=0.3 7588 DEL3D=P3D*DELMIN 7589C 7590 IF(IBA2FS.EQ.'OFF')GOTO8150 7591C 7592 IF(IBA2FS.EQ.'ONS')GOTO8120 7593 IF(IBA2FS.EQ.'ONST')GOTO8120 7594 IF(IBA2FS.EQ.'ONTS')GOTO8120 7595 IF(IBA2FS.EQ.'ONT')GOTO8130 7596C 7597 IF(IBA2FS.EQ.'ON' .OR. IBA2FS.EQ.'ONF' .OR. 7598 1 IBA2FS.EQ.'ONFS' .OR. IBA2FS.EQ.'ONSF' .OR. 7599 1 IBA2FS.EQ.'ONFT' .OR. IBA2FS.EQ.'ONTF')THEN 7600C 7601C FRONT FACE 7602C 7603 PX2(1)=X1 7604 PY2(1)=Y1 7605C 7606 PX2(2)=X2 7607 PY2(2)=Y1 7608C 7609 PX2(3)=X2 7610 PY2(3)=Y2 7611C 7612 PX2(4)=X1 7613 PY2(4)=Y2 7614C 7615 PX2(5)=X1 7616 PY2(5)=Y1 7617C 7618 NP2=5 7619C 7620 DO8115J=1,NP2 7621 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN 7622 IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX 7623 IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN 7624 IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 7625 8115 CONTINUE 7626 CALL DPFIRE(PX2,PY2,NP2, 7627 1 IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP, 7628 1 IPATT2) 7629C 7630 ENDIF 7631 8120 CONTINUE 7632C 7633 IF(IBA2TY.EQ.'2')GOTO8150 7634 IF(IBA2FS.EQ.'ONF')GOTO8150 7635 IF(IBA2FS.EQ.'ONT')GOTO8130 7636 IF(IBA2FS.EQ.'ONFT')GOTO8130 7637 IF(IBA2FS.EQ.'ONTF')GOTO8130 7638C 7639 IF(IBA2FS.EQ.'ON' .OR. IBA2FS.EQ.'ONS' .OR. 7640 1 IBA2FS.EQ.'ONFS' .OR. IBA2FS.EQ.'ONSF' .OR. 7641 1 IBA2FS.EQ.'ONST' .OR. IBA2FS.EQ.'ONTS')THEN 7642C 7643C SIDE (= RIGHT) FACE 7644C 7645 PX2(1)=X2 7646 PY2(1)=Y2 7647C 7648 PX2(2)=X2+DEL3D 7649 PY2(2)=Y2+DEL3D 7650C 7651 PX2(3)=X2+DEL3D 7652 PY2(3)=Y1+DEL3D 7653C 7654 PX2(4)=X2 7655 PY2(4)=Y1 7656C 7657 PX2(5)=X2 7658 PY2(5)=Y2 7659C 7660 NP2=5 7661C 7662 DO8125J=1,NP2 7663 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN 7664 IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX 7665 IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN 7666 IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 7667 8125 CONTINUE 7668 CALL DPFIRE(PX2,PY2,NP2, 7669 1 IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP, 7670 1 IPATT2) 7671 ENDIF 7672C 7673 8130 CONTINUE 7674C 7675 IF(IBA2FS.EQ.'ONF')GOTO8150 7676 IF(IBA2FS.EQ.'ONS')GOTO8150 7677 IF(IBA2FS.EQ.'ONFS')GOTO8150 7678 IF(IBA2FS.EQ.'ONSF')GOTO8150 7679C 7680 IF(IBA2FS.EQ.'ON' .OR. IBA2FS.EQ.'ONT' .OR. 7681 1 IBA2FS.EQ.'ONFT' .OR. IBA2FS.EQ.'ONTF' .OR. 7682 1 IBA2FS.EQ.'ONST' .OR. IBA2FS.EQ.'ONTS')THEN 7683C 7684C TOP FACE 7685C 7686 PX2(1)=X1 7687 PY2(1)=Y2 7688C 7689 PX2(2)=X1+DEL3D 7690 PY2(2)=Y2+DEL3D 7691C 7692 PX2(3)=X2+DEL3D 7693 PY2(3)=Y2+DEL3D 7694C 7695 PX2(4)=X2 7696 PY2(4)=Y2 7697C 7698 PX2(5)=X1 7699 PY2(5)=Y2 7700C 7701 NP2=5 7702C 7703 DO8135J=1,NP2 7704 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN 7705 IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX 7706 IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN 7707 IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 7708 8135 CONTINUE 7709 CALL DPFIRE(PX2,PY2,NP2, 7710 1 IFIG,IPATT,PTHICK,PX2GAP,PYGAP,ICOLF,ICOLP, 7711 1 IPATT2) 7712 ENDIF 7713C 7714 8150 CONTINUE 7715C 7716C DRAW OUT THE EDGES OF THE BAR 7717C 7718 IPATT=IBA2BL 7719 PTHICK=PBA2BT 7720 ICOL=IBA2BC 7721C 7722 PX2(1)=X1 7723 PY2(1)=Y1 7724C 7725 PX2(2)=X2 7726 PY2(2)=Y1 7727C 7728 PX2(3)=X2 7729 PY2(3)=Y2 7730C 7731 PX2(4)=X1 7732 PY2(4)=Y2 7733C 7734 PX2(5)=X1 7735 PY2(5)=Y1 7736C 7737 NP2=5 7738C 7739 DO8151J=1,NP2 7740 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN 7741 IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX 7742 IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN 7743 IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 7744 8151 CONTINUE 7745 IFLAG='ON' 7746 CALL DPDRPL(PX2,PY2,NP2, 7747 1 IFIG,IPATT,PTHICK,ICOL, 7748 1 JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 7749C 7750 IF(IBA2TY.EQ.'2')GOTO8105 7751C 7752 PX2(1)=X1 7753 PY2(1)=Y2 7754C 7755 PX2(2)=X1+DEL3D 7756 PY2(2)=Y2+DEL3D 7757C 7758 PX2(3)=X2+DEL3D 7759 PY2(3)=Y2+DEL3D 7760C 7761 PX2(4)=X2 7762 PY2(4)=Y2 7763C 7764 NP2=4 7765C 7766 DO8152J=1,NP2 7767 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN 7768 IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX 7769 IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN 7770 IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 7771 8152 CONTINUE 7772 IFLAG='OFF' 7773 CALL DPDRPL(PX2,PY2,NP2, 7774 1 IFIG,IPATT,PTHICK,ICOL, 7775 1 JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 7776C 7777 PX2(1)=X2+DEL3D 7778 PY2(1)=Y2+DEL3D 7779C 7780 PX2(2)=X2+DEL3D 7781 PY2(2)=Y1+DEL3D 7782C 7783 PX2(3)=X2 7784 PY2(3)=Y1 7785C 7786 NP2=3 7787C 7788 DO8153J=1,NP2 7789 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN 7790 IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX 7791 IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN 7792 IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 7793 8153 CONTINUE 7794 IFLAG='OFF' 7795 CALL DPDRPL(PX2,PY2,NP2, 7796 1 IFIG,IPATT,PTHICK,ICOL, 7797 1 JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 7798C 7799 8105 CONTINUE 7800C 7801 8190 CONTINUE 7802C 7803C *************************************** 7804C ** STEP 82-- ** 7805C ** DRAW OUT ALL HORIZONTAL BARS ** 7806C ** (BUT FILL FIRST, IF CALLED FOR) ** 7807C *************************************** 7808C 7809 IF(IDIR.EQ.'H')GOTO8200 7810 GOTO8290 7811C 7812 8200 CONTINUE 7813C SEPTEMBER, 1987: MOVE INSIDE LOOP 7814CCCCC IPATT=IBA2PT 7815CCCCC PTHICK=PBA2PT 7816CCCCC PXGAP=PBA2PS 7817CCCCC PYGAP=PBA2PS 7818CCCCC ICOLF=IBA2FC 7819CCCCC ICOLP=IBA2PC 7820C 7821 IF(PBASE2.LT.PXMIN.AND.(PXMIN-PBASE2).LE.0.0001)PBASE2=PXMIN 7822 IF(PBASE2.GT.PXMAX.AND.(PBASE2-PXMAX).LE.0.0001)PBASE2=PXMAX 7823C 7824 DO8205I=1,NP 7825C 7826 IPATT=IBA2PT 7827 IPATT2=IBA2PL 7828 PTHICK=PBA2PT 7829 PXGAP=PBA2PS 7830 PYGAP=PBA2PS 7831 ICOLF=IBA2FC 7832 ICOLP=IBA2PC 7833C 7834 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRBA')THEN 7835 WRITE(ICOUT,8203) 7836 8203 FORMAT('IN 8200 LOOP') 7837 CALL DPWRST('XXX','BUG ') 7838 ENDIF 7839C 7840 IF(IFLAGH.EQ.1)THEN 7841 PBOT=PY(I) 7842 PTOP=PZ(I) 7843 ELSE 7844 PBOT=PY(I)-PWIDTH/2.0 7845 PTOP=PY(I)+PWIDTH/2.0 7846 ENDIF 7847 IF(PBOT.LT.PYMIN.AND.(PYMIN-PBOT).LE.0.0001)PBOT=PYMIN 7848 IF(PTOP.GT.PYMAX.AND.(PTOP-PYMAX).LE.0.0001)PTOP=PYMAX 7849C 7850 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRBA')THEN 7851 WRITE(ICOUT,8204) PBOT,PTOP 7852 8204 FORMAT('PBOT,PTOP=',2(E15.7,1X)) 7853 CALL DPWRST('XXX','BUG ') 7854 ENDIF 7855C 7856 IF(PTOP.LT.PYMIN)GOTO8205 7857 IF(PBOT.GT.PYMAX)GOTO8205 7858 IF(PX(I).LT.PXMIN.AND.PBASE2.LT.PXMIN)GOTO8205 7859 IF(PX(I).GT.PXMAX.AND.PBASE2.GT.PXMAX)GOTO8205 7860C 7861 X1=PBASE2 7862 Y1=PBOT 7863 X2=PX(I) 7864 Y2=PTOP 7865C 7866 DELX=ABS(X2-X1) 7867 DELY=ABS(Y2-Y1) 7868 DELMIN=DELY 7869CCCCC IF(DELX.LT.DELY)DELMIN=DELX 7870 P3D=0.3 7871 DEL3D=P3D*DELMIN 7872C 7873 IF(IBA2FS.EQ.'OFF')GOTO8250 7874 IF(IBA2FS.EQ.'ONS')GOTO8220 7875 IF(IBA2FS.EQ.'ONST')GOTO8220 7876 IF(IBA2FS.EQ.'ONTS')GOTO8220 7877 IF(IBA2FS.EQ.'ONT')GOTO8230 7878C 7879 IF(IBA2FS.EQ.'ON' .OR. IBA2FS.EQ.'ONF' .OR. 7880 1 IBA2FS.EQ.'ONFS' .OR. IBA2FS.EQ.'ONSF' .OR. 7881 1 IBA2FS.EQ.'ONFT' .OR. IBA2FS.EQ.'ONTF')THEN 7882C 7883C FRONT FACE 7884C 7885 PX2(1)=X1 7886 PY2(1)=Y1 7887C 7888 PX2(2)=X2 7889 PY2(2)=Y1 7890C 7891 PX2(3)=X2 7892 PY2(3)=Y2 7893C 7894 PX2(4)=X1 7895 PY2(4)=Y2 7896C 7897 PX2(5)=X1 7898 PY2(5)=Y1 7899C 7900 NP2=5 7901C 7902 DO8215J=1,NP2 7903 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN 7904 IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX 7905 IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN 7906 IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 7907 8215 CONTINUE 7908 CALL DPFIRE(PX2,PY2,NP2, 7909 1 IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP, 7910 1 IPATT2) 7911 ENDIF 7912C 7913 8220 CONTINUE 7914C 7915 IF(IBA2TY.EQ.'2')GOTO8250 7916 IF(IBA2FS.EQ.'ONF')GOTO8250 7917 IF(IBA2FS.EQ.'ONT')GOTO8230 7918 IF(IBA2FS.EQ.'ONFT')GOTO8230 7919 IF(IBA2FS.EQ.'ONTF')GOTO8230 7920C 7921 IF(IBA2FS.EQ.'ON' .OR. IBA2FS.EQ.'ONS' .OR. 7922 1 IBA2FS.EQ.'ONFS' .OR. IBA2FS.EQ.'ONSF' .OR. 7923 1 IBA2FS.EQ.'ONST' .OR. IBA2FS.EQ.'ONTS')THEN 7924C 7925C SIDE (= RIGHT) FACE 7926C 7927 PX2(1)=X2 7928 PY2(1)=Y2 7929C 7930 PX2(2)=X2+DEL3D 7931 PY2(2)=Y2+DEL3D 7932C 7933 PX2(3)=X2+DEL3D 7934 PY2(3)=Y1+DEL3D 7935C 7936 PX2(4)=X2 7937 PY2(4)=Y1 7938C 7939 PX2(5)=X2 7940 PY2(5)=Y2 7941C 7942 NP2=5 7943C 7944 DO8225J=1,NP2 7945 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN 7946 IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX 7947 IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN 7948 IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 7949 8225 CONTINUE 7950 CALL DPFIRE(PX2,PY2,NP2, 7951 1 IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP, 7952 1 IPATT2) 7953 ENDIF 7954C 7955 8230 CONTINUE 7956C 7957 IF(IBA2FS.EQ.'ONF')GOTO8250 7958 IF(IBA2FS.EQ.'ONS')GOTO8250 7959 IF(IBA2FS.EQ.'ONFS')GOTO8250 7960 IF(IBA2FS.EQ.'ONSF')GOTO8250 7961C 7962 IF(IBA2FS.EQ.'ON' .OR. IBA2FS.EQ.'ONT' .OR. 7963 1 IBA2FS.EQ.'ONFT' .OR. IBA2FS.EQ.'ONTF' .OR. 7964 1 IBA2FS.EQ.'ONST' .OR. IBA2FS.EQ.'ONTS')THEN 7965C 7966C TOP FACE 7967C 7968 PX2(1)=X1 7969 PY2(1)=Y2 7970C 7971 PX2(2)=X1+DEL3D 7972 PY2(2)=Y2+DEL3D 7973C 7974 PX2(3)=X2+DEL3D 7975 PY2(3)=Y2+DEL3D 7976C 7977 PX2(4)=X2 7978 PY2(4)=Y2 7979C 7980 PX2(5)=X1 7981 PY2(5)=Y2 7982C 7983 NP2=5 7984C 7985 DO8235J=1,NP2 7986 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN 7987 IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX 7988 IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN 7989 IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 7990 8235 CONTINUE 7991 CALL DPFIRE(PX2,PY2,NP2, 7992 1 IFIG,IPATT,PTHICK,PX2GAP,PYGAP,ICOLF,ICOLP, 7993 1 IPATT2) 7994 ENDIF 7995C 7996 8250 CONTINUE 7997C 7998C DRAW OUT THE EDGES OF THE BAR 7999C 8000 IPATT=IBA2BL 8001 PTHICK=PBA2BT 8002 ICOL=IBA2BC 8003C 8004 PX2(1)=X1 8005 PY2(1)=Y1 8006C 8007 PX2(2)=X2 8008 PY2(2)=Y1 8009C 8010 PX2(3)=X2 8011 PY2(3)=Y2 8012C 8013 PX2(4)=X1 8014 PY2(4)=Y2 8015C 8016 PX2(5)=X1 8017 PY2(5)=Y1 8018C 8019 NP2=5 8020C 8021 DO8251J=1,NP2 8022 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN 8023 IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX 8024 IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN 8025 IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 8026 8251 CONTINUE 8027 IFLAG='ON' 8028 CALL DPDRPL(PX2,PY2,NP2, 8029 1 IFIG,IPATT,PTHICK,ICOL, 8030 1 JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 8031C 8032 IF(IBA2TY.EQ.'2')GOTO8205 8033C 8034 PX2(1)=X1 8035 PY2(1)=Y2 8036C 8037 PX2(2)=X1+DEL3D 8038 PY2(2)=Y2+DEL3D 8039C 8040 PX2(3)=X2+DEL3D 8041 PY2(3)=Y2+DEL3D 8042C 8043 PX2(4)=X2 8044 PY2(4)=Y2 8045C 8046 NP2=4 8047C 8048 DO8252J=1,NP2 8049 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN 8050 IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX 8051 IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN 8052 IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 8053 8252 CONTINUE 8054 IFLAG='OFF' 8055 CALL DPDRPL(PX2,PY2,NP2, 8056 1 IFIG,IPATT,PTHICK,ICOL, 8057 1 JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 8058C 8059 PX2(1)=X2+DEL3D 8060 PY2(1)=Y2+DEL3D 8061C 8062 PX2(2)=X2+DEL3D 8063 PY2(2)=Y1+DEL3D 8064C 8065 PX2(3)=X2 8066 PY2(3)=Y1 8067C 8068 NP2=3 8069C 8070 DO8253J=1,NP2 8071 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN 8072 IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX 8073 IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN 8074 IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 8075 8253 CONTINUE 8076 IFLAG='OFF' 8077 CALL DPDRPL(PX2,PY2,NP2, 8078 1 IFIG,IPATT,PTHICK,ICOL, 8079 1 JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 8080C 8081 8205 CONTINUE 8082C 8083 8290 CONTINUE 8084C 8085C ***************** 8086C ** STEP 90-- ** 8087C ** EXIT ** 8088C ***************** 8089C 8090 9000 CONTINUE 8091 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRBA')THEN 8092 WRITE(ICOUT,999) 8093 CALL DPWRST('XXX','BUG ') 8094 WRITE(ICOUT,9011) 8095 9011 FORMAT('***** AT THE END OF DPDRBA--') 8096 CALL DPWRST('XXX','BUG ') 8097 WRITE(ICOUT,9013)NP,ICASPL,ICAS3D,ISORSW 8098 9013 FORMAT('NP,ICASPL,ICAS3D,ISORSW = ',I8,3(2X,A4)) 8099 CALL DPWRST('XXX','BUG ') 8100 WRITE(ICOUT,9014)ABASE,HOLD,PBASE,PBASE2,PLEFT,PRIGHT 8101 9014 FORMAT('ABASE,HOLD,PBASE,PBASE2,PLEFT,PRIGHT = ',6E15.7) 8102 CALL DPWRST('XXX','BUG ') 8103 WRITE(ICOUT,9015)XDELMN,AWIDTH,PWIDTH 8104 9015 FORMAT('XDELMN,AWIDTH,PWIDTH = ',3G15.7) 8105 CALL DPWRST('XXX','BUG ') 8106 IF(NP.GT.3)THEN 8107 DO9025I=1,3 8108 WRITE(ICOUT,9026)I,X(I),Y(I) 8109 9026 FORMAT('I,X(I),Y(I) = ',I8,2G15.7) 8110 CALL DPWRST('XXX','BUG ') 8111 9025 CONTINUE 8112 NPM2=NP-2 8113 DO9027I=NPM2,NP 8114 WRITE(ICOUT,9028)I,X(I),Y(I) 8115 9028 FORMAT('I,X(I),Y(I) = ',I8,2G15.7) 8116 CALL DPWRST('XXX','BUG ') 8117 9027 CONTINUE 8118 ENDIF 8119 WRITE(ICOUT,9031)IBA2SW,ABA2WI,ABA2BA 8120 9031 FORMAT('IBA2SW,ABA2WI,ABA2BA = ',A4,2X,2G15.7) 8121 CALL DPWRST('XXX','BUG ') 8122 WRITE(ICOUT,9032)IBA2BL,IBA2BC,PBA2BT 8123 9032 FORMAT('IBA2BL,IBA2BC,PBA2BT = ',A4,2X,A4,2X,G15.7) 8124 CALL DPWRST('XXX','BUG ') 8125 WRITE(ICOUT,9033)IBA2FS,IBA2FC,IBA2PT 8126 9033 FORMAT('IBA2FS,IBA2FC,IBA2PT = ',A4,2X,A4,2X,A4) 8127 CALL DPWRST('XXX','BUG ') 8128 WRITE(ICOUT,9034)IBA2PL,IBA2PC,IBA2TY,IBA2DI,PBA2PS,PBA2PT 8129 9034 FORMAT('IBA2PL,IBA2PC,IBA2TY,IBA2DI,PBA2PS,PBA2PT = ', 8130 1 A4,2X,A4,2X,A4,2X,A4,2X,2E15.7) 8131 CALL DPWRST('XXX','BUG ') 8132 WRITE(ICOUT,9044)PXMIN,PXMAX,PYMIN,PYMAX 8133 9044 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4G15.7) 8134 CALL DPWRST('XXX','BUG ') 8135 WRITE(ICOUT,9045)FX1MIN,FX1MAX,FY1MIN,FY1MAX 8136 9045 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4G15.7) 8137 CALL DPWRST('XXX','BUG ') 8138 WRITE(ICOUT,9046)FXMIN,FXMAX,FYMIN,FYMAX 8139 9046 FORMAT('FXMIN,FXMAX,FYMIN,FYMAX= ',4G15.7) 8140 CALL DPWRST('XXX','BUG ') 8141 WRITE(ICOUT,9047)IX1TSC,IY1TSC 8142 9047 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4) 8143 CALL DPWRST('XXX','BUG ') 8144 WRITE(ICOUT,9052)IFIG,IPATT,JPATT 8145 9052 FORMAT('IFIG,IPATT,JPATT = ',A4,2X,A4,I8) 8146 CALL DPWRST('XXX','BUG ') 8147 WRITE(ICOUT,9053)PTHICK,JTHICK,PTHIC2 8148 9053 FORMAT('PTHICK,JTHICK,PTHIC2 = ',G15.7,I8,G15.7) 8149 CALL DPWRST('XXX','BUG ') 8150 WRITE(ICOUT,9054)ICOL,JCOL,IDIR,ITYPE 8151 9054 FORMAT('ICOL,JCOL,IDIR,ITYPE = ',A4,I8,2X,A4,2X,A4) 8152 CALL DPWRST('XXX','BUG ') 8153 WRITE(ICOUT,9069)IBUGG4,ISUBG4,IERRG4 8154 9069 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 8155 CALL DPWRST('XXX','BUG ') 8156 ENDIF 8157C 8158 RETURN 8159 END 8160 SUBROUTINE DPDRCH(Y,X,PY,PX,NP,PY2,PX2,NP2,X3D, 8161 1 ICASPL,ICAS3D,ISORSW,ARE2BA, 8162 1 ICH2PA,ICH2FO,ICH2CA,ICH2JU,ICH2DI, 8163 1 ACH2AN,ICH2FI,ICH2CO,ICH2TY, 8164 1 PCH2HE,PCH2WI,PCH2TH,PCH2HO,PCH2VO, 8165 1 ITEXSP, 8166 1 PXMIN,PXMAX,PYMIN,PYMAX, 8167 1 FX1MIN,FX1MAX,FY1MIN,FY1MAX, 8168 1 IX1TSC,IY1TSC, 8169 1 IMPSW2,AMPSCH,AMPSCW) 8170C 8171C PURPOSE--FOR A GENERAL GRAPHICS DEVICE, DRAW A CHARACTER TRACE OF 8172C Y(.) VERSUS X(.), THAT IS, DRAW A SPECIFIED MARKER 8173C (= CHARACTER) TYPE AT EACH OF THE PLOT POINTS. 8174C NOTE--THE VARIABLES PY(.) AND PX(.) ARE DUMMY VARIABLES WHICH ARE 8175C USED IN THE INTERMEDIATE CALCULATIONS AND WHOSE DIMENSIONS 8176C ARE DEFINED (FOR EASY OF CHANGE) BACK IN THE MAIN ROUTINE. 8177C 8178C WRITTEN BY--JAMES J. FILLIBEN 8179C STATISTICAL ENGINEERING DIVISION 8180C INFORMATION TECHNOLOGY LABORATORY 8181C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 8182C GAITHERSBURG, MD 20899-8980 8183C PHONE--301-975-2855 8184C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 8185C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 8186C LANGUAGE--ANSI FORTRAN (1977) 8187C VERSION NUMBER--83.6 8188C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. 8189C UPDATED --DECEMBER 1987. INDEPENDENT CONTROL OF CHAR WIDTH. 8190C UPDATED --SEPTEMBER 1988. LOG/WEIBULL CHECK AS A SUBROUTINE 8191C UPDATED --SEPTEMBER 1988. RENUMBER 8192C UPDATED --SEPTEMBER 1988. IBUGG4 FOR IBUGPL 8193C UPDATED --JUNE 1990. NORMAL PLOT 8194C UPDATED --MAY 1992. ADD ARE2BA AS INPUT ARGUMENT 8195C UPDATED --DECEMBER 1996. SIMPLIFY NORMAL PLOT 8196C UPDATED --SEPTEMBER 1999. ARGUMENT LIST TO DPCLCH 8197C UPDATED --JANUARY 2000. ADD X3D TO ARGUEMNT LIST 8198C UPDATED --DECEMBER 2006. SUPPORT FOR TRILINEAR PLOTS 8199C UPDATED --JANUARY 2018. ICH2TY - SPECIFY WHETHER 8200C CHARACTER COORDINATES ARE IN 8201C SCREEN UNITS OR DATA UNITS 8202C 8203C-----NON-COMMON VARIABLES (GRAPHICS)----------------------------------- 8204C 8205 CHARACTER*4 ICASPL 8206 CHARACTER*4 ICAS3D 8207 CHARACTER*4 ISORSW 8208C 8209CCCCC CHARACTER*4 ICH2PA 8210 CHARACTER*24 ICH2PA 8211 CHARACTER*4 ICH2FO 8212 CHARACTER*4 ICH2CA 8213 CHARACTER*4 ICH2JU 8214 CHARACTER*4 ICH2DI 8215 CHARACTER*4 ICH2FI 8216 CHARACTER*4 ICH2CO 8217 CHARACTER*4 ICH2TY 8218C 8219 CHARACTER*4 ITEXSP 8220 CHARACTER*4 IX1TSC 8221 CHARACTER*4 IY1TSC 8222C 8223 CHARACTER*4 IFIG 8224 CHARACTER*24 IPATT 8225 CHARACTER*4 IFONT 8226 CHARACTER*4 ICASE 8227 CHARACTER*4 IJUST 8228 CHARACTER*4 IDIR 8229 CHARACTER*4 IFILL 8230 CHARACTER*4 ICOL 8231C 8232 CHARACTER*24 ISYMBL 8233 CHARACTER*4 ISPAC 8234 CHARACTER*4 IMPSW2 8235C 8236 CHARACTER*4 ICASAX 8237C 8238 DIMENSION Y(*) 8239 DIMENSION X(*) 8240 DIMENSION X3D(*) 8241 DIMENSION PY(*) 8242 DIMENSION PX(*) 8243 DIMENSION PY2(*) 8244 DIMENSION PX2(*) 8245C 8246C-----COMMON---------------------------------------------------------- 8247C 8248 INCLUDE 'DPCOGR.INC' 8249 INCLUDE 'DPCOBE.INC' 8250 INCLUDE 'DPCOP2.INC' 8251C 8252C-----START POINT----------------------------------------------------- 8253C 8254 FXMIN=FX1MIN 8255 FXMAX=FX1MAX 8256 FYMIN=FY1MIN 8257 FYMAX=FY1MAX 8258C 8259 PXMINS=PXMIN 8260 PXMAXS=PXMAX 8261 PYMINS=PYMIN 8262 PYMAXS=PYMAX 8263C 8264 AHUNDR=100.0 8265C 8266 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRCH')THEN 8267 WRITE(ICOUT,999) 8268 999 FORMAT(1X) 8269 CALL DPWRST('XXX','BUG ') 8270 WRITE(ICOUT,51) 8271 51 FORMAT('***** AT THE BEGINNING OF DPDRCH--') 8272 CALL DPWRST('XXX','BUG ') 8273 WRITE(ICOUT,53)ICASPL,ICAS3D,NP 8274 53 FORMAT('ICASPL,ICAS3D,NP = ',2(A4,2X),I8) 8275 CALL DPWRST('XXX','BUG ') 8276 IF(NP.GT.3)THEN 8277 DO65I=1,3 8278 WRITE(ICOUT,66)I,X(I),Y(I),X3D(I) 8279 66 FORMAT('I,X(I),Y(I),X3D(I) = ',I8,3G15.7) 8280 CALL DPWRST('XXX','BUG ') 8281 65 CONTINUE 8282 NPM2=NP-2 8283 DO67I=NPM2,NP 8284 WRITE(ICOUT,68)I,X(I),Y(I),X3D(I) 8285 68 FORMAT('I,X(I),Y(I) = ',I8,3G15.7) 8286 CALL DPWRST('XXX','BUG ') 8287 67 CONTINUE 8288 ENDIF 8289 WRITE(ICOUT,70)ISORSW,ARE2BA 8290 70 FORMAT('ISORSW,ARE2BA = ',A4,2X,G15.7) 8291 CALL DPWRST('XXX','BUG ') 8292 WRITE(ICOUT,74)ICH2PA,ICH2FO,ICH2JU,ICH2DI,ICH2TY 8293 74 FORMAT('ICH2PA,ICH2FO,ICH2JU,ICH2DI,ICH2TY = ',A24,4(A4,1X)) 8294 CALL DPWRST('XXX','BUG ') 8295 WRITE(ICOUT,79)ICH2FI,ICH2CO,ITEXSP,IX1TSC,IY1TSC 8296 79 FORMAT('ICH2FI,ICH2CO,ITEXSP,IX1TSC,IY1TSC = ',4(A4,2X),A4) 8297 CALL DPWRST('XXX','BUG ') 8298 WRITE(ICOUT,78)ACH2AN,PCH2HE,PCH2WI 8299 78 FORMAT('ACH2AN,PCH2HE,PCH2WI = ',3G15.7) 8300 CALL DPWRST('XXX','BUG ') 8301 WRITE(ICOUT,83)PCH2TH,PCH2VO,PCH2HO 8302 83 FORMAT('PCH2TH,PCH2VO,PCH2HO= ',3G15.7) 8303 CALL DPWRST('XXX','BUG ') 8304 WRITE(ICOUT,85)PXMIN,PXMAX,PYMIN,PYMAX 8305 85 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4G15.7) 8306 CALL DPWRST('XXX','BUG ') 8307 WRITE(ICOUT,86)FX1MIN,FX1MAX,FY1MIN,FY1MAX 8308 86 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4G15.7) 8309 CALL DPWRST('XXX','BUG ') 8310 WRITE(ICOUT,89)IBUGG4,ISUBG4,IERRG4 8311 89 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',2(A4,2X),A4) 8312 CALL DPWRST('XXX','BUG ') 8313 ENDIF 8314C 8315C ************************************************* 8316C ** STEP 10-- ** 8317C ** IF CALLED FOR, SORT THE DATA ** 8318C ** ACCORDING TO THE HORIZONTAL AXIS VARIABLE ** 8319C ************************************************* 8320C 8321 IF(ISORSW.EQ.'OFF' .OR. ICASPL.EQ.'PIEC' .OR. 8322 1 ICASPL.EQ.'ROSE' .OR. ICAS3D.EQ.'ON' .OR. 8323 1 ICASPL.EQ.'TRPL')THEN 8324 DO1160I=1,NP 8325 PX(I)=X(I) 8326 PY(I)=Y(I) 8327 1160 CONTINUE 8328 ELSE 8329 CALL SORTC(X,Y,NP,PX,PY) 8330 ENDIF 8331C 8332C ****************************************************** 8333C ** STEP 21-- ** 8334C ** IF A NON-LINEAR SCALE PLOT IS CALLED FOR, ** 8335C ** CHECK THAT ALL HORIZONTAL AXIS DATA POINTS ** 8336C ** ARE IN VALID RANGE. ** 8337C ** IF A LOG SCALE PLOT IS CALLED FOR, CHECK THAT ** 8338C ** ALL HORIZONTAL AXIS DATA POINTS ARE > 0. IF A ** 8339C ** WEIBULL SCALE PLOT IS CALLED FOR, OR IF A ** 8340C ** NORMAL SCALE PLOT IS CALLED FOR, (JUNE 1990) ** 8341C ** CHECK THAT ALL HORIZ. AXIS DATA POINTS ARE ** 8342C ** STRICTLY > 0 AND STRICTLY < 100 ** 8343C ****************************************************** 8344C 8345 IF(IX1TSC.EQ.'LOG')THEN 8346 ICASAX='2DHO' 8347 CALL CKLOSC(PX,NP,ISORSW,ICASAX,ISUBG4,IBUGG4,IERRG4) 8348 IF(IERRG4.EQ.'YES')GOTO9000 8349 ELSEIF(IX1TSC.EQ.'WEIB' .OR. IX1TSC.EQ.'NORM')THEN 8350 ICASAX='2DHO' 8351 CALL CKPRSC(PX,NP,ISORSW,ICASAX,ISUBG4,IBUGG4,IERRG4) 8352 IF(IERRG4.EQ.'YES')GOTO9000 8353 ENDIF 8354C 8355C ****************************************************** 8356C ** STEP 22-- ** 8357C ** IF A NON-LINEAR SCALE PLOT IS CALLED FOR, CHECK ** 8358C ** THAT ALL VERTICAL AXIS DATA POINTS ARE IN A ** 8359C ** VALID RANGE. IF A LOG SCALE PLOT IS CALLED ** 8360C ** FOR, CHECK THAT ALL VERTICAL AXIS DATA POINTS ** 8361C ** ARE > 0. IF A WEIBULL SCALE PLOT IS CALLED ** 8362C ** FOR, OR IF A NORMAL SCALE PLOT IS CALLED FOR, ** 8363C ** (JUNE 1990) ** 8364C ** CHECK THAT ALL VERTICAL AXIS DATA POINTS ARE ** 8365C ** STRICTLY > 0 AND STRICTLY < 100 ** 8366C ****************************************************** 8367C 8368 IF(IY1TSC.EQ.'LOG')THEN 8369 ICASAX='2DVE' 8370 CALL CKLOSC(PY,NP,ISORSW,ICASAX,ISUBG4,IBUGG4,IERRG4) 8371 IF(IERRG4.EQ.'YES')GOTO9000 8372 ELSEIF(IY1TSC.EQ.'WEIB' .OR. IY1TSC.EQ.'NORM')THEN 8373 ICASAX='2DVE' 8374 CALL CKPRSC(PY,NP,ISORSW,ICASAX,ISUBG4,IBUGG4,IERRG4) 8375 IF(IERRG4.EQ.'YES')GOTO9000 8376 ENDIF 8377C 8378C ****************************************** 8379C ** STEP 41-- ** 8380C ** IF A LOG/WEIBULL/NORMAL SCALE PLOT ** 8381C ** IS CALLED FOR, TRANSFORM THE DATA ** 8382C ****************************************** 8383C 8384 IF(IX1TSC.EQ.'LOG')THEN 8385 DO4115I=1,NP 8386 PX(I)=LOG10(PX(I)) 8387 4115 CONTINUE 8388 ELSEIF(IX1TSC.EQ.'WEIB')THEN 8389 DO4215I=1,NP 8390 PX(I)=LOG(LOG(AHUNDR/(AHUNDR-PX(I)))) 8391 4215 CONTINUE 8392 ELSEIF(IX1TSC.EQ.'NORM')THEN 8393 DO4315I=1,NP 8394 ARG=PX(I)/AHUNDR 8395 CALL NORPPF(ARG,PX(I)) 8396 4315 CONTINUE 8397 ENDIF 8398C 8399 ABASE=ARE2BA 8400 IF(IY1TSC.EQ.'LOG')THEN 8401 DO4125I=1,NP 8402 PY(I)=LOG10(PY(I)) 8403 4125 CONTINUE 8404 ELSEIF(IY1TSC.EQ.'WEIB')THEN 8405 DO4225I=1,NP 8406 PY(I)=LOG(LOG(AHUNDR/(AHUNDR-PY(I)))) 8407 4225 CONTINUE 8408 ELSEIF(IY1TSC.EQ.'NORM')THEN 8409 IF(ABASE.NE.CPUMAX.AND.ABASE.GT.0.0.AND.ABASE.LT.AHUNDR)THEN 8410 ARG=ABASE/AHUNDR 8411 CALL NORPPF(ARG,ABASE2) 8412 ENDIF 8413 IF(ABASE.NE.CPUMAX.AND.ABASE.LE.0.0)ABASE2=0.1 8414 IF(ABASE.NE.CPUMAX.AND.ABASE.GE.AHUNDR)ABASE2=0.1 8415 ABASE=ABASE2 8416 DO4365I=1,NP 8417 ARG=PY(I)/AHUNDR 8418 CALL NORPPF(ARG,PY(I)) 8419 4365 CONTINUE 8420 ENDIF 8421C 8422C ***************************************************** 8423C ** STEP 50-- ** 8424C ** TRANSLATE THE DATA POINTS ** 8425C ** INTO STANDARDIZED (0.0 TO 100.0) COORDINATES. ** 8426C ***************************************************** 8427C 8428C 2018/01: USER HAS OPTION TO SPECIFY COORDINATES ARE ALREADY 8429C IN SCREEN UNITS. NOTE THAT SCREEN UNITS ONLY 8430C APPLY TO LINEAR SCALES. 8431C 8432 FXMIN=FX1MIN 8433 FXMAX=FX1MAX 8434 IF(IX1TSC.EQ.'LOG' .OR. IX1TSC.EQ.'WEIB' .OR. 8435 1 IX1TSC.EQ.'NORM')ICH2TY(1:1)='D' 8436 IF(IX1TSC.EQ.'LOG')THEN 8437 FXMIN=LOG10(FX1MIN) 8438 FXMAX=LOG10(FX1MAX) 8439 ELSEIF(IX1TSC.EQ.'WEIB')THEN 8440 FXMIN=LOG(LOG(AHUNDR/(AHUNDR-FX1MIN))) 8441 FXMAX=LOG(LOG(AHUNDR/(AHUNDR-FX1MAX))) 8442 ELSEIF(IX1TSC.EQ.'NORM')THEN 8443 ARG=FX1MIN/AHUNDR 8444 CALL NORPPF(ARG,FXMIN) 8445 ARG=FX1MAX/AHUNDR 8446 CALL NORPPF(ARG,FXMAX) 8447 ENDIF 8448C 8449 FYMIN=FY1MIN 8450 FYMAX=FY1MAX 8451 IF(IY1TSC.EQ.'LOG' .OR. IY1TSC.EQ.'WEIB' .OR. 8452 1 IY1TSC.EQ.'NORM')ICH2TY(2:2)='D' 8453 IF(IY1TSC.EQ.'LOG')THEN 8454 FYMIN=LOG10(FY1MIN) 8455 FYMAX=LOG10(FY1MAX) 8456 ELSEIF(IY1TSC.EQ.'WEIB')THEN 8457 FYMIN=LOG(LOG(AHUNDR/(AHUNDR-FY1MIN))) 8458 FYMAX=LOG(LOG(AHUNDR/(AHUNDR-FY1MAX))) 8459 ELSEIF(IY1TSC.EQ.'NORM')THEN 8460 ARG=FY1MIN/AHUNDR 8461 CALL NORPPF(ARG,FYMIN) 8462 ARG=FY1MAX/AHUNDR 8463 CALL NORPPF(ARG,FYMAX) 8464 ENDIF 8465C 8466 FXRANG=FXMAX-FXMIN 8467 FYRANG=FYMAX-FYMIN 8468 PXRANG=PXMAX-PXMIN 8469 PYRANG=PYMAX-PYMIN 8470C 8471 IF(ICASPL.EQ.'TRPL')THEN 8472 AK2=SQRT(2.0) 8473 AK6=SQRT(6.0) 8474 PXHALF=(PXMIN+PXMAX)/2.0 8475 PYTHRD=PYMIN + (PYMAX-PYMIN)/3.0 8476C 8477 ASUM=X(1) + Y(1) + X3D(1) 8478C 8479 DO5160I=1,NP 8480 X1K=X(I)/ASUM 8481 X2K=Y(I)/ASUM 8482 X3K=X3D(I)/ASUM 8483 AH=(1.0/AK2)*(X3K-X2K) 8484 AV=(1.0/AK6)*(2.0 - 3.0*X2K - 3.0*X3K) 8485 PX(I)=PXHALF + (PXRANG/(2.0/AK2))*AH 8486 PY(I)=PYTHRD + (PYRANG/(3.0/AK6))*AV 8487 5160 CONTINUE 8488 ELSEIF(ICH2TY(1:1).EQ.'S' .OR. ICH2TY(2:2).EQ.'S')THEN 8489C 8490C FOR SCREEN COORDINATES, CLIP AT (0,100) INSTEAD OF TO 8491C FRAME COORDINATES 8492C 8493 IF(ICH2TY(1:1).EQ.'S')THEN 8494 DO5120I=1,NP 8495 IF(PX(I).LT.0.0)PX(I)=0.0 8496 IF(PX(I).GT.100.0)PX(I)=100.0 8497 5120 CONTINUE 8498 PXMIN=0.0 8499 PXMAX=100.0 8500 ELSE 8501 DO5123I=1,NP 8502 FXRATI=(PX(I)-FXMIN)/FXRANG 8503 PX(I)=PXMIN+FXRATI*PXRANG+PCH2HO 8504 5123 CONTINUE 8505 ENDIF 8506C 8507 IF(ICH2TY(2:2).EQ.'S')THEN 8508 DO5125I=1,NP 8509 IF(PY(I).LT.0.0)PY(I)=0.0 8510 IF(PY(I).GT.100.0)PY(I)=100.0 8511 5125 CONTINUE 8512 PYMIN=0.0 8513 PYMAX=100.0 8514 ELSE 8515 DO5128I=1,NP 8516 FYRATI=(PY(I)-FYMIN)/FYRANG 8517 PY(I)=PYMIN+FYRATI*PYRANG+PCH2VO 8518 5128 CONTINUE 8519 ENDIF 8520 ELSE 8521 DO5100I=1,NP 8522 FXRATI=(PX(I)-FXMIN)/FXRANG 8523 FYRATI=(PY(I)-FYMIN)/FYRANG 8524 PX(I)=PXMIN+FXRATI*PXRANG+PCH2HO 8525 PY(I)=PYMIN+FYRATI*PYRANG+PCH2VO 8526 5100 CONTINUE 8527 ENDIF 8528C 8529C *********************************************** 8530C ** STEP 60-- ** 8531C ** WRITE OUT THE MARKERS (PLOT CHARACTERS) ** 8532C ** AT THE PLOT POINTS ** 8533C *********************************************** 8534C 8535 IFIG='GENE' 8536 IPATT=ICH2PA 8537 IFONT=ICH2FO 8538 ICASE=ICH2CA 8539 IJUST=ICH2JU 8540 IDIR=ICH2DI 8541 ANGLE=ACH2AN 8542 IFILL=ICH2FI 8543 ICOL=ICH2CO 8544 PHEIGH=PCH2HE 8545CCCCC PWIDTH=0.5*PHEIGH 8546CCCCC PWIDTH=PHEIGH*(ANUMVP/ANUMHP) DECEMBER 1987 TEST 8547 PWIDTH=PCH2WI 8548 PVEGAP=PHEIGH/2.0 8549 PHOGAP=PWIDTH/2.0 8550 PTHICK=PCH2TH 8551 ISYMBL=ICH2PA 8552 ISPAC=ITEXSP 8553C 8554CCCCC ADD X3D TO CALL LIST. JANUARY 2000. 8555 CALL DPCLCH(PX,PY,NP,PX2,PY2,NP2,X3D, 8556 1PXMIN,PXMAX,PYMIN,PYMAX, 8557 1ISORSW, 8558 1IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 8559 1PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK, 8560 1IMPSW2,AMPSCH,AMPSCW, 8561 1ISYMBL,ISPAC) 8562C 8563C ***************** 8564C ** STEP 90-- ** 8565C ** EXIT ** 8566C ***************** 8567C 8568 9000 CONTINUE 8569C 8570 PXMIN=PXMINS 8571 PXMAX=PXMAXS 8572 PYMIN=PYMINS 8573 PYMAX=PYMAXS 8574C 8575 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRCH')THEN 8576 WRITE(ICOUT,999) 8577 CALL DPWRST('XXX','BUG ') 8578 WRITE(ICOUT,9011) 8579 9011 FORMAT('***** AT THE END OF DPDRCH--') 8580 CALL DPWRST('XXX','BUG ') 8581 WRITE(ICOUT,9012)NP 8582 9012 FORMAT('NP = ',I8) 8583 CALL DPWRST('XXX','BUG ') 8584 WRITE(ICOUT,9013)ICASPL,ICAS3D 8585 9013 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) 8586 CALL DPWRST('XXX','BUG ') 8587 IF(NP.GE.1)THEN 8588 DO9025I=1,NP 8589 WRITE(ICOUT,9026)I,PX(I),PY(I) 8590 9026 FORMAT('I,PX(I),PY(I) = ',I8,2G15.7) 8591 CALL DPWRST('XXX','BUG ') 8592 9025 CONTINUE 8593 ENDIF 8594 ENDIF 8595C 8596 RETURN 8597 END 8598 SUBROUTINE DPDRFL(PXMIN,PYMIN,PXMAX,PYMAX, 8599 1ICASPL,ICAS3D, 8600 1IX1FSW,IX2FSW,IY1FSW,IY2FSW, 8601 1IX1FPA,IX2FPA,IY1FPA,IY2FPA, 8602 1IX1FCO,IX2FCO,IY1FCO,IY2FCO, 8603 1PFRATH) 8604C PURPOSE--DRAW THE 4 (IF CALLED FOR) FRAME LINES ON THE SCREEN. 8605C WRITTEN BY--JAMES J. FILLIBEN 8606C STATISTICAL ENGINEERING DIVISION 8607C INFORMATION TECHNOLOGY LABORATORY 8608C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 8609C GAITHERSBURG, MD 20899-8980 8610C PHONE--301-975-2855 8611C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 8612C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 8613C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, 8614C MODIFIED, OR OTHERWISE USED IN A CONTEXT 8615C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. 8616C LANGUAGE--ANSI FORTRAN (1977) 8617C VERSION NUMBER--83.6 8618C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. 8619C UPDATED --SEPTEMBER 1987. CALLS TO GRDRPL TO DPDRPL 8620C UPDATED --FEBRUARY 1988. STAR PLOT 8621C UPDATED --JANUARY 1989. MODIFY CALLS TO DPDRPL (ALAN) 8622C UPDATED --DECEMBER 2006. TRILINEAR SCALES 8623C 8624C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- 8625C 8626 CHARACTER*4 ICASPL 8627 CHARACTER*4 ICAS3D 8628C 8629 CHARACTER*4 IX1FSW 8630 CHARACTER*4 IX2FSW 8631 CHARACTER*4 IY1FSW 8632 CHARACTER*4 IY2FSW 8633C 8634 CHARACTER*4 IX1FPA 8635 CHARACTER*4 IX2FPA 8636 CHARACTER*4 IY1FPA 8637 CHARACTER*4 IY2FPA 8638C 8639 CHARACTER*4 IX1FCO 8640 CHARACTER*4 IX2FCO 8641 CHARACTER*4 IY1FCO 8642 CHARACTER*4 IY2FCO 8643C 8644 CHARACTER*4 IFIG 8645 CHARACTER*4 IPATT 8646 CHARACTER*4 ICOL 8647 CHARACTER*4 IFLAG 8648C 8649 DIMENSION PX(10) 8650 DIMENSION PY(10) 8651CCCCC DIMENSION PX3(10) 8652CCCCC DIMENSION PY3(10) 8653C 8654C-----COMMON---------------------------------------------------------- 8655C 8656 INCLUDE 'DPCOGR.INC' 8657 INCLUDE 'DPCOBE.INC' 8658 INCLUDE 'DPCOP2.INC' 8659C 8660C 8661C-----START POINT----------------------------------------------------- 8662C 8663 NP=2 8664C 8665 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRFL')GOTO90 8666 WRITE(ICOUT,999) 8667 999 FORMAT(1X) 8668 CALL DPWRST('XXX','BUG ') 8669 WRITE(ICOUT,51) 8670 51 FORMAT('***** AT THE BEGINNING OF DPDRFL--') 8671 CALL DPWRST('XXX','BUG ') 8672 WRITE(ICOUT,52)PXMIN,PYMIN,PXMAX,PYMAX 8673 52 FORMAT('PXMIN,PYMIN,PXMAX,PYMAX = ',4F10.5) 8674 CALL DPWRST('XXX','BUG ') 8675 WRITE(ICOUT,53)ICASPL,ICAS3D 8676 53 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) 8677 CALL DPWRST('XXX','BUG ') 8678 WRITE(ICOUT,55)IX1FSW,IX2FSW,IY1FSW,IY2FSW 8679 55 FORMAT('IX1FSW,IX2FSW,IY1FSW,IY2FSW = ',A4,2X,A4,2X,A4,2X,A4) 8680 CALL DPWRST('XXX','BUG ') 8681 WRITE(ICOUT,56)IX1FPA,IX2FPA,IY1FPA,IY2FPA 8682 56 FORMAT('IX1FPA,IX2FPA,IY1FPA,IY2FPA = ',A4,2X,A4,2X,A4,2X,A4) 8683 CALL DPWRST('XXX','BUG ') 8684 WRITE(ICOUT,57)IX1FCO,IX2FCO,IY1FCO,IY2FCO 8685 57 FORMAT('IX1FCO,IX2FCO,IY1FCO,IY2FCO = ',A4,2X,A4,2X,A4,2X,A4) 8686 CALL DPWRST('XXX','BUG ') 8687 WRITE(ICOUT,58)PFRATH 8688 58 FORMAT('PFRATH = ',E15.7) 8689 CALL DPWRST('XXX','BUG ') 8690 WRITE(ICOUT,59)IBUGG4,ISUBG4,IERRG4 8691 59 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 8692 CALL DPWRST('XXX','BUG ') 8693 90 CONTINUE 8694C 8695 IF(ICASPL.EQ.'PIEC')GOTO9000 8696 IF(ICASPL.EQ.'ROSE')GOTO9000 8697 IF(ICASPL.EQ.'STAR')GOTO9000 8698 IF(ICAS3D.EQ.'ON')GOTO9000 8699C 8700 IFIG='LINE' 8701 PTHICK=PFRATH 8702C 8703C ************************************** 8704C ** STEP 1-- ** 8705C ** DRAW OUT THE BOTTOM FRAME LINE ** 8706C ** (IF CALLED FOR) ** 8707C ************************************** 8708C 8709 IF(IX1FSW.EQ.'ON')GOTO1100 8710 GOTO1190 8711 1100 CONTINUE 8712 PX(1)=PXMIN 8713 PY(1)=PYMIN 8714 PX(2)=PXMAX 8715 PY(2)=PYMIN 8716 NP=2 8717 IPATT=IX1FPA 8718 ICOL=IX1FCO 8719 IFLAG='ON' 8720CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3, 8721CCCCC1IFIG,IPATT,PTHICK,ICOL) 8722 CALL DPDRPL(PX,PY,NP, 8723 1IFIG,IPATT,PTHICK,ICOL, 8724 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 8725 1190 CONTINUE 8726C 8727C ************************************* 8728C ** STEP 2-- ** 8729C ** DRAW OUT THE RIGHT FRAME LINE ** 8730C ** (IF CALLED FOR) ** 8731C ************************************* 8732C 8733 IF(IY2FSW.EQ.'ON')GOTO1200 8734 GOTO1290 8735 1200 CONTINUE 8736 IF(ICASPL.EQ.'TRPL')THEN 8737 PX(1)=PXMAX 8738 PY(1)=PYMIN 8739 PX(2)=(PXMIN+PXMAX)/2.0 8740 PY(2)=PYMAX 8741 ELSE 8742 PX(1)=PXMAX 8743 PY(1)=PYMIN 8744 PX(2)=PXMAX 8745 PY(2)=PYMAX 8746 ENDIF 8747 NP=2 8748 IPATT=IY2FPA 8749 ICOL=IY2FCO 8750 IFLAG='ON' 8751CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3, 8752CCCCC1IFIG,IPATT,PTHICK,ICOL) 8753 CALL DPDRPL(PX,PY,NP, 8754 1IFIG,IPATT,PTHICK,ICOL, 8755 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 8756 1290 CONTINUE 8757C 8758C *********************************** 8759C ** STEP 3-- ** 8760C ** DRAW OUT THE TOP FRAME LINE ** 8761C ** (IF CALLED FOR) ** 8762C *********************************** 8763C 8764 IF(IX2FSW.EQ.'ON')GOTO1300 8765 GOTO1390 8766 1300 CONTINUE 8767 IF(ICASPL.EQ.'TRPL')GOTO1390 8768 PX(1)=PXMAX 8769 PY(1)=PYMAX 8770 PX(2)=PXMIN 8771 PY(2)=PYMAX 8772 NP=2 8773 IPATT=IX2FPA 8774 ICOL=IX2FCO 8775 IFLAG='ON' 8776CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3, 8777CCCCC1IFIG,IPATT,PTHICK,ICOL) 8778 CALL DPDRPL(PX,PY,NP, 8779 1IFIG,IPATT,PTHICK,ICOL, 8780 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 8781 1390 CONTINUE 8782C 8783C ************************************* 8784C ** STEP 4-- ** 8785C ** DRAW OUT THE LEFT FRAME LINE ** 8786C ** (IF CALLED FOR) ** 8787C ************************************* 8788C 8789 IF(IY1FSW.EQ.'ON')GOTO1400 8790 GOTO1490 8791 1400 CONTINUE 8792 IF(ICASPL.EQ.'TRPL')THEN 8793 PX(1)=PXMIN 8794 PY(1)=PYMIN 8795 PX(2)=(PXMAX+PXMIN)/2.0 8796 PY(2)=PYMAX 8797 ELSE 8798 PX(1)=PXMIN 8799 PY(1)=PYMAX 8800 PX(2)=PXMIN 8801 PY(2)=PYMIN 8802 ENDIF 8803 NP=2 8804 IPATT=IY1FPA 8805 ICOL=IY1FCO 8806 IFLAG='ON' 8807CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3, 8808CCCCC1IFIG,IPATT,PTHICK,ICOL) 8809 CALL DPDRPL(PX,PY,NP, 8810 1IFIG,IPATT,PTHICK,ICOL, 8811 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 8812 1490 CONTINUE 8813C 8814C ***************** 8815C ** STEP 90-- ** 8816C ** EXIT ** 8817C ***************** 8818C 8819 9000 CONTINUE 8820 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRFL')GOTO9090 8821 WRITE(ICOUT,999) 8822 CALL DPWRST('XXX','BUG ') 8823 WRITE(ICOUT,9011) 8824 9011 FORMAT('***** AT THE END OF DPDRFL--') 8825 CALL DPWRST('XXX','BUG ') 8826 WRITE(ICOUT,9012)PXMIN,PYMIN,PXMAX,PYMAX 8827 9012 FORMAT('PXMIN,PYMIN,PXMAX,PYMAX = ',4F10.5) 8828 CALL DPWRST('XXX','BUG ') 8829 WRITE(ICOUT,9013)ICASPL,ICAS3D 8830 9013 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) 8831 CALL DPWRST('XXX','BUG ') 8832 WRITE(ICOUT,9015)IX1FSW,IX2FSW,IY1FSW,IY2FSW 8833 9015 FORMAT('IX1FSW,IX2FSW,IY1FSW,IY2FSW = ',A4,2X,A4,2X,A4,2X,A4) 8834 CALL DPWRST('XXX','BUG ') 8835 WRITE(ICOUT,9016)IX1FPA,IX2FPA,IY1FPA,IY2FPA 8836 9016 FORMAT('IX1FPA,IX2FPA,IY1FPA,IY2FPA = ',A4,2X,A4,2X,A4,2X,A4) 8837 CALL DPWRST('XXX','BUG ') 8838 WRITE(ICOUT,9017)IX1FCO,IX2FCO,IY1FCO,IY2FCO 8839 9017 FORMAT('IX1FCO,IX2FCO,IY1FCO,IY2FCO = ',A4,2X,A4,2X,A4,2X,A4) 8840 CALL DPWRST('XXX','BUG ') 8841 WRITE(ICOUT,9018)PFRATH 8842 9018 FORMAT('PFRATH = ',E15.7) 8843 CALL DPWRST('XXX','BUG ') 8844 WRITE(ICOUT,9025)NP 8845 9025 FORMAT('NP = ',I8) 8846 CALL DPWRST('XXX','BUG ') 8847 DO9026I=1,NP 8848 WRITE(ICOUT,9027)PX(I),PY(I) 8849 9027 FORMAT('PX(I),PY(I) = ',E15.7,E15.7) 8850 CALL DPWRST('XXX','BUG ') 8851 9026 CONTINUE 8852 WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4 8853 9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 8854 CALL DPWRST('XXX','BUG ') 8855 9090 CONTINUE 8856C 8857 RETURN 8858 END 8859 SUBROUTINE DPDRFR(ICASPL,ICAS3D, 8860 1IVGMSW,IHGMSW) 8861C 8862C PURPOSE--DRAW FRAME LINES (ALONG WITH TIC MARKS, 8863C TIC MARK LABELS, AND GRID LINES 8864C FOR A PLOT. 8865C 8866C WRITTEN BY--JAMES J. FILLIBEN 8867C STATISTICAL ENGINEERING DIVISION 8868C INFORMATION TECHNOLOGY LABORATORY 8869C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 8870C GAITHERSBURG, MD 20899-8980 8871C PHONE--301-975-2855 8872C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 8873C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 8874C LANGUAGE--ANSI FORTRAN (1977) 8875C VERSION NUMBER--83.6 8876C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. 8877C MODIFIED --MAY 1990. ADD OFFSET ARGUMENTS TO DPDRGL 8878C MODIFIED --DECEMBER 2006. SUPPORT FOR TRI-LINEAR SCALES 8879C 8880C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- 8881C 8882 CHARACTER*4 ICASPL 8883 CHARACTER*4 ICAS3D 8884C 8885 CHARACTER*4 IVGMSW 8886 CHARACTER*4 IHGMSW 8887C 8888C-----COMMON---------------------------------------------------------- 8889C 8890 INCLUDE 'DPCOPA.INC' 8891 INCLUDE 'DPCOPC.INC' 8892 INCLUDE 'DPCOGR.INC' 8893 INCLUDE 'DPCOBE.INC' 8894 INCLUDE 'DPCOP2.INC' 8895C 8896C-----START POINT----------------------------------------------------- 8897C 8898C 8899 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRFR')GOTO90 8900 WRITE(ICOUT,999) 8901 999 FORMAT(1X) 8902 CALL DPWRST('XXX','BUG ') 8903 WRITE(ICOUT,51) 8904 51 FORMAT('***** AT THE BEGINNING OF DPDRFR--') 8905 CALL DPWRST('XXX','BUG ') 8906 WRITE(ICOUT,52)IMANUF,IMODEL 8907 52 FORMAT('IMANUF,IMODEL = ',A4,2X,A4) 8908 CALL DPWRST('XXX','BUG ') 8909 WRITE(ICOUT,53)ICASPL,ICAS3D 8910 53 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) 8911 CALL DPWRST('XXX','BUG ') 8912 WRITE(ICOUT,55)IBUGG4,ISUBG4,IERRG4 8913 55 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 8914 CALL DPWRST('XXX','BUG ') 8915 90 CONTINUE 8916C 8917C ******************************* 8918C ** STEP 1-- ** 8919C ** FILL THE MARGIN REGION ** 8920C ******************************* 8921C 8922 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRFR')THEN 8923 WRITE(ICOUT,8001) 8924 8001 FORMAT('BEFORE CALL DPFIMA') 8925 CALL DPWRST('XXX','BUG ') 8926 ENDIF 8927C 8928 IF(IERASW.EQ.'ON'.AND.IMARCO.NE.IBACCO) 8929 1CALL DPFIMA(PXMIN,PYMIN,PXMAX,PYMAX, 8930 1ICASPL,ICAS3D, 8931 1IMARCO) 8932C 8933C **************************** 8934C ** STEP 2-- ** 8935C ** DRAW THE FRAME LINES ** 8936C **************************** 8937C 8938 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRFR')THEN 8939 WRITE(ICOUT,8002) 8940 8002 FORMAT('BEFORE CALL DPDRFL') 8941 CALL DPWRST('XXX','BUG ') 8942 ENDIF 8943C 8944 CALL DPDRFL(PXMIN,PYMIN,PXMAX,PYMAX, 8945 1ICASPL,ICAS3D, 8946 1IX1FSW,IX2FSW,IY1FSW,IY2FSW, 8947 1IX1FPA,IX2FPA,IY1FPA,IY2FPA, 8948 1IX1FCO,IX2FCO,IY1FCO,IY2FCO, 8949 1PFRATH) 8950C 8951C ************************** 8952C ** STEP 3-- ** 8953C ** DRAW THE TIC MARKS ** 8954C ************************** 8955C 8956 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRFR')THEN 8957 WRITE(ICOUT,8003) 8958 8003 FORMAT('BEFORE CALL DPDRTM') 8959 CALL DPWRST('XXX','BUG ') 8960 ENDIF 8961C 8962 CALL DPDRTM(PXMIN,PYMIN,PXMAX,PYMAX, 8963 1FX1MIN,FY1MIN,FX1MAX,FY1MAX, 8964 1ICASPL,ICAS3D, 8965 1IX1FSW,IX2FSW,IY1FSW,IY2FSW, 8966 1IX1TSW,IX2TSW,IY1TSW,IY2TSW, 8967 1PX1COO,PX2COO,PY1COO,PY2COO, 8968 1NX1COO,NX2COO,NY1COO,NY2COO, 8969 1PX1CMN,PX2CMN,PY1CMN,PY2CMN, 8970 1NX1CMN,NX2CMN,NY1CMN,NY2CMN, 8971 1PX1TLE,PX2TLE,PY1TLE,PY2TLE, 8972 1PTICTH,PMNTFA, 8973 1IX1TJU,IX2TJU,IY1TJU,IY2TJU, 8974 1IX1TCO,IX2TCO,IY1TCO,IY2TCO) 8975C 8976C ************************************* 8977C ** STEP 4-- ** 8978C ** WRITE OUT THE TIC MARK LABELS ** 8979C ************************************* 8980C 8981 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRFR')THEN 8982 WRITE(ICOUT,8004) 8983 8004 FORMAT('BEFORE CALL DPWRTL') 8984 CALL DPWRST('XXX','BUG ') 8985 ENDIF 8986C 8987 CALL DPWRTL(ICASPL,ICAS3D) 8988C 8989C *************************** 8990C ** STEP 5-- ** 8991C ** DRAW THE GRID LINES ** 8992C *************************** 8993C 8994 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRFR')THEN 8995 WRITE(ICOUT,8005) 8996 8005 FORMAT('BEFORE CALL DPDRGL') 8997 CALL DPWRST('XXX','BUG ') 8998 ENDIF 8999C 9000 CALL DPDRGL(PXMIN,PYMIN,PXMAX,PYMAX, 9001 1FX1MIN,FY1MIN,FX1MAX,FY1MAX, 9002 1ICASPL,ICAS3D, 9003 1IVGRSW,IHGRSW, 9004 1IVGMSW,IHGMSW, 9005 1PX1COO,PX2COO,PY1COO,PY2COO, 9006 1X1COOR,X2COOR,Y1COOR,Y2COOR, 9007 1NX1COO,NX2COO,NY1COO,NY2COO, 9008 1PX1CMN,PX2CMN,PY1CMN,PY2CMN, 9009 1X1COMN,X2COMN,Y1COMN,Y2COMN, 9010 1NX1CMN,NX2CMN,NY1CMN,NY2CMN, 9011 1IVGRPA,IHGRPA,IVGRCO,IHGRCO, 9012 1PVGRTH,PHGRTH, 9013 1PX1TOL,PX1TOR,PY1TOB,PY1TOT) 9014CCCC ABOVE LINE ADDED MAY, 1990 (FOR TIC OFFSETS) 9015C 9016C ***************** 9017C ** STEP 90-- ** 9018C ** EXIT ** 9019C ***************** 9020C 9021 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRFR')GOTO9090 9022 WRITE(ICOUT,999) 9023 CALL DPWRST('XXX','BUG ') 9024 WRITE(ICOUT,9011) 9025 9011 FORMAT('***** AT THE END OF DPDRFR--') 9026 CALL DPWRST('XXX','BUG ') 9027 WRITE(ICOUT,9012)IMANUF,IMODEL 9028 9012 FORMAT('IMANUF,IMODEL = ',A4,2X,A4) 9029 CALL DPWRST('XXX','BUG ') 9030 WRITE(ICOUT,9013)ICASPL,ICAS3D 9031 9013 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) 9032 CALL DPWRST('XXX','BUG ') 9033 WRITE(ICOUT,9015)IBUGG4,ISUBG4,IERRG4 9034 9015 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 9035 CALL DPWRST('XXX','BUG ') 9036 9090 CONTINUE 9037C 9038 RETURN 9039 END 9040 SUBROUTINE DPDRGL(PXMIN,PYMIN,PXMAX,PYMAX, 9041 1 FXMIN,FYMIN,FXMAX,FYMAX, 9042 1 ICASPL,ICAS3D, 9043 1 IVGRSW,IHGRSW, 9044 1 IVGMSW,IHGMSW, 9045 1 PX1COO,PX2COO,PY1COO,PY2COO, 9046 1 X1COOR,X2COOR,Y1COOR,Y2COOR, 9047 1 NX1COO,NX2COO,NY1COO,NY2COO, 9048 1 PX1CMN,PX2CMN,PY1CMN,PY2CMN, 9049 1 X1COMN,X2COMN,Y1COMN,Y2COMN, 9050 1 NX1CMN,NX2CMN,NY1CMN,NY2CMN, 9051 1 IVGRPA,IHGRPA,IVGRCO,IHGRCO, 9052 1 PVGRTH,PHGRTH, 9053 1 PX1TOL,PX1TOR,PY1TOB,PY1TOT) 9054C 9055C PURPOSE--DRAW GRID LINES ON A PLOT 9056C FOR A GENERAL GRAPHICS DEVICE. 9057C 9058C WRITTEN BY--JAMES J. FILLIBEN 9059C STATISTICAL ENGINEERING DIVISION 9060C INFORMATION TECHNOLOGY LABORATORY 9061C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 9062C GAITHERSBURG, MD 20899-8980 9063C PHONE--301-975-2855 9064C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 9065C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 9066C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, 9067C MODIFIED, OR OTHERWISE USED IN A CONTEXT 9068C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. 9069C LANGUAGE--ANSI FORTRAN (1977) 9070C VERSION NUMBER--83.6 9071C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. 9072C UPDATED --SEPTEMBER 1987. GRDRPL TO DPDRPL 9073C UPDATED --FEBRUARY 1988. STAR PLOT 9074C UPDATED --MAY 1990. TIC OFFSETS 9075C UPDATED --SEPTEMBER 1990. MISSING HORIZ. GRID LINES 9076C UPDATED --DECEMBER 2006. SUPPORT FOR TRILINEAR PLOTS 9077C 9078C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- 9079C 9080 CHARACTER*4 ICASPL 9081 CHARACTER*4 ICAS3D 9082C 9083 CHARACTER*4 IVGRSW 9084 CHARACTER*4 IHGRSW 9085 CHARACTER*4 IVGMSW 9086 CHARACTER*4 IHGMSW 9087 CHARACTER*4 IVGRPA 9088 CHARACTER*4 IHGRPA 9089 CHARACTER*4 IVGRCO 9090 CHARACTER*4 IHGRCO 9091C 9092 CHARACTER*4 ITYPE 9093 CHARACTER*4 IFIG 9094 CHARACTER*4 IPATT 9095 CHARACTER*4 ICOL 9096CCCCC CHARACTER*4 IHORPA 9097CCCCC CHARACTER*4 IVERPA 9098CCCCC CHARACTER*4 IDUPPA 9099CCCCC CHARACTER*4 IDDOPA 9100 CHARACTER*4 IFLAG 9101C 9102 DIMENSION PX1COO(*) 9103 DIMENSION PX2COO(*) 9104 DIMENSION PY1COO(*) 9105 DIMENSION PY2COO(*) 9106C 9107 DIMENSION X1COOR(*) 9108 DIMENSION X2COOR(*) 9109 DIMENSION Y1COOR(*) 9110 DIMENSION Y2COOR(*) 9111C 9112 DIMENSION PX1CMN(*) 9113 DIMENSION PX2CMN(*) 9114 DIMENSION PY1CMN(*) 9115 DIMENSION PY2CMN(*) 9116C 9117 DIMENSION X1COMN(*) 9118 DIMENSION X2COMN(*) 9119 DIMENSION Y1COMN(*) 9120 DIMENSION Y2COMN(*) 9121C 9122 DIMENSION PX(100) 9123 DIMENSION PY(100) 9124C 9125C-----COMMON---------------------------------------------------------- 9126C 9127 INCLUDE 'DPCOGR.INC' 9128 INCLUDE 'DPCOBE.INC' 9129 INCLUDE 'DPCOP2.INC' 9130C 9131C-----START POINT----------------------------------------------------- 9132C 9133 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRGL')THEN 9134 WRITE(ICOUT,999) 9135 999 FORMAT(1X) 9136 CALL DPWRST('XXX','BUG ') 9137 WRITE(ICOUT,51) 9138 51 FORMAT('***** AT THE BEGINNING OF DPDRGL--') 9139 CALL DPWRST('XXX','BUG ') 9140 WRITE(ICOUT,52)PXMIN,PYMIN,PXMAX,PYMAX 9141 52 FORMAT('PXMIN,PYMIN,PXMAX,PYMAX = ',4F10.5) 9142 CALL DPWRST('XXX','BUG ') 9143 WRITE(ICOUT,42)FXMIN,FYMIN,FXMAX,FYMAX 9144 42 FORMAT('FXMIN,FYMIN,FXMAX,FYMAX = ',4F10.5) 9145 CALL DPWRST('XXX','BUG ') 9146 DO43I=1,100 9147 WRITE(ICOUT,44)I,PX1CMN(I),PX2CMN(I),PY1CMN(I),PY2CMN(I) 9148 44 FORMAT('I,PX1CMN(I),PX2CMN(I),PY1CMN(I),PY2CMN(I) = ',4F10.5) 9149 CALL DPWRST('XXX','BUG ') 9150 43 CONTINUE 9151 DO45I=1,100 9152 WRITE(ICOUT,46)I,X1COMN(I),X2COMN(I),Y1COMN(I),Y2COMN(I) 9153 46 FORMAT('X1COMN(I),X2COMN(I),Y1COMN(I),Y2COMNI) = ', 9154 1 3(A4,2X),A4) 9155 CALL DPWRST('XXX','BUG ') 9156 45 CONTINUE 9157 WRITE(ICOUT,53)ICASPL,ICAS3D,IBUGG4,ISUBG4,IERRG4 9158 53 FORMAT('ICASPL,ICAS3D,IBUGG4,ISUBG4,IERRG4 = ',4(A4,2X),A4) 9159 CALL DPWRST('XXX','BUG ') 9160 WRITE(ICOUT,54)IVGRSW,IHGRSW,IVGMSW,IHGMSW 9161 54 FORMAT('IVGRSW,IHGRSW,IVGMSW,IHGMSW = ',3(A4,2X),A4) 9162 CALL DPWRST('XXX','BUG ') 9163 WRITE(ICOUT,55)IVGRPA,IHGRPA,PVGRTH,PHGRTH 9164 55 FORMAT('IVGRPA,IHGRPA,PVGRTH,PHGRTH = ',2(A4,2X),2G15.7) 9165 CALL DPWRST('XXX','BUG ') 9166 WRITE(ICOUT,57)IVGRCO,IHGRCO 9167 57 FORMAT('IVGRCO,IHGRCO = ',A4,2X,A4) 9168 CALL DPWRST('XXX','BUG ') 9169 WRITE(ICOUT,58)NX1CMN,NX2CMN,NY1CMN,NY2CMN 9170 58 FORMAT('NX1CMN,NX2CMN,NY1CMN,NY2CMN = ',4I8) 9171 CALL DPWRST('XXX','BUG ') 9172 WRITE(ICOUT,60)NX1COO,NX2COO,NY1COO,NY2COO 9173 60 FORMAT('NX1COO,NX2COO,NY1COO,NY2COO = ',4I8) 9174 CALL DPWRST('XXX','BUG ') 9175C 9176 IF(NX1COO.GT.0)THEN 9177 WRITE(ICOUT,999) 9178 CALL DPWRST('XXX','BUG ') 9179 DO61I=1,NX1COO 9180 WRITE(ICOUT,62)I,PX1COO(I),X1COOR(I) 9181 62 FORMAT('I,PX1COO(I),X1COOR(I) = ',I8,2E15.7) 9182 CALL DPWRST('XXX','BUG ') 9183 61 CONTINUE 9184 ENDIF 9185C 9186 IF(NX2COO.GT.0)THEN 9187 WRITE(ICOUT,999) 9188 CALL DPWRST('XXX','BUG ') 9189 DO71I=1,NX2COO 9190 WRITE(ICOUT,72)I,PX2COO(I),X2COOR(I) 9191 72 FORMAT('I,PX2COO(I),X2COOR(I) = ',I8,2E15.7) 9192 CALL DPWRST('XXX','BUG ') 9193 71 CONTINUE 9194 ENDIF 9195C 9196 IF(NY1COO.GT.0)THEN 9197 WRITE(ICOUT,999) 9198 CALL DPWRST('XXX','BUG ') 9199 DO81I=1,NY1COO 9200 WRITE(ICOUT,82)I,PY1COO(I),Y1COOR(I) 9201 82 FORMAT('I,PY1COO(I),Y1COOR(I) = ',I8,2E15.7) 9202 CALL DPWRST('XXX','BUG ') 9203 81 CONTINUE 9204 ENDIF 9205C 9206 IF(NY2COO.GT.0)THEN 9207 WRITE(ICOUT,999) 9208 CALL DPWRST('XXX','BUG ') 9209 DO91I=1,NY2COO 9210 WRITE(ICOUT,92)I,PY2COO(I),Y2COOR(I) 9211 92 FORMAT('I,PY2COO(I),Y2COOR(I) = ',I8,2E15.7) 9212 CALL DPWRST('XXX','BUG ') 9213 91 CONTINUE 9214 ENDIF 9215C 9216 ENDIF 9217C 9218 IF(ICASPL.EQ.'PIEC')GOTO9000 9219 IF(ICASPL.EQ.'ROSE')GOTO9000 9220 IF(ICASPL.EQ.'STAR')GOTO9000 9221 IF(ICAS3D.EQ.'ON')GOTO9000 9222 IF(ICASPL.EQ.'TRPL')GOTO2000 9223C 9224 ITYPE='LINE' 9225C 9226C *************************************************** 9227C ** STEP 1-- ** 9228C ** TRANSLATE THE VERTICAL GRID LINE LINE PATTERN ** 9229C ** INTO A NUMBER WHICH CAN BE UNDERSTOOD ** 9230C ** BY THE GRAPHICS DEVICE. ** 9231C *************************************************** 9232C 9233 IPATT=IVGRPA 9234CCCCC CALL GRTRPA(ITYPE,IPATT,PXSPA,PYSPA, 9235CCCCC1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) 9236C 9237C ********************************** 9238C ** STEP 2-- ** 9239C ** SET THE LINE PATTERN TO SOLID ** 9240C ** ON THE GRAPHICS DEVICE. ** 9241C ********************************** 9242C 9243CCCCC CALL GRSEPA(ITYPE,IPATT,PXSPA,PYSPA, 9244CCCCC1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) 9245C 9246C ********************************************** 9247C ** STEP 3-- ** 9248C ** TRANSLATE THE CHARACTER REPRESENTATION ** 9249C ** OF THE VERTICAL GRID LINE COLOR 9250C ** INTO A NUMERIC REPRESENTATION ** 9251C ** WHICH CAN BE UNDERSTOOD BY THE ** 9252C ** GRAPHICS DEVICE. ** 9253C ********************************************** 9254C 9255 ICOL=IVGRCO 9256CCCCC CALL GRTRCO(ITYPE,ICOL,JCOL) 9257C 9258C ******************************* 9259C ** STEP 4-- ** 9260C ** SET THE COLOR ** 9261C ** ON THE GRAPHICS DEVICE. ** 9262C ******************************* 9263C 9264CCCCC CALL GRSECO(ITYPE,ICOL,JCOL) 9265C 9266C ********************************************** 9267C ** STEP 5-- ** 9268C ** TRANSLATE THE CHARACTER REPRESENTATION ** 9269C ** OF THE VERTICAL GRID LINE THICKNESS ** 9270C ** INTO A NUMERIC REPRESENTATION ** 9271C ** WHICH CAN BE UNDERSTOOD BY THE ** 9272C ** GRAPHICS DEVICE. ** 9273C ********************************************** 9274C 9275 PTHICK=PVGRTH 9276CCCCC CALL GRTRTH(ITYPE,PTHICK,JTHICK,PTHIC2) 9277C 9278C ******************************* 9279C ** STEP 6-- ** 9280C ** SET THE LINE THICKNESS ** 9281C ** ON THE GRAPHICS DEVICE. ** 9282C ******************************* 9283C 9284CCCCC CALL GRSETH(ITYPE,PTHICK,JTHICK,PTHIC2) 9285C 9286C ********************************** 9287C ** STEP 7-- ** 9288C ** DRAW VERTICAL GRID LINES ** 9289C ********************************** 9290C 9291 IFIG='LINE' 9292 PY(1)=PYMIN 9293 PY(2)=PYMAX 9294C 9295 IF(IVGRSW.EQ.'OFF')GOTO1140 9296 IF(NX1COO.LE.2)GOTO1140 9297CCCCC MAY, 1990. IF TIC OFFSETS ARE NON-ZER0, DRAW THE FIRST AND 9298CCCCC LAST GRID LINES (WHICH PREVIOUSLY WOULD ALWAYS BE ON THE FRAME. 9299 EPS=0.000001 9300 IMIN=2 9301 IF(ABS(PX1TOL).GE.EPS)IMIN=1 9302 IMAX=NX1COO-1 9303 IF(ABS(PX1TOR).GE.EPS)IMAX=NX1COO 9304 NP=2 9305CCCCC IMAX=NX1COO-1 9306 IFLAG='ON' 9307CCCCC DO1110I=2,IMAX 9308 DO1110I=IMIN,IMAX 9309 PX(1)=PX1COO(I) 9310 PX(2)=PX1COO(I) 9311CCCCC CALL GRDRPL(PX,PY,NP, 9312CCCCC1IFIG,IPATT,PTHICK,ICOL, 9313CCCCC1JPATT,JTHICK,PTHIC2,JCOL) 9314 CALL DPDRPL(PX,PY,NP, 9315 1IFIG,IPATT,PTHICK,ICOL, 9316 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 9317 IFLAG='OFF' 9318 1110 CONTINUE 9319 1140 CONTINUE 9320C 9321 IF(IVGMSW.EQ.'OFF')GOTO1180 9322 IF(NX1CMN.LE.2)GOTO1180 9323 NP=2 9324 IMAX=NX1CMN 9325 IFLAG='ON' 9326 DO1150I=1,IMAX 9327 PX(1)=PX1CMN(I) 9328 PX(2)=PX1CMN(I) 9329CCCCC CALL GRDRPL(PX,PY,NP, 9330CCCCC1IFIG,IPATT,PTHICK,ICOL, 9331CCCCC1JPATT,JTHICK,PTHIC2,JCOL) 9332 CALL DPDRPL(PX,PY,NP, 9333 1IFIG,IPATT,PTHICK,ICOL, 9334 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 9335 IFLAG='OFF' 9336 1150 CONTINUE 9337 1180 CONTINUE 9338C 9339C *************************************************** 9340C ** STEP 11-- ** 9341C ** TRANSLATE THE HORIZONTAL GRID LINE LINE PATTERN * 9342C ** INTO A NUMBER WHICH CAN BE UNDERSTOOD ** 9343C ** BY THE GRAPHICS DEVICE. ** 9344C *************************************************** 9345C 9346 IPATT=IHGRPA 9347CCCCC CALL GRTRPA(ITYPE,IPATT,PXSPA,PYSPA, 9348CCCCC1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) 9349C 9350C ********************************** 9351C ** STEP 12-- ** 9352C ** SET THE LINE PATTERN TO SOLID ** 9353C ** ON THE GRAPHICS DEVICE. ** 9354C ********************************** 9355C 9356CCCCC CALL GRSEPA(ITYPE,IPATT,PXSPA,PYSPA, 9357CCCCC1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) 9358C 9359C ********************************************** 9360C ** STEP 13-- ** 9361C ** TRANSLATE THE CHARACTER REPRESENTATION ** 9362C ** OF THE HORIZONTAL GRID LINE COLOR 9363C ** INTO A NUMERIC REPRESENTATION ** 9364C ** WHICH CAN BE UNDERSTOOD BY THE ** 9365C ** GRAPHICS DEVICE. ** 9366C ********************************************** 9367C 9368 ICOL=IHGRCO 9369CCCCC CALL GRTRCO(ITYPE,ICOL,JCOL) 9370C 9371C ******************************* 9372C ** STEP 14-- ** 9373C ** SET THE COLOR ** 9374C ** ON THE GRAPHICS DEVICE. ** 9375C ******************************* 9376C 9377CCCCC CALL GRSECO(ITYPE,ICOL,JCOL) 9378C 9379C ********************************************** 9380C ** STEP 15-- ** 9381C ** TRANSLATE THE CHARACTER REPRESENTATION ** 9382C ** OF THE HORIZONAL GRID LINE THICKNESS ** 9383C ** INTO A NUMERIC REPRESENTATION ** 9384C ** WHICH CAN BE UNDERSTOOD BY THE ** 9385C ** GRAPHICS DEVICE. ** 9386C ********************************************** 9387C 9388 PTHICK=PHGRTH 9389CCCCC CALL GRTRTH(ITYPE,PTHICK,JTHICK,PTHIC2) 9390C 9391C ******************************* 9392C ** STEP 16-- ** 9393C ** SET THE LINE THICKNESS ** 9394C ** ON THE GRAPHICS DEVICE. ** 9395C ******************************* 9396C 9397CCCCC CALL GRSETH(ITYPE,PTHICK,JTHICK,PTHIC2) 9398C 9399C ********************************** 9400C ** STEP 17-- ** 9401C ** DRAW HORIZONTAL GRID LINES ** 9402C ********************************** 9403C 9404 IFIG='LINE' 9405 PX(1)=PXMIN 9406 PX(2)=PXMAX 9407C 9408 IF(IHGRSW.EQ.'OFF')GOTO1240 9409 IF(NY1COO.LE.2)GOTO1240 9410 NP=2 9411CCCCC MAY, 1990. IF TIC OFFSETS ARE NON-ZER0, DRAW THE FIRST AND 9412CCCCC LAST GRID LINES (WHICH PREVIOUSLY WOULD ALWAYS BE ON THE FRAME. 9413 EPS=0.000001 9414 IMIN=2 9415 IF(ABS(PY1TOB).GE.EPS)IMIN=1 9416CCCCC THE FOLLOWING LINE WAS FIXED SEPTEMBER 1990 9417CCCCC IMAX=NX1COO-1 9418 IMAX=NY1COO-1 9419 IF(ABS(PY1TOT).GE.EPS)IMAX=NY1COO 9420CCCCC IMAX=NY1COO-1 9421 IFLAG='ON' 9422CCCCC DO1210I=2,IMAX 9423 DO1210I=IMIN,IMAX 9424 PY(1)=PY1COO(I) 9425 PY(2)=PY1COO(I) 9426CCCCC CALL GRDRPL(PX,PY,NP, 9427CCCCC1IFIG,IPATT,PTHICK,ICOL, 9428CCCCC1JPATT,JTHICK,PTHIC2,JCOL) 9429 CALL DPDRPL(PX,PY,NP, 9430 1IFIG,IPATT,PTHICK,ICOL, 9431 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 9432 IFLAG='OFF' 9433 1210 CONTINUE 9434 1240 CONTINUE 9435C 9436 IF(IHGMSW.EQ.'OFF')GOTO1280 9437 IF(NY1CMN.LE.2)GOTO1280 9438 NP=2 9439 IMAX=NY1CMN 9440 IFLAG='ON' 9441 DO1250I=1,IMAX 9442 PY(1)=PY1CMN(I) 9443 PY(2)=PY1CMN(I) 9444CCCCC CALL GRDRPL(PX,PY,NP, 9445CCCCC1IFIG,IPATT,PTHICK,ICOL, 9446CCCCC1JPATT,JTHICK,PTHIC2,JCOL) 9447 CALL DPDRPL(PX,PY,NP, 9448 1IFIG,IPATT,PTHICK,ICOL, 9449 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 9450 IFLAG='OFF' 9451 1250 CONTINUE 9452 1280 CONTINUE 9453 GOTO9000 9454C 9455 2000 CONTINUE 9456C 9457C ***************************************** 9458C ** STEP 20-- ** 9459C ** DRAW GRID LINES FOR TRILINEAR PLOT ** 9460C ***************************************** 9461C 9462 IF(IVGRSW.EQ.'OFF' .OR. IHGRSW.EQ.'OFF')GOTO9000 9463C 9464 ITYPE='LINE' 9465 IPATT=IHGRPA 9466 ICOL=IHGRCO 9467 PTHICK=PHGRTH 9468C 9469 IFIG='LINE' 9470C 9471 AMIN=0.0 9472CCCCC AMAX=FXMAX 9473CCCCC GRDINC=(AMAX-AMIN)/REAL(NX1COO-1) 9474 AMAX=1.0 9475 GRDINC=(1.0-0.0)/REAL(NX1COO-1) 9476 PXRANG=PXMAX - PXMIN 9477 PYRANG=PYMAX - PYMIN 9478C 9479C ***************************************** 9480C ** STEP 20.A-- ** 9481C ** DRAW GRID LINES FOR X1 AXIS ** 9482C ***************************************** 9483C 9484C 9485 NP2=2 9486 IFLAG='ON' 9487 DO2010I=2,NX1COO-1 9488 XDUMMY=AMIN + (I-1)*GRDINC 9489 PXSTRT=PXMIN + 0.5*PXRANG*XDUMMY 9490 PYSTRT=PYMIN + PYRANG*XDUMMY 9491 PXSTOP=PXMAX - (PXSTRT-PXMIN) 9492 PYSTOP=PYSTRT 9493 PX(1)=PXSTRT 9494 PX(2)=PXSTOP 9495 PY(1)=PYSTRT 9496 PY(2)=PYSTOP 9497 CALL DPDRPL(PX,PY,NP2, 9498 1 IFIG,IPATT,PTHICK,ICOL, 9499 1 JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 9500 IFLAG='OFF' 9501 2010 CONTINUE 9502C 9503C ***************************************** 9504C ** STEP 20.B-- ** 9505C ** DRAW GRID LINES FOR X2 AXIS ** 9506C ***************************************** 9507C 9508C 9509 NP2=2 9510 DO2020I=2,NX1COO-1 9511 XDUMMY=AMIN + (I-1)*GRDINC 9512 PXSTRT=PXMAX - PXRANG*XDUMMY 9513 PYSTRT=PYMIN 9514 PXSTOP=PXSTRT - 0.5*PXRANG*(AMAX-XDUMMY) 9515 PYSTOP=PYSTRT + PYRANG*(AMAX-XDUMMY) 9516 PX(1)=PXSTRT 9517 PX(2)=PXSTOP 9518 PY(1)=PYSTRT 9519 PY(2)=PYSTOP 9520 CALL DPDRPL(PX,PY,NP2, 9521 1 IFIG,IPATT,PTHICK,ICOL, 9522 1 JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 9523 2020 CONTINUE 9524C 9525C ***************************************** 9526C ** STEP 20.C-- ** 9527C ** DRAW GRID LINES FOR X3 AXIS ** 9528C ***************************************** 9529C 9530 NP2=2 9531 DO2030I=2,NX1COO-1 9532 XDUMMY=AMIN + (I-1)*GRDINC 9533 PXSTRT=PXMIN + PXRANG*XDUMMY 9534 PYSTRT=PYMIN 9535 PXSTOP=PXSTRT + 0.5*PXRANG*(AMAX-XDUMMY) 9536 PYSTOP=PYSTRT + PYRANG*(AMAX-XDUMMY) 9537 PX(1)=PXSTRT 9538 PX(2)=PXSTOP 9539 PY(1)=PYSTRT 9540 PY(2)=PYSTOP 9541 CALL DPDRPL(PX,PY,NP2, 9542 1 IFIG,IPATT,PTHICK,ICOL, 9543 1 JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 9544 2030 CONTINUE 9545 IFLAG='ON' 9546C 9547C 9548C ***************** 9549C ** STEP 90-- ** 9550C ** EXIT ** 9551C ***************** 9552C 9553 9000 CONTINUE 9554 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRGL')THEN 9555 WRITE(ICOUT,999) 9556 CALL DPWRST('XXX','BUG ') 9557 WRITE(ICOUT,9011) 9558 9011 FORMAT('***** AT THE END OF DPDRGL--') 9559 CALL DPWRST('XXX','BUG ') 9560 WRITE(ICOUT,9019)IPATT,ICOL,JPATT,JCOL 9561 9019 FORMAT('IPATT,ICOL,JPATT,JCOL = ',2(A4,2X),2I8) 9562 CALL DPWRST('XXX','BUG ') 9563 WRITE(ICOUT,9020)PTHICK,JTHICK,PTHIC2 9564 9020 FORMAT('PTHICK,JTHICK,PTHIC2 = ',E15.7,2X,A4,2X,E15.7) 9565 CALL DPWRST('XXX','BUG ') 9566 WRITE(ICOUT,9022)ITYPE,IERRG4 9567 9022 FORMAT('ITYPE,IERRG4 = ',A4,2X,A4) 9568 CALL DPWRST('XXX','BUG ') 9569 ENDIF 9570C 9571 RETURN 9572 END 9573 SUBROUTINE DPDRIM(PX,PY,YRED,YBLUE,YGREEN,YALPHA,NP, 9574 1 ICASCO,PHEIGH) 9575C 9576C PURPOSE--FOR A GENERAL GRAPHICS DEVICE, DRAW AN IMAGE. THE 9577C ARRAYS PX AND PY CONTAIN THE ROW-ID AND COLUMN-ID 9578C OF THE IMAGE, RESPECTIVELY. THE ARRAYS YRED, YBLUE, 9579C AND YGREEN CONTAIN THE RED, BLUE, AND GREEN COMPONENTS, 9580C RESPECTIVELY, ON A (0,1) SCALE. THE YALPHA ARRAY IS 9581C RESERVED FOR FUTURE DEVELOPMENT (FOR AN ALPHA CHANNEL). 9582C THE SCALING FROM (0,1) TO AN APPROPRIATE 8-BIT 9583C (I.E., 0 TO 255) OR 16-BIT (I.E., 0 TO 16535) SCALE 9584C WILL BE HANDLED FOR SPECIFIC DEVICES IN THE GRDRIM 9585C ROUTINE. 9586C WRITTEN BY--JAMES J. FILLIBEN 9587C STATISTICAL ENGINEERING DIVISION 9588C INFORMATION TECHNOLOGY LABORATORY 9589C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 9590C GAITHERSBURG, MD 20899-8980 9591C PHONE--301-975-2899 9592C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 9593C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 9594C LANGUAGE--ANSI FORTRAN (1977) 9595C VERSION NUMBER--2008.3 9596C ORIGINAL VERSION--MARCH 2008. 9597C 9598C-----NON-COMMON VARIABLES (GRAPHICS)----------------------------------- 9599C 9600 CHARACTER*4 ICASCO 9601 CHARACTER*4 IERROR 9602C 9603 DIMENSION PX(*) 9604 DIMENSION PY(*) 9605 DIMENSION YRED(*) 9606 DIMENSION YBLUE(*) 9607 DIMENSION YGREEN(*) 9608 DIMENSION YALPHA(*) 9609C 9610 CHARACTER*4 IJUST 9611C 9612C-----COMMON---------------------------------------------------------- 9613C 9614 INCLUDE 'DPCOPA.INC' 9615 INCLUDE 'DPCOPC.INC' 9616 INCLUDE 'DPCOGR.INC' 9617 INCLUDE 'DPCOBE.INC' 9618 INCLUDE 'DPCOP2.INC' 9619C 9620C-----START POINT----------------------------------------------------- 9621C 9622 IERROR='OFF' 9623 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRIM')THEN 9624 WRITE(ICOUT,999) 9625 999 FORMAT(1X) 9626 CALL DPWRST('XXX','BUG ') 9627 WRITE(ICOUT,51) 9628 51 FORMAT('***** AT THE BEGINNING OF DPDRIM--') 9629 CALL DPWRST('XXX','BUG ') 9630 WRITE(ICOUT,54)NP 9631 54 FORMAT('NP = ',I8) 9632 CALL DPWRST('XXX','BUG ') 9633 DO55I=1,MAX(NP,1000) 9634 WRITE(ICOUT,56)I,PX(I),PY(I),YRED(I),YGREEN(I),YBLUE(I) 9635 56 FORMAT('I,PX(I),PY(I),YRED(I),YGREEN(I),YBLUE(I) = ', 9636 1 I8,5F10.5) 9637 CALL DPWRST('XXX','BUG ') 9638 55 CONTINUE 9639 WRITE(ICOUT,57)PHEIGH 9640 57 FORMAT('PHEIGH = ',G15.7) 9641 CALL DPWRST('XXX','BUG ') 9642 WRITE(ICOUT,59)IBUGG4,ISUBG4,IERRG4 9643 59 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 9644 CALL DPWRST('XXX','BUG ') 9645 ENDIF 9646C 9647C ********************************************** 9648C ** STEP 7-- ** 9649C ** TRANSLATE THE CHARACTER REPRESENTATION ** 9650C ** OF THE MARKER JUSTIFICATION ** 9651C ** INTO A NUMERIC REPRESENTATION ** 9652C ** WHICH CAN BE UNDERSTOOD BY THE ** 9653C ** GRAPHICS DEVICE. ** 9654C ********************************************** 9655C 9656 CALL GRTRJU(ITEXJU,IJUST,JJUST) 9657C 9658C ******************************* 9659C ** STEP 19-- ** 9660C ** DRAW OUT THE POLYMARKER ** 9661C ******************************* 9662C 9663 CALL GRDRIM(PX,PY,NP, 9664 1 ICASCO,IJUST,PHEIGH, 9665 1 YRED,YBLUE,YGREEN,YALPHA, 9666 1 PXMIN,PYMIN,PXMAX,PYMAX) 9667C 9668C ***************** 9669C ** STEP 90-- ** 9670C ** EXIT ** 9671C ***************** 9672C 9673 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRIM')THEN 9674 WRITE(ICOUT,999) 9675 CALL DPWRST('XXX','BUG ') 9676 WRITE(ICOUT,9011) 9677 9011 FORMAT('***** AT THE END OF DPDRIM--') 9678 CALL DPWRST('XXX','BUG ') 9679 ENDIF 9680C 9681 RETURN 9682 END 9683 SUBROUTINE DPDRPL(PX,PY,NP, 9684 1 IFIG,IPATT,PTHICK,ICOL, 9685 1 JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 9686C 9687C PURPOSE--FOR A GENERAL GRAPHICS DEVICE, 9688C DRAW THE POLYLINE WHOSE COORDINATES 9689C ARE GIVEN IN (PX(.),PY(.)) , 9690C AND WHICH HAS SPECIFIED 9691C PATTERN, THICKNESS, AND COLOR. 9692C NOTE--THE COORDINATES IN (PX(.),PY(.)) ARE IN 9693C STANDARDIZED (0.0 TO 100.0) UNITS. 9694C NOTE--THERE ARE NP SUCH COORDINATE PAIRS. 9695C 9696C WRITTEN BY--JAMES J. FILLIBEN 9697C STATISTICAL ENGINEERING DIVISION 9698C INFORMATION TECHNOLOGY LABORATORY 9699C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 9700C GAITHERSBURG, MD 20899-8980 9701C PHONE--301-921-369011 9702C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 9703C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 9704C LANGUAGE--ANSI FORTRAN (1977) 9705C VERSION NUMBER--83.6 9706C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. 9707C UPDATED --JANUARY 1989. MODIFED CALL LIST (ALAN) 9708C UPDATED --JANUARY 1989. MODIFIED LINE THICKNESS ALGOR. (ALAN) 9709C UPDATED --MAY 1989. DEBUG FOR IFLAG 9710C UPDATED --MAY 1995. USE EQUIVALENCE 9711C UPDATED --JUNE 2019. EQUIVALENCE FOR SCRATCH STORAGE 9712C 9713C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- 9714C 9715 CHARACTER*4 IFIG 9716 CHARACTER*4 IPATT 9717 CHARACTER*4 ICOL 9718C 9719 CHARACTER*4 ITYPE 9720 CHARACTER*4 IHORPA 9721 CHARACTER*4 IVERPA 9722 CHARACTER*4 IDUPPA 9723 CHARACTER*4 IDDOPA 9724C 9725 CHARACTER*4 IFLAG 9726C 9727 DIMENSION PX(*) 9728 DIMENSION PY(*) 9729CCCCC DIMENSION PX3(*) 9730CCCCC DIMENSION PY3(*) 9731 INCLUDE 'DPCOPA.INC' 9732 INCLUDE 'DPCOZZ.INC' 9733 DIMENSION PX3(MAXPOP) 9734 DIMENSION PY3(MAXPOP) 9735 EQUIVALENCE (GARBAG(IGAR10),PX3(1)) 9736 EQUIVALENCE (GARBAG(JGAR16),PY3(1)) 9737C 9738C-----COMMON---------------------------------------------------------- 9739C 9740 INCLUDE 'DPCOGR.INC' 9741 INCLUDE 'DPCOBE.INC' 9742 INCLUDE 'DPCOP2.INC' 9743C 9744C-----START POINT----------------------------------------------------- 9745C 9746 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRPL')THEN 9747 WRITE(ICOUT,999) 9748 999 FORMAT(1X) 9749 CALL DPWRST('XXX','BUG ') 9750 WRITE(ICOUT,51) 9751 51 FORMAT('***** AT THE BEGINNING OF DPDRPL--') 9752 CALL DPWRST('XXX','BUG ') 9753 WRITE(ICOUT,54)MAX(10,NP),IFLAG,ISUBG4,IERRG4 9754 54 FORMAT('NP,IFLAG,ISUBG4,IERRG4 = ',I8,3(2X,A4)) 9755 CALL DPWRST('XXX','BUG ') 9756 DO55I=1,NP 9757 WRITE(ICOUT,56)PX(I),PY(I) 9758 56 FORMAT('PX(I),PY(I) = ',2G15.7) 9759 CALL DPWRST('XXX','BUG ') 9760 55 CONTINUE 9761 WRITE(ICOUT,58)IFIG,IPATT,ICOL,PTHICK 9762 58 FORMAT('IFIG,IPATT,ICOL,PTHICK = ',3(A4,2X),G15.7) 9763 CALL DPWRST('XXX','BUG ') 9764 WRITE(ICOUT,59)JTHICK,PTHICK,PTHIC2 9765 59 FORMAT('JTHICK,PTHIC,PTHIC2 = ',I8,2G15.7) 9766 CALL DPWRST('XXX','BUG ') 9767 ENDIF 9768C 9769C SEPTEMMBER, 1987 - SET ATTRIBUTES ACCORDING TO FLAG 9770 NP3=NP 9771 IF(IFLAG.EQ.'OFF')GOTO700 9772C 9773 ITYPE='LINE' 9774C 9775C ********************************************** 9776C ** STEP 1-- ** 9777C ** TRANSLATE THE CHARACTER REPRESENTATION ** 9778C ** OF THE LINE PATTERN ** 9779C ** INTO A NUMERIC REPRESENTATION ** 9780C ** WHICH CAN BE UNDERSTOOD BY THE ** 9781C ** GRAPHICS DEVICE. ** 9782C ********************************************** 9783C 9784 CALL GRTRPA(ITYPE,IPATT,PXSPA,PYSPA, 9785 1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) 9786C 9787C ******************************* 9788C ** STEP 2-- ** 9789C ** SET THE LINE PATTERN ** 9790C ** ON THE GRAPHICS DEVICE. ** 9791C ******************************* 9792C 9793 CALL GRSEPA(ITYPE,IPATT,PXSPA,PYSPA, 9794 1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) 9795C 9796C ********************************************** 9797C ** STEP 3-- ** 9798C ** TRANSLATE THE DESIRED ** 9799C ** LINE THICKNESS ** 9800C ** INTO A NUMERIC REPRESENTATION ** 9801C ** WHICH CAN BE UNDERSTOOD BY THE ** 9802C ** GRAPHICS DEVICE. ** 9803C ********************************************** 9804C 9805 CALL GRTRTH(ITYPE,PTHICK,JTHICK,PTHIC2) 9806C 9807C ******************************* 9808C ** STEP 4-- ** 9809C ** SET THE LINE THICKNESS ** 9810C ** ON THE GRAPHICS DEVICE. ** 9811C ******************************* 9812C 9813 CALL GRSETH(ITYPE,PTHICK,JTHICK,PTHIC2) 9814C 9815C ********************************************** 9816C ** STEP 901-- ** 9817C ** TRANSLATE THE CHARACTER REPRESENTATION ** 9818C ** OF THE LINE COLOR ** 9819C ** INTO A NUMERIC REPRESENTATION ** 9820C ** WHICH CAN BE UNDERSTOOD BY THE ** 9821C ** GRAPHICS DEVICE. ** 9822C ********************************************** 9823C 9824 CALL GRTRCO(ITYPE,ICOL,JCOL) 9825C 9826C ******************************* 9827C ** STEP 6-- ** 9828C ** SET THE LINE COLOR ** 9829C ** ON THE GRAPHICS DEVICE. ** 9830C ******************************* 9831C 9832 CALL GRSECO(ITYPE,ICOL,JCOL) 9833C 9834C ***************************** 9835C ** STEP 7-- ** 9836C ** DRAW OUT THE POLYLINE ** 9837C ***************************** 9838C 9839 700 CONTINUE 9840 IF(IFLAG.EQ.'LOOP')GOTO800 9841 CALL GRDRPL(PX,PY,NP, 9842 1IFIG,IPATT,PTHICK,ICOL, 9843 1JPATT,JTHICK,PTHIC2,JCOL) 9844C 9845CCCCC PPENTH=0.1 9846CCCCC NLOOP=((PTHICK/(2.0*PPENTH))-1.0)+0.1 9847C 9848CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRPL') 9849CCCCC1WRITE(ICOUT,1510)PPENTH,NLOOP 9850C1510 FORMAT('PPENTH,NLOOP = ',E15.7,I8) 9851CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRPL') 9852CCCCC1CALL DPWRST('XXX','BUG ') 9853C 9854 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRPL')THEN 9855 WRITE(ICOUT,1510)PTHIC2,JTHICK 9856 1510 FORMAT('PTHIC2,JTICK = ',E15.7,I8) 9857 CALL DPWRST('XXX','BUG ') 9858 ENDIF 9859C 9860 800 CONTINUE 9861 NLOOP=JTHICK 9862 PPENTH=PTHIC2 9863C 9864 IF(NLOOP.LE.0)GOTO1590 9865 DO1520I=1,NLOOP 9866 AI=I 9867C 9868 DEL=PPENTH*AI 9869 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRPL')THEN 9870 WRITE(ICOUT,1522)I,NLOOP,DEL 9871 1522 FORMAT('I,NLOOP,DEL = ',2I8,G15.7) 9872 CALL DPWRST('XXX','BUG ') 9873 ENDIF 9874 CALL GRDEPL(PX,PY,NP,DEL,PX3,PY3,NP3) 9875 CALL GRDRPL(PX3,PY3,NP3, 9876 1IFIG,IPATT,PTHICK,ICOL, 9877 1JPATT,JTHICK,PTHIC2,JCOL) 9878C 9879 DEL=(-PPENTH*AI) 9880 CALL GRDEPL(PX,PY,NP,DEL,PX3,PY3,NP3) 9881 CALL GRDRPL(PX3,PY3,NP3, 9882 1IFIG,IPATT,PTHICK,ICOL, 9883 1JPATT,JTHICK,PTHIC2,JCOL) 9884C 9885 1520 CONTINUE 9886C 9887 1590 CONTINUE 9888C 9889C ***************** 9890C ** STEP 90-- ** 9891C ** EXIT ** 9892C ***************** 9893C 9894 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRPL')THEN 9895 WRITE(ICOUT,999) 9896 CALL DPWRST('XXX','BUG ') 9897 WRITE(ICOUT,9011) 9898 9011 FORMAT('***** AT THE END OF DPDRPL--') 9899 CALL DPWRST('XXX','BUG ') 9900 WRITE(ICOUT,9024)IERRG4,ITYPE,PPENTH,DEL,NLOOP 9901 9024 FORMAT('IERRG4,ITYPE,PPENTH,DEL,NLOOP = ',2(A4,2X),2G15.7,I8) 9902 CALL DPWRST('XXX','BUG ') 9903 ENDIF 9904C 9905 RETURN 9906 END 9907 SUBROUTINE DPDRPM(PX,PY,NP,X3D2,IJUNK2,IROWID,IROWLB, 9908 1IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 9909 1PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK, 9910 1IMPSW2,AMPSCH,AMPSCW, 9911 1ISYMBL,ISPAC) 9912C 9913C PURPOSE--FOR A GENERAL GRAPHICS DEVICE, 9914C DRAW THE POLYMARKERS WHOSE COORDINATES 9915C ARE GIVEN IN (PX(.),PY(.)) , 9916C AND WHICH HAS SPECIFIED 9917C MARKER TYPE, SIZE, FONT, JUSTIFICATION, COLOR, ANGLE, 9918C AND LINE THICKNESS. 9919C NOTE--THE COORDINATES IN (PX(.),PY(.)) ARE IN 9920C STANDARDIZED (0.0 TO 100.0) UNITS. 9921C NOTE--THERE ARE NP SUCH COORDINATE PAIRS. 9922C 9923C WRITTEN BY--JAMES J. FILLIBEN 9924C STATISTICAL ENGINEERING DIVISION 9925C INFORMATION TECHNOLOGY LABORATORY 9926C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 9927C GAITHERSBURG, MD 20899-8980 9928C PHONE--301-975-2899 9929C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 9930C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 9931C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, 9932C MODIFIED, OR OTHERWISE USED IN A CONTEXT 9933C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. 9934C LANGUAGE--ANSI FORTRAN (1977) 9935C VERSION NUMBER--83.6 9936C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. 9937C UPDATED --NOVEMBER 1995. SUPPORT FOR CASE ASIS 9938C UPDATED --SEPTEMBER 1999. GRDRPM ARGUMENT LIST 9939C UPDATED --DECEMBER 1999. SUPPORT SPECIAL PLOTTING 9940C (FOR VALUE OF POINT,ETC.) 9941C 9942C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- 9943C 9944 CHARACTER*4 ITYPE 9945C 9946 CHARACTER*4 IFIG 9947 CHARACTER*24 IPATT 9948 CHARACTER*4 IFONT 9949 CHARACTER*4 ICASE 9950 CHARACTER*4 IJUST 9951 CHARACTER*4 IDIR 9952 CHARACTER*4 IFILL 9953 CHARACTER*4 ICOL 9954C 9955 CHARACTER*24 ISYMBL 9956 CHARACTER*4 ISPAC 9957 CHARACTER*4 IMPSW2 9958C 9959 CHARACTER*4 IHORPA 9960 CHARACTER*4 IVERPA 9961 CHARACTER*4 IDUPPA 9962 CHARACTER*4 IDDOPA 9963C 9964 CHARACTER*4 ITYPSV 9965C 9966 CHARACTER*4 ICTEMP 9967 CHARACTER*4 ICTEXT 9968 CHARACTER*4 IERROR 9969C 9970 CHARACTER*24 IROWLB 9971C 9972 DIMENSION ICTEXT(50) 9973C 9974 DIMENSION IROWID(*) 9975 DIMENSION IROWLB(*) 9976 DIMENSION IJUNK2(*) 9977 DIMENSION PX(*) 9978 DIMENSION PY(*) 9979 DIMENSION X3D2(*) 9980C 9981C-----COMMON---------------------------------------------------------- 9982C 9983 INCLUDE 'DPCOPA.INC' 9984 INCLUDE 'DPCODA.INC' 9985 INCLUDE 'DPCOGR.INC' 9986 INCLUDE 'DPCOBE.INC' 9987 INCLUDE 'DPCOP2.INC' 9988C 9989C-----START POINT----------------------------------------------------- 9990C 9991 IERROR='OFF' 9992 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRPM')GOTO90 9993 WRITE(ICOUT,999) 9994 999 FORMAT(1X) 9995 CALL DPWRST('XXX','BUG ') 9996 WRITE(ICOUT,51) 9997 51 FORMAT('***** AT THE BEGINNING OF DPDRPM--') 9998 CALL DPWRST('XXX','BUG ') 9999 WRITE(ICOUT,54)NP 10000 54 FORMAT('NP = ',I8) 10001 CALL DPWRST('XXX','BUG ') 10002 DO55I=1,NP 10003 WRITE(ICOUT,56)PX(I),PY(I) 10004 56 FORMAT('PX(I),PY(I) = ',E15.7,E15.7) 10005 CALL DPWRST('XXX','BUG ') 10006 55 CONTINUE 10007 WRITE(ICOUT,58)IFIG,IFONT,IJUST,IFILL,ICOL,IPATT 10008 58 FORMAT('IFIG,IFONT,IJUST,IFILL,ICOL,IPATT = ',5(A4,1X),A16) 10009 CALL DPWRST('XXX','BUG ') 10010 WRITE(ICOUT,64)IDIR,ANGLE,PTHICK 10011 64 FORMAT('IDIR,ANGLE,PTHICK = ',A4,2X,2G15.7) 10012 CALL DPWRST('XXX','BUG ') 10013 WRITE(ICOUT,67)PHEIGH,PWIDTH,PVEGAP,PHOGAP 10014 67 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4G15.7) 10015 CALL DPWRST('XXX','BUG ') 10016 WRITE(ICOUT,71)ISYMBL,ISPAC 10017 71 FORMAT('ISYMBL,ISPAC = ',A24,2X,A4) 10018 CALL DPWRST('XXX','BUG ') 10019 WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4 10020 79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 10021 CALL DPWRST('XXX','BUG ') 10022 90 CONTINUE 10023C 10024CCCCC DECEMBER 1999. SUPPORT SPECIAL CASES: 10025CCCCC 1) XVAL = X-COORDINATE OF VARIABLE 10026CCCCC 2) YVAL = Y-COORDINATE OF VARIABLE 10027CCCCC 3) XYVA = (X,Y) OF VARIABLE 10028CCCCC 4) ROWI = ROW-ID 10029CCCCC 5) ROWL = ROW-LABEL 10030CCCCC 6) TVAL = TAG-VALUE (SPECIAL CASE FOR CROSS-TABULATE PLOT, 10031CCCCC BUT MAY HAVE OTHER USES AS WELL) 10032CCCCC 7) ZVAL = USE VALUE IN X3D2 10033C 10034 IF( 10035 1(ISYMBL(1:1).EQ.'R'.OR.ISYMBL(1:1).EQ.'r').AND. 10036 1(ISYMBL(2:2).EQ.'O'.OR.ISYMBL(2:2).EQ.'o').AND. 10037 1(ISYMBL(3:3).EQ.'W'.OR.ISYMBL(3:3).EQ.'w').AND. 10038 1(ISYMBL(4:4).EQ.'I'.OR.ISYMBL(4:4).EQ.'i') 10039 1)THEN 10040 DO1010I=1,NP 10041 IROW=IROWID(I) 10042 AROW=REAL(IROW) 10043 NCTEXT=0 10044 DO1015J=1,50 10045 ICTEXT(J)=' ' 10046 1015 CONTINUE 10047 CALL DPCONH(IROW,AROW,ICTEXT,NH,IBUGG4,IERROR) 10048 NCTEXT=NH 10049 PX1=PX(I) 10050 PY1=PY(I) 10051 CALL DPWRTE(PX1,PY1,ICTEXT,NCTEXT, 10052 1 IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 10053 1 PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK, 10054 1 ISYMBL,ISPAC, 10055 1 IMPSW2,AMPSCH,AMPSCW, 10056 1 PX99,PY99) 10057 1010 CONTINUE 10058 GOTO9000 10059 ELSEIF( 10060 1(ISYMBL(1:1).EQ.'R'.OR.ISYMBL(1:1).EQ.'r').AND. 10061 1(ISYMBL(2:2).EQ.'O'.OR.ISYMBL(2:2).EQ.'o').AND. 10062 1(ISYMBL(3:3).EQ.'W'.OR.ISYMBL(3:3).EQ.'w').AND. 10063 1(ISYMBL(4:4).EQ.'L'.OR.ISYMBL(4:4).EQ.'l') 10064 1)THEN 10065 DO1020I=1,NP 10066 ITEMP=IROWID(I) 10067C 10068C 2012/08: FOR BLANK ROW LABEL, JUST LEAVE BLANK 10069C 10070 IF(IROWLB(ITEMP).EQ.' ')THEN 10071 GOTO9000 10072CCCCC IROW=IROWID(I) 10073CCCCC AROW=REAL(IROW) 10074CCCCC NCTEXT=0 10075CCCCC DO1025J=1,50 10076CCCCC ICTEXT(J)=' ' 10077C1025 CONTINUE 10078CCCCC CALL DPCONH(IROW,AROW,ICTEXT,NH,IBUGG4,IERROR) 10079CCCCC NCTEXT=NH 10080 ELSE 10081 NCTEXT=1 10082 DO1026J=24,1,-1 10083 IF(IROWLB(ITEMP)(J:J).NE.' ')THEN 10084 NCTEXT=J 10085 GOTO1027 10086 ENDIF 10087 1026 CONTINUE 10088 1027 CONTINUE 10089 DO1028J=1,NCTEXT 10090 ICTEXT(J)=' ' 10091 ICTEXT(J)(1:1)=IROWLB(ITEMP)(J:J) 10092 1028 CONTINUE 10093 ENDIF 10094 PX1=PX(I) 10095 PY1=PY(I) 10096 CALL DPWRTE(PX1,PY1,ICTEXT,NCTEXT, 10097 1 IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 10098 1 PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK, 10099 1 ISYMBL,ISPAC, 10100 1 IMPSW2,AMPSCH,AMPSCW, 10101 1 PX99,PY99) 10102 1020 CONTINUE 10103 GOTO9000 10104 ELSEIF( 10105 1(ISYMBL(1:1).EQ.'X'.OR.ISYMBL(1:1).EQ.'x').AND. 10106 1(ISYMBL(2:2).EQ.'V'.OR.ISYMBL(2:2).EQ.'v').AND. 10107 1(ISYMBL(3:3).EQ.'A'.OR.ISYMBL(3:3).EQ.'a').AND. 10108 1(ISYMBL(4:4).EQ.'L'.OR.ISYMBL(4:4).EQ.'l') 10109 1)THEN 10110 DO1030I=1,NP 10111 PX1=PX(I) 10112 PY1=PY(I) 10113 AVAL=X(I) 10114 CONST=0.5 10115 IF(AVAL.LT.0.0)CONST=-0.5 10116 IVAL=INT(AVAL+CONST) 10117 NCTEXT=0 10118 DO1035J=1,50 10119 ICTEXT(J)=' ' 10120 1035 CONTINUE 10121 CALL DPCONH(IVAL,AVAL,ICTEXT,NH,IBUGG4,IERROR) 10122 NCTEXT=NH 10123 CALL DPWRTE(PX1,PY1,ICTEXT,NCTEXT, 10124 1 IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 10125 1 PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK, 10126 1 ISYMBL,ISPAC, 10127 1 IMPSW2,AMPSCH,AMPSCW, 10128 1 PX99,PY99) 10129 1030 CONTINUE 10130 GOTO9000 10131 ELSEIF( 10132 1(ISYMBL(1:1).EQ.'Y'.OR.ISYMBL(1:1).EQ.'y').AND. 10133 1(ISYMBL(2:2).EQ.'V'.OR.ISYMBL(2:2).EQ.'v').AND. 10134 1(ISYMBL(3:3).EQ.'A'.OR.ISYMBL(3:3).EQ.'a').AND. 10135 1(ISYMBL(4:4).EQ.'L'.OR.ISYMBL(4:4).EQ.'l') 10136 1)THEN 10137 DO1040I=1,NP 10138 PX1=PX(I) 10139 PY1=PY(I) 10140 AVAL=Y(I) 10141 CONST=0.5 10142 IF(AVAL.LT.0.0)CONST=-0.5 10143 IVAL=INT(AVAL+CONST) 10144 NCTEXT=0 10145 DO1045J=1,50 10146 ICTEXT(J)=' ' 10147 1045 CONTINUE 10148 CALL DPCONH(IVAL,AVAL,ICTEXT,NH,IBUGG4,IERROR) 10149 NCTEXT=NH 10150 CALL DPWRTE(PX1,PY1,ICTEXT,NCTEXT, 10151 1 IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 10152 1 PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK, 10153 1 ISYMBL,ISPAC, 10154 1 IMPSW2,AMPSCH,AMPSCW, 10155 1 PX99,PY99) 10156 1040 CONTINUE 10157 GOTO9000 10158 ELSEIF( 10159 1(ISYMBL(1:1).EQ.'X'.OR.ISYMBL(1:1).EQ.'x').AND. 10160 1(ISYMBL(2:2).EQ.'Y'.OR.ISYMBL(2:2).EQ.'y').AND. 10161 1(ISYMBL(3:3).EQ.'V'.OR.ISYMBL(3:3).EQ.'v').AND. 10162 1(ISYMBL(4:4).EQ.'A'.OR.ISYMBL(4:4).EQ.'a') 10163 1)THEN 10164 DO1050I=1,NP 10165 DO1055J=1,50 10166 ICTEXT(J)=' ' 10167 1055 CONTINUE 10168 PX1=PX(I) 10169 PY1=PY(I) 10170 AVAL=X(I) 10171 CONST=0.5 10172 IF(AVAL.LT.0.0)CONST=-0.5 10173 IVAL=INT(AVAL+CONST) 10174 NCTEXT=1 10175 ICTEXT(NCTEXT)(1:1)='(' 10176 NCTEXT=NCTEXT+1 10177 CALL DPCONH(IVAL,AVAL,ICTEXT(NCTEXT),NH,IBUGG4,IERROR) 10178 NCTEXT=NCTEXT+NH 10179 NCTEXT=NCTEXT+1 10180 ICTEXT(NCTEXT)(1:1)=',' 10181 NCTEXT=NCTEXT+1 10182 AVAL=Y(I) 10183 IF(AVAL.LT.0.0)CONST=-0.5 10184 IVAL=INT(AVAL+CONST) 10185 CALL DPCONH(IVAL,AVAL,ICTEXT(NCTEXT),NH,IBUGG4,IERROR) 10186 NCTEXT=NCTEXT+NH 10187 ICTEXT(NCTEXT)(1:1)=')' 10188 CALL DPWRTE(PX1,PY1,ICTEXT,NCTEXT, 10189 1 IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 10190 1 PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK, 10191 1 ISYMBL,ISPAC, 10192 1 IMPSW2,AMPSCH,AMPSCW, 10193 1 PX99,PY99) 10194 1050 CONTINUE 10195 GOTO9000 10196 ELSEIF( 10197 1(ISYMBL(1:1).EQ.'T'.OR.ISYMBL(1:1).EQ.'t').AND. 10198 1(ISYMBL(2:2).EQ.'V'.OR.ISYMBL(2:2).EQ.'v').AND. 10199 1(ISYMBL(3:3).EQ.'A'.OR.ISYMBL(3:3).EQ.'a').AND. 10200 1(ISYMBL(4:4).EQ.'L'.OR.ISYMBL(4:4).EQ.'l') 10201 1)THEN 10202 DO1060I=1,NP 10203 PX1=PX(I) 10204 PY1=PY(I) 10205 AVAL=D(I) 10206 CONST=0.5 10207 IF(AVAL.LT.0.0)CONST=-0.5 10208 IVAL=INT(AVAL+CONST) 10209 NCTEXT=0 10210 DO1065J=1,50 10211 ICTEXT(J)=' ' 10212 1065 CONTINUE 10213 CALL DPCONH(IVAL,AVAL,ICTEXT,NH,IBUGG4,IERROR) 10214 NCTEXT=NH 10215 CALL DPWRTE(PX1,PY1,ICTEXT,NCTEXT, 10216 1 IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 10217 1 PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK, 10218 1 ISYMBL,ISPAC, 10219 1 IMPSW2,AMPSCH,AMPSCW, 10220 1 PX99,PY99) 10221 1060 CONTINUE 10222 GOTO9000 10223 ELSEIF( 10224 1(ISYMBL(1:1).EQ.'Z'.OR.ISYMBL(1:1).EQ.'z').AND. 10225 1(ISYMBL(2:2).EQ.'V'.OR.ISYMBL(2:2).EQ.'v').AND. 10226 1(ISYMBL(3:3).EQ.'A'.OR.ISYMBL(3:3).EQ.'a').AND. 10227 1(ISYMBL(4:4).EQ.'L'.OR.ISYMBL(4:4).EQ.'l') 10228 1)THEN 10229 J=0 10230 DO1070I=1,MAXPOP 10231 IF(IJUNK2(I).EQ.0)GOTO1070 10232 J=J+1 10233 PX1=PX(J) 10234 PY1=PY(J) 10235 AVAL=X3D2(I) 10236 CONST=0.5 10237 IF(AVAL.LT.0.0)CONST=-0.5 10238 IVAL=INT(AVAL+CONST) 10239 NCTEXT=0 10240 DO1075JJ=1,50 10241 ICTEXT(JJ)=' ' 10242 1075 CONTINUE 10243 CALL DPCONH(IVAL,AVAL,ICTEXT,NH,IBUGG4,IERROR) 10244 NCTEXT=NH 10245 CALL DPWRTE(PX1,PY1,ICTEXT,NCTEXT, 10246 1 IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 10247 1 PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK, 10248 1 ISYMBL,ISPAC, 10249 1 IMPSW2,AMPSCH,AMPSCW, 10250 1 PX99,PY99) 10251 IF(J.GE.NP)GOTO1079 10252 1070 CONTINUE 10253 1079 CONTINUE 10254 GOTO9000 10255 ENDIF 10256CCCCC NOVEMBER 1995. DO CASE CONVERSION HERE. 10257CCCCC IF "ASIS" NO ACTION REQUIRED. 10258CCCCC BE SURE TO TRANSLATE IPATT TO UPPER CASE. 10259 IF(ICASE.EQ.'LOWE')THEN 10260 DO100I=1,24 10261 ICTEMP=ISYMBL(I:I) 10262 CALL DPCOAN(ICTEMP,IVALT) 10263 IF(IVALT.GE.65.AND.IVALT.LE.90)IVALT=IVALT+32 10264 CALL DPCONA(IVALT,ICTEMP) 10265 ISYMBL(I:I)=ICTEMP 10266 100 CONTINUE 10267 ELSEIF(ICASE.EQ.'UPPE')THEN 10268 DO110I=1,24 10269 ICTEMP=ISYMBL(I:I) 10270 CALL DPCOAN(ICTEMP,IVALT) 10271 IF(IVALT.GE.97.AND.IVALT.LE.122)IVALT=IVALT-32 10272 CALL DPCONA(IVALT,ICTEMP) 10273 ISYMBL(I:I)=ICTEMP 10274 110 CONTINUE 10275 ELSEIF(ICASE.EQ.'ASIS')THEN 10276 CONTINUE 10277 END IF 10278 DO130I=1,24 10279 ICTEMP=IPATT(I:I) 10280 CALL DPCOAN(ICTEMP,IVALT) 10281 IF(IVALT.GE.97.AND.IVALT.LE.122)IVALT=IVALT-32 10282 CALL DPCONA(IVALT,ICTEMP) 10283 IPATT(I:I)=ICTEMP 10284 130 CONTINUE 10285C 10286 ITYPE='MARK' 10287C 10288C ********************************************** 10289C ** STEP 1-- ** 10290C ** TRANSLATE THE CHARACTER REPRESENTATION ** 10291C ** OF THE MARKER PATTERN (TYPE) ** 10292C ** INTO A NUMERIC REPRESENTATION ** 10293C ** WHICH CAN BE UNDERSTOOD BY THE ** 10294C ** GRAPHICS DEVICE. ** 10295C ********************************************** 10296C 10297 CALL GRTRPA(ITYPE,IPATT(1:4),PXSPA,PYSPA, 10298 1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) 10299C 10300C ******************************* 10301C ** STEP 2-- ** 10302C ** SET THE MARKER PATTERN ** 10303C ** ON THE GRAPHICS DEVICE. ** 10304C ******************************* 10305C 10306 CALL GRSEPA(ITYPE,IPATT(1:4),PXSPA,PYSPA, 10307 1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) 10308C 10309C ********************************************** 10310C ** STEP 3-- ** 10311C ** TRANSLATE THE CHARACTER REPRESENTATION ** 10312C ** OF THE MARKER FONT ** 10313C ** INTO A NUMERIC REPRESENTATION ** 10314C ** WHICH CAN BE UNDERSTOOD BY THE ** 10315C ** GRAPHICS DEVICE. ** 10316C ********************************************** 10317C 10318 CALL GRTRFO(ITYPE,IFONT,JFONT) 10319C 10320C ************************************ 10321C ** STEP 4-- ** 10322C ** SET THE MARKER FONT ** 10323C ** ON THE GRAPHICS DEVICE. ** 10324C ************************************ 10325C 10326 CALL GRSEFO(ITYPE,IFONT,JFONT) 10327C 10328C ********************************************** 10329C ** STEP 5-- ** 10330C ** TRANSLATE THE CHARACTER REPRESENTATION ** 10331C ** OF THE MARKER CASE (UPPER OR LOWER) ** 10332C ** INTO A NUMERIC REPRESENTATION ** 10333C ** WHICH CAN BE UNDERSTOOD BY THE ** 10334C ** GRAPHICS DEVICE. ** 10335C ********************************************** 10336C 10337 CALL GRTRCA(ITYPE,ICASE,JCASE) 10338C 10339C ************************************ 10340C ** STEP 6-- ** 10341C ** SET THE MARKER CASE ** 10342C ** ON THE GRAPHICS DEVICE. ** 10343C ************************************ 10344C 10345 CALL GRSECA(ITYPE,ICASE,JCASE) 10346C 10347C ********************************************** 10348C ** STEP 7-- ** 10349C ** TRANSLATE THE CHARACTER REPRESENTATION ** 10350C ** OF THE MARKER JUSTIFICATION ** 10351C ** INTO A NUMERIC REPRESENTATION ** 10352C ** WHICH CAN BE UNDERSTOOD BY THE ** 10353C ** GRAPHICS DEVICE. ** 10354C ********************************************** 10355C 10356 CALL GRTRJU(ITYPE,IJUST,JJUST) 10357C 10358C ************************************ 10359C ** STEP 8-- ** 10360C ** SET THE MARKER JUSTIFICATION ** 10361C ** ON THE GRAPHICS DEVICE. ** 10362C ************************************ 10363C 10364 CALL GRSEJU(ITYPE,IJUST,JJUST) 10365C 10366C ********************************************** 10367C ** STEP 9-- ** 10368C ** TRANSLATE THE CHARACTER REPRESENTATION ** 10369C ** OF THE MARKER DIRECTION (ANGLE) ** 10370C ** INTO A NUMERIC REPRESENTATION ** 10371C ** WHICH CAN BE UNDERSTOOD BY THE ** 10372C ** GRAPHICS DEVICE. ** 10373C ********************************************** 10374C 10375 CALL GRTRDI(ITYPE,IDIR,ANGLE,JDIR,ANGLE2) 10376C 10377C ************************************ 10378C ** STEP 10-- ** 10379C ** SET THE MARKER DIRECTION ** 10380C ** ON THE GRAPHICS DEVICE. ** 10381C ************************************ 10382C 10383 CALL GRSEDI(ITYPE,IDIR,ANGLE,JDIR,ANGLE2) 10384C 10385C ********************************************** 10386C ** STEP 11-- ** 10387C ** TRANSLATE THE CHARACTER REPRESENTATION ** 10388C ** OF THE MARKER FILL (ON/OFF) ** 10389C ** INTO A NUMERIC REPRESENTATION ** 10390C ** WHICH CAN BE UNDERSTOOD BY THE ** 10391C ** GRAPHICS DEVICE. ** 10392C ********************************************** 10393C 10394 CALL GRTRFI(ITYPE,IFILL,JFILL) 10395C 10396C ******************************* 10397C ** STEP 12-- ** 10398C ** SET THE MARKER FILL ** 10399C ** ON THE GRAPHICS DEVICE. ** 10400C ******************************* 10401C 10402 CALL GRSEFI(ITYPE,IFILL,JFILL) 10403C 10404C ********************************************** 10405C ** STEP 13-- ** 10406C ** TRANSLATE THE CHARACTER REPRESENTATION ** 10407C ** OF THE MARKER COLOR ** 10408C ** INTO A NUMERIC REPRESENTATION ** 10409C ** WHICH CAN BE UNDERSTOOD BY THE ** 10410C ** GRAPHICS DEVICE. ** 10411C ********************************************** 10412C 10413 ITYPSV=ITYPE 10414 IF(IFONT.EQ.'TEKT')ITYPE='TEXT' 10415 CALL GRTRCO(ITYPE,ICOL,JCOL) 10416 ITYPE=ITYPSV 10417C 10418C ******************************* 10419C ** STEP 14-- ** 10420C ** SET THE MARKER COLOR ** 10421C ** ON THE GRAPHICS DEVICE. ** 10422C ******************************* 10423C 10424 ITYPSV=ITYPE 10425 IF(IFONT.EQ.'TEKT')ITYPE='TEXT' 10426 CALL GRSECO(ITYPE,ICOL,JCOL) 10427 ITYPE=ITYPSV 10428C 10429C ********************************************** 10430C ** STEP 15-- ** 10431C ** TRANSLATE THE CHARACTER REPRESENTATION ** 10432C ** OF THE MARKER SIZE ** 10433C ** INTO A NUMERIC REPRESENTATION ** 10434C ** WHICH CAN BE UNDERSTOOD BY THE ** 10435C ** GRAPHICS DEVICE. ** 10436C ********************************************** 10437C 10438 CALL GRTRSI(ITYPE,IFONT,PHEIGH,PWIDTH,PVEGAP,PHOGAP, 10439 1JSIZE, 10440 1JHEIG2,JWIDT2,JVEGA2,JHOGA2, 10441 1PHEIG2,PWIDT2,PVEGA2,PHOGA2) 10442C 10443C ************************************ 10444C ** STEP 16-- ** 10445C ** SET THE MARKER SIZE ** 10446C ** ON THE GRAPHICS DEVICE. ** 10447C ************************************ 10448C 10449 CALL GRSESI(ITYPE,IFONT,PHEIGH,PWIDTH,PVEGAP,PHOGAP, 10450 1JSIZE, 10451 1JHEIG2,JWIDT2,JVEGA2,JHOGA2, 10452 1PHEIG2,PWIDT2,PVEGA2,PHOGA2) 10453C 10454C ********************************************** 10455C ** STEP 17-- ** 10456C ** TRANSLATE THE CHARACTER REPRESENTATION ** 10457C ** OF THE MARKER LINE THICKNESS ** 10458C ** INTO A NUMERIC REPRESENTATION ** 10459C ** WHICH CAN BE UNDERSTOOD BY THE ** 10460C ** GRAPHICS DEVICE. ** 10461C ********************************************** 10462C 10463 CALL GRTRTH(ITYPE,PTHICK,JTHICK,PTHIC2) 10464C 10465C ************************************ 10466C ** STEP 18-- ** 10467C ** SET THE MARKER LINE THICKNESS ** 10468C ** ON THE GRAPHICS DEVICE. ** 10469C ************************************ 10470C 10471 CALL GRSETH(ITYPE,PTHICK,JTHICK,PTHIC2) 10472C 10473C ******************************* 10474C ** STEP 19-- ** 10475C ** DRAW OUT THE POLYMARKER ** 10476C ******************************* 10477C 10478 CALL GRDRPM(PX,PY,NP, 10479 1IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 10480 1JPATT,JFONT,JCASE,JJUST,JDIR,ANGLE2,JFILL,JCOL, 10481 1PTHICK,JTHICK,PTHIC2, 10482 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 10483 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 10484 1JHEIG2,JWIDT2,JVEGA2,JHOGA2, 10485 1IMPSW2,AMPSCH,AMPSCW, 10486 1ISYMBL,ISPAC) 10487C 10488C ***************** 10489C ** STEP 90-- ** 10490C ** EXIT ** 10491C ***************** 10492C 10493 9000 CONTINUE 10494 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRPM')GOTO9090 10495 WRITE(ICOUT,999) 10496 CALL DPWRST('XXX','BUG ') 10497 WRITE(ICOUT,9011) 10498 9011 FORMAT('***** AT THE END OF DPDRPM--') 10499 CALL DPWRST('XXX','BUG ') 10500 WRITE(ICOUT,9014)NP 10501 9014 FORMAT('NP = ',I8) 10502 CALL DPWRST('XXX','BUG ') 10503 DO9015I=1,NP 10504 WRITE(ICOUT,9016)PX(I),PY(I) 10505 9016 FORMAT('PX(I),PY(I) = ',E15.7,E15.7) 10506 CALL DPWRST('XXX','BUG ') 10507 9015 CONTINUE 10508 WRITE(ICOUT,9018)IFIG 10509 9018 FORMAT('IFIG = ',A4) 10510 CALL DPWRST('XXX','BUG ') 10511 WRITE(ICOUT,9019)IPATT,JPATT 10512 9019 FORMAT('IPATT,JPATT = ',A4,I8) 10513 CALL DPWRST('XXX','BUG ') 10514 WRITE(ICOUT,9022)IFONT,JFONT 10515 9022 FORMAT('IFONT,JFONT = ',A4,I8) 10516 CALL DPWRST('XXX','BUG ') 10517 WRITE(ICOUT,9023)IJUST,JJUST 10518 9023 FORMAT('IJUST,JJUST = ',A4,I8) 10519 CALL DPWRST('XXX','BUG ') 10520 WRITE(ICOUT,9024)IDIR,ANGLE,JDIR,ANGLE2 10521 9024 FORMAT('IDIR,ANGLE,JDIR,ANGLE2 = ',A4,2X,E15.7,A4,2X,E15.7) 10522 CALL DPWRST('XXX','BUG ') 10523 WRITE(ICOUT,9025)IFILL,JFILL 10524 9025 FORMAT('IFILL,JFILL = ',A4,I8) 10525 CALL DPWRST('XXX','BUG ') 10526 WRITE(ICOUT,9026)ICOL,JCOL 10527 9026 FORMAT('ICOL,JCOL = ',A4,I8) 10528 CALL DPWRST('XXX','BUG ') 10529 WRITE(ICOUT,9027)PHEIGH,PWIDTH,PVEGAP,PHOGAP 10530 9027 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4E15.7) 10531 CALL DPWRST('XXX','BUG ') 10532 WRITE(ICOUT,9028)PHEIG2,PWIDT2,PVEGA2,PHOGA2 10533 9028 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4E15.7) 10534 CALL DPWRST('XXX','BUG ') 10535 WRITE(ICOUT,9029)PTHICK,PTHIC2 10536 9029 FORMAT('PTHICK,PTHIC2 = ',2E15.7) 10537 CALL DPWRST('XXX','BUG ') 10538 WRITE(ICOUT,9031)ISYMBL,ISPAC 10539 9031 FORMAT('ISYMBL,ISPAC = ',A4,2X,A4) 10540 CALL DPWRST('XXX','BUG ') 10541 WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4 10542 9039 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 10543 CALL DPWRST('XXX','BUG ') 10544 9090 CONTINUE 10545C 10546 RETURN 10547 END 10548 SUBROUTINE DPDRSP(Y,X,PY,PX,NP, 10549 1ICASPL,ICAS3D, 10550 1ISORSW, 10551 1ISP2LI,ISP2CO,ISP2DI,PSP2TH,ASP2BA, 10552 1PXMIN,PXMAX,PYMIN,PYMAX, 10553 1FX1MIN,FX1MAX,FY1MIN,FY1MAX, 10554 1IX1TSC,IY1TSC) 10555C 10556C PURPOSE--FOR A GENERAL GRAPHICS DEVICE, 10557C AND FOR EACH VALUE IN X(.), DRAW A SPIKE 10558C (= A VERTICAL OR HORIZONTAL LINE SEGMENT) 10559C FROM THE BASE POINT ASP2BA 10560C TO THE POINT Y(.). 10561C DO SO FOR A SPECIFIED SPIKE LINE TYPE, 10562C LINES COLOR, LINE DIRECTION, AND LINE THICKNESS. 10563C NOTE--THE VARIABLES PY(.) AND PX(.) ARE DUMMY VARIABLES 10564C WHICH ARE USED IN THE INTERMEDIATE CALCULATIONS 10565C AND WHOSE DIMENSIONS ARE DEFINED (FOR EASY OF CHANGE) 10566C BACK IN THE MAIN ROUTINE. 10567C 10568C WRITTEN BY--JAMES J. FILLIBEN 10569C STATISTICAL ENGINEERING DIVISION 10570C INFORMATION TECHNOLOGY LABORATORY 10571C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10572C GAITHERSBURG, MD 20899-8980 10573C PHONE--301-975-2855 10574C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 10575C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 10576C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, 10577C MODIFIED, OR OTHERWISE USED IN A CONTEXT 10578C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. 10579C LANGUAGE--ANSI FORTRAN (1977) 10580C VERSION NUMBER--87.6 10581C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. 10582C UPDATED--APRIL 1987. 10583C UPDATED --SEPTEMBER 1988. RENUMBER 10584C UPDATED --FEBRUARY 1989. CHANGE CALLS FROM GRDRPL TO DPDRPL (ALA 10585C UPDATED --JULY 1990. CHARACTER*4 IPATT TO FIX BOMB 10586C 10587C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- 10588C 10589 CHARACTER*4 ICASPL 10590 CHARACTER*4 ICAS3D 10591C 10592 CHARACTER*4 ISORSW 10593C 10594 CHARACTER*4 ISP2LI 10595 CHARACTER*4 ISP2CO 10596 CHARACTER*4 ISP2DI 10597C 10598 CHARACTER*4 IX1TSC 10599 CHARACTER*4 IY1TSC 10600C 10601 CHARACTER*4 ITYPE 10602C 10603 CHARACTER*4 IFIG 10604 CHARACTER*4 IPATTT 10605CCCCC THE FOLLOWING LINE WAS ADDED TO FIX SPIKE BOMB JULY 1990 10606 CHARACTER*4 IPATT 10607 CHARACTER*4 ICOL 10608 CHARACTER*4 IDIR 10609C 10610C 6/23/86 10611C HOW COME THE FOLLOWING 4 VARIABLES ARE NOT CARRIED 10612C AS INPUT TO THIS SUBROUTINE--NOT NEEDED??? 10613C CHECK ON THIS. 10614C 10615 CHARACTER*4 IHORPA 10616 CHARACTER*4 IVERPA 10617 CHARACTER*4 IDUPPA 10618 CHARACTER*4 IDDOPA 10619CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1989 10620 CHARACTER*4 IFLAG 10621C 10622 DIMENSION Y(*) 10623 DIMENSION X(*) 10624 DIMENSION PY(*) 10625 DIMENSION PX(*) 10626C 10627 DIMENSION PY2(10) 10628 DIMENSION PX2(10) 10629C 10630C-----COMMON---------------------------------------------------------- 10631C 10632 INCLUDE 'DPCOGR.INC' 10633 INCLUDE 'DPCOBE.INC' 10634 INCLUDE 'DPCOP2.INC' 10635C 10636C-----START POINT----------------------------------------------------- 10637C 10638 HOLD=1.0 10639 ABASE=0.0 10640 PBASE=0.0 10641 PBASE2=0.0 10642C 10643 FXMIN=FX1MIN 10644 FXMAX=FX1MAX 10645 FYMIN=FY1MIN 10646 FYMAX=FY1MAX 10647C 10648CCCCC THE FOLLOWING 2 LINES WERE ADDED TO FIX SPIKE BOMB JULY 1990 10649 IPATT='JUNK' 10650 JPATT=(-888) 10651 J=0 10652C 10653 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRSP')GOTO90 10654 WRITE(ICOUT,999) 10655 999 FORMAT(1X) 10656 CALL DPWRST('XXX','BUG ') 10657 WRITE(ICOUT,51) 10658 51 FORMAT('***** AT THE BEGINNING OF DPDRSP--') 10659 CALL DPWRST('XXX','BUG ') 10660 WRITE(ICOUT,52)NP 10661 52 FORMAT('NP = ',I8) 10662 CALL DPWRST('XXX','BUG ') 10663 WRITE(ICOUT,53)ICASPL,ICAS3D 10664 53 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) 10665 CALL DPWRST('XXX','BUG ') 10666 IF(NP.LE.3)GOTO69 10667 DO65I=1,3 10668 WRITE(ICOUT,66)I,X(I),Y(I) 10669 66 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) 10670 CALL DPWRST('XXX','BUG ') 10671 65 CONTINUE 10672 NPM2=NP-2 10673 DO67I=NPM2,NP 10674 WRITE(ICOUT,68)I,X(I),Y(I) 10675 68 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) 10676 CALL DPWRST('XXX','BUG ') 10677 67 CONTINUE 10678 69 CONTINUE 10679 WRITE(ICOUT,70)ISORSW 10680 70 FORMAT('ISORSW = ',A4) 10681 CALL DPWRST('XXX','BUG ') 10682 WRITE(ICOUT,71)ISP2LI 10683 71 FORMAT('ISP2LI= ',A4) 10684 CALL DPWRST('XXX','BUG ') 10685 WRITE(ICOUT,72)ISP2CO,ISP2DI 10686 72 FORMAT('ISP2CO,ISP2DI= ',A4,2X,A4) 10687 CALL DPWRST('XXX','BUG ') 10688 WRITE(ICOUT,73)PSP2TH 10689 73 FORMAT('PSP2TH= ',E15.7) 10690 CALL DPWRST('XXX','BUG ') 10691 WRITE(ICOUT,74)ASP2BA 10692 74 FORMAT('ASP2BA= ',E15.7) 10693 CALL DPWRST('XXX','BUG ') 10694 WRITE(ICOUT,84)PXMIN,PXMAX,PYMIN,PYMAX 10695 84 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4E15.7) 10696 CALL DPWRST('XXX','BUG ') 10697 WRITE(ICOUT,85)FX1MIN,FX1MAX,FY1MIN,FY1MAX 10698 85 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4E15.7) 10699 CALL DPWRST('XXX','BUG ') 10700 WRITE(ICOUT,86)IX1TSC,IY1TSC 10701 86 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4) 10702 CALL DPWRST('XXX','BUG ') 10703 WRITE(ICOUT,89)IBUGG4,ISUBG4,IERRG4 10704 89 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 10705 CALL DPWRST('XXX','BUG ') 10706 90 CONTINUE 10707C 10708C ************************************************* 10709C ** STEP 11-- ** 10710C ** IF CALLED FOR, SORT THE DATA ** 10711C ** ACCORDING TO THE HORIZONTAL AXIS VARIABLE ** 10712C ************************************************* 10713C 10714 IDIR=ISP2DI 10715C 10716 IF(ICASPL.EQ.'TRPL')GOTO9000 10717 IF(ISORSW.EQ.'OFF')GOTO1150 10718 IF(ICASPL.EQ.'PIEC')GOTO1150 10719 IF(ICASPL.EQ.'ROSE')GOTO1150 10720 IF(ICAS3D.EQ.'ON')GOTO1150 10721 IF(ICASPL.EQ.'CONT')GOTO1150 10722C 10723 CALL SORTC(X,Y,NP,PX,PY) 10724 GOTO1190 10725C 10726 1150 CONTINUE 10727 DO1160I=1,NP 10728 PX(I)=X(I) 10729 PY(I)=Y(I) 10730 1160 CONTINUE 10731 GOTO1190 10732C 10733 1190 CONTINUE 10734C 10735C ************************************************ 10736C ** STEP 12-- ** 10737C ** IF A LOG SCALE PLOT IS CALLED FOR, ** 10738C ** CHECK THAT ALL DATA POINTS ARE POSITIVE. ** 10739C ************************************************ 10740C 10741 IF(IX1TSC.EQ.'LOG')GOTO1210 10742 GOTO1290 10743C 10744 1210 CONTINUE 10745 IF(IDIR.EQ.'H')GOTO1215 10746 GOTO1219 10747 1215 CONTINUE 10748 IF(ASP2BA.LE.0.0)HOLD=ASP2BA 10749 IF(ASP2BA.LE.0.0)GOTO1250 10750 1219 CONTINUE 10751C 10752 IF(ISORSW.EQ.'ON')GOTO1220 10753 GOTO1230 10754C 10755 1220 CONTINUE 10756 J=1 10757 IF(PX(J).LE.0.0)GOTO1250 10758 GOTO1290 10759C 10760 1230 CONTINUE 10761 DO1235I=1,NP 10762 J=I 10763 IF(PX(J).LE.0.0)GOTO1250 10764 1235 CONTINUE 10765 GOTO1290 10766C 10767 1250 CONTINUE 10768 WRITE(ICOUT,999) 10769 CALL DPWRST('XXX','BUG ') 10770 WRITE(ICOUT,1251) 10771 1251 FORMAT('***** ERROR IN DPDRSP--') 10772 CALL DPWRST('XXX','BUG ') 10773 WRITE(ICOUT,1252) 10774 1252 FORMAT(' THE LOG OF A NON-POSITIVE DATA VALUE ') 10775 CALL DPWRST('XXX','BUG ') 10776 WRITE(ICOUT,1253) 10777 1253 FORMAT(' WAS ENCOUNTERED IN FORMING A PLOT.') 10778 CALL DPWRST('XXX','BUG ') 10779 WRITE(ICOUT,1254) 10780 1254 FORMAT(' DATA MAY NOT BE ZERO OR NEGATIVE') 10781 CALL DPWRST('XXX','BUG ') 10782 WRITE(ICOUT,1255) 10783 1255 FORMAT(' WHEN A LOG SCALE PLOT IS USED.') 10784 CALL DPWRST('XXX','BUG ') 10785 WRITE(ICOUT,1256)PX(J) 10786 1256 FORMAT(' THE VALUE = ',E15.7) 10787 CALL DPWRST('XXX','BUG ') 10788 WRITE(ICOUT,1257) 10789 1257 FORMAT(' THIS VALUE CAME FROM THE ') 10790 CALL DPWRST('XXX','BUG ') 10791 WRITE(ICOUT,1258) 10792 1258 FORMAT(' HORIZONTAL AXIS VARIABLE.') 10793 CALL DPWRST('XXX','BUG ') 10794 WRITE(ICOUT,1259) 10795 1259 FORMAT(' CORRECTIVE ACTION--') 10796 CALL DPWRST('XXX','BUG ') 10797 WRITE(ICOUT,1260) 10798 1260 FORMAT(' CHANGE DATA OR CHANGE LIMITS.') 10799 CALL DPWRST('XXX','BUG ') 10800 IERRG4='YES' 10801 GOTO9000 10802C 10803 1290 CONTINUE 10804C 10805 IF(IY1TSC.EQ.'LOG')GOTO1310 10806 GOTO1390 10807C 10808 1310 CONTINUE 10809 IF(IDIR.EQ.'V')GOTO1315 10810 GOTO1319 10811 1315 CONTINUE 10812 IF(ASP2BA.LE.0.0)HOLD=ASP2BA 10813 IF(ASP2BA.LE.0.0)GOTO1350 10814 1319 CONTINUE 10815C 10816 IF(ISORSW.EQ.'ON')GOTO1320 10817 GOTO1330 10818C 10819 1320 CONTINUE 10820 J=1 10821 IF(PY(J).LE.0.0)HOLD=PY(J) 10822 IF(PY(J).LE.0.0)GOTO1350 10823 GOTO1390 10824C 10825 1330 CONTINUE 10826 DO1335I=1,NP 10827 J=I 10828 IF(PY(J).LE.0.0)HOLD=PY(J) 10829 IF(PY(J).LE.0.0)GOTO1350 10830 1335 CONTINUE 10831 GOTO1390 10832C 10833 1350 CONTINUE 10834 WRITE(ICOUT,999) 10835 CALL DPWRST('XXX','BUG ') 10836 WRITE(ICOUT,1351) 10837 1351 FORMAT('***** ERROR IN DPDRSP--') 10838 CALL DPWRST('XXX','BUG ') 10839 WRITE(ICOUT,1352) 10840 1352 FORMAT(' THE LOG OF A NON-POSITIVE DATA VALUE ') 10841 CALL DPWRST('XXX','BUG ') 10842 WRITE(ICOUT,1353) 10843 1353 FORMAT(' WAS ENCOUNTERED IN FORMING A PLOT.') 10844 CALL DPWRST('XXX','BUG ') 10845 WRITE(ICOUT,1354) 10846 1354 FORMAT(' DATA MAY NOT BE ZERO OR NEGATIVE') 10847 CALL DPWRST('XXX','BUG ') 10848 WRITE(ICOUT,1355) 10849 1355 FORMAT(' WHEN A LOG SCALE PLOT IS USED.') 10850 CALL DPWRST('XXX','BUG ') 10851 WRITE(ICOUT,1356)HOLD 10852 1356 FORMAT(' THE VALUE = ',E15.7) 10853 CALL DPWRST('XXX','BUG ') 10854 WRITE(ICOUT,1357) 10855 1357 FORMAT(' THIS VALUE CAME FROM THE ') 10856 CALL DPWRST('XXX','BUG ') 10857 WRITE(ICOUT,1358) 10858 1358 FORMAT(' VERTICAL AXIS VARIABLE.') 10859 CALL DPWRST('XXX','BUG ') 10860 WRITE(ICOUT,1359) 10861 1359 FORMAT(' CORRECTIVE ACTION--') 10862 CALL DPWRST('XXX','BUG ') 10863 WRITE(ICOUT,1360) 10864 1360 FORMAT(' CHANGE DATA OR CHANGE LIMITS.') 10865 CALL DPWRST('XXX','BUG ') 10866 IERRG4='YES' 10867 GOTO9000 10868C 10869 1390 CONTINUE 10870C 10871C ****************************************** 10872C ** STEP 40-- ** 10873C ** IF A LOG SCALE PLOT IS CALLED FOR, ** 10874C ** TRANSFORM THE DATA ** 10875C ****************************************** 10876C 10877 ABASE=ASP2BA 10878C 10879 IF(IX1TSC.EQ.'LOG')GOTO4010 10880 GOTO4019 10881 4010 CONTINUE 10882 IF(IDIR.EQ.'H')ABASE=LOG10(ABASE) 10883 DO4015I=1,NP 10884 PX(I)=LOG10(PX(I)) 10885 4015 CONTINUE 10886 4019 CONTINUE 10887C 10888 IF(IY1TSC.EQ.'LOG')GOTO4020 10889 GOTO4029 10890 4020 CONTINUE 10891 IF(IDIR.EQ.'V')ABASE=LOG10(ABASE) 10892 DO4025I=1,NP 10893 PY(I)=LOG10(PY(I)) 10894 4025 CONTINUE 10895 4029 CONTINUE 10896C 10897C ***************************************************** 10898C ** STEP 50-- ** 10899C ** TRANSLATE THE DATA POINTS ** 10900C ** INTO STANDARDIZED (0.0 TO 100.0) COORDINATES. ** 10901C ***************************************************** 10902C 10903 FXMIN=FX1MIN 10904 FXMAX=FX1MAX 10905 IF(IX1TSC.EQ.'LOG')FXMIN=LOG10(FX1MIN) 10906 IF(IX1TSC.EQ.'LOG')FXMAX=LOG10(FX1MAX) 10907C 10908 FYMIN=FY1MIN 10909 FYMAX=FY1MAX 10910 IF(IY1TSC.EQ.'LOG')FYMIN=LOG10(FY1MIN) 10911 IF(IY1TSC.EQ.'LOG')FYMAX=LOG10(FY1MAX) 10912C 10913 FXRANG=FXMAX-FXMIN 10914 FYRANG=FYMAX-FYMIN 10915 PXRANG=PXMAX-PXMIN 10916 PYRANG=PYMAX-PYMIN 10917C 10918 DO5000I=1,NP 10919 FXRATI=(PX(I)-FXMIN)/FXRANG 10920 FYRATI=(PY(I)-FYMIN)/FYRANG 10921 PX(I)=PXMIN+FXRATI*PXRANG 10922 PY(I)=PYMIN+FYRATI*PYRANG 10923 5000 CONTINUE 10924C 10925 IF(IDIR.EQ.'V')GOTO5010 10926 GOTO5019 10927 5010 CONTINUE 10928 FYRATI=(ABASE-FYMIN)/FYRANG 10929 PBASE=PYMIN+FYRATI*PYRANG 10930 5019 CONTINUE 10931C 10932 IF(IDIR.EQ.'H')GOTO5020 10933 GOTO5029 10934 5020 CONTINUE 10935 FXRATI=(ABASE-FXMIN)/FXRANG 10936 PBASE=PXMIN+FXRATI*PXRANG 10937 5029 CONTINUE 10938C 10939C ******************************* 10940C ** STEP 70-- ** 10941C ** PREPARE TO MAKE VARIOUS ** 10942C ** LINE SETTINGS ** 10943C ******************************* 10944C 10945 ITYPE='LINE' 10946C 10947C ********************************************** 10948C ** STEP 71-- ** 10949C ** TRANSLATE THE CHARACTER REPRESENTATION ** 10950C ** OF THE LINE PATTERN ** 10951C ** INTO A NUMERIC REPRESENTATION ** 10952C ** WHICH CAN BE UNDERSTOOD BY THE ** 10953C ** GRAPHICS DEVICE. ** 10954C ********************************************** 10955C 10956 IPATTT=ISP2LI 10957 CALL GRTRPA(ITYPE,IPATTT,PXSPA,PYSPA, 10958 1JPATTT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) 10959C 10960C ******************************* 10961C ** STEP 72-- ** 10962C ** SET THE LINE PATTERN ** 10963C ** ON THE GRAPHICS DEVICE. ** 10964C ******************************* 10965C 10966 CALL GRSEPA(ITYPE,IPATTT,PXSPA,PYSPA, 10967 1JPATTT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) 10968C 10969C ********************************************** 10970C ** STEP 73-- ** 10971C ** TRANSLATE THE DESIRED ** 10972C ** LINE THICKNESS ** 10973C ** INTO A NUMERIC REPRESENTATION ** 10974C ** WHICH CAN BE UNDERSTOOD BY THE ** 10975C ** GRAPHICS DEVICE. ** 10976C ********************************************** 10977C 10978 PTHICK=PSP2TH 10979 CALL GRTRTH(ITYPE,PTHICK,JTHICK,PTHIC2) 10980C 10981C ******************************* 10982C ** STEP 74-- ** 10983C ** SET THE LINE THICKNESS ** 10984C ** ON THE GRAPHICS DEVICE. ** 10985C ******************************* 10986C 10987 CALL GRSETH(ITYPE,PTHICK,JTHICK,PTHIC2) 10988C 10989C ********************************************** 10990C ** STEP 75-- ** 10991C ** TRANSLATE THE CHARACTER REPRESENTATION ** 10992C ** OF THE LINE COLOR ** 10993C ** INTO A NUMERIC REPRESENTATION ** 10994C ** WHICH CAN BE UNDERSTOOD BY THE ** 10995C ** GRAPHICS DEVICE. ** 10996C ********************************************** 10997C 10998 ICOL=ISP2CO 10999 CALL GRTRCO(ITYPE,ICOL,JCOL) 11000C 11001C ******************************* 11002C ** STEP 76-- ** 11003C ** SET THE LINE COLOR ** 11004C ** ON THE GRAPHICS DEVICE. ** 11005C ******************************* 11006C 11007 CALL GRSECO(ITYPE,ICOL,JCOL) 11008C 11009C ************************************** 11010C ** STEP 81-- ** 11011C ** DRAW OUT ALL SPIKES ** 11012C ** (BUT CLIP FIRST, IF NECESSARY) ** 11013C ************************************** 11014C 11015 IFIG='GENE' 11016C 11017 CALL DPSQUE(PX,PY,NP, 11018 1PXMIN,PXMAX,PYMIN,PYMAX) 11019C 11020 IF(IDIR.EQ.'V')GOTO7100 11021 GOTO7190 11022 7100 CONTINUE 11023 PBASE2=PBASE 11024 IF(PBASE2.LT.PYMIN.AND.(PYMIN-PBASE2).LE.0.0001)PBASE2=PYMIN 11025 IF(PBASE2.GT.PYMAX.AND.(PBASE2-PYMAX).LE.0.0001)PBASE2=PYMAX 11026C 11027CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1989 11028 IFLAG='OFF' 11029 NP2=2 11030 DO7110I=1,NP 11031C 11032 IF(PX(I).LT.PXMIN)GOTO7110 11033 IF(PX(I).GT.PXMAX)GOTO7110 11034 IF(PY(I).LT.PYMIN.AND.PBASE2.LT.PYMIN)GOTO7110 11035 IF(PY(I).GT.PYMAX.AND.PBASE2.GT.PYMAX)GOTO7110 11036C 11037 PX2(1)=PX(I) 11038 PX2(2)=PX(I) 11039C 11040 PY2(1)=PBASE2 11041 PY2(2)=PY(I) 11042C 11043 DO7150J=1,NP2 11044 IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN 11045 IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 11046 7150 CONTINUE 11047C 11048CCCCC THE FOLLOWING 3 LINES WERE COMMENTED OUT FEBRUARY 1989 11049CCCCC AND REPLACED BY THE SUBSEQUENT 3 LINES (ALAN) FEBRUARY 1989 11050CCCCC CALL GRDRPL(PX2,PY2,NP2, 11051CCCCC1IFIG,IPATTT,PTHICK,ICOL, 11052CCCCC1JPATTT,JTHICK,PTHIC2,JCOL) 11053 CALL DPDRPL(PX2,PY2,NP2, 11054 1IFIG,IPATT,PTHICK,ICOL, 11055CCCCC THE FOLLOWING LINE WAS TEMPORARILY FIXED JULY 9, 1990 11056CCCCC1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 11057 1JPATTT,JTHICK,PTHIC2,JCOL,IFLAG) 11058C 11059C 11060 7110 CONTINUE 11061 7190 CONTINUE 11062C 11063 IF(IDIR.EQ.'H')GOTO7200 11064 GOTO7290 11065 7200 CONTINUE 11066CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1989 11067 IFLAG='OFF' 11068 PBASE2=PBASE 11069 IF(PBASE2.LT.PXMIN.AND.(PXMIN-PBASE2).LE.0.0001)PBASE2=PXMIN 11070 IF(PBASE2.GT.PXMAX.AND.(PBASE2-PXMAX).LE.0.0001)PBASE2=PXMAX 11071C 11072 NP2=2 11073 DO7210I=1,NP 11074C 11075 IF(PY(I).LT.PYMIN)GOTO7210 11076 IF(PY(I).GT.PYMAX)GOTO7210 11077 IF(PX(I).LT.PXMIN.AND.PBASE2.LT.PXMIN)GOTO7210 11078 IF(PX(I).GT.PXMAX.AND.PBASE2.GT.PXMAX)GOTO7210 11079C 11080 PX2(1)=PBASE2 11081 PX2(2)=PX(I) 11082C 11083 PY2(1)=PY(I) 11084 PY2(2)=PY(I) 11085C 11086 DO7250J=1,NP2 11087 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN 11088 IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX 11089 7250 CONTINUE 11090C 11091CCCCC THE FOLLOWING 3 LINES WERE COMMENTED OUT FEBRUARY 1989 11092CCCCC AND REPLACED BY THE SUBSEQUENT 3 LINES (ALAN) FEBRUARY 1989 11093CCCCC CALL GRDRPL(PX2,PY2,NP2, 11094CCCCC1IFIG,IPATTT,PTHICK,ICOL, 11095CCCCC1JPATTT,JTHICK,PTHIC2,JCOL) 11096 CALL DPDRPL(PX2,PY2,NP2, 11097 1IFIG,IPATT,PTHICK,ICOL, 11098CCCCC THE FOLLOWING LINE WAS TEMPORARILY FIXED JULY 9, 1990 11099CCCCC1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 11100 1JPATTT,JTHICK,PTHIC2,JCOL,IFLAG) 11101C 11102 7210 CONTINUE 11103 7290 CONTINUE 11104C 11105C ***************** 11106C ** STEP 90-- ** 11107C ** EXIT ** 11108C ***************** 11109C 11110 9000 CONTINUE 11111 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRSP')GOTO9090 11112 WRITE(ICOUT,999) 11113 CALL DPWRST('XXX','BUG ') 11114 WRITE(ICOUT,9011) 11115 9011 FORMAT('***** AT THE END OF DPDRSP--') 11116 CALL DPWRST('XXX','BUG ') 11117 WRITE(ICOUT,9012)NP 11118 9012 FORMAT('NP = ',I8) 11119 CALL DPWRST('XXX','BUG ') 11120 WRITE(ICOUT,9013)ICASPL,ICAS3D 11121 9013 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) 11122 CALL DPWRST('XXX','BUG ') 11123 WRITE(ICOUT,9014)HOLD 11124 9014 FORMAT('HOLD = ',E15.7) 11125 CALL DPWRST('XXX','BUG ') 11126 WRITE(ICOUT,9015)ABASE,PBASE,PBASE2 11127 9015 FORMAT('ABASE,PBASE,PBASE2 = ',3E15.7) 11128 CALL DPWRST('XXX','BUG ') 11129 IF(NP.LE.3)GOTO9029 11130 DO9025I=1,3 11131 WRITE(ICOUT,9026)I,X(I),Y(I) 11132 9026 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) 11133 CALL DPWRST('XXX','BUG ') 11134 9025 CONTINUE 11135 NPM2=NP-2 11136 DO9027I=NPM2,NP 11137 WRITE(ICOUT,9028)I,X(I),Y(I) 11138 9028 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) 11139 CALL DPWRST('XXX','BUG ') 11140 9027 CONTINUE 11141 9029 CONTINUE 11142 WRITE(ICOUT,9030)ISORSW 11143 9030 FORMAT('ISORSW = ',A4) 11144 CALL DPWRST('XXX','BUG ') 11145 WRITE(ICOUT,9031)ISP2LI 11146 9031 FORMAT('ISP2LI= ',A4) 11147 CALL DPWRST('XXX','BUG ') 11148 WRITE(ICOUT,9032)PSP2TH 11149 9032 FORMAT('PSP2TH= ',E15.7) 11150 CALL DPWRST('XXX','BUG ') 11151 WRITE(ICOUT,9033)ISP2CO,ISP2DI 11152 9033 FORMAT('ISP2CO,ISP2DI= ',A4,2X,A4) 11153 CALL DPWRST('XXX','BUG ') 11154 WRITE(ICOUT,9044)PXMIN,PXMAX,PYMIN,PYMAX 11155 9044 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4E15.7) 11156 CALL DPWRST('XXX','BUG ') 11157 WRITE(ICOUT,9045)FX1MIN,FX1MAX,FY1MIN,FY1MAX 11158 9045 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4E15.7) 11159 CALL DPWRST('XXX','BUG ') 11160 WRITE(ICOUT,9046)FXMIN,FXMAX,FYMIN,FYMAX 11161 9046 FORMAT('FXMIN,FXMAX,FYMIN,FYMAX= ',4E15.7) 11162 CALL DPWRST('XXX','BUG ') 11163 WRITE(ICOUT,9047)IX1TSC,IY1TSC 11164 9047 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4) 11165 CALL DPWRST('XXX','BUG ') 11166 WRITE(ICOUT,9051)IFIG 11167 9051 FORMAT('IFIG = ',A4) 11168 CALL DPWRST('XXX','BUG ') 11169CCCCC THE FOLLOWING 2 LINES WERE AUGMENTED JULY 1990 11170CCCCC WRITE(ICOUT,9052)IPATTT,JPATTT 11171C9052 FORMAT('IPATTT,JPATTT = ',A4,I8) 11172CCCCC CALL DPWRST('XXX','BUG ') 11173 WRITE(ICOUT,9052)IPATT,IPATTT,JPATTT 11174 9052 FORMAT('IPATT,IPATTT,JPATTT = ',A4,2X,A4,I8) 11175 CALL DPWRST('XXX','BUG ') 11176 WRITE(ICOUT,9053)PTHICK,JTHICK,PTHIC2 11177 9053 FORMAT('PTHICK,JTHICK,PTHIC2 = ',E15.7,I8,E15.7) 11178 CALL DPWRST('XXX','BUG ') 11179 WRITE(ICOUT,9054)ICOL,JCOL,IDIR 11180 9054 FORMAT('ICOL,JCOL,IDIR = ',A4,I8,2X,A4) 11181 CALL DPWRST('XXX','BUG ') 11182 WRITE(ICOUT,9055)ITYPE 11183 9055 FORMAT('ITYPE = ',A4) 11184 CALL DPWRST('XXX','BUG ') 11185 WRITE(ICOUT,9069)IBUGG4,ISUBG4,IERRG4 11186 9069 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 11187 CALL DPWRST('XXX','BUG ') 11188 9090 CONTINUE 11189C 11190 RETURN 11191 END 11192 SUBROUTINE DPDRTM(PXMIN,PYMIN,PXMAX,PYMAX, 11193 1 FXMIN,FYMIN,FXMAX,FYMAX, 11194 1 ICASPL,ICAS3D, 11195 1 IX1FSW,IX2FSW,IY1FSW,IY2FSW, 11196 1 IX1TSW,IX2TSW,IY1TSW,IY2TSW, 11197 1 PX1COO,PX2COO,PY1COO,PY2COO, 11198 1 NX1COO,NX2COO,NY1COO,NY2COO, 11199 1 PX1CMN,PX2CMN,PY1CMN,PY2CMN, 11200 1 NX1CMN,NX2CMN,NY1CMN,NY2CMN, 11201 1 PX1TLE,PX2TLE,PY1TLE,PY2TLE, 11202 1 PTICTH,PMNTFA, 11203 1 IX1TJU,IX2TJU,IY1TJU,IY2TJU, 11204 1 IX1TCO,IX2TCO,IY1TCO,IY2TCO) 11205C 11206C PURPOSE--DRAW TIC MARKS ON THE FRAME LINES. 11207C WRITTEN BY--JAMES J. FILLIBEN 11208C STATISTICAL ENGINEERING DIVISION 11209C INFORMATION TECHNOLOGY LABORATORY 11210C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11211C GAITHERSBURG, MD 20899-8980 11212C PHONE--301-975-2855 11213C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11214C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11215C LANGUAGE--ANSI FORTRAN (1977) 11216C VERSION NUMBER--83.6 11217C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. 11218C UPDATED --FEBRUARY 1988. STAR PLOT 11219C UPDATED --JANUARY 1989. CALL DPDRPL RATHER THAN GRDRPL (ALAN) 11220C 11221C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- 11222C 11223 CHARACTER*4 ICASPL 11224 CHARACTER*4 ICAS3D 11225C 11226 CHARACTER*4 IX1FSW 11227 CHARACTER*4 IX2FSW 11228 CHARACTER*4 IY1FSW 11229 CHARACTER*4 IY2FSW 11230C 11231 CHARACTER*4 IX1TSW 11232 CHARACTER*4 IX2TSW 11233 CHARACTER*4 IY1TSW 11234 CHARACTER*4 IY2TSW 11235C 11236 CHARACTER*4 IX1TJU 11237 CHARACTER*4 IX2TJU 11238 CHARACTER*4 IY1TJU 11239 CHARACTER*4 IY2TJU 11240C 11241 CHARACTER*4 IX1TCO 11242 CHARACTER*4 IX2TCO 11243 CHARACTER*4 IY1TCO 11244 CHARACTER*4 IY2TCO 11245C 11246 CHARACTER*4 ITYPE 11247 CHARACTER*4 IFIG 11248 CHARACTER*4 IPATT 11249 CHARACTER*4 ICOL 11250 CHARACTER*4 IHORPA 11251 CHARACTER*4 IVERPA 11252 CHARACTER*4 IDUPPA 11253 CHARACTER*4 IDDOPA 11254C 11255 CHARACTER*4 IFLAG 11256C 11257 DIMENSION PX1COO(*) 11258 DIMENSION PX2COO(*) 11259 DIMENSION PY1COO(*) 11260 DIMENSION PY2COO(*) 11261C 11262 DIMENSION PX1CMN(*) 11263 DIMENSION PX2CMN(*) 11264 DIMENSION PY1CMN(*) 11265 DIMENSION PY2CMN(*) 11266C 11267 DIMENSION PX(100) 11268 DIMENSION PY(100) 11269C 11270C-----COMMON---------------------------------------------------------- 11271C 11272 INCLUDE 'DPCOGR.INC' 11273 INCLUDE 'DPCOBE.INC' 11274 INCLUDE 'DPCOP2.INC' 11275C 11276C-----START POINT----------------------------------------------------- 11277C 11278 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRTM')THEN 11279 WRITE(ICOUT,999) 11280 999 FORMAT(1X) 11281 CALL DPWRST('XXX','BUG ') 11282 WRITE(ICOUT,51) 11283 51 FORMAT('***** AT THE BEGINNING OF DPDRTM--') 11284 CALL DPWRST('XXX','BUG ') 11285 WRITE(ICOUT,52)PXMIN,PYMIN,PXMAX,PYMAX 11286 52 FORMAT('PXMIN,PYMIN,PXMAX,PYMAX = ',4F10.5) 11287 CALL DPWRST('XXX','BUG ') 11288 WRITE(ICOUT,42)FXMIN,FYMIN,FXMAX,FYMAX 11289 42 FORMAT('FXMIN,FYMIN,FXMAX,FYMAX = ',4F10.5) 11290 CALL DPWRST('XXX','BUG ') 11291 WRITE(ICOUT,53)IBUGG4,ISUBG4,IERRG4,ICASPL,ICAS3D 11292 53 FORMAT('IBUGG4,ISUBG4,IERRG4,ICASPL,ICAS3D = ',4(A4,2X),A4) 11293 CALL DPWRST('XXX','BUG ') 11294 WRITE(ICOUT,54)IX1FSW,IX2FSW,IY1FSW,IY2FSW 11295 54 FORMAT('IX1FSW,IX2FSW,IY1FSW,IY2FSW = ',3(A4,2X),A4) 11296 CALL DPWRST('XXX','BUG ') 11297 WRITE(ICOUT,55)IX1TSW,IX2TSW,IY1TSW,IY2TSW 11298 55 FORMAT('IX1TSW,IX2TSW,IY1TSW,IY2TSW = ',3(A4,2X),A4) 11299 CALL DPWRST('XXX','BUG ') 11300 WRITE(ICOUT,56)PTICTH,PMNTFA 11301 56 FORMAT('PTICTH,PMNTFA = ',2E15.7) 11302 CALL DPWRST('XXX','BUG ') 11303 WRITE(ICOUT,57)IX1TJU,IX2TJU,IY1TJU,IY2TJU 11304 57 FORMAT('IX1TJU,IX2TJU,IY1TJU,IY2TJU = ',3(A4,2X),A4) 11305 CALL DPWRST('XXX','BUG ') 11306 WRITE(ICOUT,58)IX1TCO,IX2TCO,IY1TCO,IY2TCO 11307 58 FORMAT('IX1TCO,IX2TCO,IY1TCO,IY2TCO = ',3(A4,2X),A4) 11308 CALL DPWRST('XXX','BUG ') 11309 WRITE(ICOUT,59)NX1COO,NX2COO,NY1COO,NY2COO 11310 59 FORMAT('NX1COO,NX2COO,NY1COO,NY2COO = ',4I8) 11311 CALL DPWRST('XXX','BUG ') 11312 WRITE(ICOUT,60)NX1CMN,NX2CMN,NY1CMN,NY2CMN 11313 60 FORMAT('NX1CMN,NX2CMN,NY1CMN,NY2CMN = ',4I8) 11314 CALL DPWRST('XXX','BUG ') 11315C 11316 IF(NX1COO.GT.0)THEN 11317 WRITE(ICOUT,999) 11318 CALL DPWRST('XXX','BUG ') 11319 DO61I=1,NX1COO 11320 WRITE(ICOUT,62)I,PX1COO(I) 11321 62 FORMAT('I,PX1COO(I) = ',I8,E15.7) 11322 CALL DPWRST('XXX','BUG ') 11323 61 CONTINUE 11324 ENDIF 11325C 11326 IF(NX2COO.GT.0)THEN 11327 WRITE(ICOUT,999) 11328 CALL DPWRST('XXX','BUG ') 11329 DO71I=1,NX2COO 11330 WRITE(ICOUT,72)I,PX2COO(I) 11331 72 FORMAT('I,PX2COO(I) = ',I8,E15.7) 11332 CALL DPWRST('XXX','BUG ') 11333 71 CONTINUE 11334 ENDIF 11335C 11336 IF(NY1COO.GT.0)THEN 11337 WRITE(ICOUT,999) 11338 CALL DPWRST('XXX','BUG ') 11339 DO81I=1,NY1COO 11340 WRITE(ICOUT,82)I,PY1COO(I) 11341 82 FORMAT('I,PY1COO(I) = ',I8,E15.7) 11342 CALL DPWRST('XXX','BUG ') 11343 81 CONTINUE 11344 ENDIF 11345C 11346 IF(NY2COO.GT.0)THEN 11347 WRITE(ICOUT,999) 11348 CALL DPWRST('XXX','BUG ') 11349 DO91I=1,NY2COO 11350 WRITE(ICOUT,92)I,PY2COO(I) 11351 92 FORMAT('I,PY2COO(I) = ',I8,E15.7) 11352 CALL DPWRST('XXX','BUG ') 11353 91 CONTINUE 11354 ENDIF 11355C 11356 ENDIF 11357C 11358 IF(ICASPL.EQ.'PIEC')GOTO9000 11359 IF(ICASPL.EQ.'ROSE')GOTO9000 11360 IF(ICASPL.EQ.'STAR')GOTO9000 11361 IF(ICAS3D.EQ.'ON')GOTO9000 11362 IF(ICASPL.EQ.'TRPL')GOTO2000 11363C 11364 ITYPE='LINE' 11365C 11366C *************************************************** 11367C ** STEP 1-- ** 11368C ** THE TIC MARKS WILL HAVE SOLID LINE PATTERN. ** 11369C ** TRANSLATE THIS SOLID LINE PATTERN ** 11370C ** INTO A NUMBER WHICH CAN BE UNDERSTOOD ** 11371C ** BY THE GRAPHICS DEVICE. ** 11372C *************************************************** 11373C 11374 IFIG='LINE' 11375 IPATT='SOLI' 11376 CALL GRTRPA(ITYPE,IPATT,PXSPA,PYSPA, 11377 1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) 11378C 11379C ********************************** 11380C ** STEP 2-- ** 11381C ** SET THE LINE TYPE TO SOLID ** 11382C ** ON THE GRAPHICS DEVICE. ** 11383C ********************************** 11384C 11385 CALL GRSEPA(ITYPE,IPATT,PXSPA,PYSPA, 11386 1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2) 11387C 11388C ********************************************** 11389C ** STEP 3-- ** 11390C ** TRANSLATE THE CHARACTER REPRESENTATION ** 11391C ** OF THE TIC THICKNESS ** 11392C ** INTO A NUMERIC REPRESENTATION ** 11393C ** WHICH CAN BE UNDERSTOOD BY THE ** 11394C ** GRAPHICS DEVICE. ** 11395C ********************************************** 11396C 11397 PTHICK=PTICTH 11398 CALL GRTRTH(ITYPE,PTHICK,JTHICK,PTHIC2) 11399C 11400C ******************************* 11401C ** STEP 4-- ** 11402C ** SET THE LINE THICKNESS ** 11403C ** ON THE GRAPHICS DEVICE. ** 11404C ******************************* 11405C 11406 CALL GRSETH(ITYPE,PTHICK,JTHICK,PTHIC2) 11407C 11408C ****************************************************** 11409C ** STEP 7-- ** 11410C ** DRAW MAJOR TIC MARKS ON BOTTOM HORIZONTAL AXIS ** 11411C ** DRAW MINOR TIC MARKS ON BOTTOM HORIZONTAL AXIS ** 11412C ****************************************************** 11413C 11414 IF(IX1FSW.EQ.'OFF')GOTO1190 11415 IF(IX1TSW.EQ.'OFF')GOTO1190 11416C 11417 ICOL=IX1TCO 11418 CALL GRTRCO(ITYPE,ICOL,JCOL) 11419 CALL GRSECO(ITYPE,ICOL,JCOL) 11420C 11421 PMJTLE=PX1TLE 11422C 11423 PY(1)=PYMIN 11424 PY(2)=PYMIN 11425 IF(IX1TJU.EQ.'THRU')PY(1)=PYMIN+PMJTLE/2.0 11426 IF(IX1TJU.EQ.'THRU')PY(2)=PYMIN-PMJTLE/2.0 11427 IF(IX1TJU.EQ.'IN')PY(1)=PYMIN+PMJTLE 11428 IF(IX1TJU.EQ.'INSI')PY(1)=PYMIN+PMJTLE 11429 IF(IX1TJU.EQ.'OUT')PY(1)=PYMIN-PMJTLE 11430 IF(IX1TJU.EQ.'OUTS')PY(1)=PYMIN-PMJTLE 11431C 11432 IF(NX1COO.LE.0)GOTO1190 11433 NP=2 11434 IFLAG='OFF' 11435 DO1110I=1,NX1COO 11436 PX(1)=PX1COO(I) 11437 PX(2)=PX1COO(I) 11438CCCCC CALL GRDRPL(PX,PY,NP, 11439CCCCC1IFIG,IPATT,PTHICK,ICOL, 11440CCCCC1JPATT,JTHICK,PTHIC2,JCOL) 11441 CALL DPDRPL(PX,PY,NP, 11442 1IFIG,IPATT,PTHICK,ICOL, 11443 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 11444 1110 CONTINUE 11445C 11446 PMNTLE=PMJTLE*PMNTFA 11447C 11448 PY(1)=PYMIN 11449 PY(2)=PYMIN 11450 IF(IX1TJU.EQ.'THRU')PY(1)=PYMIN+PMNTLE/2.0 11451 IF(IX1TJU.EQ.'THRU')PY(2)=PYMIN-PMNTLE/2.0 11452 IF(IX1TJU.EQ.'IN')PY(1)=PYMIN+PMNTLE 11453 IF(IX1TJU.EQ.'INSI')PY(1)=PYMIN+PMNTLE 11454 IF(IX1TJU.EQ.'OUT')PY(1)=PYMIN-PMNTLE 11455 IF(IX1TJU.EQ.'OUTS')PY(1)=PYMIN-PMNTLE 11456C 11457 IF(NX1CMN.LE.0)GOTO1190 11458 NP=2 11459 IFLAG='OFF' 11460 DO1120I=1,NX1CMN 11461 PX(1)=PX1CMN(I) 11462 PX(2)=PX1CMN(I) 11463CCCCC CALL GRDRPL(PX,PY,NP, 11464CCCCC1IFIG,IPATT,PTHICK,ICOL, 11465CCCCC1JPATT,JTHICK,PTHIC2,JCOL) 11466 CALL DPDRPL(PX,PY,NP, 11467 1IFIG,IPATT,PTHICK,ICOL, 11468 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 11469 1120 CONTINUE 11470C 11471 1190 CONTINUE 11472C 11473C ****************************************************** 11474C ** STEP 8-- ** 11475C ** DRAW MAJOR TIC MARKS ON TOP HORIZONTAL AXIS ** 11476C ** DRAW MINOR TIC MARKS ON TOP HORIZONTAL AXIS ** 11477C ****************************************************** 11478C 11479 IF(IX2FSW.EQ.'OFF')GOTO1290 11480 IF(IX2TSW.EQ.'OFF')GOTO1290 11481C 11482 ICOL=IX2TCO 11483 CALL GRTRCO(ITYPE,ICOL,JCOL) 11484 CALL GRSECO(ITYPE,ICOL,JCOL) 11485C 11486 PMJTLE=PX2TLE 11487C 11488 PY(1)=PYMAX 11489 PY(2)=PYMAX 11490 IF(IX2TJU.EQ.'THRU')PY(1)=PYMAX+PMJTLE/2.0 11491 IF(IX2TJU.EQ.'THRU')PY(2)=PYMAX-PMJTLE/2.0 11492 IF(IX2TJU.EQ.'IN')PY(1)=PYMAX-PMJTLE 11493 IF(IX2TJU.EQ.'INSI')PY(1)=PYMAX-PMJTLE 11494 IF(IX2TJU.EQ.'OUT')PY(1)=PYMAX+PMJTLE 11495 IF(IX2TJU.EQ.'OUTS')PY(1)=PYMAX+PMJTLE 11496C 11497 IF(NX2COO.LE.0)GOTO1290 11498 NP=2 11499 IFLAG='OFF' 11500 DO1210I=1,NX2COO 11501 PX(1)=PX2COO(I) 11502 PX(2)=PX2COO(I) 11503CCCCC CALL GRDRPL(PX,PY,NP, 11504CCCCC1IFIG,IPATT,PTHICK,ICOL, 11505CCCCC1JPATT,JTHICK,PTHIC2,JCOL) 11506 CALL DPDRPL(PX,PY,NP, 11507 1IFIG,IPATT,PTHICK,ICOL, 11508 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 11509 1210 CONTINUE 11510C 11511 PMNTLE=PMJTLE*PMNTFA 11512C 11513 PY(1)=PYMAX 11514 PY(2)=PYMAX 11515 IF(IX2TJU.EQ.'THRU')PY(1)=PYMAX+PMNTLE/2.0 11516 IF(IX2TJU.EQ.'THRU')PY(2)=PYMAX-PMNTLE/2.0 11517 IF(IX2TJU.EQ.'IN')PY(1)=PYMAX-PMNTLE 11518 IF(IX2TJU.EQ.'INSI')PY(1)=PYMAX-PMNTLE 11519 IF(IX2TJU.EQ.'OUT')PY(1)=PYMAX+PMNTLE 11520 IF(IX2TJU.EQ.'OUTS')PY(1)=PYMAX+PMNTLE 11521C 11522 IF(NX2CMN.LE.0)GOTO1290 11523 NP=2 11524 IFLAG='OFF' 11525 DO1220I=1,NX2CMN 11526 PX(1)=PX2CMN(I) 11527 PX(2)=PX2CMN(I) 11528CCCCC CALL GRDRPL(PX,PY,NP, 11529CCCCC1IFIG,IPATT,PTHICK,ICOL, 11530CCCCC1JPATT,JTHICK,PTHIC2,JCOL) 11531 CALL DPDRPL(PX,PY,NP, 11532 1IFIG,IPATT,PTHICK,ICOL, 11533 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 11534 1220 CONTINUE 11535C 11536 1290 CONTINUE 11537C 11538C ****************************************************** 11539C ** STEP 9-- ** 11540C ** DRAW MAJOR TIC MARKS ON LEFT VERTICAL AXIS ** 11541C ** DRAW MINOR TIC MARKS ON LEFT VERTICAL AXIS ** 11542C ****************************************************** 11543C 11544 IF(IY1FSW.EQ.'OFF')GOTO1390 11545 IF(IY1TSW.EQ.'OFF')GOTO1390 11546C 11547 ICOL=IY1TCO 11548 CALL GRTRCO(ITYPE,ICOL,JCOL) 11549 CALL GRSECO(ITYPE,ICOL,JCOL) 11550C 11551 PMJTLE=PY1TLE*(ANUMVP/ANUMHP) 11552C 11553 PX(1)=PXMIN 11554 PX(2)=PXMIN 11555 IF(IY1TJU.EQ.'THRU')PX(1)=PXMIN-PMJTLE/2.0 11556 IF(IY1TJU.EQ.'THRU')PX(2)=PXMIN+PMJTLE/2.0 11557 IF(IY1TJU.EQ.'IN')PX(1)=PXMIN+PMJTLE 11558 IF(IY1TJU.EQ.'INSI')PX(1)=PXMIN+PMJTLE 11559 IF(IY1TJU.EQ.'OUT')PX(1)=PXMIN-PMJTLE 11560 IF(IY1TJU.EQ.'OUTS')PX(1)=PXMIN-PMJTLE 11561C 11562 IF(NY1COO.LE.0)GOTO1390 11563 NP=2 11564 IFLAG='OFF' 11565 DO1310I=1,NY1COO 11566 PY(1)=PY1COO(I) 11567 PY(2)=PY1COO(I) 11568CCCCC CALL GRDRPL(PX,PY,NP, 11569CCCCC1IFIG,IPATT,PTHICK,ICOL, 11570CCCCC1JPATT,JTHICK,PTHIC2,JCOL) 11571 CALL DPDRPL(PX,PY,NP, 11572 1IFIG,IPATT,PTHICK,ICOL, 11573 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 11574 1310 CONTINUE 11575C 11576 PMNTLE=PMJTLE*PMNTFA 11577C 11578 PX(1)=PXMIN 11579 PX(2)=PXMIN 11580 IF(IY1TJU.EQ.'THRU')PX(1)=PXMIN-PMNTLE/2.0 11581 IF(IY1TJU.EQ.'THRU')PX(2)=PXMIN+PMNTLE/2.0 11582 IF(IY1TJU.EQ.'IN')PX(1)=PXMIN+PMNTLE 11583 IF(IY1TJU.EQ.'INSI')PX(1)=PXMIN+PMNTLE 11584 IF(IY1TJU.EQ.'OUT')PX(1)=PXMIN-PMNTLE 11585 IF(IY1TJU.EQ.'OUTS')PX(1)=PXMIN-PMNTLE 11586C 11587 IF(NY1CMN.LE.0)GOTO1390 11588 NP=2 11589 IFLAG='OFF' 11590 DO1320I=1,NY1CMN 11591 PY(1)=PY1CMN(I) 11592 PY(2)=PY1CMN(I) 11593CCCCC CALL GRDRPL(PX,PY,NP, 11594CCCCC1IFIG,IPATT,PTHICK,ICOL, 11595CCCCC1JPATT,JTHICK,PTHIC2,JCOL) 11596 CALL DPDRPL(PX,PY,NP, 11597 1IFIG,IPATT,PTHICK,ICOL, 11598 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 11599 1320 CONTINUE 11600C 11601 1390 CONTINUE 11602C 11603C ****************************************************** 11604C ** STEP 10-- ** 11605C ** DRAW MAJOR TIC MARKS ON RIGHT VERTICAL AXIS ** 11606C ** DRAW MINOR TIC MARKS ON RIGHT VERTICAL AXIS ** 11607C ****************************************************** 11608C 11609 IF(IY2FSW.EQ.'OFF')GOTO1490 11610 IF(IY2TSW.EQ.'OFF')GOTO1490 11611C 11612 ICOL=IY2TCO 11613 CALL GRTRCO(ITYPE,ICOL,JCOL) 11614 CALL GRSECO(ITYPE,ICOL,JCOL) 11615C 11616 PMJTLE=PY2TLE*(ANUMVP/ANUMHP) 11617C 11618 PX(1)=PXMAX 11619 PX(2)=PXMAX 11620 IF(IY2TJU.EQ.'THRU')PX(1)=PXMAX-PMJTLE/2.0 11621 IF(IY2TJU.EQ.'THRU')PX(2)=PXMAX+PMJTLE/2.0 11622 IF(IY2TJU.EQ.'IN')PX(1)=PXMAX-PMJTLE 11623 IF(IY2TJU.EQ.'INSI')PX(1)=PXMAX-PMJTLE 11624 IF(IY2TJU.EQ.'OUT')PX(1)=PXMAX+PMJTLE 11625 IF(IY2TJU.EQ.'OUTS')PX(1)=PXMAX+PMJTLE 11626C 11627 IF(NY2COO.LE.0)GOTO1490 11628 NP=2 11629 IFLAG='OFF' 11630 DO1410I=1,NY2COO 11631 PY(1)=PY2COO(I) 11632 PY(2)=PY2COO(I) 11633CCCCC CALL GRDRPL(PX,PY,NP, 11634CCCCC1IFIG,IPATT,PTHICK,ICOL, 11635CCCCC1JPATT,JTHICK,PTHIC2,JCOL) 11636 CALL DPDRPL(PX,PY,NP, 11637 1IFIG,IPATT,PTHICK,ICOL, 11638 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 11639 1410 CONTINUE 11640C 11641 PMNTLE=PMJTLE*PMNTFA 11642C 11643 PX(1)=PXMAX 11644 PX(2)=PXMAX 11645 IF(IY2TJU.EQ.'THRU')PX(1)=PXMAX-PMNTLE/2.0 11646 IF(IY2TJU.EQ.'THRU')PX(2)=PXMAX+PMNTLE/2.0 11647 IF(IY2TJU.EQ.'IN')PX(1)=PXMAX-PMNTLE 11648 IF(IY2TJU.EQ.'INSI')PX(1)=PXMAX-PMNTLE 11649 IF(IY2TJU.EQ.'OUT')PX(1)=PXMAX+PMNTLE 11650 IF(IY2TJU.EQ.'OUTS')PX(1)=PXMAX+PMNTLE 11651C 11652 IF(NY2CMN.LE.0)GOTO1490 11653 NP=2 11654 IFLAG='OFF' 11655 DO1420I=1,NY2CMN 11656 PY(1)=PY2CMN(I) 11657 PY(2)=PY2CMN(I) 11658CCCCC CALL GRDRPL(PX,PY,NP, 11659CCCCC1IFIG,IPATT,PTHICK,ICOL, 11660CCCCC1JPATT,JTHICK,PTHIC2,JCOL) 11661 CALL DPDRPL(PX,PY,NP, 11662 1IFIG,IPATT,PTHICK,ICOL, 11663 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 11664 1420 CONTINUE 11665C 11666 1490 CONTINUE 11667C 11668 GOTO9000 11669C 11670 2000 CONTINUE 11671C 11672C ***************************************** 11673C ** STEP 20-- ** 11674C ** DRAW TIC MARKS FOR TRILINEAR PLOT ** 11675C ***************************************** 11676C 11677C NOTE: FOR NOW, SUPPRESS TIC MARKS FOR TRILINEAR SCALES. 11678C THE FOLLOWING ISN'T REALLY THE RIGHT WAY TO DO IT. 11679C 11680 GOTO9000 11681C 11682 IF(IX1FSW.EQ.'OFF')GOTO9000 11683 IF(IX1TSW.EQ.'OFF')GOTO9000 11684 IF(NX1COO.LE.0)GOTO9000 11685C 11686 ITYPE='LINE' 11687 IPATT='SOLI' 11688 ICOL=IX1TCO 11689 PTHICK=PTICTH 11690C 11691 IFIG='LINE' 11692C 11693 PMJTLE=PX1TLE 11694 AMIN=0.0 11695 AMAX=FXMAX 11696 GRDINC=(AMAX-AMIN)/REAL(NX1COO-1) 11697 PXRANG=PXMAX - PXMIN 11698 PYRANG=PYMAX - PYMIN 11699C 11700C ***************************************** 11701C ** STEP 20.A-- ** 11702C ** DRAW TIC MARKS FOR X1 AXIS ** 11703C ***************************************** 11704C 11705C 11706 NP2=2 11707 IFLAG='ON' 11708 DO2010I=1,NX1COO 11709 XDUMMY=AMIN + (I-1)*GRDINC 11710 PXSTRT=PXMIN + 0.5*PXRANG*XDUMMY 11711 PYSTRT=PYMIN + PYRANG*XDUMMY 11712 PX(1)=PXSTRT 11713 PY(1)=PYSTRT 11714 PY(2)=PYSTRT 11715C 11716 IF(IX1TJU.EQ.'THRU')THEN 11717 PX(2)=PX(1)+PMJTLE/2.0 11718 PX(1)=PX(1)-PMJTLE/2.0 11719 ELSEIF(IX1TJU.EQ.'IN'.OR.IX1TJU.EQ.'INSI')THEN 11720 PX(2)=PX(1)+PMJTLE 11721 IF(I.EQ.1 .OR. I.EQ.NX1COO)GOTO2010 11722 ELSEIF(IX1TJU.EQ.'OUT'.OR.IX1TJU.EQ.'OUTS')THEN 11723 PX(2)=PX(1)-PMJTLE 11724 ENDIF 11725C 11726 CALL DPDRPL(PX,PY,NP2, 11727 1 IFIG,IPATT,PTHICK,ICOL, 11728 1 JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 11729 IFLAG='OFF' 11730 2010 CONTINUE 11731C 11732C ***************************************** 11733C ** STEP 20.B-- ** 11734C ** DRAW TIC MARKS FOR X2 AXIS ** 11735C ***************************************** 11736C 11737C 11738 NP2=2 11739 DO2020I=1,NX1COO 11740 XDUMMY=AMIN + (I-1)*GRDINC 11741 PXSTRT=PXMAX - PXRANG*XDUMMY 11742 PYSTRT=PYMIN 11743 PX(1)=PXSTRT 11744 PY(1)=PYSTRT 11745 PX(2)=PX(1) 11746C 11747 IF(IX1TJU.EQ.'THRU')THEN 11748 PY(2)=PY(1)+PMJTLE/2.0 11749 PY(1)=PY(1)-PMJTLE/2.0 11750 ELSEIF(IX1TJU.EQ.'IN'.OR.IX1TJU.EQ.'INSI')THEN 11751 PY(2)=PY(1)+PMJTLE 11752 IF(I.EQ.1 .OR. I.EQ.NX1COO)GOTO2020 11753 ELSEIF(IX1TJU.EQ.'OUT'.OR.IX1TJU.EQ.'OUTS')THEN 11754 PY(2)=PY(1)-PMJTLE 11755 ENDIF 11756C 11757 CALL DPDRPL(PX,PY,NP2, 11758 1 IFIG,IPATT,PTHICK,ICOL, 11759 1 JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 11760 2020 CONTINUE 11761C 11762C ***************************************** 11763C ** STEP 20.C-- ** 11764C ** DRAW TIC MARKS FOR X3 AXIS ** 11765C ***************************************** 11766C 11767 NP2=2 11768 DO2030I=1,NX1COO 11769 XDUMMY=AMIN + (I-1)*GRDINC 11770 PXSTRT=PXMIN + PXRANG*XDUMMY 11771 PXSTRT=PXSTRT + 0.5*PXRANG*(AMAX-XDUMMY) 11772 PYSTRT=PYMIN + PYRANG*(AMAX-XDUMMY) 11773 PX(1)=PXSTRT 11774 PY(1)=PYSTRT 11775 PY(2)=PY(1) 11776C 11777 IF(IX1TJU.EQ.'THRU')THEN 11778 PX(2)=PX(1)-PMJTLE/2.0 11779 PX(1)=PX(1)+PMJTLE/2.0 11780 ELSEIF(IX1TJU.EQ.'IN'.OR.IX1TJU.EQ.'INSI')THEN 11781 PX(2)=PX(1)-PMJTLE 11782 IF(I.EQ.1 .OR. I.EQ.NX1COO)GOTO2030 11783 ELSEIF(IX1TJU.EQ.'OUT'.OR.IX1TJU.EQ.'OUTS')THEN 11784 PX(2)=PX(1)+PMJTLE 11785 ENDIF 11786C 11787 CALL DPDRPL(PX,PY,NP2, 11788 1 IFIG,IPATT,PTHICK,ICOL, 11789 1 JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 11790 2030 CONTINUE 11791 IFLAG='ON' 11792C 11793C 11794C ***************** 11795C ** STEP 90-- ** 11796C ** EXIT ** 11797C ***************** 11798C 11799 9000 CONTINUE 11800 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRTM')THEN 11801 WRITE(ICOUT,999) 11802 CALL DPWRST('XXX','BUG ') 11803 WRITE(ICOUT,9011) 11804 9011 FORMAT('***** AT THE END OF DPDRTM--') 11805 CALL DPWRST('XXX','BUG ') 11806 WRITE(ICOUT,9016)IFIG,IPATT,PTICTH,JPATT 11807 9016 FORMAT('IFIG,IPATT,JPATT,PTICTH = ',2(A4,2X),I8,G15.7) 11808 CALL DPWRST('XXX','BUG ') 11809 WRITE(ICOUT,9020)PTHICK,JTHICK,PTHIC2 11810 9020 FORMAT('PTHICK,JTHICK,PTHIC2 = ',G15.7,2X,A4,2X,G15.7) 11811 CALL DPWRST('XXX','BUG ') 11812 WRITE(ICOUT,9021)IERRG4,ITYPE,ICOL,JCOL 11813 9021 FORMAT('IERRG4,ITYPE,ICOL,JCOL = ',3(A4,2X),I8) 11814 CALL DPWRST('XXX','BUG ') 11815 ENDIF 11816C 11817 RETURN 11818 END 11819 SUBROUTINE DPDRTR(Y,X,PY,PX,NP,PY2,PX2,NP2,PY3,PX3,NP3,X3D, 11820 1 ICASPL,ICAS3D,ISORSW, 11821 1 ILI2PA,ILI2CO,ILI2TY,PLI2TH, 11822 1 ARE2BA,ARE3BA, 11823 1 IRE2FS,IRE2FC, 11824 1 IRE2PT,IRE2PL,IRE2PC,PRE2PT,PRE2PS,IREBPL, 11825 1 PXMIN,PXMAX,PYMIN,PYMAX, 11826 1 FX1MIN,FX1MAX,FY1MIN,FY1MAX, 11827 1 IX1TSC,IY1TSC) 11828C 11829C PURPOSE--FOR A GENERAL GRAPHICS DEVICE, 11830C DRAW A SINGLE TRACE OF Y(.) VERSUS X(.) 11831C FOR A SPECIFIED LINE TYPE, COLOR, AND THICKNESS. 11832C AND (IF CALLED FOR) FILL IN BELOW/ABOVE THE TRACE 11833C TO THE BASE LINE ARE2BA. 11834C NOTE--THE VARIABLES PY(.) AND PX(.) ARE DUMMY VARIABLES 11835C WHICH ARE USED IN THE INTERMEDIATE CALCULATIONS 11836C AND WHOSE DIMENSIONS ARE DEFINED (FOR EASY OF CHANGE) 11837C BACK IN THE MAIN ROUTINE. 11838C 11839C WRITTEN BY--JAMES J. FILLIBEN 11840C STATISTICAL ENGINEERING DIVISION 11841C INFORMATION TECHNOLOGY LABORATORY 11842C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11843C GAITHERSBURG, MD 20899-8980 11844C PHONE--301-975-2855 11845C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11846C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11847C LANGUAGE--ANSI FORTRAN (1977) 11848C VERSION NUMBER--83.6 11849C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. 11850C UPDATED --FEBRUARY 1988. STAR PLOT 11851C UPDATED --JUNE 1988. CALLS TO DPFIRE 11852C UPDATED --SEPTEMBER 1988. LOG/WEIBULL CHECK AS A SUBROUTINE 11853C UPDATED --SEPTEMBER 1988. RENUMBER 11854C UPDATED --DECEMBER 1988. IBUGG4 FOR IBUGPL 11855C UPDATED --JUNE 1990. NORMAL PLOT 11856C UPDATED --OCTOBER 1993. BAR BASE AUTOMATIC 11857C UPDATED --OCTOBER 1993. REGION BASE AUTOMATIC 11858C UPDATED --NOVEMBER 1993. FILL PIE CHART AS "POLYGON" 11859C UPDATED --MARCH 1994 REGION BASE POLYGON 11860C UPDATED --DECEMBER 1996 FIX NORMAL PLOT 11861C UPDATED --DECEMBER 2006 SUPPORT FOR TRILINEAR PLOT 11862C UPDATED --JANUARY 2018. ILI2TY - SPECIFY WHETHER 11863C CHARACTER COORDINATES ARE IN 11864C SCREEN UNITS OR DATA UNITS 11865C 11866C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- 11867C 11868 CHARACTER*4 ICASPL 11869 CHARACTER*4 ICAS3D 11870C 11871 CHARACTER*4 ISORSW 11872C 11873 CHARACTER*4 ILI2PA 11874 CHARACTER*4 ILI2CO 11875 CHARACTER*4 ILI2TY 11876C 11877 CHARACTER*4 IRE2FS 11878 CHARACTER*4 IRE2FC 11879 CHARACTER*4 IRE2PT 11880 CHARACTER*4 IRE2PL 11881 CHARACTER*4 IRE2PC 11882 CHARACTER*4 IREBPL 11883C 11884 CHARACTER*4 IX1TSC 11885 CHARACTER*4 IY1TSC 11886C 11887 CHARACTER*4 IFIG 11888 CHARACTER*4 IPATT 11889 CHARACTER*4 ICOL 11890 CHARACTER*4 IPATT2 11891C 11892 CHARACTER*4 ICOLF 11893 CHARACTER*4 ICOLP 11894C 11895 CHARACTER*4 ICASAX 11896C 11897 DIMENSION Y(*) 11898 DIMENSION X(*) 11899 DIMENSION X3D(*) 11900 DIMENSION PY(*) 11901 DIMENSION PX(*) 11902 DIMENSION PY2(*) 11903 DIMENSION PX2(*) 11904 DIMENSION PY3(*) 11905 DIMENSION PX3(*) 11906C 11907C-----COMMON---------------------------------------------------------- 11908C 11909 INCLUDE 'DPCOGR.INC' 11910 INCLUDE 'DPCOBE.INC' 11911 INCLUDE 'DPCOP2.INC' 11912C 11913C-----START POINT----------------------------------------------------- 11914C 11915 HOLD=1.0 11916 ABASE=0.0 11917 PBASE=0.0 11918 PBASE2=0.0 11919 PLEFT=0.0 11920 PRIGHT=0.0 11921 AWIDTH=0.0 11922 PWIDTH=0.0 11923 FYRATI=0.0 11924C 11925 FXMIN=FX1MIN 11926 FXMAX=FX1MAX 11927 FYMIN=FY1MIN 11928 FYMAX=FY1MAX 11929C 11930 PXMINS=PXMIN 11931 PXMAXS=PXMAX 11932 PYMINS=PYMIN 11933 PYMAXS=PYMAX 11934C 11935 AHUNDR=100.0 11936 ABASE2=0.0 11937 PBASE9=0.0 11938C 11939 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRTR')THEN 11940 WRITE(ICOUT,999) 11941 999 FORMAT(1X) 11942 CALL DPWRST('XXX','BUG ') 11943 WRITE(ICOUT,51) 11944 51 FORMAT('***** AT THE BEGINNING OF DPDRTR--') 11945 CALL DPWRST('XXX','BUG ') 11946 WRITE(ICOUT,53)ICASPL,ICAS3D,ISORSW,NP,NP3 11947 53 FORMAT('ICASPL,ICAS3D,ISORSW,NP,NP3 = ',3(A4,2X),2I8) 11948 CALL DPWRST('XXX','BUG ') 11949 IF(NP.GE.1)THEN 11950 DO65I=1,NP 11951 WRITE(ICOUT,66)I,X(I),Y(I),X3D(I) 11952 66 FORMAT('I,X(I),Y(I),X3D(I) = ',I8,3G15.7) 11953 CALL DPWRST('XXX','BUG ') 11954 65 CONTINUE 11955 ENDIF 11956 WRITE(ICOUT,68)PX3(1),PY3(1) 11957 68 FORMAT('PX3(1),PY3(1) = ',2G15.7) 11958 CALL DPWRST('XXX','BUG ') 11959 WRITE(ICOUT,71)ILI2PA,ILI2CO,ILI2TY,PLI2TH 11960 71 FORMAT('ILI2PA,ILI2CO,ILI2TY,PLI2TH = ',3(A4,2X),G15.7) 11961 CALL DPWRST('XXX','BUG ') 11962 WRITE(ICOUT,73)IRE2FS,IRE2FC,ARE2BA 11963 73 FORMAT('IRE2FS,IRE2FC,ARE2BA = ',2(A4,2X),G15.7) 11964 CALL DPWRST('XXX','BUG ') 11965 WRITE(ICOUT,74)IRE2PT,IRE2PL,IRE2PC,PRE2PT,PRE2PS 11966 74 FORMAT('IRE2PT,IRE2PL,IRE2PC,PRE2PT,PRE2PS = ', 11967 1 3(A4,2X),2G15.7) 11968 CALL DPWRST('XXX','BUG ') 11969 WRITE(ICOUT,84)PXMIN,PXMAX,PYMIN,PYMAX 11970 84 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4G15.7) 11971 CALL DPWRST('XXX','BUG ') 11972 WRITE(ICOUT,85)FX1MIN,FX1MAX,FY1MIN,FY1MAX 11973 85 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4G15.7) 11974 CALL DPWRST('XXX','BUG ') 11975 WRITE(ICOUT,86)IX1TSC,IY1TSC 11976 86 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4) 11977 CALL DPWRST('XXX','BUG ') 11978 WRITE(ICOUT,89)IBUGG4,ISUBG4,IERRG4 11979 89 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',2(A4,2X),A4) 11980 CALL DPWRST('XXX','BUG ') 11981 ENDIF 11982C 11983C ************************************************* 11984C ** STEP 1-- ** 11985C ** IF CALLED FOR, SORT THE DATA ** 11986C ** ACCORDING TO THE HORIZONTAL AXIS VARIABLE ** 11987C ************************************************* 11988C 11989 IF(ISORSW.EQ.'OFF' .OR. ICASPL.EQ.'PIEC' .OR. 11990 1 ICASPL.EQ.'ROSE' .OR. ICASPL.EQ.'STAR' .OR. 11991 1 ICAS3D.EQ.'ON' .OR. ICASPL.EQ.'CONT' .OR. 11992 1 IREBPL.EQ.'ON' .OR. ICASPL.EQ.'TRPL')THEN 11993 DO1160I=1,NP 11994 PX(I)=X(I) 11995 PY(I)=Y(I) 11996 1160 CONTINUE 11997 ELSE 11998 CALL SORTC(X,Y,NP,PX,PY) 11999 ENDIF 12000C 12001C ****************************************************** 12002C ** STEP 21-- ** 12003C ** IF A NON-LINEAR SCALE PLOT IS CALLED FOR, CHECK ** 12004C ** THAT ALL HORIZONTAL AXIS DATA POINTS ** 12005C ** ARE IN VALID RANGE. ** 12006C ** IF A LOG SCALE PLOT IS CALLED FOR, CHECK THAT ** 12007C ** ALL HORIZONTAL AXIS DATA POINTS ARE > 0. ** 12008C ** IF A WEIBULL SCALE PLOT IS CALLED FOR, ** 12009C ** CHECK THAT ALL HORIZONTAL AXIS DATA POINTS ARE ** 12010C ** STRICTLY > 0 AND STRICTLY < 100 ** 12011C ****************************************************** 12012C 12013 IF(IX1TSC.EQ.'LOG')THEN 12014 ICASAX='2DHO' 12015 CALL CKLOSC(PX,NP,ISORSW,ICASAX,ISUBG4,IBUGG4,IERRG4) 12016 IF(IERRG4.EQ.'YES')GOTO9000 12017 ELSEIF(IX1TSC.EQ.'WEIB' .OR. IX1TSC.EQ.'NORM')THEN 12018 ICASAX='2DHO' 12019CCCCC CALL CKPRSC(PX,NP,ISORSW,ICASAX,ISUBG4,IBUGG4,IERRG4) 12020CCCCC IF(IERRG4.EQ.'YES')GOTO9000 12021 ENDIF 12022C 12023C ****************************************************** 12024C ** STEP 22-- ** 12025C ** IF A NON-LINEAR SCALE PLOT IS CALLED FOR, CHECK ** 12026C ** THAT ALL VERTICAL AXIS DATA POINTS ** 12027C ** ARE IN VALID RANGE. ** 12028C ** IF A LOG SCALE PLOT IS CALLED FOR, CHECK THAT ** 12029C ** ALL VERTICAL AXIS DATA POINTS ARE > 0. ** 12030C ** IF A WEIBULL SCALE PLOT IS CALLED FOR, CHECK ** 12031C ** THAT ALL VERTICAL AXIS DATA POINTS ARE ** 12032C ** STRICTLY > 0 AND STRICTLY < 100 ** 12033C ****************************************************** 12034C 12035 IF(IY1TSC.EQ.'LOG')THEN 12036 ICASAX='2DVE' 12037 CALL CKLOSC(PY,NP,ISORSW,ICASAX,ISUBG4,IBUGG4,IERRG4) 12038 IF(IERRG4.EQ.'YES')GOTO9000 12039 ELSEIF(IY1TSC.EQ.'WEIB' .OR. IY1TSC.EQ.'NORM')THEN 12040 ICASAX='2DVE' 12041CCCCC CALL CKPRSC(PY,NP,ISORSW,ICASAX,ISUBG4,IBUGG4,IERRG4) 12042CCCCC IF(IERRG4.EQ.'YES')GOTO9000 12043 ENDIF 12044C 12045C ************************************************* 12046C ** STEP 4-- ** 12047C ** IF A NON-LINEAR SCALE PLOT IS CALLED FOR, ** 12048C ** TRANSFORM THE DATA ** 12049C ************************************************* 12050C 12051C ********************************************* 12052C ** STEP 4.1-- ** 12053C ** IF A LOG/WEIBULL/NORMAL SCALE PLOT ** 12054C ** IS CALLED FOR TRANSFORM THE DATA ** 12055C ********************************************* 12056C 12057 IF(IX1TSC.EQ.'LOG')THEN 12058 DO4115I=1,NP 12059 PX(I)=LOG10(PX(I)) 12060 4115 CONTINUE 12061 ELSEIF(IX1TSC.EQ.'WEIB')THEN 12062 DO4215I=1,NP 12063 PX(I)=LOG(LOG(AHUNDR/(AHUNDR-PX(I)))) 12064 4215 CONTINUE 12065 ELSEIF(IX1TSC.EQ.'NORM')THEN 12066 DO4315I=1,NP 12067 ARG=PX(I)/AHUNDR 12068 CALL NORPPF(ARG,PX(I)) 12069 4315 CONTINUE 12070 ENDIF 12071C 12072C 12073 ABASE=ARE2BA 12074CCCCC OCTOBER 1993. ADD FOLLOWING 12075 ABAS2=ARE3BA 12076 IF(IY1TSC.EQ.'LOG')THEN 12077 IF(ABASE.NE.CPUMAX.AND.ABASE.GT.0.0)ABASE=LOG10(ABASE) 12078 IF(ABASE.NE.CPUMAX.AND.ABASE.LE.0.0)ABASE=1.0 12079CCCCC OCTOBER 1993. ADD FOLLOWING 12080 IF(ABAS2.NE.CPUMAX.AND.ABAS2.GT.0.0)ABAS2=LOG10(ABAS2) 12081 IF(ABAS2.NE.CPUMAX.AND.ABAS2.LE.0.0)ABAS2=1.0 12082 DO4165I=1,NP 12083 PY(I)=LOG10(PY(I)) 12084 4165 CONTINUE 12085 ELSEIF(IY1TSC.EQ.'WEIB')THEN 12086 IF(ABASE.NE.CPUMAX.AND.ABASE.GT.0.0.AND.ABASE.LT.AHUNDR) 12087 1 ABASE2=LOG(LOG(AHUNDR/(AHUNDR-ABASE))) 12088 IF(ABASE.NE.CPUMAX.AND.ABASE.LE.0.0)ABASE2=0.1 12089 IF(ABASE.NE.CPUMAX.AND.ABASE.GE.AHUNDR)ABASE2=0.1 12090 ABASE=ABASE2 12091CCCCC OCTOBER 1993. ADD FOLLOWING 12092 IF(ABAS2.NE.CPUMAX.AND.ABAS2.GT.0.0.AND.ABAS2.LT.AHUNDR) 12093 1 ABASE2=LOG(LOG(AHUNDR/(AHUNDR-ABAS2))) 12094 IF(ABAS2.NE.CPUMAX.AND.ABAS2.LE.0.0)ABASE2=0.1 12095 IF(ABAS2.NE.CPUMAX.AND.ABAS2.GE.AHUNDR)ABASE2=0.1 12096 ABAS2=ABASE2 12097 DO4265I=1,NP 12098 PY(I)=LOG(LOG(AHUNDR/(AHUNDR-PY(I)))) 12099 4265 CONTINUE 12100 ELSEIF(IY1TSC.EQ.'NORM')THEN 12101 IF(ABASE.NE.CPUMAX.AND.ABASE.GT.0.0.AND.ABASE.LT.AHUNDR)THEN 12102 ARG=ABASE/AHUNDR 12103 CALL NORPPF(ARG,ABASE2) 12104 ENDIF 12105 IF(ABASE.NE.CPUMAX.AND.ABASE.LE.0.0)ABASE2=0.1 12106 IF(ABASE.NE.CPUMAX.AND.ABASE.GE.AHUNDR)ABASE2=0.1 12107 ABASE=ABASE2 12108CCCCC OCTOBER 1993. ADD FOLLOWING 12109 IF(ABAS2.NE.CPUMAX.AND.ABAS2.GT.0.0.AND.ABAS2.LT.AHUNDR)THEN 12110 ARG=ABAS2/AHUNDR 12111 CALL NORPPF(ARG,ABASE2) 12112 ENDIF 12113 IF(ABAS2.NE.CPUMAX.AND.ABAS2.LE.0.0)ABASE2=0.1 12114 IF(ABAS2.NE.CPUMAX.AND.ABAS2.GE.AHUNDR)ABASE2=0.1 12115 ABAS2=ABASE2 12116 DO4365I=1,NP 12117 ARG=PY(I)/AHUNDR 12118 CALL NORPPF(ARG,PY(I)) 12119 4365 CONTINUE 12120 ENDIF 12121C 12122C ***************************************************** 12123C ** STEP 5-- ** 12124C ** TRANSLATE THE DATA POINTS ** 12125C ** INTO STANDARDIZED (0.0 TO 100.0) COORDINATES. ** 12126C ***************************************************** 12127C 12128C 2018/01: USER HAS OPTION TO SPECIFY COORDINATES ARE ALREADY 12129C IN SCREEN UNITS. NOTE THAT SCREEN UNITS ONLY 12130C APPLY TO LINEAR SCALES. 12131C 12132 FXMIN=FX1MIN 12133 FXMAX=FX1MAX 12134 IF(IX1TSC.EQ.'LOG' .OR. IX1TSC.EQ.'WEIB' .OR. 12135 1 IX1TSC.EQ.'NORM')ILI2TY(1:1)='D' 12136 IF(IX1TSC.EQ.'LOG')THEN 12137 FXMIN=LOG10(FX1MIN) 12138 FXMAX=LOG10(FX1MAX) 12139 ELSEIF(IX1TSC.EQ.'WEIB')THEN 12140 FXMIN=LOG(LOG(AHUNDR/(AHUNDR-FX1MIN))) 12141 FXMAX=LOG(LOG(AHUNDR/(AHUNDR-FX1MAX))) 12142 ELSEIF(IX1TSC.EQ.'NORM')THEN 12143 ARG=FX1MIN/AHUNDR 12144 CALL NORPPF(ARG,FXMIN) 12145 ARG=FX1MAX/AHUNDR 12146 CALL NORPPF(ARG,FXMAX) 12147 END IF 12148C 12149 FYMIN=FY1MIN 12150 FYMAX=FY1MAX 12151 IF(IY1TSC.EQ.'LOG' .OR. IY1TSC.EQ.'WEIB' .OR. 12152 1 IY1TSC.EQ.'NORM')ILI2TY(2:2)='D' 12153 IF(IY1TSC.EQ.'LOG')THEN 12154 FYMIN=LOG10(FY1MIN) 12155 FYMAX=LOG10(FY1MAX) 12156 ELSEIF(IY1TSC.EQ.'WEIB')THEN 12157 FYMIN=LOG(LOG(AHUNDR/(AHUNDR-FY1MIN))) 12158 FYMAX=LOG(LOG(AHUNDR/(AHUNDR-FY1MAX))) 12159 ELSEIF(IY1TSC.EQ.'NORM')THEN 12160 ARG=FY1MIN/AHUNDR 12161 CALL NORPPF(ARG,FYMIN) 12162 ARG=FY1MAX/AHUNDR 12163 CALL NORPPF(ARG,FYMAX) 12164 ENDIF 12165C 12166 FXRANG=FXMAX-FXMIN 12167 FYRANG=FYMAX-FYMIN 12168 PXRANG=PXMAX-PXMIN 12169 PYRANG=PYMAX-PYMIN 12170C 12171 IF(ICASPL.EQ.'TRPL')THEN 12172 AK2=SQRT(2.0) 12173 AK6=SQRT(6.0) 12174 PXHALF=(PXMIN+PXMAX)/2.0 12175 PYTHRD=PYMIN + (PYMAX-PYMIN)/3.0 12176 ASUM=X(1) + Y(1) + X3D(1) 12177 DO5160I=1,NP 12178 X1K=X(I)/ASUM 12179 X2K=Y(I)/ASUM 12180 X3K=X3D(I)/ASUM 12181 AH=(1.0/AK2)*(X3K-X2K) 12182 AV=(1.0/AK6)*(2.0 - 3.0*X2K - 3.0*X3K) 12183 PX(I)=PXHALF + (PXRANG/(2.0/AK2))*AH 12184 PY(I)=PYTHRD + (PYRANG/(3.0/AK6))*AV 12185 5160 CONTINUE 12186 ELSEIF(ILI2TY(1:1).EQ.'S' .OR. ILI2TY(2:2).EQ.'S')THEN 12187C 12188C FOR SCREEN COORDINATES, CLIP AT (0,100) INSTEAD OF TO 12189C FRAME COORDINATES 12190C 12191 IF(ILI2TY(1:1).EQ.'S')THEN 12192 DO5120I=1,NP 12193 IF(PX(I).LT.0.0)PX(I)=0.0 12194 IF(PX(I).GT.100.0)PX(I)=100.0 12195 5120 CONTINUE 12196 PXMIN=0.0 12197 PXMAX=100.0 12198 ELSE 12199 DO5123I=1,NP 12200 FXRATI=(PX(I)-FXMIN)/FXRANG 12201 FYRATI=(PY(I)-FYMIN)/FYRANG 12202 PX(I)=PXMIN+FXRATI*PXRANG 12203 5123 CONTINUE 12204 IF(ABASE.NE.CPUMAX)THEN 12205 FYRATI=(ABASE-FYMIN)/FYRANG 12206 PBASE=PYMIN+FYRATI*PYRANG 12207 ENDIF 12208CCCCC OCTOBER 1993. ADD FOLLOWING 12209 IF(ABAS2.NE.CPUMAX)THEN 12210 FYRAT2=(ABAS2-FYMIN)/FYRANG 12211 PBASE9=PYMIN+FYRAT2*PYRANG 12212 ENDIF 12213 ENDIF 12214C 12215 IF(ILI2TY(2:2).EQ.'S')THEN 12216 DO5125I=1,NP 12217 IF(PY(I).LT.0.0)PY(I)=0.0 12218 IF(PY(I).GT.100.0)PY(I)=100.0 12219 5125 CONTINUE 12220 PYMIN=0.0 12221 PYMAX=100.0 12222 ELSE 12223 DO5128I=1,NP 12224 FXRATI=(PX(I)-FXMIN)/FXRANG 12225 FYRATI=(PY(I)-FYMIN)/FYRANG 12226 PY(I)=PYMIN+FYRATI*PYRANG 12227 5128 CONTINUE 12228 IF(ABASE.NE.CPUMAX)THEN 12229 FYRATI=(ABASE-FYMIN)/FYRANG 12230 PBASE=PYMIN+FYRATI*PYRANG 12231 ENDIF 12232CCCCC OCTOBER 1993. ADD FOLLOWING 12233 IF(ABAS2.NE.CPUMAX)THEN 12234 FYRAT2=(ABAS2-FYMIN)/FYRANG 12235 PBASE9=PYMIN+FYRAT2*PYRANG 12236 ENDIF 12237 ENDIF 12238 ELSE 12239 DO5100I=1,NP 12240 FXRATI=(PX(I)-FXMIN)/FXRANG 12241 FYRATI=(PY(I)-FYMIN)/FYRANG 12242 PX(I)=PXMIN+FXRATI*PXRANG 12243 PY(I)=PYMIN+FYRATI*PYRANG 12244 5100 CONTINUE 12245 IF(ABASE.NE.CPUMAX)THEN 12246 FYRATI=(ABASE-FYMIN)/FYRANG 12247 PBASE=PYMIN+FYRATI*PYRANG 12248 ENDIF 12249CCCCC OCTOBER 1993. ADD FOLLOWING 12250 IF(ABAS2.NE.CPUMAX)THEN 12251 FYRAT2=(ABAS2-FYMIN)/FYRANG 12252 PBASE9=PYMIN+FYRAT2*PYRANG 12253 ENDIF 12254 ENDIF 12255C 12256C ************************************** 12257C ** STEP 6-- ** 12258C ** IF CALLED FOR, ** 12259C ** FILL OVER/UNDER THE TRACE ** 12260C ** (BUT CLIP FIRST, IF NECESSARY) ** 12261C ************************************** 12262C 12263 IF(ICASPL.EQ.'TRPL')GOTO6190 12264C 12265 IFIG='GENE' 12266 IF(ICASPL.EQ.'PIEC')IFIG='POLY' 12267 IF(ICASPL.EQ.'ROSE')IFIG='POLY' 12268CCCCC MARCH 1994. ADD FOLLOWING LINE 12269 IF(IREBPL.EQ.'ON')IFIG='POLY' 12270C 12271 IF(IRE2FS.EQ.'OFF')GOTO6190 12272 IPATT=IRE2PT 12273 PTHICK=PRE2PT 12274 PXGAP=PRE2PS 12275 PYGAP=PRE2PS 12276 ICOLF=IRE2FC 12277 ICOLP=IRE2PC 12278C 12279 CALL DPSQUE(PX,PY,NP, 12280 1PXMIN,PXMAX,PYMIN,PYMAX) 12281C 12282CCCCC MARCH 1994. ADD FOLLOWING LINE 12283 IF(IREBPL.EQ.'ON')GOTO6110 12284 IF(ABASE.EQ.CPUMAX)GOTO6110 12285 GOTO6120 12286C 12287 6110 CONTINUE 12288 DO6115I=1,NP 12289 PX2(I)=PX(I) 12290 PY2(I)=PY(I) 12291 6115 CONTINUE 12292 NP2=NP+1 12293 PX2(NP2)=PX(1) 12294 PY2(NP2)=PY(1) 12295C 12296 DO6116J=1,NP2 12297 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN 12298 IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX 12299 IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN 12300 IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 12301 6116 CONTINUE 12302C 12303CCCCC CALL DPFIRE(PX2,PY2,NP2, 12304CCCCC1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP) 12305C JUNE, 1988 12306 IPATT2=IRE2PL 12307 CALL DPFIRE(PX2,PY2,NP2, 12308 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2) 12309C 12310 GOTO6190 12311C 12312 6120 CONTINUE 12313 PBASE2=PBASE 12314 IF(PBASE2.LT.PYMIN.AND.(PYMIN-PBASE2).LE.0.0001)PBASE2=PYMIN 12315 IF(PBASE2.GT.PYMAX.AND.(PBASE2-PYMAX).LE.0.0001)PBASE2=PYMAX 12316CCCCC OCTOBER 1993. ADD FOLLOWING 12317 PBASE8=PBASE9 12318 IF(PBASE9.LT.PYMIN.AND.(PYMIN-PBASE9).LE.0.0001)PBASE8=PYMIN 12319 IF(PBASE9.GT.PYMAX.AND.(PBASE9-PYMAX).LE.0.0001)PBASE8=PYMAX 12320CCCCC OCTOBER 1993. 12321 IF(NP.GT.2)GOTO6130 12322C 12323 NP2=5 12324 NPM1=NP-1 12325 IF(NPM1.LE.0)GOTO6190 12326 DO6125I=1,NPM1 12327 IP1=I+1 12328C 12329 PLEFT=PX(I) 12330 PRIGHT=PX(IP1) 12331 IF(PLEFT.LT.PXMIN.AND.(PXMIN-PLEFT).LE.0.0001)PLEFT=PXMIN 12332 IF(PRIGHT.GT.PXMAX.AND.(PRIGHT-PXMAX).LE.0.0001)PRIGHT=PXMAX 12333C 12334 IF(PRIGHT.LT.PXMIN)GOTO6125 12335 IF(PLEFT.GT.PXMAX)GOTO6125 12336 IF(PY(I).LT.PYMIN.AND.PBASE2.LT.PYMIN)GOTO6125 12337 IF(PY(I).GT.PYMAX.AND.PBASE2.GT.PYMAX)GOTO6125 12338C 12339 PX2(1)=PLEFT 12340 PX2(2)=PRIGHT 12341 PX2(3)=PRIGHT 12342 PX2(4)=PLEFT 12343 PX2(5)=PLEFT 12344C 12345 PY2(1)=PBASE2 12346CCCCC OCTOBER 1993. ADD FOLLOWING 12347CCCCC PY2(2)=PBASE2 12348 PY2(2)=PBASE8 12349CCCCC END CHANGE 12350 PY2(3)=PY(IP1) 12351 PY2(4)=PY(I) 12352 PY2(5)=PBASE2 12353C 12354 DO6126J=1,NP2 12355 IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN 12356 IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX 12357 IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN 12358 IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX 12359 6126 CONTINUE 12360C 12361CCCCC CALL DPFIRE(PX2,PY2,NP2, 12362CCCCC1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP) 12363CCCCC JUNE, 1988. 12364 IPATT2=IRE2PL 12365 CALL DPFIRE(PX2,PY2,NP2, 12366 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2) 12367 6125 CONTINUE 12368C 12369 GOTO6190 12370CCCCC OCTOBER 1993. TREAT REGION AS SINGLE POLYGON 12371 6130 CONTINUE 12372C 12373 DO6135I=1,NP 12374C 12375 PX2(I)=PX(I) 12376 PY2(I)=PY(I) 12377 IF(PX2(I).LT.PXMIN)PX2(I)=PXMIN 12378 IF(PX2(I).GT.PXMAX)PX2(I)=PXMAX 12379 IF(PY2(I).LT.PYMIN)PY2(I)=PYMIN 12380 IF(PY2(I).GT.PYMAX)PY2(I)=PYMAX 12381 6135 CONTINUE 12382C 12383 NP2=NP+1 12384 PX2(NP2)=PX2(NP) 12385 PY2(NP2)=PBASE2 12386 NP2=NP2+1 12387 PX2(NP2)=PX2(1) 12388 PY2(NP2)=PBASE2 12389 NP2=NP2+1 12390 PX2(NP2)=PX2(1) 12391 PY2(NP2)=PY2(1) 12392C 12393 IPATT2=IRE2PL 12394 CALL DPFIRE(PX2,PY2,NP2, 12395 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2) 12396C 12397 GOTO6190 12398C 12399 6190 CONTINUE 12400C 12401C ***************************************** 12402C ** STEP 7-- ** 12403C ** DRAW OUT THE TRACE ** 12404C ** (BUT CLIP IT FIRST, IF NECESSARY) ** 12405C ***************************************** 12406C 12407 IFIG='GENE' 12408 IPATT=ILI2PA 12409 PTHICK=PLI2TH 12410 ICOL=ILI2CO 12411C 12412CCCCC CALL DPCLTR(PX,PY,NP,PX2,PY2,NP2,PY3,PX3,NP3, 12413 CALL DPCLTR(PX,PY,NP,PX2,PY2,NP2, 12414 1 PXMIN,PXMAX,PYMIN,PYMAX, 12415 1 ISORSW, 12416 1 IFIG,IPATT,PTHICK,ICOL) 12417C 12418C ***************** 12419C ** STEP 90-- ** 12420C ** EXIT ** 12421C ***************** 12422C 12423 9000 CONTINUE 12424C 12425 PXMIN=PXMINS 12426 PXMAX=PXMAXS 12427 PYMIN=PYMINS 12428 PYMAX=PYMAXS 12429C 12430 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRTR')THEN 12431 WRITE(ICOUT,999) 12432 CALL DPWRST('XXX','BUG ') 12433 WRITE(ICOUT,9011) 12434 9011 FORMAT('***** AT THE END OF DPDRTR--') 12435 CALL DPWRST('XXX','BUG ') 12436 WRITE(ICOUT,9012)NP 12437 9012 FORMAT('NP = ',I8) 12438 CALL DPWRST('XXX','BUG ') 12439 WRITE(ICOUT,9013)ICASPL,ICAS3D 12440 9013 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) 12441 CALL DPWRST('XXX','BUG ') 12442 IF(NP.GE.1)THEN 12443 DO9025I=1,NP 12444 WRITE(ICOUT,9026)I,PX(I),PY(I) 12445 9026 FORMAT('I,PX(I),PY(I) = ',I8,2G15.7) 12446 CALL DPWRST('XXX','BUG ') 12447 9025 CONTINUE 12448 ENDIF 12449 WRITE(ICOUT,9030)ISORSW 12450 9030 FORMAT('ISORSW = ',A4) 12451 CALL DPWRST('XXX','BUG ') 12452 WRITE(ICOUT,9031)ILI2PA,ILI2CO,PLI2TH 12453 9031 FORMAT('ILI2PA,ILI2CO,PLI2TH = ',A4,2X,A4,E15.7) 12454 CALL DPWRST('XXX','BUG ') 12455 WRITE(ICOUT,9032)ARE2BA 12456 9032 FORMAT('ARE2BA = ',E15.7) 12457 CALL DPWRST('XXX','BUG ') 12458 WRITE(ICOUT,9033)IRE2FS,IRE2FC 12459 9033 FORMAT('IRE2FS,IRE2FC = ',A4,2X,A4) 12460 CALL DPWRST('XXX','BUG ') 12461 WRITE(ICOUT,9034)IRE2PT,IRE2PL,IRE2PC,PRE2PT,PRE2PS 12462 9034 FORMAT('IRE2PT,IRE2PL,IRE2PC,PRE2PT,PRE2PS = ', 12463 1 A4,2X,A4,2X,A4,2E15.7) 12464 CALL DPWRST('XXX','BUG ') 12465 WRITE(ICOUT,9044)PXMIN,PXMAX,PYMIN,PYMAX 12466 9044 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4E15.7) 12467 CALL DPWRST('XXX','BUG ') 12468 WRITE(ICOUT,9045)FX1MIN,FX1MAX,FY1MIN,FY1MAX 12469 9045 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4E15.7) 12470 CALL DPWRST('XXX','BUG ') 12471 WRITE(ICOUT,9046)FXMIN,FXMAX,FYMIN,FYMAX 12472 9046 FORMAT('FXMIN,FXMAX,FYMIN,FYMAX= ',4E15.7) 12473 CALL DPWRST('XXX','BUG ') 12474 WRITE(ICOUT,9047)IX1TSC,IY1TSC 12475 9047 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4) 12476 CALL DPWRST('XXX','BUG ') 12477 WRITE(ICOUT,9049)IBUGG4,ISUBG4,IERRG4 12478 9049 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 12479 CALL DPWRST('XXX','BUG ') 12480 ENDIF 12481C 12482 RETURN 12483 END 12484 SUBROUTINE DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT, 12485 1 AVALUE,IDIGIT, 12486 1 NTOT,NUMROW, 12487 1 ICAPSW,ICAPTY,ILAST,IFIRST, 12488 1 ISUBRO,IBUGA3,IERROR) 12489C 12490C PURPOSE--THIS ROUTINE PRINTS A TWO-COLUMN TABLE, WHERE THE 12491C FIRST COLUMN IS TEXT AND THE SECOND COLUMN IS 12492C NUMERIC, IN HTML/LATEX/RTF/ASCII FORMATS. 12493C 12494C 1) ITITLE CONTAINS AN OVERALL TITLE (TO SKIP, 12495C SET NCTITL = 0) 12496C AN OPTIONAL SECOND LINE FOR THE TITLE MAY BE 12497C GIVEN IN ITITLZ 12498C 2) THE FIRST ROW OF ITEXT CONTAINS A HEADER 12499C ROW (SET NCTEXT(1) = 0 TO SKIP) 12500C 3) THE REMAINING ROWS CONTAIN TWO COLUMNS 12501C OF DATA - COLUMN 1 IS A TEXT FIELD AND 12502C COLUMN 2 IS A NUMERIC FIELD. 12503C 12504C WRITTEN BY--ALAN HECKERT 12505C STATISTICAL ENGINEERING DIVISION 12506C INFORMATION TECHNOLOGY LABORATORY 12507C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 12508C GAITHERSBURG, MD 20899-8980 12509C PHONE--301-975-2899 12510C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12511C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 12512C LANGUAGE--ANSI FORTRAN (1977) 12513C VERSION NUMBER--2009/3 12514C ORIGINAL VERSION--MARCH 2009. 12515C UPDATED --OCTOBER 2009. ADD ITITLZ FOR SECOND LINE 12516C OF TITLE 12517C UPDATED --JANUARY 2011. USE DPDTLA TO CHECK FOR 12518C CERTAIN CHARACTERS THAT NEED 12519C TO BE ESCAPED FOR LATEX 12520C UPDATED --FEBRUARY 2020. CALL LIST TO DPTAB5 12521C 12522C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12523C 12524 CHARACTER*(*) ITITLE 12525 CHARACTER*(*) ITITLZ 12526 CHARACTER*(*) ITEXT(*) 12527 REAL AVALUE(*) 12528 INTEGER IDIGIT(*) 12529 INTEGER NCTEXT(*) 12530 INTEGER NTOT(*) 12531C 12532 CHARACTER*4 ICAPSW 12533 CHARACTER*4 ICAPTY 12534 CHARACTER*4 ISUBRO 12535 CHARACTER*4 IBUGA3 12536 CHARACTER*4 IERROR 12537C 12538 CHARACTER*4 ISUBN1 12539 CHARACTER*4 ISUBN2 12540 CHARACTER*4 ISTEPN 12541 CHARACTER*4 ICSVWZ 12542 CHARACTER*1 IBASLC 12543C 12544 LOGICAL IFLAG1 12545 LOGICAL IFLAG2 12546 LOGICAL IFLAG3 12547 LOGICAL ILAST 12548 LOGICAL IFIRST 12549 LOGICAL IBOLD 12550C 12551C--------------------------------------------------------------------- 12552C 12553 INCLUDE 'DPCOST.INC' 12554C 12555 PARAMETER (MAXHED=1024) 12556 INTEGER IWIDTH(MAXHED) 12557 INTEGER NUMDIG(MAXHED) 12558 CHARACTER*8 ALIGN(MAXHED) 12559 CHARACTER*8 VALIGN(MAXHED) 12560 COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN 12561 CHARACTER*132 IVALUE(2) 12562 INTEGER NCTEMP(2) 12563 REAL AVAL(2) 12564C 12565 INTEGER NTOT2(2) 12566C 12567 CHARACTER*132 IHEAD 12568 CHARACTER*132 ITEMPC 12569C 12570 CHARACTER*4 IRTFMD 12571 COMMON/COMRTF/IRTFMD 12572C 12573C--------------------------------------------------------------------- 12574C 12575 INCLUDE 'DPCOP2.INC' 12576C 12577C-----START POINT----------------------------------------------------- 12578C 12579 ISUBN1='DPDT' 12580 ISUBN2='A1 ' 12581 IERROR='NO' 12582C 12583 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTA1')THEN 12584 WRITE(ICOUT,999) 12585 999 FORMAT(1X) 12586 CALL DPWRST('XXX','WRIT') 12587 WRITE(ICOUT,51) 12588 51 FORMAT('**** AT THE BEGINNING OF DPDTA1--') 12589 CALL DPWRST('XXX','WRIT') 12590 WRITE(ICOUT,52)IBUGA3,ISUBRO,NCTITL,NUMROW 12591 52 FORMAT('IBUGA3,ISUBRO,NCTITL,NUMROW = ',2(A4,2X),2I8) 12592 CALL DPWRST('XXX','WRIT') 12593 IF(NCTITL.GT.0)THEN 12594 NTEMP=MIN(80,NCTITL) 12595 WRITE(ICOUT,54)ITITLE(1:NTEMP) 12596 54 FORMAT('ITITL(1:NCTITL) = ',A80) 12597 CALL DPWRST('XXX','WRIT') 12598 ENDIF 12599 IF(NUMROW.GT.0)THEN 12600 DO56I=1,NUMROW 12601 IF(NCTEXT(I).GT.0)THEN 12602 WRITE(ICOUT,57)I,ITEXT(I)(1:NCTEXT(I)) 12603 57 FORMAT('I,ITEXT(I) = ',I8,A80) 12604 CALL DPWRST('XXX','WRIT') 12605 ENDIF 12606 56 CONTINUE 12607 DO66I=1,NUMROW 12608 WRITE(ICOUT,67)I,IDIGIT(I),AVALUE(I) 12609 67 FORMAT('I,IDIGIT(I),AVALUE(I) = ',2I8,G15.7) 12610 CALL DPWRST('XXX','WRIT') 12611 66 CONTINUE 12612 ENDIF 12613 ENDIF 12614C 12615C ******************************************* 12616C ** STEP 1-- ** 12617C ** WRITE OUT THE TITLE AND HEADER LINE ** 12618C ******************************************* 12619C 12620 ISTEPN='1' 12621 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DTA1') 12622 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12623C 12624 IF(IPRINT.EQ.'ON')THEN 12625C 12626 CALL DPCONA(92,IBASLC) 12627C 12628 IHEAD=' ' 12629 NCHEAD=0 12630 IF(NCTITZ.GT.0)THEN 12631 IHEAD(1:NCTITZ)=ITITLZ(1:NCTITZ) 12632 NCHEAD=NCTITZ 12633 ENDIF 12634 NHEAD=2 12635 IFLAG1=.TRUE. 12636 IFLAG2=.TRUE. 12637C 12638 IVALUE(1)=' ' 12639 IVALUE(1)(1:NCTEXT(1))=ITEXT(1)(1:NCTEXT(1)) 12640 NCTEMP(1)=NCTEXT(1) 12641 NCTEMP(2)=0 12642 IWIDTH(1)=0 12643 VALIGN(1)=' ' 12644 NUMDIG(1)=0 12645 ALIGN(1) =' ' 12646 IWIDTH(2)=0 12647 VALIGN(2)=' ' 12648 NUMDIG(2)=0 12649 ALIGN(2) =' ' 12650C 12651 IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN 12652 IF(NCTITZ.GT.0)THEN 12653 ITEMPC(1:NCTITL)=ITITLE(1:NCTITL) 12654 NSTRT=NCTITL+1 12655 ITEMPC(NSTRT:NSTRT+3)='<BR>' 12656 NSTRT=NSTRT+4 12657 NSTRT2=NSTRT+NCTITZ-1 12658 ITEMPC(NSTRT:NSTRT2)=ITITLZ(1:NCTITZ) 12659 NSTRT=NSTRT2 12660 CALL DPHTM1(ITEMPC,NSTRT,IFLAG1,IFLAG2) 12661 ELSE 12662 CALL DPHTM1(ITITLE,NCTITL,IFLAG1,IFLAG2) 12663 ENDIF 12664 IWIDTH(1)=400 12665 VALIGN(1)='BOTTOM' 12666 ALIGN(1) ='LEFT' 12667 IVALUE(2)=' ' 12668 NCTEMP(2)=6 12669 IWIDTH(2)=150 12670 VALIGN(2)='BOTTOM' 12671 ALIGN(2) ='RIGHT' 12672 IFLAG1=.FALSE. 12673 IFLAG2=.FALSE. 12674 IF(NCTEXT(1).GT.0)THEN 12675 CALL DPHTM4(IVALUE,NCTEMP,NHEAD,IFLAG1,IFLAG2) 12676 ENDIF 12677C 12678 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN 12679 IF(IFIRST)THEN 12680 IFLAG1=.FALSE. 12681 IFLAG2=.FALSE. 12682 IFLAG3=.TRUE. 12683 CALL DPLAT6(IFLAG1,IFLAG2,IFLAG3) 12684 ENDIF 12685 IFLAG1=.FALSE. 12686 IF(IFIRST)IFLAG1=.TRUE. 12687 IFLAG2=.TRUE. 12688 CALL DPDTLA(ITITLE,NCTITL,NCT,ISUBRO,IBUGA3,IERROR) 12689 NCTITL=NCT 12690 CALL DPLAT1(ITITLE,NCTITL,IHEAD,NCHEAD,IFLAG1) 12691 NHEAD=2 12692 VALIGN(1)='b' 12693 ALIGN(1) ='l' 12694 VALIGN(2)='b' 12695 ALIGN(2) ='r' 12696 IFLAG1=.FALSE. 12697 IFLAG2=.FALSE. 12698 IFLAG3=.TRUE. 12699 CALL DPDTLA(IVALUE(1),NCTEMP(1),NCT,ISUBRO,IBUGA3,IERROR) 12700 NCTEMP(1)=NCT 12701 CALL DPLAT4(IVALUE,NCTEMP,NHEAD,IFLAG1,IFLAG2,IFLAG3) 12702C 12703 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF ')THEN 12704C 12705 8091 FORMAT(A1,'f',I1) 12706 IF(IRTFFP.EQ.'Times New Roman')THEN 12707 ITEMP=0 12708 ELSEIF(IRTFFP.EQ.'Lucida Sans')THEN 12709 ITEMP=6 12710 ELSEIF(IRTFFP.EQ.'Arial')THEN 12711 ITEMP=2 12712 ELSEIF(IRTFFP.EQ.'Bookman')THEN 12713 ITEMP=3 12714 ELSEIF(IRTFFP.EQ.'Georgia')THEN 12715 ITEMP=4 12716 ELSEIF(IRTFFP.EQ.'Tahoma')THEN 12717 ITEMP=5 12718 ELSEIF(IRTFFP.EQ.'Verdana')THEN 12719 ITEMP=7 12720 ELSE 12721 ITEMP=0 12722 ENDIF 12723C 12724 IRTFMD='OFF' 12725C 12726 NCHAR=NCTITL+3 12727 ITEMPC(4:NCHAR)=ITITLE(1:NCTITL) 12728 ITEMPC(1:3)=' b ' 12729 ITEMPC(1:1)=IBASLC 12730 IF(NCTITZ.GT.0)THEN 12731 NCHAR2=NCTITZ+3 12732 IHEAD(4:NCHAR2)=ITITLZ(1:NCTITZ) 12733 IHEAD(1:3)=' b ' 12734 IHEAD(1:1)=IBASLC 12735 ELSE 12736 NCHAR2=0 12737 ENDIF 12738 CALL DPRTF1(ITEMPC,NCHAR,IHEAD,NCHAR2) 12739C 12740 NCHAR=NCTEXT(1)+3 12741 NTEMP=NCTEXT(1) 12742 IVALUE(1)(4:NCHAR)=ITEXT(1)(1:NTEMP) 12743 IVALUE(1)(1:3)=' b ' 12744 IVALUE(1)(1:1)=IBASLC 12745 NCTEMP(1)=NCHAR 12746 IDEFPS=20 12747 IFRST=IRTFPS*5500/IDEFPS 12748 IINC=IRTFPS*1400/IDEFPS 12749 IWIDTH(1)=IFRST 12750 VALIGN(1)='b' 12751 ALIGN(1) ='l' 12752 IWIDTH(2)=IWIDTH(1) + IINC 12753 VALIGN(2)='b' 12754 ALIGN(2) ='r' 12755 IFLAG1=.FALSE. 12756 IFLAG2=.FALSE. 12757 CALL DPRTF4(IVALUE,NCTEMP,NHEAD,IFLAG1,IFLAG2) 12758C 12759 ELSE 12760 IF(NCTITZ.LE.0)THEN 12761 CALL DPTAB1(ITITLE,NCTITL,IHEAD,NCHEAD,IFLAG1) 12762 ELSE 12763 CALL DPTABA(ITITLE,NCTITL,IHEAD,NCHEAD,IFLAG1) 12764 ENDIF 12765 IFLAG1=.FALSE. 12766 IFLAG2=.FALSE. 12767 NMAX=0 12768 CALL DPTAB4(IVALUE,NCTEMP,NHEAD,IFLAG1,IFLAG2,NMAX) 12769C 12770 ENDIF 12771C 12772C ******************************************* 12773C ** STEP 2-- ** 12774C ** WRITE OUT THE ROWS ** 12775C ******************************************* 12776C 12777 ISTEPN='2' 12778 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DTA1') 12779 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12780C 12781C COMPUTE MAXIMUM SIZE FOR COLUMN 1 12782C 12783 NTOTMX=40 12784 DO210I=2,NUMROW 12785 NTOTMX=MAX(NTOTMX,NCTEXT(I)) 12786 210 CONTINUE 12787C 12788 IF(NUMROW.GE.2)THEN 12789 NHEAD=1 12790 DO200I=2,NUMROW 12791C 12792 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DTA1')THEN 12793 WRITE(ICOUT,999) 12794 CALL DPWRST('XXX','WRIT') 12795 WRITE(ICOUT,251) 12796 251 FORMAT('**** DPDTA1--WRITING ROWS OF TABLE') 12797 CALL DPWRST('XXX','WRIT') 12798 WRITE(ICOUT,252)I,IDIGIT(I),AVALUE(I),NCTEXT(I) 12799 252 FORMAT('I,IDIGIT(I),AVALUE(I),NCTEXT(I),',2I5,G15.7,I5) 12800 CALL DPWRST('XXX','WRIT') 12801 NTEMP=NCTEXT(I) 12802 WRITE(ICOUT,253)ITEXT(I)(1:NTEMP) 12803 253 FORMAT('ITEXT(I) = ',A80) 12804 CALL DPWRST('XXX','WRIT') 12805 ENDIF 12806C 12807 IF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'HTML')THEN 12808 IBOLD=.FALSE. 12809 IWIDTH(1)=300 12810 VALIGN(1)='BOTTOM' 12811 ALIGN(1) ='LEFT' 12812 NUMDIG(1)=IDIGIT(I) 12813 IWIDTH(2)=150 12814 VALIGN(2)='BOTTOM' 12815 ALIGN(2) ='RIGHT' 12816 IFLAG1=.FALSE. 12817 IFLAG2=.FALSE. 12818 CALL DPHTM5(ITEXT(I),NCTEXT(I),AVALUE(I),NHEAD,IBOLD) 12819C 12820 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'LATE')THEN 12821 IFLAG1=.FALSE. 12822 NUMDIG(1)=IDIGIT(I) 12823 NUMDIG(2)=IDIGIT(I) 12824 CALL DPDTLA(ITEXT(I),NCTEXT(I),NCT,ISUBRO,IBUGA3,IERROR) 12825 NCTEXT(I)=NCT 12826 CALL DPLAT5(ITEXT(I),NCTEXT(I),AVALUE(I),NHEAD, 12827 1 IFLAG1) 12828 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'RTF')THEN 12829 IFLAG1=.FALSE. 12830 VALIGN(1)='b' 12831 ALIGN(1) ='l' 12832 NUMDIG(1)=-1 12833 VALIGN(2)='b' 12834 ALIGN(2) ='r' 12835 NUMDIG(2)=IDIGIT(I) 12836 AVAL(1)=0.0 12837 AVAL(2)=AVALUE(I) 12838 NCHAR=NCTEXT(I)+3 12839 NTEMP=NCTEXT(I) 12840 ITEMPC(4:NCHAR)=ITEXT(I)(1:NTEMP) 12841 ITEMPC(1:3)=' b ' 12842 ITEMPC(1:1)=IBASLC 12843 CALL DPRTF5(ITEMPC,NCHAR,AVAL,NHEAD,IFLAG1) 12844 ELSE 12845 IFLAG1=.FALSE. 12846 VALIGN(1)='b' 12847 ALIGN(1) ='l' 12848 VALIGN(2)='b' 12849 ALIGN(2) ='r' 12850 NMAX=0 12851 NUMDIG(1)=IDIGIT(I) 12852 NTOT2(1)=NTOTMX 12853 NTOT2(2)=NTOT(I) 12854 ICSVWZ='OFF' 12855 IVALT=-99 12856 CALL DPTAB5(ITEXT(I),NCTEXT(I),AVALUE(I),NHEAD, 12857 1 IFLAG1,NMAX,NTOT2,ICSVWZ) 12858 ENDIF 12859 200 CONTINUE 12860 ENDIF 12861C 12862C ******************************************* 12863C ** STEP 3-- ** 12864C ** TERMINATE THE TABLE ** 12865C ******************************************* 12866C 12867 ISTEPN='2' 12868 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DTA1') 12869 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 12870C 12871 IF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'HTML')THEN 12872 IFLAG1=.TRUE. 12873 IFLAG2=.TRUE. 12874 IFLAG2=.FALSE. 12875 IF(ILAST)IFLAG2=.TRUE. 12876 CALL DPHTM2(IFLAG1,IFLAG2,NHEAD) 12877 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'LATE')THEN 12878 IFLAG1=.TRUE. 12879 IFLAG2=.FALSE. 12880 IFLAG3=.FALSE. 12881 IF(ILAST)THEN 12882 IFLAG2=.TRUE. 12883 IFLAG3=.TRUE. 12884 ENDIF 12885 CALL DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD) 12886 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'RTF')THEN 12887 IF(IRTFFF.EQ.'Courier New')THEN 12888 ITEMP=1 12889 ELSEIF(IRTFFF.EQ.'Lucida Console')THEN 12890 ITEMP=8 12891 ENDIF 12892 WRITE(ICOUT,8091)IBASLC,ITEMP 12893 CALL DPWRST(ICOUT,'WRIT') 12894 CALL DPRTF6(NHEAD) 12895 CALL DPRTF6(NHEAD) 12896 IF(ILAST)THEN 12897 IRTFMD='VERB' 12898 ENDIF 12899 ELSE 12900 IF(ILAST)THEN 12901 WRITE(ICOUT,999) 12902 CALL DPWRST('XXX','WRIT') 12903 ENDIF 12904 ENDIF 12905C 12906 ENDIF 12907C 12908 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTA1')THEN 12909 WRITE(ICOUT,999) 12910 CALL DPWRST('XXX','WRIT') 12911 WRITE(ICOUT,9011) 12912 9011 FORMAT('**** AT THE END OF DPDTA1--') 12913 CALL DPWRST('XXX','WRIT') 12914 ENDIF 12915C 12916 RETURN 12917 END 12918 SUBROUTINE DPDTA2(ITITL9,NCTIT9, 12919 1 IHEAD,NCHEAD,ITITLE,NCTITL, 12920 1 MAXLIN,NUMLIN,MAXCOL,NUMCOL, 12921 1 ITEXT,NCTEXT,AVAL,MAXROW,NUMROW, 12922 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGZ,ALIGNZ,NMAX, 12923 1 ICAPSW,ICAPTY,IFIRST,ILAST, 12924 1 ISUBRO,IBUGA3,IERROR) 12925C 12926C PURPOSE--THIS ROUTINE PRINTS A MULTI-COLUMN TABLE CONSISTING OF: 12927C 12928C 1) AN OPTIONAL OVERALL TITLE 12929C 2) HEADERS FOR EACH OF THE COLUMNS (THESE HEADERS MAY 12930C CONTAIN MULTIPLE LINES). 12931C 3) A TABLE OF NUMERIC VALUES. IT MAY ALSO OPTIONALLY 12932C CONTAIN A CHARACTER FIELD FOR COLUMN ONE. 12933C 12934C ITITL9 => THE OVERALL TITLE 12935C IHEAD => TABLE CAPTION 12936C ITITLE => LINES FOR THE COLUMN HEADERS 12937C ITEXT => CHARACTER ARRAY FOR COLUMN 1 12938C AVAL => MATRIX OF NUMERIC VALUES FOR THE TABLE 12939C 12940C WRITTEN BY--ALAN HECKERT 12941C STATISTICAL ENGINEERING DIVISION 12942C INFORMATION TECHNOLOGY LABORATORY 12943C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 12944C GAITHERSBURG, MD 20899-8980 12945C PHONE--301-975-2899 12946C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12947C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 12948C LANGUAGE--ANSI FORTRAN (1977) 12949C VERSION NUMBER--2009/3 12950C ORIGINAL VERSION--MARCH 2009. 12951C UPDATED --APRIL 2009. ADD THE OPTIONAL OVERALL TITLE 12952C UPDATED --APRIL 2009. FOR LATEX, CHECK FOR "%" AND 12953C REPLACE WITH "\%" 12954C UPDATED --APRIL 2009. IF NUMERIC VALUE IS EQUAL TO 12955C CPUMIN, SET DIGITS TO -99 AND 12956C (THIS WILL THEN BE PRINTED 12957C AS "**") 12958C UPDATED --APRIL 2009. ALLOW CALLING ROUTINE TO 12959C SPECIFY THE POINT SIZE FOR 12960C RTF 12961C UPDATED --JANUARY 2011. USE DPDTLA TO CHECK FOR 12962C CERTAIN CHARACTERS THAT NEED 12963C TO BE ESCAPED FOR LATEX 12964C UPDATED --FEBRUARY 2020. CALL LIST TO DPTAB5 12965C 12966C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12967C 12968 CHARACTER*(*) IHEAD 12969 CHARACTER*(*) ITITL9 12970 CHARACTER*(*) ITITLE(MAXLIN,MAXCOL) 12971 CHARACTER*(*) ITEXT(MAXROW) 12972 CHARACTER*4 VALIGZ(*) 12973 CHARACTER*4 ALIGNZ(*) 12974 INTEGER NCTITL(MAXLIN,MAXCOL) 12975 INTEGER NCTEXT(MAXROW) 12976 INTEGER IDIGIT(*) 12977 INTEGER NTOT(*) 12978 INTEGER IWHTML(*) 12979 INTEGER IWRTF(*) 12980 REAL AVAL(MAXROW,MAXCOL) 12981C 12982 CHARACTER*4 ICAPSW 12983 CHARACTER*4 ICAPTY 12984 CHARACTER*4 ISUBRO 12985 CHARACTER*4 IBUGA3 12986 CHARACTER*4 IERROR 12987C 12988 CHARACTER*4 ISUBN1 12989 CHARACTER*4 ISUBN2 12990 CHARACTER*4 ISTEPN 12991 CHARACTER*4 ICSVWZ 12992 CHARACTER*1 IBASLC 12993C 12994 LOGICAL IFLAG1 12995 LOGICAL IFLAG2 12996 LOGICAL IFLAG3 12997 LOGICAL IBOLD 12998 LOGICAL IFIRST 12999 LOGICAL ILAST 13000C 13001C--------------------------------------------------------------------- 13002C 13003 INCLUDE 'DPCOST.INC' 13004C 13005 PARAMETER (MAXHED=1024) 13006 INTEGER IWIDTH(MAXHED) 13007 INTEGER NUMDIG(MAXHED) 13008 CHARACTER*8 ALIGN(MAXHED) 13009 CHARACTER*8 VALIGN(MAXHED) 13010 COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN 13011 CHARACTER*60 IVALUE(MAXHED) 13012 INTEGER NCTEMP(MAXHED) 13013 REAL AVALUE(MAXHED) 13014C 13015 CHARACTER*132 ITEMPC 13016C 13017 CHARACTER*4 IRTFMD 13018 COMMON/COMRTF/IRTFMD 13019C 13020C--------------------------------------------------------------------- 13021C 13022 INCLUDE 'DPCOP2.INC' 13023C 13024C-----START POINT----------------------------------------------------- 13025C 13026 ISUBN1='DPDT' 13027 ISUBN2='A2 ' 13028 IERROR='NO' 13029C 13030 DO40I=1,MAXHED 13031 IVAlUE(I)=' ' 13032 AVALUE(I)=0.0 13033 NCTEMP(I)=0 13034 40 CONTINUE 13035C 13036 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTA2')THEN 13037 WRITE(ICOUT,999) 13038 999 FORMAT(1X) 13039 CALL DPWRST('XXX','WRIT') 13040 WRITE(ICOUT,51) 13041 51 FORMAT('**** AT THE BEGINNING OF DPDTA2--') 13042 CALL DPWRST('XXX','WRIT') 13043 WRITE(ICOUT,52)IBUGA3,ISUBRO 13044 52 FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4) 13045 CALL DPWRST('XXX','WRIT') 13046 WRITE(ICOUT,53)MAXLIN,NUMLIN,MAXCOL,NUMCOL,MAXROW,NUMROW 13047 53 FORMAT('MAXLIN,NUMLIN,MAXCOL,NUMCOL,MAXROW,NUMROW = ',6I8) 13048 CALL DPWRST('XXX','WRIT') 13049 IF(NUMLIN.GT.0)THEN 13050 DO54I=1,NUMLIN 13051 DO55J=1,NUMCOL 13052 IF(I.EQ.1)THEN 13053 WRITE(ICOUT,58)J,NTOT(J),IDIGIT(J) 13054 58 FORMAT('J,NTOT(J),IDIGIT(J) = ',3I8) 13055 CALL DPWRST('XXX','WRIT') 13056 ENDIF 13057 IF(NCTITL(I,J).GT.0)THEN 13058 NTEMP=MIN(80,NCTITL(I,J)) 13059 WRITE(ICOUT,56)I,J,NCTITL(I,J),ITITLE(I,J)(1:NTEMP) 13060 56 FORMAT('I,J,NCTITL(I,J),ITITL(I,J)(1:NCTITL) = ', 13061 1 3I5,2X,A80) 13062 CALL DPWRST('XXX','WRIT') 13063 ENDIF 13064 55 CONTINUE 13065 54 CONTINUE 13066 ENDIF 13067 IF(NUMROW.GT.0)THEN 13068 DO57I=1,NUMROW 13069 IF(NCTEXT(I).GT.0)THEN 13070 WRITE(ICOUT,59)I,ITEXT(I)(1:NCTEXT(I)) 13071 59 FORMAT('I,ITEXT(I) = ',I8,A80) 13072 CALL DPWRST('XXX','WRIT') 13073 ENDIF 13074 WRITE(ICOUT,60)I,(AVAL(I,J),J=1,MIN(5,NUMCOL)) 13075 60 FORMAT('I,(AVAL(I,J),J=1,NUMCOL) = ',I8,5G15.7) 13076 CALL DPWRST('XXX','WRIT') 13077 57 CONTINUE 13078 ENDIF 13079 WRITE(ICOUT,62)NCHEAD 13080 62 FORMAT('NCHEAD = ',I5) 13081 CALL DPWRST('XXX','WRIT') 13082 IF(NCHEAD.GT.0)THEN 13083 WRITE(ICOUT,63)IHEAD(1:NCHEAD) 13084 63 FORMAT('NCHEAD,IHEAD = ',A80) 13085 CALL DPWRST('XXX','WRIT') 13086 ENDIF 13087 ENDIF 13088C 13089C ****************************************** 13090C ** STEP 1-- ** 13091C ** WRITE OUT THE TABLE HEADER. ** 13092C ** NOTE THAT THIS MAY CONSIST OF ** 13093C ** MULTIPLE LINES. ** 13094C ****************************************** 13095C 13096 ISTEPN='1' 13097 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DTA2') 13098 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 13099C 13100 IF(IPRINT.EQ.'ON')THEN 13101C 13102 CALL DPCONA(92,IBASLC) 13103C 13104 NHEAD=NUMCOL 13105 IF(NCTEXT(1).GT.0)NHEAD=NUMCOL+1 13106C 13107 DO100I=1,NHEAD 13108 IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN 13109 IWIDTH(I)=IWHTML(I) 13110 IF(VALIGZ(I).EQ.'b')THEN 13111 VALIGN(I)='BOTTOM' 13112 ELSEIF(VALIGZ(I).EQ.'c')THEN 13113 VALIGN(I)='CENTER' 13114 ELSEIF(VALIGZ(I).EQ.'t')THEN 13115 VALIGN(I)='TOP' 13116 ENDIF 13117 IF(ALIGNZ(I).EQ.'l')THEN 13118 ALIGN(I) ='LEFT' 13119 ELSEIF(ALIGNZ(I).EQ.'c')THEN 13120 ALIGN(I) ='CENTER' 13121 ELSEIF(ALIGNZ(I).EQ.'r')THEN 13122 ALIGN(I) ='RIGHT' 13123 ENDIF 13124C 13125 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN 13126 IF(VALIGZ(I).EQ.'b')THEN 13127 VALIGN(I)='b' 13128 ELSEIF(VALIGZ(I).EQ.'c')THEN 13129 VALIGN(I)='c' 13130 ELSEIF(VALIGZ(I).EQ.'t')THEN 13131 VALIGN(I)='t' 13132 ENDIF 13133 IF(ALIGNZ(I).EQ.'l')THEN 13134 ALIGN(I) ='l' 13135 ELSEIF(ALIGNZ(I).EQ.'c')THEN 13136 ALIGN(I) ='c' 13137 ELSEIF(ALIGNZ(I).EQ.'r')THEN 13138 ALIGN(I) ='r' 13139 ENDIF 13140 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN 13141 IWIDTH(I)=IWRTF(I) 13142 IF(VALIGZ(I).EQ.'b')THEN 13143 VALIGN(I)='b' 13144 ELSEIF(VALIGZ(I).EQ.'c')THEN 13145 VALIGN(I)='c' 13146 ELSEIF(VALIGZ(I).EQ.'t')THEN 13147 VALIGN(I)='t' 13148 ENDIF 13149 IF(ALIGNZ(I).EQ.'l')THEN 13150 ALIGN(I) ='l' 13151 ELSEIF(ALIGNZ(I).EQ.'c')THEN 13152 ALIGN(I) ='c' 13153 ELSEIF(ALIGNZ(I).EQ.'r')THEN 13154 ALIGN(I) ='r' 13155 ENDIF 13156 ELSE 13157 IF(VALIGZ(I).EQ.'b')THEN 13158 VALIGN(I)='b' 13159 ELSEIF(VALIGZ(I).EQ.'c')THEN 13160 VALIGN(I)='c' 13161 ELSEIF(VALIGZ(I).EQ.'t')THEN 13162 VALIGN(I)='t' 13163 ENDIF 13164 IF(ALIGNZ(I).EQ.'l')THEN 13165 ALIGN(I) ='l' 13166 ELSEIF(ALIGNZ(I).EQ.'c')THEN 13167 ALIGN(I) ='c' 13168 ELSEIF(ALIGNZ(I).EQ.'r')THEN 13169 ALIGN(I) ='r' 13170 ENDIF 13171 ENDIF 13172 100 CONTINUE 13173C 13174C LOOP THROUGH THE LINES OF THE HEADER 13175C 13176 IF(NUMLIN.GE.1)THEN 13177 DO110I=1,NUMLIN 13178C 13179 DO120J=1,NHEAD 13180 IVALUE(J)=' ' 13181 NCTEMP(J)=0 13182 IF(NCTITL(I,J).GT.0)THEN 13183 NCTEMP(J)=NCTITL(I,J) 13184 IVALUE(J)(1:NCTEMP(J))=ITITLE(I,J)(1:NCTEMP(J)) 13185 ENDIF 13186C 13187 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTA2')THEN 13188 WRITE(ICOUT,106)I,J,NCTEMP(J),IVALUE(J) 13189 106 FORMAT('I,J,NCTEMP(J),IVALUE(J) = ',3I8,A80) 13190 CALL DPWRST('XXX','WRIT') 13191 ENDIF 13192C 13193 120 CONTINUE 13194C 13195 IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN 13196 IF(I.EQ.1)THEN 13197 IFLAG1=.FALSE. 13198 IF(IFIRST)IFLAG1=.TRUE. 13199 IFLAG2=.TRUE. 13200 IF(NCTIT9.LE.0)THEN 13201 IF(IFIRST)THEN 13202 CALL DPHTM1(IHEAD,NCHEAD,IFLAG1,IFLAG2) 13203 ELSE 13204 CALL DPHTMA(ITITL9,NCTIT9,IHEAD,NCHEAD, 13205 1 IFLAG1,IFLAG2) 13206 ENDIF 13207 ELSE 13208 CALL DPHTMA(ITITL9,NCTIT9,IHEAD,NCHEAD,IFLAG1,IFLAG2) 13209 ENDIF 13210 ENDIF 13211 IFLAG1=.FALSE. 13212 IFLAG2=.FALSE. 13213 IF(I.EQ.1)IFLAG1=.TRUE. 13214 IF(I.EQ.NUMLIN)IFLAG2=.TRUE. 13215 CALL DPHTM4(IVALUE,NCTEMP,NHEAD,IFLAG1,IFLAG2) 13216C 13217 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN 13218C 13219 IF(I.EQ.1)THEN 13220 IF(IFIRST)THEN 13221 IFLAG1=.FALSE. 13222 IFLAG2=.FALSE. 13223 IFLAG3=.TRUE. 13224 CALL DPLAT6(IFLAG1,IFLAG2,IFLAG3) 13225 ENDIF 13226 IFLAG1=.FALSE. 13227 IF(IFIRST)IFLAG1=.TRUE. 13228 IFLAG2=.TRUE. 13229C 13230 CALL DPDTLA(IHEAD,NCHEAD,NCT,ISUBRO,IBUGA3,IERROR) 13231 NCHEAD=NCT 13232C 13233 IF(NCTIT9.LE.0)THEN 13234 ITEMPC=' ' 13235 NCHEA2=0 13236 CALL DPLAT1(IHEAD,NCHEAD,ITEMPC,NCHEA2,IFLAG1) 13237 ELSE 13238C 13239 CALL DPDTLA(ITITL9,NCTIT9,NCT,ISUBRO,IBUGA3,IERROR) 13240 NCTIT9=NCT 13241C 13242 CALL DPLAT1(ITITL9,NCTIT9,IHEAD,NCHEAD,IFLAG1) 13243 ENDIF 13244 ENDIF 13245 IFLAG1=.FALSE. 13246 IFLAG2=.FALSE. 13247 IFLAG3=.FALSE. 13248 IF(I.EQ.1)IFLAG1=.TRUE. 13249 IF(I.EQ.NUMLIN)IFLAG2=.TRUE. 13250 IF(I.EQ.1)IFLAG3=.TRUE. 13251C 13252 DO6110JJ=1,NHEAD 13253 NCT=NCTEMP(JJ) 13254 DO6130II=NCTEMP(JJ),1,-1 13255 IF(IVALUE(JJ)(II:II).EQ.'%')THEN 13256 DO6140J=NCT,II,-1 13257 IVALUE(JJ)(J+1:J+1)=IVALUE(JJ)(J:J) 13258 6140 CONTINUE 13259 NCT=NCT+1 13260 IVALUE(JJ)(II:II)=IBASLC 13261 ENDIF 13262 6130 CONTINUE 13263 NCTEMP(JJ)=NCT 13264 6110 CONTINUE 13265C 13266 CALL DPLAT4(IVALUE,NCTEMP,NHEAD,IFLAG1,IFLAG2,IFLAG3) 13267C 13268 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF ')THEN 13269C 13270 8091 FORMAT(A1,'f',I1) 13271 IF(I.EQ.1)THEN 13272 IF(IRTFFP.EQ.'Times New Roman')THEN 13273 ITEMP=0 13274 ELSEIF(IRTFFP.EQ.'Lucida Sans')THEN 13275 ITEMP=6 13276 ELSEIF(IRTFFP.EQ.'Arial')THEN 13277 ITEMP=2 13278 ELSEIF(IRTFFP.EQ.'Bookman')THEN 13279 ITEMP=3 13280 ELSEIF(IRTFFP.EQ.'Georgia')THEN 13281 ITEMP=4 13282 ELSEIF(IRTFFP.EQ.'Tahoma')THEN 13283 ITEMP=5 13284 ELSEIF(IRTFFP.EQ.'Verdana')THEN 13285 ITEMP=7 13286 ELSE 13287 ITEMP=0 13288 ENDIF 13289C 13290 IRTFMD='OFF' 13291C 13292 IF(NCHEAD.GE.1.AND.I.EQ.1)THEN 13293 NCTEM2=NCHEAD+3 13294 IHEAD(4:NCTEM2)=IHEAD(1:NCHEAD) 13295 IHEAD(1:3)=' b ' 13296 IHEAD(1:1)=IBASLC 13297 IF(NCTIT9.LE.0)THEN 13298 ITEMPC=' ' 13299 NCHEA2=0 13300 ELSE 13301 NCHEA2=NCTIT9+3 13302 ITEMPC(4:NCHEA2)=ITITL9(1:NCTIT9) 13303 ITEMPC(1:3)=' b ' 13304 ITEMPC(1:1)=IBASLC 13305 ENDIF 13306 CALL DPRTF1(ITEMPC,NCHEA2,IHEAD,NCTEM2) 13307 ENDIF 13308 ENDIF 13309C 13310 DO130J=1,NHEAD 13311 NCHAR=NCTEMP(J)+3 13312 IVALUE(J)(4:NCHAR)=IVALUE(J)(1:NCTEMP(J)) 13313 IVALUE(J)(1:3)=' b ' 13314 IVALUE(J)(1:1)=IBASLC 13315 NCTEMP(J)=NCHAR 13316 130 CONTINUE 13317 IFLAG1=.FALSE. 13318 IFLAG2=.FALSE. 13319 IF(I.EQ.1)IFLAG1=.TRUE. 13320 IF(I.EQ.NUMLIN)IFLAG2=.TRUE. 13321 CALL DPRTF4(IVALUE,NCTEMP,NHEAD,IFLAG1,IFLAG2) 13322 ELSE 13323 IF(I.EQ.1)THEN 13324 IFLAG1=.TRUE. 13325 CALL DPTAB1(ITITL9,NCTIT9,IHEAD,NCHEAD,IFLAG1) 13326 ENDIF 13327 IFLAG1=.FALSE. 13328 IFLAG2=.FALSE. 13329 IF(I.EQ.1)IFLAG1=.TRUE. 13330 IF(I.EQ.NUMLIN)IFLAG2=.TRUE. 13331C 13332 DO 141 KK=1,NHEAD 13333 IF(ALIGN(KK).EQ.'l' .AND. NCTEMP(KK).LT.NTOT(KK))THEN 13334 DO146JJ=NCTEMP(KK)+1,NTOT(KK) 13335 IVALUE(KK)(JJ:JJ)=' ' 13336 146 CONTINUE 13337 NCTEMP(KK)=NTOT(KK) 13338 ELSEIF(ALIGN(KK).EQ.'c'.AND.NCTEMP(KK).LT.NTOT(KK))THEN 13339 IVALUE(KK)(NCTEMP(KK)+1:NTOT(KK))=' ' 13340 IDIFF=(NTOT(KK)-NCTEMP(KK))/2 13341 IF(IDIFF.GT.0)THEN 13342 ISTRT=IDIFF+1 13343 IF(MOD(NTOT(KK)-NCTEMP(KK),2).EQ.1)IDIFF=IDIFF-1 13344 DO147JJ=NTOT(KK),IDIFF+1,-1 13345 IVALUE(KK)(JJ:JJ)=IVALUE(KK)(JJ-IDIFF:JJ-IDIFF) 13346 147 CONTINUE 13347 IVALUE(KK)(1:IDIFF)=' ' 13348 ENDIF 13349 NCTEMP(KK)=NTOT(KK) 13350 ELSEIF(ALIGN(KK).EQ.'r'.AND.NCTEMP(KK).LT.NTOT(KK))THEN 13351C 13352 IF(ISUBRO.EQ.'DTA2' .OR. IBUGA3.EQ.'ON')THEN 13353 WRITE(ICOUT,157)KK,NCTEMP(KK),NTOT(KK) 13354 157 FORMAT('BEFORE 148: KK,NCTEMP(KK),NTOT(KK) =', 13355 1 3I8) 13356 CALL DPWRST('XXX','WRIT') 13357 WRITE(ICOUT,153)IVALUE(KK)(1:NCTEMP(KK)) 13358 CALL DPWRST('XXX','WRIT') 13359 ENDIF 13360C 13361 IDIFF=NTOT(KK)-NCTEMP(KK) 13362 DO148JJ=NTOT(KK),IDIFF+1,-1 13363 IVALUE(KK)(JJ:JJ)=IVALUE(KK)(JJ-IDIFF:JJ-IDIFF) 13364 148 CONTINUE 13365 IVALUE(KK)(1:IDIFF)=' ' 13366 NCTEMP(KK)=NTOT(KK) 13367 ENDIF 13368C 13369 IF(ISUBRO.EQ.'DTA2' .OR. IBUGA3.EQ.'ON')THEN 13370 WRITE(ICOUT,151)KK,IDIFF,NCTEMP(KK),NUMCOL,NMAX 13371 151 FORMAT('BEFORE CALL DPTAB4: KK,IDIFF,NCTEMP(KK),', 13372 1 'NUMCOL,NMAX=',5I8) 13373 CALL DPWRST('XXX','WRIT') 13374 WRITE(ICOUT,153)IVALUE(KK)(1:NCTEMP(KK)) 13375 153 FORMAT('IVALUE(KK) = ',A80) 13376 CALL DPWRST('XXX','WRIT') 13377 ENDIF 13378C 13379 141 CONTINUE 13380C 13381 CALL DPTAB4(IVALUE,NCTEMP,NHEAD,IFLAG1,IFLAG2,NMAX) 13382C 13383 ENDIF 13384 110 CONTINUE 13385 ENDIF 13386C 13387C ****************************************** 13388C ** STEP 2-- ** 13389C ** WRITE OUT THE TABLE ROWS ** 13390C ****************************************** 13391C 13392 MAXLTA=35 13393 ILINE=0 13394 IF(NUMROW.GE.1)THEN 13395 DO200I=1,NUMROW 13396C 13397 IFLAG1=.FALSE. 13398 IF(I.EQ.NUMROW)IFLAG1=.TRUE. 13399 ISTRT=0 13400CCCCC IF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'LATE')ISTRT=1 13401 IF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'RTF'.AND. 13402 1 NCTEXT(I).GT.0)ISTRT=1 13403 DO210J=1,NUMCOL 13404 AVALUE(ISTRT+J)=AVAL(I,J) 13405 IF(AVALUE(ISTRT+J).EQ.CPUMIN)THEN 13406 NUMDIG(ISTRT+J)=-99 13407 ELSE 13408 NUMDIG(ISTRT+J)=IDIGIT(J) 13409 ENDIF 13410 210 CONTINUE 13411C 13412C FOR HTML, SHIFT DEPENDING ON WHETHER HEADER COLUMN 13413C IS GIVEN. 13414C 13415 IF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'HTML')THEN 13416 IBOLD=.FALSE. 13417 IF(I.EQ.1)THEN 13418 IF(NCTEXT(1).GT.0)THEN 13419 DO211J=1,NUMCOL 13420 ALIGN(J)=ALIGN(J) 13421 VALIGN(J)=VALIGN(J) 13422 IWIDTH(J)=IWIDTH(J) 13423 211 CONTINUE 13424 ELSE 13425 DO212J=NUMCOL+1,2,-1 13426 ALIGN(J)=ALIGN(J-1) 13427 VALIGN(J)=VALIGN(J-1) 13428 IWIDTH(J)=IWIDTH(J-1) 13429 212 CONTINUE 13430 ENDIF 13431 ENDIF 13432 CALL DPHTM5(ITEXT(I),NCTEXT(I),AVALUE,NUMCOL,IBOLD) 13433C 13434C FOR LATEX, WE CANNOT EXTEND TABLES BEYOND A SINGLE 13435C PAGE, SO PUT A CHECK IN. 13436C 13437 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'LATE')THEN 13438 CALL DPDTLA(ITEXT(I),NCTEXT(I),NCT,ISUBRO,IBUGA3,IERROR) 13439 NCTEXT(I)=NCT 13440 CALL DPLAT5(ITEXT(I),NCTEXT(I),AVALUE,NUMCOL,IFLAG1) 13441 ILINE=ILINE+1 13442 IF(ILINE.EQ.MAXLTA .AND. I.NE.NUMROW)THEN 13443 ILINE=0 13444 IFLAG1=.TRUE. 13445 IFLAG2=.FALSE. 13446 IFLAG3=.TRUE. 13447 CALL DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD) 13448 IFLAG1=.FALSE. 13449 IFLAG2=.FALSE. 13450 IFLAG3=.TRUE. 13451 CALL DPLATY(NHEAD) 13452 ENDIF 13453 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'RTF')THEN 13454 IF(NCTEXT(I).GT.0)THEN 13455 NCHAR=NCTEXT(I)+3 13456 ITEXT(I)(4:NCHAR)=ITEXT(I)(1:NCTEXT(I)) 13457 ITEXT(I)(1:3)=' b ' 13458 ITEXT(I)(1:1)=IBASLC 13459 NCTEXT(I)=NCHAR 13460 ELSE 13461 NCHAR=0 13462 ENDIF 13463 IFLAG1=.FALSE. 13464 CALL DPRTF5(ITEXT(I),NCHAR,AVALUE,NUMCOL,IFLAG1) 13465 ELSE 13466 IF(NCTEXT(I).EQ.0)ITEXT(I)=' ' 13467C 13468 IF(ISUBRO.EQ.'DTA2' .OR. IBUGA3.EQ.'ON')THEN 13469 WRITE(ICOUT,251)I,NUMCOL,NMAX 13470 251 FORMAT('BEFORE CALL DPTAB5: I,NUMCOL,NMAX = ',3I5) 13471 CALL DPWRST('XXX','WRIT') 13472 WRITE(ICOUT,252)NCTEXT(I),ITEXT(I)(1:40) 13473 252 FORMAT('NCTEXT(I),ITEXT(I)(1:40) = ',I8,A40) 13474 CALL DPWRST('XXX','WRIT') 13475 WRITE(ICOUT,253)(AVALUE(JJ),JJ=1,MIN(6,NUMCOL)) 13476 253 FORMAT('AVALUE(J),J=1,...,6 = ',6G15.7) 13477 CALL DPWRST('XXX','WRIT') 13478 ENDIF 13479C 13480 ICSVWZ='OFF' 13481 IVALT=-99 13482 CALL DPTAB5(ITEXT(I),NCTEXT(I),AVALUE,NUMCOL,IFLAG1, 13483 1 NMAX,NTOT,ICSVWZ) 13484 ENDIF 13485 200 CONTINUE 13486 ENDIF 13487C 13488C ******************************************* 13489C ** STEP 3-- ** 13490C ** TERMINATE THE TABLE ** 13491C ******************************************* 13492C 13493 ISTEPN='2' 13494 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DTA2') 13495 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 13496C 13497 IF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'HTML')THEN 13498 IFLAG1=.TRUE. 13499 IFLAG2=.FALSE. 13500 IF(ILAST)IFLAG2=.TRUE. 13501 CALL DPHTM2(IFLAG1,IFLAG2,NHEAD) 13502 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'LATE')THEN 13503 IFLAG1=.TRUE. 13504 IFLAG2=.FALSE. 13505 IFLAG3=.FALSE. 13506 IF(ILAST)THEN 13507 IFLAG2=.TRUE. 13508 IFLAG3=.TRUE. 13509 ENDIF 13510 CALL DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD) 13511 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'RTF')THEN 13512 IF(IRTFFF.EQ.'Courier New')THEN 13513 ITEMP=1 13514 ELSEIF(IRTFFF.EQ.'Lucida Console')THEN 13515 ITEMP=8 13516 ENDIF 13517 WRITE(ICOUT,8091)IBASLC,ITEMP 13518 CALL DPWRST(ICOUT,'WRIT') 13519 CALL DPRTF6(NHEAD) 13520 CALL DPRTF6(NHEAD) 13521 IF(ILAST)THEN 13522 IRTFMD='VERB' 13523 ENDIF 13524 ELSE 13525 IF(ILAST)THEN 13526 WRITE(ICOUT,999) 13527 CALL DPWRST('XXX','WRIT') 13528 ENDIF 13529 ENDIF 13530C 13531 ENDIF 13532C 13533 RETURN 13534 END 13535 SUBROUTINE DPDTA4(ITITL9,NCTIT9, 13536 1 IHEAD,NCHEAD,ITITLE,NCTITL, 13537 1 MAXLIN,NUMLIN,MAXCOL,NUMCOL, 13538 1 ITEXT,NCTEXT,AVAL,ITYPCO,MAXROW,NUMROW, 13539 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGZ,ALIGNZ,NMAX, 13540 1 ICAPSW,ICAPTY,IFIRST,ILAST, 13541 1 ISUBRO,IBUGA3,IERROR) 13542C 13543C PURPOSE--THIS ROUTINE PRINTS A MULTI-COLUMN TABLE CONSISTING OF: 13544C 13545C 1) AN OPTIONAL OVERALL TITLE 13546C 2) HEADERS FOR EACH OF THE COLUMNS (THESE HEADERS MAY 13547C CONTAIN MULTIPLE LINES). 13548C 3) A TABLE OF NUMERIC/CHARACTER VALUES. THIS IS A 13549C VARIANT OF TABLE 2 (WHICH ONLY ALLOWS TEXT FIELDS 13550C FOR THE FIRST COLUMN). 13551C 13552C ITITL9 => THE OVERALL TITLE 13553C IHEAD => TABLE CAPTION 13554C ITITLE => LINES FOR THE COLUMN HEADERS 13555C AVAL => MATRIX OF NUMERIC VALUES FOR THE TABLE 13556C ITEXT => MATRIX OF CHARACTER VALUES FOR THE TABLE 13557C 13558C WRITTEN BY--ALAN HECKERT 13559C STATISTICAL ENGINEERING DIVISION 13560C INFORMATION TECHNOLOGY LABORATORY 13561C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13562C GAITHERSBURG, MD 20899-8980 13563C PHONE--301-975-2899 13564C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13565C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13566C LANGUAGE--ANSI FORTRAN (1977) 13567C VERSION NUMBER--2009/9 13568C ORIGINAL VERSION--SEPTEMBER 2009. 13569C UPDATED --JANUARY 2011. USE DPDTLA TO CHECK FOR 13570C CERTAIN CHARACTERS THAT NEED 13571C TO BE ESCAPED FOR LATEX 13572C 13573C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13574C 13575 CHARACTER*(*) IHEAD 13576 CHARACTER*(*) ITITL9 13577 CHARACTER*(*) ITITLE(MAXLIN,MAXCOL) 13578 CHARACTER*4 VALIGZ(*) 13579 CHARACTER*4 ALIGNZ(*) 13580 INTEGER NCTITL(MAXLIN,MAXCOL) 13581 INTEGER NCTEXT(MAXROW,MAXCOL) 13582 INTEGER IDIGIT(*) 13583 INTEGER NTOT(*) 13584 INTEGER IWHTML(*) 13585 INTEGER IWRTF(*) 13586 REAL AVAL(MAXROW,MAXCOL) 13587 CHARACTER*(*) ITEXT(MAXROW,MAXCOL) 13588 CHARACTER*4 ITYPCO(MAXCOL) 13589C 13590 CHARACTER*4 ICAPSW 13591 CHARACTER*4 ICAPTY 13592 CHARACTER*4 ISUBRO 13593 CHARACTER*4 IBUGA3 13594 CHARACTER*4 IERROR 13595C 13596 CHARACTER*4 ISUBN1 13597 CHARACTER*4 ISUBN2 13598 CHARACTER*4 ISTEPN 13599 CHARACTER*4 ICSVWZ 13600 CHARACTER*1 IBASLC 13601C 13602 LOGICAL IFLAG1 13603 LOGICAL IFLAG2 13604 LOGICAL IFLAG3 13605 LOGICAL IFLAGA 13606 LOGICAL IFLAGB 13607 LOGICAL IFIRST 13608 LOGICAL ILAST 13609C 13610C--------------------------------------------------------------------- 13611C 13612 INCLUDE 'DPCOST.INC' 13613C 13614 PARAMETER (MAXHED=1024) 13615 INTEGER IWIDTH(MAXHED) 13616 INTEGER NUMDIG(MAXHED) 13617 CHARACTER*8 ALIGN(MAXHED) 13618 CHARACTER*8 VALIGN(MAXHED) 13619 COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN 13620 CHARACTER*60 IVALUE(MAXHED) 13621 INTEGER NCTEMP(MAXHED) 13622 REAL AVALUE(MAXHED) 13623C 13624 CHARACTER*132 ITEMPC 13625C 13626 CHARACTER*4 IRTFMD 13627 COMMON/COMRTF/IRTFMD 13628C 13629C--------------------------------------------------------------------- 13630C 13631 INCLUDE 'DPCOP2.INC' 13632C 13633C-----START POINT----------------------------------------------------- 13634C 13635 ISUBN1='DPDT' 13636 ISUBN2='A4 ' 13637C 13638 IERROR='NO' 13639C 13640 DO40I=1,MAXHED 13641 IVALUE(I)=' ' 13642 AVALUE(I)=0.0 13643 NCTEMP(I)=0 13644 40 CONTINUE 13645C 13646 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTA4')THEN 13647 WRITE(ICOUT,999) 13648 999 FORMAT(1X) 13649 CALL DPWRST('XXX','WRIT') 13650 WRITE(ICOUT,51) 13651 51 FORMAT('**** AT THE BEGINNING OF DPDTA4--') 13652 CALL DPWRST('XXX','WRIT') 13653 WRITE(ICOUT,52)IBUGA3,ISUBRO 13654 52 FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4) 13655 CALL DPWRST('XXX','WRIT') 13656 WRITE(ICOUT,53)MAXLIN,MAXROW,NUMROW,NUMCOL,NUMLIN 13657 53 FORMAT('MAXLIN,MAXROW,NUMROW,NUMCOL,NUMLIN = ',5I8) 13658 CALL DPWRST('XXX','WRIT') 13659 IF(NUMLIN.GT.0)THEN 13660 DO54I=1,NUMLIN 13661 DO55J=1,NUMCOL 13662 IF(NCTITL(I,J).GT.0)THEN 13663 NTEMP=MIN(80,NCTITL(I,J)) 13664 WRITE(ICOUT,56)I,J,NCTITL(I,J),ITITLE(I,J)(1:NTEMP) 13665 56 FORMAT('I,J,NCTITL(I,J),ITITL(I,J)(1:NCTITL) = ', 13666 1 3I8,2X,A80) 13667 CALL DPWRST('XXX','WRIT') 13668 ELSE 13669 WRITE(ICOUT,47)I,J,NCTITL(I,J) 13670 47 FORMAT('I,J,NCTITL(I,J) = ',3I8) 13671 CALL DPWRST('XXX','WRIT') 13672 ENDIF 13673 55 CONTINUE 13674 54 CONTINUE 13675 ENDIF 13676 IF(NUMROW.GT.0)THEN 13677 DO57I=1,NUMROW 13678 WRITE(ICOUT,60)I,(AVAL(I,J),J=1,MIN(5,NUMCOL)) 13679 60 FORMAT('I,(AVAL(I,J),J=1,NUMCOL) = ',I8,5G15.7) 13680 CALL DPWRST('XXX','WRIT') 13681 57 CONTINUE 13682 DO77I=1,NUMROW 13683 DO79J=1,NUMCOL 13684 WRITE(ICOUT,80)I,J,ITEXT(I,J) 13685 80 FORMAT('I,J,ITEXT(I,J) = ',2I5,2X,A60) 13686 CALL DPWRST('XXX','WRIT') 13687 79 CONTINUE 13688 77 CONTINUE 13689 ENDIF 13690 WRITE(ICOUT,62)NCHEAD 13691 62 FORMAT('NCHEAD = ',I5) 13692 CALL DPWRST('XXX','WRIT') 13693 IF(NCHEAD.GT.0)THEN 13694 WRITE(ICOUT,63)IHEAD(1:NCHEAD) 13695 63 FORMAT('NCHEAD,IHEAD = ',A80) 13696 CALL DPWRST('XXX','WRIT') 13697 ENDIF 13698 DO65I=1,NUMCOL 13699 WRITE(ICOUT,67)I,IWRTF(I) 13700 67 FORMAT('I,IWRTF(I) = ',I5,I8) 13701 CALL DPWRST('XXX','WRIT') 13702 65 CONTINUE 13703 ENDIF 13704C 13705C ****************************************** 13706C ** STEP 1-- ** 13707C ** WRITE OUT THE TABLE HEADER. ** 13708C ** NOTE THAT THIS MAY CONSIST OF ** 13709C ** MULTIPLE LINES. ** 13710C ****************************************** 13711C 13712 ISTEPN='1' 13713 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DTA4') 13714 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 13715C 13716 IF(IPRINT.EQ.'ON')THEN 13717C 13718 CALL DPCONA(92,IBASLC) 13719C 13720 NHEAD=NUMCOL 13721C 13722 DO100I=1,NUMCOL 13723 IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN 13724 IWIDTH(I)=IWHTML(I) 13725 IF(VALIGZ(I).EQ.'b')THEN 13726 VALIGN(I)='BOTTOM' 13727 ELSEIF(VALIGZ(I).EQ.'c')THEN 13728 VALIGN(I)='CENTER' 13729 ELSEIF(VALIGZ(I).EQ.'t')THEN 13730 VALIGN(I)='TOP' 13731 ENDIF 13732 IF(ALIGNZ(I).EQ.'l')THEN 13733 ALIGN(I) ='LEFT' 13734 ELSEIF(ALIGNZ(I).EQ.'c')THEN 13735 ALIGN(I) ='CENTER' 13736 ELSEIF(ALIGNZ(I).EQ.'r')THEN 13737 ALIGN(I) ='RIGHT' 13738 ENDIF 13739C 13740 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN 13741 IF(VALIGZ(I).EQ.'b')THEN 13742 VALIGN(I)='b' 13743 ELSEIF(VALIGZ(I).EQ.'c')THEN 13744 VALIGN(I)='c' 13745 ELSEIF(VALIGZ(I).EQ.'t')THEN 13746 VALIGN(I)='t' 13747 ENDIF 13748 IF(ALIGNZ(I).EQ.'l')THEN 13749 ALIGN(I) ='l' 13750 ELSEIF(ALIGNZ(I).EQ.'c')THEN 13751 ALIGN(I) ='c' 13752 ELSEIF(ALIGNZ(I).EQ.'r')THEN 13753 ALIGN(I) ='r' 13754 ENDIF 13755 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN 13756 IWIDTH(I)=IWRTF(I) 13757 IF(VALIGZ(I).EQ.'b')THEN 13758 VALIGN(I)='b' 13759 ELSEIF(VALIGZ(I).EQ.'c')THEN 13760 VALIGN(I)='c' 13761 ELSEIF(VALIGZ(I).EQ.'t')THEN 13762 VALIGN(I)='t' 13763 ENDIF 13764 IF(ALIGNZ(I).EQ.'l')THEN 13765 ALIGN(I) ='l' 13766 ELSEIF(ALIGNZ(I).EQ.'c')THEN 13767 ALIGN(I) ='c' 13768 ELSEIF(ALIGNZ(I).EQ.'r')THEN 13769 ALIGN(I) ='r' 13770 ENDIF 13771 ELSE 13772 IF(VALIGZ(I).EQ.'b')THEN 13773 VALIGN(I)='b' 13774 ELSEIF(VALIGZ(I).EQ.'c')THEN 13775 VALIGN(I)='c' 13776 ELSEIF(VALIGZ(I).EQ.'t')THEN 13777 VALIGN(I)='t' 13778 ENDIF 13779 IF(ALIGNZ(I).EQ.'l')THEN 13780 ALIGN(I) ='l' 13781 ELSEIF(ALIGNZ(I).EQ.'c')THEN 13782 ALIGN(I) ='c' 13783 ELSEIF(ALIGNZ(I).EQ.'r')THEN 13784 ALIGN(I) ='r' 13785 ENDIF 13786 ENDIF 13787 100 CONTINUE 13788C 13789C LOOP THROUGH THE LINES OF THE HEADER 13790C 13791 IF(NUMLIN.GE.1)THEN 13792 DO110I=1,NUMLIN 13793C 13794 DO120J=1,NUMCOL 13795 IVALUE(J)=' ' 13796 NCTEMP(J)=0 13797 IF(NCTITL(I,J).GT.0)THEN 13798 NCTEMP(J)=NCTITL(I,J) 13799 IVALUE(J)(1:NCTEMP(J))=ITITLE(I,J)(1:NCTEMP(J)) 13800 ENDIF 13801C 13802 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTA4')THEN 13803 WRITE(ICOUT,106)I,J,NCTEMP(J),IVALUE(J) 13804 106 FORMAT('I,J,NCTEMP(J),IVALUE(J) = ',3I8,A80) 13805 CALL DPWRST('XXX','WRIT') 13806 ENDIF 13807C 13808 120 CONTINUE 13809C 13810 IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN 13811 IF(I.EQ.1)THEN 13812 IFLAG1=.FALSE. 13813 IF(IFIRST)IFLAG1=.TRUE. 13814 IFLAG2=.TRUE. 13815 IF(NCTIT9.LE.0)THEN 13816 IF(IFIRST)THEN 13817 CALL DPHTM1(IHEAD,NCHEAD,IFLAG1,IFLAG2) 13818 ELSE 13819 CALL DPHTMA(ITITL9,NCTIT9,IHEAD,NCHEAD, 13820 1 IFLAG1,IFLAG2) 13821 ENDIF 13822 ELSE 13823 CALL DPHTMA(ITITL9,NCTIT9,IHEAD,NCHEAD,IFLAG1,IFLAG2) 13824 ENDIF 13825 ENDIF 13826 IFLAG1=.FALSE. 13827 IFLAG2=.FALSE. 13828 IF(I.EQ.1)IFLAG1=.TRUE. 13829 IF(I.EQ.NUMLIN)IFLAG2=.TRUE. 13830 CALL DPHTM4(IVALUE,NCTEMP,NUMCOL,IFLAG1,IFLAG2) 13831C 13832 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN 13833C 13834 IF(I.EQ.1)THEN 13835 IF(IFIRST)THEN 13836 IFLAG1=.FALSE. 13837 IFLAG2=.FALSE. 13838 IFLAG3=.TRUE. 13839 CALL DPLAT6(IFLAG1,IFLAG2,IFLAG3) 13840 ENDIF 13841 IFLAG1=.FALSE. 13842 IF(IFIRST)IFLAG1=.TRUE. 13843 IFLAG2=.TRUE. 13844C 13845 CALL DPDTLA(IHEAD,NCHEAD,NCT,ISUBRO,IBUGA3,IERROR) 13846 NCHEAD=NCT 13847C 13848 IF(NCTIT9.LE.0)THEN 13849 ITEMPC=' ' 13850 NCHEA2=0 13851 CALL DPLAT1(IHEAD,NCHEAD,ITEMPC,NCHEA2,IFLAG1) 13852 ELSE 13853C 13854 NCT=NCTIT9 13855 DO6030II=NCTIT9,1,-1 13856 IF(ITITL9(II:II).EQ.'%')THEN 13857 DO6040J=NCT,II,-1 13858 ITITL9(J+1:J+1)=ITITL9(J:J) 13859 6040 CONTINUE 13860 NCT=NCT+1 13861 ITITL9(II:II)=IBASLC 13862 ENDIF 13863 6030 CONTINUE 13864 NCTIT9=NCT 13865C 13866 CALL DPLAT1(ITITL9,NCTIT9,IHEAD,NCHEAD,IFLAG1) 13867 ENDIF 13868 ENDIF 13869 IFLAG1=.FALSE. 13870 IFLAG2=.FALSE. 13871 IFLAG3=.FALSE. 13872 IF(I.EQ.1)IFLAG1=.TRUE. 13873 IF(I.EQ.NUMLIN)IFLAG2=.TRUE. 13874 IF(I.EQ.1)IFLAG3=.TRUE. 13875C 13876 DO6110JJ=1,NUMCOL 13877 CALL DPDTLA(IVALUE(JJ),NCTEMP(JJ),NCT, 13878 1 ISUBRO,IBUGA3,IERROR) 13879 NCTEMP(JJ)=NCT 13880 6110 CONTINUE 13881C 13882 CALL DPLAT4(IVALUE,NCTEMP,NUMCOL,IFLAG1,IFLAG2,IFLAG3) 13883C 13884 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF ')THEN 13885C 13886 8091 FORMAT(A1,'f',I1) 13887 IF(I.EQ.1)THEN 13888 IF(IRTFFP.EQ.'Times New Roman')THEN 13889 ITEMP=0 13890 ELSEIF(IRTFFP.EQ.'Lucida Sans')THEN 13891 ITEMP=6 13892 ELSEIF(IRTFFP.EQ.'Arial')THEN 13893 ITEMP=2 13894 ELSEIF(IRTFFP.EQ.'Bookman')THEN 13895 ITEMP=3 13896 ELSEIF(IRTFFP.EQ.'Georgia')THEN 13897 ITEMP=4 13898 ELSEIF(IRTFFP.EQ.'Tahoma')THEN 13899 ITEMP=5 13900 ELSEIF(IRTFFP.EQ.'Verdana')THEN 13901 ITEMP=7 13902 ELSE 13903 ITEMP=0 13904 ENDIF 13905C 13906 IRTFMD='OFF' 13907C 13908 IF(NCHEAD.GE.1.AND.I.EQ.1)THEN 13909 NCTEM2=NCHEAD+3 13910 IHEAD(4:NCTEM2)=IHEAD(1:NCHEAD) 13911 IHEAD(1:3)=' b ' 13912 IHEAD(1:1)=IBASLC 13913 IF(NCTIT9.LE.0)THEN 13914 ITEMPC=' ' 13915 NCHEA2=0 13916 ELSE 13917 NCHEA2=NCTIT9+3 13918 ITEMPC(4:NCHEA2)=ITITL9(1:NCTIT9) 13919 ITEMPC(1:3)=' b ' 13920 ITEMPC(1:1)=IBASLC 13921 ENDIF 13922 CALL DPRTF1(ITEMPC,NCHEA2,IHEAD,NCTEM2) 13923 ENDIF 13924 ENDIF 13925C 13926 DO130J=1,NUMCOL 13927 NCHAR=NCTEMP(J)+3 13928 IVALUE(J)(4:NCHAR)=IVALUE(J)(1:NCTEMP(J)) 13929 IVALUE(J)(1:3)=' b ' 13930 IVALUE(J)(1:1)=IBASLC 13931 NCTEMP(J)=NCHAR 13932 130 CONTINUE 13933 IFLAG1=.FALSE. 13934 IFLAG2=.FALSE. 13935 IF(I.EQ.1)IFLAG1=.TRUE. 13936 IF(I.EQ.NUMLIN)IFLAG2=.TRUE. 13937 CALL DPRTF4(IVALUE,NCTEMP,NUMCOL,IFLAG1,IFLAG2) 13938 ELSE 13939 IF(I.EQ.1)THEN 13940 IFLAG1=.TRUE. 13941 CALL DPTAB1(ITITL9,NCTIT9,IHEAD,NCHEAD,IFLAG1) 13942 ENDIF 13943 IFLAG1=.FALSE. 13944 IFLAG2=.FALSE. 13945 IF(I.EQ.1)IFLAG1=.TRUE. 13946 IF(I.EQ.NUMLIN)IFLAG2=.TRUE. 13947C 13948 DO 141 KK=1,NUMCOL 13949 IF(ALIGN(KK).EQ.'l' .AND. NCTEMP(KK).LT.NTOT(KK))THEN 13950 DO146JJ=NCTEMP(KK)+1,NTOT(KK) 13951 IVALUE(KK)(JJ:JJ)=' ' 13952 146 CONTINUE 13953 NCTEMP(KK)=NTOT(KK) 13954 ELSEIF(ALIGN(KK).EQ.'c'.AND.NCTEMP(KK).LT.NTOT(KK))THEN 13955 IVALUE(KK)(NCTEMP(KK):NTOT(KK))=' ' 13956 IDIFF=(NTOT(KK)-NCTEMP(KK))/2 13957 IF(IDIFF.GT.0)THEN 13958 DO147JJ=NTOT(KK),IDIFF+1,-1 13959 IVALUE(KK)(JJ:JJ)=IVALUE(KK)(JJ-IDIFF:JJ-IDIFF) 13960 147 CONTINUE 13961 IVALUE(KK)(1:IDIFF)=' ' 13962 ENDIF 13963 NCTEMP(KK)=NTOT(KK) 13964 ELSEIF(ALIGN(KK).EQ.'r'.AND.NCTEMP(KK).LT.NTOT(KK))THEN 13965C 13966 IF(ISUBRO.EQ.'DTA4' .OR. IBUGA3.EQ.'ON')THEN 13967 WRITE(ICOUT,157)KK,NCTEMP(KK),NTOT(KK) 13968 157 FORMAT('BEFORE 148: KK,NCTEMP(KK),NTOT(KK) =', 13969 1 3I8) 13970 CALL DPWRST('XXX','WRIT') 13971 WRITE(ICOUT,153)IVALUE(KK)(1:NCTEMP(KK)) 13972 CALL DPWRST('XXX','WRIT') 13973 ENDIF 13974C 13975 IDIFF=NTOT(KK)-NCTEMP(KK) 13976 DO148JJ=NTOT(KK),IDIFF+1,-1 13977 IVALUE(KK)(JJ:JJ)=IVALUE(KK)(JJ-IDIFF:JJ-IDIFF) 13978 148 CONTINUE 13979 IVALUE(KK)(1:IDIFF)=' ' 13980 NCTEMP(KK)=NTOT(KK) 13981 ENDIF 13982C 13983 IF(ISUBRO.EQ.'DTA4' .OR. IBUGA3.EQ.'ON')THEN 13984 WRITE(ICOUT,151)KK,IDIFF,NCTEMP(KK),NUMCOL,NMAX 13985 151 FORMAT('BEFORE CALL DPTAB4: KK,IDIFF,NCTEMP(KK),', 13986 1 'NUMCOL,NMAX=',5I8) 13987 CALL DPWRST('XXX','WRIT') 13988 WRITE(ICOUT,153)IVALUE(KK)(1:NCTEMP(KK)) 13989 153 FORMAT('IVALUE(KK) = ',A80) 13990 CALL DPWRST('XXX','WRIT') 13991 ENDIF 13992C 13993 141 CONTINUE 13994C 13995 CALL DPTAB4(IVALUE,NCTEMP,NUMCOL,IFLAG1,IFLAG2,NMAX) 13996C 13997 ENDIF 13998 110 CONTINUE 13999 ENDIF 14000C 14001C ****************************************** 14002C ** STEP 2-- ** 14003C ** WRITE OUT THE TABLE ROWS ** 14004C ****************************************** 14005C 14006 IFLAGA=.FALSE. 14007 IFLAGB=.FALSE. 14008 MAXLTA=35 14009 ILINE=0 14010 IF(NUMROW.GE.1)THEN 14011 DO200I=1,NUMROW 14012C 14013 IFLAG1=.FALSE. 14014 IF(I.EQ.NUMROW)IFLAG1=.TRUE. 14015 DO210J=1,NUMCOL 14016 AVALUE(J)=AVAL(I,J) 14017 IF(AVALUE(J).EQ.CPUMIN)THEN 14018 NUMDIG(J)=-99 14019 ELSE 14020 NUMDIG(J)=IDIGIT(J) 14021 ENDIF 14022 IVALUE(J)=' ' 14023 NTEMP=NCTEXT(I,J) 14024 NCTEMP(J)=NTEMP 14025 IF(NTEMP.GT.0)THEN 14026 IVALUE(J)(1:NTEMP)=ITEXT(I,J)(1:NTEMP) 14027C 14028 IF(ICAPTY.EQ.'LATE')THEN 14029 CALL DPDTLA(IVALUE(J),NTEMP,NCT,ISUBRO,IBUGA3,IERROR) 14030 NTEMP=NCT 14031 ENDIF 14032C 14033 ENDIF 14034C 14035 IF(ISUBRO.EQ.'DTA4' .OR. IBUGA3.EQ.'ON')THEN 14036 WRITE(ICOUT,211)I,J,ITYPCO(J),AVALUE(J),IVALUE(J) 14037 211 FORMAT('I,J,ITYPCO(J),AVALUE(J),IVALUE(J) = ', 14038 1 2I8,2X,A4,2X,G15.7,2X,A60) 14039 CALL DPWRST('XXX','WRIT') 14040 ENDIF 14041C 14042 210 CONTINUE 14043C 14044 IF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'HTML')THEN 14045 CALL DPHTMY(IVALUE,NCTEMP,AVALUE,NUMCOL,ITYPCO, 14046 1 IFLAGA,IFLAGB) 14047C 14048C FOR LATEX, WE CANNOT EXTEND TABLES BEYOND A SINGLE 14049C PAGE, SO PUT A CHECK IN. 14050C 14051 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'LATE')THEN 14052 CALL DPLATW(IVALUE,NCTEMP,AVALUE,NUMCOL,ITYPCO, 14053 1 IFLAGA,IFLAGB) 14054 ILINE=ILINE+1 14055 IF(ILINE.EQ.MAXLTA .AND. I.NE.NUMROW)THEN 14056 ILINE=0 14057 IFLAG1=.TRUE. 14058 IFLAG2=.FALSE. 14059 IFLAG3=.TRUE. 14060 CALL DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD) 14061 IFLAG1=.FALSE. 14062 IFLAG2=.FALSE. 14063 IFLAG3=.TRUE. 14064 CALL DPLATY(NHEAD) 14065 ENDIF 14066 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'RTF')THEN 14067 CALL DPRTFY(IVALUE,NCTEMP,AVALUE,NUMCOL,ITYPCO, 14068 1 IFLAGA,IFLAGB) 14069 ELSE 14070C 14071 IF(ISUBRO.EQ.'DTA4' .OR. IBUGA3.EQ.'ON')THEN 14072 WRITE(ICOUT,251)I,NUMCOL,NMAX 14073 251 FORMAT('BEFORE CALL DPTAB8: I,NUMCOL,NMAX = ', 14074 1 3I5) 14075 CALL DPWRST('XXX','WRIT') 14076 ENDIF 14077C 14078 ICSVWZ='OFF' 14079 IVALT=-99 14080 CALL DPTABY(IVALUE,NCTEMP,AVALUE,NUMCOL,ITYPCO, 14081 1 IFLAGA,IFLAGB,NMAX,NTOT,ICSVWZ,IVALT, 14082 1 IBUGA3,ISUBRO) 14083 ENDIF 14084 200 CONTINUE 14085 ENDIF 14086C 14087C ******************************************* 14088C ** STEP 3-- ** 14089C ** TERMINATE THE TABLE ** 14090C ******************************************* 14091C 14092 ISTEPN='2' 14093 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DTA4') 14094 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14095C 14096 IF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'HTML')THEN 14097 IFLAG1=.TRUE. 14098 IFLAG2=.FALSE. 14099 IF(ILAST)IFLAG2=.TRUE. 14100 CALL DPHTM2(IFLAG1,IFLAG2,NHEAD) 14101 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'LATE')THEN 14102 IFLAG1=.TRUE. 14103 IFLAG2=.FALSE. 14104 IFLAG3=.FALSE. 14105 IF(ILAST)THEN 14106 IFLAG2=.TRUE. 14107 IFLAG3=.TRUE. 14108 ENDIF 14109 CALL DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD) 14110 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'RTF')THEN 14111 IF(IRTFFF.EQ.'Courier New')THEN 14112 ITEMP=1 14113 ELSEIF(IRTFFF.EQ.'Lucida Console')THEN 14114 ITEMP=8 14115 ENDIF 14116 WRITE(ICOUT,8091)IBASLC,ITEMP 14117 CALL DPWRST(ICOUT,'WRIT') 14118 CALL DPRTF6(NHEAD) 14119 CALL DPRTF6(NHEAD) 14120 IF(ILAST)THEN 14121 IRTFMD='VERB' 14122 ENDIF 14123 ELSE 14124 IF(ILAST)THEN 14125 WRITE(ICOUT,999) 14126 CALL DPWRST('XXX','WRIT') 14127 ENDIF 14128 ENDIF 14129C 14130 ENDIF 14131C 14132 RETURN 14133 END 14134 SUBROUTINE DPDTA5(ITITL9,NCTIT9, 14135 1 IHEAD,NCHEAD,ITITLE,NCTITL, 14136 1 MAXLIN,NUMLIN,MAXCOL,NUMCOL, 14137 1 ITEXT,NCTEXT,AVAL,ITYPCO,MAXROW,NUMROW, 14138 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGZ,ALIGNZ,NMAX, 14139 1 ICAPSW,ICAPTY,IFIRST,ILAST, 14140 1 IFLAGS,IFLAGE, 14141 1 ISUBRO,IBUGA3,IERROR) 14142C 14143C PURPOSE--THIS ROUTINE PRINTS A MULTI-COLUMN TABLE CONSISTING OF: 14144C 14145C 1) AN OPTIONAL OVERALL TITLE 14146C 2) HEADERS FOR EACH OF THE COLUMNS (THESE HEADERS MAY 14147C CONTAIN MULTIPLE LINES). 14148C 3) A TABLE OF NUMERIC/CHARACTER VALUES. THIS IS A 14149C VARIANT OF TABLE 2 (WHICH ONLY ALLOWS TEXT FIELDS 14150C FOR THE FIRST COLUMN). 14151C 14152C ITITL9 => THE OVERALL TITLE 14153C IHEAD => TABLE CAPTION 14154C ITITLE => LINES FOR THE COLUMN HEADERS 14155C AVAL => MATRIX OF NUMERIC VALUES FOR THE TABLE 14156C ITEXT => MATRIX OF CHARACTER VALUES FOR THE TABLE 14157C 14158C NOTE THAT THIS IS A SLIGHTLY MODIFIED VERSION OF 14159C DPDTA4. IN SOME CASES, THE NUMBER OF ROWS IN THE 14160C TABLE MAY NOT BE FIXED (AND IN FACT MAY BE RATHER 14161C LARGE). DPDTA5 ALLOWS THE ROWS OF THE TABLE TO BE 14162C SENT IN INCREMENTS. THE IFLAGS AND IFLAGE SPECIFY 14163C WHETHER THE TABLE HEADERS OR TRAILERS ARE TO BE 14164C PRINTED, RESPECTIVELY. 14165C 14166C WRITTEN BY--ALAN HECKERT 14167C STATISTICAL ENGINEERING DIVISION 14168C INFORMATION TECHNOLOGY LABORATORY 14169C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 14170C GAITHERSBURG, MD 20899-8980 14171C PHONE--301-975-2899 14172C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 14173C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 14174C LANGUAGE--ANSI FORTRAN (1977) 14175C VERSION NUMBER--2009/9 14176C ORIGINAL VERSION--SEPTEMBER 2009. 14177C UPDATED --JANUARY 2011. USE DPDTLA TO CHECK FOR 14178C CERTAIN CHARACTERS THAT NEED 14179C TO BE ESCAPED FOR LATEX 14180C UPDATED --FEBRUARY 2020. CALL LIST TO DPTABY 14181C 14182C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 14183C 14184 CHARACTER*(*) IHEAD 14185 CHARACTER*(*) ITITL9 14186 CHARACTER*(*) ITITLE(MAXLIN,MAXCOL) 14187 CHARACTER*4 VALIGZ(*) 14188 CHARACTER*4 ALIGNZ(*) 14189 INTEGER NCTITL(MAXLIN,MAXCOL) 14190 INTEGER NCTEXT(MAXROW,MAXCOL) 14191 INTEGER IDIGIT(*) 14192 INTEGER NTOT(*) 14193 INTEGER IWHTML(*) 14194 INTEGER IWRTF(*) 14195 REAL AVAL(MAXROW,MAXCOL) 14196 CHARACTER*(*) ITEXT(MAXROW,MAXCOL) 14197 CHARACTER*4 ITYPCO(MAXCOL) 14198C 14199 CHARACTER*4 ICAPSW 14200 CHARACTER*4 ICAPTY 14201 CHARACTER*4 ISUBRO 14202 CHARACTER*4 IBUGA3 14203 CHARACTER*4 IERROR 14204C 14205 CHARACTER*4 ISUBN1 14206 CHARACTER*4 ISUBN2 14207 CHARACTER*4 ISTEPN 14208 CHARACTER*4 ICSVWZ 14209 CHARACTER*1 IBASLC 14210C 14211 LOGICAL IFLAG1 14212 LOGICAL IFLAG2 14213 LOGICAL IFLAG3 14214 LOGICAL IFLAGA 14215 LOGICAL IFLAGB 14216 LOGICAL IFLAGS 14217 LOGICAL IFLAGE 14218 LOGICAL IFIRST 14219 LOGICAL ILAST 14220C 14221C--------------------------------------------------------------------- 14222C 14223 INCLUDE 'DPCOST.INC' 14224C 14225 PARAMETER (MAXHED=1024) 14226 INTEGER IWIDTH(MAXHED) 14227 INTEGER NUMDIG(MAXHED) 14228 CHARACTER*8 ALIGN(MAXHED) 14229 CHARACTER*8 VALIGN(MAXHED) 14230 COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN 14231 CHARACTER*60 IVALUE(MAXHED) 14232 INTEGER NCTEMP(MAXHED) 14233 REAL AVALUE(MAXHED) 14234C 14235 CHARACTER*132 ITEMPC 14236C 14237 CHARACTER*4 IRTFMD 14238 COMMON/COMRTF/IRTFMD 14239C 14240C--------------------------------------------------------------------- 14241C 14242 INCLUDE 'DPCOP2.INC' 14243C 14244C-----START POINT----------------------------------------------------- 14245C 14246 ISUBN1='DPDT' 14247 ISUBN2='A5 ' 14248C 14249 IERROR='NO' 14250C 14251 DO40I=1,MAXHED 14252 IVALUE(I)=' ' 14253 AVALUE(I)=0.0 14254 NCTEMP(I)=0 14255 40 CONTINUE 14256C 14257 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTA5')THEN 14258 WRITE(ICOUT,999) 14259 999 FORMAT(1X) 14260 CALL DPWRST('XXX','WRIT') 14261 WRITE(ICOUT,51) 14262 51 FORMAT('**** AT THE BEGINNING OF DPDTA5--') 14263 CALL DPWRST('XXX','WRIT') 14264 WRITE(ICOUT,52)IBUGA3,ISUBRO 14265 52 FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4) 14266 CALL DPWRST('XXX','WRIT') 14267 WRITE(ICOUT,53)MAXLIN,MAXROW,NUMROW,NUMCOL,NUMLIN 14268 53 FORMAT('MAXLIN,MAXROW,NUMROW,NUMCOL,NUMLIN = ',5I8) 14269 CALL DPWRST('XXX','WRIT') 14270 IF(NUMLIN.GT.0)THEN 14271 DO54I=1,NUMLIN 14272 DO55J=1,NUMCOL 14273 IF(NCTITL(I,J).GT.0)THEN 14274 NTEMP=MIN(80,NCTITL(I,J)) 14275 WRITE(ICOUT,56)I,J,NCTITL(I,J),ITITLE(I,J)(1:NTEMP) 14276 56 FORMAT('I,J,NCTITL(I,J),ITITL(I,J)(1:NCTITL) = ', 14277 1 3I5,2X,A80) 14278 CALL DPWRST('XXX','WRIT') 14279 ENDIF 14280 55 CONTINUE 14281 54 CONTINUE 14282 ENDIF 14283 IF(NUMROW.GT.0)THEN 14284 DO57I=1,NUMROW 14285 WRITE(ICOUT,60)I,(AVAL(I,J),J=1,MIN(5,NUMCOL)) 14286 60 FORMAT('I,(AVAL(I,J),J=1,NUMCOL) = ',I8,5G15.7) 14287 CALL DPWRST('XXX','WRIT') 14288 57 CONTINUE 14289 DO77I=1,NUMROW 14290 DO79J=1,NUMCOL 14291 WRITE(ICOUT,80)I,J,ITEXT(I,J) 14292 80 FORMAT('I,J,ITEXT(I,J) = ',2I5,2X,A60) 14293 CALL DPWRST('XXX','WRIT') 14294 79 CONTINUE 14295 77 CONTINUE 14296 ENDIF 14297 WRITE(ICOUT,62)NCHEAD 14298 62 FORMAT('NCHEAD = ',I5) 14299 CALL DPWRST('XXX','WRIT') 14300 IF(NCHEAD.GT.0)THEN 14301 WRITE(ICOUT,63)IHEAD(1:NCHEAD) 14302 63 FORMAT('NCHEAD,IHEAD = ',A80) 14303 CALL DPWRST('XXX','WRIT') 14304 ENDIF 14305 ENDIF 14306C 14307C ****************************************** 14308C ** STEP 1-- ** 14309C ** WRITE OUT THE TABLE HEADER. ** 14310C ** NOTE THAT THIS MAY CONSIST OF ** 14311C ** MULTIPLE LINES. ** 14312C ****************************************** 14313C 14314 ISTEPN='1' 14315 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DTA5') 14316 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14317C 14318 IF(IPRINT.EQ.'ON')THEN 14319C 14320 CALL DPCONA(92,IBASLC) 14321C 14322C SKIP HEADER IF REQUESTED 14323C 14324 IF(.NOT.IFLAGS)GOTO199 14325C 14326 NHEAD=NUMCOL 14327C 14328 DO100I=1,NUMCOL 14329 IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN 14330 IWIDTH(I)=IWHTML(I) 14331 IF(VALIGZ(I).EQ.'b')THEN 14332 VALIGN(I)='BOTTOM' 14333 ELSEIF(VALIGZ(I).EQ.'c')THEN 14334 VALIGN(I)='CENTER' 14335 ELSEIF(VALIGZ(I).EQ.'t')THEN 14336 VALIGN(I)='TOP' 14337 ENDIF 14338 IF(ALIGNZ(I).EQ.'l')THEN 14339 ALIGN(I) ='LEFT' 14340 ELSEIF(ALIGNZ(I).EQ.'c')THEN 14341 ALIGN(I) ='CENTER' 14342 ELSEIF(ALIGNZ(I).EQ.'r')THEN 14343 ALIGN(I) ='RIGHT' 14344 ENDIF 14345C 14346 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN 14347 IF(VALIGZ(I).EQ.'b')THEN 14348 VALIGN(I)='b' 14349 ELSEIF(VALIGZ(I).EQ.'c')THEN 14350 VALIGN(I)='c' 14351 ELSEIF(VALIGZ(I).EQ.'t')THEN 14352 VALIGN(I)='t' 14353 ENDIF 14354 IF(ALIGNZ(I).EQ.'l')THEN 14355 ALIGN(I) ='l' 14356 ELSEIF(ALIGNZ(I).EQ.'c')THEN 14357 ALIGN(I) ='c' 14358 ELSEIF(ALIGNZ(I).EQ.'r')THEN 14359 ALIGN(I) ='r' 14360 ENDIF 14361 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN 14362 IWIDTH(I)=IWRTF(I) 14363 IF(VALIGZ(I).EQ.'b')THEN 14364 VALIGN(I)='b' 14365 ELSEIF(VALIGZ(I).EQ.'c')THEN 14366 VALIGN(I)='c' 14367 ELSEIF(VALIGZ(I).EQ.'t')THEN 14368 VALIGN(I)='t' 14369 ENDIF 14370 IF(ALIGNZ(I).EQ.'l')THEN 14371 ALIGN(I) ='l' 14372 ELSEIF(ALIGNZ(I).EQ.'c')THEN 14373 ALIGN(I) ='c' 14374 ELSEIF(ALIGNZ(I).EQ.'r')THEN 14375 ALIGN(I) ='r' 14376 ENDIF 14377 ELSE 14378 IF(VALIGZ(I).EQ.'b')THEN 14379 VALIGN(I)='b' 14380 ELSEIF(VALIGZ(I).EQ.'c')THEN 14381 VALIGN(I)='c' 14382 ELSEIF(VALIGZ(I).EQ.'t')THEN 14383 VALIGN(I)='t' 14384 ENDIF 14385 IF(ALIGNZ(I).EQ.'l')THEN 14386 ALIGN(I) ='l' 14387 ELSEIF(ALIGNZ(I).EQ.'c')THEN 14388 ALIGN(I) ='c' 14389 ELSEIF(ALIGNZ(I).EQ.'r')THEN 14390 ALIGN(I) ='r' 14391 ENDIF 14392 ENDIF 14393 100 CONTINUE 14394C 14395C LOOP THROUGH THE LINES OF THE HEADER 14396C 14397 IF(NUMLIN.GE.1)THEN 14398 DO110I=1,NUMLIN 14399C 14400 DO120J=1,NUMCOL 14401 IVALUE(J)=' ' 14402 NCTEMP(J)=0 14403 IF(NCTITL(I,J).GT.0)THEN 14404 NCTEMP(J)=NCTITL(I,J) 14405 IVALUE(J)(1:NCTEMP(J))=ITITLE(I,J)(1:NCTEMP(J)) 14406 ENDIF 14407C 14408 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTA5')THEN 14409 WRITE(ICOUT,106)I,J,NCTEMP(J),IVALUE(J) 14410 106 FORMAT('I,J,NCTEMP(J),IVALUE(J) = ',3I8,A80) 14411 CALL DPWRST('XXX','WRIT') 14412 ENDIF 14413C 14414 120 CONTINUE 14415C 14416 IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN 14417 IF(I.EQ.1)THEN 14418 IFLAG1=.FALSE. 14419 IF(IFIRST)IFLAG1=.TRUE. 14420 IFLAG2=.TRUE. 14421 IF(NCTIT9.LE.0)THEN 14422 IF(IFIRST)THEN 14423 CALL DPHTM1(IHEAD,NCHEAD,IFLAG1,IFLAG2) 14424 ELSE 14425 CALL DPHTMA(ITITL9,NCTIT9,IHEAD,NCHEAD, 14426 1 IFLAG1,IFLAG2) 14427 ENDIF 14428 ELSE 14429 CALL DPHTMA(ITITL9,NCTIT9,IHEAD,NCHEAD,IFLAG1,IFLAG2) 14430 ENDIF 14431 ENDIF 14432 IFLAG1=.FALSE. 14433 IFLAG2=.FALSE. 14434 IF(I.EQ.1)IFLAG1=.TRUE. 14435 IF(I.EQ.NUMLIN)IFLAG2=.TRUE. 14436 CALL DPHTM4(IVALUE,NCTEMP,NUMCOL,IFLAG1,IFLAG2) 14437C 14438 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN 14439C 14440 IF(I.EQ.1)THEN 14441 IF(IFIRST)THEN 14442 IFLAG1=.FALSE. 14443 IFLAG2=.FALSE. 14444 IFLAG3=.TRUE. 14445 CALL DPLAT6(IFLAG1,IFLAG2,IFLAG3) 14446 ENDIF 14447 IFLAG1=.FALSE. 14448 IF(IFIRST)IFLAG1=.TRUE. 14449 IFLAG2=.TRUE. 14450C 14451 CALL DPDTLA(IHEAD,NCHEAD,NCT,ISUBRO,IBUGA3,IERROR) 14452 NCHEAD=NCT 14453C 14454 IF(NCTIT9.LE.0)THEN 14455 ITEMPC=' ' 14456 NCHEA2=0 14457 CALL DPLAT1(IHEAD,NCHEAD,ITEMPC,NCHEA2,IFLAG1) 14458 ELSE 14459 CALL DPDTLA(ITITL9,NCTIT9,NCT,ISUBRO,IBUGA3,IERROR) 14460 NCTIT9=NCT 14461 CALL DPLAT1(ITITL9,NCTIT9,IHEAD,NCHEAD,IFLAG1) 14462 ENDIF 14463 ENDIF 14464 IFLAG1=.FALSE. 14465 IFLAG2=.FALSE. 14466 IFLAG3=.FALSE. 14467 IF(I.EQ.1)IFLAG1=.TRUE. 14468 IF(I.EQ.NUMLIN)IFLAG2=.TRUE. 14469 IF(I.EQ.1)IFLAG3=.TRUE. 14470C 14471 DO6110JJ=1,NUMCOL 14472 CALL DPDTLA(IVALUE(JJ),NCTEMP(JJ),NCT, 14473 1 ISUBRO,IBUGA3,IERROR) 14474 NCTEMP(JJ)=NCT 14475 6110 CONTINUE 14476C 14477 CALL DPLAT4(IVALUE,NCTEMP,NUMCOL,IFLAG1,IFLAG2,IFLAG3) 14478C 14479 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF ')THEN 14480C 14481 8091 FORMAT(A1,'f',I1) 14482 IF(I.EQ.1)THEN 14483 IF(IRTFFP.EQ.'Times New Roman')THEN 14484 ITEMP=0 14485 ELSEIF(IRTFFP.EQ.'Lucida Sans')THEN 14486 ITEMP=6 14487 ELSEIF(IRTFFP.EQ.'Arial')THEN 14488 ITEMP=2 14489 ELSEIF(IRTFFP.EQ.'Bookman')THEN 14490 ITEMP=3 14491 ELSEIF(IRTFFP.EQ.'Georgia')THEN 14492 ITEMP=4 14493 ELSEIF(IRTFFP.EQ.'Tahoma')THEN 14494 ITEMP=5 14495 ELSEIF(IRTFFP.EQ.'Verdana')THEN 14496 ITEMP=7 14497 ELSE 14498 ITEMP=0 14499 ENDIF 14500C 14501 IRTFMD='OFF' 14502C 14503 IF(NCTIT9.GE.1.AND.I.EQ.1)THEN 14504 IF(NCTIT9.LE.0)THEN 14505 ITEMPC=' ' 14506 NCHEA2=0 14507 ELSE 14508 NCHEA2=NCTIT9+3 14509 ITEMPC(4:NCHEA2)=ITITL9(1:NCTIT9) 14510 ITEMPC(1:3)=' b ' 14511 ITEMPC(1:1)=IBASLC 14512 ENDIF 14513 IF(NCHEAD.GE.1)THEN 14514 NCTEM2=NCHEAD+3 14515 IHEAD(4:NCTEM2)=IHEAD(1:NCHEAD) 14516 IHEAD(1:3)=' b ' 14517 IHEAD(1:1)=IBASLC 14518 ELSE 14519 NCTEM2=0 14520 ENDIF 14521 CALL DPRTF1(ITEMPC,NCHEA2,IHEAD,NCTEM2) 14522 ENDIF 14523 ENDIF 14524C 14525 DO130J=1,NUMCOL 14526 NCHAR=NCTEMP(J)+3 14527 IVALUE(J)(4:NCHAR)=IVALUE(J)(1:NCTEMP(J)) 14528 IVALUE(J)(1:3)=' b ' 14529 IVALUE(J)(1:1)=IBASLC 14530 NCTEMP(J)=NCHAR 14531 130 CONTINUE 14532 IFLAG1=.FALSE. 14533 IFLAG2=.FALSE. 14534 IF(I.EQ.1)IFLAG1=.TRUE. 14535 IF(I.EQ.NUMLIN)IFLAG2=.TRUE. 14536 CALL DPRTF4(IVALUE,NCTEMP,NUMCOL,IFLAG1,IFLAG2) 14537 ELSE 14538 IF(I.EQ.1)THEN 14539 IFLAG1=.TRUE. 14540 CALL DPTAB1(ITITL9,NCTIT9,IHEAD,NCHEAD,IFLAG1) 14541 ENDIF 14542 IFLAG1=.FALSE. 14543 IFLAG2=.FALSE. 14544 IF(I.EQ.1)IFLAG1=.TRUE. 14545 IF(I.EQ.NUMLIN)IFLAG2=.TRUE. 14546C 14547 DO 141 KK=1,NUMCOL 14548 IF(ALIGN(KK).EQ.'l' .AND. NCTEMP(KK).LT.NTOT(KK))THEN 14549 DO146JJ=NCTEMP(KK)+1,NTOT(KK) 14550 IVALUE(KK)(JJ:JJ)=' ' 14551 146 CONTINUE 14552 NCTEMP(KK)=NTOT(KK) 14553 ELSEIF(ALIGN(KK).EQ.'c'.AND.NCTEMP(KK).LT.NTOT(KK))THEN 14554 IVALUE(KK)(NCTEMP(KK):NTOT(KK))=' ' 14555 IDIFF=(NTOT(KK)-NCTEMP(KK))/2 14556 IF(IDIFF.GT.0)THEN 14557 DO147JJ=NTOT(KK),IDIFF+1,-1 14558 IVALUE(KK)(JJ:JJ)=IVALUE(KK)(JJ-IDIFF:JJ-IDIFF) 14559 147 CONTINUE 14560 IVALUE(KK)(1:IDIFF)=' ' 14561 ENDIF 14562 NCTEMP(KK)=NTOT(KK) 14563 ELSEIF(ALIGN(KK).EQ.'r'.AND.NCTEMP(KK).LT.NTOT(KK))THEN 14564C 14565 IF(ISUBRO.EQ.'DTA5' .OR. IBUGA3.EQ.'ON')THEN 14566 WRITE(ICOUT,157)KK,NCTEMP(KK),NTOT(KK) 14567 157 FORMAT('BEFORE 148: KK,NCTEMP(KK),NTOT(KK) =', 14568 1 3I8) 14569 CALL DPWRST('XXX','WRIT') 14570 WRITE(ICOUT,153)IVALUE(KK)(1:NCTEMP(KK)) 14571 CALL DPWRST('XXX','WRIT') 14572 ENDIF 14573C 14574 IDIFF=NTOT(KK)-NCTEMP(KK) 14575 DO148JJ=NTOT(KK),IDIFF+1,-1 14576 IVALUE(KK)(JJ:JJ)=IVALUE(KK)(JJ-IDIFF:JJ-IDIFF) 14577 148 CONTINUE 14578 IVALUE(KK)(1:IDIFF)=' ' 14579 NCTEMP(KK)=NTOT(KK) 14580 ENDIF 14581C 14582 IF(ISUBRO.EQ.'DTA5' .OR. IBUGA3.EQ.'ON')THEN 14583 WRITE(ICOUT,151)KK,IDIFF,NCTEMP(KK),NUMCOL,NMAX 14584 151 FORMAT('BEFORE CALL DPTAB4: KK,IDIFF,NCTEMP(KK),', 14585 1 'NUMCOL,NMAX=',5I8) 14586 CALL DPWRST('XXX','WRIT') 14587 WRITE(ICOUT,153)IVALUE(KK)(1:NCTEMP(KK)) 14588 153 FORMAT('IVALUE(KK) = ',A80) 14589 CALL DPWRST('XXX','WRIT') 14590 ENDIF 14591C 14592 141 CONTINUE 14593C 14594 CALL DPTAB4(IVALUE,NCTEMP,NUMCOL,IFLAG1,IFLAG2,NMAX) 14595C 14596 ENDIF 14597 110 CONTINUE 14598 ENDIF 14599C 14600 199 CONTINUE 14601C 14602C ****************************************** 14603C ** STEP 2-- ** 14604C ** WRITE OUT THE TABLE ROWS ** 14605C ****************************************** 14606C 14607 IFLAGA=.FALSE. 14608 IFLAGB=.FALSE. 14609 MAXLTA=35 14610 ILINE=0 14611 IF(NUMROW.GE.1)THEN 14612 DO200I=1,NUMROW 14613C 14614 IFLAG1=.FALSE. 14615 IF(I.EQ.NUMROW)IFLAG1=.TRUE. 14616 DO210J=1,NUMCOL 14617 AVALUE(J)=AVAL(I,J) 14618 IF(AVALUE(J).EQ.CPUMIN)THEN 14619 NUMDIG(J)=-99 14620 ELSE 14621 NUMDIG(J)=IDIGIT(J) 14622 ENDIF 14623 IVALUE(J)=' ' 14624 NTEMP=NCTEXT(I,J) 14625 NCTEMP(J)=NTEMP 14626 IF(NTEMP.GT.0 .AND. ITYPCO(J).EQ.'ALPH')THEN 14627 IVALUE(J)(1:NTEMP)=ITEXT(I,J)(1:NTEMP) 14628C 14629 IF(ICAPTY.EQ.'LATE')THEN 14630 CALL DPDTLA(IVALUE(J),NTEMP,NCT,ISUBRO,IBUGA3,IERROR) 14631 NTEMP=NCT 14632 NCTEMP(J)=NTEMP 14633 ENDIF 14634C 14635 ENDIF 14636C 14637 IF(ISUBRO.EQ.'DTA5' .OR. IBUGA3.EQ.'ON')THEN 14638 WRITE(ICOUT,211)I,J,ITYPCO(J),AVALUE(J),IVALUE(J) 14639 211 FORMAT('I,J,ITYPCO(J),AVALUE(J),IVALUE(J) = ', 14640 1 2I8,2X,A4,2X,G15.7,2X,A60) 14641 CALL DPWRST('XXX','WRIT') 14642 ENDIF 14643C 14644 210 CONTINUE 14645C 14646 IF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'HTML')THEN 14647 CALL DPHTMY(IVALUE,NCTEMP,AVALUE,NUMCOL,ITYPCO, 14648 1 IFLAGA,IFLAGB) 14649C 14650C FOR LATEX, WE CANNOT EXTEND TABLES BEYOND A SINGLE 14651C PAGE, SO PUT A CHECK IN. 14652C 14653 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'LATE')THEN 14654 CALL DPLATW(IVALUE,NCTEMP,AVALUE,NUMCOL,ITYPCO, 14655 1 IFLAGA,IFLAGB) 14656 ILINE=ILINE+1 14657 IF(ILINE.EQ.MAXLTA .AND. I.NE.NUMROW)THEN 14658 ILINE=0 14659 IFLAG1=.TRUE. 14660 IFLAG2=.FALSE. 14661 IFLAG3=.TRUE. 14662 CALL DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD) 14663 IFLAG1=.FALSE. 14664 IFLAG2=.FALSE. 14665 IFLAG3=.TRUE. 14666 CALL DPLATY(NHEAD) 14667 ENDIF 14668 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'RTF')THEN 14669 CALL DPRTFY(IVALUE,NCTEMP,AVALUE,NUMCOL,ITYPCO, 14670 1 IFLAGA,IFLAGB) 14671 ELSE 14672C 14673 IF(ISUBRO.EQ.'DTA5' .OR. IBUGA3.EQ.'ON')THEN 14674 WRITE(ICOUT,251)I,NUMCOL,NMAX 14675 251 FORMAT('BEFORE CALL DPTABY: I,NUMCOL,NMAX = ', 14676 1 3I5) 14677 CALL DPWRST('XXX','WRIT') 14678 ENDIF 14679C 14680 ICSVWZ='OFF' 14681 IVALT=-99 14682 CALL DPTABY(IVALUE,NCTEMP,AVALUE,NUMCOL,ITYPCO, 14683 1 IFLAGA,IFLAGB,NMAX,NTOT,ICSVWZ,IVALT, 14684 1 IBUGA3,ISUBRO) 14685 ENDIF 14686 200 CONTINUE 14687 ENDIF 14688C 14689C ******************************************* 14690C ** STEP 3-- ** 14691C ** TERMINATE THE TABLE ** 14692C ******************************************* 14693C 14694 ISTEPN='2' 14695 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DTA5') 14696 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14697C 14698 IF(.NOT.IFLAGE)GOTO399 14699C 14700 IF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'HTML')THEN 14701 IFLAG1=.TRUE. 14702 IFLAG2=.FALSE. 14703 IF(ILAST)IFLAG2=.TRUE. 14704 CALL DPHTM2(IFLAG1,IFLAG2,NHEAD) 14705 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'LATE')THEN 14706 IFLAG1=.TRUE. 14707 IFLAG2=.FALSE. 14708 IFLAG3=.FALSE. 14709 IF(ILAST)THEN 14710 IFLAG2=.TRUE. 14711 IFLAG3=.TRUE. 14712 ENDIF 14713 CALL DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD) 14714 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'RTF')THEN 14715 IF(IRTFFF.EQ.'Courier New')THEN 14716 ITEMP=1 14717 ELSEIF(IRTFFF.EQ.'Lucida Console')THEN 14718 ITEMP=8 14719 ENDIF 14720 WRITE(ICOUT,8091)IBASLC,ITEMP 14721 CALL DPWRST(ICOUT,'WRIT') 14722 CALL DPRTF6(NHEAD) 14723 CALL DPRTF6(NHEAD) 14724 IF(ILAST)THEN 14725 IRTFMD='VERB' 14726 ENDIF 14727 ELSE 14728 IF(ILAST)THEN 14729 WRITE(ICOUT,999) 14730 CALL DPWRST('XXX','WRIT') 14731 ENDIF 14732 ENDIF 14733C 14734 399 CONTINUE 14735C 14736 ENDIF 14737C 14738 RETURN 14739 END 14740 SUBROUTINE DPDT5B(ITITL9,NCTIT9, 14741 1 IHEAD,NCHEAD,ITITLE,NCTITL, 14742 1 MAXLIN,NUMLIN,MAXCOL,NUMCOL, 14743 1 ITEXT,NCTEXT,AVAL,ITYPCO,MAXROW,NUMROW, 14744 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGZ,ALIGNZ,NMAX, 14745 1 ICOLSP,ROWSEP, 14746 1 ICAPSW,ICAPTY,IFIRST,ILAST, 14747 1 IFLAGS,IFLAGE, 14748 1 ISUBRO,IBUGA3,IERROR) 14749C 14750C PURPOSE--THIS ROUTINE PRINTS A MULTI-COLUMN TABLE CONSISTING OF: 14751C 14752C 1) AN OPTIONAL OVERALL TITLE 14753C 2) HEADERS FOR EACH OF THE COLUMNS (THESE HEADERS MAY 14754C CONTAIN MULTIPLE LINES). 14755C 3) A TABLE OF NUMERIC/CHARACTER VALUES. THIS IS A 14756C VARIANT OF TABLE 2 (WHICH ONLY ALLOWS TEXT FIELDS 14757C FOR THE FIRST COLUMN). 14758C 14759C ITITL9 => THE OVERALL TITLE 14760C IHEAD => TABLE CAPTION 14761C ITITLE => LINES FOR THE COLUMN HEADERS 14762C AVAL => MATRIX OF NUMERIC VALUES FOR THE TABLE 14763C ITEXT => MATRIX OF CHARACTER VALUES FOR THE TABLE 14764C ICOLSP => MATRIX OF COLUMN SPANS FOR THE HEADER 14765C LINES OF THE TABLE. 14766C 14767C IN SOME CASES, THE NUMBER OF ROWS IN THE 14768C TABLE MAY NOT BE FIXED (AND IN FACT MAY BE RATHER 14769C LARGE). DPDT5B ALLOWS THE ROWS OF THE TABLE TO BE 14770C SENT IN INCREMENTS. THE IFLAGS AND IFLAGE SPECIFY 14771C WHETHER THE TABLE HEADERS OR TRAILERS ARE TO BE 14772C PRINTED, RESPECTIVELY. 14773C 14774C THIS IS A VARIATION OF DPDTA5 THAT ALLOWS THE FOLLOWING: 14775C 14776C 1) HEADER TEXT TO SPAN MULTIPLE COLUMNS (COLSPN ARRAY 14777C SPECIFIES NUMBER OF COLUMNS THAT A SPECIFIC COLUMN 14778C COVERS). NOTE THAT MULTIPLE COLUMN HEADERS WILL 14779C AUTOMATICALLY BE CENTER JUSTIFIED. 14780C 14781C 2) ALLOWS FOR EMPTY CELLS. TO ACCOMODATE THIS, THE 14782C IDIGIT FIELD IS A MATRIX INSTEAD OF AN ARRAY (I.E., 14783C NEED TO SET INDIVIDUALLY). 14784C 14785C 3) ALLOW A SEPARATOR LINE TO BE DRAWN AFTER SELECT 14786C ROWS. FOR EXAMPLE, WE MAY WANT A BORDER FOR A 14787C "ROW TOTALS" ROW. THE ROWSEP VARIABLE WILL BE 14788C USED TO INDICATE THIS (A VALUE OF 1 SPECIFIES 14789C THAT THE ROW SEPARATOR WILL BE GENERATED). 14790C 14791C WRITTEN BY--ALAN HECKERT 14792C STATISTICAL ENGINEERING DIVISION 14793C INFORMATION TECHNOLOGY LABORATORY 14794C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 14795C GAITHERSBURG, MD 20899-8980 14796C PHONE--301-975-2899 14797C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 14798C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 14799C LANGUAGE--ANSI FORTRAN (1977) 14800C VERSION NUMBER--2011/1 14801C ORIGINAL VERSION--JANUARY 2011. 14802C UPDATED --JANUARY 2011. USE DPDTLA, DPDTRT TO CHECK FOR 14803C CERTAIN CHARACTERS THAT NEED 14804C TO BE ESCAPED FOR LATEX, RTF 14805C UPDATED --FEBRUARY 2020. CALL LIST TO DPTABY 14806C 14807C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 14808C 14809 CHARACTER*(*) IHEAD 14810 CHARACTER*(*) ITITL9 14811 CHARACTER*(*) ITITLE(MAXLIN,MAXCOL) 14812 CHARACTER*4 VALIGZ(*) 14813 CHARACTER*4 ALIGNZ(*) 14814 INTEGER NCTITL(MAXLIN,MAXCOL) 14815 INTEGER NCTEXT(MAXROW,MAXCOL) 14816 INTEGER ICOLSP(MAXLIN,MAXCOL) 14817 INTEGER IDIGIT(MAXROW,MAXCOL) 14818 INTEGER NTOT(*) 14819 INTEGER ROWSEP(*) 14820 INTEGER IWHTML(*) 14821 INTEGER IWRTF(*) 14822 REAL AVAL(MAXROW,MAXCOL) 14823 CHARACTER*(*) ITEXT(MAXROW,MAXCOL) 14824 CHARACTER*4 ITYPCO(MAXCOL) 14825C 14826 CHARACTER*4 ICAPSW 14827 CHARACTER*4 ICAPTY 14828 CHARACTER*4 ISUBRO 14829 CHARACTER*4 IBUGA3 14830 CHARACTER*4 IERROR 14831C 14832 CHARACTER*4 ISUBN1 14833 CHARACTER*4 ISUBN2 14834 CHARACTER*4 ISTEPN 14835 CHARACTER*4 ICSVWZ 14836 CHARACTER*1 IBASLC 14837C 14838 LOGICAL IFLAG1 14839 LOGICAL IFLAG2 14840 LOGICAL IFLAG3 14841 LOGICAL IFLAGA 14842 LOGICAL IFLAGB 14843 LOGICAL IFLAGS 14844 LOGICAL IFLAGE 14845 LOGICAL IFIRST 14846 LOGICAL ILAST 14847C 14848C--------------------------------------------------------------------- 14849C 14850 INCLUDE 'DPCOST.INC' 14851C 14852 PARAMETER (MAXHED=1024) 14853 INTEGER IWIDTH(MAXHED) 14854 INTEGER NUMDIG(MAXHED) 14855 CHARACTER*8 ALIGN(MAXHED) 14856 CHARACTER*8 VALIGN(MAXHED) 14857 COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN 14858 CHARACTER*60 IVALUE(MAXHED) 14859 INTEGER NCTEMP(MAXHED) 14860 INTEGER NCOLSP(MAXHED) 14861 REAL AVALUE(MAXHED) 14862C 14863 CHARACTER*8 ALIGNT 14864 CHARACTER*132 ITEMPC 14865C 14866 CHARACTER*4 IRTFMD 14867 COMMON/COMRTF/IRTFMD 14868C 14869C--------------------------------------------------------------------- 14870C 14871 INCLUDE 'DPCOP2.INC' 14872C 14873C-----START POINT----------------------------------------------------- 14874C 14875 ISUBN1='DPDT' 14876 ISUBN2='5B ' 14877C 14878 IERROR='NO' 14879C 14880 DO40I=1,MAXHED 14881 IVALUE(I)=' ' 14882 AVALUE(I)=0.0 14883 NCTEMP(I)=0 14884 NCOLSP(I)=0 14885 40 CONTINUE 14886C 14887 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DT5B')THEN 14888 WRITE(ICOUT,999) 14889 999 FORMAT(1X) 14890 CALL DPWRST('XXX','WRIT') 14891 WRITE(ICOUT,51) 14892 51 FORMAT('**** AT THE BEGINNING OF DPDT5B--') 14893 CALL DPWRST('XXX','WRIT') 14894 WRITE(ICOUT,52)IBUGA3,ISUBRO,IFLAGS,IFLAGE,IFIRST,ILAST 14895 52 FORMAT('IBUGA3,ISUBRO,IFLAGS,IFLAGE,IFIRST,ILAST = ', 14896 1 2(A4,2X),4L4) 14897 CALL DPWRST('XXX','WRIT') 14898 WRITE(ICOUT,53)MAXLIN,MAXROW,NUMROW,NUMCOL,NUMLIN 14899 53 FORMAT('MAXLIN,MAXROW,NUMROW,NUMCOL,NUMLIN = ',5I8) 14900 CALL DPWRST('XXX','WRIT') 14901 IF(NUMLIN.GT.0)THEN 14902 DO54I=1,NUMLIN 14903 DO55J=1,NUMCOL 14904 NTEMP=MIN(80,NCTITL(I,J)) 14905 IF(NTEMP.GT.0)THEN 14906 WRITE(ICOUT,56)I,J,NCTITL(I,J),ITITLE(I,J)(1:NTEMP) 14907 56 FORMAT('I,J,NCTITL(I,J),ITITL(I,J)(1:NCTITL) = ', 14908 1 3I5,2X,A80) 14909 CALL DPWRST('XXX','WRIT') 14910 ELSE 14911 WRITE(ICOUT,56)I,J,NCTITL(I,J) 14912 CALL DPWRST('XXX','WRIT') 14913 ENDIF 14914 55 CONTINUE 14915 54 CONTINUE 14916 ENDIF 14917 IF(NUMROW.GT.0)THEN 14918 DO57I=1,NUMROW 14919 WRITE(ICOUT,60)I,(AVAL(I,J),J=1,MIN(5,NUMCOL)) 14920 60 FORMAT('I,(AVAL(I,J),J=1,NUMCOL) = ',I8,5G15.7) 14921 CALL DPWRST('XXX','WRIT') 14922 57 CONTINUE 14923 DO77I=1,NUMROW 14924 DO79J=1,NUMCOL 14925 WRITE(ICOUT,80)I,J,ITEXT(I,J) 14926 80 FORMAT('I,J,ITEXT(I,J) = ',2I5,2X,A60) 14927 CALL DPWRST('XXX','WRIT') 14928 79 CONTINUE 14929 77 CONTINUE 14930 ENDIF 14931 WRITE(ICOUT,62)NCHEAD 14932 62 FORMAT('NCHEAD = ',I5) 14933 CALL DPWRST('XXX','WRIT') 14934 IF(NCHEAD.GT.0)THEN 14935 WRITE(ICOUT,63)IHEAD(1:NCHEAD) 14936 63 FORMAT('NCHEAD,IHEAD = ',A80) 14937 CALL DPWRST('XXX','WRIT') 14938 ENDIF 14939 DO91J=1,NUMCOL 14940 WRITE(ICOUT,93)J,ALIGNZ(J),VALIGZ(J),NTOT(J) 14941 93 FORMAT('J,ALIGNZ(J),VALIGZ(J),NTOT(J) = ',I5,2(2X,A4),2X,I5) 14942 CALL DPWRST('XXX','WRIT') 14943 91 CONTINUE 14944 ENDIF 14945C 14946C ****************************************** 14947C ** STEP 1-- ** 14948C ** WRITE OUT THE TABLE HEADER. ** 14949C ** NOTE THAT THIS MAY CONSIST OF ** 14950C ** MULTIPLE LINES. ** 14951C ****************************************** 14952C 14953 ISTEPN='1' 14954 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DT5B') 14955 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14956C 14957 IF(IPRINT.EQ.'ON')THEN 14958C 14959 CALL DPCONA(92,IBASLC) 14960C 14961C SKIP HEADER IF REQUESTED 14962C 14963 IF(.NOT.IFLAGS)GOTO199 14964C 14965 NHEAD=NUMCOL 14966C 14967 DO100I=1,NUMCOL 14968 IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN 14969 IWIDTH(I)=IWHTML(I) 14970 IF(VALIGZ(I).EQ.'b')THEN 14971 VALIGN(I)='BOTTOM' 14972 ELSEIF(VALIGZ(I).EQ.'c')THEN 14973 VALIGN(I)='CENTER' 14974 ELSEIF(VALIGZ(I).EQ.'t')THEN 14975 VALIGN(I)='TOP' 14976 ENDIF 14977 IF(ALIGNZ(I).EQ.'l')THEN 14978 ALIGN(I) ='LEFT' 14979 ELSEIF(ALIGNZ(I).EQ.'c')THEN 14980 ALIGN(I) ='CENTER' 14981 ELSEIF(ALIGNZ(I).EQ.'r')THEN 14982 ALIGN(I) ='RIGHT' 14983 ENDIF 14984C 14985 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN 14986 IF(VALIGZ(I).EQ.'b')THEN 14987 VALIGN(I)='b' 14988 ELSEIF(VALIGZ(I).EQ.'c')THEN 14989 VALIGN(I)='c' 14990 ELSEIF(VALIGZ(I).EQ.'t')THEN 14991 VALIGN(I)='t' 14992 ENDIF 14993 IF(ALIGNZ(I).EQ.'l')THEN 14994 ALIGN(I) ='l' 14995 ELSEIF(ALIGNZ(I).EQ.'c')THEN 14996 ALIGN(I) ='c' 14997 ELSEIF(ALIGNZ(I).EQ.'r')THEN 14998 ALIGN(I) ='r' 14999 ENDIF 15000 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN 15001 IWIDTH(I)=IWRTF(I) 15002 IF(VALIGZ(I).EQ.'b')THEN 15003 VALIGN(I)='b' 15004 ELSEIF(VALIGZ(I).EQ.'c')THEN 15005 VALIGN(I)='c' 15006 ELSEIF(VALIGZ(I).EQ.'t')THEN 15007 VALIGN(I)='t' 15008 ENDIF 15009 IF(ALIGNZ(I).EQ.'l')THEN 15010 ALIGN(I) ='l' 15011 ELSEIF(ALIGNZ(I).EQ.'c')THEN 15012 ALIGN(I) ='c' 15013 ELSEIF(ALIGNZ(I).EQ.'r')THEN 15014 ALIGN(I) ='r' 15015 ENDIF 15016 ELSE 15017 IF(VALIGZ(I).EQ.'b')THEN 15018 VALIGN(I)='b' 15019 ELSEIF(VALIGZ(I).EQ.'c')THEN 15020 VALIGN(I)='c' 15021 ELSEIF(VALIGZ(I).EQ.'t')THEN 15022 VALIGN(I)='t' 15023 ENDIF 15024 IF(ALIGNZ(I).EQ.'l')THEN 15025 ALIGN(I) ='l' 15026 ELSEIF(ALIGNZ(I).EQ.'c')THEN 15027 ALIGN(I) ='c' 15028 ELSEIF(ALIGNZ(I).EQ.'r')THEN 15029 ALIGN(I) ='r' 15030 ENDIF 15031 ENDIF 15032 100 CONTINUE 15033C 15034C LOOP THROUGH THE LINES OF THE HEADER 15035C 15036 IF(NUMLIN.GE.1)THEN 15037 DO110I=1,NUMLIN 15038C 15039 DO120J=1,NUMCOL 15040 IVALUE(J)=' ' 15041 NCTEMP(J)=0 15042 NCOLSP(J)=ICOLSP(I,J) 15043 IF(NCTITL(I,J).GT.0)THEN 15044 NCTEMP(J)=NCTITL(I,J) 15045 IVALUE(J)(1:NCTEMP(J))=ITITLE(I,J)(1:NCTEMP(J)) 15046 ENDIF 15047C 15048 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DT5B')THEN 15049 WRITE(ICOUT,106)I,J,NCTEMP(J),IVALUE(J) 15050 106 FORMAT('I,J,NCTEMP(J),IVALUE(J) = ',3I8,A80) 15051 CALL DPWRST('XXX','WRIT') 15052 ENDIF 15053C 15054 120 CONTINUE 15055C 15056 IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN 15057 IF(NCTIT9.LT.0)NCTIT9=0 15058 IF(I.EQ.1)THEN 15059 IFLAG1=.FALSE. 15060 IF(IFIRST)IFLAG1=.TRUE. 15061 IFLAG2=.TRUE. 15062 IF(NCTIT9.LE.0)THEN 15063 IF(IFIRST)THEN 15064 CALL DPHTM1(IHEAD,NCHEAD,IFLAG1,IFLAG2) 15065 ELSE 15066 CALL DPHTMA(ITITL9,NCTIT9,IHEAD,NCHEAD, 15067 1 IFLAG1,IFLAG2) 15068 ENDIF 15069 ELSE 15070 CALL DPHTMA(ITITL9,NCTIT9,IHEAD,NCHEAD,IFLAG1,IFLAG2) 15071 ENDIF 15072 ENDIF 15073 IFLAG1=.FALSE. 15074 IFLAG2=.FALSE. 15075 IF(I.EQ.1)IFLAG1=.TRUE. 15076 IF(I.EQ.NUMLIN)IFLAG2=.TRUE. 15077 CALL DPHT4B(IVALUE,NCTEMP,NUMCOL,NCOLSP,IFLAG1,IFLAG2) 15078C 15079 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN 15080C 15081 IF(I.EQ.1)THEN 15082 IF(IFIRST)THEN 15083 IFLAG1=.FALSE. 15084 IFLAG2=.FALSE. 15085 IFLAG3=.TRUE. 15086 CALL DPLAT6(IFLAG1,IFLAG2,IFLAG3) 15087 ENDIF 15088 IFLAG1=.FALSE. 15089 IF(IFIRST)IFLAG1=.TRUE. 15090 IFLAG2=.TRUE. 15091C 15092 IF(NCTIT9.LT.0)NCTIT9=0 15093 CALL DPDTLA(IHEAD,NCHEAD,NCT,ISUBRO,IBUGA3,IERROR) 15094 NCHEAD=NCT 15095C 15096 IF(NCTIT9.LE.0)THEN 15097 ITEMPC=' ' 15098 NCHEA2=0 15099 CALL DPLAT1(IHEAD,NCHEAD,ITEMPC,NCHEA2,IFLAG1) 15100 ELSE 15101 CALL DPDTLA(ITITL9,NCTIT9,NCT,ISUBRO,IBUGA3,IERROR) 15102 NCTIT9=NCT 15103 CALL DPLAT1(ITITL9,NCTIT9,IHEAD,NCHEAD,IFLAG1) 15104 ENDIF 15105 ENDIF 15106C 15107 IFLAG1=.FALSE. 15108 IFLAG2=.FALSE. 15109 IFLAG3=.FALSE. 15110 IF(I.EQ.1)IFLAG1=.TRUE. 15111 IF(I.EQ.NUMLIN)IFLAG2=.TRUE. 15112 IF(I.EQ.1)IFLAG3=.TRUE. 15113C 15114 DO6110JJ=1,NUMCOL 15115 CALL DPDTLA(IVALUE(JJ),NCTEMP(JJ),NCT, 15116 1 ISUBRO,IBUGA3,IERROR) 15117 NCTEMP(JJ)=NCT 15118 6110 CONTINUE 15119C 15120 CALL DPLA4B(IVALUE,NCTEMP,NUMCOL,NCOLSP, 15121 1 IFLAG1,IFLAG2,IFLAG3) 15122C 15123 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF ')THEN 15124C 15125 8091 FORMAT(A1,'f',I1) 15126 IF(I.EQ.1)THEN 15127 IF(IRTFFP.EQ.'Times New Roman')THEN 15128 ITEMP=0 15129 ELSEIF(IRTFFP.EQ.'Lucida Sans')THEN 15130 ITEMP=6 15131 ELSEIF(IRTFFP.EQ.'Arial')THEN 15132 ITEMP=2 15133 ELSEIF(IRTFFP.EQ.'Bookman')THEN 15134 ITEMP=3 15135 ELSEIF(IRTFFP.EQ.'Georgia')THEN 15136 ITEMP=4 15137 ELSEIF(IRTFFP.EQ.'Tahoma')THEN 15138 ITEMP=5 15139 ELSEIF(IRTFFP.EQ.'Verdana')THEN 15140 ITEMP=7 15141 ELSE 15142 ITEMP=0 15143 ENDIF 15144C 15145 IRTFMD='OFF' 15146C 15147 IF(NCTIT9.LT.0)NCTIT9=0 15148 IF(NCTIT9.GE.1.AND.I.EQ.1)THEN 15149 CALL DPDTRT(ITITL9,NCTIT9,NCT,ISUBRO,IBUGA3,IERROR) 15150 NCTIT9=NCT 15151 IF(NCTIT9.LE.0)THEN 15152 ITEMPC=' ' 15153 NCHEA2=0 15154 ELSE 15155 NCHEA2=NCTIT9+3 15156 ITEMPC(4:NCHEA2)=ITITL9(1:NCTIT9) 15157 ITEMPC(1:3)=' b ' 15158 ITEMPC(1:1)=IBASLC 15159 ENDIF 15160 IF(NCHEAD.GE.1)THEN 15161 CALL DPDTRT(IHEAD,NCHEAD,NCT,ISUBRO,IBUGA3,IERROR) 15162 NCHEAD=NCT 15163 NCTEM2=NCHEAD+3 15164 IHEAD(4:NCTEM2)=IHEAD(1:NCHEAD) 15165 IHEAD(1:3)=' b ' 15166 IHEAD(1:1)=IBASLC 15167 ELSE 15168 NCTEM2=0 15169 ENDIF 15170 CALL DPRTF1(ITEMPC,NCHEA2,IHEAD,NCTEM2) 15171 ENDIF 15172 ENDIF 15173C 15174 DO130J=1,NUMCOL 15175 CALL DPDTRT(IVALUE(J),NCTEMP(J),NCT, 15176 1 ISUBRO,IBUGA3,IERROR) 15177 NCTEMP(J)=NCT 15178 NCHAR=NCTEMP(J)+3 15179 IVALUE(J)(4:NCHAR)=IVALUE(J)(1:NCTEMP(J)) 15180 IVALUE(J)(1:3)=' b ' 15181 IVALUE(J)(1:1)=IBASLC 15182 NCTEMP(J)=NCHAR 15183 130 CONTINUE 15184 IFLAG1=.FALSE. 15185 IFLAG2=.FALSE. 15186 IF(I.EQ.1)IFLAG1=.TRUE. 15187 IF(I.EQ.NUMLIN)IFLAG2=.TRUE. 15188 CALL DPRT4B(IVALUE,NCTEMP,NUMCOL,NCOLSP,IFLAG1,IFLAG2) 15189 ELSE 15190 IF(I.EQ.1 .AND. NCTIT9.GE.0)THEN 15191 IFLAG1=.TRUE. 15192 CALL DPTAB1(ITITL9,NCTIT9,IHEAD,NCHEAD,IFLAG1) 15193 ENDIF 15194 IFLAG1=.FALSE. 15195 IFLAG2=.FALSE. 15196 IF(I.EQ.1)IFLAG1=.TRUE. 15197 IF(I.EQ.NUMLIN)IFLAG2=.TRUE. 15198C 15199 DO 141 KK=1,NUMCOL 15200C 15201 IF(ISUBRO.EQ.'DT5B' .OR. IBUGA3.EQ.'ON')THEN 15202 WRITE(ICOUT,142)KK,NCOLSP(KK) 15203 142 FORMAT('KK,NCOLSP(KK) = ',2I8) 15204 CALL DPWRST('XXX','WRIT') 15205 ENDIF 15206C 15207 IF(NCOLSP(KK).LE.0)GOTO141 15208 NTOTZZ=NTOT(KK) 15209 ALIGNT=ALIGN(KK) 15210 IF(NCOLSP(KK).GT.1)THEN 15211 DO1141IICOL=KK+1,KK+NCOLSP(KK)-1 15212 NTOTZZ=NTOTZZ + NTOT(IICOL) 15213 1141 CONTINUE 15214 ALIGNT='c' 15215 ENDIF 15216C 15217 IF(ISUBRO.EQ.'DT5B' .OR. IBUGA3.EQ.'ON')THEN 15218 WRITE(ICOUT,157)KK,NCTEMP(KK),NTOTZZ,ALIGNT 15219 157 FORMAT('BEFORE 148: KK,NCTEMP(KK),NTOTZZ,ALIGNT =', 15220 1 3I8,2X,A4) 15221 CALL DPWRST('XXX','WRIT') 15222 ENDIF 15223C 15224 IF(ALIGNT.EQ.'l' .AND. NCTEMP(KK).LT.NTOTZZ)THEN 15225 IF(NCTEMP(KK).GT.0)THEN 15226 DO146JJ=NCTEMP(KK)+1,NTOTZZ 15227 IVALUE(KK)(JJ:JJ)=' ' 15228 146 CONTINUE 15229 NCTEMP(KK)=NTOTZZ 15230 ELSE 15231 IVALUE(KK)(1:NTOTZZ)=' ' 15232 NCTEMP(KK)=NTOTZZ 15233 ENDIF 15234 ELSEIF(ALIGNT.EQ.'c'.AND.NCTEMP(KK).LT.NTOTZZ)THEN 15235 IF(NCTEMP(KK).GT.0)THEN 15236 IVALUE(KK)(NCTEMP(KK)+1:NTOTZZ)=' ' 15237 IDIFF=(NTOTZZ-NCTEMP(KK))/2 15238 IF(IDIFF.GT.0)THEN 15239 DO147JJ=NTOTZZ,IDIFF+1,-1 15240 IVALUE(KK)(JJ:JJ)=IVALUE(KK)(JJ-IDIFF:JJ-IDIFF) 15241 147 CONTINUE 15242 IVALUE(KK)(1:IDIFF)=' ' 15243 ENDIF 15244 NCTEMP(KK)=NTOTZZ 15245 ELSE 15246 IVALUE(KK)(1:NTOTZZ)=' ' 15247 NCTEMP(KK)=NTOTZZ 15248 ENDIF 15249 ELSEIF(ALIGNT.EQ.'r'.AND.NCTEMP(KK).LT.NTOTZZ)THEN 15250 IF(NCTEMP(KK).GT.0)THEN 15251 IDIFF=NTOTZZ-NCTEMP(KK) 15252 DO148JJ=NTOTZZ,IDIFF+1,-1 15253 IVALUE(KK)(JJ:JJ)=IVALUE(KK)(JJ-IDIFF:JJ-IDIFF) 15254 148 CONTINUE 15255 IVALUE(KK)(1:IDIFF)=' ' 15256 NCTEMP(KK)=NTOTZZ 15257 ELSE 15258 IVALUE(KK)(1:NTOTZZ)=' ' 15259 NCTEMP(KK)=NTOTZZ 15260 ENDIF 15261 ENDIF 15262C 15263 IF(ISUBRO.EQ.'DT5B' .OR. IBUGA3.EQ.'ON')THEN 15264 WRITE(ICOUT,1151)NTOTZZ,NCTEMP(KK),IDIFF 15265 1151 FORMAT('BEFORE CALL DPTA44: NTOTZZ,NCTEMP(KK),', 15266 1 'IDIFF = ',3I8) 15267 CALL DPWRST('XXX','WRIT') 15268 WRITE(ICOUT,151)KK,IDIFF,NCTEMP(KK),NUMCOL,NMAX 15269 151 FORMAT('KK,IDIFF,NCTEMP(KK),NUMCOL,NMAX=',5I8) 15270 CALL DPWRST('XXX','WRIT') 15271 WRITE(ICOUT,153)IVALUE(KK)(1:NCTEMP(KK)) 15272 153 FORMAT('IVALUE(KK) = ',A80) 15273 CALL DPWRST('XXX','WRIT') 15274 ENDIF 15275C 15276 141 CONTINUE 15277C 15278 CALL DPTA44(IVALUE,NCTEMP,NUMCOL,NCOLSP, 15279 1 IFLAG1,IFLAG2,NMAX) 15280C 15281 ENDIF 15282 110 CONTINUE 15283 ENDIF 15284C 15285 199 CONTINUE 15286C 15287C ****************************************** 15288C ** STEP 2-- ** 15289C ** WRITE OUT THE TABLE ROWS ** 15290C ****************************************** 15291C 15292 IFLAGA=.FALSE. 15293 IFLAGB=.FALSE. 15294 MAXLTA=35 15295 ILINE=0 15296 IF(NUMROW.GE.1)THEN 15297 DO200I=1,NUMROW 15298C 15299 IFLAG1=.FALSE. 15300 IF(I.EQ.NUMROW)IFLAG1=.TRUE. 15301 IFLAGA=.FALSE. 15302 IFLAGB=.FALSE. 15303 IF(ROWSEP(I).EQ.1)THEN 15304 IFLAGA=.TRUE. 15305 ELSEIF(ROWSEP(I).EQ.2)THEN 15306 IFLAGB=.TRUE. 15307 ELSEIF(ROWSEP(I).EQ.3)THEN 15308 IFLAGB=.TRUE. 15309 IFLAGA=.TRUE. 15310 ENDIF 15311 DO210J=1,NUMCOL 15312 AVALUE(J)=AVAL(I,J) 15313 IF(AVALUE(J).EQ.CPUMIN)THEN 15314 IF(IDIGIT(I,J).EQ.-1)THEN 15315 NUMDIG(J)=-1 15316 ELSE 15317 NUMDIG(J)=-99 15318 ENDIF 15319 ELSE 15320 NUMDIG(J)=IDIGIT(I,J) 15321 ENDIF 15322 IVALUE(J)=' ' 15323 NTEMP=NCTEXT(I,J) 15324 NCTEMP(J)=NTEMP 15325 IF(NTEMP.GT.0)THEN 15326 IVALUE(J)(1:NTEMP)=ITEXT(I,J)(1:NTEMP) 15327C 15328 IF(ICAPTY.EQ.'LATE')THEN 15329 CALL DPDTLA(IVALUE(J),NTEMP,NCT,ISUBRO,IBUGA3,IERROR) 15330 NTEMP=NCT 15331 NCTEMP(J)=NTEMP 15332 ELSEIF(ICAPTY.EQ.'RTF')THEN 15333 CALL DPDTRT(IVALUE(J),NTEMP,NCT,ISUBRO,IBUGA3,IERROR) 15334 NTEMP=NCT 15335 NCTEMP(J)=NTEMP 15336 ENDIF 15337C 15338 ENDIF 15339C 15340 IF(ISUBRO.EQ.'DT5B' .OR. IBUGA3.EQ.'ON')THEN 15341 WRITE(ICOUT,211)I,J,ITYPCO(J),AVALUE(J), 15342 1 NCTEMP(J),IVALUE(J) 15343 211 FORMAT('I,J,ITYPCO(J),AVALUE(J),NCTEMP(J),IVALUE(J) = ', 15344 1 2I8,2X,A4,2X,G15.7,2X,I5,2X,A60) 15345 CALL DPWRST('XXX','WRIT') 15346 ENDIF 15347C 15348 210 CONTINUE 15349C 15350 IF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'HTML')THEN 15351 CALL DPHTMY(IVALUE,NCTEMP,AVALUE,NUMCOL,ITYPCO, 15352 1 IFLAGA,IFLAGB) 15353C 15354C FOR LATEX, WE CANNOT EXTEND TABLES BEYOND A SINGLE 15355C PAGE, SO PUT A CHECK IN. 15356C 15357 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'LATE')THEN 15358 CALL DPLATW(IVALUE,NCTEMP,AVALUE,NUMCOL,ITYPCO, 15359 1 IFLAGA,IFLAGB) 15360 ILINE=ILINE+1 15361 IF(ILINE.EQ.MAXLTA .AND. I.NE.NUMROW)THEN 15362 ILINE=0 15363 IFLAG1=.TRUE. 15364 IFLAG2=.FALSE. 15365 IFLAG3=.TRUE. 15366 CALL DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD) 15367 IFLAG1=.FALSE. 15368 IFLAG2=.FALSE. 15369 IFLAG3=.TRUE. 15370 CALL DPLATY(NHEAD) 15371 ENDIF 15372 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'RTF')THEN 15373 CALL DPRTFY(IVALUE,NCTEMP,AVALUE,NUMCOL,ITYPCO, 15374 1 IFLAGA,IFLAGB) 15375 ELSE 15376C 15377 IF(ISUBRO.EQ.'DT5B' .OR. IBUGA3.EQ.'ON')THEN 15378 WRITE(ICOUT,251)I,NUMCOL,NMAX 15379 251 FORMAT('BEFORE CALL DPTABY: I,NUMCOL,NMAX = ', 15380 1 3I5) 15381 CALL DPWRST('XXX','WRIT') 15382 ENDIF 15383C 15384 ICSVWZ='OFF' 15385 IVALT=-99 15386 CALL DPTABY(IVALUE,NCTEMP,AVALUE,NUMCOL,ITYPCO, 15387 1 IFLAGA,IFLAGB,NMAX,NTOT,ICSVWZ,IVALT, 15388 1 IBUGA3,ISUBRO) 15389 ENDIF 15390 200 CONTINUE 15391 ENDIF 15392C 15393C ******************************************* 15394C ** STEP 3-- ** 15395C ** TERMINATE THE TABLE ** 15396C ******************************************* 15397C 15398 ISTEPN='2' 15399 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DT5B') 15400 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 15401C 15402 IF(.NOT.IFLAGE)GOTO399 15403C 15404 IF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'HTML')THEN 15405 IFLAG1=.TRUE. 15406 IFLAG2=.FALSE. 15407 IF(ILAST)IFLAG2=.TRUE. 15408 CALL DPHTM2(IFLAG1,IFLAG2,NHEAD) 15409 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'LATE')THEN 15410 IFLAG1=.TRUE. 15411 IFLAG2=.FALSE. 15412 IFLAG3=.FALSE. 15413 IF(ILAST)THEN 15414 IFLAG2=.TRUE. 15415 IFLAG3=.TRUE. 15416 ENDIF 15417 CALL DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD) 15418 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'RTF')THEN 15419 IF(IRTFFF.EQ.'Courier New')THEN 15420 ITEMP=1 15421 ELSEIF(IRTFFF.EQ.'Lucida Console')THEN 15422 ITEMP=8 15423 ENDIF 15424 WRITE(ICOUT,8091)IBASLC,ITEMP 15425 CALL DPWRST(ICOUT,'WRIT') 15426 CALL DPRTF6(NHEAD) 15427 CALL DPRTF6(NHEAD) 15428 IF(ILAST)THEN 15429 IRTFMD='VERB' 15430 ENDIF 15431 ELSE 15432 IF(ILAST)THEN 15433 WRITE(ICOUT,999) 15434 CALL DPWRST('XXX','WRIT') 15435 ENDIF 15436 ENDIF 15437C 15438 399 CONTINUE 15439C 15440 ENDIF 15441C 15442 RETURN 15443 END 15444 SUBROUTINE DPDT5C(ITITL9,NCTIT9, 15445 1 IHEAD,NCHEAD,ITITLE,NCTITL, 15446 1 MAXLIN,NUMLIN,MAXCOL,NUMCOL, 15447 1 ITEXT,NCTEXT,AVAL,ITYPCO,MAXROW,NUMROW, 15448 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGZ,ALIGNZ,NMAX, 15449 1 ICAPSW,ICAPTY,IFIRST,ILAST, 15450 1 IFLAGS,IFLAGE, 15451 1 ISUBRO,IBUGA3,IERROR) 15452C 15453C PURPOSE--THIS ROUTINE PRINTS A MULTI-COLUMN TABLE CONSISTING OF: 15454C 15455C 1) AN OPTIONAL OVERALL TITLE 15456C 2) HEADERS FOR EACH OF THE COLUMNS (THESE HEADERS MAY 15457C CONTAIN MULTIPLE LINES). 15458C 3) A TABLE OF NUMERIC/CHARACTER VALUES. THIS IS A 15459C VARIANT OF TABLE 2 (WHICH ONLY ALLOWS TEXT FIELDS 15460C FOR THE FIRST COLUMN). 15461C 15462C ITITL9 => THE OVERALL TITLE 15463C IHEAD => TABLE CAPTION 15464C ITITLE => LINES FOR THE COLUMN HEADERS 15465C AVAL => MATRIX OF NUMERIC VALUES FOR THE TABLE 15466C ITEXT => MATRIX OF CHARACTER VALUES FOR THE TABLE 15467C 15468C NOTE: THIS IS A VARIANT OF DPDTA5 THAT ALLOWS THE 15469C THE TYPE FOR A COLUMN TO VARY BETWEEN ALPHABETIC 15470C AND NUMERIC FOR DIFFERENT ROWS. 15471C 15472C WRITTEN BY--ALAN HECKERT 15473C STATISTICAL ENGINEERING DIVISION 15474C INFORMATION TECHNOLOGY LABORATORY 15475C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 15476C GAITHERSBURG, MD 20899-8980 15477C PHONE--301-975-2899 15478C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 15479C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 15480C LANGUAGE--ANSI FORTRAN (1977) 15481C VERSION NUMBER--2012/3 15482C ORIGINAL VERSION--MARCH 2012. 15483C UPATED --FEBRUARY 2020. CALL LIST TO DPTABY 15484C 15485C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 15486C 15487 CHARACTER*(*) IHEAD 15488 CHARACTER*(*) ITITL9 15489 CHARACTER*(*) ITITLE(MAXLIN,MAXCOL) 15490 CHARACTER*4 VALIGZ(*) 15491 CHARACTER*4 ALIGNZ(*) 15492 INTEGER NCTITL(MAXLIN,MAXCOL) 15493 INTEGER NCTEXT(MAXROW,MAXCOL) 15494 INTEGER IDIGIT(*) 15495 INTEGER NTOT(*) 15496 INTEGER IWHTML(*) 15497 INTEGER IWRTF(*) 15498 REAL AVAL(MAXROW,MAXCOL) 15499 CHARACTER*(*) ITEXT(MAXROW,MAXCOL) 15500 CHARACTER*4 ITYPCO(MAXROW,MAXCOL) 15501 CHARACTER*4 ITYPC2(20) 15502C 15503 CHARACTER*4 ICAPSW 15504 CHARACTER*4 ICAPTY 15505 CHARACTER*4 ISUBRO 15506 CHARACTER*4 IBUGA3 15507 CHARACTER*4 IERROR 15508C 15509 CHARACTER*4 ISUBN1 15510 CHARACTER*4 ISUBN2 15511 CHARACTER*4 ISTEPN 15512 CHARACTER*4 ICSVWZ 15513 CHARACTER*1 IBASLC 15514C 15515 LOGICAL IFLAG1 15516 LOGICAL IFLAG2 15517 LOGICAL IFLAG3 15518 LOGICAL IFLAGA 15519 LOGICAL IFLAGB 15520 LOGICAL IFLAGS 15521 LOGICAL IFLAGE 15522 LOGICAL IFIRST 15523 LOGICAL ILAST 15524C 15525C--------------------------------------------------------------------- 15526C 15527 INCLUDE 'DPCOST.INC' 15528C 15529 PARAMETER (MAXHED=1024) 15530 INTEGER IWIDTH(MAXHED) 15531 INTEGER NUMDIG(MAXHED) 15532 CHARACTER*8 ALIGN(MAXHED) 15533 CHARACTER*8 VALIGN(MAXHED) 15534 COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN 15535 CHARACTER*60 IVALUE(MAXHED) 15536 INTEGER NCTEMP(MAXHED) 15537 REAL AVALUE(MAXHED) 15538C 15539 CHARACTER*132 ITEMPC 15540C 15541 CHARACTER*4 IRTFMD 15542 COMMON/COMRTF/IRTFMD 15543C 15544C--------------------------------------------------------------------- 15545C 15546 INCLUDE 'DPCOP2.INC' 15547C 15548C-----START POINT----------------------------------------------------- 15549C 15550 ISUBN1='DPDT' 15551 ISUBN2='A5 ' 15552 IERROR='NO' 15553C 15554 DO40I=1,MAXHED 15555 IVALUE(I)=' ' 15556 AVALUE(I)=0.0 15557 NCTEMP(I)=0 15558 40 CONTINUE 15559C 15560 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DT5C')THEN 15561 WRITE(ICOUT,999) 15562 999 FORMAT(1X) 15563 CALL DPWRST('XXX','WRIT') 15564 WRITE(ICOUT,51) 15565 51 FORMAT('**** AT THE BEGINNING OF DPDT5C--') 15566 CALL DPWRST('XXX','WRIT') 15567 WRITE(ICOUT,52)IBUGA3,ISUBRO 15568 52 FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4) 15569 CALL DPWRST('XXX','WRIT') 15570 WRITE(ICOUT,53)MAXLIN,MAXROW,NUMROW,NUMCOL,NUMLIN 15571 53 FORMAT('MAXLIN,MAXROW,NUMROW,NUMCOL,NUMLIN = ',5I8) 15572 CALL DPWRST('XXX','WRIT') 15573 IF(NUMLIN.GT.0)THEN 15574 DO54I=1,NUMLIN 15575 DO55J=1,NUMCOL 15576 IF(NCTITL(I,J).GT.0)THEN 15577 NTEMP=MIN(80,NCTITL(I,J)) 15578 WRITE(ICOUT,56)I,J,NCTITL(I,J),ITITLE(I,J)(1:NTEMP) 15579 56 FORMAT('I,J,NCTITL(I,J),ITITL(I,J)(1:NCTITL) = ', 15580 1 3I5,2X,A80) 15581 CALL DPWRST('XXX','WRIT') 15582 ENDIF 15583 55 CONTINUE 15584 54 CONTINUE 15585 ENDIF 15586 IF(NUMROW.GT.0)THEN 15587 DO57I=1,NUMROW 15588 WRITE(ICOUT,60)I,(AVAL(I,J),J=1,MIN(5,NUMCOL)) 15589 60 FORMAT('I,(AVAL(I,J),J=1,NUMCOL) = ',I8,5G15.7) 15590 CALL DPWRST('XXX','WRIT') 15591 57 CONTINUE 15592 DO77I=1,NUMROW 15593 DO79J=1,NUMCOL 15594 WRITE(ICOUT,80)I,J,ITEXT(I,J) 15595 80 FORMAT('I,J,ITEXT(I,J) = ',2I5,2X,A60) 15596 CALL DPWRST('XXX','WRIT') 15597 79 CONTINUE 15598 77 CONTINUE 15599 ENDIF 15600 WRITE(ICOUT,62)NCHEAD 15601 62 FORMAT('NCHEAD = ',I5) 15602 CALL DPWRST('XXX','WRIT') 15603 IF(NCHEAD.GT.0)THEN 15604 WRITE(ICOUT,63)IHEAD(1:NCHEAD) 15605 63 FORMAT('NCHEAD,IHEAD = ',A80) 15606 CALL DPWRST('XXX','WRIT') 15607 ENDIF 15608 ENDIF 15609C 15610C ****************************************** 15611C ** STEP 1-- ** 15612C ** WRITE OUT THE TABLE HEADER. ** 15613C ** NOTE THAT THIS MAY CONSIST OF ** 15614C ** MULTIPLE LINES. ** 15615C ****************************************** 15616C 15617 ISTEPN='1' 15618 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DT5C') 15619 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 15620C 15621 IF(IPRINT.EQ.'ON')THEN 15622C 15623 CALL DPCONA(92,IBASLC) 15624C 15625C SKIP HEADER IF REQUESTED 15626C 15627 IF(.NOT.IFLAGS)GOTO199 15628C 15629 NHEAD=NUMCOL 15630C 15631 DO100I=1,NUMCOL 15632 IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN 15633 IWIDTH(I)=IWHTML(I) 15634 IF(VALIGZ(I).EQ.'b')THEN 15635 VALIGN(I)='BOTTOM' 15636 ELSEIF(VALIGZ(I).EQ.'c')THEN 15637 VALIGN(I)='CENTER' 15638 ELSEIF(VALIGZ(I).EQ.'t')THEN 15639 VALIGN(I)='TOP' 15640 ENDIF 15641 IF(ALIGNZ(I).EQ.'l')THEN 15642 ALIGN(I) ='LEFT' 15643 ELSEIF(ALIGNZ(I).EQ.'c')THEN 15644 ALIGN(I) ='CENTER' 15645 ELSEIF(ALIGNZ(I).EQ.'r')THEN 15646 ALIGN(I) ='RIGHT' 15647 ENDIF 15648C 15649 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN 15650 IF(VALIGZ(I).EQ.'b')THEN 15651 VALIGN(I)='b' 15652 ELSEIF(VALIGZ(I).EQ.'c')THEN 15653 VALIGN(I)='c' 15654 ELSEIF(VALIGZ(I).EQ.'t')THEN 15655 VALIGN(I)='t' 15656 ENDIF 15657 IF(ALIGNZ(I).EQ.'l')THEN 15658 ALIGN(I) ='l' 15659 ELSEIF(ALIGNZ(I).EQ.'c')THEN 15660 ALIGN(I) ='c' 15661 ELSEIF(ALIGNZ(I).EQ.'r')THEN 15662 ALIGN(I) ='r' 15663 ENDIF 15664 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN 15665 IWIDTH(I)=IWRTF(I) 15666 IF(VALIGZ(I).EQ.'b')THEN 15667 VALIGN(I)='b' 15668 ELSEIF(VALIGZ(I).EQ.'c')THEN 15669 VALIGN(I)='c' 15670 ELSEIF(VALIGZ(I).EQ.'t')THEN 15671 VALIGN(I)='t' 15672 ENDIF 15673 IF(ALIGNZ(I).EQ.'l')THEN 15674 ALIGN(I) ='l' 15675 ELSEIF(ALIGNZ(I).EQ.'c')THEN 15676 ALIGN(I) ='c' 15677 ELSEIF(ALIGNZ(I).EQ.'r')THEN 15678 ALIGN(I) ='r' 15679 ENDIF 15680 ELSE 15681 IF(VALIGZ(I).EQ.'b')THEN 15682 VALIGN(I)='b' 15683 ELSEIF(VALIGZ(I).EQ.'c')THEN 15684 VALIGN(I)='c' 15685 ELSEIF(VALIGZ(I).EQ.'t')THEN 15686 VALIGN(I)='t' 15687 ENDIF 15688 IF(ALIGNZ(I).EQ.'l')THEN 15689 ALIGN(I) ='l' 15690 ELSEIF(ALIGNZ(I).EQ.'c')THEN 15691 ALIGN(I) ='c' 15692 ELSEIF(ALIGNZ(I).EQ.'r')THEN 15693 ALIGN(I) ='r' 15694 ENDIF 15695 ENDIF 15696 100 CONTINUE 15697C 15698C LOOP THROUGH THE LINES OF THE HEADER 15699C 15700 IF(NUMLIN.GE.1)THEN 15701 DO110I=1,NUMLIN 15702C 15703 DO120J=1,NUMCOL 15704 IVALUE(J)=' ' 15705 NCTEMP(J)=0 15706 IF(NCTITL(I,J).GT.0)THEN 15707 NCTEMP(J)=NCTITL(I,J) 15708 IVALUE(J)(1:NCTEMP(J))=ITITLE(I,J)(1:NCTEMP(J)) 15709 ENDIF 15710C 15711 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DT5C')THEN 15712 WRITE(ICOUT,106)I,J,NCTEMP(J),IVALUE(J) 15713 106 FORMAT('I,J,NCTEMP(J),IVALUE(J) = ',3I8,A80) 15714 CALL DPWRST('XXX','WRIT') 15715 ENDIF 15716C 15717 120 CONTINUE 15718C 15719 IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN 15720 IF(I.EQ.1)THEN 15721 IFLAG1=.FALSE. 15722 IF(IFIRST)IFLAG1=.TRUE. 15723 IFLAG2=.TRUE. 15724 IF(NCTIT9.LE.0)THEN 15725 IF(IFIRST)THEN 15726 CALL DPHTM1(IHEAD,NCHEAD,IFLAG1,IFLAG2) 15727 ELSE 15728 CALL DPHTMA(ITITL9,NCTIT9,IHEAD,NCHEAD, 15729 1 IFLAG1,IFLAG2) 15730 ENDIF 15731 ELSE 15732 CALL DPHTMA(ITITL9,NCTIT9,IHEAD,NCHEAD,IFLAG1,IFLAG2) 15733 ENDIF 15734 ENDIF 15735 IFLAG1=.FALSE. 15736 IFLAG2=.FALSE. 15737 IF(I.EQ.1)IFLAG1=.TRUE. 15738 IF(I.EQ.NUMLIN)IFLAG2=.TRUE. 15739 CALL DPHTM4(IVALUE,NCTEMP,NUMCOL,IFLAG1,IFLAG2) 15740C 15741 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN 15742C 15743 IF(I.EQ.1)THEN 15744 IF(IFIRST)THEN 15745 IFLAG1=.FALSE. 15746 IFLAG2=.FALSE. 15747 IFLAG3=.TRUE. 15748 CALL DPLAT6(IFLAG1,IFLAG2,IFLAG3) 15749 ENDIF 15750 IFLAG1=.FALSE. 15751 IF(IFIRST)IFLAG1=.TRUE. 15752 IFLAG2=.TRUE. 15753C 15754 CALL DPDTLA(IHEAD,NCHEAD,NCT,ISUBRO,IBUGA3,IERROR) 15755 NCHEAD=NCT 15756C 15757 IF(NCTIT9.LE.0)THEN 15758 ITEMPC=' ' 15759 NCHEA2=0 15760 CALL DPLAT1(IHEAD,NCHEAD,ITEMPC,NCHEA2,IFLAG1) 15761 ELSE 15762 CALL DPDTLA(ITITL9,NCTIT9,NCT,ISUBRO,IBUGA3,IERROR) 15763 NCTIT9=NCT 15764 CALL DPLAT1(ITITL9,NCTIT9,IHEAD,NCHEAD,IFLAG1) 15765 ENDIF 15766 ENDIF 15767 IFLAG1=.FALSE. 15768 IFLAG2=.FALSE. 15769 IFLAG3=.FALSE. 15770 IF(I.EQ.1)IFLAG1=.TRUE. 15771 IF(I.EQ.NUMLIN)IFLAG2=.TRUE. 15772 IF(I.EQ.1)IFLAG3=.TRUE. 15773C 15774 DO6110JJ=1,NUMCOL 15775 CALL DPDTLA(IVALUE(JJ),NCTEMP(JJ),NCT, 15776 1 ISUBRO,IBUGA3,IERROR) 15777 NCTEMP(JJ)=NCT 15778 6110 CONTINUE 15779C 15780 CALL DPLAT4(IVALUE,NCTEMP,NUMCOL,IFLAG1,IFLAG2,IFLAG3) 15781C 15782 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF ')THEN 15783C 15784 8091 FORMAT(A1,'f',I1) 15785 IF(I.EQ.1)THEN 15786 IF(IRTFFP.EQ.'Times New Roman')THEN 15787 ITEMP=0 15788 ELSEIF(IRTFFP.EQ.'Lucida Sans')THEN 15789 ITEMP=6 15790 ELSEIF(IRTFFP.EQ.'Arial')THEN 15791 ITEMP=2 15792 ELSEIF(IRTFFP.EQ.'Bookman')THEN 15793 ITEMP=3 15794 ELSEIF(IRTFFP.EQ.'Georgia')THEN 15795 ITEMP=4 15796 ELSEIF(IRTFFP.EQ.'Tahoma')THEN 15797 ITEMP=5 15798 ELSEIF(IRTFFP.EQ.'Verdana')THEN 15799 ITEMP=7 15800 ELSE 15801 ITEMP=0 15802 ENDIF 15803C 15804 IRTFMD='OFF' 15805C 15806 IF(NCTIT9.GE.1.AND.I.EQ.1)THEN 15807 IF(NCTIT9.LE.0)THEN 15808 ITEMPC=' ' 15809 NCHEA2=0 15810 ELSE 15811 NCHEA2=NCTIT9+3 15812 ITEMPC(4:NCHEA2)=ITITL9(1:NCTIT9) 15813 ITEMPC(1:3)=' b ' 15814 ITEMPC(1:1)=IBASLC 15815 ENDIF 15816 IF(NCHEAD.GE.1)THEN 15817 NCTEM2=NCHEAD+3 15818 IHEAD(4:NCTEM2)=IHEAD(1:NCHEAD) 15819 IHEAD(1:3)=' b ' 15820 IHEAD(1:1)=IBASLC 15821 ELSE 15822 NCTEM2=0 15823 ENDIF 15824 CALL DPRTF1(ITEMPC,NCHEA2,IHEAD,NCTEM2) 15825 ENDIF 15826 ENDIF 15827C 15828 DO130J=1,NUMCOL 15829 NCHAR=NCTEMP(J)+3 15830 IVALUE(J)(4:NCHAR)=IVALUE(J)(1:NCTEMP(J)) 15831 IVALUE(J)(1:3)=' b ' 15832 IVALUE(J)(1:1)=IBASLC 15833 NCTEMP(J)=NCHAR 15834 130 CONTINUE 15835 IFLAG1=.FALSE. 15836 IFLAG2=.FALSE. 15837 IF(I.EQ.1)IFLAG1=.TRUE. 15838 IF(I.EQ.NUMLIN)IFLAG2=.TRUE. 15839 CALL DPRTF4(IVALUE,NCTEMP,NUMCOL,IFLAG1,IFLAG2) 15840 ELSE 15841 IF(I.EQ.1)THEN 15842 IFLAG1=.TRUE. 15843 CALL DPTAB1(ITITL9,NCTIT9,IHEAD,NCHEAD,IFLAG1) 15844 ENDIF 15845 IFLAG1=.FALSE. 15846 IFLAG2=.FALSE. 15847 IF(I.EQ.1)IFLAG1=.TRUE. 15848 IF(I.EQ.NUMLIN)IFLAG2=.TRUE. 15849C 15850 DO 141 KK=1,NUMCOL 15851 IF(ALIGN(KK).EQ.'l' .AND. NCTEMP(KK).LT.NTOT(KK))THEN 15852 DO146JJ=NCTEMP(KK)+1,NTOT(KK) 15853 IVALUE(KK)(JJ:JJ)=' ' 15854 146 CONTINUE 15855 NCTEMP(KK)=NTOT(KK) 15856 ELSEIF(ALIGN(KK).EQ.'c'.AND.NCTEMP(KK).LT.NTOT(KK))THEN 15857 IVALUE(KK)(NCTEMP(KK):NTOT(KK))=' ' 15858 IDIFF=(NTOT(KK)-NCTEMP(KK))/2 15859 IF(IDIFF.GT.0)THEN 15860 DO147JJ=NTOT(KK),IDIFF+1,-1 15861 IVALUE(KK)(JJ:JJ)=IVALUE(KK)(JJ-IDIFF:JJ-IDIFF) 15862 147 CONTINUE 15863 IVALUE(KK)(1:IDIFF)=' ' 15864 ENDIF 15865 NCTEMP(KK)=NTOT(KK) 15866 ELSEIF(ALIGN(KK).EQ.'r'.AND.NCTEMP(KK).LT.NTOT(KK))THEN 15867C 15868 IF(ISUBRO.EQ.'DT5C' .OR. IBUGA3.EQ.'ON')THEN 15869 WRITE(ICOUT,157)KK,NCTEMP(KK),NTOT(KK) 15870 157 FORMAT('BEFORE 148: KK,NCTEMP(KK),NTOT(KK) =', 15871 1 3I8) 15872 CALL DPWRST('XXX','WRIT') 15873 WRITE(ICOUT,153)IVALUE(KK)(1:NCTEMP(KK)) 15874 CALL DPWRST('XXX','WRIT') 15875 ENDIF 15876C 15877 IDIFF=NTOT(KK)-NCTEMP(KK) 15878 DO148JJ=NTOT(KK),IDIFF+1,-1 15879 IVALUE(KK)(JJ:JJ)=IVALUE(KK)(JJ-IDIFF:JJ-IDIFF) 15880 148 CONTINUE 15881 IVALUE(KK)(1:IDIFF)=' ' 15882 NCTEMP(KK)=NTOT(KK) 15883 ENDIF 15884C 15885 IF(ISUBRO.EQ.'DT5C' .OR. IBUGA3.EQ.'ON')THEN 15886 WRITE(ICOUT,151)KK,IDIFF,NCTEMP(KK),NUMCOL,NMAX 15887 151 FORMAT('BEFORE CALL DPTAB4: KK,IDIFF,NCTEMP(KK),', 15888 1 'NUMCOL,NMAX=',5I8) 15889 CALL DPWRST('XXX','WRIT') 15890 WRITE(ICOUT,153)IVALUE(KK)(1:NCTEMP(KK)) 15891 153 FORMAT('IVALUE(KK) = ',A80) 15892 CALL DPWRST('XXX','WRIT') 15893 ENDIF 15894C 15895 141 CONTINUE 15896C 15897 CALL DPTAB4(IVALUE,NCTEMP,NUMCOL,IFLAG1,IFLAG2,NMAX) 15898C 15899 ENDIF 15900 110 CONTINUE 15901 ENDIF 15902C 15903 199 CONTINUE 15904C 15905C ****************************************** 15906C ** STEP 2-- ** 15907C ** WRITE OUT THE TABLE ROWS ** 15908C ****************************************** 15909C 15910 IFLAGA=.FALSE. 15911 IFLAGB=.FALSE. 15912 MAXLTA=35 15913 ILINE=0 15914 IF(NUMROW.GE.1)THEN 15915 DO200I=1,NUMROW 15916C 15917 DO201JJ=1,NUMCOL 15918 ITYPC2(JJ)=ITYPCO(I,JJ) 15919 201 CONTINUE 15920C 15921 IFLAG1=.FALSE. 15922 IF(I.EQ.NUMROW)IFLAG1=.TRUE. 15923 DO210J=1,NUMCOL 15924 AVALUE(J)=AVAL(I,J) 15925 IF(AVALUE(J).EQ.CPUMIN)THEN 15926 NUMDIG(J)=-99 15927 ELSE 15928 NUMDIG(J)=IDIGIT(J) 15929 ENDIF 15930 IVALUE(J)=' ' 15931 NTEMP=NCTEXT(I,J) 15932 NCTEMP(J)=NTEMP 15933 IF(NTEMP.GT.0 .AND. ITYPC2(J).EQ.'ALPH')THEN 15934 IVALUE(J)(1:NTEMP)=ITEXT(I,J)(1:NTEMP) 15935C 15936 IF(ICAPTY.EQ.'LATE')THEN 15937 CALL DPDTLA(IVALUE(J),NTEMP,NCT,ISUBRO,IBUGA3,IERROR) 15938 NTEMP=NCT 15939 NCTEMP(J)=NTEMP 15940 ENDIF 15941C 15942 ENDIF 15943C 15944 IF(ISUBRO.EQ.'DT5C' .OR. IBUGA3.EQ.'ON')THEN 15945 WRITE(ICOUT,211)I,J,ITYPC2(J),AVALUE(J),IVALUE(J) 15946 211 FORMAT('I,J,ITYPC2(J),AVALUE(J),IVALUE(J) = ', 15947 1 2I8,2X,A4,2X,G15.7,2X,A60) 15948 CALL DPWRST('XXX','WRIT') 15949 ENDIF 15950C 15951 210 CONTINUE 15952C 15953 IF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'HTML')THEN 15954 CALL DPHTMY(IVALUE,NCTEMP,AVALUE,NUMCOL,ITYPC2, 15955 1 IFLAGA,IFLAGB) 15956C 15957C FOR LATEX, WE CANNOT EXTEND TABLES BEYOND A SINGLE 15958C PAGE, SO PUT A CHECK IN. 15959C 15960 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'LATE')THEN 15961 CALL DPLATW(IVALUE,NCTEMP,AVALUE,NUMCOL,ITYPC2, 15962 1 IFLAGA,IFLAGB) 15963 ILINE=ILINE+1 15964 IF(ILINE.EQ.MAXLTA .AND. I.NE.NUMROW)THEN 15965 ILINE=0 15966 IFLAG1=.TRUE. 15967 IFLAG2=.FALSE. 15968 IFLAG3=.TRUE. 15969 CALL DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD) 15970 IFLAG1=.FALSE. 15971 IFLAG2=.FALSE. 15972 IFLAG3=.TRUE. 15973 CALL DPLATY(NHEAD) 15974 ENDIF 15975 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'RTF')THEN 15976 CALL DPRTFY(IVALUE,NCTEMP,AVALUE,NUMCOL,ITYPC2, 15977 1 IFLAGA,IFLAGB) 15978 ELSE 15979C 15980 IF(ISUBRO.EQ.'DT5C' .OR. IBUGA3.EQ.'ON')THEN 15981 WRITE(ICOUT,251)I,NUMCOL,NMAX 15982 251 FORMAT('BEFORE CALL DPTABY: I,NUMCOL,NMAX = ', 15983 1 3I5) 15984 CALL DPWRST('XXX','WRIT') 15985 ENDIF 15986C 15987 ICSVWZ='OFF' 15988 IVALT=-99 15989 CALL DPTABY(IVALUE,NCTEMP,AVALUE,NUMCOL,ITYPC2, 15990 1 IFLAGA,IFLAGB,NMAX,NTOT,ICSVWZ,IVALT, 15991 1 IBUGA3,ISUBRO) 15992 ENDIF 15993 200 CONTINUE 15994 ENDIF 15995C 15996C ******************************************* 15997C ** STEP 3-- ** 15998C ** TERMINATE THE TABLE ** 15999C ******************************************* 16000C 16001 ISTEPN='2' 16002 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DT5C') 16003 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16004C 16005 IF(.NOT.IFLAGE)GOTO399 16006C 16007 IF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'HTML')THEN 16008 IFLAG1=.TRUE. 16009 IFLAG2=.FALSE. 16010 IF(ILAST)IFLAG2=.TRUE. 16011 CALL DPHTM2(IFLAG1,IFLAG2,NHEAD) 16012 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'LATE')THEN 16013 IFLAG1=.TRUE. 16014 IFLAG2=.FALSE. 16015 IFLAG3=.FALSE. 16016 IF(ILAST)THEN 16017 IFLAG2=.TRUE. 16018 IFLAG3=.TRUE. 16019 ENDIF 16020 CALL DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD) 16021 ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'RTF')THEN 16022 IF(IRTFFF.EQ.'Courier New')THEN 16023 ITEMP=1 16024 ELSEIF(IRTFFF.EQ.'Lucida Console')THEN 16025 ITEMP=8 16026 ENDIF 16027 WRITE(ICOUT,8091)IBASLC,ITEMP 16028 CALL DPWRST(ICOUT,'WRIT') 16029 CALL DPRTF6(NHEAD) 16030 CALL DPRTF6(NHEAD) 16031 IF(ILAST)THEN 16032 IRTFMD='VERB' 16033 ENDIF 16034 ELSE 16035 IF(ILAST)THEN 16036 WRITE(ICOUT,999) 16037 CALL DPWRST('XXX','WRIT') 16038 ENDIF 16039 ENDIF 16040C 16041 399 CONTINUE 16042C 16043 ENDIF 16044C 16045 RETURN 16046 END 16047 SUBROUTINE DPDTA6(COV,ALOWLO,AUPPLO,ALOWSC,AUPPSC,ALOWSH,AUPPSH, 16048 1 ALPHA,NUMALP, 16049 1 ICAPSW,ICAPTY,NUMDIG, 16050 1 ISUBRO,IBUGA3,IERROR) 16051C 16052C PURPOSE--FOR VARIOUS 3-PARAMETER PROBABILITY DISTRIBUTIONS, 16053C THIS SUBROUTINE PRINTS THE CONFIDENCE INTERVAL 16054C TABLES FOR THE LOCATION, SCALE AND THE SHAPE PARAMETERS. 16055C THIS IS CURRENTLY LIMITED TO THE NORMAL APPROXIMATION 16056C METHOD. IN ADDITION, IT WILL PRINT THE PARAMETER 16057C VARIANCE-COVARIANCE MATRIX. 16058C 16059C WRITTEN BY--ALAN HECKERT 16060C STATISTICAL ENGINEERING DIVISION 16061C INFORMATION TECHNOLOGY LABORATORY 16062C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 16063C GAITHERSBURG, MD 20899-8980 16064C PHONE--301-975-2899 16065C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16066C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 16067C LANGUAGE--ANSI FORTRAN (1977) 16068C VERSION NUMBER--2010/05 16069C ORIGINAL VERSION--APRIL 2010 16070C 16071C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16072C 16073 CHARACTER*4 ICAPSW 16074 CHARACTER*4 ICAPTY 16075C 16076 CHARACTER*4 ISUBRO 16077 CHARACTER*4 IBUGA3 16078 CHARACTER*4 IERROR 16079 CHARACTER*4 ISUBN1 16080 CHARACTER*4 ISUBN2 16081C 16082C--------------------------------------------------------------------- 16083C 16084 DIMENSION COV(3,3) 16085 DIMENSION ALPHA(*) 16086 DIMENSION ALOWLO(*) 16087 DIMENSION AUPPLO(*) 16088 DIMENSION ALOWSC(*) 16089 DIMENSION AUPPSC(*) 16090 DIMENSION ALOWSH(*) 16091 DIMENSION AUPPSH(*) 16092C 16093 INCLUDE 'DPCOST.INC' 16094C 16095 PARAMETER (MAXROW=10) 16096 CHARACTER*60 ITITLE 16097 CHARACTER*1 ITITL9 16098 CHARACTER*40 ITEXT(NUMALP) 16099 CHARACTER*4 ALIGN(NUMALP) 16100 CHARACTER*4 VALIGN(NUMALP) 16101 INTEGER NCTEXT(MAXROW) 16102 INTEGER IDIGIT(MAXROW) 16103 INTEGER NTOT(MAXROW) 16104C 16105 PARAMETER(NUMCLI=5) 16106 PARAMETER(MAXLIN=3) 16107 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 16108 INTEGER NCTIT2(MAXLIN,NUMCLI) 16109 INTEGER IWHTML(NUMALP) 16110 INTEGER IWRTF(NUMALP) 16111 REAL AMAT(MAXROW,NUMCLI) 16112 LOGICAL IFRST 16113 LOGICAL ILAST 16114C 16115C--------------------------------------------------------------------- 16116C 16117 INCLUDE 'DPCOP2.INC' 16118C 16119C-----START POINT----------------------------------------------------- 16120C 16121 ISUBN1='DPDT' 16122 ISUBN2='A6 ' 16123 IERROR='NO' 16124C 16125 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTA6')THEN 16126 WRITE(ICOUT,999) 16127 999 FORMAT(1X) 16128 CALL DPWRST('XXX','WRIT') 16129 WRITE(ICOUT,51) 16130 51 FORMAT('**** AT THE BEGINNING OF DPDTA6--') 16131 CALL DPWRST('XXX','WRIT') 16132 WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMALP 16133 52 FORMAT('IBUGA3,ISUBRO,NUMALP = ',A4,2X,A4,2X,I8) 16134 CALL DPWRST('XXX','WRIT') 16135 DO56I=1,NUMALP 16136 WRITE(ICOUT,57)I,ALOWLO(I),AUPPLO(I),ALOWSC(I),AUPPSC(I), 16137 1 ALOWSH(I),AUPPSH(I) 16138 57 FORMAT('I,ALOWLO(I),AUPPLO(I),ALOWSC(I),AUPPSC(I),', 16139 1 'ALOWSH(I),AUPPSH(I) = ',I8,6G15.7) 16140 CALL DPWRST('XXX','WRIT') 16141 56 CONTINUE 16142 ENDIF 16143C 16144 ITITLE(1:42)='Parameter Variance-Covariance Matrix' 16145 NCTITL=36 16146 NUMLIN=2 16147 NUMCOL=3 16148 NUMROW=3 16149 ITITL2(1,1)='Location' 16150 ITITL2(2,1)='Parameter' 16151 NCTIT2(1,1)=8 16152 NCTIT2(2,1)=9 16153 ITITL2(1,2)='Scale' 16154 ITITL2(2,2)='Parameter' 16155 NCTIT2(1,2)=5 16156 NCTIT2(2,2)=9 16157 ITITL2(1,3)='Shape' 16158 ITITL2(2,3)='Parameter' 16159 NCTIT2(1,3)=5 16160 NCTIT2(2,3)=9 16161C 16162 NMAX=0 16163 DO1121I=1,NUMCOL 16164 VALIGN(I)='b' 16165 ALIGN(I)='r' 16166 NTOT(I)=15 16167 NMAX=NMAX+NTOT(I) 16168 IDIGIT(I)=NUMDIG 16169 1121 CONTINUE 16170 DO1123I=1,NUMROW 16171 NCTEXT(I)=0 16172 AMAT(I,1)=COV(I,1) 16173 AMAT(I,2)=COV(I,2) 16174 AMAT(I,3)=COV(I,3) 16175 1123 CONTINUE 16176 IWHTML(1)=150 16177 IWHTML(2)=150 16178 IWHTML(3)=150 16179 IWHTML(4)=150 16180 IWRTF(1)=2000 16181 IWRTF(2)=IWRTF(1)+2000 16182 IWRTF(3)=IWRTF(2)+2000 16183 ITITL9=' ' 16184 NCTIT9=0 16185 IFRST=.TRUE. 16186 ILAST=.TRUE. 16187C 16188 CALL DPDTA2(ITITLE,NCTITL, 16189 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 16190 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 16191 1 ITEXT,NCTEXT,AMAT,MAXROW,NUMROW, 16192 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 16193 1 ICAPSW,ICAPTY,IFRST,ILAST, 16194 1 ISUBRO,IBUGA3,IERROR) 16195C 16196 ITITLE(1:42)='Confidence Interval for Location Parameter' 16197 NCTITL=42 16198 NUMLIN=3 16199 NUMCOL=3 16200 ITITL2(1,1)=' ' 16201 ITITL2(2,1)='Confidence' 16202 ITITL2(3,1)='Coefficient' 16203 NCTIT2(1,1)=0 16204 NCTIT2(2,1)=10 16205 NCTIT2(3,1)=11 16206 ITITL2(1,2)='Normal' 16207 ITITL2(2,2)='Lower' 16208 ITITL2(3,2)='Limit' 16209 NCTIT2(1,2)=6 16210 NCTIT2(2,2)=5 16211 NCTIT2(3,2)=5 16212 ITITL2(1,3)='Approximation' 16213 ITITL2(2,3)='Upper' 16214 ITITL2(3,3)='Limit' 16215 NCTIT2(1,3)=13 16216 NCTIT2(2,3)=5 16217 NCTIT2(3,3)=5 16218C 16219 NMAX=0 16220 DO1521I=1,NUMCOL 16221 VALIGN(I)='b' 16222 ALIGN(I)='r' 16223 NTOT(I)=15 16224 NMAX=NMAX+NTOT(I) 16225 IDIGIT(I)=NUMDIG 16226 1521 CONTINUE 16227 NTOT(1)=12 16228 IDIGIT(1)=2 16229 DO1523I=1,NUMALP 16230 NCTEXT(I)=0 16231 AMAT(I,1)=100.0*(1.0 - ALPHA(I)) 16232 AMAT(I,2)=ALOWLO(I) 16233 AMAT(I,3)=AUPPLO(I) 16234 1523 CONTINUE 16235 IWHTML(1)=150 16236 IWHTML(2)=150 16237 IWHTML(3)=150 16238 IWHTML(4)=150 16239 IWRTF(1)=2000 16240 IWRTF(2)=IWRTF(1)+2000 16241 IWRTF(3)=IWRTF(2)+2000 16242 ITITL9=' ' 16243 NCTIT9=0 16244 IFRST=.TRUE. 16245 ILAST=.TRUE. 16246C 16247 CALL DPDTA2(ITITLE,NCTITL, 16248 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 16249 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 16250 1 ITEXT,NCTEXT,AMAT,MAXROW,NUMALP, 16251 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 16252 1 ICAPSW,ICAPTY,IFRST,ILAST, 16253 1 ISUBRO,IBUGA3,IERROR) 16254C 16255 ITITLE(1:39)='Confidence Interval for Scale Parameter' 16256 NCTITL=39 16257 NUMLIN=3 16258 NUMCOL=3 16259 ITITL2(1,1)=' ' 16260 ITITL2(2,1)='Confidence' 16261 ITITL2(3,1)='Coefficient' 16262 NCTIT2(1,1)=0 16263 NCTIT2(2,1)=10 16264 NCTIT2(3,1)=11 16265 ITITL2(1,2)='Normal' 16266 ITITL2(2,2)='Lower' 16267 ITITL2(3,2)='Limit' 16268 NCTIT2(1,2)=6 16269 NCTIT2(2,2)=5 16270 NCTIT2(3,2)=5 16271 ITITL2(1,3)='Approximation' 16272 ITITL2(2,3)='Upper' 16273 ITITL2(3,3)='Limit' 16274 NCTIT2(1,3)=13 16275 NCTIT2(2,3)=5 16276 NCTIT2(3,3)=5 16277C 16278 NMAX=0 16279 DO2521I=1,NUMCOL 16280 VALIGN(I)='b' 16281 ALIGN(I)='r' 16282 NTOT(I)=15 16283 NMAX=NMAX+NTOT(I) 16284 IDIGIT(I)=NUMDIG 16285 2521 CONTINUE 16286 NTOT(1)=12 16287 IDIGIT(1)=2 16288 DO2523I=1,NUMALP 16289 NCTEXT(I)=0 16290 AMAT(I,1)=100.0*(1.0 - ALPHA(I)) 16291 AMAT(I,2)=ALOWSC(I) 16292 AMAT(I,3)=AUPPSC(I) 16293 2523 CONTINUE 16294 IWHTML(1)=150 16295 IWHTML(2)=150 16296 IWHTML(3)=150 16297 IWHTML(4)=150 16298 IWRTF(1)=2000 16299 IWRTF(2)=IWRTF(1)+2000 16300 IWRTF(3)=IWRTF(2)+2000 16301 ITITL9=' ' 16302 NCTIT9=0 16303 IFRST=.TRUE. 16304 ILAST=.TRUE. 16305C 16306 CALL DPDTA2(ITITLE,NCTITL, 16307 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 16308 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 16309 1 ITEXT,NCTEXT,AMAT,MAXROW,NUMALP, 16310 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 16311 1 ICAPSW,ICAPTY,IFRST,ILAST, 16312 1 ISUBRO,IBUGA3,IERROR) 16313C 16314 ITITLE(1:39)='Confidence Interval for Shape Parameter' 16315 NCTITL=39 16316 DO2533I=1,NUMALP 16317 NCTEXT(I)=0 16318 AMAT(I,1)=100.0*(1.0 - ALPHA(I)) 16319 AMAT(I,2)=ALOWSH(I) 16320 AMAT(I,3)=AUPPSH(I) 16321 2533 CONTINUE 16322 IFRST=.TRUE. 16323 ILAST=.TRUE. 16324C 16325 CALL DPDTA2(ITITLE,NCTITL, 16326 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 16327 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 16328 1 ITEXT,NCTEXT,AMAT,MAXROW,NUMALP, 16329 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 16330 1 ICAPSW,ICAPTY,IFRST,ILAST, 16331 1 ISUBRO,IBUGA3,IERROR) 16332C 16333C ***************** 16334C ** STEP 90-- ** 16335C ** EXIT ** 16336C ***************** 16337C 16338 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTA6')THEN 16339 WRITE(ICOUT,999) 16340 CALL DPWRST('XXX','WRIT') 16341 WRITE(ICOUT,9011) 16342 9011 FORMAT('***** AT THE END OF DPDTA6--') 16343 CALL DPWRST('XXX','WRIT') 16344 ENDIF 16345C 16346 RETURN 16347 END 16348 SUBROUTINE DPDTA7(ALOWLO,AUPPLO,ALOWSC,AUPPSC,ALPHA,NUMALP, 16349 1 ICAPSW,ICAPTY,NUMDIG,INORM, 16350 1 ISUBRO,IBUGA3,IERROR) 16351C 16352C PURPOSE--THIS ROUTINE PRINTS THE CONFIDENCE INTERVAL TABLES 16353C FOR THE LOCATION AND SCALE PARAMETERS FOR 16354C LOCATION/SCALE PROBABILITY DISTRIBUTIONS. 16355C WRITTEN BY--ALAN HECKERT 16356C STATISTICAL ENGINEERING DIVISION 16357C INFORMATION TECHNOLOGY LABORATORY 16358C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 16359C GAITHERSBURG, MD 20899-8980 16360C PHONE--301-975-2899 16361C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16362C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 16363C LANGUAGE--ANSI FORTRAN (1977) 16364C VERSION NUMBER--2010/02 16365C ORIGINAL VERSION--FEBRUARY 2010. EXTRACTED AS DISTINCT SUBROUTINE 16366C UPDATED --JUNE 2010. ADD "NORMAL APPROXIMATION" 16367C TO TITLE LINE 16368C 16369C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16370C 16371 CHARACTER*4 ICAPSW 16372 CHARACTER*4 ICAPTY 16373 CHARACTER*4 INORM 16374 CHARACTER*4 ISUBRO 16375 CHARACTER*4 IBUGA3 16376 CHARACTER*4 IERROR 16377C 16378 CHARACTER*4 ISUBN1 16379 CHARACTER*4 ISUBN2 16380C 16381C--------------------------------------------------------------------- 16382C 16383 DIMENSION ALPHA(*) 16384 DIMENSION ALOWSC(*) 16385 DIMENSION AUPPSC(*) 16386 DIMENSION ALOWLO(*) 16387 DIMENSION AUPPLO(*) 16388C 16389 INCLUDE 'DPCOST.INC' 16390C 16391 PARAMETER (MAXROW=10) 16392 CHARACTER*70 ITITLE 16393 CHARACTER*1 ITITL9 16394 CHARACTER*40 ITEXT(MAXROW) 16395 CHARACTER*4 ALIGN(NUMALP) 16396 CHARACTER*4 VALIGN(NUMALP) 16397 INTEGER NCTEXT(MAXROW) 16398 INTEGER IDIGIT(MAXROW) 16399 INTEGER NTOT(MAXROW) 16400C 16401 PARAMETER(NUMCLI=3) 16402 PARAMETER(MAXLIN=2) 16403 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 16404 INTEGER NCTIT2(MAXLIN,NUMCLI) 16405 INTEGER IWHTML(NUMALP) 16406 INTEGER IWRTF(NUMALP) 16407 REAL AMAT(MAXROW,NUMCLI) 16408 LOGICAL IFRST 16409 LOGICAL ILAST 16410C 16411C--------------------------------------------------------------------- 16412C 16413 INCLUDE 'DPCOP2.INC' 16414C 16415C-----START POINT----------------------------------------------------- 16416C 16417 ISUBN1='DPDT' 16418 ISUBN2='A7 ' 16419 IERROR='NO' 16420C 16421 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTA7')THEN 16422 WRITE(ICOUT,999) 16423 999 FORMAT(1X) 16424 CALL DPWRST('XXX','WRIT') 16425 WRITE(ICOUT,51) 16426 51 FORMAT('**** AT THE BEGINNING OF DPDTA7--') 16427 CALL DPWRST('XXX','WRIT') 16428 WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMALP 16429 52 FORMAT('IBUGA3,ISUBRO,NUMALP = ',A4,2X,A4,2X,I5) 16430 CALL DPWRST('XXX','WRIT') 16431 DO56I=1,NUMALP 16432 WRITE(ICOUT,57)I,ALOWLO(I),AUPPLO(I),ALOWSC(I),AUPPSC(I) 16433 57 FORMAT('I,ALOWLO(I),AUPPLO(I),ALOWSC(I),AUPPSC(I) = ', 16434 1 I8,4G15.7) 16435 CALL DPWRST('XXX','WRIT') 16436 56 CONTINUE 16437 ENDIF 16438C 16439 ITITL9=' ' 16440 NCTIT9=0 16441 ITITLE(1:42)='Confidence Interval for Location Parameter' 16442 IF(INORM.EQ.'YES')THEN 16443 ITITLE(43:65)=' (Normal Approximation)' 16444 NCTITL=65 16445 ELSE 16446 NCTITL=42 16447 ENDIF 16448 NUMLIN=2 16449 NUMCOL=3 16450 ITITL2(1,1)='Confidence' 16451 ITITL2(2,1)='Coefficient' 16452 ITITL2(1,2)='Lower' 16453 ITITL2(2,2)='Limit' 16454 ITITL2(1,3)='Upper' 16455 ITITL2(2,3)='Limit' 16456 NCTIT2(1,1)=10 16457 NCTIT2(2,1)=11 16458 NCTIT2(1,2)=5 16459 NCTIT2(2,2)=5 16460 NCTIT2(1,3)=5 16461 NCTIT2(2,3)=5 16462 NMAX=0 16463 DO2420I=1,NUMCOL 16464 VALIGN(I)=' ' 16465 ALIGN(I)=' ' 16466 NTOT(I)=0 16467 IDIGIT(I)=0 16468 2420 CONTINUE 16469 DO2421I=1,NUMCOL 16470 VALIGN(I)='b' 16471 ALIGN(I)='r' 16472 NTOT(I)=15 16473 NMAX=NMAX+NTOT(I) 16474 IDIGIT(I)=NUMDIG 16475 2421 CONTINUE 16476 IDIGIT(1)=2 16477 DO2423I=1,NUMALP 16478 NCTEXT(I)=0 16479 AMAT(I,1)=100.0*(1.0 - ALPHA(I)) 16480 AMAT(I,2)=ALOWLO(I) 16481 AMAT(I,3)=AUPPLO(I) 16482 2423 CONTINUE 16483 IWHTML(1)=150 16484 IWHTML(2)=150 16485 IWHTML(3)=150 16486 IWHTML(4)=150 16487 IWRTF(1)=2000 16488 IWRTF(2)=IWRTF(1)+2000 16489 IWRTF(3)=IWRTF(2)+2000 16490 IFRST=.TRUE. 16491 ILAST=.TRUE. 16492C 16493 IF(ALOWLO(1).EQ.CPUMIN)GOTO2999 16494C 16495 CALL DPDTA2(ITITL9,NCTIT9, 16496 1 ITITLE,NCTITL,ITITL2,NCTIT2, 16497 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 16498 1 ITEXT,NCTEXT,AMAT,MAXROW,NUMALP, 16499 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 16500 1 ICAPSW,ICAPTY,IFRST,ILAST, 16501 1 ISUBRO,IBUGA3,IERROR) 16502C 16503 2999 CONTINUE 16504C 16505 ITITLE(1:39)='Confidence Interval for Scale Parameter' 16506 IF(INORM.EQ.'YES')THEN 16507 ITITLE(40:62)=' (Normal Approximation)' 16508 NCTITL=62 16509 ELSE 16510 NCTITL=39 16511 ENDIF 16512 NMAX=0 16513 DO2521I=1,NUMCOL 16514 VALIGN(I)='b' 16515 ALIGN(I)='r' 16516 NTOT(I)=15 16517 NMAX=NMAX+NTOT(I) 16518 IDIGIT(I)=NUMDIG 16519 2521 CONTINUE 16520 IDIGIT(1)=2 16521 DO2523I=1,NUMALP 16522 NCTEXT(I)=0 16523 AMAT(I,1)=100.0*(1.0 - ALPHA(I)) 16524 AMAT(I,2)=ALOWSC(I) 16525 AMAT(I,3)=AUPPSC(I) 16526 2523 CONTINUE 16527 IWHTML(1)=150 16528 IWHTML(2)=150 16529 IWHTML(3)=150 16530 IWHTML(4)=150 16531 IWRTF(1)=2000 16532 IWRTF(2)=IWRTF(1)+2000 16533 IWRTF(3)=IWRTF(2)+2000 16534 IFRST=.TRUE. 16535 ILAST=.TRUE. 16536C 16537 CALL DPDTA2(ITITL9,NCTIT9, 16538 1 ITITLE,NCTITL,ITITL2,NCTIT2, 16539 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 16540 1 ITEXT,NCTEXT,AMAT,MAXROW,NUMALP, 16541 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 16542 1 ICAPSW,ICAPTY,IFRST,ILAST, 16543 1 ISUBRO,IBUGA3,IERROR) 16544C 16545C ***************** 16546C ** STEP 90-- ** 16547C ** EXIT ** 16548C ***************** 16549C 16550 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTA7')THEN 16551 WRITE(ICOUT,999) 16552 CALL DPWRST('XXX','WRIT') 16553 WRITE(ICOUT,9011) 16554 9011 FORMAT('***** AT THE END OF DPDTA7--') 16555 CALL DPWRST('XXX','WRIT') 16556 ENDIF 16557C 16558 RETURN 16559 END 16560 SUBROUTINE DPDT77(ALOWLO,AUPPLO,ALOWSC,AUPPSC, 16561 1 ALOWL2,AUPPL2,ALOWS2,AUPPS2, 16562 1 ALPHA,NUMALP, 16563 1 ICAPSW,ICAPTY,NUMDIG, 16564 1 ISUBRO,IBUGA3,IERROR) 16565C 16566C PURPOSE--THIS ROUTINE PRINTS THE CONFIDENCE INTERVAL TABLES 16567C FOR THE LOCATION AND SCALE PARAMETERS FOR 16568C LOCATION/SCALE PROBABILITY DISTRIBUTIONS. 16569C 16570C THIS IS A VARIANT OF DPDTA7 THAT ALLOWS FOR BOTH 16571C NORMAL APPROXIMATION AND FOR LIKELIHOOD RATIO 16572C METHODS FOR COMPUTING CONFIDENCE INTERVALS. 16573C 16574C IF ALOWLO(1) = CPUMIN, THEN SKIP LOCATION PARAMETER 16575C (FOR 1-PARAMETER EXPONENTIAL, ETC.). 16576C 16577C WRITTEN BY--JAMES J. FILLIBEN 16578C STATISTICAL ENGINEERING DIVISION 16579C INFORMATION TECHNOLOGY LABORATORY 16580C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 16581C GAITHERSBURG, MD 20899-8980 16582C PHONE--301-975-2855 16583C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16584C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 16585C LANGUAGE--ANSI FORTRAN (1977) 16586C VERSION NUMBER--2010/06 16587C ORIGINAL VERSION--JUNE 2010. EXTRACTED AS DISTINCT SUBROUTINE 16588C 16589C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16590C 16591 CHARACTER*4 ICAPSW 16592 CHARACTER*4 ICAPTY 16593 CHARACTER*4 ISUBRO 16594 CHARACTER*4 IBUGA3 16595 CHARACTER*4 IERROR 16596C 16597 CHARACTER*4 ISUBN1 16598 CHARACTER*4 ISUBN2 16599C 16600C--------------------------------------------------------------------- 16601C 16602 DIMENSION ALPHA(*) 16603 DIMENSION ALOWSC(*) 16604 DIMENSION AUPPSC(*) 16605 DIMENSION ALOWLO(*) 16606 DIMENSION AUPPLO(*) 16607 DIMENSION ALOWS2(*) 16608 DIMENSION AUPPS2(*) 16609 DIMENSION ALOWL2(*) 16610 DIMENSION AUPPL2(*) 16611C 16612 INCLUDE 'DPCOST.INC' 16613C 16614 PARAMETER (MAXROW=10) 16615 CHARACTER*60 ITITLE 16616 CHARACTER*1 ITITL9 16617 CHARACTER*40 ITEXT(MAXROW) 16618 CHARACTER*4 ALIGN(NUMALP) 16619 CHARACTER*4 VALIGN(NUMALP) 16620 INTEGER NCTEXT(MAXROW) 16621 INTEGER IDIGIT(MAXROW) 16622 INTEGER NTOT(MAXROW) 16623C 16624 PARAMETER(NUMCLI=5) 16625 PARAMETER(MAXLIN=3) 16626 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 16627 INTEGER NCTIT2(MAXLIN,NUMCLI) 16628 INTEGER IWHTML(NUMALP) 16629 INTEGER IWRTF(NUMALP) 16630 REAL AMAT(MAXROW,NUMCLI) 16631 LOGICAL IFRST 16632 LOGICAL ILAST 16633C 16634C--------------------------------------------------------------------- 16635C 16636 INCLUDE 'DPCOP2.INC' 16637C 16638C-----START POINT----------------------------------------------------- 16639C 16640 ISUBN1='DPDT' 16641 ISUBN2='A7 ' 16642 IERROR='NO' 16643C 16644 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DT77')THEN 16645 WRITE(ICOUT,999) 16646 999 FORMAT(1X) 16647 CALL DPWRST('XXX','WRIT') 16648 WRITE(ICOUT,51) 16649 51 FORMAT('**** AT THE BEGINNING OF DPDT77--') 16650 CALL DPWRST('XXX','WRIT') 16651 WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMALP 16652 52 FORMAT('IBUGA3,ISUBRO,NUMALP = ',A4,2X,A4,2X,I5) 16653 CALL DPWRST('XXX','WRIT') 16654 DO56I=1,NUMALP 16655 WRITE(ICOUT,57)I,ALOWLO(I),AUPPLO(I),ALOWSC(I),AUPPSC(I) 16656 57 FORMAT('I,ALOWLO(I),AUPPLO(I),ALOWSC(I),AUPPSC(I) = ', 16657 1 I8,4G15.7) 16658 CALL DPWRST('XXX','WRIT') 16659 WRITE(ICOUT,58)I,ALOWL2(I),AUPPL2(I),ALOWS2(I),AUPPS2(I) 16660 58 FORMAT('I,ALOWL2(I),AUPPL2(I),ALOWS2(I),AUPPS2(I) = ', 16661 1 I8,4G15.7) 16662 CALL DPWRST('XXX','WRIT') 16663 56 CONTINUE 16664 ENDIF 16665C 16666 ITITL9=' ' 16667 NCTIT9=0 16668 ITITLE(1:42)='Confidence Interval for Location Parameter' 16669 NCTITL=42 16670 NUMLIN=3 16671 NUMCOL=5 16672C 16673 ITITL2(1,1)=' ' 16674 ITITL2(2,1)='Confidence' 16675 ITITL2(3,1)='Coefficient' 16676 NCTIT2(1,1)=0 16677 NCTIT2(2,1)=10 16678 NCTIT2(3,1)=11 16679 ITITL2(1,2)='Normal' 16680 ITITL2(2,2)='Lower' 16681 ITITL2(3,2)='Limit' 16682 NCTIT2(1,2)=6 16683 NCTIT2(2,2)=5 16684 NCTIT2(3,2)=5 16685 ITITL2(1,3)='Approximation' 16686 ITITL2(2,3)='Upper' 16687 ITITL2(3,3)='Limit' 16688 NCTIT2(1,3)=13 16689 NCTIT2(2,3)=5 16690 NCTIT2(3,3)=5 16691 ITITL2(1,4)='Likelihood Ratio' 16692 ITITL2(2,4)='Lower' 16693 ITITL2(3,4)='Limit' 16694 NCTIT2(1,4)=16 16695 NCTIT2(2,4)=5 16696 NCTIT2(3,4)=5 16697 ITITL2(1,5)='Approximation' 16698 ITITL2(2,5)='Upper' 16699 ITITL2(3,5)='Limit' 16700 NCTIT2(1,5)=13 16701 NCTIT2(2,5)=5 16702 NCTIT2(3,5)=5 16703C 16704 NMAX=0 16705 DO2521I=1,NUMCOL 16706 VALIGN(I)='b' 16707 ALIGN(I)='r' 16708 NTOT(I)=15 16709 IF(I.EQ.1)NTOT(I)=12 16710 IF(I.EQ.4)NTOT(I)=18 16711 NMAX=NMAX+NTOT(I) 16712 IDIGIT(I)=NUMDIG 16713 2521 CONTINUE 16714 IDIGIT(1)=2 16715 DO2523I=1,NUMALP 16716 NCTEXT(I)=0 16717 AMAT(I,1)=100.0*(1.0 - ALPHA(I)) 16718 AMAT(I,2)=ALOWLO(I) 16719 AMAT(I,3)=AUPPLO(I) 16720 AMAT(I,4)=ALOWL2(I) 16721 AMAT(I,5)=AUPPL2(I) 16722 2523 CONTINUE 16723 IWHTML(1)=150 16724 IWHTML(2)=150 16725 IWHTML(3)=150 16726 IWHTML(4)=150 16727 IWHTML(5)=150 16728 IWHTML(6)=150 16729 IWRTF(1)=2000 16730 IWRTF(2)=IWRTF(1)+2000 16731 IWRTF(3)=IWRTF(2)+2000 16732 IWRTF(4)=IWRTF(3)+2000 16733 IWRTF(5)=IWRTF(4)+2000 16734C 16735 IF(ALOWLO(1).EQ.CPUMIN)GOTO2999 16736C 16737 ITITL9=' ' 16738 NCTIT9=0 16739 IFRST=.TRUE. 16740 ILAST=.TRUE. 16741 CALL DPDTA2(ITITL9,NCTIT9, 16742 1 ITITLE,NCTITL,ITITL2,NCTIT2, 16743 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 16744 1 ITEXT,NCTEXT,AMAT,MAXROW,NUMALP, 16745 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 16746 1 ICAPSW,ICAPTY,IFRST,ILAST, 16747 1 ISUBRO,IBUGA3,IERROR) 16748C 16749 2999 CONTINUE 16750C 16751 IF(ALOWSC(1).EQ.CPUMIN)GOTO3999 16752C 16753 ITITLE(1:39)='Confidence Interval for Scale Parameter' 16754 NCTITL=39 16755 NMAX=0 16756 DO3521I=1,NUMCOL 16757 VALIGN(I)='b' 16758 ALIGN(I)='r' 16759 NTOT(I)=15 16760 IF(I.EQ.1)NTOT(I)=12 16761 IF(I.EQ.4)NTOT(I)=18 16762 NMAX=NMAX+NTOT(I) 16763 IDIGIT(I)=NUMDIG 16764 3521 CONTINUE 16765 IDIGIT(1)=2 16766 DO3523I=1,NUMALP 16767 NCTEXT(I)=0 16768 AMAT(I,1)=100.0*(1.0 - ALPHA(I)) 16769 AMAT(I,2)=ALOWSC(I) 16770 AMAT(I,3)=AUPPSC(I) 16771 AMAT(I,4)=ALOWS2(I) 16772 AMAT(I,5)=AUPPS2(I) 16773 3523 CONTINUE 16774 IWHTML(1)=150 16775 IWHTML(2)=150 16776 IWHTML(3)=150 16777 IWHTML(4)=150 16778 IWHTML(5)=150 16779 IWHTML(6)=150 16780 IWRTF(1)=2000 16781 IWRTF(2)=IWRTF(1)+2000 16782 IWRTF(3)=IWRTF(2)+2000 16783 IWRTF(4)=IWRTF(3)+2000 16784 IWRTF(5)=IWRTF(4)+2000 16785C 16786 IFRST=.TRUE. 16787 ILAST=.TRUE. 16788 CALL DPDTA2(ITITL9,NCTIT9, 16789 1 ITITLE,NCTITL,ITITL2,NCTIT2, 16790 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 16791 1 ITEXT,NCTEXT,AMAT,MAXROW,NUMALP, 16792 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 16793 1 ICAPSW,ICAPTY,IFRST,ILAST, 16794 1 ISUBRO,IBUGA3,IERROR) 16795C 16796 3999 CONTINUE 16797C 16798C ***************** 16799C ** STEP 90-- ** 16800C ** EXIT ** 16801C ***************** 16802C 16803 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DT77')THEN 16804 WRITE(ICOUT,999) 16805 CALL DPWRST('XXX','WRIT') 16806 WRITE(ICOUT,9011) 16807 9011 FORMAT('***** AT THE END OF DPDT77--') 16808 CALL DPWRST('XXX','WRIT') 16809 ENDIF 16810C 16811 RETURN 16812 END 16813 SUBROUTINE DPDTA8(ALOWSC,AUPPSC,ALOWS2,AUPPS2, 16814 1 ALOWSH,AUPPSH,ALOSH2,AUPSH2,ALPHA,NUMALP, 16815 1 ICAPSW,ICAPTY,NUMDIG,ILIKFL, 16816 1 ISUBRO,IBUGA3,IERROR) 16817C 16818C PURPOSE--FOR VARIOUS 2-PARAMETER PROBABILITY DISTRIBUTIONS, 16819C THIS SUBROUTINE PRINTS THE CONFIDENCE INTERVAL 16820C TABLES FOR BOTH THE SCALE AND THE SHAPE PARAMETERS. 16821C FOR SOME DISTRIBUTIONS, WE HAVE ONLY THE NORMAL 16822C APPROXIMATION WHILE FOR OTHER DISTRIBUTIONS WE HAVE 16823C BOTH THE NORMAL APPROXIMATION AND THE LIKELIHOOD 16824C RATIO APPROXIMATION. 16825C 16826C FOR THE LOGNORMAL, SLIGHTY DIFFERENT TABLE 16827C HEADER FOR SCALE PARAMETER. ALSO DIFFERENT 16828C HEADER FOR PARETO. 16829C 16830C MAKE SCALE PARAMETER OPTIONAL (E.G., FOR THE 16831C POWER AND REFLECTED POWER DISTRIBUTIONS). 16832C 16833C FOR THE 2-PARAMETER WEIBULL WHERE WE ARE ESTIMATING 16834C A COMMON SHAPE PARAMETER, 1) DO NOT PRINT THE SCALE 16835C TABLE AND 2) USE A SLIGHTLY DIFFERENT TITLE FOR 16836C THE SHAPE PARAMETER. 16837C 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--2010/02 16848C ORIGINAL VERSION--FEBRUARY 2010. EXTRACTED AS A DISTINCT 16849C SUBROUTINE 16850C UPDATED --APRIL 2010. HEADINGS FOR SCALE PARAMETER 16851C FOR LOGNORMAL CASE 16852C UPDATED --JULY 2010. SLIGHT CORRECTION FOR 16853C LOGNORMAL CASE 16854C UPDATED --JULY 2010. HEADINGS FOR CENSORED LOGNORMAL 16855C UPDATED --APRIL 2014. COMMON SHAPE FOR 2-PARAMETER 16856C WEIBULL 16857C 16858C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16859C 16860 CHARACTER*4 ICAPSW 16861 CHARACTER*4 ICAPTY 16862 CHARACTER*4 ILIKFL 16863C 16864 CHARACTER*4 ISUBRO 16865 CHARACTER*4 IBUGA3 16866 CHARACTER*4 IERROR 16867 CHARACTER*4 ISUBN1 16868 CHARACTER*4 ISUBN2 16869C 16870C--------------------------------------------------------------------- 16871C 16872 DIMENSION ALPHA(*) 16873 DIMENSION ALOWSC(*) 16874 DIMENSION AUPPSC(*) 16875 DIMENSION ALOWS2(*) 16876 DIMENSION AUPPS2(*) 16877 DIMENSION ALOWSH(*) 16878 DIMENSION AUPPSH(*) 16879 DIMENSION ALOSH2(*) 16880 DIMENSION AUPSH2(*) 16881C 16882 INCLUDE 'DPCOST.INC' 16883C 16884 PARAMETER (MAXROW=10) 16885 CHARACTER*60 ITITLE 16886 CHARACTER*1 ITITL9 16887 CHARACTER*40 ITEXT(NUMALP) 16888 INTEGER NCTEXT(MAXROW) 16889C 16890 PARAMETER(NUMCLI=5) 16891 PARAMETER(MAXLIN=3) 16892 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 16893 INTEGER NCTIT2(MAXLIN,NUMCLI) 16894 INTEGER IWHTML(NUMCLI+1) 16895 INTEGER IWRTF(NUMCLI) 16896 INTEGER IDIGIT(NUMCLI) 16897 INTEGER NTOT(NUMCLI) 16898 CHARACTER*4 ALIGN(NUMCLI) 16899 CHARACTER*4 VALIGN(NUMCLI) 16900 REAL AMAT(MAXROW,NUMCLI) 16901 LOGICAL IFRST 16902 LOGICAL ILAST 16903C 16904C--------------------------------------------------------------------- 16905C 16906 INCLUDE 'DPCOP2.INC' 16907C 16908C-----START POINT----------------------------------------------------- 16909C 16910 ISUBN1='DPDT' 16911 ISUBN2='A8 ' 16912 IERROR='NO' 16913C 16914 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTA8')THEN 16915 WRITE(ICOUT,999) 16916 999 FORMAT(1X) 16917 CALL DPWRST('XXX','WRIT') 16918 WRITE(ICOUT,51) 16919 51 FORMAT('**** AT THE BEGINNING OF DPDTA8--') 16920 CALL DPWRST('XXX','WRIT') 16921 WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMALP 16922 52 FORMAT('IBUGA3,ISUBRO,NUMALP = ',A4,2X,A4,2X,I8) 16923 CALL DPWRST('XXX','WRIT') 16924 DO56I=1,NUMALP 16925 WRITE(ICOUT,57)I,ALOWSC(I),AUPPSC(I),ALOWSH(I),AUPPSH(I) 16926 57 FORMAT('I,ALOWSC(I),AUPPSC(I),ALOWSH(I),AUPPSH(I) = ', 16927 1 I8,4G15.7) 16928 CALL DPWRST('XXX','WRIT') 16929 IF(ILIKFL.EQ.'ON')THEN 16930 WRITE(ICOUT,58)I,ALOWS2(I),AUPPS2(I),ALOSH2(I),AUPSH2(I) 16931 58 FORMAT('I,ALOWS2(I),AUPPS2(I),ALOSH2(I),AUPSH2(I) = ', 16932 1 I8,4G15.7) 16933 CALL DPWRST('XXX','WRIT') 16934 ENDIF 16935 56 CONTINUE 16936 ENDIF 16937C 16938 ITITLE(1:39)='Confidence Interval for Scale Parameter' 16939 NCTITL=39 16940 NUMLIN=3 16941 NUMCOL=5 16942 ITITL2(1,1)=' ' 16943 ITITL2(2,1)='Confidence' 16944 ITITL2(3,1)='Coefficient' 16945 NCTIT2(1,1)=0 16946 NCTIT2(2,1)=10 16947 NCTIT2(3,1)=11 16948 IF(ILIKFL.EQ.'LOGN')THEN 16949 ITITL2(1,2)='Scale' 16950 ITITL2(2,2)='Lower' 16951 ITITL2(3,2)='Limit' 16952 NCTIT2(1,2)=5 16953 NCTIT2(2,2)=5 16954 NCTIT2(3,2)=5 16955 ITITL2(1,3)='Parameter' 16956 ITITL2(2,3)='Upper' 16957 ITITL2(3,3)='Limit' 16958 NCTIT2(1,3)=9 16959 NCTIT2(2,3)=5 16960 NCTIT2(3,3)=5 16961 ITITL2(1,4)='MU' 16962 ITITL2(2,4)='Lower' 16963 ITITL2(3,4)='Limit' 16964 NCTIT2(1,4)=2 16965 NCTIT2(2,4)=5 16966 NCTIT2(3,4)=5 16967 ITITL2(1,5)='Parameter' 16968 ITITL2(2,5)='Upper' 16969 ITITL2(3,5)='Limit' 16970 NCTIT2(1,5)=9 16971 NCTIT2(2,5)=5 16972 NCTIT2(3,5)=5 16973 ELSE 16974 ITITL2(1,2)='Normal' 16975 ITITL2(2,2)='Lower' 16976 ITITL2(3,2)='Limit' 16977 NCTIT2(1,2)=6 16978 NCTIT2(2,2)=5 16979 NCTIT2(3,2)=5 16980 ITITL2(1,3)='Approximation' 16981 ITITL2(2,3)='Upper' 16982 ITITL2(3,3)='Limit' 16983 NCTIT2(1,3)=13 16984 NCTIT2(2,3)=5 16985 NCTIT2(3,3)=5 16986 ITITL2(1,4)='Likelihood Ratio' 16987 ITITL2(2,4)='Lower' 16988 ITITL2(3,4)='Limit' 16989 NCTIT2(1,4)=16 16990 NCTIT2(2,4)=5 16991 NCTIT2(3,4)=5 16992 ITITL2(1,5)='Approximation' 16993 ITITL2(2,5)='Upper' 16994 ITITL2(3,5)='Limit' 16995 NCTIT2(1,5)=13 16996 NCTIT2(2,5)=5 16997 NCTIT2(3,5)=5 16998 ENDIF 16999C 17000 IF(ILIKFL.EQ.'OFF')NUMCOL=3 17001 IF(ILIKFL.EQ.'WCSH')NUMCOL=3 17002C 17003 NMAX=0 17004 DO2521I=1,NUMCOL 17005 VALIGN(I)='b' 17006 ALIGN(I)='r' 17007 NTOT(I)=15 17008 IF(I.EQ.1)NTOT(I)=12 17009 IF(I.EQ.4)NTOT(I)=18 17010 NMAX=NMAX+NTOT(I) 17011 IDIGIT(I)=NUMDIG 17012 2521 CONTINUE 17013 IDIGIT(1)=2 17014 DO2523I=1,NUMALP 17015 NCTEXT(I)=0 17016 AMAT(I,1)=100.0*(1.0 - ALPHA(I)) 17017 AMAT(I,2)=ALOWSC(I) 17018 AMAT(I,3)=AUPPSC(I) 17019 AMAT(I,4)=ALOWS2(I) 17020 AMAT(I,5)=AUPPS2(I) 17021 2523 CONTINUE 17022 IWHTML(1)=150 17023 IWHTML(2)=150 17024 IWHTML(3)=150 17025 IWHTML(4)=150 17026 IWHTML(5)=150 17027 IWHTML(6)=150 17028 IWRTF(1)=2000 17029 IWRTF(2)=IWRTF(1)+2000 17030 IWRTF(3)=IWRTF(2)+2000 17031 IWRTF(4)=IWRTF(3)+2000 17032 IWRTF(5)=IWRTF(4)+2000 17033C 17034 ITITL9=' ' 17035 NCTIT9=0 17036C 17037 IF(ILIKFL.EQ.'WCSH')GOTO2599 17038C 17039 IFRST=.TRUE. 17040 ILAST=.TRUE. 17041 IF(ALOWSC(1).NE.CPUMIN)THEN 17042 CALL DPDTA2(ITITLE,NCTITL, 17043 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 17044 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 17045 1 ITEXT,NCTEXT,AMAT,MAXROW,NUMALP, 17046 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 17047 1 ICAPSW,ICAPTY,IFRST,ILAST, 17048 1 ISUBRO,IBUGA3,IERROR) 17049 ENDIF 17050C 17051 2599 CONTINUE 17052C 17053 IF(ILIKFL.EQ.'LOGN')NUMCOL=3 17054 IF(ILIKFL.EQ.'WCSH')THEN 17055 ITITLE(1:46)='Confidence Interval for Common Shape Parameter' 17056 NCTITL=46 17057 NUMCOL=3 17058 ELSE 17059 ITITLE(1:39)='Confidence Interval for Shape Parameter' 17060 NCTITL=39 17061 ENDIF 17062C 17063C ADJUST HEADERS FOR LOGNORMAL 17064C 17065 IF(ILIKFL.EQ.'LOGN')THEN 17066 NUMLIN=2 17067 NUMCOL=3 17068 ITITL2(1,1)='Confidence' 17069 ITITL2(2,1)='Coefficient' 17070 NCTIT2(1,1)=10 17071 NCTIT2(2,1)=11 17072 ITITL2(1,2)='Lower' 17073 ITITL2(1,2)='Limit' 17074 NCTIT2(1,2)=5 17075 NCTIT2(2,2)=5 17076 ITITL2(1,3)='Upper' 17077 ITITL2(2,3)='Limit' 17078 NCTIT2(1,3)=5 17079 NCTIT2(2,3)=5 17080 ELSEIF(ILIKFL.EQ.'WCSH')THEN 17081 NUMLIN=2 17082 NUMCOL=3 17083 ITITL2(1,1)='Confidence' 17084 ITITL2(2,1)='Coefficient' 17085 NCTIT2(1,1)=10 17086 NCTIT2(2,1)=11 17087 ITITL2(1,2)='Lower' 17088 ITITL2(2,2)='Limit' 17089 NCTIT2(1,2)=5 17090 NCTIT2(2,2)=5 17091 ITITL2(1,3)='Upper' 17092 ITITL2(2,3)='Limit' 17093 NCTIT2(1,3)=5 17094 NCTIT2(2,3)=5 17095 ENDIF 17096C 17097 DO2533I=1,NUMALP 17098 NCTEXT(I)=0 17099 AMAT(I,1)=100.0*(1.0 - ALPHA(I)) 17100 AMAT(I,2)=ALOWSH(I) 17101 AMAT(I,3)=AUPPSH(I) 17102 AMAT(I,4)=ALOSH2(I) 17103 AMAT(I,5)=AUPSH2(I) 17104 2533 CONTINUE 17105 IFRST=.TRUE. 17106 ILAST=.TRUE. 17107C 17108 CALL DPDTA2(ITITLE,NCTITL, 17109 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 17110 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 17111 1 ITEXT,NCTEXT,AMAT,MAXROW,NUMALP, 17112 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 17113 1 ICAPSW,ICAPTY,IFRST,ILAST, 17114 1 ISUBRO,IBUGA3,IERROR) 17115C 17116C ***************** 17117C ** STEP 90-- ** 17118C ** EXIT ** 17119C ***************** 17120C 17121 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTA8')THEN 17122 WRITE(ICOUT,999) 17123 CALL DPWRST('XXX','WRIT') 17124 WRITE(ICOUT,9011) 17125 9011 FORMAT('***** AT THE END OF DPDTA8--') 17126 CALL DPWRST('XXX','WRIT') 17127 ENDIF 17128C 17129 RETURN 17130 END 17131 SUBROUTINE DPDT8A(ALOWLO,AUPPLO,ALOWSC,AUPPSC, 17132 1 ALO1SH,AUP1SH,AL1SH2,AU1SH2, 17133 1 ALO2SH,AUP2SH,AL2SH2,AU2SH2, 17134 1 ALPHA,NUMALP, 17135 1 ICAPSW,ICAPTY,NUMDIG, 17136 1 ILOCFL,ISCAFL,ILIKFL, 17137 1 ISHAP1,NCSHA1,ISHAP2,NCSHA2, 17138 1 ISUBRO,IBUGA3,IERROR) 17139C 17140C PURPOSE--FOR TWO SHAPE PARAMETER DISTRIBUTIONS, PRINT 17141C CONFIDENCE INTERVALS FOR: 17142C 17143C 1) LOCATION OR LOWER LIMIT PARAMETER 17144C 2) SCALE OR UPPER LIMIT PARAMETER 17145C 3) SHAPE ONE PARAMETER 17146C 4) SHAPE TWO PARAMETER 17147C 17148C THE LOCATION/SCALE PARAMETERS ARE OPTIONAL. 17149C THE SHAPE PARAMETERS CAN OPTIONALLY PRINT 17150C NORMAL APPROXIMATIONS AND LIKELIHOOD RATIO 17151C APPROXIMATIONS. 17152C 17153C WRITTEN BY--ALAN HECKERT 17154C STATISTICAL ENGINEERING DIVISION 17155C INFORMATION TECHNOLOGY LABORATORY 17156C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 17157C GAITHERSBURG, MD 20899-8980 17158C PHONE--301-975-2855 17159C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 17160C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 17161C LANGUAGE--ANSI FORTRAN (1977) 17162C VERSION NUMBER--2010/07 17163C ORIGINAL VERSION--JULY 2010. EXTRACTED AS A DISTINCT 17164C SUBROUTINE 17165C 17166C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 17167C 17168 CHARACTER*4 ICAPSW 17169 CHARACTER*4 ICAPTY 17170 CHARACTER*4 ILIKFL 17171 CHARACTER*4 ILOCFL 17172 CHARACTER*4 ISCAFL 17173 CHARACTER*8 ISHAP1 17174 CHARACTER*8 ISHAP2 17175C 17176 CHARACTER*4 ISUBRO 17177 CHARACTER*4 IBUGA3 17178 CHARACTER*4 IERROR 17179 CHARACTER*4 ISUBN1 17180 CHARACTER*4 ISUBN2 17181C 17182C--------------------------------------------------------------------- 17183C 17184 DIMENSION ALPHA(*) 17185 DIMENSION ALOWLO(*) 17186 DIMENSION AUPPLO(*) 17187 DIMENSION ALOWSC(*) 17188 DIMENSION AUPPSC(*) 17189 DIMENSION ALO1SH(*) 17190 DIMENSION AUP1SH(*) 17191 DIMENSION AL1SH2(*) 17192 DIMENSION AU1SH2(*) 17193 DIMENSION ALO2SH(*) 17194 DIMENSION AUP2SH(*) 17195 DIMENSION AL2SH2(*) 17196 DIMENSION AU2SH2(*) 17197C 17198 INCLUDE 'DPCOST.INC' 17199C 17200 PARAMETER (MAXROW=10) 17201 CHARACTER*60 ITITLE 17202 CHARACTER*1 ITITL9 17203 CHARACTER*40 ITEXT(NUMALP) 17204 CHARACTER*4 ALIGN(NUMALP) 17205 CHARACTER*4 VALIGN(NUMALP) 17206 INTEGER NCTEXT(MAXROW) 17207 INTEGER IDIGIT(MAXROW) 17208 INTEGER NTOT(MAXROW) 17209C 17210 PARAMETER(NUMCLI=5) 17211 PARAMETER(MAXLIN=3) 17212 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 17213 INTEGER NCTIT2(MAXLIN,NUMCLI) 17214 INTEGER IWHTML(NUMALP) 17215 INTEGER IWRTF(NUMALP) 17216 REAL AMAT(MAXROW,NUMCLI) 17217 LOGICAL IFRST 17218 LOGICAL ILAST 17219C 17220C--------------------------------------------------------------------- 17221C 17222 INCLUDE 'DPCOP2.INC' 17223C 17224C-----START POINT----------------------------------------------------- 17225C 17226 ISUBN1='DPDT' 17227 ISUBN2='8A ' 17228 IERROR='NO' 17229C 17230 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DT8A')THEN 17231 WRITE(ICOUT,999) 17232 999 FORMAT(1X) 17233 CALL DPWRST('XXX','WRIT') 17234 WRITE(ICOUT,51) 17235 51 FORMAT('**** AT THE BEGINNING OF DPDT8A--') 17236 CALL DPWRST('XXX','WRIT') 17237 WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMALP 17238 52 FORMAT('IBUGA3,ISUBRO,NUMALP = ',A4,2X,A4,2X,I8) 17239 CALL DPWRST('XXX','WRIT') 17240 WRITE(ICOUT,53)ILIKFL,ILOCFL,ISCAFL,ISHAP1,ISHAP2 17241 53 FORMAT('ILIKFL,ILOCFL,ISCAFL,ISHAP1,ISHAP2 = ',3(A4,2X), 17242 1 A8,2X,A8) 17243 CALL DPWRST('XXX','WRIT') 17244 DO56I=1,NUMALP 17245 WRITE(ICOUT,57)I,ALOWLO(I),AUPPLO(I),ALOWSC(I),AUPPSC(I) 17246 57 FORMAT('I,ALOWLO(I),AUPPLO(I),ALOWSC(I),AUPPSC(I) = ', 17247 1 I8,4G15.7) 17248 CALL DPWRST('XXX','WRIT') 17249 WRITE(ICOUT,58)I,ALO1SH(I),AUP1SH(I),AL1SH2(I),AU1SH2(I) 17250 58 FORMAT('I,ALO1SH(I),AU1PSH(I),AL1SH2(I),AU1SH2(I) = ', 17251 1 I8,4G15.7) 17252 CALL DPWRST('XXX','WRIT') 17253 WRITE(ICOUT,59)I,ALO2SH(I),AUP2SH(I),AL2SH2(I),AU2SH2(I) 17254 59 FORMAT('I,ALO2SH(I),AU2PSH(I),AL2SH2(I),AU2SH2(I) = ', 17255 1 I8,4G15.7) 17256 56 CONTINUE 17257 ENDIF 17258C 17259 ITITL9=' ' 17260 NCTIT9=0 17261C 17262 IF(ILOCFL.NE.'OFF')THEN 17263 ITITLE(1:42)='Confidence Interval for Location Parameter' 17264 NCTITL=42 17265 NUMLIN=3 17266 NUMCOL=3 17267 ITITL2(1,1)=' ' 17268 ITITL2(2,1)='Confidence' 17269 ITITL2(3,1)='Coefficient' 17270 NCTIT2(1,1)=0 17271 NCTIT2(2,1)=10 17272 NCTIT2(3,1)=11 17273 ITITL2(1,2)='Normal' 17274 IF(ILOCFL.NE.'ON')ITITL2(1,2)=' ' 17275 ITITL2(2,2)='Lower' 17276 ITITL2(3,2)='Limit' 17277 NCTIT2(1,2)=6 17278 IF(ILOCFL.NE.'ON')NCTIT2(1,2)=0 17279 NCTIT2(2,2)=5 17280 NCTIT2(3,2)=5 17281 ITITL2(1,3)='Approximation' 17282 IF(ILOCFL.NE.'ON')ITITL2(1,3)=' ' 17283 ITITL2(2,3)='Upper' 17284 ITITL2(3,3)='Limit' 17285 NCTIT2(1,3)=13 17286 IF(ILOCFL.NE.'ON')NCTIT2(1,3)=0 17287 NCTIT2(2,3)=5 17288 NCTIT2(3,3)=5 17289C 17290 NMAX=0 17291 DO1521I=1,NUMCOL 17292 VALIGN(I)='b' 17293 ALIGN(I)='r' 17294 NTOT(I)=15 17295 IF(I.EQ.1)NTOT(I)=12 17296 NMAX=NMAX+NTOT(I) 17297 IDIGIT(I)=NUMDIG 17298 1521 CONTINUE 17299 IDIGIT(1)=2 17300 DO1523I=1,NUMALP 17301 NCTEXT(I)=0 17302 AMAT(I,1)=100.0*(1.0 - ALPHA(I)) 17303 AMAT(I,2)=ALOWLO(I) 17304 AMAT(I,3)=AUPPLO(I) 17305 1523 CONTINUE 17306 IWHTML(1)=150 17307 IWHTML(2)=150 17308 IWHTML(3)=150 17309 IWHTML(4)=150 17310 IWRTF(1)=2000 17311 IWRTF(2)=IWRTF(1)+2000 17312 IWRTF(3)=IWRTF(2)+2000 17313C 17314 IFRST=.TRUE. 17315 ILAST=.TRUE. 17316 CALL DPDTA2(ITITLE,NCTITL, 17317 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 17318 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 17319 1 ITEXT,NCTEXT,AMAT,MAXROW,NUMALP, 17320 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 17321 1 ICAPSW,ICAPTY,IFRST,ILAST, 17322 1 ISUBRO,IBUGA3,IERROR) 17323 ENDIF 17324C 17325 IF(ISCAFL.NE.'OFF')THEN 17326 ITITLE(1:39)='Confidence Interval for Scale Parameter' 17327 NCTITL=39 17328 NUMLIN=3 17329 NUMCOL=3 17330 ITITL2(1,1)=' ' 17331 ITITL2(2,1)='Confidence' 17332 ITITL2(3,1)='Coefficient' 17333 NCTIT2(1,1)=0 17334 NCTIT2(2,1)=10 17335 NCTIT2(3,1)=11 17336 ITITL2(1,2)='Normal' 17337 IF(ISCAFL.NE.'ON')ITITL2(1,2)=' ' 17338 ITITL2(2,2)='Lower' 17339 ITITL2(3,2)='Limit' 17340 NCTIT2(1,2)=6 17341 IF(ISCAFL.NE.'ON')NCTIT2(1,2)=0 17342 NCTIT2(2,2)=5 17343 NCTIT2(3,2)=5 17344 ITITL2(1,3)='Approximation' 17345 IF(ISCAFL.NE.'ON')ITITL2(1,3)=' ' 17346 ITITL2(2,3)='Upper' 17347 ITITL2(3,3)='Limit' 17348 NCTIT2(1,3)=13 17349 IF(ISCAFL.NE.'ON')NCTIT2(1,3)=0 17350 NCTIT2(2,3)=5 17351 NCTIT2(3,3)=5 17352C 17353 NMAX=0 17354 DO2521I=1,NUMCOL 17355 VALIGN(I)='b' 17356 ALIGN(I)='r' 17357 NTOT(I)=15 17358 IF(I.EQ.1)NTOT(I)=12 17359 NMAX=NMAX+NTOT(I) 17360 IDIGIT(I)=NUMDIG 17361 2521 CONTINUE 17362 IDIGIT(1)=2 17363 DO2523I=1,NUMALP 17364 NCTEXT(I)=0 17365 AMAT(I,1)=100.0*(1.0 - ALPHA(I)) 17366 AMAT(I,2)=ALOWSC(I) 17367 AMAT(I,3)=AUPPSC(I) 17368 2523 CONTINUE 17369 IWHTML(1)=150 17370 IWHTML(2)=150 17371 IWHTML(3)=150 17372 IWHTML(4)=150 17373 IWRTF(1)=2000 17374 IWRTF(2)=IWRTF(1)+2000 17375 IWRTF(3)=IWRTF(2)+2000 17376C 17377 IFRST=.TRUE. 17378 ILAST=.TRUE. 17379 CALL DPDTA2(ITITLE,NCTITL, 17380 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 17381 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 17382 1 ITEXT,NCTEXT,AMAT,MAXROW,NUMALP, 17383 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 17384 1 ICAPSW,ICAPTY,IFRST,ILAST, 17385 1 ISUBRO,IBUGA3,IERROR) 17386 ENDIF 17387C 17388 ITITLE(1:40)='Confidence Interval for Shape Parameter ' 17389 ITITLE(41:41+NCSHA1-1)=ISHAP1(1:NCSHA1) 17390 NCTITL=41+NCSHA1-1 17391 NUMLIN=3 17392 NUMCOL=5 17393 IF(ILIKFL.NE.'ON')NUMCOL=3 17394C 17395C IF ILIKFL SET TO 'EXAC', THEN THIS IMPLIES WE HAVE 17396C AN "EXACT" (AS OPPOSSED TO A NORMAL APPROXIMATION). 17397C IN THIS CASE, WE ONLY USE A 2-LINE HEADER. 17398C 17399 ICNT=0 17400 IF(ILIKFL.NE.'EXAC')THEN 17401 ICNT=ICNT+1 17402 ITITL2(ICNT,1)=' ' 17403 NCTIT2(ICNT,1)=0 17404 ITITL2(ICNT,2)='Normal' 17405 NCTIT2(ICNT,2)=6 17406 ITITL2(ICNT,3)='Approximation' 17407 NCTIT2(ICNT,3)=13 17408 ITITL2(ICNT,4)='Likelihood Ratio' 17409 NCTIT2(ICNT,4)=16 17410 ITITL2(ICNT,5)='Approximation' 17411 NCTIT2(ICNT,5)=13 17412 ELSE 17413 NUMLIN=2 17414 ENDIF 17415 ICNT=ICNT+1 17416 ITITL2(ICNT,1)='Confidence' 17417 NCTIT2(ICNT,1)=10 17418 ITITL2(ICNT,2)='Lower' 17419 NCTIT2(ICNT,2)=5 17420 ITITL2(ICNT,3)='Upper' 17421 NCTIT2(ICNT,3)=5 17422 ITITL2(ICNT,4)='Lower' 17423 NCTIT2(ICNT,4)=5 17424 ITITL2(ICNT,5)='Upper' 17425 NCTIT2(ICNT,5)=5 17426 ICNT=ICNT+1 17427 ITITL2(ICNT,1)='Coefficient' 17428 NCTIT2(ICNT,1)=11 17429 ITITL2(ICNT,2)='Limit' 17430 NCTIT2(ICNT,2)=5 17431 ITITL2(ICNT,3)='Limit' 17432 NCTIT2(ICNT,3)=5 17433 ITITL2(ICNT,4)='Limit' 17434 NCTIT2(ICNT,4)=5 17435 ITITL2(ICNT,5)='Limit' 17436 NCTIT2(ICNT,5)=5 17437C 17438 NMAX=0 17439 DO2621I=1,NUMCOL 17440 VALIGN(I)='b' 17441 ALIGN(I)='r' 17442 NTOT(I)=15 17443 IF(I.EQ.1)NTOT(I)=12 17444 NMAX=NMAX+NTOT(I) 17445 IDIGIT(I)=NUMDIG 17446 2621 CONTINUE 17447 IDIGIT(1)=2 17448C 17449 DO2533I=1,NUMALP 17450 NCTEXT(I)=0 17451 AMAT(I,1)=100.0*(1.0 - ALPHA(I)) 17452 AMAT(I,2)=ALO1SH(I) 17453 AMAT(I,3)=AUP1SH(I) 17454 IF(ILIKFL.EQ.'ON')THEN 17455 AMAT(I,4)=AL1SH2(I) 17456 AMAT(I,5)=AU1SH2(I) 17457 ENDIF 17458 2533 CONTINUE 17459 IWHTML(1)=150 17460 IWHTML(2)=150 17461 IWHTML(3)=150 17462 IWHTML(4)=150 17463 IWHTML(5)=150 17464 IWHTML(6)=150 17465 IWRTF(1)=2000 17466 IWRTF(2)=IWRTF(1)+2000 17467 IWRTF(3)=IWRTF(2)+2000 17468 IWRTF(4)=IWRTF(3)+2000 17469 IWRTF(5)=IWRTF(4)+2000 17470C 17471 IFRST=.TRUE. 17472 ILAST=.TRUE. 17473C 17474 CALL DPDTA2(ITITLE,NCTITL, 17475 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 17476 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 17477 1 ITEXT,NCTEXT,AMAT,MAXROW,NUMALP, 17478 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 17479 1 ICAPSW,ICAPTY,IFRST,ILAST, 17480 1 ISUBRO,IBUGA3,IERROR) 17481C 17482 ITITLE(1:40)='Confidence Interval for Shape Parameter ' 17483 ITITLE(41:41+NCSHA2-1)=ISHAP2(1:NCSHA2) 17484 NCTITL=41+NCSHA2-1 17485C 17486 DO2543I=1,NUMALP 17487 NCTEXT(I)=0 17488 AMAT(I,1)=100.0*(1.0 - ALPHA(I)) 17489 AMAT(I,2)=ALO2SH(I) 17490 AMAT(I,3)=AUP2SH(I) 17491 IF(ILIKFL.EQ.'ON')THEN 17492 AMAT(I,4)=AL2SH2(I) 17493 AMAT(I,5)=AU2SH2(I) 17494 ENDIF 17495 2543 CONTINUE 17496 IFRST=.TRUE. 17497 ILAST=.TRUE. 17498C 17499 CALL DPDTA2(ITITLE,NCTITL, 17500 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 17501 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 17502 1 ITEXT,NCTEXT,AMAT,MAXROW,NUMALP, 17503 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 17504 1 ICAPSW,ICAPTY,IFRST,ILAST, 17505 1 ISUBRO,IBUGA3,IERROR) 17506C 17507C ***************** 17508C ** STEP 90-- ** 17509C ** EXIT ** 17510C ***************** 17511C 17512 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DT8A')THEN 17513 WRITE(ICOUT,999) 17514 CALL DPWRST('XXX','WRIT') 17515 WRITE(ICOUT,9011) 17516 9011 FORMAT('***** AT THE END OF DPDT88--') 17517 CALL DPWRST('XXX','WRIT') 17518 ENDIF 17519C 17520 RETURN 17521 END 17522 SUBROUTINE DPDT8B(ALOWPA,AUPPPA,ALPHA,NUMALP, 17523 1 ICAPSW,ICAPTY,NUMDIG, 17524 1 ISUBRO,IBUGA3,IERROR) 17525C 17526C PURPOSE--PRINT A PERCENTILE CONFIDENCE LIMIT BASED ON THE 17527C BOOTSTRAP SAMPLES. THIS HANDLES THE CASE WHEN WE 17528C ARE A BOOTSTRAPPING A STATISTIC. A DIFFERENT ROUTINE 17529C HANDLES THE CASE WHEN WE ARE BOOTSTRAPPING A 17530C DISTRIBUTIONAL MODEL. 17531C WRITTEN BY--ALAN HECKERT 17532C STATISTICAL ENGINEERING DIVISION 17533C INFORMATION TECHNOLOGY LABORATORY 17534C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 17535C GAITHERSBURG, MD 20899-8980 17536C PHONE--301-975-2899 17537C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 17538C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 17539C LANGUAGE--ANSI FORTRAN (1977) 17540C VERSION NUMBER--2010/07 17541C ORIGINAL VERSION--JULY 2010. 17542C 17543C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 17544C 17545 CHARACTER*4 ICAPSW 17546 CHARACTER*4 ICAPTY 17547C 17548 CHARACTER*4 ISUBRO 17549 CHARACTER*4 IBUGA3 17550 CHARACTER*4 IERROR 17551 CHARACTER*4 ISUBN1 17552 CHARACTER*4 ISUBN2 17553C 17554C--------------------------------------------------------------------- 17555C 17556 DIMENSION ALPHA(*) 17557 DIMENSION ALOWPA(*) 17558 DIMENSION AUPPPA(*) 17559C 17560 INCLUDE 'DPCOST.INC' 17561C 17562 PARAMETER (MAXROW=10) 17563 CHARACTER*50 ITITLE 17564 CHARACTER*1 ITITL9 17565 CHARACTER*40 ITEXT(MAXROW) 17566 INTEGER NCTEXT(MAXROW) 17567C 17568 PARAMETER(NUMCLI=3) 17569 PARAMETER(MAXLIN=2) 17570 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 17571 INTEGER NCTIT2(MAXLIN,NUMCLI) 17572 INTEGER IWHTML(NUMCLI+1) 17573 INTEGER IWRTF(NUMCLI) 17574 INTEGER IDIGIT(NUMCLI) 17575 INTEGER NTOT(NUMCLI) 17576 CHARACTER*4 ALIGN(NUMCLI) 17577 CHARACTER*4 VALIGN(NUMCLI) 17578 REAL AMAT(MAXROW,NUMCLI) 17579 LOGICAL IFRST 17580 LOGICAL ILAST 17581C 17582C--------------------------------------------------------------------- 17583C 17584 INCLUDE 'DPCOP2.INC' 17585C 17586C-----START POINT----------------------------------------------------- 17587C 17588 ISUBN1='DPDT' 17589 ISUBN2='8B ' 17590 IERROR='NO' 17591C 17592 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DT8B')THEN 17593 WRITE(ICOUT,999) 17594 999 FORMAT(1X) 17595 CALL DPWRST('XXX','WRIT') 17596 WRITE(ICOUT,51) 17597 51 FORMAT('**** AT THE BEGINNING OF DPDT8B--') 17598 CALL DPWRST('XXX','WRIT') 17599 WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMALP 17600 52 FORMAT('IBUGA3,ISUBRO,NUMALP = ',A4,2X,A4,2X,I8) 17601 CALL DPWRST('XXX','WRIT') 17602 DO56I=1,NUMALP 17603 WRITE(ICOUT,57)I,ALOWPA(I),AUPPPA(I) 17604 57 FORMAT('I,ALOWSC(I),AUPPSC(I) = ',I8,2G15.7) 17605 CALL DPWRST('XXX','WRIT') 17606 56 CONTINUE 17607 ENDIF 17608C 17609 ITITLE(1:44)='Percentile Confidence Interval for Statistic' 17610 NCTITL=44 17611 NUMLIN=2 17612 NUMCOL=3 17613 ITITL2(1,1)='Confidence' 17614 ITITL2(2,1)='Coefficient' 17615 NCTIT2(1,1)=10 17616 NCTIT2(2,1)=11 17617 ITITL2(1,2)='Lower' 17618 ITITL2(2,2)='Limit' 17619 NCTIT2(1,2)=5 17620 NCTIT2(2,2)=5 17621 ITITL2(1,3)='Upper' 17622 ITITL2(2,3)='Limit' 17623 NCTIT2(1,3)=5 17624 NCTIT2(2,3)=5 17625C 17626 NMAX=0 17627 DO2521I=1,NUMCLI 17628 VALIGN(I)='b' 17629 ALIGN(I)='r' 17630 NTOT(I)=15 17631 IF(I.EQ.1)NTOT(1)=12 17632 NMAX=NMAX+NTOT(I) 17633 IDIGIT(I)=NUMDIG 17634 2521 CONTINUE 17635 IDIGIT(1)=2 17636 DO2523I=1,NUMALP 17637 NCTEXT(I)=0 17638 AMAT(I,1)=100.0*(1.0 - ALPHA(I)) 17639 AMAT(I,2)=ALOWPA(I) 17640 AMAT(I,3)=AUPPPA(I) 17641 2523 CONTINUE 17642 IWHTML(1)=150 17643 IWHTML(2)=150 17644 IWHTML(3)=150 17645 IWHTML(4)=150 17646 IWRTF(1)=2000 17647 IWRTF(2)=IWRTF(1)+2000 17648 IWRTF(3)=IWRTF(2)+2000 17649C 17650 ITITL9=' ' 17651 NCTIT9=0 17652 IFRST=.TRUE. 17653 ILAST=.TRUE. 17654 CALL DPDTA2(ITITLE,NCTITL, 17655 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 17656 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 17657 1 ITEXT,NCTEXT,AMAT,MAXROW,NUMALP, 17658 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 17659 1 ICAPSW,ICAPTY,IFRST,ILAST, 17660 1 ISUBRO,IBUGA3,IERROR) 17661C 17662C ***************** 17663C ** STEP 90-- ** 17664C ** EXIT ** 17665C ***************** 17666C 17667 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DT8B')THEN 17668 WRITE(ICOUT,999) 17669 CALL DPWRST('XXX','WRIT') 17670 WRITE(ICOUT,9011) 17671 9011 FORMAT('***** AT THE END OF DPDT8B--') 17672 CALL DPWRST('XXX','WRIT') 17673 ENDIF 17674C 17675 RETURN 17676 END 17677 SUBROUTINE DPDT8C(ALOWPA,AUPPPA,ALPHA,NUMALP, 17678 1 ICAPSW,ICAPTY,NUMDIG,IPAR,NCPAR, 17679 1 ISUBRO,IBUGA3,IERROR) 17680C 17681C PURPOSE--PRINT A PERCENTILE CONFIDENCE LIMIT BASED ON THE 17682C BOOTSTRAP SAMPLES. THIS HANDLES THE CASE WHEN WE 17683C ARE A BOOTSTRAPPING A DISTRIBUTIONAL MODEL. A DIFFERENT 17684C ROUTINE HANDLES THE CASE WHEN WE ARE BOOTSTRAPPING A 17685C STATISTIC. 17686C WRITTEN BY--ALAN HECKERT 17687C STATISTICAL ENGINEERING DIVISION 17688C INFORMATION TECHNOLOGY LABORATORY 17689C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 17690C GAITHERSBURG, MD 20899-8980 17691C PHONE--301-975-2899 17692C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 17693C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 17694C LANGUAGE--ANSI FORTRAN (1977) 17695C VERSION NUMBER--2010/07 17696C ORIGINAL VERSION--JULY 2010. 17697C 17698C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 17699C 17700 CHARACTER*4 ICAPSW 17701 CHARACTER*4 ICAPTY 17702 CHARACTER*(*) IPAR 17703C 17704 CHARACTER*4 ISUBRO 17705 CHARACTER*4 IBUGA3 17706 CHARACTER*4 IERROR 17707 CHARACTER*4 ISUBN1 17708 CHARACTER*4 ISUBN2 17709C 17710C--------------------------------------------------------------------- 17711C 17712 DIMENSION ALPHA(*) 17713 DIMENSION ALOWPA(*) 17714 DIMENSION AUPPPA(*) 17715C 17716 INCLUDE 'DPCOST.INC' 17717C 17718 PARAMETER (MAXROW=10) 17719 CHARACTER*60 ITITLE 17720 CHARACTER*1 ITITL9 17721 CHARACTER*40 ITEXT(MAXROW) 17722 INTEGER NCTEXT(MAXROW) 17723C 17724 PARAMETER(NUMCLI=3) 17725 PARAMETER(MAXLIN=2) 17726 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 17727 INTEGER NCTIT2(MAXLIN,NUMCLI) 17728 INTEGER IWHTML(NUMCLI+1) 17729 INTEGER IWRTF(NUMCLI) 17730 INTEGER IDIGIT(NUMCLI) 17731 INTEGER NTOT(NUMCLI) 17732 CHARACTER*4 ALIGN(NUMCLI) 17733 CHARACTER*4 VALIGN(NUMCLI) 17734 REAL AMAT(MAXROW,NUMCLI) 17735 LOGICAL IFRST 17736 LOGICAL ILAST 17737C 17738C--------------------------------------------------------------------- 17739C 17740 INCLUDE 'DPCOP2.INC' 17741C 17742C-----START POINT----------------------------------------------------- 17743C 17744 ISUBN1='DPDT' 17745 ISUBN2='8C ' 17746 IERROR='NO' 17747C 17748 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DT8C')THEN 17749 WRITE(ICOUT,999) 17750 999 FORMAT(1X) 17751 CALL DPWRST('XXX','WRIT') 17752 WRITE(ICOUT,51) 17753 51 FORMAT('**** AT THE BEGINNING OF DPDT8C--') 17754 CALL DPWRST('XXX','WRIT') 17755 WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMALP 17756 52 FORMAT('IBUGA3,ISUBRO,NUMALP = ',A4,2X,A4,2X,I8) 17757 CALL DPWRST('XXX','WRIT') 17758 DO56I=1,NUMALP 17759 WRITE(ICOUT,57)I,ALOWPA(I),AUPPPA(I) 17760 57 FORMAT('I,ALOWSC(I),AUPPSC(I) = ',I8,2G15.7) 17761 CALL DPWRST('XXX','WRIT') 17762 56 CONTINUE 17763 ENDIF 17764C 17765 ITITLE(1:35)='Percentile Confidence Interval for ' 17766 NSTRT=36 17767 NCTITL=NSTRT+NCPAR-1 17768 ITITLE(NSTRT:NCTITL)=IPAR(1:NCPAR) 17769C 17770 NUMLIN=2 17771 NUMCOL=3 17772 ITITL2(1,1)='Confidence' 17773 ITITL2(2,1)='Coefficient' 17774 NCTIT2(1,1)=10 17775 NCTIT2(2,1)=11 17776 ITITL2(1,2)='Lower' 17777 ITITL2(2,2)='Limit' 17778 NCTIT2(1,2)=5 17779 NCTIT2(2,2)=5 17780 ITITL2(1,3)='Upper' 17781 ITITL2(2,3)='Limit' 17782 NCTIT2(1,3)=5 17783 NCTIT2(2,3)=5 17784C 17785 NMAX=0 17786 DO2521I=1,NUMCLI 17787 VALIGN(I)='b' 17788 ALIGN(I)='r' 17789 NTOT(I)=15 17790 IF(I.EQ.1)NTOT(I)=12 17791 NMAX=NMAX+NTOT(I) 17792 IDIGIT(I)=NUMDIG 17793 2521 CONTINUE 17794 IDIGIT(1)=2 17795 DO2523I=1,NUMALP 17796 NCTEXT(I)=0 17797 ITEXT(I)=' ' 17798 AMAT(I,1)=100.0*(1.0 - ALPHA(I)) 17799 AMAT(I,2)=ALOWPA(I) 17800 AMAT(I,3)=AUPPPA(I) 17801 2523 CONTINUE 17802 IWHTML(1)=150 17803 IWHTML(2)=150 17804 IWHTML(3)=150 17805 IWHTML(4)=150 17806 IWRTF(1)=2000 17807 IWRTF(2)=IWRTF(1)+2000 17808 IWRTF(3)=IWRTF(2)+2000 17809C 17810 ITITL9=' ' 17811 NCTIT9=0 17812 IFRST=.TRUE. 17813 ILAST=.TRUE. 17814 CALL DPDTA2(ITITLE,NCTITL, 17815 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 17816 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 17817 1 ITEXT,NCTEXT,AMAT,MAXROW,NUMALP, 17818 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 17819 1 ICAPSW,ICAPTY,IFRST,ILAST, 17820 1 ISUBRO,IBUGA3,IERROR) 17821C 17822C ***************** 17823C ** STEP 90-- ** 17824C ** EXIT ** 17825C ***************** 17826C 17827 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DT8C')THEN 17828 WRITE(ICOUT,999) 17829 CALL DPWRST('XXX','WRIT') 17830 WRITE(ICOUT,9011) 17831 9011 FORMAT('***** AT THE END OF DPDT8C--') 17832 CALL DPWRST('XXX','WRIT') 17833 ENDIF 17834C 17835 RETURN 17836 END 17837 SUBROUTINE DPDT8D(ALOWSC,AUPPSC,ALOWS2,AUPPS2, 17838 1 ALOWMU,AUPPMU,ALOWM2,AUPPM2, 17839 1 ALOWSH,AUPPSH,ALOSH2,AUPSH2,ALPHA,NUMALP, 17840 1 ICAPSW,ICAPTY,NUMDIG,ILIKFL, 17841 1 ISUBRO,IBUGA3,IERROR) 17842C 17843C PURPOSE--THIS IS A VARIANT OF "DPDTA8" USED FOR THE CENSORED 17844C 2-PARAMETER LOGNORMAL CASE. THIS SUBROUTINE PRINTS 17845C THE CONFIDENCE INTERVAL TABLES FOR BOTH THE SCALE AND 17846C THE SHAPE PARAMETERS. FOR THE SCALE, WE ALSO GENERATE 17847C THE CONFIDENCE INTERVAL FOR MU (=LOG(SCALE)) USING BOTH 17848C THE NORMAL APPROXIMATION AND THE LIKELIHOOD RATIO METHOD. 17849C 17850C WRITTEN BY--ALAN HECKERT 17851C STATISTICAL ENGINEERING DIVISION 17852C INFORMATION TECHNOLOGY LABORATORY 17853C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 17854C GAITHERSBURG, MD 20899-8980 17855C PHONE--301-975-2899 17856C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 17857C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 17858C LANGUAGE--ANSI FORTRAN (1977) 17859C VERSION NUMBER--2010/07 17860C ORIGINAL VERSION--JULY 2010. 17861C 17862C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 17863C 17864 CHARACTER*4 ICAPSW 17865 CHARACTER*4 ICAPTY 17866 CHARACTER*4 ILIKFL 17867C 17868 CHARACTER*4 ISUBRO 17869 CHARACTER*4 IBUGA3 17870 CHARACTER*4 IERROR 17871 CHARACTER*4 ISUBN1 17872 CHARACTER*4 ISUBN2 17873C 17874C--------------------------------------------------------------------- 17875C 17876 DIMENSION ALPHA(*) 17877 DIMENSION ALOWSC(*) 17878 DIMENSION AUPPSC(*) 17879 DIMENSION ALOWS2(*) 17880 DIMENSION AUPPS2(*) 17881 DIMENSION ALOWMU(*) 17882 DIMENSION AUPPMU(*) 17883 DIMENSION ALOWM2(*) 17884 DIMENSION AUPPM2(*) 17885 DIMENSION ALOWSH(*) 17886 DIMENSION AUPPSH(*) 17887 DIMENSION ALOSH2(*) 17888 DIMENSION AUPSH2(*) 17889C 17890 INCLUDE 'DPCOST.INC' 17891C 17892 PARAMETER (MAXROW=10) 17893 CHARACTER*60 ITITLE 17894 CHARACTER*40 ITITL9 17895 CHARACTER*40 ITEXT(NUMALP) 17896 INTEGER NCTEXT(MAXROW) 17897C 17898 PARAMETER(NUMCLI=5) 17899 PARAMETER(MAXLIN=3) 17900 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 17901 INTEGER NCTIT2(MAXLIN,NUMCLI) 17902 INTEGER IWHTML(NUMCLI+1) 17903 INTEGER IWRTF(NUMCLI) 17904 INTEGER IDIGIT(NUMCLI) 17905 INTEGER NTOT(NUMCLI) 17906 CHARACTER*4 ALIGN(NUMCLI) 17907 CHARACTER*4 VALIGN(NUMCLI) 17908 REAL AMAT(MAXROW,NUMCLI) 17909 LOGICAL IFRST 17910 LOGICAL ILAST 17911C--------------------------------------------------------------------- 17912C 17913 INCLUDE 'DPCOP2.INC' 17914C 17915C-----START POINT----------------------------------------------------- 17916C 17917 ISUBN1='DPDT' 17918 ISUBN2='A8 ' 17919 IERROR='NO' 17920C 17921 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DT8D')THEN 17922 WRITE(ICOUT,999) 17923 999 FORMAT(1X) 17924 CALL DPWRST('XXX','WRIT') 17925 WRITE(ICOUT,51) 17926 51 FORMAT('**** AT THE BEGINNING OF DPDT8D--') 17927 CALL DPWRST('XXX','WRIT') 17928 WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMALP 17929 52 FORMAT('IBUGA3,ISUBRO,NUMALP = ',A4,2X,A4,2X,I8) 17930 CALL DPWRST('XXX','WRIT') 17931 DO56I=1,NUMALP 17932 WRITE(ICOUT,57)I,ALOWSC(I),AUPPSC(I),ALOWS2(I),AUPPS2(I) 17933 57 FORMAT('I,ALOWSC(I),AUPPSC(I),ALOWSH(I),AUPPSH(I) = ', 17934 1 I8,4G15.7) 17935 CALL DPWRST('XXX','WRIT') 17936 WRITE(ICOUT,58)I,ALOWMU(I),AUPPMU(I),ALOWM2(I),AUPPM2(I) 17937 58 FORMAT('I,ALOWMU(I),AUPPMU(I),ALOWM2(I),AUPPM2(I) = ', 17938 1 I8,4G15.7) 17939 CALL DPWRST('XXX','WRIT') 17940 WRITE(ICOUT,59)I,ALOWSH(I),AUPPSH(I),ALOSH2(I),AUPSH2(I) 17941 59 FORMAT('I,ALOWSH(I),AUPPSH(I),ALOSH2(I),AUPSH2(I) = ', 17942 1 I8,4G15.7) 17943 CALL DPWRST('XXX','WRIT') 17944 56 CONTINUE 17945 ENDIF 17946C 17947 ITITLE(1:39)='Confidence Interval for Scale Parameter' 17948 NCTITL=39 17949 ITITL9(1:20)='Normal Approximation' 17950 NCTIT9=20 17951 NUMLIN=3 17952 NUMCOL=5 17953 ITITL2(1,1)=' ' 17954 ITITL2(2,1)='Confidence' 17955 ITITL2(3,1)='Coefficient' 17956 NCTIT2(1,1)=0 17957 NCTIT2(2,1)=10 17958 NCTIT2(3,1)=11 17959 ITITL2(1,2)='Scale' 17960 ITITL2(2,2)='Lower' 17961 ITITL2(3,2)='Limit' 17962 NCTIT2(1,2)=5 17963 NCTIT2(2,2)=5 17964 NCTIT2(3,2)=5 17965 ITITL2(1,3)='Parameter' 17966 ITITL2(2,3)='Upper' 17967 ITITL2(3,3)='Limit' 17968 NCTIT2(1,3)=9 17969 NCTIT2(2,3)=5 17970 NCTIT2(3,3)=5 17971 ITITL2(1,4)='MU' 17972 ITITL2(2,4)='Lower' 17973 ITITL2(3,4)='Limit' 17974 NCTIT2(1,4)=2 17975 NCTIT2(2,4)=5 17976 NCTIT2(3,4)=5 17977 ITITL2(1,5)='Parameter' 17978 ITITL2(2,5)='Upper' 17979 ITITL2(3,5)='Limit' 17980 NCTIT2(1,5)=9 17981 NCTIT2(2,5)=5 17982 NCTIT2(3,5)=5 17983C 17984 NMAX=0 17985 DO2521I=1,NUMCOL 17986 VALIGN(I)='b' 17987 ALIGN(I)='r' 17988 NTOT(I)=15 17989 IF(I.EQ.1)NTOT(I)=12 17990 NMAX=NMAX+NTOT(I) 17991 IDIGIT(I)=NUMDIG 17992 2521 CONTINUE 17993 IDIGIT(1)=2 17994 DO2523I=1,NUMALP 17995 NCTEXT(I)=0 17996 AMAT(I,1)=100.0*(1.0 - ALPHA(I)) 17997 AMAT(I,2)=ALOWSC(I) 17998 AMAT(I,3)=AUPPSC(I) 17999 AMAT(I,4)=ALOWMU(I) 18000 AMAT(I,5)=AUPPMU(I) 18001 2523 CONTINUE 18002 IWHTML(1)=150 18003 IWHTML(2)=150 18004 IWHTML(3)=150 18005 IWHTML(4)=150 18006 IWHTML(5)=150 18007 IWHTML(6)=150 18008 IWRTF(1)=2000 18009 IWRTF(2)=IWRTF(1)+2000 18010 IWRTF(3)=IWRTF(2)+2000 18011 IWRTF(4)=IWRTF(3)+2000 18012 IWRTF(5)=IWRTF(4)+2000 18013C 18014 IFRST=.TRUE. 18015 ILAST=.TRUE. 18016 CALL DPDTA2(ITITLE,NCTITL, 18017 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 18018 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 18019 1 ITEXT,NCTEXT,AMAT,MAXROW,NUMALP, 18020 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 18021 1 ICAPSW,ICAPTY,IFRST,ILAST, 18022 1 ISUBRO,IBUGA3,IERROR) 18023C 18024 ITITL9(1:20)='Likelihood Ratio' 18025 NCTIT9=16 18026 DO2533I=1,NUMALP 18027 NCTEXT(I)=0 18028 AMAT(I,1)=100.0*(1.0 - ALPHA(I)) 18029 AMAT(I,2)=ALOWS2(I) 18030 AMAT(I,3)=AUPPS2(I) 18031 AMAT(I,4)=ALOWM2(I) 18032 AMAT(I,5)=AUPPM2(I) 18033 2533 CONTINUE 18034C 18035 IFRST=.FALSE. 18036 ILAST=.FALSE. 18037 CALL DPDTA2(ITITLE,NCTITL, 18038 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 18039 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 18040 1 ITEXT,NCTEXT,AMAT,MAXROW,NUMALP, 18041 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 18042 1 ICAPSW,ICAPTY,IFRST,ILAST, 18043 1 ISUBRO,IBUGA3,IERROR) 18044C 18045 ITITLE(1:39)='Confidence Interval for Shape Parameter' 18046 NCTITL=39 18047 ITITL9=' ' 18048 NCTIT9=0 18049C 18050 ITITL2(1,2)='Normal' 18051 ITITL2(2,2)='Lower' 18052 ITITL2(3,2)='Limit' 18053 NCTIT2(1,2)=6 18054 NCTIT2(2,2)=5 18055 NCTIT2(3,2)=5 18056 ITITL2(1,3)='Approximation' 18057 ITITL2(2,3)='Upper' 18058 ITITL2(3,3)='Limit' 18059 NCTIT2(1,3)=13 18060 NCTIT2(2,3)=5 18061 NCTIT2(3,3)=5 18062 ITITL2(1,4)='Likelihood Ratio' 18063 ITITL2(2,4)='Lower' 18064 ITITL2(3,4)='Limit' 18065 NCTIT2(1,4)=16 18066 NCTIT2(2,4)=5 18067 NCTIT2(3,4)=5 18068 ITITL2(1,5)='Approximation' 18069 ITITL2(2,5)='Upper' 18070 ITITL2(3,5)='Limit' 18071 NCTIT2(1,5)=13 18072 NCTIT2(2,5)=5 18073 NCTIT2(3,5)=5 18074 IF(ILIKFL.EQ.'OFF')NUMCOL=3 18075C 18076 NMAX=0 18077 DO2541I=1,NUMCOL 18078 VALIGN(I)='b' 18079 ALIGN(I)='r' 18080 NTOT(I)=15 18081 IF(I.EQ.1)NTOT(I)=12 18082 IF(I.EQ.4)NTOT(I)=18 18083 NMAX=NMAX+NTOT(I) 18084 IDIGIT(I)=NUMDIG 18085 2541 CONTINUE 18086 IDIGIT(1)=2 18087C 18088 DO2543I=1,NUMALP 18089 NCTEXT(I)=0 18090 AMAT(I,1)=100.0*(1.0 - ALPHA(I)) 18091 AMAT(I,2)=ALOWSH(I) 18092 AMAT(I,3)=AUPPSH(I) 18093 AMAT(I,4)=ALOSH2(I) 18094 AMAT(I,5)=AUPSH2(I) 18095 2543 CONTINUE 18096 IFRST=.TRUE. 18097 ILAST=.TRUE. 18098C 18099 CALL DPDTA2(ITITLE,NCTITL, 18100 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 18101 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 18102 1 ITEXT,NCTEXT,AMAT,MAXROW,NUMALP, 18103 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 18104 1 ICAPSW,ICAPTY,IFRST,ILAST, 18105 1 ISUBRO,IBUGA3,IERROR) 18106C 18107C ***************** 18108C ** STEP 90-- ** 18109C ** EXIT ** 18110C ***************** 18111C 18112 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DT8D')THEN 18113 WRITE(ICOUT,999) 18114 CALL DPWRST('XXX','WRIT') 18115 WRITE(ICOUT,9011) 18116 9011 FORMAT('***** AT THE END OF DPDT8D--') 18117 CALL DPWRST('XXX','WRIT') 18118 ENDIF 18119C 18120 RETURN 18121 END 18122 SUBROUTINE DPDTA9(QP,XQPHAT,XQPLCL,XQPUCL,XQPSE,NPERC, 18123 1 ICAPSW,ICAPTY,ILIKFL,NUMDIG,ALPHAP, 18124 1 ISUBRO,IBUGA3,IERROR) 18125C 18126C PURPOSE--FOR MAXIMUM LIKELIHOOD FOR DISTRIBUTIONS, PRINT 18127C THE QUANTILE CONFIDENCE INTERVAL TABLE. 18128C WRITTEN BY--ALAN HECKERT 18129C STATISTICAL ENGINEERING DIVISION 18130C INFORMATION TECHNOLOGY LABORATORY 18131C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 18132C GAITHERSBURG, MD 20899-8980 18133C PHONE--301-975-2899 18134C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 18135C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 18136C LANGUAGE--ANSI FORTRAN (1977) 18137C VERSION NUMBER--2010/02 18138C ORIGINAL VERSION--FEBRUARY 2010 EXTRACT AS DISTINCT SUBROUTINE 18139C UPDATED --JUNE 2010 ADD ILIKFL TO SPECIFY WHEHTER 18140C BASED ON NORMAL APPROXIMAITON 18141C OR LIKELIHOOD RATIO 18142C UPDATED --JUNE 2010 2-PAR EXPONENTIAL ONLY DOES 18143C LOWER LIMIT. CHECK TO SEE 18144C IF UPPER LIMIT SET TO CPUMIN 18145C UPDATED --MARCH 2014 SUPPORT USER OPTION FOR "LOWER" 18146C OR "UPPER" CASES. ONE-SIDED 18147C PERCENTILES ARE EQUIVALENT TO 18148C ONE-SIDED TOLERANCE INTERVALS 18149C (WHICH IS THE MOTIVATION FOR THIS 18150C OPTION). 18151C UPDATED --NOVEMBER 2015 CHECK FOR SMALL VALUES OF ALPHA 18152C UPDATED --NOVEMBER 2015 USER SETTABLE DIGITS FOR 18153C PERCENTILE COLUMN 18154C 18155C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 18156C 18157 CHARACTER*4 ICAPSW 18158 CHARACTER*4 ICAPTY 18159 CHARACTER*4 ILIKFL 18160C 18161 CHARACTER*4 ISUBRO 18162 CHARACTER*4 IBUGA3 18163 CHARACTER*4 IERROR 18164C 18165 CHARACTER*4 ISUBN1 18166 CHARACTER*4 ISUBN2 18167C 18168 LOGICAL IFLAGU 18169 LOGICAL IFLAGL 18170C 18171C--------------------------------------------------------------------- 18172C 18173 DIMENSION QP(*) 18174 DIMENSION XQPHAT(*) 18175 DIMENSION XQPSE(*) 18176 DIMENSION XQPLCL(*) 18177 DIMENSION XQPUCL(*) 18178C 18179 INCLUDE 'DPCOST.INC' 18180C 18181 PARAMETER (MAXROW=50) 18182 CHARACTER*60 ITITLE 18183 CHARACTER*60 ITITL9 18184 CHARACTER*40 ITEXT(MAXROW) 18185 CHARACTER*4 ALIGN(MAXROW) 18186 CHARACTER*4 VALIGN(MAXROW) 18187 INTEGER NCTEXT(MAXROW) 18188 INTEGER IDIGIT(MAXROW) 18189 INTEGER NTOT(MAXROW) 18190C 18191 PARAMETER(NUMCLI=5) 18192 PARAMETER(MAXLIN=3) 18193 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 18194 INTEGER NCTIT2(MAXLIN,NUMCLI) 18195 INTEGER IWHTML(MAXROW) 18196 INTEGER IWRTF(MAXROW) 18197 REAL AMAT(MAXROW,NUMCLI) 18198 LOGICAL IFRST 18199 LOGICAL ILAST 18200C 18201C--------------------------------------------------------------------- 18202C 18203 INCLUDE 'DPCOP2.INC' 18204C 18205C-----START POINT----------------------------------------------------- 18206C 18207 ISUBN1='DPDT' 18208 ISUBN2='A9 ' 18209 IERROR='NO' 18210 IFLAGU=.TRUE. 18211 IFLAGL=.TRUE. 18212 IF(XQPUCL(1).EQ.CPUMIN)IFLAGU=.FALSE. 18213 IF(XQPLCL(1).EQ.CPUMIN)IFLAGL=.FALSE. 18214C 18215 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTA9')THEN 18216 WRITE(ICOUT,999) 18217 999 FORMAT(1X) 18218 CALL DPWRST('XXX','WRIT') 18219 WRITE(ICOUT,51) 18220 51 FORMAT('**** AT THE BEGINNING OF DPDTA9--') 18221 CALL DPWRST('XXX','WRIT') 18222 WRITE(ICOUT,52)IBUGA3,ISUBRO,NPERC,NUMDIG 18223 52 FORMAT('IBUGA3,ISUBRO,NPERC,NUMDIT = ',A4,2X,A4,2X,2I5) 18224 CALL DPWRST('XXX','WRIT') 18225 DO56I=1,NPERC 18226 WRITE(ICOUT,57)I,QP(I),XQPHAT(I),XQPLCL(I),XQPUCL(I),XQPSE(I) 18227 57 FORMAT('I,QP(I),XQPHAT(I),XQPLCL(I),XQPUCL(I),XQPSE(I) = ', 18228 1 I8,5G15.7) 18229 CALL DPWRST('XXX','WRIT') 18230 56 CONTINUE 18231 ENDIF 18232C 18233 IF(NPERC.GT.1)THEN 18234C 18235C CHECK FOR VERY SMALL VALUES FOR ALPHA 18236C 18237 ITITL9=' ' 18238 ITITL9(1:40)='Select Percentiles Confidence Intervals ' 18239 ITITL9(41:59)='(alpha = )' 18240 IF(ALPHAP.GE.0.001)THEN 18241 ITITL9(41:55)='(alpha = )' 18242 WRITE(ITITL9(50:54),'(F5.3)')ALPHAP 18243 NCTIT9=55 18244 ELSEIF(ALPHAP.GE.0.0001)THEN 18245 ITITL9(41:56)='(alpha = )' 18246 WRITE(ITITL9(50:55),'(F6.4)')ALPHAP 18247 NCTIT9=56 18248 ELSEIF(ALPHAP.GE.0.00001)THEN 18249 ITITL9(41:57)='(alpha = )' 18250 WRITE(ITITL9(50:56),'(F7.5)')ALPHAP 18251 NCTIT9=57 18252 ELSEIF(ALPHAP.GE.0.000001)THEN 18253 ITITL9(41:58)='(alpha = )' 18254 WRITE(ITITL9(50:57),'(F8.6)')ALPHAP 18255 NCTIT9=58 18256 ELSE 18257 ITITL9(41:60)='(alpha = )' 18258 WRITE(ITITL9(50:59),'(E10.4)')ALPHAP 18259 NCTIT9=60 18260 ENDIF 18261C 18262 IF(ILIKFL.EQ.'ON')THEN 18263 ITITLE='(Based on Likelihood Ratio)' 18264 NCTITL=27 18265 ELSEIF(ILIKFL.EQ.'EXAC')THEN 18266 ITITLE=' ' 18267 NCTITL=0 18268 ELSEIF(ILIKFL.EQ.'PARE')THEN 18269 ITITLE='(Based on Astrabadi Approximation)' 18270 NCTITL=34 18271 ELSE 18272 ITITLE='(Based on Normal Approximation)' 18273 NCTITL=31 18274 ENDIF 18275 NUMLIN=2 18276 IF(XQPSE(1).NE.CPUMIN)THEN 18277 NUMCOL=5 18278 IFLAGS=1 18279 ELSE 18280 NUMCOL=4 18281 IFLAGS=0 18282 ENDIF 18283 IF(.NOT.IFLAGL)NUMCOL=NUMCOL-1 18284 IF(.NOT.IFLAGU)NUMCOL=NUMCOL-1 18285 ITITL2(1,1)=' ' 18286 ITITL2(2,1)='Percentile' 18287 ITITL2(1,2)='Point' 18288 ITITL2(2,2)='Estimate' 18289 NCTIT2(1,1)=0 18290 NCTIT2(2,1)=10 18291 NCTIT2(1,2)=5 18292 NCTIT2(2,2)=8 18293C 18294 ICNT2=2 18295 IF(IFLAGS.EQ.1)THEN 18296 ICNT2=ICNT2+1 18297 ITITL2(1,ICNT2)='Standard' 18298 ITITL2(2,ICNT2)='Error' 18299 NCTIT2(1,ICNT2)=8 18300 NCTIT2(2,ICNT2)=5 18301 ENDIF 18302C 18303 IF(IFLAGL)THEN 18304 ICNT2=ICNT2+1 18305 ITITL2(1,ICNT2)='Lower' 18306 ITITL2(2,ICNT2)='Limit' 18307 NCTIT2(1,ICNT2)=5 18308 NCTIT2(2,ICNT2)=5 18309 ENDIF 18310C 18311 IF(IFLAGU)THEN 18312 ICNT2=ICNT2+1 18313 ITITL2(1,ICNT2)='Upper' 18314 ITITL2(2,ICNT2)='Limit' 18315 NCTIT2(1,ICNT2)=5 18316 NCTIT2(2,ICNT2)=5 18317 ENDIF 18318C 18319 NMAX=0 18320 DO2621I=1,NUMCOL 18321 VALIGN(I)='b' 18322 ALIGN(I)='r' 18323 NTOT(I)=15 18324 NMAX=NMAX+NTOT(I) 18325 IDIGIT(I)=NUMDIG 18326 2621 CONTINUE 18327CCCCC IDIGIT(1)=3 18328 IDIGIT(1)=IPCIDI 18329 DO2623I=1,NPERC 18330 NCTEXT(I)=0 18331 AMAT(I,1)=QP(I) 18332 AMAT(I,2)=XQPHAT(I) 18333 ICNT2=2 18334 IF(IFLAGS.EQ.1)THEN 18335 ICNT2=ICNT2+1 18336 AMAT(I,ICNT2)=XQPSE(I) 18337 ENDIF 18338 IF(IFLAGL)THEN 18339 ICNT2=ICNT2+1 18340 AMAT(I,ICNT2)=XQPLCL(I) 18341 ENDIF 18342 IF(IFLAGU)THEN 18343 ICNT2=ICNT2+1 18344 AMAT(I,ICNT2)=XQPUCL(I) 18345 ENDIF 18346 2623 CONTINUE 18347 IWHTML(1)=150 18348 IWHTML(2)=150 18349 IWHTML(3)=150 18350 IWHTML(4)=150 18351 IWHTML(5)=150 18352 IWHTML(6)=150 18353 IINC=2000 18354 IF(IFLAGS.EQ.1)AINC=1800 18355 IWRTF(1)=IINC 18356 IWRTF(2)=IWRTF(1)+IINC 18357 IWRTF(3)=IWRTF(2)+IINC 18358 IWRTF(4)=IWRTF(3)+IINC 18359 IWRTF(4)=IWRTF(4)+IINC 18360 IFRST=.TRUE. 18361 ILAST=.TRUE. 18362C 18363 CALL DPDTA2(ITITL9,NCTIT9, 18364 1 ITITLE,NCTITL,ITITL2,NCTIT2, 18365 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 18366 1 ITEXT,NCTEXT,AMAT,MAXROW,NPERC, 18367 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 18368 1 ICAPSW,ICAPTY,IFRST,ILAST, 18369 1 ISUBRO,IBUGA3,IERROR) 18370 ENDIF 18371C 18372C ***************** 18373C ** STEP 90-- ** 18374C ** EXIT ** 18375C ***************** 18376C 18377 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTA9')THEN 18378 WRITE(ICOUT,999) 18379 CALL DPWRST('XXX','WRIT') 18380 WRITE(ICOUT,9011) 18381 9011 FORMAT('***** AT THE END OF DPDTA9--') 18382 CALL DPWRST('XXX','WRIT') 18383 ENDIF 18384C 18385 RETURN 18386 END 18387 SUBROUTINE DPDT9B(QP,XQPHAT,XQPLCL,XQPUCL,NPERC, 18388 1 ICAPSW,ICAPTY,NUMDIG,ALPHAP, 18389 1 ISUBRO,IBUGA3,IERROR) 18390C 18391C PURPOSE--FOR BOOTSTRAP DISTRIBUTIONAL MODELING, PRINT THE 18392C QUANTILE CONFIDENCE INTERVAL TABLE. 18393C WRITTEN BY--ALAN HECKERT 18394C STATISTICAL ENGINEERING DIVISION 18395C INFORMATION TECHNOLOGY LABORATORY 18396C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 18397C GAITHERSBURG, MD 20899-8980 18398C PHONE--301-975-2899 18399C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 18400C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 18401C LANGUAGE--ANSI FORTRAN (1977) 18402C VERSION NUMBER--2010/07 18403C ORIGINAL VERSION--JULY 2010 18404C UPDATED --AUGUST 2011 SUPPORT FOR ONE-SIDED INTERVALS 18405C (NOTE THESE ARE EQUIVALENT TO 18406C ONE-SIDED TOLERANCE INTERVALS) 18407C UPDATED --NOVEMBER 2015 CHECK FOR SMALL VALUES OF ALPHA 18408C UPDATED --NOVEMBER 2015 USER SETTABLE DIGITS FOR 18409C PERCENTILE COLUMN 18410C 18411C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 18412C 18413 CHARACTER*4 ICAPSW 18414 CHARACTER*4 ICAPTY 18415C 18416 CHARACTER*4 ISUBRO 18417 CHARACTER*4 IBUGA3 18418 CHARACTER*4 IERROR 18419C 18420 CHARACTER*4 ICASE 18421 CHARACTER*4 ISUBN1 18422 CHARACTER*4 ISUBN2 18423C 18424C--------------------------------------------------------------------- 18425C 18426 DIMENSION QP(*) 18427 DIMENSION XQPHAT(*) 18428 DIMENSION XQPLCL(*) 18429 DIMENSION XQPUCL(*) 18430C 18431 INCLUDE 'DPCOST.INC' 18432C 18433 PARAMETER (MAXROW=30) 18434 CHARACTER*60 ITITLE 18435 CHARACTER*60 ITITL9 18436 CHARACTER*40 ITEXT(MAXROW) 18437 CHARACTER*4 ALIGN(MAXROW) 18438 CHARACTER*4 VALIGN(MAXROW) 18439 INTEGER NCTEXT(MAXROW) 18440 INTEGER IDIGIT(MAXROW) 18441 INTEGER NTOT(MAXROW) 18442C 18443 PARAMETER(NUMCLI=4) 18444 PARAMETER(MAXLIN=3) 18445 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 18446 INTEGER NCTIT2(MAXLIN,NUMCLI) 18447 INTEGER IWHTML(MAXROW) 18448 INTEGER IWRTF(MAXROW) 18449 REAL AMAT(MAXROW,NUMCLI) 18450 LOGICAL IFRST 18451 LOGICAL ILAST 18452C 18453C--------------------------------------------------------------------- 18454C 18455 INCLUDE 'DPCOP2.INC' 18456C 18457C-----START POINT----------------------------------------------------- 18458C 18459 ISUBN1='DPDT' 18460 ISUBN2='9B ' 18461 IERROR='NO' 18462 ICASE='TWOS' 18463 IF(XQPLCL(1).EQ.CPUMIN)THEN 18464 ICASE='UPPE' 18465 ELSEIF(XQPUCL(1).EQ.CPUMIN)THEN 18466 ICASE='LOWE' 18467 ENDIF 18468C 18469 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DT9B')THEN 18470 WRITE(ICOUT,999) 18471 999 FORMAT(1X) 18472 CALL DPWRST('XXX','WRIT') 18473 WRITE(ICOUT,51) 18474 51 FORMAT('**** AT THE BEGINNING OF DPDT9B--') 18475 CALL DPWRST('XXX','WRIT') 18476 WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASE,NPERC,NUMDIG 18477 52 FORMAT('IBUGA3,ISUBRO,ICASE,NPERC,NUMDIG = ',3(A4,2X),2I5) 18478 CALL DPWRST('XXX','WRIT') 18479 DO56I=1,NPERC 18480 WRITE(ICOUT,57)I,QP(I),XQPHAT(I),XQPLCL(I),XQPUCL(I) 18481 57 FORMAT('I,QP(I),XQPHAT(I),XQPLCL(I),XQPUCL(I) = ', 18482 1 I8,4G15.7) 18483 CALL DPWRST('XXX','WRIT') 18484 56 CONTINUE 18485 ENDIF 18486C 18487 IF(NPERC.GT.1)THEN 18488C 18489C CHECK FOR VERY SMALL VALUES FOR ALPHA 18490C 18491 ITITL9=' ' 18492 ITITL9(1:40)='Select Percentiles Confidence Intervals ' 18493 ITITL9(41:59)='(alpha = )' 18494 IF(ALPHAP.GE.0.001)THEN 18495 ITITL9(41:55)='(alpha = )' 18496 WRITE(ITITL9(50:54),'(F5.3)')ALPHAP 18497 NCTIT9=55 18498 ELSEIF(ALPHAP.GE.0.0001)THEN 18499 ITITL9(41:56)='(alpha = )' 18500 WRITE(ITITL9(50:55),'(F6.4)')ALPHAP 18501 NCTIT9=56 18502 ELSEIF(ALPHAP.GE.0.00001)THEN 18503 ITITL9(41:57)='(alpha = )' 18504 WRITE(ITITL9(50:56),'(F7.5)')ALPHAP 18505 NCTIT9=57 18506 ELSEIF(ALPHAP.GE.0.000001)THEN 18507 ITITL9(41:58)='(alpha = )' 18508 WRITE(ITITL9(50:57),'(F8.6)')ALPHAP 18509 NCTIT9=58 18510 ELSE 18511 ITITL9(41:60)='(alpha = )' 18512 WRITE(ITITL9(50:59),'(E10.4)')ALPHAP 18513 NCTIT9=60 18514 ENDIF 18515C 18516 ITITLE='(Based on Bootstrap Samples)' 18517 NCTITL=28 18518 NUMLIN=3 18519 NUMCOL=4 18520 IF(ICASE.EQ.'LOWE')NUMCOL=3 18521 IF(ICASE.EQ.'UPPE')NUMCOL=3 18522 ITITL2(1,1)=' ' 18523 ITITL2(2,1)=' ' 18524 ITITL2(3,1)='Percentile' 18525 NCTIT2(1,1)=0 18526 NCTIT2(2,1)=0 18527 NCTIT2(3,1)=10 18528 ITITL2(1,2)='Median' 18529 ITITL2(2,2)='Point' 18530 ITITL2(3,2)='Estimate' 18531 NCTIT2(1,2)=6 18532 NCTIT2(2,2)=5 18533 NCTIT2(3,2)=8 18534 IF(ICASE.EQ.'TWOS')THEN 18535 ITITL2(1,3)=' ' 18536 ITITL2(2,3)='Lower' 18537 ITITL2(3,3)='Limit' 18538 NCTIT2(1,3)=0 18539 NCTIT2(2,3)=5 18540 NCTIT2(3,3)=5 18541 ITITL2(1,4)=' ' 18542 ITITL2(2,4)='Upper' 18543 ITITL2(3,4)='Limit' 18544 NCTIT2(1,4)=0 18545 NCTIT2(2,4)=5 18546 NCTIT2(3,4)=5 18547 ELSEIF(ICASE.EQ.'LOWE')THEN 18548 ITITL2(1,3)=' ' 18549 ITITL2(2,3)='Lower' 18550 ITITL2(3,3)='Limit' 18551 NCTIT2(1,3)=0 18552 NCTIT2(2,3)=5 18553 NCTIT2(3,3)=5 18554 ELSEIF(ICASE.EQ.'UPPE')THEN 18555 ITITL2(1,3)=' ' 18556 ITITL2(2,3)='Upper' 18557 ITITL2(3,3)='Limit' 18558 NCTIT2(1,3)=0 18559 NCTIT2(2,3)=5 18560 NCTIT2(3,3)=5 18561 ENDIF 18562 NMAX=0 18563 DO2621I=1,NUMCOL 18564 VALIGN(I)='b' 18565 ALIGN(I)='r' 18566 NTOT(I)=15 18567 NMAX=NMAX+NTOT(I) 18568 IDIGIT(I)=NUMDIG 18569 2621 CONTINUE 18570CCCCC IDIGIT(1)=3 18571 IDIGIT(1)=IPCIDI 18572 DO2623I=1,NPERC 18573 NCTEXT(I)=0 18574 AMAT(I,1)=100.0*QP(I) 18575 AMAT(I,2)=XQPHAT(I) 18576 IF(ICASE.EQ.'TWOS')THEN 18577 AMAT(I,3)=XQPLCL(I) 18578 AMAT(I,4)=XQPUCL(I) 18579 ELSEIF(ICASE.EQ.'LOWE')THEN 18580 AMAT(I,3)=XQPLCL(I) 18581 ELSEIF(ICASE.EQ.'UPPE')THEN 18582 AMAT(I,3)=XQPUCL(I) 18583 ENDIF 18584 2623 CONTINUE 18585 IWHTML(1)=150 18586 IWHTML(2)=150 18587 IWHTML(3)=150 18588 IWHTML(4)=150 18589 IWHTML(5)=150 18590 IWRTF(1)=2000 18591 IWRTF(2)=IWRTF(1)+2000 18592 IWRTF(3)=IWRTF(2)+2000 18593 IWRTF(4)=IWRTF(3)+2000 18594 IFRST=.TRUE. 18595 ILAST=.TRUE. 18596C 18597 CALL DPDTA2(ITITL9,NCTIT9, 18598 1 ITITLE,NCTITL,ITITL2,NCTIT2, 18599 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 18600 1 ITEXT,NCTEXT,AMAT,MAXROW,NPERC, 18601 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 18602 1 ICAPSW,ICAPTY,IFRST,ILAST, 18603 1 ISUBRO,IBUGA3,IERROR) 18604 ENDIF 18605C 18606C ***************** 18607C ** STEP 90-- ** 18608C ** EXIT ** 18609C ***************** 18610C 18611 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DT9B')THEN 18612 WRITE(ICOUT,999) 18613 CALL DPWRST('XXX','WRIT') 18614 WRITE(ICOUT,9011) 18615 9011 FORMAT('***** AT THE END OF DPDT9B--') 18616 CALL DPWRST('XXX','WRIT') 18617 ENDIF 18618C 18619 RETURN 18620 END 18621 SUBROUTINE DPDTAP(R,NRET, 18622 1 ALOC,ASCALE,ALAMB,DG,XR, 18623 1 ICAPSW,ICAPTY,NUMDIG, 18624 1 ISUBRO,IBUGA3,IERROR) 18625C 18626C PURPOSE--GENERATE THE MEAN RECURRENCE INTERVAL TABLE FOR 18627C THE PEAKS OVER THRESHOLD PLOT. 18628C WRITTEN BY--ALAN HECKERT 18629C STATISTICAL ENGINEERING DIVISION 18630C INFORMATION TECHNOLOGY LABORATORY 18631C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 18632C GAITHERSBURG, MD 20899-8980 18633C PHONE--301-975-2899 18634C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 18635C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 18636C LANGUAGE--ANSI FORTRAN (1977) 18637C VERSION NUMBER--2010/07 18638C ORIGINAL VERSION--JULY 2010. EXTRACTED AS A DISTINCT 18639C SUBROUTINE FROM DPPOT2 18640C 18641C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 18642C 18643 CHARACTER*4 ICAPSW 18644 CHARACTER*4 ICAPTY 18645C 18646 CHARACTER*4 ISUBRO 18647 CHARACTER*4 IBUGA3 18648 CHARACTER*4 IERROR 18649 CHARACTER*4 ISUBN1 18650 CHARACTER*4 ISUBN2 18651C 18652 DOUBLE PRECISION DG 18653 DOUBLE PRECISION DXR 18654C 18655C--------------------------------------------------------------------- 18656C 18657 DIMENSION R(*) 18658C 18659 INCLUDE 'DPCOST.INC' 18660C 18661 PARAMETER (MAXROW=30) 18662 CHARACTER*1 ITITLE 18663 CHARACTER*1 ITITLZ 18664 CHARACTER*1 ITEXT(MAXROW) 18665C 18666 PARAMETER(NUMCLI=2) 18667 PARAMETER(MAXLIN=2) 18668 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 18669 INTEGER NCTIT2(MAXLIN,NUMCLI) 18670 INTEGER IWHTML(NUMCLI+1) 18671 INTEGER IWRTF(NUMCLI) 18672 INTEGER IDIGIT(NUMCLI) 18673 INTEGER NTOT(NUMCLI) 18674 INTEGER NCTEXT(MAXROW) 18675 REAL AMAT(MAXROW,NUMCLI) 18676 CHARACTER*4 ALIGN(NUMCLI) 18677 CHARACTER*4 VALIGN(NUMCLI) 18678 LOGICAL IFRST 18679 LOGICAL ILAST 18680C 18681C--------------------------------------------------------------------- 18682C 18683 INCLUDE 'DPCOP2.INC' 18684C 18685C-----START POINT----------------------------------------------------- 18686C 18687 ISUBN1='DPDT' 18688 ISUBN2='AP ' 18689 IERROR='NO' 18690C 18691 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTAP')THEN 18692 WRITE(ICOUT,999) 18693 999 FORMAT(1X) 18694 CALL DPWRST('XXX','WRIT') 18695 WRITE(ICOUT,51) 18696 51 FORMAT('**** AT THE BEGINNING OF DPDTAP--') 18697 CALL DPWRST('XXX','WRIT') 18698 WRITE(ICOUT,52)IBUGA3,ISUBRO,NRET 18699 52 FORMAT('IBUGA3,ISUBRO,NRET = ',A4,2X,A4,2X,I8) 18700 CALL DPWRST('XXX','WRIT') 18701 WRITE(ICOUT,53)ALOC,ASCALE,DG,XR,ALAMB 18702 53 FORMAT('ALOC,ASCALE,DG,XR,ALAMB = ',5G15.7) 18703 CALL DPWRST('XXX','WRIT') 18704 DO56I=1,NRET 18705 WRITE(ICOUT,57)I,R(I) 18706 57 FORMAT('I,R(I) = ',I8,G15.7) 18707 CALL DPWRST('XXX','WRIT') 18708 56 CONTINUE 18709 ENDIF 18710C 18711 NUMLIN=2 18712 NUMCOL=2 18713 ITITL2(1,1)='Mean Recurrence' 18714 ITITL2(2,1)='Interval (R)' 18715 NCTIT2(1,1)=15 18716 NCTIT2(2,1)=12 18717 ITITL2(1,2)=' ' 18718 ITITL2(2,2)='XR' 18719 NCTIT2(1,2)=0 18720 NCTIT2(2,2)=2 18721C 18722 NMAX=0 18723 DO2521I=1,NUMCOL 18724 VALIGN(I)='b' 18725 ALIGN(I)='r' 18726 NTOT(I)=15 18727 NMAX=NMAX+NTOT(I) 18728 IDIGIT(I)=NUMDIG 18729 2521 CONTINUE 18730 IDIGIT(1)=2 18731 DO2523I=1,NRET 18732 NCTEXT(I)=0 18733 AMAT(I,1)=R(I) 18734 DXR=DBLE(ALOC) - DBLE(ASCALE)* 18735 1 (1.0D0 - (DBLE(ALAMB*R(I)))**DG)/DG 18736 XR=REAL(DXR) 18737 AMAT(I,2)=REAL(DXR) 18738 2523 CONTINUE 18739 IWHTML(1)=200 18740 IWHTML(2)=200 18741 IWHTML(3)=200 18742 IWRTF(1)=2000 18743 IWRTF(2)=IWRTF(1)+2000 18744C 18745 ITITLE=' ' 18746 NCTITL=0 18747 ITITLZ=' ' 18748 NCTITZ=0 18749 IFRST=.TRUE. 18750 ILAST=.TRUE. 18751 CALL DPDTA2(ITITLE,NCTITL, 18752 1 ITITLZ,NCTITZ,ITITL2,NCTIT2, 18753 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 18754 1 ITEXT,NCTEXT,AMAT,MAXROW,NRET, 18755 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 18756 1 ICAPSW,ICAPTY,IFRST,ILAST, 18757 1 ISUBRO,IBUGA3,IERROR) 18758C 18759C ***************** 18760C ** STEP 90-- ** 18761C ** EXIT ** 18762C ***************** 18763C 18764 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTAP')THEN 18765 WRITE(ICOUT,999) 18766 CALL DPWRST('XXX','WRIT') 18767 WRITE(ICOUT,9011) 18768 9011 FORMAT('***** AT THE END OF DPDTAP--') 18769 CALL DPWRST('XXX','WRIT') 18770 ENDIF 18771C 18772 RETURN 18773 END 18774 SUBROUTINE DPDT11(CONF,T,TSDM,ALOWER,AUPPER, 18775 1 ICASAN,ICAPSW,ICAPTY,NUMDIG, 18776 1 ISUBRO,IBUGA3,IERROR) 18777C 18778C PURPOSE--THIS ROUTINE PRINTS THE CONFIDENCE INTERVAL TABLES 18779C FOR THE FOLLOWING COMMANDS: 18780C 18781C 1) CONFIDENCE LIMITS FOR THE MEAN 18782C 2) CONFIDENCE LIMITS FOR THE DIFFERENCE OF THE MEANS 18783C 3) CONFIDENCE LIMITS FOR BIWEIGHT LOCATION 18784C 4) CONFIDENCE LIMITS FOR TRIMMED MEAN 18785C 5) CONFIDENCE LIMITS FOR MEDIAN/QUANTILES 18786C 6) CONFIDENCE LIMITS FOR CORRELATION COEFFICIENT 18787C 7) CONFIDENCE LIMITS FOR HEDGES G 18788C 8) CONFIDENCE LIMITS FOR THE RATIO OF THE MEANS 18789C 18790C WRITTEN BY--ALAN HECKERT 18791C STATISTICAL ENGINEERING DIVISION 18792C INFORMATION TECHNOLOGY LABORATORY 18793C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 18794C GAITHERSBURG, MD 20899-8980 18795C PHONE--301-975-2899 18796C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 18797C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 18798C LANGUAGE--ANSI FORTRAN (1977) 18799C VERSION NUMBER--2010/03 18800C ORIGINAL VERSION--MARCH 2010. EXTRACTED AS DISTINCT SUBROUTINE 18801C UPDATED --JUNE 2012. SUPPORT FOR CORRELATION COEFFICIENT 18802C UPDATED --APRIL 2013. SUPPORT FOR LOWER/UPPER INTERVALS 18803C UPDATED --AUGUST 2018. HEDGES G 18804C UPDATED --OCTOBER 2019. RATIO OF MEANS 18805C 18806C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 18807C 18808 CHARACTER*4 ICASAN 18809 CHARACTER*4 ICAPSW 18810 CHARACTER*4 ICAPTY 18811 CHARACTER*4 ISUBRO 18812 CHARACTER*4 IBUGA3 18813 CHARACTER*4 IERROR 18814C 18815 CHARACTER*4 ISUBN1 18816 CHARACTER*4 ISUBN2 18817 CHARACTER*4 ISTEPN 18818 CHARACTER*4 ICASA2 18819C 18820C--------------------------------------------------------------------- 18821C 18822 DIMENSION CONF(*) 18823 DIMENSION T(*) 18824 DIMENSION TSDM(*) 18825 DIMENSION ALOWER(*) 18826 DIMENSION AUPPER(*) 18827C 18828 INCLUDE 'DPCOST.INC' 18829C 18830 PARAMETER (MAXCNF=8) 18831 PARAMETER (MAXROW=10) 18832 CHARACTER*60 ITITLE 18833 CHARACTER*60 ITITL9 18834 CHARACTER*4 ALIGN(MAXCNF) 18835 CHARACTER*4 VALIGN(MAXCNF) 18836 INTEGER IDIGIT(MAXROW) 18837 INTEGER NTOT(MAXROW) 18838C 18839 PARAMETER(NUMCLI=5) 18840 PARAMETER(MAXLIN=2) 18841 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 18842 CHARACTER*15 IVALUE(MAXROW,NUMCLI) 18843 CHARACTER*4 ITYPCO(NUMCLI) 18844 INTEGER NCTIT2(MAXLIN,NUMCLI) 18845 INTEGER NCVALU(MAXROW,NUMCLI) 18846 INTEGER IWHTML(NUMCLI) 18847 INTEGER IWRTF(NUMCLI) 18848 REAL AMAT(MAXROW,NUMCLI) 18849C 18850 LOGICAL IFRST 18851 LOGICAL ILAST 18852C 18853C--------------------------------------------------------------------- 18854C 18855 INCLUDE 'DPCOP2.INC' 18856C 18857C-----START POINT----------------------------------------------------- 18858C 18859 ISUBN1='DPDT' 18860 ISUBN2='11 ' 18861 IERROR='NO' 18862C 18863 ICASA2='TWOS' 18864 IF(ALOWER(1).EQ.CPUMIN)ICASA2='UPPE' 18865 IF(AUPPER(1).EQ.CPUMIN)ICASA2='LOWE' 18866 IF(ICASAN.EQ.'MRC2')ICASA2='TWOS' 18867C 18868 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DT11')THEN 18869 WRITE(ICOUT,999) 18870 999 FORMAT(1X) 18871 CALL DPWRST('XXX','WRIT') 18872 WRITE(ICOUT,51) 18873 51 FORMAT('**** AT THE BEGINNING OF DPDT11--') 18874 CALL DPWRST('XXX','WRIT') 18875 WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASA2 18876 52 FORMAT('IBUGA3,ISUBRO,ICASA2 = ',3(A4,2X),I5) 18877 CALL DPWRST('XXX','WRIT') 18878 DO56I=1,8 18879 WRITE(ICOUT,57)I,CONF(I),T(I),TSDM(I),ALOWER(I),AUPPER(I) 18880 57 FORMAT('I,CONF(I),T(I),TSDM(I),ALOWER(I),AUPPER(I) = ', 18881 1 I8,5G15.7) 18882 CALL DPWRST('XXX','WRIT') 18883 56 CONTINUE 18884 ENDIF 18885C 18886 ITITLE=' ' 18887 NCTITL=0 18888 ITITL9=' ' 18889 NCTIT9=0 18890 NUMLIN=2 18891 NUMROW=8 18892 NUMCOL=5 18893C 18894 IF(ICASAN.EQ.'QUC2')THEN 18895 ITITL9='Hettmansperger-Sheater Median Confidence Limits' 18896 NCTIT9=47 18897 NUMCOL=3 18898 ELSEIF(ICASAN.EQ.'CORR')THEN 18899 NUMCOL=4 18900 NUMROW=7 18901 ELSEIF(ICASAN.EQ.'HEDG')THEN 18902 NUMCOL=5 18903 NUMROW=7 18904 ELSEIF(ICASAN.EQ.'MRC2')THEN 18905 NUMCOL=4 18906 ENDIF 18907 IF(ICASA2.EQ.'LOWE' .OR. ICASA2.EQ.'UPPE')NUMCOL=NUMCOL-1 18908C 18909 ICNT=1 18910 ITITL2(1,ICNT)='Confidence' 18911 NCTIT2(1,ICNT)=10 18912 ITITL2(2,ICNT)='Value (%)' 18913 NCTIT2(2,ICNT)=9 18914 IF(ICASAN.EQ.'QUCI' .OR. ICASAN.EQ.'MECI')THEN 18915 ICNT=ICNT+1 18916 ITITL2(1,ICNT)='Z' 18917 NCTIT2(1,ICNT)=1 18918 ITITL2(2,ICNT)='Value' 18919 NCTIT2(2,ICNT)=5 18920 ICNT=ICNT+1 18921 ITITL2(1,ICNT)='Z-Value X' 18922 NCTIT2(1,ICNT)=9 18923 ITITL2(2,ICNT)='StdErr' 18924 NCTIT2(2,ICNT)=6 18925 ELSEIF(ICASAN.EQ.'CONF' .OR. ICASAN.EQ.'BWCO' .OR. 18926 1 ICASAN.EQ.'TMCO' .OR. ICASAN.EQ.'CON2')THEN 18927 ICNT=ICNT+1 18928 ITITL2(1,ICNT)='t' 18929 NCTIT2(1,ICNT)=1 18930 ITITL2(2,ICNT)='Value' 18931 NCTIT2(2,ICNT)=5 18932 ICNT=ICNT+1 18933 ITITL2(1,ICNT)='t-Value X' 18934 NCTIT2(1,ICNT)=9 18935 IF(ICASAN.EQ.'CONF')THEN 18936 ITITL2(2,ICNT)='SD(Mean)' 18937 NCTIT2(2,ICNT)=8 18938 ELSE 18939 ITITL2(2,3)='StdErr' 18940 NCTIT2(2,3)=6 18941 ENDIF 18942 ELSEIF(ICASAN.EQ.'HEDG')THEN 18943 ICNT=ICNT+1 18944 ITITL2(1,ICNT)='Z' 18945 NCTIT2(1,ICNT)=1 18946 ITITL2(2,ICNT)='Value' 18947 NCTIT2(2,ICNT)=5 18948 ICNT=ICNT+1 18949 ITITL2(1,ICNT)='Z-Value X' 18950 NCTIT2(1,ICNT)=9 18951 ITITL2(2,ICNT)='StdErr' 18952 NCTIT2(2,ICNT)=6 18953 ELSEIF(ICASAN.EQ.'CORR')THEN 18954 ICNT=ICNT+1 18955 ITITL2(1,ICNT)='Normal' 18956 NCTIT2(1,ICNT)=6 18957 ITITL2(2,ICNT)='Value' 18958 NCTIT2(2,ICNT)=5 18959 ELSEIF(ICASAN.EQ.'MRC2')THEN 18960 ICNT=ICNT+1 18961 ITITL2(1,ICNT)=' ' 18962 NCTIT2(1,ICNT)=1 18963 ITITL2(2,ICNT)='Ratio' 18964 NCTIT2(2,ICNT)=5 18965 ENDIF 18966 IF(ICASA2.EQ.'TWOS' .OR. ICASA2.EQ.'LOWE')THEN 18967 ICNT=ICNT+1 18968 ITITL2(1,ICNT)='Lower' 18969 NCTIT2(1,ICNT)=5 18970 ITITL2(2,ICNT)='Limit' 18971 NCTIT2(2,ICNT)=5 18972 ENDIF 18973 IF(ICASA2.EQ.'TWOS' .OR. ICASA2.EQ.'UPPE')THEN 18974 ICNT=ICNT+1 18975 ITITL2(1,ICNT)='Upper' 18976 NCTIT2(1,ICNT)=5 18977 ITITL2(2,ICNT)='Limit' 18978 NCTIT2(2,ICNT)=5 18979 ENDIF 18980C 18981 NMAX=0 18982 DO4221I=1,NUMCOL 18983 VALIGN(I)='b' 18984 ALIGN(I)='r' 18985 NTOT(I)=15 18986 IDIGIT(I)=NUMDIG 18987 ITYPCO(I)='NUME' 18988 IWHTML(I)=150 18989 IF(I.EQ.1)THEN 18990 NTOT(I)=12 18991 IDIGIT(I)=3 18992 IWHTML(1)=75 18993 ELSEIF(I.EQ.2 .AND. ICASAN.NE.'MRC2')THEN 18994 NTOT(I)=8 18995 IDIGIT(I)=3 18996 IWHTML(I)=75 18997 ENDIF 18998 NMAX=NMAX+NTOT(I) 18999 4221 CONTINUE 19000 DO4223I=1,NUMROW 19001 DO4225J=1,NUMCOL 19002 NCVALU(I,J)=0 19003 IVALUE(I,J)=' ' 19004 AMAT(I,J)=0.0 19005 4225 CONTINUE 19006 JCNT=1 19007 AMAT(I,JCNT)=CONF(I) 19008 IF(ICASAN.EQ.'CORR')THEN 19009 JCNT=JCNT+1 19010 AMAT(I,JCNT)=T(I) 19011 ELSEIF(ICASAN.EQ.'MRC2')THEN 19012 JCNT=JCNT+1 19013 AMAT(I,JCNT)=TSDM(I) 19014 ELSEIF(ICASAN.NE.'QUC2')THEN 19015 JCNT=JCNT+1 19016 AMAT(I,JCNT)=T(I) 19017 JCNT=JCNT+1 19018 AMAT(I,JCNT)=TSDM(I) 19019 ENDIF 19020 IF(ICASA2.EQ.'TWOS' .OR. ICASA2.EQ.'LOWE')THEN 19021 JCNT=JCNT+1 19022 AMAT(I,JCNT)=ALOWER(I) 19023 ENDIF 19024 IF(ICASA2.EQ.'TWOS' .OR. ICASA2.EQ.'UPPE')THEN 19025 JCNT=JCNT+1 19026 AMAT(I,JCNT)=AUPPER(I) 19027 ENDIF 19028 4223 CONTINUE 19029C 19030 IWRTF(1)=800 19031 IWRTF(2)=IWRTF(1)+800 19032 IWRTF(3)=IWRTF(2)+2000 19033 IWRTF(4)=IWRTF(2)+2000 19034 IWRTF(5)=IWRTF(2)+2000 19035 IFRST=.TRUE. 19036 ILAST=.TRUE. 19037C 19038 ISTEPN='5C' 19039 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2') 19040 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19041C 19042 CALL DPDTA4(ITITL9,NCTIT9, 19043 1 ITITLE,NCTITL,ITITL2,NCTIT2, 19044 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 19045 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW, 19046 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 19047 1 ICAPSW,ICAPTY,IFRST,ILAST, 19048 1 ISUBRO,IBUGA3,IERROR) 19049C 19050C ***************** 19051C ** STEP 90-- ** 19052C ** EXIT ** 19053C ***************** 19054C 19055 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DT11')THEN 19056 WRITE(ICOUT,999) 19057 CALL DPWRST('XXX','WRIT') 19058 WRITE(ICOUT,9011) 19059 9011 FORMAT('***** AT THE END OF DPDT11--') 19060 CALL DPWRST('XXX','WRIT') 19061 ENDIF 19062C 19063 RETURN 19064 END 19065 SUBROUTINE DPDTLA(ISTRIN,NCIN,NCT, 19066 1 ISUBRO,IBUGA3,IERROR) 19067C 19068C PURPOSE--UTILITY ROUTINE USED BY THE TABLE PRINTING ROUTINES 19069C (DPDTA1, DPDTA2, DPDTA4, DPDTA5, DPDT5B). FOR LATEX 19070C OUTPUT, IT CHECKS FOR CERTAIN CHARACTERS AND ADDS 19071C APPROPRIATE ESCAPE SEQUENCES. CURRENTLY, THE 19072C CHARACTERS CHECKED ARE: 19073C 19074C 1) % 19075C 2) < 19076C 3) > 19077C 4) ! 19078C 5) * 19079C 19080C ISTRIN => INPUT STRING, MAY BE MODIFIED ON OUTPUT 19081C NCIN => NUMBER OF CHARACTERS FOR ISTRIN 19082C NCT => NUMBER OF CHARACTERS ON OUTPUT 19083C 19084C WRITTEN BY--ALAN HECKERT 19085C STATISTICAL ENGINEERING DIVISION 19086C INFORMATION TECHNOLOGY LABORATORY 19087C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 19088C GAITHERSBURG, MD 20899-8980 19089C PHONE--301-975-2899 19090C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 19091C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 19092C LANGUAGE--ANSI FORTRAN (1977) 19093C VERSION NUMBER--2011/1 19094C ORIGINAL VERSION--JANUARY 2011. 19095C 19096C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19097C 19098 CHARACTER*(*) ISTRIN 19099 CHARACTER*4 IBUGA3 19100 CHARACTER*4 ISUBRO 19101 CHARACTER*4 IERROR 19102C 19103 CHARACTER*1 IBASLC 19104C 19105C--------------------------------------------------------------------- 19106C 19107 INCLUDE 'DPCOP2.INC' 19108C 19109C-----START POINT----------------------------------------------------- 19110C 19111 IERROR='NO' 19112C 19113 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTLA')THEN 19114 WRITE(ICOUT,999) 19115 999 FORMAT(1X) 19116 CALL DPWRST('XXX','WRIT') 19117 WRITE(ICOUT,51) 19118 51 FORMAT('**** AT THE BEGINNING OF DPDTLA--') 19119 CALL DPWRST('XXX','WRIT') 19120 WRITE(ICOUT,52)IBUGA3,ISUBRO 19121 52 FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4) 19122 CALL DPWRST('XXX','WRIT') 19123 WRITE(ICOUT,53)NCIN,ISTRIN(1:NCIN) 19124 53 FORMAT('NCIN,ISTRIN = ',I8,2X,A) 19125 ENDIF 19126C 19127C FOR LATEX, NEED TO CHECK FOR ANY CHARACTERS THAT 19128C NEED TO BE "ESCAPED". 19129C 19130C CHECK FOR <= OR >= AND CONVERT TO LATEX 19131C FORMAT (\le or \ge) 19132C 19133 CALL DPCONA(92,IBASLC) 19134 NCT=NCIN 19135 DO1010II=NCIN,1,-1 19136 IF(ISTRIN(II:II).EQ.'%')THEN 19137 DO1020J=NCT,II,-1 19138 ISTRIN(J+1:J+1)=ISTRIN(J:J) 19139 1020 CONTINUE 19140 NCT=NCT+1 19141 ISTRIN(II:II)=IBASLC 19142 ELSEIF(ISTRIN(II:II).EQ.'|' .OR. 19143 1 ISTRIN(II:II).EQ.'*')THEN 19144 DO1030J=NCT,II+1,-1 19145 ISTRIN(J+2:J+2)=ISTRIN(J:J) 19146 1030 CONTINUE 19147 ISTRIN(II+1:II+1)=ISTRIN(II:II) 19148 NCT=NCT+2 19149 ISTRIN(II:II)='$' 19150 ISTRIN(II+2:II+2)='$' 19151 ELSEIF(ISTRIN(II:II).EQ.'<' .OR. 19152 1 ISTRIN(II:II).EQ.'>')THEN 19153 IF(ISTRIN(II+1:II+1).EQ.'=')THEN 19154 DO1040J=NCT,II+2,-1 19155 ISTRIN(J+4:J+4)=ISTRIN(J:J) 19156 1040 CONTINUE 19157 IF(ISTRIN(II:II).EQ.'<')THEN 19158 ISTRIN(II:II+5)='$ le$ ' 19159 ISTRIN(II+1:II+1)=IBASLC 19160 ELSEIF(ISTRIN(II:II).EQ.'>')THEN 19161 ISTRIN(II:II+5)='$ ge$ ' 19162 ISTRIN(II+1:II+1)=IBASLC 19163 ENDIF 19164 NCT=NCT+4 19165 ELSE 19166 DO1050J=NCT,II+1,-1 19167 ISTRIN(J+2:J+2)=ISTRIN(J:J) 19168 1050 CONTINUE 19169 ISTRIN(II+1:II+1)=ISTRIN(II:II) 19170 NCT=NCT+2 19171 ISTRIN(II:II)='$' 19172 ISTRIN(II+2:II+2)='$' 19173 ENDIF 19174 ENDIF 19175 1010 CONTINUE 19176C 19177 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTLA')THEN 19178 WRITE(ICOUT,999) 19179 CALL DPWRST('XXX','WRIT') 19180 WRITE(ICOUT,9051) 19181 9051 FORMAT('**** AT THE END OF DPDTLA--') 19182 CALL DPWRST('XXX','WRIT') 19183 WRITE(ICOUT,9053)NCT,ISTRIN(1:NCT) 19184 9053 FORMAT('NCT,ISTRIN = ',I8,2X,A) 19185 ENDIF 19186C 19187 RETURN 19188 END 19189 SUBROUTINE DPDTRT(ISTRIN,NCIN,NCT, 19190 1 ISUBRO,IBUGA3,IERROR) 19191C 19192C PURPOSE--UTILITY ROUTINE USED BY THE TABLE PRINTING ROUTINES 19193C (DPDTA1, DPDTA2, DPDTA4, DPDTA5, DPDT5B). FOR RTF 19194C OUTPUT, IT CHECKS FOR CERTAIN CHARACTERS AND ADDS 19195C APPROPRIATE ESCAPE SEQUENCES. CURRENTLY, THE 19196C CHARACTERS CHECKED ARE: 19197C 19198C 1) | 19199C 19200C ISTRIN => INPUT STRING, MAY BE MODIFIED ON OUTPUT 19201C NCIN => NUMBER OF CHARACTERS FOR ISTRIN 19202C NCT => NUMBER OF CHARACTERS ON OUTPUT 19203C 19204C WRITTEN BY--ALAN HECKERT 19205C STATISTICAL ENGINEERING DIVISION 19206C INFORMATION TECHNOLOGY LABORATORY 19207C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 19208C GAITHERSBURG, MD 20899-8980 19209C PHONE--301-975-2899 19210C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 19211C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 19212C LANGUAGE--ANSI FORTRAN (1977) 19213C VERSION NUMBER--2011/1 19214C ORIGINAL VERSION--JANUARY 2011. 19215C 19216C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19217C 19218 CHARACTER*(*) ISTRIN 19219 CHARACTER*4 IBUGA3 19220 CHARACTER*4 ISUBRO 19221 CHARACTER*4 IERROR 19222C 19223 CHARACTER*1 IBASLC 19224 CHARACTER*1 IQUOTE 19225C 19226C--------------------------------------------------------------------- 19227C 19228 INCLUDE 'DPCOP2.INC' 19229C 19230C-----START POINT----------------------------------------------------- 19231C 19232 IERROR='NO' 19233C 19234 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTRT')THEN 19235 WRITE(ICOUT,999) 19236 999 FORMAT(1X) 19237 CALL DPWRST('XXX','WRIT') 19238 WRITE(ICOUT,51) 19239 51 FORMAT('**** AT THE BEGINNING OF DPDTRT--') 19240 CALL DPWRST('XXX','WRIT') 19241 WRITE(ICOUT,52)IBUGA3,ISUBRO 19242 52 FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4) 19243 CALL DPWRST('XXX','WRIT') 19244 WRITE(ICOUT,53)NCIN,ISTRIN(1:NCIN) 19245 53 FORMAT('NCIN,ISTRIN = ',I8,2X,A) 19246 ENDIF 19247C 19248C FOR RTF, NEED TO CHECK FOR ANY CHARACTERS THAT 19249C NEED TO BE "ESCAPED". 19250C 19251C CURRENTLY, REPLACE "|" WITH "\'7C" (7C IS THE HEXADECIMAL 19252C REPRESENTATION FOR A VERTICAL LINE). 19253C 19254 CALL DPCONA(92,IBASLC) 19255 CALL DPCONA(39,IQUOTE) 19256 NCT=NCIN 19257 DO1010II=NCIN,1,-1 19258 IF(ISTRIN(II:II).EQ.'|')THEN 19259 DO1030J=NCT,II+1,-1 19260 ISTRIN(J+3:J+3)=ISTRIN(J:J) 19261 1030 CONTINUE 19262 NCT=NCT+3 19263 ISTRIN(II:II)=IBASLC 19264 ISTRIN(II+1:II+1)=IQUOTE 19265 ISTRIN(II+2:II+3)='7C' 19266 ENDIF 19267 1010 CONTINUE 19268C 19269 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTRT')THEN 19270 WRITE(ICOUT,999) 19271 CALL DPWRST('XXX','WRIT') 19272 WRITE(ICOUT,9051) 19273 9051 FORMAT('**** AT THE END OF DPDTRT--') 19274 CALL DPWRST('XXX','WRIT') 19275 WRITE(ICOUT,9053)NCT,ISTRIN(1:NCT) 19276 9053 FORMAT('NCT,ISTRIN = ',I8,2X,A) 19277 ENDIF 19278C 19279 RETURN 19280 END 19281 SUBROUTINE DPDTXT(ITEXT,NCTEXT,AVALUE,IDIGIT, 19282 1 NTOTAL,NBLNK1,NBLNK2,IFLAG1,IFLAG2,ISIZE, 19283 1 ICAPSW,ICAPTY,ITYPE, 19284 1 ISUBRO,IBUGA3,IERROR) 19285C 19286C PURPOSE--THIS ROUTINE PRINTS A TEXT LINE IN HTML/LATEX/RTF/ASCII 19287C FORMATS. 19288C 19289C THIS IS USED TO PRINT INDIVIDUAL TEXT LINES (E.G., 19290C A HEADER LINE OR SOME LINES OF TEXT AFTER A TABLE). 19291C 19292C FOR MULTI-LINE CASE, SPECIFY IFLAG1 = TRUE IF FIRST LINE 19293C IFLAG2 = TRUE IF LAST LINE. 19294C 19295C WRITTEN BY--ALAN HECKERT 19296C STATISTICAL ENGINEERING DIVISION 19297C INFORMATION TECHNOLOGY LABORATORY 19298C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 19299C GAITHERSBURG, MD 20899-8980 19300C PHONE--301-975-2899 19301C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 19302C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 19303C LANGUAGE--ANSI FORTRAN (1977) 19304C VERSION NUMBER--2012/1 19305C ORIGINAL VERSION--JANUARY 2012. 19306C UPDATED --JUNE 2015. ADD ITYPE = 3. THIS IS 19307C EQUIVALENT TO ITYPE = 2, BUT 19308C FOR LATEX IT WILL NOT ENCLOSE 19309C THE TEXT WITHIN A "TABLE" 19310C STRUCTURE 19311C 19312C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19313C 19314 CHARACTER*(*) ITEXT 19315 REAL AVALUE 19316 INTEGER IDIGIT 19317C 19318 CHARACTER*4 ICAPSW 19319 CHARACTER*4 ICAPTY 19320 CHARACTER*4 ISUBRO 19321 CHARACTER*4 IBUGA3 19322 CHARACTER*4 IERROR 19323C 19324 CHARACTER*4 ISUBN1 19325 CHARACTER*4 ISUBN2 19326 CHARACTER*4 ISTEPN 19327 CHARACTER*20 IFORMT 19328 CHARACTER*1 IBASLC 19329C 19330 LOGICAL IFLAG1 19331 LOGICAL IFLAG2 19332 LOGICAL IFLAGA 19333 LOGICAL IFLAGB 19334C 19335C--------------------------------------------------------------------- 19336C 19337 INCLUDE 'DPCOST.INC' 19338C 19339 PARAMETER (MAXHED=1024) 19340 INTEGER IWIDTH(MAXHED) 19341 INTEGER NUMDIG(MAXHED) 19342 CHARACTER*8 ALIGN(MAXHED) 19343 CHARACTER*8 VALIGN(MAXHED) 19344 COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN 19345 CHARACTER*132 IHEAD 19346C 19347 CHARACTER*4 IRTFMD 19348 COMMON/COMRTF/IRTFMD 19349C 19350C--------------------------------------------------------------------- 19351C 19352 INCLUDE 'DPCOP2.INC' 19353C 19354C-----START POINT----------------------------------------------------- 19355C 19356 ISUBN1='DPDT' 19357 ISUBN2='XT ' 19358 IERROR='NO' 19359C 19360 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTXT')THEN 19361 WRITE(ICOUT,999) 19362 999 FORMAT(1X) 19363 CALL DPWRST('XXX','WRIT') 19364 WRITE(ICOUT,51) 19365 51 FORMAT('**** AT THE BEGINNING OF DPDTXT--') 19366 CALL DPWRST('XXX','WRIT') 19367 WRITE(ICOUT,52)IBUGA3,ISUBRO,AVALUE 19368 52 FORMAT('IBUGA3,ISUBRO,AVALUE = ',2(A4,2X),G15.7) 19369 CALL DPWRST('XXX','WRIT') 19370 IF(NCTEXT.GT.0)THEN 19371 WRITE(ICOUT,57)ITEXT(1:NCTEXT) 19372 57 FORMAT('ITEXT = ',A80) 19373 CALL DPWRST('XXX','WRIT') 19374 ENDIF 19375 ENDIF 19376C 19377C ******************************************* 19378C ** STEP 1-- ** 19379C ** WRITE OUT THE TITLE AND HEADER LINE ** 19380C ******************************************* 19381C 19382 ISTEPN='1' 19383 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DTXT') 19384 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19385C 19386 IF(IPRINT.EQ.'ON')THEN 19387C 19388C PRELIMINARY CODE IF FIRST LINE 19389C 19390 IF(IFLAG1)THEN 19391 IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN 19392 WRITE(ICOUT,2116) 19393 2116 FORMAT('</PRE>') 19394 CALL DPWRST('XXX','WRIT') 19395 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN 19396 IJUNK=92 19397 CALL DPCONA(IJUNK,IBASLC) 19398 WRITE(ICOUT,2126)IBASLC 19399 2126 FORMAT(A1,'end{verbatim}') 19400 CALL DPWRST('XXX','WRIT') 19401 IF(ISIZE.EQ.-1)THEN 19402 WRITE(ICOUT,2127)IBASLC 19403 2127 FORMAT(A1,'small') 19404 CALL DPWRST('XXX','WRIT') 19405 ELSEIF(ISIZE.EQ.-2)THEN 19406 WRITE(ICOUT,2128)IBASLC 19407 2128 FORMAT(A1,'tiny') 19408 CALL DPWRST('XXX','WRIT') 19409 ELSEIF(ISIZE.EQ.0)THEN 19410 WRITE(ICOUT,2130)IBASLC 19411 2130 FORMAT(A1,'normalsize') 19412 CALL DPWRST('XXX','WRIT') 19413 ENDIF 19414 IF(ITYPE.NE.3)THEN 19415 WRITE(ICOUT,2129)IBASLC 19416 2129 FORMAT(A1,'begin{table}') 19417 CALL DPWRST('XXX','WRIT') 19418 ENDIF 19419 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN 19420 ELSE 19421 ENDIF 19422 ENDIF 19423C 19424C CASE 1: A HEADER LINE 19425C 19426 IF(ITYPE.EQ.1 .AND. NCTEXT.GT.0)THEN 19427 IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN 19428 WRITE(ICOUT,1001) 19429 1001 FORMAT('<CENTER><H2>') 19430 CALL DPWRST('XXX','WRIT') 19431 IFORMT=' ' 19432 IFORMT='(A )' 19433 WRITE(IFORMT(3:4),'(I2)')NCTEXT 19434 WRITE(ICOUT,IFORMT)ITEXT(1:NCTEXT) 19435 CALL DPWRST('XXX','WRIT') 19436 WRITE(ICOUT,1004) 19437 1004 FORMAT('</H2></CENTER><BR><BR>') 19438 CALL DPWRST('XXX','WRIT') 19439 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN 19440 IFLAGA=.FALSE. 19441 IFLAGB=.TRUE. 19442 CALL DPLAT8(ITEXT,NCTEXT,IFLAGA,IFLAGB) 19443 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN 19444 IF(IRTFFP.EQ.'Times New Roman')THEN 19445 ITEMP=0 19446 ELSEIF(IRTFFP.EQ.'Lucida Sans')THEN 19447 ITEMP=6 19448 ELSEIF(IRTFFP.EQ.'Arial')THEN 19449 ITEMP=2 19450 ELSEIF(IRTFFP.EQ.'Bookman')THEN 19451 ITEMP=3 19452 ELSEIF(IRTFFP.EQ.'Georgia')THEN 19453 ITEMP=4 19454 ELSEIF(IRTFFP.EQ.'Tahoma')THEN 19455 ITEMP=5 19456 ELSEIF(IRTFFP.EQ.'Verdana')THEN 19457 ITEMP=7 19458 ELSE 19459 ITEMP=0 19460 ENDIF 19461C 19462 IRTFMD='OFF' 19463 IFLAG1=.TRUE. 19464 CALL DPRTF8(ITEXT,NCTEXT,ITEMP,IFLAG1) 19465 NHEAD=0 19466 ELSE 19467 IF(NBLNK1.GT.0)THEN 19468 DO1010I=1,NBLNK1 19469 WRITE(ICOUT,999) 19470 CALL DPWRST('XXX','WRIT') 19471 1010 CONTINUE 19472 ENDIF 19473 IFORMT=' ' 19474 IFORMT='(6X,A )' 19475 WRITE(IFORMT(6:7),'(I2)')NCTEXT 19476 WRITE(ICOUT,IFORMT)ITEXT(1:NCTEXT) 19477 CALL DPWRST('XXX','WRIT') 19478 WRITE(ICOUT,999) 19479 CALL DPWRST('XXX','WRIT') 19480 WRITE(ICOUT,999) 19481 CALL DPWRST('XXX','WRIT') 19482 IF(NBLNK2.GT.0)THEN 19483 DO1020I=1,NBLNK2 19484 WRITE(ICOUT,999) 19485 CALL DPWRST('XXX','WRIT') 19486 1020 CONTINUE 19487 ENDIF 19488 ENDIF 19489C 19490C CASE 2: SOME TEXT WITH AN OPTIONAL NUMERIC VALUE AT END 19491C 19492 ELSEIF((ITYPE.EQ.2 .OR. ITYPE.EQ.3) .AND. NCTEXT.GT.0)THEN 19493 IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN 19494 IF(NBLNK1.GT.0)THEN 19495 IHEAD=' ' 19496 NCHAR=1 19497 DO2110I=1,NBLNK1 19498 CALL DPHTMW(IHEAD,NCHAR,CPUMIN,IDIGIT) 19499 2110 CONTINUE 19500 ENDIF 19501 CALL DPHTMW(ITEXT,NCTEXT,AVALUE,IDIGIT) 19502 IF(NBLNK2.GT.0)THEN 19503 IHEAD=' ' 19504 NCHAR=1 19505 DO2120I=1,NBLNK2 19506 CALL DPHTMW(IHEAD,NCHAR,CPUMIN,IDIGIT) 19507 2120 CONTINUE 19508 ENDIF 19509 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN 19510 IF(NBLNK1.GT.0)THEN 19511 IHEAD=' ' 19512 NCHAR=1 19513 DO2210I=1,NBLNK1 19514 CALL DPLAT7(IHEAD,NCHAR,CPUMIN,IDIGIT) 19515 2210 CONTINUE 19516 ENDIF 19517 CALL DPLAT7(ITEXT,NCTEXT,AVALUE,IDIGIT) 19518 IF(NBLNK2.GT.0)THEN 19519 IHEAD=' ' 19520 NCHAR=1 19521 DO2220I=1,NBLNK2 19522 CALL DPLAT7(IHEAD,NCHAR,CPUMIN,IDIGIT) 19523 2220 CONTINUE 19524 ENDIF 19525 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN 19526 IF(NBLNK1.GT.0)THEN 19527 IHEAD=' ' 19528 NCHAR=1 19529 DO2310I=1,NBLNK1 19530 CALL DPRTF7(IHEAD,NCHAR,CPUMIN,IDIGIT) 19531 2310 CONTINUE 19532 ENDIF 19533 CALL DPRTF7(ITEXT,NCTEXT,AVALUE,IDIGIT) 19534 IF(NBLNK2.GT.0)THEN 19535 IHEAD=' ' 19536 NCHAR=1 19537 DO2320I=1,NBLNK2 19538 CALL DPRTF7(IHEAD,NCHAR,CPUMIN,IDIGIT) 19539 2320 CONTINUE 19540 ENDIF 19541 ELSE 19542 IF(NBLNK1.GT.0)THEN 19543 DO2410I=1,NBLNK1 19544 WRITE(ICOUT,999) 19545 CALL DPWRST('XXX','WRIT') 19546 2410 CONTINUE 19547 ENDIF 19548C 19549 IF(AVALUE.EQ.CPUMIN)THEN 19550 IFORMT=' ' 19551 IFORMT='(A )' 19552 WRITE(IFORMT(3:4),'(I2)')NCTEXT 19553 WRITE(ICOUT,IFORMT)ITEXT(1:NCTEXT) 19554 CALL DPWRST('XXX','WRIT') 19555 ELSE 19556 NBLANK=NTOTAL-NCTEXT 19557 IFORMT=' ' 19558 IF(IDIGIT.GT.0)THEN 19559 AVALT=RND(AVALUE,IDIGIT) 19560 IXX=IDIGIT 19561 IYY=IXX+8 19562 IF(NBLANK.GT.0)THEN 19563 IFORMT='(A , X,F . )' 19564 WRITE(IFORMT(3:4),'(I2)')NCTEXT 19565 WRITE(IFORMT(6:7),'(I2)')NBLANK 19566 WRITE(IFORMT(11:12),'(I2)')IYY 19567 WRITE(IFORMT(14:15),'(I2)')IXX 19568 ELSE 19569 IFORMT='(A ,F . )' 19570 WRITE(IFORMT(3:4),'(I2)')NCTEXT 19571 WRITE(IFORMT(7:8),'(I2)')IYY 19572 WRITE(IFORMT(10:11),'(I2)')IXX 19573 ENDIF 19574 WRITE(ICOUT,IFORMT)ITEXT(1:NCTEXT),AVALT 19575 CALL DPWRST('XXX','WRIT') 19576 ELSEIF(IDIGIT.LT.0)THEN 19577 NUMDI2=-IDIGIT 19578 AVALT=RND(AVALUE,NUMDI2) 19579 IXX=NUMDI2 19580 IYY=IXX+8 19581 IF(NBLANK.GT.0)THEN 19582 IFORMT='(A , X,EXX.YY)' 19583 WRITE(IFORMT(3:4),'(I2)')NCTEXT 19584 WRITE(IFORMT(6:7),'(I2)')NBLANK 19585 WRITE(IFORMT(11:12),'(I2)')IYY 19586 WRITE(IFORMT(14:15),'(I2)')IXX 19587 ELSE 19588 IFORMT='(A ,GXX.YY)' 19589 WRITE(IFORMT(3:4),'(I2)')NCTEXT 19590 WRITE(IFORMT(7:8),'(I2)')IYY 19591 WRITE(IFORMT(10:11),'(I2)')IXX 19592 ENDIF 19593 WRITE(ICOUT,IFORMT)ITEXT(1:NCTEXT),AVALT 19594 CALL DPWRST('XXX','WRIT') 19595 ELSEIF(IDIGIT.EQ.0)THEN 19596 IVALT=INT(AVALUE + 0.5) 19597 IF(NBLANK.GT.0)THEN 19598 IFORMT='(A , X,I10)' 19599 WRITE(IFORMT(3:4),'(I2)')NCTEXT 19600 WRITE(IFORMT(6:7),'(I2)')NBLANK 19601 ELSE 19602 IFORMT='(A ,I10)' 19603 WRITE(IFORMT(3:4),'(I2)')NCTEXT 19604 ENDIF 19605 WRITE(ICOUT,IFORMT)ITEXT(1:NCTEXT),IVALT 19606 CALL DPWRST('XXX','WRIT') 19607 ENDIF 19608 ENDIF 19609C 19610 IF(NBLNK2.GT.0)THEN 19611 DO2420I=1,NBLNK2 19612 WRITE(ICOUT,999) 19613 CALL DPWRST('XXX','WRIT') 19614 2420 CONTINUE 19615 ENDIF 19616 ENDIF 19617 ENDIF 19618C 19619C ENDING CODE IF LAST LINE 19620C 19621 IF(IFLAG2)THEN 19622 IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN 19623 WRITE(ICOUT,2516) 19624 2516 FORMAT('<PRE>') 19625 CALL DPWRST('XXX','WRIT') 19626 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN 19627 IJUNK=92 19628 CALL DPCONA(IJUNK,IBASLC) 19629 IF(ITYPE.NE.3)THEN 19630 WRITE(ICOUT,2518)IBASLC 19631 2518 FORMAT(A1,'end{table}') 19632 CALL DPWRST('XXX','WRIT') 19633 ENDIF 19634C 19635C ONLY RESTORE NORMAL SIZE IF THIS NOT A SINGLE LINE 19636C 19637 IF(.NOT.IFLAG1)THEN 19638 IF(ISIZE.EQ.0)THEN 19639 WRITE(ICOUT,2526)IBASLC 19640 2526 FORMAT(A1,'normalsize') 19641 CALL DPWRST('XXX','WRIT') 19642 ELSEIF(ISIZE.EQ.-1)THEN 19643 WRITE(ICOUT,2527)IBASLC 19644 2527 FORMAT(A1,'small') 19645 CALL DPWRST('XXX','WRIT') 19646 ELSEIF(ISIZE.EQ.-2)THEN 19647 WRITE(ICOUT,2528)IBASLC 19648 2528 FORMAT(A1,'tiny') 19649 CALL DPWRST('XXX','WRIT') 19650 ENDIF 19651 ENDIF 19652 WRITE(ICOUT,2529)IBASLC 19653 2529 FORMAT(A1,'begin{verbatim}') 19654 CALL DPWRST('XXX','WRIT') 19655 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN 19656 ELSE 19657 ENDIF 19658 ENDIF 19659C 19660 ENDIF 19661C 19662 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DTXT')THEN 19663 WRITE(ICOUT,999) 19664 CALL DPWRST('XXX','WRIT') 19665 WRITE(ICOUT,9011) 19666 9011 FORMAT('**** AT THE END OF DPDTXT--') 19667 CALL DPWRST('XXX','WRIT') 19668 ENDIF 19669C 19670 RETURN 19671 END 19672 SUBROUTINE DPDUAN(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 19673 1 IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR) 19674C 19675C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS THAT WILL 19676C WILL DEFINE A DUANE PLOT (USED IN RELIABILITY) 19677C VERTICAL AXIS = Ti /I 19678C HORIZONTAL AXIS = Ti 19679C WHERE Ti ARE SORTED FAILURE TIMES 19680C WRITTEN BY--ALAN HECKERT 19681C STATISTICAL ENGINEERING DIVISION 19682C INFORMATION TECHNOLOGY LABORATORY 19683C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 19684C GAITHERSBURG, MD 20899-8980 19685C PHONE--301-975-2899 19686C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 19687C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 19688C LANGUAGE--ANSI FORTRAN (1977) 19689C VERSION NUMBER--98/5 19690C ORIGINAL VERSION--MAY 1998. 19691C UPDATED --APRIL 2011. USE DPPAR AND DPPAR3 19692C 19693C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19694C 19695 CHARACTER*4 ICASPL 19696 CHARACTER*4 IAND1 19697 CHARACTER*4 IAND2 19698 CHARACTER*4 IBUGG2 19699 CHARACTER*4 IBUGG3 19700 CHARACTER*4 ISUBRO 19701 CHARACTER*4 IBUGQ 19702 CHARACTER*4 IFOUND 19703 CHARACTER*4 IERROR 19704C 19705 CHARACTER*4 IH 19706 CHARACTER*4 IH2 19707 CHARACTER*4 ISUBN0 19708 CHARACTER*4 ISUBN1 19709 CHARACTER*4 ISUBN2 19710 CHARACTER*4 ISTEPN 19711C 19712 CHARACTER*4 ICASE 19713 PARAMETER (MAXSPN=10) 19714 CHARACTER*40 INAME 19715 CHARACTER*4 IVARN1(MAXSPN) 19716 CHARACTER*4 IVARN2(MAXSPN) 19717 CHARACTER*4 IVARTY(MAXSPN) 19718 REAL PVAR(MAXSPN) 19719 INTEGER ILIS(MAXSPN) 19720 INTEGER NRIGHT(MAXSPN) 19721 INTEGER ICOLR(MAXSPN) 19722C 19723C--------------------------------------------------------------------- 19724C 19725 INCLUDE 'DPCOPA.INC' 19726C 19727 DIMENSION Y1(MAXOBV) 19728 INCLUDE 'DPCOZZ.INC' 19729 EQUIVALENCE (GARBAG(IGARB1),Y1(1)) 19730C 19731C-----COMMON---------------------------------------------------------- 19732C 19733 INCLUDE 'DPCOHO.INC' 19734 INCLUDE 'DPCOHK.INC' 19735 INCLUDE 'DPCODA.INC' 19736 INCLUDE 'DPCOP2.INC' 19737C 19738C-----START POINT----------------------------------------------------- 19739C 19740 IFOUND='NO' 19741 IERROR='NO' 19742 ISUBN1='DPDU' 19743 ISUBN2='AN ' 19744C 19745 MAXCP1=MAXCOL+1 19746 MAXCP2=MAXCOL+2 19747 MAXCP3=MAXCOL+3 19748 MAXCP4=MAXCOL+4 19749 MAXCP5=MAXCOL+5 19750 MAXCP6=MAXCOL+6 19751C 19752 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'DUAN')THEN 19753 WRITE(ICOUT,999) 19754 999 FORMAT(1X) 19755 CALL DPWRST('XXX','BUG ') 19756 WRITE(ICOUT,51) 19757 51 FORMAT('***** AT THE BEGINNING OF DPDUAN--') 19758 CALL DPWRST('XXX','BUG ') 19759 WRITE(ICOUT,52)ICASPL,IAND1,IAND2,MAXCOL 19760 52 FORMAT('ICASPL,IAND1,IAND2,MAXCOL = ',3(A4,2X),I8) 19761 CALL DPWRST('XXX','BUG ') 19762 WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO 19763 53 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4) 19764 CALL DPWRST('XXX','BUG ') 19765 ENDIF 19766C 19767C 19768C ********************************** 19769C ** TREAT THE DUANE PLOT ** 19770C ********************************** 19771C 19772C ******************************************* 19773C ** STEP 1-- ** 19774C ** SEARCH FOR DUANE PLOT ** 19775C ******************************************* 19776C 19777 ISTEPN='11' 19778 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DUAN') 19779 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19780C 19781 IF(NUMARG.GE.1.AND. 19782 1 ICOM.EQ.'DUAN'.AND.IHARG(1).EQ.'PLOT')THEN 19783 ICASPL='DUAN' 19784 ILASTC=1 19785 ELSE 19786 IFOUND='NO' 19787 GOTO9000 19788 ENDIF 19789C 19790 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 19791 IFOUND='YES' 19792C 19793C **************************************** 19794C ** STEP 2-- ** 19795C ** EXTRACT THE VARIABLE LIST ** 19796C **************************************** 19797C 19798 ISTEPN='2' 19799 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DUAN') 19800 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19801C 19802 INAME='DUANE PLOT' 19803 MINNA=1 19804 MAXNA=100 19805 MINN2=2 19806 IFLAGE=1 19807 IFLAGM=1 19808 IFLAGP=0 19809 JMIN=1 19810 JMAX=NUMARG 19811 MINNVA=1 19812 MAXNVA=1 19813C 19814 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 19815 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 19816 1 JMIN,JMAX, 19817 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 19818 1 IVARN1,IVARN2,IVARTY,PVAR, 19819 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 19820 1 MINNVA,MAXNVA, 19821 1 IFLAGM,IFLAGP, 19822 1 IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 19823 IF(IERROR.EQ.'YES')GOTO9000 19824C 19825 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DUAN')THEN 19826 WRITE(ICOUT,999) 19827 CALL DPWRST('XXX','BUG ') 19828 WRITE(ICOUT,281) 19829 281 FORMAT('***** AFTER CALL DPPARS--') 19830 CALL DPWRST('XXX','BUG ') 19831 WRITE(ICOUT,282)NQ,NUMVAR 19832 282 FORMAT('NQ,NUMVAR = ',2I8) 19833 CALL DPWRST('XXX','BUG ') 19834 IF(NUMVAR.GT.0)THEN 19835 DO285I=1,NUMVAR 19836 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 19837 1 ICOLR(I) 19838 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 19839 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 19840 CALL DPWRST('XXX','BUG ') 19841 285 CONTINUE 19842 ENDIF 19843 ENDIF 19844C 19845C EXTRACT THE VARIABLE. 19846C 19847 ICOL=1 19848 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 19849 1 INAME,IVARN1,IVARN2,IVARTY, 19850 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 19851 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 19852 1 MAXCP4,MAXCP5,MAXCP6, 19853 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 19854 1 Y1,Y1,Y1,NS,NS,NS,ICASE, 19855 1 IBUGG3,ISUBRO,IFOUND,IERROR) 19856 IF(IERROR.EQ.'YES')GOTO9000 19857C 19858C ******************************************************** 19859C ** STEP 41-- ** 19860C ** FORM THE VERTICAL AND HORIZONTALAXIS ** 19861C ** VARIABLES (Y(.) AND X(.), RESPECTIVELY)FOR THE ** 19862C ** PLOT. FORM THE CURVE DESIGNATION VARIABLED(.) . ** 19863C ** THIS WILL BE ALL ONES. ** 19864C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** 19865C ** DEFINE THE NUMBER OF PLOT VARIABLES(NPLOTV). ** 19866C ******************************************************** 19867C 19868 ISTEPN='41' 19869 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DUAN') 19870 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19871C 19872 CALL DPDUA2(Y1,NS,ICASPL,MAXN, 19873 1 Y,X,D,NPLOTP,NPLOTV, 19874 1 ALPHA,BETA,XRESSD,XRESDF,CCXY,SDALPH,SDBETA,CCALBE, 19875 1 IBUGG3,ISUBRO,IERROR) 19876C 19877C *************************************** 19878C ** STEP 61-- ** 19879C ** COMPUTE DUANE PLOT STAT ** 19880C ** UPDATE INTERNAL DATAPLOT TABLES ** 19881C *************************************** 19882C 19883 ISTEPN='61' 19884 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DUAN') 19885 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19886C 19887 IH='DPCC' 19888 IH2=' ' 19889 VALUE0=CCXY 19890 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19891 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19892 1IANS,IWIDTH,IBUGG3,IERROR) 19893C 19894 IH='DPA0' 19895 IH2=' ' 19896 VALUE0=ALPHA 19897 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19898 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19899 1IANS,IWIDTH,IBUGG3,IERROR) 19900C 19901 IH='DPA1' 19902 IH2=' ' 19903 VALUE0=BETA 19904 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19905 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19906 1IANS,IWIDTH,IBUGG3,IERROR) 19907C 19908 IH='SDDP' 19909 IH2='A0 ' 19910 VALUE0=SDALPH 19911 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19912 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19913 1IANS,IWIDTH,IBUGG3,IERROR) 19914C 19915 IH='SDDP' 19916 IH2='A1 ' 19917 VALUE0=SDBETA 19918 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19919 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19920 1IANS,IWIDTH,IBUGG3,IERROR) 19921C 19922 IH='DPRE' 19923 IH2='SSD ' 19924 VALUE0=XRESSD 19925 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19926 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19927 1IANS,IWIDTH,IBUGG3,IERROR) 19928C 19929 IH='DPRE' 19930 IH2='SDF ' 19931 VALUE0=XRESDF 19932 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19933 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19934 1IANS,IWIDTH,IBUGG3,IERROR) 19935C 19936C ***************** 19937C ** STEP 90-- ** 19938C ** EXIT ** 19939C ***************** 19940C 19941 9000 CONTINUE 19942 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DUAN')THEN 19943 WRITE(ICOUT,999) 19944 CALL DPWRST('XXX','BUG ') 19945 WRITE(ICOUT,9011) 19946 9011 FORMAT('***** AT THE END OF DPDUAN--') 19947 CALL DPWRST('XXX','BUG ') 19948 WRITE(ICOUT,9012)IFOUND,IERROR 19949 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 19950 CALL DPWRST('XXX','BUG ') 19951 WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 19952 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 19953 1 3I8,2X,2(A4,2X),A4) 19954 CALL DPWRST('XXX','BUG ') 19955 IF(NPLOTP.GT.0)THEN 19956 DO9015I=1,NPLOTP 19957 WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 19958 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) 19959 CALL DPWRST('XXX','BUG ') 19960 9015 CONTINUE 19961 ENDIF 19962 ENDIF 19963C 19964 RETURN 19965 END 19966 SUBROUTINE DPDUA2(Y1,N,ICASPL,MAXN, 19967 1 Y,X,D,NPLOTP,NPLOTV, 19968 1 ALPHA,BETA,XRESSD,XRESDF,CCXY, 19969 1 SDALPH,SDBETA,CCALBE, 19970 1 IBUGG3,ISUBRO,IERROR) 19971C 19972C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS 19973C THAT WILL DEFINE A DUANE PLOT 19974C VERTICAL AXIS = Ti/I 19975C HORIZONTAL AXIS = Ti 19976C INPUT ARGUMENTS--Y1 = THE SINGLE PRECISION VECTOR OF 19977C (UNSORTED) OBSERVATIONS 19978C FOR THE FIRST VARIABLE. 19979C N = THE INTEGER NUMBER OF OBSERVATIONS 19980C IN THE VECTOR X. 19981C CAUTION--THE INPUT VARIABLE Y1(.) WILL BE CHANGED HEREIN 19982C (IT WILL BE SORTED) 19983C WRITTEN BY--ALAN HECKERT 19984C STATISTICAL ENGINEERING DIVISION 19985C INFORMATION TECHNOLOGY LABORATORY 19986C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 19987C GAITHERSBURG, MD 20899-8980 19988C PHONE--301-975-2899 19989C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 19990C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 19991C LANGUAGE--ANSI FORTRAN (1977) 19992C VERSION NUMBER--98/5 19993C ORIGINAL VERSION--MAY 1998. 19994C 19995C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19996C 19997 CHARACTER*4 ICASPL 19998 CHARACTER*4 IBUGG3 19999 CHARACTER*4 ISUBRO 20000 CHARACTER*4 IERROR 20001C 20002 CHARACTER*4 ISUBN0 20003 CHARACTER*4 ISUBN1 20004 CHARACTER*4 ISUBN2 20005C 20006C--------------------------------------------------------------------- 20007C 20008 DIMENSION Y1(*) 20009C 20010 DIMENSION Y(*) 20011 DIMENSION X(*) 20012 DIMENSION D(*) 20013C 20014C--------------------------------------------------------------------- 20015C 20016 INCLUDE 'DPCOP2.INC' 20017C 20018C-----START POINT----------------------------------------------------- 20019C 20020 ISUBN1='DPDU' 20021 ISUBN2='A2 ' 20022 IERROR='NO' 20023C 20024 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'DUA2')THEN 20025 WRITE(ICOUT,999) 20026 999 FORMAT(1X) 20027 CALL DPWRST('XXX','BUG ') 20028 WRITE(ICOUT,51) 20029 51 FORMAT('***** AT THE BEGINNING OF DPDUA2--') 20030 CALL DPWRST('XXX','BUG ') 20031 WRITE(ICOUT,52)IBUGG3,ISUBRO,IERROR 20032 52 FORMAT('IBUGG3,ISUBRO,IERROR = ',2(A4,2X),A4) 20033 CALL DPWRST('XXX','BUG ') 20034 WRITE(ICOUT,53)N,ICASPL,MAXN 20035 53 FORMAT('N,ICASPL,MAXN = ',I8,2X,A4,I8) 20036 CALL DPWRST('XXX','BUG ') 20037 DO55I=1,N 20038 WRITE(ICOUT,56)I,Y1(I) 20039 56 FORMAT('I, Y1(I), = ',I8,G15.7) 20040 CALL DPWRST('XXX','BUG ') 20041 55 CONTINUE 20042 ENDIF 20043C 20044C ******************************************** 20045C ** STEP 1-- ** 20046C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 20047C ******************************************** 20048C 20049 IF(N.LT.2)THEN 20050 WRITE(ICOUT,999) 20051 CALL DPWRST('XXX','BUG ') 20052 WRITE(ICOUT,111) 20053 111 FORMAT('***** ERROR IN DUANE PLOT--') 20054 CALL DPWRST('XXX','BUG ') 20055 WRITE(ICOUT,112) 20056 112 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST TWO;') 20057 CALL DPWRST('XXX','BUG ') 20058 WRITE(ICOUT,114)N 20059 114 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) 20060 CALL DPWRST('XXX','BUG ') 20061 WRITE(ICOUT,999) 20062 CALL DPWRST('XXX','BUG ') 20063 IERROR='YES' 20064 GOTO9000 20065 ENDIF 20066C 20067 HOLD=Y1(1) 20068 DO120I=1,N 20069 IF(Y1(I).NE.HOLD)GOTO129 20070 120 CONTINUE 20071 WRITE(ICOUT,999) 20072 CALL DPWRST('XXX','BUG ') 20073 WRITE(ICOUT,111) 20074 CALL DPWRST('XXX','BUG ') 20075 WRITE(ICOUT,122) 20076 122 FORMAT(' ALL ELEMENTS IN THE THE RESPONSE VARIABLE') 20077 CALL DPWRST('XXX','BUG ') 20078 WRITE(ICOUT,123)HOLD 20079 123 FORMAT(' ARE IDENTICALLY EQUAL TO ',G15.7) 20080 CALL DPWRST('XXX','BUG ') 20081 WRITE(ICOUT,999) 20082 CALL DPWRST('XXX','BUG ') 20083 IERROR='YES' 20084 GOTO9000 20085 129 CONTINUE 20086C 20087C *********************************************** 20088C ** STEP 12-- ** 20089C ** COMPUTE COORDINATES FOR DUANE PLOT ** 20090C ** NOTE--THE LOGGING OF THE 1-F(X) WILL ** 20091C ** NOTE BE DONE HEREIN BUT WILL ** 20092C ** BE DONE IN THE UNDERLYING ** 20093C ** GRAPHICS BY LOG SCALE ** 20094C *********************************************** 20095C 20096C 20097 CALL SORT(Y1,N,Y1) 20098C 20099 AN=N 20100 J=0 20101 DO1100I=1,N 20102 J=J+1 20103 X(J)=Y1(I) 20104 Y(J)=Y1(J)/REAL(J) 20105 D(J)=1.0 20106 1100 CONTINUE 20107 NPLOTP=J 20108C 20109C NOTE: FOR FITTED LINE, NEED TO FIT THE LOGS OF Y AND X 20110C 20111 ISUBN0='DPDU' 20112 DO200I=1,NPLOTP 20113 Y(I)=LOG(Y(I)) 20114 X(I)=LOG(X(I)) 20115 200 CONTINUE 20116 CALL LINFIT(Y,X,NPLOTP, 20117 1 ALPHA,BETA,XRESSD,XRESDF,CCXY,SDALPH,SDBETA,CCALBE, 20118 1 ISUBRO,IBUGG3,IERROR) 20119 DO300I=1,NPLOTP 20120 Y(I)=EXP(Y(I)) 20121 X(I)=EXP(X(I)) 20122 300 CONTINUE 20123 NPLOTP=NPLOTP+1 20124 X(NPLOTP)=X(1) 20125 Y(NPLOTP)=EXP(ALPHA+BETA*LOG(X(1))) 20126 D(NPLOTP)=2.0 20127 NPLOTP=NPLOTP+1 20128 X(NPLOTP)=X(N) 20129 Y(NPLOTP)=EXP(ALPHA+BETA*LOG(X(N))) 20130 D(NPLOTP)=2.0 20131C 20132 NPLOTV=2 20133 GOTO9000 20134C 20135C ****************** 20136C ** STEP 90-- ** 20137C ** EXIT ** 20138C ****************** 20139C 20140 9000 CONTINUE 20141 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'DUA2')THEN 20142 WRITE(ICOUT,999) 20143 CALL DPWRST('XXX','BUG ') 20144 WRITE(ICOUT,9011) 20145 9011 FORMAT('***** AT THE END OF DPDUA2--') 20146 CALL DPWRST('XXX','BUG ') 20147 WRITE(ICOUT,9021)NPLOTP,NPLOTV 20148 9021 FORMAT('NPLOTP,NPLOTV = ',2I8) 20149 CALL DPWRST('XXX','BUG ') 20150 DO9022I=1,NPLOTP 20151 WRITE(ICOUT,9023)I,Y(I),X(I),D(I) 20152 9023 FORMAT('I,Y(I),X(I),D(I) = ',I8,3G15.7) 20153 CALL DPWRST('XXX','BUG ') 20154 9022 CONTINUE 20155 ENDIF 20156C 20157 RETURN 20158 END 20159 SUBROUTINE DPDURB(YTEMP,XTEMP,MAXNXT, 20160 1 ICAPSW,IFORSW, 20161 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 20162C 20163C PURPOSE--CARRY OUT DURBIN TEST NON-PARAMETRIC TWO-WAY ANOVA 20164C OF INCOMPLETE BLOCK DESIGNS 20165C EXAMPLE--DURBIN TEST Y X1 X2 20166C REFERENCE--W. J. CONOVER (1999). "PRACTICAL NONPARAMETRIC 20167C STATISTICS", THIRD EDITION, WILEY, PP. 388-395. 20168C WRITTEN BY--ALAN HECKERT 20169C STATISTICAL ENGINEERING DIVISION 20170C INFORMATION TECHNOLOGY LABORATORY 20171C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 20172C GAITHERSBURG, MD 20899-8980 20173C PHONE--301-975-2899 20174C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 20175C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 20176C LANGUAGE--ANSI FORTRAN (1977) 20177C VERSION NUMBER--2006/1 20178C ORIGINAL VERSION--JANUARY 2006. 20179C UPDATED --JANUARY 2007. CALL LIST TO DPDUR2 20180C UPDATED --APRIL 2011. USE DPPARS AND DPPARS3 20181C 20182C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 20183C 20184 CHARACTER*4 ICAPSW 20185 CHARACTER*4 IFORSW 20186 CHARACTER*4 IBUGA2 20187 CHARACTER*4 IBUGA3 20188 CHARACTER*4 IBUGQ 20189 CHARACTER*4 ISUBRO 20190 CHARACTER*4 IFOUND 20191 CHARACTER*4 IERROR 20192C 20193 CHARACTER*4 ISUBN1 20194 CHARACTER*4 ISUBN2 20195 CHARACTER*4 ISTEPN 20196C 20197 LOGICAL IFRST 20198 LOGICAL ILAST 20199 CHARACTER*4 IFLAGU 20200 CHARACTER*4 ICASE 20201 CHARACTER*40 INAME 20202 PARAMETER (MAXSPN=30) 20203 CHARACTER*4 IVARN1(MAXSPN) 20204 CHARACTER*4 IVARN2(MAXSPN) 20205 CHARACTER*4 IVARTY(MAXSPN) 20206 REAL PVAR(MAXSPN) 20207 INTEGER ILIS(MAXSPN) 20208 INTEGER NRIGHT(MAXSPN) 20209 INTEGER ICOLR(MAXSPN) 20210C 20211C--------------------------------------------------------------------- 20212C 20213 DIMENSION YTEMP(*) 20214 DIMENSION XTEMP(*) 20215C 20216C-----COMMON---------------------------------------------------------- 20217C 20218 INCLUDE 'DPCOPA.INC' 20219C 20220 DIMENSION XTEMP2(MAXOBV) 20221 DIMENSION DBLOCK(MAXOBV) 20222 DIMENSION DTREAT(MAXOBV) 20223 DIMENSION YRANK(MAXOBV) 20224 DIMENSION RJ(MAXOBV) 20225 DIMENSION XTEMP3(MAXOBV) 20226C 20227 INCLUDE 'DPCOZZ.INC' 20228 EQUIVALENCE(GARBAG(IGARB1),XTEMP2(1)) 20229 EQUIVALENCE(GARBAG(IGARB2),DBLOCK(1)) 20230 EQUIVALENCE(GARBAG(IGARB3),DTREAT(1)) 20231 EQUIVALENCE(GARBAG(IGARB4),YRANK(1)) 20232 EQUIVALENCE(GARBAG(IGARB5),RJ(1)) 20233 EQUIVALENCE(GARBAG(IGARB6),XTEMP3(1)) 20234C 20235 INCLUDE 'DPCOHK.INC' 20236 INCLUDE 'DPCOSU.INC' 20237 INCLUDE 'DPCODA.INC' 20238C 20239C-----COMMON VARIABLES (GENERAL)-------------------------------------- 20240C 20241 INCLUDE 'DPCOP2.INC' 20242C 20243C-----START POINT----------------------------------------------------- 20244C 20245 ISUBN1='DPDU' 20246 ISUBN2='RB ' 20247 IFOUND='YES' 20248 IERROR='NO' 20249C 20250 MAXCP1=MAXCOL+1 20251 MAXCP2=MAXCOL+2 20252 MAXCP3=MAXCOL+3 20253 MAXCP4=MAXCOL+4 20254 MAXCP5=MAXCOL+5 20255 MAXCP6=MAXCOL+6 20256C 20257C ****************************************** 20258C ** TREAT THE DURBIN TEST CASE ** 20259C ****************************************** 20260C 20261 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DURB')THEN 20262 WRITE(ICOUT,999) 20263 999 FORMAT(1X) 20264 CALL DPWRST('XXX','BUG ') 20265 WRITE(ICOUT,51) 20266 51 FORMAT('***** AT THE BEGINNING OF DPDURB--') 20267 CALL DPWRST('XXX','BUG ') 20268 WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT 20269 52 FORMAT('IBUGA2,IBUGA3,IBUBQ,ISUBRO,MAXNXT = ',4(A4,2X),I8) 20270 CALL DPWRST('XXX','BUG ') 20271 WRITE(ICOUT,53)ICAPSW,ICAPTY,IFORSW 20272 53 FORMAT('ICAPSW,ICAPTY,IFORSW = ',2(A4,2X),A4) 20273 CALL DPWRST('XXX','BUG ') 20274 ENDIF 20275C 20276C ********************************* 20277C ** STEP 1-- ** 20278C ** EXTRACT THE VARIABLE LIST ** 20279C ********************************* 20280C 20281 ISTEPN='1' 20282 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DURB') 20283 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 20284C 20285 INAME='DURBIN TEST' 20286 MAXNA=100 20287 MINNVA=1 20288 MAXNVA=3 20289 MINNA=1 20290 IFLAGE=1 20291 IFLAGM=0 20292 MINN2=2 20293 IFLAGP=0 20294 JMIN=1 20295 JMAX=NUMARG 20296C 20297 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 20298 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 20299 1 JMIN,JMAX, 20300 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 20301 1 IVARN1,IVARN2,IVARTY,PVAR, 20302 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 20303 1 MINNVA,MAXNVA, 20304 1 IFLAGM,IFLAGP, 20305 1 IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 20306 IF(IERROR.EQ.'YES')GOTO9000 20307C 20308 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DURB')THEN 20309 WRITE(ICOUT,999) 20310 CALL DPWRST('XXX','BUG ') 20311 WRITE(ICOUT,181) 20312 181 FORMAT('***** AFTER CALL DPPARS--') 20313 CALL DPWRST('XXX','BUG ') 20314 WRITE(ICOUT,182)NQ,NUMVAR,IMULT 20315 182 FORMAT('NQ,NUMVAR,IMULT = ',2I8,2X,A4) 20316 CALL DPWRST('XXX','BUG ') 20317 IF(NUMVAR.GT.0)THEN 20318 DO185I=1,NUMVAR 20319 WRITE(ICOUT,187)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 20320 1 ICOLR(I) 20321 187 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 20322 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 20323 CALL DPWRST('XXX','BUG ') 20324 185 CONTINUE 20325 ENDIF 20326 ENDIF 20327C 20328C ********************************** 20329C ** STEP 52-- ** 20330C ** CARRY OUT THE DURBIN TEST ** 20331C ********************************** 20332C 20333 ISTEPN='52' 20334 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'DURB') 20335 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 20336C 20337 ICOL=1 20338 NUMVA2=3 20339 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 20340 1 INAME,IVARN1,IVARN2,IVARTY, 20341 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 20342 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 20343 1 MAXCP4,MAXCP5,MAXCP6, 20344 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 20345 1 Y,X,XTEMP2,NS1,NS1,NS1,ICASE, 20346 1 IBUGA3,ISUBRO,IFOUND,IERROR) 20347 IF(IERROR.EQ.'YES')GOTO9000 20348C 20349 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'DURB')THEN 20350 WRITE(ICOUT,999) 20351 CALL DPWRST('XXX','BUG ') 20352 WRITE(ICOUT,5211) 20353 5211 FORMAT('***** FROM DPDURB, AS WE ARE ABOUT TO CALL DPDUR2--') 20354 CALL DPWRST('XXX','BUG ') 20355 WRITE(ICOUT,5212)NS1 20356 5212 FORMAT('NS1 = ',I8) 20357 CALL DPWRST('XXX','BUG ') 20358 DO5215I=1,NS1 20359 WRITE(ICOUT,5216)I,Y(I),X(I),XTEMP2(I) 20360 5216 FORMAT('I,Y(I),X(I),XTEMP2(I) = ',I8,3G15.7) 20361 CALL DPWRST('XXX','BUG ') 20362 5215 CONTINUE 20363 ENDIF 20364C 20365 CALL DPDUR2(Y,X,XTEMP2,NS1,IVARN1,IVARN2, 20366 1 YTEMP,XTEMP,YRANK,RJ,DBLOCK,DTREAT, 20367 1 XTEMP3,MAXNXT, 20368 1 STATVA,STATCD,PVAL, 20369 1 CUT0,CUT50,CUT75,CUT90,CUT95,CUT975,CUT99,CUT999, 20370 1 ICAPSW,ICAPTY,IFORSW, 20371 1 IBUGA3,ISUBRO,IERROR) 20372C 20373 IFLAGU='ON' 20374 IFRST=.TRUE. 20375 ILAST=.TRUE. 20376 CALL DPFRT5(STATVA,STATCD,PVAL, 20377 1 CUT0,CUT50,CUT75,CUT90,CUT95, 20378 1 CUT975,CUT99,CUT999, 20379 1 IFLAGU,IFRST,ILAST, 20380 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 20381C 20382C ***************** 20383C ** STEP 90-- ** 20384C ** EXIT ** 20385C ***************** 20386C 20387 9000 CONTINUE 20388 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'DUR2')THEN 20389 WRITE(ICOUT,999) 20390 CALL DPWRST('XXX','BUG ') 20391 WRITE(ICOUT,9011) 20392 9011 FORMAT('***** AT THE END OF DPDURB--') 20393 CALL DPWRST('XXX','BUG ') 20394 WRITE(ICOUT,9016)IFOUND,IERROR 20395 9016 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 20396 CALL DPWRST('XXX','BUG ') 20397 ENDIF 20398C 20399 RETURN 20400 END 20401 SUBROUTINE DPDUR2(Y,BLOCK,TREAT,N,IVARID,IVARI2, 20402 1 YTEMP,XTEMP,YRANK,RJ,DBLOCK,DTREAT, 20403 1 XTEMP2,MAXNXT, 20404 1 STATVA,STATCD,PVAL, 20405 1 CUT0,CUT50,CUT75,CUT90,CUT95,CUT975, 20406 1 CUT99,CUT999, 20407 1 ICAPSW,ICAPTY,IFORSW, 20408 1 IBUGA3,ISUBRO,IERROR) 20409C 20410C PURPOSE--THIS ROUTINE CARRIES OUT DURBIN'S TEST 20411C NON-PARAMETRIC TWO-WAY ANOVA FOR BALANCED, 20412C INCOMPLETE BLOCK DESIGNS 20413C EXAMPLE--DURBIN TEST Y BLOCK TREAT 20414C REFERENCE--W. J. CONOVER (1999). "PRACTICAL NONPARAMETRIC 20415C STATISTICS", THIRD EDITION, WILEY, PP. 388-395. 20416c WRITTEN BY--ALAN HECKERT 20417C STATISTICAL ENGINEERING DIVISION 20418C INFORMATION TECHNOLOGY LABORATORY 20419C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 20420C GAITHERSBURG, MD 20899-8980 20421C PHONE--301-975-2899 20422C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 20423C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 20424C LANGUAGE--ANSI FORTRAN (1977) 20425C VERSION NUMBER--2006/1 20426C ORIGINAL VERSION--JANUARY 2006. 20427C UPDATED --OCTOBER 2006. CALL LIST TO TPPF 20428C UPDATED --JANUARY 2007. CALL LIST TO RANK 20429C UPDATED --APRIL 2011. USE DPDTA1 AND DPDTA4 TO 20430C PRINT TABLES. THIS ADDS RTF 20431C SUPPORT AND SPECIFICATION OF 20432C THE NUMBER OF DIGITS. 20433C 20434C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 20435C 20436 CHARACTER*4 ICAPSW 20437 CHARACTER*4 ICAPTY 20438 CHARACTER*4 IFORSW 20439 CHARACTER*4 IBUGA3 20440 CHARACTER*4 ISUBRO 20441 CHARACTER*4 IERROR 20442 CHARACTER*4 IVARID(*) 20443 CHARACTER*4 IVARI2(*) 20444C 20445 CHARACTER*4 IWRITE 20446 CHARACTER*4 ISUBN1 20447 CHARACTER*4 ISUBN2 20448 CHARACTER*4 ISTEPN 20449 CHARACTER*4 IOP 20450 CHARACTER*3 IATEMP 20451C 20452 DOUBLE PRECISION DSUM1 20453 DOUBLE PRECISION DSUM2 20454C 20455C--------------------------------------------------------------------- 20456C 20457 DIMENSION Y(*) 20458 DIMENSION BLOCK(*) 20459 DIMENSION TREAT(*) 20460 DIMENSION YRANK(*) 20461 DIMENSION RJ(*) 20462 DIMENSION DBLOCK(*) 20463 DIMENSION DTREAT(*) 20464 DIMENSION YTEMP(*) 20465 DIMENSION XTEMP(*) 20466 DIMENSION XTEMP2(*) 20467C 20468 PARAMETER (NUMALP=8) 20469 REAL ALPHA(NUMALP) 20470C 20471 PARAMETER(NUMCLI=6) 20472 PARAMETER(MAXLIN=2) 20473 PARAMETER (MAXROW=50) 20474 CHARACTER*60 ITITLE 20475 CHARACTER*60 ITITLZ 20476 CHARACTER*1 ITITL9 20477 CHARACTER*60 ITEXT(MAXROW) 20478 CHARACTER*4 ALIGN(NUMCLI) 20479 CHARACTER*4 VALIGN(NUMCLI) 20480 REAL AVALUE(MAXROW) 20481 INTEGER NCTEXT(MAXROW) 20482 INTEGER IDIGIT(MAXROW) 20483 INTEGER NTOT(MAXROW) 20484 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 20485 CHARACTER*15 IVALUE(MAXROW,NUMCLI) 20486 CHARACTER*4 ITYPCO(NUMCLI) 20487 INTEGER NCTIT2(MAXLIN,NUMCLI) 20488 INTEGER NCVALU(MAXROW,NUMCLI) 20489 INTEGER IWHTML(NUMCLI) 20490 INTEGER IWRTF(NUMCLI) 20491 REAL AMAT(MAXROW,NUMCLI) 20492 LOGICAL IFRST 20493 LOGICAL ILAST 20494C 20495C--------------------------------------------------------------------- 20496C 20497 INCLUDE 'DPCOP2.INC' 20498C 20499C-----START POINT----------------------------------------------------- 20500C 20501 DATA ALPHA/ 20502 1 0.0, 50.0, 75.0, 90.0, 95.0, 97.5, 99.0, 99.9/ 20503C 20504 ISUBN1='DPDU' 20505 ISUBN2='R2 ' 20506C 20507 IERROR='NO' 20508C 20509 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DUR2')THEN 20510 WRITE(ICOUT,999) 20511 999 FORMAT(1X) 20512 CALL DPWRST('XXX','WRIT') 20513 WRITE(ICOUT,51) 20514 51 FORMAT('**** AT THE BEGINNING OF DPDUR2--') 20515 CALL DPWRST('XXX','WRIT') 20516 WRITE(ICOUT,52)IBUGA3,ISUBRO,N 20517 52 FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8) 20518 CALL DPWRST('XXX','WRIT') 20519 DO56I=1,N 20520 WRITE(ICOUT,57)I,Y(I),BLOCK(I),TREAT(I) 20521 57 FORMAT('I,Y(I),BLOCK(I),TREAT(I) = ',I8,3G15.7) 20522 CALL DPWRST('XXX','WRIT') 20523 56 CONTINUE 20524 ENDIF 20525C 20526C ******************************************** 20527C ** STEP 11-- ** 20528C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 20529C ******************************************** 20530C 20531 ISTEPN='11' 20532 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DUR2') 20533 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 20534C 20535 HOLD=Y(1) 20536 DO1135I=2,N 20537 IF(Y(I).NE.HOLD)GOTO1139 20538 1135 CONTINUE 20539 WRITE(ICOUT,999) 20540 CALL DPWRST('XXX','WRIT') 20541 WRITE(ICOUT,1131) 20542 1131 FORMAT('***** ERROR FROM DURBIN TEST--') 20543 CALL DPWRST('XXX','WRIT') 20544 WRITE(ICOUT,1133)HOLD 20545 1133 FORMAT(' THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7) 20546 CALL DPWRST('XXX','WRIT') 20547 IERROR='YES' 20548 GOTO9000 20549 1139 CONTINUE 20550C 20551 HOLD=BLOCK(1) 20552 DO1235I=2,N 20553 IF(BLOCK(I).NE.HOLD)GOTO1239 20554 1235 CONTINUE 20555 WRITE(ICOUT,999) 20556 CALL DPWRST('XXX','WRIT') 20557 WRITE(ICOUT,1131) 20558 CALL DPWRST('XXX','WRIT') 20559 WRITE(ICOUT,1231)HOLD 20560 1231 FORMAT(' THE FIRST FACTOR VARIABLE HAS ALL ELEMENTS = ', 20561 1 G15.7) 20562 CALL DPWRST('XXX','WRIT') 20563 IERROR='YES' 20564 GOTO9000 20565 1239 CONTINUE 20566C 20567 HOLD=TREAT(1) 20568 DO1335I=2,N 20569 IF(TREAT(I).NE.HOLD)GOTO1339 20570 1335 CONTINUE 20571 WRITE(ICOUT,999) 20572 CALL DPWRST('XXX','WRIT') 20573 WRITE(ICOUT,1131) 20574 CALL DPWRST('XXX','WRIT') 20575 WRITE(ICOUT,1331)HOLD 20576 1331 FORMAT(' THE SECOND FACTOR VARIABLE HAS ALL ELEMENTS = ', 20577 1 G15.7) 20578 CALL DPWRST('XXX','WRIT') 20579 GOTO9000 20580 1339 CONTINUE 20581C 20582C ******************************************** 20583C ** STEP 12-- ** 20584C ** CHECK TO SEE IF A BALANCED DESIGN ** 20585C ** WAS ENTERED. ** 20586C ** 1) EVERY BLOCK CONTAINS K EXPERIMENTAL** 20587C ** UNITS. ** 20588C ** 2) EVERY TREATMENT APPEARS IN R ** 20589C ** BLOCKS. ** 20590C ******************************************** 20591C 20592 ISTEPN='12' 20593 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DUR2') 20594 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 20595C 20596C STEP 1: COMPUTE NUMBER OF DISTINCT BLOCKS AND TREATMENTS 20597C 20598 CALL DISTIN(BLOCK,N,IWRITE,DBLOCK,NBLOCK,IBUGA3,IERROR) 20599 IF(IERROR.EQ.'YES' .OR. NBLOCK.LE.0)GOTO9000 20600 CALL DISTIN(TREAT,N,IWRITE,DTREAT,NTREAT,IBUGA3,IERROR) 20601 IF(IERROR.EQ.'YES' .OR. NTREAT.LE.0)GOTO9000 20602C 20603C STEP 2: DETERMINE IF EVERY BLOCK CONTAINS K EXPERIMENTAL 20604C TREATMENTS 20605C 20606 KHOLD=0 20607 DO1410I=1,NBLOCK 20608 ABLOCK=BLOCK(I) 20609 NK=0 20610 DO1420J=1,N 20611 IF(BLOCK(J).EQ.ABLOCK)NK=NK+1 20612 1420 CONTINUE 20613 IF(KHOLD.EQ.0)THEN 20614 KHOLD=NK 20615 ELSE 20616 IF(NK.NE.KHOLD)THEN 20617 WRITE(ICOUT,999) 20618 CALL DPWRST('XXX','WRIT') 20619 WRITE(ICOUT,1131) 20620 CALL DPWRST('XXX','WRIT') 20621 WRITE(ICOUT,1432) 20622 CALL DPWRST('XXX','WRIT') 20623 WRITE(ICOUT,1433)I,NK,KHOLD 20624 CALL DPWRST('XXX','WRIT') 20625 IERROR='YES' 20626 GOTO9000 20627 ENDIF 20628 ENDIF 20629 1410 CONTINUE 20630 1432 FORMAT(' UNEQUAL BLOCK SIZES DETECTED:') 20631 1433 FORMAT(' BLOCK ',I8,' HAD ',I8,' TREATMENTS WHEN ', 20632 1 I8,' TREATMENTS WERE EXPECTED.') 20633C 20634C STEP 3: DETERMINE IF EVERY TREATMENT APPEARS IN R BLOCKS 20635C (FOR NOW JUST CHECK THAT IT APPEARS R TIMES) 20636C 20637 IRHOLD=0 20638 DO1510I=1,NTREAT 20639 ATREAT=TREAT(I) 20640 NR=0 20641 DO1520J=1,N 20642 IF(TREAT(J).EQ.ATREAT)NR=NR+1 20643 1520 CONTINUE 20644 IF(IRHOLD.EQ.0)THEN 20645 IRHOLD=NR 20646 ELSE 20647 IF(NR.NE.IRHOLD)THEN 20648 WRITE(ICOUT,999) 20649 CALL DPWRST('XXX','WRIT') 20650 WRITE(ICOUT,1131) 20651 CALL DPWRST('XXX','WRIT') 20652 WRITE(ICOUT,1532) 20653 CALL DPWRST('XXX','WRIT') 20654 WRITE(ICOUT,1533)I,NR,IRHOLD 20655 CALL DPWRST('XXX','WRIT') 20656 IERROR='YES' 20657 GOTO9000 20658 ENDIF 20659 ENDIF 20660 1510 CONTINUE 20661 1532 FORMAT(' UNEQUAL TREATMENT SIZES DETECTED:') 20662 1533 FORMAT(' TREATMENT ',I8,' APPEARED ',I8,' TIMES ', 20663 1 'WHEN ',I8,' OCCURENCES WERE EXPECTED.') 20664C 20665C ****************************** 20666C ** STEP 21-- ** 20667C ** CARRY OUT CALCULATIONS ** 20668C ** FOR DURBIN TEST ** 20669C ****************************** 20670C 20671 ISTEPN='21' 20672 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DUR2') 20673 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 20674C 20675 IWRITE='OFF' 20676C 20677C COMPUTATIONAL ALGORITHM: 20678C 20679C 1. X(IJ) = RESPONSE FOR BLOCK I, TREATMENT J 20680C 2. R(X(IJ)) = RANK OF X(IJ) WITHIN EACH BLOCK 20681C 3. R(J) = SUM[I=1 TO K][R(X(IJ))] 20682C 4. A = SUM[I=1 TO B][J=1 TO T][(R(X(IJ)]**2 20683C 5. C = B*K(K+1)**2/4 20684C 6. T1 = (T-1)*{SUM[J=1 TO T][R(J)**2] - R*C]/(A-C) 20685C 20686 DSUM1=0.0D0 20687 DSUM2=0.0D0 20688 DO4010I=1,MAXNXT 20689 XTEMP(I)=0.0 20690 YTEMP(I)=0.0 20691 YRANK(I)=0.0 20692 RJ(I)=0.0 20693 4010 CONTINUE 20694C 20695C EXTRACT THE X(IJ) FOR EACH BLOCK 20696C 20697 DO2110I=1,NBLOCK 20698 HOLD=DBLOCK(I) 20699 ICOUNT=0 20700 DO2120J=1,N 20701 IF(BLOCK(J).EQ.HOLD)THEN 20702 ICOUNT=ICOUNT+1 20703 YTEMP(ICOUNT)=Y(J) 20704 ENDIF 20705 2120 CONTINUE 20706 CALL RANK(YTEMP,ICOUNT,IWRITE,XTEMP,XTEMP2,MAXNXT, 20707 1 IBUGA3,IERROR) 20708 IF(IERROR.EQ.'YES')GOTO9000 20709 ICOUNT=0 20710 DO2130J=1,N 20711 IF(BLOCK(J).EQ.HOLD)THEN 20712 ICOUNT=ICOUNT+1 20713 YRANK(J)=XTEMP(ICOUNT) 20714 ENDIF 20715 2130 CONTINUE 20716 2110 CONTINUE 20717C 20718 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DUR2')THEN 20719 DO2140I=1,N 20720 WRITE(ICOUT,2142)I,Y(I),YRANK(I) 20721 2142 FORMAT('I,Y(I),YRANK(I) = ',I8,G15.7,F12.2) 20722 CALL DPWRST('XXX','BUG ') 20723 2140 CONTINUE 20724 ENDIF 20725C 20726C STEP 3: NOW COMPUTE RANK SUMS FOR EACH TREATMENT 20727C 20728 DO2210I=1,NTREAT 20729 HOLD=DTREAT(I) 20730 DSUM1=0.0D0 20731 DO2220J=1,N 20732 IF(TREAT(J).EQ.HOLD)THEN 20733 DSUM1=DSUM1 + DBLE(YRANK(J)) 20734 ENDIF 20735 2220 CONTINUE 20736 RJ(I)=REAL(DSUM1) 20737 2210 CONTINUE 20738C 20739 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DUR2')THEN 20740 DO2240I=1,NTREAT 20741 WRITE(ICOUT,2242)I,RJ(I) 20742 2242 FORMAT('I,RJ(I) = ',I8,G15.7) 20743 CALL DPWRST('XXX','BUG ') 20744 2240 CONTINUE 20745 ENDIF 20746C 20747C STEP 4: NOW COMPUTE VARIOUS QUANTITIES BASED ON RJ 20748C 20749 DSUM2=0.0D0 20750 DO2310I=1,N 20751 DSUM2=DSUM2 + DBLE(YRANK(I))**2 20752 2310 CONTINUE 20753 A=REAL(DSUM2) 20754 B=REAL(NBLOCK) 20755 T=REAL(NTREAT) 20756 R=REAL(NR) 20757 AK=REAL(NK) 20758 C=B*AK*(AK+1)**2/4.0 20759 DENOM=A-C 20760 C1=(T-1.0) 20761 C2=R*C 20762C 20763 DSUM1=0.0D0 20764 DO2320I=1,NTREAT 20765 DSUM1=DSUM1 + RJ(I)**2 20766 2320 CONTINUE 20767 T1=C1*(REAL(DSUM1)-C2)/DENOM 20768 T2=(T1/C1)/((B*(AK-1.0) - T1)/(B*AK - B - T + 1.0)) 20769C 20770 STATVA=T2 20771 NUMDF1=NTREAT-1 20772 NUMDF2=INT(B*AK - B - T +1) 20773 CALL FCDF(STATVA,NUMDF1,NUMDF2,STATCD) 20774 PVAL=1.0 - STATCD 20775C 20776 CUT0=0.0 20777 CALL FPPF(.50,NUMDF1,NUMDF2,CUT50) 20778 CALL FPPF(.75,NUMDF1,NUMDF2,CUT75) 20779 CALL FPPF(.90,NUMDF1,NUMDF2,CUT90) 20780 CALL FPPF(.95,NUMDF1,NUMDF2,CUT95) 20781 CALL FPPF(.975,NUMDF1,NUMDF2,CUT975) 20782 CALL FPPF(.99,NUMDF1,NUMDF2,CUT99) 20783 CALL FPPF(.999,NUMDF1,NUMDF2,CUT999) 20784C 20785 IDF=INT(B*AK - B - T + 1.0) 20786 CALL TPPF(0.95,REAL(IDF),T95) 20787 CALL TPPF(0.975,REAL(IDF),T975) 20788 CALL TPPF(0.995,REAL(IDF),T995) 20789 TERM1=(A-C)*2.0*R/(B*AK - B - T + 1.0) 20790 TERM2=1.0 - (T1/(B*(AK - 1.0))) 20791 CONTRA=SQRT(TERM1*TERM2) 20792 CONTR1=T95*CONTRA 20793 CONTR2=T975*CONTRA 20794 CONTR3=T995*CONTRA 20795C 20796 IOP='OPEN' 20797 IFLG1=1 20798 IFLG2=1 20799 IFLG3=0 20800 IFLG4=0 20801 IFLG5=0 20802 CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5, 20803 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 20804 1 IBUGA3,ISUBRO,IERROR) 20805 IF(IERROR.EQ.'YES')GOTO9000 20806C 20807 WRITE(IOUNI1,2405) 20808 2405 FORMAT(4X,'RESPONSE',13X,'RANK',11X,'BLOCK',8X,'TREATMENT') 20809 DO2410I=1,N 20810 WRITE(IOUNI1,2411)Y(I),YRANK(I),BLOCK(I),TREAT(I) 20811 2411 FORMAT(1X,E15.7,F15.2,F15.2,F15.2) 20812 2410 CONTINUE 20813C 20814 WRITE(IOUNI2,2421)CONTRA 20815 2421 FORMAT(1X,'Contrast term: ',E15.7) 20816 WRITE(IOUNI2,2422)CONTR1 20817 2422 FORMAT(1X,'Contrast term*t(0.95): ',E15.7) 20818 WRITE(IOUNI2,2423)CONTR2 20819 2423 FORMAT(1X,'Contrast term*t(0.975): ',E15.7) 20820 WRITE(IOUNI2,2424)CONTR3 20821 2424 FORMAT(1X,'Contrast term*t(0.995): ',E15.7) 20822 WRITE(IOUNI2,2425) 20823 2425 FORMAT(10X,'I',10X,'J',8X,'|R(I)-R(J)|') 20824C 20825 DO2430I=1,NTREAT 20826 DO2439J=1,NTREAT 20827 IF(I.LT.J)THEN 20828 ADIFF=ABS(RJ(I)-RJ(J)) 20829 IATEMP=' ' 20830 IF(ABS(ADIFF).GE.CONTR1)IATEMP(1:1)='*' 20831 IF(ABS(ADIFF).GE.CONTR2)IATEMP(2:2)='*' 20832 IF(ABS(ADIFF).GE.CONTR3)IATEMP(3:3)='*' 20833 WRITE(IOUNI2,2437)I,J,ADIFF,IATEMP 20834 2437 FORMAT(3X,I8,3X,I8,5X,E15.7,A3) 20835 ENDIF 20836 2439 CONTINUE 20837 2430 CONTINUE 20838C 20839 IOP='CLOS' 20840 CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5, 20841 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 20842 1 IBUGA3,ISUBRO,IERROR) 20843C 20844C ****************************** 20845C ** STEP 43-- ** 20846C ** WRITE OUT EVERYTHING ** 20847C ** FOR DURBIN TEST ** 20848C ****************************** 20849C 20850 ISTEPN='43' 20851 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DUR2') 20852 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 20853C 20854 IF(IPRINT.EQ.'OFF')GOTO9000 20855C 20856 NUMDIG=7 20857 IF(IFORSW.EQ.'1')NUMDIG=1 20858 IF(IFORSW.EQ.'2')NUMDIG=2 20859 IF(IFORSW.EQ.'3')NUMDIG=3 20860 IF(IFORSW.EQ.'4')NUMDIG=4 20861 IF(IFORSW.EQ.'5')NUMDIG=5 20862 IF(IFORSW.EQ.'6')NUMDIG=6 20863 IF(IFORSW.EQ.'7')NUMDIG=7 20864 IF(IFORSW.EQ.'8')NUMDIG=8 20865 IF(IFORSW.EQ.'9')NUMDIG=9 20866 IF(IFORSW.EQ.'0')NUMDIG=0 20867 IF(IFORSW.EQ.'E')NUMDIG=-2 20868 IF(IFORSW.EQ.'-2')NUMDIG=-2 20869 IF(IFORSW.EQ.'-3')NUMDIG=-3 20870 IF(IFORSW.EQ.'-4')NUMDIG=-4 20871 IF(IFORSW.EQ.'-5')NUMDIG=-5 20872 IF(IFORSW.EQ.'-6')NUMDIG=-6 20873 IF(IFORSW.EQ.'-7')NUMDIG=-7 20874 IF(IFORSW.EQ.'-8')NUMDIG=-8 20875 IF(IFORSW.EQ.'-9')NUMDIG=-9 20876C 20877 ITITLE='Durbin Test for Two-Way Balanced Incomplete Block Designs' 20878 NCTITL=57 20879 ITITLZ=' ' 20880 NCTITZ=0 20881C 20882 ICNT=1 20883 ITEXT(ICNT)=' ' 20884 NCTEXT(ICNT)=0 20885 AVALUE(ICNT)=0.0 20886 IDIGIT(ICNT)=-1 20887 ICNT=ICNT+1 20888 ITEXT(ICNT)='Response Variable: ' 20889 WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4) 20890 WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4) 20891 NCTEXT(ICNT)=27 20892 AVALUE(ICNT)=0.0 20893 IDIGIT(ICNT)=-1 20894C 20895 ICNT=ICNT+1 20896 ITEXT(ICNT)='First Group-ID Variable: ' 20897 WRITE(ITEXT(ICNT)(26:29),'(A4)')IVARID(2)(1:4) 20898 WRITE(ITEXT(ICNT)(30:33),'(A4)')IVARI2(2)(1:4) 20899 NCTEXT(ICNT)=33 20900 AVALUE(ICNT)=0.0 20901 IDIGIT(ICNT)=-1 20902C 20903 ICNT=ICNT+1 20904 ITEXT(ICNT)='Second Group-ID Variable: ' 20905 WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARID(3)(1:4) 20906 WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARI2(3)(1:4) 20907 NCTEXT(ICNT)=34 20908 AVALUE(ICNT)=0.0 20909 IDIGIT(ICNT)=-1 20910C 20911 ICNT=ICNT+1 20912 ITEXT(ICNT)=' ' 20913 NCTEXT(ICNT)=1 20914 AVALUE(ICNT)=0.0 20915 IDIGIT(ICNT)=-1 20916C 20917 ICNT=ICNT+1 20918 ITEXT(ICNT)='H0: Treatments Have Identical Effects' 20919 NCTEXT(ICNT)=37 20920 AVALUE(ICNT)=0.0 20921 IDIGIT(ICNT)=-1 20922 ICNT=ICNT+1 20923 ITEXT(ICNT)='Ha: Treatments Do Not Have Identical Effects' 20924 NCTEXT(ICNT)=44 20925 AVALUE(ICNT)=0.0 20926 IDIGIT(ICNT)=-1 20927C 20928 ICNT=ICNT+1 20929 ITEXT(ICNT)=' ' 20930 NCTEXT(ICNT)=1 20931 AVALUE(ICNT)=0.0 20932 IDIGIT(ICNT)=-1 20933C 20934 ICNT=ICNT+1 20935 ITEXT(ICNT)='Summary Statistics:' 20936 NCTEXT(ICNT)=19 20937 AVALUE(ICNT)=0.0 20938 IDIGIT(ICNT)=-1 20939 ICNT=ICNT+1 20940 ITEXT(ICNT)='Total Number of Observations:' 20941 NCTEXT(ICNT)=29 20942 AVALUE(ICNT)=REAL(N) 20943 IDIGIT(ICNT)=0 20944 ICNT=ICNT+1 20945 ITEXT(ICNT)='Number of Blocks:' 20946 NCTEXT(ICNT)=17 20947 AVALUE(ICNT)=REAL(NBLOCK) 20948 IDIGIT(ICNT)=0 20949 ICNT=ICNT+1 20950 ITEXT(ICNT)='Number of Treatments:' 20951 NCTEXT(ICNT)=21 20952 AVALUE(ICNT)=REAL(NTREAT) 20953 IDIGIT(ICNT)=0 20954 ICNT=ICNT+1 20955 ITEXT(ICNT)='Number of Blocks for Each Treatment:' 20956 NCTEXT(ICNT)=36 20957 AVALUE(ICNT)=REAL(NR) 20958 IDIGIT(ICNT)=0 20959 ICNT=ICNT+1 20960 ITEXT(ICNT)=' ' 20961 NCTEXT(ICNT)=1 20962 AVALUE(ICNT)=0.0 20963 IDIGIT(ICNT)=-1 20964C 20965 ICNT=ICNT+1 20966 ITEXT(ICNT)='Test:' 20967 NCTEXT(ICNT)=5 20968 AVALUE(ICNT)=0.0 20969 IDIGIT(ICNT)=-1 20970 ICNT=ICNT+1 20971 ITEXT(ICNT)='Sum of Squares of Ranks (A):' 20972 NCTEXT(ICNT)=28 20973 AVALUE(ICNT)=A 20974 IDIGIT(ICNT)=NUMDIG 20975 ICNT=ICNT+1 20976 ITEXT(ICNT)='Correction Factor (C):' 20977 NCTEXT(ICNT)=28 20978 AVALUE(ICNT)=C 20979 IDIGIT(ICNT)=NUMDIG 20980 ICNT=ICNT+1 20981 ITEXT(ICNT)='Durbin Test Statistic (Uncorrected):' 20982 NCTEXT(ICNT)=36 20983 AVALUE(ICNT)=T1 20984 IDIGIT(ICNT)=NUMDIG 20985 ICNT=ICNT+1 20986 ITEXT(ICNT)='Durbin Test Statistic (Corrected):' 20987 NCTEXT(ICNT)=34 20988 AVALUE(ICNT)=STATVA 20989 IDIGIT(ICNT)=NUMDIG 20990 ICNT=ICNT+1 20991 ITEXT(ICNT)='CDF of Test Statistic:' 20992 NCTEXT(ICNT)=22 20993 AVALUE(ICNT)=STATCD 20994 IDIGIT(ICNT)=NUMDIG 20995 ICNT=ICNT+1 20996 ITEXT(ICNT)='P-Value:' 20997 NCTEXT(ICNT)=8 20998 AVALUE(ICNT)=PVAL 20999 IDIGIT(ICNT)=NUMDIG 21000C 21001 NUMROW=ICNT 21002 DO4210I=1,NUMROW 21003 NTOT(I)=15 21004 4210 CONTINUE 21005C 21006 IFRST=.TRUE. 21007 ILAST=.TRUE. 21008C 21009 ISTEPN='42A' 21010 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DUR2') 21011 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 21012C 21013 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT, 21014 1 AVALUE,IDIGIT, 21015 1 NTOT,NUMROW, 21016 1 ICAPSW,ICAPTY,ILAST,IFRST, 21017 1 ISUBRO,IBUGA3,IERROR) 21018C 21019 ITITLE=' ' 21020 NCTITL=0 21021 ITITL9=' ' 21022 NCTIT9=0 21023 ITITLE='Percent Points of the F Reference Distribution' 21024 NCTITL=46 21025 NUMLIN=1 21026 NUMROW=8 21027 NUMCOL=3 21028 ITITL2(1,1)='Percent Point' 21029 ITITL2(1,2)=' ' 21030 ITITL2(1,3)='Value' 21031 NCTIT2(1,1)=13 21032 NCTIT2(1,2)=1 21033 NCTIT2(1,3)=5 21034C 21035 NMAX=0 21036 DO4221I=1,NUMCOL 21037 VALIGN(I)='b' 21038 ALIGN(I)='r' 21039 NTOT(I)=15 21040 IF(I.EQ.2)NTOT(I)=5 21041 NMAX=NMAX+NTOT(I) 21042 IDIGIT(I)=NUMDIG 21043 ITYPCO(I)='NUME' 21044 4221 CONTINUE 21045 ITYPCO(2)='ALPH' 21046 IDIGIT(1)=1 21047 IDIGIT(3)=3 21048 DO4223I=1,NUMROW 21049 DO4225J=1,NUMCOL 21050 NCVALU(I,J)=0 21051 IVALUE(I,J)=' ' 21052 NCVALU(I,J)=0 21053 AMAT(I,J)=0.0 21054 IF(J.EQ.1)THEN 21055 AMAT(I,J)=ALPHA(I) 21056 ELSEIF(J.EQ.2)THEN 21057 IVALUE(I,J)='=' 21058 NCVALU(I,J)=1 21059 ELSEIF(J.EQ.3)THEN 21060 IF(I.EQ.1)THEN 21061 AMAT(I,J)=RND(CUT0,IDIGIT(J)) 21062 ELSEIF(I.EQ.2)THEN 21063 AMAT(I,J)=RND(CUT50,IDIGIT(J)) 21064 ELSEIF(I.EQ.3)THEN 21065 AMAT(I,J)=RND(CUT75,IDIGIT(J)) 21066 ELSEIF(I.EQ.4)THEN 21067 AMAT(I,J)=RND(CUT90,IDIGIT(J)) 21068 ELSEIF(I.EQ.5)THEN 21069 AMAT(I,J)=RND(CUT95,IDIGIT(J)) 21070 ELSEIF(I.EQ.6)THEN 21071 AMAT(I,J)=RND(CUT975,IDIGIT(J)) 21072 ELSEIF(I.EQ.7)THEN 21073 AMAT(I,J)=RND(CUT99,IDIGIT(J)) 21074 ELSEIF(I.EQ.8)THEN 21075 AMAT(I,J)=RND(CUT999,IDIGIT(J)) 21076 ENDIF 21077 ENDIF 21078 4225 CONTINUE 21079 4223 CONTINUE 21080C 21081 IWHTML(1)=150 21082 IWHTML(2)=50 21083 IWHTML(3)=150 21084 IWRTF(1)=2000 21085 IWRTF(2)=IWRTF(1)+500 21086 IWRTF(3)=IWRTF(2)+2000 21087 IFRST=.TRUE. 21088 ILAST=.TRUE. 21089C 21090 ISTEPN='42C' 21091 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DUR2') 21092 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 21093C 21094 CALL DPDTA4(ITITL9,NCTIT9, 21095 1 ITITLE,NCTITL,ITITL2,NCTIT2, 21096 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 21097 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW, 21098 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 21099 1 ICAPSW,ICAPTY,IFRST,ILAST, 21100 1 ISUBRO,IBUGA3,IERROR) 21101C 21102 CDF1=CUT90 21103 CDF2=CUT95 21104 CDF3=CUT975 21105 CDF4=CUT99 21106C 21107 ITITL9=' ' 21108 NCTIT9=0 21109 ITITLE='Conclusions (Upper 1-Tailed Test)' 21110 NCTITL=33 21111 NUMLIN=1 21112 NUMROW=4 21113 NUMCOL=4 21114 ITITL2(1,1)='Alpha' 21115 ITITL2(1,2)='CDF' 21116 ITITL2(1,3)='Critical Value' 21117 ITITL2(1,4)='Conclusion' 21118 NCTIT2(1,1)=5 21119 NCTIT2(1,2)=3 21120 NCTIT2(1,3)=14 21121 NCTIT2(1,4)=10 21122C 21123 NMAX=0 21124 DO4321I=1,NUMCOL 21125 VALIGN(I)='b' 21126 ALIGN(I)='r' 21127 NTOT(I)=15 21128 IF(I.EQ.1 .OR. I.EQ.2)NTOT(I)=7 21129 IF(I.EQ.3)NTOT(I)=17 21130 NMAX=NMAX+NTOT(I) 21131 IDIGIT(I)=3 21132 ITYPCO(I)='ALPH' 21133 4321 CONTINUE 21134 ITYPCO(3)='NUME' 21135 IDIGIT(1)=0 21136 IDIGIT(2)=0 21137 DO4323I=1,NUMROW 21138 DO4325J=1,NUMCOL 21139 NCVALU(I,J)=0 21140 IVALUE(I,J)=' ' 21141 NCVALU(I,J)=0 21142 AMAT(I,J)=0.0 21143 4325 CONTINUE 21144 4323 CONTINUE 21145 IVALUE(1,1)='10%' 21146 IVALUE(2,1)='5%' 21147 IVALUE(3,1)='2.5%' 21148 IVALUE(4,1)='1%' 21149 IVALUE(1,2)='90%' 21150 IVALUE(2,2)='95%' 21151 IVALUE(3,2)='97.5%' 21152 IVALUE(4,2)='99%' 21153 NCVALU(1,1)=3 21154 NCVALU(2,1)=2 21155 NCVALU(3,1)=4 21156 NCVALU(4,1)=2 21157 NCVALU(1,2)=3 21158 NCVALU(2,2)=3 21159 NCVALU(3,2)=5 21160 NCVALU(4,2)=3 21161 IVALUE(1,4)='Accept H0' 21162 IVALUE(2,4)='Accept H0' 21163 IVALUE(3,4)='Accept H0' 21164 IVALUE(4,4)='Accept H0' 21165 NCVALU(1,4)=9 21166 NCVALU(2,4)=9 21167 NCVALU(3,4)=9 21168 NCVALU(4,4)=9 21169 IF(STATVA.GT.CUT90)IVALUE(1,4)='Reject H0' 21170 IF(STATVA.GT.CUT95)IVALUE(2,4)='Reject H0' 21171 IF(STATVA.GT.CUT975)IVALUE(3,4)='Reject H0' 21172 IF(STATVA.GT.CUT99)IVALUE(4,4)='Reject H0' 21173 AMAT(1,3)=RND(CUT90,IDIGIT(3)) 21174 AMAT(2,3)=RND(CUT95,IDIGIT(3)) 21175 AMAT(3,3)=RND(CUT975,IDIGIT(3)) 21176 AMAT(4,3)=RND(CUT99,IDIGIT(3)) 21177C 21178 IWHTML(1)=150 21179 IWHTML(2)=150 21180 IWHTML(3)=150 21181 IWHTML(4)=150 21182 IWRTF(1)=1500 21183 IWRTF(2)=IWRTF(1)+1500 21184 IWRTF(3)=IWRTF(2)+2000 21185 IWRTF(4)=IWRTF(3)+2000 21186 IFRST=.FALSE. 21187 ILAST=.TRUE. 21188C 21189 ISTEPN='42E' 21190 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KRU2') 21191 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 21192C 21193 CALL DPDTA4(ITITL9,NCTIT9, 21194 1 ITITLE,NCTITL,ITITL2,NCTIT2, 21195 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 21196 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW, 21197 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 21198 1 ICAPSW,ICAPTY,IFRST,ILAST, 21199 1 ISUBRO,IBUGA3,IERROR) 21200C 21201C 21202C ***************** 21203C ** STEP 90-- ** 21204C ** EXIT ** 21205C ***************** 21206C 21207 9000 CONTINUE 21208 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DUR2')THEN 21209 WRITE(ICOUT,999) 21210 CALL DPWRST('XXX','WRIT') 21211 WRITE(ICOUT,9011) 21212 9011 FORMAT('***** AT THE END OF DPDUR2--') 21213 CALL DPWRST('XXX','WRIT') 21214 WRITE(ICOUT,9012)STATVA,STATCD,PVAL 21215 9012 FORMAT('STATVA,STATCD,PVAL = ',3G15.7) 21216 CALL DPWRST('XXX','WRIT') 21217 WRITE(ICOUT,9015)N 21218 9015 FORMAT('N = ',I8) 21219 CALL DPWRST('XXX','WRIT') 21220 ENDIF 21221C 21222 RETURN 21223 END 21224 SUBROUTINE DPEBLL(P,N,ALPHA,IWRITE,ALOWLM,ICASE,IBUGA3,IERROR) 21225C 21226C PURPOSE--FOR A GIVEN P, N, AND ALPHA, COMPUTE THE 21227C EXACT BINOMIAL LOWER BINOMIAL CONFIDENCE 21228C LIMIT. THIS IS USEFUL FOR GENERATING BINOMIAL 21229C CONFIDENCE LIMITS WHEN ONLY SUMMARY INFORMATION 21230C IS AVAILABLE. 21231C WRITTEN BY--JAMES J. FILLIBEN 21232C STATISTICAL ENGINEERING DIVISION 21233C INFORMATION TECHNOLOGY LABORATORY 21234C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 21235C GAITHERSBURG, MD 20899-8980 21236C PHONE--301-975-2855 21237C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 21238C OF THE NATIONAL BUREAU OF STANDARDS. 21239C LANGUAGE--ANSI FORTRAN (1977) 21240C VERSION NUMBER--2007/2 21241C ORIGINAL VERSION--FEBRUARY 2007. 21242C UPDATED --MARCH 2007. NEED TO SUBTRACT 1 FROM 21243C NUMBER OF SUCCESSES FOR 21244C LOWER BOUND 21245C 21246C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 21247C 21248 CHARACTER*4 IWRITE 21249 CHARACTER*4 ICASE 21250 CHARACTER*4 IBUGA3 21251 CHARACTER*4 IERROR 21252C 21253 CHARACTER*4 ISUBN1 21254 CHARACTER*4 ISUBN2 21255C 21256C--------------------------------------------------------------------- 21257C 21258 REAL P 21259 REAL ALPHA 21260 REAL ALOWLM 21261 INTEGER N 21262C 21263 EXTERNAL BINFUN 21264 COMMON/BINCOM/XSUCC,CONST,NTEMP 21265C 21266C--------------------------------------------------------------------- 21267C 21268 INCLUDE 'DPCOP2.INC' 21269C 21270C-----START POINT----------------------------------------------------- 21271C 21272 ISUBN1='DPEB' 21273 ISUBN2='LL ' 21274C 21275 IERROR='NO' 21276C 21277 IF(IBUGA3.EQ.'ON')THEN 21278 WRITE(ICOUT,999) 21279 999 FORMAT(1X) 21280 CALL DPWRST('XXX','BUG ') 21281 WRITE(ICOUT,51) 21282 51 FORMAT('***** AT THE BEGINNING OF DPEBLL--') 21283 CALL DPWRST('XXX','BUG ') 21284 WRITE(ICOUT,52)IBUGA3,IWRITE 21285 52 FORMAT('IBUGA3,IWRITE = ',A4,2X,A4) 21286 CALL DPWRST('XXX','BUG ') 21287 WRITE(ICOUT,53)P,N,ALPHA 21288 53 FORMAT('P,N,ALPHA = ',G15.7,I8,G15.7) 21289 CALL DPWRST('XXX','BUG ') 21290 WRITE(ICOUT,999) 21291 CALL DPWRST('XXX','BUG ') 21292 ENDIF 21293C 21294C ******************************** 21295C ** STEP 1-- ** 21296C ** CHECK FOR INPUT ERRORS ** 21297C ******************************** 21298C 21299 IF(N.LT.1)THEN 21300 IERROR='YES' 21301 WRITE(ICOUT,999) 21302 CALL DPWRST('XXX','BUG ') 21303 WRITE(ICOUT,151) 21304 151 FORMAT('***** ERROR IN DPEBLL--') 21305 CALL DPWRST('XXX','BUG ') 21306 WRITE(ICOUT,152) 21307 152 FORMAT(' THE INPUT SAMPLE SIZE FOR THE EXACT LOWER') 21308 CALL DPWRST('XXX','BUG ') 21309 WRITE(ICOUT,154) 21310 154 FORMAT(' BINOMIAL CONFIDENCE LIMIT IS LESS THAN 1.') 21311 CALL DPWRST('XXX','BUG ') 21312 WRITE(ICOUT,157)N 21313 157 FORMAT(' THE INPUT SAMPLE SIZE = ',I8) 21314 CALL DPWRST('XXX','BUG ') 21315 GOTO9000 21316 ENDIF 21317C 21318 IF(P.LT.0.0 .OR. P.GT.1.0)THEN 21319 IERROR='YES' 21320 WRITE(ICOUT,999) 21321 CALL DPWRST('XXX','BUG ') 21322 WRITE(ICOUT,161) 21323 161 FORMAT('***** ERROR IN DPEBLL--') 21324 CALL DPWRST('XXX','BUG ') 21325 WRITE(ICOUT,162) 21326 162 FORMAT(' THE BINOMIAL PROBABILITY OF SUCCESS PARAMETER') 21327 CALL DPWRST('XXX','BUG ') 21328 WRITE(ICOUT,164) 21329 164 FORMAT(' IS OUTSIDE THE (0,1) INTERVAL.') 21330 CALL DPWRST('XXX','BUG ') 21331 WRITE(ICOUT,167)P 21332 167 FORMAT(' THE PROBABILITY OF SUCCESS PARAMETER = ',G15.7) 21333 CALL DPWRST('XXX','BUG ') 21334 GOTO9000 21335 ENDIF 21336C 21337 ALPHSV=ALPHA 21338 IF(ALPHA.GT.1.0 .AND. ALPHA.LE.100.0)ALPHA=ALPHA/100.0 21339 IF(ALPHA.LE.0.0 .OR. ALPHA.GE.1.0)THEN 21340 IERROR='YES' 21341 WRITE(ICOUT,999) 21342 CALL DPWRST('XXX','BUG ') 21343 WRITE(ICOUT,171) 21344 171 FORMAT('***** ERROR IN DPEBLL--') 21345 CALL DPWRST('XXX','BUG ') 21346 WRITE(ICOUT,172) 21347 172 FORMAT(' THE VALUE OF ALPHA IS OUTSIDE THE (0,1) ', 21348 1 'INTERVAL.') 21349 CALL DPWRST('XXX','BUG ') 21350 WRITE(ICOUT,177)ALPHSV 21351 177 FORMAT(' THE VALUE OF ALPHA = ',G15.7) 21352 CALL DPWRST('XXX','BUG ') 21353 GOTO9000 21354 ENDIF 21355C 21356C ****************************************** 21357C ** STEP 2-- ** 21358C ** COMPUTE THE EXACT LOWER BINOMIAL ** 21359C ** CONFIDENCE LIMIT ** 21360C ****************************************** 21361C 21362 ALP=ALPHA 21363 IF(ALP.LT.0.5)THEN 21364 IF(ICASE.EQ.'TWOS')THEN 21365 P2=ALP/2.0 21366 P1=1.0-(ALP/2.0) 21367 ELSE 21368 P2=ALP 21369 P1=1.0-ALP 21370 ENDIF 21371 ELSE 21372 IF(ICASE.EQ.'TWOS')THEN 21373 ALP=1.0 - ALPHA 21374 P2=ALP/2.0 21375 P1=1.0-(ALP/2.0) 21376 ELSE 21377 ALP=1.0 - ALPHA 21378 P2=ALP 21379 P1=1.0-ALP 21380 ENDIF 21381 ENDIF 21382C 21383 AN=REAL(N) 21384 Q=1.0-P 21385C 21386 CALL NORPPF(P1,ZALPHA) 21387 CONST=P1 21388 PHAT=P 21389 PLOWLI=0.0 21390 PUPPLI=PHAT 21391 IF(PHAT.LE.0.0)THEN 21392 ALOWLM=0.0 21393 ELSE 21394 NTEMP=N 21395CCCCC XSUCC=AN*P 21396 XSUCC=AN*P - 1.0 21397 AE=1.E-6 21398 RE=1.E-6 21399 CALL FZERO(BINFUN,PLOWLI,PUPPLI,PHAT,RE,AE,IFLAG) 21400 IF(PLOWLI.GT.PHAT)THEN 21401 ALOWLM=0.0 21402 ELSE 21403 ALOWLM=PLOWLI 21404 ENDIF 21405 IF(ALOWLM.LT.0.0)ALOWLM=0.0 21406C 21407 IF(IFLAG.EQ.2)THEN 21408C 21409 WRITE(ICOUT,999) 21410 CALL DPWRST('XXX','BUG ') 21411 WRITE(ICOUT,2211) 21412 2211 FORMAT('***** WARNING FROM DPEBLL--') 21413 CALL DPWRST('XXX','BUG ') 21414 WRITE(ICOUT,2213) 21415 2213 FORMAT(' ESTIMATE OF LOWER CONFIDENCE VALUE FOR P ', 21416 1 'MAY NOT BE COMPUTED TO DESIRED TOLERANCE.') 21417 CALL DPWRST('XXX','BUG ') 21418 ELSEIF(IFLAG.EQ.3)THEN 21419 WRITE(ICOUT,999) 21420 CALL DPWRST('XXX','BUG ') 21421 WRITE(ICOUT,2211) 21422 CALL DPWRST('XXX','BUG ') 21423 WRITE(ICOUT,2223) 21424 2223 FORMAT(' ESTIMATE OF LOWER CONFIDENCE VALUE FOR P ', 21425 1 'MAY BE NEAR A SINGULAR POINT.') 21426 CALL DPWRST('XXX','BUG ') 21427 ELSEIF(IFLAG.EQ.4)THEN 21428CCCCC WRITE(ICOUT,999) 21429CCCCC CALL DPWRST('XXX','BUG ') 21430CCCCC WRITE(ICOUT,2211) 21431CCCCC CALL DPWRST('XXX','BUG ') 21432CCCCC WRITE(ICOUT,2233) 21433C2233 FORMAT(' APPROPRIATE BRACKETING INTERVAL NOT FOUND.') 21434CCCCC CALL DPWRST('XXX','BUG ') 21435 ELSEIF(IFLAG.EQ.5)THEN 21436 WRITE(ICOUT,999) 21437 CALL DPWRST('XXX','BUG ') 21438 WRITE(ICOUT,2211) 21439 CALL DPWRST('XXX','BUG ') 21440 WRITE(ICOUT,2243) 21441 2243 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') 21442 CALL DPWRST('XXX','BUG ') 21443 ENDIF 21444 ENDIF 21445C 21446C ***************** 21447C ** STEP 90-- ** 21448C ** EXIT. ** 21449C ***************** 21450C 21451 9000 CONTINUE 21452C 21453 IF(IBUGA3.EQ.'ON')THEN 21454 WRITE(ICOUT,999) 21455 CALL DPWRST('XXX','BUG ') 21456 WRITE(ICOUT,9011) 21457 9011 FORMAT('***** AT THE END OF DPEBLL--') 21458 CALL DPWRST('XXX','BUG ') 21459 WRITE(ICOUT,9012)IBUGA3,IERROR,ALOWLM 21460 9012 FORMAT('IBUGA3,IERROR,ALOWLM = ',A4,2X,A4,2X,G15.7) 21461 CALL DPWRST('XXX','BUG ') 21462 ENDIF 21463C 21464 RETURN 21465 END 21466 SUBROUTINE DPEBUL(P,N,ALPHA,IWRITE,AUPPLM,ICASE,IBUGA3,IERROR) 21467C 21468C PURPOSE--FOR A GIVEN P, N, AND ALPHA, COMPUTE THE 21469C EXACT BINOMIAL UPPER BINOMIAL CONFIDENCE 21470C LIMIT. THIS IS USEFUL FOR GENERATING BINOMIAL 21471C CONFIDENCE LIMITS WHEN ONLY SUMMARY INFORMATION 21472C IS AVAILABLE. 21473C WRITTEN BY--JAMES J. FILLIBEN 21474C STATISTICAL ENGINEERING DIVISION 21475C INFORMATION TECHNOLOGY LABORATORY 21476C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 21477C GAITHERSBURG, MD 20899-8980 21478C PHONE--301-975-2855 21479C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 21480C OF THE NATIONAL BUREAU OF STANDARDS. 21481C LANGUAGE--ANSI FORTRAN (1977) 21482C VERSION NUMBER--2007/2 21483C ORIGINAL VERSION--FEBRUARY 2007. 21484C 21485C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 21486C 21487 CHARACTER*4 IWRITE 21488 CHARACTER*4 ICASE 21489 CHARACTER*4 IBUGA3 21490 CHARACTER*4 IERROR 21491C 21492 CHARACTER*4 ISUBN1 21493 CHARACTER*4 ISUBN2 21494C 21495C--------------------------------------------------------------------- 21496C 21497 REAL P 21498 REAL ALPHA 21499 REAL AUPPLM 21500 INTEGER N 21501C 21502 EXTERNAL BINFUN 21503 COMMON/BINCOM/XSUCC,CONST,NTEMP 21504C 21505C--------------------------------------------------------------------- 21506C 21507 INCLUDE 'DPCOP2.INC' 21508C 21509C-----START POINT----------------------------------------------------- 21510C 21511 ISUBN1='DPEB' 21512 ISUBN2='UL ' 21513 IERROR='NO' 21514C 21515 IF(IBUGA3.EQ.'ON')THEN 21516 WRITE(ICOUT,999) 21517 999 FORMAT(1X) 21518 CALL DPWRST('XXX','BUG ') 21519 WRITE(ICOUT,51) 21520 51 FORMAT('***** AT THE BEGINNING OF DPEBUL--') 21521 CALL DPWRST('XXX','BUG ') 21522 WRITE(ICOUT,52)IBUGA3,IWRITE 21523 52 FORMAT('IBUGA3,IWRITE = ',A4,2X,A4) 21524 CALL DPWRST('XXX','BUG ') 21525 WRITE(ICOUT,53)P,N,ALPHA 21526 53 FORMAT('P,N,ALPHA = ',G15.7,I8,G15.7) 21527 CALL DPWRST('XXX','BUG ') 21528 WRITE(ICOUT,999) 21529 CALL DPWRST('XXX','BUG ') 21530 ENDIF 21531C 21532C ******************************** 21533C ** STEP 1-- ** 21534C ** CHECK FOR INPUT ERRORS ** 21535C ******************************** 21536C 21537 IF(N.LT.1)THEN 21538 IERROR='YES' 21539 WRITE(ICOUT,999) 21540 CALL DPWRST('XXX','BUG ') 21541 WRITE(ICOUT,151) 21542 151 FORMAT('***** ERROR IN DPEBUL--') 21543 CALL DPWRST('XXX','BUG ') 21544 WRITE(ICOUT,152) 21545 152 FORMAT(' THE INPUT SAMPLE SIZE FOR THE EXACT UPPER') 21546 CALL DPWRST('XXX','BUG ') 21547 WRITE(ICOUT,154) 21548 154 FORMAT(' BINOMIAL CONFIDENCE LIMIT IS LESS THAN 1.') 21549 CALL DPWRST('XXX','BUG ') 21550 WRITE(ICOUT,157)N 21551 157 FORMAT(' THE INPUT SAMPLE SIZE = ',I8) 21552 CALL DPWRST('XXX','BUG ') 21553 GOTO9000 21554 ENDIF 21555C 21556 IF(P.LT.0.0 .OR. P.GT.1.0)THEN 21557 IERROR='YES' 21558 WRITE(ICOUT,999) 21559 CALL DPWRST('XXX','BUG ') 21560 WRITE(ICOUT,161) 21561 161 FORMAT('***** ERROR IN DPEBUL--') 21562 CALL DPWRST('XXX','BUG ') 21563 WRITE(ICOUT,162) 21564 162 FORMAT(' THE BINOMIAL PROBABILITY OF SUCCESS PARAMETER') 21565 CALL DPWRST('XXX','BUG ') 21566 WRITE(ICOUT,164) 21567 164 FORMAT(' IS OUTSIDE THE (0,1) INTERVAL.') 21568 CALL DPWRST('XXX','BUG ') 21569 WRITE(ICOUT,167)P 21570 167 FORMAT(' THE PROBABILITY OF SUCCESS PARAMETER = ',G15.7) 21571 CALL DPWRST('XXX','BUG ') 21572 GOTO9000 21573 ENDIF 21574C 21575 ALPHSV=ALPHA 21576 IF(ALPHA.GT.1.0 .AND. ALPHA.LE.100.0)ALPHA=ALPHA/100.0 21577 IF(ALPHA.LE.0.0 .OR. ALPHA.GE.1.0)THEN 21578 IERROR='YES' 21579 WRITE(ICOUT,999) 21580 CALL DPWRST('XXX','BUG ') 21581 WRITE(ICOUT,171) 21582 171 FORMAT('***** ERROR IN DPEBUL--') 21583 CALL DPWRST('XXX','BUG ') 21584 WRITE(ICOUT,172) 21585 172 FORMAT(' THE VALUE OF ALPHA IS OUTSIDE THE (0,1) ', 21586 1 'INTERVAL.') 21587 CALL DPWRST('XXX','BUG ') 21588 WRITE(ICOUT,177)ALPHSV 21589 177 FORMAT(' THE VALUE OF ALPHA = ',G15.7) 21590 CALL DPWRST('XXX','BUG ') 21591 GOTO9000 21592 ENDIF 21593C 21594C ****************************************** 21595C ** STEP 2-- ** 21596C ** COMPUTE THE EXACT UPPER BINOMIAL ** 21597C ** CONFIDENCE LIMIT ** 21598C ****************************************** 21599C 21600 ALP=ALPHA 21601 IF(ALP.LT.0.5)THEN 21602 IF(ICASE.EQ.'TWOS')THEN 21603 P2=ALP/2.0 21604 P1=1.0-(ALP/2.0) 21605 ELSE 21606 P2=ALP 21607 P1=1.0-ALP 21608 ENDIF 21609 ELSE 21610 IF(ICASE.EQ.'TWOS')THEN 21611 ALP=1.0 - ALPHA 21612 P2=ALP/2.0 21613 P1=1.0-(ALP/2.0) 21614 ELSE 21615 ALP=1.0 - ALPHA 21616 P2=ALP 21617 P1=1.0-ALP 21618 ENDIF 21619 ENDIF 21620C 21621 AN=REAL(N) 21622 Q=1.0-P 21623C 21624 CALL NORPPF(P2,ZALPHA) 21625 CONST=P2 21626 PHAT=P 21627 PLOWLI=PHAT 21628 PUPPLI=1.0 21629 IF(PHAT.GE.1.0)THEN 21630 AUPPLM=1.0 21631 ELSE 21632 NTEMP=N 21633 XSUCC=AN*P 21634 AE=1.E-6 21635 RE=1.E-6 21636 CALL FZERO(BINFUN,PLOWLI,PUPPLI,PHAT,RE,AE,IFLAG) 21637 IF(PLOWLI.LT.PHAT)THEN 21638 AUPPLM=PUPPLI 21639 ELSE 21640 AUPPLM=PLOWLI 21641 ENDIF 21642 IF(AUPPLM.GT.1.0)AUPPLM=1.0 21643C 21644 IF(IFLAG.EQ.2)THEN 21645C 21646 WRITE(ICOUT,999) 21647 CALL DPWRST('XXX','BUG ') 21648 WRITE(ICOUT,2211) 21649 2211 FORMAT('***** WARNING FROM DPEBUL--') 21650 CALL DPWRST('XXX','BUG ') 21651 WRITE(ICOUT,2213) 21652 2213 FORMAT(' ESTIMATE OF UPPER CONFIDENCE VALUE FOR P ', 21653 1 'MAY NOT BE COMPUTED TO DESIRED TOLERANCE.') 21654 CALL DPWRST('XXX','BUG ') 21655 ELSEIF(IFLAG.EQ.3)THEN 21656 WRITE(ICOUT,999) 21657 CALL DPWRST('XXX','BUG ') 21658 WRITE(ICOUT,2211) 21659 CALL DPWRST('XXX','BUG ') 21660 WRITE(ICOUT,2223) 21661 2223 FORMAT(' ESTIMATE OF UPPER CONFIDENCE VALUE FOR P ', 21662 1 'MAY BE NEAR A SINGULAR POINT.') 21663 CALL DPWRST('XXX','BUG ') 21664 ELSEIF(IFLAG.EQ.4)THEN 21665CCCCC WRITE(ICOUT,999) 21666CCCCC CALL DPWRST('XXX','BUG ') 21667CCCCC WRITE(ICOUT,2211) 21668CCCCC CALL DPWRST('XXX','BUG ') 21669CCCCC WRITE(ICOUT,2233) 21670C2233 FORMAT(' APPROPRIATE BRACKETING INTERVAL NOT FOUND.') 21671CCCCC CALL DPWRST('XXX','BUG ') 21672 ELSEIF(IFLAG.EQ.5)THEN 21673 WRITE(ICOUT,999) 21674 CALL DPWRST('XXX','BUG ') 21675 WRITE(ICOUT,2211) 21676 CALL DPWRST('XXX','BUG ') 21677 WRITE(ICOUT,2243) 21678 2243 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') 21679 CALL DPWRST('XXX','BUG ') 21680 ENDIF 21681 ENDIF 21682C 21683C ***************** 21684C ** STEP 90-- ** 21685C ** EXIT. ** 21686C ***************** 21687C 21688 9000 CONTINUE 21689C 21690 IF(IBUGA3.EQ.'ON')THEN 21691 WRITE(ICOUT,999) 21692 CALL DPWRST('XXX','BUG ') 21693 WRITE(ICOUT,9011) 21694 9011 FORMAT('***** AT THE END OF DPEBUL--') 21695 CALL DPWRST('XXX','BUG ') 21696 WRITE(ICOUT,9012)IBUGA3,IERROR,AUPPLM 21697 9012 FORMAT('IBUGA3,IERROR,AUPPLM = ',A4,2X,A4,2X,G15.7) 21698 CALL DPWRST('XXX','BUG ') 21699 ENDIF 21700C 21701 RETURN 21702 END 21703 SUBROUTINE DPECDF(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 21704 1 IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR) 21705C 21706C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS 21707C THAT WILL DEFINE AN EMPIRICAL CDF PLOT 21708C WRITTEN BY--JAMES J. FILLIBEN 21709C STATISTICAL ENGINEERING DIVISION 21710C INFORMATION TECHNOLOGY LABORATORY 21711C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 21712C GAITHERSBURG, MD 20899-8980 21713C PHONE--301-975-2899 21714C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 21715C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 21716C LANGUAGE--ANSI FORTRAN (1977) 21717C VERSION NUMBER--98/5 21718C ORIGINAL VERSION--MAY 1998. 21719C UPDATED --JANUARY 2012. USE DPPARS 21720C 21721C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 21722C 21723 CHARACTER*4 ICASPL 21724 CHARACTER*4 IAND1 21725 CHARACTER*4 IAND2 21726 CHARACTER*4 IBUGG2 21727 CHARACTER*4 IBUGG3 21728 CHARACTER*4 ISUBRO 21729 CHARACTER*4 IBUGQ 21730 CHARACTER*4 IFOUND 21731 CHARACTER*4 IERROR 21732C 21733 CHARACTER*4 ISUBN1 21734 CHARACTER*4 ISUBN2 21735 CHARACTER*4 ISTEPN 21736C 21737 CHARACTER*4 ICASE 21738 CHARACTER*40 INAME 21739 PARAMETER (MAXSPN=10) 21740 CHARACTER*4 IVARN1(MAXSPN) 21741 CHARACTER*4 IVARN2(MAXSPN) 21742 CHARACTER*4 IVARTY(MAXSPN) 21743 REAL PVAR(MAXSPN) 21744 INTEGER ILIS(MAXSPN) 21745 INTEGER NRIGHT(MAXSPN) 21746 INTEGER ICOLR(MAXSPN) 21747C 21748C--------------------------------------------------------------------- 21749C 21750 INCLUDE 'DPCOPA.INC' 21751 INCLUDE 'DPCOZZ.INC' 21752C 21753 DIMENSION Y1(MAXOBV) 21754 DIMENSION X1(MAXOBV) 21755 EQUIVALENCE (GARBAG(IGARB1),Y1(1)) 21756 EQUIVALENCE (GARBAG(IGARB2),X1(1)) 21757C 21758C-----COMMON---------------------------------------------------------- 21759C 21760 INCLUDE 'DPCOHK.INC' 21761 INCLUDE 'DPCODA.INC' 21762 INCLUDE 'DPCOP2.INC' 21763C 21764C-----START POINT----------------------------------------------------- 21765C 21766 IFOUND='NO' 21767 IERROR='NO' 21768 ISUBN1='DPEC' 21769 ISUBN2='DF ' 21770C 21771 MAXCP1=MAXCOL+1 21772 MAXCP2=MAXCOL+2 21773 MAXCP3=MAXCOL+3 21774 MAXCP4=MAXCOL+4 21775 MAXCP5=MAXCOL+5 21776 MAXCP6=MAXCOL+6 21777C 21778 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ECDF')THEN 21779 WRITE(ICOUT,999) 21780 999 FORMAT(1X) 21781 CALL DPWRST('XXX','BUG ') 21782 WRITE(ICOUT,51) 21783 51 FORMAT('***** AT THE BEGINNING OF DPECDF--') 21784 CALL DPWRST('XXX','BUG ') 21785 WRITE(ICOUT,52)ICASPL,IAND1,IAND2,MAXCOL 21786 52 FORMAT('ICASPL,IAND1,IAND2,MAXCOL = ',3(A4,2X),I8) 21787 CALL DPWRST('XXX','BUG ') 21788 WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO 21789 53 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4) 21790 CALL DPWRST('XXX','BUG ') 21791 ENDIF 21792C 21793C 21794C *********************************** 21795C ** TREAT THE EMPIRICAL CDF PLOT ** 21796C *********************************** 21797C 21798C ******************************************* 21799C ** STEP 1-- ** 21800C ** SEARCH FOR EMPIRICAL CDF, ECDF ** 21801C ******************************************* 21802C 21803 ISTEPN='11' 21804 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ECDF') 21805 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 21806C 21807 ICASPL='ECDF' 21808 IF(NUMARG.GE.1.AND.ICOM.EQ.'ECDF'.AND.IHARG(1).EQ.'PLOT')THEN 21809 ILASTC=1 21810 ELSEIF(NUMARG.GE.2.AND.ICOM.EQ.'EMPI'.AND. 21811 1 IHARG(1).EQ.'CDF '.AND.IHARG(2).EQ.'PLOT')THEN 21812 ILASTC=2 21813 ELSE 21814 ICASPL=' ' 21815 IFOUND='NO' 21816 GOTO9000 21817 ENDIF 21818C 21819 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 21820 IFOUND='YES' 21821C 21822C **************************************** 21823C ** STEP 2-- ** 21824C ** EXTRACT THE VARIABLE LIST ** 21825C **************************************** 21826C 21827 ISTEPN='2' 21828 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ECDF') 21829 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 21830C 21831 INAME='EMPIRICAL CDF PLOT' 21832 MINNA=1 21833 MAXNA=100 21834 MINN2=1 21835 IFLAGE=1 21836 IFLAGM=0 21837 IFLAGP=0 21838 JMIN=1 21839 JMAX=NUMARG 21840 MINNVA=1 21841 MAXNVA=2 21842C 21843 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 21844 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 21845 1 JMIN,JMAX, 21846 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 21847 1 IVARN1,IVARN2,IVARTY,PVAR, 21848 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 21849 1 MINNVA,MAXNVA, 21850 1 IFLAGM,IFLAGP, 21851 1 IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 21852 IF(IERROR.EQ.'YES')GOTO9000 21853C 21854 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ECDF')THEN 21855 WRITE(ICOUT,999) 21856 CALL DPWRST('XXX','BUG ') 21857 WRITE(ICOUT,281) 21858 281 FORMAT('***** AFTER CALL DPPARS--') 21859 CALL DPWRST('XXX','BUG ') 21860 WRITE(ICOUT,282)NQ,NUMVAR 21861 282 FORMAT('NQ,NUMVAR = ',2I8) 21862 CALL DPWRST('XXX','BUG ') 21863 IF(NUMVAR.GT.0)THEN 21864 DO285I=1,NUMVAR 21865 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 21866 1 ICOLR(I) 21867 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 21868 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 21869 CALL DPWRST('XXX','BUG ') 21870 285 CONTINUE 21871 ENDIF 21872 ENDIF 21873C 21874C ******************************************************* 21875C ** STEP 41-- ** 21876C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** 21877C ** VARIABLES (Y(.) AND X(.), RESPECTIVELY)FOR THE ** 21878C ** PLOT FORM THE CURVE DESIGNATION VARIABLED(.) . ** 21879C ** THIS WILL BE ALL ONES. ** 21880C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** 21881C ** DEFINE THE NUMBER OF PLOT VARIABLES(NPLOTV). ** 21882C ******************************************************* 21883C 21884 ISTEPN='41' 21885 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ECDF') 21886 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 21887C 21888 ICOL=1 21889 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 21890 1 INAME,IVARN1,IVARN2,IVARTY, 21891 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 21892 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 21893 1 MAXCP4,MAXCP5,MAXCP6, 21894 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 21895 1 Y1,X1,Y1,NS,NS,NS,ICASE, 21896 1 IBUGG3,ISUBRO,IFOUND,IERROR) 21897 IF(IERROR.EQ.'YES')GOTO9000 21898C 21899 CALL DPECD2(Y1,X1,NS,NUMVAR,ICASPL,MAXN, 21900 1 Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 21901C 21902C ***************** 21903C ** STEP 90-- ** 21904C ** EXIT ** 21905C ***************** 21906C 21907 9000 CONTINUE 21908 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ECDF')THEN 21909 WRITE(ICOUT,999) 21910 CALL DPWRST('XXX','BUG ') 21911 WRITE(ICOUT,9011) 21912 9011 FORMAT('***** AT THE END OF DPECDF--') 21913 CALL DPWRST('XXX','BUG ') 21914 WRITE(ICOUT,9012)IFOUND,IERROR 21915 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 21916 CALL DPWRST('XXX','BUG ') 21917 WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 21918 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',3I8,3(2X,A4)) 21919 CALL DPWRST('XXX','BUG ') 21920 IF(NPLOTP.GT.0)THEN 21921 DO9015I=1,NPLOTP 21922 WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 21923 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) 21924 CALL DPWRST('XXX','BUG ') 21925 9015 CONTINUE 21926 ENDIF 21927 ENDIF 21928C 21929 RETURN 21930 END 21931 SUBROUTINE DPECD2(Y1,X1,N,NUMV,ICASPL,MAXN, 21932 1 Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 21933C 21934C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS 21935C THAT WILL DEFINE AN EMPIRICAL CDF PLOT 21936C INPUT ARGUMENTS--Y1 = THE SINGLE PRECISION VECTOR OF 21937C (UNSORTED) OBSERVATIONS 21938C FOR THE FIRST VARIABLE. 21939C IF X1 IS SPECIFIED, THEN Y1 BECOMES 21940C A FREQUENCY VARIABLE 21941C X1 = IF SPECIFIED, IT REPRESENTS THE 21942C OBSERVATION POINTS (AND Y1 IS THE 21943C FREQUENCY) 21944C N = THE INTEGER NUMBER OF OBSERVATIONS 21945C IN THE VECTOR X. 21946C WRITTEN BY--JAMES J. FILLIBEN 21947C STATISTICAL ENGINEERING DIVISION 21948C INFORMATION TECHNOLOGY LABORATORY 21949C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 21950C GAITHERSBURG, MD 20899-8980 21951C PHONE--301-975-2899 21952C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 21953C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 21954C LANGUAGE--ANSI FORTRAN (1977) 21955C VERSION NUMBER--98/5 21956C ORIGINAL VERSION--MAY 1998. 21957C 21958C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 21959C 21960 CHARACTER*4 ICASPL 21961 CHARACTER*4 IBUGG3 21962 CHARACTER*4 ISUBRO 21963 CHARACTER*4 IERROR 21964C 21965 CHARACTER*4 IWRITE 21966 CHARACTER*4 ISUBN1 21967 CHARACTER*4 ISUBN2 21968C 21969C--------------------------------------------------------------------- 21970C 21971 DIMENSION Y1(*) 21972 DIMENSION X1(*) 21973C 21974 DIMENSION Y(*) 21975 DIMENSION X(*) 21976 DIMENSION D(*) 21977C 21978C--------------------------------------------------------------------- 21979C 21980 INCLUDE 'DPCOP2.INC' 21981C 21982C-----START POINT----------------------------------------------------- 21983C 21984 ISUBN1='DPEC' 21985 ISUBN2='D2 ' 21986 IERROR='NO' 21987C 21988 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'ECD2')THEN 21989 WRITE(ICOUT,999) 21990 999 FORMAT(1X) 21991 CALL DPWRST('XXX','BUG ') 21992 WRITE(ICOUT,51) 21993 51 FORMAT('***** AT THE BEGINNING OF DPECD2--') 21994 CALL DPWRST('XXX','BUG ') 21995 WRITE(ICOUT,52)IBUGG3,ISUBRO,IERROR 21996 52 FORMAT('IBUGG3,ISUBRO,IERROR = ',2(A4,2X),A4) 21997 CALL DPWRST('XXX','BUG ') 21998 WRITE(ICOUT,53)ICASPL,N,NUMV,MAXN 21999 53 FORMAT('ICASPL,N,NUMV,MAXN = ',A4,2X,3I8) 22000 CALL DPWRST('XXX','BUG ') 22001 DO55I=1,N 22002 WRITE(ICOUT,56)I,Y1(I),X1(I) 22003 56 FORMAT('I, Y1(I), X1(I), = ',I8,2G15.7) 22004 CALL DPWRST('XXX','BUG ') 22005 55 CONTINUE 22006 ENDIF 22007C 22008C ******************************************** 22009C ** STEP 1-- ** 22010C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 22011C ******************************************** 22012C 22013 IF(N.LT.2)THEN 22014 WRITE(ICOUT,999) 22015 CALL DPWRST('XXX','BUG ') 22016 WRITE(ICOUT,111) 22017 111 FORMAT('***** ERROR IN EMPIRICAL CDF PLOT--') 22018 CALL DPWRST('XXX','BUG ') 22019 WRITE(ICOUT,112) 22020 112 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.') 22021 CALL DPWRST('XXX','BUG ') 22022 WRITE(ICOUT,114)N 22023 114 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) 22024 CALL DPWRST('XXX','BUG ') 22025 WRITE(ICOUT,999) 22026 CALL DPWRST('XXX','BUG ') 22027 IERROR='YES' 22028 GOTO9000 22029 ENDIF 22030C 22031 HOLD=Y1(1) 22032 DO120I=1,N 22033 IF(Y1(I).NE.HOLD)GOTO129 22034 120 CONTINUE 22035 WRITE(ICOUT,999) 22036 CALL DPWRST('XXX','BUG ') 22037 WRITE(ICOUT,111) 22038 CALL DPWRST('XXX','BUG ') 22039 WRITE(ICOUT,122)HOLD 22040 122 FORMAT(' ALL ELEMENTS IN THE RESPONSE VARIABLE ARE ', 22041 1 'IDENTICALLY EQUAL TO ',G15.7) 22042 CALL DPWRST('XXX','BUG ') 22043 WRITE(ICOUT,999) 22044 CALL DPWRST('XXX','BUG ') 22045 IERROR='YES' 22046 GOTO9000 22047 129 CONTINUE 22048C 22049C ************************************************* 22050C ** STEP 12-- ** 22051C ** COMPUTE COORDINATES FOR EMPIRICAL CDF PLOT ** 22052C ** (INCORPORATE STAIR-STEP APPEARANCE) ** 22053C ************************************************* 22054C 22055 IF(NUMV.EQ.1)THEN 22056 CALL SORT(Y1,N,Y1) 22057 J=1 22058 X(J)=Y1(1) 22059 Y(J)=0.0 22060 D(J)=1.0 22061 J=2 22062 X(J)=Y1(1) 22063 Y(J)=1.0/REAL(N) 22064 D(J)=1.0 22065 DO200I=2,N 22066 J=J+1 22067 X(J)=Y1(I) 22068 Y(J)=REAL(I-1)/REAL(N) 22069 D(J)=1.0 22070 J=J+1 22071 X(J)=Y1(I) 22072 Y(J)=REAL(I)/REAL(N) 22073 D(J)=1.0 22074 200 CONTINUE 22075 ELSE 22076C 22077C NOTE: THIS SECTION NEEDS TO BE FIXED. 22078C 22079 DO300I=1,N 22080 X1(I)=HOLD 22081 X1(I)=Y1(I) 22082 Y1(I)=HOLD 22083 300 CONTINUE 22084C 22085 CALL SORTC(X1,Y1,N,X1,Y1) 22086 IWRITE='OFF' 22087 CALL SUMDP(Y1,N,IWRITE,YSUM,IBUGG3,IERROR) 22088 CALL CUMSUM(Y1,N,IWRITE,Y1,IBUGG3,IERROR) 22089 J=1 22090 X(J)=X1(1) 22091 Y(J)=0.0 22092 D(J)=1.0 22093 J=2 22094 X(J)=X1(1) 22095 Y(J)=Y1(1)/REAL(YSUM) 22096 D(J)=1.0 22097 DO310I=2,N 22098 J=J+1 22099 X(J)=X1(I) 22100 Y(J)=Y1(I-1)/YSUM 22101 D(J)=1.0 22102 J=J+1 22103 X(J)=X1(I) 22104 Y(J)=Y1(I)/YSUM 22105 D(J)=1.0 22106 310 CONTINUE 22107 ENDIF 22108C 22109 NPLOTP=J 22110 NPLOTV=2 22111 GOTO9000 22112C 22113C ****************** 22114C ** STEP 90-- ** 22115C ** EXIT ** 22116C ****************** 22117C 22118 9000 CONTINUE 22119 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'ECD2')THEN 22120 WRITE(ICOUT,999) 22121 CALL DPWRST('XXX','BUG ') 22122 WRITE(ICOUT,9011) 22123 9011 FORMAT('***** AT THE END OF DPECD2--') 22124 CALL DPWRST('XXX','BUG ') 22125 WRITE(ICOUT,9012)IBUGG3,ISUBRO,IERROR 22126 9012 FORMAT('IBUGG3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) 22127 CALL DPWRST('XXX','BUG ') 22128 WRITE(ICOUT,9021)NPLOTP,NPLOTV 22129 9021 FORMAT('NPLOTP,NPLOTV = ',2I8) 22130 CALL DPWRST('XXX','BUG ') 22131 DO9022I=1,NPLOTP 22132 WRITE(ICOUT,9023)I,Y(I),X(I),D(I) 22133 9023 FORMAT('I,Y(I),X(I),D(I) = ',I8,3G15.7) 22134 CALL DPWRST('XXX','BUG ') 22135 9022 CONTINUE 22136 ENDIF 22137C 22138 RETURN 22139 END 22140