1 SUBROUTINE DPPROF(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 3C 4C PURPOSE--GENERATE A PROFILE PLOT-- 5C A MULTIVARIATE TECHNICQUE WHICH PLOTS A STANDARDIZED 6C (0 TO 1) VARIABLE VERSUS DUMMY VARIABLE NUMBER. 7C WRITTEN BY--JAMES J. FILLIBEN 8C STATISTICAL ENGINEERING DIVISION 9C INFORMATION TECHNOLOGY LABORATORY 10C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11C GAITHERSBURG, MD 20899-8980 12C PHONE--301-975-2855 13C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 14C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 15C LANGUAGE--ANSI FORTRAN (1977) 16C VERSION NUMBER--88/2 17C ORIGINAL VERSION--FEBRUARY 1988. 18C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON 19C UPDATED --MARCH 2011. USE DPPARS 20C 21C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 22C 23 CHARACTER*4 ICASPL 24 CHARACTER*4 IAND1 25 CHARACTER*4 IAND2 26 CHARACTER*4 IBUGG2 27 CHARACTER*4 IBUGG3 28 CHARACTER*4 IBUGQ 29 CHARACTER*4 ISUBRO 30 CHARACTER*4 IFOUND 31 CHARACTER*4 IERROR 32C 33 CHARACTER*4 IWRITE 34 CHARACTER*4 ISUBN1 35 CHARACTER*4 ISUBN2 36 CHARACTER*4 ISTEPN 37C 38 CHARACTER*40 INAME 39 PARAMETER (MAXSPN=50) 40 CHARACTER*4 IVARN1(MAXSPN) 41 CHARACTER*4 IVARN2(MAXSPN) 42 CHARACTER*4 IVARTY(MAXSPN) 43 REAL PVAR(MAXSPN) 44 INTEGER ILIS(MAXSPN) 45 INTEGER NRIGHT(MAXSPN) 46 INTEGER ICOLR(MAXSPN) 47C 48C--------------------------------------------------------------------- 49C 50 INCLUDE 'DPCOPA.INC' 51C 52 DIMENSION Z1(MAXOBV) 53 DIMENSION Z2(MAXOBV) 54 DIMENSION Z3(MAXOBV) 55 DIMENSION YSUB(MAXOBV) 56 DIMENSION YFULL(MAXOBV) 57 DIMENSION XTEMP(MAXOBV) 58CCCCC FOLLOWING LINES ADDED JUNE, 1990 59 INCLUDE 'DPCOZZ.INC' 60 EQUIVALENCE (GARBAG(IGARB1),Z1(1)) 61 EQUIVALENCE (GARBAG(IGARB2),Z2(1)) 62 EQUIVALENCE (GARBAG(IGARB3),Z3(1)) 63 EQUIVALENCE (GARBAG(IGARB4),YSUB(1)) 64 EQUIVALENCE (GARBAG(IGARB5),YFULL(1)) 65 EQUIVALENCE (GARBAG(IGARB6),XTEMP(1)) 66CCCCC END CHANGE 67C 68C-----COMMON---------------------------------------------------------- 69C 70 INCLUDE 'DPCOHK.INC' 71 INCLUDE 'DPCODA.INC' 72 INCLUDE 'DPCOP2.INC' 73C 74C-----START POINT----------------------------------------------------- 75C 76 IERROR='NO' 77 ISUBN1='DPPR' 78 ISUBN2='OF ' 79C 80 MAXCP1=MAXCOL+1 81 MAXCP2=MAXCOL+2 82 MAXCP3=MAXCOL+3 83 MAXCP4=MAXCOL+4 84 MAXCP5=MAXCOL+5 85 MAXCP6=MAXCOL+6 86C 87C *********************************** 88C ** TREAT THE PROFILE PLOT CASE ** 89C *********************************** 90C 91 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PROF')THEN 92 WRITE(ICOUT,999) 93 999 FORMAT(1X) 94 CALL DPWRST('XXX','BUG ') 95 WRITE(ICOUT,51) 96 51 FORMAT('***** AT THE BEGINNING OF DPPROF--') 97 CALL DPWRST('XXX','BUG ') 98 WRITE(ICOUT,52)IBUGG2,IBUGG3,IBUGQ,ISUBRO 99 52 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4) 100 CALL DPWRST('XXX','BUG ') 101 WRITE(ICOUT,53)ICASPL,IAND1,IAND2 102 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) 103 CALL DPWRST('XXX','BUG ') 104 ENDIF 105C 106C *************************** 107C ** STEP 1-- ** 108C ** EXTRACT THE COMMAND ** 109C *************************** 110C 111 ISTEPN='11' 112 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PROF') 113 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 114C 115 ICASPL='PROF' 116C 117 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')THEN 118 IFOUND='YES' 119 ILASTC=1 120 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 121 ELSE 122 IFOUND='NO' 123 GOTO9000 124 ENDIF 125C 126C **************************************** 127C ** STEP 2-- ** 128C ** EXTRACT THE VARIABLE LIST ** 129C **************************************** 130C 131 ISTEPN='2' 132 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PROF') 133 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 134C 135 INAME='PROFILE PLOT' 136 MINNA=1 137 MAXNA=100 138 MINN2=1 139 IFLAGE=1 140 IFLAGM=0 141 IFLAGP=0 142 JMIN=1 143 JMAX=NUMARG 144 MINNVA=1 145 MAXNVA=MAXSPN 146C 147 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 148 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 149 1 JMIN,JMAX, 150 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 151 1 IVARN1,IVARN2,IVARTY,PVAR, 152 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 153 1 MINNVA,MAXNVA, 154 1 IFLAGM,IFLAGP, 155 1 IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 156 IF(IERROR.EQ.'YES')GOTO9000 157C 158 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PROF')THEN 159 WRITE(ICOUT,999) 160 CALL DPWRST('XXX','BUG ') 161 WRITE(ICOUT,281) 162 281 FORMAT('***** AFTER CALL DPPARS--') 163 CALL DPWRST('XXX','BUG ') 164 WRITE(ICOUT,282)NQ,NUMVAR 165 282 FORMAT('NQ,NUMVAR = ',2I8) 166 CALL DPWRST('XXX','BUG ') 167 IF(NUMVAR.GT.0)THEN 168 DO285I=1,NUMVAR 169 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 170 1 ICOLR(I),IVARTY(I) 171 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 172 1 'ICOLR(I),IVARTY(I) = ',I8,2X,A4,A4,2X,3I8,2X,A4) 173 CALL DPWRST('XXX','BUG ') 174 285 CONTINUE 175 ENDIF 176 ENDIF 177C 178 IWRITE='OFF' 179 DO2200K=1,NUMVAR 180 JF=0 181 JS=0 182 IMAX=NRIGHT(K) 183 IF(NQ.LT.NRIGHT(1))IMAX=NQ 184 DO2210I=1,IMAX 185C 186C CREATE THE "FULL" VARIABLE 187C 188 JF=JF+1 189 IJ=MAXN*(ICOLR(K)-1)+I 190 IF(ICOLR(K).LE.MAXCOL)YFULL(JF)=V(IJ) 191 IF(ICOLR(K).EQ.MAXCP1)YFULL(JF)=PRED(I) 192 IF(ICOLR(K).EQ.MAXCP2)YFULL(JF)=RES(I) 193 IF(ICOLR(K).EQ.MAXCP3)YFULL(JF)=YPLOT(I) 194 IF(ICOLR(K).EQ.MAXCP4)YFULL(JF)=XPLOT(I) 195 IF(ICOLR(K).EQ.MAXCP5)YFULL(JF)=X2PLOT(I) 196 IF(ICOLR(K).EQ.MAXCP6)YFULL(JF)=TAGPLO(I) 197 2210 CONTINUE 198 NFULL=JF 199 CALL MINIM(YFULL,NFULL,IWRITE,XMIN,IBUGG3,IERROR) 200 CALL MAXIM(YFULL,NFULL,IWRITE,XMAX,IBUGG3,IERROR) 201 Z2(K)=XMIN 202 Z3(K)=XMAX 203C 204C CREATE THE "SUBSET" VARIABLE 205C 206 DO2240I=1,IMAX 207 IF(ISUB(I).EQ.0)GOTO2240 208 JS=JS+1 209 IJ=MAXN*(ICOLR(K)-1)+I 210C 211 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PROF')THEN 212 WRITE(ICOUT,2241)I,JS,MAXN,ICOLR(I),IJ,NRIGHT(I),NQ,IMAX 213 2241 FORMAT('I,JS,MAXN,ICOLR(I),IJ,NRIGHT(I),NQ,IMAX = ',8I8) 214 CALL DPWRST('XXX','BUG ') 215 ENDIF 216C 217 IF(ICOLR(K).LE.MAXCOL)YSUB(JS)=V(IJ) 218 IF(ICOLR(K).EQ.MAXCP1)YSUB(JS)=PRED(I) 219 IF(ICOLR(K).EQ.MAXCP2)YSUB(JS)=RES(I) 220 IF(ICOLR(K).EQ.MAXCP3)YSUB(JS)=YPLOT(I) 221 IF(ICOLR(K).EQ.MAXCP4)YSUB(JS)=XPLOT(I) 222 IF(ICOLR(K).EQ.MAXCP5)YSUB(JS)=X2PLOT(I) 223 IF(ICOLR(K).EQ.MAXCP6)YSUB(JS)=TAGPLO(I) 224C 225 2240 CONTINUE 226 NSUB=JS 227C 228 CALL MEDIAN(YSUB,NSUB,IWRITE,XTEMP,MAXN,XMED,IBUGG3,IERROR) 229 Z1(K)=XMED 230C 231 2200 CONTINUE 232 NZ=NUMVAR 233C 234C ******************************************************** 235C ** STEP 31-- ** 236C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** 237C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** 238C ** DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S ** 239C ** FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE LINE, ** 240C ** AND THE UPPER CONFIDENCE LINE. ** 241C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** 242C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** 243C ******************************************************** 244C 245 ISTEPN='8' 246 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PROF') 247 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 248C 249 CALL DPPRO2(Z1,Z2,Z3,NZ,ICASPL, 250 1 Y,X,D,NPLOTP,NPLOTV, 251 1 IBUGG3,ISUBRO,IERROR) 252C 253C ***************** 254C ** STEP 90-- ** 255C ** EXIT ** 256C ***************** 257C 258 9000 CONTINUE 259 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PROF')THEN 260 WRITE(ICOUT,999) 261 CALL DPWRST('XXX','BUG ') 262 WRITE(ICOUT,9011) 263 9011 FORMAT('***** AT THE END OF DPPROF--') 264 CALL DPWRST('XXX','BUG ') 265 WRITE(ICOUT,9013)IFOUND,IERROR 266 9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 267 CALL DPWRST('XXX','BUG ') 268 WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 269 9014 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 270 1 I8,I8,I8,2X,A4,2X,A4,2X,A4) 271 CALL DPWRST('XXX','BUG ') 272 WRITE(ICOUT,9021)NSUB,NFULL,NZ,NPLOTP 273 9021 FORMAT('NSUB,NFULL,NZ,NPLOTP = ',4I8) 274 CALL DPWRST('XXX','BUG ') 275 IF(NSUB.GT.0)THEN 276 DO9022I=1,NSUB 277 WRITE(ICOUT,9023)I,YSUB(I) 278 9023 FORMAT('I,YSUB(I) = ',I8,E15.7) 279 CALL DPWRST('XXX','BUG ') 280 9022 CONTINUE 281 ENDIF 282 IF(NFULL.GT.0)THEN 283 DO9032I=1,NFULL 284 WRITE(ICOUT,9033)I,YFULL(I) 285 9033 FORMAT('I,YFULL(I) = ',I8,E15.7) 286 CALL DPWRST('XXX','BUG ') 287 9032 CONTINUE 288 ENDIF 289 IF(NZ.GT.0)THEN 290 DO9042I=1,NZ 291 WRITE(ICOUT,9043)I,Z1(I),Z2(I),Z3(I) 292 9043 FORMAT('I,Z1(I),Z2(I),Z3(I) = ',I8,3G15.7) 293 CALL DPWRST('XXX','BUG ') 294 9042 CONTINUE 295 ENDIF 296 IF(NPLOTP.GT.0)THEN 297 DO9052I=1,NPLOTP 298 WRITE(ICOUT,9053)I,Y(I),X(I),D(I) 299 9053 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) 300 CALL DPWRST('XXX','BUG ') 301 9052 CONTINUE 302 ENDIF 303 ENDIF 304C 305 RETURN 306 END 307 SUBROUTINE DPPROJ(ICOM,IHARG,NUMARG,I3DPRO, 308 1IFOUND,IERROR) 309C 310C PURPOSE--DEFINE THE 3-D PROJECTION SWITCH I3DPRO. 311C THE 2 SETTINGS ARE 312C 1) ORTHOGRAPHIC (THE DEFAULT) 313C 2) PERSPECTIVE 314C INPUT ARGUMENTS--ICOM 315C --IHARG (A HOLLERITH VECTOR) 316C --NUMARG 317C OUTPUT ARGUMENTS--I3DPRO ('ORTH' OR 'PERS') 318C --IFOUND ('YES' OR 'NO' ) 319C --IERROR ('YES' OR 'NO' ) 320C WRITTEN BY--JAMES J. FILLIBEN 321C STATISTICAL ENGINEERING DI3DPROION 322C INFORMATION TECHNOLOGY LABORATORY 323C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 324C GAITHERSBURG, MD 20899-8980 325C PHONE--301-975-2855 326C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 327C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 328C LANGUAGE--ANSI FORTRAN (1977) 329C VERSION NUMBER--88/10 330C ORIGINAL VERSION--SEPTEMBER 1988. 331C 332C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 333C 334 CHARACTER*4 ICOM 335 CHARACTER*4 IHARG 336 CHARACTER*4 I3DPRO 337 CHARACTER*4 IFOUND 338 CHARACTER*4 IERROR 339C 340C--------------------------------------------------------------------- 341C 342 DIMENSION IHARG(*) 343C 344C--------------------------------------------------------------------- 345C 346 INCLUDE 'DPCOP2.INC' 347C 348C-----START POINT----------------------------------------------------- 349C 350 IFOUND='NO' 351 IERROR='NO' 352C 353 IF(ICOM.EQ.'ORTH')GOTO1110 354 IF(ICOM.EQ.'PERS')GOTO1120 355 IF(ICOM.EQ.'PROJ')GOTO1130 356C 357 1110 CONTINUE 358 IF(NUMARG.LE.0)GOTO1150 359 IF(IHARG(1).EQ.'ON')GOTO1150 360 IF(IHARG(1).EQ.'OFF')GOTO1160 361 GOTO1199 362C 363 1120 CONTINUE 364 IF(NUMARG.LE.0)GOTO1160 365 IF(IHARG(1).EQ.'ON')GOTO1160 366 IF(IHARG(1).EQ.'OFF')GOTO1150 367 GOTO1199 368C 369 1130 CONTINUE 370 IF(NUMARG.LE.0)GOTO1150 371 IF(IHARG(1).EQ.'ON')GOTO1150 372 IF(IHARG(1).EQ.'OFF')GOTO1160 373 IF(IHARG(1).EQ.'AUTO')GOTO1150 374 IF(IHARG(1).EQ.'DEFA')GOTO1150 375 IF(IHARG(1).EQ.'ORTH')GOTO1150 376 IF(IHARG(1).EQ.'PERS')GOTO1160 377 GOTO1199 378C 379 1150 CONTINUE 380 I3DPRO='ORTH' 381 GOTO1180 382C 383 1160 CONTINUE 384 I3DPRO='PERS' 385 GOTO1180 386C 387 1180 CONTINUE 388 IFOUND='YES' 389C 390 IF(IFEEDB.EQ.'OFF')GOTO1189 391 WRITE(ICOUT,999) 392 999 FORMAT(1X) 393 CALL DPWRST('XXX','BUG ') 394 WRITE(ICOUT,1181) 395 1181 FORMAT('THE PROJECTION SWITCH (AFFECTING 3-D PLOTS') 396 CALL DPWRST('XXX','BUG ') 397 WRITE(ICOUT,1182)I3DPRO 398 1182 FORMAT(' HAS JUST BEEN SET TO ',A4) 399 CALL DPWRST('XXX','BUG ') 400 1189 CONTINUE 401 GOTO1199 402C 403 1199 CONTINUE 404 RETURN 405 END 406 SUBROUTINE DPPROM(IHARG,NUMARG,IPROSW,IFOUND,IERROR) 407C 408C PURPOSE--DEFINE THE PROMPT SWITCH IPROSW. 409C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 410C --NUMARG 411C OUTPUT ARGUMENTS--IPROSW ('ON' OR 'OFF') 412C --IFOUND ('YES' OR 'NO' ) 413C --IERROR ('YES' OR 'NO' ) 414C WRITTEN BY--JAMES J. FILLIBEN 415C STATISTICAL ENGINEERING DIVISION 416C INFORMATION TECHNOLOGY LABORATORY 417C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 418C GAITHERSBURG, MD 20899-8980 419C PHONE--301-975-2855 420C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 421C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 422C LANGUAGE--ANSI FORTRAN (1977) 423C VERSION NUMBER--86/1 424C ORIGINAL VERSION--DECEMBER 1985. 425C 426C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 427C 428 CHARACTER*4 IHARG 429 CHARACTER*4 IPROSW 430 CHARACTER*4 IFOUND 431 CHARACTER*4 IERROR 432C 433C--------------------------------------------------------------------- 434C 435 DIMENSION IHARG(*) 436C 437C--------------------------------------------------------------------- 438C 439 INCLUDE 'DPCOP2.INC' 440C 441C-----START POINT----------------------------------------------------- 442C 443 IFOUND='NO' 444 IERROR='NO' 445C 446 IF(NUMARG.EQ.0)GOTO1150 447 IF(NUMARG.GE.1)GOTO1110 448 GOTO1199 449C 450 1110 CONTINUE 451 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 452 IF(IHARG(NUMARG).EQ.'OFF')GOTO1160 453 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 454 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 455 GOTO1199 456C 457 1150 CONTINUE 458 IPROSW='ON' 459 GOTO1180 460C 461 1160 CONTINUE 462 IPROSW='OFF' 463 GOTO1180 464C 465 1180 CONTINUE 466 IFOUND='YES' 467C 468 IF(IFEEDB.EQ.'OFF')GOTO1189 469 WRITE(ICOUT,999) 470 999 FORMAT(1X) 471 CALL DPWRST('XXX','BUG ') 472 WRITE(ICOUT,1181)IPROSW 473 1181 FORMAT('THE PROMPT SWITCH HAS JUST BEEN TURNED ', 474 1A4) 475 CALL DPWRST('XXX','BUG ') 476 1189 CONTINUE 477 GOTO1199 478C 479 1199 CONTINUE 480 RETURN 481 END 482 SUBROUTINE DPPRO2(Z1,Z2,Z3,NZ,ICASPL, 483 1Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR) 484C 485C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS 486C THAT WILL DEFINE 487C A PROFILE PLOT 488C (USEFUL FOR MULTIVARIATE ANALYSIS). 489C WRITTEN BY--JAMES J. FILLIBEN 490C STATISTICAL ENGINEERING DIVISION 491C INFORMATION TECHNOLOGY LABORATORY 492C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 493C GAITHERSBURG, MD 20899-8980 494C PHONE--301-975-2855 495C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 496C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 497C LANGUAGE--ANSI FORTRAN (1977) 498C VERSION NUMBER--88/2 499C ORIGINAL VERSION--JANUARY 1988. 500C UPDATED --APRIL 1992. DELETE K 501C 502C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 503C 504 CHARACTER*4 ICASPL 505 CHARACTER*4 IBUGG3 506 CHARACTER*4 ISUBRO 507 CHARACTER*4 IERROR 508C 509 CHARACTER*4 ISUBN1 510 CHARACTER*4 ISUBN2 511C 512C--------------------------------------------------------------------- 513C 514 DIMENSION Z1(*) 515 DIMENSION Z2(*) 516 DIMENSION Z3(*) 517C 518 DIMENSION Y2(*) 519 DIMENSION X2(*) 520 DIMENSION D2(*) 521C 522C--------------------------------------------------------------------- 523C 524 INCLUDE 'DPCOP2.INC' 525C 526C-----START POINT----------------------------------------------------- 527C 528 ISUBN1='DPPR' 529 ISUBN2='O2 ' 530 IERROR='NO' 531C 532C ******************************************** 533C ** STEP 1-- ** 534C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 535C ******************************************** 536C 537 IF(NZ.LT.1)THEN 538 WRITE(ICOUT,999) 539 999 FORMAT(1X) 540 CALL DPWRST('XXX','BUG ') 541 WRITE(ICOUT,31) 542 31 FORMAT('***** ERROR IN PROFILE PLOT--') 543 CALL DPWRST('XXX','BUG ') 544 WRITE(ICOUT,32) 545 32 FORMAT(' THE NUMBER OF OBSERVATIONS IS NON-POSITIVE.') 546 CALL DPWRST('XXX','BUG ') 547 WRITE(ICOUT,34)NZ 548 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) 549 CALL DPWRST('XXX','BUG ') 550 WRITE(ICOUT,999) 551 CALL DPWRST('XXX','BUG ') 552 IERROR='YES' 553 GOTO9000 554 ENDIF 555C 556 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PRO2')THEN 557 WRITE(ICOUT,999) 558 CALL DPWRST('XXX','BUG ') 559 WRITE(ICOUT,71) 560 71 FORMAT('***** AT THE BEGINNING OF DPPRO2--') 561 CALL DPWRST('XXX','BUG ') 562 WRITE(ICOUT,72)ICASPL,NZ,N2,NPLOTV 563 72 FORMAT('ICASPL,NZ,N2,NPLOTV = ',A4,2X,3I8) 564 CALL DPWRST('XXX','BUG ') 565 IF(NZ.GT.0)THEN 566 DO81I=1,NZ 567 WRITE(ICOUT,82)I,Z1(I),Z2(I),Z3(I) 568 82 FORMAT('I,Z1(I),Z2(I),Z3(I) = ',I8,3F15.7) 569 CALL DPWRST('XXX','BUG ') 570 81 CONTINUE 571 ENDIF 572 ENDIF 573C 574C **************************************** 575C ** STEP 11-- ** 576C ** DETERMINE PLOT COORDINATES ** 577C **************************************** 578C 579 J=0 580 DO1100I=1,NZ 581 ANUM=Z1(I)-Z2(I) 582 ADEN=Z3(I)-Z2(I) 583 P=0.0 584 IF(ADEN.GT.0.0)P=ANUM/ADEN 585 J=J+1 586 Y2(J)=P 587 X2(J)=J 588 D2(J)=1.0 589 1100 CONTINUE 590 N2=J 591 NPLOTV=2 592 GOTO9000 593C 594C ***************** 595C ** STEP 90-- ** 596C ** EXIT ** 597C ***************** 598C 599 9000 CONTINUE 600 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PRO2')THEN 601 WRITE(ICOUT,999) 602 CALL DPWRST('XXX','BUG ') 603 WRITE(ICOUT,9011) 604 9011 FORMAT('***** AT THE END OF DPPRO2--') 605 CALL DPWRST('XXX','BUG ') 606 WRITE(ICOUT,9031)N2,NPLOTV 607 9031 FORMAT('N2,NPLOTV = ',2I8) 608 CALL DPWRST('XXX','BUG ') 609 DO9035I=1,N2 610 WRITE(ICOUT,9036)I,Y2(I),X2(I),D2(I) 611 9036 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2G15.7,F9.2) 612 CALL DPWRST('XXX','BUG ') 613 9035 CONTINUE 614 ENDIF 615C 616 RETURN 617 END 618 SUBROUTINE DPPRPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 619 1 IANGLU,MAXNPP, 620 1 ICONT,NUMHPP,NUMVPP,IMANUF, 621 1 XMATN,YMATN,XMITN,YMITN, 622 1 ISQUAR, 623 1 IVGMSW,IHGMSW, 624 1 IMPSW,IMPNR,IMPNC,IMPCO, 625 1 PMXMIN,PMXMAX,PMYMIN,PMYMAX, 626 1 MAXNXT,ALOWFR,ALOWDG,IFORSW, 627 1 ANOPL1,ANOPL2,ISEED,IBOOSS,BARHEF,BARWEF, 628 1 ICAPSW, 629 1 IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ, 630 1 IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO, 631 1 IFOUND,IERROR) 632C 633C PURPOSE--GENERATE EITHER 634C 1) A PARTIAL REGRESSION PLOT 635C 2) A PARTIAL LEVERAGE PLOT 636C 3) A PARTIAL RESIDUAL PLOT 637C 4) A CCPR PLOT 638C FOR EXAMPLE, THE COMMAND 639C PARTIAL REGRESSION PLOT Y X1 TO XK 640C WILL GENERATE PARTIAL REGRESSION PLOTS OF Y VS X1, 641C Y VS X2, ETC. AS A MULTIPLOT ON A SINGLE PAGE. 642C WRITTEN BY--ALAN HECKERT 643C STATISTICAL ENGINEERING DIVISION 644C INFORMATION TECHNOLOGY LABORATORY 645C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 646C GAITHERSBURG, MD 20899-8980 647C PHONE--301-975-2899 648C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 649C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 650C LANGUAGE--ANSI FORTRAN (1977) 651C VERSION NUMBER--2002/6 652C ORIGINAL VERSION--JUNE 2002. 653C UPDATED --FEBRUARY 2005. CALL LIST TO MAINAN 654C UPDATED --MARCH 2006. CALL LIST TO MAINGR 655C UPDATED --AUGUST 2007. CALL LIST TO MAINGR 656C 657C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES--------------- 658C 659 INCLUDE 'DPCOPA.INC' 660C 661 CHARACTER*4 ICASPL 662 CHARACTER*4 ICASP2 663 CHARACTER*4 ICAPSW 664 CHARACTER*4 ICASAN 665 CHARACTER*4 ICONT 666 CHARACTER*4 IPOWE 667 CHARACTER*4 IAND1 668 CHARACTER*4 IAND2 669 CHARACTER*4 IANGLU 670 CHARACTER*4 IFORSW 671 CHARACTER*4 IFTEXP 672 CHARACTER*4 IFTORD 673 CHARACTER*4 ICPSWZ 674C 675 CHARACTER*4 IBUGG2 676 CHARACTER*4 IBUGG3 677 CHARACTER*4 IBUGUG 678 CHARACTER*4 IBUGU2 679 CHARACTER*4 IBUGU3 680 CHARACTER*4 IBUGU4 681 CHARACTER*4 IBUGCO 682 CHARACTER*4 IBUGEV 683 CHARACTER*4 IBUGQ 684C 685 CHARACTER*4 ISUBRO 686 CHARACTER*4 IFOUND 687 CHARACTER*4 IERROR 688 CHARACTER*4 IEMPTY 689 CHARACTER*4 ISQUAR 690 CHARACTER*4 IVGMSW 691 CHARACTER*4 IHGMSW 692 CHARACTER*4 IREPCH 693 CHARACTER*4 IMPSW 694 CHARACTER*4 IFPLFZ 695 CHARACTER*4 IFPLTZ 696 CHARACTER*4 IFPLPZ 697 CHARACTER*4 IFPLLZ 698 CHARACTER*4 IFPLL2 699 CHARACTER*4 IFPLXZ 700 CHARACTER*4 IFPLYZ 701 CHARACTER*4 IFPLDZ 702 CHARACTER*4 IFPLZT 703 CHARACTER*4 IFPLZ2 704 CHARACTER*4 IFPLZ3 705 CHARACTER*4 IFPLZ4 706 CHARACTER*4 ILFLAX 707 CHARACTER*4 ILFLAY 708 CHARACTER*4 IFPLLD 709 CHARACTER*4 IFPLDI 710 CHARACTER*4 ISTEPN 711 CHARACTER*4 ISUBN1 712 CHARACTER*4 ISUBN2 713 CHARACTER*4 IFEED9 714 CHARACTER*4 IMANUF 715 CHARACTER*4 IPLOTT 716 CHARACTER*4 ICT 717 CHARACTER*4 IC2T 718 CHARACTER*4 IHT(5) 719 CHARACTER*4 IH2T(5) 720C 721C MAXY IS THE MAXIMUM NUMBER OF VARIABLES TO USE IN CREATING THE 722C PARTIAL REGRESSION PLOT CURVE 723C 724 PARAMETER(MAXY=50) 725 CHARACTER*40 INAME 726 CHARACTER*4 IVARN1(MAXY) 727 CHARACTER*4 IVARN2(MAXY) 728 CHARACTER*4 IVARTY(MAXY) 729 DIMENSION ILIS(MAXY) 730 DIMENSION PVAR(MAXY) 731 DIMENSION NRIGHT(MAXY) 732 DIMENSION ICOLL(MAXY) 733C 734 DIMENSION TEMP(MAXOBV) 735 DIMENSION TEMP2(MAXOBV) 736 DIMENSION TEMP3(MAXOBV) 737 DIMENSION XTEMP1(MAXOBV) 738 DIMENSION XTEMP2(MAXOBV) 739C 740C-----COMMON------------------------------------------------------ 741C 742 INCLUDE 'DPCOZ3.INC' 743 INCLUDE 'DPCOPC.INC' 744 INCLUDE 'DPCOHK.INC' 745 INCLUDE 'DPCODA.INC' 746 INCLUDE 'DPCOST.INC' 747 INCLUDE 'DPCOSP.INC' 748C 749 EQUIVALENCE (G3RBAG(KGARB1),TEMP(1)) 750 EQUIVALENCE (G3RBAG(KGARB2),TEMP2(1)) 751 EQUIVALENCE (G3RBAG(KGARB3),TEMP3(1)) 752 EQUIVALENCE (G3RBAG(KGARB4),XTEMP1(1)) 753 EQUIVALENCE (G3RBAG(KGARB5),XTEMP2(1)) 754C 755C-----COMMON VARIABLES (GENERAL)---------------------------------- 756C 757 INCLUDE 'DPCOP2.INC' 758C 759C-----START POINT------------------------------------------------- 760C 761 IFOUND='YES' 762 IERROR='NO' 763 ISUBN1='DPPR' 764 ISUBN2='PL ' 765C 766 IF(ICASPL.NE.'CCPR')ICASPL='PRPL' 767 IFPLLD='ON' 768 IFPLDI='LINE' 769 IBOOSS=100 770C 771 IFLAGV=5 772C 773C *********************************************** 774C ** TREAT THE PARTIAL REGRESSION PLOT CASE ** 775C *********************************************** 776C 777 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.NE.'PRPL')THEN 778 WRITE(ICOUT,999) 779 999 FORMAT(1X) 780 CALL DPWRST('XXX','BUG ') 781 WRITE(ICOUT,51) 782 51 FORMAT('***** AT THE BEGINNING OF DPPRPL--') 783 CALL DPWRST('XXX','BUG ') 784 WRITE(ICOUT,52)ICASPL,IAND1,IAND2,NUMARG 785 52 FORMAT('ICASPL,IAND1,IAND2,NUMARG = ',3(A4,2X),I8) 786 CALL DPWRST('XXX','BUG ') 787 WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO 788 53 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4) 789 CALL DPWRST('XXX','BUG ') 790 IF(NUMARG.GT.0)THEN 791 DO61I=1,NUMARG 792 WRITE(ICOUT,62)I,IHARG(I),IARGT(I) 793 62 FORMAT('I,IHARG(I),IARGT(I) = ',I8,2X,A4,2X,A4) 794 CALL DPWRST('XXX','BUG ') 795 61 CONTINUE 796 ENDIF 797 WRITE(ICOUT,71)IFPLLA,IFPLTA,IFPLPT,IFPLFI,IFPLFR 798 71 FORMAT('IFPLLA,IFPLTA,IFPLPT,IFPLFI,IFPLFR = ',5(A4,2X),A4) 799 CALL DPWRST('XXX','BUG ') 800 ENDIF 801C 802C ****************************************************** 803C ** STEP 1-- ** 804C ** SHIFT COMMAND LINE ARGMENTS ** 805C ****************************************************** 806C 807 ISTEPN='1' 808 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PRPL') 809 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 810C 811 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'REGR'.AND.IHARG(2).EQ.'PLOT')THEN 812 ICASPL='PREG' 813 ISHIFT=2 814 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 815 1 IBUGG2,IERROR) 816 IF(IERROR.EQ.'YES')GOTO9000 817 ENDIF 818C 819C SYNONYM: ADDED VARIABLE PLOT 820C 821 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'VARI'.AND.IHARG(2).EQ.'PLOT')THEN 822 ICASPL='PREG' 823 ISHIFT=2 824 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 825 1 IBUGG2,IERROR) 826 IF(IERROR.EQ.'YES')GOTO9000 827 ENDIF 828C 829 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LEVE'.AND.IHARG(2).EQ.'PLOT')THEN 830 ICASPL='PLEV' 831 ISHIFT=2 832 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 833 1 IBUGG2,IERROR) 834 IF(IERROR.EQ.'YES')GOTO9000 835 ENDIF 836C 837 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'RESI'.AND.IHARG(2).EQ.'PLOT')THEN 838 ICASPL='PRES' 839 ISHIFT=2 840 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 841 1 IBUGG2,IERROR) 842 IF(IERROR.EQ.'YES')GOTO9000 843 ENDIF 844C 845 IF(ICASPL.EQ.'CCPR'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')THEN 846 ISHIFT=1 847 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 848 1 IBUGG2,IERROR) 849 IF(IERROR.EQ.'YES')GOTO9000 850 ENDIF 851C 852C SYNONYM: COMPONENT PLUS RESIDUAL PLOT 853C 854 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'PLUS'.AND.IHARG(2).EQ.'RESI'.AND. 855 1 IHARG(3).EQ.'PLOT')THEN 856 ICASPL='PRES' 857 ISHIFT=3 858 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 859 1 IBUGG2,IERROR) 860 IF(IERROR.EQ.'YES')GOTO9000 861 ENDIF 862C 863 ICOM='FIT ' 864 ICOM2=' ' 865 IFOUND='YES' 866C 867C ******************************************************* 868C ** STEP 2-- ** 869C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** 870C ******************************************************* 871C 872 ISTEPN='2' 873 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PRPL') 874 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 875C 876 INAME='PARTIAL REGRESSION PLOT' 877 MINNA=1 878 MAXNA=100 879 MINN2=2 880 IFLAGE=1 881 IFLAGM=0 882 IFLAGP=0 883 JMIN=1 884 JMAX=NUMARG 885 MINNVA=2 886 MAXNVA=MAXY 887C 888 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 889 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 890 1 JMIN,JMAX, 891 1 MINN2,MINNA,MAXNA,MAXY,IFLAGE,INAME, 892 1 IVARN1,IVARN2,IVARTY,PVAR, 893 1 ILIS,NRIGHT,ICOLL,ISUB,NQ,ILOCQ,NUMVAR, 894 1 MINNVA,MAXNVA, 895 1 IFLAGM,IFLAGP, 896 1 IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 897 IF(IERROR.EQ.'YES')GOTO9000 898C 899 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PRPL')THEN 900 WRITE(ICOUT,999) 901 CALL DPWRST('XXX','BUG ') 902 WRITE(ICOUT,281) 903 281 FORMAT('***** AFTER CALL DPPARS--') 904 CALL DPWRST('XXX','BUG ') 905 WRITE(ICOUT,282)NQ,NUMVAR 906 282 FORMAT('NQ,NUMVAR = ',2I8) 907 CALL DPWRST('XXX','BUG ') 908 IF(NUMVAR.GT.0)THEN 909 DO285I=1,NUMVAR 910 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 911 1 ICOLL(I) 912 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 913 1 'ICOLL(I) = ',I8,2X,A4,A4,2X,3I8) 914 CALL DPWRST('XXX','BUG ') 915 285 CONTINUE 916 ENDIF 917 ENDIF 918C 919C ************************************************** 920C ** STEP 0.5-- ** 921C ** PERFORM MULTILINEAR FIT ** 922C ************************************************** 923C 924 ISTEPN='0.5' 925 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PRPL') 926 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 927C 928 ICPSWZ='OFF' 929 CALL MAINAN(ICASAN,ISEED,ANOPL1,ANOPL2, 930 1TEMP,TEMP2,XTEMP1,XTEMP2,MAXNXT, 931 1IFTEXP,IFTORD, 932 1ALOWFR,ALOWDG, 933 1IBOOSS, 934 1ICPSWZ, 935 1IFORSW, 936 1IBUGG2,IBUGG2,IBUGG3, 937 1IBUGCO,IBUGEV,IBUGQ,ISUBRO,IFOUND,IERROR) 938C 939C ************************************************** 940C ** STEP 1-- ** 941C ** SAVE INITIAL SETTINGS ** 942C ************************************************** 943C 944 ISTEPN='1' 945 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PRPL') 946 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 947C 948 IFLAG=1 949 CALL DPSPM5(IFLAG,IMPSW,IMPCO,IMPNR,IMPNC, 950 1 IBUGG2,ISUBRO,IFOUND,IERROR) 951C 952 ILFLAX='OFF' 953 ILFLAY='OFF' 954 IF(IY1MIN.EQ.'FIXE'.AND.IY1MAX.EQ.'FIXE')THEN 955 ILFLAY='ON' 956 ENDIF 957 IF(IX1MIN.EQ.'FIXE'.AND.IX2MAX.EQ.'FIXE')THEN 958 ILFLAX='ON' 959 ENDIF 960C 961 IFPLL2=IFPLLA 962 IFPLTZ=IFPLTA 963 IFPLFZ=IFPLFR 964 IFPLPZ=IFPLPT 965 IFPLLZ=IFPLLD 966 IFPLZT=IFPLST 967 IFPLZ2=IFPLS2 968 IFPLZ3=IFPLS3 969 IFPLZ4=IFPLS4 970 IFPLXZ=IFPLXA 971 IFPLYZ=IFPLYA 972 IFPLDZ=IFPLDI 973 IF(IFPLFR.EQ.'USER'.AND.IFPLLA.EQ.'BOX')IFPLLA='ON' 974 IF(IFPLFR.EQ.'CONN')IFPLFR='DEFA' 975 IF(IFPLLA.EQ.'BOX ')THEN 976 IFPLLD='ON' 977 IF(IFPLDI.EQ.'BLAN')IFPLDI='LINE' 978 ENDIF 979C 980 IFEED9=IFEEDB 981C 982 IMPSW3=IMPSW 983 IMPCO2=IMPCO 984 IMPNR2=IMPNR 985 IMPNC2=IMPNC 986 IMPSW='ON' 987 IMPCO=1 988 IMPCO9=IMPCO 989C 990 NPLOTS=NUMVAR-1 991C 992 IF(IMPNR*IMPNC.LT.NPLOTS)THEN 993 IMPNC=INT(SQRT(REAL(NPLOTS-1)))+1 994 IMPNR=1 995 IF(NPLOTS.GE.11)THEN 996 IMPNR=INT(NPLOTS/IMPNC)+1 997 ELSEIF(NPLOTS.GE.7)THEN 998 IMPNR=3 999 ELSEIF(NPLOTS.GE.3)THEN 1000 IMPNR=2 1001 ENDIF 1002 ENDIF 1003C 1004 IROWT=IMPNR 1005 ICOLT=IMPNC 1006 IF(IFPLLA.EQ.'BOX')THEN 1007 IMPNR=IMPNR+1 1008 IMPNC=IMPNC+1 1009 IROWT=IROWT+1 1010 ICOLT=ICOLT+1 1011 ENDIF 1012C 1013C ************************************* 1014C ** STEP 21-- ** 1015C ** GENERATE THE PLOTS ** 1016C ************************************* 1017C 1018 ISTEPN='21' 1019 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'DPPRPL') 1020 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1021C 1022 IF(ICASPL.EQ.'PREG')THEN 1023 ICT='PART' 1024 IC2T='IAL ' 1025 NCCOMM=2 1026 IHT(1)='REGR' 1027 IH2T(1)='ESSI' 1028 IHT(2)='PLOT' 1029 IH2T(2)=' ' 1030 IPLOTT='PREG' 1031 ELSEIF(ICASPL.EQ.'PLEV')THEN 1032 ICT='PART' 1033 IC2T='IAL ' 1034 NCCOMM=2 1035 IHT(1)='LEVE' 1036 IH2T(1)='RAGE' 1037 IHT(2)='PLOT' 1038 IH2T(2)=' ' 1039 IPLOTT='PLEV' 1040 ELSEIF(ICASPL.EQ.'PRES')THEN 1041 ICT='PART' 1042 IC2T='IAL ' 1043 NCCOMM=2 1044 IHT(1)='RESI' 1045 IH2T(1)='DUAL' 1046 IHT(2)='PLOT' 1047 IH2T(2)=' ' 1048 IPLOTT='PRES' 1049 ELSEIF(ICASPL.EQ.'CCPR')THEN 1050 ICT='CCPR' 1051 IC2T=' ' 1052 NCCOMM=1 1053 IHT(1)='PLOT' 1054 IH2T(1)=' ' 1055 IPLOTT='CCPR' 1056 ELSE 1057 ICT='PART' 1058 IC2T='IAL ' 1059 NCCOMM=2 1060 IHT(1)='REGR' 1061 IH2T(1)='ESSI' 1062 IPLOTT='PREG' 1063 ENDIF 1064 GOTO5299 1065C 1066C ************************************************** 1067C ** GENERATE ONE OF THE FOLLOWING COMMANDS ** 1068C ** PARTIAL REGRESSION PLOT Y X1 X2 .... XI ** 1069C ** PARTIAL RESIDUAL PLOT Y X1 X2 .... XI ** 1070C ** PARTIAL LEVERAGE PLOT Y X1 X2 .... XI ** 1071C ** WHERE XI IS THE SPECIFIC VARIABLE THE ** 1072C ** PLOT IS BEING GENERATED FOR. ** 1073C ************************************************** 1074 5299 CONTINUE 1075C 1076 IF(NPLOTS.LT.1)GOTO8000 1077C 1078 ISHIFT=NCCOMM 1079 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1080 1 IBUGG2,IERROR) 1081 ICOM=ICT 1082 ICOM2=IC2T 1083 IF(NCCOMM.GT.0)THEN 1084 DO5301II=1,NCCOMM 1085 IHARG(II)=IHT(II) 1086 IHARG2(II)=IH2T(II) 1087 IARG(II)=0 1088 ARG(II)=0.0 1089 IARGT(II)='WORD' 1090 5301 CONTINUE 1091 ENDIF 1092 IFRST=NCCOMM+2 1093 NUMARG=NUMARG+1 1094 IHARG(NUMARG)=' ' 1095 IHARG2(NUMARG)=' ' 1096 IARG(NUMARG)=0 1097 ARG(NUMARG)=0.0 1098 IARGT(NUMARG)=IARGT(IFRST) 1099 NARGT=NUMARG 1100C 1101 IPLOT=0 1102 IF(IFPLLA.EQ.'BOX')THEN 1103 NPLOTS=NPLOTS+IMPNR+IMPNC-1 1104 ENDIF 1105 DO5300IRES=1,IROWT 1106 DO5400IFAC=1,ICOLT 1107C 1108 IPLOT=IPLOT+1 1109 IF(IPLOT.GT.NPLOTS)GOTO8000 1110 IHARG(NUMARG)=IHARG(IFRST+IPLOT-1) 1111 IHARG2(NUMARG)=IHARG2(IFRST+IPLOT-1) 1112 IARG(NUMARG)=IARG(IFRST+IPLOT-1) 1113 ARG(NUMARG)=ARG(IFRST+IPLOT-1) 1114 IARGT(NUMARG)=IARGT(IFRST+IPLOT-1) 1115C 1116 IXLIST=IFAC 1117 IROW=INT(IPLOT/IMPNC)+1 1118 IF(MOD(IPLOT,IMPNC).EQ.0)IROW=IROW-1 1119 ICOL=MOD(IPLOT,IMPNC) 1120 IF(ICOL.EQ.0)ICOL=IMPNC 1121C 1122 IEMPTY='NO' 1123 ITEMP=IFAC 1124 IF(IFPLLA.EQ.'BOX')THEN 1125 ICOL=ICOL-1 1126 ITEMP=IFAC-1 1127 IF(ITEMP.EQ.0)IEMPTY='YES' 1128 IF(IROW.EQ.IMPNR)IEMPTY='YES' 1129 ENDIF 1130C 1131 IF(IEMPTY.EQ.'YES')THEN 1132 DO5304I=1,MAXSUB 1133 ISU2SW(I)=ISUBSW(I) 1134 ISUBSW(I)='OFF' 1135 5304 CONTINUE 1136 ENDIF 1137 IOPTN=3 1138 IDX=1 1139 IDY=1 1140 ICASP2='FACT' 1141C 1142CCCCC NOTE: DPSPM4 IMPLEMENTS "SUB-REGIONS" ON PLOTS. THESE DON'T 1143CCCCC SEEM PARTICULARLY RELEVANT FOR THESE PLOTS, SO COMMENT 1144CCCCC OUT FOR NOW. HOWEVER, LEAVE IN CASE WE DECIDE LATER TO 1145CCCCC IMPLEMENT THEM. 1146C 1147CCCCC CALL DPSPM4(ICASP2,IOPTN,IDX,IDY, 1148CCCCC1 ISUBNU,ISUBSW, 1149CCCCC1 ASUBXL,ASUBXU,ASUBYL,ASUBYU, 1150CCCCC1 ISUBN9,ISUBSZ, 1151CCCCC1 ASBXL2,ASBXU2,ASBYL2,ASBYU2, 1152CCCCC1 PFPXSL,PFPXSU,PFPYSL,PFPYSU, 1153CCCCC1 IBUGG2,ISUBRO,IERROR) 1154C 1155 ICASP2=ICASPL 1156 IRES2=IRES 1157 IXLST2=IXLIST+1 1158 IX=IFAC+1 1159 CALL DPSPM1(ICASP2,IVARN1,IVARN2,ICOLL, 1160 1 IMPNR,IMPNC,IROW,ICOL,IRES2,IX,IPLOT, 1161 1 NPLOTS,NUMVAR, 1162 1 ICHAP2,ILINP2, 1163 1 GY1MNS,GY1MXS,GY2MNS,GY2MXS, 1164 1 GX1MNS,GX1MXS,GX2MNS,GX2MXS, 1165 1 IY1MNS,IY1MXS,IY2MNS,IY2MXS, 1166 1 IX1MNS,IX1MXS,IX2MNS,IX2MXS, 1167 1 IX1TSV,IX2TSV,IY1TSV,IY2TSV, 1168 1 IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV, 1169 1 PX1LD2,PX2LD2, 1170 1 IY1LJ2,IY1LD2,PY1LD2,PY1LA2, 1171 1 IX1LT2,IX2LT2,IY1LT2,IY2LT2, 1172 1 NCX1L2,NCX2L2,NCY1L2,NCY2L2, 1173 1 PFPXLL,PFPXUL,PFPYLL,PFPYUL,IXLST2, 1174 1 IFPLLA,IFPLLD,IPLOTT,IFPLFR,IFPLXA,IFPLYA, 1175 1 IFPLDI,ISPX1L, 1176 1 ISPMXT,ISPMXL,ISPMYT,ISPMYL, 1177 1 IFPLTD,PFPLTD,IVNMEX, 1178 1 IBUGG2,ISUBRO) 1179C 1180 IF(IEMPTY.EQ.'YES')THEN 1181 DO5306I=1,100 1182 ICHAPA(I)='BLAN' 1183 ILINPA(I)='BLAN' 1184 ISPISW(I)='OFF' 1185 IBARSW(I)='OFF' 1186 5306 CONTINUE 1187 ENDIF 1188C 1189 CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL, 1190 1 MAXNPP,ISEED,IBOOSS, 1191 1 IX1TSV,IX2TSV,IY1TSV,IY2TSV, 1192 1 IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV, 1193 1 BARHEF,BARWEF, 1194 1 IRHSTG,IHSTCW,IHSTEB,IHSTOU,IASHWT,IHSTMC,IHSTOP, 1195 1 ICAPSW,IFORSW, 1196 1 IGUIFL,IERRFA, 1197 1 IAND1,IAND2,ICONT,NUMHPP,NUMVPP, 1198CCCCC1 TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, 1199 1 MAXNXT, 1200 1 ISUBRO,IFOUND,IERROR) 1201C 1202CCCCC NOTE: DPSPM3 SETS AN X2LABEL BASED ON CORRELATION, EFFECT 1203CCCCC SIZE, OR NUMBER OF REJECTIONS. THIS DOESN"T SEEM 1204CCCCC PARTICULARLY USEFUL FOR THESE PLOTS, SO COMMENT OUT 1205CCCCC FOR NOW. HOWEVER, LEAVE CODE HERE IN CASE WE DECIDE TO 1206CCCCC ACTIVATE LATER. 1207C 1208CCCCC IF(IEMPTY.EQ.'NO')THEN 1209CCCCC CALL DPSPM3(ICASPL,IOUNI5, 1210CCCCC1 IROW,ICOL, 1211CCCCC1 PX2LD2,NPLOTP, 1212CCCCC1 IFORSW, 1213CCCCC1 IFPX2L,ISPX2P,ISPX2S, 1214CCCCC1 IHRIGH,IHRIG2,IHWUSE, 1215CCCCC1 ISUBN1,ISUBN2,MESSAG, 1216CCCCC1 IBUGG2,ISUBRO,IERROR) 1217CCCCC ENDIF 1218C 1219 ICONT=IDCONT(1) 1220 IPOWE=IDPOWE(1) 1221 NUMHPP=IDNHPP(1) 1222 IMPARG=2 1223 CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,IPOWE,NUMHPP, 1224 1 XMATN,YMATN,XMITN,YMITN, 1225 1 ISQUAR, 1226 1 IVGMSW,IHGMSW, 1227 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM, 1228 1 IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, 1229 1 YPLOT,XPLOT,X2PLOT,TAGPLO, 1230 1 IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9, 1231 1 IMPARG, 1232 1 PMXMIN,PMXMAX,PMYMIN,PMYMAX, 1233 1 MAXCOL, 1234 1 DSIZE,DSYMB,DCOLOR,DFILL, 1235 1 ICAPSW, 1236 1 IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO, 1237 1 IERROR) 1238 IF(IERROR.EQ.'NO')IAND1=IAND2 1239 IF(IERROR.EQ.'YES')GOTO5499 1240C 1241 IF(IFPLFI.EQ.'NONE')GOTO5499 1242 IF(IEMPTY.EQ.'YES')GOTO5499 1243C 1244 IMPCO=IMPCO-1 1245 IF(IMPCO.LE.1)IERASW='OFF' 1246C 1247 ICNTPL=0 1248 IOUNI5=-99 1249 CALL DPSPM2(ICASPL,IVARN1,IVARN2,ICOLL,NUMVAR,NPLOTP, 1250 1 IRES,IX, 1251 1 TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, 1252 1 ALOWFR,ALOWDG, 1253 1 IANGLU,MAXNPP,IAND1,IAND2, 1254 1 IFPLFI,IFPLTA, 1255 1 XMATN,YMATN,XMITN,YMITN, 1256 1 ISQUAR, 1257 1 IVGMSW,IHGMSW, 1258 1 IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9, 1259 1 IREPCH, 1260 1 PMXMIN,PMXMAX,PMYMIN,PMYMAX, 1261 1 ICNTPL,IOUNI5, 1262 1 IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ, 1263 1 IBUGUG,IBUGU2,IBUGU3,IBUGU4, 1264 1 ISUBRO,IFOUND,IERROR) 1265 IF(IERROR.EQ.'YES')GOTO5499 1266 1267 5499 CONTINUE 1268 IERROR='NO' 1269C 1270 ISHIFT=NCCOMM 1271 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1272 1 IBUGG2,IERROR) 1273 ICOM=ICT 1274 ICOM2=IC2T 1275 IF(NCCOMM.GT.0)THEN 1276 DO5491II=1,NCCOMM 1277 IHARG(II)=IHT(II) 1278 IHARG2(II)=IH2T(II) 1279 IARG(II)=0 1280 ARG(II)=0.0 1281 IARGT(II)='WORD' 1282 5491 CONTINUE 1283 ENDIF 1284 IFRST=NCCOMM+2 1285 IHARG(NUMARG)=' ' 1286 IHARG2(NUMARG)=' ' 1287 IARG(NUMARG)=0 1288 ARG(NUMARG)=0.0 1289 IARGT(NUMARG)=IARGT(IFRST) 1290 NARGT=NUMARG 1291C 1292 PX1LDS=PX1LD2 1293 GX1MIN=GX1MNS 1294 GX1MAX=GX1MXS 1295 GX2MIN=GX2MNS 1296 GX2MAX=GX2MXS 1297 GY1MIN=GY1MNS 1298 GY1MAX=GY1MXS 1299 GY2MIN=GY2MNS 1300 GY2MAX=GY2MXS 1301 IX1MIN=IX1MNS 1302 IX1MAX=IX1MXS 1303 IX2MIN=IX2MNS 1304 IX2MAX=IX2MXS 1305 IY1MIN=IY1MNS 1306 IY1MAX=IY1MXS 1307 IY2MIN=IY2MNS 1308 IY2MAX=IY2MXS 1309 PX1ZDS=PX1ZD2 1310 PX2ZDS=PX2ZD2 1311 PY1ZDS=PY1ZD2 1312 PY2ZDS=PY2ZD2 1313 IF(IEMPTY.EQ.'YES')THEN 1314 DO5407I=1,MAXSUB 1315 ISUBSW(I)=ISU2SW(I) 1316 5407 CONTINUE 1317 ENDIF 1318 DO5408I=1,100 1319 ICHAPA(I)=ICHAP2(I) 1320 ILINPA(I)=ILINP2(I) 1321 ISPISW(I)=ISPIS2(I) 1322 IBARSW(I)=IBARS2(I) 1323 5408 CONTINUE 1324 IF(IERROR.EQ.'YES')GOTO5400 1325C 1326 5400 CONTINUE 1327 5300 CONTINUE 1328 GOTO8000 1329C 1330C 1331C ************************************************** 1332C ** STEP 28-- ** 1333C ** REINSTATE INITIAL SETTINGS ** 1334C ************************************************** 1335C 1336 8000 CONTINUE 1337C 1338 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PRPL')THEN 1339 ISTEPN='28' 1340 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 1341 WRITE(ICOUT,8807)IMANUF,NUMDEV,IDMANU(1) 1342 8807 FORMAT('IMANUF,NUMDEV,IDMANU(1) = ',A4,I8,2X,A4) 1343 CALL DPWRST('XXX','BUG ') 1344 ENDIF 1345C 1346 IFLAG=2 1347 CALL DPSPM5(IFLAG,IMPSW,IMPCO,IMPNR,IMPNC, 1348 1 IBUGG2,ISUBRO,IFOUND,IERROR) 1349 IFPLLA=IFPLL2 1350 IFPLTA=IFPLTZ 1351 IFPLFR=IFPLFZ 1352 IFPLPT=IFPLPZ 1353 IFPLLD=IFPLLZ 1354 IFPLXA=IFPLXZ 1355 IFPLYA=IFPLYZ 1356 IFPLDI=IFPLDZ 1357 IFPLST=IFPLZT 1358 IFPLS2=IFPLZ2 1359 IFPLS3=IFPLZ3 1360 IFPLS4=IFPLZ4 1361 IFEEDB=IFEED9 1362C 1363C ***************** 1364C ** STEP 90-- ** 1365C ** EXIT ** 1366C ***************** 1367C 1368 9000 CONTINUE 1369 IF(IBUGG2.EQ.'OFF')GOTO9090 1370 WRITE(ICOUT,999) 1371 CALL DPWRST('XXX','BUG ') 1372 WRITE(ICOUT,9011) 1373 9011 FORMAT('***** AT THE END OF DPPRPL--') 1374 CALL DPWRST('XXX','BUG ') 1375 WRITE(ICOUT,9012)IFOUND,IERROR 1376 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 1377 CALL DPWRST('XXX','BUG ') 1378 WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 1379 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1380 1I8,I8,I8,2X,A4,2X,A4,2X,A4) 1381 CALL DPWRST('XXX','BUG ') 1382 WRITE(ICOUT,9014)NUMARG 1383 9014 FORMAT('NUMARG = ',I8) 1384 CALL DPWRST('XXX','BUG ') 1385 IF(NUMARG.LE.0)GOTO9029 1386 DO9021I=1,NUMARG 1387 WRITE(ICOUT,9022)I,IHARG(I),IARGT(I) 1388 9022 FORMAT('I,IHARG(I),IARGT(I) = ',I8,2X,A4,2X,A4) 1389 CALL DPWRST('XXX','BUG ') 1390 9021 CONTINUE 1391 9029 CONTINUE 1392 9090 CONTINUE 1393C 1394 RETURN 1395 END 1396 SUBROUTINE DPPRPO(ICOM,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1397 1 IPPDE1,IPPDE2, 1398 1 IBUGS2,IFOUND,IERROR) 1399C 1400C PURPOSE--DEFINE PREPLOT/POSTPLOT DEVICE 1401C THAT IS, THE CURRENT DEVICE IN WHICH 1402C THE USER WANTS A USER-SPECIFIED 1403C PREPLOT LINE TO BE WRITTEN OUT, 1404C AND A USER-DEFINED POSTPLOT LINE 1405C TO BE WRITTEN OUT. 1406C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 1407C --NUMARG (AN INTEGER VARIABLE) 1408C OUTPUT ARGUMENTS--IPPDE1 (A HOLLERITH VARIABLE) 1409C IPPDE2 (A HOLLERITH VARIABLE) 1410C --IFOUND ('YES' OR 'NO' ) 1411C --IERROR ('YES' OR 'NO' ) 1412C WRITTEN BY--JAMES J. FILLIBEN 1413C STATISTICAL ENGINEERING DIVISION 1414C INFORMATION TECHNOLOGY LABORATORY 1415C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 1416C GAITHERSBURG, MD 20899-8980 1417C PHONE--301-975-2855 1418C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 1419C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 1420C LANGUAGE--ANSI FORTRAN (1977) 1421C VERSION NUMBER--86/9 1422C ORIGINAL VERSION--OCTOBER 1986. 1423C UPDATED --FEBRUARY 1987. 1424C 1425C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 1426C 1427 CHARACTER*4 ICOM 1428 CHARACTER*4 IHARG 1429 CHARACTER*4 IHARG2 1430CCCCC CHARACTER*4 IARG JULY 1987 1431CCCCC CHARACTER*4 ARG JULY 1987 1432 CHARACTER*4 IARGT 1433C 1434 CHARACTER*4 IPPDE1 1435 CHARACTER*4 IPPDE2 1436 CHARACTER*4 IBUGS2 1437 CHARACTER*4 IFOUND 1438 CHARACTER*4 IERROR 1439C 1440 CHARACTER*4 IHOLD1 1441 CHARACTER*4 IHOLD2 1442C 1443 CHARACTER*4 IHARG1 1444C 1445C--------------------------------------------------------------------- 1446C 1447 DIMENSION IHARG(*) 1448 DIMENSION IHARG2(*) 1449 DIMENSION IARG(*) 1450 DIMENSION ARG(*) 1451 DIMENSION IARGT(*) 1452C 1453C--------------------------------------------------------------------- 1454C 1455 INCLUDE 'DPCOP2.INC' 1456C 1457C-----START POINT----------------------------------------------------- 1458C 1459 IFOUND='NO' 1460 IERROR='NO' 1461 IFOUND='YES' 1462C 1463 IHARG1=IHARG(1) 1464C 1465 IF(ICOM.EQ.'PRE')GOTO1109 1466 IF(ICOM.EQ.'PREP')GOTO1109 1467 IF(ICOM.EQ.'POST')GOTO1109 1468 ISHIFT=1 1469 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1470 1IBUGS2,IERROR) 1471 1109 CONTINUE 1472C 1473 IF(NUMARG.LE.0)GOTO1120 1474C 1475 IF(IHARG(NUMARG).EQ.'ON')GOTO1120 1476 IF(IHARG(NUMARG).EQ.'OFF')GOTO1120 1477 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1120 1478 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1120 1479C 1480 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'POST')GOTO1120 1481 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'DEVI')GOTO1120 1482 IF(NUMARG.EQ.1)GOTO1130 1483C 1484 IF(NUMARG.EQ.2.AND.IHARG(1).EQ.'POST' 1485 1 .AND.IHARG(2).EQ.'DEVI')GOTO1120 1486 IF(NUMARG.EQ.2.AND.IHARG(1).EQ.'POST' 1487 1 .AND.IHARG(2).NE.'DEVI')GOTO1130 1488 IF(NUMARG.EQ.2.AND.IHARG(1).EQ.'DEVI')GOTO1130 1489C 1490 IF(NUMARG.EQ.3.AND.IHARG(1).EQ.'POST' 1491 1 .AND.IHARG(2).EQ.'DEVI')GOTO1130 1492 IF(NUMARG.EQ.3.AND.IHARG(1).EQ.'POST' 1493 1 .AND.IHARG(2).NE.'DEVI')GOTO1140 1494 IF(NUMARG.EQ.3.AND.IHARG(1).EQ.'DEVI')GOTO1140 1495C 1496 GOTO1140 1497C 1498 1120 CONTINUE 1499 IHOLD1='NONE' 1500 IHOLD2=' ' 1501 GOTO1180 1502C 1503 1130 CONTINUE 1504 IHOLD1=IHARG(NUMARG) 1505 IHOLD2=' ' 1506 GOTO1180 1507C 1508 1140 CONTINUE 1509 NUMAM1=NUMARG-1 1510 IHOLD1=IHARG(NUMAM1) 1511 IHOLD2=IHARG(NUMARG) 1512 GOTO1180 1513C 1514 1180 CONTINUE 1515 IPPDE1=IHOLD1 1516 IPPDE2=IHOLD2 1517C 1518 IF(IFEEDB.EQ.'OFF')GOTO1189 1519 WRITE(ICOUT,999) 1520 999 FORMAT(1X) 1521 CALL DPWRST('XXX','BUG ') 1522 WRITE(ICOUT,1188)IPPDE1,IPPDE2 1523 1188 FORMAT('THE PREPLOT/POSTPLOT DEVICE HAS JUST BEEN SET TO ', 1524 1A4,2X,A4) 1525 CALL DPWRST('XXX','BUG ') 1526 1189 CONTINUE 1527 GOTO1199 1528C 1529 1199 CONTINUE 1530 RETURN 1531 END 1532 SUBROUTINE DPPRSW(IHARG,NUMARG,IPRIN2,IFOUND,IERROR) 1533C 1534C PURPOSE--SPECIFY THE PRINTING SWITCH WHICH IN TURN 1535C DETERMINES WHETHER ANY SUBSEQUENT NON-GRAPHICAL OUTPUT 1536C WILL BE PRINTED OR NOT. 1537C THIS CAPABILITY IS USEFUL IF ONE WISHES TO SUPPRESS 1538C OUTPUT FROM ALL PRELIMINARY AND INTERMEDIATE 1539C CALCULATIONS AND JUST HAVE THE FINAL PLOTS THEMSELVES 1540C APPEAR ON THE SCREEN. 1541C THE SPECIFIED PRINTING SWITCH SPECIFICATION 1542C WILL BE PLACED IN THE HOLLERITH VARIABLE IPRIN2. 1543C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 1544C --NUMARG (AN INTEGER VARIABLE) 1545C OUTPUT ARGUMENTS--IPRIN2 (A HOLLERITH VARIABLE) 1546C --IFOUND ('YES' OR 'NO' ) 1547C --IERROR ('YES' OR 'NO' ) 1548C WRITTEN BY--JAMES J. FILLIBEN 1549C STATISTICAL ENGINEERING DIVISION 1550C INFORMATION TECHNOLOGY LABORATORY 1551C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 1552C GAITHERSBURG, MD 20899-8980 1553C PHONE--301-975-2855 1554C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 1555C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 1556C LANGUAGE--ANSI FORTRAN (1977) 1557C VERSION NUMBER--82/7 1558C ORIGINAL VERSION--NOVEMBER 1980. 1559C UPDATED --FEBRUARY 1982. 1560C UPDATED --MAY 1982. 1561C UPDATED --JANUARY 2015. SAVE/RESTORE OPTION 1562C 1563C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 1564C 1565 CHARACTER*4 IHARG 1566 CHARACTER*4 IPRIN2 1567 CHARACTER*4 IFOUND 1568 CHARACTER*4 IERROR 1569C 1570 CHARACTER*4 IHOLD 1571C 1572 CHARACTER*4 IPRISV 1573 COMMON/IPRINT/IPRISV 1574C 1575C--------------------------------------------------------------------- 1576C 1577 DIMENSION IHARG(*) 1578C 1579C--------------------------------------------------------------------- 1580C 1581 INCLUDE 'DPCOP2.INC' 1582C 1583C-----START POINT----------------------------------------------------- 1584C 1585 IFOUND='NO' 1586 IERROR='NO' 1587 IHOLD=' ' 1588C 1589 IF(NUMARG.LE.0 .OR. IHARG(NUMARG).EQ.'ON' .OR. 1590 1 IHARG(NUMARG).EQ.'AUTO' .OR. IHARG(NUMARG).EQ.'DEFA')THEN 1591 IHOLD='ON' 1592 GOTO1180 1593 ELSEIF(IHARG(NUMARG).EQ.'OFF')THEN 1594 IHOLD='OFF' 1595 GOTO1180 1596 ELSEIF(IHARG(NUMARG).EQ.'SAVE')THEN 1597 IPRISV=IPRINT 1598 GOTO1199 1599 ELSEIF(IHARG(NUMARG).EQ.'REST')THEN 1600 IPRINT=IPRISV 1601 GOTO1180 1602 ELSE 1603 GOTO1199 1604 ENDIF 1605C 1606 1180 CONTINUE 1607 IFOUND='YES' 1608 IPRIN2=IHOLD 1609 IPRINT=IPRIN2 1610C 1611 IF(IFEEDB.EQ.'ON')THEN 1612 WRITE(ICOUT,999) 1613 999 FORMAT(1X) 1614 CALL DPWRST('XXX','BUG ') 1615 WRITE(ICOUT,1181)IPRIN2 1616 1181 FORMAT('THE PRINTING SWITCH HAS JUST BEEN SET TO ',A4) 1617 CALL DPWRST('XXX','BUG ') 1618 ENDIF 1619 GOTO1199 1620C 1621 1199 CONTINUE 1622 RETURN 1623 END 1624 SUBROUTINE DPPYRA(IHARG,IARGT,ARG,NUMARG, 1625 1 PXSTAR,PYSTAR,PXEND,PYEND, 1626 1 ILINPA,ILINCO,PLINTH, 1627 1 AREGBA,IREBLI,IREBCO,PREBTH, 1628 1 IREFSW,IREFCO, 1629 1 IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1630 1 PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1631 1 IGRASW,IDIASW, 1632 1 PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1633 1 PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1634 1 NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3, 1635 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1636 1 IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL, 1637 1 IBUGD2,IFOUND,IERROR) 1638C 1639C PURPOSE--DRAW ONE OR MORE PYRAMIDS (DEPENDING ON HOW MANY NUMBERS 1640C ARE PROVIDED). THE COORDINATES ARE IN STANDARDIZED UNITS 1641C OF 0 TO 100. 1642C NOTE--THE INPUT COORDINATES DEFINE THE VERTICES OF THE FRONT FACE 1643C OF THE PYRAMID. 1644C NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 3 1645C AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*3 = 6. 1646C NOTE--IF 4 NUMBERS ARE PROVIDED, THEN THE DRAWN PYRAMID WILL GO 1647C FROM THE LAST CURSOR POSITION (ASSUMED TO BE AT VERTEX 1) 1648C THROUGH THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) AS 1649C DEFINED BY THE FIRST AND SECOND NUMBERS (ASSUMED TO BE AT 1650C VERTEX 2) TO THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) 1651C AS DEFINED BY THE THIRD AND FOURTH NUMBERS (ASSUMED TO BE AT 1652C VERTEX 3) AND CONTINUING BACK THE START POINT TO CLOSE THE 1653C PYRAMID. 1654C NOTE--IF 6 NUMBERS ARE PROVIDED, THEN THE DRAWN PYRAMID WILL GO 1655C FROM THE ABSOLUTE (X,Y) POSITION AS RESULTING FORM THE FIRST 1656C AND SECOND NUMBERS (ASSUMED TO BE AT VERTEX 1) THROUGH THE 1657C (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) AS DEFINED BY THE 1658C THIRD AND FOURTH NUMBERS (ASSUMED TO BE AT VERTEX 2) TO THE 1659C (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) AS DEFINED BY THE 1660C FIFTH AND SIXTH NUMBERS (ASSUMED TO BE AT VERTEX 3) AND THEN 1661C CONTINUING BACK THE START POINT TO CLOSE THE PYRAMID. 1662C NOTE--AND SO FORTH FOR 10, 14, 18, ... NUMBERS. 1663C INPUT ARGUMENTS--IHARG 1664C --IARGT 1665C --ARG 1666C --NUMARG 1667C --PXSTAR 1668C --PYSTAR 1669C OUTPUT ARGUMENTS--PXEND 1670C --PYEND 1671C --IFOUND ('YES' OR 'NO' ) 1672C --IERROR ('YES' OR 'NO' ) 1673C WRITTEN BY--JAMES J. FILLIBEN 1674C STATISTICAL ENGINEERING DIVISION 1675C INFORMATION TECHNOLOGY LABORATORY 1676C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 1677C GAITHERSBURG, MD 20899-8980 1678C PHONE--301-975-2855 1679C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 1680C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 1681C LANGUAGE--ANSI FORTRAN (1977) 1682C VERSION NUMBER--87/5 1683C ORIGINAL VERSION--APRIL 1987. 1684C UPDATED --JANUARY 1989. CALL LIST FOR OFFSET VAR (ALAN) 1685C UPDATED --MARCH 1997. SUPPORT FOR DEVICE FONT (ALAN) 1686C UPDATED --JULY 1997. SUPPORT FOR "DATA" UNITS (ALAN) 1687C UPDATED --DECEMBER 2018. CHECK FOR DISCRETE, NULL, OR 1688C NONE DEVICE 1689C UPDATED --DECEMBER 2018. SUPPORT FOR "DEVICE ... SCALE" 1690C COMMAND 1691C 1692C-----NON-COMMON VARIABLES----------------------------------------- 1693C 1694 CHARACTER*4 IHARG 1695 CHARACTER*4 IARGT 1696C 1697 CHARACTER*4 ILINPA 1698 CHARACTER*4 ILINCO 1699C 1700 CHARACTER*4 IREBLI 1701 CHARACTER*4 IREBCO 1702 CHARACTER*4 IREFSW 1703 CHARACTER*4 IREFCO 1704 CHARACTER*4 IREPTY 1705 CHARACTER*4 IREPLI 1706 CHARACTER*4 IREPCO 1707C 1708 CHARACTER*4 IGRASW 1709 CHARACTER*4 IDIASW 1710C 1711 CHARACTER*4 IDMANU 1712 CHARACTER*4 IDMODE 1713 CHARACTER*4 IDMOD2 1714 CHARACTER*4 IDMOD3 1715 CHARACTER*4 IDPOWE 1716 CHARACTER*4 IDCONT 1717 CHARACTER*4 IDCOLO 1718CCCCC ADD FOLLOWING LINE MARCH 1997. 1719 CHARACTER*4 IDFONT 1720CCCCC ADD FOLLOWING LINE JULY 1997. 1721 CHARACTER*4 UNITSW 1722C 1723 CHARACTER*4 IFOUND 1724 CHARACTER*4 IBUGD2 1725 CHARACTER*4 IERROR 1726 CHARACTER*4 ISUBRO 1727C 1728 CHARACTER*4 IFIG 1729 CHARACTER*4 IBELSW 1730 CHARACTER*4 IERASW 1731 CHARACTER*4 IBACCO 1732 CHARACTER*4 ICOPSW 1733 CHARACTER*4 ITYPEO 1734C 1735 DIMENSION IHARG(*) 1736 DIMENSION IARGT(*) 1737 DIMENSION ARG(*) 1738C 1739 DIMENSION ILINPA(*) 1740 DIMENSION ILINCO(*) 1741 DIMENSION PLINTH(*) 1742C 1743 DIMENSION AREGBA(*) 1744 DIMENSION IREBLI(*) 1745 DIMENSION IREBCO(*) 1746 DIMENSION PREBTH(*) 1747 DIMENSION IREFSW(*) 1748 DIMENSION IREFCO(*) 1749 DIMENSION IREPTY(*) 1750 DIMENSION IREPLI(*) 1751 DIMENSION IREPCO(*) 1752 DIMENSION PREPTH(*) 1753 DIMENSION PREPSP(*) 1754 DIMENSION PDSCAL(*) 1755C 1756 DIMENSION IDMANU(*) 1757 DIMENSION IDMODE(*) 1758 DIMENSION IDMOD2(*) 1759 DIMENSION IDMOD3(*) 1760 DIMENSION IDPOWE(*) 1761 DIMENSION IDCONT(*) 1762 DIMENSION IDCOLO(*) 1763CCCCC ADD FOLLOWING LINE MARCH 1997. 1764 DIMENSION IDFONT(*) 1765 DIMENSION IDNVPP(*) 1766 DIMENSION IDNHPP(*) 1767 DIMENSION IDUNIT(*) 1768C 1769 DIMENSION IDNVOF(*) 1770 DIMENSION IDNHOF(*) 1771C 1772C-----COMMON---------------------------------------------------------- 1773C 1774 INCLUDE 'DPCOGR.INC' 1775 INCLUDE 'DPCOBE.INC' 1776 INCLUDE 'DPCOP2.INC' 1777C 1778C-----START POINT----------------------------------------------------- 1779C 1780 IFOUND='NO' 1781 IERROR='NO' 1782 IERRG4=IERROR 1783CCCCC IBUGG4=IBUGD2 1784CCCCC ISUBG4=ISUBRO 1785C 1786 ILOCFN=0 1787 NUMNUM=0 1788C 1789 X1=0.0 1790 Y1=0.0 1791 X2=0.0 1792 Y2=0.0 1793C 1794 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'PYRA')GOTO90 1795 WRITE(ICOUT,999) 1796 999 FORMAT(1X) 1797 CALL DPWRST('XXX','BUG ') 1798 WRITE(ICOUT,51) 1799 51 FORMAT('***** AT THE BEGINNING OF DPPYRA--') 1800 CALL DPWRST('XXX','BUG ') 1801 WRITE(ICOUT,53)NUMARG 1802 53 FORMAT('NUMARG = ',I8) 1803 CALL DPWRST('XXX','BUG ') 1804 DO55I=1,NUMARG 1805 WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I) 1806 56 FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2X,A4,2X,A4,E15.7) 1807 CALL DPWRST('XXX','BUG ') 1808 55 CONTINUE 1809 WRITE(ICOUT,57)PXSTAR,PYSTAR 1810 57 FORMAT('PXSTAR,PYSTAR = ',2E15.7) 1811 CALL DPWRST('XXX','BUG ') 1812 WRITE(ICOUT,58)PXEND,PYEND 1813 58 FORMAT('PXEND,PYEND = ',2E15.7) 1814 CALL DPWRST('XXX','BUG ') 1815 WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1) 1816 61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7) 1817 CALL DPWRST('XXX','BUG ') 1818 WRITE(ICOUT,62)AREGBA(1) 1819 62 FORMAT('AREGBA(1) = ',E15.7) 1820 CALL DPWRST('XXX','BUG ') 1821 WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1) 1822 63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7) 1823 CALL DPWRST('XXX','BUG ') 1824 WRITE(ICOUT,64)IREFSW(1),IREFCO(1) 1825 64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4) 1826 CALL DPWRST('XXX','BUG ') 1827 WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) 1828 65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ', 1829 1A4,2X,A4,2X,A4,2E15.7) 1830 CALL DPWRST('XXX','BUG ') 1831 WRITE(ICOUT,69)PTEXHE,PTEXWI 1832 69 FORMAT('PTEXHE,PTEXWI= ',2E15.7) 1833 CALL DPWRST('XXX','BUG ') 1834 WRITE(ICOUT,70)PTEXVG,PTEXHG 1835 70 FORMAT('PTEXVG,PTEXHG= ',2E15.6) 1836 CALL DPWRST('XXX','BUG ') 1837 WRITE(ICOUT,76)IGRASW,IDIASW 1838 76 FORMAT('IGRASW,IDIASW = ',A4,2X,A4) 1839 CALL DPWRST('XXX','BUG ') 1840 WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC 1841 77 FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4E15.7) 1842 CALL DPWRST('XXX','BUG ') 1843 WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG 1844 78 FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4E15.7) 1845 CALL DPWRST('XXX','BUG ') 1846 WRITE(ICOUT,80)NUMDEV 1847 80 FORMAT('NUMDEV= ',I8) 1848 CALL DPWRST('XXX','BUG ') 1849 DO81I=1,NUMDEV 1850 WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) 1851 82 FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ', 1852 1A4,2X,A4,2X,A4,2X,A4) 1853 CALL DPWRST('XXX','BUG ') 1854 WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I) 1855 83 FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ', 1856 1A4,2X,A4,2X,A4) 1857 CALL DPWRST('XXX','BUG ') 1858 WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I) 1859 84 FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ', 1860 1I8,I8,I8) 1861 CALL DPWRST('XXX','BUG ') 1862 81 CONTINUE 1863 WRITE(ICOUT,87)IFOUND 1864 87 FORMAT('IFOUND= ',A4) 1865 CALL DPWRST('XXX','BUG ') 1866 WRITE(ICOUT,88)IBUGG4,ISUBG4,IERRG4 1867 88 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 1868 CALL DPWRST('XXX','BUG ') 1869 WRITE(ICOUT,89)IBUGD2,IERROR 1870 89 FORMAT('IBUGD2,IERROR= ',A4,2X,A4) 1871 CALL DPWRST('XXX','BUG ') 1872 90 CONTINUE 1873C 1874 IFIG='PYRA' 1875 NUMPT=3 1876 NUMPT2=2*NUMPT 1877C 1878C ******************************** 1879C ** STEP 0-- ** 1880C ** STEP THROUGH EACH DEVICE ** 1881C ******************************** 1882C 1883 IF(NUMDEV.LE.0)GOTO9000 1884 DO8000IDEVIC=1,NUMDEV 1885C 1886 IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000 1887 IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000 1888 IF(IDMANU(IDEVIC).EQ.'OFF')GOTO8000 1889 IF(IDMANU(IDEVIC).EQ.'NULL')GOTO8000 1890 IF(IDMANU(IDEVIC).EQ.'NONE')GOTO8000 1891 IF(IDMANU(IDEVIC).EQ.'DISC')GOTO8000 1892C 1893 IMANUF=IDMANU(IDEVIC) 1894 IMODEL=IDMODE(IDEVIC) 1895 IMODE2=IDMOD2(IDEVIC) 1896 IMODE3=IDMOD3(IDEVIC) 1897 IGCONT=IDCONT(IDEVIC) 1898 IGCOLO=IDCOLO(IDEVIC) 1899 IGFONT=IDFONT(IDEVIC) 1900 NUMVPP=IDNVPP(IDEVIC) 1901 NUMHPP=IDNHPP(IDEVIC) 1902 ANUMVP=NUMVPP 1903 ANUMHP=NUMHPP 1904 IOFFSV=IDNVOF(IDEVIC) 1905 IOFFSH=IDNHOF(IDEVIC) 1906 IGUNIT=IDUNIT(IDEVIC) 1907 PCHSCA=PDSCAL(IDEVIC) 1908C 1909C ************************************ 1910C ** STEP 1-- ** 1911C ** CARRY OUT OPENING OPERATIONS ** 1912C ** ON THE GRAPHICS DEVICES ** 1913C ************************************ 1914C 1915 CALL DPOPDE 1916C 1917 IBELSW='OFF' 1918 NUMRIN=0 1919 IERASW='OFF' 1920 IBACCO='JUNK' 1921C 1922 CALL DPOPPL(IGRASW, 1923 1IBELSW,NUMRIN,IERASW, 1924 1IBACCO) 1925C 1926C ***************************************** 1927C ** STEP 2-- ** 1928C ** SEARCH FOR COMMAND SPECIFICATIONS ** 1929C ***************************************** 1930C 1931 IF(NUMARG.GE.2.AND. 1932 1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB') 1933 1GOTO1111 1934 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND. 1935 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 1936 1GOTO1112 1937 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND. 1938 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 1939 1GOTO1113 1940 GOTO1130 1941C 1942 1111 CONTINUE 1943 ITYPEO='ABSO' 1944 ILOCFN=1 1945 GOTO1119 1946C 1947 1112 CONTINUE 1948 ITYPEO='ABSO' 1949 ILOCFN=2 1950 GOTO1119 1951C 1952 1113 CONTINUE 1953 ITYPEO='RELA' 1954 ILOCFN=2 1955 GOTO1119 1956 1119 CONTINUE 1957C 1958 IF(ILOCFN.GT.NUMARG)GOTO1129 1959 DO1120I=ILOCFN,NUMARG 1960 IF(IARGT(I).EQ.'NUMB')GOTO1120 1961 GOTO1129 1962 1120 CONTINUE 1963 IFOUND='YES' 1964 GOTO1149 1965 1129 CONTINUE 1966 GOTO1130 1967C 1968 1130 CONTINUE 1969 IERRG4='YES' 1970 WRITE(ICOUT,1131) 1971 1131 FORMAT('***** ERROR IN DPPYRA--') 1972 CALL DPWRST('XXX','BUG ') 1973 WRITE(ICOUT,1132) 1974 1132 FORMAT(' ILLEGAL FORM FOR DRAW ', 1975 1'COMMAND.') 1976 CALL DPWRST('XXX','BUG ') 1977 WRITE(ICOUT,1134) 1978 1134 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1979 1'PROPER FORM--') 1980 CALL DPWRST('XXX','BUG ') 1981 WRITE(ICOUT,1135) 1982 1135 FORMAT(' SUPPOSE IT IS DESIRED TO DRAW A PYRAMID WITH ') 1983 CALL DPWRST('XXX','BUG ') 1984 WRITE(ICOUT,1136) 1985 1136 FORMAT(' FRONT FACE VERTICES (20,20), (50,20), (35,40)') 1986 CALL DPWRST('XXX','BUG ') 1987 WRITE(ICOUT,1141) 1988 1141 FORMAT(' THEN ALLOWABLE FORMS ARE--') 1989 CALL DPWRST('XXX','BUG ') 1990 WRITE(ICOUT,1142) 1991 1142 FORMAT(' PYRAMID 20 20 50 20 35 40') 1992 CALL DPWRST('XXX','BUG ') 1993 WRITE(ICOUT,1143) 1994 1143 FORMAT(' PYRAMID ABSOLUTE 20 20 50 20 35 40') 1995 CALL DPWRST('XXX','BUG ') 1996 GOTO9000 1997 1149 CONTINUE 1998C 1999C **************************** 2000C ** STEP 3-- ** 2001C ** DRAW OUT THE LINE(S) ** 2002C **************************** 2003C 2004 NUMNUM=NUMARG-ILOCFN+1 2005 IF(NUMNUM.LT.NUMPT2)GOTO1151 2006 GOTO1152 2007C 2008 1151 CONTINUE 2009 J=ILOCFN-1 2010 X1=PXSTAR 2011 Y1=PYSTAR 2012 GOTO1159 2013C 2014 1152 CONTINUE 2015 J=ILOCFN 2016 IF(J.GT.NUMARG)GOTO1190 2017 X1=ARG(J) 2018CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 2019 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,IBUGD2,ISUBRO,IERROR) 2020 J=J+1 2021 IF(J.GT.NUMARG)GOTO1190 2022 Y1=ARG(J) 2023CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 2024 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBRO,IERROR) 2025 GOTO1159 2026 1159 CONTINUE 2027C 2028 1160 CONTINUE 2029 J=J+1 2030 IF(J.GT.NUMARG)GOTO1190 2031 X2=ARG(J) 2032CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 2033 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR) 2034 IF(ITYPEO.EQ.'RELA')X2=X1+X2 2035 J=J+1 2036 IF(J.GT.NUMARG)GOTO1190 2037 Y2=ARG(J) 2038CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 2039 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR) 2040 IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2 2041C 2042 J=J+1 2043 IF(J.GT.NUMARG)GOTO1190 2044 X3=ARG(J) 2045CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 2046 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X3,X3,IBUGD2,ISUBRO,IERROR) 2047 IF(ITYPEO.EQ.'RELA')X3=X2+X3 2048 J=J+1 2049 IF(J.GT.NUMARG)GOTO1190 2050 Y3=ARG(J) 2051CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 2052 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y3,Y3,IBUGD2,ISUBRO,IERROR) 2053 IF(ITYPEO.EQ.'RELA')Y3=Y2+Y3 2054C 2055 CALL DPPYR2(X1,Y1,X2,Y2,X3,Y3, 2056 1IFIG, 2057 1ILINPA,ILINCO,PLINTH, 2058 1AREGBA, 2059 1IREBLI,IREBCO,PREBTH, 2060 1IREFSW,IREFCO, 2061 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 2062 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) 2063C 2064 X1=X3 2065 Y1=Y3 2066C 2067 GOTO1160 2068 1190 CONTINUE 2069C 2070 PXEND=X3 2071 PYEND=Y3 2072C 2073C ************************************ 2074C ** STEP 4-- ** 2075C ** CARRY OUT CLOSING OPERATIONS ** 2076C ** ON THE GRAPHICS DEVICES ** 2077C ************************************ 2078C 2079 ICOPSW='OFF' 2080 NUMCOP=0 2081 CALL DPCLPL(ICOPSW,NUMCOP, 2082 1PGRAXF,PGRAYF, 2083 1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 2084 1PDIAHE,PDIAWI,PDIAVG,PDIAHG) 2085C 2086 CALL DPCLDE 2087C 2088 8000 CONTINUE 2089C 2090C ***************** 2091C ** STEP 90-- ** 2092C ** EXIT ** 2093C ***************** 2094C 2095 9000 CONTINUE 2096 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'PYRA')GOTO9090 2097 WRITE(ICOUT,999) 2098 CALL DPWRST('XXX','BUG ') 2099 WRITE(ICOUT,9011) 2100 9011 FORMAT('***** AT THE END OF DPPYRA--') 2101 CALL DPWRST('XXX','BUG ') 2102 WRITE(ICOUT,9012)ILOCFN,NUMNUM 2103 9012 FORMAT('ILOCFN,NUMNUM = ',2I8) 2104 CALL DPWRST('XXX','BUG ') 2105 WRITE(ICOUT,9013)X1,Y1,X2,Y2,X3,Y3 2106 9013 FORMAT('X1,Y1,X2,Y2,X3,Y3 = ',6E15.7) 2107 CALL DPWRST('XXX','BUG ') 2108 WRITE(ICOUT,9015)PXSTAR,PYSTAR 2109 9015 FORMAT('PXSTAR,PYSTAR = ',2E15.7) 2110 CALL DPWRST('XXX','BUG ') 2111 WRITE(ICOUT,9016)PXEND,PYEND 2112 9016 FORMAT('PXEND,PYEND = ',2E15.7) 2113 CALL DPWRST('XXX','BUG ') 2114 WRITE(ICOUT,9017)IFIG 2115 9017 FORMAT('IFIG = ',A4) 2116 CALL DPWRST('XXX','BUG ') 2117 WRITE(ICOUT,9027)IFOUND 2118 9027 FORMAT('IFOUND = ',A4) 2119 CALL DPWRST('XXX','BUG ') 2120 WRITE(ICOUT,9028)IBUGG4,ISUBG4,IERRG4 2121 9028 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4) 2122 CALL DPWRST('XXX','BUG ') 2123 WRITE(ICOUT,9029)IBUGD2,IERROR 2124 9029 FORMAT('IBUGD2,IERROR = ',A4,2X,A4) 2125 CALL DPWRST('XXX','BUG ') 2126 9090 CONTINUE 2127C 2128 RETURN 2129 END 2130 SUBROUTINE DPPYR2(X1,Y1,X2,Y2,X3,Y3, 2131 1IFIG, 2132 1ILINPA,ILINCO,PLINTH, 2133 1AREGBA, 2134 1IREBLI,IREBCO,PREBTH, 2135 1IREFSW,IREFCO, 2136 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 2137 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) 2138C 2139C PURPOSE--DRAW A PYRAMID 2140C WITH FRONT FACE VERTICES AT (X1,Y1), 2141C (X2,Y2), AND (X3,Y3). 2142C WRITTEN BY--JAMES J. FILLIBEN 2143C STATISTICAL ENGINEERING DIVISION 2144C INFORMATION TECHNOLOGY LABORATORY 2145C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 2146C GAITHERSBURG, MD 20899-8980 2147C PHONE--301-975-2855 2148C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 2149C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 2150C LANGUAGE--ANSI FORTRAN (1977) 2151C VERSION NUMBER--87/5 2152C ORIGINAL VERSION--APRIL 1987. 2153C UPDATED --JANUARY 1989. MODIFY CALLS TO DPDRPL (ALAN) 2154C UPDATED --JANUARY 1989. MODIFY CALL TO DPFIRE (ALAN) 2155C 2156C-----NON-COMMON VARIABLES------------------------------------- 2157C 2158 CHARACTER*4 IFIG 2159 CHARACTER*4 IPATT2 2160C 2161 CHARACTER*4 ILINPA 2162 CHARACTER*4 ILINCO 2163C 2164 CHARACTER*4 IREBLI 2165 CHARACTER*4 IREBCO 2166 CHARACTER*4 IREFSW 2167 CHARACTER*4 IREFCO 2168 CHARACTER*4 IREPTY 2169 CHARACTER*4 IREPLI 2170 CHARACTER*4 IREPCO 2171C 2172 CHARACTER*4 IPATT 2173 CHARACTER*4 ICOLF 2174 CHARACTER*4 ICOLP 2175 CHARACTER*4 ICOL 2176 CHARACTER*4 IFLAG 2177C 2178 DIMENSION PX(10) 2179 DIMENSION PY(10) 2180CCCCC DIMENSION PX3(10) 2181CCCCC DIMENSION PY3(10) 2182C 2183 DIMENSION ILINPA(*) 2184 DIMENSION ILINCO(*) 2185 DIMENSION PLINTH(*) 2186C 2187 DIMENSION AREGBA(*) 2188 DIMENSION IREBLI(*) 2189 DIMENSION IREBCO(*) 2190 DIMENSION PREBTH(*) 2191 DIMENSION IREFSW(*) 2192 DIMENSION IREFCO(*) 2193 DIMENSION IREPTY(*) 2194 DIMENSION IREPLI(*) 2195 DIMENSION IREPCO(*) 2196 DIMENSION PREPTH(*) 2197 DIMENSION PREPSP(*) 2198C 2199C-----COMMON---------------------------------------------------------- 2200C 2201 INCLUDE 'DPCOGR.INC' 2202 INCLUDE 'DPCOBE.INC' 2203 INCLUDE 'DPCOP2.INC' 2204C 2205C-----START POINT----------------------------------------------------- 2206C 2207 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'PYR2')GOTO90 2208 WRITE(ICOUT,999) 2209 999 FORMAT(1X) 2210 CALL DPWRST('XXX','BUG ') 2211 WRITE(ICOUT,51) 2212 51 FORMAT('***** AT THE BEGINNING OF DPPYR2--') 2213 CALL DPWRST('XXX','BUG ') 2214 WRITE(ICOUT,53)X1,Y1 2215 53 FORMAT('X1,Y1 = ',2E15.7) 2216 CALL DPWRST('XXX','BUG ') 2217 WRITE(ICOUT,54)X2,Y2 2218 54 FORMAT('X2,Y2 = ',2E15.7) 2219 CALL DPWRST('XXX','BUG ') 2220 WRITE(ICOUT,59)IFIG 2221 59 FORMAT('IFIG = ',A4) 2222 CALL DPWRST('XXX','BUG ') 2223 WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1) 2224 61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7) 2225 CALL DPWRST('XXX','BUG ') 2226 WRITE(ICOUT,62)AREGBA(1) 2227 62 FORMAT('AREGBA(1) = ',E15.7) 2228 CALL DPWRST('XXX','BUG ') 2229 WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1) 2230 63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7) 2231 CALL DPWRST('XXX','BUG ') 2232 WRITE(ICOUT,64)IREFSW(1),IREFCO(1) 2233 64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4) 2234 CALL DPWRST('XXX','BUG ') 2235 WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) 2236 65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ', 2237 1A4,2X,A4,2X,A4,2E15.7) 2238 CALL DPWRST('XXX','BUG ') 2239 WRITE(ICOUT,69)PTEXHE,PTEXWI 2240 69 FORMAT('PTEXHE,PTEXWI= ',2E15.7) 2241 CALL DPWRST('XXX','BUG ') 2242 WRITE(ICOUT,70)PTEXVG,PTEXHG 2243 70 FORMAT('PTEXVG,PTEXHG= ',2E15.6) 2244 CALL DPWRST('XXX','BUG ') 2245 WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4 2246 79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) 2247 CALL DPWRST('XXX','BUG ') 2248 90 CONTINUE 2249C 2250C ********************************* 2251C ** STEP 1-- ** 2252C ** SET THE SPECS ** 2253C ** WHICH CONTROL THE ** 2254C ** APPEARANCE OF THE ** 2255C ** RESULTING CUBE. ** 2256C ********************************* 2257C 2258 DELX21=ABS(X2-X1) 2259 DELY32=ABS(Y3-Y2) 2260C 2261 P3DX=0.1 2262 P3DY=0.3 2263C 2264C ************************* 2265C ** STEP 2-- ** 2266C ** FILL THE FIGURE ** 2267C ** (IF CALLED FOR) ** 2268C ************************* 2269C 2270 IF(IREFSW(1).EQ.'OFF')GOTO2190 2271C 2272 IPATT=IREPTY(1) 2273 PTHICK=PREPTH(1) 2274 PXGAP=PREPSP(1) 2275 PYGAP=PREPSP(1) 2276 ICOLF=IREFCO(1) 2277 ICOLP=IREPCO(1) 2278C 2279 IF(IREFSW(1).EQ.'ON')GOTO2110 2280 IF(IREFSW(1).EQ.'ONF')GOTO2110 2281 IF(IREFSW(1).EQ.'ONS')GOTO2120 2282 IF(IREFSW(1).EQ.'ONFS')GOTO2110 2283 IF(IREFSW(1).EQ.'ONSF')GOTO2110 2284C 2285C ******************************** 2286C ** STEP 2.1-- ** 2287C ** FRONT FACE ONLY ** 2288C ******************************** 2289C 2290 2110 CONTINUE 2291 PX(1)=X1 2292 PY(1)=Y1 2293C 2294 PX(2)=X2 2295 PY(2)=Y2 2296C 2297 PX(3)=X3 2298 PY(3)=Y3 2299C 2300 PX(4)=X1 2301 PY(4)=Y1 2302C 2303 NP=4 2304C 2305 IPATT2='SOLI' 2306 CALL DPFIRE(PX,PY,NP, 2307 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2) 2308C 2309 IF(IREFSW(1).EQ.'ON')GOTO2120 2310 IF(IREFSW(1).EQ.'ONF')GOTO2190 2311 IF(IREFSW(1).EQ.'ONS')GOTO2120 2312 IF(IREFSW(1).EQ.'ONFS')GOTO2120 2313 IF(IREFSW(1).EQ.'ONSF')GOTO2120 2314C 2315C ******************************** 2316C ** STEP 2.2-- ** 2317C ** SIDE (= RIGHT) FACE ONLY ** 2318C ******************************** 2319C 2320 2120 CONTINUE 2321 PX(1)=X3 2322 PY(1)=Y3 2323C 2324 PX(2)=X2-P3DX*DELX21 2325 PY(2)=Y2+P3DY*DELY32 2326C 2327 PX(3)=X2 2328 PY(3)=Y2 2329C 2330 PX(4)=X3 2331 PY(4)=Y3 2332C 2333 NP=4 2334C 2335 IPATT2='SOLI' 2336 CALL DPFIRE(PX,PY,NP, 2337 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2) 2338C 2339 GOTO2190 2340C 2341 2190 CONTINUE 2342C 2343C *************************** 2344C ** STEP 3-- ** 2345C ** DRAW OUT THE FIGURE ** 2346C *************************** 2347C 2348 IPATT=ILINPA(1) 2349 PTHICK=PLINTH(1) 2350 ICOL=ILINCO(1) 2351C 2352 PX(1)=X1 2353 PY(1)=Y1 2354C 2355 PX(2)=X2 2356 PY(2)=Y2 2357C 2358 PX(3)=X3 2359 PY(3)=Y3 2360C 2361 PX(4)=X1 2362 PY(4)=Y1 2363C 2364 NP=4 2365C 2366 IFLAG='ON' 2367CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3, 2368CCCCC1IFIG,IPATT,PTHICK,ICOL) 2369 CALL DPDRPL(PX,PY,NP, 2370 1IFIG,IPATT,PTHICK,ICOL, 2371 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 2372C 2373 PX(1)=X3 2374 PY(1)=Y3 2375C 2376 PX(2)=X2-0.1*DELX21 2377 PY(2)=Y2+0.3*DELY32 2378C 2379 PX(3)=X2 2380 PY(3)=Y2 2381C 2382 NP=3 2383C 2384 IFLAG='ON' 2385CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3, 2386CCCCC1IFIG,IPATT,PTHICK,ICOL) 2387 CALL DPDRPL(PX,PY,NP, 2388 1IFIG,IPATT,PTHICK,ICOL, 2389 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) 2390C 2391C ***************** 2392C ** STEP 90-- ** 2393C ** EXIT ** 2394C ***************** 2395C 2396 IF(IBUGG4.EQ.'ON' .OR. ISUBG4.EQ.'PYR2')THEN 2397 WRITE(ICOUT,999) 2398 CALL DPWRST('XXX','BUG ') 2399 WRITE(ICOUT,9011) 2400 9011 FORMAT('***** AT THE END OF DPPYR2--') 2401 CALL DPWRST('XXX','BUG ') 2402 DO9015I=1,NP 2403 WRITE(ICOUT,9016)I,PX(I),PY(I) 2404 9016 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7) 2405 CALL DPWRST('XXX','BUG ') 2406 9015 CONTINUE 2407 WRITE(ICOUT,9022)DELX21,DELY32,P3DX,P3DY 2408 9022 FORMAT('DELX21,DELY32,P3DX,P3DY = ',4E15.7) 2409 CALL DPWRST('XXX','BUG ') 2410 WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4,NP 2411 9039 FORMAT('IBUGG4,ISUBG4,IERRG4,NP = ',3(A4,2X),I8) 2412 CALL DPWRST('XXX','BUG ') 2413 ENDIF 2414C 2415 RETURN 2416 END 2417 SUBROUTINE DPQCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2418 1ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2419C 2420C PURPOSE--GENERATE ONE OF THE FOLLOWING Q (= QUESENBERRY) 2421C CONTROL CHARTS-- 2422C 1) Q MEAN 2423C 2) Q RANGE 2424C 3) Q STANDARD DEVIATION 2425C 4) Q CUSUM 2426C 5) Q P 2427C 6) Q PN 2428C 7) Q C 2429C 8) Q U 2430C REFERENCE--QUESENBERRY, CHARLES P. SPC Q CHARTS FOR START-UP 2431C PROCESSES AND SHORT OR LONG RUNS. 2432C JOURNAL OF QUALITY TECNOLOGY, JULY 1991, 2433C PAGES 213-224. 2434C WRITTEN BY--JAMES J. FILLIBEN 2435C STATISTICAL ENGINEERING DIVISION 2436C INFORMATION TECHNOLOGY LABORATORY 2437C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 2438C GAITHERSBURG, MD 20899-8980 2439C PHONE--301-975-2855 2440C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 2441C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 2442C LANGUAGE--ANSI FORTRAN (1977) 2443C VERSION NUMBER--93/12 2444C ORIGINAL VERSION--DECEMBER 1993. 2445C 2446C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 2447C 2448 CHARACTER*4 ICASPL 2449 CHARACTER*4 IAND1 2450 CHARACTER*4 IAND2 2451 CHARACTER*4 ICONT 2452 CHARACTER*4 IBUGG2 2453 CHARACTER*4 IBUGG3 2454 CHARACTER*4 IBUGQ 2455 CHARACTER*4 ISUBRO 2456 CHARACTER*4 IFOUND 2457 CHARACTER*4 IERROR 2458C 2459 CHARACTER*4 IHWUSE 2460 CHARACTER*4 MESSAG 2461 CHARACTER*4 ICASEQ 2462 CHARACTER*4 IH 2463 CHARACTER*4 IH2 2464 CHARACTER*4 IERRO2 2465 CHARACTER*4 IHLEFT 2466 CHARACTER*4 IHLEF2 2467 CHARACTER*4 IHHOR 2468 CHARACTER*4 IHHOR2 2469C 2470 CHARACTER*4 IHEXT 2471 CHARACTER*4 IHEXT2 2472C 2473 CHARACTER*4 ISUBN1 2474 CHARACTER*4 ISUBN2 2475 CHARACTER*4 ISTEPN 2476C 2477C--------------------------------------------------------------------- 2478C 2479 INCLUDE 'DPCOPA.INC' 2480C 2481 DIMENSION Y1(MAXOBV) 2482 DIMENSION Y2(MAXOBV) 2483 DIMENSION X1(MAXOBV) 2484C 2485 DIMENSION XIDTEM(MAXOBV) 2486 DIMENSION TEMP(MAXOBV) 2487 DIMENSION TEMP2(MAXOBV) 2488 INCLUDE 'DPCOZZ.INC' 2489 EQUIVALENCE (GARBAG(IGARB1),X1(1)) 2490 EQUIVALENCE (GARBAG(IGARB2),Y1(1)) 2491 EQUIVALENCE (GARBAG(IGARB3),Y2(1)) 2492 EQUIVALENCE (GARBAG(IGARB4),XIDTEM(1)) 2493 EQUIVALENCE (GARBAG(IGARB5),TEMP(1)) 2494 EQUIVALENCE (GARBAG(IGARB6),TEMP2(1)) 2495C 2496C-----COMMON---------------------------------------------------------- 2497C 2498 INCLUDE 'DPCOHK.INC' 2499 INCLUDE 'DPCODA.INC' 2500 INCLUDE 'DPCOP2.INC' 2501C 2502C-----START POINT----------------------------------------------------- 2503C 2504 IERROR='NO' 2505 ISUBN1='DPQC' 2506 ISUBN2='C ' 2507C 2508 MAXCP1=MAXCOL+1 2509 MAXCP2=MAXCOL+2 2510 MAXCP3=MAXCOL+3 2511 MAXCP4=MAXCOL+4 2512 MAXCP5=MAXCOL+5 2513 MAXCP6=MAXCOL+6 2514C 2515 MAXV2=2 2516 MINN2=2 2517C 2518 ICOLH=0 2519C 2520C ************************************** 2521C ** TREAT THE Q CONTROL CHART CASE ** 2522C ************************************** 2523C 2524 IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PQCC')GOTO90 2525 WRITE(ICOUT,999) 2526 999 FORMAT(1X) 2527 CALL DPWRST('XXX','BUG ') 2528 WRITE(ICOUT,51) 2529 51 FORMAT('***** AT THE BEGINNING OF DPQCC--') 2530 CALL DPWRST('XXX','BUG ') 2531 WRITE(ICOUT,52)ICASPL,IAND1,IAND2 2532 52 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) 2533 CALL DPWRST('XXX','BUG ') 2534 WRITE(ICOUT,53)ICONT,IBUGG2,IBUGG3,IBUGQ 2535 53 FORMAT('ICONT,IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4,2X,A4) 2536 CALL DPWRST('XXX','BUG ') 2537 WRITE(ICOUT,54)ISUBRO 2538 54 FORMAT('ISUBRO = ',A4) 2539 CALL DPWRST('XXX','BUG ') 2540 90 CONTINUE 2541C 2542C *************************** 2543C ** STEP 1-- ** 2544C ** EXTRACT THE COMMAND ** 2545C *************************** 2546C 2547 ISTEPN='1' 2548 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC') 2549 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2550C 2551 ICOM=IHARG(1) 2552 ICOM2=IHARG2(1) 2553 ISHIFT=1 2554 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 2555 1IBUGG2,IERROR) 2556C 2557C *************************************** 2558C ** STEP 1.1-- ** 2559C ** SEARCH FOR Q MEAN CONTROL CHART ** 2560C *************************************** 2561C 2562 ICASPL='MECC' 2563C 2564 IF(NUMARG.GE.3.AND. 2565 1ICOM.EQ.'X'.AND.IHARG(1).EQ.'BAR'.AND.IHARG(2).EQ.'CONT'.AND. 2566 1IHARG(3).EQ.'CHAR')GOTO113 2567 IF(NUMARG.GE.2.AND. 2568 1ICOM.EQ.'XBAR'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 2569 1GOTO112 2570 IF(NUMARG.GE.2.AND. 2571 1ICOM.EQ.'MEAN'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 2572 1GOTO112 2573 IF(NUMARG.GE.2.AND. 2574 1ICOM.EQ.'AVER'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 2575 1GOTO112 2576 IF(NUMARG.GE.1.AND. 2577 1ICOM.EQ.'CONT'.AND.IHARG(1).EQ.'CHAR') 2578 1GOTO111 2579 IF(NUMARG.GE.1.AND. 2580 1ICOM.EQ.'MEAN'.AND.IHARG(1).EQ.'CHAR') 2581 1GOTO111 2582 IF(NUMARG.GE.1.AND. 2583 1ICOM.EQ.'XBAR'.AND.IHARG(1).EQ.'CHAR') 2584 1GOTO111 2585 IF(NUMARG.GE.1.AND. 2586 1ICOM.EQ.'AVER'.AND.IHARG(1).EQ.'CHAR') 2587 1GOTO111 2588C 2589C ************************************************ 2590C ** STEP 1.2-- ** 2591C ** SEARCH FOR Q STANDARD DEV. CONTROL CHART ** 2592C ************************************************ 2593C 2594 ICASPL='SDCC' 2595C 2596 IF(NUMARG.GE.3.AND. 2597 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'DEVI'.AND.IHARG(2).EQ.'CONT'.AND. 2598 1IHARG(3).EQ.'CHAR')GOTO113 2599 IF(NUMARG.GE.2.AND. 2600 1ICOM.EQ.'SD'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 2601 1GOTO112 2602 IF(NUMARG.GE.2.AND. 2603 1ICOM.EQ.'S'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 2604 1GOTO112 2605 IF(NUMARG.GE.1.AND. 2606 1ICOM.EQ.'SD'.AND.IHARG(1).EQ.'CHAR') 2607 1GOTO111 2608 IF(NUMARG.GE.1.AND. 2609 1ICOM.EQ.'S'.AND.IHARG(1).EQ.'CHAR') 2610 1GOTO111 2611C 2612C **************************************** 2613C ** STEP 1.3-- ** 2614C ** SEARCH FOR Q RANGE CONTROL CHART ** 2615C **************************************** 2616C 2617 ICASPL='RACC' 2618C 2619 IF(NUMARG.GE.2.AND. 2620 1ICOM.EQ.'RANG'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 2621 1GOTO112 2622 IF(NUMARG.GE.2.AND. 2623 1ICOM.EQ.'R'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 2624 1GOTO112 2625 IF(NUMARG.GE.1.AND. 2626 1ICOM.EQ.'RANG'.AND.IHARG(1).EQ.'CHAR') 2627 1GOTO111 2628 IF(NUMARG.GE.1.AND. 2629 1ICOM.EQ.'R'.AND.IHARG(1).EQ.'CHAR') 2630 1GOTO111 2631C 2632C **************************************** 2633C ** STEP 1.4-- ** 2634C ** SEARCH FOR Q CUSUM CONTROL CHART ** 2635C **************************************** 2636C 2637 ICASPL='CUCC' 2638C 2639 IF(NUMARG.GE.3.AND. 2640 1ICOM.EQ.'CUMU'.AND.IHARG(1).EQ.'SUM'.AND.IHARG(2).EQ.'CONT'.AND. 2641 1IHARG(3).EQ.'CHAR')GOTO113 2642 IF(NUMARG.GE.2.AND. 2643 1ICOM.EQ.'CUSU'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 2644 1GOTO112 2645C 2646C **************************************** 2647C ** STEP 1.5-- ** 2648C ** SEARCH FOR Q P CONTROL CHART ** 2649C **************************************** 2650C 2651 ICASPL='PCC' 2652C 2653 IF(NUMARG.GE.2.AND. 2654 1ICOM.EQ.'P'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 2655 1GOTO112 2656 IF(NUMARG.GE.1.AND. 2657 1ICOM.EQ.'P'.AND.IHARG(1).EQ.'CHAR') 2658 1GOTO111 2659C 2660C **************************************** 2661C ** STEP 1.6-- ** 2662C ** SEARCH FOR Q PN CONTROL CHART ** 2663C **************************************** 2664C 2665 ICASPL='PNCC' 2666C 2667 IF(NUMARG.GE.2.AND. 2668 1ICOM.EQ.'PN'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 2669 1GOTO112 2670 IF(NUMARG.GE.1.AND. 2671 1ICOM.EQ.'PN'.AND.IHARG(1).EQ.'CHAR') 2672 1GOTO111 2673 IF(NUMARG.GE.2.AND. 2674 1ICOM.EQ.'NP'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 2675 1GOTO112 2676 IF(NUMARG.GE.1.AND. 2677 1ICOM.EQ.'NP'.AND.IHARG(1).EQ.'CHAR') 2678 1GOTO111 2679C 2680C **************************************** 2681C ** STEP 1.7-- ** 2682C ** SEARCH FOR Q C CONTROL CHART ** 2683C **************************************** 2684C 2685 ICASPL='CCC' 2686C 2687 IF(NUMARG.GE.2.AND. 2688 1ICOM.EQ.'C'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 2689 1GOTO112 2690 IF(NUMARG.GE.1.AND. 2691 1ICOM.EQ.'C'.AND.IHARG(1).EQ.'CHAR') 2692 1GOTO111 2693C 2694C **************************************** 2695C ** STEP 1.8-- ** 2696C ** SEARCH FOR Q U CONTROL CHART ** 2697C **************************************** 2698C 2699 ICASPL='UCC' 2700C 2701 IF(NUMARG.GE.2.AND. 2702 1ICOM.EQ.'U'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 2703 1GOTO112 2704 IF(NUMARG.GE.1.AND. 2705 1ICOM.EQ.'U'.AND.IHARG(1).EQ.'CHAR') 2706 1GOTO111 2707C 2708 ICASPL=' ' 2709C 2710 IFOUND='NO' 2711 GOTO9000 2712C 2713 111 CONTINUE 2714 ILASTC=1 2715 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 2716 GOTO180 2717C 2718 112 CONTINUE 2719 ILASTC=2 2720 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 2721 GOTO180 2722C 2723 113 CONTINUE 2724 ILASTC=3 2725 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 2726 GOTO180 2727C 2728 180 CONTINUE 2729 IFOUND='YES' 2730 GOTO190 2731C 2732 190 CONTINUE 2733C 2734C *********************************************************** 2735C ** STEP 1-- ** 2736C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** 2737C *********************************************************** 2738C 2739 ISTEPN='1' 2740 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC') 2741 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2742C 2743 MINNA=1 2744 MAXNA=100 2745 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) 2746 IF(IERROR.EQ.'YES')GOTO9000 2747C 2748C ******************************************** 2749C ** STEP 2-- ** 2750C ** CHECK THE VALIDITY OF ARGUMENT 1 ** 2751C ** (THIS WILL BE THE RESPONSE VARIABLE) ** 2752C ******************************************** 2753C 2754 ISTEPN='2' 2755 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC') 2756 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2757C 2758 IHLEFT=IHARG(1) 2759 IHLEF2=IHARG2(1) 2760 IHWUSE='V' 2761 MESSAG='YES' 2762 CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 2763 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 2764 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 2765 IF(IERROR.EQ.'YES')GOTO9000 2766 ICOLL=IVALUE(ILOCV) 2767 NLEFT=IN(ILOCV) 2768 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC')THEN 2769 WRITE(ICOUT,211)IHLEFT,ICOLL,NLEFT 2770 211 FORMAT('IHLEFT,ICOLL,NLEFT = ',A4,I8,I8) 2771 CALL DPWRST('XXX','BUG ') 2772 ENDIF 2773C 2774C *************************************************************** 2775C ** STEP 3-- ** 2776C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** 2777C ** FOR THE RESPONSE VARIABLE IS 2 OR LARGER. ** 2778C *************************************************************** 2779C 2780 ISTEPN='3' 2781 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC') 2782 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2783C 2784 IF(NLEFT.GE.MINN2)GOTO390 2785 WRITE(ICOUT,999) 2786 CALL DPWRST('XXX','BUG ') 2787 WRITE(ICOUT,311) 2788 311 FORMAT('***** ERROR IN DPQCC--') 2789 CALL DPWRST('XXX','BUG ') 2790 WRITE(ICOUT,312) 2791 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') 2792 CALL DPWRST('XXX','BUG ') 2793 IF(ICASPL.EQ.'MECC')WRITE(ICOUT,321) 2794 321 FORMAT(' (FOR WHICH A Q MEAN CONTROL CHART ') 2795 IF(ICASPL.EQ.'MECC')CALL DPWRST('XXX','BUG ') 2796 IF(ICASPL.EQ.'SDCC')WRITE(ICOUT,322) 2797 322 FORMAT(' (FOR WHICH A Q STANDARD DEVIATION CONTROL CHART ') 2798 IF(ICASPL.EQ.'SDCC')CALL DPWRST('XXX','BUG ') 2799 IF(ICASPL.EQ.'RACC')WRITE(ICOUT,323) 2800 323 FORMAT(' (FOR WHICH A Q RANGE CONTROL CHART ') 2801 IF(ICASPL.EQ.'RACC')CALL DPWRST('XXX','BUG ') 2802 IF(ICASPL.EQ.'CUCC')WRITE(ICOUT,324) 2803 324 FORMAT(' (FOR WHICH A Q CUSUM CONTROL CHART ') 2804 IF(ICASPL.EQ.'CUCC')CALL DPWRST('XXX','BUG ') 2805 IF(ICASPL.EQ.'PCC')WRITE(ICOUT,325) 2806 325 FORMAT(' (FOR WHICH A Q P CONTROL CHART ') 2807 IF(ICASPL.EQ.'PCC')CALL DPWRST('XXX','BUG ') 2808 IF(ICASPL.EQ.'PNCC')WRITE(ICOUT,326) 2809 326 FORMAT(' (FOR WHICH A Q NP CONTROL CHART ') 2810 IF(ICASPL.EQ.'PNCC')CALL DPWRST('XXX','BUG ') 2811 IF(ICASPL.EQ.'CCC')WRITE(ICOUT,327) 2812 327 FORMAT(' (FOR WHICH A Q C CONTROL CHART ') 2813 IF(ICASPL.EQ.'CCC')CALL DPWRST('XXX','BUG ') 2814 IF(ICASPL.EQ.'UCC')WRITE(ICOUT,328) 2815 328 FORMAT(' (FOR WHICH A Q U CONTROL CHART ') 2816 IF(ICASPL.EQ.'UCC')CALL DPWRST('XXX','BUG ') 2817 WRITE(ICOUT,334) 2818 334 FORMAT(' WAS TO HAVE BEEN FORMED)') 2819 CALL DPWRST('XXX','BUG ') 2820 WRITE(ICOUT,335)MINN2 2821 335 FORMAT(' MUST BE ',I8,' OR LARGER;') 2822 CALL DPWRST('XXX','BUG ') 2823 WRITE(ICOUT,336) 2824 336 FORMAT(' SUCH WAS NOT THE CASE HERE.') 2825 CALL DPWRST('XXX','BUG ') 2826 WRITE(ICOUT,337) 2827 337 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') 2828 CALL DPWRST('XXX','BUG ') 2829 IF(IWIDTH.GE.1)WRITE(ICOUT,338)(IANS(I),I=1,IWIDTH) 2830 338 FORMAT(' ',80A1) 2831 IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') 2832 IERROR='YES' 2833 GOTO9000 2834 390 CONTINUE 2835C 2836C ***************************************** 2837C ** STEP 4-- ** 2838C ** CHECK TO SEE THE TYPE SUBCASE ** 2839C ** (BASED ON THE QUALIFIER)-- ** 2840C ** 1) UNQUALIFIED (THAT IS, FULL); ** 2841C ** 2) SUBSET/EXCEPT; OR ** 2842C ** 3) FOR. ** 2843C ***************************************** 2844C 2845 ISTEPN='4' 2846 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC') 2847 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2848C 2849 ICASEQ='FULL' 2850 ILOCQ=NUMARG+1 2851 IF(NUMARG.LT.1)GOTO480 2852 DO400J=1,NUMARG 2853 J1=J 2854 IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO410 2855 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO410 2856 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO420 2857 400 CONTINUE 2858 GOTO490 2859 410 CONTINUE 2860 ICASEQ='SUBS' 2861 ILOCQ=J1 2862 GOTO490 2863 420 CONTINUE 2864 ICASEQ='FOR' 2865 ILOCQ=J1 2866 GOTO490 2867C 2868 480 CONTINUE 2869 WRITE(ICOUT,999) 2870 CALL DPWRST('XXX','BUG ') 2871 WRITE(ICOUT,481) 2872 481 FORMAT('***** INTERNAL ERROR IN DPQCC') 2873 CALL DPWRST('XXX','BUG ') 2874 WRITE(ICOUT,482) 2875 482 FORMAT(' AT BRANCH POINT 481--') 2876 CALL DPWRST('XXX','BUG ') 2877 WRITE(ICOUT,483) 2878 483 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') 2879 CALL DPWRST('XXX','BUG ') 2880 WRITE(ICOUT,484) 2881 484 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') 2882 CALL DPWRST('XXX','BUG ') 2883 WRITE(ICOUT,485)NUMARG 2884 485 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) 2885 CALL DPWRST('XXX','BUG ') 2886 WRITE(ICOUT,486) 2887 486 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') 2888 CALL DPWRST('XXX','BUG ') 2889 IF(IWIDTH.GE.1)WRITE(ICOUT,487)(IANS(I),I=1,IWIDTH) 2890 487 FORMAT(' ',80A1) 2891 IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') 2892 IERROR='YES' 2893 GOTO9000 2894C 2895 490 CONTINUE 2896 IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PQCC')GOTO495 2897 WRITE(ICOUT,491)NUMARG,ILOCQ,ICASEQ 2898 491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) 2899 CALL DPWRST('XXX','BUG ') 2900 495 CONTINUE 2901C 2902C ************************************************************ 2903C ** STEP 5-- ** 2904C ** IF A SECOND ARGUMENT EXISTS, THEN THIS ** 2905C ** INDICATES THAT THE VALUES IN THE ** 2906C ** FIRST VARIABLE ARE TO BE GROUPED ** 2907C ** BASED ON VALUES OF THE SECOND VARIABLE; ** 2908C ** THAT IS, THE SECOND VARAIBLE DEFINES THE ** 2909C ** GROUP NUMBERS WITHIN WHICH THE MEANS, ** 2910C ** STANDARD DEVIATIONS, RANGES, AND ** 2911C ** CUMULATIVE SUMS ARE TO BE COMPUTED. ** 2912C ** THE VALUES IN THE SECOND VARIABLE ** 2913C ** ARE THE X VALUES FOR EACH MEAN, STANDARD DEVIATION, ** 2914C ** ETC. IN THE RESULTING Q CONTROL CHART. ** 2915C ** THE VALUES IN THE SECOND VARIABLE ** 2916C ** NEED NOT HAVE BEEN PREVIOUSLY ** 2917C ** SORTED OR HAVE COMMON VALUES ADJACENT. ** 2918C ** IF WE HAVE THE 2-VARIABLE CASE, ** 2919C ** CHECK THE VALIDITY OF THE SECOND (X) VARIABLE. ** 2920C ************************************************************ 2921C 2922 ISTEPN='5' 2923 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC') 2924 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2925C 2926 NUMV2=ILOCQ-1 2927 IF(NUMV2.EQ.1)GOTO599 2928 IF(NUMV2.EQ.2)GOTO530 2929 IF(NUMV2.EQ.3)GOTO540 2930 GOTO510 2931C 2932 510 CONTINUE 2933 WRITE(ICOUT,999) 2934 CALL DPWRST('XXX','BUG ') 2935 WRITE(ICOUT,511) 2936 511 FORMAT('***** ERROR IN DPQCC--') 2937 CALL DPWRST('XXX','BUG ') 2938 IF(ICASPL.EQ.'MECC')WRITE(ICOUT,512) 2939 512 FORMAT(' FOR A Q MEAN CONTROL CHART, ') 2940 IF(ICASPL.EQ.'MECC')CALL DPWRST('XXX','BUG ') 2941 IF(ICASPL.EQ.'SDCC')WRITE(ICOUT,513) 2942 513 FORMAT(' FOR A Q STANDARD DEVIATION CONTROL CHART, ') 2943 IF(ICASPL.EQ.'SDCC')CALL DPWRST('XXX','BUG ') 2944 IF(ICASPL.EQ.'RACC')WRITE(ICOUT,514) 2945 514 FORMAT(' FOR A Q RANGE CONTROL CHART, ') 2946 IF(ICASPL.EQ.'RACC')CALL DPWRST('XXX','BUG ') 2947 IF(ICASPL.EQ.'CUCC')WRITE(ICOUT,515) 2948 515 FORMAT(' FOR A Q CUSUM CONTROL CHART, ') 2949 IF(ICASPL.EQ.'CUCC')CALL DPWRST('XXX','BUG ') 2950 IF(ICASPL.EQ.'PCC')WRITE(ICOUT,516) 2951 516 FORMAT(' (FOR WHICH A Q P CONTROL CHART ') 2952 IF(ICASPL.EQ.'PCC')CALL DPWRST('XXX','BUG ') 2953 IF(ICASPL.EQ.'PNCC')WRITE(ICOUT,517) 2954 517 FORMAT(' (FOR WHICH A Q NP CONTROL CHART ') 2955 IF(ICASPL.EQ.'PNCC')CALL DPWRST('XXX','BUG ') 2956 IF(ICASPL.EQ.'CCC')WRITE(ICOUT,518) 2957 518 FORMAT(' (FOR WHICH A Q C CONTROL CHART ') 2958 IF(ICASPL.EQ.'CCC')CALL DPWRST('XXX','BUG ') 2959 IF(ICASPL.EQ.'UCC')WRITE(ICOUT,519) 2960 519 FORMAT(' (FOR WHICH A Q U CONTROL CHART ') 2961 IF(ICASPL.EQ.'UCC')CALL DPWRST('XXX','BUG ') 2962 WRITE(ICOUT,523) 2963 523 FORMAT(' THE NUMBER OF VARIABLES ') 2964 CALL DPWRST('XXX','BUG ') 2965 WRITE(ICOUT,524) 2966 524 FORMAT(' MUST BE EITHER 1 OR 2 ;') 2967 CALL DPWRST('XXX','BUG ') 2968 WRITE(ICOUT,525) 2969 525 FORMAT(' SUCH WAS NOT THE CASE HERE;') 2970 CALL DPWRST('XXX','BUG ') 2971 WRITE(ICOUT,526) 2972 526 FORMAT(' THE SPECIFIED NUMBER') 2973 CALL DPWRST('XXX','BUG ') 2974 WRITE(ICOUT,527)NUMV2 2975 527 FORMAT(' OF VARIABLES WAS ',I8) 2976 CALL DPWRST('XXX','BUG ') 2977 WRITE(ICOUT,528) 2978 528 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') 2979 CALL DPWRST('XXX','BUG ') 2980 IF(IWIDTH.GE.1)WRITE(ICOUT,529)(IANS(I),I=1,IWIDTH) 2981 529 FORMAT(' ',80A1) 2982 IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') 2983 IERROR='YES' 2984 GOTO9000 2985C 2986 530 CONTINUE 2987 IHHOR=IHARG(2) 2988 IHHOR2=IHARG2(2) 2989 IHWUSE='V' 2990 MESSAG='YES' 2991 CALL CHECKN(IHHOR,IHHOR2,IHWUSE, 2992 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 2993 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 2994 IF(IERROR.EQ.'YES')GOTO9000 2995 ICOLH=IVALUE(ILOCV) 2996 NHOR=IN(ILOCV) 2997 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC')THEN 2998 WRITE(ICOUT,531)IHHOR,ICOLH,NHOR 2999 531 FORMAT('IHHOR,ICOLH,NHOR = ',A4,I8,I8) 3000 CALL DPWRST('XXX','BUG ') 3001 ENDIF 3002 IF(NHOR.NE.NLEFT)GOTO570 3003 GOTO599 3004C 3005 540 CONTINUE 3006C IHEXT AS IN "EXTRA" 3007 IHEXT=IHARG(2) 3008 IHEXT2=IHARG2(2) 3009 IHWUSE='V' 3010 MESSAG='YES' 3011 CALL CHECKN(IHEXT,IHEXT2,IHWUSE, 3012 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 3013 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 3014 IF(IERROR.EQ.'YES')GOTO9000 3015 ICOLE=IVALUE(ILOCV) 3016 NEXT=IN(ILOCV) 3017 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC')THEN 3018 WRITE(ICOUT,541)IHEXT,ICOLE,NEXT 3019 541 FORMAT('IHEXT,ICOLE,NEXT = ',A4,I8,I8) 3020 CALL DPWRST('XXX','BUG ') 3021 ENDIF 3022 IF(NEXT.NE.NLEFT)GOTO570 3023C 3024 IHHOR=IHARG(3) 3025 IHHOR2=IHARG2(3) 3026 IHWUSE='V' 3027 MESSAG='YES' 3028 CALL CHECKN(IHHOR,IHHOR2,IHWUSE, 3029 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 3030 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 3031 IF(IERROR.EQ.'YES')GOTO9000 3032 ICOLH=IVALUE(ILOCV) 3033 NHOR=IN(ILOCV) 3034 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC')THEN 3035 WRITE(ICOUT,542)IHHOR,ICOLH,NHOR 3036 542 FORMAT('IHHOR,ICOLH,NHOR = ',A4,I8,I8) 3037 CALL DPWRST('XXX','BUG ') 3038 ENDIF 3039 IF(NHOR.NE.NLEFT)GOTO570 3040 GOTO599 3041C 3042 570 CONTINUE 3043 WRITE(ICOUT,999) 3044 CALL DPWRST('XXX','BUG ') 3045 WRITE(ICOUT,571) 3046 571 FORMAT('***** ERROR IN DPQCC--') 3047 CALL DPWRST('XXX','BUG ') 3048 IF(ICASPL.EQ.'MECC')WRITE(ICOUT,572) 3049 572 FORMAT(' FOR A Q MEAN CONTROL CHART, ') 3050 IF(ICASPL.EQ.'MECC')CALL DPWRST('XXX','BUG ') 3051 IF(ICASPL.EQ.'SDCC')WRITE(ICOUT,573) 3052 573 FORMAT(' FOR A Q STANDARD DEVIATION CONTROL CHART,') 3053 IF(ICASPL.EQ.'SDCC')CALL DPWRST('XXX','BUG ') 3054 IF(ICASPL.EQ.'RACC')WRITE(ICOUT,574) 3055 574 FORMAT(' FOR A Q RANGE CONTROL CHART, ') 3056 IF(ICASPL.EQ.'RACC')CALL DPWRST('XXX','BUG ') 3057 IF(ICASPL.EQ.'CUCC')WRITE(ICOUT,575) 3058 575 FORMAT(' FOR A Q CUSUM CONTROL CHART,') 3059 IF(ICASPL.EQ.'CUCC')CALL DPWRST('XXX','BUG ') 3060 IF(ICASPL.EQ.'PCC')WRITE(ICOUT,576) 3061 576 FORMAT(' (FOR WHICH A P CONTROL CHART ') 3062 IF(ICASPL.EQ.'PCC')CALL DPWRST('XXX','BUG ') 3063 IF(ICASPL.EQ.'PNCC')WRITE(ICOUT,577) 3064 577 FORMAT(' (FOR WHICH A NP CONTROL CHART ') 3065 IF(ICASPL.EQ.'PNCC')CALL DPWRST('XXX','BUG ') 3066 IF(ICASPL.EQ.'CCC')WRITE(ICOUT,578) 3067 578 FORMAT(' (FOR WHICH A Q C CONTROL CHART ') 3068 IF(ICASPL.EQ.'CCC')CALL DPWRST('XXX','BUG ') 3069 IF(ICASPL.EQ.'UCC')WRITE(ICOUT,579) 3070 579 FORMAT(' (FOR WHICH A Q U CONTROL CHART ') 3071 IF(ICASPL.EQ.'UCC')CALL DPWRST('XXX','BUG ') 3072 WRITE(ICOUT,584) 3073 584 FORMAT(' WHEN HAVE 2 (OR 3) VARAIBLES SPECIFIED, ') 3074 CALL DPWRST('XXX','BUG ') 3075 WRITE(ICOUT,585) 3076 585 FORMAT(' THE NUMBER OF ELEMENTS') 3077 CALL DPWRST('XXX','BUG ') 3078 WRITE(ICOUT,586) 3079 586 FORMAT(' IN THE 2 (OR 3) VARIABLES ') 3080 CALL DPWRST('XXX','BUG ') 3081 WRITE(ICOUT,587) 3082 587 FORMAT(' MUST BE THE SAME; ') 3083 CALL DPWRST('XXX','BUG ') 3084 WRITE(ICOUT,588) 3085 588 FORMAT(' SUCH WAS NOT THE CASE HERE.') 3086 CALL DPWRST('XXX','BUG ') 3087 WRITE(ICOUT,999) 3088 CALL DPWRST('XXX','BUG ') 3089 WRITE(ICOUT,589) 3090 589 FORMAT(' THE FIRST VARIABLE (RESPONSE VALUES)--') 3091 CALL DPWRST('XXX','BUG ') 3092 WRITE(ICOUT,590)IHLEFT,NLEFT 3093 590 FORMAT(' ',A4,' HAS ',I8,' ELEMENTS') 3094 CALL DPWRST('XXX','BUG ') 3095 WRITE(ICOUT,591) 3096 591 FORMAT(' THE 2ND VARIABLE--') 3097 CALL DPWRST('XXX','BUG ') 3098 IF(NUMV2.EQ.3)WRITE(ICOUT,592)IHEXT,NEXT 3099 IF(NUMV2.EQ.3)CALL DPWRST('XXX','BUG ') 3100 IF(NUMV2.EQ.2)WRITE(ICOUT,592)IHHOR,NHOR 3101 592 FORMAT(' ',A4,' HAS ',I8,' ELEMENTS') 3102 IF(NUMV2.EQ.2)CALL DPWRST('XXX','BUG ') 3103 IF(NUMV2.EQ.3)WRITE(ICOUT,593) 3104 593 FORMAT(' THE 3ND VARIABLE (HORIZ. AXIS VALUES)--') 3105 IF(NUMV2.EQ.3)CALL DPWRST('XXX','BUG ') 3106 WRITE(ICOUT,594)IHHOR,NHOR 3107 594 FORMAT(' ',A4,' HAS ',I8,' ELEMENTS') 3108 CALL DPWRST('XXX','BUG ') 3109 WRITE(ICOUT,999) 3110 CALL DPWRST('XXX','BUG ') 3111 WRITE(ICOUT,595) 3112 595 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') 3113 CALL DPWRST('XXX','BUG ') 3114 IF(IWIDTH.GE.1)WRITE(ICOUT,596)(IANS(I),I=1,IWIDTH) 3115 596 FORMAT(' ',80A1) 3116 IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') 3117 IERROR='YES' 3118 GOTO9000 3119C 3120 599 CONTINUE 3121C 3122C ************************************************* 3123C ** STEP 6-- ** 3124C ** BRANCH TO THE APPROPRIATE SUBCASE; ** 3125C ** (BASED ON THE QUALIFIER) ** 3126C ** THEN FORM THE RESPONSE VARIABLE ** 3127C ** AND THE SECOND VARIABLE (IF EXISTENT) ** 3128C ************************************************* 3129C 3130 ISTEPN='6' 3131 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC') 3132 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3133C 3134 IF(ICASEQ.EQ.'FULL')GOTO610 3135 IF(ICASEQ.EQ.'SUBS')GOTO620 3136 IF(ICASEQ.EQ.'FOR')GOTO630 3137C 3138 610 CONTINUE 3139 DO615I=1,NLEFT 3140 ISUB(I)=1 3141 615 CONTINUE 3142 NQ=NLEFT 3143 GOTO650 3144C 3145 620 CONTINUE 3146 NIOLD=NLEFT 3147 CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) 3148 NQ=NIOLD 3149 GOTO650 3150C 3151 630 CONTINUE 3152 NIOLD=NLEFT 3153 CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 3154 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) 3155 NQ=NFOR 3156 GOTO650 3157C 3158 650 CONTINUE 3159 J=0 3160 IMAX=NLEFT 3161 IF(NQ.LT.NLEFT)IMAX=NQ 3162 DO660I=1,IMAX 3163 IF(ISUB(I).EQ.0)GOTO660 3164 J=J+1 3165C 3166 IJ=MAXN*(ICOLL-1)+I 3167 IF(ICOLL.LE.MAXCOL)Y1(J)=V(IJ) 3168 IF(ICOLL.EQ.MAXCP1)Y1(J)=PRED(I) 3169 IF(ICOLL.EQ.MAXCP2)Y1(J)=RES(I) 3170 IF(ICOLL.EQ.MAXCP3)Y1(J)=YPLOT(I) 3171 IF(ICOLL.EQ.MAXCP4)Y1(J)=XPLOT(I) 3172 IF(ICOLL.EQ.MAXCP5)Y1(J)=X2PLOT(I) 3173 IF(ICOLL.EQ.MAXCP6)Y1(J)=TAGPLO(I) 3174 IF(NUMV2.LE.1)GOTO660 3175C 3176 IF(NUMV2.EQ.2)GOTO652 3177 GOTO653 3178C 3179 652 CONTINUE 3180 IJ=MAXN*(ICOLH-1)+I 3181 IF(ICOLH.LE.MAXCOL)X1(J)=V(IJ) 3182 IF(ICOLH.EQ.MAXCP1)X1(J)=PRED(I) 3183 IF(ICOLH.EQ.MAXCP2)X1(J)=RES(I) 3184 IF(ICOLH.EQ.MAXCP3)X1(J)=YPLOT(I) 3185 IF(ICOLH.EQ.MAXCP4)X1(J)=XPLOT(I) 3186 IF(ICOLH.EQ.MAXCP5)X1(J)=X2PLOT(I) 3187 IF(ICOLH.EQ.MAXCP6)X1(J)=TAGPLO(I) 3188 GOTO660 3189C 3190 653 CONTINUE 3191 IJ=MAXN*(ICOLE-1)+I 3192 IF(ICOLE.LE.MAXCOL)Y2(J)=V(IJ) 3193 IF(ICOLE.EQ.MAXCP1)Y2(J)=PRED(I) 3194 IF(ICOLE.EQ.MAXCP2)Y2(J)=RES(I) 3195 IF(ICOLE.EQ.MAXCP3)Y2(J)=YPLOT(I) 3196 IF(ICOLE.EQ.MAXCP4)Y2(J)=XPLOT(I) 3197 IF(ICOLE.EQ.MAXCP5)Y2(J)=X2PLOT(I) 3198 IF(ICOLE.EQ.MAXCP6)Y2(J)=TAGPLO(I) 3199C 3200 IJ=MAXN*(ICOLH-1)+I 3201 IF(ICOLH.LE.MAXCOL)X1(J)=V(IJ) 3202 IF(ICOLH.EQ.MAXCP1)X1(J)=PRED(I) 3203 IF(ICOLH.EQ.MAXCP2)X1(J)=RES(I) 3204 IF(ICOLH.EQ.MAXCP3)X1(J)=YPLOT(I) 3205 IF(ICOLH.EQ.MAXCP4)X1(J)=XPLOT(I) 3206 IF(ICOLH.EQ.MAXCP5)X1(J)=X2PLOT(I) 3207 IF(ICOLH.EQ.MAXCP6)X1(J)=TAGPLO(I) 3208 GOTO660 3209C 3210 660 CONTINUE 3211 NLOCAL=J 3212C 3213C **************************************************************** 3214C ** STEP 8-- ** 3215C ** DETERMINE IF THE ANALYST ** 3216C ** HAS SPECIFIED 3217C ** LSL (LOWER SPEC LIMIT) 3218C ** USL (UPPER SPEC LIMIT) 3219C ** USLCOST (UPPER SPEC LIMIT COST) 3220C ** TARGET 3221C ** FOR THE Q CONTROL CHART ANALYSIS. ** 3222C **************************************************************** 3223C 3224 ISTEPN='8' 3225 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC') 3226 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3227C 3228 CCLSL=CPUMIN 3229 IH='LSL ' 3230 IH2=' ' 3231 IHWUSE='P' 3232 MESSAG='NO' 3233 CALL CHECKN(IH,IH2,IHWUSE, 3234 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 3235 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) 3236 IF(IERRO2.EQ.'NO')CCLSL=VALUE(ILOCP) 3237C 3238 CCUSL=CPUMIN 3239 IH='USL ' 3240 IH2=' ' 3241 IHWUSE='P' 3242 MESSAG='NO' 3243 CALL CHECKN(IH,IH2,IHWUSE, 3244 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 3245 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) 3246 IF(IERRO2.EQ.'NO')CCUSL=VALUE(ILOCP) 3247C 3248 CCTARG=CPUMIN 3249 IH='TARG' 3250 IH2='ET ' 3251 IHWUSE='P' 3252 MESSAG='NO' 3253 CALL CHECKN(IH,IH2,IHWUSE, 3254 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 3255 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) 3256 IF(IERRO2.EQ.'NO')CCTARG=VALUE(ILOCP) 3257C 3258C ************************************************************* 3259C ** STEP 9-- ** 3260C ** COMPUTE THE APPROPRIATE Q CONTROL CHART STATISTIC-- ** 3261C ** MEAN, STANDARD DEVIATION, RANGE, CUSUM, ** 3262C ** P, NP, C, U. ** 3263C ** COMPUTE CONFIDENCE LINES. ** 3264C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** 3265C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** 3266C ** DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S ** 3267C ** FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE LINE, ** 3268C ** AND THE UPPER CONFIDENCE LINE. ** 3269C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** 3270C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** 3271C ************************************************************* 3272C 3273 ISTEPN='8' 3274 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC') 3275 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3276C 3277 CALL DPQCC2(Y1,Y2,X1,NLOCAL,NUMV2,ICASPL,ISIZE,ICONT, 3278 1 XIDTEM,TEMP,CCLSL,CCUSL,CCTARG, 3279 1 Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) 3280C 3281C ***************** 3282C ** STEP 90-- ** 3283C ** EXIT ** 3284C ***************** 3285C 3286 9000 CONTINUE 3287 IF(IBUGG2.EQ.'ON' .OR. ISUBRO.NE.'PQCC')THEN 3288 WRITE(ICOUT,999) 3289 CALL DPWRST('XXX','BUG ') 3290 WRITE(ICOUT,9011) 3291 9011 FORMAT('***** AT THE END OF DPQCC--') 3292 CALL DPWRST('XXX','BUG ') 3293 WRITE(ICOUT,9012)IFOUND,IERROR,ISIZE 3294 9012 FORMAT('IFOUND,IERROR,ISIZE = ',2(A4,2X),I8) 3295 CALL DPWRST('XXX','BUG ') 3296 WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 3297 9013 FORMAT('PNLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 3298 1 3I8,3(2X,A4)) 3299 CALL DPWRST('XXX','BUG ') 3300 IF(NPLOTP.GE.1)THEN 3301 DO9015I=1,NPLOTP 3302 WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 3303 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) 3304 CALL DPWRST('XXX','BUG ') 3305 9015 CONTINUE 3306 ENDIF 3307 ENDIF 3308C 3309 RETURN 3310 END 3311 SUBROUTINE DPQCC2(Y,YN,X,N,NUMV2,ICASPL,ISIZE,ICONT, 3312 1 XIDTEM,TEMP,CCLSL,CCUSL,CCTARG, 3313 1 Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR) 3314C 3315C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS 3316C THAT WILL DEFINE A Q (= QUESENBERRY) CONTROL CHART 3317C OF THE FOLLOWING TYPES-- 3318C 1) Q MEAN CONTROL CHART Y X 3319C 2) Q STANDARD DEVIATION CONTROL CHART Y X 3320C 3) Q RANGE CONTROL CHART Y X 3321C 4) Q CUSUM CONTROL CHART Y X 3322C 5) Q P CONTROL CHART NUMDEF NUMTOT X 3323C 6) Q PN CONTROL CHART NUMDEF NUMTOT X 3324C 7) Q U CONTROL CHART NUMDEF SIZE X 3325C 8) Q P CONTROL CHART NUMDEF SIZE X 3326C NOTE--USE P AND PN CHARTS IF KNOW HOW MANY ITEMS HAVE DEFECTS 3327C --USE U AND C CHARTS IF KNOW HOW MANY DEFECTS 3328C WRITTEN BY--JAMES J. FILLIBEN 3329C STATISTICAL ENGINEERING DIVISION 3330C INFORMATION TECHNOLOGY LABORATORY 3331C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 3332C GAITHERSBURG, MD 20899-8980 3333C PHONE--301-975-2855 3334C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 3335C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 3336C REFERENCE--QUESENBERRY, CHARLES P. SPC Q CHARTS FOR START-UP 3337C PROCESSES AND SHORT OR LONG RUNS. 3338C JOURNAL OF QUALITY TECNOLOGY, JULY 1991, 3339C PAGES 213-224. 3340C REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105 3341C REFERENCE--ISHIKAWA, GUIDE TO QUALITY CONTROL 3342C LANGUAGE--ANSI FORTRAN (1977) 3343C VERSION NUMBER--93/12 3344C ORIGINAL VERSION--DECEMBER 1993. 3345C UPDATED --OCTOBER 2006. CALL LIST TO TCDF 3346C 3347C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 3348C 3349 CHARACTER*4 ICASPL 3350 CHARACTER*4 ICONT 3351 CHARACTER*4 IBUGG3 3352 CHARACTER*4 ISUBRO 3353 CHARACTER*4 IERROR 3354C 3355 CHARACTER*4 ISUBN1 3356 CHARACTER*4 ISUBN2 3357 CHARACTER*4 ISTEPN 3358C 3359C--------------------------------------------------------------------- 3360C 3361 DIMENSION Y(*) 3362 DIMENSION YN(*) 3363 DIMENSION X(*) 3364 DIMENSION Y2(*) 3365 DIMENSION X2(*) 3366 DIMENSION D2(*) 3367C 3368 DIMENSION XIDTEM(*) 3369 DIMENSION TEMP(*) 3370C 3371CCCCC DIMENSION A3(30) 3372 DIMENSION C4(30) 3373 DIMENSION B3(30) 3374 DIMENSION B4(30) 3375 DIMENSION D22(30) 3376 DIMENSION D3(30) 3377 DIMENSION D4(30) 3378C 3379C--------------------------------------------------------------------- 3380C 3381 INCLUDE 'DPCOP2.INC' 3382C 3383C-----DATA STATEMENTS------------------------------------------------- 3384C 3385CCCCC DATA(A3(I),I= 1, 25) 3386CCCCC1/9.999,2.659,1.954,1.628,1.427, 3387CCCCC1 1.287,1.182,1.099,1.032,0.975, 3388CCCCC1 0.927,0.886,0.850,0.817,0.789, 3389CCCCC1 0.763,0.739,0.718,0.698,0.680, 3390CCCCC1 0.663,0.647,0.633,0.619,0.606/ 3391 DATA(C4(I),I= 1, 25) 3392 1/9.9999,0.7979,0.8862,0.9213,0.9400, 3393 1 0.9515,0.9594,0.9650,0.9693,0.9727, 3394 1 0.9754,0.9776,0.9794,0.9810,0.9823, 3395 1 0.9835,0.9845,0.9854,0.9862,0.9869, 3396 1 0.9876,0.9882,0.9887,0.9892,0.9896/ 3397 DATA(B3(I),I= 1, 25) 3398 1/0.000,0.000,0.000,0.000,0.000,0.030,0.118,0.185,0.239,0.284, 3399 1 0.321,0.354,0.382,0.406,0.428,0.448,0.466,0.482,0.497,0.510, 3400 1 0.523,0.534,0.545,0.555,0.565/ 3401 DATA(B4(I),I= 1, 25) 3402 1/9.999,3.267,2.568,2.266,2.089,1.970,1.882,1.815,1.761,1.716, 3403 1 1.679,1.646,1.618,1.594,1.572,1.552,1.534,1.518,1.503,1.490, 3404 1 1.477,1.466,1.455,1.445,1.435/ 3405 DATA(D22(I),I= 1, 25) 3406 1/9.999,3.686,4.358,4.698,4.918,5.078,5.203,5.307,5.394,5.469, 3407 1 5.534,5.592,5.646,5.693,5.737,5.779,5.817,5.854,5.888,5.922, 3408 1 5.950,5.979,6.006,6.031,6.058/ 3409 DATA(D3(I),I= 1, 25) 3410 1/0.000,0.000,0.000,0.000,0.000,0.000,0.076,0.136,0.184,0.223, 3411 1 0.256,0.284,0.308,0.329,0.348,0.364,0.379,0.392,0.404,0.414, 3412 1 0.425,0.434,0.443,0.452,0.459/ 3413 DATA(D4(I),I= 1, 25) 3414 1/9.999,3.267,2.575,2.282,2.115,2.004,1.924,1.864,1.816,1.777, 3415 1 1.744,1.716,1.692,1.671,1.652,1.636,1.621,1.608,1.596,1.586, 3416 1 1.575,1.566,1.557,1.548,1.541/ 3417C 3418C-----START POINT----------------------------------------------------- 3419C 3420 ISUBN1='DPQC' 3421 ISUBN2='C2 ' 3422C 3423 I2=0 3424 ISIZE2=0 3425C 3426 AN=0.0 3427 XBARG=0.0 3428 SDG=0.0 3429 RANGEG=0.0 3430 YUPPER=0.0 3431 YLOWER=0.0 3432C 3433 ANUMSE=0.0 3434 SDI=0.0 3435 SIGMAE=0.0 3436 RANGEE=0.0 3437 SADJ=0.0 3438 RADJ=0.0 3439C 3440C CHECK THE INPUT ARGUMENTS FOR ERRORS 3441C 3442 IF(N.GE.1)GOTO39 3443 WRITE(ICOUT,999) 3444 999 FORMAT(1X) 3445 CALL DPWRST('XXX','BUG ') 3446 WRITE(ICOUT,31) 3447 31 FORMAT('***** ERROR IN DPQCC2--') 3448 CALL DPWRST('XXX','BUG ') 3449 WRITE(ICOUT,32) 3450 32 FORMAT(' THE NUMBER OF OBSERVATIONS') 3451 CALL DPWRST('XXX','BUG ') 3452 WRITE(ICOUT,33) 3453 33 FORMAT(' MUST BE AT LEAST 1;') 3454 CALL DPWRST('XXX','BUG ') 3455 WRITE(ICOUT,34)N 3456 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) 3457 CALL DPWRST('XXX','BUG ') 3458 WRITE(ICOUT,999) 3459 CALL DPWRST('XXX','BUG ') 3460 IERROR='YES' 3461 GOTO9000 3462 39 CONTINUE 3463C 3464 IF(N.GE.2)GOTO49 3465 WRITE(ICOUT,999) 3466 CALL DPWRST('XXX','BUG ') 3467 WRITE(ICOUT,46) 3468 46 FORMAT('***** ERROR IN DPQCC2--') 3469 CALL DPWRST('XXX','BUG ') 3470 WRITE(ICOUT,47) 3471 47 FORMAT(' THE NUMBER OF OBSERVATIONS') 3472 CALL DPWRST('XXX','BUG ') 3473 WRITE(ICOUT,48) 3474 48 FORMAT(' WAS EXACTLY EQUAL TO 1.') 3475 CALL DPWRST('XXX','BUG ') 3476 WRITE(ICOUT,999) 3477 CALL DPWRST('XXX','BUG ') 3478 IERROR='YES' 3479 GOTO9000 3480 49 CONTINUE 3481C 3482 HOLD=Y(1) 3483 DO60I=1,N 3484 IF(Y(I).NE.HOLD)GOTO69 3485 60 CONTINUE 3486 WRITE(ICOUT,999) 3487 CALL DPWRST('XXX','BUG ') 3488 WRITE(ICOUT,61) 3489 61 FORMAT('***** ERROR IN DPQCC2--') 3490 CALL DPWRST('XXX','BUG ') 3491 WRITE(ICOUT,62) 3492 62 FORMAT(' ALL RESPONSE VARIABLE ELEMENTS') 3493 CALL DPWRST('XXX','BUG ') 3494 WRITE(ICOUT,63)HOLD 3495 63 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7) 3496 CALL DPWRST('XXX','BUG ') 3497 WRITE(ICOUT,999) 3498 CALL DPWRST('XXX','BUG ') 3499 IERROR='YES' 3500 GOTO9000 3501 69 CONTINUE 3502C 3503 3504 IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'QCC2')GOTO90 3505 WRITE(ICOUT,70) 3506 70 FORMAT('AT THE BEGINNING OF DPQCC2--') 3507 CALL DPWRST('XXX','BUG ') 3508 WRITE(ICOUT,71)N,ICASPL,NUMV2,ISIZE,ICONT 3509 71 FORMAT('N,ICASPL,NUMV2,ISIZE,ICONT = ',I8,2X,A4,I8,I8,2X,A4) 3510 CALL DPWRST('XXX','BUG ') 3511 DO72I=1,N 3512 WRITE(ICOUT,73)I,Y(I),X(I) 3513 73 FORMAT('I, Y(I), X(I) = ',I8,3F15.7) 3514 CALL DPWRST('XXX','BUG ') 3515 72 CONTINUE 3516 IF(NUMV2.LE.2)GOTO79 3517 DO75I=1,N 3518 WRITE(ICOUT,76)I,YN(I),X(I) 3519 76 FORMAT('I,YN(I),X(I) = ',I8,2E15.7) 3520 CALL DPWRST('XXX','BUG ') 3521 75 CONTINUE 3522 79 CONTINUE 3523 90 CONTINUE 3524C 3525C ******************************************************** 3526C ** STEP 1-- ** 3527C ** DETERMINE THE NUMBER OF DISTINCT VALUES ** 3528C ** FOR VARIABLE 2 (THE GROUP VARIABLE). ** 3529C ** IF ALL VALUES ARE DISTINCT, THEN THIS ** 3530C ** IMPLIES WE HAVE THE NO REPLICATION CASE ** 3531C ** WHICH IS AN ERROR CONDITION FOR A Q CONTROL CHART. ** 3532C ******************************************************** 3533C 3534 ISTEPN='1' 3535 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2') 3536 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3537C 3538 NUMSET=(-999) 3539 IF(NUMV2.EQ.1)GOTO199 3540 IF(NUMV2.EQ.2)GOTO150 3541C 3542 150 CONTINUE 3543 NUMSET=0 3544 DO160I=1,N 3545 IF(NUMSET.EQ.0)GOTO165 3546 DO170J=1,NUMSET 3547 IF(X(I).EQ.XIDTEM(J))GOTO160 3548 170 CONTINUE 3549 165 CONTINUE 3550 NUMSET=NUMSET+1 3551 XIDTEM(NUMSET)=X(I) 3552 160 CONTINUE 3553 CALL SORT(XIDTEM,NUMSET,XIDTEM) 3554C 3555 IF(NUMSET.GE.1)GOTO194 3556 WRITE(ICOUT,999) 3557 CALL DPWRST('XXX','BUG ') 3558 WRITE(ICOUT,191) 3559 191 FORMAT('***** ERROR IN DPQCC2 SUBROUTINE--') 3560 CALL DPWRST('XXX','BUG ') 3561 WRITE(ICOUT,192) 3562 192 FORMAT(' NUMBER OF SETS NUMSET = 0 ') 3563 CALL DPWRST('XXX','BUG ') 3564 IERROR='YES' 3565 GOTO9000 3566 194 CONTINUE 3567C 3568 IF(ICASPL.EQ.'PCC')GOTO199 3569 IF(ICASPL.EQ.'PNCC')GOTO199 3570 IF(ICASPL.EQ.'UCC')GOTO199 3571 IF(ICASPL.EQ.'CCC')GOTO199 3572C 3573 IF(NUMSET.NE.N)GOTO199 3574 WRITE(ICOUT,999) 3575 CALL DPWRST('XXX','BUG ') 3576 WRITE(ICOUT,195) 3577 195 FORMAT('***** ERROR IN DPQCC2 SUBROUTINE--') 3578 CALL DPWRST('XXX','BUG ') 3579 WRITE(ICOUT,196) 3580 196 FORMAT(' NUMBER OF SETS NUMSET IDENTICAL TO ') 3581 CALL DPWRST('XXX','BUG ') 3582 WRITE(ICOUT,197) 3583 197 FORMAT(' NUMBER OF OBSERVATIONS N .') 3584 CALL DPWRST('XXX','BUG ') 3585 WRITE(ICOUT,198)NUMSET 3586 198 FORMAT(' NUMSET = N = ',I8) 3587 CALL DPWRST('XXX','BUG ') 3588 IERROR='YES' 3589 GOTO9000 3590 199 CONTINUE 3591C 3592 AN=N 3593 ANUMSE=NUMSET 3594C 3595C ******************************************* 3596C ** STEP 3.0-- ** 3597C ** DETERMINE STATISTICS FOR THE ENTIRE ** 3598C ** DATA SET ** 3599C ******************************************* 3600C 3601 ISTEPN='3.0' 3602 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2') 3603 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3604C 3605 IF(NUMV2.EQ.1)GOTO1090 3606C 3607 SUMXBG=0.0 3608 SUMSDG=0.0 3609 SUMRAG=0.0 3610 SUMSIE=0.0 3611 SUMRIE=0.0 3612 J=0 3613 DO1010ISET=1,NUMSET 3614 J=J+1 3615C 3616 K=0 3617 DO1020I=1,N 3618 IF(X(I).EQ.XIDTEM(ISET))K=K+1 3619 IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I) 3620 1020 CONTINUE 3621 NI=K 3622 ANI=NI 3623C 3624 SUM=0.0 3625 IF(NI.LE.0)GOTO1040 3626 DO1030I=1,NI 3627 SUM=SUM+TEMP(I) 3628 1030 CONTINUE 3629 XBARI=SUM/ANI 3630C 3631 SUM=0.0 3632 DO1032I=1,NI 3633 SUM=SUM+(TEMP(I)-XBARI)**2 3634 1032 CONTINUE 3635 DENOM=ANI-1.0 3636 VARI=0.0 3637 IF(NI.GE.2)VARI=SUM/DENOM 3638 SDI=0.0 3639 IF(VARI.GT.0.0)SDI=SQRT(VARI) 3640C 3641 XTMIN=TEMP(1) 3642 XTMAX=TEMP(1) 3643 DO1034I=1,NI 3644 IF(TEMP(I).LT.XTMIN)XTMIN=TEMP(I) 3645 IF(TEMP(I).GT.XTMAX)XTMAX=TEMP(I) 3646 1034 CONTINUE 3647 RANGEI=XTMAX-XTMIN 3648 GOTO1049 3649C 3650 1040 CONTINUE 3651 WRITE(ICOUT,999) 3652 CALL DPWRST('XXX','BUG ') 3653 WRITE(ICOUT,1041) 3654 1041 FORMAT('***** INTERNAL ERROR IN DPQCC2--') 3655 CALL DPWRST('XXX','BUG ') 3656 WRITE(ICOUT,1042) 3657 1042 FORMAT('NI FOR SOME CLASS = 0') 3658 CALL DPWRST('XXX','BUG ') 3659 WRITE(ICOUT,1043)ISET,XIDTEM(ISET),NI 3660 1043 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8) 3661 CALL DPWRST('XXX','BUG ') 3662 IERROR='YES' 3663 GOTO9000 3664 1049 CONTINUE 3665C 3666 SUMXBG=SUMXBG+ANI*XBARI 3667 SUMSDG=SUMSDG+ANI*SDI 3668 SUMRAG=SUMRAG+ANI*RANGEI 3669 C4LARG=1.0 3670 IF(NI.LE.25)SUMSIE=SUMSIE+SDI/C4(NI) 3671 IF(NI.GE.26)SUMSIE=SUMSIE+SDI/C4LARG 3672 D22LAR=2.0*SQRT(2.0*LOG(2.0*ANI)) 3673 IF(NI.LE.25)SUMRIE=SUMRIE+RANGEI/D22(NI) 3674 IF(NI.GE.26)SUMRIE=SUMRIE+RANGEI/D22LAR 3675C 3676 IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'QCC2')GOTO1069 3677 WRITE(ICOUT,1061)ISET,NI,ANI 3678 1061 FORMAT('ISET,NI,ANI = ',I8,I8,E15.7) 3679 CALL DPWRST('XXX','BUG ') 3680 WRITE(ICOUT,1062)XBARI 3681 1062 FORMAT('XBARI = ',E15.7) 3682 CALL DPWRST('XXX','BUG ') 3683 WRITE(ICOUT,1063)SDI,C4(NI),C4LARG,SUMSIE 3684 1063 FORMAT('SDI,C4(NI),C4LARG,SUMSIE = ',4E15.7) 3685 CALL DPWRST('XXX','BUG ') 3686 WRITE(ICOUT,1064)RANGEI,D22(NI),D22LAR,SUMRIE 3687 1064 FORMAT('RANGEI,D22(NI),D22LAR,SUMRIE = ',4E15.7) 3688 CALL DPWRST('XXX','BUG ') 3689 1069 CONTINUE 3690C 3691 1010 CONTINUE 3692C 3693 XBARG=SUMXBG/AN 3694 SDG=SUMSDG/AN 3695 RANGEG=SUMRAG/AN 3696 SIGMAE=SUMSIE/ANUMSE 3697 RANGEE=SUMRIE/ANUMSE 3698C 3699 1090 CONTINUE 3700C 3701C ************************************************************** 3702C ** STEP 4-- ** 3703 3704C ** IN ORDER TO DETERMINE THE PROPER PLOT COOORDINATES ** 3705C ** FOR THE DESIRED PLOT, ** 3706C ** BRANCH TO THE PROPER SUBCASE-- ** 3707C ** 1) Q MEAN CONTROL CHART; ** 3708C ** 2) Q STANDARD DEVIATION CONTROL CHART; ** 3709C ** 3) Q RANGE CONTROL CHART; ** 3710C ** 4) Q CUSUM CONTROL CHART; ** 3711C ** 5) Q P CONTROL CHART; ** 3712C ** 6) Q PN CONTROL CHART; ** 3713C ** 7) Q C CONTROL CHART; ** 3714C ** 8) Q U CONTROL CHART; ** 3715C ************************************************************** 3716C 3717 ISTEPN='4' 3718 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2') 3719 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3720C 3721 IF(ICASPL.EQ.'MECC')GOTO1100 3722 IF(ICASPL.EQ.'SDCC')GOTO1200 3723 IF(ICASPL.EQ.'RACC')GOTO1300 3724 IF(ICASPL.EQ.'CUCC')GOTO1400 3725 IF(ICASPL.EQ.'PCC')GOTO1500 3726 IF(ICASPL.EQ.'PNCC')GOTO1600 3727 IF(ICASPL.EQ.'UCC')GOTO1700 3728 IF(ICASPL.EQ.'CCC')GOTO1800 3729C 3730 WRITE(ICOUT,999) 3731 CALL DPWRST('XXX','BUG ') 3732 WRITE(ICOUT,1051) 3733 1051 FORMAT('***** INTERNAL ERROR IN DPQCC2') 3734 CALL DPWRST('XXX','BUG ') 3735 WRITE(ICOUT,1052) 3736 1052 FORMAT(' AT BRANCH POINT 261--') 3737 CALL DPWRST('XXX','BUG ') 3738 WRITE(ICOUT,1053) 3739 1053 FORMAT(' ICASPL NOT EQUAL ONE OF THE ALLOWABLE 8--') 3740 CALL DPWRST('XXX','BUG ') 3741 WRITE(ICOUT,1054) 3742 1054 FORMAT(' MECC, SDCC, RACC, CSCC, PCC, PNCC, UCC, CCC.') 3743 CALL DPWRST('XXX','BUG ') 3744 WRITE(ICOUT,1056)ICASPL 3745 1056 FORMAT(' ICASPL = ',A4) 3746 CALL DPWRST('XXX','BUG ') 3747 IERROR='YES' 3748 GOTO9000 3749C 3750C ******************************************* 3751C ** STEP 5.1-- ** 3752C ** TREAT THE Q MEAN CONTROL CHART CASE ** 3753C ******************************************* 3754C 3755 1100 CONTINUE 3756C 3757 ISTEPN='5.1' 3758 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2') 3759 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3760C 3761 J=0 3762 DO1110K=3,N 3763 KM1=K-1 3764 AKM1=KM1 3765 KM2=K-2 3766C 3767 SUM=0.0 3768 DO1120I=1,KM1 3769 SUM=SUM+Y(I) 3770 1120 CONTINUE 3771 XBAKM1=SUM/AKM1 3772C 3773 SUM=0.0 3774 DO1130I=1,KM1 3775 SUM=SUM+(Y(I)-XBAKM1)**2 3776 1130 CONTINUE 3777 SKM1=SQRT(SUM/(AKM1-1.0)) 3778C 3779 ANUM=Y(K)-XBAKM1 3780 ADENOM=SKM1*SQRT((1.0/AKM1)+1.0) 3781 RATIO=ANUM/ADENOM 3782CCCCC CALL TCDF(RATIO,KM2,CDF) 3783 CALL TCDF(RATIO,REAL(KM2),CDF) 3784 CALL NORPPF(CDF,PPF) 3785 J=J+1 3786 Y2(J)=PPF 3787 X2(J)=J 3788 D2(J)=1.0 3789 1110 CONTINUE 3790 N2=J 3791 NPLOTV=2 3792 GOTO9000 3793C 3794C ********************************************************** 3795C ** STEP 5.2-- ** 3796C ** TREAT THE Q STANDARD DEVIATION CONTROL CHART CASE ** 3797C ********************************************************** 3798C 3799 1200 CONTINUE 3800C 3801 ISTEPN='5.2' 3802 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2') 3803 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3804C 3805 J=0 3806 DO1210ISET=1,NUMSET 3807C 3808 K=0 3809 DO1220I=1,N 3810 IF(X(I).EQ.XIDTEM(ISET))K=K+1 3811 IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I) 3812 1220 CONTINUE 3813 NI=K 3814 ANI=NI 3815C 3816 IF(NI.GE.1)GOTO1239 3817 WRITE(ICOUT,999) 3818 CALL DPWRST('XXX','BUG ') 3819 WRITE(ICOUT,1231) 3820 1231 FORMAT('***** INTERNAL ERROR IN DPQCC2--') 3821 CALL DPWRST('XXX','BUG ') 3822 WRITE(ICOUT,1232) 3823 1232 FORMAT('NI FOR SOME CLASS = 0') 3824 CALL DPWRST('XXX','BUG ') 3825 WRITE(ICOUT,1233)ISET,XIDTEM(ISET),NI 3826 1233 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8) 3827 CALL DPWRST('XXX','BUG ') 3828 IERROR='YES' 3829 GOTO9000 3830 1239 CONTINUE 3831C 3832 SUM=0.0 3833 DO1240I=1,NI 3834 SUM=SUM+TEMP(I) 3835 1240 CONTINUE 3836 XBARI=SUM/ANI 3837C 3838 IF(NI.LE.1)GOTO1210 3839C 3840 SUM=0.0 3841 DO1250I=1,NI 3842 SUM=SUM+(TEMP(I)-XBARI)**2 3843 1250 CONTINUE 3844 DENOM=ANI-1.0 3845 VARI=0.0 3846 IF(NI.GE.2)VARI=SUM/DENOM 3847 SDI=0.0 3848 IF(VARI.GT.0.0)SDI=SQRT(VARI) 3849C 3850 C4LARG=1.0 3851 IF(NI.LE.25)SADJ=C4(NI)*SIGMAE 3852 IF(NI.GE.26)SADJ=C4LARG*SIGMAE 3853C 3854 YMID=SADJ 3855C 3856 B4LARG=1.0+3.0/SQRT(2.0*(ANI-1.0)) 3857 IF(NI.LE.25)YUPPER=B4(NI)*SADJ 3858 IF(NI.GE.26)YUPPER=B4LARG*SADJ 3859C 3860 B3LARG=1.0-3.0/SQRT(2.0*(ANI-1.0)) 3861 IF(NI.LE.25)YLOWER=B3(NI)*SADJ 3862 IF(NI.GE.26)YLOWER=B3LARG*SADJ 3863C 3864 IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'QCC2')GOTO1269 3865 WRITE(ICOUT,1261)ISET,NI,ANI 3866 1261 FORMAT('ISET,NI,ANI = ',I8,I8,E15.7) 3867 CALL DPWRST('XXX','BUG ') 3868 WRITE(ICOUT,1262)XBARI 3869 1262 FORMAT('XBARI = ',E15.7) 3870 CALL DPWRST('XXX','BUG ') 3871 WRITE(ICOUT,1263)SDI,C4(NI),C4LARG,SIGMAE,SADJ 3872 1263 FORMAT('SDI,C4(NI),C4LARG,SIGMAE,SADJ = ',5E15.7) 3873 CALL DPWRST('XXX','BUG ') 3874 WRITE(ICOUT,1264)SADJ,YMID 3875 1264 FORMAT('SADJ,YMID = ',2E15.7) 3876 CALL DPWRST('XXX','BUG ') 3877 WRITE(ICOUT,1265)NI,ANI,B4(NI),B4LARG,YUPPER 3878 1265 FORMAT('NI,ANI,B4(NI),B4LARG,YUPPER = ',I8,4E15.7) 3879 CALL DPWRST('XXX','BUG ') 3880 WRITE(ICOUT,1266)NI,ANI,B3(NI),B3LARG,YLOWER 3881 1266 FORMAT('NI,ANI,B3(NI),B3LARG,YLOWER = ',I8,4E15.7) 3882 CALL DPWRST('XXX','BUG ') 3883 1269 CONTINUE 3884C 3885 J=J+1 3886 Y2(J)=SDI 3887 X2(J)=XIDTEM(ISET) 3888 D2(J)=1.0 3889C 3890 J=J+1 3891 Y2(J)=YMID 3892 X2(J)=XIDTEM(ISET) 3893 D2(J)=2.0 3894C 3895 J=J+1 3896 Y2(J)=YUPPER 3897 X2(J)=XIDTEM(ISET) 3898 D2(J)=3.0 3899C 3900 J=J+1 3901 Y2(J)=YLOWER 3902 X2(J)=XIDTEM(ISET) 3903 D2(J)=4.0 3904C 3905 IF(CCTARG.EQ.CPUMIN)GOTO1271 3906 J=J+1 3907 Y2(J)=CCTARG 3908 X2(J)=XIDTEM(ISET) 3909 D2(J)=5.0 3910 1271 CONTINUE 3911C 3912 IF(CCUSL.EQ.CPUMIN)GOTO1272 3913 J=J+1 3914 Y2(J)=CCUSL 3915 X2(J)=XIDTEM(ISET) 3916 D2(J)=6.0 3917 1272 CONTINUE 3918C 3919 IF(CCLSL.EQ.CPUMIN)GOTO1273 3920 J=J+1 3921 Y2(J)=CCLSL 3922 X2(J)=XIDTEM(ISET) 3923 D2(J)=7.0 3924 1273 CONTINUE 3925C 3926 1210 CONTINUE 3927 N2=J 3928 NPLOTV=3 3929 GOTO9000 3930C 3931C ******************************************** 3932C ** STEP 5.3-- ** 3933C ** TREAT THE Q RANGE CONTROL CHART CASE ** 3934C ******************************************** 3935C 3936 1300 CONTINUE 3937C 3938 ISTEPN='5.3' 3939 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2') 3940 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3941C 3942 D4FACT=1.25 3943 D3FACT=1.0/1.25 3944C 3945 J=0 3946 DO1310ISET=1,NUMSET 3947C 3948 K=0 3949 DO1320I=1,N 3950 IF(X(I).EQ.XIDTEM(ISET))K=K+1 3951 IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I) 3952 1320 CONTINUE 3953 NI=K 3954 ANI=NI 3955C 3956 IF(NI.GE.1)GOTO1339 3957 WRITE(ICOUT,999) 3958 CALL DPWRST('XXX','BUG ') 3959 WRITE(ICOUT,1331) 3960 1331 FORMAT('***** INTERNAL ERROR IN DPQCC2--') 3961 CALL DPWRST('XXX','BUG ') 3962 WRITE(ICOUT,1332) 3963 1332 FORMAT('NI FOR SOME CLASS = 0') 3964 CALL DPWRST('XXX','BUG ') 3965 WRITE(ICOUT,1333)ISET,XIDTEM(ISET),NI 3966 1333 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8) 3967 CALL DPWRST('XXX','BUG ') 3968 IERROR='YES' 3969 GOTO9000 3970 1339 CONTINUE 3971C 3972 IF(NI.LE.1)GOTO1310 3973C 3974 XTMIN=TEMP(1) 3975 XTMAX=TEMP(1) 3976 DO1340I=1,NI 3977 IF(TEMP(I).LT.XTMIN)XTMIN=TEMP(I) 3978 IF(TEMP(I).GT.XTMAX)XTMAX=TEMP(I) 3979 1340 CONTINUE 3980 RANGEI=XTMAX-XTMIN 3981C 3982 D22LAR=2.0*SQRT(2.0*LOG(2.0*ANI)) 3983 IF(NI.LE.25)RADJ=D22(NI)*RANGEE 3984 IF(NI.GE.26)RADJ=D22LAR*RANGEE 3985C 3986 YMID=RADJ 3987C 3988 D4LARG=1.0+3.0*D4FACT/SQRT(2.0*(ANI-1.0)) 3989 IF(NI.LE.25)YUPPER=D4(NI)*RADJ 3990 IF(NI.GE.26)YUPPER=D4LARG*RADJ 3991C 3992 D3LARG=1.0-3.0*D3FACT/SQRT(2.0*(ANI-1.0)) 3993 IF(NI.LE.25)YLOWER=D3(NI)*RADJ 3994 IF(NI.GE.26)YLOWER=D3LARG*RADJ 3995C 3996 IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'QCC2')GOTO1369 3997 WRITE(ICOUT,1361)ISET,NI,ANI 3998 1361 FORMAT('ISET,NI,ANI = ',I8,I8,E15.7) 3999 CALL DPWRST('XXX','BUG ') 4000 WRITE(ICOUT,1362)RANGEI 4001 1362 FORMAT('RANGEI = ',E15.7) 4002 CALL DPWRST('XXX','BUG ') 4003 WRITE(ICOUT,1363)RANGEI,D22(NI),D22LAR,RANGEE,SADJ 4004 1363 FORMAT('RANGEI,D22(NI),D22LAR,RANGEE,SADJ = ',5E15.7) 4005 CALL DPWRST('XXX','BUG ') 4006 WRITE(ICOUT,1364)RADJ,YMID 4007 1364 FORMAT('RADJ,YMID = ',2E15.7) 4008 CALL DPWRST('XXX','BUG ') 4009 WRITE(ICOUT,1365)NI,ANI,D4(NI),D4LARG,YUPPER 4010 1365 FORMAT('NI,ANI,D4(NI),D4LARG,YUPPER = ',I8,4E15.7) 4011 CALL DPWRST('XXX','BUG ') 4012 WRITE(ICOUT,1366)NI,ANI,D3(NI),D3LARG,YLOWER 4013 1366 FORMAT('NI,ANI,D3(NI),D3LARG,YLOWER = ',I8,4E15.7) 4014 CALL DPWRST('XXX','BUG ') 4015 1369 CONTINUE 4016C 4017 J=J+1 4018 Y2(J)=RANGEI 4019 X2(J)=XIDTEM(ISET) 4020 D2(J)=1.0 4021C 4022 J=J+1 4023 Y2(J)=YMID 4024 X2(J)=XIDTEM(ISET) 4025 D2(J)=2.0 4026C 4027 J=J+1 4028 Y2(J)=YUPPER 4029 X2(J)=XIDTEM(ISET) 4030 D2(J)=3.0 4031C 4032 J=J+1 4033 Y2(J)=YLOWER 4034 X2(J)=XIDTEM(ISET) 4035 D2(J)=4.0 4036C 4037 IF(CCTARG.EQ.CPUMIN)GOTO1371 4038 J=J+1 4039 Y2(J)=CCTARG 4040 X2(J)=XIDTEM(ISET) 4041 D2(J)=5.0 4042 1371 CONTINUE 4043C 4044 IF(CCUSL.EQ.CPUMIN)GOTO1372 4045 J=J+1 4046 Y2(J)=CCUSL 4047 X2(J)=XIDTEM(ISET) 4048 D2(J)=6.0 4049 1372 CONTINUE 4050C 4051 IF(CCLSL.EQ.CPUMIN)GOTO1373 4052 J=J+1 4053 Y2(J)=CCLSL 4054 X2(J)=XIDTEM(ISET) 4055 D2(J)=7.0 4056 1373 CONTINUE 4057C 4058 1310 CONTINUE 4059 N2=J 4060 NPLOTV=3 4061 GOTO9000 4062C 4063C ****************************************************** 4064C ** STEP 5.4-- ** 4065C ** DETERMINE PLOT COORDINATES ** 4066C ** FOR THE Q CUSUM CONTROL CHART PLOT SUBCASE. ** 4067C ****************************************************** 4068C 4069 1400 CONTINUE 4070C 4071 ISTEPN='3.4' 4072 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2') 4073 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4074C 4075 WRITE(ICOUT,1405) 4076 1405 FORMAT('CUSUM CAPABILITY NOT YET AVAILABLE.') 4077 CALL DPWRST('XXX','BUG ') 4078 GOTO9000 4079C 4080C ******************************************************** 4081C ** STEP 5.5-- ** 4082C ** TREAT THE Q P CONTROL CHART CASE ** 4083C ** PROPORTION DEFECTIVE PER BATCH (SUBSAMPLE) ** 4084C ** NUMBER DEFECTIVE PER BATCH / TOTAL NUMBER IN BATCH 4085C ** THE INPUT IS A DUAL SERIES-- 4086C ** 1) NUMBER OF DEFECTIVE ITEMS IN THE SUBSAMPLE 4087C ** 2) TOTAL NUMBER OF ITEMS IN THE SAMPLE 4088C ** THE CONFIDENCE BAND IS GOTTEN BY ASSUMING BINOMIAL** 4089C ******************************************************** 4090C 4091 1500 CONTINUE 4092C 4093 ISTEPN='5.5' 4094 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2') 4095 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4096C 4097 SUM1=0.0 4098 SUM2=0.0 4099 DO1510ISET=1,NUMSET 4100 SUM1=SUM1+Y(ISET) 4101 SUM2=SUM2+YN(ISET) 4102 1510 CONTINUE 4103 CTOTAL=SUM1 4104 ANTOT=SUM2 4105 PBARG=CTOTAL/ANTOT 4106 PRBARG=100.0*PBARG 4107C 4108 J=0 4109 DO1550ISET=1,NUMSET 4110C 4111 CI=Y(ISET) 4112 ANI=YN(ISET) 4113 NI=INT(ANI+0.5) 4114 IF(NI.LE.0)GOTO1550 4115C 4116 PI=CI/ANI 4117 PROPI=100.0*PI 4118 TAGI=XIDTEM(ISET) 4119C 4120 J=J+1 4121 Y2(J)=PROPI 4122 X2(J)=TAGI 4123 D2(J)=1.0 4124C 4125 J=J+1 4126 YMID=PRBARG 4127 Y2(J)=YMID 4128 X2(J)=TAGI 4129 D2(J)=2.0 4130C 4131 J=J+1 4132 VARPI=0.0 4133 IF(ANI.GT.0.0)VARPI=PBARG*(1.0-PBARG)/ANI 4134 SDPI=0.0 4135 IF(VARPI.GT.0.0)SDPI=SQRT(VARPI) 4136 SDPRI=100.0*SDPI 4137 YUPPER=YMID+3.0*SDPRI 4138 IF(YUPPER.GT.100.0)YUPPER=100.0 4139 Y2(J)=YUPPER 4140 X2(J)=TAGI 4141 D2(J)=3.0 4142C 4143 J=J+1 4144 YLOWER=YMID-3.0*SDPRI 4145 IF(YLOWER.LT.0.0)YLOWER=0.0 4146 Y2(J)=YLOWER 4147 X2(J)=TAGI 4148 D2(J)=4.0 4149C 4150 IF(CCTARG.EQ.CPUMIN)GOTO1571 4151 J=J+1 4152 Y2(J)=CCTARG 4153 X2(J)=XIDTEM(ISET) 4154 D2(J)=5.0 4155 1571 CONTINUE 4156C 4157 IF(CCUSL.EQ.CPUMIN)GOTO1572 4158 J=J+1 4159 Y2(J)=CCUSL 4160 X2(J)=XIDTEM(ISET) 4161 D2(J)=6.0 4162 1572 CONTINUE 4163C 4164 IF(CCLSL.EQ.CPUMIN)GOTO1573 4165 J=J+1 4166 Y2(J)=CCLSL 4167 X2(J)=XIDTEM(ISET) 4168 D2(J)=7.0 4169 1573 CONTINUE 4170C 4171 1550 CONTINUE 4172 N2=J 4173 NPLOTV=3 4174 GOTO9000 4175C 4176C ******************************************************** 4177C ** STEP 5.6-- ** 4178C ** TREAT THE Q PN CONTROL CHART CASE ** 4179C ** TOTAL NUMBER DEFECTIVE IN A BATCH (SUBSAMPLE) ** 4180C ** SUM UP THE NUMBER OF DEFECTIVES PER BATCH (SUBSAMPLE) 4181C ** THE NUMBER WILL BE A NON-NEGATIVE INTEGER 4182C ** THE INPUT IS A DUAL SERIES-- 4183C ** 1) NUMBER OF DEFECTIVE ITEMS IN THE SUBSAMPLE 4184C ** 2) TOTAL NUMBER OF ITEMS IN THE SAMPLE 4185C ** THE CONFIDENCE BAND IS GOTTEN BY ASSUMING BINOMIAL** 4186C ** NOTE--THE PN CHART SHOULD BE USED ONLY WHEN 4187C ** THE SUBSAMPLE SIZE IS CONSTANT. 4188C ** FOR VARYING SUBSAMPLE SIZE, USE THE P CHART 4189C ** (ISHIKAWA, GUIDE TO QUALITY CONTROL, PAGE 77) 4190C ******************************************************** 4191C 4192 1600 CONTINUE 4193C 4194 ISTEPN='5.6' 4195 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2') 4196 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4197C 4198 SUM1=0.0 4199 SUM2=0.0 4200 ANUMSE=NUMSET 4201 DO1610ISET=1,NUMSET 4202 SUM1=SUM1+Y(ISET) 4203 SUM2=SUM2+YN(ISET) 4204 1610 CONTINUE 4205 CTOTAL=SUM1 4206 ANTOT=SUM2 4207 PBARG=CTOTAL/ANTOT 4208 ANBARG=ANTOT/ANUMSE 4209 CBARG=PBARG*ANBARG 4210C 4211 J=0 4212 DO1650ISET=1,NUMSET 4213C 4214 CI=Y(ISET) 4215 ANI=YN(ISET) 4216 NI=INT(ANI+0.5) 4217 IF(NI.LE.0)GOTO1650 4218C 4219 PI=CI/ANI 4220 TAGI=XIDTEM(ISET) 4221C 4222 J=J+1 4223 Y2(J)=CI 4224 X2(J)=TAGI 4225 D2(J)=1.0 4226C 4227 J=J+1 4228 YMID=CBARG 4229 Y2(J)=YMID 4230 X2(J)=TAGI 4231 D2(J)=2.0 4232C 4233 J=J+1 4234 VARCI=0.0 4235 IF(ANBARG.GT.0.0)VARCI=ANBARG*PBARG*(1.0-PBARG) 4236 SDCI=0.0 4237 IF(VARCI.GT.0.0)SDCI=SQRT(VARCI) 4238 YUPPER=YMID+3.0*SDCI 4239 Y2(J)=YUPPER 4240 X2(J)=TAGI 4241 D2(J)=3.0 4242C 4243 J=J+1 4244 YLOWER=YMID-3.0*SDCI 4245 IF(YLOWER.LT.0.0)YLOWER=0.0 4246 Y2(J)=YLOWER 4247 X2(J)=TAGI 4248 D2(J)=4.0 4249C 4250 IF(CCTARG.EQ.CPUMIN)GOTO1671 4251 J=J+1 4252 Y2(J)=CCTARG 4253 X2(J)=XIDTEM(ISET) 4254 D2(J)=5.0 4255 1671 CONTINUE 4256C 4257 IF(CCUSL.EQ.CPUMIN)GOTO1672 4258 J=J+1 4259 Y2(J)=CCUSL 4260 X2(J)=XIDTEM(ISET) 4261 D2(J)=6.0 4262 1672 CONTINUE 4263C 4264 IF(CCLSL.EQ.CPUMIN)GOTO1673 4265 J=J+1 4266 Y2(J)=CCLSL 4267 X2(J)=XIDTEM(ISET) 4268 D2(J)=7.0 4269 1673 CONTINUE 4270C 4271 1650 CONTINUE 4272 N2=J 4273 NPLOTV=3 4274 GOTO9000 4275C 4276C ******************************************************** 4277C ** STEP 5.7-- ** 4278C ** TREAT THE Q U CONTROL CHART CASE (POISSON) ** 4279C ** DEFECTIVE PER UNIT 4280C ** DEFECTIVE PER UNIT AREA 4281C ** NUMBER DEFECTIVE PER SUB-BATCH / LENGTH OR AREA 4282C ** THE INPUT IS A DUAL SERIES-- 4283C ** 1) NUMBER OF DEFECTIVE ITEMS IN THE SUBSAMPLE 4284C ** 2) LENGTH OR AREA OF THE ITEM 4285C ** THE CONFIDENCE BAND IS GOTTEN BY ASSUMING POISSON** 4286C ******************************************************** 4287C 4288 1700 CONTINUE 4289C 4290 ISTEPN='5.7' 4291 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2') 4292 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4293C 4294 SUM1=0.0 4295 SUM2=0.0 4296 DO1710ISET=1,NUMSET 4297 SUM1=SUM1+Y(ISET) 4298 SUM2=SUM2+YN(ISET) 4299 1710 CONTINUE 4300 CTOTAL=SUM1 4301 SIZTOT=SUM2 4302 CBARG=CTOTAL/SIZTOT 4303C 4304 J=0 4305 DO1750ISET=1,NUMSET 4306C 4307 CI=Y(ISET) 4308 SIZEI=YN(ISET) 4309 NSIZEI=INT(SIZEI+0.5) 4310 IF(NSIZEI.LE.0)GOTO1750 4311C 4312 TAGI=XIDTEM(ISET) 4313C 4314 J=J+1 4315 Y2(J)=(-1.0) 4316 IF(SIZEI.NE.0.0)Y2(J)=CI/SIZEI 4317 X2(J)=TAGI 4318 D2(J)=1.0 4319C 4320 J=J+1 4321 YMID=CBARG 4322 Y2(J)=YMID 4323 X2(J)=TAGI 4324 D2(J)=2.0 4325C 4326 J=J+1 4327 VARCI=0.0 4328 IF(ANI.GT.0.0)VARCI=CBARG/SIZEI 4329 SDCI=0.0 4330 IF(VARCI.GT.0.0)SDCI=SQRT(VARCI) 4331 YUPPER=YMID+3.0*SDCI 4332 Y2(J)=YUPPER 4333 X2(J)=TAGI 4334 D2(J)=3.0 4335C 4336 J=J+1 4337 YLOWER=YMID-3.0*SDCI 4338 IF(YLOWER.LT.0.0)YLOWER=0.0 4339 Y2(J)=YLOWER 4340 X2(J)=TAGI 4341 D2(J)=4.0 4342C 4343 IF(CCTARG.EQ.CPUMIN)GOTO1771 4344 J=J+1 4345 Y2(J)=CCTARG 4346 X2(J)=XIDTEM(ISET) 4347 D2(J)=5.0 4348 1771 CONTINUE 4349C 4350 IF(CCUSL.EQ.CPUMIN)GOTO1772 4351 J=J+1 4352 Y2(J)=CCUSL 4353 X2(J)=XIDTEM(ISET) 4354 D2(J)=6.0 4355 1772 CONTINUE 4356C 4357 IF(CCLSL.EQ.CPUMIN)GOTO1773 4358 J=J+1 4359 Y2(J)=CCLSL 4360 X2(J)=XIDTEM(ISET) 4361 D2(J)=7.0 4362 1773 CONTINUE 4363C 4364 1750 CONTINUE 4365 N2=J 4366 NPLOTV=3 4367 GOTO9000 4368C 4369C ******************************************************** 4370C ** STEP 5.8-- ** 4371C ** TREAT THE Q C CONTROL CHART CASE (POISSON) ** 4372C ** TOTAL NUMBER DEFECTIVE IN A BATCH (SUBSAMPLE) ** 4373C ** SUM OF DEFECTIVES IN A BATCH (SUBSAMPLE) ** 4374C ** THE INPUT IS USUALLY A SERIES OF INTEGERS ** 4375C ** THE VALUE WILL BE A NON-NEGATIVE INTEGER ** 4376C ** THE CONFIDENCE BAND IS GOTTEN BY ASSUMING POISSON** 4377C ** NOTE--THE C CHART SHOULD BE USED ONLY WHEN 4378C ** THE SUBSAMPLE SIZE IS CONSTANT. 4379C ** FOR VARYING SUBSAMPLE SIZE, USE THE U CHART 4380C ** (ISHIKAWA, GUIDE TO QUALITY CONTROL, PAGE 77) 4381C ******************************************************** 4382C 4383 1800 CONTINUE 4384C 4385 ISTEPN='5.8' 4386 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2') 4387 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4388C 4389 SUM1=0.0 4390 SUM2=0.0 4391 ANUMSE=NUMSET 4392 DO1810ISET=1,NUMSET 4393 SUM1=SUM1+Y(ISET) 4394 IF(NUMV2.LE.2)SUM2=SUM2+1 4395 IF(NUMV2.GE.3)SUM2=SUM2+YN(ISET) 4396 1810 CONTINUE 4397 CTOTAL=SUM1 4398 CBARG=CTOTAL/ANUMSE 4399C 4400 J=0 4401 DO1850ISET=1,NUMSET 4402C 4403 CI=Y(ISET) 4404 SIZEI=YN(ISET) 4405 NSIZEI=INT(SIZEI+0.5) 4406 IF(NSIZEI.LE.0)GOTO1850 4407C 4408 TAGI=XIDTEM(ISET) 4409C 4410 J=J+1 4411 Y2(J)=CI 4412 X2(J)=TAGI 4413 D2(J)=1.0 4414C 4415 J=J+1 4416 YMID=CBARG 4417 Y2(J)=YMID 4418 X2(J)=TAGI 4419 D2(J)=2.0 4420C 4421 J=J+1 4422 VARCI=0.0 4423 IF(ANI.GT.0.0)VARCI=CBARG 4424 SDCI=0.0 4425 IF(VARCI.GT.0.0)SDCI=SQRT(VARCI) 4426 YUPPER=YMID+3.0*SDCI 4427 Y2(J)=YUPPER 4428 X2(J)=TAGI 4429 D2(J)=3.0 4430C 4431 J=J+1 4432 YLOWER=YMID-3.0*SDCI 4433 IF(YLOWER.LT.0.0)YLOWER=0.0 4434 Y2(J)=YLOWER 4435 X2(J)=TAGI 4436 D2(J)=4.0 4437C 4438 IF(CCTARG.EQ.CPUMIN)GOTO1871 4439 J=J+1 4440 Y2(J)=CCTARG 4441 X2(J)=XIDTEM(ISET) 4442 D2(J)=5.0 4443 1871 CONTINUE 4444C 4445 IF(CCUSL.EQ.CPUMIN)GOTO1872 4446 J=J+1 4447 Y2(J)=CCUSL 4448 X2(J)=XIDTEM(ISET) 4449 D2(J)=6.0 4450 1872 CONTINUE 4451C 4452 IF(CCLSL.EQ.CPUMIN)GOTO1873 4453 J=J+1 4454 Y2(J)=CCLSL 4455 X2(J)=XIDTEM(ISET) 4456 D2(J)=7.0 4457 1873 CONTINUE 4458C 4459 1850 CONTINUE 4460 N2=J 4461 NPLOTV=3 4462 GOTO9000 4463C 4464C ****************** 4465C ** STEP 90-- ** 4466C ** EXIT ** 4467C ****************** 4468C 4469 9000 CONTINUE 4470 IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'QCC2')GOTO9090 4471 WRITE(ICOUT,999) 4472 CALL DPWRST('XXX','BUG ') 4473 WRITE(ICOUT,9011) 4474 9011 FORMAT('***** AT THE END OF DPQCC2--') 4475 CALL DPWRST('XXX','BUG ') 4476 WRITE(ICOUT,9012)ICASPL,N,NUMSET,N2,IERROR 4477 9012 FORMAT('ICASPL,N,NUMSET,N2,IERROR = ',A4,3I8,2X,A4) 4478 CALL DPWRST('XXX','BUG ') 4479 WRITE(ICOUT,9013)NUMV2,ISIZE 4480 9013 FORMAT('NUMV2,ISIZE = ',2I8) 4481 CALL DPWRST('XXX','BUG ') 4482 WRITE(ICOUT,9014)AN,XBARG,SDG,RANGEG 4483 9014 FORMAT('AN,XBARG,SDG,RANGEG = ',4E15.7) 4484 CALL DPWRST('XXX','BUG ') 4485 WRITE(ICOUT,9015)ANUMSE,SIGMAE,RANGEE 4486 9015 FORMAT('ANUMSE,SIGMAE,RANGEE = ',3E15.7) 4487 CALL DPWRST('XXX','BUG ') 4488 DO9020I=1,N2 4489 WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I) 4490 9021 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) 4491 CALL DPWRST('XXX','BUG ') 4492 9020 CONTINUE 4493 9090 CONTINUE 4494C 4495 RETURN 4496 END 4497 SUBROUTINE DPQUAD(IHARG,NUMARG,IDEFPR,IHMXPR, 4498 1IPREC,IFOUND,IERROR) 4499C 4500C PURPOSE--DEFINE THE PREICSION SWITCH 4501C AS QUADRUPLE PRECISION. 4502C THIS IN TURN SPECIFIES THAT SUBSEQUENT 4503C CALCULATIONS WILL ALL BE CARRIED OUT 4504C IN QUADRUPLE PRECISION. 4505C THE SPECIFIED PRECISION SWITCH SPECIFICATION 4506C WILL BE PLACED IN THE HOLLERITH VARIABLE IPREC. 4507C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) 4508C --NUMARG (AN INTEGER VARIABLE) 4509C --IDEFPR (A HOLLERITH VARIABLE) 4510C --IHMXPR (A HOLLERITH VARIABLE) 4511C OUTPUT ARGUMENTS--IPREC (A HOLLERITH VARIABLE) 4512C --IFOUND ('YES' OR 'NO' ) 4513C --IERROR ('YES' OR 'NO' ) 4514C WRITTEN BY--JAMES J. FILLIBEN 4515C STATISTICAL ENGINEERING DIVISION 4516C INFORMATION TECHNOLOGY LABORATORY 4517C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 4518C GAITHERSBURG, MD 20899-8980 4519C PHONE--301-975-2855 4520C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 4521C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 4522C LANGUAGE--ANSI FORTRAN (1977) 4523C VERSION NUMBER--82/7 4524C ORIGINAL VERSION--NOVEMBER 1980. 4525C UPDATED --SEPTEMBER 1981. 4526C UPDATED --MAY 1982. 4527C 4528C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 4529C 4530 CHARACTER*4 IHARG 4531 CHARACTER*4 IDEFPR 4532 CHARACTER*4 IHMXPR 4533 CHARACTER*4 IPREC 4534 CHARACTER*4 IFOUND 4535 CHARACTER*4 IERROR 4536C 4537 CHARACTER*4 IHOLD 4538C 4539C--------------------------------------------------------------------- 4540C 4541 DIMENSION IHARG(*) 4542C 4543C--------------------------------------------------------------------- 4544C 4545 INCLUDE 'DPCOP2.INC' 4546C 4547C-----START POINT----------------------------------------------------- 4548C 4549 IFOUND='NO' 4550 IERROR='NO' 4551 IFOUND='YES' 4552C 4553 IF(NUMARG.LE.0)GOTO1120 4554 IF(IHARG(NUMARG).EQ.'ON')GOTO1130 4555 IF(IHARG(NUMARG).EQ.'OFF')GOTO1120 4556 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1130 4557 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1120 4558 GOTO1130 4559C 4560 1120 CONTINUE 4561 IHOLD=IDEFPR 4562 GOTO1160 4563C 4564 1130 CONTINUE 4565 IHOLD='QUAD' 4566 GOTO1160 4567C 4568 1160 CONTINUE 4569 IF(IHOLD.EQ.'DOUB'.AND.IHMXPR.EQ.'SING')GOTO1170 4570 IF(IHOLD.EQ.'TRIP'.AND.IHMXPR.EQ.'SING')GOTO1170 4571 IF(IHOLD.EQ.'TRIP'.AND.IHMXPR.EQ.'DOUB')GOTO1170 4572 IF(IHOLD.EQ.'QUAD'.AND.IHMXPR.EQ.'SING')GOTO1170 4573 IF(IHOLD.EQ.'QUAD'.AND.IHMXPR.EQ.'DOUB')GOTO1170 4574 IF(IHOLD.EQ.'QUAD'.AND.IHMXPR.EQ.'TRIP')GOTO1170 4575 GOTO1180 4576C 4577 1170 CONTINUE 4578 IERROR='YES' 4579 WRITE(ICOUT,999) 4580 999 FORMAT(1X) 4581 CALL DPWRST('XXX','BUG ') 4582 WRITE(ICOUT,1172) 4583 1172 FORMAT('***** ERROR IN DPQUAD--') 4584 CALL DPWRST('XXX','BUG ') 4585 WRITE(ICOUT,1173) 4586 1173 FORMAT(' THE DESIRED PRECISION IS HIGHER') 4587 CALL DPWRST('XXX','BUG ') 4588 WRITE(ICOUT,1174) 4589 1174 FORMAT(' THAN PERMITTED ON THIS COMPUTER.') 4590 CALL DPWRST('XXX','BUG ') 4591 WRITE(ICOUT,1175)IHOLD 4592 1175 FORMAT(' DESIRED PRECISION = ',A4) 4593 CALL DPWRST('XXX','BUG ') 4594 WRITE(ICOUT,1176)IHMXPR 4595 1176 FORMAT(' MAXIMUM ALLOWABLE PRECISION = ',A4) 4596 CALL DPWRST('XXX','BUG ') 4597 GOTO1199 4598C 4599 1180 CONTINUE 4600 IPREC=IHOLD 4601C 4602 IF(IFEEDB.EQ.'OFF')GOTO1189 4603 WRITE(ICOUT,999) 4604 CALL DPWRST('XXX','BUG ') 4605 WRITE(ICOUT,1188)IPREC 4606 1188 FORMAT('THE PRECISION SWITCH HAS JUST BEEN SET TO ', 4607 1A4) 4608 CALL DPWRST('XXX','BUG ') 4609 1189 CONTINUE 4610 GOTO1199 4611C 4612 1199 CONTINUE 4613 RETURN 4614 END 4615 SUBROUTINE DPQUAN(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 4616 1 IANGLU,MAXNPP,IBOOSS,ISEED, 4617 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 4618C 4619C PURPOSE--FORM A QUANTILE PLOT 4620C (USEFUL FOR DISTRIBUTIONALLY COMPARING 2 DATA SETS). 4621C WRITTEN BY--JAMES J. FILLIBEN 4622C STATISTICAL ENGINEERING DIVISION 4623C INFORMATION TECHNOLOGY LABORATORY 4624C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 4625C GAITHERSBURG, MD 20899-8980 4626C PHONE--301-975-2855 4627C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 4628C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 4629C LANGUAGE--ANSI FORTRAN (1977) 4630C VERSION NUMBER--87/5 4631C ORIGINAL VERSION--MAY 1987. 4632C UPDATED --MARCH 1988. ACTIVATE QUANTILE-QUANTILE 4633C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON 4634C MOVE SOME DIMENSIONS FROM DPQUA2 4635C UPDATED --FEBRUARY 2011. USE DPPARS, DPPAR3 4636C UPDATED --FEBRUARY 2011. SUPPORT FOR "HIGHLIGHTED" OPTION 4637C UPDATED --JUNE 2016. ALLOW USER-SPECIFED PERCENTILES 4638C UPDATED --JUNE 2016. SAVE A0, A1, PPCC VALUES FROM 4639C PLOT 4640C UPDATED --JUNE 2016. BOOTSTRAP FOR POINT WISE 4641C CONFIDENCE INTERVALS 4642C 4643C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 4644C 4645 CHARACTER*4 ICASPL 4646 CHARACTER*4 IAND1 4647 CHARACTER*4 IAND2 4648 CHARACTER*4 IANGLU 4649 CHARACTER*4 IBUGG2 4650 CHARACTER*4 IBUGG3 4651 CHARACTER*4 IBUGQ 4652 CHARACTER*4 ISUBRO 4653 CHARACTER*4 IFOUND 4654 CHARACTER*4 IERROR 4655C 4656 CHARACTER*4 ICASE 4657 CHARACTER*4 IHIGH 4658C 4659 CHARACTER*4 ISUBN1 4660 CHARACTER*4 ISUBN2 4661 CHARACTER*4 ISTEPN 4662 CHARACTER*4 IH 4663 CHARACTER*4 IH2 4664 CHARACTER*4 ISUBN0 4665C 4666 PARAMETER (MAXSPN=10) 4667 CHARACTER*4 IVARN1(MAXSPN) 4668 CHARACTER*4 IVARN2(MAXSPN) 4669 CHARACTER*4 IVARTY(MAXSPN) 4670 REAL PVAR(MAXSPN) 4671 INTEGER ILIS(MAXSPN) 4672 INTEGER NRIGHT(MAXSPN) 4673 INTEGER ICOLR(MAXSPN) 4674 CHARACTER*40 INAME 4675C 4676C--------------------------------------------------------------------- 4677C 4678 INCLUDE 'DPCOPA.INC' 4679 INCLUDE 'DPCOZZ.INC' 4680 INCLUDE 'DPCOZI.INC' 4681C 4682 DIMENSION Y1(MAXOBV) 4683 DIMENSION Y2(MAXOBV) 4684 DIMENSION Y3(MAXOBV) 4685 DIMENSION Y4(MAXOBV) 4686 DIMENSION XD(MAXOBV) 4687 DIMENSION YD(MAXOBV) 4688 DIMENSION XHIGH(MAXOBV) 4689 DIMENSION XDIST(MAXOBV) 4690 DIMENSION Y1SAVE(MAXOBV) 4691 DIMENSION Y2SAVE(MAXOBV) 4692 DIMENSION TEMP1(MAXOBV) 4693 DIMENSION TEMP2(MAXOBV) 4694 DIMENSION TEMP3(MAXOBV) 4695 DIMENSION TEMP4(MAXOBV) 4696 DIMENSION TEMP5(MAXOBV) 4697C 4698 INTEGER ITEMP1(MAXOBV) 4699C 4700 EQUIVALENCE (GARBAG(IGARB1),Y1(1)) 4701 EQUIVALENCE (GARBAG(IGARB2),Y2(1)) 4702 EQUIVALENCE (GARBAG(IGARB3),Y3(1)) 4703 EQUIVALENCE (GARBAG(IGARB4),Y4(1)) 4704 EQUIVALENCE (GARBAG(IGARB5),XD(1)) 4705 EQUIVALENCE (GARBAG(IGARB6),YD(1)) 4706 EQUIVALENCE (GARBAG(IGARB7),Y1SAVE(1)) 4707 EQUIVALENCE (GARBAG(IGARB8),Y2SAVE(1)) 4708 EQUIVALENCE (GARBAG(IGARB9),XHIGH(1)) 4709 EQUIVALENCE (GARBAG(IGAR10),XDIST(1)) 4710 EQUIVALENCE (GARBAG(JGAR11),TEMP1(1)) 4711 EQUIVALENCE (GARBAG(JGAR12),TEMP2(1)) 4712 EQUIVALENCE (GARBAG(JGAR13),TEMP3(1)) 4713 EQUIVALENCE (GARBAG(JGAR14),TEMP4(1)) 4714 EQUIVALENCE (GARBAG(JGAR15),TEMP5(1)) 4715 EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1)) 4716C 4717CCCCC END CHANGE 4718C 4719C-----COMMON---------------------------------------------------------- 4720C 4721 INCLUDE 'DPCOHK.INC' 4722 INCLUDE 'DPCOHO.INC' 4723 INCLUDE 'DPCODA.INC' 4724 INCLUDE 'DPCOST.INC' 4725 INCLUDE 'DPCOP2.INC' 4726C 4727C-----START POINT----------------------------------------------------- 4728C 4729 ISUBN1='DPQU' 4730 ISUBN2='AN ' 4731 IFOUND='NO' 4732 IERROR='NO' 4733 IHIGH='OFF' 4734C 4735 MAXCP1=MAXCOL+1 4736 MAXCP2=MAXCOL+2 4737 MAXCP3=MAXCOL+3 4738 MAXCP4=MAXCOL+4 4739 MAXCP5=MAXCOL+5 4740 MAXCP6=MAXCOL+6 4741C 4742 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'QUAN')THEN 4743 WRITE(ICOUT,999) 4744 999 FORMAT(1X) 4745 CALL DPWRST('XXX','BUG ') 4746 WRITE(ICOUT,51) 4747 51 FORMAT('***** AT THE BEGINNING OF DPQUAN--') 4748 CALL DPWRST('XXX','BUG ') 4749 WRITE(ICOUT,53)ICASPL,IAND1,IAND2,MAXN,MAXNPP,IQQNPR 4750 53 FORMAT('ICASPL,IAND1,IAND2,MAXN,MAXNPP,IQQNPR = ',3(A4,2X),3I8) 4751 CALL DPWRST('XXX','BUG ') 4752 WRITE(ICOUT,54)IANGLU,IBUGG2,IBUGG3,IBUGQ,ISUBRO 4753 54 FORMAT('IANGLU,IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',4(A4,2X),A4) 4754 CALL DPWRST('XXX','BUG ') 4755 WRITE(ICOUT,57)IFOUND,IERROR,NS 4756 57 FORMAT('IFOUND,IERROR,NS = ',2(A4,2X),I8) 4757 CALL DPWRST('XXX','BUG ') 4758 ENDIF 4759C 4760C *********************************** 4761C ** TREAT THE QUANTILE PLOT CASE ** 4762C *********************************** 4763C 4764C *************************** 4765C ** STEP 11-- ** 4766C ** EXTRACT THE COMMAND ** 4767C *************************** 4768C 4769 ISTEPN='11' 4770 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'QUAN') 4771 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4772C 4773 IF(ICOM.EQ.'QUAN')THEN 4774 IF(IHARG(1).EQ.'QUAN' .AND. IHARG(2).EQ.'PLOT')THEN 4775 ILASTC=2 4776 IFOUND='YES' 4777 ELSEIF(IHARG(1).EQ.'QUAN' .AND. IHARG(2).EQ.'HIGH' .AND. 4778 1 IHARG(3).EQ.'PLOT')THEN 4779 ILASTC=3 4780 IFOUND='YES' 4781 IHIGH='ON' 4782 ELSEIF(IHARG(1).EQ.'QUAN' .AND. IHARG(2).EQ.'SUBS' .AND. 4783 1 IHARG(3).EQ.'PLOT')THEN 4784 ILASTC=3 4785 IFOUND='YES' 4786 IHIGH='ON' 4787 ENDIF 4788 ELSEIF(ICOM.EQ.'HIGH' .OR. ICOM.EQ.'SUBS')THEN 4789 IF(IHARG(1).EQ.'QUAN' .AND. IHARG(2).EQ.'QUAN' .AND. 4790 1 IHARG(3).EQ.'PLOT')THEN 4791 ILASTC=3 4792 IFOUND='YES' 4793 IHIGH='ON' 4794 ENDIF 4795 ENDIF 4796C 4797 IF(IFOUND.EQ.'NO')GOTO9000 4798C 4799 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) 4800 ICASPL='QUAN' 4801C 4802C **************************************** 4803C ** STEP 2-- ** 4804C ** EXTRACT THE VARIABLE LIST ** 4805C **************************************** 4806C 4807 ISTEPN='2' 4808 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'QUAN') 4809 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4810C 4811 INAME='QUANTILE-QUANTILE PLOT' 4812 MINNA=1 4813 MAXNA=100 4814 MINN2=2 4815 IFLAGE=0 4816 IFLAGM=1 4817 IFLAGP=0 4818 JMIN=1 4819 JMAX=NUMARG 4820 MINNVA=2 4821 MAXNVA=2 4822 IF(IHIGH.EQ.'ON')THEN 4823 MINNVA=3 4824 MAXNVA=3 4825 ENDIF 4826C 4827 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 4828 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 4829 1 JMIN,JMAX, 4830 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 4831 1 IVARN1,IVARN2,IVARTY,PVAR, 4832 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 4833 1 MINNVA,MAXNVA, 4834 1 IFLAGM,IFLAGP, 4835 1 IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 4836 IF(IERROR.EQ.'YES')GOTO9000 4837C 4838 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'QUAN')THEN 4839 WRITE(ICOUT,999) 4840 CALL DPWRST('XXX','BUG ') 4841 WRITE(ICOUT,281) 4842 281 FORMAT('***** AFTER CALL DPPARS--') 4843 CALL DPWRST('XXX','BUG ') 4844 WRITE(ICOUT,282)NQ,NUMVAR 4845 282 FORMAT('NQ,NUMVAR = ',2I8) 4846 CALL DPWRST('XXX','BUG ') 4847 IF(NUMVAR.GT.0)THEN 4848 DO285I=1,NUMVAR 4849 WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 4850 1 ICOLR(I) 4851 287 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 4852 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 4853 CALL DPWRST('XXX','BUG ') 4854 285 CONTINUE 4855 ENDIF 4856 ENDIF 4857C 4858 DO290I=1,MAX(NRIGHT(1),NRIGHT(2)) 4859 XHIGH(I)=1.0 4860 290 CONTINUE 4861C 4862C IN ORDER TO ACCOMODATE MATRIX ARGUMENTS, CALL EACH 4863C VARIABLE SEPARATELY. 4864C 4865 NUMVA2=1 4866 ICOL=1 4867 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 4868 1 INAME,IVARN1,IVARN2,IVARTY, 4869 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 4870 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 4871 1 MAXCP4,MAXCP5,MAXCP6, 4872 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 4873 1 Y1,Y1,Y1,NS1,NTEMP,NTEMP,ICASE, 4874 1 IBUGG3,ISUBRO,IFOUND,IERROR) 4875 IF(IERROR.EQ.'YES')GOTO9000 4876C 4877 ICOL=2 4878 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 4879 1 INAME,IVARN1,IVARN2,IVARTY, 4880 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 4881 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 4882 1 MAXCP4,MAXCP5,MAXCP6, 4883 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 4884 1 Y2,Y2,Y2,NS2,NTEMP,NTEMP,ICASE, 4885 1 IBUGG3,ISUBRO,IFOUND,IERROR) 4886C 4887 IF(IHIGH.EQ.'ON')THEN 4888 ICOL=3 4889 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 4890 1 INAME,IVARN1,IVARN2,IVARTY, 4891 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 4892 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 4893 1 MAXCP4,MAXCP5,MAXCP6, 4894 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 4895 1 XHIGH,XHIGH,XHIGH,NHIGH,NTEMP,NTEMP,ICASE, 4896 1 IBUGG3,ISUBRO,IFOUND,IERROR) 4897 ELSE 4898 NHIGH=0 4899 ENDIF 4900C 4901C ******************************************************** 4902C ** STEP 41-- * 4903C ** FORM THE VERTICAL AND HORIZONTAL AXIS * 4904C ** VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR THE * 4905C ** PLOT. FORM THE CURVE DESIGNATION VARIABLE D(.) . * 4906C ** THIS WILL BE BOTH ONES FOR BOTH CASES * 4907C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). * 4908C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). * 4909C ******************************************************** 4910C 4911 ISTEPN='41' 4912 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'QUAN') 4913 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4914C 4915 CALL DPQUA2(Y1,NS1,Y2,NS2,XHIGH,NHIGH,ICASPL,MAXN,IQQNPR, 4916 1 TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,ITEMP1, 4917 1 Y,X,D,NPLOTP,NPLOTV, 4918 1 Y1SAVE,Y2SAVE,XDIST, 4919 1 IQQBOO,IBOOSS,ISEED,A0,A1,PPCC, 4920 1 IBUGG3,ISUBRO,IERROR) 4921 IF(IERROR.EQ.'YES')GOTO9000 4922C 4923 IH='PPCC' 4924 IH2=' ' 4925 VALUE0=PPCC 4926 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 4927 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 4928 1 IANS,IWIDTH,IBUGG3,IERROR) 4929C 4930 IH='PPA0' 4931 IH2=' ' 4932 VALUE0=A0 4933 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 4934 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 4935 1 IANS,IWIDTH,IBUGG3,IERROR) 4936C 4937 IH='PPA1' 4938 IH2=' ' 4939 VALUE0=A1 4940 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 4941 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 4942 1 IANS,IWIDTH,IBUGG3,IERROR) 4943C 4944C 4945C ***************** 4946C ** STEP 90-- ** 4947C ** EXIT ** 4948C ***************** 4949C 4950 9000 CONTINUE 4951 IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'QUAN')THEN 4952 WRITE(ICOUT,999) 4953 CALL DPWRST('XXX','BUG ') 4954 WRITE(ICOUT,9011) 4955 9011 FORMAT('***** AT THE END OF DPQUAN--') 4956 CALL DPWRST('XXX','BUG ') 4957 WRITE(ICOUT,9012)IFOUND,IERROR 4958 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 4959 CALL DPWRST('XXX','BUG ') 4960 WRITE(ICOUT,9013)NPLOTV,NPLOTP,ICASPL,IAND1,IAND2 4961 9013 FORMAT('NPLOTV,NPLOTP,ICASPL,IAND1,IAND2 = ', 4962 1 2I8,2X,2(A4,2X),A4) 4963 CALL DPWRST('XXX','BUG ') 4964 WRITE(ICOUT,9014)ICASPL,IHIGH,MAXN,NUMVAR 4965 9014 FORMAT('ICASPL,IHIGH,MAXN,NUMVAR = ',A4,2X,A4,2I8) 4966 CALL DPWRST('XXX','BUG ') 4967 WRITE(ICOUT,9015)NS1,NS2,NHIGH 4968 9015 FORMAT('NS1,NS2,NHIGH = ',3I8) 4969 CALL DPWRST('XXX','BUG ') 4970 IF(NPLOTP.GT.0)THEN 4971 DO9020I=1,NPLOTP 4972 WRITE(ICOUT,9021)I,Y(I),X(I),D(I) 4973 9021 FORMAT('I,Y(I),X(I),D(I) = ',I8,3G15.7) 4974 CALL DPWRST('XXX','BUG ') 4975 9020 CONTINUE 4976 ENDIF 4977 ENDIF 4978C 4979 RETURN 4980 END 4981 SUBROUTINE DPQUA2(Y,NY,X,NX,XHIGH,NHIGH,ICASPL,MAXN,IQQNPR, 4982 1 TEMP1,TEMP2,TEMP3,TEMP4,AINDEX,INDX, 4983 1 Y2,X2,D2,N2,NPLOTV, 4984 1 YSAVE,XSAVE,XDIST, 4985 1 IQQBOO,IBOOSS,ISEED,A0,A1,PPCC, 4986 1 IBUGG3,ISUBRO,IERROR) 4987C 4988C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS THAT WILL DEFINE 4989C A QUANTILE PLOT 4990C (USEFUL FOR DISTRIBUTIONALLY COMPARING 2 DATA SETS). 4991C NOTE--THE QUANTILES FOR THE FIRST ARGUMENT WILL APPEAR VERTICALLY; 4992C THE QUANTILES FOR THE SECOND ARGUMENT WILL APPEAR HORIZONTALLY. 4993C WRITTEN BY--JAMES J. FILLIBEN 4994C STATISTICAL ENGINEERING DIVISION 4995C INFORMATION TECHNOLOGY LABORATORY 4996C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 4997C GAITHERSBURG, MD 20899-8980 4998C PHONE--301-975-2855 4999C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5000C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5001C LANGUAGE--ANSI FORTRAN (1977) 5002C VERSION NUMBER--87/6 5003C ORIGINAL VERSION--JUNE 1987. 5004C UPDATED --MARCH 1988. PUT IN DIAGONAL REFERENCE LINE 5005C UPDATED --JUNE 1990. MOVE SOME DIMENSIONS TO DPQUAN 5006C UPDATED --APRIL 1992. N TO NX IN DEBUG STATEMENTS 5007C UPDATED --NOVEMBER 1994. EQUATE ICASE TO ICASPL 5008C UPDATED --FEBRUARY 2011. SUPPORT FOR "HIGHLIGHT" OPTION 5009C UPDATED --JUNE 2016. ALLOW USER-SPECIFED PERCENTILES 5010C UPDATED --JUNE 2016. SAVE A0, A1, PPCC VALUES FROM 5011C PLOT 5012C UPDATED --JUNE 2016. DON'T TREAT N=1 OR ALL DATA 5013C VALUES EQUAL AS AN ERROR. TREAT 5014C AS A "DEGENERATE" CASE. 5015C UPDATED --JUNE 2016. BOOTSTRAP FOR POINT WISE 5016C CONFIDENCE INTERVALS 5017C 5018C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5019C 5020 CHARACTER*4 IQQBOO 5021 CHARACTER*4 IBUGG3 5022 CHARACTER*4 ISUBRO 5023 CHARACTER*4 IERROR 5024C 5025 CHARACTER*4 ICASE 5026 CHARACTER*4 ICASJB 5027 CHARACTER*4 IOP 5028CCCCC ADD FOLLOWING LINE NOVEMBER 1994. 5029 CHARACTER*4 ICASPL 5030C 5031 CHARACTER*4 ISUBN1 5032 CHARACTER*4 ISUBN2 5033 CHARACTER*4 ISTEPN 5034 CHARACTER*4 IWRITE 5035 CHARACTER*1 IATEMP 5036C 5037C--------------------------------------------------------------------- 5038C 5039 DIMENSION Y(*) 5040 DIMENSION X(*) 5041 DIMENSION XHIGH(*) 5042 DIMENSION Y2(*) 5043 DIMENSION X2(*) 5044 DIMENSION D2(*) 5045 DIMENSION YSAVE(*) 5046 DIMENSION XSAVE(*) 5047 DIMENSION XDIST(*) 5048 DIMENSION TEMP1(*) 5049 DIMENSION TEMP2(*) 5050 DIMENSION TEMP3(*) 5051 DIMENSION TEMP4(*) 5052 DIMENSION AINDEX(*) 5053C 5054 INTEGER INDX(*) 5055C 5056C--------------------------------------------------------------------- 5057C 5058 INCLUDE 'DPCOP2.INC' 5059C 5060C-----START POINT----------------------------------------------------- 5061C 5062 ISUBN1='DPQU' 5063 ISUBN2='A2 ' 5064 IERROR='NO' 5065 IWRITE='OFF' 5066 ICASE=ICASPL 5067 ICASJB='BOOT' 5068C 5069 ANY=NY 5070 ANX=NX 5071 NTAG=0 5072 NXSAVE=0 5073 NYSAVE=0 5074C 5075 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QUA2')THEN 5076 WRITE(ICOUT,999) 5077 999 FORMAT(1X) 5078 CALL DPWRST('XXX','BUG ') 5079 WRITE(ICOUT,51) 5080 51 FORMAT('***** AT THE BEGINNING OF DPQUA2--') 5081 CALL DPWRST('XXX','BUG ') 5082 WRITE(ICOUT,52)IBUGG3,ISUBRO,ICASPL,IQQBOO 5083 52 FORMAT('IBUGG3,ISUBRO,ICASPL,IQQBOO = ',3(A4,2X),A4) 5084 CALL DPWRST('XXX','BUG ') 5085 WRITE(ICOUT,53)MAXN,NX,NY,NHIGH,IQQNPR,IBOOSS,ISEED 5086 53 FORMAT('MAXN,NX,NY,NHIGH,IQQNPR,IBOOSS,ISEED = ',7I8) 5087 CALL DPWRST('XXX','BUG ') 5088 IF(NY.GE.1)THEN 5089 DO61I=1,NY 5090 WRITE(ICOUT,62)I,Y(I) 5091 62 FORMAT('I,Y(I) = ',I8,G15.7) 5092 CALL DPWRST('XXX','BUG ') 5093 61 CONTINUE 5094 ENDIF 5095 IF(NX.GE.1)THEN 5096 DO71I=1,NX 5097 WRITE(ICOUT,72)I,X(I) 5098 72 FORMAT('I,X(I) = ',I8,G15.7) 5099 CALL DPWRST('XXX','BUG ') 5100 71 CONTINUE 5101 ENDIF 5102 IF(NHIGH.GE.1)THEN 5103 DO81I=1,NHIGH 5104 WRITE(ICOUT,82)I,XHIGH(I) 5105 82 FORMAT('I,XHIGH(I) = ',I8,G15.7) 5106 CALL DPWRST('XXX','BUG ') 5107 81 CONTINUE 5108 ENDIF 5109 ENDIF 5110C 5111C ******************************************** 5112C ** STEP 11-- ** 5113C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 5114C ******************************************** 5115C 5116 ISTEPN='11' 5117 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QUA2') 5118 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5119C 5120C 2016/06: ONLY REQUIRE N >= 1. 5121C 5122CCCCC IF(NY.LT.2)THEN 5123 IF(NY.LT.1)THEN 5124 WRITE(ICOUT,999) 5125 CALL DPWRST('XXX','BUG ') 5126 WRITE(ICOUT,1111) 5127 1111 FORMAT('***** ERROR IN QUANTILE-QUANTILE PLOT--') 5128 CALL DPWRST('XXX','BUG ') 5129 WRITE(ICOUT,1112) 5130 1112 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE FIRST ', 5131 1 'RESPONSE VARIABLE IS LESS THAN ONE.') 5132 CALL DPWRST('XXX','BUG ') 5133 WRITE(ICOUT,1114)NY 5134 1114 FORMAT(' THE NUMBER OF OBSERVATIONS = ',I8) 5135 CALL DPWRST('XXX','BUG ') 5136 IERROR='YES' 5137 GOTO9000 5138 ELSEIF(NX.LT.1)THEN 5139 WRITE(ICOUT,999) 5140 CALL DPWRST('XXX','BUG ') 5141 WRITE(ICOUT,1111) 5142 CALL DPWRST('XXX','BUG ') 5143 WRITE(ICOUT,1122) 5144 1122 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE SECOND ', 5145 1 'RESPONSE VARIABLE IS LESS THAN ONE.') 5146 CALL DPWRST('XXX','BUG ') 5147 WRITE(ICOUT,1114)NX 5148 CALL DPWRST('XXX','BUG ') 5149 IERROR='YES' 5150 GOTO9000 5151 ELSEIF(NHIGH.GT.0 .AND. NHIGH.NE.MIN(NX,NY))THEN 5152 WRITE(ICOUT,999) 5153 CALL DPWRST('XXX','BUG ') 5154 WRITE(ICOUT,1111) 5155 CALL DPWRST('XXX','BUG ') 5156 WRITE(ICOUT,1125) 5157 1125 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE HIGHLIGHTING ', 5158 1 'VARIABLE IS') 5159 CALL DPWRST('XXX','BUG ') 5160 WRITE(ICOUT,1126) 5161 1126 FORMAT(' NOT EQUAL TO THE NUMBER OF OBSERVATIONS IN THE ', 5162 1 'SHORTER RESPONSE VARIABLE.') 5163 CALL DPWRST('XXX','BUG ') 5164 WRITE(ICOUT,1127)NY 5165 1127 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE FIRST ', 5166 1 'RESPONSE VARIABLE = ',I8) 5167 CALL DPWRST('XXX','BUG ') 5168 WRITE(ICOUT,1128)NX 5169 1128 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE SECOND ', 5170 1 'RESPONSE VARIABLE = ',I8) 5171 CALL DPWRST('XXX','BUG ') 5172 WRITE(ICOUT,1129)NHIGH 5173 1129 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE HIGHLIGHT ', 5174 1 'VARIABLE = ',I8) 5175 CALL DPWRST('XXX','BUG ') 5176 IERROR='YES' 5177 GOTO9000 5178 ENDIF 5179C 5180CCCCC HOLD=Y(1) 5181CCCCC DO1130I=1,NY 5182CCCCC IF(Y(I).NE.HOLD)GOTO1139 5183C1130 CONTINUE 5184CCCCC WRITE(ICOUT,999) 5185CCCCC CALL DPWRST('XXX','BUG ') 5186CCCCC WRITE(ICOUT,1111) 5187CCCCC CALL DPWRST('XXX','BUG ') 5188CCCCC WRITE(ICOUT,1132) 5189C1132 FORMAT(' ALL ELEMENTS FOR THE FIRST RESPONSE VARIABLE') 5190CCCCC CALL DPWRST('XXX','BUG ') 5191CCCCC WRITE(ICOUT,1133)HOLD 5192C1133 FORMAT(' ARE IDENTICALLY EQUAL TO ',G15.7) 5193CCCCC CALL DPWRST('XXX','BUG ') 5194CCCCC WRITE(ICOUT,999) 5195CCCCC CALL DPWRST('XXX','BUG ') 5196CCCCC IERROR='YES' 5197CCCCC GOTO9000 5198C1139 CONTINUE 5199C 5200CCCCC HOLD=X(1) 5201CCCCC DO1140I=1,NY 5202CCCCC IF(X(I).NE.HOLD)GOTO1149 5203C1140 CONTINUE 5204CCCCC WRITE(ICOUT,999) 5205CCCCC CALL DPWRST('XXX','BUG ') 5206CCCCC WRITE(ICOUT,1111) 5207CCCCC CALL DPWRST('XXX','BUG ') 5208CCCCC WRITE(ICOUT,1142) 5209C1142 FORMAT(' ALL ELEMENTS FOR THE SECOND RESPONSE VARIABLE') 5210CCCCC CALL DPWRST('XXX','BUG ') 5211CCCCC WRITE(ICOUT,1143)HOLD 5212C1143 FORMAT(' ARE IDENTICALLY EQUAL TO ',G15.7) 5213CCCCC CALL DPWRST('XXX','BUG ') 5214CCCCC WRITE(ICOUT,999) 5215CCCCC CALL DPWRST('XXX','BUG ') 5216CCCCC IERROR='YES' 5217CCCCC GOTO9000 5218C1149 CONTINUE 5219C 5220 IF(IQQBOO.EQ.'ON')THEN 5221 DO1210II=1,NX 5222 XSAVE(II)=X(II) 5223 1210 CONTINUE 5224 NXSAVE=NX 5225 DO1220II=1,NY 5226 YSAVE(II)=Y(II) 5227 1220 CONTINUE 5228 NYSAVE=NY 5229C 5230 IOP='OPEN' 5231 IFLAG1=1 5232 IFLAG2=0 5233 IFLAG3=0 5234 IFLAG4=0 5235 IFLAG5=0 5236 CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5, 5237 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 5238 1 IBUGG3,ISUBRO,IERROR) 5239 IF(IERROR.EQ.'YES')GOTO9000 5240 ENDIF 5241C 5242 IPASS=-1 5243C 5244C **************************************************** 5245C ** STEP 21-- ** 5246C ** SORT Y AND SORT X ** 5247C **************************************************** 5248C 5249 2000 CONTINUE 5250 IPASS=IPASS+1 5251C 5252 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QUA2')THEN 5253 WRITE(ICOUT,2002) 5254 2002 FORMAT('IPASS: ',I10) 5255 CALL DPWRST('XXX','BUG ') 5256 ENDIF 5257C 5258 IF(IPASS.GT.0)THEN 5259 IF(IQQBOO.EQ.'OFF' .OR. IPASS.GT.IBOOSS)THEN 5260 GOTO8000 5261 ELSE 5262 DO2001II=1,NXSAVE 5263 X(II)=XSAVE(II) 5264 2001 CONTINUE 5265 NX=NXSAVE 5266 DO2003II=1,NYSAVE 5267 Y(II)=YSAVE(II) 5268 2003 CONTINUE 5269 NY=NYSAVE 5270C 5271C FOR BOOTSTRAP, FIX X ARRAY BUT CREATE BOOTSTRAP 5272C ARRAY FOR Y ARRAY. 5273C 5274 IJACIN=0 5275CCCCC CALL DPJBS3(X,NX,ICASJB,IJACIN,ISEED,TEMP4,NX2, 5276CCCCC1 INDX,AINDEX, 5277CCCCC1 IBUGG3,IERROR) 5278CCCCC DO2006II=1,NX 5279CCCCC X(II)=TEMP4(II) 5280C2006 CONTINUE 5281C 5282 CALL DPJBS3(Y,NY,ICASJB,IJACIN,ISEED,TEMP4,NY2, 5283 1 INDX,AINDEX, 5284 1 IBUGG3,IERROR) 5285 DO2008II=1,NY 5286 Y(II)=TEMP4(II) 5287 2008 CONTINUE 5288C 5289 ENDIF 5290 ENDIF 5291C 5292 ISTEPN='21' 5293 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QUA2') 5294 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5295C 5296 IF(NHIGH.LE.0)THEN 5297 IF(IQQNPR.GT.0)THEN 5298 CALL PERCE2(IQQNPR,X,NX,IWRITE,TEMP3,MAXN,TEMP1, 5299 1 IBUGG3,ISUBRO,IERROR) 5300 DO2010II=1,IQQNPR 5301 X(II)=TEMP1(II) 5302 2010 CONTINUE 5303 NX=IQQNPR 5304C 5305 CALL PERCE2(IQQNPR,Y,NY,IWRITE,TEMP3,MAXN,TEMP2, 5306 1 IBUGG3,ISUBRO,IERROR) 5307 DO2020II=1,IQQNPR 5308 Y(II)=TEMP2(II) 5309 2020 CONTINUE 5310 NY=IQQNPR 5311C 5312 ELSE 5313 CALL SORT(X,NX,X) 5314 CALL SORT(Y,NY,Y) 5315 ENDIF 5316 ELSEIF(NY.LE.NX)THEN 5317 CALL SORT(X,NX,X) 5318 CALL SORTC(Y,XHIGH,NY,Y,XDIST) 5319 DO2101I=1,NY 5320 XHIGH(I)=XDIST(I) 5321 2101 CONTINUE 5322 ELSEIF(NY.GT.NX)THEN 5323 CALL SORT(Y,NY,Y) 5324 CALL SORTC(X,XHIGH,NX,X,XDIST) 5325 DO2103I=1,NX 5326 XHIGH(I)=XDIST(I) 5327 2103 CONTINUE 5328 ENDIF 5329C 5330C ***************************************** 5331C ** STEP 22-- ** 5332C ** DETERMINE THE TYPE CASE ** 5333C ** EQUAL SAMPLE SIZES OR NOT) ** 5334C ** AND BRANCH ACORDINGLY ** 5335C ***************************************** 5336C 5337 ISTEPN='22' 5338 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QUA2') 5339 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5340C 5341 IF(NY.LT.NX)THEN 5342 CALL PERCE2(NY,X,NX,IWRITE,TEMP3,MAXN,TEMP2, 5343 1 IBUGG3,ISUBRO,IERROR) 5344 DO2120II=1,NY 5345 X(II)=TEMP2(II) 5346 2120 CONTINUE 5347 NX=NY 5348 ELSEIF(NY.GT.NX)THEN 5349 CALL PERCE2(NX,Y,NY,IWRITE,TEMP3,MAXN,TEMP2, 5350 1 IBUGG3,ISUBRO,IERROR) 5351 DO2130II=1,NX 5352 Y(II)=TEMP2(II) 5353 2130 CONTINUE 5354 NY=NX 5355 ENDIF 5356C 5357C ******************************************* 5358C ** STEP 51-- ** 5359C ** FORM PLOT COORDINATES ** 5360C ******************************************* 5361C 5362 ISTEPN='51' 5363 IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QUA2') 5364 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5365C 5366 IF(IPASS.EQ.0)THEN 5367 IF(NHIGH.GT.0)THEN 5368 CALL CODE(XHIGH,NHIGH,IWRITE,XDIST,D2,MAXN,IBUGG3,IERROR) 5369 CALL MAXIM(XDIST,NHIGH,IWRITE,XMAX,IBUGG3,IERROR) 5370 ENDIF 5371C 5372 J=0 5373 DO5111I=1,NX 5374 J=J+1 5375 Y2(J)=Y(J) 5376 X2(J)=X(J) 5377 IF(NHIGH.EQ.0)THEN 5378 D2(J)=1.0 5379 ELSE 5380 D2(J)=XDIST(J) 5381 ENDIF 5382 5111 CONTINUE 5383C 5384 N2=J 5385 CALL LINFIT(Y2,X2,N2, 5386 1 A0,A1,RESSD,RESDF,PPCC,SDA0,SDA1,CCALBE, 5387 1 ISUBRO,IBUGG3,IERROR) 5388C 5389 IF(NHIGH.EQ.0)THEN 5390 NTEMP=1 5391 ELSE 5392 NTEMP=INT(XMAX+0.1) 5393 ENDIF 5394C 5395 NTEMP=NTEMP+1 5396 AMIN=X(1) 5397 AMIN2=X(1) 5398 IF(Y(1).LT.X(1))AMIN=Y(1) 5399 J=J+1 5400 Y2(J)=AMIN 5401 X2(J)=AMIN 5402 D2(J)=REAL(NTEMP) 5403C 5404 AMAX=X(NX) 5405 AMAX2=X(NX) 5406 IF(Y(NY).GT.X(NX))AMAX=Y(NY) 5407 J=J+1 5408 Y2(J)=AMAX 5409 X2(J)=AMAX 5410 D2(J)=REAL(NTEMP) 5411C 5412C 2016/06: GENERATE FITTED LINE ON THE PLOT 5413C 5414 NTEMP=NTEMP+1 5415 XVAL=AMIN2 5416 YVAL=A0 + A1*XVAL 5417 J=J+1 5418 X2(J)=XVAL 5419 Y2(J)=YVAL 5420 D2(J)=REAL(NTEMP) 5421C 5422 XVAL=AMAX2 5423 YVAL=A0 + A1*XVAL 5424 J=J+1 5425 X2(J)=XVAL 5426 Y2(J)=YVAL 5427 D2(J)=REAL(NTEMP) 5428C 5429 N2=J 5430 NPLOTV=3 5431 NTAG=NTEMP 5432 ELSE 5433 DO5211I=1,NX 5434 WRITE(IOUNI1,5213)IPASS,I,Y(I),X(I) 5435 5213 FORMAT(2I10,2E15.7) 5436 5211 CONTINUE 5437 ENDIF 5438C 5439 IF(IQQBOO.EQ.'ON')GOTO2000 5440 GOTO9000 5441C 5442 8000 CONTINUE 5443 IF(IQQBOO.EQ.'ON')THEN 5444C 5445C STEP 1: CLOSE THE FILE CONTAINING THE BOOTSTRAP POINTS 5446C 5447 IOP='CLOS' 5448 CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5, 5449 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 5450 1 IBUGG3,ISUBRO,IERROR) 5451 IF(IERROR.EQ.'YES')GOTO9000 5452C 5453C STEP 2: RE-OPEN THE FILE 5454C 5455 IOP='OPEN' 5456 CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5, 5457 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 5458 1 IBUGG3,ISUBRO,IERROR) 5459 IF(IERROR.EQ.'YES')GOTO9000 5460C 5461C STEP 3: NOW LOOP THROUGH THE POINTS 5462C 5463 NTEMP=MIN(NX,NY) 5464 DO8010II=1,NTEMP 5465 REWIND(IOUNI1) 5466 IVAL=II 5467 ISKIP1=IVAL-1 5468 ISKIP2=NTEMP-IVAL 5469 ICNT=0 5470C 5471 DO8020JJ=1,IBOOSS 5472 DO8030KK=1,ISKIP1 5473 READ(IOUNI1,'(A1)',END=8091,ERR=8093)IATEMP 5474 8030 CONTINUE 5475 ICNT=ICNT+1 5476 READ(IOUNI1,5213,END=8091,ERR=8093)IJUK1,IJUNK2, 5477 1 TEMP1(ICNT),TEMP2(ICNT) 5478 DO8040KK=1,ISKIP2 5479 READ(IOUNI1,'(A1)',END=8091,ERR=8093)IATEMP 5480 8040 CONTINUE 5481 8020 CONTINUE 5482 P025=2.5 5483 CALL PERCEN(P025,TEMP1,ICNT,IWRITE,TEMP3,MAXN, 5484 1 Y025,IBUGG3,IERROR) 5485 CALL PERCEN(P025,TEMP2,ICNT,IWRITE,TEMP3,MAXN, 5486 1 X025,IBUGG3,IERROR) 5487 P975=97.5 5488 CALL PERCEN(P975,TEMP1,ICNT,IWRITE,TEMP3,MAXN, 5489 1 Y975,IBUGG3,IERROR) 5490 CALL PERCEN(P975,TEMP2,ICNT,IWRITE,TEMP3,MAXN, 5491 1 X975,IBUGG3,IERROR) 5492 N2=N2+1 5493 X2(N2)=X025 5494 Y2(N2)=Y025 5495 D2(N2)=REAL(NTAG+1) 5496 N2=N2+1 5497 X2(N2)=X975 5498 Y2(N2)=Y975 5499 D2(N2)=REAL(NTAG+2) 5500C 5501 8010 CONTINUE 5502 GOTO8099 5503C 5504C STEP 4: UNEXPECTED END OF FILE ENCOUNTERED 5505C 5506 8091 CONTINUE 5507 WRITE(ICOUT,999) 5508 CALL DPWRST('XXX','BUG ') 5509 WRITE(ICOUT,1111) 5510 CALL DPWRST('XXX','BUG ') 5511 WRITE(ICOUT,8111) 5512 8111 FORMAT(' UNEXPECTED END OF FILE READING BOOTSTRAP FILE.') 5513 CALL DPWRST('XXX','BUG ') 5514 GOTO8099 5515C 5516C STEP 5: UNEXPECTED ERROR READING FILE 5517C 5518 8093 CONTINUE 5519 WRITE(ICOUT,999) 5520 CALL DPWRST('XXX','BUG ') 5521 WRITE(ICOUT,1111) 5522 CALL DPWRST('XXX','BUG ') 5523 WRITE(ICOUT,8113) 5524 8113 FORMAT(' UNEXPECTED ERROR READING BOOTSTRAP FILE.') 5525 CALL DPWRST('XXX','BUG ') 5526 GOTO8099 5527C 5528C STEP 6: FINAL CLOSE OF FILE 5529C 5530 8099 CONTINUE 5531 IOP='CLOS' 5532 CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5, 5533 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 5534 1 IBUGG3,ISUBRO,IERROR) 5535 IF(IERROR.EQ.'YES')GOTO9000 5536C 5537 ENDIF 5538C ***************** 5539C ** STEP 90-- ** 5540C ** EXIT ** 5541C ***************** 5542C 5543 9000 CONTINUE 5544 IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'QUA2')THEN 5545 WRITE(ICOUT,999) 5546 CALL DPWRST('XXX','BUG ') 5547 WRITE(ICOUT,9011) 5548 9011 FORMAT('***** AT THE END OF DPQUA2--') 5549 CALL DPWRST('XXX','BUG ') 5550 WRITE(ICOUT,9012)N2,ICASPL,ICASE,IERROR 5551 9012 FORMAT('N2,ICASPL,ICASE,IERROR = ',I8,2(A4,2X),A4) 5552 CALL DPWRST('XXX','BUG ') 5553 DO9015I=1,N2 5554 WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I) 5555 9016 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,3G15.7) 5556 CALL DPWRST('XXX','BUG ') 5557 9015 CONTINUE 5558 WRITE(ICOUT,9053)NY,NX,AMIN,AMAX 5559 9053 FORMAT('NY,NX,AMIN,AMAX = ',2I8,2G15.7) 5560 CALL DPWRST('XXX','BUG ') 5561 ENDIF 5562C 5563 RETURN 5564 END 5565 SUBROUTINE DPQUCO(XTEMP1,XTEMP2,MAXNXT,ICASAN, 5566 1 ICAPSW,IFORSW,IMULT,IREPL, 5567 1 ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) 5568C 5569C PURPOSE--GENERATE CONFIDENCE LIMITS FOR QUANTILES (MEDIAN IS 5570C A SPECIAL CASE). METHOD BASED ON MARITZ-JARRETT 5571C ESTIMATE FOR STANDARD ERROR. 5572C WRITTEN BY--JAMES J. FILLIBEN 5573C STATISTICAL ENGINEERING DIVISION 5574C INFORMATION TECHNOLOGY LABORATORY 5575C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5576C GAITHERSBURG, MD 20899-8980 5577C PHONE--301-975-2855 5578C REFERENCE--"INTRODUCTION TO ROBUST ESTIMATION AND HYPOTHESIS 5579C TESTING", RAND R. WILCOX, ACADEMIC PRESS, 1997. 5580C 1977. 5581C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5582C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5583C LANGUAGE--ANSI FORTRAN (1977) 5584C VERSION NUMBER--2003/2 5585C ORIGINAL VERSION--FEBRUARY 2003. 5586C UPDATED --OCTOBER 2003. ADD SUPPORT FOR HTML, LATEX 5587C OUTPUT 5588C UPDATED --MARCH 2010. USE DPDTA1, DPDTA4 TO GENERATE 5589C HTML, LATEX, RTF FORMAT 5590C UPDATED --MARCH 2010. SUPPORT FOR MULTIPLE RESPONSE 5591C VARIABLES AND FOR GROUP-ID 5592C VARIABLES (I.E., REPLICATION 5593C CASE) 5594C UPDATED --MARCH 2010. USE DPPAR3 TO EXTRACT EITHER A 5595C RESPONSE VARIABLE OR A MATRIX 5596C NAME 5597C UPDATED --AUGUST 2019. ADD CTL999, CTU999 5598C 5599C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5600C 5601 CHARACTER*4 ICAPSW 5602 CHARACTER*4 IFORSW 5603 CHARACTER*4 IBUGA2 5604 CHARACTER*4 IBUGA3 5605 CHARACTER*4 IBUGQ 5606 CHARACTER*4 ISUBRO 5607 CHARACTER*4 IFOUND 5608 CHARACTER*4 IERROR 5609C 5610 CHARACTER*4 IHWUSE 5611 CHARACTER*4 MESSAG 5612 CHARACTER*4 ICASEQ 5613 CHARACTER*4 IH 5614 CHARACTER*4 IH2 5615 CHARACTER*4 ICASAN 5616 CHARACTER*4 ICASE 5617 CHARACTER*4 ISUBN1 5618 CHARACTER*4 ISUBN2 5619 CHARACTER*4 ISTEPN 5620 CHARACTER*4 IFLAGU 5621 CHARACTER*4 IREPL 5622 CHARACTER*4 IMULT 5623C 5624 LOGICAL IFRST 5625 LOGICAL ILAST 5626C 5627 CHARACTER*40 INAME 5628 PARAMETER (MAXSPN=30) 5629 CHARACTER*4 IVARN1(MAXSPN) 5630 CHARACTER*4 IVARN2(MAXSPN) 5631 CHARACTER*4 IVARTY(MAXSPN) 5632 CHARACTER*4 IVARID(MAXSPN) 5633 CHARACTER*4 IVARI2(MAXSPN) 5634 REAL PVAR(MAXSPN) 5635 REAL PID(MAXSPN) 5636 INTEGER ILIS(MAXSPN) 5637 INTEGER NRIGHT(MAXSPN) 5638 INTEGER ICOLR(MAXSPN) 5639C 5640C--------------------------------------------------------------------- 5641C 5642 INCLUDE 'DPCOPA.INC' 5643C 5644 DIMENSION XTEMP1(*) 5645 DIMENSION XTEMP2(*) 5646 DIMENSION TEMP1(MAXOBV) 5647 DIMENSION TEMP2(MAXOBV) 5648C 5649 DIMENSION XDESGN(MAXOBV,6) 5650 DIMENSION XIDTEM(MAXOBV) 5651 DIMENSION XIDTE2(MAXOBV) 5652 DIMENSION XIDTE3(MAXOBV) 5653 DIMENSION XIDTE4(MAXOBV) 5654 DIMENSION XIDTE5(MAXOBV) 5655 DIMENSION XIDTE6(MAXOBV) 5656C 5657 INCLUDE 'DPCOZZ.INC' 5658 EQUIVALENCE (GARBAG(IGARB1),XIDTEM(1)) 5659 EQUIVALENCE (GARBAG(IGARB2),XIDTE2(1)) 5660 EQUIVALENCE (GARBAG(IGARB3),XIDTE3(1)) 5661 EQUIVALENCE (GARBAG(IGARB4),XIDTE4(1)) 5662 EQUIVALENCE (GARBAG(IGARB5),XIDTE5(1)) 5663 EQUIVALENCE (GARBAG(IGARB6),XIDTE6(1)) 5664 EQUIVALENCE (GARBAG(IGARB7),TEMP1(1)) 5665 EQUIVALENCE (GARBAG(IGARB8),TEMP2(1)) 5666 EQUIVALENCE (GARBAG(IGAR10),XDESGN(1,1)) 5667C 5668C-----COMMON---------------------------------------------------------- 5669C 5670 INCLUDE 'DPCOHK.INC' 5671 INCLUDE 'DPCOSU.INC' 5672 INCLUDE 'DPCODA.INC' 5673 INCLUDE 'DPCOHO.INC' 5674 INCLUDE 'DPCOST.INC' 5675 INCLUDE 'DPCOP2.INC' 5676C 5677C-----START POINT----------------------------------------------------- 5678C 5679 ISUBN1='DPQU' 5680 ISUBN2='CO ' 5681C 5682 MAXCP1=MAXCOL+1 5683 MAXCP2=MAXCOL+2 5684 MAXCP3=MAXCOL+3 5685 MAXCP4=MAXCOL+4 5686 MAXCP5=MAXCOL+5 5687 MAXCP6=MAXCOL+6 5688C 5689 IFOUND='YES' 5690 IERROR='NO' 5691C 5692C ************************************************* 5693C ** TREAT THE QUANTILE CONFIDENCE LIMITS CASE ** 5694C ************************************************* 5695C 5696 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUCO')THEN 5697 WRITE(ICOUT,999) 5698 999 FORMAT(1X) 5699 CALL DPWRST('XXX','BUG ') 5700 WRITE(ICOUT,51) 5701 51 FORMAT('***** AT THE BEGINNING OF DPQUCO--') 5702 CALL DPWRST('XXX','BUG ') 5703 WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ICASAN,MAXNXT 5704 52 FORMAT('IBUGA2,IBUGA3,IBUGQ,ICASAN,MAXNXT = ',4(A4,2X),I8) 5705 CALL DPWRST('XXX','BUG ') 5706 ENDIF 5707C 5708C ********************************* 5709C ** STEP 1-- ** 5710C ** EXTRACT THE VARIABLE LIST ** 5711C ********************************* 5712C 5713 ISTEPN='1' 5714 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUCO') 5715 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5716C 5717 INAME='QUANTILE CONFIDENCE LIMITS' 5718 MAXNA=100 5719 MINNVA=1 5720 MAXNVA=100 5721 MINNA=1 5722 IFLAGE=1 5723 IF(IREPL.EQ.'ON')THEN 5724 MAXNVA=7 5725 ELSE 5726 MAXNVA=100 5727 IFLAGE=0 5728 ENDIF 5729 MINN2=2 5730 IFLAGM=1 5731 IFLAGP=0 5732 JMIN=1 5733 JMAX=NUMARG 5734C 5735 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 5736 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 5737 1 JMIN,JMAX, 5738 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 5739 1 IVARN1,IVARN2,IVARTY,PVAR, 5740 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 5741 1 MINNVA,MAXNVA, 5742 1 IFLAGM,IFLAGP, 5743 1 IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 5744 IF(IERROR.EQ.'YES')GOTO9000 5745C 5746 IF(NUMVAR.GT.1 .AND. IREPL.EQ.'OFF')IMULT='ON' 5747C 5748 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUCO')THEN 5749 WRITE(ICOUT,999) 5750 CALL DPWRST('XXX','BUG ') 5751 WRITE(ICOUT,181) 5752 181 FORMAT('***** AFTER CALL DPPARS--') 5753 CALL DPWRST('XXX','BUG ') 5754 WRITE(ICOUT,182)NQ,NUMVAR,IMULT,IREPL 5755 182 FORMAT('NQ,NUMVAR,IMULT,IREPL = ',2I8,2X,A4,2X,A4) 5756 CALL DPWRST('XXX','BUG ') 5757 IF(NUMVAR.GT.0)THEN 5758 DO185I=1,NUMVAR 5759 WRITE(ICOUT,187)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 5760 1 ICOLR(I) 5761 187 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 5762 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 5763 CALL DPWRST('XXX','BUG ') 5764 185 CONTINUE 5765 ENDIF 5766 ENDIF 5767C 5768C *********************************************** 5769C ** STEP 2-- ** 5770C ** DETERMINE: ** 5771C ** 1) NUMBER OF REPLICATION VARIABLES (0-6) ** 5772C ** 2) NUMBER OF RESPONSE VARIABLES (>= 1)** 5773C *********************************************** 5774C 5775 ISTEPN='2' 5776 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUCO') 5777 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5778C 5779 NRESP=0 5780 NREPL=0 5781C 5782 IF(IMULT.EQ.'ON')THEN 5783 NRESP=NUMVAR 5784 ELSEIF(IREPL.EQ.'ON')THEN 5785 NRESP=1 5786 NREPL=NUMVAR-NRESP 5787 IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN 5788 WRITE(ICOUT,999) 5789 CALL DPWRST('XXX','BUG ') 5790 WRITE(ICOUT,101) 5791 101 FORMAT('***** ERROR IN QUANTILE CONFIDENCE LIMITS--') 5792 CALL DPWRST('XXX','BUG ') 5793 WRITE(ICOUT,211) 5794 211 FORMAT(' FOR THE REPLICATION CASE, THE NUMBER OF ', 5795 1 'REPLICATION VARIABLES') 5796 CALL DPWRST('XXX','BUG ') 5797 WRITE(ICOUT,213)NREPL 5798 213 FORMAT(' THE NUMBER OF REPLICATION VARIABLES = ',I5) 5799 CALL DPWRST('XXX','BUG ') 5800 IERROR='YES' 5801 GOTO9000 5802 ENDIF 5803 ELSE 5804 NRESP=1 5805 ENDIF 5806C 5807 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUCO')THEN 5808 WRITE(ICOUT,221)NRESP,NREPL 5809 221 FORMAT('NRESP,NREPL = ',2I5) 5810 CALL DPWRST('XXX','BUG ') 5811 ENDIF 5812C 5813C ****************************************************** 5814C ** STEP 3-- ** 5815C ** DETERMINE QUANTILE TO USE (FROM P100) ** 5816C ****************************************************** 5817C 5818 IF(ICASAN.EQ.'MECI')THEN 5819 P100=0.50 5820 ELSE 5821 IH='P100' 5822 IH2=' ' 5823 IHWUSE='P' 5824 MESSAG='YES' 5825 CALL CHECKN(IH,IH2,IHWUSE, 5826 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 5827 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 5828 IF(IERROR.EQ.'YES')GOTO9000 5829 P100=VALUE(ILOCP) 5830 IF(P100.GE.1.0 .AND. P100.LE.100.0)P100=P100/100.0 5831 ENDIF 5832C 5833 IF(P100.LE.0.0 .OR. P100.GE.1.0)THEN 5834 WRITE(ICOUT,999) 5835 CALL DPWRST('XXX','BUG ') 5836 WRITE(ICOUT,101) 5837 CALL DPWRST('XXX','BUG ') 5838 WRITE(ICOUT,302) 5839 302 FORMAT(' THE QUANTILE FOR WHICH THE CONFIDENCE INTERVAL ', 5840 1 'IS TO BE') 5841 CALL DPWRST('XXX','BUG ') 5842 WRITE(ICOUT,303) 5843 303 FORMAT(' COMPUTED MUST BE BETWEEN 0 AND 1, BUT WAS NOT.') 5844 CALL DPWRST('XXX','BUG ') 5845 WRITE(ICOUT,304)P100 5846 304 FORMAT(' PARAMETER P100 = ',G15.7) 5847 CALL DPWRST('XXX','BUG ') 5848 WRITE(ICOUT,306) 5849 306 FORMAT(' USE THE LET COMMAND TO PRE-DEFINE P100:') 5850 CALL DPWRST('XXX','BUG ') 5851 WRITE(ICOUT,307) 5852 307 FORMAT(' LET P100 = 0.5') 5853 CALL DPWRST('XXX','BUG ') 5854 IERROR='YES' 5855 GOTO9000 5856 ENDIF 5857C 5858C 5859C ****************************************************** 5860C ** STEP 3-- ** 5861C ** GENERATE THE CONFIDENCE LIMITS FOR THE VARIOUS ** 5862C ** CASES ** 5863C ****************************************************** 5864C 5865 ISTEPN='3' 5866 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUCO') 5867 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5868C 5869C ***************************************** 5870C ** STEP 3A-- ** 5871C ** CASE 1: SINGLE RESPONSE VARIABLE ** 5872C ** WITH NO REPLICATION ** 5873C ***************************************** 5874C 5875 IF(IMULT.EQ.'OFF' .AND. NREPL.EQ.0)THEN 5876 ISTEPN='3A' 5877 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUCO') 5878 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5879C 5880 PID(1)=CPUMIN 5881 IVARID(1)=IVARN1(1) 5882 IVARI2(1)=IVARN2(1) 5883C 5884 ICOL=1 5885 NUMVA2=1 5886 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 5887 1 INAME,IVARN1,IVARN2,IVARTY, 5888 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 5889 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 5890 1 MAXCP4,MAXCP5,MAXCP6, 5891 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 5892 1 Y,XTEMP1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE, 5893 1 IBUGA3,ISUBRO,IFOUND,IERROR) 5894 IF(IERROR.EQ.'YES')GOTO9000 5895C 5896C ****************************************************** 5897C ** STEP 3B-- ** 5898C ** PREPARE FOR ENTRANCE INTO DPQUC2-- ** 5899C ****************************************************** 5900C 5901 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUCO')THEN 5902 ISTEPN='3B' 5903 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5904 WRITE(ICOUT,999) 5905 CALL DPWRST('XXX','BUG ') 5906 WRITE(ICOUT,331) 5907 331 FORMAT('***** FROM DPQUCO, AS WE ARE ABOUT TO CALL DPQUC2--') 5908 CALL DPWRST('XXX','BUG ') 5909 WRITE(ICOUT,332)NLOCAL,MAXN,P100 5910 332 FORMAT('NLOCAL,MAXN,P100 = ',2I8,G15.7) 5911 CALL DPWRST('XXX','BUG ') 5912 DO335I=1,NLOCAL 5913 WRITE(ICOUT,336)I,Y(I) 5914 336 FORMAT('I,Y(I) = ',I8,G15.7) 5915 CALL DPWRST('XXX','BUG ') 5916 335 CONTINUE 5917 WRITE(ICOUT,338)ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP 5918 338 FORMAT('ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP = ',5(A4,2X)) 5919 CALL DPWRST('XXX','BUG ') 5920 WRITE(ICOUT,339)ICASAN,ISUBRO,IBUGA3,IERROR 5921 339 FORMAT('ICASAN,ISUBRO,IBUGA3,IERROR = ',4A4) 5922 CALL DPWRST('XXX','BUG ') 5923 ENDIF 5924C 5925 IERROR='NO' 5926 CALL DPQUC2(Y,NLOCAL,P100, 5927 1 XTEMP1,MAXNXT, 5928 1 PID,IVARID,IVARI2,NREPL, 5929 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 5930 1 CTL999,CTU999, 5931 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 5932 1 ICASAN,ISUBRO,IBUGA3,IERROR) 5933C 5934 IFLAGU='ON' 5935 IFRST=.FALSE. 5936 ILAST=.FALSE. 5937 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 5938 1 CTL999,CTU999, 5939 1 IFLAGU,IFRST,ILAST,ICASAN, 5940 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 5941C 5942C ******************************************* 5943C ** STEP 4A-- ** 5944C ** CASE 2: MULTIPLE RESPONSE VARIABLES ** 5945C ******************************************* 5946C 5947 ELSEIF(IMULT.EQ.'ON')THEN 5948 ISTEPN='4A' 5949 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUCO') 5950 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5951C 5952C LOOP THROUGH EACH OF THE RESPONSE VARIABLES 5953C 5954 NCURVE=0 5955 DO410IRESP=1,NRESP 5956 NCURVE=NCURVE+1 5957C 5958 IINDX=ICOLR(IRESP) 5959 PID(1)=CPUMIN 5960 IVARID(1)=IVARN1(IRESP) 5961 IVARI2(1)=IVARN2(IRESP) 5962C 5963 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUCO')THEN 5964 WRITE(ICOUT,999) 5965 CALL DPWRST('XXX','BUG ') 5966 WRITE(ICOUT,411)IRESP,NCURVE 5967 411 FORMAT('IRESP,NCURVE = ',2I5) 5968 CALL DPWRST('XXX','BUG ') 5969 ENDIF 5970C 5971 ICOL=IRESP 5972 NUMVA2=1 5973 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 5974 1 INAME,IVARN1,IVARN2,IVARTY, 5975 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 5976 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 5977 1 MAXCP4,MAXCP5,MAXCP6, 5978 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 5979 1 Y,XTEMP1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE, 5980 1 IBUGA3,ISUBRO,IFOUND,IERROR) 5981 IF(IERROR.EQ.'YES')GOTO9000 5982C 5983C ***************************************************** 5984C ** STEP 4B-- ** 5985C ***************************************************** 5986C 5987 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'QUCO')THEN 5988 ISTEPN='4B' 5989 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5990 WRITE(ICOUT,999) 5991 CALL DPWRST('XXX','BUG ') 5992 WRITE(ICOUT,422) 5993 422 FORMAT('***** FROM THE MIDDLE OF DPQUCO--') 5994 CALL DPWRST('XXX','BUG ') 5995 WRITE(ICOUT,423)ICASAN,NUMVAR,NLOCAL,IRESP 5996 423 FORMAT('ICASAN,NUMVAR,NLOCAL,IRESP = ',A4,3I8) 5997 CALL DPWRST('XXX','BUG ') 5998 IF(NLOCAL.GE.1)THEN 5999 DO425I=1,NLOCAL 6000 WRITE(ICOUT,426)I,Y(I) 6001 426 FORMAT('I,Y(I) = ',I8,F12.5) 6002 CALL DPWRST('XXX','BUG ') 6003 425 CONTINUE 6004 ENDIF 6005 ENDIF 6006C 6007 CALL DPQUC2(Y,NLOCAL,P100, 6008 1 XTEMP1,MAXNXT, 6009 1 PID,IVARID,IVARI2,NREPL, 6010 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 6011 1 CTL999,CTU999, 6012 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 6013 1 ICASAN,ISUBRO,IBUGA3,IERROR) 6014C 6015 IFLAGU='FILE' 6016 IFRST=.FALSE. 6017 ILAST=.FALSE. 6018 IF(IRESP.EQ.1)IFRST=.TRUE. 6019 IF(IRESP.EQ.NRESP)ILAST=.TRUE. 6020 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 6021 1 CTL999,CTU999, 6022 1 IFLAGU,IFRST,ILAST,ICASAN, 6023 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 6024C 6025 410 CONTINUE 6026C 6027C **************************************************** 6028C ** STEP 5A-- ** 6029C ** CASE 3: ONE OR MORE REPLICATION VARIABLES. ** 6030C ** FOR THIS CASE, ALL VARIABLES MUST ** 6031C ** HAVE THE SAME LENGTH. ** 6032C **************************************************** 6033C 6034 ELSEIF(IREPL.EQ.'ON')THEN 6035 ISTEPN='5A' 6036 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUCO') 6037 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6038C 6039 J=0 6040 IMAX=NRIGHT(1) 6041 IF(NQ.LT.NRIGHT(1))IMAX=NQ 6042 DO510I=1,IMAX 6043 IF(ISUB(I).EQ.0)GOTO510 6044 J=J+1 6045C 6046C RESPONSE VARIABLE IN Y 6047C 6048 ICOLC=1 6049 IJ=MAXN*(ICOLR(ICOLC)-1)+I 6050 IF(ICOLR(ICOLC).LE.MAXCOL)Y(J)=V(IJ) 6051 IF(ICOLR(ICOLC).EQ.MAXCP1)Y(J)=PRED(I) 6052 IF(ICOLR(ICOLC).EQ.MAXCP2)Y(J)=RES(I) 6053 IF(ICOLR(ICOLC).EQ.MAXCP3)Y(J)=YPLOT(I) 6054 IF(ICOLR(ICOLC).EQ.MAXCP4)Y(J)=XPLOT(I) 6055 IF(ICOLR(ICOLC).EQ.MAXCP5)Y(J)=X2PLOT(I) 6056 IF(ICOLR(ICOLC).EQ.MAXCP6)Y(J)=TAGPLO(I) 6057C 6058 IF(NREPL.GE.1)THEN 6059 DO520IR=1,MIN(NREPL,6) 6060 ICOLC=ICOLC+1 6061 ICOLT=ICOLR(ICOLC) 6062 IJ=MAXN*(ICOLT-1)+I 6063 IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ) 6064 IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I) 6065 IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I) 6066 IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I) 6067 IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I) 6068 IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I) 6069 IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I) 6070 520 CONTINUE 6071 ENDIF 6072C 6073 510 CONTINUE 6074 NLOCAL=J 6075C 6076 ISTEPN='5B' 6077 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUCO') 6078 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6079C 6080 PID(1)=CPUMIN 6081 IVARID(1)=IVARN1(1) 6082 IVARI2(1)=IVARN2(1) 6083 IADD=1 6084 DO540II=1,NREPL 6085 IVARID(II+IADD)=IVARN1(II+IADD) 6086 IVARI2(II+IADD)=IVARN2(II+IADD) 6087 540 CONTINUE 6088C 6089C ***************************************************** 6090C ** STEP 5C-- ** 6091C ** ** 6092C ** FOR THIS CASE, WE NEED TO LOOP THROUGH THE ** 6093C ** VARIOUS REPLICATIONS. ** 6094C ***************************************************** 6095C 6096C 6097 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'QUCO')THEN 6098 ISTEPN='5C' 6099 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6100 WRITE(ICOUT,999) 6101 CALL DPWRST('XXX','BUG ') 6102 WRITE(ICOUT,541) 6103 541 FORMAT('***** FROM THE MIDDLE OF DPQUCO--') 6104 CALL DPWRST('XXX','BUG ') 6105 WRITE(ICOUT,542)ICASAN,NUMVAR,NLOCAL,NREPL 6106 542 FORMAT('ICASAN,NUMVAR,NLOCAL,NREPL = ',A4,2X,3I8) 6107 CALL DPWRST('XXX','BUG ') 6108 IF(NLOCAL.GE.1)THEN 6109 DO545I=1,NLOCAL 6110 WRITE(ICOUT,546)I,Y(I),XDESGN(I,1),XDESGN(I,2) 6111 546 FORMAT('I,Y(I),XDESGN(I,1),XDESGN(I,2) = ', 6112 1 I8,3F12.5) 6113 CALL DPWRST('XXX','BUG ') 6114 545 CONTINUE 6115 ENDIF 6116 ENDIF 6117C 6118C ***************************************************** 6119C ** STEP 5C-- ** 6120C ** FIND THE DISTINCT VALUES IN EACH OF THE ** 6121C ** REPLICATION VARIABLES. ** 6122C ***************************************************** 6123C 6124 CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3), 6125 1 XDESGN(1,4),XDESGN(1,5),XDESGN(1,6), 6126 1 NREPL,NLOCAL,MAXOBV, 6127 1 XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6, 6128 1 XTEMP1,XTEMP2, 6129 1 NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6, 6130 1 IBUGA3,ISUBRO,IERROR) 6131C 6132C ***************************************************** 6133C ** STEP 5D-- ** 6134C ** NOW LOOP THROUGH THE VARIOUS REPLICATIONS ** 6135C ***************************************************** 6136C 6137 NPLOTP=0 6138 NCURVE=0 6139 IF(NREPL.EQ.1)THEN 6140 J=0 6141 DO1110ISET1=1,NUMSE1 6142 K=0 6143 PID(IADD+1)=XIDTEM(ISET1) 6144 DO1130I=1,NLOCAL 6145 IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN 6146 K=K+1 6147 TEMP1(K)=Y(I) 6148 ENDIF 6149 1130 CONTINUE 6150 NTEMP=K 6151 NCURVE=NCURVE+1 6152 IF(NTEMP.GT.0)THEN 6153 CALL DPQUC2(TEMP1,NTEMP,P100, 6154 1 XTEMP1,MAXNXT, 6155 1 PID,IVARID,IVARI2,NREPL, 6156 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 6157 1 CTL999,CTU999, 6158 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 6159 1 ICASAN,ISUBRO,IBUGA3,IERROR) 6160 ENDIF 6161C 6162 IFLAGU='FILE' 6163 IFRST=.FALSE. 6164 ILAST=.FALSE. 6165 IF(NCURVE.EQ.1)IFRST=.TRUE. 6166 IF(NCURVE.EQ.NUMSE1)ILAST=.TRUE. 6167 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 6168 1 CTL999,CTU999, 6169 1 IFLAGU,IFRST,ILAST,ICASAN, 6170 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 6171 1110 CONTINUE 6172 ELSEIF(NREPL.EQ.2)THEN 6173 J=0 6174 NTOT=NUMSE1*NUMSE2 6175 DO1210ISET1=1,NUMSE1 6176 DO1220ISET2=1,NUMSE2 6177 K=0 6178 PID(1+IADD)=XIDTEM(ISET1) 6179 PID(2+IADD)=XIDTE2(ISET2) 6180 DO1290I=1,NLOCAL 6181 IF( 6182 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 6183 1 XIDTE2(ISET2).EQ.XDESGN(I,2) 6184 1 )THEN 6185 K=K+1 6186 TEMP1(K)=Y(I) 6187 ENDIF 6188 1290 CONTINUE 6189 NTEMP=K 6190 NCURVE=NCURVE+1 6191 NPLOT1=NPLOTP 6192 IF(NTEMP.GT.0)THEN 6193 CALL DPQUC2(TEMP1,NTEMP,P100, 6194 1 XTEMP1,MAXNXT, 6195 1 PID,IVARID,IVARI2,NREPL, 6196 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 6197 1 CTL999,CTU999, 6198 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 6199 1 ICASAN,ISUBRO,IBUGA3,IERROR) 6200 ENDIF 6201 NPLOT2=NPLOTP 6202 IFLAGU='FILE' 6203 IFRST=.FALSE. 6204 ILAST=.FALSE. 6205 IF(NCURVE.EQ.1)IFRST=.TRUE. 6206 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 6207 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 6208 1 CTL999,CTU999, 6209 1 IFLAGU,IFRST,ILAST,ICASAN, 6210 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 6211 1220 CONTINUE 6212 1210 CONTINUE 6213 ELSEIF(NREPL.EQ.3)THEN 6214 J=0 6215 NTOT=NUMSE1*NUMSE2*NUMSE3 6216 DO1310ISET1=1,NUMSE1 6217 DO1320ISET2=1,NUMSE2 6218 DO1330ISET3=1,NUMSE3 6219 K=0 6220 PID(1+IADD)=XIDTEM(ISET1) 6221 PID(2+IADD)=XIDTE2(ISET2) 6222 PID(3+IADD)=XIDTE3(ISET3) 6223 DO1390I=1,NLOCAL 6224 IF( 6225 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 6226 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 6227 1 XIDTE3(ISET3).EQ.XDESGN(I,3) 6228 1 )THEN 6229 K=K+1 6230 TEMP1(K)=Y(I) 6231 ENDIF 6232 1390 CONTINUE 6233 NTEMP=K 6234 NCURVE=NCURVE+1 6235 IF(NTEMP.GT.0)THEN 6236 CALL DPQUC2(TEMP1,NTEMP,P100, 6237 1 XTEMP1,MAXNXT, 6238 1 PID,IVARID,IVARI2,NREPL, 6239 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 6240 1 CTL999,CTU999, 6241 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 6242 1 ICASAN,ISUBRO,IBUGA3,IERROR) 6243 ENDIF 6244 IFLAGU='FILE' 6245 IFRST=.FALSE. 6246 ILAST=.FALSE. 6247 IF(NCURVE.EQ.1)IFRST=.TRUE. 6248 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 6249 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 6250 1 CTL999,CTU999, 6251 1 IFLAGU,IFRST,ILAST,ICASAN, 6252 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 6253 1330 CONTINUE 6254 1320 CONTINUE 6255 1310 CONTINUE 6256 ELSEIF(NREPL.EQ.4)THEN 6257 J=0 6258 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4 6259 DO1410ISET1=1,NUMSE1 6260 DO1420ISET2=1,NUMSE2 6261 DO1430ISET3=1,NUMSE3 6262 DO1440ISET4=1,NUMSE4 6263 K=0 6264 PID(1+IADD)=XIDTEM(ISET1) 6265 PID(2+IADD)=XIDTE2(ISET2) 6266 PID(3+IADD)=XIDTE3(ISET3) 6267 PID(4+IADD)=XIDTE4(ISET4) 6268 DO1490I=1,NLOCAL 6269 IF( 6270 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 6271 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 6272 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 6273 1 XIDTE4(ISET4).EQ.XDESGN(I,4) 6274 1 )THEN 6275 K=K+1 6276 TEMP1(K)=Y(I) 6277 ENDIF 6278 1490 CONTINUE 6279 NTEMP=K 6280 NCURVE=NCURVE+1 6281 IF(NTEMP.GT.0)THEN 6282 CALL DPQUC2(TEMP1,NTEMP,P100, 6283 1 XTEMP1,MAXNXT, 6284 1 PID,IVARID,IVARI2,NREPL, 6285 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 6286 1 CTL999,CTU999, 6287 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 6288 1 ICASAN,ISUBRO,IBUGA3,IERROR) 6289 ENDIF 6290 IFLAGU='FILE' 6291 IFRST=.FALSE. 6292 ILAST=.FALSE. 6293 IF(NCURVE.EQ.1)IFRST=.TRUE. 6294 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 6295 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 6296 1 CTL999,CTU999, 6297 1 IFLAGU,IFRST,ILAST,ICASAN, 6298 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 6299 1440 CONTINUE 6300 1430 CONTINUE 6301 1420 CONTINUE 6302 1410 CONTINUE 6303 ELSEIF(NREPL.EQ.5)THEN 6304 J=0 6305 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5 6306 DO1510ISET1=1,NUMSE1 6307 DO1520ISET2=1,NUMSE2 6308 DO1530ISET3=1,NUMSE3 6309 DO1540ISET4=1,NUMSE4 6310 DO1550ISET5=1,NUMSE5 6311 K=0 6312 PID(1+IADD)=XIDTEM(ISET1) 6313 PID(2+IADD)=XIDTE2(ISET2) 6314 PID(3+IADD)=XIDTE3(ISET3) 6315 PID(4+IADD)=XIDTE4(ISET4) 6316 PID(5+IADD)=XIDTE5(ISET4) 6317 DO1590I=1,NLOCAL 6318 IF( 6319 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 6320 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 6321 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 6322 1 XIDTE4(ISET4).EQ.XDESGN(I,4) .AND. 6323 1 XIDTE5(ISET5).EQ.XDESGN(I,5) 6324 1 )THEN 6325 K=K+1 6326 TEMP1(K)=Y(I) 6327 ENDIF 6328 1590 CONTINUE 6329 NTEMP=K 6330 NCURVE=NCURVE+1 6331 IF(NTEMP.GT.0)THEN 6332 CALL DPQUC2(TEMP1,NTEMP,P100, 6333 1 XTEMP1,MAXNXT, 6334 1 PID,IVARID,IVARI2,NREPL, 6335 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 6336 1 CTL999,CTU999, 6337 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 6338 1 ICASAN,ISUBRO,IBUGA3,IERROR) 6339 ENDIF 6340 IFLAGU='FILE' 6341 IFRST=.FALSE. 6342 ILAST=.FALSE. 6343 IF(NCURVE.EQ.1)IFRST=.TRUE. 6344 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 6345 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 6346 1 CTL999,CTU999, 6347 1 IFLAGU,IFRST,ILAST,ICASAN, 6348 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 6349 1550 CONTINUE 6350 1540 CONTINUE 6351 1530 CONTINUE 6352 1520 CONTINUE 6353 1510 CONTINUE 6354 ELSEIF(NREPL.EQ.6)THEN 6355 J=0 6356 NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6 6357 DO1610ISET1=1,NUMSE1 6358 DO1620ISET2=1,NUMSE2 6359 DO1630ISET3=1,NUMSE3 6360 DO1640ISET4=1,NUMSE4 6361 DO1650ISET5=1,NUMSE5 6362 DO1660ISET6=1,NUMSE6 6363 K=0 6364 PID(1+IADD)=XIDTEM(ISET1) 6365 PID(2+IADD)=XIDTE2(ISET2) 6366 PID(3+IADD)=XIDTE3(ISET3) 6367 PID(4+IADD)=XIDTE4(ISET4) 6368 PID(5+IADD)=XIDTE5(ISET4) 6369 PID(6+IADD)=XIDTE6(ISET4) 6370 DO1690I=1,NLOCAL 6371 IF( 6372 1 XIDTEM(ISET1).EQ.XDESGN(I,1) .AND. 6373 1 XIDTE2(ISET2).EQ.XDESGN(I,2) .AND. 6374 1 XIDTE3(ISET3).EQ.XDESGN(I,3) .AND. 6375 1 XIDTE4(ISET4).EQ.XDESGN(I,4) .AND. 6376 1 XIDTE5(ISET5).EQ.XDESGN(I,5) .AND. 6377 1 XIDTE6(ISET6).EQ.XDESGN(I,6) 6378 1 )THEN 6379 K=K+1 6380 TEMP1(K)=Y(I) 6381 ENDIF 6382 1690 CONTINUE 6383 NTEMP=K 6384 NCURVE=NCURVE+1 6385 IF(NTEMP.GT.0)THEN 6386 CALL DPQUC2(TEMP1,NTEMP,P100, 6387 1 XTEMP1,MAXNXT, 6388 1 PID,IVARID,IVARI2,NREPL, 6389 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 6390 1 CTL999,CTU999, 6391 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 6392 1 ICASAN,ISUBRO,IBUGA3,IERROR) 6393 ENDIF 6394 IFLAGU='FILE' 6395 IFRST=.FALSE. 6396 ILAST=.FALSE. 6397 IF(NCURVE.EQ.1)IFRST=.TRUE. 6398 IF(NCURVE.EQ.NTOT)ILAST=.TRUE. 6399 CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 6400 1 CTL999,CTU999, 6401 1 IFLAGU,IFRST,ILAST,ICASAN, 6402 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 6403 1660 CONTINUE 6404 1650 CONTINUE 6405 1640 CONTINUE 6406 1630 CONTINUE 6407 1620 CONTINUE 6408 1610 CONTINUE 6409 ENDIF 6410C 6411 ENDIF 6412C 6413C ***************** 6414C ** STEP 90-- ** 6415C ** EXIT ** 6416C ***************** 6417C 6418 9000 CONTINUE 6419 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUCO')THEN 6420 WRITE(ICOUT,999) 6421 CALL DPWRST('XXX','BUG ') 6422 WRITE(ICOUT,9011) 6423 9011 FORMAT('***** AT THE END OF DPQUCO--') 6424 CALL DPWRST('XXX','BUG ') 6425 WRITE(ICOUT,9014)ICASEQ,NRIGHT(1),NS 6426 9014 FORMAT('ICASEQ,NRIGHT(1),NS = ',A4,2X,2I8) 6427 CALL DPWRST('XXX','BUG ') 6428 WRITE(ICOUT,9016)IFOUND,IERROR 6429 9016 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 6430 CALL DPWRST('XXX','BUG ') 6431 ENDIF 6432C 6433 RETURN 6434 END 6435 SUBROUTINE DPQUC2(Y,N,P100, 6436 1 XTEMP1,MAXNXT, 6437 1 PID,IVARID,IVARI2,NREPL, 6438 1 CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 6439 1 CTL999,CTU999, 6440 1 ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP, 6441 1 ICASAN,ISUBRO,IBUGA3,IERROR) 6442C 6443C PURPOSE--THIS ROUTINE GENERATES QUANTILE CONFIDENCE LIMITS 6444C FOR THE DATA IN THE INPUT VECTOR Y. 6445C THE MEDIAN IS A SPECIAL CASE. SPECIFICALLY, 6446C X(0.5) +/- NORPPF(1-ALPHA/2)*QUASE 6447C WHERE QUASE IS THE MARITZ-JARRETT ESTIMATE OF 6448C THE QUANTILE STANDARD ERROR. 6449C METHOD FROM PAGE 87 OF THE RAND WILCOX BOOK 6450C "INTRODUCTION TO ROBUST ESTIMATION AND HYPOTHESIS 6451C TESTING", ACADEMIC PRESS, 1997. 6452C ALSO VIA THE HETTMANSPERGER-SHEATHER INTERPOLATION 6453C METHOD (ALSO PAGE 87 OF WILCOX). 6454C NOTE--ASSUMPTION--MODEL IS RESPONSE = CONSTANT + ERROR. 6455C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR 6456C OF OBSERVATIONS 6457C N = THE INTEGER NUMBER OF 6458C OBSERVATIONS IN THE VECTOR Y. 6459C WRITTEN BY--ALAN HECKERT 6460C STATISTICAL ENGINEERING DIVISION 6461C INFORMATION TECHNOLOGY LABORATORY 6462C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 6463C GAITHERSBURG, MD 20899-8980 6464C PHONE--301-975-2899 6465C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 6466C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 6467C LANGUAGE--ANSI FORTRAN (1977) 6468C VERSION NUMBER--2003/2 6469C ORIGINAL VERSION--FEBRUARY 2003. 6470C UPDATED --OCTOBER 2003. ADD SUPPORT FOR HTML, LATEX 6471C OUTPUT 6472C UPDATED --MARCH 2010. USE DPDTA2 AND DPDTA4 TO 6473C GENERATE OUTPUT (ADDS RTF 6474C SUPPORT) 6475C UPDATED --MARCH 2010. SOME MODIFICATIONS TO THE 6476C OUTPUT (AESTHETIC, NOT 6477C SUBSTANTIVE) 6478C UPDATED --AUGUST 2019. ADD CTL999, CTU999 6479C 6480C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 6481C 6482 CHARACTER*4 ICASAN 6483 CHARACTER*4 IBUGA3 6484 CHARACTER*4 ISUBRO 6485 CHARACTER*4 IERROR 6486C 6487 CHARACTER*4 IWRITE 6488 CHARACTER*4 ICASA2 6489 CHARACTER*4 IQUASE 6490 CHARACTER*4 IQUAME 6491 CHARACTER*4 ICAPSW 6492 CHARACTER*4 ICAPTY 6493 CHARACTER*4 IFORSW 6494 CHARACTER*40 IRTFFF 6495 CHARACTER*40 IRTFFP 6496C 6497 CHARACTER*4 IVARID(*) 6498 CHARACTER*4 IVARI2(*) 6499C 6500 CHARACTER*4 ISUBN1 6501 CHARACTER*4 ISUBN2 6502 CHARACTER*4 ISTEPN 6503C 6504C--------------------------------------------------------------------- 6505C 6506 DIMENSION Y(*) 6507 DIMENSION XTEMP1(*) 6508 DIMENSION PID(*) 6509C 6510 PARAMETER (NUMALP=8) 6511C 6512 DIMENSION CONF(NUMALP) 6513 DIMENSION T(NUMALP) 6514 DIMENSION TSDM(NUMALP) 6515 DIMENSION ALOWER(NUMALP) 6516 DIMENSION AUPPER(NUMALP) 6517 DIMENSION ALOWE2(NUMALP) 6518 DIMENSION AUPPE2(NUMALP) 6519C 6520 PARAMETER(NUMCLI=5) 6521 PARAMETER(MAXLIN=2) 6522 PARAMETER (MAXROW=20) 6523 CHARACTER*60 ITITLE 6524 CHARACTER*60 ITITLZ 6525 CHARACTER*60 ITEXT(MAXROW) 6526 REAL AVALUE(MAXROW) 6527 INTEGER NCTEXT(MAXROW) 6528 INTEGER IDIGIT(MAXROW) 6529 INTEGER NTOT(MAXROW) 6530 LOGICAL IFRST 6531 LOGICAL ILAST 6532C 6533 DOUBLE PRECISION DCDF 6534 DOUBLE PRECISION DPPF 6535C 6536C--------------------------------------------------------------------- 6537C 6538 INCLUDE 'DPCOP2.INC' 6539C 6540C-----START POINT----------------------------------------------------- 6541C 6542 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'QUC2')THEN 6543 WRITE(ICOUT,999) 6544 999 FORMAT(1X) 6545 CALL DPWRST('XXX','WRIT') 6546 WRITE(ICOUT,51) 6547 51 FORMAT('**** AT THE BEGINNING OF DPQUC2--') 6548 CALL DPWRST('XXX','WRIT') 6549 WRITE(ICOUT,52)N,MAXNXT,NREPL,P100 6550 52 FORMAT('N,MAXNXT,NREPL,P100 = ',3I8,G15.7) 6551 CALL DPWRST('XXX','WRIT') 6552 WRITE(ICOUT,53)IVARID(1),IVARI2(1),PID(1) 6553 53 FORMAT('IVARID(1),IVARI2(1),PID(1) = ',A4,A4,G15.7) 6554 CALL DPWRST('XXX','WRIT') 6555 WRITE(ICOUT,54)ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP 6556 54 FORMAT('ICAPSW,ICAPTY,IFORSW,IRTFFF,IRTFFP = ',5(A4,2X)) 6557 CALL DPWRST('XXX','WRIT') 6558 DO56I=1,N 6559 WRITE(ICOUT,57)I,Y(I) 6560 57 FORMAT('I,Y(I) = ',I8,G15.7) 6561 CALL DPWRST('XXX','WRIT') 6562 56 CONTINUE 6563 WRITE(ICOUT,58)ICASAN,ISUBRO,IBUGA3,IERROR 6564 58 FORMAT('ICASAN,ISUBRO,IBUGA3,IERROR = ',4(A4,2X)) 6565 CALL DPWRST('XXX','WRIT') 6566 ENDIF 6567C 6568 ISUBN1='DPQU' 6569 ISUBN2='C2 ' 6570 IWRITE='OFF' 6571CCCCC IERROR='NO' 6572 ICASA2='QUCO' 6573 IQUAME='ORDE' 6574 IQUASE='MJ' 6575C 6576 NUMDIG=7 6577 IF(IFORSW.EQ.'1')NUMDIG=1 6578 IF(IFORSW.EQ.'2')NUMDIG=2 6579 IF(IFORSW.EQ.'3')NUMDIG=3 6580 IF(IFORSW.EQ.'4')NUMDIG=4 6581 IF(IFORSW.EQ.'5')NUMDIG=5 6582 IF(IFORSW.EQ.'6')NUMDIG=6 6583 IF(IFORSW.EQ.'7')NUMDIG=7 6584 IF(IFORSW.EQ.'8')NUMDIG=8 6585 IF(IFORSW.EQ.'9')NUMDIG=9 6586 IF(IFORSW.EQ.'0')NUMDIG=0 6587 IF(IFORSW.EQ.'E')NUMDIG=-2 6588 IF(IFORSW.EQ.'-2')NUMDIG=-2 6589 IF(IFORSW.EQ.'-3')NUMDIG=-3 6590 IF(IFORSW.EQ.'-4')NUMDIG=-4 6591 IF(IFORSW.EQ.'-5')NUMDIG=-5 6592 IF(IFORSW.EQ.'-6')NUMDIG=-6 6593 IF(IFORSW.EQ.'-7')NUMDIG=-7 6594 IF(IFORSW.EQ.'-8')NUMDIG=-8 6595 IF(IFORSW.EQ.'-9')NUMDIG=-9 6596C 6597C ******************************************** 6598C ** STEP 1-- ** 6599C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 6600C ******************************************** 6601C 6602 ISTEPN='1' 6603 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'QUC2') 6604 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6605C 6606 IF(N.LT.3)THEN 6607 WRITE(ICOUT,999) 6608 CALL DPWRST('XXX','WRIT') 6609 WRITE(ICOUT,111) 6610 111 FORMAT('***** ERROR IN QUANTILE CONFIDENCE LIMITS--') 6611 CALL DPWRST('XXX','WRIT') 6612 WRITE(ICOUT,112) 6613 112 FORMAT(' THE NUMBER OF OBSERVATIONS IN THE RESPONSE ', 6614 1 'VARIABLE IS LESS THAN 3') 6615 CALL DPWRST('XXX','WRIT') 6616 WRITE(ICOUT,113)N 6617 113 FORMAT('SAMPLE SIZE = ',I8) 6618 CALL DPWRST('XXX','WRIT') 6619 IERROR='YES' 6620 GOTO9000 6621 ENDIF 6622C 6623 HOLD=Y(1) 6624 DO135I=2,N 6625 IF(Y(I).NE.HOLD)GOTO139 6626 135 CONTINUE 6627 WRITE(ICOUT,999) 6628 CALL DPWRST('XXX','WRIT') 6629 WRITE(ICOUT,111) 6630 CALL DPWRST('XXX','WRIT') 6631 WRITE(ICOUT,131)HOLD 6632 131 FORMAT(' THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7) 6633 CALL DPWRST('XXX','WRIT') 6634 GOTO9000 6635 139 CONTINUE 6636C 6637C *************************************************** 6638C ** STEP 3-- ** 6639C ** COMPUTE THE QUANTILE ESTIMATE ** 6640C ** COMPUTE THE QUANTILE STANDARD ERROR ** 6641C *************************************************** 6642C 6643C 6644 ISTEPN='3' 6645 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'QUC2') 6646 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6647C 6648 IWRITE='OFF' 6649C 6650 CALL MINIM(Y,N,IWRITE,XMIN,IBUGA3,IERROR) 6651 CALL MAXIM(Y,N,IWRITE,XMAX,IBUGA3,IERROR) 6652 IF(ICASAN.EQ.'MECI')THEN 6653 CALL MEDIAN(Y,N,IWRITE,XTEMP1,MAXNXT,XMED,IBUGA3,IERROR) 6654 XQUANT=XMED 6655 ELSE 6656 CALL MEDIAN(Y,N,IWRITE,XTEMP1,MAXNXT,XMED,IBUGA3,IERROR) 6657 CALL QUANT(P100,Y,N,IWRITE,XTEMP1,MAXNXT,IQUAME,XQUANT, 6658 1 IBUGA3,IERROR) 6659 ENDIF 6660 CALL QUANSE(P100,Y,N,IWRITE,XTEMP1,MAXNXT,IQUASE,XQUASE, 6661 1IBUGA3,IERROR) 6662C 6663C *************************************** 6664C ** STEP 4-- ** 6665C ** COMPUTE CONFIDENCE LIMITS ** 6666C ** FOR VARIOUS PROBABILITY VALUES. ** 6667C *************************************** 6668C 6669 ISTEPN='4' 6670 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'QUC2') 6671 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6672C 6673 CONF(1)=50.0 6674 CONF(2)=75.0 6675 CONF(3)=90.0 6676 CONF(4)=95.0 6677 CONF(5)=99.0 6678 CONF(6)=99.9 6679 CONF(7)=99.99 6680 CONF(8)=99.999 6681C 6682 DO1400I=1,8 6683 PCONF=CONF(I)/100.0 6684 CDF=0.5+PCONF/2.0 6685 CALL NORPPF(CDF,T(I)) 6686 TSDM(I)=T(I)*XQUASE 6687 ALOWER(I)=XQUANT-TSDM(I) 6688 AUPPER(I)=XQUANT+TSDM(I) 6689 1400 CONTINUE 6690 CUTL90=ALOWER(3) 6691 CUTU90=AUPPER(3) 6692 CUTL95=ALOWER(4) 6693 CUTU95=AUPPER(4) 6694 CUTL99=ALOWER(5) 6695 CUTU99=AUPPER(5) 6696 CTL999=ALOWER(6) 6697 CTU999=AUPPER(6) 6698C 6699C *************************************** 6700C ** STEP 5-- ** 6701C ** COMPUTE CONFIDENCE LIMITS ** 6702C ** FOR HETTMANSPERGER-SHEATHER ** 6703C ** INTERPOLATION METHOD. ** 6704C *************************************** 6705C 6706 IF(ICASAN.EQ.'MECI')THEN 6707 P=0.5 6708 AN=REAL(N) 6709 CALL SORT(Y,N,Y) 6710 DO2010I=1,8 6711 ALPHA=(100.0-CONF(I))/100. 6712 CALL BINPPF(DBLE(ALPHA/2.0),DBLE(P),N,DPPF) 6713 AK=REAL(DPPF) 6714 CALL BINCDF(DBLE(AN-AK),DBLE(P),N,DCDF) 6715 CDF1=REAL(DCDF) 6716 CALL BINCDF(DBLE(AK-1.0),DBLE(P),N,DCDF) 6717 CDF2=REAL(DCDF) 6718 GK=CDF1-CDF2 6719 IF(GK.GE.1.0-ALPHA)THEN 6720 CALL BINCDF(DBLE(AN-AK-1.0),DBLE(P),N,DCDF) 6721 CDF1=REAL(DCDF) 6722 CALL BINCDF(DBLE(AK-1.0),DBLE(P),N,DCDF) 6723 CDF2=REAL(DCDF) 6724 GKP1=CDF1-CDF2 6725 AKP=AK+1.0 6726 ELSE 6727 AK=AK-1.0 6728 CALL BINCDF(DBLE(AN-AK),DBLE(P),N,DCDF) 6729 CDF1=REAL(DCDF) 6730 CALL BINCDF(DBLE(AK-1.0),DBLE(P),N,DCDF) 6731 CDF2=REAL(DCDF) 6732 GKP1=CDF1-CDF2 6733 AKP=AK+1.0 6734 ENDIF 6735 ANMK=AN-AK 6736 ANMKP=ANMK+1.0 6737 AIVAR=(GK-1.0+ALPHA)/(GK-GKP1) 6738 ALAMB=((AN-AK)*AIVAR)/(AK+(AN-2.0*AK)*AIVAR) 6739 ALOWE2(I)=ALAMB*Y(INT(AKP)) + (1.0-ALAMB)*Y(INT(AK)) 6740 AUPPE2(I)=ALAMB*Y(INT(ANMK)) + (1.0-ALAMB)*Y(INT(ANMKP)) 6741 2010 CONTINUE 6742 ENDIF 6743C 6744C ADD A FUDGE FACTOR SO THAT CONFIDENCE LEVEL WILL 6745C BE PRINTED CORRECTLY TO 3 DECIMAL PLACES. 6746C 6747 CONF(1)=50.0001 6748 CONF(2)=75.0001 6749 CONF(3)=90.0001 6750 CONF(4)=95.0001 6751 CONF(5)=99.0001 6752 CONF(6)=99.9001 6753 CONF(7)=99.9901 6754 CONF(8)=99.9991 6755C 6756C **************************** 6757C ** STEP 7-- ** 6758C ** WRITE EVERYTHING OUT ** 6759C **************************** 6760C 6761 ISTEPN='7' 6762 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'QUC2') 6763 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6764C 6765 IF(IPRINT.EQ.'OFF')GOTO9000 6766C 6767 IF(ICASAN.EQ.'MECI')THEN 6768 ITITLE='Confidence Limits for the Median' 6769 NCTITL=32 6770 ELSE 6771 ITITLE='Confidence Limits for Quantile (Q0 = )' 6772 WRITE(ITITLE(39:44),'(F6.3)')P100 6773 NCTITL=45 6774 ENDIF 6775 ITITLZ='(Based on Maritz-Jarrett Standard Error for Quantiles)' 6776 NCTITZ=54 6777C 6778 ICNT=1 6779 ITEXT(ICNT)=' ' 6780 NCTEXT(ICNT)=0 6781 AVALUE(ICNT)=0.0 6782 IDIGIT(ICNT)=-1 6783 ICNT=ICNT+1 6784 ITEXT(ICNT)='Response Variable: ' 6785 WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4) 6786 WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4) 6787 NCTEXT(ICNT)=27 6788 AVALUE(ICNT)=0.0 6789 IDIGIT(ICNT)=-1 6790C 6791 IF(NREPL.GT.0)THEN 6792 NRESP=1 6793 DO4101I=1,NREPL 6794 ICNT=ICNT+1 6795 ITEMP=I+NRESP 6796 ITEXT(ICNT)='Factor Variable : ' 6797 WRITE(ITEXT(ICNT)(17:17),'(I1)')I 6798 WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4) 6799 WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4) 6800 NCTEXT(ICNT)=27 6801 AVALUE(ICNT)=PID(ITEMP) 6802 IDIGIT(ICNT)=NUMDIG 6803 4101 CONTINUE 6804 ENDIF 6805C 6806 ICNT=ICNT+1 6807 ITEXT(ICNT)=' ' 6808 NCTEXT(ICNT)=1 6809 AVALUE(ICNT)=0.0 6810 IDIGIT(ICNT)=-1 6811C 6812 ICNT=ICNT+1 6813 ITEXT(ICNT)='Summary Statistics:' 6814 NCTEXT(ICNT)=19 6815 AVALUE(ICNT)=0.0 6816 IDIGIT(ICNT)=-1 6817 ICNT=ICNT+1 6818 ITEXT(ICNT)='Number of Observations:' 6819 NCTEXT(ICNT)=23 6820 AVALUE(ICNT)=REAL(N) 6821 IDIGIT(ICNT)=0 6822 ICNT=ICNT+1 6823 ITEXT(ICNT)='Sample Minimum:' 6824 NCTEXT(ICNT)=15 6825 AVALUE(ICNT)=XMIN 6826 IDIGIT(ICNT)=NUMDIG 6827 ICNT=ICNT+1 6828 ITEXT(ICNT)='Sample Maximum:' 6829 NCTEXT(ICNT)=15 6830 AVALUE(ICNT)=XMAX 6831 IDIGIT(ICNT)=NUMDIG 6832 ICNT=ICNT+1 6833 ITEXT(ICNT)='Sample Median:' 6834 NCTEXT(ICNT)=14 6835 AVALUE(ICNT)=XMED 6836 IDIGIT(ICNT)=NUMDIG 6837 IF(ICASAN.EQ.'QUCI')THEN 6838 ICNT=ICNT+1 6839 ITEXT(ICNT)='Sample Quantile:' 6840 NCTEXT(ICNT)=16 6841 AVALUE(ICNT)=XQUANT 6842 ENDIF 6843 IDIGIT(ICNT)=NUMDIG 6844 ICNT=ICNT+1 6845 ITEXT(ICNT)='Sample Quantile Standard Error:' 6846 NCTEXT(ICNT)=31 6847 AVALUE(ICNT)=XQUASE 6848 IDIGIT(ICNT)=NUMDIG 6849 ICNT=ICNT+1 6850 ITEXT(ICNT)=' ' 6851 NCTEXT(ICNT)=1 6852 AVALUE(ICNT)=0.0 6853 IDIGIT(ICNT)=-1 6854C 6855 NUMROW=ICNT 6856 DO4210I=1,NUMROW 6857 NTOT(I)=15 6858 4210 CONTINUE 6859C 6860 IFRST=.TRUE. 6861 ILAST=.TRUE. 6862C 6863 ISTEPN='5A' 6864 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'QUC2') 6865 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6866C 6867 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT, 6868 1 AVALUE,IDIGIT, 6869 1 NTOT,NUMROW, 6870 1 ICAPSW,ICAPTY,ILAST,IFRST, 6871 1 ISUBRO,IBUGA3,IERROR) 6872C 6873 ISTEPN='5B' 6874 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2') 6875 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6876C 6877 CALL DPDT11(CONF,T,TSDM,ALOWER,AUPPER, 6878 1 ICASAN,ICAPSW,ICAPTY,NUMDIG, 6879 1 ISUBRO,IBUGA3,IERROR) 6880C 6881 IF(ICASAN.EQ.'MECI')THEN 6882 ICASA2='QUC2' 6883 CALL DPDT11(CONF,T,TSDM,ALOWE2,AUPPE2, 6884 1 ICASA2,ICAPSW,ICAPTY,NUMDIG, 6885 1 ISUBRO,IBUGA3,IERROR) 6886 ENDIF 6887C 6888C ***************** 6889C ** STEP 90-- ** 6890C ** EXIT ** 6891C ***************** 6892C 6893 9000 CONTINUE 6894 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'QUC2')THEN 6895 WRITE(ICOUT,999) 6896 CALL DPWRST('XXX','WRIT') 6897 WRITE(ICOUT,9011) 6898 9011 FORMAT('***** AT THE END OF DPQUC2--') 6899 CALL DPWRST('XXX','WRIT') 6900 WRITE(ICOUT,9012)N,IBUGA3,IERROR 6901 9012 FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4) 6902 CALL DPWRST('XXX','WRIT') 6903 WRITE(ICOUT,9013)XMED,XQUANT,XQUASE 6904 9013 FORMAT('XMED,XQUANT,XQUASE = ',3G15.7) 6905 CALL DPWRST('XXX','WRIT') 6906 ENDIF 6907C 6908 RETURN 6909 END 6910 SUBROUTINE DPQUTE(TEMP1,TEMP2,MAXNXT, 6911 1 ICAPSW,IFORSW,IMULT, 6912 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 6913C 6914C PURPOSE--CARRY OUT QUADE TEST NON-PARAMETRIC TWO-WAY ANOVA 6915C EXAMPLE--QUADE TEST Y X1 X2 6916C REFERENCE--CONOVER (1999), "PRACTICAL NONPARAMETRIC STATISTICS", 6917C THIRD EDITION, WILEY, PP. 373-380. 6918C WRITTEN BY--ALAN HECKERT 6919C STATISTICAL ENGINEERING DIVISION 6920C INFORMATION TECHNOLOGY LABORATORY 6921C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 6922C GAITHERSBURG, MD 20899-8980 6923C PHONE--301-975-2899 6924C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 6925C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 6926C LANGUAGE--ANSI FORTRAN (1977) 6927C VERSION NUMBER--2011/7 6928C ORIGINAL VERSION--JULY 2011. 6929C 6930C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 6931C 6932 CHARACTER*4 ICAPSW 6933 CHARACTER*4 IFORSW 6934 CHARACTER*4 IMULT 6935 CHARACTER*4 IBUGA2 6936 CHARACTER*4 IBUGA3 6937 CHARACTER*4 IBUGQ 6938 CHARACTER*4 ISUBRO 6939 CHARACTER*4 IFOUND 6940 CHARACTER*4 IERROR 6941C 6942 CHARACTER*4 ISUBN1 6943 CHARACTER*4 ISUBN2 6944 CHARACTER*4 ISTEPN 6945C 6946 LOGICAL IFRST 6947 LOGICAL ILAST 6948 CHARACTER*4 IFLAGU 6949 CHARACTER*4 ICASE 6950 CHARACTER*40 INAME 6951 PARAMETER (MAXSPN=30) 6952 CHARACTER*4 IVARN1(MAXSPN) 6953 CHARACTER*4 IVARN2(MAXSPN) 6954 CHARACTER*4 IVARTY(MAXSPN) 6955 REAL PVAR(MAXSPN) 6956 INTEGER ILIS(MAXSPN) 6957 INTEGER NRIGHT(MAXSPN) 6958 INTEGER ICOLR(MAXSPN) 6959C 6960C--------------------------------------------------------------------- 6961C 6962 DIMENSION TEMP1(*) 6963 DIMENSION TEMP2(*) 6964C 6965C-----COMMON---------------------------------------------------------- 6966C 6967 INCLUDE 'DPCOPA.INC' 6968 INCLUDE 'DPCOZZ.INC' 6969 INCLUDE 'DPCOZD.INC' 6970C 6971 DIMENSION XTEMP2(MAXOBV) 6972 DIMENSION DBLOCK(MAXOBV) 6973 DIMENSION DTREAT(MAXOBV) 6974 DIMENSION RJ(MAXOBV) 6975 DIMENSION QRANK(MAXOBV) 6976 DOUBLE PRECISION YRANK(MAXOBV) 6977C 6978 EQUIVALENCE(GARBAG(IGARB1),XTEMP2(1)) 6979 EQUIVALENCE(GARBAG(IGARB2),DBLOCK(1)) 6980 EQUIVALENCE(GARBAG(IGARB3),DTREAT(1)) 6981 EQUIVALENCE(GARBAG(IGARB4),RJ(1)) 6982 EQUIVALENCE(GARBAG(IGARB5),QRANK(1)) 6983 EQUIVALENCE(DGARBG(IDGAR1),YRANK(1)) 6984C 6985 INCLUDE 'DPCOHK.INC' 6986 INCLUDE 'DPCOSU.INC' 6987 INCLUDE 'DPCODA.INC' 6988 INCLUDE 'DPCOP2.INC' 6989C 6990C-----START POINT----------------------------------------------------- 6991C 6992 ISUBN1='DPQU' 6993 ISUBN2='TE ' 6994C 6995 MAXCP1=MAXCOL+1 6996 MAXCP2=MAXCOL+2 6997 MAXCP3=MAXCOL+3 6998 MAXCP4=MAXCOL+4 6999 MAXCP5=MAXCOL+5 7000 MAXCP6=MAXCOL+6 7001C 7002 IFOUND='YES' 7003 IERROR='NO' 7004C 7005C ****************************************** 7006C ** TREAT THE QUADE TEST CASE ** 7007C ****************************************** 7008C 7009 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUTE')THEN 7010 WRITE(ICOUT,999) 7011 999 FORMAT(1X) 7012 CALL DPWRST('XXX','BUG ') 7013 WRITE(ICOUT,51) 7014 51 FORMAT('***** AT THE BEGINNING OF DPQUTE--') 7015 CALL DPWRST('XXX','BUG ') 7016 WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT 7017 52 FORMAT('IBUGA2,IBUGA3,IBUBQ,ISUBRO,MAXNXT = ',4(A4,2X),I8) 7018 CALL DPWRST('XXX','BUG ') 7019 WRITE(ICOUT,53)ICAPSW,ICAPTY,IFORSW 7020 53 FORMAT('ICAPSW,ICAPTY,IFORSW = ',2(A4,2X),A4) 7021 CALL DPWRST('XXX','BUG ') 7022 ENDIF 7023C 7024C ********************************* 7025C ** STEP 1-- ** 7026C ** EXTRACT THE VARIABLE LIST ** 7027C ********************************* 7028C 7029 ISTEPN='1' 7030 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUTE') 7031 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7032C 7033 IMULT='OFF' 7034 INAME='QUADE TEST' 7035 MAXNA=100 7036 MINNVA=1 7037 MAXNVA=MAXSPN 7038 MINNA=1 7039 IFLAGE=1 7040 IFLAGM=0 7041 IF(IMULT.EQ.'ON')THEN 7042 IFLAGM=0 7043 ENDIF 7044 MINN2=2 7045 IFLAGP=0 7046 JMIN=1 7047 JMAX=NUMARG 7048C 7049 CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH, 7050 1 IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE, 7051 1 JMIN,JMAX, 7052 1 MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME, 7053 1 IVARN1,IVARN2,IVARTY,PVAR, 7054 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR, 7055 1 MINNVA,MAXNVA, 7056 1 IFLAGM,IFLAGP, 7057 1 IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 7058 IF(IERROR.EQ.'YES')GOTO9000 7059C 7060 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUTE')THEN 7061 WRITE(ICOUT,999) 7062 CALL DPWRST('XXX','BUG ') 7063 WRITE(ICOUT,181) 7064 181 FORMAT('***** AFTER CALL DPPARS--') 7065 CALL DPWRST('XXX','BUG ') 7066 WRITE(ICOUT,182)NQ,NUMVAR,IMULT 7067 182 FORMAT('NQ,NUMVAR,IMULT = ',2I8,2X,A4) 7068 CALL DPWRST('XXX','BUG ') 7069 IF(NUMVAR.GT.0)THEN 7070 DO185I=1,NUMVAR 7071 WRITE(ICOUT,187)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I), 7072 1 ICOLR(I) 7073 187 FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),', 7074 1 'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8) 7075 CALL DPWRST('XXX','BUG ') 7076 185 CONTINUE 7077 ENDIF 7078 ENDIF 7079C 7080C ********************************** 7081C ** STEP 3-- ** 7082C ** CARRY OUT THE QUADE TEST ** 7083C ********************************** 7084C 7085 ISTEPN='3' 7086 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUTE') 7087 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7088C 7089C ***************************************** 7090C ** STEP 3A-- ** 7091C ** CASE 1: THREE RESPONSE VARIABLES ** 7092C ** NO MATRIX, NO MULTIPLE ** 7093C ***************************************** 7094C 7095 IF(IMULT.EQ.'OFF')THEN 7096 ISTEPN='3A' 7097 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUTE') 7098 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7099C 7100 ICOL=1 7101 NUMVA2=3 7102 CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV, 7103 1 INAME,IVARN1,IVARN2,IVARTY, 7104 1 ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2, 7105 1 MAXCOL,MAXCP1,MAXCP2,MAXCP3, 7106 1 MAXCP4,MAXCP5,MAXCP6, 7107 1 V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO, 7108 1 Y,X,XTEMP2,NS1,NS1,NS1,ICASE, 7109 1 IBUGA3,ISUBRO,IFOUND,IERROR) 7110 IF(IERROR.EQ.'YES')GOTO9000 7111C 7112 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'QUTE')THEN 7113 WRITE(ICOUT,999) 7114 CALL DPWRST('XXX','BUG ') 7115 WRITE(ICOUT,5211) 7116 5211 FORMAT('***** FROM DPQUTE, AS WE ARE ABOUT TO CALL DPQUT2--') 7117 CALL DPWRST('XXX','BUG ') 7118 WRITE(ICOUT,5212)NS1 7119 5212 FORMAT('NS1 = ',I8) 7120 CALL DPWRST('XXX','BUG ') 7121 DO5215I=1,NS1 7122 WRITE(ICOUT,5216)I,Y(I),X(I),XTEMP2(I) 7123 5216 FORMAT('I,Y(I),X(I),XTEMP2(I) = ',I8,3G15.7) 7124 CALL DPWRST('XXX','BUG ') 7125 5215 CONTINUE 7126 ENDIF 7127C 7128 CALL DPQUT2(Y,X,XTEMP2,NS1,IVARN1,IVARN2, 7129 1 DBLOCK,DTREAT,YRANK,RJ,QRANK, 7130 1 TEMP1,TEMP2,MAXNXT, 7131 1 STATVA,STATCD,PVAL, 7132 1 CUT0,CUT50,CUT75,CUT90,CUT95,CUT99,CUT999, 7133 1 ICAPSW,ICAPTY,IFORSW,IMULT, 7134 1 IBUGA3,ISUBRO,IERROR) 7135C 7136C *************************************** 7137C ** STEP 61-- ** 7138C ** UPDATE INTERNAL DATAPLOT TABLES ** 7139C *************************************** 7140C 7141 ISTEPN='61' 7142 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUTE') 7143 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7144C 7145 IFLAGU='ON' 7146 IFRST=.TRUE. 7147 ILAST=.TRUE. 7148 CALL DPFRT5(STATVA,STATCD,PVAL, 7149 1 CUT0,CUT50,CUT75,CUT90,CUT95, 7150 1 CUT975,CUT99,CUT999, 7151 1 IFLAGU,IFRST,ILAST, 7152 1 IBUGA2,IBUGA3,ISUBRO,IERROR) 7153 ENDIF 7154C 7155C ***************** 7156C ** STEP 90-- ** 7157C ** EXIT ** 7158C ***************** 7159C 7160 9000 CONTINUE 7161 IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FRI2')THEN 7162 WRITE(ICOUT,999) 7163 CALL DPWRST('XXX','BUG ') 7164 WRITE(ICOUT,9011) 7165 9011 FORMAT('***** AT THE END OF DPQUTE--') 7166 CALL DPWRST('XXX','BUG ') 7167 WRITE(ICOUT,9016)IFOUND,IERROR,STATVA,STATCD 7168 9016 FORMAT('IFOUND,IERROR,STATVA,STATCD = ',2(A4,2X),2G15.7) 7169 CALL DPWRST('XXX','BUG ') 7170 ENDIF 7171C 7172 RETURN 7173 END 7174 SUBROUTINE DPQUT2(Y,BLOCK,TREAT,N,IVARID,IVARI2, 7175 1 DBLOCK,DTREAT,YRANK,RJ,QRANK, 7176 1 TEMP1,TEMP2,MAXNXT, 7177 1 STATVA,STATCD,PVAL, 7178 1 CUT0,CUT50,CUT75,CUT90,CUT95,CUT99,CUT999, 7179 1 ICAPSW,ICAPTY,IFORSW,IMULT, 7180 1 IBUGA3,ISUBRO,IERROR) 7181C 7182C PURPOSE--THIS ROUTINE CARRIES OUT QUADE'S TEST 7183C NON-PARAMETRIC TWO-WAY ANOVA 7184C EXAMPLE--QUADE TEST Y BLOCK TREAT 7185C REFERENCE--CONOVER (1999), "PRACTICAL NONPARAMETRIC STATISTICS", 7186C THIRD EDITION, WILEY, PP. 373-380. 7187C WRITTEN BY--ALAN HECKERT 7188C STATISTICAL ENGINEERING DIVISION 7189C INFORMATION TECHNOLOGY LABORATORY 7190C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 7191C GAITHERSBURG, MD 20899-8980 7192C PHONE--301-975-2899 7193C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 7194C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 7195C LANGUAGE--ANSI FORTRAN (1977) 7196C VERSION NUMBER--2011/7 7197C ORIGINAL VERSION--JULY 2011. 7198C 7199C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 7200C 7201 CHARACTER*4 ICAPSW 7202 CHARACTER*4 ICAPTY 7203 CHARACTER*4 IFORSW 7204 CHARACTER*4 IMULT 7205 CHARACTER*4 IBUGA3 7206 CHARACTER*4 ISUBRO 7207 CHARACTER*4 IERROR 7208 CHARACTER*4 IVARID(*) 7209 CHARACTER*4 IVARI2(*) 7210C 7211 CHARACTER*4 IWRITE 7212 CHARACTER*4 ISUBN1 7213 CHARACTER*4 ISUBN2 7214 CHARACTER*4 ISTEPN 7215 CHARACTER*4 IOP 7216 CHARACTER*3 IATEMP 7217C 7218C--------------------------------------------------------------------- 7219C 7220 DIMENSION Y(*) 7221 DIMENSION BLOCK(*) 7222 DIMENSION TREAT(*) 7223 DIMENSION RJ(*) 7224 DIMENSION QRANK(*) 7225 DIMENSION DBLOCK(*) 7226 DIMENSION DTREAT(*) 7227 DIMENSION TEMP1(*) 7228 DIMENSION TEMP2(*) 7229C 7230 DOUBLE PRECISION YRANK(*) 7231C 7232 PARAMETER (NUMALP=8) 7233 REAL ALPHA(NUMALP) 7234C 7235 PARAMETER(NUMCLI=6) 7236 PARAMETER(MAXLIN=2) 7237 PARAMETER (MAXROW=50) 7238 CHARACTER*60 ITITLE 7239 CHARACTER*60 ITITLZ 7240 CHARACTER*1 ITITL9 7241 CHARACTER*60 ITEXT(MAXROW) 7242 CHARACTER*4 ALIGN(NUMCLI) 7243 CHARACTER*4 VALIGN(NUMCLI) 7244 REAL AVALUE(MAXROW) 7245 INTEGER NCTEXT(MAXROW) 7246 INTEGER IDIGIT(MAXROW) 7247 INTEGER NTOT(MAXROW) 7248 CHARACTER*60 ITITL2(MAXLIN,NUMCLI) 7249 CHARACTER*15 IVALUE(MAXROW,NUMCLI) 7250 CHARACTER*4 ITYPCO(NUMCLI) 7251 INTEGER NCTIT2(MAXLIN,NUMCLI) 7252 INTEGER NCVALU(MAXROW,NUMCLI) 7253 INTEGER IWHTML(NUMCLI) 7254 INTEGER IWRTF(NUMCLI) 7255 REAL AMAT(MAXROW,NUMCLI) 7256 LOGICAL IFRST 7257 LOGICAL ILAST 7258C 7259C--------------------------------------------------------------------- 7260C 7261 INCLUDE 'DPCOP2.INC' 7262C 7263C-----START POINT----------------------------------------------------- 7264C 7265 DATA ALPHA/ 7266 1 0.0, 50.0, 75.0, 90.0, 95.0, 97.5, 99.0, 99.9/ 7267C 7268 ISUBN1='DPFR' 7269 ISUBN2='I2 ' 7270C 7271 IERROR='NO' 7272 IWRITE='OFF' 7273C 7274 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'QUT2')THEN 7275 WRITE(ICOUT,999) 7276 999 FORMAT(1X) 7277 CALL DPWRST('XXX','WRIT') 7278 WRITE(ICOUT,51) 7279 51 FORMAT('**** AT THE BEGINNING OF DPQUT2--') 7280 CALL DPWRST('XXX','WRIT') 7281 WRITE(ICOUT,52)IBUGA3,ISUBRO,N 7282 52 FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8) 7283 CALL DPWRST('XXX','WRIT') 7284 DO56I=1,N 7285 WRITE(ICOUT,57)I,Y(I),BLOCK(I),TREAT(I) 7286 57 FORMAT('I,Y(I),BLOCK(I),TREAT(I) = ',I8,3G15.7) 7287 CALL DPWRST('XXX','WRIT') 7288 56 CONTINUE 7289 ENDIF 7290C 7291 MAXNX2=MAXNXT 7292 CALL DPQUT3(Y,BLOCK,TREAT,N, 7293 1 DBLOCK,DTREAT,RJ,TEMP1,TEMP2,QRANK, 7294 1 YRANK, 7295 1 MAXNXT,MAXNX2, 7296 1 STATVA,STATCD,PVAL, 7297 1 NBLOCK,NTREAT,NUMDF1,NUMDF2, 7298 1 T1,T2,A1,C1,SSTR,SSTO, 7299 1 IBUGA3,ISUBRO,IERROR) 7300 IF(IERROR.EQ.'YES')GOTO9000 7301C 7302 CUT0=0.0 7303 CALL FPPF(.50,NUMDF1,NUMDF2,CUT50) 7304 CALL FPPF(.75,NUMDF1,NUMDF2,CUT75) 7305 CALL FPPF(.90,NUMDF1,NUMDF2,CUT90) 7306 CALL FPPF(.95,NUMDF1,NUMDF2,CUT95) 7307 CALL FPPF(.975,NUMDF1,NUMDF2,CUT975) 7308 CALL FPPF(.99,NUMDF1,NUMDF2,CUT99) 7309 CALL FPPF(.999,NUMDF1,NUMDF2,CUT999) 7310C 7311 ANB=REAL(NBLOCK) 7312 AK=REAL(NTREAT) 7313C 7314 IDF=(NBLOCK-1)*(NTREAT-1) 7315 CALL TPPF(0.95,REAL(IDF),T95) 7316 CALL TPPF(0.975,REAL(IDF),T975) 7317 CALL TPPF(0.995,REAL(IDF),T995) 7318 TERM1=2.0*ANB*(SSTO - SSTR)/REAL(IDF) 7319 CONTRA=SQRT(TERM1) 7320 CONTR1=T95*CONTRA 7321 CONTR2=T975*CONTRA 7322 CONTR3=T995*CONTRA 7323C 7324 IOP='OPEN' 7325 IFLG1=1 7326 IFLG2=1 7327 IFLG3=0 7328 IFLG4=0 7329 IFLG5=0 7330 CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5, 7331 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 7332 1 IBUGA3,ISUBRO,IERROR) 7333 IF(IERROR.EQ.'YES')GOTO9000 7334C 7335 WRITE(IOUNI1,2405) 7336 2405 FORMAT(4X,'RESPONSE',13X,'RANK',11X,'BLOCK',8X,'TREATMENT') 7337 DO2410I=1,N 7338 WRITE(IOUNI1,2411)Y(I),YRANK(I),BLOCK(I),TREAT(I) 7339 2411 FORMAT(1X,E15.7,F15.2,F15.2,F15.2) 7340 2410 CONTINUE 7341C 7342 WRITE(IOUNI2,2421)CONTRA 7343 2421 FORMAT(1X,'Contrast term: ',E15.7) 7344 WRITE(IOUNI2,2422)CONTR1 7345 2422 FORMAT(1X,'Contrast term*t(0.95): ',E15.7) 7346 WRITE(IOUNI2,2423)CONTR2 7347 2423 FORMAT(1X,'Contrast term*t(0.975): ',E15.7) 7348 WRITE(IOUNI2,2424)CONTR3 7349 2424 FORMAT(1X,'Contrast term*t(0.995): ',E15.7) 7350 WRITE(IOUNI2,2425) 7351 2425 FORMAT(10X,'I',10X,'J',8X,'R(I)-R(J)') 7352C 7353 DO2430I=1,NTREAT 7354 DO2439J=1,NTREAT 7355 IF(I.LT.J)THEN 7356 ADIFF=RJ(I)-RJ(J) 7357 IATEMP=' ' 7358 IF(ABS(ADIFF).GE.CONTR1)IATEMP(1:1)='*' 7359 IF(ABS(ADIFF).GE.CONTR2)IATEMP(2:2)='*' 7360 IF(ABS(ADIFF).GE.CONTR3)IATEMP(3:3)='*' 7361 WRITE(IOUNI2,2437)I,J,ADIFF,IATEMP 7362 2437 FORMAT(3X,I8,3X,I8,5X,E15.7,A3) 7363 ENDIF 7364 2439 CONTINUE 7365 2430 CONTINUE 7366C 7367 IOP='CLOS' 7368 CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5, 7369 1 IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5, 7370 1 IBUGA3,ISUBRO,IERROR) 7371C 7372C ***************************** 7373C ** STEP 42- ** 7374C ** WRITE OUT THE TABLE ** 7375C ***************************** 7376C 7377 ISTEPN='42' 7378 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'QUT2') 7379 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7380C 7381C ****************************** 7382C ** STEP 43-- ** 7383C ** WRITE OUT EVERYTHING ** 7384C ** FOR QUADE TEST ** 7385C ****************************** 7386C 7387 ISTEPN='43' 7388 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'QUT2') 7389 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7390C 7391 IF(IPRINT.EQ.'OFF')GOTO9000 7392C 7393 NUMDIG=7 7394 IF(IFORSW.EQ.'1')NUMDIG=1 7395 IF(IFORSW.EQ.'2')NUMDIG=2 7396 IF(IFORSW.EQ.'3')NUMDIG=3 7397 IF(IFORSW.EQ.'4')NUMDIG=4 7398 IF(IFORSW.EQ.'5')NUMDIG=5 7399 IF(IFORSW.EQ.'6')NUMDIG=6 7400 IF(IFORSW.EQ.'7')NUMDIG=7 7401 IF(IFORSW.EQ.'8')NUMDIG=8 7402 IF(IFORSW.EQ.'9')NUMDIG=9 7403 IF(IFORSW.EQ.'0')NUMDIG=0 7404 IF(IFORSW.EQ.'E')NUMDIG=-2 7405 IF(IFORSW.EQ.'-2')NUMDIG=-2 7406 IF(IFORSW.EQ.'-3')NUMDIG=-3 7407 IF(IFORSW.EQ.'-4')NUMDIG=-4 7408 IF(IFORSW.EQ.'-5')NUMDIG=-5 7409 IF(IFORSW.EQ.'-6')NUMDIG=-6 7410 IF(IFORSW.EQ.'-7')NUMDIG=-7 7411 IF(IFORSW.EQ.'-8')NUMDIG=-8 7412 IF(IFORSW.EQ.'-9')NUMDIG=-9 7413C 7414 ITITLE='Quade Two Factor Test' 7415 NCTITL=21 7416 ITITLZ=' ' 7417 NCTITZ=0 7418C 7419 ICNT=1 7420 ITEXT(ICNT)=' ' 7421 NCTEXT(ICNT)=0 7422 AVALUE(ICNT)=0.0 7423 IDIGIT(ICNT)=-1 7424 ICNT=ICNT+1 7425 ITEXT(ICNT)='Response Variable: ' 7426 WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4) 7427 WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4) 7428 NCTEXT(ICNT)=27 7429 AVALUE(ICNT)=0.0 7430 IDIGIT(ICNT)=-1 7431C 7432 IF(IMULT.EQ.'OFF')THEN 7433C 7434 ICNT=ICNT+1 7435 ITEXT(ICNT)='First Group-ID Variable: ' 7436 WRITE(ITEXT(ICNT)(26:29),'(A4)')IVARID(2)(1:4) 7437 WRITE(ITEXT(ICNT)(30:33),'(A4)')IVARI2(2)(1:4) 7438 NCTEXT(ICNT)=33 7439 AVALUE(ICNT)=0.0 7440 IDIGIT(ICNT)=-1 7441C 7442 ICNT=ICNT+1 7443 ITEXT(ICNT)='Second Group-ID Variable: ' 7444 WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARID(3)(1:4) 7445 WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARI2(3)(1:4) 7446 NCTEXT(ICNT)=34 7447 AVALUE(ICNT)=0.0 7448 IDIGIT(ICNT)=-1 7449C 7450 ELSE 7451 ENDIF 7452C 7453 ICNT=ICNT+1 7454 ITEXT(ICNT)=' ' 7455 NCTEXT(ICNT)=1 7456 AVALUE(ICNT)=0.0 7457 IDIGIT(ICNT)=-1 7458C 7459 ICNT=ICNT+1 7460 ITEXT(ICNT)='H0: Treatments Have Identical Effects' 7461 NCTEXT(ICNT)=37 7462 AVALUE(ICNT)=0.0 7463 IDIGIT(ICNT)=-1 7464 ICNT=ICNT+1 7465 ITEXT(ICNT)='Ha: Treatments Do Not Have Identical Effects' 7466 NCTEXT(ICNT)=44 7467 AVALUE(ICNT)=0.0 7468 IDIGIT(ICNT)=-1 7469C 7470 ICNT=ICNT+1 7471 ITEXT(ICNT)=' ' 7472 NCTEXT(ICNT)=1 7473 AVALUE(ICNT)=0.0 7474 IDIGIT(ICNT)=-1 7475C 7476 ICNT=ICNT+1 7477 ITEXT(ICNT)='Summary Statistics:' 7478 NCTEXT(ICNT)=19 7479 AVALUE(ICNT)=0.0 7480 IDIGIT(ICNT)=-1 7481 ICNT=ICNT+1 7482 ITEXT(ICNT)='Total Number of Observations:' 7483 NCTEXT(ICNT)=29 7484 AVALUE(ICNT)=REAL(N) 7485 IDIGIT(ICNT)=0 7486 ICNT=ICNT+1 7487 ITEXT(ICNT)='Number of Blocks:' 7488 NCTEXT(ICNT)=17 7489 AVALUE(ICNT)=REAL(NBLOCK) 7490 IDIGIT(ICNT)=0 7491 ICNT=ICNT+1 7492 ITEXT(ICNT)='Number of Treatments:' 7493 NCTEXT(ICNT)=21 7494 AVALUE(ICNT)=REAL(NTREAT) 7495 IDIGIT(ICNT)=0 7496 ICNT=ICNT+1 7497 ITEXT(ICNT)=' ' 7498 NCTEXT(ICNT)=1 7499 AVALUE(ICNT)=0.0 7500 IDIGIT(ICNT)=-1 7501C 7502 ICNT=ICNT+1 7503 ITEXT(ICNT)='Test:' 7504 NCTEXT(ICNT)=5 7505 AVALUE(ICNT)=0.0 7506 IDIGIT(ICNT)=-1 7507 ICNT=ICNT+1 7508 ITEXT(ICNT)='Quade Test Statistic:' 7509 NCTEXT(ICNT)=21 7510 AVALUE(ICNT)=STATVA 7511 IDIGIT(ICNT)=NUMDIG 7512 ICNT=ICNT+1 7513 ITEXT(ICNT)='Total Sum of Squares (A2):' 7514 NCTEXT(ICNT)=26 7515 AVALUE(ICNT)=SSTO 7516 IDIGIT(ICNT)=NUMDIG 7517 ICNT=ICNT+1 7518 ITEXT(ICNT)='Treatment Sum of Squares (B):' 7519 NCTEXT(ICNT)=29 7520 AVALUE(ICNT)=SSTR 7521 IDIGIT(ICNT)=NUMDIG 7522 ICNT=ICNT+1 7523 ITEXT(ICNT)='CDF of Test Statistic:' 7524 NCTEXT(ICNT)=22 7525 AVALUE(ICNT)=STATCD 7526 IDIGIT(ICNT)=NUMDIG 7527 ICNT=ICNT+1 7528 ITEXT(ICNT)='P-Value:' 7529 NCTEXT(ICNT)=8 7530 AVALUE(ICNT)=PVAL 7531 IDIGIT(ICNT)=NUMDIG 7532C 7533 NUMROW=ICNT 7534 DO4210I=1,NUMROW 7535 NTOT(I)=15 7536 4210 CONTINUE 7537C 7538 IFRST=.TRUE. 7539 ILAST=.TRUE. 7540C 7541 ISTEPN='42A' 7542 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'QUT2') 7543 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7544C 7545 CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT, 7546 1 AVALUE,IDIGIT, 7547 1 NTOT,NUMROW, 7548 1 ICAPSW,ICAPTY,ILAST,IFRST, 7549 1 ISUBRO,IBUGA3,IERROR) 7550C 7551 ITITLE=' ' 7552 NCTITL=0 7553 ITITL9=' ' 7554 NCTIT9=0 7555 ITITLE='Percent Points of the F Reference Distribution' 7556 NCTITL=46 7557 NUMLIN=1 7558 NUMROW=8 7559 NUMCOL=3 7560 ITITL2(1,1)='Percent Point' 7561 ITITL2(1,2)=' ' 7562 ITITL2(1,3)='Value' 7563 NCTIT2(1,1)=13 7564 NCTIT2(1,2)=1 7565 NCTIT2(1,3)=5 7566C 7567 NMAX=0 7568 DO4221I=1,NUMCOL 7569 VALIGN(I)='b' 7570 ALIGN(I)='r' 7571 NTOT(I)=15 7572 IF(I.EQ.2)NTOT(I)=5 7573 NMAX=NMAX+NTOT(I) 7574 IDIGIT(I)=NUMDIG 7575 ITYPCO(I)='NUME' 7576 4221 CONTINUE 7577 ITYPCO(2)='ALPH' 7578 IDIGIT(1)=1 7579 IDIGIT(3)=3 7580 DO4223I=1,NUMROW 7581 DO4225J=1,NUMCOL 7582 NCVALU(I,J)=0 7583 IVALUE(I,J)=' ' 7584 NCVALU(I,J)=0 7585 AMAT(I,J)=0.0 7586 IF(J.EQ.1)THEN 7587 AMAT(I,J)=ALPHA(I) 7588 ELSEIF(J.EQ.2)THEN 7589 IVALUE(I,J)='=' 7590 NCVALU(I,J)=1 7591 ELSEIF(J.EQ.3)THEN 7592 IF(I.EQ.1)THEN 7593 AMAT(I,J)=RND(CUT0,IDIGIT(J)) 7594 ELSEIF(I.EQ.2)THEN 7595 AMAT(I,J)=RND(CUT50,IDIGIT(J)) 7596 ELSEIF(I.EQ.3)THEN 7597 AMAT(I,J)=RND(CUT75,IDIGIT(J)) 7598 ELSEIF(I.EQ.4)THEN 7599 AMAT(I,J)=RND(CUT90,IDIGIT(J)) 7600 ELSEIF(I.EQ.5)THEN 7601 AMAT(I,J)=RND(CUT95,IDIGIT(J)) 7602 ELSEIF(I.EQ.6)THEN 7603 AMAT(I,J)=RND(CUT975,IDIGIT(J)) 7604 ELSEIF(I.EQ.7)THEN 7605 AMAT(I,J)=RND(CUT99,IDIGIT(J)) 7606 ELSEIF(I.EQ.8)THEN 7607 AMAT(I,J)=RND(CUT999,IDIGIT(J)) 7608 ENDIF 7609 ENDIF 7610 4225 CONTINUE 7611 4223 CONTINUE 7612C 7613 IWHTML(1)=150 7614 IWHTML(2)=50 7615 IWHTML(3)=150 7616 IWRTF(1)=2000 7617 IWRTF(2)=IWRTF(1)+500 7618 IWRTF(3)=IWRTF(2)+2000 7619 IFRST=.TRUE. 7620 ILAST=.TRUE. 7621C 7622 ISTEPN='42C' 7623 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'QUT2') 7624 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7625C 7626 CALL DPDTA4(ITITL9,NCTIT9, 7627 1 ITITLE,NCTITL,ITITL2,NCTIT2, 7628 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 7629 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW, 7630 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 7631 1 ICAPSW,ICAPTY,IFRST,ILAST, 7632 1 ISUBRO,IBUGA3,IERROR) 7633C 7634 CDF1=CUT90 7635 CDF2=CUT95 7636 CDF3=CUT975 7637 CDF4=CUT99 7638C 7639 ITITL9=' ' 7640 NCTIT9=0 7641 ITITLE='Conclusions (Upper 1-Tailed Test)' 7642 NCTITL=33 7643 NUMLIN=1 7644 NUMROW=4 7645 NUMCOL=4 7646 ITITL2(1,1)='Alpha' 7647 ITITL2(1,2)='CDF' 7648 ITITL2(1,3)='Critical Value' 7649 ITITL2(1,4)='Conclusion' 7650 NCTIT2(1,1)=5 7651 NCTIT2(1,2)=3 7652 NCTIT2(1,3)=14 7653 NCTIT2(1,4)=10 7654C 7655 NMAX=0 7656 DO4321I=1,NUMCOL 7657 VALIGN(I)='b' 7658 ALIGN(I)='r' 7659 NTOT(I)=15 7660 IF(I.EQ.1 .OR. I.EQ.2)NTOT(I)=7 7661 IF(I.EQ.3)NTOT(I)=17 7662 NMAX=NMAX+NTOT(I) 7663 IDIGIT(I)=3 7664 ITYPCO(I)='ALPH' 7665 4321 CONTINUE 7666 ITYPCO(3)='NUME' 7667 IDIGIT(1)=0 7668 IDIGIT(2)=0 7669 DO4323I=1,NUMROW 7670 DO4325J=1,NUMCOL 7671 NCVALU(I,J)=0 7672 IVALUE(I,J)=' ' 7673 NCVALU(I,J)=0 7674 AMAT(I,J)=0.0 7675 4325 CONTINUE 7676 4323 CONTINUE 7677 IVALUE(1,1)='10%' 7678 IVALUE(2,1)='5%' 7679 IVALUE(3,1)='2.5%' 7680 IVALUE(4,1)='1%' 7681 IVALUE(1,2)='90%' 7682 IVALUE(2,2)='95%' 7683 IVALUE(3,2)='97.5%' 7684 IVALUE(4,2)='99%' 7685 NCVALU(1,1)=3 7686 NCVALU(2,1)=2 7687 NCVALU(3,1)=4 7688 NCVALU(4,1)=2 7689 NCVALU(1,2)=3 7690 NCVALU(2,2)=3 7691 NCVALU(3,2)=5 7692 NCVALU(4,2)=3 7693 IVALUE(1,4)='Accept H0' 7694 IVALUE(2,4)='Accept H0' 7695 IVALUE(3,4)='Accept H0' 7696 IVALUE(4,4)='Accept H0' 7697 NCVALU(1,4)=9 7698 NCVALU(2,4)=9 7699 NCVALU(3,4)=9 7700 NCVALU(4,4)=9 7701 IF(STATVA.GT.CUT90)IVALUE(1,4)='Reject H0' 7702 IF(STATVA.GT.CUT95)IVALUE(2,4)='Reject H0' 7703 IF(STATVA.GT.CUT975)IVALUE(3,4)='Reject H0' 7704 IF(STATVA.GT.CUT99)IVALUE(4,4)='Reject H0' 7705 AMAT(1,3)=RND(CUT90,IDIGIT(3)) 7706 AMAT(2,3)=RND(CUT95,IDIGIT(3)) 7707 AMAT(3,3)=RND(CUT975,IDIGIT(3)) 7708 AMAT(4,3)=RND(CUT99,IDIGIT(3)) 7709C 7710 IWHTML(1)=150 7711 IWHTML(2)=150 7712 IWHTML(3)=150 7713 IWHTML(4)=150 7714 IWRTF(1)=1500 7715 IWRTF(2)=IWRTF(1)+1500 7716 IWRTF(3)=IWRTF(2)+2000 7717 IWRTF(4)=IWRTF(3)+2000 7718 IFRST=.FALSE. 7719 ILAST=.TRUE. 7720C 7721 ISTEPN='42E' 7722 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KRU2') 7723 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7724C 7725 CALL DPDTA4(ITITL9,NCTIT9, 7726 1 ITITLE,NCTITL,ITITL2,NCTIT2, 7727 1 MAXLIN,NUMLIN,NUMCLI,NUMCOL, 7728 1 IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW, 7729 1 IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX, 7730 1 ICAPSW,ICAPTY,IFRST,ILAST, 7731 1 ISUBRO,IBUGA3,IERROR) 7732C 7733C 7734C ***************** 7735C ** STEP 90-- ** 7736C ** EXIT ** 7737C ***************** 7738C 7739 9000 CONTINUE 7740 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'QUT2')THEN 7741 WRITE(ICOUT,999) 7742 CALL DPWRST('XXX','WRIT') 7743 WRITE(ICOUT,9011) 7744 9011 FORMAT('***** AT THE END OF DPQUT2--') 7745 CALL DPWRST('XXX','WRIT') 7746 WRITE(ICOUT,9012)STATVA,STATCD,PVAL 7747 9012 FORMAT('STATVA,STATCD,PVAL = ',3G15.7) 7748 CALL DPWRST('XXX','WRIT') 7749 ENDIF 7750C 7751 RETURN 7752 END 7753 SUBROUTINE DPQUT3(Y,BLOCK,TREAT,N, 7754 1 DBLOCK,DTREAT,RJ,TEMP1,TEMP2,QRANK, 7755 1 YRANK, 7756 1 MAXNXT,MAXNX2, 7757 1 STATVA,STATCD,PVAL, 7758 1 NBLOCK,NTREAT,NUMDF1,NUMDF2, 7759 1 T1,T2,A1,C1,SSTR,SSTO, 7760 1 IBUGA3,ISUBRO,IERROR) 7761C 7762C PURPOSE--THIS ROUTINE CARRIES OUT QUADE'S TEST 7763C NON-PARAMETRIC TWO-WAY ANOVA 7764C EXAMPLE--QUADE TEST Y BLOCK TREAT 7765C REFERENCE--CONOVER (1999), "PRACTICAL NONPARAMETRIC STATISTICS", 7766C THIRD EDITION, WILEY, PP. 373-380. 7767C WRITTEN BY--ALAN HECKERT 7768C STATISTICAL ENGINEERING DIVISION 7769C INFORMATION TECHNOLOGY LABORATORY 7770C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 7771C GAITHERSBURG, MD 20899-8980 7772C PHONE--301-975-2899 7773C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 7774C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 7775C LANGUAGE--ANSI FORTRAN (1977) 7776C VERSION NUMBER--2011/7 7777C ORIGINAL VERSION--JULY 2011. 7778C 7779C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 7780C 7781 CHARACTER*4 IBUGA3 7782 CHARACTER*4 ISUBRO 7783 CHARACTER*4 IERROR 7784C 7785 CHARACTER*4 IWRITE 7786 CHARACTER*4 ISUBN1 7787 CHARACTER*4 ISUBN2 7788 CHARACTER*4 ISTEPN 7789C 7790 DOUBLE PRECISION DA2 7791 DOUBLE PRECISION DB 7792 DOUBLE PRECISION SJ 7793C 7794C--------------------------------------------------------------------- 7795C 7796 DIMENSION Y(*) 7797 DIMENSION BLOCK(*) 7798 DIMENSION TREAT(*) 7799 DIMENSION RJ(*) 7800 DIMENSION DBLOCK(*) 7801 DIMENSION DTREAT(*) 7802 DIMENSION TEMP1(*) 7803 DIMENSION TEMP2(*) 7804 DIMENSION QRANK(*) 7805 DOUBLE PRECISION YRANK(*) 7806C 7807C--------------------------------------------------------------------- 7808C 7809 INCLUDE 'DPCOP2.INC' 7810C 7811C-----START POINT----------------------------------------------------- 7812C 7813 ISUBN1='DPQU' 7814 ISUBN2='T3 ' 7815 IERROR='NO' 7816 IWRITE='OFF' 7817C 7818 STATVA=CPUMIN 7819 STATCD=CPUMIN 7820 PVAL=CPUMIN 7821C 7822 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'QUT3')THEN 7823 WRITE(ICOUT,999) 7824 999 FORMAT(1X) 7825 CALL DPWRST('XXX','WRIT') 7826 WRITE(ICOUT,51) 7827 51 FORMAT('**** AT THE BEGINNING OF DPQUT3--') 7828 CALL DPWRST('XXX','WRIT') 7829 WRITE(ICOUT,52)IBUGA3,ISUBRO,N,MAXNXT 7830 52 FORMAT('IBUGA3,ISUBRO,N,MAXNXT = ',2(A4,2X),2I8) 7831 CALL DPWRST('XXX','WRIT') 7832 WRITE(ICOUT,53)A1,C1,T1,T2 7833 53 FORMAT('A1,C1,T1,T2 = ',4G15.7) 7834 CALL DPWRST('XXX','WRIT') 7835 DO56I=1,N 7836 WRITE(ICOUT,57)I,Y(I),BLOCK(I),TREAT(I) 7837 57 FORMAT('I,Y(I),BLOCK(I),TREAT(I) = ',I8,3G15.7) 7838 CALL DPWRST('XXX','WRIT') 7839 56 CONTINUE 7840 ENDIF 7841C 7842C ******************************************** 7843C ** STEP 11-- ** 7844C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 7845C ******************************************** 7846C 7847 ISTEPN='11' 7848 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'QUT3') 7849 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7850C 7851 HOLD=Y(1) 7852 DO1135I=2,N 7853 IF(Y(I).NE.HOLD)GOTO1139 7854 1135 CONTINUE 7855 WRITE(ICOUT,999) 7856 CALL DPWRST('XXX','WRIT') 7857 WRITE(ICOUT,1131) 7858 1131 FORMAT('***** ERROR FROM QUADE TEST--') 7859 CALL DPWRST('XXX','WRIT') 7860 WRITE(ICOUT,1133)HOLD 7861 1133 FORMAT(' THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7) 7862 CALL DPWRST('XXX','WRIT') 7863 IERROR='YES' 7864 GOTO9000 7865 1139 CONTINUE 7866C 7867 HOLD=BLOCK(1) 7868 DO1235I=2,N 7869 IF(BLOCK(I).NE.HOLD)GOTO1239 7870 1235 CONTINUE 7871 WRITE(ICOUT,999) 7872 CALL DPWRST('XXX','WRIT') 7873 WRITE(ICOUT,1131) 7874 CALL DPWRST('XXX','WRIT') 7875 WRITE(ICOUT,1231)HOLD 7876 1231 FORMAT(' THE FIRST FACTOR VARIABLE HAS ALL ELEMENTS = ', 7877 1 G15.7) 7878 CALL DPWRST('XXX','WRIT') 7879 IERROR='YES' 7880 GOTO9000 7881 1239 CONTINUE 7882C 7883 HOLD=TREAT(1) 7884 DO1335I=2,N 7885 IF(TREAT(I).NE.HOLD)GOTO1339 7886 1335 CONTINUE 7887 WRITE(ICOUT,999) 7888 CALL DPWRST('XXX','WRIT') 7889 WRITE(ICOUT,1131) 7890 CALL DPWRST('XXX','WRIT') 7891 WRITE(ICOUT,1331)HOLD 7892 1331 FORMAT(' THE SECOND FACTOR VARIABLE HAS ALL ELEMENTS = ', 7893 1 G15.7) 7894 CALL DPWRST('XXX','WRIT') 7895 GOTO9000 7896 1339 CONTINUE 7897C 7898C ****************************** 7899C ** STEP 2-- ** 7900C ** CARRY OUT CALCULATIONS ** 7901C ** FOR QUADE TEST ** 7902C ****************************** 7903C 7904 ISTEPN='2' 7905 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'QUT3') 7906 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7907C 7908C STEP 2A: COMPUTE NUMBER OF DISTINCT BLOCKS AND TREATMENTS 7909C 7910 CALL DISTIN(BLOCK,N,IWRITE,DBLOCK,NBLOCK,IBUGA3,IERROR) 7911 IF(IERROR.EQ.'YES')GOTO9000 7912 IF(NBLOCK.GT.MAXNX2)THEN 7913 WRITE(ICOUT,999) 7914 CALL DPWRST('XXX','BUG ') 7915 WRITE(ICOUT,1131) 7916 CALL DPWRST('XXX','BUG ') 7917 WRITE(ICOUT,1232)NBLOCK,MAXNX2 7918 1232 FORMAT(' THE NUMBER OF BLOCKS (',I8,') IS GREATER ', 7919 1 'THAN',I8) 7920 CALL DPWRST('XXX','BUG ') 7921 IERROR='YES' 7922 GOTO9000 7923 ENDIF 7924 CALL DISTIN(TREAT,N,IWRITE,DTREAT,NTREAT,IBUGA3,IERROR) 7925 IF(IERROR.EQ.'YES')GOTO9000 7926 IF(NTREAT.GT.MAXNX2)THEN 7927 WRITE(ICOUT,999) 7928 CALL DPWRST('XXX','BUG ') 7929 WRITE(ICOUT,1131) 7930 CALL DPWRST('XXX','BUG ') 7931 WRITE(ICOUT,1237)NTREAT,MAXNX2 7932 1237 FORMAT(' THE NUMBER OF TREATMENTS (',I8,') IS GREATER ', 7933 1 'THAN ',I8) 7934 CALL DPWRST('XXX','BUG ') 7935 IERROR='YES' 7936 GOTO9000 7937 ENDIF 7938C 7939C STEP 2B: COMPUTE THE RANGES WITHIN EACH BLOCK 7940C 7941 ISTEPN='2B' 7942 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'QUT3') 7943 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7944C 7945 DO2010I=1,N 7946 YRANK(I)=-1.0D0 7947 2010 CONTINUE 7948C 7949 DO2110I=1,NBLOCK 7950 HOLD=DBLOCK(I) 7951 ICOUNT=0 7952 YMIN=CPUMAX 7953 YMAX=CPUMIN 7954 DO2120J=1,N 7955 IF(BLOCK(J).EQ.HOLD)THEN 7956 ICOUNT=ICOUNT+1 7957 RJ(ICOUNT)=Y(J) 7958 IF(RJ(ICOUNT).LT.YMIN)YMIN=RJ(ICOUNT) 7959 IF(RJ(ICOUNT).GT.YMAX)YMAX=RJ(ICOUNT) 7960 ENDIF 7961 2120 CONTINUE 7962 QRANK(I)=YMAX - YMIN 7963 CALL RANK(RJ,ICOUNT,IWRITE,TEMP1,TEMP2,MAXNX2, 7964 1 IBUGA3,IERROR) 7965 IF(IERROR.EQ.'YES')GOTO9000 7966 ICOUNT=0 7967 DO2130J=1,N 7968 IF(BLOCK(J).EQ.HOLD)THEN 7969 ICOUNT=ICOUNT+1 7970 YRANK(J)=DBLE(TEMP1(ICOUNT)) 7971 ENDIF 7972 2130 CONTINUE 7973 2110 CONTINUE 7974 CALL RANK(QRANK,NBLOCK,IWRITE,TEMP1,TEMP2,MAXNX2,IBUGA3,IERROR) 7975 DO2135I=1,NBLOCK 7976 QRANK(I)=TEMP1(I) 7977 2135 CONTINUE 7978C 7979 AFACT=REAL(NTREAT+1)/2.0 7980 DA2=0.0D0 7981 DO2140I=1,NBLOCK 7982 HOLD=DBLOCK(I) 7983 ICOUNT=0 7984 SJ=0.0D0 7985 DO2150J=1,N 7986 IF(BLOCK(J).EQ.HOLD)THEN 7987 SIJ=QRANK(I)*(YRANK(J) - AFACT) 7988 DA2=DA2 + DBLE(SIJ)**2 7989 ENDIF 7990 2150 CONTINUE 7991 2140 CONTINUE 7992C 7993 DB=0.0D0 7994 DO2160I=1,NTREAT 7995 HOLD=DTREAT(I) 7996 ICOUNT=0 7997 SJ=0.0D0 7998 DO2170J=1,N 7999 IF(TREAT(J).EQ.HOLD)THEN 8000 ITEMP=INT(BLOCK(J)+0.1) 8001 SIJ=QRANK(ITEMP)*(YRANK(J) - AFACT) 8002 SJ=SJ + DBLE(SIJ) 8003 ENDIF 8004 2170 CONTINUE 8005 DB=DB + SJ**2 8006 2160 CONTINUE 8007 DB=DB/DBLE(NBLOCK) 8008C 8009 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'QUT3')THEN 8010 WRITE(ICOUT,2161)DA2,DB,AFACT 8011 2161 FORMAT('DA2,DB,AFACT = ',3G15.7) 8012 CALL DPWRST('XXX','BUG ') 8013 DO2180I=1,N 8014 WRITE(ICOUT,2182)I,Y(I),YRANK(I) 8015 2182 FORMAT('I,Y(I),YRANK(I) = ',I8,G15.7,F12.2) 8016 CALL DPWRST('XXX','BUG ') 8017 2180 CONTINUE 8018 DO2187I=1,NBLOCK 8019 WRITE(ICOUT,2188)I,QRANK(I) 8020 2188 FORMAT('I,QRANK(I) = ',I8,G15.7) 8021 CALL DPWRST('XXX','BUG ') 8022 2187 CONTINUE 8023 ENDIF 8024C 8025C STEP 2C: NOW COMPUTE RANK SUMS FOR EACH TREATMENT 8026C 8027 ISTEPN='2C' 8028 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'QUT3') 8029 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8030C 8031C STEP 4: NOW COMPUTE VARIOUS QUANTITIES 8032C 8033 SSTO=REAL(DA2) 8034 SSTR=REAL(DB) 8035C 8036 IF(DA2.EQ.DB)THEN 8037 ELSE 8038 STATVA=(DBLE(NBLOCK) -1)*DB/(DA2 - DB) 8039 NUMDF1=NTREAT-1 8040 NUMDF2=(NBLOCK-1)*(NTREAT-1) 8041 CALL FCDF(STATVA,NUMDF1,NUMDF2,STATCD) 8042 PVAL=1.0 - STATCD 8043 ENDIF 8044C 8045C ***************** 8046C ** STEP 90-- ** 8047C ** EXIT ** 8048C ***************** 8049C 8050 9000 CONTINUE 8051 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'QUT3')THEN 8052 WRITE(ICOUT,999) 8053 CALL DPWRST('XXX','WRIT') 8054 WRITE(ICOUT,9011) 8055 9011 FORMAT('***** AT THE END OF DPQUT3--') 8056 CALL DPWRST('XXX','WRIT') 8057 WRITE(ICOUT,9012)STATVA,STATCD,PVAL 8058 9012 FORMAT('STATVA,STATCD,PVAL = ',3G15.7) 8059 CALL DPWRST('XXX','WRIT') 8060 ENDIF 8061C 8062 RETURN 8063 END 8064 SUBROUTINE DPRAND(ICASRA,ISEED,ILOCNU,NUMSHA, 8065 1 SHAPE1,SHAPE2,SHAPE3,SHAPE4, 8066 1 SHAPE5,SHAPE6,SHAPE7, 8067 1 IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 8068C 8069C PURPOSE--GENERATE RANDOM NUMBERS 8070C FROM ONE OF THE FOLLOWING DISTRIBUTIONS-- 8071C 1 ) UNIFORM 8072C 2 ) NORMAL 8073C 3 ) LOGISTIC 8074C 4 ) DOUBLE EXPONENTIAL 8075C 5 ) CAUCHY 8076C 6 ) TUKEY LAMBDA 8077C 7 ) LOGNORMAL 8078C 8 ) HALFNORMAL 8079C 9 ) T 8080C 10) CHI-SQUARED 8081C 11) F 8082C 12) EXPONENTIAL 8083C 13) GAMMA 8084C 14) BETA 8085C 15) WEIBULL 8086C 16) EXTREME VALUE TYPE 1 8087C 17) EXTREME VALUE TYPE 2 8088C 18) PARETO 8089C 19) BINOMIAL 8090C 20) GEOMETRIC 8091C 21) POISSON 8092C 22) NEGATIVE BINOMIAL 8093C 23) SEMI-CIRCULAR 8094C 24) TRIANGULAR 8095C 25) INVERSE GAUSSIAN MAY 1990 8096C 26) WALD MAY 1990 8097C 27) RECIPROCAL INVERSE GAUSSIAN MAY 1990 8098C 28) FATIGUE LIFE MAY 1990 8099C 29) GENERALIZED PARETO DECEMBER 1993 8100C 30) POWER FUNCTION APRIL 1995 8101C 31) HYPERGEOMETRIC AUGUST 1995 8102C 32) NON-CENTRAL CHI-SQUARE AUGUST 1995 8103C 33) NON-CENTRAL F AUGUST 1995 8104C 34) DOUBLY NON-CENTRAL F AUGUST 1995 8105C 35) FOLDED NORMAL OCTOBER 1995 8106C 36) HALF-CAUCHY OCTOBER 1995 8107C 37) NORMAL MIXTURE MAY 1998 8108C 38) POWER LAW JUNE 1998 8109C 39) GENERALIZED TUKEY-LAMBDA AUGUST 2001 8110C 40) INVERTED WEIBULL SEPTEMBER 2001 8111C 41) DOUBLE WEIBULL OCTOBER 2001 8112C 42) DOUBLE GAMMA OCTOBER 2001 8113C 43) LOG GAMMA OCTOBER 2001 8114C 44) INVERTED GAMMA OCTOBER 2001 8115C 45) COSINE OCTOBER 2001 8116C 46) ANGLIT OCTOBER 2001 8117C 47) HYPERBOLIC SECANT OCTOBER 2001 8118C 48) ARCSIN OCTOBER 2001 8119C 49) LOG DOUBLE EXPONENTIAL OCTOBER 2001 8120C 50) GENERALIZED EXTREM VALU OCTOBER 2001 8121C 51) EXPONENTIATED WEIBULL OCTOBER 2001 8122C 52) GOMPERTZ OCTOBER 2001 8123C 53) HALF-LOGISTIC OCTOBER 2001 8124C 54) POWER EXPONENTIAL OCTOBER 2001 8125C 55) ALPHA OCTOBER 2001 8126C 56) BRADFORD OCTOBER 2001 8127C 57) RECIPROCAL OCTOBER 2001 8128C 58) JOHNSON SB OCTOBER 2001 8129C 59) JOHNSON SU OCTOBER 2001 8130C 60) POWER NORMAL OCTOBER 2001 8131C 61) LOG-LOGISTIC OCTOBER 2001 8132C 62) GEOMETRIC EXTR EXPO NOVEMBER 2001 8133C 63) POWER LOGNORMAL NOVEMBER 2001 8134C 64) BETA-BINOMIAL DECEMBER 2001 8135C 65) TWO-SIDED POWER MAY 2002 8136C 66) BIWEIBULL MAY 2002 8137C 66) LOGARITHMIC SERIES AUGUST 2002 8138C 67) G-AND-H JANUARY 2003 8139C 68) SLASH JANUARY 2003 8140C 69) LANDAU APRIL 2003 8141C 70) INVERTED BETA MAY 2003 8142C 71) ERROR (=SUBBOTIN MAY 2003 8143C =EXPONENTIAL POWER 8144C =GENERAL ERROR) 8145C 72) TRAPEZOID JUNE 2003 8146C 73) VON MISES JUNE 2003 8147C 74) PARETO SECOND KIND JUNE 2003 8148C 75) WRAPPED CAUCHY JUNE 2003 8149C 76) GENERALIZED TRAPEZOID JUNE 2003 8150C 77) TRUNCATED NORMAL JULY 2003 8151C 78) CHI JULY 2003 8152C 79) FOLDED CAUCHY JULY 2003 8153C 80) MIELKE'S BETA-KAPPA JULY 2003 8154C 81) GENERALIZED EXPONENTIAL JULY 2003 8155C 82) TRUNCATED EXPONENTIAL JULY 2003 8156C 83) GENERALIZED GAMMA SEPTEMBER 2003 8157C 84) FOLDED T NOVEMBER 2003 8158C 85) SKEWED NORMAL NOVEMBER 2003 8159C 86) SKEWED T NOVEMBER 2003 8160C 87) ZIPF NOVEMBER 2003 8161C (RENAME AS ZETA) MAY 2006 8162C 88) GOMPERTZ-MAKEHAM DECEMBER 2003 8163C 89) GENERALIZED INVERSE GAUSSIAN DECEMBER 2003 8164C (NOT ACTIVATED YET) 8165C 90) LOG SKEWED NORMAL MARCH 2004 8166C 91) LOG SKEWED T MARCH 2004 8167C 92) NON-CENTRAL T MARCH 2004 8168C 93) DOUBLY NON-CENTRAL T MARCH 2004 8169C 94) GENERALIZED HALF-LOGISTIC MARCH 2004 8170C 95) GENERALIZED LOGISTIC MARCH 2004 8171C 96) POLYA MARCH 2004 8172C 97) HERMITE APRIL 2004 8173C 98) YULE APRIL 2004 8174C 99) WARING APRIL 2004 8175C 100) GENERALIZED WARING APRIL 2004 8176C 101) NON-CENTRAL BETA MAY 2004 8177C 102) DOUBLY NON-CENTRAL BETA MAY 2004 8178C 103) SKEW DOUBLE EXPONENTIAL JUNE 2004 8179C 104) ASYMMETRIC DOUBLE EXPONENTIAL JUNE 2004 8180C 105) MAXWELL JUNE 2004 8181C 106) RAYLEIGH JUNE 2004 8182C 107) MCLEISH AUGUST 2004 8183C 108) BESSEL I-FUNCTION AUGUST 2004 8184C 109) BESSEL K-FUNCTION AUGUST 2004 (NOT WORK) 8185C 110) GENERALIZED MCLEISH SEPTEMBER 2004 8186C 111) HYPERBOLIC SEPTEMBER 2004 (NOT WORK) 8187C 112) GENERALIZED LOGISTIC TYPE 5 FEBRUARY 2006 8188C 113) WAKEBY FEBRUARY 2006 8189C 114) BETA NORMAL MARCH 2006 8190C 115) GENERALIZED LOGISTIC TYPE 2 MARCH 2006 8191C 116) GENERALIZED LOGISTIC TYPE 3 MARCH 2006 8192C 117) GENERALIZED LOGISTIC TYPE 4 MARCH 2006 8193C 118) ASYMMETRIC LOG DOUBLE EXPONENTIAL MARCH 2006 8194C 119) BETA GEOMETRIC MAY 2006 8195C 120) BOREL TANNER MAY 2006 8196C 121) LAGRANGE POISSON JUNE 2006 8197C 122) LEADS IN COIN TOSSING JUNE 2006 8198C (DISCRETE ARCSINE) 8199C 123) MATCHING JUNE 2006 8200C 124) CLASSICAL OCCUPANCY JUNE 2006 (NOT ACTIVE) 8201C 125) LOG BETA JUNE 2006 8202C 126) POLYA AEPPLI JUNE 2006 8203C 127) LOST GAMES JUNE 2006 8204C 128) NEYMAN TYPE A JUNE 2006 (NOT ACTIVE) 8205C 129) DXG JUNE 2006 (NOT ACTIVE) 8206C 130) GENERALIZED LOGARITHMIC SERIES JUNE 2006 8207C 131) GENERALIZED NEGATIVE BINOMIAL JULY 2006 8208C 132) GEETA JULY 2006 8209C 133) QUASI BINOMIAL TYPE I JULY 2006 8210C 134) CONSUL AUGUST 2006 8211C 135) DISCRETE WEIBULL NOVEMBER 2006 8212C 136) GENERALIZED LOST GAMES NOVEMBER 2006 8213C 137) TRUNCATED GENERALIZED 8214C NEGATIVE BINOMIAL JANUARY 2006 8215C 138) KATZ JANUARY 2007 8216C 139) TOPP AND LEONE FEBRUARY 2007 8217C 140) GENERALIZED TOPP AND LEONE FEBRUARY 2007 8218C 141) REFLECTED GENERALIZED TOPP AND LEONE FEBRUARY 2007 8219C 142) LAGRANGE KATZ FEBRUARY 2007 (NOT ACTIVE) 8220C 143) SLOPE SEPTEMBER 2007 8221C 144) OGIVE SEPTEMBER 2007 8222C 145) TWO-SIDED SLOPE SEPTEMBER 2007 8223C 146) TWO-SIDED OGIVE SEPTEMBER 2007 8224C 147) UNEVEN TWO-SIDED POWER OCTOBER 2007 8225C 148) DOUBLY UNIFORM PARETO OCTOBER 2007 8226C 149) BURR TYPE 1 (= UNIFORM) OCTOBER 2007 8227C 150) BURR TYPE 2 OCTOBER 2007 8228C 151) BURR TYPE 3 OCTOBER 2007 8229C 152) BURR TYPE 4 OCTOBER 2007 8230C 153) BURR TYPE 5 OCTOBER 2007 8231C 154) BURR TYPE 6 OCTOBER 2007 8232C 155) BURR TYPE 7 OCTOBER 2007 8233C 156) BURR TYPE 8 OCTOBER 2007 8234C 157) BURR TYPE 9 OCTOBER 2007 8235C 158) BURR TYPE 10 OCTOBER 2007 8236C 159) BURR TYPE 11 OCTOBER 2007 8237C 160) BURR TYPE 12 OCTOBER 2007 8238C 160) KUMARASWAMY OCTOBER 2007 8239C 161) REFLECTED POWER DECEMBER 2007 8240C 162) MUTH JANUARY 2008 8241C 163) LOGISTIC-EXPONENTIAL FEBRUARY 2008 8242C 164) TRUNCATED PARETO MARCH 2008 8243C 165) BRITTLE FRACTURE MARCH 2008 8244C 166) 3-PARAMETER LOGISTIC-EXPONENTIAL MARCH 2008 8245C 167) BOOTSTRAP INDEX DECEMBER 1988 8246C 168) RANDOM PERMUTATION DECEMBER 1988 8247C 169) RANDOM SUBSET APRIL 2008 8248C 170) RANDOM K-SET OF N-SET APRIL 2008 8249C 171) RANDOM COMPOSITION APRIL 2008 8250C 172) KAPPA MAY 2008 8251C 173) PEARSON TYPE 3 MAY 2008 8252C 174) RANDOM PARTITION JUNE 2008 8253C 175) RANDOM EQUIVALENCE RELA JUNE 2008 8254C 176) RANDOM YOUNG TABLEAUX JULY 2008 8255C 177) END EFFECTS WEIBULL JULY 2010 8256C 178) BRITTLE FIBER WEIBULL AUGUST 2010 8257C 179) ARCTANGENT JANUARY 2011 8258C 180) SINE MARCH 2013 8259C 181) EXCLUSION ZONE UNIFORM MARCH 2013 8260C 8261C WRITTEN BY--JAMES J. FILLIBEN 8262C STATISTICAL ENGINEERING DIVISION 8263C INFORMATION TECHNOLOGY LABORATORY 8264C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 8265C GAITHERSBURG, MD 20899-8980 8266C PHONE--301-975-2855 8267C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 8268C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 8269C LANGUAGE--ANSI FORTRAN (1977) 8270C VERSION NUMBER--82/7 8271C ORIGINAL VERSION--APRIL 1978. 8272C UPDATED --MAY 1978. 8273C UPDATED --JUNE 1978. 8274C UPDATED --MAY 1978. 8275C UPDATED --NOVEMBER 1978. 8276C UPDATED --JUNE 1981. 8277C UPDATED --SEPTEMBER 1981. 8278C UPDATED --OCTOBER 1981. 8279C UPDATED --MARCH 1982. 8280C UPDATED --MAY 1982. 8281C UPDATED --DECEMBER 1988. DISCRETE UNIFORM 8282C UPDATED --DECEMBER 1988. BOOTSTRAP INDEX 8283C UPDATED --DECEMBER 1988. RANDOM PERMUTATION 8284C UPDATED --JANUARY 1989. JACKNIFE INDEX 8285C UPDATED --MAY 1993. MINMAX FOR EV1/EV2/WEIB DIST. 8286C UPDATED --OCTOBER 1993. JACKNIFE INDEX TO DPMATC 8287C UPDATED --DECEMBER 1993. GENERALIZED PARETO 8288C UPDATED --MARCH 1994. DPCOS2.INC 8289C UPDATED --APRIL 1995. POWER FUNCTION 8290C UPDATED --AUGUST 1995. HYPERGEOMETRIC, NON-CENTRAL 8291C CHI-SQUARE, SINGLY AND DOUBLY 8292C NON-CENTRAL F 8293C UPDATED --MAY 1998. NORMAL MIXTURE 8294C UPDATED --JUNE 1998. POWER LAW 8295C UPDATED --AUGUST 2001. GENERALIZED LAMBDA 8296C UPDATED --SEPTEMBER 2001. INVERTED WEIBULL 8297C UPDATED --OCTOBER 2001. DOUBLE WEIBULL 8298C UPDATED --OCTOBER 2001. DOUBLE GAMMA 8299C UPDATED --OCTOBER 2001. LOG GAMMA 8300C UPDATED --OCTOBER 2001. INVERTED GAMMA 8301C UPDATED --OCTOBER 2001. COSINE 8302C UPDATED --OCTOBER 2001. ANGLIT 8303C UPDATED --OCTOBER 2001. HYPERBOLIC SECANT 8304C UPDATED --OCTOBER 2001. ARCSIN 8305C UPDATED --OCTOBER 2001. LOG DOUBLE EXPONENTIAL 8306C UPDATED --OCTOBER 2001. GENERALIZED EXTREME VALUE 8307C UPDATED --OCTOBER 2001. EXPONENTIATED WEIBULL 8308C UPDATED --OCTOBER 2001. GOMPERTZ 8309C UPDATED --OCTOBER 2001. HALF-LOGISTIC 8310C UPDATED --OCTOBER 2001. POWER EXPONENTIAL 8311C UPDATED --OCTOBER 2001. ALPHA 8312C UPDATED --OCTOBER 2001. BRADFORD 8313C UPDATED --OCTOBER 2001. RECIPROCAL 8314C UPDATED --OCTOBER 2001. JOHNSON SU 8315C UPDATED --OCTOBER 2001. JOHNSON SB 8316C UPDATED --OCTOBER 2001. POWER NORMAL 8317C UPDATED --OCTOBER 2001. LOG-LOGISTIC 8318C UPDATED --NOVEMBER 2001. GEOMETRIC EXTREME EXPO 8319C UPDATED --NOVEMBER 2001. POWER LOGNORMAL 8320C UPDATED --DECEMBER 2001. BETA-BINOMIAL 8321C UPDATED --MAY 2002. TWO-SIDED POWER 8322C UPDATED --MAY 2002. BIWEIBULL 8323C UPDATED --AUGUST 2002. LOGARITHMIC SERIES 8324C UPDATED --JANUARY 2003. G-AND-H, SLASH 8325C UPDATED --APRIL 2003. ADD SHAPE PARAMETER FOR 8326C LOGNORMAL 8327C UPDATED --APRIL 2003. LANDAU 8328C UPDATED --MAY 2003. INVERTED BETA 8329C UPDATED --MAY 2003. ERROR (=SUBBOTIN=EXPOENTIAL 8330C POWER=GENERAL ERROR) 8331C UPDATED --JUNE 2003. TRAPEZOID, VON MISES, 8332C PARETO SECOND KIND, 8333C WRAPPED CAUCHY, 8334C GENERALIZED TRAPEZOID 8335C UPDATED --JULY 2003. CHI, TRUNCATED NORMAL, 8336C FOLDED CAUCHY, 8337C MIELKE'S BETA-KAPPA, 8338C GENERALIZED EXPONENTIAL, 8339C TRUNCATED EXPONENTIAL 8340C UPDATED --SEPTEMBER 2003. GENERALIZED GAMMA 8341C UPDATED --NOVEMBER 2003. FOLDED T 8342C UPDATED --NOVEMBER 2003. SKEWED NORMAL 8343C UPDATED --NOVEMBER 2003. SKEWED T 8344C UPDATED --NOVEMBER 2003. ZIPF 8345C UPDATED --DECEMBER 2003. GOMPERTZ-MAKEHAM 8346C UPDATED --DECEMBER 2003. GENERALIZED INVERSE GAUSSIAN 8347C (NOT IMPLEMENTED YET) 8348C UPDATED --MARCH 2004. LOG SKEWED NORMAL 8349C UPDATED --MARCH 2004. LOG SKEWED T 8350C UPDATED --MARCH 2004. ALTERNATE DEFINITION OF 8351C GEOMETRIC 8352C UPDATED --MARCH 2004. NON-CENTRAL T 8353C UPDATED --MARCH 2004. DOUBLY NON-CENTRAL T 8354C UPDATED --MARCH 2004. GENERALIZED HALF-LOGISTIC 8355C UPDATED --MARCH 2004. GENERALIZED LOGISTIC 8356C UPDATED --MARCH 2004. POLYA 8357C UPDATED --APRIL 2004. HERMITE 8358C UPDATED --APRIL 2004. YULE 8359C UPDATED --APRIL 2004. WARING 8360C UPDATED --APRIL 2004. GENERALIZED WARING 8361C UPDATED --MAY 2004. NON-CENTRAL BETA 8362C UPDATED --MAY 2004. DOUBLY NON-CENTRAL BETA 8363C UPDATED --MAY 2004. REAL VALUES FOR CHI-SQUARE 8364C RANDOM NUMBERS 8365C UPDATED --MAY 2004. NON-CENTRAL CHI-SQUARE AS 8366C SEPARATE SUBROUTINE 8367C UPDATED --JUNE 2004. SKEW DOUBLE EXPONENTIAL 8368C UPDATED --JUNE 2004. ASYMMETRIC DOUBLE EXPONENTIAL 8369C UPDATED --JUNE 2004. ARGUMENT LIST TO GEPRAN 8370C UPDATED --JUNE 2004. MAXWELL, RAYLEIGH 8371C UPDATED --JULY 2004. ALTERNATE DEFINITIION FOR 8372C GOMPERTZ-MAKEHAM 8373C UPDATED --OCTOBER 2004. FOR PARETO, TREAT A AS A 8374C SHAPE PARAMETER 8375C UPDATED --JULY 2005. CALL LIST TO LGARAN AND SNRAN 8376C UPDATED --FEBRUARY 2006. GENERALIZED LOGISTIC TYPE 5 8377C UPDATED --FEBRUARY 2006. WAKEBY 8378C UPDATED --FEBRUARY 2006. ARGUMENT LIST TO GLDRAN 8379C UPDATED --MARCH 2006. BETA-NORMAL 8380C UPDATED --MARCH 2006. GENERALIZED LOGISTIC TYPE 2 8381C UPDATED --MARCH 2006. GENERALIZED LOGISTIC TYPE 3 8382C UPDATED --MARCH 2006. GENERALIZED LOGISTIC TYPE 4 8383C UPDATED --MARCH 2006. ASYMMETRIC DOUBLE EXPONENTIAL 8384C UPDATED --MAY 2006. BETA GEOMETRIC 8385C UPDATED --MAY 2006. RENAME ZIPF AS ZETA 8386C UPDATED --MAY 2006. BOREL-TANNER 8387C UPDATED --MAY 2006. BETA-NEGATIVE BINOMIAL AS 8388C SYNOMYM FOR GENERALIZED 8389C WARING 8390C UPDATED --JUNE 2006. LAGRANGE-POISSON 8391C UPDATED --JUNE 2006. LEADS IN COIN TOSSING 8392C UPDATED --JUNE 2006. MATCHING 8393C UPDATED --JUNE 2006. CLASSICAL OCCUPANCY 8394C UPDATED --JUNE 2006. LOG BETA 8395C UPDATED --JUNE 2006. GENERALIZED LOGARITHMIC 8396C SERIES 8397C UPDATED --JULY 2006. GENERALIZED NEGATIVE 8398C BINOMIAL 8399C UPDATED --JULY 2006. GEETA 8400C UPDATED --JULY 2006. QUASI BINOMIAL TYPE 1 8401C UPDATED --AUGUST 2006. CONSUL 8402C UPDATED --AUGUST 2006. LAGRANGE KATZ 8403C UPDATED --SEPTEMBER 2006. KATZ 8404C UPDATED --OCTOBER 2006. FRACTIONAL DEGREES OF 8405C FREEDOM FOR T DISTRIBUTION 8406C UPDATED --NOVEMBER 2006. DISCRETE WEIBULL 8407C UPDATED --NOVEMBER 2006. GENERALIZED LOST GAMES 8408C UPDATED --FEBRUARY 2007. TOPP AND LEONE 8409C UPDATED --FEBRUARY 2007. GENERALIZED TOPP AND LEONE 8410C UPDATED --FEBRUARY 2007. REFLECTED GENERALIZED TOPP 8411C AND LEONE 8412C UPDATED --SEPTEMBER 2007. SLOPE 8413C UPDATED --SEPTEMBER 2007. OGIVE 8414C UPDATED --SEPTEMBER 2007. TWO-SIDED SLOPE 8415C UPDATED --SEPTEMBER 2007. TWO-SIDED OGIVE 8416C UPDATED --OCTOBER 2007. BURR TYPE 1 (= UNIFORM) 8417C UPDATED --OCTOBER 2007. BURR TYPE 2 8418C UPDATED --OCTOBER 2007. BURR TYPE 3 8419C UPDATED --OCTOBER 2007. BURR TYPE 4 8420C UPDATED --OCTOBER 2007. BURR TYPE 5 8421C UPDATED --OCTOBER 2007. BURR TYPE 6 8422C UPDATED --OCTOBER 2007. BURR TYPE 7 8423C UPDATED --OCTOBER 2007. BURR TYPE 8 8424C UPDATED --OCTOBER 2007. BURR TYPE 9 8425C UPDATED --OCTOBER 2007. BURR TYPE 10 8426C UPDATED --OCTOBER 2007. BURR TYPE 11 8427C UPDATED --OCTOBER 2007. BURR TYPE 12 8428C UPDATED --OCTOBER 2007. DOUBLY PARETO UNIFORM 8429C UPDATED --OCTOBER 2007. KUMARASWAMY 8430C UPDATED --DECEMBER 2007. REFLECTED POWER 8431C UPDATED --JANUARY 2008. MUTH 8432C UPDATED --FEBRUARY 2008. LOGISTIC-EXPONENTIAL 8433C UPDATED --FEBRUARY 2008. TRUNCATED PARETO 8434C UPDATED --MARCH 2008. BRITTLE FRACTURE 8435C UPDATED --MARCH 2008. 3-PARAMETER LOGISTIC-EXPONENTIAL 8436C UPDATED --APRIL 2008. RANDOM SUBSET 8437C UPDATED --APRIL 2008. RANDOM K-SET OF N-SET 8438C UPDATED --APRIL 2008. RANDOM COMPOSITION 8439C UPDATED --MAY 2008. RENAME CALL FOR MIELKE'S 8440C BETA-KAPPA, BETA PARAMETER IS 8441C ACTUALLY A SCALE PARAMETER 8442C UPDATED --MAY 2008. KAPPA 8443C UPDATED --MAY 2008. PEARSON TYPE 3 8444C UPDATED --MAY 2008. RANDOM PARTITION 8445C UPDATED --JUNE 2008. RANDOM EQUIVALENCE RELATION 8446C UPDATED --JULY 2008. RANDOM YOUNG TABLEAUX 8447C UPDATED --JULY 2008. MODIFY GIG PARAMETERIZATION 8448C UPDATED --SEPTEMBER 2009. USE EXTPA1 8449C UPDATED --SEPTEMBER 2009. EXTRACT MOST OF THE CALLS 8450C TO RANDOM NUMBER ROUTINES TO 8451C "DPRAN2" TO ENABLE EASIER 8452C CALLING BY OTHER ROUTINES 8453C (E.G., THE BOOTSTRAP COMMAND) 8454C UPDATED --JULY 2010. END EFFECTS WEIBULL 8455C UPDATED --AUGUST 2010. BRITTLE FIBER WEIBULL 8456C UPDATED --JANUARY 2011. ARCTANGENT 8457C UPDATED --MARCH 2013. SINE 8458C UPDATED --MARCH 2013. EXCLUSION ZONE UNIFORM 8459C 8460C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 8461C 8462 CHARACTER*4 ICASRA 8463 CHARACTER*4 IBUGA3 8464 CHARACTER*4 ISUBRO 8465 CHARACTER*4 IBUGQ 8466 CHARACTER*4 IFOUND 8467 CHARACTER*4 IERROR 8468C 8469 CHARACTER*4 NEWNAM 8470 CHARACTER*4 NEWCOL 8471 CHARACTER*4 MESSAG 8472 CHARACTER*4 ICASEQ 8473 CHARACTER*4 IHWUSE 8474 CHARACTER*4 IHP 8475 CHARACTER*4 IHP2 8476 CHARACTER*4 ILEFT 8477 CHARACTER*4 ILEFT2 8478 CHARACTER*4 IHRIGH 8479 CHARACTER*4 IHRIG2 8480 CHARACTER*4 ISUBN1 8481 CHARACTER*4 ISUBN2 8482 CHARACTER*4 ISTEPN 8483C 8484 CHARACTER*60 IDIST 8485C 8486C-----COMMON---------------------------------------------------------- 8487C 8488 INCLUDE 'DPCOPA.INC' 8489 INCLUDE 'DPCOHK.INC' 8490 INCLUDE 'DPCODA.INC' 8491 INCLUDE 'DPCOSU.INC' 8492 INCLUDE 'DPCOS2.INC' 8493 INCLUDE 'DPCOST.INC' 8494C 8495 REAL TEMP3(MAXOBV) 8496 REAL TEMP4(MAXOBV) 8497 INTEGER ITEMP1(MAXOBV) 8498 INTEGER ITEMP2(MAXOBV) 8499 INTEGER ITEMP4(MAXOBV) 8500 INCLUDE 'DPCOZI.INC' 8501 INCLUDE 'DPCOZZ.INC' 8502 EQUIVALENCE (IGARBG(IIGAR1),ITEMP1) 8503 EQUIVALENCE (IGARBG(IIGAR2),ITEMP2) 8504 EQUIVALENCE (IGARBG(IIGAR4),ITEMP4) 8505 EQUIVALENCE (GARBAG(IGARB1),TEMP3) 8506 EQUIVALENCE (GARBAG(IGARB2),TEMP4) 8507C 8508 COMMON/NIJWIL/NLAST,KLAST 8509C 8510C-----COMMON VARIABLES (GENERAL)-------------------------------------- 8511C 8512 INCLUDE 'DPCOP2.INC' 8513C 8514C-----DATA STATEMENTS------------------------------------------------- 8515C 8516CCCCC DATA EPS/0.000001/ 8517CCCCC DATA ALAMLG/0.00001/ 8518C 8519C-----START POINT----------------------------------------------------- 8520C 8521 ISUBN1='DPRA' 8522 ISUBN2='ND ' 8523 IFOUND='NO' 8524 IERROR='NO' 8525 IFOUND='YES' 8526C 8527 MAXCP1=MAXCOL+1 8528 MAXCP2=MAXCOL+2 8529 MAXCP3=MAXCOL+3 8530 MAXCP4=MAXCOL+4 8531 MAXCP5=MAXCOL+5 8532 MAXCP6=MAXCOL+6 8533C 8534 NS2=0 8535 NRAN=0 8536 RANLOC=0.0 8537 RANSCA=1.0 8538C 8539C *********************************************** 8540C ** TREAT THE RANDOM NUMBER GENERATION CASE ** 8541C ** 1) FOR A FULL VARIABLE, OR ** 8542C ** 2) FOR PART OF A VARIABLE. ** 8543C *********************************************** 8544C 8545 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RAND')THEN 8546 WRITE(ICOUT,999) 8547 999 FORMAT(1X) 8548 CALL DPWRST('XXX','BUG ') 8549 WRITE(ICOUT,51) 8550 51 FORMAT('***** AT THE BEGINNING OF DPRAND--') 8551 CALL DPWRST('XXX','BUG ') 8552 WRITE(ICOUT,52)IBUGA3,IBUGQ 8553 52 FORMAT('IBUGA3,IBUGQ = ',A4,2X,A4) 8554 CALL DPWRST('XXX','BUG ') 8555 WRITE(ICOUT,53)ICASRA,ISEED,ILOCNU,MINMAX 8556 53 FORMAT('ICASRA,ISEED,ILOCNU,MINMAX = ',A4,3I8) 8557 CALL DPWRST('XXX','BUG ') 8558 ENDIF 8559C 8560C ********************************** 8561C ** STEP 1-- ** 8562C ** INITIALIZE SOME VARIABLES. ** 8563C ********************************** 8564C 8565 ISTEPN='1' 8566 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RAND') 8567 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8568C 8569 NEWNAM='NO' 8570 NEWCOL='NO' 8571C 8572C ******************************************************* 8573C ** STEP 2-- ** 8574C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** 8575C ******************************************************* 8576C 8577 ISTEPN='2' 8578 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RAND') 8579 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8580C 8581 MINNA=3 8582 MAXNA=100 8583 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 8584 1IERROR) 8585 IF(IERROR.EQ.'YES')GOTO9000 8586C 8587C ******************************************************** 8588C ** STEP 3-- * 8589C ** EXAMINE THE LEFT-HAND SIDE-- * 8590C ** IS THE PARAMETER OR VARIABLE NAME TO LEFT OF = * 8591C ** SIGN ALREADY IN THE NAME LIST? * 8592C ** NOTE THAT ILEFT IS THE NAME OF THE * 8593C ** VARIABLE ON THE LEFT. * 8594C ** NOTE THAT ILISTL IS THE LINE IN THE TABLE * 8595C ** OF THE NAME ON THE LEFT. * 8596C ** NOTE THAT ICOLL IS THE DATA COLUMN (1 TO 12)* 8597C ** FOR THE NAME OF THE LEFT. * 8598C ******************************************************** 8599C 8600 ISTEPN='3' 8601 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RAND') 8602 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8603C 8604 ILEFT=IHARG(1) 8605 ILEFT2=IHARG2(1) 8606 DO310I=1,NUMNAM 8607 I2=I 8608 IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND. 8609 1 IUSE(I).EQ.'P')THEN 8610 ILISTL=I2 8611 GOTO330 8612 ELSEIF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND. 8613 1 IUSE(I).EQ.'V')THEN 8614 ILISTL=I2 8615 ICOLL=IVALUE(ILISTL) 8616 NLEFT=IN(ILISTL) 8617 GOTO390 8618 ENDIF 8619 310 CONTINUE 8620 NEWNAM='YES' 8621 ILISTL=NUMNAM+1 8622 IF(ILISTL.GT.MAXNAM)THEN 8623 WRITE(ICOUT,999) 8624 CALL DPWRST('XXX','BUG ') 8625 WRITE(ICOUT,321) 8626 321 FORMAT('***** ERROR IN DPRAND--') 8627 CALL DPWRST('XXX','BUG ') 8628 WRITE(ICOUT,322) 8629 322 FORMAT(' THE NUMBER OF VARIABLE AND/OR PARAMETER NAMES') 8630 CALL DPWRST('XXX','BUG ') 8631 WRITE(ICOUT,323)MAXNAM 8632 323 FORMAT(' HAS JUST EXCEEDED THE MAXIMUM ALLOWABLE ',I8,'.') 8633 CALL DPWRST('XXX','BUG ') 8634 WRITE(ICOUT,324) 8635 324 FORMAT(' SUGGESTED ACTION--') 8636 CALL DPWRST('XXX','BUG ') 8637 WRITE(ICOUT,325) 8638 325 FORMAT(' ENTER STATUS') 8639 CALL DPWRST('XXX','BUG ') 8640 WRITE(ICOUT,326) 8641 326 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES, AND') 8642 CALL DPWRST('XXX','BUG ') 8643 WRITE(ICOUT,327) 8644 327 FORMAT(' THEN REDEFINE (REUSE) SOME OF THE ALREADY USED ', 8645 1 'NAMES.') 8646 CALL DPWRST('XXX','BUG ') 8647 IERROR='YES' 8648 GOTO9000 8649 ENDIF 8650C 8651 330 CONTINUE 8652 NLEFT=0 8653 ICOLL=NUMCOL+1 8654 IF(ICOLL.GT.MAXCOL)THEN 8655 WRITE(ICOUT,321) 8656 CALL DPWRST('XXX','BUG ') 8657 WRITE(ICOUT,342) 8658 342 FORMAT(' THE NUMBER OF DATA COLUMNS HAS JUST EXCEEDED') 8659 CALL DPWRST('XXX','BUG ') 8660 WRITE(ICOUT,343)MAXCOL 8661 343 FORMAT(' THE MAXIMUM ALLOWABLE ',I8,'. SUGGESTED ', 8662 1 'ACTION--') 8663 CALL DPWRST('XXX','BUG ') 8664 WRITE(ICOUT,325) 8665 CALL DPWRST('XXX','BUG ') 8666 WRITE(ICOUT,326) 8667 CALL DPWRST('XXX','BUG ') 8668 WRITE(ICOUT,347) 8669 347 FORMAT(' THEN DELETE SOME OF THE ALREADY USED NAMES.') 8670 CALL DPWRST('XXX','BUG ') 8671 IERROR='YES' 8672 GOTO9000 8673 ENDIF 8674C 8675 390 CONTINUE 8676C 8677C ******************************************************* 8678C ** STEP 4-- ** 8679C ** CHECK THAT THE INPUT CASE (ICASRA) ** 8680C ** IS ONE OF THE ALLOWABLE 100+ DISTRIBUTIONS ** 8681C ******************************************************* 8682C 8683 ISTEPN='2' 8684 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RAND') 8685 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8686C 8687C ***************************************** 8688C ** STEP 6-- ** 8689C ** CHECK TO SEE THE TYPE SUBCASE ** 8690C ** (BASED ON THE QUALIFIER) ** 8691C ** 1) UNQUALIFIED (THAT IS, FULL); ** 8692C ** 2) SUBSET/EXCEPT; OR ** 8693C ** 3) FOR. ** 8694C ***************************************** 8695C 8696 ISTEPN='6' 8697 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RAND') 8698 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8699C 8700C APRIL 2008: CHECK FOR "SUBSET" CONFLICT WITH "RANDOM SUBSET" 8701C CASE. 8702C 8703C MAY 2008: RANDOM PARTITION AND RANDOM EQUIVALENCE CLASS 8704C COMMANDS DO NOT USE THE TYPICAL 8705C "FOR I = 1 1 N" CLAUSE. 8706C 8707C JULY 2008: RANDOM YOUNG TABLEAUX USES SYNTAX: 8708C 8709C LET N = <VALUE> 8710C LET Y = RANDOM YOUNG TABLEAUX LAMBDA 8711C 8712C WHERE LAMBDA IS AN ARRAY DEFINING THE PARTITION 8713C 8714 IF(ICASRA.EQ.'RANP' .OR. ICASRA.EQ.'RANE')GOTO750 8715C 8716 IF(ICASRA.EQ.'RAYT')THEN 8717 IHRIGH=IHARG(6) 8718 IHRIG2=IHARG2(6) 8719 IHWUSE='V' 8720 MESSAG='YES' 8721 CALL CHECKN(IHRIGH,IHRIG2,IHWUSE, 8722 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 8723 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 8724 IF(IERROR.EQ.'YES')GOTO9000 8725 ICOLR=IVALUE(ILOCV) 8726 NLEFT=IN(ILOCV) 8727 J=0 8728 DO701I=1,NLEFT 8729 J=J+1 8730 IJ=MAXN*(ICOLR-1)+I 8731 IF(ICOLR.LE.MAXCOL)TEMP4(J)=V(IJ) 8732 IF(ICOLR.EQ.MAXCP1)TEMP4(J)=PRED(I) 8733 IF(ICOLR.EQ.MAXCP2)TEMP4(J)=RES(I) 8734 IF(ICOLR.EQ.MAXCP3)TEMP4(J)=YPLOT(I) 8735 IF(ICOLR.EQ.MAXCP4)TEMP4(J)=XPLOT(I) 8736 IF(ICOLR.EQ.MAXCP5)TEMP4(J)=X2PLOT(I) 8737 IF(ICOLR.EQ.MAXCP6)TEMP4(J)=TAGPLO(I) 8738 701 CONTINUE 8739 GOTO750 8740 ENDIF 8741C 8742 ICASEQ='FULL' 8743 ILOCQ=NUMARG+1 8744 IF(NUMARG.LT.1)GOTO670 8745 DO610J=1,NUMARG 8746 J1=J 8747 IF(ICASRA.NE.'SUBS')THEN 8748 IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO620 8749 ELSE 8750 IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET '.AND. 8751 1 IHARG(J+1).EQ.'SUBS'.AND.IHARG2(J+1).EQ.'ET ')THEN 8752 J1=J+1 8753 GOTO620 8754 ENDIF 8755 ENDIF 8756 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO620 8757 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO630 8758 610 CONTINUE 8759 GOTO680 8760C 8761 620 CONTINUE 8762 ICASEQ='SUBS' 8763 ILOCQ=J1 8764 GOTO680 8765C 8766 630 CONTINUE 8767 ICASEQ='FOR' 8768 ILOCQ=J1 8769 GOTO680 8770C 8771 670 CONTINUE 8772 WRITE(ICOUT,999) 8773 CALL DPWRST('XXX','BUG ') 8774 WRITE(ICOUT,671) 8775 671 FORMAT('***** INTERNAL ERROR IN DPRAND') 8776 CALL DPWRST('XXX','BUG ') 8777 WRITE(ICOUT,672) 8778 672 FORMAT(' AT BRANCH POINT 5081--') 8779 CALL DPWRST('XXX','BUG ') 8780 WRITE(ICOUT,673) 8781 673 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') 8782 CALL DPWRST('XXX','BUG ') 8783 WRITE(ICOUT,674) 8784 674 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') 8785 CALL DPWRST('XXX','BUG ') 8786 WRITE(ICOUT,675)NUMARG 8787 675 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) 8788 CALL DPWRST('XXX','BUG ') 8789 WRITE(ICOUT,676) 8790 676 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') 8791 CALL DPWRST('XXX','BUG ') 8792 IF(IWIDTH.GE.1)THEN 8793 WRITE(ICOUT,677)(IANS(I),I=1,MIN(80,IWIDTH)) 8794 677 FORMAT(80A1) 8795 CALL DPWRST('XXX','BUG ') 8796 ENDIF 8797 IERROR='YES' 8798 GOTO9000 8799C 8800 680 CONTINUE 8801 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RAND')THEN 8802 WRITE(ICOUT,681)NUMARG,ILOCQ,ICASEQ 8803 681 FORMAT('NUMARG,ILOCQ,ICASEQ = ',2I8,2X,A4) 8804 CALL DPWRST('XXX','BUG ') 8805 ENDIF 8806C 8807C ****************************************************** 8808C ** STEP 7-- ** 8809C ** BRANCH TO THE APPROPRIATE SUBCASE ** 8810C ** (BASED ON THE QUALIFIER); ** 8811C ** DETERMINE THE NUMBER (= NRAN) ** 8812C ** OF RANDOM NUMBERS TO BE GENERATED. ** 8813C ** NOTE THAT THE VARIABLE NIISUB ** 8814C ** IS THE LENGTH OF THE RESULTING ** 8815C ** VARIABLE ISUB(.). ** 8816C ** NOTE THAT DPFOR AUTOMATICALLY EXTENDS ** 8817C ** THE INPUT LENGTH OF ISUB(.) IF NECESSARY. ** 8818C ** (HENCE THE REDEFINITION OF NIISUB TO NINEW ** 8819C ** AFTER THE CALL TO DPFOR. ** 8820C ****************************************************** 8821C 8822 ISTEPN='7' 8823 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RAND') 8824 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8825C 8826CCCCC OCTOBER 1993. JACKNIFE INDEX TO DPMATC. 8827CCCCC IF(ICASRA.EQ.'JACK')GOTO1280 8828 IF(ICASEQ.EQ.'SUBS')THEN 8829 NIISUB=MAXN 8830 CALL DPSUBS(NIISUB,ILOCS,NS,IBUGQ,IERROR) 8831 NRAN=NS 8832 ELSEIF(ICASEQ.EQ.'FOR')THEN 8833 IF(NEWNAM.EQ.'NO')NIISUB=NLEFT 8834 IF(NEWNAM.EQ.'YES')NIISUB=MAXN 8835 CALL DPFOR(NIISUB,NINEW,IROW1,IROWN, 8836 1 NLOCAL,ILOCS,NS,IBUGQ,IERROR) 8837 NIISUB=NINEW 8838 NRAN=NS 8839 ELSE 8840 IF(NEWNAM.EQ.'NO')NIISUB=NLEFT 8841 IF(NEWNAM.EQ.'YES')NIISUB=MAXN 8842 DO715I=1,NIISUB 8843 ISUB(I)=1 8844 715 CONTINUE 8845 NRAN=NIISUB 8846 ENDIF 8847C 8848 750 CONTINUE 8849C 8850 IF(NRAN.LT.1)THEN 8851 WRITE(ICOUT,321) 8852 CALL DPWRST('XXX','BUG ') 8853 WRITE(ICOUT,762) 8854 762 FORMAT(' THE SPECIFIED NUMBER OF RANDOM ITEMS MUST BE ', 8855 1 '1 OR LARGER.') 8856 CALL DPWRST('XXX','BUG ') 8857 WRITE(ICOUT,769)NRAN 8858 769 FORMAT(' THE SPECIFIED NUMBER OF ITEMS = ',I8) 8859 CALL DPWRST('XXX','BUG ') 8860 GOTO9000 8861 ENDIF 8862C ****************************************** 8863C ** STEP 8-- ** 8864C ** GENERATE NRAN RANDOM NUMBERS ** 8865C ** FROM THE SPECIFIED DISTRIBUTION. ** 8866C ** STORE THEM TEMPORARILY IN ** 8867C ** THE VECTOR Y(.). ** 8868C ****************************************** 8869C 8870 ISTEPN='8' 8871 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RAND') 8872 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8873C 8874C MARCH 2013: EXCLUSION ZONE UNIFORM IS A SPECIAL CASE THAT 8875C IS NOT RECOGNIZED IN EXTDIS AND EXTPA1. 8876C 8877 IF(NUMSHA.GE.1)THEN 8878 CALL EXTPA1(ICASRA,IDIST,A,B, 8879 1 SHAPE1,SHAPE2,SHAPE3,SHAPE4, 8880 1 SHAPE5,SHAPE6,SHAPE7, 8881 1 IADEDF,IGEPDF,IMAKDF,IBEIDF, 8882 1 ILGADF,ISKNDF,IGLDDF,IBGEDF, 8883 1 IGETDF,ICONDF,IGOMDF,IKATDF, 8884 1 IGIGDF,IGEODF, 8885 1 IBFWLI,IEEWLI, 8886 1 ISUBRO,IBUGA3,IERROR) 8887 ENDIF 8888C 8889 IF(ICASRA.EQ.'UNEX')THEN 8890 IHP='A ' 8891 IHP2=' ' 8892 IHWUSE='P' 8893 MESSAG='NO' 8894 CALL CHECKN(IHP,IHP2,IHWUSE, 8895 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 8896 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 8897 IF(IERROR.EQ.'YES')THEN 8898 A=0.0 8899 ELSE 8900 A=VALUE(ILOCP) 8901 ENDIF 8902C 8903 IHP='B ' 8904 IHP2=' ' 8905 IHWUSE='P' 8906 MESSAG='NO' 8907 CALL CHECKN(IHP,IHP2,IHWUSE, 8908 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 8909 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 8910 IF(IERROR.EQ.'YES')THEN 8911 B=1.0 8912 ELSE 8913 B=VALUE(ILOCP) 8914 ENDIF 8915C 8916 IHP='DIAM' 8917 IHP2=' ' 8918 IHWUSE='P' 8919 MESSAG='YES' 8920 CALL CHECKN(IHP,IHP2,IHWUSE, 8921 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 8922 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 8923 IF(IERROR.EQ.'YES')GOTO9000 8924 SHAPE1=VALUE(ILOCP) 8925 ENDIF 8926C 8927 IF(ICASRA.EQ.'SUBS')THEN 8928 CALL RANSUB(NRAN,ISEED,Y) 8929 ELSEIF(ICASRA.EQ.'KNSE')THEN 8930 IHP='N ' 8931 IHP2=' ' 8932 IHWUSE='P' 8933 MESSAG='YES' 8934 CALL CHECKN(IHP,IHP2,IHWUSE, 8935 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 8936 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 8937 IF(IERROR.EQ.'YES')GOTO9000 8938 NPAR=INT(VALUE(ILOCP)+0.5) 8939C 8940 IF(NRAN.GT.NPAR)THEN 8941 WRITE(ICOUT,321) 8942 CALL DPWRST('XXX','BUG ') 8943 WRITE(ICOUT,3862) 8944 3862 FORMAT(' FOR THE K-SET OF N-SET CASE, THE VALUE') 8945 CALL DPWRST('XXX','BUG ') 8946 WRITE(ICOUT,3863) 8947 3863 FORMAT(' OF K MUST BE LESS THAN OR EQUAL TO THE VALUE ', 8948 1 'OF N.') 8949 CALL DPWRST('XXX','BUG ') 8950 WRITE(ICOUT,8197) 8951 8197 FORMAT(' SUCH WAS NOT THE CASE HERE.') 8952 CALL DPWRST('XXX','BUG ') 8953 WRITE(ICOUT,3868)NRAN 8954 3868 FORMAT(' THE SPECIFIED VALUE OF K = ',I8) 8955 CALL DPWRST('XXX','BUG ') 8956 WRITE(ICOUT,3869)NPAR 8957 3869 FORMAT(' THE SPECIFIED VALUE OF N = ',I8) 8958 CALL DPWRST('XXX','BUG ') 8959 GOTO9000 8960 ENDIF 8961 CALL RANKSB(NRAN,NPAR,ISEED,Y,ITEMP1) 8962 ELSEIF(ICASRA.EQ.'RANC')THEN 8963 IHP='N ' 8964 IHP2=' ' 8965 IHWUSE='P' 8966 MESSAG='YES' 8967 CALL CHECKN(IHP,IHP2,IHWUSE, 8968 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 8969 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 8970 IF(IERROR.EQ.'YES')GOTO9000 8971 NPAR=INT(VALUE(ILOCP)+0.5) 8972C 8973 IF(NPAR.LT.1)THEN 8974 WRITE(ICOUT,321) 8975 CALL DPWRST('XXX','BUG ') 8976 WRITE(ICOUT,3872) 8977 3872 FORMAT(' FOR THE RANDOM COMPOSITION CASE, THE VALUE') 8978 CALL DPWRST('XXX','BUG ') 8979 WRITE(ICOUT,3873) 8980 3873 FORMAT(' OF N MUST BE AT LEAST 1.') 8981 CALL DPWRST('XXX','BUG ') 8982 WRITE(ICOUT,8197) 8983 CALL DPWRST('XXX','BUG ') 8984 WRITE(ICOUT,3879)NPAR 8985 3879 FORMAT(' THE SPECIFIED VALUE OF N = ',I8) 8986 CALL DPWRST('XXX','BUG ') 8987 GOTO9000 8988 ENDIF 8989C 8990 IF(NRAN.LT.1 .OR. NRAN.GT.NPAR)THEN 8991 WRITE(ICOUT,321) 8992 CALL DPWRST('XXX','BUG ') 8993 WRITE(ICOUT,3882) 8994 3882 FORMAT(' FOR THE RANDOM COMPOSITION CASE, THE VALUE') 8995 CALL DPWRST('XXX','BUG ') 8996 WRITE(ICOUT,3883) 8997 3883 FORMAT(' OF K MUST BE LESS THAN OR EQUAL TO THE VALUE ', 8998 1 'OF N') 8999 CALL DPWRST('XXX','BUG ') 9000 WRITE(ICOUT,3884) 9001 3884 FORMAT(' AND GREATER THAN OR EQUAL TO ONE.') 9002 CALL DPWRST('XXX','BUG ') 9003 WRITE(ICOUT,8197) 9004 CALL DPWRST('XXX','BUG ') 9005 WRITE(ICOUT,3888)NRAN 9006 3888 FORMAT(' THE SPECIFIED VALUE OF K = ',I8) 9007 CALL DPWRST('XXX','BUG ') 9008 WRITE(ICOUT,3889)NPAR 9009 3889 FORMAT(' THE SPECIFIED VALUE OF N = ',I8) 9010 CALL DPWRST('XXX','BUG ') 9011 GOTO9000 9012 ENDIF 9013 CALL RANCOM(NRAN,NPAR,ISEED,Y,ITEMP1) 9014 ELSEIF(ICASRA.EQ.'RANP')THEN 9015 IHP='N ' 9016 IHP2=' ' 9017 IHWUSE='P' 9018 MESSAG='YES' 9019 CALL CHECKN(IHP,IHP2,IHWUSE, 9020 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 9021 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 9022 IF(IERROR.EQ.'YES')GOTO9000 9023 NPAR=INT(VALUE(ILOCP)+0.5) 9024C 9025 IF(NPAR.LT.1)THEN 9026 WRITE(ICOUT,321) 9027 CALL DPWRST('XXX','BUG ') 9028 WRITE(ICOUT,3922) 9029 3922 FORMAT(' FOR THE RANDOM PARTITION CASE, THE VALUE') 9030 CALL DPWRST('XXX','BUG ') 9031 WRITE(ICOUT,3923) 9032 3923 FORMAT(' OF N MUST BE AT LEAST 1.') 9033 CALL DPWRST('XXX','BUG ') 9034 WRITE(ICOUT,8197) 9035 CALL DPWRST('XXX','BUG ') 9036 WRITE(ICOUT,3925)NPAR 9037 3925 FORMAT(' THE SPECIFIED VALUE OF N = ',I8) 9038 CALL DPWRST('XXX','BUG ') 9039 GOTO9000 9040 ENDIF 9041C 9042 CALL RANPAR(K,NPAR,ISEED,Y,ITEMP1,ITEMP2) 9043 NRAN=K 9044 DO3929II=1,NRAN 9045 ISUB(II)=1 9046 3929 CONTINUE 9047 ICASEQ='FOR' 9048 IROWN=NRAN 9049 NIISUB=NRAN 9050 NLEFT=NRAN 9051 ELSEIF(ICASRA.EQ.'RANE')THEN 9052 IHP='N ' 9053 IHP2=' ' 9054 IHWUSE='P' 9055 MESSAG='YES' 9056 CALL CHECKN(IHP,IHP2,IHWUSE, 9057 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 9058 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 9059 IF(IERROR.EQ.'YES')GOTO9000 9060 NPAR=INT(VALUE(ILOCP)+0.5) 9061C 9062 IF(NPAR.LT.1)THEN 9063 WRITE(ICOUT,321) 9064 CALL DPWRST('XXX','BUG ') 9065 WRITE(ICOUT,3932) 9066 3932 FORMAT(' FOR THE RANDOM EQUIVALENCE RELATION CASE, ', 9067 1 'THE VALUE') 9068 CALL DPWRST('XXX','BUG ') 9069 WRITE(ICOUT,3933) 9070 3933 FORMAT(' OF N MUST BE AT LEAST 1.') 9071 CALL DPWRST('XXX','BUG ') 9072 WRITE(ICOUT,8197) 9073 CALL DPWRST('XXX','BUG ') 9074 WRITE(ICOUT,3935)NPAR 9075 3935 FORMAT(' THE SPECIFIED VALUE OF N = ',I8) 9076 CALL DPWRST('XXX','BUG ') 9077 GOTO9000 9078 ENDIF 9079C 9080 IF(NPAR.NE.NLAST)THEN 9081 NLAST=1 9082 ENDIF 9083 CALL RANEQU(NPAR,LTEMP,ITEMP1,ITEMP2,TEMP3,ITEMP4,ISEED,Y) 9084 NRAN=NPAR 9085 DO3939II=1,NRAN 9086 ISUB(II)=1 9087 Y(II)=REAL(ITEMP1(II)) 9088 3939 CONTINUE 9089 ICASEQ='FOR' 9090 IROWN=NRAN 9091 NIISUB=NRAN 9092 NLEFT=NRAN 9093 ELSEIF(ICASRA.EQ.'RAYT')THEN 9094 IHP='N ' 9095 IHP2=' ' 9096 IHWUSE='P' 9097 MESSAG='YES' 9098 CALL CHECKN(IHP,IHP2,IHWUSE, 9099 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 9100 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 9101 IF(IERROR.EQ.'YES')GOTO9000 9102 NPAR=INT(VALUE(ILOCP)+0.5) 9103C 9104 IF(NPAR.LT.1)THEN 9105 WRITE(ICOUT,321) 9106 CALL DPWRST('XXX','BUG ') 9107 WRITE(ICOUT,3942) 9108 3942 FORMAT(' FOR THE RANDOM YOUNG TABLEAUX CASE, ', 9109 1 'THE VALUE') 9110 CALL DPWRST('XXX','BUG ') 9111 WRITE(ICOUT,3943) 9112 3943 FORMAT(' OF N MUST BE AT LEAST 1.') 9113 CALL DPWRST('XXX','BUG ') 9114 WRITE(ICOUT,8197) 9115 CALL DPWRST('XXX','BUG ') 9116 WRITE(ICOUT,3945)NPAR 9117 3945 FORMAT(' THE SPECIFIED VALUE OF N = ',I8) 9118 CALL DPWRST('XXX','BUG ') 9119 GOTO9000 9120 ENDIF 9121C 9122 ISUM=0 9123 DO3948I=1,NLEFT 9124 ITEMP1(I)=INT(TEMP4(I)+0.5) 9125 ISUM=ISUM + ITEMP1(I) 9126 3948 CONTINUE 9127 IF(NLEFT.LT.NPAR)THEN 9128 DO3949I=NLEFT+1,NPAR 9129 ITEMP1(I)=0 9130 3949 CONTINUE 9131 ENDIF 9132C 9133 CALL RANYTB(NPAR,ITEMP1,ITEMP2,ISEED) 9134 NRAN=NPAR 9135 DO3952II=1,NRAN 9136 ISUB(II)=1 9137 Y(II)=REAL(ITEMP2(II)) 9138 3952 CONTINUE 9139 ICASEQ='FOR' 9140 IROWN=NRAN 9141 NIISUB=NRAN 9142 NLEFT=NRAN 9143 ELSE 9144 IHP='RANL' 9145 IHP2='OC ' 9146 IHWUSE='P' 9147 MESSAG='NO' 9148 CALL CHECKN(IHP,IHP2,IHWUSE, 9149 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 9150 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 9151 IF(IERROR.EQ.'YES')THEN 9152 RANLOC=0.0 9153 ELSE 9154 RANLOC=VALUE(ILOCV) 9155 ENDIF 9156 IHP='RANS' 9157 IHP2='CALE' 9158 IHWUSE='P' 9159 MESSAG='NO' 9160 CALL CHECKN(IHP,IHP2,IHWUSE, 9161 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 9162 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 9163 IF(IERROR.EQ.'YES')THEN 9164 RANSCA=1.0 9165 ELSE 9166 RANSCA=VALUE(ILOCV) 9167 IF(RANSCA.LE.0.0)RANSCA=1.0 9168 ENDIF 9169C 9170 IF(ICASRA.EQ.'GMCL' .OR. ICASRA.EQ.'TRAP' .OR. 9171 1 ICASRA.EQ.'GTRA' .OR. ICASRA.EQ.'UTSP' .OR. 9172 1 ICASRA.EQ.'GLGP' .OR. 9173 1 ICASRA.EQ.'PARE' .OR. ICASRA.EQ.'PAR2' 9174 1 )THEN 9175 CONTINUE 9176 ELSE 9177 IHP='A ' 9178 IHP2=' ' 9179 IHWUSE='P' 9180 MESSAG='NO' 9181 CALL CHECKN(IHP,IHP2,IHWUSE, 9182 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 9183 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 9184 IF(IERROR.EQ.'YES')THEN 9185 A=0.0 9186 ELSE 9187 A=VALUE(ILOCV) 9188 ENDIF 9189C 9190 IHP='B ' 9191 IHP2=' ' 9192 IHWUSE='P' 9193 MESSAG='NO' 9194 CALL CHECKN(IHP,IHP2,IHWUSE, 9195 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 9196 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) 9197 IF(IERROR.EQ.'YES')THEN 9198 B=1.0 9199 ELSE 9200 B=VALUE(ILOCV) 9201 ENDIF 9202C 9203 ENDIF 9204C 9205 CALL DPRAN2(ICASRA,ISEED,Y,NRAN,TEMP3, 9206 1 A,B,MINMAX, 9207 1 SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,SHAPE6,SHAPE7, 9208 1 IADEDF,IGEPDF,IMAKDF,IBEIDF, 9209 1 ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF, 9210 1 IGOMDF,IKATDF,IGIGDF,IGEODF, 9211 1 IBUGA3,ISUBRO,IFOUND,IERROR) 9212C 9213 IF(IFOUND.EQ.'NO')THEN 9214 WRITE(ICOUT,999) 9215 CALL DPWRST('XXX','BUG ') 9216 WRITE(ICOUT,321) 9217 CALL DPWRST('XXX','BUG ') 9218 WRITE(ICOUT,5953) 9219 5953 FORMAT(' THE RANDOM NUMBER CASE WAS NOT RECOGNIZED.') 9220 CALL DPWRST('XXX','BUG ') 9221 WRITE(ICOUT,5956)ICASRA 9222 5956 FORMAT(' THE VALUE OF ICASRA = ',A4) 9223 CALL DPWRST('XXX','BUG ') 9224 WRITE(ICOUT,5957) 9225 5957 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') 9226 CALL DPWRST('XXX','BUG ') 9227 IF(IWIDTH.GE.1)THEN 9228 WRITE(ICOUT,5958)(IANS(I),I=1,MIN(80,IWIDTH)) 9229 5958 FORMAT(80A1) 9230 CALL DPWRST('XXX','BUG ') 9231 ENDIF 9232 IERROR='YES' 9233 GOTO9000 9234 ENDIF 9235C 9236 DO5970JJ=1,NRAN 9237 Y(JJ)=RANLOC + RANSCA*Y(JJ) 9238 5970 CONTINUE 9239C 9240 ENDIF 9241C 9242C ****************************************************** 9243C ** STEP 8-- ** 9244C ** IF CALLED FOR (THAT IS, IF IBUGA3 IS ON), ** 9245C ** PRINT OUT THE INTERMEDIATE VARIABLE Y(.). ** 9246C ** THIS IS USEFUL FOR DIAGNOSTIC PURPOSES ** 9247C ** IN REVIEWING THE OUTPUT FROM THIS SUBROUTINE. ** 9248C ****************************************************** 9249C 9250 ISTEPN='9' 9251 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RAND')THEN 9252 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9253 WRITE(ICOUT,4011) 9254 4011 FORMAT('OUTPUT FROM MIDDLE OF DPRAND AFTER ALL XXXRAN ', 9255 1 'HAVE BEEN CALLED--') 9256 CALL DPWRST('XXX','BUG ') 9257 WRITE(ICOUT,4012)NRAN 9258 4012 FORMAT('NRAN = ',I8) 9259 CALL DPWRST('XXX','BUG ') 9260 IF(NRAN.GE.1)THEN 9261 DO4014I=1,NRAN 9262 WRITE(ICOUT,4015)I,Y(I) 9263 4015 FORMAT('I,Y(I) = ',I8,F12.5) 9264 CALL DPWRST('XXX','BUG ') 9265 4014 CONTINUE 9266 ENDIF 9267 ENDIF 9268C 9269C ****************************************************** 9270C ** STEP 9-- ** 9271C ** COPY THE RANDOM NUMBERS ** 9272C ** FROM THE INTERMEDIATE VECTOR Y(.) ** 9273C ** TO THE APPROPRIATE COLUMN ** 9274C ** (BASED ON THE QUALIFIER--FULL, SUBSET, OR FOR) ** 9275C ** IN THE INTERNAL DATAPLOT DATA TABLE. ** 9276C ****************************************************** 9277C 9278 ISTEPN='10' 9279 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RAND') 9280 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9281C 9282 NS2=0 9283 DO4060I=1,NIISUB 9284 IJ=MAXN*(ICOLL-1)+I 9285 IF(ISUB(I).EQ.0)GOTO4060 9286 NS2=NS2+1 9287 IF(ICOLL.LE.MAXCOL)V(IJ)=Y(NS2) 9288 IF(ICOLL.EQ.MAXCP1)PRED(I)=Y(NS2) 9289 IF(ICOLL.EQ.MAXCP2)RES(I)=Y(NS2) 9290 IF(ICOLL.EQ.MAXCP3)YPLOT(I)=Y(NS2) 9291 IF(ICOLL.EQ.MAXCP4)XPLOT(I)=Y(NS2) 9292 IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=Y(NS2) 9293 IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=Y(NS2) 9294 IF(NS2.EQ.1)IROW1=I 9295 IROWN=I 9296 4060 CONTINUE 9297C 9298C ******************************************* 9299C ** STEP 10-- ** 9300C ** CARRY OUT THE LIST UPDATING AND ** 9301C ** GENERATE THE INFORMATIVE PRINTING. ** 9302C ******************************************* 9303C 9304 ISTEPN='11' 9305 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RAND') 9306 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9307C 9308 IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'NO')NINEW=NLEFT 9309 IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'YES')NINEW=MAXN 9310 IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND. 9311 1NLEFT.GE.IROWN)NINEW=NLEFT 9312 IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND. 9313 1NLEFT.LT.IROWN)NINEW=IROWN 9314 IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'YES')NINEW=IROWN 9315 IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND. 9316 1NLEFT.GE.IROWN)NINEW=NLEFT 9317 IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND. 9318 1NLEFT.LT.IROWN)NINEW=IROWN 9319 IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'YES')NINEW=IROWN 9320C 9321 IHNAME(ILISTL)=ILEFT 9322 IHNAM2(ILISTL)=ILEFT2 9323 IUSE(ILISTL)='V' 9324 IVALUE(ILISTL)=ICOLL 9325 VALUE(ILISTL)=ICOLL 9326 IN(ILISTL)=NINEW 9327C 9328 IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1 9329 IF(NEWNAM.EQ.'YES')NUMCOL=NUMCOL+1 9330C 9331 DO4600J4=1,NUMNAM 9332 IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)GOTO4605 9333 GOTO4600 9334 4605 CONTINUE 9335 IUSE(J4)='V' 9336 IVALUE(J4)=ICOLL 9337 VALUE(J4)=ICOLL 9338 IN(J4)=NINEW 9339 4600 CONTINUE 9340C 9341 IF(IPRINT.EQ.'OFF')GOTO4559 9342 IF(IFEEDB.EQ.'OFF')GOTO4559 9343 WRITE(ICOUT,999) 9344 CALL DPWRST('XXX','BUG ') 9345 WRITE(ICOUT,4511)ILEFT,ILEFT2,NS2 9346 4511 FORMAT('THE NUMBER OF VALUES GENERATED FOR ', 9347 1'THE VARIABLE ',A4,A4,' = ',I8) 9348 CALL DPWRST('XXX','BUG ') 9349 WRITE(ICOUT,999) 9350 CALL DPWRST('XXX','BUG ') 9351C 9352 IJ=MAXN*(ICOLL-1)+IROW1 9353 IF(ICOLL.LE.MAXCOL)THEN 9354 WRITE(ICOUT,4521)ILEFT,ILEFT2,V(IJ),IROW1 9355 4521 FORMAT('THE FIRST COMPUTED VALUE OF ', 9356 1 A4,A4,' = ',E15.7,' (ROW ',I6,')') 9357 CALL DPWRST('XXX','BUG ') 9358 ELSE IF(ICOLL.EQ.MAXCP1)THEN 9359 WRITE(ICOUT,4521)ILEFT,ILEFT2,PRED(IROW1),IROW1 9360 CALL DPWRST('XXX','BUG ') 9361 ELSE IF(ICOLL.EQ.MAXCP2)THEN 9362 WRITE(ICOUT,4521)ILEFT,ILEFT2,RES(IROW1),IROW1 9363 CALL DPWRST('XXX','BUG ') 9364 ELSE IF(ICOLL.EQ.MAXCP3)THEN 9365 WRITE(ICOUT,4521)ILEFT,ILEFT2,YPLOT(IROW1),IROW1 9366 CALL DPWRST('XXX','BUG ') 9367 ELSE IF(ICOLL.EQ.MAXCP4)THEN 9368 WRITE(ICOUT,4521)ILEFT,ILEFT2,XPLOT(IROW1),IROW1 9369 CALL DPWRST('XXX','BUG ') 9370 ELSE IF(ICOLL.EQ.MAXCP5)THEN 9371 WRITE(ICOUT,4521)ILEFT,ILEFT2,X2PLOT(IROW1),IROW1 9372 CALL DPWRST('XXX','BUG ') 9373 ELSE IF(ICOLL.EQ.MAXCP6)THEN 9374 WRITE(ICOUT,4521)ILEFT,ILEFT2,TAGPLO(IROW1),IROW1 9375 CALL DPWRST('XXX','BUG ') 9376 ENDIF 9377C 9378 IJ=MAXN*(ICOLL-1)+IROWN 9379 IF(NS2.NE.1)THEN 9380 IF(ICOLL.LE.MAXCOL)THEN 9381 WRITE(ICOUT,4531)NS2,ILEFT,ILEFT2,V(IJ),IROWN 9382 4531 FORMAT('THE LAST (',I5,'-TH) COMPUTED VALUE OF ', 9383 1 A4,A4,' = ',E15.7,' (ROW ',I6,')') 9384 CALL DPWRST('XXX','BUG ') 9385 ELSE IF(ICOLL.EQ.MAXCP1)THEN 9386 WRITE(ICOUT,4531)NS2,ILEFT,ILEFT2,PRED(IROWN),IROWN 9387 CALL DPWRST('XXX','BUG ') 9388 ELSE IF(ICOLL.EQ.MAXCP2)THEN 9389 WRITE(ICOUT,4531)NS2,ILEFT,ILEFT2,RES(IROWN),IROWN 9390 CALL DPWRST('XXX','BUG ') 9391 ELSE IF(ICOLL.EQ.MAXCP3)THEN 9392 WRITE(ICOUT,4531)NS2,ILEFT,ILEFT2,YPLOT(IROWN),IROWN 9393 CALL DPWRST('XXX','BUG ') 9394 ELSE IF(ICOLL.EQ.MAXCP4)THEN 9395 WRITE(ICOUT,4531)NS2,ILEFT,ILEFT2,XPLOT(IROWN),IROWN 9396 CALL DPWRST('XXX','BUG ') 9397 ELSE IF(ICOLL.EQ.MAXCP5)THEN 9398 WRITE(ICOUT,4531)NS2,ILEFT,ILEFT2,X2PLOT(IROWN),IROWN 9399 CALL DPWRST('XXX','BUG ') 9400 ELSE IF(ICOLL.EQ.MAXCP6)THEN 9401 WRITE(ICOUT,4531)NS2,ILEFT,ILEFT2,TAGPLO(IROWN),IROWN 9402 CALL DPWRST('XXX','BUG ') 9403 ENDIF 9404 ENDIF 9405 IF(NS2.NE.1)GOTO4590 9406 WRITE(ICOUT,4546) 9407 4546 FORMAT('SINCE THE GENERATED SAMPLE SIZE WAS ONLY 1,') 9408 CALL DPWRST('XXX','BUG ') 9409 WRITE(ICOUT,4542) 9410 4542 FORMAT('THE ABOVE VALUE WAS THE SOLE VALUE COMPUTED.') 9411 CALL DPWRST('XXX','BUG ') 9412 4590 CONTINUE 9413 WRITE(ICOUT,999) 9414 CALL DPWRST('XXX','BUG ') 9415 WRITE(ICOUT,4612)ILEFT,ILEFT2,ICOLL 9416 4612 FORMAT('THE CURRENT COLUMN FOR THE VARIABLE ',A4,A4,' = ',I8) 9417 CALL DPWRST('XXX','BUG ') 9418 WRITE(ICOUT,4613)ILEFT,ILEFT2,NINEW 9419 4613 FORMAT('THE CURRENT LENGTH OF THE VARIABLE ',A4,A4,' = ',I8) 9420 CALL DPWRST('XXX','BUG ') 9421 WRITE(ICOUT,999) 9422 CALL DPWRST('XXX','BUG ') 9423 WRITE(ICOUT,999) 9424 CALL DPWRST('XXX','BUG ') 9425 4559 CONTINUE 9426C 9427C ***************** 9428C ** STEP 90-- ** 9429C ** EXIT ** 9430C ***************** 9431C 9432 9000 CONTINUE 9433 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RAND')THEN 9434 WRITE(ICOUT,999) 9435 CALL DPWRST('XXX','BUG ') 9436 WRITE(ICOUT,9011) 9437 9011 FORMAT('***** AT THE END OF DPRAND--') 9438 CALL DPWRST('XXX','BUG ') 9439 WRITE(ICOUT,9012)IFOUND,IERROR,IBUGA3,IBUGQ 9440 9012 FORMAT('IFOUND,IERROR,IBUGA3,IBUGQ = ',3(A4,2X),A4) 9441 CALL DPWRST('XXX','BUG ') 9442 WRITE(ICOUT,9014)ICASRA,ISEED,ILOCNU,NS2,MINMAX 9443 9014 FORMAT('ICASRA,ISEED,ILOCNU,NS2,MINMAX = ',A4,4I8) 9444 CALL DPWRST('XXX','BUG ') 9445 WRITE(ICOUT,9016)NS,NIISUB,NRAN 9446 9016 FORMAT('NS,NIISUB,NRAN = ',I8,I8,I8) 9447 CALL DPWRST('XXX','BUG ') 9448 ENDIF 9449C 9450 RETURN 9451 END 9452 SUBROUTINE DPRAN2(ICASRA,ISEED,Y,NRAN,TEMP1, 9453 1 A,B,MINMAX, 9454 1 SHAPE1,SHAPE2,SHAPE3,SHAPE4, 9455 1 SHAPE5,SHAPE6,SHAPE7, 9456 1 IADEDF,IGEPDF,IMAKDF,IBEIDF, 9457 1 ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF, 9458 1 IGOMDF,IKATDF,IGIGDF,IGEODF, 9459 1 IBUGA3,ISUBRO,IFOUND,IERROR) 9460C 9461C PURPOSE--THIS ROUTINE IS SPLIT OFF FROM DPRAND IN ORDER 9462C TO ALLOW OTHER ROUTINES TO CALL THE RANDOM NUMBER 9463C ROUTINES IN A GENERIC WAY. 9464C 9465C WRITTEN BY--JAMES J. FILLIBEN 9466C STATISTICAL ENGINEERING DIVISION 9467C INFORMATION TECHNOLOGY LABORATORY 9468C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 9469C GAITHERSBURG, MD 20899-8980 9470C PHONE--301-975-2855 9471C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 9472C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 9473C LANGUAGE--ANSI FORTRAN (1977) 9474C VERSION NUMBER--2009/9 9475C ORIGINAL VERSION--SEPTEMBER 2009. SPLIT OFF FROM DPRAND 9476C UPDATED --JULY 2010. END EFFECTS WEIBULL 9477C UPDATED --AUGUST 2010. BRITTLE FIBER WEIBULL 9478C UPDATED --JANUARY 2011. ARCTANGENT 9479C UPDATED --MARCH 2013. SINE 9480C UPDATED --MARCH 2013. EXCLUSION ZONE UNIFORM 9481C UPDATED --APRIL 2014. "G" AND "H" AS DISTINCT FROM 9482C "G AND H" DISTRIBUTIONS 9483C 9484C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 9485C 9486 CHARACTER*4 ICASRA 9487 CHARACTER*4 IADEDF 9488 CHARACTER*4 IGEPDF 9489 CHARACTER*4 IMAKDF 9490 CHARACTER*4 IBEIDF 9491 CHARACTER*4 ILGADF 9492 CHARACTER*4 ISKNDF 9493 CHARACTER*4 IGLDDF 9494 CHARACTER*4 IBGEDF 9495 CHARACTER*4 IGETDF 9496 CHARACTER*4 ICONDF 9497 CHARACTER*4 IGOMDF 9498 CHARACTER*4 IKATDF 9499 CHARACTER*4 IGIGDF 9500 CHARACTER*4 IGEODF 9501 CHARACTER*4 IBUGA3 9502 CHARACTER*4 ISUBRO 9503 CHARACTER*4 IFOUND 9504 CHARACTER*4 IERROR 9505C 9506 CHARACTER*4 ISUBN1 9507 CHARACTER*4 ISUBN2 9508C 9509C-----COMMON---------------------------------------------------------- 9510C 9511 DIMENSION Y(*) 9512 DIMENSION TEMP1(*) 9513C 9514C-----COMMON VARIABLES (GENERAL)-------------------------------------- 9515C 9516 INCLUDE 'DPCOP2.INC' 9517C 9518C-----DATA STATEMENTS------------------------------------------------- 9519C 9520C-----START POINT----------------------------------------------------- 9521C 9522 ISUBN1='DPRA' 9523 ISUBN2='N2 ' 9524 IFOUND='YES' 9525 IERROR='NO' 9526C 9527 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RAN2')THEN 9528 WRITE(ICOUT,999) 9529 999 FORMAT(1X) 9530 CALL DPWRST('XXX','BUG ') 9531 WRITE(ICOUT,51) 9532 51 FORMAT('***** AT THE BEGINNING OF DPRAN2--') 9533 CALL DPWRST('XXX','BUG ') 9534 WRITE(ICOUT,53)IBUGA3,ICASRA,NRAN,ISEED,MINMAX 9535 53 FORMAT('IBUGA3,ICASRA,NRAN,ISEED,MINMAX = ',A4,2X,A4,2X,3I8) 9536 CALL DPWRST('XXX','BUG ') 9537 ENDIF 9538C 9539C *********************************************** 9540C ** GENERATE THE RANDOM NUMBERS ** 9541C *********************************************** 9542C 9543 IF(ICASRA.EQ.'UNIF')THEN 9544 CALL UNIRAN(NRAN,ISEED,Y) 9545 ELSEIF(ICASRA.EQ.'NORM')THEN 9546 CALL NORRAN(NRAN,ISEED,Y) 9547 ELSEIF(ICASRA.EQ.'LOGI')THEN 9548 CALL LOGRAN(NRAN,ISEED,Y) 9549 ELSEIF(ICASRA.EQ.'DEXP')THEN 9550 CALL DEXRAN(NRAN,ISEED,Y) 9551 ELSEIF(ICASRA.EQ.'CAUC')THEN 9552 CALL CAURAN(NRAN,ISEED,Y) 9553 ELSEIF(ICASRA.EQ.'TULA')THEN 9554 CALL LAMRAN(NRAN,SHAPE1,ISEED,Y) 9555 ELSEIF(ICASRA.EQ.'LOGN' .OR. ICASRA.EQ.'3LGN')THEN 9556 CALL LGNRAN(NRAN,SHAPE1,ISEED,Y) 9557 ELSEIF(ICASRA.EQ.'HNOR')THEN 9558 CALL HFNRAN(NRAN,ISEED,Y) 9559 ELSEIF(ICASRA.EQ.'TPP')THEN 9560 CALL TRAN(NRAN,SHAPE1,ISEED,Y) 9561 ELSEIF(ICASRA.EQ.'CHIS')THEN 9562 CALL CHSRAN(NRAN,SHAPE1,ISEED,Y) 9563 ELSEIF(ICASRA.EQ.'FPP')THEN 9564 CALL FRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9565 ELSEIF(ICASRA.EQ.'EXPO')THEN 9566 CALL EXPRAN(NRAN,ISEED,Y) 9567 ELSEIF(ICASRA.EQ.'GAMM' .OR. ICASRA.EQ.'3GAM')THEN 9568 CALL GAMRAN(NRAN,SHAPE1,ISEED,Y) 9569 ELSEIF(ICASRA.EQ.'BETA')THEN 9570 CALL BETRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9571 ELSEIF(ICASRA.EQ.'WEIB' .OR. ICASRA.EQ.'3WEI')THEN 9572 CALL WEIRAN(NRAN,SHAPE1,MINMAX,ISEED,Y) 9573 ELSEIF(ICASRA.EQ.'EV1 ')THEN 9574 CALL EV1RAN(NRAN,MINMAX,ISEED,Y) 9575 ELSEIF(ICASRA.EQ.'EV2 ' .OR. ICASRA.EQ.'3EV2')THEN 9576 CALL EV2RAN(NRAN,SHAPE1,MINMAX,ISEED,Y) 9577 ELSEIF(ICASRA.EQ.'PARE')THEN 9578 ZLOC=SHAPE2 9579 IF(ZLOC.LE.0.0)ZLOC=1.0 9580 CALL PARRAN(NRAN,SHAPE1,ZLOC,ISEED,Y) 9581 ELSEIF(ICASRA.EQ.'BINO')THEN 9582 CALL BINRAN(NRAN,SHAPE1,INT(SHAPE2+0.1),ISEED,Y) 9583 ELSEIF(ICASRA.EQ.'GEOM')THEN 9584 IF(IGEODF.EQ.'DLMF')THEN 9585 CALL GE2RAN(NRAN,SHAPE1,ISEED,Y) 9586 ELSE 9587 CALL GEORAN(NRAN,SHAPE1,ISEED,Y) 9588 ENDIF 9589 ELSEIF(ICASRA.EQ.'POIS')THEN 9590 CALL POIRAN(NRAN,SHAPE1,ISEED,Y) 9591 ELSEIF(ICASRA.EQ.'NEBI')THEN 9592 CALL NBRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9593 ELSEIF(ICASRA.EQ.'SEMC')THEN 9594 IF(SHAPE1.EQ.CPUMIN)THEN 9595 ASCALE=1.0 9596 ELSE 9597 ASCALE=1.0 9598 ENDIF 9599 CALL SEMRAN(NRAN,ASCALE,ISEED,Y) 9600 ELSEIF(ICASRA.EQ.'TRIA')THEN 9601 CALL TRIRAN(NRAN,SHAPE1,A,B,ISEED,Y) 9602 ELSEIF(ICASRA.EQ.'DUNI')THEN 9603 CALL DUNRAN(NRAN,INT(SHAPE1+0.1),ISEED,Y) 9604 ELSEIF(ICASRA.EQ.'BOOT')THEN 9605 CALL DUNRA2(NRAN,NRAN,ISEED,Y) 9606 ELSEIF(ICASRA.EQ.'PERM')THEN 9607 CALL RANPER(NRAN,ISEED,Y) 9608 ELSEIF(ICASRA.EQ.'INGA')THEN 9609 CALL IGRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9610 ELSEIF(ICASRA.EQ.'WALD')THEN 9611 ATEMP=1.0 9612 CALL IGRAN(NRAN,SHAPE1,ATEMP,ISEED,Y) 9613 ELSEIF(ICASRA.EQ.'RIGA')THEN 9614 CALL RIGRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9615 ELSEIF(ICASRA.EQ.'FATL')THEN 9616 CALL FLRAN(NRAN,SHAPE1,ISEED,Y) 9617 ELSEIF(ICASRA.EQ.'GPAR')THEN 9618 CALL GEPRAN(NRAN,SHAPE1,MINMAX,IGEPDF,ISEED,Y) 9619 ELSEIF(ICASRA.EQ.'POWF')THEN 9620 CALL POWRAN(NRAN,SHAPE1,ISEED,Y) 9621 ELSEIF(ICASRA.EQ.'HYPG')THEN 9622 DO1352II=1,NRAN 9623 CALL HYPRAN(INT(SHAPE1+0.1),INT(SHAPE2+0.1),INT(SHAPE3+0.1), 9624 1 ISEED,JX) 9625 IF(JX.EQ.-1)THEN 9626 WRITE(ICOUT,1354) 9627 CALL DPWRST('XXX','BUG ') 9628 WRITE(ICOUT,1356)INT(SHAPE1+0.1),INT(SHAPE2+0.1), 9629 1 INT(SHAPE3+0.1) 9630 CALL DPWRST('XXX','BUG ') 9631 IERROR='YES' 9632 GOTO9000 9633 ENDIF 9634 1354 FORMAT('****** ERROR IN GENERATING HYPERGEOMETRIC RANDOM ', 9635 1 'NUMBERS.') 9636 1356 FORMAT(' THE VALUES OF K, M, AND N = ',3I8) 9637 Y(II)=REAL(JX) 9638 1352 CONTINUE 9639 ELSEIF(ICASRA.EQ.'NCCS')THEN 9640 CALL NCCRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9641 ELSEIF(ICASRA.EQ.'NCF ')THEN 9642 CALL NCFRAN(NRAN,SHAPE1,SHAPE2,SHAPE3,ISEED,Y) 9643 ELSEIF(ICASRA.EQ.'DNCF')THEN 9644 CALL DNFRAN(NRAN,SHAPE1,SHAPE2,SHAPE3,SHAPE4,ISEED,Y) 9645 ELSEIF(ICASRA.EQ.'FNOR')THEN 9646 CALL FNRRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9647 ELSEIF(ICASRA.EQ.'HCAU')THEN 9648 CALL HFCRAN(NRAN,ISEED,Y) 9649 ELSEIF(ICASRA.EQ.'NORX')THEN 9650 CALL NMXRAN(NRAN,SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,ISEED,Y) 9651 ELSEIF(ICASRA.EQ.'POWL')THEN 9652 CALL PWLRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9653 ELSEIF(ICASRA.EQ.'GTLA')THEN 9654 CALL GLDRAN(NRAN,SHAPE1,SHAPE2,ISEED,IGLDDF,Y) 9655 ELSEIF(ICASRA.EQ.'IWEI')THEN 9656 CALL IWERAN(NRAN,SHAPE1,ISEED,Y) 9657 ELSEIF(ICASRA.EQ.'DWEI')THEN 9658 CALL DWERAN(NRAN,SHAPE1,ISEED,Y) 9659 ELSEIF(ICASRA.EQ.'DGAM')THEN 9660 CALL DGARAN(NRAN,SHAPE1,ISEED,Y) 9661 ELSEIF(ICASRA.EQ.'LGAM')THEN 9662 CALL LGARAN(NRAN,SHAPE1,ILGADF,ISEED,Y) 9663 ELSEIF(ICASRA.EQ.'IGAM' .OR. ICASRA.EQ.'3IGA')THEN 9664 CALL IGARAN(NRAN,SHAPE1,ISEED,Y) 9665 ELSEIF(ICASRA.EQ.'COSI')THEN 9666 CALL COSRAN(NRAN,ISEED,Y) 9667 ELSEIF(ICASRA.EQ.'SINE')THEN 9668 CALL SINRAN(NRAN,ISEED,Y) 9669 ELSEIF(ICASRA.EQ.'ANGL')THEN 9670 CALL ANGRAN(NRAN,ISEED,Y) 9671 ELSEIF(ICASRA.EQ.'HSEC')THEN 9672 CALL HSERAN(NRAN,ISEED,Y) 9673 ELSEIF(ICASRA.EQ.'ARSI')THEN 9674 CALL ARSRAN(NRAN,ISEED,Y) 9675 ELSEIF(ICASRA.EQ.'LDEX')THEN 9676 CALL LDERAN(NRAN,SHAPE1,ISEED,Y) 9677 ELSEIF(ICASRA.EQ.'GEV ')THEN 9678 CALL GEVRAN(NRAN,SHAPE1,MINMAX,ISEED,Y) 9679 ELSEIF(ICASRA.EQ.'EWEI')THEN 9680 CALL EWERAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9681 ELSEIF(ICASRA.EQ.'GOMP')THEN 9682 CALL GOMRAN(NRAN,SHAPE1,SHAPE2,IGOMDF,ISEED,Y) 9683 ELSEIF(ICASRA.EQ.'HALO')THEN 9684 SHAPE1=-1.0 9685 CALL HFLRAN(NRAN,SHAPE1,ISEED,Y) 9686 ELSEIF(ICASRA.EQ.'GHLO')THEN 9687 CALL HFLRAN(NRAN,SHAPE1,ISEED,Y) 9688 ELSEIF(ICASRA.EQ.'PEXP')THEN 9689 CALL PEXRAN(NRAN,SHAPE1,ISEED,Y) 9690 ELSEIF(ICASRA.EQ.'ALPH')THEN 9691 CALL ALPRAN(NRAN,SHAPE1,ISEED,Y) 9692 ELSEIF(ICASRA.EQ.'BRAD')THEN 9693 CALL BRARAN(NRAN,SHAPE1,ISEED,Y) 9694 ELSEIF(ICASRA.EQ.'RECI')THEN 9695 CALL RECRAN(NRAN,SHAPE1,ISEED,Y) 9696 ELSEIF(ICASRA.EQ.'JOSB')THEN 9697 CALL JSBRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9698 ELSEIF(ICASRA.EQ.'JOSU')THEN 9699 CALL JSURAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9700 ELSEIF(ICASRA.EQ.'POWN')THEN 9701 CALL PNRRAN(NRAN,SHAPE1,ISEED,Y) 9702 ELSEIF(ICASRA.EQ.'LOGL')THEN 9703 CALL LLGRAN(NRAN,SHAPE1,ISEED,Y) 9704 ELSEIF(ICASRA.EQ.'GEEX')THEN 9705 CALL GEERAN(NRAN,SHAPE1,ISEED,Y) 9706 ELSEIF(ICASRA.EQ.'PLGN')THEN 9707 CALL PLNRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9708 ELSEIF(ICASRA.EQ.'BBIN')THEN 9709 CALL BBNRAN(SHAPE1,SHAPE2,INT(SHAPE3+0.1),NRAN,ISEED,Y) 9710 ELSEIF(ICASRA.EQ.'POLY')THEN 9711 CALL BBNRAN(SHAPE2,SHAPE1,INT(SHAPE3+0.1),NRAN,ISEED,Y) 9712 ELSEIF(ICASRA.EQ.'TSPO')THEN 9713 CALL TSPRAN(NRAN,SHAPE1,SHAPE2,A,B,ISEED,Y) 9714 ELSEIF(ICASRA.EQ.'BWEI')THEN 9715 CALL BWERAN(NRAN,SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,ISEED,Y) 9716 ELSEIF(ICASRA.EQ.'LOGS')THEN 9717 CALL DLGRAN(NRAN,SHAPE1,ISEED,Y) 9718 ELSEIF(ICASRA.EQ.'GHPP')THEN 9719 CALL GHRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9720 ELSEIF(ICASRA.EQ.'GPP')THEN 9721 SHAPE2=0.0 9722 CALL GHRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9723 ELSEIF(ICASRA.EQ.'HPP')THEN 9724 SHAPE1=0.0 9725 CALL GHRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9726 ELSEIF(ICASRA.EQ.'SLAS')THEN 9727 CALL SLARAN(NRAN,ISEED,Y) 9728 ELSEIF(ICASRA.EQ.'LAND')THEN 9729 CALL LANRAN(NRAN,ISEED,Y) 9730 ELSEIF(ICASRA.EQ.'IBET')THEN 9731 CALL IBRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9732 ELSEIF(ICASRA.EQ.'ERRO')THEN 9733 CALL ERRRAN(NRAN,SHAPE1,ISEED,Y) 9734 ELSEIF(ICASRA.EQ.'TRAP')THEN 9735 CALL TRARAN(NRAN,SHAPE1,SHAPE2,SHAPE3,SHAPE4,ISEED,Y) 9736 ELSEIF(ICASRA.EQ.'VONM')THEN 9737 CALL VONRAN(NRAN,SHAPE1,ISEED,Y) 9738 ELSEIF(ICASRA.EQ.'PAR2')THEN 9739 ZLOC=SHAPE2 9740 IF(ZLOC.LE.0.0)ZLOC=1.0 9741 CALL PA2RAN(NRAN,SHAPE1,ZLOC,ISEED,Y) 9742 ELSEIF(ICASRA.EQ.'WCAU')THEN 9743 CALL WCARAN(NRAN,SHAPE1,ISEED,Y) 9744 ELSEIF(ICASRA.EQ.'GTRA')THEN 9745 CALL GTRRAN(NRAN,SHAPE1,SHAPE2,SHAPE3,SHAPE4, 9746 1 SHAPE5,SHAPE6,SHAPE7,ISEED,Y) 9747 ELSEIF(ICASRA.EQ.'TNOR')THEN 9748 CALL TNRRAN(NRAN,A,B,SHAPE1,SHAPE2,ISEED,Y) 9749 ELSEIF(ICASRA.EQ.'CHI ')THEN 9750 CALL CHRAN(NRAN,SHAPE1,ISEED,Y) 9751 ELSEIF(ICASRA.EQ.'FCAU')THEN 9752 CALL FCARAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9753 ELSEIF(ICASRA.EQ.'MBKA')THEN 9754 CALL MIERAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9755 ELSEIF(ICASRA.EQ.'GEXP')THEN 9756 CALL GEXRAN(NRAN,SHAPE1,SHAPE2,SHAPE3,ISEED,Y) 9757 ELSEIF(ICASRA.EQ.'TEXP')THEN 9758 CALL TNERAN(NRAN,SHAPE1,SHAPE2,SHAPE3,ISEED,Y) 9759 ELSEIF(ICASRA.EQ.'GGAM')THEN 9760 CALL GGDRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9761 ELSEIF(ICASRA.EQ.'FT ')THEN 9762 CALL FTRAN(NRAN,INT(SHAPE1+0.1),ISEED,Y) 9763 ELSEIF(ICASRA.EQ.'SNOR')THEN 9764 CALL SNRAN(NRAN,SHAPE1,ISKNDF,ISEED,Y) 9765 ELSEIF(ICASRA.EQ.'TSKE')THEN 9766 CALL STRAN(NRAN,INT(SHAPE1+0.1),SHAPE2,ISEED,Y) 9767 ELSEIF(ICASRA.EQ.'ZETA')THEN 9768 CALL ZETRAN(NRAN,SHAPE1,ISEED,Y) 9769 ELSEIF(ICASRA.EQ.'GOMM')THEN 9770 IF(IMAKDF.EQ.'DLMF')THEN 9771 CALL MAKRAN(NRAN,SHAPE1,SHAPE2,SHAPE3,ISEED,Y) 9772 ELSEIF(IMAKDF.EQ.'MEEK')THEN 9773 XI=SHAPE1/SHAPE3 9774 THETA=SHAPE2/SHAPE1 9775 ALAMB=SHAPE3 9776 CALL MAKRAN(NRAN,XI,ALAMB,THETA,ISEED,Y) 9777 ELSEIF(IMAKDF.EQ.'REPA')THEN 9778 CALL MA2RAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9779 ENDIF 9780 ELSEIF(ICASRA.EQ.'GIGA'.AND.IGIGDF.EQ.'3PAR')THEN 9781 CALL GIGRAN(NRAN,SHAPE1,SHAPE2,SHAPE3,ISEED,Y) 9782 ELSEIF(ICASRA.EQ.'GIGA'.AND.IGIGDF.EQ.'2PAR')THEN 9783 CALL GI2RAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9784 ELSEIF(ICASRA.EQ.'LSNO')THEN 9785 CALL LSNRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9786 ELSEIF(ICASRA.EQ.'LSKT')THEN 9787 CALL LSTRAN(NRAN,INT(SHAPE1+0.1),SHAPE2,SHAPE3,ISEED,Y) 9788 ELSEIF(ICASRA.EQ.'NCT ')THEN 9789 CALL NCTRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9790 ELSEIF(ICASRA.EQ.'DNCT')THEN 9791 CALL DNTRAN(NRAN,SHAPE1,SHAPE2,SHAPE3,ISEED,Y) 9792 ELSEIF(ICASRA.EQ.'GLOG')THEN 9793 CALL GLORAN(NRAN,SHAPE1,ISEED,Y) 9794 ELSEIF(ICASRA.EQ.'HERM')THEN 9795 CALL HERRAN(SHAPE1,SHAPE2,NRAN,ISEED,Y) 9796 ELSEIF(ICASRA.EQ.'YULE')THEN 9797 CALL YULRAN(NRAN,SHAPE1,ISEED,Y) 9798 ELSEIF(ICASRA.EQ.'WARI')THEN 9799 B=1.0 9800 BETA=SHAPE2 9801 ALPHA=SHAPE1-SHAPE2 9802 CALL GWARAN(NRAN,BETA,B,ALPHA,ISEED,Y) 9803 ELSEIF(ICASRA.EQ.'GWAR' .OR. ICASRA.EQ.'BNBI')THEN 9804 CALL GWARAN(NRAN,SHAPE1,SHAPE2,SHAPE3,ISEED,Y) 9805 ELSEIF(ICASRA.EQ.'NCBE')THEN 9806 CALL NCBRAN(NRAN,SHAPE1,SHAPE2,SHAPE3,ISEED,Y) 9807 ELSEIF(ICASRA.EQ.'DNCB')THEN 9808 CALL DNBRAN(NRAN,SHAPE1,SHAPE2,SHAPE3,SHAPE4,ISEED,Y) 9809 ELSEIF(ICASRA.EQ.'SDEX')THEN 9810 CALL SDERAN(NRAN,SHAPE1,ISEED,Y) 9811 ELSEIF(ICASRA.EQ.'ADEX')THEN 9812 CALL ADERAN(NRAN,SHAPE1,IADEDF,ISEED,Y) 9813 ELSEIF(ICASRA.EQ.'MAXW')THEN 9814 CALL MAXRAN(NRAN,ISEED,Y) 9815 ELSEIF(ICASRA.EQ.'RAYL')THEN 9816 CALL RAYRAN(NRAN,ISEED,Y) 9817 ELSEIF(ICASRA.EQ.'GALP')THEN 9818 CALL GALRAN(NRAN,SHAPE1,SHAPE2,IADEDF,ISEED,Y) 9819 ELSEIF(ICASRA.EQ.'MCLE')THEN 9820 CALL MCLRAN(NRAN,SHAPE1,ISEED,Y) 9821 ELSEIF(ICASRA.EQ.'BEIP')THEN 9822 CALL BEIRAN(NRAN,SHAPE1,SHAPE2,INT(SHAPE3+0.5),IBEIDF,ISEED,Y) 9823 ELSEIF(ICASRA.EQ.'BEIK')THEN 9824CCCCC CALL BEKRAN(NRAN,S1SQ,S2SQ,ANU,ISEED,Y) 9825 ELSEIF(ICASRA.EQ.'GMCL')THEN 9826 CALL GMCRAN(NRAN,ALPHA,A,ISEED,Y) 9827 ELSEIF(ICASRA.EQ.'HBOL')THEN 9828CCCCC CALL HBORAN(NRAN,ALPHA,XI,ISEED,Y) 9829 ELSEIF(ICASRA.EQ.'G5LO')THEN 9830 CALL GL5RAN(NRAN,SHAPE1,ISEED,Y) 9831 ELSEIF(ICASRA.EQ.'WAKE')THEN 9832 CALL WAKRAN(NRAN,SHAPE2,SHAPE1,SHAPE3,SHAPE4,ISEED,Y) 9833 ELSEIF(ICASRA.EQ.'BNOR')THEN 9834 CALL BNORAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9835 ELSEIF(ICASRA.EQ.'G2LO')THEN 9836 CALL GL2RAN(NRAN,SHAPE1,ISEED,Y) 9837 ELSEIF(ICASRA.EQ.'G3LO')THEN 9838 CALL GL3RAN(NRAN,SHAPE1,ISEED,Y) 9839 ELSEIF(ICASRA.EQ.'G4LO')THEN 9840 CALL GL4RAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9841 ELSEIF(ICASRA.EQ.'ALDE')THEN 9842 CALL ALDRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9843 ELSEIF(ICASRA.EQ.'BGEO')THEN 9844 CALL BGERAN(SHAPE1,SHAPE2,NRAN,ISEED,Y,IBGEDF) 9845 ELSEIF(ICASRA.EQ.'ZIPF')THEN 9846 CALL ZIPRAN(NRAN,SHAPE1,INT(SHAPE2+0.1),ISEED,Y) 9847 ELSEIF(ICASRA.EQ.'BTAN')THEN 9848 CALL BTARAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9849 ELSEIF(ICASRA.EQ.'LPOI')THEN 9850 CALL LPORAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9851 ELSEIF(ICASRA.EQ.'LICT')THEN 9852 CALL LCTRAN(NRAN,INT(SHAPE1+0.1),ISEED,Y) 9853 ELSEIF(ICASRA.EQ.'MATC')THEN 9854 CALL MATRAN(NRAN,INT(SHAPE1+0.1),ISEED,Y) 9855CCCCC ELSEIF(ICASRA.EQ.'OCCU')THEN 9856 ELSEIF(ICASRA.EQ.'LBET')THEN 9857 CALL LBERAN(NRAN,SHAPE1,SHAPE2,SHAPE3,SHAPE4,ISEED,Y) 9858 ELSEIF(ICASRA.EQ.'AEPP')THEN 9859 CALL PAPRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9860 ELSEIF(ICASRA.EQ.'LOST')THEN 9861 CALL LOSRAN(NRAN,SHAPE1,INT(SHAPE2+0.1),ISEED,Y) 9862 ELSEIF(ICASRA.EQ.'GLOS')THEN 9863 CALL GLSRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9864 ELSEIF(ICASRA.EQ.'GNBI')THEN 9865 CALL GNBRAN(NRAN,SHAPE1,SHAPE2,SHAPE3,ISEED,Y) 9866 ELSEIF(ICASRA.EQ.'GEET')THEN 9867 CALL GETRAN(NRAN,SHAPE1,SHAPE2,IGETDF,ISEED,Y) 9868 ELSEIF(ICASRA.EQ.'QBIN')THEN 9869 CALL QBIRAN(NRAN,SHAPE1,SHAPE2,SHAPE3,ISEED,Y) 9870 ELSEIF(ICASRA.EQ.'CONS')THEN 9871 CALL CONRAN(NRAN,SHAPE1,SHAPE2,ICONDF,ISEED,Y) 9872 ELSEIF(ICASRA.EQ.'LKAT')THEN 9873 CALL LKRAN(NRAN,SHAPE1,SHAPE2,SHAPE3,ISEED,Y) 9874 ELSEIF(ICASRA.EQ.'KATZ')THEN 9875 CALL KATRAN(NRAN,DBLE(SHAPE1),DBLE(SHAPE2),IKATDF,ISEED,Y) 9876 ELSEIF(ICASRA.EQ.'DISW')THEN 9877 CALL DIWRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9878 ELSEIF(ICASRA.EQ.'GLGP')THEN 9879 CALL GLGRAN(NRAN,SHAPE1,INT(SHAPE2+0.1),SHAPE3,ISEED,Y) 9880 ELSEIF(ICASRA.EQ.'TGNB')THEN 9881 CALL GNTRAN(NRAN,SHAPE1,SHAPE2,SHAPE3,INT(SHAPE4+0.1),ISEED,Y) 9882 ELSEIF(ICASRA.EQ.'TOPL')THEN 9883 CALL TOPRAN(NRAN,DBLE(SHAPE1),ISEED,Y) 9884 ELSEIF(ICASRA.EQ.'RGTL')THEN 9885 CALL RGTRAN(NRAN,DBLE(SHAPE1),DBLE(SHAPE2),ISEED,Y) 9886 ELSEIF(ICASRA.EQ.'GTOL')THEN 9887 CALL GTLRAN(NRAN,DBLE(SHAPE1),DBLE(SHAPE2),ISEED,Y) 9888 ELSEIF(ICASRA.EQ.'SLOP')THEN 9889 CALL SLORAN(NRAN,SHAPE1,ISEED,Y) 9890 ELSEIF(ICASRA.EQ.'OGIV')THEN 9891 CALL OGIRAN(NRAN,SHAPE1,ISEED,Y) 9892 ELSEIF(ICASRA.EQ.'TSSL')THEN 9893 CALL TSSRAN(NRAN,SHAPE2,SHAPE1,A,B,ISEED,Y) 9894 ELSEIF(ICASRA.EQ.'TSOG')THEN 9895CCCCC CALL TSORAN(NRAN,AN,THETA,ALOWLM,AUPPLM,ISEED,Y) 9896 CALL TSORAN(NRAN,AN,THETA,A,B,ISEED,Y) 9897 ELSEIF(ICASRA.EQ.'BUR2')THEN 9898 CALL BU2RAN(NRAN,SHAPE1,ISEED,Y) 9899 ELSEIF(ICASRA.EQ.'BUR3')THEN 9900 CALL BU3RAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9901 ELSEIF(ICASRA.EQ.'BU12')THEN 9902 CALL B12RAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9903 ELSEIF(ICASRA.EQ.'BU10')THEN 9904 CALL B10RAN(NRAN,SHAPE1,ISEED,Y) 9905 ELSEIF(ICASRA.EQ.'BUR4')THEN 9906 CALL BU4RAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9907 ELSEIF(ICASRA.EQ.'BUR5')THEN 9908 CALL BU5RAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9909 ELSEIF(ICASRA.EQ.'BUR6')THEN 9910 CALL BU6RAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9911 ELSEIF(ICASRA.EQ.'BUR7')THEN 9912 CALL BU7RAN(NRAN,SHAPE1,ISEED,Y) 9913 ELSEIF(ICASRA.EQ.'BUR8')THEN 9914 CALL BU8RAN(NRAN,SHAPE1,ISEED,Y) 9915 ELSEIF(ICASRA.EQ.'BU11')THEN 9916 CALL B11RAN(NRAN,SHAPE1,ISEED,Y) 9917 ELSEIF(ICASRA.EQ.'BUR9')THEN 9918 CALL BU9RAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9919 ELSEIF(ICASRA.EQ.'DPUN')THEN 9920 CALL DPURAN(NRAN,AM,AN,ALPHA,BETA,ISEED,Y) 9921 ELSEIF(ICASRA.EQ.'UTSP')THEN 9922 CALL UTSRAN(NRAN,SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,SHAPE6, 9923 1 ISEED,Y) 9924 ELSEIF(ICASRA.EQ.'KUMA')THEN 9925 CALL KUMRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9926 ELSEIF(ICASRA.EQ.'RPOW')THEN 9927 CALL RPORAN(NRAN,SHAPE1,ISEED,Y) 9928 ELSEIF(ICASRA.EQ.'MUTH')THEN 9929 CALL MUTRAN(NRAN,SHAPE1,ISEED,Y) 9930 ELSEIF(ICASRA.EQ.'LEXP')THEN 9931 CALL LEXRAN(NRAN,SHAPE1,ISEED,Y) 9932 ELSEIF(ICASRA.EQ.'TPAR')THEN 9933 CALL TNPRAN(NRAN,SHAPE1,SHAPE2,SHAPE3,ISEED,Y) 9934 ELSEIF(ICASRA.EQ.'BFRA')THEN 9935 CALL BFRRAN(NRAN,SHAPE1,SHAPE2,SHAPE3,ISEED,Y) 9936 ELSEIF(ICASRA.EQ.'L3EX')THEN 9937 CALL LE3RAN(NRAN,SHAPE1,SHAPE2,SHAPE3,ISEED,Y) 9938 ELSEIF(ICASRA.EQ.'KAPP')THEN 9939 CALL KAPRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9940 ELSEIF(ICASRA.EQ.'PEA3')THEN 9941 CALL PE3RAN(NRAN,SHAPE1,ISEED,Y) 9942 ELSEIF(ICASRA.EQ.'EEWE')THEN 9943 CALL EEWRAN(NRAN,SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,ISEED,Y) 9944 ELSEIF(ICASRA.EQ.'BFWE')THEN 9945 CALL BFWRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9946 ELSEIF(ICASRA.EQ.'ARCT')THEN 9947 CALL ATNRAN(NRAN,SHAPE1,SHAPE2,ISEED,Y) 9948 ELSEIF(ICASRA.EQ.'UNEX')THEN 9949 CALL UNERAN(NRAN,ISEED,A,B,SHAPE1,Y,TEMP1) 9950 ELSE 9951 IFOUND='NO' 9952 ENDIF 9953C 9954C ***************** 9955C ** STEP 90-- ** 9956C ** EXIT ** 9957C ***************** 9958C 9959 9000 CONTINUE 9960 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RAN2')THEN 9961 WRITE(ICOUT,999) 9962 CALL DPWRST('XXX','BUG ') 9963 WRITE(ICOUT,9011) 9964 9011 FORMAT('***** AT THE END OF DPRAND--') 9965 CALL DPWRST('XXX','BUG ') 9966 WRITE(ICOUT,9012)IERROR,IBUGA3,IFOUND 9967 9012 FORMAT('IERROR,IBUGA3,IFOUND = ',A4,2X,A4,2X,A4) 9968 CALL DPWRST('XXX','BUG ') 9969 ENDIF 9970C 9971 RETURN 9972 END 9973 SUBROUTINE DPRAW(X,FREQ,NX,IWRITE,MAXNXT,Y,NY,IBUGA3,IERROR) 9974C 9975C PURPOSE--SOMETIMES DATA IS MADE AVAILABLE AS A FREQUENCY 9976C TABLE. HOWEVER, FOR A PARTICULAR TYPE OF ANALSYSIS 9977C YOU MAY NEED THE DATA IN RAW (I.E., IF YOU HAVE 9978C A FREQUENCY OF 10 FOR THE VALUE 1, SIMPLY GENERATE 9979C THE VALUE 1 TEN TIMES). NEED TO CHECK FOR ARRAY 9980C EXCEEDING MAXIMUM ALLOWABLE. 9981C WRITTEN BY--JAMES J. FILLIBEN 9982C STATISTICAL ENGINEERING DIVISION 9983C INFORMATION TECHNOLOGY LABORATORY 9984C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 9985C GAITHERSBURG, MD 20899-8980 9986C PHONE--301-975-2855 9987C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 9988C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 9989C LANGUAGE--ANSI FORTRAN (1977) 9990C VERSION NUMBER--2004/4 9991C ORIGINAL VERSION--APRIL 2004. 9992C 9993C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 9994C 9995 CHARACTER*4 IWRITE 9996 CHARACTER*4 IBUGA3 9997 CHARACTER*4 IERROR 9998C 9999 CHARACTER*4 ISUBN1 10000 CHARACTER*4 ISUBN2 10001C 10002C--------------------------------------------------------------------- 10003C 10004 DIMENSION X(*) 10005 DIMENSION Y(*) 10006 DIMENSION FREQ(*) 10007C 10008C--------------------------------------------------------------------- 10009C 10010 INCLUDE 'DPCOP2.INC' 10011C 10012C-----START POINT----------------------------------------------------- 10013C 10014 ISUBN1='DPRA' 10015 ISUBN2='W ' 10016 IERROR='NO' 10017C 10018 IF(IBUGA3.EQ.'ON')THEN 10019 WRITE(ICOUT,999) 10020 999 FORMAT(1X) 10021 CALL DPWRST('XXX','BUG ') 10022 WRITE(ICOUT,51) 10023 51 FORMAT('***** AT THE BEGINNING OF DPRAW--') 10024 CALL DPWRST('XXX','BUG ') 10025 WRITE(ICOUT,52)IBUGA3,IWRITE 10026 52 FORMAT('IBUGA3,IWRITE = ',A4,2X,A4) 10027 CALL DPWRST('XXX','BUG ') 10028 WRITE(ICOUT,53)NX,MAXNXT 10029 53 FORMAT('NX,MAXNXT = ',2I8) 10030 CALL DPWRST('XXX','BUG ') 10031 DO55I=1,NX 10032 WRITE(ICOUT,56)I,X(I),FREQ(I) 10033 56 FORMAT('I,X(I), FREQ(I) = ',I8,2G15.7) 10034 CALL DPWRST('XXX','BUG ') 10035 55 CONTINUE 10036 ENDIF 10037C 10038C ************************************** 10039C ** CONVERT FROM FREQUENCY TO RAW ** 10040C ************************************** 10041C 10042 IF(NX.LT.1)THEN 10043 WRITE(ICOUT,999) 10044 CALL DPWRST('XXX','BUG ') 10045 WRITE(ICOUT,101) 10046 101 FORMAT('***** ERROR--NUMBER OF CLASSES FOR FREQUENCY TO ', 10047 1 'RAW COMMAND IS LESS THAN 1.') 10048 CALL DPWRST('XXX','BUG ') 10049 IERROR='YES' 10050 GOTO9000 10051 ENDIF 10052C 10053 NY=0 10054 DO200I=1,NX 10055C 10056 NTEMP=INT(FREQ(I)+0.5) 10057 IF(NTEMP.LT.1)THEN 10058 WRITE(ICOUT,999) 10059 CALL DPWRST('XXX','BUG ') 10060 WRITE(ICOUT,201)I,FREQ(I) 10061 201 FORMAT('***** ERROR--CLASS ',I8,' HAS NON-POSITIVE ', 10062 1 'FREQUENCY (= ',F12.5,')') 10063 CALL DPWRST('XXX','BUG ') 10064 IERROR='YES' 10065 GOTO9000 10066 ENDIF 10067C 10068 NTOT=NY+NTEMP 10069 IF(NTOT.GT.MAXNXT)THEN 10070 WRITE(ICOUT,999) 10071 CALL DPWRST('XXX','BUG ') 10072 WRITE(ICOUT,203)MAXNXT 10073 203 FORMAT('***** ERROR--MAXIMUM NUMBER OF ROWS (',I8,') ') 10074 CALL DPWRST('XXX','BUG ') 10075 WRITE(ICOUT,205) 10076 205 FORMAT(' IN CONVERTING FREQUENCY DATA TO RAW DATA.') 10077 CALL DPWRST('XXX','BUG ') 10078 IERROR='YES' 10079 GOTO9000 10080 ENDIF 10081C 10082 DO210J=1,NTEMP 10083 NY=NY+1 10084 Y(NY)=X(I) 10085 210 CONTINUE 10086 200 CONTINUE 10087C 10088C ***************** 10089C ** STEP 90-- ** 10090C ** EXIT. ** 10091C ***************** 10092C 10093 9000 CONTINUE 10094C 10095 IF(IBUGA3.EQ.'ON')THEN 10096 WRITE(ICOUT,999) 10097 CALL DPWRST('XXX','BUG ') 10098 WRITE(ICOUT,9011) 10099 9011 FORMAT('***** AT THE END OF DPRAW--') 10100 CALL DPWRST('XXX','BUG ') 10101 WRITE(ICOUT,9012)IBUGA3,IERROR 10102 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 10103 CALL DPWRST('XXX','BUG ') 10104 WRITE(ICOUT,9013)NX,NY 10105 9013 FORMAT('NX,NY = ',2I8) 10106 CALL DPWRST('XXX','BUG ') 10107 DO9015I=1,NY 10108 WRITE(ICOUT,9016)I,Y(I) 10109 9016 FORMAT('I,Y(I) = ',I8,E15.7) 10110 CALL DPWRST('XXX','BUG ') 10111 9015 CONTINUE 10112 ENDIF 10113C 10114 RETURN 10115 END 10116 SUBROUTINE DPRBCO(IHARG,NUMARG,IDERBC,MAXREG,IREBCO, 10117 1IBUGP2,IFOUND,IERROR) 10118C 10119C PURPOSE--DEFINE THE REGION BORDER COLORS = THE COLORS 10120C OF THE BORDER LINE AROUND THE REGIONS. 10121C THESE ARE LOCATED IN THE VECTOR IREBCO(.). 10122C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 10123C --NUMARG 10124C --IDERBC 10125C --MAXREG 10126C --IBUGP2 ('ON' OR 'OFF' ) 10127C OUTPUT ARGUMENTS--IREBCO (A CHARACTER VECTOR) 10128C --IFOUND ('YES' OR 'NO' ) 10129C --IERROR ('YES' OR 'NO' ) 10130C WRITTEN BY--JAMES J. FILLIBEN 10131C STATISTICAL ENGINEERING DIVISION 10132C INFORMATION TECHNOLOGY LABORATORY 10133C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10134C GAITHERSBURG, MD 20899-8980 10135C PHONE--301-975-2855 10136C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 10137C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 10138C LANGUAGE--ANSI FORTRAN (1977) 10139C VERSION NUMBER--82/7 10140C ORIGINAL VERSION--DECEMBER 1983. 10141C UPDATED --MAY 1994. PRINT MESSAGE STATING THAT 10142C THIS IS AN OBSOLETE COMMAND 10143C (USE LINE COLOR COMMAND). 10144C 10145C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10146C 10147 CHARACTER*4 IHARG 10148 CHARACTER*4 IDERBC 10149 CHARACTER*4 IREBCO 10150C 10151 CHARACTER*4 IBUGP2 10152 CHARACTER*4 IFOUND 10153 CHARACTER*4 IERROR 10154C 10155 CHARACTER*4 IHOLD1 10156 CHARACTER*4 IHOLD2 10157C 10158 CHARACTER*4 ISUBN1 10159 CHARACTER*4 ISUBN2 10160 CHARACTER*4 ISTEPN 10161C 10162 DIMENSION IHARG(*) 10163 DIMENSION IREBCO(*) 10164C 10165C--------------------------------------------------------------------- 10166C 10167 INCLUDE 'DPCOP2.INC' 10168C 10169C-----START POINT----------------------------------------------------- 10170C 10171 IFOUND='NO' 10172 IERROR='NO' 10173 ISUBN1='DPRB' 10174 ISUBN2='CO ' 10175C 10176 NUMREG=0 10177 IHOLD1='-999' 10178 IHOLD2='-999' 10179C 10180 IF(IBUGP2.EQ.'OFF')GOTO90 10181 WRITE(ICOUT,999) 10182 999 FORMAT(1X) 10183 CALL DPWRST('XXX','BUG ') 10184 WRITE(ICOUT,51) 10185 51 FORMAT('***** AT THE BEGINNING OF DPRBCO--') 10186 CALL DPWRST('XXX','BUG ') 10187 WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 10188 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 10189 CALL DPWRST('XXX','BUG ') 10190 WRITE(ICOUT,53)MAXREG,NUMREG 10191 53 FORMAT('MAXREG,NUMREG = ',I8,I8) 10192 CALL DPWRST('XXX','BUG ') 10193 WRITE(ICOUT,54)IHOLD1,IHOLD2 10194 54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 10195 CALL DPWRST('XXX','BUG ') 10196 WRITE(ICOUT,55)IDERBC 10197 55 FORMAT('IDERBC = ',A4) 10198 CALL DPWRST('XXX','BUG ') 10199 WRITE(ICOUT,60)NUMARG 10200 60 FORMAT('NUMARG = ',I8) 10201 CALL DPWRST('XXX','BUG ') 10202 DO65I=1,NUMARG 10203 WRITE(ICOUT,66)IHARG(I) 10204 66 FORMAT('IHARG(I) = ',A4) 10205 CALL DPWRST('XXX','BUG ') 10206 65 CONTINUE 10207 WRITE(ICOUT,70)IREBCO(1) 10208 70 FORMAT('IREBCO(1) = ',A4) 10209 CALL DPWRST('XXX','BUG ') 10210 DO75I=1,10 10211 WRITE(ICOUT,76)I,IREBCO(I) 10212 76 FORMAT('I,IREBCO(I) = ',I8,2X,A4) 10213 CALL DPWRST('XXX','BUG ') 10214 75 CONTINUE 10215 90 CONTINUE 10216C 10217C ************************************** 10218C ** STEP 1-- ** 10219C ** BRANCH TO THE APPROPRIATE CASE ** 10220C ************************************** 10221C 10222 ISTEPN='1' 10223 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10224C 10225 IF(NUMARG.LE.1)GOTO9000 10226 IF(NUMARG.EQ.2)GOTO1120 10227 IF(NUMARG.EQ.3)GOTO1130 10228 IF(NUMARG.EQ.4)GOTO1140 10229 GOTO1150 10230C 10231 1120 CONTINUE 10232 GOTO1200 10233C 10234 1130 CONTINUE 10235 IF(IHARG(3).EQ.'ALL')IHOLD1=' ' 10236 IF(IHARG(3).EQ.'ALL')GOTO1300 10237 GOTO1200 10238C 10239 1140 CONTINUE 10240 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) 10241 IF(IHARG(3).EQ.'ALL')GOTO1300 10242 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) 10243 IF(IHARG(4).EQ.'ALL')GOTO1300 10244 GOTO1200 10245C 10246 1150 CONTINUE 10247 GOTO1200 10248C 10249C ************************************************* 10250C ** STEP 2-- ** 10251C ** TREAT THE SINGLE SPECIFICATION CASE ** 10252C ************************************************* 10253C 10254 1200 CONTINUE 10255 ISTEPN='2' 10256 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10257C 10258 IF(NUMARG.LE.2)GOTO1210 10259 GOTO1220 10260C 10261 1210 CONTINUE 10262 NUMREG=1 10263 IREBCO(1)=IDERBC 10264 GOTO1270 10265C 10266 1220 CONTINUE 10267 NUMREG=NUMARG-2 10268 IF(NUMREG.GT.MAXREG)NUMREG=MAXREG 10269 DO1225I=1,NUMREG 10270 J=I+2 10271 IHOLD1=IHARG(J) 10272 IHOLD2=IHOLD1 10273 IF(IHOLD1.EQ.'ON')IHOLD2=IDERBC 10274 IF(IHOLD1.EQ.'OFF')IHOLD2=IDERBC 10275 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDERBC 10276 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDERBC 10277 IREBCO(I)=IHOLD2 10278 1225 CONTINUE 10279 GOTO1270 10280C 10281 1270 CONTINUE 10282 IF(IFEEDB.EQ.'OFF')GOTO1279 10283 WRITE(ICOUT,999) 10284 CALL DPWRST('XXX','BUG ') 10285 DO1278I=1,NUMREG 10286 WRITE(ICOUT,1276)I,IREBCO(I) 10287 1276 FORMAT('THE COLOR OF REGION BORDER ',I6, 10288 1' HAS JUST BEEN SET TO ',A4) 10289 CALL DPWRST('XXX','BUG ') 10290 1278 CONTINUE 10291 1279 CONTINUE 10292 IFOUND='YES' 10293 GOTO9000 10294C 10295C ************************** 10296C ** STEP 3-- ** 10297C ** TREAT THE ALL CASE ** 10298C ************************** 10299C 10300 1300 CONTINUE 10301 ISTEPN='3' 10302 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10303C 10304 NUMREG=MAXREG 10305 IHOLD2=IHOLD1 10306 IF(IHOLD1.EQ.'ON')IHOLD2=IDERBC 10307 IF(IHOLD1.EQ.'OFF')IHOLD2=IDERBC 10308 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDERBC 10309 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDERBC 10310 DO1315I=1,NUMREG 10311 IREBCO(I)=IHOLD2 10312 1315 CONTINUE 10313 GOTO1370 10314C 10315 1370 CONTINUE 10316 IF(IFEEDB.EQ.'OFF')GOTO1319 10317 WRITE(ICOUT,999) 10318 CALL DPWRST('XXX','BUG ') 10319 I=1 10320 WRITE(ICOUT,1316)IREBCO(I) 10321 1316 FORMAT('THE COLOR OF ALL REGION BORDERS', 10322 1' HAS JUST BEEN SET TO ',A4) 10323 CALL DPWRST('XXX','BUG ') 10324 1319 CONTINUE 10325 IFOUND='YES' 10326CCCCC FOLLOWING SECTION ADDED MAY 1994. 10327 WRITE(ICOUT,2100) 10328 2100 FORMAT('****** WARNING. THE REGION BORDER COLOR COMMAND IS') 10329 CALL DPWRST('XXX','BUG ') 10330 WRITE(ICOUT,2101) 10331 2101 FORMAT(' NOT USED. THE BORDER COLOR FOR REGIONS IS') 10332 CALL DPWRST('XXX','BUG ') 10333 WRITE(ICOUT,2102) 10334 2102 FORMAT(' SET WITH THE LINE COLOR COMMAND. ******') 10335 CALL DPWRST('XXX','BUG ') 10336 GOTO9000 10337C 10338C ***************** 10339C ** STEP 90-- ** 10340C ** EXIT ** 10341C ***************** 10342C 10343 9000 CONTINUE 10344 IF(IBUGP2.EQ.'OFF')GOTO9090 10345 WRITE(ICOUT,9011) 10346 9011 FORMAT('***** AT THE END OF DPRBCO--') 10347 CALL DPWRST('XXX','BUG ') 10348 WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 10349 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 10350 CALL DPWRST('XXX','BUG ') 10351 WRITE(ICOUT,9013)MAXREG,NUMREG 10352 9013 FORMAT('MAXREG,NUMREG = ',I8,I8) 10353 CALL DPWRST('XXX','BUG ') 10354 WRITE(ICOUT,9014)IHOLD1,IHOLD2 10355 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 10356 CALL DPWRST('XXX','BUG ') 10357 WRITE(ICOUT,9015)IDERBC 10358 9015 FORMAT('IDERBC = ',A4) 10359 CALL DPWRST('XXX','BUG ') 10360 WRITE(ICOUT,9020)NUMARG 10361 9020 FORMAT('NUMARG = ',I8) 10362 CALL DPWRST('XXX','BUG ') 10363 DO9025I=1,NUMARG 10364 WRITE(ICOUT,9026)IHARG(I) 10365 9026 FORMAT('IHARG(I) = ',A4) 10366 CALL DPWRST('XXX','BUG ') 10367 9025 CONTINUE 10368 WRITE(ICOUT,9030)IREBCO(1) 10369 9030 FORMAT('IREBCO(1) = ',A4) 10370 CALL DPWRST('XXX','BUG ') 10371 DO9035I=1,10 10372 WRITE(ICOUT,9036)I,IREBCO(I) 10373 9036 FORMAT('I,IREBCO(I) = ',I8,2X,A4) 10374 CALL DPWRST('XXX','BUG ') 10375 9035 CONTINUE 10376 9090 CONTINUE 10377C 10378 RETURN 10379 END 10380 SUBROUTINE DPRBLI(IHARG,IHARG2,NUMARG,IDERBL,MAXREG,IREBLI, 10381CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC 10382CCCCC SUBROUTINE DPRBLI(IHARG,NUMARG,IDERBL,MAXREG,IREBLI, 10383 1IBUGP2,IFOUND,IERROR) 10384C 10385C PURPOSE--DEFINE THE BORDER LINES = THE LINES TYPES 10386C OF THE BORDER AROUND THE REGIONS. 10387C THESE ARE LOCATED IN THE VECTOR IREBLI(.). 10388C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 10389C --NUMARG 10390C --IDERBL 10391C --MAXREG 10392C --IBUGP2 ('ON' OR 'OFF' ) 10393C OUTPUT ARGUMENTS--IREBLI (A CHARACTER VECTOR) 10394C --IFOUND ('YES' OR 'NO' ) 10395C --IERROR ('YES' OR 'NO' ) 10396C WRITTEN BY--JAMES J. FILLIBEN 10397C STATISTICAL ENGINEERING DIVISION 10398C INFORMATION TECHNOLOGY LABORATORY 10399C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10400C GAITHERSBURG, MD 20899-8980 10401C PHONE--301-975-2855 10402C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 10403C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 10404C LANGUAGE--ANSI FORTRAN (1977) 10405C VERSION NUMBER--82/7 10406C ORIGINAL VERSION--DECEMBER 1983. 10407C UPDATED --MAY 1994. PRINT MESSAGE SAYING TO USE THE 10408C LINE COMMAND INSTEAD. 10409C UPDATED --AUGUST 1995. DASH2 BUG 10410C 10411C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10412C 10413 CHARACTER*4 IHARG 10414CCCCC AUGUST 1995. ADD FOLLOWING LINE 10415 CHARACTER*4 IHARG2 10416 CHARACTER*4 IDERBL 10417 CHARACTER*4 IREBLI 10418C 10419 CHARACTER*4 IBUGP2 10420 CHARACTER*4 IFOUND 10421 CHARACTER*4 IERROR 10422C 10423 CHARACTER*4 IHOLD1 10424 CHARACTER*4 IHOLD2 10425C 10426 CHARACTER*4 ISUBN1 10427 CHARACTER*4 ISUBN2 10428 CHARACTER*4 ISTEPN 10429C 10430 DIMENSION IHARG(*) 10431CCCCC AUGUST 1995. ADD FOLLOWING LINE 10432 DIMENSION IHARG2(*) 10433 DIMENSION IREBLI(*) 10434C 10435C--------------------------------------------------------------------- 10436C 10437 INCLUDE 'DPCOP2.INC' 10438C 10439C-----START POINT----------------------------------------------------- 10440C 10441 IFOUND='NO' 10442 IERROR='NO' 10443 ISUBN1='DPRB' 10444 ISUBN2='LI ' 10445C 10446 NUMREG=0 10447 IHOLD1='-999' 10448 IHOLD2='-999' 10449C 10450 IF(IBUGP2.EQ.'OFF')GOTO90 10451 WRITE(ICOUT,999) 10452 999 FORMAT(1X) 10453 CALL DPWRST('XXX','BUG ') 10454 WRITE(ICOUT,51) 10455 51 FORMAT('***** AT THE BEGINNING OF DPRBLI--') 10456 CALL DPWRST('XXX','BUG ') 10457 WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 10458 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 10459 CALL DPWRST('XXX','BUG ') 10460 WRITE(ICOUT,53)MAXREG,NUMREG 10461 53 FORMAT('MAXREG,NUMREG = ',I8,I8) 10462 CALL DPWRST('XXX','BUG ') 10463 WRITE(ICOUT,54)IHOLD1,IHOLD2 10464 54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 10465 CALL DPWRST('XXX','BUG ') 10466 WRITE(ICOUT,55)IDERBL 10467 55 FORMAT('IDERBL = ',A4) 10468 CALL DPWRST('XXX','BUG ') 10469 WRITE(ICOUT,60)NUMARG 10470 60 FORMAT('NUMARG = ',I8) 10471 CALL DPWRST('XXX','BUG ') 10472 DO65I=1,NUMARG 10473 WRITE(ICOUT,66)IHARG(I) 10474 66 FORMAT('IHARG(I) = ',A4) 10475 CALL DPWRST('XXX','BUG ') 10476 65 CONTINUE 10477 WRITE(ICOUT,70)IREBLI(1) 10478 70 FORMAT('IREBLI(1) = ',A4) 10479 CALL DPWRST('XXX','BUG ') 10480 DO75I=1,10 10481 WRITE(ICOUT,76)I,IREBLI(I) 10482 76 FORMAT('I,IREBLI(I) = ',I8,2X,A4) 10483 CALL DPWRST('XXX','BUG ') 10484 75 CONTINUE 10485 90 CONTINUE 10486C 10487C ************************************** 10488C ** STEP 1-- ** 10489C ** BRANCH TO THE APPROPRIATE CASE ** 10490C ************************************** 10491C 10492 ISTEPN='1' 10493 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10494C 10495 IF(NUMARG.LE.2)GOTO9000 10496 IF(NUMARG.EQ.3)GOTO1130 10497 IF(NUMARG.EQ.4)GOTO1140 10498 IF(NUMARG.EQ.5)GOTO1150 10499 GOTO1160 10500C 10501 1130 CONTINUE 10502 GOTO1200 10503C 10504 1140 CONTINUE 10505 IF(IHARG(5).EQ.'ALL')IHOLD1=' ' 10506 IF(IHARG(5).EQ.'ALL')GOTO1300 10507 GOTO1200 10508C 10509 1150 CONTINUE 10510CCCCC APRIL 1996. CHANGE IHOLD TO IHOLD1 BELOW 10511 IF(IHARG(5).EQ.'ALL')THEN 10512 IHOLD1=IHARG(6) 10513 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'2')IHOLD1='DA2' 10514 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'3')IHOLD1='DA3' 10515 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'4')IHOLD1='DA4' 10516 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'5')IHOLD1='DA5' 10517 GOTO1300 10518 ENDIF 10519 IF(IHARG(6).EQ.'ALL')THEN 10520 IHOLD1=IHARG(5) 10521 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'2')IHOLD1='DA2' 10522 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'3')IHOLD1='DA3' 10523 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'4')IHOLD1='DA4' 10524 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'5')IHOLD1='DA5' 10525 GOTO1300 10526 ENDIF 10527 GOTO1200 10528C 10529 1160 CONTINUE 10530 GOTO1200 10531C 10532C ************************************************* 10533C ** STEP 2-- ** 10534C ** TREAT THE SINGLE SPECIFICATION CASE ** 10535C ************************************************* 10536C 10537 1200 CONTINUE 10538 ISTEPN='2' 10539 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10540C 10541 IF(NUMARG.LE.3)GOTO1210 10542 GOTO1220 10543C 10544 1210 CONTINUE 10545 NUMREG=1 10546 IREBLI(1)=' ' 10547 GOTO1270 10548C 10549 1220 CONTINUE 10550 NUMREG=NUMARG-3 10551 IF(NUMREG.GT.MAXREG)NUMREG=MAXREG 10552 DO1225I=1,NUMREG 10553 J=I+3 10554 IHOLD1=IHARG(J) 10555 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'2')IHOLD1='DA2' 10556 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'3')IHOLD1='DA3' 10557 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'4')IHOLD1='DA4' 10558 IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'5')IHOLD1='DA5' 10559 IHOLD2=IHOLD1 10560 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' 10561 IF(IHOLD1.EQ.'OFF')IHOLD2=' ' 10562 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDERBL 10563 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDERBL 10564 IREBLI(I)=IHOLD2 10565 1225 CONTINUE 10566 GOTO1270 10567C 10568 1270 CONTINUE 10569 IF(IFEEDB.EQ.'OFF')GOTO1279 10570 WRITE(ICOUT,999) 10571 CALL DPWRST('XXX','BUG ') 10572 DO1278I=1,NUMREG 10573 WRITE(ICOUT,1276)I,IREBLI(I) 10574 1276 FORMAT('THE LINE TYPE FOR REGION BORDER ',I6, 10575 1' HAS JUST BEEN SET TO ',A4) 10576 CALL DPWRST('XXX','BUG ') 10577 1278 CONTINUE 10578 1279 CONTINUE 10579 IFOUND='YES' 10580 GOTO9000 10581C 10582C ************************** 10583C ** STEP 3-- ** 10584C ** TREAT THE ALL CASE ** 10585C ************************** 10586C 10587 1300 CONTINUE 10588 ISTEPN='3' 10589 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10590C 10591 NUMREG=MAXREG 10592 IHOLD2=IHOLD1 10593 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' 10594 IF(IHOLD1.EQ.'OFF')IHOLD2=' ' 10595 IF(IHOLD1.EQ.'AUTO')IHOLD2=IDERBL 10596 IF(IHOLD1.EQ.'DEFA')IHOLD2=IDERBL 10597 DO1315I=1,NUMREG 10598 IREBLI(I)=IHOLD2 10599 1315 CONTINUE 10600 GOTO1370 10601C 10602 1370 CONTINUE 10603 IF(IFEEDB.EQ.'OFF')GOTO1319 10604 WRITE(ICOUT,999) 10605 CALL DPWRST('XXX','BUG ') 10606 I=1 10607 WRITE(ICOUT,1316)IREBLI(I) 10608 1316 FORMAT('THE LINE TYPE FOR ALL REGION BORDERS', 10609 1' HAS JUST BEEN SET TO ',A4) 10610 CALL DPWRST('XXX','BUG ') 10611 1319 CONTINUE 10612 IFOUND='YES' 10613CCCCC ADD FOLLOWING SECTION MAY 1994. 10614 WRITE(ICOUT,2100) 10615 2100 FORMAT('****** WARNING. THE REGION BORDER LINE COMMAND IS') 10616 CALL DPWRST('XXX','BUG ') 10617 WRITE(ICOUT,2101) 10618 2101 FORMAT(' NOT USED. THE BORDER LINE STYLE FOR') 10619 CALL DPWRST('XXX','BUG ') 10620 WRITE(ICOUT,2102) 10621 2102 FORMAT(' REGIONS IS SET WITH THE LINE COLOR COMMAND.*****') 10622 CALL DPWRST('XXX','BUG ') 10623 GOTO9000 10624C 10625C ***************** 10626C ** STEP 90-- ** 10627C ** EXIT ** 10628C ***************** 10629C 10630 9000 CONTINUE 10631 IF(IBUGP2.EQ.'OFF')GOTO9090 10632 WRITE(ICOUT,9011) 10633 9011 FORMAT('***** AT THE END OF DPRBLI--') 10634 CALL DPWRST('XXX','BUG ') 10635 WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 10636 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 10637 CALL DPWRST('XXX','BUG ') 10638 WRITE(ICOUT,9013)MAXREG,NUMREG 10639 9013 FORMAT('MAXREG,NUMREG = ',I8,I8) 10640 CALL DPWRST('XXX','BUG ') 10641 WRITE(ICOUT,9014)IHOLD1,IHOLD2 10642 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) 10643 CALL DPWRST('XXX','BUG ') 10644 WRITE(ICOUT,9015)IDERBL 10645 9015 FORMAT('IDERBL = ',A4) 10646 CALL DPWRST('XXX','BUG ') 10647 WRITE(ICOUT,9020)NUMARG 10648 9020 FORMAT('NUMARG = ',I8) 10649 CALL DPWRST('XXX','BUG ') 10650 DO9025I=1,NUMARG 10651 WRITE(ICOUT,9026)IHARG(I) 10652 9026 FORMAT('IHARG(I) = ',A4) 10653 CALL DPWRST('XXX','BUG ') 10654 9025 CONTINUE 10655 WRITE(ICOUT,9030)IREBLI(1) 10656 9030 FORMAT('IREBLI(1) = ',A4) 10657 CALL DPWRST('XXX','BUG ') 10658 DO9035I=1,10 10659 WRITE(ICOUT,9036)I,IREBLI(I) 10660 9036 FORMAT('I,IREBLI(I) = ',I8,2X,A4) 10661 CALL DPWRST('XXX','BUG ') 10662 9035 CONTINUE 10663 9090 CONTINUE 10664C 10665 RETURN 10666 END 10667 SUBROUTINE DPRBTH(IHARG,IARGT,ARG,NUMARG,PDERBT,MAXREG,PREBTH, 10668 1IBUGP2,IFOUND,IERROR) 10669C 10670C PURPOSE--DEFINE THE REGION (BORDER) LINE THICKNESSES = THE THICKNESSES 10671C OF THE BORDER LINE AROUND THE REGIONS. 10672C THESE ARE LOCATED IN THE VECTOR PREBTH(.). 10673C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) 10674C --IARGT (A CHARACTER VECTOR) 10675C --ARG 10676C --NUMARG 10677C --PDERBT 10678C --MAXREG 10679C --IBUGP2 ('ON' OR 'OFF' ) 10680C OUTPUT ARGUMENTS--PREBTH (A FLOATING POINT VECTOR) 10681C --IFOUND ('YES' OR 'NO' ) 10682C --IERROR ('YES' OR 'NO' ) 10683C WRITTEN BY--JAMES J. FILLIBEN 10684C STATISTICAL ENGINEERING DIVISION 10685C INFORMATION TECHNOLOGY LABORATORY 10686C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10687C GAITHERSBURG, MD 20899-8980 10688C PHONE--301-975-2855 10689C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 10690C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 10691C LANGUAGE--ANSI FORTRAN (1977) 10692C VERSION NUMBER--82/7 10693C ORIGINAL VERSION--DECEMBER 1983. 10694C UPDATED --MAY 1994. PRINT MESSAGE TO USE LINE 10695C THICKNESS COMMAND INSTEAD. 10696C 10697C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10698C 10699 CHARACTER*4 IHARG 10700 CHARACTER*4 IARGT 10701C 10702 CHARACTER*4 IBUGP2 10703 CHARACTER*4 IFOUND 10704 CHARACTER*4 IERROR 10705C 10706 CHARACTER*4 IHOLD1 10707C 10708 CHARACTER*4 ISUBN1 10709 CHARACTER*4 ISUBN2 10710 CHARACTER*4 ISTEPN 10711C 10712 DIMENSION IHARG(*) 10713 DIMENSION IARGT(*) 10714 DIMENSION ARG(*) 10715 DIMENSION PREBTH(*) 10716C 10717C--------------------------------------------------------------------- 10718C 10719 INCLUDE 'DPCOP2.INC' 10720C 10721C-----START POINT----------------------------------------------------- 10722C 10723 IFOUND='NO' 10724 IERROR='NO' 10725 ISUBN1='DPRB' 10726 ISUBN2='TH ' 10727C 10728 NUMREG=0 10729 IHOLD1='-999' 10730 HOLD1=-999.0 10731 HOLD2=-999.0 10732C 10733 IF(IBUGP2.EQ.'OFF')GOTO90 10734 WRITE(ICOUT,999) 10735 999 FORMAT(1X) 10736 CALL DPWRST('XXX','BUG ') 10737 WRITE(ICOUT,51) 10738 51 FORMAT('***** AT THE BEGINNING OF DPRBTH--') 10739 CALL DPWRST('XXX','BUG ') 10740 WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 10741 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 10742 CALL DPWRST('XXX','BUG ') 10743 WRITE(ICOUT,53)MAXREG,NUMREG 10744 53 FORMAT('MAXREG,NUMREG = ',I8,I8) 10745 CALL DPWRST('XXX','BUG ') 10746 WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2 10747 54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) 10748 CALL DPWRST('XXX','BUG ') 10749 WRITE(ICOUT,55)PDERBT 10750 55 FORMAT('PDERBT = ',E15.7) 10751 CALL DPWRST('XXX','BUG ') 10752 WRITE(ICOUT,60)NUMARG 10753 60 FORMAT('NUMARG = ',I8) 10754 CALL DPWRST('XXX','BUG ') 10755 DO65I=1,NUMARG 10756 WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I) 10757 66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) 10758 CALL DPWRST('XXX','BUG ') 10759 65 CONTINUE 10760 WRITE(ICOUT,70)PREBTH(1) 10761 70 FORMAT('PREBTH(1) = ',E15.7) 10762 CALL DPWRST('XXX','BUG ') 10763 DO75I=1,10 10764 WRITE(ICOUT,76)I,PREBTH(I) 10765 76 FORMAT('I,PREBTH(I) = ',I8,2X,E15.7) 10766 CALL DPWRST('XXX','BUG ') 10767 75 CONTINUE 10768 90 CONTINUE 10769C 10770C ************************************** 10771C ** STEP 1-- ** 10772C ** BRANCH TO THE APPROPRIATE CASE ** 10773C ************************************** 10774C 10775 ISTEPN='1' 10776 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10777C 10778 IF(NUMARG.LE.1)GOTO9000 10779 IF(NUMARG.EQ.2)GOTO1120 10780 IF(NUMARG.EQ.3)GOTO1130 10781 IF(NUMARG.EQ.4)GOTO1140 10782 GOTO1150 10783C 10784 1120 CONTINUE 10785 GOTO1200 10786C 10787 1130 CONTINUE 10788 IF(IHARG(3).EQ.'ALL')IHOLD1=' ' 10789 IF(IHARG(3).EQ.'ALL')HOLD1=PDERBT 10790 IF(IHARG(3).EQ.'ALL')GOTO1300 10791 GOTO1200 10792C 10793 1140 CONTINUE 10794 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) 10795 IF(IHARG(3).EQ.'ALL')HOLD1=ARG(4) 10796 IF(IHARG(3).EQ.'ALL')GOTO1300 10797 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) 10798 IF(IHARG(4).EQ.'ALL')HOLD1=ARG(3) 10799 IF(IHARG(4).EQ.'ALL')GOTO1300 10800 GOTO1200 10801C 10802 1150 CONTINUE 10803 GOTO1200 10804C 10805C ************************************************* 10806C ** STEP 2-- ** 10807C ** TREAT THE SINGLE SPECIFICATION CASE ** 10808C ************************************************* 10809C 10810 1200 CONTINUE 10811 ISTEPN='2' 10812 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10813C 10814 IF(NUMARG.LE.2)GOTO1210 10815 GOTO1220 10816C 10817 1210 CONTINUE 10818 NUMREG=1 10819 PREBTH(1)=PDERBT 10820 GOTO1270 10821C 10822 1220 CONTINUE 10823 NUMREG=NUMARG-2 10824 IF(NUMREG.GT.MAXREG)NUMREG=MAXREG 10825 DO1225I=1,NUMREG 10826 J=I+2 10827 IHOLD1=IHARG(J) 10828 HOLD1=ARG(J) 10829 HOLD2=HOLD1 10830 IF(IHOLD1.EQ.'ON')HOLD2=PDERBT 10831 IF(IHOLD1.EQ.'OFF')HOLD2=PDERBT 10832 IF(IHOLD1.EQ.'AUTO')HOLD2=PDERBT 10833 IF(IHOLD1.EQ.'DEFA')HOLD2=PDERBT 10834 PREBTH(I)=HOLD2 10835 1225 CONTINUE 10836 GOTO1270 10837C 10838 1270 CONTINUE 10839 IF(IFEEDB.EQ.'OFF')GOTO1279 10840 WRITE(ICOUT,999) 10841 CALL DPWRST('XXX','BUG ') 10842 DO1278I=1,NUMREG 10843 WRITE(ICOUT,1276)I,PREBTH(I) 10844 1276 FORMAT('THE THICKNESS OF REGION BORDER ',I6, 10845 1' HAS JUST BEEN SET TO ',E15.7) 10846 CALL DPWRST('XXX','BUG ') 10847 1278 CONTINUE 10848 1279 CONTINUE 10849 IFOUND='YES' 10850 GOTO9000 10851C 10852C ************************** 10853C ** STEP 3-- ** 10854C ** TREAT THE ALL CASE ** 10855C ************************** 10856C 10857 1300 CONTINUE 10858 ISTEPN='3' 10859 IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10860C 10861 NUMREG=MAXREG 10862 HOLD2=HOLD1 10863 IF(IHOLD1.EQ.'ON')HOLD2=PDERBT 10864 IF(IHOLD1.EQ.'OFF')HOLD2=PDERBT 10865 IF(IHOLD1.EQ.'AUTO')HOLD2=PDERBT 10866 IF(IHOLD1.EQ.'DEFA')HOLD2=PDERBT 10867 DO1315I=1,NUMREG 10868 PREBTH(I)=HOLD2 10869 1315 CONTINUE 10870 GOTO1370 10871C 10872 1370 CONTINUE 10873 IF(IFEEDB.EQ.'OFF')GOTO1319 10874 WRITE(ICOUT,999) 10875 CALL DPWRST('XXX','BUG ') 10876 I=1 10877 WRITE(ICOUT,1316)PREBTH(I) 10878 1316 FORMAT('THE THICKNESS OF ALL REGION BORDERS', 10879 1' HAS JUST BEEN SET TO ',E15.7) 10880 CALL DPWRST('XXX','BUG ') 10881 1319 CONTINUE 10882 IFOUND='YES' 10883CCCCC ADD FOLLOWING SECTION MAY 1994. 10884 WRITE(ICOUT,2100) 10885 2100 FORMAT('****** WARNING. THE REGION THICKNESS COMMAND IS') 10886 CALL DPWRST('XXX','BUG ') 10887 WRITE(ICOUT,2101) 10888 2101 FORMAT(' NOT USED. THE BORDER THICKNESS FOR REGIONS') 10889 CALL DPWRST('XXX','BUG ') 10890 WRITE(ICOUT,2102) 10891 2102 FORMAT(' IS SET WITH THE LINE THICKNESS COMMAND. ******') 10892 CALL DPWRST('XXX','BUG ') 10893 GOTO9000 10894C 10895C ***************** 10896C ** STEP 90-- ** 10897C ** EXIT ** 10898C ***************** 10899C 10900 9000 CONTINUE 10901 IF(IBUGP2.EQ.'OFF')GOTO9090 10902 WRITE(ICOUT,9011) 10903 9011 FORMAT('***** AT THE END OF DPRBTH--') 10904 CALL DPWRST('XXX','BUG ') 10905 WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 10906 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 10907 CALL DPWRST('XXX','BUG ') 10908 WRITE(ICOUT,9013)MAXREG,NUMREG 10909 9013 FORMAT('MAXREG,NUMREG = ',I8,I8) 10910 CALL DPWRST('XXX','BUG ') 10911 WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2 10912 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) 10913 CALL DPWRST('XXX','BUG ') 10914 WRITE(ICOUT,9015)PDERBT 10915 9015 FORMAT('PDERBT = ',E15.7) 10916 CALL DPWRST('XXX','BUG ') 10917 WRITE(ICOUT,9020)NUMARG 10918 9020 FORMAT('NUMARG = ',I8) 10919 CALL DPWRST('XXX','BUG ') 10920 DO9025I=1,NUMARG 10921 WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I) 10922 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) 10923 CALL DPWRST('XXX','BUG ') 10924 9025 CONTINUE 10925 WRITE(ICOUT,9030)PREBTH(1) 10926 9030 FORMAT('PREBTH(1) = ',E15.7) 10927 CALL DPWRST('XXX','BUG ') 10928 DO9035I=1,10 10929 WRITE(ICOUT,9036)I,PREBTH(I) 10930 9036 FORMAT('I,PREBTH(I) = ',I8,2X,E15.7) 10931 CALL DPWRST('XXX','BUG ') 10932 9035 CONTINUE 10933 9090 CONTINUE 10934C 10935 RETURN 10936 END 10937 SUBROUTINE DPRCIL(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 10938 1IBUGD2,IFOUND,IERROR) 10939C 10940C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 10941C FOR ROMAN COMPLEX ITALIC LOWER CASE. 10942C WRITTEN BY--JAMES J. FILLIBEN 10943C STATISTICAL ENGINEERING DIVISION 10944C INFORMATION TECHNOLOGY LABORATORY 10945C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10946C GAITHERSBURG, MD 20899-8980 10947C PHONE--301-975-2855 10948C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 10949C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 10950C LANGUAGE--ANSI FORTRAN (1977) 10951C VERSION NUMBER--87/4 10952C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 10953C UPDATED --MAY 1982. 10954C UPDATED --MARCH 1987. 10955C 10956C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10957C 10958 CHARACTER*4 ICHAR2 10959 CHARACTER*4 IOP 10960 CHARACTER*4 IBUGD2 10961 CHARACTER*4 IFOUND 10962 CHARACTER*4 IERROR 10963C 10964C--------------------------------------------------------------------- 10965C 10966 DIMENSION IOP(*) 10967 DIMENSION X(*) 10968 DIMENSION Y(*) 10969C 10970C--------------------------------------------------------------------- 10971C 10972 INCLUDE 'DPCOP2.INC' 10973C 10974C-----START POINT----------------------------------------------------- 10975C 10976 IFOUND='NO' 10977 IERROR='NO' 10978C 10979 NUMCO=1 10980 ISTART=1 10981 ISTOP=1 10982 NC=1 10983C 10984C ****************************************** 10985C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 10986C ** HERSHEY CHARACTER SET CASE ** 10987C ****************************************** 10988C 10989C 10990 IF(IBUGD2.EQ.'OFF')GOTO90 10991 WRITE(ICOUT,999) 10992 999 FORMAT(1X) 10993 CALL DPWRST('XXX','BUG ') 10994 WRITE(ICOUT,51) 10995 51 FORMAT('***** AT THE BEGINNING OF DPRCIL--') 10996 CALL DPWRST('XXX','BUG ') 10997 WRITE(ICOUT,52)ICHAR2 10998 52 FORMAT('ICHAR2 = ',A4) 10999 CALL DPWRST('XXX','BUG ') 11000 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 11001 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11002 CALL DPWRST('XXX','BUG ') 11003 90 CONTINUE 11004C 11005C ************************************************** 11006C ** STEP 1-- ** 11007C ** SEARCH FOR THE INPUT CHARACTER(S). ** 11008C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** 11009C ************************************************** 11010C 11011 CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND) 11012 IF(IFOUND.EQ.'NO')GOTO9000 11013C 11014 IF(ICHARN.LE.10)GOTO1010 11015 GOTO1019 11016 1010 CONTINUE 11017 CALL DRCIL1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11018 1IBUGD2,IFOUND,IERROR) 11019 GOTO9000 11020 1019 CONTINUE 11021C 11022 IF(11.LE.ICHARN.AND.ICHARN.LE.20)GOTO1020 11023 GOTO1029 11024 1020 CONTINUE 11025 CALL DRCIL2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11026 1IBUGD2,IFOUND,IERROR) 11027 GOTO9000 11028 1029 CONTINUE 11029C 11030 IF(ICHARN.GE.21)GOTO1030 11031 GOTO1039 11032 1030 CONTINUE 11033 CALL DRCIL3(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11034 1IBUGD2,IFOUND,IERROR) 11035 GOTO9000 11036 1039 CONTINUE 11037C 11038 IFOUND='NO' 11039 GOTO9000 11040C 11041C ***************** 11042C ** STEP 90-- ** 11043C ** EXIT ** 11044C ***************** 11045C 11046 9000 CONTINUE 11047 IF(IBUGD2.EQ.'OFF')GOTO9090 11048 WRITE(ICOUT,999) 11049 CALL DPWRST('XXX','BUG ') 11050 WRITE(ICOUT,9011) 11051 9011 FORMAT('***** AT THE END OF DPRCIL--') 11052 CALL DPWRST('XXX','BUG ') 11053 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 11054 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11055 CALL DPWRST('XXX','BUG ') 11056 WRITE(ICOUT,9013)ICHAR2,ICHARN 11057 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) 11058 CALL DPWRST('XXX','BUG ') 11059 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 11060 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 11061 CALL DPWRST('XXX','BUG ') 11062 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 11063 DO9015I=1,NUMCO 11064 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 11065 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 11066 CALL DPWRST('XXX','BUG ') 11067 9015 CONTINUE 11068 9019 CONTINUE 11069 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 11070 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 11071 CALL DPWRST('XXX','BUG ') 11072 9090 CONTINUE 11073C 11074 RETURN 11075 END 11076 SUBROUTINE DPRCIN(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11077 1IBUGD2,IFOUND,IERROR) 11078C 11079C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 11080C FOR ROMAN COMPLEX ITALIC NUMERIC. 11081C WRITTEN BY--JAMES J. FILLIBEN 11082C STATISTICAL ENGINEERING DIVISION 11083C INFORMATION TECHNOLOGY LABORATORY 11084C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11085C GAITHERSBURG, MD 20899-8980 11086C PHONE--301-975-2855 11087C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11088C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11089C LANGUAGE--ANSI FORTRAN (1977) 11090C VERSION NUMBER--87/4 11091C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 11092C UPDATED --MAY 1982. 11093C UPDATED --MARCH 1987. 11094C 11095C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11096C 11097 CHARACTER*4 ICHAR2 11098 CHARACTER*4 IOP 11099 CHARACTER*4 IBUGD2 11100 CHARACTER*4 IFOUND 11101 CHARACTER*4 IERROR 11102C 11103C--------------------------------------------------------------------- 11104C 11105 DIMENSION IOP(*) 11106 DIMENSION X(*) 11107 DIMENSION Y(*) 11108C 11109C--------------------------------------------------------------------- 11110C 11111 INCLUDE 'DPCOP2.INC' 11112C 11113C-----START POINT----------------------------------------------------- 11114C 11115 IFOUND='NO' 11116 IERROR='NO' 11117C 11118 NUMCO=1 11119 ISTART=1 11120 ISTOP=1 11121 NC=1 11122C 11123C ****************************************** 11124C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 11125C ** HERSHEY CHARACTER SET CASE ** 11126C ****************************************** 11127C 11128C 11129 IF(IBUGD2.EQ.'OFF')GOTO90 11130 WRITE(ICOUT,999) 11131 999 FORMAT(1X) 11132 CALL DPWRST('XXX','BUG ') 11133 WRITE(ICOUT,51) 11134 51 FORMAT('***** AT THE BEGINNING OF DPRCIN--') 11135 CALL DPWRST('XXX','BUG ') 11136 WRITE(ICOUT,52)ICHAR2 11137 52 FORMAT('ICHAR2 = ',A4) 11138 CALL DPWRST('XXX','BUG ') 11139 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 11140 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11141 CALL DPWRST('XXX','BUG ') 11142 90 CONTINUE 11143C 11144C ************************************************** 11145C ** STEP 1-- ** 11146C ** SEARCH FOR THE INPUT CHARACTER(S). ** 11147C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** 11148C ************************************************** 11149C 11150 CALL DPCHNU(ICHAR2,ICHARN,IBUGD2,IFOUND) 11151 IF(IFOUND.EQ.'NO')GOTO9000 11152C 11153 IF(ICHARN.LE.8)GOTO1010 11154 GOTO1019 11155 1010 CONTINUE 11156 CALL DRCIN1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11157 1IBUGD2,IFOUND,IERROR) 11158 GOTO9000 11159 1019 CONTINUE 11160C 11161 IF(ICHARN.GE.9)GOTO1020 11162 GOTO1029 11163 1020 CONTINUE 11164 CALL DRCIN2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11165 1IBUGD2,IFOUND,IERROR) 11166 GOTO9000 11167 1029 CONTINUE 11168C 11169 IFOUND='NO' 11170 GOTO9000 11171C 11172C ***************** 11173C ** STEP 90-- ** 11174C ** EXIT ** 11175C ***************** 11176C 11177 9000 CONTINUE 11178 IF(IBUGD2.EQ.'OFF')GOTO9090 11179 WRITE(ICOUT,999) 11180 CALL DPWRST('XXX','BUG ') 11181 WRITE(ICOUT,9011) 11182 9011 FORMAT('***** AT THE END OF DPRCIN--') 11183 CALL DPWRST('XXX','BUG ') 11184 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 11185 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11186 CALL DPWRST('XXX','BUG ') 11187 WRITE(ICOUT,9013)ICHAR2,ICHARN 11188 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) 11189 CALL DPWRST('XXX','BUG ') 11190 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 11191 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 11192 CALL DPWRST('XXX','BUG ') 11193 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 11194 DO9015I=1,NUMCO 11195 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 11196 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 11197 CALL DPWRST('XXX','BUG ') 11198 9015 CONTINUE 11199 9019 CONTINUE 11200 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 11201 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 11202 CALL DPWRST('XXX','BUG ') 11203 9090 CONTINUE 11204C 11205 RETURN 11206 END 11207 SUBROUTINE DPRCIU(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11208 1IBUGD2,IFOUND,IERROR) 11209C 11210C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 11211C FOR ROMAN COMPLEX ITALIC UPPER CASE. 11212C WRITTEN BY--JAMES J. FILLIBEN 11213C STATISTICAL ENGINEERING DIVISION 11214C INFORMATION TECHNOLOGY LABORATORY 11215C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11216C GAITHERSBURG, MD 20899-8980 11217C PHONE--301-975-2855 11218C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11219C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11220C LANGUAGE--ANSI FORTRAN (1977) 11221C VERSION NUMBER--87/4 11222C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 11223C UPDATED --MAY 1982. 11224C UPDATED --MARCH 1987. 11225C 11226C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11227C 11228 CHARACTER*4 ICHAR2 11229 CHARACTER*4 IOP 11230 CHARACTER*4 IBUGD2 11231 CHARACTER*4 IFOUND 11232 CHARACTER*4 IERROR 11233C 11234C--------------------------------------------------------------------- 11235C 11236 DIMENSION IOP(*) 11237 DIMENSION X(*) 11238 DIMENSION Y(*) 11239C 11240C--------------------------------------------------------------------- 11241C 11242 INCLUDE 'DPCOP2.INC' 11243C 11244C-----START POINT----------------------------------------------------- 11245C 11246 IFOUND='NO' 11247 IERROR='NO' 11248C 11249 NUMCO=1 11250 ISTART=1 11251 ISTOP=1 11252 NC=1 11253C 11254C ****************************************** 11255C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 11256C ** HERSHEY CHARACTER SET CASE ** 11257C ****************************************** 11258C 11259C 11260 IF(IBUGD2.EQ.'OFF')GOTO90 11261 WRITE(ICOUT,999) 11262 999 FORMAT(1X) 11263 CALL DPWRST('XXX','BUG ') 11264 WRITE(ICOUT,51) 11265 51 FORMAT('***** AT THE BEGINNING OF DPRCIU--') 11266 CALL DPWRST('XXX','BUG ') 11267 WRITE(ICOUT,52)ICHAR2 11268 52 FORMAT('ICHAR2 = ',A4) 11269 CALL DPWRST('XXX','BUG ') 11270 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 11271 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11272 CALL DPWRST('XXX','BUG ') 11273 90 CONTINUE 11274C 11275C ************************************************** 11276C ** STEP 1-- ** 11277C ** SEARCH FOR THE INPUT CHARACTER(S). ** 11278C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** 11279C ************************************************** 11280C 11281 CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND) 11282 IF(IFOUND.EQ.'NO')GOTO9000 11283C 11284 IF(ICHARN.LE.14)GOTO1010 11285 GOTO1019 11286 1010 CONTINUE 11287 CALL DRCIU1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11288 1IBUGD2,IFOUND,IERROR) 11289 GOTO9000 11290 1019 CONTINUE 11291C 11292 IF(ICHARN.GE.15)GOTO1020 11293 GOTO1029 11294 1020 CONTINUE 11295 CALL DRCIU2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11296 1IBUGD2,IFOUND,IERROR) 11297 GOTO9000 11298 1029 CONTINUE 11299C 11300 IFOUND='NO' 11301 GOTO9000 11302C 11303C ***************** 11304C ** STEP 90-- ** 11305C ** EXIT ** 11306C ***************** 11307C 11308 9000 CONTINUE 11309 IF(IBUGD2.EQ.'OFF')GOTO9090 11310 WRITE(ICOUT,999) 11311 CALL DPWRST('XXX','BUG ') 11312 WRITE(ICOUT,9011) 11313 9011 FORMAT('***** AT THE END OF DPRCIU--') 11314 CALL DPWRST('XXX','BUG ') 11315 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 11316 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11317 CALL DPWRST('XXX','BUG ') 11318 WRITE(ICOUT,9013)ICHAR2,ICHARN 11319 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) 11320 CALL DPWRST('XXX','BUG ') 11321 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 11322 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 11323 CALL DPWRST('XXX','BUG ') 11324 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 11325 DO9015I=1,NUMCO 11326 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 11327 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 11328 CALL DPWRST('XXX','BUG ') 11329 9015 CONTINUE 11330 9019 CONTINUE 11331 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 11332 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 11333 CALL DPWRST('XXX','BUG ') 11334 9090 CONTINUE 11335C 11336 RETURN 11337 END 11338 SUBROUTINE DPRCL(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11339 1IBUGD2,IFOUND,IERROR) 11340C 11341C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 11342C FOR ROMAN COMPLEX LOWER CASE. 11343C WRITTEN BY--JAMES J. FILLIBEN 11344C STATISTICAL ENGINEERING DIVISION 11345C INFORMATION TECHNOLOGY LABORATORY 11346C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11347C GAITHERSBURG, MD 20899-8980 11348C PHONE--301-975-2855 11349C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11350C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11351C LANGUAGE--ANSI FORTRAN (1977) 11352C VERSION NUMBER--87/4 11353C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 11354C UPDATED --MAY 1982. 11355C UPDATED --MARCH 1987. 11356C 11357C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11358C 11359 CHARACTER*4 ICHAR2 11360 CHARACTER*4 IOP 11361 CHARACTER*4 IBUGD2 11362 CHARACTER*4 IFOUND 11363 CHARACTER*4 IERROR 11364C 11365C--------------------------------------------------------------------- 11366C 11367 DIMENSION IOP(*) 11368 DIMENSION X(*) 11369 DIMENSION Y(*) 11370C 11371C--------------------------------------------------------------------- 11372C 11373 INCLUDE 'DPCOP2.INC' 11374C 11375C-----START POINT----------------------------------------------------- 11376C 11377 IFOUND='NO' 11378 IERROR='NO' 11379C 11380 NUMCO=1 11381 ISTART=1 11382 ISTOP=1 11383 NC=1 11384C 11385C ****************************************** 11386C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 11387C ** HERSHEY CHARACTER SET CASE ** 11388C ****************************************** 11389C 11390C 11391 IF(IBUGD2.EQ.'OFF')GOTO90 11392 WRITE(ICOUT,999) 11393 999 FORMAT(1X) 11394 CALL DPWRST('XXX','BUG ') 11395 WRITE(ICOUT,51) 11396 51 FORMAT('***** AT THE BEGINNING OF DPRCL--') 11397 CALL DPWRST('XXX','BUG ') 11398 WRITE(ICOUT,52)ICHAR2 11399 52 FORMAT('ICHAR2 = ',A4) 11400 CALL DPWRST('XXX','BUG ') 11401 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 11402 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11403 CALL DPWRST('XXX','BUG ') 11404 90 CONTINUE 11405C 11406C ************************************************** 11407C ** STEP 1-- ** 11408C ** SEARCH FOR THE INPUT CHARACTER(S). ** 11409C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** 11410C ************************************************** 11411C 11412 CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND) 11413 IF(IFOUND.EQ.'NO')GOTO9000 11414C 11415 IF(ICHARN.LE.12)GOTO1010 11416 GOTO1019 11417 1010 CONTINUE 11418 CALL DRCL1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11419 1IBUGD2,IFOUND,IERROR) 11420 GOTO9000 11421 1019 CONTINUE 11422C 11423 IF(ICHARN.GE.13)GOTO1020 11424 GOTO1029 11425 1020 CONTINUE 11426 CALL DRCL2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11427 1IBUGD2,IFOUND,IERROR) 11428 GOTO9000 11429 1029 CONTINUE 11430C 11431 IFOUND='NO' 11432 GOTO9000 11433C 11434C ***************** 11435C ** STEP 90-- ** 11436C ** EXIT ** 11437C ***************** 11438C 11439 9000 CONTINUE 11440 IF(IBUGD2.EQ.'OFF')GOTO9090 11441 WRITE(ICOUT,999) 11442 CALL DPWRST('XXX','BUG ') 11443 WRITE(ICOUT,9011) 11444 9011 FORMAT('***** AT THE END OF DPRCL--') 11445 CALL DPWRST('XXX','BUG ') 11446 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 11447 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11448 CALL DPWRST('XXX','BUG ') 11449 WRITE(ICOUT,9013)ICHAR2,ICHARN 11450 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) 11451 CALL DPWRST('XXX','BUG ') 11452 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 11453 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 11454 CALL DPWRST('XXX','BUG ') 11455 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 11456 DO9015I=1,NUMCO 11457 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 11458 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 11459 CALL DPWRST('XXX','BUG ') 11460 9015 CONTINUE 11461 9019 CONTINUE 11462 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 11463 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 11464 CALL DPWRST('XXX','BUG ') 11465 9090 CONTINUE 11466C 11467 RETURN 11468 END 11469 SUBROUTINE DPRCN(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11470 1IBUGD2,IFOUND,IERROR) 11471C 11472C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 11473C FOR ROMAN COMPLEX NUMERIC. 11474C WRITTEN BY--JAMES J. FILLIBEN 11475C STATISTICAL ENGINEERING DIVISION 11476C INFORMATION TECHNOLOGY LABORATORY 11477C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11478C GAITHERSBURG, MD 20899-8980 11479C PHONE--301-975-2855 11480C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11481C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11482C LANGUAGE--ANSI FORTRAN (1977) 11483C VERSION NUMBER--87/4 11484C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 11485C UPDATED --MAY 1982. 11486C UPDATED --MARCH 1987. 11487C 11488C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11489C 11490 CHARACTER*4 ICHAR2 11491 CHARACTER*4 IOP 11492 CHARACTER*4 IBUGD2 11493 CHARACTER*4 IFOUND 11494 CHARACTER*4 IERROR 11495C 11496C--------------------------------------------------------------------- 11497C 11498 DIMENSION IOP(*) 11499 DIMENSION X(*) 11500 DIMENSION Y(*) 11501C 11502C--------------------------------------------------------------------- 11503C 11504 INCLUDE 'DPCOP2.INC' 11505C 11506C-----START POINT----------------------------------------------------- 11507C 11508 IFOUND='NO' 11509 IERROR='NO' 11510C 11511 NUMCO=1 11512 ISTART=1 11513 ISTOP=1 11514 NC=1 11515C 11516C ****************************************** 11517C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 11518C ** HERSHEY CHARACTER SET CASE ** 11519C ****************************************** 11520C 11521C 11522 IF(IBUGD2.EQ.'OFF')GOTO90 11523 WRITE(ICOUT,999) 11524 999 FORMAT(1X) 11525 CALL DPWRST('XXX','BUG ') 11526 WRITE(ICOUT,51) 11527 51 FORMAT('***** AT THE BEGINNING OF DPRCN--') 11528 CALL DPWRST('XXX','BUG ') 11529 WRITE(ICOUT,52)ICHAR2 11530 52 FORMAT('ICHAR2 = ',A4) 11531 CALL DPWRST('XXX','BUG ') 11532 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 11533 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11534 CALL DPWRST('XXX','BUG ') 11535 90 CONTINUE 11536C 11537C ************************************************** 11538C ** STEP 1-- ** 11539C ** SEARCH FOR THE INPUT CHARACTER(S). ** 11540C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** 11541C ************************************************** 11542C 11543 CALL DPCHNU(ICHAR2,ICHARN,IBUGD2,IFOUND) 11544 IF(IFOUND.EQ.'NO')GOTO9000 11545C 11546 IF(ICHARN.LE.9)GOTO1010 11547 GOTO1019 11548 1010 CONTINUE 11549 CALL DRCN1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11550 1IBUGD2,IFOUND,IERROR) 11551 GOTO9000 11552 1019 CONTINUE 11553C 11554 IF(ICHARN.GE.10)GOTO1020 11555 GOTO1029 11556 1020 CONTINUE 11557 CALL DRCN2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11558 1IBUGD2,IFOUND,IERROR) 11559 GOTO9000 11560 1029 CONTINUE 11561C 11562 IFOUND='NO' 11563 GOTO9000 11564C 11565C ***************** 11566C ** STEP 90-- ** 11567C ** EXIT ** 11568C ***************** 11569C 11570 9000 CONTINUE 11571 IF(IBUGD2.EQ.'OFF')GOTO9090 11572 WRITE(ICOUT,999) 11573 CALL DPWRST('XXX','BUG ') 11574 WRITE(ICOUT,9011) 11575 9011 FORMAT('***** AT THE END OF DPRCN--') 11576 CALL DPWRST('XXX','BUG ') 11577 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 11578 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 11579 CALL DPWRST('XXX','BUG ') 11580 WRITE(ICOUT,9013)ICHAR2,ICHARN 11581 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) 11582 CALL DPWRST('XXX','BUG ') 11583 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 11584 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 11585 CALL DPWRST('XXX','BUG ') 11586 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 11587 DO9015I=1,NUMCO 11588 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 11589 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 11590 CALL DPWRST('XXX','BUG ') 11591 9015 CONTINUE 11592 9019 CONTINUE 11593 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 11594 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 11595 CALL DPWRST('XXX','BUG ') 11596 9090 CONTINUE 11597C 11598 RETURN 11599 END 11600 SUBROUTINE DPRCS(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 11601 1IBUGD2,IFOUND,IERROR) 11602C 11603C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 11604C FOR ROMAN COMPLEX SYMBOLS. 11605C WRITTEN BY--JAMES J. FILLIBEN 11606C STATISTICAL ENGINEERING DIVISION 11607C INFORMATION TECHNOLOGY LABORATORY 11608C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11609C GAITHERSBURG, MD 20899-8980 11610C PHONE--301-975-2855 11611C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11612C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11613C LANGUAGE--ANSI FORTRAN (1977) 11614C VERSION NUMBER--87/4 11615C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 11616C UPDATED --MARCH 1982. 11617C UPDATED --MAY 1982. 11618C UPDATED --MARCH 1987. 11619C UPDATED --MAY 1987. 11620C 11621C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11622C 11623 CHARACTER*4 ICHAR2 11624 CHARACTER*4 IOP 11625 CHARACTER*4 IBUGD2 11626 CHARACTER*4 IFOUND 11627 CHARACTER*4 IERROR 11628C 11629 CHARACTER*4 IOPERA 11630C 11631C--------------------------------------------------------------------- 11632C 11633 DIMENSION IOP(*) 11634 DIMENSION X(*) 11635 DIMENSION Y(*) 11636C 11637 DIMENSION IOPERA(300) 11638 DIMENSION IX(300) 11639 DIMENSION IY(300) 11640C 11641 DIMENSION IXMIND(30) 11642 DIMENSION IXMAXD(30) 11643 DIMENSION IXDELD(30) 11644 DIMENSION ISTARD(30) 11645 DIMENSION NUMCOO(30) 11646C 11647C--------------------------------------------------------------------- 11648C 11649 INCLUDE 'DPCOP2.INC' 11650C 11651C-----DATA STATEMENTS------------------------------------------------- 11652C 11653C DEFINE CHARACTER 2210--. (PERIOD) 11654C 11655 DATA IOPERA( 1),IX( 1),IY( 1)/'MOVE', 0, -7/ 11656 DATA IOPERA( 2),IX( 2),IY( 2)/'DRAW', -1, -8/ 11657 DATA IOPERA( 3),IX( 3),IY( 3)/'DRAW', 0, -9/ 11658 DATA IOPERA( 4),IX( 4),IY( 4)/'DRAW', 1, -8/ 11659 DATA IOPERA( 5),IX( 5),IY( 5)/'DRAW', 0, -7/ 11660C 11661 DATA IXMIND( 1)/ -5/ 11662 DATA IXMAXD( 1)/ 5/ 11663 DATA IXDELD( 1)/ 10/ 11664 DATA ISTARD( 1)/ 1/ 11665 DATA NUMCOO( 1)/ 5/ 11666C 11667C DEFINE CHARACTER 2211--, (COMMA) 11668C 11669 DATA IOPERA( 6),IX( 6),IY( 6)/'MOVE', 0, -9/ 11670 DATA IOPERA( 7),IX( 7),IY( 7)/'DRAW', -1, -8/ 11671 DATA IOPERA( 8),IX( 8),IY( 8)/'DRAW', 0, -7/ 11672 DATA IOPERA( 9),IX( 9),IY( 9)/'DRAW', 1, -8/ 11673 DATA IOPERA( 10),IX( 10),IY( 10)/'DRAW', 1, -10/ 11674 DATA IOPERA( 11),IX( 11),IY( 11)/'DRAW', 0, -12/ 11675 DATA IOPERA( 12),IX( 12),IY( 12)/'DRAW', -1, -13/ 11676C 11677 DATA IXMIND( 2)/ -5/ 11678 DATA IXMAXD( 2)/ 5/ 11679 DATA IXDELD( 2)/ 10/ 11680 DATA ISTARD( 2)/ 6/ 11681 DATA NUMCOO( 2)/ 7/ 11682C 11683C DEFINE CHARACTER 2212--: (COLON) 11684C 11685 DATA IOPERA( 13),IX( 13),IY( 13)/'MOVE', 0, 5/ 11686 DATA IOPERA( 14),IX( 14),IY( 14)/'DRAW', -1, 4/ 11687 DATA IOPERA( 15),IX( 15),IY( 15)/'DRAW', 0, 3/ 11688 DATA IOPERA( 16),IX( 16),IY( 16)/'DRAW', 1, 4/ 11689 DATA IOPERA( 17),IX( 17),IY( 17)/'DRAW', 0, 5/ 11690 DATA IOPERA( 18),IX( 18),IY( 18)/'MOVE', 0, -7/ 11691 DATA IOPERA( 19),IX( 19),IY( 19)/'DRAW', -1, -8/ 11692 DATA IOPERA( 20),IX( 20),IY( 20)/'DRAW', 0, -9/ 11693 DATA IOPERA( 21),IX( 21),IY( 21)/'DRAW', 1, -8/ 11694 DATA IOPERA( 22),IX( 22),IY( 22)/'DRAW', 0, -7/ 11695C 11696 DATA IXMIND( 3)/ -5/ 11697 DATA IXMAXD( 3)/ 5/ 11698 DATA IXDELD( 3)/ 10/ 11699 DATA ISTARD( 3)/ 13/ 11700 DATA NUMCOO( 3)/ 10/ 11701C 11702C DEFINE CHARACTER 2213--; (SEMICOLON) 11703C 11704 DATA IOPERA( 23),IX( 23),IY( 23)/'MOVE', 0, 5/ 11705 DATA IOPERA( 24),IX( 24),IY( 24)/'DRAW', -1, 4/ 11706 DATA IOPERA( 25),IX( 25),IY( 25)/'DRAW', 0, 3/ 11707 DATA IOPERA( 26),IX( 26),IY( 26)/'DRAW', 1, 4/ 11708 DATA IOPERA( 27),IX( 27),IY( 27)/'DRAW', 0, 5/ 11709 DATA IOPERA( 28),IX( 28),IY( 28)/'MOVE', 0, -9/ 11710 DATA IOPERA( 29),IX( 29),IY( 29)/'DRAW', -1, -8/ 11711 DATA IOPERA( 30),IX( 30),IY( 30)/'DRAW', 0, -7/ 11712 DATA IOPERA( 31),IX( 31),IY( 31)/'DRAW', 1, -8/ 11713 DATA IOPERA( 32),IX( 32),IY( 32)/'DRAW', 1, -10/ 11714 DATA IOPERA( 33),IX( 33),IY( 33)/'DRAW', 0, -12/ 11715 DATA IOPERA( 34),IX( 34),IY( 34)/'DRAW', -1, -13/ 11716C 11717 DATA IXMIND( 4)/ -5/ 11718 DATA IXMAXD( 4)/ 5/ 11719 DATA IXDELD( 4)/ 10/ 11720 DATA ISTARD( 4)/ 23/ 11721 DATA NUMCOO( 4)/ 12/ 11722C 11723C DEFINE CHARACTER 2214--! (EXCLAMATION POINT) 11724C 11725 DATA IOPERA( 35),IX( 35),IY( 35)/'MOVE', 0, 12/ 11726 DATA IOPERA( 36),IX( 36),IY( 36)/'DRAW', -1, 10/ 11727 DATA IOPERA( 37),IX( 37),IY( 37)/'DRAW', 0, -2/ 11728 DATA IOPERA( 38),IX( 38),IY( 38)/'DRAW', 1, 10/ 11729 DATA IOPERA( 39),IX( 39),IY( 39)/'DRAW', 0, 12/ 11730 DATA IOPERA( 40),IX( 40),IY( 40)/'MOVE', 0, 10/ 11731 DATA IOPERA( 41),IX( 41),IY( 41)/'DRAW', 0, 4/ 11732 DATA IOPERA( 42),IX( 42),IY( 42)/'MOVE', 0, -7/ 11733 DATA IOPERA( 43),IX( 43),IY( 43)/'DRAW', -1, -8/ 11734 DATA IOPERA( 44),IX( 44),IY( 44)/'DRAW', 0, -9/ 11735 DATA IOPERA( 45),IX( 45),IY( 45)/'DRAW', 1, -8/ 11736 DATA IOPERA( 46),IX( 46),IY( 46)/'DRAW', 0, -7/ 11737C 11738 DATA IXMIND( 5)/ -5/ 11739 DATA IXMAXD( 5)/ 5/ 11740 DATA IXDELD( 5)/ 10/ 11741 DATA ISTARD( 5)/ 35/ 11742 DATA NUMCOO( 5)/ 12/ 11743C 11744C DEFINE CHARACTER 2215--? (QUESTION MARK) 11745C 11746 DATA IOPERA( 47),IX( 47),IY( 47)/'MOVE', -5, 8/ 11747 DATA IOPERA( 48),IX( 48),IY( 48)/'DRAW', -4, 7/ 11748 DATA IOPERA( 49),IX( 49),IY( 49)/'DRAW', -5, 6/ 11749 DATA IOPERA( 50),IX( 50),IY( 50)/'DRAW', -6, 7/ 11750 DATA IOPERA( 51),IX( 51),IY( 51)/'DRAW', -6, 8/ 11751 DATA IOPERA( 52),IX( 52),IY( 52)/'DRAW', -5, 10/ 11752 DATA IOPERA( 53),IX( 53),IY( 53)/'DRAW', -4, 11/ 11753 DATA IOPERA( 54),IX( 54),IY( 54)/'DRAW', -2, 12/ 11754 DATA IOPERA( 55),IX( 55),IY( 55)/'DRAW', 1, 12/ 11755 DATA IOPERA( 56),IX( 56),IY( 56)/'DRAW', 4, 11/ 11756 DATA IOPERA( 57),IX( 57),IY( 57)/'DRAW', 5, 10/ 11757 DATA IOPERA( 58),IX( 58),IY( 58)/'DRAW', 6, 8/ 11758 DATA IOPERA( 59),IX( 59),IY( 59)/'DRAW', 6, 6/ 11759 DATA IOPERA( 60),IX( 60),IY( 60)/'DRAW', 5, 4/ 11760 DATA IOPERA( 61),IX( 61),IY( 61)/'DRAW', 4, 3/ 11761 DATA IOPERA( 62),IX( 62),IY( 62)/'DRAW', 0, 1/ 11762 DATA IOPERA( 63),IX( 63),IY( 63)/'DRAW', 0, -2/ 11763 DATA IOPERA( 64),IX( 64),IY( 64)/'MOVE', 1, 12/ 11764 DATA IOPERA( 65),IX( 65),IY( 65)/'DRAW', 3, 11/ 11765 DATA IOPERA( 66),IX( 66),IY( 66)/'DRAW', 4, 10/ 11766 DATA IOPERA( 67),IX( 67),IY( 67)/'DRAW', 5, 8/ 11767 DATA IOPERA( 68),IX( 68),IY( 68)/'DRAW', 5, 6/ 11768 DATA IOPERA( 69),IX( 69),IY( 69)/'DRAW', 4, 4/ 11769 DATA IOPERA( 70),IX( 70),IY( 70)/'DRAW', 2, 2/ 11770 DATA IOPERA( 71),IX( 71),IY( 71)/'MOVE', 0, -7/ 11771 DATA IOPERA( 72),IX( 72),IY( 72)/'DRAW', -1, -8/ 11772 DATA IOPERA( 73),IX( 73),IY( 73)/'DRAW', 0, -9/ 11773 DATA IOPERA( 74),IX( 74),IY( 74)/'DRAW', 1, -8/ 11774 DATA IOPERA( 75),IX( 75),IY( 75)/'DRAW', 0, -7/ 11775C 11776 DATA IXMIND( 6)/ -9/ 11777 DATA IXMAXD( 6)/ 9/ 11778 DATA IXDELD( 6)/ 18/ 11779 DATA ISTARD( 6)/ 47/ 11780 DATA NUMCOO( 6)/ 29/ 11781C 11782C DEFINE CHARACTER 2272--& (AMPERSAND) 11783C 11784 DATA IOPERA( 76),IX( 76),IY( 76)/'MOVE', 9, 4/ 11785 DATA IOPERA( 77),IX( 77),IY( 77)/'DRAW', 8, 3/ 11786 DATA IOPERA( 78),IX( 78),IY( 78)/'DRAW', 9, 2/ 11787 DATA IOPERA( 79),IX( 79),IY( 79)/'DRAW', 10, 3/ 11788 DATA IOPERA( 80),IX( 80),IY( 80)/'DRAW', 10, 4/ 11789 DATA IOPERA( 81),IX( 81),IY( 81)/'DRAW', 9, 5/ 11790 DATA IOPERA( 82),IX( 82),IY( 82)/'DRAW', 8, 5/ 11791 DATA IOPERA( 83),IX( 83),IY( 83)/'DRAW', 7, 4/ 11792 DATA IOPERA( 84),IX( 84),IY( 84)/'DRAW', 6, 2/ 11793 DATA IOPERA( 85),IX( 85),IY( 85)/'DRAW', 4, -3/ 11794 DATA IOPERA( 86),IX( 86),IY( 86)/'DRAW', 2, -6/ 11795 DATA IOPERA( 87),IX( 87),IY( 87)/'DRAW', 0, -8/ 11796 DATA IOPERA( 88),IX( 88),IY( 88)/'DRAW', -2, -9/ 11797 DATA IOPERA( 89),IX( 89),IY( 89)/'DRAW', -5, -9/ 11798 DATA IOPERA( 90),IX( 90),IY( 90)/'DRAW', -8, -8/ 11799 DATA IOPERA( 91),IX( 91),IY( 91)/'DRAW', -9, -6/ 11800 DATA IOPERA( 92),IX( 92),IY( 92)/'DRAW', -9, -3/ 11801 DATA IOPERA( 93),IX( 93),IY( 93)/'DRAW', -8, -1/ 11802 DATA IOPERA( 94),IX( 94),IY( 94)/'DRAW', -2, 3/ 11803 DATA IOPERA( 95),IX( 95),IY( 95)/'DRAW', 0, 5/ 11804 DATA IOPERA( 96),IX( 96),IY( 96)/'DRAW', 1, 7/ 11805 DATA IOPERA( 97),IX( 97),IY( 97)/'DRAW', 1, 9/ 11806 DATA IOPERA( 98),IX( 98),IY( 98)/'DRAW', 0, 11/ 11807 DATA IOPERA( 99),IX( 99),IY( 99)/'DRAW', -2, 12/ 11808 DATA IOPERA( 100),IX( 100),IY( 100)/'DRAW', -4, 11/ 11809 DATA IOPERA( 101),IX( 101),IY( 101)/'DRAW', -5, 9/ 11810 DATA IOPERA( 102),IX( 102),IY( 102)/'DRAW', -5, 7/ 11811 DATA IOPERA( 103),IX( 103),IY( 103)/'DRAW', -4, 4/ 11812 DATA IOPERA( 104),IX( 104),IY( 104)/'DRAW', -2, 1/ 11813 DATA IOPERA( 105),IX( 105),IY( 105)/'DRAW', 3, -6/ 11814 DATA IOPERA( 106),IX( 106),IY( 106)/'DRAW', 5, -8/ 11815 DATA IOPERA( 107),IX( 107),IY( 107)/'DRAW', 8, -9/ 11816 DATA IOPERA( 108),IX( 108),IY( 108)/'DRAW', 9, -9/ 11817 DATA IOPERA( 109),IX( 109),IY( 109)/'DRAW', 10, -8/ 11818 DATA IOPERA( 110),IX( 110),IY( 110)/'DRAW', 10, -7/ 11819 DATA IOPERA( 111),IX( 111),IY( 111)/'MOVE', -5, -9/ 11820 DATA IOPERA( 112),IX( 112),IY( 112)/'DRAW', -7, -8/ 11821 DATA IOPERA( 113),IX( 113),IY( 113)/'DRAW', -8, -6/ 11822 DATA IOPERA( 114),IX( 114),IY( 114)/'DRAW', -8, -3/ 11823 DATA IOPERA( 115),IX( 115),IY( 115)/'DRAW', -7, -1/ 11824 DATA IOPERA( 116),IX( 116),IY( 116)/'DRAW', -5, 1/ 11825 DATA IOPERA( 117),IX( 117),IY( 117)/'MOVE', -5, 7/ 11826 DATA IOPERA( 118),IX( 118),IY( 118)/'DRAW', -4, 5/ 11827 DATA IOPERA( 119),IX( 119),IY( 119)/'DRAW', 4, -6/ 11828 DATA IOPERA( 120),IX( 120),IY( 120)/'DRAW', 6, -8/ 11829 DATA IOPERA( 121),IX( 121),IY( 121)/'DRAW', 8, -9/ 11830C 11831 DATA IXMIND( 7)/ -12/ 11832 DATA IXMAXD( 7)/ 13/ 11833 DATA IXDELD( 7)/ 25/ 11834 DATA ISTARD( 7)/ 76/ 11835 DATA NUMCOO( 7)/ 46/ 11836C 11837C DEFINE CHARACTER 2274--$ (DOLLAR SIGN) 11838C 11839 DATA IOPERA( 122),IX( 122),IY( 122)/'MOVE', -2, 16/ 11840 DATA IOPERA( 123),IX( 123),IY( 123)/'DRAW', -2, -13/ 11841 DATA IOPERA( 124),IX( 124),IY( 124)/'MOVE', 2, 16/ 11842 DATA IOPERA( 125),IX( 125),IY( 125)/'DRAW', 2, -13/ 11843 DATA IOPERA( 126),IX( 126),IY( 126)/'MOVE', 6, 9/ 11844 DATA IOPERA( 127),IX( 127),IY( 127)/'DRAW', 5, 8/ 11845 DATA IOPERA( 128),IX( 128),IY( 128)/'DRAW', 6, 7/ 11846 DATA IOPERA( 129),IX( 129),IY( 129)/'DRAW', 7, 8/ 11847 DATA IOPERA( 130),IX( 130),IY( 130)/'DRAW', 7, 9/ 11848 DATA IOPERA( 131),IX( 131),IY( 131)/'DRAW', 5, 11/ 11849 DATA IOPERA( 132),IX( 132),IY( 132)/'DRAW', 2, 12/ 11850 DATA IOPERA( 133),IX( 133),IY( 133)/'DRAW', -2, 12/ 11851 DATA IOPERA( 134),IX( 134),IY( 134)/'DRAW', -5, 11/ 11852 DATA IOPERA( 135),IX( 135),IY( 135)/'DRAW', -7, 9/ 11853 DATA IOPERA( 136),IX( 136),IY( 136)/'DRAW', -7, 7/ 11854 DATA IOPERA( 137),IX( 137),IY( 137)/'DRAW', -6, 5/ 11855 DATA IOPERA( 138),IX( 138),IY( 138)/'DRAW', -5, 4/ 11856 DATA IOPERA( 139),IX( 139),IY( 139)/'DRAW', -3, 3/ 11857 DATA IOPERA( 140),IX( 140),IY( 140)/'DRAW', 3, 1/ 11858 DATA IOPERA( 141),IX( 141),IY( 141)/'DRAW', 5, 0/ 11859 DATA IOPERA( 142),IX( 142),IY( 142)/'DRAW', 7, -2/ 11860 DATA IOPERA( 143),IX( 143),IY( 143)/'MOVE', -7, 7/ 11861 DATA IOPERA( 144),IX( 144),IY( 144)/'DRAW', -5, 5/ 11862 DATA IOPERA( 145),IX( 145),IY( 145)/'DRAW', -3, 4/ 11863 DATA IOPERA( 146),IX( 146),IY( 146)/'DRAW', 3, 2/ 11864 DATA IOPERA( 147),IX( 147),IY( 147)/'DRAW', 5, 1/ 11865 DATA IOPERA( 148),IX( 148),IY( 148)/'DRAW', 6, 0/ 11866 DATA IOPERA( 149),IX( 149),IY( 149)/'DRAW', 7, -2/ 11867 DATA IOPERA( 150),IX( 150),IY( 150)/'DRAW', 7, -6/ 11868 DATA IOPERA( 151),IX( 151),IY( 151)/'DRAW', 5, -8/ 11869 DATA IOPERA( 152),IX( 152),IY( 152)/'DRAW', 2, -9/ 11870 DATA IOPERA( 153),IX( 153),IY( 153)/'DRAW', -2, -9/ 11871 DATA IOPERA( 154),IX( 154),IY( 154)/'DRAW', -5, -8/ 11872 DATA IOPERA( 155),IX( 155),IY( 155)/'DRAW', -7, -6/ 11873 DATA IOPERA( 156),IX( 156),IY( 156)/'DRAW', -7, -5/ 11874 DATA IOPERA( 157),IX( 157),IY( 157)/'DRAW', -6, -4/ 11875 DATA IOPERA( 158),IX( 158),IY( 158)/'DRAW', -5, -5/ 11876 DATA IOPERA( 159),IX( 159),IY( 159)/'DRAW', -6, -6/ 11877C 11878 DATA IXMIND( 8)/ -10/ 11879 DATA IXMAXD( 8)/ 10/ 11880 DATA IXDELD( 8)/ 20/ 11881 DATA ISTARD( 8)/ 122/ 11882 DATA NUMCOO( 8)/ 38/ 11883C 11884C DEFINE CHARACTER 2220--/ (SLASH) 11885C 11886 DATA IOPERA( 160),IX( 160),IY( 160)/'MOVE', 9, 16/ 11887 DATA IOPERA( 161),IX( 161),IY( 161)/'DRAW', -9, -16/ 11888C 11889 DATA IXMIND( 9)/ -11/ 11890 DATA IXMAXD( 9)/ 11/ 11891 DATA IXDELD( 9)/ 22/ 11892 DATA ISTARD( 9)/ 160/ 11893 DATA NUMCOO( 9)/ 2/ 11894C 11895C DEFINE CHARACTER 2221--( (LEFT PARENTHESES) 11896C 11897 DATA IOPERA( 162),IX( 162),IY( 162)/'MOVE', 4, 16/ 11898 DATA IOPERA( 163),IX( 163),IY( 163)/'DRAW', 2, 14/ 11899 DATA IOPERA( 164),IX( 164),IY( 164)/'DRAW', 0, 11/ 11900 DATA IOPERA( 165),IX( 165),IY( 165)/'DRAW', -2, 7/ 11901 DATA IOPERA( 166),IX( 166),IY( 166)/'DRAW', -3, 2/ 11902 DATA IOPERA( 167),IX( 167),IY( 167)/'DRAW', -3, -2/ 11903 DATA IOPERA( 168),IX( 168),IY( 168)/'DRAW', -2, -7/ 11904 DATA IOPERA( 169),IX( 169),IY( 169)/'DRAW', 0, -11/ 11905 DATA IOPERA( 170),IX( 170),IY( 170)/'DRAW', 2, -14/ 11906 DATA IOPERA( 171),IX( 171),IY( 171)/'DRAW', 4, -16/ 11907 DATA IOPERA( 172),IX( 172),IY( 172)/'MOVE', 2, 14/ 11908 DATA IOPERA( 173),IX( 173),IY( 173)/'DRAW', 0, 10/ 11909 DATA IOPERA( 174),IX( 174),IY( 174)/'DRAW', -1, 7/ 11910 DATA IOPERA( 175),IX( 175),IY( 175)/'DRAW', -2, 2/ 11911 DATA IOPERA( 176),IX( 176),IY( 176)/'DRAW', -2, -2/ 11912 DATA IOPERA( 177),IX( 177),IY( 177)/'DRAW', -1, -7/ 11913 DATA IOPERA( 178),IX( 178),IY( 178)/'DRAW', 0, -10/ 11914 DATA IOPERA( 179),IX( 179),IY( 179)/'DRAW', 2, -14/ 11915C 11916 DATA IXMIND( 10)/ -7/ 11917 DATA IXMAXD( 10)/ 7/ 11918 DATA IXDELD( 10)/ 14/ 11919 DATA ISTARD( 10)/ 162/ 11920 DATA NUMCOO( 10)/ 18/ 11921C 11922C DEFINE CHARACTER 2222--) (RIGHT PARENTHESES) 11923C 11924 DATA IOPERA( 180),IX( 180),IY( 180)/'MOVE', -4, 16/ 11925 DATA IOPERA( 181),IX( 181),IY( 181)/'DRAW', -2, 14/ 11926 DATA IOPERA( 182),IX( 182),IY( 182)/'DRAW', 0, 11/ 11927 DATA IOPERA( 183),IX( 183),IY( 183)/'DRAW', 2, 7/ 11928 DATA IOPERA( 184),IX( 184),IY( 184)/'DRAW', 3, 2/ 11929 DATA IOPERA( 185),IX( 185),IY( 185)/'DRAW', 3, -2/ 11930 DATA IOPERA( 186),IX( 186),IY( 186)/'DRAW', 2, -7/ 11931 DATA IOPERA( 187),IX( 187),IY( 187)/'DRAW', 0, -11/ 11932 DATA IOPERA( 188),IX( 188),IY( 188)/'DRAW', -2, -14/ 11933 DATA IOPERA( 189),IX( 189),IY( 189)/'DRAW', -4, -16/ 11934 DATA IOPERA( 190),IX( 190),IY( 190)/'MOVE', -2, 14/ 11935 DATA IOPERA( 191),IX( 191),IY( 191)/'DRAW', 0, 10/ 11936 DATA IOPERA( 192),IX( 192),IY( 192)/'DRAW', 1, 7/ 11937 DATA IOPERA( 193),IX( 193),IY( 193)/'DRAW', 2, 2/ 11938 DATA IOPERA( 194),IX( 194),IY( 194)/'DRAW', 2, -2/ 11939 DATA IOPERA( 195),IX( 195),IY( 195)/'DRAW', 1, -7/ 11940 DATA IOPERA( 196),IX( 196),IY( 196)/'DRAW', 0, -10/ 11941 DATA IOPERA( 197),IX( 197),IY( 197)/'DRAW', -2, -14/ 11942C 11943 DATA IXMIND( 11)/ -7/ 11944 DATA IXMAXD( 11)/ 7/ 11945 DATA IXDELD( 11)/ 14/ 11946 DATA ISTARD( 11)/ 180/ 11947 DATA NUMCOO( 11)/ 18/ 11948C 11949C DEFINE CHARACTER 2219--* (ASTERISK) 11950C 11951 DATA IOPERA( 198),IX( 198),IY( 198)/'MOVE', 0, 12/ 11952 DATA IOPERA( 199),IX( 199),IY( 199)/'DRAW', 0, 0/ 11953 DATA IOPERA( 200),IX( 200),IY( 200)/'MOVE', -5, 9/ 11954 DATA IOPERA( 201),IX( 201),IY( 201)/'DRAW', 5, 3/ 11955 DATA IOPERA( 202),IX( 202),IY( 202)/'MOVE', 5, 9/ 11956 DATA IOPERA( 203),IX( 203),IY( 203)/'DRAW', -5, 3/ 11957C 11958 DATA IXMIND( 12)/ -8/ 11959 DATA IXMAXD( 12)/ 8/ 11960 DATA IXDELD( 12)/ 16/ 11961 DATA ISTARD( 12)/ 198/ 11962 DATA NUMCOO( 12)/ 6/ 11963C 11964C DEFINE CHARACTER 2231--- (HYPHEN OR MINUS SIGN) 11965C 11966 DATA IOPERA( 204),IX( 204),IY( 204)/'MOVE', -9, 0/ 11967 DATA IOPERA( 205),IX( 205),IY( 205)/'DRAW', 9, 0/ 11968C 11969 DATA IXMIND( 13)/ -13/ 11970 DATA IXMAXD( 13)/ 13/ 11971 DATA IXDELD( 13)/ 26/ 11972 DATA ISTARD( 13)/ 204/ 11973 DATA NUMCOO( 13)/ 2/ 11974C 11975C DEFINE CHARACTER 2232--+ (PLUS SIGN) 11976C 11977 DATA IOPERA( 206),IX( 206),IY( 206)/'MOVE', 0, 9/ 11978 DATA IOPERA( 207),IX( 207),IY( 207)/'DRAW', 0, -9/ 11979 DATA IOPERA( 208),IX( 208),IY( 208)/'MOVE', -9, 0/ 11980 DATA IOPERA( 209),IX( 209),IY( 209)/'DRAW', 9, 0/ 11981C 11982 DATA IXMIND( 14)/ -13/ 11983 DATA IXMAXD( 14)/ 13/ 11984 DATA IXDELD( 14)/ 26/ 11985 DATA ISTARD( 14)/ 206/ 11986 DATA NUMCOO( 14)/ 4/ 11987C 11988C DEFINE CHARACTER 2238--= (EQUAL SIGN) 11989C 11990 DATA IOPERA( 210),IX( 210),IY( 210)/'MOVE', -9, 3/ 11991 DATA IOPERA( 211),IX( 211),IY( 211)/'DRAW', 9, 3/ 11992 DATA IOPERA( 212),IX( 212),IY( 212)/'MOVE', -9, -3/ 11993 DATA IOPERA( 213),IX( 213),IY( 213)/'DRAW', 9, -3/ 11994C 11995 DATA IXMIND( 15)/ -13/ 11996 DATA IXMAXD( 15)/ 13/ 11997 DATA IXDELD( 15)/ 26/ 11998 DATA ISTARD( 15)/ 210/ 11999 DATA NUMCOO( 15)/ 4/ 12000C 12001C DEFINE CHARACTER 2216--' (SINGLE QUOTE) 12002C 12003 DATA IOPERA( 214),IX( 214),IY( 214)/'MOVE', 0, 12/ 12004 DATA IOPERA( 215),IX( 215),IY( 215)/'DRAW', -1, 5/ 12005 DATA IOPERA( 216),IX( 216),IY( 216)/'MOVE', 1, 12/ 12006 DATA IOPERA( 217),IX( 217),IY( 217)/'DRAW', -1, 5/ 12007C 12008 DATA IXMIND( 16)/ -4/ 12009 DATA IXMAXD( 16)/ 4/ 12010 DATA IXDELD( 16)/ 8/ 12011 DATA ISTARD( 16)/ 214/ 12012 DATA NUMCOO( 16)/ 4/ 12013C 12014C DEFINE CHARACTER 2217-- (DOUBLE QUOTE) 12015C 12016 DATA IOPERA( 218),IX( 218),IY( 218)/'MOVE', -4, 12/ 12017 DATA IOPERA( 219),IX( 219),IY( 219)/'DRAW', -5, 5/ 12018 DATA IOPERA( 220),IX( 220),IY( 220)/'MOVE', -3, 12/ 12019 DATA IOPERA( 221),IX( 221),IY( 221)/'DRAW', -5, 5/ 12020 DATA IOPERA( 222),IX( 222),IY( 222)/'MOVE', 4, 12/ 12021 DATA IOPERA( 223),IX( 223),IY( 223)/'DRAW', 3, 5/ 12022 DATA IOPERA( 224),IX( 224),IY( 224)/'MOVE', 5, 12/ 12023 DATA IOPERA( 225),IX( 225),IY( 225)/'DRAW', 3, 5/ 12024C 12025 DATA IXMIND( 17)/ -8/ 12026 DATA IXMAXD( 17)/ 8/ 12027 DATA IXDELD( 17)/ 16/ 12028 DATA ISTARD( 17)/ 218/ 12029 DATA NUMCOO( 17)/ 8/ 12030C 12031C DEFINE CHARACTER 2218-- (DEGREES) 12032C 12033 DATA IOPERA( 226),IX( 226),IY( 226)/'MOVE', -1, 12/ 12034 DATA IOPERA( 227),IX( 227),IY( 227)/'DRAW', -3, 11/ 12035 DATA IOPERA( 228),IX( 228),IY( 228)/'DRAW', -4, 9/ 12036 DATA IOPERA( 229),IX( 229),IY( 229)/'DRAW', -4, 7/ 12037 DATA IOPERA( 230),IX( 230),IY( 230)/'DRAW', -3, 5/ 12038 DATA IOPERA( 231),IX( 231),IY( 231)/'DRAW', -1, 4/ 12039 DATA IOPERA( 232),IX( 232),IY( 232)/'DRAW', 1, 4/ 12040 DATA IOPERA( 233),IX( 233),IY( 233)/'DRAW', 3, 5/ 12041 DATA IOPERA( 234),IX( 234),IY( 234)/'DRAW', 4, 7/ 12042 DATA IOPERA( 235),IX( 235),IY( 235)/'DRAW', 4, 9/ 12043 DATA IOPERA( 236),IX( 236),IY( 236)/'DRAW', 3, 11/ 12044 DATA IOPERA( 237),IX( 237),IY( 237)/'DRAW', 1, 12/ 12045 DATA IOPERA( 238),IX( 238),IY( 238)/'DRAW', -1, 12/ 12046C 12047 DATA IXMIND( 18)/ -7/ 12048 DATA IXMAXD( 18)/ 7/ 12049 DATA IXDELD( 18)/ 14/ 12050 DATA ISTARD( 18)/ 226/ 12051 DATA NUMCOO( 18)/ 13/ 12052C 12053C DEFINE CHARACTER 2747-- (NO SPACE BLANK) 12054C 12055 DATA IOPERA( 239),IX( 239),IY( 239)/'MOVE', 0, -32/ 12056 DATA IOPERA( 240),IX( 240),IY( 240)/'MOVE', 0, -32/ 12057C 12058 DATA IXMIND( 19)/ 0/ 12059 DATA IXMAXD( 19)/ 0/ 12060 DATA IXDELD( 19)/ 0/ 12061 DATA ISTARD( 19)/ 239/ 12062 DATA NUMCOO( 19)/ 2/ 12063C 12064C DEFINE CHARACTER 2748-- (HALF SPACE BLANK) 12065C 12066 DATA IOPERA( 241),IX( 241),IY( 241)/'MOVE', -4, -32/ 12067 DATA IOPERA( 242),IX( 242),IY( 242)/'MOVE', 4, -32/ 12068C 12069 DATA IXMIND( 20)/ -4/ 12070 DATA IXMAXD( 20)/ 4/ 12071 DATA IXDELD( 20)/ 8/ 12072 DATA ISTARD( 20)/ 241/ 12073 DATA NUMCOO( 20)/ 2/ 12074C 12075C DEFINE CHARACTER 2749-- (FULL SPACE BLANK) 12076C 12077 DATA IOPERA( 243),IX( 243),IY( 243)/'MOVE', -8, -32/ 12078 DATA IOPERA( 244),IX( 244),IY( 244)/'MOVE', 8, -32/ 12079C 12080 DATA IXMIND( 21)/ -8/ 12081 DATA IXMAXD( 21)/ 8/ 12082 DATA IXDELD( 21)/ 16/ 12083 DATA ISTARD( 21)/ 243/ 12084 DATA NUMCOO( 21)/ 2/ 12085C 12086C DEFINE CHARACTER 2252-- (LEFT APOSTRAPHE) 12087C 12088 DATA IOPERA( 245),IX( 245),IY( 245)/'MOVE', 1, 12/ 12089 DATA IOPERA( 246),IX( 246),IY( 246)/'DRAW', 0, 11/ 12090 DATA IOPERA( 247),IX( 247),IY( 247)/'DRAW', -1, 9/ 12091 DATA IOPERA( 248),IX( 248),IY( 248)/'DRAW', -1, 7/ 12092 DATA IOPERA( 249),IX( 249),IY( 249)/'DRAW', 0, 6/ 12093 DATA IOPERA( 250),IX( 250),IY( 250)/'DRAW', 1, 7/ 12094 DATA IOPERA( 251),IX( 251),IY( 251)/'DRAW', 0, 8/ 12095C 12096 DATA IXMIND( 22)/ -5/ 12097 DATA IXMAXD( 22)/ 5/ 12098 DATA IXDELD( 22)/ 10/ 12099 DATA ISTARD( 22)/ 245/ 12100 DATA NUMCOO( 22)/ 7/ 12101C 12102C DEFINE CHARACTER 2251-- (RIGHT APOSTRAPHE) 12103C 12104 DATA IOPERA( 252),IX( 252),IY( 252)/'MOVE', 0, 10/ 12105 DATA IOPERA( 253),IX( 253),IY( 253)/'DRAW', -1, 11/ 12106 DATA IOPERA( 254),IX( 254),IY( 254)/'DRAW', 0, 12/ 12107 DATA IOPERA( 255),IX( 255),IY( 255)/'DRAW', 1, 11/ 12108 DATA IOPERA( 256),IX( 256),IY( 256)/'DRAW', 1, 9/ 12109 DATA IOPERA( 257),IX( 257),IY( 257)/'DRAW', 0, 7/ 12110 DATA IOPERA( 258),IX( 258),IY( 258)/'DRAW', -1, 6/ 12111C 12112 DATA IXMIND( 23)/ -5/ 12113 DATA IXMAXD( 23)/ 5/ 12114 DATA IXDELD( 23)/ 10/ 12115 DATA ISTARD( 23)/ 252/ 12116 DATA NUMCOO( 23)/ 7/ 12117C 12118C DEFINE CHARACTER XXX--| (KEYBOARD VERTICAL BAR) 12119C 12120 DATA IOPERA( 259),IX( 259),IY( 259)/'MOVE', 0, 12/ 12121 DATA IOPERA( 260),IX( 260),IY( 260)/'DRAW', 0, -9/ 12122C 12123C 12124 DATA IXMIND( 24)/ -4/ 12125 DATA IXMAXD( 24)/ 4/ 12126 DATA IXDELD( 24)/ 8/ 12127 DATA ISTARD( 24)/ 259/ 12128 DATA NUMCOO( 24)/ 2/ 12129C 12130C-----START POINT----------------------------------------------------- 12131C 12132 IFOUND='NO' 12133 IERROR='NO' 12134C 12135 NUMCO=1 12136 ISTART=1 12137 ISTOP=1 12138 NC=1 12139C 12140C ****************************************** 12141C ****************************************** 12142C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 12143C ** HERSHEY CHARACTER SET CASE ** 12144C ****************************************** 12145C ****************************************** 12146C 12147C 12148 IF(IBUGD2.EQ.'OFF')GOTO90 12149 WRITE(ICOUT,999) 12150 999 FORMAT(1X) 12151 CALL DPWRST('XXX','BUG ') 12152 WRITE(ICOUT,51) 12153 51 FORMAT('***** AT THE BEGINNING OF DPRCS--') 12154 CALL DPWRST('XXX','BUG ') 12155 WRITE(ICOUT,52)ICHAR2 12156 52 FORMAT('ICHAR2 = ',A4) 12157 CALL DPWRST('XXX','BUG ') 12158 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 12159 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 12160 CALL DPWRST('XXX','BUG ') 12161 90 CONTINUE 12162C 12163C ************************************************** 12164C ************************************************** 12165C ** STEP 1-- ** 12166C ** SEARCH FOR THE INPUT CHARACTER(S). ** 12167C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** 12168C ************************************************** 12169C ************************************************** 12170C 12171 CALL DPCHSY(ICHAR2,ICHARN,IBUGD2,IFOUND) 12172 IF(IFOUND.EQ.'NO')GOTO9000 12173 GOTO1000 12174C 12175C ************************************** 12176C ************************************** 12177C ** STEP 2-- ** 12178C ** EXTRACT THE COORDINATES ** 12179C ** FOR THIS PARTICULAR CHARACTER. ** 12180C ************************************** 12181C ************************************** 12182C 12183 1000 CONTINUE 12184 ISTART=ISTARD(ICHARN) 12185 NC=NUMCOO(ICHARN) 12186 ISTOP=ISTART+NC-1 12187 J=0 12188 DO1100I=ISTART,ISTOP 12189 J=J+1 12190 IOP(J)=IOPERA(I) 12191 X(J)=IX(I) 12192 Y(J)=IY(I) 12193 1100 CONTINUE 12194 NUMCO=J 12195 IXMINS=IXMIND(ICHARN) 12196 IXMAXS=IXMAXD(ICHARN) 12197 IXDELS=IXDELD(ICHARN) 12198C 12199 GOTO9000 12200C 12201C ***************** 12202C ***************** 12203C ** STEP 90-- ** 12204C ** EXIT ** 12205C ***************** 12206C ***************** 12207C 12208 9000 CONTINUE 12209 IF(IBUGD2.EQ.'OFF')GOTO9090 12210 WRITE(ICOUT,999) 12211 CALL DPWRST('XXX','BUG ') 12212 WRITE(ICOUT,9011) 12213 9011 FORMAT('***** AT THE END OF DPRCS--') 12214 CALL DPWRST('XXX','BUG ') 12215 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 12216 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 12217 CALL DPWRST('XXX','BUG ') 12218 WRITE(ICOUT,9013)ICHAR2,ICHARN 12219 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) 12220 CALL DPWRST('XXX','BUG ') 12221 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 12222 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 12223 CALL DPWRST('XXX','BUG ') 12224 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 12225 DO9015I=1,NUMCO 12226 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 12227 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 12228 CALL DPWRST('XXX','BUG ') 12229 9015 CONTINUE 12230 9019 CONTINUE 12231 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 12232 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 12233 CALL DPWRST('XXX','BUG ') 12234 9090 CONTINUE 12235C 12236 RETURN 12237 END 12238 SUBROUTINE DPRCSL(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 12239 1IBUGD2,IFOUND,IERROR) 12240C 12241C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 12242C FOR ROMAN COMPLEX SCRIPT LOWER CASE. 12243C WRITTEN BY--JAMES J. FILLIBEN 12244C STATISTICAL ENGINEERING DIVISION 12245C INFORMATION TECHNOLOGY LABORATORY 12246C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 12247C GAITHERSBURG, MD 20899-8980 12248C PHONE--301-975-2855 12249C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12250C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 12251C LANGUAGE--ANSI FORTRAN (1977) 12252C VERSION NUMBER--87/4 12253C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 12254C UPDATED --MAY 1982. 12255C UPDATED --MARCH 1987. 12256C 12257C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12258C 12259 CHARACTER*4 ICHAR2 12260 CHARACTER*4 IOP 12261 CHARACTER*4 IBUGD2 12262 CHARACTER*4 IFOUND 12263 CHARACTER*4 IERROR 12264C 12265C--------------------------------------------------------------------- 12266C 12267 DIMENSION IOP(*) 12268 DIMENSION X(*) 12269 DIMENSION Y(*) 12270C 12271C--------------------------------------------------------------------- 12272C 12273 INCLUDE 'DPCOP2.INC' 12274C 12275C-----START POINT----------------------------------------------------- 12276C 12277 IFOUND='NO' 12278 IERROR='NO' 12279C 12280 NUMCO=1 12281 ISTART=1 12282 ISTOP=1 12283 NC=1 12284C 12285C ****************************************** 12286C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 12287C ** HERSHEY CHARACTER SET CASE ** 12288C ****************************************** 12289C 12290C 12291 IF(IBUGD2.EQ.'OFF')GOTO90 12292 WRITE(ICOUT,999) 12293 999 FORMAT(1X) 12294 CALL DPWRST('XXX','BUG ') 12295 WRITE(ICOUT,51) 12296 51 FORMAT('***** AT THE BEGINNING OF DPRCSL--') 12297 CALL DPWRST('XXX','BUG ') 12298 WRITE(ICOUT,52)ICHAR2 12299 52 FORMAT('ICHAR2 = ',A4) 12300 CALL DPWRST('XXX','BUG ') 12301 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 12302 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 12303 CALL DPWRST('XXX','BUG ') 12304 90 CONTINUE 12305C 12306C ************************************************** 12307C ** STEP 1-- ** 12308C ** SEARCH FOR THE INPUT CHARACTER(S). ** 12309C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** 12310C ************************************************** 12311C 12312 CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND) 12313 IF(IFOUND.EQ.'NO')GOTO9000 12314C 12315 IF(ICHARN.LE.12)GOTO1010 12316 GOTO1019 12317 1010 CONTINUE 12318 CALL DRCSL1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 12319 1IBUGD2,IFOUND,IERROR) 12320 GOTO9000 12321 1019 CONTINUE 12322C 12323 IF(13.LE.ICHARN.AND.ICHARN.LE.23)GOTO1020 12324 GOTO1029 12325 1020 CONTINUE 12326 CALL DRCSL2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 12327 1IBUGD2,IFOUND,IERROR) 12328 GOTO9000 12329 1029 CONTINUE 12330C 12331 IF(ICHARN.GE.24)GOTO1030 12332 GOTO1039 12333 1030 CONTINUE 12334 CALL DRCSL3(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 12335 1IBUGD2,IFOUND,IERROR) 12336 GOTO9000 12337 1039 CONTINUE 12338C 12339 IFOUND='NO' 12340 GOTO9000 12341C 12342C ***************** 12343C ** STEP 90-- ** 12344C ** EXIT ** 12345C ***************** 12346C 12347 9000 CONTINUE 12348 IF(IBUGD2.EQ.'OFF')GOTO9090 12349 WRITE(ICOUT,999) 12350 CALL DPWRST('XXX','BUG ') 12351 WRITE(ICOUT,9011) 12352 9011 FORMAT('***** AT THE END OF DPRCSL--') 12353 CALL DPWRST('XXX','BUG ') 12354 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 12355 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 12356 CALL DPWRST('XXX','BUG ') 12357 WRITE(ICOUT,9013)ICHAR2,ICHARN 12358 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) 12359 CALL DPWRST('XXX','BUG ') 12360 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 12361 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 12362 CALL DPWRST('XXX','BUG ') 12363 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 12364 DO9015I=1,NUMCO 12365 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 12366 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 12367 CALL DPWRST('XXX','BUG ') 12368 9015 CONTINUE 12369 9019 CONTINUE 12370 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 12371 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 12372 CALL DPWRST('XXX','BUG ') 12373 9090 CONTINUE 12374C 12375 RETURN 12376 END 12377