1 SUBROUTINE DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) 2C 3C NOTE--THIS SUBROUTINE IS IDENTICAL TO THE DPSUB2 SUBROUTINE 4C AND THE DPSUB3 SUBROUTINE 5C AND HAS BEEN DUPLICATED TO THEM ONLY FOR ECONOMY OF MAPPING PURPOSES 6C THAT IS, TO SAVE STORAGE IN THE MAPPING. 7C FOR VIRTUAL OPERATING SYSTEMS, THIS DUPLICATION IS NEEDLESS. 8C ANY CALLS TO SUBROUTINES DPSUB2 AND SPSUB3 COULD BE CHANGED 9C TO CALLS TO DPSUBS. 10C 11C PURPOSE--DEFINE AN INTEGER 0-1 VECTOR ISUB 12C WHICH WILL BE USED IN OTHER SUBROUTINES 13C FOR EXTRACTING SUBSETS. 14C NOTE THAT IF THE WORDS SUBSET OR EXCEPT IS NOT 15C IN THE ARGUMENT LIST, 16C THEN THE OUTPUT PARAMETER WILL BE SET TO NUMARG+1. 17C WRITTEN BY--JAMES J. FILLIBEN 18C STATISTICAL ENGINEERING DIVISION 19C INFORMATION TECHNOLOGY LABORATORY 20C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 21C GAITHERSBURG, MD 20899-8980 22C PHONE--301-975-2899 23C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 24C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 25C LANGUAGE--ANSI FORTRAN (1977) 26C VERSION NUMBER--82/7 27C ORIGINAL VERSION--JANUARY 1978. 28C UPDATED --JANUARY 1978. 29C UPDATED --FEBRUARY 1978. 30C UPDATED --MAY 1978. 31C UPDATED --OCTOBER 1978. 32C UPDATED --NOVEMBER 1978. 33C UPDATED --FEBRUARY 1979. 34C UPDATED --NOVEMBER 1980. 35C UPDATED --JANUARY 1981. 36C UPDATED --JULY 1981. 37C UPDATED --SEPTEMBER 1981. 38C UPDATED --DECEMBER 1981. 39C UPDATED --MARCH 1982. 40C UPDATED --MAY 1982. 41C UPDATED --MARCH 1988. ALLOW NOT EQUAL <> >< NOT= 42C UPDATED --JANUARY 1989. CHECK FOR EMPTY SUBSETS (ALAN) 43C 44C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 45C 46 CHARACTER*4 IBUGQ 47 CHARACTER*4 IERROR 48C 49 CHARACTER*4 ICASSC 50 CHARACTER*4 ICASQU 51 CHARACTER*4 ICASVA 52 CHARACTER*4 IHWUSE 53 CHARACTER*4 MESSAG 54 CHARACTER*4 ICASOP 55 CHARACTER*4 IHSET 56 CHARACTER*4 IHSET2 57 CHARACTER*4 IH 58 CHARACTER*4 IH2 59C 60 CHARACTER*4 ISUBN1 61 CHARACTER*4 ISUBN2 62 CHARACTER*4 ISTEPN 63C 64C-----COMMON---------------------------------------------------------- 65C 66 INCLUDE 'DPCOPA.INC' 67 INCLUDE 'DPCOHK.INC' 68 INCLUDE 'DPCODA.INC' 69 INCLUDE 'DPCOP2.INC' 70C 71C-----START POINT----------------------------------------------------- 72C 73 ISUBN1='DPSU' 74 ISUBN2='BS ' 75 IERROR='NO' 76C 77 MAXCP1=MAXCOL+1 78 MAXCP2=MAXCOL+2 79 MAXCP3=MAXCOL+3 80 MAXCP4=MAXCOL+4 81 MAXCP5=MAXCOL+5 82 MAXCP6=MAXCOL+6 83 TARGET=0.0 84C 85C ******************************** 86C ** TREAT THE SUBSET CASE ** 87C ******************************** 88C 89 IF(IBUGQ.EQ.'ON')THEN 90 WRITE(ICOUT,999) 91 999 FORMAT(1X) 92 CALL DPWRST('XXX','BUG ') 93 WRITE(ICOUT,51) 94 51 FORMAT('***** AT THE BEGINNING OF DPSUBS--') 95 CALL DPWRST('XXX','BUG ') 96 WRITE(ICOUT,52)NIOLD,ILOCS,NS 97 52 FORMAT('NIOLD,ILOCS,NS = ',3I8) 98 CALL DPWRST('XXX','BUG ') 99 WRITE(ICOUT,54)IBUGQ,IERROR 100 54 FORMAT('IBUGQ,IERROR = ',A4,2X,A4) 101 CALL DPWRST('XXX','BUG ') 102 WRITE(ICOUT,55)NUMARG,NUMNAM,MAXNAM,N,MAXN 103 55 FORMAT('NUMARG,NUMNAM,MAXNAM,N,MAXN = ',5I8) 104 CALL DPWRST('XXX','BUG ') 105 WRITE(ICOUT,56)IWIDTH,ILOCS,ILOCS2,ILOCTG 106 56 FORMAT('IWIDTH,ILOCS,ILOCS2,ILOCTG = ',4I8) 107 CALL DPWRST('XXX','BUG ') 108 ENDIF 109C 110C ******************************************************** 111C ** STEP 1-- ** 112C ** INITIALIZE THE SUBSET SIZE (NS) TO NIOLD. CHECK ** 113C ** FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ALSO ** 114C ** CHECK THAT THE RELEVANT NUMBER OF OBSERVATIONS ** 115C ** (NIOLD) IS POSITIVE. ** 116C ******************************************************** 117C 118 ISTEPN='1' 119 IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 120C 121 NS=NIOLD 122 ILOCS=NUMARG+1 123 MINNA=0 124 MAXNA=100 125 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 126 1 IERROR) 127 IF(IERROR.EQ.'YES')GOTO9000 128C 129 IF(NIOLD.LT.1)THEN 130 WRITE(ICOUT,999) 131 CALL DPWRST('XXX','BUG ') 132 WRITE(ICOUT,111) 133 111 FORMAT('***** ERROR IN DPSUBS--') 134 CALL DPWRST('XXX','BUG ') 135 WRITE(ICOUT,112) 136 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS (FROM WHICH') 137 CALL DPWRST('XXX','BUG ') 138 WRITE(ICOUT,113) 139 113 FORMAT(' A SUBSET WAS TO HAVE BEEN EXTRACTED) IS 0.') 140 CALL DPWRST('XXX','BUG ') 141 IERROR='YES' 142 GOTO9000 143 ENDIF 144C 145C ******************************************************** 146C ** STEP 2.1-- ** 147C ** INITIALIZE ALL ELEMENTS IN ISUB(.) TO 11 ** 148C ** ISUB(.) WILL TAKE ON 4 VALUES AT MOST-- ** 149C ** 00, 01, 10, 11 . ** 150C ** THE FIRST DIGIT INDICATES WHETHER OR NOT THE ** 151C ** GIVEN ELEMENT IS OUT (0) OR IN (1) OF THE LOCAL ** 152C ** CUMULATIVE UNION SET. ** 153C ** THE SECOND DIGIT INDICATES WHETHER OR NOT THE ** 154C ** GIVEN ELEMENT IS OUT (0) OR IN (1) OF THE GLOBAL ** 155C ** CUMULATIVE INTERSECTION SET. ** 156C ** THE INITIALIZATION OF ALL ELEMENTS TO 11 THUS ** 157C ** INDICATES THAT INITIALLY ALL ELEMENTS (TEMPORARILY)* 158C ** ARE IN THE LOCAL UNION SET, AND INITIALLY ALL ** 159C ** ELEMENTS ARE IN THE GLOBAL INTERSECTION SET. ** 160C ******************************************************** 161C 162 ISTEPN='2.1' 163 IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 164C 165 DO200I=1,NIOLD 166 ISUB(I)=11 167 200 CONTINUE 168C 169C ************************************************* 170C ** STEP 2.2-- ** 171C ** IF EXISTENT, ** 172C ** PACK < = INTO <= ** 173C ** PACK = < INTO =< ** 174C ** PACK > = INTO >= ** 175C ** PACK = > INTO => ** 176C ** THIS IS BECAUSE = SIGNS ARE AUTOMATICALLY ** 177C ** GIVEN A SPACE IN DPTYPE AND TREATED AS ** 178C ** AS A SEPARATE WORD. ** 179C ** NOTE THAT NUMARG WILL BE CHANGED. ** 180C ************************************************* 181C 182 ISTEPN='2.2' 183 IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 184C 185 CALL ADJUS2(IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 186C 187C ************************************************ 188C ** STEP 3.1-- ** 189C ** CHECK TO SEE IF HAVE THE SUBSET CASE. ** 190C ** CHECK TO SEE IF HAVE THE EXCEPT CASE. ** 191C ** LOCATE THE POSITION IN THE ARGUMENT LIST ** 192C ** OF THE WORD SUBSET OR EXCEPT . ** 193C ************************************************ 194C 195 ISTEPN='3.1' 196 IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 197C 198 JMAX=0 199 ICASSC='SEAR' 200 ICASQU='UNKN' 201 NUMSV=0 202 DO300IPASS=1,100 203C 204 IF(IBUGQ.EQ.'ON')THEN 205 WRITE(ICOUT,999) 206 CALL DPWRST('XXX','BUG ') 207 WRITE(ICOUT,301) 208 301 FORMAT('***** AT THE BEGINNING OF ANOTHER PASS--') 209 CALL DPWRST('XXX','BUG ') 210 WRITE(ICOUT,302)IPASS,ILOCTG 211 302 FORMAT('IPASS,ILOCTG = ',2I8) 212 CALL DPWRST('XXX','BUG ') 213 IF(ILOCTG.GE.1)THEN 214 WRITE(ICOUT,303)ICASSC,ILOCTG,IHARG(ILOCTG),IHARG2(ILOCTG) 215 303 FORMAT('ICASSC,ILOCTG,IHARG(ILOCTG),IHARG2(ILOCTG) = ', 216 1 A4,I8,2(2X,A4)) 217 CALL DPWRST('XXX','BUG ') 218 ENDIF 219 WRITE(ICOUT,304)JMAX 220 304 FORMAT('JMAX= ',I8) 221 CALL DPWRST('XXX','BUG ') 222 ENDIF 223C 224 IF(ICASSC.EQ.'STOP')GOTO1100 225 JMIN=JMAX+1 226 IF(JMIN.GT.NUMARG)GOTO1100 227 IF(JMIN.EQ.NUMARG.AND.IHARG(JMIN).EQ.'AND '.AND. 228 1IHARG2(JMIN).EQ.' ')GOTO1100 229C 230 IF(ICASSC.EQ.'CONT')GOTO600 231 DO310I=1,NIOLD 232 ITEMP=ISUB(I) 233 IF(ITEMP.EQ.00)ISUB(I)=00 234 IF(ITEMP.EQ.10)ISUB(I)=00 235 IF(ITEMP.EQ.01)ISUB(I)=00 236 IF(ITEMP.EQ.11)ISUB(I)=11 237 310 CONTINUE 238 ICASQU='UNKN' 239 DO340J=JMIN,NUMARG 240 J2=J 241 IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')THEN 242 ICASQU='SUBS' 243 ILOCS=J2 244CCCCC THE FOLLOWING 6 LINES WERE INSERTED MARCH 1988. 245 ILOCS2=ILOCS+2 246 IHSET=IHARG(ILOCS2) 247 IHSET2=IHARG2(ILOCS2) 248 IF(IHSET.EQ.'<> ')ICASQU='EXCE' 249 IF(IHSET.EQ.'>< ')ICASQU='EXCE' 250 IF(IHSET.EQ.'NOT=')ICASQU='EXCE' 251 GOTO390 252 ELSEIF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')THEN 253 ICASQU='EXCE' 254 ILOCS=J2 255 GOTO390 256 ENDIF 257 340 CONTINUE 258 ILOCS=NUMARG+1 259 GOTO1100 260C 261 390 CONTINUE 262C 263 IF(IBUGQ.EQ.'ON')THEN 264 WRITE(ICOUT,391)IPASS,ICASQU,ILOCS 265 391 FORMAT('IPASS,ICASQU,ILOCS = ',I8,2X,A4,I8) 266 CALL DPWRST('XXX','BUG ') 267 ENDIF 268C 269C ******************************************* 270C ** STEP 3.2-- ** 271C ** IF HAVE THE SUBSET CASE, ** 272C ** INITIALIZE ISUB(.) TO 0X--00 OR 01. ** 273C ** IF HAVE THE EXCEPT CASE, ** 274C ** INITIALIZE ISUB(.) TO 1X--10 OR 11. ** 275C ******************************************* 276C 277 ISTEPN='3.2' 278 IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 279C 280 IF(ICASQU.EQ.'SUBS')THEN 281 DO401I=1,NIOLD 282 ITEMP=ISUB(I) 283 IF(ITEMP.EQ.00)ISUB(I)=00 284 IF(ITEMP.EQ.10)ISUB(I)=00 285 IF(ITEMP.EQ.01)ISUB(I)=01 286 IF(ITEMP.EQ.11)ISUB(I)=01 287 401 CONTINUE 288 ELSE 289 DO406I=1,NIOLD 290 ITEMP=ISUB(I) 291 IF(ITEMP.EQ.00)ISUB(I)=10 292 IF(ITEMP.EQ.10)ISUB(I)=10 293 IF(ITEMP.EQ.01)ISUB(I)=11 294 IF(ITEMP.EQ.11)ISUB(I)=11 295 406 CONTINUE 296 ENDIF 297C 298C ******************************************************** 299C ** STEP 4-- ** 300C ** CHECK VALIDITY OF FIRST ARGUMENT AFTER SUBSET ** 301C ** OR EXCEPT . ** 302C ** THIS SHOULD BE THE SUBSET VARIABLE ** 303C ** OR THE DUMMY INDEX I . ** 304C ******************************************************** 305C 306 ISTEPN='4' 307 IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 308C 309 ICASVA='UNKN' 310 ILOCS1=ILOCS+1 311 JMAX=ILOCS1 312 IF(ILOCS1.GT.NUMARG)THEN 313 WRITE(ICOUT,999) 314 CALL DPWRST('XXX','BUG ') 315 WRITE(ICOUT,111) 316 CALL DPWRST('XXX','BUG ') 317 WRITE(ICOUT,412) 318 412 FORMAT(' THE WORD SUBSET OR EXCEPT WAS THE') 319 CALL DPWRST('XXX','BUG ') 320 WRITE(ICOUT,413) 321 413 FORMAT(' FINAL WORD ON THE COMMAND LINE.') 322 CALL DPWRST('XXX','BUG ') 323 WRITE(ICOUT,414) 324 414 FORMAT(' THE WORD SUBSET OR EXCEPT SHOULD HAVE') 325 CALL DPWRST('XXX','BUG ') 326 WRITE(ICOUT,415) 327 415 FORMAT(' BEEN FOLLOWED BY OTHER ARGUMENTS, AS IN') 328 CALL DPWRST('XXX','BUG ') 329 WRITE(ICOUT,416) 330 416 FORMAT(' SUBSET X = 4') 331 CALL DPWRST('XXX','BUG ') 332 WRITE(ICOUT,417) 333 417 FORMAT(' SUBSET X = 4 7 9 15 22') 334 CALL DPWRST('XXX','BUG ') 335 WRITE(ICOUT,418) 336 418 FORMAT(' SUBSET X = 4 TO 10') 337 CALL DPWRST('XXX','BUG ') 338 WRITE(ICOUT,419) 339 419 FORMAT(' SUBSET X >= 7') 340 CALL DPWRST('XXX','BUG ') 341 WRITE(ICOUT,420) 342 420 FORMAT(' AND SO FORTH.') 343 CALL DPWRST('XXX','BUG ') 344 WRITE(ICOUT,421) 345 421 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') 346 CALL DPWRST('XXX','BUG ') 347 IF(IWIDTH.GE.1)THEN 348 WRITE(ICOUT,422)(IANS(I),I=1,MIN(IWIDTH,100)) 349 422 FORMAT(' ',100A1) 350 CALL DPWRST('XXX','BUG ') 351 ENDIF 352 IERROR='YES' 353 GOTO9000 354 ENDIF 355C 356 IHSET=IHARG(ILOCS1) 357 IHSET2=IHARG2(ILOCS1) 358C 359 IF(IHSET.EQ.'I '.AND.IHSET2.EQ.' ')THEN 360 ICASVA='I ' 361 IF(NUMNAM.LE.0)GOTO490 362 DO435I=1,NUMNAM 363 IF(IHNAME(I).EQ.IHSET.AND.IHNAM2(I).EQ.IHSET2.AND. 364 1 IUSE(I).EQ.'V ')GOTO440 365 435 CONTINUE 366 GOTO490 367 ENDIF 368C 369 440 CONTINUE 370 ICASVA='V ' 371 IHWUSE='V' 372 MESSAG='YES' 373 CALL CHECKN(IHSET,IHSET2,IHWUSE, 374 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 375 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) 376 IF(IERROR.EQ.'YES')GOTO9000 377 ISETV=IVALUE(ILOC) 378C 379 IF(IBUGQ.EQ.'ON')THEN 380 WRITE(ICOUT,451)ILOCS1,IHSET,IHSET2,ISETV 381 451 FORMAT('ILOCS1,IHSET,IHSET2,ISETV = ',I8,3X,2A4,3X,I8) 382 CALL DPWRST('XXX','BUG ') 383 ENDIF 384C 385 GOTO490 386C 387 490 CONTINUE 388 IF(IBUGQ.EQ.'ON')THEN 389 WRITE(ICOUT,491)IPASS,IHSET,IHSET2,ICASVA,ISETV 390 491 FORMAT('IPASS,IHSET,IHSET2,ICASVA,ISETV = ',I8,3(2X,A4),I8) 391 CALL DPWRST('XXX','BUG ') 392 ENDIF 393C 394C ******************************************************* 395C ** STEP 5-- ** 396C ** CHECK TO SEE IF NEXT ARGUMENT IS ** 397C ** < ** 398C ** <= ** 399C ** = ** 400C ** >= ** 401C ** > ** 402C ** <> >< NOT= ** 403C ** IF NONE OF THE ABOVE, THEN ASSUME = . ** 404C ******************************************************* 405C 406 ISTEPN='5' 407 IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 408C 409 ICASOP='UNKN' 410 ILOCS2=ILOCS+2 411 JMAX=ILOCS2 412 IF(ILOCS2.GT.NUMARG)THEN 413 WRITE(ICOUT,999) 414 CALL DPWRST('XXX','BUG ') 415 WRITE(ICOUT,111) 416 CALL DPWRST('XXX','BUG ') 417 WRITE(ICOUT,502) 418 502 FORMAT(' THE SUBSET/EXCEPT VARIABLE NAME WAS THE') 419 CALL DPWRST('XXX','BUG ') 420 WRITE(ICOUT,503) 421 503 FORMAT(' FINAL WORD ON THE COMMAND LINE.') 422 CALL DPWRST('XXX','BUG ') 423 WRITE(ICOUT,504) 424 504 FORMAT(' THE SUBSET/EXCEPT VARIABLE NAME SHOULD HAVE') 425 CALL DPWRST('XXX','BUG ') 426 WRITE(ICOUT,505) 427 505 FORMAT(' BEEN FOLLOWED BY OTHER ARGUMENTS, AS IN') 428 CALL DPWRST('XXX','BUG ') 429 WRITE(ICOUT,506) 430 506 FORMAT(' SUBSET X = 4') 431 CALL DPWRST('XXX','BUG ') 432 WRITE(ICOUT,507) 433 507 FORMAT(' SUBSET X = 4 7 9 15 22') 434 CALL DPWRST('XXX','BUG ') 435 WRITE(ICOUT,508) 436 508 FORMAT(' SUBSET X = 4 TO 10') 437 CALL DPWRST('XXX','BUG ') 438 WRITE(ICOUT,509) 439 509 FORMAT(' SUBSET X >= 7') 440 CALL DPWRST('XXX','BUG ') 441 WRITE(ICOUT,510) 442 510 FORMAT(' AND SO FORTH.') 443 CALL DPWRST('XXX','BUG ') 444 WRITE(ICOUT,521) 445 521 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') 446 CALL DPWRST('XXX','BUG ') 447 IF(IWIDTH.GE.1)THEN 448 WRITE(ICOUT,422)(IANS(I),I=1,MIN(IWIDTH,100)) 449 CALL DPWRST('XXX','BUG ') 450 ENDIF 451 IERROR='YES' 452 GOTO9000 453 ENDIF 454C 455 IHSET=IHARG(ILOCS2) 456 IHSET2=IHARG2(ILOCS2) 457C 458 IF(IHSET.EQ.'< ')THEN 459 ICASOP='< ' 460 ILOCTG=ILOCS2 461 ELSEIF(IHSET.EQ.'<= ' .OR. IHSET.EQ.'=< ')THEN 462 ICASOP='<= ' 463 ILOCTG=ILOCS2 464 ELSEIF(IHSET.EQ.'= ')THEN 465 ICASOP='= ' 466 ILOCTG=ILOCS2 467 ELSEIF(IHSET.EQ.'>= ' .OR. IHSET.EQ.'=> ')THEN 468 ICASOP='>= ' 469 ILOCTG=ILOCS2 470 ELSEIF(IHSET.EQ.'> ')THEN 471 ICASOP='> ' 472 ILOCTG=ILOCS2 473 ELSEIF(IHSET.EQ.'<> ' .OR. IHSET.EQ.'>< ' .OR. 474 1 IHSET.EQ.'NOT=')THEN 475 ICASOP='= ' 476 ILOCTG=ILOCS2 477 ELSE 478 ICASOP='=ASS' 479 ILOCTG=ILOCS2-1 480 GOTO590 481 ENDIF 482C 483 590 CONTINUE 484C 485 IF(IBUGQ.EQ.'ON')THEN 486 WRITE(ICOUT,591)IPASS,IHSET,IHSET2,ICASVA,ICASOP 487 591 FORMAT('IPASS,IHSET,IHSET2,ICASVA,ICASOP = ', 488 1 I8,4(2X,A4)) 489 CALL DPWRST('XXX','BUG ') 490 ENDIF 491C 492C ******************************************************** 493C ** STEP 6-- ** 494C ** DETERMINE THE LOWER LIMIT OF THE INTERVAL OF ** 495C ** INTEREST. THIS IS DONE BY CHECKING THE FIRST ** 496C ** (NEXT) ARGUMENT IN THE LIST. ** 497C ** ALSO, FOR THOSE 4 CASES IN WHICH ** 498C ** ICASOP IS < <= >= > ** 499C ** DETERMINE THE UPPER LIMIT OF THE INTERVAL OF ** 500C ** INTEREST. ** 501C ******************************************************** 502C 503 600 CONTINUE 504C 505 ISTEPN='6' 506 IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 507C 508 IF(IBUGQ.EQ.'ON')THEN 509 WRITE(ICOUT,601) 510 601 FORMAT(' AT THE BEGINNING OF STEP 6 IN DPSUBS--') 511 CALL DPWRST('XXX','BUG ') 512 DO605I=1,NIOLD 513 WRITE(ICOUT,606)I,ISUB(I) 514 606 FORMAT('I,ISUB(I) = ',I8,I8) 515 CALL DPWRST('XXX','BUG ') 516 605 CONTINUE 517 ENDIF 518C 519 ILOCTG=ILOCTG+1 520 JMAX=ILOCTG 521 IF(ILOCTG.GT.NUMARG)THEN 522C 523 WRITE(ICOUT,999) 524 CALL DPWRST('XXX','BUG ') 525 WRITE(ICOUT,111) 526 CALL DPWRST('XXX','BUG ') 527 WRITE(ICOUT,612) 528 612 FORMAT(' THE SUBSET/EXCEPT OPERATION < <= = >= >') 529 CALL DPWRST('XXX','BUG ') 530 WRITE(ICOUT,613) 531 613 FORMAT(' WAS THE FINAL WORD ON THE COMMAND LINE.') 532 CALL DPWRST('XXX','BUG ') 533 WRITE(ICOUT,614) 534 614 FORMAT(' THE SUBSET/EXCEPT VARIABLE NAME SHOULD HAVE') 535 CALL DPWRST('XXX','BUG ') 536 WRITE(ICOUT,615) 537 615 FORMAT(' BEEN FOLLOWED BY OTHER ARGUMENTS, AS IN') 538 CALL DPWRST('XXX','BUG ') 539 WRITE(ICOUT,506) 540 CALL DPWRST('XXX','BUG ') 541 WRITE(ICOUT,507) 542 CALL DPWRST('XXX','BUG ') 543 WRITE(ICOUT,508) 544 CALL DPWRST('XXX','BUG ') 545 WRITE(ICOUT,509) 546 CALL DPWRST('XXX','BUG ') 547 WRITE(ICOUT,510) 548 CALL DPWRST('XXX','BUG ') 549 WRITE(ICOUT,521) 550 CALL DPWRST('XXX','BUG ') 551 IF(IWIDTH.GE.1)THEN 552 WRITE(ICOUT,422)(IANS(I),I=1,MIN(IWIDTH,100)) 553 CALL DPWRST('XXX','BUG ') 554 ENDIF 555 IERROR='YES' 556 GOTO9000 557 ENDIF 558C 559 IF(IARGT(ILOCTG).EQ.'NUMB')THEN 560 DMIN=ARG(ILOCTG) 561 DMAX=ARG(ILOCTG) 562 IF(ICASOP.EQ.'< ')THEN 563 DMIN=CPUMIN 564 DMAX=ARG(ILOCTG) 565 ELSEIF(ICASOP.EQ.'<= ')THEN 566 DMIN=CPUMIN 567 DMAX=ARG(ILOCTG) 568 ELSEIF(ICASOP.EQ.'>= ')THEN 569 DMIN=ARG(ILOCTG) 570 DMAX=CPUMAX 571 ELSEIF(ICASOP.EQ.'> ')THEN 572 DMIN=ARG(ILOCTG) 573 DMAX=CPUMAX 574 ENDIF 575 ELSEIF(IARGT(ILOCTG).EQ.'WORD')THEN 576 IH=IHARG(ILOCTG) 577 IH2=IHARG2(ILOCTG) 578 IHWUSE='P' 579 MESSAG='YES' 580 CALL CHECKN(IH,IH2,IHWUSE, 581 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 582 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) 583 IF(IERROR.EQ.'YES')GOTO9000 584 DMIN=VALUE(ILOC) 585 DMAX=VALUE(ILOC) 586 IF(ICASOP.EQ.'< ')THEN 587 DMIN=CPUMIN 588 DMAX=VALUE(ILOC) 589 ELSEIF(ICASOP.EQ.'<= ')THEN 590 DMIN=CPUMIN 591 DMAX=VALUE(ILOC) 592 ELSEIF(ICASOP.EQ.'>= ')THEN 593 DMIN=VALUE(ILOC) 594 DMAX=CPUMAX 595 ELSEIF(ICASOP.EQ.'> ')THEN 596 DMIN=VALUE(ILOC) 597 DMAX=CPUMAX 598 ENDIF 599 ELSE 600 WRITE(ICOUT,999) 601 CALL DPWRST('XXX','BUG ') 602 WRITE(ICOUT,111) 603 CALL DPWRST('XXX','BUG ') 604 WRITE(ICOUT,632) 605 632 FORMAT(' AN ARGUMENT TYPE WHICH SHOULD BE ') 606 CALL DPWRST('XXX','BUG ') 607 WRITE(ICOUT,633) 608 633 FORMAT(' EITHER A NUMBER OR A WORD, IS NEITHER.') 609 CALL DPWRST('XXX','BUG ') 610 WRITE(ICOUT,634)IHARG(ILOCTG),IHARG2(ILOCTG) 611 634 FORMAT(' ARGUMENT = ',2A4) 612 CALL DPWRST('XXX','BUG ') 613 WRITE(ICOUT,635)ILOCTG 614 635 FORMAT(' LOCATION IN ARGUMENT LIST = ',I8) 615 CALL DPWRST('XXX','BUG ') 616 WRITE(ICOUT,636)IARGT(ILOCTG) 617 636 FORMAT(' ARGUMENT TYPE = ',A4) 618 CALL DPWRST('XXX','BUG ') 619 WRITE(ICOUT,521) 620 CALL DPWRST('XXX','BUG ') 621 IF(IWIDTH.GE.1)THEN 622 WRITE(ICOUT,422)(IANS(I),I=1,MIN(IWIDTH,100)) 623 CALL DPWRST('XXX','BUG ') 624 ENDIF 625 IERROR='YES' 626 GOTO9000 627 ENDIF 628C 629 IF(IBUGQ.EQ.'ON')THEN 630 WRITE(ICOUT,691)IPASS,ICASVA,ICASOP,IH,IH2,DMIN,DMAX 631 691 FORMAT('IPASS,ICASVA,ICASOP,IH,IH2,DMIN,DMAX = ', 632 1 I8,4(2X,A4),2G15.7) 633 CALL DPWRST('XXX','BUG ') 634 ENDIF 635C 636C ******************************************************** 637C ** STEP 7-- ** 638C ** DETERMINE THE UPPER LIMIT OF THE INTERVAL OF ** 639C ** INTEREST. NOTE THAT FOR THOSE 4 CASES IN WHICH ** 640C ** ICASOP IS < <= >= > ** 641C ** THE UPPER LIMIT OF THE INTERVAL ** 642C ** HAS ALREADY BEEN DETERMINED AND SO ** 643C ** ALL OF THE CODE OF THIS SECTION MAY BE SKIPPED. ** 644C ** ON THE OTHER HAND WHEN THE OPERATION IS = , ** 645C ** (EXPLICITLY OR ASSUMED), ** 646C ** THE UPPER LIMIT MUST BE DETERMINED. ** 647C ** THIS IS DONE BY CHECKING THE NEXT ARGUMENT ** 648C ** IN THE LIST. ** 649C ** IF THIS NEXT ARGUMENT IS TO , THIS ** 650C ** IMPLIES THAT AN UPPER LIMIT WILL BE PROVIDED ** 651C ** (IN THE ARGUMENT AFTER THE TO ). ** 652C ** HOWEVER, IF THE NEXT ARGUMENT IS NOT A TO , ** 653C ** THEN THIS IMPLIES THAT THE LIST CONSISTS ** 654C ** OF INDIVIDUAL ELEMENTS OF THE SUBSET ** 655C ** AND SO THE UPPER LIMIT WILL BE IDENTICAL ** 656C ** TO THE LOWER LIMIT. ** 657C ******************************************************** 658C 659 ISTEPN='7' 660 IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 661C 662 IF(ICASOP.EQ.'< ' .OR. ICASOP.EQ.'<= ' .OR. 663 1 ICASOP.EQ.'>= ' .OR. ICASOP.EQ.'> ')THEN 664 ICASSC='SEAR' 665 GOTO790 666 ENDIF 667C 668 ILOCTG=ILOCTG+1 669C 670 IF(ILOCTG.GT.NUMARG)GOTO710 671 IF(ILOCTG.EQ.NUMARG.AND.IHARG(ILOCTG).EQ.'AND '.AND. 672 1IHARG2(ILOCTG).EQ.' ')GOTO710 673 IF(ILOCTG.LE.NUMARG.AND.IHARG(ILOCTG).EQ.'SUBS'.AND. 674 1IHARG2(ILOCTG).EQ.'ET ')GOTO720 675 IF(ILOCTG.LE.NUMARG.AND.IHARG(ILOCTG).EQ.'EXCE'.AND. 676 1IHARG2(ILOCTG).EQ.'PT ')GOTO720 677 IF(ILOCTG.LE.NUMARG.AND.IHARG(ILOCTG).EQ.'TO '.AND. 678 1IHARG2(ILOCTG).EQ.' ')GOTO750 679 GOTO730 680C 681 710 CONTINUE 682 ILOCTG=ILOCTG-1 683 JMAX=ILOCTG 684 ICASSC='STOP' 685 DMAX=DMIN 686 GOTO790 687C 688 720 CONTINUE 689 ILOCTG=ILOCTG-1 690 JMAX=ILOCTG 691 ICASSC='SEAR' 692 DMAX=DMIN 693 GOTO790 694C 695 730 CONTINUE 696 ILOCTG=ILOCTG-1 697 JMAX=ILOCTG 698 ICASSC='CONT' 699 DMAX=DMIN 700 GOTO790 701C 702 750 CONTINUE 703 ILOCTG=ILOCTG+1 704 JMAX=ILOCTG 705 IF(ILOCTG.GT.NUMARG)GOTO760 706 IF(ILOCTG.EQ.NUMARG.AND.IHARG(ILOCTG).EQ.'AND '.AND. 707 1IHARG2(ILOCTG).EQ.' ')GOTO760 708 IF(ILOCTG.LE.NUMARG.AND.IHARG(ILOCTG).EQ.'SUBS'.AND. 709 1IHARG2(ILOCTG).EQ.'ET ')GOTO760 710 IF(ILOCTG.LE.NUMARG.AND.IHARG(ILOCTG).EQ.'EXCE'.AND. 711 1IHARG2(ILOCTG).EQ.'PT ')GOTO760 712 IF(ILOCTG.LE.NUMARG.AND.IHARG(ILOCTG).EQ.'TO '.AND. 713 1IHARG2(ILOCTG).EQ.' ')GOTO760 714 GOTO770 715C 716 760 CONTINUE 717 WRITE(ICOUT,999) 718 CALL DPWRST('XXX','BUG ') 719 WRITE(ICOUT,111) 720 CALL DPWRST('XXX','BUG ') 721 WRITE(ICOUT,762) 722 762 FORMAT(' THE WORD TO SHOULD HAVE') 723 CALL DPWRST('XXX','BUG ') 724 WRITE(ICOUT,763) 725 763 FORMAT(' BEEN FOLLOWED BY A NUMBER OR') 726 CALL DPWRST('XXX','BUG ') 727 WRITE(ICOUT,764) 728 764 FORMAT(' BY A PARAMETER NAME, BUT WAS NOT.') 729 CALL DPWRST('XXX','BUG ') 730 WRITE(ICOUT,765)IHARG(ILOCTG),IHARG2(ILOCTG) 731 765 FORMAT(' TO WAS FOLLOWED BY THE WORD ',A4,A4) 732 CALL DPWRST('XXX','BUG ') 733 WRITE(ICOUT,521) 734 CALL DPWRST('XXX','BUG ') 735 IF(IWIDTH.GE.1)THEN 736 WRITE(ICOUT,422)(IANS(I),I=1,MIN(IWIDTH,100)) 737 CALL DPWRST('XXX','BUG ') 738 ENDIF 739 IERROR='YES' 740 GOTO9000 741C 742 770 CONTINUE 743 IF(IARGT(ILOCTG).EQ.'NUMB')THEN 744 DMAX=ARG(ILOCTG) 745 ELSEIF(IARGT(ILOCTG).EQ.'WORD')THEN 746 IH=IHARG(ILOCTG) 747 IH2=IHARG2(ILOCTG) 748 IHWUSE='P' 749 MESSAG='YES' 750 CALL CHECKN(IH,IH2,IHWUSE, 751 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 752 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) 753 IF(IERROR.EQ.'YES')GOTO9000 754 DMAX=VALUE(ILOC) 755 ELSE 756 IBRAN=770 757 WRITE(ICOUT,771)IBRAN 758 771 FORMAT('***** INTERNAL ERROR IN DPSUBS--', 759 1 'IMPOSSIBLE BRANCH CONDITION AT BRANCH POINT = ',I8) 760 CALL DPWRST('XXX','BUG ') 761 WRITE(ICOUT,772)ILOCTG,IARGT(ILOCTG) 762 772 FORMAT('ILOCTG, IARGT(ILOCTG) = ',I8,2X,A4) 763 CALL DPWRST('XXX','BUG ') 764 IERROR='YES' 765 GOTO9000 766 ENDIF 767C 768 ILOCTG=ILOCTG+1 769 ICASSC='CONT' 770 IF(ILOCTG.GT.NUMARG)ICASSC='STOP' 771 IF(ILOCTG.EQ.NUMARG.AND.IHARG(ILOCTG).EQ.'AND '.AND. 772 1IHARG2(ILOCTG).EQ.' ')ICASSC='STOP' 773 IF(ILOCTG.LE.NUMARG.AND.IHARG(ILOCTG).EQ.'SUBS'.AND. 774 1IHARG2(ILOCTG).EQ.'ET ')ICASSC='SEAR' 775 IF(ILOCTG.LE.NUMARG.AND.IHARG(ILOCTG).EQ.'EXCE'.AND. 776 1IHARG2(ILOCTG).EQ.'PT ')ICASSC='SEAR' 777 ILOCTG=ILOCTG-1 778 JMAX=ILOCTG 779C 780 790 CONTINUE 781C 782 IF(IBUGQ.EQ.'ON')THEN 783 WRITE(ICOUT,791)IPASS,ICASVA,ICASOP,IH,IH2,DMIN,DMAX 784 791 FORMAT('IPASS,ICASVA,ICASOP,IH,IH2,DMIN,DMAX = ', 785 1 I8,4(2X,A4),2G15.7) 786 CALL DPWRST('XXX','BUG ') 787 ENDIF 788C 789C *************************************************** 790C ** STEP 8-- ** 791C ** TO ALLOW FOR ROUNDOFF ERRORS IN THE ** 792C ** STORAGE OF NUMBERS, ** 793C ** JUDICIOUSLY EXPAND THE INTERVAL OF INTEREST ** 794C ** BY AN EPSILON AMOUNT. ** 795C *************************************************** 796C 797 ISTEPN='8' 798C 799 IF(IBUGQ.EQ.'ON')THEN 800 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 801 WRITE(ICOUT,801) 802 801 FORMAT(' AT THE BEGINNING OF STEP 8--') 803 CALL DPWRST('XXX','BUG ') 804 WRITE(ICOUT,802)DMIN,DMAX 805 802 FORMAT('DMIN,DMAX = ',2E15.7) 806 CALL DPWRST('XXX','BUG ') 807 ENDIF 808C 809 IF(DMIN.LE.DMAX)GOTO809 810 HOLD=DMIN 811 DMIN=DMAX 812 DMAX=HOLD 813 809 CONTINUE 814C 815 IF(DMIN.EQ.CPUMIN)GOTO819 816 IF(DMIN.EQ.CPUMAX)GOTO819 817 IF(ABS(DMIN).EQ.0.0)EPS=0.000001 818 IF(ABS(DMIN).NE.0.0)EPS=ABS(DMIN*0.000001) 819 IF(ICASOP.EQ.'= ')DMIN=DMIN-EPS 820 IF(ICASOP.EQ.'=ASS')DMIN=DMIN-EPS 821 IF(ICASOP.EQ.'< ')DMIN=DMIN-EPS 822 IF(ICASOP.EQ.'<= ')DMIN=DMIN-EPS 823 IF(ICASOP.EQ.'>= ')DMIN=DMIN-EPS 824 IF(ICASOP.EQ.'> ')DMIN=DMIN+EPS 825 819 CONTINUE 826C 827 IF(DMAX.EQ.CPUMAX)GOTO829 828 IF(DMAX.EQ.CPUMIN)GOTO829 829 IF(ABS(DMAX).EQ.0.0)EPS=0.000001 830 IF(ABS(DMAX).NE.0.0)EPS=ABS(DMAX*0.000001) 831 IF(ICASOP.EQ.'= ')DMAX=DMAX+EPS 832 IF(ICASOP.EQ.'=ASS')DMAX=DMAX+EPS 833 IF(ICASOP.EQ.'< ')DMAX=DMAX-EPS 834 IF(ICASOP.EQ.'<= ')DMAX=DMAX+EPS 835 IF(ICASOP.EQ.'>= ')DMAX=DMAX+EPS 836 IF(ICASOP.EQ.'> ')DMAX=DMAX+EPS 837 829 CONTINUE 838C 839 IF(IBUGQ.EQ.'ON')THEN 840 WRITE(ICOUT,891)IPASS,ICASVA,ICASOP,IH,IH2 841 891 FORMAT('IPASS,ICASVA,ICASOP,IH,IH2 = ',I8,4(2X,A4)) 842 CALL DPWRST('XXX','BUG ') 843 WRITE(ICOUT,892)EPS,DMIN,DMAX,CPUMIN,CPUMAX 844 892 FORMAT('EPS,DMIN,DMAX,CPUMIN,CPUMAX = ',5E15.7) 845 CALL DPWRST('XXX','BUG ') 846 ENDIF 847C 848C **************************************************** 849C ** STEP 9-- ** 850C ** DEFINE THE ISUB(.) VECTOR-- ** 851C ** FOR ANY K (K = 1 TO NIOLD), ** 852C ** IF THE K-TH ELEMENT OF THE ** 853C ** SUBSET SPECIFICATION VARIABLE ** 854C ** (THE VARIABLE SPECIFIED AFTER SUBSET ** 855C ** IN THE COMMAND LINE) ** 856C ** IS WITHIN THE SPECIFIED (DMIN,DMAX) LIMITS, ** 857C ** THEN ISUB(K) SHOULD RESULT IN A VALUE OF 1; ** 858C ** BUT IF THE K-TH ELEMENT OF THE ** 859C ** SUBSET SPECIFICATION VARIABLE ** 860C ** IS OUTSIDE THE SPECIFIED (DMIN,DMAX) LIMITS, ** 861C ** THEN ISUB(K) SHOULD RESULT IN A 0 . ** 862C **************************************************** 863C 864 ISTEPN='9' 865 IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 866C 867 IF(IBUGQ.EQ.'ON')WRITE(ICOUT,901)ILOCS1,IHSET,IHSET2,ICASVA,ISETV, 868 1MAXCOL 869 901 FORMAT('ILOCS1,IHSET,IHSET2,ICASVA,ISETV,MAXCOL = ', 870 1I8,2X,A4,2X,A4,2X,A4,I8,I8) 871 IF(IBUGQ.EQ.'ON')CALL DPWRST('XXX','BUG ') 872C 873 IF(ICASVA.EQ.'UNKN')GOTO910 874 IF(ICASVA.EQ.'I ')GOTO930 875 IF(ISETV.LE.MAXCOL)GOTO940 876 IF(ISETV.EQ.MAXCP1)GOTO950 877CCCCC IF(ISETV.EQ.MAXCP2)GOTO960 878 IF(ISETV.EQ.MAXCP2)GOTO950 879 IF(ISETV.EQ.MAXCP3)GOTO950 880 IF(ISETV.EQ.MAXCP4)GOTO950 881 IF(ISETV.EQ.MAXCP5)GOTO950 882 IF(ISETV.EQ.MAXCP6)GOTO950 883C 884 910 CONTINUE 885 WRITE(ICOUT,999) 886 CALL DPWRST('XXX','BUG ') 887 WRITE(ICOUT,911) 888 911 FORMAT('***** INTERNAL ERROR IN DPSUBS--') 889 CALL DPWRST('XXX','BUG ') 890 WRITE(ICOUT,912) 891 912 FORMAT(' IMPROPER VALUE FOR ICASVA AND/OR ISETV') 892 CALL DPWRST('XXX','BUG ') 893 WRITE(ICOUT,913)ICASVA,ISETV,MAXCOL,MAXCP1,MAXCP2 894 913 FORMAT(' ICASVA,ISETV,MAXCOL,MAXCP1,MAXCP2 = ',A4,4I8) 895 CALL DPWRST('XXX','BUG ') 896 IERROR='YES' 897 GOTO9000 898C 899 930 CONTINUE 900 NS=0 901 ND=0 902 DO931I=1,NIOLD 903 TARGET=I 904 IF(ICASQU.EQ.'SUBS'.AND.DMIN.LE.TARGET.AND.TARGET.LE.DMAX) 905 1GOTO932 906 IF(ICASQU.EQ.'SUBS')GOTO933 907 IF(ICASQU.EQ.'EXCE'.AND.DMIN.LE.TARGET.AND.TARGET.LE.DMAX) 908 1GOTO934 909 IF(ICASQU.EQ.'EXCE')GOTO935 910 GOTO931 911 932 CONTINUE 912 ITEMP=ISUB(I) 913 IF(ITEMP.EQ.00)ISUB(I)=10 914 IF(ITEMP.EQ.10)ISUB(I)=10 915 IF(ITEMP.EQ.01)ISUB(I)=11 916 IF(ITEMP.EQ.11)ISUB(I)=11 917 NS=NS+1 918 GOTO931 919 933 CONTINUE 920 ND=ND+1 921 GOTO931 922 934 CONTINUE 923 ITEMP=ISUB(I) 924 IF(ITEMP.EQ.00)ISUB(I)=00 925 IF(ITEMP.EQ.10)ISUB(I)=00 926 IF(ITEMP.EQ.01)ISUB(I)=01 927 IF(ITEMP.EQ.11)ISUB(I)=01 928 ND=ND+1 929 GOTO931 930 935 CONTINUE 931 NS=NS+1 932 GOTO931 933 931 CONTINUE 934 GOTO990 935C 936 940 CONTINUE 937 NS=0 938 ND=0 939 DO941I=1,NIOLD 940 IJ=MAXN*(ISETV-1)+I 941 VIJ=V(IJ) 942 IF(IBUGQ.EQ.'ON')WRITE(9,947)I,NIOLD,ISETV,DMIN,DMAX,VIJ 943 947 FORMAT('I,NIOLD,ISETV,DMIN,DMAX,VIJ = ', 944 13I8,3E12.4) 945 TARGET=VIJ 946 IF(ICASQU.EQ.'SUBS'.AND.DMIN.LE.TARGET.AND.TARGET.LE.DMAX) 947 1GOTO942 948 IF(ICASQU.EQ.'SUBS')GOTO943 949 IF(ICASQU.EQ.'EXCE'.AND.DMIN.LE.TARGET.AND.TARGET.LE.DMAX) 950 1GOTO944 951 IF(ICASQU.EQ.'EXCE')GOTO945 952 GOTO941 953 942 CONTINUE 954 ITEMP=ISUB(I) 955 IF(ITEMP.EQ.00)ISUB(I)=10 956 IF(ITEMP.EQ.10)ISUB(I)=10 957 IF(ITEMP.EQ.01)ISUB(I)=11 958 IF(ITEMP.EQ.11)ISUB(I)=11 959 NS=NS+1 960 GOTO941 961 943 CONTINUE 962 ND=ND+1 963 GOTO941 964 944 CONTINUE 965 ITEMP=ISUB(I) 966 IF(ITEMP.EQ.00)ISUB(I)=00 967 IF(ITEMP.EQ.10)ISUB(I)=00 968 IF(ITEMP.EQ.01)ISUB(I)=01 969 IF(ITEMP.EQ.11)ISUB(I)=01 970 ND=ND+1 971 GOTO941 972 945 CONTINUE 973 NS=NS+1 974 GOTO941 975 941 CONTINUE 976 GOTO990 977C 978 950 CONTINUE 979 NS=0 980 ND=0 981 DO951I=1,NIOLD 982CCCCC TARGET=PRED(I) 983 IF(ISETV.EQ.MAXCP1)TARGET=PRED(I) 984 IF(ISETV.EQ.MAXCP2)TARGET=RES(I) 985 IF(ISETV.EQ.MAXCP3)TARGET=YPLOT(I) 986 IF(ISETV.EQ.MAXCP4)TARGET=XPLOT(I) 987 IF(ISETV.EQ.MAXCP5)TARGET=X2PLOT(I) 988 IF(ISETV.EQ.MAXCP6)TARGET=TAGPLO(I) 989 IF(ICASQU.EQ.'SUBS'.AND.DMIN.LE.TARGET.AND.TARGET.LE.DMAX) 990 1GOTO952 991 IF(ICASQU.EQ.'SUBS')GOTO953 992 IF(ICASQU.EQ.'EXCE'.AND.DMIN.LE.TARGET.AND.TARGET.LE.DMAX) 993 1GOTO954 994 IF(ICASQU.EQ.'EXCE')GOTO955 995 GOTO951 996 952 CONTINUE 997 ITEMP=ISUB(I) 998 IF(ITEMP.EQ.00)ISUB(I)=10 999 IF(ITEMP.EQ.10)ISUB(I)=10 1000 IF(ITEMP.EQ.01)ISUB(I)=11 1001 IF(ITEMP.EQ.11)ISUB(I)=11 1002 NS=NS+1 1003 GOTO951 1004 953 CONTINUE 1005 ND=ND+1 1006 GOTO951 1007 954 CONTINUE 1008 ITEMP=ISUB(I) 1009 IF(ITEMP.EQ.00)ISUB(I)=00 1010 IF(ITEMP.EQ.10)ISUB(I)=00 1011 IF(ITEMP.EQ.01)ISUB(I)=01 1012 IF(ITEMP.EQ.11)ISUB(I)=01 1013 ND=ND+1 1014 GOTO951 1015 955 CONTINUE 1016 NS=NS+1 1017 GOTO951 1018 951 CONTINUE 1019 GOTO990 1020C 1021CC960 CONTINUE 1022CCCCC NS=0 1023CCCCC ND=0 1024CCCCC DO961I=1,NIOLD 1025CCCCC TARGET=RES(I) 1026CCCCC IF(ICASQU.EQ.'SUBS'.AND.DMIN.LE.TARGET.AND.TARGET.LE.DMAX) 1027CCCCC1GOTO962 1028CCCCC IF(ICASQU.EQ.'SUBS')GOTO963 1029CCCCC IF(ICASQU.EQ.'EXCE'.AND.DMIN.LE.TARGET.AND.TARGET.LE.DMAX) 1030CCCCC1GOTO964 1031CCCCC IF(ICASQU.EQ.'EXCE')GOTO965 1032CCCCC GOTO961 1033CC962 CONTINUE 1034CCCCC ITEMP=ISUB(I) 1035CCCCC IF(ITEMP.EQ.00)ISUB(I)=10 1036CCCCC IF(ITEMP.EQ.10)ISUB(I)=10 1037CCCCC IF(ITEMP.EQ.01)ISUB(I)=11 1038CCCCC IF(ITEMP.EQ.11)ISUB(I)=11 1039CCCCC NS=NS+1 1040CCCCC GOTO961 1041CC963 CONTINUE 1042CCCCC ND=ND+1 1043CCCCC GOTO961 1044CC964 CONTINUE 1045CCCCC ITEMP=ISUB(I) 1046CCCCC IF(ITEMP.EQ.00)ISUB(I)=00 1047CCCCC IF(ITEMP.EQ.10)ISUB(I)=00 1048CCCCC IF(ITEMP.EQ.01)ISUB(I)=01 1049CCCCC IF(ITEMP.EQ.11)ISUB(I)=01 1050CCCCC ND=ND+1 1051CCCCC GOTO961 1052CC965 CONTINUE 1053CCCCC NS=NS+1 1054CCCCC GOTO961 1055CC961 CONTINUE 1056CCCCC GOTO990 1057C 1058 990 CONTINUE 1059 IF(IBUGQ.EQ.'ON')WRITE(ICOUT,991)IPASS,ICASQU,DMIN,DMAX,EPS, 1060 1NIOLD,NS,ND 1061 991 FORMAT('IPASS,ICASQU,DMIN,DMAX,EPS,NIOLD,NS,ND = ', 1062 1I8,2X,A4,3E15.7,3I8) 1063 IF(IBUGQ.EQ.'ON')CALL DPWRST('XXX','BUG ') 1064 IF(IBUGQ.EQ.'OFF')GOTO994 1065 DO992I=1,NIOLD 1066 WRITE(ICOUT,993)I,ISUB(I) 1067 993 FORMAT('I,ISUB(I) = ',I8,I8) 1068 CALL DPWRST('XXX','BUG ') 1069 992 CONTINUE 1070 994 CONTINUE 1071C 1072C ************************************************* 1073C ** STEP 10-- ** 1074C ** WRITE OUT A MESSAGE FOR THIS STEP ** 1075C ** INDICATING ** 1076C ** THE SUBSET VARIABLE NAME, ** 1077C ** THE SUBSET MINIMUM, ** 1078C ** THE SUBSET MAXIMUM, ** 1079C ** THE INPUT NUMBER OF OBSERVATIONS (LOCAL), ** 1080C ** THE NUMBER OF OBSERVATIONS IGNORED ** 1081C ** AND THE OUTPUT NUMBER OF OBSERVATIONS ** 1082C ** (THAT IS, THE SUBSET SAMPLE SIZE). ** 1083C ** ALSO, CHECK THAT NS IS POSITIVE. ** 1084C ************************************************* 1085C 1086 ISTEPN='10' 1087 IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1088C 1089 IF(ICASQU.EQ.'EXCE')GOTO1020 1090 GOTO1010 1091C 1092 1010 CONTINUE 1093 IF(IFEEDB.EQ.'OFF')GOTO1019 1094 WRITE(ICOUT,999) 1095 CALL DPWRST('XXX','BUG ') 1096 WRITE(ICOUT,1011) 1097 1011 FORMAT('***** NOTE--') 1098 CALL DPWRST('XXX','BUG ') 1099 WRITE(ICOUT,1012)IHARG(ILOCS1),IHARG2(ILOCS1) 1100 1012 FORMAT(' SUBSET VARIABLE = ',2A4) 1101 CALL DPWRST('XXX','BUG ') 1102 WRITE(ICOUT,1013)DMIN 1103 1013 FORMAT(' SUBSET MINIMUM = ',E17.10) 1104 CALL DPWRST('XXX','BUG ') 1105 WRITE(ICOUT,1014)DMAX 1106 1014 FORMAT(' SUBSET MAXIMUM = ',E17.10) 1107 CALL DPWRST('XXX','BUG ') 1108 WRITE(ICOUT,1015)NIOLD 1109 1015 FORMAT(' INPUT NUMBER OF OBSERVATIONS = ',I8) 1110 CALL DPWRST('XXX','BUG ') 1111 WRITE(ICOUT,1016)ND 1112 1016 FORMAT(' NUMBER OF OBSERVATIONS IGNORED = ',I8) 1113 CALL DPWRST('XXX','BUG ') 1114 WRITE(ICOUT,1017)NS 1115 1017 FORMAT(' OUTPUT NUMBER OF OBSERVATIONS = ',I8) 1116 CALL DPWRST('XXX','BUG ') 1117 1019 CONTINUE 1118 GOTO1050 1119C 1120 1020 CONTINUE 1121 IF(IFEEDB.EQ.'OFF')GOTO1029 1122 WRITE(ICOUT,999) 1123 CALL DPWRST('XXX','BUG ') 1124 WRITE(ICOUT,1021) 1125 1021 FORMAT('***** NOTE--') 1126 CALL DPWRST('XXX','BUG ') 1127 WRITE(ICOUT,1022)IHARG(ILOCS1),IHARG2(ILOCS1) 1128 1022 FORMAT(' EXCEPTED SUBSET VARIABLE = ',2A4) 1129 CALL DPWRST('XXX','BUG ') 1130 WRITE(ICOUT,1023)DMIN 1131 1023 FORMAT(' EXCEPTED SUBSET MINIMUM = ',E17.10) 1132 CALL DPWRST('XXX','BUG ') 1133 WRITE(ICOUT,1024)DMAX 1134 1024 FORMAT(' EXCEPTED SUBSET MAXIMUM = ',E17.10) 1135 CALL DPWRST('XXX','BUG ') 1136 WRITE(ICOUT,1025)NIOLD 1137 1025 FORMAT(' INPUT NUMBER OF OBSERVATIONS = ',I8) 1138 CALL DPWRST('XXX','BUG ') 1139 WRITE(ICOUT,1026)ND 1140 1026 FORMAT(' NUMBER OF OBSERVATIONS IGNORED = ',I8) 1141 CALL DPWRST('XXX','BUG ') 1142 WRITE(ICOUT,1027)NS 1143 1027 FORMAT(' OUTPUT NUMBER OF OBSERVATIONS = ',I8) 1144 CALL DPWRST('XXX','BUG ') 1145 1029 CONTINUE 1146 GOTO1050 1147C 1148 1050 CONTINUE 1149CCCCC IF(NS.GE.1)GOTO1059 1150CCCCC WRITE(ICOUT,999) 1151CCCCC CALL DPWRST('XXX','BUG ') 1152CCCCC WRITE(ICOUT,1051) 1153C1051 FORMAT('***** ERROR IN DPSUBS--') 1154CCCCC CALL DPWRST('XXX','BUG ') 1155CCCCC WRITE(ICOUT,1052) 1156C1052 FORMAT(' THE SUBSET IS EMPTY--IT HAS NO ELEMENTS IN IT.') 1157CCCCC CALL DPWRST('XXX','BUG ') 1158CCCCC IERROR='YES' 1159CCCCC GOTO9000 1160C1059 CONTINUE 1161C 1162 NUMSV=IPASS 1163C 1164 300 CONTINUE 1165C 1166 1100 CONTINUE 1167 DO1110I=1,NIOLD 1168 ITEMP=ISUB(I) 1169 IF(ITEMP.EQ.00)ISUB(I)=00 1170 IF(ITEMP.EQ.10)ISUB(I)=00 1171 IF(ITEMP.EQ.01)ISUB(I)=00 1172 IF(ITEMP.EQ.11)ISUB(I)=11 1173 1110 CONTINUE 1174C 1175C ************************************* 1176C ** STEP 11-- ** 1177C ** PUT ISUB(.) IN FINAL 0,1 FORM ** 1178C ************************************* 1179C 1180 ISTEPN='11' 1181 IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1182C 1183 DO1210I=1,NIOLD 1184 ITEMP=ISUB(I) 1185 IF(ITEMP.EQ.00)ISUB(I)=0 1186 IF(ITEMP.EQ.10)ISUB(I)=0 1187 IF(ITEMP.EQ.01)ISUB(I)=1 1188 IF(ITEMP.EQ.11)ISUB(I)=1 1189 1210 CONTINUE 1190C 1191C ***************************************** 1192C ** STEP 12-- ** 1193C ** IF THERE WERE 2 OR MORE SUBSET ** 1194C ** VARIABLES, GATHER INFORMATION ** 1195C ** FOR A FINAL SUMMARY MESSAGE BY ** 1196C ** DETERMINING THE FINAL NUMBER OF ** 1197C ** ELEMENTS IN THE SUBSET ** 1198C ** (AFTER ALL VARIABLES HAVE ** 1199C ** BEEN INDIVIDUALLY ACCOUNTED FOR). ** 1200C ***************************************** 1201C 1202 ISTEPN='12' 1203 IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1204C 1205 IF(NUMSV.GT.1)THEN 1206 NS=0 1207 DO1510I=1,NIOLD 1208 IF(ISUB(I).EQ.1)NS=NS+1 1209 1510 CONTINUE 1210 ENDIF 1211C 1212C ************************************************* 1213C ** STEP 13-- ** 1214C ** IF THERE WERE 2 OR MORE SUBSET VARIABLES, ** 1215C ** WRITE OUT A FINAL MESSAGE ** 1216C ** SUMMARIZING FOR ALL VARIABLES ** 1217C ** THE NUMBER OF SUBSET VARIABLES ** 1218C ** THE INPUT NUMBER OF OBSERVATIONS (LOCAL), ** 1219C ** THE NUMBER OF OBSERVATIONS IGNORED ** 1220C ** AND THE OUTPUT NUMBER OF OBSERVATIONS ** 1221C ** (THAT IS, THE SUBSET SAMPLE SIZE). ** 1222C ** ALSO, CHECK THAT NS IS POSITIVE. ** 1223C ************************************************* 1224C 1225 ISTEPN='13' 1226 IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1227C 1228 IF(NUMSV.LE.1)GOTO1690 1229 ND=NIOLD-NS 1230C 1231 IF(IFEEDB.EQ.'ON')THEN 1232 WRITE(ICOUT,999) 1233 CALL DPWRST('XXX','BUG ') 1234 WRITE(ICOUT,1601) 1235 1601 FORMAT('***** SUBSET/EXCEPT SUMMARY--') 1236 CALL DPWRST('XXX','BUG ') 1237 WRITE(ICOUT,1602)NUMSV 1238 1602 FORMAT(' NUMBER OF SPECIFICATIONS = ',I8) 1239 CALL DPWRST('XXX','BUG ') 1240 WRITE(ICOUT,1605)NIOLD 1241 1605 FORMAT(' INPUT NUMBER OF OBSERVATIONS = ',I8) 1242 CALL DPWRST('XXX','BUG ') 1243 WRITE(ICOUT,1606)ND 1244 1606 FORMAT(' NUMBER OF OBSERVATIONS IGNORED = ',I8) 1245 CALL DPWRST('XXX','BUG ') 1246 WRITE(ICOUT,1607)NS 1247 1607 FORMAT(' OUTPUT NUMBER OF OBSERVATIONS = ',I8) 1248 CALL DPWRST('XXX','BUG ') 1249 ENDIF 1250C 1251 IF(NS.GE.1)GOTO1690 1252C 1253C AUGUST, 1987: FOR EMPTY SUBSETS, DO NO PRINT ERROR MESSAGE 1254C UNLESS FEEDBACK SWITCH IS ON 1255C 1256C SEPTEMBER 2018: DO NOT TREAT AN EMPTY SUBSET AS AN ERROR 1257C 1258CCCCC IF(IFEEDB.EQ.'ON')THEN 1259CCCCC WRITE(ICOUT,999) 1260CCCCC CALL DPWRST('XXX','BUG ') 1261CCCCC WRITE(ICOUT,1611) 1262C1611 FORMAT('***** ERROR IN DPSUBS--') 1263CCCCC CALL DPWRST('XXX','BUG ') 1264CCCCC WRITE(ICOUT,1612) 1265C1612 FORMAT(' THE SUBSET IS EMPTY--IT HAS NO ELEMENTS IN IT.') 1266CCCCC CALL DPWRST('XXX','BUG ') 1267CCCCC IERROR='YES' 1268CCCCC GOTO9000 1269CCCCC ENDIF 1270C 1271 1690 CONTINUE 1272C 1273C ***************** 1274C ** STEP 90-- ** 1275C ** EXIT. ** 1276C ***************** 1277C 1278 9000 CONTINUE 1279 IF(IBUGQ.EQ.'ON')THEN 1280 WRITE(ICOUT,999) 1281 CALL DPWRST('XXX','BUG ') 1282 WRITE(ICOUT,9011) 1283 9011 FORMAT('***** AT THE END OF DPSUBS--') 1284 CALL DPWRST('XXX','BUG ') 1285 WRITE(ICOUT,9014)IERROR,NUMSV,ND 1286 9014 FORMAT('IERROR,NUMSV,ND = ',A4,2X,2I8) 1287 CALL DPWRST('XXX','BUG ') 1288 WRITE(ICOUT,9018)ICASQU,ICASVA,ICASOP,ICASSC 1289 9018 FORMAT('ICASQU,ICASVA,ICASOP,ICASSC = ',3(A4,2X),A4) 1290 CALL DPWRST('XXX','BUG ') 1291 DO9020I=1,NIOLD 1292 WRITE(ICOUT,9021)I,ISUB(I) 1293 9021 FORMAT('I,ISUB(I) = ',2I8) 1294 CALL DPWRST('XXX','BUG ') 1295 9020 CONTINUE 1296 ENDIF 1297C 1298 RETURN 1299 END 1300 SUBROUTINE DPSUM2(Y,W,N,XTEMP1,XTEMP2,XTEMP3, 1301 1 DTEMP1,MAXNXT, 1302 1 ICAPSW,ICAPTY,IFORSW,ICASAN, 1303 1 PID,IVARID,IVARI2,NREPL, 1304 1 ISUBRO,IBUGA3,IERROR) 1305C 1306C PURPOSE--THIS ROUTINE GENERATES A SUMMARY 1307C OF THE DATA IN THE INPUT VECTOR Y. 1308C NOTE--ASSUMPTION--MODEL IS RESPONSE = CONSTANT + ERROR. 1309C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR 1310C OF EQUALLY-SPACED OBSERVATIONS 1311C TO BE SMOOTHED. 1312C N = THE INTEGER NUMBER OF 1313C OBSERVATIONS IN THE VECTOR Y. 1314C WRITTEN BY--JAMES J. FILLIBEN 1315C STATISTICAL ENGINEERING DIVISION 1316C INFORMATION TECHNOLOGY LABORATORY 1317C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 1318C GAITHERSBURG, MD 20899-8980 1319C PHONE--301-975-2899 1320C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 1321C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 1322C LANGUAGE--ANSI FORTRAN (1977) 1323C VERSION NUMBER--82/7 1324C ORIGINAL VERSION--JULY 1981. 1325C UPDATED --NOVEMBER 1981. 1326C UPDATED --FEBRUARY 1982. 1327C UPDATED --MAY 1982. 1328C UPDATED --OCTOBER 2002. SUPPORT FOR HTML OUTPUT 1329C (ADD ICAPSW, ICAPTY TO CALL 1330C LIST) 1331C UPDATED --OCTOBER 2003. SUPPORT FOR LATEX OUTPUT 1332C UPDATED --MAY 2011. SUPPORT FOR REPLICATION AND 1333C MULTIPLE RESPONSE 1334C UPDATED --MAY 2011. USE DPDTA1 AND DPDT5B TO PRINT 1335C THE TABLES 1336C UPDATED --JUNE 2016. CALL LIST TO NORPPC 1337C 1338C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 1339C 1340 CHARACTER*4 IVARID(*) 1341 CHARACTER*4 IVARI2(*) 1342C 1343 CHARACTER*4 ICAPSW 1344 CHARACTER*4 ICAPTY 1345 CHARACTER*4 IFORSW 1346 CHARACTER*4 ICASAN 1347C 1348 CHARACTER*4 IBUGA3 1349 CHARACTER*4 ISUBRO 1350 CHARACTER*4 IERROR 1351 CHARACTER*4 IWRITE 1352 CHARACTER*20 IDIST 1353 CHARACTER*4 ISUBN1 1354 CHARACTER*4 ISUBN2 1355 CHARACTER*4 ISTEPN 1356 CHARACTER*4 IGEPDF 1357 CHARACTER*4 ICASE 1358C 1359C--------------------------------------------------------------------- 1360C 1361 DIMENSION Y(*) 1362 DIMENSION W(*) 1363 DIMENSION XTEMP1(*) 1364 DIMENSION XTEMP2(*) 1365 DIMENSION XTEMP3(*) 1366 DIMENSION PID(*) 1367C 1368 DOUBLE PRECISION DTEMP1(*) 1369C 1370 PARAMETER(NUMCLI=5) 1371 PARAMETER(MAXLIN=1) 1372 PARAMETER (MAXROW=10) 1373 PARAMETER (MAXRO2=10) 1374 CHARACTER*60 ITITLE 1375 CHARACTER*60 ITITLZ 1376 CHARACTER*60 ITITL9 1377 CHARACTER*60 ITEXT(MAXRO2) 1378 CHARACTER*4 ALIGN(NUMCLI) 1379 CHARACTER*4 VALIGN(NUMCLI) 1380 REAL AVALUE(MAXRO2) 1381 INTEGER NCTEXT(MAXRO2) 1382 INTEGER IDIGIT(MAXRO2) 1383 INTEGER IDIGI2(MAXROW,NUMCLI) 1384 INTEGER NTOT(MAXRO2) 1385 INTEGER ROWSEP(MAXROW) 1386 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 1387 CHARACTER*21 IVALUE(MAXROW,NUMCLI) 1388 CHARACTER*4 ITYPCO(NUMCLI) 1389 INTEGER NCTIT2(MAXLIN,NUMCLI) 1390 INTEGER NCVALU(MAXROW,NUMCLI) 1391 INTEGER NCOLSP(MAXLIN,NUMCLI) 1392 INTEGER IWHTML(NUMCLI) 1393 INTEGER IWRTF(NUMCLI) 1394 REAL AMAT(MAXROW,NUMCLI) 1395 LOGICAL IFRST 1396 LOGICAL ILAST 1397 LOGICAL IFLAGS 1398 LOGICAL IFLAGE 1399C 1400C-----COMMON---------------------------------------------------------- 1401C 1402 INCLUDE 'DPCOP2.INC' 1403C 1404C-----START POINT----------------------------------------------------- 1405C 1406 ISUBN1='DPSU' 1407 ISUBN2='M2 ' 1408 IERROR='NO' 1409 IWRITE='OFF' 1410C 1411 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SUM2')THEN 1412 WRITE(ICOUT,999) 1413 999 FORMAT(1X) 1414 CALL DPWRST('XXX','BUG ') 1415 WRITE(ICOUT,51) 1416 51 FORMAT('**** AT THE BEGINNING OF DPSUM2--') 1417 CALL DPWRST('XXX','BUG ') 1418 WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASAN,N,MAXNXT 1419 52 FORMAT('IBUGA3,ISUBRO,ICASAN,N,MAXNXT = ',3(A4,2X),2I8) 1420 CALL DPWRST('XXX','BUG ') 1421 DO56I=1,N 1422 WRITE(ICOUT,57)I,Y(I),W(I) 1423 57 FORMAT('I,Y(I),W(I) = ',I8,2G15.7) 1424 CALL DPWRST('XXX','BUG ') 1425 56 CONTINUE 1426 ENDIF 1427C 1428C ******************************************** 1429C ** STEP 1-- ** 1430C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 1431C ******************************************** 1432C 1433 ISTEPN='1' 1434 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SUM2') 1435 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1436C 1437 IF(N.LT.2)THEN 1438 WRITE(ICOUT,999) 1439 CALL DPWRST('XXX','BUG ') 1440 WRITE(ICOUT,111) 1441 111 FORMAT('***** ERROR IN SUMMARY--') 1442 CALL DPWRST('XXX','BUG ') 1443 WRITE(ICOUT,112) 1444 112 FORMAT(' THE NUMBER OF OBSERVATIONS IN THE RESPONSE ', 1445 1 'VARIABLE IS LESS THAN TWO.') 1446 CALL DPWRST('XXX','BUG ') 1447 WRITE(ICOUT,113)N 1448 113 FORMAT('SAMPLE SIZE = ',I8) 1449 CALL DPWRST('XXX','BUG ') 1450 IERROR='YES' 1451 GOTO9000 1452 ENDIF 1453C 1454 HOLD=Y(1) 1455 DO135I=2,N 1456 IF(Y(I).NE.HOLD)GOTO139 1457 135 CONTINUE 1458 WRITE(ICOUT,999) 1459 CALL DPWRST('XXX','BUG ') 1460 WRITE(ICOUT,111) 1461 CALL DPWRST('XXX','BUG ') 1462 WRITE(ICOUT,131)HOLD 1463 131 FORMAT(' THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7) 1464 CALL DPWRST('XXX','BUG ') 1465 GOTO9000 1466 139 CONTINUE 1467C 1468C ********************************************** 1469C ** STEP 3-- ** 1470C ** COMPUTE VARIOUS MEASURES OF LOCATION-- ** 1471C ** 1) MIDRANGE ** 1472C ** 2) MEAN ** 1473C ** 3) MIDMEAN ** 1474C ** 4) MEDIAN ** 1475C ********************************************** 1476C 1477 ISTEPN='3' 1478 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SUM2') 1479 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1480C 1481 CALL MIDRAN(Y,N,IWRITE,YMIDR,IBUGA3,IERROR) 1482 CALL MEAN(Y,N,IWRITE,YMEAN,IBUGA3,IERROR) 1483 CALL MIDMEA(Y,N,IWRITE,XTEMP1,MAXNXT,YMIDM,IBUGA3,IERROR) 1484 CALL MEDIAN(Y,N,IWRITE,XTEMP1,MAXNXT,YMED,IBUGA3,IERROR) 1485C 1486C ********************************************** 1487C ** STEP 4-- ** 1488C ** COMPUTE VARIOUS MEASURES OF DISPERSION ** 1489C ** 1) RANGE ** 1490C ** 2) STANDARD DEVIATION ** 1491C ** 3) AVERAGE ABSOLUTE DEVIATION ** 1492C ** 4) MINIMUM ** 1493C ** 5) LOWER QUARTILE ** 1494C ** 6) LOWER HINGE ** 1495C ** 7) UPPER HINGE ** 1496C ** 8) UPPER QUARTILE ** 1497C ** 9) MAXIMUM ** 1498C ********************************************** 1499C 1500 ISTEPN='4' 1501 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SUM2') 1502 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1503C 1504 CALL RANGDP(Y,N,IWRITE,YRANGE,IBUGA3,IERROR) 1505 CALL SD(Y,N,IWRITE,YSD,IBUGA3,IERROR) 1506 ICASE='MEAN' 1507 CALL AAD(Y,N,IWRITE,XTEMP1,MAXNXT,YAAD,ICASE,IBUGA3,IERROR) 1508 CALL MINIM(Y,N,IWRITE,YMIN,IBUGA3,IERROR) 1509 CALL LOWQUA(Y,N,IWRITE,XTEMP1,MAXNXT,YLOWQ,IBUGA3,IERROR) 1510 CALL LOWHIN(Y,N,IWRITE,XTEMP1,MAXNXT,YLOWH,IBUGA3,IERROR) 1511 CALL UPPHIN(Y,N,IWRITE,XTEMP1,MAXNXT,YUPPH,IBUGA3,IERROR) 1512 CALL UPPQUA(Y,N,IWRITE,XTEMP1,MAXNXT,YUPPQ,IBUGA3,IERROR) 1513 CALL MAXIM(Y,N,IWRITE,YMAX,IBUGA3,IERROR) 1514C 1515C ******************************************************** 1516C ** STEP 5-- ** 1517C ** COMPUTE VARIOUS DISTRIBUTIONAL MEASURES-- ** 1518C ** 1) STANDARDIZED THIRD CENTRAL MOMENT ** 1519C ** 2) STANDARDIZED FOURTH CENTRAL MOMENT ** 1520C ** 3) STANDARDIZED WILK-SHAPIRO STATISTIC ** 1521C ** 4) UNIFORM PROBABILITY PLOT CORRELATION COEFF ** 1522C ** 5) NORMAL PROBABILITY PLOT CORRELATION COEFF ** 1523C ** 6) TUKEY LAMBDA = -0.5 PROBABILITY PLOT ** 1524C ** CORRELATION COEFF ** 1525C ** 7) CAUCHY PROBABILITY PLOT CORRELATION COEFF ** 1526C ********************************************************* 1527C 1528 ISTEPN='5' 1529 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SUM2') 1530 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1531C 1532 CALL STMOM3(Y,N,IWRITE,YST3MO,IBUGA3,IERROR) 1533 CALL STMOM4(Y,N,IWRITE,YST4MO,IBUGA3,IERROR) 1534 CALL STWS(Y,N,XTEMP1,IWRITE,YSTWS,MAXNXT,IBUGA3,IERROR) 1535C 1536 ALAMB=0.0 1537 ALAMB2=0.0 1538 MINMAX=1 1539 IGEPDF='NULL' 1540 IDIST='UNIFORM' 1541 CALL NORPPC(Y,N,IDIST,ALAMB,ALAMB2, 1542 1 IWRITE,XTEMP1,XTEMP2,XTEMP3,DTEMP1,MAXNXT, 1543 1 MINMAX,IGEPDF, 1544 1 YUNIPP,SHAPE,SHAPE2,ALOC,SCALE, 1545 1 IBUGA3,ISUBRO,IERROR) 1546 IDIST='NORMAL' 1547 CALL NORPPC(Y,N,IDIST,ALAMB,ALAMB2, 1548 1 IWRITE,XTEMP1,XTEMP2,XTEMP3,DTEMP1,MAXNXT, 1549 1 MINMAX,IGEPDF, 1550 1 YNORPP,SHAPE,SHAPE2,ALOC,SCALE,IBUGA3,ISUBRO,IERROR) 1551 IDIST='CAUCHY' 1552 CALL NORPPC(Y,N,IDIST,ALAMB,ALAMB2, 1553 1 IWRITE,XTEMP1,XTEMP2,XTEMP3,DTEMP1,MAXNXT, 1554 1 MINMAX,IGEPDF, 1555 1 YCAUPP,SHAPE,SHAPE2,ALOC,SCALE, 1556 1 IBUGA3,ISUBRO,IERROR) 1557 ALAMB=-0.5 1558 IDIST='TUKEY-LAMBDA' 1559 CALL NORPPC(Y,N,IDIST,ALAMB,ALAMB2, 1560 1 IWRITE,XTEMP1,XTEMP2,XTEMP3,DTEMP1,MAXNXT, 1561 1 MINMAX,IGEPDF, 1562 1 YLAMPP,SHAPE,SHAPE2,ALOC,SCALE, 1563 1 IBUGA3,ISUBRO,IERROR) 1564C 1565C ******************************************************* 1566C ** STEP 6-- ** 1567C ** COMPUTE VARIOUS RANDOMNESS MEASURES ** 1568C ** 1) AUTOCORRELATION COEFFICIENT ** 1569C ** 2) STANDARDIZED LENGTH OF LONGEST RUN (UP OR ** 1570C ** DOWN) ** 1571C ** 3) STANDARDIZED NUMBER OF RUNS (UP + DOWN) ** 1572C ******************************************************** 1573C 1574 ISTEPN='6' 1575 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SUM2') 1576 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1577C 1578 CALL AUTOCR(Y,N,IWRITE,YAUTOC,IBUGA3,IERROR) 1579CCCCC CALL STLLRU(Y,N,IWRITE,YSTLLR,IBUGA3,IERROR) 1580 YSTLLR=0.0 1581CCCCC CALL STNRUN(Y,N,IWRITE,YSTNRU,IBUGA3,IERROR) 1582 YSTNRU=0.0 1583C 1584C **************************** 1585C ** STEP 7-- ** 1586C ** WRITE EVERYTHING OUT ** 1587C **************************** 1588C 1589 ISTEPN='7' 1590 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SUM2') 1591 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1592C 1593C PRINT SUMMARY STATISTICS TABLE 1594C 1595 IF(IPRINT.EQ.'OFF')GOTO9000 1596C 1597 NUMDIG=7 1598 IF(IFORSW.EQ.'1')NUMDIG=1 1599 IF(IFORSW.EQ.'2')NUMDIG=2 1600 IF(IFORSW.EQ.'3')NUMDIG=3 1601 IF(IFORSW.EQ.'4')NUMDIG=4 1602 IF(IFORSW.EQ.'5')NUMDIG=5 1603 IF(IFORSW.EQ.'6')NUMDIG=6 1604 IF(IFORSW.EQ.'7')NUMDIG=7 1605 IF(IFORSW.EQ.'8')NUMDIG=8 1606 IF(IFORSW.EQ.'9')NUMDIG=9 1607 IF(IFORSW.EQ.'0')NUMDIG=0 1608 IF(IFORSW.EQ.'E')NUMDIG=-2 1609 IF(IFORSW.EQ.'-2')NUMDIG=-2 1610 IF(IFORSW.EQ.'-3')NUMDIG=-3 1611 IF(IFORSW.EQ.'-4')NUMDIG=-4 1612 IF(IFORSW.EQ.'-5')NUMDIG=-5 1613 IF(IFORSW.EQ.'-6')NUMDIG=-6 1614 IF(IFORSW.EQ.'-7')NUMDIG=-7 1615 IF(IFORSW.EQ.'-8')NUMDIG=-8 1616 IF(IFORSW.EQ.'-9')NUMDIG=-9 1617C 1618 ITITLE='Summary of xxxxxxxxxx Observations' 1619 WRITE(ITITLE(12:21),'(I10)')N 1620 NCTITL=34 1621 ITITLZ=' ' 1622 NCTITZ=0 1623C 1624 ICNT=1 1625 ITEXT(ICNT)='Response Variable: ' 1626 WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4) 1627 WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4) 1628 NCTEXT(ICNT)=27 1629 AVALUE(ICNT)=0.0 1630 IDIGIT(ICNT)=-1 1631C 1632 IF(NREPL.GT.0)THEN 1633 IADD=1 1634 DO2101I=1,NREPL 1635 ICNT=ICNT+1 1636 ITEMP=I+IADD 1637 ITEXT(ICNT)='Factor Variable : ' 1638 WRITE(ITEXT(ICNT)(17:17),'(I1)')I 1639 WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4) 1640 WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4) 1641 NCTEXT(ICNT)=27 1642 AVALUE(ICNT)=PID(ITEMP) 1643 IDIGIT(ICNT)=NUMDIG 1644 2101 CONTINUE 1645 ENDIF 1646C 1647 ICNT=ICNT+1 1648 ITEXT(ICNT)=' ' 1649 NCTEXT(ICNT)=1 1650 AVALUE(ICNT)=0.0 1651 IDIGIT(ICNT)=-1 1652C 1653 NUMROW=ICNT 1654 DO2310I=1,NUMROW 1655 NTOT(I)=15 1656 2310 CONTINUE 1657C 1658 IFRST=.TRUE. 1659 ILAST=.TRUE. 1660 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT, 1661 1 NCTEXT,AVALUE,IDIGIT, 1662 1 NTOT,NUMROW, 1663 1 ICAPSW,ICAPTY,ILAST,IFRST, 1664 1 ISUBRO,IBUGA3,IERROR) 1665C 1666 ITITLE=' ' 1667 NCTITL=-99 1668 ITITL9=' ' 1669 NCTIT9=0 1670C 1671 NUMCOL=5 1672 NUMLIN=1 1673C 1674 ITITL2(1,1)='Location Measures' 1675 NCTIT2(1,1)=17 1676 NCOLSP(1,1)=2 1677 ITITL2(1,2)=' ' 1678 NCTIT2(1,2)=0 1679 NCOLSP(1,2)=0 1680 ITITL2(1,3)=' | ' 1681 NCTIT2(1,3)=3 1682 NCOLSP(1,3)=1 1683 ITITL2(1,4)='Dispersion Measures' 1684 NCTIT2(1,4)=19 1685 NCOLSP(1,4)=2 1686 ITITL2(1,5)=' ' 1687 NCTIT2(1,5)=0 1688 NCOLSP(1,5)=0 1689C 1690 NMAX=0 1691 DO4210I=1,NUMCOL 1692 VALIGN(I)='b' 1693 ALIGN(I)='r' 1694 NTOT(I)=15 1695 IF(I.EQ.1)NTOT(I)=21 1696 IF(I.EQ.4)NTOT(I)=20 1697 IF(I.EQ.3)NTOT(I)=3 1698 NMAX=NMAX+NTOT(I) 1699 ITYPCO(I)='NUME' 1700 IF(I.EQ.1 .OR. I.EQ.3 .OR. I.EQ.4)ITYPCO(I)='ALPH' 1701 DO4213J=1,MAXROW 1702 IDIGI2(J,I)=NUMDIG 1703 IF(I.EQ.1 .OR. I.EQ.3 .OR. I.EQ.4)THEN 1704 IDIGI2(J,I)=-1 1705 ENDIF 1706 4213 CONTINUE 1707 4210 CONTINUE 1708C 1709 DO4289J=1,MAXROW 1710 IVALUE(J,1)=' ' 1711 IVALUE(J,2)=' ' 1712 IVALUE(J,3)=' ' 1713 IVALUE(J,4)=' ' 1714 IVALUE(J,5)=' ' 1715 NCVALU(J,1)=0 1716 NCVALU(J,2)=0 1717 NCVALU(J,3)=0 1718 NCVALU(J,4)=0 1719 NCVALU(J,5)=0 1720 AMAT(J,1)=0.0 1721 AMAT(J,2)=0.0 1722 AMAT(J,3)=0.0 1723 AMAT(J,4)=0.0 1724 AMAT(J,5)=0.0 1725 ROWSEP(J)=0 1726 4289 CONTINUE 1727 AMAT(1,2)=YMIDR 1728 AMAT(1,5)=YRANGE 1729 AMAT(2,2)=YMEAN 1730 AMAT(2,5)=YSD 1731 AMAT(3,2)=YMIDM 1732 AMAT(3,5)=YAAD 1733 AMAT(4,2)=YMED 1734 AMAT(4,5)=YMIN 1735 AMAT(5,2)=0.0 1736 IDIGI2(5,2)=-1 1737 AMAT(5,5)=YLOWQ 1738 AMAT(6,2)=0.0 1739 IDIGI2(6,2)=-1 1740 AMAT(6,5)=YLOWH 1741 AMAT(7,2)=0.0 1742 IDIGI2(7,2)=-1 1743 AMAT(7,5)=YUPPH 1744 AMAT(8,2)=0.0 1745 IDIGI2(8,2)=-1 1746 AMAT(8,5)=YUPPQ 1747 AMAT(9,2)=0.0 1748 IDIGI2(9,2)=-1 1749 AMAT(9,5)=YMAX 1750CCCCC ROWSEP(9)=1 1751C 1752 IVALUE(1,1)='Midrange:' 1753 NCVALU(1,1)=9 1754 IVALUE(2,1)='Mean:' 1755 NCVALU(2,1)=5 1756 IVALUE(3,1)='Midmean:' 1757 NCVALU(3,1)=8 1758 IVALUE(4,1)='Median:' 1759 NCVALU(4,1)=7 1760C 1761 DO4330I=1,9 1762 IVALUE(I,3)=' | ' 1763 NCVALU(I,3)=3 1764 4330 CONTINUE 1765C 1766 IVALUE(1,4)='Range:' 1767 NCVALU(1,4)=6 1768 IVALUE(2,4)='Standard Deviation:' 1769 NCVALU(2,4)=19 1770 IVALUE(3,4)='Average Abs. Dev.:' 1771 NCVALU(3,4)=18 1772 IVALUE(4,4)='Minimum:' 1773 NCVALU(4,4)=8 1774 IVALUE(5,4)='Lower Quartile:' 1775 NCVALU(5,4)=15 1776 IVALUE(6,4)='Lower Hinge:' 1777 NCVALU(6,4)=12 1778 IVALUE(7,4)='Upper Hinge:' 1779 NCVALU(7,4)=12 1780 IVALUE(8,4)='Upper Quartile:' 1781 NCVALU(8,4)=15 1782 IVALUE(9,4)='Maximum:' 1783 NCVALU(9,4)=8 1784C 1785 IWHTML(1)=150 1786 IWHTML(2)=150 1787 IWHTML(3)=25 1788 IWHTML(4)=150 1789 IWHTML(5)=150 1790 IINC=1800 1791 IINC2=200 1792 IWRTF(1)=IINC 1793 IWRTF(2)=IWRTF(1)+IINC 1794 IWRTF(3)=IWRTF(2)+IINC2 1795 IWRTF(4)=IWRTF(3)+IINC 1796 IWRTF(5)=IWRTF(4)+IINC 1797C 1798 ICNT=9 1799 IFRST=.TRUE. 1800 ILAST=.FALSE. 1801 IFLAGS=.TRUE. 1802 IFLAGE=.TRUE. 1803 CALL DPDT5B(ITITLE,NCTITL, 1804 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 1805 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 1806 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 1807 1 IDIGI2,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 1808 1 NCOLSP,ROWSEP, 1809 1 ICAPSW,ICAPTY,IFRST,ILAST, 1810 1 IFLAGS,IFLAGE, 1811 1 ISUBRO,IBUGA3,IERROR) 1812C 1813 ITITL2(1,1)='Randomness Measures' 1814 NCTIT2(1,1)=19 1815 ITITL2(1,4)='Distributional Measures' 1816 NCTIT2(1,4)=23 1817C 1818 DO4389J=1,MAXROW 1819 IVALUE(J,1)=' ' 1820 IVALUE(J,2)=' ' 1821 IVALUE(J,3)=' ' 1822 IVALUE(J,4)=' ' 1823 IVALUE(J,5)=' ' 1824 NCVALU(J,1)=0 1825 NCVALU(J,2)=0 1826 NCVALU(J,3)=0 1827 NCVALU(J,4)=0 1828 NCVALU(J,5)=0 1829 AMAT(J,1)=0.0 1830 AMAT(J,2)=0.0 1831 AMAT(J,3)=0.0 1832 AMAT(J,4)=0.0 1833 AMAT(J,5)=0.0 1834 ROWSEP(J)=0 1835 4389 CONTINUE 1836 AMAT(1,2)=YAUTOC 1837 AMAT(1,5)=YST3MO 1838 AMAT(2,2)=0.0 1839 IDIGI2(2,2)=-1 1840 AMAT(2,5)=YST4MO 1841 AMAT(3,2)=0.0 1842 IDIGI2(3,2)=-1 1843 AMAT(3,5)=YSTWS 1844 AMAT(4,2)=0.0 1845 IDIGI2(4,2)=-1 1846 AMAT(4,5)=YUNIPP 1847 AMAT(5,2)=0.0 1848 IDIGI2(5,2)=-1 1849 AMAT(5,5)=YNORPP 1850 AMAT(6,2)=0.0 1851 IDIGI2(6,2)=-1 1852 AMAT(6,5)=YLAMPP 1853 AMAT(7,2)=0.0 1854 IDIGI2(7,2)=-1 1855 AMAT(7,5)=YCAUPP 1856 ROWSEP(7)=1 1857C 1858 IVALUE(1,1)='Autocorrelation Coef:' 1859 NCVALU(1,1)=21 1860C 1861 DO4350I=1,9 1862 IVALUE(I,3)=' | ' 1863 NCVALU(I,3)=3 1864 4350 CONTINUE 1865C 1866 IVALUE(1,4)='St. Third Moment:' 1867 NCVALU(1,4)=17 1868 IVALUE(2,4)='St. Fourth Moment:' 1869 NCVALU(2,4)=18 1870 IVALUE(3,4)='St. Wilk-Shapiro:' 1871 NCVALU(3,4)=17 1872 IVALUE(4,4)='Uniform PPCC:' 1873 NCVALU(4,4)=13 1874 IVALUE(5,4)='Normal PPCC:' 1875 NCVALU(5,4)=12 1876 IVALUE(6,4)='Tukey-Lam -.5 PPCC:' 1877 NCVALU(6,4)=19 1878 IVALUE(7,4)='Cauchy PPCC:' 1879 NCVALU(7,4)=12 1880C 1881 ICNT=7 1882 IFRST=.TRUE. 1883 ILAST=.TRUE. 1884 IFLAGS=.TRUE. 1885 IFLAGE=.TRUE. 1886 CALL DPDT5B(ITITLE,NCTITL, 1887 1 ITITL9,NCTIT9,ITITL2,NCTIT2, 1888 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 1889 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT, 1890 1 IDIGI2,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 1891 1 NCOLSP,ROWSEP, 1892 1 ICAPSW,ICAPTY,IFRST,ILAST, 1893 1 IFLAGS,IFLAGE, 1894 1 ISUBRO,IBUGA3,IERROR) 1895C 1896C ***************** 1897C ** STEP 90-- ** 1898C ** EXIT ** 1899C ***************** 1900C 1901 9000 CONTINUE 1902 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SUM2')THEN 1903 WRITE(ICOUT,999) 1904 CALL DPWRST('XXX','BUG ') 1905 WRITE(ICOUT,9011) 1906 9011 FORMAT('***** AT THE END OF DPSUM2--') 1907 CALL DPWRST('XXX','BUG ') 1908 WRITE(ICOUT,9012)N,IBUGA3,IERROR 1909 9012 FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4) 1910 CALL DPWRST('XXX','BUG ') 1911 ENDIF 1912C 1913 RETURN 1914 END 1915 SUBROUTINE DPSUMM(XTEMP1,XTEMP2,MAXNXT, 1916 1 ICASAN,ICAPSW,IFORSW, 1917 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 1918C 1919C PURPOSE--GENERATE A BATTERY OF SUMMARY STATISTICS. 1920C WRITTEN BY--JAMES J. FILLIBEN 1921C STATISTICAL ENGINEERING DIVISION 1922C INFORMATION TECHNOLOGY LABORATORY 1923C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 1924C GAITHERSBURG, MD 20899-8980 1925C PHONE--301-975-2899 1926C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 1927C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 1928C LANGUAGE--ANSI FORTRAN (1977) 1929C VERSION NUMBER--82/7 1930C ORIGINAL VERSION--JULY 1981. 1931C UPDATED --AUGUST 1981. 1932C UPDATED --SEPTEMBER 1981. 1933C UPDATED --MAY 1982. 1934C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON 1935C UPDATED --OCTOBER 2002. SUPPORT FOR HTML OUTPUT 1936C (ADD ICAPSW TO CALL LIST) 1937C UPDATED --MAY 2011. USE DPPARS 1938C UPDATED --MAY 2011. SUPPORT FOR "MULTIPLE" AND 1939C "REPLICATION" OPTIONS 1940C UPDATED --JUNE 2016. CALL LIST TO DPSUM2 1941C UPDATED --JULY 2019. TWEAK SCRATCH SPACE 1942C 1943C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 1944C 1945 CHARACTER*4 ICASAN 1946 CHARACTER*4 ICAPSW 1947 CHARACTER*4 IFORSW 1948 CHARACTER*4 IBUGA2 1949 CHARACTER*4 IBUGA3 1950 CHARACTER*4 IBUGQ 1951 CHARACTER*4 ISUBRO 1952 CHARACTER*4 IFOUND 1953 CHARACTER*4 IERROR 1954C 1955 CHARACTER*4 ISUBN1 1956 CHARACTER*4 ISUBN2 1957 CHARACTER*4 ISTEPN 1958 CHARACTER*4 IREPL 1959 CHARACTER*4 IMULT 1960 CHARACTER*4 ICTMP1 1961 CHARACTER*4 ICTMP2 1962 CHARACTER*4 ICTMP3 1963 CHARACTER*4 ICTMP4 1964 CHARACTER*4 ICASE 1965C 1966 CHARACTER*40 INAME 1967 PARAMETER (MAXSPN=30) 1968 CHARACTER*4 IVARN1(MAXSPN) 1969 CHARACTER*4 IVARN2(MAXSPN) 1970 CHARACTER*4 IVARTY(MAXSPN) 1971 CHARACTER*4 IVARID(1) 1972 CHARACTER*4 IVARI2(1) 1973 REAL PVAR(MAXSPN) 1974 REAL PID(MAXSPN) 1975 INTEGER ILIS(MAXSPN) 1976 INTEGER NRIGHT(MAXSPN) 1977 INTEGER ICOLR(MAXSPN) 1978C 1979C--------------------------------------------------------------------- 1980C 1981 INCLUDE 'DPCOPA.INC' 1982C 1983 DIMENSION XTEMP1(*) 1984 DIMENSION XTEMP2(*) 1985 DIMENSION W(MAXOBV) 1986C 1987 DIMENSION XDESGN(MAXOBV,7) 1988 DIMENSION XIDTEM(MAXOBV) 1989 DIMENSION XIDTE2(MAXOBV) 1990 DIMENSION XIDTE3(MAXOBV) 1991 DIMENSION XIDTE4(MAXOBV) 1992 DIMENSION XIDTE5(MAXOBV) 1993 DIMENSION XIDTE6(MAXOBV) 1994C 1995 DIMENSION TEMP1(MAXOBV) 1996 DIMENSION TEMP2(MAXOBV) 1997 DIMENSION XTEMP3(MAXOBV) 1998C 1999 DOUBLE PRECISION DTEMP1(MAXOBV) 2000C 2001 INCLUDE 'DPCOZZ.INC' 2002 INCLUDE 'DPCOZD.INC' 2003C 2004 EQUIVALENCE (GARBAG(IGARB1),TEMP1(1)) 2005 EQUIVALENCE (GARBAG(IGARB2),XIDTEM(1)) 2006 EQUIVALENCE (GARBAG(IGARB3),XIDTE2(1)) 2007 EQUIVALENCE (GARBAG(IGARB4),XIDTE3(1)) 2008 EQUIVALENCE (GARBAG(IGARB5),XIDTE4(1)) 2009 EQUIVALENCE (GARBAG(IGARB6),XIDTE5(1)) 2010 EQUIVALENCE (GARBAG(IGARB7),XIDTE6(1)) 2011 EQUIVALENCE (GARBAG(IGARB8),TEMP2(1)) 2012 EQUIVALENCE (GARBAG(IGARB9),W(1)) 2013 EQUIVALENCE (GARBAG(IGAR10),XTEMP3(1)) 2014 EQUIVALENCE (GARBAG(JGAR11),XDESGN(1,1)) 2015 EQUIVALENCE (DGARBG(IDGAR1),DTEMP1(1)) 2016C 2017C-----COMMON---------------------------------------------------------- 2018C 2019 INCLUDE 'DPCOHK.INC' 2020 INCLUDE 'DPCODA.INC' 2021 INCLUDE 'DPCOSU.INC' 2022 INCLUDE 'DPCOST.INC' 2023 INCLUDE 'DPCOP2.INC' 2024C 2025C-----START POINT----------------------------------------------------- 2026C 2027 IERROR='NO' 2028 IFOUND='NO' 2029 ICASAN='SUMM' 2030 IREPL='OFF' 2031 IMULT='OFF' 2032 ISUBN1='DPSU' 2033 ISUBN2='MM ' 2034C 2035 MAXCP1=MAXCOL+1 2036 MAXCP2=MAXCOL+2 2037 MAXCP3=MAXCOL+3 2038 MAXCP4=MAXCOL+4 2039 MAXCP5=MAXCOL+5 2040 MAXCP6=MAXCOL+6 2041C 2042C *********************************************** 2043C ** TREAT THE SUMMARY CASE ** 2044C *********************************************** 2045C 2046 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'SUMM')THEN 2047 WRITE(ICOUT,999) 2048 999 FORMAT(1X) 2049 CALL DPWRST('XXX','BUG ') 2050 WRITE(ICOUT,51) 2051 51 FORMAT('***** AT THE BEGINNING OF DPSUMM--') 2052 CALL DPWRST('XXX','BUG ') 2053 WRITE(ICOUT,53)IBUGA2,IBUGA3,IBUGQ,ISUBRO 2054 53 FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',3(A4,2X),A4) 2055 CALL DPWRST('XXX','BUG ') 2056 ENDIF 2057C 2058C ***************************************************** 2059C ** STEP 1-- ** 2060C ** EXTRACT THE COMMAND ** 2061C ** LOOK FOR ONE OF THE FOLLOWING COMMANDS: ** 2062C ** 1) SUMMARY Y ** 2063C ** 2) MULTIPLE SUMMARY Y1 ... YK ** 2064C ** 3) REPLICATED SUMMARY Y X1 ... XK ** 2065C ***************************************************** 2066C 2067 ISTEPN='1' 2068 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SUMM') 2069 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2070C 2071 ILASTC=9999 2072 ILASTZ=9999 2073 ICASAN='SUMM' 2074C 2075 DO100I=0,NUMARG-1 2076C 2077 IF(I.EQ.0)THEN 2078 ICTMP1=ICOM 2079 ELSE 2080 ICTMP1=IHARG(I) 2081 ENDIF 2082 ICTMP2=IHARG(I+1) 2083 ICTMP3=IHARG(I+2) 2084 ICTMP4=IHARG(I+3) 2085C 2086 IF(ICTMP1.EQ.'=')THEN 2087 IFOUND='NO' 2088 GOTO9000 2089 ELSEIF(ICTMP1.EQ.'SUMM')THEN 2090 IFOUND='YES' 2091 ICASAN='SUMM' 2092 ILASTC=I 2093 ILASTZ=I 2094 ELSEIF(ICTMP1.EQ.'REPL')THEN 2095 IREPL='ON' 2096 ILASTC=MIN(ILASTC,I) 2097 ILASTZ=MAX(ILASTZ,I) 2098 ELSEIF(ICTMP1.EQ.'TOLE' .AND. ICTMP2.EQ.'LIMI')THEN 2099 IFOUND='NO' 2100 GOTO9000 2101 ELSEIF(ICTMP1.EQ.'TOLE' .AND. ICTMP2.EQ.'INTE')THEN 2102 IFOUND='NO' 2103 GOTO9000 2104 ELSEIF(ICTMP1.EQ.'MULT')THEN 2105 IMULT='ON' 2106 ILASTC=MIN(ILASTC,I) 2107 ILASTZ=MAX(ILASTZ,I) 2108 ENDIF 2109 100 CONTINUE 2110C 2111 IF(IFOUND.EQ.'NO')GOTO9000 2112C 2113 ISHIFT=ILASTZ 2114 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 2115 1 IBUGA2,IERROR) 2116C 2117 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SUMM')THEN 2118 WRITE(ICOUT,91)ICASAN,IMULT,IREPL,ISHIFT 2119 91 FORMAT('DPSUMM: ICASAN,IMULT,IREPL,ISHIFT = ',3(A4,2X),I5) 2120 CALL DPWRST('XXX','BUG ') 2121 ENDIF 2122C 2123 IF(IMULT.EQ.'ON')THEN 2124 IF(IREPL.EQ.'ON')THEN 2125 WRITE(ICOUT,999) 2126 CALL DPWRST('XXX','BUG ') 2127 WRITE(ICOUT,101) 2128 101 FORMAT('***** ERROR IN SUMMARY--') 2129 CALL DPWRST('XXX','BUG ') 2130 WRITE(ICOUT,103) 2131 103 FORMAT(' YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ', 2132 1 '"REPLICATION"') 2133 CALL DPWRST('XXX','BUG ') 2134 WRITE(ICOUT,104) 2135 104 FORMAT(' FOR THE SUMMARY COMMAND.') 2136 CALL DPWRST('XXX','BUG ') 2137 IERROR='YES' 2138 GOTO9000 2139 ENDIF 2140 ENDIF 2141C 2142C ********************************* 2143C ** STEP 4-- ** 2144C ** EXTRACT THE VARIABLE LIST ** 2145C ********************************* 2146C 2147 ISTEPN='4' 2148 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SUMM') 2149 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2150C 2151 INAME='SUMMARY' 2152 MINNA=1 2153 MAXNA=100 2154 MINN2=2 2155 IFLAGE=0 2156 IFLAGM=1 2157 IF(IREPL.EQ.'ON')THEN 2158 IFLAGM=0 2159 IFLAGE=1 2160 ENDIF 2161 IFLAGP=0 2162 JMIN=1 2163 JMAX=NUMARG 2164 MINNVA=1 2165 MAXNVA=MAXSPN 2166C 2167 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 2168 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 2169 1 JMIN,JMAX, 2170 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 2171 1 IVARN1,IVARN2,IVARTY,PVAR, 2172 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 2173 1 MINNVA,MAXNVA, 2174 1 IFLAGM,IFLAGP, 2175 1 IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 2176 IF(IERROR.EQ.'YES')GOTO9000 2177C 2178 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SUMM')THEN 2179 WRITE(ICOUT,999) 2180 CALL DPWRST('XXX','BUG ') 2181 WRITE(ICOUT,281) 2182 281 FORMAT('***** AFTER CALL DPPARS--') 2183 CALL DPWRST('XXX','BUG ') 2184 WRITE(ICOUT,282)NQ,NUMVAR 2185 282 FORMAT('NQ,NUMVAR = ',2I8) 2186 CALL DPWRST('XXX','BUG ') 2187 IF(NUMVAR.GT.0)THEN 2188 DO285I=1,NUMVAR 2189 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 2190 1 ICOLR(I) 2191 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 2192 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 2193 CALL DPWRST('XXX','BUG ') 2194 285 CONTINUE 2195 ENDIF 2196 ENDIF 2197C 2198C *********************************************** 2199C ** STEP 5-- ** 2200C ** DETERMINE: ** 2201C ** 1) NUMBER OF REPLICATION VARIABLES (0-6) ** 2202C ** 2) NUMBER OF RESPONSE VARIABLES (>= 1)** 2203C *********************************************** 2204C 2205 ISTEPN='5' 2206 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SUMM') 2207 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2208C 2209 NREPL=0 2210 NRESP=0 2211 IF(IREPL.EQ.'ON')THEN 2212 NRESP=1 2213 NREPL=NUMVAR-NRESP 2214 IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN 2215 WRITE(ICOUT,999) 2216 CALL DPWRST('XXX','BUG ') 2217 WRITE(ICOUT,101) 2218 CALL DPWRST('XXX','BUG ') 2219 WRITE(ICOUT,511) 2220 511 FORMAT(' FOR THE REPLICATION CASE, THE NUMBER OF ', 2221 1 'REPLICATION VARIABLES') 2222 CALL DPWRST('XXX','BUG ') 2223 WRITE(ICOUT,512) 2224 512 FORMAT(' MUST BE BETWEEN ONE AND SIX.') 2225 CALL DPWRST('XXX','BUG ') 2226 WRITE(ICOUT,513)NREPL 2227 513 FORMAT(' THE NUMBER OF REPLICATION VARIABLES = ',I5) 2228 CALL DPWRST('XXX','BUG ') 2229 IERROR='YES' 2230 GOTO9000 2231 ENDIF 2232 ELSE 2233 NRESP=NUMVAR 2234 IMULT='ON' 2235 ENDIF 2236C 2237 DO519I=1,MAXOBV 2238 W(I)=1.0 2239 519 CONTINUE 2240C 2241 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SUMM')THEN 2242 WRITE(ICOUT,521)NRESP,NREPL 2243 521 FORMAT('NRESP,NREPL = ',2I5) 2244 CALL DPWRST('XXX','BUG ') 2245 ENDIF 2246C 2247C ************************************************** 2248C ** STEP 6-- ** 2249C ** GENERATE THE SUMMARY FOR VARIOUS CASES ** 2250C *************************************************** 2251C 2252 ISTEPN='6' 2253 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SUMM') 2254 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2255C 2256C ****************************************** 2257C ** STEP 8A-- ** 2258C ** CASE 1: NO REPLICATION VARIABLES ** 2259C ****************************************** 2260C 2261 IF(NREPL.LT.1)THEN 2262 ISTEPN='8A' 2263 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SUMM') 2264 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2265C 2266C LOOP THROUGH EACH OF THE RESPONSE VARIABLES 2267C 2268 NCURVE=0 2269 DO810IRESP=1,NRESP 2270 NCURVE=NCURVE+1 2271C 2272 IINDX=ICOLR(IRESP) 2273 PID(1)=CPUMIN 2274 IVARID(1)=IVARN1(IRESP) 2275 IVARI2(1)=IVARN2(IRESP) 2276C 2277 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SUMM')THEN 2278 WRITE(ICOUT,999) 2279 CALL DPWRST('XXX','BUG ') 2280 WRITE(ICOUT,811)IRESP,NCURVE 2281 811 FORMAT('IRESP,NCURVE = ',2I5) 2282 CALL DPWRST('XXX','BUG ') 2283 ENDIF 2284C 2285 ICOL=IRESP 2286 NUMVA2=1 2287 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 2288 1 INAME,IVARN1,IVARN2,IVARTY, 2289 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 2290 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 2291 1 MAXCP4,MAXCP5,MAXCP6, 2292 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 2293 1 Y,XTEMP1,XTEMP1,NS1,NLOCA2,NLOCA3,ICASE, 2294 1 IBUGA3,ISUBRO,IFOUND,IERROR) 2295 IF(IERROR.EQ.'YES')GOTO9000 2296C 2297C ***************************************************** 2298C ** STEP 8B-- ** 2299C ***************************************************** 2300C 2301 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'SUMM')THEN 2302 ISTEPN='8B' 2303 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2304 WRITE(ICOUT,999) 2305 CALL DPWRST('XXX','BUG ') 2306 WRITE(ICOUT,822) 2307 822 FORMAT('***** FROM THE MIDDLE OF DPSUMM--') 2308 CALL DPWRST('XXX','BUG ') 2309 WRITE(ICOUT,823)ICASAN,NUMVAR,NS1 2310 823 FORMAT('ICASAN,NUMVAR,NS1 = ',A4,2I8) 2311 CALL DPWRST('XXX','BUG ') 2312 IF(NS1.GE.1)THEN 2313 DO825I=1,NS1 2314 WRITE(ICOUT,826)I,Y(I) 2315 826 FORMAT('I,Y(I) = ',I8,G15.7) 2316 CALL DPWRST('XXX','BUG ') 2317 825 CONTINUE 2318 ENDIF 2319 ENDIF 2320C 2321 CALL DPSUM2(Y,W,NS1,XTEMP1,XTEMP2,XTEMP3,DTEMP1,MAXNXT, 2322 1 ICAPSW,ICAPTY,IFORSW,ICASAN, 2323 1 PID,IVARID,IVARI2,NREPL, 2324 1 ISUBRO,IBUGA3,IERROR) 2325C 2326 810 CONTINUE 2327C 2328C **************************************************** 2329C ** STEP 9A-- ** 2330C ** CASE 3: ONE OR MORE REPLICATION VARIABLES. ** 2331C ** FOR THIS CASE, THE NUMBER OF RESPONSE ** 2332C ** VARIABLES MUST BE EXACTLY 1. ** 2333C ** FOR THIS CASE, ALL VARIABLES MUST ** 2334C ** HAVE THE SAME LENGTH. ** 2335C **************************************************** 2336C 2337 ELSEIF(NREPL.GE.1)THEN 2338 ISTEPN='9A' 2339 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SUMM') 2340 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2341C 2342 J=0 2343 IMAX=NRIGHT(1) 2344 IF(NQ.LT.NRIGHT(1))IMAX=NQ 2345 DO910I=1,IMAX 2346 IF(ISUB(I).EQ.0)GOTO910 2347 J=J+1 2348C 2349C RESPONSE VARIABLE IN Y 2350C 2351 ICOLC=1 2352 IJ=MAXN*(ICOLR(ICOLC)-1)+I 2353 IF(ICOLR(ICOLC).LE.MAXCOL)Y(J)=V(IJ) 2354 IF(ICOLR(ICOLC).EQ.MAXCP1)Y(J)=PRED(I) 2355 IF(ICOLR(ICOLC).EQ.MAXCP2)Y(J)=RES(I) 2356 IF(ICOLR(ICOLC).EQ.MAXCP3)Y(J)=YPLOT(I) 2357 IF(ICOLR(ICOLC).EQ.MAXCP4)Y(J)=XPLOT(I) 2358 IF(ICOLR(ICOLC).EQ.MAXCP5)Y(J)=X2PLOT(I) 2359 IF(ICOLR(ICOLC).EQ.MAXCP6)Y(J)=TAGPLO(I) 2360C 2361 IF(NREPL.GE.1)THEN 2362 DO920IR=1,MIN(NREPL,6) 2363 ICOLC=ICOLC+1 2364 ICOLT=ICOLR(ICOLC) 2365 IJ=MAXN*(ICOLT-1)+I 2366 IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ) 2367 IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I) 2368 IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I) 2369 IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I) 2370 IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I) 2371 IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I) 2372 IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I) 2373 920 CONTINUE 2374 ENDIF 2375C 2376 910 CONTINUE 2377 NLOCAL=J 2378C 2379C ***************************************************** 2380C ** STEP 9B-- ** 2381C ** CALL DPSUM2 TO PERFORM SUMMARY. ** 2382C ***************************************************** 2383C 2384C 2385 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'SUMM')THEN 2386 ISTEPN='9C' 2387 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2388 WRITE(ICOUT,999) 2389 CALL DPWRST('XXX','BUG ') 2390 WRITE(ICOUT,941) 2391 941 FORMAT('***** FROM THE MIDDLE OF DPSUMM--') 2392 CALL DPWRST('XXX','BUG ') 2393 WRITE(ICOUT,942)ICASAN,NUMVAR,NLOCAL,NREPL 2394 942 FORMAT('ICASAN,NUMVAR,NLOCAL,NREPL = ', 2395 1 A4,3I8) 2396 CALL DPWRST('XXX','BUG ') 2397 IF(NLOCAL.GE.1)THEN 2398 DO945I=1,NLOCAL 2399 WRITE(ICOUT,946)I,Y(I),XDESGN(I,1),XDESGN(I,2) 2400 946 FORMAT('I,Y(I),XDESGN(I,1),XDESGN(I,2) = ', 2401 1 I8,4F12.5) 2402 CALL DPWRST('XXX','BUG ') 2403 945 CONTINUE 2404 ENDIF 2405 ENDIF 2406C 2407C ***************************************************** 2408C ** STEP 9C-- ** 2409C ** FIND THE DISTINCT VALUES IN EACH OF THE ** 2410C ** REPLICATION VARIABLES. ** 2411C ***************************************************** 2412C 2413 CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3), 2414 1 XDESGN(1,4),XDESGN(1,5),XDESGN(1,6), 2415 1 NREPL,NLOCAL,MAXOBV, 2416 1 XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6, 2417 1 XTEMP1,TEMP2, 2418 1 NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6, 2419 1 IBUGA3,ISUBRO,IERROR) 2420C 2421C ***************************************************** 2422C ** STEP 9D-- ** 2423C ** NOW LOOP THROUGH THE VARIOUS REPLICATIONS ** 2424C ***************************************************** 2425C 2426 NCURVE=0 2427 IADD=1 2428C 2429 IF(NREPL.EQ.1)THEN 2430 J=0 2431 DO1110ISET1=1,NUMSE1 2432 K=0 2433 PID(IADD+1)=XIDTEM(ISET1) 2434 DO1130I=1,NLOCAL 2435 IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN 2436 K=K+1 2437 TEMP1(K)=Y(I) 2438 ENDIF 2439 1130 CONTINUE 2440 NTEMP=K 2441 NCURVE=NCURVE+1 2442 IF(NTEMP.GT.0)THEN 2443 CALL DPSUM2(TEMP1,W,NTEMP,XTEMP1,XTEMP2,XTEMP3, 2444 1 DTEMP1,MAXNXT, 2445 1 ICAPSW,ICAPTY,IFORSW,ICASAN, 2446 1 PID,IVARN1,IVARN2,NREPL, 2447 1 ISUBRO,IBUGA3,IERROR) 2448 ENDIF 2449 1110 CONTINUE 2450 ELSEIF(NREPL.EQ.2)THEN 2451 J=0 2452 NTOT=NUMSE1*NUMSE2 2453 DO1210ISET1=1,NUMSE1 2454 DO1220ISET2=1,NUMSE2 2455 K=0 2456 PID(1+IADD)=XIDTEM(ISET1) 2457 PID(2+IADD)=XIDTE2(ISET2) 2458 DO1290I=1,NLOCAL 2459 IF( 2460 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 2461 1 XIDTE2(ISET2).EQ.XDESGN(I,2) 2462 1 )THEN 2463 K=K+1 2464 TEMP1(K)=Y(I) 2465 ENDIF 2466 1290 CONTINUE 2467 NTEMP=K 2468 NCURVE=NCURVE+1 2469 IF(NTEMP.GT.0)THEN 2470 CALL DPSUM2(TEMP1,W,NTEMP,XTEMP1,XTEMP2,XTEMP3, 2471 1 DTEMP1,MAXNXT, 2472 1 ICAPSW,ICAPTY,IFORSW,ICASAN, 2473 1 PID,IVARN1,IVARN2,NREPL, 2474 1 ISUBRO,IBUGA3,IERROR) 2475 ENDIF 2476 1220 CONTINUE 2477 1210 CONTINUE 2478 ELSEIF(NREPL.EQ.3)THEN 2479 J=0 2480 NTOT=NUMSE1*NUMSE2*NUMSE3 2481 DO1310ISET1=1,NUMSE1 2482 DO1320ISET2=1,NUMSE2 2483 DO1330ISET3=1,NUMSE3 2484 K=0 2485 PID(1+IADD)=XIDTEM(ISET1) 2486 PID(2+IADD)=XIDTE2(ISET2) 2487 PID(3+IADD)=XIDTE3(ISET3) 2488 DO1390I=1,NLOCAL 2489 IF( 2490 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 2491 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 2492 1 XIDTE3(ISET3).EQ.XDESGN(I,3) 2493 1 )THEN 2494 K=K+1 2495 TEMP1(K)=Y(I) 2496 ENDIF 2497 1390 CONTINUE 2498 NTEMP=K 2499 NCURVE=NCURVE+1 2500 NPLOT1=NPLOTP 2501 IF(NTEMP.GT.0)THEN 2502 CALL DPSUM2(TEMP1,W,NTEMP,XTEMP1,XTEMP2,XTEMP3, 2503 1 DTEMP1,MAXNXT, 2504 1 ICAPSW,ICAPTY,IFORSW,ICASAN, 2505 1 PID,IVARN1,IVARN2,NREPL, 2506 1 ISUBRO,IBUGA3,IERROR) 2507 ENDIF 2508 1330 CONTINUE 2509 1320 CONTINUE 2510 1310 CONTINUE 2511 ELSEIF(NREPL.EQ.4)THEN 2512 J=0 2513 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4 2514 DO1410ISET1=1,NUMSE1 2515 DO1420ISET2=1,NUMSE2 2516 DO1430ISET3=1,NUMSE3 2517 DO1440ISET4=1,NUMSE4 2518 K=0 2519 PID(1+IADD)=XIDTEM(ISET1) 2520 PID(2+IADD)=XIDTE2(ISET2) 2521 PID(3+IADD)=XIDTE3(ISET3) 2522 PID(4+IADD)=XIDTE4(ISET4) 2523 DO1490I=1,NLOCAL 2524 IF( 2525 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 2526 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 2527 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 2528 1 XIDTE4(ISET4).EQ.XDESGN(I,4) 2529 1 )THEN 2530 K=K+1 2531 TEMP1(K)=Y(I) 2532 ENDIF 2533 1490 CONTINUE 2534 NTEMP=K 2535 NCURVE=NCURVE+1 2536 NPLOT1=NPLOTP 2537 IF(NTEMP.GT.0)THEN 2538 CALL DPSUM2(TEMP1,W,NTEMP,XTEMP1,XTEMP2,XTEMP3, 2539 1 DTEMP1,MAXNXT, 2540 1 ICAPSW,ICAPTY,IFORSW,ICASAN, 2541 1 PID,IVARN1,IVARN2,NREPL, 2542 1 ISUBRO,IBUGA3,IERROR) 2543 ENDIF 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)=Y(I) 2572 ENDIF 2573 1590 CONTINUE 2574 NTEMP=K 2575 NCURVE=NCURVE+1 2576 NPLOT1=NPLOTP 2577 IF(NTEMP.GT.0)THEN 2578 CALL DPSUM2(TEMP1,W,NTEMP,XTEMP1,XTEMP2,XTEMP3, 2579 1 DTEMP1,MAXNXT, 2580 1 ICAPSW,ICAPTY,IFORSW,ICASAN, 2581 1 PID,IVARN1,IVARN2,NREPL, 2582 1 ISUBRO,IBUGA3,IERROR) 2583 ENDIF 2584 1550 CONTINUE 2585 1540 CONTINUE 2586 1530 CONTINUE 2587 1520 CONTINUE 2588 1510 CONTINUE 2589 ELSEIF(NREPL.EQ.6)THEN 2590 J=0 2591 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6 2592 DO1610ISET1=1,NUMSE1 2593 DO1620ISET2=1,NUMSE2 2594 DO1630ISET3=1,NUMSE3 2595 DO1640ISET4=1,NUMSE4 2596 DO1650ISET5=1,NUMSE5 2597 DO1660ISET6=1,NUMSE6 2598 K=0 2599 PID(1+IADD)=XIDTEM(ISET1) 2600 PID(2+IADD)=XIDTE2(ISET2) 2601 PID(3+IADD)=XIDTE3(ISET3) 2602 PID(4+IADD)=XIDTE4(ISET4) 2603 PID(5+IADD)=XIDTE5(ISET4) 2604 PID(6+IADD)=XIDTE6(ISET4) 2605 DO1690I=1,NLOCAL 2606 IF( 2607 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 2608 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 2609 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 2610 1 XIDTE4(ISET4).EQ.XDESGN(I,4) .AND. 2611 1 XIDTE5(ISET5).EQ.XDESGN(I,5) .AND. 2612 1 XIDTE6(ISET6).EQ.XDESGN(I,6) 2613 1 )THEN 2614 K=K+1 2615 TEMP1(K)=Y(I) 2616 ENDIF 2617 1690 CONTINUE 2618 NTEMP=K 2619 NCURVE=NCURVE+1 2620 NPLOT1=NPLOTP 2621 IF(NTEMP.GT.0)THEN 2622 CALL DPSUM2(TEMP1,W,NTEMP,XTEMP1,XTEMP2,XTEMP3, 2623 1 DTEMP1,MAXNXT, 2624 1 ICAPSW,ICAPTY,IFORSW,ICASAN, 2625 1 PID,IVARN1,IVARN2,NREPL, 2626 1 ISUBRO,IBUGA3,IERROR) 2627 ENDIF 2628 1660 CONTINUE 2629 1650 CONTINUE 2630 1640 CONTINUE 2631 1630 CONTINUE 2632 1620 CONTINUE 2633 1610 CONTINUE 2634 ENDIF 2635C 2636 ENDIF 2637C 2638C ***************** 2639C ** STEP 90-- ** 2640C ** EXIT ** 2641C ***************** 2642C 2643 9000 CONTINUE 2644C 2645 IF(IERROR.EQ.'YES')THEN 2646 IF(IWIDTH.GE.1)THEN 2647 WRITE(ICOUT,9001)(IANS(I),I=1,MIN(100,IWIDTH)) 2648 9001 FORMAT(100A1) 2649 CALL DPWRST('XXX','BUG ') 2650 ENDIF 2651 ENDIF 2652C 2653 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'SUMM')THEN 2654 WRITE(ICOUT,999) 2655 CALL DPWRST('XXX','BUG ') 2656 WRITE(ICOUT,9011) 2657 9011 FORMAT('***** AT THE END OF DPSUMM--') 2658 CALL DPWRST('XXX','BUG ') 2659 WRITE(ICOUT,9012)IFOUND,IERROR,ICASAN 2660 9012 FORMAT('IFOUND,IERROR,ICASAN = ',2(A4,2X),A4) 2661 CALL DPWRST('XXX','BUG ') 2662 ENDIF 2663C 2664 RETURN 2665 END 2666 SUBROUTINE DPSWAP(IOP3,NUMNAM,IHNAME,IHNAM2,IUSE,IN, 2667 1IVALUE,MAXN2,MAXCO2,MAXIJ2,IBUGS2,ISUBRO,IERROR) 2668CCCCC SUBROUTINE DPSWAP(IOP3,V,NUMNAM,IHNAME,IHNAM2,IUSE,IN, 2669CCCCC1IVALUE,MAXN,MAXCOL,MAXN2,MAXCO2,MAXIJ2,IBUGS2,ISUBRO,IERROR) 2670C 2671C PURPOSE--SWAP (WRITE OUT OR READ IN) THE VECTOR V(.) 2672C FROM MASS STORAGE. 2673C WRITTEN BY--JAMES J. FILLIBEN 2674C STATISTICAL ENGINEERING DIVISION 2675C INFORMATION TECHNOLOGY LABORATORY 2676C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 2677C GAITHERSBURG, MD 20899-8980 2678C PHONE--301-975-2899 2679C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 2680C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 2681C LANGUAGE--ANSI FORTRAN (1977) 2682C VERSION NUMBER--86/1 2683C ORIGINAL VERSION--MARCH 1981. 2684C UPDATED --JULY 1981. 2685C UPDATED --AUGUST 1981. 2686C UPDATED --NOVEMBER 1981. 2687C UPDATED --MARCH 1982. 2688C UPDATED --MAY 1982. 2689C UPDATED --JANUARY 1986. 2690C UPDATED --OCTOBER 1991. SUN HAS LIMIT ON NUMBER OF WORDS 2691C THAT CAN BE WRITTEN (ALAN) 2692C 2693C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 2694C 2695 CHARACTER*4 IOP3 2696 CHARACTER*4 IHNAME(*) 2697 CHARACTER*4 IHNAM2(*) 2698 CHARACTER*4 IUSE 2699 CHARACTER*4 IBUGS2 2700 CHARACTER*4 ISUBRO 2701 CHARACTER*4 IERROR 2702C 2703 INCLUDE 'DPCOPA.INC' 2704C 2705CCCCC CHARACTER*80 IFILE 2706 CHARACTER (LEN=MAXFNC) :: IFILE 2707 CHARACTER*12 ISTAT 2708 CHARACTER*12 IFORM 2709 CHARACTER*12 IACCES 2710 CHARACTER*12 IPROT 2711 CHARACTER*12 ICURST 2712 CHARACTER*4 IENDFI 2713 CHARACTER*4 IREWIN 2714 CHARACTER*4 ISUBN0 2715 CHARACTER*4 IERRFI 2716C 2717CCCCC CHARACTER*4 IFOUND 2718C 2719 CHARACTER*4 ISTEPN 2720 CHARACTER*4 ISUBN1 2721 CHARACTER*4 ISUBN2 2722C 2723 INCLUDE 'DPCODA.INC' 2724CCCCC DIMENSION V(*) 2725 DIMENSION IUSE(*) 2726 DIMENSION IN(*) 2727 DIMENSION IVALUE(*) 2728C 2729C-----COMMON---------------------------------------------------------- 2730C 2731 INCLUDE 'DPCOFO.INC' 2732 INCLUDE 'DPCOF2.INC' 2733C FOLLOWING LINE ADDED OCTOBER 1991. 2734 INCLUDE 'DPCOHO.INC' 2735 INCLUDE 'DPCOP2.INC' 2736C 2737C-----START POINT----------------------------------------------------- 2738C 2739 ISUBN1='DPSW' 2740 ISUBN2='AP ' 2741 ISUBN0='SWAP' 2742 IERROR='NO' 2743C 2744 IWIDTH=(-999) 2745C 2746 IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SWAP')GOTO90 2747 WRITE(ICOUT,999) 2748 999 FORMAT(1X) 2749 CALL DPWRST('XXX','BUG ') 2750 WRITE(ICOUT,51) 2751 51 FORMAT('***** AT THE BEGINNING OF DPSWAP--') 2752 CALL DPWRST('XXX','BUG ') 2753 WRITE(ICOUT,53)IBUGS2,IOP3 2754 53 FORMAT('IBUGS2,IOP3 = ',A4,2X,A4) 2755 CALL DPWRST('XXX','BUG ') 2756 WRITE(ICOUT,54)V(1),V(2),V(3) 2757 54 FORMAT('V(1),V(2),V(3) = ',3E15.7) 2758 CALL DPWRST('XXX','BUG ') 2759 WRITE(ICOUT,55)NUMNAM,MAXN,MAXCOL 2760 55 FORMAT('NUMNAM,MAXN,MAXCOL = ',3I8) 2761 CALL DPWRST('XXX','BUG ') 2762 WRITE(ICOUT,71)ISCRNU 2763 71 FORMAT('ISCRNU = ',I8) 2764 CALL DPWRST('XXX','BUG ') 2765 WRITE(ICOUT,72)ISCRNA(1:80) 2766 72 FORMAT('ISCRNA = ',A80) 2767 CALL DPWRST('XXX','BUG ') 2768 WRITE(ICOUT,73)ISCRST 2769 73 FORMAT('ISCRST = ',A12) 2770 CALL DPWRST('XXX','BUG ') 2771 WRITE(ICOUT,74)ISCRFO 2772 74 FORMAT('ISCRFO = ',A12) 2773 CALL DPWRST('XXX','BUG ') 2774 WRITE(ICOUT,75)ISCRAC 2775 75 FORMAT('ISCRAC = ',A12) 2776 CALL DPWRST('XXX','BUG ') 2777 WRITE(ICOUT,76)ISCRFO 2778 76 FORMAT('ISCRFO = ',A12) 2779 CALL DPWRST('XXX','BUG ') 2780 WRITE(ICOUT,77)ISCRCS 2781 77 FORMAT('ISCRCS = ',A12) 2782 CALL DPWRST('XXX','BUG ') 2783 90 CONTINUE 2784C 2785C ************************** 2786C ** STEP 11-- ** 2787C ** COPY OVER VARIABLES ** 2788C ************************** 2789C 2790 ISTEPN='11' 2791 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWAP') 2792 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2793C 2794 IOUNIT=ISCRNU 2795 IFILE=ISCRNA 2796 ISTAT=ISCRST 2797 IFORM=ISCRFO 2798 IACCES=ISCRAC 2799 IPROT=ISCRPR 2800 ICURST=ISCRCS 2801C 2802 ISUBN0='SWAP' 2803 IERRFI='NO' 2804C 2805 IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SWAP')GOTO1199 2806 WRITE(ICOUT,1193)IOUNIT 2807 1193 FORMAT('IOUNIT = ',I8) 2808 CALL DPWRST('XXX','BUG ') 2809 WRITE(ICOUT,1194)IFILE(1:80) 2810 1194 FORMAT('IFILE = ',A80) 2811 CALL DPWRST('XXX','BUG ') 2812 WRITE(ICOUT,1195)ISTAT,IFORM,IACCES,IPROT,ICURST 2813 1195 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ', 2814 1A12,2X,A12,2X,A12,2X,A12,2X,A12) 2815 CALL DPWRST('XXX','BUG ') 2816 WRITE(ICOUT,1196)ISUBN0,IERRFI 2817 1196 FORMAT('ISUBN0,IERRFI = ',A4,2X,A4) 2818 CALL DPWRST('XXX','BUG ') 2819 1199 CONTINUE 2820C 2821C ********************************************** 2822C ** STEP 12-- ** 2823C ** CHECK TO SEE IF SCRATCH FILE MAY EXIST ** 2824C ********************************************** 2825C 2826 ISTEPN='12' 2827 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWAP') 2828 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2829C 2830 IF(ISTAT.EQ.'NONE')GOTO1200 2831 GOTO1290 2832 1200 CONTINUE 2833 IERROR='YES' 2834 WRITE(ICOUT,999) 2835 CALL DPWRST('XXX','BUG ') 2836 WRITE(ICOUT,1211) 2837 1211 FORMAT('***** IMPLEMENTATION ERROR IN DPSWAP--') 2838 CALL DPWRST('XXX','BUG ') 2839 WRITE(ICOUT,1212) 2840 1212 FORMAT(' THE DESIRED FIT REQUIRES THE ') 2841 CALL DPWRST('XXX','BUG ') 2842 WRITE(ICOUT,1213) 2843 1213 FORMAT(' BEHIND-THE-SCENES USE OF A SCRATCH FILE;') 2844 CALL DPWRST('XXX','BUG ') 2845 WRITE(ICOUT,1214) 2846 1214 FORMAT(' BUT THE USE OF SUCH A SCRATCH FILE ') 2847 CALL DPWRST('XXX','BUG ') 2848 WRITE(ICOUT,1215) 2849 1215 FORMAT(' CANNOT BE DONE BECAUSE') 2850 CALL DPWRST('XXX','BUG ') 2851 WRITE(ICOUT,1216) 2852 1216 FORMAT(' THE INTERNAL VARIABLE ISCRST ') 2853 CALL DPWRST('XXX','BUG ') 2854 WRITE(ICOUT,1217) 2855 1217 FORMAT(' WHICH ALLOWS SUCH SCRATCH FILE USE') 2856 CALL DPWRST('XXX','BUG ') 2857 WRITE(ICOUT,1218) 2858 1218 FORMAT(' HAS BEEN SET TO NONE.') 2859 CALL DPWRST('XXX','BUG ') 2860 WRITE(ICOUT,1219)ISTAT,ISCRST 2861 1219 FORMAT('ISTAT,ISCRST = ',A12,2X,A12) 2862 CALL DPWRST('XXX','BUG ') 2863 WRITE(ICOUT,1220) 2864 1220 FORMAT(' PLEASE CONTACT THE DATAPLOT IMPLEMENTOR') 2865 CALL DPWRST('XXX','BUG ') 2866 WRITE(ICOUT,1221) 2867 1221 FORMAT(' AND HAVE THE ISCRST SETTING CHANGED') 2868 CALL DPWRST('XXX','BUG ') 2869 WRITE(ICOUT,1222) 2870 1222 FORMAT(' (FROM NONE TO UNKNOWN)') 2871 CALL DPWRST('XXX','BUG ') 2872 WRITE(ICOUT,1223) 2873 1223 FORMAT(' IN SUBROUTINE INITFO.') 2874 CALL DPWRST('XXX','BUG ') 2875 GOTO9000 2876 1290 CONTINUE 2877C 2878C ***************************************** 2879C ** STEP 20-- ** 2880C ** BRANCH TO THE APPROPRIATE CASE-- ** 2881C ** 1) WRITE OUT TO MASS STORGE; ** 2882C ** 2) READ IN FROM MASS STORAGE. ** 2883C ***************************************** 2884C 2885 ISTEPN='20' 2886 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWAP') 2887 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2888C 2889 IF(IOP3.EQ.'WRIT')GOTO2100 2890 GOTO2200 2891C 2892C ****************************************** 2893C ** STEP 21-- ** 2894C ** WRITE THE V(.) VECTOR ** 2895C ** OUT TO THE MASS STORAGE FILE ** 2896C ** WITH NUMERIC DESIGNATION ISCRNU ** 2897C ****************************************** 2898C 2899 2100 CONTINUE 2900 ISTEPN='21' 2901 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWAP') 2902 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2903C 2904 MAXN2=0 2905 MAXCO2=0 2906 MAXIJ2=0 2907C 2908 IF(NUMNAM.LE.0)GOTO2129 2909 DO2110J=1,NUMNAM 2910 IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SWAP')GOTO2119 2911 WRITE(ICOUT,2111)J,IHNAME(J),IHNAM2(J),IUSE(J),IN(J),IVALUE(J) 2912 2111 FORMAT('J,IHNAME(J),IHNAM2(J),ISE(J),IN(J),IVALUE(J) = ', 2913 1I8,2X,A4,2X,A4,2X,A4,I8,I8) 2914 CALL DPWRST('XXX','BUG ') 2915 2119 CONTINUE 2916 IF(IHNAME(J).EQ.'PRED'.AND.IHNAM2(J).EQ.' ')GOTO2110 2917 IF(IHNAME(J).EQ.'RES '.AND.IHNAM2(J).EQ.' ')GOTO2110 2918 IF(IUSE(J).EQ.'V')GOTO2115 2919 GOTO2110 2920 2115 CONTINUE 2921 IROW=IN(J) 2922 ICOL=IVALUE(J) 2923 IF(ICOL.GT.MAXCOL)GOTO2110 2924 IF(IROW.GT.MAXN2)MAXN2=IROW 2925 IF(ICOL.GT.MAXCO2)MAXCO2=ICOL 2926 2110 CONTINUE 2927 2129 CONTINUE 2928C 2929 MAXIJ2=MAXN*(MAXCO2-1)+MAXN2 2930 IF(MAXIJ2.LE.0)GOTO9000 2931C 2932 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWAP') 2933 1WRITE(ICOUT,999) 2934 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWAP') 2935 1CALL DPWRST('XXX','BUG ') 2936 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWAP') 2937 1WRITE(ICOUT,2191) 2938 2191 FORMAT('***** A SWAP OUT IS ABOUT TO BE EXECUTED.') 2939 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWAP') 2940 1CALL DPWRST('XXX','BUG ') 2941C 2942 IDEV='SCRA' 2943C 2944 IREWIN='ON' 2945 CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 2946 1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 2947 IF(IERRFI.EQ.'YES')GOTO9000 2948C 2949CCCCC IF(MAXIJ2.GE.1)WRITE(IOUNIT)(V(IJ),IJ=1,MAXIJ2) 2950C 2951C OCTOBER 1991. SUN HAS LIMIT (SEEMS TO BE 2,046 WORDS) ON NUMBER OF 2952C WORDS THAT CAN BE WRITTEN IN ONE RECORD. ABOVE LINE REPLACED WITH 2953C FOLLOWING BLOCK OF CODE. 2954C 2955C MAY 2009. ABOVE ISSUE IS NO LONGER A PROBLEM. HOWEVER, WITH THE 2956C LARGER DATA SET SIZE NOW SUPPORTED BY DATAPLOT, THIS ROUTINE 2957C IS BECOMING A BIT OF A POTENTIAL BOTTLE NECK. SPECIFICALLY, 2958C 2959C 1) IF WE USE 2960C 2961C WRITE(IOUNT)V 2962C 2963C WE DECREASE THE CPU TIME USED. HOWEVER, IT INCREASES 2964C THE WALL CLOCK TIME (WRITING 10,0000,0000 VALUES AT 2965C ONE TIME PROBABLY INCREASES "SWAPPING" ISSUES). 2966C 2967C 2) IF WE USE 2968C 2969C WRITE(IOUNT)(V(IJ),IJ=1,MAXIJ2) 2970C 2971C WE GREATLY INCREASE THE CPU TIME. 2972C 2973C FOR NOW, I WILL WRITE OUT IN CHUNKS OF 10,000 (THIS WILL BE 2974C SET IN MAXWRD). 2975C 2976 IF(MAXIJ2.GE.1)THEN 2977CCCCC WRITE(IOUNIT)(V(IJ),IJ=1,MAXIJ2) 2978CCCCC WRITE(IOUNIT)V 2979C 2980CCCCC MAXWRD=100000 2981CCCCC MAXWRD=1000000 2982CCCCC IF(IHOST1.EQ.'SUN')MAXWRD=2046 2983 MAXWRD=10000 2984 IF(MAXWRD.EQ.MAXOBW)THEN 2985 WRITE(IOUNIT)V 2986 GOTO2199 2987 ENDIF 2988 NLOOPF=(MAXIJ2/MAXWRD)+1 2989 IF(NLOOPF.LT.1)GOTO2197 2990 DO2192IK=1,NLOOPF 2991 JSTART=(IK-1)*MAXWRD+1 2992 IF(JSTART.GT.MAXIJ2)GOTO2197 2993 JSTOP=IK*MAXWRD 2994 IF(JSTOP.GT.MAXIJ2)JSTOP=MAXIJ2 2995 WRITE(IOUNIT) (V(IJ),IJ=JSTART,JSTOP) 2996 2192 CONTINUE 2997 2197 CONTINUE 2998 2199 CONTINUE 2999C 3000 ENDIF 3001C END CHANGE 3002C 3003 IENDFI='OFF' 3004 IREWIN='ON' 3005 CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 3006 1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 3007C 3008 GOTO9000 3009C 3010C ****************************************** 3011C ** STEP 22-- ** 3012C ** READ THE V(.) VECTOR ** 3013C ** IN FROM THE MASS STORAGE FILE ** 3014C ** WITH NUMERIC DESIGNATION ISCRNU ** 3015C ****************************************** 3016C 3017 2200 CONTINUE 3018 ISTEPN='22' 3019 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWAP') 3020 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3021C 3022 IF(MAXIJ2.LE.0)GOTO9000 3023C 3024 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWAP') 3025 1WRITE(ICOUT,999) 3026 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWAP') 3027 1CALL DPWRST('XXX','BUG ') 3028 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWAP') 3029 1WRITE(ICOUT,2291) 3030 2291 FORMAT('***** A SWAP IN IS ABOUT TO BE EXECUTED.') 3031 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWAP') 3032 1CALL DPWRST('XXX','BUG ') 3033C 3034 IDEV='SCRA' 3035C 3036 IREWIN='ON' 3037 CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 3038 1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 3039 IF(IERRFI.EQ.'YES')GOTO9000 3040C 3041CCCCC IF(MAXIJ2.GE.1)READ(IOUNIT)(V(IJ),IJ=1,MAXIJ2) 3042C 3043C OCTOBER 1991. SUN HAS LIMIT (SEEMS TO BE 2,046 WORDS) ON NUMBER OF 3044C WORDS THAT CAN BE WRITTEN IN ONE RECORD. ABOVE LINE REPLACED WITH 3045C FOLLOWING BLOCK OF CODE. 3046C 3047C MAY 2009. SEE COMMENTS ABOVE FOR WRITE CASE. 3048C 3049 IF(MAXIJ2.GE.1)THEN 3050CCCCC READ(IOUNIT)(V(IJ),IJ=1,MAXIJ2) 3051CCCCC READ(IOUNIT)V 3052CCCCC MAXWRD=100000 3053CCCCC MAXWRD=1000000 3054CCCCC IF(IHOST1.EQ.'SUN')MAXWRD=2046 3055 MAXWRD=10000 3056 IF(MAXWRD.EQ.MAXOBW)THEN 3057 READ(IOUNIT)V 3058 GOTO2299 3059 ENDIF 3060 NLOOPF=(MAXIJ2/MAXWRD)+1 3061 IF(NLOOPF.LT.1)GOTO2297 3062 DO2292IK=1,NLOOPF 3063 JSTART=(IK-1)*MAXWRD+1 3064 IF(JSTART.GT.MAXIJ2)GOTO2297 3065 JSTOP=IK*MAXWRD 3066 IF(JSTOP.GT.MAXIJ2)JSTOP=MAXIJ2 3067 READ(IOUNIT) (V(IJ),IJ=JSTART,JSTOP) 3068 2292 CONTINUE 3069 2297 CONTINUE 3070 2299 CONTINUE 3071 ENDIF 3072C END CHANGE 3073C 3074 IENDFI='OFF' 3075 IREWIN='ON' 3076 CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 3077 1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 3078C 3079 GOTO9000 3080C 3081C ***************** 3082C ** STEP 90-- ** 3083C ** EXIT. ** 3084C ***************** 3085C 3086 9000 CONTINUE 3087 IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SWAP')GOTO9090 3088 WRITE(ICOUT,999) 3089 CALL DPWRST('XXX','BUG ') 3090 WRITE(ICOUT,9011) 3091 9011 FORMAT('***** AT THE END OF DPSWAP--') 3092 CALL DPWRST('XXX','BUG ') 3093 WRITE(ICOUT,9013)IBUGS2,IOP3 3094 9013 FORMAT('IBUGS2,IOP3 = ',A4,2X,A4) 3095 CALL DPWRST('XXX','BUG ') 3096 WRITE(ICOUT,9014)MAXN2,MAXCO2,MAXIJ2 3097 9014 FORMAT('MAXN2,MAXCO2,MAXIJ2 = ',3I8) 3098 CALL DPWRST('XXX','BUG ') 3099 WRITE(ICOUT,9019)IBUGS2,ISUBRO,IERROR 3100 9019 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) 3101 CALL DPWRST('XXX','BUG ') 3102 WRITE(ICOUT,9021)IOUNIT 3103 9021 FORMAT('IOUNIT = ',I8) 3104 CALL DPWRST('XXX','BUG ') 3105 WRITE(ICOUT,9022)IFILE 3106 9022 FORMAT('IFILE = ',A80) 3107 CALL DPWRST('XXX','BUG ') 3108 WRITE(ICOUT,9023)ISTAT 3109 9023 FORMAT('ISTAT = ',A12) 3110 CALL DPWRST('XXX','BUG ') 3111 WRITE(ICOUT,9024)IFORM 3112 9024 FORMAT('IFORM = ',A12) 3113 CALL DPWRST('XXX','BUG ') 3114 WRITE(ICOUT,9025)IACCES 3115 9025 FORMAT('IACCES = ',A12) 3116 CALL DPWRST('XXX','BUG ') 3117 WRITE(ICOUT,9026)IPROT 3118 9026 FORMAT('IPROT = ',A12) 3119 CALL DPWRST('XXX','BUG ') 3120 WRITE(ICOUT,9027)ICURST 3121 9027 FORMAT('ICURST = ',A12) 3122 CALL DPWRST('XXX','BUG ') 3123 WRITE(ICOUT,9028)IENDFI 3124 9028 FORMAT('IENDFI = ',A4) 3125 CALL DPWRST('XXX','BUG ') 3126 WRITE(ICOUT,9029)IREWIN 3127 9029 FORMAT('IREWIN = ',A4) 3128 CALL DPWRST('XXX','BUG ') 3129 WRITE(ICOUT,9031)ISUBN0 3130 9031 FORMAT('ISUBN0 = ',A12) 3131 CALL DPWRST('XXX','BUG ') 3132 WRITE(ICOUT,9032)IERRFI 3133 9032 FORMAT('IERRFI = ',A12) 3134 CALL DPWRST('XXX','BUG ') 3135 9090 CONTINUE 3136C 3137 RETURN 3138 END 3139 SUBROUTINE DPSWA2(IOP3,IFILE,V,MAXIJ2,IBUGS2,ISUBRO,IERROR) 3140C 3141C PURPOSE--SWAP (WRITE OUT OR READ IN) THE VECTOR V(.) 3142C FROM MASS STORAGE. 3143C THIS IS A VARIATION OF DPSWAP. THE DIFFERENCE 3144C IS THAT THIS READS/WRITES AN ARBITRARY MATRIX, 3145C NOT NECCESSARILY THE INTERNAL V MATRIX, WITH 3146C MAXIJ2 DEFINING THE NUMBER OF VALUES TO READ/WRITE. 3147C WRITTEN BY--JAMES J. FILLIBEN 3148C STATISTICAL ENGINEERING DIVISION 3149C INFORMATION TECHNOLOGY LABORATORY 3150C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 3151C GAITHERSBURG, MD 20899-8980 3152C PHONE--301-975-2899 3153C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 3154C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 3155C LANGUAGE--ANSI FORTRAN (1977) 3156C VERSION NUMBER--97/8 3157C ORIGINAL VERSION--AUGUST 1997. 3158C 3159C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 3160C 3161 CHARACTER*4 IOP3 3162 CHARACTER*4 IBUGS2 3163 CHARACTER*4 ISUBRO 3164 CHARACTER*4 IERROR 3165C 3166 INCLUDE 'DPCOPA.INC' 3167C 3168CCCCC CHARACTER*80 IFILE 3169 CHARACTER (LEN=MAXFNC) :: IFILE 3170 CHARACTER*12 ISTAT 3171 CHARACTER*12 IFORM 3172 CHARACTER*12 IACCES 3173 CHARACTER*12 IPROT 3174 CHARACTER*12 ICURST 3175 CHARACTER*4 IENDFI 3176 CHARACTER*4 IREWIN 3177 CHARACTER*4 ISUBN0 3178 CHARACTER*4 IERRFI 3179C 3180 CHARACTER*4 ISTEPN 3181 CHARACTER*4 ISUBN1 3182 CHARACTER*4 ISUBN2 3183C 3184 DOUBLE PRECISION V(*) 3185C 3186C-----COMMON---------------------------------------------------------- 3187C 3188 INCLUDE 'DPCOFO.INC' 3189 INCLUDE 'DPCOF2.INC' 3190 INCLUDE 'DPCOHO.INC' 3191 INCLUDE 'DPCOP2.INC' 3192C 3193C-----START POINT----------------------------------------------------- 3194C 3195 ISUBN1='DPSW' 3196 ISUBN2='A2 ' 3197 ISUBN0='SWA2' 3198 IERROR='NO' 3199 IWIDTH=(-999) 3200C 3201 IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SWA2')GOTO90 3202 WRITE(ICOUT,999) 3203 999 FORMAT(1X) 3204 CALL DPWRST('XXX','BUG ') 3205 WRITE(ICOUT,51) 3206 51 FORMAT('***** AT THE BEGINNING OF DPSWA2--') 3207 CALL DPWRST('XXX','BUG ') 3208 WRITE(ICOUT,53)IBUGS2,IOP3 3209 53 FORMAT('IBUGS2,IOP3 = ',A4,2X,A4) 3210 CALL DPWRST('XXX','BUG ') 3211 WRITE(ICOUT,54)V(1),V(2),V(3) 3212 54 FORMAT('V(1),V(2),V(3) = ',3E15.7) 3213 CALL DPWRST('XXX','BUG ') 3214 WRITE(ICOUT,71)ISCRNU 3215 71 FORMAT('ISCRNU = ',I8) 3216 CALL DPWRST('XXX','BUG ') 3217 WRITE(ICOUT,72)ISCRNA(1:80) 3218 72 FORMAT('ISCRNA = ',A80) 3219 CALL DPWRST('XXX','BUG ') 3220 WRITE(ICOUT,73)ISCRST 3221 73 FORMAT('ISCRST = ',A12) 3222 CALL DPWRST('XXX','BUG ') 3223 WRITE(ICOUT,74)ISCRFO 3224 74 FORMAT('ISCRFO = ',A12) 3225 CALL DPWRST('XXX','BUG ') 3226 WRITE(ICOUT,75)ISCRAC 3227 75 FORMAT('ISCRAC = ',A12) 3228 CALL DPWRST('XXX','BUG ') 3229 WRITE(ICOUT,76)ISCRFO 3230 76 FORMAT('ISCRFO = ',A12) 3231 CALL DPWRST('XXX','BUG ') 3232 WRITE(ICOUT,77)ISCRCS 3233 77 FORMAT('ISCRCS = ',A12) 3234 CALL DPWRST('XXX','BUG ') 3235 90 CONTINUE 3236C 3237C ************************** 3238C ** STEP 11-- ** 3239C ** COPY OVER VARIABLES ** 3240C ************************** 3241C 3242 ISTEPN='11' 3243 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWA2') 3244 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3245C 3246 IOUNIT=ISCRNU 3247CCCCC PASS IN FILE NAME, RECIPE CODE USES MULTIPLE SCRATCH FILES. 3248CCCCC IFILE=ISCRNA 3249 ISTAT=ISCRST 3250 IFORM=ISCRFO 3251 IACCES=ISCRAC 3252 IPROT=ISCRPR 3253 ICURST=ISCRCS 3254C 3255 ISUBN0='SWA2' 3256 IERRFI='NO' 3257C 3258 IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SWA2')GOTO1199 3259 WRITE(ICOUT,1193)IOUNIT 3260 1193 FORMAT('IOUNIT = ',I8) 3261 CALL DPWRST('XXX','BUG ') 3262 WRITE(ICOUT,1194)IFILE 3263 1194 FORMAT('IFILE = ',A80) 3264 CALL DPWRST('XXX','BUG ') 3265 WRITE(ICOUT,1195)ISTAT,IFORM,IACCES,IPROT,ICURST 3266 1195 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ', 3267 1A12,2X,A12,2X,A12,2X,A12,2X,A12) 3268 CALL DPWRST('XXX','BUG ') 3269 WRITE(ICOUT,1196)ISUBN0,IERRFI 3270 1196 FORMAT('ISUBN0,IERRFI = ',A4,2X,A4) 3271 CALL DPWRST('XXX','BUG ') 3272 1199 CONTINUE 3273C 3274C ********************************************** 3275C ** STEP 12-- ** 3276C ** CHECK TO SEE IF SCRATCH FILE MAY EXIST ** 3277C ********************************************** 3278C 3279 ISTEPN='12' 3280 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWA2') 3281 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3282C 3283 IF(ISTAT.EQ.'NONE')GOTO1200 3284 GOTO1290 3285 1200 CONTINUE 3286 IERROR='YES' 3287 WRITE(ICOUT,999) 3288 CALL DPWRST('XXX','BUG ') 3289 WRITE(ICOUT,1211) 3290 1211 FORMAT('***** IMPLEMENTATION ERROR IN DPSWA2--') 3291 CALL DPWRST('XXX','BUG ') 3292 WRITE(ICOUT,1212) 3293 1212 FORMAT(' THE DESIRED RECIPE OPERATION REQUIRES THE ') 3294 CALL DPWRST('XXX','BUG ') 3295 WRITE(ICOUT,1213) 3296 1213 FORMAT(' BEHIND-THE-SCENES USE OF A SCRATCH FILE;') 3297 CALL DPWRST('XXX','BUG ') 3298 WRITE(ICOUT,1214) 3299 1214 FORMAT(' BUT THE USE OF SUCH A SCRATCH FILE ') 3300 CALL DPWRST('XXX','BUG ') 3301 WRITE(ICOUT,1215) 3302 1215 FORMAT(' CANNOT BE DONE BECAUSE') 3303 CALL DPWRST('XXX','BUG ') 3304 WRITE(ICOUT,1216) 3305 1216 FORMAT(' THE INTERNAL VARIABLE ISCRST ') 3306 CALL DPWRST('XXX','BUG ') 3307 WRITE(ICOUT,1217) 3308 1217 FORMAT(' WHICH ALLOWS SUCH SCRATCH FILE USE') 3309 CALL DPWRST('XXX','BUG ') 3310 WRITE(ICOUT,1218) 3311 1218 FORMAT(' HAS BEEN SET TO NONE.') 3312 CALL DPWRST('XXX','BUG ') 3313 WRITE(ICOUT,1219)ISTAT,ISCRST 3314 1219 FORMAT('ISTAT,ISCRST = ',A12,2X,A12) 3315 CALL DPWRST('XXX','BUG ') 3316 WRITE(ICOUT,1220) 3317 1220 FORMAT(' PLEASE CONTACT THE DATAPLOT IMPLEMENTOR') 3318 CALL DPWRST('XXX','BUG ') 3319 WRITE(ICOUT,1221) 3320 1221 FORMAT(' AND HAVE THE ISCRST SETTING CHANGED') 3321 CALL DPWRST('XXX','BUG ') 3322 WRITE(ICOUT,1222) 3323 1222 FORMAT(' (FROM NONE TO UNKNOWN)') 3324 CALL DPWRST('XXX','BUG ') 3325 WRITE(ICOUT,1223) 3326 1223 FORMAT(' IN SUBROUTINE INITFO.') 3327 CALL DPWRST('XXX','BUG ') 3328 GOTO9000 3329 1290 CONTINUE 3330C 3331C ***************************************** 3332C ** STEP 20-- ** 3333C ** BRANCH TO THE APPROPRIATE CASE-- ** 3334C ** 1) WRITE OUT TO MASS STORGE; ** 3335C ** 2) READ IN FROM MASS STORAGE. ** 3336C ***************************************** 3337C 3338 ISTEPN='20' 3339 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWA2') 3340 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3341C 3342 IF(IOP3.EQ.'WRIT')GOTO2100 3343 GOTO2200 3344C 3345C ****************************************** 3346C ** STEP 21-- ** 3347C ** WRITE THE V(.) VECTOR ** 3348C ** OUT TO THE MASS STORAGE FILE ** 3349C ** WITH NUMERIC DESIGNATION ISCRNU ** 3350C ****************************************** 3351C 3352 2100 CONTINUE 3353 ISTEPN='21' 3354 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWA2') 3355 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3356C 3357C 3358 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWA2') 3359 1WRITE(ICOUT,999) 3360 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWA2') 3361 1CALL DPWRST('XXX','BUG ') 3362 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWA2') 3363 1WRITE(ICOUT,2191) 3364 2191 FORMAT('***** A SWAP OUT IS ABOUT TO BE EXECUTED.') 3365 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWA2') 3366 1CALL DPWRST('XXX','BUG ') 3367C 3368 IDEV='SCRA' 3369C 3370 IREWIN='ON' 3371 CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 3372 1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 3373 IF(IERRFI.EQ.'YES')GOTO9000 3374C 3375 IF(MAXIJ2.LT.1)GOTO2199 3376 MAXWRD=100000 3377 IF(IHOST1.EQ.'SUN')MAXWRD=2046 3378 NLOOPF=(MAXIJ2/MAXWRD)+1 3379 IF(NLOOPF.LT.1)GOTO2197 3380 DO2192IK=1,NLOOPF 3381 JSTART=(IK-1)*MAXWRD+1 3382 IF(JSTART.GT.MAXIJ2)GOTO2197 3383 JSTOP=IK*MAXWRD 3384 IF(JSTOP.GT.MAXIJ2)JSTOP=MAXIJ2 3385 WRITE(IOUNIT) (V(IJ),IJ=JSTART,JSTOP) 3386 2192 CONTINUE 3387 2197 CONTINUE 3388 2199 CONTINUE 3389C END CHANGE 3390C 3391 IENDFI='OFF' 3392 IREWIN='ON' 3393 CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 3394 1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 3395C 3396 GOTO9000 3397C 3398C ****************************************** 3399C ** STEP 22-- ** 3400C ** READ THE V(.) VECTOR ** 3401C ** IN FROM THE MASS STORAGE FILE ** 3402C ** WITH NUMERIC DESIGNATION ISCRNU ** 3403C ****************************************** 3404C 3405 2200 CONTINUE 3406 ISTEPN='22' 3407 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWA2') 3408 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3409C 3410 IF(MAXIJ2.LE.0)GOTO9000 3411C 3412 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWA2') 3413 1WRITE(ICOUT,999) 3414 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWA2') 3415 1CALL DPWRST('XXX','BUG ') 3416 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWA2') 3417 1WRITE(ICOUT,2291) 3418 2291 FORMAT('***** A SWAP IN IS ABOUT TO BE EXECUTED.') 3419 IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SWA2') 3420 1CALL DPWRST('XXX','BUG ') 3421C 3422 IDEV='SCRA' 3423C 3424 IREWIN='ON' 3425 CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 3426 1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 3427 IF(IERRFI.EQ.'YES')GOTO9000 3428C 3429 IF(MAXIJ2.LT.1)GOTO2299 3430 MAXWRD=100000 3431 IF(IHOST1.EQ.'SUN')MAXWRD=2046 3432 NLOOPF=(MAXIJ2/MAXWRD)+1 3433 IF(NLOOPF.LT.1)GOTO2297 3434 DO2292IK=1,NLOOPF 3435 JSTART=(IK-1)*MAXWRD+1 3436 IF(JSTART.GT.MAXIJ2)GOTO2297 3437 JSTOP=IK*MAXWRD 3438 IF(JSTOP.GT.MAXIJ2)JSTOP=MAXIJ2 3439 READ(IOUNIT) (V(IJ),IJ=JSTART,JSTOP) 3440 2292 CONTINUE 3441 2297 CONTINUE 3442 2299 CONTINUE 3443C END CHANGE 3444C 3445 IENDFI='OFF' 3446 IREWIN='ON' 3447 CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 3448 1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) 3449C 3450 GOTO9000 3451C 3452C ***************** 3453C ** STEP 90-- ** 3454C ** EXIT. ** 3455C ***************** 3456C 3457 9000 CONTINUE 3458 IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'SWA2')GOTO9090 3459 WRITE(ICOUT,999) 3460 CALL DPWRST('XXX','BUG ') 3461 WRITE(ICOUT,9011) 3462 9011 FORMAT('***** AT THE END OF DPSWA2--') 3463 CALL DPWRST('XXX','BUG ') 3464 WRITE(ICOUT,9013)IBUGS2,IOP3 3465 9013 FORMAT('IBUGS2,IOP3 = ',A4,2X,A4) 3466 CALL DPWRST('XXX','BUG ') 3467 WRITE(ICOUT,9014)MAXIJ2 3468 9014 FORMAT('MAXIJ2 = ',I8) 3469 CALL DPWRST('XXX','BUG ') 3470 WRITE(ICOUT,9019)IBUGS2,ISUBRO,IERROR 3471 9019 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) 3472 CALL DPWRST('XXX','BUG ') 3473 WRITE(ICOUT,9021)IOUNIT 3474 9021 FORMAT('IOUNIT = ',I8) 3475 CALL DPWRST('XXX','BUG ') 3476 WRITE(ICOUT,9022)IFILE(1:80) 3477 9022 FORMAT('IFILE = ',A80) 3478 CALL DPWRST('XXX','BUG ') 3479 WRITE(ICOUT,9023)ISTAT 3480 9023 FORMAT('ISTAT = ',A12) 3481 CALL DPWRST('XXX','BUG ') 3482 WRITE(ICOUT,9024)IFORM 3483 9024 FORMAT('IFORM = ',A12) 3484 CALL DPWRST('XXX','BUG ') 3485 WRITE(ICOUT,9025)IACCES 3486 9025 FORMAT('IACCES = ',A12) 3487 CALL DPWRST('XXX','BUG ') 3488 WRITE(ICOUT,9026)IPROT 3489 9026 FORMAT('IPROT = ',A12) 3490 CALL DPWRST('XXX','BUG ') 3491 WRITE(ICOUT,9027)ICURST 3492 9027 FORMAT('ICURST = ',A12) 3493 CALL DPWRST('XXX','BUG ') 3494 WRITE(ICOUT,9028)IENDFI 3495 9028 FORMAT('IENDFI = ',A4) 3496 CALL DPWRST('XXX','BUG ') 3497 WRITE(ICOUT,9029)IREWIN 3498 9029 FORMAT('IREWIN = ',A4) 3499 CALL DPWRST('XXX','BUG ') 3500 WRITE(ICOUT,9031)ISUBN0 3501 9031 FORMAT('ISUBN0 = ',A12) 3502 CALL DPWRST('XXX','BUG ') 3503 WRITE(ICOUT,9032)IERRFI 3504 9032 FORMAT('IERRFI = ',A12) 3505 CALL DPWRST('XXX','BUG ') 3506 9090 CONTINUE 3507C 3508 RETURN 3509 END 3510 SUBROUTINE DPSYMB(IHARG,NUMARG,IDEFSY,ITEXSY, 3511 1 IBUGD2,ISUBRO,IFOUND,IERROR) 3512C 3513C PURPOSE--DEFINE THE SYMBOL CHARACTER WHICH MAY 3514C BE USED TO DENOTE IN-LINE TEXT SUB-COMMANDS. 3515C WHEN A TEXT STRING IS PROCESSED, 3516C IT IS SCANNED FOR THE SYMBOL CHARACTER; 3517C IF IT IS FOUND, THE IN-LINE SUB-COMMAND 3518C BEFORE THE SYMBOL CHARACTER IS EXECUTED 3519C RATHER THAN THE LITERAL TEXT SUB-STRING BEING WRITTEN OUT. 3520C ANY NUMBER OF SYMBOL CHARACTERS ARE ALLOWED PER LINE. 3521C THE SYMBOL CHARACTER CAPABILITY ALLOWS THE ANALYST 3522C TO WRITE GREEK, MATH, AND OTHER SPECIAL SYMBOLS. 3523C THE SPECIFIED SYMBOL CHARACTER WILL BE PLACED 3524C IN THE CHARACTER VARIABLE ITEXSY. 3525C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 3526C --NUMARG (AN INTEGER VARIABLE) 3527C --IDEFSY (A CHARACTER VARIABLE) 3528C --IBUGD2 (A CHARACTER VARIABLE) 3529C OUTPUT ARGUMENTS--ITEXSY (A CHARACTER VARIABLE) 3530C --IFOUND ('YES' OR 'NO' ) 3531C --IERROR ('YES' OR 'NO' ) 3532C WRITTEN BY--JAMES J. FILLIBEN 3533C STATISTICAL ENGINEERING DIVISION 3534C INFORMATION TECHNOLOGY LABORATORY 3535C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 3536C GAITHERSBURG, MD 20899-8980 3537C PHONE--301-975-2899 3538C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 3539C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 3540C LANGUAGE--ANSI FORTRAN (1977) 3541C VERSION NUMBER--82/7 3542C ORIGINAL VERSION--NOVEMBER 1980. 3543C UPDATED --MAY 1982. 3544C 3545C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 3546C 3547 CHARACTER*4 IHARG 3548 CHARACTER*4 IDEFSY 3549 CHARACTER*4 ITEXSY 3550 CHARACTER*4 IBUGD2 3551 CHARACTER*4 ISUBRO 3552 CHARACTER*4 IFOUND 3553 CHARACTER*4 IERROR 3554C 3555 CHARACTER*4 IHOLD 3556C 3557C--------------------------------------------------------------------- 3558C 3559 DIMENSION IHARG(*) 3560C 3561C-----COMMON---------------------------------------------------------- 3562C 3563 INCLUDE 'DPCOP2.INC' 3564C 3565C-----START POINT----------------------------------------------------- 3566C 3567 IFOUND='NO' 3568 IERROR='NO' 3569C 3570 IF(IBUGD2.EQ.'OFF')GOTO90 3571 WRITE(ICOUT,999) 3572 999 FORMAT(1X) 3573 CALL DPWRST('XXX','BUG ') 3574 WRITE(ICOUT,51) 3575 51 FORMAT('***** AT THE BEGINNING OF DPSYMB--') 3576 CALL DPWRST('XXX','BUG ') 3577 WRITE(ICOUT,53)IDEFSY 3578 53 FORMAT('IDEFSY = ',A4) 3579 CALL DPWRST('XXX','BUG ') 3580 WRITE(ICOUT,54)NUMARG 3581 54 FORMAT('NUMARG = ',I8) 3582 CALL DPWRST('XXX','BUG ') 3583 DO55I=1,NUMARG 3584 WRITE(ICOUT,56)I,IHARG(I) 3585 56 FORMAT('I,IHARG(I) = ',I8,2X,A4) 3586 CALL DPWRST('XXX','BUG ') 3587 55 CONTINUE 3588 90 CONTINUE 3589C 3590 IF(NUMARG.LE.0)GOTO1150 3591 GOTO1110 3592C 3593 1110 CONTINUE 3594 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 3595 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 3596 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 3597 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 3598 GOTO1160 3599C 3600 1150 CONTINUE 3601 IHOLD=IDEFSY 3602 GOTO1180 3603C 3604 1160 CONTINUE 3605 IHOLD=IHARG(NUMARG) 3606 GOTO1180 3607C 3608 1180 CONTINUE 3609 IFOUND='YES' 3610 ITEXSY=IHOLD 3611C 3612 IF(IFEEDB.EQ.'OFF')GOTO1189 3613 WRITE(ICOUT,999) 3614 CALL DPWRST('XXX','BUG ') 3615 WRITE(ICOUT,1181) 3616 1181 FORMAT('THE SYMBOL CHARACTER (TO DENOTE') 3617 CALL DPWRST('XXX','BUG ') 3618 WRITE(ICOUT,1182) 3619 1182 FORMAT(' GREEK, MATH, AND OTHER SPECIAL SYMBOLS') 3620 CALL DPWRST('XXX','BUG ') 3621 WRITE(ICOUT,1183) 3622 1183 FORMAT('IN THE TEXT, TITLE, LABEL, AND LEGEND COMMANDS)') 3623 CALL DPWRST('XXX','BUG ') 3624 WRITE(ICOUT,1184)ITEXSY 3625 1184 FORMAT('HAS JUST BEEN SET TO ',A4) 3626 CALL DPWRST('XXX','BUG ') 3627 1189 CONTINUE 3628 GOTO9000 3629C 3630 9000 CONTINUE 3631 IF(IBUGD2.EQ.'OFF')GOTO9090 3632 WRITE(ICOUT,999) 3633 CALL DPWRST('XXX','BUG ') 3634 WRITE(ICOUT,9011) 3635 9011 FORMAT('***** AT THE END OF DPSYMB--') 3636 CALL DPWRST('XXX','BUG ') 3637 WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR 3638 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 3639 CALL DPWRST('XXX','BUG ') 3640 WRITE(ICOUT,9013)IDEFSY,ITEXSY 3641 9013 FORMAT('IDEFSY,ITEXSY = ',A4,2X,A4) 3642 CALL DPWRST('XXX','BUG ') 3643 9090 CONTINUE 3644C 3645 RETURN 3646 END 3647 SUBROUTINE DPSYMM(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 3648 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 3649C 3650C PURPOSE--GENERATE A SYMMETRY PLOT 3651C WRITTEN BY--ALAN HECKERT 3652C STATISTICAL ENGINEERING DIVISION 3653C INFORMATION TECHNOLOGY LABORATORY 3654C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 3655C GAITHERSBURG, MD 20899-8980 3656C PHONE--301-975-2899 3657C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 3658C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 3659C LANGUAGE--ANSI FORTRAN (1977) 3660C VERSION NUMBER--86/7 3661C ORIGINAL VERSION--APRIL 1986. 3662C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON 3663C UPDATED --NOVEMBER 2011. 1) USE DPPARS TO PERFORM 3664C SOME OF THE PARSING 3665C 2) SUPPORT "REPLICATION" AND 3666C "MULTIPLE" KEYWORDS 3667C 3) SUPPORT "HIGHLIGHT" OPTION 3668C 3669C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 3670C 3671 CHARACTER*4 ICASPL 3672 CHARACTER*4 IAND1 3673 CHARACTER*4 IAND2 3674 CHARACTER*4 IBUGG2 3675 CHARACTER*4 IBUGG3 3676 CHARACTER*4 IBUGQ 3677 CHARACTER*4 ISUBRO 3678 CHARACTER*4 IFOUND 3679 CHARACTER*4 IERROR 3680C 3681 CHARACTER*4 IDATSW 3682 CHARACTER*4 IREPL 3683 CHARACTER*4 IHIGH 3684 CHARACTER*4 IWRITE 3685 CHARACTER*4 IMULT 3686 CHARACTER*4 IGROUP 3687 CHARACTER*4 ITERM1 3688 CHARACTER*4 ITERM2 3689 CHARACTER*4 ITERM3 3690 CHARACTER*4 ISUBN1 3691 CHARACTER*4 ISUBN2 3692 CHARACTER*4 ISTEPN 3693 CHARACTER*4 ICASE 3694C 3695 CHARACTER*40 INAME 3696 PARAMETER (MAXSPN=30) 3697 CHARACTER*4 IVARN1(MAXSPN) 3698 CHARACTER*4 IVARN2(MAXSPN) 3699 CHARACTER*4 IVARTY(MAXSPN) 3700 REAL PVAR(MAXSPN) 3701 INTEGER ILIS(MAXSPN) 3702 INTEGER NRIGHT(MAXSPN) 3703 INTEGER ICOLR(MAXSPN) 3704C 3705C--------------------------------------------------------------------- 3706C 3707 INCLUDE 'DPCOPA.INC' 3708C 3709 DIMENSION Y1(MAXOBV) 3710 DIMENSION X1(MAXOBV) 3711 DIMENSION XTEMP1(MAXOBV) 3712 DIMENSION XTEMP2(MAXOBV) 3713 DIMENSION XTEMP3(MAXOBV) 3714 DIMENSION XTEMP4(MAXOBV) 3715 DIMENSION XDESGN(MAXOBV,6) 3716 DIMENSION XIDTEM(MAXOBV) 3717 DIMENSION XIDTE2(MAXOBV) 3718 DIMENSION ZY(MAXOBV) 3719 DIMENSION TAG1(MAXOBV) 3720CCCCC FOLLOWING LINES ADDED JUNE, 1990 3721 INCLUDE 'DPCOZZ.INC' 3722 EQUIVALENCE (GARBAG(IGARB1),X1(1)) 3723 EQUIVALENCE (GARBAG(IGARB2),Y1(1)) 3724 EQUIVALENCE (GARBAG(IGARB3),XTEMP1(1)) 3725 EQUIVALENCE (GARBAG(IGARB4),XTEMP2(1)) 3726 EQUIVALENCE (GARBAG(IGARB5),XTEMP3(1)) 3727 EQUIVALENCE (GARBAG(IGARB6),XTEMP4(1)) 3728 EQUIVALENCE (GARBAG(IGARB7),XIDTEM(1)) 3729 EQUIVALENCE (GARBAG(IGARB8),XIDTE2(1)) 3730 EQUIVALENCE (GARBAG(IGARB9),ZY(1)) 3731 EQUIVALENCE (GARBAG(JGAR11),TAG1(1)) 3732 EQUIVALENCE (GARBAG(JGAR12),XDESGN(1,1)) 3733CCCCC END CHANGE 3734C 3735C-----COMMON---------------------------------------------------------- 3736C 3737 INCLUDE 'DPCOST.INC' 3738 INCLUDE 'DPCOHK.INC' 3739 INCLUDE 'DPCODA.INC' 3740 INCLUDE 'DPCOP2.INC' 3741C 3742C-----START POINT----------------------------------------------------- 3743C 3744 IERROR='NO' 3745 IFOUND='NO' 3746 ISUBN1='DPSY' 3747 ISUBN2='MM ' 3748C 3749 IHIGH='OFF' 3750 IMULT='OFF' 3751 IREPL='OFF' 3752 ICASE='NONE' 3753C 3754 MAXCP1=MAXCOL+1 3755 MAXCP2=MAXCOL+2 3756 MAXCP3=MAXCOL+3 3757 MAXCP4=MAXCOL+4 3758 MAXCP5=MAXCOL+5 3759 MAXCP6=MAXCOL+6 3760C 3761C *************************************** 3762C ** TREAT THE SYMMETRY PLOT CASE ** 3763C *************************************** 3764C 3765 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SYMM')THEN 3766 WRITE(ICOUT,999) 3767 999 FORMAT(1X) 3768 CALL DPWRST('XXX','BUG ') 3769 WRITE(ICOUT,51) 3770 51 FORMAT('***** AT THE BEGINNING OF DPSYMM--') 3771 CALL DPWRST('XXX','BUG ') 3772 WRITE(ICOUT,52)ICASPL,IAND1,IAND2 3773 52 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) 3774 CALL DPWRST('XXX','BUG ') 3775 WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO 3776 53 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4) 3777 CALL DPWRST('XXX','BUG ') 3778 ENDIF 3779C 3780C *************************** 3781C ** STEP 1-- ** 3782C ** EXTRACT THE COMMAND ** 3783C *************************** 3784C 3785C LOOK FOR THE WORDS "SYMMETRY PLOT". ALSO LOOK 3786C FOR THE KEYWORDS "MULTIPLE", "REPLICATION", OR "HIGHLIGHT". 3787C 3788 ISTEPN='1' 3789 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SYMM') 3790 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3791C 3792 ILASTC=-9999 3793 DO100I=0,NUMARG-1 3794C 3795 IF(I.EQ.0)THEN 3796 ITERM1=ICOM 3797 ITERM2=IHARG(I+1) 3798 ITERM3=IHARG(I+2) 3799 ELSE 3800 ITERM1=IHARG(I) 3801 ITERM2=IHARG(I+1) 3802 ITERM3=IHARG(I+2) 3803 ENDIF 3804C 3805 IF(ITERM1.EQ.'SYMM' .AND. ITERM2.EQ.'PLOT')THEN 3806 IFOUND='YES' 3807 ILASTC=MAX(ILASTC,I+1) 3808 ELSEIF(ITERM1.EQ.'REPL')THEN 3809 IREPL='ON' 3810 ILASTC=MAX(ILASTC,I) 3811 ELSEIF(ITERM1.EQ.'MULT')THEN 3812 IMULT='ON' 3813 ILASTC=MAX(ILASTC,I) 3814 ELSEIF(ITERM1.EQ.'HIGH')THEN 3815 IHIGH='ON' 3816 ILASTC=MAX(ILASTC,I) 3817 ELSEIF(ITERM1.EQ.'GROU' .OR. ITERM1.EQ.'BINN')THEN 3818 IGROUP='ON' 3819 ILASTC=MAX(ILASTC,I) 3820 ENDIF 3821 100 CONTINUE 3822C 3823 IF(IFOUND.EQ.'NO')GOTO9000 3824 IF(IMULT.EQ.'ON')THEN 3825 IF(IREPL.EQ.'ON')THEN 3826 WRITE(ICOUT,999) 3827 CALL DPWRST('XXX','BUG ') 3828 WRITE(ICOUT,101) 3829 101 FORMAT('***** ERROR IN SYMMETRY PLOT--') 3830 CALL DPWRST('XXX','BUG ') 3831 WRITE(ICOUT,102) 3832 102 FORMAT(' YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ', 3833 1 '"REPLICATION" FOR THE SYMMETRY PLOT.') 3834 CALL DPWRST('XXX','BUG ') 3835 IERROR='YES' 3836 GOTO9000 3837 ELSEIF(IHIGH.EQ.'ON')THEN 3838 WRITE(ICOUT,999) 3839 CALL DPWRST('XXX','BUG ') 3840 WRITE(ICOUT,101) 3841 CALL DPWRST('XXX','BUG ') 3842 WRITE(ICOUT,122) 3843 122 FORMAT(' YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ', 3844 1 '"HIGHTLIGHTED" FOR THE SYMMETRY PLOT.') 3845 CALL DPWRST('XXX','BUG ') 3846 IERROR='YES' 3847 GOTO9000 3848 ENDIF 3849 ENDIF 3850C 3851 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 3852 IFOUND='YES' 3853 ICASPL='SYMM' 3854C 3855C ********************************* 3856C ** STEP 2-- ** 3857C ** EXTRACT THE VARIABLE LIST ** 3858C ********************************* 3859C 3860 ISTEPN='4' 3861 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SYMM') 3862 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3863C 3864 INAME='SYMMETRY PLOT' 3865 MINNA=1 3866 MAXNA=100 3867 MINN2=2 3868 IFLAGE=1 3869 IFLAGM=0 3870 IF(IMULT.EQ.'ON')THEN 3871 IFLAGE=0 3872 IFLAGM=1 3873 ELSE 3874 IF(IREPL.EQ.'OFF' .AND. IHIGH.EQ.'OFF')IFLAGM=1 3875 ENDIF 3876 IFLAGP=0 3877 JMIN=1 3878 JMAX=NUMARG 3879 IF(IMULT.EQ.'OFF' .AND. IHIGH.EQ.'OFF' .AND. IREPL.EQ.'OFF')THEN 3880 MINNVA=1 3881 MAXNVA=3 3882 IFLAGM=1 3883 ELSEIF(IHIGH.EQ.'ON')THEN 3884 MINNVA=2 3885 MAXNVA=3 3886 IFLAGM=0 3887 ELSE 3888 MINNVA=-99 3889 MAXNVA=-99 3890 ENDIF 3891C 3892 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 3893 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 3894 1 JMIN,JMAX, 3895 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 3896 1 IVARN1,IVARN2,IVARTY,PVAR, 3897 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 3898 1 MINNVA,MAXNVA, 3899 1 IFLAGM,IFLAGP, 3900 1 IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 3901 IF(IERROR.EQ.'YES')GOTO9000 3902C 3903 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SYMM')THEN 3904 WRITE(ICOUT,999) 3905 CALL DPWRST('XXX','BUG ') 3906 WRITE(ICOUT,281) 3907 281 FORMAT('***** AFTER CALL DPPARS--') 3908 CALL DPWRST('XXX','BUG ') 3909 WRITE(ICOUT,282)NQ,NUMVAR 3910 282 FORMAT('NQ,NUMVAR = ',2I8) 3911 CALL DPWRST('XXX','BUG ') 3912 IF(NUMVAR.GT.0)THEN 3913 DO285I=1,NUMVAR 3914 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 3915 1 ICOLR(I) 3916 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 3917 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 3918 CALL DPWRST('XXX','BUG ') 3919 285 CONTINUE 3920 ENDIF 3921 ENDIF 3922C 3923C *********************************************** 3924C ** STEP 3-- ** 3925C ** DETERMINE: ** 3926C ** 1) NUMBER OF REPLICATION VARIABLES (0-2) ** 3927C ** 2) NUMBER OF GROUPING VARIABLES (0-2) ** 3928C ** 3) NUMBER OF RESPONSE VARIABLES (>= 1)** 3929C ** 4) NUMBER OF HIGHLIGHT VARIABLES (0-2) ** 3930C *********************************************** 3931C 3932 ISTEPN='5' 3933 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SYMM') 3934 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3935C 3936 NRESP=0 3937 NREPL=0 3938 NGROUP=0 3939 NHIGH=0 3940 IDATSW='RAW' 3941 IF(IMULT.EQ.'ON')THEN 3942 NRESP=NUMVAR 3943 ELSEIF(IHIGH.EQ.'ON')THEN 3944 NRESP=1 3945 NHIGH=NUMVAR-1 3946 IF(NHIGH.LT.1 .OR. NHIGH.GT.2)THEN 3947 WRITE(ICOUT,999) 3948 CALL DPWRST('XXX','BUG ') 3949 WRITE(ICOUT,101) 3950 CALL DPWRST('XXX','BUG ') 3951 WRITE(ICOUT,501) 3952 501 FORMAT(' FOR THE HIGHLIGHTED CASE, THE NUMBER OF ', 3953 1 'HIGHLIGHT VARIABLES') 3954 CALL DPWRST('XXX','BUG ') 3955 WRITE(ICOUT,502) 3956 502 FORMAT(' MUST BE ONE OR TWO; SUCH WAS NOT THE ', 3957 1 'CASE HERE.') 3958 CALL DPWRST('XXX','BUG ') 3959 WRITE(ICOUT,503)NHIGH 3960 503 FORMAT(' THE NUMBER OF HIGHLIGHT VARIABLES = ',I5) 3961 CALL DPWRST('XXX','BUG ') 3962 IERROR='YES' 3963 GOTO9000 3964 ENDIF 3965 ELSEIF(IREPL.EQ.'ON')THEN 3966 NRESP=1 3967 NREPL=NUMVAR-NRESP 3968 IF(NREPL.LT.1 .OR. NREPL.GT.2)THEN 3969 WRITE(ICOUT,999) 3970 CALL DPWRST('XXX','BUG ') 3971 WRITE(ICOUT,101) 3972 CALL DPWRST('XXX','BUG ') 3973 WRITE(ICOUT,511) 3974 511 FORMAT(' FOR THE REPLICATION CASE, THE NUMBER OF ', 3975 1 'REPLICATION VARIABLES') 3976 CALL DPWRST('XXX','BUG ') 3977 WRITE(ICOUT,512) 3978 512 FORMAT(' MUST BE BETWEEN 1 AND 2; SUCH WAS NOT THE ', 3979 1 'CASE HERE.') 3980 CALL DPWRST('XXX','BUG ') 3981 WRITE(ICOUT,513)NREPL 3982 513 FORMAT(' THE NUMBER OF REPLICATION VARIABLES = ',I5) 3983 CALL DPWRST('XXX','BUG ') 3984 IERROR='YES' 3985 GOTO9000 3986 ENDIF 3987 ENDIF 3988C 3989C ********************************************* 3990C ** STEP 7A-- ** 3991C ** CASE 1: NO REPLICATION, NO MULTIPLE, ** 3992C ** AND NO HIGHLIGHTING ** 3993C ********************************************* 3994C 3995C FOR THIS CASE, CAN HAVE ONE TO TWO RESPONSE VARIABLES 3996C (DEPDENDING ON WHETHER WE HAVE BINNED DATA OR RAW DATA). 3997C 3998C FOR THIS CASE, ONLY SUPPORT MATRIX ARGUMENT FOR RAW DATA 3999C NUMBER OF OBSERVATIONS MUST BE THE SAME FOR ALL VARIABLES. 4000C 4001 IF(IMULT.EQ.'OFF' .AND. NREPL.EQ.0 .AND. NHIGH.EQ.0)THEN 4002 ISTEPN='7A' 4003 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SYMM') 4004 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4005C 4006 ICOL=1 4007 IF(NUMVAR.EQ.1)THEN 4008 IDATSW='RAW' 4009 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 4010 1 INAME,IVARN1,IVARN2,IVARTY, 4011 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 4012 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 4013 1 MAXCP4,MAXCP5,MAXCP6, 4014 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 4015 1 Y1,X1,XTEMP1,NLOCAL,NLOCA2,NLOCA3,ICASE, 4016 1 IBUGG3,ISUBRO,IFOUND,IERROR) 4017 ELSEIF(NUMVAR.EQ.2)THEN 4018 IDATSW='FREQ' 4019 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 4020 1 INAME,IVARN1,IVARN2,IVARTY, 4021 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 4022 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 4023 1 MAXCP4,MAXCP5,MAXCP6, 4024 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 4025 1 Y1,X1,XTEMP1,NLOCAL,NLOCA2,NLOCA3,ICASE, 4026 1 IBUGG3,ISUBRO,IFOUND,IERROR) 4027 ENDIF 4028 IF(ICASE.EQ.'MATR' .AND. NUMVAR.GT.1)THEN 4029 WRITE(ICOUT,999) 4030 CALL DPWRST('XXX','BUG ') 4031 WRITE(ICOUT,101) 4032 CALL DPWRST('XXX','BUG ') 4033 WRITE(ICOUT,701) 4034 701 FORMAT(' MATRIX ARGUMENTS ARE ONLY SUPPORTED FOR THE') 4035 CALL DPWRST('XXX','BUG ') 4036 WRITE(ICOUT,703) 4037 703 FORMAT(' RAW DATA CASE.') 4038 CALL DPWRST('XXX','BUG ') 4039 IERROR='YES' 4040 GOTO9000 4041 ELSEIF(NUMVAR.EQ.2 .AND. NLOCAL.NE.NLOCA2)THEN 4042 WRITE(ICOUT,999) 4043 CALL DPWRST('XXX','BUG ') 4044 WRITE(ICOUT,101) 4045 CALL DPWRST('XXX','BUG ') 4046 WRITE(ICOUT,711) 4047 711 FORMAT(' FOR THE FREQUENCY CASE, THE NUMBER OF ', 4048 1 'OBSERVATIONS FOR') 4049 CALL DPWRST('XXX','BUG ') 4050 WRITE(ICOUT,713) 4051 713 FORMAT(' THE TWO VARIABLES MUST BE EQUAL.') 4052 CALL DPWRST('XXX','BUG ') 4053 WRITE(ICOUT,715)IVARN1(1),IVARN2(1),NLOCAL 4054 715 FORMAT(' ',A4,A4,' HAS ',I8,' OBSERVATIONS.') 4055 CALL DPWRST('XXX','BUG ') 4056 WRITE(ICOUT,715)IVARN1(2),IVARN2(2),NLOCA2 4057 CALL DPWRST('XXX','BUG ') 4058 IERROR='YES' 4059 GOTO9000 4060 ENDIF 4061C 4062C ***************************************************** 4063C ** STEP 7B-- ** 4064C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** 4065C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** 4066C ** RESET THE VECTOR D(.) TO ALL ONES. ** 4067C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** 4068C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** 4069C ***************************************************** 4070C 4071C 4072 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'SYMM')THEN 4073 ISTEPN='7B' 4074 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4075 WRITE(ICOUT,999) 4076 CALL DPWRST('XXX','BUG ') 4077 WRITE(ICOUT,731) 4078 731 FORMAT('***** FROM THE MIDDLE OF DPSYMM--') 4079 CALL DPWRST('XXX','BUG ') 4080 WRITE(ICOUT,732)ICASPL,NUMVAR,IDATSW,NLOCAL 4081 732 FORMAT('ICASPL,NUMVAR,IDATSW,NLOCAL = ', 4082 1 A4,I8,2X,A4,I8) 4083 CALL DPWRST('XXX','BUG ') 4084 IF(NLOCAL.GE.1)THEN 4085 DO735I=1,NLOCAL 4086 WRITE(ICOUT,736)I,Y1(I),X1(I) 4087 736 FORMAT('I,Y1(I),X1(I) = ',I8,2G15.7) 4088 CALL DPWRST('XXX','BUG ') 4089 735 CONTINUE 4090 ENDIF 4091 ENDIF 4092C 4093 NPLOTP=0 4094 NCURVE=1 4095 CALL DPSYM2(Y1,X1,NLOCAL,ICASPL,IDATSW,MAXOBV, 4096 1 NUMVAR,NCURVE,NHIGH, 4097 1 TAG1,XTEMP1,XTEMP2, 4098 1 Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 4099C 4100C ****************************************** 4101C ** STEP 8A-- ** 4102C ** CASE 2: MULTIPLE RESPONSE VARIABLES ** 4103C ** NOTE THAT HIGHLIGHTING AND ** 4104C ** GROUPING ARE NOT SUPPORTED ** 4105C ** FOR THIS CASE. ** 4106C ****************************************** 4107C 4108 ELSEIF(IMULT.EQ.'ON')THEN 4109 ISTEPN='8A' 4110 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SYMM') 4111 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4112C 4113C LOOP THROUGH EACH OF THE RESPONSE VARIABLES 4114C 4115 NPLOTP=0 4116 NCURVE=0 4117 DO810IRESP=1,NRESP 4118 NCURVE=NCURVE+1 4119C 4120 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PERC')THEN 4121 WRITE(ICOUT,999) 4122 CALL DPWRST('XXX','BUG ') 4123 WRITE(ICOUT,811)IRESP,NCURVE 4124 811 FORMAT('IRESP,NCURVE = ',2I5) 4125 CALL DPWRST('XXX','BUG ') 4126 ENDIF 4127C 4128 ICOL=IRESP 4129 NUMVA2=1 4130 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 4131 1 INAME,IVARN1,IVARN2,IVARTY, 4132 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 4133 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 4134 1 MAXCP4,MAXCP5,MAXCP6, 4135 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 4136 1 Y1,XTEMP1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE, 4137 1 IBUGG3,ISUBRO,IFOUND,IERROR) 4138C 4139C ***************************************************** 4140C ** STEP 8B-- ** 4141C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** 4142C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** 4143C ** RESET THE VECTOR D(.) TO ALL ONES. ** 4144C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** 4145C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** 4146C ***************************************************** 4147C 4148C 4149 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'SYMM')THEN 4150 ISTEPN='8B' 4151 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4152 WRITE(ICOUT,999) 4153 CALL DPWRST('XXX','BUG ') 4154 WRITE(ICOUT,822) 4155 822 FORMAT('***** FROM THE MIDDLE OF DPSYMM--') 4156 CALL DPWRST('XXX','BUG ') 4157 WRITE(ICOUT,823)ICASPL,NUMVAR,IDATSW,NLOCAL 4158 823 FORMAT('ICASPL,NUMVAR,IDATSW,NLOCAL = ', 4159 1 A4,I8,2X,A4,I8) 4160 CALL DPWRST('XXX','BUG ') 4161 IF(NLOCAL.GE.1)THEN 4162 DO825I=1,NLOCAL 4163 WRITE(ICOUT,826)I,Y1(I) 4164 826 FORMAT('I,X1(I) = ',I8,G15.7) 4165 CALL DPWRST('XXX','BUG ') 4166 825 CONTINUE 4167 ENDIF 4168 ENDIF 4169C 4170 CALL DPSYM2(Y1,X1,NLOCAL,ICASPL,IDATSW,MAXOBV, 4171 1 NUMVAR,NCURVE,NHIGH, 4172 1 TAG1,XTEMP1,XTEMP2, 4173 1 Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 4174 810 CONTINUE 4175C 4176C *************************************************** 4177C ** STEP 9A-- ** 4178C ** CASE 3: ONE OR MORE REPLICATION VARIABLES. ** 4179C ** CURRENTLY, ONLY SUPPORT THIS OPTION ** 4180C ** FOR UNBINNED DATA. ** 4181C *************************************************** 4182C 4183 ELSEIF(NRESP.GE.1 .AND. NREPL.GE.1)THEN 4184 ISTEPN='9A' 4185 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SYMM') 4186 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4187C 4188 J=0 4189 IMAX=NRIGHT(1) 4190 IF(NQ.LT.NRIGHT(1))IMAX=NQ 4191 DO910I=1,IMAX 4192 IF(ISUB(I).EQ.0)GOTO910 4193 J=J+1 4194C 4195C RESPONSE VARIABLE IN X1 (OR Y1 IF GROUPED DATA) 4196C 4197 IJ=MAXN*(ICOLR(1)-1)+I 4198 IF(ICOLR(1).LE.MAXCOL)Y1(J)=V(IJ) 4199 IF(ICOLR(1).EQ.MAXCP1)Y1(J)=PRED(I) 4200 IF(ICOLR(1).EQ.MAXCP2)Y1(J)=RES(I) 4201 IF(ICOLR(1).EQ.MAXCP3)Y1(J)=YPLOT(I) 4202 IF(ICOLR(1).EQ.MAXCP4)Y1(J)=XPLOT(I) 4203 IF(ICOLR(1).EQ.MAXCP5)Y1(J)=X2PLOT(I) 4204 IF(ICOLR(1).EQ.MAXCP6)Y1(J)=TAGPLO(I) 4205 ICOLC=1 4206C 4207 DO920IR=1,MIN(NREPL,2) 4208 ICOLC=ICOLC+1 4209 ICOLT=ICOLR(ICOLC) 4210 IJ=MAXN*(ICOLT-1)+I 4211 IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ) 4212 IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I) 4213 IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I) 4214 IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I) 4215 IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I) 4216 IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I) 4217 IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I) 4218 920 CONTINUE 4219C 4220 910 CONTINUE 4221 NLOCAL=J 4222C 4223C ***************************************************** 4224C ** STEP 9B-- ** 4225C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** 4226C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** 4227C ** ** 4228C ** FOR THIS CASE, WE NEED TO LOOP THROUGH THE ** 4229C ** VARIOUS REPLICATIONS. ** 4230C ***************************************************** 4231C 4232 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'SYMM')THEN 4233 ISTEPN='9B' 4234 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4235 WRITE(ICOUT,999) 4236 CALL DPWRST('XXX','BUG ') 4237 WRITE(ICOUT,931) 4238 931 FORMAT('***** FROM THE MIDDLE OF DPSYMM--') 4239 CALL DPWRST('XXX','BUG ') 4240 WRITE(ICOUT,932)ICASPL,NUMVAR,IDATSW,NLOCAL 4241 932 FORMAT('ICASPL,NUMVAR,IDATSW,NLOCAL = ', 4242 1 A4,I8,2X,A4,I8) 4243 CALL DPWRST('XXX','BUG ') 4244 IF(NLOCAL.GE.1)THEN 4245 DO935I=1,NLOCAL 4246 WRITE(ICOUT,936)I,Y1(I),XDESGN(I,1),XDESGN(I,2) 4247 936 FORMAT('I,Y1(I),XDESGN(I,1),XDESGN(I,2)=',I8,3G15.7) 4248 CALL DPWRST('XXX','BUG ') 4249 935 CONTINUE 4250 ENDIF 4251 ENDIF 4252C 4253C ***************************************************** 4254C ** STEP 9C-- ** 4255C ** FIND THE DISTINCT VALUES IN EACH OF THE ** 4256C ** REPLICATION VARIABLES. ** 4257C ***************************************************** 4258C 4259 CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3), 4260 1 XDESGN(1,4),XDESGN(1,5),XDESGN(1,6), 4261 1 NREPL,NLOCAL,MAXOBV, 4262 1 XIDTEM,XIDTE2,XIDTE2,XIDTE2,XIDTE2,XIDTE2, 4263 1 XTEMP1,XTEMP2, 4264 1 NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6, 4265 1 IBUGG3,ISUBRO,IERROR) 4266C 4267C ***************************************************** 4268C ** STEP 9D-- ** 4269C ** NOW LOOP THROUGH THE VARIOUS REPLICATIONS ** 4270C ***************************************************** 4271C 4272 NPLOTP=0 4273 NCURVE=0 4274 IF(NREPL.EQ.1)THEN 4275 J=0 4276 DO1110ISET1=1,NUMSE1 4277 K=0 4278 DO1130I=1,NLOCAL 4279 IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN 4280 K=K+1 4281 ZY(K)=Y1(I) 4282 ENDIF 4283 1130 CONTINUE 4284 NTEMP=K 4285 NCURVE=NCURVE+1 4286 NUMVA2=1 4287 IF(NTEMP.GT.0)THEN 4288 CALL DPSYM2(ZY,X1,NTEMP,ICASPL,IDATSW,MAXOBV, 4289 1 NUMVA2,NCURVE,NHIGH, 4290 1 TAG1,XTEMP1,XTEMP2, 4291 1 Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 4292 ENDIF 4293 1110 CONTINUE 4294 ELSEIF(NREPL.EQ.2)THEN 4295 J=0 4296 NTOT=NUMSE1*NUMSE2 4297 DO1210ISET1=1,NUMSE1 4298 DO1220ISET2=1,NUMSE2 4299 K=0 4300 DO1290I=1,NLOCAL 4301 IF( 4302 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 4303 1 XIDTE2(ISET2).EQ.XDESGN(I,2) 4304 1 )THEN 4305 K=K+1 4306 ZY(K)=Y1(I) 4307 ENDIF 4308 1290 CONTINUE 4309 NTEMP=K 4310 NCURVE=NCURVE+1 4311 NUMVA2=1 4312 IF(NTEMP.GT.0)THEN 4313 CALL DPSYM2(ZY,X1,NTEMP,ICASPL,IDATSW,MAXOBV, 4314 1 NUMVA2,NCURVE,NHIGH, 4315 1 TAG1,XTEMP1,XTEMP2, 4316 1 Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 4317 ENDIF 4318 1220 CONTINUE 4319 1210 CONTINUE 4320 ENDIF 4321C 4322C *************************************************** 4323C ** STEP 10A-- ** 4324C ** CASE 4: ONE OR TWO HIGHLIGHT VARIABLES. ** 4325C ** THIS CASE DOES NOT SUPPORT GROUPED ** 4326C ** DATA AND ALL VARIABLES MUST HAVE ** 4327C ** SAME LENGTH. ** 4328C *************************************************** 4329C 4330 ELSEIF(NRESP.EQ.1 .AND. NHIGH.GE.1)THEN 4331 ISTEPN='10A' 4332 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SYMM') 4333 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4334C 4335 ICOL=1 4336 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 4337 1 INAME,IVARN1,IVARN2,IVARTY, 4338 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 4339 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 4340 1 MAXCP4,MAXCP5,MAXCP6, 4341 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 4342 1 Y1,X1,XTEMP1,NLOCAL,NLOCA2,NLOCA3,ICASE, 4343 1 IBUGG3,ISUBRO,IFOUND,IERROR) 4344C 4345 IF(NHIGH.EQ.1)THEN 4346 CALL CODE(X1,NLOCAL,IWRITE,TAG1,XTEMP1,MAXOBV, 4347 1 IBUGG3,IERROR) 4348 ELSE 4349 ICCTOF=0 4350 ICCTG1=0 4351 CALL CODCT2(X1,XTEMP1,NLOCAL,ICCTOF,ICCTG1,IWRITE, 4352 1 TAG1,XTEMP2,XTEMP3, 4353 1 IBUGG3,ISUBRO,IERROR) 4354 ENDIF 4355C 4356C ***************************************************** 4357C ** STEP 10B-- ** 4358C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** 4359C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** 4360C ** ** 4361C ** FOR THIS CASE, WE NEED TO LOOP THROUGH THE ** 4362C ** VARIOUS REPLICATIONS. ** 4363C ***************************************************** 4364C 4365 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'SYMM')THEN 4366 ISTEPN='10B' 4367 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4368 WRITE(ICOUT,999) 4369 CALL DPWRST('XXX','BUG ') 4370 WRITE(ICOUT,1731) 4371 1731 FORMAT('***** FROM THE MIDDLE OF DPSYMM--') 4372 CALL DPWRST('XXX','BUG ') 4373 WRITE(ICOUT,1732)ICASPL,NUMVAR,IDATSW,NLOCAL 4374 1732 FORMAT('ICASPL,NUMVAR,IDATSW,NQ = ', 4375 1 A4,I8,2X,A4,I8) 4376 CALL DPWRST('XXX','BUG ') 4377 IF(NLOCAL.GE.1)THEN 4378 DO1735I=1,NLOCAL 4379 WRITE(ICOUT,1736)I,Y1(I),TAG1(I) 4380 1736 FORMAT('I,Y1(I),TAG1(I) = ',I8,2G15.7) 4381 CALL DPWRST('XXX','BUG ') 4382 1735 CONTINUE 4383 ENDIF 4384 ENDIF 4385C 4386C ************************************ 4387C ** STEP 10C-- ** 4388C ** GENERATE THE SYMMETRY PLOT ** 4389C ************************************ 4390C 4391 NPLOTP=0 4392 NCURVE=1 4393 CALL DPSYM2(Y1,X1,NLOCAL,ICASPL,IDATSW,MAXOBV, 4394 1 NUMVAR,NCURVE,NHIGH, 4395 1 TAG1,XTEMP1,XTEMP2, 4396 1 Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 4397C 4398 ENDIF 4399C 4400C ***************** 4401C ** STEP 90-- ** 4402C ** EXIT ** 4403C ***************** 4404C 4405 9000 CONTINUE 4406 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SYMM')THEN 4407 WRITE(ICOUT,999) 4408 CALL DPWRST('XXX','BUG ') 4409 WRITE(ICOUT,9011) 4410 9011 FORMAT('***** AT THE END OF DPSYMM--') 4411 CALL DPWRST('XXX','BUG ') 4412 WRITE(ICOUT,9012)IFOUND,IERROR 4413 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 4414 CALL DPWRST('XXX','BUG ') 4415 WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 4416 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',3I8,3(2X,A4)) 4417 CALL DPWRST('XXX','BUG ') 4418 IF(NPLOTP.GT.0)THEN 4419 DO9020I=1,NPLOTP 4420 WRITE(ICOUT,9021)I,Y(I),X(I),D(I) 4421 9021 FORMAT('I,Y(I),X(I),D(I) = ',I8,3G15.7) 4422 CALL DPWRST('XXX','BUG ') 4423 9020 CONTINUE 4424 ENDIF 4425 ENDIF 4426C 4427 RETURN 4428 END 4429 SUBROUTINE DPSYM2(Y,X,N,ICASPL,IDATSW,MAXOBV, 4430 1 NUMVAR,NCURVE,NHIGH, 4431 1 TAG1,XTEMP1,XTEMP2, 4432 1 Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR) 4433C 4434C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS 4435C THAT WILL DEFINE A SYMMETRY PLOT. 4436C WRITTEN BY--ALAN HECKERT 4437C STATISTICAL ENGINEERING DIVISION 4438C INFORMATION TECHNOLOGY LABORATORY 4439C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 4440C GAITHERSBURG, MD 20899-8980 4441C PHONE--301-975-2899 4442C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 4443C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 4444C LANGUAGE--ANSI FORTRAN (1977) 4445C VERSION NUMBER--86/7 4446C ORIGINAL VERSION--APRIL 1986. 4447C UPDATED --NOVEMBER 2011. SUPPORT FOR HIGHLIGHTED CASE 4448C 4449C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 4450C 4451 CHARACTER*4 ICASPL 4452 CHARACTER*4 IDATSW 4453 CHARACTER*4 IBUGG3 4454 CHARACTER*4 ISUBRO 4455 CHARACTER*4 IERROR 4456C 4457 CHARACTER*4 IWRIT2 4458 CHARACTER*4 ISUBN1 4459 CHARACTER*4 ISUBN2 4460C 4461C--------------------------------------------------------------------- 4462C 4463 DIMENSION Y(*) 4464 DIMENSION X(*) 4465 DIMENSION Y2(*) 4466 DIMENSION X2(*) 4467 DIMENSION D2(*) 4468 DIMENSION TAG1(*) 4469 DIMENSION XTEMP1(*) 4470 DIMENSION XTEMP2(*) 4471C 4472C-----COMMON---------------------------------------------------------- 4473C 4474 INCLUDE 'DPCOP2.INC' 4475C 4476C-----START POINT----------------------------------------------------- 4477C 4478 ISUBN1='DPSY' 4479 ISUBN2='M2 ' 4480 IERROR='NO' 4481C 4482 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'SYM2')THEN 4483 WRITE(ICOUT,999) 4484 CALL DPWRST('XXX','BUG ') 4485 WRITE(ICOUT,71) 4486 71 FORMAT('***** AT THE BEGINNING OF DPSYM2--') 4487 CALL DPWRST('XXX','BUG ') 4488 WRITE(ICOUT,72)ICASPL,IDATSW,N,NPLOTV,N2,NUMVAR 4489 72 FORMAT('ICASPL,IDATSW,N,NPLOTV,N2,NUMVAR = ',2(A4,2X),4I8) 4490 CALL DPWRST('XXX','BUG ') 4491 IF(N.GT.0)THEN 4492 DO85I=1,N 4493 WRITE(ICOUT,86)I,Y(I),X(I) 4494 86 FORMAT('I,Y(I),X(I) = ',I8,2G15.7) 4495 CALL DPWRST('XXX','BUG ') 4496 85 CONTINUE 4497 ENDIF 4498 ENDIF 4499C 4500C ******************************************** 4501C ** STEP 1-- ** 4502C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 4503C ******************************************** 4504C 4505 IF(N.LT.2)THEN 4506 WRITE(ICOUT,999) 4507 999 FORMAT(1X) 4508 CALL DPWRST('XXX','BUG ') 4509 WRITE(ICOUT,31) 4510 31 FORMAT('***** ERROR IN SYMMETRY PLOT--') 4511 CALL DPWRST('XXX','BUG ') 4512 WRITE(ICOUT,32) 4513 32 FORMAT(' THE NUMBER OF OBSERVATIONS WAS LESS THAN TWO.') 4514 CALL DPWRST('XXX','BUG ') 4515 WRITE(ICOUT,34)N 4516 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS = ',I6) 4517 CALL DPWRST('XXX','BUG ') 4518 WRITE(ICOUT,999) 4519 CALL DPWRST('XXX','BUG ') 4520 IERROR='YES' 4521 GOTO9000 4522 ENDIF 4523C 4524 HOLD=Y(1) 4525 DO60I=1,N 4526 IF(Y(I).NE.HOLD)GOTO69 4527 60 CONTINUE 4528 WRITE(ICOUT,999) 4529 CALL DPWRST('XXX','BUG ') 4530 WRITE(ICOUT,31) 4531 CALL DPWRST('XXX','BUG ') 4532 WRITE(ICOUT,62) 4533 62 FORMAT(' ALL INPUT VERTICAL AXIS ELEMENTS') 4534 CALL DPWRST('XXX','BUG ') 4535 WRITE(ICOUT,63)HOLD 4536 63 FORMAT(' ARE IDENTICALLY EQUAL TO ',G15.7) 4537 CALL DPWRST('XXX','BUG ') 4538 WRITE(ICOUT,999) 4539 CALL DPWRST('XXX','BUG ') 4540 IERROR='YES' 4541 GOTO9000 4542 69 CONTINUE 4543C 4544C ************************************** 4545C ** STEP 4-- ** 4546C ** BRANCH TO THE APPROPRIATE CASE ** 4547C ** AND DETERMINE PLOT COORDINATES ** 4548C ************************************** 4549C 4550 IF(IDATSW.EQ.'RAW')THEN 4551C 4552C **************************************** 4553C ** STEP 4.1-- ** 4554C ** DETERMINE PLOT COORDINATES ** 4555C ** FOR THE 1-VARIABLE CASE ** 4556C ** (THAT IS, FOR THE RAW DATA CASE) ** 4557C **************************************** 4558C 4559 IWRIT2='OFF' 4560 CALL MEDIAN(Y,N,IWRIT2,XTEMP1,MAXOBV,XMED,IBUGG3,IERROR) 4561C 4562 IF(NHIGH.EQ.0)THEN 4563 CALL SORT(Y,N,XTEMP1) 4564 NHALFP=(N+1)/2 4565 DO1110I=1,NHALFP 4566 IREV=N-I+1 4567 Y2(N2+I)=XTEMP1(IREV)-XMED 4568 X2(N2+I)=XMED-XTEMP1(I) 4569 D2(N2+I)=REAL(NCURVE) 4570 1110 CONTINUE 4571 N2=N2+NHALFP 4572 NPLOTV=2 4573 ELSE 4574C 4575C HIGHLIGHT CASE: BASE HIGHLIGHTING ON MAXIMUM OF 4576C THE TWO POINTS THAT GENERATE A SINGLE 4577C PLOT POINT. 4578C 4579 CALL SORTC(Y,TAG1,N,XTEMP1,XTEMP2) 4580 NHALFP=(N+1)/2 4581 DO1210I=1,NHALFP 4582 IREV=N-I+1 4583 Y2(N2+I)=XTEMP1(IREV)-XMED 4584 X2(N2+I)=XMED-XTEMP1(I) 4585 D2(N2+I)=MAX(XTEMP2(I),XTEMP2(IREV)) 4586 1210 CONTINUE 4587 N2=N2+NHALFP 4588 NPLOTV=2 4589 ENDIF 4590 ELSEIF(IDATSW.EQ.'FREQ')THEN 4591C 4592C ******************************************** 4593C ** STEP 4.2-- ** 4594C ** DETERMINE PLOT COORDINATES ** 4595C ** FOR THE 2-VARIABLE CASE ** 4596C ** (THAT IS, FOR THE GROUPED DATA CASE) ** 4597C ******************************************** 4598C 4599 CALL SORTC(X,Y,N,D2,Y2) 4600C 4601 SUM=0.0 4602 DO2110I=1,N 4603 SUM=SUM+Y(I) 4604 2110 CONTINUE 4605 NTOT=INT(SUM+0.5) 4606C 4607 IF(NTOT.GT.1000)THEN 4608 IERROR='YES' 4609 WRITE(ICOUT,999) 4610 CALL DPWRST('XXX','BUG ') 4611 WRITE(ICOUT,2111) 4612 2111 FORMAT('***** ERROR IN DPSYM2--') 4613 CALL DPWRST('XXX','BUG ') 4614 WRITE(ICOUT,2113) 4615 2113 FORMAT(' FOR THE 2-VARIABLE (GROUPED) CASE, THE') 4616 CALL DPWRST('XXX','BUG ') 4617 WRITE(ICOUT,2114) 4618 2114 FORMAT(' UNGROUPED NUMBER OF OBSERVATIONS IS TOO ', 4619 1 'LARGE.') 4620 CALL DPWRST('XXX','BUG ') 4621 WRITE(ICOUT,2116)NTOT 4622 2116 FORMAT(' NTOT = ',I8) 4623 CALL DPWRST('XXX','BUG ') 4624 GOTO9000 4625 ENDIF 4626C 4627 K=0 4628 DO2121I=1,N 4629 NI=INT(Y2(I)+0.5) 4630 IF(NI.LE.0)GOTO2121 4631 DO2122J=1,NI 4632 K=K+1 4633 X2(K)=D2(I) 4634 2122 CONTINUE 4635 2121 CONTINUE 4636C 4637 IWRIT2='OFF' 4638 MAXND2=1000 4639 CALL MEDIAN(X2,K,IWRIT2,D2,MAXND2,XMED,IBUGG3,IERROR) 4640 CALL SORT(X2,K,D2) 4641C 4642 KHALFP=(K+1)/2 4643 DO2130I=1,KHALFP 4644 IREV=K-I+1 4645 Y2(I)=D2(IREV)-XMED 4646 X2(I)=XMED-D2(I) 4647 2130 CONTINUE 4648 DO2140I=1,KHALFP 4649 D2(I)=1.0 4650 2140 CONTINUE 4651 N2=KHALFP 4652 NPLOTV=2 4653 ELSE 4654 WRITE(ICOUT,999) 4655 CALL DPWRST('XXX','BUG ') 4656 WRITE(ICOUT,31) 4657 CALL DPWRST('XXX','BUG ') 4658 WRITE(ICOUT,1012) 4659 1012 FORMAT(' IDATSW SHOULD BE EITHER') 4660 CALL DPWRST('XXX','BUG ') 4661 WRITE(ICOUT,1013) 4662 1013 FORMAT(' RAW OR FREQ, BUT IS NEITHER.') 4663 CALL DPWRST('XXX','BUG ') 4664 WRITE(ICOUT,1014)IDATSW 4665 1014 FORMAT(' IDATSW = ',A4) 4666 CALL DPWRST('XXX','BUG ') 4667 IERROR='YES' 4668 GOTO9000 4669 ENDIF 4670 GOTO9000 4671C 4672C ***************** 4673C ** STEP 90-- ** 4674C ** EXIT ** 4675C ***************** 4676C 4677 9000 CONTINUE 4678 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'SYM2')THEN 4679 WRITE(ICOUT,999) 4680 CALL DPWRST('XXX','BUG ') 4681 WRITE(ICOUT,9011) 4682 9011 FORMAT('***** AT THE END OF DPSYM2--') 4683 CALL DPWRST('XXX','BUG ') 4684 WRITE(ICOUT,9012)ICASPL,IDATSW,N2,IERROR 4685 9012 FORMAT('ICASPL,IDATSW,N2,IERROR = ',A4,2X,A4,I8,2X,A4) 4686 CALL DPWRST('XXX','BUG ') 4687 WRITE(ICOUT,9013)N,NHALFP,NTOT,K,KHALFP 4688 9013 FORMAT('N,NHALFP,NTOT,K,KHALFP = ',5I8) 4689 CALL DPWRST('XXX','BUG ') 4690 WRITE(ICOUT,9014)N2,NPLOTV 4691 9014 FORMAT('N2,NPLOTV = ',2I8) 4692 CALL DPWRST('XXX','BUG ') 4693 DO9015I=1,N2 4694 WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I) 4695 9016 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) 4696 CALL DPWRST('XXX','BUG ') 4697 9015 CONTINUE 4698 ENDIF 4699C 4700 RETURN 4701 END 4702 SUBROUTINE DPSYST(IANS,IANSLC,IWIDTH, 4703 1 IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 4704 1 IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, 4705 1 IBUGD2,ISUBRO,IFOUND,IERROR) 4706C 4707C PURPOSE--ENTER AN OPERATING SYSTEM COMMAND. NOTE THAT THIS COMMAND 4708C IS SITE AND HOST DEPENDENT. IT IS PROVIODED TO ACCOMODATE 4709C THOSE OPERATING SYSTEMS THAT ALLOW HOOKS INTO THE OPERATING 4710C SYSTEM. IT IS LEFT UP TO THE LOCAL IMPLEMENTOR AS TO HOW 4711C THIS COMMAND WILL BE USED. 4712C 4713C THE CALL TO THE OPERATING SYSTEM IS DONE BELOW IN 4714C CALL SCLCMD 4715C IF YOUR COMPUTER DOES NOT ALLOW SUCH A HOOK, DO NOTHING. 4716C IF YOUR COMPUTER DOES ALLOW SUCH A HOOK, THEN THE 4717C IMPLEMENTER SHOULD REPLACE THE CALL TO SCLCMD 4718C (WHICH IS APPROPRIATE ONLY FOR CDC CYBER NOS/VE) 4719C WITH THE APPROPRIATE SYSTEM CALL; 4720C THE LINE SHOULD ALSO BE UN-COMMENTED OUT. 4721C 4722C NOTE THAT IF A COMMAND IS PASSED TO THE OPERATING SYSTEM, 4723C DATAPLOT WILL DO NO ERROR CHECKING. IT WILL SIMPLY PASS 4724C THE COMMAND AS GIVEN. 4725C 4726C WRITTEN BY--ALAN HECKERT 4727C STATISTICAL ENGINEERING DIVISION 4728C INFORMATION TECHNOLOGY LABORATORY 4729C NATIONAL INSTITTE OF STANDARDS AND TECHNOLOGY 4730C GAITHERSBURG, MD 20899 4731C PHONE--301-975-2899 4732C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 4733C OF THE NATIONAL BUREAU OF STANDARDS. 4734C LANGUAGE--ANSI FORTRAN (1977) 4735C HOST DEPENDENT 4736C VERSION NUMBER--89.3 4737C ORIGINAL VERSION--FEBRUARY 1989. 4738C UPDATED --MARCH 1990. USE "IANSLC" SINCE SOME SYSTEMS 4739C ARE CASE SENSITIVE (E.G., UNIX) 4740C UPDATED --APRIL 1992. DO OPERATING SPECIFIC CALL IN DPSYS2 4741C UPDATED --APRIL 1992. ADD ISUBRO IN CALL TO DPSYS2 4742C UPDATED --APRIL 1992. ADD UNIX & DOS 4743C UPDATED --APRIL 1992. ADD OTG CHECK 4744C UPDATED --APRIL 1992. AUGMENT ERROR INFO 4745C UPDATED --APRIL 2018. SINCE THE PLATFORM DEPENDENT 4746C CODE IS IN DPSYS2, RECODE THIS 4747C ROUTINE AND MOVE IT OUT OF 4748C dp1.F. 4749C 4750C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- 4751C 4752 CHARACTER*4 IANS 4753 CHARACTER*4 IANSLC 4754C 4755 CHARACTER*4 ITEXTE 4756 CHARACTER*4 ITEXTF 4757 CHARACTER*4 IHNAME 4758 CHARACTER*4 IHNAM2 4759 CHARACTER*4 IUSE 4760 CHARACTER*4 IBUGD2 4761 CHARACTER*4 ISUBRO 4762 CHARACTER*4 IFOUND 4763 CHARACTER*4 IERROR 4764 CHARACTER*4 IFUNC 4765 CHARACTER*1 IREPCH 4766C 4767 DIMENSION IANS(*) 4768 DIMENSION IANSLC(*) 4769C 4770 PARAMETER(MAXCH=256) 4771 DIMENSION ITEXTE(MAXCH) 4772 DIMENSION ITEXTF(MAXCH) 4773 CHARACTER*256 ITEXT2 4774 CHARACTER*256 ITEXT3 4775C 4776 DIMENSION IHNAME(*) 4777 DIMENSION IHNAM2(*) 4778 DIMENSION IUSE(*) 4779 DIMENSION IVALUE(*) 4780 DIMENSION VALUE(*) 4781 DIMENSION IVSTAR(*) 4782 DIMENSION IVSTOP(*) 4783 DIMENSION IFUNC(*) 4784C 4785C-----COMMON---------------------------------------------------------- 4786C 4787 INCLUDE 'DPCOHO.INC' 4788 INCLUDE 'DPCOBE.INC' 4789 INCLUDE 'DPCOP2.INC' 4790C 4791C-----START POINT----------------------------------------------------- 4792C 4793 IFOUND='NO' 4794 IERROR='NO' 4795C 4796 J2=0 4797C 4798 IF(IBUGD2.EQ.'ON'.OR.ISUBRO.EQ.'SYST')THEN 4799 WRITE(ICOUT,999) 4800 999 FORMAT(1X) 4801 CALL DPWRST('XXX','BUG ') 4802 WRITE(ICOUT,51) 4803 51 FORMAT('***** AT THE BEGINNING OF DPSYST--') 4804 CALL DPWRST('XXX','BUG ') 4805 WRITE(ICOUT,53)IBUGD2,ISUBRO,IWIDTH,NUMNAM 4806 53 FORMAT('IBUGD2,ISUBRO,IWIDTH,NUMNAM= ',2(A4,2X),2I8) 4807 CALL DPWRST('XXX','BUG ') 4808 WRITE(ICOUT,54)(IANS(I),I=1,MIN(255,IWIDTH)) 4809 54 FORMAT('(IANS(I),I=1,IWIDTH) = ',255A4) 4810 CALL DPWRST('XXX','BUG ') 4811 DO76I=1,NUMNAM 4812 WRITE(ICOUT,77)I,IHNAME(I),IHNAM2(I),IUSE(I), 4813 1 IVALUE(I),VALUE(I) 4814 77 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I)= ', 4815 1 I8,3(2X,A4),I8,G15.7) 4816 CALL DPWRST('XXX','BUG ') 4817 76 CONTINUE 4818 ENDIF 4819C 4820C ***************************************************** 4821C ** STEP 1-- ** 4822C ** EXTRACT THE TEXT STRING FROM THE COMMAND LINE ** 4823C ***************************************************** 4824C 4825C ***************************************** 4826C ** STEP 1.1-- ** 4827C ** DETERMINE THE COMMAND ** 4828C ** (SYSTEM OR SYST) AND ITS LOCATION ** 4829C ** ON THE LINE. ** 4830C ** DETERMINE THE START POSITION ** 4831C ** (XSTART) OF THE FIRST CHARACTER ** 4832C ** FOR THE STRING TO BE PRINTED. ** 4833C ***************************************** 4834C 4835C CHECK FOR "SYSTEM" FIRST 4836C 4837 DO1115I=1,IWIDTH 4838 IP1=I+1 4839 IP2=I+2 4840 IP3=I+3 4841 IP4=I+4 4842 IP5=I+5 4843 IP6=I+6 4844C 4845 IF(IP6.GT.IWIDTH)GOTO1115 4846 ISTART=IP6+1 4847 IF(IANS(I).EQ.'S'.AND.IANS(IP1).EQ.'Y'.AND. 4848 1 IANS(IP2).EQ.'S'.AND.IANS(IP3).EQ.'T'.AND. 4849 1 IANS(IP4).EQ.'E'.AND.IANS(IP5).EQ.'M'.AND. 4850 1 IANS(IP6).EQ.' ')GOTO1190 4851 1115 CONTINUE 4852C 4853C CHECK FOR "SYST" 4854C 4855 DO1125I=1,IWIDTH 4856 IP1=I+1 4857 IP2=I+2 4858 IP3=I+3 4859 IP4=I+4 4860 IP5=I+5 4861C 4862 IF(IP4.GT.IWIDTH)GOTO1125 4863 ISTART=IP5 4864 IF(IANS(I).EQ.'S'.AND.IANS(IP1).EQ.'Y'.AND. 4865 1 IANS(IP2).EQ.'S'.AND.IANS(IP3).EQ.'T'.AND. 4866 1 IANS(IP4).EQ.' ')GOTO1190 4867 1125 CONTINUE 4868C 4869CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1992 4870C CHECK FOR "UNIX" 4871C 4872 DO1135I=1,IWIDTH 4873 IP1=I+1 4874 IP2=I+2 4875 IP3=I+3 4876 IP4=I+4 4877 IP5=I+5 4878C 4879 IF(IP4.GT.IWIDTH)GOTO1135 4880 ISTART=IP5 4881 IF(IANS(I).EQ.'U'.AND.IANS(IP1).EQ.'N'.AND. 4882 1 IANS(IP2).EQ.'I'.AND.IANS(IP3).EQ.'X'.AND. 4883 1 IANS(IP4).EQ.' ')GOTO1190 4884 1135 CONTINUE 4885C 4886CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1992 4887C CHECK FOR "DOS" 4888C 4889 DO1145I=1,IWIDTH 4890 IP1=I+1 4891 IP2=I+2 4892 IP3=I+3 4893 IP4=I+4 4894C 4895 IF(IP3.GT.IWIDTH)GOTO1145 4896 ISTART=IP4 4897 IF(IANS(I).EQ.'D'.AND.IANS(IP1).EQ.'O'.AND. 4898 1 IANS(IP2).EQ.'S'.AND.IANS(IP3).EQ.' ')GOTO1190 4899 1145 CONTINUE 4900C 4901CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 2018 4902C CHECK FOR "LUNIX" 4903C 4904 DO1155I=1,IWIDTH 4905 IP1=I+1 4906 IP2=I+2 4907 IP3=I+3 4908 IP4=I+4 4909 IP5=I+5 4910C 4911 IF(IP4.GT.IWIDTH)GOTO1155 4912 ISTART=IP5 4913 IF(IANS(I).EQ.'L'.AND.IANS(IP1).EQ.'I'.AND. 4914 1 IANS(IP2).EQ.'N'.AND.IANS(IP3).EQ.'U'.AND. 4915 1 IANS(IP4).EQ.'X'.AND.IANS(IP5).EQ.' ')GOTO1190 4916 1155 CONTINUE 4917C 4918C NO MATCH 4919C 4920 WRITE(ICOUT,999) 4921 CALL DPWRST('XXX','BUG ') 4922 WRITE(ICOUT,1181) 4923 1181 FORMAT('***** ERROR IN SYSTEM COMMAND--') 4924 CALL DPWRST('XXX','BUG ') 4925 WRITE(ICOUT,1182) 4926 1182 FORMAT(' COMMAND NOT EQUAL TO: SYSTEM, SYST, UNIX, LINUX ', 4927 1 'OR DOS.') 4928 CALL DPWRST('XXX','BUG ') 4929 IERROR='YES' 4930 GOTO9000 4931 1190 CONTINUE 4932C 4933C ********************************************************** 4934C ** STEP 1.2-- ** 4935C ** DEFINE THE STOP POSITION (ISTOP) FOR THE STRING. ** 4936C ********************************************************** 4937C 4938 IFOUND='YES' 4939C 4940 ISTOP=0 4941 IF(ISTART.LE.IWIDTH)THEN 4942 DO1220I=ISTART,IWIDTH 4943 IREV=IWIDTH-I+ISTART 4944 IF(IANS(IREV).NE.' ')THEN 4945 ISTOP=IREV 4946 GOTO1229 4947 ENDIF 4948 1220 CONTINUE 4949 1229 CONTINUE 4950 ENDIF 4951C 4952C ***************************************** 4953C ** STEP 1.3-- ** 4954C ** COPY OVER THE STRING OF INTEREST. ** 4955C ***************************************** 4956C 4957 IF(ISTART.GT.ISTOP .OR. ISTOP.EQ.0)THEN 4958 NCTEX=0 4959 ELSE 4960 ITEMP=ISTOP-ISTART+1 4961 IF(ITEMP.GT.MAXCH)ITEMP=MAXCH 4962 ISTOP=ISTART+ITEMP-1 4963C 4964 J=0 4965 DO1310I=ISTART,ISTOP 4966 J=J+1 4967 J2=J 4968 ITEXTE(J)=IANS(I) 4969 ITEXTF(J)=IANSLC(I) 4970 1310 CONTINUE 4971 NCTEX=J2 4972 ENDIF 4973C 4974C ****************************************************** 4975C ** STEP 1.4-- ** 4976C ** CALL THE SUBROUTINE DPREPL ** 4977C ** WHICH WILL SCAN THE STRING FOR ALL OCCURRANCES ** 4978C ** OF THE SUBSTRING VALU() ** 4979C ** AND REPLACE THEM BY THEIR LITERAL VALUES. ** 4980C ****************************************************** 4981C 4982 NCTEXT=NCTEX 4983 IF(NCTEXT.GE.1)THEN 4984 CALL DPREPL(ITEXTE,NCTEXT, 4985 1 IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 4986 1 IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, 4987 1 IBUGD2,IERROR) 4988 ENDIF 4989C 4990 IF(NCTEXT.GE.1)THEN 4991 DO1510I=1,NCTEXT 4992 ITEXT2(I:I)=ITEXTE(I)(1:1) 4993 1510 CONTINUE 4994 ENDIF 4995C 4996 NCTEXT=NCTEX 4997 IF(NCTEXT.GE.1)THEN 4998 CALL DPREPL(ITEXTF,NCTEXT, 4999 1 IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 5000 1 IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, 5001 1 IBUGD2,IERROR) 5002 ENDIF 5003 IF(NCTEXT.GE.1)THEN 5004 DO1610I=1,NCTEXT 5005 ITEXT3(I:I)=ITEXTF(I)(1:1) 5006 1610 CONTINUE 5007 ENDIF 5008C 5009C ***************************************** 5010C ** STEP 2-- ** 5011C ** CALL DPSYS2 TO EXECUTE THE COMMAND ** 5012C ***************************************** 5013C 5014C 2018/04: ALTHOUGH WINDOWS COMMANDS ARE NOT CASE SENSITIVE, 5015C ARGUMENTS MAY BE. SO USE LOWER CASE VARIANT FOR 5016C ALL SYSTEMS. 5017C 5018CCCCC IF(IOPSY1.EQ.'UNIX')THEN 5019 CALL DPSYS2(ITEXT3,NCTEXT,ISUBRO,IERROR) 5020CCCCC ELSE 5021CCCCC CALL DPSYS2(ITEXT2,NCTEXT,ISUBRO,IERROR) 5022CCCCC ENDIF 5023C 5024C ***************** 5025C ** STEP 90-- ** 5026C ** EXIT ** 5027C ***************** 5028C 5029 9000 CONTINUE 5030 IF(IBUGD2.EQ.'ON'.OR.ISUBRO.EQ.'SYST')THEN 5031 WRITE(ICOUT,999) 5032 CALL DPWRST('XXX','BUG ') 5033 WRITE(ICOUT,9011) 5034 9011 FORMAT('***** AT THE END OF DPSYST--') 5035 CALL DPWRST('XXX','BUG ') 5036 WRITE(ICOUT,9016)(ITEXTE(I),I=1,NCTEX) 5037 9016 FORMAT('(ITEXTE(I),I =1,NCTEX) = ',25A4) 5038 CALL DPWRST('XXX','BUG ') 5039 WRITE(ICOUT,9017)IFOUND,IERROR,IREPCH,NCTEXT,NCTEX 5040 9017 FORMAT('IFOUND,IERROR,IREPCH,NCTEXT,NCTEX = ', 5041 1 2(A4,2X),A1,2X,2I8) 5042 CALL DPWRST('XXX','BUG ') 5043 WRITE(ICOUT,9018)(ITEXT2(J:J),J=1,NCTEXT) 5044 9018 FORMAT('(ITEXT2(I),I=1,NCTEXT) = ',25A4) 5045 CALL DPWRST('XXX','BUG ') 5046 ENDIF 5047C 5048 RETURN 5049 END 5050 SUBROUTINE DPTAB1(IHEAD,NHEAD,CAPTN,NCAP,IFLAG1) 5051C 5052C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING 5053C TABULAR OUTPUT IN ASCII FORMAT. THIS ROUTINE IS USED 5054C TO INITIATE THE TABULAR OUTPUT. THE ONLY OPTIONAL ELEMENT 5055C IS THE CAPTION. 5056C INPUT ARGUMENTS--IHEAD = THE CHARACTER STRING CONTAINING 5057C THE TEXT FOR THE HEADER 5058C --NHEAD = THE INTEGER NUMBER THAT SPECIFIES 5059C THE NUMBER OF CHARACTERS IN THE 5060C HEADER. 5061C --CAPTN = THE CHARACTER STRING CONTAINING 5062C THE CAPTION. 5063C --NCAP = THE INTEGER NUMBER THAT SPECIFIES 5064C THE NUMBER OF CHARACTERS IN THE 5065C CAPTION. 5066C WRITTEN BY--JAMES J. FILLIBEN 5067C STATISTICAL ENGINEERING DIVISION 5068C INFORMATION TECHNOLOGY LABOARATORY 5069C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5070C GAITHERSBURG, MD 20899-8980 5071C PHONE--301-975-2855 5072C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5073C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5074C LANGUAGE--ANSI FORTRAN (1977) 5075C VERSION NUMBER--2009/3 5076C ORIGINAL VERSION--MARCH 2009. 5077C 5078C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5079C 5080 CHARACTER*(*) CAPTN 5081 CHARACTER*(*) IHEAD 5082C 5083 LOGICAL IFLAG1 5084 CHARACTER*10 IFORMT 5085C 5086C-----COMMON---------------------------------------------------------- 5087C 5088 INCLUDE 'DPCOP2.INC' 5089C 5090C-----START POINT----------------------------------------------------- 5091C 5092C STEP 1: WRITE A HEADER 5093C 5094 999 FORMAT(1X) 5095C 5096 IF(IFLAG1)THEN 5097 WRITE(ICOUT,999) 5098 CALL DPWRST('XXX','WRIT') 5099 ENDIF 5100C 5101 IF(NHEAD.GE.1)THEN 5102 IFORMT=' ' 5103 IFORMT(1:9)='(12X,A )' 5104 IF(NHEAD.GT.0 .AND. NHEAD.LE.99)THEN 5105 WRITE(IFORMT(7:8),'(I2)')NHEAD 5106 WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD) 5107 CALL DPWRST('XXX','WRIT') 5108 ENDIF 5109 WRITE(ICOUT,999) 5110 CALL DPWRST('XXX','WRIT') 5111 ENDIF 5112C 5113C STEP 2: START TABLE AND DEFINE A CAPTION 5114C 5115 IF(NCAP.GT.0 .AND. NCAP.LT.130)THEN 5116 IFORMT=' ' 5117 IFORMT(1:6)='(A )' 5118 WRITE(IFORMT(3:5),'(I3)')NCAP 5119 WRITE(ICOUT,IFORMT)CAPTN(1:NCAP) 5120 CALL DPWRST('XXX','WRIT') 5121 ENDIF 5122C 5123 RETURN 5124 END 5125 SUBROUTINE DPTABA(IHEAD,NHEAD,CAPTN,NCAP,IFLAG1) 5126C 5127C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING 5128C TABULAR OUTPUT IN ASCII FORMAT. THIS ROUTINE IS USED 5129C TO INITIATE THE TABULAR OUTPUT. THE ONLY OPTIONAL ELEMENT 5130C IS THE CAPTION. 5131C 5132C NOTE: THIS IS A SLIGHT VARIANT OF DPTAB1. DIFFERS 5133C IN POSITIONING OF "CAPTN" STRING. 5134C 5135C INPUT ARGUMENTS--IHEAD = THE CHARACTER STRING CONTAINING 5136C THE TEXT FOR THE HEADER 5137C --NHEAD = THE INTEGER NUMBER THAT SPECIFIES 5138C THE NUMBER OF CHARACTERS IN THE 5139C HEADER. 5140C --CAPTN = THE CHARACTER STRING CONTAINING 5141C THE CAPTION. 5142C --NCAP = THE INTEGER NUMBER THAT SPECIFIES 5143C THE NUMBER OF CHARACTERS IN THE 5144C CAPTION. 5145C WRITTEN BY--JAMES J. FILLIBEN 5146C STATISTICAL ENGINEERING DIVISION 5147C INFORMATION TECHNOLOGY LABOARATORY 5148C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5149C GAITHERSBURG, MD 20899-8980 5150C PHONE--301-975-2855 5151C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5152C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5153C LANGUAGE--ANSI FORTRAN (1977) 5154C VERSION NUMBER--2009/3 5155C ORIGINAL VERSION--MARCH 2009. 5156C 5157C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5158C 5159 CHARACTER*(*) CAPTN 5160 CHARACTER*(*) IHEAD 5161C 5162 LOGICAL IFLAG1 5163 CHARACTER*10 IFORMT 5164C 5165C-----COMMON---------------------------------------------------------- 5166C 5167 INCLUDE 'DPCOP2.INC' 5168C 5169C-----START POINT----------------------------------------------------- 5170C 5171C STEP 1: WRITE A HEADER 5172C 5173 999 FORMAT(1X) 5174C 5175 IF(IFLAG1)THEN 5176 WRITE(ICOUT,999) 5177 CALL DPWRST('XXX','WRIT') 5178 ENDIF 5179C 5180 IF(NHEAD.GE.1)THEN 5181 IFORMT=' ' 5182 IFORMT(1:9)='(12X,A )' 5183 WRITE(IFORMT(7:8),'(I2)')NHEAD 5184 WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD) 5185 CALL DPWRST('XXX','WRIT') 5186 ENDIF 5187C 5188C STEP 2: START TABLE AND DEFINE A CAPTION 5189C 5190 NSTRT=12 5191 NDIFF=NHEAD-NCAP 5192 IF(NDIFF.GE.2)THEN 5193 NDIFF=NDIFF/2 5194 NSTRT=NSTRT+NDIFF 5195 ENDIF 5196 IF(NCAP.GT.0)THEN 5197 IFORMT=' ' 5198 IFORMT(1:9)='( X,A )' 5199 WRITE(IFORMT(2:3),'(I2)')NSTRT 5200 WRITE(IFORMT(7:8),'(I2)')NCAP 5201 WRITE(ICOUT,IFORMT)CAPTN(1:NCAP) 5202 CALL DPWRST('XXX','WRIT') 5203 WRITE(ICOUT,999) 5204 CALL DPWRST('XXX','WRIT') 5205 ENDIF 5206C 5207 RETURN 5208 END 5209 SUBROUTINE DPTAB4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2,NMAX) 5210C 5211C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING 5212C TABULAR OUTPUT IN ASCII FORMAT. THIS ROUTINE IS USED TO 5213C GENERATE A HEADER ROW FOR A TABLE. YOU CAN ALSO OPTIONALLY 5214C ADD A RULE LINE BEFORE OR AFTER THE HEADER. 5215C 5216C INPUT ARGUMENTS--IVALUE = THE CHARACTER STRING ARRAY 5217C CONTAINING THE TEXT FOR THE 5218C HEADER VALUES. 5219C --NCHAR = THE INTEGER ARRAY THAT SPECIFIES 5220C THE NUMBER OF CHARACTERS IN THE 5221C HEADER VALUES. 5222C --NHEAD = THE INTEGER VALUE THAT SPECIFIES 5223C THE NUMBER OF HEADER VALUES. 5224C --IFLAG1 = A LOGICAL VALUE THAT SPECIFIES 5225C WHETHER A RULE LINE IS DRAWN BEFORE 5226C THE HEADER. 5227C --IFLAG2 = A LOGICAL VALUE THAT SPECIFIES 5228C WHETHER A RULE LINE IS DRAWN AFTER 5229C THE HEADER. 5230C --NMAX = NUMBER OF CHARACTERS FOR "RULE" LINE 5231C WRITTEN BY--ALAN HECKERT 5232C STATISTICAL ENGINEERING DIVISION 5233C INFORMATION TECHNOLOGY LABOARATORY 5234C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5235C GAITHERSBURG, MD 20899-8980 5236C PHONE--301-975-2899 5237C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5238C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5239C LANGUAGE--ANSI FORTRAN (1977) 5240C VERSION NUMBER--2009/3 5241C ORIGINAL VERSION--MARCH 2009. 5242C 5243C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5244C 5245 CHARACTER*(*) IVALUE(NHEAD) 5246 INTEGER NCHAR(NHEAD) 5247C 5248 PARAMETER (MAXHED=1024) 5249 INTEGER IWIDTH(MAXHED) 5250 INTEGER NUMDIG(MAXHED) 5251 CHARACTER*8 ALIGN(MAXHED) 5252 CHARACTER*8 VALIGN(MAXHED) 5253 COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN 5254C 5255 CHARACTER*255 IATEMP 5256C 5257 LOGICAL IFLAG1 5258 LOGICAL IFLAG2 5259C 5260 CHARACTER*20 IFORMT 5261 CHARACTER*160 ISTR 5262C 5263C-----COMMON---------------------------------------------------------- 5264C 5265 INCLUDE 'DPCOP2.INC' 5266C 5267C-----START POINT----------------------------------------------------- 5268C 5269CC999 FORMAT(1X) 5270C 5271C STEP 1: PRINT INITIAL RULE LINE 5272C 5273 IF(NHEAD.GE.1)THEN 5274 IF(IFLAG1 .AND. NMAX.GT.0)THEN 5275 IFORMT=' ' 5276 DO8010I=1,MIN(NMAX,255) 5277 IATEMP(I:I)='-' 5278 8010 CONTINUE 5279 IFORMT(1:6)='(A )' 5280 WRITE(IFORMT(3:5),'(I3)')NMAX 5281 WRITE(ICOUT,IFORMT)IATEMP(1:NMAX) 5282 CALL DPWRST('XXX','WRIT') 5283 ENDIF 5284C 5285C STEP 2: PRINT TEXT FIELDS 5286C 5287 IFORMT=' ' 5288 NCSTR=0 5289 DO8020I=1,NHEAD 5290 IF(NCHAR(I).GE.1)THEN 5291 NCSTR=NCSTR+1 5292 NCSTR2=NCSTR+NCHAR(I)-1 5293 IFORMT(1:5)='(A )' 5294 WRITE(IFORMT(3:4),'(I2)')NCHAR(I) 5295 WRITE(ISTR(NCSTR:NCSTR2),IFORMT)IVALUE(I)(1:NCHAR(I)) 5296 NCSTR=NCSTR2 5297 ENDIF 5298 8020 CONTINUE 5299 IFORMT=' ' 5300 IFORMT(1:6)='(A )' 5301 WRITE(IFORMT(3:5),'(I3)')NCSTR 5302 IF(NCSTR.GE.1)THEN 5303 WRITE(ICOUT,IFORMT)ISTR(1:NCSTR) 5304 CALL DPWRST('XXX','WRIT') 5305 ENDIF 5306C 5307C STEP 3: PRINT TRAILING RULE LINE 5308C 5309 IF(IFLAG2 .AND. NMAX.GT.0)THEN 5310 IFORMT=' ' 5311 DO8030I=1,NMAX 5312 IATEMP(I:I)='-' 5313 8030 CONTINUE 5314 IFORMT(1:6)='(A )' 5315 WRITE(IFORMT(3:5),'(I3)')NMAX 5316 WRITE(ICOUT,IFORMT)IATEMP(1:NMAX) 5317 CALL DPWRST('XXX','WRIT') 5318 ENDIF 5319C 5320 ENDIF 5321C 5322 RETURN 5323 END 5324 SUBROUTINE DPTA44(IVALUE,NCHAR,NHEAD,NCOLSP,IFLAG1,IFLAG2,NMAX) 5325C 5326C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING 5327C TABULAR OUTPUT IN ASCII FORMAT. THIS ROUTINE IS USED TO 5328C GENERATE A HEADER ROW FOR A TABLE. YOU CAN ALSO OPTIONALLY 5329C ADD A RULE LINE BEFORE OR AFTER THE HEADER. 5330C 5331C THIS IS A MODIFIED VERSION OF DPTAB4 THAT ALLOWS 5332C HEADERS THAT SPAN MULTIPLE COLUMNS. 5333C 5334C INPUT ARGUMENTS--IVALUE = THE CHARACTER STRING ARRAY 5335C CONTAINING THE TEXT FOR THE 5336C HEADER VALUES. 5337C --NCHAR = THE INTEGER ARRAY THAT SPECIFIES 5338C THE NUMBER OF CHARACTERS IN THE 5339C HEADER VALUES. 5340C --NHEAD = THE INTEGER VALUE THAT SPECIFIES 5341C THE NUMBER OF HEADER VALUES. 5342C --NCOLSP = THE INTEGER ARRAY THAT SPECIFIES 5343C THE NUMBER OF SPANNING COLUMNS. 5344C --IFLAG1 = A LOGICAL VALUE THAT SPECIFIES 5345C WHETHER A RULE LINE IS DRAWN BEFORE 5346C THE HEADER. 5347C --IFLAG2 = A LOGICAL VALUE THAT SPECIFIES 5348C WHETHER A RULE LINE IS DRAWN AFTER 5349C THE HEADER. 5350C --NMAX = NUMBER OF CHARACTERS FOR "RULE" LINE 5351C WRITTEN BY--ALAN HECKERT 5352C STATISTICAL ENGINEERING DIVISION 5353C INFORMATION TECHNOLOGY LABOARATORY 5354C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5355C GAITHERSBURG, MD 20899-8980 5356C PHONE--301-975-2899 5357C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5358C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5359C LANGUAGE--ANSI FORTRAN (1977) 5360C VERSION NUMBER--2011/1 5361C ORIGINAL VERSION--JANUARY 2011. 5362C 5363C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5364C 5365 CHARACTER*(*) IVALUE(NHEAD) 5366 INTEGER NCHAR(NHEAD) 5367 INTEGER NCOLSP(NHEAD) 5368C 5369 PARAMETER (MAXHED=1024) 5370 INTEGER IWIDTH(MAXHED) 5371 INTEGER NUMDIG(MAXHED) 5372 CHARACTER*8 ALIGN(MAXHED) 5373 CHARACTER*8 VALIGN(MAXHED) 5374 COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN 5375C 5376 CHARACTER*255 IATEMP 5377C 5378 LOGICAL IFLAG1 5379 LOGICAL IFLAG2 5380C 5381 CHARACTER*20 IFORMT 5382 CHARACTER*160 ISTR 5383C 5384C-----COMMON---------------------------------------------------------- 5385C 5386 INCLUDE 'DPCOP2.INC' 5387C 5388C-----START POINT----------------------------------------------------- 5389C 5390CC999 FORMAT(1X) 5391C 5392C STEP 1: PRINT INITIAL RULE LINE 5393C 5394 IF(NHEAD.GE.1)THEN 5395 IF(IFLAG1 .AND. NMAX.GT.0)THEN 5396 IFORMT=' ' 5397 DO8010I=1,MIN(NMAX,255) 5398 IATEMP(I:I)='-' 5399 8010 CONTINUE 5400 IFORMT(1:6)='(A )' 5401 WRITE(IFORMT(3:5),'(I3)')NMAX 5402 WRITE(ICOUT,IFORMT)IATEMP(1:NMAX) 5403 CALL DPWRST('XXX','WRIT') 5404 ENDIF 5405C 5406C STEP 2: PRINT TEXT FIELDS 5407C 5408 IFORMT=' ' 5409 NCSTR=0 5410 DO8020I=1,NHEAD 5411 IF(NCHAR(I).GE.1 .AND. NCOLSP(I).GT.0)THEN 5412 NCSTR=NCSTR+1 5413 NCSTR2=NCSTR+NCHAR(I)-1 5414 IFORMT(1:5)='(A )' 5415 WRITE(IFORMT(3:4),'(I2)')NCHAR(I) 5416 WRITE(ISTR(NCSTR:NCSTR2),IFORMT)IVALUE(I)(1:NCHAR(I)) 5417 NCSTR=NCSTR2 5418 ENDIF 5419 8020 CONTINUE 5420 IFORMT=' ' 5421 IFORMT(1:6)='(A )' 5422 WRITE(IFORMT(3:5),'(I3)')NCSTR 5423 IF(NCSTR.GE.1)THEN 5424 WRITE(ICOUT,IFORMT)ISTR(1:NCSTR) 5425 CALL DPWRST('XXX','WRIT') 5426 ENDIF 5427C 5428C STEP 3: PRINT TRAILING RULE LINE 5429C 5430 IF(IFLAG2 .AND. NMAX.GT.0)THEN 5431 IFORMT=' ' 5432 DO8030I=1,NMAX 5433 IATEMP(I:I)='-' 5434 8030 CONTINUE 5435 IFORMT(1:6)='(A )' 5436 WRITE(IFORMT(3:5),'(I3)')NMAX 5437 WRITE(ICOUT,IFORMT)IATEMP(1:NMAX) 5438 CALL DPWRST('XXX','WRIT') 5439 ENDIF 5440C 5441 ENDIF 5442C 5443 RETURN 5444 END 5445 SUBROUTINE DPTAB5(IVALUE,NCHAR,AVALUE,NHEAD,IFLAG1,NMAX,NTOT, 5446 1 ICSVWR) 5447C 5448C PURPOSE--THIS ROUTINE IS A UTILITY ROUTINE FOR CREATING 5449C TABULAR OUTPUT IN ASCII FORMAT. THIS ROUTINE IS USED TO 5450C GENERATE A DATA ROW FOR A TABLE. THE FIRST FIELD CAN 5451C BE A TEXT VALUE (FOR A ROW LABEL). 5452C 5453C INPUT ARGUMENTS--IVALUE = THE CHARACTER STRING CONTAINING 5454C THE TEXT FOR THE FIRST COLUMN. 5455C --NCHAR = THE INTEGER ARRAY THAT SPECIFIES 5456C THE NUMBER OF CHARACTERS IN THE 5457C FIRST TEXT FIELD. 5458C --AVALUE = A REAL ARRAY CONTAINING THE DATA 5459C TO BE GENERATED. 5460C --NHEAD = THE INTEGER VALUE THAT SPECIFIES 5461C THE NUMBER OF NUMERIC VALUES. 5462C --IFLAG1 = A LOGICAL VALUE THAT SPECIFIES WHETHER 5463C A RULE LINE WILL BE PRINTED AFTER THE 5464C ROW 5465C --NMAX = NUMBER OF CHARACTERS IN RULE LINE 5466C --NTOT = AN INTEGER ARRAY CONTAINING THE TOTAL 5467C NUMBER OF CHARACTERS IN EACH FIELD 5468C WRITTEN BY--ALAN HECKERT 5469C STATISTICAL ENGINEERING DIVISION 5470C INFORMATION TECHNOLOGY LABOARATORY 5471C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5472C GAITHERSBURG, MD 20899-8980 5473C PHONE--301-975-2899 5474C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5475C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5476C LANGUAGE--ANSI FORTRAN (1977) 5477C VERSION NUMBER--2009/3 5478C ORIGINAL VERSION--MARCH 2009. 5479C UPDATED --APRIL 2009. ADDITIONAL FORMATTING OPTIONS 5480C UPDATED --APRIL 2015. SUPPORT HORIZONTAL ALIGNMENT 5481C (LEFT, CENTER, RIGHT) 5482C UPDATED --FEBRUARY 2020. OPTION FOR WRITING CVS FILES 5483C (FOR IMPORTING INTO OTHER 5484C PROGRAMS) 5485C 5486C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5487C 5488 CHARACTER*(*) IVALUE 5489 CHARACTER*4 ICSVWR 5490 REAL AVALUE(NHEAD) 5491 INTEGER NTOT(*) 5492 INTEGER NCHAR 5493C 5494 LOGICAL IFLAG1 5495C 5496 PARAMETER (MAXHED=1024) 5497 INTEGER IWIDTH(MAXHED) 5498 INTEGER NUMDIG(MAXHED) 5499 CHARACTER*8 ALIGN(MAXHED) 5500 CHARACTER*8 VALIGN(MAXHED) 5501 COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN 5502C 5503 CHARACTER*20 IFORMT 5504 CHARACTER*240 ISTR 5505 CHARACTER*255 IATEMP 5506C 5507C-----COMMON---------------------------------------------------------- 5508C 5509 INCLUDE 'DPCOP2.INC' 5510C 5511C-----START POINT----------------------------------------------------- 5512C 5513C STEP 1: PRINT ROW LABEL IF REQUESTED 5514C 5515 NCSTR=0 5516 ISTR=' ' 5517 ICNT=0 5518 IF(NCHAR.GT.0)THEN 5519 ICNT=ICNT+1 5520 IF(ALIGN(ICNT).EQ.'l')THEN 5521 ISTR(NCSTR+1:NCSTR+NCHAR)=IVALUE(1:NCHAR) 5522 NCSTR=NCSTR+NCHAR 5523 IF(NTOT(ICNT).GT.NCHAR)THEN 5524 NCSTR=NCSTR+1 5525 NCSTR2=NCSTR+(NTOT(ICNT)-NCHAR)-1 5526 ISTR(NCSTR:NCSTR2)=' ' 5527 NCSTR=NCSTR2 5528 ENDIF 5529 ELSEIF(ALIGN(ICNT).EQ.'r')THEN 5530 NSKIP=NTOT(ICNT) - NCHAR 5531 IF(NSKIP.GE.0)THEN 5532 ISTR(NSKIP+1:NSKIP+NCHAR)=IVALUE(1:NCHAR) 5533 NCSTR=NSKIP+NCHAR 5534 ELSE 5535 ISTR(1:NTOT(ICNT))=IVALUE(1:NTOT(ICNT)) 5536 NCSTR=NTOT(ICNT) 5537 ENDIF 5538 ELSEIF(ALIGN(ICNT).EQ.'c')THEN 5539 NSKIP=NTOT(ICNT) - NCHAR 5540 NSKIP=NSKIP/2 5541 IF(NSKIP.GE.0)THEN 5542 ISTR(NSKIP+1:NSKIP+NCHAR)=IVALUE(1:NCHAR) 5543 NCSTR=NSKIP+NCHAR 5544 ELSE 5545 ISTR(1:NTOT(ICNT))=IVALUE(1:NTOT(ICNT)) 5546 NCSTR=NTOT(ICNT) 5547 ENDIF 5548 ENDIF 5549 IF(ICSVWR.EQ.'ON')THEN 5550 NCSTR=NCSTR+1 5551 ISTR(NCSTR:NCSTR)=',' 5552 ENDIF 5553 ENDIF 5554C 5555C STEP 2: LOOP THROUGH THE NUMERIC FIELDS 5556C 5557C APRIL 2009: SUPPORT THE FOLLOWING FORMATTING OPTIONS 5558C 5559C NUMDIG(I) > 0 => Fyy.xx FORMAT 5560C NUMDIG(I) = 0 => I12 FORMAT 5561C NUMDIG(I) = -1 => BLANK 5562C NUMDIG(I) = -2 => G15.7 5563C NUMDIG(I) = -3 to -20 => Eyy.xx 5564C NUMDIG(I) = -99 => '**' 5565C 5566 IF(NHEAD.GE.1)THEN 5567C 5568 DO8000I=1,NHEAD 5569 ICNT=ICNT+1 5570 IFORMT=' ' 5571 ATEMP=AVALUE(I) 5572 IF(NUMDIG(I).GT.0)THEN 5573 NCHTOT=NTOT(ICNT) 5574 NCHDEC=NUMDIG(I) 5575 CALL GRTRR1(ATEMP,NCHTOT,NCHDEC,ISTR,NCSTR,ALIGN(ICNT)) 5576 ELSEIF(NUMDIG(I).EQ.0)THEN 5577 IF(ATEMP.GE.0.0)THEN 5578 ITEMP=INT(ATEMP+0.5) 5579 ELSE 5580 ITEMP=INT(ATEMP-0.5) 5581 ENDIF 5582 NCHTOT=NTOT(ICNT) 5583 CALL GRTRI1(ITEMP,NCHTOT,ISTR,NCSTR,ALIGN(ICNT)) 5584 ELSEIF(NUMDIG(I).EQ.-1)THEN 5585 NCSTR=NCSTR+1 5586 ISTR(NCSTR:NCSTR)=' ' 5587 ELSEIF(NUMDIG(I).EQ.-2)THEN 5588 NCSTR=NCSTR+1 5589 NCSTR2=NCSTR+14 5590 WRITE(ISTR(NCSTR:NCSTR2),'(G15.7)')ATEMP 5591 NCSTR=NCSTR2 5592 ELSEIF(NUMDIG(I).LT.-2 .AND. NUMDIG(I).GT.-20)THEN 5593 IXX=ABS(NUMDIG(I)) 5594 IYY=IXX+8 5595 NCSTR=NCSTR+1 5596 NCSTR2=NCSTR+IYY-1 5597 IFORMT='(E . )' 5598 WRITE(IFORMT(3:4),'(I2)')IYY 5599 WRITE(IFORMT(6:7),'(I2)')IXX 5600 WRITE(ISTR(NCSTR:NCSTR2),IFORMT)ATEMP 5601 NCSTR=NCSTR2 5602 ELSEIF(NUMDIG(I).EQ.-99)THEN 5603 NCHTOT=NTOT(ICNT) 5604 IF(NCHTOT.GT.2)THEN 5605 DO7010J=1,NCHTOT-2 5606 NCSTR=NCSTR+1 5607 ISTR(NCSTR:NCSTR)=' ' 5608 7010 CONTINUE 5609 ENDIF 5610 NCSTR=NCSTR+1 5611 NCSTR2=NCSTR+1 5612 ISTR(NCSTR:NCSTR2)='**' 5613 NCSTR=NCSTR2 5614 ELSE 5615 NCSTR=NCSTR+1 5616 ISTR(NCSTR:NCSTR)=' ' 5617 ENDIF 5618 IF(ICSVWR.EQ.'ON' .AND. I.LT.NHEAD)THEN 5619 NCSTR=NCSTR+1 5620 ISTR(NCSTR:NCSTR)=',' 5621 ENDIF 5622 8000 CONTINUE 5623C 5624 IF(NCSTR.GE.1)THEN 5625 IFORMT='(A )' 5626 WRITE(IFORMT(3:5),'(I3)')NCSTR 5627 WRITE(ICOUT,IFORMT)ISTR(1:NCSTR) 5628 CALL DPWRST('XXX','WRIT') 5629 ENDIF 5630C 5631C STEP 3: WRITE RULE LINE IF REQUESTED 5632C 5633 IF(IFLAG1 .AND. NMAX.GT.0)THEN 5634 IFORMT=' ' 5635 DO8030I=1,NMAX 5636 IATEMP(I:I)='-' 5637 8030 CONTINUE 5638 IFORMT(1:6)='(A )' 5639 WRITE(IFORMT(3:5),'(I3)')NMAX 5640 WRITE(ICOUT,IFORMT)IATEMP(1:NMAX) 5641 CALL DPWRST('XXX','WRIT') 5642 ENDIF 5643C 5644 ENDIF 5645C 5646 RETURN 5647 END 5648 SUBROUTINE DPTAB6(IHEAD,NHEAD,CAPTN,NCAP,NMAX,IFLAG1,IFLAG2) 5649C 5650C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING 5651C TABULAR OUTPUT IN ASCII FORMAT. THIS ROUTINE IS USED 5652C TO INITIATE THE TABULAR OUTPUT. IT WILL OPTIONALLY 5653C DRAW A RULE LINE BEFORE AND/OR AFTER THE TITLE. 5654C IS THE CAPTION. THIS IS A VARIANT OF DPTAB1 (THIS 5655C ROUTINE ALLOWS THE RULE LINES). 5656C INPUT ARGUMENTS--IHEAD = THE CHARACTER STRING CONTAINING 5657C THE TEXT FOR THE HEADER 5658C --NHEAD = THE INTEGER NUMBER THAT SPECIFIES 5659C THE NUMBER OF CHARACTERS IN THE 5660C HEADER. 5661C --CAPTN = THE CHARACTER STRING CONTAINING 5662C THE CAPTION. 5663C --NCAP = THE INTEGER NUMBER THAT SPECIFIES 5664C THE NUMBER OF CHARACTERS IN THE 5665C CAPTION. 5666C --NMAX = THE INTEGER NUMBER THAT SPECIFIES 5667C THE TOTAL NUMBER OF COLUMNS IN THE 5668C TABLE. 5669C --IFLAG1 = A LOGICAL PARAMETER THAT SPECIFIES 5670C WHETHER A RULE LINE IS DRAWN BEFORE 5671C THE TABLE HEADER. 5672C --IFLAG2 = A LOGICAL PARAMETER THAT SPECIFIES 5673C WHETHER A RULE LINE IS DRAWN AFTER 5674C THE TABLE HEADER. 5675C WRITTEN BY--JAMES J. FILLIBEN 5676C STATISTICAL ENGINEERING DIVISION 5677C INFORMATION TECHNOLOGY LABOARATORY 5678C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5679C GAITHERSBURG, MD 20899-8980 5680C PHONE--301-975-2855 5681C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5682C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5683C LANGUAGE--ANSI FORTRAN (1977) 5684C VERSION NUMBER--2009/4 5685C ORIGINAL VERSION--APRIL 2009. 5686C 5687C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5688C 5689 CHARACTER*(*) CAPTN 5690 CHARACTER*(*) IHEAD 5691C 5692 CHARACTER*132 IATEMP 5693C 5694 LOGICAL IFLAG1 5695 LOGICAL IFLAG2 5696 CHARACTER*10 IFORMT 5697C 5698C-----COMMON---------------------------------------------------------- 5699C 5700 INCLUDE 'DPCOP2.INC' 5701C 5702C-----START POINT----------------------------------------------------- 5703C 5704C STEP 1: WRITE A HEADER 5705C 5706 999 FORMAT(1X) 5707C 5708 IF(IFLAG1.AND.NMAX.GT.0)THEN 5709 WRITE(ICOUT,999) 5710 CALL DPWRST('XXX','WRIT') 5711 IFORMT=' ' 5712 DO8010I=1,MIN(NMAX,132) 5713 IATEMP(I:I)='-' 5714 8010 CONTINUE 5715 IFORMT(1:6)='(A )' 5716 WRITE(IFORMT(3:5),'(I3)')NMAX 5717 WRITE(ICOUT,IFORMT)IATEMP(1:NMAX) 5718 CALL DPWRST('XXX','WRIT') 5719 ENDIF 5720C 5721 IF(NHEAD.GE.1)THEN 5722 IFORMT=' ' 5723 IFORMT(1:9)='(12X,A )' 5724 WRITE(IFORMT(7:8),'(I2)')NHEAD 5725 WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD) 5726 CALL DPWRST('XXX','WRIT') 5727 WRITE(ICOUT,999) 5728 CALL DPWRST('XXX','WRIT') 5729 ENDIF 5730C 5731C STEP 2: START TABLE AND DEFINE A CAPTION 5732C 5733 IF(NCAP.GT.0)THEN 5734 IFORMT=' ' 5735 IFORMT(1:5)='(A )' 5736 WRITE(IFORMT(3:4),'(I2)')NCAP 5737 WRITE(ICOUT,IFORMT)CAPTN(1:NCAP) 5738 CALL DPWRST('XXX','WRIT') 5739 ENDIF 5740C 5741 IF(IFLAG2.AND.NMAX.GT.0)THEN 5742 WRITE(ICOUT,999) 5743 CALL DPWRST('XXX','WRIT') 5744 IFORMT=' ' 5745 DO8090I=1,MIN(NMAX,132) 5746 IATEMP(I:I)='-' 5747 8090 CONTINUE 5748 IFORMT(1:6)='(A )' 5749 WRITE(IFORMT(3:5),'(I3)')NMAX 5750 WRITE(ICOUT,IFORMT)IATEMP(1:NMAX) 5751 CALL DPWRST('XXX','WRIT') 5752 ENDIF 5753C 5754 RETURN 5755 END 5756 SUBROUTINE DPTABY(IVALUE,NCHAR,AVALUE,NHEAD,ITYPE, 5757 1 IFLAGA,IFLAGB,NMAX,NTOT,ICSVWR,IOUNI1, 5758 1 IBUGA3,ISUBRO) 5759C 5760C PURPOSE--THIS ROUTINE IS A UTILITY ROUTINE FOR CREATING 5761C TABULAR OUTPUT IN ASCII FORMAT. THIS ROUTINE IS USED TO 5762C GENERATE A DATA ROW FOR A TABLE WHERE THE FIELDS CAN 5763C BE A MIX OF CHARACTER AND NUMERIC VALUES. 5764C 5765C INPUT ARGUMENTS--IVALUE = AN ARRAY OF CHARACTER STRINGS. 5766C --NCHAR = THE INTEGER ARRAY THAT SPECIFIES 5767C THE NUMBER OF CHARACTERS IN THE 5768C CHARACTER FIELDS. 5769C --AVALUE = A REAL ARRAY CONTAINING THE DATA 5770C TO BE GENERATED. 5771C --NHEAD = THE INTEGER VALUE THAT SPECIFIES 5772C THE NUMBER OF NUMERIC VALUES. 5773C --ITYPE = A CHARACTER ARRAY THAT SPECIFIES 5774C WHICH FIELDS ARE NUMERIC AND 5775C WHICH ARE CHARACTER. 5776C --IFLAGA = GENERATE A SEPARATOR LINE AFTER THE 5777C CURRENT LINE. 5778C --IFLAGB = GENERATE A SEPARATOR LINE BEFORE THE 5779C CURRENT LINE. 5780C --NMAX = NUMBER OF CHARACTERS IN RULE LINE 5781C --NTOT = AN INTEGER ARRAY CONTAINING THE TOTAL 5782C NUMBER OF CHARACTERS IN EACH FIELD 5783C WRITTEN BY--ALAN HECKERT 5784C STATISTICAL ENGINEERING DIVISION 5785C INFORMATION TECHNOLOGY LABOARATORY 5786C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5787C GAITHERSBURG, MD 20899-8980 5788C PHONE--301-975-2899 5789C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5790C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5791C LANGUAGE--ANSI FORTRAN (1977) 5792C VERSION NUMBER--2009/9 5793C ORIGINAL VERSION--SEPTEMBER 2009. 5794C UPDATED --APRIL 2015. SUPPORT FOR HORIZONTAL ALIGNMENT 5795C FOR Fx.x AND Ix FORMATS 5796C 5797C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5798C 5799 CHARACTER*(*) IVALUE(*) 5800 CHARACTER*4 ITYPE(*) 5801 CHARACTER*4 ICSVWR 5802 CHARACTER*4 IBUGA3 5803 CHARACTER*4 ISUBRO 5804 REAL AVALUE(NHEAD) 5805 INTEGER NCHAR(*) 5806 INTEGER NTOT(*) 5807C 5808 LOGICAL IFLAGA 5809 LOGICAL IFLAGB 5810C 5811 PARAMETER (MAXHED=1024) 5812 INTEGER IWIDTH(MAXHED) 5813 INTEGER NUMDIG(MAXHED) 5814 CHARACTER*8 ALIGN(MAXHED) 5815 CHARACTER*8 VALIGN(MAXHED) 5816 COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN 5817C 5818 CHARACTER*20 IFORMT 5819 CHARACTER*240 ISTR 5820 CHARACTER*132 IATEMP 5821C 5822C-----COMMON---------------------------------------------------------- 5823C 5824 INCLUDE 'DPCOP2.INC' 5825C 5826C-----START POINT----------------------------------------------------- 5827C 5828C STEP 1: LOOP THROUGH THE FIELDS 5829C 5830C SUPPORT THE FOLLOWING FORMATTING OPTIONS FOR NUMERIC FIELDS 5831C 5832C NUMDIG(I) > 0 => Fyy.xx FORMAT 5833C NUMDIG(I) = 0 => I12 FORMAT 5834C NUMDIG(I) = -1 => BLANK 5835C NUMDIG(I) = -2 => G15.7 5836C NUMDIG(I) = -3 to -20 => Eyy.xx 5837C NUMDIG(I) = -99 => '**' 5838C 5839 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TABY')THEN 5840 WRITE(ICOUT,1001)NHEAD,NMAX 5841 1001 FORMAT('NHEAD,NMAX = ',2I8) 5842 CALL DPWRST('XXX','WRIT') 5843 ENDIF 5844C 5845 IF(NHEAD.GE.1)THEN 5846C 5847C STEP 1: WRITE RULE LINE BEFORE CURRENT LINE IF REQUESTED 5848C 5849 IF(IFLAGB .AND. NMAX.GT.0)THEN 5850 IFORMT=' ' 5851 DO7030I=1,NMAX 5852 IATEMP(I:I)='-' 5853 7030 CONTINUE 5854 IFORMT(1:6)='(A )' 5855 WRITE(IFORMT(3:5),'(I3)')NMAX 5856 IF(IOUNI1.GT.0)THEN 5857 WRITE(IOUNI1,IFORMT)IATEMP(1:NMAX) 5858 ELSE 5859 WRITE(ICOUT,IFORMT)IATEMP(1:NMAX) 5860 CALL DPWRST('XXX','WRIT') 5861 ENDIF 5862C 5863 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TABY')THEN 5864 WRITE(ICOUT,7031) 5865 7031 FORMAT('AFTER WRITE BORDER LINE') 5866 CALL DPWRST('XXX','WRIT') 5867 ENDIF 5868C 5869 ENDIF 5870C 5871 ISTR=' ' 5872 NCSTR=0 5873 ICNT=0 5874C 5875 DO8000I=1,NHEAD 5876 ICNT=ICNT+1 5877 IFORMT=' ' 5878C 5879 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TABY')THEN 5880 WRITE(ICOUT,8001)I,ICNT,NCSTR,ITYPE(I) 5881 8001 FORMAT('I,ICNT,NCSTR,ITYPE(I) = ',3I8,2X,A4) 5882 CALL DPWRST('XXX','WRIT') 5883 WRITE(ICOUT,8002)I,AVALUE(I),NUMDIG(I) 5884 8002 FORMAT('I,AVALUE(I),NUMDIG(I) = ',I8,2X,G15.7,I8) 5885 CALL DPWRST('XXX','WRIT') 5886 ENDIF 5887C 5888 IF(ITYPE(I).NE.'ALPH')THEN 5889 ATEMP=AVALUE(I) 5890 IF(NUMDIG(I).GT.0)THEN 5891 NCHTOT=NTOT(ICNT) 5892 NCHDEC=NUMDIG(I) 5893 CALL GRTRR1(ATEMP,NCHTOT,NCHDEC,ISTR,NCSTR,ALIGN(ICNT)) 5894 ELSEIF(NUMDIG(I).EQ.0)THEN 5895 IF(ATEMP.GE.0.0)THEN 5896 ITEMP=INT(ATEMP+0.5) 5897 ELSE 5898 ITEMP=INT(ATEMP-0.5) 5899 ENDIF 5900 NCHTOT=NTOT(ICNT) 5901 CALL GRTRI1(ITEMP,NCHTOT,ISTR,NCSTR,ALIGN(ICNT)) 5902 ELSEIF(NUMDIG(I).EQ.-1)THEN 5903 NJUNK=NTOT(I) 5904 NCSTR=NCSTR+1 5905 NCSTR2=NCSTR+NJUNK-1 5906 ISTR(NCSTR:NCSTR2)=' ' 5907 NCSTR=NCSTR2 5908 ELSEIF(NUMDIG(I).EQ.-2)THEN 5909 NCSTR=NCSTR+1 5910 NCSTR2=NCSTR+14 5911 WRITE(ISTR(NCSTR:NCSTR2),'(G15.7)')ATEMP 5912 NCSTR=NCSTR2 5913 ELSEIF(NUMDIG(I).LT.-2 .AND. NUMDIG(I).GT.-20)THEN 5914 IXX=ABS(NUMDIG(I)) 5915 IYY=IXX+8 5916 NCSTR=NCSTR+1 5917 NCSTR2=NCSTR+IYY-1 5918 IFORMT='(E . )' 5919 WRITE(IFORMT(3:4),'(I2)')IYY 5920 WRITE(IFORMT(6:7),'(I2)')IXX 5921 WRITE(ISTR(NCSTR:NCSTR2),IFORMT)ATEMP 5922 NCSTR=NCSTR2 5923 ELSEIF(NUMDIG(I).EQ.-99)THEN 5924 NCHTOT=NTOT(ICNT) 5925 IF(NCHTOT.GT.2)THEN 5926 DO7010J=1,NCHTOT-2 5927 NCSTR=NCSTR+1 5928 ISTR(NCSTR:NCSTR)=' ' 5929 7010 CONTINUE 5930 ENDIF 5931 NCSTR=NCSTR+1 5932 NCSTR2=NCSTR+1 5933 ISTR(NCSTR:NCSTR2)='**' 5934 NCSTR=NCSTR2 5935 ELSE 5936 NCSTR=NCSTR+1 5937 ISTR(NCSTR:NCSTR)=' ' 5938 ENDIF 5939C 5940C CHARACTER FIELDS 5941C 5942 ELSE 5943C 5944 NTEMP=NCHAR(I) 5945 IF(NTEMP.GT.NTOT(I))NTEMP=NTOT(I) 5946 NCSTR=NCSTR+1 5947 NCSTR3=NCSTR+NTOT(I)-1 5948 ISTR(NCSTR:NCSTR3)=' ' 5949C 5950 IF(NTEMP.GT.0)THEN 5951 IF(ALIGN(I).EQ.'l')THEN 5952 NCSTR2=NCSTR+NTEMP-1 5953 ISTR(NCSTR:NCSTR2)=IVALUE(ICNT)(1:NTEMP) 5954 ELSEIF(ALIGN(I).EQ.'c')THEN 5955 NBLANK=(NTOT(I)-NTEMP)/2 5956 NCSTR=NCSTR+NBLANK 5957 NCSTR2=NCSTR+NTEMP-1 5958 ISTR(NCSTR:NCSTR2)=IVALUE(ICNT)(1:NTEMP) 5959 ELSEIF(ALIGN(I).EQ.'r')THEN 5960 NBLANK=NTOT(I)-NTEMP 5961 NCSTR=NCSTR+NBLANK 5962 NCSTR2=NCSTR+NTEMP-1 5963 ISTR(NCSTR:NCSTR2)=IVALUE(ICNT)(1:NTEMP) 5964 ENDIF 5965 ENDIF 5966 NCSTR=NCSTR3 5967 ENDIF 5968C 5969 IF(ICSVWR.EQ.'ON' .AND. I.LT.NHEAD)THEN 5970 NCSTR=NCSTR+1 5971 ISTR(NCSTR:NCSTR)=',' 5972 ENDIF 5973C 5974 8000 CONTINUE 5975C 5976 IF(NCSTR.GE.1)THEN 5977 IFORMT='(A )' 5978 WRITE(IFORMT(3:5),'(I3)')NCSTR 5979 IF(IOUNI1.GT.0)THEN 5980 WRITE(IOUNI1,IFORMT)ISTR(1:NCSTR) 5981 ELSE 5982 WRITE(ICOUT,IFORMT)ISTR(1:NCSTR) 5983 CALL DPWRST('XXX','WRIT') 5984 ENDIF 5985 ENDIF 5986C 5987C STEP 3: WRITE RULE LINE AFTER CURRENT LINE IF REQUESTED 5988C 5989 IF(IFLAGA .AND. NMAX.GT.0)THEN 5990 IFORMT=' ' 5991 DO8030I=1,NMAX 5992 IATEMP(I:I)='-' 5993 8030 CONTINUE 5994 IFORMT(1:6)='(A )' 5995 WRITE(IFORMT(3:5),'(I3)')NMAX 5996 IF(IOUNI1.GT.0)THEN 5997 WRITE(IOUNI1,IFORMT)IATEMP(1:NMAX) 5998 ELSE 5999 WRITE(ICOUT,IFORMT)IATEMP(1:NMAX) 6000 CALL DPWRST('XXX','WRIT') 6001 ENDIF 6002 ENDIF 6003C 6004 ENDIF 6005C 6006 RETURN 6007 END 6008 SUBROUTINE DPTAC2(Y1,Y2,Y3,TAG1,TAG2,TAG3,TAG4,N,YLEVEL,NLEVEL, 6009 1 NUMV2,ICASCT,ICTNAM,ISTANR, 6010 1 XIDTEM,XIDTE2,XIDTE3,XIDTE4, 6011 1 TEMP1,TEMP2,TEMP3,TEMP4,TEMP5, 6012 1 TEMP6,TEMP7,TEMP8,TEMP9,TMP10,TMP11, 6013 1 XACLOW,XACUPP, 6014 1 ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 6015 1 DTEMP1,DTEMP2,DTEMP3, 6016 1 ISEED,ICTAMV,PSTAMV,PCTAMV,ALPHA,IQUASE, 6017 1 NCRTV,MAXOBV,PTPLXI,PTPLYI,ITPLDI,ITPLUN, 6018 1 ITPLNI,ITPLCD,ITPLSO,ITPLSR,ITPLSC, 6019 1 ITPLRM,ITPLCM, 6020 1 Y,X,D,X3D, 6021 1 NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 6022C 6023C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS 6024C THAT WILL DEFINE AN TABULATION PLOT 6025C 6026C THIS SUPPORTS THE "CHARACTER" VARIANT. IN THIS VARIANT, WE PLOT 6027C THE VALUE OF THE STATISTIC (FOR RAW DATA, WE CAN USE THE MEAN AS 6028C THE DESIRED STATISTIC). 6029C 6030C DESCRIPTION--IN THE TABULATION PLOT, WE CROSS-TABULATE OVER 6031C 1 TO 4 GROUP-ID VARIABLES (ANALAGOUS TO A 6032C FLUCTUATION PLOT). WE DEFINE A GRID BASED ON THE 6033C THESE GROUP-ID VARIABLES. THEN FOR THE RESPONSE 6034C VALUES CORRESPONDING TO A GIVEN SET OF THESE 6035C GROUP-ID VARIABLES, WE COMPUTE A USER-SPECIFED 6036C STATISTIC (THE DEFAULT IS THE MEAN). THE VALUE 6037C OF THE STATISTIC IS THEN COMPARED TO SOME 6038C USER-SPECIFIED LEVELS (THESE ARE DEFINED IN THE 6039C YLEVEL VARIABLE). A RECTANGLE IS DRAWN AND THE 6040C ATTRIBUTES (PRIMARILY FILL COLOR) ARE BASED ON 6041C THE VALUE OF THE STATISTIC RELATIVE TO YLEVEL. 6042C 6043C THIS PLOT IS USEFUL FOR VISUALLY IDENTIFYING 6044C AREAS WITH "HIGH" AND "LOW" VALUES OF THE 6045C STATISTIC ACROSS GROUPS. 6046C WRITTEN BY--ALAN HECKERT 6047C STATISTICAL ENGINEERING DIVISION 6048C INFORMATION TECHNOLOGY LABORATORY 6049C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 6050C GAITHERSBURG, MD 20899-8980 6051C PHONE--301-975-2889 6052C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 6053C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 6054C LANGUAGE--ANSI FORTRAN (1977) 6055C VERSION NUMBER--2010/6 6056C ORIGINAL VERSION--JUNE 2010. THIS VARIANT ADDED TO THE 6057C TABULATION PLOT 6058C UPDATED --AUGUST 2010. ROW/COLUMN "MINMAX" OPTION 6059C FOR TWO GROUP-ID VARIABLES CASE 6060C 6061C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 6062C 6063 CHARACTER*4 ICASCT 6064 CHARACTER*60 ICTNAM 6065 CHARACTER*4 ICTAMV 6066 CHARACTER*4 IQUASE 6067 CHARACTER*4 ITPLDI 6068 CHARACTER*4 ITPLUN 6069 CHARACTER*4 ITPLCD 6070 CHARACTER*4 ITPLSO 6071 CHARACTER*4 ITPLSR 6072 CHARACTER*4 ITPLSC 6073 CHARACTER*4 ITPLCM 6074 CHARACTER*4 ITPLRM 6075 CHARACTER*4 ISUBRO 6076 CHARACTER*4 IBUGG3 6077 CHARACTER*4 IERROR 6078C 6079 CHARACTER*4 IWRITE 6080 CHARACTER*4 ISUBN1 6081 CHARACTER*4 ISUBN2 6082 CHARACTER*4 ISTEPN 6083C 6084C--------------------------------------------------------------------- 6085C 6086 DIMENSION Y1(*) 6087 DIMENSION Y2(*) 6088 DIMENSION Y3(*) 6089 DIMENSION YLEVEL(*) 6090 DIMENSION TAG1(*) 6091 DIMENSION TAG2(*) 6092 DIMENSION TAG3(*) 6093 DIMENSION TAG4(*) 6094C 6095 DIMENSION XIDTEM(*) 6096 DIMENSION XIDTE2(*) 6097 DIMENSION XIDTE3(*) 6098 DIMENSION XIDTE4(*) 6099C 6100 DIMENSION TEMP1(*) 6101 DIMENSION TEMP2(*) 6102 DIMENSION TEMP3(*) 6103 DIMENSION TEMP4(*) 6104 DIMENSION TEMP5(*) 6105 DIMENSION TEMP6(*) 6106 DIMENSION TEMP7(*) 6107 DIMENSION TEMP8(*) 6108 DIMENSION TEMP9(*) 6109 DIMENSION TMP10(*) 6110 DIMENSION TMP11(*) 6111C 6112 DIMENSION ITEMP1(*) 6113 DIMENSION ITEMP2(*) 6114 DIMENSION ITEMP3(*) 6115 DIMENSION ITEMP4(*) 6116 DIMENSION ITEMP5(*) 6117 DIMENSION ITEMP6(*) 6118C 6119 DOUBLE PRECISION DTEMP1(*) 6120 DOUBLE PRECISION DTEMP2(*) 6121 DOUBLE PRECISION DTEMP3(*) 6122C 6123 DIMENSION Y(*) 6124 DIMENSION X(*) 6125 DIMENSION D(*) 6126 DIMENSION X3D(*) 6127C 6128 DIMENSION XACLOW(*) 6129 DIMENSION XACUPP(*) 6130C 6131 COMMON/ITABC2/IADD 6132C 6133C-----COMMON---------------------------------------------------------- 6134C 6135 INCLUDE 'DPCOP2.INC' 6136C 6137C-----START POINT----------------------------------------------------- 6138C 6139 ISUBN1='DPTA' 6140 ISUBN2='C2 ' 6141 IWRITE='OFF' 6142 IERROR='NO' 6143 IADD=0 6144C 6145C ******************************************** 6146C ** STEP 1-- ** 6147C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 6148C ******************************************** 6149C 6150C 6151C CHECK THE INPUT ARGUMENTS FOR ERRORS 6152C 6153 IF(N.LT.2)THEN 6154 WRITE(ICOUT,999) 6155 999 FORMAT(1X) 6156 CALL DPWRST('XXX','BUG ') 6157 WRITE(ICOUT,31) 6158 31 FORMAT('***** ERROR IN CHARACTER TABULATION PLOT--') 6159 CALL DPWRST('XXX','BUG ') 6160 WRITE(ICOUT,32) 6161 32 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.') 6162 CALL DPWRST('XXX','BUG ') 6163 WRITE(ICOUT,34)N 6164 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) 6165 CALL DPWRST('XXX','BUG ') 6166 WRITE(ICOUT,999) 6167 CALL DPWRST('XXX','BUG ') 6168 IERROR='YES' 6169 GOTO9000 6170 ENDIF 6171C 6172 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAC2')THEN 6173 WRITE(ICOUT,70) 6174 70 FORMAT('AT THE BEGINNING OF DPTAC2--') 6175 CALL DPWRST('XXX','BUG ') 6176 WRITE(ICOUT,71)ICASCT,N,NUMV2,NCRTV,NLEVEL,ISTANR 6177 71 FORMAT('ICASCT,N,NUMV2,NCRTV,NLEVEL,ISTANR = ',A4,2X,5I8) 6178 CALL DPWRST('XXX','BUG ') 6179 WRITE(ICOUT,74)ICTNAM 6180 74 FORMAT('ICTNAM = ',A60) 6181 CALL DPWRST('XXX','BUG ') 6182 WRITE(ICOUT,78)ITPLUN,ITPLNI,PTPLXI,PTPLYI 6183 78 FORMAT('ITPLUN,ITPLNI,PTPLXI,PTPLYI = ',A4,2X,I8,2G15.7) 6184 CALL DPWRST('XXX','BUG ') 6185 DO72I=1,N 6186 WRITE(ICOUT,73)I,Y1(I),Y2(I),TAG1(I),TAG2(I),TAG3(I), 6187 1 TAG4(I) 6188 73 FORMAT('I,Y(I),Y2(I),TAG1-6(I) = ',I8,9F10.3) 6189 CALL DPWRST('XXX','BUG ') 6190 72 CONTINUE 6191 IF(NLEVEL.GE.1)THEN 6192 DO82I=1,NLEVEL 6193 WRITE(ICOUT,83)I,YLEVEL(I) 6194 83 FORMAT('I,YLEVEL(I) = ',I8,G15.7) 6195 CALL DPWRST('XXX','BUG ') 6196 82 CONTINUE 6197 ENDIF 6198 ENDIF 6199C 6200 IF(NLEVEL.GE.1)THEN 6201 CALL DISTIN(YLEVEL,NLEVEL,IWRITE,TEMP1,NTEMP,IBUGG3,IERROR) 6202 DO110I=1,NTEMP 6203 YLEVEL(I)=TEMP1(I) 6204 110 CONTINUE 6205 NLEVEL=NTEMP 6206 CALL SORT(YLEVEL,NLEVEL,YLEVEL) 6207 ENDIF 6208C 6209C ****************************************************** 6210C ** STEP 1-- ** 6211C ** DETERMINE THE NUMBER OF DISTINCT VALUES ** 6212C ** FOR THE GROUP VARIABLES (TAG1, TAG2) ** 6213C ** IF ALL VALUES ARE DISTINCT, THEN THIS ** 6214C ** IMPLIES WE HAVE THE NO REPLICATION CASE ** 6215C ** WHICH IS AN ERROR CONDITION FOR A PLOT. ** 6216C ****************************************************** 6217C 6218 ISTEPN='1' 6219 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TAC2') 6220 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6221C 6222 IF(ITPLCD.EQ.'ON')THEN 6223 CALL CODE(TAG1,N,IWRITE,TEMP1,TEMP2,MAXOBV,IBUGG3,IERROR) 6224 DO910I=1,N 6225 TAG1(I)=TEMP1(I) 6226 910 CONTINUE 6227 ENDIF 6228 CALL DISTIN(TAG1,N,IWRITE,XIDTEM,NUMSE1,IBUGG3,IERROR) 6229 CALL SORT(XIDTEM,NUMSE1,XIDTEM) 6230C 6231 IF(NCRTV.GE.2)THEN 6232 IF(ITPLCD.EQ.'ON')THEN 6233 CALL CODE(TAG2,N,IWRITE,TEMP1,TEMP2,MAXOBV,IBUGG3,IERROR) 6234 DO920I=1,N 6235 TAG2(I)=TEMP1(I) 6236 920 CONTINUE 6237 ENDIF 6238 CALL DISTIN(TAG2,N,IWRITE,XIDTE2,NUMSE2,IBUGG3,IERROR) 6239 CALL SORT(XIDTE2,NUMSE2,XIDTE2) 6240 ENDIF 6241C 6242 IF(NCRTV.GE.3)THEN 6243 IF(ITPLCD.EQ.'ON')THEN 6244 CALL CODE(TAG3,N,IWRITE,TEMP1,TEMP2,MAXOBV,IBUGG3,IERROR) 6245 DO930I=1,N 6246 TAG3(I)=TEMP1(I) 6247 930 CONTINUE 6248 ENDIF 6249 CALL DISTIN(TAG3,N,IWRITE,XIDTE3,NUMSE3,IBUGG3,IERROR) 6250 CALL SORT(XIDTE3,NUMSE3,XIDTE3) 6251 ELSE 6252 NUMSE3=0 6253 ENDIF 6254C 6255 IF(NCRTV.GE.4)THEN 6256 IF(ITPLCD.EQ.'ON')THEN 6257 CALL CODE(TAG4,N,IWRITE,TEMP1,TEMP2,MAXOBV,IBUGG3,IERROR) 6258 DO940I=1,N 6259 TAG4(I)=TEMP1(I) 6260 940 CONTINUE 6261 ENDIF 6262 CALL DISTIN(TAG4,N,IWRITE,XIDTE4,NUMSE4,IBUGG3,IERROR) 6263 CALL SORT(XIDTE4,NUMSE4,XIDTE4) 6264 ELSE 6265 NUMSE4=0 6266 ENDIF 6267C 6268 IF(NUMSE1.LT.1 .OR. NUMSE1.GT.N)THEN 6269 WRITE(ICOUT,999) 6270 CALL DPWRST('XXX','BUG ') 6271 WRITE(ICOUT,31) 6272 CALL DPWRST('XXX','BUG ') 6273 ITEMP=1 6274 WRITE(ICOUT,111)ITEMP,NUMSE1 6275 111 FORMAT(' THE NUMBER OF SETS FOR THE GROUP ',I1, 6276 1 ' VARIABLE, ',I8,',') 6277 CALL DPWRST('XXX','BUG ') 6278 WRITE(ICOUT,113) 6279 113 FORMAT(' IS EITHER LESS THAN ONE OR GREATER THAN THE ', 6280 1 'NUMBER') 6281 CALL DPWRST('XXX','BUG ') 6282 WRITE(ICOUT,115)N 6283 115 FORMAT(' OF OBSERVATIONS, ',I8,'.') 6284 CALL DPWRST('XXX','BUG ') 6285 IERROR='YES' 6286 GOTO9000 6287 ENDIF 6288C 6289 IF(NCRTV.GE.2 .AND. (NUMSE2.LT.1 .OR. NUMSE2.GT.N))THEN 6290 WRITE(ICOUT,999) 6291 CALL DPWRST('XXX','BUG ') 6292 WRITE(ICOUT,31) 6293 CALL DPWRST('XXX','BUG ') 6294 ITEMP=2 6295 WRITE(ICOUT,111)ITEMP,NUMSE2 6296 CALL DPWRST('XXX','BUG ') 6297 WRITE(ICOUT,113) 6298 CALL DPWRST('XXX','BUG ') 6299 WRITE(ICOUT,115)N 6300 CALL DPWRST('XXX','BUG ') 6301 IERROR='YES' 6302 GOTO9000 6303 ENDIF 6304C 6305 IF(NCRTV.GE.3 .AND. (NUMSE3.LT.1 .OR. NUMSE3.GT.N))THEN 6306 WRITE(ICOUT,999) 6307 CALL DPWRST('XXX','BUG ') 6308 WRITE(ICOUT,31) 6309 CALL DPWRST('XXX','BUG ') 6310 ITEMP=3 6311 WRITE(ICOUT,111)ITEMP,NUMSE3 6312 CALL DPWRST('XXX','BUG ') 6313 WRITE(ICOUT,113) 6314 CALL DPWRST('XXX','BUG ') 6315 WRITE(ICOUT,115)N 6316 CALL DPWRST('XXX','BUG ') 6317 IERROR='YES' 6318 GOTO9000 6319 ENDIF 6320C 6321 IF(NCRTV.GE.4 .AND. (NUMSE4.LT.1 .OR. NUMSE4.GT.N))THEN 6322 WRITE(ICOUT,999) 6323 CALL DPWRST('XXX','BUG ') 6324 WRITE(ICOUT,31) 6325 CALL DPWRST('XXX','BUG ') 6326 ITEMP=4 6327 WRITE(ICOUT,111)ITEMP,NUMSE4 6328 CALL DPWRST('XXX','BUG ') 6329 WRITE(ICOUT,113) 6330 CALL DPWRST('XXX','BUG ') 6331 WRITE(ICOUT,115)N 6332 CALL DPWRST('XXX','BUG ') 6333 IERROR='YES' 6334 GOTO9000 6335 ENDIF 6336C 6337 AN=REAL(N) 6338 ANUMS1=REAL(NUMSE1) 6339 ANUMS2=REAL(NUMSE2) 6340 ANUMS3=REAL(NUMSE3) 6341 ANUMS4=REAL(NUMSE4) 6342C 6343C *********************************************** 6344C ** STEP 5-- ** 6345C ** COMPUTE THE VARIOUS CROSS-TAB STATISTICS ** 6346C *********************************************** 6347C 6348 ISTEPN='5.1' 6349 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TAC2')THEN 6350 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6351 WRITE(ICOUT,201)NUMSE1,NUMSE2,NUMSE3,NUMSE4 6352 201 FORMAT('NUMSE1,NUMSE2,NUMSE3,NUMSE4 = ',4I8) 6353 CALL DPWRST('XXX','BUG ') 6354 IF(NUMSE1.GE.1)THEN 6355 DO210I=1,NUMSE1 6356 WRITE(ICOUT,211)I,XIDTEM(I) 6357 211 FORMAT('I,XIDTEM(I) = ',I8,G15.7) 6358 CALL DPWRST('XXX','BUG ') 6359 210 CONTINUE 6360 ENDIF 6361C 6362 IF(NUMSE2.GE.1)THEN 6363 DO220I=1,NUMSE2 6364 WRITE(ICOUT,221)I,XIDTE2(I) 6365 221 FORMAT('I,XIDTE2(I) = ',I8,G15.7) 6366 CALL DPWRST('XXX','BUG ') 6367 220 CONTINUE 6368 ENDIF 6369 ENDIF 6370C 6371 IWRITE='OFF' 6372C 6373 IF(NCRTV.EQ.1)THEN 6374 CALL DPTAP0(Y1,Y2,Y3,TAG1,N, 6375 1 NUMV2,ICASCT,ISTANR, 6376 1 XIDTEM, 6377 1 NUMSE1, 6378 1 TEMP1,TEMP2,TMP11,TEMP3,TEMP4,TEMP5, 6379 1 ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 6380 1 DTEMP1,DTEMP2,DTEMP3, 6381 1 ISEED,ALPHA, 6382 1 ICTAMV,PCTAMV,PSTAMV,IQUASE, 6383 1 TEMP6,TEMP7,XACLOW,XACUPP,N2, 6384 1 ISUBRO,IBUGG3,IERROR) 6385C 6386CCCCC NOW GENERATE THE PLOT COORDINATES. SET "X3D" TO VALUE 6387CCCCC OF STATISTIC FOR EACH POINT. 6388C 6389 ICNT=0 6390C 6391 DO1001I=1,N2 6392 STAT=TEMP6(I) 6393 IF(ITPLDI.EQ.'X')THEN 6394 XVAL=TEMP7(I) 6395 YVAL=1.0 6396 ELSE 6397 YVAL=TEMP7(I) 6398 XVAL=1.0 6399 ENDIF 6400 XCOOR1=XVAL 6401 YCOOR1=YVAL 6402 IF(STAT.LT.YLEVEL(1))THEN 6403 ILEVEL=1 6404 ELSEIF(STAT.GE.YLEVEL(NLEVEL))THEN 6405 ILEVEL=NLEVEL+1 6406 ELSE 6407 DO1003J=2,NLEVEL 6408 IF(STAT.GE.YLEVEL(J-1) .AND. STAT.LT.YLEVEL(J))THEN 6409 ILEVEL=J 6410 ENDIF 6411 1003 CONTINUE 6412 ENDIF 6413C 6414 ICNT=ICNT+1 6415 X(ICNT)=XCOOR1 6416 Y(ICNT)=YCOOR1 6417 X3D(ICNT)=STAT 6418 D(ICNT)=REAL(ILEVEL) 6419C 6420 1001 CONTINUE 6421C 6422 NPLOTP=ICNT 6423 NPLOTV=2 6424C 6425C WHEN THERE ARE EXACTLY TWO CROSS-TABULATION VARIABLES, THEN 6426C SUPPORT A "SORT" OPTION. FIRST NEED TO OBTAIN ROW AND COLUMN 6427C VALUES FOR THE STATISTICS. FROM THESE, CREATE "INDEX" VARIABLES. 6428C 6429 ELSEIF(NCRTV.EQ.2)THEN 6430C 6431C SORT THE ROWS. FOR THIS APPLICATION, NEED A RANK. SINCE THE 6432C RANK WILL SERVE AS AN ARRAY INDEX, NEED TO CHECK FOR TIES. 6433C 6434 IF(ITPLSO.EQ.'ON' .OR. ITPLSO.EQ.'ROW')THEN 6435 CALL DPTAP0(Y1,Y2,Y3,TAG1,N, 6436 1 NUMV2,ICASCT,ISTANR, 6437 1 XIDTEM, 6438 1 NUMSE1, 6439 1 TEMP1,TEMP2,TMP11,TEMP3,TEMP4,TEMP5, 6440 1 ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 6441 1 DTEMP1,DTEMP2,DTEMP3, 6442 1 ISEED,ALPHA, 6443 1 ICTAMV,PCTAMV,PSTAMV,IQUASE, 6444 1 TEMP9,TEMP7,XACLOW,XACUPP,N2, 6445 1 ISUBRO,IBUGG3,IERROR) 6446 CALL RANKI(TEMP9,NUMSE1,IWRITE,XIDTE3,TEMP7,ITEMP1,MAXOBV, 6447 1 IBUGG3,IERROR) 6448 CALL DISTIN(XIDTE3,NUMSE1,IWRITE,TEMP7,NTEMP,IBUGG3,IERROR) 6449 IF(NTEMP.NE.NUMSE1)THEN 6450 DO1006II=1,NUMSE1 6451 XIDTE3(II)=XIDTEM(II) 6452 1006 CONTINUE 6453 ENDIF 6454 IF(ITPLSR.EQ.'DESC')THEN 6455 DO2006I=1,N 6456 IRANK=INT(XIDTE3(I)+0.1) 6457 IRANK2=NUMSE1 - IRANK + 1 6458 XIDTE3(I)=REAL(IRANK2) 6459 2006 CONTINUE 6460 ENDIF 6461 ELSE 6462 IF(ITPLSR.EQ.'DESC')THEN 6463 DO3007II=1,NUMSE1 6464 IVAL=NUMSE1 - II + 1 6465 XIDTE3(II)=XIDTEM(IVAL) 6466 3007 CONTINUE 6467 ELSE 6468 DO1007II=1,NUMSE1 6469 XIDTE3(II)=XIDTEM(II) 6470 1007 CONTINUE 6471 ENDIF 6472 ENDIF 6473C 6474C SORT THE COLUMNS 6475C 6476 IF(ITPLSO.EQ.'ON' .OR. ITPLSO.EQ.'COLU')THEN 6477 CALL DPTAP0(Y1,Y2,Y3,TAG2,N, 6478 1 NUMV2,ICASCT,ISTANR, 6479 1 XIDTE2, 6480 1 NUMSE2, 6481 1 TEMP1,TEMP2,TMP11,TEMP3,TEMP4,TEMP5, 6482 1 ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 6483 1 DTEMP1,DTEMP2,DTEMP3, 6484 1 ISEED,ALPHA, 6485 1 ICTAMV,PCTAMV,PSTAMV,IQUASE, 6486 1 TMP10,TEMP7,XACLOW,XACUPP,N2, 6487 1 ISUBRO,IBUGG3,IERROR) 6488 CALL RANKI(TMP10,NUMSE2,IWRITE,XIDTE4,TEMP7,ITEMP1,MAXOBV, 6489 1 IBUGG3,IERROR) 6490 CALL DISTIN(XIDTE4,NUMSE2,IWRITE,TEMP7,NTEMP,IBUGG3,IERROR) 6491 IF(NTEMP.NE.NUMSE2)THEN 6492 DO1008II=1,NUMSE2 6493 XIDTE4(II)=XIDTE2(II) 6494 1008 CONTINUE 6495 ENDIF 6496 IF(ITPLSC.EQ.'DESC')THEN 6497 DO2008I=1,N 6498 IRANK=INT(XIDTE4(I)+0.1) 6499 IRANK2=NUMSE2 - IRANK + 1 6500 XIDTE4(I)=REAL(IRANK2) 6501 2008 CONTINUE 6502 ENDIF 6503 ELSE 6504 IF(ITPLSR.EQ.'DESC')THEN 6505 DO3008II=1,NUMSE2 6506 IVAL=NUMSE2 - II + 1 6507 XIDTE4(II)=XIDTE2(IVAL) 6508 3008 CONTINUE 6509 ELSE 6510 DO1009II=1,NUMSE2 6511 XIDTE4(II)=XIDTE2(II) 6512 1009 CONTINUE 6513 ENDIF 6514 ENDIF 6515C 6516 CALL DPTAP3(Y1,Y2,Y3,TAG1,TAG2,N, 6517 1 NUMV2,ICASCT,ISTANR, 6518 1 XIDTEM,XIDTE2, 6519 1 NUMSE1,NUMSE2, 6520 1 TEMP1,TEMP2,TMP11,TEMP3,TEMP4,TEMP5, 6521 1 TMP10,TMP11,ITPLCM,ITPLRM, 6522 1 ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 6523 1 DTEMP1,DTEMP2,DTEMP3, 6524 1 ISEED,ALPHA, 6525 1 ICTAMV,PCTAMV,PSTAMV,IQUASE, 6526 1 TEMP6,TEMP7,TEMP8,XACLOW,XACUPP,N2, 6527 1 ISUBRO,IBUGG3,IERROR) 6528C 6529CCCCC NOW GENERATE THE PLOT COORDINATES. 6530C 6531 ICNT=0 6532C 6533 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAC2')THEN 6534 WRITE(ICOUT,1011)N2,ITPLSO,ITPLDI 6535 1011 FORMAT('DPTAC2 AFTER CALL DPTAP3: N2,ITPLSO,ITPLDI = ', 6536 1 I8,A4,2X,A4) 6537 CALL DPWRST('XXX','BUG ') 6538 DO1012I=1,NUMSE1 6539 WRITE(ICOUT,1013)I,XIDTE3(I) 6540 1013 FORMAT('I,XIDTE3(I) = ',I8,G15.7) 6541 CALL DPWRST('XXX','BUG ') 6542 1012 CONTINUE 6543 DO1014I=1,NUMSE2 6544 WRITE(ICOUT,1015)I,XIDTE4(I) 6545 1015 FORMAT('I,XIDTE4(I) = ',I8,G15.7) 6546 CALL DPWRST('XXX','BUG ') 6547 1014 CONTINUE 6548 ENDIF 6549C 6550 DO1010I=1,N2 6551 STAT=TEMP6(I) 6552C 6553 IF(ITPLDI.EQ.'X')THEN 6554 INDEXX=INT(TEMP7(I)+0.1) 6555 INDEXY=INT(TEMP8(I)+0.1) 6556 XVAL=XIDTE3(INDEXX) 6557 YVAL=XIDTE4(INDEXY) 6558 ELSE 6559CCCCC INDEXX=INT(TEMP8(I)+0.1) 6560CCCCC INDEXY=INT(TEMP7(I)+0.1) 6561CCCCC XVAL=XIDTE4(INDEXX) 6562CCCCC YVAL=XIDTE3(INDEXY) 6563 INDEXX=INT(TEMP8(I)+0.1) 6564 INDEXY=INT(TEMP7(I)+0.1) 6565 XVAL=XIDTE4(INDEXX) 6566 YVAL=XIDTE3(INDEXY) 6567 ENDIF 6568C 6569 XCOOR1=XVAL 6570 YCOOR1=YVAL 6571 ILEVEL=-99 6572 IF(NLEVEL.GE.1)THEN 6573 IF(STAT.LT.YLEVEL(1))THEN 6574 ILEVEL=1 6575 ELSEIF(STAT.GE.YLEVEL(NLEVEL))THEN 6576 ILEVEL=NLEVEL+1 6577 ELSE 6578 DO1016J=2,NLEVEL 6579 IF(STAT.GE.YLEVEL(J-1) .AND. STAT.LT.YLEVEL(J))THEN 6580 ILEVEL=J 6581 ENDIF 6582 1016 CONTINUE 6583 ENDIF 6584 ENDIF 6585C 6586 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAC2')THEN 6587 WRITE(ICOUT,1017)I,STAT,INDEXX,XVAL,XCOOR1, 6588 1 INDEXY,YVAL,YCOOR1 6589 1017 FORMAT('I,STAT,INDEXX,XVAL,XCOOR1,INDEXY,YVAL,YCOOR1 = ', 6590 1 I8,G15.7,2(I6,2F12.5)) 6591 CALL DPWRST('XXX','BUG ') 6592 ENDIF 6593C 6594 ICNT=ICNT+1 6595 X(ICNT)=XCOOR1 6596 Y(ICNT)=YCOOR1 6597 X3D(ICNT)=STAT 6598 D(ICNT)=REAL(ILEVEL) 6599C 6600 1010 CONTINUE 6601C 6602C IF REQUESTED, FLAG COLUMN/ROW MIN/MAX POINTS 6603C 6604 IF(ITPLCM.EQ.'OFF' .AND. ITPLRM.EQ.'OFF')GOTO5099 6605C 6606C PERFORM DUPLICATION OF ARRAYS FIRST (ADD MIN/MAX PART 6607C AT END) 6608C 6609 IF(ICNT.GT.0)THEN 6610 DO5010I=1,ICNT 6611 ICNT=ICNT+1 6612 X(ICNT)=X(I) 6613 Y(ICNT)=Y(I) 6614 X3D(ICNT)=X3D(I) 6615 D(ICNT)=D(I) + REAL(NLEVEL+1) 6616 5010 CONTINUE 6617 ENDIF 6618 CALL MAXIM(D,ICNT,IWRITE,DMAX,IBUGG3,IERROR) 6619C 6620 IF(ITPLDI.EQ.'Y')THEN 6621 IADD=0 6622C 6623 IF(ITPLCM.EQ.'ON')THEN 6624 IADD=IADD+1 6625 DO5020I=1,N2 6626 IF(TMP10(I).EQ.1.0)THEN 6627 ICNT=ICNT+1 6628 X(ICNT)=X(I) 6629 Y(ICNT)=Y(I) 6630 X3D(ICNT)=X3D(I) 6631 D(ICNT)=REAL(2*(NLEVEL+1)+IADD) 6632 ENDIF 6633 IF(TMP10(I).EQ.2.0)THEN 6634 ICNT=ICNT+1 6635 X(ICNT)=X(I) 6636 Y(ICNT)=Y(I) 6637 X3D(ICNT)=X3D(I) 6638 D(ICNT)=REAL(2*(NLEVEL+1)+IADD+1) 6639 ENDIF 6640 5020 CONTINUE 6641 ENDIF 6642C 6643 IF(ITPLRM.EQ.'ON')THEN 6644 IADD=IADD+1 6645 DO5030I=1,N2 6646 IF(TMP11(I).EQ.1.0)THEN 6647 ICNT=ICNT+1 6648 X(ICNT)=X(I) 6649 Y(ICNT)=Y(I) 6650 X3D(ICNT)=X3D(I) 6651 D(ICNT)=REAL(2*(NLEVEL+1)+IADD) 6652 ENDIF 6653 IF(TMP11(I).EQ.2.0)THEN 6654 ICNT=ICNT+1 6655 X(ICNT)=X(I) 6656 Y(ICNT)=Y(I) 6657 X3D(ICNT)=X3D(I) 6658 D(ICNT)=REAL(2*(NLEVEL+1)+IADD+1) 6659 ENDIF 6660 5030 CONTINUE 6661 IADD=IADD+1 6662 ENDIF 6663C 6664 ELSEIF(ITPLDI.EQ.'X')THEN 6665 IADD=0 6666C 6667 IF(ITPLRM.EQ.'ON')THEN 6668 IADD=IADD+1 6669 DO5040I=1,N2 6670 IF(TMP11(I).EQ.1.0)THEN 6671 ICNT=ICNT+1 6672 X(ICNT)=X(I) 6673 Y(ICNT)=Y(I) 6674 X3D(ICNT)=X3D(I) 6675 D(ICNT)=REAL(NLEVEL+1+IADD) 6676 ENDIF 6677 IF(TMP11(I).EQ.2.0)THEN 6678 ICNT=ICNT+1 6679 X(ICNT)=X(I) 6680 Y(ICNT)=Y(I) 6681 X3D(ICNT)=X3D(I) 6682 D(ICNT)=REAL(NLEVEL+1+IADD+1) 6683 ENDIF 6684 5040 CONTINUE 6685 IADD=IADD+1 6686 ENDIF 6687C 6688 IF(ITPLCM.EQ.'ON')THEN 6689 IADD=IADD+1 6690 DO5050I=1,N2 6691 IF(TMP10(I).EQ.1.0)THEN 6692 ICNT=ICNT+1 6693 X(ICNT)=X(I) 6694 Y(ICNT)=Y(I) 6695 X3D(ICNT)=X3D(I) 6696 D(ICNT)=REAL(NLEVEL+1+IADD) 6697 ENDIF 6698 IF(TMP10(I).EQ.2.0)THEN 6699 ICNT=ICNT+1 6700 X(ICNT)=X(I) 6701 Y(ICNT)=Y(I) 6702 X3D(ICNT)=X3D(I) 6703 D(ICNT)=REAL(NLEVEL+1+IADD+1) 6704 ENDIF 6705 5050 CONTINUE 6706 IADD=IADD+1 6707 ENDIF 6708C 6709 NPLOTP=ICNT 6710 NPLOTV=2 6711 GOTO9000 6712C 6713 ENDIF 6714C 6715 NPLOTP=ICNT 6716 NPLOTV=2 6717 GOTO9000 6718C 6719 5099 CONTINUE 6720 NPLOTP=ICNT 6721 NPLOTV=2 6722C 6723 ELSEIF(NCRTV.EQ.3)THEN 6724 CALL DPTAP4(Y1,Y2,Y3,TAG1,TAG2,TAG3,N, 6725 1 NUMV2,ICASCT,ISTANR, 6726 1 XIDTEM,XIDTE2,XIDTE3, 6727 1 NUMSE1,NUMSE2,NUMSE3, 6728 1 TEMP1,TEMP2,TMP11,TEMP3,TEMP4,TEMP5, 6729 1 ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 6730 1 DTEMP1,DTEMP2,DTEMP3, 6731 1 ISEED,ALPHA, 6732 1 ICTAMV,PCTAMV,PSTAMV,IQUASE, 6733 1 TEMP6,TEMP7,TEMP8,TEMP9,XACLOW,XACUPP,N2, 6734 1 ISUBRO,IBUGG3,IERROR) 6735C 6736CCCCC NOW GENERATE THE PLOT COORDINATES. 6737C 6738 ICNT=0 6739C 6740 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAC2')THEN 6741 WRITE(ICOUT,1021)N2 6742 1021 FORMAT('DPTAC2: AFTER CALL DPTAP4--N2 = ',I8) 6743 CALL DPWRST('XXX','BUG ') 6744 ENDIF 6745C 6746 DO1020I=1,N2 6747 STAT=TEMP6(I) 6748 IF(ITPLDI.EQ.'X')THEN 6749 XVAL=TEMP7(I) 6750 YVAL=TEMP8(I) 6751 XVAL2=TEMP9(I) 6752 XCOOR1=XVAL + XVAL2/REAL(NUMSE3) 6753 YCOOR1=YVAL 6754 ELSE 6755 YVAL=TEMP7(I) 6756 XVAL=TEMP8(I) 6757 YVAL2=TEMP9(I) 6758 XCOOR1=XVAL 6759 YCOOR1=YVAL + YVAL2/REAL(NUMSE3) 6760 ENDIF 6761 IF(STAT.LT.YLEVEL(1))THEN 6762 ILEVEL=1 6763 ELSEIF(STAT.GE.YLEVEL(NLEVEL))THEN 6764 ILEVEL=NLEVEL+1 6765 ELSE 6766 DO1025J=2,NLEVEL 6767 IF(STAT.GE.YLEVEL(J-1) .AND. STAT.LT.YLEVEL(J))THEN 6768 ILEVEL=J 6769 ENDIF 6770 1025 CONTINUE 6771 ENDIF 6772C 6773 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAC2')THEN 6774 WRITE(ICOUT,1026)I,STAT,YVAL,XVAL,YVAL2 6775 1026 FORMAT('I,STAT,YVAL,XVAL,YVAL2 = ',I8,4G15.7) 6776 CALL DPWRST('XXX','BUG ') 6777 WRITE(ICOUT,1027)XCOOR1,YCOOR1,ILEVEL 6778 1027 FORMAT('XCOOR1,YCOOR1,ILEVEL = ',2G15.7,I8) 6779 CALL DPWRST('XXX','BUG ') 6780 WRITE(ICOUT,1028)ILEVEL 6781 1028 FORMAT('ILEVEL = ',I8) 6782 CALL DPWRST('XXX','BUG ') 6783 ENDIF 6784C 6785 ICNT=ICNT+1 6786 X(ICNT)=XCOOR1 6787 Y(ICNT)=YCOOR1 6788 X3D(ICNT)=STAT 6789 D(ICNT)=REAL(ILEVEL) 6790C 6791 1020 CONTINUE 6792C 6793 NPLOTP=ICNT 6794 NPLOTV=2 6795C 6796 ELSEIF(NCRTV.EQ.4)THEN 6797 CALL DPTAP5(Y1,Y2,Y3,TAG1,TAG2,TAG3,TAG4,N, 6798 1 NUMV2,ICASCT,ISTANR, 6799 1 XIDTEM,XIDTE2,XIDTE3,XIDTE4, 6800 1 NUMSE1,NUMSE2,NUMSE3,NUMSE4, 6801 1 TEMP1,TEMP2,TMP11,TEMP3,TEMP4,TEMP5, 6802 1 ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 6803 1 DTEMP1,DTEMP2,DTEMP3, 6804 1 ISEED,ALPHA, 6805 1 ICTAMV,PCTAMV,PSTAMV,IQUASE, 6806 1 TEMP6,TEMP7,TEMP8,TEMP9,TMP10,XACLOW,XACUPP,N2, 6807 1 ISUBRO,IBUGG3,IERROR) 6808C 6809CCCCC NOW GENERATE THE PLOT COORDINATES. 6810C 6811 ICNT=0 6812C 6813 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAC2')THEN 6814 WRITE(ICOUT,1031)N2 6815 1031 FORMAT('DPTAC2: AFTER CALL DPTAP5--N2 = ',I8) 6816 CALL DPWRST('XXX','BUG ') 6817 ENDIF 6818C 6819 DO1030I=1,N2 6820 STAT=TEMP6(I) 6821 IF(ITPLDI.EQ.'X')THEN 6822 XVAL=TEMP7(I) 6823 YVAL=TEMP8(I) 6824 XVAL2=TEMP9(I) 6825 YVAL2=TMP10(I) 6826 ELSE 6827 YVAL=TEMP7(I) 6828 XVAL=TEMP8(I) 6829 YVAL2=TEMP9(I) 6830 XVAL2=TMP10(I) 6831 ENDIF 6832 XCOOR1=XVAL + XVAL2/REAL(NUMSE3) 6833 YCOOR1=YVAL + YVAL2/REAL(NUMSE4) 6834 YCOOR2=YCOOR1 + YINC2 6835 IF(STAT.LT.YLEVEL(1))THEN 6836 ILEVEL=1 6837 ELSEIF(STAT.GE.YLEVEL(NLEVEL))THEN 6838 ILEVEL=NLEVEL+1 6839 ELSE 6840 DO1035J=2,NLEVEL 6841 IF(STAT.GE.YLEVEL(J-1) .AND. STAT.LT.YLEVEL(J))THEN 6842 ILEVEL=J 6843 ENDIF 6844 1035 CONTINUE 6845 ENDIF 6846C 6847 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAC2')THEN 6848 WRITE(ICOUT,1036)I,STAT,YVAL,XVAL,YVAL2,XVAL2 6849 1036 FORMAT('I,STAT,YVAL,XVAL,YVAL2,XVAL2 = ',I8,5G15.7) 6850 CALL DPWRST('XXX','BUG ') 6851 WRITE(ICOUT,1037)XCOOR1,YCOOR1,ILEVEL 6852 1037 FORMAT('XCOOR1,YCOOR1,ILEVEL = ',2G15.7,I8) 6853 CALL DPWRST('XXX','BUG ') 6854 ENDIF 6855C 6856 ICNT=ICNT+1 6857 X(ICNT)=XCOOR1 6858 Y(ICNT)=YCOOR1 6859 X3D(ICNT)=STAT 6860 D(ICNT)=REAL(ILEVEL) 6861C 6862 1030 CONTINUE 6863C 6864 NPLOTP=ICNT 6865 NPLOTV=2 6866C 6867 ENDIF 6868C 6869C NOW DUPLICATE ARRAYS 6870C 6871 IF(NPLOTP.GT.0)THEN 6872 DO2010I=1,NPLOTP 6873 NPLOTP=NPLOTP+1 6874 X(NPLOTP)=X(I) 6875 Y(NPLOTP)=Y(I) 6876 X3D(NPLOTP)=X3D(I) 6877CCCCC D(NPLOTP)=D(I) + REAL(NLEVEL+1+IADD+1) 6878 D(NPLOTP)=D(I) + REAL(NLEVEL+1+IADD) 6879 2010 CONTINUE 6880 ENDIF 6881C 6882C ***************** 6883C ** STEP 90-- ** 6884C ** EXIT ** 6885C ***************** 6886C 6887 9000 CONTINUE 6888 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TAC2')THEN 6889 WRITE(ICOUT,999) 6890 CALL DPWRST('XXX','BUG ') 6891 WRITE(ICOUT,9011) 6892 9011 FORMAT('***** AT THE END OF DPTAC2--') 6893 CALL DPWRST('XXX','BUG ') 6894 WRITE(ICOUT,9012)ICASCT,N,NPLOTP,NPLOTV,IERROR 6895 9012 FORMAT('ICASCT,N,NPLOTP,NPLOTV,IERROR = ',A4,3I8,2X,A4) 6896 CALL DPWRST('XXX','BUG ') 6897 DO9035I=1,NPLOTP 6898 WRITE(ICOUT,9036)I,Y(I),X(I),X3D(I),D(I) 6899 9036 FORMAT('I,Y(I),X(I),X3D(I),D(I) = ',I8,4G15.7) 6900 CALL DPWRST('XXX','BUG ') 6901 9035 CONTINUE 6902 ENDIF 6903C 6904 RETURN 6905 END 6906 SUBROUTINE DPTAIL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 6907 1 IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR) 6908C 6909C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS 6910C THAT WILL DEFINE AN (EMPIRICAL) TAIL AREA PLOT 6911C (A SYNONYM IS SURVIVAL PLOT) 6912C VERTICAL AXIS = 1-F(X) (ON A LOG10 SCALE) 6913C HORIZONTAL AXIS = SORTED DATA 6914C WRITTEN BY--JAMES J. FILLIBEN 6915C STATISTICAL ENGINEERING DIVISION 6916C INFORMATION TECHNOLOGY LABORATORY 6917C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 6918C GAITHERSBURG, MD 20899-8980 6919C PHONE--301-975-2899 6920C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 6921C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 6922C LANGUAGE--ANSI FORTRAN (1977) 6923C VERSION NUMBER--89/6 6924C ORIGINAL VERSION--MAY 1989. 6925C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON 6926C UPDATED --APRIL 1992. MAXCP31 TO MAXCP6 6927C UPDATED --JANUARY 2012. USE DPPARS 6928C UPDATED --JANUARY 2012. SUPPORT FOR MULTIPLE AND 6929C REPLICATION OPTIONS 6930C 6931C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 6932C 6933 CHARACTER*4 ICASPL 6934 CHARACTER*4 IAND1 6935 CHARACTER*4 IAND2 6936 CHARACTER*4 IBUGG2 6937 CHARACTER*4 IBUGG3 6938 CHARACTER*4 ISUBRO 6939 CHARACTER*4 IBUGQ 6940 CHARACTER*4 IFOUND 6941 CHARACTER*4 IERROR 6942C 6943 CHARACTER*4 ISUBN1 6944 CHARACTER*4 ISUBN2 6945 CHARACTER*4 ISTEPN 6946C 6947 CHARACTER*4 IREPL 6948 CHARACTER*4 IMULT 6949 CHARACTER*4 ICASE 6950 CHARACTER*40 INAME 6951 PARAMETER (MAXSPN=30) 6952 CHARACTER*4 IVARN1(MAXSPN) 6953 CHARACTER*4 IVARN2(MAXSPN) 6954 CHARACTER*4 IVARTY(MAXSPN) 6955 REAL PVAR(MAXSPN) 6956 INTEGER ILIS(MAXSPN) 6957 INTEGER NRIGHT(MAXSPN) 6958 INTEGER ICOLR(MAXSPN) 6959C 6960C--------------------------------------------------------------------- 6961C 6962 INCLUDE 'DPCOPA.INC' 6963 INCLUDE 'DPCOZZ.INC' 6964C 6965 DIMENSION Y1(MAXOBV) 6966 DIMENSION XIDTEM(MAXOBV) 6967 DIMENSION XIDTE2(MAXOBV) 6968 DIMENSION XIDTE3(MAXOBV) 6969 DIMENSION XTEMP1(MAXOBV) 6970 DIMENSION XTEMP2(MAXOBV) 6971 DIMENSION ZY1(MAXOBV) 6972 DIMENSION XDESGN(MAXOBV,2) 6973C 6974 EQUIVALENCE (GARBAG(IGARB1),Y1(1)) 6975 EQUIVALENCE (GARBAG(IGARB2),XTEMP1(1)) 6976 EQUIVALENCE (GARBAG(IGARB3),XTEMP2(1)) 6977 EQUIVALENCE (GARBAG(IGARB4),XIDTEM(1)) 6978 EQUIVALENCE (GARBAG(IGARB5),XIDTE2(1)) 6979 EQUIVALENCE (GARBAG(IGARB6),XIDTE3(1)) 6980 EQUIVALENCE (GARBAG(IGARB7),ZY1(1)) 6981 EQUIVALENCE (GARBAG(IGARB8),XDESGN(1,1)) 6982C 6983C-----COMMON---------------------------------------------------------- 6984C 6985 INCLUDE 'DPCOHK.INC' 6986 INCLUDE 'DPCODA.INC' 6987 INCLUDE 'DPCOP2.INC' 6988C 6989C-----START POINT----------------------------------------------------- 6990C 6991 IFOUND='NO' 6992 IERROR='NO' 6993 IREPL='OFF' 6994 IMULT='OFF' 6995 ISUBN1='DPTA' 6996 ISUBN2='IL ' 6997C 6998 MAXCP1=MAXCOL+1 6999 MAXCP2=MAXCOL+2 7000 MAXCP3=MAXCOL+3 7001 MAXCP4=MAXCOL+4 7002 MAXCP5=MAXCOL+5 7003 MAXCP6=MAXCOL+6 7004C 7005 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TAIL')THEN 7006 WRITE(ICOUT,999) 7007 999 FORMAT(1X) 7008 CALL DPWRST('XXX','BUG ') 7009 WRITE(ICOUT,51) 7010 51 FORMAT('***** AT THE BEGINNING OF DPTAIL--') 7011 CALL DPWRST('XXX','BUG ') 7012 WRITE(ICOUT,52)ICASPL,IAND1,IAND2,MAXCOL 7013 52 FORMAT('ICASPL,IAND1,IAND2 = ',3(A4,2X),I8) 7014 CALL DPWRST('XXX','BUG ') 7015 WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO 7016 53 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4) 7017 CALL DPWRST('XXX','BUG ') 7018 ENDIF 7019C 7020C 7021C ********************************** 7022C ** TREAT THE TAIL AREA PLOT ** 7023C ** = THE SURVIVAL PLOT ** 7024C ********************************** 7025C 7026C ******************************************* 7027C ** STEP 1-- ** 7028C ** SEARCH FOR TAIL AREA PLOT ** 7029C ** OR SURVIVAL PLOT ** 7030C ******************************************* 7031C 7032 ISTEPN='11' 7033 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TAIL') 7034 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7035C 7036 ICASPL='TAIL' 7037C 7038 IF(ICOM.EQ.'MULT')THEN 7039 IMULT='ON' 7040 IF((IHARG(1).EQ.'TAIL' .OR. IHARG(1).EQ.'SURV') .AND. 7041 1 IHARG(2).EQ.'PLOT')THEN 7042 ILASTC=2 7043 ELSEIF(IHARG(1).EQ.'TAIL' .AND. IHARG(2).EQ.'AREA' .AND. 7044 1 IHARG(3).EQ.'PLOT')THEN 7045 ILASTC=3 7046 ENDIF 7047 ELSEIF(ICOM.EQ.'REPL')THEN 7048 IREPL='ON' 7049 IF((IHARG(1).EQ.'TAIL' .OR. IHARG(1).EQ.'SURV') .AND. 7050 1 IHARG(2).EQ.'PLOT')THEN 7051 ILASTC=2 7052 ELSEIF(IHARG(1).EQ.'TAIL' .AND. IHARG(2).EQ.'AREA' .AND. 7053 1 IHARG(3).EQ.'PLOT')THEN 7054 ILASTC=3 7055 ENDIF 7056 ELSEIF((ICOM.EQ.'TAIL' .OR. ICOM.EQ.'SURV') .AND. 7057 1 IHARG(1).EQ.'PLOT')THEN 7058 ILASTC=1 7059 ELSEIF(ICOM.EQ.'TAIL' .AND. IHARG(1).EQ.'AREA' .AND. 7060 1 IHARG(2).EQ.'PLOT')THEN 7061 ILASTC=2 7062 ELSE 7063 GOTO9000 7064 ENDIF 7065C 7066 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 7067 IFOUND='YES' 7068C 7069C **************************************** 7070C ** STEP 2-- ** 7071C ** EXTRACT THE VARIABLE LIST ** 7072C **************************************** 7073C 7074 ISTEPN='2' 7075 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TAIL') 7076 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7077C 7078 INAME='TAIL AREA PLOT' 7079 MINNA=1 7080 MAXNA=100 7081 MINN2=1 7082 IFLAGE=1 7083 IF(IMULT.EQ.'ON')IFLAGE=0 7084 IFLAGM=1 7085 IFLAGP=0 7086 JMIN=1 7087 JMAX=NUMARG 7088 MINNVA=1 7089 MAXNVA=1 7090 IF(IREPL.EQ.'ON')THEN 7091 MINNVA=MINNVA+1 7092 MAXNVA=MAXNVA+2 7093 IFLAGM=0 7094 ELSEIF(IMULT.EQ.'ON')THEN 7095 MINNVA=1 7096 MAXNVA=MAXSPN 7097 ENDIF 7098C 7099 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 7100 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 7101 1 JMIN,JMAX, 7102 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 7103 1 IVARN1,IVARN2,IVARTY,PVAR, 7104 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 7105 1 MINNVA,MAXNVA, 7106 1 IFLAGM,IFLAGP, 7107 1 IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 7108 IF(IERROR.EQ.'YES')GOTO9000 7109C 7110 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TAIL')THEN 7111 WRITE(ICOUT,999) 7112 CALL DPWRST('XXX','BUG ') 7113 WRITE(ICOUT,281) 7114 281 FORMAT('***** AFTER CALL DPPARS--') 7115 CALL DPWRST('XXX','BUG ') 7116 WRITE(ICOUT,282)NQ,NUMVAR 7117 282 FORMAT('NQ,NUMVAR = ',2I8) 7118 CALL DPWRST('XXX','BUG ') 7119 IF(NUMVAR.GT.0)THEN 7120 DO285I=1,NUMVAR 7121 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 7122 1 ICOLR(I) 7123 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 7124 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 7125 CALL DPWRST('XXX','BUG ') 7126 285 CONTINUE 7127 ENDIF 7128 ENDIF 7129C 7130 NRESP=0 7131 NREPL=0 7132 IF(IREPL.EQ.'OFF' .AND. NUMVAR.GT.1)IMULT='ON' 7133 IF(IMULT.EQ.'ON')THEN 7134 NRESP=NUMVAR 7135 ELSEIF(IREPL.EQ.'ON')THEN 7136 NRESP=1 7137 NREPL=NUMVAR-NRESP 7138 IF(NREPL.LT.1 .OR. NREPL.GT.2)THEN 7139 WRITE(ICOUT,999) 7140 CALL DPWRST('XXX','BUG ') 7141 WRITE(ICOUT,101) 7142 101 FORMAT('***** ERROR IN TAIL ERROR PLOT--') 7143 CALL DPWRST('XXX','BUG ') 7144 WRITE(ICOUT,511) 7145 511 FORMAT(' FOR THE REPLICATION CASE, THE NUMBER OF ', 7146 1 'REPLICATION VARIABLES') 7147 CALL DPWRST('XXX','BUG ') 7148 WRITE(ICOUT,512) 7149 512 FORMAT(' MUST BE BETWEEN 1 AND 2; SUCH WAS NOT THE ', 7150 1 'CASE HERE.') 7151 CALL DPWRST('XXX','BUG ') 7152 WRITE(ICOUT,513)NREPL 7153 513 FORMAT(' THE NUMBER OF REPLICATION VARIABLES = ',I5) 7154 CALL DPWRST('XXX','BUG ') 7155 IERROR='YES' 7156 GOTO9000 7157 ENDIF 7158 ELSE 7159 NRESP=1 7160 ENDIF 7161C 7162C ******************************************** 7163C ** STEP 6-- ** 7164C ** GENERATE THE TAIL AREA PLOTS FOR ** 7165C ** THE VARIOUS CASES. ** 7166C ******************************************** 7167C 7168 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TAIL')THEN 7169 ISTEPN='6' 7170 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7171 WRITE(ICOUT,601)NRESP,NREPL 7172 601 FORMAT('NRESP,NREPL = ',2I5) 7173 CALL DPWRST('XXX','BUG ') 7174 ENDIF 7175C 7176 IF(NREPL.EQ.0)THEN 7177 ISTEPN='8A' 7178 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TAIL') 7179 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7180C 7181C LOOP THROUGH EACH OF THE RESPONSE VARIABLES 7182C 7183 NPLOTP=0 7184 DO810IRESP=1,NRESP 7185 NCURVE=IRESP 7186C 7187 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPEC')THEN 7188 WRITE(ICOUT,999) 7189 CALL DPWRST('XXX','BUG ') 7190 WRITE(ICOUT,811)IRESP,NCURVE 7191 811 FORMAT('IRESP,NCURVE = ',2I5) 7192 CALL DPWRST('XXX','BUG ') 7193 ENDIF 7194C 7195 ICOL=IRESP 7196 NUMVA2=1 7197 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 7198 1 INAME,IVARN1,IVARN2,IVARTY, 7199 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 7200 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 7201 1 MAXCP4,MAXCP5,MAXCP6, 7202 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 7203 1 Y1,Y1,Y1,NS,NS,NS,ICASE, 7204 1 IBUGG3,ISUBRO,IFOUND,IERROR) 7205 IF(IERROR.EQ.'YES')GOTO9000 7206C 7207C ***************************************************** 7208C ** STEP 8B-- ** 7209C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** 7210C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** 7211C ***************************************************** 7212C 7213 CALL DPTAI2(Y1,NS,NCURVE,ICASPL,MAXN, 7214 1 Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 7215C 7216 810 CONTINUE 7217C 7218C ***************************************************** 7219C ** STEP 9A-- ** 7220C ** CASE 3: ONE OR TWO REPLICATION VARIABLES. ** 7221C ** FOR THIS CASE, THE NUMBER OF RESPONSE ** 7222C ** VARIABLES MUST BE EXACTLY 1. ** 7223C ***************************************************** 7224C 7225 ELSEIF(NREPL.GE.1)THEN 7226 ISTEPN='9A' 7227 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TAIL') 7228 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7229C 7230 J=0 7231 IMAX=NRIGHT(1) 7232 IF(NQ.LT.NRIGHT(1))IMAX=NQ 7233 DO910I=1,IMAX 7234 IF(ISUB(I).EQ.0)GOTO910 7235 J=J+1 7236C 7237C RESPONSE VARIABLE IN Y1 7238C 7239 IJ=MAXN*(ICOLR(1)-1)+I 7240 IF(ICOLR(1).LE.MAXCOL)Y1(J)=V(IJ) 7241 IF(ICOLR(1).EQ.MAXCP1)Y1(J)=PRED(I) 7242 IF(ICOLR(1).EQ.MAXCP2)Y1(J)=RES(I) 7243 IF(ICOLR(1).EQ.MAXCP3)Y1(J)=YPLOT(I) 7244 IF(ICOLR(1).EQ.MAXCP4)Y1(J)=XPLOT(I) 7245 IF(ICOLR(1).EQ.MAXCP5)Y1(J)=X2PLOT(I) 7246 IF(ICOLR(1).EQ.MAXCP6)Y1(J)=TAGPLO(I) 7247 ICOLC=1 7248C 7249 DO920IR=1,MIN(NREPL,2) 7250 ICOLC=ICOLC+1 7251 ICOLT=ICOLR(ICOLC) 7252 IJ=MAXN*(ICOLT-1)+I 7253 IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ) 7254 IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I) 7255 IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I) 7256 IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I) 7257 IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I) 7258 IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I) 7259 IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I) 7260 920 CONTINUE 7261C 7262 910 CONTINUE 7263 NLOCAL=J 7264C 7265C ***************************************************** 7266C ** STEP 9B-- ** 7267C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** 7268C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** 7269C ** ** 7270C ** FOR THIS CASE, WE NEED TO LOOP THROUGH THE ** 7271C ** VARIOUS REPLICATIONS. ** 7272C ***************************************************** 7273C 7274 ISTEPN='9B' 7275 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TAIL')THEN 7276 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7277 WRITE(ICOUT,999) 7278 CALL DPWRST('XXX','BUG ') 7279 WRITE(ICOUT,931) 7280 931 FORMAT('***** FROM THE MIDDLE OF DPSPEC--') 7281 CALL DPWRST('XXX','BUG ') 7282 WRITE(ICOUT,932)ICASPL,NUMVAR,NLOCAL 7283 932 FORMAT('ICASPL,NUMVAR,NQ = ',A4,2I8) 7284 CALL DPWRST('XXX','BUG ') 7285 IF(NLOCAL.GE.1)THEN 7286 DO935I=1,NLOCAL 7287 WRITE(ICOUT,936)I,Y1(I),XDESGN(I,1),XDESGN(I,2) 7288 936 FORMAT('I,Y1(I),XDESGN(I,1),XDESGN(I,2) = ',I8,3F12.5) 7289 CALL DPWRST('XXX','BUG ') 7290 935 CONTINUE 7291 ENDIF 7292 ENDIF 7293C 7294C ***************************************************** 7295C ** STEP 9C-- ** 7296C ** FIND THE DISTINCT VALUES IN EACH OF THE ** 7297C ** REPLICATION VARIABLES. ** 7298C ***************************************************** 7299C 7300 CALL DPFRE5(XDESGN(1,1),XDESGN(1,2), 7301 1 NREPL,NLOCAL,MAXOBV, 7302 1 XIDTEM,XIDTE2, 7303 1 XTEMP1,XTEMP2, 7304 1 NUMSE1,NUMSE2, 7305 1 IBUGG3,ISUBRO,IERROR) 7306C 7307C ***************************************************** 7308C ** STEP 9D-- ** 7309C ** NOW LOOP THROUGH THE VARIOUS REPLICATIONS ** 7310C ***************************************************** 7311C 7312 NPLOTP=0 7313 NCURVE=0 7314 IF(NREPL.EQ.1)THEN 7315 J=0 7316 DO1110ISET1=1,NUMSE1 7317 K=0 7318 DO1130I=1,NLOCAL 7319 IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN 7320 K=K+1 7321 ZY1(K)=Y1(I) 7322 ENDIF 7323 1130 CONTINUE 7324 NTEMP=K 7325 NCURVE=NCURVE+1 7326 IF(NTEMP.GT.0)THEN 7327 CALL DPTAI2(ZY1,NTEMP,NCURVE,ICASPL,MAXN, 7328 1 Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 7329 ENDIF 7330 1110 CONTINUE 7331 ELSEIF(NREPL.EQ.2)THEN 7332 J=0 7333 NTOT=NUMSE1*NUMSE2 7334 DO1210ISET1=1,NUMSE1 7335 DO1220ISET2=1,NUMSE2 7336 K=0 7337 DO1290I=1,NLOCAL 7338 IF( 7339 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 7340 1 XIDTE2(ISET2).EQ.XDESGN(I,2) 7341 1 )THEN 7342 K=K+1 7343 ZY1(K)=Y1(I) 7344 ENDIF 7345 1290 CONTINUE 7346 NTEMP=K 7347 NCURVE=NCURVE+1 7348 IF(NTEMP.GT.0)THEN 7349 CALL DPTAI2(ZY1,NTEMP,NCURVE,ICASPL,MAXN, 7350 1 Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 7351 ENDIF 7352 1220 CONTINUE 7353 1210 CONTINUE 7354 ENDIF 7355 ENDIF 7356C 7357C ***************** 7358C ** STEP 90-- ** 7359C ** EXIT ** 7360C ***************** 7361C 7362 9000 CONTINUE 7363 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TAIL')THEN 7364 WRITE(ICOUT,999) 7365 CALL DPWRST('XXX','BUG ') 7366 WRITE(ICOUT,9011) 7367 9011 FORMAT('***** AT THE END OF DPTAIL--') 7368 CALL DPWRST('XXX','BUG ') 7369 WRITE(ICOUT,9012)IFOUND,IERROR 7370 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 7371 CALL DPWRST('XXX','BUG ') 7372 WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 7373 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',3I8,3(2X,A4)) 7374 CALL DPWRST('XXX','BUG ') 7375 IF(NPLOTP.GT.0)THEN 7376 DO9015I=1,NPLOTP 7377 WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 7378 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) 7379 CALL DPWRST('XXX','BUG ') 7380 9015 CONTINUE 7381 ENDIF 7382 ENDIF 7383C 7384 RETURN 7385 END 7386 SUBROUTINE DPTAI2(Y1,N,NCURVE,ICASPL,MAXN, 7387 1 Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 7388C 7389C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS 7390C THAT WILL DEFINE AN (EMPIRICAL) TAIL AREA PLOT 7391C (A SYNONYM IS SURVIVAL PLOT) 7392C VERTICAL AXIS = 1-F(X) (ON A LOG10 SCALE) 7393C HORIZONTAL AXIS = SORTED DATA 7394C INPUT ARGUMENTS--Y1 = THE SINGLE PRECISION VECTOR OF 7395C (UNSORTED) OBSERVATIONS 7396C FOR THE FIRST VARIABLE. 7397C N = THE INTEGER NUMBER OF OBSERVATIONS 7398C IN THE VECTOR X. 7399C CAUTION--THE INPUT VARIABLE Y1(.) WILL BE CHANGED HEREIN 7400C (IT WILL BE SORTED) 7401C WRITTEN BY--JAMES J. FILLIBEN 7402C STATISTICAL ENGINEERING DIVISION 7403C INFORMATION TECHNOLOGY LABORATORY 7404C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 7405C GAITHERSBURG, MD 20899-8980 7406C PHONE--301-975-2855 7407C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 7408C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 7409C LANGUAGE--ANSI FORTRAN (1977) 7410C VERSION NUMBER--89/6 7411C ORIGINAL VERSION--MAY 1989. 7412C 7413C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 7414C 7415 CHARACTER*4 ICASPL 7416 CHARACTER*4 IBUGG3 7417 CHARACTER*4 ISUBRO 7418 CHARACTER*4 IERROR 7419C 7420 CHARACTER*4 ISUBN1 7421 CHARACTER*4 ISUBN2 7422C 7423C--------------------------------------------------------------------- 7424C 7425 DIMENSION Y1(*) 7426 DIMENSION Y(*) 7427 DIMENSION X(*) 7428 DIMENSION D(*) 7429C 7430C-----COMMON---------------------------------------------------------- 7431C 7432 INCLUDE 'DPCOP2.INC' 7433C 7434C-----START POINT----------------------------------------------------- 7435C 7436 ISUBN1='DPTA' 7437 ISUBN2='I2 ' 7438 IERROR='NO' 7439C 7440 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TAI2')THEN 7441 WRITE(ICOUT,999) 7442 999 FORMAT(1X) 7443 CALL DPWRST('XXX','BUG ') 7444 WRITE(ICOUT,51) 7445 51 FORMAT('***** AT THE BEGINNING OF DPTAI2--') 7446 CALL DPWRST('XXX','BUG ') 7447 WRITE(ICOUT,52)IBUGG3,ISUBRO,IERROR 7448 52 FORMAT('IBUGG3,ISUBRO,IERROR = ',2(A4,2X),A4) 7449 CALL DPWRST('XXX','BUG ') 7450 WRITE(ICOUT,53)N,MAXN,NCURVE,ICASPL 7451 53 FORMAT('N,MAXN,NCURVE,ICASPL = ',3I8,2X,A4) 7452 CALL DPWRST('XXX','BUG ') 7453 DO55I=1,N 7454 WRITE(ICOUT,56)I,Y1(I) 7455 56 FORMAT('I,Y1(I) = ',I8,G15.7) 7456 CALL DPWRST('XXX','BUG ') 7457 55 CONTINUE 7458 ENDIF 7459C 7460C ******************************************** 7461C ** STEP 1-- ** 7462C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 7463C ******************************************** 7464C 7465 IF(N.LE.1)THEN 7466 WRITE(ICOUT,999) 7467 CALL DPWRST('XXX','BUG ') 7468 WRITE(ICOUT,111) 7469 111 FORMAT('***** ERROR IN TAIL AREA PLOT--') 7470 CALL DPWRST('XXX','BUG ') 7471 WRITE(ICOUT,112) 7472 112 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.') 7473 CALL DPWRST('XXX','BUG ') 7474 WRITE(ICOUT,114)N 7475 114 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) 7476 CALL DPWRST('XXX','BUG ') 7477 WRITE(ICOUT,999) 7478 CALL DPWRST('XXX','BUG ') 7479 IERROR='YES' 7480 GOTO9000 7481 ENDIF 7482C 7483 HOLD=Y1(1) 7484 DO120I=1,N 7485 IF(Y1(I).NE.HOLD)GOTO129 7486 120 CONTINUE 7487 WRITE(ICOUT,999) 7488 CALL DPWRST('XXX','BUG ') 7489 WRITE(ICOUT,111) 7490 CALL DPWRST('XXX','BUG ') 7491 WRITE(ICOUT,122)HOLD 7492 122 FORMAT(' ALL ELEMENTS IN THE RESPONSE VARIABLE ARE ', 7493 1 'IDENTICALLY EQUAL TO ',G15.7) 7494 CALL DPWRST('XXX','BUG ') 7495 WRITE(ICOUT,999) 7496 CALL DPWRST('XXX','BUG ') 7497 IERROR='YES' 7498 GOTO9000 7499 129 CONTINUE 7500C 7501C *********************************************** 7502C ** STEP 12-- ** 7503C ** COMPUTE COORDINATES FOR TAIL AREA PLOT ** 7504C ** (INCORPORATE STAIR-STEP APPEARANCE) ** 7505C ** NOTE--THE LOGGING OF THE 1-F(X) WILL ** 7506C ** NOTE BE DONE HEREIN BUT WILL ** 7507C ** BE DONE IN THE UNDERLYING ** 7508C ** GRAPHICS BY LOG SCALE ** 7509C *********************************************** 7510C 7511C 7512 CALL SORT(Y1,N,Y1) 7513C 7514 ANP1=N+1 7515 J=0 7516 DO1100I=1,N 7517 ARG1=N-I+1 7518 ARG2=N-I 7519 J=J+1 7520 X(J+NPLOTP)=Y1(I) 7521 Y(J+NPLOTP)=ARG1/ANP1 7522 D(J+NPLOTP)=REAL(NCURVE) 7523 IF(I.GE.N)GOTO1100 7524 J=J+1 7525 X(J+NPLOTP)=Y1(I) 7526 Y(J+NPLOTP)=ARG2/ANP1 7527 D(J+NPLOTP)=REAL(NCURVE) 7528 1100 CONTINUE 7529 NPLOTP=NPLOTP+J 7530 NPLOTV=2 7531 GOTO9000 7532C 7533C ****************** 7534C ** STEP 90-- ** 7535C ** EXIT ** 7536C ****************** 7537C 7538 9000 CONTINUE 7539 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TAI2')THEN 7540 WRITE(ICOUT,999) 7541 CALL DPWRST('XXX','BUG ') 7542 WRITE(ICOUT,9011) 7543 9011 FORMAT('***** AT THE END OF DPTAI2--') 7544 CALL DPWRST('XXX','BUG ') 7545 DO9015I=1,N 7546 WRITE(ICOUT,9016)I,Y1(I) 7547 9016 FORMAT('I,Y1(I) = ',I8,G15.7) 7548 CALL DPWRST('XXX','BUG ') 7549 9015 CONTINUE 7550 WRITE(ICOUT,9021)NPLOTP,NPLOTV,IERROR 7551 9021 FORMAT('NPLOTP,NPLOTV,IERROR = ',2I8,2X,A4) 7552 CALL DPWRST('XXX','BUG ') 7553 DO9022I=1,NPLOTP 7554 WRITE(ICOUT,9023)I,Y(I),X(I),D(I) 7555 9023 FORMAT('I,Y(I),X(I),D(I) = ',I8,3G15.7) 7556 CALL DPWRST('XXX','BUG ') 7557 9022 CONTINUE 7558 ENDIF 7559C 7560 RETURN 7561 END 7562 SUBROUTINE DPTAP0(Y,Z,Z2,TAG1,N, 7563 1 NUMV2,ICASCT,ISTANR, 7564 1 XIDTEM, 7565 1 NUMSE1, 7566 1 TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3, 7567 1 ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 7568 1 DTEMP1,DTEMP2,DTEMP3, 7569 1 ISEED,ALPHA, 7570 1 ICTAMV,PCTAMV,PSTAMV,IQUASE, 7571 1 Y2,X2,XACLOW,XACUPP,N2, 7572 1 ISUBRO,IBUGG3,IERROR) 7573C 7574C PURPOSE--GENERATE A ONE-WAY TABULATION PLOT. 7575C WRITTEN BY--ALAN HECKERT 7576C STATISTICAL ENGINEERING DIVISION 7577C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 7578C GAITHERSBURG, MD 20899-8980 7579C PHONE--301-975-2899 7580C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 7581C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 7582C LANGUAGE--ANSI FORTRAN (1977) 7583C VERSION NUMBER--2009/9 7584C ORIGINAL VERSION--SEPTEMBER 2009. 7585C UPDATED --DECEMBER 2009. UNCERTAINTY OPTION FOR 7586C BINOMIAL PROBABILITY, MEAN AND 7587C MEDIAN CONFIDENCE INTERVAL 7588C UPDATED --JANUARY 2010. SUPPORT FOR UNCERTAINTY INTERVALS 7589C FOR BINOMIAL RATIO 7590C 7591C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 7592C 7593 CHARACTER*4 ICASCT 7594 CHARACTER*4 ICTAMV 7595 CHARACTER*4 IQUASE 7596 CHARACTER*4 IBUGG3 7597 CHARACTER*4 ISUBRO 7598 CHARACTER*4 IERROR 7599C 7600 CHARACTER*4 ISUBN1 7601 CHARACTER*4 ISUBN2 7602 CHARACTER*4 ISTEPN 7603 CHARACTER*4 IWRITE 7604C 7605C--------------------------------------------------------------------- 7606C 7607 DIMENSION Y(*) 7608 DIMENSION Z(*) 7609 DIMENSION Z2(*) 7610 DIMENSION XIDTEM(*) 7611 DIMENSION Y2(*) 7612 DIMENSION X2(*) 7613C 7614 DIMENSION TAG1(*) 7615 DIMENSION TEMP(*) 7616 DIMENSION TEMPZ(*) 7617 DIMENSION TEMPZ2(*) 7618 DIMENSION XTEMP1(*) 7619 DIMENSION XTEMP2(*) 7620 DIMENSION XTEMP3(*) 7621C 7622 DIMENSION XACLOW(*) 7623 DIMENSION XACUPP(*) 7624C 7625 INTEGER ITEMP1(*) 7626 INTEGER ITEMP2(*) 7627 INTEGER ITEMP3(*) 7628 INTEGER ITEMP4(*) 7629 INTEGER ITEMP5(*) 7630 INTEGER ITEMP6(*) 7631C 7632 DOUBLE PRECISION DTEMP1(*) 7633 DOUBLE PRECISION DTEMP2(*) 7634 DOUBLE PRECISION DTEMP3(*) 7635C 7636C-----COMMON---------------------------------------------------------- 7637C 7638 INCLUDE 'DPCOP2.INC' 7639C 7640C-----START POINT----------------------------------------------------- 7641C 7642 ISUBN1='DPTA' 7643 ISUBN2='P0 ' 7644 IWRITE='OFF' 7645C 7646 I2=0 7647C 7648 AN=INT(N+0.01) 7649C 7650C *********************************************** 7651C ** STEP 5-- ** 7652C ** COMPUTE THE VARIOUS CROSS-TAB STATISTICS ** 7653C *********************************************** 7654C 7655 ISTEPN='5.1' 7656 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TAP0') 7657 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7658C 7659 J=0 7660 NRESP=NUMV2-1 7661 DO1110ISET1=1,NUMSE1 7662C 7663 K=0 7664 DO1130I=1,N 7665 IF(XIDTEM(ISET1).EQ.TAG1(I))GOTO1131 7666 GOTO1130 7667 1131 CONTINUE 7668C 7669 K=K+1 7670 TEMP(K)=0.0 7671 TEMPZ(K)=0.0 7672 TEMPZ2(K)=0.0 7673 IF(ISTANR.GE.1)TEMP(K)=Y(I) 7674 IF(ISTANR.GE.2)TEMPZ(K)=Z(I) 7675 IF(ISTANR.GE.3)TEMPZ2(K)=Z2(I) 7676 1130 CONTINUE 7677 NTEMP=K 7678C 7679 NTRIAL=0 7680 ALOWLM=0.0 7681 AUPPLM=0.0 7682 IF(NTEMP.EQ.0)THEN 7683 IF(ICTAMV.EQ.'ZERO')THEN 7684 STAT=0.0 7685 IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR. 7686 1 ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN 7687 NTRIAL=0 7688 ALOWLM=0.0 7689 AUPPLM=0.0 7690 ENDIF 7691 ELSEIF(ICTAMV.EQ.'MV ')THEN 7692 STAT=PCTAMV 7693 IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR. 7694 1 ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN 7695 NTRIAL=0 7696 ALOWLM=PCTAMV 7697 AUPPLM=PCTAMV 7698 ENDIF 7699 ELSE 7700 GOTO1110 7701 ENDIF 7702 ELSE 7703 CALL CMPSTA( 7704 1 TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3, 7705 1 MAXNXT,NTEMP,NTEMP,NTEMP, 7706 1 NRESP,ICASCT, 7707 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 7708 1 DTEMP1,DTEMP2,DTEMP3, 7709CCCCC1 IQUAME,IQUASE,PSTAMV, 7710 1 STAT, 7711 1 ISUBRO,IBUGG3,IERROR) 7712 IF(IERROR.EQ.'YES')GOTO9000 7713 IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN 7714 PTEMP=STAT 7715 NTRIAL=NTEMP 7716 IF(ICASCT.EQ.'BRAT')NTRIAL=ITEMP1(1) 7717 IF(STAT.EQ.PSTAMV)THEN 7718 ALOWLM=PSTAMV 7719 AUPPLM=PSTAMV 7720 ELSE 7721 ALPHAT=ALPHA 7722 IF(ALPHAT.LE.0.5)ALPHAT=1.0 - ALPHA 7723 CALL DPAGCO(PTEMP,NTRIAL,ALPHAT,IWRITE, 7724 1 ALOWLM,AUPPLM,IBUGG3,IERROR) 7725 ENDIF 7726 ELSEIF(ICASCT.EQ.'MECL')THEN 7727 XMEAN=STAT 7728 NTRIAL=NTEMP 7729 IF(STAT.EQ.PSTAMV)THEN 7730 ALOWLM=PSTAMV 7731 AUPPLM=PSTAMV 7732 ELSE 7733 CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGG3,IERROR) 7734 ALPHAT=ALPHA 7735 CALL DPMECL(XMEAN,XSD,NTEMP,ALPHAT,IWRITE, 7736 1 ALOWLM,AUPPLM,IBUGG3,IERROR) 7737 ENDIF 7738 ELSEIF(ICASCT.EQ.'MDCL')THEN 7739 XMED=STAT 7740 NTRIAL=NTEMP 7741 IF(STAT.EQ.PSTAMV)THEN 7742 ALOWLM=PSTAMV 7743 AUPPLM=PSTAMV 7744 ELSE 7745 XQ=0.5 7746 CALL QUANSE(XQ,TEMP,NTEMP,IWRITE,XTEMP1,MAXNXT,IQUASE, 7747 1 QUASE,IBUGG3,IERROR) 7748 ALPHAT=ALPHA 7749 CALL DPMECL(XMED,QUASE,NTEMP,ALPHAT,IWRITE, 7750 1 ALOWLM,AUPPLM,IBUGG3,IERROR) 7751 ENDIF 7752 ENDIF 7753 ENDIF 7754C 7755 J=J+1 7756 Y2(J)=STAT 7757 X2(J)=XIDTEM(ISET1) 7758 IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR. 7759 1 ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN 7760 IF(AUPPLM.GT.STATMX)STATMX=AUPPLM 7761 IF(ALOWLM.LT.STATMN)STATMN=ALOWLM 7762 XACLOW(J)=ALOWLM 7763 XACUPP(J)=AUPPLM 7764 ENDIF 7765C 7766 1110 CONTINUE 7767 N2=J 7768C 7769C ****************** 7770C ** STEP 90-- ** 7771C ** EXIT ** 7772C ****************** 7773C 7774 9000 CONTINUE 7775 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAP0')THEN 7776 WRITE(ICOUT,999) 7777 999 FORMAT(1X) 7778 CALL DPWRST('XXX','BUG ') 7779 WRITE(ICOUT,9011) 7780 9011 FORMAT('***** AT THE END OF DPTAP0--') 7781 CALL DPWRST('XXX','BUG ') 7782 WRITE(ICOUT,9012)ICASCT,N,NUMV2,IERROR 7783 9012 FORMAT('ICASCT,N,NUMV2,IERROR = ',A4,2I8,2X,A4) 7784 CALL DPWRST('XXX','BUG ') 7785 WRITE(ICOUT,9015)NUMSE1,N2 7786 9015 FORMAT('NUMSE1,N2 = ',2I8) 7787 CALL DPWRST('XXX','BUG ') 7788 DO9020I=1,N2 7789 WRITE(ICOUT,9021)I,Y2(I),X2(I) 7790 9021 FORMAT('I,Y2(I),X2(I) = ',I8,2G15.7) 7791 CALL DPWRST('XXX','BUG ') 7792 9020 CONTINUE 7793 ENDIF 7794C 7795 RETURN 7796 END 7797 SUBROUTINE DPTAPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 7798 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 7799C 7800C PURPOSE--GENERATE A TABULATION PLOT. 7801C 7802C THIS IS SOMEWHAT SIMILAR TO A FLUCTUATION PLOT. 7803C HOWEVER, INSTEAD OF A FILLED BAR BASED ON THE 7804C VALUE OF A STATISTIC, WE COLOR CODE BASED ON 7805C THE LEVEL OF THE RESPONSE VARIABLE (I.E., 7806C LIKE SPECIFYING THE LEVELS IN A CONTOUR PLOT). 7807C WE CURRENTLY SUPPORT THIS PLOT FOR ONE-WAY THROUGH 7808C FOUR-WAY TABLES. 7809C 7810C X1 = CATEGORY LEVEL FOR VARIABLE 1 7811C X2 = CATEGORY LEVEL FOR VARIABLE 2 7812C X3 = CATEGORY LEVEL FOR VARIABLE 3 7813C X4 = CATEGORY LEVEL FOR VARIABLE 4 7814C 7815C NOTE THAT WE EXTENED THE TABULATION PLOT TO ALLOW 7816C ANY OF DATAPLOT'S SUPPORTED STATISTICS TO BE 7817C PLOTTED (THE DEFAULT IS THE MEAN). 7818C 7819C EXAMPLES--TABULATION PLOT Y X1 X2 ZLEVEL 7820C --TABULATION PLOT Y X1 X2 X3 ZLEVEL 7821C --TABULATION PLOT Y X1 X2 X3 X4 ZLEVEL 7822C --TABULATION PLOT TABLE ZLEVEL 7823C --MEAN TABULATION PLOT Y X1 X2 ZLEVEL 7824C --SD TABULATION PLOT Y X1 X2 ZLEVEL 7825C WRITTEN BY--ALAN HECKERT 7826C STATISTICAL ENGINEERING DIVISION 7827C INFORMATION TECHNOLOGY LABORATORY 7828C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 7829C GAITHERSBURG, MD 20899-8980 7830C PHONE--301-975-2899 7831C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 7832C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 7833C LANGUAGE--ANSI FORTRAN (1977) 7834C VERSION NUMBER--2009/9 7835C ORIGINAL VERSION--SEPTEMBER 2009. 7836C UPDATED --JUNE 2010. ADD "CHARACTER TABULATION PLOT" 7837C CASE. THIS IS A VARIANT THAT 7838C PLOTS THE NUMERICAL VALUE OF THE 7839C STATISTIC RATHER THAN A COLORED 7840C RECTANGLE 7841C UPDATED --SEPTEMBER 2016. SUPPORT FOR MATRIX ARGUMENTS 7842C UPDATED --JULY 2019. TWEAK SCRATCH SPACE 7843C 7844C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 7845C 7846 CHARACTER*4 ICASPL 7847 CHARACTER*4 IAND1 7848 CHARACTER*4 IAND2 7849 CHARACTER*4 IBUGG2 7850 CHARACTER*4 IBUGG3 7851 CHARACTER*4 IBUGQ 7852 CHARACTER*4 ISUBRO 7853 CHARACTER*4 IFOUND 7854 CHARACTER*4 IERROR 7855C 7856 CHARACTER*4 ICASCT 7857 CHARACTER*4 IHP 7858 CHARACTER*4 IHP2 7859 CHARACTER*4 IHWUSE 7860 CHARACTER*4 MESSAG 7861 CHARACTER*4 ICASE 7862 CHARACTER*4 ISTADF 7863 CHARACTER*4 ISUBN1 7864 CHARACTER*4 ISUBN2 7865 CHARACTER*4 ISTEPN 7866C 7867 PARAMETER (MAXSPN=20) 7868 CHARACTER*4 IVARN1(MAXSPN) 7869 CHARACTER*4 IVARN2(MAXSPN) 7870 CHARACTER*4 IVARTY(MAXSPN) 7871 REAL PVAR(MAXSPN) 7872 INTEGER ILIS(MAXSPN) 7873 INTEGER NRIGHT(MAXSPN) 7874 INTEGER ICOLR(MAXSPN) 7875 CHARACTER*40 INAME 7876C 7877 CHARACTER*8 IYNAM 7878 CHARACTER*8 IXNAM 7879 CHARACTER*8 IX1NAM 7880 CHARACTER*8 IX2NAM 7881 CHARACTER*8 IX3NAM 7882 CHARACTER*8 IX4NAM 7883 CHARACTER*60 ICTNAM 7884C 7885C--------------------------------------------------------------------- 7886C 7887 INCLUDE 'DPCOPA.INC' 7888 INCLUDE 'DPCOZZ.INC' 7889 INCLUDE 'DPCOZI.INC' 7890 INCLUDE 'DPCOZD.INC' 7891C 7892 DIMENSION Y1(MAXOBV) 7893 DIMENSION Y2(MAXOBV) 7894 DIMENSION Y3(MAXOBV) 7895 DIMENSION YLEVEL(MAXOBV) 7896C 7897 DIMENSION XH1DIS(MAXOBV) 7898 DIMENSION XH2DIS(MAXOBV) 7899 DIMENSION XH3DIS(MAXOBV) 7900 DIMENSION XH4DIS(MAXOBV) 7901C 7902 DIMENSION X1(MAXOBV) 7903 DIMENSION X2(MAXOBV) 7904 DIMENSION X3(MAXOBV) 7905 DIMENSION X4(MAXOBV) 7906C 7907 DIMENSION TEMP1(MAXOBV) 7908 DIMENSION TEMP2(MAXOBV) 7909 DIMENSION TEMP3(MAXOBV) 7910 DIMENSION TEMP4(MAXOBV) 7911 DIMENSION TEMP5(MAXOBV) 7912 DIMENSION TEMP6(MAXOBV) 7913 DIMENSION TEMP7(MAXOBV) 7914 DIMENSION TEMP8(MAXOBV) 7915 DIMENSION TEMP9(MAXOBV) 7916 DIMENSION TMP10(MAXOBV) 7917 DIMENSION TMP11(MAXOBV) 7918C 7919 DIMENSION XACLOW(MAXOBV) 7920 DIMENSION XACUPP(MAXOBV) 7921C 7922 DIMENSION ITEMP1(MAXOBV) 7923 DIMENSION ITEMP2(MAXOBV) 7924 DIMENSION ITEMP3(MAXOBV) 7925 DIMENSION ITEMP4(MAXOBV) 7926 DIMENSION ITEMP5(MAXOBV) 7927 DIMENSION ITEMP6(MAXOBV) 7928 DOUBLE PRECISION DTEMP1(MAXOBV) 7929 DOUBLE PRECISION DTEMP2(MAXOBV) 7930 DOUBLE PRECISION DTEMP3(MAXOBV) 7931C 7932 EQUIVALENCE (GARBAG(IGARB1),Y1(1)) 7933 EQUIVALENCE (GARBAG(IGARB2),Y2(1)) 7934 EQUIVALENCE (GARBAG(IGARB3),YLEVEL(1)) 7935 EQUIVALENCE (GARBAG(IGARB4),X1(1)) 7936 EQUIVALENCE (GARBAG(IGARB5),X2(1)) 7937 EQUIVALENCE (GARBAG(IGARB6),X3(1)) 7938 EQUIVALENCE (GARBAG(IGARB7),X4(1)) 7939 EQUIVALENCE (GARBAG(IGARB8),XH1DIS(1)) 7940 EQUIVALENCE (GARBAG(IGARB9),XH2DIS(1)) 7941 EQUIVALENCE (GARBAG(IGAR10),XH3DIS(1)) 7942 EQUIVALENCE (GARBAG(JGAR11),XH4DIS(1)) 7943 EQUIVALENCE (GARBAG(JGAR12),TEMP1(1)) 7944 EQUIVALENCE (GARBAG(JGAR13),TEMP2(1)) 7945 EQUIVALENCE (GARBAG(JGAR14),TEMP3(1)) 7946 EQUIVALENCE (GARBAG(JGAR15),TEMP4(1)) 7947 EQUIVALENCE (GARBAG(JGAR16),TEMP5(1)) 7948 EQUIVALENCE (GARBAG(JGAR17),TEMP6(1)) 7949 EQUIVALENCE (GARBAG(JGAR18),TEMP7(1)) 7950 EQUIVALENCE (GARBAG(JGAR19),TEMP8(1)) 7951 EQUIVALENCE (GARBAG(JGAR20),TEMP9(1)) 7952 EQUIVALENCE (GARBAG(IGAR11),TMP10(1)) 7953 EQUIVALENCE (GARBAG(IGAR12),XACLOW(1)) 7954 EQUIVALENCE (GARBAG(IGAR13),XACUPP(1)) 7955 EQUIVALENCE (GARBAG(IGAR14),Y3(1)) 7956 EQUIVALENCE (GARBAG(IGAR15),TMP11(1)) 7957C 7958 EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1)) 7959 EQUIVALENCE (IGARBG(IIGAR2),ITEMP2(1)) 7960 EQUIVALENCE (IGARBG(IIGAR3),ITEMP3(1)) 7961 EQUIVALENCE (IGARBG(IIGAR4),ITEMP4(1)) 7962 EQUIVALENCE (IGARBG(IIGAR5),ITEMP5(1)) 7963 EQUIVALENCE (IGARBG(IIGAR6),ITEMP6(1)) 7964C 7965 EQUIVALENCE (DGARBG(IDGAR1),DTEMP1(1)) 7966 EQUIVALENCE (DGARBG(IDGAR2),DTEMP2(1)) 7967 EQUIVALENCE (DGARBG(IDGAR3),DTEMP3(1)) 7968C 7969C-----COMMON---------------------------------------------------------- 7970C 7971 INCLUDE 'DPCOSU.INC' 7972 INCLUDE 'DPCOHK.INC' 7973 INCLUDE 'DPCODA.INC' 7974 INCLUDE 'DPCOST.INC' 7975 INCLUDE 'DPCOHO.INC' 7976 INCLUDE 'DPCOP2.INC' 7977C 7978C-----START POINT----------------------------------------------------- 7979C 7980 IERROR='NO' 7981 IFOUND='NO' 7982 ISUBN1='DPTA' 7983 ISUBN2='PL ' 7984C 7985 IYNAM=' ' 7986 IXNAM=' ' 7987 IX1NAM=' ' 7988 IX2NAM=' ' 7989 IX3NAM=' ' 7990 IX4NAM=' ' 7991C 7992 MAXCP1=MAXCOL+1 7993 MAXCP2=MAXCOL+2 7994 MAXCP3=MAXCOL+3 7995 MAXCP4=MAXCOL+4 7996 MAXCP5=MAXCOL+5 7997 MAXCP6=MAXCOL+6 7998C 7999 MAXV2=7 8000 MINN2=2 8001 J2=0 8002C 8003C **************************************** 8004C ** TREAT THE TABULATION PLOT CASE ** 8005C **************************************** 8006C 8007 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TAPL')THEN 8008 WRITE(ICOUT,999) 8009 999 FORMAT(1X) 8010 CALL DPWRST('XXX','BUG ') 8011 WRITE(ICOUT,51) 8012 51 FORMAT('***** AT THE BEGINNING OF DPTAPL--') 8013 CALL DPWRST('XXX','BUG ') 8014 WRITE(ICOUT,52)IBUGG2,IBUGG3,IBUGQ,ISUBRO 8015 52 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4) 8016 CALL DPWRST('XXX','BUG ') 8017 WRITE(ICOUT,53)ICASPL,IAND1,IAND2,MAXN,NS 8018 53 FORMAT('ICASPL,IAND1,IAND2,NS = ',3(A4,2X),2I8) 8019 CALL DPWRST('XXX','BUG ') 8020 ENDIF 8021C 8022C *************************** 8023C ** STEP 1-- ** 8024C ** EXTRACT THE COMMAND ** 8025C *************************** 8026C 8027 ISTEPN='11' 8028 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TAPL') 8029 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8030C 8031C **************************************************** 8032C ** STEP 1.5-- ** 8033C ** SEARCH FOR TABULATION <STAT> PLOT ** 8034C ** SEARCH FOR CHARACTER TABULATION <STAT> PLOT ** 8035C **************************************************** 8036C 8037 ICASCT=' ' 8038C 8039 IF(NUMARG.LE.1)GOTO9000 8040 IF(ICOM.EQ.'TABU')THEN 8041 ICASPL='TABU' 8042 JMIN=1 8043 ELSEIF(ICOM.EQ.'CHAR' .AND. IHARG(1).EQ.'TABU')THEN 8044 ICASPL='TABC' 8045 JMIN=2 8046 ELSE 8047 GOTO9000 8048 ENDIF 8049C 8050CCCCC USE "EXTSTA" TO PARSE. NOTE THAT IF NO STATISTIC IS GIVEN, 8051CCCCC WE ASSUME THE "MEAN" CASE. 8052C 8053 JMAX=MIN(NUMARG,JMIN+6) 8054 DO200I=JMIN,JMAX 8055 IF(IHARG(I).EQ.'PLOT')THEN 8056 JMAX=I-1 8057 ILASTC=I 8058 GOTO209 8059 ENDIF 8060 200 CONTINUE 8061 IFOUND='NO' 8062 GOTO9000 8063 209 CONTINUE 8064C 8065 CALL EXTSTA(ICOM,ICOM2,IHARG,IHARG2,IARGT,ARG,NUMARG,JMIN,JMAX, 8066 1 ICASCT,ICTNAM,ISTANR,ISTADF,IFOUND,ILOCV, 8067 1 ISUBRO,IBUGG3,IERROR) 8068C 8069 IF(IFOUND.EQ.'NO')THEN 8070 ICTNAM='NUMBER' 8071 ILOCV=2 8072 IFOUND='YES' 8073 ENDIF 8074C 8075 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 8076C 8077C ********************************* 8078C ** STEP 2-- ** 8079C ** EXTRACT THE VARIABLE LIST ** 8080C ********************************* 8081C 8082 ISTEPN='2' 8083 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TAPL') 8084 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8085C 8086C 2016/09: ALLOW MATRIX ARGUMENTS 8087C 8088 INAME='TABULATION PLOT' 8089 MINNA=1 8090 MAXNA=100 8091 MAXVAR=100 8092 MINN2=2 8093 IFLAGE=99 8094 IFLAGM=1 8095 IFLAGP=0 8096 JMIN=1 8097 JMAX=NUMARG 8098 MINNVA=1 8099 MAXNVA=7 8100C 8101 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 8102 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 8103 1 JMIN,JMAX, 8104 1 MINN2,MINNA,MAXNA,MAXVAR,IFLAGE,INAME, 8105 1 IVARN1,IVARN2,IVARTY,PVAR, 8106 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 8107 1 MINNVA,MAXNVA, 8108 1 IFLAGM,IFLAGP, 8109 1 IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 8110 IF(IERROR.EQ.'YES')GOTO9000 8111C 8112 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TAPL')THEN 8113 WRITE(ICOUT,999) 8114 CALL DPWRST('XXX','BUG ') 8115 WRITE(ICOUT,251) 8116 251 FORMAT('***** AFTER CALL DPPARS--') 8117 CALL DPWRST('XXX','BUG ') 8118 WRITE(ICOUT,252)NQ,NUMVAR 8119 252 FORMAT('NQ,NUMVAR = ',2I8) 8120 CALL DPWRST('XXX','BUG ') 8121 IF(NUMVAR.GT.0)THEN 8122 DO255I=1,NUMVAR 8123 WRITE(ICOUT,257)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 8124 1 ICOLR(I) 8125 257 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 8126 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 8127 CALL DPWRST('XXX','BUG ') 8128 255 CONTINUE 8129 ENDIF 8130 ENDIF 8131C 8132C IF MATRIX ARGUMENTS GIVEN, THEN ALL RESPONSES MUST BE MATRICES 8133C AND ALL MATRICES MUST HAVE SAME DIMENSION. 8134C 8135 IFLAGM=0 8136 DO260I=1,NUMVAR 8137 IF(IVARTY(I).EQ.'MATR')IFLAGM=1 8138 260 CONTINUE 8139C 8140 IF(IFLAGM.EQ.1)THEN 8141C 8142 NRESP=ISTANR 8143 NLVARI=1 8144 IF(ICASPL.EQ.'TABC')NLVARI=0 8145 NCRTV=2 8146C 8147 DO291I=1,NRESP 8148 IF(IVARTY(I).NE.'MATR')THEN 8149 WRITE(ICOUT,999) 8150 CALL DPWRST('XXX','BUG ') 8151 WRITE(ICOUT,311) 8152 CALL DPWRST('XXX','BUG ') 8153 WRITE(ICOUT,292) 8154 292 FORMAT(' IF ONE RESPONSE VARIABLE IS A MATRIX, ', 8155 1 'THEN ALL MUST BE MATRICES.') 8156 CALL DPWRST('XXX','BUG ') 8157 WRITE(ICOUT,293)I 8158 293 FORMAT(' RESPONSE VARIABLE ',I5,' IS NOT A MATRIX.') 8159 CALL DPWRST('XXX','BUG ') 8160 IERROR='YES' 8161 GOTO9000 8162 ELSE 8163 ILISR=ILIS(I) 8164 NRTEMP=IN(ILISR) 8165 ICOL1=IVALUE(ILISR) 8166 ICOL2=IVALU2(ILISR) 8167 NCTEMP=(ICOL2 - ICOL1) + 1 8168 IF(I.EQ.1)THEN 8169 NROW=NRTEMP 8170 NCOL=NCTEMP 8171 ELSE 8172 IF(NRTEMP.NE.NROW .OR. NCTEMP.NE.NCOL)THEN 8173 WRITE(ICOUT,999) 8174 CALL DPWRST('XXX','BUG ') 8175 WRITE(ICOUT,311) 8176 CALL DPWRST('XXX','BUG ') 8177 WRITE(ICOUT,296) 8178 296 FORMAT(' FOR MATRIX RESPONSE VARIABLES, THE ', 8179 1 'ROW AND COLUMN DIMENSIONS MUST BE EQUAL.') 8180 CALL DPWRST('XXX','BUG ') 8181 WRITE(ICOUT,297)NROW,NCOL 8182 297 FORMAT(' THE FIRST MATRIX HAS ',I5,' ROWS AND ', 8183 1 I5,' COLUMNS.') 8184 CALL DPWRST('XXX','BUG ') 8185 WRITE(ICOUT,298)I,NRTEMP,NCTEMP 8186 298 FORMAT(' MATRIX ',I2,' HAS ',I5,' ROWS AND ', 8187 1 I5,' COLUMNS.') 8188 CALL DPWRST('XXX','BUG ') 8189 IERROR='YES' 8190 GOTO9000 8191 ENDIF 8192 ENDIF 8193 ENDIF 8194 291 CONTINUE 8195C 8196 NTEMP=NRESP + NLVARI 8197 IF(NTEMP.NE.NUMVAR)THEN 8198 WRITE(ICOUT,999) 8199 CALL DPWRST('XXX','BUG ') 8200 WRITE(ICOUT,311) 8201 CALL DPWRST('XXX','BUG ') 8202 WRITE(ICOUT,272) 8203 272 FORMAT(' WHEN MATRIX ARGUMENTS ARE GIVEN, THE ', 8204 1 'NUMBER OF MATRICES') 8205 CALL DPWRST('XXX','BUG ') 8206 WRITE(ICOUT,274) 8207 274 FORMAT(' MUST BE THE SAME AS THE NUMBER OF RESPONSE ', 8208 1 'VARIABLES FOR THE SELECTED STATISTIC.') 8209 CALL DPWRST('XXX','BUG ') 8210 WRITE(ICOUT,276)NUMVAR-NLVARI 8211 276 FORMAT(' THE NUMBER OF MATRICES ENTERED = ',I5) 8212 CALL DPWRST('XXX','BUG ') 8213 WRITE(ICOUT,278)ISTANR 8214 278 FORMAT(' THE NUMBER OF MATRICES EXPECTED = ',I5) 8215 CALL DPWRST('XXX','BUG ') 8216 IERROR='YES' 8217 GOTO9000 8218 ENDIF 8219C 8220 GOTO400 8221C 8222 ENDIF 8223C 8224C ****************************************************** 8225C ** STEP 3-- ** 8226C ** CHECK FOR ALLOWABLE NUMBER OF CROSS TABULATION ** 8227C ** VARIABLES. ** 8228C ****************************************************** 8229C 8230 ISTEPN='3' 8231 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TAPL') 8232 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8233C 8234C FOR "CHARACTER TABULATION" CASE, THE "LEVELS" VARIABLE IS OPTIONAL. 8235C IF LAST VARIABLE HAS SAME NUMBER OF OBSERVATIONS AS FIRST VARIABLE, 8236C ASSUME NO "LEVEL" VARIABLE GIVEN. 8237C 8238 NRESP=ISTANR 8239 NLVARI=1 8240 IF(ICASPL.EQ.'TABC' .AND. NRIGHT(1).EQ.NRIGHT(NUMVAR)) NLVARI=0 8241 NCRTV=NUMVAR - NRESP - NLVARI 8242C 8243 IF(NCRTV.LT.1 .OR. NCRTV.GT.4)THEN 8244 WRITE(ICOUT,999) 8245 CALL DPWRST('XXX','BUG ') 8246 WRITE(ICOUT,311) 8247 311 FORMAT('***** ERROR IN TABULATION PLOT--') 8248 CALL DPWRST('XXX','BUG ') 8249 WRITE(ICOUT,312) 8250 312 FORMAT(' THE NUMBER OF CROSS TABULATION VARIABLES MUST') 8251 CALL DPWRST('XXX','BUG ') 8252 WRITE(ICOUT,313) 8253 313 FORMAT(' BE BETWEEN 1 AND 4. SUCH WAS NOT THE CASE HERE;') 8254 CALL DPWRST('XXX','BUG ') 8255 WRITE(ICOUT,314)NCRTV 8256 314 FORMAT(' THE SPECIFIED NUMBER OF CROSS TABULATION ', 8257 1 'VARIABLES WAS ',I8) 8258 CALL DPWRST('XXX','BUG ') 8259 IF(IWIDTH.GE.1)THEN 8260 WRITE(ICOUT,318)(IANS(I),I=1,MIN(80,IWIDTH)) 8261 318 FORMAT(80A1) 8262 CALL DPWRST('XXX','BUG ') 8263 ENDIF 8264 IERROR='YES' 8265 GOTO9000 8266 ENDIF 8267C 8268C ****************************************************** 8269C ** STEP 4-- ** 8270C ** CREATE THE VARIABLES ** 8271C ****************************************************** 8272C 8273 400 CONTINUE 8274C 8275 ISTEPN='4' 8276 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TAPL') 8277 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8278C 8279 IF(IFLAGM.EQ.1)THEN 8280 ICOL=1 8281 CALL DPPARZ(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 8282 1 INAME,IVARN1,IVARN2,IVARTY, 8283 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 8284 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 8285 1 MAXCP4,MAXCP5,MAXCP6, 8286 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 8287 1 Y1,X1,X2,NLOCAL, 8288 1 IBUGG2,ISUBRO,IFOUND,IERROR) 8289 IF(IERROR.EQ.'YES')GOTO9000 8290C 8291 IF(NRESP.GE.2)THEN 8292 ICOL=2 8293 CALL DPPARZ(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 8294 1 INAME,IVARN1,IVARN2,IVARTY, 8295 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 8296 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 8297 1 MAXCP4,MAXCP5,MAXCP6, 8298 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 8299 1 Y2,X3,X4,N2, 8300 1 IBUGG2,ISUBRO,IFOUND,IERROR) 8301 IF(IERROR.EQ.'YES')GOTO9000 8302 ENDIF 8303C 8304 IF(NRESP.GE.3)THEN 8305 ICOL=3 8306 CALL DPPARZ(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 8307 1 INAME,IVARN1,IVARN2,IVARTY, 8308 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 8309 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 8310 1 MAXCP4,MAXCP5,MAXCP6, 8311 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 8312 1 Y3,X3,X4,N3, 8313 1 IBUGG2,ISUBRO,IFOUND,IERROR) 8314 IF(IERROR.EQ.'YES')GOTO9000 8315 ENDIF 8316C 8317 GOTO499 8318 ENDIF 8319C 8320 J=0 8321 IMAX=NRIGHT(1) 8322 IF(NQ.LT.NRIGHT(1))IMAX=NQ 8323 DO410I=1,IMAX 8324 IF(ISUB(I).EQ.0)GOTO410 8325 J=J+1 8326C 8327 IJ=MAXN*(ICOLR(1)-1)+I 8328 IF(ISTANR.LT.1)THEN 8329 Y1(J)=0.0 8330 ELSE 8331 IF(ICOLR(1).LE.MAXCOL)Y1(J)=V(IJ) 8332 IF(ICOLR(1).EQ.MAXCP1)Y1(J)=PRED(I) 8333 IF(ICOLR(1).EQ.MAXCP2)Y1(J)=RES(I) 8334 IF(ICOLR(1).EQ.MAXCP3)Y1(J)=YPLOT(I) 8335 IF(ICOLR(1).EQ.MAXCP4)Y1(J)=XPLOT(I) 8336 IF(ICOLR(1).EQ.MAXCP5)Y1(J)=X2PLOT(I) 8337 IF(ICOLR(1).EQ.MAXCP6)Y1(J)=TAGPLO(I) 8338 ENDIF 8339C 8340 IJ=MAXN*(ICOLR(2)-1)+I 8341 IF(ISTANR.LT.2)THEN 8342 Y2(J)=0.0 8343 ELSE 8344 IF(ICOLR(2).LE.MAXCOL)Y2(J)=V(IJ) 8345 IF(ICOLR(2).EQ.MAXCP1)Y2(J)=PRED(I) 8346 IF(ICOLR(2).EQ.MAXCP2)Y2(J)=RES(I) 8347 IF(ICOLR(2).EQ.MAXCP3)Y2(J)=YPLOT(I) 8348 IF(ICOLR(2).EQ.MAXCP4)Y2(J)=XPLOT(I) 8349 IF(ICOLR(2).EQ.MAXCP5)Y2(J)=X2PLOT(I) 8350 IF(ICOLR(2).EQ.MAXCP6)Y2(J)=TAGPLO(I) 8351 ENDIF 8352C 8353 IJ=MAXN*(ICOLR(3)-1)+I 8354 IF(ISTANR.LT.3)THEN 8355 Y3(J)=0.0 8356 ELSE 8357 IF(ICOLR(3).LE.MAXCOL)Y3(J)=V(IJ) 8358 IF(ICOLR(3).EQ.MAXCP1)Y3(J)=PRED(I) 8359 IF(ICOLR(3).EQ.MAXCP2)Y3(J)=RES(I) 8360 IF(ICOLR(3).EQ.MAXCP3)Y3(J)=YPLOT(I) 8361 IF(ICOLR(3).EQ.MAXCP4)Y3(J)=XPLOT(I) 8362 IF(ICOLR(3).EQ.MAXCP5)Y3(J)=X2PLOT(I) 8363 IF(ICOLR(3).EQ.MAXCP6)Y3(J)=TAGPLO(I) 8364 ENDIF 8365C 8366 ICNT=ISTANR+1 8367 IF(NCRTV.GE.1)THEN 8368 IJ=MAXN*(ICOLR(ICNT)-1)+I 8369 IF(ICOLR(ICNT).LE.MAXCOL)X1(J)=V(IJ) 8370 IF(ICOLR(ICNT).EQ.MAXCP1)X1(J)=PRED(I) 8371 IF(ICOLR(ICNT).EQ.MAXCP2)X1(J)=RES(I) 8372 IF(ICOLR(ICNT).EQ.MAXCP3)X1(J)=YPLOT(I) 8373 IF(ICOLR(ICNT).EQ.MAXCP4)X1(J)=XPLOT(I) 8374 IF(ICOLR(ICNT).EQ.MAXCP5)X1(J)=X2PLOT(I) 8375 IF(ICOLR(ICNT).EQ.MAXCP6)X1(J)=TAGPLO(I) 8376 ELSE 8377 X1(J)=0.0 8378 ENDIF 8379C 8380 ICNT=ISTANR+2 8381 IF(NCRTV.GE.2)THEN 8382 IJ=MAXN*(ICOLR(ICNT)-1)+I 8383 IF(ICOLR(ICNT).LE.MAXCOL)X2(J)=V(IJ) 8384 IF(ICOLR(ICNT).EQ.MAXCP1)X2(J)=PRED(I) 8385 IF(ICOLR(ICNT).EQ.MAXCP2)X2(J)=RES(I) 8386 IF(ICOLR(ICNT).EQ.MAXCP3)X2(J)=YPLOT(I) 8387 IF(ICOLR(ICNT).EQ.MAXCP4)X2(J)=XPLOT(I) 8388 IF(ICOLR(ICNT).EQ.MAXCP5)X2(J)=X2PLOT(I) 8389 IF(ICOLR(ICNT).EQ.MAXCP6)X2(J)=TAGPLO(I) 8390 ELSE 8391 X2(J)=0.0 8392 ENDIF 8393C 8394 ICNT=ISTANR+3 8395 IF(NCRTV.GE.3)THEN 8396 IJ=MAXN*(ICOLR(ICNT)-1)+I 8397 IF(ICOLR(ICNT).LE.MAXCOL)X3(J)=V(IJ) 8398 IF(ICOLR(ICNT).EQ.MAXCP1)X3(J)=PRED(I) 8399 IF(ICOLR(ICNT).EQ.MAXCP2)X3(J)=RES(I) 8400 IF(ICOLR(ICNT).EQ.MAXCP3)X3(J)=YPLOT(I) 8401 IF(ICOLR(ICNT).EQ.MAXCP4)X3(J)=XPLOT(I) 8402 IF(ICOLR(ICNT).EQ.MAXCP5)X3(J)=X2PLOT(I) 8403 IF(ICOLR(ICNT).EQ.MAXCP6)X3(J)=TAGPLO(I) 8404 ELSE 8405 X3(J)=0.0 8406 ENDIF 8407C 8408 ICNT=ISTANR+4 8409 IF(NCRTV.GE.4)THEN 8410 IJ=MAXN*(ICOLR(ICNT)-1)+I 8411 IF(ICOLR(ICNT).LE.MAXCOL)X4(J)=V(IJ) 8412 IF(ICOLR(ICNT).EQ.MAXCP1)X4(J)=PRED(I) 8413 IF(ICOLR(ICNT).EQ.MAXCP2)X4(J)=RES(I) 8414 IF(ICOLR(ICNT).EQ.MAXCP3)X4(J)=YPLOT(I) 8415 IF(ICOLR(ICNT).EQ.MAXCP4)X4(J)=XPLOT(I) 8416 IF(ICOLR(ICNT).EQ.MAXCP5)X4(J)=X2PLOT(I) 8417 IF(ICOLR(ICNT).EQ.MAXCP6)X4(J)=TAGPLO(I) 8418 ELSE 8419 X4(J)=0.0 8420 ENDIF 8421C 8422 410 CONTINUE 8423 NLOCAL=J 8424C 8425 499 CONTINUE 8426C 8427 IF(NLVARI.GE.1)THEN 8428 J2=0 8429 IMAX=NRIGHT(NUMVAR) 8430 DO490I=1,IMAX 8431 J2=J2+1 8432C 8433 IJ=MAXN*(ICOLR(NUMVAR)-1)+I 8434 IF(ICOLR(NUMVAR).LE.MAXCOL)YLEVEL(J2)=V(IJ) 8435 IF(ICOLR(NUMVAR).EQ.MAXCP1)YLEVEL(J2)=PRED(I) 8436 IF(ICOLR(NUMVAR).EQ.MAXCP2)YLEVEL(J2)=RES(I) 8437 IF(ICOLR(NUMVAR).EQ.MAXCP3)YLEVEL(J2)=YPLOT(I) 8438 IF(ICOLR(NUMVAR).EQ.MAXCP4)YLEVEL(J2)=XPLOT(I) 8439 IF(ICOLR(NUMVAR).EQ.MAXCP5)YLEVEL(J2)=X2PLOT(I) 8440 IF(ICOLR(NUMVAR).EQ.MAXCP6)YLEVEL(J2)=TAGPLO(I) 8441 490 CONTINUE 8442 NLEVEL=J2 8443 ELSE 8444 YLEVEL(J2)=CPUMIN 8445 NLEVEL=-99 8446 ENDIF 8447C 8448C ************************************* 8449C ** STEP 5-- ** 8450C ** GENERATE THE TABULATION PLOT ** 8451C ************************************* 8452C 8453 ISTEPN='61' 8454 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TAPL')THEN 8455 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8456 WRITE(ICOUT,6001)NLOCAL,NLEVEL,ICASPL 8457 6001 FORMAT('NLOCAL,NLEVEL,ICASPL=',2I8,1X,A4) 8458 CALL DPWRST('XXX','BUG ') 8459 ENDIF 8460C 8461 IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR. 8462 1 ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN 8463 IHP='ALPH' 8464 IHP2='A ' 8465 IHWUSE='P' 8466 MESSAG='NO' 8467 CALL CHECKN(IHP,IHP2,IHWUSE, 8468 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE, 8469 1 NUMNAM,MAXNAM, 8470 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH, 8471 1 ILOCP,IERROR) 8472 IF(IERROR.EQ.'YES')THEN 8473 ALPHA=0.05 8474 ELSE 8475 ALPHA=VALUE(ILOCP) 8476 IF(ALPHA.LE.0.0)ALPHA=0.05 8477 IF(ALPHA.GE.1.0)ALPHA=0.05 8478 ENDIF 8479 ELSE 8480 ALPHA=0.05 8481 ENDIF 8482C 8483 IF(ICASPL.EQ.'TABU')THEN 8484 CALL DPTAP2(Y1,Y2,Y3,X1,X2,X3,X4,NLOCAL,YLEVEL,NLEVEL, 8485 1 NUMVAR,ICASCT,ICTNAM,ISTANR, 8486 1 XH1DIS,XH2DIS,XH3DIS,XH4DIS, 8487 1 TEMP1,TEMP2,TEMP3,TEMP4,TEMP5, 8488 1 TEMP6,TEMP7,TEMP8,TEMP9,TMP10,TMP11, 8489 1 XACLOW,XACUPP, 8490 1 ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 8491 1 DTEMP1,DTEMP2,DTEMP3, 8492 1 ISEED,ICTAMV,PSTAMV,PCTAMV,ALPHA,IQUASE, 8493 1 NCRTV,MAXOBV,PTPLXI,PTPLYI,ITPLDI,ITPLUN, 8494 1 ITPLNI,ITPLCD, 8495 1 ITPLSO,ITPLSR,ITPLSC, 8496 1 ITPLRM,ITPLCM, 8497 1 Y,X,D,DCOLOR, 8498 1 NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 8499 ELSE 8500 CALL DPTAC2(Y1,Y2,Y3,X1,X2,X3,X4,NLOCAL,YLEVEL,NLEVEL, 8501 1 NUMVAR,ICASCT,ICTNAM,ISTANR, 8502 1 XH1DIS,XH2DIS,XH3DIS,XH4DIS, 8503 1 TEMP1,TEMP2,TEMP3,TEMP4,TEMP5, 8504 1 TEMP6,TEMP7,TEMP8,TEMP9,TMP10,TMP11, 8505 1 XACLOW,XACUPP, 8506 1 ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 8507 1 DTEMP1,DTEMP2,DTEMP3, 8508 1 ISEED,ICTAMV,PSTAMV,PCTAMV,ALPHA,IQUASE, 8509 1 NCRTV,MAXOBV,PTPLXI,PTPLYI,ITPLDI,ITPLUN, 8510 1 ITPLNI,ITPLCD,ITPLSO,ITPLSR,ITPLSC, 8511 1 ITPLRM,ITPLCM, 8512 1 Y,X,D,X3D, 8513 1 NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 8514 ENDIF 8515C 8516C ***************** 8517C ** STEP 9-- ** 8518C ** EXIT ** 8519C ***************** 8520C 8521 9000 CONTINUE 8522 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'TAPL')THEN 8523 WRITE(ICOUT,999) 8524 CALL DPWRST('XXX','BUG ') 8525 WRITE(ICOUT,9011) 8526 9011 FORMAT('***** AT THE END OF DPTAPL--') 8527 CALL DPWRST('XXX','BUG ') 8528 WRITE(ICOUT,9012)IBUGG2,IBUGG3,IBUGQ,ISUBRO 8529 9012 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4) 8530 CALL DPWRST('XXX','BUG ') 8531 WRITE(ICOUT,9013)IFOUND,IERROR 8532 9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 8533 CALL DPWRST('XXX','BUG ') 8534 WRITE(ICOUT,9014)NPLOTV,NPLOTP,NLOCAL,ICASPL,IAND1,IAND2 8535 9014 FORMAT('NPLOTV,NPLOTP,NLOCAL,ICASPL,IAND1,IAND2 = ', 8536 1 I8,I8,I8,2X,A4,2X,A4,2X,A4) 8537 CALL DPWRST('XXX','BUG ') 8538 WRITE(ICOUT,9041)NLOCAL 8539 9041 FORMAT('NLOCAL = ',I8) 8540 CALL DPWRST('XXX','BUG ') 8541 IF(NLOCAL.GE.1 .AND. ICASE.EQ.'VARI')THEN 8542 DO9042I=1,NLOCAL 8543 WRITE(ICOUT,9043)I,Y1(I),Y2(I) 8544 9043 FORMAT('I,Y1(I),Y2(I) = ',I8,2E15.7) 8545 CALL DPWRST('XXX','BUG ') 8546 9042 CONTINUE 8547 ENDIF 8548 WRITE(ICOUT,9051)NPLOTP 8549 9051 FORMAT('NPLOTP = ',I8) 8550 CALL DPWRST('XXX','BUG ') 8551 IF(NPLOTP.GE.1)THEN 8552 DO9052I=1,NPLOTP 8553 WRITE(ICOUT,9053)I,Y(I),X(I),D(I),DCOLOR(I) 8554 9053 FORMAT('I,Y(I),X(I),D(I),DCOLOR(I),',I8,4F12.5) 8555 CALL DPWRST('XXX','BUG ') 8556 9052 CONTINUE 8557 ENDIF 8558 ENDIF 8559C 8560 RETURN 8561 END 8562 SUBROUTINE DPTAP2(Y1,Y2,Y3,TAG1,TAG2,TAG3,TAG4,N,YLEVEL,NLEVEL, 8563 1 NUMV2,ICASCT,ICTNAM,ISTANR, 8564 1 XIDTEM,XIDTE2,XIDTE3,XIDTE4, 8565 1 TEMP1,TEMP2,TEMP3,TEMP4,TEMP5, 8566 1 TEMP6,TEMP7,TEMP8,TEMP9,TMP10,TMP11, 8567 1 XACLOW,XACUPP, 8568 1 ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 8569 1 DTEMP1,DTEMP2,DTEMP3, 8570 1 ISEED,ICTAMV,PSTAMV,PCTAMV,ALPHA,IQUASE, 8571 1 NCRTV,MAXOBV,PTPLXI,PTPLYI,ITPLDI,ITPLUN, 8572 1 ITPLNI,ITPLCD,ITPLSO,ITPLSR,ITPLSC, 8573 1 ITPLRM,ITPLCM, 8574 1 Y,X,D,DCOLOR, 8575 1 NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 8576C 8577C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS 8578C THAT WILL DEFINE AN TABULATION PLOT 8579C DESCRIPTION--IN THE TABULATION PLOT, WE CROSS-TABULATE OVER 8580C 1 TO 4 GROUP-ID VARIABLES (ANALAGOUS TO A 8581C FLUCTUATION PLOT). WE DEFINE A GRID BASED ON THE 8582C THESE GROUP-ID VARIABLES. THEN FOR THE RESPONSE 8583C VALUES CORRESPONDING TO A GIVEN SET OF THESE 8584C GROUP-ID VARIABLES, WE COMPUTE A USER-SPECIFED 8585C STATISTIC (THE DEFAULT IS THE MEAN). THE VALUE 8586C OF THE STATISTIC IS THEN COMPARED TO SOME 8587C USER-SPECIFIED LEVELS (THESE ARE DEFINED IN THE 8588C YLEVEL VARIABLE). A RECTANGLE IS DRAWN AND THE 8589C ATTRIBUTES (PRIMARILY FILL COLOR) ARE BASED ON 8590C THE VALUE OF THE STATISTIC RELATIVE TO YLEVEL. 8591C 8592C THIS PLOT IS USEFUL FOR VISUALLY IDENTIFYING 8593C AREAS WITH "HIGH" AND "LOW" VALUES OF THE 8594C STATISTIC ACROSS GROUPS. 8595C WRITTEN BY--ALAN HECKERT 8596C STATISTICAL ENGINEERING DIVISION 8597C INFORMATION TECHNOLOGY LABORATORY 8598C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 8599C GAITHERSBURG, MD 20899-8980 8600C PHONE--301-975-2889 8601C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 8602C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 8603C LANGUAGE--ANSI FORTRAN (1977) 8604C VERSION NUMBER--2009/9 8605C ORIGINAL VERSION--SEPTEMBER 2009. 8606C UPDATED --DECEMBER 2009. SUPPORT FOR "UNCERTAINTY" OPTION 8607C FOR BINOMIAL PROBABILITIES 8608C UPDATED --JANUARY 2010. SUPPORT FOR UNCERTAINTY INTERVALS 8609C FOR BINOMIAL RATIO 8610C UPDATED --JANUARY 2010. OPTION TO LEAVE AXIS VARIABLES 8611C UNCODED 8612C UPDATED --JUNE 2010. SUPPORT FOR "SORTED" OPTION FOR 8613C THE TWO GROUP-ID VARIABLE CASE 8614C 8615C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 8616C 8617 CHARACTER*4 ICASCT 8618 CHARACTER*60 ICTNAM 8619 CHARACTER*4 ICTAMV 8620 CHARACTER*4 IQUASE 8621 CHARACTER*4 ITPLDI 8622 CHARACTER*4 ITPLUN 8623 CHARACTER*4 ITPLCD 8624 CHARACTER*4 ITPLSO 8625 CHARACTER*4 ITPLSR 8626 CHARACTER*4 ITPLSC 8627 CHARACTER*4 ITPLRM 8628 CHARACTER*4 ITPLCM 8629 CHARACTER*4 IBUGG3 8630 CHARACTER*4 ISUBRO 8631 CHARACTER*4 IERROR 8632C 8633 CHARACTER*4 IWRITE 8634 CHARACTER*4 ISUBN1 8635 CHARACTER*4 ISUBN2 8636 CHARACTER*4 ISTEPN 8637C 8638C--------------------------------------------------------------------- 8639C 8640 DIMENSION Y1(*) 8641 DIMENSION Y2(*) 8642 DIMENSION Y3(*) 8643 DIMENSION YLEVEL(*) 8644 DIMENSION TAG1(*) 8645 DIMENSION TAG2(*) 8646 DIMENSION TAG3(*) 8647 DIMENSION TAG4(*) 8648C 8649 DIMENSION XIDTEM(*) 8650 DIMENSION XIDTE2(*) 8651 DIMENSION XIDTE3(*) 8652 DIMENSION XIDTE4(*) 8653C 8654 DIMENSION TEMP1(*) 8655 DIMENSION TEMP2(*) 8656 DIMENSION TEMP3(*) 8657 DIMENSION TEMP4(*) 8658 DIMENSION TEMP5(*) 8659 DIMENSION TEMP6(*) 8660 DIMENSION TEMP7(*) 8661 DIMENSION TEMP8(*) 8662 DIMENSION TEMP9(*) 8663 DIMENSION TMP10(*) 8664 DIMENSION TMP11(*) 8665C 8666 DIMENSION ITEMP1(*) 8667 DIMENSION ITEMP2(*) 8668 DIMENSION ITEMP3(*) 8669 DIMENSION ITEMP4(*) 8670 DIMENSION ITEMP5(*) 8671 DIMENSION ITEMP6(*) 8672C 8673 DOUBLE PRECISION DTEMP1(*) 8674 DOUBLE PRECISION DTEMP2(*) 8675 DOUBLE PRECISION DTEMP3(*) 8676C 8677 DIMENSION Y(*) 8678 DIMENSION X(*) 8679 DIMENSION D(*) 8680 DIMENSION DCOLOR(*) 8681C 8682 DIMENSION XACLOW(*) 8683 DIMENSION XACUPP(*) 8684C 8685C-----COMMON---------------------------------------------------------- 8686C 8687 INCLUDE 'DPCOP2.INC' 8688C 8689C-----START POINT----------------------------------------------------- 8690C 8691 ISUBN1='DPTA' 8692 ISUBN2='P2 ' 8693 IWRITE='OFF' 8694 IERROR='NO' 8695C 8696C ******************************************** 8697C ** STEP 1-- ** 8698C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 8699C ******************************************** 8700C 8701C 8702C CHECK THE INPUT ARGUMENTS FOR ERRORS 8703C 8704 IF(N.LT.2)THEN 8705 WRITE(ICOUT,999) 8706 999 FORMAT(1X) 8707 CALL DPWRST('XXX','BUG ') 8708 WRITE(ICOUT,31) 8709 31 FORMAT('***** ERROR IN TABULATION PLOT--') 8710 CALL DPWRST('XXX','BUG ') 8711 WRITE(ICOUT,32) 8712 32 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.') 8713 CALL DPWRST('XXX','BUG ') 8714 WRITE(ICOUT,34)N 8715 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) 8716 CALL DPWRST('XXX','BUG ') 8717 WRITE(ICOUT,999) 8718 CALL DPWRST('XXX','BUG ') 8719 IERROR='YES' 8720 GOTO9000 8721 ENDIF 8722C 8723 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAP2')THEN 8724 WRITE(ICOUT,70) 8725 70 FORMAT('AT THE BEGINNING OF DPTAP2--') 8726 CALL DPWRST('XXX','BUG ') 8727 WRITE(ICOUT,71)ICASCT,N,NUMV2,NCRTV,NLEVEL,ISTANR 8728 71 FORMAT('ICASCT,N,NUMV2,NCRTV,NLEVEL,ISTANR = ',A4,2X,5I8) 8729 CALL DPWRST('XXX','BUG ') 8730 WRITE(ICOUT,74)ICTNAM 8731 74 FORMAT('ICTNAM = ',A60) 8732 CALL DPWRST('XXX','BUG ') 8733 DO72I=1,N 8734 WRITE(ICOUT,73)I,Y1(I),Y2(I),TAG1(I),TAG2(I),TAG3(I), 8735 1 TAG4(I) 8736 73 FORMAT('I,Y(I),Y2(I),TAG1-6(I) = ',I8,9F10.3) 8737 CALL DPWRST('XXX','BUG ') 8738 72 CONTINUE 8739 DO82I=1,NLEVEL 8740 WRITE(ICOUT,83)I,YLEVEL(I) 8741 83 FORMAT('I,YLEVEL(I) = ',I8,G15.7) 8742 CALL DPWRST('XXX','BUG ') 8743 82 CONTINUE 8744 ENDIF 8745C 8746 CALL DISTIN(YLEVEL,NLEVEL,IWRITE,TEMP1,NTEMP,IBUGG3,IERROR) 8747 DO110I=1,NTEMP 8748 YLEVEL(I)=TEMP1(I) 8749 110 CONTINUE 8750 NLEVEL=NTEMP 8751 CALL SORT(YLEVEL,NLEVEL,YLEVEL) 8752C 8753C ****************************************************** 8754C ** STEP 1-- ** 8755C ** DETERMINE THE NUMBER OF DISTINCT VALUES ** 8756C ** FOR THE GROUP VARIABLES (TAG1, TAG2) ** 8757C ** IF ALL VALUES ARE DISTINCT, THEN THIS ** 8758C ** IMPLIES WE HAVE THE NO REPLICATION CASE ** 8759C ** WHICH IS AN ERROR CONDITION FOR A PLOT. ** 8760C ****************************************************** 8761C 8762 ISTEPN='1' 8763 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TAP2') 8764 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8765C 8766 IF(ITPLCD.EQ.'ON')THEN 8767 CALL CODE(TAG1,N,IWRITE,TEMP1,TEMP2,MAXOBV,IBUGG3,IERROR) 8768 DO910I=1,N 8769 TAG1(I)=TEMP1(I) 8770 910 CONTINUE 8771 ENDIF 8772 CALL DISTIN(TAG1,N,IWRITE,XIDTEM,NUMSE1,IBUGG3,IERROR) 8773 CALL SORT(XIDTEM,NUMSE1,XIDTEM) 8774C 8775 IF(NCRTV.GE.2)THEN 8776 IF(ITPLCD.EQ.'ON')THEN 8777 CALL CODE(TAG2,N,IWRITE,TEMP1,TEMP2,MAXOBV,IBUGG3,IERROR) 8778 DO920I=1,N 8779 TAG2(I)=TEMP1(I) 8780 920 CONTINUE 8781 ENDIF 8782 CALL DISTIN(TAG2,N,IWRITE,XIDTE2,NUMSE2,IBUGG3,IERROR) 8783 CALL SORT(XIDTE2,NUMSE2,XIDTE2) 8784 ENDIF 8785C 8786 IF(NCRTV.GE.3)THEN 8787 IF(ITPLCD.EQ.'ON')THEN 8788 CALL CODE(TAG3,N,IWRITE,TEMP1,TEMP2,MAXOBV,IBUGG3,IERROR) 8789 DO930I=1,N 8790 TAG3(I)=TEMP1(I) 8791 930 CONTINUE 8792 ENDIF 8793 CALL DISTIN(TAG3,N,IWRITE,XIDTE3,NUMSE3,IBUGG3,IERROR) 8794 CALL SORT(XIDTE3,NUMSE3,XIDTE3) 8795 ELSE 8796 NUMSE3=0 8797 ENDIF 8798C 8799 IF(NCRTV.GE.4)THEN 8800 IF(ITPLCD.EQ.'ON')THEN 8801 CALL CODE(TAG4,N,IWRITE,TEMP1,TEMP2,MAXOBV,IBUGG3,IERROR) 8802 DO940I=1,N 8803 TAG4(I)=TEMP1(I) 8804 940 CONTINUE 8805 ENDIF 8806 CALL DISTIN(TAG4,N,IWRITE,XIDTE4,NUMSE4,IBUGG3,IERROR) 8807 CALL SORT(XIDTE4,NUMSE4,XIDTE4) 8808 ELSE 8809 NUMSE4=0 8810 ENDIF 8811C 8812 IF(NUMSE1.LT.1 .OR. NUMSE1.GT.N)THEN 8813 WRITE(ICOUT,999) 8814 CALL DPWRST('XXX','BUG ') 8815 WRITE(ICOUT,31) 8816 CALL DPWRST('XXX','BUG ') 8817 ITEMP=1 8818 WRITE(ICOUT,111)ITEMP,NUMSE1 8819 111 FORMAT(' THE NUMBER OF SETS FOR THE GROUP ',I1, 8820 1 ' VARIABLE, ',I8,',') 8821 CALL DPWRST('XXX','BUG ') 8822 WRITE(ICOUT,113) 8823 113 FORMAT(' IS EITHER LESS THAN ONE OR GREATER THAN THE ', 8824 1 'NUMBER') 8825 CALL DPWRST('XXX','BUG ') 8826 WRITE(ICOUT,115)N 8827 115 FORMAT(' OF OBSERVATIONS, ',I8,'.') 8828 CALL DPWRST('XXX','BUG ') 8829 IERROR='YES' 8830 GOTO9000 8831 ENDIF 8832C 8833 IF(NCRTV.GE.2 .AND. (NUMSE2.LT.1 .OR. NUMSE2.GT.N))THEN 8834 WRITE(ICOUT,999) 8835 CALL DPWRST('XXX','BUG ') 8836 WRITE(ICOUT,31) 8837 CALL DPWRST('XXX','BUG ') 8838 ITEMP=2 8839 WRITE(ICOUT,111)ITEMP,NUMSE2 8840 CALL DPWRST('XXX','BUG ') 8841 WRITE(ICOUT,113) 8842 CALL DPWRST('XXX','BUG ') 8843 WRITE(ICOUT,115)N 8844 CALL DPWRST('XXX','BUG ') 8845 IERROR='YES' 8846 GOTO9000 8847 ENDIF 8848C 8849 IF(NCRTV.GE.3 .AND. (NUMSE3.LT.1 .OR. NUMSE3.GT.N))THEN 8850 WRITE(ICOUT,999) 8851 CALL DPWRST('XXX','BUG ') 8852 WRITE(ICOUT,31) 8853 CALL DPWRST('XXX','BUG ') 8854 ITEMP=3 8855 WRITE(ICOUT,111)ITEMP,NUMSE3 8856 CALL DPWRST('XXX','BUG ') 8857 WRITE(ICOUT,113) 8858 CALL DPWRST('XXX','BUG ') 8859 WRITE(ICOUT,115)N 8860 CALL DPWRST('XXX','BUG ') 8861 IERROR='YES' 8862 GOTO9000 8863 ENDIF 8864C 8865 IF(NCRTV.GE.4 .AND. (NUMSE4.LT.1 .OR. NUMSE4.GT.N))THEN 8866 WRITE(ICOUT,999) 8867 CALL DPWRST('XXX','BUG ') 8868 WRITE(ICOUT,31) 8869 CALL DPWRST('XXX','BUG ') 8870 ITEMP=4 8871 WRITE(ICOUT,111)ITEMP,NUMSE4 8872 CALL DPWRST('XXX','BUG ') 8873 WRITE(ICOUT,113) 8874 CALL DPWRST('XXX','BUG ') 8875 WRITE(ICOUT,115)N 8876 CALL DPWRST('XXX','BUG ') 8877 IERROR='YES' 8878 GOTO9000 8879 ENDIF 8880C 8881 AN=REAL(N) 8882 ANUMS1=REAL(NUMSE1) 8883 ANUMS2=REAL(NUMSE2) 8884 ANUMS3=REAL(NUMSE3) 8885 ANUMS4=REAL(NUMSE4) 8886C 8887C FOR THE BINOMIAL PROPORTION, MEAN CONFIDENCE LIMIT, AND 8888C MEDIAN CONFIDENCE LIMIT, INSTEAD OF A SINGLE SHADED RECTANGLE, 8889C DEFINE "ITPLNI" INTERVALS THAT WILL BE SHADED FROM LOWEST 8890C CONFIDENCE VALUE TO HIGHEST CONFIDENCE VALUE. 8891C 8892 IFLAGU=0 8893 IF((ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR. 8894 1 ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT') .AND. 8895 1 ITPLUN.EQ.'ON')THEN 8896 IFLAGU=1 8897 ENDIF 8898C 8899C *********************************************** 8900C ** STEP 5-- ** 8901C ** COMPUTE THE VARIOUS CROSS-TAB STATISTICS ** 8902C *********************************************** 8903C 8904 ISTEPN='5.1' 8905 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TAP2') 8906 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8907C 8908 IWRITE='OFF' 8909C 8910 IF(NCRTV.EQ.1)THEN 8911 CALL DPTAP0(Y1,Y2,Y3,TAG1,N, 8912 1 NUMV2,ICASCT,ISTANR, 8913 1 XIDTEM, 8914 1 NUMSE1, 8915 1 TEMP1,TEMP2,TMP11,TEMP3,TEMP4,TEMP5, 8916 1 ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 8917 1 DTEMP1,DTEMP2,DTEMP3, 8918 1 ISEED,ALPHA, 8919 1 ICTAMV,PCTAMV,PSTAMV,IQUASE, 8920 1 TEMP6,TEMP7,XACLOW,XACUPP,N2, 8921 1 ISUBRO,IBUGG3,IERROR) 8922C 8923CCCCC NOW GENERATE THE PLOT COORDINATES. DEFINE A RECTANGLE 8924CCCCC FOR EACH POINT. 8925CCCCC 8926C 8927 XINC=0.5 - PTPLXI 8928 YINC=0.5 - PTPLYI 8929 ICNT=0 8930 ICNT2=0 8931C 8932 IF(IFLAGU.EQ.1)THEN 8933 DO2000I=1,N2 8934 STAT=TEMP6(I) 8935 STATMN=XACLOW(I) 8936 STATMX=XACUPP(I) 8937 IF(ITPLDI.EQ.'X')THEN 8938 XVAL=TEMP7(I) 8939 YVAL=1.0 8940 ELSE 8941 YVAL=TEMP7(I) 8942 XVAL=1.0 8943 ENDIF 8944C 8945 XCOOR1=XVAL - XINC 8946 XCOOR2=XVAL + XINC 8947 YCOOR1=YVAL - YINC 8948 YCOOR2=YVAL + YINC 8949C 8950C DIVIDE RECTANGLE INTO "ITPLNI" VERTICAL INCREMENTS AND 8951C COMPUTE LEVEL-COLOR INDEPENDENTLY FOR EACH OF THESE 8952C MINI-RECTANGLES. 8953C 8954 STATIN=(STATMX - STATMN)/REAL(ITPLNI) 8955 STATZ=STATMN - STATIN 8956 AINC=(YCOOR2 - YCOOR1)/REAL(ITPLNI) 8957 YCZ2=YCOOR1 8958C 8959 DO2009IROW=1,ITPLNI 8960C 8961 YCZ1=YCZ2 8962 YCZ2=YCZ1 + AINC 8963C 8964 STATZ=STATZ + STATIN 8965 IF(STATZ.LT.YLEVEL(1))THEN 8966 ILEVEL=1 8967 ELSEIF(STATZ.GE.YLEVEL(NLEVEL))THEN 8968 ILEVEL=NLEVEL+1 8969 ELSE 8970 DO2005J=2,NLEVEL 8971 IF(STATZ.GE.YLEVEL(J-1) .AND. STATZ.LT.YLEVEL(J))THEN 8972 ILEVEL=J 8973 ENDIF 8974 2005 CONTINUE 8975 ENDIF 8976C 8977 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAP2')THEN 8978 WRITE(ICOUT,2006)I,IROW,STAT,STATZ,STATMN,STATMX,STATIN 8979 2006 FORMAT('I,IROW,STAT,STATZ,STATMN,STATMX,STATIN = ', 8980 1 2I8,5G15.7) 8981 CALL DPWRST('XXX','BUG ') 8982 WRITE(ICOUT,2007)XCOOR1,XCOOR2,YCOOR1,YCOOR2,YCZ1,YCZ2 8983 2007 FORMAT('XCOOR1,XCOOR2,YCOOR1,YCOOR2,YCZ1,YCZ2 = ', 8984 1 6G15.7) 8985 CALL DPWRST('XXX','BUG ') 8986 WRITE(ICOUT,2008)IROW,ILEVEL 8987 2008 FORMAT('IROW,ILEVEL = ',2I8) 8988 CALL DPWRST('XXX','BUG ') 8989 ENDIF 8990C 8991 ICNT2=ICNT2+1 8992 ICNT=ICNT+1 8993 X(ICNT)=XCOOR1 8994 Y(ICNT)=YCZ1 8995 D(ICNT)=REAL(ICNT2) 8996 DCOLOR(ICNT)=REAL(ILEVEL) 8997C 8998 ICNT=ICNT+1 8999 X(ICNT)=XCOOR2 9000 Y(ICNT)=YCZ1 9001 D(ICNT)=REAL(ICNT2) 9002 DCOLOR(ICNT)=REAL(ILEVEL) 9003C 9004 ICNT=ICNT+1 9005 X(ICNT)=XCOOR2 9006 Y(ICNT)=YCZ2 9007 D(ICNT)=REAL(ICNT2) 9008 DCOLOR(ICNT)=REAL(ILEVEL) 9009C 9010 ICNT=ICNT+1 9011 X(ICNT)=XCOOR1 9012 Y(ICNT)=YCZ2 9013 D(ICNT)=REAL(ICNT2) 9014 DCOLOR(ICNT)=REAL(ILEVEL) 9015C 9016 ICNT=ICNT+1 9017 X(ICNT)=XCOOR1 9018 Y(ICNT)=YCZ1 9019 D(ICNT)=REAL(ICNT2) 9020 DCOLOR(ICNT)=REAL(ILEVEL) 9021C 9022 2009 CONTINUE 9023C 9024 2000 CONTINUE 9025 ELSE 9026 DO1001I=1,N2 9027 STAT=TEMP6(I) 9028 IF(ITPLDI.EQ.'X')THEN 9029 XVAL=TEMP7(I) 9030 YVAL=1.0 9031 ELSE 9032 YVAL=TEMP7(I) 9033 XVAL=1.0 9034 ENDIF 9035 XCOOR1=XVAL - XINC 9036 XCOOR2=XVAL + XINC 9037 YCOOR1=YVAL - YINC 9038 YCOOR2=YVAL + YINC 9039 IF(STAT.LT.YLEVEL(1))THEN 9040 ILEVEL=1 9041 ELSEIF(STAT.GE.YLEVEL(NLEVEL))THEN 9042 ILEVEL=NLEVEL+1 9043 ELSE 9044 DO1005J=2,NLEVEL 9045 IF(STAT.GE.YLEVEL(J-1) .AND. STAT.LT.YLEVEL(J))THEN 9046 ILEVEL=J 9047 ENDIF 9048 1005 CONTINUE 9049 ENDIF 9050C 9051 ICNT2=ICNT2+1 9052 ICNT=ICNT+1 9053 X(ICNT)=XCOOR1 9054 Y(ICNT)=YCOOR1 9055 D(ICNT)=REAL(ICNT2) 9056 DCOLOR(ICNT)=REAL(ILEVEL) 9057C 9058 ICNT=ICNT+1 9059 X(ICNT)=XCOOR2 9060 Y(ICNT)=YCOOR1 9061 D(ICNT)=REAL(ICNT2) 9062 DCOLOR(ICNT)=REAL(ILEVEL) 9063C 9064 ICNT=ICNT+1 9065 X(ICNT)=XCOOR2 9066 Y(ICNT)=YCOOR2 9067 D(ICNT)=REAL(ICNT2) 9068 DCOLOR(ICNT)=REAL(ILEVEL) 9069C 9070 ICNT=ICNT+1 9071 X(ICNT)=XCOOR1 9072 Y(ICNT)=YCOOR2 9073 D(ICNT)=REAL(ICNT2) 9074 DCOLOR(ICNT)=REAL(ILEVEL) 9075C 9076 ICNT=ICNT+1 9077 X(ICNT)=XCOOR1 9078 Y(ICNT)=YCOOR1 9079 D(ICNT)=REAL(ICNT2) 9080 DCOLOR(ICNT)=REAL(ILEVEL) 9081C 9082 1001 CONTINUE 9083 ENDIF 9084C 9085 NPLOTP=ICNT 9086 NPLOTV=2 9087C 9088C WHEN THERE ARE EXACTLY TWO CROSS-TABULATION VARIABLES, THEN 9089C SUPPORT A "SORT" OPTION. FIRST NEED TO OBTAIN ROW AND COLUMN 9090C VALUES FOR THE STATISTICS. FROM THESE, CREATE "INDEX" VARIABLES. 9091C 9092 ELSEIF(NCRTV.EQ.2)THEN 9093C 9094C SORT THE ROWS. FOR THIS APPLICATION, NEED A RANK. SINCE THE 9095C RANK WILL SERVE AS AN ARRAY INDEX, NEED TO CHECK FOR TIES. 9096C 9097 IF(ITPLSO.EQ.'ON' .OR. ITPLSO.EQ.'ROW')THEN 9098 CALL DPTAP0(Y1,Y2,Y3,TAG1,N, 9099 1 NUMV2,ICASCT,ISTANR, 9100 1 XIDTEM, 9101 1 NUMSE1, 9102 1 TEMP1,TEMP2,TMP11,TEMP3,TEMP4,TEMP5, 9103 1 ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 9104 1 DTEMP1,DTEMP2,DTEMP3, 9105 1 ISEED,ALPHA, 9106 1 ICTAMV,PCTAMV,PSTAMV,IQUASE, 9107 1 TEMP9,TEMP7,XACLOW,XACUPP,N2, 9108 1 ISUBRO,IBUGG3,IERROR) 9109 CALL RANKI(TEMP9,NUMSE1,IWRITE,XIDTE3,TEMP7,ITEMP1,MAXOBV, 9110 1 IBUGG3,IERROR) 9111 CALL DISTIN(XIDTE3,NUMSE1,IWRITE,TEMP7,NTEMP,IBUGG3,IERROR) 9112 IF(NTEMP.NE.NUMSE1)THEN 9113 DO1006II=1,NUMSE1 9114 XIDTE3(II)=XIDTEM(II) 9115 1006 CONTINUE 9116 ENDIF 9117 IF(ITPLSR.EQ.'DESC')THEN 9118 DO4006I=1,N 9119 IRANK=INT(XIDTE3(I)+0.1) 9120 IRANK2=NUMSE1 - IRANK + 1 9121 XIDTE3(I)=REAL(IRANK2) 9122 4006 CONTINUE 9123 ENDIF 9124 ELSE 9125 IF(ITPLSR.EQ.'DESC')THEN 9126 DO4007II=1,NUMSE1 9127 IVAL=NUMSE1 - II + 1 9128 XIDTE3(II)=XIDTEM(IVAL) 9129 4007 CONTINUE 9130 ELSE 9131 DO1007II=1,NUMSE1 9132 XIDTE3(II)=XIDTEM(II) 9133 1007 CONTINUE 9134 ENDIF 9135 ENDIF 9136C 9137C SORT THE COLUMNS 9138C 9139 IF(ITPLSO.EQ.'ON' .OR. ITPLSO.EQ.'COLU')THEN 9140 CALL DPTAP0(Y1,Y2,Y3,TAG2,N, 9141 1 NUMV2,ICASCT,ISTANR, 9142 1 XIDTE2, 9143 1 NUMSE2, 9144 1 TEMP1,TEMP2,TMP11,TEMP3,TEMP4,TEMP5, 9145 1 ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 9146 1 DTEMP1,DTEMP2,DTEMP3, 9147 1 ISEED,ALPHA, 9148 1 ICTAMV,PCTAMV,PSTAMV,IQUASE, 9149 1 TMP10,TEMP7,XACLOW,XACUPP,N2, 9150 1 ISUBRO,IBUGG3,IERROR) 9151 CALL RANKI(TMP10,NUMSE2,IWRITE,XIDTE4,TEMP7,ITEMP1,MAXOBV, 9152 1 IBUGG3,IERROR) 9153 CALL DISTIN(XIDTE4,NUMSE2,IWRITE,TEMP7,NTEMP,IBUGG3,IERROR) 9154 IF(NTEMP.NE.NUMSE2)THEN 9155 DO1008II=1,NUMSE2 9156 XIDTE4(II)=XIDTE2(II) 9157 1008 CONTINUE 9158 ENDIF 9159 IF(ITPLSC.EQ.'DESC')THEN 9160 DO4008I=1,N 9161 IRANK=INT(XIDTE4(I)+0.1) 9162 IRANK2=NUMSE2 - IRANK + 1 9163 XIDTE4(I)=REAL(IRANK2) 9164 4008 CONTINUE 9165 ENDIF 9166 ELSE 9167 IF(ITPLSR.EQ.'DESC')THEN 9168 DO5008II=1,NUMSE2 9169 IVAL=NUMSE2 - II + 1 9170 XIDTE4(II)=XIDTE2(IVAL) 9171 5008 CONTINUE 9172 ELSE 9173 DO1009II=1,NUMSE2 9174 XIDTE4(II)=XIDTE2(II) 9175 1009 CONTINUE 9176 ENDIF 9177 ENDIF 9178C 9179 CALL DPTAP3(Y1,Y2,Y3,TAG1,TAG2,N, 9180 1 NUMV2,ICASCT,ISTANR, 9181 1 XIDTEM,XIDTE2, 9182 1 NUMSE1,NUMSE2, 9183 1 TEMP1,TEMP2,TMP11,TEMP3,TEMP4,TEMP5, 9184 1 TMP10,TMP11,ITPLRM,ITPLCM, 9185 1 ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 9186 1 DTEMP1,DTEMP2,DTEMP3, 9187 1 ISEED,ALPHA, 9188 1 ICTAMV,PCTAMV,PSTAMV,IQUASE, 9189 1 TEMP6,TEMP7,TEMP8,XACLOW,XACUPP,N2, 9190 1 ISUBRO,IBUGG3,IERROR) 9191C 9192CCCCC NOW GENERATE THE PLOT COORDINATES. DEFINE A RECTANGLE 9193CCCCC FOR EACH POINT. 9194C 9195 ICNT=0 9196 ICNT2=0 9197 XINC=0.5 - PTPLXI 9198 YINC=0.5 - PTPLYI 9199C 9200 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAP2')THEN 9201 WRITE(ICOUT,1011)N2 9202 1011 FORMAT('DPTAP2: AFTER CALL DPTAP3--N2 = ',I8) 9203 CALL DPWRST('XXX','BUG ') 9204 WRITE(ICOUT,1012)XINC,YINC 9205 1012 FORMAT('XINC,YINC = ',2G15.7) 9206 CALL DPWRST('XXX','BUG ') 9207 ENDIF 9208C 9209 IF(IFLAGU.EQ.1)THEN 9210 DO2010I=1,N2 9211 STAT=TEMP6(I) 9212 STATMN=XACLOW(I) 9213 STATMX=XACUPP(I) 9214CCCCC JUNE 2010: MODIFIED TO ACCOUNT FOR SORTING 9215CCCCC IF(ITPLDI.EQ.'X')THEN 9216CCCCC XVAL=TEMP7(I) 9217CCCCC YVAL=TEMP8(I) 9218CCCCC ELSE 9219CCCCC YVAL=TEMP7(I) 9220CCCCC XVAL=TEMP8(I) 9221CCCCC ENDIF 9222 IF(ITPLSO.EQ.'OFF' .AND. ITPLCD.EQ.'OFF')THEN 9223 IF(ITPLDI.EQ.'X')THEN 9224 XVAL=TEMP7(I) 9225 YVAL=TEMP8(I) 9226 ELSE 9227 XVAL=TEMP8(I) 9228 YVAL=TEMP7(I) 9229 ENDIF 9230 ELSE 9231 IF(ITPLDI.EQ.'X')THEN 9232 INDEXX=INT(TEMP7(I)+0.1) 9233 INDEXY=INT(TEMP8(I)+0.1) 9234 XVAL=XIDTE3(INDEXX) 9235 YVAL=XIDTE4(INDEXY) 9236 ELSE 9237 INDEXX=INT(TEMP8(I)+0.1) 9238 INDEXY=INT(TEMP7(I)+0.1) 9239 XVAL=XIDTE4(INDEXX) 9240 YVAL=XIDTE3(INDEXY) 9241 ENDIF 9242 ENDIF 9243C 9244 XCOOR1=XVAL - XINC 9245 XCOOR2=XVAL + XINC 9246 YCOOR1=YVAL - YINC 9247 YCOOR2=YVAL + YINC 9248C 9249C DIVIDE RECTANGLE INTO "ITPLNI" VERTICAL INCREMENTS AND 9250C COMPUTE LEVEL-COLOR INDEPENDENTLY FOR EACH OF THESE 9251C MINI-RECTANGLES. 9252C 9253 STATIN=(STATMX - STATMN)/REAL(ITPLNI) 9254 STATZ=STATMN - STATIN 9255 AINC=(YCOOR2 - YCOOR1)/REAL(ITPLNI) 9256 YCZ2=YCOOR1 9257C 9258 DO2019IROW=1,ITPLNI 9259C 9260 YCZ1=YCZ2 9261 YCZ2=YCZ1 + AINC 9262C 9263 STATZ=STATZ + STATIN 9264 IF(STATZ.LT.YLEVEL(1))THEN 9265 ILEVEL=1 9266 ELSEIF(STATZ.GE.YLEVEL(NLEVEL))THEN 9267 ILEVEL=NLEVEL+1 9268 ELSE 9269 DO2015J=2,NLEVEL 9270 IF(STATZ.GE.YLEVEL(J-1) .AND. STATZ.LT.YLEVEL(J))THEN 9271 ILEVEL=J 9272 ENDIF 9273 2015 CONTINUE 9274 ENDIF 9275C 9276 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAP2')THEN 9277 WRITE(ICOUT,2016)I,IROW,STAT,STATZ,STATMN,STATMX,STATIN 9278 2016 FORMAT('I,IROW,STAT,STATZ,STATMN,STATMX,STATIN = ', 9279 1 2I8,5G15.7) 9280 CALL DPWRST('XXX','BUG ') 9281 WRITE(ICOUT,2017)XCOOR1,XCOOR2,YCOOR1,YCOOR2,YCZ1,YCZ2 9282 2017 FORMAT('XCOOR1,XCOOR2,YCOOR1,YCOOR2,YCZ1,YCZ2 = ', 9283 1 6G15.7) 9284 CALL DPWRST('XXX','BUG ') 9285 WRITE(ICOUT,2018)IROW,ILEVEL 9286 2018 FORMAT('IROW,ILEVEL = ',2I8) 9287 CALL DPWRST('XXX','BUG ') 9288 ENDIF 9289C 9290 ICNT2=ICNT2+1 9291 ICNT=ICNT+1 9292 X(ICNT)=XCOOR1 9293 Y(ICNT)=YCZ1 9294 D(ICNT)=REAL(ICNT2) 9295 DCOLOR(ICNT)=REAL(ILEVEL) 9296C 9297 ICNT=ICNT+1 9298 X(ICNT)=XCOOR2 9299 Y(ICNT)=YCZ1 9300 D(ICNT)=REAL(ICNT2) 9301 DCOLOR(ICNT)=REAL(ILEVEL) 9302C 9303 ICNT=ICNT+1 9304 X(ICNT)=XCOOR2 9305 Y(ICNT)=YCZ2 9306 D(ICNT)=REAL(ICNT2) 9307 DCOLOR(ICNT)=REAL(ILEVEL) 9308C 9309 ICNT=ICNT+1 9310 X(ICNT)=XCOOR1 9311 Y(ICNT)=YCZ2 9312 D(ICNT)=REAL(ICNT2) 9313 DCOLOR(ICNT)=REAL(ILEVEL) 9314C 9315 ICNT=ICNT+1 9316 X(ICNT)=XCOOR1 9317 Y(ICNT)=YCZ1 9318 D(ICNT)=REAL(ICNT2) 9319 DCOLOR(ICNT)=REAL(ILEVEL) 9320C 9321 2019 CONTINUE 9322C 9323 2010 CONTINUE 9324 ELSE 9325 DO1010I=1,N2 9326 STAT=TEMP6(I) 9327CCCCC JUNE 2010: ACCOUNT FOR SORTING 9328CCCCC IF(ITPLDI.EQ.'X')THEN 9329CCCCC XVAL=TEMP7(I) 9330CCCCC YVAL=TEMP8(I) 9331CCCCC ELSE 9332CCCCC YVAL=TEMP7(I) 9333CCCCC XVAL=TEMP8(I) 9334CCCCC ENDIF 9335 IF(ITPLSO.EQ.'OFF' .AND. ITPLCD.EQ.'OFF')THEN 9336 IF(ITPLDI.EQ.'X')THEN 9337 XVAL=TEMP7(I) 9338 YVAL=TEMP8(I) 9339 ELSE 9340 XVAL=TEMP8(I) 9341 YVAL=TEMP7(I) 9342 ENDIF 9343 ELSE 9344 IF(ITPLDI.EQ.'X')THEN 9345 INDEXX=INT(TEMP7(I)+0.1) 9346 INDEXY=INT(TEMP8(I)+0.1) 9347 XVAL=XIDTE3(INDEXX) 9348 YVAL=XIDTE4(INDEXY) 9349 ELSE 9350 INDEXX=INT(TEMP8(I)+0.1) 9351 INDEXY=INT(TEMP7(I)+0.1) 9352 XVAL=XIDTE4(INDEXX) 9353 YVAL=XIDTE3(INDEXY) 9354 ENDIF 9355 ENDIF 9356C 9357C 9358 XCOOR1=XVAL - XINC 9359 XCOOR2=XVAL + XINC 9360 YCOOR1=YVAL - YINC 9361 YCOOR2=YVAL + YINC 9362 IF(STAT.LT.YLEVEL(1))THEN 9363 ILEVEL=1 9364 ELSEIF(STAT.GE.YLEVEL(NLEVEL))THEN 9365 ILEVEL=NLEVEL+1 9366 ELSE 9367 DO1015J=2,NLEVEL 9368 IF(STAT.GE.YLEVEL(J-1) .AND. STAT.LT.YLEVEL(J))THEN 9369 ILEVEL=J 9370 ENDIF 9371 1015 CONTINUE 9372 ENDIF 9373C 9374 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAP2')THEN 9375 WRITE(ICOUT,1016)I,STAT,YVAL,XVAL 9376 1016 FORMAT('I,STAT,YVAL,XVAL = ',I8,3G15.7) 9377 CALL DPWRST('XXX','BUG ') 9378 WRITE(ICOUT,1017)XCOOR1,XCOOR2,YCOOR1,YCOOR2 9379 1017 FORMAT('XCOOR1,XCOOR2,YCOOR1,YCOOR2 = ',4G15.7) 9380 CALL DPWRST('XXX','BUG ') 9381 WRITE(ICOUT,1018)ILEVEL 9382 1018 FORMAT('ILEVEL = ',I8) 9383 CALL DPWRST('XXX','BUG ') 9384 ENDIF 9385C 9386 ICNT2=ICNT2+1 9387 ICNT=ICNT+1 9388 X(ICNT)=XCOOR1 9389 Y(ICNT)=YCOOR1 9390 D(ICNT)=REAL(ICNT2) 9391 DCOLOR(ICNT)=REAL(ILEVEL) 9392C 9393 ICNT=ICNT+1 9394 X(ICNT)=XCOOR2 9395 Y(ICNT)=YCOOR1 9396 D(ICNT)=REAL(ICNT2) 9397 DCOLOR(ICNT)=REAL(ILEVEL) 9398C 9399 ICNT=ICNT+1 9400 X(ICNT)=XCOOR2 9401 Y(ICNT)=YCOOR2 9402 D(ICNT)=REAL(ICNT2) 9403 DCOLOR(ICNT)=REAL(ILEVEL) 9404C 9405 ICNT=ICNT+1 9406 X(ICNT)=XCOOR1 9407 Y(ICNT)=YCOOR2 9408 D(ICNT)=REAL(ICNT2) 9409 DCOLOR(ICNT)=REAL(ILEVEL) 9410C 9411 ICNT=ICNT+1 9412 X(ICNT)=XCOOR1 9413 Y(ICNT)=YCOOR1 9414 D(ICNT)=REAL(ICNT2) 9415 DCOLOR(ICNT)=REAL(ILEVEL) 9416C 9417 1010 CONTINUE 9418 ENDIF 9419C 9420 NPLOTP=ICNT 9421 NPLOTV=2 9422C 9423 ELSEIF(NCRTV.EQ.3)THEN 9424 CALL DPTAP4(Y1,Y2,Y3,TAG1,TAG2,TAG3,N, 9425 1 NUMV2,ICASCT,ISTANR, 9426 1 XIDTEM,XIDTE2,XIDTE3, 9427 1 NUMSE1,NUMSE2,NUMSE3, 9428 1 TEMP1,TEMP2,TMP11,TEMP3,TEMP4,TEMP5, 9429 1 ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 9430 1 DTEMP1,DTEMP2,DTEMP3, 9431 1 ISEED,ALPHA, 9432 1 ICTAMV,PCTAMV,PSTAMV,IQUASE, 9433 1 TEMP6,TEMP7,TEMP8,TEMP9,XACLOW,XACUPP,N2, 9434 1 ISUBRO,IBUGG3,IERROR) 9435C 9436CCCCC NOW GENERATE THE PLOT COORDINATES. DEFINE A RECTANGLE 9437CCCCC FOR EACH POINT. 9438C 9439 ICNT=0 9440 ICNT2=0 9441 XINC=0.5 - PTPLXI 9442 YINC=0.5 - PTPLYI 9443 YINC2=2.0*YINC/REAL(NUMSE3) 9444C 9445 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAP2')THEN 9446 WRITE(ICOUT,1021)N2 9447 1021 FORMAT('DPTAP2: AFTER CALL DPTAP2--N2 = ',I8) 9448 CALL DPWRST('XXX','BUG ') 9449 WRITE(ICOUT,1022)XINC,YINC,YINC2 9450 1022 FORMAT('XINC,YINC,YINC2 = ',3G15.7) 9451 CALL DPWRST('XXX','BUG ') 9452 ENDIF 9453C 9454 IF(IFLAGU.EQ.1)THEN 9455 DO2020I=1,N2 9456 STAT=TEMP6(I) 9457 STATMN=XACLOW(I) 9458 STATMX=XACUPP(I) 9459 IF(ITPLDI.EQ.'X')THEN 9460CCCCC XVAL=TEMP7(I) 9461CCCCC YVAL=TEMP8(I) 9462CCCCC XVAL2=TEMP9(I) 9463 XVAL=TEMP8(I) 9464 YVAL=ANUMS1*(TEMP9(I) - 1.0) + TEMP7(I) 9465 XCOOR1=XVAL - XINC 9466 XCOOR2=XVAL + XINC 9467 YCOOR1=YVAL - YINC 9468 YCOOR2=YVAL + YINC 9469 ELSE 9470CCCCC YVAL=TEMP7(I) 9471CCCCC XVAL=TEMP8(I) 9472CCCCC YVAL2=TEMP9(I) 9473 XCOOR1=XVAL - XINC 9474 XCOOR2=XVAL + XINC 9475 YCOOR1=YVAL - YINC 9476 YCOOR2=YVAL + YINC 9477 ENDIF 9478C 9479C DIVIDE RECTANGLE INTO "ITPLNI" VERTICAL INCREMENTS AND 9480C COMPUTE LEVEL-COLOR INDEPENDENTLY FOR EACH OF THESE 9481C MINI-RECTANGLES. 9482C 9483 STATIN=(STATMX - STATMN)/REAL(ITPLNI) 9484 STATZ=STATMN - STATIN 9485 AINC=(YCOOR2 - YCOOR1)/REAL(ITPLNI) 9486 YCZ2=YCOOR1 9487C 9488 DO2029IROW=1,ITPLNI 9489C 9490 YCZ1=YCZ2 9491 YCZ2=YCZ1 + AINC 9492C 9493 STATZ=STATZ + STATIN 9494 IF(STATZ.LT.YLEVEL(1))THEN 9495 ILEVEL=1 9496 ELSEIF(STATZ.GE.YLEVEL(NLEVEL))THEN 9497 ILEVEL=NLEVEL+1 9498 ELSE 9499 DO2025J=2,NLEVEL 9500 IF(STATZ.GE.YLEVEL(J-1) .AND. STATZ.LT.YLEVEL(J))THEN 9501 ILEVEL=J 9502 ENDIF 9503 2025 CONTINUE 9504 ENDIF 9505C 9506 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAP2')THEN 9507 WRITE(ICOUT,2026)I,IROW,STAT,STATZ,STATMN,STATMX,STATIN 9508 2026 FORMAT('I,IROW,STAT,STATZ,STATMN,STATMX,STATIN = ', 9509 1 2I8,5G15.7) 9510 CALL DPWRST('XXX','BUG ') 9511 WRITE(ICOUT,2027)XCOOR1,XCOOR2,YCOOR1,YCOOR2,YCZ1,YCZ2 9512 2027 FORMAT('XCOOR1,XCOOR2,YCOOR1,YCOOR2,YCZ1,YCZ2 = ', 9513 1 6G15.7) 9514 CALL DPWRST('XXX','BUG ') 9515 WRITE(ICOUT,2028)IROW,ILEVEL 9516 2028 FORMAT('IROW,ILEVEL = ',2I8) 9517 CALL DPWRST('XXX','BUG ') 9518 ENDIF 9519C 9520 ICNT2=ICNT2+1 9521 ICNT=ICNT+1 9522 X(ICNT)=XCOOR1 9523 Y(ICNT)=YCZ1 9524 D(ICNT)=REAL(ICNT2) 9525 DCOLOR(ICNT)=REAL(ILEVEL) 9526C 9527 ICNT=ICNT+1 9528 X(ICNT)=XCOOR2 9529 Y(ICNT)=YCZ1 9530 D(ICNT)=REAL(ICNT2) 9531 DCOLOR(ICNT)=REAL(ILEVEL) 9532C 9533 ICNT=ICNT+1 9534 X(ICNT)=XCOOR2 9535 Y(ICNT)=YCZ2 9536 D(ICNT)=REAL(ICNT2) 9537 DCOLOR(ICNT)=REAL(ILEVEL) 9538C 9539 ICNT=ICNT+1 9540 X(ICNT)=XCOOR1 9541 Y(ICNT)=YCZ2 9542 D(ICNT)=REAL(ICNT2) 9543 DCOLOR(ICNT)=REAL(ILEVEL) 9544C 9545 ICNT=ICNT+1 9546 X(ICNT)=XCOOR1 9547 Y(ICNT)=YCZ1 9548 D(ICNT)=REAL(ICNT2) 9549 DCOLOR(ICNT)=REAL(ILEVEL) 9550C 9551 2029 CONTINUE 9552C 9553 2020 CONTINUE 9554 ELSE 9555 DO1020I=1,N2 9556 STAT=TEMP6(I) 9557 IF(ITPLDI.EQ.'X')THEN 9558CCCCC XVAL=TEMP7(I) 9559CCCCC YVAL=TEMP8(I) 9560CCCCC XVAL2=TEMP9(I) 9561 XVAL=TEMP8(I) 9562 YVAL=ANUMS1*(TEMP9(I) - 1.0) + TEMP7(I) 9563 XCOOR1=XVAL - XINC 9564 XCOOR2=XVAL + XINC 9565 YCOOR1=YVAL - YINC 9566 YCOOR2=YVAL + YINC 9567 ELSE 9568CCCCC YVAL=TEMP7(I) 9569CCCCC XVAL=TEMP8(I) 9570CCCCC YVAL2=TEMP9(I) 9571 XVAL=ANUMS1*(TEMP9(I) - 1.0) + TEMP7(I) 9572 YVAL=TEMP8(I) 9573 XCOOR1=XVAL - XINC 9574 XCOOR2=XVAL + XINC 9575 YCOOR1=YVAL - YINC 9576 YCOOR2=YVAL + YINC 9577 ENDIF 9578 IF(STAT.LT.YLEVEL(1))THEN 9579 ILEVEL=1 9580 ELSEIF(STAT.GE.YLEVEL(NLEVEL))THEN 9581 ILEVEL=NLEVEL+1 9582 ELSE 9583 DO1025J=2,NLEVEL 9584 IF(STAT.GE.YLEVEL(J-1) .AND. STAT.LT.YLEVEL(J))THEN 9585 ILEVEL=J 9586 ENDIF 9587 1025 CONTINUE 9588 ENDIF 9589C 9590 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAP2')THEN 9591 WRITE(ICOUT,1026)I,STAT,YVAL,XVAL,YVAL2 9592 1026 FORMAT('I,STAT,YVAL,XVAL,YVAL2 = ',I8,4G15.7) 9593 CALL DPWRST('XXX','BUG ') 9594 WRITE(ICOUT,1027)XCOOR1,XCOOR2,YCOOR1,YCOOR2 9595 1027 FORMAT('XCOOR1,XCOOR2,YCOOR1,YCOOR2 = ',4G15.7) 9596 CALL DPWRST('XXX','BUG ') 9597 WRITE(ICOUT,1028)ILEVEL 9598 1028 FORMAT('ILEVEL = ',I8) 9599 CALL DPWRST('XXX','BUG ') 9600 ENDIF 9601C 9602 ICNT2=ICNT2+1 9603 ICNT=ICNT+1 9604 X(ICNT)=XCOOR1 9605 Y(ICNT)=YCOOR1 9606 D(ICNT)=REAL(ICNT2) 9607 DCOLOR(ICNT)=REAL(ILEVEL) 9608C 9609 ICNT=ICNT+1 9610 X(ICNT)=XCOOR2 9611 Y(ICNT)=YCOOR1 9612 D(ICNT)=REAL(ICNT2) 9613 DCOLOR(ICNT)=REAL(ILEVEL) 9614C 9615 ICNT=ICNT+1 9616 X(ICNT)=XCOOR2 9617 Y(ICNT)=YCOOR2 9618 D(ICNT)=REAL(ICNT2) 9619 DCOLOR(ICNT)=REAL(ILEVEL) 9620C 9621 ICNT=ICNT+1 9622 X(ICNT)=XCOOR1 9623 Y(ICNT)=YCOOR2 9624 D(ICNT)=REAL(ICNT2) 9625 DCOLOR(ICNT)=REAL(ILEVEL) 9626C 9627 ICNT=ICNT+1 9628 X(ICNT)=XCOOR1 9629 Y(ICNT)=YCOOR1 9630 D(ICNT)=REAL(ICNT2) 9631 DCOLOR(ICNT)=REAL(ILEVEL) 9632C 9633 1020 CONTINUE 9634 ENDIF 9635C 9636 NPLOTP=ICNT 9637 NPLOTV=2 9638C 9639 ELSEIF(NCRTV.EQ.4)THEN 9640 CALL DPTAP5(Y1,Y2,Y3,TAG1,TAG2,TAG3,TAG4,N, 9641 1 NUMV2,ICASCT,ISTANR, 9642 1 XIDTEM,XIDTE2,XIDTE3,XIDTE4, 9643 1 NUMSE1,NUMSE2,NUMSE3,NUMSE4, 9644 1 TEMP1,TEMP2,TMP11,TEMP3,TEMP4,TEMP5, 9645 1 ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 9646 1 DTEMP1,DTEMP2,DTEMP3, 9647 1 ISEED,ALPHA, 9648 1 ICTAMV,PCTAMV,PSTAMV,IQUASE, 9649 1 TEMP6,TEMP7,TEMP8,TEMP9,TMP10,XACLOW,XACUPP,N2, 9650 1 ISUBRO,IBUGG3,IERROR) 9651C 9652CCCCC NOW GENERATE THE PLOT COORDINATES. DEFINE A RECTANGLE 9653CCCCC FOR EACH POINT. 9654C 9655 ICNT=0 9656 ICNT2=0 9657 XINC=0.5 - PTPLXI 9658 YINC=0.5 - PTPLYI 9659 YINC2=2.0*YINC/REAL(NUMSE3) 9660 XINC2=2.0*XINC/REAL(NUMSE4) 9661C 9662 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAP2')THEN 9663 WRITE(ICOUT,1031)N2 9664 1031 FORMAT('DPTAP2: AFTER CALL DPTAP5--N2 = ',I8) 9665 CALL DPWRST('XXX','BUG ') 9666 WRITE(ICOUT,1032)XINC,YINC,XINC2,YINC2 9667 1032 FORMAT('XINC,YINC,XINC2,YINC2 = ',4G15.7) 9668 CALL DPWRST('XXX','BUG ') 9669 ENDIF 9670C 9671 IF(IFLAGU.EQ.1)THEN 9672 DO2030I=1,N2 9673 STAT=TEMP6(I) 9674 STATMN=XACLOW(I) 9675 STATMX=XACUPP(I) 9676 IF(ITPLDI.EQ.'X')THEN 9677CCCCC XVAL=TEMP7(I) 9678CCCCC YVAL=TEMP8(I) 9679CCCCC XVAL2=TEMP9(I) 9680CCCCC YVAL2=TMP10(I) 9681 XVAL=ANUMS2*(TMP10(I) - 1.0) + TEMP8(I) 9682 YVAL=ANUMS1*(TEMP9(I) - 1.0) + TEMP7(I) 9683 ELSE 9684CCCCC YVAL=TEMP7(I) 9685CCCCC XVAL=TEMP8(I) 9686CCCCC YVAL2=TEMP9(I) 9687CCCCC XVAL2=TMP10(I) 9688 XVAL=ANUMS1*(TEMP9(I) - 1.0) + TEMP7(I) 9689 YVAL=ANUMS2*(TMP10(I) - 1.0) + TEMP8(I) 9690 ENDIF 9691 XCOOR1=XVAL - XINC 9692 XCOOR2=XVAL + XINC 9693 YCOOR1=YVAL - YINC 9694 YCOOR2=YVAL + YINC 9695C 9696C DIVIDE RECTANGLE INTO "ITPLNI" VERTICAL INCREMENTS AND 9697C COMPUTE LEVEL-COLOR INDEPENDENTLY FOR EACH OF THESE 9698C MINI-RECTANGLES. 9699C 9700 STATIN=(STATMX - STATMN)/REAL(ITPLNI) 9701 STATZ=STATMN - STATIN 9702 AINC=(YCOOR2 - YCOOR1)/REAL(ITPLNI) 9703 YCZ2=YCOOR1 9704C 9705 DO2039IROW=1,ITPLNI 9706C 9707 YCZ1=YCZ2 9708 YCZ2=YCZ1 + AINC 9709C 9710 STATZ=STATZ + STATIN 9711 IF(STATZ.LT.YLEVEL(1))THEN 9712 ILEVEL=1 9713 ELSEIF(STATZ.GE.YLEVEL(NLEVEL))THEN 9714 ILEVEL=NLEVEL+1 9715 ELSE 9716 DO2035J=2,NLEVEL 9717 IF(STATZ.GE.YLEVEL(J-1) .AND. STATZ.LT.YLEVEL(J))THEN 9718 ILEVEL=J 9719 ENDIF 9720 2035 CONTINUE 9721 ENDIF 9722C 9723 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAP2')THEN 9724 WRITE(ICOUT,2036)I,IROW,STAT,STATZ,STATMN,STATMX,STATIN 9725 2036 FORMAT('I,IROW,STAT,STATZ,STATMN,STATMX,STATIN = ', 9726 1 2I8,5G15.7) 9727 CALL DPWRST('XXX','BUG ') 9728 WRITE(ICOUT,2037)XCOOR1,XCOOR2,YCOOR1,YCOOR2,YCZ1,YCZ2 9729 2037 FORMAT('XCOOR1,XCOOR2,YCOOR1,YCOOR2,YCZ1,YCZ2 = ', 9730 1 6G15.7) 9731 CALL DPWRST('XXX','BUG ') 9732 WRITE(ICOUT,2038)IROW,ILEVEL 9733 2038 FORMAT('IROW,ILEVEL = ',2I8) 9734 CALL DPWRST('XXX','BUG ') 9735 ENDIF 9736C 9737 ICNT2=ICNT2+1 9738 ICNT=ICNT+1 9739 X(ICNT)=XCOOR1 9740 Y(ICNT)=YCZ1 9741 D(ICNT)=REAL(ICNT2) 9742 DCOLOR(ICNT)=REAL(ILEVEL) 9743C 9744 ICNT=ICNT+1 9745 X(ICNT)=XCOOR2 9746 Y(ICNT)=YCZ1 9747 D(ICNT)=REAL(ICNT2) 9748 DCOLOR(ICNT)=REAL(ILEVEL) 9749C 9750 ICNT=ICNT+1 9751 X(ICNT)=XCOOR2 9752 Y(ICNT)=YCZ2 9753 D(ICNT)=REAL(ICNT2) 9754 DCOLOR(ICNT)=REAL(ILEVEL) 9755C 9756 ICNT=ICNT+1 9757 X(ICNT)=XCOOR1 9758 Y(ICNT)=YCZ2 9759 D(ICNT)=REAL(ICNT2) 9760 DCOLOR(ICNT)=REAL(ILEVEL) 9761C 9762 ICNT=ICNT+1 9763 X(ICNT)=XCOOR1 9764 Y(ICNT)=YCZ1 9765 D(ICNT)=REAL(ICNT2) 9766 DCOLOR(ICNT)=REAL(ILEVEL) 9767C 9768 2039 CONTINUE 9769C 9770 2030 CONTINUE 9771 ELSE 9772 DO1030I=1,N2 9773 STAT=TEMP6(I) 9774 IF(ITPLDI.EQ.'X')THEN 9775CCCCC XVAL=TEMP7(I) 9776CCCCC YVAL=TEMP8(I) 9777CCCCC XVAL2=TEMP9(I) 9778CCCCC YVAL2=TMP10(I) 9779 XVAL=ANUMS2*(TMP10(I) - 1.0) + TEMP8(I) 9780 YVAL=ANUMS1*(TEMP9(I) - 1.0) + TEMP7(I) 9781 ELSE 9782CCCCC YVAL=TEMP7(I) 9783CCCCC XVAL=TEMP8(I) 9784CCCCC YVAL2=TEMP9(I) 9785CCCCC XVAL2=TMP10(I) 9786 XVAL=ANUMS1*(TEMP9(I) - 1.0) + TEMP7(I) 9787 YVAL=ANUMS2*(TMP10(I) - 1.0) + TEMP8(I) 9788 ENDIF 9789CCCCC XCOOR1=XVAL - XINC) + (XVAL2 - 1.0)*XINC2 9790 XCOOR1=XVAL - XINC 9791 XCOOR2=XVAL + XINC 9792CCCCCC YCOOR1=(YVAL - YINC) + (YVAL2 - 1.0)*YINC2 9793 YCOOR1=YVAL - YINC 9794 YCOOR2=YVAL + YINC 9795 IF(STAT.LT.YLEVEL(1))THEN 9796 ILEVEL=1 9797 ELSEIF(STAT.GE.YLEVEL(NLEVEL))THEN 9798 ILEVEL=NLEVEL+1 9799 ELSE 9800 DO1035J=2,NLEVEL 9801 IF(STAT.GE.YLEVEL(J-1) .AND. STAT.LT.YLEVEL(J))THEN 9802 ILEVEL=J 9803 ENDIF 9804 1035 CONTINUE 9805 ENDIF 9806C 9807 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAP2')THEN 9808 WRITE(ICOUT,1036)I,STAT,YVAL,XVAL,YVAL2,XVAL2 9809 1036 FORMAT('I,STAT,YVAL,XVAL,YVAL2,XVAL2 = ',I8,5G15.7) 9810 CALL DPWRST('XXX','BUG ') 9811 WRITE(ICOUT,1037)XCOOR1,XCOOR2,YCOOR1,YCOOR2 9812 1037 FORMAT('XCOOR1,XCOOR2,YCOOR1,YCOOR2 = ',4G15.7) 9813 CALL DPWRST('XXX','BUG ') 9814 WRITE(ICOUT,1038)ILEVEL 9815 1038 FORMAT('ILEVEL = ',I8) 9816 CALL DPWRST('XXX','BUG ') 9817 ENDIF 9818C 9819 ICNT2=ICNT2+1 9820 ICNT=ICNT+1 9821 X(ICNT)=XCOOR1 9822 Y(ICNT)=YCOOR1 9823 D(ICNT)=REAL(ICNT2) 9824 DCOLOR(ICNT)=REAL(ILEVEL) 9825C 9826 ICNT=ICNT+1 9827 X(ICNT)=XCOOR2 9828 Y(ICNT)=YCOOR1 9829 D(ICNT)=REAL(ICNT2) 9830 DCOLOR(ICNT)=REAL(ILEVEL) 9831C 9832 ICNT=ICNT+1 9833 X(ICNT)=XCOOR2 9834 Y(ICNT)=YCOOR2 9835 D(ICNT)=REAL(ICNT2) 9836 DCOLOR(ICNT)=REAL(ILEVEL) 9837C 9838 ICNT=ICNT+1 9839 X(ICNT)=XCOOR1 9840 Y(ICNT)=YCOOR2 9841 D(ICNT)=REAL(ICNT2) 9842 DCOLOR(ICNT)=REAL(ILEVEL) 9843C 9844 ICNT=ICNT+1 9845 X(ICNT)=XCOOR1 9846 Y(ICNT)=YCOOR1 9847 D(ICNT)=REAL(ICNT2) 9848 DCOLOR(ICNT)=REAL(ILEVEL) 9849C 9850 1030 CONTINUE 9851 ENDIF 9852C 9853 NPLOTP=ICNT 9854 NPLOTV=2 9855C 9856 ENDIF 9857C ***************** 9858C ** STEP 90-- ** 9859C ** EXIT ** 9860C ***************** 9861C 9862 9000 CONTINUE 9863 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TAP2')THEN 9864 WRITE(ICOUT,999) 9865 CALL DPWRST('XXX','BUG ') 9866 WRITE(ICOUT,9011) 9867 9011 FORMAT('***** AT THE END OF DPTAP2--') 9868 CALL DPWRST('XXX','BUG ') 9869 WRITE(ICOUT,9012)ICASCT,N,NPLOTP,NPLOTV,IERROR 9870 9012 FORMAT('ICASCT,N,NPLOTP,NPLOTV,IERROR = ',A4,3I8,2X,A4) 9871 CALL DPWRST('XXX','BUG ') 9872 DO9035I=1,NPLOTP 9873 WRITE(ICOUT,9036)I,Y(I),X(I),D(I),DCOLOR(I) 9874 9036 FORMAT('I,Y(I),X(I),D(I),DCOLOR(I) = ',I8,4G15.7) 9875 CALL DPWRST('XXX','BUG ') 9876 9035 CONTINUE 9877 ENDIF 9878C 9879 RETURN 9880 END 9881 SUBROUTINE DPTAP3(Y,Z,Z2,TAG1,TAG2,N, 9882 1 NUMV2,ICASCT,ISTANR, 9883 1 XIDTEM,XIDTE2, 9884 1 NUMSE1,NUMSE2, 9885 1 TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3, 9886 1 YCMNMX,YRMNMX,ITPLCM,ITPLRM, 9887 1 ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 9888 1 DTEMP1,DTEMP2,DTEMP3, 9889 1 ISEED,ALPHA, 9890 1 ICTAMV,PCTAMV,PSTAMV,IQUASE, 9891 1 Y2,X2,D2,XACLOW,XACUPP,N2, 9892 1 ISUBRO,IBUGG3,IERROR) 9893C 9894C PURPOSE--GENERATE A TWO-WAY TABULATION PLOT. 9895C WRITTEN BY--ALAN HECKERT 9896C STATISTICAL ENGINEERING DIVISION 9897C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 9898C GAITHERSBURG, MD 20899-8980 9899C PHONE--301-975-2899 9900C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 9901C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 9902C LANGUAGE--ANSI FORTRAN (1977) 9903C VERSION NUMBER--2009/9 9904C ORIGINAL VERSION--SEPTEMBER 2009. 9905C UPDATED --DECEMBER 2009. UNCERTAINTY OPTION FOR 9906C BINOMIAL PROBABILITY, MEAN AND 9907C MEDIAN CONFIDENCE INTERVAL 9908C UPDATED --JANUARY 2010. SUPPORT FOR UNCERTAINTY INTERVALS 9909C FOR BINOMIAL RATIO 9910C UPDATED --AUGUST 2010. FOR EACH VALUE, DETERMINE IF 9911C IT A ROW COLUMN MINIMUM OR 9912C MAXIMUM VALUE FOR THE STATISTIC 9913C 9914C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 9915C 9916 CHARACTER*4 ICASCT 9917 CHARACTER*4 ICTAMV 9918 CHARACTER*4 IQUASE 9919 CHARACTER*4 ITPLCM 9920 CHARACTER*4 ITPLRM 9921 CHARACTER*4 IBUGG3 9922 CHARACTER*4 ISUBRO 9923 CHARACTER*4 IERROR 9924C 9925 CHARACTER*4 IWRITE 9926 CHARACTER*4 ISUBN1 9927 CHARACTER*4 ISUBN2 9928 CHARACTER*4 ISTEPN 9929C 9930C--------------------------------------------------------------------- 9931C 9932 DIMENSION Y(*) 9933 DIMENSION Z(*) 9934 DIMENSION Z2(*) 9935 DIMENSION XIDTEM(*) 9936 DIMENSION XIDTE2(*) 9937 DIMENSION Y2(*) 9938 DIMENSION X2(*) 9939 DIMENSION D2(*) 9940 DIMENSION XACLOW(*) 9941 DIMENSION XACUPP(*) 9942C 9943 DIMENSION TAG1(*) 9944 DIMENSION TAG2(*) 9945 DIMENSION TEMP(*) 9946 DIMENSION TEMPZ(*) 9947 DIMENSION TEMPZ2(*) 9948 DIMENSION XTEMP1(*) 9949 DIMENSION XTEMP2(*) 9950 DIMENSION XTEMP3(*) 9951 DIMENSION YCMNMX(*) 9952 DIMENSION YRMNMX(*) 9953C 9954 INTEGER ITEMP1(*) 9955 INTEGER ITEMP2(*) 9956 INTEGER ITEMP3(*) 9957 INTEGER ITEMP4(*) 9958 INTEGER ITEMP5(*) 9959 INTEGER ITEMP6(*) 9960C 9961 DOUBLE PRECISION DTEMP1(*) 9962 DOUBLE PRECISION DTEMP2(*) 9963 DOUBLE PRECISION DTEMP3(*) 9964C 9965C-----COMMON---------------------------------------------------------- 9966C 9967 INCLUDE 'DPCOP2.INC' 9968C 9969C-----START POINT----------------------------------------------------- 9970C 9971 ISUBN1='DPTA' 9972 ISUBN2='P3 ' 9973C 9974 I2=0 9975C 9976 AN=INT(N+0.01) 9977C 9978C *********************************************** 9979C ** STEP 5-- ** 9980C ** COMPUTE THE VARIOUS CROSS-TAB STATISTICS ** 9981C *********************************************** 9982C 9983 ISTEPN='5.1' 9984 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TAP3') 9985 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9986C 9987 IWRITE='OFF' 9988C 9989C FOR EACH ROW/COLUMN COMBINATION, DETERMINE IF IT IS A 9990C ROW OR COLUMN MINIMUM OR MAXIMUM. 9991 J=0 9992 NRESP=NUMV2-2 9993 DO1110ISET1=1,NUMSE1 9994 DO1120ISET2=1,NUMSE2 9995C 9996 K=0 9997 DO1130I=1,N 9998 IF(XIDTEM(ISET1).EQ.TAG1(I).AND.XIDTE2(ISET2).EQ.TAG2(I)) 9999 1 GOTO1131 10000 GOTO1130 10001 1131 CONTINUE 10002C 10003 K=K+1 10004 TEMP(K)=0.0 10005 TEMPZ(K)=0.0 10006 TEMPZ2(K)=0.0 10007 IF(ISTANR.GE.1)TEMP(K)=Y(I) 10008 IF(ISTANR.GE.2)TEMPZ(K)=Z(I) 10009 IF(ISTANR.GE.3)TEMPZ2(K)=Z2(I) 10010 1130 CONTINUE 10011 NTEMP=K 10012C 10013 NTRIAL=0 10014 ALOWLM=0.0 10015 AUPPLM=0.0 10016 IF(NTEMP.EQ.0)THEN 10017 IF(ICTAMV.EQ.'ZERO')THEN 10018 STAT=0.0 10019 IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR. 10020 1 ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN 10021 NTRIAL=0 10022 ALOWLM=0.0 10023 AUPPLM=0.0 10024 ENDIF 10025 ELSEIF(ICTAMV.EQ.'MV ')THEN 10026 STAT=PCTAMV 10027 IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR. 10028 1 ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN 10029 NTRIAL=0 10030 ALOWLM=PCTAMV 10031 AUPPLM=PCTAMV 10032 ENDIF 10033 ELSE 10034 GOTO1120 10035 ENDIF 10036 ELSE 10037 CALL CMPSTA( 10038 1 TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3, 10039 1 MAXNXT,NTEMP,NTEMP,NTEMP, 10040 1 NRESP,ICASCT, 10041 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 10042 1 DTEMP1,DTEMP2,DTEMP3, 10043CCCCC1 IQUAME,IQUASE,PSTAMV, 10044 1 STAT, 10045 1 ISUBRO,IBUGG3,IERROR) 10046 IF(IERROR.EQ.'YES')GOTO9000 10047 IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN 10048 PTEMP=STAT 10049 NTRIAL=NTEMP 10050 IF(ICASCT.EQ.'BRAT')NTRIAL=ITEMP1(1) 10051 IF(STAT.EQ.PSTAMV)THEN 10052 ALOWLM=PSTAMV 10053 AUPPLM=PSTAMV 10054 ELSE 10055 ALPHAT=ALPHA 10056 IF(ALPHAT.LE.0.5)ALPHAT=1.0 - ALPHA 10057 CALL DPAGCO(PTEMP,NTRAIL,ALPHAT,IWRITE, 10058 1 ALOWLM,AUPPLM,IBUGG3,IERROR) 10059 ENDIF 10060 ELSEIF(ICASCT.EQ.'MECL')THEN 10061 XMEAN=STAT 10062 NTRIAL=NTEMP 10063 IF(STAT.EQ.PSTAMV)THEN 10064 ALOWLM=PSTAMV 10065 AUPPLM=PSTAMV 10066 ELSE 10067 CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGG3,IERROR) 10068 ALPHAT=ALPHA 10069 CALL DPMECL(XMEAN,XSD,NTEMP,ALPHAT,IWRITE, 10070 1 ALOWLM,AUPPLM,IBUGG3,IERROR) 10071 ENDIF 10072 ELSEIF(ICASCT.EQ.'MDCL')THEN 10073 XMED=STAT 10074 NTRIAL=NTEMP 10075 IF(STAT.EQ.PSTAMV)THEN 10076 ALOWLM=PSTAMV 10077 AUPPLM=PSTAMV 10078 ELSE 10079 XQ=0.5 10080 CALL QUANSE(XQ,TEMP,NTEMP,IWRITE,XTEMP1,MAXNXT,IQUASE, 10081 1 QUASE,IBUGG3,IERROR) 10082 ALPHAT=ALPHA 10083 CALL DPMECL(XMED,QUASE,NTEMP,ALPHAT,IWRITE, 10084 1 ALOWLM,AUPPLM,IBUGG3,IERROR) 10085 ENDIF 10086 ENDIF 10087 ENDIF 10088C 10089 J=J+1 10090 Y2(J)=STAT 10091 X2(J)=XIDTEM(ISET1) 10092 D2(J)=XIDTE2(ISET2) 10093 AMNMAX=0.0 10094 IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR. 10095 1 ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN 10096 IF(AUPPLM.GT.STATMX)STATMX=AUPPLM 10097 IF(ALOWLM.LT.STATMN)STATMN=ALOWLM 10098 XACLOW(J)=ALOWLM 10099 XACUPP(J)=AUPPLM 10100 ENDIF 10101C 10102 1120 CONTINUE 10103 1110 CONTINUE 10104 N2=J 10105C 10106C DETERMINE THE COLUMN MINIMUM AND MAXIMUM POINTS 10107C 10108 IF(ITPLCM.EQ.'OFF' .AND. ITPLRM.EQ.'OFF')GOTO9000 10109C 10110 DO3101I=1,N 10111 YCMNMX(I)=0.0 10112 YRMNMX(I)=0.0 10113 3101 CONTINUE 10114C 10115 DO3110ISET2=1,NUMSE2 10116 ACOLMN=CPUMIN 10117 ACOLMX=CPUMIN 10118C 10119C DETERMINE COLUMN MIN/MAX 10120C 10121 DO3120I=1,N 10122 IF(XIDTE2(ISET2).EQ.D2(I))THEN 10123 IF(Y2(I).NE.PSTAMV .AND. Y2(I).NE.CPUMIN)THEN 10124 IF(ACOLMN.EQ.CPUMIN)THEN 10125 ACOLMN=Y2(I) 10126 ACOLMX=Y2(I) 10127 ELSE 10128 IF(Y2(I).LE.ACOLMN)ACOLMN=Y2(I) 10129 IF(Y2(I).GE.ACOLMX)ACOLMX=Y2(I) 10130 ENDIF 10131 ENDIF 10132 ENDIF 10133 3120 CONTINUE 10134C 10135C NOW SET YCMNMX TO: 10136C 10137C 0 = NEITHER MIN NOR MAX 10138C 1 = EQUAL TO COLUMN MINIMUM 10139C 2 = EQUAL TO COLUMN MAXIMUM 10140C 10141 DO3130I=1,N 10142 IF(XIDTE2(ISET2).EQ.D2(I))THEN 10143 YCMNMX(I)=0.0 10144 IF(Y2(I).EQ.ACOLMN)YCMNMX(I)=1.0 10145 IF(Y2(I).EQ.ACOLMX)YCMNMX(I)=2.0 10146 ENDIF 10147 3130 CONTINUE 10148C 10149 3110 CONTINUE 10150C 10151C DETERMINE THE ROW MINIMUM AND MAXIMUM POINTS 10152C 10153 DO4110ISET1=1,NUMSE1 10154 AROWMN=CPUMIN 10155 AROWMX=CPUMIN 10156C 10157C DETERMINE ROW MIN/MAX 10158C 10159 DO4120I=1,N 10160 IF(XIDTEM(ISET1).EQ.X2(I))THEN 10161 IF(Y2(I).NE.PSTAMV .AND. Y2(I).NE.CPUMIN)THEN 10162 IF(AROWMN.EQ.CPUMIN)THEN 10163 AROWMN=Y2(I) 10164 AROWMX=Y2(I) 10165 ELSE 10166 IF(Y2(I).LE.AROWMN)AROWMN=Y2(I) 10167 IF(Y2(I).GE.AROWMX)AROWMX=Y2(I) 10168 ENDIF 10169 ENDIF 10170 ENDIF 10171 4120 CONTINUE 10172C 10173C NOW SET YRMNMX TO: 10174C 10175C 0 = NEITHER MIN NOR MAX 10176C 1 = EQUAL TO ROW MINIMUM 10177C 2 = EQUAL TO ROW MAXIMUM 10178C 10179 DO4130I=1,N 10180 IF(XIDTEM(ISET1).EQ.X2(I))THEN 10181 YRMNMX(I)=0.0 10182 IF(Y2(I).EQ.AROWMN)YRMNMX(I)=1.0 10183 IF(Y2(I).EQ.AROWMX)YRMNMX(I)=2.0 10184 ENDIF 10185 4130 CONTINUE 10186C 10187 4110 CONTINUE 10188C ****************** 10189C ** STEP 90-- ** 10190C ** EXIT ** 10191C ****************** 10192C 10193 9000 CONTINUE 10194 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAP3')THEN 10195 WRITE(ICOUT,999) 10196 999 FORMAT(1X) 10197 CALL DPWRST('XXX','BUG ') 10198 WRITE(ICOUT,9011) 10199 9011 FORMAT('***** AT THE END OF DPTAP3--') 10200 CALL DPWRST('XXX','BUG ') 10201 WRITE(ICOUT,9012)ICASCT,N,NUMV2,IERROR 10202 9012 FORMAT('ICASCT,N,NUMV2,IERROR = ',A4,2I8,2X,A4) 10203 CALL DPWRST('XXX','BUG ') 10204 WRITE(ICOUT,9015)NUMSE1,NUMSE2,N2 10205 9015 FORMAT('NUMSE1,NUMSE2,N2 = ',3I8) 10206 CALL DPWRST('XXX','BUG ') 10207 DO9020I=1,N2 10208 WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I),YCMNMX(I),YRMNMX(I) 10209 9021 FORMAT('I,Y2(I),X2(I),D2(I),YCMNMX(I),YRMNMX(I) = ', 10210 1 I8,5G15.7) 10211 CALL DPWRST('XXX','BUG ') 10212 9020 CONTINUE 10213 ENDIF 10214C 10215 RETURN 10216 END 10217 SUBROUTINE DPTAP4(Y,Z,Z2,TAG1,TAG2,TAG3,N, 10218 1 NUMV2,ICASCT,ISTANR, 10219 1 XIDTEM,XIDTE2,XIDTE3, 10220 1 NUMSE1,NUMSE2,NUMSE3, 10221 1 TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3, 10222 1 ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 10223 1 DTEMP1,DTEMP2,DTEMP3, 10224 1 ISEED,ALPHA, 10225 1 ICTAMV,PCTAMV,PSTAMV,IQUASE, 10226 1 Y2,X2,D2,D3,XACLOW,XACUPP,N2, 10227 1 ISUBRO,IBUGG3,IERROR) 10228C 10229C PURPOSE--GENERATE A TWO-WAY TABULATION PLOT. 10230C WRITTEN BY--ALAN HECKERT 10231C STATISTICAL ENGINEERING DIVISION 10232C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10233C GAITHERSBURG, MD 20899-8980 10234C PHONE--301-975-2899 10235C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 10236C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 10237C LANGUAGE--ANSI FORTRAN (1977) 10238C VERSION NUMBER--2009/9 10239C ORIGINAL VERSION--SEPTEMBER 2009. 10240C UPDATED --DECEMBER 2009. UNCERTAINTY OPTION FOR 10241C BINOMIAL PROBABILITY, MEAN AND 10242C MEDIAN CONFIDENCE INTERVAL 10243C UPDATED --JANUARY 2010. SUPPORT FOR UNCERTAINTY INTERVALS 10244C FOR BINOMIAL RATIO 10245C 10246C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10247C 10248 CHARACTER*4 ICASCT 10249 CHARACTER*4 ICTAMV 10250 CHARACTER*4 IQUASE 10251 CHARACTER*4 IBUGG3 10252 CHARACTER*4 ISUBRO 10253 CHARACTER*4 IERROR 10254C 10255 CHARACTER*4 IWRITE 10256 CHARACTER*4 ISUBN1 10257 CHARACTER*4 ISUBN2 10258 CHARACTER*4 ISTEPN 10259C 10260C--------------------------------------------------------------------- 10261C 10262 DIMENSION Y(*) 10263 DIMENSION Z(*) 10264 DIMENSION Z2(*) 10265 DIMENSION XIDTEM(*) 10266 DIMENSION XIDTE2(*) 10267 DIMENSION XIDTE3(*) 10268 DIMENSION Y2(*) 10269 DIMENSION X2(*) 10270 DIMENSION D2(*) 10271 DIMENSION D3(*) 10272C 10273 DIMENSION TAG1(*) 10274 DIMENSION TAG2(*) 10275 DIMENSION TAG3(*) 10276 DIMENSION TEMP(*) 10277 DIMENSION TEMPZ(*) 10278 DIMENSION TEMPZ2(*) 10279 DIMENSION XTEMP1(*) 10280 DIMENSION XTEMP2(*) 10281 DIMENSION XTEMP3(*) 10282C 10283 DIMENSION XACLOW(*) 10284 DIMENSION XACUPP(*) 10285C 10286 INTEGER ITEMP1(*) 10287 INTEGER ITEMP2(*) 10288 INTEGER ITEMP3(*) 10289 INTEGER ITEMP4(*) 10290 INTEGER ITEMP5(*) 10291 INTEGER ITEMP6(*) 10292C 10293 DOUBLE PRECISION DTEMP1(*) 10294 DOUBLE PRECISION DTEMP2(*) 10295 DOUBLE PRECISION DTEMP3(*) 10296C 10297C-----COMMON---------------------------------------------------------- 10298C 10299 INCLUDE 'DPCOP2.INC' 10300C 10301C-----START POINT----------------------------------------------------- 10302C 10303 ISUBN1='DPTA' 10304 ISUBN2='P4 ' 10305C 10306 I2=0 10307C 10308 AN=INT(N+0.01) 10309C 10310C *********************************************** 10311C ** STEP 5-- ** 10312C ** COMPUTE THE VARIOUS CROSS-TAB STATISTICS ** 10313C *********************************************** 10314C 10315 ISTEPN='5.1' 10316 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TAP4') 10317 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10318C 10319 IWRITE='OFF' 10320C 10321 J=0 10322 NRESP=NUMV2-3 10323 DO1110ISET1=1,NUMSE1 10324 DO1120ISET2=1,NUMSE2 10325 DO1130ISET3=1,NUMSE3 10326C 10327 K=0 10328 DO1180I=1,N 10329 IF(XIDTEM(ISET1).EQ.TAG1(I).AND. 10330 1 XIDTE2(ISET2).EQ.TAG2(I).AND. 10331 1 XIDTE3(ISET3).EQ.TAG3(I) 10332 1 )GOTO1181 10333 GOTO1180 10334 1181 CONTINUE 10335C 10336 K=K+1 10337 TEMP(K)=0.0 10338 TEMPZ(K)=0.0 10339 TEMPZ2(K)=0.0 10340 IF(ISTANR.GE.1)TEMP(K)=Y(I) 10341 IF(ISTANR.GE.2)TEMPZ(K)=Z(I) 10342 IF(ISTANR.GE.3)TEMPZ2(K)=Z2(I) 10343 1180 CONTINUE 10344 NTEMP=K 10345C 10346 NTRIAL=0 10347 ALOWLM=0.0 10348 AUPPLM=0.0 10349 IF(NTEMP.EQ.0)THEN 10350 IF(ICTAMV.EQ.'ZERO')THEN 10351 STAT=0.0 10352 IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR. 10353 1 ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN 10354 NTRIAL=0 10355 ALOWLM=0.0 10356 AUPPLM=0.0 10357 ENDIF 10358 ELSEIF(ICTAMV.EQ.'MV ')THEN 10359 STAT=PCTAMV 10360 IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR. 10361 1 ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN 10362 NTRIAL=0 10363 ALOWLM=PCTAMV 10364 AUPPLM=PCTAMV 10365 ENDIF 10366 ELSE 10367 GOTO1130 10368 ENDIF 10369 ELSE 10370 CALL CMPSTA( 10371 1 TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3, 10372 1 MAXNXT,NTEMP,NTEMP,NTEMP, 10373 1 NRESP,ICASCT, 10374 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 10375 1 DTEMP1,DTEMP2,DTEMP3, 10376CCCCC1 IQUAME,IQUASE,PSTAMV, 10377 1 STAT, 10378 1 ISUBRO,IBUGG3,IERROR) 10379 IF(IERROR.EQ.'YES')GOTO9000 10380 IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN 10381 PTEMP=STAT 10382 NTRIAL=NTEMP 10383 IF(ICASCT.EQ.'BRAT')NTRIAL=ITEMP1(1) 10384 IF(STAT.EQ.PSTAMV)THEN 10385 ALOWLM=PSTAMV 10386 AUPPLM=PSTAMV 10387 ELSE 10388 ALPHAT=ALPHA 10389 IF(ALPHAT.LE.0.5)ALPHAT=1.0 - ALPHA 10390 CALL DPAGCO(PTEMP,NTRIAL,ALPHAT,IWRITE, 10391 1 ALOWLM,AUPPLM,IBUGG3,IERROR) 10392 ENDIF 10393 ELSEIF(ICASCT.EQ.'MECL')THEN 10394 XMEAN=STAT 10395 NTRIAL=NTEMP 10396 IF(STAT.EQ.PSTAMV)THEN 10397 ALOWLM=PSTAMV 10398 AUPPLM=PSTAMV 10399 ELSE 10400 CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGG3,IERROR) 10401 ALPHAT=ALPHA 10402 CALL DPMECL(XMEAN,XSD,NTEMP,ALPHAT,IWRITE, 10403 1 ALOWLM,AUPPLM,IBUGG3,IERROR) 10404 ENDIF 10405 ELSEIF(ICASCT.EQ.'MDCL')THEN 10406 XMED=STAT 10407 NTRIAL=NTEMP 10408 IF(STAT.EQ.PSTAMV)THEN 10409 ALOWLM=PSTAMV 10410 AUPPLM=PSTAMV 10411 ELSE 10412 XQ=0.5 10413 CALL QUANSE(XQ,TEMP,NTEMP,IWRITE,XTEMP1,MAXNXT,IQUASE, 10414 1 QUASE,IBUGG3,IERROR) 10415 ALPHAT=ALPHA 10416 CALL DPMECL(XMED,QUASE,NTEMP,ALPHAT,IWRITE, 10417 1 ALOWLM,AUPPLM,IBUGG3,IERROR) 10418 ENDIF 10419 ENDIF 10420 ENDIF 10421C 10422 J=J+1 10423 Y2(J)=STAT 10424 X2(J)=XIDTEM(ISET1) 10425 D2(J)=XIDTE2(ISET2) 10426 D3(J)=XIDTE3(ISET3) 10427 IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR. 10428 1 ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN 10429 IF(AUPPLM.GT.STATMX)STATMX=AUPPLM 10430 IF(ALOWLM.LT.STATMN)STATMN=ALOWLM 10431 XACLOW(J)=ALOWLM 10432 XACUPP(J)=AUPPLM 10433 ENDIF 10434C 10435 1130 CONTINUE 10436 1120 CONTINUE 10437 1110 CONTINUE 10438 N2=J 10439C 10440C ****************** 10441C ** STEP 90-- ** 10442C ** EXIT ** 10443C ****************** 10444C 10445 9000 CONTINUE 10446 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAP4')THEN 10447 WRITE(ICOUT,999) 10448 999 FORMAT(1X) 10449 CALL DPWRST('XXX','BUG ') 10450 WRITE(ICOUT,9011) 10451 9011 FORMAT('***** AT THE END OF DPTAP4--') 10452 CALL DPWRST('XXX','BUG ') 10453 WRITE(ICOUT,9012)ICASCT,N,NUMV2,IERROR 10454 9012 FORMAT('ICASCT,N,NUMV2,IERROR = ',A4,2I8,2X,A4) 10455 CALL DPWRST('XXX','BUG ') 10456 WRITE(ICOUT,9015)NUMSE1,NUMSE2,NUMSE3,N2 10457 9015 FORMAT('NUMSE1,NUMSE2,NUMSE3,N2 = ',4I8) 10458 CALL DPWRST('XXX','BUG ') 10459 DO9020I=1,N2 10460 WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I),D3(I) 10461 9021 FORMAT('I,Y2(I),X2(I),D2(I),D3(I) = ',I8,4G15.7) 10462 CALL DPWRST('XXX','BUG ') 10463 9020 CONTINUE 10464 ENDIF 10465C 10466 RETURN 10467 END 10468 SUBROUTINE DPTAP5(Y,Z,Z2,TAG1,TAG2,TAG3,TAG4,N, 10469 1 NUMV2,ICASCT,ISTANR, 10470 1 XIDTEM,XIDTE2,XIDTE3,XIDTE4, 10471 1 NUMSE1,NUMSE2,NUMSE3,NUMSE4, 10472 1 TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3, 10473 1 ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 10474 1 DTEMP1,DTEMP2,DTEMP3, 10475 1 ISEED,ALPHA, 10476 1 ICTAMV,PCTAMV,PSTAMV,IQUASE, 10477 1 Y2,X2,D2,D3,D4,XACLOW,XACUPP,N2, 10478 1 ISUBRO,IBUGG3,IERROR) 10479C 10480C PURPOSE--GENERATE A TWO-WAY TABULATION PLOT. 10481C WRITTEN BY--ALAN HECKERT 10482C STATISTICAL ENGINEERING DIVISION 10483C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10484C GAITHERSBURG, MD 20899-8980 10485C PHONE--301-975-2899 10486C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 10487C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 10488C LANGUAGE--ANSI FORTRAN (1977) 10489C VERSION NUMBER--2009/9 10490C ORIGINAL VERSION--SEPTEMBER 2009. 10491C UPDATED --DECEMBER 2009. UNCERTAINTY OPTION FOR 10492C BINOMIAL PROBABILITY, MEAN AND 10493C MEDIAN CONFIDENCE INTERVAL 10494C UPDATED --JANUARY 2010. SUPPORT FOR UNCERTAINTY INTERVALS 10495C FOR BINOMIAL RATIO 10496C 10497C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10498C 10499 CHARACTER*4 ICASCT 10500 CHARACTER*4 ICTAMV 10501 CHARACTER*4 IQUASE 10502 CHARACTER*4 IBUGG3 10503 CHARACTER*4 IERROR 10504 CHARACTER*4 ISUBRO 10505C 10506 CHARACTER*4 IWRITE 10507 CHARACTER*4 ISUBN1 10508 CHARACTER*4 ISUBN2 10509 CHARACTER*4 ISTEPN 10510C 10511C--------------------------------------------------------------------- 10512C 10513 DIMENSION Y(*) 10514 DIMENSION Z(*) 10515 DIMENSION Z2(*) 10516 DIMENSION XIDTEM(*) 10517 DIMENSION XIDTE2(*) 10518 DIMENSION XIDTE3(*) 10519 DIMENSION XIDTE4(*) 10520 DIMENSION Y2(*) 10521 DIMENSION X2(*) 10522 DIMENSION D2(*) 10523 DIMENSION D3(*) 10524 DIMENSION D4(*) 10525C 10526 DIMENSION TAG1(*) 10527 DIMENSION TAG2(*) 10528 DIMENSION TAG3(*) 10529 DIMENSION TAG4(*) 10530 DIMENSION TEMP(*) 10531 DIMENSION TEMPZ(*) 10532 DIMENSION TEMPZ2(*) 10533 DIMENSION XTEMP1(*) 10534 DIMENSION XTEMP2(*) 10535 DIMENSION XTEMP3(*) 10536C 10537 DIMENSION XACLOW(*) 10538 DIMENSION XACUPP(*) 10539C 10540 INTEGER ITEMP1(*) 10541 INTEGER ITEMP2(*) 10542 INTEGER ITEMP3(*) 10543 INTEGER ITEMP4(*) 10544 INTEGER ITEMP5(*) 10545 INTEGER ITEMP6(*) 10546C 10547 DOUBLE PRECISION DTEMP1(*) 10548 DOUBLE PRECISION DTEMP2(*) 10549 DOUBLE PRECISION DTEMP3(*) 10550C 10551C-----COMMON---------------------------------------------------------- 10552C 10553 INCLUDE 'DPCOP2.INC' 10554C 10555C-----START POINT----------------------------------------------------- 10556C 10557 ISUBN1='DPTA' 10558 ISUBN2='P5 ' 10559C 10560 I2=0 10561C 10562 AN=INT(N+0.01) 10563C 10564C *********************************************** 10565C ** STEP 5-- ** 10566C ** COMPUTE THE VARIOUS CROSS-TAB STATISTICS ** 10567C *********************************************** 10568C 10569 ISTEPN='5.1' 10570 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TAP5') 10571 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10572C 10573 IWRITE='OFF' 10574C 10575 J=0 10576 NRESP=NUMV2-4 10577 DO1110ISET1=1,NUMSE1 10578 DO1120ISET2=1,NUMSE2 10579 DO1130ISET3=1,NUMSE3 10580 DO1140ISET4=1,NUMSE4 10581C 10582 K=0 10583 DO1180I=1,N 10584 IF(XIDTEM(ISET1).EQ.TAG1(I).AND. 10585 1 XIDTE2(ISET2).EQ.TAG2(I).AND. 10586 1 XIDTE3(ISET3).EQ.TAG3(I).AND. 10587 1 XIDTE4(ISET4).EQ.TAG4(I) 10588 1 )GOTO1181 10589 GOTO1180 10590 1181 CONTINUE 10591C 10592 K=K+1 10593 TEMP(K)=0.0 10594 TEMPZ(K)=0.0 10595 TEMPZ2(K)=0.0 10596 IF(ISTANR.GE.1)TEMP(K)=Y(I) 10597 IF(ISTANR.GE.2)TEMPZ(K)=Z(I) 10598 IF(ISTANR.GE.3)TEMPZ2(K)=Z2(I) 10599 1180 CONTINUE 10600 NTEMP=K 10601C 10602 NTRIAL=0 10603 ALOWLM=0.0 10604 AUPPLM=0.0 10605 IF(NTEMP.EQ.0)THEN 10606 IF(ICTAMV.EQ.'ZERO')THEN 10607 STAT=0.0 10608 IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR. 10609 1 ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN 10610 NTRIAL=0 10611 ALOWLM=0.0 10612 AUPPLM=0.0 10613 ENDIF 10614 ELSEIF(ICTAMV.EQ.'MV ')THEN 10615 STAT=PCTAMV 10616 IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR. 10617 1 ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN 10618 NTRIAL=0 10619 ALOWLM=PCTAMV 10620 AUPPLM=PCTAMV 10621 ENDIF 10622 ELSE 10623 GOTO1140 10624 ENDIF 10625 ELSE 10626 CALL CMPSTA( 10627 1 TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3, 10628 1 MAXNXT,NTEMP,NTEMP,NTEMP, 10629 1 NRESP,ICASCT, 10630 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 10631 1 DTEMP1,DTEMP2,DTEMP3, 10632CCCCC1 IQUAME,IQUASE,PSTAMV, 10633 1 STAT, 10634 1 ISUBRO,IBUGG3,IERROR) 10635 IF(IERROR.EQ.'YES')GOTO9000 10636 IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'BRAT')THEN 10637 PTEMP=STAT 10638 NTRIAL=NTEMP 10639 IF(ICASCT.EQ.'BRAT')NTRIAL=ITEMP1(1) 10640 IF(STAT.EQ.PSTAMV)THEN 10641 ALOWLM=PSTAMV 10642 AUPPLM=PSTAMV 10643 ELSE 10644 ALPHAT=ALPHA 10645 IF(ALPHAT.LE.0.5)ALPHAT=1.0 - ALPHA 10646 CALL DPAGCO(PTEMP,NTRIAL,ALPHAT,IWRITE, 10647 1 ALOWLM,AUPPLM,IBUGG3,IERROR) 10648 ENDIF 10649 ELSEIF(ICASCT.EQ.'MECL')THEN 10650 XMEAN=STAT 10651 NTRIAL=NTEMP 10652 IF(STAT.EQ.PSTAMV)THEN 10653 ALOWLM=PSTAMV 10654 AUPPLM=PSTAMV 10655 ELSE 10656 CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGG3,IERROR) 10657 ALPHAT=ALPHA 10658 CALL DPMECL(XMEAN,XSD,NTEMP,ALPHAT,IWRITE, 10659 1 ALOWLM,AUPPLM,IBUGG3,IERROR) 10660 ENDIF 10661 ELSEIF(ICASCT.EQ.'MDCL')THEN 10662 XMED=STAT 10663 NTRIAL=NTEMP 10664 IF(STAT.EQ.PSTAMV)THEN 10665 ALOWLM=PSTAMV 10666 AUPPLM=PSTAMV 10667 ELSE 10668 XQ=0.5 10669 CALL QUANSE(XQ,TEMP,NTEMP,IWRITE,XTEMP1,MAXNXT,IQUASE, 10670 1 QUASE,IBUGG3,IERROR) 10671 ALPHAT=ALPHA 10672 CALL DPMECL(XMED,QUASE,NTEMP,ALPHAT,IWRITE, 10673 1 ALOWLM,AUPPLM,IBUGG3,IERROR) 10674 ENDIF 10675 ENDIF 10676 ENDIF 10677C 10678 J=J+1 10679 Y2(J)=STAT 10680 X2(J)=XIDTEM(ISET1) 10681 D2(J)=XIDTE2(ISET2) 10682 D3(J)=XIDTE3(ISET3) 10683 D4(J)=XIDTE4(ISET4) 10684 IF(ICASCT.EQ.'BPRO' .OR. ICASCT.EQ.'MECL' .OR. 10685 1 ICASCT.EQ.'MDCL' .OR. ICASCT.EQ.'BRAT')THEN 10686 IF(AUPPLM.GT.STATMX)STATMX=AUPPLM 10687 IF(ALOWLM.LT.STATMN)STATMN=ALOWLM 10688 XACLOW(J)=ALOWLM 10689 XACUPP(J)=AUPPLM 10690 ENDIF 10691C 10692 1140 CONTINUE 10693 1130 CONTINUE 10694 1120 CONTINUE 10695 1110 CONTINUE 10696 N2=J 10697C 10698C ****************** 10699C ** STEP 90-- ** 10700C ** EXIT ** 10701C ****************** 10702C 10703 9000 CONTINUE 10704 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TAP5')THEN 10705 WRITE(ICOUT,999) 10706 999 FORMAT(1X) 10707 CALL DPWRST('XXX','BUG ') 10708 WRITE(ICOUT,9011) 10709 9011 FORMAT('***** AT THE END OF DPTAP5--') 10710 CALL DPWRST('XXX','BUG ') 10711 WRITE(ICOUT,9012)ICASCT,N,NUMV2,IERROR 10712 9012 FORMAT('ICASCT,N,NUMV2,IERROR = ',A4,2I8,2X,A4) 10713 CALL DPWRST('XXX','BUG ') 10714 WRITE(ICOUT,9015)NUMSE1,NUMSE2,NUMSE3,NUMSE4,N2 10715 9015 FORMAT('NUMSE1,NUMSE2,NUMSE3,NUMSE4,N2 = ',5I8) 10716 CALL DPWRST('XXX','BUG ') 10717 DO9020I=1,N2 10718 WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I),D3(I),D4(I) 10719 9021 FORMAT('I,Y2(I),X2(I),D2(I),D3(I),D4(I) = ',I8,5G15.7) 10720 CALL DPWRST('XXX','BUG ') 10721 9020 CONTINUE 10722 ENDIF 10723C 10724 RETURN 10725 END 10726 SUBROUTINE DPTAWI(IFORWI,IFORWR,MAXNWI, 10727 1 ISUBRO,IBUGS2,IFOUND,IERROR) 10728C 10729C PURPOSE--IMPLEMENT THE COMMAND 10730C 10731C TABLE WIDTH <SIGDIG> <TOTWID> 10732C 10733C THIS IS AN ALTERNATIVE TO "SET WRITE DECIMALS" AND 10734C "SET WRITE FORMAT" FOR DEFINING HOW TO PRINT 10735C VARIABLES WITH THE WRITE COMMAND. THE LIMITATION 10736C OF "SET WRITE DECIMALS" IS THAT IT ONLY ALLOWS YOU 10737C TO SPECIFY THE NUMBER OF DIGITS TO THE RIGHT OF 10738C THE DECIMAL POINT AND IT SETS ALL COLUMNS TO THE 10739C SAME VALUE. THE LIMITATION OF SET WRITE FORMAT 10740C IS THAT IT CANNOT BE EASILY APPLIED TO HTML, LATEK, 10741C OR RTF OUTPUT. 10742C 10743C THE <SIGDIG> VARIABLE DEFINES THE NUMBER OF DIGITS 10744C TO THE RIGHT OF THE DECIMAL POINT AND <TOTWID> DEFINES 10745C THE TOTAL WIDTH OF THE FIELD (SO THIS SETS Fxx.yy 10746C FORMAT WHERE WE ARE DEFINING "yy" AND "xx"). 10747C 10748C IF EITHER <SIGDIG> OR <TOTWID> IS NEGATIVE, THEN 10749C WE USE Exx.yy FORMAT. 10750C 10751C IF <SIGDIG> OR <TOTWID> IS A SCALAR, THEN ALL ROWS 10752C OF IFORWI AND IFORWR WILL BE SET. IF ONLY <SIGDIG> 10753C IS SPECIFIED, <TOTWID> WILL BE SET TO -99 (THIS IS 10754C EQUIVALENT TO USING SET WRITE DECIMALS) FOR F FORMAT 10755C AND TO <SIGDIG> + 8 FOR E FORMAT. 10756C 10757C INPUT ARGUMENTS --MAXNWI = MAXIMUM NUMBER OF FIELDS THAT 10758C CAN BE SPECIFIED 10759C OUTPUT ARGUMENTS--IFORWI = INTEGER ARRAY THAT DEFINES THE 10760C TOTAL WIDTH OF THE FIELDS 10761C --IFORWR = INTEGER ARRAY THAT DEFINES THE 10762C NUMBER OF DIGITS TO THE RIGHT OF 10763C THE DECIMAL 10764C --IFOUND ('YES' OR 'NO' ) 10765C --IERROR ('YES' OR 'NO' ) 10766C WRITTEN BY--JAMES J. FILLIBEN 10767C STATISTICAL ENGINEERING DIVISION 10768C INFORMATION TECHNOLOGY LABORATORY 10769C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10770C GAITHERSBURG, MD 20899-8980 10771C PHONE--301-975-2855 10772C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 10773C OF THE NATIONAL BUREAU OF STANDARDS. 10774C LANGUAGE--ANSI FORTRAN (1977) 10775C VERSION NUMBER--2009/3 10776C ORIGINAL VERSION--MARCH 2009. 10777C 10778C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10779C 10780 CHARACTER*4 ISUBRO 10781 CHARACTER*4 IBUGS2 10782 CHARACTER*4 IFOUND 10783 CHARACTER*4 IERROR 10784C 10785 CHARACTER*4 IHWUSE 10786 CHARACTER*4 IH11 10787 CHARACTER*4 IH12 10788 CHARACTER*4 MESSAG 10789 CHARACTER*4 ISUBN1 10790 CHARACTER*4 ISUBN2 10791C 10792C--------------------------------------------------------------------- 10793C 10794 INCLUDE 'DPCOPA.INC' 10795 INCLUDE 'DPCODA.INC' 10796 INCLUDE 'DPCOHK.INC' 10797 INCLUDE 'DPCOM2.INC' 10798C 10799 DIMENSION IFORWI(*) 10800 DIMENSION IFORWR(*) 10801C 10802C-----COMMON---------------------------------------------------------- 10803C 10804 INCLUDE 'DPCOP2.INC' 10805C 10806C-----START POINT----------------------------------------------------- 10807C 10808 IFOUND='NO' 10809 IERROR='NO' 10810C 10811 IHOLD1=0 10812 IHOLD2=0 10813 I1=-99 10814 I2=-99 10815 I3=-99 10816 ICOL2=0 10817C 10818 IF(ISUBRO.EQ.'TAWI' .OR. IBUGS2.EQ.'ON')THEN 10819 WRITE(ICOUT,999) 10820 999 FORMAT(1X) 10821 CALL DPWRST('XXX','BUG ') 10822 WRITE(ICOUT,51) 10823 51 FORMAT('****AT THE BEGINNING OF DPTAWI') 10824 CALL DPWRST('XXX','BUG ') 10825 WRITE(ICOUT,53)MAXNWI 10826 53 FORMAT('MAXNWI = ',I5) 10827 CALL DPWRST('XXX','BUG ') 10828 DO55I=1,MAXNWI 10829 WRITE(ICOUT,57)I,IFORWI(I),IFORWR(I) 10830 57 FORMAT('I,IFORWI(I),IFORWR(I) = ',3I8) 10831 CALL DPWRST('XXX','BUG ') 10832 55 CONTINUE 10833 ENDIF 10834C 10835C **************************************************** 10836C ** TREAT THE CASE WHEN ** 10837C ** THE FORMAT WIDTHS ARE TO BE CHANGED ** 10838C **************************************************** 10839C 10840 IF(NUMARG.LE.0)GOTO9000 10841 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'WIDT')GOTO1110 10842 GOTO1190 10843C 10844 1110 CONTINUE 10845 IF(NUMARG.EQ.1)GOTO1120 10846 IF(IHARG(NUMARG).EQ.'ON')GOTO1120 10847 IF(IHARG(NUMARG).EQ.'OFF')GOTO1120 10848 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1120 10849 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1120 10850 IF(IHARG(NUMARG).EQ.'?')GOTO8100 10851 IF(NUMARG.GE.3.AND.IARGT(2).EQ.'NUMB'.AND. 10852 1IARGT(3).EQ.'NUMB')GOTO1130 10853 IF(NUMARG.GE.2.AND.IARGT(2).EQ.'NUMB')GOTO1140 10854 GOTO3140 10855C 10856C CASE 1: RESET DEFAULT 10857C 10858 1120 CONTINUE 10859 I1=-99 10860 I2=-99 10861 DO1122I=1,MAXNWI 10862 IFORWI(I)=I1 10863 IFORWR(I)=I2 10864 1122 CONTINUE 10865 GOTO1180 10866C 10867C CASE 2: BOTH VALUES SCALARS 10868C 10869 1130 CONTINUE 10870 I1=IARG(2) 10871 I2=IARG(3) 10872 DO1132I=1,MAXNWI 10873 IFORWI(I)=I1 10874 IFORWR(I)=I2 10875 1132 CONTINUE 10876 GOTO1180 10877C 10878C CASE 3: ONE SCALAR SPECIFIED 10879C 10880 1140 CONTINUE 10881 I1=-99 10882 I2=IARG(2) 10883 DO1142I=1,MAXNWI 10884 IFORWI(I)=I1 10885 IFORWR(I)=I2 10886 1142 CONTINUE 10887 GOTO1180 10888C 10889 1180 CONTINUE 10890 IFOUND='YES' 10891C 10892 IF(IFEEDB.EQ.'ON')THEN 10893 WRITE(ICOUT,999) 10894 CALL DPWRST('XXX','BUG ') 10895 WRITE(ICOUT,1185)I1 10896 1185 FORMAT('THE TABLE WIDTHS SET TO ',I8) 10897 CALL DPWRST('XXX','BUG ') 10898 WRITE(ICOUT,1188)I2 10899 1188 FORMAT('THE TABLE DIGITS SET TO ',I8) 10900 CALL DPWRST('XXX','BUG ') 10901 ENDIF 10902 GOTO9000 10903C 10904 1190 CONTINUE 10905C 10906C ******************************************** 10907C ** STEP 81-- ** 10908C ** TREAT THE ? CASE-- ** 10909C ** DUMP OUT CURRENT AND DEFAULT VALUES. ** 10910C ******************************************** 10911C 10912 8100 CONTINUE 10913 IFOUND='YES' 10914 WRITE(ICOUT,999) 10915 CALL DPWRST('XXX','BUG ') 10916 WRITE(ICOUT,8109) 10917 8109 FORMAT('FIELD WIDTH FIELD DIGITS') 10918 CALL DPWRST('XXX','BUG ') 10919 DO8110I=1,MAXNWI 10920 WRITE(ICOUT,8111)IFORWI(I),IFORWR(I) 10921 8111 FORMAT(I11,5X,I12) 10922 CALL DPWRST('XXX','BUG ') 10923 8110 CONTINUE 10924 GOTO9000 10925C 10926 3140 CONTINUE 10927C 10928 IF(IARGT(2).EQ.'NUMB')THEN 10929 I2=IARG(2) 10930 N1=-99 10931 ELSE 10932 IH11=IHARG(2) 10933 IH12=IHARG2(2) 10934 IHWUSE='V' 10935 MESSAG='YES' 10936 CALL CHECKN(IH11,IH12,IHWUSE, 10937 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 10938 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 10939 IF(IERROR.EQ.'NO')THEN 10940 ICOL1=IVALUE(ILOCV) 10941 N1=IN(ILOCV) 10942 ELSE 10943 GOTO9000 10944 ENDIF 10945 ENDIF 10946C 10947 IF(IARGT(3).EQ.'NUMB')THEN 10948 I3=IARG(3) 10949 N2=-99 10950 ELSE 10951 IH11=IHARG(3) 10952 IH12=IHARG2(3) 10953 IHWUSE='V' 10954 MESSAG='YES' 10955 CALL CHECKN(IH11,IH12,IHWUSE, 10956 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 10957 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 10958 IF(IERROR.EQ.'NO')THEN 10959 ICOL2=IVALUE(ILOCV) 10960 N2=IN(ILOCV) 10961 ELSE 10962 GOTO9000 10963 ENDIF 10964 ENDIF 10965C 10966 IF(N1.GT.0)THEN 10967 J=0 10968 IMAX=MIN(MAXNWI,N1) 10969 DO3160I=1,IMAX 10970C 10971 IF(I.GT.IMAX)GOTO3169 10972 J=J+1 10973 IFORWI(J)=-99 10974 IJ=MAXN*(ICOL1-1)+I 10975 IF(ICOL1.LE.MAXCOL)IFORWI(J)=INT(V(IJ)) 10976 IF(ICOL1.EQ.MAXCP1)IFORWI(J)=INT(PRED(I)) 10977 IF(ICOL1.EQ.MAXCP2)IFORWI(J)=INT(RES(I)) 10978 IF(ICOL1.EQ.MAXCP3)IFORWI(J)=INT(YPLOT(I)) 10979 IF(ICOL1.EQ.MAXCP4)IFORWI(J)=INT(XPLOT(I)) 10980 IF(ICOL1.EQ.MAXCP5)IFORWI(J)=INT(X2PLOT(I)) 10981 IF(ICOL1.EQ.MAXCP6)IFORWI(J)=INT(TAGPLO(I)) 10982C 10983 3160 CONTINUE 10984 3169 CONTINUE 10985C 10986 ELSE 10987 DO3165J=1,MAXNWI 10988 IFORWI(J)=I2 10989 3165 CONTINUE 10990 ENDIF 10991C 10992 IF(N2.GT.0)THEN 10993 J=0 10994 IMAX=MIN(MAXNWI,N2) 10995 DO3170I=1,IMAX 10996C 10997 IF(I.GT.IMAX)GOTO3179 10998 J=J+1 10999 IFORWR(J)=-99 11000 IJ=MAXN*(ICOL2-1)+I 11001 IF(ICOL2.LE.MAXCOL)IFORWR(J)=INT(V(IJ)) 11002 IF(ICOL2.EQ.MAXCP1)IFORWR(J)=INT(PRED(I)) 11003 IF(ICOL2.EQ.MAXCP2)IFORWR(J)=INT(RES(I)) 11004 IF(ICOL2.EQ.MAXCP3)IFORWR(J)=INT(YPLOT(I)) 11005 IF(ICOL2.EQ.MAXCP4)IFORWR(J)=INT(XPLOT(I)) 11006 IF(ICOL2.EQ.MAXCP5)IFORWR(J)=INT(X2PLOT(I)) 11007 IF(ICOL2.EQ.MAXCP6)IFORWR(J)=INT(TAGPLO(I)) 11008C 11009 3170 CONTINUE 11010 3179 CONTINUE 11011C 11012 ELSE 11013 DO3175J=1,MAXNWI 11014 IFORWR(J)=I3 11015 3175 CONTINUE 11016 ENDIF 11017C 11018 IF(IFEEDB.EQ.'ON')THEN 11019 WRITE(ICOUT,999) 11020 CALL DPWRST('XXX','BUG ') 11021 WRITE(ICOUT,8109) 11022 CALL DPWRST('XXX','BUG ') 11023 ILAST=MAX(N1,N2) 11024 ILAST=MIN(ILAST,MAXNWI) 11025 DO3190I=1,ILAST 11026 WRITE(ICOUT,8111)IFORWI(I),IFORWR(I) 11027 CALL DPWRST('XXX','BUG ') 11028 3190 CONTINUE 11029 ENDIF 11030C 11031 IFOUND='YES' 11032 GOTO9000 11033C 11034C ***************** 11035C ** STEP 90-- ** 11036C ** EXIT ** 11037C ***************** 11038C 11039 9000 CONTINUE 11040C 11041 IF(ISUBRO.EQ.'TAWI' .OR. IBUGS2.EQ.'ON')THEN 11042 WRITE(ICOUT,999) 11043 CALL DPWRST('XXX','BUG ') 11044 WRITE(ICOUT,9051) 11045 9051 FORMAT('****AT THE END OF DPTAWI') 11046 CALL DPWRST('XXX','BUG ') 11047 DO9055I=1,MAXNWI 11048 WRITE(ICOUT,9057)I,IFORWI(I),IFORWR(I) 11049 9057 FORMAT('I,IFORWI(I),IFORWR(I) = ',3I8) 11050 CALL DPWRST('XXX','BUG ') 11051 9055 CONTINUE 11052 ENDIF 11053C 11054 RETURN 11055 END 11056 SUBROUTINE DPTBCO(IHARG,NUMARG,IDETBC,MAXTEX,ITEBCO, 11057 1IBUGP2,IFOUND,IERROR) 11058C 11059C PURPOSE--DEFINE THE TEXT BORDER COLORS = THE COLORS 11060C OF THE BORDER LINE AROUND THE TEXTS. 11061C THESE ARE LOCATED IN THE VECTOR ITEBCO(.). 11062C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 11063C --NUMARG 11064C --IDETBC 11065C --MAXTEX 11066C --IBUGP2 ('ON' OR 'OFF' ) 11067C OUTPUT ARGUMENTS--ITEBCO (A CHARACTER VECTOR) 11068C --IFOUND ('YES' OR 'NO' ) 11069C --IERROR ('YES' OR 'NO' ) 11070C WRITTEN BY--JAMES J. FILLIBEN 11071C STATISTICAL ENGINEERING DIVISION 11072C INFORMATION TECHNOLOGY LABORATORY 11073C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11074C GAITHERSBURG, MD 20899-8980 11075C PHONE--301-975-2899 11076C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11077C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11078C LANGUAGE--ANSI FORTRAN (1977) 11079C VERSION NUMBER--82/7 11080C ORIGINAL VERSION--DECEMBER 1983. 11081C 11082C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11083C 11084 CHARACTER*4 IHARG 11085 CHARACTER*4 IDETBC 11086 CHARACTER*4 ITEBCO 11087C 11088 CHARACTER*4 IBUGP2 11089 CHARACTER*4 IFOUND 11090 CHARACTER*4 IERROR 11091C 11092 CHARACTER*4 IHOLD1 11093 CHARACTER*4 IHOLD2 11094C 11095 CHARACTER*4 ISUBN1 11096 CHARACTER*4 ISUBN2 11097 CHARACTER*4 ISTEPN 11098C 11099 DIMENSION IHARG(*) 11100 DIMENSION ITEBCO(*) 11101C 11102C-----COMMON---------------------------------------------------------- 11103C 11104 INCLUDE 'DPCOP2.INC' 11105C 11106C-----START POINT----------------------------------------------------- 11107C 11108 IFOUND='NO' 11109 IERROR='NO' 11110 ISUBN1='DPTB' 11111 ISUBN2='CO ' 11112C 11113 NUMTEX=0 11114 IHOLD1='-999' 11115 IHOLD2='-999' 11116C 11117 IF(IBUGP2.EQ.'OFF')GOTO90 11118 WRITE(ICOUT,999) 11119 999 FORMAT(1X) 11120 CALL DPWRST('XXX','BUG ') 11121 WRITE(ICOUT,51) 11122 51 FORMAT('***** AT THE BEGINNING OF DPTBCO--') 11123 CALL DPWRST('XXX','BUG ') 11124 WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 11125 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11126 CALL DPWRST('XXX','BUG ') 11127 WRITE(ICOUT,53)MAXTEX,NUMTEX 11128 53 FORMAT('MAXTEX,NUMTEX = ',I8,I8) 11129 CALL DPWRST('XXX','BUG ') 11130 WRITE(ICOUT,54)IHOLD1,IHOLD2 11131 54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 11132 CALL DPWRST('XXX','BUG ') 11133 WRITE(ICOUT,55)IDETBC 11134 55 FORMAT('IDETBC = ',A4) 11135 CALL DPWRST('XXX','BUG ') 11136 WRITE(ICOUT,60)NUMARG 11137 60 FORMAT('NUMARG = ',I8) 11138 CALL DPWRST('XXX','BUG ') 11139 DO65I=1,NUMARG 11140 WRITE(ICOUT,66)IHARG(I) 11141 66 FORMAT('IHARG(I) = ',A4) 11142 CALL DPWRST('XXX','BUG ') 11143 65 CONTINUE 11144 WRITE(ICOUT,70)ITEBCO(1) 11145 70 FORMAT('ITEBCO(1) = ',A4) 11146 CALL DPWRST('XXX','BUG ') 11147 DO75I=1,10 11148 WRITE(ICOUT,76)I,ITEBCO(I) 11149 76 FORMAT('I,ITEBCO(I) = ',I8,2X,A4) 11150 CALL DPWRST('XXX','BUG ') 11151 75 CONTINUE 11152 90 CONTINUE 11153C 11154C ************************************** 11155C ** STEP 1-- ** 11156C ** BRANCH TO THE APPROPRIATE CASE ** 11157C ************************************** 11158C 11159 ISTEPN='1' 11160 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 11161C 11162 IF(NUMARG.LE.1)GOTO9000 11163 IF(NUMARG.EQ.2)GOTO1120 11164 IF(NUMARG.EQ.3)GOTO1130 11165 IF(NUMARG.EQ.4)GOTO1140 11166 GOTO1150 11167C 11168 1120 CONTINUE 11169 GOTO1200 11170C 11171 1130 CONTINUE 11172 IF(IHARG(3).EQ.'ALL')IHOLD1=' ' 11173 IF(IHARG(3).EQ.'ALL')GOTO1300 11174 GOTO1200 11175C 11176 1140 CONTINUE 11177 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) 11178 IF(IHARG(3).EQ.'ALL')GOTO1300 11179 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) 11180 IF(IHARG(4).EQ.'ALL')GOTO1300 11181 GOTO1200 11182C 11183 1150 CONTINUE 11184 GOTO1200 11185C 11186C ************************************************* 11187C ** STEP 2-- ** 11188C ** TREAT THE SINGLE SPECIFICATION CASE ** 11189C ************************************************* 11190C 11191 1200 CONTINUE 11192 ISTEPN='2' 11193 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 11194C 11195 IF(NUMARG.LE.2)GOTO1210 11196 GOTO1220 11197C 11198 1210 CONTINUE 11199 NUMTEX=1 11200 ITEBCO(1)=IDETBC 11201 GOTO1270 11202C 11203 1220 CONTINUE 11204 NUMTEX=NUMARG-2 11205 IF(NUMTEX.GT.MAXTEX)NUMTEX=MAXTEX 11206 DO1225I=1,NUMTEX 11207 J=I+2 11208 IHOLD1=IHARG(J) 11209 IHOLD2=IHOLD1 11210 IF(IHOLD1.EQ.'ON')IHOLD2=IDETBC 11211 IF(IHOLD1.EQ.'OFF')IHOLD2=IDETBC 11212 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDETBC 11213 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDETBC 11214 ITEBCO(I)=IHOLD2 11215 1225 CONTINUE 11216 GOTO1270 11217C 11218 1270 CONTINUE 11219 IF(IFEEDB.EQ.'OFF')GOTO1279 11220 WRITE(ICOUT,999) 11221 CALL DPWRST('XXX','BUG ') 11222 DO1278I=1,NUMTEX 11223 WRITE(ICOUT,1276)I,ITEBCO(I) 11224 1276 FORMAT('THE COLOR OF TEXT BORDER ',I6, 11225 1' HAS JUST BEEN SET TO ',A4) 11226 CALL DPWRST('XXX','BUG ') 11227 1278 CONTINUE 11228 1279 CONTINUE 11229 IFOUND='YES' 11230 GOTO9000 11231C 11232C ************************** 11233C ** STEP 3-- ** 11234C ** TREAT THE ALL CASE ** 11235C ************************** 11236C 11237 1300 CONTINUE 11238 ISTEPN='3' 11239 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 11240C 11241 NUMTEX=MAXTEX 11242 IHOLD2=IHOLD1 11243 IF(IHOLD1.EQ.'ON')IHOLD2=IDETBC 11244 IF(IHOLD1.EQ.'OFF')IHOLD2=IDETBC 11245 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDETBC 11246 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDETBC 11247 DO1315I=1,NUMTEX 11248 ITEBCO(I)=IHOLD2 11249 1315 CONTINUE 11250 GOTO1370 11251C 11252 1370 CONTINUE 11253 IF(IFEEDB.EQ.'OFF')GOTO1319 11254 WRITE(ICOUT,999) 11255 CALL DPWRST('XXX','BUG ') 11256 I=1 11257 WRITE(ICOUT,1316)ITEBCO(I) 11258 1316 FORMAT('THE COLOR OF ALL TEXT BORDERS', 11259 1' HAS JUST BEEN SET TO ',A4) 11260 CALL DPWRST('XXX','BUG ') 11261 1319 CONTINUE 11262 IFOUND='YES' 11263 GOTO9000 11264C 11265C ***************** 11266C ** STEP 90-- ** 11267C ** EXIT ** 11268C ***************** 11269C 11270 9000 CONTINUE 11271 IF(IBUGP2.EQ.'OFF')GOTO9090 11272 WRITE(ICOUT,9011) 11273 9011 FORMAT('***** AT THE END OF DPTBCO--') 11274 CALL DPWRST('XXX','BUG ') 11275 WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 11276 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11277 CALL DPWRST('XXX','BUG ') 11278 WRITE(ICOUT,9013)MAXTEX,NUMTEX 11279 9013 FORMAT('MAXTEX,NUMTEX = ',I8,I8) 11280 CALL DPWRST('XXX','BUG ') 11281 WRITE(ICOUT,9014)IHOLD1,IHOLD2 11282 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 11283 CALL DPWRST('XXX','BUG ') 11284 WRITE(ICOUT,9015)IDETBC 11285 9015 FORMAT('IDETBC = ',A4) 11286 CALL DPWRST('XXX','BUG ') 11287 WRITE(ICOUT,9020)NUMARG 11288 9020 FORMAT('NUMARG = ',I8) 11289 CALL DPWRST('XXX','BUG ') 11290 DO9025I=1,NUMARG 11291 WRITE(ICOUT,9026)IHARG(I) 11292 9026 FORMAT('IHARG(I) = ',A4) 11293 CALL DPWRST('XXX','BUG ') 11294 9025 CONTINUE 11295 WRITE(ICOUT,9030)ITEBCO(1) 11296 9030 FORMAT('ITEBCO(1) = ',A4) 11297 CALL DPWRST('XXX','BUG ') 11298 DO9035I=1,10 11299 WRITE(ICOUT,9036)I,ITEBCO(I) 11300 9036 FORMAT('I,ITEBCO(I) = ',I8,2X,A4) 11301 CALL DPWRST('XXX','BUG ') 11302 9035 CONTINUE 11303 9090 CONTINUE 11304C 11305 RETURN 11306 END 11307 SUBROUTINE DPTBLI(IHARG,IHARG2,NUMARG,IDETBL,MAXTEX,ITEBLI, 11308CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC 11309CCCCC SUBROUTINE DPTBLI(IHARG,NUMARG,IDETBL,MAXTEX,ITEBLI, 11310 1IBUGP2,IFOUND,IERROR) 11311C 11312C PURPOSE--DEFINE THE BORDER LINES = THE LINES TYPES 11313C OF THE BORDER AROUND THE TEXTS. 11314C THESE ARE LOCATED IN THE VECTOR ITEBLI(.). 11315C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 11316C --NUMARG 11317C --IDETBL 11318C --MAXTEX 11319C --IBUGP2 ('ON' OR 'OFF' ) 11320C OUTPUT ARGUMENTS--ITEBLI (A CHARACTER VECTOR) 11321C --IFOUND ('YES' OR 'NO' ) 11322C --IERROR ('YES' OR 'NO' ) 11323C WRITTEN BY--JAMES J. FILLIBEN 11324C STATISTICAL ENGINEERING DIVISION 11325C INFORMATION TECHNOLOGY LABORATORY 11326C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11327C GAITHERSBURG, MD 20899-8980 11328C PHONE--301-975-2899 11329C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11330C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11331C LANGUAGE--ANSI FORTRAN (1977) 11332C VERSION NUMBER--82/7 11333C ORIGINAL VERSION--DECEMBER 1983. 11334C UPDATED --AUGUST 1995. DASH2 BUG 11335C 11336C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11337C 11338 CHARACTER*4 IHARG 11339CCCCC AUGUST 1995. ADD FOLLOWING LINE 11340 CHARACTER*4 IHARG2 11341 CHARACTER*4 IDETBL 11342 CHARACTER*4 ITEBLI 11343C 11344 CHARACTER*4 IBUGP2 11345 CHARACTER*4 IFOUND 11346 CHARACTER*4 IERROR 11347C 11348 CHARACTER*4 IHOLD1 11349 CHARACTER*4 IHOLD2 11350C 11351 CHARACTER*4 ISUBN1 11352 CHARACTER*4 ISUBN2 11353 CHARACTER*4 ISTEPN 11354C 11355 DIMENSION IHARG(*) 11356CCCCC AUGUST 1995. ADD FOLLOWING LINE 11357 DIMENSION IHARG2(*) 11358 DIMENSION ITEBLI(*) 11359C 11360C-----COMMON---------------------------------------------------------- 11361C 11362 INCLUDE 'DPCOP2.INC' 11363C 11364C-----START POINT----------------------------------------------------- 11365C 11366 IFOUND='NO' 11367 IERROR='NO' 11368 ISUBN1='DPTB' 11369 ISUBN2='LI ' 11370C 11371 NUMTEX=0 11372 IHOLD1='-999' 11373 IHOLD2='-999' 11374C 11375 IF(IBUGP2.EQ.'OFF')GOTO90 11376 WRITE(ICOUT,999) 11377 999 FORMAT(1X) 11378 CALL DPWRST('XXX','BUG ') 11379 WRITE(ICOUT,51) 11380 51 FORMAT('***** AT THE BEGINNING OF DPTBLI--') 11381 CALL DPWRST('XXX','BUG ') 11382 WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 11383 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11384 CALL DPWRST('XXX','BUG ') 11385 WRITE(ICOUT,53)MAXTEX,NUMTEX 11386 53 FORMAT('MAXTEX,NUMTEX = ',I8,I8) 11387 CALL DPWRST('XXX','BUG ') 11388 WRITE(ICOUT,54)IHOLD1,IHOLD2 11389 54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 11390 CALL DPWRST('XXX','BUG ') 11391 WRITE(ICOUT,55)IDETBL 11392 55 FORMAT('IDETBL = ',A4) 11393 CALL DPWRST('XXX','BUG ') 11394 WRITE(ICOUT,60)NUMARG 11395 60 FORMAT('NUMARG = ',I8) 11396 CALL DPWRST('XXX','BUG ') 11397 DO65I=1,NUMARG 11398 WRITE(ICOUT,66)IHARG(I) 11399 66 FORMAT('IHARG(I) = ',A4) 11400 CALL DPWRST('XXX','BUG ') 11401 65 CONTINUE 11402 WRITE(ICOUT,70)ITEBLI(1) 11403 70 FORMAT('ITEBLI(1) = ',A4) 11404 CALL DPWRST('XXX','BUG ') 11405 DO75I=1,10 11406 WRITE(ICOUT,76)I,ITEBLI(I) 11407 76 FORMAT('I,ITEBLI(I) = ',I8,2X,A4) 11408 CALL DPWRST('XXX','BUG ') 11409 75 CONTINUE 11410 90 CONTINUE 11411C 11412C ************************************** 11413C ** STEP 1-- ** 11414C ** BRANCH TO THE APPROPRIATE CASE ** 11415C ************************************** 11416C 11417 ISTEPN='1' 11418 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 11419C 11420 IF(NUMARG.LE.2)GOTO9000 11421 IF(NUMARG.EQ.3)GOTO1130 11422 IF(NUMARG.EQ.4)GOTO1140 11423 IF(NUMARG.EQ.5)GOTO1150 11424 GOTO1160 11425C 11426 1130 CONTINUE 11427 GOTO1200 11428C 11429 1140 CONTINUE 11430 IF(IHARG(5).EQ.'ALL')IHOLD1=' ' 11431 IF(IHARG(5).EQ.'ALL')GOTO1300 11432 GOTO1200 11433C 11434 1150 CONTINUE 11435CCCCC IF(IHARG(5).EQ.'ALL')IHOLD1=IHARG(6) 11436CCCCC IF(IHARG(5).EQ.'ALL')GOTO1300 11437CCCCC IF(IHARG(6).EQ.'ALL')IHOLD1=IHARG(5) 11438CCCCC IF(IHARG(6).EQ.'ALL')GOTO1300 11439CCCCC APRIL 1996. CHANGE IHOLD TO IHOLD1 BELOW 11440 IF(IHARG(5).EQ.'ALL')THEN 11441 IHOLD1=IHARG(6) 11442 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'2')IHOLD1='DA2' 11443 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'3')IHOLD1='DA3' 11444 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'4')IHOLD1='DA4' 11445 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'5')IHOLD1='DA5' 11446 GOTO1300 11447 ENDIF 11448 IF(IHARG(6).EQ.'ALL')THEN 11449 IHOLD1=IHARG(5) 11450 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'2')IHOLD1='DA2' 11451 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'3')IHOLD1='DA3' 11452 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'4')IHOLD1='DA4' 11453 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'5')IHOLD1='DA5' 11454 GOTO1300 11455 ENDIF 11456 GOTO1200 11457C 11458 1160 CONTINUE 11459 GOTO1200 11460C 11461C ************************************************* 11462C ** STEP 2-- ** 11463C ** TREAT THE SINGLE SPECIFICATION CASE ** 11464C ************************************************* 11465C 11466 1200 CONTINUE 11467 ISTEPN='2' 11468 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 11469C 11470 IF(NUMARG.LE.3)GOTO1210 11471 GOTO1220 11472C 11473 1210 CONTINUE 11474 NUMTEX=1 11475 ITEBLI(1)=' ' 11476 GOTO1270 11477C 11478 1220 CONTINUE 11479 NUMTEX=NUMARG-3 11480 IF(NUMTEX.GT.MAXTEX)NUMTEX=MAXTEX 11481 DO1225I=1,NUMTEX 11482 J=I+3 11483 IHOLD1=IHARG(J) 11484 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'2')IHOLD1='DA2' 11485 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'3')IHOLD1='DA3' 11486 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'4')IHOLD1='DA4' 11487 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'5')IHOLD1='DA5' 11488 IHOLD2=IHOLD1 11489 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' 11490 IF(IHOLD1.EQ.'OFF')IHOLD2=' ' 11491 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDETBL 11492 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDETBL 11493 ITEBLI(I)=IHOLD2 11494 1225 CONTINUE 11495 GOTO1270 11496C 11497 1270 CONTINUE 11498 IF(IFEEDB.EQ.'OFF')GOTO1279 11499 WRITE(ICOUT,999) 11500 CALL DPWRST('XXX','BUG ') 11501 DO1278I=1,NUMTEX 11502 WRITE(ICOUT,1276)I,ITEBLI(I) 11503 1276 FORMAT('THE LINE TYPE FOR TEXT BORDER ',I6, 11504 1' HAS JUST BEEN SET TO ',A4) 11505 CALL DPWRST('XXX','BUG ') 11506 1278 CONTINUE 11507 1279 CONTINUE 11508 IFOUND='YES' 11509 GOTO9000 11510C 11511C ************************** 11512C ** STEP 3-- ** 11513C ** TREAT THE ALL CASE ** 11514C ************************** 11515C 11516 1300 CONTINUE 11517 ISTEPN='3' 11518 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 11519C 11520 NUMTEX=MAXTEX 11521 IHOLD2=IHOLD1 11522 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' 11523 IF(IHOLD1.EQ.'OFF')IHOLD2=' ' 11524 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDETBL 11525 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDETBL 11526 DO1315I=1,NUMTEX 11527 ITEBLI(I)=IHOLD2 11528 1315 CONTINUE 11529 GOTO1370 11530C 11531 1370 CONTINUE 11532 IF(IFEEDB.EQ.'OFF')GOTO1319 11533 WRITE(ICOUT,999) 11534 CALL DPWRST('XXX','BUG ') 11535 I=1 11536 WRITE(ICOUT,1316)ITEBLI(I) 11537 1316 FORMAT('THE LINE TYPE FOR ALL TEXT BORDERS', 11538 1' HAS JUST BEEN SET TO ',A4) 11539 CALL DPWRST('XXX','BUG ') 11540 1319 CONTINUE 11541 IFOUND='YES' 11542 GOTO9000 11543C 11544C ***************** 11545C ** STEP 90-- ** 11546C ** EXIT ** 11547C ***************** 11548C 11549 9000 CONTINUE 11550 IF(IBUGP2.EQ.'OFF')GOTO9090 11551 WRITE(ICOUT,9011) 11552 9011 FORMAT('***** AT THE END OF DPTBLI--') 11553 CALL DPWRST('XXX','BUG ') 11554 WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 11555 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11556 CALL DPWRST('XXX','BUG ') 11557 WRITE(ICOUT,9013)MAXTEX,NUMTEX 11558 9013 FORMAT('MAXTEX,NUMTEX = ',I8,I8) 11559 CALL DPWRST('XXX','BUG ') 11560 WRITE(ICOUT,9014)IHOLD1,IHOLD2 11561 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 11562 CALL DPWRST('XXX','BUG ') 11563 WRITE(ICOUT,9015)IDETBL 11564 9015 FORMAT('IDETBL = ',A4) 11565 CALL DPWRST('XXX','BUG ') 11566 WRITE(ICOUT,9020)NUMARG 11567 9020 FORMAT('NUMARG = ',I8) 11568 CALL DPWRST('XXX','BUG ') 11569 DO9025I=1,NUMARG 11570 WRITE(ICOUT,9026)IHARG(I) 11571 9026 FORMAT('IHARG(I) = ',A4) 11572 CALL DPWRST('XXX','BUG ') 11573 9025 CONTINUE 11574 WRITE(ICOUT,9030)ITEBLI(1) 11575 9030 FORMAT('ITEBLI(1) = ',A4) 11576 CALL DPWRST('XXX','BUG ') 11577 DO9035I=1,10 11578 WRITE(ICOUT,9036)I,ITEBLI(I) 11579 9036 FORMAT('I,ITEBLI(I) = ',I8,2X,A4) 11580 CALL DPWRST('XXX','BUG ') 11581 9035 CONTINUE 11582 9090 CONTINUE 11583C 11584 RETURN 11585 END 11586 SUBROUTINE DPTBTH(IHARG,IARGT,ARG,NUMARG,PDETBT,MAXTEX,PTEBTH, 11587 1IBUGP2,IFOUND,IERROR) 11588C 11589C PURPOSE--DEFINE THE TEXT (BORDER) LINE THICKNESSES = THE THICKNESSES 11590C OF THE BORDER LINE AROUND THE TEXTS. 11591C THESE ARE LOCATED IN THE VECTOR PTEBTH(.). 11592C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 11593C --IARGT (A CHARACTER VECTOR) 11594C --ARG 11595C --NUMARG 11596C --PDETBT 11597C --MAXTEX 11598C --IBUGP2 ('ON' OR 'OFF' ) 11599C OUTPUT ARGUMENTS--PTEBTH (A FLOATING POINT VECTOR) 11600C --IFOUND ('YES' OR 'NO' ) 11601C --IERROR ('YES' OR 'NO' ) 11602C WRITTEN BY--JAMES J. FILLIBEN 11603C STATISTICAL ENGINEERING DIVISION 11604C INFORMATION TECHNOLOGY LABORATORY 11605C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11606C GAITHERSBURG, MD 20899-8980 11607C PHONE--301-975-2899 11608C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11609C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11610C LANGUAGE--ANSI FORTRAN (1977) 11611C VERSION NUMBER--82/7 11612C ORIGINAL VERSION--DECEMBER 1983. 11613C 11614C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11615C 11616 CHARACTER*4 IHARG 11617 CHARACTER*4 IARGT 11618C 11619 CHARACTER*4 IBUGP2 11620 CHARACTER*4 IFOUND 11621 CHARACTER*4 IERROR 11622C 11623 CHARACTER*4 IHOLD1 11624C 11625 CHARACTER*4 ISUBN1 11626 CHARACTER*4 ISUBN2 11627 CHARACTER*4 ISTEPN 11628C 11629 DIMENSION IHARG(*) 11630 DIMENSION IARGT(*) 11631 DIMENSION ARG(*) 11632 DIMENSION PTEBTH(*) 11633C 11634C-----COMMON---------------------------------------------------------- 11635C 11636 INCLUDE 'DPCOP2.INC' 11637C 11638C-----START POINT----------------------------------------------------- 11639C 11640 IFOUND='NO' 11641 IERROR='NO' 11642 ISUBN1='DPTB' 11643 ISUBN2='TH ' 11644C 11645 NUMTEX=0 11646 IHOLD1='-999' 11647 HOLD1=-999.0 11648 HOLD2=-999.0 11649C 11650 IF(IBUGP2.EQ.'OFF')GOTO90 11651 WRITE(ICOUT,999) 11652 999 FORMAT(1X) 11653 CALL DPWRST('XXX','BUG ') 11654 WRITE(ICOUT,51) 11655 51 FORMAT('***** AT THE BEGINNING OF DPTBTH--') 11656 CALL DPWRST('XXX','BUG ') 11657 WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 11658 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11659 CALL DPWRST('XXX','BUG ') 11660 WRITE(ICOUT,53)MAXTEX,NUMTEX 11661 53 FORMAT('MAXTEX,NUMTEX = ',I8,I8) 11662 CALL DPWRST('XXX','BUG ') 11663 WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2 11664 54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) 11665 CALL DPWRST('XXX','BUG ') 11666 WRITE(ICOUT,55)PDETBT 11667 55 FORMAT('PDETBT = ',E15.7) 11668 CALL DPWRST('XXX','BUG ') 11669 WRITE(ICOUT,60)NUMARG 11670 60 FORMAT('NUMARG = ',I8) 11671 CALL DPWRST('XXX','BUG ') 11672 DO65I=1,NUMARG 11673 WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I) 11674 66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) 11675 CALL DPWRST('XXX','BUG ') 11676 65 CONTINUE 11677 WRITE(ICOUT,70)PTEBTH(1) 11678 70 FORMAT('PTEBTH(1) = ',E15.7) 11679 CALL DPWRST('XXX','BUG ') 11680 DO75I=1,10 11681 WRITE(ICOUT,76)I,PTEBTH(I) 11682 76 FORMAT('I,PTEBTH(I) = ',I8,2X,E15.7) 11683 CALL DPWRST('XXX','BUG ') 11684 75 CONTINUE 11685 90 CONTINUE 11686C 11687C ************************************** 11688C ** STEP 1-- ** 11689C ** BRANCH TO THE APPROPRIATE CASE ** 11690C ************************************** 11691C 11692 ISTEPN='1' 11693 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 11694C 11695 IF(NUMARG.LE.1)GOTO9000 11696 IF(NUMARG.EQ.2)GOTO1120 11697 IF(NUMARG.EQ.3)GOTO1130 11698 IF(NUMARG.EQ.4)GOTO1140 11699 GOTO1150 11700C 11701 1120 CONTINUE 11702 GOTO1200 11703C 11704 1130 CONTINUE 11705 IF(IHARG(3).EQ.'ALL')IHOLD1=' ' 11706 IF(IHARG(3).EQ.'ALL')HOLD1=PDETBT 11707 IF(IHARG(3).EQ.'ALL')GOTO1300 11708 GOTO1200 11709C 11710 1140 CONTINUE 11711 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) 11712 IF(IHARG(3).EQ.'ALL')HOLD1=ARG(4) 11713 IF(IHARG(3).EQ.'ALL')GOTO1300 11714 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) 11715 IF(IHARG(4).EQ.'ALL')HOLD1=ARG(3) 11716 IF(IHARG(4).EQ.'ALL')GOTO1300 11717 GOTO1200 11718C 11719 1150 CONTINUE 11720 GOTO1200 11721C 11722C ************************************************* 11723C ** STEP 2-- ** 11724C ** TREAT THE SINGLE SPECIFICATION CASE ** 11725C ************************************************* 11726C 11727 1200 CONTINUE 11728 ISTEPN='2' 11729 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 11730C 11731 IF(NUMARG.LE.2)GOTO1210 11732 GOTO1220 11733C 11734 1210 CONTINUE 11735 NUMTEX=1 11736 PTEBTH(1)=PDETBT 11737 GOTO1270 11738C 11739 1220 CONTINUE 11740 NUMTEX=NUMARG-2 11741 IF(NUMTEX.GT.MAXTEX)NUMTEX=MAXTEX 11742 DO1225I=1,NUMTEX 11743 J=I+2 11744 IHOLD1=IHARG(J) 11745 HOLD1=ARG(J) 11746 HOLD2=HOLD1 11747 IF(IHOLD1.EQ.'ON')HOLD2=PDETBT 11748 IF(IHOLD1.EQ.'OFF')HOLD2=PDETBT 11749 IF(IHOLD1.EQ.'AUTO')HOLD2=PDETBT 11750 IF(IHOLD1.EQ.'DEFA')HOLD2=PDETBT 11751 PTEBTH(I)=HOLD2 11752 1225 CONTINUE 11753 GOTO1270 11754C 11755 1270 CONTINUE 11756 IF(IFEEDB.EQ.'OFF')GOTO1279 11757 WRITE(ICOUT,999) 11758 CALL DPWRST('XXX','BUG ') 11759 DO1278I=1,NUMTEX 11760 WRITE(ICOUT,1276)I,PTEBTH(I) 11761 1276 FORMAT('THE THICKNESS OF TEXT BORDER ',I6, 11762 1' HAS JUST BEEN SET TO ',E15.7) 11763 CALL DPWRST('XXX','BUG ') 11764 1278 CONTINUE 11765 1279 CONTINUE 11766 IFOUND='YES' 11767 GOTO9000 11768C 11769C ************************** 11770C ** STEP 3-- ** 11771C ** TREAT THE ALL CASE ** 11772C ************************** 11773C 11774 1300 CONTINUE 11775 ISTEPN='3' 11776 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 11777C 11778 NUMTEX=MAXTEX 11779 HOLD2=HOLD1 11780 IF(IHOLD1.EQ.'ON')HOLD2=PDETBT 11781 IF(IHOLD1.EQ.'OFF')HOLD2=PDETBT 11782 IF(IHOLD1.EQ.'AUTO')HOLD2=PDETBT 11783 IF(IHOLD1.EQ.'DEFA')HOLD2=PDETBT 11784 DO1315I=1,NUMTEX 11785 PTEBTH(I)=HOLD2 11786 1315 CONTINUE 11787 GOTO1370 11788C 11789 1370 CONTINUE 11790 IF(IFEEDB.EQ.'OFF')GOTO1319 11791 WRITE(ICOUT,999) 11792 CALL DPWRST('XXX','BUG ') 11793 I=1 11794 WRITE(ICOUT,1316)PTEBTH(I) 11795 1316 FORMAT('THE THICKNESS OF ALL TEXT BORDERS', 11796 1' HAS JUST BEEN SET TO ',E15.7) 11797 CALL DPWRST('XXX','BUG ') 11798 1319 CONTINUE 11799 IFOUND='YES' 11800 GOTO9000 11801C 11802C ***************** 11803C ** STEP 90-- ** 11804C ** EXIT ** 11805C ***************** 11806C 11807 9000 CONTINUE 11808 IF(IBUGP2.EQ.'OFF')GOTO9090 11809 WRITE(ICOUT,9011) 11810 9011 FORMAT('***** AT THE END OF DPTBTH--') 11811 CALL DPWRST('XXX','BUG ') 11812 WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 11813 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11814 CALL DPWRST('XXX','BUG ') 11815 WRITE(ICOUT,9013)MAXTEX,NUMTEX 11816 9013 FORMAT('MAXTEX,NUMTEX = ',I8,I8) 11817 CALL DPWRST('XXX','BUG ') 11818 WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2 11819 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) 11820 CALL DPWRST('XXX','BUG ') 11821 WRITE(ICOUT,9015)PDETBT 11822 9015 FORMAT('PDETBT = ',E15.7) 11823 CALL DPWRST('XXX','BUG ') 11824 WRITE(ICOUT,9020)NUMARG 11825 9020 FORMAT('NUMARG = ',I8) 11826 CALL DPWRST('XXX','BUG ') 11827 DO9025I=1,NUMARG 11828 WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I) 11829 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) 11830 CALL DPWRST('XXX','BUG ') 11831 9025 CONTINUE 11832 WRITE(ICOUT,9030)PTEBTH(1) 11833 9030 FORMAT('PTEBTH(1) = ',E15.7) 11834 CALL DPWRST('XXX','BUG ') 11835 DO9035I=1,10 11836 WRITE(ICOUT,9036)I,PTEBTH(I) 11837 9036 FORMAT('I,PTEBTH(I) = ',I8,2X,E15.7) 11838 CALL DPWRST('XXX','BUG ') 11839 9035 CONTINUE 11840 9090 CONTINUE 11841C 11842 RETURN 11843 END 11844 SUBROUTINE DPTCCL(ICOM,IHARG,NUMARG, 11845 1IDEFCO, 11846 1IX1TCO,IX2TCO,IY1TCO,IY2TCO, 11847 1IFOUND,IERROR) 11848C 11849C PURPOSE--DEFINE THE TIC MARK COLOR SWITCHES 11850C FOR ANY OF THE 4 FRAME LINES. 11851C SUCH TIC MARK SWITCHES DESCRIBE 11852C THE TIC MARK COLOR ON THE 4 FRAME LINES OF A PLOT. 11853C THE CONTENTS OF A TIC MARK COLOR SWITCH ARE 11854C A COLOR. 11855C THE TIC MARK COLOR SWITCHES FOR THE 4 FRAME LINES 11856C ARE CONTAINED IN THE 4 VARIABLES 11857C IX1TCO,IX2TCO,IY1TCO,IY2TCO 11858C INPUT ARGUMENTS--ICOM 11859C --IHARG (A HOLLERITH VECTOR) 11860C --NUMARG 11861C --IDEFCO 11862C OUTPUT ARGUMENTS--IX1TCO = COLOR FOR BOTTOM HORIZ. TICS 11863C --IX2TCO = COLOR FOR TOP HORIZ. TICS 11864C --IY1TCO = COLOR FOR LEFT VERT. TICS 11865C --IY2TCO = COLOR FOR RIGHT VERT. TICS 11866C --IFOUND ('YES' OR 'NO' ) 11867C --IERROR ('YES' OR 'NO' ) 11868C WRITTEN BY--JAMES J. FILLIBEN 11869C STATISTICAL ENGINEERING DIVISION 11870C INFORMATION TECHNOLOGY LABORATORY 11871C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11872C GAITHERSBURG, MD 20899-8980 11873C PHONE--301-975-2899 11874C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11875C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11876C LANGUAGE--ANSI FORTRAN (1977) 11877C VERSION NUMBER--82/7 11878C ORIGINAL VERSION--OCTOBER 1980. 11879C UPDATED --MAY 1982. 11880C 11881C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11882C 11883 CHARACTER*4 ICOM 11884 CHARACTER*4 IHARG 11885C 11886 CHARACTER*4 IDEFCO 11887C 11888 CHARACTER*4 IX1TCO 11889 CHARACTER*4 IX2TCO 11890 CHARACTER*4 IY1TCO 11891 CHARACTER*4 IY2TCO 11892C 11893 CHARACTER*4 IFOUND 11894 CHARACTER*4 IERROR 11895C 11896 CHARACTER*4 IHOLD 11897C 11898C--------------------------------------------------------------------- 11899C 11900 DIMENSION IHARG(*) 11901C 11902C-----COMMON---------------------------------------------------------- 11903C 11904 INCLUDE 'DPCOP2.INC' 11905C 11906C-----START POINT----------------------------------------------------- 11907C 11908 IFOUND='NO' 11909 IERROR='NO' 11910C 11911 IF(NUMARG.LE.0)GOTO1900 11912 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO1090 11913 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 11914 1IHARG(2).EQ.'COLO')GOTO1090 11915 GOTO1900 11916 1090 CONTINUE 11917C 11918C ***************************************************** 11919C ** TREAT THE CASE WHEN ** 11920C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 11921C ***************************************************** 11922C 11923 IF(ICOM.EQ.'XTIC')GOTO1100 11924 GOTO1199 11925C 11926 1100 CONTINUE 11927 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 11928 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 11929 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 11930 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 11931 IF(IHARG(NUMARG).EQ.'COLO')GOTO1150 11932 GOTO1160 11933C 11934 1150 CONTINUE 11935 IHOLD=IDEFCO 11936 GOTO1180 11937C 11938 1160 CONTINUE 11939 IHOLD=IHARG(NUMARG) 11940 GOTO1180 11941C 11942 1180 CONTINUE 11943 IFOUND='YES' 11944 IX1TCO=IHOLD 11945 IX2TCO=IHOLD 11946C 11947 IF(IFEEDB.EQ.'OFF')GOTO1189 11948 WRITE(ICOUT,999) 11949 999 FORMAT(1X) 11950 CALL DPWRST('XXX','BUG ') 11951 WRITE(ICOUT,1181) 11952 1181 FORMAT('THE TIC MARK COLOR (FOR BOTH HORIZONTAL ', 11953 1'FRAME LINES)') 11954 CALL DPWRST('XXX','BUG ') 11955 WRITE(ICOUT,1182)IHOLD 11956 1182 FORMAT('HAS JUST BEEN SET TO ',A4) 11957 CALL DPWRST('XXX','BUG ') 11958 1189 CONTINUE 11959 GOTO1900 11960C 11961 1199 CONTINUE 11962C 11963C ************************************************************** 11964C ** TREAT THE CASE WHEN ** 11965C ** ONLY THE BOTTOM HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 11966C ************************************************************** 11967C 11968 IF(ICOM.EQ.'X1TI')GOTO1200 11969 GOTO1299 11970C 11971 1200 CONTINUE 11972 IF(IHARG(NUMARG).EQ.'ON')GOTO1250 11973 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 11974 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 11975 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 11976 IF(IHARG(NUMARG).EQ.'COLO')GOTO1250 11977 GOTO1260 11978C 11979 1250 CONTINUE 11980 IHOLD=IDEFCO 11981 GOTO1280 11982C 11983 1260 CONTINUE 11984 IHOLD=IHARG(NUMARG) 11985 GOTO1280 11986C 11987 1280 CONTINUE 11988 IFOUND='YES' 11989 IX1TCO=IHOLD 11990C 11991 IF(IFEEDB.EQ.'OFF')GOTO1289 11992 WRITE(ICOUT,999) 11993 CALL DPWRST('XXX','BUG ') 11994 WRITE(ICOUT,1281) 11995 1281 FORMAT('THE TIC MARK COLOR (FOR THE BOTTOM HORIZONTAL ', 11996 1'FRAME LINE)') 11997 CALL DPWRST('XXX','BUG ') 11998 WRITE(ICOUT,1282)IHOLD 11999 1282 FORMAT('HAS JUST BEEN SET TO ',A4) 12000 CALL DPWRST('XXX','BUG ') 12001 1289 CONTINUE 12002 GOTO1900 12003C 12004 1299 CONTINUE 12005C 12006C ************************************************************** 12007C ** TREAT THE CASE WHEN ** 12008C ** ONLY THE TOP HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 12009C ************************************************************** 12010C 12011 IF(ICOM.EQ.'X2TI')GOTO1300 12012 GOTO1399 12013C 12014 1300 CONTINUE 12015 IF(IHARG(NUMARG).EQ.'ON')GOTO1350 12016 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 12017 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 12018 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 12019 IF(IHARG(NUMARG).EQ.'COLO')GOTO1350 12020 GOTO1360 12021C 12022 1350 CONTINUE 12023 IHOLD=IDEFCO 12024 GOTO1380 12025C 12026 1360 CONTINUE 12027 IHOLD=IHARG(NUMARG) 12028 GOTO1380 12029C 12030 1380 CONTINUE 12031 IFOUND='YES' 12032 IX2TCO=IHOLD 12033C 12034 IF(IFEEDB.EQ.'OFF')GOTO1389 12035 WRITE(ICOUT,999) 12036 CALL DPWRST('XXX','BUG ') 12037 WRITE(ICOUT,1381) 12038 1381 FORMAT('THE TIC MARK COLOR (FOR THE TOP HORIZONTAL ', 12039 1'FRAME LINE)') 12040 CALL DPWRST('XXX','BUG ') 12041 WRITE(ICOUT,1382)IHOLD 12042 1382 FORMAT('HAS JUST BEEN SET TO ',A4) 12043 CALL DPWRST('XXX','BUG ') 12044 1389 CONTINUE 12045 GOTO1900 12046C 12047 1399 CONTINUE 12048C 12049C ***************************************************** 12050C ** TREAT THE CASE WHEN ** 12051C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 12052C ***************************************************** 12053C 12054 IF(ICOM.EQ.'YTIC')GOTO1400 12055 GOTO1499 12056C 12057 1400 CONTINUE 12058 IF(IHARG(NUMARG).EQ.'ON')GOTO1450 12059 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 12060 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 12061 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 12062 IF(IHARG(NUMARG).EQ.'COLO')GOTO1450 12063 GOTO1460 12064C 12065 1450 CONTINUE 12066 IHOLD=IDEFCO 12067 GOTO1480 12068C 12069 1460 CONTINUE 12070 IHOLD=IHARG(NUMARG) 12071 GOTO1480 12072C 12073 1480 CONTINUE 12074 IFOUND='YES' 12075 IY1TCO=IHOLD 12076 IY2TCO=IHOLD 12077C 12078 IF(IFEEDB.EQ.'OFF')GOTO1489 12079 WRITE(ICOUT,999) 12080 CALL DPWRST('XXX','BUG ') 12081 WRITE(ICOUT,1481) 12082 1481 FORMAT('THE TIC MARK COLOR (FOR BOTH VERTICAL ', 12083 1'FRAME LINES)') 12084 CALL DPWRST('XXX','BUG ') 12085 WRITE(ICOUT,1482)IHOLD 12086 1482 FORMAT('HAS JUST BEEN SET TO ',A4) 12087 CALL DPWRST('XXX','BUG ') 12088 1489 CONTINUE 12089 GOTO1900 12090C 12091 1499 CONTINUE 12092C 12093C ************************************************************** 12094C ** TREAT THE CASE WHEN ** 12095C ** ONLY THE LEFT VERTICAL TIC MARKS ARE TO BE CHANGED ** 12096C ************************************************************** 12097C 12098 IF(ICOM.EQ.'Y1TI')GOTO1500 12099 GOTO1599 12100C 12101 1500 CONTINUE 12102 IF(IHARG(NUMARG).EQ.'ON')GOTO1550 12103 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 12104 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 12105 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 12106 IF(IHARG(NUMARG).EQ.'COLO')GOTO1550 12107 GOTO1560 12108C 12109 1550 CONTINUE 12110 IHOLD=IDEFCO 12111 GOTO1580 12112C 12113 1560 CONTINUE 12114 IHOLD=IHARG(NUMARG) 12115 GOTO1580 12116C 12117 1580 CONTINUE 12118 IFOUND='YES' 12119 IY1TCO=IHOLD 12120C 12121 IF(IFEEDB.EQ.'OFF')GOTO1589 12122 WRITE(ICOUT,999) 12123 CALL DPWRST('XXX','BUG ') 12124 WRITE(ICOUT,1581) 12125 1581 FORMAT('THE TIC MARK COLOR (FOR THE LEFT VERTICAL ', 12126 1'FRAME LINE)') 12127 CALL DPWRST('XXX','BUG ') 12128 WRITE(ICOUT,1582)IHOLD 12129 1582 FORMAT('HAS JUST BEEN SET TO ',A4) 12130 CALL DPWRST('XXX','BUG ') 12131 1589 CONTINUE 12132 GOTO1900 12133C 12134 1599 CONTINUE 12135C 12136C ************************************************************** 12137C ** TREAT THE CASE WHEN ** 12138C ** ONLY THE RIGHT VERTICAL TIC MARKS ARE TO BE CHANGED ** 12139C ************************************************************** 12140C 12141 IF(ICOM.EQ.'Y2TI')GOTO1600 12142 GOTO1699 12143C 12144 1600 CONTINUE 12145 IF(IHARG(NUMARG).EQ.'ON')GOTO1650 12146 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 12147 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 12148 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 12149 IF(IHARG(NUMARG).EQ.'COLO')GOTO1650 12150 GOTO1660 12151C 12152 1650 CONTINUE 12153 IHOLD=IDEFCO 12154 GOTO1680 12155C 12156 1660 CONTINUE 12157 IHOLD=IHARG(NUMARG) 12158 GOTO1680 12159C 12160 1680 CONTINUE 12161 IFOUND='YES' 12162 IY2TCO=IHOLD 12163C 12164 IF(IFEEDB.EQ.'OFF')GOTO1689 12165 WRITE(ICOUT,999) 12166 CALL DPWRST('XXX','BUG ') 12167 WRITE(ICOUT,1681) 12168 1681 FORMAT('THE TIC MARK COLOR (FOR THE RIGHT VERTICAL ', 12169 1'FRAME LINE)') 12170 CALL DPWRST('XXX','BUG ') 12171 WRITE(ICOUT,1682)IHOLD 12172 1682 FORMAT('HAS JUST BEEN SET TO ',A4) 12173 CALL DPWRST('XXX','BUG ') 12174 1689 CONTINUE 12175 GOTO1900 12176C 12177 1699 CONTINUE 12178C 12179C ***************************************************** 12180C ** TREAT THE CASE WHEN ** 12181C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 12182C ***************************************************** 12183C 12184 IF(ICOM.EQ.'TIC')GOTO1700 12185 IF(ICOM.EQ.'TICS')GOTO1700 12186 IF(ICOM.EQ.'XYTI')GOTO1700 12187 IF(ICOM.EQ.'YXTI')GOTO1700 12188 GOTO1799 12189C 12190 1700 CONTINUE 12191 IF(IHARG(NUMARG).EQ.'ON')GOTO1750 12192 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 12193 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 12194 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 12195 IF(IHARG(NUMARG).EQ.'COLO')GOTO1750 12196 GOTO1760 12197C 12198 1750 CONTINUE 12199 IHOLD=IDEFCO 12200 GOTO1780 12201C 12202 1760 CONTINUE 12203 IHOLD=IHARG(NUMARG) 12204 GOTO1780 12205C 12206 1780 CONTINUE 12207 IFOUND='YES' 12208 IX1TCO=IHOLD 12209 IX2TCO=IHOLD 12210 IY1TCO=IHOLD 12211 IY2TCO=IHOLD 12212C 12213 IF(IFEEDB.EQ.'OFF')GOTO1789 12214 WRITE(ICOUT,999) 12215 CALL DPWRST('XXX','BUG ') 12216 WRITE(ICOUT,1781) 12217 1781 FORMAT('THE TIC MARK COLOR (FOR ALL 4 ', 12218 1'FRAME LINES)') 12219 CALL DPWRST('XXX','BUG ') 12220 WRITE(ICOUT,1782)IHOLD 12221 1782 FORMAT('HAS JUST BEEN SET TO ',A4) 12222 CALL DPWRST('XXX','BUG ') 12223 1789 CONTINUE 12224 GOTO1900 12225C 12226 1799 CONTINUE 12227C 12228 1900 CONTINUE 12229 RETURN 12230 END 12231 SUBROUTINE DPTCDP(ICOM,IHARG,IARG,NUMARG, 12232 1 IDEFDP, 12233 1 IX1ZDP,IX2ZDP,IY1ZDP,IY2ZDP, 12234 1 IFOUND,IERROR) 12235C 12236C PURPOSE--DEFINE THE TIC MARK LABEL DECIMAL PLACES 12237C FOR ANY OF THE 4 FRAME LINES. 12238C SUCH TIC MARK LABEL SWITCHES DESCRIBE 12239C THE NUMBER OF TIC MARK LABEL DECIMAL PLACES ON THE 4 FRAME LINES 12240C THE CONTENTS OF A TIC MARK LABEL DECIMAL PLACE ARE 12241C AN INTEGER NUMBER. 12242C THE TIC MARK LABEL DECIMAL PLACES FOR THE 4 FRAME LINES 12243C ARE CONTAINED IN THE 4 VARIABLES 12244C IX1ZDP,IX2ZDP,IY1ZDP,IY2ZDP 12245C INPUT ARGUMENTS--ICOM 12246C --IHARG (A HOLLERITH VECTOR) 12247C --IARGT (A HOLLERITH VECTOR) 12248C --IARG (AN INTEGER VECTOR) 12249C --NUMARG 12250C --IDEFDP 12251C OUTPUT ARGUMENTS--IX1ZDP = NUM. DEC. FOR BOTTOM HORIZ. TIC LABELS 12252C --IX2ZDP = NUM. DEC. FOR TOP HORIZ. TIC LABELS 12253C --IY1ZDP = NUM. DEC. FOR LEFT VERT. TIC LABELS 12254C --IY2ZDP = NUM. DEC. FOR RIGHT VERT. TIC LABELS 12255C --IFOUND ('YES' OR 'NO' ) 12256C --IERROR ('YES' OR 'NO' ) 12257C WRITTEN BY--JAMES J. FILLIBEN 12258C STATISTICAL ENGINEERING DIVISION 12259C INFORMATION TECHNOLOGY LABORATORY 12260C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 12261C GAITHERSBURG, MD 20899-8980 12262C PHONE--301-975-2899 12263C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12264C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 12265C LANGUAGE--ANSI FORTRAN (1977) 12266C VERSION NUMBER--82/7 12267C ORIGINAL VERSION--OCTOBER 1980. 12268C UPDATED --MAY 1982. 12269C 12270C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12271C 12272 CHARACTER*4 ICOM 12273 CHARACTER*4 IHARG 12274C 12275 CHARACTER*4 IFOUND 12276 CHARACTER*4 IERROR 12277C 12278C--------------------------------------------------------------------- 12279C 12280 DIMENSION IHARG(*) 12281 DIMENSION IARG(*) 12282C 12283C-----COMMON---------------------------------------------------------- 12284C 12285 INCLUDE 'DPCOP2.INC' 12286C 12287C-----START POINT----------------------------------------------------- 12288C 12289 IFOUND='NO' 12290 IERROR='NO' 12291C 12292 IF(IHARG(NUMARG).EQ.'?')GOTO8100 12293C 12294 IF(NUMARG.LE.0)GOTO9000 12295 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DECI')GOTO1090 12296 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLAC')GOTO1090 12297 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'DECI'.AND. 12298 1IHARG(2).EQ.'PLAC')GOTO1090 12299C 12300 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 12301 1IHARG(2).EQ.'DECI')GOTO1090 12302 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 12303 1IHARG(2).EQ.'PLAC')GOTO1090 12304C 12305 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 12306 1IHARG(2).EQ.'DECI')GOTO1090 12307 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LABE'.AND. 12308 1IHARG(2).EQ.'PLAC')GOTO1090 12309C 12310 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 12311 1IHARG(3).EQ.'PLAC')GOTO1090 12312CCCCC JUNE 1994. FOLLOWING 3 LINES ADDED (FOR TIC MARK LABEL DECIMAL) 12313 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 12314 1IHARG(2).EQ.'LABE'.AND. 12315 1IHARG(3).EQ.'DECI')GOTO1090 12316 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'LABEL'.AND. 12317 1IHARG(3).EQ.'PLAC')GOTO1090 12318CCCCC JUNE 1994. FOLLOWING 2 LINES ADDED (FOR TIC MARK LABEL DECIMAL) 12319 IF(NUMARG.GE.4.AND.IHARG(1).EQ.'MARK'.AND. 12320 1IHARG(4).EQ.'PLAC')GOTO1090 12321C 12322 GOTO9000 12323 1090 CONTINUE 12324C 12325C ***************************************************** 12326C ** TREAT THE CASE WHEN ** 12327C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 12328C ***************************************************** 12329C 12330 IF(ICOM.EQ.'XTIC')GOTO1100 12331 GOTO1199 12332C 12333 1100 CONTINUE 12334 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 12335 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 12336 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 12337 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 12338 IF(IHARG(NUMARG).EQ.'DECI')GOTO1150 12339 IF(IHARG(NUMARG).EQ.'PLAC')GOTO1150 12340 GOTO1160 12341C 12342 1150 CONTINUE 12343 IHOLD=IDEFDP 12344 GOTO1180 12345C 12346 1160 CONTINUE 12347 IHOLD=IARG(NUMARG) 12348 GOTO1180 12349C 12350 1180 CONTINUE 12351 IFOUND='YES' 12352 IX1ZDP=IHOLD 12353 IX2ZDP=IHOLD 12354C 12355 IF(IFEEDB.EQ.'OFF')GOTO1189 12356 WRITE(ICOUT,999) 12357 999 FORMAT(1X) 12358 CALL DPWRST('XXX','BUG ') 12359 WRITE(ICOUT,1181) 12360 1181 FORMAT('THE TIC LABEL DECIMALS (FOR BOTH HORIZONTAL ', 12361 1'FRAME LINES)') 12362 CALL DPWRST('XXX','BUG ') 12363 WRITE(ICOUT,1182)IHOLD 12364 1182 FORMAT('HAVE JUST BEEN SET TO ',I8) 12365 CALL DPWRST('XXX','BUG ') 12366 IF(IHOLD.LT.0)WRITE(ICOUT,1183) 12367 1183 FORMAT('THAT IS, THEY WILL FLOAT WITH THE VALUE AND BE NEAT.') 12368 IF(IHOLD.LT.0)CALL DPWRST('XXX','BUG ') 12369 1189 CONTINUE 12370 GOTO9000 12371C 12372 1199 CONTINUE 12373C 12374C ************************************************************** 12375C ** TREAT THE CASE WHEN ** 12376C ** ONLY THE BOTTOM HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 12377C ************************************************************** 12378C 12379 IF(ICOM.EQ.'X1TI')GOTO1200 12380 GOTO1299 12381C 12382 1200 CONTINUE 12383 IF(IHARG(NUMARG).EQ.'ON')GOTO1250 12384 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 12385 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 12386 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 12387 IF(IHARG(NUMARG).EQ.'DECI')GOTO1250 12388 IF(IHARG(NUMARG).EQ.'PLAC')GOTO1250 12389 GOTO1260 12390C 12391 1250 CONTINUE 12392 IHOLD=IDEFDP 12393 GOTO1280 12394C 12395 1260 CONTINUE 12396 IHOLD=IARG(NUMARG) 12397 GOTO1280 12398C 12399 1280 CONTINUE 12400 IFOUND='YES' 12401 IX1ZDP=IHOLD 12402C 12403 IF(IFEEDB.EQ.'OFF')GOTO1289 12404 WRITE(ICOUT,999) 12405 CALL DPWRST('XXX','BUG ') 12406 WRITE(ICOUT,1281) 12407 1281 FORMAT('THE TIC LABEL DECIMALS (FOR THE BOTTOM HORIZONTAL ', 12408 1'FRAME LINE)') 12409 CALL DPWRST('XXX','BUG ') 12410 WRITE(ICOUT,1282)IHOLD 12411 1282 FORMAT('HAVE JUST BEEN SET TO ',I8) 12412 CALL DPWRST('XXX','BUG ') 12413 IF(IHOLD.LT.0)WRITE(ICOUT,1283) 12414 1283 FORMAT('THAT IS, THEY WILL FLOAT WITH THE VALUE AND BE NEAT.') 12415 IF(IHOLD.LT.0)CALL DPWRST('XXX','BUG ') 12416 1289 CONTINUE 12417 GOTO9000 12418C 12419 1299 CONTINUE 12420C 12421C ************************************************************** 12422C ** TREAT THE CASE WHEN ** 12423C ** ONLY THE TOP HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 12424C ************************************************************** 12425C 12426 IF(ICOM.EQ.'X2TI')GOTO1300 12427 GOTO1399 12428C 12429 1300 CONTINUE 12430 IF(IHARG(NUMARG).EQ.'ON')GOTO1350 12431 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 12432 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 12433 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 12434 IF(IHARG(NUMARG).EQ.'DECI')GOTO1350 12435 IF(IHARG(NUMARG).EQ.'PLAC')GOTO1350 12436 GOTO1360 12437C 12438 1350 CONTINUE 12439 IHOLD=IDEFDP 12440 GOTO1380 12441C 12442 1360 CONTINUE 12443 IHOLD=IARG(NUMARG) 12444 GOTO1380 12445C 12446 1380 CONTINUE 12447 IFOUND='YES' 12448 IX2ZDP=IHOLD 12449C 12450 IF(IFEEDB.EQ.'OFF')GOTO1389 12451 WRITE(ICOUT,999) 12452 CALL DPWRST('XXX','BUG ') 12453 WRITE(ICOUT,1381) 12454 1381 FORMAT('THE TIC LABEL DECIMALS (FOR THE TOP HORIZONTAL ', 12455 1'FRAME LINE)') 12456 CALL DPWRST('XXX','BUG ') 12457 WRITE(ICOUT,1382)IHOLD 12458 1382 FORMAT('HAVE JUST BEEN SET TO ',I8) 12459 CALL DPWRST('XXX','BUG ') 12460 IF(IHOLD.LT.0)WRITE(ICOUT,1383) 12461 1383 FORMAT('THAT IS, THEY WILL FLOAT WITH THE VALUE AND BE NEAT.') 12462 IF(IHOLD.LT.0)CALL DPWRST('XXX','BUG ') 12463 1389 CONTINUE 12464 GOTO9000 12465C 12466 1399 CONTINUE 12467C 12468C ***************************************************** 12469C ** TREAT THE CASE WHEN ** 12470C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 12471C ***************************************************** 12472C 12473 IF(ICOM.EQ.'YTIC')GOTO1400 12474 GOTO1499 12475C 12476 1400 CONTINUE 12477 IF(IHARG(NUMARG).EQ.'ON')GOTO1450 12478 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 12479 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 12480 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 12481 IF(IHARG(NUMARG).EQ.'DECI')GOTO1450 12482 IF(IHARG(NUMARG).EQ.'PLAC')GOTO1450 12483 GOTO1460 12484C 12485 1450 CONTINUE 12486 IHOLD=IDEFDP 12487 GOTO1480 12488C 12489 1460 CONTINUE 12490 IHOLD=IARG(NUMARG) 12491 GOTO1480 12492C 12493 1480 CONTINUE 12494 IFOUND='YES' 12495 IY1ZDP=IHOLD 12496 IY2ZDP=IHOLD 12497C 12498 IF(IFEEDB.EQ.'OFF')GOTO1489 12499 WRITE(ICOUT,999) 12500 CALL DPWRST('XXX','BUG ') 12501 WRITE(ICOUT,1481) 12502 1481 FORMAT('THE TIC LABEL DECIMALS (FOR BOTH VERTICAL ', 12503 1'FRAME LINES)') 12504 CALL DPWRST('XXX','BUG ') 12505 WRITE(ICOUT,1482)IHOLD 12506 1482 FORMAT('HAVE JUST BEEN SET TO ',I8) 12507 CALL DPWRST('XXX','BUG ') 12508 IF(IHOLD.LT.0)WRITE(ICOUT,1483) 12509 1483 FORMAT('THAT IS, THEY WILL FLOAT WITH THE VALUE AND BE NEAT.') 12510 IF(IHOLD.LT.0)CALL DPWRST('XXX','BUG ') 12511 1489 CONTINUE 12512 GOTO9000 12513C 12514 1499 CONTINUE 12515C 12516C ************************************************************** 12517C ** TREAT THE CASE WHEN ** 12518C ** ONLY THE LEFT VERTICAL TIC MARKS ARE TO BE CHANGED ** 12519C ************************************************************** 12520C 12521 IF(ICOM.EQ.'Y1TI')GOTO1500 12522 GOTO1599 12523C 12524 1500 CONTINUE 12525 IF(IHARG(NUMARG).EQ.'ON')GOTO1550 12526 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 12527 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 12528 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 12529 IF(IHARG(NUMARG).EQ.'DECI')GOTO1550 12530 IF(IHARG(NUMARG).EQ.'PLAC')GOTO1550 12531 GOTO1560 12532C 12533 1550 CONTINUE 12534 IHOLD=IDEFDP 12535 GOTO1580 12536C 12537 1560 CONTINUE 12538 IHOLD=IARG(NUMARG) 12539 GOTO1580 12540C 12541 1580 CONTINUE 12542 IFOUND='YES' 12543 IY1ZDP=IHOLD 12544C 12545 IF(IFEEDB.EQ.'OFF')GOTO1589 12546 WRITE(ICOUT,999) 12547 CALL DPWRST('XXX','BUG ') 12548 WRITE(ICOUT,1581) 12549 1581 FORMAT('THE TIC LABEL DECIMALS (FOR THE LEFT VERTICAL ', 12550 1'FRAME LINE)') 12551 CALL DPWRST('XXX','BUG ') 12552 WRITE(ICOUT,1582)IHOLD 12553 1582 FORMAT('HAVE JUST BEEN SET TO ',I8) 12554 CALL DPWRST('XXX','BUG ') 12555 IF(IHOLD.LT.0)WRITE(ICOUT,1583) 12556 1583 FORMAT('THAT IS, THEY WILL FLOAT WITH THE VALUE AND BE NEAT.') 12557 IF(IHOLD.LT.0)CALL DPWRST('XXX','BUG ') 12558 1589 CONTINUE 12559 GOTO9000 12560C 12561 1599 CONTINUE 12562C 12563C ************************************************************** 12564C ** TREAT THE CASE WHEN ** 12565C ** ONLY THE RIGHT VERTICAL TIC MARKS ARE TO BE CHANGED ** 12566C ************************************************************** 12567C 12568 IF(ICOM.EQ.'Y2TI')GOTO1600 12569 GOTO1699 12570C 12571 1600 CONTINUE 12572 IF(IHARG(NUMARG).EQ.'ON')GOTO1650 12573 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 12574 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 12575 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 12576 IF(IHARG(NUMARG).EQ.'DECI')GOTO1650 12577 IF(IHARG(NUMARG).EQ.'PLAC')GOTO1650 12578 GOTO1660 12579C 12580 1650 CONTINUE 12581 IHOLD=IDEFDP 12582 GOTO1680 12583C 12584 1660 CONTINUE 12585 IHOLD=IARG(NUMARG) 12586 GOTO1680 12587C 12588 1680 CONTINUE 12589 IFOUND='YES' 12590 IY2ZDP=IHOLD 12591C 12592 IF(IFEEDB.EQ.'OFF')GOTO1689 12593 WRITE(ICOUT,999) 12594 CALL DPWRST('XXX','BUG ') 12595 WRITE(ICOUT,1681) 12596 1681 FORMAT('THE TIC LABEL DECIMALS (FOR THE RIGHT VERTICAL ', 12597 1'FRAME LINE)') 12598 CALL DPWRST('XXX','BUG ') 12599 WRITE(ICOUT,1682)IHOLD 12600 1682 FORMAT('HAVE JUST BEEN SET TO ',I8) 12601 CALL DPWRST('XXX','BUG ') 12602 IF(IHOLD.LT.0)WRITE(ICOUT,1683) 12603 1683 FORMAT('THAT IS, THEY WILL FLOAT WITH THE VALUE AND BE NEAT.') 12604 IF(IHOLD.LT.0)CALL DPWRST('XXX','BUG ') 12605 1689 CONTINUE 12606 GOTO9000 12607C 12608 1699 CONTINUE 12609C 12610C ***************************************************** 12611C ** TREAT THE CASE WHEN ** 12612C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 12613C ***************************************************** 12614C 12615 IF(ICOM.EQ.'TIC')GOTO1700 12616 IF(ICOM.EQ.'TICS')GOTO1700 12617 IF(ICOM.EQ.'XYTI')GOTO1700 12618 IF(ICOM.EQ.'YXTI')GOTO1700 12619 GOTO1799 12620C 12621 1700 CONTINUE 12622 IF(IHARG(NUMARG).EQ.'ON')GOTO1750 12623 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 12624 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 12625 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 12626 IF(IHARG(NUMARG).EQ.'DECI')GOTO1750 12627 IF(IHARG(NUMARG).EQ.'PLAC')GOTO1750 12628 GOTO1760 12629C 12630 1750 CONTINUE 12631 IHOLD=IDEFDP 12632 GOTO1780 12633C 12634 1760 CONTINUE 12635 IHOLD=IARG(NUMARG) 12636 GOTO1780 12637C 12638 1780 CONTINUE 12639 IFOUND='YES' 12640 IX1ZDP=IHOLD 12641 IX2ZDP=IHOLD 12642 IY1ZDP=IHOLD 12643 IY2ZDP=IHOLD 12644C 12645 IF(IFEEDB.EQ.'OFF')GOTO1789 12646 WRITE(ICOUT,999) 12647 CALL DPWRST('XXX','BUG ') 12648 WRITE(ICOUT,1781) 12649 1781 FORMAT('THE TIC LABEL DECIMALS (FOR ALL 4 ', 12650 1'FRAME LINES)') 12651 CALL DPWRST('XXX','BUG ') 12652 WRITE(ICOUT,1782)IHOLD 12653 1782 FORMAT('HAVE JUST BEEN SET TO ',I8) 12654 CALL DPWRST('XXX','BUG ') 12655 IF(IHOLD.LT.0)WRITE(ICOUT,1783) 12656 1783 FORMAT('THAT IS, THEY WILL FLOAT WITH THE VALUE AND BE NEAT.') 12657 IF(IHOLD.LT.0)CALL DPWRST('XXX','BUG ') 12658 1789 CONTINUE 12659 GOTO9000 12660C 12661 1799 CONTINUE 12662 GOTO9000 12663C 12664C ******************************************** 12665C ** STEP 81-- ** 12666C ** TREAT THE ? CASE-- ** 12667C ** DUMP OUT CURRENT AND DEFAULT VALUES. ** 12668C ******************************************** 12669C 12670 8100 CONTINUE 12671 IFOUND='YES' 12672 WRITE(ICOUT,999) 12673 CALL DPWRST('XXX','BUG ') 12674 WRITE(ICOUT,8111) 12675 8111 FORMAT('THE CURRENT NUMBER OF TIC LABEL DECIMAL PLACES IS ') 12676 CALL DPWRST('XXX','BUG ') 12677 WRITE(ICOUT,8112)IX1ZDP 12678 8112 FORMAT(' --X1 (BOTTOM HORIZONTAL) = ',I8) 12679 CALL DPWRST('XXX','BUG ') 12680 WRITE(ICOUT,8113)IX2ZDP 12681 8113 FORMAT(' --X2 (TOP HORIZONTAL) = ',I8) 12682 CALL DPWRST('XXX','BUG ') 12683 WRITE(ICOUT,8114)IY1ZDP 12684 8114 FORMAT(' --Y1 (LEFT VERTICAL ) = ',I8) 12685 CALL DPWRST('XXX','BUG ') 12686 WRITE(ICOUT,8115)IY2ZDP 12687 8115 FORMAT(' --Y2 (RIGHT VERTICAL ) = ',I8) 12688 CALL DPWRST('XXX','BUG ') 12689 WRITE(ICOUT,999) 12690 CALL DPWRST('XXX','BUG ') 12691 WRITE(ICOUT,8116) 12692 8116 FORMAT(' --NEGATIVE VALUES INDICATE THE') 12693 CALL DPWRST('XXX','BUG ') 12694 WRITE(ICOUT,8117) 12695 8117 FORMAT(' NUMBER OF DECIMALS FLOAT AND NEAT') 12696 CALL DPWRST('XXX','BUG ') 12697 WRITE(ICOUT,999) 12698 CALL DPWRST('XXX','BUG ') 12699 WRITE(ICOUT,8121) 12700 8121 FORMAT('THE DEFAULT NUMBER OF TIC LABEL DECIMAL PLACES ARE ') 12701 CALL DPWRST('XXX','BUG ') 12702 WRITE(ICOUT,8122) 12703 8122 FORMAT(' --X1 (BOTTOM HORIZONTAL) = FLOAT & NEAT') 12704 CALL DPWRST('XXX','BUG ') 12705 WRITE(ICOUT,8123) 12706 8123 FORMAT(' --X2 (TOP HORIZONTAL) = FLOAT & NEAT') 12707 CALL DPWRST('XXX','BUG ') 12708 WRITE(ICOUT,8124) 12709 8124 FORMAT(' --Y1 (LEFT VERTICAL ) = FLOAT & NEAT') 12710 CALL DPWRST('XXX','BUG ') 12711 WRITE(ICOUT,8125) 12712 8125 FORMAT(' --Y2 (BOTTOM VERTICAL ) = FLOAT & NEAT') 12713 CALL DPWRST('XXX','BUG ') 12714 GOTO9000 12715C 12716C ***************** 12717C ** STEP 90-- ** 12718C ** EXIT ** 12719C ***************** 12720C 12721 9000 CONTINUE 12722 RETURN 12723 END 12724 SUBROUTINE DPTCJU(ICOM,IHARG,NUMARG, 12725 1IX1TJU,IX2TJU,IY1TJU,IY2TJU, 12726 1IFOUND,IERROR) 12727C 12728C PURPOSE--DEFINE THE TIC MARK JUSTIFICATION SWITCHES 12729C FOR ANY OF THE 4 FRAME LINES. 12730C SUCH TIC MARK SWITCHES DESCRIBE 12731C THE TIC MARK JUSTIFICATION (THRU, IN, OR OUT) ON THE 4 FRAME LINE 12732C THE CONTENTS OF A TIC MARK JUSTIFICATION SWITCH ARE 12733C A JUSTIFICATION (THRU, IN, OR OUT). 12734C THE TIC MARK JUSTIFICATION SWITCHES FOR THE 4 FRAME LINES 12735C ARE CONTAINED IN THE 4 VARIABLES 12736C IX1TJU,IX2TJU,IY1TJU,IY2TJU 12737C INPUT ARGUMENTS--ICOM 12738C --IHARG (A HOLLERITH VECTOR) 12739C --NUMARG 12740C OUTPUT ARGUMENTS--IX1TJU = JUSTIFICATION FOR BOTTOM HORIZ. TICS 12741C --IX2TJU = JUSTIFICATION FOR TOP HORIZ. TICS 12742C --IY1TJU = JUSTIFICATION FOR LEFT VERT. TICS 12743C --IY2TJU = JUSTIFICATION FOR RIGHT VERT. TICS 12744C --IFOUND ('YES' OR 'NO' ) 12745C --IERROR ('YES' OR 'NO' ) 12746C WRITTEN BY--JAMES J. FILLIBEN 12747C STATISTICAL ENGINEERING DIVISION 12748C INFORMATION TECHNOLOGY LABORATORY 12749C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 12750C GAITHERSBURG, MD 20899-8980 12751C PHONE--301-975-2899 12752C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12753C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 12754C LANGUAGE--ANSI FORTRAN (1977) 12755C VERSION NUMBER--82/7 12756C ORIGINAL VERSION--OCTOBER 1980. 12757C UPDATED --MAY 1982. 12758C 12759C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12760C 12761 CHARACTER*4 ICOM 12762 CHARACTER*4 IHARG 12763C 12764 CHARACTER*4 IX1TJU 12765 CHARACTER*4 IX2TJU 12766 CHARACTER*4 IY1TJU 12767 CHARACTER*4 IY2TJU 12768C 12769 CHARACTER*4 IFOUND 12770 CHARACTER*4 IERROR 12771C 12772C--------------------------------------------------------------------- 12773C 12774 DIMENSION IHARG(*) 12775C 12776C-----COMMON---------------------------------------------------------- 12777C 12778 INCLUDE 'DPCOP2.INC' 12779C 12780C-----START POINT----------------------------------------------------- 12781C 12782 IFOUND='NO' 12783 IERROR='NO' 12784C 12785 IF(NUMARG.LE.0)GOTO1900 12786 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'POSI')GOTO1090 12787 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 12788 1IHARG(2).EQ.'POSI')GOTO1090 12789 GOTO1900 12790 1090 CONTINUE 12791C 12792C ***************************************************** 12793C ** TREAT THE CASE WHEN ** 12794C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 12795C ***************************************************** 12796C 12797 IF(ICOM.EQ.'XTIC')GOTO1100 12798 GOTO1199 12799C 12800 1100 CONTINUE 12801 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 12802 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 12803 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 12804 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 12805 IF(IHARG(NUMARG).EQ.'POSI')GOTO1150 12806 IF(IHARG(NUMARG).EQ.'IN')GOTO1130 12807 IF(IHARG(NUMARG).EQ.'INSI')GOTO1130 12808 IF(IHARG(NUMARG).EQ.'OUT')GOTO1140 12809 IF(IHARG(NUMARG).EQ.'OUTS')GOTO1140 12810 IF(IHARG(NUMARG).EQ.'THRO')GOTO1150 12811 IF(IHARG(NUMARG).EQ.'THRU')GOTO1150 12812 IF(IHARG(NUMARG).EQ.'CENT')GOTO1150 12813 IERROR='YES' 12814 GOTO1900 12815C 12816 1130 CONTINUE 12817 IFOUND='YES' 12818 IX1TJU='IN' 12819 IX2TJU='IN' 12820C 12821 IF(IFEEDB.EQ.'OFF')GOTO1139 12822 WRITE(ICOUT,999) 12823 999 FORMAT(1X) 12824 CALL DPWRST('XXX','BUG ') 12825 WRITE(ICOUT,1135) 12826 1135 FORMAT('THE TIC MARK JUSTIFICATION (FOR BOTH HORIZONTAL ', 12827 1'FRAME LINES)') 12828 CALL DPWRST('XXX','BUG ') 12829 WRITE(ICOUT,1136) 12830 1136 FORMAT('HAS JUST BEEN SET TO INSIDE ') 12831 CALL DPWRST('XXX','BUG ') 12832 1139 CONTINUE 12833 GOTO1900 12834C 12835 1140 CONTINUE 12836 IFOUND='YES' 12837 IX1TJU='OUT' 12838 IX2TJU='OUT' 12839C 12840 IF(IFEEDB.EQ.'OFF')GOTO1149 12841 WRITE(ICOUT,999) 12842 CALL DPWRST('XXX','BUG ') 12843 WRITE(ICOUT,1145) 12844 1145 FORMAT('THE TIC MARK JUSTIFICATION (FOR BOTH HORIZONTAL ', 12845 1'FRAME LINES)') 12846 CALL DPWRST('XXX','BUG ') 12847 WRITE(ICOUT,1146) 12848 1146 FORMAT('HAS JUST BEEN SET TO OUTSIDE ') 12849 CALL DPWRST('XXX','BUG ') 12850 1149 CONTINUE 12851 GOTO1900 12852C 12853 1150 CONTINUE 12854 IFOUND='YES' 12855 IX1TJU='THRU' 12856 IX2TJU='THRU' 12857C 12858 IF(IFEEDB.EQ.'OFF')GOTO1159 12859 WRITE(ICOUT,999) 12860 CALL DPWRST('XXX','BUG ') 12861 WRITE(ICOUT,1155) 12862 1155 FORMAT('THE TIC MARK JUSTIFICATION (FOR BOTH HORIZONTAL ', 12863 1'FRAME LINES)') 12864 CALL DPWRST('XXX','BUG ') 12865 WRITE(ICOUT,1156) 12866 1156 FORMAT('HAS JUST BEEN SET TO THROUGH ') 12867 CALL DPWRST('XXX','BUG ') 12868 1159 CONTINUE 12869 GOTO1900 12870C 12871 1199 CONTINUE 12872C 12873C ************************************************************** 12874C ** TREAT THE CASE WHEN ** 12875C ** ONLY THE BOTTOM HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 12876C ************************************************************** 12877C 12878 IF(ICOM.EQ.'X1TI')GOTO1200 12879 GOTO1299 12880C 12881 1200 CONTINUE 12882 IF(IHARG(NUMARG).EQ.'ON')GOTO1250 12883 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 12884 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 12885 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 12886 IF(IHARG(NUMARG).EQ.'POSI')GOTO1250 12887 IF(IHARG(NUMARG).EQ.'IN')GOTO1230 12888 IF(IHARG(NUMARG).EQ.'INSI')GOTO1230 12889 IF(IHARG(NUMARG).EQ.'OUT')GOTO1240 12890 IF(IHARG(NUMARG).EQ.'OUTS')GOTO1240 12891 IF(IHARG(NUMARG).EQ.'THRO')GOTO1250 12892 IF(IHARG(NUMARG).EQ.'THRU')GOTO1250 12893 IF(IHARG(NUMARG).EQ.'CENT')GOTO1250 12894 IERROR='YES' 12895 GOTO1900 12896C 12897 1230 CONTINUE 12898 IFOUND='YES' 12899 IX1TJU='IN' 12900C 12901 IF(IFEEDB.EQ.'OFF')GOTO1239 12902 WRITE(ICOUT,999) 12903 CALL DPWRST('XXX','BUG ') 12904 WRITE(ICOUT,1235) 12905 1235 FORMAT('THE TIC MARK JUSTIFICATION (FOR THE BOTTOM ', 12906 1'HORIZONTAL FRAME LINE)') 12907 CALL DPWRST('XXX','BUG ') 12908 WRITE(ICOUT,1236) 12909 1236 FORMAT('HAS JUST BEEN SET TO INSIDE ') 12910 CALL DPWRST('XXX','BUG ') 12911 1239 CONTINUE 12912 GOTO1900 12913C 12914 1240 CONTINUE 12915 IFOUND='YES' 12916 IX1TJU='OUT' 12917C 12918 IF(IFEEDB.EQ.'OFF')GOTO1249 12919 WRITE(ICOUT,999) 12920 CALL DPWRST('XXX','BUG ') 12921 WRITE(ICOUT,1245) 12922 1245 FORMAT('THE TIC MARK JUSTIFICATION (FOR THE BOTTOM ', 12923 1'HORIZONTAL FRAME LINE)') 12924 CALL DPWRST('XXX','BUG ') 12925 WRITE(ICOUT,1246) 12926 1246 FORMAT('HAS JUST BEEN SET TO OUTSIDE ') 12927 CALL DPWRST('XXX','BUG ') 12928 1249 CONTINUE 12929 GOTO1900 12930C 12931 1250 CONTINUE 12932 IFOUND='YES' 12933 IX1TJU='THRU' 12934C 12935 IF(IFEEDB.EQ.'OFF')GOTO1259 12936 WRITE(ICOUT,999) 12937 CALL DPWRST('XXX','BUG ') 12938 WRITE(ICOUT,1255) 12939 1255 FORMAT('THE TIC MARK JUSTIFICATION (FOR THE BOTTOM ', 12940 1'HORIZONTAL FRAME LINE)') 12941 CALL DPWRST('XXX','BUG ') 12942 WRITE(ICOUT,1256) 12943 1256 FORMAT('HAS JUST BEEN SET TO THROUGH ') 12944 CALL DPWRST('XXX','BUG ') 12945 1259 CONTINUE 12946 GOTO1900 12947C 12948 1299 CONTINUE 12949C 12950C ************************************************************** 12951C ** TREAT THE CASE WHEN ** 12952C ** ONLY THE TOP HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 12953C ************************************************************** 12954C 12955 IF(ICOM.EQ.'X2TI')GOTO1300 12956 GOTO1399 12957C 12958 1300 CONTINUE 12959 IF(IHARG(NUMARG).EQ.'ON')GOTO1350 12960 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 12961 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 12962 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 12963 IF(IHARG(NUMARG).EQ.'POSI')GOTO1350 12964 IF(IHARG(NUMARG).EQ.'IN')GOTO1330 12965 IF(IHARG(NUMARG).EQ.'INSI')GOTO1330 12966 IF(IHARG(NUMARG).EQ.'OUT')GOTO1340 12967 IF(IHARG(NUMARG).EQ.'OUTS')GOTO1340 12968 IF(IHARG(NUMARG).EQ.'THRO')GOTO1350 12969 IF(IHARG(NUMARG).EQ.'THRU')GOTO1350 12970 IF(IHARG(NUMARG).EQ.'CENT')GOTO1350 12971 IERROR='YES' 12972 GOTO1900 12973C 12974 1330 CONTINUE 12975 IFOUND='YES' 12976 IX2TJU='IN' 12977C 12978 IF(IFEEDB.EQ.'OFF')GOTO1339 12979 WRITE(ICOUT,999) 12980 CALL DPWRST('XXX','BUG ') 12981 WRITE(ICOUT,1335) 12982 1335 FORMAT('THE TIC MARK JUSTIFICATION (FOR THE TOP HORIZONTAL ', 12983 1'FRAME LINE)') 12984 CALL DPWRST('XXX','BUG ') 12985 WRITE(ICOUT,1336) 12986 1336 FORMAT('HAS JUST BEEN SET TO INSIDE ') 12987 CALL DPWRST('XXX','BUG ') 12988 1339 CONTINUE 12989 GOTO1900 12990C 12991 1340 CONTINUE 12992 IFOUND='YES' 12993 IX2TJU='OUT' 12994C 12995 IF(IFEEDB.EQ.'OFF')GOTO1349 12996 WRITE(ICOUT,999) 12997 CALL DPWRST('XXX','BUG ') 12998 WRITE(ICOUT,1345) 12999 1345 FORMAT('THE TIC MARK JUSTIFICATION (FOR THE TOP HORIZONTAL ', 13000 1'FRAME LINE)') 13001 CALL DPWRST('XXX','BUG ') 13002 WRITE(ICOUT,1346) 13003 1346 FORMAT('HAS JUST BEEN SET TO OUTSIDE ') 13004 CALL DPWRST('XXX','BUG ') 13005 1349 CONTINUE 13006 GOTO1900 13007C 13008 1350 CONTINUE 13009 IFOUND='YES' 13010 IX2TJU='THRU' 13011C 13012 IF(IFEEDB.EQ.'OFF')GOTO1359 13013 WRITE(ICOUT,999) 13014 CALL DPWRST('XXX','BUG ') 13015 WRITE(ICOUT,1355) 13016 1355 FORMAT('THE TIC MARK JUSTIFICATION (FOR THE TOP HORIZONTAL ', 13017 1'FRAME LINE)') 13018 CALL DPWRST('XXX','BUG ') 13019 WRITE(ICOUT,1356) 13020 1356 FORMAT('HAS JUST BEEN SET TO THROUGH ') 13021 CALL DPWRST('XXX','BUG ') 13022 1359 CONTINUE 13023 GOTO1900 13024C 13025 1399 CONTINUE 13026C 13027C ***************************************************** 13028C ** TREAT THE CASE WHEN ** 13029C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 13030C ***************************************************** 13031C 13032 IF(ICOM.EQ.'YTIC')GOTO1400 13033 GOTO1499 13034C 13035 1400 CONTINUE 13036 IF(IHARG(NUMARG).EQ.'ON')GOTO1450 13037 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 13038 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 13039 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 13040 IF(IHARG(NUMARG).EQ.'POSI')GOTO1450 13041 IF(IHARG(NUMARG).EQ.'IN')GOTO1430 13042 IF(IHARG(NUMARG).EQ.'INSI')GOTO1430 13043 IF(IHARG(NUMARG).EQ.'OUT')GOTO1440 13044 IF(IHARG(NUMARG).EQ.'OUTS')GOTO1440 13045 IF(IHARG(NUMARG).EQ.'THRO')GOTO1450 13046 IF(IHARG(NUMARG).EQ.'THRU')GOTO1450 13047 IF(IHARG(NUMARG).EQ.'CENT')GOTO1450 13048 IERROR='YES' 13049 GOTO1900 13050C 13051 1430 CONTINUE 13052 IFOUND='YES' 13053 IY1TJU='IN' 13054 IY2TJU='IN' 13055C 13056 IF(IFEEDB.EQ.'OFF')GOTO1439 13057 WRITE(ICOUT,999) 13058 CALL DPWRST('XXX','BUG ') 13059 WRITE(ICOUT,1435) 13060 1435 FORMAT('THE TIC MARK JUSTIFICATION (FOR BOTH VERTICAL ', 13061 1'FRAME LINES)') 13062 CALL DPWRST('XXX','BUG ') 13063 WRITE(ICOUT,1436) 13064 1436 FORMAT('HAS JUST BEEN SET TO INSIDE ') 13065 CALL DPWRST('XXX','BUG ') 13066 1439 CONTINUE 13067 GOTO1900 13068C 13069 1440 CONTINUE 13070 IFOUND='YES' 13071 IY1TJU='OUT' 13072 IY2TJU='OUT' 13073C 13074 IF(IFEEDB.EQ.'OFF')GOTO1449 13075 WRITE(ICOUT,999) 13076 CALL DPWRST('XXX','BUG ') 13077 WRITE(ICOUT,1445) 13078 1445 FORMAT('THE TIC MARK JUSTIFICATION (FOR BOTH VERTICAL ', 13079 1'FRAME LINES)') 13080 CALL DPWRST('XXX','BUG ') 13081 WRITE(ICOUT,1446) 13082 1446 FORMAT('HAS JUST BEEN SET TO OUTSIDE ') 13083 CALL DPWRST('XXX','BUG ') 13084 1449 CONTINUE 13085 GOTO1900 13086C 13087 1450 CONTINUE 13088 IFOUND='YES' 13089 IY1TJU='THRU' 13090 IY2TJU='THRU' 13091C 13092 IF(IFEEDB.EQ.'OFF')GOTO1459 13093 WRITE(ICOUT,999) 13094 CALL DPWRST('XXX','BUG ') 13095 WRITE(ICOUT,1455) 13096 1455 FORMAT('THE TIC MARK JUSTIFICATION (FOR BOTH VERTICAL ', 13097 1'FRAME LINES)') 13098 CALL DPWRST('XXX','BUG ') 13099 WRITE(ICOUT,1456) 13100 1456 FORMAT('HAS JUST BEEN SET TO THROUGH ') 13101 CALL DPWRST('XXX','BUG ') 13102 1459 CONTINUE 13103 GOTO1900 13104C 13105 1499 CONTINUE 13106C 13107C ************************************************************** 13108C ** TREAT THE CASE WHEN ** 13109C ** ONLY THE LEFT VERTICAL TIC MARKS ARE TO BE CHANGED ** 13110C ************************************************************** 13111C 13112 IF(ICOM.EQ.'Y1TI')GOTO1500 13113 GOTO1599 13114C 13115 1500 CONTINUE 13116 IF(IHARG(NUMARG).EQ.'ON')GOTO1550 13117 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 13118 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 13119 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 13120 IF(IHARG(NUMARG).EQ.'POSI')GOTO1550 13121 IF(IHARG(NUMARG).EQ.'IN')GOTO1530 13122 IF(IHARG(NUMARG).EQ.'INSI')GOTO1530 13123 IF(IHARG(NUMARG).EQ.'OUT')GOTO1540 13124 IF(IHARG(NUMARG).EQ.'OUTS')GOTO1540 13125 IF(IHARG(NUMARG).EQ.'THRO')GOTO1550 13126 IF(IHARG(NUMARG).EQ.'THRU')GOTO1550 13127 IF(IHARG(NUMARG).EQ.'CENT')GOTO1550 13128 IERROR='YES' 13129 GOTO1900 13130C 13131 1530 CONTINUE 13132 IFOUND='YES' 13133 IY1TJU='IN' 13134C 13135 IF(IFEEDB.EQ.'OFF')GOTO1539 13136 WRITE(ICOUT,999) 13137 CALL DPWRST('XXX','BUG ') 13138 WRITE(ICOUT,1535) 13139 1535 FORMAT('THE TIC MARK JUSTIFICATION (FOR THE LEFT VERTICAL ', 13140 1'FRAME LINE)') 13141 CALL DPWRST('XXX','BUG ') 13142 WRITE(ICOUT,1536) 13143 1536 FORMAT('HAS JUST BEEN SET TO INSIDE ') 13144 CALL DPWRST('XXX','BUG ') 13145 1539 CONTINUE 13146 GOTO1900 13147C 13148 1540 CONTINUE 13149 IFOUND='YES' 13150 IY1TJU='OUT' 13151C 13152 IF(IFEEDB.EQ.'OFF')GOTO1549 13153 WRITE(ICOUT,999) 13154 CALL DPWRST('XXX','BUG ') 13155 WRITE(ICOUT,1545) 13156 1545 FORMAT('THE TIC MARK JUSTIFICATION (FOR THE LEFT VERTICAL ', 13157 1'FRAME LINE)') 13158 CALL DPWRST('XXX','BUG ') 13159 WRITE(ICOUT,1546) 13160 1546 FORMAT('HAS JUST BEEN SET TO OUTSIDE ') 13161 CALL DPWRST('XXX','BUG ') 13162 1549 CONTINUE 13163 GOTO1900 13164C 13165 1550 CONTINUE 13166 IFOUND='YES' 13167 IY1TJU='THRU' 13168C 13169 IF(IFEEDB.EQ.'OFF')GOTO1559 13170 WRITE(ICOUT,999) 13171 CALL DPWRST('XXX','BUG ') 13172 WRITE(ICOUT,1555) 13173 1555 FORMAT('THE TIC MARK JUSTIFICATION (FOR THE LEFT VERTICAL ', 13174 1'FRAME LINE)') 13175 CALL DPWRST('XXX','BUG ') 13176 WRITE(ICOUT,1556) 13177 1556 FORMAT('HAS JUST BEEN SET TO THROUGH ') 13178 CALL DPWRST('XXX','BUG ') 13179 1559 CONTINUE 13180 GOTO1900 13181C 13182 1599 CONTINUE 13183C 13184C ************************************************************** 13185C ** TREAT THE CASE WHEN ** 13186C ** ONLY THE RIGHT VERTICAL TIC MARKS ARE TO BE CHANGED ** 13187C ************************************************************** 13188C 13189 IF(ICOM.EQ.'Y2TI')GOTO1600 13190 GOTO1699 13191C 13192 1600 CONTINUE 13193 IF(IHARG(NUMARG).EQ.'ON')GOTO1650 13194 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 13195 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 13196 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 13197 IF(IHARG(NUMARG).EQ.'POSI')GOTO1650 13198 IF(IHARG(NUMARG).EQ.'IN')GOTO1630 13199 IF(IHARG(NUMARG).EQ.'INSI')GOTO1630 13200 IF(IHARG(NUMARG).EQ.'OUT')GOTO1640 13201 IF(IHARG(NUMARG).EQ.'OUTS')GOTO1640 13202 IF(IHARG(NUMARG).EQ.'THRO')GOTO1650 13203 IF(IHARG(NUMARG).EQ.'THRU')GOTO1650 13204 IF(IHARG(NUMARG).EQ.'CENT')GOTO1650 13205 IERROR='YES' 13206 GOTO1900 13207C 13208 1630 CONTINUE 13209 IFOUND='YES' 13210 IY2TJU='IN' 13211C 13212 IF(IFEEDB.EQ.'OFF')GOTO1639 13213 WRITE(ICOUT,999) 13214 CALL DPWRST('XXX','BUG ') 13215 WRITE(ICOUT,1635) 13216 1635 FORMAT('THE TIC MARK JUSTIFICATION (FOR THE RIGHT VERTICAL ', 13217 1'FRAME LINE)') 13218 CALL DPWRST('XXX','BUG ') 13219 WRITE(ICOUT,1636) 13220 1636 FORMAT('HAS JUST BEEN SET TO INSIDE ') 13221 CALL DPWRST('XXX','BUG ') 13222 1639 CONTINUE 13223 GOTO1900 13224C 13225 1640 CONTINUE 13226 IFOUND='YES' 13227 IY2TJU='OUT' 13228C 13229 IF(IFEEDB.EQ.'OFF')GOTO1649 13230 WRITE(ICOUT,999) 13231 CALL DPWRST('XXX','BUG ') 13232 WRITE(ICOUT,1645) 13233 1645 FORMAT('THE TIC MARK JUSTIFICATION (FOR THE RIGHT VERTICAL ', 13234 1'FRAME LINE)') 13235 CALL DPWRST('XXX','BUG ') 13236 WRITE(ICOUT,1646) 13237 1646 FORMAT('HAS JUST BEEN SET TO OUTSIDE ') 13238 CALL DPWRST('XXX','BUG ') 13239 1649 CONTINUE 13240 GOTO1900 13241C 13242 1650 CONTINUE 13243 IFOUND='YES' 13244 IY2TJU='THRU' 13245C 13246 IF(IFEEDB.EQ.'OFF')GOTO1659 13247 WRITE(ICOUT,999) 13248 CALL DPWRST('XXX','BUG ') 13249 WRITE(ICOUT,1655) 13250 1655 FORMAT('THE TIC MARK JUSTIFICATION (FOR THE RIGHT VERTICAL ', 13251 1'FRAME LINE)') 13252 CALL DPWRST('XXX','BUG ') 13253 WRITE(ICOUT,1656) 13254 1656 FORMAT('HAS JUST BEEN SET TO THROUGH ') 13255 CALL DPWRST('XXX','BUG ') 13256 1659 CONTINUE 13257 GOTO1900 13258C 13259 1699 CONTINUE 13260C 13261C ***************************************************** 13262C ** TREAT THE CASE WHEN ** 13263C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 13264C ***************************************************** 13265C 13266 IF(ICOM.EQ.'TIC')GOTO1700 13267 IF(ICOM.EQ.'TICS')GOTO1700 13268 IF(ICOM.EQ.'XYTI')GOTO1700 13269 IF(ICOM.EQ.'YXTI')GOTO1700 13270 GOTO1799 13271C 13272 1700 CONTINUE 13273 IF(IHARG(NUMARG).EQ.'ON')GOTO1750 13274 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 13275 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 13276 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 13277 IF(IHARG(NUMARG).EQ.'POSI')GOTO1750 13278 IF(IHARG(NUMARG).EQ.'IN')GOTO1730 13279 IF(IHARG(NUMARG).EQ.'INSI')GOTO1730 13280 IF(IHARG(NUMARG).EQ.'OUT')GOTO1740 13281 IF(IHARG(NUMARG).EQ.'OUTS')GOTO1740 13282 IF(IHARG(NUMARG).EQ.'THRO')GOTO1750 13283 IF(IHARG(NUMARG).EQ.'THRU')GOTO1750 13284 IF(IHARG(NUMARG).EQ.'CENT')GOTO1750 13285 IERROR='YES' 13286 GOTO1900 13287C 13288 1730 CONTINUE 13289 IFOUND='YES' 13290 IX1TJU='IN' 13291 IX2TJU='IN' 13292 IY1TJU='IN' 13293 IY2TJU='IN' 13294C 13295 IF(IFEEDB.EQ.'OFF')GOTO1739 13296 WRITE(ICOUT,999) 13297 CALL DPWRST('XXX','BUG ') 13298 WRITE(ICOUT,1735) 13299 1735 FORMAT('THE TIC MARKS (FOR ALL 4 ', 13300 1'FRAME LINES)') 13301 CALL DPWRST('XXX','BUG ') 13302 WRITE(ICOUT,1736) 13303 1736 FORMAT('HAS JUST BEEN SET TO INSIDE ') 13304 CALL DPWRST('XXX','BUG ') 13305 1739 CONTINUE 13306 GOTO1900 13307C 13308 1740 CONTINUE 13309 IFOUND='YES' 13310 IX1TJU='OUT' 13311 IX2TJU='OUT' 13312 IY1TJU='OUT' 13313 IY2TJU='OUT' 13314C 13315 IF(IFEEDB.EQ.'OFF')GOTO1749 13316 WRITE(ICOUT,999) 13317 CALL DPWRST('XXX','BUG ') 13318 WRITE(ICOUT,1745) 13319 1745 FORMAT('THE TIC MARKS (FOR ALL 4 ', 13320 1'FRAME LINES)') 13321 CALL DPWRST('XXX','BUG ') 13322 WRITE(ICOUT,1746) 13323 1746 FORMAT('HAS JUST BEEN SET TO OUTSIDE ') 13324 CALL DPWRST('XXX','BUG ') 13325 1749 CONTINUE 13326 GOTO1900 13327C 13328 1750 CONTINUE 13329 IFOUND='YES' 13330 IX1TJU='THRU' 13331 IX2TJU='THRU' 13332 IY1TJU='THRU' 13333 IY2TJU='THRU' 13334C 13335 IF(IFEEDB.EQ.'OFF')GOTO1759 13336 WRITE(ICOUT,999) 13337 CALL DPWRST('XXX','BUG ') 13338 WRITE(ICOUT,1755) 13339 1755 FORMAT('THE TIC MARKS (FOR ALL 4 ', 13340 1'FRAME LINES)') 13341 CALL DPWRST('XXX','BUG ') 13342 WRITE(ICOUT,1756) 13343 1756 FORMAT('HAS JUST BEEN SET TO THROUGH ') 13344 CALL DPWRST('XXX','BUG ') 13345 1759 CONTINUE 13346 GOTO1900 13347C 13348 1799 CONTINUE 13349C 13350 1900 CONTINUE 13351 RETURN 13352 END 13353 SUBROUTINE DPTCOF(ICOM,IHARG,IARGT,ARG,NUMARG, 13354 1DEFTOF,IDEFTU, 13355 1ITICUN, 13356 1PX1TOL,PX2TOL,PY1TOB,PY2TOB, 13357 1PX1TOR,PX2TOR,PY1TOT,PY2TOT, 13358 1IFOUND,IERROR) 13359C 13360C PURPOSE--DEFINE THE TIC MARK OFFSETS 13361C FOR ANY OF THE 4 FRAME LINES. 13362C SUCH TIC MARK OFFSETS DEFINE THE DISTANCE (IN EITHER 13363C DATA UNITS OR DATAPLOT PERCENT UNITS) FROM THE FIRST OR 13364C LAST TIC MARK TO THE FRAME LIMIT. NOTE THAT THIS VALUE 13365C WILL BE ADDED TO THE CURRENT DATA LIMITS (EITHER DEFINED 13366C VIA THE LIMITS COMMAND OR AS AUTOMATICALLY DETERMINED 13367C BY DATAPLOT). 13368C INPUT ARGUMENTS--ICOM 13369C --IHARG (A HOLLERITH VECTOR) 13370C --IARGT (A HOLLERITH VECTOR) 13371C --ARG (A FLOATING POINT VECTOR) 13372C --NUMARG 13373C --DEFTOF = DEFAULT OFFSET 13374C --IDEFTU = DEFAULT TIC UNITS 13375C OUTPUT ARGUMENTS-- 13376C --PX1TOL = BOTTOM HORIZONTAL TIC LEFT OFFSET 13377C --PX2TOL = TOP HORIZONTAL TIC LEFT OFFSET 13378C --PY1TOB = LEFT VERTICAL TIC BOTTOM OFFSET 13379C --PY2TOB = RIGHT VERTICAL TIC BOTTOM OFFSET 13380C --PX1TOL = BOTTOM HORIZONTAL TIC LEFT OFFSET 13381C --PX2TOL = TOP HORIZONTAL TIC LEFT OFFSET 13382C --PY1TOB = LEFT VERTICAL TIC BOTTOM OFFSET 13383C --PY2TOB = RIGHT VERTICAL TIC BOTTOM OFFSET 13384C --IFOUND ('YES' OR 'NO' ) 13385C --IERROR ('YES' OR 'NO' ) 13386C WRITTEN BY--JAMES J. FILLIBEN 13387C STATISTICAL ENGINEERING DIVISION 13388C INFORMATION TECHNOLOGY LABORATORY 13389C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13390C GAITHERSBURG, MD 20899-8980 13391C PHONE--301-975-2899 13392C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13393C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13394C LANGUAGE--ANSI FORTRAN (1977) 13395C VERSION NUMBER--90/5 13396C ORIGINAL VERSION--MAY 1990. 13397C UPDATED --OCTOBER 1991. INSERT FEEDBACK OFF JUMP 13398C 13399C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13400C 13401 CHARACTER*4 ICOM 13402 CHARACTER*4 IHARG 13403 CHARACTER*4 IARGT 13404 CHARACTER*4 ITICUN 13405 CHARACTER*4 IDEFTU 13406 CHARACTER*4 IFOUND 13407 CHARACTER*4 IERROR 13408C 13409C--------------------------------------------------------------------- 13410C 13411 DIMENSION IHARG(*) 13412 DIMENSION IARGT(*) 13413 DIMENSION ARG(*) 13414C 13415C-----COMMON---------------------------------------------------------- 13416C 13417 INCLUDE 'DPCOP2.INC' 13418C 13419C-----START POINT----------------------------------------------------- 13420C 13421 IFOUND='NO' 13422 IERROR='NO' 13423C 13424 IF(NUMARG.LE.0)GOTO1900 13425 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'OFFS'.AND. 13426 1IHARG(2).EQ.'UNIT')GOTO2090 13427 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MARK'.AND. 13428 1IHARG(2).EQ.'OFFS'.AND.IHARG(3).EQ.'UNIT')GOTO2090 13429 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'OFFS')GOTO1090 13430 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 13431 1IHARG(2).EQ.'OFFS')GOTO1090 13432 GOTO1900 13433C 13434 1090 CONTINUE 13435 IFOUND='YES' 13436C 13437C ***************************************************** 13438C ** TREAT THE CASE WHEN ** 13439C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 13440C ***************************************************** 13441C 13442 IF(ICOM.EQ.'XTIC')GOTO1100 13443 GOTO1199 13444C 13445 1100 CONTINUE 13446 ILEFT=2 13447 IF(IHARG(2).EQ.'OFFS')ILEFT=3 13448 IRIGHT=ILEFT+1 13449 IF(ILEFT.GT.NUMARG)ILEFT=0 13450 IF(IRIGHT.GT.NUMARG)IRIGHT=0 13451C 13452C ***************************************************** 13453C ** TREAT THE LEFT OFFSET ** 13454C ** NO ARGUMENT WILL SET THE DEFAULT ** 13455C ***************************************************** 13456C 13457 IF(ILEFT.EQ.0)GOTO1110 13458 IF(IHARG(ILEFT).EQ.'ON')GOTO1110 13459 IF(IHARG(ILEFT).EQ.'OFF')GOTO1110 13460 IF(IHARG(ILEFT).EQ.'AUTO')GOTO1110 13461 IF(IHARG(ILEFT).EQ.'DEFA')GOTO1110 13462 IF(IHARG(ILEFT).EQ.'FLOA')GOTO1110 13463 IF(IARGT(ILEFT).EQ.'NUMB')GOTO1120 13464 IERROR='YES' 13465 GOTO1900 13466C 13467 1110 CONTINUE 13468 HOLD=DEFTOF 13469 GOTO1140 13470C 13471 1120 CONTINUE 13472 HOLD=ARG(ILEFT) 13473 GOTO1140 13474C 13475 1140 CONTINUE 13476 IFOUND='YES' 13477 HOLD=ABS(HOLD) 13478 PX1TOL=HOLD 13479 PX2TOL=HOLD 13480C 13481 IF(IFEEDB.EQ.'OFF')GOTO1149 13482 WRITE(ICOUT,999) 13483 999 FORMAT(1X) 13484 CALL DPWRST('XXX','BUG ') 13485 WRITE(ICOUT,1141) 13486 1141 FORMAT('THE TIC MARK LEFT OFFSET (FOR BOTH HORIZONTAL ', 13487 1'FRAME LINES)') 13488 CALL DPWRST('XXX','BUG ') 13489 WRITE(ICOUT,1142)HOLD 13490 1142 FORMAT('HAS JUST BEEN SET TO ',E15.7) 13491 CALL DPWRST('XXX','BUG ') 13492 1149 CONTINUE 13493C 13494C ***************************************************** 13495C ** TREAT THE RIGHT OFFSET ** 13496C ** NO ARGUMENT WILL LEAVE THE CURRENT VALUE ** 13497C ***************************************************** 13498C 13499 IF(IRIGHT.EQ.0)GOTO1160 13500 IF(IHARG(IRIGHT).EQ.'ON')GOTO1170 13501 IF(IHARG(IRIGHT).EQ.'OFF')GOTO1170 13502 IF(IHARG(IRIGHT).EQ.'AUTO')GOTO1170 13503 IF(IHARG(IRIGHT).EQ.'DEFA')GOTO1170 13504 IF(IHARG(IRIGHT).EQ.'FLOA')GOTO1170 13505 IF(IARGT(IRIGHT).EQ.'NUMB')GOTO1180 13506 IERROR='YES' 13507 GOTO1900 13508C 13509 1160 CONTINUE 13510 HOLD=PX1TOR 13511 GOTO1190 13512C 13513 1170 CONTINUE 13514 HOLD=DEFTOF 13515 GOTO1190 13516C 13517 1180 CONTINUE 13518 HOLD=ARG(IRIGHT) 13519 GOTO1190 13520C 13521 1190 CONTINUE 13522 IFOUND='YES' 13523 HOLD=ABS(HOLD) 13524 PX1TOR=HOLD 13525 PX2TOR=HOLD 13526C 13527 IF(IFEEDB.EQ.'OFF')GOTO1197 13528 WRITE(ICOUT,999) 13529 CALL DPWRST('XXX','BUG ') 13530 WRITE(ICOUT,1191) 13531 1191 FORMAT('THE TIC MARK RIGHT OFFSET (FOR BOTH HORIZONTAL ', 13532 1'FRAME LINES)') 13533 CALL DPWRST('XXX','BUG ') 13534 WRITE(ICOUT,1192)HOLD 13535 1192 FORMAT('HAS JUST BEEN SET TO ',E15.7) 13536 CALL DPWRST('XXX','BUG ') 13537C 13538 1197 CONTINUE 13539C 13540 GOTO1900 13541C 13542 1199 CONTINUE 13543C 13544C ************************************************************** 13545C ** TREAT THE CASE WHEN ** 13546C ** ONLY THE BOTTOM HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 13547C ************************************************************** 13548C 13549 IF(ICOM.EQ.'X1TI')GOTO1200 13550 GOTO1299 13551C 13552 1200 CONTINUE 13553C 13554 ILEFT=2 13555 IF(IHARG(2).EQ.'OFFS')ILEFT=3 13556 IRIGHT=ILEFT+1 13557 IF(ILEFT.GT.NUMARG)ILEFT=0 13558 IF(IRIGHT.GT.NUMARG)IRIGHT=0 13559C 13560C ***************************************************** 13561C ** TREAT THE LEFT OFFSET ** 13562C ** NO ARGUMENT WILL SET THE DEFAULT ** 13563C ***************************************************** 13564C 13565 IF(ILEFT.EQ.0)GOTO1210 13566 IF(IHARG(ILEFT).EQ.'ON')GOTO1210 13567 IF(IHARG(ILEFT).EQ.'OFF')GOTO1210 13568 IF(IHARG(ILEFT).EQ.'AUTO')GOTO1210 13569 IF(IHARG(ILEFT).EQ.'DEFA')GOTO1210 13570 IF(IHARG(ILEFT).EQ.'FLOA')GOTO1210 13571 IF(IARGT(ILEFT).EQ.'NUMB')GOTO1220 13572 IERROR='YES' 13573 GOTO1900 13574C 13575 1210 CONTINUE 13576 HOLD=DEFTOF 13577 GOTO1240 13578C 13579 1220 CONTINUE 13580 HOLD=ARG(ILEFT) 13581 GOTO1240 13582C 13583 1240 CONTINUE 13584 IFOUND='YES' 13585 HOLD=ABS(HOLD) 13586 PX1TOL=HOLD 13587C 13588 IF(IFEEDB.EQ.'OFF')GOTO1249 13589 WRITE(ICOUT,999) 13590 CALL DPWRST('XXX','BUG ') 13591 WRITE(ICOUT,1241) 13592 1241 FORMAT('THE TIC MARK LEFT OFFSET (FOR BOTTOM HORIZONTAL ', 13593 1'FRAME LINE)') 13594 CALL DPWRST('XXX','BUG ') 13595 WRITE(ICOUT,1242)HOLD 13596 1242 FORMAT('HAS JUST BEEN SET TO ',E15.7) 13597 CALL DPWRST('XXX','BUG ') 13598 1249 CONTINUE 13599C 13600C ***************************************************** 13601C ** TREAT THE RIGHT OFFSET ** 13602C ** NO ARGUMENT WILL LEAVE THE CURRENT VALUE ** 13603C ***************************************************** 13604C 13605 IF(IRIGHT.EQ.0)GOTO1260 13606 IF(IHARG(IRIGHT).EQ.'ON')GOTO1270 13607 IF(IHARG(IRIGHT).EQ.'OFF')GOTO1270 13608 IF(IHARG(IRIGHT).EQ.'AUTO')GOTO1270 13609 IF(IHARG(IRIGHT).EQ.'DEFA')GOTO1270 13610 IF(IHARG(IRIGHT).EQ.'FLOA')GOTO1270 13611 IF(IARGT(IRIGHT).EQ.'NUMB')GOTO1280 13612 IERROR='YES' 13613 GOTO1900 13614C 13615 1260 CONTINUE 13616 HOLD=PX2TOR 13617 GOTO1290 13618C 13619 1270 CONTINUE 13620 HOLD=DEFTOF 13621 GOTO1290 13622C 13623 1280 CONTINUE 13624 HOLD=ARG(IRIGHT) 13625 GOTO1290 13626C 13627 1290 CONTINUE 13628 IFOUND='YES' 13629 HOLD=ABS(HOLD) 13630 PX1TOR=HOLD 13631C 13632 IF(IFEEDB.EQ.'OFF')GOTO1297 13633 WRITE(ICOUT,999) 13634 CALL DPWRST('XXX','BUG ') 13635 WRITE(ICOUT,1291) 13636 1291 FORMAT('THE TIC MARK RIGHT OFFSET (FOR BOTTOM HORIZONTAL ', 13637 1'FRAME LINES)') 13638 CALL DPWRST('XXX','BUG ') 13639 WRITE(ICOUT,1292)HOLD 13640 1292 FORMAT('HAS JUST BEEN SET TO ',E15.7) 13641 CALL DPWRST('XXX','BUG ') 13642C 13643 1297 CONTINUE 13644C 13645 GOTO1900 13646C 13647 1299 CONTINUE 13648C 13649C ************************************************************** 13650C ** TREAT THE CASE WHEN ** 13651C ** ONLY THE TOP HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 13652C ************************************************************** 13653C 13654 IF(ICOM.EQ.'X2TI')GOTO1300 13655 GOTO1399 13656C 13657 1300 CONTINUE 13658C 13659 ILEFT=2 13660 IF(IHARG(2).EQ.'OFFS')ILEFT=3 13661 IRIGHT=ILEFT+1 13662 IF(ILEFT.GT.NUMARG)ILEFT=0 13663 IF(IRIGHT.GT.NUMARG)IRIGHT=0 13664C 13665C ***************************************************** 13666C ** TREAT THE LEFT OFFSET ** 13667C ** NO ARGUMENT WILL SET THE DEFAULT ** 13668C ***************************************************** 13669C 13670 IF(ILEFT.EQ.0)GOTO1310 13671 IF(IHARG(ILEFT).EQ.'ON')GOTO1310 13672 IF(IHARG(ILEFT).EQ.'OFF')GOTO1310 13673 IF(IHARG(ILEFT).EQ.'AUTO')GOTO1310 13674 IF(IHARG(ILEFT).EQ.'DEFA')GOTO1310 13675 IF(IHARG(ILEFT).EQ.'FLOA')GOTO1310 13676 IF(IARGT(ILEFT).EQ.'NUMB')GOTO1320 13677 IERROR='YES' 13678 GOTO1900 13679C 13680 1310 CONTINUE 13681 HOLD=DEFTOF 13682 GOTO1340 13683C 13684 1320 CONTINUE 13685 HOLD=ARG(ILEFT) 13686 GOTO1340 13687C 13688 1340 CONTINUE 13689 IFOUND='YES' 13690 HOLD=ABS(HOLD) 13691 PX2TOL=HOLD 13692C 13693 IF(IFEEDB.EQ.'OFF')GOTO1349 13694 WRITE(ICOUT,999) 13695 CALL DPWRST('XXX','BUG ') 13696 WRITE(ICOUT,1341) 13697 1341 FORMAT('THE TIC MARK LEFT OFFSET (FOR TOP HORIZONTAL ', 13698 1'FRAME LINE)') 13699 CALL DPWRST('XXX','BUG ') 13700 WRITE(ICOUT,1342)HOLD 13701 1342 FORMAT('HAS JUST BEEN SET TO ',E15.7) 13702 CALL DPWRST('XXX','BUG ') 13703 1349 CONTINUE 13704C 13705C ***************************************************** 13706C ** TREAT THE RIGHT OFFSET ** 13707C ** NO ARGUMENT WILL LEAVE THE CURRENT VALUE ** 13708C ***************************************************** 13709C 13710 IF(IRIGHT.EQ.0)GOTO1360 13711 IF(IHARG(IRIGHT).EQ.'ON')GOTO1370 13712 IF(IHARG(IRIGHT).EQ.'OFF')GOTO1370 13713 IF(IHARG(IRIGHT).EQ.'AUTO')GOTO1370 13714 IF(IHARG(IRIGHT).EQ.'DEFA')GOTO1370 13715 IF(IHARG(IRIGHT).EQ.'FLOA')GOTO1370 13716 IF(IARGT(IRIGHT).EQ.'NUMB')GOTO1380 13717 IERROR='YES' 13718 GOTO1900 13719C 13720 1360 CONTINUE 13721 HOLD=PX2TOR 13722 GOTO1390 13723C 13724 1370 CONTINUE 13725 HOLD=DEFTOF 13726 GOTO1390 13727C 13728 1380 CONTINUE 13729 HOLD=ARG(IRIGHT) 13730 GOTO1390 13731C 13732 1390 CONTINUE 13733 IFOUND='YES' 13734 HOLD=ABS(HOLD) 13735 PX2TOR=HOLD 13736C 13737 IF(IFEEDB.EQ.'OFF')GOTO1397 13738 WRITE(ICOUT,999) 13739 CALL DPWRST('XXX','BUG ') 13740 WRITE(ICOUT,1391) 13741 1391 FORMAT('THE TIC MARK RIGHT OFFSET (FOR TOP HORIZONTAL ', 13742 1'FRAME LINES)') 13743 CALL DPWRST('XXX','BUG ') 13744 WRITE(ICOUT,1392)HOLD 13745 1392 FORMAT('HAS JUST BEEN SET TO ',E15.7) 13746 CALL DPWRST('XXX','BUG ') 13747C 13748 1397 CONTINUE 13749C 13750 GOTO1900 13751C 13752 1399 CONTINUE 13753C 13754C ***************************************************** 13755C ** TREAT THE CASE WHEN ** 13756C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 13757C ***************************************************** 13758C 13759 IF(ICOM.EQ.'YTIC')GOTO1400 13760 GOTO1499 13761C 13762 1400 CONTINUE 13763C 13764 ILEFT=2 13765 IF(IHARG(2).EQ.'OFFS')ILEFT=3 13766 IRIGHT=ILEFT+1 13767 IF(ILEFT.GT.NUMARG)ILEFT=0 13768 IF(IRIGHT.GT.NUMARG)IRIGHT=0 13769C 13770C ***************************************************** 13771C ** TREAT THE BOTTOM OFFSET ** 13772C ** NO ARGUMENT WILL SET THE DEFAULT ** 13773C ***************************************************** 13774C 13775 IF(ILEFT.EQ.0)GOTO1410 13776 IF(IHARG(ILEFT).EQ.'ON')GOTO1410 13777 IF(IHARG(ILEFT).EQ.'OFF')GOTO1410 13778 IF(IHARG(ILEFT).EQ.'AUTO')GOTO1410 13779 IF(IHARG(ILEFT).EQ.'DEFA')GOTO1410 13780 IF(IHARG(ILEFT).EQ.'FLOA')GOTO1410 13781 IF(IARGT(ILEFT).EQ.'NUMB')GOTO1420 13782 IERROR='YES' 13783 GOTO1900 13784C 13785 1410 CONTINUE 13786 HOLD=DEFTOF 13787 GOTO1440 13788C 13789 1420 CONTINUE 13790 HOLD=ARG(ILEFT) 13791 GOTO1440 13792C 13793 1440 CONTINUE 13794 IFOUND='YES' 13795 HOLD=ABS(HOLD) 13796 PY1TOB=HOLD 13797 PY2TOB=HOLD 13798C 13799 IF(IFEEDB.EQ.'OFF')GOTO1449 13800 WRITE(ICOUT,999) 13801 CALL DPWRST('XXX','BUG ') 13802 WRITE(ICOUT,1441) 13803 1441 FORMAT('THE TIC MARK BOTTOM OFFSET (FOR BOTH VERTICAL ', 13804 1'FRAME LINES)') 13805 CALL DPWRST('XXX','BUG ') 13806 WRITE(ICOUT,1442)HOLD 13807 1442 FORMAT('HAS JUST BEEN SET TO ',E15.7) 13808 CALL DPWRST('XXX','BUG ') 13809 1449 CONTINUE 13810C 13811C ***************************************************** 13812C ** TREAT THE TOP OFFSET ** 13813C ** NO ARGUMENT WILL LEAVE THE CURRENT VALUE ** 13814C ***************************************************** 13815C 13816 IF(IRIGHT.EQ.0)GOTO1460 13817 IF(IHARG(IRIGHT).EQ.'ON')GOTO1470 13818 IF(IHARG(IRIGHT).EQ.'OFF')GOTO1470 13819 IF(IHARG(IRIGHT).EQ.'AUTO')GOTO1470 13820 IF(IHARG(IRIGHT).EQ.'DEFA')GOTO1470 13821 IF(IHARG(IRIGHT).EQ.'FLOA')GOTO1470 13822 IF(IARGT(IRIGHT).EQ.'NUMB')GOTO1480 13823 IERROR='YES' 13824 GOTO1900 13825C 13826 1460 CONTINUE 13827 HOLD=PY1TOT 13828 GOTO1490 13829C 13830 1470 CONTINUE 13831 HOLD=DEFTOF 13832 GOTO1490 13833C 13834 1480 CONTINUE 13835 HOLD=ARG(IRIGHT) 13836 GOTO1490 13837C 13838 1490 CONTINUE 13839 IFOUND='YES' 13840 HOLD=ABS(HOLD) 13841 PY1TOT=HOLD 13842 PY2TOT=HOLD 13843C 13844 IF(IFEEDB.EQ.'OFF')GOTO1497 13845 WRITE(ICOUT,999) 13846 CALL DPWRST('XXX','BUG ') 13847 WRITE(ICOUT,1491) 13848 1491 FORMAT('THE TIC MARK TOP OFFSET (FOR BOTH VERTICAL ', 13849 1'FRAME LINES)') 13850 CALL DPWRST('XXX','BUG ') 13851 WRITE(ICOUT,1492)HOLD 13852 1492 FORMAT('HAS JUST BEEN SET TO ',E15.7) 13853 CALL DPWRST('XXX','BUG ') 13854C 13855 1497 CONTINUE 13856C 13857 GOTO1900 13858C 13859 1499 CONTINUE 13860C 13861C ************************************************************** 13862C ** TREAT THE CASE WHEN ** 13863C ** ONLY THE LEFT VERTICAL TIC OFFSETS ARE TO BE CHANGED ** 13864C ************************************************************** 13865C 13866 IF(ICOM.EQ.'Y1TI')GOTO1500 13867 GOTO1599 13868C 13869 1500 CONTINUE 13870C 13871 ILEFT=2 13872 IF(IHARG(2).EQ.'OFFS')ILEFT=3 13873 IRIGHT=ILEFT+1 13874 IF(ILEFT.GT.NUMARG)ILEFT=0 13875 IF(IRIGHT.GT.NUMARG)IRIGHT=0 13876C 13877C ***************************************************** 13878C ** TREAT THE BOTTOM OFFSET ** 13879C ** NO ARGUMENT WILL SET THE DEFAULT ** 13880C ***************************************************** 13881C 13882 IF(ILEFT.EQ.0)GOTO1510 13883 IF(IHARG(ILEFT).EQ.'ON')GOTO1510 13884 IF(IHARG(ILEFT).EQ.'OFF')GOTO1510 13885 IF(IHARG(ILEFT).EQ.'AUTO')GOTO1510 13886 IF(IHARG(ILEFT).EQ.'DEFA')GOTO1510 13887 IF(IHARG(ILEFT).EQ.'FLOA')GOTO1510 13888 IF(IARGT(ILEFT).EQ.'NUMB')GOTO1520 13889 IERROR='YES' 13890 GOTO1900 13891C 13892 1510 CONTINUE 13893 HOLD=DEFTOF 13894 GOTO1540 13895C 13896 1520 CONTINUE 13897 HOLD=ARG(ILEFT) 13898 GOTO1540 13899C 13900 1540 CONTINUE 13901 IFOUND='YES' 13902 HOLD=ABS(HOLD) 13903 PY1TOB=HOLD 13904C 13905 IF(IFEEDB.EQ.'OFF')GOTO1549 13906 WRITE(ICOUT,999) 13907 CALL DPWRST('XXX','BUG ') 13908 WRITE(ICOUT,1541) 13909 1541 FORMAT('THE TIC MARK BOTTOM OFFSET (FOR LEFT VERTICAL ', 13910 1'FRAME LINE)') 13911 CALL DPWRST('XXX','BUG ') 13912 WRITE(ICOUT,1542)HOLD 13913 1542 FORMAT('HAS JUST BEEN SET TO ',E15.7) 13914 CALL DPWRST('XXX','BUG ') 13915 1549 CONTINUE 13916C 13917C ***************************************************** 13918C ** TREAT THE TOP OFFSET ** 13919C ** NO ARGUMENT WILL LEAVE THE CURRENT VALUE ** 13920C ***************************************************** 13921C 13922 IF(IRIGHT.EQ.0)GOTO1560 13923 IF(IHARG(IRIGHT).EQ.'ON')GOTO1570 13924 IF(IHARG(IRIGHT).EQ.'OFF')GOTO1570 13925 IF(IHARG(IRIGHT).EQ.'AUTO')GOTO1570 13926 IF(IHARG(IRIGHT).EQ.'DEFA')GOTO1570 13927 IF(IHARG(IRIGHT).EQ.'FLOA')GOTO1570 13928 IF(IARGT(IRIGHT).EQ.'NUMB')GOTO1580 13929 IERROR='YES' 13930 GOTO1900 13931C 13932 1560 CONTINUE 13933 HOLD=PY1TOT 13934 GOTO1590 13935C 13936 1570 CONTINUE 13937 HOLD=DEFTOF 13938 GOTO1590 13939C 13940 1580 CONTINUE 13941 HOLD=ARG(IRIGHT) 13942 GOTO1590 13943C 13944 1590 CONTINUE 13945 IFOUND='YES' 13946 HOLD=ABS(HOLD) 13947 PY1TOT=HOLD 13948C 13949 IF(IFEEDB.EQ.'OFF')GOTO1597 13950 WRITE(ICOUT,999) 13951 CALL DPWRST('XXX','BUG ') 13952 WRITE(ICOUT,1591) 13953 1591 FORMAT('THE TIC MARK TOP OFFSET (FOR LEFT VERTICAL ', 13954 1'FRAME LINE)') 13955 CALL DPWRST('XXX','BUG ') 13956 WRITE(ICOUT,1592)HOLD 13957 1592 FORMAT('HAS JUST BEEN SET TO ',E15.7) 13958 CALL DPWRST('XXX','BUG ') 13959C 13960 1597 CONTINUE 13961C 13962 GOTO1900 13963C 13964 1599 CONTINUE 13965C 13966C ************************************************************** 13967C ** TREAT THE CASE WHEN ** 13968C ** ONLY THE RIGHT VERTICAL TIC OFFSETS ARE TO BE CHANGED ** 13969C ************************************************************** 13970C 13971 IF(ICOM.EQ.'Y2TI')GOTO1600 13972 GOTO1699 13973C 13974 1600 CONTINUE 13975C 13976 ILEFT=2 13977 IF(IHARG(2).EQ.'OFFS')ILEFT=3 13978 IRIGHT=ILEFT+1 13979 IF(ILEFT.GT.NUMARG)ILEFT=0 13980 IF(IRIGHT.GT.NUMARG)IRIGHT=0 13981C 13982C ***************************************************** 13983C ** TREAT THE BOTTOM OFFSET ** 13984C ** NO ARGUMENT WILL SET THE DEFAULT ** 13985C ***************************************************** 13986C 13987 IF(ILEFT.EQ.0)GOTO1610 13988 IF(IHARG(ILEFT).EQ.'ON')GOTO1610 13989 IF(IHARG(ILEFT).EQ.'OFF')GOTO1610 13990 IF(IHARG(ILEFT).EQ.'AUTO')GOTO1610 13991 IF(IHARG(ILEFT).EQ.'DEFA')GOTO1610 13992 IF(IHARG(ILEFT).EQ.'FLOA')GOTO1610 13993 IF(IARGT(ILEFT).EQ.'NUMB')GOTO1620 13994 IERROR='YES' 13995 GOTO1900 13996C 13997 1610 CONTINUE 13998 HOLD=DEFTOF 13999 GOTO1640 14000C 14001 1620 CONTINUE 14002 HOLD=ARG(ILEFT) 14003 GOTO1640 14004C 14005 1640 CONTINUE 14006 IFOUND='YES' 14007 HOLD=ABS(HOLD) 14008 PY2TOB=HOLD 14009C 14010 IF(IFEEDB.EQ.'OFF')GOTO1649 14011 WRITE(ICOUT,999) 14012 CALL DPWRST('XXX','BUG ') 14013 WRITE(ICOUT,1641) 14014 1641 FORMAT('THE TIC MARK BOTTOM OFFSET (FOR RIGHT VERTICAL ', 14015 1'FRAME LINE)') 14016 CALL DPWRST('XXX','BUG ') 14017 WRITE(ICOUT,1642)HOLD 14018 1642 FORMAT('HAS JUST BEEN SET TO ',E16.7) 14019 CALL DPWRST('XXX','BUG ') 14020 1649 CONTINUE 14021C 14022C ***************************************************** 14023C ** TREAT THE TOP OFFSET ** 14024C ** NO ARGUMENT WILL LEAVE THE CURRENT VALUE ** 14025C ***************************************************** 14026C 14027 IF(IRIGHT.EQ.0)GOTO1660 14028 IF(IHARG(IRIGHT).EQ.'ON')GOTO1670 14029 IF(IHARG(IRIGHT).EQ.'OFF')GOTO1670 14030 IF(IHARG(IRIGHT).EQ.'AUTO')GOTO1670 14031 IF(IHARG(IRIGHT).EQ.'DEFA')GOTO1670 14032 IF(IHARG(IRIGHT).EQ.'FLOA')GOTO1670 14033 IF(IARGT(IRIGHT).EQ.'NUMB')GOTO1680 14034 IERROR='YES' 14035 GOTO1900 14036C 14037 1660 CONTINUE 14038 HOLD=PY2TOT 14039 GOTO1690 14040C 14041 1670 CONTINUE 14042 HOLD=DEFTOF 14043 GOTO1690 14044C 14045 1680 CONTINUE 14046 HOLD=ARG(IRIGHT) 14047 GOTO1690 14048C 14049 1690 CONTINUE 14050 IFOUND='YES' 14051 HOLD=ABS(HOLD) 14052 PY2TOT=HOLD 14053C 14054 IF(IFEEDB.EQ.'OFF')GOTO1697 14055 WRITE(ICOUT,999) 14056 CALL DPWRST('XXX','BUG ') 14057 WRITE(ICOUT,1691) 14058 1691 FORMAT('THE TIC MARK TOP OFFSET (FOR RIGHT VERTICAL ', 14059 1'FRAME LINE)') 14060 CALL DPWRST('XXX','BUG ') 14061 WRITE(ICOUT,1692)HOLD 14062 1692 FORMAT('HAS JUST BEEN SET TO ',E16.7) 14063 CALL DPWRST('XXX','BUG ') 14064C 14065 1697 CONTINUE 14066 GOTO1900 14067C 14068 1699 CONTINUE 14069C 14070C ***************************************************** 14071C ** TREAT THE CASE WHEN ** 14072C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 14073C ***************************************************** 14074C 14075 IF(ICOM.EQ.'TIC')GOTO1700 14076 IF(ICOM.EQ.'TICS')GOTO1700 14077 IF(ICOM.EQ.'XYTI')GOTO1700 14078 IF(ICOM.EQ.'YXTI')GOTO1700 14079 GOTO1799 14080C 14081 1700 CONTINUE 14082C 14083 ILEFT=2 14084 IF(IHARG(2).EQ.'OFFS')ILEFT=3 14085 IRIGHT=ILEFT+1 14086 IF(ILEFT.GT.NUMARG)ILEFT=0 14087 IF(IRIGHT.GT.NUMARG)IRIGHT=0 14088C 14089C ***************************************************** 14090C ** TREAT THE BOTTOM OFFSET ** 14091C ** NO ARGUMENT WILL SET THE DEFAULT ** 14092C ***************************************************** 14093C 14094 IF(ILEFT.EQ.0)GOTO1710 14095 IF(IHARG(ILEFT).EQ.'ON')GOTO1710 14096 IF(IHARG(ILEFT).EQ.'OFF')GOTO1710 14097 IF(IHARG(ILEFT).EQ.'AUTO')GOTO1710 14098 IF(IHARG(ILEFT).EQ.'DEFA')GOTO1710 14099 IF(IHARG(ILEFT).EQ.'FLOA')GOTO1710 14100 IF(IARGT(ILEFT).EQ.'NUMB')GOTO1720 14101 IERROR='YES' 14102 GOTO1900 14103C 14104 1710 CONTINUE 14105 HOLD=DEFTOF 14106 GOTO1740 14107C 14108 1720 CONTINUE 14109 HOLD=ARG(ILEFT) 14110 GOTO1740 14111C 14112 1740 CONTINUE 14113 IFOUND='YES' 14114 HOLD=ABS(HOLD) 14115 PX1TOL=HOLD 14116 PX2TOL=HOLD 14117 PY1TOB=HOLD 14118 PY2TOB=HOLD 14119C 14120 IF(IFEEDB.EQ.'OFF')GOTO1749 14121 WRITE(ICOUT,999) 14122 CALL DPWRST('XXX','BUG ') 14123 WRITE(ICOUT,1741) 14124 1741 FORMAT('THE TIC MARK BOTTOM OFFSET (FOR BOTH VERTICAL ', 14125 1'FRAME LINES)') 14126 CALL DPWRST('XXX','BUG ') 14127 WRITE(ICOUT,1742)HOLD 14128 1742 FORMAT('HAS JUST BEEN SET TO ',E15.7) 14129 CALL DPWRST('XXX','BUG ') 14130 WRITE(ICOUT,1743) 14131 1743 FORMAT('THE TIC MARK LEFT OFFSET (FOR BOTH HORIZONTAL ', 14132 1'FRAME LINES)') 14133 CALL DPWRST('XXX','BUG ') 14134 WRITE(ICOUT,1742)HOLD 14135 CALL DPWRST('XXX','BUG ') 14136 1749 CONTINUE 14137C 14138C ***************************************************** 14139C ** TREAT THE TOP OFFSET ** 14140C ** NO ARGUMENT WILL LEAVE THE CURRENT VALUE ** 14141C ***************************************************** 14142C 14143 IF(IRIGHT.EQ.0)GOTO1760 14144 IF(IHARG(IRIGHT).EQ.'ON')GOTO1770 14145 IF(IHARG(IRIGHT).EQ.'OFF')GOTO1770 14146 IF(IHARG(IRIGHT).EQ.'AUTO')GOTO1770 14147 IF(IHARG(IRIGHT).EQ.'DEFA')GOTO1770 14148 IF(IHARG(IRIGHT).EQ.'FLOA')GOTO1770 14149 IF(IARGT(IRIGHT).EQ.'NUMB')GOTO1780 14150 IERROR='YES' 14151 GOTO1900 14152C 14153 1760 CONTINUE 14154 GOTO1900 14155C 14156 1770 CONTINUE 14157 HOLD=DEFTOF 14158 GOTO1790 14159C 14160 1780 CONTINUE 14161 HOLD=ARG(IRIGHT) 14162 GOTO1790 14163C 14164 1790 CONTINUE 14165 IFOUND='YES' 14166 HOLD=ABS(HOLD) 14167 PX1TOR=HOLD 14168 PX2TOR=HOLD 14169 PY1TOT=HOLD 14170 PY2TOT=HOLD 14171C 14172 IF(IFEEDB.EQ.'OFF')GOTO1797 14173 WRITE(ICOUT,999) 14174 CALL DPWRST('XXX','BUG ') 14175 WRITE(ICOUT,1791) 14176 1791 FORMAT('THE TIC MARK TOP OFFSET (FOR BOTH VERTICAL ', 14177 1'FRAME LINES)') 14178 CALL DPWRST('XXX','BUG ') 14179 WRITE(ICOUT,1792)HOLD 14180 1792 FORMAT('HAS JUST BEEN SET TO ',E15.7) 14181 CALL DPWRST('XXX','BUG ') 14182 WRITE(ICOUT,1793) 14183 1793 FORMAT('THE TIC MARK RIGHT OFFSET (FOR BOTH HORIZONTAL ', 14184 1'FRAME LINES)') 14185 CALL DPWRST('XXX','BUG ') 14186 WRITE(ICOUT,1792)HOLD 14187 CALL DPWRST('XXX','BUG ') 14188C 14189 1797 CONTINUE 14190C 14191 GOTO1900 14192C 14193 1799 CONTINUE 14194 GOTO1900 14195C 14196C ***************************************************** 14197C ** TREAT THE OFFSET UNITS CASE ** 14198C ** NOTE THAT CURRENTLY THERE IS ONLY ONE UNITS ** 14199C ** SWITCH, I.E., ALL 4 FRAME LINES WILL USE THE ** 14200C ** SAME UNITS. THE CHOICES ARE "DATA", (OFFSETS ** 14201C ** IN UNITS OF THE DATA) AND "ABSOLUTE" (OFFSETS ** 14202C ** IN DATAPLOT 0. TO 100. PERCENT UNITS). ** 14203C ***************************************************** 14204C 14205 2090 CONTINUE 14206 IFOUND='YES' 14207C 14208 IF(IHARG(NUMARG).EQ.'ON')GOTO2150 14209 IF(IHARG(NUMARG).EQ.'OFF')GOTO2150 14210 IF(IHARG(NUMARG).EQ.'AUTO')GOTO2150 14211 IF(IHARG(NUMARG).EQ.'DEFA')GOTO2150 14212 IF(IHARG(NUMARG).EQ.'FLOA')GOTO2150 14213 IF(IHARG(NUMARG).EQ.'DATA')GOTO2160 14214 IF(IHARG(NUMARG).EQ.'SCRE')GOTO2170 14215 IF(IHARG(NUMARG).EQ.'ABSO')GOTO2170 14216 GOTO2150 14217C 14218 2150 CONTINUE 14219 ITICUN=IDEFTU 14220CCCCC THE FOLLOWING LINE (AND THE CONTINUE) WERE ADDED OCTOBER 1991 14221 IF(IFEEDB.EQ.'OFF')GOTO2159 14222 WRITE(ICOUT,2151)ITICUN 14223 2151 FORMAT('TIC MARK OFFSETS WILL BE CALCULATED IN ',A4, 14224 1' UNITS.') 14225 CALL DPWRST('XXX','BUG ') 14226 2159 CONTINUE 14227 GOTO1900 14228C 14229 2160 CONTINUE 14230 ITICUN='DATA' 14231CCCCC THE FOLLOWING LINE (AND THE CONTINUE) WERE ADDED OCTOBER 1991 14232 IF(IFEEDB.EQ.'OFF')GOTO2169 14233 WRITE(ICOUT,2161) 14234 2161 FORMAT('TIC MARK OFFSETS WILL BE CALCULATED IN DATA', 14235 1' UNITS.') 14236 CALL DPWRST('XXX','BUG ') 14237 2169 CONTINUE 14238 GOTO1900 14239C 14240 2170 CONTINUE 14241 ITICUN='ABSO' 14242CCCCC THE FOLLOWING LINE (AND THE CONTINUE) WERE ADDED OCTOBER 1991 14243 IF(IFEEDB.EQ.'OFF')GOTO2179 14244 WRITE(ICOUT,2171) 14245 2171 FORMAT('TIC MARK OFFSETS WILL BE CALCULATED IN', 14246 1' DATAPLOT SCREEN UNITS.') 14247 CALL DPWRST('XXX','BUG ') 14248 2179 CONTINUE 14249 GOTO1900 14250C 14251 1900 CONTINUE 14252 RETURN 14253 END 14254 SUBROUTINE DPTCPA(ICOM,IHARG,NUMARG, 14255 1IDEFPA, 14256 1IX1TPA,IX2TPA,IY1TPA,IY2TPA, 14257 1IFOUND,IERROR) 14258C 14259C PURPOSE--DEFINE THE TIC MARK PATTERN SWITCHES 14260C FOR ANY OF THE 4 FRAME LINES. 14261C SUCH TIC MARK SWITCHES DESCRIBE 14262C THE TIC MARK PATTERN ON THE 4 FRAME LINES OF A PLOT. 14263C THE CONTENTS OF A TIC MARK PATTERN SWITCH ARE 14264C A PATTERN. 14265C THE TIC MARK PATTERN SWITCHES FOR THE 4 FRAME LINES 14266C ARE CONTAINED IN THE 4 VARIABLES 14267C IX1TPA,IX2TPA,IY1TPA,IY2TPA 14268C INPUT ARGUMENTS--ICOM 14269C --IHARG (A HOLLERITH VECTOR) 14270C --NUMARG 14271C --IDEFPA 14272C OUTPUT ARGUMENTS--IX1TPA = PATTERN FOR BOTTOM HORIZ. TICS 14273C --IX2TPA = PATTERN FOR TOP HORIZ. TICS 14274C --IY1TPA = PATTERN FOR LEFT VERT. TICS 14275C --IY2TPA = PATTERN FOR RIGHT VERT. TICS 14276C --IFOUND ('YES' OR 'NO' ) 14277C --IERROR ('YES' OR 'NO' ) 14278C WRITTEN BY--ALAN HECKERT 14279C COMPUTER SERVICES DIVISION 14280C INFORMATION TECHNOLOGY LABORATORY 14281C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 14282C GAITHERSBURG, MD 20899-8980 14283C PHONE--301-975-2899 14284C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 14285C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 14286C LANGUAGE--ANSI FORTRAN (1977) 14287C VERSION NUMBER--89/2 14288C ORIGINAL VERSION--JANUARY 1989. 14289C 14290C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 14291C 14292 CHARACTER*4 ICOM 14293 CHARACTER*4 IHARG 14294C 14295 CHARACTER*4 IDEFPA 14296C 14297 CHARACTER*4 IX1TPA 14298 CHARACTER*4 IX2TPA 14299 CHARACTER*4 IY1TPA 14300 CHARACTER*4 IY2TPA 14301C 14302 CHARACTER*4 IFOUND 14303 CHARACTER*4 IERROR 14304C 14305 CHARACTER*4 IHOLD 14306C 14307C--------------------------------------------------------------------- 14308C 14309 DIMENSION IHARG(*) 14310C 14311C-----COMMON---------------------------------------------------------- 14312C 14313 INCLUDE 'DPCOP2.INC' 14314C 14315C-----START POINT----------------------------------------------------- 14316C 14317 IFOUND='NO' 14318 IERROR='NO' 14319C 14320 IF(NUMARG.LE.0)GOTO1900 14321 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PATT')GOTO1090 14322 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 14323 1IHARG(2).EQ.'PATT')GOTO1090 14324 GOTO1900 14325 1090 CONTINUE 14326C 14327C ***************************************************** 14328C ** TREAT THE CASE WHEN ** 14329C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 14330C ***************************************************** 14331C 14332 IF(ICOM.EQ.'XTIC')GOTO1100 14333 GOTO1199 14334C 14335 1100 CONTINUE 14336 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 14337 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 14338 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 14339 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 14340 IF(IHARG(NUMARG).EQ.'PATT')GOTO1150 14341 GOTO1160 14342C 14343 1150 CONTINUE 14344 IHOLD=IDEFPA 14345 GOTO1180 14346C 14347 1160 CONTINUE 14348 IHOLD=IHARG(NUMARG) 14349 GOTO1180 14350C 14351 1180 CONTINUE 14352 IFOUND='YES' 14353 IX1TPA=IHOLD 14354 IX2TPA=IHOLD 14355C 14356 IF(IFEEDB.EQ.'OFF')GOTO1189 14357 WRITE(ICOUT,999) 14358 999 FORMAT(1X) 14359 CALL DPWRST('XXX','BUG ') 14360 WRITE(ICOUT,1181) 14361 1181 FORMAT('THE TIC MARK PATTERN (FOR BOTH HORIZONTAL ', 14362 1'FRAME LINES)') 14363 CALL DPWRST('XXX','BUG ') 14364 WRITE(ICOUT,1182)IHOLD 14365 1182 FORMAT('HAS JUST BEEN SET TO ',A4) 14366 CALL DPWRST('XXX','BUG ') 14367 1189 CONTINUE 14368 GOTO1900 14369C 14370 1199 CONTINUE 14371C 14372C ************************************************************** 14373C ** TREAT THE CASE WHEN ** 14374C ** ONLY THE BOTTOM HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 14375C ************************************************************** 14376C 14377 IF(ICOM.EQ.'X1TI')GOTO1200 14378 GOTO1299 14379C 14380 1200 CONTINUE 14381 IF(IHARG(NUMARG).EQ.'ON')GOTO1250 14382 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 14383 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 14384 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 14385 IF(IHARG(NUMARG).EQ.'PATT')GOTO1250 14386 GOTO1260 14387C 14388 1250 CONTINUE 14389 IHOLD=IDEFPA 14390 GOTO1280 14391C 14392 1260 CONTINUE 14393 IHOLD=IHARG(NUMARG) 14394 GOTO1280 14395C 14396 1280 CONTINUE 14397 IFOUND='YES' 14398 IX1TPA=IHOLD 14399C 14400 IF(IFEEDB.EQ.'OFF')GOTO1289 14401 WRITE(ICOUT,999) 14402 CALL DPWRST('XXX','BUG ') 14403 WRITE(ICOUT,1281) 14404 1281 FORMAT('THE TIC MARK PATTERN (FOR THE BOTTOM HORIZONTAL ', 14405 1'FRAME LINE)') 14406 CALL DPWRST('XXX','BUG ') 14407 WRITE(ICOUT,1282)IHOLD 14408 1282 FORMAT('HAS JUST BEEN SET TO ',A4) 14409 CALL DPWRST('XXX','BUG ') 14410 1289 CONTINUE 14411 GOTO1900 14412C 14413 1299 CONTINUE 14414C 14415C ************************************************************** 14416C ** TREAT THE CASE WHEN ** 14417C ** ONLY THE TOP HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 14418C ************************************************************** 14419C 14420 IF(ICOM.EQ.'X2TI')GOTO1300 14421 GOTO1399 14422C 14423 1300 CONTINUE 14424 IF(IHARG(NUMARG).EQ.'ON')GOTO1350 14425 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 14426 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 14427 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 14428 IF(IHARG(NUMARG).EQ.'PATT')GOTO1350 14429 GOTO1360 14430C 14431 1350 CONTINUE 14432 IHOLD=IDEFPA 14433 GOTO1380 14434C 14435 1360 CONTINUE 14436 IHOLD=IHARG(NUMARG) 14437 GOTO1380 14438C 14439 1380 CONTINUE 14440 IFOUND='YES' 14441 IX2TPA=IHOLD 14442C 14443 IF(IFEEDB.EQ.'OFF')GOTO1389 14444 WRITE(ICOUT,999) 14445 CALL DPWRST('XXX','BUG ') 14446 WRITE(ICOUT,1381) 14447 1381 FORMAT('THE TIC MARK PATTERN (FOR THE TOP HORIZONTAL ', 14448 1'FRAME LINE)') 14449 CALL DPWRST('XXX','BUG ') 14450 WRITE(ICOUT,1382)IHOLD 14451 1382 FORMAT('HAS JUST BEEN SET TO ',A4) 14452 CALL DPWRST('XXX','BUG ') 14453 1389 CONTINUE 14454 GOTO1900 14455C 14456 1399 CONTINUE 14457C 14458C ***************************************************** 14459C ** TREAT THE CASE WHEN ** 14460C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 14461C ***************************************************** 14462C 14463 IF(ICOM.EQ.'YTIC')GOTO1400 14464 GOTO1499 14465C 14466 1400 CONTINUE 14467 IF(IHARG(NUMARG).EQ.'ON')GOTO1450 14468 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 14469 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 14470 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 14471 IF(IHARG(NUMARG).EQ.'PATT')GOTO1450 14472 GOTO1460 14473C 14474 1450 CONTINUE 14475 IHOLD=IDEFPA 14476 GOTO1480 14477C 14478 1460 CONTINUE 14479 IHOLD=IHARG(NUMARG) 14480 GOTO1480 14481C 14482 1480 CONTINUE 14483 IFOUND='YES' 14484 IY1TPA=IHOLD 14485 IY2TPA=IHOLD 14486C 14487 IF(IFEEDB.EQ.'OFF')GOTO1489 14488 WRITE(ICOUT,999) 14489 CALL DPWRST('XXX','BUG ') 14490 WRITE(ICOUT,1481) 14491 1481 FORMAT('THE TIC MARK PATTERN (FOR BOTH VERTICAL ', 14492 1'FRAME LINES)') 14493 CALL DPWRST('XXX','BUG ') 14494 WRITE(ICOUT,1482)IHOLD 14495 1482 FORMAT('HAS JUST BEEN SET TO ',A4) 14496 CALL DPWRST('XXX','BUG ') 14497 1489 CONTINUE 14498 GOTO1900 14499C 14500 1499 CONTINUE 14501C 14502C ************************************************************** 14503C ** TREAT THE CASE WHEN ** 14504C ** ONLY THE LEFT VERTICAL TIC MARKS ARE TO BE CHANGED ** 14505C ************************************************************** 14506C 14507 IF(ICOM.EQ.'Y1TI')GOTO1500 14508 GOTO1599 14509C 14510 1500 CONTINUE 14511 IF(IHARG(NUMARG).EQ.'ON')GOTO1550 14512 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 14513 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 14514 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 14515 IF(IHARG(NUMARG).EQ.'PATT')GOTO1550 14516 GOTO1560 14517C 14518 1550 CONTINUE 14519 IHOLD=IDEFPA 14520 GOTO1580 14521C 14522 1560 CONTINUE 14523 IHOLD=IHARG(NUMARG) 14524 GOTO1580 14525C 14526 1580 CONTINUE 14527 IFOUND='YES' 14528 IY1TPA=IHOLD 14529C 14530 IF(IFEEDB.EQ.'OFF')GOTO1589 14531 WRITE(ICOUT,999) 14532 CALL DPWRST('XXX','BUG ') 14533 WRITE(ICOUT,1581) 14534 1581 FORMAT('THE TIC MARK PATTERN (FOR THE LEFT VERTICAL ', 14535 1'FRAME LINE)') 14536 CALL DPWRST('XXX','BUG ') 14537 WRITE(ICOUT,1582)IHOLD 14538 1582 FORMAT('HAS JUST BEEN SET TO ',A4) 14539 CALL DPWRST('XXX','BUG ') 14540 1589 CONTINUE 14541 GOTO1900 14542C 14543 1599 CONTINUE 14544C 14545C ************************************************************** 14546C ** TREAT THE CASE WHEN ** 14547C ** ONLY THE RIGHT VERTICAL TIC MARKS ARE TO BE CHANGED ** 14548C ************************************************************** 14549C 14550 IF(ICOM.EQ.'Y2TI')GOTO1600 14551 GOTO1699 14552C 14553 1600 CONTINUE 14554 IF(IHARG(NUMARG).EQ.'ON')GOTO1650 14555 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 14556 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 14557 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 14558 IF(IHARG(NUMARG).EQ.'PATT')GOTO1650 14559 GOTO1660 14560C 14561 1650 CONTINUE 14562 IHOLD=IDEFPA 14563 GOTO1680 14564C 14565 1660 CONTINUE 14566 IHOLD=IHARG(NUMARG) 14567 GOTO1680 14568C 14569 1680 CONTINUE 14570 IFOUND='YES' 14571 IY2TPA=IHOLD 14572C 14573 IF(IFEEDB.EQ.'OFF')GOTO1689 14574 WRITE(ICOUT,999) 14575 CALL DPWRST('XXX','BUG ') 14576 WRITE(ICOUT,1681) 14577 1681 FORMAT('THE TIC MARK PATTERN (FOR THE RIGHT VERTICAL ', 14578 1'FRAME LINE)') 14579 CALL DPWRST('XXX','BUG ') 14580 WRITE(ICOUT,1682)IHOLD 14581 1682 FORMAT('HAS JUST BEEN SET TO ',A4) 14582 CALL DPWRST('XXX','BUG ') 14583 1689 CONTINUE 14584 GOTO1900 14585C 14586 1699 CONTINUE 14587C 14588C ***************************************************** 14589C ** TREAT THE CASE WHEN ** 14590C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 14591C ***************************************************** 14592C 14593 IF(ICOM.EQ.'TIC')GOTO1700 14594 IF(ICOM.EQ.'TICS')GOTO1700 14595 IF(ICOM.EQ.'XYTI')GOTO1700 14596 IF(ICOM.EQ.'YXTI')GOTO1700 14597 GOTO1799 14598C 14599 1700 CONTINUE 14600 IF(IHARG(NUMARG).EQ.'ON')GOTO1750 14601 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 14602 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 14603 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 14604 IF(IHARG(NUMARG).EQ.'PATT')GOTO1750 14605 GOTO1760 14606C 14607 1750 CONTINUE 14608 IHOLD=IDEFPA 14609 GOTO1780 14610C 14611 1760 CONTINUE 14612 IHOLD=IHARG(NUMARG) 14613 GOTO1780 14614C 14615 1780 CONTINUE 14616 IFOUND='YES' 14617 IX1TPA=IHOLD 14618 IX2TPA=IHOLD 14619 IY1TPA=IHOLD 14620 IY2TPA=IHOLD 14621C 14622 IF(IFEEDB.EQ.'OFF')GOTO1789 14623 WRITE(ICOUT,999) 14624 CALL DPWRST('XXX','BUG ') 14625 WRITE(ICOUT,1781) 14626 1781 FORMAT('THE TIC MARK PATTERN (FOR ALL 4 ', 14627 1'FRAME LINES)') 14628 CALL DPWRST('XXX','BUG ') 14629 WRITE(ICOUT,1782)IHOLD 14630 1782 FORMAT('HAS JUST BEEN SET TO ',A4) 14631 CALL DPWRST('XXX','BUG ') 14632 1789 CONTINUE 14633 GOTO1900 14634C 14635 1799 CONTINUE 14636C 14637 1900 CONTINUE 14638 RETURN 14639 END 14640 SUBROUTINE DPTCSZ(ICOM,IHARG,IARGT,ARG,NUMARG, 14641 1DEFTL, 14642 1PX1TLE,PX2TLE,PY1TLE,PY2TLE, 14643 1IFOUND,IERROR) 14644C 14645C PURPOSE--DEFINE THE TIC MARK SIZES 14646C FOR ANY OF THE 4 FRAME LINES. 14647C SUCH TIC MARK SWITCHES DEFINE THE SIZE (LENGTH) 14648C OF THE MAJOR TIC MARKS ON THE 4 FRAME LINES OF A PLOT. 14649C (THE SIZE OF THE MINOR TIC MARKS IS ALWAYS 14650C 1/2 THE SIZE OF THE MAJOR TIC MARKS.) 14651C THE TIC MARK SIZE SWITCHES FOR THE 4 FRAME LINES 14652C ARE CONTAINED IN THE 4 VARIABLES 14653C PX1TLE,PX2TLE,PY1TLE,PY2TLE, 14654C INPUT ARGUMENTS--ICOM 14655C --IHARG (A HOLLERITH VECTOR) 14656C --IARGT (A HOLLERITH VECTOR) 14657C --ARG (A FLOATING POINT VECTOR) 14658C --NUMARG 14659C --DEFTL 14660C OUTPUT ARGUMENTS-- 14661C --PX1TLE = BOTTOM HORIZONTAL TIC LENGTH 14662C --PX2TLE = TOP HORIZONTAL TIC LENGTH 14663C --PY1TLE = LEFT VERTICAL TIC LENGTH 14664C --PY2TLE = RIGHT VERTICAL TIC LENGTH 14665C --IFOUND ('YES' OR 'NO' ) 14666C --IERROR ('YES' OR 'NO' ) 14667C WRITTEN BY--JAMES J. FILLIBEN 14668C STATISTICAL ENGINEERING DIVISION 14669C INFORMATION TECHNOLOGY LABORATORY 14670C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 14671C GAITHERSBURG, MD 20899-8980 14672C PHONE--301-975-2899 14673C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 14674C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 14675C LANGUAGE--ANSI FORTRAN (1977) 14676C VERSION NUMBER--82/7 14677C ORIGINAL VERSION--OCTOBER 1980. 14678C UPDATED --MAY 1982. 14679C 14680C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 14681C 14682 CHARACTER*4 ICOM 14683 CHARACTER*4 IHARG 14684 CHARACTER*4 IARGT 14685 CHARACTER*4 IFOUND 14686 CHARACTER*4 IERROR 14687C 14688C--------------------------------------------------------------------- 14689C 14690 DIMENSION IHARG(*) 14691 DIMENSION IARGT(*) 14692 DIMENSION ARG(*) 14693C 14694C-----COMMON---------------------------------------------------------- 14695C 14696 INCLUDE 'DPCOP2.INC' 14697C 14698C-----START POINT----------------------------------------------------- 14699C 14700 IFOUND='NO' 14701 IERROR='NO' 14702C 14703 IF(NUMARG.LE.0)GOTO1900 14704 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SIZE')GOTO1090 14705 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 14706 1IHARG(2).EQ.'SIZE')GOTO1090 14707 GOTO1900 14708 1090 CONTINUE 14709C 14710C ***************************************************** 14711C ** TREAT THE CASE WHEN ** 14712C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 14713C ***************************************************** 14714C 14715 IF(ICOM.EQ.'XTIC')GOTO1100 14716 GOTO1199 14717C 14718 1100 CONTINUE 14719 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 14720 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 14721 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 14722 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 14723 IF(IHARG(NUMARG).EQ.'SIZE')GOTO1150 14724 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 14725 IERROR='YES' 14726 GOTO1900 14727C 14728 1150 CONTINUE 14729 HOLD=DEFTL 14730 GOTO1180 14731C 14732 1160 CONTINUE 14733 HOLD=ARG(NUMARG) 14734 GOTO1180 14735C 14736 1180 CONTINUE 14737 IFOUND='YES' 14738 PX1TLE=HOLD 14739 PX2TLE=HOLD 14740C 14741 IF(IFEEDB.EQ.'OFF')GOTO1189 14742 WRITE(ICOUT,999) 14743 999 FORMAT(1X) 14744 CALL DPWRST('XXX','BUG ') 14745 WRITE(ICOUT,1181) 14746 1181 FORMAT('THE TIC MARK SIZE (FOR BOTH HORIZONTAL ', 14747 1'FRAME LINES)') 14748 CALL DPWRST('XXX','BUG ') 14749 WRITE(ICOUT,1182)HOLD 14750 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7) 14751 CALL DPWRST('XXX','BUG ') 14752 1189 CONTINUE 14753 GOTO1900 14754C 14755 1199 CONTINUE 14756C 14757C ************************************************************** 14758C ** TREAT THE CASE WHEN ** 14759C ** ONLY THE BOTTOM HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 14760C ************************************************************** 14761C 14762 IF(ICOM.EQ.'X1TI')GOTO1200 14763 GOTO1299 14764C 14765 1200 CONTINUE 14766 IF(IHARG(NUMARG).EQ.'ON')GOTO1250 14767 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 14768 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 14769 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 14770 IF(IHARG(NUMARG).EQ.'SIZE')GOTO1250 14771 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1260 14772 IERROR='YES' 14773 GOTO1900 14774C 14775 1250 CONTINUE 14776 HOLD=DEFTL 14777 GOTO1280 14778C 14779 1260 CONTINUE 14780 HOLD=ARG(NUMARG) 14781 GOTO1280 14782C 14783 1280 CONTINUE 14784 IFOUND='YES' 14785 PX1TLE=HOLD 14786C 14787 IF(IFEEDB.EQ.'OFF')GOTO1289 14788 WRITE(ICOUT,999) 14789 CALL DPWRST('XXX','BUG ') 14790 WRITE(ICOUT,1281) 14791 1281 FORMAT('THE TIC MARK SIZE (FOR THE BOTTOM HORIZONTAL ', 14792 1'FRAME LINE)') 14793 CALL DPWRST('XXX','BUG ') 14794 WRITE(ICOUT,1282)HOLD 14795 1282 FORMAT('HAS JUST BEEN SET TO ',E15.7) 14796 CALL DPWRST('XXX','BUG ') 14797 1289 CONTINUE 14798 GOTO1900 14799C 14800 1299 CONTINUE 14801C 14802C ************************************************************** 14803C ** TREAT THE CASE WHEN ** 14804C ** ONLY THE TOP HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 14805C ************************************************************** 14806C 14807 IF(ICOM.EQ.'X2TI')GOTO1300 14808 GOTO1399 14809C 14810 1300 CONTINUE 14811 IF(IHARG(NUMARG).EQ.'ON')GOTO1350 14812 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 14813 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 14814 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 14815 IF(IHARG(NUMARG).EQ.'SIZE')GOTO1350 14816 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1360 14817 IERROR='YES' 14818 GOTO1900 14819C 14820 1350 CONTINUE 14821 HOLD=DEFTL 14822 GOTO1380 14823C 14824 1360 CONTINUE 14825 HOLD=ARG(NUMARG) 14826 GOTO1380 14827C 14828 1380 CONTINUE 14829 IFOUND='YES' 14830 PX2TLE=HOLD 14831C 14832 IF(IFEEDB.EQ.'OFF')GOTO1389 14833 WRITE(ICOUT,999) 14834 CALL DPWRST('XXX','BUG ') 14835 WRITE(ICOUT,1381) 14836 1381 FORMAT('THE TIC MARK SIZE (FOR THE TOP HORIZONTAL ', 14837 1'FRAME LINE)') 14838 CALL DPWRST('XXX','BUG ') 14839 WRITE(ICOUT,1382)HOLD 14840 1382 FORMAT('HAS JUST BEEN SET TO ',E15.7) 14841 CALL DPWRST('XXX','BUG ') 14842 1389 CONTINUE 14843 GOTO1900 14844C 14845 1399 CONTINUE 14846C 14847C ***************************************************** 14848C ** TREAT THE CASE WHEN ** 14849C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 14850C ***************************************************** 14851C 14852 IF(ICOM.EQ.'YTIC')GOTO1400 14853 GOTO1499 14854C 14855 1400 CONTINUE 14856 IF(IHARG(NUMARG).EQ.'ON')GOTO1450 14857 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 14858 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 14859 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 14860 IF(IHARG(NUMARG).EQ.'SIZE')GOTO1450 14861 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1460 14862 IERROR='YES' 14863 GOTO1900 14864C 14865 1450 CONTINUE 14866 HOLD=DEFTL 14867 GOTO1480 14868C 14869 1460 CONTINUE 14870 HOLD=ARG(NUMARG) 14871 GOTO1480 14872C 14873 1480 CONTINUE 14874 IFOUND='YES' 14875 PY1TLE=HOLD 14876 PY2TLE=HOLD 14877C 14878 IF(IFEEDB.EQ.'OFF')GOTO1489 14879 WRITE(ICOUT,999) 14880 CALL DPWRST('XXX','BUG ') 14881 WRITE(ICOUT,1481) 14882 1481 FORMAT('THE TIC MARK SIZE (FOR BOTH VERTICAL ', 14883 1'FRAME LINES)') 14884 CALL DPWRST('XXX','BUG ') 14885 WRITE(ICOUT,1482)HOLD 14886 1482 FORMAT('HAS JUST BEEN SET TO ',E15.7) 14887 CALL DPWRST('XXX','BUG ') 14888 1489 CONTINUE 14889 GOTO1900 14890C 14891 1499 CONTINUE 14892C 14893C ************************************************************** 14894C ** TREAT THE CASE WHEN ** 14895C ** ONLY THE LEFT VERTICAL TIC MARKS ARE TO BE CHANGED ** 14896C ************************************************************** 14897C 14898 IF(ICOM.EQ.'Y1TI')GOTO1500 14899 GOTO1599 14900C 14901 1500 CONTINUE 14902 IF(IHARG(NUMARG).EQ.'ON')GOTO1550 14903 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 14904 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 14905 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 14906 IF(IHARG(NUMARG).EQ.'SIZE')GOTO1550 14907 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1560 14908 IERROR='YES' 14909 GOTO1900 14910C 14911 1550 CONTINUE 14912 HOLD=DEFTL 14913 GOTO1580 14914C 14915 1560 CONTINUE 14916 HOLD=ARG(NUMARG) 14917 GOTO1580 14918C 14919 1580 CONTINUE 14920 IFOUND='YES' 14921 PY1TLE=HOLD 14922C 14923 IF(IFEEDB.EQ.'OFF')GOTO1589 14924 WRITE(ICOUT,999) 14925 CALL DPWRST('XXX','BUG ') 14926 WRITE(ICOUT,1581) 14927 1581 FORMAT('THE TIC MARK SIZE (FOR THE LEFT VERTICAL ', 14928 1'FRAME LINE)') 14929 CALL DPWRST('XXX','BUG ') 14930 WRITE(ICOUT,1582)HOLD 14931 1582 FORMAT('HAS JUST BEEN SET TO ',E15.7) 14932 CALL DPWRST('XXX','BUG ') 14933 1589 CONTINUE 14934 GOTO1900 14935C 14936 1599 CONTINUE 14937C 14938C ************************************************************** 14939C ** TREAT THE CASE WHEN ** 14940C ** ONLY THE RIGHT VERTICAL TIC MARKS ARE TO BE CHANGED ** 14941C ************************************************************** 14942C 14943 IF(ICOM.EQ.'Y2TI')GOTO1600 14944 GOTO1699 14945C 14946 1600 CONTINUE 14947 IF(IHARG(NUMARG).EQ.'ON')GOTO1650 14948 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 14949 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 14950 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 14951 IF(IHARG(NUMARG).EQ.'SIZE')GOTO1650 14952 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1660 14953 IERROR='YES' 14954 GOTO1900 14955C 14956 1650 CONTINUE 14957 HOLD=DEFTL 14958 GOTO1680 14959C 14960 1660 CONTINUE 14961 HOLD=ARG(NUMARG) 14962 GOTO1680 14963C 14964 1680 CONTINUE 14965 IFOUND='YES' 14966 PY2TLE=HOLD 14967C 14968 IF(IFEEDB.EQ.'OFF')GOTO1689 14969 WRITE(ICOUT,999) 14970 CALL DPWRST('XXX','BUG ') 14971 WRITE(ICOUT,1681) 14972 1681 FORMAT('THE TIC MARK SIZE (FOR THE RIGHT VERTICAL ', 14973 1'FRAME LINE)') 14974 CALL DPWRST('XXX','BUG ') 14975 WRITE(ICOUT,1682)HOLD 14976 1682 FORMAT('HAS JUST BEEN SET TO ',E15.7) 14977 CALL DPWRST('XXX','BUG ') 14978 1689 CONTINUE 14979 GOTO1900 14980C 14981 1699 CONTINUE 14982C 14983C ***************************************************** 14984C ** TREAT THE CASE WHEN ** 14985C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 14986C ***************************************************** 14987C 14988 IF(ICOM.EQ.'TIC')GOTO1700 14989 IF(ICOM.EQ.'TICS')GOTO1700 14990 IF(ICOM.EQ.'XYTI')GOTO1700 14991 IF(ICOM.EQ.'YXTI')GOTO1700 14992 GOTO1799 14993C 14994 1700 CONTINUE 14995 IF(IHARG(NUMARG).EQ.'ON')GOTO1750 14996 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 14997 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 14998 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 14999 IF(IHARG(NUMARG).EQ.'SIZE')GOTO1750 15000 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1760 15001 IERROR='YES' 15002 GOTO1900 15003C 15004 1750 CONTINUE 15005 HOLD=DEFTL 15006 GOTO1780 15007C 15008 1760 CONTINUE 15009 HOLD=ARG(NUMARG) 15010 GOTO1780 15011C 15012 1780 CONTINUE 15013 IFOUND='YES' 15014 PX1TLE=HOLD 15015 PX2TLE=HOLD 15016 PY1TLE=HOLD 15017 PY2TLE=HOLD 15018C 15019 IF(IFEEDB.EQ.'OFF')GOTO1789 15020 WRITE(ICOUT,999) 15021 CALL DPWRST('XXX','BUG ') 15022 WRITE(ICOUT,1781) 15023 1781 FORMAT('THE TIC MARK SIZE (FOR ALL 4 ', 15024 1'FRAME LINES)') 15025 CALL DPWRST('XXX','BUG ') 15026 WRITE(ICOUT,1782)HOLD 15027 1782 FORMAT('HAS JUST BEEN SET TO ',E15.7) 15028 CALL DPWRST('XXX','BUG ') 15029 1789 CONTINUE 15030 GOTO1900 15031C 15032 1799 CONTINUE 15033C 15034 1900 CONTINUE 15035 RETURN 15036 END 15037 SUBROUTINE DPTCTH(ICOM,IHARG,ARG,NUMARG, 15038 1PDEFTH, 15039 1PTICTH, 15040 1IFOUND,IERROR) 15041C 15042C PURPOSE--DEFINE THE TIC MARK THICKNESS SWITCHES 15043C FOR ANY OF THE 4 FRAME LINES. 15044C SUCH TIC MARK SWITCHES DESCRIBE 15045C THE TIC MARK THICKNESS ON THE 4 FRAME LINES OF A PLOT. 15046C THE CONTENTS OF A TIC MARK THICKNESS SWITCH ARE 15047C A THICKNESS. 15048C CURRENTLY, THE TIC MARK THICKNESS FOR ALL 4 SIDES 15049C MUST BE THE SAME AND ARE CONTAINED IN THE VARIABLE 15050C PTICTH 15051C INPUT ARGUMENTS--ICOM 15052C --IHARG (A HOLLERITH VECTOR) 15053C --ARG (A REAL VECTOR) 15054C --NUMARG 15055C --PDEFTH 15056C OUTPUT ARGUMENTS--PTICTH = THICKNESS FOR ALL 4 FRAME SIDE TICS 15057C --IFOUND ('YES' OR 'NO' ) 15058C --IERROR ('YES' OR 'NO' ) 15059C WRITTEN BY--ALAN HECKERT 15060C COMPUTER SERVICES DIVISION 15061C INFORMATION TECHNOLOGY LABORATORY 15062C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 15063C GAITHERSBURG, MD 20899-8980 15064C PHONE--301-975-2899 15065C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 15066C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 15067C LANGUAGE--ANSI FORTRAN (1977) 15068C VERSION NUMBER--89/2 15069C ORIGINAL VERSION--JANUARY 1989. 15070C 15071C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 15072C 15073 CHARACTER*4 ICOM 15074 CHARACTER*4 IHARG 15075C 15076 REAL PDEFTH 15077C 15078C 15079 CHARACTER*4 IFOUND 15080 CHARACTER*4 IERROR 15081C 15082 REAL PHOLD 15083C 15084C--------------------------------------------------------------------- 15085C 15086 DIMENSION IHARG(*) 15087 DIMENSION ARG(*) 15088C 15089C-----COMMON---------------------------------------------------------- 15090C 15091 INCLUDE 'DPCOP2.INC' 15092C 15093C-----START POINT----------------------------------------------------- 15094C 15095 IFOUND='NO' 15096 IERROR='NO' 15097C 15098 IF(NUMARG.LE.0)GOTO1900 15099 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'THIC')GOTO1090 15100 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 15101 1IHARG(2).EQ.'THIC')GOTO1090 15102 GOTO1900 15103 1090 CONTINUE 15104C 15105C ***************************************************** 15106C ** TREAT THE CASE WHEN ** 15107C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 15108C ***************************************************** 15109C 15110 IF(ICOM.EQ.'XTIC')GOTO1100 15111 GOTO1199 15112C 15113 1100 CONTINUE 15114 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 15115 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 15116 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 15117 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 15118 IF(IHARG(NUMARG).EQ.'THIC')GOTO1150 15119 GOTO1160 15120C 15121 1150 CONTINUE 15122 PHOLD=PDEFTH 15123 GOTO1180 15124C 15125 1160 CONTINUE 15126 PHOLD=ARG(NUMARG) 15127 GOTO1180 15128C 15129 1180 CONTINUE 15130 IFOUND='YES' 15131 PTICTH=PHOLD 15132C 15133 IF(IFEEDB.EQ.'OFF')GOTO1189 15134 WRITE(ICOUT,999) 15135 999 FORMAT(1X) 15136 CALL DPWRST('XXX','BUG ') 15137 WRITE(ICOUT,1181) 15138 1181 FORMAT('THE TIC MARK THICKNESS (FOR ALL ', 15139 1'FRAME LINES)') 15140 CALL DPWRST('XXX','BUG ') 15141 WRITE(ICOUT,1182)PHOLD 15142 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7) 15143 CALL DPWRST('XXX','BUG ') 15144 1189 CONTINUE 15145 GOTO1900 15146C 15147 1199 CONTINUE 15148C 15149C ************************************************************** 15150C ** TREAT THE CASE WHEN ** 15151C ** ONLY THE BOTTOM HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 15152C ************************************************************** 15153C 15154 IF(ICOM.EQ.'X1TI')GOTO1200 15155 GOTO1299 15156C 15157 1200 CONTINUE 15158 IF(IHARG(NUMARG).EQ.'ON')GOTO1250 15159 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 15160 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 15161 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 15162 IF(IHARG(NUMARG).EQ.'THIC')GOTO1250 15163 GOTO1260 15164C 15165 1250 CONTINUE 15166 PHOLD=PDEFTH 15167 GOTO1280 15168C 15169 1260 CONTINUE 15170 PHOLD=ARG(NUMARG) 15171 GOTO1280 15172C 15173 1280 CONTINUE 15174 IFOUND='YES' 15175 PTICTH=PHOLD 15176C 15177 IF(IFEEDB.EQ.'OFF')GOTO1289 15178 WRITE(ICOUT,999) 15179 CALL DPWRST('XXX','BUG ') 15180 WRITE(ICOUT,1281) 15181 1281 FORMAT('THE TIC MARK THICKNESS (FOR ALL ', 15182 1'FRAME LINES)') 15183 CALL DPWRST('XXX','BUG ') 15184 WRITE(ICOUT,1282)PHOLD 15185 1282 FORMAT('HAS JUST BEEN SET TO ',E15.7) 15186 CALL DPWRST('XXX','BUG ') 15187 1289 CONTINUE 15188 GOTO1900 15189C 15190 1299 CONTINUE 15191C 15192C ************************************************************** 15193C ** TREAT THE CASE WHEN ** 15194C ** ONLY THE TOP HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 15195C ************************************************************** 15196C 15197 IF(ICOM.EQ.'X2TI')GOTO1300 15198 GOTO1399 15199C 15200 1300 CONTINUE 15201 IF(IHARG(NUMARG).EQ.'ON')GOTO1350 15202 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 15203 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 15204 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 15205 IF(IHARG(NUMARG).EQ.'THIC')GOTO1350 15206 GOTO1360 15207C 15208 1350 CONTINUE 15209 PHOLD=PDEFTH 15210 GOTO1380 15211C 15212 1360 CONTINUE 15213 PHOLD=ARG(NUMARG) 15214 GOTO1380 15215C 15216 1380 CONTINUE 15217 IFOUND='YES' 15218 PTICTH=PHOLD 15219C 15220 IF(IFEEDB.EQ.'OFF')GOTO1389 15221 WRITE(ICOUT,999) 15222 CALL DPWRST('XXX','BUG ') 15223 WRITE(ICOUT,1381) 15224 1381 FORMAT('THE TIC MARK THICKNESS (FOR ALL ', 15225 1'FRAME LINES)') 15226 CALL DPWRST('XXX','BUG ') 15227 WRITE(ICOUT,1382)PHOLD 15228 1382 FORMAT('HAS JUST BEEN SET TO ',E15.7) 15229 CALL DPWRST('XXX','BUG ') 15230 1389 CONTINUE 15231 GOTO1900 15232C 15233 1399 CONTINUE 15234C 15235C ***************************************************** 15236C ** TREAT THE CASE WHEN ** 15237C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 15238C ***************************************************** 15239C 15240 IF(ICOM.EQ.'YTIC')GOTO1400 15241 GOTO1499 15242C 15243 1400 CONTINUE 15244 IF(IHARG(NUMARG).EQ.'ON')GOTO1450 15245 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 15246 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 15247 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 15248 IF(IHARG(NUMARG).EQ.'THIC')GOTO1450 15249 GOTO1460 15250C 15251 1450 CONTINUE 15252 PHOLD=PDEFTH 15253 GOTO1480 15254C 15255 1460 CONTINUE 15256 PHOLD=ARG(NUMARG) 15257 GOTO1480 15258C 15259 1480 CONTINUE 15260 IFOUND='YES' 15261 PTICTH=PHOLD 15262C 15263 IF(IFEEDB.EQ.'OFF')GOTO1489 15264 WRITE(ICOUT,999) 15265 CALL DPWRST('XXX','BUG ') 15266 WRITE(ICOUT,1481) 15267 1481 FORMAT('THE TIC MARK THICKNESS (FOR ALL', 15268 1'FRAME LINES)') 15269 CALL DPWRST('XXX','BUG ') 15270 WRITE(ICOUT,1482)PHOLD 15271 1482 FORMAT('HAS JUST BEEN SET TO ',E15.7) 15272 CALL DPWRST('XXX','BUG ') 15273 1489 CONTINUE 15274 GOTO1900 15275C 15276 1499 CONTINUE 15277C 15278C ************************************************************** 15279C ** TREAT THE CASE WHEN ** 15280C ** ONLY THE LEFT VERTICAL TIC MARKS ARE TO BE CHANGED ** 15281C ************************************************************** 15282C 15283 IF(ICOM.EQ.'Y1TI')GOTO1500 15284 GOTO1599 15285C 15286 1500 CONTINUE 15287 IF(IHARG(NUMARG).EQ.'ON')GOTO1550 15288 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 15289 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 15290 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 15291 IF(IHARG(NUMARG).EQ.'THIC')GOTO1550 15292 GOTO1560 15293C 15294 1550 CONTINUE 15295 PHOLD=PDEFTH 15296 GOTO1580 15297C 15298 1560 CONTINUE 15299 PHOLD=ARG(NUMARG) 15300 GOTO1580 15301C 15302 1580 CONTINUE 15303 IFOUND='YES' 15304 PTICTH=PHOLD 15305C 15306 IF(IFEEDB.EQ.'OFF')GOTO1589 15307 WRITE(ICOUT,999) 15308 CALL DPWRST('XXX','BUG ') 15309 WRITE(ICOUT,1581) 15310 1581 FORMAT('THE TIC MARK THICKNESS (FOR ALL ', 15311 1'FRAME LINES)') 15312 CALL DPWRST('XXX','BUG ') 15313 WRITE(ICOUT,1582)PHOLD 15314 1582 FORMAT('HAS JUST BEEN SET TO ',E15.7) 15315 CALL DPWRST('XXX','BUG ') 15316 1589 CONTINUE 15317 GOTO1900 15318C 15319 1599 CONTINUE 15320C 15321C ************************************************************** 15322C ** TREAT THE CASE WHEN ** 15323C ** ONLY THE RIGHT VERTICAL TIC MARKS ARE TO BE CHANGED ** 15324C ************************************************************** 15325C 15326 IF(ICOM.EQ.'Y2TI')GOTO1600 15327 GOTO1699 15328C 15329 1600 CONTINUE 15330 IF(IHARG(NUMARG).EQ.'ON')GOTO1650 15331 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 15332 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 15333 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 15334 IF(IHARG(NUMARG).EQ.'THIC')GOTO1650 15335 GOTO1660 15336C 15337 1650 CONTINUE 15338 PHOLD=PDEFTH 15339 GOTO1680 15340C 15341 1660 CONTINUE 15342 PHOLD=ARG(NUMARG) 15343 GOTO1680 15344C 15345 1680 CONTINUE 15346 IFOUND='YES' 15347 PTICTH=PHOLD 15348C 15349 IF(IFEEDB.EQ.'OFF')GOTO1689 15350 WRITE(ICOUT,999) 15351 CALL DPWRST('XXX','BUG ') 15352 WRITE(ICOUT,1681) 15353 1681 FORMAT('THE TIC MARK THICKNESS (FOR ALL ', 15354 1'FRAME LINES)') 15355 CALL DPWRST('XXX','BUG ') 15356 WRITE(ICOUT,1682)PHOLD 15357 1682 FORMAT('HAS JUST BEEN SET TO ',E15.7) 15358 CALL DPWRST('XXX','BUG ') 15359 1689 CONTINUE 15360 GOTO1900 15361C 15362 1699 CONTINUE 15363C 15364C ***************************************************** 15365C ** TREAT THE CASE WHEN ** 15366C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 15367C ***************************************************** 15368C 15369 IF(ICOM.EQ.'TIC')GOTO1700 15370 IF(ICOM.EQ.'TICS')GOTO1700 15371 IF(ICOM.EQ.'XYTI')GOTO1700 15372 IF(ICOM.EQ.'YXTI')GOTO1700 15373 GOTO1799 15374C 15375 1700 CONTINUE 15376 IF(IHARG(NUMARG).EQ.'ON')GOTO1750 15377 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 15378 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 15379 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 15380 IF(IHARG(NUMARG).EQ.'THIC')GOTO1750 15381 GOTO1760 15382C 15383 1750 CONTINUE 15384 PHOLD=PDEFTH 15385 GOTO1780 15386C 15387 1760 CONTINUE 15388 PHOLD=ARG(NUMARG) 15389 GOTO1780 15390C 15391 1780 CONTINUE 15392 IFOUND='YES' 15393 PTICTH=PHOLD 15394C 15395 IF(IFEEDB.EQ.'OFF')GOTO1789 15396 WRITE(ICOUT,999) 15397 CALL DPWRST('XXX','BUG ') 15398 WRITE(ICOUT,1781) 15399 1781 FORMAT('THE TIC MARK THICKNESS (FOR ALL 4 ', 15400 1'FRAME LINES)') 15401 CALL DPWRST('XXX','BUG ') 15402 WRITE(ICOUT,1782)PHOLD 15403 1782 FORMAT('HAS JUST BEEN SET TO ',E15.7) 15404 CALL DPWRST('XXX','BUG ') 15405 1789 CONTINUE 15406 GOTO1900 15407C 15408 1799 CONTINUE 15409C 15410 1900 CONTINUE 15411 RETURN 15412 END 15413 SUBROUTINE DPTEBA(IHARG,IARGT,ARG,NUMARG,ADETBA,MAXTEX,ATEXBA, 15414 1IBUGP2,IFOUND,IERROR) 15415C 15416C PURPOSE--DEFINE THE TEXT BASES. 15417C THESE ARE LOCATED IN THE VECTOR ATEXBA(.). 15418C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 15419C --IARGT (A CHARACTER VECTOR) 15420C --ARG 15421C --NUMARG 15422C --ADETBA 15423C --MAXTEX 15424C --IBUGP2 ('ON' OR 'OFF' ) 15425C OUTPUT ARGUMENTS--ATEXBA (A FLOATING POINT VECTOR) 15426C --IFOUND ('YES' OR 'NO' ) 15427C --IERROR ('YES' OR 'NO' ) 15428C WRITTEN BY--JAMES J. FILLIBEN 15429C STATISTICAL ENGINEERING DIVISION 15430C INFORMATION TECHNOLOGY LABORATORY 15431C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 15432C GAITHERSBURG, MD 20899-8980 15433C PHONE--301-975-2899 15434C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 15435C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 15436C LANGUAGE--ANSI FORTRAN (1977) 15437C VERSION NUMBER--82/7 15438C ORIGINAL VERSION--DECEMBER 1983. 15439C 15440C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 15441C 15442 CHARACTER*4 IHARG 15443 CHARACTER*4 IARGT 15444C 15445 CHARACTER*4 IBUGP2 15446 CHARACTER*4 IFOUND 15447 CHARACTER*4 IERROR 15448C 15449 CHARACTER*4 IHOLD1 15450C 15451 CHARACTER*4 ISUBN1 15452 CHARACTER*4 ISUBN2 15453 CHARACTER*4 ISTEPN 15454C 15455 DIMENSION IHARG(*) 15456 DIMENSION IARGT(*) 15457 DIMENSION ARG(*) 15458 DIMENSION ATEXBA(*) 15459C 15460C-----COMMON---------------------------------------------------------- 15461C 15462 INCLUDE 'DPCOP2.INC' 15463C 15464C-----START POINT----------------------------------------------------- 15465C 15466 IFOUND='NO' 15467 IERROR='NO' 15468 ISUBN1='DPTE' 15469 ISUBN2='BA ' 15470C 15471 NUMTEX=0 15472 IHOLD1='-999' 15473 HOLD1=-999.0 15474 HOLD2=-999.0 15475C 15476 IF(IBUGP2.EQ.'OFF')GOTO90 15477 WRITE(ICOUT,999) 15478 999 FORMAT(1X) 15479 CALL DPWRST('XXX','BUG ') 15480 WRITE(ICOUT,51) 15481 51 FORMAT('***** AT THE BEGINNING OF DPTEBA--') 15482 CALL DPWRST('XXX','BUG ') 15483 WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 15484 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 15485 CALL DPWRST('XXX','BUG ') 15486 WRITE(ICOUT,53)MAXTEX,NUMTEX 15487 53 FORMAT('MAXTEX,NUMTEX = ',I8,I8) 15488 CALL DPWRST('XXX','BUG ') 15489 WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2 15490 54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) 15491 CALL DPWRST('XXX','BUG ') 15492 WRITE(ICOUT,55)ADETBA 15493 55 FORMAT('ADETBA = ',E15.7) 15494 CALL DPWRST('XXX','BUG ') 15495 WRITE(ICOUT,60)NUMARG 15496 60 FORMAT('NUMARG = ',I8) 15497 CALL DPWRST('XXX','BUG ') 15498 DO65I=1,NUMARG 15499 WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I) 15500 66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) 15501 CALL DPWRST('XXX','BUG ') 15502 65 CONTINUE 15503 WRITE(ICOUT,70)ATEXBA(1) 15504 70 FORMAT('ATEXBA(1) = ',E15.7) 15505 CALL DPWRST('XXX','BUG ') 15506 DO75I=1,10 15507 WRITE(ICOUT,76)I,ATEXBA(I) 15508 76 FORMAT('I,ATEXBA(I) = ',I8,2X,E15.7) 15509 CALL DPWRST('XXX','BUG ') 15510 75 CONTINUE 15511 90 CONTINUE 15512C 15513C ************************************** 15514C ** STEP 1-- ** 15515C ** BRANCH TO THE APPROPRIATE CASE ** 15516C ************************************** 15517C 15518 ISTEPN='1' 15519 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 15520C 15521 IF(NUMARG.LE.0)GOTO9000 15522 IF(NUMARG.EQ.1)GOTO1110 15523 IF(NUMARG.EQ.2)GOTO1120 15524 IF(NUMARG.EQ.3)GOTO1130 15525 GOTO1140 15526C 15527 1110 CONTINUE 15528 GOTO1200 15529C 15530 1120 CONTINUE 15531 IF(IHARG(2).EQ.'ALL')IHOLD1=' ' 15532 IF(IHARG(2).EQ.'ALL')HOLD1=ADETBA 15533 IF(IHARG(2).EQ.'ALL')GOTO1300 15534 GOTO1200 15535C 15536 1130 CONTINUE 15537 IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3) 15538 IF(IHARG(2).EQ.'ALL')HOLD1=ARG(3) 15539 IF(IHARG(2).EQ.'ALL')GOTO1300 15540 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2) 15541 IF(IHARG(3).EQ.'ALL')HOLD1=ARG(2) 15542 IF(IHARG(3).EQ.'ALL')GOTO1300 15543 GOTO1200 15544C 15545 1140 CONTINUE 15546 GOTO1200 15547C 15548C ************************************************* 15549C ** STEP 2-- ** 15550C ** TREAT THE SINGLE SPECIFICATION CASE ** 15551C ************************************************* 15552C 15553 1200 CONTINUE 15554 ISTEPN='2' 15555 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 15556C 15557 IF(NUMARG.LE.1)GOTO1210 15558 GOTO1220 15559C 15560 1210 CONTINUE 15561 NUMTEX=1 15562 ATEXBA(1)=ADETBA 15563 GOTO1270 15564C 15565 1220 CONTINUE 15566 NUMTEX=NUMARG-1 15567 IF(NUMTEX.GT.MAXTEX)NUMTEX=MAXTEX 15568 DO1225I=1,NUMTEX 15569 J=I+1 15570 IHOLD1=IHARG(J) 15571 HOLD1=ARG(J) 15572 HOLD2=HOLD1 15573 IF(IHOLD1.EQ.'ON')HOLD2=ADETBA 15574 IF(IHOLD1.EQ.'OFF')HOLD2=ADETBA 15575 IF(IHOLD1.EQ.'AUTO')HOLD2=ADETBA 15576 IF(IHOLD1.EQ.'DEFA')HOLD2=ADETBA 15577 ATEXBA(I)=HOLD2 15578 1225 CONTINUE 15579 GOTO1270 15580C 15581 1270 CONTINUE 15582 IF(IFEEDB.EQ.'OFF')GOTO1279 15583 WRITE(ICOUT,999) 15584 CALL DPWRST('XXX','BUG ') 15585 DO1278I=1,NUMTEX 15586 WRITE(ICOUT,1276)I,ATEXBA(I) 15587 1276 FORMAT('THE BASE OF TEXT ',I6, 15588 1' HAS JUST BEEN SET TO ',E15.7) 15589 CALL DPWRST('XXX','BUG ') 15590 1278 CONTINUE 15591 1279 CONTINUE 15592 IFOUND='YES' 15593 GOTO9000 15594C 15595C ************************** 15596C ** STEP 3-- ** 15597C ** TREAT THE ALL CASE ** 15598C ************************** 15599C 15600 1300 CONTINUE 15601 ISTEPN='3' 15602 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 15603C 15604 NUMTEX=MAXTEX 15605 HOLD2=HOLD1 15606 IF(IHOLD1.EQ.'ON')HOLD2=ADETBA 15607 IF(IHOLD1.EQ.'OFF')HOLD2=ADETBA 15608 IF(IHOLD1.EQ.'AUTO')HOLD2=ADETBA 15609 IF(IHOLD1.EQ.'DEFA')HOLD2=ADETBA 15610 DO1315I=1,NUMTEX 15611 ATEXBA(I)=HOLD2 15612 1315 CONTINUE 15613 GOTO1370 15614C 15615 1370 CONTINUE 15616 IF(IFEEDB.EQ.'OFF')GOTO1319 15617 WRITE(ICOUT,999) 15618 CALL DPWRST('XXX','BUG ') 15619 I=1 15620 WRITE(ICOUT,1316)ATEXBA(I) 15621 1316 FORMAT('THE BASE OF ALL TEXTS', 15622 1' HAS JUST BEEN SET TO ',E15.7) 15623 CALL DPWRST('XXX','BUG ') 15624 1319 CONTINUE 15625 IFOUND='YES' 15626 GOTO9000 15627C 15628C ***************** 15629C ** STEP 90-- ** 15630C ** EXIT ** 15631C ***************** 15632C 15633 9000 CONTINUE 15634 IF(IBUGP2.EQ.'OFF')GOTO9090 15635 WRITE(ICOUT,9011) 15636 9011 FORMAT('***** AT THE END OF DPTEBA--') 15637 CALL DPWRST('XXX','BUG ') 15638 WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 15639 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 15640 CALL DPWRST('XXX','BUG ') 15641 WRITE(ICOUT,9013)MAXTEX,NUMTEX 15642 9013 FORMAT('MAXTEX,NUMTEX = ',I8,I8) 15643 CALL DPWRST('XXX','BUG ') 15644 WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2 15645 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) 15646 CALL DPWRST('XXX','BUG ') 15647 WRITE(ICOUT,9015)ADETBA 15648 9015 FORMAT('ADETBA = ',E15.7) 15649 CALL DPWRST('XXX','BUG ') 15650 WRITE(ICOUT,9020)NUMARG 15651 9020 FORMAT('NUMARG = ',I8) 15652 CALL DPWRST('XXX','BUG ') 15653 DO9025I=1,NUMARG 15654 WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I) 15655 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) 15656 CALL DPWRST('XXX','BUG ') 15657 9025 CONTINUE 15658 WRITE(ICOUT,9030)ATEXBA(1) 15659 9030 FORMAT('ATEXBA(1) = ',E15.7) 15660 CALL DPWRST('XXX','BUG ') 15661 DO9035I=1,10 15662 WRITE(ICOUT,9036)I,ATEXBA(I) 15663 9036 FORMAT('I,ATEXBA(I) = ',I8,2X,E15.7) 15664 CALL DPWRST('XXX','BUG ') 15665 9035 CONTINUE 15666 9090 CONTINUE 15667C 15668 RETURN 15669 END 15670 SUBROUTINE DPTECH(IHARG,NUMARG, 15671 1IDEFTC, 15672 1ITERCH, 15673 1IBUGS2,IFOUND,IERROR) 15674C 15675C PURPOSE--DEFINE THE TERMINATOR CHARACTOR WHICH MAY 15676C BE USED TO PUT MULTIPLE COMMAND STATEMENTS 15677C ON A SINGLE COMMAND LINE. 15678C WHEN A COMMAND LINE IS READ, 15679C IT IS SEARCHED FOR THE TERMINATOR CHARACTER; 15680C IF IT IS FOUND, THE COMMAND STATEMENT 15681C BEFORE THE TERMINATOR CHARACTOR IS EXECUTED; 15682C AFTER EXECUTION, THE COMMAND STAEMENT AFTER THE 15683C TERMINATOR CHARACTOR IS EXECUTED. 15684C ANY NUMBER OF TERMINATOR CHARACTORS ARE ALLOWED PER LINE. 15685C THE COMMAND CHARACTER CAPABILITY ALLOWS THE ANALYST 15686C TO PACK SEVERAL COMMANDS PER LINE. 15687C THE SPECIFIED TERMINATOR CHARACTOR WILL BE PLACED 15688C IN THE CHARACTER VARIABLE ITERCH. 15689C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 15690C --NUMARG (AN INTEGER VARIABLE) 15691C --IDEFTC (A CHARACTER VARIABLE) 15692C --IBUGS2 (A CHARACTER VARIABLE) 15693C OUTPUT ARGUMENTS--ITERCH (A CHARACTER VARIABLE) 15694C --IFOUND ('YES' OR 'NO' ) 15695C --IERROR ('YES' OR 'NO' ) 15696C WRITTEN BY--JAMES J. FILLIBEN 15697C STATISTICAL ENGINEERING DIVISION 15698C INFORMATION TECHNOLOGY LABORATORY 15699C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 15700C GAITHERSBURG, MD 20899-8980 15701C PHONE--301-975-2899 15702C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 15703C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 15704C LANGUAGE--ANSI FORTRAN (1977) 15705C VERSION NUMBER--82/7 15706C ORIGINAL VERSION--NOVEMBER 1980. 15707C UPDATED --MAY 1982. 15708C 15709C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 15710C 15711 CHARACTER*4 IHARG 15712 CHARACTER*4 IDEFTC 15713 CHARACTER*4 ITERCH 15714 CHARACTER*4 IBUGS2 15715 CHARACTER*4 IFOUND 15716 CHARACTER*4 IERROR 15717C 15718 CHARACTER*4 IHOLD 15719C 15720C--------------------------------------------------------------------- 15721C 15722 DIMENSION IHARG(*) 15723C 15724C-----COMMON---------------------------------------------------------- 15725C 15726 INCLUDE 'DPCOP2.INC' 15727C 15728C-----START POINT----------------------------------------------------- 15729C 15730 IF(IBUGS2.EQ.'OFF')GOTO90 15731 WRITE(ICOUT,999) 15732 999 FORMAT(1X) 15733 CALL DPWRST('XXX','BUG ') 15734 WRITE(ICOUT,51) 15735 51 FORMAT('***** AT THE BEGINNING OF DPTECH--') 15736 CALL DPWRST('XXX','BUG ') 15737 WRITE(ICOUT,53)IDEFTC 15738 53 FORMAT('IDEFTC = ',A4) 15739 CALL DPWRST('XXX','BUG ') 15740 WRITE(ICOUT,54)NUMARG 15741 54 FORMAT('NUMARG = ',I8) 15742 CALL DPWRST('XXX','BUG ') 15743 DO55I=1,NUMARG 15744 WRITE(ICOUT,56)I,IHARG(I) 15745 56 FORMAT('I,IHARG(I) = ',I8,2X,A4) 15746 CALL DPWRST('XXX','BUG ') 15747 55 CONTINUE 15748 90 CONTINUE 15749C 15750 IFOUND='NO' 15751 IERROR='NO' 15752C 15753 IF(NUMARG.LE.0)GOTO1150 15754 GOTO1110 15755C 15756 1110 CONTINUE 15757 IF(NUMARG.LE.1)GOTO1150 15758 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 15759 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 15760 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 15761 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 15762 GOTO1160 15763C 15764 1150 CONTINUE 15765 IHOLD=IDEFTC 15766 GOTO1180 15767C 15768 1160 CONTINUE 15769 IHOLD=IHARG(NUMARG) 15770 GOTO1180 15771C 15772 1180 CONTINUE 15773 IFOUND='YES' 15774 ITERCH=IHOLD 15775C 15776 IF(IFEEDB.EQ.'OFF')GOTO1189 15777 WRITE(ICOUT,999) 15778 CALL DPWRST('XXX','BUG ') 15779 WRITE(ICOUT,1181)ITERCH 15780 1181 FORMAT('THE TERMINATOR CHARACTOR HAVE JUST BEEN SET TO ', 15781 1A4) 15782 CALL DPWRST('XXX','BUG ') 15783 1189 CONTINUE 15784 GOTO9000 15785C 15786 9000 CONTINUE 15787 IF(IBUGS2.EQ.'OFF')GOTO9090 15788 WRITE(ICOUT,999) 15789 CALL DPWRST('XXX','BUG ') 15790 WRITE(ICOUT,9011) 15791 9011 FORMAT('***** AT THE END OF DPECH--') 15792 CALL DPWRST('XXX','BUG ') 15793 WRITE(ICOUT,9012)IBUGS2,IFOUND,IERROR 15794 9012 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 15795 CALL DPWRST('XXX','BUG ') 15796 WRITE(ICOUT,9013)IDEFTC,ITERCH 15797 9013 FORMAT('IDEFTC,ITERCH = ',A4,2X,A4) 15798 CALL DPWRST('XXX','BUG ') 15799 9090 CONTINUE 15800C 15801 RETURN 15802 END 15803 SUBROUTINE DPTEXT(IANS,IANSLC,IWIDTH, 15804 1 ITEXTE,NCTEX, 15805 1 PXSTAR,PYSTAR,PXEND,PYEND, 15806 1 IGRASW,IDIASW,PRV,PDIARV, 15807 1 ILINPA,ILINCO,PLINTH, 15808 1 ATEXBA,ITEBLI,ITEBCO,PTEBTH, 15809 1 ITEFSW,ITEFCO, 15810 1 ITEPTY,ITEPLI,ITEPCO,PTEPTH,PTEPSP, 15811 1 PTEXMR,ITEXCV,ATEXAN,PTEXRV, 15812 1 IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 15813 1 IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, 15814 1 NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3, 15815 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 15816 1 IDNVOF,IDNHOF,IDFONT,PDSCAL, 15817 1 IMPSW2,AMPSCH,AMPSCW, 15818 1 IBUGD2,IFOUND,IERROR) 15819C 15820C PURPOSE--WRITE OUT A TEXT STRING. 15821C 15822C WRITTEN BY--JAMES J. FILLIBEN 15823C STATISTICAL ENGINEERING DIVISION 15824C INFORMATION TECHNOLOGY LABORATORY 15825C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 15826C GAITHERSBURG, MD 20899-8980 15827C PHONE--301-975-2899 15828C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 15829C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 15830C LANGUAGE--ANSI FORTRAN (1977) 15831C VERSION NUMBER--83.6 15832C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. 15833C UPDATED --DECEMBER 1986. 15834C UPDATED --JULY 1988. 15835C UPDATED --JANUARY 1989. CALL LIST FOR OFFSET 15836C VARIABLES (ALAN) 15837C UPDATED --MARCH 1993. 15838C UPDATED --SEPTEMBER 1993. ALLOW LOWER CASE 15839C UPDATED --MARCH 1997. DEVICE FONT SUPPORT 15840C UPDATED --DECEMBER 2018. SUPPORT FOR DEVICE ... SCALE 15841C COMMAND (PDSCAL TO CALL LIST) 15842C 15843C-----NON-COMMON VARIABLES (GRAPHICS)----------------------------------- 15844C 15845 CHARACTER*4 IANS 15846CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1993 15847CCCCC TO ALLOW FOR LOWER CASE SEPTEMBER 1993 15848 CHARACTER*4 IANSLC 15849C 15850 CHARACTER*4 IGRASW 15851 CHARACTER*4 IDIASW 15852C 15853 CHARACTER*4 ILINPA 15854 CHARACTER*4 ILINCO 15855C 15856 CHARACTER*4 ITEBLI 15857 CHARACTER*4 ITEBCO 15858 CHARACTER*4 ITEFSW 15859 CHARACTER*4 ITEFCO 15860 CHARACTER*4 ITEPTY 15861 CHARACTER*4 ITEPLI 15862 CHARACTER*4 ITEPCO 15863C 15864 CHARACTER*4 ITEXTE 15865 CHARACTER*4 ITEXFO 15866 CHARACTER*4 ITEXCA 15867 CHARACTER*4 ITEXJU 15868 CHARACTER*4 ITEXDI 15869 CHARACTER*4 ITEXFI 15870 CHARACTER*4 ITEXCO 15871C 15872 CHARACTER*4 ITEXCR 15873 CHARACTER*4 ITEXLF 15874C 15875 CHARACTER*4 ITEXSY 15876 CHARACTER*4 ITEXSP 15877C 15878 CHARACTER*4 IHNAME 15879 CHARACTER*4 IHNAM2 15880 CHARACTER*4 IUSE 15881 CHARACTER*4 IFUNC 15882C 15883 CHARACTER*1 IREPCH 15884C 15885 CHARACTER*4 IMPSW2 15886C 15887 CHARACTER*4 IDMANU 15888 CHARACTER*4 IDMODE 15889 CHARACTER*4 IDMOD2 15890 CHARACTER*4 IDMOD3 15891 CHARACTER*4 IDPOWE 15892 CHARACTER*4 IDCONT 15893 CHARACTER*4 IDCOLO 15894CCCCC ADD FOLLOWING LINE MARCH 1997. 15895 CHARACTER*4 IDFONT 15896C 15897 CHARACTER*4 IBUGD2 15898 CHARACTER*4 IFOUND 15899 CHARACTER*4 IERROR 15900C 15901 CHARACTER*4 IBELSW 15902 CHARACTER*4 IERASW 15903 CHARACTER*4 ICOPSW 15904 CHARACTER*4 IBACCO 15905C 15906 CHARACTER*4 ICTEXT 15907C 15908 CHARACTER*4 IFONT 15909 CHARACTER*4 ICASE 15910 CHARACTER*4 IJUST 15911 CHARACTER*4 IDIR 15912 CHARACTER*4 IFILL 15913 CHARACTER*4 ICOL 15914C 15915 CHARACTER*24 ISYMBL 15916 CHARACTER*4 ISPAC 15917C 15918 CHARACTER*4 ITEXCV 15919C 15920 DIMENSION PRV(6) 15921 DIMENSION PDIARV(4) 15922 DIMENSION ITEXCV(10) 15923 DIMENSION PTEXRV(5) 15924C 15925 DIMENSION IANS(*) 15926CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1993 15927CCCCC TO ALLOW FOR LOWER CASE SEPTEMBER 1993 15928 DIMENSION IANSLC(*) 15929C 15930 DIMENSION ILINPA(*) 15931 DIMENSION ILINCO(*) 15932 DIMENSION PLINTH(*) 15933C 15934 DIMENSION ATEXBA(*) 15935 DIMENSION ITEBLI(*) 15936 DIMENSION ITEBCO(*) 15937 DIMENSION PTEBTH(*) 15938 DIMENSION ITEFSW(*) 15939 DIMENSION ITEFCO(*) 15940 DIMENSION ITEPTY(*) 15941 DIMENSION ITEPLI(*) 15942 DIMENSION ITEPCO(*) 15943 DIMENSION PTEPTH(*) 15944 DIMENSION PTEPSP(*) 15945 DIMENSION PDSCAL(*) 15946C 15947 DIMENSION ITEXTE(*) 15948C 15949 DIMENSION IHNAME(*) 15950 DIMENSION IHNAM2(*) 15951 DIMENSION IUSE(*) 15952 DIMENSION IVALUE(*) 15953 DIMENSION VALUE(*) 15954 DIMENSION IVSTAR(*) 15955 DIMENSION IVSTOP(*) 15956 DIMENSION IFUNC(*) 15957C 15958C 15959 DIMENSION IDMANU(*) 15960 DIMENSION IDMODE(*) 15961 DIMENSION IDMOD2(*) 15962 DIMENSION IDMOD3(*) 15963 DIMENSION IDPOWE(*) 15964 DIMENSION IDCONT(*) 15965 DIMENSION IDCOLO(*) 15966CCCCC ADD FOLLOWING LINE MARCH 1997. 15967 DIMENSION IDFONT(*) 15968 DIMENSION IDNVPP(*) 15969 DIMENSION IDNHPP(*) 15970 DIMENSION IDUNIT(*) 15971C 15972 DIMENSION IDNVOF(*) 15973 DIMENSION IDNHOF(*) 15974C 15975CCCCC DIMENSION ICTEXT(130) 15976 INCLUDE 'DPCOPA.INC' 15977 DIMENSION ICTEXT(MAXCH) 15978C 15979C-----COMMON---------------------------------------------------------- 15980C 15981 INCLUDE 'DPCOGR.INC' 15982 INCLUDE 'DPCOBE.INC' 15983 INCLUDE 'DPCOP2.INC' 15984C 15985C-----START POINT----------------------------------------------------- 15986C 15987 PGRAXF=PRV(1) 15988 PGRAYF=PRV(2) 15989 PDIAXC=PRV(3) 15990 PDIAYC=PRV(4) 15991 PDIAX2=PRV(5) 15992 PDIAY2=PRV(6) 15993C 15994 PDIAHE=PDIARV(1) 15995 PDIAWI=PDIARV(2) 15996 PDIAVG=PDIARV(3) 15997 PDIAHG=PDIARV(4) 15998C 15999 ITEXFO=ITEXCV(1) 16000 ITEXCA=ITEXCV(2) 16001 ITEXJU=ITEXCV(3) 16002 ITEXDI=ITEXCV(4) 16003 ITEXCR=ITEXCV(5) 16004 ITEXLF=ITEXCV(6) 16005 ITEXSY=ITEXCV(7) 16006 ITEXSP=ITEXCV(8) 16007 ITEXFI=ITEXCV(9) 16008 ITEXCO=ITEXCV(10) 16009C 16010 PTEXHE=PTEXRV(1) 16011 PTEXWI=PTEXRV(2) 16012 PTEXVG=PTEXRV(3) 16013 PTEXHG=PTEXRV(4) 16014 PTEXTH=PTEXRV(5) 16015C 16016 IFOUND='NO' 16017 IERROR='NO' 16018C 16019 J2=0 16020C 16021 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'TEXT')THEN 16022 WRITE(ICOUT,999) 16023 999 FORMAT(1X) 16024 CALL DPWRST('XXX','BUG ') 16025 WRITE(ICOUT,51) 16026 51 FORMAT('***** AT THE BEGINNING OF DPTEXT--') 16027 CALL DPWRST('XXX','BUG ') 16028 WRITE(ICOUT,53)IWIDTH,NUMNAM,NUMDEV 16029 53 FORMAT('IWIDTH,NUMNAM,NUMDEV= ',3I8) 16030 CALL DPWRST('XXX','BUG ') 16031 WRITE(ICOUT,54)(IANS(I),I=1,MIN(25,IWIDTH)) 16032 54 FORMAT('(IANS(I),I=1,IWIDTH) = ',25A4) 16033 CALL DPWRST('XXX','BUG ') 16034 WRITE(ICOUT,58)IDIASW,PDIAXC,PDIAYC 16035 58 FORMAT('IDIASW,PDIAXC,PDIAYC = ',A4,2X,2G15.7) 16036 CALL DPWRST('XXX','BUG ') 16037 WRITE(ICOUT,60)PXSTAR,PYSTAR,PXEND,PYEND 16038 60 FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4G15.7) 16039 CALL DPWRST('XXX','BUG ') 16040 WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1) 16041 61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',2(A4,2X),G15.7) 16042 CALL DPWRST('XXX','BUG ') 16043 WRITE(ICOUT,62)ATEXBA(1),PTEBTH(1) 16044 62 FORMAT('ATEXBA(1),PTEBTH(1) = ',2G15.7) 16045 CALL DPWRST('XXX','BUG ') 16046 WRITE(ICOUT,63)ITEBLI(1),ITEBCO(1),ITEFSW(1),ITEFCO(1) 16047 63 FORMAT('ITEBLI(1),ITEBCO(1),ITEFSW(1),ITEFCO = ',3(A4,2X),A4) 16048 CALL DPWRST('XXX','BUG ') 16049 WRITE(ICOUT,65)ITEPTY(1),ITEPLI(1),ITEPCO(1),PTEPTH(1),PTEPSP(1) 16050 65 FORMAT('ITEPTY(1),ITEPLI(1),ITEPCO(1),PTEPTH(1),PTEPSP(1) = ', 16051 1 3(A4,2X),2G15.7) 16052 CALL DPWRST('XXX','BUG ') 16053 WRITE(ICOUT,66)ITEXCR,ITEXLF,PTEXMR 16054 66 FORMAT('ITEXCR,ITEXLF,PTEXMR = ',2(A4,2X),G15.7) 16055 CALL DPWRST('XXX','BUG ') 16056 WRITE(ICOUT,67)ITEXSY,ITEXSP,ITEXFO,ITEXCA,ITEXJU 16057 67 FORMAT('ITEXSY,ITEXSP,ITEXFO,ITEXCA,ITEXJU = ',4(A4,2X),A4) 16058 CALL DPWRST('XXX','BUG ') 16059 WRITE(ICOUT,68)ITEXDI,ATEXAN,ITEXFI,ITEXCO 16060 68 FORMAT('ITEXDI,ATEXAN,ITEXFI,ITEXCO = ',3(A4,2X),A4) 16061 CALL DPWRST('XXX','BUG ') 16062 WRITE(ICOUT,70)PTEXHE,PTEXWI,PTEXVG,PTEXHG,PTEXTH 16063 70 FORMAT('PTEXHE,PTEXWI,PTEXVG,PTEXHG,PTEXTH= ',5G15.7) 16064 CALL DPWRST('XXX','BUG ') 16065 DO76I=1,NUMNAM 16066 WRITE(ICOUT,77)I,IHNAME(I),IHNAM2(I),IUSE(I), 16067 1 IVALUE(I),VALUE(I) 16068 77 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I)= ', 16069 1 I8,3(2X,A4),I8,G15.7) 16070 CALL DPWRST('XXX','BUG ') 16071 76 CONTINUE 16072 DO81I=1,NUMDEV 16073 WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) 16074 82 FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ', 16075 1 3(A4,2X),A4) 16076 CALL DPWRST('XXX','BUG ') 16077 WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I) 16078 83 FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ',2(A4,2X),A4) 16079 CALL DPWRST('XXX','BUG ') 16080 WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I) 16081 84 FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ',3I8) 16082 CALL DPWRST('XXX','BUG ') 16083 81 CONTINUE 16084 WRITE(ICOUT,87)ISUBG4,IERRG4,IBUGD2,IFOUND,IERROR,IREPCH 16085 87 FORMAT('ISUBG4,IERRG4,IBUGD2,IFOUND,IERROR,IREPCH = ', 16086 1 5(A4,2X),A1) 16087 CALL DPWRST('XXX','BUG ') 16088 ENDIF 16089C 16090C ***************************************************** 16091C ** STEP 1-- ** 16092C ** EXTRACT THE TEXT STRING FROM THE COMMAND LINE ** 16093C ***************************************************** 16094C 16095C ***************************************** 16096C ** STEP 1.1-- ** 16097C ** DETERMINE THE COMMAND ** 16098C ** (TEXT) AND ITS LOCATION ** 16099C ** ON THE LINE. ** 16100C ** DETERMINE THE START POSITION ** 16101C ** (XSTART) OF THE FIRST CHARACTER ** 16102C ** FOR THE STRING TO BE PRINTED. ** 16103C ***************************************** 16104C 16105 DO1115I=1,IWIDTH 16106 IP1=I+1 16107 IP2=I+2 16108 IP3=I+3 16109 IP4=I+4 16110 IP5=I+5 16111C 16112 IF(IP3.EQ.IWIDTH)GOTO1190 16113 IF(IP4.EQ.IWIDTH)GOTO1190 16114 IF(IANS(I).EQ.'T'.AND.IANS(IP1).EQ.'E'.AND. 16115 1 IANS(IP2).EQ.'X'.AND.IANS(IP3).EQ.'T'.AND. 16116 1 IANS(IP4).EQ.' ')GOTO1190 16117 1115 CONTINUE 16118C 16119 WRITE(ICOUT,1131) 16120 1131 FORMAT('***** ERROR IN DPTEXT--') 16121 CALL DPWRST('XXX','BUG ') 16122 WRITE(ICOUT,1132) 16123 1132 FORMAT(' NO MATCH FOR COMMAND.') 16124 CALL DPWRST('XXX','BUG ') 16125 IERROR='YES' 16126 GOTO9000 16127C 16128 1190 CONTINUE 16129C 16130C ******************************************************** 16131C ** STEP 1.2-- ** 16132C ** DEFINE THE STOP POSITION (ISTOP) FOR THE STRING. ** 16133C ******************************************************** 16134C 16135 IFOUND='YES' 16136C 16137 ISTART=IP5 16138 ISTOP=0 16139 IF(ISTART.LE.IWIDTH)THEN 16140 DO1220I=ISTART,IWIDTH 16141 IREV=IWIDTH-I+ISTART 16142 IF(IANS(IREV).NE.' ')THEN 16143 ISTOP=IREV 16144 GOTO1225 16145 ENDIF 16146 1220 CONTINUE 16147 1225 CONTINUE 16148 ENDIF 16149C 16150C ***************************************** 16151C ** STEP 1.3-- ** 16152C ** COPY OVER THE STRING OF INTEREST. ** 16153C ***************************************** 16154C 16155 IF(ISTART.GT.ISTOP .OR. ISTOP.EQ.0)THEN 16156 NCTEX=0 16157 ELSE 16158C SEPTEMBER, 1987 (CHECK IF MAXIMUM SIZE STRING EXCEEDED) 16159 ITEMP=ISTOP-ISTART+1 16160 IF(ITEMP.GT.MAXCH)ITEMP=MAXCH 16161 ISTOP=ISTART+ITEMP-1 16162C 16163 J=0 16164 DO1310I=ISTART,ISTOP 16165 J=J+1 16166 J2=J 16167CCCCC THE FOLLOWING LINE WAS CHANGED SEPTEMBER 1993 16168CCCCC TO ALLOW FOR LOWER CASE SEPTEMBER 1993 16169CCCCC CHECK FOR CASE "ASIS" OCTOBER 1993 16170CCCCC ITEXTE(J)=IANS(I) 16171 IF(ITEXCA.EQ.'ASIS')THEN 16172 ITEXTE(J)=IANSLC(I) 16173 ELSE 16174 ITEXTE(J)=IANS(I) 16175 ENDIF 16176 1310 CONTINUE 16177 NCTEX=J2 16178 ENDIF 16179C 16180C ****************************************** 16181C ** STEP 1.4-- ** 16182C ** COPY OVER THE ORIGINAL TEXT STRING ** 16183C ** SO AS TO PRESERVE IT IN COMMON. ** 16184C ****************************************** 16185C 16186 NCTEXT=NCTEX 16187 IF(NCTEX.GT.0)THEN 16188 DO1410I=1,NCTEX 16189 ICTEXT(I)=ITEXTE(I) 16190 1410 CONTINUE 16191 ENDIF 16192C 16193C ****************************************************** 16194C ** STEP 1.4-- ** 16195C ** CALL THE SUBROUTINE DPREPL ** 16196C ** WHICH WILL SCAN THE STRING FOR ALL OCCURRANCES ** 16197C ** OF THE SUBSTRING VALU() ** 16198C ** AND REPLACE THEM BY THEIR LITERAL VALUES. ** 16199C ****************************************************** 16200C 16201 IF(NCTEXT.GE.1)CALL DPREPL(ICTEXT,NCTEXT, 16202 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 16203 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, 16204 1IBUGD2,IERROR) 16205C 16206C ******************************** 16207C ** STEP 2-- ** 16208C ** STEP THROUGH EACH DEVICE ** 16209C ******************************** 16210C 16211 IF(NUMDEV.LE.0)GOTO9000 16212C JULY, 1988. BUG: IF DEVICE 1 OFF AND DEVICE 2 ON, 16213C STARTING COORDINATES PX1 AND PY1 WERE NOT GETTING SET. 16214C MOVE FROM INSIDE LOOP TO HERE. 16215 PX1=PXSTAR 16216 PY1=PYSTAR 16217C END BUG FIX 16218 DO8000IDEVIC=1,NUMDEV 16219C 16220 IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000 16221 IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000 16222 IF(IDMANU(IDEVIC).EQ.'OFF')GOTO8000 16223 IF(IDMANU(IDEVIC).EQ.'NULL')GOTO8000 16224 IF(IDMANU(IDEVIC).EQ.'NONE')GOTO8000 16225 IF(IDMANU(IDEVIC).EQ.'DISC')GOTO8000 16226C 16227 IMANUF=IDMANU(IDEVIC) 16228 IMODEL=IDMODE(IDEVIC) 16229 IMODE2=IDMOD2(IDEVIC) 16230 IMODE3=IDMOD3(IDEVIC) 16231 IGCOLO=IDCOLO(IDEVIC) 16232 IGFONT=IDFONT(IDEVIC) 16233 NUMVPP=IDNVPP(IDEVIC) 16234 NUMHPP=IDNHPP(IDEVIC) 16235 ANUMVP=NUMVPP 16236 ANUMHP=NUMHPP 16237 IOFFSV=IDNVOF(IDEVIC) 16238 IOFFSH=IDNHOF(IDEVIC) 16239 IGUNIT=IDUNIT(IDEVIC) 16240 PCHSCA=PDSCAL(IDEVIC) 16241C 16242C ************************************ 16243C ** STEP 3-- ** 16244C ** CARRY OUT OPENING OPERATIONS ** 16245C ** ON THE GRAPHICS DEVICES ** 16246C ************************************ 16247C 16248 CALL DPOPDE() 16249C 16250 IBELSW='OFF' 16251 NUMRIN=0 16252 IERASW='OFF' 16253 IBACCO='JUNK' 16254C 16255 CALL DPOPPL(IGRASW,IBELSW,NUMRIN,IERASW,IBACCO) 16256C 16257C ***************************** 16258C ** STEP 4-- ** 16259C ** WRITE OUT THE TEXT ** 16260C ***************************** 16261C 16262 IFONT=ITEXFO 16263 ICASE=ITEXCA 16264 IJUST=ITEXJU 16265 IDIR=ITEXDI 16266 ANGLE=ATEXAN 16267 IFILL=ITEXFI 16268 ICOL=ITEXCO 16269 PHEIGH=PTEXHE 16270 PWIDTH=PTEXWI 16271 PHOGAP=PTEXHG 16272 PVEGAP=PTEXVG 16273 PTHICK=PTEXTH 16274 ISYMBL=ITEXSY 16275 ISPAC=ITEXSP 16276C 16277C JULY, 1988. MOVE FOLLOWING 4 LINES TO BEFORE LOOP. 16278CCCCC IF(IDEVIC.GE.2)GOTO1610 16279CCCCC PX1=PXSTAR 16280CCCCC PY1=PYSTAR 16281C1610 CONTINUE 16282C 16283 IF(NCTEXT.GE.1)CALL DPWRTE(PX1,PY1,ICTEXT,NCTEXT, 16284 1 IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 16285 1 PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK, 16286 1 ISYMBL,ISPAC, 16287 1 IMPSW2,AMPSCH,AMPSCW, 16288 1 PX99,PY99) 16289C 16290CCCCC MARCH 1993. MOVE FOLLOWING SECTION OUTSIDE LOOP. 16291CCCCC IF(IDEVIC.GE.2)GOTO1690 16292CCCCC PXEND=PX99 16293CCCCC PYEND=PY99 16294CCCCC IF(ITEXCR.EQ.'ON')PXEND=PTEXMR 16295CCCCC IF(ITEXLF.EQ.'ON')PYEND=PYSTAR-PTEXHE-PTEXVG 16296C 16297CCCCC PXSTAR=PXEND 16298CCCCC PYSTAR=PYEND 16299C 16300C ************************************ 16301C ** STEP 5-- ** 16302C ** CARRY OUT CLOSING OPERATIONS ** 16303C ** ON THE GRAPHICS DEVICES ** 16304C ************************************ 16305C 16306 ICOPSW='OFF' 16307 NUMCOP=0 16308 CALL DPCLPL(ICOPSW,NUMCOP, 16309 1 PGRAXF,PGRAYF, 16310 1 IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 16311 1 PDIAHE,PDIAWI,PDIAVG,PDIAHG) 16312C 16313 CALL DPCLDE 16314C 16315 8000 CONTINUE 16316C 16317C MARCH, 1993. BUG: IF DEVICE 1 OFF AND DEVICE 2 ON, 16318C NEW VALUES OF PXSTAR AND PYSTAR NOT SET. 16319C MOVE FROM INSIDE LOOP TO HERE. 16320C 16321 PXEND=PX99 16322 PYEND=PY99 16323 IF(ITEXCR.EQ.'ON')PXEND=PTEXMR 16324 IF(ITEXLF.EQ.'ON')PYEND=PYSTAR-PTEXHE-PTEXVG 16325C 16326 PXSTAR=PXEND 16327 PYSTAR=PYEND 16328C END CHANGE 16329C 16330C ***************** 16331C ** STEP 90-- ** 16332C ** EXIT ** 16333C ***************** 16334C 16335 9000 CONTINUE 16336 IERROR=IERRG4 16337 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'TEXT')THEN 16338 WRITE(ICOUT,999) 16339 CALL DPWRST('XXX','BUG ') 16340 WRITE(ICOUT,9011) 16341 9011 FORMAT('***** AT THE END OF DPTEXT--') 16342 CALL DPWRST('XXX','BUG ') 16343 WRITE(ICOUT,9015)NCTEX,NCTEXT 16344 9015 FORMAT('NCTEX,NCTEXT = ',2I8) 16345 CALL DPWRST('XXX','BUG ') 16346 WRITE(ICOUT,9016)(ITEXTE(I),I=1,MIN(25,NCTEX)) 16347 9016 FORMAT('(ITEXTE(I),I =1,NCTEX) = ',25A4) 16348 CALL DPWRST('XXX','BUG ') 16349 WRITE(ICOUT,9018)(ICTEXT(I),I=1,MIN(25,NCTEXT)) 16350 9018 FORMAT('(ICTEXT(I),I=1,NCTEXT) = ',25A4) 16351 CALL DPWRST('XXX','BUG ') 16352 WRITE(ICOUT,9019)PXSTAR,PYSTAR,PXEND,PYEND 16353 9019 FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4G15.7) 16354 CALL DPWRST('XXX','BUG ') 16355 WRITE(ICOUT,9033)PX1,PY1,PX99,PY99 16356 9033 FORMAT('PX1,PY1,PX99,PY99 = ',4G15.7) 16357 CALL DPWRST('XXX','BUG ') 16358 WRITE(ICOUT,9035)IMANUF,IMODEL,IFOUND 16359 9035 FORMAT('IMANUF,IMODEL,IFOUND = ',2(A4,2X),A4) 16360 CALL DPWRST('XXX','BUG ') 16361 ENDIF 16362C 16363 RETURN 16364 END 16365 SUBROUTINE DPTFCO(IHARG,NUMARG,IDETFC,MAXTEX,ITEFCO, 16366 1IBUGP2,IFOUND,IERROR) 16367C 16368C PURPOSE--DEFINE THE TEXT FILL COLORS = THE COLORS 16369C OF THE (BACKGROUND) FILL WITHIN THE TEXTS. 16370C THESE ARE LOCATED IN THE VECTOR ITEFCO(.). 16371C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 16372C --NUMARG 16373C --IDETFC 16374C --MAXTEX 16375C --IBUGP2 ('ON' OR 'OFF' ) 16376C OUTPUT ARGUMENTS--ITEFCO (A CHARACTER VECTOR) 16377C --IFOUND ('YES' OR 'NO' ) 16378C --IERROR ('YES' OR 'NO' ) 16379C WRITTEN BY--JAMES J. FILLIBEN 16380C STATISTICAL ENGINEERING DIVISION 16381C INFORMATION TECHNOLOGY LABORATORY 16382C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 16383C GAITHERSBURG, MD 20899-8980 16384C PHONE--301-975-2899 16385C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16386C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 16387C LANGUAGE--ANSI FORTRAN (1977) 16388C VERSION NUMBER--82/7 16389C ORIGINAL VERSION--DECEMBER 1983. 16390C 16391C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16392C 16393 CHARACTER*4 IHARG 16394 CHARACTER*4 IDETFC 16395 CHARACTER*4 ITEFCO 16396C 16397 CHARACTER*4 IBUGP2 16398 CHARACTER*4 IFOUND 16399 CHARACTER*4 IERROR 16400C 16401 CHARACTER*4 IHOLD1 16402 CHARACTER*4 IHOLD2 16403C 16404 CHARACTER*4 ISUBN1 16405 CHARACTER*4 ISUBN2 16406 CHARACTER*4 ISTEPN 16407C 16408 DIMENSION IHARG(*) 16409 DIMENSION ITEFCO(*) 16410C 16411C-----COMMON---------------------------------------------------------- 16412C 16413 INCLUDE 'DPCOP2.INC' 16414C 16415C-----START POINT----------------------------------------------------- 16416C 16417 IFOUND='NO' 16418 IERROR='NO' 16419 ISUBN1='DPTF' 16420 ISUBN2='CO ' 16421C 16422 NUMTEX=0 16423 IHOLD1='-999' 16424 IHOLD2='-999' 16425C 16426 IF(IBUGP2.EQ.'OFF')GOTO90 16427 WRITE(ICOUT,999) 16428 999 FORMAT(1X) 16429 CALL DPWRST('XXX','BUG ') 16430 WRITE(ICOUT,51) 16431 51 FORMAT('***** AT THE BEGINNING OF DPTFCO--') 16432 CALL DPWRST('XXX','BUG ') 16433 WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 16434 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 16435 CALL DPWRST('XXX','BUG ') 16436 WRITE(ICOUT,53)MAXTEX,NUMTEX 16437 53 FORMAT('MAXTEX,NUMTEX = ',I8,I8) 16438 CALL DPWRST('XXX','BUG ') 16439 WRITE(ICOUT,54)IHOLD1,IHOLD2 16440 54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 16441 CALL DPWRST('XXX','BUG ') 16442 WRITE(ICOUT,55)IDETFC 16443 55 FORMAT('IDETFC = ',A4) 16444 CALL DPWRST('XXX','BUG ') 16445 WRITE(ICOUT,60)NUMARG 16446 60 FORMAT('NUMARG = ',I8) 16447 CALL DPWRST('XXX','BUG ') 16448 DO65I=1,NUMARG 16449 WRITE(ICOUT,66)IHARG(I) 16450 66 FORMAT('IHARG(I) = ',A4) 16451 CALL DPWRST('XXX','BUG ') 16452 65 CONTINUE 16453 WRITE(ICOUT,70)ITEFCO(1) 16454 70 FORMAT('ITEFCO(1) = ',A4) 16455 CALL DPWRST('XXX','BUG ') 16456 DO75I=1,10 16457 WRITE(ICOUT,76)I,ITEFCO(I) 16458 76 FORMAT('I,ITEFCO(I) = ',I8,2X,A4) 16459 CALL DPWRST('XXX','BUG ') 16460 75 CONTINUE 16461 90 CONTINUE 16462C 16463C ************************************** 16464C ** STEP 1-- ** 16465C ** BRANCH TO THE APPROPRIATE CASE ** 16466C ************************************** 16467C 16468 ISTEPN='1' 16469 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16470C 16471 IF(NUMARG.LE.1)GOTO9000 16472 IF(NUMARG.EQ.2)GOTO1120 16473 IF(NUMARG.EQ.3)GOTO1130 16474 IF(NUMARG.EQ.4)GOTO1140 16475 GOTO1150 16476C 16477 1120 CONTINUE 16478 GOTO1200 16479C 16480 1130 CONTINUE 16481 IF(IHARG(3).EQ.'ALL')IHOLD1=' ' 16482 IF(IHARG(3).EQ.'ALL')GOTO1300 16483 GOTO1200 16484C 16485 1140 CONTINUE 16486 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) 16487 IF(IHARG(3).EQ.'ALL')GOTO1300 16488 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) 16489 IF(IHARG(4).EQ.'ALL')GOTO1300 16490 GOTO1200 16491C 16492 1150 CONTINUE 16493 GOTO1200 16494C 16495C ************************************************* 16496C ** STEP 2-- ** 16497C ** TREAT THE SINGLE SPECIFICATION CASE ** 16498C ************************************************* 16499C 16500 1200 CONTINUE 16501 ISTEPN='2' 16502 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16503C 16504 IF(NUMARG.LE.2)GOTO1210 16505 GOTO1220 16506C 16507 1210 CONTINUE 16508 NUMTEX=1 16509 ITEFCO(1)=IDETFC 16510 GOTO1270 16511C 16512 1220 CONTINUE 16513 NUMTEX=NUMARG-2 16514 IF(NUMTEX.GT.MAXTEX)NUMTEX=MAXTEX 16515 DO1225I=1,NUMTEX 16516 J=I+2 16517 IHOLD1=IHARG(J) 16518 IHOLD2=IHOLD1 16519 IF(IHOLD1.EQ.'ON')IHOLD2=IDETFC 16520 IF(IHOLD1.EQ.'OFF')IHOLD2=IDETFC 16521 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDETFC 16522 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDETFC 16523 ITEFCO(I)=IHOLD2 16524 1225 CONTINUE 16525 GOTO1270 16526C 16527 1270 CONTINUE 16528 IF(IFEEDB.EQ.'OFF')GOTO1279 16529 WRITE(ICOUT,999) 16530 CALL DPWRST('XXX','BUG ') 16531 DO1278I=1,NUMTEX 16532 WRITE(ICOUT,1276)I,ITEFCO(I) 16533 1276 FORMAT('THE FILL COLOR OF TEXT ',I6, 16534 1' HAS JUST BEEN SET TO ',A4) 16535 CALL DPWRST('XXX','BUG ') 16536 1278 CONTINUE 16537 1279 CONTINUE 16538 IFOUND='YES' 16539 GOTO9000 16540C 16541C ************************** 16542C ** STEP 3-- ** 16543C ** TREAT THE ALL CASE ** 16544C ************************** 16545C 16546 1300 CONTINUE 16547 ISTEPN='3' 16548 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16549C 16550 NUMTEX=MAXTEX 16551 IHOLD2=IHOLD1 16552 IF(IHOLD1.EQ.'ON')IHOLD2=IDETFC 16553 IF(IHOLD1.EQ.'OFF')IHOLD2=IDETFC 16554 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDETFC 16555 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDETFC 16556 DO1315I=1,NUMTEX 16557 ITEFCO(I)=IHOLD2 16558 1315 CONTINUE 16559 GOTO1370 16560C 16561 1370 CONTINUE 16562 IF(IFEEDB.EQ.'OFF')GOTO1319 16563 WRITE(ICOUT,999) 16564 CALL DPWRST('XXX','BUG ') 16565 I=1 16566 WRITE(ICOUT,1316)ITEFCO(I) 16567 1316 FORMAT('THE FILL COLOR OF ALL TEXTS', 16568 1' HAS JUST BEEN SET TO ',A4) 16569 CALL DPWRST('XXX','BUG ') 16570 1319 CONTINUE 16571 IFOUND='YES' 16572 GOTO9000 16573C 16574C ***************** 16575C ** STEP 90-- ** 16576C ** EXIT ** 16577C ***************** 16578C 16579 9000 CONTINUE 16580 IF(IBUGP2.EQ.'OFF')GOTO9090 16581 WRITE(ICOUT,9011) 16582 9011 FORMAT('***** AT THE END OF DPTFCO--') 16583 CALL DPWRST('XXX','BUG ') 16584 WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 16585 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 16586 CALL DPWRST('XXX','BUG ') 16587 WRITE(ICOUT,9013)MAXTEX,NUMTEX,NUMARG 16588 9013 FORMAT('MAXTEX,NUMTEX,NUMARG = ',3I8) 16589 CALL DPWRST('XXX','BUG ') 16590 WRITE(ICOUT,9014)IHOLD1,IHOLD2,IDETFC 16591 9014 FORMAT('IHOLD1,IHOLD2,IDETFC = ',2(A4,2X),A4) 16592 CALL DPWRST('XXX','BUG ') 16593 DO9025I=1,NUMARG 16594 WRITE(ICOUT,9026)IHARG(I) 16595 9026 FORMAT('IHARG(I) = ',A4) 16596 CALL DPWRST('XXX','BUG ') 16597 9025 CONTINUE 16598 DO9035I=1,10 16599 WRITE(ICOUT,9036)I,ITEFCO(I) 16600 9036 FORMAT('I,ITEFCO(I) = ',I8,2X,A4) 16601 CALL DPWRST('XXX','BUG ') 16602 9035 CONTINUE 16603 9090 CONTINUE 16604C 16605 RETURN 16606 END 16607 SUBROUTINE DPTFSW(IHARG,NUMARG,IDETFS,MAXTEX,ITEFSW, 16608 1IBUGP2,IFOUND,IERROR) 16609C 16610C PURPOSE--DEFINE THE TEXT FILL SWITCHES = THE ON/OFF SWITCHES 16611C OF THE (BACKGROUND) FILL WITHIN THE TEXTS. 16612C THESE ARE LOCATED IN THE VECTOR ITEFSW(.). 16613C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 16614C --NUMARG 16615C --IDETFS 16616C --MAXTEX 16617C --IBUGP2 ('ON' OR 'OFF' ) 16618C OUTPUT ARGUMENTS--ITEFSW (A CHARACTER VECTOR) 16619C --IFOUND ('YES' OR 'NO' ) 16620C --IERROR ('YES' OR 'NO' ) 16621C WRITTEN BY--JAMES J. FILLIBEN 16622C STATISTICAL ENGINEERING DIVISION 16623C INFORMATION TECHNOLOGY LABORATORY 16624C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 16625C GAITHERSBURG, MD 20899-8980 16626C PHONE--301-975-2899 16627C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16628C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 16629C LANGUAGE--ANSI FORTRAN (1977) 16630C VERSION NUMBER--82/7 16631C ORIGINAL VERSION--DECEMBER 1983. 16632C 16633C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16634C 16635 CHARACTER*4 IHARG 16636 CHARACTER*4 IDETFS 16637 CHARACTER*4 ITEFSW 16638C 16639 CHARACTER*4 IBUGP2 16640 CHARACTER*4 IFOUND 16641 CHARACTER*4 IERROR 16642C 16643 CHARACTER*4 IHOLD1 16644 CHARACTER*4 IHOLD2 16645C 16646 CHARACTER*4 ISUBN1 16647 CHARACTER*4 ISUBN2 16648 CHARACTER*4 ISTEPN 16649C 16650 DIMENSION IHARG(*) 16651 DIMENSION ITEFSW(*) 16652C 16653C-----COMMON---------------------------------------------------------- 16654C 16655 INCLUDE 'DPCOP2.INC' 16656C 16657C-----START POINT----------------------------------------------------- 16658C 16659 IFOUND='NO' 16660 IERROR='NO' 16661 ISUBN1='DPTF' 16662 ISUBN2='SW ' 16663C 16664 NUMTEX=0 16665 IHOLD1='-999' 16666 IHOLD2='-999' 16667C 16668 IF(IBUGP2.EQ.'OFF')GOTO90 16669 WRITE(ICOUT,999) 16670 999 FORMAT(1X) 16671 CALL DPWRST('XXX','BUG ') 16672 WRITE(ICOUT,51) 16673 51 FORMAT('***** AT THE BEGINNING OF DPTFSW--') 16674 CALL DPWRST('XXX','BUG ') 16675 WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 16676 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 16677 CALL DPWRST('XXX','BUG ') 16678 WRITE(ICOUT,53)MAXTEX,NUMTEX 16679 53 FORMAT('MAXTEX,NUMTEX = ',I8,I8) 16680 CALL DPWRST('XXX','BUG ') 16681 WRITE(ICOUT,54)IHOLD1,IHOLD2 16682 54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 16683 CALL DPWRST('XXX','BUG ') 16684 WRITE(ICOUT,55)IDETFS 16685 55 FORMAT('IDETFS = ',A4) 16686 CALL DPWRST('XXX','BUG ') 16687 WRITE(ICOUT,60)NUMARG 16688 60 FORMAT('NUMARG = ',I8) 16689 CALL DPWRST('XXX','BUG ') 16690 DO65I=1,NUMARG 16691 WRITE(ICOUT,66)IHARG(I) 16692 66 FORMAT('IHARG(I) = ',A4) 16693 CALL DPWRST('XXX','BUG ') 16694 65 CONTINUE 16695 WRITE(ICOUT,70)ITEFSW(1) 16696 70 FORMAT('ITEFSW(1) = ',A4) 16697 CALL DPWRST('XXX','BUG ') 16698 DO75I=1,10 16699 WRITE(ICOUT,76)I,ITEFSW(I) 16700 76 FORMAT('I,ITEFSW(I) = ',I8,2X,A4) 16701 CALL DPWRST('XXX','BUG ') 16702 75 CONTINUE 16703 90 CONTINUE 16704C 16705C ************************************** 16706C ** STEP 1-- ** 16707C ** BRANCH TO THE APPROPRIATE CASE ** 16708C ************************************** 16709C 16710 ISTEPN='1' 16711 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16712C 16713 IF(NUMARG.LE.1)GOTO9000 16714 IF(NUMARG.EQ.2)GOTO1120 16715 IF(NUMARG.EQ.3)GOTO1130 16716 IF(NUMARG.EQ.4)GOTO1140 16717 GOTO1150 16718C 16719 1120 CONTINUE 16720 GOTO1200 16721C 16722 1130 CONTINUE 16723 IF(IHARG(3).EQ.'ALL')IHOLD1='ON' 16724 IF(IHARG(3).EQ.'ALL')GOTO1300 16725 GOTO1200 16726C 16727 1140 CONTINUE 16728 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) 16729 IF(IHARG(3).EQ.'ALL')GOTO1300 16730 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) 16731 IF(IHARG(4).EQ.'ALL')GOTO1300 16732 GOTO1200 16733C 16734 1150 CONTINUE 16735 GOTO1200 16736C 16737C ************************************************* 16738C ** STEP 2-- ** 16739C ** TREAT THE SINGLE SPECIFICATION CASE ** 16740C ************************************************* 16741C 16742 1200 CONTINUE 16743 ISTEPN='2' 16744 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16745C 16746 IF(NUMARG.LE.2)GOTO1210 16747 GOTO1220 16748C 16749 1210 CONTINUE 16750 NUMTEX=1 16751 ITEFSW(1)='ON' 16752 GOTO1270 16753C 16754 1220 CONTINUE 16755 NUMTEX=NUMARG-2 16756 IF(NUMTEX.GT.MAXTEX)NUMTEX=MAXTEX 16757 DO1225I=1,NUMTEX 16758 J=I+2 16759 IHOLD1=IHARG(J) 16760 IHOLD2=IHOLD1 16761 IF(IHOLD1.EQ.'ON')IHOLD2='ON' 16762 IF(IHOLD1.EQ.'OFF')IHOLD2='OFF' 16763 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDETFS 16764 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDETFS 16765 ITEFSW(I)=IHOLD2 16766 1225 CONTINUE 16767 GOTO1270 16768C 16769 1270 CONTINUE 16770 IF(IFEEDB.EQ.'OFF')GOTO1279 16771 WRITE(ICOUT,999) 16772 CALL DPWRST('XXX','BUG ') 16773 DO1278I=1,NUMTEX 16774 WRITE(ICOUT,1276)I,ITEFSW(I) 16775 1276 FORMAT('THE FILL SWITCH FOR TEXT ',I6, 16776 1' HAS JUST BEEN SET TO ',A4) 16777 CALL DPWRST('XXX','BUG ') 16778 1278 CONTINUE 16779 1279 CONTINUE 16780 IFOUND='YES' 16781 GOTO9000 16782C 16783C ************************** 16784C ** STEP 3-- ** 16785C ** TREAT THE ALL CASE ** 16786C ************************** 16787C 16788 1300 CONTINUE 16789 ISTEPN='3' 16790 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 16791C 16792 NUMTEX=MAXTEX 16793 IHOLD2=IHOLD1 16794 IF(IHOLD1.EQ.'ON')IHOLD2='ON' 16795 IF(IHOLD1.EQ.'OFF')IHOLD2='OFF' 16796 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDETFS 16797 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDETFS 16798 DO1315I=1,NUMTEX 16799 ITEFSW(I)=IHOLD2 16800 1315 CONTINUE 16801 GOTO1370 16802C 16803 1370 CONTINUE 16804 IF(IFEEDB.EQ.'OFF')GOTO1319 16805 WRITE(ICOUT,999) 16806 CALL DPWRST('XXX','BUG ') 16807 I=1 16808 WRITE(ICOUT,1316)ITEFSW(I) 16809 1316 FORMAT('THE FILL SWITCH FOR ALL TEXTS', 16810 1' HAS JUST BEEN SET TO ',A4) 16811 CALL DPWRST('XXX','BUG ') 16812 1319 CONTINUE 16813 IFOUND='YES' 16814 GOTO9000 16815C 16816C ***************** 16817C ** STEP 90-- ** 16818C ** EXIT ** 16819C ***************** 16820C 16821 9000 CONTINUE 16822 IF(IBUGP2.EQ.'OFF')GOTO9090 16823 WRITE(ICOUT,9011) 16824 9011 FORMAT('***** AT THE END OF DPTFSW--') 16825 CALL DPWRST('XXX','BUG ') 16826 WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 16827 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 16828 CALL DPWRST('XXX','BUG ') 16829 WRITE(ICOUT,9013)MAXTEX,NUMTEX 16830 9013 FORMAT('MAXTEX,NUMTEX = ',I8,I8) 16831 CALL DPWRST('XXX','BUG ') 16832 WRITE(ICOUT,9014)IHOLD1,IHOLD2 16833 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 16834 CALL DPWRST('XXX','BUG ') 16835 WRITE(ICOUT,9015)IDETFS 16836 9015 FORMAT('IDETFS = ',A4) 16837 CALL DPWRST('XXX','BUG ') 16838 WRITE(ICOUT,9020)NUMARG 16839 9020 FORMAT('NUMARG = ',I8) 16840 CALL DPWRST('XXX','BUG ') 16841 DO9025I=1,NUMARG 16842 WRITE(ICOUT,9026)IHARG(I) 16843 9026 FORMAT('IHARG(I) = ',A4) 16844 CALL DPWRST('XXX','BUG ') 16845 9025 CONTINUE 16846 WRITE(ICOUT,9030)ITEFSW(1) 16847 9030 FORMAT('ITEFSW(1) = ',A4) 16848 CALL DPWRST('XXX','BUG ') 16849 DO9035I=1,10 16850 WRITE(ICOUT,9036)I,ITEFSW(I) 16851 9036 FORMAT('I,ITEFSW(I) = ',I8,2X,A4) 16852 CALL DPWRST('XXX','BUG ') 16853 9035 CONTINUE 16854 9090 CONTINUE 16855C 16856 RETURN 16857 END 16858 SUBROUTINE DPTHIC(IHARG,IARGT,ARG,NUMARG, 16859 1PDEFTH, 16860 1PTEXTH, 16861C DECEMBER 1987: SET ALL THICKNESS (CAN THEN 16862C OVERRIDE ANY INDIVIDUALLY) 16863 1PFRATH,PTICTH,PTIZTH,PVGRTH,PHGRTH,PTITTH,PX1LTH,PX2LTH,PY1LTH, 16864 1PY2LTH,PLEGTH,MAXLG,PBOPTH,PBOFTH,MAXBX,PARRTH,MAXAR, 16865 1PSEGTH,MAXSG,PLINTH,MAXLN,PCHATH,MAXCH2,PFILTH,MAXFL, 16866 1PPATTH,MAXPT,PSPITH,MAXSP,PBABTH,PBAPTH,MAXBA,PREPTH,MAXRG, 16867 1PMABTH,PMAPTH,MAXMR,PTEBTH,PTEPTH,MAXTX, 16868C END CHANGE 16869 1IBUGD2,ISUBRO,IFOUND,IERROR) 16870C 16871C PURPOSE--DEFINE THE THICKNESS FOR TEXT CHARACTERS. 16872C THE THICKNESS FOR TEXT CHARACTERS WILL BE PLACED 16873C IN THE FLOATING POINT VARIABLE PTEXTH. 16874C NOTE--THE THICKNESS IS IN STANDARDIZED UNITS (0.0 TO 100.0). 16875C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 16876C --IARGT 16877C --ARG 16878C --NUMARG 16879C --PDEFTH 16880C --IBUGD2 16881C OUTPUT ARGUMENTS--PTEXTH 16882C --IFOUND ('YES' OR 'NO' ) 16883C --IERROR ('YES' OR 'NO' ) 16884C WRITTEN BY--JAMES J. FILLIBEN 16885C STATISTICAL ENGINEERING DIVISION 16886C INFORMATION TECHNOLOGY LABORATORY 16887C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 16888C GAITHERSBURG, MD 20899-8980 16889C PHONE--301-975-2899 16890C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16891C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 16892C LANGUAGE--ANSI FORTRAN (1977) 16893C VERSION NUMBER--82/7 16894C ORIGINAL VERSION--APRIL 1981. 16895C UPDATED --MAY 1982. 16896C UPDATED --JANUARY 1989. SET ALL THICKNESS PARAMETERS (ALAN) 16897C UPDATED --SEPTEMBER 1993. FIX BUG FORMAT STATEMENT 16898C 16899C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16900C 16901 CHARACTER*4 IHARG 16902 CHARACTER*4 IARGT 16903 CHARACTER*4 IBUGD2 16904 CHARACTER*4 ISUBRO 16905 CHARACTER*4 IFOUND 16906 CHARACTER*4 IERROR 16907C 16908C--------------------------------------------------------------------- 16909C 16910C DECEMBER 1987 16911 DIMENSION PLEGTH(*) 16912 DIMENSION PBOPTH(*) 16913 DIMENSION PBOFTH(*) 16914 DIMENSION PARRTH(*) 16915 DIMENSION PSEGTH(*) 16916 DIMENSION PLINTH(*) 16917 DIMENSION PCHATH(*) 16918 DIMENSION PFILTH(*) 16919 DIMENSION PPATTH(*) 16920 DIMENSION PSPITH(*) 16921 DIMENSION PBABTH(*) 16922 DIMENSION PBAPTH(*) 16923 DIMENSION PREPTH(*) 16924 DIMENSION PMABTH(*) 16925 DIMENSION PMAPTH(*) 16926 DIMENSION PTEBTH(*) 16927 DIMENSION PTEPTH(*) 16928C END CHANGE 16929 DIMENSION IHARG(*) 16930 DIMENSION IARGT(*) 16931 DIMENSION ARG(*) 16932C 16933C-----COMMON---------------------------------------------------------- 16934C 16935 INCLUDE 'DPCOP2.INC' 16936C 16937C-----START POINT----------------------------------------------------- 16938C 16939 IFOUND='NO' 16940 IERROR='NO' 16941C 16942 IF(IBUGD2.EQ.'OFF')GOTO90 16943 WRITE(ICOUT,999) 16944 999 FORMAT(1X) 16945 CALL DPWRST('XXX','BUG ') 16946 WRITE(ICOUT,51) 16947 51 FORMAT('***** AT THE BEGINNING OF DPTHIC--') 16948 CALL DPWRST('XXX','BUG ') 16949 WRITE(ICOUT,53)PDEFTH 16950 53 FORMAT('PDEFTH = ',E15.7) 16951 CALL DPWRST('XXX','BUG ') 16952 WRITE(ICOUT,54)NUMARG 16953 54 FORMAT('NUMARG = ',I8) 16954 CALL DPWRST('XXX','BUG ') 16955 DO55I=1,NUMARG 16956 WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I) 16957 56 FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2X,A4,2X,A4,E15.7) 16958 CALL DPWRST('XXX','BUG ') 16959 55 CONTINUE 16960 90 CONTINUE 16961C 16962C ***************************** 16963C ** TREAT THE THICKNESS CASE ** 16964C ***************************** 16965C 16966 IF(NUMARG.LE.0)GOTO1150 16967 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 16968 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 16969 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 16970 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 16971 IF(IHARG(NUMARG).EQ.'?')GOTO8100 16972C 16973 IF(NUMARG.GE.1.AND.IARGT(NUMARG).EQ.'NUMB') 16974 1GOTO1160 16975C 16976 IERROR='YES' 16977 WRITE(ICOUT,1121) 16978 1121 FORMAT('***** ERROR IN DPTHIC--') 16979 CALL DPWRST('XXX','BUG ') 16980 WRITE(ICOUT,1122) 16981 1122 FORMAT(' ILLEGAL FORM FOR THICKNESS COMMAND.') 16982 CALL DPWRST('XXX','BUG ') 16983 WRITE(ICOUT,1124) 16984 1124 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 16985 1'PROPER FORM--') 16986 CALL DPWRST('XXX','BUG ') 16987 WRITE(ICOUT,1125) 16988 1125 FORMAT(' SUPPOSE IT IS DESIRED THAT ') 16989 CALL DPWRST('XXX','BUG ') 16990 WRITE(ICOUT,1126) 16991 1126 FORMAT(' THE TEXT CHARACTERS HAVE A THICKNESS OF 1') 16992 CALL DPWRST('XXX','BUG ') 16993 WRITE(ICOUT,1127) 16994 1127 FORMAT(' (WHERE THE VERTICAL SCREEN UNITS RANGE') 16995 CALL DPWRST('XXX','BUG ') 16996 WRITE(ICOUT,1128) 16997 1128 FORMAT(' FROM 0 TO 100, ') 16998 CALL DPWRST('XXX','BUG ') 16999 WRITE(ICOUT,1130) 17000 1130 FORMAT(' THEN THE ALLOWABLE FORM IS--') 17001 CALL DPWRST('XXX','BUG ') 17002 WRITE(ICOUT,1131) 17003 1131 FORMAT(' THICKNESS 1 ') 17004 CALL DPWRST('XXX','BUG ') 17005 GOTO9000 17006C 17007 1150 CONTINUE 17008 PTEXTH=PDEFTH 17009 GOTO1180 17010C 17011 1160 CONTINUE 17012 PTEXTH=ARG(NUMARG) 17013 GOTO1180 17014C 17015 1180 CONTINUE 17016 IFOUND='YES' 17017C 17018C DECEMBER 1987: SET ALL THICKNESSES TO THE SET VALUE 17019 PFRATH=PTEXTH 17020 PTICTH=PTEXTH 17021 PTIZTH=PTEXTH 17022 PVGRTH=PTEXTH 17023 PHGRTH=PTEXTH 17024 PTITTH=PTEXTH 17025 PX1LTH=PTEXTH 17026 PX2LTH=PTEXTH 17027 PY1LTH=PTEXTH 17028 PY2LTH=PTEXTH 17029 DO2010I=1,MAXLG 17030 PLEGTH(I)=PTEXTH 17031 2010 CONTINUE 17032 DO2020I=1,MAXBX 17033 PBOPTH(I)=PTEXTH 17034 PBOFTH(I)=PTEXTH 17035 2020 CONTINUE 17036 DO2030I=1,MAXAR 17037 PARRTH(I)=PTEXTH 17038 2030 CONTINUE 17039 DO2040I=1,MAXSG 17040 PSEGTH(I)=PTEXTH 17041 2040 CONTINUE 17042 DO2050I=1,MAXLN 17043 PLINTH(I)=PTEXTH 17044 2050 CONTINUE 17045 DO2060I=1,MAXCH2 17046 PCHATH(I)=PTEXTH 17047 2060 CONTINUE 17048 DO2070I=1,MAXFL 17049 PFILTH(I)=PTEXTH 17050 2070 CONTINUE 17051 DO2080I=1,MAXPT 17052 PPATTH(I)=PTEXTH 17053 2080 CONTINUE 17054 DO2090I=1,MAXSP 17055 PSPITH(I)=PTEXTH 17056 2090 CONTINUE 17057 DO2100I=1,MAXBA 17058 PBABTH(I)=PTEXTH 17059 PBAPTH(I)=PTEXTH 17060 2100 CONTINUE 17061 DO2110I=1,MAXRG 17062 PREPTH(I)=PTEXTH 17063 2110 CONTINUE 17064 DO2120I=1,MAXMR 17065 PMABTH(I)=PTEXTH 17066 PMAPTH(I)=PTEXTH 17067 2120 CONTINUE 17068 DO2130I=1,MAXTX 17069 PTEBTH(I)=PTEXTH 17070 PTEPTH(I)=PTEXTH 17071 2130 CONTINUE 17072C END CHANGE 17073 IF(IFEEDB.EQ.'OFF')GOTO1189 17074 WRITE(ICOUT,999) 17075 CALL DPWRST('XXX','BUG ') 17076 WRITE(ICOUT,1181) 17077 1181 FORMAT('THE THICKNESS (FOR TEXT CHARACTERS) ') 17078 CALL DPWRST('XXX','BUG ') 17079 WRITE(ICOUT,1182)PTEXTH 17080 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7) 17081 CALL DPWRST('XXX','BUG ') 17082 1189 CONTINUE 17083 GOTO9000 17084C 17085C ******************************************** 17086C ** STEP 81-- ** 17087C ** TREAT THE ? CASE-- ** 17088C ** DUMP OUT CURRENT AND DEFAULT VALUES. ** 17089C ******************************************** 17090C 17091 8100 CONTINUE 17092 IFOUND='YES' 17093 WRITE(ICOUT,999) 17094 CALL DPWRST('XXX','BUG ') 17095 WRITE(ICOUT,8111)PTEXTH 17096 8111 FORMAT('THE CURRENT (TEXT) THICKNESS IS ',E15.7) 17097 CALL DPWRST('XXX','BUG ') 17098 WRITE(ICOUT,8112)PDEFTH 17099 8112 FORMAT('THE DEFAULT (TEXT) THICKNESS IS ',E15.7) 17100 CALL DPWRST('XXX','BUG ') 17101 GOTO9000 17102C 17103C ***************** 17104C ** STEP 90-- ** 17105C ** EXIT ** 17106C ***************** 17107C 17108 9000 CONTINUE 17109 IF(IBUGD2.EQ.'OFF')GOTO9090 17110 WRITE(ICOUT,999) 17111 CALL DPWRST('XXX','BUG ') 17112 WRITE(ICOUT,9011) 17113 9011 FORMAT('***** AT THE END OF DPTHIC--') 17114 CALL DPWRST('XXX','BUG ') 17115 WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR 17116CCCCC THE FOLLOWING LINE WAS FIXED SEPTEMBER 1993 17117C9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',,A4,2X,A4,2X,A4) 17118 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4,2X,A4) 17119 CALL DPWRST('XXX','BUG ') 17120 WRITE(ICOUT,9013)PTEXTH 17121 9013 FORMAT('PTEXTH = ',E15.7) 17122 CALL DPWRST('XXX','BUG ') 17123 9090 CONTINUE 17124C 17125 RETURN 17126 END 17127 SUBROUTINE DPTIC(ICOM,IHARG,NUMARG, 17128 1IX1TSW,IX2TSW,IY1TSW,IY2TSW, 17129 1IFOUND,IERROR) 17130C 17131C PURPOSE--DEFINE THE 4 TIC MARK SWITCHES CONTAINED IN THE 17132C 4 VARIABLES IX1TSW,IX2TSW,IY1TSW,IY2TSW 17133C SUCH TIC MARK SWITCHES TURN ON OR OFF 17134C THE TIC MARKS ON THE 4 FRAME LINES OF A PLOT. 17135C INPUT ARGUMENTS--ICOM 17136C --IHARG (A HOLLERITH VECTOR) 17137C --NUMARG 17138C OUTPUT ARGUMENTS-- 17139C --IX1TSW = LOWER HORIZONTAL FRAME TIC MARKS 17140C --IX2TSW = UPPER HORIZONTAL FRAME TIC MARKS 17141C --IY1TSW = LEFT VERTICAL FRAME TIC MARKS 17142C --IY2TSW = RIGHT VERTICAL FRAME TIC MARKS 17143C --IFOUND ('YES' OR 'NO' ) 17144C --IERROR ('YES' OR 'NO' ) 17145C WRITTEN BY--JAMES J. FILLIBEN 17146C STATISTICAL ENGINEERING DIVISION 17147C INFORMATION TECHNOLOGY LABORATORY 17148C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 17149C GAITHERSBURG, MD 20899-8980 17150C PHONE--301-975-2899 17151C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 17152C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 17153C LANGUAGE--ANSI FORTRAN (1977) 17154C VERSION NUMBER--82/7 17155C ORIGINAL VERSION--SEPTEMBER 1980. 17156C UPDATED --MARCH 1981. 17157C UPDATED --MAY 1982. 17158C UPDATED --JANUARY 1988. (ALLOW FOR TIC NUMBER COMMAND) 17159C 17160C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 17161C 17162 CHARACTER*4 ICOM 17163 CHARACTER*4 IHARG 17164C 17165 CHARACTER*4 IX1TSW 17166 CHARACTER*4 IX2TSW 17167 CHARACTER*4 IY1TSW 17168 CHARACTER*4 IY2TSW 17169C 17170 CHARACTER*4 IFOUND 17171 CHARACTER*4 IERROR 17172C 17173 CHARACTER*4 IHOLD 17174C 17175C--------------------------------------------------------------------- 17176C 17177 DIMENSION IHARG(*) 17178C 17179C-----COMMON---------------------------------------------------------- 17180C 17181 INCLUDE 'DPCOP2.INC' 17182C 17183C-----START POINT----------------------------------------------------- 17184C 17185 IFOUND='NO' 17186 IERROR='NO' 17187C 17188 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO1900 17189 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COOR')GOTO1900 17190 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'POSI')GOTO1900 17191 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SIZE')GOTO1900 17192 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'HW')GOTO1900 17193 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LABE')GOTO1900 17194 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DECI')GOTO1900 17195 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLAC')GOTO1900 17196 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'NUMB')GOTO1900 17197 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'OFFS')GOTO1900 17198C 17199 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 17200 1IHARG(2).EQ.'COLO')GOTO1900 17201 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 17202 1IHARG(2).EQ.'COOR')GOTO1900 17203 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 17204 1IHARG(2).EQ.'POSI')GOTO1900 17205 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 17206 1IHARG(2).EQ.'SIZE')GOTO1900 17207 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 17208 1IHARG(2).EQ.'HW')GOTO1900 17209 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 17210 1IHARG(2).EQ.'LABE')GOTO1900 17211 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 17212 1IHARG(2).EQ.'DECI')GOTO1900 17213 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 17214 1IHARG(2).EQ.'PLAC')GOTO1900 17215 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 17216 1IHARG(2).EQ.'NUMB')GOTO1900 17217 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 17218 1IHARG(2).EQ.'OFFS')GOTO1900 17219C 17220C ***************************************************** 17221C ** TREAT THE CASE WHEN ** 17222C ** BOTH HORIZONTAL AXIS TICS ARE TO BE CHANGED ** 17223C ***************************************************** 17224C 17225 IF(ICOM.EQ.'XTIC')GOTO1100 17226 GOTO1199 17227C 17228 1100 CONTINUE 17229 IF(NUMARG.LE.0)GOTO1160 17230 IF(IHARG(NUMARG).EQ.'MARK')GOTO1160 17231 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 17232 IF(IHARG(NUMARG).EQ.'OFF')GOTO1160 17233 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 17234 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 17235 GOTO1150 17236C 17237 1150 CONTINUE 17238 IHOLD='ON' 17239 GOTO1180 17240C 17241 1160 CONTINUE 17242 IHOLD='OFF' 17243 GOTO1180 17244C 17245 1180 CONTINUE 17246 IFOUND='YES' 17247 IX1TSW=IHOLD 17248 IX2TSW=IHOLD 17249C 17250 IF(IFEEDB.EQ.'OFF')GOTO1189 17251 WRITE(ICOUT,999) 17252 999 FORMAT(1X) 17253 CALL DPWRST('XXX','BUG ') 17254 WRITE(ICOUT,1181) 17255 1181 FORMAT('THE TIC MARKS (FOR BOTH HORIZONTAL ', 17256 1'FRAME LINES)') 17257 CALL DPWRST('XXX','BUG ') 17258 WRITE(ICOUT,1182)IHOLD 17259 1182 FORMAT('HAVE JUST BEEN TURNED ',A4) 17260 CALL DPWRST('XXX','BUG ') 17261 1189 CONTINUE 17262 GOTO1900 17263C 17264 1199 CONTINUE 17265C 17266C ************************************************************** 17267C ** TREAT THE CASE WHEN ** 17268C ** ONLY THE BOTTOM HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 17269C ************************************************************** 17270C 17271 IF(ICOM.EQ.'X1TI')GOTO1200 17272 GOTO1299 17273C 17274 1200 CONTINUE 17275 IF(NUMARG.LE.0)GOTO1260 17276 IF(IHARG(NUMARG).EQ.'MARK')GOTO1260 17277 IF(IHARG(NUMARG).EQ.'ON')GOTO1250 17278 IF(IHARG(NUMARG).EQ.'OFF')GOTO1260 17279 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 17280 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 17281 GOTO1250 17282C 17283 1250 CONTINUE 17284 IHOLD='ON' 17285 GOTO1280 17286C 17287 1260 CONTINUE 17288 IHOLD='OFF' 17289 GOTO1280 17290C 17291 1280 CONTINUE 17292 IFOUND='YES' 17293 IX1TSW=IHOLD 17294C 17295 IF(IFEEDB.EQ.'OFF')GOTO1289 17296 WRITE(ICOUT,999) 17297 CALL DPWRST('XXX','BUG ') 17298 WRITE(ICOUT,1281) 17299 1281 FORMAT('THE TIC MARKS (FOR THE BOTTOM ', 17300 1'HORIZONTAL FRAME LINE)') 17301 CALL DPWRST('XXX','BUG ') 17302 WRITE(ICOUT,1282)IHOLD 17303 1282 FORMAT('HAVE JUST BEEN TURNED ',A4) 17304 CALL DPWRST('XXX','BUG ') 17305 1289 CONTINUE 17306 GOTO1900 17307C 17308 1299 CONTINUE 17309C 17310C ************************************************************** 17311C ** TREAT THE CASE WHEN ** 17312C ** ONLY THE TOP HORIZONTAL TIC MARKS ARE TO BE CHANGED ** 17313C ************************************************************** 17314C 17315 IF(ICOM.EQ.'X2TI')GOTO1300 17316 GOTO1399 17317C 17318 1300 CONTINUE 17319 IF(NUMARG.LE.0)GOTO1360 17320 IF(IHARG(NUMARG).EQ.'MARK')GOTO1360 17321 IF(IHARG(NUMARG).EQ.'ON')GOTO1350 17322 IF(IHARG(NUMARG).EQ.'OFF')GOTO1360 17323 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 17324 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 17325 GOTO1350 17326C 17327 1350 CONTINUE 17328 IHOLD='ON' 17329 GOTO1380 17330C 17331 1360 CONTINUE 17332 IHOLD='OFF' 17333 GOTO1380 17334C 17335 1380 CONTINUE 17336 IFOUND='YES' 17337 IX2TSW=IHOLD 17338C 17339 IF(IFEEDB.EQ.'OFF')GOTO1389 17340 WRITE(ICOUT,999) 17341 CALL DPWRST('XXX','BUG ') 17342 WRITE(ICOUT,1381) 17343 1381 FORMAT('THE TIC MARKS (FOR THE TOP HORIZONTAL ', 17344 1'FRAME LINE)') 17345 CALL DPWRST('XXX','BUG ') 17346 WRITE(ICOUT,1382)IHOLD 17347 1382 FORMAT('HAVE JUST BEEN TURNED ',A4) 17348 CALL DPWRST('XXX','BUG ') 17349 1389 CONTINUE 17350 GOTO1900 17351C 17352 1399 CONTINUE 17353C 17354C ***************************************************** 17355C ** TREAT THE CASE WHEN ** 17356C ** BOTH VERTICAL AXIS TICS ARE TO BE CHANGED ** 17357C ***************************************************** 17358C 17359 IF(ICOM.EQ.'YTIC')GOTO1400 17360 GOTO1499 17361C 17362 1400 CONTINUE 17363 IF(NUMARG.LE.0)GOTO1460 17364 IF(IHARG(NUMARG).EQ.'MARK')GOTO1460 17365 IF(IHARG(NUMARG).EQ.'ON')GOTO1450 17366 IF(IHARG(NUMARG).EQ.'OFF')GOTO1460 17367 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 17368 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 17369 GOTO1450 17370C 17371 1450 CONTINUE 17372 IHOLD='ON' 17373 GOTO1480 17374C 17375 1460 CONTINUE 17376 IHOLD='OFF' 17377 GOTO1480 17378C 17379 1480 CONTINUE 17380 IFOUND='YES' 17381 IY1TSW=IHOLD 17382 IY2TSW=IHOLD 17383C 17384 IF(IFEEDB.EQ.'OFF')GOTO1489 17385 WRITE(ICOUT,999) 17386 CALL DPWRST('XXX','BUG ') 17387 WRITE(ICOUT,1481) 17388 1481 FORMAT('THE TIC MARKS (FOR BOTH VERTICAL ', 17389 1'FRAME LINES)') 17390 CALL DPWRST('XXX','BUG ') 17391 WRITE(ICOUT,1482)IHOLD 17392 1482 FORMAT('HAVE JUST BEEN TURNED ',A4) 17393 CALL DPWRST('XXX','BUG ') 17394 1489 CONTINUE 17395 GOTO1900 17396C 17397 1499 CONTINUE 17398C 17399C ************************************************************** 17400C ** TREAT THE CASE WHEN ** 17401C ** ONLY THE LEFT VERTICAL TIC MARKS ARE TO BE CHANGED ** 17402C ************************************************************** 17403C 17404 IF(ICOM.EQ.'Y1TI')GOTO1500 17405 GOTO1599 17406C 17407 1500 CONTINUE 17408 IF(NUMARG.LE.0)GOTO1560 17409 IF(IHARG(NUMARG).EQ.'MARK')GOTO1560 17410 IF(IHARG(NUMARG).EQ.'ON')GOTO1550 17411 IF(IHARG(NUMARG).EQ.'OFF')GOTO1560 17412 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 17413 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 17414 GOTO1550 17415C 17416 1550 CONTINUE 17417 IHOLD='ON' 17418 GOTO1580 17419C 17420 1560 CONTINUE 17421 IHOLD='OFF' 17422 GOTO1580 17423C 17424 1580 CONTINUE 17425 IFOUND='YES' 17426 IY1TSW=IHOLD 17427C 17428 IF(IFEEDB.EQ.'OFF')GOTO1589 17429 WRITE(ICOUT,999) 17430 CALL DPWRST('XXX','BUG ') 17431 WRITE(ICOUT,1581) 17432 1581 FORMAT('THE TIC MARKS (FOR THE LEFT VERTICAL ', 17433 1'FRAME LINE)') 17434 CALL DPWRST('XXX','BUG ') 17435 WRITE(ICOUT,1582)IHOLD 17436 1582 FORMAT('HAVE JUST BEEN TURNED ',A4) 17437 CALL DPWRST('XXX','BUG ') 17438 1589 CONTINUE 17439 GOTO1900 17440C 17441 1599 CONTINUE 17442C 17443C ************************************************************** 17444C ** TREAT THE CASE WHEN ** 17445C ** ONLY THE RIGHT VERTICAL TIC MARKS ARE TO BE CHANGED ** 17446C ************************************************************** 17447C 17448 IF(ICOM.EQ.'Y2TI')GOTO1600 17449 GOTO1699 17450C 17451 1600 CONTINUE 17452 IF(NUMARG.LE.0)GOTO1660 17453 IF(IHARG(NUMARG).EQ.'MARK')GOTO1660 17454 IF(IHARG(NUMARG).EQ.'ON')GOTO1650 17455 IF(IHARG(NUMARG).EQ.'OFF')GOTO1660 17456 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 17457 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 17458 GOTO1650 17459C 17460 1650 CONTINUE 17461 IHOLD='ON' 17462 GOTO1680 17463C 17464 1660 CONTINUE 17465 IHOLD='OFF' 17466 GOTO1680 17467C 17468 1680 CONTINUE 17469 IFOUND='YES' 17470 IY2TSW=IHOLD 17471C 17472 IF(IFEEDB.EQ.'OFF')GOTO1689 17473 WRITE(ICOUT,999) 17474 CALL DPWRST('XXX','BUG ') 17475 WRITE(ICOUT,1681) 17476 1681 FORMAT('THE TIC MARKS (FOR THE RIGHT VERTICAL ', 17477 1'FRAME LINE)') 17478 CALL DPWRST('XXX','BUG ') 17479 WRITE(ICOUT,1682)IHOLD 17480 1682 FORMAT('HAVE JUST BEEN TURNED ',A4) 17481 CALL DPWRST('XXX','BUG ') 17482 1689 CONTINUE 17483 GOTO1900 17484C 17485 1699 CONTINUE 17486C 17487C ***************************************************** 17488C ** TREAT THE CASE WHEN ** 17489C ** ALL 4 FRAME TICS ARE TO BE CHANGED ** 17490C ***************************************************** 17491C 17492 IF(ICOM.EQ.'TIC')GOTO1700 17493 IF(ICOM.EQ.'TICS')GOTO1700 17494 IF(ICOM.EQ.'XYTI')GOTO1700 17495 IF(ICOM.EQ.'YXTI')GOTO1700 17496 GOTO1799 17497C 17498 1700 CONTINUE 17499 IF(NUMARG.LE.0)GOTO1760 17500 IF(IHARG(NUMARG).EQ.'MARK')GOTO1760 17501 IF(IHARG(NUMARG).EQ.'ON')GOTO1750 17502 IF(IHARG(NUMARG).EQ.'OFF')GOTO1760 17503 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 17504 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 17505 GOTO1750 17506C 17507 1750 CONTINUE 17508 IHOLD='ON' 17509 GOTO1780 17510C 17511 1760 CONTINUE 17512 IHOLD='OFF' 17513 GOTO1780 17514C 17515 1780 CONTINUE 17516 IFOUND='YES' 17517 IX1TSW=IHOLD 17518 IX2TSW=IHOLD 17519 IY1TSW=IHOLD 17520 IY2TSW=IHOLD 17521C 17522 IF(IFEEDB.EQ.'OFF')GOTO1789 17523 WRITE(ICOUT,999) 17524 CALL DPWRST('XXX','BUG ') 17525 WRITE(ICOUT,1781) 17526 1781 FORMAT('THE TIC MARKS (FOR ALL 4 ', 17527 1'FRAME LINES)') 17528 CALL DPWRST('XXX','BUG ') 17529 WRITE(ICOUT,1782)IHOLD 17530 1782 FORMAT('HAVE JUST BEEN TURNED ',A4) 17531 CALL DPWRST('XXX','BUG ') 17532 1789 CONTINUE 17533 GOTO1900 17534C 17535 1799 CONTINUE 17536C 17537 1900 CONTINUE 17538 RETURN 17539 END 17540 SUBROUTINE DPTICA(IHARG,NUMARG,IDEFCA,ITITCA,IFOUND,IERROR) 17541C 17542C PURPOSE--DEFINE THE CASE FOR THE TITLE 17543C (THE HORIZONTAL STRING ABOVE THE UPPER HORIZONTAL FRAME). 17544C THE CASE FOR THE TITLE WILL BE PLACED 17545C IN THE HOLLERITH VARIABLE ITITCA. 17546C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 17547C --NUMARG 17548C --IDEFCA 17549C OUTPUT ARGUMENTS--ITITCA 17550C --IFOUND ('YES' OR 'NO' ) 17551C --IERROR ('YES' OR 'NO' ) 17552C WRITTEN BY--ALAN HECKERT 17553C COMPUTER SERVICES DIVISION 17554C INFORMATION TECHNOLOGY LABORATORY 17555C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 17556C GAITHERSBURG, MD 20899-8980 17557C PHONE--301-975-2899 17558C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 17559C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 17560C LANGUAGE--ANSI FORTRAN (1977) 17561C VERSION NUMBER--89/2 17562C ORIGINAL VERSION--JANUARY 1989. 17563C 17564C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 17565C 17566 CHARACTER*4 IHARG 17567 CHARACTER*4 IDEFCA 17568 CHARACTER*4 ITITCA 17569 CHARACTER*4 IFOUND 17570 CHARACTER*4 IERROR 17571C 17572C--------------------------------------------------------------------- 17573C 17574 DIMENSION IHARG(*) 17575C 17576C-----COMMON---------------------------------------------------------- 17577C 17578 INCLUDE 'DPCOP2.INC' 17579C 17580C-----START POINT----------------------------------------------------- 17581C 17582 IFOUND='NO' 17583 IERROR='NO' 17584C 17585 IF(NUMARG.LE.0)GOTO1199 17586 IF(IHARG(1).EQ.'CASE')GOTO1110 17587 GOTO1199 17588C 17589 1110 CONTINUE 17590 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 17591 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 17592 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 17593 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 17594 IF(NUMARG.EQ.1)GOTO1150 17595 GOTO1160 17596C 17597 1150 CONTINUE 17598 ITITCA=IDEFCA 17599 GOTO1180 17600C 17601 1160 CONTINUE 17602 ITITCA=IHARG(NUMARG) 17603 GOTO1180 17604C 17605 1180 CONTINUE 17606 IFOUND='YES' 17607C 17608 IF(IFEEDB.EQ.'OFF')GOTO1189 17609 WRITE(ICOUT,999) 17610 999 FORMAT(1X) 17611 CALL DPWRST('XXX','BUG ') 17612 WRITE(ICOUT,1181)ITITCA 17613 1181 FORMAT('THE TITLE CASE HAS JUST BEEN SET TO ', 17614 1A4) 17615 CALL DPWRST('XXX','BUG ') 17616 1189 CONTINUE 17617 GOTO1199 17618C 17619 1199 CONTINUE 17620 RETURN 17621 END 17622 SUBROUTINE DPTICL(IHARG,NUMARG,IDEFCO,ITITCO,IFOUND,IERROR) 17623C 17624C PURPOSE--DEFINE THE COLOR FOR THE TITLE 17625C (THE HORIZONTAL STRING ABOVE THE UPPER HORIZONTAL FRAME). 17626C THE COLOR FOR THE TITLE WILL BE PLACED 17627C IN THE HOLLERITH VARIABLE ITITCO. 17628C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 17629C --NUMARG 17630C --IDEFCO 17631C OUTPUT ARGUMENTS--ITITCO 17632C --IFOUND ('YES' OR 'NO' ) 17633C --IERROR ('YES' OR 'NO' ) 17634C WRITTEN BY--JAMES J. FILLIBEN 17635C STATISTICAL ENGINEERING DIVISION 17636C INFORMATION TECHNOLOGY LABORATORY 17637C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 17638C GAITHERSBURG, MD 20899-8980 17639C PHONE--301-975-2899 17640C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 17641C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 17642C LANGUAGE--ANSI FORTRAN (1977) 17643C VERSION NUMBER--82/7 17644C ORIGINAL VERSION--SEPTEMBER 1980. 17645C UPDATED --MAY 1982. 17646C 17647C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 17648C 17649 CHARACTER*4 IHARG 17650 CHARACTER*4 IDEFCO 17651 CHARACTER*4 ITITCO 17652 CHARACTER*4 IFOUND 17653 CHARACTER*4 IERROR 17654C 17655C--------------------------------------------------------------------- 17656C 17657 DIMENSION IHARG(*) 17658C 17659C-----COMMON---------------------------------------------------------- 17660C 17661 INCLUDE 'DPCOP2.INC' 17662C 17663C-----START POINT----------------------------------------------------- 17664C 17665 IFOUND='NO' 17666 IERROR='NO' 17667C 17668 IF(NUMARG.LE.0)GOTO1199 17669 IF(IHARG(1).EQ.'COLO')GOTO1110 17670 GOTO1199 17671C 17672 1110 CONTINUE 17673 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 17674 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 17675 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 17676 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 17677 IF(NUMARG.EQ.1)GOTO1150 17678 GOTO1160 17679C 17680 1150 CONTINUE 17681 ITITCO=IDEFCO 17682 GOTO1180 17683C 17684 1160 CONTINUE 17685 ITITCO=IHARG(NUMARG) 17686 GOTO1180 17687C 17688 1180 CONTINUE 17689 IFOUND='YES' 17690C 17691 IF(IFEEDB.EQ.'OFF')GOTO1189 17692 WRITE(ICOUT,999) 17693 999 FORMAT(1X) 17694 CALL DPWRST('XXX','BUG ') 17695 WRITE(ICOUT,1181)ITITCO 17696 1181 FORMAT('THE TITLE COLOR HAS JUST BEEN SET TO ', 17697 1A4) 17698 CALL DPWRST('XXX','BUG ') 17699 1189 CONTINUE 17700 GOTO1199 17701C 17702 1199 CONTINUE 17703 RETURN 17704 END 17705 SUBROUTINE DPTIET(XTEMP1,MAXNXT, 17706 1 ICAPSW,ICASAN,IFORSW,ISEED, 17707 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 17708C 17709C PURPOSE--PERFORM TIETJEN-MOORE TEST FOR UNIVARIATE OUTLIERS. 17710C THIS IS A GENERALIZATION OF THE GRUBB TEST (WHICH 17711C LOOKS FOR A SINGLE OUTLIER) TO LOOK FOR "K" OUTLIERS. 17712C LIKE GRUBBS TEST, THIS TEST ASSUMES THE DATA FOLLOWS AN 17713C APPROXIMATELY NORMAL DISRIBUTION). 17714C WRITTEN BY--ALAN HECKERT 17715C STATISTICAL ENGINEERING DIVISION 17716C INFORMATION TECHNOLOGY LABORAOTRY 17717C NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY 17718C GAITHERSBURG, MD 20899-8980 17719C PHONE--301-975-2855 17720C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 17721C OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY. 17722C LANGUAGE--ANSI FORTRAN (1977) 17723C VERSION NUMBER--2009/11 17724C ORIGINAL VERSION--NOVEMBER 2009. 17725C UPDATED --JANUARY 2009. PRINT VALUES OF POTENTIAL 17726C OUTLIERS 17727C UPDATED --AUGUST 2010. FOR TWO-SIDED CASE, POTENTIAL 17728C OUTLIERS PRINTED WERE CORRECT 17729C UPDATED --JULY 2019. TWEAK SCRATCH SPACE 17730C 17731C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 17732C 17733 CHARACTER*4 ICASAN 17734 CHARACTER*4 ICAPSW 17735 CHARACTER*4 IFORSW 17736 CHARACTER*4 IBUGA2 17737 CHARACTER*4 IBUGA3 17738 CHARACTER*4 IBUGQ 17739 CHARACTER*4 ISUBRO 17740 CHARACTER*4 IFOUND 17741 CHARACTER*4 IERROR 17742C 17743 CHARACTER*4 IWRITE 17744 CHARACTER*4 ICASP2 17745 CHARACTER*4 IHWUSE 17746 CHARACTER*4 MESSAG 17747 CHARACTER*4 IDATSW 17748 CHARACTER*4 IHP 17749 CHARACTER*4 IHP2 17750 CHARACTER*4 ISUBN1 17751 CHARACTER*4 ISUBN2 17752 CHARACTER*4 ISTEPN 17753 CHARACTER*4 IOP 17754C 17755 CHARACTER*4 IFLAGU 17756 LOGICAL IFRST 17757 LOGICAL ILAST 17758C 17759 CHARACTER*4 IREPL 17760 CHARACTER*4 IMULT 17761 CHARACTER*4 ICASE 17762 CHARACTER*4 IRANSV 17763 CHARACTER*4 ICTMP1 17764 CHARACTER*4 ICTMP2 17765 CHARACTER*4 ICTMP3 17766C 17767 CHARACTER*40 INAME 17768 PARAMETER (MAXSPN=30) 17769 CHARACTER*4 IVARN1(MAXSPN) 17770 CHARACTER*4 IVARN2(MAXSPN) 17771 CHARACTER*4 IVARTY(MAXSPN) 17772 CHARACTER*4 IVARID(MAXSPN) 17773 CHARACTER*4 IVARI2(MAXSPN) 17774 REAL PVAR(MAXSPN) 17775 REAL PID(MAXSPN) 17776 INTEGER ILIS(MAXSPN) 17777 INTEGER NRIGHT(MAXSPN) 17778 INTEGER ICOLR(MAXSPN) 17779C 17780C--------------------------------------------------------------------- 17781C 17782 INCLUDE 'DPCOPA.INC' 17783C 17784 DIMENSION Y1(MAXOBV) 17785 DIMENSION X1(MAXOBV) 17786 DIMENSION TEMP1(MAXOBV) 17787 DIMENSION TEMP2(MAXOBV) 17788 DIMENSION XTEMP1(MAXOBV) 17789 DIMENSION XTEMP2(MAXOBV) 17790 DIMENSION XTEMP3(MAXOBV) 17791 DIMENSION XTEMP4(MAXOBV) 17792 DIMENSION YSTAT(MAXOBV) 17793C 17794 DIMENSION XDESGN(MAXOBV,7) 17795 DIMENSION XIDTEM(MAXOBV) 17796 DIMENSION XIDTE2(MAXOBV) 17797 DIMENSION XIDTE3(MAXOBV) 17798 DIMENSION XIDTE4(MAXOBV) 17799 DIMENSION XIDTE5(MAXOBV) 17800 DIMENSION XIDTE6(MAXOBV) 17801C 17802 INTEGER ITEMP1(MAXOBV) 17803 INTEGER ITEMP2(MAXOBV) 17804 INTEGER ITEMP3(MAXOBV) 17805C 17806 INCLUDE 'DPCOZZ.INC' 17807 INCLUDE 'DPCOZI.INC' 17808C 17809 EQUIVALENCE (GARBAG(IGARB1),Y1(1)) 17810 EQUIVALENCE (GARBAG(IGARB2),X1(1)) 17811 EQUIVALENCE (GARBAG(IGARB4),XTEMP2(1)) 17812 EQUIVALENCE (GARBAG(IGARB5),XTEMP3(1)) 17813 EQUIVALENCE (GARBAG(IGARB6),XTEMP4(1)) 17814 EQUIVALENCE (GARBAG(IGARB7),TEMP1(1)) 17815 EQUIVALENCE (GARBAG(IGARB8),TEMP2(1)) 17816 EQUIVALENCE (GARBAG(IGARB9),YSTAT(1)) 17817 EQUIVALENCE (GARBAG(IGAR10),XIDTEM(1)) 17818 EQUIVALENCE (GARBAG(JGAR11),XIDTE2(1)) 17819 EQUIVALENCE (GARBAG(JGAR12),XIDTE3(1)) 17820 EQUIVALENCE (GARBAG(JGAR13),XIDTE4(1)) 17821 EQUIVALENCE (GARBAG(JGAR14),XIDTE5(1)) 17822 EQUIVALENCE (GARBAG(JGAR15),XIDTE6(1)) 17823 EQUIVALENCE (GARBAG(IGAR11),XDESGN(1,1)) 17824 EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1)) 17825 EQUIVALENCE (IGARBG(IIGAR2),ITEMP2(1)) 17826 EQUIVALENCE (IGARBG(IIGAR3),ITEMP3(1)) 17827C 17828C-----COMMON---------------------------------------------------------- 17829C 17830 INCLUDE 'DPCOHK.INC' 17831 INCLUDE 'DPCODA.INC' 17832 INCLUDE 'DPCOSU.INC' 17833 INCLUDE 'DPCOS2.INC' 17834 INCLUDE 'DPCOHO.INC' 17835 INCLUDE 'DPCOMC.INC' 17836 INCLUDE 'DPCOST.INC' 17837 INCLUDE 'DPCOF2.INC' 17838C 17839 COMMON/ISED/ISED1,ISED2,ISED3,ISED4,ISED5,ISED6, 17840 1 ISED7,ISED8,ISED9,ISED10,ISED11 17841C 17842C-----COMMON VARIABLES (GENERAL)-------------------------------------- 17843C 17844 INCLUDE 'DPCOP2.INC' 17845C 17846C-----START POINT----------------------------------------------------- 17847C 17848 IERROR='NO' 17849 ICASAN=' ' 17850 IREPL='OFF' 17851 IMULT='OFF' 17852 IRANSV=IRANAL 17853 IRANAL='FINC' 17854 ISEESV=ISEED 17855 ISEED=2503 17856 ISUBN1='DPTI' 17857 ISUBN2='ET ' 17858C 17859 MAXCP1=MAXCOL+1 17860 MAXCP2=MAXCOL+2 17861 MAXCP3=MAXCOL+3 17862 MAXCP4=MAXCOL+4 17863 MAXCP5=MAXCOL+5 17864 MAXCP6=MAXCOL+6 17865C 17866 MINN2=3 17867C 17868C *************************************************** 17869C ** TREAT THE TIETJEN MOORE CASE ** 17870C *************************************************** 17871C 17872 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TIET')THEN 17873 WRITE(ICOUT,999) 17874 999 FORMAT(1X) 17875 CALL DPWRST('XXX','BUG ') 17876 WRITE(ICOUT,51) 17877 51 FORMAT('***** AT THE BEGINNING OF DPTIET--') 17878 CALL DPWRST('XXX','BUG ') 17879 WRITE(ICOUT,52)ICASAN 17880 52 FORMAT('ICASAN = ',A4) 17881 CALL DPWRST('XXX','BUG ') 17882 WRITE(ICOUT,53)ICASAN,IBUGA2,IBUGA3,IBUGQ,MAXNXT 17883 53 FORMAT('ICASAN,IBUGA2,IBUGA3,IBUGQ,MAXNXT = ',4(A4,2X),I8) 17884 CALL DPWRST('XXX','BUG ') 17885 ENDIF 17886C 17887C ********************************************************* 17888C ** STEP 1-- ** 17889C ** EXTRACT THE COMMAND ** 17890C ** LOOK FOR ONE OF THE FOLLOWING COMMANDS: ** 17891C ** 1) TIETJEN MOORE TEST Y ** 17892C ** 2) TIETJEN MOORE TEST Y LABID ** 17893C ** 3) TIETJEN MOORE TEST Y1 ... YK ** 17894C ** 4) REPLICATED TIETJEN MOORE TEST Y X1 ... XK ** 17895C ** 5) REPLICATED TIETJEN MOORE TEST Y LABID X1 ... XK * 17896C ********************************************************* 17897C 17898 ISTEPN='1' 17899 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TIET') 17900 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17901C 17902 ILASTC=9999 17903 ILASTZ=9999 17904 IFOUND='NO' 17905 ICASAN='TWOS' 17906C 17907 DO100I=0,NUMARG-1 17908C 17909 IF(I.EQ.0)THEN 17910 ICTMP1=ICOM 17911 ICTMP2=IHARG(I+1) 17912 ICTMP3=IHARG(I+2) 17913 ELSE 17914 ICTMP1=IHARG(I) 17915 ICTMP2=IHARG(I+1) 17916 ICTMP3=IHARG(I+2) 17917 ENDIF 17918C 17919 IF(ICTMP1.EQ.'TIET' .AND. ICTMP2.EQ.'MOOR' .AND. 17920 1 ICTMP3.EQ.'TEST')THEN 17921 IFOUND='YES' 17922 ILASTC=I 17923 ILASTZ=I+2 17924 ELSEIF(ICTMP1.EQ.'TIET' .AND. ICTMP2.EQ.'MOOR')THEN 17925 IFOUND='YES' 17926 ILASTC=I 17927 ILASTZ=I+1 17928 ELSEIF(ICTMP1.EQ.'MINI')THEN 17929 ICASAN='MINI' 17930 ILASTC=MIN(ILASTC,I) 17931 ILASTZ=MAX(ILASTZ,I) 17932 ELSEIF(ICTMP1.EQ.'MAXI')THEN 17933 ICASAN='MAXI' 17934 ILASTC=MIN(ILASTC,I) 17935 ILASTZ=MAX(ILASTZ,I) 17936 ELSEIF(ICTMP1.EQ.'REPL')THEN 17937 IREPL='ON' 17938 ILASTC=MIN(ILASTC,I) 17939 ILASTZ=MAX(ILASTZ,I) 17940 ELSEIF(ICTMP1.EQ.'MULT')THEN 17941 IMULT='ON' 17942 ILASTC=MIN(ILASTC,I) 17943 ILASTZ=MAX(ILASTZ,I) 17944 ELSEIF(ICTMP1.EQ.'TEST')THEN 17945 ILASTC=MIN(ILASTC,I) 17946 ILASTZ=MAX(ILASTZ,I) 17947 ENDIF 17948 100 CONTINUE 17949C 17950 ISHIFT=ILASTZ 17951 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 17952 1 IBUGA2,IERROR) 17953C 17954 IF(IFOUND.EQ.'NO')GOTO9000 17955 IF(IMULT.EQ.'ON')THEN 17956 IF(IREPL.EQ.'ON')THEN 17957 WRITE(ICOUT,999) 17958 CALL DPWRST('XXX','BUG ') 17959 WRITE(ICOUT,101) 17960 101 FORMAT('***** ERROR IN TIETJEN-MOORE TEST--') 17961 CALL DPWRST('XXX','BUG ') 17962 WRITE(ICOUT,102) 17963 102 FORMAT(' YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ', 17964 1 '"REPLICATION" FOR') 17965 CALL DPWRST('XXX','BUG ') 17966 WRITE(ICOUT,103) 17967 103 FORMAT(' THE TIETJEN-MOORE TEST COMMAND.') 17968 CALL DPWRST('XXX','BUG ') 17969 IERROR='YES' 17970 GOTO9000 17971 ENDIF 17972 ENDIF 17973C 17974C ********************************* 17975C ** STEP 4-- ** 17976C ** EXTRACT THE VARIABLE LIST ** 17977C ********************************* 17978C 17979 ISTEPN='4' 17980 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TIET') 17981 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 17982C 17983 INAME='TIETJEN-MOORE TEST FOR OUTLIERS' 17984 MINNA=1 17985 MAXNA=100 17986 MINN2=2 17987 IFLAGE=1 17988 IF(IMULT.EQ.'ON')IFLAGE=0 17989 IFLAGM=1 17990 IF(IREPL.EQ.'ON')IFLAGM=0 17991 IFLAGP=0 17992 JMIN=1 17993 JMAX=NUMARG 17994 MINNVA=-99 17995 MAXNVA=-99 17996C 17997 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 17998 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 17999 1 JMIN,JMAX, 18000 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 18001 1 IVARN1,IVARN2,IVARTY,PVAR, 18002 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 18003 1 MINNVA,MAXNVA, 18004 1 IFLAGM,IFLAGP, 18005 1 IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 18006 IF(IERROR.EQ.'YES')GOTO9000 18007C 18008 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TIET')THEN 18009 WRITE(ICOUT,999) 18010 CALL DPWRST('XXX','BUG ') 18011 WRITE(ICOUT,281) 18012 281 FORMAT('***** AFTER CALL DPPARS--') 18013 CALL DPWRST('XXX','BUG ') 18014 WRITE(ICOUT,282)NQ,NUMVAR 18015 282 FORMAT('NQ,NUMVAR = ',2I8) 18016 CALL DPWRST('XXX','BUG ') 18017 IF(NUMVAR.GT.0)THEN 18018 DO285I=1,NUMVAR 18019 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 18020 1 ICOLR(I) 18021 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 18022 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 18023 CALL DPWRST('XXX','BUG ') 18024 285 CONTINUE 18025 ENDIF 18026 ENDIF 18027C 18028C *********************************************** 18029C ** STEP 5-- ** 18030C ** DETERMINE: ** 18031C ** 1) NUMBER OF REPLICATION VARIABLES (0-6) ** 18032C ** 2) NUMBER OF RESPONSE VARIABLES (>= 1)** 18033C *********************************************** 18034C 18035 ISTEPN='5' 18036 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TIET') 18037 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18038C 18039 NRESP=0 18040 NREPL=0 18041 NLABID=0 18042 IF(IMULT.EQ.'ON')THEN 18043 NRESP=NUMVAR 18044 ELSEIF(IREPL.EQ.'ON')THEN 18045 NRESP=1 18046 IF(NUMVAR.EQ.2)THEN 18047 NLABID=0 18048 NREPL=1 18049 ELSE 18050 NLABID=1 18051 NREPL=NUMVAR-NRESP-NLABID 18052 ENDIF 18053 IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN 18054 WRITE(ICOUT,999) 18055 CALL DPWRST('XXX','BUG ') 18056 WRITE(ICOUT,101) 18057 CALL DPWRST('XXX','BUG ') 18058 WRITE(ICOUT,511) 18059 511 FORMAT(' FOR THE REPLICATION CASE, THE NUMBER OF ', 18060 1 'REPLICATION VARIABLES') 18061 CALL DPWRST('XXX','BUG ') 18062 WRITE(ICOUT,513)NREPL 18063 513 FORMAT(' THE NUMBER OF REPLICATION VARIABLES = ',I5) 18064 CALL DPWRST('XXX','BUG ') 18065 IERROR='YES' 18066 GOTO9000 18067 ENDIF 18068 ELSE 18069 NRESP=1 18070 NLABID=NUMVAR-NRESP 18071 IF(NLABID.GT.1)NLABID=1 18072 ENDIF 18073C 18074 IHP='NOUT' 18075 IHP2='LIER' 18076 IHWUSE='P' 18077 MESSAG='NO' 18078 CALL CHECKN(IHP,IHP2,IHWUSE, 18079 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 18080 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 18081 IF(IERROR.EQ.'YES')THEN 18082 IR=1 18083 ELSE 18084 AR=VALUE(ILOCV) 18085 IR=INT(AR+0.1) 18086 IF(IR.LT.1)IR=1 18087 ENDIF 18088C 18089 IOP='OPEN' 18090 IFLAG1=0 18091 IFLAG2=1 18092 IFLAG3=0 18093 IFLAG4=0 18094 IFLAG5=0 18095 CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5, 18096 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 18097 1 IBUGA3,ISUBRO,IERROR) 18098 IF(IERROR.EQ.'YES')GOTO9000 18099C 18100 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TIET')THEN 18101 WRITE(ICOUT,521)NRESP,NLABID,NREPL,IR 18102 521 FORMAT('NRESP,NLABID,NREPL,IR = ',4I5) 18103 CALL DPWRST('XXX','BUG ') 18104 ENDIF 18105C 18106C ****************************************************** 18107C ** STEP 6-- ** 18108C ** GENERATE THE TIETJEN-MOORE TEST FOR THE VARIOUS ** 18109C ** CASES ** 18110C ****************************************************** 18111C 18112 ISTEPN='6' 18113 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TIET') 18114 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18115C 18116C ***************************************** 18117C ** STEP 7A-- ** 18118C ** CASE 1: SINGLE RESPONSE VARIABLE ** 18119C ** WITH NO REPLICATION ** 18120C ***************************************** 18121C 18122 IF(NRESP.EQ.1 .AND. NREPL.EQ.0)THEN 18123 ISTEPN='7A' 18124 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TIET') 18125 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18126C 18127 PID(1)=CPUMIN 18128 IVARID(1)=IVARN1(1) 18129 IVARI2(1)=IVARN2(1) 18130C 18131 ICOL=1 18132 NUMVA2=1 18133 IF(NLABID.GE.1)NUMVA2=2 18134 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 18135 1 INAME,IVARN1,IVARN2,IVARTY, 18136 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 18137 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 18138 1 MAXCP4,MAXCP5,MAXCP6, 18139 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 18140 1 Y1,X1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE, 18141 1 IBUGA3,ISUBRO,IFOUND,IERROR) 18142 IF(IERROR.EQ.'YES')GOTO9000 18143C 18144C ***************************************************** 18145C ** STEP 7B-- ** 18146C ** CALL DPTIE2 TO PERFORM THE OUTLIER TEST. ** 18147C ***************************************************** 18148C 18149C 18150 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TIET')THEN 18151 ISTEPN='7B' 18152 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18153 WRITE(ICOUT,999) 18154 CALL DPWRST('XXX','BUG ') 18155 WRITE(ICOUT,711) 18156 711 FORMAT('***** FROM THE MIDDLE OF DPTIET--') 18157 CALL DPWRST('XXX','BUG ') 18158 WRITE(ICOUT,712)ICASAN,NUMVAR,IDATSW,NLOCAL 18159 712 FORMAT('ICASAN,NUMVAR,IDATSW,NQ = ', 18160 1 A4,I8,2X,A4,I8) 18161 CALL DPWRST('XXX','BUG ') 18162 IF(NLOCAL.GE.1)THEN 18163 DO715I=1,NLOCAL 18164 WRITE(ICOUT,716)I,Y1(I),X1(I) 18165 716 FORMAT('I,Y1(I),X1(I) = ',I8,2F12.5) 18166 CALL DPWRST('XXX','BUG ') 18167 715 CONTINUE 18168 ENDIF 18169 ENDIF 18170C 18171 NREPL=0 18172 NCURVE=1 18173 CALL DPTIE2(Y1,X1,NLOCAL,ICASAN,IOUNI2,ISEED, 18174 1 YSTAT,XTEMP1,XTEMP2,XTEMP3,XTEMP4, 18175 1 ITEMP1,ITEMP2,ITEMP3, 18176 1 PID,IVARID,IVARI2,NCURVE,NREPL,NLABID,IR, 18177 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 18178 1 STATVA,STATCD,PVAL, 18179 1 CUT0,CUT01,CUT025,CUT05,CUT10, 18180 1 CUT25,CUT50,CUT100, 18181 1 ISUBRO,IBUGA3,IERROR) 18182C 18183C *************************************** 18184C ** STEP 7C-- ** 18185C ** UPDATE INTERNAL DATAPLOT TABLES ** 18186C *************************************** 18187C 18188 ISTEPN='7C' 18189 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TIET') 18190 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18191C 18192 IFLAGU='ON' 18193 IFRST=.FALSE. 18194 ILAST=.FALSE. 18195 CALL DPTIE4(STATVA,STATCD,PVAL, 18196 1 CUT0,CUT01,CUT025,CUT05,CUT10, 18197 1 CUT25,CUT50,CUT100, 18198 1 IFLAGU,IFRST,ILAST,ICASP2, 18199 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 18200C 18201C ****************************************** 18202C ** STEP 8A-- ** 18203C ** CASE 2: MULTIPLE RESPONSE VARIABLES ** 18204C ** NOTE THAT A LABID VARIABLE ** 18205C ** IS NOT SUPPORTED FOR THIS ** 18206C ** CASE. ** 18207C ****************************************** 18208C 18209 ELSEIF(NRESP.GT.1)THEN 18210 ISTEPN='8A' 18211 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TIET') 18212 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18213C 18214C LOOP THROUGH EACH OF THE RESPONSE VARIABLES 18215C 18216 NCURVE=0 18217 DO810IRESP=1,NRESP 18218 NCURVE=NCURVE+1 18219C 18220 IINDX=ICOLR(IRESP) 18221 PID(1)=CPUMIN 18222 IVARID(1)=IVARN1(IRESP) 18223 IVARI2(1)=IVARN2(IRESP) 18224C 18225 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TIET')THEN 18226 WRITE(ICOUT,999) 18227 CALL DPWRST('XXX','BUG ') 18228 WRITE(ICOUT,811)IRESP,NCURVE 18229 811 FORMAT('IRESP,NCURVE = ',2I5) 18230 CALL DPWRST('XXX','BUG ') 18231 ENDIF 18232C 18233 ICOL=IRESP 18234 NUMVA2=1 18235 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 18236 1 INAME,IVARN1,IVARN2,IVARTY, 18237 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 18238 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 18239 1 MAXCP4,MAXCP5,MAXCP6, 18240 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 18241 1 Y1,XTEMP1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE, 18242 1 IBUGA3,ISUBRO,IFOUND,IERROR) 18243 IF(IERROR.EQ.'YES')GOTO9000 18244 DO820I=1,NLOCAL 18245 X1(I)=REAL(I) 18246 820 CONTINUE 18247C 18248C ***************************************************** 18249C ** STEP 8B-- ** 18250C ** CALL DPTIE2 TO PERFORM THE OUTLIER TEST. ** 18251C ***************************************************** 18252C 18253 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TIET')THEN 18254 ISTEPN='8B' 18255 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18256 WRITE(ICOUT,999) 18257 CALL DPWRST('XXX','BUG ') 18258 WRITE(ICOUT,822) 18259 822 FORMAT('***** FROM THE MIDDLE OF DPTIET--') 18260 CALL DPWRST('XXX','BUG ') 18261 WRITE(ICOUT,823)ICASAN,NUMVAR,IDATSW,NLOCAL 18262 823 FORMAT('ICASAN,NUMVAR,IDATSW,NQ = ', 18263 1 A4,I8,2X,A4,I8) 18264 CALL DPWRST('XXX','BUG ') 18265 IF(NLOCAL.GE.1)THEN 18266 DO825I=1,NLOCAL 18267 WRITE(ICOUT,826)I,Y1(I),X1(I) 18268 826 FORMAT('I,Y1(I),X1(I) = ',I8,2F12.5) 18269 CALL DPWRST('XXX','BUG ') 18270 825 CONTINUE 18271 ENDIF 18272 ENDIF 18273C 18274 CALL DPTIE2(Y1,X1,NLOCAL,ICASAN,IOUNI2,ISEED, 18275 1 YSTAT,XTEMP1,XTEMP2,XTEMP3,XTEMP4, 18276 1 ITEMP1,ITEMP2,ITEMP3, 18277 1 PID,IVARID,IVARI2,NCURVE,NREPL,NLABID,IR, 18278 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 18279 1 STATVA,STATCD,PVAL, 18280 1 CUT0,CUT01,CUT025,CUT05,CUT10, 18281 1 CUT25,CUT50,CUT100, 18282 1 ISUBRO,IBUGA3,IERROR) 18283C 18284C *************************************** 18285C ** STEP 8C-- ** 18286C ** COMPUTE GRUBB STAT ** 18287C ** UPDATE INTERNAL DATAPLOT TABLES ** 18288C *************************************** 18289C 18290 ISTEPN='8C' 18291 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TIET') 18292 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18293C 18294 IFLAGU='FILE' 18295 IFRST=.FALSE. 18296 ILAST=.FALSE. 18297 IF(IRESP.EQ.1)IFRST=.TRUE. 18298 IF(IRESP.EQ.NRESP)ILAST=.TRUE. 18299 IFLAGU='ON' 18300 IFRST=.FALSE. 18301 ILAST=.FALSE. 18302 CALL DPTIE4(STATVA,STATCD,PVAL, 18303 1 CUT0,CUT01,CUT025,CUT05,CUT10, 18304 1 CUT25,CUT50,CUT100, 18305 1 IFLAGU,IFRST,ILAST,ICASP2, 18306 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 18307C 18308 810 CONTINUE 18309C 18310C **************************************************** 18311C ** STEP 9A-- ** 18312C ** CASE 3: ONE OR MORE REPLICATION VARIABLES. ** 18313C ** FOR THIS CASE, THE NUMBER OF RESPONSE ** 18314C ** VARIABLES MUST BE EXACTLY 1. ** 18315C ** FOR THIS CASE, ALL VARIABLES MUST ** 18316C ** HAVE THE SAME LENGTH. ** 18317C **************************************************** 18318C 18319 ELSEIF(IREPL.EQ.'ON')THEN 18320 ISTEPN='9A' 18321 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TIET') 18322 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18323C 18324 J=0 18325 IMAX=NRIGHT(1) 18326 IF(NQ.LT.NRIGHT(1))IMAX=NQ 18327 DO910I=1,IMAX 18328 IF(ISUB(I).EQ.0)GOTO910 18329 J=J+1 18330C 18331C RESPONSE VARIABLE IN Y1 18332C 18333 ICOLC=1 18334 IJ=MAXN*(ICOLR(ICOLC)-1)+I 18335 IF(ICOLR(ICOLC).LE.MAXCOL)Y1(J)=V(IJ) 18336 IF(ICOLR(ICOLC).EQ.MAXCP1)Y1(J)=PRED(I) 18337 IF(ICOLR(ICOLC).EQ.MAXCP2)Y1(J)=RES(I) 18338 IF(ICOLR(ICOLC).EQ.MAXCP3)Y1(J)=YPLOT(I) 18339 IF(ICOLR(ICOLC).EQ.MAXCP4)Y1(J)=XPLOT(I) 18340 IF(ICOLR(ICOLC).EQ.MAXCP5)Y1(J)=X2PLOT(I) 18341 IF(ICOLR(ICOLC).EQ.MAXCP6)Y1(J)=TAGPLO(I) 18342C 18343C LABID VARIABLE IN X1 18344C 18345 IF(NLABID.GE.1)THEN 18346 ICOLC=ICOLC+1 18347 ICOLT=ICOLR(ICOLC) 18348 IJ=MAXN*(ICOLT-1)+I 18349 IF(ICOLT.LE.MAXCOL)X1(J)=V(IJ) 18350 IF(ICOLT.EQ.MAXCP1)X1(J)=PRED(I) 18351 IF(ICOLT.EQ.MAXCP2)X1(J)=RES(I) 18352 IF(ICOLT.EQ.MAXCP3)X1(J)=YPLOT(I) 18353 IF(ICOLT.EQ.MAXCP4)X1(J)=XPLOT(I) 18354 IF(ICOLT.EQ.MAXCP5)X1(J)=X2PLOT(I) 18355 IF(ICOLT.EQ.MAXCP6)X1(J)=TAGPLO(I) 18356 ELSE 18357 X1(J)=REAL(I) 18358 ENDIF 18359C 18360 IF(NREPL.GE.1)THEN 18361 DO920IR=1,MIN(NREPL,6) 18362 ICOLC=ICOLC+1 18363 ICOLT=ICOLR(ICOLC) 18364 IJ=MAXN*(ICOLT-1)+I 18365 IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ) 18366 IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I) 18367 IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I) 18368 IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I) 18369 IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I) 18370 IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I) 18371 IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I) 18372 920 CONTINUE 18373 ENDIF 18374C 18375 910 CONTINUE 18376 NLOCAL=J 18377C 18378 ISTEPN='9B' 18379 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TIET') 18380 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18381C 18382C NOTE: CHECK TO SEE IF X1 HAS ALL UNIQUE ELEMENTS. IF NOT, 18383C THEN INTERPRET THIS AS A REPLICATION VARIABLE. 18384C 18385 CALL DISTIN(X1,NLOCAL,IWRITE,XTEMP2,NDIST,IBUGA3,IERROR) 18386 IF(NLOCAL.NE.NDIST)THEN 18387 NLABID=0 18388 IF(NREPL.GT.6)NREPL=6 18389 IF(NREPL.GE.1)THEN 18390 DO930J=1,NREPL-1 18391 DO935I=1,NLOCAL 18392 XDESGN(I,J+1)=XDESGN(I,J) 18393 935 CONTINUE 18394 930 CONTINUE 18395 ENDIF 18396 NREPL=NREPL+1 18397 DO938I=1,NLOCAL 18398 XDESGN(I,1)=X1(I) 18399 X1(I)=REAL(I) 18400 938 CONTINUE 18401 ENDIF 18402C 18403 PID(1)=CPUMIN 18404 IVARID(1)=IVARN1(1) 18405 IVARI2(1)=IVARN2(1) 18406 IF(NLABID.EQ.1)THEN 18407 PID(2)=CPUMIN 18408 IVARID(2)=IVARN1(2) 18409 IVARI2(2)=IVARN2(2) 18410 ENDIF 18411 IADD=NRESP+NLABID 18412 DO940II=1,NREPL 18413 IVARID(II+IADD)=IVARN1(II+IADD) 18414 IVARI2(II+IADD)=IVARN2(II+IADD) 18415 940 CONTINUE 18416C 18417C ***************************************************** 18418C ** STEP 9B-- ** 18419C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** 18420C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** 18421C ** ** 18422C ** FOR THIS CASE, WE NEED TO LOOP THROUGH THE ** 18423C ** VARIOUS REPLICATIONS. ** 18424C ***************************************************** 18425C 18426C 18427 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TIET')THEN 18428 ISTEPN='9C' 18429 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18430 WRITE(ICOUT,999) 18431 CALL DPWRST('XXX','BUG ') 18432 WRITE(ICOUT,941) 18433 941 FORMAT('***** FROM THE MIDDLE OF DPTIET--') 18434 CALL DPWRST('XXX','BUG ') 18435 WRITE(ICOUT,942)ICASAN,NUMVAR,IDATSW,NLOCAL,NREPL 18436 942 FORMAT('ICASAN,NUMVAR,IDATSW,NLOCAL,NREPL = ', 18437 1 A4,I8,2X,A4,2I8) 18438 CALL DPWRST('XXX','BUG ') 18439 IF(NLOCAL.GE.1)THEN 18440 DO945I=1,NLOCAL 18441 WRITE(ICOUT,946)I,Y1(I),X1(I),XDESGN(I,1),XDESGN(I,2) 18442 946 FORMAT('I,Y1(I),X1(I),XDESGN(I,1),XDESGN(I,2) = ', 18443 1 I8,4F12.5) 18444 CALL DPWRST('XXX','BUG ') 18445 945 CONTINUE 18446 ENDIF 18447 ENDIF 18448C 18449C ***************************************************** 18450C ** STEP 9C-- ** 18451C ** FIND THE DISTINCT VALUES IN EACH OF THE ** 18452C ** REPLICATION VARIABLES. ** 18453C ***************************************************** 18454C 18455 CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3), 18456 1 XDESGN(1,4),XDESGN(1,5),XDESGN(1,6), 18457 1 NREPL,NLOCAL,MAXOBV, 18458 1 XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6, 18459 1 XTEMP1,XTEMP2, 18460 1 NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6, 18461 1 IBUGA3,ISUBRO,IERROR) 18462C 18463C ***************************************************** 18464C ** STEP 9D-- ** 18465C ** NOW LOOP THROUGH THE VARIOUS REPLICATIONS ** 18466C ***************************************************** 18467C 18468 NPLOTP=0 18469 NCURVE=0 18470 IF(NREPL.EQ.1)THEN 18471 J=0 18472 DO1110ISET1=1,NUMSE1 18473 K=0 18474 PID(IADD+1)=XIDTEM(ISET1) 18475 DO1130I=1,NLOCAL 18476 IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN 18477 K=K+1 18478 TEMP1(K)=Y1(I) 18479 TEMP2(K)=X1(I) 18480 ENDIF 18481 1130 CONTINUE 18482 NTEMP=K 18483 NCURVE=NCURVE+1 18484 NPLOT1=NPLOTP 18485 IF(NTEMP.GT.0)THEN 18486 CALL DPTIE2(TEMP1,TEMP2,NTEMP,ICASAN,IOUNI2,ISEED, 18487 1 YSTAT,XTEMP1,XTEMP2,XTEMP3,XTEMP4, 18488 1 ITEMP1,ITEMP2,ITEMP3, 18489 1 PID,IVARID,IVARI2,NCURVE,NREPL,NLABID,IR, 18490 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 18491 1 STATVA,STATCD,PVAL, 18492 1 CUT0,CUT01,CUT025,CUT05,CUT10, 18493 1 CUT25,CUT50,CUT100, 18494 1 ISUBRO,IBUGA3,IERROR) 18495 ENDIF 18496 NPLOT2=NPLOTP 18497 IFLAGU='FILE' 18498 IFRST=.FALSE. 18499 ILAST=.FALSE. 18500 IF(NCURVE.EQ.1)IFRST=.TRUE. 18501 IF(NCURVE.EQ.NUMSE1)ILAST=.TRUE. 18502 NPTEMP=NPLOT2-NPLOT1 18503 CALL DPTIE4(STATVA,STATCD,PVAL, 18504 1 CUT0,CUT01,CUT025,CUT05,CUT10, 18505 1 CUT25,CUT50,CUT100, 18506 1 IFLAGU,IFRST,ILAST,ICASP2, 18507 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 18508 1110 CONTINUE 18509 ELSEIF(NREPL.EQ.2)THEN 18510 J=0 18511 NTOT=NUMSE1*NUMSE2 18512 DO1210ISET1=1,NUMSE1 18513 DO1220ISET2=1,NUMSE2 18514 K=0 18515 PID(1+IADD)=XIDTEM(ISET1) 18516 PID(2+IADD)=XIDTE2(ISET2) 18517 DO1290I=1,NLOCAL 18518 IF( 18519 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 18520 1 XIDTE2(ISET2).EQ.XDESGN(I,2) 18521 1 )THEN 18522 K=K+1 18523 TEMP1(K)=Y1(I) 18524 TEMP2(K)=X1(I) 18525 ENDIF 18526 1290 CONTINUE 18527 NTEMP=K 18528 NCURVE=NCURVE+1 18529 NPLOT1=NPLOTP 18530 IF(NTEMP.GT.0)THEN 18531 CALL DPTIE2(TEMP1,TEMP2,NTEMP,ICASAN,IOUNI2,ISEED, 18532 1 YSTAT,XTEMP1,XTEMP2,XTEMP3,XTEMP4, 18533 1 ITEMP1,ITEMP2,ITEMP3, 18534 1 PID,IVARID,IVARI2,NCURVE,NREPL,NLABID,IR, 18535 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 18536 1 STATVA,STATCD,PVAL, 18537 1 CUT0,CUT01,CUT025,CUT05,CUT10, 18538 1 CUT25,CUT50,CUT100, 18539 1 ISUBRO,IBUGA3,IERROR) 18540 ENDIF 18541 NPLOT2=NPLOTP 18542 IFLAGU='FILE' 18543 IFRST=.FALSE. 18544 ILAST=.FALSE. 18545 IF(NCURVE.EQ.1)IFRST=.TRUE. 18546 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 18547 NPTEMP=NPLOT2-NPLOT1 18548 CALL DPTIE4(STATVA,STATCD,PVAL, 18549 1 CUT0,CUT01,CUT025,CUT05,CUT10, 18550 1 CUT25,CUT50,CUT100, 18551 1 IFLAGU,IFRST,ILAST,ICASP2, 18552 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 18553 1220 CONTINUE 18554 1210 CONTINUE 18555 ELSEIF(NREPL.EQ.3)THEN 18556 J=0 18557 NTOT=NUMSE1*NUMSE2*NUMSE3 18558 DO1310ISET1=1,NUMSE1 18559 DO1320ISET2=1,NUMSE2 18560 DO1330ISET3=1,NUMSE3 18561 K=0 18562 PID(1+IADD)=XIDTEM(ISET1) 18563 PID(2+IADD)=XIDTE2(ISET2) 18564 PID(3+IADD)=XIDTE3(ISET3) 18565 DO1390I=1,NLOCAL 18566 IF( 18567 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 18568 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 18569 1 XIDTE3(ISET3).EQ.XDESGN(I,3) 18570 1 )THEN 18571 K=K+1 18572 TEMP1(K)=Y1(I) 18573 TEMP2(K)=X1(I) 18574 ENDIF 18575 1390 CONTINUE 18576 NTEMP=K 18577 NCURVE=NCURVE+1 18578 NPLOT1=NPLOTP 18579 IF(NTEMP.GT.0)THEN 18580 CALL DPTIE2(TEMP1,TEMP2,NTEMP,ICASAN,IOUNI2,ISEED, 18581 1 YSTAT,XTEMP1,XTEMP2,XTEMP3,XTEMP4, 18582 1 ITEMP1,ITEMP2,ITEMP3, 18583 1 PID,IVARID,IVARI2,NCURVE,NREPL,NLABID,IR, 18584 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 18585 1 STATVA,STATCD,PVAL, 18586 1 CUT0,CUT01,CUT025,CUT05,CUT10, 18587 1 CUT25,CUT50,CUT100, 18588 1 ISUBRO,IBUGA3,IERROR) 18589 ENDIF 18590 NPLOT2=NPLOTP 18591 IFLAGU='FILE' 18592 IFRST=.FALSE. 18593 ILAST=.FALSE. 18594 IF(NCURVE.EQ.1)IFRST=.TRUE. 18595 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 18596 NPTEMP=NPLOT2-NPLOT1 18597 CALL DPTIE4(STATVA,STATCD,PVAL, 18598 1 CUT0,CUT01,CUT025,CUT05,CUT10, 18599 1 CUT25,CUT50,CUT100, 18600 1 IFLAGU,IFRST,ILAST,ICASP2, 18601 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 18602 1330 CONTINUE 18603 1320 CONTINUE 18604 1310 CONTINUE 18605 ELSEIF(NREPL.EQ.4)THEN 18606 J=0 18607 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4 18608 DO1410ISET1=1,NUMSE1 18609 DO1420ISET2=1,NUMSE2 18610 DO1430ISET3=1,NUMSE3 18611 DO1440ISET4=1,NUMSE4 18612 K=0 18613 PID(1+IADD)=XIDTEM(ISET1) 18614 PID(2+IADD)=XIDTE2(ISET2) 18615 PID(3+IADD)=XIDTE3(ISET3) 18616 PID(4+IADD)=XIDTE4(ISET4) 18617 DO1490I=1,NLOCAL 18618 IF( 18619 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 18620 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 18621 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 18622 1 XIDTE4(ISET4).EQ.XDESGN(I,4) 18623 1 )THEN 18624 K=K+1 18625 TEMP1(K)=Y1(I) 18626 TEMP2(K)=X1(I) 18627 ENDIF 18628 1490 CONTINUE 18629 NTEMP=K 18630 NCURVE=NCURVE+1 18631 NPLOT1=NPLOTP 18632 IF(NTEMP.GT.0)THEN 18633 CALL DPTIE2(TEMP1,TEMP2,NTEMP,ICASAN,IOUNI2,ISEED, 18634 1 YSTAT,XTEMP1,XTEMP2,XTEMP3,XTEMP4, 18635 1 ITEMP1,ITEMP2,ITEMP3, 18636 1 PID,IVARID,IVARI2,NCURVE,NREPL,NLABID,IR, 18637 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 18638 1 STATVA,STATCD,PVAL, 18639 1 CUT0,CUT01,CUT025,CUT05,CUT10, 18640 1 CUT25,CUT50,CUT100, 18641 1 ISUBRO,IBUGA3,IERROR) 18642 ENDIF 18643 NPLOT2=NPLOTP 18644 IFLAGU='FILE' 18645 IFRST=.FALSE. 18646 ILAST=.FALSE. 18647 IF(NCURVE.EQ.1)IFRST=.TRUE. 18648 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 18649 NPTEMP=NPLOT2-NPLOT1 18650 CALL DPTIE4(STATVA,STATCD,PVAL, 18651 1 CUT0,CUT01,CUT025,CUT05,CUT10, 18652 1 CUT25,CUT50,CUT100, 18653 1 IFLAGU,IFRST,ILAST,ICASP2, 18654 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 18655 1440 CONTINUE 18656 1430 CONTINUE 18657 1420 CONTINUE 18658 1410 CONTINUE 18659 ELSEIF(NREPL.EQ.5)THEN 18660 J=0 18661 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5 18662 DO1510ISET1=1,NUMSE1 18663 DO1520ISET2=1,NUMSE2 18664 DO1530ISET3=1,NUMSE3 18665 DO1540ISET4=1,NUMSE4 18666 DO1550ISET5=1,NUMSE5 18667 K=0 18668 PID(1+IADD)=XIDTEM(ISET1) 18669 PID(2+IADD)=XIDTE2(ISET2) 18670 PID(3+IADD)=XIDTE3(ISET3) 18671 PID(4+IADD)=XIDTE4(ISET4) 18672 PID(5+IADD)=XIDTE5(ISET4) 18673 DO1590I=1,NLOCAL 18674 IF( 18675 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 18676 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 18677 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 18678 1 XIDTE4(ISET4).EQ.XDESGN(I,4) .AND. 18679 1 XIDTE5(ISET5).EQ.XDESGN(I,5) 18680 1 )THEN 18681 K=K+1 18682 TEMP1(K)=Y1(I) 18683 TEMP2(K)=X1(I) 18684 ENDIF 18685 1590 CONTINUE 18686 NTEMP=K 18687 NCURVE=NCURVE+1 18688 NPLOT1=NPLOTP 18689 IF(NTEMP.GT.0)THEN 18690 CALL DPTIE2(TEMP1,TEMP2,NTEMP,ICASAN,IOUNI2,ISEED, 18691 1 YSTAT,XTEMP1,XTEMP2,XTEMP3,XTEMP4, 18692 1 ITEMP1,ITEMP2,ITEMP3, 18693 1 PID,IVARID,IVARI2,NCURVE,NREPL,NLABID,IR, 18694 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 18695 1 STATVA,STATCD,PVAL, 18696 1 CUT0,CUT01,CUT025,CUT05,CUT10, 18697 1 CUT25,CUT50,CUT100, 18698 1 ISUBRO,IBUGA3,IERROR) 18699 ENDIF 18700 NPLOT2=NPLOTP 18701 IFLAGU='FILE' 18702 IFRST=.FALSE. 18703 ILAST=.FALSE. 18704 IF(NCURVE.EQ.1)IFRST=.TRUE. 18705 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 18706 NPTEMP=NPLOT2-NPLOT1 18707 CALL DPTIE4(STATVA,STATCD,PVAL, 18708 1 CUT0,CUT01,CUT025,CUT05,CUT10, 18709 1 CUT25,CUT50,CUT100, 18710 1 IFLAGU,IFRST,ILAST,ICASP2, 18711 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 18712 1550 CONTINUE 18713 1540 CONTINUE 18714 1530 CONTINUE 18715 1520 CONTINUE 18716 1510 CONTINUE 18717 ELSEIF(NREPL.EQ.6)THEN 18718 J=0 18719 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6 18720 DO1610ISET1=1,NUMSE1 18721 DO1620ISET2=1,NUMSE2 18722 DO1630ISET3=1,NUMSE3 18723 DO1640ISET4=1,NUMSE4 18724 DO1650ISET5=1,NUMSE5 18725 DO1660ISET6=1,NUMSE6 18726 K=0 18727 PID(1+IADD)=XIDTEM(ISET1) 18728 PID(2+IADD)=XIDTE2(ISET2) 18729 PID(3+IADD)=XIDTE3(ISET3) 18730 PID(4+IADD)=XIDTE4(ISET4) 18731 PID(5+IADD)=XIDTE5(ISET4) 18732 PID(6+IADD)=XIDTE6(ISET4) 18733 DO1690I=1,NLOCAL 18734 IF( 18735 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 18736 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 18737 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 18738 1 XIDTE4(ISET4).EQ.XDESGN(I,4) .AND. 18739 1 XIDTE5(ISET5).EQ.XDESGN(I,5) .AND. 18740 1 XIDTE6(ISET6).EQ.XDESGN(I,6) 18741 1 )THEN 18742 K=K+1 18743 TEMP1(K)=Y1(I) 18744 TEMP2(K)=X1(I) 18745 ENDIF 18746 1690 CONTINUE 18747 NTEMP=K 18748 NCURVE=NCURVE+1 18749 NPLOT1=NPLOTP 18750 IF(NTEMP.GT.0)THEN 18751 CALL DPTIE2(TEMP1,TEMP2,NTEMP,ICASAN,IOUNI2,ISEED, 18752 1 YSTAT,XTEMP1,XTEMP2,XTEMP3,XTEMP4, 18753 1 ITEMP1,ITEMP2,ITEMP3, 18754 1 PID,IVARID,IVARI2,NCURVE,NREPL,NLABID,IR, 18755 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 18756 1 STATVA,STATCD,PVAL, 18757 1 CUT0,CUT01,CUT025,CUT05,CUT10, 18758 1 CUT25,CUT50,CUT100, 18759 1 ISUBRO,IBUGA3,IERROR) 18760 ENDIF 18761 NPLOT2=NPLOTP 18762 IFLAGU='FILE' 18763 IFRST=.FALSE. 18764 ILAST=.FALSE. 18765 IF(NCURVE.EQ.1)IFRST=.TRUE. 18766 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 18767 NPTEMP=NPLOT2-NPLOT1 18768 CALL DPTIE4(STATVA,STATCD,PVAL, 18769 1 CUT0,CUT01,CUT025,CUT05,CUT10, 18770 1 CUT25,CUT50,CUT100, 18771 1 IFLAGU,IFRST,ILAST,ICASP2, 18772 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 18773 1660 CONTINUE 18774 1650 CONTINUE 18775 1640 CONTINUE 18776 1630 CONTINUE 18777 1620 CONTINUE 18778 1610 CONTINUE 18779 ENDIF 18780C 18781 ENDIF 18782C 18783C ***************** 18784C ** STEP 90-- ** 18785C ** EXIT ** 18786C ***************** 18787C 18788 9000 CONTINUE 18789C 18790 IRANAL=IRANSV 18791 ISEED=ISEESV 18792C 18793 IOP='CLOS' 18794 CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5, 18795 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 18796 1 IBUGA3,ISUBRO,IERROR) 18797C 18798 IF(IERROR.EQ.'YES')THEN 18799 IF(IWIDTH.GE.1)THEN 18800 WRITE(ICOUT,9001)(IANS(I),I=1,MIN(100,IWIDTH)) 18801 9001 FORMAT(100A1) 18802 CALL DPWRST('XXX','BUG ') 18803 ENDIF 18804 ENDIF 18805C 18806 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TIET')THEN 18807 WRITE(ICOUT,999) 18808 CALL DPWRST('XXX','BUG ') 18809 WRITE(ICOUT,9011) 18810 9011 FORMAT('***** AT THE END OF DPTIET--') 18811 CALL DPWRST('XXX','BUG ') 18812 WRITE(ICOUT,9012)IFOUND,IERROR 18813 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 18814 CALL DPWRST('XXX','BUG ') 18815 WRITE(ICOUT,9013)NPLOTP,NS,ICASAN 18816 9013 FORMAT('NPLOTP,NS,ICASAN = ',I8,I8,2X,A4) 18817 CALL DPWRST('XXX','BUG ') 18818 ENDIF 18819C 18820 RETURN 18821 END 18822 SUBROUTINE DPTIE2(Y,X,N,ICASAN,IOUNI2,ISEED, 18823 1 YSTAT,TEMP1,TEMP2,TEMP3,TEMP4, 18824 1 ITEMP1,ITEMP2,ITEMP3, 18825 1 PID,IVARID,IVARI2,NCURVE,NREPL,NLABID,IR, 18826 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 18827 1 STATVA,STATCD,PVAL, 18828 1 CUT0,CUT01,CUT025,CUT05,CUT10, 18829 1 CUT25,CUT50,CUT100, 18830 1 ISUBRO,IBUGA3,IERROR) 18831C 18832C PURPOSE--THIS ROUTINE CARRIES OUT THE TIETJEN-MOORE TEST FOR 18833C UNIVARIATE OUTLIERS (DATA ASSUMED TO FOLLOW AN 18834C APPROXIMATELY NORMAL DISTRIBUTION). THE NUMBER OF 18835C SUSPECTED OUTLIERS MUST BE SPECIFIED IN ADVANCE. 18836C EXAMPLE--TIETJEN-MOORE TEST Y 18837C REFERENCE--GARY TIETJEN AND ROGER MOORE (AUGUST 1972), "SOME 18838C GRUBBS-TYPE STATISTICS FOR THE DETECTION OF SEVERAL 18839C OUTLIERS", TECHNOMETRICS, VOL. 14, NO. 3, PP. 583-597. 18840C WRITTEN BY--ALAN HECKERT 18841C STATISTICAL ENGINEERING DIVISION 18842C INFORMATION TECHNOLOGY LABORATORY 18843C NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY 18844C GAITHERSBURG, MD 20899-8980 18845C PHONE--301-975-2899 18846C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 18847C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 18848C LANGUAGE--ANSI FORTRAN (1977) 18849C VERSION NUMBER--2009/11 18850C ORIGINAL VERSION--NOVEMBER 2009. 18851C UPDATED --JULY 2014. ADD SKEWNESS AND KURTOSIS TO 18852C SUMMARY STATISTICS 18853C 18854C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 18855C 18856 CHARACTER*4 ISUBRO 18857 CHARACTER*4 IBUGA3 18858 CHARACTER*4 IERROR 18859 CHARACTER*4 IVARID(*) 18860 CHARACTER*4 IVARI2(*) 18861 CHARACTER*4 ICAPSW 18862 CHARACTER*4 ICAPTY 18863 CHARACTER*4 IFORSW 18864 CHARACTER*4 ICASAN 18865C 18866 CHARACTER*40 IRTFFF 18867 CHARACTER*40 IRTFFP 18868C 18869 CHARACTER*4 IWRITE 18870 CHARACTER*4 IDIR 18871C 18872 CHARACTER*4 ISUBN1 18873 CHARACTER*4 ISUBN2 18874 CHARACTER*4 ISTEPN 18875C 18876 CHARACTER*4 IRTFMD 18877 COMMON/COMRTF/IRTFMD 18878C 18879 PARAMETER (NUMALP=8) 18880 REAL ALPHA(NUMALP) 18881C 18882 CHARACTER*1 IBASLC 18883 PARAMETER(NUMCLI=4) 18884 PARAMETER(MAXLIN=2) 18885 PARAMETER (MAXROW=50) 18886 CHARACTER*60 ITITLE 18887 CHARACTER*60 ITITLZ 18888 CHARACTER*1 ITITL9 18889 CHARACTER*60 ITEXT(MAXROW) 18890 CHARACTER*4 ALIGN(NUMCLI) 18891 CHARACTER*4 VALIGN(NUMCLI) 18892 REAL AVALUE(MAXROW) 18893 INTEGER NCTEXT(MAXROW) 18894 INTEGER IDIGIT(MAXROW) 18895 INTEGER NTOT(MAXROW) 18896 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 18897 CHARACTER*15 IVALUE(MAXROW,NUMCLI) 18898 CHARACTER*4 ITYPCO(NUMCLI) 18899 INTEGER NCTIT2(MAXLIN,NUMCLI) 18900 INTEGER NCVALU(MAXROW,NUMCLI) 18901 INTEGER IWHTML(NUMCLI) 18902 INTEGER IWRTF(NUMCLI) 18903 REAL AMAT(MAXROW,NUMCLI) 18904 LOGICAL IFRST 18905 LOGICAL ILAST 18906 LOGICAL IFLAG1 18907 LOGICAL IFLAG2 18908 LOGICAL IFLAG3 18909C 18910C--------------------------------------------------------------------- 18911C 18912 DIMENSION Y(*) 18913 DIMENSION X(*) 18914 DIMENSION YSTAT(*) 18915 DIMENSION TEMP1(*) 18916 DIMENSION TEMP2(*) 18917 DIMENSION TEMP3(*) 18918 DIMENSION TEMP4(*) 18919 DIMENSION PID(*) 18920C 18921 INTEGER ITEMP1(*) 18922 INTEGER ITEMP2(*) 18923 INTEGER ITEMP3(*) 18924C 18925C-----COMMON---------------------------------------------------------- 18926C 18927 INCLUDE 'DPCOP2.INC' 18928C 18929 DATA ALPHA/ 18930 1 0.0, 1.0, 2.5, 5.0, 10.0, 25.0, 50.0, 100.0/ 18931C 18932C-----START POINT----------------------------------------------------- 18933C 18934 ISUBN1='DPTI' 18935 ISUBN2='E2 ' 18936 IERROR='NO' 18937 STATVA=CPUMIN 18938 STATCD=CPUMIN 18939 PVAL=CPUMIN 18940 CUT0=CPUMIN 18941 CUT01=CPUMIN 18942 CUT025=CPUMIN 18943 CUT05=CPUMIN 18944 CUT10=CPUMIN 18945 CUT25=CPUMIN 18946 CUT50=CPUMIN 18947 CUT100=CPUMIN 18948C 18949 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TIE2')THEN 18950 WRITE(ICOUT,999) 18951 999 FORMAT(1X) 18952 CALL DPWRST('XXX','WRIT') 18953 WRITE(ICOUT,51) 18954 51 FORMAT('**** AT THE BEGINNING OF DPTIE2--') 18955 CALL DPWRST('XXX','WRIT') 18956 WRITE(ICOUT,52)ISUBRO,IBUGA3,ICASAN 18957 52 FORMAT('ISUBRO,IBUGA3,ICASAN = ',3(A4,2X)) 18958 CALL DPWRST('XXX','WRIT') 18959 WRITE(ICOUT,55)N 18960 55 FORMAT('N = ',I8) 18961 CALL DPWRST('XXX','WRIT') 18962 DO56I=1,N 18963 WRITE(ICOUT,57)I,Y(I),X(I) 18964 57 FORMAT('I,Y(I),X(I) = ',I8,2G15.7) 18965 CALL DPWRST('XXX','WRIT') 18966 56 CONTINUE 18967 ENDIF 18968C 18969C ******************************************** 18970C ** STEP 11-- ** 18971C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 18972C ******************************************** 18973C 18974 ISTEPN='11' 18975 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TIE2') 18976 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 18977C 18978 IF(N.LT.3)THEN 18979 WRITE(ICOUT,999) 18980 CALL DPWRST('XXX','WRIT') 18981 WRITE(ICOUT,1111) 18982 1111 FORMAT('***** ERROR IN TIETJEN-MOORE TEST--') 18983 CALL DPWRST('XXX','WRIT') 18984 WRITE(ICOUT,1113) 18985 1113 FORMAT(' THE NUMBER OF OBSERVATIONS IS LESS THAN 3.') 18986 CALL DPWRST('XXX','WRIT') 18987 WRITE(ICOUT,1114)N 18988 1114 FORMAT('SAMPLE SIZE = ',I8) 18989 CALL DPWRST('XXX','WRIT') 18990 IERROR='YES' 18991 GOTO9000 18992 ENDIF 18993C 18994 IF(IR.GE.N/2)THEN 18995 WRITE(ICOUT,999) 18996 CALL DPWRST('XXX','WRIT') 18997 WRITE(ICOUT,1111) 18998 CALL DPWRST('XXX','WRIT') 18999 WRITE(ICOUT,1121) 19000 1121 FORMAT(' THE SPECIFIED NUMBER OF SUSPECTED OUTLIERS IS ', 19001 1 'GREATER THAN N/2') 19002 CALL DPWRST('XXX','WRIT') 19003 WRITE(ICOUT,1123)IR 19004 1123 FORMAT('THE SUSPECTED NUMBER OF OUTLIERS = ',I8) 19005 CALL DPWRST('XXX','WRIT') 19006 WRITE(ICOUT,1125)N 19007 1125 FORMAT('THE SAMPLE SIZE = ',I8) 19008 CALL DPWRST('XXX','WRIT') 19009 IERROR='YES' 19010 GOTO9000 19011 ENDIF 19012C 19013 HOLD=Y(1) 19014 DO1135I=2,N 19015 IF(Y(I).NE.HOLD)GOTO1139 19016 1135 CONTINUE 19017 WRITE(ICOUT,999) 19018 CALL DPWRST('XXX','WRIT') 19019 WRITE(ICOUT,1111) 19020 CALL DPWRST('XXX','WRIT') 19021 WRITE(ICOUT,1131)HOLD 19022 1131 FORMAT(' THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7) 19023 CALL DPWRST('XXX','WRIT') 19024 IERROR='YES' 19025 GOTO9000 19026 1139 CONTINUE 19027C 19028C ************************************ 19029C ** STEP 21-- ** 19030C ** CARRY OUT CALCULATIONS ** 19031C ** FOR TIETJEN-MOORE TEST ** 19032C ************************************ 19033C 19034 ISTEPN='21' 19035 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TIE2') 19036 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19037C 19038 CALL DPTIE3(Y,N,ICASAN,IR, 19039 1 TEMP1,TEMP2,TEMP3,ITEMP1,ITEMP3, 19040 1 STATVA,YMEAN,YSD,YMIN,YMAX, 19041 1 ISUBRO,IBUGA3,IERROR) 19042C 19043 CALL STMOM3(Y,N,IWRITE,YSKEW,IBUGA3,IERROR) 19044 CALL STMOM4(Y,N,IWRITE,YKURT,IBUGA3,IERROR) 19045C 19046 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TIE2')THEN 19047 WRITE(ICOUT,2131)YMEAN,YSD,YMIN,YMAX,STATVA 19048 2131 FORMAT('YMEAN,YSD,YMIN,YMAX,STATVA = ',5G15.7) 19049 CALL DPWRST('XXX','WRIT') 19050 ENDIF 19051C 19052C ************************************ 19053C ** STEP 22-- ** 19054C ** COMPUTE CRITICAL VALUES VIA ** 19055C ** MONTE-CARLO SIMULATION ** 19056C ************************************ 19057C 19058 ISTEPN='22' 19059 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TIE2') 19060 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19061C 19062 NMCSAM=10000 19063 NTEMP=N 19064 DO2210I=1,NMCSAM 19065 CALL NORRAN(NTEMP,ISEED,TEMP4) 19066 CALL DPTIE3(TEMP4,NTEMP,ICASAN,IR, 19067 1 TEMP1,TEMP2,TEMP3,ITEMP1,ITEMP2, 19068 1 STATV2,YMEAN2,YSD2,YMIN2,YMAX2, 19069 1 ISUBRO,IBUGA3,IERROR) 19070 YSTAT(I)=STATV2 19071 WRITE(IOUNI2,'(3I8,2X,E15.7)')NCURVE,NREPL,I,YSTAT(I) 19072 2210 CONTINUE 19073 IDIR='LOWE' 19074 CALL DPGOF8(YSTAT,NMCSAM,STATVA,PVAL,IDIR, 19075 1 IBUGA3,ISUBRO,IERROR) 19076 STATCD=1.0 - PVAL 19077 CUT0=YSTAT(1) 19078 CUT100=YSTAT(NMCSAM) 19079 IWRITE='OFF' 19080 DO2220I=2,7 19081 P100=ALPHA(I) 19082 CALL PERCEN(P100,YSTAT,NMCSAM,IWRITE,TEMP1,NMCSAM, 19083 1 XSTAT,IBUGA3,IERROR) 19084 IF(I.EQ.2)CUT01=XSTAT 19085 IF(I.EQ.3)CUT025=XSTAT 19086 IF(I.EQ.4)CUT05=XSTAT 19087 IF(I.EQ.5)CUT10=XSTAT 19088 IF(I.EQ.6)CUT25=XSTAT 19089 IF(I.EQ.7)CUT50=XSTAT 19090 2220 CONTINUE 19091C 19092 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TIE2')THEN 19093 WRITE(ICOUT,2231)PVAL,STATCD,CUT0,CUT01,CUT025 19094 2231 FORMAT('PVAL,STATCD,CUT0,CUT01,CUT025 = ',5G15.7) 19095 CALL DPWRST('XXX','WRIT') 19096 WRITE(ICOUT,2233)CUT05,CUT10,CUT25,CUT50,CUT100 19097 2233 FORMAT('CUT05,CUT10,CUT25,CUT50,CUT100 = ',5G15.7) 19098 CALL DPWRST('XXX','WRIT') 19099 ENDIF 19100C 19101C 19102C ********************************* 19103C ** STEP 42-- ** 19104C ** WRITE OUT EVERYTHING ** 19105C ** FOR TIETJEN-MOORE TEST ** 19106C ********************************* 19107C 19108 ISTEPN='42' 19109 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TIE2') 19110 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19111C 19112 IF(IPRINT.EQ.'OFF')GOTO9000 19113C 19114 NUMDIG=7 19115 IF(IFORSW.EQ.'1')NUMDIG=1 19116 IF(IFORSW.EQ.'2')NUMDIG=2 19117 IF(IFORSW.EQ.'3')NUMDIG=3 19118 IF(IFORSW.EQ.'4')NUMDIG=4 19119 IF(IFORSW.EQ.'5')NUMDIG=5 19120 IF(IFORSW.EQ.'6')NUMDIG=6 19121 IF(IFORSW.EQ.'7')NUMDIG=7 19122 IF(IFORSW.EQ.'8')NUMDIG=8 19123 IF(IFORSW.EQ.'9')NUMDIG=9 19124 IF(IFORSW.EQ.'0')NUMDIG=0 19125 IF(IFORSW.EQ.'E')NUMDIG=-2 19126 IF(IFORSW.EQ.'-2')NUMDIG=-2 19127 IF(IFORSW.EQ.'-3')NUMDIG=-3 19128 IF(IFORSW.EQ.'-4')NUMDIG=-4 19129 IF(IFORSW.EQ.'-5')NUMDIG=-5 19130 IF(IFORSW.EQ.'-6')NUMDIG=-6 19131 IF(IFORSW.EQ.'-7')NUMDIG=-7 19132 IF(IFORSW.EQ.'-8')NUMDIG=-8 19133 IF(IFORSW.EQ.'-9')NUMDIG=-9 19134C 19135 IF(ICASAN.EQ.'TWOS')THEN 19136 ITITLE= 19137 1 'Tietjen-Moore Test for Multiple Outliers: Two-Sided Case' 19138 NCTITL=56 19139 ITITLZ='(Assumption: Normality)' 19140 NCTITZ=23 19141 ELSEIF(ICASAN.EQ.'MINI')THEN 19142 ITITLE='Tietjen-Moore Test for Multiple Outliers: Minimum Case' 19143 NCTITL=54 19144 ITITLZ='(Assumption: Normality)' 19145 NCTITZ=23 19146 ELSEIF(ICASAN.EQ.'MAXI')THEN 19147 ITITLE='Tietjen-Moore Test for Multiple Outliers: Maximum Case' 19148 NCTITL=54 19149 ITITLZ='(Assumption: Normality)' 19150 NCTITZ=23 19151 ENDIF 19152C 19153 ICNT=1 19154 ITEXT(ICNT)=' ' 19155 NCTEXT(ICNT)=0 19156 AVALUE(ICNT)=0.0 19157 IDIGIT(ICNT)=-1 19158 ICNT=ICNT+1 19159 ITEXT(ICNT)='Response Variable: ' 19160 WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4) 19161 WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4) 19162 NCTEXT(ICNT)=27 19163 AVALUE(ICNT)=0.0 19164 IDIGIT(ICNT)=-1 19165C 19166 IF(NREPL.GT.0)THEN 19167 NRESP=1 19168 IADD=NLABID+NRESP 19169 DO4101I=1,NREPL 19170 ICNT=ICNT+1 19171 ITEMP=I+IADD 19172 ITEXT(ICNT)='Factor Variable : ' 19173 WRITE(ITEXT(ICNT)(17:17),'(I1)')I 19174 WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4) 19175 WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4) 19176 NCTEXT(ICNT)=27 19177 AVALUE(ICNT)=PID(ITEMP) 19178 IDIGIT(ICNT)=NUMDIG 19179 4101 CONTINUE 19180 ENDIF 19181C 19182 ICNT=ICNT+1 19183 ITEXT(ICNT)=' ' 19184 NCTEXT(ICNT)=1 19185 AVALUE(ICNT)=0.0 19186 IDIGIT(ICNT)=-1 19187C 19188 ICNT=ICNT+1 19189 ITEXT(ICNT)='H0: There are no outliers' 19190 NCTEXT(ICNT)=25 19191 AVALUE(ICNT)=0.0 19192 IDIGIT(ICNT)=-1 19193 ICNT=ICNT+1 19194C 19195 ITEXT(ICNT)(1:8)='Ha: The ' 19196 WRITE(ITEXT(ICNT)(9:13),'(I5)')IR 19197 ISTRT=N-IR+1 19198 IF(ICASAN.EQ.'TWOS')THEN 19199 ITEXT(ICNT)(14:46)=' most extreme points are outliers' 19200 NCTEXT(ICNT)=46 19201 AVALUE(ICNT)=0.0 19202 IDIGIT(ICNT)=-1 19203 DO4111I=ISTRT,N 19204 ICNT=ICNT+1 19205 ITEXT(ICNT)='Potential Outlier Value Tested:' 19206 NCTEXT(ICNT)=31 19207CCCCC DPTIE3 SORTS Y APPROPRIATELY, SO ITEMP3 RETURNS WRONG 19208CCCCC VALUE, JUST PRINT THE Y 19209CCCCC INDOUT=ITEMP3(I) 19210CCCCC AVALUE(ICNT)=Y(INDOUT) 19211 AVALUE(ICNT)=Y(I) 19212 IDIGIT(ICNT)=NUMDIG 19213 4111 CONTINUE 19214 ELSEIF(ICASAN.EQ.'MINI')THEN 19215 ITEXT(ICNT)(14:41)=' minimum points are outliers' 19216 NCTEXT(ICNT)=41 19217 AVALUE(ICNT)=0.0 19218 IDIGIT(ICNT)=-1 19219 DO4113I=ISTRT,N 19220 ICNT=ICNT+1 19221 ITEXT(ICNT)='Potential Outlier Value Tested:' 19222 NCTEXT(ICNT)=31 19223 AVALUE(ICNT)=Y(I) 19224 IDIGIT(ICNT)=NUMDIG 19225 4113 CONTINUE 19226 ELSEIF(ICASAN.EQ.'MAXI')THEN 19227 ITEXT(ICNT)(14:41)=' maximum points are outliers' 19228 NCTEXT(ICNT)=41 19229 AVALUE(ICNT)=0.0 19230 IDIGIT(ICNT)=-1 19231 DO4115I=ISTRT,N 19232 ICNT=ICNT+1 19233 ITEXT(ICNT)='Potential Outlier Value Tested:' 19234 NCTEXT(ICNT)=31 19235 AVALUE(ICNT)=Y(I) 19236 IDIGIT(ICNT)=NUMDIG 19237 4115 CONTINUE 19238 ENDIF 19239C 19240 ICNT=ICNT+1 19241 ITEXT(ICNT)=' ' 19242 NCTEXT(ICNT)=1 19243 AVALUE(ICNT)=0.0 19244 IDIGIT(ICNT)=-1 19245 ICNT=ICNT+1 19246 ITEXT(ICNT)='Summary Statistics:' 19247 NCTEXT(ICNT)=19 19248 AVALUE(ICNT)=0.0 19249 IDIGIT(ICNT)=-1 19250 ICNT=ICNT+1 19251 ITEXT(ICNT)='Number of Observations:' 19252 NCTEXT(ICNT)=23 19253 AVALUE(ICNT)=REAL(N) 19254 IDIGIT(ICNT)=0 19255 ICNT=ICNT+1 19256 ITEXT(ICNT)='Sample Minimum:' 19257 NCTEXT(ICNT)=15 19258 AVALUE(ICNT)=YMIN 19259 IDIGIT(ICNT)=NUMDIG 19260CCCCC ICNT=ICNT+1 19261CCCCC ITEXT(ICNT)='ID for Sample Minimum:' 19262CCCCC NCTEXT(ICNT)=22 19263CCCCC AVALUE(ICNT)=X(INDMIN) 19264CCCCC IDIGIT(ICNT)=0 19265 ICNT=ICNT+1 19266 ITEXT(ICNT)='Sample Maximum:' 19267 NCTEXT(ICNT)=15 19268 AVALUE(ICNT)=YMAX 19269 IDIGIT(ICNT)=NUMDIG 19270CCCCC ICNT=ICNT+1 19271CCCCC ITEXT(ICNT)='ID for Sample Maximum:' 19272CCCCC NCTEXT(ICNT)=22 19273CCCCC AVALUE(ICNT)=X(INDMAX) 19274CCCCC IDIGIT(ICNT)=0 19275 ICNT=ICNT+1 19276 ITEXT(ICNT)='Sample Mean:' 19277 NCTEXT(ICNT)=12 19278 AVALUE(ICNT)=YMEAN 19279 IDIGIT(ICNT)=NUMDIG 19280 ICNT=ICNT+1 19281 ITEXT(ICNT)='Sample SD:' 19282 NCTEXT(ICNT)=10 19283 AVALUE(ICNT)=YSD 19284 IDIGIT(ICNT)=NUMDIG 19285 ICNT=ICNT+1 19286 ITEXT(ICNT)='Sample Skewness:' 19287 NCTEXT(ICNT)=16 19288 AVALUE(ICNT)=YSKEW 19289 IDIGIT(ICNT)=NUMDIG 19290 ICNT=ICNT+1 19291 ITEXT(ICNT)='Sample Kurtosis:' 19292 NCTEXT(ICNT)=16 19293 AVALUE(ICNT)=YKURT 19294 IDIGIT(ICNT)=NUMDIG 19295 ICNT=ICNT+1 19296 ITEXT(ICNT)=' ' 19297 NCTEXT(ICNT)=1 19298 AVALUE(ICNT)=0.0 19299 IDIGIT(ICNT)=-1 19300 ICNT=ICNT+1 19301 ITEXT(ICNT)='Tietjen-Moore Test Statistic Value:' 19302 NCTEXT(ICNT)=35 19303 AVALUE(ICNT)=STATVA 19304 IDIGIT(ICNT)=NUMDIG 19305C 19306 ICNT=ICNT+1 19307 ITEXT(ICNT)='CDF Value:' 19308 NCTEXT(ICNT)=10 19309 AVALUE(ICNT)=STATCD 19310 IDIGIT(ICNT)=NUMDIG 19311 ICNT=ICNT+1 19312 ITEXT(ICNT)='P-Value:' 19313 NCTEXT(ICNT)=7 19314 AVALUE(ICNT)=PVAL 19315 IDIGIT(ICNT)=NUMDIG 19316 ICNT=ICNT+1 19317 ITEXT(ICNT)=' ' 19318 NCTEXT(ICNT)=1 19319 AVALUE(ICNT)=0.0 19320 IDIGIT(ICNT)=-1 19321C 19322 NUMROW=ICNT 19323 DO4210I=1,NUMROW 19324 NTOT(I)=15 19325 4210 CONTINUE 19326C 19327 IFRST=.TRUE. 19328 ILAST=.TRUE. 19329C 19330 ISTEPN='42A' 19331 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TIE2') 19332 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19333C 19334 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT, 19335 1 AVALUE,IDIGIT, 19336 1 NTOT,NUMROW, 19337 1 ICAPSW,ICAPTY,ILAST,IFRST, 19338 1 ISUBRO,IBUGA3,IERROR) 19339C 19340 ISTEPN='42B' 19341 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TIE2') 19342 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19343C 19344 ITITLE=' ' 19345 NCTITL=0 19346C 19347 ITITL9=' ' 19348 NCTIT9=0 19349 ITITLE(1:44)='Percent Points of the Reference Distribution' 19350 NCTITL=44 19351 NUMLIN=1 19352 NUMROW=8 19353 NUMCOL=3 19354 ITITL2(1,1)='Percent Point' 19355 ITITL2(1,2)=' ' 19356 ITITL2(1,3)='Value' 19357 NCTIT2(1,1)=13 19358 NCTIT2(1,2)=1 19359 NCTIT2(1,3)=5 19360C 19361 NMAX=0 19362 DO4221I=1,NUMCOL 19363 VALIGN(I)='b' 19364 ALIGN(I)='r' 19365 NTOT(I)=15 19366 IF(I.EQ.2)NTOT(I)=5 19367 NMAX=NMAX+NTOT(I) 19368 IDIGIT(I)=NUMDIG 19369 ITYPCO(I)='NUME' 19370 4221 CONTINUE 19371 ITYPCO(2)='ALPH' 19372 IDIGIT(1)=1 19373 IDIGIT(3)=3 19374 DO4223I=1,NUMROW 19375 DO4225J=1,NUMCOL 19376 NCVALU(I,J)=0 19377 IVALUE(I,J)=' ' 19378 NCVALU(I,J)=0 19379 AMAT(I,J)=0.0 19380 IF(J.EQ.1)THEN 19381 AMAT(I,J)=ALPHA(I) 19382 ELSEIF(J.EQ.2)THEN 19383 IVALUE(I,J)='=' 19384 NCVALU(I,J)=1 19385 ELSEIF(J.EQ.3)THEN 19386 IF(I.EQ.1)THEN 19387 AMAT(I,J)=RND(CUT0,IDIGIT(J)) 19388 ELSEIF(I.EQ.2)THEN 19389 AMAT(I,J)=RND(CUT01,IDIGIT(J)) 19390 ELSEIF(I.EQ.3)THEN 19391 AMAT(I,J)=RND(CUT025,IDIGIT(J)) 19392 ELSEIF(I.EQ.4)THEN 19393 AMAT(I,J)=RND(CUT05,IDIGIT(J)) 19394 ELSEIF(I.EQ.5)THEN 19395 AMAT(I,J)=RND(CUT10,IDIGIT(J)) 19396 ELSEIF(I.EQ.6)THEN 19397 AMAT(I,J)=RND(CUT25,IDIGIT(J)) 19398 ELSEIF(I.EQ.7)THEN 19399 AMAT(I,J)=RND(CUT50,IDIGIT(J)) 19400 ELSEIF(I.EQ.8)THEN 19401 AMAT(I,J)=RND(CUT100,IDIGIT(J)) 19402 ENDIF 19403 ENDIF 19404 4225 CONTINUE 19405 4223 CONTINUE 19406C 19407 IWHTML(1)=150 19408 IWHTML(2)=50 19409 IWHTML(3)=150 19410 IWRTF(1)=2000 19411 IWRTF(2)=IWRTF(1)+500 19412 IWRTF(3)=IWRTF(2)+2000 19413 IFRST=.TRUE. 19414 ILAST=.FALSE. 19415C 19416 ISTEPN='42C' 19417 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TIE2') 19418 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19419C 19420 CALL DPDTA4(ITITL9,NCTIT9, 19421 1 ITITLE,NCTITL,ITITL2,NCTIT2, 19422 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 19423 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW, 19424 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 19425 1 ICAPSW,ICAPTY,IFRST,ILAST, 19426 1 ISUBRO,IBUGA3,IERROR) 19427C 19428 ISTEPN='42D' 19429 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TIE2') 19430 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19431C 19432 CDF1=CUT10 19433 CDF2=CUT05 19434 CDF3=CUT025 19435 CDF4=CUT01 19436C 19437 ITITL9=' ' 19438 NCTIT9=0 19439 ITITLE='Conclusions (Lower 1-Tailed Test)' 19440 NCTITL=33 19441 NUMLIN=1 19442 NUMROW=4 19443 NUMCOL=4 19444 ITITL2(1,1)='Alpha' 19445 ITITL2(1,2)='CDF' 19446 ITITL2(1,3)='Critical Value' 19447 ITITL2(1,4)='Conclusion' 19448 NCTIT2(1,1)=5 19449 NCTIT2(1,2)=3 19450 NCTIT2(1,3)=14 19451 NCTIT2(1,4)=10 19452C 19453 NMAX=0 19454 DO4321I=1,NUMCOL 19455 VALIGN(I)='b' 19456 ALIGN(I)='r' 19457 NTOT(I)=15 19458 IF(I.EQ.1 .OR. I.EQ.2)NTOT(I)=7 19459 IF(I.EQ.3)NTOT(I)=17 19460 NMAX=NMAX+NTOT(I) 19461 IDIGIT(I)=3 19462 ITYPCO(I)='ALPH' 19463 4321 CONTINUE 19464 ITYPCO(3)='NUME' 19465 IDIGIT(1)=0 19466 IDIGIT(2)=0 19467 DO4323I=1,NUMROW 19468 DO4325J=1,NUMCOL 19469 NCVALU(I,J)=0 19470 IVALUE(I,J)=' ' 19471 NCVALU(I,J)=0 19472 AMAT(I,J)=0.0 19473 4325 CONTINUE 19474 4323 CONTINUE 19475 IVALUE(1,1)='10%' 19476 IVALUE(2,1)='5%' 19477 IVALUE(3,1)='2.5%' 19478 IVALUE(4,1)='1%' 19479 IVALUE(1,2)='10%' 19480 IVALUE(2,2)='5%' 19481 IVALUE(3,2)='2.5%' 19482 IVALUE(4,2)='1%' 19483 NCVALU(1,1)=3 19484 NCVALU(2,1)=2 19485 NCVALU(3,1)=4 19486 NCVALU(4,1)=2 19487 NCVALU(1,2)=3 19488 NCVALU(2,2)=2 19489 NCVALU(3,2)=4 19490 NCVALU(4,2)=2 19491 IVALUE(1,4)='Accept H0' 19492 IVALUE(2,4)='Accept H0' 19493 IVALUE(3,4)='Accept H0' 19494 IVALUE(4,4)='Accept H0' 19495 NCVALU(1,4)=9 19496 NCVALU(2,4)=9 19497 NCVALU(3,4)=9 19498 NCVALU(4,4)=9 19499 IF(STATVA.LT.CDF1)IVALUE(1,4)='Reject H0' 19500 IF(STATVA.LT.CDF2)IVALUE(2,4)='Reject H0' 19501 IF(STATVA.LT.CDF3)IVALUE(3,4)='Reject H0' 19502 IF(STATVA.LT.CDF4)IVALUE(4,4)='Reject H0' 19503 AMAT(1,3)=RND(CDF1,IDIGIT(3)) 19504 AMAT(2,3)=RND(CDF2,IDIGIT(3)) 19505 AMAT(3,3)=RND(CDF3,IDIGIT(3)) 19506 AMAT(4,3)=RND(CDF4,IDIGIT(3)) 19507C 19508 IWHTML(1)=150 19509 IWHTML(2)=150 19510 IWHTML(3)=150 19511 IWHTML(4)=150 19512 IWRTF(1)=1500 19513 IWRTF(2)=IWRTF(1)+1500 19514 IWRTF(3)=IWRTF(2)+2000 19515 IWRTF(4)=IWRTF(3)+2000 19516 IFRST=.FALSE. 19517C 19518C FOR LATEX, WE WANT TO ENSURE THAT TRAILING LINE IS PART 19519C OF THE TABLE SO THAT IT WILL BE PRINTED IN THE PROPER PLACE. 19520C 19521 IF(ICAPTY.EQ.'LATE')THEN 19522 ILAST=.FALSE. 19523 ELSE 19524 ILAST=.TRUE. 19525 ENDIF 19526C 19527 ISTEPN='42E' 19528 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TIE2') 19529 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19530C 19531 CALL DPDTA4(ITITL9,NCTIT9, 19532 1 ITITLE,NCTITL,ITITL2,NCTIT2, 19533 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 19534 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW, 19535 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 19536 1 ICAPSW,ICAPTY,IFRST,ILAST, 19537 1 ISUBRO,IBUGA3,IERROR) 19538C 19539 ITITLE(1:26)='*Critical Values Based on ' 19540 WRITE(ITITLE(27:34),'(I8)')NMCSAM 19541 ITITLE(35:58)=' Monte Carlo Simulations' 19542 NCTITL=58 19543C 19544 IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN 19545 CALL DPHTMV(ITITLE,NCTITL,CPUMIN,NUMDIG) 19546 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN 19547 CALL DPLATV(ITITLE,NCTITL,CPUMIN,NUMDIG) 19548 IFLAG1=.FALSE. 19549 IFLAG2=.TRUE. 19550 IFLAG3=.TRUE. 19551 CALL DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD) 19552 ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF ')THEN 19553C 19554 CALL DPCONA(92,IBASLC) 19555 IRTFMD='OFF' 19556 IPTSZ=14 19557 WRITE(ICOUT,8199)IBASLC,IPTSZ 19558 8199 FORMAT(A1,'fs',I2) 19559 CALL DPWRST(ICOUT,'WRIT') 19560 IF(IRTFFF.EQ.'Courier New')THEN 19561 ITEMP=1 19562 ELSEIF(IRTFFF.EQ.'Lucida Console')THEN 19563 ITEMP=8 19564 ENDIF 19565 WRITE(ICOUT,8301)IBASLC,ITEMP 19566 CALL DPWRST(ICOUT,'WRIT') 19567 CALL DPRTFZ(ITITLE,NCTITL,CPUMIN,NUMDIG) 19568 IF(IRTFFP.EQ.'Times New Roman')THEN 19569 ITEMP=0 19570 ELSEIF(IRTFFP.EQ.'Lucida Sans')THEN 19571 ITEMP=6 19572 ELSEIF(IRTFFP.EQ.'Arial')THEN 19573 ITEMP=2 19574 ELSEIF(IRTFFP.EQ.'Bookman')THEN 19575 ITEMP=3 19576 ELSEIF(IRTFFP.EQ.'Georgia')THEN 19577 ITEMP=4 19578 ELSEIF(IRTFFP.EQ.'Tahoma')THEN 19579 ITEMP=5 19580 ELSEIF(IRTFFP.EQ.'Verdana')THEN 19581 ITEMP=7 19582 ENDIF 19583 WRITE(ICOUT,8301)IBASLC,ITEMP 19584 8301 FORMAT(A1,'f',I1) 19585 CALL DPWRST(ICOUT,'WRIT') 19586C 19587C END TABLE AND RESET "ASIS" MODE 19588C 19589 IF(IRTFFF.EQ.'Courier New')THEN 19590 ITEMP=1 19591 ELSEIF(IRTFFF.EQ.'Lucida Console')THEN 19592 ITEMP=8 19593 ENDIF 19594 WRITE(ICOUT,8091)IBASLC,ITEMP 19595 8091 FORMAT(A1,'f',I1) 19596 CALL DPWRST(ICOUT,'WRIT') 19597C 19598 CALL DPRTF6(NHEAD) 19599 CALL DPRTF6(NHEAD) 19600 IRTFMD='VERB' 19601 ELSE 19602 WRITE(ICOUT,2589)ITITLE(1:58) 19603 2589 FORMAT(A60) 19604 CALL DPWRST('XXX','BUG ') 19605 ENDIF 19606C 19607C ***************** 19608C ** STEP 90-- ** 19609C ** EXIT ** 19610C ***************** 19611C 19612 9000 CONTINUE 19613 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TIE2')THEN 19614 WRITE(ICOUT,999) 19615 CALL DPWRST('XXX','WRIT') 19616 WRITE(ICOUT,9011) 19617 9011 FORMAT('***** AT THE END OF DPTIE2--') 19618 CALL DPWRST('XXX','WRIT') 19619 WRITE(ICOUT,9012)N,IERROR 19620 9012 FORMAT('N,IERROR = ',I8,2X,A4) 19621 CALL DPWRST('XXX','WRIT') 19622 WRITE(ICOUT,9013)STATVA,STATCD,PVAL 19623 9013 FORMAT('STATVA,STATCD,PVAL = ',3G15.7) 19624 CALL DPWRST('XXX','WRIT') 19625 ENDIF 19626C 19627 RETURN 19628 END 19629 SUBROUTINE DPTIE3(Y,N,ICASAN,IR, 19630 1 TEMP1,TEMP2,TEMP3,ITEMP1,ITEMP2, 19631 1 STATVA,YMEAN,YSD,YMIN,YMAX, 19632 1 ISUBRO,IBUGA3,IERROR) 19633C 19634C PURPOSE--THIS ROUTINE IS SPLIT OFF FROM DPTIE2 TO COMPUTE 19635C TIETJEN-MOORE STATISTIC. THIS ROUTINE JUST RETURNS 19636C THE VALUE OF THE TEST STATISTIC (I.E., NO CRITICAL 19637C VALUES OR PRINTING). THIS SIMPLIFIES THE SIMULATION 19638C STEP USED TO OBTAIN THE CRITICAL VALUES. 19639C REFERENCE--GARY TIETJEN AND ROGER MOORE (AUGUST 1972), "SOME 19640C GRUBBS-TYPE STATISTICS FOR THE DETECTION OF SEVERAL 19641C OUTLIERS", TECHNOMETRICS, VOL. 14, NO. 3, PP. 583-597. 19642C WRITTEN BY--ALAN HECKERT 19643C STATISTICAL ENGINEERING DIVISION 19644C INFORMATION TECHNOLOGY LABORATORY 19645C NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY 19646C GAITHERSBURG, MD 20899-8980 19647C PHONE--301-975-2899 19648C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 19649C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 19650C LANGUAGE--ANSI FORTRAN (1977) 19651C VERSION NUMBER--2009/11 19652C ORIGINAL VERSION--NOVEMBER 2009. 19653C UPDATED --JANUARY 2009. SAVE INDICES FOR VALUES TO 19654C BE TESTED AS OUTLIERS 19655C UPDATED --JULY 2014. ADD SKEWNESS AND KURTOSIS TO 19656C SUMMARY STATISTICS 19657C 19658C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19659C 19660 CHARACTER*4 ISUBRO 19661 CHARACTER*4 IBUGA3 19662 CHARACTER*4 IERROR 19663 CHARACTER*4 ICASAN 19664C 19665 CHARACTER*4 IWRITE 19666C 19667 CHARACTER*4 ISUBN1 19668 CHARACTER*4 ISUBN2 19669 CHARACTER*4 ISTEPN 19670C 19671 DOUBLE PRECISION DSUMN 19672 DOUBLE PRECISION DSUMD 19673 DOUBLE PRECISION DTERM1 19674C 19675C--------------------------------------------------------------------- 19676C 19677 DIMENSION Y(*) 19678 DIMENSION TEMP1(*) 19679 DIMENSION TEMP2(*) 19680 DIMENSION TEMP3(*) 19681C 19682 INTEGER ITEMP1(*) 19683 INTEGER ITEMP2(*) 19684C 19685C-----COMMON---------------------------------------------------------- 19686C 19687 INCLUDE 'DPCOP2.INC' 19688C 19689C-----START POINT----------------------------------------------------- 19690C 19691 ISUBN1='DPTI' 19692 ISUBN2='E3 ' 19693 IERROR='NO' 19694 STATVA=CPUMIN 19695C 19696 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TIE3')THEN 19697 WRITE(ICOUT,999) 19698 999 FORMAT(1X) 19699 CALL DPWRST('XXX','WRIT') 19700 WRITE(ICOUT,51) 19701 51 FORMAT('**** AT THE BEGINNING OF DPTIE3--') 19702 CALL DPWRST('XXX','WRIT') 19703 WRITE(ICOUT,52)ISUBRO,IBUGA3,ICASAN 19704 52 FORMAT('ISUBRO,IBUGA3,ICASAN = ',3(A4,2X)) 19705 CALL DPWRST('XXX','WRIT') 19706 WRITE(ICOUT,55)N 19707 55 FORMAT('N = ',I8) 19708 CALL DPWRST('XXX','WRIT') 19709 DO56I=1,N 19710 WRITE(ICOUT,57)I,Y(I) 19711 57 FORMAT('I,Y(I) = ',I8,G15.7) 19712 CALL DPWRST('XXX','WRIT') 19713 56 CONTINUE 19714 ENDIF 19715C 19716C ******************************************** 19717C ** STEP 11-- ** 19718C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 19719C ******************************************** 19720C 19721 ISTEPN='11' 19722 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TIE3') 19723 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19724C 19725 IF(N.LT.3)THEN 19726 WRITE(ICOUT,999) 19727 CALL DPWRST('XXX','WRIT') 19728 WRITE(ICOUT,1111) 19729 1111 FORMAT('***** ERROR IN TIETJEN-MOORE TEST--') 19730 CALL DPWRST('XXX','WRIT') 19731 WRITE(ICOUT,1113) 19732 1113 FORMAT(' THE NUMBER OF OBSERVATIONS IS LESS THAN 3.') 19733 CALL DPWRST('XXX','WRIT') 19734 WRITE(ICOUT,1114)N 19735 1114 FORMAT('SAMPLE SIZE = ',I8) 19736 CALL DPWRST('XXX','WRIT') 19737 IERROR='YES' 19738 GOTO9000 19739 ENDIF 19740C 19741 IF(IR.GE.N/2)THEN 19742 WRITE(ICOUT,999) 19743 CALL DPWRST('XXX','WRIT') 19744 WRITE(ICOUT,1111) 19745 CALL DPWRST('XXX','WRIT') 19746 WRITE(ICOUT,1121) 19747 1121 FORMAT(' THE SPECIFIED NUMBER OF SUSPECTED OUTLIERS IS ', 19748 1 'GREATER THAN N/2') 19749 CALL DPWRST('XXX','WRIT') 19750 WRITE(ICOUT,1123)IR 19751 1123 FORMAT('THE SUSPECTED NUMBER OF OUTLIERS = ',I8) 19752 CALL DPWRST('XXX','WRIT') 19753 WRITE(ICOUT,1125)N 19754 1125 FORMAT('THE SAMPLE SIZE = ',I8) 19755 CALL DPWRST('XXX','WRIT') 19756 IERROR='YES' 19757 GOTO9000 19758 ENDIF 19759C 19760 HOLD=Y(1) 19761 DO1135I=2,N 19762 IF(Y(I).NE.HOLD)GOTO1139 19763 1135 CONTINUE 19764 WRITE(ICOUT,999) 19765 CALL DPWRST('XXX','WRIT') 19766 WRITE(ICOUT,1111) 19767 CALL DPWRST('XXX','WRIT') 19768 WRITE(ICOUT,1131)HOLD 19769 1131 FORMAT(' THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7) 19770 CALL DPWRST('XXX','WRIT') 19771 IERROR='YES' 19772 GOTO9000 19773 1139 CONTINUE 19774C 19775C ************************************ 19776C ** STEP 21-- ** 19777C ** CARRY OUT CALCULATIONS ** 19778C ** FOR TIETJEN-MOORE TEST ** 19779C ************************************ 19780C 19781 ISTEPN='21' 19782 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TIE3') 19783 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19784C 19785 IWRITE='OFF' 19786 CALL SORT(Y,N,Y) 19787 YMIN=Y(1) 19788 YMAX=Y(N) 19789 CALL MEAN(Y,N,IWRITE,YMEAN,IBUGA3,IERROR) 19790 CALL SD(Y,N,IWRITE,YSD,IBUGA3,IERROR) 19791 DO2101I=1,N 19792 ITEMP1(I)=I 19793 2101 CONTINUE 19794C 19795 IF(ICASAN.EQ.'TWOS')THEN 19796 DO2110I=1,N 19797 TEMP1(I)=ABS(Y(I)-YMEAN) 19798 2110 CONTINUE 19799CCCCC CALL SORTC3(TEMP1,ITEMP1,N,TEMP2,ITEMP2) 19800 CALL SORTC(TEMP1,Y,N,TEMP2,TEMP3) 19801 DO2115I=1,N 19802 Y(I)=TEMP3(I) 19803 2115 CONTINUE 19804 ELSEIF(ICASAN.EQ.'MINI')THEN 19805 CALL REVERS(Y,N,IWRITE,TEMP1,TEMP2,IBUGA3,IERROR) 19806 DO2117I=1,N 19807 Y(I)=TEMP1(I) 19808 2117 CONTINUE 19809 ENDIF 19810 NLAST=N-IR 19811 CALL MEAN(Y,NLAST,IWRITE,YMEANN,IBUGA3,IERROR) 19812C 19813 DSUMN=0.0D0 19814 DSUMD=0.0D0 19815 DO2120I=1,N 19816 DTERM1=DBLE(Y(I) - YMEAN) 19817 DSUMD=DSUMD + DTERM1**2 19818 2120 CONTINUE 19819C 19820 DO2125I=1,NLAST 19821 DTERM1=DBLE(Y(I) - YMEANN) 19822 DSUMN=DSUMN + DTERM1**2 19823 2125 CONTINUE 19824C 19825 DTERM1=DSUMN/DSUMD 19826 STATVA=REAL(DTERM1) 19827C 19828C ***************** 19829C ** STEP 90-- ** 19830C ** EXIT ** 19831C ***************** 19832C 19833 9000 CONTINUE 19834 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TIE3')THEN 19835 WRITE(ICOUT,999) 19836 CALL DPWRST('XXX','WRIT') 19837 WRITE(ICOUT,9011) 19838 9011 FORMAT('***** AT THE END OF DPTIE3--') 19839 CALL DPWRST('XXX','WRIT') 19840 WRITE(ICOUT,9013)YMEAN,YSD,YMIN,YMAX 19841 9013 FORMAT('YMEAN,YSD,YMIN,YMAX = ',4G15.7) 19842 CALL DPWRST('XXX','WRIT') 19843 WRITE(ICOUT,9015)YMEANN,YSDN,ITEMP2(1) 19844 9015 FORMAT('YMEANN,YSDN,YMIN,YMAX,ITEMP2(1) = ',4G15.7,I8) 19845 CALL DPWRST('XXX','WRIT') 19846 WRITE(ICOUT,9017)DSUM1,DSUM2,STATVA 19847 9017 FORMAT('DSUM1,DSUM2,STATVA = ',3G15.7) 19848 CALL DPWRST('XXX','WRIT') 19849 ENDIF 19850C 19851 RETURN 19852 END 19853 SUBROUTINE DPTIE4(STATVA,STATCD,PVAL, 19854 1 CUT0,CUT01,CUT025,CUT05,CUT10, 19855 1 CUT25,CUT50,CUT100, 19856 1 IFLAGU,IFRST,ILAST,ICASPL, 19857 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 19858C 19859C PURPOSE--UTILITY ROUTINE USED BY DPTIET. THIS ROUTINE 19860C UPDATES THE PARAMETERS "STATVAL", "STATCDF", AND 19861C "PVALUE" AFTER A TIETJEN-MOORE TEST. 19862C WRITTEN BY--JAMES J. FILLIBEN 19863C STATISTICAL ENGINEERING DIVISION 19864C INFORMATION TECHNOLOGY LABORAOTRY 19865C NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY 19866C GAITHERSBURG, MD 20899-8980 19867C PHONE--301-975-2855 19868C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 19869C OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY. 19870C LANGUAGE--ANSI FORTRAN (1977) 19871C VERSION NUMBER--2009/11 19872C ORIGINAL VERSION--NOVEMBER 2009. 19873C 19874C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19875C 19876 CHARACTER*4 IFLAGU 19877 CHARACTER*4 ICASPL 19878 CHARACTER*4 IBUGA2 19879 CHARACTER*4 IBUGA3 19880 CHARACTER*4 ISUBRO 19881 CHARACTER*4 IERROR 19882C 19883 LOGICAL IFRST 19884 LOGICAL ILAST 19885C 19886 CHARACTER*4 IH 19887 CHARACTER*4 IH2 19888 CHARACTER*4 ISUBN0 19889 CHARACTER*4 ISUBN1 19890 CHARACTER*4 ISUBN2 19891 CHARACTER*4 ISTEPN 19892 CHARACTER*4 IOP 19893C 19894 SAVE IOUNI1 19895C 19896C--------------------------------------------------------------------- 19897C 19898 INCLUDE 'DPCOPA.INC' 19899 INCLUDE 'DPCOHK.INC' 19900 INCLUDE 'DPCOHO.INC' 19901 INCLUDE 'DPCOF2.INC' 19902C 19903C-----COMMON---------------------------------------------------------- 19904C 19905 INCLUDE 'DPCOP2.INC' 19906C 19907C-----START POINT----------------------------------------------------- 19908C 19909 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TIE4')THEN 19910 ISTEPN='1' 19911 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19912 WRITE(ICOUT,999) 19913 999 FORMAT(1X) 19914 CALL DPWRST('XXX','BUG ') 19915 WRITE(ICOUT,51) 19916 51 FORMAT('***** AT THE BEGINNING OF DPTIE4--') 19917 CALL DPWRST('XXX','BUG ') 19918 WRITE(ICOUT,53)ICASPL,STATVA,STATCD,PVAL 19919 53 FORMAT('ICASPL,STATVA,STATCD,PVAL = ',A4,2X,3G15.7) 19920 CALL DPWRST('XXX','BUG ') 19921 WRITE(ICOUT,54)CUT0,CUT01,CUT025,CUT05 19922 54 FORMAT('CUT0,CUT01,CUT025,CUT05 = ',4G15.7) 19923 CALL DPWRST('XXX','BUG ') 19924 WRITE(ICOUT,55)CUT10,CUT25,CUT50,CUT100 19925 55 FORMAT('CUT10,CUT25,CUT50,CUT100 = ',4G15.7) 19926 CALL DPWRST('XXX','BUG ') 19927 ENDIF 19928C 19929 IF(IFLAGU.EQ.'FILE')THEN 19930 IF(IFRST)THEN 19931 IOP='OPEN' 19932 IFLAG1=1 19933 IFLAG2=0 19934 IFLAG3=0 19935 IFLAG4=0 19936 IFLAG5=0 19937 CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5, 19938 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 19939 1 IBUGA3,ISUBRO,IERROR) 19940C 19941 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TIE4')THEN 19942 ISTEPN='2A' 19943 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19944 WRITE(ICOUT,999) 19945 CALL DPWRST('XXX','BUG ') 19946 WRITE(ICOUT,201) 19947 201 FORMAT('AFTER CALL DPOPFI, IERRF1 = ',A4) 19948 CALL DPWRST('XXX','BUG ') 19949 WRITE(ICOUT,203)IOUNI1,IFILE1 19950 203 FORMAT('IOUNI1,IFILE1 = ',I5,A80) 19951 CALL DPWRST('XXX','BUG ') 19952 ENDIF 19953C 19954 IF(IERROR.EQ.'YES')GOTO9000 19955C 19956 WRITE(IOUNI1,295) 19957 295 FORMAT(11X,'STATVAL',8X,'STATCDF',8X,'PVALUE', 19958 1 7X,'CUTOFF0',7X,'CUTOFF01',6X,'CUTOFF025', 19959 1 7X,'CUTOFF05',7X,'CUTOFF10',7X,'CUTOF25', 19960 1 7X,'CUTOFF50',7X,'CUTOF100') 19961 WRITE(IOUNI1,299)STATVA,STATCD,PVAL,CUT0,CUT01,CUT025, 19962 1 CUT05,CUT10,CUT25,CUT50,CUT100 19963 299 FORMAT(11E15.7) 19964 ENDIF 19965 ELSEIF(IFLAGU.EQ.'ON')THEN 19966 IF(STATCD.NE.CPUMIN)THEN 19967 IH='STAT' 19968 IH2='VAL ' 19969 VALUE0=STATVA 19970 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19971 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19972 1 IANS,IWIDTH,IBUGA3,IERROR) 19973 ENDIF 19974C 19975 IF(STATCD.NE.CPUMIN)THEN 19976 IH='STAT' 19977 IH2='CDF ' 19978 VALUE0=STATCD 19979 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19980 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19981 1 IANS,IWIDTH,IBUGA3,IERROR) 19982 ENDIF 19983C 19984 IF(PVAL.NE.CPUMIN)THEN 19985 IH='PVAL' 19986 IH2='UE ' 19987 VALUE0=PVAL 19988 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19989 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19990 1 IANS,IWIDTH,IBUGA3,IERROR) 19991 ENDIF 19992C 19993 IF(CUT0.NE.CPUMIN)THEN 19994 IH='CUTO' 19995 IH2='FF0' 19996 VALUE0=CUT0 19997 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 19998 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 19999 1 IANS,IWIDTH,IBUGA3,IERROR) 20000 ENDIF 20001C 20002 IF(CUT01.NE.CPUMIN)THEN 20003 IH='CUTO' 20004 IH2='FF01' 20005 VALUE0=CUT01 20006 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 20007 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 20008 1 IANS,IWIDTH,IBUGA3,IERROR) 20009 ENDIF 20010C 20011 IF(CUT025.NE.CPUMIN)THEN 20012 IH='CUTO' 20013 IH2='F025' 20014 VALUE0=CUT025 20015 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 20016 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 20017 1 IANS,IWIDTH,IBUGA3,IERROR) 20018 ENDIF 20019C 20020 IF(CUT05.NE.CPUMIN)THEN 20021 IH='CUTO' 20022 IH2='FF05' 20023 VALUE0=CUT05 20024 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 20025 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 20026 1 IANS,IWIDTH,IBUGA3,IERROR) 20027 ENDIF 20028C 20029 IF(CUT10.NE.CPUMIN)THEN 20030 IH='CUTO' 20031 IH2='FF10' 20032 VALUE0=CUT10 20033 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 20034 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 20035 1 IANS,IWIDTH,IBUGA3,IERROR) 20036 ENDIF 20037C 20038 IF(CUT25.NE.CPUMIN)THEN 20039 IH='CUTO' 20040 IH2='FF25' 20041 VALUE0=CUT25 20042 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 20043 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 20044 1 IANS,IWIDTH,IBUGA3,IERROR) 20045 ENDIF 20046C 20047 IF(CUT50.NE.CPUMIN)THEN 20048 IH='CUTO' 20049 IH2='FF50' 20050 VALUE0=CUT50 20051 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 20052 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 20053 1 IANS,IWIDTH,IBUGA3,IERROR) 20054 ENDIF 20055C 20056 IF(CUT100.NE.CPUMIN)THEN 20057 IH='CUTO' 20058 IH2='F100' 20059 VALUE0=CUT100 20060 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 20061 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 20062 1 IANS,IWIDTH,IBUGA3,IERROR) 20063 ENDIF 20064C 20065 ENDIF 20066C 20067 IF(IFLAGU.EQ.'FILE')THEN 20068 IF(ILAST)THEN 20069 IOP='CLOS' 20070 IFLAG1=1 20071 IFLAG2=0 20072 IFLAG3=0 20073 IFLAG4=0 20074 IFLAG5=0 20075 CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5, 20076 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 20077 1 IBUGA3,ISUBRO,IERROR) 20078C 20079 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TIE4')THEN 20080 ISTEPN='3A' 20081 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 20082 WRITE(ICOUT,999) 20083 CALL DPWRST('XXX','BUG ') 20084 WRITE(ICOUT,301) 20085 301 FORMAT('AFTER CALL DPCLFI, IERRF1 = ',A4) 20086 CALL DPWRST('XXX','BUG ') 20087 WRITE(ICOUT,303)IOUNI1,IFILE1 20088 303 FORMAT('IOUNI1,IFILE1 = ',I5,A80) 20089 CALL DPWRST('XXX','BUG ') 20090 ENDIF 20091C 20092 IF(IERROR.EQ.'YES')GOTO9000 20093 ENDIF 20094 ENDIF 20095C 20096C ***************** 20097C ** STEP 90-- ** 20098C ** EXIT ** 20099C ***************** 20100C 20101 9000 CONTINUE 20102C 20103 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'TIE4')THEN 20104 WRITE(ICOUT,999) 20105 CALL DPWRST('XXX','BUG ') 20106 WRITE(ICOUT,9011) 20107 9011 FORMAT('***** AT THE END OF DPTIE4--') 20108 CALL DPWRST('XXX','BUG ') 20109 ENDIF 20110C 20111 RETURN 20112 END 20113 SUBROUTINE DPTIFO(IHARG,NUMARG,IDEFFO,ITITFO,IFOUND,IERROR) 20114C 20115C PURPOSE--DEFINE THE FONT FOR THE TITLE 20116C (THE HORIZONTAL STRING ABOVE THE UPPER HORIZONTAL FRAME). 20117C THE FONT FOR THE TITLE WILL BE PLACED 20118C IN THE HOLLERITH VARIABLE ITITFO. 20119C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 20120C --NUMARG 20121C --IDEFFO 20122C OUTPUT ARGUMENTS--ITITFO 20123C --IFOUND ('YES' OR 'NO' ) 20124C --IERROR ('YES' OR 'NO' ) 20125C WRITTEN BY--ALAN HECKERT 20126C COMPUTER SERVICES DIVISION 20127C INFORMATION TECHNOLOGY LABORATORY 20128C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 20129C GAITHERSBURG, MD 20899-8980 20130C PHONE--301-975-2899 20131C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 20132C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 20133C LANGUAGE--ANSI FORTRAN (1977) 20134C VERSION NUMBER--89/2 20135C ORIGINAL VERSION--JANUARY 1989. 20136C 20137C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 20138C 20139 CHARACTER*4 IHARG 20140 CHARACTER*4 IDEFFO 20141 CHARACTER*4 ITITFO 20142 CHARACTER*4 IFOUND 20143 CHARACTER*4 IERROR 20144C 20145C--------------------------------------------------------------------- 20146C 20147 DIMENSION IHARG(*) 20148C 20149C-----COMMON---------------------------------------------------------- 20150C 20151 INCLUDE 'DPCOP2.INC' 20152C 20153C-----START POINT----------------------------------------------------- 20154C 20155 IFOUND='NO' 20156 IERROR='NO' 20157C 20158 IF(NUMARG.LE.0)GOTO1199 20159 IF(IHARG(1).EQ.'FONT')GOTO1110 20160 GOTO1199 20161C 20162 1110 CONTINUE 20163 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 20164 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 20165 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 20166 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 20167 IF(NUMARG.EQ.1)GOTO1150 20168 GOTO1160 20169C 20170 1150 CONTINUE 20171 ITITFO=IDEFFO 20172 GOTO1180 20173C 20174 1160 CONTINUE 20175 ITITFO=IHARG(NUMARG) 20176 GOTO1180 20177C 20178 1180 CONTINUE 20179 IFOUND='YES' 20180C 20181 IF(IFEEDB.EQ.'OFF')GOTO1189 20182 WRITE(ICOUT,999) 20183 999 FORMAT(1X) 20184 CALL DPWRST('XXX','BUG ') 20185 WRITE(ICOUT,1181)ITITFO 20186 1181 FORMAT('THE TITLE FONT HAS JUST BEEN SET TO ', 20187 1A4) 20188 CALL DPWRST('XXX','BUG ') 20189 1189 CONTINUE 20190 GOTO1199 20191C 20192 1199 CONTINUE 20193 RETURN 20194 END 20195