1 SUBROUTINE DPRLPP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 3C 4C PURPOSE--GIVEN Z-SCORES WITH THEIR ASSOCIATED LAB-ID's, GENERATE 5C A PLOT OF RELATIVE LAB PERFORMANCE (RLP) VERSUS 6C THE RESCALED SUM (RSZ). 7C 8C THE RLP IS DEFINED AS: 9C 10C RLP = SQRT(SSQ/NMAT) 11C 12C WHERE NMAT IS THE NUMBER OF MATERIALS AND 13C 14C SSQ = SUM[i=1 to n][Z(i)**2] 15C 16C WHERE n IS THE NUMBER OF Z-SCORES FOR A GIVEN LAB. 17C 18C THE RSZ IS DEFINED AS: 19C 20C RSCSUM = SUM[i=1 to n][X(i)]/SQRT(N) 21C 22C 23C THIS COMMAND IS USED IN ISO 13528 TYPE PROFICIENCY 24C ANALYSES. IT COMBINES Z-SCORES FROM MULTIPLE 25C MATERIALS AND MULTIPLE ROUNDS AND IS ONE TOOL USED TO 26C IDENTIFY PROBLEMATIC LABORATORIES. 27C 28C NOTE THAT THE ISO 13528 STANDARD SPECIFIES A NUMBER 29C OF DIFFERENT METHODS FOR COMPUTING Z-SCORES, SO THIS 30C COMMAND ASSUMES THAT THE Z-SCORE HAS ALREADY BEEN 31C COMPUTED. 32C 33C THE COMMAND HAS THE FOLLOWING FORMAT: 34C 35C RPL PLOT Z LABID MATID 36C 37C WHERE Z IS THE Z-SCORE OF THE RESPONSE, LABID IS THE 38C LAB-ID, AND MATID IS THE MATERIAL-ID (MATERIAL-ID ENTERS 39C IN ONLY TO COMPUTE THE NUMBER OF DISTINCT MATERIALS). 40C 41C EXAMPLE--RPL PLOT Z LABID MATID 42C WRITTEN BY--ALAN HECKERT 43C STATISTICAL ENGINEERING DIVISION 44C INFORMATION TECHNOLOGY LABORATORY 45C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 46C GAITHERSBURG, MD 20899-8980 47C PHONE--301-975-2899 48C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 49C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 50C LANGUAGE--ANSI FORTRAN (1977) 51C VERSION NUMBER--2012/2 52C ORIGINAL VERSION--FEBRUARY 2012. 53C 54C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 55C 56 CHARACTER*4 ICASPL 57 CHARACTER*4 IAND1 58 CHARACTER*4 IAND2 59 CHARACTER*4 IBUGG2 60 CHARACTER*4 IBUGG3 61 CHARACTER*4 IBUGQ 62 CHARACTER*4 ISUBRO 63 CHARACTER*4 IFOUND 64 CHARACTER*4 IERROR 65C 66 CHARACTER*4 ISUBN1 67 CHARACTER*4 ISUBN2 68 CHARACTER*4 ISTEPN 69 CHARACTER*4 IHP 70 CHARACTER*4 IHP2 71 CHARACTER*4 IHWUSE 72 CHARACTER*4 MESSAG 73C 74 CHARACTER*40 INAME 75 PARAMETER (MAXSPN=10) 76 CHARACTER*4 IVARN1(MAXSPN) 77 CHARACTER*4 IVARN2(MAXSPN) 78 CHARACTER*4 IVARTY(MAXSPN) 79 REAL PVAR(MAXSPN) 80 INTEGER ILIS(MAXSPN) 81 INTEGER NRIGHT(MAXSPN) 82 INTEGER ICOLR(MAXSPN) 83C 84C--------------------------------------------------------------------- 85C 86 INCLUDE 'DPCOPA.INC' 87 INCLUDE 'DPCOZZ.INC' 88C 89 DIMENSION Z(MAXOBV) 90 DIMENSION ALAB(MAXOBV) 91 DIMENSION AMATID(MAXOBV) 92 DIMENSION TEMP1(MAXOBV) 93 DIMENSION TEMP2(MAXOBV) 94 DIMENSION TEMP3(MAXOBV) 95C 96 EQUIVALENCE (GARBAG(IGARB1),Z(1)) 97 EQUIVALENCE (GARBAG(IGARB2),ALAB(1)) 98 EQUIVALENCE (GARBAG(IGARB3),AMATID(1)) 99 EQUIVALENCE (GARBAG(IGARB4),TEMP1(1)) 100 EQUIVALENCE (GARBAG(IGARB5),TEMP2(1)) 101 EQUIVALENCE (GARBAG(IGARB6),TEMP3(1)) 102C 103C-----COMMON---------------------------------------------------------- 104C 105 INCLUDE 'DPCOST.INC' 106 INCLUDE 'DPCOHO.INC' 107 INCLUDE 'DPCOHK.INC' 108 INCLUDE 'DPCODA.INC' 109C 110 CHARACTER*4 ISUBSW 111 CHARACTER*4 ISUBTY 112 CHARACTER*4 IDEFSB 113C 114 COMMON /RSUBR/ 115 1ASUBXL(MAXSUB), 116 1ASUBXU(MAXSUB), 117 1ASUBYL(MAXSUB), 118 1ASUBYU(MAXSUB) 119C 120 COMMON /ISUBR/ 121 1ISUBNU 122C 123 COMMON /CSUBR/ 124 1ISUBTY(MAXSUB), 125 1ISUBSW(MAXSUB), 126 1IDEFSB 127C 128C 129C-----COMMON VARIABLES (GENERAL)-------------------------------------- 130C 131 INCLUDE 'DPCOP2.INC' 132C 133C-----START POINT----------------------------------------------------- 134C 135 IERROR='NO' 136 IFOUND='NO' 137 ISUBN1='DPRL' 138 ISUBN2='PP ' 139C 140 MAXCP1=MAXCOL+1 141 MAXCP2=MAXCOL+2 142 MAXCP3=MAXCOL+3 143 MAXCP4=MAXCOL+4 144 MAXCP5=MAXCOL+5 145 MAXCP6=MAXCOL+6 146C 147C **************************************** 148C ** TREAT THE RLP PLOT CASE ** 149C **************************************** 150C 151 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'RLPP')THEN 152 WRITE(ICOUT,999) 153 999 FORMAT(1X) 154 CALL DPWRST('XXX','BUG ') 155 WRITE(ICOUT,51) 156 51 FORMAT('***** AT THE BEGINNING OF DPRLPP--') 157 CALL DPWRST('XXX','BUG ') 158 WRITE(ICOUT,52)IBUGG2,IBUGG3,IBUGQ,ISUBRO 159 52 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4) 160 CALL DPWRST('XXX','BUG ') 161 WRITE(ICOUT,53)ICASPL,IAND1,IAND2,MAXN 162 53 FORMAT('ICASPL,IAND1,IAND2,MAXN = ',3(A4,2X),I8) 163 CALL DPWRST('XXX','BUG ') 164 ENDIF 165C 166C *************************** 167C ** STEP 1-- ** 168C ** EXTRACT THE COMMAND ** 169C *************************** 170C 171 ISTEPN='11' 172 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'RLPP') 173 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 174C 175 IF(NUMARG.GE.1 .AND. ICOM.EQ.'ISO ' .AND. 176 1 IHARG(1).EQ.'1352' .AND. IHARG(2).EQ.'RLP ' .AND. 177 1 IHARG(3).EQ.'PLOT')THEN 178 ILASTC=3 179 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 180 IFOUND='YES' 181 ICASPL='RLP' 182 ELSE 183 GOTO9000 184 ENDIF 185C 186C **************************************** 187C ** STEP 2-- ** 188C ** EXTRACT THE VARIABLE LIST ** 189C **************************************** 190C 191 ISTEPN='2' 192 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'RLPP') 193 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 194C 195 INAME='RLP PLOT' 196 MINNA=1 197 MAXNA=100 198 MINN2=2 199 IFLAGE=1 200 IFLAGM=0 201 IFLAGP=0 202 JMIN=1 203 JMAX=NUMARG 204 MINNVA=2 205 MAXNVA=3 206C 207 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 208 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 209 1 JMIN,JMAX, 210 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 211 1 IVARN1,IVARN2,IVARTY,PVAR, 212 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 213 1 MINNVA,MAXNVA, 214 1 IFLAGM,IFLAGP, 215 1 IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 216 IF(IERROR.EQ.'YES')GOTO9000 217C 218 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'RLPP')THEN 219 WRITE(ICOUT,999) 220 CALL DPWRST('XXX','BUG ') 221 WRITE(ICOUT,281) 222 281 FORMAT('***** AFTER CALL DPPARS--') 223 CALL DPWRST('XXX','BUG ') 224 WRITE(ICOUT,282)NQ,NUMVAR 225 282 FORMAT('NQ,NUMVAR = ',2I8) 226 CALL DPWRST('XXX','BUG ') 227 IF(NUMVAR.GT.0)THEN 228 DO285I=1,NUMVAR 229 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 230 1 ICOLR(I),IVARTY(I) 231 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 232 1 'ICOLR(I),IVARTY(I) = ',I8,2X,A4,A4,2X,3I8,2X,A4) 233 CALL DPWRST('XXX','BUG ') 234 285 CONTINUE 235 ENDIF 236 ENDIF 237C 238C ********************************************** 239C ** STEP 33-- ** 240C ** FORM THE SUBSETTED VARIABLES ** 241C ** Z(.) ** 242C ** ALABID(.) ** 243C ** AMATID(.) ** 244C ********************************************** 245C 246 ISTEPN='33' 247 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'RLPP') 248 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 249C 250 ICOL=1 251 CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 252 1 INAME,IVARN1,IVARN2,IVARTY, 253 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 254 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 255 1 MAXCP4,MAXCP5,MAXCP6, 256 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 257 1 Z,ALAB,AMATID,TEMP1,TEMP1,TEMP1,TEMP1,NS, 258 1 IBUGG3,ISUBRO,IFOUND,IERROR) 259 IF(IERROR.EQ.'YES')GOTO9000 260C 261 IF(NUMVAR.EQ.2)THEN 262 DO3310I=1,NS 263 AMATID(I)=1.0 264 3310 CONTINUE 265 ENDIF 266C 267 IHP='CAPV' 268 IHP2='ALUE' 269 IHWUSE='P' 270 MESSAG='NO' 271 CALL CHECKN(IHP,IHP2,IHWUSE, 272 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 273 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 274 IF(IERROR.EQ.'YES')THEN 275 XCAP=CPUMIN 276 ELSE 277 XCAP=VALUE(ILOCP) 278 ENDIF 279C 280C ******************************************************* 281C ** STEP 8-- ** 282C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** 283C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** 284C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** 285C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** 286C ******************************************************* 287C 288 ISTEPN='5' 289 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'RLPP')THEN 290 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 291 WRITE(ICOUT,5001)NS,ICASPL 292 5001 FORMAT('NS,ICASPL=',I8,1X,A4) 293 CALL DPWRST('XXX','BUG ') 294 ENDIF 295C 296 CALL DPRLP2(Z,ALAB,AMATID,NS, 297 1 ICASPL,MAXOBV,IRLPLA,XCAP, 298 1 TEMP1,TEMP2,TEMP3, 299 1 Y,X,D,X3D, 300 1 NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 301C 302 IF(IERROR.EQ.'NO')THEN 303 ISUBNU=ISUBNU+1 304 ISUBSW(ISUBNU)='ON' 305 ASUBXL(ISUBNU)=-2.0 306 ASUBXU(ISUBNU)=2.0 307 ASUBYL(ISUBNU)=0.0 308 ASUBYU(ISUBNU)=1.5 309 ENDIF 310C 311C ***************** 312C ** STEP 9-- ** 313C ** EXIT ** 314C ***************** 315C 316 9000 CONTINUE 317 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'RLPP')THEN 318 WRITE(ICOUT,999) 319 CALL DPWRST('XXX','BUG ') 320 WRITE(ICOUT,9011) 321 9011 FORMAT('***** AT THE END OF DPRLPP--') 322 CALL DPWRST('XXX','BUG ') 323 WRITE(ICOUT,9013)IFOUND,IERROR 324 9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 325 CALL DPWRST('XXX','BUG ') 326 WRITE(ICOUT,9014)NPLOTV,NPLOTP,ICASPL,IAND1,IAND2 327 9014 FORMAT('NPLOTV,NPLOTP,ICASPL,IAND1,IAND2 = ', 328 1 2I8,2X,2(A4,2X),A4) 329 CALL DPWRST('XXX','BUG ') 330 ENDIF 331C 332 RETURN 333 END 334 SUBROUTINE DPRLP2(Z,ALAB,AMATID,N, 335 1 ICASPL,MAXOBV,IRLPLA,XCAP, 336 1 XIDTEM,XIDTE2,TEMP1, 337 1 Y,X,D,X3D, 338 1 NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 339C 340C PURPOSE--GIVEN Z-SCORES WITH THEIR ASSOCIATED LAB-ID's, GENERATE 341C A PLOT OF RELATIVE LAB PERFORMANCE (RLP) VERSUS 342C THE RESCALED SUM (RSZ). 343C 344C THE RLP IS DEFINED AS: 345C 346C RLP = SQRT(SSQ/NMAT) 347C 348C WHERE NMAT IS THE NUMBER OF MATERIALS AND 349C 350C SSQ = SUM[i=1 to n][Z(i)**2] 351C 352C WHERE n IS THE NUMBER OF Z-SCORES FOR A GIVEN LAB. 353C 354C THE RSZ IS DEFINED AS: 355C 356C RSCSUM = SUM[i=1 to n][X(i)]/SQRT(N) 357C 358C 359C THIS COMMAND IS USED IN ISO 13528 TYPE PROFICIENCY 360C ANALYSES. IT COMBINES Z-SCORES FROM MULTIPLE 361C MATERIALS AND MULTIPLE ROUNDS AND IS ONE TOOL USED TO 362C IDENTIFY PROBLEMATIC LABORATORIES. 363C 364C NOTE THAT THE ISO 13528 STANDARD SPECIFIES A NUMBER 365C OF DIFFERENT METHODS FOR COMPUTING Z-SCORES, SO THIS 366C COMMAND ASSUMES THAT THE Z-SCORE HAS ALREADY BEEN 367C COMPUTED. 368C 369C THE COMMAND HAS THE FOLLOWING FORMAT: 370C 371C RLP PLOT Z LABID MATID 372C 373C WHERE Z IS THE Z-SCORE OF THE RESPONSE, LABID IS THE 374C LAB-ID, AND MATID IS THE MATERIAL-ID (MATERIAL-ID ENTERS 375C IN ONLY TO COMPUTE THE NUMBER OF DISTINCT MATERIALS). 376C 377C REFERENCE--XXXXX 378C --ISO 13528 (2005), "Statistical Methods for use in 379C proficiency testing by interlaboratory comparisons," 380C First Edition, 2005-09-01, pp. 56-57. 381C WRITTEN BY--ALAN HECKERT 382C STATISTICAL ENGINEERING DIVISION 383C INFORMATION TECHNOLOGY LABORATORY 384C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 385C GAITHERSBURG, MD 20899-8980 386C PHONE--301-975-2899 387C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 388C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 389C LANGUAGE--ANSI FORTRAN (1977) 390C VERSION NUMBER--2012/2 391C ORIGINAL VERSION--FEBRUARY 2012. 392C UPDATED --AUGUST 2019. COMPUTE NUMBER OF MATERIALS 393C SEPARATELY FOR EACH LAB INSTEAD 394C OF ASSUMING THE NUMBER OF 395C MATERIALS IS EQUAL ACROSS LABS 396C 397C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 398C 399 CHARACTER*4 ICASPL 400 CHARACTER*4 IRLPLA 401 CHARACTER*4 IBUGG3 402 CHARACTER*4 ISUBRO 403 CHARACTER*4 IERROR 404C 405 CHARACTER*4 IWRITE 406 CHARACTER*4 ISUBN1 407 CHARACTER*4 ISUBN2 408C 409C--------------------------------------------------------------------- 410C 411 DIMENSION Z(*) 412 DIMENSION ALAB(*) 413 DIMENSION AMATID(*) 414C 415 DIMENSION XIDTEM(*) 416 DIMENSION XIDTE2(*) 417 DIMENSION TEMP1(*) 418C 419 DIMENSION Y(*) 420 DIMENSION X(*) 421 DIMENSION D(*) 422 DIMENSION X3D(*) 423C 424C--------------------------------------------------------------------- 425C 426 INCLUDE 'DPCOP2.INC' 427C 428C-----START POINT----------------------------------------------------- 429C 430 ISUBN1='DPRL' 431 ISUBN2='P2 ' 432 IWRITE='OFF' 433 IERROR='NO' 434C 435 NPLOTP=0 436 NPLOTV=3 437C 438 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'RLP2')THEN 439 WRITE(ICOUT,999) 440 CALL DPWRST('XXX','BUG ') 441 WRITE(ICOUT,71) 442 71 FORMAT('***** AT THE BEGINNING OF DPRLP2--') 443 CALL DPWRST('XXX','BUG ') 444 WRITE(ICOUT,72)IBUGG3,ISUBRO,ICASPL,IRLPLA,N,MAXOBV 445 72 FORMAT('IBUGG3,ISUBRO,ICASPL,IRLPLA,N,MAXOBV = ',4(A4,2X),2I8) 446 CALL DPWRST('XXX','BUG ') 447 IF(N.GT.0)THEN 448 DO81I=1,N 449 WRITE(ICOUT,82)I,Z(I),ALAB(I),AMATID(I) 450 82 FORMAT('I,Z(I),ALAB(I),AMATID(I) = ',I8,3G15.7) 451 CALL DPWRST('XXX','BUG ') 452 81 CONTINUE 453 ENDIF 454 ENDIF 455C 456C ******************************************** 457C ** STEP 1-- ** 458C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 459C ******************************************** 460C 461 IF(N.LT.2)THEN 462 WRITE(ICOUT,999) 463 999 FORMAT(1X) 464 CALL DPWRST('XXX','BUG ') 465 WRITE(ICOUT,31) 466 31 FORMAT('***** ERROR IN RPL PLOT--') 467 CALL DPWRST('XXX','BUG ') 468 WRITE(ICOUT,32) 469 32 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.') 470 CALL DPWRST('XXX','BUG ') 471 WRITE(ICOUT,34)N 472 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) 473 CALL DPWRST('XXX','BUG ') 474 WRITE(ICOUT,999) 475 CALL DPWRST('XXX','BUG ') 476 IERROR='YES' 477 GOTO9000 478 ENDIF 479C 480C ******************************************** 481C ** STEP 2-- ** 482C ** COMPUTE UNIQUE VALUES OF LAB AND ** 483C ** MATERIAL. ** 484C ******************************************** 485C 486 IWRITE='OFF' 487 NPLOTP=0 488 CALL DISTIN(ALAB,N,IWRITE,XIDTEM,NLAB,IBUGG3,IERROR) 489 CALL SORT(XIDTEM,NLAB,XIDTEM) 490C 491C ******************************************** 492C ** STEP 3-- ** 493C ** GENERATE THE PLOT COORDINATES. ** 494C ******************************************** 495C 496 DO2010J=1,NLAB 497 HOLD=XIDTEM(J) 498 K=0 499 DO2020I=1,N 500 IF(ALAB(I).EQ.HOLD)THEN 501 K=K+1 502 TEMP1(K)=Z(I) 503 ENDIF 504 2020 CONTINUE 505 IF(K.GE.1)THEN 506 CALL DISTIN(TEMP1,K,IWRITE,XIDTE2,NMAT,IBUGG3,IERROR) 507 CALL SORT(XIDTE2,NMAT,XIDTE2) 508 ANMAT=REAL(NMAT) 509 CALL RSCSUM(TEMP1,K,XCAP,IWRITE,RSZ,IBUGG3,ISUBRO,IERROR) 510 CALL SSQ(TEMP1,K,XCAP,IWRITE,ATEMP,IBUGG3,ISUBRO,IERROR) 511 RLP=SQRT(ATEMP/ANMAT) 512C 513 NPLOTP=NPLOTP+1 514 Y(NPLOTP)=RLP 515 X(NPLOTP)=RSZ 516 D(NPLOTP)=1.0 517 X3D(NPLOTP)=0.0 518C 519 IF(IRLPLA.EQ.'ALL')THEN 520 NPLOTP=NPLOTP+1 521 Y(NPLOTP)=RLP 522 X(NPLOTP)=RSZ 523 D(NPLOTP)=2.0 524 X3D(NPLOTP)=HOLD 525 ELSEIF(IRLPLA.EQ.'ACTI')THEN 526 IF(RLP.GT.1.5 .OR. ABS(RSZ).GT.3.0)THEN 527 NPLOTP=NPLOTP+1 528 Y(NPLOTP)=RLP 529 X(NPLOTP)=RSZ 530 D(NPLOTP)=2.0 531 X3D(NPLOTP)=HOLD 532 ENDIF 533 ELSEIF(IRLPLA.EQ.'WARN')THEN 534 IF(RLP.GT.1.5 .OR. ABS(RSZ).GT.2.0)THEN 535 NPLOTP=NPLOTP+1 536 Y(NPLOTP)=RLP 537 X(NPLOTP)=RSZ 538 D(NPLOTP)=2.0 539 X3D(NPLOTP)=HOLD 540 ENDIF 541 ENDIF 542 ENDIF 543C 544 2010 CONTINUE 545C 546C ***************** 547C ** STEP 90-- ** 548C ** EXIT ** 549C ***************** 550C 551 9000 CONTINUE 552 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'RLP2')THEN 553 WRITE(ICOUT,999) 554 CALL DPWRST('XXX','BUG ') 555 WRITE(ICOUT,9011) 556 9011 FORMAT('***** AT THE END OF DPRLP2--') 557 CALL DPWRST('XXX','BUG ') 558 WRITE(ICOUT,9013)IERROR,NPLOTP,NPLOTV 559 9013 FORMAT('IERROR,NPLOTP,NPLOTV = ',A4,2X,2I8) 560 CALL DPWRST('XXX','BUG ') 561 IF(NPLOTP.GT.0)THEN 562 DO9035I=1,NPLOTP 563 WRITE(ICOUT,9036)I,Y(I),X(I),D(I) 564 9036 FORMAT('I,Y(I),X(I),D(I) = ',I8,3G15.7) 565 CALL DPWRST('XXX','BUG ') 566 9035 CONTINUE 567 ENDIF 568 ENDIF 569C 570 RETURN 571 END 572 SUBROUTINE DPROAC(IHARG,IARGT,ARG,NUMARG,DEFRAC, 573 1ROOTAC,IFOUND,IERROR) 574C 575C PURPOSE--DEFINE THE ROOT ACCURACY. 576C THE DIFFERENCE IN FUNCTION VALUES AFTER EACH 577C ITERATION OF A ROOT EXTRACTION WILL BE COMPARED 578C TO THE SPECIFIED ROOT ACCURACY. 579C THE SPECIFIED ROOT ACCURACY VALUE WILL BE PLACED 580C IN THE FLOATING POINT VARIABLE ROOTAC. 581C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 582C --IARGT (A HOLLERITH VECTOR) 583C --ARG (A FLOATING POINT VECTOR) 584C --NUMARG (AN INTEGER VARIABLE) 585C --DEFRAC (A FLOATING POINT VARIABLE) 586C OUTPUT ARGUMENTS--ROOTAC (A FLOATING POINT VARIABLE) 587C --IFOUND ('YES' OR 'NO' ) 588C --IERROR ('YES' OR 'NO' ) 589C WRITTEN BY--JAMES J. FILLIBEN 590C STATISTICAL ENGINEERING DIVISION 591C INFORMATION TECHNOLOGY LABORATORY 592C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 593C GAITHERSBURG, MD 20899 594C PHONE--301-975-2855 595C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 596C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 597C LANGUAGE--ANSI FORTRAN (1977) 598C VERSION NUMBER--82/7 599C ORIGINAL VERSION--NOVEMBER 1980. 600C UPDATED --MAY 1982. 601C 602C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 603C 604 CHARACTER*4 IHARG 605 CHARACTER*4 IARGT 606 CHARACTER*4 IFOUND 607 CHARACTER*4 IERROR 608C 609C--------------------------------------------------------------------- 610C 611 DIMENSION IHARG(*) 612 DIMENSION IARGT(*) 613 DIMENSION ARG(*) 614C 615C--------------------------------------------------------------------- 616C 617 INCLUDE 'DPCOP2.INC' 618C 619C-----START POINT----------------------------------------------------- 620C 621 IFOUND='NO' 622 IERROR='NO' 623C 624 IF(NUMARG.EQ.0)GOTO1199 625 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'=')GOTO1199 626 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ACCU')GOTO1110 627 GOTO1199 628C 629 1110 CONTINUE 630 IF(IHARG(NUMARG).EQ.'ACCU')GOTO1150 631 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 632 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 633 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 634 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 635 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 636 GOTO1120 637C 638 1120 CONTINUE 639 IERROR='YES' 640 WRITE(ICOUT,1121) 641 1121 FORMAT('***** ERROR IN DPROAC--') 642 CALL DPWRST('XXX','BUG ') 643 WRITE(ICOUT,1122) 644 1122 FORMAT(' ILLEGAL FORM FOR ROOT ACCURACY ', 645 1'COMMAND.') 646 CALL DPWRST('XXX','BUG ') 647 WRITE(ICOUT,1124) 648 1124 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 649 1'PROPER FORM--') 650 CALL DPWRST('XXX','BUG ') 651 WRITE(ICOUT,1125) 652 1125 FORMAT(' SUPPOSE THE THE ANALYST WILL BE CARRYING OUT ') 653 CALL DPWRST('XXX','BUG ') 654 WRITE(ICOUT,1126) 655 1126 FORMAT(' A ROOT-EXTRACTION, ') 656 CALL DPWRST('XXX','BUG ') 657 WRITE(ICOUT,1127) 658 1127 FORMAT(' AND SUPPOSE THE ANALYST WISHES TO TERMINATE ') 659 CALL DPWRST('XXX','BUG ') 660 WRITE(ICOUT,1128) 661 1128 FORMAT(' THE ROOT-FINDING PROCESS WHENEVER SUCCESSIVE') 662 CALL DPWRST('XXX','BUG ') 663 WRITE(ICOUT,1129) 664 1129 FORMAT(' X DIFFERENCES ARE .00001 OR SMALLER; ') 665 CALL DPWRST('XXX','BUG ') 666 WRITE(ICOUT,1130) 667 1130 FORMAT(' THEN THE ALLOWABLE FORM IS--') 668 CALL DPWRST('XXX','BUG ') 669 WRITE(ICOUT,1131) 670 1131 FORMAT(' ROOT ACCURACY .00001 ') 671 CALL DPWRST('XXX','BUG ') 672 GOTO1199 673C 674 1150 CONTINUE 675 HOLD=DEFRAC 676 GOTO1180 677C 678 1160 CONTINUE 679 HOLD=ARG(NUMARG) 680 GOTO1180 681C 682 1180 CONTINUE 683 IFOUND='YES' 684 ROOTAC=HOLD 685C 686 IF(IFEEDB.EQ.'OFF')GOTO1189 687 WRITE(ICOUT,999) 688 999 FORMAT(1X) 689 CALL DPWRST('XXX','BUG ') 690 WRITE(ICOUT,1181)ROOTAC 691 1181 FORMAT('THE ROOT ACCURACY HAS JUST BEEN SET TO ', 692 1E15.7) 693 CALL DPWRST('XXX','BUG ') 694 1189 CONTINUE 695 GOTO1199 696C 697 1199 CONTINUE 698 RETURN 699 END 700 SUBROUTINE DPROC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 701 1 IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR) 702C 703C PURPOSE--GENERATE A ROC CURVE. 704C WRITTEN BY--ALAN HECKERT 705C STATISTICAL ENGINEERING DIVISION 706C INFORMATION TECHNOLOGY LABORATORY 707C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 708C GAITHERSBURG, MD 20899-8980 709C PHONE--301-975-2899 710C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 711C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 712C LANGUAGE--ANSI FORTRAN (1977) 713C VERSION NUMBER--2007/7 714C ORIGINAL VERSION--JULY 2007. 715C UPDATED --APRIL 2011. USE DPPARS AND DPPAR5 716C 717C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 718C 719 CHARACTER*4 ICASPL 720 CHARACTER*4 IAND1 721 CHARACTER*4 IAND2 722 CHARACTER*4 IBUGG2 723 CHARACTER*4 IBUGG3 724 CHARACTER*4 ISUBRO 725 CHARACTER*4 IBUGQ 726 CHARACTER*4 IFOUND 727 CHARACTER*4 IERROR 728C 729 CHARACTER*4 IH 730 CHARACTER*4 IH2 731 CHARACTER*4 ISUBN0 732 CHARACTER*4 ISUBN1 733 CHARACTER*4 ISUBN2 734 CHARACTER*4 ISTEPN 735C 736 CHARACTER*40 INAME 737 PARAMETER (MAXSPN=10) 738 CHARACTER*4 IVARN1(MAXSPN) 739 CHARACTER*4 IVARN2(MAXSPN) 740 CHARACTER*4 IVARTY(MAXSPN) 741 REAL PVAR(MAXSPN) 742 INTEGER ILIS(MAXSPN) 743 INTEGER NRIGHT(MAXSPN) 744 INTEGER ICOLR(MAXSPN) 745C 746C--------------------------------------------------------------------- 747C 748C-----COMMON---------------------------------------------------------- 749C 750 INCLUDE 'DPCOPA.INC' 751C 752 DIMENSION Y1(MAXOBV) 753 DIMENSION Y2(MAXOBV) 754 DIMENSION Y3(MAXOBV) 755 DIMENSION XGROUP(MAXOBV) 756 DIMENSION XGROU2(MAXOBV) 757 DIMENSION XIDTEM(MAXOBV) 758 DIMENSION XIDTE2(MAXOBV) 759 DIMENSION TEMP1(MAXOBV) 760 DIMENSION TEMP2(MAXOBV) 761 DIMENSION TEMP3(MAXOBV) 762 DIMENSION TEMP4(MAXOBV) 763 DIMENSION TEMP5(MAXOBV) 764C 765 INCLUDE 'DPCOZZ.INC' 766 EQUIVALENCE (GARBAG(IGARB1),Y1(1)) 767 EQUIVALENCE (GARBAG(IGARB2),Y2(1)) 768 EQUIVALENCE (GARBAG(IGARB3),XGROUP(1)) 769 EQUIVALENCE (GARBAG(IGARB4),XGROU2(1)) 770 EQUIVALENCE (GARBAG(IGARB5),XIDTEM(1)) 771 EQUIVALENCE (GARBAG(IGARB6),XIDTE2(1)) 772 EQUIVALENCE (GARBAG(IGARB7),TEMP1(1)) 773 EQUIVALENCE (GARBAG(IGARB8),TEMP2(1)) 774 EQUIVALENCE (GARBAG(IGARB9),TEMP3(1)) 775 EQUIVALENCE (GARBAG(IGAR10),TEMP4(1)) 776 EQUIVALENCE (GARBAG(JGAR11),TEMP5(1)) 777 EQUIVALENCE (GARBAG(JGAR12),Y3(1)) 778C 779C-----COMMON VARIABLES (GENERAL)-------------------------------------- 780C 781 INCLUDE 'DPCOHK.INC' 782 INCLUDE 'DPCOHO.INC' 783 INCLUDE 'DPCODA.INC' 784 INCLUDE 'DPCOP2.INC' 785C 786C-----START POINT----------------------------------------------------- 787C 788 IFOUND='NO' 789 IERROR='NO' 790 ISUBN1='DPRO' 791 ISUBN2='C ' 792C 793 MAXCP1=MAXCOL+1 794 MAXCP2=MAXCOL+2 795 MAXCP3=MAXCOL+3 796 MAXCP4=MAXCOL+4 797 MAXCP5=MAXCOL+5 798 MAXCP6=MAXCOL+6 799C 800C ******************************** 801C ** TREAT THE ROC CURVE CASE ** 802C ******************************** 803C 804 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'ROC ')THEN 805 WRITE(ICOUT,999) 806 999 FORMAT(1X) 807 CALL DPWRST('XXX','BUG ') 808 WRITE(ICOUT,51) 809 51 FORMAT('***** AT THE BEGINNING OF DPROC--') 810 CALL DPWRST('XXX','BUG ') 811 WRITE(ICOUT,53)ICASPL,IAND1,IAND2,MAXNPP 812 53 FORMAT('ICASPL,IAND1,IAND2,MAXNPP = ',3(A4,2X),I8) 813 CALL DPWRST('XXX','BUG ') 814 WRITE(ICOUT,54)IBUGG2,IBUGG3,ISUBRO,IBUGQ 815 54 FORMAT('IBUGG2,IBUGG3,ISUBRO,IBUGQ = ',3(A4,2X),A4) 816 CALL DPWRST('XXX','BUG ') 817 ENDIF 818C 819C ******************************************* 820C ** STEP 1-- ** 821C ** SEARCH FOR ROC CURVE ** 822C ******************************************* 823C 824 ISTEPN='1' 825 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'RPLO') 826 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 827C 828 IF(NUMARG.GE.1.AND. 829 1 (IHARG(1).EQ.'PLOT' .OR. IHARG(1).EQ.'CURV'))THEN 830 ICASPL='ROC ' 831 ILASTC=1 832 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 833 IFOUND='YES' 834 INAME='ROC CURVE' 835 IHARG(NUMARG+1)=' ' 836 IHARG2(NUMARG+1)=' ' 837 ELSEIF(NUMARG.GE.2.AND. 838 1 IHARG(1).EQ.'ROC '.AND. 839 1 (IHARG(2).EQ.'PLOT' .OR. IHARG(2).EQ.'CURV'))THEN 840 ICASPL='PROC' 841 INAME='PSUEDO ROC CURVE' 842 ILASTC=2 843 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 844 IFOUND='YES' 845 IHARG(NUMARG+1)=' ' 846 IHARG2(NUMARG+1)=' ' 847 ELSE 848 ICASPL=' ' 849 GOTO9000 850 ENDIF 851C 852C **************************************** 853C ** STEP 2-- ** 854C ** EXTRACT THE VARIABLE LIST ** 855C **************************************** 856C 857 ISTEPN='2' 858 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PROC') 859 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 860C 861 MINNA=3 862 MAXNA=100 863 MINN2=2 864 IFLAGE=1 865 IFLAGM=0 866 IFLAGP=0 867 JMIN=1 868 JMAX=NUMARG 869 IF(ICASPL.EQ.'ROC')THEN 870 MINNVA=3 871 MAXNVA=4 872 ELSE 873 MINNVA=4 874 MAXNVA=5 875 ENDIF 876C 877 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 878 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 879 1 JMIN,JMAX, 880 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 881 1 IVARN1,IVARN2,IVARTY,PVAR, 882 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 883 1 MINNVA,MAXNVA, 884 1 IFLAGM,IFLAGP, 885 1 IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 886 IF(IERROR.EQ.'YES')GOTO9000 887C 888 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PROC')THEN 889 WRITE(ICOUT,999) 890 CALL DPWRST('XXX','BUG ') 891 WRITE(ICOUT,281) 892 281 FORMAT('***** AFTER CALL DPPARS--') 893 CALL DPWRST('XXX','BUG ') 894 WRITE(ICOUT,282)NQ,NUMVAR 895 282 FORMAT('NQ,NUMVAR = ',2I8) 896 CALL DPWRST('XXX','BUG ') 897 IF(NUMVAR.GT.0)THEN 898 DO285I=1,NUMVAR 899 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 900 1 ICOLR(I),IVARTY(I) 901 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 902 1 'ICOLR(I),IVARTY(I) = ',I8,2X,A4,A4,2X,3I8,2X,A4) 903 CALL DPWRST('XXX','BUG ') 904 285 CONTINUE 905 ENDIF 906 ENDIF 907C 908C ********************************************** 909C ** STEP 33-- ** 910C ** FORM THE SUBSETTED VARIABLES ** 911C ********************************************** 912C 913 ISTEPN='33' 914 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PROC') 915 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 916C 917 ICOL=1 918 IF(ICASPL.EQ.'ROC')THEN 919 CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 920 1 INAME,IVARN1,IVARN2,IVARTY, 921 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 922 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 923 1 MAXCP4,MAXCP5,MAXCP6, 924 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 925 1 Y1,Y2,XGROUP,XGROU2,TEMP1,TEMP1,TEMP1,NS, 926 1 IBUGG3,ISUBRO,IFOUND,IERROR) 927 ELSE 928 CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 929 1 INAME,IVARN1,IVARN2,IVARTY, 930 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 931 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 932 1 MAXCP4,MAXCP5,MAXCP6, 933 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 934 1 Y1,Y2,Y3,XGROUP,XGROU2,TEMP1,TEMP1,NS, 935 1 IBUGG3,ISUBRO,IFOUND,IERROR) 936 ENDIF 937 IF(IERROR.EQ.'YES')GOTO9000 938C 939C ***************************************************** 940C ** STEP 41-- ** 941C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** 942C ** VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR ** 943C ** THE PLOT. ** 944C ** FORM THE CURVE DESIGNATION VARIABLE D(.) . ** 945C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** 946C ** DEFINE THE NUMBER OF PLOT VARIABLES(NPLOTV). ** 947C ***************************************************** 948C 949 ISTEPN='61' 950 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PROC')THEN 951 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 952 DO3180I=1,NS 953 WRITE(ICOUT,3182)I,Y1(I),Y2(I),XGROUP(I),XGROU2(I) 954 3182 FORMAT('I,Y1(I),Y2(I),XGROUP(I),XGROU2(I)=',I8,4G15.7) 955 CALL DPWRST('XXX','BUG ') 956 3180 CONTINUE 957 ENDIF 958C 959 IF(ICASPL.EQ.'ROC')THEN 960 CALL DPROC2(Y1,Y2,XGROUP,XGROU2,NS,NUMVAR, 961 1 ICASPL,MAXN, 962 1 XIDTEM,XIDTE2,TEMP1,TEMP2,TEMP3,TEMP4,TEMP5, 963 1 Y,X,X3D,D,NPLOTP,NPLOTV,AUC, 964 1 IBUGG3,ISUBRO,IERROR) 965 ELSE 966 CALL DPROC3(Y1,Y2,Y3,XGROUP,XGROU2,NS,NUMVAR, 967 1 ICASPL,MAXN, 968 1 XIDTEM,XIDTE2,TEMP1,TEMP2,TEMP3,TEMP4, 969 1 Y,X,X3D,D,NPLOTP,NPLOTV, 970 1 IBUGG3,ISUBRO,IERROR) 971 ENDIF 972C 973C *************************************** 974C ** STEP 62-- ** 975C ** UPDATE INTERNAL DATAPLOT TABLES ** 976C *************************************** 977C 978 ISTEPN='62' 979 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ROC ') 980 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 981C 982 ISUBN0='ROC ' 983C 984 IF(NUMVAR.LE.3)THEN 985 IH='AUC ' 986 IH2=' ' 987 VALUE0=AUC 988 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 989 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 990 1 IANS,IWIDTH,IBUGG2,IERROR) 991 ENDIF 992C 993C ***************** 994C ** STEP 90-- ** 995C ** EXIT. ** 996C ***************** 997C 998 9000 CONTINUE 999 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'ROC ')THEN 1000 WRITE(ICOUT,999) 1001 CALL DPWRST('XXX','BUG ') 1002 WRITE(ICOUT,9011) 1003 9011 FORMAT('***** AT THE END OF DPROC--') 1004 CALL DPWRST('XXX','BUG ') 1005 WRITE(ICOUT,9012)IFOUND,IERROR,ICASPL 1006 9012 FORMAT('IFOUND,IERROR,ICASPL = ',2(A4,2X),A4) 1007 CALL DPWRST('XXX','BUG ') 1008 WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,IAND1,IAND2 1009 9013 FORMAT('NPLOTV,NPLOTP,NS,IAND1,IAND2 = ',3I8,2X,A4,2X,A4) 1010 CALL DPWRST('XXX','BUG ') 1011 WRITE(ICOUT,9020) 1012 9020 FORMAT('I,Y(.),X(.),D(.),ISUB(.)--') 1013 CALL DPWRST('XXX','BUG ') 1014 DO9021I=1,NPLOTP 1015 WRITE(ICOUT,9022)I,Y(I),X(I),D(I),ISUB(I) 1016 9022 FORMAT(I8,3G15.7,I8) 1017 CALL DPWRST('XXX','BUG ') 1018 9021 CONTINUE 1019 ENDIF 1020C 1021 RETURN 1022 END 1023 SUBROUTINE DPROC2(Y1,Y2,XGROUP,XSET,N,NUMV2, 1024 1 ICASPL,MAXN, 1025 1 XIDTEM,XIDTE2,TEMP1,TEMP2,TEMP3,TEMP4,TEMP5, 1026 1 YPLOT,XPLOT,X3D,D2,NPLOTP,NPLOTV,AUC, 1027 1 IBUGG3,ISUBRO,IERROR) 1028C 1029C PURPOSE--FORM A ROC CURVE. 1030C WRITTEN BY--JAMES J. FILLIBEN 1031C STATISTICAL ENGINEERING DIVISION 1032C INFORMATION TECHNOLOGY LABORATORY 1033C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 1034C GAITHERSBURG, MD 20899-8980 1035C PHONE--301-975-2855 1036C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 1037C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 1038C LANGUAGE--ANSI FORTRAN (1977) 1039C VERSION NUMBER--2007/7 1040C ORIGINAL VERSION--JULY 2007. 1041C 1042C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 1043C 1044 CHARACTER*4 ICASPL 1045 CHARACTER*4 IBUGG3 1046 CHARACTER*4 ISUBRO 1047 CHARACTER*4 IERROR 1048C 1049 CHARACTER*4 ISUBN1 1050 CHARACTER*4 ISUBN2 1051 CHARACTER*4 ISTEPN 1052 CHARACTER*4 IWRITE 1053 CHARACTER*4 IOP 1054C 1055 DIMENSION Y1(*) 1056 DIMENSION Y2(*) 1057 DIMENSION XGROUP(*) 1058 DIMENSION XSET(*) 1059 DIMENSION XIDTEM(*) 1060 DIMENSION XIDTE2(*) 1061 DIMENSION TEMP1(*) 1062 DIMENSION TEMP2(*) 1063 DIMENSION TEMP3(*) 1064 DIMENSION TEMP4(*) 1065 DIMENSION TEMP5(*) 1066 DIMENSION YPLOT(*) 1067 DIMENSION XPLOT(*) 1068 DIMENSION X3D(*) 1069 DIMENSION D2(*) 1070C 1071C-----COMMON---------------------------------------------------------- 1072C 1073 INCLUDE 'DPCOPA.INC' 1074 INCLUDE 'DPCOF2.INC' 1075 INCLUDE 'DPCOP2.INC' 1076C 1077C-----START POINT----------------------------------------------------- 1078C 1079 ISUBN1='DPRO' 1080 ISUBN2='C2 ' 1081 IERROR='NO' 1082 IWRITE='OFF' 1083C 1084 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ROC2')THEN 1085 WRITE(ICOUT,999) 1086 999 FORMAT(1X) 1087 CALL DPWRST('XXX','BUG ') 1088 WRITE(ICOUT,51) 1089 51 FORMAT('***** AT THE BEGINNING OF DPROC2--') 1090 CALL DPWRST('XXX','BUG ') 1091 WRITE(ICOUT,52)NUMV2,N,MAXN 1092 52 FORMAT('NUMV2,N,MAXN = ',3I8) 1093 CALL DPWRST('XXX','BUG ') 1094 WRITE(ICOUT,53)ICASPL,IBUGG3,IERROR 1095 53 FORMAT('ICASPL,IBUGG3,IERROR = ',A4,2X,A4,2X,A4) 1096 CALL DPWRST('XXX','BUG ') 1097 DO55I=1,MIN(N,100) 1098 WRITE(ICOUT,56)I,Y1(I),Y2(I),XGROUP(I),XSET(I) 1099 56 FORMAT('I,Y1(I),Y2(I),XGROUP(I),XSET(I) = ',I8,4G15.7) 1100 CALL DPWRST('XXX','BUG ') 1101 55 CONTINUE 1102 ENDIF 1103C 1104C ******************************************** 1105C ** STEP 1-- ** 1106C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 1107C ******************************************** 1108C 1109 ISTEPN='1' 1110 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'ROC2') 1111 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1112C 1113C **************************************************** 1114C ** STEP 2-- ** 1115C ** COMPUTE COORDINATES FOR ROC CURVE ** 1116C **************************************************** 1117C 1118 ISTEPN='2' 1119 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'ROC2') 1120 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1121C 1122 IF(NUMV2.EQ.3)THEN 1123 CALL DISTIN(XGROUP,N,IWRITE,XIDTEM,NUMSET,IBUGG3,IERROR) 1124 CALL SORT(XIDTEM,NUMSET,XIDTEM) 1125C 1126 XPLOT(1)=0.0 1127 YPLOT(1)=0.0 1128 D2(1)=1.0 1129 XPLOT(2)=1.0 1130 YPLOT(2)=1.0 1131 D2(2)=1.0 1132C 1133 J=2 1134 ITAG=2 1135 ICNT=0 1136 DO1000ISET=1,NUMSET 1137 HOLD=XIDTEM(ISET) 1138C 1139 K=0 1140 DO1010I=1,N 1141 IF(XGROUP(I).EQ.HOLD)THEN 1142 K=K+1 1143 TEMP1(K)=Y1(I) 1144 TEMP2(K)=Y2(I) 1145 ENDIF 1146 1010 CONTINUE 1147C 1148 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ROC2')THEN 1149 WRITE(ICOUT,999) 1150 CALL DPWRST('XXX','BUG ') 1151 WRITE(ICOUT,1051)ISET,K 1152 1051 FORMAT('***** SET ',I8,' HAS ',I8,' ELEMENTS.') 1153 CALL DPWRST('XXX','BUG ') 1154 IF(K.GT.0)THEN 1155 DO1055I=1,K 1156 WRITE(ICOUT,1057)I,TEMP1(I),TEMP2(I) 1157 1057 FORMAT('I,TEMP1(I),TEMP2(I) = ',I8,2G15.7) 1158 CALL DPWRST('XXX','BUG ') 1159 1055 CONTINUE 1160 ENDIF 1161 ENDIF 1162C 1163 CALL SENSIT(TEMP1,TEMP2,K,IWRITE,TEMP3,SENS,IBUGG3,IERROR) 1164 IF(IERROR.EQ.'YES')GOTO9000 1165 CALL SPECIF(TEMP1,TEMP2,K,IWRITE,TEMP3,SPEC,IBUGG3,IERROR) 1166 IF(IERROR.EQ.'YES')GOTO9000 1167 ICNT=ICNT+1 1168 J=J+1 1169 YPLOT(J)=SENS 1170 XPLOT(J)=1.0 - SPEC 1171 D2(J)=REAL(ITAG) 1172C 1173 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ROC2')THEN 1174 WRITE(ICOUT,1061)SENS,SPEC 1175 1061 FORMAT('SENSIT, SPEC = ',2G15.7) 1176 CALL DPWRST('XXX','BUG ') 1177 ENDIF 1178C 1179 1000 CONTINUE 1180C 1181 ICNT2=2 1182 DO1090I=1,ICNT 1183 J=J+1 1184 ICNT2=ICNT2+1 1185 ITAG=ITAG+1 1186 YPLOT(J)=YPLOT(ICNT2) 1187 XPLOT(J)=XPLOT(ICNT2) 1188 D2(J)=REAL(ITAG) 1189 1090 CONTINUE 1190C 1191 N2=J 1192 NPLOTP=N2 1193 NPLOTV=2 1194C 1195C COMPUTE AUC STATISTIC USING INTEGRATION. 1196C 1197 K=1 1198 TEMP1(K)=0.0 1199 TEMP2(K)=0.0 1200 DO1200I=1,NPLOTP 1201 IF(D2(I).EQ.2.0)THEN 1202 K=K+1 1203 TEMP1(K)=YPLOT(I) 1204 TEMP2(K)=XPLOT(I) 1205 ENDIF 1206 1200 CONTINUE 1207 K=K+1 1208 TEMP1(K)=1.0 1209 TEMP2(K)=1.0 1210C 1211 NUMV2=2 1212 IWRITE='OFF' 1213 CALL INTVEC(TEMP1,TEMP2,K,NUMV2,IWRITE,AUC,IBUGG3,IERROR) 1214C 1215C FOR 4 VARIABLE CASE: 1216C 1217C 1) XGROUP IDENTIFIES THE GROUP (I.E., MACHINE) 1218C 2) XSET IDENTIFIES SETTING WITH GROUP (I.E., THE 1219C SETTINGS FOR A SPECIFIC MACHINE) 1220C 1221 ELSEIF(NUMV2.EQ.4)THEN 1222 CALL DISTIN(XGROUP,N,IWRITE,XIDTEM,NUMSET,IBUGG3,IERROR) 1223 CALL SORT(XIDTEM,NUMSET,XIDTEM) 1224 CALL DISTIN(XSET,N,IWRITE,XIDTE2,NUMSE2,IBUGG3,IERROR) 1225 CALL SORT(XIDTE2,NUMSE2,XIDTE2) 1226C 1227 XPLOT(1)=0.0 1228 YPLOT(1)=0.0 1229 D2(1)=1.0 1230 XPLOT(2)=1.0 1231 YPLOT(2)=1.0 1232 D2(2)=1.0 1233C 1234 IOP='OPEN' 1235 IFLAG1=1 1236 IFLAG2=0 1237 IFLAG3=0 1238 IFLAG4=0 1239 IFLAG5=0 1240 CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5, 1241 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 1242 1 IBUGG3,ISUBRO,IERROR) 1243 IF(IERROR.EQ.'YES')GOTO9000 1244C 1245 J=2 1246 ITAG=1 1247C 1248 DO2000ISET=1,NUMSET 1249 HOLD=XIDTEM(ISET) 1250 ITAG=ITAG+1 1251 TEMP3(1)=0.0 1252 TEMP4(1)=0.0 1253 ICNT2=1 1254C 1255 DO3000ISET2=1,NUMSE2 1256 HOLD2=XIDTE2(ISET2) 1257C 1258 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ROC2')THEN 1259 WRITE(ICOUT,3011) 1260 3011 FORMAT('ISET,ISET2,HOLD,HOLD2 = ',2I8,2G15.7) 1261 CALL DPWRST('XXX','BUG ') 1262 ENDIF 1263C 1264 K=0 1265 DO2010I=1,N 1266 IF(XGROUP(I).EQ.HOLD .AND. XSET(I).EQ.HOLD2)THEN 1267 K=K+1 1268 TEMP1(K)=Y1(I) 1269 TEMP2(K)=Y2(I) 1270 ENDIF 1271 2010 CONTINUE 1272C 1273 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ROC2')THEN 1274 WRITE(ICOUT,3013) 1275 3013 FORMAT('K = ',I8) 1276 CALL DPWRST('XXX','BUG ') 1277 DO3015II=1,K 1278 WRITE(ICOUT,3017) 1279 3017 FORMAT('II,TEMP1(II),TEMP2(II) = ',I8,2G15.7) 1280 CALL DPWRST('XXX','BUG ') 1281 3015 CONTINUE 1282 ENDIF 1283C 1284 CALL SENSIT(TEMP1,TEMP2,K,IWRITE,TEMP5,SENS,IBUGG3,IERROR) 1285 IF(IERROR.EQ.'YES')GOTO9000 1286 CALL SPECIF(TEMP1,TEMP2,K,IWRITE,TEMP5,SPEC,IBUGG3,IERROR) 1287 IF(IERROR.EQ.'YES')GOTO9000 1288C 1289 J=J+1 1290 YPLOT(J)=SENS 1291 XPLOT(J)=1.0 - SPEC 1292 D2(J)=REAL(ITAG) 1293C 1294 ICNT2=ICNT2+1 1295 TEMP3(ICNT2)=XPLOT(J) 1296 TEMP4(ICNT2)=YPLOT(J) 1297C 1298 3000 CONTINUE 1299C 1300 ICNT2=ICNT2+1 1301 TEMP3(ICNT2)=1.0 1302 TEMP4(ICNT2)=1.0 1303 NUMV2=2 1304 IWRITE='OFF' 1305 CALL INTVEC(TEMP3,TEMP4,ICNT2,NUMV2,IWRITE,AUC, 1306 1 IBUGG3,IERROR) 1307 WRITE(IOUNI1,2029)ISET,AUC 1308 2029 FORMAT(I8,2X,E15.7) 1309C 1310 2000 CONTINUE 1311C 1312 IOP='CLOS' 1313 CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5, 1314 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 1315 1 IBUGG3,ISUBRO,IERROR) 1316 IF(IERROR.EQ.'YES')GOTO9000 1317C 1318 N2=J 1319 NPLOTP=N2 1320 NPLOTV=2 1321 ENDIF 1322C 1323C ***************** 1324C ** STEP 90-- ** 1325C ** EXIT ** 1326C ***************** 1327C 1328 9000 CONTINUE 1329 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ROC2')THEN 1330 WRITE(ICOUT,999) 1331 CALL DPWRST('XXX','BUG ') 1332 WRITE(ICOUT,9011) 1333 9011 FORMAT('***** AT THE END OF DPROC2--') 1334 CALL DPWRST('XXX','BUG ') 1335 WRITE(ICOUT,9012)IFOUND,IERROR 1336 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 1337 CALL DPWRST('XXX','BUG ') 1338 WRITE(ICOUT,9013)NPLOTV,NPLOTP,N,ICASPL 1339 9013 FORMAT('NPLOTV,NPLOTP,N,ICASPL = ', 1340 1 I8,I8,I8,2X,A4) 1341 CALL DPWRST('XXX','BUG ') 1342 WRITE(ICOUT,9020) 1343 9020 FORMAT('I,YPLOT(.),XPLOT(.),X3D(.),D2(.)--') 1344 CALL DPWRST('XXX','BUG ') 1345 DO9021I=1,NPLOTP 1346 WRITE(ICOUT,9022)I,YPLOT(I),XPLOT(I),X3D(I),D2(I) 1347 9022 FORMAT(I8,4G15.7) 1348 CALL DPWRST('XXX','BUG ') 1349 9021 CONTINUE 1350 ENDIF 1351C 1352 RETURN 1353 END 1354 SUBROUTINE DPROC3(Y1,Y2,Y3,XGROUP,XSET,N,NUMV2, 1355 1 ICASPL,MAXN, 1356 1 XIDTEM,XIDTE2,TEMP1,TEMP2,TEMP3,TEMP4, 1357 1 YPLOT,XPLOT,X3D,D2,NPLOTP,NPLOTV, 1358 1 IBUGG3,ISUBRO,IERROR) 1359C 1360C PURPOSE--FORM A PSUEDO ROC CURVE. 1361C 1362C THIS IS A VARIANT OF THE ROC CURVE. WHERE THE 1363C ROC CURVE PLOTS SENSITIVITY VERSUS (1 - SPECIFICITY), 1364C THE PSUEDO ROC CURVE PLOTS PROBABILITY CORRECT 1365C VERSUS PROBABILITY FALSE POSITIVE. 1366C 1367C THIS VARIANT IS MOTIVATED BY THE CASE WHERE 1368C THE "GROUND TRUTH" IS ALWAYS "1" (I.E., PRESENT). 1369C IN ADDITION, THE "OBSERVED" CAN BE MORE FLEXIBLE 1370C THAN SIMPLY PRESENT OR ABSENT. IN THIS CASE, 1371C WE DEFINE A FALSE NEGATIVE AS TOO LOW AN ALARM 1372C AND A FALSE POSITIVE AS TOO HIGH AN ALARM. 1373C 1374C THE DATA CONSISTS OF: 1375C 1376C Y1 = 1 CORRECT MATCH 1377C = 0 INCORRECT MATCH 1378C Y2 = 1 FALSE POSITIVE 1379C = 0 NO FALSE POSITIVE 1380C Y3 = 1 FALSE NEGATIVE 1381C = 0 NO FALSE NEGATIVE 1382C 1383C 1384C WRITTEN BY--JAMES J. FILLIBEN 1385C STATISTICAL ENGINEERING DIVISION 1386C INFORMATION TECHNOLOGY LABORATORY 1387C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 1388C GAITHERSBURG, MD 20899-8980 1389C PHONE--301-975-2855 1390C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 1391C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 1392C LANGUAGE--ANSI FORTRAN (1977) 1393C VERSION NUMBER--2007/7 1394C ORIGINAL VERSION--JULY 2007. 1395C 1396C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 1397C 1398 CHARACTER*4 ICASPL 1399 CHARACTER*4 IBUGG3 1400 CHARACTER*4 ISUBRO 1401 CHARACTER*4 IERROR 1402C 1403 CHARACTER*4 ISUBN1 1404 CHARACTER*4 ISUBN2 1405 CHARACTER*4 ISTEPN 1406 CHARACTER*4 IWRITE 1407C 1408 DIMENSION Y1(*) 1409 DIMENSION Y2(*) 1410 DIMENSION Y3(*) 1411 DIMENSION XGROUP(*) 1412 DIMENSION XSET(*) 1413 DIMENSION XIDTEM(*) 1414 DIMENSION XIDTE2(*) 1415 DIMENSION TEMP1(*) 1416 DIMENSION TEMP2(*) 1417 DIMENSION TEMP3(*) 1418 DIMENSION TEMP4(*) 1419 DIMENSION YPLOT(*) 1420 DIMENSION XPLOT(*) 1421 DIMENSION X3D(*) 1422 DIMENSION D2(*) 1423C 1424C-----COMMON---------------------------------------------------------- 1425C 1426 INCLUDE 'DPCOPA.INC' 1427 INCLUDE 'DPCOF2.INC' 1428 INCLUDE 'DPCOP2.INC' 1429C 1430C-----START POINT----------------------------------------------------- 1431C 1432 ISUBN1='DPRO' 1433 ISUBN2='C3 ' 1434 IERROR='NO' 1435 IWRITE='OFF' 1436C 1437 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ROC3')THEN 1438 WRITE(ICOUT,999) 1439 999 FORMAT(1X) 1440 CALL DPWRST('XXX','BUG ') 1441 WRITE(ICOUT,51) 1442 51 FORMAT('***** AT THE BEGINNING OF DPROC3--') 1443 CALL DPWRST('XXX','BUG ') 1444 WRITE(ICOUT,52)NUMV2,N,MAXN 1445 52 FORMAT('NUMV2,N,MAXN = ',3I8) 1446 CALL DPWRST('XXX','BUG ') 1447 WRITE(ICOUT,53)ICASPL,IBUGG3,IERROR 1448 53 FORMAT('ICASPL,IBUGG3,IERROR = ',A4,2X,A4,2X,A4) 1449 CALL DPWRST('XXX','BUG ') 1450 DO55I=1,MIN(N,100) 1451 WRITE(ICOUT,56)I,Y1(I),Y2(I),XGROUP(I),XSET(I) 1452 56 FORMAT('I,Y1(I),Y2(I),XGROUP(I),XSET(I) = ',I8,4G15.7) 1453 CALL DPWRST('XXX','BUG ') 1454 55 CONTINUE 1455 ENDIF 1456C 1457C ************************************************ 1458C ** STEP 1-- ** 1459C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 1460C ** 1) ROWS OF Y1, Y2, AND Y3 MUST SUM TO 1 ** 1461C ************************************************ 1462C 1463 ISTEPN='1' 1464 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'ROC3') 1465 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1466C 1467 DO100I=1,N 1468C 1469 ITEMP1=INT(Y1(I)+0.5) 1470 IF(ITEMP1.LT.0 .OR. ITEMP1.GT.1)THEN 1471 WRITE(ICOUT,999) 1472 CALL DPWRST('XXX','BUG ') 1473 WRITE(ICOUT,101) 1474 101 FORMAT('***** ERROR IN PSUEDO ROC CURVE') 1475 CALL DPWRST('XXX','BUG ') 1476 WRITE(ICOUT,103) 1477 103 FORMAT(' RESPONSE VARIABLE 1 (CORRECT MATCH) SHOULD') 1478 CALL DPWRST('XXX','BUG ') 1479 WRITE(ICOUT,105)I,Y1(I) 1480 105 FORMAT(' BE EITHER 0 OR 1. ROW ',I8,' HAS THE VALUE ', 1481 1 G15.7) 1482 CALL DPWRST('XXX','BUG ') 1483 IERROR='YES' 1484 GOTO9000 1485 ENDIF 1486 Y1(I)=REAL(ITEMP1) 1487C 1488 ITEMP2=INT(Y2(I)+0.5) 1489 IF(ITEMP2.GT.1)ITEMP2=1 1490 IF(ITEMP2.LT.0 .OR. ITEMP2.GT.1)THEN 1491 WRITE(ICOUT,999) 1492 CALL DPWRST('XXX','BUG ') 1493 WRITE(ICOUT,101) 1494 CALL DPWRST('XXX','BUG ') 1495 WRITE(ICOUT,113) 1496 113 FORMAT(' RESPONSE VARIABLE 2 (FALSE POSITIVE) SHOULD') 1497 CALL DPWRST('XXX','BUG ') 1498 WRITE(ICOUT,115)I,Y2(I) 1499 115 FORMAT(' BE EITHER 0 OR 1. ROW ',I8,' HAS THE VALUE ', 1500 1 G15.7) 1501 CALL DPWRST('XXX','BUG ') 1502 IERROR='YES' 1503 GOTO9000 1504 ENDIF 1505 Y2(I)=REAL(ITEMP2) 1506C 1507 ITEMP3=INT(Y3(I)+0.5) 1508 IF(ITEMP3.GT.1)ITEMP3=1 1509 IF(ITEMP3.LT.0 .OR. ITEMP3.GT.1)THEN 1510 WRITE(ICOUT,999) 1511 CALL DPWRST('XXX','BUG ') 1512 WRITE(ICOUT,101) 1513 CALL DPWRST('XXX','BUG ') 1514 WRITE(ICOUT,123) 1515 123 FORMAT(' RESPONSE VARIABLE 3 (FALSE NEGATIVE) SHOULD') 1516 CALL DPWRST('XXX','BUG ') 1517 WRITE(ICOUT,125)I,Y3(I) 1518 125 FORMAT(' BE EITHER 0 OR 1. ROW ',I8,' HAS THE VALUE ', 1519 1 G15.7) 1520 CALL DPWRST('XXX','BUG ') 1521 IERROR='YES' 1522 GOTO9000 1523 ENDIF 1524 Y3(I)=REAL(ITEMP3) 1525C 1526C IF ITEMP1 = 1, BOTH ITEMP2 AND ITEMP3 SHOULD BE ZERO. 1527C 1528 IF(ITEMP1.EQ.1)THEN 1529 IF(ITEMP2.EQ.1 .OR. ITEMP3.EQ.1)THEN 1530 WRITE(ICOUT,999) 1531 CALL DPWRST('XXX','BUG ') 1532 WRITE(ICOUT,101) 1533 CALL DPWRST('XXX','BUG ') 1534 WRITE(ICOUT,133) 1535 133 FORMAT(' IF A CORECT MATCH SPECIFIED, THEN BOTH ', 1536 1 'THE FALSE POSITIVE') 1537 CALL DPWRST('XXX','BUG ') 1538 WRITE(ICOUT,134) 1539 134 FORMAT(' AND THE FALSE NEGATIVE SHOULD BE 0. SUCH') 1540 CALL DPWRST('XXX','BUG ') 1541 WRITE(ICOUT,135) 1542 135 FORMAT(' WAS NOT THE CASE FOR ROW ',I8,'.') 1543 CALL DPWRST('XXX','BUG ') 1544 IERROR='YES' 1545 GOTO9000 1546 ENDIF 1547C 1548C IF ITEMP1 = 0, EITHER ITEMP2 OR ITEMP3 SHOULD BE ZERO. 1549C 1550 ELSEIF(ITEMP1.EQ.0)THEN 1551 IF(ITEMP2.EQ.0 .AND. ITEMP3.EQ.0)THEN 1552 WRITE(ICOUT,999) 1553 CALL DPWRST('XXX','BUG ') 1554 WRITE(ICOUT,101) 1555 CALL DPWRST('XXX','BUG ') 1556 WRITE(ICOUT,143) 1557 143 FORMAT(' IF AN INCORECT MATCH SPECIFIED, THEN ', 1558 1 'EITHER THE FALSE POSITIVE') 1559 CALL DPWRST('XXX','BUG ') 1560 WRITE(ICOUT,144) 1561 144 FORMAT(' OR THE FALSE NEGATIVE SHOULD BE 1. SUCH') 1562 CALL DPWRST('XXX','BUG ') 1563 WRITE(ICOUT,145) 1564 145 FORMAT(' WAS NOT THE CASE FOR ROW ',I8,'.') 1565 CALL DPWRST('XXX','BUG ') 1566 IERROR='YES' 1567 GOTO9000 1568 ENDIF 1569 ENDIF 1570 100 CONTINUE 1571C 1572C **************************************************** 1573C ** STEP 2-- ** 1574C ** COMPUTE COORDINATES FOR ROC CURVE ** 1575C **************************************************** 1576C 1577 ISTEPN='2' 1578 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'ROC3') 1579 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1580C 1581 IF(NUMV2.EQ.4)THEN 1582 CALL DISTIN(XGROUP,N,IWRITE,XIDTEM,NUMSET,IBUGG3,IERROR) 1583 CALL SORT(XIDTEM,NUMSET,XIDTEM) 1584C 1585 J=0 1586 ITAG=0 1587 DO1000ISET=1,NUMSET 1588 HOLD=XIDTEM(ISET) 1589C 1590 K=0 1591 DO1010I=1,N 1592 IF(XGROUP(I).EQ.HOLD)THEN 1593 K=K+1 1594 TEMP1(K)=Y1(I) 1595 TEMP2(K)=Y2(I) 1596 ENDIF 1597 1010 CONTINUE 1598C 1599 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ROC3')THEN 1600 WRITE(ICOUT,999) 1601 CALL DPWRST('XXX','BUG ') 1602 WRITE(ICOUT,1051)ISET,K 1603 1051 FORMAT('***** SET ',I8,' HAS ',I8,' ELEMENTS.') 1604 CALL DPWRST('XXX','BUG ') 1605 IF(K.GT.0)THEN 1606 DO1055I=1,K 1607 WRITE(ICOUT,1057)I,TEMP1(I),TEMP2(I) 1608 1057 FORMAT('I,TEMP1(I),TEMP2(I) = ',I8,2G15.7) 1609 CALL DPWRST('XXX','BUG ') 1610 1055 CONTINUE 1611 ENDIF 1612 ENDIF 1613C 1614C COMPUTE PROPORTION CORRECT AND PROPORTION OF FALSE 1615C POSITIVES. 1616C 1617 CALL SUMDP(TEMP1,K,IWRITE,PID,IBUGG3,IERROR) 1618 PID=PID/REAL(K) 1619 IF(IERROR.EQ.'YES')GOTO9000 1620 CALL SUMDP(TEMP2,K,IWRITE,PFP,IBUGG3,IERROR) 1621 PFP=PFP/REAL(K) 1622 IF(IERROR.EQ.'YES')GOTO9000 1623 J=J+1 1624 ITAG=ITAG+1 1625 YPLOT(J)=PID 1626 XPLOT(J)=PFP 1627 D2(J)=REAL(ITAG) 1628C 1629 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ROC3')THEN 1630 WRITE(ICOUT,1061)PID,PFP 1631 1061 FORMAT('PID,PFP = ',2G15.7) 1632 CALL DPWRST('XXX','BUG ') 1633 ENDIF 1634C 1635 1000 CONTINUE 1636C 1637 N2=J 1638 NPLOTP=N2 1639 NPLOTV=2 1640C 1641C FOR 4 VARIABLE CASE: 1642C 1643C 1) XGROUP IDENTIFIES THE GROUP (I.E., MACHINE) 1644C 2) XSET IDENTIFIES SETTING WITH GROUP (I.E., THE 1645C SETTINGS FOR A SPECIFIC MACHINE) 1646C 1647 ELSEIF(NUMV2.EQ.5)THEN 1648 CALL DISTIN(XGROUP,N,IWRITE,XIDTEM,NUMSET,IBUGG3,IERROR) 1649 CALL SORT(XIDTEM,NUMSET,XIDTEM) 1650 CALL DISTIN(XSET,N,IWRITE,XIDTE2,NUMSE2,IBUGG3,IERROR) 1651 CALL SORT(XIDTE2,NUMSE2,XIDTE2) 1652C 1653 J=0 1654 ITAG=0 1655C 1656 DO2000ISET=1,NUMSET 1657 HOLD=XIDTEM(ISET) 1658 ITAG=ITAG+1 1659 TEMP3(1)=0.0 1660 TEMP4(1)=0.0 1661 ICNT2=1 1662C 1663 DO3000ISET2=1,NUMSE2 1664 HOLD2=XIDTE2(ISET2) 1665C 1666 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ROC3')THEN 1667 WRITE(ICOUT,3011) 1668 3011 FORMAT('ISET,ISET2,HOLD,HOLD2 = ',2I8,2G15.7) 1669 CALL DPWRST('XXX','BUG ') 1670 ENDIF 1671C 1672 K=0 1673 DO2010I=1,N 1674 IF(XGROUP(I).EQ.HOLD .AND. XSET(I).EQ.HOLD2)THEN 1675 K=K+1 1676 TEMP1(K)=Y1(I) 1677 TEMP2(K)=Y2(I) 1678 ENDIF 1679 2010 CONTINUE 1680C 1681 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ROC3')THEN 1682 WRITE(ICOUT,3013) 1683 3013 FORMAT('K = ',I8) 1684 CALL DPWRST('XXX','BUG ') 1685 DO3015II=1,K 1686 WRITE(ICOUT,3017) 1687 3017 FORMAT('II,TEMP1(II),TEMP2(II) = ',I8,2G15.7) 1688 CALL DPWRST('XXX','BUG ') 1689 3015 CONTINUE 1690 ENDIF 1691C 1692 CALL SUMDP(TEMP1,K,IWRITE,PID,IBUGG3,IERROR) 1693 PID=PID/REAL(K) 1694 IF(IERROR.EQ.'YES')GOTO9000 1695 CALL SUMDP(TEMP2,K,IWRITE,PFP,IBUGG3,IERROR) 1696 PFP=PFP/REAL(K) 1697 IF(IERROR.EQ.'YES')GOTO9000 1698C 1699 J=J+1 1700 YPLOT(J)=PID 1701 XPLOT(J)=PFP 1702 D2(J)=REAL(ITAG) 1703C 1704 3000 CONTINUE 1705 2000 CONTINUE 1706C 1707 N2=J 1708 NPLOTP=N2 1709 NPLOTV=2 1710 ENDIF 1711C 1712C ***************** 1713C ** STEP 90-- ** 1714C ** EXIT ** 1715C ***************** 1716C 1717 9000 CONTINUE 1718 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ROC3')THEN 1719 WRITE(ICOUT,999) 1720 CALL DPWRST('XXX','BUG ') 1721 WRITE(ICOUT,9011) 1722 9011 FORMAT('***** AT THE END OF DPROC3--') 1723 CALL DPWRST('XXX','BUG ') 1724 WRITE(ICOUT,9012)IFOUND,IERROR 1725 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 1726 CALL DPWRST('XXX','BUG ') 1727 WRITE(ICOUT,9013)NPLOTV,NPLOTP,N,ICASPL 1728 9013 FORMAT('NPLOTV,NPLOTP,N,ICASPL = ', 1729 1 I8,I8,I8,2X,A4) 1730 CALL DPWRST('XXX','BUG ') 1731 WRITE(ICOUT,9020) 1732 9020 FORMAT('I,YPLOT(.),XPLOT(.),X3D(.),D2(.)--') 1733 CALL DPWRST('XXX','BUG ') 1734 DO9021I=1,NPLOTP 1735 WRITE(ICOUT,9022)I,YPLOT(I),XPLOT(I),X3D(I),D2(I) 1736 9022 FORMAT(I8,4G15.7) 1737 CALL DPWRST('XXX','BUG ') 1738 9021 CONTINUE 1739 ENDIF 1740C 1741 RETURN 1742 END 1743 SUBROUTINE DPROEY(IHARG,IARGT,ARG,NUMARG, 1744 1 X3DEYE,Y3DEYE,Z3DEYE, 1745 1 X3DMID,Y3DMID,Z3DMID, 1746 1 AEYEXC,AEYEYC,AEYEZC, 1747 1 IFOUND,IERROR) 1748C 1749C PURPOSE--ROTATE THE CURRENT EYE COORDINATES 1750C LEFT, RIGHT, UP, DOWN, XY, XZ, OR YZ 1751C DEFAULT DIRECTION = LEFT 1752C DEFAULT ANGLE = 10 DEGREES 1753C COMMAND EXAMPLE = ROTATE EYE LEFT 45 1754C 1755C 0 ARGUMENT CASE 1756C ROTATE ==> ROTATE EYE LEFT 10 1757C 1 ARGUMENT CASE 1758C ROTATE 17 ==> ROTATE EYE LEFT 17 1759C ROTATE EYE ==> ROTATE EYE LEFT 10 1760C ROTATE LEFT ==> ROTATE EYE LEFT 10 1761C ROTATE RIGHT ==> ROTATE EYE RIGHT 10 1762C ROTATE UP ==> ROTATE EYE UP 10 1763C ROTATE DOWN ==> ROTATE EYE DOWN 10 1764C ROTATE XY ==> ROTATE EYE XY 10 1765C ROTATE XZ ==> ROTATE EYE XZ 10 1766C ROTATE YZ ==> ROTATE EYE YZ 10 1767C 2 ARGUMENT CASE 1768C ROTATE EYE 17 ==> ROTATE EYE LEFT 17 1769C ROTATE LEFT 17 ==> ROTATE EYE LEFT 17 1770C ROTATE RIGHT 17 ==> ROTATE EYE RIGHT 17 1771C ROTATE UP 17 ==> ROTATE EYE UP 17 1772C ROTATE DOWN 17 ==> ROTATE EYE DOWN 17 1773C ROTATE XY 17 ==> ROTATE EYE XY 17 1774C ROTATE XZ 17 ==> ROTATE EYE XZ 17 1775C ROTATE YZ 17 ==> ROTATE EYE YZ 17 1776C ROTATE EYE LEFT ==> ROTATE EYE LEFT 10 1777C ROTATE EYE RIGHT ==> ROTATE EYE LEFT 10 1778C ROTATE EYE UP ==> ROTATE EYE UP 10 1779C ROTATE EYE DOWN ==> ROTATE EYE DOWN 10 1780C ROTATE EYE XY ==> ROTATE EYE XY 10 1781C ROTATE EYE XZ ==> ROTATE EYE XZ 10 1782C ROTATE EYE YZ ==> ROTATE EYE YZ 10 1783C 3 ARGUMENT CASE 1784C ROTATE EYE LEFT 17 1785C ROTATE EYE RIGHT 17 1786C ROTATE EYE UP 17 1787C ROTATE EYE DOWN 17 1788C ROTATE EYE XY 17 1789C ROTATE EYE XZ 17 1790C ROTATE EYE YZ 17 1791C 1792C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 1793C --IARGT (A HOLLERITH VECTOR) 1794C --ARG (A FLOATING POINT VECTOR) 1795C --NUMARG 1796C --X3DEYE = X-COORDINATE OF EYE 1797C --Y3DEYE = Y-COORDINATE OF EYE 1798C --Z3DEYE = Z-COORDINATE OF EYE 1799C --X3DMID = X-COORDINATE OF MID-FIGURE 1800C --Y3DMID = Y-COORDINATE OF MID-FIGURE 1801C --Z3DMID = Z-COORDINATE OF MID-FIGURE 1802C OUTPUT ARGUMENTS--AEYEXC = X-COORDINATE OF EYE (POST-ROTAT.) 1803C --AEYEYC = Y-COORDINATE OF EYE (POST-ROTAT.) 1804C --AEYEZC = Z-COORDINATE OF EYE (POST-ROTAT.) 1805C --IFOUND ('YES' OR 'NO' ) 1806C --IERROR ('YES' OR 'NO' ) 1807C WRITTEN BY--JAMES J. FILLIBEN 1808C STATISTICAL ENGINEERING DIVISION 1809C INFORMATION TECHNOLOGY LABORATORY 1810C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 1811C GAITHERSBURG, MD 20899 1812C PHONE--301-975-2855 1813C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 1814C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 1815C LANGUAGE--ANSI FORTRAN (1977) 1816C VERSION NUMBER--93/10 1817C ORIGINAL VERSION--SEPTEMBER 1993. 1818C 1819C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 1820C 1821 CHARACTER*4 IHARG 1822 CHARACTER*4 IARGT 1823 CHARACTER*4 IFOUND 1824 CHARACTER*4 IERROR 1825CCCCC OCTOBER 1993. ADD FOLLOWING LINE 1826 CHARACTER*4 IDIR 1827C 1828C--------------------------------------------------------------------- 1829C 1830 DIMENSION IHARG(*) 1831 DIMENSION IARGT(*) 1832 DIMENSION ARG(*) 1833C 1834C--------------------------------------------------------------------- 1835C 1836 INCLUDE 'DPCOP2.INC' 1837C 1838C-----START POINT----------------------------------------------------- 1839C 1840 IFOUND='NO' 1841 IERROR='NO' 1842C 1843 ANGDEF=10.0 1844 X3=0.0 1845 Y3=0.0 1846 Z3=0.0 1847C 1848C ******************************************** 1849C ** STEP 1-- ** 1850C ** BRANCH ACCORDING TO THE CASE ** 1851C ******************************************** 1852C 1853 IF(NUMARG.EQ.0)THEN 1854 ANGLE=ANGDEF 1855 IDIR='LEFT' 1856 GOTO1000 1857 ENDIF 1858C 1859 IF(NUMARG.GE.1)THEN 1860 IF(IHARG(NUMARG).EQ.'?')GOTO2000 1861 ENDIF 1862C 1863 IF(NUMARG.EQ.1)THEN 1864 IF(IARGT(1).EQ.'NUMB')THEN 1865 ANGLE=ARG(1) 1866 IDIR='LEFT' 1867 GOTO1000 1868 ELSE 1869 ANGLE=ANGDEF 1870 IDIR='LEFT' 1871 IF(IHARG(1).EQ.'EYE ')IDIR='LEFT' 1872 IF(IHARG(1).EQ.'LEFT')IDIR='LEFT' 1873 IF(IHARG(1).EQ.'RIGH')IDIR='RIGH' 1874 IF(IHARG(1).EQ.'UP ')IDIR='UP ' 1875 IF(IHARG(1).EQ.'DOWN')IDIR='DOWN' 1876 IF(IHARG(1).EQ.'XY ')IDIR='XY ' 1877 IF(IHARG(1).EQ.'YX ')IDIR='XY ' 1878 IF(IHARG(1).EQ.'XZ ')IDIR='XZ ' 1879 IF(IHARG(1).EQ.'ZX ')IDIR='XZ ' 1880 IF(IHARG(1).EQ.'YZ ')IDIR='YZ ' 1881 IF(IHARG(1).EQ.'ZY ')IDIR='YZ ' 1882 GOTO1000 1883 ENDIF 1884 ENDIF 1885C 1886 IF(NUMARG.EQ.2)THEN 1887 IF(IARGT(2).EQ.'NUMB')THEN 1888 ANGLE=ARG(2) 1889 IDIR='LEFT' 1890 IF(IHARG(1).EQ.'EYE ')IDIR='LEFT' 1891 IF(IHARG(1).EQ.'LEFT')IDIR='LEFT' 1892 IF(IHARG(1).EQ.'RIGH')IDIR='RIGH' 1893 IF(IHARG(1).EQ.'UP ')IDIR='UP ' 1894 IF(IHARG(1).EQ.'DOWN')IDIR='DOWN' 1895 IF(IHARG(1).EQ.'XY ')IDIR='XY ' 1896 IF(IHARG(1).EQ.'YX ')IDIR='XY ' 1897 IF(IHARG(1).EQ.'XZ ')IDIR='XZ ' 1898 IF(IHARG(1).EQ.'ZX ')IDIR='XZ ' 1899 IF(IHARG(1).EQ.'YZ ')IDIR='YZ ' 1900 IF(IHARG(1).EQ.'ZY ')IDIR='YZ ' 1901 GOTO1000 1902 ELSE 1903 ANGLE=ANGDEF 1904 IDIR='LEFT' 1905 IF(IHARG(2).EQ.'EYE ')IDIR='LEFT' 1906 IF(IHARG(2).EQ.'LEFT')IDIR='LEFT' 1907 IF(IHARG(2).EQ.'RIGH')IDIR='RIGH' 1908 IF(IHARG(2).EQ.'UP ')IDIR='UP ' 1909 IF(IHARG(2).EQ.'DOWN')IDIR='DOWN' 1910 IF(IHARG(1).EQ.'XY ')IDIR='XY ' 1911 IF(IHARG(1).EQ.'YX ')IDIR='XY ' 1912 IF(IHARG(1).EQ.'XZ ')IDIR='XZ ' 1913 IF(IHARG(1).EQ.'ZX ')IDIR='XZ ' 1914 IF(IHARG(1).EQ.'YZ ')IDIR='YZ ' 1915 IF(IHARG(1).EQ.'ZY ')IDIR='YZ ' 1916 GOTO1000 1917 ENDIF 1918 ENDIF 1919C 1920 IF(NUMARG.EQ.3)THEN 1921 IF(IARGT(3).EQ.'NUMB')THEN 1922 ANGLE=ARG(3) 1923 IDIR='LEFT' 1924 IF(IHARG(2).EQ.'EYE ')IDIR='LEFT' 1925 IF(IHARG(2).EQ.'LEFT')IDIR='LEFT' 1926 IF(IHARG(2).EQ.'RIGH')IDIR='RIGH' 1927 IF(IHARG(2).EQ.'UP ')IDIR='UP ' 1928 IF(IHARG(2).EQ.'DOWN')IDIR='DOWN' 1929 IF(IHARG(1).EQ.'XY ')IDIR='XY ' 1930 IF(IHARG(1).EQ.'YX ')IDIR='XY ' 1931 IF(IHARG(1).EQ.'XZ ')IDIR='XZ ' 1932 IF(IHARG(1).EQ.'ZX ')IDIR='XZ ' 1933 IF(IHARG(1).EQ.'YZ ')IDIR='YZ ' 1934 IF(IHARG(1).EQ.'ZY ')IDIR='YZ ' 1935 GOTO1000 1936 ELSE 1937 ANGLE=ANGDEF 1938 IDIR='LEFT' 1939 GOTO1000 1940 ENDIF 1941 ENDIF 1942C 1943 GOTO8000 1944C 1945C ******************************************** 1946C ** STEP 11-- ** 1947C ** DO THE ROTATION ** 1948C ******************************************** 1949C 1950 1000 CONTINUE 1951 IFOUND='YES' 1952 THETA=(ANGLE/360.0)*2*3.14159 1953 X1=X3DEYE 1954 Y1=Y3DEYE 1955 Z1=Z3DEYE 1956 X2=X3DEYE-X3DMID 1957 Y2=Y3DEYE-Y3DMID 1958 Z2=Z3DEYE-Z3DMID 1959C 1960 IF(IDIR.EQ.'LEFT'.OR.IDIR.EQ.'RIGH')THEN 1961 IF(IDIR.EQ.'RIGH')THETA=(-THETA) 1962 X3=X2*COS(THETA)-Y2*SIN(THETA) 1963 Y3=X2*SIN(THETA)+Y2*COS(THETA) 1964 Z3=Z2 1965 GOTO1100 1966 ENDIF 1967C 1968 IF(IDIR.EQ.'UP'.OR.IDIR.EQ.'DOWN')THEN 1969 IF(IDIR.EQ.'DOWN')THETA=(-THETA) 1970CTODO X3=X2*COS(A1)+Y2*COS(A2)+Z2*COS(A3) DPTR32, MATH DICT. 337 1971CTODO Y3=X2*COS(B1)+Y2*COS(B2)+Z2*COS(B3) 1972CTODO Z3=X2*COS(C1)+Y2*COS(C2)+Z2*COS(C3) 1973 GOTO1100 1974 ENDIF 1975C 1976 IF(IDIR.EQ.'XY ')THEN 1977 THETA=(-THETA) 1978 X3=X2*COS(THETA)-Y2*SIN(THETA) 1979 Y3=X2*SIN(THETA)+Y2*COS(THETA) 1980 Z3=Z2 1981 GOTO1100 1982 ENDIF 1983C 1984 IF(IDIR.EQ.'XZ ')THEN 1985 THETA=(-THETA) 1986 X3=X2*COS(THETA)-Z2*SIN(THETA) 1987 Y3=Y2 1988 Z3=X2*SIN(THETA)+Z2*COS(THETA) 1989 GOTO1100 1990 ENDIF 1991C 1992 IF(IDIR.EQ.'YZ ')THEN 1993 THETA=(-THETA) 1994 X3=X2 1995 Y3=Z2*SIN(THETA)+Y2*COS(THETA) 1996 Z3=Z2*COS(THETA)-Y2*SIN(THETA) 1997 GOTO1100 1998 ENDIF 1999C 2000 1100 CONTINUE 2001 X4=X3+X3DMID 2002 Y4=Y3+Y3DMID 2003 Z4=Z3+Z3DMID 2004 AEYEXC=X4 2005 AEYEYC=Y4 2006 AEYEZC=Z4 2007 IF(IFEEDB.EQ.'ON')THEN 2008 WRITE(ICOUT,999) 2009 999 FORMAT(1X) 2010 CALL DPWRST('XXX','BUG ') 2011 WRITE(ICOUT,1111) 2012 1111 FORMAT('OLD & NEW (X,Y,Z) EYE COORDINATES--') 2013 CALL DPWRST('XXX','BUG ') 2014 WRITE(ICOUT,1121)X1,X4 2015 1121 FORMAT(' X = ',2F10.3) 2016 CALL DPWRST('XXX','BUG ') 2017 WRITE(ICOUT,1122)Y1,Y4 2018 1122 FORMAT(' Y = ',2F10.3) 2019 CALL DPWRST('XXX','BUG ') 2020 WRITE(ICOUT,1123)Z1,Z4 2021 1123 FORMAT(' Z = ',2F10.3) 2022 CALL DPWRST('XXX','BUG ') 2023 ENDIF 2024 GOTO9000 2025C 2026C ******************************************** 2027C ** STEP 12-- ** 2028C ** TREAT THE ? CASE-- ** 2029C ** DUMP OUT CURRENT AND DEFAULT VALUES. ** 2030C ******************************************** 2031C 2032 2000 CONTINUE 2033 IFOUND='YES' 2034 WRITE(ICOUT,999) 2035 CALL DPWRST('XXX','WRIT') 2036 WRITE(ICOUT,2011) 2037 2011 FORMAT('THE CURRENT (X,Y,Z) EYE COORDINATES ARE') 2038 CALL DPWRST('XXX','WRIT') 2039 WRITE(ICOUT,2021)X3DEYE 2040 2021 FORMAT(' X = ',E15.7) 2041 CALL DPWRST('XXX','WRIT') 2042 WRITE(ICOUT,2022)Y3DEYE 2043 2022 FORMAT(' Y = ',E15.7) 2044 CALL DPWRST('XXX','WRIT') 2045 WRITE(ICOUT,2023)Z3DEYE 2046 2023 FORMAT(' Z = ',E15.7) 2047 CALL DPWRST('XXX','WRIT') 2048C 2049 WRITE(ICOUT,999) 2050 CALL DPWRST('XXX','WRIT') 2051 WRITE(ICOUT,2031) 2052 2031 FORMAT('THE DEFAULT ROTATION DIRECTION IS LEFT (= XY)') 2053 CALL DPWRST('XXX','WRIT') 2054 WRITE(ICOUT,2032) 2055 2032 FORMAT('THE DEFAULT ROTATION ANGLE IS 10 DEGREES') 2056 CALL DPWRST('XXX','WRIT') 2057 WRITE(ICOUT,2033) 2058 2033 FORMAT(' THEREFORE, ROTATE == ROTATE EYE LEFT 10') 2059 CALL DPWRST('XXX','WRIT') 2060 WRITE(ICOUT,999) 2061 CALL DPWRST('XXX','WRIT') 2062 WRITE(ICOUT,2041) 2063 2041 FORMAT('SYNTAX: ROTATE EYE <DIRECTION> <ANGLE>') 2064 CALL DPWRST('XXX','WRIT') 2065 WRITE(ICOUT,2042) 2066 2042 FORMAT('<DIRECTION> = LEFT, RIGHT, UP, DOWN, XY, XZ, YZ') 2067 CALL DPWRST('XXX','WRIT') 2068 WRITE(ICOUT,2043) 2069 2043 FORMAT('<ANGLE> = -360 TO +360 DEGREES') 2070 CALL DPWRST('XXX','WRIT') 2071 WRITE(ICOUT,2044) 2072 2044 FORMAT('EXAMPLE--ROTATE EYE LEFT 60') 2073 CALL DPWRST('XXX','WRIT') 2074 WRITE(ICOUT,2045) 2075 2045 FORMAT('EXAMPLE--ROTATE EYE YZ 45') 2076 CALL DPWRST('XXX','WRIT') 2077 WRITE(ICOUT,2046) 2078 2046 FORMAT('EXAMPLE--ROTATE (== ROTATE EYE LEFT 10)') 2079 CALL DPWRST('XXX','WRIT') 2080 GOTO9000 2081C 2082C ******************************************** 2083C ** STEP 80-- ** 2084C ** TREAT THE ERROR CASE ** 2085C ******************************************** 2086C 2087 8000 CONTINUE 2088 IERROR='YES' 2089 WRITE(ICOUT,8011) 2090 8011 FORMAT('***** ERROR IN DPROEY--') 2091 CALL DPWRST('XXX','BUG ') 2092 WRITE(ICOUT,8012) 2093 8012 FORMAT(' ILLEGAL SYNTAX FOR ROTATE EYE COMMAND.') 2094 CALL DPWRST('XXX','BUG ') 2095 WRITE(ICOUT,8013) 2096 8013 FORMAT(' SYNTAX: ROTATE EYE <DIRECTION> <ANGLE>') 2097 CALL DPWRST('XXX','BUG ') 2098 WRITE(ICOUT,8014) 2099 8014 FORMAT(' <DIRECTION> = LEFT, RIGHT, UP, DOWN, XY, XZ, YZ') 2100 CALL DPWRST('XXX','BUG ') 2101 WRITE(ICOUT,8015) 2102 8015 FORMAT(' <ANGLE> = -360 TO +360 DEGREES') 2103 CALL DPWRST('XXX','BUG ') 2104 WRITE(ICOUT,8016) 2105 8016 FORMAT(' EXAMPLE--ROTATE EYE LEFT 60') 2106 CALL DPWRST('XXX','BUG ') 2107 WRITE(ICOUT,8017) 2108 8017 FORMAT(' EXAMPLE--ROTATE EYE YZ 45') 2109 CALL DPWRST('XXX','BUG ') 2110 GOTO9000 2111C 2112C ***************** 2113C ** STEP 90-- ** 2114C ** EXIT ** 2115C ***************** 2116C 2117 9000 CONTINUE 2118 RETURN 2119 END 2120 SUBROUTINE DPROO2(MODEL,NUMCHA,PARAM,IPARN,IPARN2,NUMPV, 2121 1 IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 2122 1 IVARN,IVARN2,NUMVAR,XMIN,XMAX,ROOTS2,NROOTS, 2123 1 ROOTAC,IFLGFB, 2124 1 IHNAME,IHNAM2,IUSE,IVALUE,VALUE, 2125 1 NUMNAM,MAXNAM,MAXCOL,IFTEXP,IFTORD,IFORSW, 2126 1 PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,V,MAXN, 2127 1 ISUBRO,IBUGA3,IBUGCO,IBUGEV,IERROR) 2128C 2129C 2015/09: ADD LINES TO ARGUMENT LIST FOR FUNCTION BLOCK 2130C AUGMENTATION 2131C 2132C PURPOSE--COMPUTE THE ROOTS OF A FUNCTION 2133C THAT ARE KNOWN TO BE BETWEEN THE LIMITS 2134C XMIN AND XMAX. 2135C WRITTEN BY--JAMES J. FILLIBEN 2136C STATISTICAL ENGINEERING DIVISION 2137C INFORMATION TECHNOLOGY LABORATORY 2138C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 2139C GAITHERSBURG, MD 20899 2140C PHONE--301-975-2855 2141C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 2142C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 2143C LANGUAGE--ANSI FORTRAN (1977) 2144C VERSION NUMBER--82/7 2145C ORIGINAL VERSION--NOVEMBER 1978. 2146C UPDATED --FEBRUARY 1981. 2147C UPDATED --JULY 1981. 2148C UPDATED --MARCH 1982. 2149C UPDATED --MAY 1982. 2150C UPDATED --FEBRUARY 1994. ACTIVATE ROOT ACCURACY 2151C UPDATED --SEPTEMBER 2015. SUPPORT FOR "FUNCTION BLOCKS" 2152C 2153C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 2154C 2155 CHARACTER*4 MODEL 2156 CHARACTER*4 IPARN 2157 CHARACTER*4 IPARN2 2158 CHARACTER*4 IANGLU 2159 CHARACTER*4 ITYPEH 2160 CHARACTER*4 IW21HO 2161 CHARACTER*4 IW22HO 2162 CHARACTER*4 IVARN 2163 CHARACTER*4 IVARN2 2164 CHARACTER*4 IFTEXP 2165 CHARACTER*4 IFTORD 2166 CHARACTER*4 IFORSW 2167 CHARACTER*4 ISUBRO 2168 CHARACTER*4 IBUGA3 2169 CHARACTER*4 IBUGCO 2170 CHARACTER*4 IBUGEV 2171 CHARACTER*4 IERROR 2172C 2173 CHARACTER*4 ILAB 2174 CHARACTER*4 IH 2175 CHARACTER*4 IH2 2176C 2177 CHARACTER*4 ISUBN1 2178 CHARACTER*4 ISUBN2 2179 CHARACTER*4 ISTEPN 2180 CHARACTER*4 IFOUND 2181C 2182C--------------------------------------------------------------------- 2183C 2184 DIMENSION MODEL(*) 2185 DIMENSION PARAM(*) 2186 DIMENSION IPARN(*) 2187 DIMENSION IPARN2(*) 2188 DIMENSION IVARN(*) 2189 DIMENSION IVARN2(*) 2190 DIMENSION ROOTS2(*) 2191C 2192 DIMENSION ITYPEH(*) 2193 DIMENSION IW21HO(*) 2194 DIMENSION IW22HO(*) 2195 DIMENSION W2HOLD(*) 2196C 2197 DIMENSION PRED(*) 2198 DIMENSION RES(*) 2199 DIMENSION XPLOT(*) 2200 DIMENSION YPLOT(*) 2201 DIMENSION X2PLOT(*) 2202 DIMENSION TAGPLO(*) 2203 DIMENSION V(*) 2204C 2205 DIMENSION IVALUE(*) 2206 DIMENSION VALUE(*) 2207C 2208 CHARACTER*4 IHNAME(*) 2209 CHARACTER*4 IHNAM2(*) 2210 CHARACTER*4 IUSE(*) 2211C 2212 DIMENSION ILOCV(10) 2213 DIMENSION ILAB(10) 2214C 2215C 2015/08: FUNCTION BLOCK 2216C 2217 INCLUDE 'DPCOFB.INC' 2218C 2219 CHARACTER*8 IFBNAM 2220 CHARACTER*8 IFBANS 2221C 2222 CHARACTER*4 IFEESV 2223 COMMON/IFEED/IFEESV 2224C 2225C--------------------------------------------------------------------- 2226C 2227 INCLUDE 'DPCOP2.INC' 2228C 2229C-----START POINT----------------------------------------------------- 2230C 2231 ISUBN1='DPRO' 2232 ISUBN2='O2 ' 2233 IERROR='NO' 2234 IFOUND='NO' 2235C 2236C THE FOLLOWING ACCURACY SETTING WAS SWITCHED DUE TO FAILURE 2237C TO CONVERGE FOR SOME FUNCTIONS ON 32-BIT VAX 2238C (BUT DID CONVERGE ON 36-BIT UNIVAC) 2239CCCCC ROOTAC=0.0000001 2240CCCCC PASS ROOTAC AS ARGUMENT. FEBRUARY 1994. 2241CCCCC ROOTAC=0.000001 2242 CUTOFF=0.001 2243 DIFF=(-999.) 2244 RATIO=(-999.) 2245 IPASS=2 2246 NROOTS=0 2247C 2248 J2=0 2249C 2250 X2=0.0 2251 X3MIN=0.0 2252 X3MAX=0.0 2253 CALC1=0.0 2254 RATIO=0.0 2255C 2256 MAXCP1=MAXCOL+1 2257 MAXCP2=MAXCOL+2 2258 MAXCP3=MAXCOL+3 2259 MAXCP4=MAXCOL+4 2260 MAXCP5=MAXCOL+5 2261 MAXCP6=MAXCOL+6 2262C 2263 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROO2')THEN 2264 WRITE(ICOUT,999) 2265 999 FORMAT(1X) 2266 CALL DPWRST('XXX','BUG ') 2267 WRITE(ICOUT,51) 2268 51 FORMAT('AT THE BEGINNING OF DPROO2--') 2269 CALL DPWRST('XXX','BUG ') 2270 WRITE(ICOUT,52)IBUGA3,IBUGCO,IBUGEV,IANGLU 2271 52 FORMAT('IBUGA3,IBUGCO,IBUGEV,IANGLU = ',3(A4,2X),A4) 2272 CALL DPWRST('XXX','BUG ') 2273 WRITE(ICOUT,53)NUMCHA,NUMPV,NUMVAR,IFLGFB 2274 53 FORMAT('NUMCHA,NUMPV,NUMVAR,IFLGFB = ',4I8) 2275 CALL DPWRST('XXX','BUG ') 2276 WRITE(ICOUT,54)(MODEL(J),J=1,MIN(100,NUMCHA)) 2277 54 FORMAT('MODEL(I) = ',100A1) 2278 CALL DPWRST('XXX','BUG ') 2279 DO55I=1,NUMPV 2280 WRITE(ICOUT,56)I,PARAM(I),IPARN(I),IPARN2(I) 2281 56 FORMAT('I,PARAM(I),IPARN(I),IPARN2(I) = ',I8,G15.7,A4,A4) 2282 CALL DPWRST('XXX','BUG ') 2283 55 CONTINUE 2284 DO60I=1,NUMVAR 2285 WRITE(ICOUT,61)I,IVARN(I),IVARN2(I) 2286 61 FORMAT('I, IVARN(I),IVARN2(I) = ',I8,2X,A4,A4) 2287 CALL DPWRST('XXX','BUG ') 2288 60 CONTINUE 2289 WRITE(ICOUT,62)XMIN,XMAX 2290 62 FORMAT('XMIN, XMAX = ',2G15.7) 2291 CALL DPWRST('XXX','BUG ') 2292 ENDIF 2293C 2294C *************************************************** 2295C ** STEP 1-- ** 2296C ** DETERMINE THE LOCATIONS (IN THE LIST IPARN) ** 2297C ** OF THE VARIABLES OF THE FUNCTION. ** 2298C *************************************************** 2299C 2300 ISTEPN='1' 2301 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROO2') 2302 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2303C 2304 IFBNAM=' ' 2305 IFBANS=' ' 2306C 2307 IF(IFLGFB.LE.0)THEN 2308 DO100I=1,NUMVAR 2309 IH=IVARN(I) 2310 IH2=IVARN2(I) 2311 DO200J=1,NUMPV 2312 J2=J 2313 IF(IPARN(J).EQ.IH.AND.IPARN2(J).EQ.IH2)THEN 2314 ILOCV(I)=J2 2315 GOTO210 2316 ENDIF 2317 200 CONTINUE 2318 210 CONTINUE 2319 100 CONTINUE 2320 ELSE 2321 IF(IFLGFB.EQ.1)THEN 2322 IFBNAM=IFBNA1 2323 IFBANS=IFBAN1 2324 IH=IFBPL1(1)(1:4) 2325 IH2=IFBPL1(1)(5:8) 2326 ELSEIF(IFLGFB.EQ.2)THEN 2327 IFBNAM=IFBNA2 2328 IFBANS=IFBAN2 2329 IH=IFBPL2(1)(1:4) 2330 IH2=IFBPL2(1)(5:8) 2331 ELSEIF(IFLGFB.EQ.3)THEN 2332 IFBNAM=IFBNA3 2333 IFBANS=IFBAN3 2334 IH=IFBPL3(1)(1:4) 2335 IH2=IFBPL3(1)(5:8) 2336 ENDIF 2337 ENDIF 2338C 2339C ************************************************* 2340C ** STEP 2-- ** 2341C ** WRITE OUT PRELIMINARY SUMMARY INFORMATION ** 2342C ************************************************* 2343C 2344 ISTEPN='2' 2345 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROO2') 2346 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2347C 2348 IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN 2349 WRITE(ICOUT,999) 2350 CALL DPWRST('XXX','BUG ') 2351 WRITE(ICOUT,401) 2352 401 FORMAT('ROOTS OF AN EQUATION') 2353 CALL DPWRST('XXX','BUG ') 2354 IF(IFLGFB.LE.0)THEN 2355 ILAB(1)=' ' 2356 ILAB(2)=' FU' 2357 ILAB(3)='NCTI' 2358 ILAB(4)='ON--' 2359 NUMWDL=4 2360 CALL DPPRIF(ILAB,NUMWDL,MODEL,NUMCHA,IBUGA3) 2361 ENDIF 2362C 2363 WRITE(ICOUT,402)IVARN(1),IVARN2(1) 2364 402 FORMAT(' ROOT VARIABLE = ',A4,A4) 2365 CALL DPWRST('XXX','BUG ') 2366C 2367 WRITE(ICOUT,403)XMIN 2368 403 FORMAT(' SPECIFIED LOWER LIMIT OF INTERVAL = ',F20.10) 2369 CALL DPWRST('XXX','BUG ') 2370 WRITE(ICOUT,404)XMAX 2371 404 FORMAT(' SPECIFIED UPPER LIMIT OF INTERVAL = ',F20.10) 2372 CALL DPWRST('XXX','BUG ') 2373 ENDIF 2374C 2375 NUMSEG=100 2376 NUMPT=NUMSEG+1 2377 ANUMPT=NUMPT 2378C 2379C ******************************************************* 2380C ** STEP 3-- ** 2381C ** PARTITION THE INTERVAL FROM XMIN TO XMAX INTO ** 2382C ** NUMSEG EQUALLY-SPACED SEGMENTS. STEP ** 2383C ** THROUGH EACH OF THE NUMSEG + 1 POINTS ** 2384C ** WHICH DEFINE THE SEGMENTS-- ** 2385C ** ALL THE WHILE LOOKING FOR FUNCTION CROSS-OVERS. ** 2386C ******************************************************* 2387C 2388 ISTEPN='3' 2389 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROO2') 2390 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2391C 2392 DO1000I=1,NUMPT 2393 AI=I 2394 P=(AI-1.0)/(ANUMPT-1.0) 2395 X2=(1.0-P)*XMIN+P*XMAX 2396 X3MAX=X2 2397C 2398 IF(IFLGFB.LE.0)THEN 2399 DO1100K=1,NUMVAR 2400 JLOC=ILOCV(K) 2401 PARAM(JLOC)=X2 2402 1100 CONTINUE 2403 CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPV, 2404 1 IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,CALC2, 2405 1 IBUGCO,IBUGEV,IERROR) 2406 IF(IERROR.EQ.'YES')GOTO9000 2407 ELSE 2408C 2409C FUNCTION BLOCK CASE: 2410C 2411C STEP 1: COMPUTE FUNCTION BLOCK (BUT FIRST SET CURRENT 2412C VALUE OF DESIRED PARAMETER) 2413C 2414 DO1105II=1,NUMNAM 2415 IF(IH.EQ.IHNAME(II) .AND. IH2.EQ.IHNAM2(II) .AND. 2416 1 IUSE(II).EQ.'P')THEN 2417 VALUE(II)=X2 2418 IVALUE(II)=INT(X2+0.5) 2419 GOTO1109 2420 ENDIF 2421 1105 CONTINUE 2422C 2423C PARAMETER NAME NOT FOUND IN CURRENT LIST, SO NEED TO ADD 2424C TO NAME LIST 2425C 2426 IF(NUMNAM.LT.MAXNAM)THEN 2427 NUMNAM=NUMNAM+1 2428 IHNAME(NUMNAM)=IH 2429 IHNAM2(NUMNAM)=IH2 2430 IUSE(NUMNAM)='P' 2431 VALUE(NUMNAM)=X2 2432 IVALUE(NUMNAM)=INT(X2+ 0.5) 2433 ELSE 2434 WRITE(ICOUT,999) 2435 CALL DPWRST('XXX','BUG ') 2436 WRITE(ICOUT,1361) 2437 CALL DPWRST('XXX','BUG ') 2438 WRITE(ICOUT,1107) 2439 1107 FORMAT(' THE MAXIMUM NUMBER OF NAMES EXCEEDED.') 2440 CALL DPWRST('XXX','BUG ') 2441 ENDIF 2442C 2443 1109 CONTINUE 2444C 2445 IFEEDB='OFF' 2446 CALL DPFBEX(IFBNAM,IANGLU,ISEED,IFTEXP,IFTORD,IFORSW, 2447 1 IBUGA3,IBUGA3,IBUGCO,IBUGEV,IBUGEV, 2448 1 ISUBRO,IFOUND,IERROR) 2449 IFEEDB=IFEESV 2450C 2451C STEP 2: RETRIEVE RESPONSE 2452C 2453 DO1120II=1,NUMNAM 2454 IF(IFBANS(1:4).EQ.IHNAME(II) .AND. 2455 1 IFBANS(5:8).EQ.IHNAM2(II))THEN 2456 IF(IUSE(II).EQ.'P')THEN 2457 CALC2=VALUE(II) 2458 GOTO1129 2459 ELSEIF(IUSE(II).EQ.'V')THEN 2460 ICOLR=IVALUE(II) 2461 IJ=MAXN*(ICOLR-1)+1 2462 IF(ICOLR.LE.MAXCOL)CALC2=V(IJ) 2463 IF(ICOLR.EQ.MAXCP1)CALC2=PRED(1) 2464 IF(ICOLR.EQ.MAXCP2)CALC2=RES(1) 2465 IF(ICOLR.EQ.MAXCP3)CALC2=YPLOT(1) 2466 IF(ICOLR.EQ.MAXCP4)CALC2=XPLOT(1) 2467 IF(ICOLR.EQ.MAXCP5)CALC2=X2PLOT(1) 2468 IF(ICOLR.EQ.MAXCP6)CALC2=TAGPLO(1) 2469 GOTO1129 2470 ENDIF 2471 ENDIF 2472 1120 CONTINUE 2473C 2474C PARAMETER/VARIABLE NAME NOT FOUND 2475C 2476 WRITE(ICOUT,1361) 2477 CALL DPWRST('XXX','BUG ') 2478 WRITE(ICOUT,1121) 2479 1121 FORMAT(' EXPECTED PARAMETER/VARIABLE NOT FOUND IN NAME ', 2480 1 'TABLE.') 2481 CALL DPWRST('XXX','BUG ') 2482 WRITE(ICOUT,1123)IFBANS 2483 1123 FORMAT(' EXPECTED NAME = ',A8) 2484 CALL DPWRST('XXX','BUG ') 2485C 2486 1129 CONTINUE 2487C 2488 ENDIF 2489C 2490 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROO2')THEN 2491 WRITE(ICOUT,1302)X2,CALC2 2492 1302 FORMAT('X2,CALC2 = ',2G15.7) 2493 CALL DPWRST('XXX','BUG ') 2494 ENDIF 2495C 2496 IF(CALC2.EQ.0.0)THEN 2497 NROOTS=NROOTS+1 2498 ROOTS2(NROOTS)=X2 2499 ENDIF 2500C 2501 IF(I.EQ.1)GOTO1390 2502C 2503 IF(CALC1.LT.0.0.AND.CALC2.GT.0.0)GOTO1350 2504 IF(CALC1.GT.0.0.AND.CALC2.LT.0.0)GOTO1350 2505 GOTO1390 2506C 2507 1350 CONTINUE 2508C 2509C THE FOLLOWING LINE WAS MOVED 25 LINES UP 2510C (MODIFICATION SUGGESTED BY TED PRINCE, NBS) 2511CCCCC X3MAX=X2 2512C 2513C ******************************************************** 2514C ** STEP 4-- ** 2515C ** PERFORM THE FOLLOWING SUB-SECTION OF CODE ONLY ** 2516C ** WHEN A CROSS-OVER HAS BEEN FOUND WHILE STEPPING ** 2517C ** THROUGH THE NUMSEG + 1 POINTS IN THE INTERVAL.* 2518C ** THE PURPOSE OF THE FOLLOWING SUB-SECTION OF CODE ** 2519C ** IS TO DETERMINE MORE PRECISELY THE ROOT ** 2520C ** WHEN A CROSS-OVER HAS BEEN DETECTED. ** 2521C ******************************************************** 2522C 2523 ICOUMX=1000 2524 ICOUNT=0 2525 1360 CONTINUE 2526 ICOUNT=ICOUNT+1 2527 IF(ICOUNT.GT.ICOUMX)THEN 2528 WRITE(ICOUT,999) 2529 CALL DPWRST('XXX','BUG ') 2530 WRITE(ICOUT,1321) 2531 1321 FORMAT('***** CAUTION FROM DPROO2--') 2532 CALL DPWRST('XXX','BUG ') 2533 WRITE(ICOUT,1322) 2534 1322 FORMAT(' THE NUMBER OF INTERATIONS IN THE ROOT-FINDING') 2535 CALL DPWRST('XXX','BUG ') 2536 WRITE(ICOUT,1324)ICOUMX 2537 1324 FORMAT(' PROCESS HAS JUST EXCEEDED ',I8) 2538 CALL DPWRST('XXX','BUG ') 2539 WRITE(ICOUT,1325)X3 2540 1325 FORMAT(' ROOT = ',E15.7) 2541 CALL DPWRST('XXX','BUG ') 2542 WRITE(ICOUT,1326)ROOTAC 2543 1326 FORMAT(' DESIRED ACCURACY = ',E15.7) 2544 CALL DPWRST('XXX','BUG ') 2545 WRITE(ICOUT,1327)DIFF 2546 1327 FORMAT(' ACTUAL DELTA X = ',E15.7) 2547 CALL DPWRST('XXX','BUG ') 2548 WRITE(ICOUT,1328)RATIO 2549 1328 FORMAT(' ACTUAL DELTA X / X = ',E15.7) 2550 CALL DPWRST('XXX','BUG ') 2551 GOTO1370 2552 ENDIF 2553C 2554 X3=(X3MIN+X3MAX)/2.0 2555C 2556C 2557 IF(IFLGFB.LE.0)THEN 2558 DO3100K=1,NUMVAR 2559 JLOC=ILOCV(K) 2560 PARAM(JLOC)=X3 2561 3100 CONTINUE 2562 CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPV, 2563 1 IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,CALC3, 2564 1 IBUGCO,IBUGEV,IERROR) 2565 ELSE 2566C 2567C FUNCTION BLOCK CASE: 2568C 2569C STEP 1: COMPUTE FUNCTION BLOCK (BUT FIRST SET CURRENT 2570C VALUE OF DESIRED PARAMETER) 2571C 2572 IFEEDB='OFF' 2573C 2574 DO3105II=1,NUMNAM 2575 IF(IH.EQ.IHNAME(II) .AND. IH2.EQ.IHNAM2(II) .AND. 2576 1 IUSE(II).EQ.'P')THEN 2577 VALUE(II)=X3 2578 IVALUE(II)=INT(X3+0.5) 2579 GOTO3109 2580 ENDIF 2581 3105 CONTINUE 2582C 2583C PARAMETER NAME NOT FOUND IN CURRENT LIST, SO NEED TO ADD 2584C TO NAME LIST 2585C 2586 IF(NUMNAM.LT.MAXNAM)THEN 2587 NUMNAM=NUMNAM+1 2588 IHNAME(NUMNAM)=IH 2589 IHNAM2(NUMNAM)=IH2 2590 IUSE(NUMNAM)='P' 2591 VALUE(NUMNAM)=X3 2592 IVALUE(NUMNAM)=INT(X3+ 0.5) 2593 ELSE 2594 WRITE(ICOUT,999) 2595 CALL DPWRST('XXX','BUG ') 2596 WRITE(ICOUT,1361) 2597 CALL DPWRST('XXX','BUG ') 2598 WRITE(ICOUT,1107) 2599 CALL DPWRST('XXX','BUG ') 2600 ENDIF 2601C 2602 3109 CONTINUE 2603C 2604 CALL DPFBEX(IFBNAM,IANGLU,ISEED,IFTEXP,IFTORD,IFORSW, 2605 1 IBUGA3,IBUGA3,IBUGCO,IBUGEV,IBUGEV, 2606 1 ISUBRO,IFOUND,IERROR) 2607C 2608C STEP 2: RETRIEVE RESPONSE 2609C 2610 DO3120II=1,NUMNAM 2611 IF(IFBANS(1:4).EQ.IHNAME(II) .AND. 2612 1 IFBANS(5:8).EQ.IHNAM2(II))THEN 2613 IF(IUSE(II).EQ.'P')THEN 2614 CALC3=VALUE(II) 2615 GOTO3129 2616 ELSEIF(IUSE(II).EQ.'V')THEN 2617 ICOLR=IVALUE(II) 2618 IJ=MAXN*(ICOLR-1)+1 2619 IF(ICOLR.LE.MAXCOL)CALC3=V(IJ) 2620 IF(ICOLR.EQ.MAXCP1)CALC3=PRED(1) 2621 IF(ICOLR.EQ.MAXCP2)CALC3=RES(1) 2622 IF(ICOLR.EQ.MAXCP3)CALC3=YPLOT(1) 2623 IF(ICOLR.EQ.MAXCP4)CALC3=XPLOT(1) 2624 IF(ICOLR.EQ.MAXCP5)CALC3=X2PLOT(1) 2625 IF(ICOLR.EQ.MAXCP6)CALC3=TAGPLO(1) 2626 GOTO3129 2627 ENDIF 2628 ENDIF 2629 3120 CONTINUE 2630C 2631C PARAMETER/VARIABLE NAME NOT FOUND 2632C 2633 WRITE(ICOUT,1361) 2634 CALL DPWRST('XXX','BUG ') 2635 WRITE(ICOUT,1121) 2636 CALL DPWRST('XXX','BUG ') 2637 WRITE(ICOUT,1123)IFBANS 2638 CALL DPWRST('XXX','BUG ') 2639C 2640 3129 CONTINUE 2641C 2642 IFEEDB=IFEESV 2643C 2644 ENDIF 2645C 2646 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROO2')THEN 2647 WRITE(ICOUT,1303)X3,CALC3 2648 1303 FORMAT('X3,CALC3 = ',2G15.7) 2649 CALL DPWRST('XXX','BUG ') 2650 ENDIF 2651C 2652 PROD1=CALC1*CALC3 2653 PROD2=CALC2*CALC3 2654 IF(PROD1.GT.0.0)X3MIN=X3 2655 IF(PROD2.GT.0.0)X3MAX=X3 2656C 2657 ABSX3=ABS(X3) 2658 DIFF=ABS(X3MAX-X3MIN) 2659 IF(ABSX3.LE.CUTOFF.AND.DIFF.LE.ROOTAC)GOTO1370 2660 IF(ABSX3.LE.CUTOFF.AND.DIFF.GT.ROOTAC)GOTO1340 2661 RATIO=ABS(DIFF/X3) 2662 IF(ABSX3.GT.CUTOFF.AND.RATIO.LE.ROOTAC)GOTO1370 2663 IF(ABSX3.GT.CUTOFF.AND.RATIO.GT.ROOTAC)GOTO1340 2664 1340 CONTINUE 2665C 2666 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROO2')THEN 2667 WRITE(ICOUT,3145)CUTOFF,ROOTAC,DIFF,RATIO,ABSX3 2668 3145 FORMAT('CUTOFF,ROOTAC,DIFF,RATIO,ABSX3 = ',5E15.7) 2669 CALL DPWRST('XXX','BUG ') 2670 ENDIF 2671C 2672 IF(PROD2.EQ.0.0)GOTO1370 2673 IF(PROD1.GT.0.0.OR.PROD2.GT.0.0)GOTO1360 2674C 2675 WRITE(ICOUT,1361) 2676 1361 FORMAT('***** ERROR IN ROOTS--') 2677 CALL DPWRST('XXX','BUG ') 2678 WRITE(ICOUT,1362) 2679 1362 FORMAT(' IMPOSSIBLE CONDITION ARISING: PROD1 OR PROD2 ', 2680 1 'NOT EQUAL ZERO') 2681 CALL DPWRST('XXX','BUG ') 2682 WRITE(ICOUT,1363)PROD1,PROD2,X3MIN,X3,X3MAX,CALC1,CALC3,CALC2 2683 1363 FORMAT('PROD1,PROD2,X3MIN,X3,X3MAX,CALC1,CALC3,CALC2 = ', 2684 1 8E10.3) 2685 CALL DPWRST('XXX','BUG ') 2686 IERROR='YES' 2687 GOTO9000 2688C 2689 1370 CONTINUE 2690 NROOTS=NROOTS+1 2691 ROOTS2(NROOTS)=X3 2692 GOTO1390 2693C 2694 1390 CONTINUE 2695 X3MIN=X3MAX 2696 CALC1=CALC2 2697C 2698 1000 CONTINUE 2699C 2700C *************************** 2701C ** STEP 5-- ** 2702C ** WRITE OUT THE ROOTS ** 2703C *************************** 2704C 2705 ISTEPN='5' 2706 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROO2') 2707 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2708C 2709 IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN 2710 WRITE(ICOUT,999) 2711 CALL DPWRST('XXX','BUG ') 2712 WRITE(ICOUT,1405)NROOTS 2713 1405 FORMAT(' NUMBER OF ROOTS FOUND IN INTERVAL = ',I8) 2714 CALL DPWRST('XXX','BUG ') 2715 WRITE(ICOUT,999) 2716 CALL DPWRST('XXX','BUG ') 2717 IF(NROOTS.GT.0)THEN 2718 DO1410I=1,NROOTS 2719 WRITE(ICOUT,1411)I,ROOTS2(I) 2720 1411 FORMAT('ROOT ',I5,' = ',G15.7) 2721 CALL DPWRST('XXX','BUG ') 2722 1410 CONTINUE 2723 WRITE(ICOUT,999) 2724 CALL DPWRST('XXX','BUG ') 2725 ENDIF 2726 ENDIF 2727C 2728C ***************** 2729C ** STEP 90-- ** 2730C ** EXIT ** 2731C ***************** 2732C 2733 9000 CONTINUE 2734 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROO2')THEN 2735 WRITE(ICOUT,9011) 2736 9011 FORMAT('***** AT THE END OF DPROO2--') 2737 CALL DPWRST('XXX','BUG ') 2738 WRITE(ICOUT,9012)IERROR,NROOTS,NUMVAR,NUMSEG 2739 9012 FORMAT('IERROR,NROOTS,NUMVAR,NUMSEG = ',A4,2X,3I8) 2740 CALL DPWRST('XXX','BUG ') 2741 DO9015I=1,NROOTS 2742 WRITE(ICOUT,9016)I,ROOTS2(I) 2743 9016 FORMAT('I,ROOTS2(I) = ',I8,G15.7) 2744 CALL DPWRST('XXX','BUG ') 2745 9015 CONTINUE 2746 WRITE(ICOUT,9023)CALC1,CALC2,CALC3 2747 9023 FORMAT('CALC1,CALC2,CALC3 = ',3G15.7) 2748 CALL DPWRST('XXX','BUG ') 2749 WRITE(ICOUT,9024)X2,X3MIN,X3,X3MAX 2750 9024 FORMAT('X2,X3MIN,X3,X3MAX = ',4G15.7) 2751 CALL DPWRST('XXX','BUG ') 2752 ENDIF 2753C 2754 RETURN 2755 END 2756 SUBROUTINE DPROOT(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 2757 1 PARAM,IPARN,IPARN2, 2758 1 ROOTAC,IFTEXP,IFTORD,IFORSW,IANGLU, 2759 1 ISUBRO,IBUGA3,IBUGCO,IBUGEV,IBUGQ,IERROR) 2760C 2761C PURPOSE--TREAT THE LET CASE FOR 2762C FINDING THE ROOTS OF AN EQUATION. 2763C EXAMPLE--LET X = ROOTS X**3+2*X**2-4*X+5 FOR X = -100 200 2764C --LET X = F1 FOR X = 0 B 2765C WRITTEN BY--JAMES J. FILLIBEN 2766C STATISTICAL ENGINEERING DIVISION 2767C INFORMATION TECHNOLOGY LABORATORY 2768C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 2769C GAITHERSBURG, MD 20899 2770C PHONE--301-975-2855 2771C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 2772C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 2773C LANGUAGE--ANSI FORTRAN (1977) 2774C VERSION NUMBER--82/7 2775C ORIGINAL VERSION--JANUARY 1979. 2776C UPDATED-- --FEBRUARY 1979. 2777C UPDATED --MARCH 1979. 2778C UPDATED --JULY 1981. 2779C UPDATED --SEPTEMBER 1981. 2780C UPDATED --MARCH 1982. 2781C UPDATED --MAY 1982. 2782C UPDATED --FEBRUARY 1994. ACTIVATE ROOT ACCURACY 2783C UPDATED --SPETEMBER 2015. SUPPORT FUNCTION BLOCK 2784C 2785C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 2786C 2787 CHARACTER*4 ITYPEH 2788 CHARACTER*4 IW21HO 2789 CHARACTER*4 IW22HO 2790 CHARACTER*4 IPARN 2791 CHARACTER*4 IPARN2 2792 CHARACTER*4 IFTEXP 2793 CHARACTER*4 IFTORD 2794 CHARACTER*4 IFORSW 2795 CHARACTER*4 IANGLU 2796 CHARACTER*4 ISUBRO 2797 CHARACTER*4 IBUGA3 2798 CHARACTER*4 IBUGCO 2799 CHARACTER*4 IBUGEV 2800 CHARACTER*4 IBUGQ 2801 CHARACTER*4 IERROR 2802C 2803 CHARACTER*4 NEWNAM 2804 CHARACTER*4 IWD1 2805 CHARACTER*4 IWD12 2806 CHARACTER*4 IWD2 2807 CHARACTER*4 IWD22 2808 CHARACTER*4 ILAB 2809 CHARACTER*4 IKEY 2810 CHARACTER*4 IKEY2 2811 CHARACTER*4 INCLUN 2812 CHARACTER*4 IHWUSE 2813 CHARACTER*4 MESSAG 2814 CHARACTER*4 ICASUP 2815 CHARACTER*4 IERRO2 2816 CHARACTER*4 IHLEFT 2817 CHARACTER*4 IFOUN1 2818 CHARACTER*4 IFOUN2 2819 CHARACTER*4 IOLD 2820 CHARACTER*4 IOLD2 2821 CHARACTER*4 INEW 2822 CHARACTER*4 INEW2 2823 CHARACTER*4 IHPARN 2824 CHARACTER*4 IHPAR2 2825 CHARACTER*4 IHL 2826 CHARACTER*4 IHL2 2827 CHARACTER*4 IDUMV 2828 CHARACTER*4 IDUMV2 2829 CHARACTER*4 IHOUT 2830 CHARACTER*4 IHOUT2 2831 CHARACTER*4 IUOUT 2832 CHARACTER*4 IHLEF2 2833 CHARACTER*4 IFOUND 2834C 2835 CHARACTER*4 ISUBN1 2836 CHARACTER*4 ISUBN2 2837 CHARACTER*4 ISTEPN 2838C 2839C--------------------------------------------------------------------- 2840C 2841 DIMENSION ITYPEH(*) 2842 DIMENSION IW21HO(*) 2843 DIMENSION IW22HO(*) 2844 DIMENSION W2HOLD(*) 2845C 2846 DIMENSION PARAM(*) 2847 DIMENSION IPARN(*) 2848 DIMENSION IPARN2(*) 2849C 2850 DIMENSION IDUMV(100) 2851 DIMENSION IDUMV2(100) 2852 DIMENSION ROOTS2(100) 2853C 2854 DIMENSION ILAB(10) 2855 DIMENSION IOLD(10) 2856 DIMENSION IOLD2(10) 2857 DIMENSION INEW(10) 2858 DIMENSION INEW2(10) 2859C 2860C-----COMMON---------------------------------------------------------- 2861C 2862 INCLUDE 'DPCOPA.INC' 2863 INCLUDE 'DPCOHK.INC' 2864 INCLUDE 'DPCODA.INC' 2865 INCLUDE 'DPCOFB.INC' 2866 INCLUDE 'DPCOP2.INC' 2867C 2868C-----START POINT----------------------------------------------------- 2869C 2870C ******************************* 2871C ** TREAT THE ROOTS SUBCASE ** 2872C ** OF THE LET COMMAND ** 2873C ******************************* 2874C 2875 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROOT')THEN 2876 WRITE(ICOUT,999) 2877 999 FORMAT(1X) 2878 CALL DPWRST('XXX','BUG ') 2879 WRITE(ICOUT,51) 2880 51 FORMAT('***** AT THE BEGINNING OF DPROOT--') 2881 CALL DPWRST('XXX','BUG ') 2882 WRITE(ICOUT,53)IBUGA2,IBUGCO,IBUGEV,IBUGQ 2883 53 FORMAT('IBUGA3,IBUGCO,IBUGEV,IBUGQ = ',4(A4,2X),A4) 2884 CALL DPWRST('XXX','BUG ') 2885 ENDIF 2886C 2887C ********************************** 2888C ** STEP 1-- ** 2889C ** INITIALIZE SOME VARIABLES. ** 2890C ********************************** 2891C 2892 ISTEPN='1' 2893 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROOT') 2894 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2895C 2896 ISUBN1='DPRO' 2897 ISUBN2='OT ' 2898 IFOUND='NO' 2899 IERROR='NO' 2900 NEWNAM='NO' 2901C 2902 MAXCP1=MAXCOL+1 2903 MAXCP2=MAXCOL+2 2904 MAXCP3=MAXCOL+3 2905 MAXCP4=MAXCOL+4 2906 MAXCP5=MAXCOL+5 2907 MAXCP6=MAXCOL+6 2908 ILOCMX=0 2909 NUMLIM=0 2910 ILOC3=0 2911 MAXN2=MAXCHF 2912 MAXN3=MAXCHF 2913C 2914C ******************************************************* 2915C ** STEP 2-- ** 2916C ** EXAMINE THE LEFT-HAND SIDE-- ** 2917C ** IS THE VARIABLE NAME TO LEFT OF = SIGN ** 2918C ** ALREADY IN THE NAME LIST? ** 2919C ** NOTE THAT ILISTL IS THE LINE IN THE TABLE ** 2920C ** OF THE NAME ON THE LEFT. ** 2921C ******************************************************* 2922C 2923 ISTEPN='2' 2924 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROOT') 2925 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2926C 2927 IHLEFT=IHARG(1) 2928 IHLEF2=IHARG2(1) 2929 DO2000I=1,NUMNAM 2930 I2=I 2931 IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN 2932 ILISTL=I2 2933 GOTO2900 2934 ENDIF 2935 2000 CONTINUE 2936C 2937 NEWNAM='YES' 2938 ILISTL=NUMNAM+1 2939 IF(ILISTL.GT.MAXNAM)THEN 2940 WRITE(ICOUT,999) 2941 CALL DPWRST('XXX','BUG ') 2942 WRITE(ICOUT,2201) 2943 2201 FORMAT('***** ERROR IN LET ... ROOT--') 2944 CALL DPWRST('XXX','BUG ') 2945 WRITE(ICOUT,2202) 2946 2202 FORMAT(' THE NUMBER OF VARIABLE, PARAMETER, AND FUNCTION') 2947 CALL DPWRST('XXX','BUG ') 2948 WRITE(ICOUT,2203)MAXNAM 2949 2203 FORMAT(' NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8) 2950 CALL DPWRST('XXX','BUG ') 2951 WRITE(ICOUT,2204) 2952 2204 FORMAT(' ENTER STAT') 2953 CALL DPWRST('XXX','BUG ') 2954 WRITE(ICOUT,2205) 2955 2205 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES, AND ', 2956 1 'THEN') 2957 CALL DPWRST('XXX','BUG ') 2958 WRITE(ICOUT,2206) 2959 2206 FORMAT(' REDEFINE (REUSE) SOME OF THE ALREADY-USED NAMES') 2960 CALL DPWRST('XXX','BUG ') 2961 IERROR='YES' 2962 GOTO9000 2963 ENDIF 2964C 2965 2900 CONTINUE 2966C 2967C ******************************************************* 2968C ** STEP 3.1-- ** 2969C ** EXTRACT THE RIGHT-SIDE FUNCTIONAL EXPRESSION ** 2970C ** FROM THE INPUT COMMAND LINE (STARTING WITH THE ** 2971C ** FIRST NON-BLANK LOCATION AFTER THE EQUAL SIGN ** 2972C ** AND ENDING WITH THE END OF THE LINE OR WITH THE ** 2973C ** LAST NON-BLANK CHARACTER BEFORE WRT . ** 2974C ** PLACE THE FUNCTION IN IFUNC2(.) . ** 2975C ******************************************************* 2976C 2977 ISTEPN='3.1' 2978 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROOT') 2979 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2980C 2981C 2015/09: CHECK TO SEE IF THE FIRST ARGUMENT ON RHS IS A FUNCTION 2982C BLOCK NAME. 2983C 2984 IF(IHARG(4).EQ.IFBNA1(1:4) .AND. IHARG2(4).EQ.IFBNA1(5:8))THEN 2985 IFLGFB=1 2986 ELSEIF(IHARG(4).EQ.IFBNA2(1:4) .AND. IHARG2(4).EQ.IFBNA2(5:8))THEN 2987 IFLGFB=2 2988 ELSEIF(IHARG(4).EQ.IFBNA3(1:4) .AND. IHARG2(4).EQ.IFBNA3(5:8))THEN 2989 IFLGFB=3 2990 ELSE 2991 IFLGFB=0 2992 ENDIF 2993C 2994 IWD1=IHARG(3) 2995 IWD12=IHARG2(3) 2996 IWD2='WRT ' 2997 IWD22=' ' 2998 CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2, 2999 1 IFUNC2,N2,IBUGA3,IFOUND,IERROR) 3000 IF(IERROR.EQ.'YES')GOTO9000 3001 IF(IFOUND.EQ.'YES')GOTO3500 3002C 3003 IWD1=IHARG(3) 3004 IWD12=IHARG2(3) 3005 IWD2='FOR ' 3006 IWD22=' ' 3007 CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2, 3008 1 IFUNC2,N2,IBUGA3,IFOUND,IERROR) 3009 IF(IERROR.EQ.'YES')GOTO9000 3010 IF(IFOUND.EQ.'YES')GOTO3500 3011C 3012 WRITE(ICOUT,999) 3013 CALL DPWRST('XXX','BUG ') 3014 WRITE(ICOUT,2201) 3015 CALL DPWRST('XXX','BUG ') 3016 WRITE(ICOUT,3102) 3017 3102 FORMAT(' INVALID COMMAND FORM FOR ROOT-FINDING.') 3018 CALL DPWRST('XXX','BUG ') 3019 WRITE(ICOUT,3103) 3020 3103 FORMAT(' GENERAL FORM--') 3021 CALL DPWRST('XXX','BUG ') 3022 WRITE(ICOUT,3104) 3023 3104 FORMAT(' LET ... = ROOTS ... WRT ... ', 3024 1 'FOR ... = ... TO ...') 3025 CALL DPWRST('XXX','BUG ') 3026 WRITE(ICOUT,3105) 3027 3105 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') 3028 CALL DPWRST('XXX','BUG ') 3029 IF(IWIDTH.GE.1)THEN 3030 WRITE(ICOUT,3106)(IANS(I),I=1,MIN(100,IWIDTH)) 3031 3106 FORMAT(' ',100A1) 3032 CALL DPWRST('XXX','BUG ') 3033 ENDIF 3034 IERROR='YES' 3035 GOTO9000 3036C 3037 3500 CONTINUE 3038C 3039C ***************************************************** 3040C ** STEP 3.2-- ** 3041C ** DETERMINE IF THE RIGHT-HAND SIDE IS ** 3042C ** IN FUNCTION FORM OR IS IN EQUATION FORM. ** 3043C ** IF IN EQUATION FORM, CONVERT TO FUNCTION FORM ** 3044C ** BY REPLACING THE EQUAL SIGN BY A MINUS SIGN ** 3045C ** AND ENCLOSING THE REST OF THE EXPRESSION IN ** 3046C ** PARENTHESES. ** 3047C ** PLACE THE OUTPUT FUNCTION BACK IN IFUNC2(.) ** 3048C ***************************************************** 3049C 3050 ISTEPN='3.2' 3051 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROOT') 3052 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3053C 3054 DO3600I=1,N2 3055 I2=I 3056 IF(IFUNC2(I).EQ.'=')THEN 3057 ILOCE2=I2 3058 IMIN=ILOCE2+1 3059 IF(IMIN.LE.N2)THEN 3060 DO3650II=IMIN,N2 3061 IREV=N2-II+IMIN 3062 IREVP1=IREV+1 3063 IFUNC2(IREVP1)=IFUNC2(IREV) 3064 3650 CONTINUE 3065 J=ILOCE2 3066 IFUNC2(J)='-' 3067 J=ILOCE2+1 3068 IFUNC2(J)='(' 3069 J=N2+2 3070 IFUNC2(J)=')' 3071 N2=J 3072 ENDIF 3073 GOTO3900 3074 ENDIF 3075 3600 CONTINUE 3076C 3077 3900 CONTINUE 3078C 3079C ******************************************************** 3080C ** STEP 4-- ** 3081C ** DETERMINE IF THE EXPRESSION HAS ANY FUNCTION NAMES** 3082C ** INBEDDED. IF SO, REPLACE THE FUNCTION NAMES BY ** 3083C ** EACH FUNCTION'S DEFINITION. DO SO REPEATEDLY ** 3084C ** UNTIL ALL FUNCTION REFERENCES HAVE BEEN ANNIHILATED* 3085C ** AND THE EXPRESSION IS LEFT ONLY WITH CONSTANTS, ** 3086C ** PARAMETERS, AND VARIABLES--NO FUNCTIONS. PLACE ** 3087C ** THE RESULTING FUNCTIONAL EXPRESSION INTO IFUNC3(.)** 3088C ******************************************************** 3089C 3090 ISTEPN='4' 3091 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROOT') 3092 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3093C 3094 IF(IFLGFB.LE.0)THEN 3095 CALL DPEXFU(IFUNC2,N2,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP, 3096 1 NUMNAM,IANS,IWIDTH,IFUNC,NUMCHF,MAXCHF,IFUNC3, 3097 1 N3,MAXN3, 3098 1 IBUGA3,IERROR) 3099 IF(IERROR.EQ.'YES')GOTO9000 3100C 3101 IF(IBUGA3.EQ.'ON')THEN 3102 WRITE(ICOUT,999) 3103 CALL DPWRST('XXX','BUG ') 3104 ILAB(1)='INPU' 3105 ILAB(2)='T FU' 3106 ILAB(3)='NCTI' 3107 ILAB(4)='ON ' 3108 ILAB(5)=' ' 3109 ILAB(6)=' = ' 3110 NUMWDL=6 3111 CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3) 3112 WRITE(ICOUT,5081)IDUMV(1),IDUMV2(1) 3113 5081 FORMAT('ROOT VARIABLE = ',A4,A4) 3114 CALL DPWRST('XXX','BUG ') 3115 ENDIF 3116C 3117 ENDIF 3118C 3119C ************************************* 3120C ** STEP 5-- ** 3121C ** EXTRACT QUALIFIER INFORMATION. ** 3122C ************************************* 3123C 3124C ************************************************** 3125C ** STEP 5.1-- ** 3126C ** DETERMINE THE DUMMY VARIABLE FOR THE ROOT. ** 3127C ************************************************** 3128C 3129 ISTEPN='5.1' 3130 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROOT') 3131 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3132C 3133 IKEY='WRT ' 3134 IKEY2=' ' 3135 ISHIFT=1 3136 ILOCA=1 3137 ILOCB=NUMARG 3138 INCLUN='NO' 3139 CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 3140 1 IHARG,IHARG2,NUMARG, 3141 1 INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE, 3142 1 IUSE,IN,NUMNAM, 3143 1 IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT, 3144 1 IVOUT,VOUT,IUOUT, 3145 1 INOUT,IBUGA3,IERROR) 3146 IF(IFOUN1.EQ.'YES'.AND.IFOUN2.EQ.'YES')THEN 3147 IDUMV(1)=IHOUT 3148 IDUMV2(1)=IHOUT2 3149 NUMDV=1 3150 GOTO5190 3151 ENDIF 3152C 3153 IKEY='FOR ' 3154 IKEY2=' ' 3155 ISHIFT=1 3156 ILOCA=1 3157 ILOCB=NUMARG 3158 INCLUN='NO' 3159 CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,IHARG,IHARG2,NUMARG, 3160 1 INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE, 3161 1 IUSE,IN,NUMNAM, 3162 1 IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT, 3163 1 IVOUT,VOUT,IUOUT, 3164 1 INOUT,IBUGA3,IERROR) 3165 IF(IFOUN1.EQ.'YES'.AND.IFOUN2.EQ.'YES')THEN 3166 IDUMV(1)=IHOUT 3167 IDUMV2(1)=IHOUT2 3168 NUMDV=1 3169 GOTO5190 3170 ENDIF 3171C 3172 WRITE(ICOUT,999) 3173 CALL DPWRST('XXX','BUG ') 3174 WRITE(ICOUT,2201) 3175 CALL DPWRST('XXX','BUG ') 3176 WRITE(ICOUT,5182) 3177 5182 FORMAT(' INVALID COMMAND FORM FOR ROOT-FINDING.') 3178 CALL DPWRST('XXX','BUG ') 3179 WRITE(ICOUT,5183) 3180 5183 FORMAT(' NO VARIABLE FOR ROOT-FINDING DEFINED.') 3181 CALL DPWRST('XXX','BUG ') 3182 WRITE(ICOUT,3102) 3183 CALL DPWRST('XXX','BUG ') 3184 WRITE(ICOUT,3103) 3185 CALL DPWRST('XXX','BUG ') 3186 WRITE(ICOUT,3104) 3187 CALL DPWRST('XXX','BUG ') 3188 WRITE(ICOUT,3105) 3189 CALL DPWRST('XXX','BUG ') 3190 IF(IWIDTH.GE.1)THEN 3191 WRITE(ICOUT,3106)(IANS(I),I=1,MIN(100,IWIDTH)) 3192 CALL DPWRST('XXX','BUG ') 3193 ENDIF 3194 IERROR='YES' 3195 GOTO9000 3196 5190 CONTINUE 3197C 3198C ************************************************** 3199C ** STEP 5.2-- ** 3200C ** DETERMINE THE LIMITS FOR THE ROOTS. ** 3201C ************************************************** 3202C 3203 ISTEPN='5.2' 3204 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROOT') 3205 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3206C 3207 NUMLIM=0 3208C 3209 IKEY='FOR ' 3210 IKEY2=' ' 3211 ISHIFT=3 3212 ILOCA=1 3213 ILOCB=NUMARG 3214 INCLUN='NO' 3215 CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 3216 1 IHARG,IHARG2,NUMARG, 3217 1 INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE, 3218 1 IUSE,IN,NUMNAM, 3219 1 IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT, 3220 1 IVOUT,VOUT,IUOUT, 3221 1 INOUT,IBUGA3,IERROR) 3222 IF(IFOUN1.EQ.'YES'.AND.IFOUN2.EQ.'YES')THEN 3223 XMIN=VOUT 3224 NUMLIM=NUMLIM+1 3225 ENDIF 3226C 3227 IKEY='FOR ' 3228 IKEY2=' ' 3229 ISHIFT=4 3230 ILOCA=1 3231 ILOCB=NUMARG 3232 INCLUN='NO' 3233 CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 3234 1 IHARG,IHARG2,NUMARG, 3235 1 INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE, 3236 1 IUSE,IN,NUMNAM, 3237 1 IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT, 3238 1 IVOUT,VOUT,IUOUT, 3239 1 INOUT,IBUGA3,IERROR) 3240 IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5239 3241 IF(IHOUT.EQ.'TO '.AND.IHOUT2.EQ.' ')GOTO5229 3242 XMAX=VOUT 3243 ILOCMX=ILOC2 3244 NUMLIM=NUMLIM+1 3245 5229 CONTINUE 3246C 3247 IF(NUMLIM.EQ.2)GOTO5239 3248 IKEY='FOR ' 3249 IKEY2=' ' 3250 ISHIFT=5 3251 ILOCA=1 3252 ILOCB=NUMARG 3253 INCLUN='NO' 3254 CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 3255 1 IHARG,IHARG2,NUMARG, 3256 1 INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE, 3257 1 IN,NUMNAM, 3258 1 IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT, 3259 1 VOUT,IUOUT, 3260 1 INOUT,IBUGA3,IERROR) 3261 IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5239 3262 XMAX=VOUT 3263 ILOCMX=ILOC2 3264 NUMLIM=NUMLIM+1 3265 5239 CONTINUE 3266C 3267 IF(NUMLIM.NE.2)THEN 3268 WRITE(ICOUT,999) 3269 CALL DPWRST('XXX','BUG ') 3270 WRITE(ICOUT,2201) 3271 CALL DPWRST('XXX','BUG ') 3272 WRITE(ICOUT,5182) 3273 CALL DPWRST('XXX','BUG ') 3274 IF(NUMLIM.EQ.0)THEN 3275 WRITE(ICOUT,5283) 3276 5283 FORMAT(' NO LIMITS FOR ROOT-FINDING DEFINED.') 3277 ELSEIF(NUMLIM.EQ.1)THEN 3278 WRITE(ICOUT,5284) 3279 5284 FORMAT(' ONLY ONE LIMIT FOR ROOT-FINDING DEFINED.') 3280 ELSE 3281 WRITE(ICOUT,5285)NUMLIM 3282 5285 FORMAT(' NUMBER OF LIMITS DEFINED = ',I8) 3283 ENDIF 3284 CALL DPWRST('XXX','BUG ') 3285 WRITE(ICOUT,3102) 3286 CALL DPWRST('XXX','BUG ') 3287 WRITE(ICOUT,3103) 3288 CALL DPWRST('XXX','BUG ') 3289 WRITE(ICOUT,3104) 3290 CALL DPWRST('XXX','BUG ') 3291 WRITE(ICOUT,3105) 3292 CALL DPWRST('XXX','BUG ') 3293 IF(IWIDTH.GE.1)THEN 3294 WRITE(ICOUT,3106)(IANS(I),I=1,MIN(100,IWIDTH)) 3295 CALL DPWRST('XXX','BUG ') 3296 ENDIF 3297 IERROR='YES' 3298 GOTO9000 3299 ENDIF 3300C 3301C ********************************************** 3302C ** STEP 6.3-- ** 3303C ** SCAN THE QUALIFIERS FOR VARIABLE, ** 3304C ** PARAMETER, FUNCTION, AND VALUE CHANGES ** 3305C ** IN THE FUNCTION. ** 3306C ********************************************** 3307C 3308 ISTEPN='6.3' 3309 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROOT') 3310 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3311C 3312 NCHANG=0 3313 DO6300IFORI=1,10 3314C 3315 IKEY='FOR ' 3316 IKEY2=' ' 3317 ISHIFT=1 3318 IF(IFORI.EQ.1)ILOCA=ILOCMX 3319 IF(IFORI.NE.1)ILOCA=ILOC3 3320 ILOCB=NUMARG 3321 INCLUN='NO' 3322 CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 3323 1 IHARG,IHARG2,NUMARG, 3324 1 INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE, 3325 1 VALUE,IUSE,IN,NUMNAM, 3326 1 IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT, 3327 1 IVOUT,VOUT,IUOUT, 3328 1 INOUT,IBUGA3,IERROR) 3329 IF(IERROR.EQ.'YES')GOTO6380 3330 IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO6390 3331C 3332 ILOC3=ILOC2+2 3333 IF(ILOC3.GT.NUMARG)GOTO6380 3334 NCHANG=NCHANG+1 3335 IOLD(NCHANG)=IHARG(ILOC2) 3336 IOLD2(NCHANG)=IHARG2(ILOC2) 3337 INEW(NCHANG)=IHARG(ILOC3) 3338 INEW2(NCHANG)=IHARG2(ILOC3) 3339C 3340 6300 CONTINUE 3341 GOTO6390 3342C 3343 6380 CONTINUE 3344 WRITE(ICOUT,999) 3345 CALL DPWRST('XXX','BUG ') 3346 WRITE(ICOUT,2201) 3347 CALL DPWRST('XXX','BUG ') 3348 WRITE(ICOUT,3102) 3349 CALL DPWRST('XXX','BUG ') 3350 WRITE(ICOUT,3103) 3351 CALL DPWRST('XXX','BUG ') 3352 WRITE(ICOUT,3104) 3353 CALL DPWRST('XXX','BUG ') 3354 WRITE(ICOUT,3105) 3355 CALL DPWRST('XXX','BUG ') 3356 IF(IWIDTH.GE.1)THEN 3357 WRITE(ICOUT,3106)(IANS(I),I=1,MIN(100,IWIDTH)) 3358 CALL DPWRST('XXX','BUG ') 3359 ENDIF 3360 IERROR='YES' 3361 GOTO9000 3362C 3363 6390 CONTINUE 3364C 3365C ********************************************** 3366C ** STEP 6.4-- ** 3367C ** CARRY OUT THE VARIABLE, ** 3368C ** PARAMETER, AND FUNCTION CHANGES ** 3369C ** AND THEN PRINT OUT A BRIEF MESSAGE ** 3370C ** INDICATING THAT THE CHANGES ** 3371C ** HAVE BEEN MADE. ** 3372C ********************************************** 3373C 3374 ISTEPN='6.4' 3375 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROOT') 3376 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3377C 3378 IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON' .AND. NCHANG.GT.0 .AND. 3379 1 IFLGFB.LE.0)THEN 3380C 3381 WRITE(ICOUT,999) 3382 CALL DPWRST('XXX','BUG ') 3383 ILAB(1)='PRE ' 3384 ILAB(2)='-CHA' 3385 ILAB(3)='NGE ' 3386 ILAB(4)='FUNC' 3387 ILAB(5)='TION' 3388 ILAB(6)=' = ' 3389 NUMWDL=6 3390 CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3) 3391C 3392 CALL COMPIC(IFUNC3,N3,IOLD,IOLD2,INEW,INEW2,NCHANG,IFUNC3,N3, 3393 1 IBUGA3,IERROR) 3394 IF(IERROR.EQ.'YES')GOTO9000 3395C 3396 ILAB(1)='POST' 3397 ILAB(2)='-CHA' 3398 ILAB(3)='NGE ' 3399 ILAB(4)='FUNC' 3400 ILAB(5)='TION' 3401 ILAB(6)=' = ' 3402 NUMWDL=6 3403 CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3) 3404C 3405 ENDIF 3406C 3407C ******************************************************** 3408C ** STEP 6.7-- ** 3409C ** MAKE A NON-CALCULATING PASS AT THE FUNCTION SO AS ** 3410C ** TO EXTRACT ALL PARAMETER AND VARIABLE NAMES. ** 3411C ******************************************************** 3412C 3413 ISTEPN='6.8' 3414 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROOT') 3415 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3416C 3417 IPASS=1 3418 IF(IFLGFB.LE.0)THEN 3419 CALL COMPIM(IFUNC3,N3,IPASS,PARAM,IPARN,IPARN2,NUMPV, 3420 1 IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,AJUNK, 3421 1 IBUGCO,IBUGEV,IERROR) 3422 IF(IERROR.EQ.'YES')GOTO9000 3423 ELSE 3424 GOTO7701 3425 ENDIF 3426C 3427C *********************************************** 3428C ** STEP 7-- ** 3429C ** CHECK THAT ALL PARAMETERS ** 3430C ** IN THE FUNCTION ARE ALREADY PRESENT ** 3431C ** IN THE AVAILABLE NAME LIST IHNAME(.). ** 3432C ** ALSO CHECK THAT THE VARIABLE NAME ** 3433C ** THAT FOLLOWS FOR (THAT IS, THE DUMMY ** 3434C ** VARIABLE IS IN THE FUNCTION. ** 3435C ** NOTE--ALL PARAMETERS AND VARIABLES ** 3436C ** THAT ARE NOT FOUND IN IHNAME(.) ** 3437C ** WILL BE AUTOMATICALLY SET TO 0.0 ** 3438C ** (BUT ONLY TEMPORARILY); ** 3439C ** THIS CONVENTION ALLOWS AN AUTOMATIC ** 3440C ** SOLUTION TO THE PROBLEM OF SOLVING ** 3441C ** FOR ROOTS OF EQUATIONS ** 3442C ** (AS OPPOSED TO FUNCTIONS) ** 3443C ** SINCE 'Y' WILL TYPICALLY BE SET TO ZERO ** 3444C ** AS ONE WOULD WANT FOR SOLVING ** 3445C ** FOR A ROOT (= A FUNCTION ZERO). ** 3446C *********************************************** 3447C 3448 ISTEPN='7' 3449 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROOT') 3450 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3451C 3452 IP=0 3453 IV=0 3454 IF(NUMPV.GT.0)THEN 3455 DO7600J=1,NUMPV 3456 IHPARN=IPARN(J) 3457 IHPAR2=IPARN2(J) 3458 IF(IHPARN.EQ.IDUMV(1).AND.IHPAR2.EQ.IDUMV2(1))THEN 3459 IV=IV+1 3460 LOCDUM=J 3461 ELSE 3462 IHWUSE='P' 3463 MESSAG='YES' 3464 CALL CHECKN(IHPARN,IHPAR2,IHWUSE, 3465 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE, 3466 1 NUMNAM,MAXNAM, 3467 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) 3468 IF(IERRO2.EQ.'YES')THEN 3469 IP=IP+1 3470 PARAM(J)=0.0 3471 WRITE(ICOUT,999) 3472 CALL DPWRST('XXX','BUG ') 3473 WRITE(ICOUT,7606)IHPARN,IHPAR2 3474 7606 FORMAT('NOTE--',A4,A4,' HAS BEEN TEMPORARILY SET TO ZERO') 3475 CALL DPWRST('XXX','BUG ') 3476 WRITE(ICOUT,7607) 3477 7607 FORMAT(' FOR THE ROOT-FINDING PROCESS.') 3478 CALL DPWRST('XXX','BUG ') 3479 ENDIF 3480 IP=IP+1 3481 PARAM(J)=VALUE(ILOCP) 3482 ENDIF 3483 7600 CONTINUE 3484 ENDIF 3485C 3486C ****************************** 3487C ** STEP 8-- ** 3488C ** DETERMINE THE ROOTS . ** 3489C ****************************** 3490C 3491 7701 CONTINUE 3492C 3493 ISTEPN='8' 3494 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROOT')THEN 3495 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3496 WRITE(ICOUT,999) 3497 CALL DPWRST('XXX','BUG ') 3498 WRITE(ICOUT,7711) 3499 7711 FORMAT('***** FROM DPROOT, IMMEDIATELY BEFORE CALLING ', 3500 1 'ROOTS--') 3501 CALL DPWRST('XXX','BUG ') 3502 WRITE(ICOUT,7712)N3,NUMPV 3503 7712 FORMAT('N3,NUMPV = ',I8,I8) 3504 CALL DPWRST('XXX','BUG ') 3505 WRITE(ICOUT,7713)NUMDV,XMIN,XMAX 3506 7713 FORMAT('NUMDV,XMIN,XMAX = ',I8,2G15.7) 3507 CALL DPWRST('XXX','BUG ') 3508 DO7714I=1,NUMDV 3509 WRITE(ICOUT,7715)I,IDUMV(I),IDUMV2(I) 3510 7715 FORMAT('I,IDUMV(I),IDUMV2(I) = ',I8,2X,A4,A4) 3511 CALL DPWRST('XXX','BUG ') 3512 7714 CONTINUE 3513 ENDIF 3514C 3515 CALL DPROO2(IFUNC3,N3,PARAM,IPARN,IPARN2,NUMPV, 3516 1 IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 3517 1 IDUMV,IDUMV2,NUMDV,XMIN,XMAX,ROOTS2,NROOTS, 3518 1 ROOTAC,IFLGFB, 3519 1 IHNAME,IHNAM2,IUSE,IVALUE,VALUE, 3520 1 NUMNAM,MAXNAM,MAXCOL,IFTEXP,IFTORD,IFORSW, 3521 1 PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,V,MAXN, 3522 1 ISUBRO,IBUGA3,IBUGCO,IBUGEV,IERROR) 3523 AROOTS=NROOTS 3524C 3525C ***************************************** 3526C ** STEP 9-- ** 3527C ** ENTER THE ROOTS INTO THE DATAPLOT ** 3528C ** ARRAY V(.). ** 3529C ** ENTER THE FOUND NUMBER OF ROOTS ** 3530C ** INTO THE DATAPLOT PARAMETER ** 3531C ** NROOTS . ** 3532C ***************************************** 3533C 3534 ISTEPN='9' 3535 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROOT') 3536 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3537C 3538 IHL=IHLEFT 3539 IHL2=IHLEF2 3540 ICASUP='V' 3541 CALL DPINVP(IHL,IHL2,ICASUP,ROOTS2,NROOTS,AROOTS,NROOTS, 3542 1ISUBN1,ISUBN2,IBUGA3,IERROR) 3543C 3544 IHL='NROO' 3545 IHL2='TS ' 3546 ICASUP='P' 3547 CALL DPINVP(IHL,IHL2,ICASUP,ROOTS2,NROOTS,AROOTS,NROOTS, 3548 1ISUBN1,ISUBN2,IBUGA3,IERROR) 3549C 3550C **************** 3551C ** STEP 90-- ** 3552C ** EXIT ** 3553C **************** 3554C 3555 9000 CONTINUE 3556 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROOT')THEN 3557 WRITE(ICOUT,999) 3558 CALL DPWRST('XXX','BUG ') 3559 WRITE(ICOUT,9011) 3560 9011 FORMAT('***** AT THE END OF DPROOT--') 3561 CALL DPWRST('XXX','BUG ') 3562 DO9015I=1,NUMNAM 3563 WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I), 3564 1 IVSTAR(I),IVSTOP(I) 3565 9016 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I)=', 3566 1 I8,2X,A4,A4,2X,A4,I8,I8) 3567 CALL DPWRST('XXX','BUG ') 3568 9015 CONTINUE 3569 WRITE(ICOUT,9017)NUMCHF,MAXCHF,IWIDTH,N2,N3,NUMPV,IFLGFB 3570 9017 FORMAT('NUMCHF,MAXCHF,IWIDTH,N2,N3,NUMPV,IFLGFB = ',7I8) 3571 CALL DPWRST('XXX','BUG ') 3572 WRITE(ICOUT,9018)(IFUNC(I),I=1,MIN(115,IWIDTH)) 3573 9018 FORMAT('IFUNC(.) = ',115A1) 3574 CALL DPWRST('XXX','BUG ') 3575 WRITE(ICOUT,9019)(IFUNC2(I),I=1,MIN(115,N2)) 3576 9019 FORMAT('IFUNC2(.) = ',115A1) 3577 CALL DPWRST('XXX','BUG ') 3578 WRITE(ICOUT,9021)(IFUNC3(I),I=1,MIN(120,N3)) 3579 9021 FORMAT('IFUNC3(.) = ',120A1) 3580 CALL DPWRST('XXX','BUG ') 3581 WRITE(ICOUT,9023)IHLEFT,IHLEF2 3582 9023 FORMAT('IHLEFT,IHLEF2 = ',A4,A4) 3583 CALL DPWRST('XXX','BUG ') 3584 WRITE(ICOUT,9024)ICASUP,IFOUND,IERROR 3585 9024 FORMAT('ICASUP,IFOUND,IERROR = ',2(A4,2X),A4) 3586 CALL DPWRST('XXX','BUG ') 3587 WRITE(ICOUT,9025)XMIN,XMAX,NROOTS 3588 9025 FORMAT('XMIN,XMAX,NROOTS = ',2G15.7,I8) 3589 CALL DPWRST('XXX','BUG ') 3590 DO9027I=1,NROOTS 3591 WRITE(ICOUT,9028)I,ROOTS2(I) 3592 9028 FORMAT('I,ROOTS2(I) = ',I8,G15.7) 3593 CALL DPWRST('XXX','BUG ') 3594 9027 CONTINUE 3595 ENDIF 3596C 3597 RETURN 3598 END 3599 SUBROUTINE DPROSE(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 3600 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 3601C 3602C PURPOSE--GENERATE A ROSE PLOT (A VARIATION OF A ROSE PLOT): 3603C ROSE PLOT Y 3604C ROSE PLOT Y1 Y2 3605C REFERENCE--WAINER (1997), "VISUAL REVELATIONS: GRAPHICAL 3606C TALES OF FATE AND DECEPTION FROM NAPOLEAN BONAPORTE 3607C TO ROSS PEROT", COPERNICUS, CHAPTER 11. 3608C WRITTEN BY--ALAN HECKERT 3609C STATISTICAL ENGINEERING DIVISION 3610C INFORMATION TECHNOLOGY LABORATORY 3611C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 3612C GAITHERSBURG, MD 20899-8980 3613C PHONE--301-75-2899 3614C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 3615C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 3616C LANGUAGE--ANSI FORTRAN (1977) 3617C VERSION NUMBER--2007/4 3618C ORIGINAL VERSION--APRIL 2007. 3619C UPDATED --APRIL 2011. USE DPPARS AND DPPAR3 3620C 3621C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 3622C 3623 CHARACTER*4 ICASPL 3624 CHARACTER*4 IAND1 3625 CHARACTER*4 IAND2 3626 CHARACTER*4 IBUGG2 3627 CHARACTER*4 IBUGG3 3628 CHARACTER*4 IBUGQ 3629 CHARACTER*4 ISUBRO 3630 CHARACTER*4 IFOUND 3631 CHARACTER*4 IERROR 3632C 3633 CHARACTER*4 ISUBN1 3634 CHARACTER*4 ISUBN2 3635 CHARACTER*4 ISTEPN 3636C 3637 CHARACTER*4 ICASE 3638 PARAMETER (MAXSPN=10) 3639 CHARACTER*40 INAME 3640 CHARACTER*4 IVARN1(MAXSPN) 3641 CHARACTER*4 IVARN2(MAXSPN) 3642 CHARACTER*4 IVARTY(MAXSPN) 3643 REAL PVAR(MAXSPN) 3644 INTEGER ILIS(MAXSPN) 3645 INTEGER NRIGHT(MAXSPN) 3646 INTEGER ICOLR(MAXSPN) 3647C 3648C--------------------------------------------------------------------- 3649C 3650 INCLUDE 'DPCOPA.INC' 3651C 3652 DIMENSION Y1(MAXOBV) 3653 DIMENSION Y2(MAXOBV) 3654 DIMENSION X1(MAXOBV) 3655 DIMENSION XIDTEM(MAXOBV) 3656 DIMENSION TEMP1(MAXOBV) 3657 DIMENSION TEMP2(MAXOBV) 3658 INCLUDE 'DPCOZZ.INC' 3659 EQUIVALENCE (GARBAG(IGARB1),Y1(1)) 3660 EQUIVALENCE (GARBAG(IGARB2),Y2(1)) 3661 EQUIVALENCE (GARBAG(IGARB3),X1(1)) 3662 EQUIVALENCE (GARBAG(IGARB4),XIDTEM(1)) 3663 EQUIVALENCE (GARBAG(IGARB5),TEMP1(1)) 3664 EQUIVALENCE (GARBAG(IGARB6),TEMP2(1)) 3665C 3666C-----COMMON---------------------------------------------------------- 3667C 3668 INCLUDE 'DPCOHK.INC' 3669 INCLUDE 'DPCODA.INC' 3670 INCLUDE 'DPCOP2.INC' 3671C 3672C-----START POINT----------------------------------------------------- 3673C 3674 IFOUND='NO' 3675 IERROR='NO' 3676 ISUBN1='DPRO' 3677 ISUBN2='SE ' 3678C 3679 MAXCP1=MAXCOL+1 3680 MAXCP2=MAXCOL+2 3681 MAXCP3=MAXCOL+3 3682 MAXCP4=MAXCOL+4 3683 MAXCP5=MAXCOL+5 3684 MAXCP6=MAXCOL+6 3685C 3686C *************************** 3687C ** TREAT THE ROSE PLOT ** 3688C *************************** 3689C 3690 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'ROSE')THEN 3691 WRITE(ICOUT,999) 3692 CALL DPWRST('XXX','BUG ') 3693 WRITE(ICOUT,51) 3694 51 FORMAT('***** AT THE BEGINNING OF DPROSE--') 3695 CALL DPWRST('XXX','BUG ') 3696 WRITE(ICOUT,52)ICASPL,IAND1,IAND2 3697 52 FORMAT('ICASPL,IAND1,IAND2 = ',2(A4,2X),A4) 3698 CALL DPWRST('XXX','BUG ') 3699 WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO 3700 53 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4) 3701 CALL DPWRST('XXX','BUG ') 3702 ENDIF 3703C 3704C *************************** 3705C ** STEP 1-- ** 3706C ** EXTRACT THE COMMAND ** 3707C *************************** 3708C 3709 ISTEPN='1' 3710 IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3711C 3712 IF(NUMARG.GE.1.AND. 3713 1 ICOM.EQ.'ROSE'.AND.IHARG(1).EQ.'PLOT')THEN 3714 ILASTC=1 3715 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 3716 ELSE 3717 GOTO9000 3718 ENDIF 3719C 3720 IFOUND='YES' 3721 ICASPL='PIEC' 3722C 3723C **************************************** 3724C ** STEP 2-- ** 3725C ** EXTRACT THE VARIABLE LIST ** 3726C **************************************** 3727C 3728 ISTEPN='2' 3729 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ROSE') 3730 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3731C 3732 INAME='ROSE PLOT' 3733 MINNA=1 3734 MAXNA=100 3735 MINN2=2 3736 IFLAGE=1 3737 IFLAGM=0 3738 IFLAGP=0 3739 JMIN=1 3740 JMAX=NUMARG 3741 MINNVA=1 3742 MAXNVA=2 3743C 3744 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 3745 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 3746 1 JMIN,JMAX, 3747 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 3748 1 IVARN1,IVARN2,IVARTY,PVAR, 3749 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 3750 1 MINNVA,MAXNVA, 3751 1 IFLAGM,IFLAGP, 3752 1 IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 3753 IF(IERROR.EQ.'YES')GOTO9000 3754C 3755 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ROSE')THEN 3756 WRITE(ICOUT,999) 3757 CALL DPWRST('XXX','BUG ') 3758 WRITE(ICOUT,281) 3759 281 FORMAT('***** AFTER CALL DPPARS--') 3760 CALL DPWRST('XXX','BUG ') 3761 WRITE(ICOUT,282)NQ,NUMVAR 3762 282 FORMAT('NQ,NUMVAR = ',2I8) 3763 CALL DPWRST('XXX','BUG ') 3764 IF(NUMVAR.GT.0)THEN 3765 DO285I=1,NUMVAR 3766 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 3767 1 ICOLR(I) 3768 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 3769 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 3770 CALL DPWRST('XXX','BUG ') 3771 285 CONTINUE 3772 ENDIF 3773 ENDIF 3774C 3775C EXTRACT THE VARIABLE. 3776C 3777 ICOL=1 3778 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 3779 1 INAME,IVARN1,IVARN2,IVARTY, 3780 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 3781 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 3782 1 MAXCP4,MAXCP5,MAXCP6, 3783 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 3784 1 Y1,Y2,Y1,NLOCAL,NS,NS,ICASE, 3785 1 IBUGG3,ISUBRO,IFOUND,IERROR) 3786 IF(IERROR.EQ.'YES')GOTO9000 3787C 3788C ***************************************************** 3789C ** STEP 8-- ** 3790C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** 3791C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** 3792C ** RESET THE VECTOR D(.) TO ALL ONES. ** 3793C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** 3794C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** 3795C ***************************************************** 3796C 3797 CALL DPROS2(Y1,Y2,X1,NLOCAL,NUMVAR, 3798 1 XIDTEM,TEMP1,TEMP2, 3799 1 Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 3800C 3801C ***************** 3802C ** STEP 90-- ** 3803C ** EXIT ** 3804C ***************** 3805C 3806 9000 CONTINUE 3807 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'ROSE')THEN 3808 WRITE(ICOUT,999) 3809 999 FORMAT(1X) 3810 CALL DPWRST('XXX','BUG ') 3811 WRITE(ICOUT,9011) 3812 9011 FORMAT('***** AT THE END OF DPROSE--') 3813 CALL DPWRST('XXX','BUG ') 3814 WRITE(ICOUT,9012)IFOUND,IERROR 3815 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 3816 CALL DPWRST('XXX','BUG ') 3817 WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 3818 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 3819 1 I8,I8,I8,2X,A4,2X,A4,2X,A4) 3820 CALL DPWRST('XXX','BUG ') 3821 IF(NPLOTP.GT.0)THEN 3822 DO9015I=1,NPLOTP 3823 WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 3824 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) 3825 CALL DPWRST('XXX','BUG ') 3826 9015 CONTINUE 3827 ENDIF 3828 ENDIF 3829C 3830 RETURN 3831 END 3832 SUBROUTINE DPROS2(Y1,Y2,X,N,NUMV2, 3833 1 XIDTEM,XIDTE2,TEMP1, 3834 1 YPLOT,XPLOT,D2,NPLOTP,NPLOTV, 3835 1 IBUGG3,ISUBRO,IERROR) 3836C 3837C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS 3838C THAT WILL DEFINE A ROSE PLOT 3839C REFERENCE--WAINER (1997), "VISUAL REVELATIONS: GRAPHICAL 3840C TALES OF FATE AND DECEPTION FROM NAPOLEAN BONAPORTE 3841C TO ROSS PEROT", COPERNICUS, CHAPTER 11. 3842C WRITTEN BY--ALAN HECKERT 3843C STATISTICAL ENGINEERING DIVISION 3844C INFORMATION TECHNOLOGY LABORATORY 3845C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 3846C GAITHERSBURG, MD 20899-8980 3847C PHONE--301-975-2899 3848C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 3849C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 3850C LANGUAGE--ANSI FORTRAN (1977) 3851C VERSION NUMBER--2007/4 3852C ORIGINAL VERSION--APRIL 2007. 3853C 3854C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 3855C 3856 CHARACTER*4 ISUBRO 3857 CHARACTER*4 IBUGG3 3858 CHARACTER*4 IERROR 3859C 3860 CHARACTER*4 IWRITE 3861 CHARACTER*4 ISTEPN 3862 CHARACTER*4 ISUBN1 3863 CHARACTER*4 ISUBN2 3864C 3865C--------------------------------------------------------------------- 3866C 3867 DIMENSION Y1(*) 3868 DIMENSION Y2(*) 3869 DIMENSION X(*) 3870 DIMENSION YPLOT(*) 3871 DIMENSION XPLOT(*) 3872 DIMENSION D2(*) 3873 DIMENSION XIDTEM(*) 3874 DIMENSION XIDTE2(*) 3875 DIMENSION TEMP1(*) 3876C 3877C--------------------------------------------------------------------- 3878C 3879 INCLUDE 'DPCOP2.INC' 3880C 3881C-----DATA STATEMENTS------------------------------------------------- 3882C 3883 DATA PI/3.1415926535878/ 3884C 3885C-----START POINT----------------------------------------------------- 3886C 3887 ISUBN1='DPRO' 3888 ISUBN2='S2 ' 3889 IERROR='NO' 3890C 3891C ******************************************** 3892C ** STEP 1-- ** 3893C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 3894C ******************************************** 3895C 3896 IF(N.LE.1)THEN 3897 WRITE(ICOUT,999) 3898 999 FORMAT(1X) 3899 CALL DPWRST('XXX','BUG ') 3900 WRITE(ICOUT,31) 3901 31 FORMAT('***** ERROR IN ROSE PLOT--') 3902 CALL DPWRST('XXX','BUG ') 3903 WRITE(ICOUT,32) 3904 32 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2;') 3905 CALL DPWRST('XXX','BUG ') 3906 WRITE(ICOUT,34)N 3907 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) 3908 CALL DPWRST('XXX','BUG ') 3909 WRITE(ICOUT,999) 3910 CALL DPWRST('XXX','BUG ') 3911 IERROR='YES' 3912 GOTO9000 3913 ENDIF 3914C 3915 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ROS2')THEN 3916 WRITE(ICOUT,999) 3917 CALL DPWRST('XXX','BUG ') 3918 WRITE(ICOUT,70) 3919 70 FORMAT('***** AT THE BEGINNING OF DPROS2--') 3920 CALL DPWRST('XXX','BUG ') 3921 WRITE(ICOUT,71)NUMV2,N 3922 71 FORMAT('NUMV2,N = ',2I8) 3923 CALL DPWRST('XXX','BUG ') 3924 DO73I=1,MIN(N,100) 3925 WRITE(ICOUT,74)I,Y1(I),Y2(I) 3926 74 FORMAT('I, Y1(I),Y2(I) = ',I8,3G15.7) 3927 CALL DPWRST('XXX','BUG ') 3928 73 CONTINUE 3929 ENDIF 3930C 3931C ******************************************* 3932C ** STEP 4-- ** 3933C ** DETERMINE PLOT COORDINATES ** 3934C ** THREE CASES: ** 3935C ** 1) ONE VARIABLE ** 3936C ** 2) TWO VARIABLE - CROSS-TABULATE ** 3937C ** (IN PARTICULAR 2X2 TABLES ** 3938C ** 3) THREE VARIABLE - CROSS-TABULATE ** 3939C ** FIRST TWO VARIABLES, THRID ** 3940C ** VARIABLE IS A GROUP-ID VARIABLE ** 3941C ** (ONE ROSE PLOT WILL BE ** 3942C ** GENERATED FOR EACH GROUP) ** 3943C ******************************************* 3944C 3945 IF(NUMV2.EQ.1)THEN 3946 GOTO1000 3947 ELSEIF(NUMV2.EQ.2)THEN 3948 GOTO2000 3949 ELSE 3950 GOTO9000 3951 ENDIF 3952C 3953C THIS PLOT USES THE RELATIONSHIPS: 3954C 3955C X = R*COS(THETA) 3956C Y = R*SIN(THETA) 3957C 3958C IN THE STANDARD PIE CHART, THE ANGLE IS PROPORTIONAL 3959C TO THE DATA VALUE, WE CENTER THE CIRCLE AT (0,0) AND WE 3960C SET R = 1. FOR THE ROSE PLOT, THE ANGLES ARE CONSTANT 3961C AND WE MAKE THE SQUARE ROOT OF THE RADIUS PROPORTIONAL 3962C TO THE DATA VALUE (SCALE SO THAT THE LARGEST DATA VALUE 3963C HAS R = 1). THE ROSE PLOT WILL ALSO BE CENTERED AT (0,0). 3964C 3965 1000 CONTINUE 3966C 3967C FOR THE SINGLE VARIABLE CASE, THE VALUES ARE INTERPRETED 3968C AS PROPORTIONS OR COUNTS (I.E., THE VALUE DIVIDED BY THE 3969C SUM OF THE VALUES GIVES THE PROPORTION FOR THAT GROUP). SO 3970C NEGATIVE VALUES ARE NOT ALLOWED. 3971C 3972 DO1010I=1,N 3973 IF(Y1(I).LT.0.0)THEN 3974 WRITE(ICOUT,999) 3975 CALL DPWRST('XXX','BUG ') 3976 WRITE(ICOUT,31) 3977 CALL DPWRST('XXX','BUG ') 3978 WRITE(ICOUT,1012) 3979 1012 FORMAT(' A NEGATIVE PROPORTION/COUNT WAS ENCOUNTERED.') 3980 CALL DPWRST('XXX','BUG ') 3981 WRITE(ICOUT,1014)I,Y1(I) 3982 1014 FORMAT(' ROW ',I8,' = ',G15.7) 3983 CALL DPWRST('XXX','BUG ') 3984 WRITE(ICOUT,999) 3985 CALL DPWRST('XXX','BUG ') 3986 IERROR='YES' 3987 GOTO9000 3988 ENDIF 3989 1010 CONTINUE 3990C 3991 NUMCLA=N 3992 ANGINC=2.0*PI/REAL(NUMCLA) 3993C 3994 YMAX=Y1(1) 3995 DO1060J=1,NUMCLA 3996 YMAX=MAX(YMAX,Y1(J)) 3997 1060 CONTINUE 3998C 3999 DO1070J=1,NUMCLA 4000 TEMP1(J)=SQRT(Y1(J)/YMAX) 4001 1070 CONTINUE 4002C 4003C NOTE: SINCE A PRIMARY APPLICATION OF THIS PLOT IS TO 4004C DISPLAY 2X2 TABLES, SCALE TO GO FROM -PI TO PI 4005C RATHER THAN 0 TO 2*PI. 4006C 4007 K=0 4008 J2=0 4009 DO1120J=1,NUMCLA 4010C 4011 R=TEMP1(J) 4012 ANGSTA=PI - (J-1)*ANGINC 4013 ANGSTO=ANGSTA-ANGINC 4014C 4015 K=K+1 4016 J2=J2+1 4017C 4018 XPLOT(K)=0.0 4019 YPLOT(K)=0.0 4020 D2(K)=J2 4021C 4022 ANG=ANGSTA 4023 K=K+1 4024 XPLOT(K)=R*COS(ANG) 4025 YPLOT(K)=R*SIN(ANG) 4026 D2(K)=J2 4027C 4028 1125 CONTINUE 4029 ANG=ANG - 0.015 4030 IF(ANG.LT.ANGSTO)THEN 4031 K=K+1 4032 XPLOT(K)=R*COS(ANGSTO) 4033 YPLOT(K)=R*SIN(ANGSTO) 4034 D2(K)=J2 4035 K=K+1 4036 XPLOT(K)=0.0 4037 YPLOT(K)=0.0 4038 D2(K)=J2 4039 GOTO1120 4040 ELSE 4041 K=K+1 4042 XPLOT(K)=R*COS(ANG) 4043 YPLOT(K)=R*SIN(ANG) 4044 D2(K)=J2 4045 ENDIF 4046C 4047 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'ROS2')THEN 4048 WRITE(ICOUT,1121)J,J2,K,ANGSTA,ANGSTO,ANG 4049 1121 FORMAT('J,J2,K,ANSTA,ANGSTO,ANG = ',3I8,3G15.7) 4050 CALL DPWRST('XXX','BUG ') 4051 WRITE(ICOUT,1123)R,XPLOT(K),YPLOT(K) 4052 1123 FORMAT('R,XPLOT(K),YPLOT(K) = ',3G15.7) 4053 CALL DPWRST('XXX','BUG ') 4054 ENDIF 4055C 4056 GOTO1125 4057C 4058 1120 CONTINUE 4059C 4060 NPLOTP=K 4061 NPLOTV=3 4062 GOTO9000 4063C 4064 2000 CONTINUE 4065C 4066C FOR THE TWO VARIABLE CASE, A CROSS-TABULATION IS PERFORMED. 4067C THIS IS MOST TYPICALLY APPLIED FOR THE CASE OF 2X2 TABLES, 4068C BUT THE CODE BELOW WILL IN FACT HANDLE RXC TABLES. IF N = 2, 4069C THEN ASSUME THAT DATA IS ENTERED AS A 2X2 TABLE: 4070C 4071C TRUE POSITIVES FALSE NEGATIVES 4072C FALSE POSITIVES TRUE NEGATIVES 4073C 4074 IF(N.LT.2)THEN 4075 WRITE(ICOUT,999) 4076 CALL DPWRST('XXX','WRIT') 4077 WRITE(ICOUT,31) 4078 CALL DPWRST('XXX','WRIT') 4079 WRITE(ICOUT,2101) 4080 2101 FORMAT(' THE NUMBER OF OBSERVATIONS FOR VARIABLE 1 ', 4081 1 'IS NON-POSITIVE') 4082 CALL DPWRST('XXX','WRIT') 4083 WRITE(ICOUT,2103)N1 4084 2103 FORMAT('SAMPLE SIZE = ',I8) 4085 CALL DPWRST('XXX','WRIT') 4086 IERROR='YES' 4087 GOTO9000 4088 ENDIF 4089C 4090 IF(N.EQ.2)THEN 4091 X(1)=Y2(1) 4092 X(2)=Y2(2) 4093 X(3)=Y1(2) 4094 X(4)=Y1(1) 4095 NUMCLA=4 4096 GOTO3000 4097 ENDIF 4098C 4099C ****************************************************** 4100C ** STEP 2.2-- ** 4101C ** DETERMINE THE NUMBER OF DISTINCT VALUES ** 4102C ** FOR THE GROUP VARIABLES (Y1, Y2). ** 4103C ****************************************************** 4104C 4105 ISTEPN='22' 4106 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'ROS2') 4107 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4108C 4109 IWRITE='OFF' 4110 CALL DISTIN(Y1,N,IWRITE,XIDTEM,NUMSE1,IBUGG3,IERROR) 4111 CALL SORT(XIDTEM,NUMSE1,XIDTEM) 4112 CALL DISTIN(Y2,N,IWRITE,XIDTE2,NUMSE2,IBUGG3,IERROR) 4113 CALL SORT(XIDTE2,NUMSE2,XIDTE2) 4114C 4115 IF(NUMSE1.LT.1)THEN 4116 WRITE(ICOUT,999) 4117 CALL DPWRST('XXX','BUG ') 4118 WRITE(ICOUT,31) 4119 CALL DPWRST('XXX','BUG ') 4120 WRITE(ICOUT,2202) 4121 2202 FORMAT(' NUMBER OF SETS NUMSE1 = 0 ') 4122 CALL DPWRST('XXX','BUG ') 4123 IERROR='YES' 4124 GOTO9000 4125 ENDIF 4126C 4127 IF(NUMSE2.LT.1)THEN 4128 WRITE(ICOUT,999) 4129 CALL DPWRST('XXX','BUG ') 4130 WRITE(ICOUT,31) 4131 CALL DPWRST('XXX','BUG ') 4132 WRITE(ICOUT,2204) 4133 2204 FORMAT(' NUMBER OF SETS NUMSE2 = 0 ') 4134 CALL DPWRST('XXX','BUG ') 4135 IERROR='YES' 4136 GOTO9000 4137 ENDIF 4138C 4139 AN=N 4140 ANUMS1=NUMSE1 4141 ANUMS2=NUMSE2 4142C 4143C COMPUTE COUNTS FOR EACH CELL. IF 2X2 TABLE DETECTED 4144C WHERE DISTINCT VALUES ARE 1 AND 0, TREAT LIKE 2X2 TABLE 4145C ABOVE. 4146C 4147 IF(NUMSE1.EQ.2 .AND. NUMSE2.EQ.2)THEN 4148 IF(XIDTEM(1).EQ.0.0 .AND. XIDTEM(2).EQ.1.0)THEN 4149 IF(XIDTE2(1).EQ.0.0 .AND. XIDTE2(2).EQ.1.0)THEN 4150 N11=0 4151 N12=0 4152 N21=0 4153 N22=0 4154 DO2260I=1,N 4155 IF(Y1(I).EQ.1.0 .AND. Y2(I).EQ.1.0)THEN 4156 N11=N11+1 4157 ELSEIF(Y1(I).EQ.1.0 .AND. Y2(I).EQ.0.0)THEN 4158 N12=N12+1 4159 ELSEIF(Y1(I).EQ.0.0 .AND. Y2(I).EQ.1.0)THEN 4160 N21=N21+1 4161 ELSEIF(Y1(I).EQ.0.0 .AND. Y2(I).EQ.0.0)THEN 4162 N22=N22+1 4163 ENDIF 4164 2260 CONTINUE 4165 X(1)=REAL(N11) 4166 X(2)=REAL(N12) 4167 X(3)=REAL(N21) 4168 X(4)=REAL(N22) 4169 NUMCLA=4 4170 GOTO3000 4171 ENDIF 4172 ENDIF 4173 ENDIF 4174C 4175 J=0 4176 DO2310ISET1=1,NUMSE1 4177 DO2320ISET2=1,NUMSE2 4178C 4179 K=0 4180 DO2330I=1,N 4181 IF(XIDTEM(ISET1).EQ.Y1(I).AND.XIDTE2(ISET2).EQ.Y2(I))THEN 4182 K=K+1 4183 ENDIF 4184 2330 CONTINUE 4185 J=J+1 4186 X(J)=REAL(K) 4187C 4188 2320 CONTINUE 4189 2310 CONTINUE 4190 NUMCLA=J 4191C 4192 GOTO3000 4193C 4194 3000 CONTINUE 4195C 4196 DO3010I=1,NUMCLA 4197 IF(X(I).LT.0.0)THEN 4198 WRITE(ICOUT,999) 4199 CALL DPWRST('XXX','BUG ') 4200 WRITE(ICOUT,31) 4201 CALL DPWRST('XXX','BUG ') 4202 WRITE(ICOUT,3012) 4203 3012 FORMAT(' FOR THE TWO-VARIABLE CASE, A NEGATIVE ', 4204 1 'COUNT WAS ENCOUNTERED.') 4205 CALL DPWRST('XXX','BUG ') 4206 WRITE(ICOUT,999) 4207 CALL DPWRST('XXX','BUG ') 4208 IERROR='YES' 4209 GOTO9000 4210 ENDIF 4211 3010 CONTINUE 4212C 4213 ANGINC=2.0*PI/REAL(NUMCLA) 4214C 4215 YMAX=X(1) 4216 DO3060J=1,NUMCLA 4217 YMAX=MAX(YMAX,X(J)) 4218 3060 CONTINUE 4219C 4220 DO3070J=1,NUMCLA 4221 TEMP1(J)=SQRT(X(J)/YMAX) 4222 3070 CONTINUE 4223C 4224 K=0 4225 J2=0 4226 DO3120J=1,NUMCLA 4227C 4228 R=TEMP1(J) 4229 ANGSTA=PI - (J-1)*ANGINC 4230 ANGSTO=ANGSTA-ANGINC 4231C 4232 K=K+1 4233 J2=J2+1 4234C 4235 XPLOT(K)=0.0 4236 YPLOT(K)=0.0 4237 D2(K)=J2 4238C 4239 ANG=ANGSTA 4240 K=K+1 4241 XPLOT(K)=R*COS(ANG) 4242 YPLOT(K)=R*SIN(ANG) 4243 D2(K)=J2 4244C 4245 3125 CONTINUE 4246 ANG=ANG - 0.015 4247 IF(ANG.LT.ANGSTO)THEN 4248 K=K+1 4249 XPLOT(K)=R*COS(ANGSTO) 4250 YPLOT(K)=R*SIN(ANGSTO) 4251 D2(K)=J2 4252 K=K+1 4253 XPLOT(K)=0.0 4254 YPLOT(K)=0.0 4255 D2(K)=J2 4256 GOTO3120 4257 ELSE 4258 K=K+1 4259 XPLOT(K)=R*COS(ANG) 4260 YPLOT(K)=R*SIN(ANG) 4261 D2(K)=J2 4262 ENDIF 4263C 4264 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'ROS2')THEN 4265 WRITE(ICOUT,3121)J,J2,K,ANGSTA,ANGSTO,ANG 4266 3121 FORMAT('J,J2,K,ANSTA,ANGSTO,ANG = ',3I8,3G15.7) 4267 CALL DPWRST('XXX','BUG ') 4268 WRITE(ICOUT,3123)R,XPLOT(K),YPLOT(K) 4269 3123 FORMAT('R,XPLOT(K),YPLOT(K) = ',3G15.7) 4270 CALL DPWRST('XXX','BUG ') 4271 ENDIF 4272C 4273 GOTO3125 4274C 4275 3120 CONTINUE 4276C 4277 NPLOTP=K 4278 NPLOTV=3 4279 GOTO9000 4280C 4281C ****************** 4282C ** STEP 90-- ** 4283C ** EXIT ** 4284C ****************** 4285C 4286 9000 CONTINUE 4287 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ROS2')THEN 4288 WRITE(ICOUT,999) 4289 CALL DPWRST('XXX','BUG ') 4290 WRITE(ICOUT,9011) 4291 9011 FORMAT('***** AT THE END OF DPROS2--') 4292 CALL DPWRST('XXX','BUG ') 4293 WRITE(ICOUT,9012)NPLOTP 4294 9012 FORMAT('NPLOTP = ',I8) 4295 CALL DPWRST('XXX','BUG ') 4296 DO9015I=1,NPLOTP 4297 WRITE(ICOUT,9016)I,YPLOT(I),XPLOT(I),D2(I) 4298 9016 FORMAT('I,YPLOT(I),XPLOT(I),D2(I) = ',I8,2G15.7,F9.2) 4299 CALL DPWRST('XXX','BUG ') 4300 9015 CONTINUE 4301 ENDIF 4302C 4303 RETURN 4304 END 4305 SUBROUTINE DPROTA(X,Y,XREF,YREF,ANGLE,AMAX,XP,YP) 4306C 4307C ROTATE THE POINT (X,Y) ABOUT THE 4308C REFERENCE POINT (XREF,YREF). 4309C THE ANGLE OF ROTATION IS ANGLE. 4310C AMAX (STANDING FOR MAXIMUM ANGLE) IS 4311C THE ANGLE FOR 1 FULL ROTATION 4312C (360.0 FOR DEGREES, 2*PI FOR RADIANS, 4313C 400 FOR GRADS)--THIS IMPLICITELY DEFINES 4314C THE UNITS FOR THE ANGLE. 4315C WRITTEN BY--JAMES J. FILLIBEN 4316C STATISTICAL ENGINEERING DIVISION 4317C INFORMATION TECHNOLOGY LABORATORY 4318C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 4319C GAITHERSBURG, MD 20899 4320C PHONE--301-975-2855 4321C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 4322C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 4323C LANGUAGE--ANSI FORTRAN (1977) 4324C VERSION NUMBER--82/7 4325C ORIGINAL VERSION--OCTOBER 1980. 4326C UPDATED --APRIL 1981. 4327C UPDATED --MAY 1982. 4328C 4329C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 4330C 4331C--------------------------------------------------------------------- 4332C 4333 INCLUDE 'DPCOP2.INC' 4334C 4335C-----START POINT----------------------------------------------------- 4336C 4337 THETA=(ANGLE/AMAX)*2.0*3.1415926 4338C 4339 XROT=(X-XREF)*COS(THETA)-(Y-YREF)*SIN(THETA) 4340 YROT=(X-XREF)*SIN(THETA)+(Y-YREF)*COS(THETA) 4341C 4342 XP=XREF+XROT 4343 YP=YREF+YROT 4344 GOTO9000 4345C 4346 9000 CONTINUE 4347 RETURN 4348 END 4349 SUBROUTINE DPROWL(IHARG,IARGT,IARG,NUMARG,IDEFR1,IDEFR2, 4350 1IFROW1,IFROW2,IFOUND,IERROR) 4351C 4352C PURPOSE--DEFINE ROW LIMITS 4353C WHICH WILL DEFINE THE EXTREME 4354C ROWS (WITHIN A FILE) TO BE SCANNED IN CARRYING 4355C OUT THE READ AND SERIAL READ COMMANDS. 4356C THE 2 LIMITS ARE CONTAINED IN THE 4357C 2 ARGUMENTS IFROW1 AND IFROW2, RESPECTIVELY. 4358C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 4359C --IARGT (A HOLLERITH VECTOR) 4360C --IARG (AN INTEGER VECTOR) 4361C --NUMARG 4362C --IDEFR1 4363C --IDEFR2 4364C OUTPUT ARGUMENTS--IFROW1 (AN INTEGER VARIABLE 4365C CONTAINING THE MINIMUM ROW 4366C IN THE DATA FILE TO BE SCANNED 4367C DURING A READ OR A SERIAL READ. 4368C --IFROW2 (AN INTEGER VARIABLE 4369C CONTAINING THE MAXIMUM ROW 4370C IN THE DATA FILE TO BE SCANNED 4371C DURING A READ OR A SERIAL READ. 4372C --IFOUND ('YES' OR 'NO' ) 4373C --IERROR ('YES' OR 'NO' ) 4374C WRITTEN BY--JAMES J. FILLIBEN 4375C STATISTICAL ENGINEERING DIVISION 4376C INFORMATION TECHNOLOGY LABORATORY 4377C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 4378C GAITHERSBURG, MD 20899 4379C PHONE--301-975-2855 4380C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 4381C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 4382C LANGUAGE--ANSI FORTRAN (1977) 4383C VERSION NUMBER--82/7 4384C ORIGINAL VERSION--NOVEMBER 1980. 4385C UPDATED --MAY 1982. 4386C 4387C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 4388C 4389 CHARACTER*4 IHARG 4390 CHARACTER*4 IARGT 4391 CHARACTER*4 IFOUND 4392 CHARACTER*4 IERROR 4393C 4394C--------------------------------------------------------------------- 4395C 4396 DIMENSION IHARG(*) 4397 DIMENSION IARGT(*) 4398 DIMENSION IARG(*) 4399C 4400C--------------------------------------------------------------------- 4401C 4402 INCLUDE 'DPCOP2.INC' 4403C 4404C-----START POINT----------------------------------------------------- 4405C 4406 IFOUND='NO' 4407 IERROR='NO' 4408C 4409 IHOLD1=0 4410 IHOLD2=0 4411C 4412C **************************************************** 4413C ** TREAT THE CASE WHEN ** 4414C ** THE ROW LIMITS ARE TO BE CHANGED ** 4415C **************************************************** 4416C 4417 IF(NUMARG.LE.0)GOTO1900 4418 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LIMI')GOTO1110 4419 GOTO1190 4420C 4421 1110 CONTINUE 4422 IF(NUMARG.EQ.1)GOTO1120 4423 IF(IHARG(NUMARG).EQ.'ON')GOTO1120 4424 IF(IHARG(NUMARG).EQ.'OFF')GOTO1120 4425 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1120 4426 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1120 4427 IF(NUMARG.GE.3.AND.IARGT(2).EQ.'NUMB'.AND. 4428 1IARGT(3).EQ.'NUMB')GOTO1130 4429 GOTO1190 4430C 4431 1120 CONTINUE 4432 I1=IDEFR1 4433 I2=IDEFR2 4434 IF(I1.LE.I2)IHOLD1=I1 4435 IF(I1.LE.I2)IHOLD2=I2 4436 IF(I1.GT.I2)IHOLD1=I2 4437 IF(I1.GT.I2)IHOLD2=I1 4438 GOTO1180 4439C 4440 1130 CONTINUE 4441 I1=IARG(2) 4442 I2=IARG(3) 4443 IF(I1.LE.I2)IHOLD1=I1 4444 IF(I1.LE.I2)IHOLD2=I2 4445 IF(I1.GT.I2)IHOLD1=I2 4446 IF(I1.GT.I2)IHOLD2=I1 4447 GOTO1180 4448C 4449 1180 CONTINUE 4450 IFOUND='YES' 4451 IFROW1=IHOLD1 4452 IFROW2=IHOLD2 4453C 4454 IF(IFEEDB.EQ.'OFF')GOTO1189 4455 WRITE(ICOUT,999) 4456 999 FORMAT(1X) 4457 CALL DPWRST('XXX','BUG ') 4458 WRITE(ICOUT,1185) 4459 1185 FORMAT('THE ROW LIMITS (FOR READ AND SERIAL READ)') 4460 CALL DPWRST('XXX','BUG ') 4461 IF(IFROW2.NE.IDEFR2)WRITE(ICOUT,1186)IFROW1,IFROW2 4462 1186 FORMAT('HAVE JUST BEEN SET TO ',I8,2X,I8) 4463 IF(IFROW2.NE.IDEFR2)CALL DPWRST('XXX','BUG ') 4464 IF(IFROW2.EQ.IDEFR2)WRITE(ICOUT,1187)IFROW1 4465 1187 FORMAT('HAVE JUST BEEN SET TO ',I8,2X,'INFINITY') 4466 IF(IFROW2.EQ.IDEFR2)CALL DPWRST('XXX','BUG ') 4467 1189 CONTINUE 4468 GOTO1900 4469C 4470 1190 CONTINUE 4471C 4472C **************************************************** 4473C ** TREAT THE CASE WHEN ** 4474C ** THE ROW MINIMUM IS TO BE CHANGED ** 4475C **************************************************** 4476C 4477 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MINI')GOTO1210 4478 GOTO1290 4479C 4480 1210 CONTINUE 4481 IF(NUMARG.EQ.1)GOTO1220 4482 IF(IHARG(NUMARG).EQ.'ON')GOTO1220 4483 IF(IHARG(NUMARG).EQ.'OFF')GOTO1220 4484 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1220 4485 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1220 4486 IF(NUMARG.GE.2.AND.IARGT(2).EQ.'NUMB')GOTO1230 4487 GOTO1290 4488C 4489 1220 CONTINUE 4490 IHOLD1=IDEFR1 4491 GOTO1280 4492C 4493 1230 CONTINUE 4494 IHOLD1=IARG(2) 4495 GOTO1280 4496C 4497 1280 CONTINUE 4498 IFOUND='YES' 4499 IFROW1=IHOLD1 4500C 4501 IF(IFEEDB.EQ.'OFF')GOTO1289 4502 WRITE(ICOUT,999) 4503 CALL DPWRST('XXX','BUG ') 4504 WRITE(ICOUT,1285) 4505 1285 FORMAT('THE ROW MINIMUM (FOR READ AND SERIAL READ)') 4506 CALL DPWRST('XXX','BUG ') 4507 WRITE(ICOUT,1286)IFROW1 4508 1286 FORMAT('HAS JUST BEEN SET TO ',I8) 4509 CALL DPWRST('XXX','BUG ') 4510 1289 CONTINUE 4511 GOTO1900 4512C 4513 1290 CONTINUE 4514C 4515C **************************************************** 4516C ** TREAT THE CASE WHEN ** 4517C ** THE ROW MAXIMUM IS TO BE CHANGED ** 4518C **************************************************** 4519C 4520 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MAXI')GOTO1310 4521 GOTO1390 4522C 4523 1310 CONTINUE 4524 IF(NUMARG.EQ.1)GOTO1320 4525 IF(IHARG(NUMARG).EQ.'ON')GOTO1320 4526 IF(IHARG(NUMARG).EQ.'OFF')GOTO1320 4527 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1320 4528 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1320 4529 IF(NUMARG.GE.2.AND.IARGT(2).EQ.'NUMB')GOTO1330 4530 GOTO1390 4531C 4532 1320 CONTINUE 4533 IHOLD2=IDEFR2 4534 GOTO1380 4535C 4536 1330 CONTINUE 4537 IHOLD2=IARG(2) 4538 GOTO1380 4539C 4540 1380 CONTINUE 4541 IFOUND='YES' 4542 IFROW2=IHOLD2 4543C 4544 IF(IFEEDB.EQ.'OFF')GOTO1389 4545 WRITE(ICOUT,999) 4546 CALL DPWRST('XXX','BUG ') 4547 WRITE(ICOUT,1385) 4548 1385 FORMAT('THE ROW MAXIMUM (FOR READ AND SERIAL READ)') 4549 CALL DPWRST('XXX','BUG ') 4550 IF(IFROW2.NE.IDEFR2)WRITE(ICOUT,1386)IFROW2 4551 1386 FORMAT('HAS JUST BEEN SET TO ',I8) 4552 IF(IFROW2.NE.IDEFR2)CALL DPWRST('XXX','BUG ') 4553 IF(IFROW2.EQ.IDEFR2)WRITE(ICOUT,1387) 4554 1387 FORMAT('HAS JUST BEEN SET TO ','INFINITY') 4555 IF(IFROW2.EQ.IDEFR2)CALL DPWRST('XXX','BUG ') 4556 1389 CONTINUE 4557 GOTO1900 4558C 4559 1390 CONTINUE 4560C 4561 1900 CONTINUE 4562 RETURN 4563 END 4564 SUBROUTINE DPRPCO(IHARG,NUMARG,IDERPC,MAXREG,IREPCO, 4565 1IBUGP2,IFOUND,IERROR) 4566C 4567C PURPOSE--DEFINE THE REGION PATTERN COLORS = THE COLORS 4568C OF THE LINES MAKING UP A PATTERN WITHIN A REGION. 4569C THESE ARE LOCATED IN THE VECTOR IREPCO(.). 4570C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 4571C --NUMARG 4572C --IDERPC 4573C --MAXREG 4574C --IBUGP2 ('ON' OR 'OFF' ) 4575C OUTPUT ARGUMENTS--IREPCO (A CHARACTER VECTOR) 4576C --IFOUND ('YES' OR 'NO' ) 4577C --IERROR ('YES' OR 'NO' ) 4578C WRITTEN BY--JAMES J. FILLIBEN 4579C STATISTICAL ENGINEERING DIVISION 4580C INFORMATION TECHNOLOGY LABORATORY 4581C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 4582C GAITHERSBURG, MD 20899 4583C PHONE--301-975-2855 4584C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 4585C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 4586C LANGUAGE--ANSI FORTRAN (1977) 4587C VERSION NUMBER--82/7 4588C ORIGINAL VERSION--DECEMBER 1983. 4589C 4590C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 4591C 4592 CHARACTER*4 IHARG 4593 CHARACTER*4 IDERPC 4594 CHARACTER*4 IREPCO 4595C 4596 CHARACTER*4 IBUGP2 4597 CHARACTER*4 IFOUND 4598 CHARACTER*4 IERROR 4599C 4600 CHARACTER*4 IHOLD1 4601 CHARACTER*4 IHOLD2 4602C 4603 CHARACTER*4 ISUBN1 4604 CHARACTER*4 ISUBN2 4605 CHARACTER*4 ISTEPN 4606C 4607 DIMENSION IHARG(*) 4608 DIMENSION IREPCO(*) 4609C 4610C--------------------------------------------------------------------- 4611C 4612 INCLUDE 'DPCOP2.INC' 4613C 4614C-----START POINT----------------------------------------------------- 4615C 4616 IFOUND='NO' 4617 IERROR='NO' 4618 ISUBN1='DPRP' 4619 ISUBN2='CO ' 4620C 4621 NUMREG=0 4622 IHOLD1='-999' 4623 IHOLD2='-999' 4624C 4625 IF(IBUGP2.EQ.'OFF')GOTO90 4626 WRITE(ICOUT,999) 4627 999 FORMAT(1X) 4628 CALL DPWRST('XXX','BUG ') 4629 WRITE(ICOUT,51) 4630 51 FORMAT('***** AT THE BEGINNING OF DPRPCO--') 4631 CALL DPWRST('XXX','BUG ') 4632 WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 4633 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 4634 CALL DPWRST('XXX','BUG ') 4635 WRITE(ICOUT,53)MAXREG,NUMREG 4636 53 FORMAT('MAXREG,NUMREG = ',I8,I8) 4637 CALL DPWRST('XXX','BUG ') 4638 WRITE(ICOUT,54)IHOLD1,IHOLD2 4639 54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 4640 CALL DPWRST('XXX','BUG ') 4641 WRITE(ICOUT,55)IDERPC 4642 55 FORMAT('IDERPC = ',A4) 4643 CALL DPWRST('XXX','BUG ') 4644 WRITE(ICOUT,60)NUMARG 4645 60 FORMAT('NUMARG = ',I8) 4646 CALL DPWRST('XXX','BUG ') 4647 DO65I=1,NUMARG 4648 WRITE(ICOUT,66)IHARG(I) 4649 66 FORMAT('IHARG(I) = ',A4) 4650 CALL DPWRST('XXX','BUG ') 4651 65 CONTINUE 4652 WRITE(ICOUT,70)IREPCO(1) 4653 70 FORMAT('IREPCO(1) = ',A4) 4654 CALL DPWRST('XXX','BUG ') 4655 DO75I=1,10 4656 WRITE(ICOUT,76)I,IREPCO(I) 4657 76 FORMAT('I,IREPCO(I) = ',I8,2X,A4) 4658 CALL DPWRST('XXX','BUG ') 4659 75 CONTINUE 4660 90 CONTINUE 4661C 4662C ************************************** 4663C ** STEP 1-- ** 4664C ** BRANCH TO THE APPROPRIATE CASE ** 4665C ************************************** 4666C 4667 ISTEPN='1' 4668 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4669C 4670 IF(NUMARG.LE.1)GOTO9000 4671 IF(NUMARG.EQ.2)GOTO1120 4672 IF(NUMARG.EQ.3)GOTO1130 4673 IF(NUMARG.EQ.4)GOTO1140 4674 GOTO1150 4675C 4676 1120 CONTINUE 4677 GOTO1200 4678C 4679 1130 CONTINUE 4680 IF(IHARG(3).EQ.'ALL')IHOLD1=' ' 4681 IF(IHARG(3).EQ.'ALL')GOTO1300 4682 GOTO1200 4683C 4684 1140 CONTINUE 4685 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) 4686 IF(IHARG(3).EQ.'ALL')GOTO1300 4687 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) 4688 IF(IHARG(4).EQ.'ALL')GOTO1300 4689 GOTO1200 4690C 4691 1150 CONTINUE 4692 GOTO1200 4693C 4694C ************************************************* 4695C ** STEP 2-- ** 4696C ** TREAT THE SINGLE SPECIFICATION CASE ** 4697C ************************************************* 4698C 4699 1200 CONTINUE 4700 ISTEPN='2' 4701 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4702C 4703 IF(NUMARG.LE.2)GOTO1210 4704 GOTO1220 4705C 4706 1210 CONTINUE 4707 NUMREG=1 4708 IREPCO(1)=IDERPC 4709 GOTO1270 4710C 4711 1220 CONTINUE 4712 NUMREG=NUMARG-2 4713 IF(NUMREG.GT.MAXREG)NUMREG=MAXREG 4714 DO1225I=1,NUMREG 4715 J=I+2 4716 IHOLD1=IHARG(J) 4717 IHOLD2=IHOLD1 4718 IF(IHOLD1.EQ.'ON')IHOLD2=IDERPC 4719 IF(IHOLD1.EQ.'OFF')IHOLD2=IDERPC 4720 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDERPC 4721 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDERPC 4722 IREPCO(I)=IHOLD2 4723 1225 CONTINUE 4724 GOTO1270 4725C 4726 1270 CONTINUE 4727 IF(IFEEDB.EQ.'OFF')GOTO1279 4728 WRITE(ICOUT,999) 4729 CALL DPWRST('XXX','BUG ') 4730 DO1278I=1,NUMREG 4731 WRITE(ICOUT,1276)I,IREPCO(I) 4732 1276 FORMAT('THE COLOR OF REGION PATTERN ',I6, 4733 1' HAS JUST BEEN SET TO ',A4) 4734 CALL DPWRST('XXX','BUG ') 4735 1278 CONTINUE 4736 1279 CONTINUE 4737 IFOUND='YES' 4738 GOTO9000 4739C 4740C ************************** 4741C ** STEP 3-- ** 4742C ** TREAT THE ALL CASE ** 4743C ************************** 4744C 4745 1300 CONTINUE 4746 ISTEPN='3' 4747 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4748C 4749 NUMREG=MAXREG 4750 IHOLD2=IHOLD1 4751 IF(IHOLD1.EQ.'ON')IHOLD2=IDERPC 4752 IF(IHOLD1.EQ.'OFF')IHOLD2=IDERPC 4753 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDERPC 4754 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDERPC 4755 DO1315I=1,NUMREG 4756 IREPCO(I)=IHOLD2 4757 1315 CONTINUE 4758 GOTO1370 4759C 4760 1370 CONTINUE 4761 IF(IFEEDB.EQ.'OFF')GOTO1319 4762 WRITE(ICOUT,999) 4763 CALL DPWRST('XXX','BUG ') 4764 I=1 4765 WRITE(ICOUT,1316)IREPCO(I) 4766 1316 FORMAT('THE COLOR OF ALL REGION PATTERNS', 4767 1' HAS JUST BEEN SET TO ',A4) 4768 CALL DPWRST('XXX','BUG ') 4769 1319 CONTINUE 4770 IFOUND='YES' 4771 GOTO9000 4772C 4773C ***************** 4774C ** STEP 90-- ** 4775C ** EXIT ** 4776C ***************** 4777C 4778 9000 CONTINUE 4779 IF(IBUGP2.EQ.'OFF')GOTO9090 4780 WRITE(ICOUT,9011) 4781 9011 FORMAT('***** AT THE END OF DPRPCO--') 4782 CALL DPWRST('XXX','BUG ') 4783 WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 4784 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 4785 CALL DPWRST('XXX','BUG ') 4786 WRITE(ICOUT,9013)MAXREG,NUMREG 4787 9013 FORMAT('MAXREG,NUMREG = ',I8,I8) 4788 CALL DPWRST('XXX','BUG ') 4789 WRITE(ICOUT,9014)IHOLD1,IHOLD2 4790 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 4791 CALL DPWRST('XXX','BUG ') 4792 WRITE(ICOUT,9015)IDERPC 4793 9015 FORMAT('IDERPC = ',A4) 4794 CALL DPWRST('XXX','BUG ') 4795 WRITE(ICOUT,9020)NUMARG 4796 9020 FORMAT('NUMARG = ',I8) 4797 CALL DPWRST('XXX','BUG ') 4798 DO9025I=1,NUMARG 4799 WRITE(ICOUT,9026)IHARG(I) 4800 9026 FORMAT('IHARG(I) = ',A4) 4801 CALL DPWRST('XXX','BUG ') 4802 9025 CONTINUE 4803 WRITE(ICOUT,9030)IREPCO(1) 4804 9030 FORMAT('IREPCO(1) = ',A4) 4805 CALL DPWRST('XXX','BUG ') 4806 DO9035I=1,10 4807 WRITE(ICOUT,9036)I,IREPCO(I) 4808 9036 FORMAT('I,IREPCO(I) = ',I8,2X,A4) 4809 CALL DPWRST('XXX','BUG ') 4810 9035 CONTINUE 4811 9090 CONTINUE 4812C 4813 RETURN 4814 END 4815 SUBROUTINE DPRPLI(IHARG,IHARG2,NUMARG,IDERPL,MAXREG,IREPLI, 4816CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC 4817CCCCC SUBROUTINE DPRPLI(IHARG,NUMARG,IDERPL,MAXREG,IREPLI, 4818 1IBUGP2,IFOUND,IERROR) 4819C 4820C PURPOSE--DEFINE THE PATTERN LINES = THE LINES TYPES 4821C OF THE PATTERN WITHIN THE REGIONS. 4822C THESE ARE LOCATED IN THE VECTOR IREPLI(.). 4823C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 4824C --NUMARG 4825C --IDERPL 4826C --MAXREG 4827C --IBUGP2 ('ON' OR 'OFF' ) 4828C OUTPUT ARGUMENTS--IREPLI (A CHARACTER VECTOR) 4829C --IFOUND ('YES' OR 'NO' ) 4830C --IERROR ('YES' OR 'NO' ) 4831C WRITTEN BY--JAMES J. FILLIBEN 4832C STATISTICAL ENGINEERING DIVISION 4833C INFORMATION TECHNOLOGY LABORATORY 4834C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 4835C GAITHERSBURG, MD 20899 4836C PHONE--301-975-2855 4837C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 4838C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 4839C LANGUAGE--ANSI FORTRAN (1977) 4840C VERSION NUMBER--82/7 4841C ORIGINAL VERSION--DECEMBER 1983. 4842C UPDATED --AUGUST 1995. 4843C 4844C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 4845C 4846 CHARACTER*4 IHARG 4847CCCCC AUGUST 1995. ADD FOLLOWING LINE 4848 CHARACTER*4 IHARG2 4849 CHARACTER*4 IDERPL 4850 CHARACTER*4 IREPLI 4851C 4852 CHARACTER*4 IBUGP2 4853 CHARACTER*4 IFOUND 4854 CHARACTER*4 IERROR 4855C 4856 CHARACTER*4 IHOLD1 4857 CHARACTER*4 IHOLD2 4858C 4859 CHARACTER*4 ISUBN1 4860 CHARACTER*4 ISUBN2 4861 CHARACTER*4 ISTEPN 4862C 4863 DIMENSION IHARG(*) 4864CCCCC AUGUST 1995. ADD FOLLOWING LINE 4865 DIMENSION IHARG2(*) 4866 DIMENSION IREPLI(*) 4867C 4868C--------------------------------------------------------------------- 4869C 4870 INCLUDE 'DPCOP2.INC' 4871C 4872C-----START POINT----------------------------------------------------- 4873C 4874 IFOUND='NO' 4875 IERROR='NO' 4876 ISUBN1='DPRP' 4877 ISUBN2='LI ' 4878C 4879 NUMREG=0 4880 IHOLD1='-999' 4881 IHOLD2='-999' 4882C 4883 IF(IBUGP2.EQ.'OFF')GOTO90 4884 WRITE(ICOUT,999) 4885 999 FORMAT(1X) 4886 CALL DPWRST('XXX','BUG ') 4887 WRITE(ICOUT,51) 4888 51 FORMAT('***** AT THE BEGINNING OF DPRPLI--') 4889 CALL DPWRST('XXX','BUG ') 4890 WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 4891 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 4892 CALL DPWRST('XXX','BUG ') 4893 WRITE(ICOUT,53)MAXREG,NUMREG 4894 53 FORMAT('MAXREG,NUMREG = ',I8,I8) 4895 CALL DPWRST('XXX','BUG ') 4896 WRITE(ICOUT,54)IHOLD1,IHOLD2 4897 54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 4898 CALL DPWRST('XXX','BUG ') 4899 WRITE(ICOUT,55)IDERPL 4900 55 FORMAT('IDERPL = ',A4) 4901 CALL DPWRST('XXX','BUG ') 4902 WRITE(ICOUT,60)NUMARG 4903 60 FORMAT('NUMARG = ',I8) 4904 CALL DPWRST('XXX','BUG ') 4905 DO65I=1,NUMARG 4906 WRITE(ICOUT,66)IHARG(I) 4907 66 FORMAT('IHARG(I) = ',A4) 4908 CALL DPWRST('XXX','BUG ') 4909 65 CONTINUE 4910 WRITE(ICOUT,70)IREPLI(1) 4911 70 FORMAT('IREPLI(1) = ',A4) 4912 CALL DPWRST('XXX','BUG ') 4913 DO75I=1,10 4914 WRITE(ICOUT,76)I,IREPLI(I) 4915 76 FORMAT('I,IREPLI(I) = ',I8,2X,A4) 4916 CALL DPWRST('XXX','BUG ') 4917 75 CONTINUE 4918 90 CONTINUE 4919C 4920C ************************************** 4921C ** STEP 1-- ** 4922C ** BRANCH TO THE APPROPRIATE CASE ** 4923C ************************************** 4924C 4925 ISTEPN='1' 4926 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4927C 4928 IF(NUMARG.LE.2)GOTO9000 4929 IF(NUMARG.EQ.3)GOTO1130 4930 IF(NUMARG.EQ.4)GOTO1140 4931 IF(NUMARG.EQ.5)GOTO1150 4932 GOTO1160 4933C 4934 1130 CONTINUE 4935 GOTO1200 4936C 4937 1140 CONTINUE 4938 IF(IHARG(5).EQ.'ALL')IHOLD1=' ' 4939 IF(IHARG(5).EQ.'ALL')GOTO1300 4940 GOTO1200 4941C 4942 1150 CONTINUE 4943CCCCC APRIL 1996. CHANGE IHOLD TO IHOLD1 BELOW 4944 IF(IHARG(5).EQ.'ALL')THEN 4945 IHOLD1=IHARG(6) 4946 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'2')IHOLD1='DA2' 4947 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'3')IHOLD1='DA3' 4948 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'4')IHOLD1='DA4' 4949 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'5')IHOLD1='DA5' 4950 GOTO1300 4951 ENDIF 4952 IF(IHARG(6).EQ.'ALL')THEN 4953 IHOLD1=IHARG(5) 4954 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'2')IHOLD1='DA2' 4955 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'3')IHOLD1='DA3' 4956 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'4')IHOLD1='DA4' 4957 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'5')IHOLD1='DA5' 4958 GOTO1300 4959 ENDIF 4960 GOTO1200 4961C 4962 1160 CONTINUE 4963 GOTO1200 4964C 4965C ************************************************* 4966C ** STEP 2-- ** 4967C ** TREAT THE SINGLE SPECIFICATION CASE ** 4968C ************************************************* 4969C 4970 1200 CONTINUE 4971 ISTEPN='2' 4972 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4973C 4974 IF(NUMARG.LE.3)GOTO1210 4975 GOTO1220 4976C 4977 1210 CONTINUE 4978 NUMREG=1 4979 IREPLI(1)=' ' 4980 GOTO1270 4981C 4982 1220 CONTINUE 4983 NUMREG=NUMARG-3 4984 IF(NUMREG.GT.MAXREG)NUMREG=MAXREG 4985 DO1225I=1,NUMREG 4986 J=I+3 4987 IHOLD1=IHARG(J) 4988 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'2')IHOLD1='DA2' 4989 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'3')IHOLD1='DA3' 4990 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'4')IHOLD1='DA4' 4991 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'5')IHOLD1='DA5' 4992 IHOLD2=IHOLD1 4993 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' 4994 IF(IHOLD1.EQ.'OFF')IHOLD2=' ' 4995 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDERPL 4996 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDERPL 4997 IREPLI(I)=IHOLD2 4998 1225 CONTINUE 4999 GOTO1270 5000C 5001 1270 CONTINUE 5002 IF(IFEEDB.EQ.'OFF')GOTO1279 5003 WRITE(ICOUT,999) 5004 CALL DPWRST('XXX','BUG ') 5005 DO1278I=1,NUMREG 5006 WRITE(ICOUT,1276)I,IREPLI(I) 5007 1276 FORMAT('THE LINE TYPE FOR REGION PATTERN ',I6, 5008 1' HAS JUST BEEN SET TO ',A4) 5009 CALL DPWRST('XXX','BUG ') 5010 1278 CONTINUE 5011 1279 CONTINUE 5012 IFOUND='YES' 5013 GOTO9000 5014C 5015C ************************** 5016C ** STEP 3-- ** 5017C ** TREAT THE ALL CASE ** 5018C ************************** 5019C 5020 1300 CONTINUE 5021 ISTEPN='3' 5022 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5023C 5024 NUMREG=MAXREG 5025 IHOLD2=IHOLD1 5026 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' 5027 IF(IHOLD1.EQ.'OFF')IHOLD2=' ' 5028 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDERPL 5029 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDERPL 5030 DO1315I=1,NUMREG 5031 IREPLI(I)=IHOLD2 5032 1315 CONTINUE 5033 GOTO1370 5034C 5035 1370 CONTINUE 5036 IF(IFEEDB.EQ.'OFF')GOTO1319 5037 WRITE(ICOUT,999) 5038 CALL DPWRST('XXX','BUG ') 5039 I=1 5040 WRITE(ICOUT,1316)IREPLI(I) 5041 1316 FORMAT('THE LINE TYPE FOR ALL REGION PATTERNS', 5042 1' HAS JUST BEEN SET TO ',A4) 5043 CALL DPWRST('XXX','BUG ') 5044 1319 CONTINUE 5045 IFOUND='YES' 5046 GOTO9000 5047C 5048C ***************** 5049C ** STEP 90-- ** 5050C ** EXIT ** 5051C ***************** 5052C 5053 9000 CONTINUE 5054 IF(IBUGP2.EQ.'OFF')GOTO9090 5055 WRITE(ICOUT,9011) 5056 9011 FORMAT('***** AT THE END OF DPRPLI--') 5057 CALL DPWRST('XXX','BUG ') 5058 WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 5059 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 5060 CALL DPWRST('XXX','BUG ') 5061 WRITE(ICOUT,9013)MAXREG,NUMREG 5062 9013 FORMAT('MAXREG,NUMREG = ',I8,I8) 5063 CALL DPWRST('XXX','BUG ') 5064 WRITE(ICOUT,9014)IHOLD1,IHOLD2 5065 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 5066 CALL DPWRST('XXX','BUG ') 5067 WRITE(ICOUT,9015)IDERPL 5068 9015 FORMAT('IDERPL = ',A4) 5069 CALL DPWRST('XXX','BUG ') 5070 WRITE(ICOUT,9020)NUMARG 5071 9020 FORMAT('NUMARG = ',I8) 5072 CALL DPWRST('XXX','BUG ') 5073 DO9025I=1,NUMARG 5074 WRITE(ICOUT,9026)IHARG(I) 5075 9026 FORMAT('IHARG(I) = ',A4) 5076 CALL DPWRST('XXX','BUG ') 5077 9025 CONTINUE 5078 WRITE(ICOUT,9030)IREPLI(1) 5079 9030 FORMAT('IREPLI(1) = ',A4) 5080 CALL DPWRST('XXX','BUG ') 5081 DO9035I=1,10 5082 WRITE(ICOUT,9036)I,IREPLI(I) 5083 9036 FORMAT('I,IREPLI(I) = ',I8,2X,A4) 5084 CALL DPWRST('XXX','BUG ') 5085 9035 CONTINUE 5086 9090 CONTINUE 5087C 5088 RETURN 5089 END 5090 SUBROUTINE DPRPLO(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 5091 1 IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR) 5092C 5093C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS 5094C THAT WILL DEFINE A REPAIR PLOT FOR MULTIPLE 5095C SYSTEMS. 5096C REFERENCE--TOBIAS AND TRINDADE (1995), "APPLIED 5097C RELIABILITY", SECOND EDITION, CHAPMAN AND HALL, 5098C PP. 314. 5099C WRITTEN BY--ALAN HECKERT 5100C STATISTICAL ENGINEERING DIVISION 5101C INFORMATION TECHNOLOGY LABORATORY 5102C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5103C GAITHERSBURG, MD 20899-8980 5104C PHONE--301-975-2899 5105C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5106C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5107C LANGUAGE--ANSI FORTRAN (1977) 5108C VERSION NUMBER--2006/10 5109C ORIGINAL VERSION--OCTOBER 2006. 5110C UPDATED --APRIL 2011. USE DPPAR AND DPPAR3 5111C 5112C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5113C 5114 CHARACTER*4 ICASPL 5115 CHARACTER*4 IAND1 5116 CHARACTER*4 IAND2 5117 CHARACTER*4 IBUGG2 5118 CHARACTER*4 IBUGG3 5119 CHARACTER*4 ISUBRO 5120 CHARACTER*4 IBUGQ 5121 CHARACTER*4 IFOUND 5122 CHARACTER*4 IERROR 5123C 5124 CHARACTER*4 ISUBN1 5125 CHARACTER*4 ISUBN2 5126 CHARACTER*4 ISTEPN 5127C 5128 CHARACTER*4 ICASE 5129 PARAMETER (MAXSPN=10) 5130 CHARACTER*40 INAME 5131 CHARACTER*4 IVARN1(MAXSPN) 5132 CHARACTER*4 IVARN2(MAXSPN) 5133 CHARACTER*4 IVARTY(MAXSPN) 5134 REAL PVAR(MAXSPN) 5135 INTEGER ILIS(MAXSPN) 5136 INTEGER NRIGHT(MAXSPN) 5137 INTEGER ICOLR(MAXSPN) 5138C 5139C--------------------------------------------------------------------- 5140C 5141 INCLUDE 'DPCOPA.INC' 5142C 5143 DIMENSION Y1(MAXOBV) 5144 DIMENSION X1(MAXOBV) 5145 DIMENSION XCEN(MAXOBV) 5146 DIMENSION TEMP1(MAXOBV) 5147 DIMENSION TEMP2(MAXOBV) 5148 DIMENSION TEMP3(MAXOBV) 5149 DIMENSION TEMP4(MAXOBV) 5150 DIMENSION TEMP5(MAXOBV) 5151C 5152 INCLUDE 'DPCOZZ.INC' 5153 EQUIVALENCE (GARBAG(IGARB1),Y1(1)) 5154 EQUIVALENCE (GARBAG(IGARB2),X1(1)) 5155 EQUIVALENCE (GARBAG(IGARB3),XCEN(1)) 5156 EQUIVALENCE (GARBAG(IGARB4),TEMP1(1)) 5157 EQUIVALENCE (GARBAG(IGARB5),TEMP2(1)) 5158 EQUIVALENCE (GARBAG(IGARB6),TEMP3(1)) 5159 EQUIVALENCE (GARBAG(IGARB7),TEMP4(1)) 5160 EQUIVALENCE (GARBAG(IGARB8),TEMP5(1)) 5161C 5162C-----COMMON---------------------------------------------------------- 5163C 5164 INCLUDE 'DPCOHO.INC' 5165 INCLUDE 'DPCOHK.INC' 5166 INCLUDE 'DPCODA.INC' 5167 INCLUDE 'DPCOP2.INC' 5168C 5169C-----START POINT----------------------------------------------------- 5170C 5171 IFOUND='NO' 5172 IERROR='NO' 5173 ISUBN1='DPRP' 5174 ISUBN2='PL ' 5175C 5176 MAXCP1=MAXCOL+1 5177 MAXCP2=MAXCOL+2 5178 MAXCP3=MAXCOL+3 5179 MAXCP4=MAXCOL+4 5180 MAXCP5=MAXCOL+5 5181 MAXCP6=MAXCOL+6 5182C 5183 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'RPLO')THEN 5184 WRITE(ICOUT,999) 5185 999 FORMAT(1X) 5186 CALL DPWRST('XXX','BUG ') 5187 WRITE(ICOUT,51) 5188 51 FORMAT('***** AT THE BEGINNING OF DPRPLO--') 5189 CALL DPWRST('XXX','BUG ') 5190 WRITE(ICOUT,52)ICASPL,IAND1,IAND2,MAXCOL 5191 52 FORMAT('ICASPL,IAND1,IAND2,MAXCOL = ',3(A4,2X),I8) 5192 CALL DPWRST('XXX','BUG ') 5193 WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO 5194 53 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4) 5195 CALL DPWRST('XXX','BUG ') 5196 ENDIF 5197C 5198C ********************************************* 5199C ** TREAT THE REPAIR PLOT ** 5200C ********************************************* 5201C 5202C ******************************************* 5203C ** STEP 1-- ** 5204C ** SEARCH FOR REPAIR PLOT ** 5205C ******************************************* 5206C 5207 ISTEPN='11' 5208 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'RPLO') 5209 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5210C 5211 ICASPL='REPA' 5212 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')THEN 5213 ILASTC=1 5214 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 5215 IFOUND='YES' 5216 ELSE 5217 ICASPL=' ' 5218 IFOUND='NO' 5219 GOTO9000 5220 ENDIF 5221C 5222C **************************************** 5223C ** STEP 2-- ** 5224C ** EXTRACT THE VARIABLE LIST ** 5225C **************************************** 5226C 5227 ISTEPN='2' 5228 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'RPLO') 5229 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5230C 5231 INAME='REPAIR PLOT' 5232 MINNA=1 5233 MAXNA=100 5234 MINN2=2 5235 IFLAGE=1 5236 IFLAGM=0 5237 IFLAGP=0 5238 JMIN=1 5239 JMAX=NUMARG 5240 MINNVA=1 5241 MAXNVA=3 5242C 5243 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 5244 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 5245 1 JMIN,JMAX, 5246 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 5247 1 IVARN1,IVARN2,IVARTY,PVAR, 5248 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 5249 1 MINNVA,MAXNVA, 5250 1 IFLAGM,IFLAGP, 5251 1 IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 5252 IF(IERROR.EQ.'YES')GOTO9000 5253C 5254 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'RPLO')THEN 5255 WRITE(ICOUT,999) 5256 CALL DPWRST('XXX','BUG ') 5257 WRITE(ICOUT,281) 5258 281 FORMAT('***** AFTER CALL DPPARS--') 5259 CALL DPWRST('XXX','BUG ') 5260 WRITE(ICOUT,282)NQ,NUMVAR 5261 282 FORMAT('NQ,NUMVAR = ',2I8) 5262 CALL DPWRST('XXX','BUG ') 5263 IF(NUMVAR.GT.0)THEN 5264 DO285I=1,NUMVAR 5265 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 5266 1 ICOLR(I) 5267 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 5268 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 5269 CALL DPWRST('XXX','BUG ') 5270 285 CONTINUE 5271 ENDIF 5272 ENDIF 5273C 5274C EXTRACT THE VARIABLES. 5275C 5276 ICOL=1 5277 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 5278 1 INAME,IVARN1,IVARN2,IVARTY, 5279 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR, 5280 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 5281 1 MAXCP4,MAXCP5,MAXCP6, 5282 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 5283 1 Y1,X1,XCEN,NS,NGROUP,NCENS,ICASE, 5284 1 IBUGG3,ISUBRO,IFOUND,IERROR) 5285 IF(IERROR.EQ.'YES')GOTO9000 5286 IF(NUMVAR.LT.2)NGROUP=0 5287 IF(NUMVAR.LT.3)NCENS=0 5288C 5289C ***************************************************** 5290C ** STEP 41-- ** 5291C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** 5292C ** VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR ** 5293C ** THE PLOT. ** 5294C ** FORM THE CURVE DESIGNATION VARIABLED(.) . ** 5295C ** THIS WILL BE ALL ONES. ** 5296C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** 5297C ** DEFINE THE NUMBER OF PLOT VARIABLES(NPLOTV). ** 5298C ***************************************************** 5299C 5300 ISTEPN='41' 5301 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'RPLO') 5302 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5303C 5304 CALL DPRPL2(Y1,NS,X1,NGROUP,XCEN,NCENS,ICASPL,MAXN, 5305 1 TEMP1,TEMP2,TEMP3,TEMP4,TEMP5, 5306 1 Y,X,D,NPLOTP,NPLOTV, 5307 1 IBUGG3,ISUBRO,IERROR) 5308C 5309C ***************** 5310C ** STEP 90-- ** 5311C ** EXIT ** 5312C ***************** 5313C 5314 9000 CONTINUE 5315 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'RPLO')THEN 5316 WRITE(ICOUT,999) 5317 CALL DPWRST('XXX','BUG ') 5318 WRITE(ICOUT,9011) 5319 9011 FORMAT('***** AT THE END OF DPRPLO--') 5320 CALL DPWRST('XXX','BUG ') 5321 WRITE(ICOUT,9012)IFOUND,IERROR 5322 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 5323 CALL DPWRST('XXX','BUG ') 5324 WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 5325 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 5326 1 I8,I8,I8,2X,A4,2X,A4,2X,A4) 5327 CALL DPWRST('XXX','BUG ') 5328 IF(NPLOTP.GT.0)THEN 5329 DO9015I=1,NPLOTP 5330 WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 5331 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) 5332 CALL DPWRST('XXX','BUG ') 5333 9015 CONTINUE 5334 ENDIF 5335 ENDIF 5336C 5337 RETURN 5338 END 5339 SUBROUTINE DPRPL2(Y1,N,X1,NGROUP,XCEN,NCENS,ICASPL,MAXN, 5340 1XIDTEM,TEMP2,TEMP3,TEMP4,TEMP5, 5341 1Y,X,D,NPLOTP,NPLOTV, 5342 1IBUGG3,ISUBRO,IERROR) 5343C 5344C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS 5345C THAT WILL DEFINE A REPAIR PLOT. 5346C PLOT THE REPAIR TIMES FOR EACH GROUP, EACH GROUP 5347C MAY HAVE A SINGLE CENSORING TIME. 5348C INPUT ARGUMENTS--Y1 = THE SINGLE PRECISION VECTOR OF 5349C (UNSORTED) REPAIR/CENSORING TIMES. 5350C --X1 = THE OPTIONAL SINGLE PRECISION VECTOR 5351C GROUP-ID VALUES 5352C --XCENS = THE OPTIONAL SINGLE PRECISION VECTOR 5353C OF CENSOR VALUES (1 = REPAIR 5354C TIME, 0 = CENSOR TIME). 5355C NY = THE INTEGER NUMBER OF OBSERVATIONS 5356C IN THE VECTOR Y1. 5357C NX = THE INTEGER NUMBER OF OBSERVATIONS 5358C IN THE VECTOR X1. 5359C NC = THE INTEGER NUMBER OF OBSERVATIONS 5360C IN THE VECTOR XCEN. 5361C REFERENCE--TOBIAS AND TRINDADE (1995), "APPLIED 5362C RELIABILITY", SECOND EDITION, CHAPMAN AND HALL, 5363C PP. 314. 5364C WRITTEN BY--JAMES J. FILLIBEN 5365C STATISTICAL ENGINEERING DIVISION 5366C INFORMATION TECHNOLOGY LABORATORY 5367C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5368C GAITHERSBURG, MD 20899 5369C PHONE--301-975-2899 5370C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5371C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5372C LANGUAGE--ANSI FORTRAN (1977) 5373C VERSION NUMBER--2006/10 5374C ORIGINAL VERSION--OCTOBER 2006. 5375C 5376C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5377C 5378 CHARACTER*4 ICASPL 5379 CHARACTER*4 IBUGG3 5380 CHARACTER*4 ISUBRO 5381 CHARACTER*4 IERROR 5382C 5383 CHARACTER*4 ISUBN1 5384 CHARACTER*4 ISUBN2 5385C 5386C--------------------------------------------------------------------- 5387C 5388 DIMENSION Y1(*) 5389 DIMENSION X1(*) 5390 DIMENSION XCEN(*) 5391C 5392 DIMENSION XIDTEM(*) 5393 DIMENSION TEMP2(*) 5394 DIMENSION TEMP3(*) 5395 DIMENSION TEMP4(*) 5396 DIMENSION TEMP5(*) 5397C 5398 DIMENSION Y(*) 5399 DIMENSION X(*) 5400 DIMENSION D(*) 5401C 5402C--------------------------------------------------------------------- 5403C 5404 INCLUDE 'DPCOP2.INC' 5405C 5406C-----START POINT----------------------------------------------------- 5407C 5408 ISUBN1='DPRP' 5409 ISUBN2='L2 ' 5410 IERROR='NO' 5411C 5412 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'RPL2')THEN 5413 WRITE(ICOUT,999) 5414 999 FORMAT(1X) 5415 CALL DPWRST('XXX','BUG ') 5416 WRITE(ICOUT,51) 5417 51 FORMAT('***** AT THE BEGINNING OF DPRPL2--') 5418 CALL DPWRST('XXX','BUG ') 5419 WRITE(ICOUT,52)IBUGG3,ISUBRO,IERROR 5420 52 FORMAT('IBUGG3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) 5421 CALL DPWRST('XXX','BUG ') 5422 WRITE(ICOUT,53)N,NGROUP,NCENS,ICASPL,MAXN 5423 53 FORMAT('N,NGROUP,NCENS,ICASPL,MAXN = ',3I10,2X,A4,I8) 5424 CALL DPWRST('XXX','BUG ') 5425 DO55I=1,N 5426 WRITE(ICOUT,56)I,Y1(I),X1(I),XCEN(I) 5427 56 FORMAT('I, Y1(I),X1(I),XCEN(I) = ',I10,3G15.7) 5428 CALL DPWRST('XXX','BUG ') 5429 55 CONTINUE 5430 ENDIF 5431C 5432C ******************************************** 5433C ** STEP 1-- ** 5434C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 5435C ******************************************** 5436C 5437 IF(N.LT.2)THEN 5438 WRITE(ICOUT,999) 5439 CALL DPWRST('XXX','BUG ') 5440 WRITE(ICOUT,111) 5441 111 FORMAT('***** ERROR IN REPAIR PLOT--') 5442 CALL DPWRST('XXX','BUG ') 5443 WRITE(ICOUT,112) 5444 112 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2;') 5445 CALL DPWRST('XXX','BUG ') 5446 WRITE(ICOUT,114)N 5447 114 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I8) 5448 CALL DPWRST('XXX','BUG ') 5449 WRITE(ICOUT,999) 5450 CALL DPWRST('XXX','BUG ') 5451 IERROR='YES' 5452 GOTO9000 5453 ENDIF 5454C 5455 HOLD=Y1(1) 5456 DO120I=1,N 5457 IF(Y1(I).NE.HOLD)GOTO129 5458 120 CONTINUE 5459 WRITE(ICOUT,999) 5460 CALL DPWRST('XXX','BUG ') 5461 WRITE(ICOUT,121) 5462 121 FORMAT('***** ERROR IN REPAIR PLOT--') 5463 CALL DPWRST('XXX','BUG ') 5464 WRITE(ICOUT,122)HOLD 5465 122 FORMAT(' ALL ELEMENTS IN RESPONSE VARIABLE ARE ', 5466 1 'IDENTICALLY EQUAL TO ',G15.7) 5467 CALL DPWRST('XXX','BUG ') 5468 WRITE(ICOUT,999) 5469 CALL DPWRST('XXX','BUG ') 5470 IERROR='YES' 5471 GOTO9000 5472 129 CONTINUE 5473C 5474C **************************************************** 5475C ** STEP 12-- ** 5476C ** COMPUTE COORDINATES FOR MEAN REPAIR FUNCTION ** 5477C ** PLOT ** 5478C **************************************************** 5479C 5480C CASE 1: NO GROUP OR CENSORING VARIABLE 5481C 5482 IF(NGROUP.EQ.0 .AND. NCENS.EQ.0)THEN 5483 CALL SORT(Y1,N,Y1) 5484 DO1000I=1,N 5485 Y(I)=1.0 5486 X(I)=Y1(I) 5487 D(I)=1.0 5488 1000 CONTINUE 5489 NPLOTP=N 5490C 5491C CASE 2: GROUP VARIABLE, BUT NO CENSORING VARIABLE 5492C 5493 ELSEIF(NCENS.EQ.0)THEN 5494C 5495C STEP 1: DETERMINE UNIQUE GROUPS 5496C 5497 NUMSET=0 5498 DO1051I=1,N 5499 IF(NUMSET.EQ.0)GOTO1053 5500 DO1052J=1,NUMSET 5501 IF(X1(I).EQ.XIDTEM(J))GOTO1051 5502 1052 CONTINUE 5503 1053 CONTINUE 5504 NUMSET=NUMSET+1 5505 XIDTEM(NUMSET)=X1(I) 5506 1051 CONTINUE 5507 CALL SORT(XIDTEM,NUMSET,XIDTEM) 5508C 5509C STEP 2: GENERATE TRACES FOR EACH GROUP 5510C 5511 J=0 5512 DO1090ISET=1,NUMSET 5513C 5514 K=0 5515 DO1091I=1,N 5516 IF(X1(I).EQ.XIDTEM(ISET))THEN 5517 K=K+1 5518 TEMP2(K)=Y1(I) 5519 ENDIF 55201091 CONTINUE 5521 NI=K 5522 CALL SORT(TEMP2,NI,TEMP2) 5523 DO1096I=1,NI 5524 J=J+1 5525 Y(J)=XIDTEM(ISET) 5526 X(J)=TEMP2(I) 5527 D(J)=REAL(ISET) 55281096 CONTINUE 55291090 CONTINUE 5530 NPLOTP=J 5531C 5532C CASE 3: BOTH GROUP VARIABLE AND CENSORING VARIABLE 5533C 5534 ELSE 5535C 5536C STEP 1: DETERMINE UNIQUE GROUPS 5537C 5538 NUMSET=0 5539 DO1111I=1,N 5540 IF(NUMSET.EQ.0)GOTO1113 5541 DO1112J=1,NUMSET 5542 IF(X1(I).EQ.XIDTEM(J))GOTO1111 5543 1112 CONTINUE 5544 1113 CONTINUE 5545 NUMSET=NUMSET+1 5546 XIDTEM(NUMSET)=X1(I) 5547 1111 CONTINUE 5548 CALL SORT(XIDTEM,NUMSET,XIDTEM) 5549C 5550C STEP 2A: EXTRACT RESPONSE AND CENSORING DATA FOR EACH 5551C GROUP 5552C 5553 J=0 5554 ISETMX=NUMSET 5555 DO1120ISET=1,NUMSET 5556C 5557 K=0 5558 DO1121I=1,N 5559 IF(X1(I).EQ.XIDTEM(ISET))THEN 5560 K=K+1 5561 TEMP2(K)=Y1(I) 5562 TEMP3(K)=XCEN(I) 5563 ENDIF 55641121 CONTINUE 5565 NI=K 5566C 5567C STEP 2B: PROCESS THE CENSORING VARIABLE. THERE CAN 5568C BE AT MOST ONE CENSORING POINT FOR EACH 5569C GROUP. 5570C 5571 CALL SORTC(TEMP2,TEMP3,NI,TEMP4,TEMP5) 5572 DO1160I=1,NI 5573 TEMP2(I)=TEMP4(I) 5574 TEMP3(I)=TEMP5(I) 5575 1160 CONTINUE 5576 AREP=TEMP3(1) 5577 ACEN=TEMP3(NI) 5578 IF(NI.LE.1)THEN 5579 NTEMPR=1 5580 NTEMPC=0 5581 ELSE 5582 IF(AREP.EQ.ACEN)THEN 5583 NTEMPR=NI 5584 NTEMPC=0 5585 DO1170I=1,NI 5586 IF(TEMP3(I).NE.AREP)THEN 5587 WRITE(ICOUT,999) 5588 CALL DPWRST('XXX','BUG ') 5589 WRITE(ICOUT,121) 5590 CALL DPWRST('XXX','BUG ') 5591 WRITE(ICOUT,1171) 5592 CALL DPWRST('XXX','BUG ') 5593 WRITE(ICOUT,1172) 5594 CALL DPWRST('XXX','BUG ') 5595 WRITE(ICOUT,1173) 5596 CALL DPWRST('XXX','BUG ') 5597 WRITE(ICOUT,1174)XIDTEM(ISET) 5598 CALL DPWRST('XXX','BUG ') 5599 IERROR='YES' 5600 GOTO9000 5601 ENDIF 5602 1170 CONTINUE 5603 ELSE 5604 NTEMPR=NI-1 5605 NTEMPC=1 5606 DO1180I=1,NTEMPR 5607 IF(TEMP3(I).NE.AREP)THEN 5608 WRITE(ICOUT,999) 5609 CALL DPWRST('XXX','BUG ') 5610 WRITE(ICOUT,121) 5611 CALL DPWRST('XXX','BUG ') 5612 WRITE(ICOUT,1171) 5613 CALL DPWRST('XXX','BUG ') 5614 WRITE(ICOUT,1172) 5615 CALL DPWRST('XXX','BUG ') 5616 WRITE(ICOUT,1173) 5617 CALL DPWRST('XXX','BUG ') 5618 WRITE(ICOUT,1174)XIDTEM(ISET) 5619 CALL DPWRST('XXX','BUG ') 5620 IERROR='YES' 5621 GOTO9000 5622 ENDIF 5623 1180 CONTINUE 5624 ENDIF 5625 ENDIF 5626 1171 FORMAT(' FOR EACH SYSTEM, THERE SHOULD BE AT MOST') 5627 1172 FORMAT(' CENSORING TIME AND IT MUST BE THE MAXIMUM') 5628 1173 FORMAT(' VALUE FOR THAT SYSTEM.') 5629 1174 FORMAT(' SUCH WAS NOT THE CASE FOR SYSTEM ',G15.7) 5630C 5631C STEP 2C: TRACE 1 IS SIMPLY ALL OF THE REPAIR TIMES 5632C (I.E., OMIT THE CENSORING TIME). THEN TRACES 5633C 2 - NUMBER OF SYSTEMS + 1 ARE THE REPAIR PLUS 5634C CENSORING TIMES FOR EACH SYSTEM. 5635C 5636 DO1191I=1,NTEMPR 5637 J=J+1 5638 Y(J)=XIDTEM(ISET) 5639 X(J)=TEMP2(I) 5640 D(J)=1.0 56411191 CONTINUE 5642C 5643 DO1196I=1,NI 5644 J=J+1 5645 Y(J)=XIDTEM(ISET) 5646 X(J)=TEMP2(I) 5647 D(J)=REAL(ISET+1) 56481196 CONTINUE 5649C 56501120 CONTINUE 5651 NPLOTP=J 5652 ENDIF 5653C 5654 NPLOTV=2 5655C 5656C ****************** 5657C ** STEP 90-- ** 5658C ** EXIT ** 5659C ****************** 5660C 5661 9000 CONTINUE 5662 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'RPL2')THEN 5663 WRITE(ICOUT,999) 5664 CALL DPWRST('XXX','BUG ') 5665 WRITE(ICOUT,9011) 5666 9011 FORMAT('***** AT THE END OF DPRPL2--') 5667 CALL DPWRST('XXX','BUG ') 5668 WRITE(ICOUT,9012)IBUGG3,ISUBRO,IERROR 5669 9012 FORMAT('IBUGG3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) 5670 CALL DPWRST('XXX','BUG ') 5671 WRITE(ICOUT,9013)N,ICASPL,MAXN 5672 9013 FORMAT('N,ICASPL,MAXN = ',I8,2X,A4,I8) 5673 CALL DPWRST('XXX','BUG ') 5674 WRITE(ICOUT,9021)NPLOTP,NPLOTV 5675 9021 FORMAT('NPLOTP,NPLOTV = ',2I8) 5676 CALL DPWRST('XXX','BUG ') 5677 DO9022I=1,NPLOTP 5678 WRITE(ICOUT,9023)I,Y(I),X(I),D(I) 5679 9023 FORMAT('I,Y(I),X(I),D(I) = ',I8,3E15.7) 5680 CALL DPWRST('XXX','BUG ') 5681 9022 CONTINUE 5682 ENDIF 5683C 5684 RETURN 5685 END 5686 SUBROUTINE DPRPSP(IHARG,IARGT,ARG,NUMARG,PDERPS,MAXREG,PREPSP, 5687 1IBUGP2,IFOUND,IERROR) 5688C 5689C PURPOSE--DEFINE THE REGION PATTERN SPACINGS = THE SPACINGS 5690C BETWEEN THE LINES WHICH MAKE UP THE PATTERNS WITHIN THE REGIONS. 5691C THESE ARE LOCATED IN THE VECTOR PREPSP(.). 5692C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 5693C --IARGT (A CHARACTER VECTOR) 5694C --ARG 5695C --NUMARG 5696C --PDERPS 5697C --MAXREG 5698C --IBUGP2 ('ON' OR 'OFF' ) 5699C OUTPUT ARGUMENTS--PREPSP (A FLOATING POINT VECTOR) 5700C --IFOUND ('YES' OR 'NO' ) 5701C --IERROR ('YES' OR 'NO' ) 5702C WRITTEN BY--JAMES J. FILLIBEN 5703C STATISTICAL ENGINEERING DIVISION 5704C INFORMATION TECHNOLOGY LABORATORY 5705C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5706C GAITHERSBURG, MD 20899 5707C PHONE--301-975-2855 5708C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5709C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5710C LANGUAGE--ANSI FORTRAN (1977) 5711C VERSION NUMBER--82/7 5712C ORIGINAL VERSION--DECEMBER 1983. 5713C 5714C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5715C 5716 CHARACTER*4 IHARG 5717 CHARACTER*4 IARGT 5718C 5719 CHARACTER*4 IBUGP2 5720 CHARACTER*4 IFOUND 5721 CHARACTER*4 IERROR 5722C 5723 CHARACTER*4 IHOLD1 5724C 5725 CHARACTER*4 ISUBN1 5726 CHARACTER*4 ISUBN2 5727 CHARACTER*4 ISTEPN 5728C 5729 DIMENSION IHARG(*) 5730 DIMENSION IARGT(*) 5731 DIMENSION ARG(*) 5732 DIMENSION PREPSP(*) 5733C 5734C--------------------------------------------------------------------- 5735C 5736 INCLUDE 'DPCOP2.INC' 5737C 5738C-----START POINT----------------------------------------------------- 5739C 5740 IFOUND='NO' 5741 IERROR='NO' 5742 ISUBN1='DPRP' 5743 ISUBN2='SP ' 5744C 5745 NUMREG=0 5746 IHOLD1='-999' 5747 HOLD1=-999.0 5748 HOLD2=-999.0 5749C 5750 IF(IBUGP2.EQ.'OFF')GOTO90 5751 WRITE(ICOUT,999) 5752 999 FORMAT(1X) 5753 CALL DPWRST('XXX','BUG ') 5754 WRITE(ICOUT,51) 5755 51 FORMAT('***** AT THE BEGINNING OF DPRPSP--') 5756 CALL DPWRST('XXX','BUG ') 5757 WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 5758 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 5759 CALL DPWRST('XXX','BUG ') 5760 WRITE(ICOUT,53)MAXREG,NUMREG 5761 53 FORMAT('MAXREG,NUMREG = ',I8,I8) 5762 CALL DPWRST('XXX','BUG ') 5763 WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2 5764 54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) 5765 CALL DPWRST('XXX','BUG ') 5766 WRITE(ICOUT,55)PDERPS 5767 55 FORMAT('PDERPS = ',E15.7) 5768 CALL DPWRST('XXX','BUG ') 5769 WRITE(ICOUT,60)NUMARG 5770 60 FORMAT('NUMARG = ',I8) 5771 CALL DPWRST('XXX','BUG ') 5772 DO65I=1,NUMARG 5773 WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I) 5774 66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) 5775 CALL DPWRST('XXX','BUG ') 5776 65 CONTINUE 5777 WRITE(ICOUT,70)PREPSP(1) 5778 70 FORMAT('PREPSP(1) = ',E15.7) 5779 CALL DPWRST('XXX','BUG ') 5780 DO75I=1,10 5781 WRITE(ICOUT,76)I,PREPSP(I) 5782 76 FORMAT('I,PREPSP(I) = ',I8,2X,E15.7) 5783 CALL DPWRST('XXX','BUG ') 5784 75 CONTINUE 5785 90 CONTINUE 5786C 5787C ************************************** 5788C ** STEP 1-- ** 5789C ** BRANCH TO THE APPROPRIATE CASE ** 5790C ************************************** 5791C 5792 ISTEPN='1' 5793 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5794C 5795 IF(NUMARG.LE.1)GOTO9000 5796 IF(NUMARG.EQ.2)GOTO1120 5797 IF(NUMARG.EQ.3)GOTO1130 5798 IF(NUMARG.EQ.4)GOTO1140 5799 GOTO1150 5800C 5801 1120 CONTINUE 5802 GOTO1200 5803C 5804 1130 CONTINUE 5805 IF(IHARG(3).EQ.'ALL')IHOLD1=' ' 5806 IF(IHARG(3).EQ.'ALL')HOLD1=PDERPS 5807 IF(IHARG(3).EQ.'ALL')GOTO1300 5808 GOTO1200 5809C 5810 1140 CONTINUE 5811 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) 5812 IF(IHARG(3).EQ.'ALL')HOLD1=ARG(4) 5813 IF(IHARG(3).EQ.'ALL')GOTO1300 5814 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) 5815 IF(IHARG(4).EQ.'ALL')HOLD1=ARG(3) 5816 IF(IHARG(4).EQ.'ALL')GOTO1300 5817 GOTO1200 5818C 5819 1150 CONTINUE 5820 GOTO1200 5821C 5822C ************************************************* 5823C ** STEP 2-- ** 5824C ** TREAT THE SINGLE SPECIFICATION CASE ** 5825C ************************************************* 5826C 5827 1200 CONTINUE 5828 ISTEPN='2' 5829 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5830C 5831 IF(NUMARG.LE.2)GOTO1210 5832 GOTO1220 5833C 5834 1210 CONTINUE 5835 NUMREG=1 5836 PREPSP(1)=PDERPS 5837 GOTO1270 5838C 5839 1220 CONTINUE 5840 NUMREG=NUMARG-2 5841 IF(NUMREG.GT.MAXREG)NUMREG=MAXREG 5842 DO1225I=1,NUMREG 5843 J=I+2 5844 IHOLD1=IHARG(J) 5845 HOLD1=ARG(J) 5846 HOLD2=HOLD1 5847 IF(IHOLD1.EQ.'ON')HOLD2=PDERPS 5848 IF(IHOLD1.EQ.'OFF')HOLD2=PDERPS 5849 IF(IHOLD1.EQ.'AUTO')HOLD2=PDERPS 5850 IF(IHOLD1.EQ.'DEFA')HOLD2=PDERPS 5851 PREPSP(I)=HOLD2 5852 1225 CONTINUE 5853 GOTO1270 5854C 5855 1270 CONTINUE 5856 IF(IFEEDB.EQ.'OFF')GOTO1279 5857 WRITE(ICOUT,999) 5858 CALL DPWRST('XXX','BUG ') 5859 DO1278I=1,NUMREG 5860 WRITE(ICOUT,1276)I,PREPSP(I) 5861 1276 FORMAT('THE SPACING BETWEEN (LINES WITHIN) PATTERN ',I6, 5862 1' HAS JUST BEEN SET TO ',E15.7) 5863 CALL DPWRST('XXX','BUG ') 5864 1278 CONTINUE 5865 1279 CONTINUE 5866 IFOUND='YES' 5867 GOTO9000 5868C 5869C ************************** 5870C ** STEP 3-- ** 5871C ** TREAT THE ALL CASE ** 5872C ************************** 5873C 5874 1300 CONTINUE 5875 ISTEPN='3' 5876 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5877C 5878 NUMREG=MAXREG 5879 HOLD2=HOLD1 5880 IF(IHOLD1.EQ.'ON')HOLD2=PDERPS 5881 IF(IHOLD1.EQ.'OFF')HOLD2=PDERPS 5882 IF(IHOLD1.EQ.'AUTO')HOLD2=PDERPS 5883 IF(IHOLD1.EQ.'DEFA')HOLD2=PDERPS 5884 DO1315I=1,NUMREG 5885 PREPSP(I)=HOLD2 5886 1315 CONTINUE 5887 GOTO1370 5888C 5889 1370 CONTINUE 5890 IF(IFEEDB.EQ.'OFF')GOTO1319 5891 WRITE(ICOUT,999) 5892 CALL DPWRST('XXX','BUG ') 5893 I=1 5894 WRITE(ICOUT,1316)PREPSP(I) 5895 1316 FORMAT('THE SPACING BETWEEN (LINES WITHIN) ALL PATTERNS', 5896 1' HAS JUST BEEN SET TO ',E15.7) 5897 CALL DPWRST('XXX','BUG ') 5898 1319 CONTINUE 5899 IFOUND='YES' 5900 GOTO9000 5901C 5902C ***************** 5903C ** STEP 90-- ** 5904C ** EXIT ** 5905C ***************** 5906C 5907 9000 CONTINUE 5908 IF(IBUGP2.EQ.'OFF')GOTO9090 5909 WRITE(ICOUT,9011) 5910 9011 FORMAT('***** AT THE END OF DPRPSP--') 5911 CALL DPWRST('XXX','BUG ') 5912 WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 5913 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 5914 CALL DPWRST('XXX','BUG ') 5915 WRITE(ICOUT,9013)MAXREG,NUMREG 5916 9013 FORMAT('MAXREG,NUMREG = ',I8,I8) 5917 CALL DPWRST('XXX','BUG ') 5918 WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2 5919 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) 5920 CALL DPWRST('XXX','BUG ') 5921 WRITE(ICOUT,9015)PDERPS 5922 9015 FORMAT('PDERPS = ',E15.7) 5923 CALL DPWRST('XXX','BUG ') 5924 WRITE(ICOUT,9020)NUMARG 5925 9020 FORMAT('NUMARG = ',I8) 5926 CALL DPWRST('XXX','BUG ') 5927 DO9025I=1,NUMARG 5928 WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I) 5929 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) 5930 CALL DPWRST('XXX','BUG ') 5931 9025 CONTINUE 5932 WRITE(ICOUT,9030)PREPSP(1) 5933 9030 FORMAT('PREPSP(1) = ',E15.7) 5934 CALL DPWRST('XXX','BUG ') 5935 DO9035I=1,10 5936 WRITE(ICOUT,9036)I,PREPSP(I) 5937 9036 FORMAT('I,PREPSP(I) = ',I8,2X,E15.7) 5938 CALL DPWRST('XXX','BUG ') 5939 9035 CONTINUE 5940 9090 CONTINUE 5941C 5942 RETURN 5943 END 5944 SUBROUTINE DPRPTH(IHARG,IARGT,ARG,NUMARG,PDERPT,MAXREG,PREPTH, 5945 1IBUGP2,IFOUND,IERROR) 5946C 5947C PURPOSE--DEFINE THE REGION PATTERN THICKNESSES = THE THICKNESSES 5948C OF THE LINES WHICH MAKE UP THE PATTERNS WITHIN THE REGIONS. 5949C THESE ARE LOCATED IN THE VECTOR PREPTH(.). 5950C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 5951C --IARGT (A CHARACTER VECTOR) 5952C --ARG 5953C --NUMARG 5954C --PDERPT 5955C --MAXREG 5956C --IBUGP2 ('ON' OR 'OFF' ) 5957C OUTPUT ARGUMENTS--PREPTH (A FLOATING POINT VECTOR) 5958C --IFOUND ('YES' OR 'NO' ) 5959C --IERROR ('YES' OR 'NO' ) 5960C WRITTEN BY--JAMES J. FILLIBEN 5961C STATISTICAL ENGINEERING DIVISION 5962C INFORMATION TECHNOLOGY LABORATORY 5963C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5964C GAITHERSBURG, MD 20899 5965C PHONE--301-975-2855 5966C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5967C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5968C LANGUAGE--ANSI FORTRAN (1977) 5969C VERSION NUMBER--82/7 5970C ORIGINAL VERSION--DECEMBER 1983. 5971C 5972C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5973C 5974 CHARACTER*4 IHARG 5975 CHARACTER*4 IARGT 5976C 5977 CHARACTER*4 IBUGP2 5978 CHARACTER*4 IFOUND 5979 CHARACTER*4 IERROR 5980C 5981 CHARACTER*4 IHOLD1 5982C 5983 CHARACTER*4 ISUBN1 5984 CHARACTER*4 ISUBN2 5985 CHARACTER*4 ISTEPN 5986C 5987 DIMENSION IHARG(*) 5988 DIMENSION IARGT(*) 5989 DIMENSION ARG(*) 5990 DIMENSION PREPTH(*) 5991C 5992C--------------------------------------------------------------------- 5993C 5994 INCLUDE 'DPCOP2.INC' 5995C 5996C-----START POINT----------------------------------------------------- 5997C 5998 IFOUND='NO' 5999 IERROR='NO' 6000 ISUBN1='DPRP' 6001 ISUBN2='TH ' 6002C 6003 NUMREG=0 6004 IHOLD1='-999' 6005 HOLD1=-999.0 6006 HOLD2=-999.0 6007C 6008 IF(IBUGP2.EQ.'OFF')GOTO90 6009 WRITE(ICOUT,999) 6010 999 FORMAT(1X) 6011 CALL DPWRST('XXX','BUG ') 6012 WRITE(ICOUT,51) 6013 51 FORMAT('***** AT THE BEGINNING OF DPRPTH--') 6014 CALL DPWRST('XXX','BUG ') 6015 WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 6016 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 6017 CALL DPWRST('XXX','BUG ') 6018 WRITE(ICOUT,53)MAXREG,NUMREG 6019 53 FORMAT('MAXREG,NUMREG = ',I8,I8) 6020 CALL DPWRST('XXX','BUG ') 6021 WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2 6022 54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) 6023 CALL DPWRST('XXX','BUG ') 6024 WRITE(ICOUT,55)PDERPT 6025 55 FORMAT('PDERPT = ',E15.7) 6026 CALL DPWRST('XXX','BUG ') 6027 WRITE(ICOUT,60)NUMARG 6028 60 FORMAT('NUMARG = ',I8) 6029 CALL DPWRST('XXX','BUG ') 6030 DO65I=1,NUMARG 6031 WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I) 6032 66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) 6033 CALL DPWRST('XXX','BUG ') 6034 65 CONTINUE 6035 WRITE(ICOUT,70)PREPTH(1) 6036 70 FORMAT('PREPTH(1) = ',E15.7) 6037 CALL DPWRST('XXX','BUG ') 6038 DO75I=1,10 6039 WRITE(ICOUT,76)I,PREPTH(I) 6040 76 FORMAT('I,PREPTH(I) = ',I8,2X,E15.7) 6041 CALL DPWRST('XXX','BUG ') 6042 75 CONTINUE 6043 90 CONTINUE 6044C 6045C ************************************** 6046C ** STEP 1-- ** 6047C ** BRANCH TO THE APPROPRIATE CASE ** 6048C ************************************** 6049C 6050 ISTEPN='1' 6051 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6052C 6053 IF(NUMARG.LE.1)GOTO9000 6054 IF(NUMARG.EQ.2)GOTO1120 6055 IF(NUMARG.EQ.3)GOTO1130 6056 IF(NUMARG.EQ.4)GOTO1140 6057 GOTO1150 6058C 6059 1120 CONTINUE 6060 GOTO1200 6061C 6062 1130 CONTINUE 6063 IF(IHARG(3).EQ.'ALL')IHOLD1=' ' 6064 IF(IHARG(3).EQ.'ALL')HOLD1=PDERPT 6065 IF(IHARG(3).EQ.'ALL')GOTO1300 6066 GOTO1200 6067C 6068 1140 CONTINUE 6069 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) 6070 IF(IHARG(3).EQ.'ALL')HOLD1=ARG(4) 6071 IF(IHARG(3).EQ.'ALL')GOTO1300 6072 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) 6073 IF(IHARG(4).EQ.'ALL')HOLD1=ARG(2) 6074 IF(IHARG(4).EQ.'ALL')GOTO1300 6075 GOTO1200 6076C 6077 1150 CONTINUE 6078 GOTO1200 6079C 6080C ************************************************* 6081C ** STEP 2-- ** 6082C ** TREAT THE SINGLE SPECIFICATION CASE ** 6083C ************************************************* 6084C 6085 1200 CONTINUE 6086 ISTEPN='2' 6087 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6088C 6089 IF(NUMARG.LE.2)GOTO1210 6090 GOTO1220 6091C 6092 1210 CONTINUE 6093 NUMREG=1 6094 PREPTH(1)=PDERPT 6095 GOTO1270 6096C 6097 1220 CONTINUE 6098 NUMREG=NUMARG-2 6099 IF(NUMREG.GT.MAXREG)NUMREG=MAXREG 6100 DO1225I=1,NUMREG 6101 J=I+2 6102 IHOLD1=IHARG(J) 6103 HOLD1=ARG(J) 6104 HOLD2=HOLD1 6105 IF(IHOLD1.EQ.'ON')HOLD2=PDERPT 6106 IF(IHOLD1.EQ.'OFF')HOLD2=PDERPT 6107 IF(IHOLD1.EQ.'AUTO')HOLD2=PDERPT 6108 IF(IHOLD1.EQ.'DEFA')HOLD2=PDERPT 6109 PREPTH(I)=HOLD2 6110 1225 CONTINUE 6111 GOTO1270 6112C 6113 1270 CONTINUE 6114 IF(IFEEDB.EQ.'OFF')GOTO1279 6115 WRITE(ICOUT,999) 6116 CALL DPWRST('XXX','BUG ') 6117 DO1278I=1,NUMREG 6118 WRITE(ICOUT,1276)I,PREPTH(I) 6119 1276 FORMAT('THE THICKNESS OF (LINES WITHIN) PATTERN ',I6, 6120 1' HAS JUST BEEN SET TO ',E15.7) 6121 CALL DPWRST('XXX','BUG ') 6122 1278 CONTINUE 6123 1279 CONTINUE 6124 IFOUND='YES' 6125 GOTO9000 6126C 6127C ************************** 6128C ** STEP 3-- ** 6129C ** TREAT THE ALL CASE ** 6130C ************************** 6131C 6132 1300 CONTINUE 6133 ISTEPN='3' 6134 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6135C 6136 NUMREG=MAXREG 6137 HOLD2=HOLD1 6138 IF(IHOLD1.EQ.'ON')HOLD2=PDERPT 6139 IF(IHOLD1.EQ.'OFF')HOLD2=PDERPT 6140 IF(IHOLD1.EQ.'AUTO')HOLD2=PDERPT 6141 IF(IHOLD1.EQ.'DEFA')HOLD2=PDERPT 6142 DO1315I=1,NUMREG 6143 PREPTH(I)=HOLD2 6144 1315 CONTINUE 6145 GOTO1370 6146C 6147 1370 CONTINUE 6148 IF(IFEEDB.EQ.'OFF')GOTO1319 6149 WRITE(ICOUT,999) 6150 CALL DPWRST('XXX','BUG ') 6151 I=1 6152 WRITE(ICOUT,1316)PREPTH(I) 6153 1316 FORMAT('THE THICKNESS OF (LINES WITHIN) ALL PATTERNS', 6154 1' HAS JUST BEEN SET TO ',E15.7) 6155 CALL DPWRST('XXX','BUG ') 6156 1319 CONTINUE 6157 IFOUND='YES' 6158 GOTO9000 6159C 6160C ***************** 6161C ** STEP 90-- ** 6162C ** EXIT ** 6163C ***************** 6164C 6165 9000 CONTINUE 6166 IF(IBUGP2.EQ.'OFF')GOTO9090 6167 WRITE(ICOUT,9011) 6168 9011 FORMAT('***** AT THE END OF DPRPTH--') 6169 CALL DPWRST('XXX','BUG ') 6170 WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 6171 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 6172 CALL DPWRST('XXX','BUG ') 6173 WRITE(ICOUT,9013)MAXREG,NUMREG 6174 9013 FORMAT('MAXREG,NUMREG = ',I8,I8) 6175 CALL DPWRST('XXX','BUG ') 6176 WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2 6177 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) 6178 CALL DPWRST('XXX','BUG ') 6179 WRITE(ICOUT,9015)PDERPT 6180 9015 FORMAT('PDERPT = ',E15.7) 6181 CALL DPWRST('XXX','BUG ') 6182 WRITE(ICOUT,9020)NUMARG 6183 9020 FORMAT('NUMARG = ',I8) 6184 CALL DPWRST('XXX','BUG ') 6185 DO9025I=1,NUMARG 6186 WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I) 6187 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) 6188 CALL DPWRST('XXX','BUG ') 6189 9025 CONTINUE 6190 WRITE(ICOUT,9030)PREPTH(1) 6191 9030 FORMAT('PREPTH(1) = ',E15.7) 6192 CALL DPWRST('XXX','BUG ') 6193 DO9035I=1,10 6194 WRITE(ICOUT,9036)I,PREPTH(I) 6195 9036 FORMAT('I,PREPTH(I) = ',I8,2X,E15.7) 6196 CALL DPWRST('XXX','BUG ') 6197 9035 CONTINUE 6198 9090 CONTINUE 6199C 6200 RETURN 6201 END 6202 SUBROUTINE DPRPTY(IHARG,NUMARG,IDERPT,MAXREG,IREPTY, 6203 1IBUGP2,IFOUND,IERROR) 6204C 6205C PURPOSE--DEFINE THE PATTERN TYPES = THE TYPES 6206C OF THE PATTERN WITHIN THE REGIONS. 6207C THESE ARE LOCATED IN THE VECTOR IREPTY(.). 6208C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 6209C --NUMARG 6210C --IDERPT 6211C --MAXREG 6212C --IBUGP2 ('ON' OR 'OFF' ) 6213C OUTPUT ARGUMENTS--IREPTY (A CHARACTER VECTOR) 6214C --IFOUND ('YES' OR 'NO' ) 6215C --IERROR ('YES' OR 'NO' ) 6216C WRITTEN BY--JAMES J. FILLIBEN 6217C STATISTICAL ENGINEERING DIVISION 6218C INFORMATION TECHNOLOGY LABORATORY 6219C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 6220C GAITHERSBURG, MD 20899 6221C PHONE--301-975-2855 6222C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 6223C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 6224C LANGUAGE--ANSI FORTRAN (1977) 6225C VERSION NUMBER--82/7 6226C ORIGINAL VERSION--DECEMBER 1983. 6227C 6228C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 6229C 6230 CHARACTER*4 IHARG 6231 CHARACTER*4 IDERPT 6232 CHARACTER*4 IREPTY 6233C 6234 CHARACTER*4 IBUGP2 6235 CHARACTER*4 IFOUND 6236 CHARACTER*4 IERROR 6237C 6238 CHARACTER*4 IHOLD1 6239 CHARACTER*4 IHOLD2 6240C 6241 CHARACTER*4 ISUBN1 6242 CHARACTER*4 ISUBN2 6243 CHARACTER*4 ISTEPN 6244C 6245 DIMENSION IHARG(*) 6246 DIMENSION IREPTY(*) 6247C 6248C--------------------------------------------------------------------- 6249C 6250 INCLUDE 'DPCOP2.INC' 6251C 6252C-----START POINT----------------------------------------------------- 6253C 6254 IFOUND='NO' 6255 IERROR='NO' 6256 ISUBN1='DPRP' 6257 ISUBN2='TY ' 6258C 6259 NUMREG=0 6260 IHOLD1='-999' 6261 IHOLD2='-999' 6262C 6263 IF(IBUGP2.EQ.'OFF')GOTO90 6264 WRITE(ICOUT,999) 6265 999 FORMAT(1X) 6266 CALL DPWRST('XXX','BUG ') 6267 WRITE(ICOUT,51) 6268 51 FORMAT('***** AT THE BEGINNING OF DPRPTY--') 6269 CALL DPWRST('XXX','BUG ') 6270 WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 6271 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 6272 CALL DPWRST('XXX','BUG ') 6273 WRITE(ICOUT,53)MAXREG,NUMREG 6274 53 FORMAT('MAXREG,NUMREG = ',I8,I8) 6275 CALL DPWRST('XXX','BUG ') 6276 WRITE(ICOUT,54)IHOLD1,IHOLD2 6277 54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 6278 CALL DPWRST('XXX','BUG ') 6279 WRITE(ICOUT,55)IDERPT 6280 55 FORMAT('IDERPT = ',A4) 6281 CALL DPWRST('XXX','BUG ') 6282 WRITE(ICOUT,60)NUMARG 6283 60 FORMAT('NUMARG = ',I8) 6284 CALL DPWRST('XXX','BUG ') 6285 DO65I=1,NUMARG 6286 WRITE(ICOUT,66)IHARG(I) 6287 66 FORMAT('IHARG(I) = ',A4) 6288 CALL DPWRST('XXX','BUG ') 6289 65 CONTINUE 6290 WRITE(ICOUT,70)IREPTY(1) 6291 70 FORMAT('IREPTY(1) = ',A4) 6292 CALL DPWRST('XXX','BUG ') 6293 DO75I=1,10 6294 WRITE(ICOUT,76)I,IREPTY(I) 6295 76 FORMAT('I,IREPTY(I) = ',I8,2X,A4) 6296 CALL DPWRST('XXX','BUG ') 6297 75 CONTINUE 6298 90 CONTINUE 6299C 6300C ************************************** 6301C ** STEP 1-- ** 6302C ** BRANCH TO THE APPROPRIATE CASE ** 6303C ************************************** 6304C 6305 ISTEPN='1' 6306 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6307C 6308 IF(NUMARG.LE.1)GOTO9000 6309 IF(NUMARG.EQ.2)GOTO1120 6310 IF(NUMARG.EQ.3)GOTO1130 6311 IF(NUMARG.EQ.4)GOTO1140 6312 GOTO1150 6313C 6314 1120 CONTINUE 6315 GOTO1200 6316C 6317 1130 CONTINUE 6318 IF(IHARG(3).EQ.'ALL')IHOLD1=' ' 6319 IF(IHARG(3).EQ.'ALL')GOTO1300 6320 GOTO1200 6321C 6322 1140 CONTINUE 6323 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) 6324 IF(IHARG(3).EQ.'ALL')GOTO1300 6325 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) 6326 IF(IHARG(4).EQ.'ALL')GOTO1300 6327 GOTO1200 6328C 6329 1150 CONTINUE 6330 GOTO1200 6331C 6332C ************************************************* 6333C ** STEP 2-- ** 6334C ** TREAT THE SINGLE SPECIFICATION CASE ** 6335C ************************************************* 6336C 6337 1200 CONTINUE 6338 ISTEPN='2' 6339 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6340C 6341 IF(NUMARG.LE.2)GOTO1210 6342 GOTO1220 6343C 6344 1210 CONTINUE 6345 NUMREG=1 6346 IREPTY(1)=' ' 6347 GOTO1270 6348C 6349 1220 CONTINUE 6350 NUMREG=NUMARG-2 6351 IF(NUMREG.GT.MAXREG)NUMREG=MAXREG 6352 DO1225I=1,NUMREG 6353 J=I+2 6354 IHOLD1=IHARG(J) 6355 IHOLD2=IHOLD1 6356 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' 6357 IF(IHOLD1.EQ.'OFF')IHOLD2=' ' 6358 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDERPT 6359 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDERPT 6360 IREPTY(I)=IHOLD2 6361 1225 CONTINUE 6362 GOTO1270 6363C 6364 1270 CONTINUE 6365 IF(IFEEDB.EQ.'OFF')GOTO1279 6366 WRITE(ICOUT,999) 6367 CALL DPWRST('XXX','BUG ') 6368 DO1278I=1,NUMREG 6369 WRITE(ICOUT,1276)I,IREPTY(I) 6370 1276 FORMAT('THE TYPE FOR REGION PATTERN ',I6, 6371 1' HAS JUST BEEN SET TO ',A4) 6372 CALL DPWRST('XXX','BUG ') 6373 1278 CONTINUE 6374 1279 CONTINUE 6375 IFOUND='YES' 6376 GOTO9000 6377C 6378C ************************** 6379C ** STEP 3-- ** 6380C ** TREAT THE ALL CASE ** 6381C ************************** 6382C 6383 1300 CONTINUE 6384 ISTEPN='3' 6385 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6386C 6387 NUMREG=MAXREG 6388 IHOLD2=IHOLD1 6389 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' 6390 IF(IHOLD1.EQ.'OFF')IHOLD2=' ' 6391 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDERPT 6392 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDERPT 6393 DO1315I=1,NUMREG 6394 IREPTY(I)=IHOLD2 6395 1315 CONTINUE 6396 GOTO1370 6397C 6398 1370 CONTINUE 6399 IF(IFEEDB.EQ.'OFF')GOTO1319 6400 WRITE(ICOUT,999) 6401 CALL DPWRST('XXX','BUG ') 6402 I=1 6403 WRITE(ICOUT,1316)IREPTY(I) 6404 1316 FORMAT('THE TYPE FOR ALL REGION PATTERNS', 6405 1' HAS JUST BEEN SET TO ',A4) 6406 CALL DPWRST('XXX','BUG ') 6407 1319 CONTINUE 6408 IFOUND='YES' 6409 GOTO9000 6410C 6411C ***************** 6412C ** STEP 90-- ** 6413C ** EXIT ** 6414C ***************** 6415C 6416 9000 CONTINUE 6417 IF(IBUGP2.EQ.'OFF')GOTO9090 6418 WRITE(ICOUT,9011) 6419 9011 FORMAT('***** AT THE END OF DPRPTY--') 6420 CALL DPWRST('XXX','BUG ') 6421 WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 6422 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 6423 CALL DPWRST('XXX','BUG ') 6424 WRITE(ICOUT,9013)MAXREG,NUMREG 6425 9013 FORMAT('MAXREG,NUMREG = ',I8,I8) 6426 CALL DPWRST('XXX','BUG ') 6427 WRITE(ICOUT,9014)IHOLD1,IHOLD2 6428 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 6429 CALL DPWRST('XXX','BUG ') 6430 WRITE(ICOUT,9015)IDERPT 6431 9015 FORMAT('IDERPT = ',A4) 6432 CALL DPWRST('XXX','BUG ') 6433 WRITE(ICOUT,9020)NUMARG 6434 9020 FORMAT('NUMARG = ',I8) 6435 CALL DPWRST('XXX','BUG ') 6436 DO9025I=1,NUMARG 6437 WRITE(ICOUT,9026)IHARG(I) 6438 9026 FORMAT('IHARG(I) = ',A4) 6439 CALL DPWRST('XXX','BUG ') 6440 9025 CONTINUE 6441 WRITE(ICOUT,9030)IREPTY(1) 6442 9030 FORMAT('IREPTY(1) = ',A4) 6443 CALL DPWRST('XXX','BUG ') 6444 DO9035I=1,10 6445 WRITE(ICOUT,9036)I,IREPTY(I) 6446 9036 FORMAT('I,IREPTY(I) = ',I8,2X,A4) 6447 CALL DPWRST('XXX','BUG ') 6448 9035 CONTINUE 6449 9090 CONTINUE 6450C 6451 RETURN 6452 END 6453 SUBROUTINE DPROLA(IWRITE,IBUGA3,ISUBRO,IERROR) 6454C 6455C PURPOSE--THIS SUBROUTINE DOES THE FOLLOWING: 6456C 6457C 1) IT CHECKS THE FILE "DPZCHF.DAT" TO SEE IF THE 6458C SPECIFIED VARIABLE NAME IS FOUND. IF SO, IT 6459C READS THE CHARCTER DATA STORED IN DPZCHF.DAT 6460C AND SAVES IT IN THE ROWLABEL ARRAY. 6461C 6462C 2) IF THE VARIABLE NAME IS NOT FOUND IN THE 6463C CHARACTER DATA LIST, THEN CHECK THE NORMAL 6464C NUMERIC VARIABLE LIST. IF FOUND, CONVERT THIS 6465C NUMERIC VARIABLE TO ROW LABELS (E.G., THE LAB-ID 6466C MIGHT BE USED AS THE ROW LABEL). 6467C 6468C EXAMPLE: 6469C LET ROWLABEL = IX 6470C 6471C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 6472C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 6473C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 6474C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 6475C LANGUAGE--ANSI FORTRAN (1977) 6476C REFERENCES--NONE. 6477C WRITTEN BY--ALAN HECKERT 6478C STATISTICAL ENGINEERING DIVISION 6479C INFORMATION TECHNOLOGY LABORATORY 6480C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 6481C GAITHERSBURG, MD 20899-8980 6482C PHONE--301-975-2899 6483C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 6484C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 6485C LANGUAGE--ANSI FORTRAN (1977) 6486C VERSION NUMBER--2004/1 6487C ORIGINAL VERSION--JANUARY 2004. 6488C UPDATED --AUGUST 2012. CHECK FOR NUMERIC VARIABLE 6489C 6490C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 6491C 6492 CHARACTER*4 IWRITE 6493 CHARACTER*4 IBUGA3 6494 CHARACTER*4 ISUBRO 6495 CHARACTER*4 IERROR 6496C 6497 CHARACTER*4 ISTEPN 6498 CHARACTER*4 ISUBN1 6499 CHARACTER*4 ISUBN2 6500 CHARACTER*4 MESSAG 6501 CHARACTER*4 ICASEQ 6502 CHARACTER*4 IHWUSE 6503 CHARACTER*4 IH 6504 CHARACTER*4 IH2 6505 CHARACTER*4 IHRIGH 6506 CHARACTER*4 IHRIG2 6507C 6508 CHARACTER*4 ICTEXT(100) 6509C 6510C--------------------------------------------------------------------- 6511C 6512 INCLUDE 'DPCOPA.INC' 6513 INCLUDE 'DPCODA.INC' 6514 INCLUDE 'DPCOHK.INC' 6515 INCLUDE 'DPCOF2.INC' 6516C 6517CCCCC CHARACTER*80 IFILE 6518 CHARACTER (LEN=MAXFNC) :: IFILE 6519 CHARACTER*12 ISTAT 6520 CHARACTER*12 IFORM 6521 CHARACTER*12 IACCES 6522 CHARACTER*12 IPROT 6523 CHARACTER*12 ICURST 6524 CHARACTER*4 IENDFI 6525 CHARACTER*4 IREWIN 6526 CHARACTER*4 ISUBN0 6527 CHARACTER*4 IERRFI 6528C 6529 CHARACTER*500 IATEMP 6530 CHARACTER*10 IFRMT 6531C 6532C--------------------------------------------------------------------- 6533C 6534 INCLUDE 'DPCOP2.INC' 6535C 6536C-----START POINT----------------------------------------------------- 6537C 6538 ISUBN1='DPRO' 6539 ISUBN2='LA ' 6540 IFLAGV=0 6541 IERROR='NO' 6542C 6543 NQ=0 6544 NRIGHT=0 6545C 6546 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROLA')THEN 6547 WRITE(ICOUT,999) 6548 999 FORMAT(1X) 6549 CALL DPWRST('XXX','BUG ') 6550 WRITE(ICOUT,51) 6551 51 FORMAT('***** AT THE BEGINNING OF DPROLA--') 6552 CALL DPWRST('XXX','BUG ') 6553 WRITE(ICOUT,52)IBUGA3,ISUBRO 6554 52 FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4) 6555 CALL DPWRST('XXX','BUG ') 6556 ENDIF 6557C 6558C ******************************************** 6559C ** STEP 2-- ** 6560C ** OPEN THE DPZCHF.DAT FILE. ** 6561C ******************************************** 6562C 6563 ISTEPN='2' 6564 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROLA') 6565 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6566C 6567 IHRIGH=IHARG(3) 6568 IHRIG2=IHARG2(3) 6569C 6570 IOUNIT=IZCHNU 6571 IFILE=IZCHNA 6572 ISTAT=IZCHST 6573 IFORM=IZCHFO 6574 IACCES=IZCHAC 6575 IPROT=IZCHPR 6576 ICURST=IZCHCS 6577C 6578 ISUBN0='READ' 6579 IERRFI='NO' 6580 CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT, 6581 1 ICURST, 6582 1 IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR) 6583 IF(IERRFI.EQ.'YES')THEN 6584 IFLAGV=1 6585 GOTO8000 6586CCCCC IERROR='YES' 6587CCCCC WRITE(ICOUT,999) 6588CCCCC CALL DPWRST('XXX','BUG ') 6589CCCCC WRITE(ICOUT,111) 6590 111 FORMAT('***** ERROR IN DPROLA--') 6591CCCCC CALL DPWRST('XXX','BUG ') 6592CCCCC WRITE(ICOUT,118) 6593CC118 FORMAT(' UNABLE TO OPEN THE CHARACTER DATA FILE:') 6594CCCCC CALL DPWRST('XXX','BUG ') 6595CCCCC WRITE(ICOUT,119)IFILE 6596 119 FORMAT(' ',A80) 6597CCCCC CALL DPWRST('XXX','BUG ') 6598 GOTO8000 6599 ENDIF 6600C 6601 READ(IOUNIT,'(I8)',END=171,ERR=171)NUMVAR 6602C 6603 DO130I=1,NUMVAR 6604 READ(IOUNIT,'(A4,A4)',END=181,ERR=181)IH,IH2 6605 IF(IHRIGH.EQ.IH .AND. IHRIG2.EQ.IH2)THEN 6606 IVAR=I 6607 IFLAGV=0 6608 GOTO199 6609 ENDIF 6610 130 CONTINUE 6611C 6612 IFLAGV=1 6613 GOTO8000 6614C 6615CCCCC WRITE(ICOUT,999) 6616CCCCC CALL DPWRST('XXX','BUG ') 6617CCCCC WRITE(ICOUT,111) 6618CCCCC CALL DPWRST('XXX','BUG ') 6619CCCCC WRITE(ICOUT,131)IHRIGH,IHRIG2 6620CC131 FORMAT('***** VARIABLE ',A4,A4,' NOT FOUND IN THE CHARACTER ', 6621CCCCC1 'DATA FILE:') 6622CCCCC CALL DPWRST('XXX','BUG ') 6623CCCCC WRITE(ICOUT,119)IFILE 6624CCCCC CALL DPWRST('XXX','BUG ') 6625CCCCC IERROR='YES' 6626CCCCC GOTO8000 6627C 6628 171 CONTINUE 6629 IFLAGV=1 6630 GOTO8000 6631CCCCC WRITE(ICOUT,999) 6632CCCCC CALL DPWRST('XXX','BUG ') 6633CCCCC WRITE(ICOUT,111) 6634CCCCC CALL DPWRST('XXX','BUG ') 6635CCCCC WRITE(ICOUT,173) 6636CC173 FORMAT(' ERROR READING THE NUMBER OF CHARACTER VARIABLES ', 6637CCCCC1 'IN THE CHARACTER DATA FILE:') 6638CCCCC CALL DPWRST('XXX','BUG ') 6639CCCCC WRITE(ICOUT,119)IFILE 6640CCCCC CALL DPWRST('XXX','BUG ') 6641CCCCC IERROR='YES' 6642CCCCC GOTO8000 6643C 6644 181 CONTINUE 6645 IFLAGV=1 6646 GOTO8000 6647CCCCC WRITE(ICOUT,999) 6648CCCCC CALL DPWRST('XXX','BUG ') 6649CCCCC WRITE(ICOUT,111) 6650CCCCC CALL DPWRST('XXX','BUG ') 6651CCCCC WRITE(ICOUT,183) 6652CC183 FORMAT(' ERROR READING THE VARIABLE NAMES ', 6653CCCCC1 'IN THE CHARACTER DATA FILE:') 6654CCCCC CALL DPWRST('XXX','BUG ') 6655CCCCC WRITE(ICOUT,119)IFILE 6656CCCCC CALL DPWRST('XXX','BUG ') 6657CCCCC IERROR='YES' 6658CCCCC GOTO8000 6659C 6660 199 CONTINUE 6661C 6662C ************************************************* 6663C ** STEP 3-- ** 6664C ** DEFINE THE ROW LABELS. ** 6665C ** STORE UNIQUE VALUES IN IROWLB. ** 6666C ************************************************* 6667C 6668 ISTEPN='3' 6669 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROLA') 6670 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6671C 6672 DO205I=1,MAXOBV 6673 IROWLB(I)=' ' 6674 205 CONTINUE 6675C 6676 IFRMT='(A )' 6677 WRITE(IFRMT(3:5),'(I3)')25*IVAR 6678 IFRST=(IVAR-1)*25 + 1 6679 ILAST=IVAR*25 - 1 6680C 6681 DO210I=1,MAXOBV 6682 IATEMP=' ' 6683 READ(IOUNIT,IFRMT,END=499,ERR=491)IATEMP 6684 IROWLB(I)=IATEMP(IFRST:ILAST) 6685 IROW=I 6686 210 CONTINUE 6687 GOTO499 6688C 6689 491 CONTINUE 6690 WRITE(ICOUT,999) 6691 CALL DPWRST('XXX','BUG ') 6692 WRITE(ICOUT,111) 6693 CALL DPWRST('XXX','BUG ') 6694 WRITE(ICOUT,493)IROW 6695 493 FORMAT(' ERROR READING ROW ',I8,' OF THE CHARACTER ', 6696 1 'VARIABLES IN THE CHARACTER DATA FILE:') 6697 CALL DPWRST('XXX','BUG ') 6698 WRITE(ICOUT,119)IFILE 6699 CALL DPWRST('XXX','BUG ') 6700 IERROR='YES' 6701 GOTO8000 6702C 6703C 6704C ****************************** 6705C ** STEP 3-- ** 6706C ** WRITE OUT A FEW LINES ** 6707C ** OF SUMMARY INFORMATION ** 6708C ** ABOUT THE CODING. ** 6709C ****************************** 6710C 6711 499 CONTINUE 6712C 6713 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 6714 WRITE(ICOUT,999) 6715 CALL DPWRST('XXX','BUG ') 6716 WRITE(ICOUT,811)IROW 6717 811 FORMAT('NUMBER OF ROW LABELS CREATED = ',I8) 6718 CALL DPWRST('XXX','BUG ') 6719 WRITE(ICOUT,813)IROWLB(1)(1:24) 6720 813 FORMAT('FIRST ROW LABEL = ',A24) 6721 CALL DPWRST('XXX','BUG ') 6722 WRITE(ICOUT,815)IROW,IROWLB(1)(1:24) 6723 815 FORMAT('LAST ROW LABEL (',I8,') = ',A24) 6724 CALL DPWRST('XXX','BUG ') 6725 WRITE(ICOUT,999) 6726 CALL DPWRST('XXX','BUG ') 6727 ENDIF 6728C 6729C *************************************** 6730C ** STEP 88-- ** 6731C ** CLOSE THE DPZCHF.DAT FILE. ** 6732C *************************************** 6733C 6734 8000 CONTINUE 6735C 6736 IENDFI='OFF' 6737 IREWIN='ON' 6738 CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 6739 1 IENDFI,IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR) 6740 IZCHCS='CLOSED' 6741 IF(IFLAGV.EQ.0)GOTO9000 6742C 6743C ******************************************** 6744C ** STEP 91-- ** 6745C ** LOOK FOR THE VARIABLE NAME IN REGULAR ** 6746C ** NAME TABLE. ** 6747C ******************************************** 6748C 6749 ISTEPN='91' 6750 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROLA') 6751 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6752C 6753 IHWUSE='V' 6754 MESSAG='NO' 6755 CALL CHECKN(IHRIGH,IHRIG2,IHWUSE, 6756 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE, 6757 1 NUMNAM,MAXNAM, 6758 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 6759 IF(IERROR.EQ.'YES')THEN 6760 WRITE(ICOUT,999) 6761 CALL DPWRST('XXX','BUG ') 6762 WRITE(ICOUT,111) 6763 CALL DPWRST('XXX','BUG ') 6764 WRITE(ICOUT,901) 6765 901 FORMAT(' THE SPECIFIED VARIABLE NAME ON THE RIGHT OF ', 6766 1 'THE = SIGN') 6767 CALL DPWRST('XXX','BUG ') 6768 WRITE(ICOUT,903) 6769 903 FORMAT(' WAS NOT FOUND IN EITHER CHARACTER VARIABLE ', 6770 1 'NAME LIST') 6771 CALL DPWRST('XXX','BUG ') 6772 WRITE(ICOUT,905) 6773 905 FORMAT(' OR IN THE INTERNAL VARIABLE NAME LIST.') 6774 CALL DPWRST('XXX','BUG ') 6775 IERROR='YES' 6776 GOTO9000 6777 ENDIF 6778C 6779 ILIS=ILOCV 6780 NRIGHT=IN(ILOCV) 6781 ICOLR=IVALUE(ILOCV) 6782 MAXCP1=MAXCOL+1 6783 MAXCP2=MAXCOL+2 6784 MAXCP3=MAXCOL+3 6785 MAXCP4=MAXCOL+4 6786 MAXCP5=MAXCOL+5 6787 MAXCP6=MAXCOL+6 6788C 6789 ICASEQ='FULL' 6790 ILOCQ=NUMARG+1 6791 IF(NUMARG.GE.5)THEN 6792 DO911J=1,NUMARG 6793 J1=J 6794 IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')THEN 6795 ICASEQ='SUBS' 6796 ILOCQ=J1 6797 GOTO916 6798 ELSEIF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')THEN 6799 ICASEQ='SUBS' 6800 ILOCQ=J1 6801 GOTO916 6802 ELSEIF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')THEN 6803 ICASEQ='FOR' 6804 ILOCQ=J1 6805 GOTO916 6806 ENDIF 6807 911 CONTINUE 6808 ENDIF 6809 916 CONTINUE 6810C 6811 IF(ICASEQ.EQ.'FULL')THEN 6812 DO921I=1,NRIGHT 6813 ISUB(I)=1 6814 921 CONTINUE 6815 NQ=NRIGHT 6816 ELSEIF(ICASEQ.EQ.'SUBS')THEN 6817 NIOLD=NRIGHT 6818 CALL DPSUBS(NIOLD,ILOCS,NS,IBUGA3,IERROR) 6819 NQ=NIOLD 6820 ELSEIF(ICASEQ.EQ.'FOR')THEN 6821 NIOLD=NRIGHT 6822 CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 6823 1 NLOCAL,ILOCS,NS,IBUGA3,IERROR) 6824 NQ=NFOR 6825 ENDIF 6826C 6827 J=0 6828 IMAX=NRIGHT 6829 IF(NQ.LT.NRIGHT)IMAX=NQ 6830 DO960I=1,IMAX 6831 IF(ISUB(I).EQ.0)GOTO960 6832 J=J+1 6833C 6834 IJ=MAXN*(ICOLR-1)+I 6835 IF(ICOLR.LE.MAXCOL)AVAL=V(IJ) 6836 IF(ICOLR.EQ.MAXCP1)AVAL=PRED(I) 6837 IF(ICOLR.EQ.MAXCP2)AVAL=RES(I) 6838 IF(ICOLR.EQ.MAXCP3)AVAL=YPLOT(I) 6839 IF(ICOLR.EQ.MAXCP4)AVAL=XPLOT(I) 6840 IF(ICOLR.EQ.MAXCP5)AVAL=X2PLOT(I) 6841 IF(ICOLR.EQ.MAXCP6)AVAL=TAGPLO(I) 6842C 6843C NOW CONVERT ATEMP TO ROW LABEL 6844C 6845 IVAL=INT(AVAL+0.5) 6846 CALL DPCONH(IVAL,AVAL,ICTEXT,NCTEXT,IBUGA3,IERROR) 6847 IF(NCTEXT.LE.0)THEN 6848 IROWLB(J)=' ' 6849 ELSE 6850 IROWLB(J)=' ' 6851 DO965II=1,MIN(24,NCTEXT) 6852 IROWLB(J)(II:II)=ICTEXT(II)(1:1) 6853 965 CONTINUE 6854 IF(IROWLB(J)(NCTEXT:NCTEXT).EQ.'.')THEN 6855 IROWLB(J)(NCTEXT:NCTEXT)=' ' 6856 ENDIF 6857 ENDIF 6858C 6859 960 CONTINUE 6860 IROW=J 6861C 6862 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 6863 WRITE(ICOUT,999) 6864 CALL DPWRST('XXX','BUG ') 6865 WRITE(ICOUT,811)IROW 6866 CALL DPWRST('XXX','BUG ') 6867 WRITE(ICOUT,813)IROWLB(1)(1:24) 6868 CALL DPWRST('XXX','BUG ') 6869 WRITE(ICOUT,815)IROW,IROWLB(IROW)(1:24) 6870 CALL DPWRST('XXX','BUG ') 6871 WRITE(ICOUT,999) 6872 CALL DPWRST('XXX','BUG ') 6873 ENDIF 6874C 6875C ***************** 6876C ** STEP 90-- ** 6877C ** EXIT. ** 6878C ***************** 6879C 6880 9000 CONTINUE 6881C 6882 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ROLA')THEN 6883 WRITE(ICOUT,999) 6884 CALL DPWRST('XXX','BUG ') 6885 WRITE(ICOUT,9011) 6886 9011 FORMAT('***** AT THE END OF DPROLA--') 6887 CALL DPWRST('XXX','BUG ') 6888 WRITE(ICOUT,9012)IBUGA3,IERROR 6889 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 6890 CALL DPWRST('XXX','BUG ') 6891 WRITE(ICOUT,9013)IROW 6892 9013 FORMAT('IROW = ',I8) 6893 CALL DPWRST('XXX','BUG ') 6894 IF(IROW.GT.0)THEN 6895 DO9015I=1,MIN(IROW,20) 6896 WRITE(ICOUT,9016)I,IROWLB(I) 6897 9016 FORMAT('I,IROWLB(I) = ',I8,A24) 6898 CALL DPWRST('XXX','BUG ') 6899 9015 CONTINUE 6900 ENDIF 6901 ENDIF 6902C 6903 RETURN 6904 END 6905 SUBROUTINE DPRSL(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 6906 1IBUGD2,IFOUND,IERROR) 6907C 6908C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 6909C FOR ROMAN SIMPLEX LOWER CASE. 6910C WRITTEN BY--JAMES J. FILLIBEN 6911C STATISTICAL ENGINEERING DIVISION 6912C INFORMATION TECHNOLOGY LABORATORY 6913C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 6914C GAITHERSBURG, MD 20899 6915C PHONE--301-975-2855 6916C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 6917C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 6918C LANGUAGE--ANSI FORTRAN (1977) 6919C VERSION NUMBER--87/4 6920C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 6921C UPDATED --MAY 1982. 6922C UPDATED --MARCH 1987. 6923C 6924C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 6925C 6926 CHARACTER*4 ICHAR2 6927 CHARACTER*4 IOP 6928 CHARACTER*4 IBUGD2 6929 CHARACTER*4 IFOUND 6930 CHARACTER*4 IERROR 6931C 6932 CHARACTER*4 IOPERA 6933C 6934C--------------------------------------------------------------------- 6935C 6936 DIMENSION IOP(*) 6937 DIMENSION X(*) 6938 DIMENSION Y(*) 6939C 6940 DIMENSION IOPERA(300) 6941 DIMENSION IX(300) 6942 DIMENSION IY(300) 6943C 6944 DIMENSION IXMIND(30) 6945 DIMENSION IXMAXD(30) 6946 DIMENSION IXDELD(30) 6947 DIMENSION ISTARD(30) 6948 DIMENSION NUMCOO(30) 6949C 6950C--------------------------------------------------------------------- 6951C 6952 INCLUDE 'DPCOP2.INC' 6953C 6954C-----DATA STATEMENTS------------------------------------------------- 6955C 6956C DEFINE CHARACTER 601--LOWER CASE A 6957C 6958 DATA IOPERA( 1),IX( 1),IY( 1)/'MOVE', 6, 5/ 6959 DATA IOPERA( 2),IX( 2),IY( 2)/'DRAW', 6, -9/ 6960 DATA IOPERA( 3),IX( 3),IY( 3)/'MOVE', 6, 2/ 6961 DATA IOPERA( 4),IX( 4),IY( 4)/'DRAW', 4, 4/ 6962 DATA IOPERA( 5),IX( 5),IY( 5)/'DRAW', 2, 5/ 6963 DATA IOPERA( 6),IX( 6),IY( 6)/'DRAW', -1, 5/ 6964 DATA IOPERA( 7),IX( 7),IY( 7)/'DRAW', -3, 4/ 6965 DATA IOPERA( 8),IX( 8),IY( 8)/'DRAW', -5, 2/ 6966 DATA IOPERA( 9),IX( 9),IY( 9)/'DRAW', -6, -1/ 6967 DATA IOPERA( 10),IX( 10),IY( 10)/'DRAW', -6, -3/ 6968 DATA IOPERA( 11),IX( 11),IY( 11)/'DRAW', -5, -6/ 6969 DATA IOPERA( 12),IX( 12),IY( 12)/'DRAW', -3, -8/ 6970 DATA IOPERA( 13),IX( 13),IY( 13)/'DRAW', -1, -9/ 6971 DATA IOPERA( 14),IX( 14),IY( 14)/'DRAW', 2, -9/ 6972 DATA IOPERA( 15),IX( 15),IY( 15)/'DRAW', 4, -8/ 6973 DATA IOPERA( 16),IX( 16),IY( 16)/'DRAW', 6, -6/ 6974C 6975 DATA IXMIND( 1)/ -9/ 6976 DATA IXMAXD( 1)/ 10/ 6977 DATA IXDELD( 1)/ 19/ 6978 DATA ISTARD( 1)/ 1/ 6979 DATA NUMCOO( 1)/ 16/ 6980C 6981C DEFINE CHARACTER 602--LOWER CASE B 6982C 6983 DATA IOPERA( 17),IX( 17),IY( 17)/'MOVE', -6, 12/ 6984 DATA IOPERA( 18),IX( 18),IY( 18)/'DRAW', -6, -9/ 6985 DATA IOPERA( 19),IX( 19),IY( 19)/'MOVE', -6, 2/ 6986 DATA IOPERA( 20),IX( 20),IY( 20)/'DRAW', -4, 4/ 6987 DATA IOPERA( 21),IX( 21),IY( 21)/'DRAW', -2, 5/ 6988 DATA IOPERA( 22),IX( 22),IY( 22)/'DRAW', 1, 5/ 6989 DATA IOPERA( 23),IX( 23),IY( 23)/'DRAW', 3, 4/ 6990 DATA IOPERA( 24),IX( 24),IY( 24)/'DRAW', 5, 2/ 6991 DATA IOPERA( 25),IX( 25),IY( 25)/'DRAW', 6, -1/ 6992 DATA IOPERA( 26),IX( 26),IY( 26)/'DRAW', 6, -3/ 6993 DATA IOPERA( 27),IX( 27),IY( 27)/'DRAW', 5, -6/ 6994 DATA IOPERA( 28),IX( 28),IY( 28)/'DRAW', 3, -8/ 6995 DATA IOPERA( 29),IX( 29),IY( 29)/'DRAW', 1, -9/ 6996 DATA IOPERA( 30),IX( 30),IY( 30)/'DRAW', -2, -9/ 6997 DATA IOPERA( 31),IX( 31),IY( 31)/'DRAW', -4, -8/ 6998 DATA IOPERA( 32),IX( 32),IY( 32)/'DRAW', -6, -6/ 6999C 7000 DATA IXMIND( 2)/ -10/ 7001 DATA IXMAXD( 2)/ 9/ 7002 DATA IXDELD( 2)/ 19/ 7003 DATA ISTARD( 2)/ 17/ 7004 DATA NUMCOO( 2)/ 16/ 7005C 7006C DEFINE CHARACTER 603--LOWER CASE C 7007C 7008 DATA IOPERA( 33),IX( 33),IY( 33)/'MOVE', 6, 2/ 7009 DATA IOPERA( 34),IX( 34),IY( 34)/'DRAW', 4, 4/ 7010 DATA IOPERA( 35),IX( 35),IY( 35)/'DRAW', 2, 5/ 7011 DATA IOPERA( 36),IX( 36),IY( 36)/'DRAW', -1, 5/ 7012 DATA IOPERA( 37),IX( 37),IY( 37)/'DRAW', -3, 4/ 7013 DATA IOPERA( 38),IX( 38),IY( 38)/'DRAW', -5, 2/ 7014 DATA IOPERA( 39),IX( 39),IY( 39)/'DRAW', -6, -1/ 7015 DATA IOPERA( 40),IX( 40),IY( 40)/'DRAW', -6, -3/ 7016 DATA IOPERA( 41),IX( 41),IY( 41)/'DRAW', -5, -6/ 7017 DATA IOPERA( 42),IX( 42),IY( 42)/'DRAW', -3, -8/ 7018 DATA IOPERA( 43),IX( 43),IY( 43)/'DRAW', -1, -9/ 7019 DATA IOPERA( 44),IX( 44),IY( 44)/'DRAW', 2, -9/ 7020 DATA IOPERA( 45),IX( 45),IY( 45)/'DRAW', 4, -8/ 7021 DATA IOPERA( 46),IX( 46),IY( 46)/'DRAW', 6, -6/ 7022C 7023 DATA IXMIND( 3)/ -9/ 7024 DATA IXMAXD( 3)/ 9/ 7025 DATA IXDELD( 3)/ 18/ 7026 DATA ISTARD( 3)/ 33/ 7027 DATA NUMCOO( 3)/ 14/ 7028C 7029C DEFINE CHARACTER 604--LOWER CASE D 7030C 7031 DATA IOPERA( 47),IX( 47),IY( 47)/'MOVE', 6, 12/ 7032 DATA IOPERA( 48),IX( 48),IY( 48)/'DRAW', 6, -9/ 7033 DATA IOPERA( 49),IX( 49),IY( 49)/'MOVE', 6, 2/ 7034 DATA IOPERA( 50),IX( 50),IY( 50)/'DRAW', 4, 4/ 7035 DATA IOPERA( 51),IX( 51),IY( 51)/'DRAW', 2, 5/ 7036 DATA IOPERA( 52),IX( 52),IY( 52)/'DRAW', -1, 5/ 7037 DATA IOPERA( 53),IX( 53),IY( 53)/'DRAW', -3, 4/ 7038 DATA IOPERA( 54),IX( 54),IY( 54)/'DRAW', -5, 2/ 7039 DATA IOPERA( 55),IX( 55),IY( 55)/'DRAW', -6, -1/ 7040 DATA IOPERA( 56),IX( 56),IY( 56)/'DRAW', -6, -3/ 7041 DATA IOPERA( 57),IX( 57),IY( 57)/'DRAW', -5, -6/ 7042 DATA IOPERA( 58),IX( 58),IY( 58)/'DRAW', -3, -8/ 7043 DATA IOPERA( 59),IX( 59),IY( 59)/'DRAW', -1, -9/ 7044 DATA IOPERA( 60),IX( 60),IY( 60)/'DRAW', 2, -9/ 7045 DATA IOPERA( 61),IX( 61),IY( 61)/'DRAW', 4, -8/ 7046 DATA IOPERA( 62),IX( 62),IY( 62)/'DRAW', 6, -6/ 7047C 7048 DATA IXMIND( 4)/ -9/ 7049 DATA IXMAXD( 4)/ 10/ 7050 DATA IXDELD( 4)/ 19/ 7051 DATA ISTARD( 4)/ 47/ 7052 DATA NUMCOO( 4)/ 16/ 7053C 7054C DEFINE CHARACTER 605--LOWER CASE E 7055C 7056 DATA IOPERA( 63),IX( 63),IY( 63)/'MOVE', -6, -1/ 7057 DATA IOPERA( 64),IX( 64),IY( 64)/'DRAW', 6, -1/ 7058 DATA IOPERA( 65),IX( 65),IY( 65)/'DRAW', 6, 1/ 7059 DATA IOPERA( 66),IX( 66),IY( 66)/'DRAW', 5, 3/ 7060 DATA IOPERA( 67),IX( 67),IY( 67)/'DRAW', 4, 4/ 7061 DATA IOPERA( 68),IX( 68),IY( 68)/'DRAW', 2, 5/ 7062 DATA IOPERA( 69),IX( 69),IY( 69)/'DRAW', -1, 5/ 7063 DATA IOPERA( 70),IX( 70),IY( 70)/'DRAW', -3, 4/ 7064 DATA IOPERA( 71),IX( 71),IY( 71)/'DRAW', -5, 2/ 7065 DATA IOPERA( 72),IX( 72),IY( 72)/'DRAW', -6, -1/ 7066 DATA IOPERA( 73),IX( 73),IY( 73)/'DRAW', -6, -3/ 7067 DATA IOPERA( 74),IX( 74),IY( 74)/'DRAW', -5, -6/ 7068 DATA IOPERA( 75),IX( 75),IY( 75)/'DRAW', -3, -8/ 7069 DATA IOPERA( 76),IX( 76),IY( 76)/'DRAW', -1, -9/ 7070 DATA IOPERA( 77),IX( 77),IY( 77)/'DRAW', 2, -9/ 7071 DATA IOPERA( 78),IX( 78),IY( 78)/'DRAW', 4, -8/ 7072 DATA IOPERA( 79),IX( 79),IY( 79)/'DRAW', 6, -6/ 7073C 7074 DATA IXMIND( 5)/ -9/ 7075 DATA IXMAXD( 5)/ 9/ 7076 DATA IXDELD( 5)/ 18/ 7077 DATA ISTARD( 5)/ 63/ 7078 DATA NUMCOO( 5)/ 17/ 7079C 7080C DEFINE CHARACTER 606--LOWER CASE F 7081C 7082 DATA IOPERA( 80),IX( 80),IY( 80)/'MOVE', 5, 12/ 7083 DATA IOPERA( 81),IX( 81),IY( 81)/'DRAW', 3, 12/ 7084 DATA IOPERA( 82),IX( 82),IY( 82)/'DRAW', 1, 11/ 7085 DATA IOPERA( 83),IX( 83),IY( 83)/'DRAW', 0, 8/ 7086 DATA IOPERA( 84),IX( 84),IY( 84)/'DRAW', 0, -9/ 7087 DATA IOPERA( 85),IX( 85),IY( 85)/'MOVE', -3, 5/ 7088 DATA IOPERA( 86),IX( 86),IY( 86)/'DRAW', 4, 5/ 7089C 7090 DATA IXMIND( 6)/ -5/ 7091 DATA IXMAXD( 6)/ 7/ 7092 DATA IXDELD( 6)/ 12/ 7093 DATA ISTARD( 6)/ 80/ 7094 DATA NUMCOO( 6)/ 7/ 7095C 7096C DEFINE CHARACTER 607--LOWER CASE G 7097C 7098 DATA IOPERA( 87),IX( 87),IY( 87)/'MOVE', 6, 5/ 7099 DATA IOPERA( 88),IX( 88),IY( 88)/'DRAW', 6, -11/ 7100 DATA IOPERA( 89),IX( 89),IY( 89)/'DRAW', 5, -14/ 7101 DATA IOPERA( 90),IX( 90),IY( 90)/'DRAW', 4, -15/ 7102 DATA IOPERA( 91),IX( 91),IY( 91)/'DRAW', 2, -16/ 7103 DATA IOPERA( 92),IX( 92),IY( 92)/'DRAW', -1, -16/ 7104 DATA IOPERA( 93),IX( 93),IY( 93)/'DRAW', -3, -15/ 7105 DATA IOPERA( 94),IX( 94),IY( 94)/'MOVE', 6, 2/ 7106 DATA IOPERA( 95),IX( 95),IY( 95)/'DRAW', 4, 4/ 7107 DATA IOPERA( 96),IX( 96),IY( 96)/'DRAW', 2, 5/ 7108 DATA IOPERA( 97),IX( 97),IY( 97)/'DRAW', -1, 5/ 7109 DATA IOPERA( 98),IX( 98),IY( 98)/'DRAW', -3, 4/ 7110 DATA IOPERA( 99),IX( 99),IY( 99)/'DRAW', -5, 2/ 7111 DATA IOPERA( 100),IX( 100),IY( 100)/'DRAW', -6, -1/ 7112 DATA IOPERA( 101),IX( 101),IY( 101)/'DRAW', -6, -3/ 7113 DATA IOPERA( 102),IX( 102),IY( 102)/'DRAW', -5, -6/ 7114 DATA IOPERA( 103),IX( 103),IY( 103)/'DRAW', -3, -8/ 7115 DATA IOPERA( 104),IX( 104),IY( 104)/'DRAW', -1, -9/ 7116 DATA IOPERA( 105),IX( 105),IY( 105)/'DRAW', 2, -9/ 7117 DATA IOPERA( 106),IX( 106),IY( 106)/'DRAW', 4, -8/ 7118 DATA IOPERA( 107),IX( 107),IY( 107)/'DRAW', 6, -6/ 7119C 7120 DATA IXMIND( 7)/ -9/ 7121 DATA IXMAXD( 7)/ 10/ 7122 DATA IXDELD( 7)/ 19/ 7123 DATA ISTARD( 7)/ 87/ 7124 DATA NUMCOO( 7)/ 21/ 7125C 7126C DEFINE CHARACTER 608--LOWER CASE H 7127C 7128 DATA IOPERA( 108),IX( 108),IY( 108)/'MOVE', -5, 12/ 7129 DATA IOPERA( 109),IX( 109),IY( 109)/'DRAW', -5, -9/ 7130 DATA IOPERA( 110),IX( 110),IY( 110)/'MOVE', -5, 1/ 7131 DATA IOPERA( 111),IX( 111),IY( 111)/'DRAW', -2, 4/ 7132 DATA IOPERA( 112),IX( 112),IY( 112)/'DRAW', 0, 5/ 7133 DATA IOPERA( 113),IX( 113),IY( 113)/'DRAW', 3, 5/ 7134 DATA IOPERA( 114),IX( 114),IY( 114)/'DRAW', 5, 4/ 7135 DATA IOPERA( 115),IX( 115),IY( 115)/'DRAW', 6, 1/ 7136 DATA IOPERA( 116),IX( 116),IY( 116)/'DRAW', 6, -9/ 7137C 7138 DATA IXMIND( 8)/ -9/ 7139 DATA IXMAXD( 8)/ 10/ 7140 DATA IXDELD( 8)/ 19/ 7141 DATA ISTARD( 8)/ 108/ 7142 DATA NUMCOO( 8)/ 9/ 7143C 7144C DEFINE CHARACTER 609--LOWER CASE I 7145C 7146 DATA IOPERA( 117),IX( 117),IY( 117)/'MOVE', -1, 12/ 7147 DATA IOPERA( 118),IX( 118),IY( 118)/'DRAW', 0, 11/ 7148 DATA IOPERA( 119),IX( 119),IY( 119)/'DRAW', 1, 12/ 7149 DATA IOPERA( 120),IX( 120),IY( 120)/'DRAW', 0, 13/ 7150 DATA IOPERA( 121),IX( 121),IY( 121)/'DRAW', -1, 12/ 7151 DATA IOPERA( 122),IX( 122),IY( 122)/'MOVE', 0, 5/ 7152 DATA IOPERA( 123),IX( 123),IY( 123)/'DRAW', 0, -9/ 7153C 7154 DATA IXMIND( 9)/ -4/ 7155 DATA IXMAXD( 9)/ 4/ 7156 DATA IXDELD( 9)/ 8/ 7157 DATA ISTARD( 9)/ 117/ 7158 DATA NUMCOO( 9)/ 7/ 7159C 7160C DEFINE CHARACTER 610--LOWER CASE J 7161C 7162 DATA IOPERA( 124),IX( 124),IY( 124)/'MOVE', 0, 12/ 7163 DATA IOPERA( 125),IX( 125),IY( 125)/'DRAW', 1, 11/ 7164 DATA IOPERA( 126),IX( 126),IY( 126)/'DRAW', 2, 12/ 7165 DATA IOPERA( 127),IX( 127),IY( 127)/'DRAW', 1, 13/ 7166 DATA IOPERA( 128),IX( 128),IY( 128)/'DRAW', 0, 12/ 7167 DATA IOPERA( 129),IX( 129),IY( 129)/'MOVE', 1, 5/ 7168 DATA IOPERA( 130),IX( 130),IY( 130)/'DRAW', 1, -12/ 7169 DATA IOPERA( 131),IX( 131),IY( 131)/'DRAW', 0, -15/ 7170 DATA IOPERA( 132),IX( 132),IY( 132)/'DRAW', -2, -16/ 7171 DATA IOPERA( 133),IX( 133),IY( 133)/'DRAW', -4, -16/ 7172C 7173 DATA IXMIND( 10)/ -5/ 7174 DATA IXMAXD( 10)/ 5/ 7175 DATA IXDELD( 10)/ 10/ 7176 DATA ISTARD( 10)/ 124/ 7177 DATA NUMCOO( 10)/ 10/ 7178C 7179C DEFINE CHARACTER 611--LOWER CASE K 7180C 7181 DATA IOPERA( 134),IX( 134),IY( 134)/'MOVE', -5, 12/ 7182 DATA IOPERA( 135),IX( 135),IY( 135)/'DRAW', -5, -9/ 7183 DATA IOPERA( 136),IX( 136),IY( 136)/'MOVE', 5, 5/ 7184 DATA IOPERA( 137),IX( 137),IY( 137)/'DRAW', -5, -5/ 7185 DATA IOPERA( 138),IX( 138),IY( 138)/'MOVE', -1, -1/ 7186 DATA IOPERA( 139),IX( 139),IY( 139)/'DRAW', 6, -9/ 7187C 7188 DATA IXMIND( 11)/ -9/ 7189 DATA IXMAXD( 11)/ 8/ 7190 DATA IXDELD( 11)/ 17/ 7191 DATA ISTARD( 11)/ 134/ 7192 DATA NUMCOO( 11)/ 6/ 7193C 7194C DEFINE CHARACTER 612--LOWER CASE L 7195C 7196 DATA IOPERA( 140),IX( 140),IY( 140)/'MOVE', 0, 12/ 7197 DATA IOPERA( 141),IX( 141),IY( 141)/'DRAW', 0, -9/ 7198C 7199 DATA IXMIND( 12)/ -4/ 7200 DATA IXMAXD( 12)/ 4/ 7201 DATA IXDELD( 12)/ 8/ 7202 DATA ISTARD( 12)/ 140/ 7203 DATA NUMCOO( 12)/ 2/ 7204C 7205C DEFINE CHARACTER 613--LOWER CASE M 7206C 7207 DATA IOPERA( 142),IX( 142),IY( 142)/'MOVE', -11, 5/ 7208 DATA IOPERA( 143),IX( 143),IY( 143)/'DRAW', -11, -9/ 7209 DATA IOPERA( 144),IX( 144),IY( 144)/'MOVE', -11, 1/ 7210 DATA IOPERA( 145),IX( 145),IY( 145)/'DRAW', -8, 4/ 7211 DATA IOPERA( 146),IX( 146),IY( 146)/'DRAW', -6, 5/ 7212 DATA IOPERA( 147),IX( 147),IY( 147)/'DRAW', -3, 5/ 7213 DATA IOPERA( 148),IX( 148),IY( 148)/'DRAW', -1, 4/ 7214 DATA IOPERA( 149),IX( 149),IY( 149)/'DRAW', 0, 1/ 7215 DATA IOPERA( 150),IX( 150),IY( 150)/'DRAW', 0, -9/ 7216 DATA IOPERA( 151),IX( 151),IY( 151)/'MOVE', 0, 1/ 7217 DATA IOPERA( 152),IX( 152),IY( 152)/'DRAW', 3, 4/ 7218 DATA IOPERA( 153),IX( 153),IY( 153)/'DRAW', 5, 5/ 7219 DATA IOPERA( 154),IX( 154),IY( 154)/'DRAW', 8, 5/ 7220 DATA IOPERA( 155),IX( 155),IY( 155)/'DRAW', 10, 4/ 7221 DATA IOPERA( 156),IX( 156),IY( 156)/'DRAW', 11, 1/ 7222 DATA IOPERA( 157),IX( 157),IY( 157)/'DRAW', 11, -9/ 7223C 7224 DATA IXMIND( 13)/ -15/ 7225 DATA IXMAXD( 13)/ 15/ 7226 DATA IXDELD( 13)/ 30/ 7227 DATA ISTARD( 13)/ 142/ 7228 DATA NUMCOO( 13)/ 16/ 7229C 7230C DEFINE CHARACTER 614--LOWER CASE N 7231C 7232 DATA IOPERA( 158),IX( 158),IY( 158)/'MOVE', -5, 5/ 7233 DATA IOPERA( 159),IX( 159),IY( 159)/'DRAW', -5, -9/ 7234 DATA IOPERA( 160),IX( 160),IY( 160)/'MOVE', -5, 1/ 7235 DATA IOPERA( 161),IX( 161),IY( 161)/'DRAW', -2, 4/ 7236 DATA IOPERA( 162),IX( 162),IY( 162)/'DRAW', 0, 5/ 7237 DATA IOPERA( 163),IX( 163),IY( 163)/'DRAW', 3, 5/ 7238 DATA IOPERA( 164),IX( 164),IY( 164)/'DRAW', 5, 4/ 7239 DATA IOPERA( 165),IX( 165),IY( 165)/'DRAW', 6, 1/ 7240 DATA IOPERA( 166),IX( 166),IY( 166)/'DRAW', 6, -9/ 7241C 7242 DATA IXMIND( 14)/ -9/ 7243 DATA IXMAXD( 14)/ 10/ 7244 DATA IXDELD( 14)/ 19/ 7245 DATA ISTARD( 14)/ 158/ 7246 DATA NUMCOO( 14)/ 9/ 7247C 7248C DEFINE CHARACTER 615--LOWER CASE O 7249C 7250 DATA IOPERA( 167),IX( 167),IY( 167)/'MOVE', -1, 5/ 7251 DATA IOPERA( 168),IX( 168),IY( 168)/'DRAW', -3, 4/ 7252 DATA IOPERA( 169),IX( 169),IY( 169)/'DRAW', -5, 2/ 7253 DATA IOPERA( 170),IX( 170),IY( 170)/'DRAW', -6, -1/ 7254 DATA IOPERA( 171),IX( 171),IY( 171)/'DRAW', -6, -3/ 7255 DATA IOPERA( 172),IX( 172),IY( 172)/'DRAW', -5, -6/ 7256 DATA IOPERA( 173),IX( 173),IY( 173)/'DRAW', -3, -8/ 7257 DATA IOPERA( 174),IX( 174),IY( 174)/'DRAW', -1, -9/ 7258 DATA IOPERA( 175),IX( 175),IY( 175)/'DRAW', 2, -9/ 7259 DATA IOPERA( 176),IX( 176),IY( 176)/'DRAW', 4, -8/ 7260 DATA IOPERA( 177),IX( 177),IY( 177)/'DRAW', 6, -6/ 7261 DATA IOPERA( 178),IX( 178),IY( 178)/'DRAW', 7, -3/ 7262 DATA IOPERA( 179),IX( 179),IY( 179)/'DRAW', 7, -1/ 7263 DATA IOPERA( 180),IX( 180),IY( 180)/'DRAW', 6, 2/ 7264 DATA IOPERA( 181),IX( 181),IY( 181)/'DRAW', 4, 4/ 7265 DATA IOPERA( 182),IX( 182),IY( 182)/'DRAW', 2, 5/ 7266 DATA IOPERA( 183),IX( 183),IY( 183)/'DRAW', -1, 5/ 7267C 7268 DATA IXMIND( 15)/ -9/ 7269 DATA IXMAXD( 15)/ 10/ 7270 DATA IXDELD( 15)/ 19/ 7271 DATA ISTARD( 15)/ 167/ 7272 DATA NUMCOO( 15)/ 17/ 7273C 7274C DEFINE CHARACTER 616--LOWER CASE P 7275C 7276 DATA IOPERA( 184),IX( 184),IY( 184)/'MOVE', -6, 5/ 7277 DATA IOPERA( 185),IX( 185),IY( 185)/'DRAW', -6, -16/ 7278 DATA IOPERA( 186),IX( 186),IY( 186)/'MOVE', -6, 2/ 7279 DATA IOPERA( 187),IX( 187),IY( 187)/'DRAW', -4, 4/ 7280 DATA IOPERA( 188),IX( 188),IY( 188)/'DRAW', -2, 5/ 7281 DATA IOPERA( 189),IX( 189),IY( 189)/'DRAW', 1, 5/ 7282 DATA IOPERA( 190),IX( 190),IY( 190)/'DRAW', 3, 4/ 7283 DATA IOPERA( 191),IX( 191),IY( 191)/'DRAW', 5, 2/ 7284 DATA IOPERA( 192),IX( 192),IY( 192)/'DRAW', 6, -1/ 7285 DATA IOPERA( 193),IX( 193),IY( 193)/'DRAW', 6, -3/ 7286 DATA IOPERA( 194),IX( 194),IY( 194)/'DRAW', 5, -6/ 7287 DATA IOPERA( 195),IX( 195),IY( 195)/'DRAW', 3, -8/ 7288 DATA IOPERA( 196),IX( 196),IY( 196)/'DRAW', 1, -9/ 7289 DATA IOPERA( 197),IX( 197),IY( 197)/'DRAW', -2, -9/ 7290 DATA IOPERA( 198),IX( 198),IY( 198)/'DRAW', -4, -8/ 7291 DATA IOPERA( 199),IX( 199),IY( 199)/'DRAW', -6, -6/ 7292C 7293 DATA IXMIND( 16)/ -10/ 7294 DATA IXMAXD( 16)/ 9/ 7295 DATA IXDELD( 16)/ 19/ 7296 DATA ISTARD( 16)/ 184/ 7297 DATA NUMCOO( 16)/ 16/ 7298C 7299C DEFINE CHARACTER 617--LOWER CASE Q 7300C 7301 DATA IOPERA( 200),IX( 200),IY( 200)/'MOVE', 6, 5/ 7302 DATA IOPERA( 201),IX( 201),IY( 201)/'DRAW', 6, -16/ 7303 DATA IOPERA( 202),IX( 202),IY( 202)/'MOVE', 6, 2/ 7304 DATA IOPERA( 203),IX( 203),IY( 203)/'DRAW', 4, 4/ 7305 DATA IOPERA( 204),IX( 204),IY( 204)/'DRAW', 2, 5/ 7306 DATA IOPERA( 205),IX( 205),IY( 205)/'DRAW', -1, 5/ 7307 DATA IOPERA( 206),IX( 206),IY( 206)/'DRAW', -3, 4/ 7308 DATA IOPERA( 207),IX( 207),IY( 207)/'DRAW', -5, 2/ 7309 DATA IOPERA( 208),IX( 208),IY( 208)/'DRAW', -6, -1/ 7310 DATA IOPERA( 209),IX( 209),IY( 209)/'DRAW', -6, -3/ 7311 DATA IOPERA( 210),IX( 210),IY( 210)/'DRAW', -5, -6/ 7312 DATA IOPERA( 211),IX( 211),IY( 211)/'DRAW', -3, -8/ 7313 DATA IOPERA( 212),IX( 212),IY( 212)/'DRAW', -1, -9/ 7314 DATA IOPERA( 213),IX( 213),IY( 213)/'DRAW', 2, -9/ 7315 DATA IOPERA( 214),IX( 214),IY( 214)/'DRAW', 4, -8/ 7316 DATA IOPERA( 215),IX( 215),IY( 215)/'DRAW', 6, -6/ 7317C 7318 DATA IXMIND( 17)/ -9/ 7319 DATA IXMAXD( 17)/ 10/ 7320 DATA IXDELD( 17)/ 19/ 7321 DATA ISTARD( 17)/ 200/ 7322 DATA NUMCOO( 17)/ 16/ 7323C 7324C DEFINE CHARACTER 618--LOWER CASE R 7325C 7326 DATA IOPERA( 216),IX( 216),IY( 216)/'MOVE', -3, 5/ 7327 DATA IOPERA( 217),IX( 217),IY( 217)/'DRAW', -3, -9/ 7328 DATA IOPERA( 218),IX( 218),IY( 218)/'MOVE', -3, -1/ 7329 DATA IOPERA( 219),IX( 219),IY( 219)/'DRAW', -2, 2/ 7330 DATA IOPERA( 220),IX( 220),IY( 220)/'DRAW', 0, 4/ 7331 DATA IOPERA( 221),IX( 221),IY( 221)/'DRAW', 2, 5/ 7332 DATA IOPERA( 222),IX( 222),IY( 222)/'DRAW', 5, 5/ 7333C 7334 DATA IXMIND( 18)/ -7/ 7335 DATA IXMAXD( 18)/ 6/ 7336 DATA IXDELD( 18)/ 13/ 7337 DATA ISTARD( 18)/ 216/ 7338 DATA NUMCOO( 18)/ 7/ 7339C 7340C DEFINE CHARACTER 619--LOWER CASE S 7341C 7342 DATA IOPERA( 223),IX( 223),IY( 223)/'MOVE', 6, 2/ 7343 DATA IOPERA( 224),IX( 224),IY( 224)/'DRAW', 5, 4/ 7344 DATA IOPERA( 225),IX( 225),IY( 225)/'DRAW', 2, 5/ 7345 DATA IOPERA( 226),IX( 226),IY( 226)/'DRAW', -1, 5/ 7346 DATA IOPERA( 227),IX( 227),IY( 227)/'DRAW', -4, 4/ 7347 DATA IOPERA( 228),IX( 228),IY( 228)/'DRAW', -5, 2/ 7348 DATA IOPERA( 229),IX( 229),IY( 229)/'DRAW', -4, 0/ 7349 DATA IOPERA( 230),IX( 230),IY( 230)/'DRAW', -2, -1/ 7350 DATA IOPERA( 231),IX( 231),IY( 231)/'DRAW', 3, -2/ 7351 DATA IOPERA( 232),IX( 232),IY( 232)/'DRAW', 5, -3/ 7352 DATA IOPERA( 233),IX( 233),IY( 233)/'DRAW', 6, -5/ 7353 DATA IOPERA( 234),IX( 234),IY( 234)/'DRAW', 6, -6/ 7354 DATA IOPERA( 235),IX( 235),IY( 235)/'DRAW', 5, -8/ 7355 DATA IOPERA( 236),IX( 236),IY( 236)/'DRAW', 2, -9/ 7356 DATA IOPERA( 237),IX( 237),IY( 237)/'DRAW', -1, -9/ 7357 DATA IOPERA( 238),IX( 238),IY( 238)/'DRAW', -4, -8/ 7358 DATA IOPERA( 239),IX( 239),IY( 239)/'DRAW', -5, -6/ 7359C 7360 DATA IXMIND( 19)/ -8/ 7361 DATA IXMAXD( 19)/ 9/ 7362 DATA IXDELD( 19)/ 17/ 7363 DATA ISTARD( 19)/ 223/ 7364 DATA NUMCOO( 19)/ 17/ 7365C 7366C DEFINE CHARACTER 620--LOWER CASE T 7367C 7368 DATA IOPERA( 240),IX( 240),IY( 240)/'MOVE', 0, 12/ 7369 DATA IOPERA( 241),IX( 241),IY( 241)/'DRAW', 0, -5/ 7370 DATA IOPERA( 242),IX( 242),IY( 242)/'DRAW', 1, -8/ 7371 DATA IOPERA( 243),IX( 243),IY( 243)/'DRAW', 3, -9/ 7372 DATA IOPERA( 244),IX( 244),IY( 244)/'DRAW', 5, -9/ 7373 DATA IOPERA( 245),IX( 245),IY( 245)/'MOVE', -3, 5/ 7374 DATA IOPERA( 246),IX( 246),IY( 246)/'DRAW', 4, 5/ 7375C 7376 DATA IXMIND( 20)/ -5/ 7377 DATA IXMAXD( 20)/ 7/ 7378 DATA IXDELD( 20)/ 12/ 7379 DATA ISTARD( 20)/ 240/ 7380 DATA NUMCOO( 20)/ 7/ 7381C 7382C DEFINE CHARACTER 621--LOWER CASE U 7383C 7384 DATA IOPERA( 247),IX( 247),IY( 247)/'MOVE', -5, 5/ 7385 DATA IOPERA( 248),IX( 248),IY( 248)/'DRAW', -5, -5/ 7386 DATA IOPERA( 249),IX( 249),IY( 249)/'DRAW', -4, -8/ 7387 DATA IOPERA( 250),IX( 250),IY( 250)/'DRAW', -2, -9/ 7388 DATA IOPERA( 251),IX( 251),IY( 251)/'DRAW', 1, -9/ 7389 DATA IOPERA( 252),IX( 252),IY( 252)/'DRAW', 3, -8/ 7390 DATA IOPERA( 253),IX( 253),IY( 253)/'DRAW', 6, -5/ 7391 DATA IOPERA( 254),IX( 254),IY( 254)/'MOVE', 6, 5/ 7392 DATA IOPERA( 255),IX( 255),IY( 255)/'DRAW', 6, -9/ 7393C 7394 DATA IXMIND( 21)/ -9/ 7395 DATA IXMAXD( 21)/ 10/ 7396 DATA IXDELD( 21)/ 19/ 7397 DATA ISTARD( 21)/ 247/ 7398 DATA NUMCOO( 21)/ 9/ 7399C 7400C DEFINE CHARACTER 622--LOWER CASE V 7401C 7402 DATA IOPERA( 256),IX( 256),IY( 256)/'MOVE', -6, 5/ 7403 DATA IOPERA( 257),IX( 257),IY( 257)/'DRAW', 0, -9/ 7404 DATA IOPERA( 258),IX( 258),IY( 258)/'MOVE', 6, 5/ 7405 DATA IOPERA( 259),IX( 259),IY( 259)/'DRAW', 0, -9/ 7406C 7407 DATA IXMIND( 22)/ -8/ 7408 DATA IXMAXD( 22)/ 8/ 7409 DATA IXDELD( 22)/ 16/ 7410 DATA ISTARD( 22)/ 256/ 7411 DATA NUMCOO( 22)/ 4/ 7412C 7413C DEFINE CHARACTER 623--LOWER CASE W 7414C 7415 DATA IOPERA( 260),IX( 260),IY( 260)/'MOVE', -8, 5/ 7416 DATA IOPERA( 261),IX( 261),IY( 261)/'DRAW', -4, -9/ 7417 DATA IOPERA( 262),IX( 262),IY( 262)/'MOVE', 0, 5/ 7418 DATA IOPERA( 263),IX( 263),IY( 263)/'DRAW', -4, -9/ 7419 DATA IOPERA( 264),IX( 264),IY( 264)/'MOVE', 0, 5/ 7420 DATA IOPERA( 265),IX( 265),IY( 265)/'DRAW', 4, -9/ 7421 DATA IOPERA( 266),IX( 266),IY( 266)/'MOVE', 8, 5/ 7422 DATA IOPERA( 267),IX( 267),IY( 267)/'DRAW', 4, -9/ 7423C 7424 DATA IXMIND( 23)/ -11/ 7425 DATA IXMAXD( 23)/ 11/ 7426 DATA IXDELD( 23)/ 22/ 7427 DATA ISTARD( 23)/ 260/ 7428 DATA NUMCOO( 23)/ 8/ 7429C 7430C DEFINE CHARACTER 624--LOWER CASE X 7431C 7432 DATA IOPERA( 268),IX( 268),IY( 268)/'MOVE', -5, 5/ 7433 DATA IOPERA( 269),IX( 269),IY( 269)/'DRAW', 6, -9/ 7434 DATA IOPERA( 270),IX( 270),IY( 270)/'MOVE', 6, 5/ 7435 DATA IOPERA( 271),IX( 271),IY( 271)/'DRAW', -5, -9/ 7436C 7437 DATA IXMIND( 24)/ -8/ 7438 DATA IXMAXD( 24)/ 9/ 7439 DATA IXDELD( 24)/ 17/ 7440 DATA ISTARD( 24)/ 268/ 7441 DATA NUMCOO( 24)/ 4/ 7442C 7443C DEFINE CHARACTER 625--LOWER CASE Y 7444C 7445 DATA IOPERA( 272),IX( 272),IY( 272)/'MOVE', -6, 5/ 7446 DATA IOPERA( 273),IX( 273),IY( 273)/'DRAW', 0, -9/ 7447 DATA IOPERA( 274),IX( 274),IY( 274)/'MOVE', 6, 5/ 7448 DATA IOPERA( 275),IX( 275),IY( 275)/'DRAW', 0, -9/ 7449 DATA IOPERA( 276),IX( 276),IY( 276)/'DRAW', -2, -13/ 7450 DATA IOPERA( 277),IX( 277),IY( 277)/'DRAW', -4, -15/ 7451 DATA IOPERA( 278),IX( 278),IY( 278)/'DRAW', -6, -16/ 7452 DATA IOPERA( 279),IX( 279),IY( 279)/'DRAW', -7, -16/ 7453C 7454 DATA IXMIND( 25)/ -8/ 7455 DATA IXMAXD( 25)/ 8/ 7456 DATA IXDELD( 25)/ 16/ 7457 DATA ISTARD( 25)/ 272/ 7458 DATA NUMCOO( 25)/ 8/ 7459C 7460C DEFINE CHARACTER 626--LOWER CASE Z 7461C 7462 DATA IOPERA( 280),IX( 280),IY( 280)/'MOVE', 6, 5/ 7463 DATA IOPERA( 281),IX( 281),IY( 281)/'DRAW', -5, -9/ 7464 DATA IOPERA( 282),IX( 282),IY( 282)/'MOVE', -5, 5/ 7465 DATA IOPERA( 283),IX( 283),IY( 283)/'DRAW', 6, 5/ 7466 DATA IOPERA( 284),IX( 284),IY( 284)/'MOVE', -5, -9/ 7467 DATA IOPERA( 285),IX( 285),IY( 285)/'DRAW', 6, -9/ 7468C 7469 DATA IXMIND( 26)/ -8/ 7470 DATA IXMAXD( 26)/ 9/ 7471 DATA IXDELD( 26)/ 17/ 7472 DATA ISTARD( 26)/ 280/ 7473 DATA NUMCOO( 26)/ 6/ 7474C 7475C-----START POINT----------------------------------------------------- 7476C 7477 IFOUND='NO' 7478 IERROR='NO' 7479C 7480 NUMCO=1 7481 ISTART=1 7482 ISTOP=1 7483 NC=1 7484C 7485C ****************************************** 7486C ****************************************** 7487C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 7488C ** HERSHEY CHARACTER SET CASE ** 7489C ****************************************** 7490C ****************************************** 7491C 7492C 7493 IF(IBUGD2.EQ.'OFF')GOTO90 7494 WRITE(ICOUT,999) 7495 999 FORMAT(1X) 7496 CALL DPWRST('XXX','BUG ') 7497 WRITE(ICOUT,51) 7498 51 FORMAT('***** AT THE BEGINNING OF DPRSL--') 7499 CALL DPWRST('XXX','BUG ') 7500 WRITE(ICOUT,52)ICHAR2 7501 52 FORMAT('ICHAR2 = ',A4) 7502 CALL DPWRST('XXX','BUG ') 7503 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 7504 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 7505 CALL DPWRST('XXX','BUG ') 7506 90 CONTINUE 7507C 7508C ************************************************** 7509C ************************************************** 7510C ** STEP 1-- ** 7511C ** SEARCH FOR THE INPUT CHARACTER(S). ** 7512C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** 7513C ************************************************** 7514C ************************************************** 7515C 7516 CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND) 7517 IF(IFOUND.EQ.'NO')GOTO9000 7518 GOTO1000 7519C 7520C ************************************** 7521C ************************************** 7522C ** STEP 2-- ** 7523C ** EXTRACT THE COORDINATES ** 7524C ** FOR THIS PARTICULAR CHARACTER. ** 7525C ************************************** 7526C ************************************** 7527C 7528 1000 CONTINUE 7529 ISTART=ISTARD(ICHARN) 7530 NC=NUMCOO(ICHARN) 7531 ISTOP=ISTART+NC-1 7532 J=0 7533 DO1100I=ISTART,ISTOP 7534 J=J+1 7535 IOP(J)=IOPERA(I) 7536 X(J)=IX(I) 7537 Y(J)=IY(I) 7538 1100 CONTINUE 7539 NUMCO=J 7540 IXMINS=IXMIND(ICHARN) 7541 IXMAXS=IXMAXD(ICHARN) 7542 IXDELS=IXDELD(ICHARN) 7543C 7544 GOTO9000 7545C 7546C ***************** 7547C ***************** 7548C ** STEP 90-- ** 7549C ** EXIT ** 7550C ***************** 7551C ***************** 7552C 7553 9000 CONTINUE 7554 IF(IBUGD2.EQ.'OFF')GOTO9090 7555 WRITE(ICOUT,999) 7556 CALL DPWRST('XXX','BUG ') 7557 WRITE(ICOUT,9011) 7558 9011 FORMAT('***** AT THE END OF DPRSL--') 7559 CALL DPWRST('XXX','BUG ') 7560 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 7561 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 7562 CALL DPWRST('XXX','BUG ') 7563 WRITE(ICOUT,9013)ICHAR2,ICHARN 7564 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) 7565 CALL DPWRST('XXX','BUG ') 7566 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 7567 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 7568 CALL DPWRST('XXX','BUG ') 7569 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 7570 DO9015I=1,NUMCO 7571 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 7572 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 7573 CALL DPWRST('XXX','BUG ') 7574 9015 CONTINUE 7575 9019 CONTINUE 7576 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 7577 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 7578 CALL DPWRST('XXX','BUG ') 7579 9090 CONTINUE 7580C 7581 RETURN 7582 END 7583 SUBROUTINE DPRSN(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 7584 1IBUGD2,IFOUND,IERROR) 7585C 7586C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 7587C FOR ROMAN SIMPLEX NUMERIC. 7588C WRITTEN BY--JAMES J. FILLIBEN 7589C STATISTICAL ENGINEERING DIVISION 7590C INFORMATION TECHNOLOGY LABORATORY 7591C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 7592C GAITHERSBURG, MD 20899 7593C PHONE--301-975-2855 7594C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 7595C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 7596C LANGUAGE--ANSI FORTRAN (1977) 7597C VERSION NUMBER--87/4 7598C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 7599C UPDATED --MAY 1982. 7600C UPDATED --MARCH 1987. 7601C 7602C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 7603C 7604 CHARACTER*4 ICHAR2 7605 CHARACTER*4 IOP 7606 CHARACTER*4 IBUGD2 7607 CHARACTER*4 IFOUND 7608 CHARACTER*4 IERROR 7609C 7610 CHARACTER*4 IOPERA 7611C 7612C--------------------------------------------------------------------- 7613C 7614 DIMENSION IOP(*) 7615 DIMENSION X(*) 7616 DIMENSION Y(*) 7617C 7618 DIMENSION IOPERA(300) 7619 DIMENSION IX(300) 7620 DIMENSION IY(300) 7621C 7622 DIMENSION IXMIND(30) 7623 DIMENSION IXMAXD(30) 7624 DIMENSION IXDELD(30) 7625 DIMENSION ISTARD(30) 7626 DIMENSION NUMCOO(30) 7627C 7628C--------------------------------------------------------------------- 7629C 7630 INCLUDE 'DPCOP2.INC' 7631C 7632C-----DATA STATEMENTS------------------------------------------------- 7633C 7634C DEFINE CHARACTER 700--0 7635C 7636 DATA IOPERA( 1),IX( 1),IY( 1)/'MOVE', -1, 12/ 7637 DATA IOPERA( 2),IX( 2),IY( 2)/'DRAW', -4, 11/ 7638 DATA IOPERA( 3),IX( 3),IY( 3)/'DRAW', -6, 8/ 7639 DATA IOPERA( 4),IX( 4),IY( 4)/'DRAW', -7, 3/ 7640 DATA IOPERA( 5),IX( 5),IY( 5)/'DRAW', -7, 0/ 7641 DATA IOPERA( 6),IX( 6),IY( 6)/'DRAW', -6, -5/ 7642 DATA IOPERA( 7),IX( 7),IY( 7)/'DRAW', -4, -8/ 7643 DATA IOPERA( 8),IX( 8),IY( 8)/'DRAW', -1, -9/ 7644 DATA IOPERA( 9),IX( 9),IY( 9)/'DRAW', 1, -9/ 7645 DATA IOPERA( 10),IX( 10),IY( 10)/'DRAW', 4, -8/ 7646 DATA IOPERA( 11),IX( 11),IY( 11)/'DRAW', 6, -5/ 7647 DATA IOPERA( 12),IX( 12),IY( 12)/'DRAW', 7, 0/ 7648 DATA IOPERA( 13),IX( 13),IY( 13)/'DRAW', 7, 3/ 7649 DATA IOPERA( 14),IX( 14),IY( 14)/'DRAW', 6, 8/ 7650 DATA IOPERA( 15),IX( 15),IY( 15)/'DRAW', 4, 11/ 7651 DATA IOPERA( 16),IX( 16),IY( 16)/'DRAW', 1, 12/ 7652 DATA IOPERA( 17),IX( 17),IY( 17)/'DRAW', -1, 12/ 7653C 7654 DATA IXMIND( 1)/ -10/ 7655 DATA IXMAXD( 1)/ 10/ 7656 DATA IXDELD( 1)/ 20/ 7657 DATA ISTARD( 1)/ 1/ 7658 DATA NUMCOO( 1)/ 17/ 7659C 7660C DEFINE CHARACTER 701--1 7661C 7662 DATA IOPERA( 18),IX( 18),IY( 18)/'MOVE', -4, 8/ 7663 DATA IOPERA( 19),IX( 19),IY( 19)/'DRAW', -2, 9/ 7664 DATA IOPERA( 20),IX( 20),IY( 20)/'DRAW', 1, 12/ 7665 DATA IOPERA( 21),IX( 21),IY( 21)/'DRAW', 1, -9/ 7666C 7667 DATA IXMIND( 2)/ -10/ 7668 DATA IXMAXD( 2)/ 10/ 7669 DATA IXDELD( 2)/ 20/ 7670 DATA ISTARD( 2)/ 18/ 7671 DATA NUMCOO( 2)/ 4/ 7672C 7673C DEFINE CHARACTER 702--2 7674C 7675 DATA IOPERA( 22),IX( 22),IY( 22)/'MOVE', -6, 7/ 7676 DATA IOPERA( 23),IX( 23),IY( 23)/'DRAW', -6, 8/ 7677 DATA IOPERA( 24),IX( 24),IY( 24)/'DRAW', -5, 10/ 7678 DATA IOPERA( 25),IX( 25),IY( 25)/'DRAW', -4, 11/ 7679 DATA IOPERA( 26),IX( 26),IY( 26)/'DRAW', -2, 12/ 7680 DATA IOPERA( 27),IX( 27),IY( 27)/'DRAW', 2, 12/ 7681 DATA IOPERA( 28),IX( 28),IY( 28)/'DRAW', 4, 11/ 7682 DATA IOPERA( 29),IX( 29),IY( 29)/'DRAW', 5, 10/ 7683 DATA IOPERA( 30),IX( 30),IY( 30)/'DRAW', 6, 8/ 7684 DATA IOPERA( 31),IX( 31),IY( 31)/'DRAW', 6, 6/ 7685 DATA IOPERA( 32),IX( 32),IY( 32)/'DRAW', 5, 4/ 7686 DATA IOPERA( 33),IX( 33),IY( 33)/'DRAW', 3, 1/ 7687 DATA IOPERA( 34),IX( 34),IY( 34)/'DRAW', -7, -9/ 7688 DATA IOPERA( 35),IX( 35),IY( 35)/'DRAW', 7, -9/ 7689C 7690 DATA IXMIND( 3)/ -10/ 7691 DATA IXMAXD( 3)/ 10/ 7692 DATA IXDELD( 3)/ 20/ 7693 DATA ISTARD( 3)/ 22/ 7694 DATA NUMCOO( 3)/ 14/ 7695C 7696C DEFINE CHARACTER 703--3 7697C 7698 DATA IOPERA( 36),IX( 36),IY( 36)/'MOVE', -5, 12/ 7699 DATA IOPERA( 37),IX( 37),IY( 37)/'DRAW', 6, 12/ 7700 DATA IOPERA( 38),IX( 38),IY( 38)/'DRAW', 0, 4/ 7701 DATA IOPERA( 39),IX( 39),IY( 39)/'DRAW', 3, 4/ 7702 DATA IOPERA( 40),IX( 40),IY( 40)/'DRAW', 5, 3/ 7703 DATA IOPERA( 41),IX( 41),IY( 41)/'DRAW', 6, 2/ 7704 DATA IOPERA( 42),IX( 42),IY( 42)/'DRAW', 7, -1/ 7705 DATA IOPERA( 43),IX( 43),IY( 43)/'DRAW', 7, -3/ 7706 DATA IOPERA( 44),IX( 44),IY( 44)/'DRAW', 6, -6/ 7707 DATA IOPERA( 45),IX( 45),IY( 45)/'DRAW', 4, -8/ 7708 DATA IOPERA( 46),IX( 46),IY( 46)/'DRAW', 1, -9/ 7709 DATA IOPERA( 47),IX( 47),IY( 47)/'DRAW', -2, -9/ 7710 DATA IOPERA( 48),IX( 48),IY( 48)/'DRAW', -5, -8/ 7711 DATA IOPERA( 49),IX( 49),IY( 49)/'DRAW', -6, -7/ 7712 DATA IOPERA( 50),IX( 50),IY( 50)/'DRAW', -7, -5/ 7713C 7714 DATA IXMIND( 4)/ -10/ 7715 DATA IXMAXD( 4)/ 10/ 7716 DATA IXDELD( 4)/ 20/ 7717 DATA ISTARD( 4)/ 36/ 7718 DATA NUMCOO( 4)/ 15/ 7719C 7720C DEFINE CHARACTER 704--4 7721C 7722 DATA IOPERA( 51),IX( 51),IY( 51)/'MOVE', 3, 12/ 7723 DATA IOPERA( 52),IX( 52),IY( 52)/'DRAW', -7, -2/ 7724 DATA IOPERA( 53),IX( 53),IY( 53)/'DRAW', 8, -2/ 7725 DATA IOPERA( 54),IX( 54),IY( 54)/'MOVE', 3, 12/ 7726 DATA IOPERA( 55),IX( 55),IY( 55)/'DRAW', 3, -9/ 7727C 7728 DATA IXMIND( 5)/ -10/ 7729 DATA IXMAXD( 5)/ 10/ 7730 DATA IXDELD( 5)/ 20/ 7731 DATA ISTARD( 5)/ 51/ 7732 DATA NUMCOO( 5)/ 5/ 7733C 7734C DEFINE CHARACTER 705--5 7735C 7736 DATA IOPERA( 56),IX( 56),IY( 56)/'MOVE', 5, 12/ 7737 DATA IOPERA( 57),IX( 57),IY( 57)/'DRAW', -5, 12/ 7738 DATA IOPERA( 58),IX( 58),IY( 58)/'DRAW', -6, 3/ 7739 DATA IOPERA( 59),IX( 59),IY( 59)/'DRAW', -5, 4/ 7740 DATA IOPERA( 60),IX( 60),IY( 60)/'DRAW', -2, 5/ 7741 DATA IOPERA( 61),IX( 61),IY( 61)/'DRAW', 1, 5/ 7742 DATA IOPERA( 62),IX( 62),IY( 62)/'DRAW', 4, 4/ 7743 DATA IOPERA( 63),IX( 63),IY( 63)/'DRAW', 6, 2/ 7744 DATA IOPERA( 64),IX( 64),IY( 64)/'DRAW', 7, -1/ 7745 DATA IOPERA( 65),IX( 65),IY( 65)/'DRAW', 7, -3/ 7746 DATA IOPERA( 66),IX( 66),IY( 66)/'DRAW', 6, -6/ 7747 DATA IOPERA( 67),IX( 67),IY( 67)/'DRAW', 4, -8/ 7748 DATA IOPERA( 68),IX( 68),IY( 68)/'DRAW', 1, -9/ 7749 DATA IOPERA( 69),IX( 69),IY( 69)/'DRAW', -2, -9/ 7750 DATA IOPERA( 70),IX( 70),IY( 70)/'DRAW', -5, -8/ 7751 DATA IOPERA( 71),IX( 71),IY( 71)/'DRAW', -6, -7/ 7752 DATA IOPERA( 72),IX( 72),IY( 72)/'DRAW', -7, -5/ 7753C 7754 DATA IXMIND( 6)/ -10/ 7755 DATA IXMAXD( 6)/ 10/ 7756 DATA IXDELD( 6)/ 20/ 7757 DATA ISTARD( 6)/ 56/ 7758 DATA NUMCOO( 6)/ 17/ 7759C 7760C DEFINE CHARACTER 706--6 7761C 7762 DATA IOPERA( 73),IX( 73),IY( 73)/'MOVE', 6, 9/ 7763 DATA IOPERA( 74),IX( 74),IY( 74)/'DRAW', 5, 11/ 7764 DATA IOPERA( 75),IX( 75),IY( 75)/'DRAW', 2, 12/ 7765 DATA IOPERA( 76),IX( 76),IY( 76)/'DRAW', 0, 12/ 7766 DATA IOPERA( 77),IX( 77),IY( 77)/'DRAW', -3, 11/ 7767 DATA IOPERA( 78),IX( 78),IY( 78)/'DRAW', -5, 8/ 7768 DATA IOPERA( 79),IX( 79),IY( 79)/'DRAW', -6, 3/ 7769 DATA IOPERA( 80),IX( 80),IY( 80)/'DRAW', -6, -2/ 7770 DATA IOPERA( 81),IX( 81),IY( 81)/'DRAW', -5, -6/ 7771 DATA IOPERA( 82),IX( 82),IY( 82)/'DRAW', -3, -8/ 7772 DATA IOPERA( 83),IX( 83),IY( 83)/'DRAW', 0, -9/ 7773 DATA IOPERA( 84),IX( 84),IY( 84)/'DRAW', 1, -9/ 7774 DATA IOPERA( 85),IX( 85),IY( 85)/'DRAW', 4, -8/ 7775 DATA IOPERA( 86),IX( 86),IY( 86)/'DRAW', 6, -6/ 7776 DATA IOPERA( 87),IX( 87),IY( 87)/'DRAW', 7, -3/ 7777 DATA IOPERA( 88),IX( 88),IY( 88)/'DRAW', 7, -2/ 7778 DATA IOPERA( 89),IX( 89),IY( 89)/'DRAW', 6, 1/ 7779 DATA IOPERA( 90),IX( 90),IY( 90)/'DRAW', 4, 3/ 7780 DATA IOPERA( 91),IX( 91),IY( 91)/'DRAW', 1, 4/ 7781 DATA IOPERA( 92),IX( 92),IY( 92)/'DRAW', 0, 4/ 7782 DATA IOPERA( 93),IX( 93),IY( 93)/'DRAW', -3, 3/ 7783 DATA IOPERA( 94),IX( 94),IY( 94)/'DRAW', -5, 1/ 7784 DATA IOPERA( 95),IX( 95),IY( 95)/'DRAW', -6, -2/ 7785C 7786 DATA IXMIND( 7)/ -10/ 7787 DATA IXMAXD( 7)/ 10/ 7788 DATA IXDELD( 7)/ 20/ 7789 DATA ISTARD( 7)/ 73/ 7790 DATA NUMCOO( 7)/ 23/ 7791C 7792C DEFINE CHARACTER 707--7 7793C 7794 DATA IOPERA( 96),IX( 96),IY( 96)/'MOVE', 7, 12/ 7795 DATA IOPERA( 97),IX( 97),IY( 97)/'DRAW', -3, -9/ 7796 DATA IOPERA( 98),IX( 98),IY( 98)/'MOVE', -7, 12/ 7797 DATA IOPERA( 99),IX( 99),IY( 99)/'DRAW', 7, 12/ 7798C 7799 DATA IXMIND( 8)/ -10/ 7800 DATA IXMAXD( 8)/ 10/ 7801 DATA IXDELD( 8)/ 20/ 7802 DATA ISTARD( 8)/ 96/ 7803 DATA NUMCOO( 8)/ 4/ 7804C 7805C DEFINE CHARACTER 708--8 7806C 7807 DATA IOPERA( 100),IX( 100),IY( 100)/'MOVE', -2, 12/ 7808 DATA IOPERA( 101),IX( 101),IY( 101)/'DRAW', -5, 11/ 7809 DATA IOPERA( 102),IX( 102),IY( 102)/'DRAW', -6, 9/ 7810 DATA IOPERA( 103),IX( 103),IY( 103)/'DRAW', -6, 7/ 7811 DATA IOPERA( 104),IX( 104),IY( 104)/'DRAW', -5, 5/ 7812 DATA IOPERA( 105),IX( 105),IY( 105)/'DRAW', -3, 4/ 7813 DATA IOPERA( 106),IX( 106),IY( 106)/'DRAW', 1, 3/ 7814 DATA IOPERA( 107),IX( 107),IY( 107)/'DRAW', 4, 2/ 7815 DATA IOPERA( 108),IX( 108),IY( 108)/'DRAW', 6, 0/ 7816 DATA IOPERA( 109),IX( 109),IY( 109)/'DRAW', 7, -2/ 7817 DATA IOPERA( 110),IX( 110),IY( 110)/'DRAW', 7, -5/ 7818 DATA IOPERA( 111),IX( 111),IY( 111)/'DRAW', 6, -7/ 7819 DATA IOPERA( 112),IX( 112),IY( 112)/'DRAW', 5, -8/ 7820 DATA IOPERA( 113),IX( 113),IY( 113)/'DRAW', 2, -9/ 7821 DATA IOPERA( 114),IX( 114),IY( 114)/'DRAW', -2, -9/ 7822 DATA IOPERA( 115),IX( 115),IY( 115)/'DRAW', -5, -8/ 7823 DATA IOPERA( 116),IX( 116),IY( 116)/'DRAW', -6, -7/ 7824 DATA IOPERA( 117),IX( 117),IY( 117)/'DRAW', -7, -5/ 7825 DATA IOPERA( 118),IX( 118),IY( 118)/'DRAW', -7, -2/ 7826 DATA IOPERA( 119),IX( 119),IY( 119)/'DRAW', -6, 0/ 7827 DATA IOPERA( 120),IX( 120),IY( 120)/'DRAW', -4, 2/ 7828 DATA IOPERA( 121),IX( 121),IY( 121)/'DRAW', -1, 3/ 7829 DATA IOPERA( 122),IX( 122),IY( 122)/'DRAW', 3, 4/ 7830 DATA IOPERA( 123),IX( 123),IY( 123)/'DRAW', 5, 5/ 7831 DATA IOPERA( 124),IX( 124),IY( 124)/'DRAW', 6, 7/ 7832 DATA IOPERA( 125),IX( 125),IY( 125)/'DRAW', 6, 9/ 7833 DATA IOPERA( 126),IX( 126),IY( 126)/'DRAW', 5, 11/ 7834 DATA IOPERA( 127),IX( 127),IY( 127)/'DRAW', 2, 12/ 7835 DATA IOPERA( 128),IX( 128),IY( 128)/'DRAW', -2, 12/ 7836C 7837 DATA IXMIND( 9)/ -10/ 7838 DATA IXMAXD( 9)/ 10/ 7839 DATA IXDELD( 9)/ 20/ 7840 DATA ISTARD( 9)/ 100/ 7841 DATA NUMCOO( 9)/ 29/ 7842C 7843C DEFINE CHARACTER 709--9 7844C 7845 DATA IOPERA( 129),IX( 129),IY( 129)/'MOVE', 6, 5/ 7846 DATA IOPERA( 130),IX( 130),IY( 130)/'DRAW', 5, 2/ 7847 DATA IOPERA( 131),IX( 131),IY( 131)/'DRAW', 3, 0/ 7848 DATA IOPERA( 132),IX( 132),IY( 132)/'DRAW', 0, -1/ 7849 DATA IOPERA( 133),IX( 133),IY( 133)/'DRAW', -1, -1/ 7850 DATA IOPERA( 134),IX( 134),IY( 134)/'DRAW', -4, 0/ 7851 DATA IOPERA( 135),IX( 135),IY( 135)/'DRAW', -6, 2/ 7852 DATA IOPERA( 136),IX( 136),IY( 136)/'DRAW', -7, 5/ 7853 DATA IOPERA( 137),IX( 137),IY( 137)/'DRAW', -7, 6/ 7854 DATA IOPERA( 138),IX( 138),IY( 138)/'DRAW', -6, 9/ 7855 DATA IOPERA( 139),IX( 139),IY( 139)/'DRAW', -4, 11/ 7856 DATA IOPERA( 140),IX( 140),IY( 140)/'DRAW', -1, 12/ 7857 DATA IOPERA( 141),IX( 141),IY( 141)/'DRAW', 0, 12/ 7858 DATA IOPERA( 142),IX( 142),IY( 142)/'DRAW', 3, 11/ 7859 DATA IOPERA( 143),IX( 143),IY( 143)/'DRAW', 5, 9/ 7860 DATA IOPERA( 144),IX( 144),IY( 144)/'DRAW', 6, 5/ 7861 DATA IOPERA( 145),IX( 145),IY( 145)/'DRAW', 6, 0/ 7862 DATA IOPERA( 146),IX( 146),IY( 146)/'DRAW', 5, -5/ 7863 DATA IOPERA( 147),IX( 147),IY( 147)/'DRAW', 3, -8/ 7864 DATA IOPERA( 148),IX( 148),IY( 148)/'DRAW', 0, -9/ 7865 DATA IOPERA( 149),IX( 149),IY( 149)/'DRAW', -2, -9/ 7866 DATA IOPERA( 150),IX( 150),IY( 150)/'DRAW', -5, -8/ 7867 DATA IOPERA( 151),IX( 151),IY( 151)/'DRAW', -6, -6/ 7868C 7869 DATA IXMIND( 10)/ -10/ 7870 DATA IXMAXD( 10)/ 10/ 7871 DATA IXDELD( 10)/ 20/ 7872 DATA ISTARD( 10)/ 129/ 7873 DATA NUMCOO( 10)/ 23/ 7874C 7875C-----START POINT----------------------------------------------------- 7876C 7877 IFOUND='NO' 7878 IERROR='NO' 7879C 7880 NUMCO=1 7881 ISTART=1 7882 ISTOP=1 7883 NC=1 7884C 7885C ****************************************** 7886C ****************************************** 7887C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 7888C ** HERSHEY CHARACTER SET CASE ** 7889C ****************************************** 7890C ****************************************** 7891C 7892C 7893 IF(IBUGD2.EQ.'OFF')GOTO90 7894 WRITE(ICOUT,999) 7895 999 FORMAT(1X) 7896 CALL DPWRST('XXX','BUG ') 7897 WRITE(ICOUT,51) 7898 51 FORMAT('***** AT THE BEGINNING OF DPRSN--') 7899 CALL DPWRST('XXX','BUG ') 7900 WRITE(ICOUT,52)ICHAR2 7901 52 FORMAT('ICHAR2 = ',A4) 7902 CALL DPWRST('XXX','BUG ') 7903 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 7904 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 7905 CALL DPWRST('XXX','BUG ') 7906 90 CONTINUE 7907C 7908C ************************************************** 7909C ************************************************** 7910C ** STEP 1-- ** 7911C ** SEARCH FOR THE INPUT CHARACTER(S). ** 7912C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** 7913C ************************************************** 7914C ************************************************** 7915C 7916 CALL DPCHNU(ICHAR2,ICHARN,IBUGD2,IFOUND) 7917 IF(IFOUND.EQ.'NO')GOTO9000 7918 GOTO1000 7919C 7920C ************************************** 7921C ************************************** 7922C ** STEP 2-- ** 7923C ** EXTRACT THE COORDINATES ** 7924C ** FOR THIS PARTICULAR CHARACTER. ** 7925C ************************************** 7926C ************************************** 7927C 7928 1000 CONTINUE 7929 ISTART=ISTARD(ICHARN) 7930 NC=NUMCOO(ICHARN) 7931 ISTOP=ISTART+NC-1 7932 J=0 7933 DO1100I=ISTART,ISTOP 7934 J=J+1 7935 IOP(J)=IOPERA(I) 7936 X(J)=IX(I) 7937 Y(J)=IY(I) 7938 1100 CONTINUE 7939 NUMCO=J 7940 IXMINS=IXMIND(ICHARN) 7941 IXMAXS=IXMAXD(ICHARN) 7942 IXDELS=IXDELD(ICHARN) 7943C 7944 GOTO9000 7945C 7946C ***************** 7947C ***************** 7948C ** STEP 90-- ** 7949C ** EXIT ** 7950C ***************** 7951C ***************** 7952C 7953 9000 CONTINUE 7954 IF(IBUGD2.EQ.'OFF')GOTO9090 7955 WRITE(ICOUT,999) 7956 CALL DPWRST('XXX','BUG ') 7957 WRITE(ICOUT,9011) 7958 9011 FORMAT('***** AT THE END OF DPRSN--') 7959 CALL DPWRST('XXX','BUG ') 7960 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 7961 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 7962 CALL DPWRST('XXX','BUG ') 7963 WRITE(ICOUT,9013)ICHAR2,ICHARN 7964 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) 7965 CALL DPWRST('XXX','BUG ') 7966 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 7967 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 7968 CALL DPWRST('XXX','BUG ') 7969 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 7970 DO9015I=1,NUMCO 7971 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 7972 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 7973 CALL DPWRST('XXX','BUG ') 7974 9015 CONTINUE 7975 9019 CONTINUE 7976 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 7977 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 7978 CALL DPWRST('XXX','BUG ') 7979 9090 CONTINUE 7980C 7981 RETURN 7982 END 7983 SUBROUTINE DPRSS(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 7984 1IBUGD2,IFOUND,IERROR) 7985C 7986C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 7987C FOR ROMAN SIMPLEX SYMBOLS. 7988C WRITTEN BY--JAMES J. FILLIBEN 7989C STATISTICAL ENGINEERING DIVISION 7990C INFORMATION TECHNOLOGY LABORATORY 7991C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 7992C GAITHERSBURG, MD 20899 7993C PHONE--301-975-2855 7994C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 7995C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 7996C LANGUAGE--ANSI FORTRAN (1977) 7997C VERSION NUMBER--87/4 7998C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 7999C UPDATED --MARCH 1982. 8000C UPDATED --MAY 1982. 8001C UPDATED --MARCH 1987. 8002C UPDATED --MAY 1987. 8003C 8004C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 8005C 8006 CHARACTER*4 ICHAR2 8007 CHARACTER*4 IOP 8008 CHARACTER*4 IBUGD2 8009 CHARACTER*4 IFOUND 8010 CHARACTER*4 IERROR 8011C 8012 CHARACTER*4 IOPERA 8013C 8014C--------------------------------------------------------------------- 8015C 8016 DIMENSION IOP(*) 8017 DIMENSION X(*) 8018 DIMENSION Y(*) 8019C 8020 DIMENSION IOPERA(300) 8021 DIMENSION IX(300) 8022 DIMENSION IY(300) 8023C 8024 DIMENSION IXMIND(30) 8025 DIMENSION IXMAXD(30) 8026 DIMENSION IXDELD(30) 8027 DIMENSION ISTARD(30) 8028 DIMENSION NUMCOO(30) 8029C 8030C--------------------------------------------------------------------- 8031C 8032 INCLUDE 'DPCOP2.INC' 8033C 8034C-----DATA STATEMENTS------------------------------------------------- 8035C 8036C DEFINE CHARACTER 710--. (PERIOD) 8037C 8038 DATA IOPERA( 1),IX( 1),IY( 1)/'MOVE', 0, -7/ 8039 DATA IOPERA( 2),IX( 2),IY( 2)/'DRAW', -1, -8/ 8040 DATA IOPERA( 3),IX( 3),IY( 3)/'DRAW', 0, -9/ 8041 DATA IOPERA( 4),IX( 4),IY( 4)/'DRAW', 1, -8/ 8042 DATA IOPERA( 5),IX( 5),IY( 5)/'DRAW', 0, -7/ 8043C 8044 DATA IXMIND( 1)/ -5/ 8045 DATA IXMAXD( 1)/ 5/ 8046 DATA IXDELD( 1)/ 10/ 8047 DATA ISTARD( 1)/ 1/ 8048 DATA NUMCOO( 1)/ 5/ 8049C 8050C DEFINE CHARACTER 711--, (COMMA) 8051C 8052 DATA IOPERA( 6),IX( 6),IY( 6)/'MOVE', 1, -8/ 8053 DATA IOPERA( 7),IX( 7),IY( 7)/'DRAW', 0, -9/ 8054 DATA IOPERA( 8),IX( 8),IY( 8)/'DRAW', -1, -8/ 8055 DATA IOPERA( 9),IX( 9),IY( 9)/'DRAW', 0, -7/ 8056 DATA IOPERA( 10),IX( 10),IY( 10)/'DRAW', 1, -8/ 8057 DATA IOPERA( 11),IX( 11),IY( 11)/'DRAW', 1, -10/ 8058 DATA IOPERA( 12),IX( 12),IY( 12)/'DRAW', 0, -12/ 8059 DATA IOPERA( 13),IX( 13),IY( 13)/'DRAW', -1, -13/ 8060C 8061 DATA IXMIND( 2)/ -5/ 8062 DATA IXMAXD( 2)/ 5/ 8063 DATA IXDELD( 2)/ 10/ 8064 DATA ISTARD( 2)/ 6/ 8065 DATA NUMCOO( 2)/ 8/ 8066C 8067C DEFINE CHARACTER 712--: (COLON) 8068C 8069 DATA IOPERA( 14),IX( 14),IY( 14)/'MOVE', 0, 5/ 8070 DATA IOPERA( 15),IX( 15),IY( 15)/'DRAW', -1, 4/ 8071 DATA IOPERA( 16),IX( 16),IY( 16)/'DRAW', 0, 3/ 8072 DATA IOPERA( 17),IX( 17),IY( 17)/'DRAW', 1, 4/ 8073 DATA IOPERA( 18),IX( 18),IY( 18)/'DRAW', 0, 5/ 8074 DATA IOPERA( 19),IX( 19),IY( 19)/'MOVE', 0, -7/ 8075 DATA IOPERA( 20),IX( 20),IY( 20)/'DRAW', -1, -8/ 8076 DATA IOPERA( 21),IX( 21),IY( 21)/'DRAW', 0, -9/ 8077 DATA IOPERA( 22),IX( 22),IY( 22)/'DRAW', 1, -8/ 8078 DATA IOPERA( 23),IX( 23),IY( 23)/'DRAW', 0, -7/ 8079C 8080 DATA IXMIND( 3)/ -5/ 8081 DATA IXMAXD( 3)/ 5/ 8082 DATA IXDELD( 3)/ 10/ 8083 DATA ISTARD( 3)/ 14/ 8084 DATA NUMCOO( 3)/ 10/ 8085C 8086C DEFINE CHARACTER 713--; (SEMICOLON) 8087C 8088 DATA IOPERA( 24),IX( 24),IY( 24)/'MOVE', 0, 5/ 8089 DATA IOPERA( 25),IX( 25),IY( 25)/'DRAW', -1, 4/ 8090 DATA IOPERA( 26),IX( 26),IY( 26)/'DRAW', 0, 3/ 8091 DATA IOPERA( 27),IX( 27),IY( 27)/'DRAW', 1, 4/ 8092 DATA IOPERA( 28),IX( 28),IY( 28)/'DRAW', 0, 5/ 8093 DATA IOPERA( 29),IX( 29),IY( 29)/'MOVE', 1, -8/ 8094 DATA IOPERA( 30),IX( 30),IY( 30)/'DRAW', 0, -9/ 8095 DATA IOPERA( 31),IX( 31),IY( 31)/'DRAW', -1, -8/ 8096 DATA IOPERA( 32),IX( 32),IY( 32)/'DRAW', 0, -7/ 8097 DATA IOPERA( 33),IX( 33),IY( 33)/'DRAW', 1, -8/ 8098 DATA IOPERA( 34),IX( 34),IY( 34)/'DRAW', 1, -10/ 8099 DATA IOPERA( 35),IX( 35),IY( 35)/'DRAW', 0, -12/ 8100 DATA IOPERA( 36),IX( 36),IY( 36)/'DRAW', -1, -13/ 8101C 8102 DATA IXMIND( 4)/ -5/ 8103 DATA IXMAXD( 4)/ 5/ 8104 DATA IXDELD( 4)/ 10/ 8105 DATA ISTARD( 4)/ 24/ 8106 DATA NUMCOO( 4)/ 13/ 8107C 8108C DEFINE CHARACTER 714--! (EXCLAMATION POINT) 8109C 8110 DATA IOPERA( 37),IX( 37),IY( 37)/'MOVE', 0, 12/ 8111 DATA IOPERA( 38),IX( 38),IY( 38)/'DRAW', 0, -2/ 8112 DATA IOPERA( 39),IX( 39),IY( 39)/'MOVE', 0, -7/ 8113 DATA IOPERA( 40),IX( 40),IY( 40)/'DRAW', -1, -8/ 8114 DATA IOPERA( 41),IX( 41),IY( 41)/'DRAW', 0, -9/ 8115 DATA IOPERA( 42),IX( 42),IY( 42)/'DRAW', 1, -8/ 8116 DATA IOPERA( 43),IX( 43),IY( 43)/'DRAW', 0, -7/ 8117C 8118 DATA IXMIND( 5)/ -5/ 8119 DATA IXMAXD( 5)/ 5/ 8120 DATA IXDELD( 5)/ 10/ 8121 DATA ISTARD( 5)/ 37/ 8122 DATA NUMCOO( 5)/ 7/ 8123C 8124C DEFINE CHARACTER 715--? (QUESTION MARK) 8125C 8126 DATA IOPERA( 44),IX( 44),IY( 44)/'MOVE', -6, 7/ 8127 DATA IOPERA( 45),IX( 45),IY( 45)/'DRAW', -6, 8/ 8128 DATA IOPERA( 46),IX( 46),IY( 46)/'DRAW', -5, 10/ 8129 DATA IOPERA( 47),IX( 47),IY( 47)/'DRAW', -4, 11/ 8130 DATA IOPERA( 48),IX( 48),IY( 48)/'DRAW', -2, 12/ 8131 DATA IOPERA( 49),IX( 49),IY( 49)/'DRAW', 2, 12/ 8132 DATA IOPERA( 50),IX( 50),IY( 50)/'DRAW', 4, 11/ 8133 DATA IOPERA( 51),IX( 51),IY( 51)/'DRAW', 5, 10/ 8134 DATA IOPERA( 52),IX( 52),IY( 52)/'DRAW', 6, 8/ 8135 DATA IOPERA( 53),IX( 53),IY( 53)/'DRAW', 6, 6/ 8136 DATA IOPERA( 54),IX( 54),IY( 54)/'DRAW', 5, 4/ 8137 DATA IOPERA( 55),IX( 55),IY( 55)/'DRAW', 4, 3/ 8138 DATA IOPERA( 56),IX( 56),IY( 56)/'DRAW', 0, 1/ 8139 DATA IOPERA( 57),IX( 57),IY( 57)/'DRAW', 0, -2/ 8140 DATA IOPERA( 58),IX( 58),IY( 58)/'MOVE', 0, -7/ 8141 DATA IOPERA( 59),IX( 59),IY( 59)/'DRAW', -1, -8/ 8142 DATA IOPERA( 60),IX( 60),IY( 60)/'DRAW', 0, -9/ 8143 DATA IOPERA( 61),IX( 61),IY( 61)/'DRAW', 1, -8/ 8144 DATA IOPERA( 62),IX( 62),IY( 62)/'DRAW', 0, -7/ 8145C 8146 DATA IXMIND( 6)/ -9/ 8147 DATA IXMAXD( 6)/ 9/ 8148 DATA IXDELD( 6)/ 18/ 8149 DATA ISTARD( 6)/ 44/ 8150 DATA NUMCOO( 6)/ 19/ 8151C 8152C DEFINE CHARACTER 734--& (AMPERSAND) 8153C 8154 DATA IOPERA( 63),IX( 63),IY( 63)/'MOVE', 10, 3/ 8155 DATA IOPERA( 64),IX( 64),IY( 64)/'DRAW', 10, 4/ 8156 DATA IOPERA( 65),IX( 65),IY( 65)/'DRAW', 9, 5/ 8157 DATA IOPERA( 66),IX( 66),IY( 66)/'DRAW', 8, 5/ 8158 DATA IOPERA( 67),IX( 67),IY( 67)/'DRAW', 7, 4/ 8159 DATA IOPERA( 68),IX( 68),IY( 68)/'DRAW', 6, 2/ 8160 DATA IOPERA( 69),IX( 69),IY( 69)/'DRAW', 4, -3/ 8161 DATA IOPERA( 70),IX( 70),IY( 70)/'DRAW', 2, -6/ 8162 DATA IOPERA( 71),IX( 71),IY( 71)/'DRAW', 0, -8/ 8163 DATA IOPERA( 72),IX( 72),IY( 72)/'DRAW', -2, -9/ 8164 DATA IOPERA( 73),IX( 73),IY( 73)/'DRAW', -6, -9/ 8165 DATA IOPERA( 74),IX( 74),IY( 74)/'DRAW', -8, -8/ 8166 DATA IOPERA( 75),IX( 75),IY( 75)/'DRAW', -9, -7/ 8167 DATA IOPERA( 76),IX( 76),IY( 76)/'DRAW', -10, -5/ 8168 DATA IOPERA( 77),IX( 77),IY( 77)/'DRAW', -10, -3/ 8169 DATA IOPERA( 78),IX( 78),IY( 78)/'DRAW', -9, -1/ 8170 DATA IOPERA( 79),IX( 79),IY( 79)/'DRAW', -8, 0/ 8171 DATA IOPERA( 80),IX( 80),IY( 80)/'DRAW', -1, 4/ 8172 DATA IOPERA( 81),IX( 81),IY( 81)/'DRAW', 0, 5/ 8173 DATA IOPERA( 82),IX( 82),IY( 82)/'DRAW', 1, 7/ 8174 DATA IOPERA( 83),IX( 83),IY( 83)/'DRAW', 1, 9/ 8175 DATA IOPERA( 84),IX( 84),IY( 84)/'DRAW', 0, 11/ 8176 DATA IOPERA( 85),IX( 85),IY( 85)/'DRAW', -2, 12/ 8177 DATA IOPERA( 86),IX( 86),IY( 86)/'DRAW', -4, 11/ 8178 DATA IOPERA( 87),IX( 87),IY( 87)/'DRAW', -5, 9/ 8179 DATA IOPERA( 88),IX( 88),IY( 88)/'DRAW', -5, 7/ 8180 DATA IOPERA( 89),IX( 89),IY( 89)/'DRAW', -4, 4/ 8181 DATA IOPERA( 90),IX( 90),IY( 90)/'DRAW', -2, 1/ 8182 DATA IOPERA( 91),IX( 91),IY( 91)/'DRAW', 3, -6/ 8183 DATA IOPERA( 92),IX( 92),IY( 92)/'DRAW', 5, -8/ 8184 DATA IOPERA( 93),IX( 93),IY( 93)/'DRAW', 7, -9/ 8185 DATA IOPERA( 94),IX( 94),IY( 94)/'DRAW', 9, -9/ 8186 DATA IOPERA( 95),IX( 95),IY( 95)/'DRAW', 10, -8/ 8187 DATA IOPERA( 96),IX( 96),IY( 96)/'DRAW', 10, -7/ 8188C 8189 DATA IXMIND( 7)/ -13/ 8190 DATA IXMAXD( 7)/ 13/ 8191 DATA IXDELD( 7)/ 26/ 8192 DATA ISTARD( 7)/ 63/ 8193 DATA NUMCOO( 7)/ 34/ 8194C 8195C DEFINE CHARACTER 719--$ (DOLLAR SIGN) 8196C 8197 DATA IOPERA( 97),IX( 97),IY( 97)/'MOVE', -2, 16/ 8198 DATA IOPERA( 98),IX( 98),IY( 98)/'DRAW', -2, -13/ 8199 DATA IOPERA( 99),IX( 99),IY( 99)/'MOVE', 2, 16/ 8200 DATA IOPERA( 100),IX( 100),IY( 100)/'DRAW', 2, -13/ 8201 DATA IOPERA( 101),IX( 101),IY( 101)/'MOVE', 7, 9/ 8202 DATA IOPERA( 102),IX( 102),IY( 102)/'DRAW', 5, 11/ 8203 DATA IOPERA( 103),IX( 103),IY( 103)/'DRAW', 2, 12/ 8204 DATA IOPERA( 104),IX( 104),IY( 104)/'DRAW', -2, 12/ 8205 DATA IOPERA( 105),IX( 105),IY( 105)/'DRAW', -5, 11/ 8206 DATA IOPERA( 106),IX( 106),IY( 106)/'DRAW', -7, 9/ 8207 DATA IOPERA( 107),IX( 107),IY( 107)/'DRAW', -7, 7/ 8208 DATA IOPERA( 108),IX( 108),IY( 108)/'DRAW', -6, 5/ 8209 DATA IOPERA( 109),IX( 109),IY( 109)/'DRAW', -5, 4/ 8210 DATA IOPERA( 110),IX( 110),IY( 110)/'DRAW', -3, 3/ 8211 DATA IOPERA( 111),IX( 111),IY( 111)/'DRAW', 3, 1/ 8212 DATA IOPERA( 112),IX( 112),IY( 112)/'DRAW', 5, 0/ 8213 DATA IOPERA( 113),IX( 113),IY( 113)/'DRAW', 6, -1/ 8214 DATA IOPERA( 114),IX( 114),IY( 114)/'DRAW', 7, -3/ 8215 DATA IOPERA( 115),IX( 115),IY( 115)/'DRAW', 7, -6/ 8216 DATA IOPERA( 116),IX( 116),IY( 116)/'DRAW', 5, -8/ 8217 DATA IOPERA( 117),IX( 117),IY( 117)/'DRAW', 2, -9/ 8218 DATA IOPERA( 118),IX( 118),IY( 118)/'DRAW', -2, -9/ 8219 DATA IOPERA( 119),IX( 119),IY( 119)/'DRAW', -5, -8/ 8220 DATA IOPERA( 120),IX( 120),IY( 120)/'DRAW', -7, -6/ 8221C 8222 DATA IXMIND( 8)/ -10/ 8223 DATA IXMAXD( 8)/ 10/ 8224 DATA IXDELD( 8)/ 20/ 8225 DATA ISTARD( 8)/ 97/ 8226 DATA NUMCOO( 8)/ 24/ 8227C 8228C DEFINE CHARACTER 720--/ (SLASH) 8229C 8230 DATA IOPERA( 121),IX( 121),IY( 121)/'MOVE', 9, 16/ 8231 DATA IOPERA( 122),IX( 122),IY( 122)/'DRAW', -9, -16/ 8232C 8233 DATA IXMIND( 9)/ -11/ 8234 DATA IXMAXD( 9)/ 11/ 8235 DATA IXDELD( 9)/ 22/ 8236 DATA ISTARD( 9)/ 121/ 8237 DATA NUMCOO( 9)/ 2/ 8238C 8239C DEFINE CHARACTER 721--( (LEFT PARENTHESES) 8240C 8241 DATA IOPERA( 123),IX( 123),IY( 123)/'MOVE', 4, 16/ 8242 DATA IOPERA( 124),IX( 124),IY( 124)/'DRAW', 2, 14/ 8243 DATA IOPERA( 125),IX( 125),IY( 125)/'DRAW', 0, 11/ 8244 DATA IOPERA( 126),IX( 126),IY( 126)/'DRAW', -2, 7/ 8245 DATA IOPERA( 127),IX( 127),IY( 127)/'DRAW', -3, 2/ 8246 DATA IOPERA( 128),IX( 128),IY( 128)/'DRAW', -3, -2/ 8247 DATA IOPERA( 129),IX( 129),IY( 129)/'DRAW', -2, -7/ 8248 DATA IOPERA( 130),IX( 130),IY( 130)/'DRAW', 0, -11/ 8249 DATA IOPERA( 131),IX( 131),IY( 131)/'DRAW', 2, -14/ 8250 DATA IOPERA( 132),IX( 132),IY( 132)/'DRAW', 4, -16/ 8251C 8252 DATA IXMIND( 10)/ -7/ 8253 DATA IXMAXD( 10)/ 7/ 8254 DATA IXDELD( 10)/ 14/ 8255 DATA ISTARD( 10)/ 123/ 8256 DATA NUMCOO( 10)/ 10/ 8257C 8258C DEFINE CHARACTER 722--) (RIGHT PARENTHESES) 8259C 8260 DATA IOPERA( 133),IX( 133),IY( 133)/'MOVE', -4, 16/ 8261 DATA IOPERA( 134),IX( 134),IY( 134)/'DRAW', -2, 14/ 8262 DATA IOPERA( 135),IX( 135),IY( 135)/'DRAW', 0, 11/ 8263 DATA IOPERA( 136),IX( 136),IY( 136)/'DRAW', 2, 7/ 8264 DATA IOPERA( 137),IX( 137),IY( 137)/'DRAW', 3, 2/ 8265 DATA IOPERA( 138),IX( 138),IY( 138)/'DRAW', 3, -2/ 8266 DATA IOPERA( 139),IX( 139),IY( 139)/'DRAW', 2, -7/ 8267 DATA IOPERA( 140),IX( 140),IY( 140)/'DRAW', 0, -11/ 8268 DATA IOPERA( 141),IX( 141),IY( 141)/'DRAW', -2, -14/ 8269 DATA IOPERA( 142),IX( 142),IY( 142)/'DRAW', -4, -16/ 8270C 8271 DATA IXMIND( 11)/ -7/ 8272 DATA IXMAXD( 11)/ 7/ 8273 DATA IXDELD( 11)/ 14/ 8274 DATA ISTARD( 11)/ 133/ 8275 DATA NUMCOO( 11)/ 10/ 8276C 8277C DEFINE CHARACTER 728--* (ASTERISK) 8278C 8279 DATA IOPERA( 143),IX( 143),IY( 143)/'MOVE', 0, 6/ 8280 DATA IOPERA( 144),IX( 144),IY( 144)/'DRAW', 0, -6/ 8281 DATA IOPERA( 145),IX( 145),IY( 145)/'MOVE', -5, 3/ 8282 DATA IOPERA( 146),IX( 146),IY( 146)/'DRAW', 5, -3/ 8283 DATA IOPERA( 147),IX( 147),IY( 147)/'MOVE', 5, 3/ 8284 DATA IOPERA( 148),IX( 148),IY( 148)/'DRAW', -5, -3/ 8285C 8286 DATA IXMIND( 12)/ -8/ 8287 DATA IXMAXD( 12)/ 8/ 8288 DATA IXDELD( 12)/ 16/ 8289 DATA ISTARD( 12)/ 143/ 8290 DATA NUMCOO( 12)/ 6/ 8291C 8292C DEFINE CHARACTER 724--- (HYPHEN OR MINUS SIGN) 8293C 8294 DATA IOPERA( 149),IX( 149),IY( 149)/'MOVE', -9, 0/ 8295 DATA IOPERA( 150),IX( 150),IY( 150)/'DRAW', 9, 0/ 8296C 8297 DATA IXMIND( 13)/ -13/ 8298 DATA IXMAXD( 13)/ 13/ 8299 DATA IXDELD( 13)/ 26/ 8300 DATA ISTARD( 13)/ 149/ 8301 DATA NUMCOO( 13)/ 2/ 8302C 8303C DEFINE CHARACTER 725--+ (PLUS SIGN) 8304C 8305 DATA IOPERA( 151),IX( 151),IY( 151)/'MOVE', 0, 9/ 8306 DATA IOPERA( 152),IX( 152),IY( 152)/'DRAW', 0, -9/ 8307 DATA IOPERA( 153),IX( 153),IY( 153)/'MOVE', -9, 0/ 8308 DATA IOPERA( 154),IX( 154),IY( 154)/'DRAW', 9, 0/ 8309C 8310 DATA IXMIND( 14)/ -13/ 8311 DATA IXMAXD( 14)/ 13/ 8312 DATA IXDELD( 14)/ 26/ 8313 DATA ISTARD( 14)/ 151/ 8314 DATA NUMCOO( 14)/ 4/ 8315C 8316C DEFINE CHARACTER 726--= (EQUAL SIGN) 8317C 8318 DATA IOPERA( 155),IX( 155),IY( 155)/'MOVE', -9, 3/ 8319 DATA IOPERA( 156),IX( 156),IY( 156)/'DRAW', 9, 3/ 8320 DATA IOPERA( 157),IX( 157),IY( 157)/'MOVE', -9, -3/ 8321 DATA IOPERA( 158),IX( 158),IY( 158)/'DRAW', 9, -3/ 8322C 8323 DATA IXMIND( 15)/ -13/ 8324 DATA IXMAXD( 15)/ 13/ 8325 DATA IXDELD( 15)/ 26/ 8326 DATA ISTARD( 15)/ 155/ 8327 DATA NUMCOO( 15)/ 4/ 8328C 8329C DEFINE CHARACTER 716--' (SINGLE QUOTE) 8330C 8331 DATA IOPERA( 159),IX( 159),IY( 159)/'MOVE', 0, 12/ 8332 DATA IOPERA( 160),IX( 160),IY( 160)/'DRAW', 0, 5/ 8333C 8334 DATA IXMIND( 16)/ -4/ 8335 DATA IXMAXD( 16)/ 4/ 8336 DATA IXDELD( 16)/ 8/ 8337 DATA ISTARD( 16)/ 159/ 8338 DATA NUMCOO( 16)/ 2/ 8339C 8340C DEFINE CHARACTER 717-- (DOUBLE QUOTE) 8341C 8342 DATA IOPERA( 161),IX( 161),IY( 161)/'MOVE', -4, 12/ 8343 DATA IOPERA( 162),IX( 162),IY( 162)/'DRAW', -4, 5/ 8344 DATA IOPERA( 163),IX( 163),IY( 163)/'MOVE', 4, 12/ 8345 DATA IOPERA( 164),IX( 164),IY( 164)/'DRAW', 4, 5/ 8346C 8347 DATA IXMIND( 17)/ -8/ 8348 DATA IXMAXD( 17)/ 8/ 8349 DATA IXDELD( 17)/ 16/ 8350 DATA ISTARD( 17)/ 161/ 8351 DATA NUMCOO( 17)/ 4/ 8352C 8353C DEFINE CHARACTER 718-- (DEGREES) 8354C 8355 DATA IOPERA( 165),IX( 165),IY( 165)/'MOVE', -1, 12/ 8356 DATA IOPERA( 166),IX( 166),IY( 166)/'DRAW', -3, 11/ 8357 DATA IOPERA( 167),IX( 167),IY( 167)/'DRAW', -4, 9/ 8358 DATA IOPERA( 168),IX( 168),IY( 168)/'DRAW', -4, 7/ 8359 DATA IOPERA( 169),IX( 169),IY( 169)/'DRAW', -3, 5/ 8360 DATA IOPERA( 170),IX( 170),IY( 170)/'DRAW', -1, 4/ 8361 DATA IOPERA( 171),IX( 171),IY( 171)/'DRAW', 1, 4/ 8362 DATA IOPERA( 172),IX( 172),IY( 172)/'DRAW', 3, 5/ 8363 DATA IOPERA( 173),IX( 173),IY( 173)/'DRAW', 4, 7/ 8364 DATA IOPERA( 174),IX( 174),IY( 174)/'DRAW', 4, 9/ 8365 DATA IOPERA( 175),IX( 175),IY( 175)/'DRAW', 3, 11/ 8366 DATA IOPERA( 176),IX( 176),IY( 176)/'DRAW', 1, 12/ 8367 DATA IOPERA( 177),IX( 177),IY( 177)/'DRAW', -1, 12/ 8368C 8369 DATA IXMIND( 18)/ -7/ 8370 DATA IXMAXD( 18)/ 7/ 8371 DATA IXDELD( 18)/ 14/ 8372 DATA ISTARD( 18)/ 165/ 8373 DATA NUMCOO( 18)/ 13/ 8374C 8375C DEFINE CHARACTER 2747-- (NO SPACE BLANK) 8376C 8377 DATA IOPERA( 178),IX( 178),IY( 178)/'MOVE', -32, -32/ 8378C 8379 DATA IXMIND( 19)/ 0/ 8380 DATA IXMAXD( 19)/ 0/ 8381 DATA IXDELD( 19)/ 0/ 8382 DATA ISTARD( 19)/ 178/ 8383 DATA NUMCOO( 19)/ 1/ 8384C 8385C DEFINE CHARACTER 2748-- (HALF SPACE BLANK) 8386C 8387 DATA IOPERA( 179),IX( 179),IY( 179)/'MOVE', -32, -32/ 8388C 8389 DATA IXMIND( 20)/ -4/ 8390 DATA IXMAXD( 20)/ 4/ 8391 DATA IXDELD( 20)/ 8/ 8392 DATA ISTARD( 20)/ 179/ 8393 DATA NUMCOO( 20)/ 1/ 8394C 8395C DEFINE CHARACTER 2749-- (FULL SPACE BLANK) 8396C 8397 DATA IOPERA( 180),IX( 180),IY( 180)/'MOVE', -32, -32/ 8398C 8399 DATA IXMIND( 21)/ -8/ 8400 DATA IXMAXD( 21)/ 8/ 8401 DATA IXDELD( 21)/ 16/ 8402 DATA ISTARD( 21)/ 180/ 8403 DATA NUMCOO( 21)/ 1/ 8404C 8405C DEFINE CHARACTER 730-- (LEFT APOSTRAPHE) 8406C 8407 DATA IOPERA( 181),IX( 181),IY( 181)/'MOVE', 1, 12/ 8408 DATA IOPERA( 182),IX( 182),IY( 182)/'DRAW', 0, 11/ 8409 DATA IOPERA( 183),IX( 183),IY( 183)/'DRAW', -1, 9/ 8410 DATA IOPERA( 184),IX( 184),IY( 184)/'DRAW', -1, 7/ 8411 DATA IOPERA( 185),IX( 185),IY( 185)/'DRAW', 0, 6/ 8412 DATA IOPERA( 186),IX( 186),IY( 186)/'DRAW', 1, 7/ 8413 DATA IOPERA( 187),IX( 187),IY( 187)/'DRAW', 0, 8/ 8414C 8415 DATA IXMIND( 22)/ -5/ 8416 DATA IXMAXD( 22)/ 5/ 8417 DATA IXDELD( 22)/ 10/ 8418 DATA ISTARD( 22)/ 181/ 8419 DATA NUMCOO( 22)/ 7/ 8420C 8421C DEFINE CHARACTER 731-- (RIGHT APOSTRAPHE) 8422C 8423 DATA IOPERA( 188),IX( 188),IY( 188)/'MOVE', 0, 10/ 8424 DATA IOPERA( 189),IX( 189),IY( 189)/'DRAW', -1, 11/ 8425 DATA IOPERA( 190),IX( 190),IY( 190)/'DRAW', 0, 12/ 8426 DATA IOPERA( 191),IX( 191),IY( 191)/'DRAW', 1, 11/ 8427 DATA IOPERA( 192),IX( 192),IY( 192)/'DRAW', 1, 9/ 8428 DATA IOPERA( 193),IX( 193),IY( 193)/'DRAW', 0, 7/ 8429 DATA IOPERA( 194),IX( 194),IY( 194)/'DRAW', -1, 6/ 8430C 8431 DATA IXMIND( 23)/ -5/ 8432 DATA IXMAXD( 23)/ 5/ 8433 DATA IXDELD( 23)/ 10/ 8434 DATA ISTARD( 23)/ 188/ 8435 DATA NUMCOO( 23)/ 7/ 8436C 8437C DEFINE CHARACTER XXX--| (KEYBOARD VERTICAL BAR) 8438C 8439 DATA IOPERA( 195),IX( 195),IY( 195)/'MOVE', 0, 12/ 8440 DATA IOPERA( 196),IX( 196),IY( 196)/'DRAW', 0, -9/ 8441C 8442 DATA IXMIND( 24)/ -4/ 8443 DATA IXMAXD( 24)/ 4/ 8444 DATA IXDELD( 24)/ 8/ 8445 DATA ISTARD( 24)/ 195/ 8446 DATA NUMCOO( 24)/ 2/ 8447C 8448C-----START POINT----------------------------------------------------- 8449C 8450 IFOUND='NO' 8451 IERROR='NO' 8452C 8453 NUMCO=1 8454 ISTART=1 8455 ISTOP=1 8456 NC=1 8457C 8458C ****************************************** 8459C ****************************************** 8460C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 8461C ** HERSHEY CHARACTER SET CASE ** 8462C ****************************************** 8463C ****************************************** 8464C 8465C 8466 IF(IBUGD2.EQ.'OFF')GOTO90 8467 WRITE(ICOUT,999) 8468 999 FORMAT(1X) 8469 CALL DPWRST('XXX','BUG ') 8470 WRITE(ICOUT,51) 8471 51 FORMAT('***** AT THE BEGINNING OF DPRSS--') 8472 CALL DPWRST('XXX','BUG ') 8473 WRITE(ICOUT,52)ICHAR2 8474 52 FORMAT('ICHAR2 = ',A4) 8475 CALL DPWRST('XXX','BUG ') 8476 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 8477 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 8478 CALL DPWRST('XXX','BUG ') 8479 90 CONTINUE 8480C 8481C ************************************************** 8482C ************************************************** 8483C ** STEP 1-- ** 8484C ** SEARCH FOR THE INPUT CHARACTER(S). ** 8485C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** 8486C ************************************************** 8487C ************************************************** 8488C 8489 CALL DPCHSY(ICHAR2,ICHARN,IBUGD2,IFOUND) 8490 IF(IFOUND.EQ.'NO')GOTO9000 8491 GOTO1000 8492C 8493C ************************************** 8494C ************************************** 8495C ** STEP 2-- ** 8496C ** EXTRACT THE COORDINATES ** 8497C ** FOR THIS PARTICULAR CHARACTER. ** 8498C ************************************** 8499C ************************************** 8500C 8501 1000 CONTINUE 8502 ISTART=ISTARD(ICHARN) 8503 NC=NUMCOO(ICHARN) 8504 ISTOP=ISTART+NC-1 8505 J=0 8506 DO1100I=ISTART,ISTOP 8507 J=J+1 8508 IOP(J)=IOPERA(I) 8509 X(J)=IX(I) 8510 Y(J)=IY(I) 8511 1100 CONTINUE 8512 NUMCO=J 8513 IXMINS=IXMIND(ICHARN) 8514 IXMAXS=IXMAXD(ICHARN) 8515 IXDELS=IXDELD(ICHARN) 8516C 8517 GOTO9000 8518C 8519C ***************** 8520C ***************** 8521C ** STEP 90-- ** 8522C ** EXIT ** 8523C ***************** 8524C ***************** 8525C 8526 9000 CONTINUE 8527 IF(IBUGD2.EQ.'OFF')GOTO9090 8528 WRITE(ICOUT,999) 8529 CALL DPWRST('XXX','BUG ') 8530 WRITE(ICOUT,9011) 8531 9011 FORMAT('***** AT THE END OF DPRSS--') 8532 CALL DPWRST('XXX','BUG ') 8533 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 8534 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 8535 CALL DPWRST('XXX','BUG ') 8536 WRITE(ICOUT,9013)ICHAR2,ICHARN 8537 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) 8538 CALL DPWRST('XXX','BUG ') 8539 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 8540 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 8541 CALL DPWRST('XXX','BUG ') 8542 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 8543 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 8544 DO9015I=1,NUMCO 8545 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 8546 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 8547 CALL DPWRST('XXX','BUG ') 8548 9015 CONTINUE 8549 9019 CONTINUE 8550 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 8551 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 8552 CALL DPWRST('XXX','BUG ') 8553 9090 CONTINUE 8554C 8555 RETURN 8556 END 8557 SUBROUTINE DPRSSL(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 8558 1IBUGD2,IFOUND,IERROR) 8559C 8560C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 8561C FOR ROMAN SIMPLEX SCRIPT LOWER CASE. 8562C WRITTEN BY--JAMES J. FILLIBEN 8563C STATISTICAL ENGINEERING DIVISION 8564C INFORMATION TECHNOLOGY LABORATORY 8565C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 8566C GAITHERSBURG, MD 20899 8567C PHONE--301-975-2855 8568C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 8569C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 8570C LANGUAGE--ANSI FORTRAN (1977) 8571C VERSION NUMBER--87/4 8572C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 8573C UPDATED --MAY 1982. 8574C UPDATED --MARCH 1987. 8575C 8576C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 8577C 8578 CHARACTER*4 ICHAR2 8579 CHARACTER*4 IOP 8580 CHARACTER*4 IBUGD2 8581 CHARACTER*4 IFOUND 8582 CHARACTER*4 IERROR 8583C 8584C--------------------------------------------------------------------- 8585C 8586 DIMENSION IOP(*) 8587 DIMENSION X(*) 8588 DIMENSION Y(*) 8589C 8590C--------------------------------------------------------------------- 8591C 8592 INCLUDE 'DPCOP2.INC' 8593C 8594C-----START POINT----------------------------------------------------- 8595C 8596 IFOUND='NO' 8597 IERROR='NO' 8598C 8599 NUMCO=1 8600 ISTART=1 8601 ISTOP=1 8602 NC=1 8603C 8604C ****************************************** 8605C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 8606C ** HERSHEY CHARACTER SET CASE ** 8607C ****************************************** 8608C 8609C 8610 IF(IBUGD2.EQ.'OFF')GOTO90 8611 WRITE(ICOUT,999) 8612 999 FORMAT(1X) 8613 CALL DPWRST('XXX','BUG ') 8614 WRITE(ICOUT,51) 8615 51 FORMAT('***** AT THE BEGINNING OF DPRSSL--') 8616 CALL DPWRST('XXX','BUG ') 8617 WRITE(ICOUT,52)ICHAR2 8618 52 FORMAT('ICHAR2 = ',A4) 8619 CALL DPWRST('XXX','BUG ') 8620 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 8621 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 8622 CALL DPWRST('XXX','BUG ') 8623 90 CONTINUE 8624C 8625C ************************************************** 8626C ** STEP 1-- ** 8627C ** SEARCH FOR THE INPUT CHARACTER(S). ** 8628C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** 8629C ************************************************** 8630C 8631 CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND) 8632 IF(IFOUND.EQ.'NO')GOTO9000 8633C 8634 IF(ICHARN.LE.14)GOTO1010 8635 GOTO1019 8636 1010 CONTINUE 8637 CALL DRSSL1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 8638 1IBUGD2,IFOUND,IERROR) 8639 GOTO9000 8640 1019 CONTINUE 8641C 8642 IF(ICHARN.GE.15)GOTO1020 8643 GOTO1029 8644 1020 CONTINUE 8645 CALL DRSSL2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 8646 1IBUGD2,IFOUND,IERROR) 8647 GOTO9000 8648 1029 CONTINUE 8649C 8650 IFOUND='NO' 8651 GOTO9000 8652C 8653C ***************** 8654C ** STEP 90-- ** 8655C ** EXIT ** 8656C ***************** 8657C 8658 9000 CONTINUE 8659 IF(IBUGD2.EQ.'OFF')GOTO9090 8660 WRITE(ICOUT,999) 8661 CALL DPWRST('XXX','BUG ') 8662 WRITE(ICOUT,9011) 8663 9011 FORMAT('***** AT THE END OF DPRSSL--') 8664 CALL DPWRST('XXX','BUG ') 8665 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 8666 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 8667 CALL DPWRST('XXX','BUG ') 8668 WRITE(ICOUT,9013)ICHAR2,ICHARN 8669 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) 8670 CALL DPWRST('XXX','BUG ') 8671 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 8672 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 8673 CALL DPWRST('XXX','BUG ') 8674 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 8675 DO9015I=1,NUMCO 8676 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 8677 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 8678 CALL DPWRST('XXX','BUG ') 8679 9015 CONTINUE 8680 9019 CONTINUE 8681 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 8682 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 8683 CALL DPWRST('XXX','BUG ') 8684 9090 CONTINUE 8685C 8686 RETURN 8687 END 8688 SUBROUTINE DPRSSU(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 8689 1IBUGD2,IFOUND,IERROR) 8690C 8691C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 8692C FOR ROMAN SIMPLEX SCRIPT UPPER CASE. 8693C WRITTEN BY--JAMES J. FILLIBEN 8694C STATISTICAL ENGINEERING DIVISION 8695C INFORMATION TECHNOLOGY LABORATORY 8696C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 8697C GAITHERSBURG, MD 20899 8698C PHONE--301-975-2855 8699C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 8700C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 8701C LANGUAGE--ANSI FORTRAN (1977) 8702C VERSION NUMBER--87/4 8703C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 8704C UPDATED --MAY 1982. 8705C UPDATED --MARCH 1987. 8706C 8707C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 8708C 8709 CHARACTER*4 ICHAR2 8710 CHARACTER*4 IOP 8711 CHARACTER*4 IBUGD2 8712 CHARACTER*4 IFOUND 8713 CHARACTER*4 IERROR 8714C 8715C--------------------------------------------------------------------- 8716C 8717 DIMENSION IOP(*) 8718 DIMENSION X(*) 8719 DIMENSION Y(*) 8720C 8721C--------------------------------------------------------------------- 8722C 8723 INCLUDE 'DPCOP2.INC' 8724C 8725C-----START POINT----------------------------------------------------- 8726C 8727 IFOUND='NO' 8728 IERROR='NO' 8729C 8730 NUMCO=1 8731 ISTART=1 8732 ISTOP=1 8733 NC=1 8734C 8735C ****************************************** 8736C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 8737C ** HERSHEY CHARACTER SET CASE ** 8738C ****************************************** 8739C 8740C 8741 IF(IBUGD2.EQ.'OFF')GOTO90 8742 WRITE(ICOUT,999) 8743 999 FORMAT(1X) 8744 CALL DPWRST('XXX','BUG ') 8745 WRITE(ICOUT,51) 8746 51 FORMAT('***** AT THE BEGINNING OF DPRSSU--') 8747 CALL DPWRST('XXX','BUG ') 8748 WRITE(ICOUT,52)ICHAR2 8749 52 FORMAT('ICHAR2 = ',A4) 8750 CALL DPWRST('XXX','BUG ') 8751 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 8752 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 8753 CALL DPWRST('XXX','BUG ') 8754 90 CONTINUE 8755C 8756C ************************************************** 8757C ** STEP 1-- ** 8758C ** SEARCH FOR THE INPUT CHARACTER(S). ** 8759C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** 8760C ************************************************** 8761C 8762 CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND) 8763 IF(IFOUND.EQ.'NO')GOTO9000 8764C 8765 IF(ICHARN.LE.10)GOTO1010 8766 GOTO1019 8767 1010 CONTINUE 8768 CALL DRSSU1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 8769 1IBUGD2,IFOUND,IERROR) 8770 GOTO9000 8771 1019 CONTINUE 8772C 8773 IF(11.LE.ICHARN.AND.ICHARN.LE.19)GOTO1020 8774 GOTO1029 8775 1020 CONTINUE 8776 CALL DRSSU2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 8777 1IBUGD2,IFOUND,IERROR) 8778 GOTO9000 8779 1029 CONTINUE 8780C 8781 IF(ICHARN.GE.20)GOTO1030 8782 GOTO1039 8783 1030 CONTINUE 8784 CALL DRSSU3(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 8785 1IBUGD2,IFOUND,IERROR) 8786 GOTO9000 8787 1039 CONTINUE 8788C 8789 IFOUND='NO' 8790 GOTO9000 8791C 8792C ***************** 8793C ** STEP 90-- ** 8794C ** EXIT ** 8795C ***************** 8796C 8797 9000 CONTINUE 8798 IF(IBUGD2.EQ.'OFF')GOTO9090 8799 WRITE(ICOUT,999) 8800 CALL DPWRST('XXX','BUG ') 8801 WRITE(ICOUT,9011) 8802 9011 FORMAT('***** AT THE END OF DPRSSU--') 8803 CALL DPWRST('XXX','BUG ') 8804 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 8805 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 8806 CALL DPWRST('XXX','BUG ') 8807 WRITE(ICOUT,9013)ICHAR2,ICHARN 8808 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) 8809 CALL DPWRST('XXX','BUG ') 8810 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 8811 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 8812 CALL DPWRST('XXX','BUG ') 8813 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 8814 DO9015I=1,NUMCO 8815 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 8816 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 8817 CALL DPWRST('XXX','BUG ') 8818 9015 CONTINUE 8819 9019 CONTINUE 8820 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 8821 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 8822 CALL DPWRST('XXX','BUG ') 8823 9090 CONTINUE 8824C 8825 RETURN 8826 END 8827 SUBROUTINE DPRSU(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 8828 1IBUGD2,IFOUND,IERROR) 8829C 8830C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 8831C FOR ROMAN SIMPLEX UPPER CASE. 8832C WRITTEN BY--JAMES J. FILLIBEN 8833C STATISTICAL ENGINEERING DIVISION 8834C INFORMATION TECHNOLOGY LABORATORY 8835C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 8836C GAITHERSBURG, MD 20899 8837C PHONE--301-975-2855 8838C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 8839C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 8840C LANGUAGE--ANSI FORTRAN (1977) 8841C VERSION NUMBER--87/4 8842C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 8843C UPDATED --MAY 1982. 8844C UPDATED --MARCH 1987. 8845C 8846C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 8847C 8848 CHARACTER*4 ICHAR2 8849 CHARACTER*4 IOP 8850 CHARACTER*4 IBUGD2 8851 CHARACTER*4 IFOUND 8852 CHARACTER*4 IERROR 8853C 8854 CHARACTER*4 IOPERA 8855C 8856C--------------------------------------------------------------------- 8857C 8858 DIMENSION IOP(*) 8859 DIMENSION X(*) 8860 DIMENSION Y(*) 8861C 8862 DIMENSION IOPERA(300) 8863 DIMENSION IX(300) 8864 DIMENSION IY(300) 8865C 8866 DIMENSION IXMIND(30) 8867 DIMENSION IXMAXD(30) 8868 DIMENSION IXDELD(30) 8869 DIMENSION ISTARD(30) 8870 DIMENSION NUMCOO(30) 8871C 8872C--------------------------------------------------------------------- 8873C 8874 INCLUDE 'DPCOP2.INC' 8875C 8876C-----DATA STATEMENTS------------------------------------------------- 8877C 8878C DEFINE CHARACTER 501--UPPER CASE A 8879C 8880 DATA IOPERA( 1),IX( 1),IY( 1)/'MOVE', 0, 12/ 8881 DATA IOPERA( 2),IX( 2),IY( 2)/'DRAW', -8, -9/ 8882 DATA IOPERA( 3),IX( 3),IY( 3)/'MOVE', 0, 12/ 8883 DATA IOPERA( 4),IX( 4),IY( 4)/'DRAW', 8, -9/ 8884 DATA IOPERA( 5),IX( 5),IY( 5)/'MOVE', -5, -2/ 8885 DATA IOPERA( 6),IX( 6),IY( 6)/'DRAW', 5, -2/ 8886C 8887 DATA IXMIND( 1)/ -9/ 8888 DATA IXMAXD( 1)/ 9/ 8889 DATA IXDELD( 1)/ 18/ 8890 DATA ISTARD( 1)/ 1/ 8891 DATA NUMCOO( 1)/ 6/ 8892C 8893C DEFINE CHARACTER 502--UPPER CASE B 8894C 8895 DATA IOPERA( 7),IX( 7),IY( 7)/'MOVE', -7, 12/ 8896 DATA IOPERA( 8),IX( 8),IY( 8)/'DRAW', -7, -9/ 8897 DATA IOPERA( 9),IX( 9),IY( 9)/'MOVE', -7, 12/ 8898 DATA IOPERA( 10),IX( 10),IY( 10)/'DRAW', 2, 12/ 8899 DATA IOPERA( 11),IX( 11),IY( 11)/'DRAW', 5, 11/ 8900 DATA IOPERA( 12),IX( 12),IY( 12)/'DRAW', 6, 10/ 8901 DATA IOPERA( 13),IX( 13),IY( 13)/'DRAW', 7, 8/ 8902 DATA IOPERA( 14),IX( 14),IY( 14)/'DRAW', 7, 6/ 8903 DATA IOPERA( 15),IX( 15),IY( 15)/'DRAW', 6, 4/ 8904 DATA IOPERA( 16),IX( 16),IY( 16)/'DRAW', 5, 3/ 8905 DATA IOPERA( 17),IX( 17),IY( 17)/'DRAW', 2, 2/ 8906 DATA IOPERA( 18),IX( 18),IY( 18)/'MOVE', -7, 2/ 8907 DATA IOPERA( 19),IX( 19),IY( 19)/'DRAW', 2, 2/ 8908 DATA IOPERA( 20),IX( 20),IY( 20)/'DRAW', 5, 1/ 8909 DATA IOPERA( 21),IX( 21),IY( 21)/'DRAW', 6, 0/ 8910 DATA IOPERA( 22),IX( 22),IY( 22)/'DRAW', 7, -2/ 8911 DATA IOPERA( 23),IX( 23),IY( 23)/'DRAW', 7, -5/ 8912 DATA IOPERA( 24),IX( 24),IY( 24)/'DRAW', 6, -7/ 8913 DATA IOPERA( 25),IX( 25),IY( 25)/'DRAW', 5, -8/ 8914 DATA IOPERA( 26),IX( 26),IY( 26)/'DRAW', 2, -9/ 8915 DATA IOPERA( 27),IX( 27),IY( 27)/'DRAW', -7, -9/ 8916C 8917 DATA IXMIND( 2)/ -11/ 8918 DATA IXMAXD( 2)/ 10/ 8919 DATA IXDELD( 2)/ 21/ 8920 DATA ISTARD( 2)/ 7/ 8921 DATA NUMCOO( 2)/ 21/ 8922C 8923C DEFINE CHARACTER 503--UPPER CASE C 8924C 8925 DATA IOPERA( 28),IX( 28),IY( 28)/'MOVE', 8, 7/ 8926 DATA IOPERA( 29),IX( 29),IY( 29)/'DRAW', 7, 9/ 8927 DATA IOPERA( 30),IX( 30),IY( 30)/'DRAW', 5, 11/ 8928 DATA IOPERA( 31),IX( 31),IY( 31)/'DRAW', 3, 12/ 8929 DATA IOPERA( 32),IX( 32),IY( 32)/'DRAW', -1, 12/ 8930 DATA IOPERA( 33),IX( 33),IY( 33)/'DRAW', -3, 11/ 8931 DATA IOPERA( 34),IX( 34),IY( 34)/'DRAW', -5, 9/ 8932 DATA IOPERA( 35),IX( 35),IY( 35)/'DRAW', -6, 7/ 8933 DATA IOPERA( 36),IX( 36),IY( 36)/'DRAW', -7, 4/ 8934 DATA IOPERA( 37),IX( 37),IY( 37)/'DRAW', -7, -1/ 8935 DATA IOPERA( 38),IX( 38),IY( 38)/'DRAW', -6, -4/ 8936 DATA IOPERA( 39),IX( 39),IY( 39)/'DRAW', -5, -6/ 8937 DATA IOPERA( 40),IX( 40),IY( 40)/'DRAW', -3, -8/ 8938 DATA IOPERA( 41),IX( 41),IY( 41)/'DRAW', -1, -9/ 8939 DATA IOPERA( 42),IX( 42),IY( 42)/'DRAW', 3, -9/ 8940 DATA IOPERA( 43),IX( 43),IY( 43)/'DRAW', 5, -8/ 8941 DATA IOPERA( 44),IX( 44),IY( 44)/'DRAW', 7, -6/ 8942 DATA IOPERA( 45),IX( 45),IY( 45)/'DRAW', 8, -4/ 8943C 8944 DATA IXMIND( 3)/ -10/ 8945 DATA IXMAXD( 3)/ 11/ 8946 DATA IXDELD( 3)/ 21/ 8947 DATA ISTARD( 3)/ 28/ 8948 DATA NUMCOO( 3)/ 18/ 8949C 8950C DEFINE CHARACTER 504--UPPER CASE D 8951C 8952 DATA IOPERA( 46),IX( 46),IY( 46)/'MOVE', -7, 12/ 8953 DATA IOPERA( 47),IX( 47),IY( 47)/'DRAW', -7, -9/ 8954 DATA IOPERA( 48),IX( 48),IY( 48)/'MOVE', -7, 12/ 8955 DATA IOPERA( 49),IX( 49),IY( 49)/'DRAW', 0, 12/ 8956 DATA IOPERA( 50),IX( 50),IY( 50)/'DRAW', 3, 11/ 8957 DATA IOPERA( 51),IX( 51),IY( 51)/'DRAW', 5, 9/ 8958 DATA IOPERA( 52),IX( 52),IY( 52)/'DRAW', 6, 7/ 8959 DATA IOPERA( 53),IX( 53),IY( 53)/'DRAW', 7, 4/ 8960 DATA IOPERA( 54),IX( 54),IY( 54)/'DRAW', 7, -1/ 8961 DATA IOPERA( 55),IX( 55),IY( 55)/'DRAW', 6, -4/ 8962 DATA IOPERA( 56),IX( 56),IY( 56)/'DRAW', 5, -6/ 8963 DATA IOPERA( 57),IX( 57),IY( 57)/'DRAW', 3, -8/ 8964 DATA IOPERA( 58),IX( 58),IY( 58)/'DRAW', 0, -9/ 8965 DATA IOPERA( 59),IX( 59),IY( 59)/'DRAW', -7, -9/ 8966C 8967 DATA IXMIND( 4)/ -11/ 8968 DATA IXMAXD( 4)/ 10/ 8969 DATA IXDELD( 4)/ 21/ 8970 DATA ISTARD( 4)/ 46/ 8971 DATA NUMCOO( 4)/ 14/ 8972C 8973C DEFINE CHARACTER 505--UPPER CASE E 8974C 8975 DATA IOPERA( 60),IX( 60),IY( 60)/'MOVE', -6, 12/ 8976 DATA IOPERA( 61),IX( 61),IY( 61)/'DRAW', -6, -9/ 8977 DATA IOPERA( 62),IX( 62),IY( 62)/'MOVE', -6, 12/ 8978 DATA IOPERA( 63),IX( 63),IY( 63)/'DRAW', 7, 12/ 8979 DATA IOPERA( 64),IX( 64),IY( 64)/'MOVE', -6, 2/ 8980 DATA IOPERA( 65),IX( 65),IY( 65)/'DRAW', 2, 2/ 8981 DATA IOPERA( 66),IX( 66),IY( 66)/'MOVE', -6, -9/ 8982 DATA IOPERA( 67),IX( 67),IY( 67)/'DRAW', 7, -9/ 8983C 8984 DATA IXMIND( 5)/ -10/ 8985 DATA IXMAXD( 5)/ 9/ 8986 DATA IXDELD( 5)/ 19/ 8987 DATA ISTARD( 5)/ 60/ 8988 DATA NUMCOO( 5)/ 8/ 8989C 8990C DEFINE CHARACTER 506--UPPER CASE F 8991C 8992 DATA IOPERA( 68),IX( 68),IY( 68)/'MOVE', -6, 12/ 8993 DATA IOPERA( 69),IX( 69),IY( 69)/'DRAW', -6, -9/ 8994 DATA IOPERA( 70),IX( 70),IY( 70)/'MOVE', -6, 12/ 8995 DATA IOPERA( 71),IX( 71),IY( 71)/'DRAW', 7, 12/ 8996 DATA IOPERA( 72),IX( 72),IY( 72)/'MOVE', -6, 2/ 8997 DATA IOPERA( 73),IX( 73),IY( 73)/'DRAW', 2, 2/ 8998C 8999 DATA IXMIND( 6)/ -10/ 9000 DATA IXMAXD( 6)/ 8/ 9001 DATA IXDELD( 6)/ 18/ 9002 DATA ISTARD( 6)/ 68/ 9003 DATA NUMCOO( 6)/ 6/ 9004C 9005C DEFINE CHARACTER 507--UPPER CASE G 9006C 9007 DATA IOPERA( 74),IX( 74),IY( 74)/'MOVE', 8, 7/ 9008 DATA IOPERA( 75),IX( 75),IY( 75)/'DRAW', 7, 9/ 9009 DATA IOPERA( 76),IX( 76),IY( 76)/'DRAW', 5, 11/ 9010 DATA IOPERA( 77),IX( 77),IY( 77)/'DRAW', 3, 12/ 9011 DATA IOPERA( 78),IX( 78),IY( 78)/'DRAW', -1, 12/ 9012 DATA IOPERA( 79),IX( 79),IY( 79)/'DRAW', -3, 11/ 9013 DATA IOPERA( 80),IX( 80),IY( 80)/'DRAW', -5, 9/ 9014 DATA IOPERA( 81),IX( 81),IY( 81)/'DRAW', -6, 7/ 9015 DATA IOPERA( 82),IX( 82),IY( 82)/'DRAW', -7, 4/ 9016 DATA IOPERA( 83),IX( 83),IY( 83)/'DRAW', -7, -1/ 9017 DATA IOPERA( 84),IX( 84),IY( 84)/'DRAW', -6, -4/ 9018 DATA IOPERA( 85),IX( 85),IY( 85)/'DRAW', -5, -6/ 9019 DATA IOPERA( 86),IX( 86),IY( 86)/'DRAW', -3, -8/ 9020 DATA IOPERA( 87),IX( 87),IY( 87)/'DRAW', -1, -9/ 9021 DATA IOPERA( 88),IX( 88),IY( 88)/'DRAW', 3, -9/ 9022 DATA IOPERA( 89),IX( 89),IY( 89)/'DRAW', 5, -8/ 9023 DATA IOPERA( 90),IX( 90),IY( 90)/'DRAW', 7, -6/ 9024 DATA IOPERA( 91),IX( 91),IY( 91)/'DRAW', 8, -4/ 9025 DATA IOPERA( 92),IX( 92),IY( 92)/'DRAW', 8, -1/ 9026 DATA IOPERA( 93),IX( 93),IY( 93)/'MOVE', 3, -1/ 9027 DATA IOPERA( 94),IX( 94),IY( 94)/'DRAW', 8, -1/ 9028C 9029 DATA IXMIND( 7)/ -10/ 9030 DATA IXMAXD( 7)/ 11/ 9031 DATA IXDELD( 7)/ 21/ 9032 DATA ISTARD( 7)/ 74/ 9033 DATA NUMCOO( 7)/ 21/ 9034C 9035C DEFINE CHARACTER 508--UPPER CASE H 9036C 9037 DATA IOPERA( 95),IX( 95),IY( 95)/'MOVE', -7, 12/ 9038 DATA IOPERA( 96),IX( 96),IY( 96)/'DRAW', -7, -9/ 9039 DATA IOPERA( 97),IX( 97),IY( 97)/'MOVE', 7, 12/ 9040 DATA IOPERA( 98),IX( 98),IY( 98)/'DRAW', 7, -9/ 9041 DATA IOPERA( 99),IX( 99),IY( 99)/'MOVE', -7, 2/ 9042 DATA IOPERA( 100),IX( 100),IY( 100)/'DRAW', 7, 2/ 9043C 9044 DATA IXMIND( 8)/ -11/ 9045 DATA IXMAXD( 8)/ 11/ 9046 DATA IXDELD( 8)/ 22/ 9047 DATA ISTARD( 8)/ 95/ 9048 DATA NUMCOO( 8)/ 6/ 9049C 9050C DEFINE CHARACTER 509--UPPER CASE I 9051C 9052 DATA IOPERA( 101),IX( 101),IY( 101)/'MOVE', 0, 12/ 9053 DATA IOPERA( 102),IX( 102),IY( 102)/'DRAW', 0, -9/ 9054C 9055 DATA IXMIND( 9)/ -4/ 9056 DATA IXMAXD( 9)/ 4/ 9057 DATA IXDELD( 9)/ 8/ 9058 DATA ISTARD( 9)/ 101/ 9059 DATA NUMCOO( 9)/ 2/ 9060C 9061C DEFINE CHARACTER 510--UPPER CASE J 9062C 9063 DATA IOPERA( 103),IX( 103),IY( 103)/'MOVE', 4, 12/ 9064 DATA IOPERA( 104),IX( 104),IY( 104)/'DRAW', 4, -4/ 9065 DATA IOPERA( 105),IX( 105),IY( 105)/'DRAW', 3, -7/ 9066 DATA IOPERA( 106),IX( 106),IY( 106)/'DRAW', 2, -8/ 9067 DATA IOPERA( 107),IX( 107),IY( 107)/'DRAW', 0, -9/ 9068 DATA IOPERA( 108),IX( 108),IY( 108)/'DRAW', -2, -9/ 9069 DATA IOPERA( 109),IX( 109),IY( 109)/'DRAW', -4, -8/ 9070 DATA IOPERA( 110),IX( 110),IY( 110)/'DRAW', -5, -7/ 9071 DATA IOPERA( 111),IX( 111),IY( 111)/'DRAW', -6, -4/ 9072 DATA IOPERA( 112),IX( 112),IY( 112)/'DRAW', -6, -2/ 9073C 9074 DATA IXMIND( 10)/ -8/ 9075 DATA IXMAXD( 10)/ 8/ 9076 DATA IXDELD( 10)/ 16/ 9077 DATA ISTARD( 10)/ 103/ 9078 DATA NUMCOO( 10)/ 10/ 9079C 9080C DEFINE CHARACTER 511--UPPER CASE K 9081C 9082 DATA IOPERA( 113),IX( 113),IY( 113)/'MOVE', -7, 12/ 9083 DATA IOPERA( 114),IX( 114),IY( 114)/'DRAW', -7, -9/ 9084 DATA IOPERA( 115),IX( 115),IY( 115)/'MOVE', 7, 12/ 9085 DATA IOPERA( 116),IX( 116),IY( 116)/'DRAW', -7, -2/ 9086 DATA IOPERA( 117),IX( 117),IY( 117)/'MOVE', -2, 3/ 9087 DATA IOPERA( 118),IX( 118),IY( 118)/'DRAW', 7, -9/ 9088C 9089 DATA IXMIND( 11)/ -11/ 9090 DATA IXMAXD( 11)/ 10/ 9091 DATA IXDELD( 11)/ 21/ 9092 DATA ISTARD( 11)/ 113/ 9093 DATA NUMCOO( 11)/ 6/ 9094C 9095C DEFINE CHARACTER 512--UPPER CASE L 9096C 9097 DATA IOPERA( 119),IX( 119),IY( 119)/'MOVE', -6, 12/ 9098 DATA IOPERA( 120),IX( 120),IY( 120)/'DRAW', -6, -9/ 9099 DATA IOPERA( 121),IX( 121),IY( 121)/'MOVE', -6, -9/ 9100 DATA IOPERA( 122),IX( 122),IY( 122)/'DRAW', 6, -9/ 9101C 9102 DATA IXMIND( 12)/ -10/ 9103 DATA IXMAXD( 12)/ 7/ 9104 DATA IXDELD( 12)/ 17/ 9105 DATA ISTARD( 12)/ 119/ 9106 DATA NUMCOO( 12)/ 4/ 9107C 9108C DEFINE CHARACTER 513--UPPER CASE M 9109C 9110 DATA IOPERA( 123),IX( 123),IY( 123)/'MOVE', -8, 12/ 9111 DATA IOPERA( 124),IX( 124),IY( 124)/'DRAW', -8, -9/ 9112 DATA IOPERA( 125),IX( 125),IY( 125)/'MOVE', -8, 12/ 9113 DATA IOPERA( 126),IX( 126),IY( 126)/'DRAW', 0, -9/ 9114 DATA IOPERA( 127),IX( 127),IY( 127)/'MOVE', 8, 12/ 9115 DATA IOPERA( 128),IX( 128),IY( 128)/'DRAW', 0, -9/ 9116 DATA IOPERA( 129),IX( 129),IY( 129)/'MOVE', 8, 12/ 9117 DATA IOPERA( 130),IX( 130),IY( 130)/'DRAW', 8, -9/ 9118C 9119 DATA IXMIND( 13)/ -12/ 9120 DATA IXMAXD( 13)/ 12/ 9121 DATA IXDELD( 13)/ 24/ 9122 DATA ISTARD( 13)/ 123/ 9123 DATA NUMCOO( 13)/ 8/ 9124C 9125C DEFINE CHARACTER 514--UPPER CASE N 9126C 9127 DATA IOPERA( 131),IX( 131),IY( 131)/'MOVE', -7, 12/ 9128 DATA IOPERA( 132),IX( 132),IY( 132)/'DRAW', -7, -9/ 9129 DATA IOPERA( 133),IX( 133),IY( 133)/'MOVE', -7, 12/ 9130 DATA IOPERA( 134),IX( 134),IY( 134)/'DRAW', 7, -9/ 9131 DATA IOPERA( 135),IX( 135),IY( 135)/'MOVE', 7, 12/ 9132 DATA IOPERA( 136),IX( 136),IY( 136)/'DRAW', 7, -9/ 9133C 9134 DATA IXMIND( 14)/ -11/ 9135 DATA IXMAXD( 14)/ 11/ 9136 DATA IXDELD( 14)/ 22/ 9137 DATA ISTARD( 14)/ 131/ 9138 DATA NUMCOO( 14)/ 6/ 9139C 9140C DEFINE CHARACTER 515--UPPER CASE O 9141C 9142 DATA IOPERA( 137),IX( 137),IY( 137)/'MOVE', -2, 12/ 9143 DATA IOPERA( 138),IX( 138),IY( 138)/'DRAW', -4, 11/ 9144 DATA IOPERA( 139),IX( 139),IY( 139)/'DRAW', -6, 9/ 9145 DATA IOPERA( 140),IX( 140),IY( 140)/'DRAW', -7, 7/ 9146 DATA IOPERA( 141),IX( 141),IY( 141)/'DRAW', -8, 4/ 9147 DATA IOPERA( 142),IX( 142),IY( 142)/'DRAW', -8, -1/ 9148 DATA IOPERA( 143),IX( 143),IY( 143)/'DRAW', -7, -4/ 9149 DATA IOPERA( 144),IX( 144),IY( 144)/'DRAW', -6, -6/ 9150 DATA IOPERA( 145),IX( 145),IY( 145)/'DRAW', -4, -8/ 9151 DATA IOPERA( 146),IX( 146),IY( 146)/'DRAW', -2, -9/ 9152 DATA IOPERA( 147),IX( 147),IY( 147)/'DRAW', 2, -9/ 9153 DATA IOPERA( 148),IX( 148),IY( 148)/'DRAW', 4, -8/ 9154 DATA IOPERA( 149),IX( 149),IY( 149)/'DRAW', 6, -6/ 9155 DATA IOPERA( 150),IX( 150),IY( 150)/'DRAW', 7, -4/ 9156 DATA IOPERA( 151),IX( 151),IY( 151)/'DRAW', 8, -1/ 9157 DATA IOPERA( 152),IX( 152),IY( 152)/'DRAW', 8, 4/ 9158 DATA IOPERA( 153),IX( 153),IY( 153)/'DRAW', 7, 7/ 9159 DATA IOPERA( 154),IX( 154),IY( 154)/'DRAW', 6, 9/ 9160 DATA IOPERA( 155),IX( 155),IY( 155)/'DRAW', 4, 11/ 9161 DATA IOPERA( 156),IX( 156),IY( 156)/'DRAW', 2, 12/ 9162 DATA IOPERA( 157),IX( 157),IY( 157)/'DRAW', -2, 12/ 9163C 9164 DATA IXMIND( 15)/ -11/ 9165 DATA IXMAXD( 15)/ 11/ 9166 DATA IXDELD( 15)/ 22/ 9167 DATA ISTARD( 15)/ 137/ 9168 DATA NUMCOO( 15)/ 21/ 9169C 9170C DEFINE CHARACTER 516--UPPER CASE P 9171C 9172 DATA IOPERA( 158),IX( 158),IY( 158)/'MOVE', -7, 12/ 9173 DATA IOPERA( 159),IX( 159),IY( 159)/'DRAW', -7, -9/ 9174 DATA IOPERA( 160),IX( 160),IY( 160)/'MOVE', -7, 12/ 9175 DATA IOPERA( 161),IX( 161),IY( 161)/'DRAW', 2, 12/ 9176 DATA IOPERA( 162),IX( 162),IY( 162)/'DRAW', 5, 11/ 9177 DATA IOPERA( 163),IX( 163),IY( 163)/'DRAW', 6, 10/ 9178 DATA IOPERA( 164),IX( 164),IY( 164)/'DRAW', 7, 8/ 9179 DATA IOPERA( 165),IX( 165),IY( 165)/'DRAW', 7, 5/ 9180 DATA IOPERA( 166),IX( 166),IY( 166)/'DRAW', 6, 3/ 9181 DATA IOPERA( 167),IX( 167),IY( 167)/'DRAW', 5, 2/ 9182 DATA IOPERA( 168),IX( 168),IY( 168)/'DRAW', 2, 1/ 9183 DATA IOPERA( 169),IX( 169),IY( 169)/'DRAW', -7, 1/ 9184C 9185 DATA IXMIND( 16)/ -11/ 9186 DATA IXMAXD( 16)/ 10/ 9187 DATA IXDELD( 16)/ 21/ 9188 DATA ISTARD( 16)/ 158/ 9189 DATA NUMCOO( 16)/ 12/ 9190C 9191C DEFINE CHARACTER 517--UPPER CASE Q 9192C 9193 DATA IOPERA( 170),IX( 170),IY( 170)/'MOVE', -2, 12/ 9194 DATA IOPERA( 171),IX( 171),IY( 171)/'DRAW', -4, 11/ 9195 DATA IOPERA( 172),IX( 172),IY( 172)/'DRAW', -6, 9/ 9196 DATA IOPERA( 173),IX( 173),IY( 173)/'DRAW', -7, 7/ 9197 DATA IOPERA( 174),IX( 174),IY( 174)/'DRAW', -8, 4/ 9198 DATA IOPERA( 175),IX( 175),IY( 175)/'DRAW', -8, -1/ 9199 DATA IOPERA( 176),IX( 176),IY( 176)/'DRAW', -7, -4/ 9200 DATA IOPERA( 177),IX( 177),IY( 177)/'DRAW', -6, -6/ 9201 DATA IOPERA( 178),IX( 178),IY( 178)/'DRAW', -4, -8/ 9202 DATA IOPERA( 179),IX( 179),IY( 179)/'DRAW', -2, -9/ 9203 DATA IOPERA( 180),IX( 180),IY( 180)/'DRAW', 2, -9/ 9204 DATA IOPERA( 181),IX( 181),IY( 181)/'DRAW', 4, -8/ 9205 DATA IOPERA( 182),IX( 182),IY( 182)/'DRAW', 6, -6/ 9206 DATA IOPERA( 183),IX( 183),IY( 183)/'DRAW', 7, -4/ 9207 DATA IOPERA( 184),IX( 184),IY( 184)/'DRAW', 8, -1/ 9208 DATA IOPERA( 185),IX( 185),IY( 185)/'DRAW', 8, 4/ 9209 DATA IOPERA( 186),IX( 186),IY( 186)/'DRAW', 7, 7/ 9210 DATA IOPERA( 187),IX( 187),IY( 187)/'DRAW', 6, 9/ 9211 DATA IOPERA( 188),IX( 188),IY( 188)/'DRAW', 4, 11/ 9212 DATA IOPERA( 189),IX( 189),IY( 189)/'DRAW', 2, 12/ 9213 DATA IOPERA( 190),IX( 190),IY( 190)/'DRAW', -2, 12/ 9214 DATA IOPERA( 191),IX( 191),IY( 191)/'MOVE', 1, -5/ 9215 DATA IOPERA( 192),IX( 192),IY( 192)/'DRAW', 7, -11/ 9216C 9217 DATA IXMIND( 17)/ -11/ 9218 DATA IXMAXD( 17)/ 11/ 9219 DATA IXDELD( 17)/ 22/ 9220 DATA ISTARD( 17)/ 170/ 9221 DATA NUMCOO( 17)/ 23/ 9222C 9223C DEFINE CHARACTER 518--UPPER CASE R 9224C 9225 DATA IOPERA( 193),IX( 193),IY( 193)/'MOVE', -7, 12/ 9226 DATA IOPERA( 194),IX( 194),IY( 194)/'DRAW', -7, -9/ 9227 DATA IOPERA( 195),IX( 195),IY( 195)/'MOVE', -7, 12/ 9228 DATA IOPERA( 196),IX( 196),IY( 196)/'DRAW', 2, 12/ 9229 DATA IOPERA( 197),IX( 197),IY( 197)/'DRAW', 5, 11/ 9230 DATA IOPERA( 198),IX( 198),IY( 198)/'DRAW', 6, 10/ 9231 DATA IOPERA( 199),IX( 199),IY( 199)/'DRAW', 7, 8/ 9232 DATA IOPERA( 200),IX( 200),IY( 200)/'DRAW', 7, 6/ 9233 DATA IOPERA( 201),IX( 201),IY( 201)/'DRAW', 6, 4/ 9234 DATA IOPERA( 202),IX( 202),IY( 202)/'DRAW', 5, 3/ 9235 DATA IOPERA( 203),IX( 203),IY( 203)/'DRAW', 2, 2/ 9236 DATA IOPERA( 204),IX( 204),IY( 204)/'DRAW', -7, 2/ 9237 DATA IOPERA( 205),IX( 205),IY( 205)/'MOVE', 0, 2/ 9238 DATA IOPERA( 206),IX( 206),IY( 206)/'DRAW', 7, -9/ 9239C 9240 DATA IXMIND( 18)/ -11/ 9241 DATA IXMAXD( 18)/ 10/ 9242 DATA IXDELD( 18)/ 21/ 9243 DATA ISTARD( 18)/ 193/ 9244 DATA NUMCOO( 18)/ 14/ 9245C 9246C DEFINE CHARACTER 519--UPPER CASE S 9247C 9248 DATA IOPERA( 207),IX( 207),IY( 207)/'MOVE', 7, 9/ 9249 DATA IOPERA( 208),IX( 208),IY( 208)/'DRAW', 5, 11/ 9250 DATA IOPERA( 209),IX( 209),IY( 209)/'DRAW', 2, 12/ 9251 DATA IOPERA( 210),IX( 210),IY( 210)/'DRAW', -2, 12/ 9252 DATA IOPERA( 211),IX( 211),IY( 211)/'DRAW', -5, 11/ 9253 DATA IOPERA( 212),IX( 212),IY( 212)/'DRAW', -7, 9/ 9254 DATA IOPERA( 213),IX( 213),IY( 213)/'DRAW', -7, 7/ 9255 DATA IOPERA( 214),IX( 214),IY( 214)/'DRAW', -6, 5/ 9256 DATA IOPERA( 215),IX( 215),IY( 215)/'DRAW', -5, 4/ 9257 DATA IOPERA( 216),IX( 216),IY( 216)/'DRAW', -3, 3/ 9258 DATA IOPERA( 217),IX( 217),IY( 217)/'DRAW', 3, 1/ 9259 DATA IOPERA( 218),IX( 218),IY( 218)/'DRAW', 5, 0/ 9260 DATA IOPERA( 219),IX( 219),IY( 219)/'DRAW', 6, -1/ 9261 DATA IOPERA( 220),IX( 220),IY( 220)/'DRAW', 7, -3/ 9262 DATA IOPERA( 221),IX( 221),IY( 221)/'DRAW', 7, -6/ 9263 DATA IOPERA( 222),IX( 222),IY( 222)/'DRAW', 5, -8/ 9264 DATA IOPERA( 223),IX( 223),IY( 223)/'DRAW', 2, -9/ 9265 DATA IOPERA( 224),IX( 224),IY( 224)/'DRAW', -2, -9/ 9266 DATA IOPERA( 225),IX( 225),IY( 225)/'DRAW', -5, -8/ 9267 DATA IOPERA( 226),IX( 226),IY( 226)/'DRAW', -7, -6/ 9268C 9269 DATA IXMIND( 19)/ -10/ 9270 DATA IXMAXD( 19)/ 10/ 9271 DATA IXDELD( 19)/ 20/ 9272 DATA ISTARD( 19)/ 207/ 9273 DATA NUMCOO( 19)/ 20/ 9274C 9275C DEFINE CHARACTER 520--UPPER CASE T 9276C 9277 DATA IOPERA( 227),IX( 227),IY( 227)/'MOVE', 0, 12/ 9278 DATA IOPERA( 228),IX( 228),IY( 228)/'DRAW', 0, -9/ 9279 DATA IOPERA( 229),IX( 229),IY( 229)/'MOVE', -7, 12/ 9280 DATA IOPERA( 230),IX( 230),IY( 230)/'DRAW', 7, 12/ 9281C 9282 DATA IXMIND( 20)/ -8/ 9283 DATA IXMAXD( 20)/ 8/ 9284 DATA IXDELD( 20)/ 16/ 9285 DATA ISTARD( 20)/ 227/ 9286 DATA NUMCOO( 20)/ 4/ 9287C 9288C DEFINE CHARACTER 521--UPPER CASE U 9289C 9290 DATA IOPERA( 231),IX( 231),IY( 231)/'MOVE', -7, 12/ 9291 DATA IOPERA( 232),IX( 232),IY( 232)/'DRAW', -7, -3/ 9292 DATA IOPERA( 233),IX( 233),IY( 233)/'DRAW', -6, -6/ 9293 DATA IOPERA( 234),IX( 234),IY( 234)/'DRAW', -4, -8/ 9294 DATA IOPERA( 235),IX( 235),IY( 235)/'DRAW', -1, -9/ 9295 DATA IOPERA( 236),IX( 236),IY( 236)/'DRAW', 1, -9/ 9296 DATA IOPERA( 237),IX( 237),IY( 237)/'DRAW', 4, -8/ 9297 DATA IOPERA( 238),IX( 238),IY( 238)/'DRAW', 6, -6/ 9298 DATA IOPERA( 239),IX( 239),IY( 239)/'DRAW', 7, -3/ 9299 DATA IOPERA( 240),IX( 240),IY( 240)/'DRAW', 7, 12/ 9300C 9301 DATA IXMIND( 21)/ -11/ 9302 DATA IXMAXD( 21)/ 11/ 9303 DATA IXDELD( 21)/ 22/ 9304 DATA ISTARD( 21)/ 231/ 9305 DATA NUMCOO( 21)/ 10/ 9306C 9307C DEFINE CHARACTER 522--UPPER CASE V 9308C 9309 DATA IOPERA( 241),IX( 241),IY( 241)/'MOVE', -8, 12/ 9310 DATA IOPERA( 242),IX( 242),IY( 242)/'DRAW', 0, -9/ 9311 DATA IOPERA( 243),IX( 243),IY( 243)/'MOVE', 8, 12/ 9312 DATA IOPERA( 244),IX( 244),IY( 244)/'DRAW', 0, -9/ 9313C 9314 DATA IXMIND( 22)/ -9/ 9315 DATA IXMAXD( 22)/ 9/ 9316 DATA IXDELD( 22)/ 18/ 9317 DATA ISTARD( 22)/ 241/ 9318 DATA NUMCOO( 22)/ 4/ 9319C 9320C DEFINE CHARACTER 523--UPPER CASE W 9321C 9322 DATA IOPERA( 245),IX( 245),IY( 245)/'MOVE', -10, 12/ 9323 DATA IOPERA( 246),IX( 246),IY( 246)/'DRAW', -5, -9/ 9324 DATA IOPERA( 247),IX( 247),IY( 247)/'MOVE', 0, 12/ 9325 DATA IOPERA( 248),IX( 248),IY( 248)/'DRAW', -5, -9/ 9326 DATA IOPERA( 249),IX( 249),IY( 249)/'MOVE', 0, 12/ 9327 DATA IOPERA( 250),IX( 250),IY( 250)/'DRAW', 5, -9/ 9328 DATA IOPERA( 251),IX( 251),IY( 251)/'MOVE', 10, 12/ 9329 DATA IOPERA( 252),IX( 252),IY( 252)/'DRAW', 5, -9/ 9330C 9331 DATA IXMIND( 23)/ -12/ 9332 DATA IXMAXD( 23)/ 12/ 9333 DATA IXDELD( 23)/ 24/ 9334 DATA ISTARD( 23)/ 245/ 9335 DATA NUMCOO( 23)/ 8/ 9336C 9337C DEFINE CHARACTER 524--UPPER CASE X 9338C 9339 DATA IOPERA( 253),IX( 253),IY( 253)/'MOVE', -7, 12/ 9340 DATA IOPERA( 254),IX( 254),IY( 254)/'DRAW', 7, -9/ 9341 DATA IOPERA( 255),IX( 255),IY( 255)/'MOVE', 7, 12/ 9342 DATA IOPERA( 256),IX( 256),IY( 256)/'DRAW', -7, -9/ 9343C 9344 DATA IXMIND( 24)/ -10/ 9345 DATA IXMAXD( 24)/ 10/ 9346 DATA IXDELD( 24)/ 20/ 9347 DATA ISTARD( 24)/ 253/ 9348 DATA NUMCOO( 24)/ 4/ 9349C 9350C DEFINE CHARACTER 525--UPPER CASE Y 9351C 9352 DATA IOPERA( 257),IX( 257),IY( 257)/'MOVE', -8, 12/ 9353 DATA IOPERA( 258),IX( 258),IY( 258)/'DRAW', 0, 2/ 9354 DATA IOPERA( 259),IX( 259),IY( 259)/'DRAW', 0, -9/ 9355 DATA IOPERA( 260),IX( 260),IY( 260)/'MOVE', 8, 12/ 9356 DATA IOPERA( 261),IX( 261),IY( 261)/'DRAW', 0, 2/ 9357C 9358 DATA IXMIND( 25)/ -9/ 9359 DATA IXMAXD( 25)/ 9/ 9360 DATA IXDELD( 25)/ 18/ 9361 DATA ISTARD( 25)/ 257/ 9362 DATA NUMCOO( 25)/ 5/ 9363C 9364C DEFINE CHARACTER 526--UPPER CASE Z 9365C 9366 DATA IOPERA( 262),IX( 262),IY( 262)/'MOVE', 7, 12/ 9367 DATA IOPERA( 263),IX( 263),IY( 263)/'DRAW', -7, -9/ 9368 DATA IOPERA( 264),IX( 264),IY( 264)/'MOVE', -7, 12/ 9369 DATA IOPERA( 265),IX( 265),IY( 265)/'DRAW', 7, 12/ 9370 DATA IOPERA( 266),IX( 266),IY( 266)/'MOVE', -7, -9/ 9371 DATA IOPERA( 267),IX( 267),IY( 267)/'DRAW', 7, -9/ 9372C 9373 DATA IXMIND( 26)/ -10/ 9374 DATA IXMAXD( 26)/ 10/ 9375 DATA IXDELD( 26)/ 20/ 9376 DATA ISTARD( 26)/ 262/ 9377 DATA NUMCOO( 26)/ 6/ 9378C 9379C-----START POINT----------------------------------------------------- 9380C 9381 IFOUND='NO' 9382 IERROR='NO' 9383C 9384 NUMCO=1 9385 ISTART=1 9386 ISTOP=1 9387 NC=1 9388C 9389C ****************************************** 9390C ****************************************** 9391C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 9392C ** HERSHEY CHARACTER SET CASE ** 9393C ****************************************** 9394C ****************************************** 9395C 9396C 9397 IF(IBUGD2.EQ.'OFF')GOTO90 9398 WRITE(ICOUT,999) 9399 999 FORMAT(1X) 9400 CALL DPWRST('XXX','BUG ') 9401 WRITE(ICOUT,51) 9402 51 FORMAT('***** AT THE BEGINNING OF DPRSU--') 9403 CALL DPWRST('XXX','BUG ') 9404 WRITE(ICOUT,52)ICHAR2 9405 52 FORMAT('ICHAR2 = ',A4) 9406 CALL DPWRST('XXX','BUG ') 9407 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 9408 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 9409 CALL DPWRST('XXX','BUG ') 9410 90 CONTINUE 9411C 9412C ************************************************** 9413C ************************************************** 9414C ** STEP 1-- ** 9415C ** SEARCH FOR THE INPUT CHARACTER(S). ** 9416C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** 9417C ************************************************** 9418C ************************************************** 9419C 9420 CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND) 9421 IF(IFOUND.EQ.'NO')GOTO9000 9422 GOTO1000 9423C 9424C ************************************** 9425C ************************************** 9426C ** STEP 2-- ** 9427C ** EXTRACT THE COORDINATES ** 9428C ** FOR THIS PARTICULAR CHARACTER. ** 9429C ************************************** 9430C ************************************** 9431C 9432 1000 CONTINUE 9433 ISTART=ISTARD(ICHARN) 9434 NC=NUMCOO(ICHARN) 9435 ISTOP=ISTART+NC-1 9436 J=0 9437 DO1100I=ISTART,ISTOP 9438 J=J+1 9439 IOP(J)=IOPERA(I) 9440 X(J)=IX(I) 9441 Y(J)=IY(I) 9442 1100 CONTINUE 9443 NUMCO=J 9444 IXMINS=IXMIND(ICHARN) 9445 IXMAXS=IXMAXD(ICHARN) 9446 IXDELS=IXDELD(ICHARN) 9447C 9448 GOTO9000 9449C 9450C ***************** 9451C ***************** 9452C ** STEP 90-- ** 9453C ** EXIT ** 9454C ***************** 9455C ***************** 9456C 9457 9000 CONTINUE 9458 IF(IBUGD2.EQ.'OFF')GOTO9090 9459 WRITE(ICOUT,999) 9460 CALL DPWRST('XXX','BUG ') 9461 WRITE(ICOUT,9011) 9462 9011 FORMAT('***** AT THE END OF DPRSU--') 9463 CALL DPWRST('XXX','BUG ') 9464 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 9465 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 9466 CALL DPWRST('XXX','BUG ') 9467 WRITE(ICOUT,9013)ICHAR2,ICHARN 9468 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) 9469 CALL DPWRST('XXX','BUG ') 9470 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 9471 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 9472 CALL DPWRST('XXX','BUG ') 9473 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 9474 DO9015I=1,NUMCO 9475 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 9476 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 9477 CALL DPWRST('XXX','BUG ') 9478 9015 CONTINUE 9479 9019 CONTINUE 9480 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 9481 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 9482 CALL DPWRST('XXX','BUG ') 9483 9090 CONTINUE 9484C 9485 RETURN 9486 END 9487 SUBROUTINE DPRTF1(IHEAD,NHEAD,CAPTN,NCAP) 9488C 9489C PURPOSE--THIS ROUTINE IS A UTILITY ROUTINE FOR CREATING 9490C RTF OUTPUT. THIS ROUTINE IS USED TO INITIATE 9491C THE RTF OUTPUT AND STARTS THE FIRST TABLE. 9492C THE ONLY OPTIONAL ELEMENT IS THE CAPTION. 9493C INPUT ARGUMENTS--IHEAD = THE CHARACTER STRING CONTAINING 9494C THE TEXT FOR THE HEADER 9495C --NHEAD = THE INTEGER NUMBER THAT SPECIFIES 9496C THE NUMBER OF CHARACTERS IN THE 9497C HEADER. 9498C --CAPTN = THE CHARACTER STRING CONTAINING 9499C THE CAPTION. 9500C --NCAP = THE INTEGER NUMBER THAT SPECIFIES 9501C THE NUMBER OF CHARACTERS IN THE 9502C CAPTION. 9503C WRITTEN BY--ALAN HECKERT 9504C STATISTICAL ENGINEERING DIVISION 9505C INFORMATION TECHNOLOGY LABOARATORY 9506C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 9507C GAITHERSBURG, MD 20899-8980 9508C PHONE--301-975-2899 9509C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 9510C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 9511C LANGUAGE--ANSI FORTRAN (1977) 9512C VERSION NUMBER--2005/2 9513C ORIGINAL VERSION--FEBRUARY 2005. 9514C 9515C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 9516C 9517 CHARACTER*(*) CAPTN 9518 CHARACTER*(*) IHEAD 9519C 9520 CHARACTER*1 IBASLC 9521 CHARACTER*10 IFORMT 9522C 9523C-----COMMON---------------------------------------------------------- 9524C 9525 INCLUDE 'DPCOST.INC' 9526 INCLUDE 'DPCOP2.INC' 9527C 9528C-----START POINT----------------------------------------------------- 9529C 9530C STEP 1: END ASIS MODE AND WRITE A HEADER 9531C 9532C 9533 CALL DPCONA(92,IBASLC) 9534 8001 FORMAT('{',A1,'pard') 9535 8002 FORMAT(A1,'par}') 9536C8003 FORMAT('{',A1,'qc',A1,'fs',I2,A1,'b') 9537 8003 FORMAT('{',A1,'qc',A1,'b') 9538 8007 FORMAT('}') 9539 8008 FORMAT(A1,'line') 9540C8009 FORMAT(A1,'line ',A1,'line') 9541 WRITE(ICOUT,8001)IBASLC 9542 CALL DPWRST('XXX','WRIT') 9543 IF(NHEAD.GE.1)THEN 9544 ATEMP=1.5*REAL(IRTFPS) 9545 ITEMP=INT(ATEMP) 9546 WRITE(ICOUT,8003)IBASLC,IBASLC 9547 CALL DPWRST('XXX','WRIT') 9548 IFORMT=' ' 9549 IFORMT(1:5)='(A )' 9550 WRITE(IFORMT(3:4),'(I2)')NHEAD 9551 WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD) 9552 CALL DPWRST('XXX','WRIT') 9553 WRITE(ICOUT,8007) 9554 CALL DPWRST('XXX','WRIT') 9555 WRITE(ICOUT,8008)IBASLC 9556 CALL DPWRST('XXX','WRIT') 9557 ENDIF 9558C 9559C STEP 2: START TABLE AND DEFINE A CAPTION 9560C 9561 8013 FORMAT('{',A1,'qc',A1,'b') 9562 IF(NCAP.GT.0)THEN 9563 WRITE(ICOUT,8013)IBASLC,IBASLC 9564 CALL DPWRST('XXX','WRIT') 9565 IFORMT=' ' 9566 IFORMT(1:6)='(A )' 9567 WRITE(IFORMT(3:5),'(I3)')NCAP 9568 WRITE(ICOUT,IFORMT)CAPTN(1:NCAP) 9569 CALL DPWRST('XXX','WRIT') 9570 WRITE(ICOUT,8007) 9571 CALL DPWRST('XXX','WRIT') 9572 WRITE(ICOUT,8008)IBASLC 9573 CALL DPWRST('XXX','WRIT') 9574 ENDIF 9575 WRITE(ICOUT,8002)IBASLC 9576 CALL DPWRST('XXX','WRIT') 9577C 9578 RETURN 9579 END 9580 SUBROUTINE DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) 9581C 9582C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING 9583C RTF OUTPUT. THIS ROUTINE IS USED TO GENERATE 9584C A HEADER ROW FOR A TABLE. YOU CAN ALSO OPTIONALLY 9585C ADD A RULE LINE BEFORE OR AFTER THE HEADER. 9586C 9587C INPUT ARGUMENTS--IVALUE = THE CHARACTER STRING ARRAY 9588C CONTAINING THE TEXT FOR THE 9589C HEADER VALUES. 9590C --NCHAR = THE INTEGER ARRAY THAT SPECIFIES 9591C THE NUMBER OF CHARACTERS IN THE 9592C HEADER VALUES. 9593C --NHEAD = THE INTEGER VALUE THAT SPECIFIES 9594C THE NUMBER OF HEADER VALUES. 9595C --IFLAG1 = A LOGICAL VALUE THAT SPECIFIES 9596C WHETHER A RULE LINE IS DRAWN BEFORE 9597C THE HEADER. 9598C --IFLAG2 = A LOGICAL VALUE THAT SPECIFIES 9599C WHETHER A RULE LINE IS DRAWN AFTER 9600C THE HHEADER. 9601C WRITTEN BY--ALAN HECKERT 9602C STATISTICAL ENGINEERING DIVISION 9603C INFORMATION TECHNOLOGY LABOARATORY 9604C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 9605C GAITHERSBURG, MD 20899-8980 9606C PHONE--301-975-2899 9607C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 9608C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 9609C LANGUAGE--ANSI FORTRAN (1977) 9610C VERSION NUMBER--2005/2 9611C ORIGINAL VERSION--FEBRUARY 2005. 9612C 9613C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 9614C 9615 CHARACTER*(*) IVALUE(NHEAD) 9616 INTEGER NCHAR(NHEAD) 9617C 9618 PARAMETER (MAXHED=1024) 9619 INTEGER IWIDTH(MAXHED) 9620 INTEGER NUMDIG(MAXHED) 9621 CHARACTER*8 ALIGN(MAXHED) 9622 CHARACTER*8 VALIGN(MAXHED) 9623 COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN 9624C 9625 LOGICAL IFLAG1 9626 LOGICAL IFLAG2 9627C 9628 CHARACTER*1 IBASLC 9629 CHARACTER*20 IFORMT 9630C 9631C--------------------------------------------------------------------- 9632C 9633 INCLUDE 'DPCOP2.INC' 9634C 9635C-----START POINT----------------------------------------------------- 9636C 9637 CALL DPCONA(92,IBASLC) 9638C 9639C STEP 1: GENERATE A HEADER LINE 9640C 9641 8001 FORMAT('{',A1,'trowd',A1,'trgraph90') 9642 WRITE(ICOUT,8001)IBASLC,IBASLC 9643 CALL DPWRST('XXX','WRIT') 9644C 9645 8011 FORMAT(A1,'clvertalt',A1,'cellx',I3) 9646 8012 FORMAT(A1,'clvertalc',A1,'cellx',I3) 9647 8013 FORMAT(A1,'clvertalb',A1,'cellx',I3) 9648 8111 FORMAT(A1,'clvertalt',A1,'cellx',I4) 9649 8112 FORMAT(A1,'clvertalc',A1,'cellx',I4) 9650 8113 FORMAT(A1,'clvertalb',A1,'cellx',I4) 9651 8211 FORMAT(A1,'clvertalt',A1,'cellx',I5) 9652 8212 FORMAT(A1,'clvertalc',A1,'cellx',I5) 9653 8213 FORMAT(A1,'clvertalb',A1,'cellx',I5) 9654 8014 FORMAT(A1,'clbrdrt',A1,'brdrw15',A1,'brdrs') 9655 8015 FORMAT(A1,'clbrdrb',A1,'brdrw15',A1,'brdrs') 9656 DO8010I=1,NHEAD 9657 IF(IFLAG1)THEN 9658 WRITE(ICOUT,8014)IBASLC,IBASLC,IBASLC 9659 CALL DPWRST('XXX','WRIT') 9660 ENDIF 9661 IF(IFLAG2)THEN 9662 WRITE(ICOUT,8015)IBASLC,IBASLC,IBASLC 9663 CALL DPWRST('XXX','WRIT') 9664 ENDIF 9665 IF(VALIGN(I).EQ.'b')THEN 9666 IF(IWIDTH(I).LE.999)THEN 9667 WRITE(ICOUT,8013)IBASLC,IBASLC,IWIDTH(I) 9668 ELSEIF(IWIDTH(I).LE.9999)THEN 9669 WRITE(ICOUT,8113)IBASLC,IBASLC,IWIDTH(I) 9670 ELSE 9671 WRITE(ICOUT,8213)IBASLC,IBASLC,IWIDTH(I) 9672 ENDIF 9673 ELSEIF(VALIGN(I).EQ.'c')THEN 9674 IF(IWIDTH(I).LE.999)THEN 9675 WRITE(ICOUT,8012)IBASLC,IBASLC,IWIDTH(I) 9676 ELSEIF(IWIDTH(I).LE.9999)THEN 9677 WRITE(ICOUT,8112)IBASLC,IBASLC,IWIDTH(I) 9678 ELSE 9679 WRITE(ICOUT,8212)IBASLC,IBASLC,IWIDTH(I) 9680 ENDIF 9681 ELSE 9682 IF(IWIDTH(I).LE.999)THEN 9683 WRITE(ICOUT,8011)IBASLC,IBASLC,IWIDTH(I) 9684 ELSEIF(IWIDTH(I).LE.9999)THEN 9685 WRITE(ICOUT,8111)IBASLC,IBASLC,IWIDTH(I) 9686 ELSE 9687 WRITE(ICOUT,8211)IBASLC,IBASLC,IWIDTH(I) 9688 ENDIF 9689 ENDIF 9690 CALL DPWRST('XXX','WRIT') 9691 8010 CONTINUE 9692C 9693 8021 FORMAT(A1,'pard',A1,'intbl',A1,'ql {') 9694 8022 FORMAT(A1,'pard',A1,'intbl',A1,'qc {') 9695 8023 FORMAT(A1,'pard',A1,'intbl',A1,'qr {') 9696 IFORMT=' ' 9697 IFORMT(1:5)='(A )' 9698 8027 FORMAT('}',A1,'cell') 9699 DO8020I=1,NHEAD 9700 IF(ALIGN(I).EQ.'l')THEN 9701 WRITE(ICOUT,8021)IBASLC,IBASLC,IBASLC 9702 ELSEIF(ALIGN(I).EQ.'c')THEN 9703 WRITE(ICOUT,8022)IBASLC,IBASLC,IBASLC 9704 ELSE 9705 WRITE(ICOUT,8023)IBASLC,IBASLC,IBASLC 9706 ENDIF 9707 CALL DPWRST('XXX','WRIT') 9708 IF(NCHAR(I).GT.0)THEN 9709 WRITE(IFORMT(3:4),'(I2)')NCHAR(I) 9710 WRITE(ICOUT,IFORMT)IVALUE(I)(1:NCHAR(I)) 9711 CALL DPWRST('XXX','WRIT') 9712 ELSE 9713 ITEMP=1 9714 WRITE(IFORMT(3:4),'(I2)')ITEMP 9715 WRITE(ICOUT,IFORMT) ' ' 9716 CALL DPWRST('XXX','WRIT') 9717 ENDIF 9718 WRITE(ICOUT,8027)IBASLC 9719 CALL DPWRST('XXX','WRIT') 9720 8020 CONTINUE 9721C 9722 8039 FORMAT(A1,'row}') 9723 WRITE(ICOUT,8039)IBASLC 9724 CALL DPWRST('XXX','WRIT') 9725C 9726 RETURN 9727 END 9728 SUBROUTINE DPRT4B(IVALUE,NCHAR,NHEAD,NCOLSP,IFLAG1,IFLAG2) 9729C 9730C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING 9731C RTF OUTPUT. THIS ROUTINE IS USED TO GENERATE 9732C A HEADER ROW FOR A TABLE. YOU CAN ALSO OPTIONALLY 9733C ADD A RULE LINE BEFORE OR AFTER THE HEADER. 9734C 9735C INPUT ARGUMENTS--IVALUE = THE CHARACTER STRING ARRAY 9736C CONTAINING THE TEXT FOR THE 9737C HEADER VALUES. 9738C --NCHAR = THE INTEGER ARRAY THAT SPECIFIES 9739C THE NUMBER OF CHARACTERS IN THE 9740C HEADER VALUES. 9741C --NHEAD = THE INTEGER VALUE THAT SPECIFIES 9742C THE NUMBER OF HEADER VALUES. 9743C --NCOLSP = THE INTEGER ARRAY THAT SPECIFIES 9744C THE COLUMN SPAN FOR THE GIVEN COLUMN 9745C --IFLAG1 = A LOGICAL VALUE THAT SPECIFIES 9746C WHETHER A RULE LINE IS DRAWN BEFORE 9747C THE HEADER. 9748C --IFLAG2 = A LOGICAL VALUE THAT SPECIFIES 9749C WHETHER A RULE LINE IS DRAWN AFTER 9750C THE HEADER. 9751C WRITTEN BY--ALAN HECKERT 9752C STATISTICAL ENGINEERING DIVISION 9753C INFORMATION TECHNOLOGY LABOARATORY 9754C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 9755C GAITHERSBURG, MD 20899-8980 9756C PHONE--301-975-2899 9757C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 9758C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 9759C LANGUAGE--ANSI FORTRAN (1977) 9760C VERSION NUMBER--2011/1 9761C ORIGINAL VERSION--JANUARY 2011. 9762C 9763C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 9764C 9765 CHARACTER*(*) IVALUE(NHEAD) 9766 INTEGER NCHAR(NHEAD) 9767 INTEGER NCOLSP(NHEAD) 9768C 9769 PARAMETER (MAXHED=1024) 9770 INTEGER IWIDTH(MAXHED) 9771 INTEGER NUMDIG(MAXHED) 9772 CHARACTER*8 ALIGN(MAXHED) 9773 CHARACTER*8 VALIGN(MAXHED) 9774 COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN 9775C 9776 LOGICAL IFLAG1 9777 LOGICAL IFLAG2 9778C 9779 CHARACTER*1 IBASLC 9780 CHARACTER*20 IFORMT 9781C 9782C--------------------------------------------------------------------- 9783C 9784 INCLUDE 'DPCOP2.INC' 9785C 9786C-----START POINT----------------------------------------------------- 9787C 9788 CALL DPCONA(92,IBASLC) 9789C 9790C STEP 1: GENERATE A HEADER LINE 9791C 9792 8001 FORMAT('{',A1,'trowd',A1,'trgraph90') 9793 WRITE(ICOUT,8001)IBASLC,IBASLC 9794 CALL DPWRST('XXX','WRIT') 9795C 9796 8011 FORMAT(A1,'clvertalt',A1,'cellx',I3) 9797 8012 FORMAT(A1,'clvertalc',A1,'cellx',I3) 9798 8013 FORMAT(A1,'clvertalb',A1,'cellx',I3) 9799 8111 FORMAT(A1,'clvertalt',A1,'cellx',I4) 9800 8112 FORMAT(A1,'clvertalc',A1,'cellx',I4) 9801 8113 FORMAT(A1,'clvertalb',A1,'cellx',I4) 9802 8211 FORMAT(A1,'clvertalt',A1,'cellx',I5) 9803 8212 FORMAT(A1,'clvertalc',A1,'cellx',I5) 9804 8213 FORMAT(A1,'clvertalb',A1,'cellx',I5) 9805 8014 FORMAT(A1,'clbrdrt',A1,'brdrw15',A1,'brdrs') 9806 8015 FORMAT(A1,'clbrdrb',A1,'brdrw15',A1,'brdrs') 9807 8016 FORMAT(A1,'clbrdrr',A1,'brdrw15',A1,'brdrs') 9808C 9809C TRANSLATE "\'7C" TO BE A RIGHT BORDER (FORMAT 8016) 9810C AND MAKE THE TEXT BLANK. 9811C 9812 DO8010I=1,NHEAD 9813 IF(IFLAG1)THEN 9814 WRITE(ICOUT,8014)IBASLC,IBASLC,IBASLC 9815 CALL DPWRST('XXX','WRIT') 9816 ENDIF 9817 IF(IFLAG2)THEN 9818 WRITE(ICOUT,8015)IBASLC,IBASLC,IBASLC 9819 CALL DPWRST('XXX','WRIT') 9820 ENDIF 9821 IF(IVALUE(I)(7:8).EQ.'7C')THEN 9822 CALL DPCOAN(IVALUE(I)(5:5),IJUNK1) 9823 CALL DPCOAN(IVALUE(I)(6:6),IJUNK2) 9824 IF(IJUNK1.EQ.92 .AND. IJUNK2.EQ.39)THEN 9825 WRITE(ICOUT,8016)IBASLC,IBASLC,IBASLC 9826 CALL DPWRST('XXX','WRIT') 9827 IVALUE(I)=' ' 9828 NCHAR(I)=0 9829 ENDIF 9830 ENDIF 9831C 9832C CHECK FOR COLUMN SPAN 9833C 9834C FOR RTF, THE COLUMN WIDTHS ARE CUMULATIVE, SO 9835C SET TO WIDTH OF LAST COLUMN. 9836C 9837 IF(NCOLSP(I).LE.0)THEN 9838 GOTO8010 9839 ELSEIF(NCOLSP(I).EQ.1)THEN 9840 IWIDT=IWIDTH(I) 9841 ELSE 9842 IWIDT=IWIDTH(I+NCOLSP(I)-1) 9843 ENDIF 9844C 9845 IF(VALIGN(I).EQ.'b')THEN 9846 IF(IWIDT.LE.999)THEN 9847 WRITE(ICOUT,8013)IBASLC,IBASLC,IWIDT 9848 ELSEIF(IWIDT.LE.9999)THEN 9849 WRITE(ICOUT,8113)IBASLC,IBASLC,IWIDT 9850 ELSE 9851 WRITE(ICOUT,8213)IBASLC,IBASLC,IWIDT 9852 ENDIF 9853 ELSEIF(VALIGN(I).EQ.'c')THEN 9854 IF(IWIDT.LE.999)THEN 9855 WRITE(ICOUT,8012)IBASLC,IBASLC,IWIDT 9856 ELSEIF(IWIDT.LE.9999)THEN 9857 WRITE(ICOUT,8112)IBASLC,IBASLC,IWIDT 9858 ELSE 9859 WRITE(ICOUT,8212)IBASLC,IBASLC,IWIDT 9860 ENDIF 9861 ELSE 9862 IF(IWIDT.LE.999)THEN 9863 WRITE(ICOUT,8011)IBASLC,IBASLC,IWIDT 9864 ELSEIF(IWIDT.LE.9999)THEN 9865 WRITE(ICOUT,8111)IBASLC,IBASLC,IWIDT 9866 ELSE 9867 WRITE(ICOUT,8211)IBASLC,IBASLC,IWIDT 9868 ENDIF 9869 ENDIF 9870 CALL DPWRST('XXX','WRIT') 9871 8010 CONTINUE 9872C 9873 8021 FORMAT(A1,'pard',A1,'intbl',A1,'ql {') 9874 8022 FORMAT(A1,'pard',A1,'intbl',A1,'qc {') 9875 8023 FORMAT(A1,'pard',A1,'intbl',A1,'qr {') 9876 IFORMT=' ' 9877 IFORMT(1:5)='(A )' 9878 8027 FORMAT('}',A1,'cell') 9879 DO8020I=1,NHEAD 9880 IF(NCOLSP(I).LE.0)GOTO8020 9881 IF(ALIGN(I).EQ.'c' .OR. NCOLSP(I).GT.1)THEN 9882 WRITE(ICOUT,8022)IBASLC,IBASLC,IBASLC 9883 ELSEIF(ALIGN(I).EQ.'l')THEN 9884 WRITE(ICOUT,8021)IBASLC,IBASLC,IBASLC 9885 ELSE 9886 WRITE(ICOUT,8023)IBASLC,IBASLC,IBASLC 9887 ENDIF 9888 CALL DPWRST('XXX','WRIT') 9889 IF(NCHAR(I).GT.0)THEN 9890 WRITE(IFORMT(3:4),'(I2)')NCHAR(I) 9891 WRITE(ICOUT,IFORMT)IVALUE(I)(1:NCHAR(I)) 9892 CALL DPWRST('XXX','WRIT') 9893 ELSE 9894 ITEMP=1 9895 WRITE(IFORMT(3:4),'(I2)')ITEMP 9896 WRITE(ICOUT,IFORMT) ' ' 9897 CALL DPWRST('XXX','WRIT') 9898 ENDIF 9899 WRITE(ICOUT,8027)IBASLC 9900 CALL DPWRST('XXX','WRIT') 9901 8020 CONTINUE 9902C 9903 8039 FORMAT(A1,'row}') 9904 WRITE(ICOUT,8039)IBASLC 9905 CALL DPWRST('XXX','WRIT') 9906C 9907 RETURN 9908 END 9909 SUBROUTINE DPRTF5(IVALUE,NCHAR,AVALUE,NHEAD,IFLAG1) 9910C 9911C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING 9912C RTF OUTPUT. THIS ROUTINE IS USED TO GENERATE 9913C A DATA ROW FOR A TABLE. THE FIRST FIELD CAN BE 9914C A TEXT VALUE (FOR A ROW LABEL). 9915C 9916C INPUT ARGUMENTS--IVALUE = THE CHARACTER STRING CONTAINING 9917C THE TEXT FOR THE FIRST COLUMN. 9918C --NCHAR = THE INTEGER ARRAY THAT SPECIFIES 9919C THE NUMBER OF CHARACTERS IN THE 9920C FIRST TEXT FIELD. 9921C --AVALUE = A REAL ARRAY CONTAINING THE DATA 9922C TO BE GENERATED. 9923C --NHEAD = THE INTEGER VALUE THAT SPECIFIES 9924C THE NUMBER OF NUMERIC VALUES. 9925C WRITTEN BY--ALAN HECKERT 9926C STATISTICAL ENGINEERING DIVISION 9927C INFORMATION TECHNOLOGY LABOARATORY 9928C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 9929C GAITHERSBURG, MD 20899-8980 9930C PHONE--301-975-2899 9931C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 9932C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 9933C LANGUAGE--ANSI FORTRAN (1977) 9934C VERSION NUMBER--2005/2 9935C ORIGINAL VERSION--FEBRUARY 2005. 9936C UPDATED --APRIL 2009. ADDITIONAL FORMATTING OPTIONS 9937C UPDATED --JANUARY 2011. MODIFY HOW FONTS ARE SET 9938C 1) SET PROPORTIONAL FONT FOR 9939C FIRST COLUMN 9940C 2) SET FIXED FONT FOR SECOND 9941C (NUMERIC COLUMN) 9942C 3) RESET PROPORTIONAL FONT 9943C 9944C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 9945C 9946 CHARACTER*(*) IVALUE 9947 REAL AVALUE(*) 9948 INTEGER NCHAR 9949C 9950 PARAMETER (MAXHED=1024) 9951 INTEGER IWIDTH(MAXHED) 9952 INTEGER NUMDIG(MAXHED) 9953 CHARACTER*8 ALIGN(MAXHED) 9954 CHARACTER*8 VALIGN(MAXHED) 9955 COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN 9956C 9957 LOGICAL IFLAG1 9958C 9959 CHARACTER*1 IBASLC 9960 CHARACTER*20 IFORMT 9961C 9962C-----COMMON---------------------------------------------------------- 9963C 9964 INCLUDE 'DPCOST.INC' 9965 INCLUDE 'DPCOP2.INC' 9966C 9967C-----START POINT----------------------------------------------------- 9968C 9969 CALL DPCONA(92,IBASLC) 9970C 9971C STEP 0: SET PROPORTIONAL FONT FOR CHARACTER COLUMN ONE 9972C 9973 IF(IRTFFP.EQ.'Times New Roman')THEN 9974 ITEMP=0 9975 ELSEIF(IRTFFP.EQ.'Lucida Sans')THEN 9976 ITEMP=6 9977 ELSEIF(IRTFFP.EQ.'Arial')THEN 9978 ITEMP=2 9979 ELSEIF(IRTFFP.EQ.'Bookman')THEN 9980 ITEMP=3 9981 ELSEIF(IRTFFP.EQ.'Georgia')THEN 9982 ITEMP=4 9983 ELSEIF(IRTFFP.EQ.'Tahoma')THEN 9984 ITEMP=5 9985 ELSEIF(IRTFFP.EQ.'Verdana')THEN 9986 ITEMP=7 9987 ENDIF 9988 WRITE(ICOUT,8091)IBASLC,ITEMP 9989 CALL DPWRST(ICOUT,'WRIT') 9990C 9991C 9992C STEP 1: GENERATE A HEADER LINE 9993C 9994 8001 FORMAT('{',A1,'trowd',A1,'trgraph90') 9995 WRITE(ICOUT,8001)IBASLC,IBASLC 9996 CALL DPWRST('XXX','WRIT') 9997C 9998 8011 FORMAT(A1,'clvertalt',A1,'cellx',I3) 9999 8012 FORMAT(A1,'clvertalc',A1,'cellx',I3) 10000 8013 FORMAT(A1,'clvertalb',A1,'cellx',I3) 10001 8111 FORMAT(A1,'clvertalt',A1,'cellx',I4) 10002 8112 FORMAT(A1,'clvertalc',A1,'cellx',I4) 10003 8113 FORMAT(A1,'clvertalb',A1,'cellx',I4) 10004 8211 FORMAT(A1,'clvertalt',A1,'cellx',I5) 10005 8212 FORMAT(A1,'clvertalc',A1,'cellx',I5) 10006 8213 FORMAT(A1,'clvertalb',A1,'cellx',I5) 10007C8014 FORMAT(A1,'clbrdrt',A1,'brdrw15',A1,'brdrs') 10008 8015 FORMAT(A1,'clbrdrb',A1,'brdrw15',A1,'brdrs') 10009 NCOLS=NHEAD 10010 IF(NCHAR.GT.0)NCOLS=NCOLS+1 10011 DO8010I=1,NCOLS 10012 IF(IFLAG1)THEN 10013 WRITE(ICOUT,8015)IBASLC,IBASLC,IBASLC 10014 CALL DPWRST('XXX','WRIT') 10015 ENDIF 10016 IF(VALIGN(I).EQ.'b')THEN 10017 IF(IWIDTH(I).LE.999)THEN 10018 WRITE(ICOUT,8013)IBASLC,IBASLC,IWIDTH(I) 10019 ELSEIF(IWIDTH(I).LE.9999)THEN 10020 WRITE(ICOUT,8113)IBASLC,IBASLC,IWIDTH(I) 10021 ELSE 10022 WRITE(ICOUT,8213)IBASLC,IBASLC,IWIDTH(I) 10023 ENDIF 10024 ELSEIF(VALIGN(I).EQ.'c')THEN 10025 IF(IWIDTH(I).LE.999)THEN 10026 WRITE(ICOUT,8012)IBASLC,IBASLC,IWIDTH(I) 10027 ELSEIF(IWIDTH(I).LE.9999)THEN 10028 WRITE(ICOUT,8112)IBASLC,IBASLC,IWIDTH(I) 10029 ELSE 10030 WRITE(ICOUT,8212)IBASLC,IBASLC,IWIDTH(I) 10031 ENDIF 10032 ELSE 10033 IF(IWIDTH(I).LE.999)THEN 10034 WRITE(ICOUT,8011)IBASLC,IBASLC,IWIDTH(I) 10035 ELSEIF(IWIDTH(I).LE.9999)THEN 10036 WRITE(ICOUT,8111)IBASLC,IBASLC,IWIDTH(I) 10037 ELSE 10038 WRITE(ICOUT,8211)IBASLC,IBASLC,IWIDTH(I) 10039 ENDIF 10040 ENDIF 10041 CALL DPWRST('XXX','WRIT') 10042 8010 CONTINUE 10043C 10044 8021 FORMAT(A1,'pard',A1,'intbl',A1,'ql {') 10045 8022 FORMAT(A1,'pard',A1,'intbl',A1,'qc {') 10046 8023 FORMAT(A1,'pard',A1,'intbl',A1,'qr {') 10047 IFORMT=' ' 10048 IFORMT(1:5)='(A )' 10049 8027 FORMAT('}',A1,'cell') 10050C 10051C PRINT ROW LABEL 10052C 10053 IF(NCHAR.GT.0)THEN 10054 IF(ALIGN(1).EQ.'l')THEN 10055 WRITE(ICOUT,8021)IBASLC,IBASLC,IBASLC 10056 ELSEIF(ALIGN(1).EQ.'c')THEN 10057 WRITE(ICOUT,8022)IBASLC,IBASLC,IBASLC 10058 ELSE 10059 WRITE(ICOUT,8023)IBASLC,IBASLC,IBASLC 10060 ENDIF 10061 CALL DPWRST('XXX','WRIT') 10062 WRITE(IFORMT(3:4),'(I2)')NCHAR 10063 WRITE(ICOUT,IFORMT)IVALUE(1:NCHAR) 10064 CALL DPWRST('XXX','WRIT') 10065 WRITE(ICOUT,8027)IBASLC 10066 CALL DPWRST('XXX','WRIT') 10067 IADD=1 10068 ELSE 10069 IADD=0 10070 ENDIF 10071C 10072C PRINT NUMERIC VALUES 10073C 10074 8091 FORMAT(a1,'f',I1) 10075 IF(IRTFFF.EQ.'Courier New')THEN 10076 ITEMP=1 10077 ELSEIF(IRTFFF.EQ.'Lucida Console')THEN 10078 ITEMP=8 10079 ENDIF 10080 WRITE(ICOUT,8091)IBASLC,ITEMP 10081 CALL DPWRST(ICOUT,'WRIT') 10082C 10083C APRIL 2009: SUPPORT THE FOLLOWING FORMATTING OPTIONS 10084C 10085C NUMDIG(I) > 0 => Fyy.xx FORMAT 10086C NUMDIG(I) = 0 => I12 FORMAT 10087C NUMDIG(I) = -1 => BLANK 10088C NUMDIG(I) = -2 => G15.7 10089C NUMDIG(I) = -3 to -20 => Eyy.xx 10090C NUMDIG(I) = -99 => '**' 10091C 10092 8035 FORMAT(1X) 10093C8031 FORMAT(G15.7) 10094C8033 FORMAT(I12) 10095 8037 FORMAT('**') 10096 DO8020I=1,NHEAD 10097 IF(ALIGN(I+IADD).EQ.'l')THEN 10098 WRITE(ICOUT,8021)IBASLC,IBASLC,IBASLC 10099 ELSEIF(ALIGN(I+IADD).EQ.'c')THEN 10100 WRITE(ICOUT,8022)IBASLC,IBASLC,IBASLC 10101 ELSE 10102 WRITE(ICOUT,8023)IBASLC,IBASLC,IBASLC 10103 ENDIF 10104 CALL DPWRST('XXX','WRIT') 10105C 10106 IF(NUMDIG(I+IADD).EQ.-1)THEN 10107 WRITE(ICOUT,8035) 10108 CALL DPWRST('XXX','WRIT') 10109 ELSEIF(NUMDIG(I+IADD).EQ.-99)THEN 10110 WRITE(ICOUT,8037) 10111 CALL DPWRST('XXX','WRIT') 10112 ELSE 10113 IXX=ABS(NUMDIG(I+IADD)) 10114 IFORMT=' ' 10115 NRIGHT=MIN(IXX,12) 10116 IF(ABS(AVALUE(I+IADD)).LT.10.0)THEN 10117 NLEFT=1 10118 ELSEIF(ABS(AVALUE(I+IADD)).LT.100.0)THEN 10119 NLEFT=2 10120 ELSEIF(ABS(AVALUE(I+IADD)).LT.1000.0)THEN 10121 NLEFT=3 10122 ELSEIF(ABS(AVALUE(I+IADD)).LT.10000.0)THEN 10123 NLEFT=4 10124 ELSEIF(ABS(AVALUE(I+IADD)).LT.100000.0)THEN 10125 NLEFT=5 10126 ELSEIF(ABS(AVALUE(I+IADD)).LT.1000000.0)THEN 10127 NLEFT=6 10128 ELSEIF(ABS(AVALUE(I+IADD)).LT.10000000.0)THEN 10129 NLEFT=7 10130 ELSEIF(ABS(AVALUE(I+IADD)).LT.100000000.0)THEN 10131 NLEFT=8 10132 ELSEIF(ABS(AVALUE(I+IADD)).LT.1000000000.0)THEN 10133 NLEFT=9 10134 ELSE 10135 NLEFT=10 10136 ENDIF 10137 IF(AVALUE(I+IADD).LT.0.0)NLEFT=NLEFT+1 10138 NTOT=NRIGHT+NLEFT+2 10139 IF(NUMDIG(I+IADD).GT.0)THEN 10140 IFORMT(1:8)='(F . )' 10141 WRITE(IFORMT(3:4),'(I2)')NTOT 10142 WRITE(IFORMT(6:7),'(I2)')NRIGHT 10143 WRITE(ICOUT,IFORMT)AVALUE(I+IADD) 10144 CALL DPWRST('XXX','WRIT') 10145 ELSEIF(NUMDIG(I+IADD).EQ.0)THEN 10146 IFORMT(1:5)='(I )' 10147 WRITE(IFORMT(3:4),'(I2)')NLEFT 10148 IF(AVALUE(I+IADD).GE.0.0)THEN 10149 WRITE(ICOUT,IFORMT)INT(AVALUE(I+IADD)+0.5) 10150 ELSE 10151 WRITE(ICOUT,IFORMT)INT(AVALUE(I+IADD)-0.5) 10152 ENDIF 10153 CALL DPWRST('XXX','WRIT') 10154 ELSEIF(NUMDIG(I+IADD).EQ.-2)THEN 10155 IFORMT(1:7)='(G15.7)' 10156 WRITE(ICOUT,IFORMT)AVALUE(I+IADD) 10157 CALL DPWRST('XXX','WRIT') 10158 ELSEIF(NUMDIG(I+IADD).LT.-2 .AND. NUMDIG(I+IADD).GT.-20)THEN 10159 IFORMT(1:8)='(E . )' 10160 IXX=ABS(NUMDIG(I)) 10161 IYY=IXX+8 10162 WRITE(IFORMT(3:4),'(I2)')IYY 10163 WRITE(IFORMT(6:7),'(I2)')IXX 10164 WRITE(ICOUT,IFORMT)AVALUE(I+IADD) 10165 CALL DPWRST('XXX','WRIT') 10166 ELSE 10167 WRITE(ICOUT,'(A1)') ' ' 10168 ENDIF 10169 ENDIF 10170C 10171 WRITE(ICOUT,8027)IBASLC 10172 CALL DPWRST('XXX','WRIT') 10173 8020 CONTINUE 10174C 10175 8039 FORMAT(A1,'row}') 10176 WRITE(ICOUT,8039)IBASLC 10177 CALL DPWRST('XXX','WRIT') 10178C 10179 IF(IRTFFP.EQ.'Times New Roman')THEN 10180 ITEMP=0 10181 ELSEIF(IRTFFP.EQ.'Lucida Sans')THEN 10182 ITEMP=6 10183 ELSEIF(IRTFFP.EQ.'Arial')THEN 10184 ITEMP=2 10185 ELSEIF(IRTFFP.EQ.'Bookman')THEN 10186 ITEMP=3 10187 ELSEIF(IRTFFP.EQ.'Georgia')THEN 10188 ITEMP=4 10189 ELSEIF(IRTFFP.EQ.'Tahoma')THEN 10190 ITEMP=5 10191 ELSEIF(IRTFFP.EQ.'Verdana')THEN 10192 ITEMP=7 10193 ENDIF 10194 WRITE(ICOUT,8091)IBASLC,ITEMP 10195 CALL DPWRST(ICOUT,'WRIT') 10196C 10197 RETURN 10198 END 10199 SUBROUTINE DPRTF6(NHEAD) 10200C 10201C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING 10202C RTF OUTPUT. THIS ROUTINE IS USED TO CLOSE A 10203C TABLE (PRINT 2 BLANK LINES). 10204C INPUT ARGUMENTS--IHEAD = THE CHARACTER STRING CONTAINING 10205C THE TEXT FOR THE HEADER 10206C --NHEAD = THE INTEGER NUMBER THAT SPECIFIES 10207C THE NUMBER OF CHARACTERS IN THE 10208C HEADER. 10209C --CAPTN = THE CHARACTER STRING CONTAINING 10210C THE CAPTION. 10211C --NCAP = THE INTEGER NUMBER THAT SPECIFIES 10212C THE NUMBER OF CHARACTERS IN THE 10213C CAPTION. 10214C WRITTEN BY--ALAN HECKERT 10215C STATISTICAL ENGINEERING DIVISION 10216C INFORMATION TECHNOLOGY LABOARATORY 10217C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10218C GAITHERSBURG, MD 20899-8980 10219C PHONE--301-975-2899 10220C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 10221C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 10222C LANGUAGE--ANSI FORTRAN (1977) 10223C VERSION NUMBER--2005/2 10224C ORIGINAL VERSION--FEBRUARY 2005. 10225C 10226C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10227C 10228 CHARACTER*1 IBASLC 10229C 10230C-----COMMON---------------------------------------------------------- 10231C 10232 INCLUDE 'DPCOBE.INC' 10233 INCLUDE 'DPCOST.INC' 10234 INCLUDE 'DPCOP2.INC' 10235C 10236C-----START POINT----------------------------------------------------- 10237C 10238C STEP 1: WRITE SOME LINE BREAKS 10239C 10240 IF(ISUBG4.EQ.'RTF6')THEN 10241 WRITE(ICOUT,52)NHEAD 10242 52 FORMAT('NHEAD = ',I8) 10243 CALL DPWRST('XXX','BUG ') 10244 ENDIF 10245C 10246 CALL DPCONA(92,IBASLC) 10247 8009 FORMAT(A1,'line ',A1,'line') 10248 WRITE(ICOUT,8009)IBASLC,IBASLC 10249 CALL DPWRST('XXX','WRIT') 10250C 10251 RETURN 10252 END 10253 SUBROUTINE DPRTF7(IHEAD,NHEAD,AVAL,NUMDIG) 10254C 10255C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING 10256C RTF OUTPUT. THIS ROUTINE IS USED TO WRITE A 10257C A SINGLE LINE OF OUTPUT. 10258C INPUT ARGUMENTS--IHEAD = THE CHARACTER STRING CONTAINING 10259C THE TEXT FOR THE LINE 10260C --NHEAD = THE INTEGER NUMBER THAT SPECIFIES 10261C THE NUMBER OF CHARACTERS IN THE 10262C LINE. 10263C WRITTEN BY--ALAN HECKERT 10264C STATISTICAL ENGINEERING DIVISION 10265C INFORMATION TECHNOLOGY LABOARATORY 10266C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10267C GAITHERSBURG, MD 20899-8980 10268C PHONE--301-975-2899 10269C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 10270C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 10271C LANGUAGE--ANSI FORTRAN (1977) 10272C VERSION NUMBER--2005/2 10273C ORIGINAL VERSION--FEBRUARY 2005. 10274C 10275C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10276C 10277 CHARACTER*(*) IHEAD 10278C 10279 CHARACTER*1 IBASLC 10280 CHARACTER*25 IFORMT 10281C 10282C--------------------------------------------------------------------- 10283C 10284 INCLUDE 'DPCOP2.INC' 10285C 10286C-----START POINT----------------------------------------------------- 10287C 10288C STEP 1: END ASIS MODE AND WRITE A HEADER 10289C 10290 CALL DPCONA(92,IBASLC) 10291 IFORMT=' ' 10292 ICOUT=' ' 10293C 10294C STEP 2: START TABLE AND DEFINE A CAPTION 10295C 10296 8005 FORMAT('{',A1,'ql ') 10297 8007 FORMAT(A1,'line') 10298C 10299 IF(NHEAD.GE.1)THEN 10300 IF(AVAL.NE.CPUMIN)THEN 10301 IF(NUMDIG.GT.0)THEN 10302 AVALT=RND(AVAL,NUMDIG) 10303 IXX=NUMDIG 10304 IYY=IXX+8 10305 IFORMT(1:21)='(A ,2X,F . ,2X,A1)' 10306 WRITE(IFORMT(3:4),'(I2)')NHEAD 10307 WRITE(IFORMT(10:11),'(I2)')IYY 10308 WRITE(IFORMT(13:14),'(I2)')IXX 10309 WRITE(ICOUT,8005)IBASLC 10310 CALL DPWRST('XXX','WRIT') 10311 WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD),AVALT,'}' 10312 CALL DPWRST('XXX','WRIT') 10313 ELSEIF(NUMDIG.LT.0)THEN 10314 NUMDI2=-NUMDIG 10315 AVALT=RND(AVAL,NUMDI2) 10316 IXX=-NUMDIG 10317 IYY=IXX+8 10318 IFORMT(1:21)='(A ,2X,E . ,2X,A1)' 10319 WRITE(IFORMT(3:4),'(I2)')NHEAD 10320 WRITE(IFORMT(10:11),'(I2)')IYY 10321 WRITE(IFORMT(13:14),'(I2)')IXX 10322 WRITE(ICOUT,8005)IBASLC 10323 CALL DPWRST('XXX','WRIT') 10324 WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD),AVALT,'}' 10325 CALL DPWRST('XXX','WRIT') 10326 ELSEIF(NUMDIG.EQ.0)THEN 10327 IF(AVAL.GE.0.0)THEN 10328 IVALT=INT(AVAL + 0.5) 10329 ELSE 10330 IVALT=INT(AVAL - 0.5) 10331 ENDIF 10332 IFORMT(1:18)='(A ,2X,I10,A1)' 10333 WRITE(IFORMT(3:4),'(I2)')NHEAD 10334 WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD),IVALT,'{' 10335 CALL DPWRST('XXX','WRIT') 10336 ENDIF 10337 ELSE 10338 IFORMT(1:11)='(A ,2X,A1)' 10339 WRITE(IFORMT(3:4),'(I2)')NHEAD 10340 WRITE(ICOUT,8005)IBASLC 10341 CALL DPWRST('XXX','WRIT') 10342 WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD),'}' 10343 CALL DPWRST('XXX','WRIT') 10344 ENDIF 10345 WRITE(ICOUT,8007)IBASLC 10346 CALL DPWRST('XXX','WRIT') 10347 ENDIF 10348C 10349 RETURN 10350 END 10351 SUBROUTINE DPRTF8(IHEAD,NHEAD,ITEMP,IFLAG1) 10352C 10353C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING 10354C RTF OUTPUT. THIS ROUTINE IS USED TO INITIATE 10355C THE RTF OUTPUT AND GENERATE AN OVERALL TITLE. 10356C INPUT ARGUMENTS--IHEAD = THE CHARACTER STRING CONTAINING 10357C THE TEXT FOR THE HEADER 10358C --NHEAD = THE INTEGER NUMBER THAT SPECIFIES 10359C THE NUMBER OF CHARACTERS IN THE 10360C HEADER. 10361C WRITTEN BY--ALAN HECKERT 10362C STATISTICAL ENGINEERING DIVISION 10363C INFORMATION TECHNOLOGY LABOARATORY 10364C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10365C GAITHERSBURG, MD 20899-8980 10366C PHONE--301-975-2899 10367C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 10368C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 10369C LANGUAGE--ANSI FORTRAN (1977) 10370C VERSION NUMBER--2005/2 10371C ORIGINAL VERSION--FEBRUARY 2005. 10372C 10373C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10374C 10375 LOGICAL IFLAG1 10376C 10377 CHARACTER*(*) IHEAD 10378C 10379 CHARACTER*1 IBASLC 10380 CHARACTER*1 IQUOTE 10381 CHARACTER*40 IFORMT 10382C 10383C--------------------------------------------------------------------- 10384C 10385 INCLUDE 'DPCOP2.INC' 10386C 10387C-----START POINT----------------------------------------------------- 10388C 10389C STEP 1: END ASIS MODE AND WRITE A HEADER 10390C 10391 CALL DPCONA(92,IBASLC) 10392 CALL DPCONA(39,IQUOTE) 10393C 10394 8001 FORMAT(A1,'par}') 10395 8003 FORMAT(A1,'pagebb') 10396 8004 FORMAT(A1,'f',I1) 10397 8014 FORMAT(A1,'f',I2) 10398 8005 FORMAT('{',A1,'pard') 10399 IF(IFLAG1)THEN 10400CCCCC WRITE(ICOUT,8001)IBASLC 10401CCCCC CALL DPWRST('XXX','WRIT') 10402 WRITE(ICOUT,8005)IBASLC 10403 CALL DPWRST('XXX','WRIT') 10404 WRITE(ICOUT,8003)IBASLC 10405 CALL DPWRST('XXX','WRIT') 10406 IF(ITEMP.LE.9)THEN 10407 WRITE(ICOUT,8004)IBASLC,ITEMP 10408 CALL DPWRST('XXX','WRIT') 10409 ELSE 10410 WRITE(ICOUT,8014)IBASLC,ITEMP 10411 CALL DPWRST('XXX','WRIT') 10412 ENDIF 10413CCCCC WRITE(ICOUT,8005)IBASLC 10414CCCCC CALL DPWRST('XXX','WRIT') 10415 ENDIF 10416C 10417 IF(NHEAD.GE.1)THEN 10418 IFORMT=' ' 10419 IFORMT='( { ,A1, qc ,A , } ,A1, line )' 10420 IFORMT(2:2)=IQUOTE 10421 IFORMT(4:4)=IQUOTE 10422 IFORMT(9:9)=IQUOTE 10423 IFORMT(13:13)=IQUOTE 10424 IFORMT(20:20)=IQUOTE 10425 IFORMT(23:23)=IQUOTE 10426 IFORMT(28:28)=IQUOTE 10427 IFORMT(33:33)=IQUOTE 10428 WRITE(IFORMT(16:18),'(I3)')NHEAD 10429 WRITE(ICOUT,IFORMT)IBASLC,IHEAD(1:NHEAD),IBASLC 10430 CALL DPWRST('XXX','WRIT') 10431 WRITE(ICOUT,8001)IBASLC 10432 CALL DPWRST('XXX','WRIT') 10433 ENDIF 10434C 10435 RETURN 10436 END 10437 SUBROUTINE DPRTF9(IVALUE,NCHAR,AVALUE,NHEAD,IFLAG1,IVAL2,NCHAR2) 10438C 10439C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING 10440C RTF OUTPUT. THIS ROUTINE IS USED TO GENERATE 10441C A DATA ROW FOR A TABLE. THE FIRST FIELD CAN BE 10442C A TEXT VALUE (FOR A ROW LABEL). IN ADDITION, THE 10443C LAST FIELD IS ALSO A CHARACTER FIELD. 10444C 10445C INPUT ARGUMENTS--IVALUE = THE CHARACTER STRING CONTAINING 10446C THE TEXT FOR THE FIRST COLUMN. 10447C --NCHAR = THE INTEGER ARRAY THAT SPECIFIES 10448C THE NUMBER OF CHARACTERS IN THE 10449C FIRST TEXT FIELD. 10450C --AVALUE = A REAL ARRAY CONTAINING THE DATA 10451C TO BE GENERATED. 10452C --NHEAD = THE INTEGER VALUE THAT SPECIFIES 10453C THE NUMBER OF NUMERIC VALUES. 10454C --IVAL2 = THE CHARACTER STRING CONTAINING 10455C THE TEXT FOR THE LAST COLUMN. 10456C --NCHAR2 = THE INTEGER ARRAY THAT SPECIFIES 10457C THE NUMBER OF CHARACTERS IN THE 10458C LAST TEXT FIELD. 10459C WRITTEN BY--ALAN HECKERT 10460C STATISTICAL ENGINEERING DIVISION 10461C INFORMATION TECHNOLOGY LABOARATORY 10462C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10463C GAITHERSBURG, MD 20899-8980 10464C PHONE--301-975-2899 10465C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 10466C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 10467C LANGUAGE--ANSI FORTRAN (1977) 10468C VERSION NUMBER--2006/11 10469C ORIGINAL VERSION--NOVEMBER 2006. 10470C 10471C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10472C 10473 CHARACTER*(*) IVALUE 10474 CHARACTER*(*) IVAL2 10475 REAL AVALUE(*) 10476 INTEGER NCHAR 10477 INTEGER NCHAR2 10478C 10479 PARAMETER (MAXHED=1024) 10480 INTEGER IWIDTH(MAXHED) 10481 INTEGER NUMDIG(MAXHED) 10482 CHARACTER*8 ALIGN(MAXHED) 10483 CHARACTER*8 VALIGN(MAXHED) 10484 COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN 10485C 10486 LOGICAL IFLAG1 10487C 10488 CHARACTER*1 IBASLC 10489 CHARACTER*20 IFORMT 10490C 10491C-----COMMON---------------------------------------------------------- 10492C 10493 INCLUDE 'DPCOST.INC' 10494 INCLUDE 'DPCOP2.INC' 10495C 10496C-----START POINT----------------------------------------------------- 10497C 10498 CALL DPCONA(92,IBASLC) 10499C 10500C STEP 1: GENERATE A HEADER LINE 10501C 10502 8001 FORMAT('{',A1,'trowd',A1,'trgraph90') 10503 WRITE(ICOUT,8001)IBASLC,IBASLC 10504 CALL DPWRST('XXX','WRIT') 10505C 10506 8011 FORMAT(A1,'clvertalt',A1,'cellx',I3) 10507 8012 FORMAT(A1,'clvertalc',A1,'cellx',I3) 10508 8013 FORMAT(A1,'clvertalb',A1,'cellx',I3) 10509 8111 FORMAT(A1,'clvertalt',A1,'cellx',I4) 10510 8112 FORMAT(A1,'clvertalc',A1,'cellx',I4) 10511 8113 FORMAT(A1,'clvertalb',A1,'cellx',I4) 10512 8211 FORMAT(A1,'clvertalt',A1,'cellx',I5) 10513 8212 FORMAT(A1,'clvertalc',A1,'cellx',I5) 10514 8213 FORMAT(A1,'clvertalb',A1,'cellx',I5) 10515C8014 FORMAT(A1,'clbrdrt',A1,'brdrw15',A1,'brdrs') 10516 8015 FORMAT(A1,'clbrdrb',A1,'brdrw15',A1,'brdrs') 10517 NCOLS=NHEAD 10518 IF(NCHAR.GT.0)NCOLS=NCOLS+1 10519 DO8010I=1,NCOLS+1 10520 IF(IFLAG1)THEN 10521 WRITE(ICOUT,8015)IBASLC,IBASLC,IBASLC 10522 CALL DPWRST('XXX','WRIT') 10523 ENDIF 10524 IF(VALIGN(I).EQ.'b')THEN 10525 IF(IWIDTH(I).LE.999)THEN 10526 WRITE(ICOUT,8013)IBASLC,IBASLC,IWIDTH(I) 10527 ELSEIF(IWIDTH(I).LE.9999)THEN 10528 WRITE(ICOUT,8113)IBASLC,IBASLC,IWIDTH(I) 10529 ELSE 10530 WRITE(ICOUT,8213)IBASLC,IBASLC,IWIDTH(I) 10531 ENDIF 10532 ELSEIF(VALIGN(I).EQ.'c')THEN 10533 IF(IWIDTH(I).LE.999)THEN 10534 WRITE(ICOUT,8012)IBASLC,IBASLC,IWIDTH(I) 10535 ELSEIF(IWIDTH(I).LE.9999)THEN 10536 WRITE(ICOUT,8112)IBASLC,IBASLC,IWIDTH(I) 10537 ELSE 10538 WRITE(ICOUT,8212)IBASLC,IBASLC,IWIDTH(I) 10539 ENDIF 10540 ELSE 10541 IF(IWIDTH(I).LE.999)THEN 10542 WRITE(ICOUT,8011)IBASLC,IBASLC,IWIDTH(I) 10543 ELSEIF(IWIDTH(I).LE.9999)THEN 10544 WRITE(ICOUT,8111)IBASLC,IBASLC,IWIDTH(I) 10545 ELSE 10546 WRITE(ICOUT,8211)IBASLC,IBASLC,IWIDTH(I) 10547 ENDIF 10548 ENDIF 10549 CALL DPWRST('XXX','WRIT') 10550 8010 CONTINUE 10551C 10552 8021 FORMAT(A1,'pard',A1,'intbl',A1,'ql {') 10553 8022 FORMAT(A1,'pard',A1,'intbl',A1,'qc {') 10554 8023 FORMAT(A1,'pard',A1,'intbl',A1,'qr {') 10555 IFORMT=' ' 10556 IFORMT(1:5)='(A )' 10557 8027 FORMAT('}',A1,'cell') 10558C 10559C PRINT ROW LABEL 10560C 10561 IF(NCHAR.GT.0)THEN 10562 IF(ALIGN(1).EQ.'l')THEN 10563 WRITE(ICOUT,8021)IBASLC,IBASLC,IBASLC 10564 ELSEIF(ALIGN(1).EQ.'c')THEN 10565 WRITE(ICOUT,8022)IBASLC,IBASLC,IBASLC 10566 ELSE 10567 WRITE(ICOUT,8023)IBASLC,IBASLC,IBASLC 10568 ENDIF 10569 CALL DPWRST('XXX','WRIT') 10570 WRITE(IFORMT(3:4),'(I2)')NCHAR 10571 WRITE(ICOUT,IFORMT)IVALUE(1:NCHAR) 10572 CALL DPWRST('XXX','WRIT') 10573 WRITE(ICOUT,8027)IBASLC 10574 CALL DPWRST('XXX','WRIT') 10575 IADD=1 10576 ELSE 10577 IADD=0 10578 ENDIF 10579C 10580C PRINT NUMERIC VALUES 10581C 10582 8091 FORMAT(a1,'f',I1) 10583 IF(IRTFFF.EQ.'Courier New')THEN 10584 ITEMP=1 10585 ELSEIF(IRTFFF.EQ.'Lucida Console')THEN 10586 ITEMP=8 10587 ENDIF 10588 WRITE(ICOUT,8091)IBASLC,ITEMP 10589 CALL DPWRST(ICOUT,'WRIT') 10590 8035 FORMAT(1X) 10591C8031 FORMAT(G15.7) 10592C8033 FORMAT(I12) 10593 DO8020I=1,NHEAD 10594 IF(ALIGN(I+IADD).EQ.'l')THEN 10595 WRITE(ICOUT,8021)IBASLC,IBASLC,IBASLC 10596 ELSEIF(ALIGN(I+IADD).EQ.'c')THEN 10597 WRITE(ICOUT,8022)IBASLC,IBASLC,IBASLC 10598 ELSE 10599 WRITE(ICOUT,8023)IBASLC,IBASLC,IBASLC 10600 ENDIF 10601 CALL DPWRST('XXX','WRIT') 10602C 10603 IFORMT=' ' 10604 NRIGHT=MIN(NUMDIG(I+IADD),9) 10605 IF(ABS(AVALUE(I+IADD)).LT.10.0)THEN 10606 NLEFT=1 10607 ELSEIF(ABS(AVALUE(I+IADD)).LT.100.0)THEN 10608 NLEFT=2 10609 ELSEIF(ABS(AVALUE(I+IADD)).LT.1000.0)THEN 10610 NLEFT=3 10611 ELSEIF(ABS(AVALUE(I+IADD)).LT.10000.0)THEN 10612 NLEFT=4 10613 ELSEIF(ABS(AVALUE(I+IADD)).LT.100000.0)THEN 10614 NLEFT=5 10615 ELSEIF(ABS(AVALUE(I+IADD)).LT.1000000.0)THEN 10616 NLEFT=6 10617 ELSE 10618 NLEFT=7 10619 ENDIF 10620 IF(AVALUE(I+IADD).LT.0.0)NLEFT=NLEFT+1 10621 NTOT=NRIGHT+NLEFT+2 10622 IF(NUMDIG(I+IADD).GT.0)THEN 10623 IFORMT(1:7)='(F . )' 10624 WRITE(IFORMT(3:4),'(I2)')NTOT 10625 WRITE(IFORMT(6:6),'(I1)')NRIGHT 10626 WRITE(ICOUT,IFORMT)AVALUE(I+IADD) 10627 CALL DPWRST('XXX','WRIT') 10628 ELSEIF(NUMDIG(I+IADD).EQ.0)THEN 10629 IFORMT(1:5)='(I )' 10630 WRITE(IFORMT(3:4),'(I2)')NLEFT 10631 IF(AVALUE(I+IADD).GE.0.0)THEN 10632 WRITE(ICOUT,IFORMT)INT(AVALUE(I+IADD)+0.5) 10633 ELSE 10634 WRITE(ICOUT,IFORMT)INT(AVALUE(I+IADD)-0.5) 10635 ENDIF 10636 CALL DPWRST('XXX','WRIT') 10637 ELSEIF(NUMDIG(I+IADD).EQ.-1)THEN 10638 WRITE(ICOUT,8035) 10639 CALL DPWRST('XXX','WRIT') 10640 ELSEIF(NUMDIG(I+IADD).EQ.-2)THEN 10641 IFORMT(1:7)='(G .7)' 10642 NTOT=12+NLEFT 10643 WRITE(IFORMT(3:4),'(I2)')NTOT 10644 WRITE(ICOUT,IFORMT)AVALUE(I+IADD) 10645 CALL DPWRST('XXX','WRIT') 10646 ELSE 10647 WRITE(ICOUT,'(A1)') ' ' 10648 CALL DPWRST('XXX','WRIT') 10649 ENDIF 10650C 10651 WRITE(ICOUT,8027)IBASLC 10652 CALL DPWRST('XXX','WRIT') 10653 8020 CONTINUE 10654C 10655C PRINT CHARACTER DATA IN LAST FIELD 10656C 10657 IF(NCHAR2.GT.0)THEN 10658 IFORMT=' ' 10659 IFORMT(1:5)='(A )' 10660 IF(ALIGN(NCOLS+1).EQ.'l')THEN 10661 WRITE(ICOUT,8021)IBASLC,IBASLC,IBASLC 10662 ELSEIF(ALIGN(NCOLS+1).EQ.'c')THEN 10663 WRITE(ICOUT,8022)IBASLC,IBASLC,IBASLC 10664 ELSE 10665 WRITE(ICOUT,8023)IBASLC,IBASLC,IBASLC 10666 ENDIF 10667 CALL DPWRST('XXX','WRIT') 10668 IFORMT(3:4)=' ' 10669 WRITE(IFORMT(3:4),'(I2)')NCHAR2 10670 WRITE(ICOUT,IFORMT)IVAL2(1:NCHAR2) 10671 CALL DPWRST('XXX','WRIT') 10672 WRITE(ICOUT,8027)IBASLC 10673 CALL DPWRST('XXX','WRIT') 10674 ENDIF 10675C 10676 8039 FORMAT(A1,'row}') 10677 WRITE(ICOUT,8039)IBASLC 10678 CALL DPWRST('XXX','WRIT') 10679C 10680 IF(IRTFFF.EQ.'Times New Roman')THEN 10681 ITEMP=0 10682 ELSEIF(IRTFFF.EQ.'Lucida Sans')THEN 10683 ITEMP=6 10684 ELSEIF(IRTFFF.EQ.'Arial')THEN 10685 ITEMP=2 10686 ELSEIF(IRTFFF.EQ.'Bookman')THEN 10687 ITEMP=3 10688 ELSEIF(IRTFFF.EQ.'Georgia')THEN 10689 ITEMP=4 10690 ELSEIF(IRTFFF.EQ.'Tahoma')THEN 10691 ITEMP=5 10692 ELSEIF(IRTFFF.EQ.'Verdana')THEN 10693 ITEMP=7 10694 ENDIF 10695 WRITE(ICOUT,8091)IBASLC,ITEMP 10696 CALL DPWRST(ICOUT,'WRIT') 10697C 10698 RETURN 10699 END 10700 SUBROUTINE DPRTFA(IVALUE,NCHAR,NHEAD,IFLAG1) 10701C 10702C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING 10703C RTF OUTPUT. THIS ROUTINE IS USED TO GENERATE 10704C A DATA ROW FOR A TABLE. FOR THIS ROUTINE, EACH 10705C OF THE FIELDS WILL BE GIVEN AS CHARACTER STRINGS. 10706C 10707C INPUT ARGUMENTS--IVALUE = THE CHARACTER STRING CONTAINING 10708C THE TEXT FOR THE FIRST COLUMN. 10709C --NCHAR = THE INTEGER ARRAY THAT SPECIFIES 10710C THE NUMBER OF CHARACTERS IN THE 10711C FIRST TEXT FIELD. 10712C --NHEAD = THE INTEGER VALUE THAT SPECIFIES 10713C THE NUMBER OF NUMERIC VALUES. 10714C WRITTEN BY--ALAN HECKERT 10715C STATISTICAL ENGINEERING DIVISION 10716C INFORMATION TECHNOLOGY LABOARATORY 10717C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10718C GAITHERSBURG, MD 20899-8980 10719C PHONE--301-975-2899 10720C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 10721C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 10722C LANGUAGE--ANSI FORTRAN (1977) 10723C VERSION NUMBER--2007/3 10724C ORIGINAL VERSION--MARCH 2007. 10725C 10726C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10727C 10728 CHARACTER*(*) IVALUE(*) 10729 INTEGER NCHAR(*) 10730C 10731 PARAMETER (MAXHED=1024) 10732 INTEGER IWIDTH(MAXHED) 10733 INTEGER NUMDIG(MAXHED) 10734 CHARACTER*8 ALIGN(MAXHED) 10735 CHARACTER*8 VALIGN(MAXHED) 10736 COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN 10737C 10738 LOGICAL IFLAG1 10739C 10740 CHARACTER*1 IBASLC 10741 CHARACTER*20 IFORMT 10742C 10743C-----COMMON---------------------------------------------------------- 10744C 10745 INCLUDE 'DPCOST.INC' 10746 INCLUDE 'DPCOP2.INC' 10747C 10748C-----START POINT----------------------------------------------------- 10749C 10750 CALL DPCONA(92,IBASLC) 10751C 10752C STEP 1: GENERATE A HEADER LINE 10753C 10754 8001 FORMAT('{',A1,'trowd',A1,'trgraph90') 10755 WRITE(ICOUT,8001)IBASLC,IBASLC 10756 CALL DPWRST('XXX','WRIT') 10757C 10758 8011 FORMAT(A1,'clvertalt',A1,'cellx',I3) 10759 8012 FORMAT(A1,'clvertalc',A1,'cellx',I3) 10760 8013 FORMAT(A1,'clvertalb',A1,'cellx',I3) 10761 8111 FORMAT(A1,'clvertalt',A1,'cellx',I4) 10762 8112 FORMAT(A1,'clvertalc',A1,'cellx',I4) 10763 8113 FORMAT(A1,'clvertalb',A1,'cellx',I4) 10764 8211 FORMAT(A1,'clvertalt',A1,'cellx',I5) 10765 8212 FORMAT(A1,'clvertalc',A1,'cellx',I5) 10766 8213 FORMAT(A1,'clvertalb',A1,'cellx',I5) 10767C8014 FORMAT(A1,'clbrdrt',A1,'brdrw15',A1,'brdrs') 10768 8015 FORMAT(A1,'clbrdrb',A1,'brdrw15',A1,'brdrs') 10769C 10770 NCOLS=NHEAD 10771 DO8010I=1,NCOLS 10772 IF(IFLAG1)THEN 10773 WRITE(ICOUT,8015)IBASLC,IBASLC,IBASLC 10774 CALL DPWRST('XXX','WRIT') 10775 ENDIF 10776 IF(VALIGN(I).EQ.'b')THEN 10777 IF(IWIDTH(I).LE.999)THEN 10778 WRITE(ICOUT,8013)IBASLC,IBASLC,IWIDTH(I) 10779 ELSEIF(IWIDTH(I).LE.9999)THEN 10780 WRITE(ICOUT,8113)IBASLC,IBASLC,IWIDTH(I) 10781 ELSE 10782 WRITE(ICOUT,8213)IBASLC,IBASLC,IWIDTH(I) 10783 ENDIF 10784 ELSEIF(VALIGN(I).EQ.'c')THEN 10785 IF(IWIDTH(I).LE.999)THEN 10786 WRITE(ICOUT,8012)IBASLC,IBASLC,IWIDTH(I) 10787 ELSEIF(IWIDTH(I).LE.9999)THEN 10788 WRITE(ICOUT,8112)IBASLC,IBASLC,IWIDTH(I) 10789 ELSE 10790 WRITE(ICOUT,8212)IBASLC,IBASLC,IWIDTH(I) 10791 ENDIF 10792 ELSE 10793 IF(IWIDTH(I).LE.999)THEN 10794 WRITE(ICOUT,8011)IBASLC,IBASLC,IWIDTH(I) 10795 ELSEIF(IWIDTH(I).LE.9999)THEN 10796 WRITE(ICOUT,8111)IBASLC,IBASLC,IWIDTH(I) 10797 ELSE 10798 WRITE(ICOUT,8211)IBASLC,IBASLC,IWIDTH(I) 10799 ENDIF 10800 ENDIF 10801 CALL DPWRST('XXX','WRIT') 10802 8010 CONTINUE 10803C 10804 8021 FORMAT(A1,'pard',A1,'intbl',A1,'ql {') 10805 8022 FORMAT(A1,'pard',A1,'intbl',A1,'qc {') 10806 8023 FORMAT(A1,'pard',A1,'intbl',A1,'qr {') 10807 IFORMT=' ' 10808 IFORMT(1:5)='(A )' 10809 8027 FORMAT('}',A1,'cell') 10810C 10811C PRINT ROW LABEL 10812C 10813 IF(IRTFFF.EQ.'Courier New')THEN 10814 ITEMP=1 10815 ELSEIF(IRTFFF.EQ.'Lucida Console')THEN 10816 ITEMP=8 10817 ENDIF 10818 WRITE(ICOUT,8091)IBASLC,ITEMP 10819 CALL DPWRST(ICOUT,'WRIT') 10820C 10821 DO8020I=1,NHEAD 10822 IF(NCHAR(I).GT.0)THEN 10823 IF(ALIGN(I).EQ.'l')THEN 10824 WRITE(ICOUT,8021)IBASLC,IBASLC,IBASLC 10825 ELSEIF(ALIGN(I).EQ.'c')THEN 10826 WRITE(ICOUT,8022)IBASLC,IBASLC,IBASLC 10827 ELSE 10828 WRITE(ICOUT,8023)IBASLC,IBASLC,IBASLC 10829 ENDIF 10830 CALL DPWRST('XXX','WRIT') 10831 WRITE(IFORMT(3:4),'(I2)')NCHAR(I) 10832 WRITE(ICOUT,IFORMT)IVALUE(I)(1:NCHAR(I)) 10833 CALL DPWRST('XXX','WRIT') 10834 WRITE(ICOUT,8027)IBASLC 10835 CALL DPWRST('XXX','WRIT') 10836 ENDIF 10837 8020 CONTINUE 10838C 10839 8039 FORMAT(A1,'row}') 10840 WRITE(ICOUT,8039)IBASLC 10841 CALL DPWRST('XXX','WRIT') 10842C 10843 IF(IRTFFF.EQ.'Times New Roman')THEN 10844 ITEMP=0 10845 ELSEIF(IRTFFF.EQ.'Lucida Sans')THEN 10846 ITEMP=6 10847 ELSEIF(IRTFFF.EQ.'Arial')THEN 10848 ITEMP=2 10849 ELSEIF(IRTFFF.EQ.'Bookman')THEN 10850 ITEMP=3 10851 ELSEIF(IRTFFF.EQ.'Georgia')THEN 10852 ITEMP=4 10853 ELSEIF(IRTFFF.EQ.'Tahoma')THEN 10854 ITEMP=5 10855 ELSEIF(IRTFFF.EQ.'Verdana')THEN 10856 ITEMP=7 10857 ENDIF 10858 8091 FORMAT(a1,'f',I1) 10859 WRITE(ICOUT,8091)IBASLC,ITEMP 10860 CALL DPWRST(ICOUT,'WRIT') 10861C 10862 RETURN 10863 END 10864 SUBROUTINE DPRTFX(IVALUE,NCHAR,AVALUE,NHEAD,ITYPE,IFLAGA,IFLAGB) 10865C 10866C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING 10867C RTF OUTPUT. THIS ROUTINE IS USED TO GENERATE 10868C A DATA ROW FOR A TABLE. IT IS SIMILAR TO DPRTF5, 10869C BUT IT ALLOWS CHARACTER AND NUMERIC FIELDS TO BE 10870C MIXED. 10871C 10872C INPUT ARGUMENTS--IVALUE = THE ARRAY OF CHARACTER STRINGS CONTAINING 10873C THE TEXT FOR THE CHARACTER FIELDS. 10874C --NCHAR = THE INTEGER ARRAY THAT SPECIFIES 10875C THE NUMBER OF CHARACTERS IN THE 10876C TEXT FIELDS. 10877C --AVALUE = A REAL ARRAY CONTAINING THE DATA 10878C FOR THE NUMERIC FIELDS. 10879C --NHEAD = THE INTEGER VALUE THAT SPECIFIES 10880C THE NUMBER OF COMBINED NUMERIC AND 10881C TEXT FIELDS. 10882C --IFLAGA = A LOGICIAL VARIABLE THAT SPECIFIES 10883C WHETHER A LINE IS DRAWN BEFORE THE ROW. 10884C --IFLAGB = A LOGICIAL VARIABLE THAT SPECIFIES 10885C WHETHER A LINE IS DRAWN AFTER THE ROW. 10886C WRITTEN BY--ALAN HECKERT 10887C STATISTICAL ENGINEERING DIVISION 10888C INFORMATION TECHNOLOGY LABOARATORY 10889C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10890C GAITHERSBURG, MD 20899-8980 10891C PHONE--301-975-2899 10892C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 10893C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 10894C LANGUAGE--ANSI FORTRAN (1977) 10895C VERSION NUMBER--2008/10 10896C ORIGINAL VERSION--OCTOBER 2008. 10897C 10898C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10899C 10900 CHARACTER*(*) IVALUE(*) 10901 CHARACTER*4 ITYPE(*) 10902 REAL AVALUE(*) 10903 INTEGER NCHAR(*) 10904C 10905 PARAMETER (MAXHED=1024) 10906 INTEGER IWIDTH(MAXHED) 10907 INTEGER NUMDIG(MAXHED) 10908 CHARACTER*8 ALIGN(MAXHED) 10909 CHARACTER*8 VALIGN(MAXHED) 10910 COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN 10911C 10912 LOGICAL IFLAGA 10913 LOGICAL IFLAGB 10914C 10915 CHARACTER*1 IBASLC 10916 CHARACTER*20 IFORMT 10917C 10918C-----COMMON---------------------------------------------------------- 10919C 10920 INCLUDE 'DPCOST.INC' 10921 INCLUDE 'DPCOP2.INC' 10922C 10923C-----START POINT----------------------------------------------------- 10924C 10925 CALL DPCONA(92,IBASLC) 10926C 10927C STEP 1: GENERATE A HEADER LINE 10928C 10929 8001 FORMAT('{',A1,'trowd',A1,'trgraph90') 10930 WRITE(ICOUT,8001)IBASLC,IBASLC 10931 CALL DPWRST('XXX','WRIT') 10932C 10933 8011 FORMAT(A1,'clvertalt',A1,'cellx',I3) 10934 8012 FORMAT(A1,'clvertalc',A1,'cellx',I3) 10935 8013 FORMAT(A1,'clvertalb',A1,'cellx',I3) 10936 8111 FORMAT(A1,'clvertalt',A1,'cellx',I4) 10937 8112 FORMAT(A1,'clvertalc',A1,'cellx',I4) 10938 8113 FORMAT(A1,'clvertalb',A1,'cellx',I4) 10939 8211 FORMAT(A1,'clvertalt',A1,'cellx',I5) 10940 8212 FORMAT(A1,'clvertalc',A1,'cellx',I5) 10941 8213 FORMAT(A1,'clvertalb',A1,'cellx',I5) 10942 8014 FORMAT(A1,'clbrdrt',A1,'brdrw15',A1,'brdrs') 10943 8015 FORMAT(A1,'clbrdrb',A1,'brdrw15',A1,'brdrs') 10944C 10945 NCOLS=NHEAD 10946C 10947 DO8010I=1,NCOLS 10948 IF(IFLAGB)THEN 10949 WRITE(ICOUT,8014)IBASLC,IBASLC,IBASLC 10950 CALL DPWRST('XXX','WRIT') 10951 ENDIF 10952 IF(IFLAGA)THEN 10953 WRITE(ICOUT,8015)IBASLC,IBASLC,IBASLC 10954 CALL DPWRST('XXX','WRIT') 10955 ENDIF 10956 IF(VALIGN(I).EQ.'b')THEN 10957 IF(IWIDTH(I).LE.999)THEN 10958 WRITE(ICOUT,8013)IBASLC,IBASLC,IWIDTH(I) 10959 ELSEIF(IWIDTH(I).LE.9999)THEN 10960 WRITE(ICOUT,8113)IBASLC,IBASLC,IWIDTH(I) 10961 ELSE 10962 WRITE(ICOUT,8213)IBASLC,IBASLC,IWIDTH(I) 10963 ENDIF 10964 ELSEIF(VALIGN(I).EQ.'c')THEN 10965 IF(IWIDTH(I).LE.999)THEN 10966 WRITE(ICOUT,8012)IBASLC,IBASLC,IWIDTH(I) 10967 ELSEIF(IWIDTH(I).LE.9999)THEN 10968 WRITE(ICOUT,8112)IBASLC,IBASLC,IWIDTH(I) 10969 ELSE 10970 WRITE(ICOUT,8212)IBASLC,IBASLC,IWIDTH(I) 10971 ENDIF 10972 ELSE 10973 IF(IWIDTH(I).LE.999)THEN 10974 WRITE(ICOUT,8011)IBASLC,IBASLC,IWIDTH(I) 10975 ELSEIF(IWIDTH(I).LE.9999)THEN 10976 WRITE(ICOUT,8111)IBASLC,IBASLC,IWIDTH(I) 10977 ELSE 10978 WRITE(ICOUT,8211)IBASLC,IBASLC,IWIDTH(I) 10979 ENDIF 10980 ENDIF 10981 CALL DPWRST('XXX','WRIT') 10982 8010 CONTINUE 10983C 10984 8021 FORMAT(A1,'pard',A1,'intbl',A1,'ql {') 10985 8022 FORMAT(A1,'pard',A1,'intbl',A1,'qc {') 10986 8023 FORMAT(A1,'pard',A1,'intbl',A1,'qr {') 10987 8027 FORMAT('}',A1,'cell') 10988C 10989 8091 FORMAT(a1,'f',I1) 10990 8035 FORMAT(1X) 10991C8031 FORMAT(G15.7) 10992C8033 FORMAT(I12) 10993 8036 FORMAT(A2) 10994C 10995 ICNTA=0 10996 ICNTN=0 10997 DO8020I=1,NHEAD 10998C 10999 IF(ITYPE(I).EQ.'ALPH')THEN 11000C 11001C PRINT CHARACTER FIELD 11002C 11003 IFORMT=' ' 11004 IFORMT(1:5)='(A )' 11005 ICNTA=ICNTA+1 11006 IF(NCHAR(ICNTA).GT.0)THEN 11007 IF(ALIGN(I).EQ.'l')THEN 11008 WRITE(ICOUT,8021)IBASLC,IBASLC,IBASLC 11009 ELSEIF(ALIGN(I).EQ.'c')THEN 11010 WRITE(ICOUT,8022)IBASLC,IBASLC,IBASLC 11011 ELSE 11012 WRITE(ICOUT,8023)IBASLC,IBASLC,IBASLC 11013 ENDIF 11014 CALL DPWRST('XXX','WRIT') 11015 WRITE(IFORMT(3:4),'(I2)')NCHAR(ICNTA) 11016 WRITE(ICOUT,IFORMT)IVALUE(ICNTA)(1:NCHAR(ICNTA)) 11017 CALL DPWRST('XXX','WRIT') 11018 WRITE(ICOUT,8027)IBASLC 11019 CALL DPWRST('XXX','WRIT') 11020 ENDIF 11021 ELSE 11022C 11023C PRINT NUMERIC FIELD 11024C 11025 ICNTN=ICNTN+1 11026 IF(IRTFFF.EQ.'Courier New')THEN 11027 ITEMP=1 11028 ELSEIF(IRTFFF.EQ.'Lucida Console')THEN 11029 ITEMP=8 11030 ENDIF 11031 WRITE(ICOUT,8091)IBASLC,ITEMP 11032 CALL DPWRST(ICOUT,'WRIT') 11033C 11034 IF(ALIGN(I).EQ.'l')THEN 11035 WRITE(ICOUT,8021)IBASLC,IBASLC,IBASLC 11036 ELSEIF(ALIGN(I).EQ.'c')THEN 11037 WRITE(ICOUT,8022)IBASLC,IBASLC,IBASLC 11038 ELSE 11039 WRITE(ICOUT,8023)IBASLC,IBASLC,IBASLC 11040 ENDIF 11041 CALL DPWRST('XXX','WRIT') 11042C 11043 IFORMT=' ' 11044 NRIGHT=MIN(ABS(NUMDIG(I)),9) 11045 IF(ABS(AVALUE(ICNTN)).LT.10.0)THEN 11046 NLEFT=1 11047 ELSEIF(ABS(AVALUE(ICNTN)).LT.100.0)THEN 11048 NLEFT=2 11049 ELSEIF(ABS(AVALUE(ICNTN)).LT.1000.0)THEN 11050 NLEFT=3 11051 ELSEIF(ABS(AVALUE(ICNTN)).LT.10000.0)THEN 11052 NLEFT=4 11053 ELSEIF(ABS(AVALUE(ICNTN)).LT.100000.0)THEN 11054 NLEFT=5 11055 ELSEIF(ABS(AVALUE(ICNTN)).LT.1000000.0)THEN 11056 NLEFT=6 11057 ELSE 11058 NLEFT=7 11059 ENDIF 11060 NTOT=NRIGHT+NLEFT+2 11061 IF(NUMDIG(I).GT.0)THEN 11062 IFORMT(1:7)='(F . )' 11063 WRITE(IFORMT(3:4),'(I2)')NTOT 11064 WRITE(IFORMT(6:6),'(I1)')NRIGHT 11065 WRITE(ICOUT,IFORMT)AVALUE(ICNTN) 11066 CALL DPWRST('XXX','WRIT') 11067 ELSEIF(NUMDIG(I).EQ.0)THEN 11068 IFORMT(1:5)='(I )' 11069 WRITE(IFORMT(3:4),'(I2)')NLEFT 11070 IF(AVALUE(ICNTN).GE.0.0)THEN 11071 WRITE(ICOUT,IFORMT)INT(AVALUE(ICNTN)+0.5) 11072 ELSE 11073 WRITE(ICOUT,IFORMT)INT(AVALUE(ICNTN)-0.5) 11074 ENDIF 11075 CALL DPWRST('XXX','WRIT') 11076 ELSEIF(NUMDIG(I).EQ.-1)THEN 11077 WRITE(ICOUT,8035) 11078 CALL DPWRST('XXX','WRIT') 11079 ELSEIF(NUMDIG(I).EQ.-2)THEN 11080 IFORMT(1:7)='(G .7)' 11081 NTOT=12+NLEFT 11082 WRITE(IFORMT(3:4),'(I2)')NTOT 11083 WRITE(ICOUT,IFORMT)AVALUE(ICNTN) 11084 CALL DPWRST('XXX','WRIT') 11085 ELSEIF(NUMDIG(I).EQ.-99)THEN 11086 WRITE(ICOUT,8036)'**' 11087 CALL DPWRST('XXX','WRIT') 11088 ELSEIF(NUMDIG(I).LT.-2 .AND. NUMDIG(I).GT.-20)THEN 11089 IFORMT(1:7)='(E . )' 11090 WRITE(IFORMT(3:4),'(I2)')NTOT 11091 WRITE(IFORMT(6:6),'(I1)')NRIGHT 11092 WRITE(ICOUT,IFORMT)AVALUE(ICNTN) 11093 CALL DPWRST('XXX','WRIT') 11094 ELSE 11095 WRITE(ICOUT,'(A1)') ' ' 11096 ENDIF 11097C 11098 WRITE(ICOUT,8027)IBASLC 11099 CALL DPWRST('XXX','WRIT') 11100 ENDIF 11101 8020 CONTINUE 11102C 11103 8039 FORMAT(A1,'row}') 11104 WRITE(ICOUT,8039)IBASLC 11105 CALL DPWRST('XXX','WRIT') 11106C 11107 IF(IRTFFF.EQ.'Times New Roman')THEN 11108 ITEMP=0 11109 ELSEIF(IRTFFF.EQ.'Lucida Sans')THEN 11110 ITEMP=6 11111 ELSEIF(IRTFFF.EQ.'Arial')THEN 11112 ITEMP=2 11113 ELSEIF(IRTFFF.EQ.'Bookman')THEN 11114 ITEMP=3 11115 ELSEIF(IRTFFF.EQ.'Georgia')THEN 11116 ITEMP=4 11117 ELSEIF(IRTFFF.EQ.'Tahoma')THEN 11118 ITEMP=5 11119 ELSEIF(IRTFFF.EQ.'Verdana')THEN 11120 ITEMP=7 11121 ENDIF 11122 WRITE(ICOUT,8091)IBASLC,ITEMP 11123 CALL DPWRST(ICOUT,'WRIT') 11124C 11125 RETURN 11126 END 11127 SUBROUTINE DPRTFY(IVALUE,NCHAR,AVALUE,NHEAD,ITYPE,IFLAGA,IFLAGB) 11128C 11129C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING 11130C RTF OUTPUT. THIS ROUTINE IS USED TO GENERATE 11131C A DATA ROW FOR A TABLE. IT IS SIMILAR TO DPRTF5, 11132C BUT IT ALLOWS CHARACTER AND NUMERIC FIELDS TO BE 11133C MIXED. 11134C 11135C THIS IS A VARIATION OF DPRTFX. IT DIFFERS IN THE 11136C COUNTERS FOR THE NUMERIC AND ALPHANUMERIC FIELDS. 11137C 11138C INPUT ARGUMENTS--IVALUE = THE ARRAY OF CHARACTER STRINGS CONTAINING 11139C THE TEXT FOR THE CHARACTER FIELDS. 11140C --NCHAR = THE INTEGER ARRAY THAT SPECIFIES 11141C THE NUMBER OF CHARACTERS IN THE 11142C TEXT FIELDS. 11143C --AVALUE = A REAL ARRAY CONTAINING THE DATA 11144C FOR THE NUMERIC FIELDS. 11145C --NHEAD = THE INTEGER VALUE THAT SPECIFIES 11146C THE NUMBER OF COMBINED NUMERIC AND 11147C TEXT FIELDS. 11148C --IFLAGA = A LOGICIAL VARIABLE THAT SPECIFIES 11149C WHETHER A LINE IS DRAWN BEFORE THE ROW. 11150C --IFLAGB = A LOGICIAL VARIABLE THAT SPECIFIES 11151C WHETHER A LINE IS DRAWN AFTER THE ROW. 11152C WRITTEN BY--ALAN HECKERT 11153C STATISTICAL ENGINEERING DIVISION 11154C INFORMATION TECHNOLOGY LABOARATORY 11155C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11156C GAITHERSBURG, MD 20899-8980 11157C PHONE--301-975-2899 11158C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11159C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11160C LANGUAGE--ANSI FORTRAN (1977) 11161C VERSION NUMBER--2008/10 11162C ORIGINAL VERSION--OCTOBER 2008. 11163C 11164C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11165C 11166 CHARACTER*(*) IVALUE(*) 11167 CHARACTER*4 ITYPE(*) 11168 REAL AVALUE(*) 11169 INTEGER NCHAR(*) 11170C 11171 PARAMETER (MAXHED=1024) 11172 INTEGER IWIDTH(MAXHED) 11173 INTEGER NUMDIG(MAXHED) 11174 CHARACTER*8 ALIGN(MAXHED) 11175 CHARACTER*8 VALIGN(MAXHED) 11176 COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN 11177C 11178 LOGICAL IFLAGA 11179 LOGICAL IFLAGB 11180C 11181 CHARACTER*1 IBASLC 11182 CHARACTER*20 IFORMT 11183C 11184C-----COMMON---------------------------------------------------------- 11185C 11186 INCLUDE 'DPCOST.INC' 11187 INCLUDE 'DPCOP2.INC' 11188C 11189C-----START POINT----------------------------------------------------- 11190C 11191 CALL DPCONA(92,IBASLC) 11192C 11193C STEP 1: GENERATE A HEADER LINE 11194C 11195 8001 FORMAT('{',A1,'trowd',A1,'trgraph90') 11196 WRITE(ICOUT,8001)IBASLC,IBASLC 11197 CALL DPWRST('XXX','WRIT') 11198C 11199 8011 FORMAT(A1,'clvertalt',A1,'cellx',I3) 11200 8012 FORMAT(A1,'clvertalc',A1,'cellx',I3) 11201 8013 FORMAT(A1,'clvertalb',A1,'cellx',I3) 11202 8111 FORMAT(A1,'clvertalt',A1,'cellx',I4) 11203 8112 FORMAT(A1,'clvertalc',A1,'cellx',I4) 11204 8113 FORMAT(A1,'clvertalb',A1,'cellx',I4) 11205 8211 FORMAT(A1,'clvertalt',A1,'cellx',I5) 11206 8212 FORMAT(A1,'clvertalc',A1,'cellx',I5) 11207 8213 FORMAT(A1,'clvertalb',A1,'cellx',I5) 11208 8014 FORMAT(A1,'clbrdrt',A1,'brdrw15',A1,'brdrs') 11209 8015 FORMAT(A1,'clbrdrb',A1,'brdrw15',A1,'brdrs') 11210 8016 FORMAT(A1,'clbrdrr',A1,'brdrw15',A1,'brdrs') 11211C 11212 NCOLS=NHEAD 11213C 11214 DO8010I=1,NCOLS 11215 IF(IFLAGB)THEN 11216 WRITE(ICOUT,8014)IBASLC,IBASLC,IBASLC 11217 CALL DPWRST('XXX','WRIT') 11218 ENDIF 11219 IF(IFLAGA)THEN 11220 WRITE(ICOUT,8015)IBASLC,IBASLC,IBASLC 11221 CALL DPWRST('XXX','WRIT') 11222 ENDIF 11223C 11224 IF(IVALUE(I)(4:5).EQ.'7C')THEN 11225 CALL DPCOAN(IVALUE(I)(2:2),IJUNK1) 11226 CALL DPCOAN(IVALUE(I)(3:3),IJUNK2) 11227 IF(IJUNK1.EQ.92 .AND. IJUNK2.EQ.39)THEN 11228 WRITE(ICOUT,8016)IBASLC,IBASLC,IBASLC 11229 CALL DPWRST('XXX','WRIT') 11230 IVALUE(I)=' ' 11231 NCHAR(I)=0 11232 ENDIF 11233 ENDIF 11234C 11235 IF(VALIGN(I).EQ.'b')THEN 11236 IF(IWIDTH(I).LE.999)THEN 11237 WRITE(ICOUT,8013)IBASLC,IBASLC,IWIDTH(I) 11238 ELSEIF(IWIDTH(I).LE.9999)THEN 11239 WRITE(ICOUT,8113)IBASLC,IBASLC,IWIDTH(I) 11240 ELSE 11241 WRITE(ICOUT,8213)IBASLC,IBASLC,IWIDTH(I) 11242 ENDIF 11243 ELSEIF(VALIGN(I).EQ.'c')THEN 11244 IF(IWIDTH(I).LE.999)THEN 11245 WRITE(ICOUT,8012)IBASLC,IBASLC,IWIDTH(I) 11246 ELSEIF(IWIDTH(I).LE.9999)THEN 11247 WRITE(ICOUT,8112)IBASLC,IBASLC,IWIDTH(I) 11248 ELSE 11249 WRITE(ICOUT,8212)IBASLC,IBASLC,IWIDTH(I) 11250 ENDIF 11251 ELSE 11252 IF(IWIDTH(I).LE.999)THEN 11253 WRITE(ICOUT,8011)IBASLC,IBASLC,IWIDTH(I) 11254 ELSEIF(IWIDTH(I).LE.9999)THEN 11255 WRITE(ICOUT,8111)IBASLC,IBASLC,IWIDTH(I) 11256 ELSE 11257 WRITE(ICOUT,8211)IBASLC,IBASLC,IWIDTH(I) 11258 ENDIF 11259 ENDIF 11260 CALL DPWRST('XXX','WRIT') 11261 8010 CONTINUE 11262C 11263 8021 FORMAT(A1,'pard',A1,'intbl',A1,'ql {') 11264 8022 FORMAT(A1,'pard',A1,'intbl',A1,'qc {') 11265 8023 FORMAT(A1,'pard',A1,'intbl',A1,'qr {') 11266 8027 FORMAT('}',A1,'cell') 11267C 11268 8091 FORMAT(a1,'f',I1) 11269 8035 FORMAT(1X) 11270 8036 FORMAT(A2) 11271 8135 FORMAT(A1,'pard',A1,'intbl',A1,'ql { }',A1,'cell') 11272C8031 FORMAT(G15.7) 11273C8033 FORMAT(I12) 11274C 11275 ICNT=0 11276 DO8020I=1,NHEAD 11277C 11278 IF(ITYPE(I).EQ.'ALPH')THEN 11279C 11280C PRINT CHARACTER FIELD 11281C 11282 IFORMT=' ' 11283 IFORMT(1:5)='(A )' 11284 ICNT=ICNT+1 11285 IF(NCHAR(ICNT).GT.0)THEN 11286 IF(ALIGN(I).EQ.'l')THEN 11287 WRITE(ICOUT,8021)IBASLC,IBASLC,IBASLC 11288 ELSEIF(ALIGN(I).EQ.'c')THEN 11289 WRITE(ICOUT,8022)IBASLC,IBASLC,IBASLC 11290 ELSE 11291 WRITE(ICOUT,8023)IBASLC,IBASLC,IBASLC 11292 ENDIF 11293 CALL DPWRST('XXX','WRIT') 11294 WRITE(IFORMT(3:4),'(I2)')NCHAR(ICNT) 11295 WRITE(ICOUT,IFORMT)IVALUE(ICNT)(1:NCHAR(ICNT)) 11296 CALL DPWRST('XXX','WRIT') 11297 WRITE(ICOUT,8027)IBASLC 11298 CALL DPWRST('XXX','WRIT') 11299 ELSE 11300 WRITE(ICOUT,8135)IBASLC,IBASLC,IBASLC,IBASLC 11301 CALL DPWRST('XXX','WRIT') 11302 ENDIF 11303 ELSE 11304C 11305C PRINT NUMERIC FIELD 11306C 11307 ICNT=ICNT+1 11308 IF(IRTFFF.EQ.'Courier New')THEN 11309 ITEMP=1 11310 ELSEIF(IRTFFF.EQ.'Lucida Console')THEN 11311 ITEMP=8 11312 ENDIF 11313 WRITE(ICOUT,8091)IBASLC,ITEMP 11314 CALL DPWRST(ICOUT,'WRIT') 11315C 11316 IF(ALIGN(I).EQ.'l')THEN 11317 WRITE(ICOUT,8021)IBASLC,IBASLC,IBASLC 11318 ELSEIF(ALIGN(I).EQ.'c')THEN 11319 WRITE(ICOUT,8022)IBASLC,IBASLC,IBASLC 11320 ELSE 11321 WRITE(ICOUT,8023)IBASLC,IBASLC,IBASLC 11322 ENDIF 11323 CALL DPWRST('XXX','WRIT') 11324C 11325 IFORMT=' ' 11326 NRIGHT=MIN(ABS(NUMDIG(I)),9) 11327 IF(ABS(AVALUE(ICNT)).LT.10.0)THEN 11328 NLEFT=1 11329 ELSEIF(ABS(AVALUE(ICNT)).LT.100.0)THEN 11330 NLEFT=2 11331 ELSEIF(ABS(AVALUE(ICNT)).LT.1000.0)THEN 11332 NLEFT=3 11333 ELSEIF(ABS(AVALUE(ICNT)).LT.10000.0)THEN 11334 NLEFT=4 11335 ELSEIF(ABS(AVALUE(ICNT)).LT.100000.0)THEN 11336 NLEFT=5 11337 ELSEIF(ABS(AVALUE(ICNT)).LT.1000000.0)THEN 11338 NLEFT=6 11339 ELSE 11340 NLEFT=7 11341 ENDIF 11342 IF(AVALUE(ICNT).LT.0.0)NLEFT=NLEFT+1 11343 NTOT=NRIGHT+NLEFT+2 11344 IF(NUMDIG(I).GT.0)THEN 11345 IFORMT(1:7)='(F . )' 11346 WRITE(IFORMT(3:4),'(I2)')NTOT 11347 WRITE(IFORMT(6:6),'(I1)')NRIGHT 11348 WRITE(ICOUT,IFORMT)AVALUE(ICNT) 11349 CALL DPWRST('XXX','WRIT') 11350 ELSEIF(NUMDIG(I).EQ.0)THEN 11351 IFORMT(1:5)='(I )' 11352 WRITE(IFORMT(3:4),'(I2)')NLEFT 11353 IF(AVALUE(ICNT).GE.0.0)THEN 11354 WRITE(ICOUT,IFORMT)INT(AVALUE(ICNT)+0.5) 11355 ELSE 11356 WRITE(ICOUT,IFORMT)INT(AVALUE(ICNT)-0.5) 11357 ENDIF 11358 CALL DPWRST('XXX','WRIT') 11359 ELSEIF(NUMDIG(I).EQ.-1)THEN 11360 WRITE(ICOUT,8035) 11361 CALL DPWRST('XXX','WRIT') 11362 ELSEIF(NUMDIG(I).EQ.-2)THEN 11363 IFORMT(1:7)='(G .7)' 11364 NTOT=12+NLEFT 11365 WRITE(IFORMT(3:4),'(I2)')NTOT 11366 WRITE(ICOUT,IFORMT)AVALUE(ICNT) 11367 CALL DPWRST('XXX','WRIT') 11368 ELSEIF(NUMDIG(I).EQ.-99)THEN 11369 WRITE(ICOUT,8036)'**' 11370 CALL DPWRST('XXX','WRIT') 11371 ELSEIF(NUMDIG(I).LT.-2 .AND. NUMDIG(I).GT.-20)THEN 11372 IFORMT(1:7)='(E . )' 11373 WRITE(IFORMT(3:4),'(I2)')NTOT 11374 WRITE(IFORMT(6:6),'(I1)')NRIGHT 11375 WRITE(ICOUT,IFORMT)AVALUE(ICNT) 11376 CALL DPWRST('XXX','WRIT') 11377 ELSE 11378 WRITE(ICOUT,'(A1)') ' ' 11379 ENDIF 11380C 11381 WRITE(ICOUT,8027)IBASLC 11382 CALL DPWRST('XXX','WRIT') 11383 ENDIF 11384 8020 CONTINUE 11385C 11386 8039 FORMAT(A1,'row}') 11387 WRITE(ICOUT,8039)IBASLC 11388 CALL DPWRST('XXX','WRIT') 11389C 11390 IF(IRTFFF.EQ.'Times New Roman')THEN 11391 ITEMP=0 11392 ELSEIF(IRTFFF.EQ.'Lucida Sans')THEN 11393 ITEMP=6 11394 ELSEIF(IRTFFF.EQ.'Arial')THEN 11395 ITEMP=2 11396 ELSEIF(IRTFFF.EQ.'Bookman')THEN 11397 ITEMP=3 11398 ELSEIF(IRTFFF.EQ.'Georgia')THEN 11399 ITEMP=4 11400 ELSEIF(IRTFFF.EQ.'Tahoma')THEN 11401 ITEMP=5 11402 ELSEIF(IRTFFF.EQ.'Verdana')THEN 11403 ITEMP=7 11404 ENDIF 11405 WRITE(ICOUT,8091)IBASLC,ITEMP 11406 CALL DPWRST(ICOUT,'WRIT') 11407C 11408 RETURN 11409 END 11410 SUBROUTINE DPRTFZ(IHEAD,NHEAD,AVAL,NUMDIG) 11411C 11412C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING 11413C RTF OUTPUT. THIS ROUTINE IS USED TO WRITE A 11414C A SINGLE LINE OF OUTPUT. 11415C INPUT ARGUMENTS--IHEAD = THE CHARACTER STRING CONTAINING 11416C THE TEXT FOR THE LINE 11417C --NHEAD = THE INTEGER NUMBER THAT SPECIFIES 11418C THE NUMBER OF CHARACTERS IN THE 11419C LINE. 11420C WRITTEN BY--ALAN HECKERT 11421C STATISTICAL ENGINEERING DIVISION 11422C INFORMATION TECHNOLOGY LABOARATORY 11423C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11424C GAITHERSBURG, MD 20899-8980 11425C PHONE--301-975-2899 11426C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11427C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11428C LANGUAGE--ANSI FORTRAN (1977) 11429C VERSION NUMBER--2005/2 11430C ORIGINAL VERSION--FEBRUARY 2005. 11431C 11432C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11433C 11434 CHARACTER*(*) IHEAD 11435C 11436 CHARACTER*1 IBASLC 11437 CHARACTER*25 IFORMT 11438C 11439C-----COMMON---------------------------------------------------------- 11440C 11441 INCLUDE 'DPCOP2.INC' 11442C 11443C-----START POINT----------------------------------------------------- 11444C 11445C STEP 1: END ASIS MODE AND WRITE A HEADER 11446C 11447 CALL DPCONA(92,IBASLC) 11448C 11449C STEP 2: START TABLE AND DEFINE A CAPTION 11450C 11451 8005 FORMAT('{',A1,'ql ') 11452 8007 FORMAT(A1,'line') 11453C 11454 IF(NHEAD.GE.1)THEN 11455 IFORMT=' ' 11456 IF(AVAL.NE.CPUMIN)THEN 11457 IF(NUMDIG.GT.0)THEN 11458 AVALT=RND(AVAL,NUMDIG) 11459 IXX=NUMDIG 11460 IYY=IXX+8 11461 IFORMT(1:21)='(A ,2X,Gyy.xx,2X,A1)' 11462 WRITE(IFORMT(3:4),'(I2)')NHEAD 11463 WRITE(IFORMT(10:11),'(I2)')IYY 11464 WRITE(IFORMT(13:14),'(I2)')IXX 11465 WRITE(ICOUT,8005)IBASLC 11466 CALL DPWRST('XXX','WRIT') 11467 WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD),AVALT,'}' 11468 CALL DPWRST('XXX','WRIT') 11469 ELSEIF(NUMDIG.LT.0)THEN 11470 NUMDI2=-NUMDIG 11471 AVALT=RND(AVAL,NUMDI2) 11472 IXX=-NUMDIG 11473 IYY=IXX+8 11474 IFORMT(1:21)='(A ,2X,Eyy.xx,2X,A1)' 11475 WRITE(IFORMT(3:4),'(I2)')NHEAD 11476 WRITE(IFORMT(10:11),'(I2)')IYY 11477 WRITE(IFORMT(13:14),'(I2)')IXX 11478 WRITE(ICOUT,8005)IBASLC 11479 CALL DPWRST('XXX','WRIT') 11480 WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD),AVALT,'}' 11481 CALL DPWRST('XXX','WRIT') 11482 ELSEIF(NUMDIG.EQ.0)THEN 11483 IF(AVAL.GE.0.0)THEN 11484 IVALT=INT(AVAL + 0.5) 11485 ELSE 11486 IVALT=INT(AVAL - 0.5) 11487 ENDIF 11488 IFORMT(1:18)='(A ,2X,I10,2X,A1)' 11489 WRITE(IFORMT(3:4),'(I2)')NHEAD 11490 WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD),IVALT,'}' 11491 CALL DPWRST('XXX','WRIT') 11492 ENDIF 11493 ELSE 11494 IFORMT(1:11)='(A ,2X,A1)' 11495 WRITE(IFORMT(3:4),'(I2)')NHEAD 11496 WRITE(ICOUT,8005)IBASLC 11497 CALL DPWRST('XXX','WRIT') 11498 WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD),'}' 11499 CALL DPWRST('XXX','WRIT') 11500 ENDIF 11501 WRITE(ICOUT,8007)IBASLC 11502 CALL DPWRST('XXX','WRIT') 11503 ENDIF 11504C 11505 RETURN 11506 END 11507 SUBROUTINE DPRTIL(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11508 1IBUGD2,IFOUND,IERROR) 11509C 11510C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 11511C FOR ROMAN TRIPLEX ITALIC LOWER CASE. 11512C WRITTEN BY--JAMES J. FILLIBEN 11513C STATISTICAL ENGINEERING DIVISION 11514C INFORMATION TECHNOLOGY LABORATORY 11515C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11516C GAITHERSBURG, MD 20899 11517C PHONE--301-975-2855 11518C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11519C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11520C LANGUAGE--ANSI FORTRAN (1977) 11521C VERSION NUMBER--87/4 11522C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 11523C UPDATED --MAY 1982. 11524C UPDATED --MARCH 1987. 11525C 11526C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11527C 11528 CHARACTER*4 ICHAR2 11529 CHARACTER*4 IOP 11530 CHARACTER*4 IBUGD2 11531 CHARACTER*4 IFOUND 11532 CHARACTER*4 IERROR 11533C 11534C--------------------------------------------------------------------- 11535C 11536 DIMENSION IOP(*) 11537 DIMENSION X(*) 11538 DIMENSION Y(*) 11539C 11540C-----COMMON---------------------------------------------------------- 11541C 11542 INCLUDE 'DPCOP2.INC' 11543C 11544C-----START POINT----------------------------------------------------- 11545C 11546 IFOUND='NO' 11547 IERROR='NO' 11548C 11549 NUMCO=1 11550 ISTART=1 11551 ISTOP=1 11552 NC=1 11553C 11554C ****************************************** 11555C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 11556C ** HERSHEY CHARACTER SET CASE ** 11557C ****************************************** 11558C 11559C 11560 IF(IBUGD2.EQ.'OFF')GOTO90 11561 WRITE(ICOUT,999) 11562 999 FORMAT(1X) 11563 CALL DPWRST('XXX','BUG ') 11564 WRITE(ICOUT,51) 11565 51 FORMAT('***** AT THE BEGINNING OF DPRTIL--') 11566 CALL DPWRST('XXX','BUG ') 11567 WRITE(ICOUT,52)ICHAR2 11568 52 FORMAT('ICHAR2 = ',A4) 11569 CALL DPWRST('XXX','BUG ') 11570 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 11571 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11572 CALL DPWRST('XXX','BUG ') 11573 90 CONTINUE 11574C 11575C ************************************************** 11576C ** STEP 1-- ** 11577C ** SEARCH FOR THE INPUT CHARACTER(S). ** 11578C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** 11579C ************************************************** 11580C 11581 CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND) 11582 IF(IFOUND.EQ.'NO')GOTO9000 11583C 11584 IF(ICHARN.LE.7)GOTO1010 11585 GOTO1019 11586 1010 CONTINUE 11587 CALL DRTIL1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11588 1IBUGD2,IFOUND,IERROR) 11589 GOTO9000 11590 1019 CONTINUE 11591C 11592 IF(8.LE.ICHARN.AND.ICHARN.LE.15)GOTO1020 11593 GOTO1029 11594 1020 CONTINUE 11595 CALL DRTIL2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11596 1IBUGD2,IFOUND,IERROR) 11597 GOTO9000 11598 1029 CONTINUE 11599C 11600 IF(16.LE.ICHARN.AND.ICHARN.LE.23)GOTO1030 11601 GOTO1039 11602 1030 CONTINUE 11603 CALL DRTIL3(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11604 1IBUGD2,IFOUND,IERROR) 11605 GOTO9000 11606 1039 CONTINUE 11607C 11608 IF(ICHARN.GE.24)GOTO1040 11609 GOTO1049 11610 1040 CONTINUE 11611 CALL DRTIL4(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11612 1IBUGD2,IFOUND,IERROR) 11613 GOTO9000 11614 1049 CONTINUE 11615C 11616 IFOUND='NO' 11617 GOTO9000 11618C 11619C ***************** 11620C ** STEP 90-- ** 11621C ** EXIT ** 11622C ***************** 11623C 11624 9000 CONTINUE 11625 IF(IBUGD2.EQ.'OFF')GOTO9090 11626 WRITE(ICOUT,999) 11627 CALL DPWRST('XXX','BUG ') 11628 WRITE(ICOUT,9011) 11629 9011 FORMAT('***** AT THE END OF DPRTIL--') 11630 CALL DPWRST('XXX','BUG ') 11631 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 11632 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11633 CALL DPWRST('XXX','BUG ') 11634 WRITE(ICOUT,9013)ICHAR2,ICHARN 11635 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) 11636 CALL DPWRST('XXX','BUG ') 11637 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 11638 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 11639 CALL DPWRST('XXX','BUG ') 11640 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 11641 DO9015I=1,NUMCO 11642 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 11643 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 11644 CALL DPWRST('XXX','BUG ') 11645 9015 CONTINUE 11646 9019 CONTINUE 11647 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 11648 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 11649 CALL DPWRST('XXX','BUG ') 11650 9090 CONTINUE 11651C 11652 RETURN 11653 END 11654 SUBROUTINE DPRTIN(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11655 1IBUGD2,IFOUND,IERROR) 11656C 11657C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 11658C FOR ROMAN TRIPLEX ITALIC NUMERIC. 11659C WRITTEN BY--JAMES J. FILLIBEN 11660C STATISTICAL ENGINEERING DIVISION 11661C INFORMATION TECHNOLOGY LABORATORY 11662C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11663C GAITHERSBURG, MD 20899 11664C PHONE--301-975-2855 11665C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11666C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11667C LANGUAGE--ANSI FORTRAN (1977) 11668C VERSION NUMBER--87/4 11669C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 11670C UPDATED --MAY 1982. 11671C UPDATED --MARCH 1987. 11672C 11673C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11674C 11675 CHARACTER*4 ICHAR2 11676 CHARACTER*4 IOP 11677 CHARACTER*4 IBUGD2 11678 CHARACTER*4 IFOUND 11679 CHARACTER*4 IERROR 11680C 11681C--------------------------------------------------------------------- 11682C 11683 DIMENSION IOP(*) 11684 DIMENSION X(*) 11685 DIMENSION Y(*) 11686C 11687C-----COMMON---------------------------------------------------------- 11688C 11689 INCLUDE 'DPCOP2.INC' 11690C 11691C-----START POINT----------------------------------------------------- 11692C 11693 IFOUND='NO' 11694 IERROR='NO' 11695C 11696 NUMCO=1 11697 ISTART=1 11698 ISTOP=1 11699 NC=1 11700C 11701C ****************************************** 11702C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 11703C ** HERSHEY CHARACTER SET CASE ** 11704C ****************************************** 11705C 11706C 11707 IF(IBUGD2.EQ.'OFF')GOTO90 11708 WRITE(ICOUT,999) 11709 999 FORMAT(1X) 11710 CALL DPWRST('XXX','BUG ') 11711 WRITE(ICOUT,51) 11712 51 FORMAT('***** AT THE BEGINNING OF DPRTIN--') 11713 CALL DPWRST('XXX','BUG ') 11714 WRITE(ICOUT,52)ICHAR2 11715 52 FORMAT('ICHAR2 = ',A4) 11716 CALL DPWRST('XXX','BUG ') 11717 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 11718 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11719 CALL DPWRST('XXX','BUG ') 11720 90 CONTINUE 11721C 11722C ************************************************** 11723C ** STEP 1-- ** 11724C ** SEARCH FOR THE INPUT CHARACTER(S). ** 11725C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** 11726C ************************************************** 11727C 11728 CALL DPCHNU(ICHAR2,ICHARN,IBUGD2,IFOUND) 11729 IF(IFOUND.EQ.'NO')GOTO9000 11730C 11731 IF(ICHARN.LE.7)GOTO1010 11732 GOTO1019 11733 1010 CONTINUE 11734 CALL DRTIN1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11735 1IBUGD2,IFOUND,IERROR) 11736 GOTO9000 11737 1019 CONTINUE 11738C 11739 IF(ICHARN.GE.8)GOTO1020 11740 GOTO1029 11741 1020 CONTINUE 11742 CALL DRTIN2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11743 1IBUGD2,IFOUND,IERROR) 11744 GOTO9000 11745 1029 CONTINUE 11746C 11747 IFOUND='NO' 11748 GOTO9000 11749C 11750C ***************** 11751C ** STEP 90-- ** 11752C ** EXIT ** 11753C ***************** 11754C 11755 9000 CONTINUE 11756 IF(IBUGD2.EQ.'OFF')GOTO9090 11757 WRITE(ICOUT,999) 11758 CALL DPWRST('XXX','BUG ') 11759 WRITE(ICOUT,9011) 11760 9011 FORMAT('***** AT THE END OF DPRTIN--') 11761 CALL DPWRST('XXX','BUG ') 11762 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 11763 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11764 CALL DPWRST('XXX','BUG ') 11765 WRITE(ICOUT,9013)ICHAR2,ICHARN 11766 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) 11767 CALL DPWRST('XXX','BUG ') 11768 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 11769 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 11770 CALL DPWRST('XXX','BUG ') 11771 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 11772 DO9015I=1,NUMCO 11773 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 11774 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 11775 CALL DPWRST('XXX','BUG ') 11776 9015 CONTINUE 11777 9019 CONTINUE 11778 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 11779 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 11780 CALL DPWRST('XXX','BUG ') 11781 9090 CONTINUE 11782C 11783 RETURN 11784 END 11785 SUBROUTINE DPRTIU(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11786 1IBUGD2,IFOUND,IERROR) 11787C 11788C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 11789C FOR ROMAN TRIPLEX ITALIC UPPER CASE. 11790C WRITTEN BY--JAMES J. FILLIBEN 11791C STATISTICAL ENGINEERING DIVISION 11792C INFORMATION TECHNOLOGY LABORATORY 11793C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11794C GAITHERSBURG, MD 20899 11795C PHONE--301-975-2855 11796C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11797C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11798C LANGUAGE--ANSI FORTRAN (1977) 11799C VERSION NUMBER--87/4 11800C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 11801C UPDATED --MAY 1982. 11802C UPDATED --MARCH 1987. 11803C 11804C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11805C 11806 CHARACTER*4 ICHAR2 11807 CHARACTER*4 IOP 11808 CHARACTER*4 IBUGD2 11809 CHARACTER*4 IFOUND 11810 CHARACTER*4 IERROR 11811C 11812C--------------------------------------------------------------------- 11813C 11814 DIMENSION IOP(*) 11815 DIMENSION X(*) 11816 DIMENSION Y(*) 11817C 11818C-----COMMON---------------------------------------------------------- 11819C 11820 INCLUDE 'DPCOP2.INC' 11821C 11822C-----START POINT----------------------------------------------------- 11823C 11824 IFOUND='NO' 11825 IERROR='NO' 11826C 11827 NUMCO=1 11828 ISTART=1 11829 ISTOP=1 11830 NC=1 11831C 11832C ****************************************** 11833C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 11834C ** HERSHEY CHARACTER SET CASE ** 11835C ****************************************** 11836C 11837C 11838 IF(IBUGD2.EQ.'OFF')GOTO90 11839 WRITE(ICOUT,999) 11840 999 FORMAT(1X) 11841 CALL DPWRST('XXX','BUG ') 11842 WRITE(ICOUT,51) 11843 51 FORMAT('***** AT THE BEGINNING OF DPRTIU--') 11844 CALL DPWRST('XXX','BUG ') 11845 WRITE(ICOUT,52)ICHAR2 11846 52 FORMAT('ICHAR2 = ',A4) 11847 CALL DPWRST('XXX','BUG ') 11848 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 11849 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11850 CALL DPWRST('XXX','BUG ') 11851 90 CONTINUE 11852C 11853C ************************************************** 11854C ** STEP 1-- ** 11855C ** SEARCH FOR THE INPUT CHARACTER(S). ** 11856C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** 11857C ************************************************** 11858C 11859 CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND) 11860 IF(IFOUND.EQ.'NO')GOTO9000 11861C 11862 IF(ICHARN.LE.6)GOTO1010 11863 GOTO1019 11864 1010 CONTINUE 11865 CALL DRTIU1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11866 1IBUGD2,IFOUND,IERROR) 11867 GOTO9000 11868 1019 CONTINUE 11869C 11870 IF(7.LE.ICHARN.AND.ICHARN.LE.13)GOTO1020 11871 GOTO1029 11872 1020 CONTINUE 11873 CALL DRTIU2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11874 1IBUGD2,IFOUND,IERROR) 11875 GOTO9000 11876 1029 CONTINUE 11877C 11878 IF(14.LE.ICHARN.AND.ICHARN.LE.19)GOTO1030 11879 GOTO1039 11880 1030 CONTINUE 11881 CALL DRTIU3(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11882 1IBUGD2,IFOUND,IERROR) 11883 GOTO9000 11884 1039 CONTINUE 11885C 11886 IF(ICHARN.GE.20)GOTO1040 11887 GOTO1049 11888 1040 CONTINUE 11889 CALL DRTIU4(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11890 1IBUGD2,IFOUND,IERROR) 11891 GOTO9000 11892 1049 CONTINUE 11893C 11894 IFOUND='NO' 11895 GOTO9000 11896C 11897C 11898C ***************** 11899C ** STEP 90-- ** 11900C ** EXIT ** 11901C ***************** 11902C 11903 9000 CONTINUE 11904 IF(IBUGD2.EQ.'OFF')GOTO9090 11905 WRITE(ICOUT,999) 11906 CALL DPWRST('XXX','BUG ') 11907 WRITE(ICOUT,9011) 11908 9011 FORMAT('***** AT THE END OF DPRTIU--') 11909 CALL DPWRST('XXX','BUG ') 11910 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 11911 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11912 CALL DPWRST('XXX','BUG ') 11913 WRITE(ICOUT,9013)ICHAR2,ICHARN 11914 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) 11915 CALL DPWRST('XXX','BUG ') 11916 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 11917 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 11918 CALL DPWRST('XXX','BUG ') 11919 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 11920 DO9015I=1,NUMCO 11921 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 11922 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 11923 CALL DPWRST('XXX','BUG ') 11924 9015 CONTINUE 11925 9019 CONTINUE 11926 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 11927 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 11928 CALL DPWRST('XXX','BUG ') 11929 9090 CONTINUE 11930C 11931 RETURN 11932 END 11933