1 SUBROUTINE CNP(X,N,XTEMP,MAXNXT,ENGLSL,ENGUSL,IWRITE,ICNPKD, 2 1 XCNP,IBUGA3,IERROR) 3C 4C PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE NON-PARAMETRIC CP 5C (PROCESS CAPABILITY INDEX) OF THE DATA IN THE INPUT 6C VECTOR X. 7C CNP = (ENGUSL - ENGLSL)/(P(.99865) - P(0.00135)) 8C WHERE P(x) IS THE PERCENTILE FUNCTION. THIS HAS COVERAGE 9C COMPARABLE TO THE NORMAL-BASED CP STATISTIC (+/- 3*SIGMA). 10C AN ALTERNATIVE DEFINITION HAS 99% COVERAGE AND HAS THE 11C FORMULA 12C CNP = (ENGUSL - ENGLSL)/(P(.995) - P(0.005)) 13C NOTE--CP IS A MEASURE OF PROCESS PRECISION-- 14C IT CONTAINS NO BIAS INFORMATION. 15C NOTE--THE CP INDEX IS A MEASURE WHICH TAKES ON THE VALUES 0 TO 16C INFINITY. A GOOD PROCESS YIELDS VALUES OF CP WHICH ARE 17C LARGE (ABOVE 2); VALUES OF CP FROM 0.5 TO 1.0 ARE TYPICAL. 18C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 19C (UNSORTED OR SORTED) OBSERVATIONS. 20C --N = THE INTEGER NUMBER OF OBSERVATIONS 21C IN THE VECTOR X. 22C --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT 23C --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT 24C OUTPUT ARGUMENTS--CP = THE SINGLE PRECISION VALUE OF THE 25C COMPUTED SAMPLE CP 26C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE SAMPLE CP INDEX 27C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 28C OF N FOR THIS SUBROUTINE. 29C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 30C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. 31C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 32C LANGUAGE--ANSI FORTRAN (1977) 33C REFERENCES--CHEN AND DING (2001), "A NEW PROCESS CAPABILITY 34C INDEX FOR NON-NORMAL DISTRIBUTIONS", INTERNATIONAL 35C JOURNAL OF QUALITY & RELIABILITY MANAGEMENT, 36C VOL. 18, NO. 7, PP. 762-770. 37C WRITTEN BY--ALAN HECKERT 38C STATISTICAL ENGINEERING DIVISION 39C INFORMATION TECHNOLOGY LABORATORY 40C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 41C GAITHERSBURG, MD 20899 42C PHONE--301-975-28999 43C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 44C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 45C LANGUAGE--ANSI FORTRAN (1977) 46C VERSION NUMBER--2015.4 47C ORIGINAL VERSION--APRIL 2015. 48C 49C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 50C 51 CHARACTER*4 ICNPKD 52 CHARACTER*4 IWRITE 53 CHARACTER*4 IBUGA3 54 CHARACTER*4 IERROR 55C 56 CHARACTER*4 ISUBN1 57 CHARACTER*4 ISUBN2 58C 59 REAL NUM 60C 61C--------------------------------------------------------------------- 62C 63 DIMENSION X(*) 64 DIMENSION XTEMP(*) 65C 66C--------------------------------------------------------------------- 67C 68 INCLUDE 'DPCOP2.INC' 69C 70C-----START POINT----------------------------------------------------- 71C 72 ISUBN1='CNP ' 73 ISUBN2=' ' 74 IERROR='NO' 75C 76 XCNP=0.0 77 DMEAN=0.0D0 78C 79 IF(IBUGA3.EQ.'ON')THEN 80 WRITE(ICOUT,999) 81 999 FORMAT(1X) 82 CALL DPWRST('XXX','BUG ') 83 WRITE(ICOUT,51) 84 51 FORMAT('***** AT THE BEGINNING OF CNP--') 85 CALL DPWRST('XXX','BUG ') 86 WRITE(ICOUT,52)IBUGA3,N,MAXNXT,ENGUSL,ENGLSL 87 52 FORMAT('IBUGA3,N,MAXNXT,ENGUSL,ENGLSL = ',A4,2X,2I8,2G15.7) 88 CALL DPWRST('XXX','BUG ') 89 DO55I=1,N 90 WRITE(ICOUT,56)I,X(I) 91 56 FORMAT('I,X(I) = ',I8,G15.7) 92 CALL DPWRST('XXX','BUG ') 93 55 CONTINUE 94 ENDIF 95C 96C ******************************************** 97C ** COMPUTE PROCESS CAPABILITY INDEX CP ** 98C ******************************************** 99C 100C ******************************************** 101C ** STEP 1-- ** 102C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 103C ******************************************** 104C 105 AN=N 106C 107 IF(N.LT.1)THEN 108 IERROR='YES' 109 WRITE(ICOUT,999) 110 CALL DPWRST('XXX','BUG ') 111 WRITE(ICOUT,111) 112 111 FORMAT('***** ERROR IN CNP--') 113 CALL DPWRST('XXX','BUG ') 114 WRITE(ICOUT,112) 115 112 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ', 116 1 'VARIABLE IS NON-POSITIVE.') 117 CALL DPWRST('XXX','BUG ') 118 WRITE(ICOUT,117)N 119 117 FORMAT(' THE NUMBER OF OBSERVATIONS = ',I8,'.') 120 CALL DPWRST('XXX','BUG ') 121 GOTO9000 122 ELSEIF(N.EQ.1)THEN 123 GOTO9000 124 ENDIF 125C 126 HOLD=X(1) 127 DO135I=2,N 128 IF(X(I).NE.HOLD)GOTO139 129 135 CONTINUE 130 GOTO9000 131 139 CONTINUE 132C 133C **************************************** 134C ** STEP 2-- ** 135C ** COMPUTE THE MEDIAN AND PERCENTILE ** 136C ** POINTS ** 137C **************************************** 138C 139 IWRITE='OFF' 140 IF(ICNPKD.EQ.'PEAR')THEN 141 P=99.865 142 CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P995,IBUGA3,IERROR) 143 P=0.135 144 CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P005,IBUGA3,IERROR) 145 ELSE 146 P=99.5 147 CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P995,IBUGA3,IERROR) 148 P=0.5 149 CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P005,IBUGA3,IERROR) 150 ENDIF 151C 152C ************************************************** 153C ** STEP 3-- ** 154C ** COMPUTE THE CNP RATIO ** 155C ************************************************** 156C 157 NUM=ENGUSL-ENGLSL 158 IF(NUM.LE.0.0)NUM=0.0D0 159 DEN=P995-P005 160 IF(DEN.GT.0.0)XCNP=NUM/DEN 161C 162C ******************************* 163C ** STEP 3-- ** 164C ** WRITE OUT A LINE ** 165C ** OF SUMMARY INFORMATION. ** 166C ******************************* 167C 168 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 169 WRITE(ICOUT,999) 170 CALL DPWRST('XXX','BUG ') 171 WRITE(ICOUT,811)N,XCNP 172 811 FORMAT('THE CNP OF THE ',I8,' OBSERVATIONS = ',G15.7) 173 CALL DPWRST('XXX','BUG ') 174 ENDIF 175C 176C ***************** 177C ** STEP 90-- ** 178C ** EXIT. ** 179C ***************** 180C 181 9000 CONTINUE 182 IF(IBUGA3.EQ.'ON')THEN 183 WRITE(ICOUT,999) 184 CALL DPWRST('XXX','BUG ') 185 WRITE(ICOUT,9011) 186 9011 FORMAT('***** AT THE END OF CP--') 187 CALL DPWRST('XXX','BUG ') 188 WRITE(ICOUT,9012)IBUGA3,IERROR 189 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 190 CALL DPWRST('XXX','BUG ') 191 WRITE(ICOUT,9017)NUM,DEN,XCNP 192 9017 FORMAT('NUM,DEN,XCNP = ',3G15.7) 193 CALL DPWRST('XXX','BUG ') 194 ENDIF 195C 196 RETURN 197 END 198 SUBROUTINE CNPK(X,N,XTEMP,MAXNXT,ENGLSL,ENGUSL,IWRITE,ICNPKD, 199 1 XCNPK, 200 1 IBUGA3,IERROR) 201C 202C PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE CNPK 203C (PROCESS CAPABILITY INDEX) OF THE DATA IN THE INPUT 204C VECTOR X. 205C CNPK = MIN(A,B) 206C WHERE: 207C A = (USL-MEDIAN)/(P(.995)-MEDIAN) 208C B = (MEDIAN-LSL)/(MEDIAN-P(.005)) 209C P = THE PERCENTILE FUNCTION 210C NOTE--SUPPORT OPTIONAL FORMULA THAT SEEMS TO BE MORE 211C PREVALENT IN THE LITERATURE: 212C 213C CNPK = MIN(A,B) 214C WHERE: 215C A = (USL-MEDIAN)/((P(.99865)-P(.00135))/2) 216C B = (MEDIAN-LSL)/((P(.99865)-P(.00135))/2) 217C P = THE PERCENTILE FUNCTION 218C NOTE--CNPK IS A MEASURE OF PROCESS ACCURACY-- 219C COMBINING BOTH PRECISION AND UNBIASEDNESS. 220C IT IS A NON-PARAMETERIC METHOD FOR THE CPK STATISTIC 221C THAT IS RECOMMENDED WHEN THE DATA ARE NOT NORMAL. 222C NOTE--THE CNPK INDEX IS A MEASURE WHICH TAKES ON THE VALUES 0 TO 223C INFINITY. A GOOD PROCESS YIELDS VALUES OF CNPK 224C WHICH ARE LARGE (ABOVE 2); 225C VALUES OF CNPK FROM 0.5 TO 1.0 ARE TYPICAL. 226C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 227C (UNSORTED OR SORTED) OBSERVATIONS. 228C --N = THE INTEGER NUMBER OF OBSERVATIONS 229C IN THE VECTOR X. 230C --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT 231C --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT 232C OUTPUT ARGUMENTS--CNPK = THE SINGLE PRECISION VALUE OF THE 233C COMPUTED SAMPLE CNPK 234C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE 235C SAMPLE CNPK INDEX 236C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 237C OF N FOR THIS SUBROUTINE. 238C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 239C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. 240C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 241C LANGUAGE--ANSI FORTRAN (1977) 242C REFERENCES--AFP 800-7. "USAF R&M 2000 PROCESS", DEPARTMENT OF 243C THE AIR FORCE, HQ USAF, WASHINGTON, DC GPO, 1 OCT 244C 1988. (THIS ISN'T THE RIGHT DOCUMENT, NOT SURE 245C WHICH DOCUMENT ACTUALLY HAS THE TECHNICAL DETAILS). 246C --PEARN, TAI, HSIAO, AND AO (2014), "APPROXIMATELY 247C UNBIASED ESTIMATOR FOR NON-NORMAL PROCESS 248C CAPABILITY INDEX", JOURNAL OF TESTING AND 249C EVALUATION, VOL. 42, NO. 6, PP. 1-10. 250C --CHEN AND DING (2001), "A NEW PROCESS CAPABILITY 251C INDEX FOR NON-NORMAL DISTRIBUTIONS", INTERNATIONAL 252C JOURNAL OF QUALITY & RELIABILITY MANAGEMENT, 253C VOL. 18, NO. 7, PP. 762-770. 254C WRITTEN BY--JAMES J. FILLIBEN 255C STATISTICAL ENGINEERING DIVISION 256C INFORMATION TECHNOLOGY LABORATORY 257C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 258C GAITHERSBURG, MD 20899 259C PHONE--301-975-2855 260C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 261C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 262C LANGUAGE--ANSI FORTRAN (1977) 263C VERSION NUMBER--99.3 264C ORIGINAL VERSION--MARCH 1999. 265C UPDATED --APRIL 2015. SUPPORT ALTERNATIVE DEFINITION 266C 267C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 268C 269 CHARACTER*4 ICNPKD 270 CHARACTER*4 IWRITE 271 CHARACTER*4 IBUGA3 272 CHARACTER*4 IERROR 273C 274 CHARACTER*4 ISUBN1 275 CHARACTER*4 ISUBN2 276C 277C--------------------------------------------------------------------- 278C 279 DIMENSION X(*) 280 DIMENSION XTEMP(*) 281C 282C--------------------------------------------------------------------- 283C 284 INCLUDE 'DPCOP2.INC' 285C 286C-----START POINT----------------------------------------------------- 287C 288 ISUBN1='CNPK' 289 ISUBN2=' ' 290 IERROR='NO' 291C 292 DMEAN=0.0D0 293 XCNPK=0.0 294C 295 IF(IBUGA3.EQ.'ON')THEN 296 WRITE(ICOUT,999) 297 999 FORMAT(1X) 298 CALL DPWRST('XXX','BUG ') 299 WRITE(ICOUT,51) 300 51 FORMAT('***** AT THE BEGINNING OF CNPK--') 301 CALL DPWRST('XXX','BUG ') 302 WRITE(ICOUT,52)IBUGA3,N,ENGUSL,ENGLSL 303 52 FORMAT('IBUGA3,N,ENGUSL,ENGLSL = ',A4,2X,I8,2G15.7) 304 CALL DPWRST('XXX','BUG ') 305 DO55I=1,N 306 WRITE(ICOUT,56)I,X(I) 307 56 FORMAT('I,X(I) = ',I8,G15.7) 308 CALL DPWRST('XXX','BUG ') 309 55 CONTINUE 310 ENDIF 311C 312C ******************************************** 313C ** COMPUTE PROCESS CAPABILITY INDEX CNPK ** 314C ******************************************** 315C 316C ******************************************** 317C ** STEP 1-- ** 318C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 319C ******************************************** 320C 321 AN=N 322C 323 IF(N.LT.1)THEN 324 IERROR='YES' 325 WRITE(ICOUT,999) 326 CALL DPWRST('XXX','BUG ') 327 WRITE(ICOUT,111) 328 111 FORMAT('***** ERROR IN CNPK--') 329 CALL DPWRST('XXX','BUG ') 330 WRITE(ICOUT,112) 331 112 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ', 332 1 'VARIABLE IS NON-POSITIVE.') 333 CALL DPWRST('XXX','BUG ') 334 WRITE(ICOUT,117)N 335 117 FORMAT(' THE NUMBER OF OBSERVATIONS HERE = ',I8,'.') 336 CALL DPWRST('XXX','BUG ') 337 GOTO9000 338 ELSEIF(N.EQ.1)THEN 339 GOTO9000 340 ENDIF 341C 342 HOLD=X(1) 343 DO135I=2,N 344 IF(X(I).NE.HOLD)GOTO139 345 135 CONTINUE 346 GOTO9000 347 139 CONTINUE 348C 349C **************************************** 350C ** STEP 2-- ** 351C ** COMPUTE THE MEDIAN AND PERCENTILE ** 352C ** POINTS ** 353C **************************************** 354C 355 IWRITE='OFF' 356 CALL MEDIAN(X,N,IWRITE,XTEMP,MAXNXT,XMED,IBUGA3,IERROR) 357 IF(ICNPKD.EQ.'PEAR')THEN 358 P=99.865 359 CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P995,IBUGA3,IERROR) 360 P=0.135 361 CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P005,IBUGA3,IERROR) 362 ELSE 363 P=99.5 364 CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P995,IBUGA3,IERROR) 365 P=0.5 366 CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P005,IBUGA3,IERROR) 367 ENDIF 368C 369C ************************************************** 370C ** STEP 3-- ** 371C ** COMPUTE THE CNPK RATIO ** 372C ************************************************** 373C 374 IF(ICNPKD.EQ.'PEAR')THEN 375 DENOM=(P995 - P005)/2.0 376 UPPER=(ENGUSL-XMED)/DENOM 377 ALOWER=(XMED-ENGLSL)/DENOM 378 XCNPK=MIN(UPPER,ALOWER) 379 ELSE 380 UPPER=(ENGUSL-XMED)/(P995-XMED) 381 ALOWER=(XMED-ENGLSL)/(XMED-P005) 382 XCNPK=MIN(UPPER,ALOWER) 383 ENDIF 384C 385C ******************************* 386C ** STEP 3-- ** 387C ** WRITE OUT A LINE ** 388C ** OF SUMMARY INFORMATION. ** 389C ******************************* 390C 391 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 392 WRITE(ICOUT,999) 393 CALL DPWRST('XXX','BUG ') 394 WRITE(ICOUT,811)N,XCNPK 395 811 FORMAT('THE CNPK OF THE ',I8,' OBSERVATIONS = ', 396 1 G15.7) 397 CALL DPWRST('XXX','BUG ') 398 ENDIF 399C 400C ***************** 401C ** STEP 90-- ** 402C ** EXIT. ** 403C ***************** 404C 405 9000 CONTINUE 406 IF(IBUGA3.EQ.'ON')THEN 407 WRITE(ICOUT,999) 408 CALL DPWRST('XXX','BUG ') 409 WRITE(ICOUT,9011) 410 9011 FORMAT('***** AT THE END OF CNPK--') 411 CALL DPWRST('XXX','BUG ') 412 WRITE(ICOUT,9012)IBUGA3,IERROR 413 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 414 CALL DPWRST('XXX','BUG ') 415 WRITE(ICOUT,9014)XMED,P005,P995 416 9014 FORMAT('XMED,P005,P995 = ',3G15.7) 417 CALL DPWRST('XXX','BUG ') 418 WRITE(ICOUT,9016)UPPER,ALOWER,XCNPK 419 9016 FORMAT('UPPER,ALOWER ,XCNPK= ',3G15.7) 420 CALL DPWRST('XXX','BUG ') 421 ENDIF 422C 423 RETURN 424 END 425 SUBROUTINE CNPM(X,N,XTEMP,MAXNXT,ENGLSL,ENGUSL,TARGET,IWRITE, 426 1 ICNPKD,XCNPM, 427 1 IBUGA3,IERROR) 428C 429C PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE CNPM PROCESS 430C CAPABILITY INDEX OF THE DATA IN THE INPUT VECTOR X. 431C THIS IS A NON-PARAMETRIC VERSION OF THE CPM STATISTIC. 432C 433C CNPM = (USL - LSL)/ 434C [6*SQRT{((P(0.99865)-P(0.00135)/6)**2 + 435C (MEDIAN - TARGET)**2}] 436C 437C WHERE P(x) IS THE PERCENTILE FUNCTION. THIS HAS COVERAGE 438C COMPARABLE TO THE NORMAL-BASED CPM STATISTIC (+/- 3*SIGMA). 439C AN ALTERNATIVE DEFINITION HAS 99% COVERAGE AND USES 440C P(0.995) AND P(0.005). 441C NOTE--CNPM IS A MEASURE OF PROCESS ACCURACY-- 442C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 443C (UNSORTED OR SORTED) OBSERVATIONS. 444C --N = THE INTEGER NUMBER OF OBSERVATIONS 445C IN THE VECTOR X. 446C --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT 447C --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT 448C --TARGET = TARGET (ENGINEERING) SPEC LIMIT 449C OUTPUT ARGUMENTS--XCNPM = THE SINGLE PRECISION VALUE OF THE 450C COMPUTED SAMPLE CNPM 451C --XLCL = LOWER 95% CONFIDENCE INTERVAL 452C --XUCL = UPPER 95% CONFIDENCE INTERVAL 453C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE SAMPLE CPM INDEX 454C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 455C OF N FOR THIS SUBROUTINE. 456C OTHER DATAPAC SUBROUTINES NEEDED--MEAN AND SD. 457C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. 458C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 459C LANGUAGE--ANSI FORTRAN (1977) 460C REFERENCES--NORMA HUBELE, ARIZONA STATE 461C --CHEN AND DING (2001), "A NEW PROCESS CAPABILITY 462C INDEX FOR NON-NORMAL DISTRIBUTIONS", INTERNATIONAL 463C JOURNAL OF QUALITY & RELIABILITY MANAGEMENT, 464C VOL. 18, NO. 7, PP. 762-770. 465C WRITTEN BY--ALAN HECKERT 466C STATISTICAL ENGINEERING DIVISION 467C INFORMATION TECHNOLOGY LABORATORY 468C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 469C GAITHERSBURG, MD 20899 470C PHONE--301-975-2899 471C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 472C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 473C LANGUAGE--ANSI FORTRAN (1977) 474C VERSION NUMBER--2015.04 475C ORIGINAL VERSION--APRIL 2015. 476C 477C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 478C 479 CHARACTER*4 ICNPKD 480 CHARACTER*4 IWRITE 481 CHARACTER*4 IBUGA3 482 CHARACTER*4 IERROR 483C 484 CHARACTER*4 ISUBN1 485 CHARACTER*4 ISUBN2 486C 487 REAL NUM 488C 489C--------------------------------------------------------------------- 490C 491 DIMENSION X(*) 492 DIMENSION XTEMP(*) 493C 494C--------------------------------------------------------------------- 495C 496 INCLUDE 'DPCOP2.INC' 497C 498C-----START POINT----------------------------------------------------- 499C 500 ISUBN1='CNPM' 501 ISUBN2=' ' 502 IERROR='NO' 503C 504 XCNPM=0.0 505C 506 IF(IBUGA3.EQ.'ON')THEN 507 WRITE(ICOUT,999) 508 999 FORMAT(1X) 509 CALL DPWRST('XXX','BUG ') 510 WRITE(ICOUT,51) 511 51 FORMAT('***** AT THE BEGINNING OF CNPM--') 512 CALL DPWRST('XXX','BUG ') 513 WRITE(ICOUT,52)IBUGA3,N,ENGUSL,ENGLSL,TARGET 514 52 FORMAT('IBUGA3,N,ENGUSL,ENGLSL,TARGET = ',A4,2X,I8,3G15.7) 515 CALL DPWRST('XXX','BUG ') 516 DO55I=1,N 517 WRITE(ICOUT,56)I,X(I) 518 56 FORMAT('I,X(I) = ',I8,G15.7) 519 CALL DPWRST('XXX','BUG ') 520 55 CONTINUE 521 ENDIF 522C 523C ******************************************** 524C ** COMPUTE PROCESS CAPABILITY INDEX CNPM ** 525C ******************************************** 526C 527C ******************************************** 528C ** STEP 1-- ** 529C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 530C ******************************************** 531C 532 AN=N 533C 534 IF(N.LT.1)THEN 535 IERROR='YES' 536 WRITE(ICOUT,999) 537 CALL DPWRST('XXX','BUG ') 538 WRITE(ICOUT,111) 539 111 FORMAT('***** ERROR IN CNPM--') 540 CALL DPWRST('XXX','BUG ') 541 WRITE(ICOUT,112) 542 112 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ', 543 1 'VARIABLE IS NON-POSITIVE.') 544 CALL DPWRST('XXX','BUG ') 545 WRITE(ICOUT,117)N 546 117 FORMAT(' THE NUMBER OF OBSERVATIONS = ',I8,'.') 547 CALL DPWRST('XXX','BUG ') 548 GOTO9000 549 ELSEIF(N.EQ.1)THEN 550 GOTO9000 551 ENDIF 552C 553 HOLD=X(1) 554 DO135I=2,N 555 IF(X(I).NE.HOLD)GOTO139 556 135 CONTINUE 557 GOTO9000 558 139 CONTINUE 559C 560C **************************************** 561C ** STEP 2-- ** 562C ** COMPUTE THE MEDIAN AND PERCENTILE ** 563C ** POINTS ** 564C **************************************** 565C 566 IWRITE='OFF' 567 CALL MEDIAN(X,N,IWRITE,XTEMP,MAXNXT,XMED,IBUGA3,IERROR) 568 IF(ICNPKD.EQ.'PEAR')THEN 569 P=99.865 570 CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P995,IBUGA3,IERROR) 571 P=0.135 572 CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P005,IBUGA3,IERROR) 573 ELSE 574 P=99.5 575 CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P995,IBUGA3,IERROR) 576 P=0.5 577 CALL PERCEN(P,X,N,IWRITE,XTEMP,MAXNXT,P005,IBUGA3,IERROR) 578 ENDIF 579C 580C ************************************************** 581C ** STEP 3-- ** 582C ** COMPUTE THE CNPM RATIO ** 583C ************************************************** 584C 585 NUM=ABS(ENGUSL-ENGLSL) 586 TERM1=(P995-P005)/6.0 587 TERM2=(XMED-TARGET)**2 588 DEN=6.0*SQRT(TERM1**2 + TERM2) 589 IF(DEN.GT.0.0)XCNPM=NUM/DEN 590C 591C ******************************* 592C ** STEP 3-- ** 593C ** WRITE OUT A LINE ** 594C ** OF SUMMARY INFORMATION. ** 595C ******************************* 596C 597 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 598 WRITE(ICOUT,999) 599 CALL DPWRST('XXX','BUG ') 600 WRITE(ICOUT,811)N,XNCPM 601 811 FORMAT('THE CNPM OF THE ',I8,' OBSERVATIONS = ',G15.7) 602 CALL DPWRST('XXX','BUG ') 603 ENDIF 604C 605C ***************** 606C ** STEP 90-- ** 607C ** EXIT. ** 608C ***************** 609C 610 9000 CONTINUE 611 IF(IBUGA3.EQ.'ON')THEN 612 WRITE(ICOUT,999) 613 CALL DPWRST('XXX','BUG ') 614 WRITE(ICOUT,9011) 615 9011 FORMAT('***** AT THE END OF CNPM--') 616 CALL DPWRST('XXX','BUG ') 617 WRITE(ICOUT,9012)IBUGA3,IERROR 618 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 619 CALL DPWRST('XXX','BUG ') 620 WRITE(ICOUT,9014)XMED,P005,P995 621 9014 FORMAT('XMED,P005,P995 = ',3G15.7) 622 CALL DPWRST('XXX','BUG ') 623 WRITE(ICOUT,9016)NUM,DEN,XCNPM 624 9016 FORMAT('NUM,DEN,XCNPM= ',3G15.7) 625 CALL DPWRST('XXX','BUG ') 626 ENDIF 627C 628 RETURN 629 END 630 SUBROUTINE CNPMK(X,N,XTEMP1,MAXNXT,ENGLSL,ENGUSL,TARGET,IWRITE, 631 1 ICNPKD,XCNPMK, 632 1 IBUGA3,IERROR) 633C 634C PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE CNPMK PROCESS 635C CAPABILITY INDEX OF THE DATA IN THE INPUT VECTOR X. 636C THIS IS A NON-PARAMETRIC VERSION OF THE CPMK STATISTIC. 637C 638C CNPMK = min{(USL - MED,MED-LSL)}/ 639C [3*SQRT{((P(0.99865)-P(0.00135)/6)**2 + 640C (MEDIAN - TARGET)**2}] 641C 642C WHERE P(x) IS THE PERCENTILE FUNCTION. THIS HAS COVERAGE 643C COMPARABLE TO THE NORMAL-BASED CPM STATISTIC (+/- 3*SIGMA). 644C AN ALTERNATIVE DEFINITION HAS 99% COVERAGE AND USES 645C P(0.995) AND P(0.005). 646C NOTE--CNPM IS A MEASURE OF PROCESS ACCURACY-- 647C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 648C (UNSORTED OR SORTED) OBSERVATIONS. 649C --N = THE INTEGER NUMBER OF OBSERVATIONS 650C IN THE VECTOR X. 651C --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT 652C --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT 653C --TARGET = TARGET (ENGINEERING) SPEC LIMIT 654C OUTPUT ARGUMENTS--XCNPMK = THE SINGLE PRECISION VALUE OF THE 655C COMPUTED SAMPLE CNPMK 656C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE SAMPLE CPMK INDEX 657C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 658C OF N FOR THIS SUBROUTINE. 659C OTHER DATAPAC SUBROUTINES NEEDED--NONE 660C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. 661C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 662C LANGUAGE--ANSI FORTRAN (1977) 663C REFERENCES--CHEN AND DING (2001), "A NEW PROCESS CAPABILITY 664C INDEX FOR NON-NORMAL DISTRIBUTIONS", INTERNATIONAL 665C JOURNAL OF QUALITY & RELIABILITY MANAGEMENT, 666C VOL. 18, NO. 7, PP. 762-770. 667C WRITTEN BY--ALAN HECKERT 668C STATISTICAL ENGINEERING DIVISION 669C INFORMATION TECHNOLOGY LABORATORY 670C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 671C GAITHERSBURG, MD 20899 672C PHONE--301-975-2899 673C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 674C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 675C LANGUAGE--ANSI FORTRAN (1977) 676C VERSION NUMBER--2015.04 677C ORIGINAL VERSION--APRIL 2015. 678C 679C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 680C 681 CHARACTER*4 ICNPKD 682 CHARACTER*4 IWRITE 683 CHARACTER*4 IBUGA3 684 CHARACTER*4 IERROR 685C 686 CHARACTER*4 ISUBN1 687 CHARACTER*4 ISUBN2 688C 689 REAL NUM 690C 691C--------------------------------------------------------------------- 692C 693 DIMENSION X(*) 694 DIMENSION XTEMP1(*) 695C 696C--------------------------------------------------------------------- 697C 698 INCLUDE 'DPCOP2.INC' 699C 700C-----START POINT----------------------------------------------------- 701C 702 ISUBN1='CNPM' 703 ISUBN2='K ' 704 IERROR='NO' 705C 706 XCNPMK=0.0 707C 708 IF(IBUGA3.EQ.'ON')THEN 709 WRITE(ICOUT,999) 710 999 FORMAT(1X) 711 CALL DPWRST('XXX','BUG ') 712 WRITE(ICOUT,51) 713 51 FORMAT('***** AT THE BEGINNING OF CNPMK--') 714 CALL DPWRST('XXX','BUG ') 715 WRITE(ICOUT,52)IBUGA3,N,ENGUSL,ENGLSL,TARGET 716 52 FORMAT('IBUGA3,N,ENGUSL,ENGLSL,TARGET = ',A4,2X,I8,3G15.7) 717 CALL DPWRST('XXX','BUG ') 718 DO55I=1,N 719 WRITE(ICOUT,56)I,X(I) 720 56 FORMAT('I,X(I) = ',I8,G15.7) 721 CALL DPWRST('XXX','BUG ') 722 55 CONTINUE 723 ENDIF 724C 725C ******************************************** 726C ** COMPUTE PROCESS CAPABILITY INDEX CNPM ** 727C ******************************************** 728C 729C ******************************************** 730C ** STEP 1-- ** 731C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 732C ******************************************** 733C 734 AN=N 735C 736 IF(N.LT.1)THEN 737 IERROR='YES' 738 WRITE(ICOUT,999) 739 CALL DPWRST('XXX','BUG ') 740 WRITE(ICOUT,111) 741 111 FORMAT('***** ERROR IN CNPMK--') 742 CALL DPWRST('XXX','BUG ') 743 WRITE(ICOUT,112) 744 112 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ', 745 1 'VARIABLE IS NON-POSITIVE.') 746 CALL DPWRST('XXX','BUG ') 747 WRITE(ICOUT,117)N 748 117 FORMAT(' THE NUMBER OF OBSERVATIONS = ',I8,'.') 749 CALL DPWRST('XXX','BUG ') 750 GOTO9000 751 ELSEIF(N.EQ.1)THEN 752 GOTO9000 753 ENDIF 754C 755 HOLD=X(1) 756 DO135I=2,N 757 IF(X(I).NE.HOLD)GOTO139 758 135 CONTINUE 759 GOTO9000 760 139 CONTINUE 761C 762C **************************************** 763C ** STEP 2-- ** 764C ** COMPUTE THE MEDIAN AND PERCENTILE ** 765C ** POINTS ** 766C **************************************** 767C 768 IWRITE='OFF' 769 CALL MEDIAN(X,N,IWRITE,XTEMP1,MAXNXT,XMED,IBUGA3,IERROR) 770 IF(ICNPKD.EQ.'PEAR')THEN 771 P=99.865 772 CALL PERCEN(P,X,N,IWRITE,XTEMP1,MAXNXT,P995,IBUGA3,IERROR) 773 P=0.135 774 CALL PERCEN(P,X,N,IWRITE,XTEMP1,MAXNXT,P005,IBUGA3,IERROR) 775 ELSE 776 P=99.5 777 CALL PERCEN(P,X,N,IWRITE,XTEMP1,MAXNXT,P995,IBUGA3,IERROR) 778 P=0.5 779 CALL PERCEN(P,X,N,IWRITE,XTEMP1,MAXNXT,P005,IBUGA3,IERROR) 780 ENDIF 781C 782C ************************************************** 783C ** STEP 3-- ** 784C ** COMPUTE THE CNPM RATIO ** 785C ************************************************** 786C 787 UPPER=ENGUSL-XMED 788 ALOWER=XMED-ENGLSL 789 NUM=MIN(UPPER,ALOWER) 790 TERM1=(P995-P005)/6.0 791 TERM2=(XMED-TARGET)**2 792 DEN=3.0*SQRT(TERM1**2 + TERM2) 793 IF(DEN.GT.0.0)XCNPMK=NUM/DEN 794C 795C ******************************* 796C ** STEP 3-- ** 797C ** WRITE OUT A LINE ** 798C ** OF SUMMARY INFORMATION. ** 799C ******************************* 800C 801 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 802 WRITE(ICOUT,999) 803 CALL DPWRST('XXX','BUG ') 804 WRITE(ICOUT,811)N,XNCPMK 805 811 FORMAT('THE CNPMK OF THE ',I8,' OBSERVATIONS = ',G15.7) 806 CALL DPWRST('XXX','BUG ') 807 ENDIF 808C 809C ***************** 810C ** STEP 90-- ** 811C ** EXIT. ** 812C ***************** 813C 814 9000 CONTINUE 815 IF(IBUGA3.EQ.'ON')THEN 816 WRITE(ICOUT,999) 817 CALL DPWRST('XXX','BUG ') 818 WRITE(ICOUT,9011) 819 9011 FORMAT('***** AT THE END OF CNPM--') 820 CALL DPWRST('XXX','BUG ') 821 WRITE(ICOUT,9012)IBUGA3,IERROR 822 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 823 CALL DPWRST('XXX','BUG ') 824 WRITE(ICOUT,9014)XMED,P005,P995 825 9014 FORMAT('XMED,P005,P995 = ',3G15.7) 826 CALL DPWRST('XXX','BUG ') 827 WRITE(ICOUT,9016)NUM,DEN,XCNPMK 828 9016 FORMAT('NUM,DEN,XCNPMK= ',3G15.7) 829 CALL DPWRST('XXX','BUG ') 830 ENDIF 831C 832 RETURN 833 END 834 SUBROUTINE COCODE(X,N,XREF,NREF,XPRIME,IBUGA3) 835C 836C PURPOSE--THIS SUBROUTINE CO-CODES 837C THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X, 838C AS DICTATED BY HOW X MATCHES XREF. 839C IN PARTICULAR, ALL ELEMENTS IN X THAT MATCH XREF(1) 840C WILL GET CODED WITH 1. 841C ALL ELEMENTS IN X THAT MATCH XREF(2) 842C WILL GET CODED WITH 2. 843C ETC. 844C THE OUTPUT IS, IN FACT, PLACED IN XPRIME. 845C (X AND XREF REMAIN UNCHANGED) 846C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 847C OBSERVATIONS TO BE CO-CODED. 848C --N = THE INTEGER NUMBER OF OBSERVATIONS 849C IN THE VECTOR X AND XPRIME. 850C --XREF = THE SINGLE PRECISION VECTOR OF 851C REFERENCE OBSERVATIONS. 852C --NREF = THE INTEGER NUMBER OF OBSERVATIONS 853C IN THE VECTOR XREF. 854C OUTPUT ARGUMENTS--XPRIME = THE SINGLE PRECISION VECTOR 855C INTO WHICH THE RECODED DATA VALUES 856C WILL BE PLACED. 857C OUTPUT--THE SINGLE PRECISION VECTOR XPRIME 858C CONTAINING THE RECODED VALUES. 859C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 860C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 861C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 862C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 863C LANGUAGE--ANSI FORTRAN (1977) 864C WRITTEN BY--JAMES J. FILLIBEN 865C STATISTICAL ENGINEERING DIVISION 866C INFORMATION TECHNOLOGY LABORATORY 867C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 868C GAITHERSBURG, MD 20899 869C PHONE--301-975-2855 870C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 871C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 872C ORIGINAL VERSION--JULY 1991. 873C 874C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 875C 876C--------------------------------------------------------------------- 877C 878 DIMENSION X(*),XREF(*),XPRIME(*) 879 CHARACTER*4 IBUGA3 880C 881C--------------------------------------------------------------------- 882C 883 INCLUDE 'DPCOP2.INC' 884C 885C-----START POINT----------------------------------------------------- 886C 887C CHECK THE INPUT ARGUMENTS FOR ERRORS 888C 889 IF(N.LT.1)GOTO50 890 GOTO90 891 50 CONTINUE 892 WRITE(ICOUT,15) 893 15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 894 1'SORTC SUBROUTINE IS NON-POSITIVE *****') 895 CALL DPWRST('XXX','BUG ') 896 WRITE(ICOUT,47)N 897 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') 898 CALL DPWRST('XXX','BUG ') 899 RETURN 900 90 CONTINUE 901C 902 IF(IBUGA3.NE.'ON')GOTO190 903 WRITE(ICOUT,999) 904 999 FORMAT(1X) 905 CALL DPWRST('XXX','BUG ') 906 WRITE(ICOUT,110) 907 110 FORMAT('***** AT THE BEGINNING OF COCODE--') 908 CALL DPWRST('XXX','BUG ') 909 WRITE(ICOUT,111)N,NREF 910 111 FORMAT('N,NREF = ',I8,I8) 911 CALL DPWRST('XXX','BUG ') 912 DO112I=1,N 913 WRITE(ICOUT,113)I,X(I),XREF(I) 914 113 FORMAT('I,X(I),XREF(I) = ',I8,2E15.7) 915 CALL DPWRST('XXX','BUG ') 916 112 CONTINUE 917 190 CONTINUE 918C 919 DO1100I=1,N 920 XPRIME(I)=-999 921 1100 CONTINUE 922C 923 DO1200I=1,NREF 924 XREFI=XREF(I) 925 DO1300J=1,N 926 IF(X(J).EQ.XREFI)XPRIME(J)=I 927 1300 CONTINUE 928 1200 CONTINUE 929C 930 IF(IBUGA3.EQ.'ON')THEN 931 WRITE(ICOUT,999) 932 CALL DPWRST('XXX','BUG ') 933 WRITE(ICOUT,9011) 934 9011 FORMAT('***** AT THE END OF COCODE--') 935 CALL DPWRST('XXX','BUG ') 936 WRITE(ICOUT,9012)N,NREF 937 9012 FORMAT('N,NREF = ',2I8) 938 CALL DPWRST('XXX','BUG ') 939 DO9015I=1,N 940 WRITE(ICOUT,9016)I,X(I),XREF(I),XPRIME(I) 941 9016 FORMAT('I,X(I),XREF(I),XPRIME(I) = ',I8,3G15.7) 942 CALL DPWRST('XXX','BUG ') 943 9015 CONTINUE 944 ENDIF 945C 946 RETURN 947 END 948 SUBROUTINE COCOPY(YREF,NREF,X,NX,XREF,Y,NY,IBUGA3) 949C 950C PURPOSE--THIS SUBROUTINE CO-COPIES 951C THE NREF ELEMENTS OF THE SINGLE PRECISION 952C VECTOR YREF INTO THE (TYPICALLY) LONGER VECTOR Y. 953C AS DICTATED BY HOW X MATCHES XREF. 954C IN PARTICULAR, FOR ALL ELEMENTS IN X THAT MATCH XREF(1), 955C Y WILL BECOME YREF(1). 956C FOR ALL ELEMENTS IN X THAT MATCH XREF(2), 957C Y WILL BECOME YREF(2). 958C ETC. 959C THE OUTPUT IS, IN FACT, PLACED IN Y. 960C (X, XREF, AND YREF REMAIN UNCHANGED). 961C INPUT ARGUMENTS--YREF = THE SINGLE PRECISION VECTOR OF 962C OBSERVATIONS TO BE CO-COPIED. 963C --NREF = THE INTEGER NUMBER OF OBSERVATIONS 964C IN THE VECTOR YREF (AND XREF). 965C --X = THE SINGLE PRECISION VECTOR OF 966C OBSERVATIONS USED FOR MATCHING . 967C --NX = THE INTEGER NUMBER OF OBSERVATIONS 968C IN THE VECTOR X (AND Y). 969C --XREF = THE SINGLE PRECISION VECTOR OF 970C REFERENCE OBSERVATIONS. 971C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR 972C INTO WHICH THE VARIOUS YREF VALUES 973C WILL BE COPIED. 974C NY = THE INTEGER NUMBER OF ELEMENTS 975C IN Y (= NX) 976C OUTPUT--THE SINGLE PRECISION VECTOR Y 977C CONTAINING THE COPIED VALUES. 978C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 979C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 980C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 981C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 982C LANGUAGE--ANSI FORTRAN (1977) 983C WRITTEN BY--JAMES J. FILLIBEN 984C STATISTICAL ENGINEERING DIVISION 985C INFORMATION TECHNOLOGY LABORATORY 986C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 987C GAITHERSBURG, MD 20899 988C PHONE--301-975-2855 989C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 990C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 991C ORIGINAL VERSION--JULY 1991. 992C 993C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 994C 995C--------------------------------------------------------------------- 996C 997 DIMENSION YREF(*),X(*),XREF(*),Y(*) 998 CHARACTER*4 IBUGA3 999C 1000C--------------------------------------------------------------------- 1001C 1002 INCLUDE 'DPCOP2.INC' 1003C 1004C-----START POINT----------------------------------------------------- 1005C 1006C CHECK THE INPUT ARGUMENTS FOR ERRORS 1007C 1008 IF(NX.LT.1)GOTO50 1009 GOTO90 1010 50 CONTINUE 1011 WRITE(ICOUT,15) 1012 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1013 1'SORTC SUBROUTINE IS NON-POSITIVE *****') 1014 CALL DPWRST('XXX','BUG ') 1015 WRITE(ICOUT,47)NX 1016 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') 1017 CALL DPWRST('XXX','BUG ') 1018 NY=NX 1019 RETURN 1020 90 CONTINUE 1021C 1022 IF(IBUGA3.NE.'ON')GOTO190 1023 WRITE(ICOUT,999) 1024 999 FORMAT(1X) 1025 CALL DPWRST('XXX','BUG ') 1026 WRITE(ICOUT,110) 1027 110 FORMAT('***** AT THE BEGINNING OF COCOPY--') 1028 CALL DPWRST('XXX','BUG ') 1029 WRITE(ICOUT,111)NREF,NX 1030 111 FORMAT('NREF,NX = ',I8,I8) 1031 CALL DPWRST('XXX','BUG ') 1032 DO112I=1,NX 1033 WRITE(ICOUT,113)I,X(I),XREF(I),YREF(I) 1034 113 FORMAT('I,X(I),XREF(I),YREF(I) = ',I8,3E15.7) 1035 CALL DPWRST('XXX','BUG ') 1036 112 CONTINUE 1037 190 CONTINUE 1038C 1039 DO1100I=1,NX 1040 Y(I)=-999 1041 1100 CONTINUE 1042C 1043 DO1200I=1,NREF 1044 XREFI=XREF(I) 1045 DO1300J=1,NX 1046 IF(X(J).EQ.XREFI)Y(J)=YREF(I) 1047 1300 CONTINUE 1048 1200 CONTINUE 1049 NY=NX 1050C 1051 IF(IBUGA3.EQ.'ON')THEN 1052 WRITE(ICOUT,999) 1053 CALL DPWRST('XXX','BUG ') 1054 WRITE(ICOUT,9011) 1055 9011 FORMAT('***** AT THE END OF COCOPY--') 1056 CALL DPWRST('XXX','BUG ') 1057 WRITE(ICOUT,9012)NREF,NX,NY 1058 9012 FORMAT('NREF,NX,NY = ',I8,I8,I8) 1059 CALL DPWRST('XXX','BUG ') 1060 DO9015I=1,NX 1061 WRITE(ICOUT,9016)I,X(I),XREF(I),YREF(I) 1062 9016 FORMAT('I,X(I),XREF(I),YREF(I) = ',I8,3E15.7) 1063 CALL DPWRST('XXX','BUG ') 1064 9015 CONTINUE 1065 DO9020I=1,NY 1066 WRITE(ICOUT,9021)I,Y(I) 1067 9021 FORMAT('I,Y(I) = ',I8,E15.7) 1068 CALL DPWRST('XXX','BUG ') 1069 9020 CONTINUE 1070 ENDIF 1071C 1072 RETURN 1073 END 1074 SUBROUTINE CODCT2(X1,X2,N,ICCTOF,ICCTG1,IWRITE, 1075 1 Y,XIDTEM,XIDTE2, 1076 1 IBUGA3,ISUBRO,IERROR) 1077C 1078C PURPOSE--THIS SUBROUTINE CREATES A CODED VARIABLE FROM THE 1079C CROSS TABULATION OF TWO GROUP-ID VARIABLES. THIS 1080C CAN BE USEFUL FOR COMMANDS OF THE FORM 1081C 1082C <COMMAND> Y X 1083C 1084C WHERE X IS A GROUP-ID VARIABLE. THIS ALLOWS US TO 1085C USE THESE COMMANDS FOR THE CASE WHERE WE ACTUALLY 1086C HAVE MULTIPLE GROUPS. FOR EXAMPLE, WE CAN CREATE 1087C A BOX PLOT OVER SEVERAL GROUPS. 1088C 1089C THE CODING IS BASED ON THE FOLLOWING FORMULA: 1090C 1091C ICODE = OFFSET + (ISET1-1)*NGROUP2 + ISET2 1092C 1093C WHERE 1094C 1095C OFFSET = AN INITIAL OFFSET (DEFAULTS TO 0) 1096C ISET1 = I-TH DISTINCT VALUE OF GROUP 1 1097C ISET2 = I-TH DISTINCT VALUE OF GROUP 2 1098C NGROUP2 = NUMBER OF DISTINCT VALUES FOR GROUP 2 1099C 1100C FOR PLOTS, WE MAY WANT TO SPACE GROUPS FURTHER APART. 1101C THE ICCTG1 PARAMETER CAN BE USED TO CONTROL THIS 1102C (I.E., WE USE THE MAXIMUM OF NGROUP2 AND ICCTG1). 1103C INPUT ARGUMENTS--X1 = THE SINGLE PRECISION VECTOR CONTAINING 1104C THE VALUES OF THE FIRST GROUP VARIABLE 1105C --X2 = THE SINGLE PRECISION VECTOR CONTAINING 1106C THE VALUES OF THE SECOND GROUP VARIABLE 1107C --N = THE INTEGER NUMBER OF OBSERVATIONS 1108C IN THE VECTORS X1 AND X2. 1109C --ICCTOF = THE INTEGER PARAMETER THAT SPECIFIES 1110C THE OFFSET. 1111C --ICCTG1 = THE INTEGER PARAMETER THAT SPECIFIES 1112C THE SPACING BETWEEN GROUPS. 1113C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR INTO WHICH 1114C THE CODED VALUES WILL BE PLACED. 1115C OUTPUT--THE SINGLE PRECISION VECTOR Y WHICH WILL CONTAIN THE CODED 1116C VALUES CORRESPONDING TO THE OBSERVATIONS IN THE VECTORS 1117C X1 AND X2. 1118C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 1119C OTHER DATAPAC SUBROUTINES NEEDED--SORT, DISTIN. 1120C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 1121C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 1122C LANGUAGE--ANSI FORTRAN (1977) 1123C WRITTEN BY--JAMES J. FILLIBEN 1124C STATISTICAL ENGINEERING DIVISION 1125C INFORMATION TECHNOLOGY LABORATORY 1126C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 1127C GAITHERSBURG, MD 20899-8980 1128C PHONE--301-975-2899 1129C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 1130C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 1131C LANGUAGE--ANSI FORTRAN (1977) 1132C VERSION NUMBER--2009/6 1133C ORIGINAL VERSION--JUNE 2009. 1134C 1135C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 1136C 1137 CHARACTER*4 IWRITE 1138 CHARACTER*4 IBUGA3 1139 CHARACTER*4 ISUBRO 1140 CHARACTER*4 IERROR 1141C 1142 CHARACTER*4 ISUBN1 1143 CHARACTER*4 ISUBN2 1144C 1145C--------------------------------------------------------------------- 1146C 1147CCCCC INCLUDE 'DPCOPA.INC' 1148C 1149 DIMENSION X1(*) 1150 DIMENSION X2(*) 1151 DIMENSION Y(*) 1152 DIMENSION XIDTEM(*) 1153 DIMENSION XIDTE2(*) 1154C 1155C--------------------------------------------------------------------- 1156C 1157 INCLUDE 'DPCOP2.INC' 1158C 1159C-----START POINT----------------------------------------------------- 1160C 1161 ISUBN1='CODC' 1162 ISUBN2='T2 ' 1163C 1164 IERROR='NO' 1165C 1166 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT2')THEN 1167 WRITE(ICOUT,999) 1168 999 FORMAT(1X) 1169 CALL DPWRST('XXX','BUG ') 1170 WRITE(ICOUT,51) 1171 51 FORMAT('***** AT THE BEGINNING OF CODCT2--') 1172 CALL DPWRST('XXX','BUG ') 1173 WRITE(ICOUT,52)IBUGA3,ISUBRO,N,ICCTOF,ICCTG1 1174 52 FORMAT('IBUGA3,ISUBRO,N,ICCTOF,ICCTG1 = ',A4,2X,A4,2X,3I8) 1175 CALL DPWRST('XXX','BUG ') 1176 DO55I=1,N 1177 WRITE(ICOUT,56)I,X1(I),X2(I) 1178 56 FORMAT('I,X1(I),X2(I) = ',I8,2G15.7) 1179 CALL DPWRST('XXX','BUG ') 1180 55 CONTINUE 1181 ENDIF 1182C 1183C *********************************************************** 1184C ** STEP 2-- ** 1185C ** PERFORM THE CODING-- ** 1186C *********************************************************** 1187C 1188 CALL DISTIN(X1,N,IWRITE,XIDTEM,NGRP1,IBUGA3,IERROR) 1189 CALL SORT(XIDTEM,NGRP1,XIDTEM) 1190 CALL DISTIN(X2,N,IWRITE,XIDTE2,NGRP2,IBUGA3,IERROR) 1191 CALL SORT(XIDTE2,NGRP2,XIDTE2) 1192C 1193 IFACT1=MAX(NGRP2,ICCTG1) 1194C 1195 DO100I=1,N 1196C 1197 DO200J=1,NGRP1 1198 DO300K=1,NGRP2 1199C 1200 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT2')THEN 1201 WRITE(ICOUT,301)I,J,K 1202 301 FORMAT('I,J,K = ',3I8) 1203 CALL DPWRST('XXX','BUG ') 1204 WRITE(ICOUT,302)X1(I),X2(I),XIDTEM(J),XIDTE2(K) 1205 302 FORMAT('X1(I),X2(I),XIDTEM(J),XIDTE2(K)=',4G15.7) 1206 CALL DPWRST('XXX','BUG ') 1207 ENDIF 1208C 1209 IF(X1(I).EQ.XIDTEM(J) .AND. X2(I).EQ.XIDTE2(K))THEN 1210 IINDX=ICCTOF + (J-1)*IFACT1 + K 1211 Y(I)=REAL(IINDX) 1212 GOTO100 1213 ENDIF 1214 300 CONTINUE 1215 200 CONTINUE 1216C 1217 WRITE(ICOUT,999) 1218 CALL DPWRST('XXX','BUG ') 1219 WRITE(ICOUT,305) 1220 305 FORMAT('***** INTERNAL ERROR IN CODCT2 SUBROUTINE--') 1221 CALL DPWRST('XXX','BUG ') 1222 WRITE(ICOUT,310)I 1223 310 FORMAT(' NO CODE FOUND FOR ELEMENT NUMBER ',I8) 1224 CALL DPWRST('XXX','BUG ') 1225 WRITE(ICOUT,312)X1(I) 1226 312 FORMAT(' GROUP-ID VARIABLE 1 = ',G15.7) 1227 CALL DPWRST('XXX','BUG ') 1228 WRITE(ICOUT,313)X2(I) 1229 313 FORMAT(' GROUP-ID VARIABLE 2 = ',G15.7) 1230 CALL DPWRST('XXX','BUG ') 1231 IERROR='YES' 1232 GOTO9000 1233C 1234 100 CONTINUE 1235C 1236C ****************************** 1237C ** STEP 3-- ** 1238C ** WRITE OUT A FEW LINES ** 1239C ** OF SUMMARY INFORMATION ** 1240C ** ABOUT THE CODING. ** 1241C ****************************** 1242C 1243 IF(IFEEDB.EQ.'OFF')GOTO890 1244 IF(IWRITE.EQ.'OFF')GOTO890 1245 WRITE(ICOUT,999) 1246 CALL DPWRST('XXX','BUG ') 1247 WRITE(ICOUT,811)NGRP1*NGRP2 1248 811 FORMAT('NUMBER OF DISTINCT CODE VALUES = ',I8) 1249 CALL DPWRST('XXX','BUG ') 1250 WRITE(ICOUT,999) 1251 CALL DPWRST('XXX','BUG ') 1252 890 CONTINUE 1253C 1254C ***************** 1255C ** STEP 90-- ** 1256C ** EXIT. ** 1257C ***************** 1258C 1259 9000 CONTINUE 1260C 1261 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT2')THEN 1262 WRITE(ICOUT,999) 1263 CALL DPWRST('XXX','BUG ') 1264 WRITE(ICOUT,9011) 1265 9011 FORMAT('***** AT THE END OF CODCT2--') 1266 CALL DPWRST('XXX','BUG ') 1267 WRITE(ICOUT,9013)NGRP1,NGRP2 1268 9013 FORMAT('NGRP1,NGRP2 = ',2I8) 1269 CALL DPWRST('XXX','BUG ') 1270 DO9015I=1,N 1271 WRITE(ICOUT,9016)I,X1(I),X2(I),Y(I) 1272 9016 FORMAT('I,X1(I),X2(I),Y(I) = ',I8,3G15.7) 1273 CALL DPWRST('XXX','BUG ') 1274 9015 CONTINUE 1275 ENDIF 1276C 1277 RETURN 1278 END 1279 SUBROUTINE CODCT3(X1,X2,X3,N,ICCTOF,ICCTG1,ICCTG2,IWRITE, 1280 1 Y,XIDTEM,XIDTE2,XIDTE3, 1281 1 IBUGA3,ISUBRO,IERROR) 1282C 1283C PURPOSE--THIS SUBROUTINE CREATES A CODED VARIABLE FROM THE 1284C CROSS TABULATION OF THREE GROUP-ID VARIABLES. THIS 1285C CAN BE USEFUL FOR COMMANDS OF THE FORM 1286C 1287C <COMMAND> Y X 1288C 1289C WHERE X IS A GROUP-ID VARIABLE. THIS ALLOWS US TO 1290C USE THESE COMMANDS FOR THE CASE WHERE WE ACTUALLY 1291C HAVE MULTIPLE GROUPS. FOR EXAMPLE, WE CAN CREATE 1292C A BOX PLOT OVER SEVERAL GROUPS. 1293C 1294C THE CODING IS BASED ON THE FOLLOWING FORMULA: 1295C 1296C ICODE = OFFSET + (ISET1-1)*NGROUP2*NGROUP3 + 1297C (ISET2-1)*NGROUP3 + ISET3 1298C 1299C WHERE 1300C 1301C OFFSET = AN INITIAL OFFSET (DEFAULTS TO 0) 1302C ISET1 = I-TH DISTINCT VALUE OF GROUP 1 1303C ISET2 = I-TH DISTINCT VALUE OF GROUP 2 1304C ISET3 = I-TH DISTINCT VALUE OF GROUP 3 1305C NGROUP2 = NUMBER OF DISTINCT VALUES FOR GROUP 2 1306C NGROUP3 = NUMBER OF DISTINCT VALUES FOR GROUP 3 1307C 1308C FOR PLOTS, WE MAY WANT TO SPACE GROUPS FURTHER APART. 1309C THE ICCTG1 AND ICCTG2 PARAMETERS CAN BE USED TO CONTROL 1310C THIS (I.E., WE USE: 1311C 1312C THE MAXIMUM OF NGROUP2 AND ICCTG1 1313C THE MAXIMUM OF NGROUP3 AND ICCTG2 1314C 1315C INPUT ARGUMENTS--X1 = THE SINGLE PRECISION VECTOR CONTAINING 1316C THE VALUES OF THE FIRST GROUP VARIABLE 1317C --X2 = THE SINGLE PRECISION VECTOR CONTAINING 1318C THE VALUES OF THE SECOND GROUP VARIABLE 1319C --X3 = THE SINGLE PRECISION VECTOR CONTAINING 1320C THE VALUES OF THE THIRD GROUP VARIABLE 1321C --N = THE INTEGER NUMBER OF OBSERVATIONS 1322C IN THE VECTORS X1, X2 AND X3. 1323C --ICCTOF = THE INTEGER PARAMETER THAT SPECIFIES 1324C THE OFFSET. 1325C --ICCTG1 = THE INTEGER PARAMETER THAT SPECIFIES 1326C THE SPACING FOR GROUP 2. 1327C --ICCTG2 = THE INTEGER PARAMETER THAT SPECIFIES 1328C THE SPACING FOR GROUP 3. 1329C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR INTO WHICH 1330C THE CODED VALUES WILL BE PLACED. 1331C OUTPUT--THE SINGLE PRECISION VECTOR Y WHICH WILL CONTAIN THE CODED 1332C VALUES CORRESPONDING TO THE OBSERVATIONS IN THE VECTORS 1333C X1, X2 AND X3. 1334C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 1335C OTHER DATAPAC SUBROUTINES NEEDED--SORT, DISTIN. 1336C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 1337C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 1338C LANGUAGE--ANSI FORTRAN (1977) 1339C WRITTEN BY--JAMES J. FILLIBEN 1340C STATISTICAL ENGINEERING DIVISION 1341C INFORMATION TECHNOLOGY LABORATORY 1342C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 1343C GAITHERSBURG, MD 20899-8980 1344C PHONE--301-975-2899 1345C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 1346C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 1347C LANGUAGE--ANSI FORTRAN (1977) 1348C VERSION NUMBER--2009/6 1349C ORIGINAL VERSION--JUNE 2009. 1350C 1351C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 1352C 1353 CHARACTER*4 IWRITE 1354 CHARACTER*4 IBUGA3 1355 CHARACTER*4 ISUBRO 1356 CHARACTER*4 IERROR 1357C 1358 CHARACTER*4 ISUBN1 1359 CHARACTER*4 ISUBN2 1360C 1361C--------------------------------------------------------------------- 1362C 1363CCCCC INCLUDE 'DPCOPA.INC' 1364C 1365 DIMENSION X1(*) 1366 DIMENSION X2(*) 1367 DIMENSION X3(*) 1368 DIMENSION Y(*) 1369 DIMENSION XIDTEM(*) 1370 DIMENSION XIDTE2(*) 1371 DIMENSION XIDTE3(*) 1372C 1373C--------------------------------------------------------------------- 1374C 1375 INCLUDE 'DPCOP2.INC' 1376C 1377C-----START POINT----------------------------------------------------- 1378C 1379 ISUBN1='CODC' 1380 ISUBN2='T3 ' 1381C 1382 IERROR='NO' 1383C 1384 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT3')THEN 1385 WRITE(ICOUT,999) 1386 999 FORMAT(1X) 1387 CALL DPWRST('XXX','BUG ') 1388 WRITE(ICOUT,51) 1389 51 FORMAT('***** AT THE BEGINNING OF CODCT3--') 1390 CALL DPWRST('XXX','BUG ') 1391 WRITE(ICOUT,52)IBUGA3,ISUBRO,N 1392 52 FORMAT('IBUGA3,ISUBRO,N = ',A4,2X,A4,2X,I8) 1393 CALL DPWRST('XXX','BUG ') 1394 DO55I=1,N 1395 WRITE(ICOUT,56)I,X1(I),X2(I),X3(I) 1396 56 FORMAT('I,X1(I),X2(I),X3(I) = ',I8,3G15.7) 1397 CALL DPWRST('XXX','BUG ') 1398 55 CONTINUE 1399 ENDIF 1400C 1401C *********************************************************** 1402C ** STEP 2-- ** 1403C ** PERFORM THE CODING-- ** 1404C *********************************************************** 1405C 1406 CALL DISTIN(X1,N,IWRITE,XIDTEM,NGRP1,IBUGA3,IERROR) 1407 CALL SORT(XIDTEM,NGRP1,XIDTEM) 1408 CALL DISTIN(X2,N,IWRITE,XIDTE2,NGRP2,IBUGA3,IERROR) 1409 CALL SORT(XIDTE2,NGRP2,XIDTE2) 1410 CALL DISTIN(X3,N,IWRITE,XIDTE3,NGRP3,IBUGA3,IERROR) 1411 CALL SORT(XIDTE3,NGRP3,XIDTE3) 1412C 1413 IFACT1=MAX(NGRP2,ICCTG1) 1414 IFACT2=MAX(NGRP3,ICCTG2) 1415C 1416 DO100I=1,N 1417C 1418 DO200J=1,NGRP1 1419 DO300K=1,NGRP2 1420 DO400L=1,NGRP3 1421C 1422 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT3')THEN 1423 WRITE(ICOUT,301)I,J,K,L 1424 301 FORMAT('I,J,K,L = ',4I8) 1425 CALL DPWRST('XXX','BUG ') 1426 WRITE(ICOUT,302)X1(I),X2(I),X3(I) 1427 302 FORMAT('X1(I),X2(I),X3(I)=',3G15.7) 1428 CALL DPWRST('XXX','BUG ') 1429 WRITE(ICOUT,303)XIDTEM(J),XIDTE2(K),XIDTE3(L) 1430 303 FORMAT('XIDTEM(J),XIDTE2(K),XIDTE3(L)=',3G15.7) 1431 CALL DPWRST('XXX','BUG ') 1432 ENDIF 1433C 1434 IF(X1(I).EQ.XIDTEM(J) .AND. X2(I).EQ.XIDTE2(K) .AND. 1435 1 X3(I).EQ.XIDTE3(L))THEN 1436 IINDX=ICCTOF + (J-1)*IFACT1*IFACT2 + (K-1)*IFACT2 + L 1437 Y(I)=REAL(IINDX) 1438 GOTO100 1439 ENDIF 1440 400 CONTINUE 1441 300 CONTINUE 1442 200 CONTINUE 1443C 1444 WRITE(ICOUT,999) 1445 CALL DPWRST('XXX','BUG ') 1446 WRITE(ICOUT,305) 1447 305 FORMAT('***** INTERNAL ERROR IN CODCT3 SUBROUTINE--') 1448 CALL DPWRST('XXX','BUG ') 1449 WRITE(ICOUT,310)I 1450 310 FORMAT(' NO CODE FOUND FOR ELEMENT NUMBER ',I8) 1451 CALL DPWRST('XXX','BUG ') 1452 WRITE(ICOUT,312)X1(I) 1453 312 FORMAT(' GROUP-ID VARIABLE 1 = ',G15.7) 1454 CALL DPWRST('XXX','BUG ') 1455 WRITE(ICOUT,313)X2(I) 1456 313 FORMAT(' GROUP-ID VARIABLE 2 = ',G15.7) 1457 CALL DPWRST('XXX','BUG ') 1458 WRITE(ICOUT,314)X3(I) 1459 314 FORMAT(' GROUP-ID VARIABLE 3 = ',G15.7) 1460 CALL DPWRST('XXX','BUG ') 1461 IERROR='YES' 1462 GOTO9000 1463C 1464 100 CONTINUE 1465C 1466C ****************************** 1467C ** STEP 3-- ** 1468C ** WRITE OUT A FEW LINES ** 1469C ** OF SUMMARY INFORMATION ** 1470C ** ABOUT THE CODING. ** 1471C ****************************** 1472C 1473 IF(IFEEDB.EQ.'OFF')GOTO890 1474 IF(IWRITE.EQ.'OFF')GOTO890 1475 WRITE(ICOUT,999) 1476 CALL DPWRST('XXX','BUG ') 1477 WRITE(ICOUT,811)NGRP1*NGRP2*NGRP3 1478 811 FORMAT('NUMBER OF DISTINCT CODE VALUES = ',I8) 1479 CALL DPWRST('XXX','BUG ') 1480 WRITE(ICOUT,999) 1481 CALL DPWRST('XXX','BUG ') 1482 890 CONTINUE 1483C 1484C ***************** 1485C ** STEP 90-- ** 1486C ** EXIT. ** 1487C ***************** 1488C 1489 9000 CONTINUE 1490C 1491 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT3')THEN 1492 WRITE(ICOUT,999) 1493 CALL DPWRST('XXX','BUG ') 1494 WRITE(ICOUT,9011) 1495 9011 FORMAT('***** AT THE END OF CODCT3--') 1496 CALL DPWRST('XXX','BUG ') 1497 WRITE(ICOUT,9013)NGRP1,NGRP2,NGRP3 1498 9013 FORMAT('NGRP1,NGRP2,NGRP3 = ',3I8) 1499 CALL DPWRST('XXX','BUG ') 1500 DO9015I=1,N 1501 WRITE(ICOUT,9016)I,X1(I),X2(I),X3(I),Y(I) 1502 9016 FORMAT('I,X1(I),X2(I),X3(I),Y(I) = ',I8,4G15.7) 1503 CALL DPWRST('XXX','BUG ') 1504 9015 CONTINUE 1505 ENDIF 1506C 1507 RETURN 1508 END 1509 SUBROUTINE CODCT4(X1,X2,X3,X4,N, 1510 1 ICCTOF,ICCTG1,ICCTG2,ICCTG3,IWRITE, 1511 1 Y,XIDTEM,XIDTE2,XIDTE3,XIDTE4, 1512 1 IBUGA3,ISUBRO,IERROR) 1513C 1514C PURPOSE--THIS SUBROUTINE CREATES A CODED VARIABLE FROM THE 1515C CROSS TABULATION OF FOUR GROUP-ID VARIABLES. THIS 1516C CAN BE USEFUL FOR COMMANDS OF THE FORM 1517C 1518C <COMMAND> Y X 1519C 1520C WHERE X IS A GROUP-ID VARIABLE. THIS ALLOWS US TO 1521C USE THESE COMMANDS FOR THE CASE WHERE WE ACTUALLY 1522C HAVE MULTIPLE GROUPS. FOR EXAMPLE, WE CAN CREATE 1523C A BOX PLOT OVER SEVERAL GROUPS. 1524C 1525C THE CODING IS BASED ON THE FOLLOWING FORMULA: 1526C 1527C ICODE = OFFSET + (ISET1-1)*NGROUP2*NGROUP3*NGROUP4 + 1528C (ISET2-1)*NGROUP3*NGROUP4 + 1529C (ISET3-1)*NGROUP4 + ISET4 1530C 1531C WHERE 1532C 1533C OFFSET = AN INITIAL OFFSET (DEFAULTS TO 0) 1534C ISET1 = I-TH DISTINCT VALUE OF GROUP 1 1535C ISET2 = I-TH DISTINCT VALUE OF GROUP 2 1536C ISET3 = I-TH DISTINCT VALUE OF GROUP 3 1537C ISET4 = I-TH DISTINCT VALUE OF GROUP 4 1538C NGROUP2 = NUMBER OF DISTINCT VALUES FOR GROUP 2 1539C NGROUP3 = NUMBER OF DISTINCT VALUES FOR GROUP 3 1540C NGROUP4 = NUMBER OF DISTINCT VALUES FOR GROUP 4 1541C 1542C FOR PLOTS, WE MAY WANT TO SPACE GROUPS FURTHER APART. 1543C THE ICCTG1, ICCTG2, AND ICCTG3 PARAMETERS CAN BE USED 1544C TO CONTROL THIS (I.E., WE USE: 1545C 1546C THE MAXIMUM OF NGROUP2 AND ICCTG1 1547C THE MAXIMUM OF NGROUP3 AND ICCTG2 1548C THE MAXIMUM OF NGROUP4 AND ICCTG3 1549C 1550C INPUT ARGUMENTS--X1 = THE SINGLE PRECISION VECTOR CONTAINING 1551C THE VALUES OF THE FIRST GROUP VARIABLE 1552C --X2 = THE SINGLE PRECISION VECTOR CONTAINING 1553C THE VALUES OF THE SECOND GROUP VARIABLE 1554C --X3 = THE SINGLE PRECISION VECTOR CONTAINING 1555C THE VALUES OF THE THIRD GROUP VARIABLE 1556C --X4 = THE SINGLE PRECISION VECTOR CONTAINING 1557C THE VALUES OF THE FOURTH GROUP VARIABLE 1558C --N = THE INTEGER NUMBER OF OBSERVATIONS 1559C IN THE VECTORS X1, X2, X3 AND X4. 1560C --ICCTOF = THE INTEGER PARAMETER THAT SPECIFIES 1561C THE OFFSET. 1562C --ICCTG1 = THE INTEGER PARAMETER THAT SPECIFIES 1563C THE SPACING FOR GROUP 2. 1564C --ICCTG2 = THE INTEGER PARAMETER THAT SPECIFIES 1565C THE SPACING FOR GROUP 3. 1566C --ICCTG3 = THE INTEGER PARAMETER THAT SPECIFIES 1567C THE SPACING FOR GROUP 4. 1568C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR INTO WHICH 1569C THE CODED VALUES WILL BE PLACED. 1570C OUTPUT--THE SINGLE PRECISION VECTOR Y WHICH WILL CONTAIN THE CODED 1571C VALUES CORRESPONDING TO THE OBSERVATIONS IN THE VECTORS 1572C X1, X2, X3 AND X4. 1573C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 1574C OTHER DATAPAC SUBROUTINES NEEDED--SORT, DISTIN. 1575C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 1576C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 1577C LANGUAGE--ANSI FORTRAN (1977) 1578C WRITTEN BY--JAMES J. FILLIBEN 1579C STATISTICAL ENGINEERING DIVISION 1580C INFORMATION TECHNOLOGY LABORATORY 1581C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 1582C GAITHERSBURG, MD 20899-8980 1583C PHONE--301-975-2899 1584C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 1585C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 1586C LANGUAGE--ANSI FORTRAN (1977) 1587C VERSION NUMBER--2009/6 1588C ORIGINAL VERSION--JUNE 2009. 1589C 1590C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 1591C 1592 CHARACTER*4 IWRITE 1593 CHARACTER*4 IBUGA3 1594 CHARACTER*4 ISUBRO 1595 CHARACTER*4 IERROR 1596C 1597 CHARACTER*4 ISUBN1 1598 CHARACTER*4 ISUBN2 1599C 1600C--------------------------------------------------------------------- 1601C 1602CCCCC INCLUDE 'DPCOPA.INC' 1603C 1604 DIMENSION X1(*) 1605 DIMENSION X2(*) 1606 DIMENSION X3(*) 1607 DIMENSION X4(*) 1608 DIMENSION Y(*) 1609 DIMENSION XIDTEM(*) 1610 DIMENSION XIDTE2(*) 1611 DIMENSION XIDTE3(*) 1612 DIMENSION XIDTE4(*) 1613C 1614C--------------------------------------------------------------------- 1615C 1616 INCLUDE 'DPCOP2.INC' 1617C 1618C-----START POINT----------------------------------------------------- 1619C 1620 ISUBN1='CODC' 1621 ISUBN2='T4 ' 1622C 1623 IERROR='NO' 1624C 1625 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT4')THEN 1626 WRITE(ICOUT,999) 1627 999 FORMAT(1X) 1628 CALL DPWRST('XXX','BUG ') 1629 WRITE(ICOUT,51) 1630 51 FORMAT('***** AT THE BEGINNING OF CODCT4--') 1631 CALL DPWRST('XXX','BUG ') 1632 WRITE(ICOUT,52)IBUGA3,ISUBRO,N 1633 52 FORMAT('IBUGA3,ISUBRO,N = ',A4,2X,A4,2X,I8) 1634 CALL DPWRST('XXX','BUG ') 1635 DO55I=1,N 1636 WRITE(ICOUT,56)I,X1(I),X2(I),X3(I),X4(I) 1637 56 FORMAT('I,X1(I),X2(I),X3(I),X4(I) = ',I8,4G15.7) 1638 CALL DPWRST('XXX','BUG ') 1639 55 CONTINUE 1640 ENDIF 1641C 1642C *********************************************************** 1643C ** STEP 2-- ** 1644C ** PERFORM THE CODING-- ** 1645C *********************************************************** 1646C 1647 CALL DISTIN(X1,N,IWRITE,XIDTEM,NGRP1,IBUGA3,IERROR) 1648 CALL SORT(XIDTEM,NGRP1,XIDTEM) 1649 CALL DISTIN(X2,N,IWRITE,XIDTE2,NGRP2,IBUGA3,IERROR) 1650 CALL SORT(XIDTE2,NGRP2,XIDTE2) 1651 CALL DISTIN(X3,N,IWRITE,XIDTE3,NGRP3,IBUGA3,IERROR) 1652 CALL SORT(XIDTE3,NGRP3,XIDTE3) 1653 CALL DISTIN(X4,N,IWRITE,XIDTE4,NGRP4,IBUGA3,IERROR) 1654 CALL SORT(XIDTE4,NGRP4,XIDTE4) 1655C 1656 IFACT1=MAX(NGRP2,ICCTG1) 1657 IFACT2=MAX(NGRP3,ICCTG2) 1658 IFACT3=MAX(NGRP4,ICCTG3) 1659C 1660 DO100I=1,N 1661C 1662 DO200J=1,NGRP1 1663 DO300K=1,NGRP2 1664 DO400L=1,NGRP3 1665 DO500M=1,NGRP4 1666C 1667 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT4')THEN 1668 WRITE(ICOUT,301)I,J,K,L,M 1669 301 FORMAT('I,J,K,L,M = ',5I8) 1670 CALL DPWRST('XXX','BUG ') 1671 WRITE(ICOUT,302)X1(I),X2(I),X3(I),X4(I) 1672 302 FORMAT('X1(I),X2(I),X3(I),X4(I)=',4G15.7) 1673 CALL DPWRST('XXX','BUG ') 1674 WRITE(ICOUT,303)XIDTEM(J),XIDTE2(K),XIDTE3(L),XIDTE4(M) 1675 303 FORMAT('XIDTEM(J),XIDTE2(K),XIDTE3(L),XIDTE4(M)=',4G15.7) 1676 CALL DPWRST('XXX','BUG ') 1677 ENDIF 1678C 1679 IF(X1(I).EQ.XIDTEM(J) .AND. X2(I).EQ.XIDTE2(K) .AND. 1680 1 X3(I).EQ.XIDTE3(L) .AND. X4(I).EQ.XIDTE4(M))THEN 1681 IINDX=ICCTOF + (J-1)*IFACT1*IFACT2*IFACT3 + 1682 1 (K-1)*IFACT2*IFACT3 + 1683 1 (L-1)*IFACT3 + M 1684 Y(I)=REAL(IINDX) 1685 GOTO100 1686 ENDIF 1687 500 CONTINUE 1688 400 CONTINUE 1689 300 CONTINUE 1690 200 CONTINUE 1691C 1692 WRITE(ICOUT,999) 1693 CALL DPWRST('XXX','BUG ') 1694 WRITE(ICOUT,305) 1695 305 FORMAT('***** INTERNAL ERROR IN CODCT4 SUBROUTINE--') 1696 CALL DPWRST('XXX','BUG ') 1697 WRITE(ICOUT,310)I 1698 310 FORMAT(' NO CODE FOUND FOR ELEMENT NUMBER ',I8) 1699 CALL DPWRST('XXX','BUG ') 1700 WRITE(ICOUT,312)X1(I) 1701 312 FORMAT(' GROUP-ID VARIABLE 1 = ',G15.7) 1702 CALL DPWRST('XXX','BUG ') 1703 WRITE(ICOUT,313)X2(I) 1704 313 FORMAT(' GROUP-ID VARIABLE 2 = ',G15.7) 1705 CALL DPWRST('XXX','BUG ') 1706 WRITE(ICOUT,314)X3(I) 1707 314 FORMAT(' GROUP-ID VARIABLE 3 = ',G15.7) 1708 CALL DPWRST('XXX','BUG ') 1709 WRITE(ICOUT,315)X4(I) 1710 315 FORMAT(' GROUP-ID VARIABLE 4 = ',G15.7) 1711 CALL DPWRST('XXX','BUG ') 1712 IERROR='YES' 1713 GOTO9000 1714C 1715 100 CONTINUE 1716C 1717C ****************************** 1718C ** STEP 3-- ** 1719C ** WRITE OUT A FEW LINES ** 1720C ** OF SUMMARY INFORMATION ** 1721C ** ABOUT THE CODING. ** 1722C ****************************** 1723C 1724 IF(IFEEDB.EQ.'OFF')GOTO890 1725 IF(IWRITE.EQ.'OFF')GOTO890 1726 WRITE(ICOUT,999) 1727 CALL DPWRST('XXX','BUG ') 1728 WRITE(ICOUT,811)NGRP1*NGRP2*NGRP3*NGRP4 1729 811 FORMAT('NUMBER OF DISTINCT CODE VALUES = ',I8) 1730 CALL DPWRST('XXX','BUG ') 1731 WRITE(ICOUT,999) 1732 CALL DPWRST('XXX','BUG ') 1733 890 CONTINUE 1734C 1735C ***************** 1736C ** STEP 90-- ** 1737C ** EXIT. ** 1738C ***************** 1739C 1740 9000 CONTINUE 1741C 1742 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT4')THEN 1743 WRITE(ICOUT,999) 1744 CALL DPWRST('XXX','BUG ') 1745 WRITE(ICOUT,9011) 1746 9011 FORMAT('***** AT THE END OF CODCT4--') 1747 CALL DPWRST('XXX','BUG ') 1748 WRITE(ICOUT,9013)NGRP1,NGRP2,NGRP3,NGRP4 1749 9013 FORMAT('NGRP1,NGRP2,NGRP3,NGRP4 = ',4I8) 1750 CALL DPWRST('XXX','BUG ') 1751 DO9015I=1,N 1752 WRITE(ICOUT,9016)I,X1(I),X2(I),X3(I),X4(I),Y(I) 1753 9016 FORMAT('I,X1(I),X2(I),X3(I),X4(I),Y(I) = ',I8,5G15.7) 1754 CALL DPWRST('XXX','BUG ') 1755 9015 CONTINUE 1756 ENDIF 1757C 1758 RETURN 1759 END 1760 SUBROUTINE CODCT5(X1,X2,X3,X4,X5,N, 1761 1 ICCTOF,ICCTG1,ICCTG2,ICCTG3,ICCTG4,IWRITE, 1762 1 Y,XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5, 1763 1 IBUGA3,ISUBRO,IERROR) 1764C 1765C PURPOSE--THIS SUBROUTINE CREATES A CODED VARIABLE FROM THE 1766C CROSS TABULATION OF FIVE GROUP-ID VARIABLES. THIS 1767C CAN BE USEFUL FOR COMMANDS OF THE FORM 1768C 1769C <COMMAND> Y X 1770C 1771C WHERE X IS A GROUP-ID VARIABLE. THIS ALLOWS US TO 1772C USE THESE COMMANDS FOR THE CASE WHERE WE ACTUALLY 1773C HAVE MULTIPLE GROUPS. FOR EXAMPLE, WE CAN CREATE 1774C A BOX PLOT OVER SEVERAL GROUPS. 1775C 1776C THE CODING IS BASED ON THE FOLLOWING FORMULA: 1777C 1778C ICODE = OFFSET + 1779C (ISET1-1)*NGROUP2*NGROUP3*NGROUP4*NGROUP5 + 1780C (ISET2-1)*NGROUP3*NGROUP4*NGROUP5 + 1781C (ISET3-1)*NGROUP4*NGROUP5 1782C (ISET4-1)*NGROUP5 + ISET5 1783C 1784C WHERE 1785C 1786C OFFSET = AN INITIAL OFFSET (DEFAULTS TO 0) 1787C ISET1 = I-TH DISTINCT VALUE OF GROUP 1 1788C ISET2 = I-TH DISTINCT VALUE OF GROUP 2 1789C ISET3 = I-TH DISTINCT VALUE OF GROUP 3 1790C ISET4 = I-TH DISTINCT VALUE OF GROUP 4 1791C ISET5 = I-TH DISTINCT VALUE OF GROUP 5 1792C NGROUP2 = NUMBER OF DISTINCT VALUES FOR GROUP 2 1793C NGROUP3 = NUMBER OF DISTINCT VALUES FOR GROUP 3 1794C NGROUP4 = NUMBER OF DISTINCT VALUES FOR GROUP 4 1795C NGROUP5 = NUMBER OF DISTINCT VALUES FOR GROUP 5 1796C 1797C FOR PLOTS, WE MAY WANT TO SPACE GROUPS FURTHER APART. 1798C THE ICCTG1, ICCTG2, ICCTG3,AND ICCTG4 PARAMETERS CAN BE 1799C USED TO CONTROL THIS (I.E., WE USE: 1800C 1801C THE MAXIMUM OF NGROUP2 AND ICCTG1 1802C THE MAXIMUM OF NGROUP3 AND ICCTG2 1803C THE MAXIMUM OF NGROUP4 AND ICCTG3 1804C THE MAXIMUM OF NGROUP5 AND ICCTG4 1805C 1806C INPUT ARGUMENTS--X1 = THE SINGLE PRECISION VECTOR CONTAINING 1807C THE VALUES OF THE FIRST GROUP VARIABLE 1808C --X2 = THE SINGLE PRECISION VECTOR CONTAINING 1809C THE VALUES OF THE SECOND GROUP VARIABLE 1810C --X3 = THE SINGLE PRECISION VECTOR CONTAINING 1811C THE VALUES OF THE THIRD GROUP VARIABLE 1812C --X4 = THE SINGLE PRECISION VECTOR CONTAINING 1813C THE VALUES OF THE FOURTH GROUP VARIABLE 1814C --X5 = THE SINGLE PRECISION VECTOR CONTAINING 1815C THE VALUES OF THE FIFTH GROUP VARIABLE 1816C --N = THE INTEGER NUMBER OF OBSERVATIONS 1817C IN THE VECTORS X1, X2, X3, X4 AND X5. 1818C --ICCTOF = THE INTEGER PARAMETER THAT SPECIFIES 1819C THE OFFSET. 1820C --ICCTG1 = THE INTEGER PARAMETER THAT SPECIFIES 1821C THE SPACING FOR GROUP 2. 1822C --ICCTG2 = THE INTEGER PARAMETER THAT SPECIFIES 1823C THE SPACING FOR GROUP 3. 1824C --ICCTG3 = THE INTEGER PARAMETER THAT SPECIFIES 1825C THE SPACING FOR GROUP 4. 1826C --ICCTG4 = THE INTEGER PARAMETER THAT SPECIFIES 1827C THE SPACING FOR GROUP 5. 1828C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR INTO WHICH 1829C THE CODED VALUES WILL BE PLACED. 1830C OUTPUT--THE SINGLE PRECISION VECTOR Y WHICH WILL CONTAIN THE CODED 1831C VALUES CORRESPONDING TO THE OBSERVATIONS IN THE VECTORS 1832C X1, X2, X3, X4 AND X5. 1833C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 1834C OTHER DATAPAC SUBROUTINES NEEDED--SORT, DISTIN. 1835C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 1836C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 1837C LANGUAGE--ANSI FORTRAN (1977) 1838C WRITTEN BY--JAMES J. FILLIBEN 1839C STATISTICAL ENGINEERING DIVISION 1840C INFORMATION TECHNOLOGY LABORATORY 1841C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 1842C GAITHERSBURG, MD 20899-8980 1843C PHONE--301-975-2899 1844C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 1845C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 1846C LANGUAGE--ANSI FORTRAN (1977) 1847C VERSION NUMBER--2009/6 1848C ORIGINAL VERSION--JUNE 2009. 1849C 1850C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 1851C 1852 CHARACTER*4 IWRITE 1853 CHARACTER*4 IBUGA3 1854 CHARACTER*4 ISUBRO 1855 CHARACTER*4 IERROR 1856C 1857 CHARACTER*4 ISUBN1 1858 CHARACTER*4 ISUBN2 1859C 1860C--------------------------------------------------------------------- 1861C 1862CCCCC INCLUDE 'DPCOPA.INC' 1863C 1864 DIMENSION X1(*) 1865 DIMENSION X2(*) 1866 DIMENSION X3(*) 1867 DIMENSION X4(*) 1868 DIMENSION X5(*) 1869 DIMENSION Y(*) 1870 DIMENSION XIDTEM(*) 1871 DIMENSION XIDTE2(*) 1872 DIMENSION XIDTE3(*) 1873 DIMENSION XIDTE4(*) 1874 DIMENSION XIDTE5(*) 1875C 1876C--------------------------------------------------------------------- 1877C 1878 INCLUDE 'DPCOP2.INC' 1879C 1880C-----START POINT----------------------------------------------------- 1881C 1882 ISUBN1='CODC' 1883 ISUBN2='T4 ' 1884C 1885 IERROR='NO' 1886C 1887 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT5')THEN 1888 WRITE(ICOUT,999) 1889 999 FORMAT(1X) 1890 CALL DPWRST('XXX','BUG ') 1891 WRITE(ICOUT,51) 1892 51 FORMAT('***** AT THE BEGINNING OF CODCT5--') 1893 CALL DPWRST('XXX','BUG ') 1894 WRITE(ICOUT,52)IBUGA3,ISUBRO,N 1895 52 FORMAT('IBUGA3,ISUBRO,N = ',A4,2X,A4,2X,I8) 1896 CALL DPWRST('XXX','BUG ') 1897 WRITE(ICOUT,53)ICCTOF,ICCTG1,ICCTG2,ICCTG3,ICCTG4 1898 53 FORMAT('ICCTOF,ICCTG1,ICCTG2,ICCTG3,ICCTG4 = ',5I5) 1899 CALL DPWRST('XXX','BUG ') 1900 DO55I=1,N 1901 WRITE(ICOUT,56)I,X1(I),X2(I),X3(I),X4(I),X5(I) 1902 56 FORMAT('I,X1(I),X2(I),X3(I),X4(I),X5(I) = ',I8,5G15.7) 1903 CALL DPWRST('XXX','BUG ') 1904 55 CONTINUE 1905 ENDIF 1906C 1907C *********************************************************** 1908C ** STEP 2-- ** 1909C ** PERFORM THE CODING-- ** 1910C *********************************************************** 1911C 1912 CALL DISTIN(X1,N,IWRITE,XIDTEM,NGRP1,IBUGA3,IERROR) 1913 CALL SORT(XIDTEM,NGRP1,XIDTEM) 1914 CALL DISTIN(X2,N,IWRITE,XIDTE2,NGRP2,IBUGA3,IERROR) 1915 CALL SORT(XIDTE2,NGRP2,XIDTE2) 1916 CALL DISTIN(X3,N,IWRITE,XIDTE3,NGRP3,IBUGA3,IERROR) 1917 CALL SORT(XIDTE3,NGRP3,XIDTE3) 1918 CALL DISTIN(X4,N,IWRITE,XIDTE4,NGRP4,IBUGA3,IERROR) 1919 CALL SORT(XIDTE4,NGRP4,XIDTE4) 1920 CALL DISTIN(X5,N,IWRITE,XIDTE5,NGRP5,IBUGA3,IERROR) 1921 CALL SORT(XIDTE5,NGRP5,XIDTE5) 1922C 1923 IFACT1=MAX(NGRP2,ICCTG1) 1924 IFACT2=MAX(NGRP3,ICCTG2) 1925 IFACT3=MAX(NGRP4,ICCTG3) 1926 IFACT4=MAX(NGRP5,ICCTG4) 1927C 1928 DO100I=1,N 1929C 1930 DO200J=1,NGRP1 1931 DO300K=1,NGRP2 1932 DO400L=1,NGRP3 1933 DO500M=1,NGRP4 1934 DO600JJ=1,NGRP5 1935C 1936 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT5')THEN 1937 WRITE(ICOUT,301)I,J,K,L,M 1938 301 FORMAT('I,J,K,L,M = ',5I8) 1939 CALL DPWRST('XXX','BUG ') 1940 WRITE(ICOUT,302)X1(I),X2(I),X3(I),X4(I),X5(I) 1941 302 FORMAT('X1(I),X2(I),X3(I),X4(I),X5(I)=',5G15.7) 1942 CALL DPWRST('XXX','BUG ') 1943 WRITE(ICOUT,303)XIDTEM(J),XIDTE2(K),XIDTE3(L), 1944 1 XIDTE4(M),XIDTE5(JJ) 1945 303 FORMAT('XIDTEM(J),XIDTE2(K),XIDTE3(L),XIDTE4(M),', 1946 1 'XIDTE5(JJ)=',5G15.7) 1947 CALL DPWRST('XXX','BUG ') 1948 ENDIF 1949C 1950 IF(X1(I).EQ.XIDTEM(J) .AND. X2(I).EQ.XIDTE2(K) .AND. 1951 1 X3(I).EQ.XIDTE3(L) .AND. X4(I).EQ.XIDTE4(M) .AND. 1952 1 X5(I).EQ.XIDTE5(JJ))THEN 1953 IINDX=ICCTOF + (J-1)*IFACT1*IFACT2*IFACT3*IFACT4 + 1954 1 (K-1)*IFACT2*IFACT3*IFACT4 + 1955 1 (L-1)*IFACT3*IFACT4 + 1956 1 (M-1)*IFACT4 + JJ 1957 Y(I)=REAL(IINDX) 1958 GOTO100 1959 ENDIF 1960 600 CONTINUE 1961 500 CONTINUE 1962 400 CONTINUE 1963 300 CONTINUE 1964 200 CONTINUE 1965C 1966 WRITE(ICOUT,999) 1967 CALL DPWRST('XXX','BUG ') 1968 WRITE(ICOUT,305) 1969 305 FORMAT('***** INTERNAL ERROR IN CODCT5 SUBROUTINE--') 1970 CALL DPWRST('XXX','BUG ') 1971 WRITE(ICOUT,310)I 1972 310 FORMAT(' NO CODE FOUND FOR ELEMENT NUMBER ',I8) 1973 CALL DPWRST('XXX','BUG ') 1974 WRITE(ICOUT,312)X1(I) 1975 312 FORMAT(' GROUP-ID VARIABLE 1 = ',G15.7) 1976 CALL DPWRST('XXX','BUG ') 1977 WRITE(ICOUT,313)X2(I) 1978 313 FORMAT(' GROUP-ID VARIABLE 2 = ',G15.7) 1979 CALL DPWRST('XXX','BUG ') 1980 WRITE(ICOUT,314)X3(I) 1981 314 FORMAT(' GROUP-ID VARIABLE 3 = ',G15.7) 1982 CALL DPWRST('XXX','BUG ') 1983 WRITE(ICOUT,315)X4(I) 1984 315 FORMAT(' GROUP-ID VARIABLE 4 = ',G15.7) 1985 CALL DPWRST('XXX','BUG ') 1986 WRITE(ICOUT,316)X5(I) 1987 316 FORMAT(' GROUP-ID VARIABLE 5 = ',G15.7) 1988 CALL DPWRST('XXX','BUG ') 1989 IERROR='YES' 1990 GOTO9000 1991C 1992 100 CONTINUE 1993C 1994C ****************************** 1995C ** STEP 3-- ** 1996C ** WRITE OUT A FEW LINES ** 1997C ** OF SUMMARY INFORMATION ** 1998C ** ABOUT THE CODING. ** 1999C ****************************** 2000C 2001 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 2002 WRITE(ICOUT,999) 2003 CALL DPWRST('XXX','BUG ') 2004 WRITE(ICOUT,811)NGRP1*NGRP2*NGRP3*NGRP4*NGRP5 2005 811 FORMAT('NUMBER OF DISTINCT CODE VALUES = ',I8) 2006 CALL DPWRST('XXX','BUG ') 2007 WRITE(ICOUT,999) 2008 CALL DPWRST('XXX','BUG ') 2009 ENDIF 2010C 2011C ***************** 2012C ** STEP 90-- ** 2013C ** EXIT. ** 2014C ***************** 2015C 2016 9000 CONTINUE 2017C 2018 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT5')THEN 2019 WRITE(ICOUT,999) 2020 CALL DPWRST('XXX','BUG ') 2021 WRITE(ICOUT,9011) 2022 9011 FORMAT('***** AT THE END OF CODCT5--') 2023 CALL DPWRST('XXX','BUG ') 2024 WRITE(ICOUT,9013)NGRP1,NGRP2,NGRP3,NGRP4,NGRP5 2025 9013 FORMAT('NGRP1,NGRP2,NGRP3,NGRP4,NGRP5 = ',5I8) 2026 CALL DPWRST('XXX','BUG ') 2027 DO9015I=1,N 2028 WRITE(ICOUT,9016)I,X1(I),X2(I),X3(I),X4(I),X5(I),Y(I) 2029 9016 FORMAT('I,X1(I),X2(I),X3(I),X4(I),X5(I),Y(I) = ',I8,5G15.7) 2030 CALL DPWRST('XXX','BUG ') 2031 9015 CONTINUE 2032 ENDIF 2033C 2034 RETURN 2035 END 2036 SUBROUTINE CODCT6(X1,X2,X3,X4,X5,X6,N, 2037 1 ICCTOF,ICCTG1,ICCTG2,ICCTG3,ICCTG4,ICCTG5, 2038 1 IWRITE, 2039 1 Y,XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6, 2040 1 IBUGA3,ISUBRO,IERROR) 2041C 2042C PURPOSE--THIS SUBROUTINE CREATES A CODED VARIABLE FROM THE 2043C CROSS TABULATION OF SIX GROUP-ID VARIABLES. THIS 2044C CAN BE USEFUL FOR COMMANDS OF THE FORM 2045C 2046C <COMMAND> Y X 2047C 2048C WHERE X IS A GROUP-ID VARIABLE. THIS ALLOWS US TO 2049C USE THESE COMMANDS FOR THE CASE WHERE WE ACTUALLY 2050C HAVE MULTIPLE GROUPS. FOR EXAMPLE, WE CAN CREATE 2051C A BOX PLOT OVER SEVERAL GROUPS. 2052C 2053C THE CODING IS BASED ON THE FOLLOWING FORMULA: 2054C 2055C ICODE = OFFSET + 2056C (ISET1-1)*NGROUP2*NGROUP3*NGROUP4*NGROUP5*NGROUP6 + 2057C (ISET2-1)*NGROUP3*NGROUP4*NGROUP5*NGROUP6 + 2058C (ISET3-1)*NGROUP4*NGROUP5*NGROUP6 + 2059C (ISET4-1)*NGROUP5*NGROUP6 + 2060C (ISET5-1)*NGROUP6 + ISET6 2061C 2062C WHERE 2063C 2064C OFFSET = AN INITIAL OFFSET (DEFAULTS TO 0) 2065C ISET1 = I-TH DISTINCT VALUE OF GROUP 1 2066C ISET2 = I-TH DISTINCT VALUE OF GROUP 2 2067C ISET3 = I-TH DISTINCT VALUE OF GROUP 3 2068C ISET4 = I-TH DISTINCT VALUE OF GROUP 4 2069C ISET5 = I-TH DISTINCT VALUE OF GROUP 5 2070C ISET6 = I-TH DISTINCT VALUE OF GROUP 6 2071C NGROUP2 = NUMBER OF DISTINCT VALUES FOR GROUP 2 2072C NGROUP3 = NUMBER OF DISTINCT VALUES FOR GROUP 3 2073C NGROUP4 = NUMBER OF DISTINCT VALUES FOR GROUP 4 2074C NGROUP5 = NUMBER OF DISTINCT VALUES FOR GROUP 5 2075C NGROUP6 = NUMBER OF DISTINCT VALUES FOR GROUP 6 2076C 2077C FOR PLOTS, WE MAY WANT TO SPACE GROUPS FURTHER APART. 2078C THE ICCTG1, ICCTG2, ICCTG3, ICCTG4, AND ICCTG5 PARAMETERS 2079C CAN BE USED TO CONTROL THIS (I.E., WE USE: 2080C 2081C THE MAXIMUM OF NGROUP2 AND ICCTG1 2082C THE MAXIMUM OF NGROUP3 AND ICCTG2 2083C THE MAXIMUM OF NGROUP4 AND ICCTG3 2084C THE MAXIMUM OF NGROUP5 AND ICCTG4 2085C THE MAXIMUM OF NGROUP6 AND ICCTG5 2086C 2087C INPUT ARGUMENTS--X1 = THE SINGLE PRECISION VECTOR CONTAINING 2088C THE VALUES OF THE FIRST GROUP VARIABLE 2089C --X2 = THE SINGLE PRECISION VECTOR CONTAINING 2090C THE VALUES OF THE SECOND GROUP VARIABLE 2091C --X3 = THE SINGLE PRECISION VECTOR CONTAINING 2092C THE VALUES OF THE THIRD GROUP VARIABLE 2093C --X4 = THE SINGLE PRECISION VECTOR CONTAINING 2094C THE VALUES OF THE FOURTH GROUP VARIABLE 2095C --X5 = THE SINGLE PRECISION VECTOR CONTAINING 2096C THE VALUES OF THE FIFTH GROUP VARIABLE 2097C --X6 = THE SINGLE PRECISION VECTOR CONTAINING 2098C THE VALUES OF THE SIXTH GROUP VARIABLE 2099C --N = THE INTEGER NUMBER OF OBSERVATIONS 2100C IN THE VECTORS X1, X2, X3, X4, X5 AND 2101C X6. 2102C --ICCTOF = THE INTEGER PARAMETER THAT SPECIFIES 2103C THE OFFSET. 2104C --ICCTG1 = THE INTEGER PARAMETER THAT SPECIFIES 2105C THE SPACING FOR GROUP 2. 2106C --ICCTG2 = THE INTEGER PARAMETER THAT SPECIFIES 2107C THE SPACING FOR GROUP 3. 2108C --ICCTG3 = THE INTEGER PARAMETER THAT SPECIFIES 2109C THE SPACING FOR GROUP 4. 2110C --ICCTG4 = THE INTEGER PARAMETER THAT SPECIFIES 2111C THE SPACING FOR GROUP 5. 2112C --ICCTG5 = THE INTEGER PARAMETER THAT SPECIFIES 2113C THE SPACING FOR GROUP 6. 2114C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR INTO WHICH 2115C THE CODED VALUES WILL BE PLACED. 2116C OUTPUT--THE SINGLE PRECISION VECTOR Y WHICH WILL CONTAIN THE CODED 2117C VALUES CORRESPONDING TO THE OBSERVATIONS IN THE VECTORS 2118C X1, X2, X3, X4, X5 AND X6. 2119C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 2120C OTHER DATAPAC SUBROUTINES NEEDED--SORT, DISTIN. 2121C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 2122C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 2123C LANGUAGE--ANSI FORTRAN (1977) 2124C WRITTEN BY--JAMES J. FILLIBEN 2125C STATISTICAL ENGINEERING DIVISION 2126C INFORMATION TECHNOLOGY LABORATORY 2127C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 2128C GAITHERSBURG, MD 20899-8980 2129C PHONE--301-975-2899 2130C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 2131C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 2132C LANGUAGE--ANSI FORTRAN (1977) 2133C VERSION NUMBER--2009/6 2134C ORIGINAL VERSION--JUNE 2009. 2135C 2136C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 2137C 2138 CHARACTER*4 IWRITE 2139 CHARACTER*4 IBUGA3 2140 CHARACTER*4 ISUBRO 2141 CHARACTER*4 IERROR 2142C 2143 CHARACTER*4 ISUBN1 2144 CHARACTER*4 ISUBN2 2145C 2146C--------------------------------------------------------------------- 2147C 2148CCCCC INCLUDE 'DPCOPA.INC' 2149C 2150 DIMENSION X1(*) 2151 DIMENSION X2(*) 2152 DIMENSION X3(*) 2153 DIMENSION X4(*) 2154 DIMENSION X5(*) 2155 DIMENSION X6(*) 2156 DIMENSION Y(*) 2157 DIMENSION XIDTEM(*) 2158 DIMENSION XIDTE2(*) 2159 DIMENSION XIDTE3(*) 2160 DIMENSION XIDTE4(*) 2161 DIMENSION XIDTE5(*) 2162 DIMENSION XIDTE6(*) 2163C 2164C--------------------------------------------------------------------- 2165C 2166 INCLUDE 'DPCOP2.INC' 2167C 2168C-----START POINT----------------------------------------------------- 2169C 2170 ISUBN1='CODC' 2171 ISUBN2='T6 ' 2172 IERROR='NO' 2173C 2174 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT6')THEN 2175 WRITE(ICOUT,999) 2176 999 FORMAT(1X) 2177 CALL DPWRST('XXX','BUG ') 2178 WRITE(ICOUT,51) 2179 51 FORMAT('***** AT THE BEGINNING OF CODCT6--') 2180 CALL DPWRST('XXX','BUG ') 2181 WRITE(ICOUT,52)IBUGA3,ISUBRO,N 2182 52 FORMAT('IBUGA3,ISUBRO,N = ',A4,2X,A4,2X,I8) 2183 CALL DPWRST('XXX','BUG ') 2184 WRITE(ICOUT,53)ICCTOF,ICCTG1,ICCTG2,ICCTG3,ICCTG4,ICCTG5 2185 53 FORMAT('ICCTOF,ICCTG1,ICCTG2,ICCTG3,ICCTG4,ICCTG5 = ',6I5) 2186 CALL DPWRST('XXX','BUG ') 2187 DO55I=1,N 2188 WRITE(ICOUT,56)I,X1(I),X2(I),X3(I),X4(I),X5(I),X6(I) 2189 56 FORMAT('I,X1(I),X2(I),X3(I),X4(I),X5(I),X6(I) = ',I8,6G15.7) 2190 CALL DPWRST('XXX','BUG ') 2191 55 CONTINUE 2192 ENDIF 2193C 2194C *********************************************************** 2195C ** STEP 2-- ** 2196C ** PERFORM THE CODING-- ** 2197C *********************************************************** 2198C 2199 CALL DISTIN(X1,N,IWRITE,XIDTEM,NGRP1,IBUGA3,IERROR) 2200 CALL SORT(XIDTEM,NGRP1,XIDTEM) 2201 CALL DISTIN(X2,N,IWRITE,XIDTE2,NGRP2,IBUGA3,IERROR) 2202 CALL SORT(XIDTE2,NGRP2,XIDTE2) 2203 CALL DISTIN(X3,N,IWRITE,XIDTE3,NGRP3,IBUGA3,IERROR) 2204 CALL SORT(XIDTE3,NGRP3,XIDTE3) 2205 CALL DISTIN(X4,N,IWRITE,XIDTE4,NGRP4,IBUGA3,IERROR) 2206 CALL SORT(XIDTE4,NGRP4,XIDTE4) 2207 CALL DISTIN(X5,N,IWRITE,XIDTE5,NGRP5,IBUGA3,IERROR) 2208 CALL SORT(XIDTE5,NGRP5,XIDTE5) 2209 CALL DISTIN(X6,N,IWRITE,XIDTE6,NGRP6,IBUGA3,IERROR) 2210 CALL SORT(XIDTE6,NGRP6,XIDTE6) 2211C 2212 IFACT1=MAX(NGRP2,ICCTG1) 2213 IFACT2=MAX(NGRP3,ICCTG2) 2214 IFACT3=MAX(NGRP4,ICCTG3) 2215 IFACT4=MAX(NGRP5,ICCTG4) 2216 IFACT5=MAX(NGRP6,ICCTG5) 2217C 2218 DO100I=1,N 2219C 2220 DO200J=1,NGRP1 2221 DO300K=1,NGRP2 2222 DO400L=1,NGRP3 2223 DO500M=1,NGRP4 2224 DO600JJ=1,NGRP5 2225 DO700KK=1,NGRP6 2226C 2227 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT6')THEN 2228 WRITE(ICOUT,301)I,J,K,L,M 2229 301 FORMAT('I,J,K,L,M = ',5I8) 2230 CALL DPWRST('XXX','BUG ') 2231 WRITE(ICOUT,302)X1(I),X2(I),X3(I),X4(I),X5(I),X6(I) 2232 302 FORMAT('X1(I),X2(I),X3(I),X4(I),X5(I),X6(I)=',6G15.7) 2233 CALL DPWRST('XXX','BUG ') 2234 WRITE(ICOUT,303)XIDTEM(J),XIDTE2(K),XIDTE3(L), 2235 1 XIDTE4(M),XIDTE5(JJ),XIDTE6(KK) 2236 303 FORMAT('XIDTEM(J),XIDTE2(K),XIDTE3(L),XIDTE4(M),', 2237 1 'XIDTE5(JJ),XIDTE6(KK)=',6G15.7) 2238 CALL DPWRST('XXX','BUG ') 2239 ENDIF 2240C 2241 IF(X1(I).EQ.XIDTEM(J) .AND. X2(I).EQ.XIDTE2(K) .AND. 2242 1 X3(I).EQ.XIDTE3(L) .AND. X4(I).EQ.XIDTE4(M) .AND. 2243 1 X5(I).EQ.XIDTE5(JJ) .AND. X6(I).EQ.XIDTE6(KK))THEN 2244 IINDX=ICCTOF + (J-1)*IFACT1*IFACT2*IFACT3*IFACT4*IFACT5 + 2245 1 (K-1)*IFACT2*IFACT3*IFACT4*IFACT5 + 2246 1 (L-1)*IFACT3*IFACT4*IFACT5 + 2247 1 (M-1)*IFACT4*IFACT5 + 2248 1 (JJ-1)*IFACT5 + KK 2249 Y(I)=REAL(IINDX) 2250 GOTO100 2251 ENDIF 2252 700 CONTINUE 2253 600 CONTINUE 2254 500 CONTINUE 2255 400 CONTINUE 2256 300 CONTINUE 2257 200 CONTINUE 2258C 2259 WRITE(ICOUT,999) 2260 CALL DPWRST('XXX','BUG ') 2261 WRITE(ICOUT,305) 2262 305 FORMAT('***** INTERNAL ERROR IN CODCT6 SUBROUTINE--') 2263 CALL DPWRST('XXX','BUG ') 2264 WRITE(ICOUT,310)I 2265 310 FORMAT(' NO CODE FOUND FOR ELEMENT NUMBER ',I8) 2266 CALL DPWRST('XXX','BUG ') 2267 WRITE(ICOUT,312)X1(I) 2268 312 FORMAT(' GROUP-ID VARIABLE 1 = ',G15.7) 2269 CALL DPWRST('XXX','BUG ') 2270 WRITE(ICOUT,313)X2(I) 2271 313 FORMAT(' GROUP-ID VARIABLE 2 = ',G15.7) 2272 CALL DPWRST('XXX','BUG ') 2273 WRITE(ICOUT,314)X3(I) 2274 314 FORMAT(' GROUP-ID VARIABLE 3 = ',G15.7) 2275 CALL DPWRST('XXX','BUG ') 2276 WRITE(ICOUT,315)X4(I) 2277 315 FORMAT(' GROUP-ID VARIABLE 4 = ',G15.7) 2278 CALL DPWRST('XXX','BUG ') 2279 WRITE(ICOUT,316)X5(I) 2280 316 FORMAT(' GROUP-ID VARIABLE 5 = ',G15.7) 2281 CALL DPWRST('XXX','BUG ') 2282 WRITE(ICOUT,317)X6(I) 2283 317 FORMAT(' GROUP-ID VARIABLE 6 = ',G15.7) 2284 CALL DPWRST('XXX','BUG ') 2285 IERROR='YES' 2286 GOTO9000 2287C 2288 100 CONTINUE 2289C 2290C ****************************** 2291C ** STEP 3-- ** 2292C ** WRITE OUT A FEW LINES ** 2293C ** OF SUMMARY INFORMATION ** 2294C ** ABOUT THE CODING. ** 2295C ****************************** 2296C 2297 IF(IFEEDB.EQ.'OFF')GOTO890 2298 IF(IWRITE.EQ.'OFF')GOTO890 2299 WRITE(ICOUT,999) 2300 CALL DPWRST('XXX','BUG ') 2301 WRITE(ICOUT,811)NGRP1*NGRP2*NGRP3*NGRP4*NGRP5*NGRP6 2302 811 FORMAT('NUMBER OF DISTINCT CODE VALUES = ',I8) 2303 CALL DPWRST('XXX','BUG ') 2304 WRITE(ICOUT,999) 2305 CALL DPWRST('XXX','BUG ') 2306 890 CONTINUE 2307C 2308C ***************** 2309C ** STEP 90-- ** 2310C ** EXIT. ** 2311C ***************** 2312C 2313 9000 CONTINUE 2314C 2315 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DCT6')THEN 2316 WRITE(ICOUT,999) 2317 CALL DPWRST('XXX','BUG ') 2318 WRITE(ICOUT,9011) 2319 9011 FORMAT('***** AT THE END OF CODCT6--') 2320 CALL DPWRST('XXX','BUG ') 2321 WRITE(ICOUT,9013)NGRP1,NGRP2,NGRP3,NGRP4,NGRP5,NGRP6 2322 9013 FORMAT('NGRP1,NGRP2,NGRP3,NGRP4,NGRP5,NGRP6 = ',6I8) 2323 CALL DPWRST('XXX','BUG ') 2324 DO9015I=1,N 2325 WRITE(ICOUT,9016)I,X1(I),X2(I),X3(I),X4(I),X5(I),X6(I),Y(I) 2326 9016 FORMAT('I,X1(I),X2(I),X3(I),X4(I),X5(I),X6(I),Y(I) = ', 2327 1 I8,6G15.7) 2328 CALL DPWRST('XXX','BUG ') 2329 9015 CONTINUE 2330 ENDIF 2331C 2332 RETURN 2333 END 2334 SUBROUTINE CODE(X,N,IWRITE,Y,DIST,MAXOBV,IBUGA3,IERROR) 2335C 2336C PURPOSE--THIS SUBROUTINE CODES THE ELEMENTS 2337C OF THE INPUT VECTOR X 2338C AND PUTS THE CODED VALUES INTO THE OUTPUT VECTOR Y. 2339C THE CODING IS AS FOLLOWS-- 2340C THE MINIMUM IS CODED AS 1.0. 2341C THE NEXT LARGER VALUE AS 2.0, 2342C THE NEXT LARGER VALUE AS 3.0, 2343C ETC. 2344C NOTE--THIS ROUTINE IN JJF8 HAS BEEN MODIFIED FOR DATAPLOT 2345C FROM THE SAME-NAME SUBROUTINE IN JJF6 IN 4 IMPORTANT WAYS-- 2346C 1) THE UPPER LIMIT (IUPPER) HAS BEEN 2347C REDUCED FROM 7500 TO 1000 2348C 2) THE VECTOR DIST HAS HAD ITS DIMENSION 2349C CHANGED FROM 7500 TO 1000. 2350C 3) THE VECTOR DIST HAS BEEN TAKEN OUT OF COMMON. 2351C 4) THE VECTOR WS HAS BEEN DELETED. 2352C 5) THE OUTPUT WRITING HAS BEEN SUPPRESSED. 2353C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR 2354C OF OBSERVATIONS TO BE CODED. 2355C --N = THE INTEGER NUMBER OF OBSERVATIONS 2356C IN THE VECTOR X. 2357C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR 2358C INTO WHICH THE CODED VALUES 2359C WILL BE PLACED. 2360C OUTPUT--THE SINGLE PRECISION VECTOR Y 2361C WHICH WILL CONTAIN THE CODED VALUES 2362C CORRESPONDING TO THE OBSERVATIONS IN 2363C THE VECTOR X. 2364C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 2365C RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N 2366C FOR THIS SUBROUTINE IS 15000. 2367C OTHER DATAPAC SUBROUTINES NEEDED--SORT. 2368C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 2369C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 2370C LANGUAGE--ANSI FORTRAN (1977) 2371C COMMENT--ALL OCCURRANCES OF THE MINIMUM ARE CODED AS 1.0; 2372C ALL OCCURANCES OF THE NEXT LARGER VALUE 2373C ARE CODED AS 2.0; 2374C ALL OCCURANCES OF THE NEXT LARGER VALUE 2375C ARE CODED AS 3.0, ETC. 2376C COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. 2377C REFERENCES--NONE. 2378C WRITTEN BY--JAMES J. FILLIBEN 2379C STATISTICAL ENGINEERING DIVISION 2380C INFORMATION TECHNOLOGY LABORATORY 2381C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 2382C GAITHERSBURG, MD 20899 2383C PHONE--301-975-2855 2384C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 2385C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 2386C LANGUAGE--ANSI FORTRAN (1977) 2387C VERSION NUMBER--82/7 2388C ORIGINAL VERSION--OCTOBER 1975. 2389C UPDATED --NOVEMBER 1975. 2390C UPDATED --JUNE 1977. 2391C UPDATED --JULY 1977. 2392C UPDATED --JULY 1979. 2393C UPDATED --AUGUST 1981. 2394C UPDATED --APRIL 1982. 2395C UPDATED --MAY 1982. 2396C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON 2397C 2398C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 2399C 2400 CHARACTER*4 IWRITE 2401 CHARACTER*4 IBUGA3 2402 CHARACTER*4 IERROR 2403C 2404 CHARACTER*4 ISUBN1 2405 CHARACTER*4 ISUBN2 2406C 2407C--------------------------------------------------------------------- 2408C 2409 DIMENSION X(*) 2410 DIMENSION Y(*) 2411 DIMENSION DIST(*) 2412C 2413C--------------------------------------------------------------------- 2414C 2415 INCLUDE 'DPCOP2.INC' 2416C 2417C-----START POINT----------------------------------------------------- 2418C 2419 ISUBN1='CODE' 2420 ISUBN2=' ' 2421 IERROR='NO' 2422 IUPPER=MAXOBV 2423C 2424 IF(IBUGA3.EQ.'ON')THEN 2425 WRITE(ICOUT,999) 2426 999 FORMAT(1X) 2427 CALL DPWRST('XXX','BUG ') 2428 WRITE(ICOUT,51) 2429 51 FORMAT('***** AT THE BEGINNING OF CODE--') 2430 CALL DPWRST('XXX','BUG ') 2431 WRITE(ICOUT,52)IBUGA3,N,IUPPER 2432 52 FORMAT('IBUGA3,N,IUPPER = ',A4,2X,2I8) 2433 CALL DPWRST('XXX','BUG ') 2434 DO55I=1,N 2435 WRITE(ICOUT,56)I,X(I) 2436 56 FORMAT('I,X(I) = ',I8,G15.7) 2437 CALL DPWRST('XXX','BUG ') 2438 55 CONTINUE 2439 ENDIF 2440C 2441C ***************************** 2442C ** COMPUTE CODED VALUES. ** 2443C ***************************** 2444C 2445C ******************************************** 2446C ** STEP 1-- ** 2447C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 2448C ******************************************** 2449C 2450 IF(N.LT.1 .OR. N.GT.IUPPER)THEN 2451 WRITE(ICOUT,999) 2452 CALL DPWRST('XXX','BUG ') 2453 WRITE(ICOUT,111) 2454 111 FORMAT('***** ERROR IN CODE--') 2455 CALL DPWRST('XXX','BUG ') 2456 WRITE(ICOUT,113) 2457 113 FORMAT(' THE NUMBER OF OBSERVATIONS IN THE RESPONSE ', 2458 1 'VARIABLE') 2459 CALL DPWRST('XXX','BUG ') 2460 WRITE(ICOUT,115)IUPPER 2461 115 FORMAT(' IS LESS THAN 1 OR GREATER THAN ',I10) 2462 CALL DPWRST('XXX','BUG ') 2463 WRITE(ICOUT,118)N 2464 118 FORMAT(' THE VALUE OF THE ARGUMENT IS ',I8) 2465 CALL DPWRST('XXX','BUG ') 2466 IERROR='YES' 2467 GOTO9000 2468 ENDIF 2469C 2470 IF(N.EQ.1)THEN 2471 Y(1)=1.0 2472 GOTO9000 2473 ENDIF 2474C 2475 HOLD=X(1) 2476 DO135I=2,N 2477 IF(X(I).NE.HOLD)GOTO139 2478 135 CONTINUE 2479 DO137I=1,N 2480 Y(I)=1.0 2481 137 CONTINUE 2482 GOTO9000 2483 139 CONTINUE 2484C 2485C ************************************************************* 2486C ** STEP 2-- ** 2487C ** PERFORM THE CODING-- ** 2488C ** PULL OUT THE DISTINCT VALUES, ** 2489C ** THEN SORT (AND ESSENTIALLY RANK) THE DISTINCT VALUES, ** 2490C ** THEN APPLY THE RANKS TO ALL THE VALUES. ** 2491C ************************************************************* 2492C 2493 NUMDIS=1 2494 DIST(NUMDIS)=X(1) 2495 DO200I=2,N 2496 DO300J=1,NUMDIS 2497 IF(X(I).EQ.DIST(J))GOTO200 2498 300 CONTINUE 2499 NUMDIS=NUMDIS+1 2500 DIST(NUMDIS)=X(I) 2501 200 CONTINUE 2502C 2503 CALL SORT(DIST,NUMDIS,DIST) 2504C 2505 DO600I=1,N 2506 DO700J=1,NUMDIS 2507 IF(X(I).EQ.DIST(J))THEN 2508 Y(I)=J 2509 GOTO600 2510 ENDIF 2511 700 CONTINUE 2512 WRITE(ICOUT,999) 2513 CALL DPWRST('XXX','BUG ') 2514 WRITE(ICOUT,705) 2515 CALL DPWRST('XXX','BUG ') 2516 WRITE(ICOUT,710)I,X(I) 2517 705 FORMAT('***** INTERNAL ERROR IN CODE SUBROUTINE--') 2518 CALL DPWRST('XXX','BUG ') 2519 710 FORMAT(' NO CODE FOUND FOR ELEMENT NUMBER ',I8,' = ', 2520 1 G15.7) 2521 GOTO9000 2522 600 CONTINUE 2523C 2524C ****************************** 2525C ** STEP 3-- ** 2526C ** WRITE OUT A FEW LINES ** 2527C ** OF SUMMARY INFORMATION ** 2528C ** ABOUT THE CODING. ** 2529C ****************************** 2530C 2531 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 2532 WRITE(ICOUT,999) 2533 CALL DPWRST('XXX','BUG ') 2534 WRITE(ICOUT,811)NUMDIS 2535 811 FORMAT('NUMBER OF DISTINCT CODE VALUES = ',I8) 2536 CALL DPWRST('XXX','BUG ') 2537 WRITE(ICOUT,999) 2538 CALL DPWRST('XXX','BUG ') 2539 AI=1 2540 WRITE(ICOUT,812)DIST(1),AI 2541 812 FORMAT('THE MINIMUM (= ',G15.7,' ) HAS CODE VALUE ',F10.0) 2542 CALL DPWRST('XXX','BUG ') 2543 AI=NUMDIS 2544 WRITE(ICOUT,813)DIST(NUMDIS),AI 2545 813 FORMAT('THE MAXIMUM (= ',G15.7,' ) HAS CODE VALUE ',F10.0) 2546 CALL DPWRST('XXX','BUG ') 2547 ENDIF 2548C 2549C ***************** 2550C ** STEP 90-- ** 2551C ** EXIT. ** 2552C ***************** 2553C 2554 9000 CONTINUE 2555C 2556 IF(IBUGA3.EQ.'ON')THEN 2557 WRITE(ICOUT,999) 2558 CALL DPWRST('XXX','BUG ') 2559 WRITE(ICOUT,9011) 2560 9011 FORMAT('***** AT THE END OF CODE--') 2561 CALL DPWRST('XXX','BUG ') 2562 WRITE(ICOUT,9012)IBUGA3,IERROR 2563 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 2564 CALL DPWRST('XXX','BUG ') 2565 WRITE(ICOUT,9013)N,NUMDIS 2566 9013 FORMAT('N,NUMDIS = ',2I8) 2567 CALL DPWRST('XXX','BUG ') 2568 DO9015I=1,N 2569 WRITE(ICOUT,9016)I,X(I),Y(I),DIST(I) 2570 9016 FORMAT('I,X(I),Y(I),DIST(I) = ',I8,3E15.7) 2571 CALL DPWRST('XXX','BUG ') 2572 9015 CONTINUE 2573 ENDIF 2574C 2575 RETURN 2576 END 2577 SUBROUTINE CODECH(YTEMP,IWRITE,IBUGA3,ISUBRO,IERROR) 2578C 2579C PURPOSE--THIS SUBROUTINE READS THE CHARCTER DATA STORED IN 2580C FILE "DPZCHF.DAT" AND CODES A SELECTED FIELD INTO 2581C A NUMERIC VARIABLE. THAT IS, EACH DISTINCT 2582C CHARACTER VARIABLE WILL BE ASSIGNED AN INTEGER 2583C CODE (DETERMINED BY ORDER THAT THE FIRST OCCURENCE 2584C IS FOUND). 2585C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR 2586C INTO WHICH THE CODED VALUES 2587C WILL BE PLACED. 2588C --N = THE INTEGER NUMBER OF OBSERVATIONS 2589C IN THE CHARACTER VARIABLE. 2590C OUTPUT--THE SINGLE PRECISION VECTOR Y 2591C WHICH WILL CONTAIN THE CODED VALUES 2592C CORRESPONDING TO THE OBSERVATIONS IN 2593C THE VECTOR X. 2594C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 2595C RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N 2596C FOR THIS SUBROUTINE IS MAXOBV. 2597C OTHER DATAPAC SUBROUTINES NEEDED--SORT. 2598C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 2599C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 2600C LANGUAGE--ANSI FORTRAN (1977) 2601C REFERENCES--NONE. 2602C WRITTEN BY--ALAN HECKERT 2603C STATISTICAL ENGINEERING DIVISION 2604C INFORMATION TECHNOLOGY LABORATORY 2605C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 2606C GAITHERSBURG, MD 20899-8980 2607C PHONE--301-975-2899 2608C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 2609C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 2610C LANGUAGE--ANSI FORTRAN (1977) 2611C VERSION NUMBER--2004/1 2612C ORIGINAL VERSION--JANUARY 2004. 2613C UPDATED --FEBRUARY 2006. FIX BUG WHERE IT WAS ONLY 2614C WORKING IF THERE WAS ONE 2615C CHARACTER VARIABLE IN THE 2616C DPZCHF.DAT. 2617C UPDATED --APRIL 2017. MODIFY THE FEEDBACK TO SHOW 2618C THE ACTUAL MAPPING 2619C UPDATED --JUNE 2019. DIMENSION SCRATCH REAL ARRAYS IN 2620C CALLING ROUTINE 2621C 2622C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 2623C 2624 DIMENSION YTEMP(*) 2625C 2626 CHARACTER*4 IWRITE 2627 CHARACTER*4 IBUGA3 2628 CHARACTER*4 ISUBRO 2629 CHARACTER*4 IERROR 2630C 2631 CHARACTER*4 ISTEPN 2632 CHARACTER*4 ISUBN1 2633 CHARACTER*4 ISUBN2 2634 CHARACTER*4 ICASEL 2635C 2636 CHARACTER*4 IH 2637 CHARACTER*4 IH2 2638 CHARACTER*4 IHLEFT 2639 CHARACTER*4 IHLEF2 2640 CHARACTER*4 IHRIGH 2641 CHARACTER*4 IHRIG2 2642C 2643C--------------------------------------------------------------------- 2644C 2645 INCLUDE 'DPCOPA.INC' 2646 INCLUDE 'DPCODA.INC' 2647 INCLUDE 'DPCOHK.INC' 2648 INCLUDE 'DPCOF2.INC' 2649 INCLUDE 'DPCOZC.INC' 2650C 2651CCCCC CHARACTER*80 IFILE 2652 CHARACTER (LEN=MAXFNC) :: IFILE 2653 CHARACTER*12 ISTAT 2654 CHARACTER*12 IFORM 2655 CHARACTER*12 IACCES 2656 CHARACTER*12 IPROT 2657 CHARACTER*12 ICURST 2658 CHARACTER*4 IENDFI 2659 CHARACTER*4 IREWIN 2660 CHARACTER*4 ISUBN0 2661 CHARACTER*4 IERRFI 2662C 2663 CHARACTER*500 IATEMP 2664 CHARACTER*20 IFRMT 2665 CHARACTER*24 IXTEMP(MAXOBV) 2666 EQUIVALENCE (CGARBG(1),IXTEMP(1)) 2667C 2668C--------------------------------------------------------------------- 2669C 2670 INCLUDE 'DPCOP2.INC' 2671C 2672C-----START POINT----------------------------------------------------- 2673C 2674 ISUBN1='CODE' 2675 ISUBN2='CH ' 2676 IERROR='NO' 2677C 2678 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DECH')THEN 2679 WRITE(ICOUT,999) 2680 999 FORMAT(1X) 2681 CALL DPWRST('XXX','BUG ') 2682 WRITE(ICOUT,51) 2683 51 FORMAT('***** AT THE BEGINNING OF CODECH--') 2684 CALL DPWRST('XXX','BUG ') 2685 WRITE(ICOUT,52)IBUGA3 2686 52 FORMAT('IBUGA3 = ',A4) 2687 CALL DPWRST('XXX','BUG ') 2688 ENDIF 2689C 2690C ************************************************** 2691C ** STEP 1-- * 2692C ** EXAMINE THE LEFT-HAND SIDE-- * 2693C ** IS THE NAME NAME TO LEFT OF = SIGN * 2694C ** ALREADY IN THE NAME LIST? * 2695C ** NOTE THAT ILISTL IS THE LINE IN THE * 2696C ** TABLE OF THE NAME ON THE LEFT. * 2697C ************************************************** 2698C 2699 ISTEPN='1' 2700 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DECH') 2701 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2702C 2703 IHLEFT=IHARG(1) 2704 IHLEF2=IHARG2(1) 2705 DO2000I=1,NUMNAM 2706 I2=I 2707 IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN 2708 ILISTL=I2 2709 GOTO2100 2710 ENDIF 2711 2000 CONTINUE 2712 ILISTL=NUMNAM+1 2713 IF(ILISTL.GT.MAXNAM)THEN 2714 WRITE(ICOUT,999) 2715 CALL DPWRST('XXX','BUG ') 2716 WRITE(ICOUT,2201) 2717 2201 FORMAT('***** ERROR IN CODECH--') 2718 CALL DPWRST('XXX','BUG ') 2719 WRITE(ICOUT,2202) 2720 2202 FORMAT(' THE NUMBER OF VARIABLE, PARAMETER, AND FUNCTION') 2721 CALL DPWRST('XXX','BUG ') 2722 WRITE(ICOUT,2203)MAXNAM 2723 2203 FORMAT(' NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8) 2724 CALL DPWRST('XXX','BUG ') 2725 WRITE(ICOUT,2204) 2726 2204 FORMAT(' ENTER STATUS') 2727 CALL DPWRST('XXX','BUG ') 2728 WRITE(ICOUT,2205) 2729 2205 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES, AND') 2730 CALL DPWRST('XXX','BUG ') 2731 WRITE(ICOUT,2206) 2732 2206 FORMAT(' THEN DELETE SOME OF THE ALREADY-USED NAMES.') 2733 CALL DPWRST('XXX','BUG ') 2734 IERROR='YES' 2735 GOTO9000 2736 ENDIF 2737C 2738 2100 CONTINUE 2739C 2740C ***************************** 2741C ** COMPUTE CODED VALUES. ** 2742C ***************************** 2743C 2744C ******************************************** 2745C ** STEP 2-- ** 2746C ** OPEN THE DPZCHF.DAT FILE. ** 2747C ******************************************** 2748C 2749 IHRIGH=IHARG(5) 2750 IHRIG2=IHARG2(5) 2751C 2752 IOUNIT=IZCHNU 2753 IFILE=IZCHNA 2754 ISTAT=IZCHST 2755 IFORM=IZCHFO 2756 IACCES=IZCHAC 2757 IPROT=IZCHPR 2758 ICURST=IZCHCS 2759C 2760 ISUBN0='READ' 2761 IERRFI='NO' 2762 CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT, 2763 1 ICURST, 2764 1 IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR) 2765 IF(IERRFI.EQ.'YES')THEN 2766 IERROR='YES' 2767 WRITE(ICOUT,999) 2768 CALL DPWRST('XXX','BUG ') 2769 WRITE(ICOUT,111) 2770 111 FORMAT('***** ERROR IN CODECH--') 2771 CALL DPWRST('XXX','BUG ') 2772 WRITE(ICOUT,118) 2773 118 FORMAT(' UNABLE TO OPEN THE FILE CHARACTER DATA FILE:') 2774 CALL DPWRST('XXX','BUG ') 2775 WRITE(ICOUT,119)IFILE 2776 119 FORMAT(' ',A80) 2777 CALL DPWRST('XXX','BUG ') 2778 GOTO8000 2779 ENDIF 2780C 2781 READ(IOUNIT,'(I8)',END=171,ERR=171)NUMVAR 2782C 2783CCCCC FEBRUARY 2006: BUG FIX FOR THE FOLLOWING LOOP. 2784C 2785 IVAR=-1 2786 DO130I=1,NUMVAR 2787 READ(IOUNIT,'(A4,A4)',END=181,ERR=181)IH,IH2 2788 IF(IHRIGH.EQ.IH .AND. IHRIG2.EQ.IH2)THEN 2789 IVAR=I 2790CCCCC GOTO199 2791 ENDIF 2792 130 CONTINUE 2793 IF(IVAR.GT.0)GOTO199 2794C 2795 WRITE(ICOUT,999) 2796 CALL DPWRST('XXX','BUG ') 2797 WRITE(ICOUT,111) 2798 CALL DPWRST('XXX','BUG ') 2799 WRITE(ICOUT,131)IHRIGH,IHRIG2 2800 131 FORMAT('***** VARIABLE ',A4,A4,' NOT FOUND IN THE CHARACTER ', 2801 1 'DATA FILE:') 2802 CALL DPWRST('XXX','BUG ') 2803 WRITE(ICOUT,119)IFILE 2804 CALL DPWRST('XXX','BUG ') 2805 IERROR='YES' 2806 GOTO8000 2807C 2808 171 CONTINUE 2809 WRITE(ICOUT,999) 2810 CALL DPWRST('XXX','BUG ') 2811 WRITE(ICOUT,111) 2812 CALL DPWRST('XXX','BUG ') 2813 WRITE(ICOUT,173) 2814 173 FORMAT(' ERROR READING THE NUMBER OF CHARACTER VARIABLES ', 2815 1 'IN THE CHARACTER DATA FILE:') 2816 CALL DPWRST('XXX','BUG ') 2817 WRITE(ICOUT,119)IFILE 2818 CALL DPWRST('XXX','BUG ') 2819 IERROR='YES' 2820 GOTO8000 2821C 2822 181 CONTINUE 2823 WRITE(ICOUT,999) 2824 CALL DPWRST('XXX','BUG ') 2825 WRITE(ICOUT,111) 2826 CALL DPWRST('XXX','BUG ') 2827 WRITE(ICOUT,183) 2828 183 FORMAT(' ERROR READING THE VARIABLE NAMES ', 2829 1 'IN THE CHARACTER DATA FILE:') 2830 CALL DPWRST('XXX','BUG ') 2831 WRITE(ICOUT,119)IFILE 2832 CALL DPWRST('XXX','BUG ') 2833 IERROR='YES' 2834 GOTO8000 2835C 2836 199 CONTINUE 2837C 2838C ************************************************* 2839C ** STEP 2-- ** 2840C ** PERFORM THE CODING-- ** 2841C ** STORE UNIQUE VALUES IN IXTEMP, COMPARE ** 2842C ** TO LIST IN IXTEMP. ** 2843C ************************************************* 2844C 2845 IATEMP=' ' 2846 IFRMT='(A )' 2847 WRITE(IFRMT(3:5),'(I3)')25*IVAR 2848 N=1 2849 IROW=1 2850 READ(IOUNIT,IFRMT,END=491,ERR=491)IATEMP 2851 YTEMP(1)=REAL(N) 2852 IFRST=(IVAR-1)*25 + 1 2853 ILAST=IVAR*25 - 1 2854 IXTEMP(1)=' ' 2855 IXTEMP(1)=IATEMP(IFRST:ILAST) 2856C 2857 DO210I=2,MAXOBV 2858 IATEMP=' ' 2859 READ(IOUNIT,IFRMT,END=499,ERR=491)IATEMP 2860 IROW=I 2861 DO220J=1,N 2862 IF(IATEMP(IFRST:ILAST).EQ.IXTEMP(J)(1:24))THEN 2863 YTEMP(IROW)=REAL(J) 2864 GOTO210 2865 ENDIF 2866 220 CONTINUE 2867 N=N+1 2868 IXTEMP(N)=' ' 2869 IXTEMP(N)=IATEMP(IFRST:ILAST) 2870 YTEMP(IROW)=REAL(N) 2871 210 CONTINUE 2872 GOTO499 2873C 2874 491 CONTINUE 2875 WRITE(ICOUT,999) 2876 CALL DPWRST('XXX','BUG ') 2877 WRITE(ICOUT,111) 2878 CALL DPWRST('XXX','BUG ') 2879 WRITE(ICOUT,493)IROW 2880 493 FORMAT(' ERROR READING ROW ',I8,' OF THE CHARACTER ', 2881 1 'VARIABLES IN THE CHARACTER DATA FILE:') 2882 CALL DPWRST('XXX','BUG ') 2883 WRITE(ICOUT,119)IFILE 2884 CALL DPWRST('XXX','BUG ') 2885 IERROR='YES' 2886 GOTO8000 2887C 2888C 2889C ****************************** 2890C ** STEP 3-- ** 2891C ** WRITE OUT A FEW LINES ** 2892C ** OF SUMMARY INFORMATION ** 2893C ** ABOUT THE CODING. ** 2894C ****************************** 2895C 2896 499 CONTINUE 2897C 2898C 2017/04: MODIFY THE FEEDBACK TO SHOW THE FULL MAPPING 2899C 2900 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 2901 WRITE(ICOUT,999) 2902 CALL DPWRST('XXX','BUG ') 2903 WRITE(ICOUT,811)IHRIGH,IHRIG2,N 2904 811 FORMAT('NUMBER OF DISTINCT CHARACTER VALUES FOR ',2A4,' = ',I8) 2905 CALL DPWRST('XXX','BUG ') 2906 WRITE(ICOUT,999) 2907 CALL DPWRST('XXX','BUG ') 2908 IF(N.LE.9)THEN 2909 IFRMT="(A ,' => ',I1)" 2910 ELSEIF(N.LE.99)THEN 2911 IFRMT="(A ,' => ',I2)" 2912 ELSE 2913 IFRMT="(A ,' => ',I3)" 2914 ENDIF 2915C 2916 MAXCHR=1 2917 DO810I=1,MIN(N,100) 2918 DO813J=24,1,-1 2919 IF(IXTEMP(I)(J:J).NE.' ')THEN 2920 IF(J.GT.MAXCHR)MAXCHR=J 2921 GOTO815 2922 ENDIF 2923 813 CONTINUE 2924 815 CONTINUE 2925 810 CONTINUE 2926 WRITE(IFRMT(3:4),'(I2)')MAXCHR 2927C 2928 DO820I=1,N 2929 WRITE(ICOUT,IFRMT)IXTEMP(I),I 2930 CALL DPWRST('XXX','BUG ') 2931 820 CONTINUE 2932 ENDIF 2933C 2934C ***************************************************** 2935C ** STEP 5-- ** 2936C ** ENTER THE CODED VALUES INTO THE DATAPLOT ** 2937C ** HOUSEKEEPING ARRAY ** 2938C ***************************************************** 2939C 2940 ISTEPN='5' 2941 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DECH') 2942 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 2943C 2944 ICASEL='V' 2945 XINT=0.0 2946 IXINT=0 2947 CALL DPINVP(IHLEFT,IHLEF2,ICASEL,YTEMP,IROW,XINT,IXINT, 2948 1ISUBN1,ISUBN2,IBUGA3,IERROR) 2949C 2950C *************************************** 2951C ** STEP 88-- ** 2952C ** CLOSE THE DPZCHF.DAT FILE. ** 2953C *************************************** 2954C 2955 8000 CONTINUE 2956C 2957 IENDFI='OFF' 2958 IREWIN='ON' 2959 CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 2960 1 IENDFI,IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR) 2961 IZCHCS='CLOSED' 2962 GOTO9000 2963C 2964C ***************** 2965C ** STEP 90-- ** 2966C ** EXIT. ** 2967C ***************** 2968C 2969 9000 CONTINUE 2970C 2971 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DECH')THEN 2972 WRITE(ICOUT,999) 2973 CALL DPWRST('XXX','BUG ') 2974 WRITE(ICOUT,9011) 2975 9011 FORMAT('***** AT THE END OF CODECH--') 2976 CALL DPWRST('XXX','BUG ') 2977 WRITE(ICOUT,9012)IBUGA3,IERROR,N,IROW 2978 9012 FORMAT('IBUGA3,IERROR,N,IROW = ',2(A4,2X),2I8) 2979 CALL DPWRST('XXX','BUG ') 2980 DO9015I=1,N 2981 WRITE(ICOUT,9016)I,IXTEMP(I) 2982 9016 FORMAT('I,IXTEMP(I) = ',I8,A24) 2983 CALL DPWRST('XXX','BUG ') 2984 9015 CONTINUE 2985 DO9035I=1,IROW 2986 WRITE(ICOUT,9036)I,YTEMP(I) 2987 9036 FORMAT('I,YTEMP(I) = ',I8,G15.7) 2988 CALL DPWRST('XXX','BUG ') 2989 9035 CONTINUE 2990 ENDIF 2991C 2992 RETURN 2993 END 2994 SUBROUTINE CODEC2(YTEMP,YTEMP2,IPERM,IWRITE,IBUGA3,ISUBRO,IERROR) 2995C 2996C PURPOSE--THIS SUBROUTINE READS THE CHARCTER DATA STORED IN 2997C FILE "DPZCHF.DAT" AND CODES A SELECTED FIELD INTO 2998C A NUMERIC VARIABLE. THAT IS, EACH DISTINCT 2999C CHARACTER VARIABLE WILL BE ASSIGNED AN INTEGER 3000C CODE. THIS ROUTINE IS SIMILAR TO CODECH. THE 3001C DISTINCTION IS THAT CODECH CODES BY THE ORDER THE 3002C VALUES ARE ENCOUNTERED IN THE FILE WHILE THIS 3003C ROUTINE CODES BY (LEXICAL) ALPHABETIC ORDER. 3004C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 3005C RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N 3006C FOR THIS SUBROUTINE IS MAXOBV. 3007C OTHER DATAPAC SUBROUTINES NEEDED--HPSORT. 3008C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 3009C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 3010C LANGUAGE--ANSI FORTRAN (1977) 3011C REFERENCES--NONE. 3012C WRITTEN BY--ALAN HECKERT 3013C STATISTICAL ENGINEERING DIVISION 3014C INFORMATION TECHNOLOGY LABORATORY 3015C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 3016C GAITHERSBURG, MD 20899-8980 3017C PHONE--301-975-2899 3018C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 3019C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 3020C LANGUAGE--ANSI FORTRAN (1977) 3021C VERSION NUMBER--2004/1 3022C ORIGINAL VERSION--JANUARY 2004. 3023C UPDATED --DECEMBER 2009. DON'T USE IXSAVE SO COMMENT 3024C OUT DECLARATION 3025C UPDATED --DECEMBER 2009. MODIFY DECLARATION OF IXWORK 3026C FOR INTEL COMPILER 3027C UPDATED --APRIL 2017. MODIFY THE FEEDBACK TO SHOW 3028C THE ACTUAL MAPPING 3029C UPDATED --JUNE 2019. DIMENSION REAL SCRATCH ARRAYS 3030C IN CALLING ROUTINE 3031C 3032C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 3033C 3034 DIMENSION YTEMP(*) 3035 DIMENSION YTEMP2(*) 3036 DIMENSION IPERM(*) 3037C 3038 CHARACTER*4 IWRITE 3039 CHARACTER*4 IBUGA3 3040 CHARACTER*4 ISUBRO 3041 CHARACTER*4 IERROR 3042C 3043 CHARACTER*4 ISTEPN 3044 CHARACTER*4 ISUBN1 3045 CHARACTER*4 ISUBN2 3046 CHARACTER*4 ICASEL 3047C 3048 CHARACTER*4 IH 3049 CHARACTER*4 IH2 3050 CHARACTER*4 IHLEFT 3051 CHARACTER*4 IHLEF2 3052 CHARACTER*4 IHRIGH 3053 CHARACTER*4 IHRIG2 3054C 3055C--------------------------------------------------------------------- 3056C 3057 INCLUDE 'DPCOPA.INC' 3058 INCLUDE 'DPCODA.INC' 3059 INCLUDE 'DPCOHK.INC' 3060 INCLUDE 'DPCOF2.INC' 3061 INCLUDE 'DPCOZC.INC' 3062C 3063CCCCC CHARACTER*80 IFILE 3064 CHARACTER (LEN=MAXFNC) :: IFILE 3065 CHARACTER*12 ISTAT 3066 CHARACTER*12 IFORM 3067 CHARACTER*12 IACCES 3068 CHARACTER*12 IPROT 3069 CHARACTER*12 ICURST 3070 CHARACTER*4 IENDFI 3071 CHARACTER*4 IREWIN 3072 CHARACTER*4 ISUBN0 3073 CHARACTER*4 IERRFI 3074C 3075 CHARACTER*500 IATEMP 3076 CHARACTER*20 IFRMT 3077 CHARACTER*24 IXTEMP(MAXOBV/2) 3078 CHARACTER*24 IXWORK(MAXOBV/2) 3079CCCCC CHARACTER*24 IXSAVE(MAXOBV/2) 3080 EQUIVALENCE (CGARBG(1),IXTEMP(1)) 3081 EQUIVALENCE (CGARBG(MAXOBV/2 + 1),IXWORK(1)) 3082C 3083C--------------------------------------------------------------------- 3084C 3085 INCLUDE 'DPCOP2.INC' 3086C 3087C-----START POINT----------------------------------------------------- 3088C 3089 ISUBN1='CODE' 3090 ISUBN2='C2 ' 3091 IERROR='NO' 3092C 3093 INDX=0 3094C 3095 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2')THEN 3096 ISTEPN='1' 3097 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3098 WRITE(ICOUT,999) 3099 999 FORMAT(1X) 3100 CALL DPWRST('XXX','BUG ') 3101 WRITE(ICOUT,51) 3102 51 FORMAT('***** AT THE BEGINNING OF CODEC2--') 3103 CALL DPWRST('XXX','BUG ') 3104 WRITE(ICOUT,52)IBUGA3 3105 52 FORMAT('IBUGA3 = ',A4) 3106 CALL DPWRST('XXX','BUG ') 3107 ENDIF 3108C 3109C ************************************************** 3110C ** STEP 1-- * 3111C ** EXAMINE THE LEFT-HAND SIDE-- * 3112C ** IS THE NAME NAME TO LEFT OF = SIGN * 3113C ** ALREADY IN THE NAME LIST? * 3114C ** NOTE THAT ILISTL IS THE LINE IN THE * 3115C ** TABLE OF THE NAME ON THE LEFT. * 3116C ************************************************** 3117C 3118 IHLEFT=IHARG(1) 3119 IHLEF2=IHARG2(1) 3120 DO2000I=1,NUMNAM 3121 I2=I 3122 IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN 3123 ILISTL=I2 3124 GOTO2100 3125 ENDIF 3126 2000 CONTINUE 3127 ILISTL=NUMNAM+1 3128 IF(ILISTL.GT.MAXNAM)THEN 3129 WRITE(ICOUT,999) 3130 CALL DPWRST('XXX','BUG ') 3131 WRITE(ICOUT,2201) 3132 2201 FORMAT('***** ERROR IN CODEC2--') 3133 CALL DPWRST('XXX','BUG ') 3134 WRITE(ICOUT,2202) 3135 2202 FORMAT(' THE NUMBER OF VARIABLE, PARAMETER, AND FUNCTION') 3136 CALL DPWRST('XXX','BUG ') 3137 WRITE(ICOUT,2203)MAXNAM 3138 2203 FORMAT(' NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8) 3139 CALL DPWRST('XXX','BUG ') 3140 WRITE(ICOUT,2204) 3141 2204 FORMAT(' ENTER STATUS') 3142 CALL DPWRST('XXX','BUG ') 3143 WRITE(ICOUT,2205) 3144 2205 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES, AND') 3145 CALL DPWRST('XXX','BUG ') 3146 WRITE(ICOUT,2206) 3147 2206 FORMAT(' THEN DELETE SOME OF THE ALREADY-USED NAMES.') 3148 CALL DPWRST('XXX','BUG ') 3149 IERROR='YES' 3150 GOTO9000 3151 ENDIF 3152C 3153 2100 CONTINUE 3154C 3155C ***************************** 3156C ** COMPUTE CODED VALUES. ** 3157C ***************************** 3158C 3159C ******************************************** 3160C ** STEP 2-- ** 3161C ** OPEN THE DPZCHF.DAT FILE. ** 3162C ******************************************** 3163C 3164 IHRIGH=IHARG(6) 3165 IHRIG2=IHARG2(6) 3166C 3167 IOUNIT=IZCHNU 3168 IFILE=IZCHNA 3169 ISTAT=IZCHST 3170 IFORM=IZCHFO 3171 IACCES=IZCHAC 3172 IPROT=IZCHPR 3173 ICURST=IZCHCS 3174C 3175 ISUBN0='READ' 3176 IERRFI='NO' 3177 CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT, 3178 1 ICURST, 3179 1 IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR) 3180 IF(IERRFI.EQ.'YES')THEN 3181 IERROR='YES' 3182 WRITE(ICOUT,999) 3183 CALL DPWRST('XXX','BUG ') 3184 WRITE(ICOUT,111) 3185 111 FORMAT('***** ERROR IN CODEC2--') 3186 CALL DPWRST('XXX','BUG ') 3187 WRITE(ICOUT,118) 3188 118 FORMAT(' UNABLE TO OPEN THE FILE CHARACTER DATA FILE:') 3189 CALL DPWRST('XXX','BUG ') 3190 WRITE(ICOUT,119)IFILE 3191 119 FORMAT(' ',A80) 3192 CALL DPWRST('XXX','BUG ') 3193 GOTO8000 3194 ENDIF 3195C 3196 READ(IOUNIT,'(I8)',END=171,ERR=171)NUMVAR 3197C 3198 IVAR=-1 3199 DO130I=1,NUMVAR 3200 READ(IOUNIT,'(A4,A4)',END=181,ERR=181)IH,IH2 3201 IF(IHRIGH.EQ.IH .AND. IHRIG2.EQ.IH2)THEN 3202 IVAR=I 3203CCCCC GOTO199 3204 ENDIF 3205 130 CONTINUE 3206 IF(IVAR.GT.0)GOTO199 3207C 3208 WRITE(ICOUT,999) 3209 CALL DPWRST('XXX','BUG ') 3210 WRITE(ICOUT,111) 3211 CALL DPWRST('XXX','BUG ') 3212 WRITE(ICOUT,131)IHRIGH,IHRIG2 3213 131 FORMAT('***** VARIABLE ',A4,A4,' NOT FOUND IN THE CHARACTER ', 3214 1 'DATA FILE:') 3215 CALL DPWRST('XXX','BUG ') 3216 WRITE(ICOUT,119)IFILE 3217 CALL DPWRST('XXX','BUG ') 3218 IERROR='YES' 3219 GOTO8000 3220C 3221 171 CONTINUE 3222 WRITE(ICOUT,999) 3223 CALL DPWRST('XXX','BUG ') 3224 WRITE(ICOUT,111) 3225 CALL DPWRST('XXX','BUG ') 3226 WRITE(ICOUT,173) 3227 173 FORMAT(' ERROR READING THE NUMBER OF CHARACTER VARIABLES ', 3228 1 'IN THE CHARACTER DATA FILE:') 3229 CALL DPWRST('XXX','BUG ') 3230 WRITE(ICOUT,119)IFILE 3231 CALL DPWRST('XXX','BUG ') 3232 IERROR='YES' 3233 GOTO8000 3234C 3235 181 CONTINUE 3236 WRITE(ICOUT,999) 3237 CALL DPWRST('XXX','BUG ') 3238 WRITE(ICOUT,111) 3239 CALL DPWRST('XXX','BUG ') 3240 WRITE(ICOUT,183) 3241 183 FORMAT(' ERROR READING THE VARIABLE NAMES ', 3242 1 'IN THE CHARACTER DATA FILE:') 3243 CALL DPWRST('XXX','BUG ') 3244 WRITE(ICOUT,119)IFILE 3245 CALL DPWRST('XXX','BUG ') 3246 IERROR='YES' 3247 GOTO8000 3248C 3249 199 CONTINUE 3250C 3251C ************************************************* 3252C ** STEP 2-- ** 3253C ** PERFORM THE CODING-- ** 3254C ** 1) STORE UNIQUE VALUES IN IXTEMP ** 3255C ** 2) SORT VALUES IN IXTEMP ** 3256C ** 3) CODE BASED ON SORTED IXTEMP VALUES ** 3257C ************************************************* 3258C 3259 ISTEPN='2' 3260 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2') 3261 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3262C 3263 IATEMP=' ' 3264 IFRMT=' ' 3265 IFRMT='(A )' 3266 WRITE(IFRMT(3:5),'(I3)')25*IVAR 3267 N=1 3268 IROW=1 3269 READ(IOUNIT,IFRMT,END=491,ERR=491)IATEMP 3270 YTEMP(1)=REAL(N) 3271 IFRST=(IVAR-1)*25 + 1 3272 ILAST=IVAR*25 - 1 3273 IXTEMP(1)=' ' 3274 IXTEMP(1)=IATEMP(IFRST:ILAST) 3275C 3276 DO210I=2,MAXOBV 3277 IATEMP=' ' 3278 READ(IOUNIT,IFRMT,END=499,ERR=491)IATEMP 3279 IROW=IROW+1 3280 DO220J=1,N 3281 IF(IATEMP(IFRST:ILAST).EQ.IXTEMP(J)(1:24))THEN 3282 YTEMP(IROW)=REAL(J) 3283 GOTO210 3284 ENDIF 3285 220 CONTINUE 3286 N=N+1 3287 IF(N.GT.MAXOBV/2)THEN 3288 WRITE(ICOUT,999) 3289 CALL DPWRST('XXX','BUG ') 3290 WRITE(ICOUT,111) 3291 CALL DPWRST('XXX','BUG ') 3292 WRITE(ICOUT,221) 3293 221 FORMAT(' NUMBER OF UNIQUE CHARACTER VALUE EXCEEDS ', 3294 1 I8,' .') 3295 CALL DPWRST('XXX','BUG ') 3296 WRITE(ICOUT,223) 3297 223 FORMAT(' CODING NOT PERFORMED.') 3298 CALL DPWRST('XXX','BUG ') 3299 IERROR='YES' 3300 GOTO9000 3301 ENDIF 3302 IXTEMP(N)=' ' 3303 IXTEMP(N)=IATEMP(IFRST:ILAST) 3304 YTEMP(IROW)=REAL(N) 3305 210 CONTINUE 3306C 3307 499 CONTINUE 3308C 3309 ISTEPN='3' 3310 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2') 3311 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3312C 3313 IBEG=1 3314 IEND=24 3315 KFLAG=2 3316 IER=0 3317 CALL HPSORT(IXTEMP,N,IBEG,IEND,IPERM,KFLAG,IXWORK(1),IER) 3318C 3319 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2')THEN 3320 WRITE(ICOUT,292)N,IROW,IER 3321 292 FORMAT('N,IROW,IER = ',3I8) 3322 CALL DPWRST('XXX','BUG ') 3323 IF(N.GT.0)THEN 3324 DO290I=1,N 3325 WRITE(ICOUT,293)I,IXTEMP(I),IPERM(I) 3326 293 FORMAT('I,IXTEMP(I),IPERM(I) = ',I8,1X,A24,1X,I8) 3327 CALL DPWRST('XXX','BUG ') 3328 290 CONTINUE 3329 ENDIF 3330 ENDIF 3331 IF(IER.GT.0)GOTO9000 3332C 3333 ISTEPN='4' 3334 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2') 3335 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3336C 3337 DO310I=1,IROW 3338 ITEMP=INT(YTEMP(I) + 0.5) 3339 DO320K=1,N 3340 IF(ITEMP.EQ.IPERM(K))THEN 3341 INDX=K 3342 GOTO329 3343 ENDIF 3344 320 CONTINUE 3345 329 CONTINUE 3346 YTEMP2(I)=REAL(INDX) 3347 310 CONTINUE 3348 DO330I=1,IROW 3349 YTEMP(I)=YTEMP2(I) 3350 330 CONTINUE 3351C 3352 GOTO599 3353C 3354 491 CONTINUE 3355 WRITE(ICOUT,999) 3356 CALL DPWRST('XXX','BUG ') 3357 WRITE(ICOUT,111) 3358 CALL DPWRST('XXX','BUG ') 3359 WRITE(ICOUT,493)IROW 3360 493 FORMAT(' ERROR READING ROW ',I8,' OF THE CHARACTER ', 3361 1 'VARIABLES IN THE CHARACTER DATA FILE:') 3362 CALL DPWRST('XXX','BUG ') 3363 WRITE(ICOUT,119)IFILE 3364 CALL DPWRST('XXX','BUG ') 3365 IERROR='YES' 3366 GOTO8000 3367C 3368C ****************************** 3369C ** STEP 3-- ** 3370C ** WRITE OUT A FEW LINES ** 3371C ** OF SUMMARY INFORMATION ** 3372C ** ABOUT THE CODING. ** 3373C ****************************** 3374C 3375 599 CONTINUE 3376C 3377C 2017/04: MODIFY THE FEEDBACK TO SHOW THE FULL MAPPING 3378C 3379 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 3380 WRITE(ICOUT,999) 3381 CALL DPWRST('XXX','BUG ') 3382 WRITE(ICOUT,811)IHRIGH,IHRIG2,N 3383 811 FORMAT('NUMBER OF DISTINCT CHARACTER VALUES FOR ',2A4,' = ',I8) 3384 CALL DPWRST('XXX','BUG ') 3385 WRITE(ICOUT,999) 3386 CALL DPWRST('XXX','BUG ') 3387 IF(N.LE.9)THEN 3388 IFRMT="(A ,' => ',I1)" 3389 ELSEIF(N.LE.99)THEN 3390 IFRMT="(A ,' => ',I2)" 3391 ELSE 3392 IFRMT="(A ,' => ',I3)" 3393 ENDIF 3394C 3395 MAXCHR=1 3396 DO810I=1,MIN(N,100) 3397 DO813J=24,1,-1 3398 IF(IXTEMP(I)(J:J).NE.' ')THEN 3399 IF(J.GT.MAXCHR)MAXCHR=J 3400 GOTO815 3401 ENDIF 3402 813 CONTINUE 3403 815 CONTINUE 3404 810 CONTINUE 3405 WRITE(IFRMT(3:4),'(I2)')MAXCHR 3406C 3407 DO820I=1,N 3408 WRITE(ICOUT,IFRMT)IXTEMP(I),I 3409 CALL DPWRST('XXX','BUG ') 3410 820 CONTINUE 3411 ENDIF 3412C 3413C ***************************************************** 3414C ** STEP 5-- ** 3415C ** ENTER THE CODED VALUES INTO THE DATAPLOT ** 3416C ** HOUSEKEEPING ARRAY ** 3417C ***************************************************** 3418C 3419 ISTEPN='5' 3420 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2') 3421 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3422C 3423 ICASEL='V' 3424 XINT=0.0 3425 IXINT=0 3426 CALL DPINVP(IHLEFT,IHLEF2,ICASEL,YTEMP,IROW,XINT,IXINT, 3427 1ISUBN1,ISUBN2,IBUGA3,IERROR) 3428C 3429C *************************************** 3430C ** STEP 6-- ** 3431C ** CLOSE THE DPZCHF.DAT FILE. ** 3432C *************************************** 3433C 3434 8000 CONTINUE 3435C 3436 ISTEPN='6' 3437 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2') 3438 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3439C 3440 IENDFI='OFF' 3441 IREWIN='ON' 3442 CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 3443 1 IENDFI,IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR) 3444 IZCHCS='CLOSED' 3445 GOTO9000 3446C 3447C ***************** 3448C ** STEP 90-- ** 3449C ** EXIT. ** 3450C ***************** 3451C 3452 9000 CONTINUE 3453C 3454 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC2')THEN 3455 WRITE(ICOUT,999) 3456 CALL DPWRST('XXX','BUG ') 3457 WRITE(ICOUT,9011) 3458 9011 FORMAT('***** AT THE END OF CODEC2--') 3459 CALL DPWRST('XXX','BUG ') 3460 WRITE(ICOUT,9012)IBUGA3,IERROR 3461 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 3462 CALL DPWRST('XXX','BUG ') 3463 WRITE(ICOUT,9013)N,IROW 3464 9013 FORMAT('N,IROW = ',2I8) 3465 CALL DPWRST('XXX','BUG ') 3466 DO9015I=1,N 3467 WRITE(ICOUT,9016)I,IXTEMP(I) 3468 9016 FORMAT('I,IXTEMP(I) = ',I8,A24) 3469 CALL DPWRST('XXX','BUG ') 3470 9015 CONTINUE 3471 DO9035I=1,IROW 3472 WRITE(ICOUT,9036)I,YTEMP(I) 3473 9036 FORMAT('I,YTEMP(I) = ',I8,E15.7) 3474 CALL DPWRST('XXX','BUG ') 3475 9035 CONTINUE 3476 ENDIF 3477C 3478 RETURN 3479 END 3480 SUBROUTINE CODEC3(YTEMP,IWRITE,IBUGA3,ISUBRO,IERROR) 3481C 3482C PURPOSE--THIS SUBROUTINE READS THE CHARCTER DATA STORED IN 3483C FILE "DPZCHF.DAT" AND CODES A SELECTED FIELD INTO 3484C A NUMERIC VARIABLE. THIS IMPLEMENTS THE 3485C "REFERENCE CHARACTER CODE" COMMAND. 3486C 3487C FOR THE "CODECH" ROUTINE (WHICH IMPLEMENTS THE 3488C "CHARACTER CODE" COMMAND"), EACH DISTINCT CHARACTER 3489C VARIABLE WILL BE ASSIGNED AN INTEGER CODE DETERMINED 3490C BY ORDER THAT THE FIRST OCCURENCE IS FOUND). 3491C 3492C THIS VARIANT IS SIMILAR. HOWEVER, INSTEAD OF BASING THE 3493C CODE BASED ON THE ORDER OF FIRST APPEARANCE, THE CODE 3494C WILL BE BASED ON A PREVIOUSLY DEFINED GROUP LABEL. THIS 3495C IS USEFUL WHEN, FOR EXAMPLE, READING SEVERAL SETS OF DATA 3496C THAT USE THE SAME CATEGORICAL VARIABLE AND WE WANT THE 3497C CODING TO BE CONSISTENT ACROSS THE DATA FILES. 3498C 3499C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR INTO WHICH 3500C THE CODED VALUES WILL BE PLACED. 3501C --N = THE INTEGER NUMBER OF OBSERVATIONS IN 3502C THE CHARACTER VARIABLE. 3503C OUTPUT--THE SINGLE PRECISION VECTOR Y WHICH WILL CONTAIN THE CODED 3504C VALUES CORRESPONDING TO THE OBSERVATIONS IN THE VECTOR X. 3505C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 3506C RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N FOR THIS SUBROUTINE 3507C IS MAXOBV. 3508C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 3509C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 3510C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 3511C LANGUAGE--ANSI FORTRAN (1977) 3512C REFERENCES--NONE. 3513C WRITTEN BY--ALAN HECKERT 3514C STATISTICAL ENGINEERING DIVISION 3515C INFORMATION TECHNOLOGY LABORATORY 3516C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 3517C GAITHERSBURG, MD 20899-8980 3518C PHONE--301-975-2899 3519C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 3520C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 3521C LANGUAGE--ANSI FORTRAN (1977) 3522C VERSION NUMBER--2018/06 3523C ORIGINAL VERSION--JUNE 2018. 3524C UPDATED --JUNE 2019. MOVE DIMENSION OF SCRATCH 3525C REAL ARRAY TO CALLING ROUTINE 3526C 3527C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 3528C 3529 DIMENSION YTEMP(*) 3530C 3531 CHARACTER*4 IWRITE 3532 CHARACTER*4 IBUGA3 3533 CHARACTER*4 ISUBRO 3534 CHARACTER*4 IERROR 3535C 3536 CHARACTER*4 ISTEPN 3537 CHARACTER*4 ISUBN1 3538 CHARACTER*4 ISUBN2 3539 CHARACTER*4 ICASEL 3540C 3541 CHARACTER*4 IH 3542 CHARACTER*4 IH2 3543 CHARACTER*4 IHLEFT 3544 CHARACTER*4 IHLEF2 3545 CHARACTER*4 IHRIGH 3546 CHARACTER*4 IHRIG2 3547 CHARACTER*4 IHRIG3 3548 CHARACTER*4 IHRIG4 3549C 3550C--------------------------------------------------------------------- 3551C 3552 INCLUDE 'DPCOPA.INC' 3553 INCLUDE 'DPCODA.INC' 3554 INCLUDE 'DPCOHK.INC' 3555 INCLUDE 'DPCOF2.INC' 3556 INCLUDE 'DPCOZC.INC' 3557C 3558CCCCC CHARACTER*80 IFILE 3559 CHARACTER (LEN=MAXFNC) :: IFILE 3560 CHARACTER*12 ISTAT 3561 CHARACTER*12 IFORM 3562 CHARACTER*12 IACCES 3563 CHARACTER*12 IPROT 3564 CHARACTER*12 ICURST 3565 CHARACTER*4 IENDFI 3566 CHARACTER*4 IREWIN 3567 CHARACTER*4 ISUBN0 3568 CHARACTER*4 IERRFI 3569C 3570 CHARACTER*500 IATEMP 3571 CHARACTER*20 IFRMT 3572 CHARACTER*24 IXTEMP(MAXOBV) 3573 EQUIVALENCE (CGARBG(1),IXTEMP(1)) 3574C 3575C--------------------------------------------------------------------- 3576C 3577 INCLUDE 'DPCOP2.INC' 3578C 3579C-----START POINT----------------------------------------------------- 3580C 3581 ISUBN1='CODE' 3582 ISUBN2='CH ' 3583 IERROR='NO' 3584C 3585 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3')THEN 3586 WRITE(ICOUT,999) 3587 999 FORMAT(1X) 3588 CALL DPWRST('XXX','BUG ') 3589 WRITE(ICOUT,51) 3590 51 FORMAT('***** AT THE BEGINNING OF CODEC3--') 3591 CALL DPWRST('XXX','BUG ') 3592 WRITE(ICOUT,52)IBUGA3,ISUBRO 3593 52 FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4) 3594 CALL DPWRST('XXX','BUG ') 3595 ENDIF 3596C 3597C ************************************************** 3598C ** STEP 1-- * 3599C ** EXAMINE THE LEFT-HAND SIDE-- * 3600C ** IS THE NAME NAME TO LEFT OF = SIGN * 3601C ** ALREADY IN THE NAME LIST? * 3602C ** NOTE THAT ILISTL IS THE LINE IN THE * 3603C ** TABLE OF THE NAME ON THE LEFT. * 3604C ************************************************** 3605C 3606 ISTEPN='1' 3607 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3') 3608 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3609C 3610 IHLEFT=IHARG(1) 3611 IHLEF2=IHARG2(1) 3612 DO100I=1,NUMNAM 3613 I2=I 3614 IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN 3615 ILISTL=I2 3616 GOTO110 3617 ENDIF 3618 100 CONTINUE 3619 ILISTL=NUMNAM+1 3620 IF(ILISTL.GT.MAXNAM)THEN 3621 WRITE(ICOUT,999) 3622 CALL DPWRST('XXX','BUG ') 3623 WRITE(ICOUT,111) 3624 111 FORMAT('***** ERROR IN REFERENCE CHARACTER CODE--') 3625 CALL DPWRST('XXX','BUG ') 3626 WRITE(ICOUT,112) 3627 112 FORMAT(' THE NUMBER OF VARIABLE, PARAMETER, AND FUNCTION') 3628 CALL DPWRST('XXX','BUG ') 3629 WRITE(ICOUT,113)MAXNAM 3630 113 FORMAT(' NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8) 3631 CALL DPWRST('XXX','BUG ') 3632 WRITE(ICOUT,114) 3633 114 FORMAT(' ENTER STATUS') 3634 CALL DPWRST('XXX','BUG ') 3635 WRITE(ICOUT,115) 3636 115 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES, AND') 3637 CALL DPWRST('XXX','BUG ') 3638 WRITE(ICOUT,116) 3639 116 FORMAT(' THEN DELETE SOME OF THE ALREADY-USED NAMES.') 3640 CALL DPWRST('XXX','BUG ') 3641 IERROR='YES' 3642 GOTO9000 3643 ENDIF 3644C 3645 110 CONTINUE 3646C 3647C ************************************************** 3648C ** STEP 2-- * 3649C ** EXAMINE THE RIGHT-HAND SIDE-- * 3650C ** IS THE SECOND NAME ON THE RIGHT HAND SIDE * 3651C ** A PREVIOUSLY DEFINED GROUP LABEL? * 3652C ************************************************** 3653C 3654 ISTEPN='1' 3655 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3') 3656 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3657C 3658 IHRIG3=IHARG(7) 3659 IHRIG4=IHARG2(7) 3660 DO200I=1,MAXGRP 3661 IF(IHRIG3.EQ.IGRPVN(I)(1:4).AND.IHRIG4.EQ.IGRPVN(I)(5:8))THEN 3662 IGRP=I 3663 GOTO210 3664 ENDIF 3665 200 CONTINUE 3666C 3667 WRITE(ICOUT,999) 3668 CALL DPWRST('XXX','BUG ') 3669 WRITE(ICOUT,111) 3670 CALL DPWRST('XXX','BUG ') 3671 WRITE(ICOUT,212)IHRIG3,IHRIG4 3672 212 FORMAT(' THE SPECIFIED GROUP (',2A4,') WAS NOT FOUND.') 3673 CALL DPWRST('XXX','BUG ') 3674 IERROR='YES' 3675 GOTO9000 3676C 3677 210 CONTINUE 3678C 3679 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3')THEN 3680 WRITE(ICOUT,221)IGRP 3681 221 FORMAT('AT 210: IGRP = ',I8) 3682 CALL DPWRST('XXX','BUG ') 3683 WRITE(ICOUT,51) 3684 ENDIF 3685C 3686C ***************************** 3687C ** COMPUTE CODED VALUES. ** 3688C ***************************** 3689C 3690C ******************************************** 3691C ** STEP 3-- ** 3692C ** OPEN THE DPZCHF.DAT FILE. ** 3693C ******************************************** 3694C 3695 ISTEPN='3' 3696 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3') 3697 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3698C 3699 IHRIGH=IHARG(6) 3700 IHRIG2=IHARG2(6) 3701C 3702 IOUNIT=IZCHNU 3703 IFILE=IZCHNA 3704 ISTAT=IZCHST 3705 IFORM=IZCHFO 3706 IACCES=IZCHAC 3707 IPROT=IZCHPR 3708 ICURST=IZCHCS 3709C 3710 ISUBN0='READ' 3711 IERRFI='NO' 3712 CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT, 3713 1 ICURST, 3714 1 IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR) 3715 IF(IERRFI.EQ.'YES')THEN 3716 IERROR='YES' 3717 WRITE(ICOUT,999) 3718 CALL DPWRST('XXX','BUG ') 3719 WRITE(ICOUT,111) 3720 CALL DPWRST('XXX','BUG ') 3721 WRITE(ICOUT,311) 3722 311 FORMAT(' UNABLE TO OPEN THE FILE CHARACTER DATA FILE:') 3723 CALL DPWRST('XXX','BUG ') 3724 WRITE(ICOUT,319)IFILE 3725 319 FORMAT(' ',A80) 3726 CALL DPWRST('XXX','BUG ') 3727 GOTO7000 3728 ENDIF 3729C 3730 READ(IOUNIT,'(I8)',END=371,ERR=371)NUMVAR 3731C 3732 IVAR=-1 3733 DO330I=1,NUMVAR 3734 READ(IOUNIT,'(A4,A4)',END=381,ERR=381)IH,IH2 3735 IF(IHRIGH.EQ.IH .AND. IHRIG2.EQ.IH2)THEN 3736 IVAR=I 3737 ENDIF 3738 330 CONTINUE 3739 IF(IVAR.GT.0)GOTO399 3740C 3741 WRITE(ICOUT,999) 3742 CALL DPWRST('XXX','BUG ') 3743 WRITE(ICOUT,111) 3744 CALL DPWRST('XXX','BUG ') 3745 WRITE(ICOUT,331)IHRIGH,IHRIG2 3746 331 FORMAT(' VARIABLE ',A4,A4,' NOT FOUND IN THE CHARACTER ', 3747 1 'DATA FILE:') 3748 CALL DPWRST('XXX','BUG ') 3749 WRITE(ICOUT,319)IFILE 3750 CALL DPWRST('XXX','BUG ') 3751 IERROR='YES' 3752 GOTO7000 3753C 3754 371 CONTINUE 3755 WRITE(ICOUT,999) 3756 CALL DPWRST('XXX','BUG ') 3757 WRITE(ICOUT,111) 3758 CALL DPWRST('XXX','BUG ') 3759 WRITE(ICOUT,373) 3760 373 FORMAT(' ERROR READING THE NUMBER OF CHARACTER VARIABLES ', 3761 1 'IN THE CHARACTER DATA FILE:') 3762 CALL DPWRST('XXX','BUG ') 3763 WRITE(ICOUT,319)IFILE 3764 CALL DPWRST('XXX','BUG ') 3765 IERROR='YES' 3766 GOTO7000 3767C 3768 381 CONTINUE 3769 WRITE(ICOUT,999) 3770 CALL DPWRST('XXX','BUG ') 3771 WRITE(ICOUT,111) 3772 CALL DPWRST('XXX','BUG ') 3773 WRITE(ICOUT,383) 3774 383 FORMAT(' ERROR READING THE VARIABLE NAMES ', 3775 1 'IN THE CHARACTER DATA FILE:') 3776 CALL DPWRST('XXX','BUG ') 3777 WRITE(ICOUT,319)IFILE 3778 CALL DPWRST('XXX','BUG ') 3779 IERROR='YES' 3780 GOTO7000 3781C 3782 399 CONTINUE 3783C 3784C ************************************************* 3785C ** STEP 4-- ** 3786C ** PERFORM THE CODING-- ** 3787C ** STORE UNIQUE VALUES IN IXTEMP, COMPARE ** 3788C ** TO LIST IN IXTEMP. ** 3789C ************************************************* 3790C 3791 ISTEPN='4' 3792 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3') 3793 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3794C 3795 IFRMT='(A )' 3796 WRITE(IFRMT(3:5),'(I3)')25*IVAR 3797 IFRST=(IVAR-1)*25 + 1 3798 ILAST=IVAR*25 - 1 3799C 3800 DO410I=1,MAXOBV 3801 IATEMP=' ' 3802 READ(IOUNIT,IFRMT,END=499,ERR=491)IATEMP 3803 IROW=I 3804 DO420J=1,MAXGLA 3805 IF(IATEMP(IFRST:ILAST).EQ.IGRPLA(J,IGRP)(1:24))THEN 3806 YTEMP(IROW)=REAL(J) 3807 GOTO419 3808 ENDIF 3809 420 CONTINUE 3810 YTEMP(IROW)=-1.0 3811C 3812 419 CONTINUE 3813 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3')THEN 3814 WRITE(ICOUT,421)I,IFRST,ILAST 3815 421 FORMAT('AT 419: I,IFRST,ILAST = ',3I8) 3816 CALL DPWRST('XXX','BUG ') 3817 WRITE(ICOUT,423)IATEMP(IFRST:ILAST) 3818 423 FORMAT('IATEMP(IFRST:ILAST) = ',A24) 3819 CALL DPWRST('XXX','BUG ') 3820 ENDIF 3821C 3822 410 CONTINUE 3823 GOTO499 3824C 3825 491 CONTINUE 3826 WRITE(ICOUT,999) 3827 CALL DPWRST('XXX','BUG ') 3828 WRITE(ICOUT,111) 3829 CALL DPWRST('XXX','BUG ') 3830 WRITE(ICOUT,493)IROW 3831 493 FORMAT(' ERROR READING ROW ',I8,' OF THE CHARACTER ', 3832 1 'VARIABLES IN THE CHARACTER DATA FILE:') 3833 CALL DPWRST('XXX','BUG ') 3834 WRITE(ICOUT,319)IFILE 3835 CALL DPWRST('XXX','BUG ') 3836 IERROR='YES' 3837 GOTO7000 3838C 3839C 3840C ****************************** 3841C ** STEP 5-- ** 3842C ** WRITE OUT A FEW LINES ** 3843C ** OF SUMMARY INFORMATION ** 3844C ** ABOUT THE CODING. ** 3845C ****************************** 3846C 3847 499 CONTINUE 3848C 3849 ISTEPN='5' 3850 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3') 3851 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3852C 3853 CALL MINIM(YTEMP,IROW,IWRITE,YMIN,IBUGA3,IERROR) 3854 CALL MAXIM(YTEMP,IROW,IWRITE,YMAX,IBUGA3,IERROR) 3855C 3856 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 3857 WRITE(ICOUT,999) 3858 CALL DPWRST('XXX','BUG ') 3859 WRITE(ICOUT,811)IHLEFT,IHLEF2,INT(YMIN) 3860 811 FORMAT('THE MINIMUM VALUE FOR ',2A4,' IS: ',I8) 3861 CALL DPWRST('XXX','BUG ') 3862 WRITE(ICOUT,813)IHLEFT,IHLEF2,INT(YMAX) 3863 813 FORMAT('THE MAXIMUM VALUE FOR ',2A4,' IS: ',I8) 3864 CALL DPWRST('XXX','BUG ') 3865 ENDIF 3866C 3867C ***************************************************** 3868C ** STEP 6-- ** 3869C ** ENTER THE CODED VALUES INTO THE DATAPLOT ** 3870C ** HOUSEKEEPING ARRAY ** 3871C ***************************************************** 3872C 3873 ISTEPN='6' 3874 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3') 3875 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3876C 3877 ICASEL='V' 3878 XINT=0.0 3879 IXINT=0 3880 CALL DPINVP(IHLEFT,IHLEF2,ICASEL,YTEMP,IROW,XINT,IXINT, 3881 1ISUBN1,ISUBN2,IBUGA3,IERROR) 3882C 3883C *************************************** 3884C ** STEP 7-- ** 3885C ** CLOSE THE DPZCHF.DAT FILE. ** 3886C *************************************** 3887C 3888 7000 CONTINUE 3889C 3890 ISTEPN='7' 3891 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3') 3892 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3893C 3894 IENDFI='OFF' 3895 IREWIN='ON' 3896 CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 3897 1 IENDFI,IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR) 3898 IZCHCS='CLOSED' 3899 GOTO9000 3900C 3901C ***************** 3902C ** STEP 90-- ** 3903C ** EXIT. ** 3904C ***************** 3905C 3906 9000 CONTINUE 3907C 3908 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEC3')THEN 3909 WRITE(ICOUT,999) 3910 CALL DPWRST('XXX','BUG ') 3911 WRITE(ICOUT,9011) 3912 9011 FORMAT('***** AT THE END OF CODEC3--') 3913 CALL DPWRST('XXX','BUG ') 3914 WRITE(ICOUT,9013)IERROR,N,IROW 3915 9013 FORMAT('IERROR,N,IROW = ',A4,2X,2I8) 3916 CALL DPWRST('XXX','BUG ') 3917 DO9035I=1,IROW 3918 WRITE(ICOUT,9036)I,YTEMP(I) 3919 9036 FORMAT('I,YTEMP(I) = ',I8,G15.7) 3920 CALL DPWRST('XXX','BUG ') 3921 9035 CONTINUE 3922 ENDIF 3923C 3924 RETURN 3925 END 3926 SUBROUTINE CODEDX(X,N,IWRITE,Y,XDIST,IBUGA3,ISUBRO,IERROR) 3927C 3928C PURPOSE--FOR CLASSIC 2-LEVEL FACTORIAL DESIGNS, IT IS CONVENIENT 3929C FOR EACH OF THE FACTOR VARIABLES TO LABEL THE LOW VALUE AS 3930C "-1" AND THE HIGH VALUE AS "+1". IN ADDITION, THERE MAY BE 3931C CENTER POINTS WHICH ARE CODED AS "0". IF THE FACTOR 3932C VARIABLE IS CODED IN THE ORIGINAL UNITS OF THE DATA, THIS 3933C ROUTINE CAN BE USED TO CONVERT IT TO THE "-1" AND "+1" 3934C CODING. 3935C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR 3936C OF OBSERVATIONS TO BE CODED. 3937C --N = THE INTEGER NUMBER OF OBSERVATIONS 3938C IN THE VECTOR X. 3939C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR 3940C INTO WHICH THE CODED VALUES 3941C WILL BE PLACED. 3942C OUTPUT--THE SINGLE PRECISION VECTOR Y WHICH WILL CONTAIN THE CODED 3943C VALUES CORRESPONDING TO THE OBSERVATIONS IN THE VECTOR X. 3944C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 3945C RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N FOR THIS SUBROUTINE 3946C IS 15000. 3947C OTHER DATAPAC SUBROUTINES NEEDED--DISTIN. 3948C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 3949C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 3950C LANGUAGE--ANSI FORTRAN (1977) 3951C COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. 3952C REFERENCES--NONE. 3953C WRITTEN BY--ALAN HECKERT 3954C STATISTICAL ENGINEERING DIVISION 3955C INFORMATION TECHNOLOGY LABORATORY 3956C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 3957C GAITHERSBURG, MD 20899 3958C PHONE--301-975-2899 3959C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 3960C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 3961C VERSION NUMBER--2018/01 3962C ORIGINAL VERSION--JANUARY 2018. 3963C 3964C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 3965C 3966 CHARACTER*4 IWRITE 3967 CHARACTER*4 IBUGA3 3968 CHARACTER*4 ISUBRO 3969 CHARACTER*4 IERROR 3970C 3971 CHARACTER*4 ISUBN1 3972 CHARACTER*4 ISUBN2 3973C 3974C--------------------------------------------------------------------- 3975C 3976 DIMENSION X(*) 3977 DIMENSION Y(*) 3978 DIMENSION XDIST(*) 3979C 3980C--------------------------------------------------------------------- 3981C 3982 INCLUDE 'DPCOP2.INC' 3983C 3984C-----START POINT----------------------------------------------------- 3985C 3986 ISUBN1='CODE' 3987 ISUBN2='DX ' 3988 IERROR='NO' 3989C 3990 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEDX')THEN 3991 WRITE(ICOUT,999) 3992 999 FORMAT(1X) 3993 CALL DPWRST('XXX','BUG ') 3994 WRITE(ICOUT,51) 3995 51 FORMAT('***** AT THE BEGINNING OF CODEDX--') 3996 CALL DPWRST('XXX','BUG ') 3997 WRITE(ICOUT,53)IBUGA3,ISUBRO,N 3998 53 FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8) 3999 CALL DPWRST('XXX','BUG ') 4000 DO55I=1,N 4001 WRITE(ICOUT,56)I,X(I) 4002 56 FORMAT('I,X(I) = ',I8,G15.7) 4003 CALL DPWRST('XXX','BUG ') 4004 55 CONTINUE 4005 ENDIF 4006C 4007C ***************************** 4008C ** COMPUTE CODED VALUES. ** 4009C ***************************** 4010C 4011C ******************************************** 4012C ** STEP 1-- ** 4013C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 4014C ******************************************** 4015C 4016 IF(N.LT.1)THEN 4017 WRITE(ICOUT,999) 4018 CALL DPWRST('XXX','BUG ') 4019 WRITE(ICOUT,111) 4020 111 FORMAT('***** ERROR IN CODEDX--') 4021 CALL DPWRST('XXX','BUG ') 4022 WRITE(ICOUT,113) 4023 113 FORMAT(' THE NUMBER OF OBSERVATIONS IN THE RESPONSE ', 4024 1 'VARIABLE IS LESS THAN 1.') 4025 CALL DPWRST('XXX','BUG ') 4026 WRITE(ICOUT,118)N 4027 118 FORMAT(' THE NUMBER OF OBSERVATIONS IS ',I10) 4028 CALL DPWRST('XXX','BUG ') 4029 IERROR='YES' 4030 GOTO9000 4031 ELSEIF(N.EQ.1)THEN 4032 Y(1)=1.0 4033 GOTO8000 4034 ENDIF 4035C 4036 HOLD=X(1) 4037 DO135I=2,N 4038 IF(X(I).NE.HOLD)GOTO139 4039 135 CONTINUE 4040 DO137I=1,N 4041 Y(I)=1.0 4042 137 CONTINUE 4043 GOTO8000 4044 139 CONTINUE 4045C 4046C ************************************************************* 4047C ** STEP 2-- ** 4048C ** PERFORM THE CODING-- ** 4049C ************************************************************* 4050C 4051 CALL DISTIN(X,N,IWRITE,XDIST,NDIST,IBUGA3,IERROR) 4052 CALL SORT(XDIST,NDIST,XDIST) 4053C 4054 IF(NDIST.EQ.1)THEN 4055 DO210I=1,N 4056 Y(I)=1.0 4057 210 CONTINUE 4058 ELSEIF(NDIST.EQ.2)THEN 4059 AVAL1=XDIST(1) 4060 AVAL2=XDIST(2) 4061 DO220I=1,N 4062 IF(X(I).EQ.AVAL1)THEN 4063 Y(I)=-1.0 4064 ELSE 4065 Y(I)=1.0 4066 ENDIF 4067 220 CONTINUE 4068 ELSEIF(NDIST.EQ.3)THEN 4069 AVAL1=XDIST(1) 4070 AVAL2=XDIST(2) 4071 AVAL3=XDIST(3) 4072 DO230I=1,N 4073 IF(X(I).EQ.AVAL1)THEN 4074 Y(I)=-1.0 4075 ELSEIF(X(I).EQ.AVAL3)THEN 4076 Y(I)=1.0 4077 ELSE 4078 Y(I)=0.0 4079 ENDIF 4080 230 CONTINUE 4081 ELSE 4082 WRITE(ICOUT,111) 4083 CALL DPWRST('XXX','BUG ') 4084 WRITE(ICOUT,241) 4085 241 FORMAT(' THE RESPONSE VARIABLE CONTAINS MORE THAN THREE ', 4086 1 'DISTINCT VALUES.') 4087 CALL DPWRST('XXX','BUG ') 4088 WRITE(ICOUT,243)NDIST 4089 243 FORMAT(' THE NUMBER OF DISTINCT VALUES DETECTED WAS ',I8) 4090 CALL DPWRST('XXX','BUG ') 4091 IERROR='YES' 4092 GOTO9000 4093 ENDIF 4094C 4095C ****************************** 4096C ** STEP 3-- ** 4097C ** WRITE OUT A FEW LINES ** 4098C ** OF SUMMARY INFORMATION ** 4099C ** ABOUT THE CODING. ** 4100C ****************************** 4101C 4102 8000 CONTINUE 4103C 4104 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 4105 WRITE(ICOUT,999) 4106 CALL DPWRST('XXX','BUG ') 4107 IF(NDIST.LE.2)THEN 4108 WRITE(ICOUT,8112) 4109 8112 FORMAT('THE RESPONSE VARIABLE HAS BEEN CODED AS ', 4110 1 '-1 AND +1 VALUES.') 4111 CALL DPWRST('XXX','BUG ') 4112 ELSE 4113 WRITE(ICOUT,8114) 4114 8114 FORMAT('THE RESPONSE VARIABLE HAS BEEN CODED AS ', 4115 1 '-1, 0, AND +1 VALUES.') 4116 CALL DPWRST('XXX','BUG ') 4117 ENDIF 4118 ENDIF 4119C 4120C ***************** 4121C ** STEP 90-- ** 4122C ** EXIT. ** 4123C ***************** 4124C 4125 9000 CONTINUE 4126C 4127 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEDX')THEN 4128 WRITE(ICOUT,999) 4129 CALL DPWRST('XXX','BUG ') 4130 WRITE(ICOUT,9011) 4131 9011 FORMAT('***** AT THE END OF CODEDX--') 4132 CALL DPWRST('XXX','BUG ') 4133 WRITE(ICOUT,9013)IERROR 4134 9013 FORMAT('IERROR = ',A4) 4135 CALL DPWRST('XXX','BUG ') 4136 DO9015I=1,N 4137 WRITE(ICOUT,9016)I,X(I),Y(I) 4138 9016 FORMAT('I,X(I),Y(I) = ',I8,G15.7,F7.0) 4139 CALL DPWRST('XXX','BUG ') 4140 9015 CONTINUE 4141 ENDIF 4142C 4143 RETURN 4144 END 4145 SUBROUTINE CODED2(X,N,IWRITE,Y,NOUT,XDIST,IBUGA3,ISUBRO,IERROR) 4146C 4147C PURPOSE--FOR CLASSIC 2-LEVEL FACTORIAL DESIGNS, IT IS CONVENIENT 4148C FOR EACH OF THE FACTOR VARIABLES TO LABEL THE LOW VALUE AS 4149C "-1" AND THE HIGH VALUE AS "+1". IN ADDITION, THERE MAY BE 4150C CENTER POINTS WHICH ARE CODED AS "0". IF THE FACTOR 4151C VARIABLE IS CODED IN THE ORIGINAL UNITS OF THE DATA, THIS 4152C ROUTINE CAN BE USED TO CONVERT IT TO THE "-1" AND "+1" 4153C CODING. 4154C 4155C THIS ROUTINE IS SIMILAR TO "CODEDX". THE DISTINCTION IS 4156C THAT THIS ROUTINE ONLY SAVES THE MINIMUM VALUE (AS -1) 4157C AND THE MAXIMUM VALUE (AS +1). ALL OTHER VALUES ARE 4158C DISCARDED. 4159C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR 4160C OF OBSERVATIONS TO BE CODED. 4161C --N = THE INTEGER NUMBER OF OBSERVATIONS 4162C IN THE VECTOR X. 4163C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR 4164C INTO WHICH THE CODED VALUES 4165C WILL BE PLACED. 4166C --NOUT = THE INTEGER NUMBER OF OBSERVATIONS 4167C THAT ARE SAVED IN Y (NOT NECCESSARILY 4168C EQUAL TO N). 4169C OUTPUT--THE SINGLE PRECISION VECTOR Y WHICH WILL CONTAIN THE CODED 4170C VALUES CORRESPONDING TO THE OBSERVATIONS IN THE VECTOR X. 4171C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 4172C RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N FOR THIS SUBROUTINE 4173C IS 15000. 4174C OTHER DATAPAC SUBROUTINES NEEDED--DISTIN. 4175C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 4176C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 4177C LANGUAGE--ANSI FORTRAN (1977) 4178C COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. 4179C REFERENCES--NONE. 4180C WRITTEN BY--ALAN HECKERT 4181C STATISTICAL ENGINEERING DIVISION 4182C INFORMATION TECHNOLOGY LABORATORY 4183C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 4184C GAITHERSBURG, MD 20899 4185C PHONE--301-975-2899 4186C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 4187C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 4188C VERSION NUMBER--2018/10 4189C ORIGINAL VERSION--OCTOBER 2018. 4190C 4191C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 4192C 4193 CHARACTER*4 IWRITE 4194 CHARACTER*4 IBUGA3 4195 CHARACTER*4 ISUBRO 4196 CHARACTER*4 IERROR 4197C 4198 CHARACTER*4 ISUBN1 4199 CHARACTER*4 ISUBN2 4200C 4201C--------------------------------------------------------------------- 4202C 4203 DIMENSION X(*) 4204 DIMENSION Y(*) 4205 DIMENSION XDIST(*) 4206C 4207C--------------------------------------------------------------------- 4208C 4209 INCLUDE 'DPCOP2.INC' 4210C 4211C-----START POINT----------------------------------------------------- 4212C 4213 ISUBN1='CODE' 4214 ISUBN2='D2 ' 4215 IERROR='NO' 4216C 4217 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DED2')THEN 4218 WRITE(ICOUT,999) 4219 999 FORMAT(1X) 4220 CALL DPWRST('XXX','BUG ') 4221 WRITE(ICOUT,51) 4222 51 FORMAT('***** AT THE BEGINNING OF CODED2--') 4223 CALL DPWRST('XXX','BUG ') 4224 WRITE(ICOUT,53)IBUGA3,ISUBRO,N 4225 53 FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8) 4226 CALL DPWRST('XXX','BUG ') 4227 DO55I=1,N 4228 WRITE(ICOUT,56)I,X(I) 4229 56 FORMAT('I,X(I) = ',I8,G15.7) 4230 CALL DPWRST('XXX','BUG ') 4231 55 CONTINUE 4232 ENDIF 4233C 4234C ***************************** 4235C ** COMPUTE CODED VALUES. ** 4236C ***************************** 4237C 4238C ******************************************** 4239C ** STEP 1-- ** 4240C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 4241C ******************************************** 4242C 4243 IF(N.LT.1)THEN 4244 WRITE(ICOUT,999) 4245 CALL DPWRST('XXX','BUG ') 4246 WRITE(ICOUT,111) 4247 111 FORMAT('***** ERROR IN CODED2--') 4248 CALL DPWRST('XXX','BUG ') 4249 WRITE(ICOUT,113) 4250 113 FORMAT(' THE NUMBER OF OBSERVATIONS IN THE RESPONSE ', 4251 1 'VARIABLE IS LESS THAN 1.') 4252 CALL DPWRST('XXX','BUG ') 4253 WRITE(ICOUT,118)N 4254 118 FORMAT(' THE NUMBER OF OBSERVATIONS IS ',I10) 4255 CALL DPWRST('XXX','BUG ') 4256 IERROR='YES' 4257 GOTO9000 4258 ELSEIF(N.EQ.1)THEN 4259 Y(1)=1.0 4260 NOUT=1 4261 GOTO8000 4262 ENDIF 4263C 4264 HOLD=X(1) 4265 DO135I=2,N 4266 IF(X(I).NE.HOLD)GOTO139 4267 135 CONTINUE 4268 DO137I=1,N 4269 Y(I)=1.0 4270 137 CONTINUE 4271 NOUT=N 4272 GOTO8000 4273 139 CONTINUE 4274C 4275C ************************************************************* 4276C ** STEP 2-- ** 4277C ** PERFORM THE CODING-- ** 4278C ************************************************************* 4279C 4280 CALL DISTIN(X,N,IWRITE,XDIST,NDIST,IBUGA3,IERROR) 4281 CALL SORT(XDIST,NDIST,XDIST) 4282C 4283 IF(NDIST.EQ.1)THEN 4284 DO210I=1,N 4285 Y(I)=1.0 4286 210 CONTINUE 4287 NOUT=N 4288 ELSEIF(NDIST.EQ.2)THEN 4289 AVAL1=XDIST(1) 4290 AVAL2=XDIST(2) 4291 DO220I=1,N 4292 IF(X(I).EQ.AVAL1)THEN 4293 Y(I)=-1.0 4294 ELSE 4295 Y(I)=1.0 4296 ENDIF 4297 220 CONTINUE 4298 NOUT=N 4299 ELSEIF(NDIST.GE.3)THEN 4300 AVAL1=XDIST(1) 4301 AVAL2=XDIST(NDIST) 4302 NOUT=0 4303 DO230I=1,N 4304 IF(X(I).EQ.AVAL1)THEN 4305 Y(I)=-1.0 4306 NOUT=NOUT+1 4307 ELSEIF(X(I).EQ.AVAL2)THEN 4308 Y(I)=1.0 4309 NOUT=NOUT+1 4310 ENDIF 4311 230 CONTINUE 4312 ENDIF 4313C 4314C ****************************** 4315C ** STEP 3-- ** 4316C ** WRITE OUT A FEW LINES ** 4317C ** OF SUMMARY INFORMATION ** 4318C ** ABOUT THE CODING. ** 4319C ****************************** 4320C 4321 8000 CONTINUE 4322C 4323 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 4324 WRITE(ICOUT,999) 4325 CALL DPWRST('XXX','BUG ') 4326 WRITE(ICOUT,8112) 4327 8112 FORMAT('THE RESPONSE VARIABLE HAS BEEN CODED AS ', 4328 1 '-1 AND +1 VALUES.') 4329 CALL DPWRST('XXX','BUG ') 4330 ENDIF 4331C 4332C ***************** 4333C ** STEP 90-- ** 4334C ** EXIT. ** 4335C ***************** 4336C 4337 9000 CONTINUE 4338C 4339 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DED2')THEN 4340 WRITE(ICOUT,999) 4341 CALL DPWRST('XXX','BUG ') 4342 WRITE(ICOUT,9011) 4343 9011 FORMAT('***** AT THE END OF CODED2--') 4344 CALL DPWRST('XXX','BUG ') 4345 WRITE(ICOUT,9013)IERROR,NOUT,NDIST 4346 9013 FORMAT('IERROR,NOUT,NDIST = ',A4,2X,2I8) 4347 CALL DPWRST('XXX','BUG ') 4348 DO9015I=1,NOUT 4349 WRITE(ICOUT,9016)I,Y(I) 4350 9016 FORMAT('I,Y(I) = ',I8,F7.0) 4351 CALL DPWRST('XXX','BUG ') 4352 9015 CONTINUE 4353 ENDIF 4354C 4355 RETURN 4356 END 4357 SUBROUTINE CODEH(X,N,NUMINT,IWRITE,Y,XS,MAXOBV,IBUGA3,IERROR) 4358C 4359C PURPOSE--THIS SUBROUTINE CODES THE ELEMENTS 4360C OF THE INPUT VECTOR X 4361C AND PUTS THE CODED VALUES INTO THE OUTPUT VECTOR Y. 4362C THE CODING IS AS FOLLOWS-- 4363C THE FIRST NUMINT'TH OF THE DATA IS CODED AS 1.0 4364C THE NEXT NUMINT'TH OF THE DATA IS CODED AS 2.0 4365C ETC. 4366C THE LAST NUMINT'TH OF THE DATA IS CODED AS NUMINT 4367C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR 4368C OF OBSERVATIONS TO BE CODED. 4369C --N = THE INTEGER NUMBER OF OBSERVATIONS 4370C IN THE VECTOR X. 4371C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR 4372C INTO WHICH THE CODED VALUES 4373C WILL BE PLACED. 4374C OUTPUT--THE SINGLE PRECISION VECTOR Y 4375C WHICH WILL CONTAIN THE CODED VALUES 4376C CORRESPONDING TO THE OBSERVATIONS IN 4377C THE VECTOR X. 4378C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 4379C RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N 4380C FOR THIS SUBROUTINE IS 15000. 4381C OTHER DATAPAC SUBROUTINES NEEDED--SORT. 4382C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 4383C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 4384C LANGUAGE--ANSI FORTRAN (1977) 4385C COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. 4386C REFERENCES--NONE. 4387C WRITTEN BY--JAMES J. FILLIBEN 4388C STATISTICAL ENGINEERING DIVISION 4389C INFORMATION TECHNOLOGY LABORATORY 4390C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 4391C GAITHERSBURG, MD 20899 4392C PHONE--301-975-2855 4393C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 4394C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 4395C VERSION NUMBER--82/7 4396C ORIGINAL VERSION--OCTOBER 1981. 4397C UPDATED --MAY 1982. 4398C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON 4399C 4400C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 4401C 4402 CHARACTER*4 IWRITE 4403 CHARACTER*4 IBUGA3 4404 CHARACTER*4 IERROR 4405C 4406 CHARACTER*4 ISUBN1 4407 CHARACTER*4 ISUBN2 4408C 4409C--------------------------------------------------------------------- 4410C 4411CCCCC INCLUDE 'DPCOPA.INC' 4412C 4413 DIMENSION X(*) 4414 DIMENSION Y(*) 4415 DIMENSION XS(MAXOBV) 4416CCCCC FOLLOWING LINES ADDED JUNE, 1990 4417CCCCC INCLUDE 'DPCOZ2.INC' 4418CCCCC EQUIVALENCE (G2RBAG(IGAR45),XS(1)) 4419CCCCC END CHANGE 4420C 4421C--------------------------------------------------------------------- 4422C 4423 INCLUDE 'DPCOP2.INC' 4424C 4425C-----START POINT----------------------------------------------------- 4426C 4427 ISUBN1='CODE' 4428 ISUBN2='N ' 4429C 4430 IERROR='NO' 4431 IUPPER=MAXOBV 4432C 4433 X50=0.0 4434C 4435 IF(IBUGA3.EQ.'OFF')GOTO90 4436 WRITE(ICOUT,999) 4437 999 FORMAT(1X) 4438 CALL DPWRST('XXX','BUG ') 4439 WRITE(ICOUT,51) 4440 51 FORMAT('***** AT THE BEGINNING OF CODEH--') 4441 CALL DPWRST('XXX','BUG ') 4442 WRITE(ICOUT,52)IBUGA3 4443 52 FORMAT('IBUGA3 = ',A4) 4444 CALL DPWRST('XXX','BUG ') 4445 WRITE(ICOUT,53)N,IUPPER,NUMINT 4446 53 FORMAT('N,IUPPER,NUMINT = ',3I8) 4447 CALL DPWRST('XXX','BUG ') 4448 DO55I=1,N 4449 WRITE(ICOUT,56)I,X(I) 4450 56 FORMAT('I,X(I) = ',I8,E15.7) 4451 CALL DPWRST('XXX','BUG ') 4452 55 CONTINUE 4453 90 CONTINUE 4454C 4455C ***************************** 4456C ** COMPUTE CODED VALUES. ** 4457C ***************************** 4458C 4459C ******************************************** 4460C ** STEP 1-- ** 4461C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 4462C ******************************************** 4463C 4464 IF(1.LE.N.AND.N.LE.IUPPER)GOTO119 4465 IERROR='YES' 4466 WRITE(ICOUT,999) 4467 CALL DPWRST('XXX','BUG ') 4468 WRITE(ICOUT,111)IUPPER 4469 111 FORMAT('***** ERROR IN CODEH--', 4470 1'THE SECOND INPUT ARGUMENT (N) IS SMALLER THAN 1', 4471 1'OR LARGER THAN ',I8) 4472 CALL DPWRST('XXX','BUG ') 4473 WRITE(ICOUT,118)N 4474 118 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 4475 CALL DPWRST('XXX','BUG ') 4476 GOTO9000 4477 119 CONTINUE 4478C 4479 IF(N.EQ.1)GOTO120 4480 GOTO129 4481 120 CONTINUE 4482CCCCC WRITE(ICOUT,999) 4483CCCCC CALL DPWRST('XXX','BUG ') 4484CCCCC WRITE(ICOUT,121) 4485CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN CODEH--', 4486CCCCC CALL DPWRST('XXX','BUG ') 4487CCCCC1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1') 4488 Y(1)=1.0 4489 GOTO9000 4490 129 CONTINUE 4491C 4492 HOLD=X(1) 4493 DO135I=2,N 4494 IF(X(I).NE.HOLD)GOTO139 4495 135 CONTINUE 4496CCCCC WRITE(ICOUT,999) 4497CCCCC CALL DPWRST('XXX','BUG ') 4498CCCCC WRITE(ICOUT,136)HOLD 4499CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN CODEH--', 4500CCCCC CALL DPWRST('XXX','BUG ') 4501CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) 4502 DO137I=1,N 4503 Y(I)=1.0 4504 137 CONTINUE 4505 GOTO9000 4506 139 CONTINUE 4507C 4508C ******************************************************* 4509C ** STEP 2-- ** 4510C ** PERFORM THE CODING-- ** 4511C ******************************************************* 4512C 4513 CALL SORT(X,N,XS) 4514C 4515 AN=N 4516C 4517 DO1410I=1,N 4518 Y(I)=4.0 4519 1410 CONTINUE 4520C 4521 N2=(N+1)/2 4522 IARG1=(N2+1)/2 4523 IARG2=(N2+1)-IARG1 4524 IARG1R=N-IARG1+1 4525 IARG2R=N-IARG2+1 4526 X75=(XS(IARG1R)+XS(IARG2R))/2.0 4527 XCUT=X75 4528 DO1420I=1,N 4529 IF(X(I).LE.XCUT)Y(I)=3.0 4530 1420 CONTINUE 4531C 4532 N50=N/2 4533 N50P1=N50+1 4534 IEVODD=N-2*(N/2) 4535 IF(IEVODD.EQ.0)X50=(XS(N50)+XS(N50P1))/2.0 4536 IF(IEVODD.EQ.1)X50=XS(N50P1) 4537 XCUT=X50 4538 DO1430I=1,N 4539 IF(X(I).LE.XCUT)Y(I)=2.0 4540 1430 CONTINUE 4541C 4542 N2=(N+1)/2 4543 IARG1=(N2+1)/2 4544 IARG2=(N2+1)-IARG1 4545 X25=(XS(IARG1)+XS(IARG2))/2.0 4546 XCUT=X25 4547 DO1440I=1,N 4548 IF(X(I).LE.XCUT)Y(I)=1.0 4549 1440 CONTINUE 4550C 4551C ****************************** 4552C ** STEP 3-- ** 4553C ** WRITE OUT A FEW LINES ** 4554C ** OF SUMMARY INFORMATION ** 4555C ** ABOUT THE CODING. ** 4556C ****************************** 4557C 4558 IF(IFEEDB.EQ.'OFF')GOTO8190 4559 IF(IWRITE.EQ.'OFF')GOTO8190 4560 WRITE(ICOUT,999) 4561 CALL DPWRST('XXX','BUG ') 4562 WRITE(ICOUT,8112)NUMINT 4563 8112 FORMAT('NUMBER OF CODE INTERVALS = ',I8) 4564 CALL DPWRST('XXX','BUG ') 4565 WRITE(ICOUT,999) 4566 CALL DPWRST('XXX','BUG ') 4567 AI=1 4568 WRITE(ICOUT,8114)XS(1),AI 4569 8114 FORMAT('THE MINIMUM (= ',E15.7,' ) HAS CODE VALUE ',F10.0) 4570 CALL DPWRST('XXX','BUG ') 4571 AI=NUMINT 4572 WRITE(ICOUT,8116)XS(N),AI 4573 8116 FORMAT('THE MAXIMUM (= ',E15.7,' ) HAS CODE VALUE ',F10.0) 4574 CALL DPWRST('XXX','BUG ') 4575 8190 CONTINUE 4576C 4577C ***************** 4578C ** STEP 90-- ** 4579C ** EXIT. ** 4580C ***************** 4581C 4582 9000 CONTINUE 4583C 4584 IF(IBUGA3.EQ.'OFF')GOTO9090 4585 WRITE(ICOUT,999) 4586 CALL DPWRST('XXX','BUG ') 4587 WRITE(ICOUT,9011) 4588 9011 FORMAT('***** AT THE END OF CODEH--') 4589 CALL DPWRST('XXX','BUG ') 4590 WRITE(ICOUT,9012)IBUGA3,IERROR 4591 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 4592 CALL DPWRST('XXX','BUG ') 4593 WRITE(ICOUT,9013)N,NUMINT 4594 9013 FORMAT('N,NUMINT = ',2I8) 4595 CALL DPWRST('XXX','BUG ') 4596 DO9015I=1,N 4597 WRITE(ICOUT,9016)I,X(I),Y(I) 4598 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) 4599 CALL DPWRST('XXX','BUG ') 4600 9015 CONTINUE 4601 9090 CONTINUE 4602C 4603 RETURN 4604 END 4605 SUBROUTINE CODEN(X,N,NUMINT,IWRITE,Y,XS,MAXOBV,IBUGA3,IERROR) 4606C 4607C PURPOSE--THIS SUBROUTINE CODES THE ELEMENTS 4608C OF THE INPUT VECTOR X 4609C AND PUTS THE CODED VALUES INTO THE OUTPUT VECTOR Y. 4610C THE CODING IS AS FOLLOWS-- 4611C THE FIRST NUMINT'TH OF THE DATA IS CODED AS 1.0 4612C THE NEXT NUMINT'TH OF THE DATA IS CODED AS 2.0 4613C ETC. 4614C THE LAST NUMINT'TH OF THE DATA IS CODED AS NUMINT 4615C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR 4616C OF OBSERVATIONS TO BE CODED. 4617C --N = THE INTEGER NUMBER OF OBSERVATIONS 4618C IN THE VECTOR X. 4619C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR 4620C INTO WHICH THE CODED VALUES 4621C WILL BE PLACED. 4622C OUTPUT--THE SINGLE PRECISION VECTOR Y 4623C WHICH WILL CONTAIN THE CODED VALUES 4624C CORRESPONDING TO THE OBSERVATIONS IN 4625C THE VECTOR X. 4626C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 4627C RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N 4628C FOR THIS SUBROUTINE IS 15000. 4629C OTHER DATAPAC SUBROUTINES NEEDED--SORT. 4630C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 4631C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 4632C LANGUAGE--ANSI FORTRAN (1977) 4633C COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. 4634C REFERENCES--NONE. 4635C WRITTEN BY--JAMES J. FILLIBEN 4636C STATISTICAL ENGINEERING DIVISION 4637C INFORMATION TECHNOLOGY LABORATORY 4638C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 4639C GAITHERSBURG, MD 20899 4640C PHONE--301-975-2855 4641C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 4642C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 4643C VERSION NUMBER--82/7 4644C ORIGINAL VERSION--OCTOBER 1981. 4645C UPDATED --MAY 1982. 4646C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON 4647C 4648C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 4649C 4650 CHARACTER*4 IWRITE 4651 CHARACTER*4 IBUGA3 4652 CHARACTER*4 IERROR 4653C 4654 CHARACTER*4 ISUBN1 4655 CHARACTER*4 ISUBN2 4656C 4657C--------------------------------------------------------------------- 4658C 4659 DIMENSION X(*) 4660 DIMENSION Y(*) 4661 DIMENSION XS(MAXOBV) 4662C 4663C--------------------------------------------------------------------- 4664C 4665 INCLUDE 'DPCOP2.INC' 4666C 4667C-----START POINT----------------------------------------------------- 4668C 4669 ISUBN1='CODE' 4670 ISUBN2='N ' 4671 IERROR='NO' 4672C 4673 IUPPER=MAXOBV 4674 XMED=0.0 4675C 4676 IF(IBUGA3.EQ.'ON')THEN 4677 WRITE(ICOUT,999) 4678 999 FORMAT(1X) 4679 CALL DPWRST('XXX','BUG ') 4680 WRITE(ICOUT,51) 4681 51 FORMAT('***** AT THE BEGINNING OF CODEN--') 4682 CALL DPWRST('XXX','BUG ') 4683 WRITE(ICOUT,53)IBUGA3,N,IUPPER,NUMINT 4684 53 FORMAT('IBUGA3,N,IUPPER,NUMINT = ',A4,2X,3I8) 4685 CALL DPWRST('XXX','BUG ') 4686 DO55I=1,N 4687 WRITE(ICOUT,56)I,X(I) 4688 56 FORMAT('I,X(I) = ',I8,G15.7) 4689 CALL DPWRST('XXX','BUG ') 4690 55 CONTINUE 4691 ENDIF 4692C 4693C ***************************** 4694C ** COMPUTE CODED VALUES. ** 4695C ***************************** 4696C 4697C ******************************************** 4698C ** STEP 1-- ** 4699C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 4700C ******************************************** 4701C 4702 IF(N.LT.1 .OR. N.GT.IUPPER)THEN 4703 IERROR='YES' 4704 WRITE(ICOUT,999) 4705 CALL DPWRST('XXX','BUG ') 4706 WRITE(ICOUT,111) 4707 111 FORMAT('***** ERROR IN CODEN--') 4708 CALL DPWRST('XXX','BUG ') 4709 WRITE(ICOUT,113) 4710 113 FORMAT(' THE NUMBER OF OBSERVATIONS IN THE RESPONSE ', 4711 1 'VARIABLE') 4712 CALL DPWRST('XXX','BUG ') 4713 WRITE(ICOUT,115)IUPPER 4714 115 FORMAT(' IS LESS THAN 1 OR GREATER THAN ',I10) 4715 CALL DPWRST('XXX','BUG ') 4716 WRITE(ICOUT,118)N 4717 118 FORMAT(' THE NUMBER OF OBSERVATIONS IS ',I10) 4718 CALL DPWRST('XXX','BUG ') 4719 GOTO9000 4720 ENDIF 4721C 4722 IF(N.EQ.1)THEN 4723 Y(1)=1.0 4724 GOTO9000 4725 ENDIF 4726C 4727 HOLD=X(1) 4728 DO135I=2,N 4729 IF(X(I).NE.HOLD)GOTO139 4730 135 CONTINUE 4731 DO137I=1,N 4732 Y(I)=1.0 4733 137 CONTINUE 4734 GOTO9000 4735 139 CONTINUE 4736C 4737C ************************************************************* 4738C ** STEP 2-- ** 4739C ** PERFORM THE CODING-- ** 4740C ************************************************************* 4741C 4742 CALL SORT(X,N,XS) 4743C 4744 AN=N 4745 IF(NUMINT.EQ.1)THEN 4746 DO1110I=1,N 4747 Y(I)=NUMINT 4748 1110 CONTINUE 4749 ELSEIF(NUMINT.GE.3)THEN 4750 DO1310I=1,N 4751 Y(I)=NUMINT 4752 1310 CONTINUE 4753 ANUMIN=NUMINT 4754 JMAX=NUMINT-1 4755 DO1320J=1,JMAX 4756 JREV=JMAX-J+1 4757 AJREV=JREV 4758 P=AJREV/ANUMIN 4759 AK=P*AN 4760 K1=INT(AK) 4761 K2=INT(AK+1.0) 4762 IF(K1.LE.1)K1=1 4763 IF(K1.GE.N)K1=N 4764 IF(K2.LE.1)K2=1 4765 IF(K2.GE.N)K2=N 4766 XCUT=(XS(K1)+XS(K2))/2.0 4767 DO1350I=1,N 4768 IF(X(I).LE.XCUT)Y(I)=JREV 4769 1350 CONTINUE 4770 1320 CONTINUE 4771 ELSE 4772 DO1210I=1,N 4773 Y(I)=NUMINT 4774 1210 CONTINUE 4775 N50=N/2 4776 N50P1=N50+1 4777 IEVODD=N-2*(N/2) 4778 IF(IEVODD.EQ.0)XMED=(XS(N50)+XS(N50P1))/2.0 4779 IF(IEVODD.EQ.1)XMED=XS(N50P1) 4780 XCUT=XMED 4781 DO1250I=1,N 4782 IF(X(I).LE.XCUT)Y(I)=1.0 4783 1250 CONTINUE 4784 ENDIF 4785C 4786C ****************************** 4787C ** STEP 3-- ** 4788C ** WRITE OUT A FEW LINES ** 4789C ** OF SUMMARY INFORMATION ** 4790C ** ABOUT THE CODING. ** 4791C ****************************** 4792C 4793 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 4794 WRITE(ICOUT,999) 4795 CALL DPWRST('XXX','BUG ') 4796 WRITE(ICOUT,8112)NUMINT 4797 8112 FORMAT('NUMBER OF CODE INTERVALS = ',I8) 4798 CALL DPWRST('XXX','BUG ') 4799 WRITE(ICOUT,999) 4800 CALL DPWRST('XXX','BUG ') 4801 AI=1 4802 WRITE(ICOUT,8114)XS(1),AI 4803 8114 FORMAT('THE MINIMUM (= ',E15.7,' ) HAS CODE VALUE ',F10.0) 4804 CALL DPWRST('XXX','BUG ') 4805 AI=NUMINT 4806 WRITE(ICOUT,8116)XS(N),AI 4807 8116 FORMAT('THE MAXIMUM (= ',E15.7,' ) HAS CODE VALUE ',F10.0) 4808 CALL DPWRST('XXX','BUG ') 4809 ENDIF 4810C 4811C ***************** 4812C ** STEP 90-- ** 4813C ** EXIT. ** 4814C ***************** 4815C 4816 9000 CONTINUE 4817C 4818 IF(IBUGA3.EQ.'ON')THEN 4819 WRITE(ICOUT,999) 4820 CALL DPWRST('XXX','BUG ') 4821 WRITE(ICOUT,9011) 4822 9011 FORMAT('***** AT THE END OF CODEN--') 4823 CALL DPWRST('XXX','BUG ') 4824 WRITE(ICOUT,9013)IERROR,N,NUMINT 4825 9013 FORMAT('IERROR,N,NUMINT = ',A4,2X,2I8) 4826 CALL DPWRST('XXX','BUG ') 4827 DO9015I=1,N 4828 WRITE(ICOUT,9016)I,X(I),Y(I) 4829 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) 4830 CALL DPWRST('XXX','BUG ') 4831 9015 CONTINUE 4832 ENDIF 4833C 4834 RETURN 4835 END 4836 SUBROUTINE CODEST(ISUBRO,IBUGA3,IERROR) 4837C 4838C PURPOSE--THIS SUBROUTINE READS THE CHARCTER DATA STORED IN 4839C FILE "DPZCHF.DAT" AND CODES A SELECTED FIELD INTO 4840C A STRING. THE LHS DEFINES THE BASE NAME FOR THE 4841C STRINGS. 4842C OUTPUT--THE CHARACTER STRINGS. 4843C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 4844C RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N 4845C FOR THIS SUBROUTINE IS MAXOBV. 4846C OTHER DATAPAC SUBROUTINES NEEDED--SORT. 4847C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 4848C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 4849C LANGUAGE--ANSI FORTRAN (1977) 4850C REFERENCES--NONE. 4851C WRITTEN BY--ALAN HECKERT 4852C STATISTICAL ENGINEERING DIVISION 4853C INFORMATION TECHNOLOGY LABORATORY 4854C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 4855C GAITHERSBURG, MD 20899-8980 4856C PHONE--301-975-2899 4857C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 4858C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 4859C LANGUAGE--ANSI FORTRAN (1977) 4860C VERSION NUMBER--2011/10 4861C ORIGINAL VERSION--OCTOBER 2011. 4862C UPDATED --MARCH 2015. CALL LIST TO DPINFU 4863C 4864C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 4865C 4866 CHARACTER*4 IBUGA3 4867 CHARACTER*4 ISUBRO 4868 CHARACTER*4 IERROR 4869C 4870 CHARACTER*4 ISTEPN 4871 CHARACTER*4 ISUBN1 4872 CHARACTER*4 ISUBN2 4873 CHARACTER*4 ICASEL 4874C 4875 CHARACTER*4 NEWNAM 4876 CHARACTER*4 NEWCOL 4877 CHARACTER*4 IH 4878 CHARACTER*4 IH2 4879 CHARACTER*8 ISTRIN 4880 CHARACTER*8 IHLEFT 4881 CHARACTER*4 IHLEF3 4882 CHARACTER*4 IHLEF4 4883 CHARACTER*4 IHRIGH 4884 CHARACTER*4 IHRIG2 4885C 4886 CHARACTER*4 ISTRZ2(24) 4887C 4888 CHARACTER*4 ISUBN0 4889C 4890C--------------------------------------------------------------------- 4891C 4892 INCLUDE 'DPCOPA.INC' 4893 INCLUDE 'DPCODA.INC' 4894 INCLUDE 'DPCOHK.INC' 4895 INCLUDE 'DPCOHO.INC' 4896 INCLUDE 'DPCOF2.INC' 4897 INCLUDE 'DPCOZC.INC' 4898C 4899CCCCC CHARACTER*80 IFILE 4900 CHARACTER (LEN=MAXFNC) :: IFILE 4901 CHARACTER*12 ISTAT 4902 CHARACTER*12 IFORM 4903 CHARACTER*12 IACCES 4904 CHARACTER*12 IPROT 4905 CHARACTER*12 ICURST 4906 CHARACTER*4 IENDFI 4907 CHARACTER*4 IREWIN 4908 CHARACTER*4 IERRFI 4909C 4910 CHARACTER*24 IATEMP 4911 CHARACTER*12 IFRMT 4912 CHARACTER*24 IXTEMP(9999) 4913 EQUIVALENCE (CGARBG(1),IXTEMP(1)) 4914C 4915C--------------------------------------------------------------------- 4916C 4917 INCLUDE 'DPCOP2.INC' 4918C 4919C-----START POINT----------------------------------------------------- 4920C 4921 ISUBN1='CODE' 4922 ISUBN2='ST ' 4923 IERROR='NO' 4924C 4925 NBASE=0 4926C 4927 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEST')THEN 4928 WRITE(ICOUT,999) 4929 999 FORMAT(1X) 4930 CALL DPWRST('XXX','BUG ') 4931 WRITE(ICOUT,51) 4932 51 FORMAT('***** AT THE BEGINNING OF CODEST--') 4933 CALL DPWRST('XXX','BUG ') 4934 WRITE(ICOUT,52)IBUGA3,ISUBRO 4935 52 FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4) 4936 CALL DPWRST('XXX','BUG ') 4937 ENDIF 4938C 4939C ******************************************** 4940C ** STEP 1-- ** 4941C ** OPEN THE DPZCHF.DAT FILE. ** 4942C ******************************************** 4943C 4944 ISTEPN='1' 4945 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DEST') 4946 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 4947C 4948 IHRIGH=IHARG(6) 4949 IHRIG2=IHARG2(6) 4950C 4951 IOUNIT=IZCHNU 4952 IFILE=IZCHNA 4953 ISTAT=IZCHST 4954 IFORM=IZCHFO 4955 IACCES=IZCHAC 4956 IPROT=IZCHPR 4957 ICURST=IZCHCS 4958C 4959 ISUBN0='READ' 4960 IERRFI='NO' 4961 CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT, 4962 1 ICURST, 4963 1 IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR) 4964 IF(IERRFI.EQ.'YES')THEN 4965 IERROR='YES' 4966 WRITE(ICOUT,999) 4967 CALL DPWRST('XXX','BUG ') 4968 WRITE(ICOUT,111) 4969 111 FORMAT('***** ERROR IN CHARACTER CODE STRING--') 4970 CALL DPWRST('XXX','BUG ') 4971 WRITE(ICOUT,118) 4972 118 FORMAT(' UNABLE TO OPEN THE FILE CHARACTER DATA FILE:') 4973 CALL DPWRST('XXX','BUG ') 4974 WRITE(ICOUT,119)IFILE 4975 119 FORMAT(' ',A80) 4976 CALL DPWRST('XXX','BUG ') 4977 GOTO8000 4978 ENDIF 4979C 4980 READ(IOUNIT,'(I8)',END=171,ERR=171)NUMVAR 4981C 4982 IVAR=-1 4983 DO130I=1,NUMVAR 4984 READ(IOUNIT,'(A4,A4)',END=181,ERR=181)IH,IH2 4985 IF(IHRIGH.EQ.IH .AND. IHRIG2.EQ.IH2)THEN 4986 IVAR=I 4987 ENDIF 4988 130 CONTINUE 4989 IF(IVAR.GT.0)GOTO199 4990C 4991 WRITE(ICOUT,999) 4992 CALL DPWRST('XXX','BUG ') 4993 WRITE(ICOUT,111) 4994 CALL DPWRST('XXX','BUG ') 4995 WRITE(ICOUT,131)IHRIGH,IHRIG2 4996 131 FORMAT('***** VARIABLE ',A4,A4,' NOT FOUND IN THE CHARACTER ', 4997 1 'DATA FILE:') 4998 CALL DPWRST('XXX','BUG ') 4999 WRITE(ICOUT,119)IFILE 5000 CALL DPWRST('XXX','BUG ') 5001 IERROR='YES' 5002 GOTO8000 5003C 5004 171 CONTINUE 5005 WRITE(ICOUT,999) 5006 CALL DPWRST('XXX','BUG ') 5007 WRITE(ICOUT,111) 5008 CALL DPWRST('XXX','BUG ') 5009 WRITE(ICOUT,173) 5010 173 FORMAT(' ERROR READING THE NUMBER OF CHARACTER VARIABLES ', 5011 1 'IN THE CHARACTER DATA FILE:') 5012 CALL DPWRST('XXX','BUG ') 5013 WRITE(ICOUT,119)IFILE 5014 CALL DPWRST('XXX','BUG ') 5015 IERROR='YES' 5016 GOTO8000 5017C 5018 181 CONTINUE 5019 WRITE(ICOUT,999) 5020 CALL DPWRST('XXX','BUG ') 5021 WRITE(ICOUT,111) 5022 CALL DPWRST('XXX','BUG ') 5023 WRITE(ICOUT,183) 5024 183 FORMAT(' ERROR READING THE VARIABLE NAMES ', 5025 1 'IN THE CHARACTER DATA FILE:') 5026 CALL DPWRST('XXX','BUG ') 5027 WRITE(ICOUT,119)IFILE 5028 CALL DPWRST('XXX','BUG ') 5029 IERROR='YES' 5030 GOTO8000 5031C 5032 199 CONTINUE 5033C 5034C ********************************** 5035C ** STEP 2-- ** 5036C ** DETERMINE NUMBER OF STRINGS ** 5037C ** TO CREATE ** 5038C ********************************** 5039C 5040 ISTEPN='2' 5041 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DEST') 5042 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5043C 5044 NSTR=NUMVAR 5045 IF(NSTR.GT.9999)NSTR=9999 5046C 5047C ************************************************* 5048C ** STEP 3-- ** 5049C ** EXTRACT THE BASE NAME ON THE LHS OF THE ** 5050C ** EQUAL SIGN AND THEN LOOP THROUGH THE ** 5051C ** NUMBER OF STRINGS TO CREATE. ** 5052C ************************************************* 5053C 5054 ISTEPN='3' 5055 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DEST') 5056 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5057C 5058 IHLEFT(1:4)=IHARG(1) 5059 IHLEFT(5:8)=IHARG2(1) 5060 NBASE=1 5061 DO310I=8,1,-1 5062 IF(IHLEFT(I:I).NE.' ')THEN 5063 NBASE=I 5064 GOTO319 5065 ENDIF 5066 310 CONTINUE 5067 319 CONTINUE 5068C 5069 IF(NSTR.LE.9)THEN 5070 IF(NBASE.GT.7)NBASE=7 5071 ELSEIF(NSTR.LE.99)THEN 5072 IF(NBASE.GT.6)NBASE=6 5073 ELSEIF(NSTR.LE.999)THEN 5074 IF(NBASE.GT.5)NBASE=5 5075 ELSE 5076 IF(NBASE.GT.4)NBASE=4 5077 ENDIF 5078C 5079 ISTEPN='4' 5080 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DEST') 5081 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5082C 5083 IF(IVAR.EQ.1)THEN 5084 IFRMT='(A24)' 5085 ELSE 5086 IFRMT='( X,A24)' 5087 WRITE(IFRMT(2:4),'(I3)')25*(IVAR-1) 5088 ENDIF 5089C 5090 N=0 5091 IROW=0 5092C 5093 DO410I=1,MAXOBV 5094C 5095 IATEMP=' ' 5096 READ(IOUNIT,IFRMT,END=499,ERR=491)IATEMP 5097 IROW=I 5098C 5099C CHECK TO SEE IF TEXT ON CURRENT ROW IS NEW OR 5100C HAS BEEN PREVIOUSLY ENTERED. 5101C 5102 INEW=1 5103 IF(N.GE.1)THEN 5104 DO420J=1,N 5105 IF(IATEMP(1:24).EQ.IXTEMP(J)(1:24))THEN 5106 INEW=0 5107 GOTO429 5108 ENDIF 5109 420 CONTINUE 5110 429 CONTINUE 5111 ENDIF 5112C 5113C ADD NEW STRING IF REQUIRED 5114C 5115 IF(INEW.EQ.0)GOTO410 5116 N=N+1 5117 IF(N.GT.9999)THEN 5118 WRITE(ICOUT,999) 5119 CALL DPWRST('XXX','BUG ') 5120 WRITE(ICOUT,111) 5121 CALL DPWRST('XXX','BUG ') 5122 WRITE(ICOUT,431) 5123 431 FORMAT(' ATTEMPT TO CREATE MORE THAN 9,999 STRINGS.') 5124 CALL DPWRST('XXX','BUG ') 5125 WRITE(ICOUT,433) 5126 433 FORMAT(' NO MORE STRINGS WILL BE GENERATED.') 5127 CALL DPWRST('XXX','BUG ') 5128 ELSE 5129 IXTEMP(N)=' ' 5130 IXTEMP(N)=IATEMP(1:24) 5131 ISTRIN=' ' 5132 ISTRIN(1:NBASE)=IHLEFT(1:NBASE) 5133 IF(N.LE.9)THEN 5134 WRITE(ISTRIN(NBASE+1:NBASE+1),'(I1)')N 5135 ELSEIF(N.LE.99)THEN 5136 WRITE(ISTRIN(NBASE+1:NBASE+2),'(I2)')N 5137 ELSEIF(N.LE.999)THEN 5138 WRITE(ISTRIN(NBASE+1:NBASE+3),'(I3)')N 5139 ELSE 5140 WRITE(ISTRIN(NBASE+1:NBASE+4),'(I4)')N 5141 ENDIF 5142C 5143 NEWNAM='NO' 5144 NEWCOL='NO' 5145 ICASEL='UNKN' 5146 NIOLD1=0 5147 ICOLL=0 5148C 5149 DO510II=1,NUMNAM 5150 I2=II 5151 IF(ISTRIN(1:4).EQ.IHNAME(I2).AND. 5152 1 ISTRIN(5:8).EQ.IHNAM2(I2))THEN 5153 IF(IUSE(I2).EQ.'F')THEN 5154 ICASEL='STRI' 5155 ILISTL=I2 5156 GOTO519 5157 ELSE 5158 WRITE(ICOUT,999) 5159 CALL DPWRST('XXX','BUG ') 5160 WRITE(ICOUT,111) 5161 CALL DPWRST('XXX','BUG ') 5162 WRITE(ICOUT,513)ISTRIN 5163 513 FORMAT(' THE NAME ',A8,' ALREADY EXISTS, BUT NOT ', 5164 1 'AS A STRING.') 5165 CALL DPWRST('XXX','BUG ') 5166 WRITE(ICOUT,515) 5167 515 FORMAT(' THIS STRING WILL NOT BE CREATED.') 5168 CALL DPWRST('XXX','BUG ') 5169 GOTO9000 5170 ENDIF 5171 ENDIF 5172 510 CONTINUE 5173 519 CONTINUE 5174C 5175 NEWNAM='YES' 5176 ICASEL='STRI' 5177C 5178 ILISTL=NUMNAM+1 5179 IF(ILISTL.GT.MAXNAM)THEN 5180 WRITE(ICOUT,999) 5181 CALL DPWRST('XXX','BUG ') 5182 WRITE(ICOUT,111) 5183 CALL DPWRST('XXX','BUG ') 5184 WRITE(ICOUT,522) 5185 522 FORMAT(' THE NUMBER OF VARIABLE, PARAMETER, AND ', 5186 1 'FUNCTION') 5187 CALL DPWRST('XXX','BUG ') 5188 WRITE(ICOUT,524)MAXNAM 5189 524 FORMAT(' NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8) 5190 CALL DPWRST('XXX','BUG ') 5191 IERROR='YES' 5192 GOTO9000 5193 ENDIF 5194C 5195C ***************************************************** 5196C ** STEP 6-- ** 5197C ** ADD THE CURRENT STRING ** 5198C ***************************************************** 5199C 5200 ISTEPN='6' 5201 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STGL') 5202 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5203C 5204 NCHAR=1 5205 DO605JJ=24,1,-1 5206 IF(IXTEMP(N)(JJ:JJ).NE.' ')THEN 5207 NCHAR=JJ 5208 GOTO609 5209 ENDIF 5210 605 CONTINUE 5211 609 CONTINUE 5212 IHLEF3=ISTRIN(1:4) 5213 IHLEF4=ISTRIN(5:8) 5214 DO611J=1,NCHAR 5215 ISTRZ2(J)=' ' 5216 ISTRZ2(J)(1:1)=IXTEMP(N)(J:J) 5217 611 CONTINUE 5218C 5219 CALL DPINFU(ISTRZ2,NCHAR,IHNAME,IHNAM2,IUSE,IN, 5220 1 IVSTAR,IVSTOP, 5221 1 NUMNAM,IANS,IWIDTH,IHLEF3,IHLEF4,ILISTL, 5222 1 NEWNAM,MAXNAM, 5223 1 IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR) 5224 IF(IERROR.EQ.'YES')GOTO9000 5225C 5226 ENDIF 5227C 5228 410 CONTINUE 5229 GOTO499 5230C 5231 491 CONTINUE 5232 WRITE(ICOUT,999) 5233 CALL DPWRST('XXX','BUG ') 5234 WRITE(ICOUT,111) 5235 CALL DPWRST('XXX','BUG ') 5236 WRITE(ICOUT,493)I 5237 493 FORMAT(' ERROR READING ROW ',I8,' OF THE CHARACTER ', 5238 1 'VARIABLES IN THE CHARACTER DATA FILE:') 5239 CALL DPWRST('XXX','BUG ') 5240 WRITE(ICOUT,119)IFILE 5241 CALL DPWRST('XXX','BUG ') 5242 IERROR='YES' 5243 GOTO8000 5244C 5245 499 CONTINUE 5246 GOTO8000 5247C 5248C *************************************** 5249C ** STEP 88-- ** 5250C ** CLOSE THE DPZCHF.DAT FILE. ** 5251C *************************************** 5252C 5253 8000 CONTINUE 5254C 5255 IENDFI='OFF' 5256 IREWIN='ON' 5257 CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 5258 1 IENDFI,IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR) 5259 IZCHCS='CLOSED' 5260 IF(IFEEDB.EQ.'ON')THEN 5261 WRITE(ICOUT,999) 5262 CALL DPWRST('XXX','BUG ') 5263 WRITE(ICOUT,8001)N,ISTRIN(1:NBASE) 5264 8001 FORMAT(' ',I5,' STRINGS CREATED WITH BASE NAME = ',A8) 5265 CALL DPWRST('XXX','BUG ') 5266 ENDIF 5267 GOTO9000 5268C 5269C ***************** 5270C ** STEP 90-- ** 5271C ** EXIT. ** 5272C ***************** 5273C 5274 9000 CONTINUE 5275C 5276 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DEST')THEN 5277 WRITE(ICOUT,999) 5278 CALL DPWRST('XXX','BUG ') 5279 WRITE(ICOUT,9011) 5280 9011 FORMAT('***** AT THE END OF CODEST--') 5281 CALL DPWRST('XXX','BUG ') 5282 WRITE(ICOUT,9012)IBUGA3,IERROR 5283 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 5284 CALL DPWRST('XXX','BUG ') 5285 WRITE(ICOUT,9013)N,IROW 5286 9013 FORMAT('N,IROW = ',I8) 5287 CALL DPWRST('XXX','BUG ') 5288 DO9015I=1,N 5289 WRITE(ICOUT,9016)I,IXTEMP(I) 5290 9016 FORMAT('I,IXTEMP(I) = ',I8,A24) 5291 CALL DPWRST('XXX','BUG ') 5292 9015 CONTINUE 5293 ENDIF 5294C 5295 RETURN 5296 END 5297 SUBROUTINE CODEX(X,N,IWRITE,Y,IBUGA3,ISUBRO,IERROR) 5298C 5299C PURPOSE--GIVEN DATA OF THE FORM 5300C 5301C 5302C 1 1 1 0 0 0 1 1 5303C 5304C WE WANT TO CREATE A CODED VARIABLE 5305C 5306C 1 1 1 0 0 0 2 2 5307C 5308C THAT IS, FOR EACH NON-ZERO CHUNK, WE WANT TO 5309C CREATE A COUNTER FOR EACH NON-ZERO BLOCK. 5310C 5311C THIS IS USED IN THE CONTEXT OF A TAG VARIABLE 5312C WHERE THE TAG IS SET TO 1 WHEN SOME CONDITION IS 5313C SATISFIED. HOWEVER, WE WANT TO UNIQUELY IDENTIFY 5314C EACH CONTIGUOUS CHUNK OF DATA THAT SATISFIES THE 5315C CONDITION. 5316C 5317C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR 5318C OF OBSERVATIONS TO BE CODED. 5319C --N = THE INTEGER NUMBER OF OBSERVATIONS 5320C IN THE VECTOR X. 5321C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR INTO WHICH 5322C THE CODED VALUES WILL BE PLACED. 5323C OUTPUT--THE SINGLE PRECISION VECTOR Y WHICH WILL CONTAIN THE CODED 5324C VALUES CORRESPONDING TO THE OBSERVATIONS IN THE VECTOR X. 5325C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 5326C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 5327C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 5328C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 5329C LANGUAGE--ANSI FORTRAN (1977) 5330C COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. 5331C REFERENCES--NONE. 5332C WRITTEN BY--ALAN HECKERT 5333C STATISTICAL ENGINEERING DIVISION 5334C INFORMATION TECHNOLOGY LABORATORY 5335C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 5336C GAITHERSBURG, MD 20899 5337C PHONE--301-975-2899 5338C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5339C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 5340C LANGUAGE--ANSI FORTRAN (1977) 5341C VERSION NUMBER--2017/07 5342C ORIGINAL VERSION--JULY 2017. 5343C 5344C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5345C 5346 CHARACTER*4 IWRITE 5347 CHARACTER*4 IBUGA3 5348 CHARACTER*4 ISUBRO 5349 CHARACTER*4 IERROR 5350C 5351 CHARACTER*4 ISUBN1 5352 CHARACTER*4 ISUBN2 5353C 5354C--------------------------------------------------------------------- 5355C 5356 DIMENSION X(*) 5357 DIMENSION Y(*) 5358C 5359C--------------------------------------------------------------------- 5360C 5361 INCLUDE 'DPCOP2.INC' 5362C 5363C-----START POINT----------------------------------------------------- 5364C 5365 ISUBN1='CODE' 5366 ISUBN2='X ' 5367 IERROR='NO' 5368C 5369 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ODEX')THEN 5370 WRITE(ICOUT,999) 5371 999 FORMAT(1X) 5372 CALL DPWRST('XXX','BUG ') 5373 WRITE(ICOUT,51) 5374 51 FORMAT('***** AT THE BEGINNING OF CODE--') 5375 CALL DPWRST('XXX','BUG ') 5376 WRITE(ICOUT,52)IBUGA3,ISUBRO,N 5377 52 FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8) 5378 CALL DPWRST('XXX','BUG ') 5379 DO55I=1,N 5380 WRITE(ICOUT,56)I,X(I) 5381 56 FORMAT('I,X(I) = ',I8,G15.7) 5382 CALL DPWRST('XXX','BUG ') 5383 55 CONTINUE 5384 ENDIF 5385C 5386C ***************************** 5387C ** COMPUTE CODED VALUES. ** 5388C ***************************** 5389C 5390C ******************************************** 5391C ** STEP 1-- ** 5392C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 5393C ******************************************** 5394C 5395 IF(N.LT.1)THEN 5396 WRITE(ICOUT,999) 5397 CALL DPWRST('XXX','BUG ') 5398 WRITE(ICOUT,111) 5399 111 FORMAT('***** ERROR IN CODEX--') 5400 CALL DPWRST('XXX','BUG ') 5401 WRITE(ICOUT,113)N 5402 113 FORMAT(' THE NUMBER OF OBSERVATIONS, ',I8,' IS LESS ', 5403 1 'THAN ONE.') 5404 CALL DPWRST('XXX','BUG ') 5405 IERROR='YES' 5406 GOTO9000 5407 ENDIF 5408C 5409C ***************************************************** 5410C ** STEP 2-- ** 5411C ** PERFORM THE CODING-- ** 5412C ***************************************************** 5413C 5414 ICNT=0 5415 IFLAG=0 5416 DO600I=1,N 5417 IF(X(I).EQ.0.0)THEN 5418 Y(I)=0.0 5419 IFLAG=0 5420 ELSE 5421 IF(IFLAG.EQ.0)THEN 5422 ICNT=ICNT+1 5423 Y(I)=REAL(ICNT) 5424 IFLAG=1 5425 ELSEIF(IFLAG.EQ.1)THEN 5426 Y(I)=REAL(ICNT) 5427 ENDIF 5428 ENDIF 5429 600 CONTINUE 5430C 5431C ****************************** 5432C ** STEP 3-- ** 5433C ** WRITE OUT A FEW LINES ** 5434C ** OF SUMMARY INFORMATION ** 5435C ** ABOUT THE CODING. ** 5436C ****************************** 5437C 5438 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 5439 WRITE(ICOUT,999) 5440 CALL DPWRST('XXX','BUG ') 5441 WRITE(ICOUT,812)X(1),Y(1) 5442 812 FORMAT('THE FIRST OUTPUT VALUE (= ',G15.7,' ) HAS CODE ', 5443 1 'VALUE ',F10.0) 5444 CALL DPWRST('XXX','BUG ') 5445 WRITE(ICOUT,814)X(N),Y(N) 5446 814 FORMAT('THE LAST OUTPUT VALUE (= ',G15.7,' ) HAS CODE ', 5447 1 'VALUE ',F10.0) 5448 CALL DPWRST('XXX','BUG ') 5449 ENDIF 5450C 5451C ***************** 5452C ** STEP 90-- ** 5453C ** EXIT. ** 5454C ***************** 5455C 5456 9000 CONTINUE 5457C 5458 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ODEX')THEN 5459 WRITE(ICOUT,999) 5460 CALL DPWRST('XXX','BUG ') 5461 WRITE(ICOUT,9011) 5462 9011 FORMAT('***** AT THE END OF CODEX--') 5463 CALL DPWRST('XXX','BUG ') 5464 WRITE(ICOUT,9012)IERROR 5465 9012 FORMAT('IERROR = ',A4) 5466 CALL DPWRST('XXX','BUG ') 5467 DO9015I=1,N 5468 WRITE(ICOUT,9016)I,X(I),Y(I) 5469 9016 FORMAT('I,X(I),Y(I) = ',I8,2G15.7) 5470 CALL DPWRST('XXX','BUG ') 5471 9015 CONTINUE 5472 ENDIF 5473C 5474 RETURN 5475 END 5476 SUBROUTINE CODEZ(X,N,IWRITE,Y,IBUGA3,ISUBRO,IERROR) 5477C 5478C PURPOSE--THIS SUBROUTINE IS SIMILAR TO THE CODE ROUTINE. 5479C HOWEVER, IT DIFFERS IN ONE KEY RESPECT. THE CODE 5480C ROUTINE CODES BASED ON THE DISTINCT VALUES REGARDLESS 5481C OF THE ORDER OF THE DATA. THIS ROUTINE CREATES THE 5482C CODE BASED ON WHEN THE INPUT VECTOR CHANGES VALUE. 5483C FOR EXAMPLE, IF X HAS 5484C 5485C 1 1 1 2 2 2 3 3 3 1 1 2 2 2 2 3 3 3 5486C 5487C THEN THE CODED VECTOR WILL BE 5488C 5489C 1 1 1 2 2 2 3 3 3 4 4 5 5 5 5 6 6 5490C 5491C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR 5492C OF OBSERVATIONS TO BE CODED. 5493C --N = THE INTEGER NUMBER OF OBSERVATIONS 5494C IN THE VECTOR X. 5495C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR INTO WHICH 5496C THE CODED VALUES WILL BE PLACED. 5497C OUTPUT--THE SINGLE PRECISION VECTOR Y WHICH WILL CONTAIN THE CODED 5498C VALUES CORRESPONDING TO THE OBSERVATIONS IN THE VECTOR X. 5499C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 5500C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 5501C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 5502C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 5503C LANGUAGE--ANSI FORTRAN (1977) 5504C COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. 5505C REFERENCES--NONE. 5506C WRITTEN BY--ALAN HECKERT 5507C STATISTICAL ENGINEERING DIVISION 5508C INFORMATION TECHNOLOGY LABORATORY 5509C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 5510C GAITHERSBURG, MD 20899 5511C PHONE--301-975-2899 5512C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5513C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 5514C LANGUAGE--ANSI FORTRAN (1977) 5515C VERSION NUMBER--2016/6 5516C ORIGINAL VERSION--JUNE 2016. 5517C 5518C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5519C 5520 CHARACTER*4 IWRITE 5521 CHARACTER*4 IBUGA3 5522 CHARACTER*4 ISUBRO 5523 CHARACTER*4 IERROR 5524C 5525 CHARACTER*4 ISUBN1 5526 CHARACTER*4 ISUBN2 5527C 5528C--------------------------------------------------------------------- 5529C 5530 DIMENSION X(*) 5531 DIMENSION Y(*) 5532C 5533C--------------------------------------------------------------------- 5534C 5535 INCLUDE 'DPCOP2.INC' 5536C 5537C-----START POINT----------------------------------------------------- 5538C 5539 ISUBN1='CODE' 5540 ISUBN2='Z ' 5541C 5542 IERROR='NO' 5543C 5544 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ODEZ')THEN 5545 WRITE(ICOUT,999) 5546 999 FORMAT(1X) 5547 CALL DPWRST('XXX','BUG ') 5548 WRITE(ICOUT,51) 5549 51 FORMAT('***** AT THE BEGINNING OF CODE--') 5550 CALL DPWRST('XXX','BUG ') 5551 WRITE(ICOUT,52)IBUGA3,ISUBRO,N 5552 52 FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8) 5553 CALL DPWRST('XXX','BUG ') 5554 DO55I=1,N 5555 WRITE(ICOUT,56)I,X(I) 5556 56 FORMAT('I,X(I) = ',I8,G15.7) 5557 CALL DPWRST('XXX','BUG ') 5558 55 CONTINUE 5559 ENDIF 5560C 5561C ***************************** 5562C ** COMPUTE CODED VALUES. ** 5563C ***************************** 5564C 5565C ******************************************** 5566C ** STEP 1-- ** 5567C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 5568C ******************************************** 5569C 5570 IF(N.LT.1)THEN 5571 WRITE(ICOUT,999) 5572 CALL DPWRST('XXX','BUG ') 5573 WRITE(ICOUT,111) 5574 111 FORMAT('***** ERROR IN CODEZ--') 5575 CALL DPWRST('XXX','BUG ') 5576 WRITE(ICOUT,113)N 5577 113 FORMAT(' THE NUMBER OF OBSERVATIONS, ',I8,' IS LESS ', 5578 1 'THAN ONE.') 5579 CALL DPWRST('XXX','BUG ') 5580 IERROR='YES' 5581 GOTO9000 5582 ENDIF 5583C 5584 IF(N.EQ.1)THEN 5585 Y(1)=1.0 5586 GOTO9000 5587 ENDIF 5588C 5589C 5590C ***************************************************** 5591C ** STEP 2-- ** 5592C ** PERFORM THE CODING-- ** 5593C ***************************************************** 5594C 5595 HOLD=X(1) 5596 ACODE=1.0 5597 Y(1)=ACODE 5598 DO600I=2,N 5599 IF(X(I).EQ.HOLD)THEN 5600 Y(I)=ACODE 5601 ELSE 5602 HOLD=X(I) 5603 ACODE=ACODE+1.0 5604 Y(I)=ACODE 5605 ENDIF 5606 600 CONTINUE 5607C 5608C ****************************** 5609C ** STEP 3-- ** 5610C ** WRITE OUT A FEW LINES ** 5611C ** OF SUMMARY INFORMATION ** 5612C ** ABOUT THE CODING. ** 5613C ****************************** 5614C 5615 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 5616 WRITE(ICOUT,999) 5617 CALL DPWRST('XXX','BUG ') 5618 WRITE(ICOUT,812)X(1),Y(1) 5619 812 FORMAT('THE FIRST OUTPUT VALUE (= ',G15.7,' ) HAS CODE ', 5620 1 'VALUE ',F10.0) 5621 CALL DPWRST('XXX','BUG ') 5622 WRITE(ICOUT,814)X(N),Y(N) 5623 814 FORMAT('THE LAST OUTPUT VALUE (= ',G15.7,' ) HAS CODE ', 5624 1 'VALUE ',F10.0) 5625 CALL DPWRST('XXX','BUG ') 5626 ENDIF 5627C 5628C ***************** 5629C ** STEP 90-- ** 5630C ** EXIT. ** 5631C ***************** 5632C 5633 9000 CONTINUE 5634C 5635 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ODEZ')THEN 5636 WRITE(ICOUT,999) 5637 CALL DPWRST('XXX','BUG ') 5638 WRITE(ICOUT,9011) 5639 9011 FORMAT('***** AT THE END OF CODEZ--') 5640 CALL DPWRST('XXX','BUG ') 5641 WRITE(ICOUT,9012)IERROR 5642 9012 FORMAT('IERROR = ',A4) 5643 CALL DPWRST('XXX','BUG ') 5644 DO9015I=1,N 5645 WRITE(ICOUT,9016)I,X(I),Y(I) 5646 9016 FORMAT('I,X(I),Y(I) = ',I8,2G15.7) 5647 CALL DPWRST('XXX','BUG ') 5648 9015 CONTINUE 5649 ENDIF 5650C 5651 RETURN 5652 END 5653 SUBROUTINE COENAM(IV1,IV2,IWORD1,IWORD2,IBUGCN,IERROR) 5654C 5655C PURPOSE--THIS SUBROUTINE CREATES A HOLLERITH COEFFICIENT NAME 5656C FROM THE 2 INPUT INTEGER VALUES IV1 AND IV2. 5657C IT ALSO AUTOMATICALLY PUTS THE LETTER A AS 5658C THE FIRST LETTER OF THE PARAMETER NAME. 5659C EXAMPLES-- 5660C INPUT--IV1 = 1 AND IV2 = 7 OUTPUT--A17 5661C INPUT--IV1 = 2 AND IV2 = 3 OUTPUT--A23 5662C INPUT--IV1 = 5 AND IV2 = 2 OUTPUT--A52 5663C NOTE--IF THE OUTPUT STRING HAPPENS TO CONSIST OF 5664C 1 TO 4 CHARACTERS, THEN CHARACTERS 1 TO 4 5665C WILL BE PLACED INTO THE FIRST HOLLERITH 5666C VARIABLE IWORD1. 5667C IF THE OUTPUT STRING HAPPENS TO CONSIST OF 5668C MORE THAN 4 CHARACTERS, THEN CHARACTERS 5 TO 8 5669C WILL BE PLACED INTO THE SECOND HOLLERITH 5670C VARIABLE IWORD2. 5671C IF THE OUTPUT STRING HAPPENS TO CONSIST OF 5672C MORE THAN 8 CHARACTERS, THEN CHARACTERS 9 ON UP 5673C WILL BE IGNORED. 5674C NOTE--IV1 AND IV2 ARE INTEGER VARIABLES. 5675C NOTE--IWORD1 IS A HOLLERITH VARIABLE. 5676C --IWORD2 IS A HOLLERITH VARIABLE. 5677C WRITTEN BY--JAMES J. FILLIBEN 5678C STATISTICAL ENGINEERING DIVISION 5679C INFORMATION TECHNOLOGY LABORATORY 5680C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 5681C GAITHERSBURG, MD 20899 5682C PHONE--301-975-2855 5683C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5684C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 5685C LANGUAGE--ANSI FORTRAN (1977) 5686C VERSION NUMBER--82/7 5687C ORIGINAL VERSION--DECEMBER 1978. 5688C UPDATED --MARCH 1981. 5689C UPDATED --NOVEMBER 1981. 5690C UPDATED --MARCH 1982. 5691C UPDATED --MAY 1982. 5692C 5693C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5694C 5695 CHARACTER*4 IWORD1 5696 CHARACTER*4 IWORD2 5697 CHARACTER*4 IBUGCN 5698 CHARACTER*4 IERROR 5699C 5700 CHARACTER*4 ISTRIT 5701 CHARACTER*4 ISTRIN 5702 CHARACTER*4 IWORD3 5703C 5704 CHARACTER*4 ISUBN1 5705 CHARACTER*4 ISUBN2 5706 CHARACTER*4 ISTEPN 5707C 5708C--------------------------------------------------------------------- 5709C 5710 DIMENSION ISTRIT(15) 5711 DIMENSION ISTRIN(30) 5712C 5713C--------------------------------------------------------------------- 5714C 5715 INCLUDE 'DPCOP2.INC' 5716C 5717C-----START POINT----------------------------------------------------- 5718C 5719 IERROR='NO' 5720C 5721 ISUBN1='COEN' 5722 ISUBN2='AM ' 5723C 5724 IF(IBUGCN.EQ.'OFF')GOTO90 5725 WRITE(ICOUT,999) 5726 999 FORMAT(1X) 5727 CALL DPWRST('XXX','BUG ') 5728 WRITE(ICOUT,51) 5729 51 FORMAT('***** AT THE BEGINNING OF COENAM--') 5730 CALL DPWRST('XXX','BUG ') 5731 WRITE(ICOUT,52)IV1,IV2 5732 52 FORMAT('IV1,IV2 = ',2I8) 5733 CALL DPWRST('XXX','BUG ') 5734 WRITE(ICOUT,53)IBUGCN 5735 53 FORMAT('IBUGCN = ',A4) 5736 CALL DPWRST('XXX','BUG ') 5737 90 CONTINUE 5738C 5739C ********************************** 5740C ** STEP 1-- ** 5741C ** DEFINE THE FIRST CHARACTER ** 5742C ** OF THE PARAMETER NAME ** 5743C ********************************** 5744C 5745 ISTEPN='1' 5746 IF(IBUGCN.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5747C 5748 K=0 5749 K=K+1 5750 ISTRIN(K)='A' 5751C 5752C ******************************************* 5753C ** STEP 2-- ** 5754C ** FORM THE STRING CONTAINING ** 5755C ** THE 1 CHARACTER PER WORD ** 5756C ** REPRESENTATION OF THE VALUE IN IV1. ** 5757C ******************************************* 5758C 5759 J=0 5760 ISTEPN='2' 5761 IF(IBUGCN.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5762C 5763 IREM=IV1 5764 DO100IPASS=1,10 5765 J=J+1 5766 IDIGIT=IREM-10*(IREM/10) 5767 IF(IDIGIT.EQ.0)ISTRIT(J)='0' 5768 IF(IDIGIT.EQ.1)ISTRIT(J)='1' 5769 IF(IDIGIT.EQ.2)ISTRIT(J)='2' 5770 IF(IDIGIT.EQ.3)ISTRIT(J)='3' 5771 IF(IDIGIT.EQ.4)ISTRIT(J)='4' 5772 IF(IDIGIT.EQ.5)ISTRIT(J)='5' 5773 IF(IDIGIT.EQ.6)ISTRIT(J)='6' 5774 IF(IDIGIT.EQ.7)ISTRIT(J)='7' 5775 IF(IDIGIT.EQ.8)ISTRIT(J)='8' 5776 IF(IDIGIT.EQ.9)ISTRIT(J)='9' 5777 IREM=IREM-IDIGIT 5778 IREM=IREM/10 5779 IF(IREM.LE.0)GOTO140 5780 100 CONTINUE 5781 140 CONTINUE 5782 N1=J 5783C 5784 DO150I=1,N1 5785 K=K+1 5786 IREV=N1-I+1 5787 ISTRIN(K)=ISTRIT(IREV) 5788 150 CONTINUE 5789C 5790C ******************************************* 5791C ** STEP 3-- ** 5792C ** FORM THE STRING CONTAINING ** 5793C ** THE 1 CHARACTER PER WORD ** 5794C ** REPRESENTATION OF THE VALUE IN IV2. ** 5795C ******************************************* 5796C 5797 ISTEPN='3' 5798 IF(IBUGCN.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5799C 5800 J=0 5801 IREM=IV2 5802 DO200IPASS=1,10 5803 J=J+1 5804 IDIGIT=IREM-10*(IREM/10) 5805 IF(IDIGIT.EQ.0)ISTRIT(J)='0' 5806 IF(IDIGIT.EQ.1)ISTRIT(J)='1' 5807 IF(IDIGIT.EQ.2)ISTRIT(J)='2' 5808 IF(IDIGIT.EQ.3)ISTRIT(J)='3' 5809 IF(IDIGIT.EQ.4)ISTRIT(J)='4' 5810 IF(IDIGIT.EQ.5)ISTRIT(J)='5' 5811 IF(IDIGIT.EQ.6)ISTRIT(J)='6' 5812 IF(IDIGIT.EQ.7)ISTRIT(J)='7' 5813 IF(IDIGIT.EQ.8)ISTRIT(J)='8' 5814 IF(IDIGIT.EQ.9)ISTRIT(J)='9' 5815 IREM=IREM-IDIGIT 5816 IREM=IREM/10 5817 IF(IREM.LE.0)GOTO240 5818 200 CONTINUE 5819 240 CONTINUE 5820 N2=J 5821C 5822 DO250I=1,N2 5823 K=K+1 5824 IREV=N2-I+1 5825 ISTRIN(K)=ISTRIT(IREV) 5826 250 CONTINUE 5827C 5828C ******************************************************* 5829C ** STEP 4-- ** 5830C ** CONVERT THE 1 CHARACTER PER WORD REPRESENTATION ** 5831C ** FOR THE PARAMETER NAME ** 5832C ** INTO A 4 CHARACTER PER WORD REPRESENTATION. ** 5833C ******************************************************* 5834C 5835 ISTEPN='4' 5836 IF(IBUGCN.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 5837C 5838 ISTART=1 5839 ISTOP=K 5840 CALL DP1H4H(ISTART,ISTOP,ISTRIN, 5841 1IWORD1,IWORD2,IWORD3,NUMWD,NUMCH,IBUGCN,IERROR) 5842C 5843C ***************** 5844C ** STEP 90-- ** 5845C ** EXIT ** 5846C ***************** 5847C 5848 IF(IBUGCN.EQ.'ON')THEN 5849 WRITE(ICOUT,999) 5850 CALL DPWRST('XXX','BUG ') 5851 WRITE(ICOUT,9011) 5852 9011 FORMAT('***** AT THE END OF COENAM--') 5853 CALL DPWRST('XXX','BUG ') 5854 WRITE(ICOUT,9012)IERROR 5855 9012 FORMAT('IERROR = ',A4) 5856 CALL DPWRST('XXX','BUG ') 5857 WRITE(ICOUT,9013)N1,N2,ISTART,ISTOP 5858 9013 FORMAT('N1,N2,ISTART,ISTOP = ',4I8) 5859 CALL DPWRST('XXX','BUG ') 5860 WRITE(ICOUT,9014)(ISTRIN(I),I=1,K) 5861 9014 FORMAT('ISTRIN(.) = ',80A1) 5862 CALL DPWRST('XXX','BUG ') 5863 WRITE(ICOUT,9015)NUMBPC,NUMCPW,NUMWD,NUMCH 5864 9015 FORMAT('NUMBPC,NUMCPW,NUMWD,NUMCH = ',4I8) 5865 CALL DPWRST('XXX','BUG ') 5866 WRITE(ICOUT,9017)IWORD1,IWORD2,IWORD3 5867 9017 FORMAT('IWORD1,IWORD2,IWORD3 = ',2(A4,2X),A4) 5868 CALL DPWRST('XXX','BUG ') 5869 ENDIF 5870C 5871 RETURN 5872 END 5873 SUBROUTINE COLLAP(NVAR, X, Y, LOCY, NX, NY, DIM, CONFIG) 5874C 5875C ALGORITHM AS 51.1 APPL. STATIST. (1972) VOL.21, P.218 5876C 5877C COMPUTES A MARGINAL TABLE FROM A COMPLETE TABLE. 5878C ALL PARAMETERS ARE ASSUMED VALID WITHOUT TEST. 5879C 5880C IF THE VALUE OF NVAR IS TO BE GREATER THAN 7, THE 5881C DIMENSIONS IN THE DECLARATIONS OF SIZE AND COORD MUST 5882C BE INCREASED TO NVAR+1 AND NVAR RESPECTIVELY. 5883C 5884 INTEGER SIZE(8), DIM(NVAR), CONFIG(NVAR), COORD(7) 5885C 5886C THE LARGER TABLE IS X AND THE SMALLER ONE IS Y 5887C 5888 REAL X(NX), Y(NY), ZERO 5889 DATA ZERO /0.0/ 5890C 5891C INITIALISE ARRAYS 5892C 5893 SIZE(1) = 1 5894 DO 10 K = 1, NVAR 5895 L = CONFIG(K) 5896 IF (L .EQ. 0) GOTO 20 5897 SIZE(K + 1) = SIZE(K) * DIM(L) 5898 10 CONTINUE 5899C 5900C FIND NUMBER OF VARIABLES IN CONFIGURATION 5901C 5902 K = NVAR + 1 5903 20 CONTINUE 5904 N = K - 1 5905C 5906C INITIALISE Y. FIRST CELL OF MARGINAL TABLE IS 5907C AT Y(LOCY) AND TABLE HAS SIZE(K) ELEMENTS 5908C 5909 LOCU = LOCY + SIZE(K) - 1 5910 DO 30 J = LOCY, LOCU 5911 Y(J) = ZERO 5912 30 CONTINUE 5913C 5914C INITIALISE COORDINATES 5915C 5916 DO 50 K = 1, NVAR 5917 COORD(K) = 0 5918 50 CONTINUE 5919C 5920C FIND LOCATIONS IN TABLES 5921C 5922 I = 1 5923 60 CONTINUE 5924 J = LOCY 5925 DO 70 K = 1, N 5926 L = CONFIG(K) 5927 J = J + COORD(L) * SIZE(K) 5928 70 CONTINUE 5929 Y(J) = Y(J) + X(I) 5930C 5931C UPDATE COORDINATES 5932C 5933 I = I + 1 5934 DO 80 K = 1, NVAR 5935 COORD(K) = COORD(K) + 1 5936 IF (COORD(K) .LT. DIM(K)) GOTO 60 5937 COORD(K) = 0 5938 80 CONTINUE 5939C 5940 RETURN 5941 END 5942 SUBROUTINE COMARI(Y1,Y2,Y3,Y4,N1,IACASE,IWRITE, 5943 1 Y5,Y6,N5,SCAL3,ITYP3, 5944 1 IBUGA3,ISUBRO,IERROR) 5945C 5946C PURPOSE--CARRY OUT COMPLEX ARITHMETIC OPERATIONS 5947C OF THE COMPLEX DATA IN Y1,Y2 AND Y3,Y4. 5948C 5949C OPERATIONS--ADDITION 5950C SUBTRACTTION 5951C MULTIPLICATION 5952C DIVISION 5953C EXPONENTIATION 5954C SQUARE ROOT 5955C ROOTS OF A POLYNOMIAL (WITH COMPLEX COEFFICIENTS) 5956C CONJUGATE 5957C 5958C INPUT ARGUMENTS--Y1 (REAL PART) Y2 (IMAGINARY PART) 5959C --Y3 (REAL PART) Y4 (IMAGINARY PART) 5960C OUTPUT ARGUMENTS--Y5 (REAL PART) Y6 (IMAGINARY PART) 5961C 5962C NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT VECTORS Y5(.) AND Y6(.) 5963C BEING IDENTICAL TO THE INPUT VECTORS Y1(.) AND Y2(.), OR 5964C Y3(.) AND Y4(.). 5965C WRITTEN BY--JAMES J. FILLIBEN 5966C STATISTICAL ENGINEERING DIVISION 5967C INFORMATION TECHNOLOGY LABORATORY 5968C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 5969C GAITHERSBURG, MD 20899 5970C PHONE--301-975-2855 5971C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5972C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 5973C LANGUAGE--ANSI FORTRAN (1977) 5974C VERSION NUMBER--87/5 5975C ORIGINAL VERSION--APRIL 1987. 5976C UPDATED --AUGUST 1987. COMPLEX SQUARE ROOT 5977C UPDATED --AUGUST 1987. COMPLEX ROOTS OF POLYNOMIAL 5978C UPDATED --SEPTEMBER 1987. COMPLEX CONJUGATE 5979C UPDATED --MAY 1995. EQUIVALENCE FOR ARRAYS 5980C UPDATED --AUGUST 1995. REPLACE NUMERICAL RECIPES 5981C ROUTINE FOR COMPLEX ROOTS 5982C WITH CMLIB ROUTINE 5983C UPDATED --JUNE 2019. DIMENSION COEFS, ROOTS, 5984C WORK, ERRBND 5985C 5986C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5987C 5988 CHARACTER*4 IACASE 5989 CHARACTER*4 IWRITE 5990 CHARACTER*4 ITYP3 5991 CHARACTER*4 IBUGA3 5992 CHARACTER*4 ISUBRO 5993 CHARACTER*4 IERROR 5994C 5995 CHARACTER*4 ISUBN1 5996 CHARACTER*4 ISUBN2 5997C 5998C-----COMPLEX STATEMENTS FOR NON-COMMON VARIABLES------------------- 5999C 6000 COMPLEX CY1Y2 6001 COMPLEX CTRANS 6002 COMPLEX COEFS 6003 COMPLEX ROOTS 6004CCCCC FOLLOWING LINES ADDED AUGUST 1995 6005 COMPLEX WORK 6006C 6007C-----DOUBLE PRECISION STATEMENTS FOR NON-COMMON VARIABLES------------------- 6008C 6009 DOUBLE PRECISION DY1 6010 DOUBLE PRECISION DY2 6011 DOUBLE PRECISION DY3 6012 DOUBLE PRECISION DY4 6013 DOUBLE PRECISION DY5 6014 DOUBLE PRECISION DY6 6015 DOUBLE PRECISION DDEN 6016 DOUBLE PRECISION DE 6017 DOUBLE PRECISION DC 6018 DOUBLE PRECISION DS 6019C 6020C-----LOGICAL STATEMENTS FOR NON-COMMON VARIABLES------------------- 6021C 6022CCCCC LOGICAL POLISH 6023C 6024C--------------------------------------------------------------------- 6025C 6026 INCLUDE 'DPCOPA.INC' 6027C 6028 DIMENSION Y1(*) 6029 DIMENSION Y2(*) 6030 DIMENSION Y3(*) 6031 DIMENSION Y4(*) 6032 DIMENSION Y5(*) 6033 DIMENSION Y6(*) 6034C 6035 DIMENSION COEFS(MAXOBV) 6036 DIMENSION ROOTS(MAXOBV) 6037 DIMENSION WORK(MAXOBV) 6038 DIMENSION ERRBND(MAXOBV) 6039 INCLUDE 'DPCOZZ.INC' 6040 EQUIVALENCE (GARBAG(JGAR15),COEFS(1)) 6041 EQUIVALENCE (GARBAG(JGAR17),ROOTS(1)) 6042 EQUIVALENCE (GARBAG(JGAR19),WORK(1)) 6043 EQUIVALENCE (GARBAG(IGAR10),ERRBND(1)) 6044C 6045C--------------------------------------------------------------------- 6046C 6047 INCLUDE 'DPCOP2.INC' 6048C 6049C-----START POINT----------------------------------------------------- 6050C 6051 ISUBN1='COMA' 6052 ISUBN2='RI ' 6053C 6054 IERROR='NO' 6055C 6056 SCAL3=(-999.0) 6057 ITYP3='VECT' 6058C 6059 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'MARI')GOTO90 6060 WRITE(ICOUT,999) 6061 999 FORMAT(1X) 6062 CALL DPWRST('XXX','BUG ') 6063 WRITE(ICOUT,51) 6064 51 FORMAT('***** AT THE BEGINNING OF COMARI--') 6065 CALL DPWRST('XXX','BUG ') 6066 WRITE(ICOUT,52)IBUGA3,ISUBRO,IACASE,IWRITE 6067 52 FORMAT('IBUGA3,ISUBRO,IACASE,IWRITE = ',A4,2X,A4,2X,A4,2X,A4) 6068 CALL DPWRST('XXX','BUG ') 6069 WRITE(ICOUT,53)N1 6070 53 FORMAT('N1 = ',I8) 6071 CALL DPWRST('XXX','BUG ') 6072 DO55I=1,N1 6073 WRITE(ICOUT,56)I,Y1(I),Y2(I),Y3(I),Y4(I) 6074 56 FORMAT('I,Y1(I),Y2(I),Y3(I),Y4(I) = ',I8,4E13.5) 6075 CALL DPWRST('XXX','BUG ') 6076 55 CONTINUE 6077 90 CONTINUE 6078C 6079C *********************************************** 6080C ** CARRY OUT COMPLEX ARITHMETIC OPERATIONS ** 6081C *********************************************** 6082C 6083C ******************************************** 6084C ** STEP 11-- ** 6085C ** CHECK NUMBER OF INPUT OBSERVATIONS. ** 6086C ******************************************** 6087C 6088 IF(N1.LT.1)GOTO1100 6089 GOTO1190 6090C 6091 1100 CONTINUE 6092 IERROR='YES' 6093 WRITE(ICOUT,999) 6094 CALL DPWRST('XXX','BUG ') 6095 WRITE(ICOUT,1151) 6096 1151 FORMAT('***** ERROR IN COMARI--') 6097 CALL DPWRST('XXX','BUG ') 6098 WRITE(ICOUT,1152) 6099 1152 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') 6100 CALL DPWRST('XXX','BUG ') 6101 WRITE(ICOUT,1153) 6102 1153 FORMAT(' IN THE VARIABLE FOR WHICH') 6103 CALL DPWRST('XXX','BUG ') 6104 IF(IACASE.EQ.'COAD')WRITE(ICOUT,1154) 6105 1154 FORMAT(' THE COMPLEX ADDITION IS TO BE ', 6106 1'COMPUTED') 6107 IF(IACASE.EQ.'COAD')CALL DPWRST('XXX','BUG ') 6108 IF(IACASE.EQ.'COSU')WRITE(ICOUT,1155) 6109 1155 FORMAT(' THE COMPLEX SUBTRACTION IS TO BE ', 6110 1'COMPUTED') 6111 IF(IACASE.EQ.'COSU')CALL DPWRST('XXX','BUG ') 6112 IF(IACASE.EQ.'COMU')WRITE(ICOUT,1156) 6113 1156 FORMAT(' THE COMPLEX MULTIPLICATION IS TO BE ', 6114 1'COMPUTED') 6115 IF(IACASE.EQ.'COMU')CALL DPWRST('XXX','BUG ') 6116 IF(IACASE.EQ.'CODI')WRITE(ICOUT,1157) 6117 1157 FORMAT(' THE COMPLEX DIVISION IS TO BE ', 6118 1'COMPUTED') 6119 IF(IACASE.EQ.'CODI')CALL DPWRST('XXX','BUG ') 6120 IF(IACASE.EQ.'COEX')WRITE(ICOUT,1158) 6121 1158 FORMAT(' THE COMPLEX EXPONENTIATION IS TO BE ', 6122 1'COMPUTED') 6123 IF(IACASE.EQ.'COEX')CALL DPWRST('XXX','BUG ') 6124 IF(IACASE.EQ.'COSR')WRITE(ICOUT,1159) 6125 1159 FORMAT(' THE COMPLEX SQUARE ROOT IS TO BE ', 6126 1'COMPUTED') 6127 IF(IACASE.EQ.'COSR')CALL DPWRST('XXX','BUG ') 6128 IF(IACASE.EQ.'CORO')WRITE(ICOUT,1160) 6129 1160 FORMAT(' THE COMPLEX ROOTS ARE TO BE ', 6130 1'COMPUTED') 6131 IF(IACASE.EQ.'CORO')CALL DPWRST('XXX','BUG ') 6132 IF(IACASE.EQ.'COR1')WRITE(ICOUT,1161) 6133 1161 FORMAT(' THE COMPLEX ROOTS ARE TO BE ', 6134 1'COMPUTED') 6135 IF(IACASE.EQ.'COR1')CALL DPWRST('XXX','BUG ') 6136 IF(IACASE.EQ.'COCO')WRITE(ICOUT,1162) 6137 1162 FORMAT(' THE COMPLEX CONJUGATE IS TO BE ', 6138 1'COMPUTED') 6139 IF(IACASE.EQ.'COCO')CALL DPWRST('XXX','BUG ') 6140 WRITE(ICOUT,1171) 6141 1171 FORMAT(' MUST BE 1 OR LARGER.') 6142 CALL DPWRST('XXX','BUG ') 6143 WRITE(ICOUT,1172) 6144 1172 FORMAT(' SUCH WAS NOT THE CASE HERE.') 6145 CALL DPWRST('XXX','BUG ') 6146 WRITE(ICOUT,1173)N1 6147 1173 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 6148 1'.') 6149 CALL DPWRST('XXX','BUG ') 6150 GOTO9000 6151C 6152 1190 CONTINUE 6153C 6154C ********************************* 6155C ** STEP 12-- ** 6156C ** BRANCH TO THE PROPER CASE ** 6157C ********************************* 6158C 6159 IF(IACASE.EQ.'COAD')GOTO2100 6160 IF(IACASE.EQ.'COSU')GOTO2200 6161 IF(IACASE.EQ.'COMU')GOTO2300 6162 IF(IACASE.EQ.'CODI')GOTO2400 6163 IF(IACASE.EQ.'COEX')GOTO2500 6164 IF(IACASE.EQ.'COSR')GOTO2600 6165 IF(IACASE.EQ.'CORO')GOTO2700 6166 IF(IACASE.EQ.'COR1')GOTO2700 6167 IF(IACASE.EQ.'COCO')GOTO2800 6168C 6169 WRITE(ICOUT,999) 6170 CALL DPWRST('XXX','BUG ') 6171 WRITE(ICOUT,1211) 6172 1211 FORMAT('***** INTERNAL ERROR IN COMARI--') 6173 CALL DPWRST('XXX','BUG ') 6174 WRITE(ICOUT,1212) 6175 1212 FORMAT(' IACASE NOT EQUAL TO') 6176 CALL DPWRST('XXX','BUG ') 6177 WRITE(ICOUT,1213) 6178 1213 FORMAT(' COAD, COSU, COMU, CODI,') 6179 CALL DPWRST('XXX','BUG ') 6180 WRITE(ICOUT,1214) 6181 1214 FORMAT(' COEX, COSR, CORO, COR1,') 6182 CALL DPWRST('XXX','BUG ') 6183 WRITE(ICOUT,1215) 6184 1215 FORMAT(' OR COCO') 6185 CALL DPWRST('XXX','BUG ') 6186 WRITE(ICOUT,1221) 6187 1221 FORMAT(' IACASE = ',A4) 6188 CALL DPWRST('XXX','BUG ') 6189 IERROR='YES' 6190 GOTO9000 6191C 6192C ********************************************* 6193C ** STEP 21-- ** 6194C ** TREAT THE COMPLEX ADDITION CASE ** 6195C ********************************************* 6196C 6197 2100 CONTINUE 6198 DO2110I=1,N1 6199 DY1=Y1(I) 6200 DY2=Y2(I) 6201 DY3=Y3(I) 6202 DY4=Y4(I) 6203 DY5=DY1+DY3 6204 DY6=DY2+DY4 6205 Y5(I)=DY5 6206 Y6(I)=DY6 6207 2110 CONTINUE 6208C 6209 ITYP3='VECT' 6210 N5=N1 6211 GOTO9000 6212C 6213C ********************************************* 6214C ** STEP 22-- ** 6215C ** TREAT THE COMPLEX SUBTRACTION CASE ** 6216C ********************************************* 6217C 6218 2200 CONTINUE 6219 DO2210I=1,N1 6220 DY1=Y1(I) 6221 DY2=Y2(I) 6222 DY3=Y3(I) 6223 DY4=Y4(I) 6224 DY5=DY1-DY3 6225 DY6=DY2-DY4 6226 Y5(I)=DY5 6227 Y6(I)=DY6 6228 2210 CONTINUE 6229C 6230 ITYP3='VECT' 6231 N5=N1 6232 GOTO9000 6233C 6234C ********************************************* 6235C ** STEP 23-- ** 6236C ** TREAT THE COMPLEX MULTIPLICATION CASE ** 6237C ********************************************* 6238C 6239 2300 CONTINUE 6240 DO2310I=1,N1 6241 DY1=Y1(I) 6242 DY2=Y2(I) 6243 DY3=Y3(I) 6244 DY4=Y4(I) 6245 DY5=DY1*DY3-DY2*DY4 6246 DY6=DY1*DY4+DY2*DY3 6247 Y5(I)=DY5 6248 Y6(I)=DY6 6249 2310 CONTINUE 6250C 6251 ITYP3='VECT' 6252 N5=N1 6253 GOTO9000 6254C 6255C ********************************************* 6256C ** STEP 24-- ** 6257C ** TREAT THE COMPLEX DIVISION CASE ** 6258C ********************************************* 6259C 6260 2400 CONTINUE 6261 DO2410I=1,N1 6262 DY1=Y1(I) 6263 DY2=Y2(I) 6264 DY3=Y3(I) 6265 DY4=Y4(I) 6266 DDEN=DY3**2+DY4**2 6267 IF(DDEN.NE.0.0D0)GOTO2419 6268 WRITE(ICOUT,999) 6269 CALL DPWRST('XXX','BUG ') 6270 WRITE(ICOUT,2411) 6271 2411 FORMAT('***** ERROR IN COMARI--') 6272 CALL DPWRST('XXX','BUG ') 6273 WRITE(ICOUT,2412) 6274 2412 FORMAT(' A ZERO DENOMINATOR WAS ENCOUNTERED') 6275 CALL DPWRST('XXX','BUG ') 6276 WRITE(ICOUT,2413) 6277 2413 FORMAT(' IN ATTEMPTING TO CARRY OUT') 6278 CALL DPWRST('XXX','BUG ') 6279 WRITE(ICOUT,2414) 6280 2414 FORMAT(' A COMPLEX DIVISION.') 6281 CALL DPWRST('XXX','BUG ') 6282 WRITE(ICOUT,2415)I 6283 2415 FORMAT(' THE ',I8,'TH ELEMENT OF THE') 6284 CALL DPWRST('XXX','BUG ') 6285 WRITE(ICOUT,2416) 6286 2416 FORMAT(' REAL AND IMAGINARY PARTS OF THE') 6287 CALL DPWRST('XXX','BUG ') 6288 WRITE(ICOUT,2417) 6289 2417 FORMAT(' COMPLEX DIVISOR ARE BOTH 0') 6290 CALL DPWRST('XXX','BUG ') 6291 WRITE(ICOUT,2418)I,Y3(I),Y4(I) 6292 2418 FORMAT('I,Y3(I),Y4(I) = ',I8,2E15.7) 6293 CALL DPWRST('XXX','BUG ') 6294 IERROR='YES' 6295 GOTO9000 6296 2419 CONTINUE 6297 DY5=(DY1*DY3+DY2*DY4)/DDEN 6298 DY6=(DY2*DY3-DY1*DY4)/DDEN 6299 Y5(I)=DY5 6300 Y6(I)=DY6 6301 2410 CONTINUE 6302C 6303 ITYP3='VECT' 6304 N5=N1 6305 GOTO9000 6306C 6307C ********************************************* 6308C ** STEP 25-- ** 6309C ** TREAT THE COMPLEX EXPONENTIATION CASE ** 6310C ********************************************* 6311C 6312 2500 CONTINUE 6313 DO2510I=1,N1 6314 DY1=Y1(I) 6315 DY2=Y2(I) 6316 DE=DEXP(DY1) 6317 DC=DCOS(DY2) 6318 DS=DSIN(DY2) 6319 DY5=DE*DC 6320 DY6=DE*DS 6321 Y5(I)=DY5 6322 Y6(I)=DY6 6323 2510 CONTINUE 6324C 6325 ITYP3='VECT' 6326 N5=N1 6327 GOTO9000 6328C 6329C ********************************************* 6330C ** STEP 26-- ** 6331C ** TREAT THE COMPLEX SQUARE ROOT CASE ** 6332C ********************************************* 6333C 6334 2600 CONTINUE 6335 DO2610I=1,N1 6336 CY1Y2=CMPLX(Y1(I),Y2(I)) 6337 CTRANS=CSQRT(CY1Y2) 6338 Y5(I)=REAL(CTRANS) 6339 Y6(I)=AIMAG(CTRANS) 6340 2610 CONTINUE 6341C 6342 ITYP3='VECT' 6343 N5=N1 6344 GOTO9000 6345C 6346C *********************************************** 6347C ** STEP 27-- ** 6348C ** TREAT THE COMPLEX ROOTS OF A POLYNOMIAL ** 6349C ** WITH COMPLEX COEFFICIENTS CASE ** 6350C *********************************************** 6351C 6352 2700 CONTINUE 6353 NCOEFS=N1 6354 NROOTS=NCOEFS-1 6355C 6356CCCCC AUGUST 1995. REPLACE NUMERICAL RECIPES ROUTINE WITH 6357CCCCC SLATEC ROUTINE. 6358CCCCC CPZERO EXPECTS COEFFICIENTS IN OPPOSIT ORDER OF ZROOTS. 6359CCCCC DO2710I=1,NCOEFS 6360CCCCC COEFS(I)=CMPLX(Y1(I),Y2(I)) 6361C2710 CONTINUE 6362 ICOUNT=0 6363 DO2710I=NCOEFS,1,-1 6364 ICOUNT=ICOUNT+1 6365 COEFS(ICOUNT)=CMPLX(Y1(I),Y2(I)) 6366 2710 CONTINUE 6367C 6368 IFLG=0 6369 CALL CPZERO(NROOTS,COEFS,ROOTS,WORK,IFLG,ERRBND) 6370 IF(IFLG.EQ.1)THEN 6371 WRITE(ICOUT,2721) 6372 2721 FORMAT('***** ERROR IN COMARI--LEADING COEFFICIENT IS ', 6373 1 'ZERO OR DEGREE IS ZERO') 6374 CALL DPWRST('XXX','BUG ') 6375 ELSEIF(IFLG.EQ.2)THEN 6376 WRITE(ICOUT,2726) 6377 2726 FORMAT('***** ERROR IN COMARI--ROOTS DID NOT CONVERGE.') 6378 CALL DPWRST('XXX','BUG ') 6379 ENDIF 6380CCCCC POLISH=.FALSE. 6381CCCCC CALL ZROOTS(COEFS,NROOTS,ROOTS,POLISH) 6382C 6383CCCCC DO2720I=1,NROOTS 6384CCCCC ROOTS(I)=ROOTS(I)*(1.0+0.01*I) 6385C2720 CONTINUE 6386C 6387CCCCC POLISH=.TRUE. 6388CCCCC CALL ZROOTS(COEFS,NROOTS,ROOTS,POLISH) 6389C 6390 DO2730I=1,NROOTS 6391 Y5(I)=REAL(ROOTS(I)) 6392 Y6(I)=AIMAG(ROOTS(I)) 6393 2730 CONTINUE 6394C 6395 ITYP3='VECT' 6396 N5=NROOTS 6397 GOTO9000 6398C 6399C ********************************************* 6400C ** STEP 28-- ** 6401C ** TREAT THE COMPLEX CONJUGATE CASE ** 6402C ********************************************* 6403C 6404 2800 CONTINUE 6405 DO2810I=1,N1 6406 Y5(I)=Y1(I) 6407 Y6(I)=(-Y2(I)) 6408 2810 CONTINUE 6409C 6410 ITYP3='VECT' 6411 N5=N1 6412 GOTO9000 6413C 6414C ***************** 6415C ** STEP 90-- ** 6416C ** EXIT. ** 6417C ***************** 6418C 6419 9000 CONTINUE 6420C 6421 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'MARI')GOTO9090 6422 WRITE(ICOUT,999) 6423 CALL DPWRST('XXX','BUG ') 6424 WRITE(ICOUT,9011) 6425 9011 FORMAT('***** AT THE END OF COMARI--') 6426 CALL DPWRST('XXX','BUG ') 6427 WRITE(ICOUT,9012)IBUGA3,ISUBRO,IACASE,IWRITE 6428 9012 FORMAT('IBUGA3,ISUBRO,IACASE,IWRITE = ',A4,2X,A4,2X,A4,2X,A4) 6429 CALL DPWRST('XXX','BUG ') 6430 WRITE(ICOUT,9013)IERROR 6431 9013 FORMAT('IERROR = ',A4) 6432 CALL DPWRST('XXX','BUG ') 6433 WRITE(ICOUT,9017)N1,N5 6434 9017 FORMAT('N1,N5 = ',2I8) 6435 CALL DPWRST('XXX','BUG ') 6436 WRITE(ICOUT,9018)SCAL3,ITYP3 6437 9018 FORMAT('SCAL3,ITYP3 = ',E15.7,2X,A4) 6438 CALL DPWRST('XXX','BUG ') 6439 IF(ITYP3.EQ.'SCAL')GOTO9090 6440 DO9015I=1,N1 6441 WRITE(ICOUT,9016)I,Y1(I),Y2(I),Y3(I),Y4(I),Y5(I),Y6(I) 6442 9016 FORMAT('I,Y1(I),Y2(I),Y3(I),Y4(I),Y5(I),Y6(I) = ',I8,6E13.5) 6443 CALL DPWRST('XXX','BUG ') 6444 9015 CONTINUE 6445 9090 CONTINUE 6446C 6447 RETURN 6448 END 6449 SUBROUTINE COMDIG(X,N,IWRITE,XDIGI,NDIGI,IBUGA3,IERROR) 6450C 6451C PURPOSE--THIS SUBROUTINE COMPUTES THE COMMON DIGITS FOR A 6452C VECTOR OF NUMBERS. FOR EXAMPLE, GIVEN 6453C 0.0321, 0.0323, 0.0329, 0.0325 6454C THE COMMON DIGITS ARE 0.03. NOTE THAT ONLY DIGITS 6455C TO THE RIGHT OF THE DECIMAL PLACE ARE CONSIDERED. 6456C THE FOLLOWING SPECIAL CASES ARE CONSIDERED: 6457C 1) IF THE FIRST DECIMAL DOES NOT AGREE, SET 6458C XDIGI=-1.0. 6459C 2) IF THE INTEGER PORTION OF THE NUMBER DOES 6460C NOT AGREE, THEN SET XDIGI=-1.0. 6461C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 6462C (UNSORTED OR SORTED) OBSERVATIONS. 6463C --N = THE INTEGER NUMBER OF OBSERVATIONS 6464C IN THE VECTOR X. 6465C OUTPUT ARGUMENTS--XDIGI = THE SINGLE PRECISION VALUE OF THE 6466C COMPUTED COMMON DIGITS 6467C --NDIGI = THE INTEGER VALUE OF THE 6468C NUMBER OF COMMON DIGITS 6469C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE 6470C COMMON DIGITS 6471C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 6472C OF N FOR THIS SUBROUTINE. 6473C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 6474C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 6475C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 6476C LANGUAGE--ANSI FORTRAN (1977) 6477C WRITTEN BY--ALAN HECKERT 6478C STATISTICAL ENGINEERING DIVISION 6479C INFORMATION TECHNOLOGY LABORATORY 6480C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 6481C GAITHERSBURG, MD 20899 6482C PHONE--301-975-2899 6483C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 6484C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 6485C LANGUAGE--ANSI FORTRAN (1977) 6486C VERSION NUMBER--2001.8 6487C ORIGINAL VERSION--AUGUST 2001. 6488C 6489 PARAMETER(MAXDIG=7) 6490C 6491C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 6492C 6493 CHARACTER*4 IWRITE 6494 CHARACTER*4 IBUGA3 6495 CHARACTER*4 IERROR 6496C 6497 CHARACTER*4 ISUBN1 6498 CHARACTER*4 ISUBN2 6499C 6500C--------------------------------------------------------------------- 6501C 6502 DIMENSION X(*) 6503 DIMENSION DIGITS(MAXDIG) 6504C 6505C--------------------------------------------------------------------- 6506C 6507 INCLUDE 'DPCOP2.INC' 6508C 6509C-----START POINT----------------------------------------------------- 6510C 6511 ISUBN1='COMD' 6512 ISUBN2='IG ' 6513C 6514 IERROR='NO' 6515C 6516 IF(IBUGA3.EQ.'OFF')GOTO90 6517 WRITE(ICOUT,999) 6518 999 FORMAT(1X) 6519 CALL DPWRST('XXX','BUG ') 6520 WRITE(ICOUT,51) 6521 51 FORMAT('***** AT THE BEGINNING OF COMDIG--') 6522 CALL DPWRST('XXX','BUG ') 6523 WRITE(ICOUT,52)IBUGA3 6524 52 FORMAT('IBUGA3 = ',A4) 6525 CALL DPWRST('XXX','BUG ') 6526 WRITE(ICOUT,53)N 6527 53 FORMAT('N = ',I8) 6528 CALL DPWRST('XXX','BUG ') 6529 DO55I=1,N 6530 WRITE(ICOUT,56)I,X(I) 6531 56 FORMAT('I,X(I) = ',I8,E15.7) 6532 CALL DPWRST('XXX','BUG ') 6533 55 CONTINUE 6534 90 CONTINUE 6535C 6536C ******************************************** 6537C ** STEP 1-- ** 6538C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 6539C ******************************************** 6540C 6541 AN=N 6542C 6543 IF(N.GE.2)GOTO119 6544 IERROR='YES' 6545 WRITE(ICOUT,999) 6546 CALL DPWRST('XXX','BUG ') 6547 WRITE(ICOUT,111) 6548 111 FORMAT('***** ERROR IN COMDIG--THE INPUT NUMBER OF OBSERVATIONS') 6549 CALL DPWRST('XXX','BUG ') 6550 WRITE(ICOUT,113) 6551 113 FORMAT(' IN THE VARIABLE FOR WHICH THE COMMON DIGITS ARE') 6552 CALL DPWRST('XXX','BUG ') 6553 WRITE(ICOUT,115) 6554 115 FORMAT(' TO BE COMPUTED MUST BE 2 OR LARGER.') 6555 CALL DPWRST('XXX','BUG ') 6556 WRITE(ICOUT,116) 6557 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') 6558 CALL DPWRST('XXX','BUG ') 6559 WRITE(ICOUT,117)N 6560 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,'.') 6561 CALL DPWRST('XXX','BUG ') 6562 GOTO9000 6563 119 CONTINUE 6564C 6565 HOLD=X(1) 6566 DO135I=2,N 6567 IF(X(I).NE.HOLD)GOTO139 6568 135 CONTINUE 6569 WRITE(ICOUT,999) 6570 CALL DPWRST('XXX','BUG ') 6571 WRITE(ICOUT,136)HOLD 6572 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN COMDIG--', 6573 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) 6574 CALL DPWRST('XXX','BUG ') 6575 XDIGI=ABS(HOLD)-REAL(INT(ABS(HOLD))) 6576 NDIGI=MAXDIG 6577 GOTO9000 6578 139 CONTINUE 6579C 6580C CHECK IF INTEGER PORTION OF NUMBERS MATCHES FOR ALL THE NUMBERS. 6581C 6582 IHOLD=INT(X(1)) 6583 DO145I=2,N 6584 IXTEMP=INT(X(I)) 6585 IF(IXTEMP.NE.IHOLD)THEN 6586 NDIG=-1 6587 XDIGI=0.0 6588 IF(IFEEDB.EQ.'OFF')GOTO149 6589 IF(IWRITE.EQ.'OFF')GOTO149 6590 WRITE(ICOUT,999) 6591 CALL DPWRST('XXX','BUG ') 6592 WRITE(ICOUT,146)N 6593 146 FORMAT('THE INTEGER PORTION OF THE ',I8,' OBSERVATIONS DOES ', 6594 1 'NOT MATCH.') 6595 CALL DPWRST('XXX','BUG ') 6596 149 CONTINUE 6597 GOTO800 6598 ENDIF 6599 145 CONTINUE 6600C 6601C ************************ 6602C ** STEP 2-- ** 6603C ** COMPUTE THE DIGITS** 6604C ************************ 6605C 6606 XDIGI=0.0 6607 NDIGI=0 6608C 6609 DO200L=1,MAXDIG 6610 ATEMP=X(1)*10**(L-1) 6611 ADIG=ABS(ATEMP) - INT(ABS(ATEMP)) 6612 IDIG=INT(ADIG*10) 6613 DO300I=2,N 6614 ATEMP=X(I)*10**(L-1) 6615 ADIG=ABS(ATEMP) - INT(ABS(ATEMP)) 6616 IDIG2=INT(ADIG*10) 6617 IF(IDIG.NE.IDIG2)GOTO209 6618 300 CONTINUE 6619 NDIGI=NDIGI+1 6620 DIGITS(NDIGI)=IDIG 6621 200 CONTINUE 6622 209 CONTINUE 6623C 6624 IF(NDIGI.GT.0)THEN 6625 XDIGI=REAL(INT(X(1)))*(10**NDIGI) 6626 DO400I=1,NDIGI 6627 ATEMP=DIGITS(I)*(10**(NDIGI-I)) 6628 XDIGI=XDIGI + ATEMP 6629 400 CONTINUE 6630 XDIGI=XDIGI/(10**NDIGI) 6631 ENDIF 6632C 6633C ******************************* 6634C ** STEP 3-- ** 6635C ** WRITE OUT A LINE ** 6636C ** OF SUMMARY INFORMATION. ** 6637C ******************************* 6638C 6639 800 CONTINUE 6640 IF(IFEEDB.EQ.'OFF')GOTO890 6641 IF(IWRITE.EQ.'OFF')GOTO890 6642 WRITE(ICOUT,999) 6643 CALL DPWRST('XXX','BUG ') 6644 WRITE(ICOUT,811)N,NDIGI 6645 811 FORMAT('THE NUMBER OF COMMON DIGITS FOR THE ',I8, 6646 1 ' OBSERVATIONS = ',I5) 6647 CALL DPWRST('XXX','BUG ') 6648 WRITE(ICOUT,813)XDIGI 6649 813 FORMAT('THE COMMON DIGITS = ',G15.7) 6650 CALL DPWRST('XXX','BUG ') 6651 890 CONTINUE 6652C 6653C ***************** 6654C ** STEP 90-- ** 6655C ** EXIT. ** 6656C ***************** 6657C 6658 9000 CONTINUE 6659 IF(IBUGA3.EQ.'OFF')GOTO9090 6660 WRITE(ICOUT,999) 6661 CALL DPWRST('XXX','BUG ') 6662 WRITE(ICOUT,9011) 6663 9011 FORMAT('***** AT THE END OF SUM--') 6664 CALL DPWRST('XXX','BUG ') 6665 WRITE(ICOUT,9012)IBUGA3,IERROR 6666 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 6667 CALL DPWRST('XXX','BUG ') 6668 WRITE(ICOUT,9013)N 6669 9013 FORMAT('N = ',I8) 6670 CALL DPWRST('XXX','BUG ') 6671 WRITE(ICOUT,9015)NDIGI,XDIGI 6672 9015 FORMAT('NDIGI,XDIGI = ',I8,E15.7) 6673 CALL DPWRST('XXX','BUG ') 6674 9090 CONTINUE 6675C 6676 RETURN 6677 END 6678 SUBROUTINE COMOVE(X,Y,N,IWRITE,XYCOMO,IBUGA3,IERROR) 6679C 6680C PURPOSE--THIS SUBROUTINE COMPUTES THE 6681C SAMPLE (LEIGH-PERLMAN) COMOVEMENT COEFFICIENT 6682C BETWEEN THE 2 SETS OF DATA IN THE INPUT VECTORS X AND Y. 6683C THE SAMPLE COMOVEMENT COEFFICIENT WILL BE A SINGLE 6684C PRECISION VALUE CALCULATED AS THE 6685C SUM OF CROSS PRODUCTS DIVIDED BY (N-1). 6686C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 6687C (UNSORTED) OBSERVATIONS 6688C WHICH CONSTITUTE THE FIRST SET 6689C OF DATA. 6690C --Y = THE SINGLE PRECISION VECTOR OF 6691C (UNSORTED) OBSERVATIONS 6692C WHICH CONSTITUTE THE SECOND SET 6693C OF DATA. 6694C --N = THE INTEGER NUMBER OF OBSERVATIONS 6695C IN THE VECTOR X, OR EQUIVALENTLY, 6696C THE INTEGER NUMBER OF OBSERVATIONS 6697C IN THE VECTOR Y. 6698C OUTPUT ARGUMENTS--XYCOMO = THE SINGLE PRECISION VALUE OF THE 6699C COMPUTED SAMPLE COMOVEMENT COEFFICIENT 6700C BETWEEN THE 2 SETS OF DATA 6701C IN THE INPUT VECTORS X AND Y. 6702C THIS SINGLE PRECISION VALUE 6703C WILL BE BETWEEN -1.0 AND 1.0 6704C (INCLUSIVELY). 6705C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE 6706C SAMPLE COMOVEMENT COEFFICIENT BETWEEN THE 2 SETS 6707C OF DATA IN THE INPUT VECTORS X AND Y. 6708C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 6709C OF N FOR THIS SUBROUTINE. 6710C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 6711C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. 6712C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 6713C LANGUAGE--ANSI FORTRAN (1977) 6714C REFERENCES--AN INDEX FOR COMOVEMENT OF TIME SEQUENCES 6715C WITH GEOPHYSICAL APPLICATIONS: A WORKING PAPER 6716C (PENN STATE INTERFACE CONFERANCE ON ASTRONOMY 6717C AUGUST 11-14, 1991) 6718C WRITTEN BY--JAMES J. FILLIBEN 6719C STATISTICAL ENGINEERING DIVISION 6720C INFORMATION TECHNOLOGY LABORATORY 6721C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 6722C GAITHERSBURG, MD 20899 6723C PHONE--301-975-2855 6724C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 6725C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 6726C LANGUAGE--ANSI FORTRAN (1966) 6727C VERSION NUMBER--92/8 6728C ORIGINAL VERSION--AUGUST 1991. 6729C 6730C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 6731C 6732 CHARACTER*4 IWRITE 6733 CHARACTER*4 IBUGA3 6734 CHARACTER*4 IERROR 6735C 6736 CHARACTER*4 ISUBN1 6737 CHARACTER*4 ISUBN2 6738C 6739C--------------------------------------------------------------------- 6740C 6741 DOUBLE PRECISION DN 6742 DOUBLE PRECISION DXI 6743 DOUBLE PRECISION DXIM1 6744 DOUBLE PRECISION DYI 6745 DOUBLE PRECISION DYIM1 6746 DOUBLE PRECISION DDELX 6747 DOUBLE PRECISION DDELY 6748 DOUBLE PRECISION DSUMX 6749 DOUBLE PRECISION DSUMY 6750 DOUBLE PRECISION DSUMXY 6751 DOUBLE PRECISION DSQRTX 6752 DOUBLE PRECISION DSQRTY 6753C 6754 DIMENSION X(*) 6755 DIMENSION Y(*) 6756C 6757C--------------------------------------------------------------------- 6758C 6759 INCLUDE 'DPCOP2.INC' 6760C 6761C-----START POINT----------------------------------------------------- 6762C 6763 ISUBN1='COMO' 6764 ISUBN2='VE ' 6765C 6766 IERROR='NO' 6767C 6768 DN=0.0D0 6769 DSUMX=0.0D0 6770 DSUMY=0.0D0 6771 DSUMXY=0.0D0 6772C 6773 IF(IBUGA3.EQ.'OFF')GOTO90 6774 WRITE(ICOUT,999) 6775 999 FORMAT(1X) 6776 CALL DPWRST('XXX','BUG ') 6777 WRITE(ICOUT,51) 6778 51 FORMAT('***** AT THE BEGINNING OF COMOVE--') 6779 CALL DPWRST('XXX','BUG ') 6780 WRITE(ICOUT,52)IBUGA3 6781 52 FORMAT('IBUGA3 = ',A4) 6782 CALL DPWRST('XXX','BUG ') 6783 WRITE(ICOUT,53)N 6784 53 FORMAT('N = ',I8) 6785 CALL DPWRST('XXX','BUG ') 6786 DO55I=1,N 6787 WRITE(ICOUT,56)I,X(I),Y(I) 6788 56 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) 6789 CALL DPWRST('XXX','BUG ') 6790 55 CONTINUE 6791 90 CONTINUE 6792C 6793C ******************************************* 6794C ** COMPUTE COMOVEMENT COEFFICIENT ** 6795C ******************************************* 6796C 6797C ******************************************** 6798C ** STEP 1-- ** 6799C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 6800C ******************************************** 6801C 6802 AN=N 6803C 6804 IF(N.GE.2)GOTO119 6805 IERROR='YES' 6806 WRITE(ICOUT,999) 6807 CALL DPWRST('XXX','BUG ') 6808 WRITE(ICOUT,111) 6809 111 FORMAT('***** ERROR IN COMOVE--') 6810 CALL DPWRST('XXX','BUG ') 6811 WRITE(ICOUT,112) 6812 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') 6813 CALL DPWRST('XXX','BUG ') 6814 WRITE(ICOUT,113) 6815 113 FORMAT(' IN THE VARIABLE FOR WHICH') 6816 CALL DPWRST('XXX','BUG ') 6817 WRITE(ICOUT,114) 6818 114 FORMAT(' THE COMOVEMENT COEFFICIENT IS TO BE') 6819 CALL DPWRST('XXX','BUG ') 6820 WRITE(ICOUT,115) 6821 115 FORMAT(' COMPUTED, MUST BE 2 OR LARGER.') 6822 CALL DPWRST('XXX','BUG ') 6823 WRITE(ICOUT,116) 6824 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') 6825 CALL DPWRST('XXX','BUG ') 6826 WRITE(ICOUT,117)N 6827 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 6828 1'.') 6829 CALL DPWRST('XXX','BUG ') 6830 GOTO9000 6831 119 CONTINUE 6832C 6833 IF(N.EQ.2)GOTO120 6834 GOTO129 6835 120 CONTINUE 6836 WRITE(ICOUT,999) 6837 CALL DPWRST('XXX','BUG ') 6838 WRITE(ICOUT,121) 6839 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN COMOVE--', 6840 1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 2') 6841 CALL DPWRST('XXX','BUG ') 6842 XYCOMO=1.0 6843 GOTO9000 6844 129 CONTINUE 6845C 6846 HOLD=X(1) 6847 DO135I=2,N 6848 IF(X(I).NE.HOLD)GOTO139 6849 135 CONTINUE 6850 WRITE(ICOUT,999) 6851 CALL DPWRST('XXX','BUG ') 6852 WRITE(ICOUT,136)HOLD 6853 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN COMOVE--', 6854 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) 6855 CALL DPWRST('XXX','BUG ') 6856 XYCOMO=1.0 6857 GOTO9000 6858 139 CONTINUE 6859C 6860 HOLD=Y(1) 6861 DO145I=2,N 6862 IF(Y(I).NE.HOLD)GOTO149 6863 145 CONTINUE 6864 WRITE(ICOUT,999) 6865 CALL DPWRST('XXX','BUG ') 6866 WRITE(ICOUT,146)HOLD 6867 146 FORMAT('***** NON-FATAL DIAGNOSTIC IN COMOVE--', 6868 1'THE SECOND INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) 6869 CALL DPWRST('XXX','BUG ') 6870 XYCOMO=1.0 6871 GOTO9000 6872 149 CONTINUE 6873C 6874C ************************************************ 6875C ** STEP 2-- ** 6876C ** COMPUTE THE COMOVEMENT COEFFICIENT. ** 6877C ************************************************ 6878C 6879 DN=N 6880 DSUMX=0.0D0 6881 DSUMY=0.0D0 6882 DSUMXY=0.0D0 6883 DO300I=2,N 6884 IM1=I-1 6885 DXI=X(I) 6886 DXIM1=X(IM1) 6887 DDELX=DXI-DXIM1 6888 DYI=Y(I) 6889 DYIM1=Y(IM1) 6890 DDELY=DYI-DYIM1 6891 DSUMX=DSUMX+DDELX**2 6892 DSUMY=DSUMY+DDELY**2 6893 DSUMXY=DSUMXY+DDELX*DDELY 6894 300 CONTINUE 6895 DSQRTX=0.0 6896 IF(DSUMX.GT.0.0D0)DSQRTX=DSQRT(DSUMX) 6897 DSQRTY=0.0 6898 IF(DSUMY.GT.0.0D0)DSQRTY=DSQRT(DSUMY) 6899 XYCOMO=DSUMXY/(DSQRTX*DSQRTY) 6900C 6901C ******************************* 6902C ** STEP 3-- ** 6903C ** WRITE OUT A LINE ** 6904C ** OF SUMMARY INFORMATION. ** 6905C ******************************* 6906C 6907 IF(IFEEDB.EQ.'OFF')GOTO890 6908 IF(IWRITE.EQ.'OFF')GOTO890 6909 WRITE(ICOUT,999) 6910 CALL DPWRST('XXX','BUG ') 6911 WRITE(ICOUT,811)N,XYCOMO 6912 811 FORMAT('THE LEIGH-PERLMAN COMOVEMENT COEF. OF THE ', 6913 1I8,' OBSERV. = ',E15.7) 6914 CALL DPWRST('XXX','BUG ') 6915 890 CONTINUE 6916C 6917C ***************** 6918C ** STEP 90-- ** 6919C ** EXIT. ** 6920C ***************** 6921C 6922 9000 CONTINUE 6923 IF(IBUGA3.EQ.'OFF')GOTO9090 6924 WRITE(ICOUT,999) 6925 CALL DPWRST('XXX','BUG ') 6926 WRITE(ICOUT,9011) 6927 9011 FORMAT('***** AT THE END OF COV--') 6928 CALL DPWRST('XXX','BUG ') 6929 WRITE(ICOUT,9012)IBUGA3,IERROR 6930 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 6931 CALL DPWRST('XXX','BUG ') 6932 WRITE(ICOUT,9013)N 6933 9013 FORMAT('N = ',I8) 6934 CALL DPWRST('XXX','BUG ') 6935 WRITE(ICOUT,9014)DN,DSUMX,DSUMY,DSUMXY 6936 9014 FORMAT('DN,DSUMX,DSUMY,DSUMXY = ',4D15.7) 6937 CALL DPWRST('XXX','BUG ') 6938 WRITE(ICOUT,9015)XYCOMO 6939 9015 FORMAT('XYCOMO = ',E15.7) 6940 CALL DPWRST('XXX','BUG ') 6941 9090 CONTINUE 6942C 6943 RETURN 6944 END 6945 SUBROUTINE COMPIC(IFUNC1,N1,IOLD,IOLD2,INEW,INEW2,NCHANG, 6946 1IFUNC2,N2,IBUGA3,IERROR) 6947C 6948C PURPOSE--SCAN THE FUNCTIONAL EXPRESSION GIVEN IN IFUNC1 6949C AND CHANGE ALL OCCURRANCES OF 6950C PARAMETER, VARIABLE, FUNCTION, AND 6951C NUMBERS GIVEN IN IOLD BY THE CORRESPONDING 6952C STRINGS GIVEN IN INEW. 6953C NOTE--IT IS ASSUMED THAT NAMES ARE 6954C ALREADY IN THE FORM OF A4--THAT IS 6955C INDIVIDUALLY PACKED PER WORD. 6956C NOTE--NUMBERS MAY NOT BE CHANGED. 6957C NOTE--PARAMETERS MAY BE CHANGED TO NUMBERS 6958C BUT ONLY THE FIRST 8 CHARACTERS OF THE NUMBER WILL 6959C BE TRANSFERRED. 6960C WRITTEN BY--JAMES J. FILLIBEN 6961C STATISTICAL ENGINEERING DIVISION 6962C INFORMATION TECHNOLOGY LABORATORY 6963C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 6964C GAITHERSBURG, MD 20899 6965C PHONE--301-975-2855 6966C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 6967C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 6968C LANGUAGE--ANSI FORTRAN (1977) 6969C VERSION NUMBER--82/7 6970C ORIGINAL VERSION--JANUARY 1979. 6971C UPDATED --FEBRUARY 1979. 6972C UPDATED --JULY 1981. 6973C UPDATED --MAY 1982. 6974C 6975C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 6976C 6977 CHARACTER*4 IFUNC1 6978 CHARACTER*4 IOLD 6979 CHARACTER*4 IOLD2 6980 CHARACTER*4 INEW 6981 CHARACTER*4 INEW2 6982 CHARACTER*4 IFUNC2 6983 CHARACTER*4 IBUGA3 6984 CHARACTER*4 IERROR 6985C 6986 CHARACTER*4 ISUBN1 6987 CHARACTER*4 ISUBN2 6988 CHARACTER*4 ISTEPN 6989C 6990 CHARACTER*4 ICH11 6991 CHARACTER*4 ICH12 6992 CHARACTER*4 ICH1 6993 CHARACTER*4 ICH21 6994 CHARACTER*4 ICH22 6995 CHARACTER*4 ICH2 6996 CHARACTER*4 ICASEP 6997 CHARACTER*4 ICASEA 6998 CHARACTER*4 IHALF1 6999 CHARACTER*4 IHALF2 7000C 7001C--------------------------------------------------------------------- 7002C 7003 DIMENSION IFUNC1(*) 7004 DIMENSION IFUNC2(*) 7005 DIMENSION IOLD(*) 7006 DIMENSION IOLD2(*) 7007 DIMENSION INEW(*) 7008 DIMENSION INEW2(*) 7009C 7010 DIMENSION ICH11(10) 7011 DIMENSION ICH12(10) 7012 DIMENSION ICH1(20) 7013 DIMENSION ICH21(10) 7014 DIMENSION ICH22(10) 7015 DIMENSION ICH2(20) 7016C 7017C--------------------------------------------------------------------- 7018C 7019 INCLUDE 'DPCOP2.INC' 7020C 7021C-----START POINT----------------------------------------------------- 7022C 7023 ISUBN1='COMP' 7024 ISUBN2='IC ' 7025C 7026 IERROR='NO' 7027C 7028 NUMASC=4 7029 NUMAS2=2*NUMASC 7030C 7031 IEND1=0 7032C 7033 IF(IBUGA3.EQ.'OFF')GOTO90 7034 WRITE(ICOUT,999) 7035 999 FORMAT(1X) 7036 CALL DPWRST('XXX','BUG ') 7037 WRITE(ICOUT,51) 7038 51 FORMAT('***** AT THE BEGINNING OF COMPIC--') 7039 CALL DPWRST('XXX','BUG ') 7040 WRITE(ICOUT,52)N1,IBUGA3 7041 52 FORMAT('N1,IBUGA3 = ',I8,2X,A4) 7042 CALL DPWRST('XXX','BUG ') 7043 WRITE(ICOUT,53)(IFUNC1(I),I=1,N1) 7044 53 FORMAT('IFUNC1(.)=',30A4) 7045 CALL DPWRST('XXX','BUG ') 7046 WRITE(ICOUT,54)NCHANG 7047 54 FORMAT('NCHANG = ',I8) 7048 CALL DPWRST('XXX','BUG ') 7049 DO55I=1,NCHANG 7050 WRITE(ICOUT,56)I,IOLD(I),IOLD2(I),INEW(I),INEW2(I) 7051 56 FORMAT('I,IOLD(I),IOLD2(I),INEW(I),INEW2(I) = ', 7052 1I8,2X,A4,A4,2X,A4,A4) 7053 CALL DPWRST('XXX','BUG ') 7054 55 CONTINUE 7055 90 CONTINUE 7056C 7057C ******************************************** 7058C ** STEP 1-- ** 7059C ** COPY THE INPUT FUNCTION IN IFUNC1(.) ** 7060C ** INTO THE OUTPUT VECTOR IFUNC2(.). ** 7061C ******************************************** 7062C 7063 ISTEPN='1' 7064 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7065C 7066 IF(N1.LE.0)GOTO190 7067 DO80I=1,N1 7068 IFUNC2(I)=IFUNC1(I) 7069 80 CONTINUE 7070 N2=N1 7071C 7072C ***************************************** 7073C ** STEP 2-- ** 7074C ** LOOP THROUGH THE INPUT FUNCTION-- ** 7075C ** 1 CHARACTER (USUALLY) AT A TIME. ** 7076C ***************************************** 7077C 7078 ISTEPN='2' 7079 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7080C 7081 I=0 7082 100 CONTINUE 7083 I=I+1 7084 IF(I.GT.N2)GOTO190 7085 IF(NCHANG.LE.0)GOTO190 7086C 7087C ****************************************** 7088C ** STEP 3-- ** 7089C ** FOR THIS CHARACTER (CHARACTER I), ** 7090C ** SCAN THROUGH ALL POTENTIAL CHANGES ** 7091C ** TO BE MADE. ** 7092C ****************************************** 7093C 7094 ISTEPN='3' 7095 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7096C 7097 DO200J=1,NCHANG 7098 CALL DPXH1H(IOLD(J),ICH11,IEND11,IBUGA3) 7099 CALL DPXH1H(IOLD2(J),ICH12,IEND12,IBUGA3) 7100 DO205K=1,NUMAS2 7101 ICH1(K)=' ' 7102 205 CONTINUE 7103 L=0 7104 DO206K=1,NUMASC 7105 L=L+1 7106 ICH1(L)=ICH11(K) 7107 206 CONTINUE 7108 DO207K=1,NUMASC 7109 L=L+1 7110 ICH1(L)=ICH12(K) 7111 207 CONTINUE 7112 IEND1=0 7113 IF(IEND11.GE.1)IEND1=IEND11 7114 IF(IEND11.GE.NUMASC)IEND1=NUMASC 7115 IF(IEND12.GE.1)IEND1=NUMASC+IEND12 7116 IF(IEND12.GE.NUMAS2)IEND1=NUMAS2 7117C 7118 IF(IEND1.LE.0)GOTO200 7119C 7120C ********************************************* 7121C ** STEP 4-- ** 7122C ** CHECK FOR A LEFT OR RIGHT PARENTHESIS ** 7123C ** IN THE INPUT CHANGE PATTERN. ** 7124C ********************************************* 7125C 7126 ISTEPN='4' 7127 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7128C 7129 ICASEP='NO' 7130 DO210K=1,IEND1 7131 IF(ICH1(K).EQ.'(')GOTO220 7132 IF(ICH1(K).EQ.')')GOTO220 7133 210 CONTINUE 7134 ICASEP='NO' 7135 GOTO290 7136 220 CONTINUE 7137 ICASEP='YES' 7138 290 CONTINUE 7139C 7140C ******************************************************** 7141C ** STEP 5-- ** 7142C ** STARTING WITH CHARACTER I OF THE INPUT FUNCTION, ** 7143C ** COMPARE THE STRING IN THE INPUT FUNCTION ** 7144C ** WITH THIS INPUT CHANGE PATTERN. ** 7145C ** DETERMINE IF THERE IS A MATCH. ** 7146C ******************************************************** 7147C 7148 ISTEPN='5' 7149 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7150C 7151 L1=I-1 7152 DO300K=1,IEND1 7153 L1=L1+1 7154 IF(IFUNC2(L1).EQ.ICH1(K))GOTO300 7155 GOTO200 7156 300 CONTINUE 7157C 7158C ********************************************** 7159C ** STEP 6-- ** 7160C ** IF HAVE A MATCH, ** 7161C ** CHECK TO SEE IF THE STRING ** 7162C ** IN THE FUNCTION ** 7163C ** IS PRECEDED BY A +, -, *, /, **, (, ** 7164C ** (OR IS THE FIRST STRING ON THE LINE), ** 7165C ** AND ALSO ** 7166C ** IS SUCCEDED BY A +, -, *, /, **, ), ** 7167C ** (OR IS THE LAST STRING ON THE LINE). ** 7168C ** A FULFILLMENT OF ANY OF THE ABOVE ** 7169C ** 14 CONDITIONS WILL BE SUFFICIENT ** 7170C ** TO ASSURE THAT INDIVIDUAL MIDDLE ** 7171C ** CHARACTERS IN LIBRARY FUNCTIONS ** 7172C ** (E.G., THE 'X' IN 'EXP') ** 7173C ** AND IN MULTI-CHARACTER VARIABLE NAMES ** 7174C ** (E.G., THE 'X' IN 'FLUX') ** 7175C ** WILL NOT BE INADVERTANTLY CHANGED ** 7176C ** (E.G., BY, SAY, 'FOR X = 3'). ** 7177C ********************************************** 7178C 7179 ISTEPN='6' 7180 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7181C 7182 ICASEA='NO' 7183 IHALF1='NO' 7184 IHALF2='NO' 7185C 7186 IM1=I-1 7187 IF(IM1.LE.0)GOTO410 7188 IF(IFUNC2(IM1).EQ.'+')GOTO410 7189 IF(IFUNC2(IM1).EQ.'-')GOTO410 7190 IF(IFUNC2(IM1).EQ.'*')GOTO410 7191 IF(IFUNC2(IM1).EQ.'/')GOTO410 7192 IF(IFUNC2(IM1).EQ.'**')GOTO410 7193 IF(IFUNC2(IM1).EQ.'(')GOTO410 7194 IHALF1='NO' 7195 GOTO419 7196 410 CONTINUE 7197 IHALF1='YES' 7198 419 CONTINUE 7199C 7200 L1P1=L1+1 7201 IF(L1P1.GT.N2)GOTO420 7202 IF(IFUNC2(L1P1).EQ.'+')GOTO420 7203 IF(IFUNC2(L1P1).EQ.'-')GOTO420 7204 IF(IFUNC2(L1P1).EQ.'*')GOTO420 7205 IF(IFUNC2(L1P1).EQ.'/')GOTO420 7206 IF(IFUNC2(L1P1).EQ.'**')GOTO420 7207 IF(IFUNC2(L1P1).EQ.')')GOTO420 7208 IHALF2='NO' 7209 GOTO429 7210 420 CONTINUE 7211 IHALF2='YES' 7212 429 CONTINUE 7213C 7214 ICASEA='NO' 7215 IF(IHALF1.EQ.'YES'.AND.IHALF2.EQ.'YES')ICASEA='YES' 7216C 7217C ********************************************************* 7218C ** STEP 7-- ** 7219C ** IF THE INPUT STRING HAD ANY PARENTHESES, ** 7220C ** THEN CHANGE ANY MATCHING STRING IN THE FUNCTION.** 7221C ** IF THE INPUT STRING HAD NO PARENTHESES, ** 7222C ** THEN CHANGE MATCHING STRINGS IN THE FUNCTION ** 7223C ** ONLY WHEN THE MATCHING FUNCTION SUBSTRING ** 7224C ** IS PRECEDED BY A +, -, *, /, **, (, ** 7225C ** (OR IS THE FIRST STRING ON THE LINE), AND ALSO ** 7226C ** IS SUCCEDED BY A +, -, *, /, **, ), ** 7227C ** (OR IS THE LAST STRING ON THE LINE). ** 7228C ********************************************************* 7229C 7230 ISTEPN='7' 7231 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7232C 7233 IF(ICASEP.EQ.'YES')GOTO590 7234 IF(ICASEP.EQ.'NO'.AND.ICASEA.EQ.'YES')GOTO590 7235 GOTO200 7236 590 CONTINUE 7237C 7238C ************************************************** 7239C ** STEP 8-- ** 7240C ** IF CHANGES ARE TO BE MADE, ** 7241C ** EXTRACT THE OUTPUT CHANGE PATTERN ** 7242C ** CORRESPONDING TO THE INPUT CHANGE PATTERN. ** 7243C ************************************************** 7244C 7245 ISTEPN='8' 7246 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7247C 7248 CALL DPXH1H(INEW(J),ICH21,IEND21,IBUGA3) 7249 CALL DPXH1H(INEW2(J),ICH22,IEND22,IBUGA3) 7250 DO605K=1,NUMAS2 7251 ICH2(K)=' ' 7252 605 CONTINUE 7253 L=0 7254 DO606K=1,NUMASC 7255 L=L+1 7256 ICH2(L)=ICH21(K) 7257 606 CONTINUE 7258 DO607K=1,NUMASC 7259 L=L+1 7260 ICH2(L)=ICH22(K) 7261 607 CONTINUE 7262 IEND2=0 7263 IF(IEND21.GE.1)IEND2=IEND21 7264 IF(IEND21.GE.NUMASC)IEND2=NUMASC 7265 IF(IEND22.GE.1)IEND2=NUMASC+IEND21 7266 IF(IEND22.GE.NUMAS2)IEND2=NUMAS2 7267C 7268 IF(IEND2.LE.0)GOTO200 7269C 7270C ****************************** 7271C ** STEP 9-- ** 7272C ** CARRY OUT THE CHANGES ** 7273C ** IN THE INPUT FUNCTION. ** 7274C ****************************** 7275C 7276 ISTEPN='9' 7277 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7278C 7279 ISTAR1=I 7280 ISTOP1=ISTAR1+IEND1-1 7281 ISTAR2=1 7282 ISTOP2=ISTAR2+IEND2-1 7283 CALL DPSIRS(IFUNC2,N2,ISTAR1,ISTOP1,ICH2,IEND2,ISTAR2,ISTOP2, 7284 1IBUGA3,IERROR) 7285 I=ISTOP1+(IEND2-IEND1) 7286 GOTO100 7287C 7288 200 CONTINUE 7289 GOTO100 7290C 7291 190 CONTINUE 7292C 7293C ***************** 7294C ** STEP 90-- ** 7295C ** EXIT ** 7296C ***************** 7297C 7298 IF(IBUGA3.EQ.'ON')THEN 7299 WRITE(ICOUT,999) 7300 CALL DPWRST('XXX','BUG ') 7301 WRITE(ICOUT,9011) 7302 9011 FORMAT('***** AT THE END OF COMPIC--') 7303 CALL DPWRST('XXX','BUG ') 7304 WRITE(ICOUT,9012)IBUGA3,N1,NCHANG,NUMASC,NUMAS2 7305 9012 FORMAT('IBUGA3,N1,N2,NCHANG,NUMASC,NUMAS2 = ',A4,2X,5I8) 7306 CALL DPWRST('XXX','BUG ') 7307 WRITE(ICOUT,9013)(IFUNC1(I),I=1,N1) 7308 9013 FORMAT('IFUNC1(.)=',30A4) 7309 CALL DPWRST('XXX','BUG ') 7310 DO9015I=1,NCHANG 7311 WRITE(ICOUT,9016)I,IOLD(I),IOLD2(I),INEW(I),INEW2(I) 7312 9016 FORMAT('I,IOLD(I),IOLD2(I),INEW(I),INEW2(I) = ', 7313 1 I8,2X,2A4,2X,2A4) 7314 CALL DPWRST('XXX','BUG ') 7315 9015 CONTINUE 7316 WRITE(ICOUT,9018)(IFUNC2(I),I=1,N2) 7317 9018 FORMAT('IFUNC2(.)=',30A4) 7318 CALL DPWRST('XXX','BUG ') 7319 WRITE(ICOUT,9020)IEND11,IEND12,IEND1,IEND21,IEND22,IEND2 7320 9020 FORMAT('IEND11,IEND12,IEND1,IEND21,IEND22,IEND2 = ',6I8) 7321 CALL DPWRST('XXX','BUG ') 7322 WRITE(ICOUT,9021)(ICH11(I),I=1,10) 7323 9021 FORMAT('(ICH11(I),I=1,10) = ',10A1) 7324 CALL DPWRST('XXX','BUG ') 7325 WRITE(ICOUT,9022)(ICH12(I),I=1,10) 7326 9022 FORMAT('(ICH12(I),I=1,10) = ',10A1) 7327 CALL DPWRST('XXX','BUG ') 7328 WRITE(ICOUT,9023)(ICH1 (I),I=1,10) 7329 9023 FORMAT('(ICH1 (I),I=1,10) = ',10A1) 7330 CALL DPWRST('XXX','BUG ') 7331 WRITE(ICOUT,9024)(ICH21(I),I=1,10) 7332 9024 FORMAT('(ICH21(I),I=1,10) = ',10A1) 7333 CALL DPWRST('XXX','BUG ') 7334 WRITE(ICOUT,9025)(ICH22(I),I=1,10) 7335 9025 FORMAT('(ICH22(I),I=1,10) = ',10A1) 7336 CALL DPWRST('XXX','BUG ') 7337 WRITE(ICOUT,9026)(ICH2 (I),I=1,10) 7338 9026 FORMAT('(ICH2 (I),I=1,10) = ',10A1) 7339 CALL DPWRST('XXX','BUG ') 7340 ENDIF 7341C 7342 RETURN 7343 END 7344 SUBROUTINE COMPID(IA,NUMCHA,IPASS,PARAM,IPARN1,IPARN2,NUMPAR, 7345 1IVARN1,IVARN2,NUMVAR, 7346 1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,ID,NUMCHD, 7347 1IBUGCO,IBUGEV,ISUBRO,IERROR) 7348C 7349C PURPOSE--THIS SUBROUTINE DETERMINES THE DERIVATIVE OF 7350C A FORTRAN MATHEMATICAL FUNCTION EXPRESSION. 7351C NOTE--TYPICALLY THIS SUBROUTINE IS CALLED ONLY 7352C WITH IPASS=2; IN SUCH CASE, 7353C IPARN1(.) AND NUMPAR ARE NEVER DETERMINED, 7354C NEEDED, OR OUTPUTTED. 7355C (NOTE--THERE EXISTS POSSIBLE DIFFERENCES WITH NUMPAR 7356C AS DEFINED FOR THIS SUBROUTINE 7357C AS OPPOSED TO THE DEFINITION FOR COMPID). 7358C INPUT ARGUMENTS--IA = THE HOLLARITH VECTOR WHICH CONTAINS 7359C THE FUNCTION OF INTEREST 7360C FOR WHICH THE ANALYTIC DERIVATIVE 7361C IS TO BE DETERMINED. 7362C IA(.) MAY BE EITHER UNPACKED (1 CHARACTER PER W 7363C OR PACKED (4 CHARACTERS PER WORD) 7364C ALTHOUGH THE USUAL REPRESENTATION IS UNPACKED. 7365C --NUMCHA = THE INTEGER VALUE WHICH 7366C DEFINES THE NUMBER OF CHARACTERS IN IA. 7367C NUMCHA DEFINES THE LENGTH OF THE 7368C HOLLARITH STRING TO BE OPERATED ON. 7369C --IPASS = AN INTEGER FLAG CODE 7370C WHICH DEFINES WHICH PASS (1 OR 2) INTO THIS 7371C SUBROUTINE THE USER IS IN. 7372C PASS 1 DETERMINE PARAMETER NAMES; 7373C PASS 2 DOES FUNCTION EVALUATIONS. 7374C --PARAM = THE SINGLE PRECISION VECTOR OF PARAMETER 7375C (AND VARIABLE) 7376C VALUES CORRESPONDING TO THE PARAMETER NAMES 7377C AS GIVEN IN THE VECTOR IPARN1. 7378C --IPARN1 = THE INTEGER VECTOR OF PARAMETER 7379C (AND VARIABLE) 7380C NAMES AS TYPICALLY DETERMINED BY PASS 1. 7381C OUTPUT ARGUMENTS--ID = THE HOLLARITH VECTOR WHICH CONTAINS 7382C THE DESIRED DERIVATIVE FUNCTION. 7383C ID(.) IS UNPACKED (THAT IS, 7384C 1 CHARACTER PER WORD). 7385C --NUMCHD = THE INTEGER VALUE WHICH 7386C DEFINES THE NUMBER OF CHARACTERS IN ID. 7387C NUMCHD DEFINES THE LENGTH OF THE 7388C HOLLARITH STRING FOR THE DERIVATIVE FUNCTION. 7389C OUTPUT--THE SINGLE PRECISION COMPUTED SCALAR VALUE, 7390C PRINTING--NONE. 7391C RESTRICTIONS--NONE. 7392C OTHER SUBROUTINES NEEDED--EVAL 7393C FORTRAN LIBRARY SUBROUTINES NEEDED--(ALL IN EVAL) 7394C SQRT 7395C EXP 7396C LOG 7397C LOG10 7398C SIN 7399C COS 7400C ATAN 7401C ATAN2 7402C TANH 7403C ABS 7404C AINT 7405C ARCSIN 7406C ARCCOS 7407C ARCTAN 7408C OCTAL 7409C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 7410C LANGUAGE--ANSI FORTRAN. 7411C NOTE--THIS SUBROUTINE ALLOWS ONE TO PERFORM 7412C INTERACTIVE FUNCTION EVALUATIONS. 7413C REFERENCES--NONE. 7414C WRITTEN BY--JAMES J. FILLIBEN 7415C STATISTICAL ENGINEERING LABORATORY (205.03) 7416C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 7417C GAITHERSBURG, MD 20899 7418C PHONE: 301-921-2315 7419C ORIGINAL VERSION--DECEMBER 1978. 7420C UPDATED --JANUARY 1979. 7421C UPDATED --JANUARY 1981. 7422C UPDATED --APRIL 1986. 7423C 7424 CHARACTER*4 IA 7425 CHARACTER*4 IPARN1 7426 CHARACTER*4 IPARN2 7427 CHARACTER*4 IVARN1 7428 CHARACTER*4 IVARN2 7429 CHARACTER*4 IANGLU 7430 CHARACTER*4 ITYPEH 7431 CHARACTER*4 IW21HO 7432 CHARACTER*4 IW22HO 7433 CHARACTER*4 IBUGCO 7434 CHARACTER*4 IBUGEV 7435 CHARACTER*4 IERROR 7436C 7437 CHARACTER*4 ISUBN1 7438 CHARACTER*4 ISUBN2 7439 CHARACTER*4 ISTEPN 7440C 7441 CHARACTER*4 IR 7442 CHARACTER*4 IB 7443 CHARACTER*4 IL 7444 CHARACTER*4 ICH 7445 CHARACTER*4 IW21 7446 CHARACTER*4 IW22 7447 CHARACTER*4 ITYPE 7448 CHARACTER*4 IANS1 7449 CHARACTER*4 IANS2 7450 CHARACTER*4 IANS3 7451 CHARACTER*4 IANS4 7452 CHARACTER*4 ISUBRO 7453 CHARACTER*4 IFOUND 7454CCCCC CHARACTER*4 IBUG0 7455CCCCC CHARACTER*4 IBUG1 7456CCCCC CHARACTER*4 IBUG2 7457CCCCC CHARACTER*4 IBUG3 7458CCCCC CHARACTER*4 IBUG4 7459CCCCC CHARACTER*4 IBUG5 7460CCCCC CHARACTER*4 IBUG6 7461CCCCC CHARACTER*4 IBUG7 7462CCCCC CHARACTER*4 IBUGXH 7463CCCCC CHARACTER*4 IBUGCD 7464C 7465 CHARACTER*4 ID 7466 CHARACTER*4 ID1 7467 CHARACTER*4 ID2 7468 CHARACTER*4 ID3 7469 CHARACTER*4 ICON 7470C 7471C--------------------------------------------------------------------- 7472C 7473 DIMENSION IA(*) 7474 DIMENSION PARAM(*) 7475 DIMENSION IPARN1(*) 7476 DIMENSION IPARN2(*) 7477C 7478 DIMENSION IVARN1(*) 7479 DIMENSION IVARN2(*) 7480C 7481 DIMENSION ID(*) 7482C 7483C NOTE--THE DIMENSIONS OF ITYPEH, IW21HO, IW22HO, AND W2HOLD 7484C WHICH ARE DEFINED IN THE MAIN PROGRAM 7485C SHOULD BE AT LEAST AS LARGE AS THE DIMENSIONS 7486C OF IW21 AND IW22 BELOW. 7487C 7488 DIMENSION ITYPEH(*) 7489 DIMENSION IW21HO(*) 7490 DIMENSION IW22HO(*) 7491 DIMENSION W2HOLD(*) 7492C 7493CCCCC DIMENSION IB(225) 7494CCCCC DIMENSION IR(225) 7495CCCCC DIMENSION IBEGIN(225) 7496CCCCC DIMENSION IEND(225) 7497CCCCC DIMENSION ITYPE(225) 7498CCCCC DIMENSION IW21(225) 7499CCCCC DIMENSION IW22(225) 7500CCCCC DIMENSION W2(225) 7501 DIMENSION IB(1000) 7502 DIMENSION IR(1000) 7503 DIMENSION IBEGIN(1000) 7504 DIMENSION IEND(1000) 7505 DIMENSION ITYPE(1000) 7506 DIMENSION IW21(1000) 7507 DIMENSION IW22(1000) 7508 DIMENSION W2(1000) 7509C 7510 DIMENSION ID1(250) 7511 DIMENSION ID2(250) 7512 DIMENSION ID3(250) 7513C 7514 DIMENSION ICH(10) 7515C 7516 DIMENSION IL(10) 7517C 7518 DIMENSION ICON(1000) 7519 DIMENSION ICON1(50) 7520 DIMENSION ICON2(50) 7521C 7522C-----COMMON VARIABLES (GENERAL)----------------------------------------------- 7523C 7524 INCLUDE 'DPCOP2.INC' 7525C 7526C-----DATA STATEMENTS----------------------------------------------------- 7527C 7528CCCCC DATA IBUG0/'OFF'/ 7529CCCCC DATA IBUG1/'OFF'/ 7530CCCCC DATA IBUG2/'OFF'/ 7531CCCCC DATA IBUG3/'OFF'/ 7532CCCCC DATA IBUG4/'OFF'/ 7533CCCCC DATA IBUG5/'OFF'/ 7534CCCCC DATA IBUG6/'OFF'/ 7535CCCCC DATA IBUG7/'OFF'/ 7536CCCCC DATA IBUGXH/'OFF'/ 7537CCCCC DATA IBUGCD/'OFF'/ 7538C 7539C DEFINE THE UPPER LIMIT OF THE NUMBER OF CHARACTERS 7540C THAT MAY BE PROCESSED BY THIS SUBROUTINE 7541C (COUNTING BLANKS, LEFT-HAND SIDE, EQUAL SIGN, 7542C AND RIGHT HAND SIDE). 7543C IF RESTRICT THE EXPRESSION TO 1 LINE IMAGE, 7544C THEN A REASONABLE UPPER BOUND IS 80. 7545C WHATEVER UPPER BOUND IS SET, 7546C THE DIMENSIONS OF MOST OF THE VECTORS 7547C MUST BE EQUAL OR LARGER TO THIS NUMBER. 7548C (THE VECTOR IL(.) WHICH CONTAINS THE 7549C NUMBER OF CHARACTERS TO THE LEFT 7550C OF THE EQUAL SIGN (BLANKS IGNORED) 7551C MAY BE MUCH SMALLER--LIKE 6.) 7552C NOTE--AS OF JANUARY 1979, THE BOUND WAS RESET TO 150. 7553C 7554CCCCC DATA MAXCHA/150/ 7555CCCCC DATA MAXCHA/225/ 7556 DATA MAXCHA/1000/ 7557C 7558C-----START POINT----------------------------------------------------- 7559C 7560 ISUBN1='COMP' 7561 ISUBN2='ID ' 7562C 7563 IERROR='NO ' 7564C 7565C THE FOLLOWING STATEMENT (N=1) HAS BEEN ADDED 7566C IN CONVERTING THE COMPIL SUBROUTINE 7567C TO THE COMPID SUBROUTINE. 7568C 7569 N=1 7570C 7571 IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO90 7572 WRITE(ICOUT,999) 7573 999 FORMAT(1X) 7574 CALL DPWRST('XXX','BUG ') 7575 WRITE(ICOUT,51) 7576 51 FORMAT('***** AT THE BEGINNING OF COMPID--') 7577 CALL DPWRST('XXX','BUG ') 7578 WRITE(ICOUT,52)NUMCHA,N,IPASS,IANGLU 7579 52 FORMAT('NUMCHA,N,IPASS,IANGLU = ',3I8,2X,A4) 7580 CALL DPWRST('XXX','BUG ') 7581 WRITE(ICOUT,53)(IA(I),I=1,NUMCHA) 7582 53 FORMAT('IA--',80A1) 7583 CALL DPWRST('XXX','BUG ') 7584 WRITE(ICOUT,54)IBUGCO,IBUGEV 7585 54 FORMAT('IBUGCO,IBUGEV = ',A4,2X,A4) 7586 CALL DPWRST('XXX','BUG ') 7587 WRITE(ICOUT,999) 7588 CALL DPWRST('XXX','BUG ') 7589 WRITE(ICOUT,61)NUMPAR 7590 61 FORMAT('NUMPAR = ',I8) 7591 CALL DPWRST('XXX','BUG ') 7592 IF(NUMPAR.LE.0)GOTO64 7593 DO62I=1,NUMPAR 7594 WRITE(ICOUT,63)I,IPARN1(I),IPARN2(I),PARAM(I) 7595 63 FORMAT('I,IPARN1(I),IPARN2(I),PARAM(I) = ',I8,2X,A4,2X,A4,2X, 7596 1E15.7) 7597 CALL DPWRST('XXX','BUG ') 7598 62 CONTINUE 7599 64 CONTINUE 7600 WRITE(ICOUT,999) 7601 CALL DPWRST('XXX','BUG ') 7602 WRITE(ICOUT,65)NUMVAR 7603 65 FORMAT('NUMVAR = ',I8) 7604 CALL DPWRST('XXX','BUG ') 7605 IF(NUMVAR.LE.0)GOTO69 7606 DO66I=1,NUMVAR 7607 WRITE(ICOUT,67)I,IVARN1(I),IVARN2(I) 7608 67 FORMAT('I,IVARN1(I),IVARN2(I) = ',I8,2X,A4,2X,A4) 7609 CALL DPWRST('XXX','BUG ') 7610 66 CONTINUE 7611 69 CONTINUE 7612 WRITE(ICOUT,999) 7613 CALL DPWRST('XXX','BUG ') 7614 WRITE(ICOUT,71)NWHOLD 7615 71 FORMAT('NWHOLD = ',I8) 7616 CALL DPWRST('XXX','BUG ') 7617 IF(NWHOLD.LE.0)GOTO79 7618 DO72I=1,NWHOLD 7619 WRITE(ICOUT,73)I,ITYPEH(I),IW21HO(I),IW22HO(I),W2HOLD(I) 7620 73 FORMAT('I,ITYPEH(I),IW21HO(I),IW22HO(I),W2HOLD(I) = ', 7621 1I8,2X,A4,2X,A4,2X,A4,2X,E15.7) 7622 CALL DPWRST('XXX','BUG ') 7623 72 CONTINUE 7624 79 CONTINUE 7625 90 CONTINUE 7626C 7627C ************************************************************ 7628C ** DEFINE NUMASC = NUMBER OF ASCII CHARACTERS PER WORD. ** 7629C ** THIS IS 4 REGARDLESS OF THE COMPUTER MAKE AND ** 7630C ** REGARDLESS OF THE WORD SIZE. ** 7631C ************************************************************ 7632C 7633 NUMASC=4 7634 NUMAS2=2*NUMASC 7635 NUMAS3=3*NUMASC 7636 NUMAS4=4*NUMASC 7637C 7638C CHECK THAT THE INPUT NUMBER OF CHARACTERS NUMCHA 7639C (INCLUDING LEFT SIDE, RIGHT SIDE, EQUAL SIGN, 7640C AND BLANKS) IS AT LEAST 1 AND AT MOST MAXCHA 7641C (WHERE MAXCHA IS THE INTERNALLY DEFINED VARIABLE 7642C WHICH CONTROLS DIMENSION SIZES AND WHICH 7643C TYPICALLY HAS THE VALUE 80). 7644C 7645 IF(1.LE.NUMCHA.AND.NUMCHA.LE.MAXCHA)GOTO139 7646 WRITE(ICOUT,121) 7647 121 FORMAT('***** ERROR IN COMPID--') 7648 CALL DPWRST('XXX','BUG ') 7649 WRITE(ICOUT,122) 7650 122 FORMAT(' THE NUMBER OF CHARACTERS NUMCHA ') 7651 CALL DPWRST('XXX','BUG ') 7652 WRITE(ICOUT,123) 7653 123 FORMAT(' WHICH DEFINES THE LENGTH OF THE ') 7654 CALL DPWRST('XXX','BUG ') 7655 WRITE(ICOUT,124) 7656 124 FORMAT(' INPUT EXPRESSION (INCLUDING LEFT-HAND SIDE,') 7657 CALL DPWRST('XXX','BUG ') 7658 WRITE(ICOUT,125) 7659 125 FORMAT(' RIGHT-HAND SIDE, EQUAL SIGN, AND ALL BLANKS)') 7660 CALL DPWRST('XXX','BUG ') 7661 WRITE(ICOUT,126) 7662 126 FORMAT(' IS SMALLER THAN 1 OR LARGER THAN MAXCHA') 7663 CALL DPWRST('XXX','BUG ') 7664 WRITE(ICOUT,127) 7665 127 FORMAT(' (MAXCHA IS AN INTERNALLY-DEFINED VARIABLE') 7666 CALL DPWRST('XXX','BUG ') 7667 WRITE(ICOUT,128)MAXCHA 7668 128 FORMAT(' WHICH HAS THE VALUE = ',I8,' .') 7669 CALL DPWRST('XXX','BUG ') 7670 WRITE(ICOUT,129) 7671 129 FORMAT(' THE NUMBER OF CHARACTERS IN THE') 7672 CALL DPWRST('XXX','BUG ') 7673 WRITE(ICOUT,130)NUMCHA 7674 130 FORMAT(' INPUT EXPRESSION IS ',I8) 7675 CALL DPWRST('XXX','BUG ') 7676 IF(NUMCHA.GE.1)WRITE(ICOUT,131)(IA(I),I=1,NUMCHA) 7677 131 FORMAT(' INPUT EXPRESSION--',100A1) 7678 IF(NUMCHA.GE.1)CALL DPWRST('XXX','BUG ') 7679 IERROR='YES ' 7680 GOTO9000 7681 139 CONTINUE 7682C 7683C BLANK-OUT AND ZERO-OUT SOME VARIABLES AND VECTORS. 7684C 7685CCCCC Y=0.0 7686 IC2=0 7687C 7688 DO160I=1,NUMCHA 7689 IR(I)=' ' 7690 IB(I)=' ' 7691 IW21(I)=' ' 7692 IW22(I)=' ' 7693 W2(I)=0.0 7694 ITYPE(I)=' ' 7695 IW21HO(I)=' ' 7696 IW22HO(I)=' ' 7697 W2HOLD(I)=0.0 7698 ITYPEH(I)=' ' 7699 ID1(I)=' ' 7700 ID2(I)=' ' 7701 ID3(I)=' ' 7702 ID(I)=' ' 7703 160 CONTINUE 7704C 7705C 7706C *********************************************** 7707C ** STEP 1-- ** 7708C ** OPERATE ON THE VECTOR IA(.). ** 7709C ** IA(.) MAY BE OPTIONALLY EITHER UNPACKED ** 7710C ** (1 CHARACTER PER WORD), ** 7711C ** OR PACKED ** 7712C ** (UP TO 4 CHARACTERS PER WORD). ** 7713C ** IN ANY EVENT, IB(.) IS UNPACKED. ** 7714C ** NOTE ALSO THAT IB(.) HAS BLANKS OMITTED. ** 7715C *********************************************** 7716C 7717 ISTEPN='1' 7718 IF(IBUGCO.EQ.'ON'.OR.ISUBRO.EQ.'RIV4') 7719 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7720C 7721 K=0 7722 DO200I=1,NUMCHA 7723 IF(IA(I).EQ.' ')GOTO200 7724 CALL DPXH1H(IA(I),ICH,ILASTC,IBUGEV) 7725 IF(ILASTC.LE.0)GOTO200 7726 DO250J=1,ILASTC 7727 K=K+1 7728 IB(K)=ICH(J) 7729 250 CONTINUE 7730 200 CONTINUE 7731 NCTOT=K 7732C 7733 IF(NCTOT.GE.1)GOTO290 7734 WRITE(ICOUT,205)NCTOT 7735 205 FORMAT('***** ERROR IN COMPID--TOTAL NUMBER OF CHARACTERS ', 7736 1'IN MODEL (INCL. BOTH SIDES, BLANKS, AND EQUAL SIGN) ', 7737 1'IS < 2. NCTOT = ',I5) 7738 CALL DPWRST('XXX','BUG ') 7739 WRITE(ICOUT,271)NUMCHA,N,IPASS 7740 271 FORMAT('NUMCHA,N,IPASS = ',3I8) 7741 CALL DPWRST('XXX','BUG ') 7742 WRITE(ICOUT,272)(IA(I),I=1,NUMCHA) 7743 272 FORMAT('IA--',80A1) 7744 CALL DPWRST('XXX','BUG ') 7745C 7746 WRITE(ICOUT,999) 7747 CALL DPWRST('XXX','BUG ') 7748 WRITE(ICOUT,281)NUMPAR 7749 281 FORMAT('NUMPAR = ',I8) 7750 CALL DPWRST('XXX','BUG ') 7751 IF(NUMPAR.LE.0)GOTO289 7752 DO282I=1,NUMPAR 7753 WRITE(ICOUT,283)I,IPARN1(I),IPARN2(I),PARAM(I) 7754 283 FORMAT('I,IPARN1(I),IPARN2(I),PARAM(I) = ',I8,2X,A4,2X,A4,2X, 7755 1E15.7) 7756 CALL DPWRST('XXX','BUG ') 7757 282 CONTINUE 7758 289 CONTINUE 7759 IERROR='YES ' 7760 GOTO9000 7761C 7762 290 CONTINUE 7763 IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO299 7764 WRITE(ICOUT,291)NCTOT 7765 291 FORMAT('NCTOT = ',I8) 7766 CALL DPWRST('XXX','BUG ') 7767 DO292I=1,NCTOT 7768 WRITE(ICOUT,293)I,IB(I) 7769 293 FORMAT('I,IB(I) = ',I8,2X,A4) 7770 CALL DPWRST('XXX','BUG ') 7771 292 CONTINUE 7772 299 CONTINUE 7773C 7774C ************************************************************** 7775C ** STEP 2-- ** 7776C ** OPERATE ON THE VECTOR IB(.). ** 7777C ** DETERMINE THE NUMBER OF CHARACTERS (IF ANY) ** 7778C ** FOR THE LEFT-HAND SIDE. OUTPUT THEM INTO THE ** 7779C ** VECTOR IL(.). ** 7780C ************************************************************** 7781C 7782 DO500I=1,NCTOT 7783 I2=I 7784 IF(IB(I).EQ.'= ')GOTO550 7785 500 CONTINUE 7786 NCL=0 7787 ISTARR=1 7788 GOTO559 7789 550 CONTINUE 7790 NCL=I2-1 7791 ISTARR=I2+1 7792 559 CONTINUE 7793C 7794 IF(NCL.LE.0)GOTO699 7795 DO600I=1,NCL 7796 IL(I)=IB(I) 7797 600 CONTINUE 7798 IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO699 7799 ISTEPN='2' 7800 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7801 WRITE(ICOUT,691)NCL 7802 691 FORMAT('NCL = ',2I8) 7803 CALL DPWRST('XXX','BUG ') 7804 DO692I=1,NCL 7805 WRITE(ICOUT,693)I,IL(I) 7806 693 FORMAT('I,IL(I) = ',I8,2X,A4) 7807 CALL DPWRST('XXX','BUG ') 7808 692 CONTINUE 7809 699 CONTINUE 7810C 7811C *************************************************************** 7812C ** STEP 3-- ** 7813C ** OPERATE ON THE VECTOR IB(.). ** 7814C ** DETERMINE THE NUMBER OF CHARACTERS FOR RIGHT-HAND SIDE. ** 7815C ** OUTPUT THEM INTO THE VECTOR IR(.). ** 7816C *************************************************************** 7817C 7818 IF(ISTARR.LE.NCTOT)GOTO719 7819 WRITE(ICOUT,701) 7820 701 FORMAT('***** ERROR IN COMPID--') 7821 CALL DPWRST('XXX','BUG ') 7822 WRITE(ICOUT,702) 7823 702 FORMAT(' THE NUMBER OF CHARACTERS ON THE RIGHT') 7824 CALL DPWRST('XXX','BUG ') 7825 WRITE(ICOUT,703) 7826 703 FORMAT(' (WITH BLANKS IGNORED) IS 0.') 7827 CALL DPWRST('XXX','BUG ') 7828 WRITE(ICOUT,704) 7829 704 FORMAT(' THE TOTAL NUMBER OF PACKED CHARACTERS NCTOT') 7830 CALL DPWRST('XXX','BUG ') 7831 WRITE(ICOUT,705) 7832 705 FORMAT(' LEFT (IF ANY), EQUAL SIGN (IF ANY), AND RIGHT') 7833 CALL DPWRST('XXX','BUG ') 7834 WRITE(ICOUT,706)NCTOT 7835 706 FORMAT(' = ',I8) 7836 CALL DPWRST('XXX','BUG ') 7837 WRITE(ICOUT,707) 7838 707 FORMAT(' THE START POSITION FOR THE PACKED RIGHT') 7839 CALL DPWRST('XXX','BUG ') 7840 WRITE(ICOUT,708)ISTARR 7841 708 FORMAT(' IS COLUMN ',I8) 7842 CALL DPWRST('XXX','BUG ') 7843 WRITE(ICOUT,709)NUMCHA 7844 709 FORMAT(' THE INPUT NUMBER OF CHARACTERS NUMCHA = ',I8) 7845 CALL DPWRST('XXX','BUG ') 7846 IF(NUMCHA.GE.1)WRITE(ICOUT,710)(IA(I),I=1,NUMCHA) 7847 710 FORMAT(' INPUT EXPRESSION--',100A1) 7848 IF(NUMCHA.GE.1)CALL DPWRST('XXX','BUG ') 7849 IERROR='YES ' 7850 GOTO9000 7851 719 CONTINUE 7852C 7853 K=0 7854 DO700I=ISTARR,NCTOT 7855 K=K+1 7856 IR(K)=IB(I) 7857 700 CONTINUE 7858 NCR=K 7859C 7860 IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO799 7861 ISTEPN='3' 7862 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7863 WRITE(ICOUT,791)NCR 7864 791 FORMAT('NCR = ',2I8) 7865 CALL DPWRST('XXX','BUG ') 7866 DO792I=1,NCR 7867 WRITE(ICOUT,793)I,IR(I) 7868 793 FORMAT('I,IR(I) = ',I8,2X,A4) 7869 CALL DPWRST('XXX','BUG ') 7870 792 CONTINUE 7871 799 CONTINUE 7872C 7873C **************************************************************** 7874C ** STEP 4-- 7875C ** OPERATE ON THE VECTOR IR(.). 7876C ** SIMPLIFY THE RIGHT-HAND SIDE. 7877C ** ANALYZE THE RIGHT-HAND SIDE. 7878C ** DETERMINE THE NUMBER OF DIFFERENT LOGICAL COMPONENTS. 7879C ** 1. NUMBER (CONSISTING OF 0,1,2,...,9 OR .) 7880C ** 2. X VARIABLE 7881C ** 3. OPERATION (+ - * / **) 7882C ** 4. PARENTHESES ( ( OR ) ) 7883C ** 5. LIBRARY FUNCTION (ALOG EXP ETC + AUGMENTED LIB. 7884C ** 6. COMMA (FOR MULTI-ARGUMENT LIBRARY FUNCTIONS) 7885C ** 7. PARAMETER (ANYTHING NOT ABOVE) 7886C ** CHECK FOR SYNTAX ERRORS. 7887C ** OUTPUT THE TYPE COMPONENT INTO ITYPE(.). 7888C ** OUTPUT THE START LOCATION IN IR(.) OF EACH COMPONENT INTO IB 7889C ** OUTPUT THE STOP LOCATION IN IR(.) OF EACH COMPONENT INTO IE 7890C **************************************************************** 7891C 7892 CALL DPSIPA(IR,NCR,IBUGEV,IERROR) 7893 CALL DPSISI(IR,NCR,IBUGEV,IERROR) 7894 CALL DPSIP1(IR,NCR,IBUGEV,IERROR) 7895 CALL DPSIP0(IR,NCR,IBUGEV,IERROR) 7896 CALL DPSIE1(IR,NCR,IBUGEV,IERROR) 7897 CALL DPSIE0(IR,NCR,IBUGEV,IERROR) 7898 CALL DPSIA0(IR,NCR,IBUGEV,IERROR) 7899 CALL DPSIA2(IR,NCR,IBUGEV,ISUBRO,IERROR) 7900 CALL DPSIFL(IR,NCR,IBUGEV,IERROR) 7901C 7902 NW=0 7903 I=1 7904 NCON=0 7905 1050 CONTINUE 7906 IP1=I+1 7907 IP2=I+2 7908 IP3=I+3 7909 IP4=I+4 7910 IP5=I+5 7911C 7912 IF(IR(I).EQ.'0 ')GOTO1100 7913 IF(IR(I).EQ.'1 ')GOTO1100 7914 IF(IR(I).EQ.'2 ')GOTO1100 7915 IF(IR(I).EQ.'3 ')GOTO1100 7916 IF(IR(I).EQ.'4 ')GOTO1100 7917 IF(IR(I).EQ.'5 ')GOTO1100 7918 IF(IR(I).EQ.'6 ')GOTO1100 7919 IF(IR(I).EQ.'7 ')GOTO1100 7920 IF(IR(I).EQ.'8 ')GOTO1100 7921 IF(IR(I).EQ.'9 ')GOTO1100 7922 IF(IR(I).EQ.'. ')GOTO1100 7923C 7924C NOTE--THE FOLLOWING LINE IS BEING COMMENTED OUT 7925C SO AS TO GENERALIZE COMPIL INTO COMPID 7926C (1 VARIABLE INTO MANY VARIABLES). 7927C 7928CCCCC IF(IR(I).EQ.'X ')GOTO1200 7929C 7930 IF(IR(I).EQ.'+ ')GOTO1300 7931 IF(IR(I).EQ.'- ')GOTO1300 7932 IF(IR(I).EQ.'* ')GOTO1300 7933 IF(IR(I).EQ.'/ ')GOTO1300 7934C 7935 IF(IR(I).EQ.'( ')GOTO1410 7936 IF(IR(I).EQ.') ')GOTO1420 7937C 7938 IF(IR(I).EQ.', ')GOTO1700 7939C 7940C CHECK FOR A LIBRARY FUNCTION. 7941C 7942CCCCC CALL CKLIBF(IR,NCR,I,IFOUND,NCLF,IBUGEV,IERROR) 7943 CALL CKLIB1(IR,NCR,I,IFOUND,NCLF,IBUGEV,IERROR) 7944 IF(IERROR.EQ.'YES')GOTO9000 7945 IF(IFOUND.EQ.'NO')CALL CKLIB2(IR,NCR,I,IFOUND,NCLF,IBUGEV,IERROR) 7946 IF(IERROR.EQ.'YES')GOTO9000 7947C 7948C 7949 IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO1069 7950 WRITE(ICOUT,999) 7951 CALL DPWRST('XXX','BUG ') 7952 WRITE(ICOUT,1061) 7953 1061 FORMAT('***** IN COMPID, AFTER RETURNING FROM CKLIBF--') 7954 CALL DPWRST('XXX','BUG ') 7955 WRITE(ICOUT,1062)NCR,I 7956 1062 FORMAT('NCR,I = ',2I8) 7957 CALL DPWRST('XXX','BUG ') 7958 DO1063I4=1,NCR 7959 WRITE(ICOUT,1064)I4,IR(I4) 7960 1064 FORMAT('I4,IR(I4) = ',I8,2X,A4) 7961 CALL DPWRST('XXX','BUG ') 7962 1063 CONTINUE 7963 WRITE(ICOUT,1065)IFOUND,NCLF,IERROR 7964 1065 FORMAT('IFOUND,NCLF,IERROR = ',A4,I8,2X,A4) 7965 CALL DPWRST('XXX','BUG ') 7966 1069 CONTINUE 7967C 7968 IF(IERROR.EQ.'YES ')GOTO9000 7969 IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.8)GOTO1580 7970 IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.7)GOTO1570 7971 IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.6)GOTO1560 7972 IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.5)GOTO1550 7973 IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.4)GOTO1540 7974 IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.3)GOTO1530 7975 IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.2)GOTO1520 7976 IF(IFOUND.EQ.'YES '.AND.NCLF.EQ.1)GOTO1510 7977C 7978 GOTO1600 7979C 7980 1100 CONTINUE 7981 NCON=NCON+1 7982 ICON1(NCON)=IC2+1 7983 IC=0 7984 NW=NW+1 7985 ITYPE(NW)='N ' 7986 JMIN=I 7987 J=I 7988 1150 CONTINUE 7989 IC=IC+1 7990 IC2=IC2+1 7991 ICON(IC2)=IR(J) 7992 J=J+1 7993 IF(J.GT.NCR)GOTO1160 7994 IF(IR(J).EQ.'0 ')GOTO1150 7995 IF(IR(J).EQ.'1 ')GOTO1150 7996 IF(IR(J).EQ.'2 ')GOTO1150 7997 IF(IR(J).EQ.'3 ')GOTO1150 7998 IF(IR(J).EQ.'4 ')GOTO1150 7999 IF(IR(J).EQ.'5 ')GOTO1150 8000 IF(IR(J).EQ.'6 ')GOTO1150 8001 IF(IR(J).EQ.'7 ')GOTO1150 8002 IF(IR(J).EQ.'8 ')GOTO1150 8003 IF(IR(J).EQ.'9 ')GOTO1150 8004 IF(IR(J).EQ.'. ')GOTO1150 8005 1160 CONTINUE 8006 ICON2(NCON)=IC2 8007 JMAX=J-1 8008 GOTO1800 8009C 8010C1200 CONTINUE 8011CCCCC NW=NW+1 8012CCCCC NLPWP=0 8013CCCCC NRPWP=0 8014CCCCC JMIN=I 8015CCCCC J=I 8016CCCCC ILOOP=0 8017 1250 CONTINUE 8018 J=J+1 8019 IF(J.GT.NCR)GOTO1260 8020 IF(IR(J).EQ.'+ ')GOTO1260 8021 IF(IR(J).EQ.'- ')GOTO1260 8022 IF(IR(J).EQ.'* ')GOTO1260 8023 IF(IR(J).EQ.'/ ')GOTO1260 8024 IF(IR(J).EQ.'( ')NLPWP=NLPWP+1 8025 IF(IR(J).EQ.') ')NRPWP=NRPWP+1 8026 IF(IR(J).EQ.') '.AND.NRPWP.GT.NLPWP)GOTO1260 8027 ILOOP=ILOOP+1 8028 IF(ILOOP.LE.NUMAS2)GOTO1250 8029 WRITE(ICOUT,1256)NUMAS2 8030 1256 FORMAT('***** ERROR IN COMPID--PARAMETER NAME EXCEEDS ',I8, 8031 1'CHARACTERS') 8032 CALL DPWRST('XXX','BUG ') 8033 DO1257K=JMIN,J 8034 WRITE(ICOUT,1258)K,IR(K) 8035 1258 FORMAT('K,IR(K) = ',I8,2X,A4) 8036 CALL DPWRST('XXX','BUG ') 8037 1257 CONTINUE 8038 IERROR='YES ' 8039 GOTO9000 8040 1260 CONTINUE 8041 JMAX=J-1 8042C THE FOLLOWING STATEMENT HAS BEEN 8043C COMMENTED OUT IN GOING FROM THE 8044C COMPIL SUBROUTINE TO THE COMPID 8045C SUBROUTINE SO THAT X WILL NOT 8046C BE TREATED AS A SPECIAL VARIABLE. 8047CCCCC IF(JMAX.EQ.JMIN)ITYPE(NW)='X ' 8048 IF(JMAX.GT.JMIN)ITYPE(NW)='PAR ' 8049 GOTO1800 8050C 8051 1300 CONTINUE 8052 NW=NW+1 8053 ITYPE(NW)='OP ' 8054 JMIN=I 8055 JMAX=I 8056 IP1=I+1 8057 IF(IR(I).EQ.'* '.AND.IR(IP1).EQ.'* ')JMAX=IP1 8058 GOTO1800 8059C 8060 1410 CONTINUE 8061 NW=NW+1 8062 ITYPE(NW)='LP ' 8063 JMIN=I 8064 JMAX=I 8065 GOTO1800 8066 1420 CONTINUE 8067 NW=NW+1 8068 ITYPE(NW)='RP ' 8069 JMIN=I 8070 JMAX=I 8071 GOTO1800 8072C 8073 1510 CONTINUE 8074 NW=NW+1 8075 ITYPE(NW)='LF ' 8076 JMIN=I 8077 JMAX=I 8078 GOTO1800 8079C 8080 1520 CONTINUE 8081 NW=NW+1 8082 ITYPE(NW)='LF ' 8083 JMIN=I 8084 JMAX=I+1 8085 GOTO1800 8086C 8087 1530 CONTINUE 8088 NW=NW+1 8089 ITYPE(NW)='LF ' 8090 JMIN=I 8091 JMAX=I+2 8092 GOTO1800 8093C 8094 1540 CONTINUE 8095 NW=NW+1 8096 ITYPE(NW)='LF ' 8097 JMIN=I 8098 JMAX=I+3 8099 GOTO1800 8100C 8101 1550 CONTINUE 8102 NW=NW+1 8103 ITYPE(NW)='LF ' 8104 JMIN=I 8105 JMAX=I+4 8106 GOTO1800 8107C 8108 1560 CONTINUE 8109 NW=NW+1 8110 ITYPE(NW)='LF ' 8111 JMIN=I 8112 JMAX=I+5 8113 GOTO1800 8114C 8115 1570 CONTINUE 8116 NW=NW+1 8117 ITYPE(NW)='LF ' 8118 JMIN=I 8119 JMAX=I+6 8120 GOTO1800 8121C 8122 1580 CONTINUE 8123 NW=NW+1 8124 ITYPE(NW)='LF ' 8125 JMIN=I 8126 JMAX=I+7 8127 GOTO1800 8128C 8129 1700 CONTINUE 8130 NW=NW+1 8131 ITYPE(NW)='COM ' 8132 JMIN=I 8133 JMAX=I 8134 GOTO1800 8135C 8136 1600 CONTINUE 8137 NW=NW+1 8138 ITYPE(NW)='PAR ' 8139 NLPWP=0 8140 NRPWP=0 8141 JMIN=I 8142 J=I 8143 ILOOP=0 8144C 8145 1650 CONTINUE 8146 J=J+1 8147 IF(J.GT.NCR)GOTO1660 8148 IF(IR(J).EQ.'+ ')GOTO1660 8149 IF(IR(J).EQ.'- ')GOTO1660 8150 IF(IR(J).EQ.'* ')GOTO1660 8151 IF(IR(J).EQ.'/ ')GOTO1660 8152 IF(IR(J).EQ.'( ')NLPWP=NLPWP+1 8153 IF(IR(J).EQ.') ')NRPWP=NRPWP+1 8154 IF(IR(J).EQ.') '.AND.NRPWP.GT.NLPWP)GOTO1660 8155 IF(IR(J).EQ.', ')GOTO1660 8156 ILOOP=ILOOP+1 8157 IF(ILOOP.LE.NUMAS2)GOTO1650 8158 WRITE(ICOUT,1656)NUMAS2 8159 1656 FORMAT('***** ERROR IN COMPID--PARAMETER NAME EXCEEDS ',I8, 8160 1'CHARACTERS') 8161 CALL DPWRST('XXX','BUG ') 8162 DO1657K=JMIN,J 8163 WRITE(ICOUT,1658)K,IR(K) 8164 1658 FORMAT('K,IR(K) = ',I8,2X,A4) 8165 CALL DPWRST('XXX','BUG ') 8166 1657 CONTINUE 8167 IERROR='YES ' 8168 GOTO9000 8169 1660 CONTINUE 8170 JMAX=J-1 8171 GOTO1800 8172C 8173 1800 CONTINUE 8174C 8175C CHECK THAT NW HAS NOT EXCEEDED MAXCHA (USUALLY 80) 8176C 8177 IF(NW.LE.MAXCHA)GOTO1900 8178 WRITE(ICOUT,1901) 8179 1901 FORMAT('***** ERROR IN COMPID--') 8180 CALL DPWRST('XXX','BUG ') 8181 WRITE(ICOUT,1902) 8182 1902 FORMAT(' THE VARIABLE NW HAS JUST EXCEEDED') 8183 CALL DPWRST('XXX','BUG ') 8184 WRITE(ICOUT,1903) 8185 1903 FORMAT(' THE MAX ALLOWABLE LIMIT DEFINED ', 8186 1'BY THE INTERNAL VARIABLE MAXCHA.') 8187 CALL DPWRST('XXX','BUG ') 8188 WRITE(ICOUT,1904)MAXCHA 8189 1904 FORMAT(' THIS LIMIT IS MAXCHA = ',I8) 8190 CALL DPWRST('XXX','BUG ') 8191 WRITE(ICOUT,1905)NUMCHA 8192 1905 FORMAT(' THE INPUT NUMBER OF CHARACTERS NUMCHA = ',I8) 8193 CALL DPWRST('XXX','BUG ') 8194 IF(NUMCHA.GE.1)WRITE(ICOUT,1906)(IA(I),I=1,NUMCHA) 8195 1906 FORMAT(' INPUT EXPRESSION--',100A1) 8196 IF(NUMCHA.GE.1)CALL DPWRST('XXX','BUG ') 8197 WRITE(ICOUT,1907) 8198 1907 FORMAT(' THE NUMBER OF (PACKED) CHARACTERS ON ', 8199 1'RIGHT-HAND SIDE NCR = ',I8) 8200 CALL DPWRST('XXX','BUG ') 8201 IF(NCR.GE.1)WRITE(ICOUT,1908)(IR(I),I=1,NCR) 8202 1908 FORMAT(' (PACKED) RIGHT-HAND SIDE--',95A1) 8203 IF(NCR.GE.1)CALL DPWRST('XXX','BUG ') 8204 IERROR='YES ' 8205 GOTO9000 8206 1900 CONTINUE 8207C 8208 IBEGIN(NW)=JMIN 8209 IEND(NW)=JMAX 8210 I=JMAX 8211C 8212 I=I+1 8213 IF(I.LE.NCR)GOTO1050 8214C 8215C TEST THAT NW IS POSITIVE. 8216C 8217 IF(NW.GE.1)GOTO1959 8218 WRITE(ICOUT,1951)NW 8219 1951 FORMAT('***** ERROR IN COMPID--NW IS NON-POSITIVE. ', 8220 1'NW = ',I8) 8221 CALL DPWRST('XXX','BUG ') 8222 IERROR='YES ' 8223 GOTO9000 8224 1959 CONTINUE 8225C 8226 IF(NW.EQ.1)GOTO1969 8227 DO1960I=1,NW 8228 IP1=I+1 8229 IF(ITYPE(I).EQ.'LF '.AND.ITYPE(IP1).NE.'LP ')GOTO1961 8230 GOTO1960 8231 1961 CONTINUE 8232 WRITE(ICOUT,1962) 8233 CALL DPWRST('XXX','BUG ') 8234 WRITE(ICOUT,1963)NW 8235 CALL DPWRST('XXX','BUG ') 8236 WRITE(ICOUT,1964)I 8237 CALL DPWRST('XXX','BUG ') 8238 WRITE(ICOUT,1965)ITYPE(I) 8239 CALL DPWRST('XXX','BUG ') 8240 WRITE(ICOUT,1966)ITYPE(IP1) 8241 1962 FORMAT('***** ERROR IN COMPID--LIBRARY FUNCTION ', 8242 1'NOT FOLLOWED BY A LEFT PARENTHESES') 8243 CALL DPWRST('XXX','BUG ') 8244 1963 FORMAT(' NW = ',I8) 8245 1964 FORMAT(' I = ',I8) 8246 1965 FORMAT(' ITYPE(I) = ',A4) 8247 1966 FORMAT(' ITYPE(I+1) = ',A4) 8248 IERROR='YES ' 8249 GOTO9000 8250 1960 CONTINUE 8251 1969 CONTINUE 8252C 8253 IF(ITYPE(NW).EQ.'OP ')GOTO1970 8254 IF(ITYPE(NW).EQ.'LF ')GOTO1972 8255 GOTO1979 8256C 8257 1970 CONTINUE 8258 WRITE(ICOUT,1971)ITYPE(NW) 8259 1971 FORMAT('***** ERROR IN COMPID--LAST TERM IN TOTAL ', 8260 1' EXPRESSION IS AN OPERATION = ',A4) 8261 CALL DPWRST('XXX','BUG ') 8262 IERROR='YES ' 8263 GOTO9000 8264 1972 CONTINUE 8265 WRITE(ICOUT,1973)ITYPE(NW) 8266 1973 FORMAT('***** ERROR IN COMPID--LAST TERM IN TOTAL ', 8267 1' EXPRESSION = A LIBRARY FUNCTION = ',A4) 8268 CALL DPWRST('XXX','BUG ') 8269 IERROR='YES ' 8270 GOTO9000 8271 1979 CONTINUE 8272C 8273 IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO1999 8274 ISTEPN='4' 8275 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8276 WRITE(ICOUT,1991)NW,ICMIN 8277 1991 FORMAT('NW,ICMIN = ',2I8) 8278 CALL DPWRST('XXX','BUG ') 8279 DO1992I=1,NW 8280 ICMIN=IBEGIN(I) 8281 ICMINP=ICMIN+1 8282 ICMINQ=ICMIN+2 8283 WRITE(ICOUT,1993)I,IR(ICMIN),IR(ICMINP),IR(ICMINQ),ITYPE(I), 8284 1IBEGIN(I),IEND(I) 8285 1993 FORMAT('I,IR(ICMIN),IR(ICMIN+1),IR(ICMIN+2),ITYPE(I),', 8286 1'IBEGIN(I),IEND(I) = ',I8,2X,3A4,A4,2X,I8,2X,I8) 8287 CALL DPWRST('XXX','BUG ') 8288 1992 CONTINUE 8289 1999 CONTINUE 8290C 8291C **************************************************************** 8292C ** STEP 5-- 8293C ** OPERATE ON EACH COMPONENT OF THE VECTOR IR(.). 8294C ** CONVERT THE NUMBERS TO FLOATING POINT VALUES. 8295C ** CONVERT THE PARAMETERS TO FLOATING POINT VALUES. 8296C * SET THE X TO A DUMMY VALUE OF 0.0 FOR THE TIME BEING. ** 8297C ** CONVERT THE OPERATIONS INTO A 1-WORD REPRESENTATION. 8298C ** 'CONVERT' THE PARENTHESES INTO A 1-WORD REPRESENTATION. 8299C ** CONVERT THE COEFFICIENTS TO COEFFICIENT VALUES. 8300C ** CONVERT THE LIBRARY FUNCTIONS INTO A 1-WORD REPRESENTATION. 8301C ** SAVE THE CONTENTS OF ITYPE, IW2, AND W2 IN 8302C ** ITYPEH, IW21HO, AND WHOLD FOR LATER USE 8303C ** IN REDEFINING ITYPE, IW2, AND W2 FOR EACH NEW X VALUE. 8304C ** OUTPUT THE VECTORS IW2 AND W2. 8305C ** OUTPUT THE VECTORS IW21HO, W2HOLD, AND ITYPEH. 8306C **************************************************************** 8307C 8308CCCCC IC=0 APRIL 29, 1986 8309 IC3=0 8310 DO3000I=1,NW 8311 ICMIN=IBEGIN(I) 8312 ICMAX=IEND(I) 8313 IF(ITYPE(I).EQ.'N ')GOTO3100 8314 IF(ITYPE(I).EQ.'X ')GOTO3200 8315 IF(ITYPE(I).EQ.'OP ')GOTO3300 8316 IF(ITYPE(I).EQ.'LP '.OR.ITYPE(I).EQ.'RP ')GOTO3400 8317 IF(ITYPE(I).EQ.'PAR ')GOTO3500 8318 IF(ITYPE(I).EQ.'LF ')GOTO3600 8319 IF(ITYPE(I).EQ.'COM ')GOTO3700 8320 WRITE(ICOUT,3005) 8321 3005 FORMAT('***** ERROR IN COMPID--ITYPE(I) NOT X, OP, LP, PAR, ', 8322 1'OR LF') 8323 CALL DPWRST('XXX','BUG ') 8324 WRITE(ICOUT,3006)I,ITYPE(I),IW21(I),W2(I) 8325 3006 FORMAT('I,ITYPE(I),IW21(I),W2(I) = ', 8326 1I8,2X,A4,2X,A4,2X,E15.7) 8327 CALL DPWRST('XXX','BUG ') 8328 IERROR='YES ' 8329 GOTO9000 8330C 8331 3100 CONTINUE 8332CCCCC IC=IC+1 APRIL 29, 1986 8333 IC3=IC3+1 8334CCCCC IW21(I)=IC 8335CCCCC CALL DPC4IH(IC,IW21(I),IBUGEV,IERROR) APRIL 29, 1986 8336 CALL DPC4IH(IC3,IW21(I),IBUGEV,IERROR) 8337 IW22(I)=' ' 8338 W2(I)=0.0 8339 IANS1=' ' 8340 IANS2=' ' 8341 IANS3=' ' 8342 IANS4=' ' 8343 J=0 8344 DO3150IC=ICMIN,ICMAX 8345 J=J+1 8346 JM1=J-1 8347 L=J-(NUMASC*(JM1/NUMASC)) 8348 K=NUMBPC*(L-1) 8349 K=IABS(K) 8350CCCCC WRITE(ICOUT,3333)J,JM1,L,K,IR(IC) 8351C3333 FORMAT('J,JM1,L,K,IR(IC) = ',4I8,2X,A4) 8352CCCCC CALL DPWRST('XXX','BUG ') 8353 IF(J.LE.NUMASC)GOTO3151 8354 IF(J.LE.NUMAS2)GOTO3152 8355 IF(J.LE.NUMAS3)GOTO3153 8356 IF(J.LE.NUMAS4)GOTO3154 8357 GOTO3155 8358 3151 CONTINUE 8359 CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS1) 8360 GOTO3155 8361 3152 CONTINUE 8362 CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS2) 8363 GOTO3155 8364 3153 CONTINUE 8365 CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS3) 8366 GOTO3155 8367 3154 CONTINUE 8368 CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS4) 8369 GOTO3155 8370 3155 CONTINUE 8371CCCCC WRITE(ICOUT,4444)IANS1,IANS2,IANS3,IANS4 8372C4444 FORMAT(4A4) 8373CCCCC CALL DPWRST('XXX','BUG ') 8374 3150 CONTINUE 8375 CALL ERRORF(IANS1,IANS2,IANS3,IANS4,-1000000000.0,1000000000.0, 8376 11000000000.0,ANS2,IERROR) 8377 IF(IERROR.EQ.'YES ')GOTO9000 8378 W2(I)=ANS2 8379 GOTO3000 8380C 8381 3200 CONTINUE 8382 W2(I)=0.0 8383 GOTO3000 8384C 8385 3300 CONTINUE 8386 IW21(I)=IR(ICMIN) 8387 IW22(I)=' ' 8388 ICMINP=ICMIN+1 8389 IF(IR(ICMIN).EQ.'* '.AND.IR(ICMINP).EQ.'* ')IW21(I)='** ' 8390 IF(IR(ICMIN).EQ.'* '.AND.IR(ICMINP).EQ.'* ')IW22(I)=' ' 8391 GOTO3000 8392C 8393 3400 CONTINUE 8394 IW21(I)=IR(ICMIN) 8395 IW22(I)=' ' 8396 GOTO3000 8397C 8398 3500 CONTINUE 8399 IW21(I)=' ' 8400 IW22(I)=' ' 8401 ICMAX2=ICMIN+NUMAS2-1 8402 IF(ICMAX.LE.ICMAX2)ICMAX2=ICMAX 8403 J=0 8404 DO3530IC=ICMIN,ICMAX2 8405 J=J+1 8406 J2=J 8407 IF(J2.GT.NUMASC)J2=J-NUMASC 8408 ISTAR3=NUMBPC*(J2-1) 8409 ISTAR3=IABS(ISTAR3) 8410 IF(J.LE.NUMASC)CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW21(I)) 8411 IF(J.GT.NUMASC)CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW22(I)) 8412 3530 CONTINUE 8413C 8414 IF(IPASS.EQ.1)GOTO3000 8415C 8416 IF(NUMPAR.LE.0)GOTO3559 8417 DO3550J=1,NUMPAR 8418 IF(IW21(I).EQ.IPARN1(J).AND.IW22(I).EQ.IPARN2(J))GOTO3555 8419 3550 CONTINUE 8420 GOTO3559 8421 3555 CONTINUE 8422 W2(I)=PARAM(J) 8423 GOTO3000 8424 3559 CONTINUE 8425C 8426 IF(NUMVAR.LE.0)GOTO3569 8427 DO3560J=1,NUMVAR 8428 IF(IW21(I).EQ.IPARN1(J).AND.IW22(I).EQ.IPARN2(J))GOTO3565 8429 3560 CONTINUE 8430 3565 CONTINUE 8431 W2(I)=0.0 8432 ITYPE(I)='VAR ' 8433 GOTO3000 8434 3569 CONTINUE 8435C 8436 WRITE(ICOUT,3571) 8437 3571 FORMAT('***** ERROR IN COMPID--NO MATCH FOR PARAM./VAR. NAME') 8438 CALL DPWRST('XXX','BUG ') 8439 WRITE(ICOUT,3572)IW21(I),IW22(I) 8440 3572 FORMAT(' GIVEN PARAM./VAR. NAME = ',2A4) 8441 CALL DPWRST('XXX','BUG ') 8442 WRITE(ICOUT,3573)NUMPAR 8443 3573 FORMAT(' NUMBER OF PARAM./VAR. =',I8) 8444 CALL DPWRST('XXX','BUG ') 8445 WRITE(ICOUT,3574) 8446 3574 FORMAT(' ADMISSIBLE PARAM./VAR. ', 8447 1'NAMES = ') 8448 CALL DPWRST('XXX','BUG ') 8449 DO3575J=1,NUMPAR 8450 WRITE(ICOUT,3576)J,IPARN1(J),IPARN2(J) 8451 3576 FORMAT(' PARAM./VAR. NAME ',I4,'-- ', 8452 12A4) 8453 CALL DPWRST('XXX','BUG ') 8454 3575 CONTINUE 8455 WRITE(ICOUT,3577)(IA(J),J=1,NUMCHA) 8456 3577 FORMAT(' FUNCTION EXPRESSION--',100A1) 8457 CALL DPWRST('XXX','BUG ') 8458 IERROR='YES ' 8459 GOTO9000 8460C 8461 3600 CONTINUE 8462 IW21(I)=' ' 8463 IW22(I)=' ' 8464 ICMAX2=ICMIN+NUMAS2-1 8465 IF(ICMAX.LE.ICMAX2)ICMAX2=ICMAX 8466 J=0 8467 DO3650IC=ICMIN,ICMAX2 8468 J=J+1 8469 J2=J 8470 IF(J2.GT.NUMASC)J2=J-NUMASC 8471 ISTAR3=NUMBPC*(J2-1) 8472 ISTAR3=IABS(ISTAR3) 8473 IF(J.LE.NUMASC)CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW21(I)) 8474 IF(J.GT.NUMASC)CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW22(I)) 8475 3650 CONTINUE 8476 GOTO3000 8477C 8478 3700 CONTINUE 8479 IW21(I)=IR(ICMIN) 8480 IW22(I)=' ' 8481 GOTO3000 8482C 8483 3000 CONTINUE 8484 NWHOLD=NW 8485 DO3900I=1,NW 8486 ITYPEH(I)=ITYPE(I) 8487 IW21HO(I)=IW21(I) 8488 IW22HO(I)=IW22(I) 8489 W2HOLD(I)=W2(I) 8490 3900 CONTINUE 8491 IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO3999 8492 ISTEPN='5' 8493 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8494 DO3992I=1,NW 8495 ICMIN=IBEGIN(I) 8496 ICMINP=ICMIN+1 8497 ICMINQ=ICMIN+2 8498 WRITE(ICOUT,3993)I,IR(ICMIN),IR(ICMINP),IR(ICMINQ),ITYPE(I), 8499 1IW21(I),IW22(I),W2(I) 8500 3993 FORMAT('I,IR(ICMIN),IR(ICMIN+1),IR(ICMIN+2),ITYPE(I),', 8501 1'IW21(I),IW22HO(I),W2(I) = ',I8,2X,3A4,2X,A4,2X,A4,2X,A4,2X,E15.6) 8502 CALL DPWRST('XXX','BUG ') 8503 3992 CONTINUE 8504 3999 CONTINUE 8505C 8506C **************************************************** 8507C ** STEP 6-- ** 8508C ** THIS STEP IS TO BE EXECUTED IF IPASS=1; ** 8509C ** OTHERWISE IT IS SKIPPED. ** 8510C ** IF THIS STEP IS EXECUTED, STEP 7 IS NOT; ** 8511C ** IF THIS STEP IS NOT EXECUTED, STEP 7 IS. ** 8512C ** OPERATE ON IW2 AND ITYPE VECTORS. ** 8513C ** DETERMINE THE NUMBER OF DISTINCT PARAMETERS. ** 8514C ** FORM THE OUTPUT VECTOR IPARN1. ** 8515C ** CHECK TO SEE IF SOME OF THE PREVIOSULY- ** 8516C ** DEFINED PARAMETERS ARE IN FACT VARIABLES. ** 8517C **************************************************** 8518C 8519 IF(IPASS.EQ.1)GOTO4050 8520 GOTO4999 8521 4050 CONTINUE 8522C 8523 NUMPAR=0 8524 DO4100I=1,NW 8525 IF(ITYPE(I).EQ.'PAR ')GOTO4190 8526 GOTO4100 8527 4190 CONTINUE 8528C 8529 IF(NUMVAR.LE.0)GOTO4290 8530 DO4250J=1,NUMVAR 8531 IF(IW21(I).EQ.IVARN1(J).AND.IW22(I).EQ.IVARN2(J))GOTO4260 8532 4250 CONTINUE 8533 GOTO4290 8534 4260 CONTINUE 8535 ITYPE(I)='VAR ' 8536 GOTO4100 8537 4290 CONTINUE 8538C 8539 IF(NUMPAR.EQ.0)GOTO4300 8540 DO4400J=1,NUMPAR 8541 IF(IW21(I).EQ.IPARN1(J).AND.IW22(I).EQ.IPARN2(J))GOTO4100 8542 4400 CONTINUE 8543 4300 CONTINUE 8544 NUMPAR=NUMPAR+1 8545 IPARN1(NUMPAR)=IW21(I) 8546 IPARN2(NUMPAR)=IW22(I) 8547 4100 CONTINUE 8548C 8549 IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO4599 8550 ISTEPN='6' 8551 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8552 WRITE(ICOUT,4591) 8553 4591 FORMAT('AT END OF STEP 6 FOR PASS 1 (RIGHT BEFORE ', 8554 1'RETURNING TO MAIN ROUTINE FROM COMPID)--') 8555 CALL DPWRST('XXX','BUG ') 8556 DO4592I=1,NW 8557 ICMIN=IBEGIN(I) 8558 ICMINP=ICMIN+1 8559 ICMINQ=ICMIN+2 8560 WRITE(ICOUT,4593)I,IR(ICMIN),IR(ICMINP),IR(ICMINQ),ITYPE(I), 8561 1IW21(I),IW22(I),W2(I) 8562 4593 FORMAT('I,IR(ICMIN),IR(ICMIN+1),IR(ICMIN+2),ITYPE(I),', 8563 1'IW21(I),IW22(I),W2(I) = ',I8,2X,3A4,A4,2X,A4,2X,A4,2X,E15.7) 8564 CALL DPWRST('XXX','BUG ') 8565 4592 CONTINUE 8566 4599 CONTINUE 8567C 8568 GOTO9000 8569 4999 CONTINUE 8570C 8571C **************************************************************** 8572C ** STEP 7-- 8573C ** OPERATE ON THE W2(.) AND IW21(.) VECTORS. 8574C ** THIS STEP IS NOT EXECUTED IF STEP 6 IS; 8575C ** THIS STEP IS EXECUTED IF STEP 6 IS NOT. 8576C ** FIRST MAKE SURE THAT THE NUMBER OF LEFT 8577C ** AND RIGHT PARENTHESES ARE THE SAME. 8578C ** (STEP 6 THEN SETS UP A LARGE DO LOOP 8579C ** WHICH GOES THROUGH ALL OF THE VALUES OF THE X VECTOR 8580C ** AND GENERATES CORRESPONDING VALUES OF THE Y VECTOR.) 8581C ** FOR A GIVEN X VALUE, IT EVALUATES THE FUNCTION 8582C ** BY FIRST SEEKING THE INNERMOST PARENTHESES 8583C ** (BY SEARCHING FOR THE FIRST REMAINING RIGHT PARENTHESS). 8584C ** AND THEN EVALUATING ALL SUCH PARENTHETICAL EXPRESSIONS-- 8585C ** WORKING FROM THE INNERMOST OUT. 8586C ** AFTER EVALUATING A PARENTHESES PAIR, 8587C ** THE ENTIRE PARENTHESES GROUP (PARENTHESES INCLUDED) 8588C ** IS REPLACED BY THE SCALAR ANSWER. 8589C ** THE IW2, W2, AND ITYPE VECTORS ARE SQUEEZED ACCORDINGLY 8590C ** (IN THE SUBROUTINE EVAL). 8591C ** SINCE THE VECTORS IW2, W2, AND ITYPE ARE ALTERED (SQUEEZED) 8592C ** FOR EACH X VALUE, THEY MUST BE REDEFINED FROM THE SAVED 8593C ** VALUES IN IW2, W2, AND ITYPE FOR EACH NEW X VALUE. 8594C ** THE ABOVE SQUEEZING OPERATION IS REPEATED 8595C ** FOR EACH PARENTHESES PAIR UNTIL ALL PARENTHESES 8596C ** ARE GONE AND WE REMAIN ONLY WITH THE FINAL ANSWER. 8597C ** FOR EACH VALUE X(.) OF THE INPUT X VECTOR, 8598C ** OUTPUT THE CORRESPONDING VALUE Y(.) OF 8599C ** THE DESIRED OUTPUT VECTOR. 8600C ** FOR A GIVEN VALUE X(.), THE CORRESPONDING 8601C ** COMPUTED Y(.) WILL BE THE EVALUATED VALUE OF 8602C ** THE RIGHT-HAND SIDE OF THE SPECIFIED EQUATION Y = F(X). 8603C **************************************************************** 8604C 8605 NLP=0 8606 NRP=0 8607 DO5100I=1,NW 8608 IF(ITYPE(I).EQ.'LP ')NLP=NLP+1 8609 IF(ITYPE(I).EQ.'RP ')NRP=NRP+1 8610 5100 CONTINUE 8611 IF(NLP.EQ.NRP)GOTO5190 8612 WRITE(ICOUT,5155) 8613 CALL DPWRST('XXX','BUG ') 8614 WRITE(ICOUT,5156) 8615 CALL DPWRST('XXX','BUG ') 8616 WRITE(ICOUT,5157)NLP 8617 CALL DPWRST('XXX','BUG ') 8618 WRITE(ICOUT,5158)NRP 8619 5155 FORMAT('***** ERROR IN COMPID--') 8620 CALL DPWRST('XXX','BUG ') 8621 5156 FORMAT('NUMBER OF LEFT PARENTHESES NOT EQUAL TO ', 8622 1'NUMBER OF RIGHT PARENTHESES') 8623 5157 FORMAT('NUMBER OF LEFT PARENTHESES = ',I8) 8624 5158 FORMAT('NUMBER OF RIGHT PARENTHESES = ',I8) 8625 IERROR='YES ' 8626 GOTO9000 8627 5190 CONTINUE 8628C 8629CCCCC DO8000II=1,N 8630 NW=NWHOLD 8631 DO5200I=1,NW 8632 ITYPE(I)=ITYPEH(I) 8633 IW21(I)=IW21HO(I) 8634 IW22(I)=IW22HO(I) 8635 W2(I)=W2HOLD(I) 8636C THE FOLLOWING STATEMENT HAS BEEN COMMENTED OUT 8637C IN GOING FROM COMPIL TO COMPID. 8638CCCCC IF(ITYPE(I).EQ.'X ')W2(I)=X(II) 8639 5200 CONTINUE 8640 IF(IBUGCO.EQ.'ON'.OR.ISUBRO.EQ.'RIV4') 8641 1GOTO5249 8642 GOTO5299 8643 5249 CONTINUE 8644 ISTEPN='7' 8645 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8646 DO5250I=1,NW 8647 WRITE(ICOUT,5251)I,IW21HO(I),IW21(I),ITYPE(I) 8648 5251 FORMAT('I,IW21HO(I),IW21(I),ITYPE(I) = ',I8,2X,A4,2X,A4,2X,A4) 8649 CALL DPWRST('XXX','BUG ') 8650 5250 CONTINUE 8651 5299 CONTINUE 8652C 8653C ********************************* 8654C ** STEP 7-- ** 8655C ** DETERMINE THE DERIVATIVE. ** 8656C ********************************* 8657C 8658 CALL DERIV0(IW21,IW22,ITYPE,NW, 8659 1IPARN1,IPARN2,NUMPAR,IVARN1,IVARN2,NUMVAR, 8660 1ICON,ICON1,ICON2,NCON,ID1,ID2,NUMCD2, 8661 1IBUGEV,ISUBRO,IFOUND,IERROR) 8662C 8663 IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO5319 8664 WRITE(ICOUT,999) 8665 CALL DPWRST('XXX','BUG ') 8666 WRITE(ICOUT,5311) 8667 5311 FORMAT('***** IN COMPID, AFTER RETURNING FROM DERIV0--') 8668 CALL DPWRST('XXX','BUG ') 8669 WRITE(ICOUT,5312)NUMCD2 8670 5312 FORMAT(' NUMCD2 = ',I8) 8671 CALL DPWRST('XXX','BUG ') 8672 DO5315I=1,NUMCD2 8673 WRITE(ICOUT,5316)I,ID1(I),ID2(I) 8674 5316 FORMAT(' I,ID1(I),ID2(I) = ',I8,2X,A4,2X,A4) 8675 CALL DPWRST('XXX','BUG ') 8676 5315 CONTINUE 8677 5319 CONTINUE 8678C 8679C *********************************************************** 8680C ** STEP 7.2-- ** 8681C ** FORM THE OUTPUT VECTOR ID(.). ** 8682C ** NOTE THAT ID1(.) AND ID2(.) ARE PARALLEL ** 8683C ** REPRESENTATIONS OF THE DESIRED DERIVATIVE FUNCTION ** 8684C ** (ID1(.) HAS THE FIRST 4 CHARACTERS; ** 8685C ** ID2(.) HAS THE NEXT 4 CHARACTERS). ** 8686C ** MOST COMPONENTS (E.G., +, -, *, /, (, ), ETC.) ** 8687C ** USE ONLY 1 CHARACTER OUT OF THE 8. ** 8688C ** SOME COMPONENTS (NAMELY, **) ** 8689C ** USE 2 CHARACTERS OUT OF THE 8. ** 8690C ** SOME COMPONTENTS (NAMELY, LIBRARY FUNCTIONS) ** 8691C ** USE MANY (3 TO 7) CHARACTERS OUT OF THE 8. ** 8692C ** IN ANY EVENT, THE OUTPUT VECTOR ID(.) WILL BE ** 8693C ** AN UNPACKED (1 CHARACTER PER WORD) SYNTHESIS ** 8694C ** OF THE 2 PACKED \VYYEYC\TYORS Y\I\D1(.) AND ID2(.). ** 8695C *********************************************************** 8696C 8697 ISTEPN='7.2' 8698 IF(IBUGCO.EQ.'ON'.OR.ISUBRO.EQ.'RIV4') 8699 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8700C 8701 J=0 8702 IF(NUMCD2.LE.0)GOTO5639 8703 DO5600I=1,NUMCD2 8704 IF(ID1(I).EQ.' ')GOTO5619 8705 J=J+1 8706 ID3(J)=ID1(I) 8707 5619 CONTINUE 8708 IF(ID2(I).EQ.' ')GOTO5629 8709 J=J+1 8710 ID3(J)=ID2(I) 8711 5629 CONTINUE 8712 5600 CONTINUE 8713 5639 CONTINUE 8714 NUMCH3=J 8715C 8716 IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO5649 8717 WRITE(ICOUT,999) 8718 CALL DPWRST('XXX','BUG ') 8719 WRITE(ICOUT,5641)NUMCD2,NUMCH3 8720 5641 FORMAT('NUMCD2,NUMCH3 = ',2I8) 8721 CALL DPWRST('XXX','BUG ') 8722 DO5645I=1,NUMCH3 8723 WRITE(ICOUT,5646)I,ID3(I) 8724 5646 FORMAT('I,ID3(I) = ',I8,2X,A4) 8725 CALL DPWRST('XXX','BUG ') 8726 5645 CONTINUE 8727 5649 CONTINUE 8728C 8729 K=0 8730 DO5700I=1,NUMCH3 8731 IF(ID3(I).EQ.' ')GOTO5700 8732 CALL DPXH1H(ID3(I),ICH,ILASTC,IBUGEV) 8733 IF(ILASTC.LE.0)GOTO5700 8734 DO5750J=1,ILASTC 8735 K=K+1 8736 ID(K)=ICH(J) 8737 5750 CONTINUE 8738 5700 CONTINUE 8739 NCTOTD=K 8740C 8741 IF(NCTOTD.GE.1)GOTO5789 8742 WRITE(ICOUT,5705)NCTOTD 8743 5705 FORMAT('***** ERROR IN COMPID--TOTAL NUMBER OF CHARACTERS ', 8744 1'IN DERIVATIVE. (INCL. BLANKS, AND EQUAL SIGN) ', 8745 1'IS < 2. NCTOTD = ',I5) 8746 CALL DPWRST('XXX','BUG ') 8747 WRITE(ICOUT,5771)NUMCHD,N,IPASS 8748 5771 FORMAT('NUMCHD,N,IPASS = ',3I8) 8749 CALL DPWRST('XXX','BUG ') 8750 WRITE(ICOUT,5772)(ID(I),I=1,NUMCHD) 8751 5772 FORMAT('ID--',80A1) 8752 CALL DPWRST('XXX','BUG ') 8753 IERROR='YES' 8754 GOTO9000 8755 5789 CONTINUE 8756C 8757 IF(IBUGCO.EQ.'OFF'.AND.ISUBRO.NE.'MPID')GOTO5799 8758 WRITE(ICOUT,5791)NCTOTD 8759 5791 FORMAT('NCTOTD = ',I8) 8760 CALL DPWRST('XXX','BUG ') 8761 DO5792I=1,NCTOTD 8762 WRITE(ICOUT,5793)I,ID(I) 8763 5793 FORMAT('I,ID(I) = ',I8,2X,A4) 8764 CALL DPWRST('XXX','BUG ') 8765 5792 CONTINUE 8766 5799 CONTINUE 8767 NUMCHD=NCTOTD 8768C 8769C ******************************************* 8770C ** STEP 7.3-- ** 8771C ** SIMPLIFY THE FUNCTIONAL EXPRESSION. ** 8772C ******************************************* 8773C 8774 CALL DPSIPA(ID,NUMCHD,IBUGEV,IERROR) 8775 CALL DPSISI(ID,NUMCHD,IBUGEV,IERROR) 8776 CALL DPSIP1(ID,NUMCHD,IBUGEV,IERROR) 8777 CALL DPSIP0(ID,NUMCHD,IBUGEV,IERROR) 8778 CALL DPSIE1(ID,NUMCHD,IBUGEV,IERROR) 8779 CALL DPSIE0(ID,NUMCHD,IBUGEV,IERROR) 8780 CALL DPSIA0(ID,NUMCHD,IBUGEV,IERROR) 8781 CALL DPSIA2(ID,NUMCHD,IBUGEV,ISUBRO,IERROR) 8782 CALL DPSIFL(ID,NUMCHD,IBUGEV,IERROR) 8783C 8784 CALL DPSIPA(ID,NUMCHD,IBUGEV,IERROR) 8785 CALL DPSISI(ID,NUMCHD,IBUGEV,IERROR) 8786 CALL DPSIP1(ID,NUMCHD,IBUGEV,IERROR) 8787 CALL DPSIP0(ID,NUMCHD,IBUGEV,IERROR) 8788 CALL DPSIE1(ID,NUMCHD,IBUGEV,IERROR) 8789 CALL DPSIE0(ID,NUMCHD,IBUGEV,IERROR) 8790 CALL DPSIA0(ID,NUMCHD,IBUGEV,IERROR) 8791 CALL DPSIA2(ID,NUMCHD,IBUGEV,ISUBRO,IERROR) 8792 CALL DPSIFL(ID,NUMCHD,IBUGEV,IERROR) 8793C 8794C ***************** 8795C ** STEP 90-- ** 8796C ** EXIT. ** 8797C ***************** 8798C 8799 9000 CONTINUE 8800C 8801 IF(IBUGCO.EQ.'ON' .OR. ISUBRO.EQ.'MPID')THEN 8802 WRITE(ICOUT,999) 8803 CALL DPWRST('XXX','BUG ') 8804 WRITE(ICOUT,9011) 8805 9011 FORMAT('***** AT THE END OF COMPID--') 8806 CALL DPWRST('XXX','BUG ') 8807 WRITE(ICOUT,9012)IERROR,NUMCHA,NUMCHD 8808 9012 FORMAT('IERROR,NUMCHA,NUMCHD = ',A4,2X,2I8) 8809 CALL DPWRST('XXX','BUG ') 8810 WRITE(ICOUT,9013) 8811 9013 FORMAT('INPUT FUNCTION--') 8812 CALL DPWRST('XXX','BUG ') 8813 WRITE(ICOUT,9016)(IA(J),J=1,NUMCHA) 8814 9016 FORMAT(130A1) 8815 CALL DPWRST('XXX','BUG ') 8816C 8817 WRITE(ICOUT,9022) 8818 9022 FORMAT('OUTPUT DERIVATIVE--') 8819 CALL DPWRST('XXX','BUG ') 8820 DO9025I=1,NUMCHD,12 8821 JMIN=I 8822 JMAX=JMIN+11 8823 IF(JMAX.GT.NUMCHD)JMAX=NUMCHD 8824 WRITE(ICOUT,9026)(ID(J),J=JMIN,JMAX) 8825 9026 FORMAT(12A4) 8826 CALL DPWRST('XXX','BUG ') 8827 9025 CONTINUE 8828C 8829 ENDIF 8830C 8831 RETURN 8832 END 8833 SUBROUTINE COMPIM(IA,NUMCHA,IPASS,PARAM,IPARN1,IPARN2,NUMPAR, 8834 1 IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,Y, 8835 1 IBUGCO,IBUGEV,IERROR) 8836C 8837C PURPOSE--THIS SUBROUTINE INTERPRETS AND EVALUATES A FORTRAN 8838C MATHEMATICAL FUNCTION EXPRESSION OF THE FORM 8839C Y=F(.,.,.,.,...). IT IS A GENERALIZATION OF JJF7.COMPIL 8840C WHICH COULD HANDLE ONLY 1 ARGUMENT (X). THIS SUBROUTINE 8841C IS TYPICALLY ENTERED WITH TWO PASSES-- 8842C THE FIRST PASS ANALYZES THE STRING AND HAS AS ITS OUTPUT 8843C THE HOLLERITH NAMES OF THE VARIOUS PARAMETERS. A 8844C 'PARAMETER' IN THIS SUBROUTINE (COMPIM) MEANS ANY USUAL 8845C PARAMETER IN AN EXPRESSION AS WELL AS ANY VARIABLE NAME 8846C (E.G., X1, X2, X3, TEMP, RES, ETC.) THIS IS A FUNDAMENTAL 8847C WAY THAT COMPIM DIFFERS FROM COMPIL. ALSO, COMPIM OUTPUTS 8848C ONLY A COMPUTED SCALAR VALUE (AS OPPOSED TO COMPIL WHICH 8849C OUTPUTS AN ENTIRE COMPUTED VECTOR). THESE NAMES ARE 8850C OUTPUTTED IN THIS FIRST PASS AS ELEMENTS IN THE VECTORS 8851C IPARN1 AND IPARN2. THE SECOND PASS USES INPUT PARAMETER 8852C VALUES (INPUTTED IN THE VECTOR PARAM) TO ACTUALLY EVALUATE 8853C THE FUNCTION (OUTPUTTED IN THE SCALAR Y). NOTE THAT IF 8854C SOME OF THE 'PARAMETERS' ARE IN FACT ELEMENTS OF A VECTOR 8855C VARIABLE, THE ITERATING THROUGH THE ENTIRE VECTOR IS DONE 8856C IN THE CALLING SUBROUTINE AND NOT WITHIN COMPIM 8857C (THIS IS ANOTHER WAY THAT COMPIM DIFFERS FROM COMPIL). 8858C INPUT ARGUMENTS--IA = THE INTEGER VECTOR WHICH CONTAINS 8859C THE HOLLERITH CHARACTERS WHICH 8860C MAKE UP THE LINE OF FORTRAN CODE. 8861C THIS VECTOR CONTAINS THE STRING 8862C TO BE OPERATED ON, INTERPRETED, 8863C AND EVALUATED. 8864C --NUMCHA = THE INTEGER VALUE WHICH 8865C DEFINES THE NUMBER OF CHARACTERS IN IA. 8866C NUMCHA DEFINES THE LENGTH OF THE 8867C HOLLERITH STRING TO BE OPERATED ON, 8868C INTERPRETED, AND EVALUATED. 8869C --IPASS = AN INTEGER FLAG CODE 8870C WHICH DEFINES WHICH PASS (1 OR 2) INTO THIS 8871C SUBROUTINE THE USER IS IN. 8872C PASS 1 DETERMINE PARAMETER NAMES; 8873C PASS 2 DOES FUNCTION EVALUATIONS. 8874C --PARAM = THE SINGLE PRECISION VECTOR OF PARAMETER 8875C (AND VARIABLE) 8876C VALUES CORRESPONDING TO THE PARAMETER NAMES 8877C AS GIVEN IN THE VECTOR IPARN. 8878C --IPARN1 = THE INTEGER VECTOR 8879C CONTAINING CHARACTERS 1 THROUGH 4 8880C OF PARAMETER (AND VARIABLE) 8881C NAMES AS TYPICALLY DETERMINED BY PASS 1. 8882C --IPARN2 = THE INTEGER VECTOR 8883C CONTAINING CHARACTERS 5 THROUGH 8 8884C OF PARAMETER (AND VARIABLE) 8885C NAMES AS TYPICALLY DETERMINED BY PASS 1. 8886C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION COMPUTED SCALAR VALUE OF 8887C THE FUNCTION AS DETERMINED BY PASS 2 8888C AND WHICH CONSTITUTE THE ULTIMATE 8889C OUTPUT FROM THIS SUBROUTINE. 8890C THAT IS, SYMBOLICALLY, 8891C Y = F(X1,X2,X3,TEMP,RES,ETC.,PAR1,PAR2,PAR3,ETC 8892C OUTPUT--THE SINGLE PRECISION COMPUTED SCALAR VALUE, 8893C PRINTING--NONE. 8894C RESTRICTIONS--NONE. 8895C OTHER SUBROUTINES NEEDED--EVAL 8896C FORTRAN LIBRARY SUBROUTINES NEEDED--(ALL IN EVAL) 8897C SQRT 8898C EXP 8899C LOG 8900C LOG10 8901C SIN 8902C COS 8903C ATAN 8904C ATAN2 8905C TANH 8906C ABS 8907C AINT 8908C ARCSIN 8909C ARCCOS 8910C ARCTAN 8911C OCTAL 8912C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 8913C LANGUAGE--ANSI FORTRAN (1977) 8914C NOTE--THIS SUBROUTINE ALLOWS ONE TO PERFORM 8915C INTERACTIVE FUNCTION EVALUATIONS. 8916C REFERENCES--NONE. 8917C WRITTEN BY--JAMES J. FILLIBEN 8918C STATISTICAL ENGINEERING DIVISION 8919C INFORMATION TECHNOLOGY LABORATORY 8920C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 8921C GAITHERSBURG, MD 20899 8922C PHONE--301-975-2855 8923C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 8924C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 8925C LANGUAGE--ANSI FORTRAN (1966) 8926C VERSION NUMBER--82/7 8927C ORIGINAL VERSION--NOVEMBER 1976. 8928C UPDATED --FEBRUARY 1977. 8929C UPDATED --DECEMBER 1977. 8930C UPDATED --JANUARY 1978. 8931C UPDATED --JULY 1978. 8932C UPDATED --OCTOBER 1978. 8933C UPDATED --DECEMBER 1978. 8934C UPDATED --JANUARY 1979. 8935C UPDATED --FEBRUARY 1979. 8936C UPDATED --JULY 1979. 8937C UPDATED --JANUARY 1981. 8938C UPDATED --FEBRUARY 1981. 8939C UPDATED --JUNE 1981. 8940C UPDATED --JANUARY 1981. 8941C UPDATED --MARCH 1982. 8942C UPDATED --MAY 1982. 8943C UPDATED --JUNE 1986. 8944C UPDATED --DECEMBER 1988. BLANK OUT IR(.) FOR AT LEAST 10 CHAR 8945C UPDATED --SEPTEMBER 1994. ADD SAVE4 ARGUMENT TO EVALM. 8946C UPDATED --APRIL 1995. BUG: 8947C LET A = TPDF(X,2) - TPDF(X,3) 8948C SETS SAVE1 TO 2 IN BOTH CASES 8949C UPDATED --MAY 1998. ADD FIFTH PARAMETER 8950C UPDATED --JUNE 2003. ADD SAVE6, SAVE7, SAVE8 8951C ARGUMENTS TO EVALM. 8952C UPDATED --FEBRUARY 2005. CONVERT STRING TO UPPER CASE 8953C UPDATED --DECEMBER 2010. INITIALIZATION OF SAVE1 ... 8954C SAVE8 8955C 8956C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 8957C 8958 CHARACTER*4 IA 8959 CHARACTER*4 IPARN1 8960 CHARACTER*4 IPARN2 8961 CHARACTER*4 IANGLU 8962 CHARACTER*4 ITYPEH 8963 CHARACTER*4 IW21HO 8964 CHARACTER*4 IW22HO 8965 CHARACTER*4 IBUGCO 8966 CHARACTER*4 IBUGEV 8967 CHARACTER*4 IERROR 8968C 8969 CHARACTER*4 ISUBN1 8970 CHARACTER*4 ISUBN2 8971 CHARACTER*4 ISTEPN 8972C 8973 CHARACTER*4 IR 8974 CHARACTER*4 IB 8975 CHARACTER*4 IL 8976 CHARACTER*4 ICH 8977 CHARACTER*4 IW21 8978 CHARACTER*4 IW22 8979 CHARACTER*4 ITYPE 8980 CHARACTER*4 IANS1 8981 CHARACTER*4 IANS2 8982 CHARACTER*4 IANS3 8983 CHARACTER*4 IANS4 8984 CHARACTER*4 IFOUND 8985C 8986C--------------------------------------------------------------------- 8987C 8988 DIMENSION IA(*) 8989 DIMENSION PARAM(*) 8990 DIMENSION IPARN1(*) 8991 DIMENSION IPARN2(*) 8992C 8993C NOTE--THE DIMENSIONS OF ITYPEH, IW21HO, IW22HO, AND W2HOLD 8994C WHICH ARE DEFINED IN THE MAIN PROGRAM 8995C SHOULD BE AT LEAST AS LARGE AS THE DIMENSIONS 8996C OF IW2 AND IW22 BELOW. 8997C 8998 DIMENSION ITYPEH(*) 8999 DIMENSION IW21HO(*) 9000 DIMENSION IW22HO(*) 9001 DIMENSION W2HOLD(*) 9002C 9003C NOTE--THE DIMENSION OF IB SHOULD BE THE SAME AS 9004C THE DIMENSION OF SUBROUTINE IA IN DPLET. 9005C 9006 PARAMETER (MAXCHA=1000) 9007C 9008 DIMENSION IB(MAXCHA) 9009 DIMENSION IR(MAXCHA) 9010 DIMENSION IBEGIN(MAXCHA) 9011 DIMENSION IEND(MAXCHA) 9012 DIMENSION ITYPE(MAXCHA) 9013 DIMENSION IW21(MAXCHA) 9014 DIMENSION IW22(MAXCHA) 9015 DIMENSION W2(MAXCHA) 9016C 9017 DIMENSION ICH(10) 9018 DIMENSION IL(10) 9019C 9020CCCCC ADD FOLLOWING SECTION APRIL 1995. 9021C 9022 PARAMETER(MAXNST=25) 9023 DIMENSION SAVE1(MAXNST) 9024 DIMENSION SAVE2(MAXNST) 9025 DIMENSION SAVE3(MAXNST) 9026 DIMENSION SAVE4(MAXNST) 9027 DIMENSION SAVE5(MAXNST) 9028 DIMENSION SAVE6(MAXNST) 9029 DIMENSION SAVE7(MAXNST) 9030 DIMENSION SAVE8(MAXNST) 9031C 9032C--------------------------------------------------------------------- 9033C 9034 INCLUDE 'DPCOP2.INC' 9035C 9036C-----DATA STATEMENTS------------------------------------------------- 9037C 9038C DEFINE THE UPPER LIMIT OF THE NUMBER OF CHARACTERS THAT MAY BE 9039C PROCESSED BY THIS SUBROUTINE (COUNTING BLANKS, LEFT-HAND SIDE, 9040C EQUAL SIGN, AND RIGHT HAND SIDE). IF RESTRICT THE EXPRESSION TO 1 9041C LINE IMAGE, THEN A REASONABLE UPPER BOUND IS 80. WHATEVER UPPER 9042C BOUND IS SET, THE DIMENSIONS OF MOST OF THE VECTORS MUST BE EQUAL 9043C OR LARGER TO THIS NUMBER. (THE VECTOR IL(.) WHICH CONTAINS THE 9044C NUMBER OF CHARACTERS TO THE LEFT OF THE EQUAL SIGN (BLANKS IGNORED) 9045C MAY BE MUCH SMALLER--LIKE 6.) 9046C NOTE--AS OF JANUARY 1979, THE BOUND WAS RESET TO 150. 9047C 9048CCCCC DATA MAXCHA/150/ 9049CCCCC DATA MAXCHA/225/ 9050CCCCC DATA MAXCHA/1000/ 9051C 9052C-----START POINT----------------------------------------------------- 9053C 9054 ISUBN1='COMP' 9055 ISUBN2='IM ' 9056C 9057 IERROR='NO' 9058C 9059C THE FOLLOWING STATEMENT (N=1) HAS BEEN ADDED IN CONVERTING 9060C THE COMPIL SUBROUTINE TO THE COMPIM SUBROUTINE. 9061C 9062 N=1 9063C 9064 IF(IBUGCO.EQ.'ON')THEN 9065 WRITE(ICOUT,999) 9066 999 FORMAT(1X) 9067 CALL DPWRST('XXX','BUG ') 9068 WRITE(ICOUT,51) 9069 51 FORMAT('***** AT THE BEGINNING OF COMPIM--') 9070 CALL DPWRST('XXX','BUG ') 9071 WRITE(ICOUT,52)NUMCHA,N,IPASS,IANGLU,IBUGCO,IBUGEV 9072 52 FORMAT('NUMCHA,N,IPASS,IANGLU,IBUGCO,IBUGEV = ',3I8,3(2X,A4)) 9073 CALL DPWRST('XXX','BUG ') 9074 WRITE(ICOUT,53)(IA(I),I=1,MIN(80,NUMCHA)) 9075 53 FORMAT('IA--',80A1) 9076 CALL DPWRST('XXX','BUG ') 9077 WRITE(ICOUT,999) 9078 CALL DPWRST('XXX','BUG ') 9079 WRITE(ICOUT,61)NUMPAR 9080 61 FORMAT('NUMPAR = ',I8) 9081 CALL DPWRST('XXX','BUG ') 9082 IF(NUMPAR.GE.1)THEN 9083 DO62I=1,NUMPAR 9084 WRITE(ICOUT,63)I,IPARN1(I),IPARN2(I),PARAM(I) 9085 63 FORMAT('I,IPARN1(I),IPARN2(I),PARAM(I) = ',I8,2(2X,A4),2X, 9086 1 F15.7) 9087 CALL DPWRST('XXX','BUG ') 9088 62 CONTINUE 9089 ENDIF 9090 WRITE(ICOUT,999) 9091 CALL DPWRST('XXX','BUG ') 9092 WRITE(ICOUT,71)NWHOLD 9093 71 FORMAT('NWHOLD = ',I8) 9094 CALL DPWRST('XXX','BUG ') 9095 IF(NWHOLD.GE.1)THEN 9096 DO72I=1,NWHOLD 9097 WRITE(ICOUT,73)I,ITYPEH(I),IW21HO(I),IW22HO(I),W2HOLD(I) 9098 73 FORMAT('I,ITYPEH(I),IW21HO(I),IW22HO(I),W2HOLD(I) = ', 9099 1 I8,3(2X,A4),2X,F15.7) 9100 CALL DPWRST('XXX','BUG ') 9101 72 CONTINUE 9102 ENDIF 9103 WRITE(ICOUT,81)IPASS,NW 9104 81 FORMAT('IPASS,NW = ',2I8) 9105 CALL DPWRST('XXX','BUG ') 9106 IF(NW.GE.1)THEN 9107 WRITE(ICOUT,82)ITYPE(NW) 9108 82 FORMAT('ITYPE(NW) = ',A4) 9109 CALL DPWRST('XXX','BUG ') 9110 ENDIF 9111 ENDIF 9112C 9113C ********************************************************** 9114C ** DEFINE NUMASC = NUMBER OF ASCII CHARACTERS PER WORD.** 9115C ** THIS IS 4 REGARDLESS OF THE COMPUTER MAKE AND ** 9116C ** REGARDLESS OF THE WORD SIZE. ** 9117C ********************************************************** 9118C 9119 NUMASC=4 9120 NUMAS2=2*NUMASC 9121 NUMAS3=3*NUMASC 9122 NUMAS4=4*NUMASC 9123C 9124C IF IPASS = 2, SKIP ALL OF THE PRELIMINARY CODE 9125C AND JUMP TO CALCULATIVE PART OF CODE. 9126C 9127 IF(IPASS.EQ.2)GOTO5000 9128C 9129C CHECK THAT THE INPUT NUMBER OF CHARACTERS NUMCHA 9130C (INCLUDING LEFT SIDE, RIGHT SIDE, EQUAL SIGN, 9131C AND BLANKS) IS AT LEAST 1 AND AT MOST MAXCHA 9132C (WHERE MAXCHA IS THE INTERNALLY DEFINED VARIABLE 9133C WHICH CONTROLS DIMENSION SIZES AND WHICH 9134C TYPICALLY HAS THE VALUE 80). 9135C 9136 IF(NUMCHA.LT.1 .OR. NUMCHA.GT.MAXCHA)THEN 9137 WRITE(ICOUT,21) 9138 21 FORMAT('***** ERROR IN COMPIM--') 9139 CALL DPWRST('XXX','BUG ') 9140 WRITE(ICOUT,22) 9141 22 FORMAT(' THE NUMBER OF CHARACTERS NUMCHA WHICH DEFINES ', 9142 1 'THE LENGTH') 9143 CALL DPWRST('XXX','BUG ') 9144 WRITE(ICOUT,24) 9145 24 FORMAT(' OF THE INPUT EXPRESSION (INCLUDING LEFT-HAND ', 9146 1 'SIDE,') 9147 CALL DPWRST('XXX','BUG ') 9148 WRITE(ICOUT,25) 9149 25 FORMAT(' RIGHT-HAND SIDE, EQUAL SIGN, AND ALL BLANKS) IS') 9150 CALL DPWRST('XXX','BUG ') 9151 WRITE(ICOUT,26) 9152 26 FORMAT(' LESS THAN 1 OR LARGER THAN MAXCHA (MAXCHA IS AN') 9153 CALL DPWRST('XXX','BUG ') 9154 WRITE(ICOUT,28)MAXCHA 9155 28 FORMAT(' INTERNALLY DEFINED VARIABLE WHICH HAS THE ', 9156 1 'VALUE = ',I8,' .') 9157 CALL DPWRST('XXX','BUG ') 9158 WRITE(ICOUT,30)NUMCHA 9159 30 FORMAT(' THE NUMBER OF CHARACTERS IN THE INPUT ', 9160 1 'EXPRESSION IS ',I8) 9161 CALL DPWRST('XXX','BUG ') 9162 IF(NUMCHA.GE.1)THEN 9163 WRITE(ICOUT,31)(IA(I),I=1,MIN(100,NUMCHA)) 9164 31 FORMAT(' INPUT EXPRESSION--',100A1) 9165 CALL DPWRST('XXX','BUG ') 9166 ENDIF 9167 IERROR='YES' 9168 GOTO9000 9169 ENDIF 9170C 9171CCCCC FEBRUARY 2005. CONVERT INPUT FUNCTION TO ALL UPPER CASE. 9172CCCCC THIS IS TO ADDRESS ISSUE WHERE IF FUNCTION 9173CCCCC WAS DEFINED AS "LET STRING" RATHER THAN 9174CCCCC "LET FUNCTION", CASE IS PRESERVED. HOWEVER, 9175CCCCC WHEN EVALUATING FUNCTION, WE NEED THE STRING 9176CCCCC TO BE EVALUATED IN UPPER CASE. 9177C 9178 DO91I=1,NUMCHA 9179 ITEMP=ICHAR(IA(I)(1:1)) 9180 IF(ITEMP.GE.97 .AND. ITEMP.LE.122)THEN 9181 ITEMP=ITEMP-32 9182 IA(I)(1:1)=CHAR(ITEMP) 9183 ENDIF 9184 91 CONTINUE 9185C 9186C BLANK-OUT AND ZERO-OUT SOME VARIABLES AND VECTORS. 9187C 9188 Y=0.0 9189 DO160I=1,NUMCHA 9190 IR(I)=' ' 9191 IB(I)=' ' 9192 IW21(I)=' ' 9193 IW22(I)=' ' 9194 W2(I)=0.0 9195 ITYPE(I)=' ' 9196 IW21HO(I)=' ' 9197 IW22HO(I)=' ' 9198 W2HOLD(I)=0.0 9199 ITYPEH(I)=' ' 9200 160 CONTINUE 9201C 9202C THE FOLLOWING LOOP WAS PUT IN TO AVOID A PROBLEM 9203C ESSENTAILLY CAUSED IN DPLIB1 AND WHICH 9204C SHOWED UP IN LET A = 1 1 3 LET A = ABS(A) LET B = A 9205C MARY BETH 12/88 9206C 9207 DO161I=1,10 9208 IR(I)=' ' 9209 161 CONTINUE 9210C 9211C ************************************ 9212C ** STEP 1-- ** 9213C ** OPERATE ON THE VECTOR IA(.). ** 9214C ** SQUEEZE OUT ALL BLANKS. ** 9215C ** OUTPUT THE VECTOR IB(.). ** 9216C ************************************ 9217C 9218 K=0 9219 DO100I=1,NUMCHA 9220 IF(IA(I).EQ.' ')GOTO100 9221 CALL DPXH1H(IA(I),ICH,ILASTC,IBUGCO) 9222 IF(ILASTC.LE.0)GOTO100 9223 DO150J=1,ILASTC 9224 K=K+1 9225 IB(K)=ICH(J) 9226 150 CONTINUE 9227 100 CONTINUE 9228 NCTOT=K 9229 IF(NCTOT.LT.1)THEN 9230 WRITE(ICOUT,21) 9231 CALL DPWRST('XXX','BUG ') 9232 WRITE(ICOUT,105)NCTOT 9233 105 FORMAT(' TOTAL NUMBER OF CHARACTERS IN MODEL (INCLUDING ', 9234 1 'BOTH SIDES, BLANKS, AND EQUAL SIGN) IS < 1. NCTOT = ', 9235 1 I5) 9236 CALL DPWRST('XXX','BUG ') 9237 WRITE(ICOUT,171)NUMCHA,N,IPASS 9238 171 FORMAT('NUMCHA,N,IPASS = ',3I8) 9239 CALL DPWRST('XXX','BUG ') 9240 WRITE(ICOUT,172)(IA(I),I=1,MIN(80,NUMCHA)) 9241 172 FORMAT('IA--',80A1) 9242 CALL DPWRST('XXX','BUG ') 9243C 9244 WRITE(ICOUT,999) 9245 CALL DPWRST('XXX','BUG ') 9246 WRITE(ICOUT,181)NUMPAR 9247 181 FORMAT('NUMPAR = ',I8) 9248 CALL DPWRST('XXX','BUG ') 9249 IF(NUMPAR.GT.0)THEN 9250 DO182I=1,NUMPAR 9251 WRITE(ICOUT,183)I,IPARN1(I),IPARN2(I),PARAM(I) 9252 183 FORMAT('I,IPARN1(I),IPARN2(I),PARAM(I) = ',I8,2(2X,A4),2X, 9253 1 F15.7) 9254 CALL DPWRST('XXX','BUG ') 9255 182 CONTINUE 9256 ENDIF 9257 IERROR='YES' 9258 GOTO9000 9259 ENDIF 9260C 9261 IF(IBUGCO.EQ.'ON')THEN 9262 ISTEPN='1' 9263 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9264 WRITE(ICOUT,191)NCTOT 9265 191 FORMAT('NCTOT = ',I8) 9266 CALL DPWRST('XXX','BUG ') 9267 DO192I=1,NCTOT 9268 WRITE(ICOUT,193)I,IB(I) 9269 193 FORMAT('I,IB(I) = ',I5,2X,A4) 9270 CALL DPWRST('XXX','BUG ') 9271 192 CONTINUE 9272 ENDIF 9273C 9274C ********************************************************* 9275C ** STEP 2-- ** 9276C ** OPERATE ON THE VECTOR IB(.). ** 9277C ** DETERMINE THE NUMBER OF CHARACTERS (IF ANY) ** 9278C ** FOR THE LEFT-HAND SIDE. OUTPUT THEM INTO THE ** 9279C ** VECTOR IL(.). ** 9280C ********************************************************* 9281C 9282 DO500I=1,NCTOT 9283 I2=I 9284 IF(IB(I).EQ.'=')THEN 9285 NCL=I2-1 9286 ISTARR=I2+1 9287 GOTO559 9288 ENDIF 9289 500 CONTINUE 9290 NCL=0 9291 ISTARR=1 9292 559 CONTINUE 9293C 9294 IF(NCL.GT.0)THEN 9295 DO600I=1,NCL 9296 IL(I)=IB(I) 9297 600 CONTINUE 9298 ENDIF 9299C 9300 IF(IBUGCO.EQ.'ON')THEN 9301 ISTEPN='2' 9302 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9303 WRITE(ICOUT,691)NCL 9304 691 FORMAT('NCL = ',2I8) 9305 CALL DPWRST('XXX','BUG ') 9306 DO692I=1,NCL 9307 WRITE(ICOUT,693)I,IL(I) 9308 693 FORMAT('I,IL(I) = ',I5,2X,A4) 9309 CALL DPWRST('XXX','BUG ') 9310 692 CONTINUE 9311 ENDIF 9312C 9313C ********************************************************* 9314C ** STEP 3-- ** 9315C ** OPERATE ON THE VECTOR IB(.). DETERMINE THE ** 9316C ** NUMBER OF CHARACTERS FOR RIGHT-HAND SIDE. ** 9317C ** OUTPUT THEM INTO THE VECTOR IR(.). ** 9318C ********************************************************* 9319C 9320 IF(ISTARR.GT.NCTOT)THEN 9321 WRITE(ICOUT,21) 9322 CALL DPWRST('XXX','BUG ') 9323 WRITE(ICOUT,702) 9324 702 FORMAT(' THE NUMBER OF CHARACTERS ON THE RIGHT (WITH ', 9325 1 'BLANKS IGNORED)') 9326 CALL DPWRST('XXX','BUG ') 9327 WRITE(ICOUT,703) 9328 703 FORMAT(' IS 0. THE TOTAL NUMBER OF PACKED CHARACTERS ', 9329 1 'LEFT') 9330 CALL DPWRST('XXX','BUG ') 9331 WRITE(ICOUT,704)NCTOT 9332 704 FORMAT(' (IF ANY), EQUAL SIGN (IF ANY), AND RIGHT = ',I8) 9333 CALL DPWRST('XXX','BUG ') 9334 WRITE(ICOUT,707)ISTARR 9335 707 FORMAT(' THE START POSITION FOR THE PACKED RIGHT IS ', 9336 1 'COLUMN ',I8) 9337 CALL DPWRST('XXX','BUG ') 9338 WRITE(ICOUT,709)NUMCHA 9339 709 FORMAT(' THE INPUT NUMBER OF CHARACTERS NUMCHA = ',I8) 9340 CALL DPWRST('XXX','BUG ') 9341 IF(NUMCHA.GE.1)THEN 9342 WRITE(ICOUT,31)(IA(I),I=1,MIN(100,NUMCHA)) 9343 CALL DPWRST('XXX','BUG ') 9344 ENDIF 9345 IERROR='YES' 9346 GOTO9000 9347 ENDIF 9348C 9349 K=0 9350 DO700I=ISTARR,NCTOT 9351 K=K+1 9352 IR(K)=IB(I) 9353 700 CONTINUE 9354 NCR=K 9355C 9356 IF(IBUGCO.EQ.'ON')THEN 9357 ISTEPN='3' 9358 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9359 WRITE(ICOUT,791)NCR 9360 791 FORMAT('NCR = ',2I8) 9361 CALL DPWRST('XXX','BUG ') 9362 DO792I=1,NCR 9363 WRITE(ICOUT,793)I,IR(I) 9364 793 FORMAT('I,IR(I) = ',I5,2X,A4) 9365 CALL DPWRST('XXX','BUG ') 9366 792 CONTINUE 9367 ENDIF 9368C 9369C ******************************************************** 9370C ** STEP 4-- ** 9371C ** OPERATE ON THE VECTOR IR(.). ANALYZE THE ** 9372C ** RIGHT-HAND SIDE. DETERMINE THE NUMBER OF ** 9373C ** DIFFERENT LOGICAL COMPONENTS. ** 9374C ** 1. NUMBER (CONSISTING OF 0,1,2,...,9 OR .) ** 9375C ** 2. X VARIABLE ** 9376C ** 3. OPERATION (+ - * / **) ** 9377C ** 4. PARENTHESES ( ( OR ) ) ** 9378C ** 5. LIBRARY FUNCTION (ALOG EXP ETC + ** 9379C ** AUGMENTED LIB. ** 9380C ** 6. COMMA (FOR MULTI-ARGUMENT LIBRARY FUNCTIONS)** 9381C ** 7. PARAMETER (ANYTHING NOT ABOVE) ** 9382C ** CHECK FOR SYNTAX ERRORS. ** 9383C ** OUTPUT THE TYPE COMPONENT INTO ITYPE(.). ** 9384C ** OUTPUT THE START LOCATION IN IR(.) OF EACH ** 9385C ** OUTPUT THE STOP LOCATION IN IR(.) OF EACH ** 9386C ** COMPONENT INTO IE ** 9387C ******************************************************** 9388C 9389 NW=0 9390 I=1 9391 1050 CONTINUE 9392 IP1=I+1 9393 IP2=I+2 9394 IP3=I+3 9395 IP4=I+4 9396 IP5=I+5 9397C 9398 IF(IR(I).EQ.'0' .OR. IR(I).EQ.'1' .OR. IR(I).EQ.'2' .OR. 9399 1 IR(I).EQ.'3' .OR. IR(I).EQ.'4' .OR. IR(I).EQ.'5' .OR. 9400 1 IR(I).EQ.'6' .OR. IR(I).EQ.'7' .OR. IR(I).EQ.'8' .OR. 9401 1 IR(I).EQ.'9' .OR. IR(I).EQ.'.')THEN 9402 NW=NW+1 9403 ITYPE(NW)='N' 9404 JMIN=I 9405 J=I 9406 1150 CONTINUE 9407 J=J+1 9408 IF(J.LE.NCR)THEN 9409 IF(IR(J).EQ.'0' .OR. IR(J).EQ.'1' .OR. IR(J).EQ.'2' .OR. 9410 1 IR(J).EQ.'3' .OR. IR(J).EQ.'4' .OR. IR(J).EQ.'5' .OR. 9411 1 IR(J).EQ.'6' .OR. IR(J).EQ.'7' .OR. IR(J).EQ.'8' .OR. 9412 1 IR(J).EQ.'9' .OR. IR(J).EQ.'.')THEN 9413 GOTO1150 9414 ENDIF 9415 ENDIF 9416 JMAX=J-1 9417 GOTO1800 9418 ELSEIF(IR(I).EQ.'+' .OR. IR(I).EQ.'-' .OR. IR(I).EQ.'*' .OR. 9419 1 IR(I).EQ.'/')THEN 9420 NW=NW+1 9421 ITYPE(NW)='OP' 9422 JMIN=I 9423 JMAX=I 9424 IP1=I+1 9425 IF(IR(I).EQ.'*'.AND.IR(IP1).EQ.'*')JMAX=IP1 9426 GOTO1800 9427 ELSEIF(IR(I).EQ.'(')THEN 9428 NW=NW+1 9429 ITYPE(NW)='LP' 9430 JMIN=I 9431 JMAX=I 9432 GOTO1800 9433 ELSEIF(IR(I).EQ.')')THEN 9434 NW=NW+1 9435 ITYPE(NW)='RP' 9436 JMIN=I 9437 JMAX=I 9438 GOTO1800 9439 ELSEIF(IR(I).EQ.',')THEN 9440 NW=NW+1 9441 ITYPE(NW)='COM' 9442 JMIN=I 9443 JMAX=I 9444 GOTO1800 9445 ENDIF 9446C 9447C CHECK FOR A LIBRARY FUNCTION. 9448C 9449 CALL CKLIB1(IR,NCR,I,IFOUND,NCLF,IBUGEV,IERROR) 9450 IF(IERROR.EQ.'YES')GOTO9000 9451 IF(IFOUND.EQ.'NO')CALL CKLIB2(IR,NCR,I,IFOUND,NCLF,IBUGEV,IERROR) 9452 IF(IERROR.EQ.'YES')GOTO9000 9453C 9454 IF(IFOUND.EQ.'YES')THEN 9455 IF(NCLF.GE.1 .AND. NCLF.LE.8)THEN 9456 NW=NW+1 9457 ITYPE(NW)='LF' 9458 JMIN=I 9459 JMAX=I+NCLF-1 9460 GOTO1800 9461 ENDIF 9462 ENDIF 9463C 9464 NW=NW+1 9465 ITYPE(NW)='PAR' 9466 NLPWP=0 9467 NRPWP=0 9468 JMIN=I 9469 J=I 9470 ILOOP=0 9471 1650 CONTINUE 9472 J=J+1 9473 IF(J.LE.NCR)THEN 9474 IF(IR(J).EQ.'+' .OR. IR(J).EQ.'-' .OR. 9475 1 IR(J).EQ.'*' .OR. IR(J).EQ.'/' .OR. 9476 1 IR(J).EQ.',')GOTO1660 9477 IF(IR(J).EQ.'(')NLPWP=NLPWP+1 9478 IF(IR(J).EQ.')')NRPWP=NRPWP+1 9479 IF(IR(J).EQ.')'.AND.NRPWP.GT.NLPWP)GOTO1660 9480 ILOOP=ILOOP+1 9481 IF(ILOOP.LE.NUMAS2)GOTO1650 9482C 9483 WRITE(ICOUT,21) 9484 CALL DPWRST('XXX','BUG ') 9485 WRITE(ICOUT,1656)NUMAS2 9486 1656 FORMAT(' PARAMETER NAME EXCEEDS ',I8,' CHARACTERS') 9487 CALL DPWRST('XXX','BUG ') 9488 DO1657K=JMIN,J 9489 WRITE(ICOUT,1658)K,IR(K) 9490 1658 FORMAT('K, IR(K) = ',I8,2X,A4) 9491 CALL DPWRST('XXX','BUG ') 9492 1657 CONTINUE 9493 IERROR='YES' 9494 GOTO9000 9495 ENDIF 9496C 9497 1660 CONTINUE 9498 JMAX=J-1 9499C 9500 1800 CONTINUE 9501C 9502C CHECK THAT NW HAS NOT EXCEEDED MAXCHA (USUALLY 80) 9503C 9504 IF(NW.GT.MAXCHA)THEN 9505 WRITE(ICOUT,21) 9506 CALL DPWRST('XXX','BUG ') 9507 WRITE(ICOUT,1902) 9508 1902 FORMAT(' THE VARIABLE NW HAS JUST EXCEEDED THE MAXIMUM ', 9509 1 'ALLOWABLE') 9510 CALL DPWRST('XXX','BUG ') 9511 WRITE(ICOUT,1903) 9512 1903 FORMAT(' LIMIT DEFINED BY THE INTERNAL VARIABLE MAXCHA.') 9513 CALL DPWRST('XXX','BUG ') 9514 WRITE(ICOUT,1904)MAXCHA 9515 1904 FORMAT(' THIS LIMIT IS MAXCHA = ',I8) 9516 CALL DPWRST('XXX','BUG ') 9517 WRITE(ICOUT,1905)NUMCHA 9518 1905 FORMAT(' THE INPUT NUMBER OF CHARACTERS NUMCHA = ',I8) 9519 CALL DPWRST('XXX','BUG ') 9520 IF(NUMCHA.GE.1)THEN 9521 WRITE(ICOUT,31)(IA(I),I=1,MIN(100,NUMCHA)) 9522 CALL DPWRST('XXX','BUG ') 9523 ENDIF 9524 WRITE(ICOUT,1907) 9525 1907 FORMAT(' THE NUMBER OF (PACKED) CHARACTERS ON ', 9526 1 'RIGHT-HAND SIDE = ',I8) 9527 CALL DPWRST('XXX','BUG ') 9528 IF(NCR.GE.1)THEN 9529 WRITE(ICOUT,1908)(IR(I),I=1,MIN(95,NCR)) 9530 1908 FORMAT(' (PACKED) RIGHT-HAND SIDE--',95A1) 9531 CALL DPWRST('XXX','BUG ') 9532 ENDIF 9533 IERROR='YES' 9534 GOTO9000 9535 ENDIF 9536C 9537 IBEGIN(NW)=JMIN 9538 IEND(NW)=JMAX 9539 I=JMAX 9540C 9541 I=I+1 9542 IF(I.LE.NCR)GOTO1050 9543C 9544C TEST THAT NW IS POSITIVE. 9545C 9546 IF(NW.LT.1)THEN 9547 WRITE(ICOUT,21) 9548 CALL DPWRST('XXX','BUG ') 9549 WRITE(ICOUT,1951)NW 9550 1951 FORMAT(' NW IS NON-POSITIVE. NW = ',I8) 9551 CALL DPWRST('XXX','BUG ') 9552 IERROR='YES' 9553 GOTO9000 9554 ELSEIF(NW.EQ.1)THEN 9555 DO1960I=1,NW 9556 IP1=I+1 9557 IF(ITYPE(I).EQ.'LF'.AND.ITYPE(IP1).NE.'LP')THEN 9558 WRITE(ICOUT,21) 9559 CALL DPWRST('XXX','BUG ') 9560 WRITE(ICOUT,1962) 9561 1962 FORMAT(' LIBRARY FUNCTION NOT FOLLOWED BY A LEFT ', 9562 1 'PARENTHESES') 9563 CALL DPWRST('XXX','BUG ') 9564 WRITE(ICOUT,1963)NW 9565 1963 FORMAT(' NW = ',I8) 9566 CALL DPWRST('XXX','BUG ') 9567 WRITE(ICOUT,1964)I 9568 1964 FORMAT(' I = ',I8) 9569 CALL DPWRST('XXX','BUG ') 9570 WRITE(ICOUT,1965)ITYPE(I) 9571 1965 FORMAT(' ITYPE(I) = ',A4) 9572 CALL DPWRST('XXX','BUG ') 9573 WRITE(ICOUT,1966)ITYPE(IP1) 9574 1966 FORMAT(' ITYPE(I+1) = ',A4) 9575 CALL DPWRST('XXX','BUG ') 9576 IERROR='YES' 9577 GOTO9000 9578 ENDIF 9579 1960 CONTINUE 9580 ENDIF 9581C 9582 IF(ITYPE(NW).EQ.'OP')THEN 9583 WRITE(ICOUT,21) 9584 CALL DPWRST('XXX','BUG ') 9585 WRITE(ICOUT,1971)ITYPE(NW) 9586 1971 FORMAT(' LAST TERM IN TOTAL EXPRESSION IS AN OPERATION = ', 9587 1 A4) 9588 CALL DPWRST('XXX','BUG ') 9589 IERROR='YES' 9590 GOTO9000 9591 ELSEIF(ITYPE(NW).EQ.'LF')THEN 9592 WRITE(ICOUT,21) 9593 CALL DPWRST('XXX','BUG ') 9594 WRITE(ICOUT,1973)ITYPE(NW) 9595 1973 FORMAT(' LAST TERM IN TOTAL EXPRESSION = A LIBRARY ', 9596 1 'FUNCTION = ',A4) 9597 CALL DPWRST('XXX','BUG ') 9598 WRITE(ICOUT,1975)IPASS,NW 9599 1975 FORMAT('IPASS,NW = ',2I8) 9600 CALL DPWRST('XXX','BUG ') 9601 IF(NW.GE.1)THEN 9602 WRITE(ICOUT,1976)ITYPE(NW) 9603 1976 FORMAT('ITYPE(NW) = ',A4) 9604 CALL DPWRST('XXX','BUG ') 9605 ENDIF 9606 IERROR='YES' 9607 GOTO9000 9608 ENDIF 9609C 9610 IF(IBUGCO.EQ.'ON')THEN 9611 ISTEPN='4' 9612 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9613 WRITE(ICOUT,1991)NW 9614 1991 FORMAT('NW = ',I8) 9615 CALL DPWRST('XXX','BUG ') 9616 DO1992I=1,NW 9617 ICMIN=IBEGIN(I) 9618 ICMINP=ICMIN+1 9619 ICMINQ=ICMIN+2 9620 WRITE(ICOUT,1993)I,IR(ICMIN),IR(ICMINP),IR(ICMINQ),ITYPE(I), 9621 1 IBEGIN(I),IEND(I) 9622 1993 FORMAT('I,IR(ICMIN),IR(ICMIN+1),IR(ICMIN+2),ITYPE(I),', 9623 1 'IBEGIN(I),IEND(I) = ',I8,2X,4A4,2(2X,I8)) 9624 CALL DPWRST('XXX','BUG ') 9625 1992 CONTINUE 9626 ENDIF 9627C 9628C ******************************************************** 9629C ** STEP 5-- ** 9630C ** OPERATE ON EACH COMPONENT OF THE VECTOR IR(.). ** 9631C ** CONVERT THE NUMBERS TO FLOATING POINT VALUES. ** 9632C ** CONVERT THE PARAMATERS TO FLOATING POINT VALUES. ** 9633C ** SET THE X TO AN DUMMY VALUE OF 0.0 FOR THE TIME BEING. 9634C ** CONVERT THE OPERATIONS INTO A 1-WORD REPRESENTATION. 9635C ** 'CONVERT' THE PARENTHESES INTO A 1-WORD REPRESENTATION. 9636C ** CONVERT THE COEFFICIENTS TO COEFFICIENT VALUES. ** 9637C ** CONVERT THE LIBRARY FUNCTIONS INTO A 1-WORD REPRESENTATION. 9638C ** SAVE THE CONTENTS OF ITYPE, IW21, IW22, AND W2 IN ** 9639C ** ITYPEH, IW21HO, IW22HO, AND WHOLD FOR LATER USE ** 9640C ** IN REDEFINING ITYPE, IW21, IW22, AND W2 FOR EACH NEW X VALUE 9641C ** OUTPUT THE VECTORS IW21, IW22 AND W2. ** 9642C ** OUTPUT THE VECTORS IW21HO, IW22HO, W2HOLD, AND ITYPEH. 9643C ******************************************************** 9644C 9645 DO3000I=1,NW 9646 ICMIN=IBEGIN(I) 9647 ICMAX=IEND(I) 9648 IF(ITYPE(I).EQ.'N')THEN 9649 W2(I)=0.0 9650 IANS1=' ' 9651 IANS2=' ' 9652 IANS3=' ' 9653 IANS4=' ' 9654 J=0 9655 DO3150IC=ICMIN,ICMAX 9656 J=J+1 9657 JM1=J-1 9658 L=J-(NUMASC*(JM1/NUMASC)) 9659 K=NUMBPC*(L-1) 9660 K=IABS(K) 9661 IF(J.LE.NUMASC)THEN 9662 CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS1) 9663 ELSEIF(J.LE.NUMAS2)THEN 9664 CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS2) 9665 ELSEIF(J.LE.NUMAS3)THEN 9666 CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS3) 9667 ELSEIF(J.LE.NUMAS4)THEN 9668 CALL DPCHEX(0,NUMBPC,IR(IC),K,NUMBPC,IANS4) 9669 ENDIF 9670 3150 CONTINUE 9671 ERRMAX=10.0**9 9672 ERRMIN=-ERRMAX 9673 CALL ERRORF(IANS1,IANS2,IANS3,IANS4,ERRMIN,ERRMAX, 9674 1 ERRMAX,ANS2,IERROR) 9675 IF(IERROR.EQ.'YES')GOTO9000 9676 W2(I)=ANS2 9677 GOTO3000 9678 ELSEIF(ITYPE(I).EQ.'X')THEN 9679 W2(I)=0.0 9680 GOTO3000 9681 ELSEIF(ITYPE(I).EQ.'OP')THEN 9682 IW21(I)=IR(ICMIN) 9683 ICMINP=ICMIN+1 9684 IF(IR(ICMIN).EQ.'*'.AND.IR(ICMINP).EQ.'*')IW21(I)='**' 9685 GOTO3000 9686 ELSEIF(ITYPE(I).EQ.'LP'.OR.ITYPE(I).EQ.'RP')THEN 9687 IW21(I)=IR(ICMIN) 9688 GOTO3000 9689 ELSEIF(ITYPE(I).EQ.'PAR')THEN 9690 IW21(I)=' ' 9691 IW22(I)=' ' 9692 ICMAX2=ICMIN+NUMAS2-1 9693 IF(ICMAX.LE.ICMAX2)ICMAX2=ICMAX 9694 J=0 9695 DO3550IC=ICMIN,ICMAX2 9696 J=J+1 9697 J2=J 9698 IF(J2.GT.NUMASC)J2=J-NUMASC 9699 ISTAR3=NUMBPC*(J2-1) 9700 ISTAR3=IABS(ISTAR3) 9701 IF(J.LE.NUMASC)THEN 9702 CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW21(I)) 9703 ELSE 9704 CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW22(I)) 9705 ENDIF 9706 3550 CONTINUE 9707C 9708 IF(IPASS.EQ.1)GOTO3000 9709C 9710 DO3570J=1,NUMPAR 9711 IF(IW21(I).EQ.IPARN1(J).AND.IW22(I).EQ.IPARN2(J))THEN 9712 W2(I)=PARAM(J) 9713 GOTO3000 9714 ENDIF 9715 3570 CONTINUE 9716 WRITE(ICOUT,21) 9717 CALL DPWRST('XXX','BUG ') 9718 WRITE(ICOUT,3571) 9719 3571 FORMAT(' NO MATCH FOR PARAMETER/VARIABLE NAME') 9720 CALL DPWRST('XXX','BUG ') 9721 WRITE(ICOUT,3572)IW21(I),IW22(I) 9722 3572 FORMAT(' GIVEN PARAMETER/VARIABLE NAME = ',2A4) 9723 CALL DPWRST('XXX','BUG ') 9724 WRITE(ICOUT,3573)NUMPAR 9725 3573 FORMAT(' NUMBER OF PARAMETER/VARIABLE =',I8) 9726 CALL DPWRST('XXX','BUG ') 9727 WRITE(ICOUT,3574) 9728 3574 FORMAT(' ADMISSIBLE PARAMETER/VARIABLE ', 9729 1 'NAMES = ') 9730 CALL DPWRST('XXX','BUG ') 9731 DO3575J=1,NUMPAR 9732 WRITE(ICOUT,3576)J,IPARN1(J),IPARN2(J) 9733 3576 FORMAT(' PARAMETER/VARIABLE NAME ',I4,'--', 9734 1 2A4) 9735 CALL DPWRST('XXX','BUG ') 9736 3575 CONTINUE 9737 WRITE(ICOUT,3577)(IA(J),J=1,MIN(100,NUMCHA)) 9738 3577 FORMAT(' FUNCTION EXPRESSION--',100A1) 9739 CALL DPWRST('XXX','BUG ') 9740 IERROR='YES' 9741 GOTO9000 9742 ELSEIF(ITYPE(I).EQ.'LF')THEN 9743 IW21(I)=' ' 9744 IW22(I)=' ' 9745 ICMAX2=ICMIN+NUMAS2-1 9746 IF(ICMAX.LE.ICMAX2)ICMAX2=ICMAX 9747 J=0 9748 DO3650IC=ICMIN,ICMAX2 9749 J=J+1 9750 J2=J 9751 IF(J2.GT.NUMASC)J2=J-NUMASC 9752 ISTAR3=NUMBPC*(J2-1) 9753 ISTAR3=IABS(ISTAR3) 9754 IF(J.LE.NUMASC)THEN 9755 CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW21(I)) 9756 ELSE 9757 CALL DPCHEX(0,NUMBPC,IR(IC),ISTAR3,NUMBPC,IW22(I)) 9758 ENDIF 9759 3650 CONTINUE 9760 GOTO3000 9761 ELSEIF(ITYPE(I).EQ.'COM')THEN 9762 IW21(I)=IR(ICMIN) 9763 GOTO3000 9764 ENDIF 9765C 9766 WRITE(ICOUT,21) 9767 CALL DPWRST('XXX','BUG ') 9768 WRITE(ICOUT,3005) 9769 3005 FORMAT(' ITYPE(I) NOT X, OP, LP, PAR, OR LF') 9770 CALL DPWRST('XXX','BUG ') 9771 WRITE(ICOUT,3006)I,ITYPE(I),IW21(I),W2(I) 9772 3006 FORMAT('I,ITYPE(I),IW21(I),W2(I) = ',I8,2(2X,A4),2X,F15.7) 9773 CALL DPWRST('XXX','BUG ') 9774 IERROR='YES' 9775 GOTO9000 9776C 9777 3000 CONTINUE 9778C 9779 NWHOLD=NW 9780 DO3900I=1,NW 9781 ITYPEH(I)=ITYPE(I) 9782 IW21HO(I)=IW21(I) 9783 IW22HO(I)=IW22(I) 9784 W2HOLD(I)=W2(I) 9785 3900 CONTINUE 9786C 9787 IF(IBUGCO.EQ.'ON')THEN 9788 ISTEPN='5' 9789 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9790 DO3992I=1,NW 9791 ICMIN=IBEGIN(I) 9792 ICMINP=ICMIN+1 9793 ICMINQ=ICMIN+2 9794 WRITE(ICOUT,3993)I,IR(ICMIN),IR(ICMINP),IR(ICMINQ),ITYPE(I), 9795 1 IW21(I),IW22(I),W2(I) 9796 3993 FORMAT('I,IR(ICMIN),IR(ICMIN+1),IR(ICMIN+2),ITYPE(I),W21(I),', 9797 1 'IW22HO(I),W2(I) = ',I8,2X,3A4,3(2X,A4),2X,F15.6) 9798 CALL DPWRST('XXX','BUG ') 9799 3992 CONTINUE 9800 ENDIF 9801C 9802C **************************************************** 9803C ** STEP 6-- ** 9804C ** THIS STEP IS TO BE EXECUTED IF IPASS=1; ** 9805C ** OTHERWISE IT IS SKIPPED. ** 9806C ** IF THIS STEP IS EXECUTED, STEP 7 IS NOT; ** 9807C ** IF THIS STEP IS NOT EXECUTED, STEP 7 IS. ** 9808C ** OPERATE ON IW21, IW22, AND ITYPE VECTORS. ** 9809C ** DETERMINE THE NUMBER OF DISTINCT PARAMETERS. ** 9810C ** FORM THE OUTPUT VECTOR IPARN. ** 9811C **************************************************** 9812C 9813 IF(IPASS.EQ.1)THEN 9814C 9815 NUMPAR=0 9816 DO4100I=1,NW 9817 IF(ITYPE(I).NE.'PAR')GOTO4100 9818 IF(NUMPAR.GT.0)THEN 9819 DO4400J=1,NUMPAR 9820 IF(IW21(I).EQ.IPARN1(J).AND.IW22(I).EQ.IPARN2(J))GOTO4100 9821 4400 CONTINUE 9822 ENDIF 9823 NUMPAR=NUMPAR+1 9824 IPARN1(NUMPAR)=IW21(I) 9825 IPARN2(NUMPAR)=IW22(I) 9826 4100 CONTINUE 9827 GOTO9000 9828 ENDIF 9829C 9830C ********************************************************* 9831C ** STEP 7-- C ** 9832C ** OPERATE ON THE W2(.), IW21(.), AND IW22(.) VECTORS.** 9833C ** THIS STEP IS NOT EXECUTED IF STEP 6 IS; THIS STEP ** 9834C ** IS EXECUTED IF STEP 6 IS NOT. FIRST MAKE SURE THAT** 9835C ** THE NUMBER OF LEFT AND RIGHT PARENTHESES ARE THE ** 9836C ** SAME. (STEP 6 THEN SETS UP A LARGE DO LOOP WHICH ** 9837C ** GOES THROUGH ALL OF THE VALUES OF THE X VECTOR AND ** 9838C ** GENERATES CORRESPONDING VALUES OF THE Y VECTOR.) ** 9839C ** FOR A GIVEN X VALUE, IT EVALUATES THE FUNCTION BY ** 9840C ** FIRST SEEKING THE INNERMOST PARENTHESES (BY ** 9841C ** SEARCHING FOR THE FIRST REMAINING RIGHT PARENTHESS).* 9842C ** AND THEN EVALUATING ALL SUCH PARENTHETICAL ** 9843C ** EXPRESSIONS--WORKING FROM THE INNERMOST OUT. AFTER ** 9844C ** EVALUATING A PARENTHESES PAIR, THE ENTIRE ** 9845C ** PARENTHESES GROUP (PARENTHESES INCLUDED) IS ** 9846C ** REPLACED BY THE SCALAR ANSWER. THE IW21, IW22, ** 9847C ** W2, AND ITYPE VECTORS ARE SQUEEZED ACCORDING (IN ** 9848C ** THE SUBROUTINE EVAL). SINCE THE VECTORS IW21, ** 9849C ** IW22, W2, AND ITYPE ARE ALTERED FOR EACH X VALUE, ** 9850C ** THEY MUST BE REDEFINED FROM THE SAVED VALUES IN ** 9851C ** IW21HO, IW22HO, W2HOLD, AND ITYPEH FOR EACH NEW X ** 9852C ** THE ABOVE SQUEEZING OPERATION IS REPEATED FOR EACH ** 9853C ** PARENTHESES PAIR UNTIL ALL PARENTHESES ARE GONE ** 9854C ** AND WE REMAIN ONLY WITH THE FINAL ANSWER. FOR ** 9855C ** EACH VALUE X(.) OF THE INPUT X VECTOR, OUTPUT THE ** 9856C ** CORRESPONDING VALUE Y(.) OF THE DESIRED OUTPUT ** 9857C ** VECTOR. FOR A GIVEN VALUE X(.), THE CORRESPONDING ** 9858C ** COMPUTED Y(.) WILL BE THE EVALUATED VALUE OF THE ** 9859C ** RIGHT-HAND SIDE OF THE SPECIFIED EQUATION Y = F(X).** 9860C ********************************************************* 9861C 9862 5000 CONTINUE 9863C 9864 NW=NWHOLD 9865 DO5050I=1,NW 9866 ITYPE(I)=ITYPEH(I) 9867 IW21(I)=IW21HO(I) 9868 IW22(I)=IW22HO(I) 9869 W2(I)=W2HOLD(I) 9870 5050 CONTINUE 9871C 9872 DO5060I=1,NW 9873 IF(ITYPE(I).EQ.'PAR')THEN 9874 IF(NUMPAR.GT.0)THEN 9875 DO5070J=1,NUMPAR 9876 J2=J 9877 IF(IW21(I).EQ.IPARN1(J).AND.IW22(I).EQ.IPARN2(J))THEN 9878 W2(I)=PARAM(J2) 9879 GOTO5060 9880 ENDIF 9881 5070 CONTINUE 9882 ENDIF 9883C 9884 WRITE(ICOUT,21) 9885 CALL DPWRST('XXX','BUG ') 9886 WRITE(ICOUT,5071) 9887 5071 FORMAT(' NO MATCH FOR PARAMETER/VARIABLE NAME') 9888 CALL DPWRST('XXX','BUG ') 9889 WRITE(ICOUT,5072)IW21(I),IW22(I) 9890 5072 FORMAT(' GIVEN PARAMETER/VARIABLE NAME = ',2A4) 9891 CALL DPWRST('XXX','BUG ') 9892 WRITE(ICOUT,5073)NUMPAR 9893 5073 FORMAT(' NUMBER OF PARAMETERS/VARIABLES =',I8) 9894 CALL DPWRST('XXX','BUG ') 9895 WRITE(ICOUT,5074) 9896 5074 FORMAT(' ADMISSIBLE PARAMETER/VARIABLE NAMES = ') 9897 CALL DPWRST('XXX','BUG ') 9898 DO5075J=1,NUMPAR 9899 WRITE(ICOUT,5076)J,IPARN1(J),IPARN2(J) 9900 5076 FORMAT(' PARAMETER/VARIABLE NAME ',I3,'--',2A4) 9901 CALL DPWRST('XXX','BUG ') 9902 5075 CONTINUE 9903 WRITE(ICOUT,5077)(IA(J),J=1,MIN(100,NUMCHA)) 9904 5077 FORMAT(' FUNCTION EXPRESSION--',100A1) 9905 CALL DPWRST('XXX','BUG ') 9906 IERROR='YES' 9907 GOTO9000 9908C 9909 ELSEIF(ITYPE(I).EQ.'N' .OR. ITYPE(I).EQ.'X' .OR. 9910 1 ITYPE(I).EQ.'OP' .OR. ITYPE(I).EQ.'LP' .OR. 9911 1 ITYPE(I).EQ.'RP' .OR. ITYPE(I).EQ.'LF' .OR. 9912 1 ITYPE(I).EQ.'COM')THEN 9913 GOTO5060 9914 ELSE 9915 WRITE(ICOUT,21) 9916 CALL DPWRST('XXX','BUG ') 9917 WRITE(ICOUT,5061) 9918 5061 FORMAT(' ITYPE(I) NOT X, OP, LP, PAR, OR LF') 9919 CALL DPWRST('XXX','BUG ') 9920 WRITE(ICOUT,5062)I,ITYPE(I),IW21(I),IW22(I),W2(I) 9921 5062 FORMAT('I,ITYPE(I),IW21(I),IW22(I),W2(I) = ', 9922 1 I8,3(2X,A4),2X,F15.7) 9923 CALL DPWRST('XXX','BUG ') 9924 IERROR='YES' 9925 GOTO9000 9926 ENDIF 9927 5060 CONTINUE 9928C 9929 NLP=0 9930 NRP=0 9931 DO5100I=1,NW 9932 IF(ITYPE(I).EQ.'LP')NLP=NLP+1 9933 IF(ITYPE(I).EQ.'RP')NRP=NRP+1 9934 5100 CONTINUE 9935C 9936 IF(NLP.NE.NRP)THEN 9937 WRITE(ICOUT,21) 9938 CALL DPWRST('XXX','BUG ') 9939 WRITE(ICOUT,5156) 9940 5156 FORMAT(' NUMBER OF LEFT PARENTHESES NOT EQUAL TO ', 9941 1 'NUMBER OF RIGHT PARENTHESES') 9942 CALL DPWRST('XXX','BUG ') 9943 WRITE(ICOUT,5157)NLP 9944 5157 FORMAT(' NUMBER OF LEFT PARENTHESES = ',I8) 9945 CALL DPWRST('XXX','BUG ') 9946 WRITE(ICOUT,5158)NRP 9947 5158 FORMAT(' NUMBER OF RIGHT PARENTHESES = ',I8) 9948 CALL DPWRST('XXX','BUG ') 9949 IERROR='YES' 9950 GOTO9000 9951 ENDIF 9952C 9953CCCCC ADD FOLLOWING LINES APRIL 1995. 9954CCCCC 2010/12: INITIALIZE TO CPUMIN RATHER THAN -99.9. 9955CCCCC NEED TO MODIFY DPLIB1, DPLIB2, DPLIB3 TO 9956CCCCC CHECK FOR CPUMIN RATHER THAN -99.9. 9957C 9958 ILIBC1=0 9959 ILIBC2=0 9960 DO5195IJ=1,MAXNST 9961 SAVE1(IJ)=CPUMIN 9962 SAVE2(IJ)=CPUMIN 9963 SAVE3(IJ)=CPUMIN 9964 SAVE4(IJ)=CPUMIN 9965 SAVE5(IJ)=CPUMIN 9966 SAVE6(IJ)=CPUMIN 9967 SAVE7(IJ)=CPUMIN 9968 SAVE8(IJ)=CPUMIN 9969 5195 CONTINUE 9970C 9971 DO10000II=1,N 9972C 9973 IF(II.GT.1)THEN 9974 NW=NWHOLD 9975 DO5200I=1,NW 9976 ITYPE(I)=ITYPEH(I) 9977 IW21(I)=IW21HO(I) 9978 IW22(I)=IW22HO(I) 9979 W2(I)=W2HOLD(I) 9980 5200 CONTINUE 9981 ENDIF 9982C 9983 IF(IBUGCO.EQ.'ON')THEN 9984 ISTEPN='7' 9985 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9986 DO5250I=1,NW 9987 WRITE(ICOUT,5251)I,IW21HO(I),IW22HO(I),IW21(I),IW22(I) 9988 5251 FORMAT('I,IW21HO(I),IW22HO(I),IW21(I),IW22(I) = ', 9989 1 I8,4(2X,A4)) 9990 CALL DPWRST('XXX','BUG ') 9991 5250 CONTINUE 9992 ENDIF 9993C 9994 ILOOP=1 9995 5350 CONTINUE 9996 DO5400I=1,NW 9997 I2=I 9998 IF(ITYPE(I).EQ.'RP')THEN 9999 ISTOP=I2 10000 DO5600JJ=1,ISTOP 10001 IREV=ISTOP-JJ+1 10002 IF(ITYPE(IREV).EQ.'LP')THEN 10003 ISTART=IREV 10004 GOTO5690 10005 ENDIF 10006 5600 CONTINUE 10007 WRITE(ICOUT,21) 10008 CALL DPWRST('XXX','BUG ') 10009 WRITE(ICOUT,5605) 10010 5605 FORMAT(' ITYPE(IREV) NOT LP') 10011 CALL DPWRST('XXX','BUG ') 10012 ISTART=IREV 10013 GOTO5690 10014 ENDIF 10015 5400 CONTINUE 10016 ISTOP=NW+1 10017 ISTART=0 10018 5690 CONTINUE 10019C 10020 ISTAP1=ISTART+1 10021 ISTOM1=ISTOP-1 10022 IJUNK=ISTART-1 10023 IF(IJUNK.GE.1)THEN 10024 IF(ITYPE(IJUNK).EQ.'LF')ILIBC1=ILIBC1+1 10025 ENDIF 10026 CALL EVALM(IW21,IW22,W2,ITYPE,ISTAP1,ISTOM1,IANGLU,Y, 10027 1 SAVE1,SAVE2,SAVE3,SAVE4,SAVE5,SAVE6,SAVE7,SAVE8, 10028 1 ILIBC1,ILIBC2,IBUGEV,IERROR) 10029 IF(IERROR.EQ.'YES')GOTO9000 10030C 10031 IF(ISTART.GT.0)THEN 10032 W2(ISTART)=Y 10033 ITYPE(ISTART)='V' 10034 IF(NW.GT.1)THEN 10035 ISTOPP=ISTOP+1 10036 J=ISTART 10037 IF(ISTOP.NE.NW)THEN 10038 DO5700I=ISTOPP,NW 10039 J=J+1 10040 IW21(J)=IW21(I) 10041 IW22(J)=IW22(I) 10042 W2(J)=W2(I) 10043 ITYPE(J)=ITYPE(I) 10044 5700 CONTINUE 10045 ENDIF 10046 NW=J 10047 GOTO5350 10048 ENDIF 10049 ENDIF 1005010000 CONTINUE 10051C 10052C ***************** 10053C ** STEP 90-- ** 10054C ** EXIT ** 10055C ***************** 10056C 10057 9000 CONTINUE 10058 IF(IBUGCO.EQ.'ON')THEN 10059 WRITE(ICOUT,999) 10060 CALL DPWRST('XXX','BUG ') 10061 WRITE(ICOUT,9011) 10062 9011 FORMAT('***** AT THE END OF COMPIM--') 10063 CALL DPWRST('XXX','BUG ') 10064 DO9113I=1,MAXNST 10065 WRITE(ICOUT,9013)I,SAVE1(I),SAVE2(I),SAVE3(I),SAVE4(I),Y 10066 9013 FORMAT('I,SAVE1,SAVE2,SAVE3,SAVE4,Y = ',I3,5E15.7) 10067 CALL DPWRST('XXX','BUG ') 10068 9113 CONTINUE 10069 WRITE(ICOUT,9014)NUMCHA,N,IPASS,NW,IANGLU 10070 9014 FORMAT('NUMCHA,N,IPASS,NW,IANGLU = ',4I8,2X,A4) 10071 CALL DPWRST('XXX','BUG ') 10072 IF(NW.GE.1)THEN 10073 WRITE(ICOUT,9022)ITYPE(NW) 10074 9022 FORMAT('ITYPE(NW) = ',A4) 10075 CALL DPWRST('XXX','BUG ') 10076 ENDIF 10077 ENDIF 10078C 10079 RETURN 10080 END 10081 DOUBLE PRECISION FUNCTION CONDIT( N, SYMIN ) 10082* 10083* Computes condition number of symmetric matix in situ 10084* 10085 INTEGER NL, N 10086 PARAMETER ( NL = 100 ) 10087 DOUBLE PRECISION DET, SYMIN(*), SUM, ROWMX, ROWMXI, 10088 & SYM(NL*(NL+1)/2) 10089 INTEGER II, IJ, I, J, IM 10090 ROWMX = 0 10091 IJ = 0 10092 DO 100 I = 1,N 10093 SUM = 0 10094 IM = (I-2)*(I-1)/2 10095 DO 200 J = 1,I-1 10096 IM = IM + 1 10097 SUM = SUM + ABS(SYMIN(IM)) 10098 IJ = IJ + 1 10099 SYM(IJ) = SYMIN(IM) 10100 200 CONTINUE 10101 SUM = SUM + 1 10102 IJ = IJ + 1 10103 SYM(IJ) = 1 10104 IM = IM + I 10105 DO 300 J = I,N-1 10106 SUM = SUM + ABS(SYMIN(IM)) 10107 IM = IM + J 10108 300 CONTINUE 10109 ROWMX = MAX( SUM, ROWMX ) 10110 100 CONTINUE 10111 CALL SYMINV(N, SYM, DET) 10112 ROWMXI = 0 10113 II = 0 10114 DO 400 I = 1,N 10115 SUM = 0 10116 IJ = II 10117 DO 500 J = 1,I 10118 IJ = IJ + 1 10119 SUM = SUM + ABS(SYM(IJ)) 10120 500 CONTINUE 10121 DO 600 J = I,N-1 10122 IJ = IJ + J 10123 SUM = SUM + ABS(SYM(IJ)) 10124 600 CONTINUE 10125 ROWMXI = MAX( SUM, ROWMXI ) 10126 II = II + I 10127 400 CONTINUE 10128 CONDIT = ROWMX*ROWMXI 10129C 10130 RETURN 10131 END 10132 SUBROUTINE CONINS(X,Y,NPT,XX,YY,NPTC) 10133C 10134C PURPOSE--INCORPORATE AN INTERIOR CLOSED CONTOUR SEGMENT 10135C INTO ANOTHER SEGMENT 10136C 10137C RECOMMENDED DIMENSIONS-- 10138C X(NPT+NPTC+1) 10139C Y(NPT+NPTC+1) 10140C XX(NPTC) 10141C YY(NPTC) 10142C LC(4) 10143C 10144C WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI). 10145C AS PART OF NOAA'S CONCX V.3 MARCH 1988. 10146C ORIGINAL VERSION (IN DATAPLOT)--AUGUST 1988. 10147C 10148C--------------------------------------------------------------------- 10149C 10150CCCCC DIMENSION X(NPT+NPTC+1),Y(NPT+NPTC+1),XX(NPTC),YY(NPTC),LC(4) 10151C 10152 DIMENSION X(*) 10153 DIMENSION Y(*) 10154 DIMENSION XX(*) 10155 DIMENSION YY(*) 10156C 10157 DIMENSION LC(4) 10158C 10159C-----START POINT----------------------------------------------------- 10160C 10161C FIRST FIND UP, DOWN, LEFT & RIGHT EXTREMES OF AN INTERIOR SEGMENT 10162 DO 10 I=1,4 10163 LC(I)=1 10164 10 CONTINUE 10165 DO 20 L=1,NPTC 10166 IF (XX(L).LT.XX(LC(1))) LC(1)=L 10167 IF (YY(L).GT.YY(LC(2))) LC(2)=L 10168 IF (XX(L).GT.XX(LC(3))) LC(3)=L 10169 IF (YY(L).LT.YY(LC(4))) LC(4)=L 10170 20 CONTINUE 10171C FIND A REASONABLY CLOSE APPROACH OF INTERIOR SEGMENT TO THE CONTINUOUS 10172C STRING 10173 L1=LC(1) 10174 L0=1 10175 DMN=SQRT((XX(L1)-X(L0))**2+(YY(L1)-Y(L0))**2) 10176 DO 100 L=1,NPT 10177 DO 200 I=1,4 10178 LL=LC(I) 10179 DTST=SQRT((XX(LL)-X(L))**2+(YY(LL)-Y(L))**2) 10180 IF (DTST.LT.DMN) THEN 10181 DMN=DTST 10182 L0=L 10183 L1=LL 10184 END IF 10185 200 CONTINUE 10186 100 CONTINUE 10187C REORDER THE INTERIOR SEGMENT 10188 DO 300 L=1,L1-1 10189 HX=XX(1) 10190 HY=YY(1) 10191 DO 400 LL=2,NPTC-1 10192 XX(LL-1)=XX(LL) 10193 YY(LL-1)=YY(LL) 10194 400 CONTINUE 10195 XX(NPTC-1)=HX 10196 YY(NPTC-1)=HY 10197 300 CONTINUE 10198 XX(NPTC)=XX(1) 10199 YY(NPTC)=YY(1) 10200C INSERT THE INTERIOR SEGMENT INTO THE CONTINUOUS STRING 10201 DO 500 L=NPT,L0,-1 10202 X(L+1)=X(L) 10203 Y(L+1)=Y(L) 10204 500 CONTINUE 10205 NPT=NPT+1 10206 L0=L0+1 10207 L2=NPT+1 10208 L3=NPTC+L2 10209 NPT=L3-1 10210 DO 600 L=L2,NPT 10211 LL=L-L2+1 10212 X(L)=XX(LL) 10213 Y(L)=YY(LL) 10214 600 CONTINUE 10215 CALL STRSWP(X,L0,L2,L3) 10216 CALL STRSWP(Y,L0,L2,L3) 10217 RETURN 10218 END 10219 SUBROUTINE CONCDF(DX,DSHAPE,DM,ICONDF,DCDF) 10220C 10221C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION 10222C FUNCTION VALUE FOR THE CONSUL DISTRIBUTION WITH SHAPE 10223C PARAMETERS THETA AND M. THIS DISTRIBUTION IS 10224C DEFINED FOR ALL INTEGER X >= 1. 10225C 10226C THIS DISTRIBUTION REDUCES TO THE GEOMETRIC 10227C DISTRIBUTION WHEN M = 1. FOR THIS REASON, IT 10228C SOMETIMES REFERRED TO AS THE GENERALIZED GEOMETRIC 10229C DISTRIBUTION. NOTE THAT THIS DISTRIBUTION HAS A 10230C SIMILAR FORM TO THE GEETA DISTRIBUTION. 10231C 10232C THE PROBABILITY MASS FUNCTION IS: 10233C p(X;THETA,M)= 10234C (M*X X-1)*THETA**(X-1)*(1-THETA)**(M*X-X+1)/X 10235C X = 1, 2, 3, ,... 10236C 0 < THETA < 1; 1 <= M < 1/THETA 10237C 10238C A RECURRENCE RELATION FOR THE CDF FUNCTION IS 10239C 10240C P(X;THETA,M) = {(M-1)*(X-1)+1}/(X-1)}* 10241C THETA*(1-TYHETA)**(M-1)* 10242C PROD[i=1 to X-2][(1 + M/(M*X-M-i)]* 10243C P(X-1;THETA,M) 10244C 10245C THIS DISTRIBUTION IS SOMETIMES PARAMETERIZED USING 10246C THE MEAN (MU) INSTEAD OF THETA. THIS RESULTS IN 10247C THE PROBABILITY MASS FUNCTION: 10248C p(X;MU,M)= 10249C (M*X X-1)*((MU-1)/(M*MU))**(X-1)* 10250C (1 - (M-1)/(M*MU))**(M*X-X+1)/X 10251C X = 1, 2, 3, ,... 10252C MU >= 1; M > 1 10253C NOTE THAT THE RELATION IS: 10254C 10255C THETA=(MU-1)/(M*MU) 10256C 10257C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT 10258C WHICH THE CUMULATIVE DISTRIBUTION 10259C FUNCTION IS TO BE EVALUATED. 10260C X SHOULD BE A NON-NEGATIVE INTEGER. 10261C --DSHAPE = THE FIRST SHAPE PARAMETER 10262C (EITHER THETA OR MU) 10263C --DM = THE SECOND SHAPE PARAMETER 10264C OUTPUT ARGUMENTS--DCDF = THE DOUBLE PRECISION CUMULATIVE 10265C DISTRIBUTION FUNCTION VALUE. 10266C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION 10267C VALUE CDF FOR THE CONSUL DISTRIBUTION WITH SHAPE 10268C PARAMETERS THETA (OR MU) AND M 10269C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 10270C RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER 10271C --0 < THETA < 1; 1 < M < 1/THETA 10272C --MU >= 1; M > 1 10273C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 10274C LANGUAGE--ANSI FORTRAN (1977) 10275C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY 10276C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8. 10277C WRITTEN BY--JAMES J. FILLIBEN 10278C STATISTICAL ENGINEERING DIVISION 10279C INFORMATION TECHNOLOGY LABORATORY 10280C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10281C GAITHERSBURG, MD 20899-8980 10282C PHONE--301-975-2855 10283C LANGUAGE--ANSI FORTRAN (1977) 10284C VERSION NUMBER--2006/8 10285C ORIGINAL VERSION--AUGUST 2006. 10286C 10287C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10288C 10289C--------------------------------------------------------------------- 10290C 10291 DOUBLE PRECISION DX 10292 DOUBLE PRECISION DSHAPE 10293 DOUBLE PRECISION DM 10294 DOUBLE PRECISION DCDF 10295 DOUBLE PRECISION DPDF 10296 DOUBLE PRECISION DPDFSV 10297C 10298 DOUBLE PRECISION DTERM1 10299 DOUBLE PRECISION DTERM2 10300 DOUBLE PRECISION DTERM3 10301 DOUBLE PRECISION DTHETA 10302 DOUBLE PRECISION DMU 10303 DOUBLE PRECISION DSUM 10304C 10305 CHARACTER*4 ICONDF 10306 CHARACTER*4 ICOND2 10307C 10308C--------------------------------------------------------------------- 10309C 10310 INCLUDE 'DPCOP2.INC' 10311C 10312C-----START POINT----------------------------------------------------- 10313C 10314C CHECK THE INPUT ARGUMENTS FOR ERRORS 10315C 10316 IF(ICONDF.EQ.'THET')THEN 10317 DTHETA=DSHAPE 10318 ELSE 10319 DMU=DSHAPE 10320 DTHETA=(DMU-1.0D0)/(DM*DMU) 10321 ENDIF 10322C 10323 IX=INT(DX+0.5D0) 10324 IF(IX.LT.1)THEN 10325 WRITE(ICOUT,4) 10326 CALL DPWRST('XXX','BUG ') 10327 WRITE(ICOUT,46)DX 10328 CALL DPWRST('XXX','BUG ') 10329 DCDF=0.0D0 10330 GOTO9000 10331 ENDIF 10332 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO CONCDF IS LESS ', 10333 1'THAN 1') 10334C 10335 IF(ICONDF.EQ.'THET')THEN 10336 IF(DTHETA.LE.0.0D0 .OR. DTHETA.GE.1.0D0)THEN 10337 WRITE(ICOUT,15) 10338 CALL DPWRST('XXX','BUG ') 10339 WRITE(ICOUT,46)DTHETA 10340 CALL DPWRST('XXX','BUG ') 10341 DCDF=0.0 10342 GOTO9000 10343 ENDIF 10344 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO CONCDF IS NOT ', 10345 1 'IN THE INTERVAL (0,1)') 10346C 10347 IF(DM.LT.1.0D0 .OR. DM.GE.1.0D0/DTHETA)THEN 10348 WRITE(ICOUT,25)1.0D0/DTHETA 10349 CALL DPWRST('XXX','BUG ') 10350 WRITE(ICOUT,46)DM 10351 CALL DPWRST('XXX','BUG ') 10352 DCDF=0.0 10353 GOTO9000 10354 ENDIF 10355 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO CONCDF IS NOT ', 10356 1 'IN THE INTERVAL (1,',G15.7,')') 10357 ELSE 10358 IF(DMU.LT.1.0D0)THEN 10359 WRITE(ICOUT,35) 10360 CALL DPWRST('XXX','BUG ') 10361 WRITE(ICOUT,46)DMU 10362 CALL DPWRST('XXX','BUG ') 10363 DCDF=0.0 10364 GOTO9000 10365 ENDIF 10366 35 FORMAT('***** ERROR--THE SECOND ARGUMENT TO CONCDF IS ', 10367 1 'LESS THAN 1') 10368C 10369 IF(DM.LT.1.0D0)THEN 10370 WRITE(ICOUT,38) 10371 CALL DPWRST('XXX','BUG ') 10372 WRITE(ICOUT,46)DM 10373 CALL DPWRST('XXX','BUG ') 10374 DCDF=0.0 10375 GOTO9000 10376 ENDIF 10377 38 FORMAT('***** ERROR--THE THIRD ARGUMENT TO CONCDF IS ', 10378 1 'LESS THAN 1') 10379 ENDIF 10380C 10381 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 10382C 10383 DCDF=(1.0D0 - DTHETA)**DM 10384 IF(IX.EQ.1)THEN 10385 GOTO9000 10386 ELSE 10387 DX=2.0D0 10388 ICOND2='THET' 10389 CALL CONPDF(DX,DTHETA,DM,ICOND2,DPDF) 10390 DCDF=DCDF+DPDF 10391 IF(IX.EQ.2)GOTO9000 10392 DX=3.0D0 10393 CALL CONPDF(DX,DTHETA,DM,ICOND2,DPDF) 10394 DCDF=DCDF+DPDF 10395 IF(IX.EQ.3)GOTO9000 10396 DPDFSV=DPDF 10397 ENDIF 10398C 10399 DO100I=4,IX 10400 DX=DBLE(I) 10401 DTERM1=DLOG(DTHETA) + (DM-1.0D0)*DLOG(1.0D0 - DTHETA) 10402 DTERM2=DLOG((DM-1.0D0)*(DX-1.0D0) + 1.0D0) - DLOG(DX-1.0D0) 10403 DTERM3=DTERM1 + DTERM2 10404 DSUM=0.0D0 10405 DO200J=1,I-2 10406 DSUM=DSUM + DLOG(1.0D0 + DM/(DM*DX - DM - DBLE(J))) 10407 200 CONTINUE 10408 IF(DPDFSV.GT.0.0D0)THEN 10409 DPDF=DEXP(DTERM3 + DSUM + DLOG(DPDFSV)) 10410 ELSE 10411 GOTO9000 10412 ENDIF 10413 DCDF=DCDF + DPDF 10414 DPDFSV=DPDF 10415 100 CONTINUE 10416C 10417 9000 CONTINUE 10418 RETURN 10419 END 10420 SUBROUTINE CONFOU(ISUBRO,IBUGA3,IERROR) 10421C 10422C PURPOSE--CREATE STRINGS FOR CONFOUNDING FOR CERTAIN 10423C TWO-LEVEL DESIGNS. 10424C EXAMPLE--LET CON COP = CONFOUND N K 10425C 10426C BASED ON VALUES OF N AND K, A NUMBER OF STRINGS 10427C STARTING WITH "CON" AND "COP" WILL BE CREATED. 10428C WRITTEN BY--ALAN HECKERT 10429C STATISTICAL ENGINEERING DIVISION 10430C INFORMATION TECHNOLOGY LABORATORY 10431C NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY 10432C GAITHERSBURG, MD 20899-8980 10433C PHONE--301-975-2899 10434C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 10435C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 10436C LANGUAGE--ANSI FORTRAN (1977) 10437C VERSION NUMBER--2015/01 10438C ORIGINAL VERSION--JANUARY 2015. 10439C 10440C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10441C 10442 CHARACTER*4 ISUBRO 10443 CHARACTER*4 IBUGA3 10444 CHARACTER*4 IERROR 10445C 10446 CHARACTER*8 IHLEFT 10447 CHARACTER*4 IHLEF2 10448 CHARACTER*4 IHRIGH 10449 CHARACTER*4 IHRIG2 10450C 10451 CHARACTER*8 ISTR1 10452 CHARACTER*8 ISTR2 10453 CHARACTER*8 ISTRZ1 10454 CHARACTER*16 ISTRZ2 10455C 10456 CHARACTER*4 ISUBN1 10457 CHARACTER*4 ISUBN2 10458 CHARACTER*4 ISTEPN 10459C 10460C--------------------------------------------------------------------- 10461C 10462C-----COMMON---------------------------------------------------------- 10463C 10464 INCLUDE 'DPCOPA.INC' 10465 INCLUDE 'DPCOHK.INC' 10466 INCLUDE 'DPCOHO.INC' 10467 INCLUDE 'DPCODA.INC' 10468C 10469C-----COMMON VARIABLES (GENERAL)-------------------------------------- 10470C 10471 INCLUDE 'DPCOP2.INC' 10472C 10473C-----START POINT----------------------------------------------------- 10474C 10475 ISUBN1='CONF' 10476 ISUBN2='OU ' 10477 IERROR='NO' 10478C 10479 N=-1 10480 K=-1 10481 ILOC3=0 10482C 10483 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NFOU')THEN 10484 WRITE(ICOUT,999) 10485 999 FORMAT(1X) 10486 CALL DPWRST('XXX','BUG ') 10487 WRITE(ICOUT,51) 10488 51 FORMAT('***** AT THE BEGINNING OF CONFOU--') 10489 CALL DPWRST('XXX','BUG ') 10490 WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM 10491 52 FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8) 10492 CALL DPWRST('XXX','BUG ') 10493 DO55I=1,NUMNAM 10494 WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I), 10495 1 IVSTOP(I) 10496 56 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),', 10497 1 'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8) 10498 CALL DPWRST('XXX','BUG ') 10499 55 CONTINUE 10500 WRITE(ICOUT,57)NUMCHF,MAXCHF 10501 57 FORMAT('NUMCHF,MAXCHF = ',2I8) 10502 CALL DPWRST('XXX','BUG ') 10503 WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF)) 10504 60 FORMAT('IFUNC(.) = ',120A1) 10505 CALL DPWRST('XXX','BUG ') 10506 ENDIF 10507C 10508C ********************************** 10509C ** STEP 1-- ** 10510C ** ERROR CHECKING--EXACTLY 6 ** 10511C ** AGUMENTS REQUIRED. ** 10512C ********************************** 10513C 10514 ISTEPN='1' 10515 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFOU') 10516 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10517C 10518 IF(NUMARG.NE.6)THEN 10519 WRITE(ICOUT,999) 10520 CALL DPWRST('XXX','BUG ') 10521 WRITE(ICOUT,101) 10522 101 FORMAT('***** ERROR IN CONFOUND--') 10523 CALL DPWRST('XXX','BUG ') 10524 WRITE(ICOUT,103) 10525 103 FORMAT(' EXACTLY SIX ARGUMENTS EXPECTED.') 10526 CALL DPWRST('XXX','BUG ') 10527 WRITE(ICOUT,105)NUMARG 10528 105 FORMAT(' ',I3,' ARGUMENTS GIVEN.') 10529 CALL DPWRST('XXX','BUG ') 10530 IERROR='YES' 10531 GOTO9000 10532 ENDIF 10533C 10534C ********************************** 10535C ** STEP 2-- ** 10536C ** EXTRACT VALUES FOR N AND K ** 10537C ** FROM RIGHT HAND SIDE. ** 10538C ********************************** 10539C 10540 ISTEPN='1' 10541 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFOU') 10542 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10543C 10544C N AND K CAN EITHER BE PREVIOUSLY DEFINED PARAMETERS OR 10545C SIMPLY NUMBERS. ANY OTHER TYPE IS AN ERROR. 10546C 10547 IHRIGH=IHARG(5) 10548 IHRIG2=IHARG2(5) 10549C 10550 DO210I=1,NUMNAM 10551 IF(IHRIGH(1:4).EQ.IHNAME(I)(1:4) .AND. 10552 1 IHRIG2(1:4).EQ.IHNAM2(I)(1:4))THEN 10553 AK=VALUE(I) 10554 GOTO219 10555 ENDIF 10556 210 CONTINUE 10557C 10558C NAME NOT FOUND. CHECK IF ARGUMENT IS A NUMBER. 10559C 10560 IF(IARGT(5).EQ.'NUMB')THEN 10561 AK=ARG(5) 10562 ELSE 10563 WRITE(ICOUT,999) 10564 CALL DPWRST('XXX','BUG ') 10565 WRITE(ICOUT,101) 10566 CALL DPWRST('XXX','BUG ') 10567 WRITE(ICOUT,203) 10568 203 FORMAT(' THE NUMBER OF FACTORS ARGUMENT WAS NOT FOUND') 10569 CALL DPWRST('XXX','BUG ') 10570 WRITE(ICOUT,205) 10571 205 FORMAT(' AS EITHER A PARAMETER OR A NUMBER.') 10572 CALL DPWRST('XXX','BUG ') 10573 WRITE(ICOUT,207)IHARG(5),IHARG2(5) 10574 207 FORMAT(' THE ARGUMENT IS: ',2A4) 10575 CALL DPWRST('XXX','BUG ') 10576 IERROR='YES' 10577 GOTO9000 10578 ENDIF 10579 219 CONTINUE 10580C 10581 IHRIGH=IHARG(6) 10582 IHRIG2=IHARG2(6) 10583C 10584 DO260I=1,NUMNAM 10585 IF(IHRIGH(1:4).EQ.IHNAME(I)(1:4) .AND. 10586 1 IHRIG2(1:4).EQ.IHNAM2(I)(1:4))THEN 10587 AN=VALUE(I) 10588 GOTO269 10589 ENDIF 10590 260 CONTINUE 10591C 10592C NAME NOT FOUND. CHECK IF ARGUMENT IS A NUMBER. 10593C 10594 IF(IARGT(6).EQ.'NUMB')THEN 10595 AN=ARG(6) 10596 ELSE 10597 WRITE(ICOUT,999) 10598 CALL DPWRST('XXX','BUG ') 10599 WRITE(ICOUT,101) 10600 CALL DPWRST('XXX','BUG ') 10601 WRITE(ICOUT,263) 10602 263 FORMAT(' THE SAMPLE SIZE ARGUMENT WAS NOT FOUND') 10603 CALL DPWRST('XXX','BUG ') 10604 WRITE(ICOUT,265) 10605 265 FORMAT(' AS EITHER A PARAMETER OR A NUMBER.') 10606 CALL DPWRST('XXX','BUG ') 10607 WRITE(ICOUT,267)IHARG(6),IHARG2(6) 10608 267 FORMAT(' THE ARGUMENT IS: ',2A4) 10609 CALL DPWRST('XXX','BUG ') 10610 IERROR='YES' 10611 GOTO9000 10612 ENDIF 10613C 10614 269 CONTINUE 10615C 10616 IF(AK.GT.AN)THEN 10617 AKSAV=AK 10618 AK=AN 10619 AN=AKSAV 10620 ENDIF 10621C 10622 K=INT(AK+0.1) 10623 NTEMP=INT(AN+0.1) 10624C 10625 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NFOU')THEN 10626 WRITE(ICOUT,291)K,NTEMP 10627 291 FORMAT('K,NTEMP = ',2I8) 10628 CALL DPWRST('XXX','BUG ') 10629 ENDIF 10630C 10631C ************************************************* 10632C ** STEP 3-- ** 10633C ** EXTRACT THE BASE NAMES ON THE LHS OF THE ** 10634C ** EQUAL SIGN AND THEN LOOP THROUGH THE ** 10635C ** NUMBER OF STRINGS TO CREATE. ** 10636C ************************************************* 10637C 10638 ISTEPN='3' 10639 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFOU') 10640 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10641C 10642 IHLEFT(1:4)=IHARG(1) 10643 IHLEFT(5:8)=IHARG2(1) 10644 NBASE1=1 10645 DO310I=8,1,-1 10646 IF(IHLEFT(I:I).NE.' ')THEN 10647 NBASE1=I 10648 GOTO319 10649 ENDIF 10650 310 CONTINUE 10651 319 CONTINUE 10652C 10653 ISTR1=' ' 10654 IF(NBASE1.LE.4)THEN 10655 ISTR1(1:NBASE1)=IHLEFT(1:NBASE1) 10656 ELSE 10657 ISTR1(1:4)=IHLEFT(1:4) 10658 NCHR=NBASE1-5+1 10659 ISTR1(5:NBASE1)=IHLEF2(1:NCHR) 10660 ENDIF 10661C 10662 IHLEFT(1:4)=IHARG(2) 10663 IHLEFT(5:8)=IHARG2(2) 10664 NBASE2=1 10665 DO360I=8,1,-1 10666 IF(IHLEFT(I:I).NE.' ')THEN 10667 NBASE2=I 10668 GOTO369 10669 ENDIF 10670 360 CONTINUE 10671 369 CONTINUE 10672C 10673 ISTR2=' ' 10674 IF(NBASE2.LE.4)THEN 10675 ISTR2(1:NBASE2)=IHLEFT(1:NBASE2) 10676 ELSE 10677 ISTR2(1:4)=IHLEFT(1:4) 10678 NCHR=NBASE2-5+1 10679 ISTR2(5:NBASE2)=IHLEF2(1:NCHR) 10680 ENDIF 10681C 10682 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NFOU')THEN 10683 WRITE(ICOUT,391)NBASE1,NBASE2,ISTR1,ISTR2 10684 391 FORMAT('NBASE1,NBASE2,ISTR1,ISTR2 = ',2I8,2(2X,A4)) 10685 CALL DPWRST('XXX','BUG ') 10686 ENDIF 10687C 10688C ********************************** 10689C ** STEP 4-- ** 10690C ** STEP THROUGH THE SUPPORTED ** 10691C ** K/N COMBINATIONS AND CREATE ** 10692C ** THE STRINGS. ** 10693C ********************************** 10694C 10695 ISTEPN='4' 10696 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFOU') 10697 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10698C 10699 IF(NTEMP.EQ.4)THEN 10700 IF(K.EQ.2)THEN 10701C 10702C K = 2, N = 4 (2**2) 10703C 10704C CON1 = 1 10705C CON2 = 2 10706C CON12 = 12 10707C 10708C COP1 = 1 10709C COP2 = 2 10710C COP12 = 12 10711C 10712C MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS 10713C 10714 IF(NBASE1.GT.6)THEN 10715 IERROR='YES' 10716 GOTO8010 10717 ELSEIF(NBASE2.GT.6)THEN 10718 IERROR='YES' 10719 GOTO8010 10720 ENDIF 10721C 10722C NOW CREATE THE STRINGS 10723C 10724 ISTR1(NBASE1+1:NBASE1+1)='1' 10725 ISTRZ1(1:1)='1' 10726 NCHAR=1 10727 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 10728 IF(IERROR.EQ.'YES')GOTO8020 10729C 10730 ISTR1(NBASE1+1:NBASE1+1)='2' 10731 ISTRZ1(1:1)='2' 10732 NCHAR=1 10733 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 10734 IF(IERROR.EQ.'YES')GOTO8020 10735C 10736 ISTR1(NBASE1+1:NBASE1+2)='12' 10737 ISTRZ1(1:2)='12' 10738 NCHAR=2 10739 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 10740 IF(IERROR.EQ.'YES')GOTO8020 10741C 10742 ISTR2(NBASE2+1:NBASE2+1)='1' 10743 ISTRZ2(1:1)='1' 10744 NCHAR=1 10745 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 10746 IF(IERROR.EQ.'YES')GOTO8020 10747C 10748 ISTR2(NBASE2+1:NBASE2+1)='2' 10749 ISTRZ2(1:1)='2' 10750 NCHAR=1 10751 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 10752 IF(IERROR.EQ.'YES')GOTO8020 10753C 10754 ISTR2(NBASE2+1:NBASE2+2)='12' 10755 ISTRZ2(1:2)='12' 10756 NCHAR=2 10757 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 10758 IF(IERROR.EQ.'YES')GOTO8020 10759C 10760 ELSEIF(K.EQ.3)THEN 10761C 10762C K = 3, N = 4 (2**(3-1) 10763C 10764C CON1 = 1 10765C CON2 = 2 10766C CON12 = 3 10767C 10768C COP1 = 1+23 10769C COP2 = 2+13 10770C COP12 = 3+12 10771C 10772C MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS 10773C 10774 IF(NBASE1.GT.6)THEN 10775 IERROR='YES' 10776 GOTO8010 10777 ELSEIF(NBASE2.GT.6)THEN 10778 IERROR='YES' 10779 GOTO8010 10780 ENDIF 10781C 10782C NOW CREATE THE STRINGS 10783C 10784 ISTR1(NBASE1+1:NBASE1+1)='1' 10785 ISTRZ1(1:1)='1' 10786 NCHAR=1 10787 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 10788 IF(IERROR.EQ.'YES')GOTO9000 10789C 10790 ISTR1(NBASE1+1:NBASE1+1)='2' 10791 ISTRZ1(1:1)='2' 10792 NCHAR=1 10793 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 10794 IF(IERROR.EQ.'YES')GOTO9000 10795C 10796 ISTR1(NBASE1+1:NBASE1+2)='12' 10797 ISTRZ1(1:1)='3' 10798 NCHAR=1 10799 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 10800 IF(IERROR.EQ.'YES')GOTO9000 10801C 10802 ISTR2(NBASE2+1:NBASE2+1)='1' 10803 ISTRZ2(1:4)='1+23' 10804 NCHAR=4 10805 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 10806 IF(IERROR.EQ.'YES')GOTO9000 10807C 10808 ISTR2(NBASE2+1:NBASE2+1)='2' 10809 ISTRZ2(1:4)='2+13' 10810 NCHAR=4 10811 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 10812 IF(IERROR.EQ.'YES')GOTO9000 10813C 10814 ISTR2(NBASE2+1:NBASE2+2)='12' 10815 ISTRZ2(1:4)='3+12' 10816 NCHAR=4 10817 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 10818 IF(IERROR.EQ.'YES')GOTO9000 10819C 10820 ELSE 10821 IERROR='YES' 10822 GOTO8030 10823 ENDIF 10824 ELSEIF(NTEMP.EQ.8)THEN 10825 IF(K.EQ.3)THEN 10826C 10827C K = 3, N = 8 (2**3) 10828C 10829C CON1 = 1 10830C CON2 = 2 10831C CON3 = 3 10832C CON12 = 12 10833C CON13 = 13 10834C CON23 = 23 10835C CON123 = 123 10836C 10837C COP1 = 1 10838C COP2 = 2 10839C COP3 = 3 10840C COP12 = 12 10841C COP13 = 13 10842C COP23 = 23 10843C COP123 = 123 10844C 10845C MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS 10846C 10847 IF(NBASE1.GT.5)THEN 10848 IERROR='YES' 10849 GOTO8010 10850 ELSEIF(NBASE2.GT.5)THEN 10851 IERROR='YES' 10852 GOTO8010 10853 ENDIF 10854C 10855C NOW CREATE THE STRINGS 10856C 10857 ISTR1(NBASE1+1:NBASE1+1)='1' 10858 ISTRZ1(1:1)='1' 10859 NCHAR=1 10860 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 10861 IF(IERROR.EQ.'YES')GOTO9000 10862C 10863 ISTR1(NBASE1+1:NBASE1+1)='2' 10864 ISTRZ1(1:1)='2' 10865 NCHAR=1 10866 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 10867 IF(IERROR.EQ.'YES')GOTO9000 10868C 10869 ISTR1(NBASE1+1:NBASE1+2)='3' 10870 ISTRZ1(1:1)='3' 10871 NCHAR=1 10872 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 10873 IF(IERROR.EQ.'YES')GOTO9000 10874C 10875 ISTR1(NBASE1+1:NBASE1+2)='12' 10876 ISTRZ1(1:2)='12' 10877 NCHAR=2 10878 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 10879 IF(IERROR.EQ.'YES')GOTO9000 10880C 10881 ISTR1(NBASE1+1:NBASE1+2)='13' 10882 ISTRZ1(1:2)='13' 10883 NCHAR=2 10884 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 10885 IF(IERROR.EQ.'YES')GOTO9000 10886C 10887 ISTR1(NBASE1+1:NBASE1+2)='23' 10888 ISTRZ1(1:2)='23' 10889 NCHAR=2 10890 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 10891 IF(IERROR.EQ.'YES')GOTO9000 10892C 10893 ISTR1(NBASE1+1:NBASE1+3)='123' 10894 ISTRZ1(1:3)='123' 10895 NCHAR=3 10896 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 10897 IF(IERROR.EQ.'YES')GOTO9000 10898C 10899 ISTR2(NBASE2+1:NBASE2+1)='1' 10900 ISTRZ2(1:1)='1' 10901 NCHAR=1 10902 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 10903 IF(IERROR.EQ.'YES')GOTO9000 10904C 10905 ISTR2(NBASE2+1:NBASE2+1)='2' 10906 ISTRZ2(1:2)='2' 10907 NCHAR=1 10908 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 10909 IF(IERROR.EQ.'YES')GOTO9000 10910C 10911 ISTR2(NBASE2+1:NBASE2+1)='3' 10912 ISTRZ2(1:1)='3' 10913 NCHAR=1 10914 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 10915 IF(IERROR.EQ.'YES')GOTO9000 10916C 10917 ISTR2(NBASE2+1:NBASE2+2)='12' 10918 ISTRZ2(1:2)='12' 10919 NCHAR=2 10920 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 10921 IF(IERROR.EQ.'YES')GOTO9000 10922C 10923 ISTR2(NBASE2+1:NBASE2+2)='13' 10924 ISTRZ2(1:2)='13' 10925 NCHAR=2 10926 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 10927 IF(IERROR.EQ.'YES')GOTO9000 10928C 10929 ISTR2(NBASE2+1:NBASE2+2)='23' 10930 ISTRZ2(1:2)='23' 10931 NCHAR=2 10932 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 10933 IF(IERROR.EQ.'YES')GOTO9000 10934C 10935 ISTR2(NBASE2+1:NBASE2+3)='123' 10936 ISTRZ2(1:3)='123' 10937 NCHAR=3 10938 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 10939 IF(IERROR.EQ.'YES')GOTO9000 10940C 10941 ELSEIF(K.EQ.4)THEN 10942C 10943C K = 4, N = 8 (2**(4-1)) 10944C 10945C CON1 = 1 10946C CON2 = 2 10947C CON3 = 3 10948C CON12 = 12 10949C CON13 = 13 10950C CON23 = 14 10951C CON123 = 4 10952C 10953C COP1 = 1 10954C COP2 = 2 10955C COP3 = 3 10956C COP12 = 12+34 10957C COP13 = 13+24 10958C COP23 = 14+23 10959C COP123 = 4 10960C 10961C MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS 10962C 10963 IF(NBASE1.GT.5)THEN 10964 IERROR='YES' 10965 GOTO8010 10966 ELSEIF(NBASE2.GT.5)THEN 10967 IERROR='YES' 10968 GOTO8010 10969 ENDIF 10970C 10971C NOW CREATE THE STRINGS 10972C 10973 ISTR1(NBASE1+1:NBASE1+1)='1' 10974 ISTRZ1(1:1)='1' 10975 NCHAR=1 10976 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 10977 IF(IERROR.EQ.'YES')GOTO9000 10978C 10979 ISTR1(NBASE1+1:NBASE1+1)='2' 10980 ISTRZ1(1:1)='2' 10981 NCHAR=1 10982 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 10983 IF(IERROR.EQ.'YES')GOTO9000 10984C 10985 ISTR1(NBASE1+1:NBASE1+2)='3' 10986 ISTRZ1(1:1)='3' 10987 NCHAR=1 10988 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 10989 IF(IERROR.EQ.'YES')GOTO9000 10990C 10991 ISTR1(NBASE1+1:NBASE1+2)='12' 10992 ISTRZ1(1:2)='12' 10993 NCHAR=2 10994 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 10995 IF(IERROR.EQ.'YES')GOTO9000 10996C 10997 ISTR1(NBASE1+1:NBASE1+2)='13' 10998 ISTRZ1(1:2)='13' 10999 NCHAR=2 11000 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11001 IF(IERROR.EQ.'YES')GOTO9000 11002C 11003 ISTR1(NBASE1+1:NBASE1+2)='23' 11004 ISTRZ1(1:2)='14' 11005 NCHAR=2 11006 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11007 IF(IERROR.EQ.'YES')GOTO9000 11008C 11009 ISTR1(NBASE1+1:NBASE1+3)='123' 11010 ISTRZ1(1:1)='4' 11011 NCHAR=1 11012 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11013 IF(IERROR.EQ.'YES')GOTO9000 11014C 11015 ISTR2(NBASE2+1:NBASE2+1)='1' 11016 ISTRZ2(1:1)='1' 11017 NCHAR=1 11018 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11019 IF(IERROR.EQ.'YES')GOTO9000 11020C 11021 ISTR2(NBASE2+1:NBASE2+1)='2' 11022 ISTRZ2(1:2)='2' 11023 NCHAR=1 11024 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11025 IF(IERROR.EQ.'YES')GOTO9000 11026C 11027 ISTR2(NBASE2+1:NBASE2+1)='3' 11028 ISTRZ2(1:1)='3' 11029 NCHAR=1 11030 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11031 IF(IERROR.EQ.'YES')GOTO9000 11032C 11033 ISTR2(NBASE2+1:NBASE2+2)='12' 11034 ISTRZ2(1:5)='12+34' 11035 NCHAR=5 11036 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11037 IF(IERROR.EQ.'YES')GOTO9000 11038C 11039 ISTR2(NBASE2+1:NBASE2+2)='13' 11040 ISTRZ2(1:5)='13+24' 11041 NCHAR=5 11042 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11043 IF(IERROR.EQ.'YES')GOTO9000 11044C 11045 ISTR2(NBASE2+1:NBASE2+2)='23' 11046 ISTRZ2(1:5)='14+23' 11047 NCHAR=5 11048 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11049 IF(IERROR.EQ.'YES')GOTO9000 11050C 11051 ISTR2(NBASE2+1:NBASE2+3)='123' 11052 ISTRZ2(1:1)='4' 11053 NCHAR=1 11054 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11055 IF(IERROR.EQ.'YES')GOTO9000 11056C 11057 ELSEIF(K.EQ.5)THEN 11058C 11059C K = 5, N = 8 (2**(5-2)) 11060C 11061C CON1 = 1 11062C CON2 = 2 11063C CON3 = 3 11064C CON12 = 4 11065C CON13 = 5 11066C CON23 = 23 11067C CON123 = 25 11068C 11069C COP1 = 1+24+35 11070C COP2 = 2+14 11071C COP3 = 3+15 11072C COP12 = 4+12 11073C COP13 = 5+13 11074C COP23 = 23+45 11075C COP123 = 25+34 11076C 11077C MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS 11078C 11079 IF(NBASE1.GT.5)THEN 11080 IERROR='YES' 11081 GOTO8010 11082 ELSEIF(NBASE2.GT.5)THEN 11083 IERROR='YES' 11084 GOTO8010 11085 ENDIF 11086C 11087C NOW CREATE THE STRINGS 11088C 11089 ISTR1(NBASE1+1:NBASE1+1)='1' 11090 ISTRZ1(1:1)='1' 11091 NCHAR=1 11092 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11093 IF(IERROR.EQ.'YES')GOTO9000 11094C 11095 ISTR1(NBASE1+1:NBASE1+1)='2' 11096 ISTRZ1(1:1)='2' 11097 NCHAR=1 11098 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11099 IF(IERROR.EQ.'YES')GOTO9000 11100C 11101 ISTR1(NBASE1+1:NBASE1+2)='3' 11102 ISTRZ1(1:1)='3' 11103 NCHAR=1 11104 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11105 IF(IERROR.EQ.'YES')GOTO9000 11106C 11107 ISTR1(NBASE1+1:NBASE1+2)='12' 11108 ISTRZ1(1:1)='4' 11109 NCHAR=1 11110 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11111 IF(IERROR.EQ.'YES')GOTO9000 11112C 11113 ISTR1(NBASE1+1:NBASE1+2)='13' 11114 ISTRZ1(1:1)='5' 11115 NCHAR=1 11116 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11117 IF(IERROR.EQ.'YES')GOTO9000 11118C 11119 ISTR1(NBASE1+1:NBASE1+2)='23' 11120 ISTRZ1(1:2)='23' 11121 NCHAR=2 11122 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11123 IF(IERROR.EQ.'YES')GOTO9000 11124C 11125 ISTR1(NBASE1+1:NBASE1+3)='123' 11126 ISTRZ1(1:2)='25' 11127 NCHAR=2 11128 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11129 IF(IERROR.EQ.'YES')GOTO9000 11130C 11131 ISTR2(NBASE2+1:NBASE2+1)='1' 11132 ISTRZ2(1:7)='1+24+35' 11133 NCHAR=7 11134 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11135 IF(IERROR.EQ.'YES')GOTO9000 11136C 11137 ISTR2(NBASE2+1:NBASE2+1)='2' 11138 ISTRZ2(1:4)='2+14' 11139 NCHAR=4 11140 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11141 IF(IERROR.EQ.'YES')GOTO9000 11142C 11143 ISTR2(NBASE2+1:NBASE2+1)='3' 11144 ISTRZ2(1:4)='3+15' 11145 NCHAR=4 11146 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11147 IF(IERROR.EQ.'YES')GOTO9000 11148C 11149 ISTR2(NBASE2+1:NBASE2+2)='12' 11150 ISTRZ2(1:4)='4+12' 11151 NCHAR=4 11152 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11153 IF(IERROR.EQ.'YES')GOTO9000 11154C 11155 ISTR2(NBASE2+1:NBASE2+2)='13' 11156 ISTRZ2(1:4)='5+13' 11157 NCHAR=4 11158 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11159 IF(IERROR.EQ.'YES')GOTO9000 11160C 11161 ISTR2(NBASE2+1:NBASE2+2)='23' 11162 ISTRZ2(1:5)='23+45' 11163 NCHAR=5 11164 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11165 IF(IERROR.EQ.'YES')GOTO9000 11166C 11167 ISTR2(NBASE2+1:NBASE2+3)='123' 11168 ISTRZ2(1:5)='25+34' 11169 NCHAR=5 11170 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11171 IF(IERROR.EQ.'YES')GOTO9000 11172C 11173 ELSEIF(K.EQ.6)THEN 11174C 11175C K = 6, N = 8 (2**(6-3)) 11176C 11177C CON1 = 1 11178C CON2 = 2 11179C CON3 = 3 11180C CON12 = 4 11181C CON13 = 5 11182C CON23 = 6 11183C CON123 = 16 11184C 11185C COP1 = 1+24+35 11186C COP2 = 2+14+36 11187C COP3 = 3+15+26 11188C COP12 = 4+12+56 11189C COP13 = 5+13+46 11190C COP23 = 6+23+45 11191C COP123 = 16+25+34 11192C 11193C MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS 11194C 11195 IF(NBASE1.GT.5)THEN 11196 IERROR='YES' 11197 GOTO8010 11198 ELSEIF(NBASE2.GT.5)THEN 11199 IERROR='YES' 11200 GOTO8010 11201 ENDIF 11202C 11203C NOW CREATE THE STRINGS 11204C 11205 ISTR1(NBASE1+1:NBASE1+1)='1' 11206 ISTRZ1(1:1)='1' 11207 NCHAR=1 11208 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11209 IF(IERROR.EQ.'YES')GOTO9000 11210C 11211 ISTR1(NBASE1+1:NBASE1+1)='2' 11212 ISTRZ1(1:1)='2' 11213 NCHAR=1 11214 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11215 IF(IERROR.EQ.'YES')GOTO9000 11216C 11217 ISTR1(NBASE1+1:NBASE1+2)='3' 11218 ISTRZ1(1:1)='3' 11219 NCHAR=1 11220 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11221 IF(IERROR.EQ.'YES')GOTO9000 11222C 11223 ISTR1(NBASE1+1:NBASE1+2)='12' 11224 ISTRZ1(1:1)='4' 11225 NCHAR=1 11226 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11227 IF(IERROR.EQ.'YES')GOTO9000 11228C 11229 ISTR1(NBASE1+1:NBASE1+2)='13' 11230 ISTRZ1(1:1)='5' 11231 NCHAR=1 11232 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11233 IF(IERROR.EQ.'YES')GOTO9000 11234C 11235 ISTR1(NBASE1+1:NBASE1+2)='23' 11236 ISTRZ1(1:1)='6' 11237 NCHAR=1 11238 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11239 IF(IERROR.EQ.'YES')GOTO9000 11240C 11241 ISTR1(NBASE1+1:NBASE1+3)='123' 11242 ISTRZ1(1:2)='16' 11243 NCHAR=2 11244 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11245 IF(IERROR.EQ.'YES')GOTO9000 11246C 11247 ISTR2(NBASE2+1:NBASE2+1)='1' 11248 ISTRZ2(1:7)='1+24+35' 11249 NCHAR=7 11250 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11251 IF(IERROR.EQ.'YES')GOTO9000 11252C 11253 ISTR2(NBASE2+1:NBASE2+1)='2' 11254 ISTRZ2(1:7)='2+14+36' 11255 NCHAR=7 11256 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11257 IF(IERROR.EQ.'YES')GOTO9000 11258C 11259 ISTR2(NBASE2+1:NBASE2+1)='3' 11260 ISTRZ2(1:7)='3+15+26' 11261 NCHAR=7 11262 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11263 IF(IERROR.EQ.'YES')GOTO9000 11264C 11265 ISTR2(NBASE2+1:NBASE2+2)='12' 11266 ISTRZ2(1:7)='4+12+56' 11267 NCHAR=7 11268 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11269 IF(IERROR.EQ.'YES')GOTO9000 11270C 11271 ISTR2(NBASE2+1:NBASE2+2)='13' 11272 ISTRZ2(1:7)='5+13+46' 11273 NCHAR=7 11274 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11275 IF(IERROR.EQ.'YES')GOTO9000 11276C 11277 ISTR2(NBASE2+1:NBASE2+2)='23' 11278 ISTRZ2(1:7)='6+23+45' 11279 NCHAR=7 11280 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11281 IF(IERROR.EQ.'YES')GOTO9000 11282C 11283 ISTR2(NBASE2+1:NBASE2+3)='123' 11284 ISTRZ2(1:8)='16+25+34' 11285 NCHAR=8 11286 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11287 IF(IERROR.EQ.'YES')GOTO9000 11288C 11289 ELSEIF(K.EQ.7)THEN 11290C 11291C K = 7, N = 8 (2**(7-4)) 11292C 11293C CON1 = 1 11294C CON2 = 2 11295C CON3 = 3 11296C CON12 = 4 11297C CON13 = 5 11298C CON23 = 6 11299C CON123 = 7 11300C 11301C COP1 = 1+24+35+67 11302C COP2 = 2+14+36+57 11303C COP3 = 3+15+26+47 11304C COP12 = 4+12+56+37 11305C COP13 = 5+13+46+17 11306C COP23 = 6+23+45+17 11307C COP123 = 7+16+25+34 11308C 11309C MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS 11310C 11311 IF(NBASE1.GT.5)THEN 11312 IERROR='YES' 11313 GOTO8010 11314 ELSEIF(NBASE2.GT.5)THEN 11315 IERROR='YES' 11316 GOTO8010 11317 ENDIF 11318C 11319C NOW CREATE THE STRINGS 11320C 11321 ISTR1(NBASE1+1:NBASE1+1)='1' 11322 ISTRZ1(1:1)='1' 11323 NCHAR=1 11324 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11325 IF(IERROR.EQ.'YES')GOTO9000 11326C 11327 ISTR1(NBASE1+1:NBASE1+1)='2' 11328 ISTRZ1(1:1)='2' 11329 NCHAR=1 11330 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11331 IF(IERROR.EQ.'YES')GOTO9000 11332C 11333 ISTR1(NBASE1+1:NBASE1+2)='3' 11334 ISTRZ1(1:1)='3' 11335 NCHAR=1 11336 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11337 IF(IERROR.EQ.'YES')GOTO9000 11338C 11339 ISTR1(NBASE1+1:NBASE1+2)='12' 11340 ISTRZ1(1:1)='4' 11341 NCHAR=1 11342 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11343 IF(IERROR.EQ.'YES')GOTO9000 11344C 11345 ISTR1(NBASE1+1:NBASE1+2)='13' 11346 ISTRZ1(1:1)='5' 11347 NCHAR=1 11348 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11349 IF(IERROR.EQ.'YES')GOTO9000 11350C 11351 ISTR1(NBASE1+1:NBASE1+2)='23' 11352 ISTRZ1(1:1)='6' 11353 NCHAR=1 11354 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11355 IF(IERROR.EQ.'YES')GOTO9000 11356C 11357 ISTR1(NBASE1+1:NBASE1+3)='123' 11358 ISTRZ1(1:1)='7' 11359 NCHAR=1 11360 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11361 IF(IERROR.EQ.'YES')GOTO9000 11362C 11363 ISTR2(NBASE2+1:NBASE2+1)='1' 11364 ISTRZ2(1:10)='1+24+35+67' 11365 NCHAR=10 11366 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11367 IF(IERROR.EQ.'YES')GOTO9000 11368C 11369 ISTR2(NBASE2+1:NBASE2+1)='2' 11370 ISTRZ2(1:10)='2+14+36+57' 11371 NCHAR=10 11372 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11373 IF(IERROR.EQ.'YES')GOTO9000 11374C 11375 ISTR2(NBASE2+1:NBASE2+1)='3' 11376 ISTRZ2(1:10)='3+15+26+47' 11377 NCHAR=10 11378 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11379 IF(IERROR.EQ.'YES')GOTO9000 11380C 11381 ISTR2(NBASE2+1:NBASE2+2)='12' 11382 ISTRZ2(1:10)='4+12+56+37' 11383 NCHAR=10 11384 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11385 IF(IERROR.EQ.'YES')GOTO9000 11386C 11387 ISTR2(NBASE2+1:NBASE2+2)='13' 11388 ISTRZ2(1:10)='5+13+46+17' 11389 NCHAR=10 11390 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11391 IF(IERROR.EQ.'YES')GOTO9000 11392C 11393 ISTR2(NBASE2+1:NBASE2+2)='23' 11394 ISTRZ2(1:10)='6+23+45+17' 11395 NCHAR=10 11396 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11397 IF(IERROR.EQ.'YES')GOTO9000 11398C 11399 ISTR2(NBASE2+1:NBASE2+3)='123' 11400 ISTRZ2(1:10)='7+16+25+34' 11401 NCHAR=10 11402 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11403 IF(IERROR.EQ.'YES')GOTO9000 11404C 11405 ELSE 11406 IERROR='YES' 11407 GOTO8030 11408 ENDIF 11409 ELSEIF(NTEMP.EQ.16)THEN 11410 IF(K.EQ.4)THEN 11411C 11412C K = 4, N = 16 (2**4) 11413C 11414C CON1 = 1 11415C CON2 = 2 11416C CON3 = 3 11417C CON4 = 4 11418C CON12 = 12 11419C CON13 = 13 11420C CON14 = 14 11421C CON23 = 23 11422C CON24 = 24 11423C CON34 = 34 11424C CON123 = 123 11425C CON124 = 124 11426C CON134 = 134 11427C CON234 = 234 11428C CON1234 = 1234 11429C 11430C COP1 = 1 11431C COP2 = 2 11432C COP3 = 3 11433C COP4 = 4 11434C COP12 = 12 11435C COP13 = 13 11436C COP14 = 14 11437C COP23 = 23 11438C COP24 = 24 11439C COP34 = 34 11440C COP123 = 123 11441C COP124 = 124 11442C COP134 = 134 11443C COP234 = 234 11444C COP1234 = 1234 11445C 11446C MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS 11447C 11448 IF(NBASE1.GT.4)THEN 11449 IERROR='YES' 11450 GOTO8010 11451 ELSEIF(NBASE2.GT.4)THEN 11452 IERROR='YES' 11453 GOTO8010 11454 ENDIF 11455C 11456C NOW CREATE THE STRINGS 11457C 11458 ISTR1(NBASE1+1:NBASE1+1)='1' 11459 ISTRZ1(1:1)='1' 11460 NCHAR=1 11461 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11462 IF(IERROR.EQ.'YES')GOTO9000 11463C 11464 ISTR1(NBASE1+1:NBASE1+1)='2' 11465 ISTRZ1(1:1)='2' 11466 NCHAR=1 11467 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11468 IF(IERROR.EQ.'YES')GOTO9000 11469C 11470 ISTR1(NBASE1+1:NBASE1+2)='3' 11471 ISTRZ1(1:1)='3' 11472 NCHAR=1 11473 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11474 IF(IERROR.EQ.'YES')GOTO9000 11475C 11476 ISTR1(NBASE1+1:NBASE1+2)='4' 11477 ISTRZ1(1:1)='4' 11478 NCHAR=1 11479 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11480 IF(IERROR.EQ.'YES')GOTO9000 11481C 11482 ISTR1(NBASE1+1:NBASE1+2)='12' 11483 ISTRZ1(1:2)='12' 11484 NCHAR=2 11485 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11486 IF(IERROR.EQ.'YES')GOTO9000 11487C 11488 ISTR1(NBASE1+1:NBASE1+2)='13' 11489 ISTRZ1(1:2)='13' 11490 NCHAR=2 11491 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11492 IF(IERROR.EQ.'YES')GOTO9000 11493C 11494 ISTR1(NBASE1+1:NBASE1+2)='14' 11495 ISTRZ1(1:2)='14' 11496 NCHAR=2 11497 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11498 IF(IERROR.EQ.'YES')GOTO9000 11499C 11500 ISTR1(NBASE1+1:NBASE1+2)='23' 11501 ISTRZ1(1:2)='23' 11502 NCHAR=2 11503 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11504 IF(IERROR.EQ.'YES')GOTO9000 11505C 11506 ISTR1(NBASE1+1:NBASE1+2)='24' 11507 ISTRZ1(1:2)='24' 11508 NCHAR=2 11509 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11510 IF(IERROR.EQ.'YES')GOTO9000 11511C 11512 ISTR1(NBASE1+1:NBASE1+2)='34' 11513 ISTRZ1(1:2)='34' 11514 NCHAR=2 11515 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11516 IF(IERROR.EQ.'YES')GOTO9000 11517C 11518 ISTR1(NBASE1+1:NBASE1+3)='123' 11519 ISTRZ1(1:3)='123' 11520 NCHAR=3 11521 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11522 IF(IERROR.EQ.'YES')GOTO9000 11523C 11524 ISTR1(NBASE1+1:NBASE1+3)='124' 11525 ISTRZ1(1:3)='124' 11526 NCHAR=3 11527 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11528 IF(IERROR.EQ.'YES')GOTO9000 11529C 11530 ISTR1(NBASE1+1:NBASE1+3)='134' 11531 ISTRZ1(1:3)='134' 11532 NCHAR=3 11533 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11534 IF(IERROR.EQ.'YES')GOTO9000 11535C 11536 ISTR1(NBASE1+1:NBASE1+3)='234' 11537 ISTRZ1(1:3)='234' 11538 NCHAR=3 11539 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11540 IF(IERROR.EQ.'YES')GOTO9000 11541C 11542 ISTR1(NBASE1+1:NBASE1+4)='1234' 11543 ISTRZ1(1:4)='1234' 11544 NCHAR=4 11545 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11546 IF(IERROR.EQ.'YES')GOTO9000 11547C 11548 ISTR2(NBASE2+1:NBASE2+1)='1' 11549 ISTRZ2(1:1)='1' 11550 NCHAR=1 11551 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11552 IF(IERROR.EQ.'YES')GOTO9000 11553C 11554 ISTR2(NBASE2+1:NBASE2+1)='2' 11555 ISTRZ2(1:1)='2' 11556 NCHAR=1 11557 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11558 IF(IERROR.EQ.'YES')GOTO9000 11559C 11560 ISTR2(NBASE2+1:NBASE2+1)='3' 11561 ISTRZ2(1:1)='3' 11562 NCHAR=1 11563 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11564 IF(IERROR.EQ.'YES')GOTO9000 11565C 11566 ISTR2(NBASE2+1:NBASE2+1)='4' 11567 ISTRZ2(1:1)='4' 11568 NCHAR=1 11569 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11570 IF(IERROR.EQ.'YES')GOTO9000 11571C 11572 ISTR2(NBASE2+1:NBASE2+2)='12' 11573 ISTRZ2(1:2)='12' 11574 NCHAR=2 11575 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11576 IF(IERROR.EQ.'YES')GOTO9000 11577C 11578 ISTR2(NBASE2+1:NBASE2+2)='13' 11579 ISTRZ2(1:2)='13' 11580 NCHAR=2 11581 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11582 IF(IERROR.EQ.'YES')GOTO9000 11583C 11584 ISTR2(NBASE2+1:NBASE2+2)='14' 11585 ISTRZ2(1:2)='14' 11586 NCHAR=2 11587 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11588 IF(IERROR.EQ.'YES')GOTO9000 11589C 11590 ISTR2(NBASE2+1:NBASE2+2)='23' 11591 ISTRZ2(1:2)='23' 11592 NCHAR=2 11593 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11594 IF(IERROR.EQ.'YES')GOTO9000 11595C 11596 ISTR2(NBASE2+1:NBASE2+2)='24' 11597 ISTRZ2(1:2)='24' 11598 NCHAR=2 11599 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11600 IF(IERROR.EQ.'YES')GOTO9000 11601C 11602 ISTR2(NBASE2+1:NBASE2+2)='34' 11603 ISTRZ2(1:2)='34' 11604 NCHAR=2 11605 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11606 IF(IERROR.EQ.'YES')GOTO9000 11607C 11608 ISTR2(NBASE2+1:NBASE2+3)='123' 11609 ISTRZ2(1:3)='123' 11610 NCHAR=3 11611 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11612 IF(IERROR.EQ.'YES')GOTO9000 11613C 11614 ISTR2(NBASE2+1:NBASE2+3)='124' 11615 ISTRZ2(1:3)='124' 11616 NCHAR=3 11617 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11618 IF(IERROR.EQ.'YES')GOTO9000 11619C 11620 ISTR2(NBASE2+1:NBASE2+3)='134' 11621 ISTRZ2(1:3)='134' 11622 NCHAR=3 11623 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11624 IF(IERROR.EQ.'YES')GOTO9000 11625C 11626 ISTR2(NBASE2+1:NBASE2+3)='234' 11627 ISTRZ2(1:3)='234' 11628 NCHAR=3 11629 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11630 IF(IERROR.EQ.'YES')GOTO9000 11631C 11632 ISTR2(NBASE2+1:NBASE2+4)='1234' 11633 ISTRZ2(1:4)='1234' 11634 NCHAR=4 11635 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11636 IF(IERROR.EQ.'YES')GOTO9000 11637C 11638 ELSEIF(K.EQ.5)THEN 11639C 11640C K = 5, N = 16 (2**(5-1)) 11641C 11642C CON1 = 1 11643C CON2 = 2 11644C CON3 = 3 11645C CON4 = 4 11646C CON12 = 12 11647C CON13 = 13 11648C CON14 = 14 11649C CON23 = 23 11650C CON24 = 24 11651C CON34 = 34 11652C CON123 = 45 11653C CON124 = 35 11654C CON134 = 25 11655C CON234 = 15 11656C CON1234 = 5 11657C 11658C COP1 = 1 11659C COP2 = 2 11660C COP3 = 3 11661C COP4 = 4 11662C COP12 = 12 11663C COP13 = 13 11664C COP14 = 14 11665C COP23 = 23 11666C COP24 = 24 11667C COP34 = 34 11668C COP123 = 45 11669C COP124 = 35 11670C COP134 = 25 11671C COP234 = 15 11672C COP1234 = 5 11673C 11674C MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS 11675C 11676 IF(NBASE1.GT.4)THEN 11677 IERROR='YES' 11678 GOTO8010 11679 ELSEIF(NBASE2.GT.4)THEN 11680 IERROR='YES' 11681 GOTO8010 11682 ENDIF 11683C 11684C NOW CREATE THE STRINGS 11685C 11686 ISTR1(NBASE1+1:NBASE1+1)='1' 11687 ISTRZ1(1:1)='1' 11688 NCHAR=1 11689 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11690 IF(IERROR.EQ.'YES')GOTO9000 11691C 11692 ISTR1(NBASE1+1:NBASE1+1)='2' 11693 ISTRZ1(1:1)='2' 11694 NCHAR=1 11695 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11696 IF(IERROR.EQ.'YES')GOTO9000 11697C 11698 ISTR1(NBASE1+1:NBASE1+2)='3' 11699 ISTRZ1(1:1)='3' 11700 NCHAR=1 11701 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11702 IF(IERROR.EQ.'YES')GOTO9000 11703C 11704 ISTR1(NBASE1+1:NBASE1+2)='4' 11705 ISTRZ1(1:1)='4' 11706 NCHAR=1 11707 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11708 IF(IERROR.EQ.'YES')GOTO9000 11709C 11710 ISTR1(NBASE1+1:NBASE1+2)='12' 11711 ISTRZ1(1:2)='12' 11712 NCHAR=2 11713 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11714 IF(IERROR.EQ.'YES')GOTO9000 11715C 11716 ISTR1(NBASE1+1:NBASE1+2)='13' 11717 ISTRZ1(1:2)='13' 11718 NCHAR=2 11719 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11720 IF(IERROR.EQ.'YES')GOTO9000 11721C 11722 ISTR1(NBASE1+1:NBASE1+2)='14' 11723 ISTRZ1(1:2)='14' 11724 NCHAR=2 11725 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11726 IF(IERROR.EQ.'YES')GOTO9000 11727C 11728 ISTR1(NBASE1+1:NBASE1+2)='23' 11729 ISTRZ1(1:2)='23' 11730 NCHAR=2 11731 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11732 IF(IERROR.EQ.'YES')GOTO9000 11733C 11734 ISTR1(NBASE1+1:NBASE1+2)='24' 11735 ISTRZ1(1:2)='24' 11736 NCHAR=2 11737 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11738 IF(IERROR.EQ.'YES')GOTO9000 11739C 11740 ISTR1(NBASE1+1:NBASE1+2)='34' 11741 ISTRZ1(1:2)='34' 11742 NCHAR=2 11743 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11744 IF(IERROR.EQ.'YES')GOTO9000 11745C 11746 ISTR1(NBASE1+1:NBASE1+3)='123' 11747 ISTRZ1(1:2)='45' 11748 NCHAR=2 11749 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11750 IF(IERROR.EQ.'YES')GOTO9000 11751C 11752 ISTR1(NBASE1+1:NBASE1+3)='124' 11753 ISTRZ1(1:2)='35' 11754 NCHAR=2 11755 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11756 IF(IERROR.EQ.'YES')GOTO9000 11757C 11758 ISTR1(NBASE1+1:NBASE1+3)='134' 11759 ISTRZ1(1:2)='25' 11760 NCHAR=2 11761 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11762 IF(IERROR.EQ.'YES')GOTO9000 11763C 11764 ISTR1(NBASE1+1:NBASE1+3)='234' 11765 ISTRZ1(1:2)='15' 11766 NCHAR=2 11767 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11768 IF(IERROR.EQ.'YES')GOTO9000 11769C 11770 ISTR1(NBASE1+1:NBASE1+4)='1234' 11771 ISTRZ1(1:1)='5' 11772 NCHAR=1 11773 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11774 IF(IERROR.EQ.'YES')GOTO9000 11775C 11776 ISTR2(NBASE2+1:NBASE2+1)='1' 11777 ISTRZ2(1:1)='1' 11778 NCHAR=1 11779 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11780 IF(IERROR.EQ.'YES')GOTO9000 11781C 11782 ISTR2(NBASE2+1:NBASE2+1)='2' 11783 ISTRZ2(1:1)='2' 11784 NCHAR=1 11785 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11786 IF(IERROR.EQ.'YES')GOTO9000 11787C 11788 ISTR2(NBASE2+1:NBASE2+1)='3' 11789 ISTRZ2(1:1)='3' 11790 NCHAR=1 11791 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11792 IF(IERROR.EQ.'YES')GOTO9000 11793C 11794 ISTR2(NBASE2+1:NBASE2+1)='4' 11795 ISTRZ2(1:1)='4' 11796 NCHAR=1 11797 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11798 IF(IERROR.EQ.'YES')GOTO9000 11799C 11800 ISTR2(NBASE2+1:NBASE2+2)='12' 11801 ISTRZ2(1:2)='12' 11802 NCHAR=2 11803 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11804 IF(IERROR.EQ.'YES')GOTO9000 11805C 11806 ISTR2(NBASE2+1:NBASE2+2)='13' 11807 ISTRZ2(1:2)='13' 11808 NCHAR=2 11809 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11810 IF(IERROR.EQ.'YES')GOTO9000 11811C 11812 ISTR2(NBASE2+1:NBASE2+2)='14' 11813 ISTRZ2(1:2)='14' 11814 NCHAR=2 11815 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11816 IF(IERROR.EQ.'YES')GOTO9000 11817C 11818 ISTR2(NBASE2+1:NBASE2+2)='23' 11819 ISTRZ2(1:2)='23' 11820 NCHAR=2 11821 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11822 IF(IERROR.EQ.'YES')GOTO9000 11823C 11824 ISTR2(NBASE2+1:NBASE2+2)='24' 11825 ISTRZ2(1:2)='24' 11826 NCHAR=2 11827 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11828 IF(IERROR.EQ.'YES')GOTO9000 11829C 11830 ISTR2(NBASE2+1:NBASE2+2)='34' 11831 ISTRZ2(1:2)='34' 11832 NCHAR=2 11833 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11834 IF(IERROR.EQ.'YES')GOTO9000 11835C 11836 ISTR2(NBASE2+1:NBASE2+3)='123' 11837 ISTRZ2(1:2)='45' 11838 NCHAR=2 11839 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11840 IF(IERROR.EQ.'YES')GOTO9000 11841C 11842 ISTR2(NBASE2+1:NBASE2+3)='124' 11843 ISTRZ2(1:2)='35' 11844 NCHAR=2 11845 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11846 IF(IERROR.EQ.'YES')GOTO9000 11847C 11848 ISTR2(NBASE2+1:NBASE2+3)='134' 11849 ISTRZ2(1:2)='25' 11850 NCHAR=2 11851 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11852 IF(IERROR.EQ.'YES')GOTO9000 11853C 11854 ISTR2(NBASE2+1:NBASE2+3)='234' 11855 ISTRZ2(1:2)='15' 11856 NCHAR=2 11857 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11858 IF(IERROR.EQ.'YES')GOTO9000 11859C 11860 ISTR2(NBASE2+1:NBASE2+4)='1234' 11861 ISTRZ2(1:1)='5' 11862 NCHAR=1 11863 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 11864 IF(IERROR.EQ.'YES')GOTO9000 11865C 11866 ELSEIF(K.EQ.6)THEN 11867C 11868C K = 6, N = 16 (2**(6-2)) 11869C 11870C CON1 = 1 11871C CON2 = 2 11872C CON3 = 3 11873C CON4 = 4 11874C CON12 = 12 11875C CON13 = 13 11876C CON14 = 14 11877C CON23 = 23 11878C CON24 = 24 11879C CON34 = 34 11880C CON123 = 5 11881C CON124 = 124 11882C CON134 = 134 11883C CON234 = 6 11884C CON1234 = 16 11885C 11886C COP1 = 1 11887C COP2 = 2 11888C COP3 = 3 11889C COP4 = 4 11890C COP12 = 12+35 11891C COP13 = 13+25 11892C COP14 = 14+56 11893C COP23 = 23+15+46 11894C COP24 = 24+36 11895C COP34 = 34+26 11896C COP123 = 5 11897C COP124 = 124 11898C COP134 = 134 11899C COP234 = 6 11900C COP1234 = 45 11901C 11902C MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS 11903C 11904 IF(NBASE1.GT.4)THEN 11905 IERROR='YES' 11906 GOTO8010 11907 ELSEIF(NBASE2.GT.4)THEN 11908 IERROR='YES' 11909 GOTO8010 11910 ENDIF 11911C 11912C NOW CREATE THE STRINGS 11913C 11914 ISTR1(NBASE1+1:NBASE1+1)='1' 11915 ISTRZ1(1:1)='1' 11916 NCHAR=1 11917 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11918 IF(IERROR.EQ.'YES')GOTO9000 11919C 11920 ISTR1(NBASE1+1:NBASE1+1)='2' 11921 ISTRZ1(1:1)='2' 11922 NCHAR=1 11923 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11924 IF(IERROR.EQ.'YES')GOTO9000 11925C 11926 ISTR1(NBASE1+1:NBASE1+2)='3' 11927 ISTRZ1(1:1)='3' 11928 NCHAR=1 11929 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11930 IF(IERROR.EQ.'YES')GOTO9000 11931C 11932 ISTR1(NBASE1+1:NBASE1+2)='4' 11933 ISTRZ1(1:1)='4' 11934 NCHAR=1 11935 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11936 IF(IERROR.EQ.'YES')GOTO9000 11937C 11938 ISTR1(NBASE1+1:NBASE1+2)='12' 11939 ISTRZ1(1:2)='12' 11940 NCHAR=2 11941 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11942 IF(IERROR.EQ.'YES')GOTO9000 11943C 11944 ISTR1(NBASE1+1:NBASE1+2)='13' 11945 ISTRZ1(1:2)='13' 11946 NCHAR=2 11947 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11948 IF(IERROR.EQ.'YES')GOTO9000 11949C 11950 ISTR1(NBASE1+1:NBASE1+2)='14' 11951 ISTRZ1(1:2)='14' 11952 NCHAR=2 11953 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11954 IF(IERROR.EQ.'YES')GOTO9000 11955C 11956 ISTR1(NBASE1+1:NBASE1+2)='23' 11957 ISTRZ1(1:2)='23' 11958 NCHAR=2 11959 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11960 IF(IERROR.EQ.'YES')GOTO9000 11961C 11962 ISTR1(NBASE1+1:NBASE1+2)='24' 11963 ISTRZ1(1:2)='24' 11964 NCHAR=2 11965 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11966 IF(IERROR.EQ.'YES')GOTO9000 11967C 11968 ISTR1(NBASE1+1:NBASE1+2)='34' 11969 ISTRZ1(1:2)='34' 11970 NCHAR=2 11971 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11972 IF(IERROR.EQ.'YES')GOTO9000 11973C 11974 ISTR1(NBASE1+1:NBASE1+3)='123' 11975 ISTRZ1(1:1)='5' 11976 NCHAR=1 11977 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11978 IF(IERROR.EQ.'YES')GOTO9000 11979C 11980 ISTR1(NBASE1+1:NBASE1+3)='124' 11981 ISTRZ1(1:3)='124' 11982 NCHAR=3 11983 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11984 IF(IERROR.EQ.'YES')GOTO9000 11985C 11986 ISTR1(NBASE1+1:NBASE1+3)='134' 11987 ISTRZ1(1:3)='134' 11988 NCHAR=3 11989 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11990 IF(IERROR.EQ.'YES')GOTO9000 11991C 11992 ISTR1(NBASE1+1:NBASE1+3)='234' 11993 ISTRZ1(1:1)='6' 11994 NCHAR=1 11995 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 11996 IF(IERROR.EQ.'YES')GOTO9000 11997C 11998 ISTR1(NBASE1+1:NBASE1+4)='1234' 11999 ISTRZ1(1:2)='16' 12000 NCHAR=2 12001 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12002 IF(IERROR.EQ.'YES')GOTO9000 12003C 12004 ISTR2(NBASE2+1:NBASE2+1)='1' 12005 ISTRZ2(1:1)='1' 12006 NCHAR=1 12007 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12008 IF(IERROR.EQ.'YES')GOTO9000 12009C 12010 ISTR2(NBASE2+1:NBASE2+1)='2' 12011 ISTRZ2(1:1)='2' 12012 NCHAR=1 12013 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12014 IF(IERROR.EQ.'YES')GOTO9000 12015C 12016 ISTR2(NBASE2+1:NBASE2+1)='3' 12017 ISTRZ2(1:1)='3' 12018 NCHAR=1 12019 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12020 IF(IERROR.EQ.'YES')GOTO9000 12021C 12022 ISTR2(NBASE2+1:NBASE2+1)='4' 12023 ISTRZ2(1:1)='4' 12024 NCHAR=1 12025 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12026 IF(IERROR.EQ.'YES')GOTO9000 12027C 12028 ISTR2(NBASE2+1:NBASE2+2)='12' 12029 ISTRZ2(1:5)='12+35' 12030 NCHAR=5 12031 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12032 IF(IERROR.EQ.'YES')GOTO9000 12033C 12034 ISTR2(NBASE2+1:NBASE2+2)='13' 12035 ISTRZ2(1:5)='13+25' 12036 NCHAR=5 12037 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12038 IF(IERROR.EQ.'YES')GOTO9000 12039C 12040 ISTR2(NBASE2+1:NBASE2+2)='14' 12041 ISTRZ2(1:5)='14+56' 12042 NCHAR=5 12043 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12044 IF(IERROR.EQ.'YES')GOTO9000 12045C 12046 ISTR2(NBASE2+1:NBASE2+2)='23' 12047 ISTRZ2(1:8)='23+15+46' 12048 NCHAR=8 12049 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12050 IF(IERROR.EQ.'YES')GOTO9000 12051C 12052 ISTR2(NBASE2+1:NBASE2+2)='24' 12053 ISTRZ2(1:5)='24+36' 12054 NCHAR=5 12055 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12056 IF(IERROR.EQ.'YES')GOTO9000 12057C 12058 ISTR2(NBASE2+1:NBASE2+2)='34' 12059 ISTRZ2(1:5)='34+26' 12060 NCHAR=5 12061 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12062 IF(IERROR.EQ.'YES')GOTO9000 12063C 12064 ISTR2(NBASE2+1:NBASE2+3)='123' 12065 ISTRZ2(1:1)='5' 12066 NCHAR=1 12067 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12068 IF(IERROR.EQ.'YES')GOTO9000 12069C 12070 ISTR2(NBASE2+1:NBASE2+3)='124' 12071 ISTRZ2(1:3)='124' 12072 NCHAR=3 12073 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12074 IF(IERROR.EQ.'YES')GOTO9000 12075C 12076 ISTR2(NBASE2+1:NBASE2+3)='134' 12077 ISTRZ2(1:3)='134' 12078 NCHAR=3 12079 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12080 IF(IERROR.EQ.'YES')GOTO9000 12081C 12082 ISTR2(NBASE2+1:NBASE2+3)='234' 12083 ISTRZ2(1:1)='6' 12084 NCHAR=1 12085 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12086 IF(IERROR.EQ.'YES')GOTO9000 12087C 12088 ISTR2(NBASE2+1:NBASE2+4)='1234' 12089 ISTRZ2(1:2)='45' 12090 NCHAR=2 12091 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12092 IF(IERROR.EQ.'YES')GOTO9000 12093C 12094 ELSEIF(K.EQ.7)THEN 12095C 12096C K = 7, N = 16 (2**(7-3)) 12097C 12098C CON1 = 1 12099C CON2 = 2 12100C CON3 = 3 12101C CON4 = 4 12102C CON12 = 12 12103C CON13 = 13 12104C CON14 = 14 12105C CON23 = 23 12106C CON24 = 24 12107C CON34 = 34 12108C CON123 = 7 12109C CON124 = 124 12110C CON134 = 6 12111C CON234 = 5 12112C CON1234 = 15 12113C 12114C COP1 = 1 12115C COP2 = 2 12116C COP3 = 3 12117C COP4 = 4 12118C COP12 = 12+37+56 12119C COP13 = 13+27+46 12120C COP14 = 14+36+57 12121C COP23 = 15+26+47 12122C COP24 = 16+25+34 12123C COP34 = 17+23+45 12124C COP123 = 7 12125C COP124 = 124 12126C COP134 = 6 12127C COP234 = 5 12128C COP1234 = 15+26+47 12129C 12130C MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS 12131C 12132 IF(NBASE1.GT.4)THEN 12133 IERROR='YES' 12134 GOTO8010 12135 ELSEIF(NBASE2.GT.4)THEN 12136 IERROR='YES' 12137 GOTO8010 12138 ENDIF 12139C 12140C NOW CREATE THE STRINGS 12141C 12142 ISTR1(NBASE1+1:NBASE1+1)='1' 12143 ISTRZ1(1:1)='1' 12144 NCHAR=1 12145 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12146 IF(IERROR.EQ.'YES')GOTO9000 12147C 12148 ISTR1(NBASE1+1:NBASE1+1)='2' 12149 ISTRZ1(1:1)='2' 12150 NCHAR=1 12151 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12152 IF(IERROR.EQ.'YES')GOTO9000 12153C 12154 ISTR1(NBASE1+1:NBASE1+2)='3' 12155 ISTRZ1(1:1)='3' 12156 NCHAR=1 12157 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12158 IF(IERROR.EQ.'YES')GOTO9000 12159C 12160 ISTR1(NBASE1+1:NBASE1+2)='4' 12161 ISTRZ1(1:1)='4' 12162 NCHAR=1 12163 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12164 IF(IERROR.EQ.'YES')GOTO9000 12165C 12166 ISTR1(NBASE1+1:NBASE1+2)='12' 12167 ISTRZ1(1:2)='12' 12168 NCHAR=2 12169 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12170 IF(IERROR.EQ.'YES')GOTO9000 12171C 12172 ISTR1(NBASE1+1:NBASE1+2)='13' 12173 ISTRZ1(1:2)='13' 12174 NCHAR=2 12175 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12176 IF(IERROR.EQ.'YES')GOTO9000 12177C 12178 ISTR1(NBASE1+1:NBASE1+2)='14' 12179 ISTRZ1(1:2)='14' 12180 NCHAR=2 12181 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12182 IF(IERROR.EQ.'YES')GOTO9000 12183C 12184 ISTR1(NBASE1+1:NBASE1+2)='23' 12185 ISTRZ1(1:2)='23' 12186 NCHAR=2 12187 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12188 IF(IERROR.EQ.'YES')GOTO9000 12189C 12190 ISTR1(NBASE1+1:NBASE1+2)='24' 12191 ISTRZ1(1:2)='24' 12192 NCHAR=2 12193 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12194 IF(IERROR.EQ.'YES')GOTO9000 12195C 12196 ISTR1(NBASE1+1:NBASE1+2)='34' 12197 ISTRZ1(1:2)='34' 12198 NCHAR=2 12199 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12200 IF(IERROR.EQ.'YES')GOTO9000 12201C 12202 ISTR1(NBASE1+1:NBASE1+3)='123' 12203 ISTRZ1(1:1)='7' 12204 NCHAR=1 12205 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12206 IF(IERROR.EQ.'YES')GOTO9000 12207C 12208 ISTR1(NBASE1+1:NBASE1+3)='124' 12209 ISTRZ1(1:3)='124' 12210 NCHAR=3 12211 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12212 IF(IERROR.EQ.'YES')GOTO9000 12213C 12214 ISTR1(NBASE1+1:NBASE1+3)='134' 12215 ISTRZ1(1:1)='6' 12216 NCHAR=1 12217 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12218 IF(IERROR.EQ.'YES')GOTO9000 12219C 12220 ISTR1(NBASE1+1:NBASE1+3)='234' 12221 ISTRZ1(1:1)='5' 12222 NCHAR=1 12223 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12224 IF(IERROR.EQ.'YES')GOTO9000 12225C 12226 ISTR1(NBASE1+1:NBASE1+4)='1234' 12227 ISTRZ1(1:2)='15' 12228 NCHAR=2 12229 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12230 IF(IERROR.EQ.'YES')GOTO9000 12231C 12232 ISTR2(NBASE2+1:NBASE2+1)='1' 12233 ISTRZ2(1:1)='1' 12234 NCHAR=1 12235 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12236 IF(IERROR.EQ.'YES')GOTO9000 12237C 12238 ISTR2(NBASE2+1:NBASE2+1)='2' 12239 ISTRZ2(1:1)='2' 12240 NCHAR=1 12241 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12242 IF(IERROR.EQ.'YES')GOTO9000 12243C 12244 ISTR2(NBASE2+1:NBASE2+1)='3' 12245 ISTRZ2(1:1)='3' 12246 NCHAR=1 12247 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12248 IF(IERROR.EQ.'YES')GOTO9000 12249C 12250 ISTR2(NBASE2+1:NBASE2+1)='4' 12251 ISTRZ2(1:1)='4' 12252 NCHAR=1 12253 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12254 IF(IERROR.EQ.'YES')GOTO9000 12255C 12256 ISTR2(NBASE2+1:NBASE2+2)='12' 12257 ISTRZ2(1:8)='12+37+56' 12258 NCHAR=8 12259 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12260 IF(IERROR.EQ.'YES')GOTO9000 12261C 12262 ISTR2(NBASE2+1:NBASE2+2)='13' 12263 ISTRZ2(1:8)='13+27+46' 12264 NCHAR=8 12265 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12266 IF(IERROR.EQ.'YES')GOTO9000 12267C 12268 ISTR2(NBASE2+1:NBASE2+2)='14' 12269 ISTRZ2(1:8)='14+36+57' 12270 NCHAR=8 12271 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12272 IF(IERROR.EQ.'YES')GOTO9000 12273C 12274 ISTR2(NBASE2+1:NBASE2+2)='23' 12275 ISTRZ2(1:8)='15+26+47' 12276 NCHAR=8 12277 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12278 IF(IERROR.EQ.'YES')GOTO9000 12279C 12280 ISTR2(NBASE2+1:NBASE2+2)='24' 12281 ISTRZ2(1:8)='16+25+34' 12282 NCHAR=8 12283 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12284 IF(IERROR.EQ.'YES')GOTO9000 12285C 12286 ISTR2(NBASE2+1:NBASE2+2)='34' 12287 ISTRZ2(1:8)='17+23+45' 12288 NCHAR=8 12289 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12290 IF(IERROR.EQ.'YES')GOTO9000 12291C 12292 ISTR2(NBASE2+1:NBASE2+3)='123' 12293 ISTRZ2(1:1)='7' 12294 NCHAR=1 12295 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12296 IF(IERROR.EQ.'YES')GOTO9000 12297C 12298 ISTR2(NBASE2+1:NBASE2+3)='124' 12299 ISTRZ2(1:3)='124' 12300 NCHAR=3 12301 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12302 IF(IERROR.EQ.'YES')GOTO9000 12303C 12304 ISTR2(NBASE2+1:NBASE2+3)='134' 12305 ISTRZ2(1:1)='6' 12306 NCHAR=1 12307 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12308 IF(IERROR.EQ.'YES')GOTO9000 12309C 12310 ISTR2(NBASE2+1:NBASE2+3)='234' 12311 ISTRZ2(1:1)='5' 12312 NCHAR=1 12313 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12314 IF(IERROR.EQ.'YES')GOTO9000 12315C 12316 ISTR2(NBASE2+1:NBASE2+4)='1234' 12317 ISTRZ2(1:8)='15+26+47' 12318 NCHAR=8 12319 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12320 IF(IERROR.EQ.'YES')GOTO9000 12321C 12322 ELSEIF(K.EQ.8)THEN 12323C 12324C K = 8, N = 16 (2**(8-4)) 12325C 12326C CON1 = 1 12327C CON2 = 2 12328C CON3 = 3 12329C CON4 = 4 12330C CON12 = 12 12331C CON13 = 13 12332C CON14 = 14 12333C CON23 = 23 12334C CON24 = 24 12335C CON34 = 34 12336C CON123 = 7 12337C CON124 = 8 12338C CON134 = 6 12339C CON234 = 5 12340C CON1234 = 15 12341C 12342C COP1 = 1 12343C COP2 = 2 12344C COP3 = 3 12345C COP4 = 4 12346C COP12 = 12+37+48+56 12347C COP13 = 13+27+46+58 12348C COP14 = 14+28+36+57 12349C COP23 = 23+17+45+68 12350C COP24 = 24+18+35+67 12351C COP34 = 34+16+25+78 12352C COP123 = 7 12353C COP124 = 8 12354C COP134 = 6 12355C COP234 = 5 12356C COP1234 = 15+26+38+47 12357C 12358C MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS 12359C 12360 IF(NBASE1.GT.4)THEN 12361 IERROR='YES' 12362 GOTO8010 12363 ELSEIF(NBASE2.GT.4)THEN 12364 IERROR='YES' 12365 GOTO8010 12366 ENDIF 12367C 12368C NOW CREATE THE STRINGS 12369C 12370 ISTR1(NBASE1+1:NBASE1+1)='1' 12371 ISTRZ1(1:1)='1' 12372 NCHAR=1 12373 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12374 IF(IERROR.EQ.'YES')GOTO9000 12375C 12376 ISTR1(NBASE1+1:NBASE1+1)='2' 12377 ISTRZ1(1:1)='2' 12378 NCHAR=1 12379 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12380 IF(IERROR.EQ.'YES')GOTO9000 12381C 12382 ISTR1(NBASE1+1:NBASE1+2)='3' 12383 ISTRZ1(1:1)='3' 12384 NCHAR=1 12385 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12386 IF(IERROR.EQ.'YES')GOTO9000 12387C 12388 ISTR1(NBASE1+1:NBASE1+2)='4' 12389 ISTRZ1(1:1)='4' 12390 NCHAR=1 12391 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12392 IF(IERROR.EQ.'YES')GOTO9000 12393C 12394 ISTR1(NBASE1+1:NBASE1+2)='12' 12395 ISTRZ1(1:2)='12' 12396 NCHAR=2 12397 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12398 IF(IERROR.EQ.'YES')GOTO9000 12399C 12400 ISTR1(NBASE1+1:NBASE1+2)='13' 12401 ISTRZ1(1:2)='13' 12402 NCHAR=2 12403 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12404 IF(IERROR.EQ.'YES')GOTO9000 12405C 12406 ISTR1(NBASE1+1:NBASE1+2)='14' 12407 ISTRZ1(1:2)='14' 12408 NCHAR=2 12409 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12410 IF(IERROR.EQ.'YES')GOTO9000 12411C 12412 ISTR1(NBASE1+1:NBASE1+2)='23' 12413 ISTRZ1(1:2)='23' 12414 NCHAR=2 12415 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12416 IF(IERROR.EQ.'YES')GOTO9000 12417C 12418 ISTR1(NBASE1+1:NBASE1+2)='24' 12419 ISTRZ1(1:2)='24' 12420 NCHAR=2 12421 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12422 IF(IERROR.EQ.'YES')GOTO9000 12423C 12424 ISTR1(NBASE1+1:NBASE1+2)='34' 12425 ISTRZ1(1:2)='34' 12426 NCHAR=2 12427 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12428 IF(IERROR.EQ.'YES')GOTO9000 12429C 12430 ISTR1(NBASE1+1:NBASE1+3)='123' 12431 ISTRZ1(1:1)='7' 12432 NCHAR=1 12433 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12434 IF(IERROR.EQ.'YES')GOTO9000 12435C 12436 ISTR1(NBASE1+1:NBASE1+3)='124' 12437 ISTRZ1(1:1)='8' 12438 NCHAR=1 12439 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12440 IF(IERROR.EQ.'YES')GOTO9000 12441C 12442 ISTR1(NBASE1+1:NBASE1+3)='134' 12443 ISTRZ1(1:1)='6' 12444 NCHAR=1 12445 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12446 IF(IERROR.EQ.'YES')GOTO9000 12447C 12448 ISTR1(NBASE1+1:NBASE1+3)='234' 12449 ISTRZ1(1:1)='5' 12450 NCHAR=1 12451 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12452 IF(IERROR.EQ.'YES')GOTO9000 12453C 12454 ISTR1(NBASE1+1:NBASE1+4)='1234' 12455 ISTRZ1(1:2)='15' 12456 NCHAR=2 12457 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12458 IF(IERROR.EQ.'YES')GOTO9000 12459C 12460 ISTR2(NBASE2+1:NBASE2+1)='1' 12461 ISTRZ2(1:1)='1' 12462 NCHAR=1 12463 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12464 IF(IERROR.EQ.'YES')GOTO9000 12465C 12466 ISTR2(NBASE2+1:NBASE2+1)='2' 12467 ISTRZ2(1:1)='2' 12468 NCHAR=1 12469 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12470 IF(IERROR.EQ.'YES')GOTO9000 12471C 12472 ISTR2(NBASE2+1:NBASE2+1)='3' 12473 ISTRZ2(1:1)='3' 12474 NCHAR=1 12475 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12476 IF(IERROR.EQ.'YES')GOTO9000 12477C 12478 ISTR2(NBASE2+1:NBASE2+1)='4' 12479 ISTRZ2(1:1)='4' 12480 NCHAR=1 12481 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12482 IF(IERROR.EQ.'YES')GOTO9000 12483C 12484 ISTR2(NBASE2+1:NBASE2+2)='12' 12485 ISTRZ2(1:11)='12+37+48+56' 12486 NCHAR=11 12487 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12488 IF(IERROR.EQ.'YES')GOTO9000 12489C 12490 ISTR2(NBASE2+1:NBASE2+2)='13' 12491 ISTRZ2(1:11)='13+27+46+58' 12492 NCHAR=11 12493 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12494 IF(IERROR.EQ.'YES')GOTO9000 12495C 12496 ISTR2(NBASE2+1:NBASE2+2)='14' 12497 ISTRZ2(1:11)='14+28+36+57' 12498 NCHAR=11 12499 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12500 IF(IERROR.EQ.'YES')GOTO9000 12501C 12502 ISTR2(NBASE2+1:NBASE2+2)='23' 12503 ISTRZ2(1:11)='23+17+45+68' 12504 NCHAR=11 12505 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12506 IF(IERROR.EQ.'YES')GOTO9000 12507C 12508 ISTR2(NBASE2+1:NBASE2+2)='24' 12509 ISTRZ2(1:11)='24+18+35+67' 12510 NCHAR=11 12511 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12512 IF(IERROR.EQ.'YES')GOTO9000 12513C 12514 ISTR2(NBASE2+1:NBASE2+2)='34' 12515 ISTRZ2(1:11)='34+16+25+78' 12516 NCHAR=11 12517 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12518 IF(IERROR.EQ.'YES')GOTO9000 12519C 12520 ISTR2(NBASE2+1:NBASE2+3)='123' 12521 ISTRZ2(1:1)='7' 12522 NCHAR=1 12523 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12524 IF(IERROR.EQ.'YES')GOTO9000 12525C 12526 ISTR2(NBASE2+1:NBASE2+3)='124' 12527 ISTRZ2(1:1)='8' 12528 NCHAR=1 12529 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12530 IF(IERROR.EQ.'YES')GOTO9000 12531C 12532 ISTR2(NBASE2+1:NBASE2+3)='134' 12533 ISTRZ2(1:1)='6' 12534 NCHAR=1 12535 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12536 IF(IERROR.EQ.'YES')GOTO9000 12537C 12538 ISTR2(NBASE2+1:NBASE2+3)='234' 12539 ISTRZ2(1:1)='5' 12540 NCHAR=1 12541 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12542 IF(IERROR.EQ.'YES')GOTO9000 12543C 12544 ISTR2(NBASE2+1:NBASE2+4)='1234' 12545 ISTRZ2(1:11)='15+26+38+47' 12546 NCHAR=11 12547 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12548 IF(IERROR.EQ.'YES')GOTO9000 12549C 12550 ELSE 12551 IERROR='YES' 12552 GOTO8030 12553 ENDIF 12554 ELSEIF(NTEMP.EQ.32)THEN 12555 IF(K.EQ.5)THEN 12556C 12557C K = 5, N = 32 (2**5) 12558C 12559C CON1 = 1 12560C CON2 = 2 12561C CON3 = 3 12562C CON4 = 4 12563C CON5 = 5 12564C CON12 = 12 12565C CON13 = 13 12566C CON14 = 14 12567C CON15 = 15 12568C CON23 = 23 12569C CON24 = 24 12570C CON25 = 25 12571C CON34 = 34 12572C CON35 = 35 12573C CON45 = 45 12574C CON123 = 123 12575C CON124 = 124 12576C CON125 = 125 12577C CON134 = 134 12578C CON135 = 135 12579C CON145 = 145 12580C CON234 = 234 12581C CON235 = 235 12582C CON245 = 245 12583C CON345 = 345 12584C CON1234 = 1234 12585C CON1235 = 1235 12586C CON1245 = 1245 12587C CON1345 = 1345 12588C CON2345 = 2345 12589C CON12345 = 12345 12590C 12591C COP1 = 1 12592C COP2 = 2 12593C COP3 = 3 12594C COP4 = 4 12595C COP5 = 5 12596C COP12 = 12 12597C COP13 = 13 12598C COP14 = 14 12599C COP15 = 15 12600C COP23 = 23 12601C COP24 = 24 12602C COP25 = 25 12603C COP34 = 34 12604C COP35 = 35 12605C COP45 = 45 12606C COP123 = 123 12607C COP124 = 124 12608C COP125 = 125 12609C COP134 = 134 12610C COP135 = 135 12611C COP145 = 145 12612C COP234 = 234 12613C COP235 = 235 12614C COP245 = 245 12615C COP345 = 345 12616C COP1234 = 1234 12617C COP1235 = 1235 12618C COP1245 = 1245 12619C COP1345 = 1345 12620C COP2345 = 2345 12621C COP12345 = 12345 12622C 12623C MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS 12624C 12625 IF(NBASE1.GT.3)THEN 12626 IERROR='YES' 12627 GOTO8010 12628 ELSEIF(NBASE2.GT.3)THEN 12629 IERROR='YES' 12630 GOTO8010 12631 ENDIF 12632C 12633C NOW CREATE THE STRINGS 12634C 12635 ISTR1(NBASE1+1:NBASE1+1)='1' 12636 ISTRZ1(1:1)='1' 12637 NCHAR=1 12638 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12639 IF(IERROR.EQ.'YES')GOTO9000 12640C 12641 ISTR1(NBASE1+1:NBASE1+1)='2' 12642 ISTRZ1(1:1)='2' 12643 NCHAR=1 12644 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12645 IF(IERROR.EQ.'YES')GOTO9000 12646C 12647 ISTR1(NBASE1+1:NBASE1+2)='3' 12648 ISTRZ1(1:1)='3' 12649 NCHAR=1 12650 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12651 IF(IERROR.EQ.'YES')GOTO9000 12652C 12653 ISTR1(NBASE1+1:NBASE1+2)='4' 12654 ISTRZ1(1:1)='4' 12655 NCHAR=1 12656 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12657 IF(IERROR.EQ.'YES')GOTO9000 12658C 12659 ISTR1(NBASE1+1:NBASE1+2)='5' 12660 ISTRZ1(1:1)='5' 12661 NCHAR=1 12662 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12663 IF(IERROR.EQ.'YES')GOTO9000 12664C 12665 ISTR1(NBASE1+1:NBASE1+2)='12' 12666 ISTRZ1(1:2)='12' 12667 NCHAR=2 12668 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12669 IF(IERROR.EQ.'YES')GOTO9000 12670C 12671 ISTR1(NBASE1+1:NBASE1+2)='13' 12672 ISTRZ1(1:2)='13' 12673 NCHAR=2 12674 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12675 IF(IERROR.EQ.'YES')GOTO9000 12676C 12677 ISTR1(NBASE1+1:NBASE1+2)='14' 12678 ISTRZ1(1:2)='14' 12679 NCHAR=2 12680 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12681 IF(IERROR.EQ.'YES')GOTO9000 12682C 12683 ISTR1(NBASE1+1:NBASE1+2)='15' 12684 ISTRZ1(1:2)='15' 12685 NCHAR=2 12686 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12687 IF(IERROR.EQ.'YES')GOTO9000 12688C 12689 ISTR1(NBASE1+1:NBASE1+2)='23' 12690 ISTRZ1(1:2)='23' 12691 NCHAR=2 12692 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12693 IF(IERROR.EQ.'YES')GOTO9000 12694C 12695 ISTR1(NBASE1+1:NBASE1+2)='24' 12696 ISTRZ1(1:2)='24' 12697 NCHAR=2 12698 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12699 IF(IERROR.EQ.'YES')GOTO9000 12700C 12701 ISTR1(NBASE1+1:NBASE1+2)='25' 12702 ISTRZ1(1:2)='25' 12703 NCHAR=2 12704 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12705 IF(IERROR.EQ.'YES')GOTO9000 12706C 12707 ISTR1(NBASE1+1:NBASE1+2)='34' 12708 ISTRZ1(1:2)='34' 12709 NCHAR=2 12710 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12711 IF(IERROR.EQ.'YES')GOTO9000 12712C 12713 ISTR1(NBASE1+1:NBASE1+2)='35' 12714 ISTRZ1(1:2)='35' 12715 NCHAR=2 12716 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12717 IF(IERROR.EQ.'YES')GOTO9000 12718C 12719 ISTR1(NBASE1+1:NBASE1+2)='45' 12720 ISTRZ1(1:2)='45' 12721 NCHAR=2 12722 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12723 IF(IERROR.EQ.'YES')GOTO9000 12724C 12725 ISTR1(NBASE1+1:NBASE1+3)='123' 12726 ISTRZ1(1:3)='123' 12727 NCHAR=3 12728 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12729 IF(IERROR.EQ.'YES')GOTO9000 12730C 12731 ISTR1(NBASE1+1:NBASE1+3)='124' 12732 ISTRZ1(1:3)='124' 12733 NCHAR=3 12734 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12735 IF(IERROR.EQ.'YES')GOTO9000 12736C 12737 ISTR1(NBASE1+1:NBASE1+3)='125' 12738 ISTRZ1(1:3)='125' 12739 NCHAR=3 12740 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12741 IF(IERROR.EQ.'YES')GOTO9000 12742C 12743 ISTR1(NBASE1+1:NBASE1+3)='134' 12744 ISTRZ1(1:3)='134' 12745 NCHAR=3 12746 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12747 IF(IERROR.EQ.'YES')GOTO9000 12748C 12749 ISTR1(NBASE1+1:NBASE1+3)='135' 12750 ISTRZ1(1:3)='135' 12751 NCHAR=3 12752 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12753 IF(IERROR.EQ.'YES')GOTO9000 12754C 12755 ISTR1(NBASE1+1:NBASE1+3)='145' 12756 ISTRZ1(1:3)='145' 12757 NCHAR=3 12758 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12759 IF(IERROR.EQ.'YES')GOTO9000 12760C 12761 ISTR1(NBASE1+1:NBASE1+3)='234' 12762 ISTRZ1(1:3)='234' 12763 NCHAR=3 12764 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12765 IF(IERROR.EQ.'YES')GOTO9000 12766C 12767 ISTR1(NBASE1+1:NBASE1+3)='235' 12768 ISTRZ1(1:3)='235' 12769 NCHAR=3 12770 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12771 IF(IERROR.EQ.'YES')GOTO9000 12772C 12773 ISTR1(NBASE1+1:NBASE1+3)='245' 12774 ISTRZ1(1:3)='245' 12775 NCHAR=3 12776 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12777 IF(IERROR.EQ.'YES')GOTO9000 12778C 12779 ISTR1(NBASE1+1:NBASE1+3)='345' 12780 ISTRZ1(1:3)='345' 12781 NCHAR=3 12782 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12783 IF(IERROR.EQ.'YES')GOTO9000 12784C 12785 ISTR1(NBASE1+1:NBASE1+4)='1234' 12786 ISTRZ1(1:4)='1234' 12787 NCHAR=4 12788 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12789 IF(IERROR.EQ.'YES')GOTO9000 12790C 12791 ISTR1(NBASE1+1:NBASE1+4)='1235' 12792 ISTRZ1(1:4)='1235' 12793 NCHAR=4 12794 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12795 IF(IERROR.EQ.'YES')GOTO9000 12796C 12797 ISTR1(NBASE1+1:NBASE1+4)='1245' 12798 ISTRZ1(1:4)='1245' 12799 NCHAR=4 12800 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12801 IF(IERROR.EQ.'YES')GOTO9000 12802C 12803 ISTR1(NBASE1+1:NBASE1+4)='1345' 12804 ISTRZ1(1:4)='1345' 12805 NCHAR=4 12806 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12807 IF(IERROR.EQ.'YES')GOTO9000 12808C 12809 ISTR1(NBASE1+1:NBASE1+4)='2345' 12810 ISTRZ1(1:4)='2345' 12811 NCHAR=4 12812 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12813 IF(IERROR.EQ.'YES')GOTO9000 12814C 12815 ISTR1(NBASE1+1:NBASE1+5)='12345' 12816 ISTRZ1(1:5)='12345' 12817 NCHAR=5 12818 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 12819 IF(IERROR.EQ.'YES')GOTO9000 12820C 12821 ISTR2(NBASE2+1:NBASE2+1)='1' 12822 ISTRZ2(1:1)='1' 12823 NCHAR=1 12824 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12825 IF(IERROR.EQ.'YES')GOTO9000 12826C 12827 ISTR2(NBASE2+1:NBASE2+1)='2' 12828 ISTRZ2(1:1)='2' 12829 NCHAR=1 12830 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12831 IF(IERROR.EQ.'YES')GOTO9000 12832C 12833 ISTR2(NBASE2+1:NBASE2+2)='3' 12834 ISTRZ2(1:1)='3' 12835 NCHAR=1 12836 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12837 IF(IERROR.EQ.'YES')GOTO9000 12838C 12839 ISTR2(NBASE2+1:NBASE2+2)='4' 12840 ISTRZ2(1:1)='4' 12841 NCHAR=1 12842 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12843 IF(IERROR.EQ.'YES')GOTO9000 12844C 12845 ISTR2(NBASE2+1:NBASE2+2)='5' 12846 ISTRZ2(1:1)='5' 12847 NCHAR=1 12848 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12849 IF(IERROR.EQ.'YES')GOTO9000 12850C 12851 ISTR2(NBASE2+1:NBASE2+2)='12' 12852 ISTRZ2(1:2)='12' 12853 NCHAR=2 12854 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12855 IF(IERROR.EQ.'YES')GOTO9000 12856C 12857 ISTR2(NBASE2+1:NBASE2+2)='13' 12858 ISTRZ2(1:2)='13' 12859 NCHAR=2 12860 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12861 IF(IERROR.EQ.'YES')GOTO9000 12862C 12863 ISTR2(NBASE2+1:NBASE2+2)='14' 12864 ISTRZ2(1:2)='14' 12865 NCHAR=2 12866 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12867 IF(IERROR.EQ.'YES')GOTO9000 12868C 12869 ISTR2(NBASE2+1:NBASE2+2)='15' 12870 ISTRZ2(1:2)='15' 12871 NCHAR=2 12872 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12873 IF(IERROR.EQ.'YES')GOTO9000 12874C 12875 ISTR2(NBASE2+1:NBASE2+2)='23' 12876 ISTRZ2(1:2)='23' 12877 NCHAR=2 12878 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12879 IF(IERROR.EQ.'YES')GOTO9000 12880C 12881 ISTR2(NBASE2+1:NBASE2+2)='24' 12882 ISTRZ2(1:2)='24' 12883 NCHAR=2 12884 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12885 IF(IERROR.EQ.'YES')GOTO9000 12886C 12887 ISTR2(NBASE2+1:NBASE2+2)='25' 12888 ISTRZ2(1:2)='25' 12889 NCHAR=2 12890 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12891 IF(IERROR.EQ.'YES')GOTO9000 12892C 12893 ISTR2(NBASE2+1:NBASE2+2)='34' 12894 ISTRZ2(1:2)='34' 12895 NCHAR=2 12896 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12897 IF(IERROR.EQ.'YES')GOTO9000 12898C 12899 ISTR2(NBASE2+1:NBASE2+2)='35' 12900 ISTRZ2(1:2)='35' 12901 NCHAR=2 12902 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12903 IF(IERROR.EQ.'YES')GOTO9000 12904C 12905 ISTR2(NBASE2+1:NBASE2+2)='45' 12906 ISTRZ2(1:2)='45' 12907 NCHAR=2 12908 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12909 IF(IERROR.EQ.'YES')GOTO9000 12910C 12911 ISTR2(NBASE2+1:NBASE2+3)='123' 12912 ISTRZ2(1:3)='123' 12913 NCHAR=3 12914 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12915 IF(IERROR.EQ.'YES')GOTO9000 12916C 12917 ISTR2(NBASE2+1:NBASE2+3)='124' 12918 ISTRZ2(1:3)='124' 12919 NCHAR=3 12920 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12921 IF(IERROR.EQ.'YES')GOTO9000 12922C 12923 ISTR2(NBASE2+1:NBASE2+3)='125' 12924 ISTRZ2(1:3)='125' 12925 NCHAR=3 12926 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12927 IF(IERROR.EQ.'YES')GOTO9000 12928C 12929 ISTR2(NBASE2+1:NBASE2+3)='134' 12930 ISTRZ2(1:3)='134' 12931 NCHAR=3 12932 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12933 IF(IERROR.EQ.'YES')GOTO9000 12934C 12935 ISTR2(NBASE2+1:NBASE2+3)='135' 12936 ISTRZ2(1:3)='135' 12937 NCHAR=3 12938 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12939 IF(IERROR.EQ.'YES')GOTO9000 12940C 12941 ISTR2(NBASE2+1:NBASE2+3)='145' 12942 ISTRZ2(1:3)='145' 12943 NCHAR=3 12944 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12945 IF(IERROR.EQ.'YES')GOTO9000 12946C 12947 ISTR2(NBASE2+1:NBASE2+3)='234' 12948 ISTRZ2(1:3)='234' 12949 NCHAR=3 12950 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12951 IF(IERROR.EQ.'YES')GOTO9000 12952C 12953 ISTR2(NBASE2+1:NBASE2+3)='235' 12954 ISTRZ2(1:3)='235' 12955 NCHAR=3 12956 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12957 IF(IERROR.EQ.'YES')GOTO9000 12958C 12959 ISTR2(NBASE2+1:NBASE2+3)='245' 12960 ISTRZ2(1:3)='245' 12961 NCHAR=3 12962 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12963 IF(IERROR.EQ.'YES')GOTO9000 12964C 12965 ISTR2(NBASE2+1:NBASE2+3)='345' 12966 ISTRZ2(1:3)='345' 12967 NCHAR=3 12968 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12969 IF(IERROR.EQ.'YES')GOTO9000 12970C 12971 ISTR2(NBASE2+1:NBASE2+4)='1234' 12972 ISTRZ2(1:4)='1234' 12973 NCHAR=4 12974 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12975 IF(IERROR.EQ.'YES')GOTO9000 12976C 12977 ISTR2(NBASE2+1:NBASE2+4)='1235' 12978 ISTRZ2(1:4)='1235' 12979 NCHAR=4 12980 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12981 IF(IERROR.EQ.'YES')GOTO9000 12982C 12983 ISTR2(NBASE2+1:NBASE2+4)='1245' 12984 ISTRZ2(1:4)='1245' 12985 NCHAR=4 12986 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12987 IF(IERROR.EQ.'YES')GOTO9000 12988C 12989 ISTR2(NBASE2+1:NBASE2+4)='1345' 12990 ISTRZ2(1:4)='1345' 12991 NCHAR=4 12992 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12993 IF(IERROR.EQ.'YES')GOTO9000 12994C 12995 ISTR2(NBASE2+1:NBASE2+4)='2345' 12996 ISTRZ2(1:4)='2345' 12997 NCHAR=4 12998 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 12999 IF(IERROR.EQ.'YES')GOTO9000 13000C 13001 ISTR2(NBASE2+1:NBASE2+5)='12345' 13002 ISTRZ2(1:5)='12345' 13003 NCHAR=5 13004 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13005 IF(IERROR.EQ.'YES')GOTO9000 13006C 13007 ELSEIF(K.EQ.6)THEN 13008C 13009C K = 6, N = 32 (2**(6-1)) 13010C 13011C CON1 = 1 13012C CON2 = 2 13013C CON3 = 3 13014C CON4 = 4 13015C CON5 = 5 13016C CON12 = 12 13017C CON13 = 13 13018C CON14 = 14 13019C CON15 = 15 13020C CON23 = 23 13021C CON24 = 24 13022C CON25 = 25 13023C CON34 = 34 13024C CON35 = 35 13025C CON45 = 45 13026C CON123 = 123 13027C CON124 = 124 13028C CON125 = 125 13029C CON134 = 134 13030C CON135 = 135 13031C CON145 = 145 13032C CON234 = 234 13033C CON235 = 235 13034C CON245 = 245 13035C CON345 = 345 13036C CON1234 = 56 13037C CON1235 = 46 13038C CON1245 = 36 13039C CON1345 = 26 13040C CON2345 = 16 13041C CON12345 = 6 13042C 13043C COP1 = 1 13044C COP2 = 2 13045C COP3 = 3 13046C COP4 = 4 13047C COP5 = 5 13048C COP12 = 12 13049C COP13 = 13 13050C COP14 = 14 13051C COP15 = 15 13052C COP23 = 23 13053C COP24 = 24 13054C COP25 = 25 13055C COP34 = 34 13056C COP35 = 35 13057C COP45 = 45 13058C COP123 = 123 13059C COP124 = 124 13060C COP125 = 125 13061C COP134 = 134 13062C COP135 = 135 13063C COP145 = 145 13064C COP234 = 234 13065C COP235 = 235 13066C COP245 = 245 13067C COP345 = 345 13068C COP1234 = 56 13069C COP1235 = 46 13070C COP1245 = 36 13071C COP1345 = 26 13072C COP2345 = 16 13073C COP12345 = 6 13074C 13075C MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS 13076C 13077 IF(NBASE1.GT.3)THEN 13078 IERROR='YES' 13079 GOTO8010 13080 ELSEIF(NBASE2.GT.3)THEN 13081 IERROR='YES' 13082 GOTO8010 13083 ENDIF 13084C 13085C NOW CREATE THE STRINGS 13086C 13087 ISTR1(NBASE1+1:NBASE1+1)='1' 13088 ISTRZ1(1:1)='1' 13089 NCHAR=1 13090 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13091 IF(IERROR.EQ.'YES')GOTO9000 13092C 13093 ISTR1(NBASE1+1:NBASE1+1)='2' 13094 ISTRZ1(1:1)='2' 13095 NCHAR=1 13096 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13097 IF(IERROR.EQ.'YES')GOTO9000 13098C 13099 ISTR1(NBASE1+1:NBASE1+2)='3' 13100 ISTRZ1(1:1)='3' 13101 NCHAR=1 13102 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13103 IF(IERROR.EQ.'YES')GOTO9000 13104C 13105 ISTR1(NBASE1+1:NBASE1+2)='4' 13106 ISTRZ1(1:1)='4' 13107 NCHAR=1 13108 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13109 IF(IERROR.EQ.'YES')GOTO9000 13110C 13111 ISTR1(NBASE1+1:NBASE1+2)='5' 13112 ISTRZ1(1:1)='5' 13113 NCHAR=1 13114 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13115 IF(IERROR.EQ.'YES')GOTO9000 13116C 13117 ISTR1(NBASE1+1:NBASE1+2)='12' 13118 ISTRZ1(1:2)='12' 13119 NCHAR=2 13120 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13121 IF(IERROR.EQ.'YES')GOTO9000 13122C 13123 ISTR1(NBASE1+1:NBASE1+2)='13' 13124 ISTRZ1(1:2)='13' 13125 NCHAR=2 13126 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13127 IF(IERROR.EQ.'YES')GOTO9000 13128C 13129 ISTR1(NBASE1+1:NBASE1+2)='14' 13130 ISTRZ1(1:2)='14' 13131 NCHAR=2 13132 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13133 IF(IERROR.EQ.'YES')GOTO9000 13134C 13135 ISTR1(NBASE1+1:NBASE1+2)='15' 13136 ISTRZ1(1:2)='15' 13137 NCHAR=2 13138 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13139 IF(IERROR.EQ.'YES')GOTO9000 13140C 13141 ISTR1(NBASE1+1:NBASE1+2)='23' 13142 ISTRZ1(1:2)='23' 13143 NCHAR=2 13144 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13145 IF(IERROR.EQ.'YES')GOTO9000 13146C 13147 ISTR1(NBASE1+1:NBASE1+2)='24' 13148 ISTRZ1(1:2)='24' 13149 NCHAR=2 13150 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13151 IF(IERROR.EQ.'YES')GOTO9000 13152C 13153 ISTR1(NBASE1+1:NBASE1+2)='25' 13154 ISTRZ1(1:2)='25' 13155 NCHAR=2 13156 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13157 IF(IERROR.EQ.'YES')GOTO9000 13158C 13159 ISTR1(NBASE1+1:NBASE1+2)='34' 13160 ISTRZ1(1:2)='34' 13161 NCHAR=2 13162 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13163 IF(IERROR.EQ.'YES')GOTO9000 13164C 13165 ISTR1(NBASE1+1:NBASE1+2)='35' 13166 ISTRZ1(1:2)='35' 13167 NCHAR=2 13168 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13169 IF(IERROR.EQ.'YES')GOTO9000 13170C 13171 ISTR1(NBASE1+1:NBASE1+2)='45' 13172 ISTRZ1(1:2)='45' 13173 NCHAR=2 13174 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13175 IF(IERROR.EQ.'YES')GOTO9000 13176C 13177 ISTR1(NBASE1+1:NBASE1+3)='123' 13178 ISTRZ1(1:3)='123' 13179 NCHAR=3 13180 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13181 IF(IERROR.EQ.'YES')GOTO9000 13182C 13183 ISTR1(NBASE1+1:NBASE1+3)='124' 13184 ISTRZ1(1:3)='124' 13185 NCHAR=3 13186 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13187 IF(IERROR.EQ.'YES')GOTO9000 13188C 13189 ISTR1(NBASE1+1:NBASE1+3)='125' 13190 ISTRZ1(1:3)='125' 13191 NCHAR=3 13192 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13193 IF(IERROR.EQ.'YES')GOTO9000 13194C 13195 ISTR1(NBASE1+1:NBASE1+3)='134' 13196 ISTRZ1(1:3)='134' 13197 NCHAR=3 13198 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13199 IF(IERROR.EQ.'YES')GOTO9000 13200C 13201 ISTR1(NBASE1+1:NBASE1+3)='135' 13202 ISTRZ1(1:3)='135' 13203 NCHAR=3 13204 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13205 IF(IERROR.EQ.'YES')GOTO9000 13206C 13207 ISTR1(NBASE1+1:NBASE1+3)='145' 13208 ISTRZ1(1:3)='145' 13209 NCHAR=3 13210 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13211 IF(IERROR.EQ.'YES')GOTO9000 13212C 13213 ISTR1(NBASE1+1:NBASE1+3)='234' 13214 ISTRZ1(1:3)='234' 13215 NCHAR=3 13216 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13217 IF(IERROR.EQ.'YES')GOTO9000 13218C 13219 ISTR1(NBASE1+1:NBASE1+3)='235' 13220 ISTRZ1(1:3)='235' 13221 NCHAR=3 13222 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13223 IF(IERROR.EQ.'YES')GOTO9000 13224C 13225 ISTR1(NBASE1+1:NBASE1+3)='245' 13226 ISTRZ1(1:3)='245' 13227 NCHAR=3 13228 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13229 IF(IERROR.EQ.'YES')GOTO9000 13230C 13231 ISTR1(NBASE1+1:NBASE1+3)='345' 13232 ISTRZ1(1:3)='345' 13233 NCHAR=3 13234 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13235 IF(IERROR.EQ.'YES')GOTO9000 13236C 13237 ISTR1(NBASE1+1:NBASE1+4)='1234' 13238 ISTRZ1(1:2)='56' 13239 NCHAR=2 13240 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13241 IF(IERROR.EQ.'YES')GOTO9000 13242C 13243 ISTR1(NBASE1+1:NBASE1+4)='1235' 13244 ISTRZ1(1:2)='46' 13245 NCHAR=2 13246 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13247 IF(IERROR.EQ.'YES')GOTO9000 13248C 13249 ISTR1(NBASE1+1:NBASE1+4)='1245' 13250 ISTRZ1(1:2)='36' 13251 NCHAR=2 13252 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13253 IF(IERROR.EQ.'YES')GOTO9000 13254C 13255 ISTR1(NBASE1+1:NBASE1+4)='1345' 13256 ISTRZ1(1:2)='26' 13257 NCHAR=2 13258 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13259 IF(IERROR.EQ.'YES')GOTO9000 13260C 13261 ISTR1(NBASE1+1:NBASE1+4)='2345' 13262 ISTRZ1(1:2)='16' 13263 NCHAR=2 13264 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13265 IF(IERROR.EQ.'YES')GOTO9000 13266C 13267 ISTR1(NBASE1+1:NBASE1+5)='12345' 13268 ISTRZ1(1:1)='6' 13269 NCHAR=1 13270 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13271 IF(IERROR.EQ.'YES')GOTO9000 13272C 13273 ISTR2(NBASE2+1:NBASE2+1)='1' 13274 ISTRZ2(1:1)='1' 13275 NCHAR=1 13276 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13277 IF(IERROR.EQ.'YES')GOTO9000 13278C 13279 ISTR2(NBASE2+1:NBASE2+1)='2' 13280 ISTRZ2(1:1)='2' 13281 NCHAR=1 13282 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13283 IF(IERROR.EQ.'YES')GOTO9000 13284C 13285 ISTR2(NBASE2+1:NBASE2+2)='3' 13286 ISTRZ2(1:1)='3' 13287 NCHAR=1 13288 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13289 IF(IERROR.EQ.'YES')GOTO9000 13290C 13291 ISTR2(NBASE2+1:NBASE2+2)='4' 13292 ISTRZ2(1:1)='4' 13293 NCHAR=1 13294 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13295 IF(IERROR.EQ.'YES')GOTO9000 13296C 13297 ISTR2(NBASE2+1:NBASE2+2)='5' 13298 ISTRZ2(1:1)='5' 13299 NCHAR=1 13300 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13301 IF(IERROR.EQ.'YES')GOTO9000 13302C 13303 ISTR2(NBASE2+1:NBASE2+2)='12' 13304 ISTRZ2(1:2)='12' 13305 NCHAR=2 13306 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13307 IF(IERROR.EQ.'YES')GOTO9000 13308C 13309 ISTR2(NBASE2+1:NBASE2+2)='13' 13310 ISTRZ2(1:2)='13' 13311 NCHAR=2 13312 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13313 IF(IERROR.EQ.'YES')GOTO9000 13314C 13315 ISTR2(NBASE2+1:NBASE2+2)='14' 13316 ISTRZ2(1:2)='14' 13317 NCHAR=2 13318 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13319 IF(IERROR.EQ.'YES')GOTO9000 13320C 13321 ISTR2(NBASE2+1:NBASE2+2)='15' 13322 ISTRZ2(1:2)='15' 13323 NCHAR=2 13324 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13325 IF(IERROR.EQ.'YES')GOTO9000 13326C 13327 ISTR2(NBASE2+1:NBASE2+2)='23' 13328 ISTRZ2(1:2)='23' 13329 NCHAR=2 13330 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13331 IF(IERROR.EQ.'YES')GOTO9000 13332C 13333 ISTR2(NBASE2+1:NBASE2+2)='24' 13334 ISTRZ2(1:2)='24' 13335 NCHAR=2 13336 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13337 IF(IERROR.EQ.'YES')GOTO9000 13338C 13339 ISTR2(NBASE2+1:NBASE2+2)='25' 13340 ISTRZ2(1:2)='25' 13341 NCHAR=2 13342 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13343 IF(IERROR.EQ.'YES')GOTO9000 13344C 13345 ISTR2(NBASE2+1:NBASE2+2)='34' 13346 ISTRZ2(1:2)='34' 13347 NCHAR=2 13348 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13349 IF(IERROR.EQ.'YES')GOTO9000 13350C 13351 ISTR2(NBASE2+1:NBASE2+2)='35' 13352 ISTRZ2(1:2)='35' 13353 NCHAR=2 13354 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13355 IF(IERROR.EQ.'YES')GOTO9000 13356C 13357 ISTR2(NBASE2+1:NBASE2+2)='45' 13358 ISTRZ2(1:2)='45' 13359 NCHAR=2 13360 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13361 IF(IERROR.EQ.'YES')GOTO9000 13362C 13363 ISTR2(NBASE2+1:NBASE2+3)='123' 13364 ISTRZ2(1:3)='123' 13365 NCHAR=3 13366 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13367 IF(IERROR.EQ.'YES')GOTO9000 13368C 13369 ISTR2(NBASE2+1:NBASE2+3)='124' 13370 ISTRZ2(1:3)='124' 13371 NCHAR=3 13372 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13373 IF(IERROR.EQ.'YES')GOTO9000 13374C 13375 ISTR2(NBASE2+1:NBASE2+3)='125' 13376 ISTRZ2(1:3)='125' 13377 NCHAR=3 13378 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13379 IF(IERROR.EQ.'YES')GOTO9000 13380C 13381 ISTR2(NBASE2+1:NBASE2+3)='134' 13382 ISTRZ2(1:3)='134' 13383 NCHAR=3 13384 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13385 IF(IERROR.EQ.'YES')GOTO9000 13386C 13387 ISTR2(NBASE2+1:NBASE2+3)='135' 13388 ISTRZ2(1:3)='135' 13389 NCHAR=3 13390 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13391 IF(IERROR.EQ.'YES')GOTO9000 13392C 13393 ISTR2(NBASE2+1:NBASE2+3)='145' 13394 ISTRZ2(1:3)='145' 13395 NCHAR=3 13396 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13397 IF(IERROR.EQ.'YES')GOTO9000 13398C 13399 ISTR2(NBASE2+1:NBASE2+3)='234' 13400 ISTRZ2(1:3)='234' 13401 NCHAR=3 13402 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13403 IF(IERROR.EQ.'YES')GOTO9000 13404C 13405 ISTR2(NBASE2+1:NBASE2+3)='235' 13406 ISTRZ2(1:3)='235' 13407 NCHAR=3 13408 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13409 IF(IERROR.EQ.'YES')GOTO9000 13410C 13411 ISTR2(NBASE2+1:NBASE2+3)='245' 13412 ISTRZ2(1:3)='245' 13413 NCHAR=3 13414 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13415 IF(IERROR.EQ.'YES')GOTO9000 13416C 13417 ISTR2(NBASE2+1:NBASE2+3)='345' 13418 ISTRZ2(1:3)='345' 13419 NCHAR=3 13420 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13421 IF(IERROR.EQ.'YES')GOTO9000 13422C 13423 ISTR2(NBASE2+1:NBASE2+4)='1234' 13424 ISTRZ2(1:2)='56' 13425 NCHAR=2 13426 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13427 IF(IERROR.EQ.'YES')GOTO9000 13428C 13429 ISTR2(NBASE2+1:NBASE2+4)='1235' 13430 ISTRZ2(1:2)='46' 13431 NCHAR=2 13432 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13433 IF(IERROR.EQ.'YES')GOTO9000 13434C 13435 ISTR2(NBASE2+1:NBASE2+4)='1245' 13436 ISTRZ2(1:2)='36' 13437 NCHAR=2 13438 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13439 IF(IERROR.EQ.'YES')GOTO9000 13440C 13441 ISTR2(NBASE2+1:NBASE2+4)='1345' 13442 ISTRZ2(1:2)='26' 13443 NCHAR=2 13444 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13445 IF(IERROR.EQ.'YES')GOTO9000 13446C 13447 ISTR2(NBASE2+1:NBASE2+4)='2345' 13448 ISTRZ2(1:2)='16' 13449 NCHAR=2 13450 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13451 IF(IERROR.EQ.'YES')GOTO9000 13452C 13453 ISTR2(NBASE2+1:NBASE2+5)='12345' 13454 ISTRZ2(1:1)='6' 13455 NCHAR=1 13456 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13457 IF(IERROR.EQ.'YES')GOTO9000 13458C 13459 ELSEIF(K.EQ.7)THEN 13460C 13461C K = 7, N = 32 (2**(7-2)) 13462C 13463C CON1 = 1 13464C CON2 = 2 13465C CON3 = 3 13466C CON4 = 4 13467C CON5 = 5 13468C CON12 = 12 13469C CON13 = 13 13470C CON14 = 14 13471C CON15 = 15 13472C CON23 = 23 13473C CON24 = 24 13474C CON25 = 25 13475C CON34 = 34 13476C CON35 = 35 13477C CON45 = 45 13478C CON123 = 46 13479C CON124 = 36 13480C CON125 = 47 13481C CON134 = 26 13482C CON135 = 135 13483C CON145 = 27 13484C CON234 = 16 13485C CON235 = 235 13486C CON245 = 17 13487C CON345 = 345 13488C CON1234 = 6 13489C CON1235 = 456 13490C CON1245 = 7 13491C CON1345 = 256 13492C CON2345 = 156 13493C CON12345 = 56 13494C 13495C COP1 = 1 13496C COP2 = 2 13497C COP3 = 3 13498C COP4 = 4 13499C COP5 = 5 13500C COP12 = 12 13501C COP13 = 13 13502C COP14 = 14 13503C COP15 = 15 13504C COP23 = 23 13505C COP24 = 24 13506C COP25 = 25 13507C COP34 = 34 13508C COP35 = 35+67 13509C COP45 = 45 13510C COP123 = 46 13511C COP124 = 36+57 13512C COP125 = 47 13513C COP134 = 26 13514C COP135 = 135 13515C COP145 = 27 13516C COP234 = 16 13517C COP235 = 235 13518C COP245 = 17 13519C COP345 = 345 13520C COP1234 = 6 13521C COP1235 = 456 13522C COP1245 = 7 13523C COP1345 = 256 13524C COP2345 = 156 13525C COP12345 = 56+37 13526C 13527C MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS 13528C 13529 IF(NBASE1.GT.3)THEN 13530 IERROR='YES' 13531 GOTO8010 13532 ELSEIF(NBASE2.GT.3)THEN 13533 IERROR='YES' 13534 GOTO8010 13535 ENDIF 13536C 13537C NOW CREATE THE STRINGS 13538C 13539 ISTR1(NBASE1+1:NBASE1+1)='1' 13540 ISTRZ1(1:1)='1' 13541 NCHAR=1 13542 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13543 IF(IERROR.EQ.'YES')GOTO9000 13544C 13545 ISTR1(NBASE1+1:NBASE1+1)='2' 13546 ISTRZ1(1:1)='2' 13547 NCHAR=1 13548 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13549 IF(IERROR.EQ.'YES')GOTO9000 13550C 13551 ISTR1(NBASE1+1:NBASE1+2)='3' 13552 ISTRZ1(1:1)='3' 13553 NCHAR=1 13554 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13555 IF(IERROR.EQ.'YES')GOTO9000 13556C 13557 ISTR1(NBASE1+1:NBASE1+2)='4' 13558 ISTRZ1(1:1)='4' 13559 NCHAR=1 13560 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13561 IF(IERROR.EQ.'YES')GOTO9000 13562C 13563 ISTR1(NBASE1+1:NBASE1+2)='5' 13564 ISTRZ1(1:1)='5' 13565 NCHAR=1 13566 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13567 IF(IERROR.EQ.'YES')GOTO9000 13568C 13569 ISTR1(NBASE1+1:NBASE1+2)='12' 13570 ISTRZ1(1:2)='12' 13571 NCHAR=2 13572 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13573 IF(IERROR.EQ.'YES')GOTO9000 13574C 13575 ISTR1(NBASE1+1:NBASE1+2)='13' 13576 ISTRZ1(1:2)='13' 13577 NCHAR=2 13578 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13579 IF(IERROR.EQ.'YES')GOTO9000 13580C 13581 ISTR1(NBASE1+1:NBASE1+2)='14' 13582 ISTRZ1(1:2)='14' 13583 NCHAR=2 13584 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13585 IF(IERROR.EQ.'YES')GOTO9000 13586C 13587 ISTR1(NBASE1+1:NBASE1+2)='15' 13588 ISTRZ1(1:2)='15' 13589 NCHAR=2 13590 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13591 IF(IERROR.EQ.'YES')GOTO9000 13592C 13593 ISTR1(NBASE1+1:NBASE1+2)='23' 13594 ISTRZ1(1:2)='23' 13595 NCHAR=2 13596 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13597 IF(IERROR.EQ.'YES')GOTO9000 13598C 13599 ISTR1(NBASE1+1:NBASE1+2)='24' 13600 ISTRZ1(1:2)='24' 13601 NCHAR=2 13602 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13603 IF(IERROR.EQ.'YES')GOTO9000 13604C 13605 ISTR1(NBASE1+1:NBASE1+2)='25' 13606 ISTRZ1(1:2)='25' 13607 NCHAR=2 13608 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13609 IF(IERROR.EQ.'YES')GOTO9000 13610C 13611 ISTR1(NBASE1+1:NBASE1+2)='34' 13612 ISTRZ1(1:2)='34' 13613 NCHAR=2 13614 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13615 IF(IERROR.EQ.'YES')GOTO9000 13616C 13617 ISTR1(NBASE1+1:NBASE1+2)='35' 13618 ISTRZ1(1:2)='35' 13619 NCHAR=2 13620 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13621 IF(IERROR.EQ.'YES')GOTO9000 13622C 13623 ISTR1(NBASE1+1:NBASE1+2)='45' 13624 ISTRZ1(1:2)='45' 13625 NCHAR=2 13626 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13627 IF(IERROR.EQ.'YES')GOTO9000 13628C 13629 ISTR1(NBASE1+1:NBASE1+3)='123' 13630 ISTRZ1(1:2)='46' 13631 NCHAR=2 13632 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13633 IF(IERROR.EQ.'YES')GOTO9000 13634C 13635 ISTR1(NBASE1+1:NBASE1+3)='124' 13636 ISTRZ1(1:2)='36' 13637 NCHAR=2 13638 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13639 IF(IERROR.EQ.'YES')GOTO9000 13640C 13641 ISTR1(NBASE1+1:NBASE1+3)='125' 13642 ISTRZ1(1:2)='47' 13643 NCHAR=2 13644 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13645 IF(IERROR.EQ.'YES')GOTO9000 13646C 13647 ISTR1(NBASE1+1:NBASE1+3)='134' 13648 ISTRZ1(1:2)='26' 13649 NCHAR=2 13650 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13651 IF(IERROR.EQ.'YES')GOTO9000 13652C 13653 ISTR1(NBASE1+1:NBASE1+3)='135' 13654 ISTRZ1(1:3)='135' 13655 NCHAR=3 13656 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13657 IF(IERROR.EQ.'YES')GOTO9000 13658C 13659 ISTR1(NBASE1+1:NBASE1+3)='145' 13660 ISTRZ1(1:2)='27' 13661 NCHAR=2 13662 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13663 IF(IERROR.EQ.'YES')GOTO9000 13664C 13665 ISTR1(NBASE1+1:NBASE1+3)='234' 13666 ISTRZ1(1:2)='16' 13667 NCHAR=2 13668 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13669 IF(IERROR.EQ.'YES')GOTO9000 13670C 13671 ISTR1(NBASE1+1:NBASE1+3)='235' 13672 ISTRZ1(1:3)='235' 13673 NCHAR=3 13674 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13675 IF(IERROR.EQ.'YES')GOTO9000 13676C 13677 ISTR1(NBASE1+1:NBASE1+3)='245' 13678 ISTRZ1(1:2)='17' 13679 NCHAR=2 13680 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13681 IF(IERROR.EQ.'YES')GOTO9000 13682C 13683 ISTR1(NBASE1+1:NBASE1+3)='345' 13684 ISTRZ1(1:3)='345' 13685 NCHAR=3 13686 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13687 IF(IERROR.EQ.'YES')GOTO9000 13688C 13689 ISTR1(NBASE1+1:NBASE1+4)='1234' 13690 ISTRZ1(1:1)='6' 13691 NCHAR=1 13692 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13693 IF(IERROR.EQ.'YES')GOTO9000 13694C 13695 ISTR1(NBASE1+1:NBASE1+4)='1235' 13696 ISTRZ1(1:3)='456' 13697 NCHAR=3 13698 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13699 IF(IERROR.EQ.'YES')GOTO9000 13700C 13701 ISTR1(NBASE1+1:NBASE1+4)='1245' 13702 ISTRZ1(1:1)='7' 13703 NCHAR=1 13704 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13705 IF(IERROR.EQ.'YES')GOTO9000 13706C 13707 ISTR1(NBASE1+1:NBASE1+4)='1345' 13708 ISTRZ1(1:3)='256' 13709 NCHAR=3 13710 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13711 IF(IERROR.EQ.'YES')GOTO9000 13712C 13713 ISTR1(NBASE1+1:NBASE1+4)='2345' 13714 ISTRZ1(1:3)='156' 13715 NCHAR=3 13716 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13717 IF(IERROR.EQ.'YES')GOTO9000 13718C 13719 ISTR1(NBASE1+1:NBASE1+5)='12345' 13720 ISTRZ1(1:2)='56' 13721 NCHAR=2 13722 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13723 IF(IERROR.EQ.'YES')GOTO9000 13724C 13725 ISTR2(NBASE2+1:NBASE2+1)='1' 13726 ISTRZ2(1:1)='1' 13727 NCHAR=1 13728 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13729 IF(IERROR.EQ.'YES')GOTO9000 13730C 13731 ISTR2(NBASE2+1:NBASE2+1)='2' 13732 ISTRZ2(1:1)='2' 13733 NCHAR=1 13734 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13735 IF(IERROR.EQ.'YES')GOTO9000 13736C 13737 ISTR2(NBASE2+1:NBASE2+2)='3' 13738 ISTRZ2(1:1)='3' 13739 NCHAR=1 13740 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13741 IF(IERROR.EQ.'YES')GOTO9000 13742C 13743 ISTR2(NBASE2+1:NBASE2+2)='4' 13744 ISTRZ2(1:1)='4' 13745 NCHAR=1 13746 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13747 IF(IERROR.EQ.'YES')GOTO9000 13748C 13749 ISTR2(NBASE2+1:NBASE2+2)='5' 13750 ISTRZ2(1:1)='5' 13751 NCHAR=1 13752 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13753 IF(IERROR.EQ.'YES')GOTO9000 13754C 13755 ISTR2(NBASE2+1:NBASE2+2)='12' 13756 ISTRZ2(1:2)='12' 13757 NCHAR=2 13758 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13759 IF(IERROR.EQ.'YES')GOTO9000 13760C 13761 ISTR2(NBASE2+1:NBASE2+2)='13' 13762 ISTRZ2(1:2)='13' 13763 NCHAR=2 13764 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13765 IF(IERROR.EQ.'YES')GOTO9000 13766C 13767 ISTR2(NBASE2+1:NBASE2+2)='14' 13768 ISTRZ2(1:2)='14' 13769 NCHAR=2 13770 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13771 IF(IERROR.EQ.'YES')GOTO9000 13772C 13773 ISTR2(NBASE2+1:NBASE2+2)='15' 13774 ISTRZ2(1:2)='15' 13775 NCHAR=2 13776 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13777 IF(IERROR.EQ.'YES')GOTO9000 13778C 13779 ISTR2(NBASE2+1:NBASE2+2)='23' 13780 ISTRZ2(1:2)='23' 13781 NCHAR=2 13782 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13783 IF(IERROR.EQ.'YES')GOTO9000 13784C 13785 ISTR2(NBASE2+1:NBASE2+2)='24' 13786 ISTRZ2(1:2)='24' 13787 NCHAR=2 13788 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13789 IF(IERROR.EQ.'YES')GOTO9000 13790C 13791 ISTR2(NBASE2+1:NBASE2+2)='25' 13792 ISTRZ2(1:2)='25' 13793 NCHAR=2 13794 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13795 IF(IERROR.EQ.'YES')GOTO9000 13796C 13797 ISTR2(NBASE2+1:NBASE2+2)='34' 13798 ISTRZ2(1:2)='34' 13799 NCHAR=2 13800 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13801 IF(IERROR.EQ.'YES')GOTO9000 13802C 13803 ISTR2(NBASE2+1:NBASE2+2)='35' 13804 ISTRZ2(1:5)='35+67' 13805 NCHAR=5 13806 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13807 IF(IERROR.EQ.'YES')GOTO9000 13808C 13809 ISTR2(NBASE2+1:NBASE2+2)='45' 13810 ISTRZ2(1:2)='45' 13811 NCHAR=2 13812 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13813 IF(IERROR.EQ.'YES')GOTO9000 13814C 13815 ISTR2(NBASE2+1:NBASE2+3)='123' 13816 ISTRZ2(1:2)='46' 13817 NCHAR=2 13818 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13819 IF(IERROR.EQ.'YES')GOTO9000 13820C 13821 ISTR2(NBASE2+1:NBASE2+3)='124' 13822 ISTRZ2(1:5)='36+57' 13823 NCHAR=5 13824 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13825 IF(IERROR.EQ.'YES')GOTO9000 13826C 13827 ISTR2(NBASE2+1:NBASE2+3)='125' 13828 ISTRZ2(1:2)='47' 13829 NCHAR=2 13830 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13831 IF(IERROR.EQ.'YES')GOTO9000 13832C 13833 ISTR2(NBASE2+1:NBASE2+3)='134' 13834 ISTRZ2(1:2)='26' 13835 NCHAR=2 13836 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13837 IF(IERROR.EQ.'YES')GOTO9000 13838C 13839 ISTR2(NBASE2+1:NBASE2+3)='135' 13840 ISTRZ2(1:3)='135' 13841 NCHAR=3 13842 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13843 IF(IERROR.EQ.'YES')GOTO9000 13844C 13845 ISTR2(NBASE2+1:NBASE2+3)='145' 13846 ISTRZ2(1:2)='27' 13847 NCHAR=2 13848 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13849 IF(IERROR.EQ.'YES')GOTO9000 13850C 13851 ISTR2(NBASE2+1:NBASE2+3)='234' 13852 ISTRZ2(1:2)='16' 13853 NCHAR=2 13854 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13855 IF(IERROR.EQ.'YES')GOTO9000 13856C 13857 ISTR2(NBASE2+1:NBASE2+3)='235' 13858 ISTRZ2(1:3)='235' 13859 NCHAR=3 13860 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13861 IF(IERROR.EQ.'YES')GOTO9000 13862C 13863 ISTR2(NBASE2+1:NBASE2+3)='245' 13864 ISTRZ2(1:2)='17' 13865 NCHAR=2 13866 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13867 IF(IERROR.EQ.'YES')GOTO9000 13868C 13869 ISTR2(NBASE2+1:NBASE2+3)='345' 13870 ISTRZ2(1:3)='345' 13871 NCHAR=3 13872 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13873 IF(IERROR.EQ.'YES')GOTO9000 13874C 13875 ISTR2(NBASE2+1:NBASE2+4)='1234' 13876 ISTRZ2(1:1)='6' 13877 NCHAR=1 13878 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13879 IF(IERROR.EQ.'YES')GOTO9000 13880C 13881 ISTR2(NBASE2+1:NBASE2+4)='1235' 13882 ISTRZ2(1:3)='456' 13883 NCHAR=3 13884 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13885 IF(IERROR.EQ.'YES')GOTO9000 13886C 13887 ISTR2(NBASE2+1:NBASE2+4)='1245' 13888 ISTRZ2(1:1)='7' 13889 NCHAR=1 13890 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13891 IF(IERROR.EQ.'YES')GOTO9000 13892C 13893 ISTR2(NBASE2+1:NBASE2+4)='1345' 13894 ISTRZ2(1:3)='256' 13895 NCHAR=3 13896 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13897 IF(IERROR.EQ.'YES')GOTO9000 13898C 13899 ISTR2(NBASE2+1:NBASE2+4)='2345' 13900 ISTRZ2(1:3)='156' 13901 NCHAR=3 13902 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13903 IF(IERROR.EQ.'YES')GOTO9000 13904C 13905 ISTR2(NBASE2+1:NBASE2+5)='12345' 13906 ISTRZ2(1:5)='56+37' 13907 NCHAR=5 13908 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 13909 IF(IERROR.EQ.'YES')GOTO9000 13910C 13911 ELSEIF(K.EQ.10)THEN 13912C 13913C K = 10, N = 32 (2**(10-5)) 13914C 13915C CON1 = 1 13916C CON2 = 2 13917C CON3 = 3 13918C CON4 = 4 13919C CON5 = 5 13920C CON12 = 12 13921C CON13 = 13 13922C CON14 = 14 13923C CON15 = 15 13924C CON23 = 23 13925C CON24 = 24 13926C CON25 = 25 13927C CON34 = 34 13928C CON35 = 35 13929C CON45 = 45 13930C CON123 = 46 13931C CON124 = 36 13932C CON125 = 37 13933C CON134 = 26 13934C CON135 = 27 13935C CON145 = 28 13936C CON234 = 16 13937C CON235 = 17 13938C CON245 = 18 13939C CON345 = 19 13940C CON1234 = 6 13941C CON1235 = 7 13942C CON1245 = 8 13943C CON1345 = 9 13944C CON2345 = 0 13945C CON12345 = 10 13946C 13947C COP1 = 1 13948C COP2 = 2 13949C COP3 = 3 13950C COP4 = 4 13951C COP5 = 5 13952C COP12 = 12+90 13953C COP13 = 13+80 13954C COP14 = 14+70 13955C COP15 = 15+60 13956C COP23 = 23+89 13957C COP24 = 24+79 13958C COP25 = 25+69 13959C COP34 = 34+78 13960C COP35 = 35+68 13961C COP45 = 45+67 13962C COP123 = 46+57 13963C COP124 = 36+58 13964C COP125 = 37+48 13965C COP134 = 26+59 13966C COP135 = 27+49 13967C COP145 = 28+39 13968C COP234 = 16+50 13969C COP235 = 17+40 13970C COP245 = 18+30 13971C COP345 = 19+20 13972C COP1234 = 6 13973C COP1235 = 7 13974C COP1245 = 8 13975C COP1345 = 9 13976C COP2345 = 0 13977C COP12345 = 56+47+38+29+10 13978C 13979C MAKE SURE STRING NAME WILL HAVE <= 8 CHARACTERS 13980C 13981 IF(NBASE1.GT.3)THEN 13982 IERROR='YES' 13983 GOTO8010 13984 ELSEIF(NBASE2.GT.3)THEN 13985 IERROR='YES' 13986 GOTO8010 13987 ENDIF 13988C 13989C NOW CREATE THE STRINGS 13990C 13991 ISTR1(NBASE1+1:NBASE1+1)='1' 13992 ISTRZ1(1:1)='1' 13993 NCHAR=1 13994 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 13995 IF(IERROR.EQ.'YES')GOTO9000 13996C 13997 ISTR1(NBASE1+1:NBASE1+1)='2' 13998 ISTRZ1(1:1)='2' 13999 NCHAR=1 14000 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14001 IF(IERROR.EQ.'YES')GOTO9000 14002C 14003 ISTR1(NBASE1+1:NBASE1+2)='3' 14004 ISTRZ1(1:1)='3' 14005 NCHAR=1 14006 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14007 IF(IERROR.EQ.'YES')GOTO9000 14008C 14009 ISTR1(NBASE1+1:NBASE1+2)='4' 14010 ISTRZ1(1:1)='4' 14011 NCHAR=1 14012 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14013 IF(IERROR.EQ.'YES')GOTO9000 14014C 14015 ISTR1(NBASE1+1:NBASE1+2)='5' 14016 ISTRZ1(1:1)='5' 14017 NCHAR=1 14018 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14019 IF(IERROR.EQ.'YES')GOTO9000 14020C 14021 ISTR1(NBASE1+1:NBASE1+2)='12' 14022 ISTRZ1(1:2)='12' 14023 NCHAR=2 14024 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14025 IF(IERROR.EQ.'YES')GOTO9000 14026C 14027 ISTR1(NBASE1+1:NBASE1+2)='13' 14028 ISTRZ1(1:2)='13' 14029 NCHAR=2 14030 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14031 IF(IERROR.EQ.'YES')GOTO9000 14032C 14033 ISTR1(NBASE1+1:NBASE1+2)='14' 14034 ISTRZ1(1:2)='14' 14035 NCHAR=2 14036 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14037 IF(IERROR.EQ.'YES')GOTO9000 14038C 14039 ISTR1(NBASE1+1:NBASE1+2)='15' 14040 ISTRZ1(1:2)='15' 14041 NCHAR=2 14042 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14043 IF(IERROR.EQ.'YES')GOTO9000 14044C 14045 ISTR1(NBASE1+1:NBASE1+2)='23' 14046 ISTRZ1(1:2)='23' 14047 NCHAR=2 14048 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14049 IF(IERROR.EQ.'YES')GOTO9000 14050C 14051 ISTR1(NBASE1+1:NBASE1+2)='24' 14052 ISTRZ1(1:2)='24' 14053 NCHAR=2 14054 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14055 IF(IERROR.EQ.'YES')GOTO9000 14056C 14057 ISTR1(NBASE1+1:NBASE1+2)='25' 14058 ISTRZ1(1:2)='25' 14059 NCHAR=2 14060 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14061 IF(IERROR.EQ.'YES')GOTO9000 14062C 14063 ISTR1(NBASE1+1:NBASE1+2)='34' 14064 ISTRZ1(1:2)='34' 14065 NCHAR=2 14066 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14067 IF(IERROR.EQ.'YES')GOTO9000 14068C 14069 ISTR1(NBASE1+1:NBASE1+2)='35' 14070 ISTRZ1(1:2)='35' 14071 NCHAR=2 14072 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14073 IF(IERROR.EQ.'YES')GOTO9000 14074C 14075 ISTR1(NBASE1+1:NBASE1+2)='45' 14076 ISTRZ1(1:2)='45' 14077 NCHAR=2 14078 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14079 IF(IERROR.EQ.'YES')GOTO9000 14080C 14081 ISTR1(NBASE1+1:NBASE1+3)='123' 14082 ISTRZ1(1:2)='46' 14083 NCHAR=2 14084 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14085 IF(IERROR.EQ.'YES')GOTO9000 14086C 14087 ISTR1(NBASE1+1:NBASE1+3)='124' 14088 ISTRZ1(1:2)='36' 14089 NCHAR=2 14090 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14091 IF(IERROR.EQ.'YES')GOTO9000 14092C 14093 ISTR1(NBASE1+1:NBASE1+3)='125' 14094 ISTRZ1(1:2)='37' 14095 NCHAR=2 14096 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14097 IF(IERROR.EQ.'YES')GOTO9000 14098C 14099 ISTR1(NBASE1+1:NBASE1+3)='134' 14100 ISTRZ1(1:2)='26' 14101 NCHAR=2 14102 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14103 IF(IERROR.EQ.'YES')GOTO9000 14104C 14105 ISTR1(NBASE1+1:NBASE1+3)='135' 14106 ISTRZ1(1:2)='27' 14107 NCHAR=2 14108 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14109 IF(IERROR.EQ.'YES')GOTO9000 14110C 14111 ISTR1(NBASE1+1:NBASE1+3)='145' 14112 ISTRZ1(1:2)='28' 14113 NCHAR=2 14114 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14115 IF(IERROR.EQ.'YES')GOTO9000 14116C 14117 ISTR1(NBASE1+1:NBASE1+3)='234' 14118 ISTRZ1(1:2)='16' 14119 NCHAR=2 14120 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14121 IF(IERROR.EQ.'YES')GOTO9000 14122C 14123 ISTR1(NBASE1+1:NBASE1+3)='235' 14124 ISTRZ1(1:2)='17' 14125 NCHAR=2 14126 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14127 IF(IERROR.EQ.'YES')GOTO9000 14128C 14129 ISTR1(NBASE1+1:NBASE1+3)='245' 14130 ISTRZ1(1:2)='18' 14131 NCHAR=2 14132 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14133 IF(IERROR.EQ.'YES')GOTO9000 14134C 14135 ISTR1(NBASE1+1:NBASE1+3)='345' 14136 ISTRZ1(1:2)='19' 14137 NCHAR=2 14138 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14139 IF(IERROR.EQ.'YES')GOTO9000 14140C 14141 ISTR1(NBASE1+1:NBASE1+4)='1234' 14142 ISTRZ1(1:1)='6' 14143 NCHAR=1 14144 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14145 IF(IERROR.EQ.'YES')GOTO9000 14146C 14147 ISTR1(NBASE1+1:NBASE1+4)='1235' 14148 ISTRZ1(1:1)='7' 14149 NCHAR=1 14150 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14151 IF(IERROR.EQ.'YES')GOTO9000 14152C 14153 ISTR1(NBASE1+1:NBASE1+4)='1245' 14154 ISTRZ1(1:1)='8' 14155 NCHAR=1 14156 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14157 IF(IERROR.EQ.'YES')GOTO9000 14158C 14159 ISTR1(NBASE1+1:NBASE1+4)='1345' 14160 ISTRZ1(1:1)='9' 14161 NCHAR=1 14162 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14163 IF(IERROR.EQ.'YES')GOTO9000 14164C 14165 ISTR1(NBASE1+1:NBASE1+4)='2345' 14166 ISTRZ1(1:1)='0' 14167 NCHAR=1 14168 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14169 IF(IERROR.EQ.'YES')GOTO9000 14170C 14171 ISTR1(NBASE1+1:NBASE1+5)='12345' 14172 ISTRZ1(1:2)='10' 14173 NCHAR=2 14174 CALL CONFO2(ISTR1,ISTRZ1,NCHAR,ISUBRO,IBUGA3,IERROR) 14175 IF(IERROR.EQ.'YES')GOTO9000 14176C 14177 ISTR2(NBASE2+1:NBASE2+1)='1' 14178 ISTRZ2(1:1)='1' 14179 NCHAR=1 14180 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14181 IF(IERROR.EQ.'YES')GOTO9000 14182C 14183 ISTR2(NBASE2+1:NBASE2+1)='2' 14184 ISTRZ2(1:1)='2' 14185 NCHAR=1 14186 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14187 IF(IERROR.EQ.'YES')GOTO9000 14188C 14189 ISTR2(NBASE2+1:NBASE2+2)='3' 14190 ISTRZ2(1:1)='3' 14191 NCHAR=1 14192 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14193 IF(IERROR.EQ.'YES')GOTO9000 14194C 14195 ISTR2(NBASE2+1:NBASE2+2)='4' 14196 ISTRZ2(1:1)='4' 14197 NCHAR=1 14198 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14199 IF(IERROR.EQ.'YES')GOTO9000 14200C 14201 ISTR2(NBASE2+1:NBASE2+2)='5' 14202 ISTRZ2(1:1)='5' 14203 NCHAR=1 14204 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14205 IF(IERROR.EQ.'YES')GOTO9000 14206C 14207 ISTR2(NBASE2+1:NBASE2+2)='12' 14208 ISTRZ2(1:5)='12+90' 14209 NCHAR=5 14210 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14211 IF(IERROR.EQ.'YES')GOTO9000 14212C 14213 ISTR2(NBASE2+1:NBASE2+2)='13' 14214 ISTRZ2(1:5)='13+80' 14215 NCHAR=5 14216 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14217 IF(IERROR.EQ.'YES')GOTO9000 14218C 14219 ISTR2(NBASE2+1:NBASE2+2)='14' 14220 ISTRZ2(1:5)='14+70' 14221 NCHAR=5 14222 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14223 IF(IERROR.EQ.'YES')GOTO9000 14224C 14225 ISTR2(NBASE2+1:NBASE2+2)='15' 14226 ISTRZ2(1:5)='15+60' 14227 NCHAR=5 14228 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14229 IF(IERROR.EQ.'YES')GOTO9000 14230C 14231 ISTR2(NBASE2+1:NBASE2+2)='23' 14232 ISTRZ2(1:5)='23+89' 14233 NCHAR=5 14234 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14235 IF(IERROR.EQ.'YES')GOTO9000 14236C 14237 ISTR2(NBASE2+1:NBASE2+2)='24' 14238 ISTRZ2(1:5)='24+79' 14239 NCHAR=5 14240 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14241 IF(IERROR.EQ.'YES')GOTO9000 14242C 14243 ISTR2(NBASE2+1:NBASE2+2)='25' 14244 ISTRZ2(1:5)='25+69' 14245 NCHAR=5 14246 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14247 IF(IERROR.EQ.'YES')GOTO9000 14248C 14249 ISTR2(NBASE2+1:NBASE2+2)='34' 14250 ISTRZ2(1:5)='34+78' 14251 NCHAR=5 14252 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14253 IF(IERROR.EQ.'YES')GOTO9000 14254C 14255 ISTR2(NBASE2+1:NBASE2+2)='35' 14256 ISTRZ2(1:5)='35+68' 14257 NCHAR=5 14258 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14259 IF(IERROR.EQ.'YES')GOTO9000 14260C 14261 ISTR2(NBASE2+1:NBASE2+2)='45' 14262 ISTRZ2(1:5)='45+67' 14263 NCHAR=5 14264 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14265 IF(IERROR.EQ.'YES')GOTO9000 14266C 14267 ISTR2(NBASE2+1:NBASE2+3)='123' 14268 ISTRZ2(1:5)='46+57' 14269 NCHAR=5 14270 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14271 IF(IERROR.EQ.'YES')GOTO9000 14272C 14273 ISTR2(NBASE2+1:NBASE2+3)='124' 14274 ISTRZ2(1:5)='36+58' 14275 NCHAR=5 14276 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14277 IF(IERROR.EQ.'YES')GOTO9000 14278C 14279 ISTR2(NBASE2+1:NBASE2+3)='125' 14280 ISTRZ2(1:5)='37+48' 14281 NCHAR=5 14282 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14283 IF(IERROR.EQ.'YES')GOTO9000 14284C 14285 ISTR2(NBASE2+1:NBASE2+3)='134' 14286 ISTRZ2(1:5)='26+59' 14287 NCHAR=5 14288 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14289 IF(IERROR.EQ.'YES')GOTO9000 14290C 14291 ISTR2(NBASE2+1:NBASE2+3)='135' 14292 ISTRZ2(1:5)='27+49' 14293 NCHAR=5 14294 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14295 IF(IERROR.EQ.'YES')GOTO9000 14296C 14297 ISTR2(NBASE2+1:NBASE2+3)='145' 14298 ISTRZ2(1:5)='28+39' 14299 NCHAR=5 14300 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14301 IF(IERROR.EQ.'YES')GOTO9000 14302C 14303 ISTR2(NBASE2+1:NBASE2+3)='234' 14304 ISTRZ2(1:5)='16+50' 14305 NCHAR=5 14306 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14307 IF(IERROR.EQ.'YES')GOTO9000 14308C 14309 ISTR2(NBASE2+1:NBASE2+3)='235' 14310 ISTRZ2(1:5)='17+40' 14311 NCHAR=5 14312 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14313 IF(IERROR.EQ.'YES')GOTO9000 14314C 14315 ISTR2(NBASE2+1:NBASE2+3)='245' 14316 ISTRZ2(1:5)='18+30' 14317 NCHAR=5 14318 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14319 IF(IERROR.EQ.'YES')GOTO9000 14320C 14321 ISTR2(NBASE2+1:NBASE2+3)='345' 14322 ISTRZ2(1:5)='19+20' 14323 NCHAR=5 14324 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14325 IF(IERROR.EQ.'YES')GOTO9000 14326C 14327 ISTR2(NBASE2+1:NBASE2+4)='1234' 14328 ISTRZ2(1:1)='6' 14329 NCHAR=1 14330 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14331 IF(IERROR.EQ.'YES')GOTO9000 14332C 14333 ISTR2(NBASE2+1:NBASE2+4)='1235' 14334 ISTRZ2(1:1)='7' 14335 NCHAR=1 14336 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14337 IF(IERROR.EQ.'YES')GOTO9000 14338C 14339 ISTR2(NBASE2+1:NBASE2+4)='1245' 14340 ISTRZ2(1:1)='8' 14341 NCHAR=1 14342 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14343 IF(IERROR.EQ.'YES')GOTO9000 14344C 14345 ISTR2(NBASE2+1:NBASE2+4)='1345' 14346 ISTRZ2(1:1)='9' 14347 NCHAR=1 14348 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14349 IF(IERROR.EQ.'YES')GOTO9000 14350C 14351 ISTR2(NBASE2+1:NBASE2+4)='2345' 14352 ISTRZ2(1:1)='0' 14353 NCHAR=1 14354 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14355 IF(IERROR.EQ.'YES')GOTO9000 14356C 14357 ISTR2(NBASE2+1:NBASE2+5)='12345' 14358 ISTRZ2(1:14)='56+47+38+29+10' 14359 NCHAR=14 14360 CALL CONFO2(ISTR2,ISTRZ2,NCHAR,ISUBRO,IBUGA3,IERROR) 14361 IF(IERROR.EQ.'YES')GOTO9000 14362C 14363 ELSE 14364 IERROR='YES' 14365 GOTO8030 14366 ENDIF 14367 ELSE 14368 IERROR='YES' 14369 GOTO8030 14370 ENDIF 14371C 14372C ***************************************************** 14373C ** STEP 7-- ** 14374C ** PRINT FEEDBACK MESSAGE ** 14375C ***************************************************** 14376C 14377 ISTEPN='4' 14378 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFOU') 14379 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14380C 14381 IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN 14382 WRITE(ICOUT,999) 14383 CALL DPWRST('XXX','BUG ') 14384 WRITE(ICOUT,710) 14385 710 FORMAT(I5,' THE CONFOUNDING STRINGS HAVE BEEN CREATED.') 14386 CALL DPWRST('XXX','BUG ') 14387 WRITE(ICOUT,999) 14388 CALL DPWRST('XXX','BUG ') 14389 ENDIF 14390 GOTO9000 14391C 14392C ***************************************************** 14393C ** STEP 8-- ** 14394C ** PRINT ERROR MESSAGES ** 14395C ***************************************************** 14396C 14397 8010 CONTINUE 14398 WRITE(ICOUT,999) 14399 CALL DPWRST('XXX','BUG ') 14400 WRITE(ICOUT,101) 14401 CALL DPWRST('XXX','BUG ') 14402 WRITE(ICOUT,8011) 14403 8011 FORMAT(' STRING BASE TOO LONG FOR SPECIFIED N AND K.') 14404 CALL DPWRST('XXX','BUG ') 14405 WRITE(ICOUT,8013)ISTR1 14406 8013 FORMAT(' BASE FOR FIRST SET OF STRINGS IS ',A8) 14407 CALL DPWRST('XXX','BUG ') 14408 WRITE(ICOUT,8015)ISTR2 14409 8015 FORMAT(' BASE FOR SECOND SET OF STRINGS IS ',A8) 14410 CALL DPWRST('XXX','BUG ') 14411 WRITE(ICOUT,8033)K 14412 CALL DPWRST('XXX','BUG ') 14413 WRITE(ICOUT,8035)NTEMP 14414 CALL DPWRST('XXX','BUG ') 14415 GOTO9000 14416C 14417 8020 CONTINUE 14418 WRITE(ICOUT,999) 14419 CALL DPWRST('XXX','BUG ') 14420 WRITE(ICOUT,101) 14421 CALL DPWRST('XXX','BUG ') 14422 WRITE(ICOUT,8021) 14423 8021 FORMAT(' ERROR IN CREATING THE STRINGS.') 14424 CALL DPWRST('XXX','BUG ') 14425 GOTO9000 14426C 14427 8030 CONTINUE 14428 WRITE(ICOUT,999) 14429 CALL DPWRST('XXX','BUG ') 14430 WRITE(ICOUT,101) 14431 CALL DPWRST('XXX','BUG ') 14432 WRITE(ICOUT,8031) 14433 8031 FORMAT(' CONFOUND NOT SPECIFIED FOR GIVEN K AND N.') 14434 CALL DPWRST('XXX','BUG ') 14435 WRITE(ICOUT,8033)K 14436 8033 FORMAT(' THE VALUE OF K IS ',I8) 14437 CALL DPWRST('XXX','BUG ') 14438 WRITE(ICOUT,8035)NTEMP 14439 8035 FORMAT(' THE VALUE OF N IS ',I8) 14440 CALL DPWRST('XXX','BUG ') 14441 GOTO9000 14442C 14443C **************** 14444C ** STEP 90-- ** 14445C ** EXIT. ** 14446C **************** 14447C 14448 9000 CONTINUE 14449 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NFOU')THEN 14450 WRITE(ICOUT,999) 14451 CALL DPWRST('XXX','BUG ') 14452 WRITE(ICOUT,9011) 14453 9011 FORMAT('***** AT THE END OF CONFOU--') 14454 CALL DPWRST('XXX','BUG ') 14455 WRITE(ICOUT,9013)NUMNAM 14456 9013 FORMAT('NUMNAM,IVALUE = ',2I8) 14457 CALL DPWRST('XXX','BUG ') 14458 DO9015I=1,NUMNAM 14459 WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I), 14460 1 IVSTAR(I),IVSTOP(I) 14461 9016 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),', 14462 1 'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8) 14463 CALL DPWRST('XXX','BUG ') 14464 9015 CONTINUE 14465 ENDIF 14466C 14467 RETURN 14468 END 14469 SUBROUTINE CONFO2(ISTRIN,ISTRZZ,NCHAR,ISUBRO,IBUGA3,IERROR) 14470C 14471C PURPOSE--UTILITY ROUTINE FOR "CONFOU". THIS ROUTINE 14472C UPDATES A SINGLE STRING IN THE INTERNAL STRING 14473C TABLE. 14474C WRITTEN BY--ALAN HECKERT 14475C STATISTICAL ENGINEERING DIVISION 14476C INFORMATION TECHNOLOGY LABORATORY 14477C NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY 14478C GAITHERSBURG, MD 20899-8980 14479C PHONE--301-975-2899 14480C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 14481C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 14482C LANGUAGE--ANSI FORTRAN (1977) 14483C VERSION NUMBER--2015/01 14484C ORIGINAL VERSION--JANUARY 2015. 14485C UPDATED --MARCH 2015. CALL LIST TO DPINFU 14486C 14487C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 14488C 14489 CHARACTER*4 ISTRZ2(40) 14490C 14491 CHARACTER*8 ISTRIN 14492 CHARACTER*4 ISUBRO 14493 CHARACTER*4 IBUGA3 14494 CHARACTER*4 IERROR 14495C 14496 CHARACTER*4 NEWNAM 14497 CHARACTER*4 ICASEL 14498 CHARACTER*8 IHLEFT 14499 CHARACTER*4 IHLEF2 14500 CHARACTER*4 ISUBN1 14501 CHARACTER*4 ISUBN2 14502 CHARACTER*4 ISTEPN 14503C 14504 CHARACTER*(*) ISTRZZ 14505C 14506C--------------------------------------------------------------------- 14507C 14508C-----COMMON---------------------------------------------------------- 14509C 14510 INCLUDE 'DPCOPA.INC' 14511 INCLUDE 'DPCOHK.INC' 14512 INCLUDE 'DPCOHO.INC' 14513 INCLUDE 'DPCODA.INC' 14514C 14515C-----COMMON VARIABLES (GENERAL)-------------------------------------- 14516C 14517 INCLUDE 'DPCOP2.INC' 14518C 14519C-----START POINT----------------------------------------------------- 14520C 14521 ISUBN1='CONF' 14522 ISUBN2='O2 ' 14523 IERROR='NO' 14524C 14525 N=-1 14526 K=-1 14527 ILOC3=0 14528C 14529 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NFO2')THEN 14530 WRITE(ICOUT,999) 14531 999 FORMAT(1X) 14532 CALL DPWRST('XXX','BUG ') 14533 WRITE(ICOUT,51) 14534 51 FORMAT('***** AT THE BEGINNING OF CONFO2--') 14535 CALL DPWRST('XXX','BUG ') 14536 WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM 14537 52 FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8) 14538 CALL DPWRST('XXX','BUG ') 14539 DO55I=1,NUMNAM 14540 WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I), 14541 1 IVSTOP(I) 14542 56 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),', 14543 1 'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8) 14544 CALL DPWRST('XXX','BUG ') 14545 55 CONTINUE 14546 WRITE(ICOUT,57)NUMCHF,MAXCHF 14547 57 FORMAT('NUMCHF,MAXCHF = ',2I8) 14548 CALL DPWRST('XXX','BUG ') 14549 WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF)) 14550 60 FORMAT('IFUNC(.) = ',120A1) 14551 CALL DPWRST('XXX','BUG ') 14552 ENDIF 14553C 14554C ****************************************************** 14555C ** STEP 5-- * 14556C ** EXAMINE THE CURRENT STRING-- * 14557C ** IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD * 14558C ** BE A STRING (IF NOT, REPORT AN ERROR). * 14559C ****************************************************** 14560C 14561 ISTEPN='5' 14562 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFO2') 14563 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14564C 14565 DO510II=1,NUMNAM 14566 I2=II 14567 IF(ISTRIN(1:4).EQ.IHNAME(I2).AND. 14568 1 ISTRIN(5:8).EQ.IHNAM2(I2))THEN 14569 IF(IUSE(I2).EQ.'F')THEN 14570 ICASEL='STRI' 14571 ILISTL=I2 14572 GOTO519 14573 ELSE 14574 WRITE(ICOUT,999) 14575 CALL DPWRST('XXX','BUG ') 14576 WRITE(ICOUT,511) 14577 511 FORMAT('****** ERROR IN CONFO2--') 14578 CALL DPWRST('XXX','BUG ') 14579 WRITE(ICOUT,513)ISTRIN 14580 513 FORMAT(' THE NAME ',A8,' ALREADY EXISTS, BUT NOT ', 14581 1 'AS A STRING.') 14582 CALL DPWRST('XXX','BUG ') 14583 WRITE(ICOUT,515) 14584 515 FORMAT(' THIS STRING WILL NOT BE CREATED.') 14585 CALL DPWRST('XXX','BUG ') 14586 GOTO9000 14587 ENDIF 14588 ENDIF 14589 510 CONTINUE 14590C 14591 NEWNAM='YES' 14592 ICASEL='STRI' 14593C 14594 ILISTL=NUMNAM+1 14595 IF(ILISTL.GT.MAXNAM)THEN 14596 WRITE(ICOUT,999) 14597 CALL DPWRST('XXX','BUG ') 14598 WRITE(ICOUT,511) 14599 CALL DPWRST('XXX','BUG ') 14600 WRITE(ICOUT,522) 14601 522 FORMAT(' THE NUMBER OF VARIABLE, PARAMETER, AND ', 14602 1 'FUNCTION') 14603 CALL DPWRST('XXX','BUG ') 14604 WRITE(ICOUT,524)MAXNAM 14605 524 FORMAT(' NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8) 14606 CALL DPWRST('XXX','BUG ') 14607 IERROR='YES' 14608 GOTO9000 14609 ENDIF 14610C 14611 519 CONTINUE 14612C 14613C ***************************************************** 14614C ** STEP 6-- ** 14615C ** ADD THE CURRENT STRING ** 14616C ***************************************************** 14617C 14618 ISTEPN='6' 14619 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFO2') 14620 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 14621C 14622 IHLEFT=ISTRIN(1:4) 14623 IHLEF2=ISTRIN(5:8) 14624 DO411J=1,NCHAR 14625 ISTRZ2(J)=' ' 14626 ISTRZ2(J)(1:1)=ISTRZZ(J:J) 14627 411 CONTINUE 14628C 14629 CALL DPINFU(ISTRZ2,NCHAR,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP, 14630 1 NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL, 14631 1 NEWNAM,MAXNME, 14632 1 IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR) 14633 IF(IERROR.EQ.'YES')GOTO9000 14634C 14635C **************** 14636C ** STEP 90-- ** 14637C ** EXIT. ** 14638C **************** 14639C 14640 9000 CONTINUE 14641 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NFO2')THEN 14642 WRITE(ICOUT,999) 14643 CALL DPWRST('XXX','BUG ') 14644 WRITE(ICOUT,9011) 14645 9011 FORMAT('***** AT THE END OF CONFO2--') 14646 CALL DPWRST('XXX','BUG ') 14647 WRITE(ICOUT,9013)NUMNAM 14648 9013 FORMAT('NUMNAM,IVALUE = ',2I8) 14649 CALL DPWRST('XXX','BUG ') 14650 DO9015I=1,NUMNAM 14651 WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I), 14652 1 IVSTAR(I),IVSTOP(I) 14653 9016 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),', 14654 1 'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8) 14655 CALL DPWRST('XXX','BUG ') 14656 9015 CONTINUE 14657 ENDIF 14658C 14659 RETURN 14660 END 14661 DOUBLE PRECISION FUNCTION CONFUN(DM) 14662C 14663C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE 14664C CONSUL MEAN AND ONES FREQUENCY EQUATION. 14665C 14666C THE MEAN AND ONES FREQUENCY ESTIMATE OF MU IS: 14667C 14668C MUHAT = XBAR 14669C 14670C THE ESTIMATE OF M IS THEN THE SOLUTION OF THE 14671C EQUATION 14672C 14673C M*LOG(1 - (XBAR-1)/(M*XBAR)) - LOG(N1/N) = 0 14674C 14675C CALLED BY DFZERO ROUTINE FOR SOLVING A NONLINEAR 14676C UNIVARIATE EQUATION. 14677C EXAMPLE--CONSUL MAXIMUM LIKELIHOOD Y 14678C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY 14679C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8. 14680C WRITTEN BY--JAMES J. FILLIBEN 14681C STATISTICAL ENGINEERING DIVISION 14682C INFORMATION TECHNOLOGY LABORATORY 14683C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 14684C GAITHERSBUG, MD 20899-8980 14685C PHONE--301-975-2855 14686C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 14687C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 14688C LANGUAGE--ANSI FORTRAN (1977) 14689C VERSION NUMBER--2006/8 14690C ORIGINAL VERSION--AUGUST 2006. 14691C 14692C--------------------------------------------------------------------- 14693C 14694 DOUBLE PRECISION DM 14695C 14696 DOUBLE PRECISION XBAR 14697 DOUBLE PRECISION S2 14698 DOUBLE PRECISION F1FREQ 14699 COMMON/CONCOM/XBAR,S2,F1FREQ,MAXROW,N 14700C 14701C--------------------------------------------------------------------- 14702C 14703 INCLUDE 'DPCOP2.INC' 14704C 14705C-----START POINT----------------------------------------------------- 14706C 14707 CONFUN=DM*DLOG(1.0D0 - (XBAR-1.0D0)/(DM*XBAR)) - DLOG(F1FREQ) 14708C 14709 RETURN 14710 END 14711 SUBROUTINE CONFU2(N,XPAR,FVEC,IFLAG,Y,K) 14712C 14713C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE 14714C CONSUL MAXIMUM LIKELIHOOD EQUATION. 14715C 14716C THE MAXIMUM LIKELIHOOD FREQUENCY ESTIMATE OF MU IS: 14717C 14718C MUHAT = XBAR 14719C 14720C THE ESTIMATE OF M IS THEN THE SOLUTION OF THE 14721C EQUATION 14722C 14723C LOG(1 - (XBAR-1)/(M*XBAR)) + (1/(N*XBAR))* 14724C SUM[X=2 to k][SUM[i=0 to X-2][X*N(x)/(M*X-i)]] = 0 14725C 14726C THIS ROUTINE ASSUMES THE DATA IS IN THE FORM 14727C 14728C X(I) FREQ(I) 14729C 14730C CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS 14731C NONLINEAR EQUATIONS. NOTE THAT THE CALLING SEQUENCE 14732C DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF 14733C OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST. 14734C SINCE DNSQE ONLY PASSES ONE ARRAY, WE SPLIT INTO 14735C TWO PARTS: 1 - MAXNXT/2 ARE THE FREQUENCIES WHILE 14736C (MAXNXT/2 + 1) - MAXNXT ARE THE CLASS VALUES (I.E., 14737C THE X). 14738C EXAMPLE--CONSUL MAXIMUM LIKELIHOOD Y 14739C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY 14740C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8. 14741C WRITTEN BY--JAMES J. FILLIBEN 14742C STATISTICAL ENGINEERING DIVISION 14743C INFORMATION TECHNOLOGY LABORATORY 14744C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 14745C GAITHERSBUG, MD 20899-8980 14746C PHONE--301-975-2855 14747C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 14748C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 14749C LANGUAGE--ANSI FORTRAN (1977) 14750C VERSION NUMBER--2006/8 14751C ORIGINAL VERSION--AUGUST 2006. 14752C 14753C--------------------------------------------------------------------- 14754C 14755 DOUBLE PRECISION XPAR(*) 14756 DOUBLE PRECISION FVEC(*) 14757 REAL Y(*) 14758C 14759 DOUBLE PRECISION DM 14760 DOUBLE PRECISION DTERM1 14761 DOUBLE PRECISION DTERM2 14762 DOUBLE PRECISION DTERM3 14763 DOUBLE PRECISION DSUM1 14764 DOUBLE PRECISION DN 14765 DOUBLE PRECISION DX 14766 DOUBLE PRECISION DFREQ 14767C 14768 DOUBLE PRECISION XBAR 14769 DOUBLE PRECISION S2 14770 DOUBLE PRECISION F1FREQ 14771 COMMON/CONCOM/XBAR,S2,F1FREQ,MAXROW,NTOT 14772C 14773C--------------------------------------------------------------------- 14774C 14775 INCLUDE 'DPCOP2.INC' 14776C 14777C-----START POINT----------------------------------------------------- 14778C 14779 N=1 14780 IFLAG=0 14781C 14782 DM=XPAR(1) 14783 DN=DBLE(NTOT) 14784 IINDX=MAXROW/2 14785C 14786 DTERM1=(DM*XBAR - XBAR + 1.0D0)/(DM*XBAR) 14787 DTERM2=1.0D0/(DN*XBAR) 14788C 14789 DSUM1=0.0D0 14790 DO100I=2,K 14791 DX=DBLE(Y(IINDX+I)) 14792 DFREQ=Y(I) 14793 DO200J=0,I-2 14794 DSUM1=DSUM1 + DX*DFREQ/(DM*DX - DBLE(J)) 14795 200 CONTINUE 14796 100 CONTINUE 14797C 14798 DTERM3=DTERM2*DSUM1 14799 FVEC(1)=DTERM1 - DEXP(-DTERM3) 14800CCCCC FVEC(1)=DTERM1 + DTERM2*DSUM1 14801C 14802 RETURN 14803 END 14804 SUBROUTINE CONPDF(DX,DSHAPE,DM,ICONDF,DPDF) 14805C 14806C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS 14807C FUNCTION VALUE FOR THE CONSUL DISTRIBUTION WITH SHAPE 14808C PARAMETERS THETA AND M. THIS DISTRIBUTION IS 14809C DEFINED FOR ALL INTEGER X >= 1. 14810C 14811C THIS DISTRIBUTION REDUCES TO THE GEOMETRIC 14812C DISTRIBUTION WHEN M = 1. FOR THIS REASON, IT 14813C SOMETIMES REFERRED TO AS THE GENERALIZED GEOMETRIC 14814C DISTRIBUTION. NOTE THAT THIS DISTRIBUTION HAS A 14815C SIMILAR FORM TO THE GEETA DISTRIBUTION. 14816C 14817C THE PROBABILITY MASS FUNCTION IS: 14818C p(X;THETA,M)= 14819C (M*X X-1)*THETA**(X-1)*(1-THETA)**(M*X-X+1)/X 14820C X = 1, 2, 3, ,... 14821C 0 < THETA < 1; 1 <= M < 1/THETA 14822C 14823C THE MEAN AND VARIANCE ARE: 14824C 14825C MEAN = 1/(1-THETA*M) 14826C VARIANCE = M*THETA*(1-THETA)/ 14827C (1-THETA*M)**3 14828C 14829C THIS DISTRIBUTION IS SOMETIMES PARAMETERIZED USING 14830C THE MEAN (MU) INSTEAD OF THETA. THIS RESULTS IN 14831C THE PROBABILITY MASS FUNCTION: 14832C p(X;MU,M)= 14833C (M*X X-1)*((MU-1)/(M*MU))**(X-1)* 14834C (1 - (M-1)/(M*MU))**(M*X-X+1)/X 14835C X = 1, 2, 3, ,... 14836C MU >= 1; M > 1 14837C NOTE THAT THE RELATION IS: 14838C 14839C THETA=(MU-1)/(M*MU) 14840C 14841C THE MEAN AND VARIANCE BECOME: 14842C 14843C MEAN = MU 14844C VARIANCE = MU*(MU-1)*(M*MU-MU+1)/M 14845C 14846C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT 14847C WHICH THE PROBABILITY MASS 14848C FUNCTION IS TO BE EVALUATED. 14849C X SHOULD BE A NON-NEGATIVE INTEGER. 14850C --DSHAPE = THE FIRST SHAPE PARAMETER 14851C (EITHER THETA OR MU) 14852C --DM = THE SECOND SHAPE PARAMETER 14853C OUTPUT ARGUMENTS--DPDF = THE DOUBLE PRECISION PROBABILITY MASS 14854C FUNCTION VALUE. 14855C OUTPUT--THE DOUBLE PRECISION PROBABILITY MASS FUNCTION VALUE 14856C PDF FOR THE CONSUL DISTRIBUTION WITH SHAPE PARAMETERS 14857C THETA (OR MU) AND M 14858C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 14859C RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER 14860C --0 < THETA < 1; 1 < M < 1/THETA 14861C --MU >= 1; M > 1 14862C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 14863C LANGUAGE--ANSI FORTRAN (1977) 14864C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY 14865C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8. 14866C WRITTEN BY--JAMES J. FILLIBEN 14867C STATISTICAL ENGINEERING DIVISION 14868C INFORMATION TECHNOLOGY LABORATORY 14869C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 14870C GAITHERSBURG, MD 20899-8980 14871C PHONE--301-975-2855 14872C LANGUAGE--ANSI FORTRAN (1977) 14873C VERSION NUMBER--2006/8 14874C ORIGINAL VERSION--AUGUST 2006. 14875C 14876C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 14877C 14878C--------------------------------------------------------------------- 14879C 14880 DOUBLE PRECISION DX 14881 DOUBLE PRECISION DSHAPE 14882 DOUBLE PRECISION DM 14883 DOUBLE PRECISION DPDF 14884C 14885 DOUBLE PRECISION DTERM1 14886 DOUBLE PRECISION DTERM2 14887 DOUBLE PRECISION DTERM3 14888 DOUBLE PRECISION DTERM4 14889 DOUBLE PRECISION DTERM5 14890 DOUBLE PRECISION DTERM6 14891 DOUBLE PRECISION DTHETA 14892 DOUBLE PRECISION DMU 14893 DOUBLE PRECISION DLNGAM 14894C 14895 CHARACTER*4 ICONDF 14896C 14897C--------------------------------------------------------------------- 14898C 14899 INCLUDE 'DPCOP2.INC' 14900C 14901C-----START POINT----------------------------------------------------- 14902C 14903C CHECK THE INPUT ARGUMENTS FOR ERRORS 14904C 14905 IF(ICONDF.EQ.'THET')THEN 14906 DTHETA=DSHAPE 14907 ELSE 14908 DMU=DSHAPE 14909 ENDIF 14910C 14911 IX=INT(DX+0.5D0) 14912 IF(IX.LT.1)THEN 14913 WRITE(ICOUT,4) 14914 CALL DPWRST('XXX','BUG ') 14915 WRITE(ICOUT,46)DX 14916 CALL DPWRST('XXX','BUG ') 14917 DPDF=0.0D0 14918 GOTO9000 14919 ENDIF 14920 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO CONPDF IS LESS ', 14921 1'THAN 1') 14922C 14923 IF(ICONDF.EQ.'THET')THEN 14924 IF(DTHETA.LE.0.0D0 .OR. DTHETA.GE.1.0D0)THEN 14925 WRITE(ICOUT,15) 14926 CALL DPWRST('XXX','BUG ') 14927 WRITE(ICOUT,46)DTHETA 14928 CALL DPWRST('XXX','BUG ') 14929 DPDF=0.0 14930 GOTO9000 14931 ENDIF 14932 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO CONPDF IS NOT ', 14933 1 'IN THE INTERVAL (0,1)') 14934C 14935 IF(DM.LT.1.0D0 .OR. DM.GE.1.0D0/DTHETA)THEN 14936 WRITE(ICOUT,25)1.0D0/DTHETA 14937 CALL DPWRST('XXX','BUG ') 14938 WRITE(ICOUT,46)DM 14939 CALL DPWRST('XXX','BUG ') 14940 DPDF=0.0 14941 GOTO9000 14942 ENDIF 14943 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO CONPDF IS NOT ', 14944 1 'IN THE INTERVAL (1,',G15.7,')') 14945 ELSE 14946 IF(DMU.LT.1.0D0)THEN 14947 WRITE(ICOUT,35) 14948 CALL DPWRST('XXX','BUG ') 14949 WRITE(ICOUT,46)DMU 14950 CALL DPWRST('XXX','BUG ') 14951 DPDF=0.0 14952 GOTO9000 14953 ENDIF 14954 35 FORMAT('***** ERROR--THE SECOND ARGUMENT TO CONPDF IS ', 14955 1 'LESS THAN 1') 14956C 14957 IF(DM.LT.1.0D0)THEN 14958 WRITE(ICOUT,38) 14959 CALL DPWRST('XXX','BUG ') 14960 WRITE(ICOUT,46)DM 14961 CALL DPWRST('XXX','BUG ') 14962 DPDF=0.0 14963 GOTO9000 14964 ENDIF 14965 38 FORMAT('***** ERROR--THE THIRD ARGUMENT TO CONPDF IS ', 14966 1 'LESS THAN 1') 14967 ENDIF 14968C 14969 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 14970C 14971 DX=DBLE(IX) 14972C 14973 IF(ICONDF.EQ.'THET')THEN 14974 DTERM1=DLNGAM(DM*DX+1.0D0) + (DX-1.0D0)*DLOG(DTHETA) + 14975 1 (DM*DX-DX+1.0D0)*DLOG(1.0D0 - DTHETA) 14976 DTERM2=DLNGAM(DX) + DLNGAM(DM*DX-DX+2.0D0) 14977 DTERM3=DLOG(DX) 14978 DTERM4=DTERM1 - DTERM2 - DTERM3 14979 DPDF=DEXP(DTERM4) 14980 ELSE 14981 DTERM1=-DLOG(DX) 14982 DTERM2=DLNGAM(DM*DX+1.0D0) 14983 DTERM3=-DLNGAM(DX) - DLNGAM(DM*DX-DX+2.0D0) 14984 DTERM4=(DX-1.0D0)*(DLOG(DMU-1.0D0) - DLOG(DM) - DLOG(DMU)) 14985 DTERM5=(DM*DX-DX+1.0D0)*DLOG(1.0D0 - (DMU-1.0D0)/(DM*DMU)) 14986 DTERM6=DTERM1 + DTERM2 + DTERM3 + DTERM4 + DTERM5 14987 DPDF=DEXP(DTERM6) 14988 ENDIF 14989C 14990 9000 CONTINUE 14991 RETURN 14992 END 14993 SUBROUTINE CONPPF(DP,DSHAPE,DM,ICONDF,DPPF) 14994C 14995C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT 14996C FUNCTION VALUE FOR THE CONSUL DISTRIBUTION WITH SHAPE 14997C PARAMETERS THETA AND M. THIS DISTRIBUTION IS 14998C DEFINED FOR ALL INTEGER X >= 1. 14999C 15000C THIS DISTRIBUTION REDUCES TO THE GEOMETRIC 15001C DISTRIBUTION WHEN M = 1. FOR THIS REASON, IT 15002C SOMETIMES REFERRED TO AS THE GENERALIZED GEOMETRIC 15003C DISTRIBUTION. NOTE THAT THIS DISTRIBUTION HAS A 15004C SIMILAR FORM TO THE GEETA DISTRIBUTION. 15005C 15006C THE PROBABILITY MASS FUNCTION IS: 15007C p(X;THETA,M)= 15008C (M*X X-1)*THETA**(X-1)*(1-THETA)**(M*X-X+1)/X 15009C X = 1, 2, 3, ,... 15010C 0 < THETA < 1; 1 <= M < 1/THETA 15011C 15012C A RECURRENCE RELATION FOR THE CDF FUNCTION IS 15013C 15014C P(X;THETA,M) = {(M-1)*(X-1)+1}/(X-1)}* 15015C THETA*(1-TYHETA)**(M-1)* 15016C PROD[i=1 to X-2][(1 + M/(M*X-M-i)]* 15017C P(X-1;THETA,M) 15018C 15019C THIS DISTRIBUTION IS SOMETIMES PARAMETERIZED USING 15020C THE MEAN (MU) INSTEAD OF THETA. THIS RESULTS IN 15021C THE PROBABILITY MASS FUNCTION: 15022C p(X;MU,M)= 15023C (M*X X-1)*((MU-1)/(M*MU))**(X-1)* 15024C (1 - (M-1)/(M*MU))**(M*X-X+1)/X 15025C X = 1, 2, 3, ,... 15026C MU >= 1; M > 1 15027C NOTE THAT THE RELATION IS: 15028C 15029C THETA=(MU-1)/(M*MU) 15030C 15031C THE PERCENT POINT FUNCTION IS COMPUTED BY SUMMING 15032C THE CUMULATIVE DISTRIBUTION UNTIL THE APPROPRIATE 15033C PROBABILITY IS REACHED. 15034C 15035C INPUT ARGUMENTS--DP = THE DOUBLE PRECISION VALUE AT 15036C WHICH THE PERCENT POINT 15037C FUNCTION IS TO BE EVALUATED. 15038C --DSHAPE = THE FIRST SHAPE PARAMETER 15039C (EITHER THETA OR MU) 15040C --DM = THE SECOND SHAPE PARAMETER 15041C OUTPUT ARGUMENTS--DPPF = THE DOUBLE PRECISION PERCENT POINT 15042C FUNCTION VALUE. 15043C OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION 15044C VALUE PPF FOR THE CONSUL DISTRIBUTION WITH SHAPE 15045C PARAMETERS THETA (OR MU) AND M 15046C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 15047C RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER 15048C --0 < THETA < 1; 1 < M < 1/THETA 15049C --MU >= 1; M > 1 15050C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 15051C LANGUAGE--ANSI FORTRAN (1977) 15052C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY 15053C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8. 15054C WRITTEN BY--JAMES J. FILLIBEN 15055C STATISTICAL ENGINEERING DIVISION 15056C INFORMATION TECHNOLOGY LABORATORY 15057C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 15058C GAITHERSBURG, MD 20899-8980 15059C PHONE--301-975-2855 15060C LANGUAGE--ANSI FORTRAN (1977) 15061C VERSION NUMBER--2006/8 15062C ORIGINAL VERSION--AUGUST 2006. 15063C 15064C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 15065C 15066C--------------------------------------------------------------------- 15067C 15068 DOUBLE PRECISION DP 15069 DOUBLE PRECISION DPPF 15070 DOUBLE PRECISION DX 15071 DOUBLE PRECISION DSHAPE 15072 DOUBLE PRECISION DM 15073 DOUBLE PRECISION DCDF 15074 DOUBLE PRECISION DPDF 15075 DOUBLE PRECISION DPDFSV 15076C 15077 DOUBLE PRECISION DTERM1 15078 DOUBLE PRECISION DTERM2 15079 DOUBLE PRECISION DTERM3 15080 DOUBLE PRECISION DTHETA 15081 DOUBLE PRECISION DMU 15082 DOUBLE PRECISION DSUM 15083 DOUBLE PRECISION DEPS 15084C 15085 CHARACTER*4 ICONDF 15086 CHARACTER*4 ICOND2 15087C 15088C--------------------------------------------------------------------- 15089C 15090 INCLUDE 'DPCOP2.INC' 15091C 15092C-----START POINT----------------------------------------------------- 15093C 15094C CHECK THE INPUT ARGUMENTS FOR ERRORS 15095C 15096 IF(ICONDF.EQ.'THET')THEN 15097 DTHETA=DSHAPE 15098 ELSE 15099 DMU=DSHAPE 15100 DTHETA=(DMU-1.0D0)/(DM*DMU) 15101 ENDIF 15102C 15103 IF(DP.LT.0.0D0 .OR. DP.GE.1.0D0)THEN 15104 WRITE(ICOUT,4) 15105 CALL DPWRST('XXX','BUG ') 15106 WRITE(ICOUT,46)DP 15107 CALL DPWRST('XXX','BUG ') 15108 DPPF=0.0D0 15109 GOTO9000 15110 ENDIF 15111 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GETPPF IS OUTSIDE ', 15112 1'THE (0,1] INTERVAL') 15113C 15114 IF(ICONDF.EQ.'THET')THEN 15115 IF(DTHETA.LE.0.0D0 .OR. DTHETA.GE.1.0D0)THEN 15116 WRITE(ICOUT,15) 15117 CALL DPWRST('XXX','BUG ') 15118 WRITE(ICOUT,46)DTHETA 15119 CALL DPWRST('XXX','BUG ') 15120 DPPF=0.0 15121 GOTO9000 15122 ENDIF 15123 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO CONPPF IS NOT ', 15124 1 'IN THE INTERVAL (0,1)') 15125C 15126 IF(DM.LT.1.0D0 .OR. DM.GE.1.0D0/DTHETA)THEN 15127 WRITE(ICOUT,25)1.0D0/DTHETA 15128 CALL DPWRST('XXX','BUG ') 15129 WRITE(ICOUT,46)DM 15130 CALL DPWRST('XXX','BUG ') 15131 DPPF=0.0 15132 GOTO9000 15133 ENDIF 15134 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO CONPPF IS NOT ', 15135 1 'IN THE INTERVAL (1,',G15.7,')') 15136 ELSE 15137 IF(DMU.LT.1.0D0)THEN 15138 WRITE(ICOUT,35) 15139 CALL DPWRST('XXX','BUG ') 15140 WRITE(ICOUT,46)DMU 15141 CALL DPWRST('XXX','BUG ') 15142 DPPF=0.0 15143 GOTO9000 15144 ENDIF 15145 35 FORMAT('***** ERROR--THE SECOND ARGUMENT TO CONPPF IS ', 15146 1 'LESS THAN 1') 15147C 15148 IF(DM.LT.1.0D0)THEN 15149 WRITE(ICOUT,38) 15150 CALL DPWRST('XXX','BUG ') 15151 WRITE(ICOUT,46)DM 15152 CALL DPWRST('XXX','BUG ') 15153 DPPF=0.0 15154 GOTO9000 15155 ENDIF 15156 38 FORMAT('***** ERROR--THE THIRD ARGUMENT TO CONPPF IS ', 15157 1 'LESS THAN 1') 15158 ENDIF 15159C 15160 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 15161C 15162 DEPS=1.0D-7 15163 DCDF=(1.0D0 - DTHETA)**DM 15164 IF(DCDF.GE.DP-DEPS)THEN 15165 DPPF=1.0D0 15166 GOTO9000 15167 ELSE 15168 DX=2.0D0 15169 ICOND2='THET' 15170 CALL CONPDF(DX,DTHETA,DM,ICOND2,DPDF) 15171 DCDF=DCDF+DPDF 15172 IF(DCDF.GE.DP-DEPS)THEN 15173 DPPF=2.0D0 15174 GOTO9000 15175 ENDIF 15176 DX=3.0D0 15177 CALL CONPDF(DX,DTHETA,DM,ICOND2,DPDF) 15178 DCDF=DCDF+DPDF 15179 IF(DCDF.GE.DP-DEPS)THEN 15180 DPPF=3.0D0 15181 GOTO9000 15182 ENDIF 15183 DPDFSV=DPDF 15184 ENDIF 15185C 15186 I=3 15187 100 CONTINUE 15188 I=I+1 15189 DX=DBLE(I) 15190 DTERM1=DLOG(DTHETA) + (DM-1.0D0)*DLOG(1.0D0 - DTHETA) 15191 DTERM2=DLOG((DM-1.0D0)*(DX-1.0D0) + 1.0D0) - DLOG(DX-1.0D0) 15192 DTERM3=DTERM1 + DTERM2 15193 DSUM=0.0D0 15194 DO200J=1,I-2 15195 DSUM=DSUM + DLOG(1.0D0 + DM/(DM*DX - DM - DBLE(J))) 15196 200 CONTINUE 15197 IF(DPDFSV.GT.0.0D0)THEN 15198 DPDF=DEXP(DTERM3 + DSUM + DLOG(DPDFSV)) 15199 ELSE 15200 DPPF=DBLE(I) 15201 GOTO9000 15202 ENDIF 15203 DCDF=DCDF + DPDF 15204 IF(DCDF.GE.DP-DEPS)THEN 15205 DPPF=DBLE(I) 15206 GOTO9000 15207 ENDIF 15208 DPDFSV=DPDF 15209 GOTO100 15210C 15211 9000 CONTINUE 15212 RETURN 15213 END 15214 SUBROUTINE CONRAN(N,SHAPE,AM,ICONDF,ISEED,X) 15215C 15216C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N 15217C FROM THE CONSUL DISTRIBUTION WITH SHAPE PARAMETERS 15218C THETA OR MU AND AM. 15219C 15220C THE PROBABILITY MASS FUNCTION IS: 15221C p(X;THETA,M)= 15222C (M*X X-1)*THETA**(X-1)*(1-THETA)**(M*X-X+1)/X 15223C X = 1, 2, 3, ,... 15224C 0 < THETA < 1; 1 <= M < 1/THETA 15225C 15226C THE MEAN AND VARIANCE ARE: 15227C 15228C MEAN = 1/(1-THETA*M) 15229C VARIANCE = M*THETA*(1-THETA)/ 15230C (1-THETA*M)**3 15231C 15232C THIS DISTRIBUTION IS SOMETIMES PARAMETERIZED USING 15233C THE MEAN (MU) INSTEAD OF THETA. THIS RESULTS IN 15234C THE PROBABILITY MASS FUNCTION: 15235C p(X;MU,M)= 15236C (M*X X-1)*((MU-1)/(M*MU))**(X-1)* 15237C (1 - (M-1)/(M*MU))**(M*X-X+1)/X 15238C X = 1, 2, 3, ,... 15239C MU >= 1; M > 1 15240C NOTE THAT THE RELATION IS: 15241C 15242C THETA=(MU-1)/(M*MU) 15243C 15244C 15245C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER 15246C OF RANDOM NUMBERS TO BE 15247C GENERATED. 15248C --SHAPE = THE SINGLE PRECISION VALUE 15249C OF THE FIRST SHAPE PARAMETER. 15250C --AM = THE SINGLE PRECISION VALUE 15251C OF THE SECOND SHAPE PARAMETER. 15252C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR 15253C (OF DIMENSION AT LEAST N) 15254C INTO WHICH THE CONSUL 15255C RANDOM SAMPLE WILL BE PLACED. 15256C OUTPUT--A RANDOM SAMPLE OF SIZE N 15257C FROM THE CONSUL DISTRIBUTION 15258C WITH SHAPE PARAMETERS THETA (OR MU) AND AM. 15259C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 15260C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 15261C OF N FOR THIS SUBROUTINE. 15262C --0 < THETA < 1, 1 < M < 1/THETA 15263C MU >= 1; M > 1 15264C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, CONPPF 15265C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 15266C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 15267C LANGUAGE--ANSI FORTRAN (1977) 15268C REFERENCES--CONSUL (1990), "CONSUL DISTRIBUTION AND ITS 15269C PROPERTIES", COMMUNICATIONS IN STATISTICS-- 15270C THEORY AND METHODS, 19, PP. 3051-3068. 15271C --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY 15272C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8. 15273C WRITTEN BY--JAMES J. FILLIBEN 15274C STATISTICAL ENGINEERING DIVISION 15275C INFORMATION TECHNOLOGY LABORATORY 15276C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 15277C GAITHERSBURG, MD 20899-8980 15278C PHONE--301-975-2899 15279C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 15280C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 15281C LANGUAGE--ANSI FORTRAN (1977) 15282C VERSION NUMBER--2006/7 15283C ORIGINAL VERSION--JULY 2006. 15284C 15285C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 15286C 15287C--------------------------------------------------------------------- 15288C 15289 DIMENSION X(*) 15290C 15291 CHARACTER*4 ICONDF 15292C 15293 DOUBLE PRECISION DPPF 15294C 15295C--------------------------------------------------------------------- 15296C 15297 INCLUDE 'DPCOP2.INC' 15298C 15299C-----START POINT----------------------------------------------------- 15300C 15301C CHECK THE INPUT ARGUMENTS FOR ERRORS 15302C 15303 IF(N.LT.1)THEN 15304 WRITE(ICOUT,5) 15305 CALL DPWRST('XXX','BUG ') 15306 WRITE(ICOUT,47)N 15307 CALL DPWRST('XXX','BUG ') 15308 GOTO9000 15309 ENDIF 15310 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF CONSUL RANDOM ', 15311 1 'NUMBERS IS NON-POSITIVE') 15312C 15313 IF(ICONDF.EQ.'THET')THEN 15314 THETA=SHAPE 15315 IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN 15316 WRITE(ICOUT,15) 15317 CALL DPWRST('XXX','BUG ') 15318 WRITE(ICOUT,16) 15319 CALL DPWRST('XXX','BUG ') 15320 WRITE(ICOUT,46)THETA 15321 CALL DPWRST('XXX','BUG ') 15322 GOTO9000 15323 ENDIF 15324 15 FORMAT('***** ERROR--THE THETA PARAMETER FOR THE CONSUL') 15325 16 FORMAT(' RANDOM NUMBERS IS OUTSIDE THE (0,1) INTERVAL') 15326C 15327 IF(AM.LT.1.0 .OR. AM.GE.1.0/THETA)THEN 15328 WRITE(ICOUT,25) 15329 CALL DPWRST('XXX','BUG ') 15330 WRITE(ICOUT,26)1.0/THETA 15331 CALL DPWRST('XXX','BUG ') 15332 WRITE(ICOUT,46)AM 15333 CALL DPWRST('XXX','BUG ') 15334 GOTO9000 15335 ENDIF 15336 25 FORMAT('***** ERROR--THE M PARAMETER FOR THE CONSUL') 15337 26 FORMAT(' RANDOM NUMBERS IS OUTSIDE THE (1,',G15.7,') ', 15338 1 'INTERVAL') 15339 ELSE 15340 AMU=SHAPE 15341 IF(AMU.LT.1.0)THEN 15342 WRITE(ICOUT,35) 15343 CALL DPWRST('XXX','BUG ') 15344 WRITE(ICOUT,36) 15345 CALL DPWRST('XXX','BUG ') 15346 WRITE(ICOUT,46)AMU 15347 CALL DPWRST('XXX','BUG ') 15348 GOTO9000 15349 ENDIF 15350 35 FORMAT('***** ERROR--THE MU PARAMETER FOR THE CONSUL') 15351 36 FORMAT(' RANDOM NUMBERS IS LESS THAN 1') 15352C 15353 IF(AM.LE.1.0)THEN 15354 WRITE(ICOUT,38) 15355 CALL DPWRST('XXX','BUG ') 15356 WRITE(ICOUT,39) 15357 CALL DPWRST('XXX','BUG ') 15358 WRITE(ICOUT,46)AM 15359 CALL DPWRST('XXX','BUG ') 15360 GOTO9000 15361 ENDIF 15362 38 FORMAT('***** ERROR--THE M PARAMETER FOR THE CONSUL') 15363 39 FORMAT(' RANDOM NUMBERS IS LESS THAN OR EQUAL TO 1') 15364 ENDIF 15365C 15366 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 15367 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 15368C 15369C GENERATE N CONSUL DISTRIBUTION RANDOM NUMBERS USING THE 15370C INVERSION METHOD. 15371C 15372 CALL UNIRAN(N,ISEED,X) 15373 DO100I=1,N 15374 XTEMP=X(I) 15375 CALL CONPPF(DBLE(XTEMP),DBLE(SHAPE),DBLE(AM),ICONDF,DPPF) 15376 X(I)=REAL(DPPF) 15377 100 CONTINUE 15378C 15379 9000 CONTINUE 15380C 15381 RETURN 15382 END 15383 SUBROUTINE CONV14(ISTRIN,NSTRIN,IA,IB,IWIDTH,IBUGXX,IERROR) 15384C 15385C PURPOSE--CONVERT THE FIRST NSTRIN CHARACTERS IF ISTRIN 15386C TO THE FIRST CHARACTERS OF THE CHARACTER*4 ARRAYS 15387C IA AND IB. 15388C 15389C WRITTEN BY--JAMES J. FILLIBEN 15390C STATISTICAL ENGINEERING DIVISION 15391C INFORMATION TECHNOLOGY LABORATORY 15392C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 15393C GAITHERSBURG, MD 20899 15394C PHONE--301-975-2855 15395C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 15396C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 15397C LANGUAGE--ANSI FORTRAN (1977) 15398C VERSION NUMBER--93.3 15399C ORIGINAL VERSION--FEBRUARY 1993 15400C 15401C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 15402C 15403CCCCC CHARACTER*80 ISTRIN 15404 CHARACTER (LEN=*) :: ISTRIN 15405 CHARACTER (LEN=4) :: IA(*) 15406 CHARACTER (LEN=4) :: IB(*) 15407 CHARACTER*4 IBUGXX 15408 CHARACTER*4 IERROR 15409C 15410 CHARACTER*4 IC4 15411C 15412C--------------------------------------------------------------------- 15413C 15414 INCLUDE 'DPCOP2.INC' 15415C 15416C-----START POINT----------------------------------------------------- 15417C 15418 IERROR='NO' 15419C 15420 IF(IBUGXX.EQ.'ON')THEN 15421 WRITE(ICOUT,999) 15422 999 FORMAT(1X) 15423 CALL DPWRST('XXX','BUG ') 15424 WRITE(ICOUT,51) 15425 51 FORMAT('***** AT THE BEGINNING OF CONV14--') 15426 CALL DPWRST('XXX','BUG ') 15427 WRITE(ICOUT,52)IBUGXX,IERROR,NSTRIN 15428 52 FORMAT('IBUGXX,IERROR,NSTRIN = ',2(A4,2X),I8) 15429 CALL DPWRST('XXX','BUG ') 15430 WRITE(ICOUT,53)ISTRIN(1:80) 15431 53 FORMAT('ISTRIN(1:80) = ',A80) 15432 CALL DPWRST('XXX','BUG ') 15433 ENDIF 15434C 15435 IWIDTH=NSTRIN 15436 IF(1.LE.NSTRIN.AND.NSTRIN.LE.80)THEN 15437 DO1000I=1,NSTRIN 15438 IC4=' ' 15439 IC4(1:1)=ISTRIN(I:I) 15440 IA(I)=IC4 15441 IB(I)=IC4 15442 1000 CONTINUE 15443 IERROR='NO' 15444 ELSE 15445 IERROR='YES' 15446 ENDIF 15447C 15448 IF(IBUGXX.EQ.'ON')THEN 15449 WRITE(ICOUT,999) 15450 CALL DPWRST('XXX','BUG ') 15451 WRITE(ICOUT,9011) 15452 9011 FORMAT('***** AT THE END OF CONV14--') 15453 CALL DPWRST('XXX','BUG ') 15454 WRITE(ICOUT,9014)IERROR,NSTRIN,IWIDTH 15455 9014 FORMAT('IERROR,NSTRIN,IWIDTH = ',A4,2X,2I8) 15456 CALL DPWRST('XXX','BUG ') 15457 IF(IWIDTH.GE.1)THEN 15458 DO9020I=1,IWIDTH 15459 WRITE(ICOUT,9021)I,IA(I),IB(I) 15460 9021 FORMAT('I,IA(I),IB(I) = ',I8,2X,A4,2X,A4) 15461 CALL DPWRST('XXX','BUG ') 15462 9020 CONTINUE 15463 ENDIF 15464 ENDIF 15465C 15466 RETURN 15467 END 15468 SUBROUTINE CONVOL(Y1,N1,Y2,N2,NUMVAR,IWRITE,MAXN, 15469 1 Y3,N3,IBUGA3,IERROR) 15470C 15471C PURPOSE--COMPUTE CONVOLUTION OF 2 VARIABLES. 15472C NOTE--IF THE FIRST VARIABLE IS Y1(.) 15473C AND THE SECOND VARIABLE IS Y2(.), 15474C THEN THE OUTPUT VARIABLE CONTAINING THE 15475C CONVOLUTION 15476C WILL BE COMPUTED AS FOLLOWS-- 15477C Y3(1) = Y1(1)*Y2(1) 15478C Y3(2) = Y1(1)*Y2(2) + Y1(2)*Y2(1) 15479C Y3(3) = Y1(1)*Y2(3) + Y1(2)*Y2(2) + Y1(3)*Y2(1) 15480C ETC. 15481C NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y3(.) 15482C BEING IDENTICAL (OVERLAYED) ON THE INPUT VECTORS Y1(.) OR Y2(.) 15483C NOTE--Y1 AND Y2 NEED NOT BE THE SAME LENGTH. 15484C WRITTEN BY--JAMES J. FILLIBEN 15485C STATISTICAL ENGINEERING DIVISION 15486C INFORMATION TECHNOLOGY LABORATORY 15487C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 15488C GAITHERSBURG, MD 20899 15489C PHONE--301-975-2855 15490C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 15491C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 15492C LANGUAGE--ANSI FORTRAN (1977) 15493C VERSION NUMBER--82/7 15494C ORIGINAL VERSION--NOVEMBER 1981. 15495C UPDATED --MAY 1982. 15496C 15497C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 15498C 15499 CHARACTER*4 IWRITE 15500 CHARACTER*4 IBUGA3 15501 CHARACTER*4 IERROR 15502C 15503 CHARACTER*4 ISUBN1 15504 CHARACTER*4 ISUBN2 15505 CHARACTER*4 ISTEPN 15506C 15507C--------------------------------------------------------------------- 15508C 15509 DIMENSION Y1(*) 15510 DIMENSION Y2(*) 15511 DIMENSION Y3(*) 15512C 15513C--------------------------------------------------------------------- 15514C 15515 INCLUDE 'DPCOP2.INC' 15516C 15517C-----START POINT----------------------------------------------------- 15518C 15519 ISUBN1='CONV' 15520 ISUBN2='OL ' 15521 IERROR='NO' 15522C 15523 IF(IBUGA3.EQ.'ON')THEN 15524 WRITE(ICOUT,999) 15525 999 FORMAT(1X) 15526 CALL DPWRST('XXX','BUG ') 15527 WRITE(ICOUT,51) 15528 51 FORMAT('***** AT THE BEGINNING OF CONVOL--') 15529 CALL DPWRST('XXX','BUG ') 15530 WRITE(ICOUT,53)IBUGA3,IWRITE,N1,N2,NUMVAR,MAXN 15531 53 FORMAT('IBUGA3,IWRITE,N1,N2,NUMVAR,MAXN = ',2(A4,2X),4I8) 15532 CALL DPWRST('XXX','BUG ') 15533 DO55I=1,N1 15534 WRITE(ICOUT,56)I,Y1(I) 15535 56 FORMAT('I,Y1(I) = ',I8,G15.7) 15536 CALL DPWRST('XXX','BUG ') 15537 55 CONTINUE 15538 DO57I=1,N2 15539 WRITE(ICOUT,58)I,Y2(I) 15540 58 FORMAT('I,Y2(I) = ',I8,G15.7) 15541 CALL DPWRST('XXX','BUG ') 15542 57 CONTINUE 15543 ENDIF 15544C 15545C ******************************* 15546C ** COMPUTE THE CONVOLUTION ** 15547C ******************************* 15548C 15549 ISTEPN='1' 15550 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 15551C 15552 IF(N1.LE.0)GOTO150 15553 IF(N2.LE.0)GOTO150 15554 I3MIN=2 15555 I3MAX=N1+N2 15556 N3=I3MAX-I3MIN+1 15557 IF(N3.GT.MAXN)GOTO170 15558C 15559 DO100I3=1,N3 15560 Y3(I3)=0.0 15561 100 CONTINUE 15562C 15563 DO500I1=1,N1 15564 DO600I2=1,N2 15565 Y1P=Y1(I1) 15566 Y2P=Y2(I2) 15567 Y3P=Y1P*Y2P 15568 IARG=I1+I2-1 15569 Y3(IARG)=Y3(IARG)+Y3P 15570 600 CONTINUE 15571 500 CONTINUE 15572 GOTO190 15573C 15574 150 CONTINUE 15575 IERROR='YES' 15576 WRITE(ICOUT,999) 15577 CALL DPWRST('XXX','BUG ') 15578 WRITE(ICOUT,151) 15579 151 FORMAT('***** ERROR IN CONVOL--') 15580 CALL DPWRST('XXX','BUG ') 15581 WRITE(ICOUT,152) 15582 152 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') 15583 CALL DPWRST('XXX','BUG ') 15584 WRITE(ICOUT,153) 15585 153 FORMAT(' IN THE VARIABLES FOR WHICH') 15586 CALL DPWRST('XXX','BUG ') 15587 WRITE(ICOUT,154) 15588 154 FORMAT(' THE CONVOLUTION IS TO BE COMPUTED') 15589 CALL DPWRST('XXX','BUG ') 15590 WRITE(ICOUT,155) 15591 155 FORMAT(' MUST BE 1 OR LARGER.') 15592 CALL DPWRST('XXX','BUG ') 15593 WRITE(ICOUT,156) 15594 156 FORMAT(' SUCH WAS NOT THE CASE HERE.') 15595 CALL DPWRST('XXX','BUG ') 15596 WRITE(ICOUT,157)N1,N2 15597 157 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',2I8, 15598 1'.') 15599 CALL DPWRST('XXX','BUG ') 15600 GOTO190 15601C 15602 170 CONTINUE 15603 IERROR='YES' 15604 WRITE(ICOUT,999) 15605 CALL DPWRST('XXX','BUG ') 15606 WRITE(ICOUT,171) 15607 171 FORMAT('***** ERROR IN CONVOL--') 15608 CALL DPWRST('XXX','BUG ') 15609 WRITE(ICOUT,172) 15610 172 FORMAT(' THE NUMBER OF OBSERVATIONS') 15611 CALL DPWRST('XXX','BUG ') 15612 WRITE(ICOUT,173) 15613 173 FORMAT(' IN THE RESULTING CONVOLUTION VARIABLE ') 15614 CALL DPWRST('XXX','BUG ') 15615 WRITE(ICOUT,175)MAXN 15616 175 FORMAT(' MUST BE LESS THAN OR EQUAL TO ',I8,' .') 15617 CALL DPWRST('XXX','BUG ') 15618 WRITE(ICOUT,176) 15619 176 FORMAT(' SUCH WAS NOT THE CASE HERE.') 15620 CALL DPWRST('XXX','BUG ') 15621 WRITE(ICOUT,177)N3 15622 177 FORMAT(' THE OUTPUT NUMBER OF OBSERVATIONS HERE = ',I8, 15623 1'.') 15624 CALL DPWRST('XXX','BUG ') 15625 GOTO190 15626C 15627 190 CONTINUE 15628C 15629C ***************** 15630C ** STEP 90-- ** 15631C ** EXIT. ** 15632C ***************** 15633C 15634 IF(IBUGA3.EQ.'ON')THEN 15635 WRITE(ICOUT,999) 15636 CALL DPWRST('XXX','BUG ') 15637 WRITE(ICOUT,9011) 15638 9011 FORMAT('***** AT THE END OF CONVOL--') 15639 CALL DPWRST('XXX','BUG ') 15640 WRITE(ICOUT,9013)IERROR,N1,N2,NUMVAR,MAXN,N3 15641 9013 FORMAT('IERROR,N1,N2,NUMVAR,MAXN,N3 = ',A4,2X,5I8) 15642 CALL DPWRST('XXX','BUG ') 15643 DO9015I=1,N3 15644 WRITE(ICOUT,9016)I,Y1(I),Y2(I),Y3(I) 15645 9016 FORMAT('I,Y1(I),Y2(I),Y3(I) = ',I8,3G15.7) 15646 CALL DPWRST('XXX','BUG ') 15647 9015 CONTINUE 15648 ENDIF 15649C 15650 RETURN 15651 END 15652 SUBROUTINE CORMAT(X,Y,N,IWRITE,XIDTEM,STAT,IBUGA3,IERROR) 15653C 15654C PURPOSE--THIS SUBROUTINE COMPUTES THE PROPORTION OF 15655C CORRECT MATCHES BETWEEN TWO VARIABLES. THE 15656C NUMBER OF CORRECT MATCHES IS THE SUM OF THE 15657C TRUE POSITIVES AND TRUE NEGATIVES. 15658C 15659C THIS IS SPECIFICALLY FOR THE 2X2 CASE. THAT IS, 15660C EACH VARIABLE HAS TWO MUTUALLY EXCLUSIVE 15661C CHOICES CODED AS 1 (FOR SUCCESS) OR 0 (FOR 15662C FAILURE). A TRUE POSITIVE IS DEFINED AS THE 15663C CASE WHERE THE SECOND VARIABLE IS 1 AND THE FIRST 15664C VARIABLE IS A 1. 15665C 15666C A TYPICAL EXAMPLE WOULD BE WHERE VARIABLE ONE 15667C DENOTES THE GROUND TRUTH AND A VALUE OF 1 15668C INDICATES "PRESENT" AND A VALUE OF 0 INDICATES 15669C "NOT PRESENT". VARIABLE TWO REPRESENTS SOME TYPE 15670C OF DETECTION DEVICE WHERE A VALUE OF 1 INDICATES 15671C THE DEVICE DETECTED THE SPECIFIED OBJECT WHILE A 15672C VALUE OF 0 INDICATES THAT THE OBJECT WAS NOT 15673C DETECTED. A TRUE POSITIVE THEN IS THE CASE WHERE 15674C THE DEVICE DETECTED THE OBJECT WHEN IT WAS 15675C ACTUALY THERE. 15676C 15677C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 15678C (UNSORTED) OBSERVATIONS 15679C WHICH CONSTITUTE THE FIRST SET 15680C OF DATA. 15681C --Y = THE SINGLE PRECISION VECTOR OF 15682C (UNSORTED) OBSERVATIONS 15683C WHICH CONSTITUTE THE SECOND SET 15684C OF DATA. 15685C --N = THE INTEGER NUMBER OF OBSERVATIONS 15686C IN THE VECTOR X, OR EQUIVALENTLY, 15687C THE INTEGER NUMBER OF OBSERVATIONS 15688C IN THE VECTOR Y. 15689C OUTPUT ARGUMENTS--STAT = THE SINGLE PRECISION VALUE OF THE 15690C COMPUTED TRUE POSITIVE PROPORTION 15691C BETWEEN THE 2 SETS OF DATA 15692C IN THE INPUT VECTORS X AND Y. 15693C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE 15694C SAMPLE TRUE POSITIVE PROPORTION BETWEEN THE 2 SETS 15695C OF DATA IN THE INPUT VECTORS X AND Y. 15696C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 15697C OF N FOR THIS SUBROUTINE. 15698C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 15699C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 15700C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 15701C LANGUAGE--ANSI FORTRAN (1977) 15702C WRITTEN BY--JAMES J. FILLIBEN 15703C STATISTICAL ENGINEERING DIVISION 15704C INFORMATION TECHNOLOGY LABORATORY 15705C NATIONAL INSTIUTE OF STANDARDS AND TECHNOLOGY 15706C GAITHERSBURG, MD 20899-8980 15707C PHONE--301-975-2899 15708C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 15709C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 15710C LANGUAGE--ANSI FORTRAN (1977) 15711C VERSION NUMBER--2007/5 15712C ORIGINAL VERSION--MAY 2007. 15713C UPDATED --AUGUST 2007. IF 2X2 CASE, CHECK IF SUM 15714C OF ENTRIES IS <= 4. IN THIS 15715C CASE, ASSUME WE HAVE RAW DATA 15716C 15717C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 15718C 15719 CHARACTER*4 IWRITE 15720 CHARACTER*4 IBUGA3 15721 CHARACTER*4 IERROR 15722C 15723 CHARACTER*4 ISTEPN 15724 CHARACTER*4 ISUBN1 15725 CHARACTER*4 ISUBN2 15726C 15727C--------------------------------------------------------------------- 15728C 15729 DIMENSION X(*) 15730 DIMENSION Y(*) 15731 DIMENSION XIDTEM(*) 15732C 15733C--------------------------------------------------------------------- 15734C 15735 INCLUDE 'DPCOP2.INC' 15736C 15737C-----START POINT----------------------------------------------------- 15738C 15739 ISUBN1='TRUP' 15740 ISUBN2='OS ' 15741C 15742 IERROR='NO' 15743C 15744C 15745 IF(IBUGA3.EQ.'ON')THEN 15746 WRITE(ICOUT,999) 15747 999 FORMAT(1X) 15748 CALL DPWRST('XXX','BUG ') 15749 WRITE(ICOUT,51) 15750 51 FORMAT('***** AT THE BEGINNING OF CORMAT--') 15751 CALL DPWRST('XXX','BUG ') 15752 WRITE(ICOUT,52)IBUGA3 15753 52 FORMAT('IBUGA3 = ',A4) 15754 CALL DPWRST('XXX','BUG ') 15755 WRITE(ICOUT,53)N 15756 53 FORMAT('N = ',I8) 15757 CALL DPWRST('XXX','BUG ') 15758 DO55I=1,N 15759 WRITE(ICOUT,56)I,X(I),Y(I) 15760 56 FORMAT('I,X(I),Y(I) = ',I8,2G15.7) 15761 CALL DPWRST('XXX','BUG ') 15762 55 CONTINUE 15763 ENDIF 15764C 15765C ******************************************** 15766C ** STEP 21-- ** 15767C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 15768C ******************************************** 15769C 15770 ISTEPN='21' 15771 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 15772C 15773 IF(N.LT.2)THEN 15774 WRITE(ICOUT,999) 15775 CALL DPWRST('XXX','WRIT') 15776 WRITE(ICOUT,1201) 15777 1201 FORMAT('***** ERROR IN THE CORRECT MATCH PROPORTION') 15778 CALL DPWRST('XXX','WRIT') 15779 WRITE(ICOUT,1203) 15780 1203 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ', 15781 1 'VARIABLES IS LESS THAN TWO') 15782 CALL DPWRST('XXX','WRIT') 15783 WRITE(ICOUT,1205)N 15784 1205 FORMAT('SAMPLE SIZE = ',I8) 15785 CALL DPWRST('XXX','WRIT') 15786 IERROR='YES' 15787 GOTO9000 15788 ENDIF 15789C 15790C ******************************************** 15791C ** STEP 22-- ** 15792C ** CHECK THAT THE VARIABLES HAVE AT MOST ** 15793C ** TWO DISTINCT VALUES (1 INDICATES A ** 15794C ** SUCCESS, 0 INDICATES A FAILURE). ** 15795C ******************************************** 15796C 15797 ISTEPN='22' 15798 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 15799C 15800C NOTE: CHECK FOR SPECIAL CASE N = 2. IN THIS CASE, 15801C ASSUME WE HAVE A 2X2 TABLE OF COUNTS INSTEAD 15802C OF RAW DATA. 15803C 15804 IF(N.EQ.2)THEN 15805 N11=INT(X(1)+0.5) 15806 N21=INT(X(2)+0.5) 15807 N12=INT(Y(1)+0.5) 15808 N22=INT(Y(2)+0.5) 15809C 15810C CHECK IF ALL ENTRIES 0 OR 1. IF SO, ASSUME 15811C RAW DATA CASE. 15812C 15813 IF((N11.EQ.0 .OR. N11.EQ.1) .AND. 15814 1 (N12.EQ.0 .OR. N12.EQ.1) .AND. 15815 1 (N21.EQ.0 .OR. N21.EQ.1) .AND. 15816 1 (N22.EQ.0 .OR. N22.EQ.1)) GOTO1349 15817C 15818 IF(N11.LT.0)THEN 15819 WRITE(ICOUT,999) 15820 CALL DPWRST('XXX','BUG ') 15821 WRITE(ICOUT,1201) 15822 CALL DPWRST('XXX','BUG ') 15823 WRITE(ICOUT,1311) 15824 1311 FORMAT(' ROW 1 COLUMN 1 OF THE COUNTS TABLE IS ', 15825 1 'NEGATIVE.') 15826 CALL DPWRST('XXX','BUG ') 15827 ELSEIF(N21.LT.0)THEN 15828 WRITE(ICOUT,999) 15829 CALL DPWRST('XXX','BUG ') 15830 WRITE(ICOUT,1201) 15831 CALL DPWRST('XXX','BUG ') 15832 WRITE(ICOUT,1321) 15833 1321 FORMAT(' ROW 2 COLUMN 1 OF THE COUNTS TABLE IS ', 15834 1 'NEGATIVE.') 15835 CALL DPWRST('XXX','BUG ') 15836 ELSEIF(N12.LT.0)THEN 15837 WRITE(ICOUT,999) 15838 CALL DPWRST('XXX','BUG ') 15839 WRITE(ICOUT,1201) 15840 CALL DPWRST('XXX','BUG ') 15841 WRITE(ICOUT,1331) 15842 1331 FORMAT(' ROW 1 COLUMN 2 OF THE COUNTS TABLE IS ', 15843 1 'NEGATIVE.') 15844 CALL DPWRST('XXX','BUG ') 15845 ELSEIF(N22.LT.0)THEN 15846 WRITE(ICOUT,999) 15847 CALL DPWRST('XXX','BUG ') 15848 WRITE(ICOUT,1201) 15849 CALL DPWRST('XXX','BUG ') 15850 WRITE(ICOUT,1341) 15851 1341 FORMAT(' ROW 2 COLUMN 2 OF THE COUNTS TABLE IS ', 15852 1 'NEGATIVE.') 15853 CALL DPWRST('XXX','BUG ') 15854 ENDIF 15855C 15856 NTEMP=N11 + N12 + N21 + N22 15857 STAT=REAL(N11 + N22)/REAL(NTEMP) 15858 GOTO3000 15859 ENDIF 15860C 15861 1349 CONTINUE 15862C 15863 CALL DISTIN(X,N,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR) 15864 IF(NDIST.EQ.1)THEN 15865 AVAL=XIDTEM(1) 15866 IF(ABS(AVAL).LE.0.5)THEN 15867 AVAL=0.0 15868 ELSE 15869 AVAL=1.0 15870 ENDIF 15871 DO2202I=1,N 15872 X(I)=1.0 15873 2202 CONTINUE 15874 ELSEIF(NDIST.EQ.2)THEN 15875 IF(XIDTEM(1).EQ.1.0 .OR. XIDTEM(2).EQ.1.0)THEN 15876 DO2203I=1,N 15877 IF(X(I).NE.1.0)X(I)=0.0 15878 2203 CONTINUE 15879 ELSE 15880 ATEMP1=MIN(XIDTEM(1),XIDTEM(2)) 15881 ATEMP2=MAX(XIDTEM(1),XIDTEM(2)) 15882 DO2208I=1,N 15883 IF(X(I).EQ.ATEMP1)X(I)=0.0 15884 IF(X(I).EQ.ATEMP2)X(I)=1.0 15885 2208 CONTINUE 15886 ENDIF 15887 ELSEIF(NDIST.GT.2)THEN 15888 N11=0 15889 N12=0 15890 N21=0 15891 DO2510I=1,N 15892 IF(Y(I).EQ.X(I))THEN 15893 N11=N11+1 15894 ELSEIF(Y(I).LT.X(I))THEN 15895 N12=N12+1 15896 ELSEIF(Y(I).GT.X(I))THEN 15897 N21=N21+1 15898 ENDIF 15899 2510 CONTINUE 15900 STAT=REAL(N11)/REAL(N) 15901 GOTO9000 15902 ELSE 15903CCCCC WRITE(ICOUT,999) 15904CCCCC CALL DPWRST('XXX','BUG ') 15905CCCCC WRITE(ICOUT,1201) 15906CCCCC CALL DPWRST('XXX','BUG ') 15907CCCCC WRITE(ICOUT,2211) 15908C2211 FORMAT(' RESPONSE VARIABLE ONE SHOULD CONTAIN AT MOST') 15909CCCCC CALL DPWRST('XXX','BUG ') 15910CCCCC WRITE(ICOUT,2213) 15911C2213 FORMAT(' TWO DISTINCT VALUES.') 15912CCCCC CALL DPWRST('XXX','BUG ') 15913CCCCC WRITE(ICOUT,2215)NDIST 15914C2215 FORMAT(' ',I8,' DISTINCT VALUES FOUND.') 15915CCCCC CALL DPWRST('XXX','BUG ') 15916CCCCC IERROR='YES' 15917CCCCC GOTO9000 15918 ENDIF 15919C 15920 CALL DISTIN(Y,N,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR) 15921 IF(NDIST.EQ.1)THEN 15922 AVAL=XIDTEM(1) 15923 IF(ABS(AVAL).LE.0.5)THEN 15924 AVAL=0.0 15925 ELSE 15926 AVAL=1.0 15927 ENDIF 15928 DO2302I=1,N 15929 Y(I)=1.0 15930 2302 CONTINUE 15931 ELSEIF(NDIST.EQ.2)THEN 15932 IF(XIDTEM(1).EQ.1.0 .OR. XIDTEM(2).EQ.1.0)THEN 15933 DO2303I=1,N 15934 IF(Y(I).NE.1.0)Y(I)=0.0 15935 2303 CONTINUE 15936 ELSE 15937 ATEMP1=MIN(XIDTEM(1),XIDTEM(2)) 15938 ATEMP2=MAX(XIDTEM(1),XIDTEM(2)) 15939 DO2308I=1,N 15940 IF(Y(I).EQ.ATEMP1)Y(I)=0.0 15941 IF(Y(I).EQ.ATEMP2)Y(I)=1.0 15942 2308 CONTINUE 15943 ENDIF 15944 ELSEIF(NDIST.GT.2)THEN 15945 N11=0 15946 N12=0 15947 N21=0 15948 DO2520I=1,N 15949 IF(Y(I).EQ.X(I))THEN 15950 N11=N11+1 15951 ELSEIF(Y(I).LT.X(I))THEN 15952 N12=N12+1 15953 ELSEIF(Y(I).GT.X(I))THEN 15954 N21=N21+1 15955 ENDIF 15956 2520 CONTINUE 15957 STAT=REAL(N11)/REAL(N) 15958 GOTO9000 15959 ELSE 15960CCCCC WRITE(ICOUT,999) 15961CCCCC CALL DPWRST('XXX','BUG ') 15962CCCCC WRITE(ICOUT,1201) 15963CCCCC CALL DPWRST('XXX','BUG ') 15964CCCCC WRITE(ICOUT,2311) 15965C2311 FORMAT(' RESPONSE VARIABLE TWO SHOULD CONTAIN AT MOST') 15966CCCCC CALL DPWRST('XXX','BUG ') 15967CCCCC WRITE(ICOUT,2313) 15968C2313 FORMAT(' TWO DISTINCT VALUES.') 15969CCCCC CALL DPWRST('XXX','BUG ') 15970CCCCC WRITE(ICOUT,2315)NDIST 15971C2315 FORMAT(' ',I8,' DISTINCT VALUES FOUND.') 15972CCCCC CALL DPWRST('XXX','BUG ') 15973CCCCC IERROR='YES' 15974CCCCC GOTO9000 15975 ENDIF 15976C 15977 N11=0 15978 N12=0 15979 N21=0 15980 N22=0 15981 DO2410I=1,N 15982 IF(X(I).EQ.1.0 .AND. Y(I).EQ.1.0)THEN 15983 N11=N11+1 15984 ELSEIF(X(I).EQ.0.0 .AND. Y(I).EQ.0.0)THEN 15985 N22=N22+1 15986 ELSEIF(X(I).EQ.1.0 .AND. Y(I).EQ.0.0)THEN 15987 N12=N12+1 15988 ELSEIF(X(I).EQ.0.0 .AND. Y(I).EQ.1.0)THEN 15989 N21=N21+1 15990 ENDIF 15991 2410 CONTINUE 15992C 15993 STAT=REAL(N11 + N22)/REAL(N) 15994C 15995 3000 CONTINUE 15996C 15997C 15998C ******************************* 15999C ** STEP 3-- ** 16000C ** WRITE OUT A LINE ** 16001C ** OF SUMMARY INFORMATION. ** 16002C ******************************* 16003C 16004 IF(IFEEDB.EQ.'OFF')GOTO890 16005 IF(IWRITE.EQ.'OFF' .OR. IWRITE.EQ.'NO')GOTO890 16006 WRITE(ICOUT,999) 16007 CALL DPWRST('XXX','BUG ') 16008 WRITE(ICOUT,811)STAT 16009 811 FORMAT('THE CORRECT MATCH PROPORTION = ',G15.7) 16010 CALL DPWRST('XXX','BUG ') 16011 890 CONTINUE 16012C 16013C ***************** 16014C ** STEP 90-- ** 16015C ** EXIT. ** 16016C ***************** 16017C 16018 9000 CONTINUE 16019 IF(IBUGA3.EQ.'ON')THEN 16020 WRITE(ICOUT,999) 16021 CALL DPWRST('XXX','BUG ') 16022 WRITE(ICOUT,9011) 16023 9011 FORMAT('***** AT THE END OF CORMAT--') 16024 CALL DPWRST('XXX','BUG ') 16025 WRITE(ICOUT,9012)IBUGA3,IERROR 16026 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 16027 CALL DPWRST('XXX','BUG ') 16028 WRITE(ICOUT,9013)N,N11,N12,N21,N22 16029 9013 FORMAT('N,N11,N12,N21,N22 = ',5I10) 16030 CALL DPWRST('XXX','BUG ') 16031 WRITE(ICOUT,9015)STAT 16032 9015 FORMAT('STAT = ',G15.7) 16033 CALL DPWRST('XXX','BUG ') 16034 ENDIF 16035C 16036 RETURN 16037 END 16038 SUBROUTINE CORR(X,Y,N,IWRITE,XYCORR,IBUGA3,IERROR) 16039C 16040C PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE CORRELATION COEFFICIENT 16041C BETWEEN THE 2 SETS OF DATA IN THE INPUT VECTORS X AND Y. 16042C THE SAMPLE CORRELATION COEFFICIENT WILL BE A SINGLE 16043C PRECISION VALUE CALCULATED AS THE SUM OF CROSS PRODUCTS 16044C DIVIDED BY (N-1). 16045C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 16046C (UNSORTED) OBSERVATIONS WHICH 16047C CONSTITUTE THE FIRST SET OF DATA. 16048C --Y = THE SINGLE PRECISION VECTOR OF 16049C (UNSORTED) OBSERVATIONS WHICH 16050C CONSTITUTE THE SECOND SET OF DATA. 16051C --N = THE INTEGER NUMBER OF OBSERVATIONS 16052C IN THE VECTOR X, OR EQUIVALENTLY, 16053C THE INTEGER NUMBER OF OBSERVATIONS 16054C IN THE VECTOR Y. 16055C OUTPUT ARGUMENTS--XYCORR = THE SINGLE PRECISION VALUE OF THE 16056C COMPUTED SAMPLE CORRELATION COEFFICIENT 16057C BETWEEN THE 2 SETS OF DATA IN THE 16058C INPUT VECTORS X AND Y. THIS SINGLE 16059C PRECISION VALUE WILL BE BETWEEN -1.0 16060C AND 1.0 (INCLUSIVELY). 16061C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE 16062C SAMPLE CORRELATION COEFFICIENT BETWEEN THE 2 SETS 16063C OF DATA IN THE INPUT VECTORS X AND Y. 16064C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 16065C OF N FOR THIS SUBROUTINE. 16066C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 16067C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. 16068C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 16069C LANGUAGE--ANSI FORTRAN (1977) 16070C REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF 16071C STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 235-236. 16072C --KENDALL AND STUART, THE ADVANCED THEORY OF 16073C STATISTICS, VOLUME 2, EDITION 1, 1961, PAGES 292-293. 16074C --SNEDECOR AND COCHRAN, STATISTICAL METHODS, 16075C EDITION 6, 1967, PAGES 172-198. 16076C WRITTEN BY--JAMES J. FILLIBEN 16077C STATISTICAL ENGINEERING DIVISION 16078C INFORMATION TECHNOLOGY LABORATORY 16079C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 16080C GAITHERSBURG, MD 20899 16081C PHONE--301-975-2855 16082C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16083C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 16084C LANGUAGE--ANSI FORTRAN (1977) 16085C VERSION NUMBER--82/7 16086C ORIGINAL VERSION--APRIL 1979. 16087C UPDATED --JUNE 1979. 16088C UPDATED --JULY 1979. 16089C UPDATED --AUGUST 1981. 16090C UPDATED --MAY 1982. 16091C 16092C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16093C 16094 CHARACTER*4 IWRITE 16095 CHARACTER*4 IBUGA3 16096 CHARACTER*4 IERROR 16097C 16098 CHARACTER*4 ISUBN1 16099 CHARACTER*4 ISUBN2 16100C 16101C--------------------------------------------------------------------- 16102C 16103 DOUBLE PRECISION DN 16104 DOUBLE PRECISION DX1 16105 DOUBLE PRECISION DX2 16106 DOUBLE PRECISION DSUM1 16107 DOUBLE PRECISION DSUM2 16108 DOUBLE PRECISION DSUM12 16109 DOUBLE PRECISION DMEAN1 16110 DOUBLE PRECISION DMEAN2 16111 DOUBLE PRECISION DSQRT1 16112 DOUBLE PRECISION DSQRT2 16113C 16114 DIMENSION X(*) 16115 DIMENSION Y(*) 16116C 16117C--------------------------------------------------------------------- 16118C 16119 INCLUDE 'DPCOP2.INC' 16120C 16121C-----START POINT----------------------------------------------------- 16122C 16123 ISUBN1='CORR' 16124 ISUBN2=' ' 16125 IERROR='NO' 16126C 16127 DN=0.0D0 16128 DMEAN1=0.0D0 16129 DMEAN2=0.0D0 16130 DSUM12=0.0D0 16131C 16132 IF(IBUGA3.EQ.'ON')THEN 16133 WRITE(ICOUT,999) 16134 999 FORMAT(1X) 16135 CALL DPWRST('XXX','BUG ') 16136 WRITE(ICOUT,51) 16137 51 FORMAT('***** AT THE BEGINNING OF CORR--') 16138 CALL DPWRST('XXX','BUG ') 16139 WRITE(ICOUT,52)IBUGA3,N 16140 52 FORMAT('IBUGA3,N = ',A4,2X,I8) 16141 CALL DPWRST('XXX','BUG ') 16142 DO55I=1,N 16143 WRITE(ICOUT,56)I,X(I),Y(I) 16144 56 FORMAT('I,X(I),Y(I) = ',I8,2G15.7) 16145 CALL DPWRST('XXX','BUG ') 16146 55 CONTINUE 16147 ENDIF 16148C 16149C ******************************************* 16150C ** COMPUTE CORRELATION COEFFICIENT ** 16151C ******************************************* 16152C 16153C ******************************************** 16154C ** STEP 1-- ** 16155C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 16156C ******************************************** 16157C 16158 AN=N 16159C 16160 IF(N.LT.1)THEN 16161 IERROR='YES' 16162 WRITE(ICOUT,999) 16163 CALL DPWRST('XXX','BUG ') 16164 WRITE(ICOUT,111) 16165 111 FORMAT('***** ERROR IN CORRELATION--') 16166 CALL DPWRST('XXX','BUG ') 16167 WRITE(ICOUT,112) 16168 112 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE RESPONSE') 16169 CALL DPWRST('XXX','BUG ') 16170 WRITE(ICOUT,113) 16171 113 FORMAT(' IS LESS THAN 1.') 16172 CALL DPWRST('XXX','BUG ') 16173 WRITE(ICOUT,117)N 16174 117 FORMAT(' THE NUMBER OF OBSERVATIONS HERE = ',I8,'.') 16175 CALL DPWRST('XXX','BUG ') 16176 GOTO9000 16177 ENDIF 16178C 16179 IF(N.EQ.1)THEN 16180 XYCORR=1.0 16181 GOTO9000 16182 ENDIF 16183C 16184 HOLD=X(1) 16185 DO135I=2,N 16186 IF(X(I).NE.HOLD)GOTO139 16187 135 CONTINUE 16188 IF(IWRITE.EQ.'ON')THEN 16189 WRITE(ICOUT,999) 16190 CALL DPWRST('XXX','BUG ') 16191 WRITE(ICOUT,131) 16192 131 FORMAT('***** WARNING IN CORRELATION--') 16193 CALL DPWRST('XXX','BUG ') 16194 WRITE(ICOUT,136)HOLD 16195 136 FORMAT(' THE FIRST RESPONSE VARIABLE HAS ALL ', 16196 1 'ELEMENTS = ',G15.7) 16197 CALL DPWRST('XXX','BUG ') 16198 ENDIF 16199 XYCORR=0.0 16200 GOTO9000 16201 139 CONTINUE 16202C 16203 HOLD=Y(1) 16204 DO145I=2,N 16205 IF(Y(I).NE.HOLD)GOTO149 16206 145 CONTINUE 16207 IF(IWRITE.EQ.'ON')THEN 16208 WRITE(ICOUT,999) 16209 CALL DPWRST('XXX','BUG ') 16210 WRITE(ICOUT,131) 16211 CALL DPWRST('XXX','BUG ') 16212 WRITE(ICOUT,146)HOLD 16213 146 FORMAT(' THE SECOND RESPONSE VARIABLE HAS ALL ', 16214 1 'ELEMENTS = ',G15.7) 16215 CALL DPWRST('XXX','BUG ') 16216 ENDIF 16217 XYCORR=0.0 16218 GOTO9000 16219 149 CONTINUE 16220C 16221C ************************************************ 16222C ** STEP 2-- ** 16223C ** COMPUTE THE CORRELATION COEFFICIENT. ** 16224C ************************************************ 16225C 16226 DN=N 16227 DSUM1=0.0D0 16228 DSUM2=0.0D0 16229 DO200I=1,N 16230 DX1=X(I) 16231 DX2=Y(I) 16232 DSUM1=DSUM1+DX1 16233 DSUM2=DSUM2+DX2 16234 200 CONTINUE 16235 DMEAN1=DSUM1/DN 16236 DMEAN2=DSUM2/DN 16237C 16238 DSUM1=0.0D0 16239 DSUM2=0.0D0 16240 DSUM12=0.0D0 16241 DO300I=1,N 16242 DX1=X(I) 16243 DX2=Y(I) 16244 DSUM1=DSUM1+(DX1-DMEAN1)*(DX1-DMEAN1) 16245 DSUM2=DSUM2+(DX2-DMEAN2)*(DX2-DMEAN2) 16246 DSUM12=DSUM12+(DX1-DMEAN1)*(DX2-DMEAN2) 16247 300 CONTINUE 16248 DSQRT1=0.0 16249 IF(DSUM1.GT.0.0D0)DSQRT1=DSQRT(DSUM1) 16250 DSQRT2=0.0 16251 IF(DSUM2.GT.0.0D0)DSQRT2=DSQRT(DSUM2) 16252 XYCORR=DSUM12/(DSQRT1*DSQRT2) 16253C 16254C ******************************* 16255C ** STEP 3-- ** 16256C ** WRITE OUT A LINE ** 16257C ** OF SUMMARY INFORMATION. ** 16258C ******************************* 16259C 16260 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 16261 WRITE(ICOUT,999) 16262 CALL DPWRST('XXX','BUG ') 16263 WRITE(ICOUT,811)N,XYCORR 16264 811 FORMAT('THE CORRELATION COEFFICIENT OF THE ',I8, 16265 1 ' OBSERVATIONS = ',G15.7) 16266 CALL DPWRST('XXX','BUG ') 16267 ENDIF 16268C 16269C ***************** 16270C ** STEP 90-- ** 16271C ** EXIT. ** 16272C ***************** 16273C 16274 9000 CONTINUE 16275 IF(IBUGA3.EQ.'ON')THEN 16276 WRITE(ICOUT,999) 16277 CALL DPWRST('XXX','BUG ') 16278 WRITE(ICOUT,9011) 16279 9011 FORMAT('***** AT THE END OF CORR--') 16280 CALL DPWRST('XXX','BUG ') 16281 WRITE(ICOUT,9012)IERROR,XYCORR 16282 9012 FORMAT('IERROR,XYCORR = ',A4,2X,G15.7) 16283 CALL DPWRST('XXX','BUG ') 16284 WRITE(ICOUT,9014)DN,DMEAN1,DMEAN2,DSUM12 16285 9014 FORMAT('DN,DMEAN1,DMEAN2,DSUM12 = ',4G15.7) 16286 CALL DPWRST('XXX','BUG ') 16287 ENDIF 16288C 16289 RETURN 16290 END 16291 SUBROUTINE CORRAT(Y,X,N,ICASE,IWRITE,XDIST,ETA, 16292 1 IBUGA3,ISUBRO,IERROR) 16293C 16294C PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE CORRELATION RATIO 16295C FOR THE RESPONSE VARIABLE Y AND GROUP-ID VARIABLE X. 16296C THE FORMULA IS: 16297C 16298C ETA**2 = SUM[i=1 to p][N(i)*(YBAR(i) - YBAR)**2/ 16299C SUM[i=1 to p][SUM[j=1 to N(i)][Y(ij) - YBAR)**2 16300C 16301C WHERE 16302C 16303C P = NUMBER OF GROUPS 16304C N(i) = NUMBER OF OBERVATIONS IN GROUP i 16305C YBAR(i) = MEAN OF GROUP i 16306C YBAR = GRAND MEAN 16307C 16308C THE INTRACLASS CORRELATION COEFFICIENT IS THE THE 16309C SQUARE ROOT OF THE CORRELATION RATIO. 16310C 16311C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR OF 16312C (UNSORTED) OBSERVATIONS FOR THE 16313C RESPONSE VARIABLE. 16314C --X = THE SINGLE PRECISION VECTOR OF 16315C (UNSORTED) OBSERVATIONS FOR THE 16316C GROUP-ID VARIABLE. 16317C --N = THE INTEGER NUMBER OF OBSERVATIONS 16318C IN THE VECTOR Y. 16319C OUTPUT ARGUMENTS--CORR = THE SINGLE PRECISION VALUE OF THE 16320C COMPUTED SAMPLE CORRELATION RATIO. 16321C THIS SINGLE PRECISION VALUE WILL BE 16322C BETWEEN -1.0 AND 1.0 (INCLUSIVELY). 16323C --ETA = THE SINGLE PRECISION VALUE OF THE 16324C COMPUTED SAMPLE INTRACLASS CORRELATION. 16325C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE SAMPLE 16326C CORRELATION RATIO FOR THE 2 SETS OF DATA IN THE INPUT 16327C VECTORS X AND Y. 16328C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 16329C OF N FOR THIS SUBROUTINE. 16330C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 16331C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. 16332C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 16333C LANGUAGE--ANSI FORTRAN (1977) 16334C REFERENCES--Pearson E.S. (1926) "Review of Statistical Methods 16335C for Research Workers (R. A. Fisher)", Science 16336C Progress, 20, 733-734. 16337C WRITTEN BY--ALAN HECKERT 16338C STATISTICAL ENGINEERING DIVISION 16339C INFORMATION TECHNOLOGY LABORATORY 16340C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 16341C GAITHERSBURG, MD 20899 16342C PHONE--301-975-2899 16343C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16344C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 16345C LANGUAGE--ANSI FORTRAN (1977) 16346C VERSION NUMBER--2019/08 16347C ORIGINAL VERSION--AUGUST 2019. 16348C 16349C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16350C 16351 CHARACTER*4 ICASE 16352 CHARACTER*4 IWRITE 16353 CHARACTER*4 IBUGA3 16354 CHARACTER*4 ISUBRO 16355 CHARACTER*4 IERROR 16356C 16357 CHARACTER*4 ISUBN1 16358 CHARACTER*4 ISUBN2 16359C 16360C--------------------------------------------------------------------- 16361C 16362 DIMENSION X(*) 16363 DIMENSION Y(*) 16364 DIMENSION XDIST(*) 16365C 16366 DOUBLE PRECISION DN 16367 DOUBLE PRECISION DSUM1 16368 DOUBLE PRECISION DSUM2 16369 DOUBLE PRECISION DSUM3 16370 DOUBLE PRECISION DSUM4 16371 DOUBLE PRECISION DMEAN 16372C 16373C--------------------------------------------------------------------- 16374C 16375 INCLUDE 'DPCOP2.INC' 16376C 16377C-----START POINT----------------------------------------------------- 16378C 16379 ISUBN1='CORR' 16380 ISUBN2='AT ' 16381 IERROR='NO' 16382C 16383 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RRAT')THEN 16384 WRITE(ICOUT,999) 16385 999 FORMAT(1X) 16386 CALL DPWRST('XXX','BUG ') 16387 WRITE(ICOUT,51) 16388 51 FORMAT('***** AT THE BEGINNING OF CORR--') 16389 CALL DPWRST('XXX','BUG ') 16390 WRITE(ICOUT,52)IBUGA3,ISUBRO,N 16391 52 FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8) 16392 CALL DPWRST('XXX','BUG ') 16393 DO55I=1,N 16394 WRITE(ICOUT,56)I,X(I),Y(I) 16395 56 FORMAT('I,X(I),Y(I) = ',I8,2G15.7) 16396 CALL DPWRST('XXX','BUG ') 16397 55 CONTINUE 16398 ENDIF 16399C 16400C ******************************************* 16401C ** COMPUTE CORRELATION RATIO ** 16402C ******************************************* 16403C 16404C ******************************************** 16405C ** STEP 1-- ** 16406C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 16407C ******************************************** 16408C 16409 AN=N 16410C 16411 IF(N.LT.1)THEN 16412 IERROR='YES' 16413 WRITE(ICOUT,999) 16414 CALL DPWRST('XXX','BUG ') 16415 WRITE(ICOUT,111) 16416 111 FORMAT('***** ERROR IN CORRELATION RATIO--') 16417 CALL DPWRST('XXX','BUG ') 16418 WRITE(ICOUT,112) 16419 112 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE RESPONSE') 16420 CALL DPWRST('XXX','BUG ') 16421 WRITE(ICOUT,113) 16422 113 FORMAT(' VARIABLE IS LESS THAN 1.') 16423 CALL DPWRST('XXX','BUG ') 16424 WRITE(ICOUT,117)N 16425 117 FORMAT(' THE NUMBER OF OBSERVATIONS = ',I8,'.') 16426 CALL DPWRST('XXX','BUG ') 16427 GOTO9000 16428 ENDIF 16429C 16430C ************************************************ 16431C ** STEP 2-- ** 16432C ** COMPUTE THE CORRELATION RATIO. ** 16433C ************************************************ 16434C 16435 CALL DISTIN(X,N,IWRITE,XDIST,NDIST,IBUGA3,IERROR) 16436 CALL MEAN(Y,N,IWRITE,YBAR,IBUGA3,IERROR) 16437C 16438 DSUM2=0.0D0 16439 DSUM4=0.0D0 16440 DO1000IGRP=1,NDIST 16441 NTEMP=0 16442 AHOLD=XDIST(IGRP) 16443 DSUM1=0.0D0 16444 DSUM3=0.0D0 16445 DO1010I=1,N 16446 IF(X(I).EQ.AHOLD)THEN 16447 NTEMP=NTEMP+1 16448 DSUM1=DSUM1 + DBLE(Y(I)) 16449 DSUM3=DSUM3 + (DBLE(Y(I)) - DBLE(YBAR))**2 16450 ENDIF 16451 1010 CONTINUE 16452 DMEAN=DSUM1/DBLE(NTEMP) 16453 DN=DBLE(NTEMP) 16454 DSUM2=DSUM2 + DN*(DMEAN-DBLE(YBAR))**2 16455 DSUM4=DSUM4 + DSUM3 16456C 16457 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RRAT')THEN 16458 WRITE(ICOUT,1019)IGRP,NTEMP,DSUM1,DSUM3 16459 1019 FORMAT('IGRP,NTEMP,DSUM1,DSUM3 = ',2I8,2G15.7) 16460 CALL DPWRST('XXX','BUG ') 16461 ENDIF 16462C 16463 1000 CONTINUE 16464 ETASQ=REAL(DSUM2/DSUM4) 16465 ETA=DSQRT(DSUM2/DSUM4) 16466C 16467C ******************************* 16468C ** STEP 3-- ** 16469C ** WRITE OUT A LINE ** 16470C ** OF SUMMARY INFORMATION. ** 16471C ******************************* 16472C 16473 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 16474 WRITE(ICOUT,999) 16475 CALL DPWRST('XXX','BUG ') 16476 IF(ICASE.EQ.'CRAT')THEN 16477 WRITE(ICOUT,8011)N,ETA 16478 8011 FORMAT('THE CORRELATION RATIO OF THE ',I8, 16479 1 ' OBSERVATIONS = ',G15.7) 16480 CALL DPWRST('XXX','BUG ') 16481 ELSE 16482 WRITE(ICOUT,8013)N,ETASQ 16483 8013 FORMAT('THE INTRACLASS CORRELATION OF THE ',I8, 16484 1 ' OBSERVATIONS = ',G15.7) 16485 CALL DPWRST('XXX','BUG ') 16486 ENDIF 16487 ENDIF 16488C 16489C ***************** 16490C ** STEP 90-- ** 16491C ** EXIT. ** 16492C ***************** 16493C 16494 9000 CONTINUE 16495 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RRAT')THEN 16496 WRITE(ICOUT,999) 16497 CALL DPWRST('XXX','BUG ') 16498 WRITE(ICOUT,9011) 16499 9011 FORMAT('***** AT THE END OF CORRAT--') 16500 CALL DPWRST('XXX','BUG ') 16501 WRITE(ICOUT,9012)IERROR,NDIST,CORR,ETA 16502 9012 FORMAT('IERROR,NDIST,CORR,ETA = ',A4,2X,I8,2X,2G15.7) 16503 CALL DPWRST('XXX','BUG ') 16504 WRITE(ICOUT,9014)DN,DMEAN1,DMEAN2,DSUM12 16505 9014 FORMAT('DN,DMEAN1,DMEAN2,DSUM12 = ',4G15.7) 16506 CALL DPWRST('XXX','BUG ') 16507 ENDIF 16508C 16509 RETURN 16510 END 16511 SUBROUTINE COSCDF(X,CDF) 16512C 16513C NOTE--COSINE CDF IS: 16514C COSCDF(X) = (PI + X + SIN(X))/(2*PI), -PI<=X<=PI 16515C WRITTEN BY--JAMES J. FILLIBEN 16516C STATISTICAL ENGINEERING DIVISION 16517C INFORMATION TECHNOLOGY LABORATORY 16518C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 16519C GAITHERSBURG, MD 20899 16520C PHONE--301-975-2855 16521C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16522C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 16523C LANGUAGE--ANSI FORTRAN (1977) 16524C VERSION NUMBER--95/4 16525C ORIGINAL VERSION--APRIL 1995. 16526C 16527C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16528C 16529C 16530 INCLUDE 'DPCOP2.INC' 16531C 16532 DATA PI/3.1415926535898E0/ 16533C 16534C-----START POINT----------------------------------------------------- 16535C 16536 CDF=0.0 16537 IF(X.LT.-PI)THEN 16538 CDF=0.0 16539 ELSEIF(X.GT.PI)THEN 16540 CDF=1.0 16541 ELSE 16542 CDF=(PI + X + SIN(X))/(2*PI) 16543 ENDIF 16544C 16545 RETURN 16546 END 16547 SUBROUTINE COSDIS(X,Y,N,IWRITE,ICASE,STATVA,IBUGA3,ISUBRO,IERROR) 16548C 16549C PURPOSE--THIS SUBROUTINE COMPUTES THE COSINE DISTANCE BETWEEN THE 16550C TWO SETS OF DATA IN THE INPUT VECTORS X AND Y. THE 16551C SAMPLE COSINE DISTANCE WILL BE A SINGLE PRECISION VALUE 16552C CALCULATED AS: 16553C 16554C SIMLARITY = SUM[i=1 to n][X(i)*Y(i)]/ 16555C {SQRT(SUM{i=1 to n][X(i)**2])* 16556C SQRT(SUM{i=1 to n][Y(i)**2])} 16557C 16558C DISTANCE = 1 - SIMILARITY 16559C 16560C THE ABOVE DISTANCE IS FOR POSITIVE VECTORS. NOTE 16561C THAT THIS DISTANCE IS NOT A PROPER DISTANCE IN THAT 16562C THE SCHWARTZ INEQUALITY DOES NOT HOLD. HOWEVER, THE 16563C ANGULAR VERSIONS (FOR POSITIVE VECTORS) ARE PROPER 16564C DISTANCES: 16565C 16566C ANGULAR DISTANCE = (1/COSINE SIMILARITY)/PI 16567C ANGULAR SIMILARITY = 1 - DISTANCE 16568C 16569C 2018/08: UPDATED FORMULAS 16570C 16571C ANGULAR DISTANCE = COS^(-1)(COSINE SIMILARITY)/PI 16572C ANGULAR SIMILARITY = 1 - DISTANCE 16573C 16574C IF NEGATIVE DATA IS ENCOUNTERED IN THE INPUT 16575C VECTORS, ONLY THE COSINE SIMILARITY IS COMPUTED. 16576C 16577C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 16578C (UNSORTED) OBSERVATIONS WHICH 16579C CONSTITUTE THE FIRST SET OF DATA. 16580C --Y = THE SINGLE PRECISION VECTOR OF 16581C (UNSORTED) OBSERVATIONS WHICH 16582C CONSTITUTE THE SECOND SET OF DATA. 16583C --N = THE INTEGER NUMBER OF OBSERVATIONS 16584C IN THE VECTORS X AND Y. 16585C OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE 16586C COMPUTED SAMPLE COSINE DISTANCE 16587C BETWEEN THE TWO SETS OF DATA IN THE 16588C INPUT VECTORS X AND Y. THIS SINGLE 16589C PRECISION VALUE WILL BE BETWEEN 0.0 16590C AND 1.0 (INCLUSIVELY). 16591C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE 16592C SAMPLE COSINE DISTANCE BETWEEN THE 2 SETS 16593C OF DATA IN THE INPUT VECTORS X AND Y. 16594C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 16595C OF N FOR THIS SUBROUTINE. 16596C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 16597C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. 16598C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 16599C LANGUAGE--ANSI FORTRAN (1977) 16600C REFERENCES--JOHN FOREMAN (2014), "DATA SMART", WILEY. 16601C WRITTEN BY--ALAN HECKERT 16602C STATISTICAL ENGINEERING DIVISION 16603C INFORMATION TECHNOLOGY LABORATORY 16604C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 16605C GAITHERSBURG, MD 20899 16606C PHONE--301-975-2899 16607C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16608C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 16609C LANGUAGE--ANSI FORTRAN (1977) 16610C VERSION NUMBER--2017/03 16611C ORIGINAL VERSION--MARCH 2017. 16612C 16613C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16614C 16615 CHARACTER*4 IWRITE 16616 CHARACTER*4 ICASE 16617 CHARACTER*4 IBUGA3 16618 CHARACTER*4 ISUBRO 16619 CHARACTER*4 IERROR 16620C 16621 CHARACTER*4 ISUBN1 16622 CHARACTER*4 ISUBN2 16623C 16624C--------------------------------------------------------------------- 16625C 16626 DOUBLE PRECISION DX1 16627 DOUBLE PRECISION DX2 16628 DOUBLE PRECISION DSUM1 16629 DOUBLE PRECISION DSUM2 16630 DOUBLE PRECISION DSUM3 16631 DOUBLE PRECISION DTERM1 16632C 16633 DIMENSION X(*) 16634 DIMENSION Y(*) 16635C 16636C--------------------------------------------------------------------- 16637C 16638 INCLUDE 'DPCOP2.INC' 16639C 16640 DATA PI/3.14159265358979/ 16641C 16642C-----START POINT----------------------------------------------------- 16643C 16644 ISUBN1='COSD' 16645 ISUBN2='IS ' 16646 IERROR='NO' 16647 COSSIM=CPUMIN 16648 COSDST=CPUMIN 16649 ANGSIM=CPUMIN 16650 ANGDIS=CPUMIN 16651C 16652 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SDIS')THEN 16653 WRITE(ICOUT,999) 16654 999 FORMAT(1X) 16655 CALL DPWRST('XXX','BUG ') 16656 WRITE(ICOUT,51) 16657 51 FORMAT('***** AT THE BEGINNING OF COSDIS--') 16658 CALL DPWRST('XXX','BUG ') 16659 WRITE(ICOUT,52)IBUGA3,ISUBRO,N 16660 52 FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8) 16661 CALL DPWRST('XXX','BUG ') 16662 DO55I=1,N 16663 WRITE(ICOUT,56)I,X(I),Y(I) 16664 56 FORMAT('I,X(I),Y(I) = ',I8,2G15.7) 16665 CALL DPWRST('XXX','BUG ') 16666 55 CONTINUE 16667 ENDIF 16668C 16669C ******************************************** 16670C ** STEP 1-- ** 16671C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 16672C ******************************************** 16673C 16674 AN=N 16675C 16676 IF(N.LT.1)THEN 16677 WRITE(ICOUT,999) 16678 CALL DPWRST('XXX','BUG ') 16679 WRITE(ICOUT,111) 16680 111 FORMAT('***** ERROR IN COSINE DISTANCE--') 16681 CALL DPWRST('XXX','BUG ') 16682 WRITE(ICOUT,112) 16683 112 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE RESPONSE') 16684 CALL DPWRST('XXX','BUG ') 16685 WRITE(ICOUT,113) 16686 113 FORMAT(' VARIABLES IS LESS THAN 1.') 16687 CALL DPWRST('XXX','BUG ') 16688 WRITE(ICOUT,117)N 16689 117 FORMAT(' THE NUMBER OF OBSERVATIONS HERE = ',I8,'.') 16690 CALL DPWRST('XXX','BUG ') 16691 IERROR='YES' 16692 GOTO9000 16693 ENDIF 16694C 16695 IF(N.EQ.1)THEN 16696 STATVA=1.0 16697 GOTO9000 16698 ENDIF 16699C 16700C ************************************************ 16701C ** STEP 2-- ** 16702C ** COMPUTE THE COSINE DISTANCE. ** 16703C ************************************************ 16704C 16705 IFLAG=1 16706 DSUM1=0.0D0 16707 DSUM2=0.0D0 16708 DSUM3=0.0D0 16709 DO200I=1,N 16710 IF(X(I).LT.0.0)IFLAG=0 16711 IF(Y(I).LT.0.0)IFLAG=0 16712 DX1=X(I) 16713 DX2=Y(I) 16714 DSUM1=DSUM1+DX1*DX2 16715 DSUM2=DSUM2+DX1**2 16716 DSUM3=DSUM3+DX2**2 16717 200 CONTINUE 16718 IF(DSUM2.GT.0.0D0 .AND. DSUM3.GT.0.0D0)THEN 16719 DTERM1=DSUM1/(DSQRT(DSUM2)*DSQRT(DSUM3)) 16720 ELSE 16721 GOTO9000 16722 ENDIF 16723 COSSIM=REAL(DTERM1) 16724 IF(IFLAG.EQ.1)THEN 16725 COSDST=1.0 - COSSIM 16726 AFACT=2.0 16727 ELSE 16728 AFACT=1.0 16729 ENDIF 16730 ANGDIS=AFACT*ACOS(COSSIM)/PI 16731 ANGSIM=1.0 - ANGDIS 16732C 16733 IF(ICASE.EQ.'COSS')THEN 16734 STATVA=COSSIM 16735 ELSEIF(ICASE.EQ.'COSD')THEN 16736 STATVA=COSDST 16737 ELSEIF(ICASE.EQ.'ACOS')THEN 16738 STATVA=ANGSIM 16739 ELSEIF(ICASE.EQ.'ACOD')THEN 16740 STATVA=ANGDIS 16741 ENDIF 16742C 16743C ******************************* 16744C ** STEP 3-- ** 16745C ** WRITE OUT A LINE ** 16746C ** OF SUMMARY INFORMATION. ** 16747C ******************************* 16748C 16749 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 16750 WRITE(ICOUT,999) 16751 CALL DPWRST('XXX','BUG ') 16752 IF(ICASE.EQ.'COSD')THEN 16753 WRITE(ICOUT,811)N,STATVA 16754 811 FORMAT('THE COSINE DISTANCE OF THE ',I8, 16755 1 ' OBSERVATIONS = ',G15.7) 16756 CALL DPWRST('XXX','BUG ') 16757 ELSEIF(ICASE.EQ.'COSS')THEN 16758 WRITE(ICOUT,813)N,STATVA 16759 813 FORMAT('THE COSINE SIMILARITY OF THE ',I8, 16760 1 ' OBSERVATIONS = ',G15.7) 16761 CALL DPWRST('XXX','BUG ') 16762 ELSEIF(ICASE.EQ.'ANGS')THEN 16763 WRITE(ICOUT,815)N,STATVA 16764 815 FORMAT('THE ANGULAR COSINE SIMILARITY OF THE ',I8, 16765 1 ' OBSERVATIONS = ',G15.7) 16766 CALL DPWRST('XXX','BUG ') 16767 ELSEIF(ICASE.EQ.'ANGD')THEN 16768 WRITE(ICOUT,817)N,STATVA 16769 817 FORMAT('THE ANGULAR COSINE DISTANCE OF THE ',I8, 16770 1 ' OBSERVATIONS = ',G15.7) 16771 CALL DPWRST('XXX','BUG ') 16772 ENDIF 16773 ENDIF 16774C 16775C ***************** 16776C ** STEP 90-- ** 16777C ** EXIT. ** 16778C ***************** 16779C 16780 9000 CONTINUE 16781 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SDIS')THEN 16782 WRITE(ICOUT,999) 16783 CALL DPWRST('XXX','BUG ') 16784 WRITE(ICOUT,9011) 16785 9011 FORMAT('***** AT THE END OF CORR--') 16786 CALL DPWRST('XXX','BUG ') 16787 WRITE(ICOUT,9012)IERROR,STATVA,IFLAG1 16788 9012 FORMAT('IERROR,STATVA,IFLAG1 = ',A4,2X,G15.7,I5) 16789 CALL DPWRST('XXX','BUG ') 16790 WRITE(ICOUT,9014)DSUM1,DSUM2,DSUM3,DTERM1 16791 9014 FORMAT('DSUM1,DSUM2,DSUM3,DTERM1 = ',4G15.7) 16792 CALL DPWRST('XXX','BUG ') 16793 WRITE(ICOUT,9016)COSSIM,COSDST,ANGSIM,ANGDIS 16794 9016 FORMAT('COSSIM,COSDST,ANGSIM,ANGDIS = ',4G15.7) 16795 CALL DPWRST('XXX','BUG ') 16796 ENDIF 16797C 16798 RETURN 16799 END 16800 SUBROUTINE COSPDF(X,PDF) 16801C 16802C NOTE--COSINE PDF IS: 16803C COSPDF(X) = (1 + COS(X))/(2*PI), -PI<=X<=PI 16804C WRITTEN BY--JAMES J. FILLIBEN 16805C STATISTICAL ENGINEERING DIVISION 16806C INFORMATION TECHNOLOGY LABORATORY 16807C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 16808C GAITHERSBURG, MD 20899 16809C PHONE--301-975-2855 16810C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16811C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 16812C LANGUAGE--ANSI FORTRAN (1977) 16813C VERSION NUMBER--95/4 16814C ORIGINAL VERSION--APRIL 1995. 16815C 16816C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16817C 16818C 16819 INCLUDE 'DPCOP2.INC' 16820C 16821 DATA PI/3.1415926535898E0/ 16822C 16823C-----START POINT----------------------------------------------------- 16824C 16825 PDF=0.0 16826 IF(X.LT.-PI .OR. X.GT.PI)THEN 16827 WRITE(ICOUT,301) 16828 CALL DPWRST('XXX','BUG ') 16829 WRITE(ICOUT,302)X 16830 CALL DPWRST('XXX','BUG ') 16831 GOTO9999 16832 ENDIF 16833 301 FORMAT('***** ERROR--THE INPUT ARGUMENT TO COSPDF IS NOT IN THE ', 16834 1 'INTERVAL (-PI,PI).') 16835 302 FORMAT(' THE VALUE OF THE ARGUMENT IS ',G15.7) 16836C 16837 PDF=(1.0 + COS(X))/(2*PI) 16838C 16839 9999 CONTINUE 16840 RETURN 16841 END 16842 SUBROUTINE COSPPF(P,PPF) 16843C 16844C NOTE--ALGORITHM ADDED APRIL 1995 (ALAN) 16845C USE A BISECTION METHOD 16846C WRITTEN BY--JAMES J. FILLIBEN 16847C STATISTICAL ENGINEERING DIVISION 16848C INFORMATION TECHNOLOGY LABORATORY 16849C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 16850C GAITHERSBURG, MD 20899 16851C PHONE--301-975-2855 16852C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16853C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 16854C LANGUAGE--ANSI FORTRAN (1977) 16855C VERSION NUMBER--95/4 16856C ORIGINAL VERSION--APRIL 1995. 16857C 16858C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16859C 16860 INCLUDE 'DPCOP2.INC' 16861C 16862 DATA PI/3.1415926535898E0/ 16863 DATA EPS /1.0E-10/ 16864 DATA SIG /1.0E-10/ 16865 DATA ZERO /0./ 16866 DATA MAXIT /500/ 16867C 16868C-----START POINT----------------------------------------------------- 16869C 16870C CHECK THE INPUT ARGUMENTS FOR ERRORS 16871C 16872 IF(P.LT.0.0.OR.P.GT.1.0)THEN 16873 WRITE(ICOUT,1) 16874 1 FORMAT('***** ERROR--THE FIRST ARGUMENT TO COSPPF IS OUTSIDE', 16875 1 ' THE ALLOWABLE (0,1) INTERVAL.') 16876 CALL DPWRST('XXX','BUG ') 16877 WRITE(ICOUT,46)P 16878 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 16879 CALL DPWRST('XXX','BUG ') 16880 PPF=0.0 16881 RETURN 16882 ENDIF 16883C 16884 IERR=0 16885 IC = 0 16886 IF(P.LE.0.0)THEN 16887 PPF=-PI 16888 GOTO9999 16889 ELSEIF(P.GE.1.0)THEN 16890 PPF=PI 16891 GOTO9999 16892 ENDIF 16893C 16894 XL = -PI 16895 XR = PI 16896 FXL = -P 16897 FXR = 1.0 - P 16898CCCCC INVALID P EXPLICITLY CHECKED FOR EARLIER. 16899CCCCC IF(FXL*FXR .GT. ZERO)GOTO50 16900C 16901C BISECTION METHOD 16902C 16903 105 CONTINUE 16904 X = (XL+XR)*0.5 16905 CALL COSCDF(X,CDF) 16906 P1=CDF 16907 PPF=X 16908 FCS = P1 - P 16909 IF(FCS*FXL.GT.ZERO)GOTO110 16910 XR = X 16911 FXR = FCS 16912 GOTO115 16913 110 CONTINUE 16914 XL = X 16915 FXL = FCS 16916 115 CONTINUE 16917 XRML = XR - XL 16918 IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999 16919 IC = IC + 1 16920 IF(IC.LE.MAXIT)GOTO105 16921 WRITE(ICOUT,130) 16922 CALL DPWRST('XXX','BUG ') 16923 130 FORMAT('***** ERROR--COSPPF ROUTINE DID NOT CONVERGE. ***') 16924 GOTO9999 16925C 16926 9999 CONTINUE 16927 RETURN 16928 END 16929 SUBROUTINE COSRAN(N,ISEED,X) 16930C 16931C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N 16932C FROM THE COSINE DISTRIBUTION 16933C F(X) = 0.5*EXP(-ABS(X)). 16934C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER 16935C OF RANDOM NUMBERS TO BE 16936C GENERATED. 16937C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR 16938C (OF DIMENSION AT LEAST N) 16939C INTO WHICH THE GENERATED 16940C RANDOM SAMPLE WILL BE PLACED. 16941C OUTPUT--A RANDOM SAMPLE OF SIZE N 16942C FROM THE COSINE DISTRIBUTION 16943C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 16944C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 16945C OF N FOR THIS SUBROUTINE. 16946C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. 16947C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 16948C LANGUAGE--ANSI FORTRAN (1977) 16949C WRITTEN BY--JAMES J. FILLIBEN 16950C STATISTICAL ENGINEERING DIVISION 16951C INFORMATION TECHNOLOGY LABORATORY 16952C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 16953C GAITHERSBURG, MD 20899 16954C PHONE--301-975-2855 16955C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 16956C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 16957C LANGUAGE--ANSI FORTRAN (1977) 16958C VERSION NUMBER--2001/10 16959C ORIGINAL VERSION--OCTOBER 2001. 16960C 16961C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 16962C 16963C--------------------------------------------------------------------- 16964C 16965 DIMENSION X(*) 16966C 16967C--------------------------------------------------------------------- 16968C 16969 INCLUDE 'DPCOP2.INC' 16970C 16971C-----START POINT----------------------------------------------------- 16972C 16973C CHECK THE INPUT ARGUMENTS FOR ERRORS 16974C 16975 IF(N.LT.1)THEN 16976 WRITE(ICOUT, 5) 16977 5 FORMAT('***** ERROR--THE FIRST ARGUMENT TO COSRAN IS ', 16978 1 'NON-POSITIVE.') 16979 CALL DPWRST('XXX','BUG ') 16980 WRITE(ICOUT,47)N 16981 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 16982 CALL DPWRST('XXX','BUG ') 16983 RETURN 16984 ENDIF 16985C 16986C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; 16987C 16988 CALL UNIRAN(N,ISEED,X) 16989C 16990C GENERATE N COSINE RANDOM NUMBERS 16991C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. 16992C 16993 DO100I=1,N 16994 CALL COSPPF(X(I),XTEMP) 16995 X(I)=XTEMP 16996 100 CONTINUE 16997C 16998 RETURN 16999 END 17000 SUBROUTINE COSTRA(Y1,N1,IWRITE,Y2,N2,IBUGA3,IERROR) 17001C 17002C PURPOSE--COMPUTE COSINE TRANSFORM OF A VARIABLE-- 17003C = THE COEFFICIENTS OF THE COSINE TERM 17004C IN THE FINITE FOURIER RESPRESENTATION OF THE DATA IN Y1. 17005C Y2(1) = A0 = MEAN 17006C Y2(2) = A1 17007C Y2(3) = A2 17008C ETC. 17009C NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y2(.) 17010C BEING IDENTICAL TO THE INPUT VECTOR Y1(.). 17011C WRITTEN BY--JAMES J. FILLIBEN 17012C STATISTICAL ENGINEERING DIVISION 17013C INFORMATION TECHNOLOGY LABORATORY 17014C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 17015C GAITHERSBURG, MD 20899 17016C PHONE--301-975-2855 17017C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 17018C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 17019C LANGUAGE--ANSI FORTRAN (1977) 17020C VERSION NUMBER--85/1 17021C ORIGINAL VERSION--DECEMBER 1984. 17022C 17023C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 17024C 17025 CHARACTER*4 IWRITE 17026 CHARACTER*4 IBUGA3 17027 CHARACTER*4 IERROR 17028C 17029 CHARACTER*4 ISUBN1 17030C 17031C-----DOUBLE PRECISION STATEMENTS FOR NON-COMMON VARIABLES------------- 17032C 17033 DOUBLE PRECISION DPI 17034 DOUBLE PRECISION DN1 17035 DOUBLE PRECISION DDEL 17036 DOUBLE PRECISION DI 17037 DOUBLE PRECISION DSUM 17038 DOUBLE PRECISION DK 17039 DOUBLE PRECISION DOMEGA 17040 DOUBLE PRECISION DY1K 17041C 17042C--------------------------------------------------------------------- 17043C 17044 DIMENSION Y1(*) 17045 DIMENSION Y2(*) 17046C 17047C--------------------------------------------------------------------- 17048C 17049 INCLUDE 'DPCOP2.INC' 17050C 17051C-----START POINT----------------------------------------------------- 17052C 17053 ISUBN1='COST' 17054 IERROR='NO' 17055C 17056 N1HALF=(-999) 17057 IMAX=(-999) 17058 IEVODD=(-999) 17059 DDEL=(-999.0D0) 17060 DN1=(-999.0D0) 17061C 17062 DN1=N1 17063C 17064 DPI=3.14159265358979D0 17065C 17066 IF(IBUGA3.EQ.'ON')THEN 17067 WRITE(ICOUT,999) 17068 999 FORMAT(1X) 17069 CALL DPWRST('XXX','BUG ') 17070 WRITE(ICOUT,51) 17071 51 FORMAT('***** AT THE BEGINNING OF COSTRA--') 17072 CALL DPWRST('XXX','BUG ') 17073 WRITE(ICOUT,53)IBUGA3,IWRITE,N1 17074 53 FORMAT('IBUGA3,IWRITE,N1 = ',2(A4,2X),I8) 17075 CALL DPWRST('XXX','BUG ') 17076 DO55I=1,N1 17077 WRITE(ICOUT,56)I,Y1(I) 17078 56 FORMAT('I,Y1(I) = ',I8,G15.7) 17079 CALL DPWRST('XXX','BUG ') 17080 55 CONTINUE 17081 ENDIF 17082C 17083C *********************************** 17084C ** COMPUTE COSINE TRANSFORM. ** 17085C *********************************** 17086C 17087 IF(N1.LT.1)GOTO1100 17088 GOTO1190 17089C 17090 1100 CONTINUE 17091 IERROR='YES' 17092 WRITE(ICOUT,999) 17093 CALL DPWRST('XXX','BUG ') 17094 WRITE(ICOUT,1151) 17095 1151 FORMAT('***** ERROR IN COSTRA--') 17096 CALL DPWRST('XXX','BUG ') 17097 WRITE(ICOUT,1152) 17098 1152 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') 17099 CALL DPWRST('XXX','BUG ') 17100 WRITE(ICOUT,1153) 17101 1153 FORMAT(' IN THE VARIABLE FOR WHICH') 17102 CALL DPWRST('XXX','BUG ') 17103 WRITE(ICOUT,1154) 17104 1154 FORMAT(' THE COSINE TRANSFORM IS TO BE COMPUTED') 17105 CALL DPWRST('XXX','BUG ') 17106 WRITE(ICOUT,1155) 17107 1155 FORMAT(' MUST BE 1 OR LARGER.') 17108 CALL DPWRST('XXX','BUG ') 17109 WRITE(ICOUT,1156) 17110 1156 FORMAT(' SUCH WAS NOT THE CASE HERE.') 17111 CALL DPWRST('XXX','BUG ') 17112 WRITE(ICOUT,1157)N1 17113 1157 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 17114 1'.') 17115 CALL DPWRST('XXX','BUG ') 17116 GOTO9000 17117C 17118 1190 CONTINUE 17119C 17120 N1HALF=N1/2 17121 N1HALP=N1HALF+1 17122 IMAX=N1HALP 17123 IEVODD=N1-2*(N1/2) 17124 DDEL=(DN1+1.0D0)/2.0D0 17125 IF(IEVODD.EQ.0)DDEL=(DN1+2.0D0)/2.0D0 17126C 17127 J=0 17128 J=J+1 17129 DSUM=0.0 17130 DO1205K=1,N1 17131 DY1K=Y1(K) 17132 DSUM=DSUM+DY1K 17133 1205 CONTINUE 17134 COEF=DSUM/DN1 17135 Y2(J)=COEF 17136C 17137 DO1210IP1=2,IMAX 17138 J=J+1 17139 I=IP1-1 17140 DI=I 17141CCCCC FREQI=DI/DN1 17142 DSUM=0.0D0 17143C 17144 DO1220K=1,N1 17145 DK=K 17146 DOMEGA=2.0*DPI*(DI/DN1) 17147 DY1K=Y1(K) 17148 DSUM=DSUM+DY1K*DCOS(DOMEGA*(DK-DDEL)) 17149 1220 CONTINUE 17150 COEF=DSUM/DN1 17151 IF(IBUGA3.EQ.'ON')WRITE(ICOUT,1221)J,I,DN1,DI,COEF 17152 1221 FORMAT('J,I,DN1,DI,COEF = ',I8,I8,2D15.7,E15.7) 17153 IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') 17154C 17155 Y2(J)=COEF 17156C 17157 1210 CONTINUE 17158C 17159 N2=J 17160C 17161C ***************** 17162C ** STEP 90-- ** 17163C ** EXIT. ** 17164C ***************** 17165C 17166 9000 CONTINUE 17167C 17168 IF(IBUGA3.EQ.'OFF')GOTO9090 17169 WRITE(ICOUT,999) 17170 CALL DPWRST('XXX','BUG ') 17171 WRITE(ICOUT,9011) 17172 9011 FORMAT('***** AT THE END OF COSTRA--') 17173 CALL DPWRST('XXX','BUG ') 17174 WRITE(ICOUT,9012)IBUGA3,IERROR 17175 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 17176 CALL DPWRST('XXX','BUG ') 17177 WRITE(ICOUT,9013)N1,N2,N1HALF,IMAX,IEVODD,DDEL 17178 9013 FORMAT('N1,N2,N1HALF,IMAX,IEVODD,DDEL = ',5I8,D15.7) 17179 CALL DPWRST('XXX','BUG ') 17180 DO9015I=1,N1 17181 WRITE(ICOUT,9016)I,Y1(I),Y2(I) 17182 9016 FORMAT('I,Y1(I),Y2(I) = ',I8,2E15.7) 17183 CALL DPWRST('XXX','BUG ') 17184 9015 CONTINUE 17185 9090 CONTINUE 17186C 17187 RETURN 17188 END 17189 SUBROUTINE COV(X,Y,N,IWRITE,XYCOV,IBUGA3,IERROR) 17190C 17191C PURPOSE--THIS SUBROUTINE COMPUTES THE 17192C SAMPLE COVARIANCE COEFFICIENT 17193C BETWEEN THE 2 SETS OF DATA IN THE INPUT VECTORS X AND Y. 17194C THE SAMPLE COVARIANCE COEFFICIENT WILL BE A SINGLE 17195C PRECISION VALUE CALCULATED AS THE 17196C SUM OF CROSS PRODUCTS DIVIDED BY (N-1). 17197C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 17198C (UNSORTED) OBSERVATIONS 17199C WHICH CONSTITUTE THE FIRST SET 17200C OF DATA. 17201C --Y = THE SINGLE PRECISION VECTOR OF 17202C (UNSORTED) OBSERVATIONS 17203C WHICH CONSTITUTE THE SECOND SET 17204C OF DATA. 17205C --N = THE INTEGER NUMBER OF OBSERVATIONS 17206C IN THE VECTOR X, OR EQUIVALENTLY, 17207C THE INTEGER NUMBER OF OBSERVATIONS 17208C IN THE VECTOR Y. 17209C OUTPUT ARGUMENTS--XYCOV = THE SINGLE PRECISION VALUE OF THE 17210C COMPUTED SAMPLE COVARIANCE COEFFICIENT 17211C BETWEEN THE 2 SETS OF DATA 17212C IN THE INPUT VECTORS X AND Y. 17213C THIS SINGLE PRECISION VALUE 17214C WILL BE BETWEEN -1.0 AND 1.0 17215C (INCLUSIVELY). 17216C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE 17217C SAMPLE COVARIANCE COEFFICIENT BETWEEN THE 2 SETS 17218C OF DATA IN THE INPUT VECTORS X AND Y. 17219C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 17220C OF N FOR THIS SUBROUTINE. 17221C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 17222C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 17223C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 17224C LANGUAGE--ANSI FORTRAN (1977) 17225C REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF 17226C STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 235-236. 17227C --KENDALL AND STUART, THE ADVANCED THEORY OF 17228C STATISTICS, VOLUME 2, EDITION 1, 1961, PAGES 292-293. 17229C --SNEDECOR AND COCHRAN, STATISTICAL METHODS, 17230C EDITION 6, 1967, PAGES 172-198. 17231C WRITTEN BY--JAMES J. FILLIBEN 17232C STATISTICAL ENGINEERING DIVISION 17233C INFORMATION TECHNOLOGY LABORATORY 17234C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 17235C GAITHERSBURG, MD 20899 17236C PHONE--301-975-2855 17237C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 17238C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 17239C LANGUAGE--ANSI FORTRAN (1966) 17240C VERSION NUMBER--82/7 17241C ORIGINAL VERSION--APRIL 1979. 17242C UPDATED --JUNE 1979. 17243C UPDATED --JULY 1979. 17244C UPDATED --AUGUST 1981. 17245C UPDATED --MAY 1982. 17246C 17247C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 17248C 17249 CHARACTER*4 IWRITE 17250 CHARACTER*4 IBUGA3 17251 CHARACTER*4 IERROR 17252C 17253 CHARACTER*4 ISUBN1 17254 CHARACTER*4 ISUBN2 17255C 17256C--------------------------------------------------------------------- 17257C 17258 DOUBLE PRECISION DN 17259 DOUBLE PRECISION DX1 17260 DOUBLE PRECISION DX2 17261 DOUBLE PRECISION DSUM1 17262 DOUBLE PRECISION DSUM2 17263 DOUBLE PRECISION DSUM12 17264 DOUBLE PRECISION DMEAN1 17265 DOUBLE PRECISION DMEAN2 17266C 17267 DIMENSION X(*) 17268 DIMENSION Y(*) 17269C 17270C--------------------------------------------------------------------- 17271C 17272 INCLUDE 'DPCOP2.INC' 17273C 17274C-----START POINT----------------------------------------------------- 17275C 17276 ISUBN1='COV ' 17277 ISUBN2=' ' 17278C 17279 IERROR='NO' 17280C 17281 DN=0.0D0 17282 DMEAN1=0.0D0 17283 DMEAN2=0.0D0 17284 DSUM12=0.0D0 17285C 17286 IF(IBUGA3.EQ.'OFF')GOTO90 17287 WRITE(ICOUT,999) 17288 999 FORMAT(1X) 17289 CALL DPWRST('XXX','BUG ') 17290 WRITE(ICOUT,51) 17291 51 FORMAT('***** AT THE BEGINNING OF COV--') 17292 CALL DPWRST('XXX','BUG ') 17293 WRITE(ICOUT,52)IBUGA3 17294 52 FORMAT('IBUGA3 = ',A4) 17295 CALL DPWRST('XXX','BUG ') 17296 WRITE(ICOUT,53)N 17297 53 FORMAT('N = ',I8) 17298 CALL DPWRST('XXX','BUG ') 17299 DO55I=1,N 17300 WRITE(ICOUT,56)I,X(I),Y(I) 17301 56 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) 17302 CALL DPWRST('XXX','BUG ') 17303 55 CONTINUE 17304 90 CONTINUE 17305C 17306C ******************************************* 17307C ** COMPUTE COVARIANCE COEFFICIENT ** 17308C ******************************************* 17309C 17310C ******************************************** 17311C ** STEP 1-- ** 17312C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 17313C ******************************************** 17314C 17315 AN=N 17316C 17317 IF(N.GE.1)GOTO119 17318 IERROR='YES' 17319 WRITE(ICOUT,999) 17320 CALL DPWRST('XXX','BUG ') 17321 WRITE(ICOUT,111) 17322 111 FORMAT('***** ERROR IN COV--') 17323 CALL DPWRST('XXX','BUG ') 17324 WRITE(ICOUT,112) 17325 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') 17326 CALL DPWRST('XXX','BUG ') 17327 WRITE(ICOUT,113) 17328 113 FORMAT(' IN THE VARIABLE FOR WHICH') 17329 CALL DPWRST('XXX','BUG ') 17330 WRITE(ICOUT,114) 17331 114 FORMAT(' THE COVARIANCE COEFFICIENT IS TO BE') 17332 CALL DPWRST('XXX','BUG ') 17333 WRITE(ICOUT,115) 17334 115 FORMAT(' COMPUTED, MUST BE 1 OR LARGER.') 17335 CALL DPWRST('XXX','BUG ') 17336 WRITE(ICOUT,116) 17337 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') 17338 CALL DPWRST('XXX','BUG ') 17339 WRITE(ICOUT,117)N 17340 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 17341 1'.') 17342 CALL DPWRST('XXX','BUG ') 17343 GOTO9000 17344 119 CONTINUE 17345C 17346 IF(N.EQ.1)GOTO120 17347 GOTO129 17348 120 CONTINUE 17349 WRITE(ICOUT,999) 17350 CALL DPWRST('XXX','BUG ') 17351 WRITE(ICOUT,121) 17352 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN COV--', 17353 1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 1') 17354 CALL DPWRST('XXX','BUG ') 17355 XYCOV=0.0 17356 GOTO9000 17357 129 CONTINUE 17358C 17359 HOLD=X(1) 17360 DO135I=2,N 17361 IF(X(I).NE.HOLD)GOTO139 17362 135 CONTINUE 17363 WRITE(ICOUT,999) 17364 CALL DPWRST('XXX','BUG ') 17365 WRITE(ICOUT,136)HOLD 17366 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN COV--', 17367 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) 17368 CALL DPWRST('XXX','BUG ') 17369 XYCOV=0.0 17370 GOTO9000 17371 139 CONTINUE 17372C 17373 HOLD=Y(1) 17374 DO145I=2,N 17375 IF(Y(I).NE.HOLD)GOTO149 17376 145 CONTINUE 17377 WRITE(ICOUT,999) 17378 CALL DPWRST('XXX','BUG ') 17379 WRITE(ICOUT,146)HOLD 17380 146 FORMAT('***** NON-FATAL DIAGNOSTIC IN COV--', 17381 1'THE SECOND INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) 17382 CALL DPWRST('XXX','BUG ') 17383 XYCOV=0.0 17384 GOTO9000 17385 149 CONTINUE 17386C 17387C ************************************************ 17388C ** STEP 2-- ** 17389C ** COMPUTE THE COVARIANCE COEFFICIENT. ** 17390C ************************************************ 17391C 17392 DN=N 17393 DSUM1=0.0D0 17394 DSUM2=0.0D0 17395 DO200I=1,N 17396 DX1=X(I) 17397 DX2=Y(I) 17398 DSUM1=DSUM1+DX1 17399 DSUM2=DSUM2+DX2 17400 200 CONTINUE 17401 DMEAN1=DSUM1/DN 17402 DMEAN2=DSUM2/DN 17403C 17404 DSUM12=0.0D0 17405 DO300I=1,N 17406 DX1=X(I) 17407 DX2=Y(I) 17408 DSUM12=DSUM12+(DX1-DMEAN1)*(DX2-DMEAN2) 17409 300 CONTINUE 17410 XYCOV=DSUM12/(DN-1.0D0) 17411C 17412C ******************************* 17413C ** STEP 3-- ** 17414C ** WRITE OUT A LINE ** 17415C ** OF SUMMARY INFORMATION. ** 17416C ******************************* 17417C 17418 IF(IFEEDB.EQ.'OFF')GOTO890 17419 IF(IWRITE.EQ.'OFF')GOTO890 17420 WRITE(ICOUT,999) 17421 CALL DPWRST('XXX','BUG ') 17422 WRITE(ICOUT,811)N,XYCOV 17423 811 FORMAT('THE COVARIANCE COEFFICIENT OF THE ',I8, 17424 1' OBSERVATIONS = ',E15.7) 17425 CALL DPWRST('XXX','BUG ') 17426 890 CONTINUE 17427C 17428C ***************** 17429C ** STEP 90-- ** 17430C ** EXIT. ** 17431C ***************** 17432C 17433 9000 CONTINUE 17434 IF(IBUGA3.EQ.'OFF')GOTO9090 17435 WRITE(ICOUT,999) 17436 CALL DPWRST('XXX','BUG ') 17437 WRITE(ICOUT,9011) 17438 9011 FORMAT('***** AT THE END OF COV--') 17439 CALL DPWRST('XXX','BUG ') 17440 WRITE(ICOUT,9012)IBUGA3,IERROR 17441 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 17442 CALL DPWRST('XXX','BUG ') 17443 WRITE(ICOUT,9013)N 17444 9013 FORMAT('N = ',I8) 17445 CALL DPWRST('XXX','BUG ') 17446 WRITE(ICOUT,9014)DN,DMEAN1,DMEAN2,DSUM12 17447 9014 FORMAT('DN,DMEAN1,DMEAN2,DSUM12 = ',4D15.7) 17448 CALL DPWRST('XXX','BUG ') 17449 WRITE(ICOUT,9015)XYCOV 17450 9015 FORMAT('XYCOV = ',E15.7) 17451 CALL DPWRST('XXX','BUG ') 17452 9090 CONTINUE 17453C 17454 RETURN 17455 END 17456 SUBROUTINE COVMAT(YM1,YM9,DMEAN,MAXROM,NR,NC,MAXVAR) 17457C 17458C PURPOSE--THIS SUBROUTINE COMPUTES THE VARIANCE-COVARIANCE 17459C MATRIX. THIS IS A UTILITY ROUTINE, ERROR CHECKING 17460C PERFORMED BY CALLING ROUTINES. 17461C INPUT ARGUMENTS--YM1 = THE SINGLE PRECISION MATRIX OF 17462C OBSERVATIONS 17463C --NR = THE INTEGER NUMBER OF ROWS 17464C --NC = THE INTEGER NUMBER OF COLUMNS 17465C --MAXROM = LEADING DIMENSION OF XMAT, COVMAT 17466C OUTPUT ARGUMENTS--YM9 = THE SINGLE PRECISION MATRIX WHICH 17467C WILL CONTAIN THE COVARIANCE MATRIX 17468C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE 17469C SAMPLE VARIANCE-COVARIANCE MATRIX. 17470C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 17471C OF N FOR THIS SUBROUTINE. 17472C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 17473C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 17474C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 17475C LANGUAGE--ANSI FORTRAN (1977) 17476C WRITTEN BY--JAMES J. FILLIBEN 17477C STATISTICAL ENGINEERING DIVISION 17478C INFORMATION TECHNOLOGY LABORATORY 17479C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 17480C GAITHERSBURG, MD 20899 17481C PHONE--301-975-2855 17482C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 17483C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 17484C LANGUAGE--ANSI FORTRAN (1966) 17485C VERSION NUMBER--2003/2 17486C ORIGINAL VERSION--FEBRUARY 2003. 17487C 17488C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 17489C 17490 DOUBLE PRECISION DSUM1 17491 DOUBLE PRECISION DYM1 17492 DOUBLE PRECISION DDENOM 17493 DOUBLE PRECISION DNR 17494 DOUBLE PRECISION DDEL1 17495 DOUBLE PRECISION DDEL2 17496 DOUBLE PRECISION DCOV 17497 DOUBLE PRECISION DMEAN(*) 17498C 17499 DIMENSION YM1(MAXROM,NC) 17500 DIMENSION YM9(MAXVAR,MAXVAR) 17501C 17502C--------------------------------------------------------------------- 17503C 17504 INCLUDE 'DPCOP2.INC' 17505C 17506C-----START POINT----------------------------------------------------- 17507C 17508 DNR=DBLE(NR) 17509C 17510 DO5111J=1,NC 17511 DSUM1=0.0D0 17512 DO5112I=1,NR 17513 DYM1=YM1(I,J) 17514 DSUM1=DSUM1+DYM1 17515 5112 CONTINUE 17516 DMEAN(J)=-9999.0D0 17517 DDENOM=DNR 17518 IF(DDENOM.NE.0.0D0)DMEAN(J)=REAL(DSUM1/DDENOM) 17519 5111 CONTINUE 17520C 17521 DO5121J=1,NC 17522 DO5122K=J,NC 17523 DSUM1=0.0D0 17524 DO5123I=1,NR 17525 DYM1=YM1(I,J) 17526 DYM2=YM1(I,K) 17527 DDEL1=DYM1-DMEAN(J) 17528 DDEL2=DYM2-DMEAN(K) 17529 DSUM1=DSUM1+DDEL1*DDEL2 17530 5123 CONTINUE 17531 DCOV=-9999.0D0 17532 DDENOM=DNR-1.0D0 17533 IF(DDENOM.NE.0.0D0)DCOV=DSUM1/DDENOM 17534 YM9(J,K)=DCOV 17535 YM9(K,J)=DCOV 17536 5122 CONTINUE 17537 5121 CONTINUE 17538C 17539C ***************** 17540C ** STEP 90-- ** 17541C ** EXIT. ** 17542C ***************** 17543C 17544 RETURN 17545 END 17546 SUBROUTINE CP(X,N,ENGLSL,ENGUSL,IWRITE,XCP,XLCL,XUCL, 17547 1 IBUGA3,IERROR) 17548C 17549C PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE CP (PROCESS 17550C CAPABILITY INDEX) OF THE DATA IN THE INPUT VECTOR X. 17551C CP = (ENGUSL - ENGLSL) / 6*S 17552C NOTE--IF THE TARGET VALUE IS MIDWAY BETWEEN ENGUSL AND ENGLSL, 17553C THEN AN ALTERNATIVE EQUIVALENT DEFINITION FOR CP IS 17554C CP = (ENGUSL-TARGET) / 3*S 17555C NOTE--CP IS A MEASURE OF PROCESS PRECISION-- 17556C IT CONTAINS NO BIAS INFORMATION. 17557C NOTE--THE CP INDEX IS A MEASURE WHICH TAKES ON THE VALUES 0 TO 17558C INFINITY. A GOOD PROCESS YIELDS VALUES OF CP WHICH ARE 17559C LARGE (ABOVE 2); VALUES OF CP FROM 0.5 TO 1.0 ARE TYPICAL. 17560C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 17561C (UNSORTED OR SORTED) OBSERVATIONS. 17562C --N = THE INTEGER NUMBER OF OBSERVATIONS 17563C IN THE VECTOR X. 17564C --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT 17565C --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT 17566C OUTPUT ARGUMENTS--CP = THE SINGLE PRECISION VALUE OF THE 17567C COMPUTED SAMPLE CP 17568C --XLCL = LOWER 95% CONFIDENCE INTERVAL 17569C --XUCL = UPPER 95% CONFIDENCE INTERVAL 17570C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE 17571C SAMPLE CP INDEX 17572C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 17573C OF N FOR THIS SUBROUTINE. 17574C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 17575C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. 17576C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 17577C LANGUAGE--ANSI FORTRAN (1977) 17578C REFERENCES--R&M 2000 AIRFORCE MANUAL 17579C WRITTEN BY--JAMES J. FILLIBEN 17580C STATISTICAL ENGINEERING DIVISION 17581C INFORMATION TECHNOLOGY LABORATORY 17582C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 17583C GAITHERSBURG, MD 20899 17584C PHONE--301-975-2855 17585C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 17586C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 17587C LANGUAGE--ANSI FORTRAN (1977) 17588C VERSION NUMBER--89.5 17589C ORIGINAL VERSION--MAY 1989. 17590C UPDATED --SEPTEMBER 1990. REVERSE INPUT ARGS 17591C UPDATED --APRIL 2001. ADD LOWER AND UPPER 95% 17592C CONFIDENCE INTERVAL. 17593C 17594C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 17595C 17596 CHARACTER*4 IWRITE 17597 CHARACTER*4 IBUGA3 17598 CHARACTER*4 IERROR 17599C 17600 CHARACTER*4 ISUBN1 17601 CHARACTER*4 ISUBN2 17602C 17603C--------------------------------------------------------------------- 17604C 17605 DOUBLE PRECISION DN 17606 DOUBLE PRECISION DX 17607 DOUBLE PRECISION DSUM 17608 DOUBLE PRECISION DMEAN 17609 DOUBLE PRECISION DVAR 17610 DOUBLE PRECISION DSD 17611C 17612 DOUBLE PRECISION DUSL 17613 DOUBLE PRECISION DLSL 17614 DOUBLE PRECISION DNUM 17615 DOUBLE PRECISION DDEN 17616 DOUBLE PRECISION DCP 17617C 17618 DIMENSION X(*) 17619C 17620C--------------------------------------------------------------------- 17621C 17622 INCLUDE 'DPCOP2.INC' 17623C 17624C-----START POINT----------------------------------------------------- 17625C 17626 ISUBN1='CP ' 17627 ISUBN2=' ' 17628 IERROR='NO' 17629C 17630 XCP=0.0 17631 DMEAN=0.0D0 17632C 17633 IF(IBUGA3.EQ.'ON')THEN 17634 WRITE(ICOUT,999) 17635 999 FORMAT(1X) 17636 CALL DPWRST('XXX','BUG ') 17637 WRITE(ICOUT,51) 17638 51 FORMAT('***** AT THE BEGINNING OF CP--') 17639 CALL DPWRST('XXX','BUG ') 17640 WRITE(ICOUT,52)IBUGA3,N,ENGUSL,ENGLSL 17641 52 FORMAT('IBUGA3,N,ENGUSL,ENGLSL = ',A4,2X,I8,2G15.7) 17642 CALL DPWRST('XXX','BUG ') 17643 DO55I=1,N 17644 WRITE(ICOUT,56)I,X(I) 17645 56 FORMAT('I,X(I) = ',I8,G15.7) 17646 CALL DPWRST('XXX','BUG ') 17647 55 CONTINUE 17648 ENDIF 17649C 17650C ******************************************** 17651C ** COMPUTE PROCESS CAPABILITY INDEX CP ** 17652C ******************************************** 17653C 17654C ******************************************** 17655C ** STEP 1-- ** 17656C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 17657C ******************************************** 17658C 17659 AN=N 17660C 17661 IF(N.LT.1)THEN 17662 IERROR='YES' 17663 WRITE(ICOUT,999) 17664 CALL DPWRST('XXX','BUG ') 17665 WRITE(ICOUT,111) 17666 111 FORMAT('***** ERROR IN CP--') 17667 CALL DPWRST('XXX','BUG ') 17668 WRITE(ICOUT,112) 17669 112 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ', 17670 1 'VARIABLE IS NON-POSITIVE.') 17671 CALL DPWRST('XXX','BUG ') 17672 WRITE(ICOUT,117)N 17673 117 FORMAT(' THE NUMBER OF OBSERVATIONS = ',I8,'.') 17674 CALL DPWRST('XXX','BUG ') 17675 GOTO9000 17676 ELSEIF(N.EQ.1)THEN 17677 GOTO9000 17678 ENDIF 17679C 17680 HOLD=X(1) 17681 DO135I=2,N 17682 IF(X(I).NE.HOLD)GOTO139 17683 135 CONTINUE 17684 GOTO9000 17685 139 CONTINUE 17686C 17687C *************************************** 17688C ** STEP 2-- ** 17689C ** COMPUTE THE STANDARD DEVIATION. ** 17690C *************************************** 17691C 17692 DN=N 17693 DSUM=0.0D0 17694 DO200I=1,N 17695 DX=X(I) 17696 DSUM=DSUM+DX 17697 200 CONTINUE 17698 DMEAN=DSUM/DN 17699C 17700 DSUM=0.0D0 17701 DO300I=1,N 17702 DX=X(I) 17703 DSUM=DSUM+(DX-DMEAN)**2 17704 300 CONTINUE 17705 DVAR=DSUM/(DN-1.0D0) 17706 DSD=0.0D0 17707 IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR) 17708 XSD=DSD 17709C 17710C ************************************************** 17711C ** STEP 3-- ** 17712C ** COMPUTE THE CP RATIO ** 17713C ************************************************** 17714C 17715 DUSL=ENGUSL 17716 DLSL=ENGLSL 17717C 17718 DNUM=DUSL-DLSL 17719 IF(DNUM.LE.0.0D0)DNUM=0.0D0 17720C 17721 DDEN=6.0*DSD 17722C 17723 DCP=0.0 17724 IF(DDEN.GT.0.0D0)DCP=DNUM/DDEN 17725 XCP=DCP 17726C 17727 XLCL=0.0 17728 XUCL=0.0 17729 AN=REAL(N) 17730 NV=N-1 17731 AV=REAL(NV) 17732 P=0.975 17733 CALL CHSPPF(P,NV,PPF) 17734 IF((PPF/AV).GT.0.0)XUCL=XCP*SQRT(PPF/AV) 17735 P=0.025 17736 CALL CHSPPF(P,NV,PPF) 17737 IF((PPF/AV).GT.0.0)XLCL=XCP*SQRT(PPF/AV) 17738C 17739C ******************************* 17740C ** STEP 3-- ** 17741C ** WRITE OUT A LINE ** 17742C ** OF SUMMARY INFORMATION. ** 17743C ******************************* 17744C 17745 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 17746 WRITE(ICOUT,999) 17747 CALL DPWRST('XXX','BUG ') 17748 WRITE(ICOUT,811)N,XCP 17749 811 FORMAT('THE CP OF THE ',I8,' OBSERVATIONS = ',G15.7) 17750 CALL DPWRST('XXX','BUG ') 17751 ENDIF 17752C 17753C ***************** 17754C ** STEP 90-- ** 17755C ** EXIT. ** 17756C ***************** 17757C 17758 9000 CONTINUE 17759 IF(IBUGA3.EQ.'ON')THEN 17760 WRITE(ICOUT,999) 17761 CALL DPWRST('XXX','BUG ') 17762 WRITE(ICOUT,9011) 17763 9011 FORMAT('***** AT THE END OF CP--') 17764 CALL DPWRST('XXX','BUG ') 17765 WRITE(ICOUT,9012)IBUGA3,IERROR 17766 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 17767 CALL DPWRST('XXX','BUG ') 17768 WRITE(ICOUT,9014)DMEAN,DSD,DUSL,DLSL 17769 9014 FORMAT('DMEAN,DSD,DUSL,DLSL = ',4G15.7) 17770 CALL DPWRST('XXX','BUG ') 17771 WRITE(ICOUT,9017)DNUM,DDEN,DCP,XCP 17772 9017 FORMAT('DNUM,DDEN,DCP,XCP = ',4G15.7) 17773 CALL DPWRST('XXX','BUG ') 17774 ENDIF 17775C 17776 RETURN 17777 END 17778 SUBROUTINE CPEVL(N,M,A,Z,C,B,KBD) 17779C***BEGIN PROLOGUE CPEVL 17780C***REFER TO CPZERO 17781C 17782C Evaluate a complex polynomial and its derivatives. 17783C Optionally compute error bounds for these values. 17784C 17785C INPUT... 17786C N = Degree of the polynomial 17787C M = Number of derivatives to be calculated, 17788C M=0 evaluates only the function 17789C M=1 evaluates the function and first derivative, etc. 17790C if M .GT. N+1 function and all N derivatives will be 17791C calculated. 17792C A = Complex vector containing the N+1 coefficients of polynomial 17793C A(I)= coefficient of Z**(N+1-I) 17794C Z = Complex point at which the evaluation is to take place. 17795C C = Array of 2(M+1) words into which values are placed. 17796C B = Array of 2(M+1) words only needed if bounds are to be 17797C calculated. It is not used otherwise. 17798C KBD = A logical variable, e.g. .TRUE. or .FALSE. which is 17799C to be set .TRUE. if bounds are to be computed. 17800C 17801C OUTPUT... 17802C C = C(I+1) contains the complex value of the I-th 17803C derivative at Z, I=0,...,M 17804C B = B(I) contains the bounds on the real and imaginary parts 17805C of C(I) if they were requested. 17806C***ROUTINES CALLED I1MACH 17807C***END PROLOGUE CPEVL 17808C 17809 COMPLEX A(1),C(1),Z,CI,CIM1,B(1),BI,BIM1,T,ZA,Q 17810 LOGICAL KBD 17811C 17812 INCLUDE 'DPCOMC.INC' 17813C 17814 DATA NBITS /0/ 17815 ZA(Q)=CMPLX(ABS(REAL(Q)),ABS(AIMAG(Q))) 17816C***FIRST EXECUTABLE STATEMENT CPEVL 17817 IF ( NBITS .EQ. 0 ) NBITS = I1MACH (11) 17818 D1=2.**(1-NBITS) 17819 NP1=N+1 17820 DO 1 J=1,NP1 17821 CI=0.0 17822 CIM1=A(J) 17823 BI=0.0 17824 BIM1=0.0 17825 MINI=MIN0(M+1,N+2-J) 17826 DO 11 I=1,MINI 17827 IF(J .NE. 1) CI=C(I) 17828 IF(I .NE. 1) CIM1=C(I-1) 17829 C(I)=CIM1+Z*CI 17830 IF(.NOT. KBD) GO TO 1 17831 IF(J .NE. 1) BI=B(I) 17832 IF(I .NE. 1) BIM1=B(I-1) 17833 T=BI+(3.*D1+4.*D1*D1)*ZA(CI) 17834 R=REAL(ZA(Z)*CMPLX(REAL(T),-AIMAG(T))) 17835 S=AIMAG(ZA(Z)*T) 17836 B(I)=(1.+8.*D1)*(BIM1+D1*ZA(CIM1)+CMPLX(R,S)) 17837 IF(J .EQ. 1) B(I)=0.0 17838 11 CONTINUE 17839 1 CONTINUE 17840 RETURN 17841 END 17842 SUBROUTINE CPK(X,N,ENGLSL,ENGUSL,IWRITE,XCPK,XLCL,XUCL, 17843 1 IBUGA3,IERROR) 17844C 17845C PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE CPK (PROCESS 17846C CAPABILITY INDEX) OF THE DATA IN THE INPUT VECTOR X. 17847C 17848C CPK = MIN(USL-MEAN,MEAN-LSL)/(3*S) 17849C 17850C NOTE--CPK IS A MEASURE OF PROCESS ACCURACY-- 17851C COMBINING BOTH PRECISION AND UNBIASEDNESS. 17852C NOTE--THE CPK INDEX IS A MEASURE WHICH TAKES ON THE VALUES 0 TO 17853C INFINITY. A GOOD PROCESS YIELDS VALUES OF CPK WHICH ARE 17854C LARGE (ABOVE 2); VALUES OF CPK FROM 0.5 TO 1.0 ARE TYPICAL. 17855C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 17856C (UNSORTED OR SORTED) OBSERVATIONS. 17857C --N = THE INTEGER NUMBER OF OBSERVATIONS 17858C IN THE VECTOR X. 17859C --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT 17860C --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT 17861C OUTPUT ARGUMENTS--CPK = THE SINGLE PRECISION VALUE OF THE 17862C COMPUTED SAMPLE CPK 17863C --XLCL = LOWER 95% CONFIDENCE LEVEL 17864C --XUCL = UPPER 95% CONFIDENCE LEVEL 17865C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE 17866C SAMPLE CPK INDEX 17867C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 17868C OF N FOR THIS SUBROUTINE. 17869C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 17870C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. 17871C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 17872C LANGUAGE--ANSI FORTRAN (1977) 17873C REFERENCES--R&M 2000 AIR FORCE MANUAL 17874C --CHEN AND DING (2001), "A NEW PROCESS CAPABILITY 17875C INDEX FOR NON-NORMAL DISTRIBUTIONS", INTERNATIONAL 17876C JOURNAL OF QUALITY & RELIABILITY MANAGEMENT, 17877C VOL. 18, NO. 7, PP. 762-770. 17878C WRITTEN BY--JAMES J. FILLIBEN 17879C STATISTICAL ENGINEERING DIVISION 17880C INFORMATION TECHNOLOGY LABORATORY 17881C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 17882C GAITHERSBURG, MD 20899 17883C PHONE--301-975-2855 17884C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 17885C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 17886C LANGUAGE--ANSI FORTRAN (1977) 17887C VERSION NUMBER--89.5 17888C ORIGINAL VERSION--MAY 1989. 17889C UPDATED --SEPTEMBER 1990. REVERSE INPUT ARGS 17890C UPDATED --APRIL 2001. 95% CONFIDENCE LIMITS 17891C 17892C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 17893C 17894 CHARACTER*4 IWRITE 17895 CHARACTER*4 IBUGA3 17896 CHARACTER*4 IERROR 17897C 17898 CHARACTER*4 ISUBN1 17899 CHARACTER*4 ISUBN2 17900C 17901C--------------------------------------------------------------------- 17902C 17903 DOUBLE PRECISION DN 17904 DOUBLE PRECISION DX 17905 DOUBLE PRECISION DSUM 17906 DOUBLE PRECISION DMEAN 17907 DOUBLE PRECISION DVAR 17908 DOUBLE PRECISION DSD 17909C 17910 DOUBLE PRECISION DUSL 17911 DOUBLE PRECISION DLSL 17912 DOUBLE PRECISION DUPPER 17913 DOUBLE PRECISION DLOWER 17914 DOUBLE PRECISION DNUM 17915 DOUBLE PRECISION DDEN 17916 DOUBLE PRECISION DCPK 17917C 17918 DIMENSION X(*) 17919C 17920C--------------------------------------------------------------------- 17921C 17922 INCLUDE 'DPCOP2.INC' 17923C 17924C-----START POINT----------------------------------------------------- 17925C 17926 ISUBN1='CPK ' 17927 ISUBN2=' ' 17928 IERROR='NO' 17929C 17930 XCPK=0.0 17931C 17932 IF(IBUGA3.EQ.'ON')THEN 17933 WRITE(ICOUT,999) 17934 999 FORMAT(1X) 17935 CALL DPWRST('XXX','BUG ') 17936 WRITE(ICOUT,51) 17937 51 FORMAT('***** AT THE BEGINNING OF CPK--') 17938 CALL DPWRST('XXX','BUG ') 17939 WRITE(ICOUT,52)IBUGA3,N,ENGUSL,ENGLSL 17940 52 FORMAT('IBUGA3,N,ENGUSL,ENGLSL = ',A4,2X,I8,2G15.7) 17941 CALL DPWRST('XXX','BUG ') 17942 DO55I=1,N 17943 WRITE(ICOUT,56)I,X(I) 17944 56 FORMAT('I,X(I) = ',I8,G15.7) 17945 CALL DPWRST('XXX','BUG ') 17946 55 CONTINUE 17947 ENDIF 17948C 17949C ******************************************** 17950C ** COMPUTE PROCESS CAPABILITY INDEX CPK ** 17951C ******************************************** 17952C 17953C ******************************************** 17954C ** STEP 1-- ** 17955C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 17956C ******************************************** 17957C 17958 AN=N 17959C 17960 IF(N.LT.1)THEN 17961 IERROR='YES' 17962 WRITE(ICOUT,999) 17963 CALL DPWRST('XXX','BUG ') 17964 WRITE(ICOUT,111) 17965 111 FORMAT('***** ERROR IN CPK--') 17966 CALL DPWRST('XXX','BUG ') 17967 WRITE(ICOUT,112) 17968 112 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ', 17969 1 'VARIABLE IS NON-POSITIVE.') 17970 CALL DPWRST('XXX','BUG ') 17971 WRITE(ICOUT,117)N 17972 117 FORMAT(' THE NUMBER OF OBSERVATIONS = ',I8,'.') 17973 CALL DPWRST('XXX','BUG ') 17974 GOTO9000 17975 ELSEIF(N.EQ.1)THEN 17976 GOTO9000 17977 ENDIF 17978C 17979 HOLD=X(1) 17980 DO135I=2,N 17981 IF(X(I).NE.HOLD)GOTO139 17982 135 CONTINUE 17983 GOTO9000 17984 139 CONTINUE 17985C 17986C *************************************** 17987C ** STEP 2-- ** 17988C ** COMPUTE THE STANDARD DEVIATION. ** 17989C *************************************** 17990C 17991 DN=N 17992 DSUM=0.0D0 17993 DO200I=1,N 17994 DX=X(I) 17995 DSUM=DSUM+DX 17996 200 CONTINUE 17997 DMEAN=DSUM/DN 17998C 17999 DSUM=0.0D0 18000 DO300I=1,N 18001 DX=X(I) 18002 DSUM=DSUM+(DX-DMEAN)**2 18003 300 CONTINUE 18004 DVAR=DSUM/(DN-1.0D0) 18005 DSD=0.0D0 18006 IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR) 18007 XSD=DSD 18008C 18009C ************************************************** 18010C ** STEP 3-- ** 18011C ** COMPUTE THE CPK RATIO ** 18012C ************************************************** 18013C 18014 DUSL=ENGUSL 18015 DLSL=ENGLSL 18016C 18017 DUPPER=DUSL-DMEAN 18018 DLOWER=DMEAN-DLSL 18019C 18020 DNUM=DUPPER 18021 IF(DLOWER.LT.DUPPER)DNUM=DLOWER 18022 IF(DNUM.LE.0.0D0)DNUM=0.0D0 18023C 18024 DDEN=3.0*DSD 18025C 18026 DCPK=0.0 18027 IF(DDEN.GT.0.0D0)DCPK=DNUM/DDEN 18028 XCPK=DCPK 18029C 18030 AN=REAL(N) 18031 P=0.975 18032 TERM1=1.0/(9.0*AN) 18033 TERM2=XCPK*XCPK/(2.0*(AN-1.0)) 18034 CALL NORPPF(P,PPF) 18035 XLCL=XCPK - PPF*SQRT(TERM1 + TERM2) 18036 XUCL=XCPK + PPF*SQRT(TERM1 + TERM2) 18037C 18038C ******************************* 18039C ** STEP 3-- ** 18040C ** WRITE OUT A LINE ** 18041C ** OF SUMMARY INFORMATION. ** 18042C ******************************* 18043C 18044 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 18045 WRITE(ICOUT,999) 18046 CALL DPWRST('XXX','BUG ') 18047 WRITE(ICOUT,811)N,XCPK 18048 811 FORMAT('THE CPK OF THE ',I8,' OBSERVATIONS = ',G15.7) 18049 CALL DPWRST('XXX','BUG ') 18050 ENDIF 18051C 18052C ***************** 18053C ** STEP 90-- ** 18054C ** EXIT. ** 18055C ***************** 18056C 18057 9000 CONTINUE 18058 IF(IBUGA3.EQ.'ON')THEN 18059 WRITE(ICOUT,999) 18060 CALL DPWRST('XXX','BUG ') 18061 WRITE(ICOUT,9011) 18062 9011 FORMAT('***** AT THE END OF CPK--') 18063 CALL DPWRST('XXX','BUG ') 18064 WRITE(ICOUT,9012)IBUGA3,IERROR 18065 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 18066 CALL DPWRST('XXX','BUG ') 18067 WRITE(ICOUT,9014)DMEAN,DSD 18068 9014 FORMAT('DMEAN,DSD = ',2G15.7) 18069 CALL DPWRST('XXX','BUG ') 18070 WRITE(ICOUT,9016)DUSL,DLSL,DUPPER,DLOWER 18071 9016 FORMAT('DUSL,DLSL,DUPPER,DLOWER = ',4G15.7) 18072 CALL DPWRST('XXX','BUG ') 18073 WRITE(ICOUT,9017)DNUM,DDEN,DCPK,XCPK 18074 9017 FORMAT('DNUM,DDEN,DCPK,XCPK = ',4G15.7) 18075 CALL DPWRST('XXX','BUG ') 18076 ENDIF 18077C 18078 RETURN 18079 END 18080 SUBROUTINE CPKM(X,N,ENGLSL,ENGUSL,TARGET,IWRITE,XCPKM,XLCL,XUCL, 18081 1 IBUGA3,IERROR) 18082C 18083C PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE CPKM (PROCESS 18084C CAPABILITY INDEX) OF THE DATA IN THE INPUT VECTOR X. 18085C 18086C CPKM = MIN(USL-MEAN,MEAN-LSL)/ 18087C {3*SQRT(S**2 +(MEAN-TARGET)**2)} 18088C 18089C NOTE--CPKM IS A MEASURE OF PROCESS ACCURACY-- 18090C COMBINING BOTH PRECISION AND UNBIASEDNESS. 18091C NOTE--THE CPKM INDEX IS A MEASURE WHICH TAKES ON THE VALUES 0 TO 18092C INFINITY. A GOOD PROCESS YIELDS VALUES OF CPKM WHICH ARE 18093C LARGE (ABOVE 2); VALUES OF CPKM FROM 0.5 TO 1.0 ARE TYPICAL. 18094C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 18095C (UNSORTED OR SORTED) OBSERVATIONS. 18096C --N = THE INTEGER NUMBER OF OBSERVATIONS 18097C IN THE VECTOR X. 18098C --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT 18099C --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT 18100C --TARGET = TARGET VALUE (ENGINEERING) 18101C OUTPUT ARGUMENTS--CPKM = THE SINGLE PRECISION VALUE OF THE 18102C COMPUTED SAMPLE CPKM 18103C --XLCL = LOWER 95% CONFIDENCE LEVEL 18104C --XUCL = UPPER 95% CONFIDENCE LEVEL 18105C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE 18106C SAMPLE CPKM INDEX 18107C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 18108C OF N FOR THIS SUBROUTINE. 18109C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 18110C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. 18111C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 18112C LANGUAGE--ANSI FORTRAN (1977) 18113C REFERENCES--CHEN AND DING (2001), "A NEW PROCESS CAPABILITY 18114C INDEX FOR NON-NORMAL DISTRIBUTIONS", INTERNATIONAL 18115C JOURNAL OF QUALITY & RELIABILITY MANAGEMENT, 18116C VOL. 18, NO. 7, PP. 762-770. 18117C WRITTEN BY--ALAN HECKERT 18118C STATISTICAL ENGINEERING DIVISION 18119C INFORMATION TECHNOLOGY LABORATORY 18120C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 18121C GAITHERSBURG, MD 20899 18122C PHONE--301-975-2899 18123C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 18124C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 18125C LANGUAGE--ANSI FORTRAN (1977) 18126C VERSION NUMBER--2015.4 18127C ORIGINAL VERSION--APRIL 2015. 18128C 18129C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 18130C 18131 CHARACTER*4 IWRITE 18132 CHARACTER*4 IBUGA3 18133 CHARACTER*4 IERROR 18134C 18135 CHARACTER*4 ISUBN1 18136 CHARACTER*4 ISUBN2 18137C 18138C--------------------------------------------------------------------- 18139C 18140 DOUBLE PRECISION DN 18141 DOUBLE PRECISION DX 18142 DOUBLE PRECISION DSUM 18143 DOUBLE PRECISION DMEAN 18144 DOUBLE PRECISION DVAR 18145 DOUBLE PRECISION DSD 18146C 18147 DOUBLE PRECISION DUSL 18148 DOUBLE PRECISION DLSL 18149 DOUBLE PRECISION DTARG 18150 DOUBLE PRECISION DUPPER 18151 DOUBLE PRECISION DLOWER 18152 DOUBLE PRECISION DNUM 18153 DOUBLE PRECISION DDEN 18154 DOUBLE PRECISION DCPKM 18155C 18156 DIMENSION X(*) 18157C 18158C--------------------------------------------------------------------- 18159C 18160 INCLUDE 'DPCOP2.INC' 18161C 18162C-----START POINT----------------------------------------------------- 18163C 18164 ISUBN1='CPKM' 18165 ISUBN2=' ' 18166 IERROR='NO' 18167C 18168 XCPKM=0.0 18169 XCL=CPUMIN 18170 XUL=CPUMIN 18171C 18172 IF(IBUGA3.EQ.'ON')THEN 18173 WRITE(ICOUT,999) 18174 999 FORMAT(1X) 18175 CALL DPWRST('XXX','BUG ') 18176 WRITE(ICOUT,51) 18177 51 FORMAT('***** AT THE BEGINNING OF CPKM--') 18178 CALL DPWRST('XXX','BUG ') 18179 WRITE(ICOUT,52)IBUGA3,N,ENGUSL,ENGLSL,XLCL,XUCL 18180 52 FORMAT('IBUGA3,N,ENGUSL,ENGLSL,XLCL,XUCL = ',A4,2X,I8,4G15.7) 18181 CALL DPWRST('XXX','BUG ') 18182 DO55I=1,N 18183 WRITE(ICOUT,56)I,X(I) 18184 56 FORMAT('I,X(I) = ',I8,G15.7) 18185 CALL DPWRST('XXX','BUG ') 18186 55 CONTINUE 18187 ENDIF 18188C 18189C ******************************************** 18190C ** COMPUTE PROCESS CAPABILITY INDEX CPKM ** 18191C ******************************************** 18192C 18193C ******************************************** 18194C ** STEP 1-- ** 18195C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 18196C ******************************************** 18197C 18198 AN=N 18199C 18200 IF(N.LT.1)THEN 18201 IERROR='YES' 18202 WRITE(ICOUT,999) 18203 CALL DPWRST('XXX','BUG ') 18204 WRITE(ICOUT,111) 18205 111 FORMAT('***** ERROR IN CPKM--') 18206 CALL DPWRST('XXX','BUG ') 18207 WRITE(ICOUT,112) 18208 112 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ', 18209 1 'VARIABLE IS NON-POSITIVE.') 18210 CALL DPWRST('XXX','BUG ') 18211 WRITE(ICOUT,117)N 18212 117 FORMAT(' THE NUMBER OF OBSERVATIONS = ',I8,'.') 18213 CALL DPWRST('XXX','BUG ') 18214 GOTO9000 18215 ELSEIF(N.EQ.1)THEN 18216 GOTO9000 18217 ENDIF 18218C 18219 HOLD=X(1) 18220 DO135I=2,N 18221 IF(X(I).NE.HOLD)GOTO139 18222 135 CONTINUE 18223 GOTO9000 18224 139 CONTINUE 18225C 18226C *************************************** 18227C ** STEP 2-- ** 18228C ** COMPUTE THE STANDARD DEVIATION. ** 18229C *************************************** 18230C 18231 DN=N 18232 DSUM=0.0D0 18233 DO200I=1,N 18234 DX=X(I) 18235 DSUM=DSUM+DX 18236 200 CONTINUE 18237 DMEAN=DSUM/DN 18238C 18239 DSUM=0.0D0 18240 DO300I=1,N 18241 DX=X(I) 18242 DSUM=DSUM+(DX-DMEAN)**2 18243 300 CONTINUE 18244 DVAR=DSUM/(DN-1.0D0) 18245 DSD=0.0D0 18246 IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR) 18247 XSD=DSD 18248C 18249C ************************************************** 18250C ** STEP 3-- ** 18251C ** COMPUTE THE CPKM RATIO ** 18252C ************************************************** 18253C 18254 DUSL=DBLE(ENGUSL) 18255 DLSL=DBLE(ENGLSL) 18256 DTARG=DBLE(TARGET) 18257C 18258 DUPPER=DUSL-DMEAN 18259 DLOWER=DMEAN-DLSL 18260C 18261 DNUM=DUPPER 18262 IF(DLOWER.LT.DUPPER)DNUM=DLOWER 18263 IF(DNUM.LE.0.0D0)DNUM=0.0D0 18264C 18265 DDEN=3.0*DSQRT(DSD**2 + (DMEAN-DTARG)**2) 18266C 18267 DCPKM=0.0 18268 IF(DDEN.GT.0.0D0)DCPKM=DNUM/DDEN 18269 XCPKM=DCPKM 18270C 18271C FOLLOWING CONFIDENCE INTERVALS ARE FOR CPK. HAVEN'T FOUND 18272C A SOURCE FOR CPKM CONFIDENCE INTERVALS. 18273C 18274CCCCC AN=REAL(N) 18275CCCCC P=0.975 18276CCCCC TERM1=1.0/(9.0*AN) 18277CCCCC TERM2=XCPKM*XCPK/(2.0*(AN-1.0)) 18278CCCCC CALL NORPPF(P,PPF) 18279CCCCC XLCL=XCPKM - PPF*SQRT(TERM1 + TERM2) 18280CCCCC XUCL=XCPKM + PPF*SQRT(TERM1 + TERM2) 18281C 18282C ******************************* 18283C ** STEP 3-- ** 18284C ** WRITE OUT A LINE ** 18285C ** OF SUMMARY INFORMATION. ** 18286C ******************************* 18287C 18288 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 18289 WRITE(ICOUT,999) 18290 CALL DPWRST('XXX','BUG ') 18291 WRITE(ICOUT,811)N,XCPKM 18292 811 FORMAT('THE CPKM OF THE ',I8,' OBSERVATIONS = ',G15.7) 18293 CALL DPWRST('XXX','BUG ') 18294 ENDIF 18295C 18296C ***************** 18297C ** STEP 90-- ** 18298C ** EXIT. ** 18299C ***************** 18300C 18301 9000 CONTINUE 18302 IF(IBUGA3.EQ.'ON')THEN 18303 WRITE(ICOUT,999) 18304 CALL DPWRST('XXX','BUG ') 18305 WRITE(ICOUT,9011) 18306 9011 FORMAT('***** AT THE END OF CPKM--') 18307 CALL DPWRST('XXX','BUG ') 18308 WRITE(ICOUT,9012)IBUGA3,IERROR 18309 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 18310 CALL DPWRST('XXX','BUG ') 18311 WRITE(ICOUT,9014)DMEAN,DSD 18312 9014 FORMAT('DMEAN,DSD = ',2G15.7) 18313 CALL DPWRST('XXX','BUG ') 18314 WRITE(ICOUT,9016)DUSL,DLSL,DUPPER,DLOWER 18315 9016 FORMAT('DUSL,DLSL,DUPPER,DLOWER = ',4G15.7) 18316 CALL DPWRST('XXX','BUG ') 18317 WRITE(ICOUT,9017)DNUM,DDEN,DCPKM,XCPKM 18318 9017 FORMAT('DNUM,DDEN,DCPKM,XCPK = ',4G15.7) 18319 CALL DPWRST('XXX','BUG ') 18320 ENDIF 18321C 18322 RETURN 18323 END 18324 SUBROUTINE CPL(X,N,ENGLSL,ENGUSL,IWRITE,XCPL,XLCL,XUCL, 18325 1 IBUGA3,IERROR) 18326C 18327C PURPOSE--THIS SUBROUTINE COMPUTES THE 18328C SAMPLE CPL (PROCESS CAPABILITY INDEX) 18329C OF THE DATA IN THE INPUT VECTOR X. 18330C CPL = NUMERATOR/DENOMINATOR 18331C WHERE NUMERATOR = XBAR - LOWER SPEC LIMIT 18332C AND DENOMINATOR = 3 * SIGMA 18333C NOTE--CPL IS A VARIATION OF CPL WHEN YOU ARE ONLY 18334C INTERESTED IN THE LOWER SPEC LIMIT. 18335C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 18336C (UNSORTED OR SORTED) OBSERVATIONS. 18337C --N = THE INTEGER NUMBER OF OBSERVATIONS 18338C IN THE VECTOR X. 18339C --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT 18340C --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT 18341C OUTPUT ARGUMENTS--CPL = THE SINGLE PRECISION VALUE OF THE 18342C COMPUTED SAMPLE CPL 18343C --XLCL = LOWER 95% CONFIDENCE LEVEL 18344C --XUCL = UPPER 95% CONFIDENCE LEVEL 18345C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE 18346C SAMPLE CPL INDEX 18347C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 18348C OF N FOR THIS SUBROUTINE. 18349C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 18350C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. 18351C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 18352C LANGUAGE--ANSI FORTRAN (1977) 18353C REFERENCES--R&M 2000 AIR FORCE MANUAL 18354C WRITTEN BY--JAMES J. FILLIBEN 18355C STATISTICAL ENGINEERING DIVISION 18356C INFORMATION TECHNOLOGY LABORATORY 18357C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 18358C GAITHERSBURG, MD 20899 18359C PHONE--301-975-2855 18360C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 18361C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 18362C LANGUAGE--ANSI FORTRAN (1977) 18363C VERSION NUMBER--2001.4 18364C ORIGINAL VERSION--APRIL 2001. 18365C 18366C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 18367C 18368 CHARACTER*4 IWRITE 18369 CHARACTER*4 IBUGA3 18370 CHARACTER*4 IERROR 18371C 18372 CHARACTER*4 ISUBN1 18373 CHARACTER*4 ISUBN2 18374C 18375C--------------------------------------------------------------------- 18376C 18377 DOUBLE PRECISION DN 18378 DOUBLE PRECISION DX 18379 DOUBLE PRECISION DSUM 18380 DOUBLE PRECISION DMEAN 18381 DOUBLE PRECISION DVAR 18382 DOUBLE PRECISION DSD 18383C 18384 DOUBLE PRECISION DUSL 18385 DOUBLE PRECISION DLSL 18386 DOUBLE PRECISION DUPPER 18387 DOUBLE PRECISION DLOWER 18388 DOUBLE PRECISION DNUM 18389 DOUBLE PRECISION DDEN 18390 DOUBLE PRECISION DCPL 18391C 18392 DIMENSION X(*) 18393C 18394C--------------------------------------------------------------------- 18395C 18396 INCLUDE 'DPCOP2.INC' 18397C 18398C-----START POINT----------------------------------------------------- 18399C 18400 ISUBN1='CPL ' 18401 ISUBN2=' ' 18402C 18403 IERROR='NO' 18404C 18405 DMEAN=0.0D0 18406C 18407 IF(IBUGA3.EQ.'OFF')GOTO90 18408 WRITE(ICOUT,999) 18409 999 FORMAT(1X) 18410 CALL DPWRST('XXX','BUG ') 18411 WRITE(ICOUT,51) 18412 51 FORMAT('***** AT THE BEGINNING OF CPL--') 18413 CALL DPWRST('XXX','BUG ') 18414 WRITE(ICOUT,52)IBUGA3 18415 52 FORMAT('IBUGA3 = ',A4) 18416 CALL DPWRST('XXX','BUG ') 18417 WRITE(ICOUT,53)N 18418 53 FORMAT('N = ',I8) 18419 CALL DPWRST('XXX','BUG ') 18420 WRITE(ICOUT,54)ENGUSL,ENGLSL 18421 54 FORMAT('ENGUSL,ENGLSL = ',2E15.7) 18422 CALL DPWRST('XXX','BUG ') 18423 DO55I=1,N 18424 WRITE(ICOUT,56)I,X(I) 18425 56 FORMAT('I,X(I) = ',I8,E15.7) 18426 CALL DPWRST('XXX','BUG ') 18427 55 CONTINUE 18428 90 CONTINUE 18429C 18430C ******************************************** 18431C ** COMPUTE PROCESS CAPABILITY INDEX CPL ** 18432C ******************************************** 18433C 18434C ******************************************** 18435C ** STEP 1-- ** 18436C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 18437C ******************************************** 18438C 18439 AN=N 18440C 18441 IF(N.GE.1)GOTO119 18442 IERROR='YES' 18443 WRITE(ICOUT,999) 18444 CALL DPWRST('XXX','BUG ') 18445 WRITE(ICOUT,111) 18446 111 FORMAT('***** ERROR IN CPL--') 18447 CALL DPWRST('XXX','BUG ') 18448 WRITE(ICOUT,112) 18449 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') 18450 CALL DPWRST('XXX','BUG ') 18451 WRITE(ICOUT,113) 18452 113 FORMAT(' IN THE VARIABLE FOR WHICH') 18453 CALL DPWRST('XXX','BUG ') 18454 WRITE(ICOUT,114) 18455 114 FORMAT(' THE CPL STATISTIC IS TO BE COMPUTED') 18456 CALL DPWRST('XXX','BUG ') 18457 WRITE(ICOUT,115) 18458 115 FORMAT(' MUST BE 1 OR LARGER.') 18459 CALL DPWRST('XXX','BUG ') 18460 WRITE(ICOUT,116) 18461 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') 18462 CALL DPWRST('XXX','BUG ') 18463 WRITE(ICOUT,117)N 18464 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 18465 1'.') 18466 CALL DPWRST('XXX','BUG ') 18467 GOTO9000 18468 119 CONTINUE 18469C 18470 IF(N.EQ.1)GOTO120 18471 GOTO129 18472 120 CONTINUE 18473 XSD=0.0 18474 GOTO9000 18475 129 CONTINUE 18476C 18477 HOLD=X(1) 18478 DO135I=2,N 18479 IF(X(I).NE.HOLD)GOTO139 18480 135 CONTINUE 18481 XSD=0.0 18482 GOTO9000 18483 139 CONTINUE 18484C 18485C *************************************** 18486C ** STEP 2-- ** 18487C ** COMPUTE THE STANDARD DEVIATION. ** 18488C *************************************** 18489C 18490 DN=N 18491 DSUM=0.0D0 18492 DO200I=1,N 18493 DX=X(I) 18494 DSUM=DSUM+DX 18495 200 CONTINUE 18496 DMEAN=DSUM/DN 18497C 18498 DSUM=0.0D0 18499 DO300I=1,N 18500 DX=X(I) 18501 DSUM=DSUM+(DX-DMEAN)**2 18502 300 CONTINUE 18503 DVAR=DSUM/(DN-1.0D0) 18504 DSD=0.0D0 18505 IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR) 18506 XSD=DSD 18507C 18508C ************************************************** 18509C ** STEP 3-- ** 18510C ** COMPUTE THE CPL RATIO ** 18511C ************************************************** 18512C 18513 DUSL=ENGUSL 18514 DLSL=ENGLSL 18515C 18516 DUPPER=DUSL-DMEAN 18517 DLOWER=DMEAN-DLSL 18518C 18519 DNUM=DLOWER 18520C 18521 DDEN=3.0*DSD 18522C 18523 DCPL=0.0D0 18524 IF(DDEN.GT.0.0D0)DCPL=DNUM/DDEN 18525 XCPL=DCPL 18526C 18527 AN=REAL(N) 18528 P=0.975 18529 CALL NORPPF(P,PPF) 18530 XLCL=0.0 18531 XUCL=0.0 18532 IF(N.GT.1)THEN 18533 XLCL=XCPL - PPF*SQRT((1.0/(9.0*AN)) + XCPL/(2.0*(AN-1.0))) 18534 XUCL=XCPL + PPF*SQRT((1.0/(9.0*AN)) + XCPL/(2.0*(AN-1.0))) 18535 ENDIF 18536C 18537C ******************************* 18538C ** STEP 3-- ** 18539C ** WRITE OUT A LINE ** 18540C ** OF SUMMARY INFORMATION. ** 18541C ******************************* 18542C 18543 IF(IFEEDB.EQ.'OFF')GOTO890 18544 IF(IWRITE.EQ.'OFF')GOTO890 18545 WRITE(ICOUT,999) 18546 CALL DPWRST('XXX','BUG ') 18547 WRITE(ICOUT,811)N,XCPL 18548 811 FORMAT('THE CPK OF THE ',I8,' OBSERVATIONS = ', 18549 1E15.7) 18550 CALL DPWRST('XXX','BUG ') 18551 890 CONTINUE 18552C 18553C ***************** 18554C ** STEP 90-- ** 18555C ** EXIT. ** 18556C ***************** 18557C 18558 9000 CONTINUE 18559 IF(IBUGA3.EQ.'OFF')GOTO9090 18560 WRITE(ICOUT,999) 18561 CALL DPWRST('XXX','BUG ') 18562 WRITE(ICOUT,9011) 18563 9011 FORMAT('***** AT THE END OF CPL--') 18564 CALL DPWRST('XXX','BUG ') 18565 WRITE(ICOUT,9012)IBUGA3,IERROR 18566 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 18567 CALL DPWRST('XXX','BUG ') 18568 WRITE(ICOUT,9013)N 18569 9013 FORMAT('N = ',I8) 18570 CALL DPWRST('XXX','BUG ') 18571 WRITE(ICOUT,9014)DMEAN 18572 9014 FORMAT('DMEAN = ',D15.7) 18573 CALL DPWRST('XXX','BUG ') 18574 WRITE(ICOUT,9015)DSD 18575 9015 FORMAT('DSD = ',E15.7) 18576 CALL DPWRST('XXX','BUG ') 18577 WRITE(ICOUT,9016)DUSL,DLSL,DUPPER,DLOWER 18578 9016 FORMAT('DUSL,DLSL,DUPPER,DLOWER = ',4D15.7) 18579 CALL DPWRST('XXX','BUG ') 18580 WRITE(ICOUT,9017)DNUM,DDEN,DCPL,XCPL 18581 9017 FORMAT('DNUM,DDEN,DCPL,XCPL = ',3D15.7,E15.7) 18582 CALL DPWRST('XXX','BUG ') 18583 9090 CONTINUE 18584C 18585 RETURN 18586 END 18587 SUBROUTINE CPM(X,N,ENGLSL,ENGUSL,TARGET,IWRITE,XCPM,XLCL,XUCL, 18588 1 IBUGA3,IERROR) 18589C 18590C PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE CPM (PROCESS 18591C CAPABILITY INDEX) OF THE DATA IN THE INPUT VECTOR X. 18592C 18593C CPM = (USL - LSL)/(6*SQRT(S**2+(XBAR-TARGET)**2)) 18594C 18595C NOTE--CPM IS A MEASURE OF PROCESS ACCURACY-- 18596C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 18597C (UNSORTED OR SORTED) OBSERVATIONS. 18598C --N = THE INTEGER NUMBER OF OBSERVATIONS 18599C IN THE VECTOR X. 18600C --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT 18601C --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT 18602C --TARGET = TARGET (ENGINEERING) SPEC LIMIT 18603C OUTPUT ARGUMENTS--XCPM = THE SINGLE PRECISION VALUE OF THE 18604C COMPUTED SAMPLE CPM 18605C --XLCL = LOWER 95% CONFIDENCE INTERVAL 18606C --XUCL = UPPER 95% CONFIDENCE INTERVAL 18607C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE SAMPLE CPM INDEX 18608C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 18609C OF N FOR THIS SUBROUTINE. 18610C OTHER DATAPAC SUBROUTINES NEEDED--MEAN AND SD. 18611C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. 18612C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 18613C LANGUAGE--ANSI FORTRAN (1977) 18614C REFERENCES--NORMA HUBELE, ARIZONA STATE 18615C --CHEN AND DING (2001), "A NEW PROCESS CAPABILITY 18616C INDEX FOR NON-NORMAL DISTRIBUTIONS", INTERNATIONAL 18617C JOURNAL OF QUALITY & RELIABILITY MANAGEMENT, 18618C VOL. 18, NO. 7, PP. 762-770. 18619C WRITTEN BY--JAMES J. FILLIBEN 18620C STATISTICAL ENGINEERING DIVISION 18621C INFORMATION TECHNOLOGY LABORATORY 18622C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 18623C GAITHERSBURG, MD 20899 18624C PHONE--301-975-2899 18625C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 18626C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 18627C LANGUAGE--ANSI FORTRAN (1977) 18628C VERSION NUMBER--98.11 18629C ORIGINAL VERSION--NOVEMBER 1998. 18630C UPDATED --APRIL 2001. ADD 95% CONFIDENCE LIMITS 18631C 18632C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 18633C 18634 CHARACTER*4 IWRITE 18635 CHARACTER*4 IBUGA3 18636 CHARACTER*4 IERROR 18637C 18638 CHARACTER*4 ISUBN1 18639 CHARACTER*4 ISUBN2 18640C 18641C--------------------------------------------------------------------- 18642C 18643 DOUBLE PRECISION DN 18644 DOUBLE PRECISION DX 18645 DOUBLE PRECISION DSUM 18646 DOUBLE PRECISION DMEAN 18647 DOUBLE PRECISION DVAR 18648 DOUBLE PRECISION DSD 18649C 18650 DOUBLE PRECISION DUSL 18651 DOUBLE PRECISION DLSL 18652 DOUBLE PRECISION DTARG 18653 DOUBLE PRECISION DNUM 18654 DOUBLE PRECISION DDEN 18655 DOUBLE PRECISION DCPM 18656C 18657 DIMENSION X(*) 18658C 18659C--------------------------------------------------------------------- 18660C 18661 INCLUDE 'DPCOP2.INC' 18662C 18663C-----START POINT----------------------------------------------------- 18664C 18665 ISUBN1='CPM ' 18666 ISUBN2=' ' 18667 IERROR='NO' 18668C 18669 XCPM=0.0 18670C 18671 IF(IBUGA3.EQ.'ON')THEN 18672 WRITE(ICOUT,999) 18673 999 FORMAT(1X) 18674 CALL DPWRST('XXX','BUG ') 18675 WRITE(ICOUT,51) 18676 51 FORMAT('***** AT THE BEGINNING OF CPM--') 18677 CALL DPWRST('XXX','BUG ') 18678 WRITE(ICOUT,52)IBUGA3,N,ENGUSL,ENGLSL,TARGET 18679 52 FORMAT('IBUGA3,N,ENGUSL,ENGLSL,TARGET = ',A4,2X,I8,3G15.7) 18680 CALL DPWRST('XXX','BUG ') 18681 DO55I=1,N 18682 WRITE(ICOUT,56)I,X(I) 18683 56 FORMAT('I,X(I) = ',I8,G15.7) 18684 CALL DPWRST('XXX','BUG ') 18685 55 CONTINUE 18686 ENDIF 18687C 18688C ******************************************** 18689C ** COMPUTE PROCESS CAPABILITY INDEX CPM ** 18690C ******************************************** 18691C 18692C ******************************************** 18693C ** STEP 1-- ** 18694C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 18695C ******************************************** 18696C 18697 AN=N 18698C 18699 IF(N.LT.1)THEN 18700 IERROR='YES' 18701 WRITE(ICOUT,999) 18702 CALL DPWRST('XXX','BUG ') 18703 WRITE(ICOUT,111) 18704 111 FORMAT('***** ERROR IN CPM--') 18705 CALL DPWRST('XXX','BUG ') 18706 WRITE(ICOUT,112) 18707 112 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ', 18708 1 'VARIABLE IS NON-POSITIVE.') 18709 CALL DPWRST('XXX','BUG ') 18710 WRITE(ICOUT,117)N 18711 117 FORMAT(' THE NUMBER OF OBSERVATIONS = ',I8,'.') 18712 CALL DPWRST('XXX','BUG ') 18713 GOTO9000 18714 ELSEIF(N.EQ.1)THEN 18715 GOTO9000 18716 ENDIF 18717C 18718 HOLD=X(1) 18719 DO135I=2,N 18720 IF(X(I).NE.HOLD)GOTO139 18721 135 CONTINUE 18722 GOTO9000 18723 139 CONTINUE 18724C 18725C *************************************** 18726C ** STEP 2-- ** 18727C ** COMPUTE THE STANDARD DEVIATION. ** 18728C *************************************** 18729C 18730 DN=N 18731 DSUM=0.0D0 18732 DO200I=1,N 18733 DX=X(I) 18734 DSUM=DSUM+DX 18735 200 CONTINUE 18736 DMEAN=DSUM/DN 18737C 18738 DSUM=0.0D0 18739 DO300I=1,N 18740 DX=X(I) 18741 DSUM=DSUM+(DX-DMEAN)**2 18742 300 CONTINUE 18743 DVAR=DSUM/(DN-1.0D0) 18744 DSD=0.0D0 18745 IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR) 18746 XMEAN=DMEAN 18747 XSD=DSD 18748C 18749C ************************************************** 18750C ** STEP 3-- ** 18751C ** COMPUTE THE CPM RATIO ** 18752C ************************************************** 18753C 18754 DUSL=ENGUSL 18755 DLSL=ENGLSL 18756 DTARG=TARGET 18757C 18758 DNUM=DUSL-DLSL 18759 DDEN=6.0D0*DSQRT(DSD**2 + (DMEAN-DTARG)**2) 18760C 18761 DCPM=0.0 18762 IF(DDEN.GT.0.0D0)DCPM=DNUM/DDEN 18763 XCPM=DCPM 18764C 18765 XLCL=0.0 18766 XUCL=0.0 18767 AN=REAL(N) 18768 NV=N-1 18769 AV=REAL(NV) 18770 P=0.975 18771 CALL CHSPPF(P,NV,PPF) 18772 IF((PPF/AV).GT.0.0)XUCL=XCPM*SQRT(PPF/AV) 18773 P=0.025 18774 CALL CHSPPF(P,NV,PPF) 18775 IF((PPF/AV).GT.0.0)XLCL=XCPM*SQRT(PPF/AV) 18776C 18777C ******************************* 18778C ** STEP 3-- ** 18779C ** WRITE OUT A LINE ** 18780C ** OF SUMMARY INFORMATION. ** 18781C ******************************* 18782C 18783 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 18784 WRITE(ICOUT,999) 18785 CALL DPWRST('XXX','BUG ') 18786 WRITE(ICOUT,811)N,XCPM 18787 811 FORMAT('THE CPM OF THE ',I8,' OBSERVATIONS = ',G15.7) 18788 CALL DPWRST('XXX','BUG ') 18789 ENDIF 18790C 18791C ***************** 18792C ** STEP 90-- ** 18793C ** EXIT. ** 18794C ***************** 18795C 18796 9000 CONTINUE 18797 IF(IBUGA3.EQ.'ON')THEN 18798 WRITE(ICOUT,999) 18799 CALL DPWRST('XXX','BUG ') 18800 WRITE(ICOUT,9011) 18801 9011 FORMAT('***** AT THE END OF CPM--') 18802 CALL DPWRST('XXX','BUG ') 18803 WRITE(ICOUT,9012)IBUGA3,IERROR 18804 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 18805 CALL DPWRST('XXX','BUG ') 18806 WRITE(ICOUT,9014)DMEAN,DSD,DUSL,DLSL 18807 9014 FORMAT('DMEAN,DSD,DUSL,DLSL = ',4G15.7) 18808 CALL DPWRST('XXX','BUG ') 18809 WRITE(ICOUT,9017)DNUM,DDEN,DCPM,XCPM 18810 9017 FORMAT('DNUM,DDEN,DCPM,XCPM = ',4G15.7) 18811 CALL DPWRST('XXX','BUG ') 18812 ENDIF 18813C 18814 RETURN 18815 END 18816 SUBROUTINE CPMK(X,N,ENGLSL,ENGUSL,TARGET,IWRITE,XCPMK,XLCL,XUCL, 18817 1 IBUGA3,IERROR) 18818C 18819C PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE CPMK (PROCESS 18820C CAPABILITY INDEX) OF THE DATA IN THE INPUT VECTOR X. 18821C 18822C CPMK = MIN(USL-MEAN,MEAN-LSL)/ 18823C {3*SQRT(S**2 +(MEAN-TARGET)**2)} 18824C 18825C NOTE--CPMK IS A MEASURE OF PROCESS ACCURACY-- 18826C COMBINING BOTH PRECISION AND UNBIASEDNESS. 18827C NOTE--THE CPMK INDEX IS A MEASURE WHICH TAKES ON THE VALUES 0 TO 18828C INFINITY. A GOOD PROCESS YIELDS VALUES OF CPMK WHICH ARE 18829C LARGE (ABOVE 2); VALUES OF CPMK FROM 0.5 TO 1.0 ARE TYPICAL. 18830C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 18831C (UNSORTED OR SORTED) OBSERVATIONS. 18832C --N = THE INTEGER NUMBER OF OBSERVATIONS 18833C IN THE VECTOR X. 18834C --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT 18835C --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT 18836C --TARGET = TARGET VALUE (ENGINEERING) 18837C OUTPUT ARGUMENTS--CPMK = THE SINGLE PRECISION VALUE OF THE 18838C COMPUTED SAMPLE CPMK 18839C --XLCL = LOWER 95% CONFIDENCE LEVEL 18840C --XUCL = UPPER 95% CONFIDENCE LEVEL 18841C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE 18842C SAMPLE CPMK INDEX 18843C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 18844C OF N FOR THIS SUBROUTINE. 18845C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 18846C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. 18847C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 18848C LANGUAGE--ANSI FORTRAN (1977) 18849C REFERENCES--CHEN AND DING (2001), "A NEW PROCESS CAPABILITY 18850C INDEX FOR NON-NORMAL DISTRIBUTIONS", INTERNATIONAL 18851C JOURNAL OF QUALITY & RELIABILITY MANAGEMENT, 18852C VOL. 18, NO. 7, PP. 762-770. 18853C WRITTEN BY--ALAN HECKERT 18854C STATISTICAL ENGINEERING DIVISION 18855C INFORMATION TECHNOLOGY LABORATORY 18856C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 18857C GAITHERSBURG, MD 20899 18858C PHONE--301-975-2899 18859C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 18860C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 18861C LANGUAGE--ANSI FORTRAN (1977) 18862C VERSION NUMBER--2015.4 18863C ORIGINAL VERSION--APRIL 2015. 18864C 18865C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 18866C 18867 CHARACTER*4 IWRITE 18868 CHARACTER*4 IBUGA3 18869 CHARACTER*4 IERROR 18870C 18871 CHARACTER*4 ISUBN1 18872 CHARACTER*4 ISUBN2 18873C 18874C--------------------------------------------------------------------- 18875C 18876 DOUBLE PRECISION DN 18877 DOUBLE PRECISION DX 18878 DOUBLE PRECISION DSUM 18879 DOUBLE PRECISION DMEAN 18880 DOUBLE PRECISION DVAR 18881 DOUBLE PRECISION DSD 18882C 18883 DOUBLE PRECISION DUSL 18884 DOUBLE PRECISION DLSL 18885 DOUBLE PRECISION DTARG 18886 DOUBLE PRECISION DUPPER 18887 DOUBLE PRECISION DLOWER 18888 DOUBLE PRECISION DNUM 18889 DOUBLE PRECISION DDEN 18890 DOUBLE PRECISION DCPMK 18891C 18892 DIMENSION X(*) 18893C 18894C--------------------------------------------------------------------- 18895C 18896 INCLUDE 'DPCOP2.INC' 18897C 18898C-----START POINT----------------------------------------------------- 18899C 18900 ISUBN1='CPMK' 18901 ISUBN2=' ' 18902 IERROR='NO' 18903C 18904 XCPMK=0.0 18905 XCL=CPUMIN 18906 XUL=CPUMIN 18907C 18908 IF(IBUGA3.EQ.'ON')THEN 18909 WRITE(ICOUT,999) 18910 999 FORMAT(1X) 18911 CALL DPWRST('XXX','BUG ') 18912 WRITE(ICOUT,51) 18913 51 FORMAT('***** AT THE BEGINNING OF CPMK--') 18914 CALL DPWRST('XXX','BUG ') 18915 WRITE(ICOUT,52)IBUGA3,N,ENGUSL,ENGLSL,XLCL,XUCL 18916 52 FORMAT('IBUGA3,N,ENGUSL,ENGLSL,XLCL,XUCL = ',A4,2X,I8,4G15.7) 18917 CALL DPWRST('XXX','BUG ') 18918 DO55I=1,N 18919 WRITE(ICOUT,56)I,X(I) 18920 56 FORMAT('I,X(I) = ',I8,G15.7) 18921 CALL DPWRST('XXX','BUG ') 18922 55 CONTINUE 18923 ENDIF 18924C 18925C ******************************************** 18926C ** COMPUTE PROCESS CAPABILITY INDEX CPMK ** 18927C ******************************************** 18928C 18929C ******************************************** 18930C ** STEP 1-- ** 18931C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 18932C ******************************************** 18933C 18934 AN=N 18935C 18936 IF(N.LT.1)THEN 18937 IERROR='YES' 18938 WRITE(ICOUT,999) 18939 CALL DPWRST('XXX','BUG ') 18940 WRITE(ICOUT,111) 18941 111 FORMAT('***** ERROR IN CPMK--') 18942 CALL DPWRST('XXX','BUG ') 18943 WRITE(ICOUT,112) 18944 112 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ', 18945 1 'VARIABLE IS NON-POSITIVE.') 18946 CALL DPWRST('XXX','BUG ') 18947 WRITE(ICOUT,117)N 18948 117 FORMAT(' THE NUMBER OF OBSERVATIONS = ',I8,'.') 18949 CALL DPWRST('XXX','BUG ') 18950 GOTO9000 18951 ELSEIF(N.EQ.1)THEN 18952 GOTO9000 18953 ENDIF 18954C 18955 HOLD=X(1) 18956 DO135I=2,N 18957 IF(X(I).NE.HOLD)GOTO139 18958 135 CONTINUE 18959 GOTO9000 18960 139 CONTINUE 18961C 18962C *************************************** 18963C ** STEP 2-- ** 18964C ** COMPUTE THE STANDARD DEVIATION. ** 18965C *************************************** 18966C 18967 DN=N 18968 DSUM=0.0D0 18969 DO200I=1,N 18970 DX=X(I) 18971 DSUM=DSUM+DX 18972 200 CONTINUE 18973 DMEAN=DSUM/DN 18974C 18975 DSUM=0.0D0 18976 DO300I=1,N 18977 DX=X(I) 18978 DSUM=DSUM+(DX-DMEAN)**2 18979 300 CONTINUE 18980 DVAR=DSUM/(DN-1.0D0) 18981 DSD=0.0D0 18982 IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR) 18983 XSD=DSD 18984C 18985C ************************************************** 18986C ** STEP 3-- ** 18987C ** COMPUTE THE CPMK RATIO ** 18988C ************************************************** 18989C 18990 DUSL=DBLE(ENGUSL) 18991 DLSL=DBLE(ENGLSL) 18992 DTARG=DBLE(TARGET) 18993C 18994 DUPPER=DUSL-DMEAN 18995 DLOWER=DMEAN-DLSL 18996C 18997 DNUM=DUPPER 18998 IF(DLOWER.LT.DUPPER)DNUM=DLOWER 18999 IF(DNUM.LE.0.0D0)DNUM=0.0D0 19000C 19001 DDEN=3.0*DSQRT(DSD**2 + (DMEAN-DTARG)**2) 19002C 19003 DCPMK=0.0 19004 IF(DDEN.GT.0.0D0)DCPMK=DNUM/DDEN 19005 XCPMK=DCPMK 19006C 19007C FOLLOWING CONFIDENCE INTERVALS ARE FOR CPK. HAVEN'T FOUND 19008C A SOURCE FOR CPMK CONFIDENCE INTERVALS. 19009C 19010CCCCC AN=REAL(N) 19011CCCCC P=0.975 19012CCCCC TERM1=1.0/(9.0*AN) 19013CCCCC TERM2=XCPMK*XCPK/(2.0*(AN-1.0)) 19014CCCCC CALL NORPPF(P,PPF) 19015CCCCC XLCL=XCPMK - PPF*SQRT(TERM1 + TERM2) 19016CCCCC XUCL=XCPMK + PPF*SQRT(TERM1 + TERM2) 19017C 19018C ******************************* 19019C ** STEP 3-- ** 19020C ** WRITE OUT A LINE ** 19021C ** OF SUMMARY INFORMATION. ** 19022C ******************************* 19023C 19024 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 19025 WRITE(ICOUT,999) 19026 CALL DPWRST('XXX','BUG ') 19027 WRITE(ICOUT,811)N,XCPMK 19028 811 FORMAT('THE CPMK OF THE ',I8,' OBSERVATIONS = ',G15.7) 19029 CALL DPWRST('XXX','BUG ') 19030 ENDIF 19031C 19032C ***************** 19033C ** STEP 90-- ** 19034C ** EXIT. ** 19035C ***************** 19036C 19037 9000 CONTINUE 19038 IF(IBUGA3.EQ.'ON')THEN 19039 WRITE(ICOUT,999) 19040 CALL DPWRST('XXX','BUG ') 19041 WRITE(ICOUT,9011) 19042 9011 FORMAT('***** AT THE END OF CPMK--') 19043 CALL DPWRST('XXX','BUG ') 19044 WRITE(ICOUT,9012)IBUGA3,IERROR 19045 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 19046 CALL DPWRST('XXX','BUG ') 19047 WRITE(ICOUT,9014)DMEAN,DSD 19048 9014 FORMAT('DMEAN,DSD = ',2G15.7) 19049 CALL DPWRST('XXX','BUG ') 19050 WRITE(ICOUT,9016)DUSL,DLSL,DUPPER,DLOWER 19051 9016 FORMAT('DUSL,DLSL,DUPPER,DLOWER = ',4G15.7) 19052 CALL DPWRST('XXX','BUG ') 19053 WRITE(ICOUT,9017)DNUM,DDEN,DCPMK,XCPMK 19054 9017 FORMAT('DNUM,DDEN,DCPMK,XCPMK = ',4G15.7) 19055 CALL DPWRST('XXX','BUG ') 19056 ENDIF 19057C 19058 RETURN 19059 END 19060 COMPLEX FUNCTION CPSI(ZIN) 19061C***BEGIN PROLOGUE CPSI 19062C***DATE WRITTEN 780501 (YYMMDD) 19063C***REVISION DATE 820801 (YYMMDD) 19064C***CATEGORY NO. C7C 19065C***KEYWORDS COMPLEX,DIGAMMA FUNCTION,PSI FUNCTION,SPECIAL FUNCTION 19066C***AUTHOR FULLERTON, W., (LANL) 19067C***PURPOSE Computes the Psi function of complex argument. 19068C***DESCRIPTION 19069C 19070C PSI(X) calculates the psi (or digamma) function of X. PSI(X) 19071C is the logarithmic derivative of the gamma function of X. 19072C***REFERENCES (NONE) 19073C***ROUTINES CALLED CCOT,R1MACH,XERROR 19074C***END PROLOGUE CPSI 19075 COMPLEX ZIN, Z, Z2INV, CORR, CCOT, CLOG 19076C 19077 INCLUDE 'DPCOMC.INC' 19078 INCLUDE 'DPCOP2.INC' 19079C 19080 DIMENSION BERN(13) 19081 DATA BERN( 1) / .8333333333 3333333 E-1 / 19082 DATA BERN( 2) / -.8333333333 3333333 E-2 / 19083 DATA BERN( 3) / .3968253968 2539683 E-2 / 19084 DATA BERN( 4) / -.4166666666 6666667 E-2 / 19085 DATA BERN( 5) / .7575757575 7575758 E-2 / 19086 DATA BERN( 6) / -.2109279609 2796093 E-1 / 19087 DATA BERN( 7) / .8333333333 3333333 E-1 / 19088 DATA BERN( 8) / -.4432598039 2156863 E0 / 19089 DATA BERN( 9) / .3053954330 2701197 E1 / 19090 DATA BERN(10) / -.2645621212 1212121 E2 / 19091 DATA BERN(11) / .2814601449 2753623 E3 / 19092 DATA BERN(12) / -.3454885393 7728938 E4 / 19093 DATA BERN(13) / .5482758333 3333333 E5 / 19094 DATA PI / 3.141592653 589793 E0 / 19095 DATA NTERM, BOUND, DXREL, RMIN, RBIG / 0, 4*0.0 / 19096C***FIRST EXECUTABLE STATEMENT CPSI 19097C 19098 CPSI = (0.0, 0.0) 19099C 19100 IF (NTERM.NE.0) GO TO 10 19101 NTERM = INT(-0.30*LOG(R1MACH(3))) 19102C MAYBE BOUND = N*(0.1*EPS)**(-1/(2*N-1)) / (PI*EXP(1)) 19103 BOUND = 0.1171*FLOAT(NTERM) * 19104 1 (0.1*R1MACH(3))**(-1.0/(2.0*FLOAT(NTERM)-1.0)) 19105 DXREL = SQRT(R1MACH(4)) 19106 RMIN = EXP (AMAX1 (LOG(R1MACH(1)), -LOG(R1MACH(2))) + 0.011 ) 19107 RBIG = 1.0/R1MACH(3) 19108C 19109 10 Z = ZIN 19110 X = REAL(Z) 19111 Y = AIMAG(Z) 19112 IF (Y.LT.0.0) Z = CONJG(Z) 19113C 19114 CORR = (0.0, 0.0) 19115 CABSZ = CABS(Z) 19116 IF (X.GE.0.0 .AND. CABSZ.GT.BOUND) GO TO 50 19117 IF (X.LT.0.0 .AND. ABS(Y).GT.BOUND) GO TO 50 19118C 19119 IF (CABSZ.LT.BOUND) GO TO 20 19120C 19121C USE THE REFLECTION FORMULA FOR REAL(Z) NEGATIVE, CABS(Z) LARGE, AND 19122C ABS(AIMAG(Y)) SMALL. 19123C 19124 CORR = -PI*CCOT(PI*Z) 19125 Z = 1.0 - Z 19126 GO TO 50 19127C 19128C USE THE RECURSION RELATION FOR CABS(Z) SMALL. 19129C 19130 20 IF (CABSZ.LT.RMIN) THEN 19131CCCCC CALL XERROR ( 'CPSI CPSI CALLED WITH Z SO NE 19132CCCCC1AR 0 THAT CPSI OVERFLOWS', 56, 2, 2) 19133 WRITE(ICOUT,102) 19134 CALL DPWRST('XXX','BUG ') 19135 RETURN 19136 ENDIF 19137 102 FORMAT('***** INTERNAL ERROR FROM CPSI: ARGUMENT SO CLOSE', 19138 1' TO ZERO THAT CPSI OVERFLOWS') 19139C 19140 IF (X.GE.(-0.5) .OR. ABS(Y).GT.DXREL) GO TO 30 19141 IF (CABS((Z-AINT(X-0.5))/X).LT.DXREL) THEN 19142CCCCC CALL XERROR ( 'CPSI ANSWE 19143CCCCC1R LT HALF PRECISION BECAUSE Z TOO NEAR NEGATIVE INTEGER', 68, 1, 1 19144CCCCC2) 19145 WRITE(ICOUT,202) 19146 CALL DPWRST('XXX','BUG ') 19147 RETURN 19148 ENDIF 19149 202 FORMAT('***** INTERNAL ERROR FROM CPSI: ANSWER LESS THAN HALF', 19150 1' PRECISION BECAUSE ARGUMENT TOO NEAR A NEGATIVE INTEGER') 19151 IF (Y.EQ.0.0 .AND. X.EQ.AINT(X)) THEN 19152CCCCC CALL XERROR ( 'CPSI Z IS A NEG 19153CCCCC1ATIVE INTEGER', 31, 3, 2) 19154 WRITE(ICOUT,302) 19155 CALL DPWRST('XXX','BUG ') 19156 RETURN 19157 ENDIF 19158 302 FORMAT('***** INTERNAL ERROR FROM CPSI: ARGUMENT IS A ', 19159 1' NEGATIVE INTEGER') 19160C 19161 30 N = INT(SQRT(BOUND**2-Y**2) - X + 1.0) 19162 DO 40 I=1,N 19163 CORR = CORR - 1.0/Z 19164 Z = Z + 1.0 19165 40 CONTINUE 19166C 19167C NOW EVALUATE THE ASYMPTOTIC SERIES FOR SUITABLY LARGE Z. 19168C 19169 50 IF (CABSZ.GT.RBIG) CPSI = CLOG(Z) + CORR 19170 IF (CABSZ.GT.RBIG) GO TO 70 19171C 19172 CPSI = (0.0, 0.0) 19173 Z2INV = 1.0/Z**2 19174 DO 60 I=1,NTERM 19175 NDX = NTERM + 1 - I 19176 CPSI = BERN(NDX) + Z2INV*CPSI 19177 60 CONTINUE 19178 CPSI = CLOG(Z) - 0.5/Z - CPSI*Z2INV + CORR 19179C 19180 70 IF (Y.LT.0.0) CPSI = CONJG(CPSI) 19181C 19182 RETURN 19183 END 19184 SUBROUTINE CPU(X,N,ENGLSL,ENGUSL,IWRITE,XCPU,XLCL,XUCL, 19185 1 IBUGA3,IERROR) 19186C 19187C PURPOSE--THIS SUBROUTINE COMPUTES THE 19188C SAMPLE CPU (PROCESS CAPABILITY INDEX) 19189C OF THE DATA IN THE INPUT VECTOR X. 19190C CPU = NUMERATOR/DENOMINATOR 19191C WHERE NUMERATOR = XBAR + UPPER SPEC LIMIT 19192C AND DENOMINATOR = 3 * SIGMA 19193C NOTE--CPU IS A VARIATION OF CPK WHEN YOU ARE ONLY 19194C INTERESTED IN THE UPPER SPEC LIMIT. 19195C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 19196C (UNSORTED OR SORTED) OBSERVATIONS. 19197C --N = THE INTEGER NUMBER OF OBSERVATIONS 19198C IN THE VECTOR X. 19199C --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT 19200C --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT 19201C OUTPUT ARGUMENTS--CPU = THE SINGLE PRECISION VALUE OF THE 19202C COMPUTED SAMPLE CPU 19203C --XLCL = LOWER 95% CONFIDENCE LEVEL 19204C --XUCL = UPPER 95% CONFIDENCE LEVEL 19205C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE 19206C SAMPLE CPU INDEX 19207C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 19208C OF N FOR THIS SUBROUTINE. 19209C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 19210C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. 19211C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 19212C LANGUAGE--ANSI FORTRAN (1977) 19213C REFERENCES--R&M 2000 AIR FORCE MANUAL 19214C WRITTEN BY--JAMES J. FILLIBEN 19215C STATISTICAL ENGINEERING DIVISION 19216C INFORMATION TECHNOLOGY LABORATORY 19217C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 19218C GAITHERSBURG, MD 20899 19219C PHONE--301-975-2855 19220C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 19221C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 19222C LANGUAGE--ANSI FORTRAN (1977) 19223C VERSION NUMBER--2001.4 19224C ORIGINAL VERSION--APRIL 2001. 19225C 19226C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19227C 19228 CHARACTER*4 IWRITE 19229 CHARACTER*4 IBUGA3 19230 CHARACTER*4 IERROR 19231C 19232 CHARACTER*4 ISUBN1 19233 CHARACTER*4 ISUBN2 19234C 19235C--------------------------------------------------------------------- 19236C 19237 DOUBLE PRECISION DN 19238 DOUBLE PRECISION DX 19239 DOUBLE PRECISION DSUM 19240 DOUBLE PRECISION DMEAN 19241 DOUBLE PRECISION DVAR 19242 DOUBLE PRECISION DSD 19243C 19244 DOUBLE PRECISION DUSL 19245 DOUBLE PRECISION DLSL 19246 DOUBLE PRECISION DUPPER 19247 DOUBLE PRECISION DLOWER 19248 DOUBLE PRECISION DNUM 19249 DOUBLE PRECISION DDEN 19250 DOUBLE PRECISION DCPU 19251C 19252 DIMENSION X(*) 19253C 19254C--------------------------------------------------------------------- 19255C 19256 INCLUDE 'DPCOP2.INC' 19257C 19258C-----START POINT----------------------------------------------------- 19259C 19260 ISUBN1='CPU ' 19261 ISUBN2=' ' 19262 IERROR='NO' 19263C 19264 DMEAN=0.0D0 19265C 19266 IF(IBUGA3.EQ.'OFF')GOTO90 19267 WRITE(ICOUT,999) 19268 999 FORMAT(1X) 19269 CALL DPWRST('XXX','BUG ') 19270 WRITE(ICOUT,51) 19271 51 FORMAT('***** AT THE BEGINNING OF CPU--') 19272 CALL DPWRST('XXX','BUG ') 19273 WRITE(ICOUT,52)IBUGA3 19274 52 FORMAT('IBUGA3 = ',A4) 19275 CALL DPWRST('XXX','BUG ') 19276 WRITE(ICOUT,53)N 19277 53 FORMAT('N = ',I8) 19278 CALL DPWRST('XXX','BUG ') 19279 WRITE(ICOUT,54)ENGUSL,ENGLSL 19280 54 FORMAT('ENGUSL,ENGLSL = ',2E15.7) 19281 CALL DPWRST('XXX','BUG ') 19282 DO55I=1,N 19283 WRITE(ICOUT,56)I,X(I) 19284 56 FORMAT('I,X(I) = ',I8,E15.7) 19285 CALL DPWRST('XXX','BUG ') 19286 55 CONTINUE 19287 90 CONTINUE 19288C 19289C ******************************************** 19290C ** COMPUTE PROCESS CAPABILITY INDEX CPU ** 19291C ******************************************** 19292C 19293C ******************************************** 19294C ** STEP 1-- ** 19295C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 19296C ******************************************** 19297C 19298 AN=N 19299C 19300 IF(N.GE.1)GOTO119 19301 IERROR='YES' 19302 WRITE(ICOUT,999) 19303 CALL DPWRST('XXX','BUG ') 19304 WRITE(ICOUT,111) 19305 111 FORMAT('***** ERROR IN CPU--') 19306 CALL DPWRST('XXX','BUG ') 19307 WRITE(ICOUT,112) 19308 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') 19309 CALL DPWRST('XXX','BUG ') 19310 WRITE(ICOUT,113) 19311 113 FORMAT(' IN THE VARIABLE FOR WHICH') 19312 CALL DPWRST('XXX','BUG ') 19313 WRITE(ICOUT,114) 19314 114 FORMAT(' THE CPU STATISTIC IS TO BE COMPUTED') 19315 CALL DPWRST('XXX','BUG ') 19316 WRITE(ICOUT,115) 19317 115 FORMAT(' MUST BE 1 OR LARGER.') 19318 CALL DPWRST('XXX','BUG ') 19319 WRITE(ICOUT,116) 19320 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') 19321 CALL DPWRST('XXX','BUG ') 19322 WRITE(ICOUT,117)N 19323 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 19324 1'.') 19325 CALL DPWRST('XXX','BUG ') 19326 GOTO9000 19327 119 CONTINUE 19328C 19329 IF(N.EQ.1)GOTO120 19330 GOTO129 19331 120 CONTINUE 19332 XSD=0.0 19333 GOTO9000 19334 129 CONTINUE 19335C 19336 HOLD=X(1) 19337 DO135I=2,N 19338 IF(X(I).NE.HOLD)GOTO139 19339 135 CONTINUE 19340 XSD=0.0 19341 GOTO9000 19342 139 CONTINUE 19343C 19344C *************************************** 19345C ** STEP 2-- ** 19346C ** COMPUTE THE STANDARD DEVIATION. ** 19347C *************************************** 19348C 19349 DN=N 19350 DSUM=0.0D0 19351 DO200I=1,N 19352 DX=X(I) 19353 DSUM=DSUM+DX 19354 200 CONTINUE 19355 DMEAN=DSUM/DN 19356C 19357 DSUM=0.0D0 19358 DO300I=1,N 19359 DX=X(I) 19360 DSUM=DSUM+(DX-DMEAN)**2 19361 300 CONTINUE 19362 DVAR=DSUM/(DN-1.0D0) 19363 DSD=0.0D0 19364 IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR) 19365 XSD=DSD 19366C 19367C ************************************************** 19368C ** STEP 3-- ** 19369C ** COMPUTE THE CPU RATIO ** 19370C ************************************************** 19371C 19372 DUSL=ENGUSL 19373 DLSL=ENGLSL 19374C 19375 DUPPER=DUSL-DMEAN 19376 DLOWER=DMEAN-DLSL 19377C 19378 DNUM=DUPPER 19379C 19380 DDEN=3.0*DSD 19381C 19382 DCPU=0.0D0 19383 IF(DDEN.GT.0.0D0)DCPU=DNUM/DDEN 19384 XCPU=DCPU 19385C 19386 AN=REAL(N) 19387 P=0.975 19388 CALL NORPPF(P,PPF) 19389 XLCL=0.0 19390 XUCL=0.0 19391 IF(N.GT.1)THEN 19392 XLCL=XCPU - PPF*SQRT((1.0/(9.0*AN)) + XCPU/(2.0*(AN-1.0))) 19393 XUCL=XCPU + PPF*SQRT((1.0/(9.0*AN)) + XCPU/(2.0*(AN-1.0))) 19394 ENDIF 19395C 19396C ******************************* 19397C ** STEP 3-- ** 19398C ** WRITE OUT A LINE ** 19399C ** OF SUMMARY INFORMATION. ** 19400C ******************************* 19401C 19402 IF(IFEEDB.EQ.'OFF')GOTO890 19403 IF(IWRITE.EQ.'OFF')GOTO890 19404 WRITE(ICOUT,999) 19405 CALL DPWRST('XXX','BUG ') 19406 WRITE(ICOUT,811)N,XCPU 19407 811 FORMAT('THE CPK OF THE ',I8,' OBSERVATIONS = ', 19408 1E15.7) 19409 CALL DPWRST('XXX','BUG ') 19410 890 CONTINUE 19411C 19412C ***************** 19413C ** STEP 90-- ** 19414C ** EXIT. ** 19415C ***************** 19416C 19417 9000 CONTINUE 19418 IF(IBUGA3.EQ.'OFF')GOTO9090 19419 WRITE(ICOUT,999) 19420 CALL DPWRST('XXX','BUG ') 19421 WRITE(ICOUT,9011) 19422 9011 FORMAT('***** AT THE END OF CPU--') 19423 CALL DPWRST('XXX','BUG ') 19424 WRITE(ICOUT,9012)IBUGA3,IERROR 19425 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 19426 CALL DPWRST('XXX','BUG ') 19427 WRITE(ICOUT,9013)N 19428 9013 FORMAT('N = ',I8) 19429 CALL DPWRST('XXX','BUG ') 19430 WRITE(ICOUT,9014)DMEAN 19431 9014 FORMAT('DMEAN = ',D15.7) 19432 CALL DPWRST('XXX','BUG ') 19433 WRITE(ICOUT,9015)DSD 19434 9015 FORMAT('DSD = ',E15.7) 19435 CALL DPWRST('XXX','BUG ') 19436 WRITE(ICOUT,9016)DUSL,DLSL,DUPPER,DLOWER 19437 9016 FORMAT('DUSL,DLSL,DUPPER,DLOWER = ',4D15.7) 19438 CALL DPWRST('XXX','BUG ') 19439 WRITE(ICOUT,9017)DNUM,DDEN,DCPU,XCPU 19440 9017 FORMAT('DNUM,DDEN,DCPU,XCPU = ',3D15.7,E15.7) 19441 CALL DPWRST('XXX','BUG ') 19442 9090 CONTINUE 19443C 19444 RETURN 19445 END 19446 SUBROUTINE CPZERO(IN,A,R,T,IFLG,S) 19447C***BEGIN PROLOGUE CPZERO 19448C***DATE WRITTEN 810223 (YYMMDD) 19449C***REVISION DATE 860227 (YYMMDD) 19450C***CATEGORY NO. F1A1B 19451C***KEYWORDS COMPLEX,POLYNOMIAL ROOTS,ROOTS,ZEROES,ZEROS 19452C***AUTHOR KAHANER, D. K., (NBS) 19453C***PURPOSE Find the zeros of a polynomial with complex coefficients. 19454C***DESCRIPTION 19455C 19456C Find the zeros of the complex polynomial 19457C P(Z)= A(1)*Z**N + A(2)*Z**(N-1) +...+ A(N+1) 19458C 19459C Input... 19460C IN = degree of P(Z) 19461C A = complex vector containing coefficients of P(Z), 19462C A(I) = coefficient of Z**(N+1-i) 19463C R = N word complex vector containing initial estimates for zeros 19464C if these are known. 19465C T = 4(N+1) word array used for temporary storage 19466C IFLG = flag to indicate if initial estimates of 19467C zeros are input. 19468C If IFLG .EQ. 0, no estimates are input. 19469C If IFLG .NE. 0, the vector R contains estimates of 19470C the zeros 19471C ** WARNING ****** If estimates are input, they must 19472C be separated, that is, distinct or 19473C not repeated. 19474C S = an N word array 19475C 19476C Output... 19477C R(I) = Ith zero, 19478C S(I) = bound for R(I) . 19479C IFLG = error diagnostic 19480C Error Diagnostics... 19481C If IFLG .EQ. 0 on return, all is well 19482C If IFLG .EQ. 1 on return, A(1)=0.0 or N=0 on input 19483C If IFLG .EQ. 2 on return, the program failed to coverge 19484C after 25*N iterations. Best current estimates of the 19485C zeros are in R(I). Error bounds are not calculated. 19486C***REFERENCES (NONE) 19487C***ROUTINES CALLED CPEVL 19488C***END PROLOGUE CPZERO 19489C 19490CCCCC APRIL 1996. MAKE DUMMY DIMENSION "*" 19491CCCCC REAL S(1) 19492CCCCC COMPLEX R(1),T(1),A(1),PN,TEMP 19493 REAL S(*) 19494 COMPLEX R(*),T(*),A(*),PN,TEMP,PNTEMP(1),TEMP2(1) 19495C***FIRST EXECUTABLE STATEMENT CPZERO 19496 IF( IN .LE. 0 .OR. CABS(A(1)) .EQ. 0.0 ) GO TO 30 19497C 19498C CHECK FOR EASILY OBTAINED ZEROS 19499C 19500 N=IN 19501 N1=N+1 19502 IF(IFLG .NE. 0) GO TO 14 19503 1 CONTINUE 19504 N1=N+1 19505 IF(N .GT. 1) GO TO 2 19506 R(1)=-A(2)/A(1) 19507 S(1)=0.0 19508 RETURN 19509 2 CONTINUE 19510 IF( CABS(A(N1)) .NE. 0.0 ) GO TO 3 19511 R(N)=0.0 19512 S(N)=0.0 19513 N=N-1 19514 GO TO 1 19515C 19516C IF INITIAL ESTIMATES FOR ZEROS NOT GIVEN, FIND SOME 19517C 19518 3 CONTINUE 19519 TEMP=-A(2)/(A(1)*FLOAT(N)) 19520 CALL CPEVL(N,N,A,TEMP,T,T,.FALSE.) 19521 IMAX=N+2 19522 T(N1)=CABS(T(N1)) 19523 DO 6 I=2,N1 19524 T(N+I)=-CABS(T(N+2-I)) 19525 IF(REAL(T(N+I)) .LT. REAL(T(IMAX))) IMAX=N+I 19526 6 CONTINUE 19527 X=(-REAL(T(IMAX))/REAL(T(N1)))**(1./FLOAT(IMAX-N1)) 19528 7 CONTINUE 19529 X=2.*X 19530 CALL CPEVL(N,0,T(N1),CMPLX(X,0.0),PNTEMP,PNTEMP,.FALSE.) 19531 PN=PNTEMP(1) 19532 IF (REAL(PN).LT.0.) GO TO 7 19533 U=.5*X 19534 V=X 19535 10 CONTINUE 19536 X=.5*(U+V) 19537 CALL CPEVL(N,0,T(N1),CMPLX(X,0.0),PNTEMP,PNTEMP,.FALSE.) 19538 PN=PNTEMP(1) 19539 IF (REAL(PN).GT.0.) V=X 19540 IF (REAL(PN).LE.0.) U=X 19541 IF((V-U) .GT. .001*(1.+V)) GO TO 10 19542 DO 13 I=1,N 19543 U=(3.14159265/FLOAT(N))*(.5+2.*FLOAT(I-1)) 19544 R(I)=AMAX1(X,.001*CABS(TEMP))*CMPLX(COS(U),SIN(U))+TEMP 19545 13 CONTINUE 19546C 19547C MAIN ITERATION LOOP STARTS HERE 19548C 19549 14 CONTINUE 19550 NR=0 19551 NMAX=25*N 19552 DO 19 NIT=1,NMAX 19553 DO 18 I=1,N 19554 IF(NIT .NE. 1 .AND. CABS(T(I)) .EQ. 0.) GO TO 18 19555 CALL CPEVL(N,0,A,R(I),PNTEMP,TEMP2,.TRUE.) 19556 PN=PNTEMP(1) 19557 TEMP=TEMP2(1) 19558 IF(ABS(REAL(PN))+ABS(AIMAG(PN)) .GT. REAL(TEMP)+ 19559 1 AIMAG(TEMP)) GO TO 16 19560 T(I)=0.0 19561 NR=NR+1 19562 GO TO 18 19563 16 TEMP=A(1) 19564 DO 17 J=1,N 19565 IF(J .NE. I) TEMP=TEMP*(R(I)-R(J)) 19566 17 CONTINUE 19567 T(I)=PN/TEMP 19568 18 CONTINUE 19569 DO 15 I=1,N 19570 R(I)=R(I)-T(I) 19571 15 CONTINUE 19572 IF(NR .EQ. N) GO TO 21 19573 19 CONTINUE 19574 GO TO 26 19575C 19576C CALCULATE ERROR BOUNDS FOR ZEROS 19577C 19578 21 DO 25 NR=1,N 19579 CALL CPEVL(N,N,A,R(NR),T,T(N+2),.TRUE.) 19580 X=CABS(CMPLX(ABS(REAL(T(1))),ABS(AIMAG(T(1))))+T(N+2)) 19581 S(NR)=0.0 19582 DO 23 I=1,N 19583 X=X*FLOAT(N1-I)/FLOAT(I) 19584 TEMP=CMPLX(AMAX1(ABS(REAL(T(I+1)))-REAL(T(N1+I)),0.0), 19585 1 AMAX1(ABS(AIMAG(T(I+1)))-AIMAG(T(N1+I)),0.0)) 19586 S(NR)=AMAX1(S(NR),(CABS(TEMP)/X)**(1./FLOAT(I))) 19587 23 CONTINUE 19588 S(NR)=1./S(NR) 19589 25 CONTINUE 19590 IFLG=0 19591 RETURN 19592C ERROR EXITS 19593 26 CONTINUE 19594 IFLG=2 19595 RETURN 19596 30 CONTINUE 19597 IFLG=1 19598 RETURN 19599 END 19600 SUBROUTINE CRAMER(Y1,Y2,N,IWRITE,XIDTEM,XIDTE2,TEMP1,STAT, 19601 1 IBUGA3,IERROR) 19602C 19603C PURPOSE--THIS SUBROUTINE COMPUTES CRAMER'S COEFFICIENT 19604C FOR RXC CONTINGENCY TABLES. THIS IS 19605C 19606C SQRT(T/(N*(Q-1))) 19607C 19608C WHERE 19609C 19610C T = CHI-SQUARE STATISTIC 19611C = SUM[i=1 to r][SUM[j=1 to c] 19612C [(O(ij)-E(ij))**2/E(ij)]] 19613C 19614C O = OBSERVED COUNT 19615C E = EXPECTED COUNT 19616C = ROW TOTAL*COL TOTAL/GRAND TOTAL 19617C 19618C N = TOTAL NUMBER OF OBSERVATIONS 19619C Q = MIN(R,C) 19620C 19621C REFERENCE--CONOVER (1999), "PRACTICAL NONPARAMETRIC 19622C STATISTICS", THIRD EDITION, WILEY, PP. 229-230. 19623C NOTE--THIS SUBROUTINE HANDLES THE RAW DATA CASE. USE 19624C THE COMMAND 19625C 19626C LET A = MATRIX CRAMER CONTINGENCY COEFFICENT M 19627C 19628C IF YOUR DATA CONSISTS OF AN RXC TABLE. 19629C INPUT ARGUMENTS--Y1 = THE SINGLE PRECISION VECTOR OF 19630C (UNSORTED) OBSERVATIONS 19631C WHICH CONSTITUTE THE FIRST SET 19632C OF DATA. 19633C --Y2 = THE SINGLE PRECISION VECTOR OF 19634C (UNSORTED) OBSERVATIONS 19635C WHICH CONSTITUTE THE SECOND SET 19636C OF DATA. 19637C --N = THE INTEGER NUMBER OF OBSERVATIONS 19638C IN THE VECTOR X, OR EQUIVALENTLY, 19639C THE INTEGER NUMBER OF OBSERVATIONS 19640C IN THE VECTOR Y. 19641C OUTPUT ARGUMENTS--STAT = THE SINGLE PRECISION VALUE OF THE 19642C CRAMER'S CONTINGENCY COEFFICIENT 19643C BETWEEN THE 2 SETS OF DATA 19644C IN THE INPUT VECTORS X AND Y. 19645C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE 19646C SAMPLE CRAMER'S CONTINGENCY COEFFICENT BETWEEN THE 19647C 2 SETS OF DATA IN THE INPUT VECTORS X AND Y. 19648C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 19649C OF N FOR THIS SUBROUTINE. 19650C OTHER DATAPAC SUBROUTINES NEEDED--DISTIN. 19651C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 19652C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 19653C LANGUAGE--ANSI FORTRAN (1977) 19654C WRITTEN BY--JAMES J. FILLIBEN 19655C STATISTICAL ENGINEERING DIVISION 19656C INFORMATION TECHNOLOGY LABORATORY 19657C NATIONAL INSTIUTE OF STANDARDS AND TECHNOLOGY 19658C GAITHERSBURG, MD 20899-8980 19659C PHONE--301-975-2899 19660C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 19661C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 19662C LANGUAGE--ANSI FORTRAN (1977) 19663C VERSION NUMBER--2007/3 19664C ORIGINAL VERSION--MARCH 2007. 19665C 19666C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19667C 19668 CHARACTER*4 IWRITE 19669 CHARACTER*4 IBUGA3 19670 CHARACTER*4 IERROR 19671C 19672 CHARACTER*4 ISTEPN 19673 CHARACTER*4 ISUBN1 19674 CHARACTER*4 ISUBN2 19675C 19676C--------------------------------------------------------------------- 19677C 19678 PARAMETER(MAXLEV=20000) 19679 PARAMETER(IWORK1=0) 19680 PARAMETER(IWORK2=20000) 19681 PARAMETER(IWORK3=40000) 19682 PARAMETER(IWORK4=60000) 19683 PARAMETER(IWORK5=80000) 19684C 19685 DIMENSION Y1(*) 19686 DIMENSION Y2(*) 19687 DIMENSION XIDTEM(*) 19688 DIMENSION XIDTE2(*) 19689 DIMENSION TEMP1(*) 19690C 19691C--------------------------------------------------------------------- 19692C 19693 INCLUDE 'DPCOP2.INC' 19694C 19695C-----START POINT----------------------------------------------------- 19696C 19697 ISUBN1='CRAM' 19698 ISUBN2='ER ' 19699C 19700 IERROR='NO' 19701C 19702C 19703 IF(IBUGA3.EQ.'ON')THEN 19704 WRITE(ICOUT,999) 19705 999 FORMAT(1X) 19706 CALL DPWRST('XXX','BUG ') 19707 WRITE(ICOUT,51) 19708 51 FORMAT('***** AT THE BEGINNING OF CRAMER--') 19709 CALL DPWRST('XXX','BUG ') 19710 WRITE(ICOUT,52)IBUGA3 19711 52 FORMAT('IBUGA3 = ',A4) 19712 CALL DPWRST('XXX','BUG ') 19713 WRITE(ICOUT,53)N 19714 53 FORMAT('N = ',I8) 19715 CALL DPWRST('XXX','BUG ') 19716 DO55I=1,N 19717 WRITE(ICOUT,56)I,Y1(I),Y2(I) 19718 56 FORMAT('I,Y1(I),Y2(I) = ',I8,2G15.7) 19719 CALL DPWRST('XXX','BUG ') 19720 55 CONTINUE 19721 ENDIF 19722C 19723C ******************************************** 19724C ** STEP 21-- ** 19725C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 19726C ******************************************** 19727C 19728 ISTEPN='21' 19729 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19730C 19731 IF(N.LT.2)THEN 19732 WRITE(ICOUT,999) 19733 CALL DPWRST('XXX','WRIT') 19734 WRITE(ICOUT,1201) 19735 1201 FORMAT('****** ERROR IN CRAMER CONTINGENCY COEFFICIENT--') 19736 CALL DPWRST('XXX','WRIT') 19737 WRITE(ICOUT,2101) 19738 2101 FORMAT(' THE NUMBER OF OBSERVATIONS IS LESS THAN 2.') 19739 CALL DPWRST('XXX','WRIT') 19740 WRITE(ICOUT,2103)N 19741 2103 FORMAT('SAMPLE SIZE = ',I8) 19742 CALL DPWRST('XXX','WRIT') 19743 IERROR='YES' 19744 GOTO9000 19745 ENDIF 19746C 19747C ****************************************************** 19748C ** STEP 2.2-- ** 19749C ** DETERMINE THE NUMBER OF DISTINCT VALUES ** 19750C ** FOR THE GROUP VARIABLES (Y1, Y2). ** 19751C ****************************************************** 19752C 19753 ISTEPN='22' 19754 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19755C 19756 CALL DISTIN(Y1,N,IWRITE,XIDTEM,NUMSE1,IBUGA3,IERROR) 19757 CALL SORT(XIDTEM,NUMSE1,XIDTEM) 19758 CALL DISTIN(Y2,N,IWRITE,XIDTE2,NUMSE2,IBUGA3,IERROR) 19759 CALL SORT(XIDTE2,NUMSE2,XIDTE2) 19760C 19761 IF(NUMSE1.LT.1 .OR. NUMSE1.GT.MAXLEV)THEN 19762 WRITE(ICOUT,999) 19763 CALL DPWRST('XXX','BUG ') 19764 WRITE(ICOUT,1201) 19765 CALL DPWRST('XXX','BUG ') 19766 WRITE(ICOUT,2202)MAXLEV 19767 2202 FORMAT(' NUMBER OF SETS FOR VARIABLE ONE IS OUTSIDE ', 19768 1 'THE INTERVAL (1,',I8,')') 19769 CALL DPWRST('XXX','BUG ') 19770 WRITE(ICOUT,2204)NUMSE1 19771 2204 FORMAT(' THE NUMBER OF SET = ',I10) 19772 CALL DPWRST('XXX','BUG ') 19773 IERROR='YES' 19774 GOTO9000 19775 ENDIF 19776C 19777 IF(NUMSE2.LT.1 .OR. NUMSE2.GT.MAXLEV)THEN 19778 WRITE(ICOUT,999) 19779 CALL DPWRST('XXX','BUG ') 19780 WRITE(ICOUT,1201) 19781 CALL DPWRST('XXX','BUG ') 19782 WRITE(ICOUT,2212)MAXLEV 19783 2212 FORMAT(' NUMBER OF SETS FOR VARIABLE TWO IS OUTSIDE ', 19784 1 'THE INTERVAL (1,',I8,')') 19785 CALL DPWRST('XXX','BUG ') 19786 WRITE(ICOUT,2204)NUMSE2 19787 CALL DPWRST('XXX','BUG ') 19788 IERROR='YES' 19789 GOTO9000 19790 ENDIF 19791C 19792C *********************************************** 19793C ** STEP 2.3-- ** 19794C ** COMPUTE THE CHI-SQUARE STATISTIC ** 19795C *********************************************** 19796C 19797 ISTEPN='23' 19798 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 19799C 19800C COMPUTE COUNTS FOR EACH CELL 19801C 19802 J=0 19803 DO2310ISET1=1,NUMSE1 19804 DO2320ISET2=1,NUMSE2 19805C 19806 K=0 19807 DO2330I=1,N 19808 IF(XIDTEM(ISET1).EQ.Y1(I).AND.XIDTE2(ISET2).EQ.Y2(I))THEN 19809 K=K+1 19810 ENDIF 19811 2330 CONTINUE 19812 NTEMP=K 19813 J=J+1 19814 TEMP1(IWORK1+J)=REAL(K) 19815 TEMP1(IWORK2+J)=XIDTEM(ISET1) 19816 TEMP1(IWORK3+J)=XIDTE2(ISET2) 19817C 19818 2320 CONTINUE 19819 2310 CONTINUE 19820 NTEMP2=J 19821C 19822C COMPUTE ROW AND COLUMN TOTALS AND GRAND TOTAL. 19823C 19824 J=0 19825 GTOTAL=0.0 19826C 19827 DO2340ISET1=1,NUMSE1 19828 TEMP1(IWORK4+ISET1)=0.0 19829 DO2350ISET2=1,NUMSE2 19830 J=J+1 19831 TEMP1(IWORK4+ISET1)=TEMP1(IWORK4+ISET1) + TEMP1(IWORK1+J) 19832 GTOTAL=GTOTAL + TEMP1(IWORK1+J) 19833 2350 CONTINUE 19834C 19835 IF(IBUGA3.EQ.'ON')THEN 19836 WRITE(ICOUT,2352)ISET1,TEMP1(IWORK4+ISET1) 19837 2352 FORMAT('ISET1,ROWTOT(ISET1)=',I5,1X,G15.7) 19838 CALL DPWRST('XXX','BUG ') 19839 ENDIF 19840 2340 CONTINUE 19841C 19842 DO2360ISET2=1,NUMSE2 19843 TEMP1(IWORK5+ISET2)=0.0 19844 DO2370J=1,NTEMP2 19845 IF(TEMP1(IWORK3+J).EQ.XIDTE2(ISET2))THEN 19846 TEMP1(IWORK5+ISET2)=TEMP1(IWORK5+ISET2) + TEMP1(IWORK1+J) 19847 ENDIF 19848 2370 CONTINUE 19849C 19850 IF(IBUGA3.EQ.'ON')THEN 19851 WRITE(ICOUT,2372)ISET2,TEMP1(IWORK5+ISET2) 19852 2372 FORMAT('ISET2,COLTOT(ISET2)=',I5,1X,G15.7) 19853 CALL DPWRST('XXX','BUG ') 19854 ENDIF 19855C 19856 2360 CONTINUE 19857C 19858C NOW COMPUTE THE CHI-SQUARE TEST STATISTIC 19859C 19860 STAT=0.0 19861 J=0 19862C 19863 DO2380ISET1=1,NUMSE1 19864 DO2390ISET2=1,NUMSE2 19865 J=J+1 19866 EXP=TEMP1(IWORK4+ISET1)*TEMP1(IWORK5+ISET2)/GTOTAL 19867 STAT=STAT + (TEMP1(IWORK1+J) - EXP)**2/EXP 19868 2390 CONTINUE 19869 2380 CONTINUE 19870 T=STAT 19871 Q=REAL(MIN(NUMSE1,NUMSE2)) 19872 STAT=STAT/(GTOTAL*(Q-1.0)) 19873 STAT=SQRT(STAT) 19874C 19875C ******************************* 19876C ** STEP 3-- ** 19877C ** WRITE OUT A LINE ** 19878C ** OF SUMMARY INFORMATION. ** 19879C ******************************* 19880C 19881 IF(IFEEDB.EQ.'OFF')GOTO890 19882 IF(IWRITE.EQ.'OFF')GOTO890 19883 WRITE(ICOUT,999) 19884 CALL DPWRST('XXX','BUG ') 19885 WRITE(ICOUT,811)STAT 19886 811 FORMAT('THE CRAMER CONTINGENCY COEFFICIENT = ',G15.7) 19887 CALL DPWRST('XXX','BUG ') 19888 890 CONTINUE 19889C 19890C ***************** 19891C ** STEP 90-- ** 19892C ** EXIT. ** 19893C ***************** 19894C 19895 9000 CONTINUE 19896 IF(IBUGA3.EQ.'ON')THEN 19897 WRITE(ICOUT,999) 19898 CALL DPWRST('XXX','BUG ') 19899 WRITE(ICOUT,9011) 19900 9011 FORMAT('***** AT THE END OF CRAMER--') 19901 CALL DPWRST('XXX','BUG ') 19902 WRITE(ICOUT,9012)IBUGA3,IERROR 19903 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 19904 CALL DPWRST('XXX','BUG ') 19905 WRITE(ICOUT,9015)T,GTOTAL,Q,STAT 19906 9015 FORMAT('T,GTOTAL,Q,STAT = ',4G15.7) 19907 CALL DPWRST('XXX','BUG ') 19908 ENDIF 19909C 19910 RETURN 19911 END 19912 SUBROUTINE CRAME2(XMAT,MAXOBV,NR1,NC1,IWRITE, 19913 1 TEMP1,STAT, 19914 1 IBUGA3,IERROR) 19915C 19916C PURPOSE--THIS SUBROUTINE COMPUTES CRAMER'S COEFFICIENT 19917C FOR RXC CONTINGENCY TABLES. THIS IS 19918C 19919C SQRT(T/(N*(Q-1))) 19920C 19921C WHERE 19922C 19923C T = CHI-SQUARE STATISTIC 19924C = SUM[i=1 to r][SUM[j=1 to c] 19925C [(O(ij)-E(ij))**2/E(ij)]] 19926C 19927C O = OBSERVED COUNT 19928C E = EXPECTED COUNT 19929C = ROW TOTAL*COL TOTAL/GRAND TOTAL 19930C 19931C N = TOTAL NUMBER OF OBSERVATIONS 19932C Q = MIN(R,C) 19933C 19934C REFERENCE--CONOVER (1999), "PRACTICAL NONPARAMETRIC 19935C STATISTICS", THIRD EDITION, WILEY, PP. 229-230. 19936C NOTE--THIS SUBROUTINE HANDLES THE SUMMARY DATA CASE (I.E.. 19937C THE DATA IS GIVEN AS AN RXC TABLE). THE "CRAMER" 19938C SUBROUTINE IS USED FOR THE RAW DATA CASE. 19939C INPUT ARGUMENTS--XMAT = THE SINGLE PRECISION MATRIX OF 19940C OBSERVATIONS (RXC TABLE) 19941C --MAXOBV = THE INTEGER NUMBER THAT SPECIFIES 19942C THE MAXIMUM NUMBER OF ROWS IN THE 19943C MATRIX. 19944C --NR1 = THE INTEGER NUMBER OF ROWS 19945C IN THE MATRIX XMAT. 19946C --NC1 = THE INTEGER NUMBER OF COLUMNS 19947C IN THE MATRIX XMAT. 19948C OUTPUT ARGUMENTS--STAT = THE SINGLE PRECISION VALUE OF THE 19949C CRAMER'S CONTINGENCY COEFFICIENT 19950C OF THE DATA IN THE MATRIX XMAT. 19951C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE 19952C SAMPLE CRAMER'S CONTINGENCY COEFFICENT OF THE DATA 19953C IN THE MATRIX XMAT. 19954C RESTRICTIONS--THE MAXIMUM NUMBER OF LEVELS IS 50,000. 19955C OTHER DATAPAC SUBROUTINES NEEDED--DISTIN. 19956C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 19957C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 19958C LANGUAGE--ANSI FORTRAN (1977) 19959C WRITTEN BY--JAMES J. FILLIBEN 19960C STATISTICAL ENGINEERING DIVISION 19961C INFORMATION TECHNOLOGY LABORATORY 19962C NATIONAL INSTIUTE OF STANDARDS AND TECHNOLOGY 19963C GAITHERSBURG, MD 20899-8980 19964C PHONE--301-975-2899 19965C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 19966C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 19967C LANGUAGE--ANSI FORTRAN (1977) 19968C VERSION NUMBER--2007/3 19969C ORIGINAL VERSION--MARCH 2007. 19970C 19971C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19972C 19973 CHARACTER*4 IWRITE 19974 CHARACTER*4 IBUGA3 19975 CHARACTER*4 IERROR 19976C 19977 CHARACTER*4 ISTEPN 19978 CHARACTER*4 ISUBN1 19979 CHARACTER*4 ISUBN2 19980C 19981C--------------------------------------------------------------------- 19982C 19983 PARAMETER(MAXLEV=50000) 19984 PARAMETER(IWORK1=0) 19985 PARAMETER(IWORK2=50000) 19986C 19987 DIMENSION XMAT(MAXOBV,NC1) 19988 DIMENSION TEMP1(*) 19989C 19990C--------------------------------------------------------------------- 19991C 19992 INCLUDE 'DPCOP2.INC' 19993C 19994C-----START POINT----------------------------------------------------- 19995C 19996 ISUBN1='CRAM' 19997 ISUBN2='ER ' 19998 IERROR='NO' 19999C 20000C 20001 IF(IBUGA3.EQ.'ON')THEN 20002 WRITE(ICOUT,999) 20003 999 FORMAT(1X) 20004 CALL DPWRST('XXX','BUG ') 20005 WRITE(ICOUT,51) 20006 51 FORMAT('***** AT THE BEGINNING OF CRAME2--') 20007 CALL DPWRST('XXX','BUG ') 20008 WRITE(ICOUT,52)IBUGA3 20009 52 FORMAT('IBUGA3 = ',A4) 20010 CALL DPWRST('XXX','BUG ') 20011 WRITE(ICOUT,53)MAXOBV,NR1,NC1 20012 53 FORMAT('MAXOBV,NR1,NC1 = ',3I8) 20013 CALL DPWRST('XXX','BUG ') 20014 DO55I=1,NR1 20015 DO60J=1,NC1 20016 WRITE(ICOUT,56)I,J,XMAT(I,J) 20017 56 FORMAT('I,J,XMAT(I,J) = ',2I8,G15.7) 20018 CALL DPWRST('XXX','BUG ') 20019 60 CONTINUE 20020 55 CONTINUE 20021 ENDIF 20022C 20023C ******************************************** 20024C ** STEP 21-- ** 20025C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 20026C ******************************************** 20027C 20028 ISTEPN='21' 20029 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 20030C 20031 IF(NR1.LT.2 .OR. NR1.GT.MAXLEV)THEN 20032 WRITE(ICOUT,999) 20033 CALL DPWRST('XXX','WRIT') 20034 WRITE(ICOUT,1201) 20035 1201 FORMAT('****** ERROR IN MATRIX CRAMER CONTINGENCY ', 20036 1 'COEFFICIENT--') 20037 CALL DPWRST('XXX','WRIT') 20038 WRITE(ICOUT,2101) 20039 2101 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX IS LESS ', 20040 1 'THAN 2') 20041 CALL DPWRST('XXX','WRIT') 20042 WRITE(ICOUT,2102)MAXLEV 20043 2102 FORMAT(' OR GREATER THAN ',I10,'.') 20044 CALL DPWRST('XXX','WRIT') 20045 WRITE(ICOUT,2103)NR1 20046 2103 FORMAT('NUMBER OF ROWS = ',I8) 20047 CALL DPWRST('XXX','WRIT') 20048 IERROR='YES' 20049 GOTO9000 20050 ENDIF 20051C 20052 IF(NC1.LT.2 .OR. NC1.GT.MAXLEV)THEN 20053 WRITE(ICOUT,999) 20054 CALL DPWRST('XXX','WRIT') 20055 WRITE(ICOUT,1201) 20056 CALL DPWRST('XXX','WRIT') 20057 WRITE(ICOUT,2111) 20058 2111 FORMAT(' THE NUMBER OF COLUMNS IN THE MATRIX IS LESS ', 20059 1 'THAN 2') 20060 CALL DPWRST('XXX','WRIT') 20061 WRITE(ICOUT,2102)MAXLEV 20062 CALL DPWRST('XXX','WRIT') 20063 WRITE(ICOUT,2113)NC1 20064 2113 FORMAT('NUMBER OF COLUMNS = ',I8) 20065 CALL DPWRST('XXX','WRIT') 20066 IERROR='YES' 20067 GOTO9000 20068 ENDIF 20069C 20070 GTOTAL=0.0 20071 DO2120J=1,NC1 20072 DO2130I=1,NR1 20073 ITEMP=INT(XMAT(I,J)+0.5) 20074 IF(ITEMP.LT.0)THEN 20075 WRITE(ICOUT,999) 20076 CALL DPWRST('XXX','WRIT') 20077 WRITE(ICOUT,1201) 20078 CALL DPWRST('XXX','WRIT') 20079 WRITE(ICOUT,2131) 20080 2131 FORMAT(' A NEGATIVE COUNT WAS ENCOUNTERED IN THE ', 20081 1 'INPUT MATRIX.') 20082 CALL DPWRST('XXX','WRIT') 20083 WRITE(ICOUT,2133)I,J,ITEMP 20084 2133 FORMAT(' COUNT FOR ROW ',I8,' COLUMN ',I8,' = ',I8) 20085 CALL DPWRST('XXX','WRIT') 20086 IERROR='YES' 20087 GOTO9000 20088 ENDIF 20089 XMAT(I,J)=REAL(ITEMP) 20090 GTOTAL=GTOTAL + XMAT(I,J) 20091 2130 CONTINUE 20092 2120 CONTINUE 20093C 20094 IF(IBUGA3.EQ.'ON')THEN 20095 WRITE(ICOUT,2344)GTOTAL 20096 2344 FORMAT('GTOTAL = ',G15.7) 20097 CALL DPWRST('XXX','BUG ') 20098 ENDIF 20099C 20100C ****************************************************** 20101C ** STEP 2.2-- ** 20102C ** COMPUTE THE ROW AND COLUMN TOTALS. ** 20103C ****************************************************** 20104C 20105 ISTEPN='22' 20106 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 20107C 20108 DO2340ISET1=1,NR1 20109 TEMP1(IWORK1+ISET1)=0.0 20110 DO2350ISET2=1,NC1 20111 TEMP1(IWORK1+ISET1)=TEMP1(IWORK1+ISET1) + XMAT(ISET1,ISET2) 20112 IF(IBUGA3.EQ.'ON')THEN 20113 WRITE(ICOUT,2342)ISET1,ISET2,XMAT(ISET1,ISET2) 20114 2342 FORMAT('ISET1,ISET2,XMAT(I,J) =',2I8,G15.7) 20115 CALL DPWRST('XXX','BUG ') 20116 ENDIF 20117 2350 CONTINUE 20118C 20119 IF(IBUGA3.EQ.'ON')THEN 20120 WRITE(ICOUT,2352)ISET1,TEMP1(IWORK1+ISET1) 20121 2352 FORMAT('ISET1,ROWTOT(ISET1)=',I5,1X,G15.7) 20122 CALL DPWRST('XXX','BUG ') 20123 ENDIF 20124 2340 CONTINUE 20125C 20126 DO2360ISET2=1,NC1 20127 TEMP1(IWORK2+ISET2)=0.0 20128 DO2370ISET1=1,NR1 20129 TEMP1(IWORK2+ISET2)=TEMP1(IWORK2+ISET2) + XMAT(ISET1,ISET2) 20130 2370 CONTINUE 20131C 20132 IF(IBUGA3.EQ.'ON')THEN 20133 WRITE(ICOUT,2372)ISET2,TEMP1(IWORK2+ISET2) 20134 2372 FORMAT('ISET2,COLTOT(ISET2)=',I5,1X,G15.7) 20135 CALL DPWRST('XXX','BUG ') 20136 ENDIF 20137C 20138 2360 CONTINUE 20139C 20140C ****************************************************** 20141C ** STEP 2.3-- ** 20142C ** COMPUTE THE CHI-SQUARE STATISTIC. ** 20143C ****************************************************** 20144C 20145 ISTEPN='23' 20146 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 20147C 20148C NOW COMPUTE THE CHI-SQUARE TEST STATISTIC 20149C 20150 STAT=0.0 20151C 20152 DO2380ISET1=1,NR1 20153 DO2390ISET2=1,NC1 20154 EXP=TEMP1(IWORK1+ISET1)*TEMP1(IWORK2+ISET2)/GTOTAL 20155 STAT=STAT + (XMAT(ISET1,ISET2) - EXP)**2/EXP 20156 2390 CONTINUE 20157 2380 CONTINUE 20158 T=STAT 20159 Q=REAL(MIN(NR1,NC1)) 20160 STAT=STAT/(GTOTAL*(Q-1.0)) 20161 STAT=SQRT(STAT) 20162C 20163C ******************************* 20164C ** STEP 3-- ** 20165C ** WRITE OUT A LINE ** 20166C ** OF SUMMARY INFORMATION. ** 20167C ******************************* 20168C 20169 IF(IFEEDB.EQ.'OFF')GOTO890 20170 IF(IWRITE.EQ.'OFF')GOTO890 20171 WRITE(ICOUT,999) 20172 CALL DPWRST('XXX','BUG ') 20173 WRITE(ICOUT,811)STAT 20174 811 FORMAT('THE CRAMER CONTINGENCY COEFFICIENT = ',G15.7) 20175 CALL DPWRST('XXX','BUG ') 20176 890 CONTINUE 20177C 20178C ***************** 20179C ** STEP 90-- ** 20180C ** EXIT. ** 20181C ***************** 20182C 20183 9000 CONTINUE 20184 IF(IBUGA3.EQ.'ON')THEN 20185 WRITE(ICOUT,999) 20186 CALL DPWRST('XXX','BUG ') 20187 WRITE(ICOUT,9011) 20188 9011 FORMAT('***** AT THE END OF CRAME2--') 20189 CALL DPWRST('XXX','BUG ') 20190 WRITE(ICOUT,9012)IBUGA3,IERROR 20191 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 20192 CALL DPWRST('XXX','BUG ') 20193 WRITE(ICOUT,9015)T,GTOTAL,Q,STAT 20194 9015 FORMAT('T,GTOTAL,Q,STAT = ',4G15.7) 20195 CALL DPWRST('XXX','BUG ') 20196 ENDIF 20197C 20198 RETURN 20199 END 20200 FUNCTION CSEVL (X, CS, N) 20201C***BEGIN PROLOGUE CSEVL 20202C***PURPOSE Evaluate a Chebyshev series. 20203C***LIBRARY SLATEC (FNLIB) 20204C***CATEGORY C3A2 20205C***TYPE SINGLE PRECISION (CSEVL-S, DCSEVL-D) 20206C***KEYWORDS CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS 20207C***AUTHOR Fullerton, W., (LANL) 20208C***DESCRIPTION 20209C 20210C Evaluate the N-term Chebyshev series CS at X. Adapted from 20211C a method presented in the paper by Broucke referenced below. 20212C 20213C Input Arguments -- 20214C X value at which the series is to be evaluated. 20215C CS array of N terms of a Chebyshev series. In evaluating 20216C CS, only half the first coefficient is summed. 20217C N number of terms in array CS. 20218C 20219C***REFERENCES R. Broucke, Ten subroutines for the manipulation of 20220C Chebyshev series, Algorithm 446, Communications of 20221C the A.C.M. 16, (1973) pp. 254-256. 20222C L. Fox and I. B. Parker, Chebyshev Polynomials in 20223C Numerical Analysis, Oxford University Press, 1968, 20224C page 56. 20225C***ROUTINES CALLED R1MACH, XERMSG 20226C***REVISION HISTORY (YYMMDD) 20227C 770401 DATE WRITTEN 20228C 890831 Modified array declarations. (WRB) 20229C 890831 REVISION DATE from Version 3.2 20230C 891214 Prologue converted to Version 4.0 format. (BAB) 20231C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 20232C 900329 Prologued revised extensively and code rewritten to allow 20233C X to be slightly outside interval (-1,+1). (WRB) 20234C 920501 Reformatted the REFERENCES section. (WRB) 20235C***END PROLOGUE CSEVL 20236 REAL B0, B1, B2, CS(*), ONEPL, TWOX, X 20237 LOGICAL FIRST 20238 SAVE FIRST, ONEPL 20239C 20240C-----COMMON---------------------------------------------------------- 20241C 20242 INCLUDE 'DPCOMC.INC' 20243 INCLUDE 'DPCOP2.INC' 20244C 20245 DATA FIRST /.TRUE./ 20246C***FIRST EXECUTABLE STATEMENT CSEVL 20247C 20248 B0=0.0 20249 B2=0.0 20250C 20251 IF (FIRST) ONEPL = 1.0E0 + R1MACH(4) 20252 FIRST = .FALSE. 20253C 20254 IF (N .LT. 1) THEN 20255 WRITE(ICOUT,11) 20256 CALL DPWRST('XXX','BUG ') 20257 WRITE(ICOUT,12) 20258 CALL DPWRST('XXX','BUG ') 20259 CSEVL = 0.0 20260 RETURN 20261 ENDIF 20262 11 FORMAT('***** ERROR FROM CSEVL. THE NUMBER OF TERMS IS ') 20263 12 FORMAT(' LESS THAN OR EQUAL TO ZERO. *****') 20264 IF (N .GT. 1000) THEN 20265 WRITE(ICOUT,21) 20266 CALL DPWRST('XXX','BUG ') 20267 WRITE(ICOUT,22) 20268 CALL DPWRST('XXX','BUG ') 20269 CSEVL = 0.0 20270 RETURN 20271 ENDIF 20272 21 FORMAT('***** ERROR FROM CSEVL. THE NUMBER OF TERMS IS ') 20273 22 FORMAT(' GREATER THAN 1000. *****') 20274 IF (ABS(X) .GT. ONEPL) THEN 20275 WRITE(ICOUT,31) 20276 CALL DPWRST('XXX','BUG ') 20277 WRITE(ICOUT,32) 20278 CALL DPWRST('XXX','BUG ') 20279 ENDIF 20280 31 FORMAT('***** WARNING FROM CSEVL. X IS OUTSIDE THE ') 20281 32 FORMAT(' INTERVAL (-1,+1). *****') 20282C 20283 B1 = 0.0E0 20284 B0 = 0.0E0 20285 TWOX = 2.0*X 20286 DO 10 I = 1,N 20287 B2 = B1 20288 B1 = B0 20289 NI = N + 1 - I 20290 B0 = TWOX*B1 - B2 + CS(NI) 20291 10 CONTINUE 20292C 20293 CSEVL = 0.5E0*(B0-B2) 20294C 20295 RETURN 20296 END 20297 SUBROUTINE CUMAVE(X,NX,IWRITE,Y,IBUGA3,IERROR) 20298C 20299C PURPOSE--COMPUTE CUMULATIVE AVERAGE (MEAN) OF AN ARRAY 20300C NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.) 20301C BEING IDENTICAL TO THE INPUT VECTOR X(.). 20302C WRITTEN BY--JAMES J. FILLIBEN 20303C STATISTICAL ENGINEERING DIVISION 20304C INFORMATION TECHNOLOGY LABORATORY 20305C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 20306C GAITHERSBURG, MD 20899 20307C PHONE--301-975-2855 20308C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 20309C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 20310C LANGUAGE--ANSI FORTRAN (1977) 20311C VERSION NUMBER--98/5 20312C ORIGINAL VERSION--MAY 1998. 20313C 20314C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 20315C 20316 CHARACTER*4 IWRITE 20317 CHARACTER*4 IBUGA3 20318 CHARACTER*4 IERROR 20319C 20320 CHARACTER*4 ISUBN1 20321 CHARACTER*4 ISUBN2 20322C 20323 DOUBLE PRECISION DSUM 20324C 20325C--------------------------------------------------------------------- 20326C 20327 DIMENSION X(*) 20328 DIMENSION Y(*) 20329C 20330C--------------------------------------------------------------------- 20331C 20332 INCLUDE 'DPCOP2.INC' 20333C 20334C-----START POINT----------------------------------------------------- 20335C 20336 ISUBN1='CUMA' 20337 ISUBN2='VE ' 20338 IERROR='NO' 20339C 20340 IF(IBUGA3.EQ.'ON')THEN 20341 WRITE(ICOUT,999) 20342 999 FORMAT(1X) 20343 CALL DPWRST('XXX','BUG ') 20344 WRITE(ICOUT,51) 20345 51 FORMAT('***** AT THE BEGINNING OF CUMAVE--') 20346 CALL DPWRST('XXX','BUG ') 20347 WRITE(ICOUT,52)IBUGA3,IWRITE,NX 20348 52 FORMAT('IBUGA3,IWRITE,NX = ',2(A4,2X),I8) 20349 CALL DPWRST('XXX','BUG ') 20350 DO55I=1,NX 20351 WRITE(ICOUT,56)I,X(I) 20352 56 FORMAT('I,X(I) = ',I8,G15.7) 20353 CALL DPWRST('XXX','BUG ') 20354 55 CONTINUE 20355 ENDIF 20356C 20357C ************************************** 20358C ** COMPUTE CUMULATIVE AVERAGE ** 20359C ************************************** 20360C 20361 Y(1)=X(1) 20362 IF(NX.LT.2)GOTO9000 20363 DSUM=DBLE(Y(1)) 20364 DO100I=2,NX 20365 DSUM=DSUM + DBLE(X(I)) 20366 Y(I)=REAL(DSUM/DBLE(I)) 20367 100 CONTINUE 20368C 20369C ***************** 20370C ** STEP 90-- ** 20371C ** EXIT. ** 20372C ***************** 20373C 20374 9000 CONTINUE 20375C 20376 IF(IBUGA3.EQ.'OFF')GOTO9090 20377 WRITE(ICOUT,999) 20378 CALL DPWRST('XXX','BUG ') 20379 WRITE(ICOUT,9011) 20380 9011 FORMAT('***** AT THE END OF CUMAVE--') 20381 CALL DPWRST('XXX','BUG ') 20382 WRITE(ICOUT,9012)IBUGA3,IERROR 20383 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 20384 CALL DPWRST('XXX','BUG ') 20385 WRITE(ICOUT,9013)NX 20386 9013 FORMAT('NX = ',I8) 20387 CALL DPWRST('XXX','BUG ') 20388 DO9015I=1,NX 20389 WRITE(ICOUT,9016)I,X(I),Y(I) 20390 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) 20391 CALL DPWRST('XXX','BUG ') 20392 9015 CONTINUE 20393 9090 CONTINUE 20394C 20395 RETURN 20396 END 20397 SUBROUTINE CUMHAZ(X,TAG,NX,IWRITE,Y,XTEMP,MAXOBV,IBUGA3,IERROR) 20398C 20399C PURPOSE--COMPUTE CUMULATIVE HAZARD OF AN ARRAY 20400C THE TAG VARIABLE IDENTIFIES CENSORED DATA 20401C (1 = FAILURE TIME, 0 = CENSORED) 20402C NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.) 20403C BEING IDENTICAL TO THE INPUT VECTOR X(.). 20404C WRITTEN BY--JAMES J. FILLIBEN 20405C STATISTICAL ENGINEERING DIVISION 20406C INFORMATION TECHNOLOGY LABORATORY 20407C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 20408C GAITHERSBURG, MD 20899 20409C PHONE--301-975-2855 20410C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 20411C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 20412C LANGUAGE--ANSI FORTRAN (1977) 20413C VERSION NUMBER--98/5 20414C ORIGINAL VERSION--MAY 1998. 20415C UPDATED --JANUARY 2007. ARGUMENT LIST TO RANK 20416C 20417C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 20418C 20419 CHARACTER*4 IWRITE 20420 CHARACTER*4 IBUGA3 20421 CHARACTER*4 IERROR 20422C 20423 CHARACTER*4 ISUBN1 20424 CHARACTER*4 ISUBN2 20425C 20426 DOUBLE PRECISION DSUM 20427C 20428C--------------------------------------------------------------------- 20429C 20430 DIMENSION X(*) 20431 DIMENSION Y(*) 20432 DIMENSION TAG(*) 20433 DIMENSION XTEMP(*) 20434C 20435C--------------------------------------------------------------------- 20436C 20437 INCLUDE 'DPCOP2.INC' 20438C 20439C-----START POINT----------------------------------------------------- 20440C 20441 ISUBN1='CUMH' 20442 ISUBN2='AZ ' 20443C 20444 IERROR='NO' 20445C 20446 IF(IBUGA3.EQ.'OFF')GOTO90 20447 WRITE(ICOUT,999) 20448 999 FORMAT(1X) 20449 CALL DPWRST('XXX','BUG ') 20450 WRITE(ICOUT,51) 20451 51 FORMAT('***** AT THE BEGINNING OF CUMHAZ--') 20452 CALL DPWRST('XXX','BUG ') 20453 WRITE(ICOUT,52)IBUGA3 20454 52 FORMAT('IBUGA3 = ',A4) 20455 CALL DPWRST('XXX','BUG ') 20456 WRITE(ICOUT,53)NX 20457 53 FORMAT('NX = ',I8) 20458 CALL DPWRST('XXX','BUG ') 20459 DO55I=1,NX 20460 WRITE(ICOUT,56)I,X(I),TAG(I) 20461 56 FORMAT('I,X(I), TAG(I) = ',I8,2E15.7) 20462 CALL DPWRST('XXX','BUG ') 20463 55 CONTINUE 20464 90 CONTINUE 20465C 20466C ************************************** 20467C ** COMPUTE CUMULATIVE HAZARD ** 20468C ************************************** 20469C 20470 CALL SORTC(X,TAG,NX,Y,TAG) 20471 CALL RANK(Y,NX,IWRITE,Y,XTEMP,MAXOBV,IBUGA3,IERROR) 20472 IF(IERROR.EQ.'YES')GOTO9000 20473C 20474 AFACT=REAL(NX+1) 20475 DO100J=1,NX 20476 IF(ABS(TAG(J)).GE.0.5)THEN 20477 Y(J)=100./(AFACT - Y(J)) 20478 ELSE 20479 Y(J)=0.0 20480 ENDIF 20481 100 CONTINUE 20482C 20483 DSUM=0.0D0 20484 DO200I=1,NX 20485 DSUM=DSUM+DBLE(Y(I)) 20486 Y(I)=REAL(DSUM) 20487 200 CONTINUE 20488C 20489C ***************** 20490C ** STEP 90-- ** 20491C ** EXIT. ** 20492C ***************** 20493C 20494 9000 CONTINUE 20495C 20496 IF(IBUGA3.EQ.'OFF')GOTO9090 20497 WRITE(ICOUT,999) 20498 CALL DPWRST('XXX','BUG ') 20499 WRITE(ICOUT,9011) 20500 9011 FORMAT('***** AT THE END OF CUMHAZ--') 20501 CALL DPWRST('XXX','BUG ') 20502 WRITE(ICOUT,9012)IBUGA3,IERROR 20503 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 20504 CALL DPWRST('XXX','BUG ') 20505 WRITE(ICOUT,9013)NX 20506 9013 FORMAT('NX = ',2I8) 20507 CALL DPWRST('XXX','BUG ') 20508 DO9015I=1,NX 20509 WRITE(ICOUT,9016)I,X(I),Y(I) 20510 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) 20511 CALL DPWRST('XXX','BUG ') 20512 9015 CONTINUE 20513 9090 CONTINUE 20514C 20515 RETURN 20516 END 20517 SUBROUTINE CUMINT(Y,X,N,NUMVAR,IWRITE,Z,IBUGA3,IERROR) 20518C 20519C PURPOSE--COMPUTE CUMULATIVE INTEGRAL OF A VARIABLE. 20520C NOTE--IF THE VERTICAL AXIS VARIABLE IS Y(.) 20521C AND THE HORIZONTAL AXIS VARIABLE IS X(.), 20522C THEN THE OUTPUT VARIABLE CONTAINING THE 20523C CUMULATIVE INTEGRAL 20524C WILL BE COMPUTED AS FOLLOWS-- 20525C Z(1) = 0 20526C Z(2) = Z(1) + (Y(2)-Y(1))*(X(2)-X(1))/2 20527C Z(3) = Z(2) + Y(2)*(X(3)-X(2)) + (Y(3)-Y(2))*(X(3)-X(2))/2 20528C ETC. 20529C NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Z(.) 20530C BEING IDENTICAL TO THE INPUT VECTOR X(.) 20531C OR THE INPUT VECTORS X(.) AND Y(.). 20532C WRITTEN BY--JAMES J. FILLIBEN 20533C STATISTICAL ENGINEERING DIVISION 20534C INFORMATION TECHNOLOGY LABORATORY 20535C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 20536C GAITHERSBURG, MD 20899 20537C PHONE--301-975-2855 20538C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 20539C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 20540C LANGUAGE--ANSI FORTRAN (1977) 20541C VERSION NUMBER--82/7 20542C ORIGINAL VERSION--FEBRUARY 1979. 20543C UPDATED --APRIL 1979. 20544C UPDATED --JULY 1979. 20545C UPDATED --AUGUST 1981. 20546C UPDATED --MAY 1982. 20547C 20548C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 20549C 20550 CHARACTER*4 IWRITE 20551 CHARACTER*4 IBUGA3 20552 CHARACTER*4 IERROR 20553C 20554 CHARACTER*4 ISUBN1 20555 CHARACTER*4 ISUBN2 20556 CHARACTER*4 ISTEPN 20557C 20558C--------------------------------------------------------------------- 20559C 20560 DIMENSION Y(*) 20561 DIMENSION X(*) 20562 DIMENSION Z(*) 20563C 20564 DOUBLE PRECISION DINT 20565 DOUBLE PRECISION DXI 20566 DOUBLE PRECISION DYI 20567 DOUBLE PRECISION DXIM1 20568 DOUBLE PRECISION DYIM1 20569 DOUBLE PRECISION DDELX 20570 DOUBLE PRECISION DDELY 20571 DOUBLE PRECISION DTERM1 20572 DOUBLE PRECISION DTERM2 20573C 20574C--------------------------------------------------------------------- 20575C 20576 INCLUDE 'DPCOP2.INC' 20577C 20578C-----START POINT----------------------------------------------------- 20579C 20580 ISUBN1='CUMI' 20581 ISUBN2='NT ' 20582 IERROR='NO' 20583C 20584 DXI=0.0D0 20585C 20586 IF(IBUGA3.EQ.'ON')THEN 20587 WRITE(ICOUT,999) 20588 999 FORMAT(1X) 20589 CALL DPWRST('XXX','BUG ') 20590 WRITE(ICOUT,51) 20591 51 FORMAT('***** AT THE BEGINNING OF CUMINT--') 20592 CALL DPWRST('XXX','BUG ') 20593 WRITE(ICOUT,52)IBUGA3,IWRITE,N,NUMVAR 20594 52 FORMAT('IBUGA3,IWRITE,N,NUMVAR = ',2(A4,2X),2I8) 20595 CALL DPWRST('XXX','BUG ') 20596 DO55I=1,N 20597 WRITE(ICOUT,56)I,X(I),Y(I) 20598 56 FORMAT('I,X(I),Y(I) = ',I8,2G15.7) 20599 CALL DPWRST('XXX','BUG ') 20600 55 CONTINUE 20601 ENDIF 20602C 20603C **************************************************** 20604C ** CUMPUTE THE CUMULATIVE (NUMERICAL) INTEGRAL. ** 20605C **************************************************** 20606C 20607 ISTEPN='1' 20608 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 20609C 20610 DINT=0.0D0 20611 IF(N.LT.1)GOTO150 20612 IF(N.EQ.1)GOTO190 20613 I=1 20614 IF(NUMVAR.EQ.1)DXI=I 20615 IF(NUMVAR.EQ.2)DXI=X(I) 20616 DYI=Y(1) 20617 Z(1)=0.0 20618 DO100I=2,N 20619 DXIM1=DXI 20620 DYIM1=DYI 20621 IF(NUMVAR.EQ.1)DXI=I 20622 IF(NUMVAR.EQ.2)DXI=X(I) 20623 DYI=Y(I) 20624 DDELX=DXI-DXIM1 20625 DDELY=DYI-DYIM1 20626 DTERM1=DYIM1*DDELX 20627 DTERM2=DDELY*DDELX/2.0D0 20628 DINT=DINT+DTERM1+DTERM2 20629 Z(I)=DINT 20630 100 CONTINUE 20631 GOTO190 20632C 20633 150 CONTINUE 20634 IERROR='YES' 20635 WRITE(ICOUT,999) 20636 CALL DPWRST('XXX','BUG ') 20637 WRITE(ICOUT,151) 20638 151 FORMAT('***** ERROR IN CUMINT--') 20639 CALL DPWRST('XXX','BUG ') 20640 WRITE(ICOUT,152) 20641 152 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') 20642 CALL DPWRST('XXX','BUG ') 20643 WRITE(ICOUT,153) 20644 153 FORMAT(' IN THE VARIABLE FOR WHICH') 20645 CALL DPWRST('XXX','BUG ') 20646 WRITE(ICOUT,154) 20647 154 FORMAT(' THE CUMULATIVE INTEGRAL IS TO BE COMPUTED') 20648 CALL DPWRST('XXX','BUG ') 20649 WRITE(ICOUT,155) 20650 155 FORMAT(' MUST BE 1 OR LARGER.') 20651 CALL DPWRST('XXX','BUG ') 20652 WRITE(ICOUT,156) 20653 156 FORMAT(' SUCH WAS NOT THE CASE HERE.') 20654 CALL DPWRST('XXX','BUG ') 20655 WRITE(ICOUT,157)N 20656 157 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 20657 1'.') 20658 CALL DPWRST('XXX','BUG ') 20659 190 CONTINUE 20660C 20661C ***************** 20662C ** STEP 90-- ** 20663C ** EXIT. ** 20664C ***************** 20665C 20666 IF(IBUGA3.EQ.'ON')THEN 20667 WRITE(ICOUT,999) 20668 CALL DPWRST('XXX','BUG ') 20669 WRITE(ICOUT,9011) 20670 9011 FORMAT('***** AT THE END OF CUMINT--') 20671 CALL DPWRST('XXX','BUG ') 20672 WRITE(ICOUT,9012)IBUGA3,IERROR,N,NUMVAR 20673 9012 FORMAT('IBUGA3,IERROR,N,NUMVAR = ',2(A4,2X),2I8) 20674 CALL DPWRST('XXX','BUG ') 20675 DO9015I=1,N 20676 WRITE(ICOUT,9016)I,X(I),Y(I),Z(I) 20677 9016 FORMAT('I,X(I),Y(I),Z(I) = ',I8,3G15.7) 20678 CALL DPWRST('XXX','BUG ') 20679 9015 CONTINUE 20680 ENDIF 20681C 20682 RETURN 20683 END 20684 SUBROUTINE CUMMAX(X,N,IWRITE,Y,IBUGA3,ISUBRO,IERROR) 20685C 20686C PURPOSE--COMPUTE CUMULATIVE MAXIMUM OF A VARIABLE 20687C NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.) 20688C BEING IDENTICAL TO THE INPUT VECTOR X(.). 20689C WRITTEN BY--ALAN HECKERT 20690C STATISTICAL ENGINEERING DIVISION 20691C INFORMATION TECHNOLOGY LABORATORY 20692C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 20693C GAITHERSBURG, MD 20899 20694C PHONE--301-975-2899 20695C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 20696C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 20697C LANGUAGE--ANSI FORTRAN (1977) 20698C VERSION NUMBER--2012/12 20699C ORIGINAL VERSION--DECEMBER 2012. 20700C 20701C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 20702C 20703 CHARACTER*4 IWRITE 20704 CHARACTER*4 IBUGA3 20705 CHARACTER*4 ISUBRO 20706 CHARACTER*4 IERROR 20707C 20708 CHARACTER*4 ISUBN1 20709 CHARACTER*4 ISUBN2 20710C 20711C--------------------------------------------------------------------- 20712C 20713 DIMENSION X(*) 20714 DIMENSION Y(*) 20715C 20716C--------------------------------------------------------------------- 20717C 20718 INCLUDE 'DPCOP2.INC' 20719C 20720C-----START POINT----------------------------------------------------- 20721C 20722 ISUBN1='CUMM' 20723 ISUBN2='IN ' 20724 IERROR='NO' 20725C 20726 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MMAX')THEN 20727 WRITE(ICOUT,999) 20728 999 FORMAT(1X) 20729 CALL DPWRST('XXX','BUG ') 20730 WRITE(ICOUT,51) 20731 51 FORMAT('***** AT THE BEGINNING OF CUMMAX--') 20732 CALL DPWRST('XXX','BUG ') 20733 WRITE(ICOUT,52)IBUGA3,IWRITE,N 20734 52 FORMAT('IBUGA3,IWRITE,N = ',2(A4,2X),I8) 20735 CALL DPWRST('XXX','BUG ') 20736 DO55I=1,N 20737 WRITE(ICOUT,56)I,X(I) 20738 56 FORMAT('I,X(I) = ',I8,G15.7) 20739 CALL DPWRST('XXX','BUG ') 20740 55 CONTINUE 20741 ENDIF 20742C 20743C *********************************** 20744C ** COMPUTE CUMULATIVE MAXIMUM. ** 20745C *********************************** 20746C 20747 IF(N.LT.1)THEN 20748 IERROR='YES' 20749 WRITE(ICOUT,999) 20750 CALL DPWRST('XXX','BUG ') 20751 WRITE(ICOUT,151) 20752 151 FORMAT('***** ERROR IN CUMULATIVE MAXIMUM--') 20753 CALL DPWRST('XXX','BUG ') 20754 WRITE(ICOUT,152) 20755 152 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR THE') 20756 CALL DPWRST('XXX','BUG ') 20757 WRITE(ICOUT,153) 20758 153 FORMAT(' RESPONSE VARIABLE IS LESS THAN 1.') 20759 CALL DPWRST('XXX','BUG ') 20760 WRITE(ICOUT,157)N 20761 157 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 20762 1 '.') 20763 CALL DPWRST('XXX','BUG ') 20764C 20765 ELSE 20766C 20767 Y(1)=X(1) 20768 YMAX=Y(1) 20769 DO100I=1,N 20770 IF(X(I).GT.YMAX)THEN 20771 Y(I)=X(I) 20772 YMAX=Y(I) 20773 ELSE 20774 Y(I)=YMAX 20775 ENDIF 20776 100 CONTINUE 20777 ENDIF 20778C 20779C ***************** 20780C ** STEP 90-- ** 20781C ** EXIT. ** 20782C ***************** 20783C 20784 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MMAX')THEN 20785 WRITE(ICOUT,999) 20786 CALL DPWRST('XXX','BUG ') 20787 WRITE(ICOUT,9011) 20788 9011 FORMAT('***** AT THE END OF CUMMAX--') 20789 CALL DPWRST('XXX','BUG ') 20790 WRITE(ICOUT,9012)IERROR 20791 9012 FORMAT('IERROR = ',A4) 20792 CALL DPWRST('XXX','BUG ') 20793 DO9015I=1,N 20794 WRITE(ICOUT,9016)I,X(I),Y(I) 20795 9016 FORMAT('I,X(I),Y(I) = ',I8,2G15.7) 20796 CALL DPWRST('XXX','BUG ') 20797 9015 CONTINUE 20798 ENDIF 20799C 20800 RETURN 20801 END 20802 SUBROUTINE CUMMIN(X,N,IWRITE,Y,IBUGA3,ISUBRO,IERROR) 20803C 20804C PURPOSE--COMPUTE CUMULATIVE MINIMUM OF A VARIABLE 20805C NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.) 20806C BEING IDENTICAL TO THE INPUT VECTOR X(.). 20807C WRITTEN BY--ALAN HECKERT 20808C STATISTICAL ENGINEERING DIVISION 20809C INFORMATION TECHNOLOGY LABORATORY 20810C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 20811C GAITHERSBURG, MD 20899 20812C PHONE--301-975-2899 20813C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 20814C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 20815C LANGUAGE--ANSI FORTRAN (1977) 20816C VERSION NUMBER--2012/12 20817C ORIGINAL VERSION--DECEMBER 2012. 20818C 20819C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 20820C 20821 CHARACTER*4 IWRITE 20822 CHARACTER*4 IBUGA3 20823 CHARACTER*4 ISUBRO 20824 CHARACTER*4 IERROR 20825C 20826 CHARACTER*4 ISUBN1 20827 CHARACTER*4 ISUBN2 20828C 20829C--------------------------------------------------------------------- 20830C 20831 DIMENSION X(*) 20832 DIMENSION Y(*) 20833C 20834C--------------------------------------------------------------------- 20835C 20836 INCLUDE 'DPCOP2.INC' 20837C 20838C-----START POINT----------------------------------------------------- 20839C 20840 ISUBN1='CUMM' 20841 ISUBN2='IN ' 20842 IERROR='NO' 20843C 20844 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MMIN')THEN 20845 WRITE(ICOUT,999) 20846 999 FORMAT(1X) 20847 CALL DPWRST('XXX','BUG ') 20848 WRITE(ICOUT,51) 20849 51 FORMAT('***** AT THE BEGINNING OF CUMMIN--') 20850 CALL DPWRST('XXX','BUG ') 20851 WRITE(ICOUT,52)IBUGA3,IWRITE,N 20852 52 FORMAT('IBUGA3,IWRITE,N = ',2(A4,2X),I8) 20853 CALL DPWRST('XXX','BUG ') 20854 DO55I=1,N 20855 WRITE(ICOUT,56)I,X(I) 20856 56 FORMAT('I,X(I) = ',I8,G15.7) 20857 CALL DPWRST('XXX','BUG ') 20858 55 CONTINUE 20859 ENDIF 20860C 20861C *********************************** 20862C ** COMPUTE CUMULATIVE MINIMUM. ** 20863C *********************************** 20864C 20865 IF(N.LT.1)THEN 20866 IERROR='YES' 20867 WRITE(ICOUT,999) 20868 CALL DPWRST('XXX','BUG ') 20869 WRITE(ICOUT,151) 20870 151 FORMAT('***** ERROR IN CUMULATIVE MINIMUM--') 20871 CALL DPWRST('XXX','BUG ') 20872 WRITE(ICOUT,152) 20873 152 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR THE') 20874 CALL DPWRST('XXX','BUG ') 20875 WRITE(ICOUT,153) 20876 153 FORMAT(' RESPONSE VARIABLE IS LESS THAN 1.') 20877 CALL DPWRST('XXX','BUG ') 20878 WRITE(ICOUT,157)N 20879 157 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 20880 1 '.') 20881 CALL DPWRST('XXX','BUG ') 20882C 20883 ELSE 20884C 20885 Y(1)=X(1) 20886 YMIN=Y(1) 20887 DO100I=1,N 20888 IF(X(I).LT.YMIN)THEN 20889 Y(I)=X(I) 20890 YMIN=Y(I) 20891 ELSE 20892 Y(I)=YMIN 20893 ENDIF 20894 100 CONTINUE 20895 ENDIF 20896C 20897C ***************** 20898C ** STEP 90-- ** 20899C ** EXIT. ** 20900C ***************** 20901C 20902 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MMIN')THEN 20903 WRITE(ICOUT,999) 20904 CALL DPWRST('XXX','BUG ') 20905 WRITE(ICOUT,9011) 20906 9011 FORMAT('***** AT THE END OF CUMMIN--') 20907 CALL DPWRST('XXX','BUG ') 20908 WRITE(ICOUT,9012)IERROR 20909 9012 FORMAT('IERROR = ',A4) 20910 CALL DPWRST('XXX','BUG ') 20911 DO9015I=1,N 20912 WRITE(ICOUT,9016)I,X(I),Y(I) 20913 9016 FORMAT('I,X(I),Y(I) = ',I8,2G15.7) 20914 CALL DPWRST('XXX','BUG ') 20915 9015 CONTINUE 20916 ENDIF 20917C 20918 RETURN 20919 END 20920 SUBROUTINE CUMPRO(X,N,IWRITE,Y,IBUGA3,IERROR) 20921C 20922C PURPOSE--COMPUTE CUMULATIVE PRODUCT OF A VARIABLE-- 20923C Y(1) = X(1) 20924C Y(2) = X(1) * X(2) 20925C Y(3) = X(1) * X(2) * X(3) 20926C ETC. 20927C NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.) 20928C BEING IDENTICAL TO THE INPUT VECTOR X(.). 20929C WRITTEN BY--JAMES J. FILLIBEN 20930C STATISTICAL ENGINEERING DIVISION 20931C INFORMATION TECHNOLOGY LABORATORY 20932C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 20933C GAITHERSBURG, MD 20899 20934C PHONE--301-975-2855 20935C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 20936C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 20937C LANGUAGE--ANSI FORTRAN (1977) 20938C VERSION NUMBER--82/7 20939C ORIGINAL VERSION--APRIL 1979. 20940C UPDATED --JULY 1979. 20941C UPDATED --AUGUST 1981. 20942C UPDATED --MAY 1982. 20943C 20944C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 20945C 20946 CHARACTER*4 IWRITE 20947 CHARACTER*4 IBUGA3 20948 CHARACTER*4 IERROR 20949C 20950 CHARACTER*4 ISUBN1 20951 CHARACTER*4 ISUBN2 20952C 20953C--------------------------------------------------------------------- 20954C 20955 DIMENSION X(*) 20956 DIMENSION Y(*) 20957C 20958 DOUBLE PRECISION DPROD 20959 DOUBLE PRECISION DX 20960C 20961C--------------------------------------------------------------------- 20962C 20963 INCLUDE 'DPCOP2.INC' 20964C 20965C-----START POINT----------------------------------------------------- 20966C 20967 ISUBN1='CUMP' 20968 ISUBN2='RO ' 20969 IERROR='NO' 20970C 20971 IF(IBUGA3.EQ.'ON')THEN 20972 WRITE(ICOUT,999) 20973 999 FORMAT(1X) 20974 CALL DPWRST('XXX','BUG ') 20975 WRITE(ICOUT,51) 20976 51 FORMAT('***** AT THE BEGINNING OF CUMPRO--') 20977 CALL DPWRST('XXX','BUG ') 20978 WRITE(ICOUT,52)IBUGA3,IWRITE,N 20979 52 FORMAT('IBUGA3,IWRITE,N = ',2(A4,2X),I8) 20980 CALL DPWRST('XXX','BUG ') 20981 DO55I=1,N 20982 WRITE(ICOUT,56)I,X(I) 20983 56 FORMAT('I,X(I) = ',I8,G15.7) 20984 CALL DPWRST('XXX','BUG ') 20985 55 CONTINUE 20986 ENDIF 20987C 20988C *********************************** 20989C ** COMPUTE CUMULATIVE PRODUCT. ** 20990C *********************************** 20991C 20992 DPROD=1.0D0 20993 IF(N.LT.1)THEN 20994 IERROR='YES' 20995 WRITE(ICOUT,999) 20996 CALL DPWRST('XXX','BUG ') 20997 WRITE(ICOUT,151) 20998 151 FORMAT('***** ERROR IN CUMULATIVE PRODUCT--') 20999 CALL DPWRST('XXX','BUG ') 21000 WRITE(ICOUT,152) 21001 152 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR THE') 21002 CALL DPWRST('XXX','BUG ') 21003 WRITE(ICOUT,153) 21004 153 FORMAT(' RESPONSE VARIABLE IS LESS THAN 1.') 21005 CALL DPWRST('XXX','BUG ') 21006 WRITE(ICOUT,157)N 21007 157 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 21008 1 '.') 21009 CALL DPWRST('XXX','BUG ') 21010 ELSE 21011 DO100I=1,N 21012 DX=X(I) 21013 DPROD=DPROD*DX 21014 Y(I)=DPROD 21015 100 CONTINUE 21016 ENDIF 21017C 21018C ***************** 21019C ** STEP 90-- ** 21020C ** EXIT. ** 21021C ***************** 21022C 21023 IF(IBUGA3.EQ.'ON')THEN 21024 WRITE(ICOUT,999) 21025 CALL DPWRST('XXX','BUG ') 21026 WRITE(ICOUT,9011) 21027 9011 FORMAT('***** AT THE END OF CUMPRO--') 21028 CALL DPWRST('XXX','BUG ') 21029 WRITE(ICOUT,9012)IERROR 21030 9012 FORMAT('IERROR = ',A4) 21031 CALL DPWRST('XXX','BUG ') 21032 DO9015I=1,N 21033 WRITE(ICOUT,9016)I,X(I),Y(I) 21034 9016 FORMAT('I,X(I),Y(I) = ',I8,2G15.7) 21035 CALL DPWRST('XXX','BUG ') 21036 9015 CONTINUE 21037 ENDIF 21038C 21039 RETURN 21040 END 21041 SUBROUTINE CUMSTA(Y1,Y2,Y3,N,NUMV,ICASS7,MAXNXT, 21042 1 ISEED,ICSTSV, 21043 1 TEMP1,TEMP2,TEMP3, 21044 1 ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 21045 1 DTEMP1,DTEMP2,DTEMP3, 21046 1 YOUT,NOUT, 21047 1 ISUBRO,IBUGA3,IERROR) 21048C 21049C PURPOSE--COMPUTE A "CUMULATIVE" STATISTIC. ALTHOUGH THIS IS TYPICALLY 21050C USED FOR A LOCATION STATISTIC, IN CAN BE USED FOR ANY 21051C SUPPORTED STATISTIC. NOTE THAT A FEW SPECIFIC STATISTICS 21052C ARE GENERATED SEPARATELY FROM THIS SUBROUTINE. THESE 21053C ARE TYPICALLY GENERATED MORE EFFICIENTLY THAN THIS ROUTINE 21054C WHICH SIMPLY LOOPS THROUGH THE ARRAY AND CALLS CMPSTA TO 21055C COMPUTE THE STATISTIC. 21056C WRITTEN BY--ALAN HECKERT 21057C STATISTICAL ENGINEERING DIVISION 21058C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 21059C GAITHERSBURG, MD 20899-8980 21060C PHONE--301-975-2899 21061C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 21062C OF THE NATIONAL BUREAU OF STANDARDS. 21063C LANGUAGE--ANSI FORTRAN (1977) 21064C VERSION NUMBER--2013/01 21065C ORIGINAL VERSION--JANUARY 2013. 21066C UPDATED --MARCH 2013. CUMULATIVE STATISTIC START 21067C 21068C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 21069C 21070 CHARACTER*4 ICASS7 21071 CHARACTER*4 ISUBRO 21072 CHARACTER*4 IBUGA3 21073 CHARACTER*4 IERROR 21074C 21075 CHARACTER*4 ISUBN1 21076 CHARACTER*4 ISUBN2 21077C 21078C--------------------------------------------------------------------- 21079C 21080 DIMENSION Y1(*) 21081 DIMENSION Y2(*) 21082 DIMENSION Y3(*) 21083 DIMENSION YOUT(*) 21084C 21085 DIMENSION TEMP1(*) 21086 DIMENSION TEMP2(*) 21087 DIMENSION TEMP3(*) 21088 INTEGER ITEMP1(*) 21089 INTEGER ITEMP2(*) 21090 INTEGER ITEMP3(*) 21091 INTEGER ITEMP4(*) 21092 INTEGER ITEMP5(*) 21093 INTEGER ITEMP6(*) 21094 DOUBLE PRECISION DTEMP1(*) 21095 DOUBLE PRECISION DTEMP2(*) 21096 DOUBLE PRECISION DTEMP3(*) 21097C 21098C--------------------------------------------------------------------- 21099C 21100 INCLUDE 'DPCOP2.INC' 21101C 21102C-----START POINT----------------------------------------------------- 21103C 21104 ISUBN1='CUMS' 21105 ISUBN2='TA ' 21106C 21107 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MSTA')THEN 21108 WRITE(ICOUT,70) 21109 70 FORMAT('AT THE BEGINNING OF CUMSTA--') 21110 CALL DPWRST('XXX','BUG ') 21111 WRITE(ICOUT,71)ICASS7,N,ICSTSV 21112 71 FORMAT('ICASS7,N,ICSTSV = ',A4,2X,2I8) 21113 CALL DPWRST('XXX','BUG ') 21114 DO75I=1,N 21115 WRITE(ICOUT,73)I,Y1(I),Y2(I),Y3(I) 21116 73 FORMAT('I,Y1(I),Y2(I),Y3(I) = ',I8,3G15.7) 21117 CALL DPWRST('XXX','BUG ') 21118 75 CONTINUE 21119 ENDIF 21120C 21121C CHECK THE INPUT ARGUMENTS FOR ERRORS 21122C 21123 IF(N.LT.2)THEN 21124 WRITE(ICOUT,999) 21125 999 FORMAT(1X) 21126 CALL DPWRST('XXX','BUG ') 21127 WRITE(ICOUT,31) 21128 31 FORMAT('***** ERROR IN CUMULATIVE <STAT> COMMAND--') 21129 CALL DPWRST('XXX','BUG ') 21130 WRITE(ICOUT,32) 21131 32 FORMAT(' THE NUMBER OF OBSERVATIONS IS LESS THAN TWO.') 21132 CALL DPWRST('XXX','BUG ') 21133 WRITE(ICOUT,34)N 21134 34 FORMAT(' THE NUMBER OF OBSERVATIONS = ',I8) 21135 CALL DPWRST('XXX','BUG ') 21136 WRITE(ICOUT,999) 21137 CALL DPWRST('XXX','BUG ') 21138 IERROR='YES' 21139 GOTO9000 21140 ENDIF 21141C 21142C ****************************************************** 21143C ** STEP 1--LOOP THROUGH AND COMPUTE THE STATISTIC ** 21144C ****************************************************** 21145C 21146C MARCH 2013: SOME STATISTICS REQUIRE A MINIMUM NUMBER OF VALUES 21147C IN ORDER TO COMPUTE. USER CAN ENTER THE COMMAND 21148C 21149C SET CUMULATIVE STATISTIC START <IVAL> 21150C 21151C TO SPECIFY A MINIMUM NUMBER OF VALUES BEFORE START 21152C COMPUTING THE STATISTIC. 21153C 21154 NOUT=0 21155 ISTRT=ICSTSV 21156 IF(ISTRT.LT.1 .OR. ISTRT.GT.N)ISTRT=1 21157 DO1010I=ISTRT,N 21158 NTEMP=I 21159 CALL CMPSTA(Y1,Y2,Y3,TEMP1,TEMP2,TEMP3, 21160 1 MAXNXT,NTEMP,NTEMP,NTEMP,NUMV,ICASS7, 21161 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 21162 1 DTEMP1,DTEMP2,DTEMP3, 21163CCCCC1 IQUAME,IQUASE,PSTAMV, 21164 1 STAT, 21165 1 ISUBRO,IBUGA3,IERROR) 21166 IF(IERROR.EQ.'YES')GOTO9000 21167 NOUT=NOUT+1 21168 YOUT(NOUT)=STAT 21169 1010 CONTINUE 21170C 21171C ****************** 21172C ** STEP 90-- ** 21173C ** EXIT ** 21174C ****************** 21175C 21176 9000 CONTINUE 21177 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MSTA')THEN 21178 WRITE(ICOUT,999) 21179 CALL DPWRST('XXX','BUG ') 21180 WRITE(ICOUT,9011) 21181 9011 FORMAT('***** AT THE END OF CUMSTA--') 21182 CALL DPWRST('XXX','BUG ') 21183 WRITE(ICOUT,9013)NOUT 21184 9013 FORMAT('NOUT = ',I8) 21185 CALL DPWRST('XXX','BUG ') 21186 IF(NOUT.GE.1)THEN 21187 DO9021I=1,NOUT 21188 WRITE(ICOUT,9023)I,YOUT(I) 21189 9023 FORMAT('I,YOUT(I) = ',I8,G15.7) 21190 CALL DPWRST('XXX','BUG ') 21191 9021 CONTINUE 21192 ENDIF 21193 ENDIF 21194C 21195 RETURN 21196 END 21197 SUBROUTINE CUMSUM(X,N,IWRITE,Y,IBUGA3,IERROR) 21198C 21199C PURPOSE--COMPUTE CUMULATIVE SUM OF A VARIABLE-- 21200C Y(1) = X(1) 21201C Y(2) = X(1) + X(2) 21202C Y(3) = X(1) + X(2) + X(3) 21203C ETC. 21204C NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.) 21205C BEING IDENTICAL TO THE INPUT VECTOR X(.). 21206C WRITTEN BY--JAMES J. FILLIBEN 21207C STATISTICAL ENGINEERING DIVISION 21208C INFORMATION TECHNOLOGY LABORATORY 21209C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 21210C GAITHERSBURG, MD 20899 21211C PHONE--301-975-2855 21212C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 21213C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 21214C LANGUAGE--ANSI FORTRAN (1977) 21215C VERSION NUMBER--82/7 21216C ORIGINAL VERSION--FEBRUARY 1979. 21217C UPDATED --APRIL 1979. 21218C UPDATED --JULY 1979. 21219C UPDATED --AUGUST 1981. 21220C UPDATED --MAY 1982. 21221C 21222C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 21223C 21224 CHARACTER*4 IWRITE 21225 CHARACTER*4 IBUGA3 21226 CHARACTER*4 IERROR 21227C 21228 CHARACTER*4 ISUBN1 21229 CHARACTER*4 ISUBN2 21230C 21231C--------------------------------------------------------------------- 21232C 21233 DIMENSION X(*) 21234 DIMENSION Y(*) 21235C 21236 DOUBLE PRECISION DSUM 21237 DOUBLE PRECISION DX 21238C 21239C--------------------------------------------------------------------- 21240C 21241 INCLUDE 'DPCOP2.INC' 21242C 21243C-----START POINT----------------------------------------------------- 21244C 21245 ISUBN1='CUMS' 21246 ISUBN2='UM ' 21247 IERROR='NO' 21248C 21249 IF(IBUGA3.EQ.'ON')THEN 21250 WRITE(ICOUT,999) 21251 999 FORMAT(1X) 21252 CALL DPWRST('XXX','BUG ') 21253 WRITE(ICOUT,51) 21254 51 FORMAT('***** AT THE BEGINNING OF CUMSUM--') 21255 CALL DPWRST('XXX','BUG ') 21256 WRITE(ICOUT,52)IBUGA3,IWRITE,N 21257 52 FORMAT('IBUGA3,IWRITE,N = ',2(A4,2X),I8) 21258 CALL DPWRST('XXX','BUG ') 21259 DO55I=1,N 21260 WRITE(ICOUT,56)I,X(I) 21261 56 FORMAT('I,X(I) = ',I8,G15.7) 21262 CALL DPWRST('XXX','BUG ') 21263 55 CONTINUE 21264 ENDIF 21265C 21266C ******************************* 21267C ** COMPUTE CUMULATIVE SUM. ** 21268C ******************************* 21269C 21270 DSUM=0.0D0 21271 IF(N.LT.1)THEN 21272 IERROR='YES' 21273 WRITE(ICOUT,999) 21274 CALL DPWRST('XXX','BUG ') 21275 WRITE(ICOUT,151) 21276 151 FORMAT('***** ERROR IN CUMULATIVE SUM--') 21277 CALL DPWRST('XXX','BUG ') 21278 WRITE(ICOUT,152) 21279 152 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR THE') 21280 CALL DPWRST('XXX','BUG ') 21281 WRITE(ICOUT,153) 21282 153 FORMAT(' RESPONSE VARIABLE IS LESS THAN 1.') 21283 CALL DPWRST('XXX','BUG ') 21284 WRITE(ICOUT,157)N 21285 157 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 21286 1 '.') 21287 CALL DPWRST('XXX','BUG ') 21288 ELSE 21289 DO100I=1,N 21290 DX=X(I) 21291 DSUM=DSUM+DX 21292 Y(I)=DSUM 21293 100 CONTINUE 21294 ENDIF 21295C 21296C ***************** 21297C ** STEP 90-- ** 21298C ** EXIT. ** 21299C ***************** 21300C 21301 IF(IBUGA3.EQ.'ON')THEN 21302 WRITE(ICOUT,999) 21303 CALL DPWRST('XXX','BUG ') 21304 WRITE(ICOUT,9011) 21305 9011 FORMAT('***** AT THE END OF CUMSUM--') 21306 CALL DPWRST('XXX','BUG ') 21307 WRITE(ICOUT,9012)IERROR 21308 9012 FORMAT('IERROR = ',A4) 21309 CALL DPWRST('XXX','BUG ') 21310 DO9015I=1,N 21311 WRITE(ICOUT,9016)I,X(I),Y(I) 21312 9016 FORMAT('I,X(I),Y(I) = ',I8,2G15.7) 21313 CALL DPWRST('XXX','BUG ') 21314 9015 CONTINUE 21315 ENDIF 21316C 21317 RETURN 21318 END 21319 SUBROUTINE cumtnc(t,df,pnonc,cum,ccum) 21320C 21321C 2017/01: THIS ROUTINE IS FROM THE DCDFLIB LIBRARY OF BARRY BROWN, 21322C JAMES LAVATO, AND KATHY RUSSELL. 21323C 21324C THE MAIN MODIFICATION OF THIS ROUTINE IS TO REPLACE 21325C GAMLN, CUMT, CUMNOR, AND BRATIO WITH ROUTINES THAT ARE 21326C ALREADY IN DATAPLOT. 21327C 21328C********************************************************************** 21329C 21330C SUBROUTINE CUMTNC(T,DF,PNONC,CUM,CCUM) 21331C 21332C CUMulative Non-Central T-distribution 21333C 21334C 21335C Function 21336C 21337C 21338C Computes the integral from -infinity to T of the non-central 21339C t-density. 21340C 21341C 21342C Arguments 21343C 21344C 21345C T --> Upper limit of integration of the non-central t-density. 21346C T is DOUBLE PRECISION 21347C 21348C DF --> Degrees of freedom of the non-central t-distribution. 21349C DF is DOUBLE PRECISIO 21350C 21351C PNONC --> Non-centrality parameter of the non-central t distibutio 21352C PNONC is DOUBLE PRECI 21353C 21354C CUM <-- Cumulative t-distribution. 21355C CCUM is DOUBLE PRECIS 21356C 21357C CCUM <-- Compliment of Cumulative t-distribution. 21358C CCUM is DOUBLE PRECIS 21359C 21360C 21361C Method 21362C 21363C Upper tail of the cumulative noncentral t using 21364C formulae from page 532 of Johnson, Kotz, Balakrishnan, Coninuous 21365C Univariate Distributions, Vol 2, 2nd Edition. Wiley (1995) 21366C 21367C This implementation starts the calculation at i = lambda, 21368C which is near the largest Di. It then sums forward and backward. 21369C*********************************************************************** 21370C .. Parameters .. 21371 21372 DOUBLE PRECISION one,zero,half,two,onep5 21373 PARAMETER (one=1.0d0,zero=0.0d0,half=0.5d0,two=2.0d0,onep5=1.5d0) 21374 DOUBLE PRECISION conv 21375 PARAMETER (conv=1.0d-7) 21376 DOUBLE PRECISION tiny 21377 PARAMETER (tiny=1.0d-10) 21378C .. 21379C .. Scalar Arguments .. 21380 DOUBLE PRECISION ccum,cum,df,pnonc,t 21381C .. 21382C .. Local Scalars .. 21383 DOUBLE PRECISION alghdf,b,bb,bbcent,bcent,cent,d,dcent,dpnonc, 21384 + dum1,dum2,e,ecent,halfdf,lambda,lnomx,lnx,omx, 21385 + pnonc2,s,scent,ss,sscent,t2,term,tt,twoi,x, 21386 + xi,xlnd,xlne 21387 INTEGER ierr 21388 LOGICAL qrevs 21389C .. 21390C .. External Functions .. 21391CCCCC DOUBLE PRECISION gamln 21392CCCCC EXTERNAL gamln 21393 DOUBLE PRECISION DLNGAM 21394 EXTERNAL DLNGAM 21395C .. 21396C .. External Subroutines .. 21397CCCCC EXTERNAL bratio,cumnor,cumt 21398 EXTERNAL bratio 21399C .. 21400C .. Intrinsic Functions .. 21401 INTRINSIC abs,exp,int,log,max,min 21402C .. 21403 21404C 21405 dum1=0.0 21406 dum2=0.0 21407C 21408C Case pnonc essentially zero 21409 21410 IF (abs(pnonc).LE.tiny) THEN 21411ccccc CALL cumt(t,df,cum,ccum) 21412 CALL tdcdf(t,df,cum) 21413 ccum=1.0d0 - cum 21414 RETURN 21415 21416 END IF 21417 21418 qrevs = t .LT. zero 21419 IF (qrevs) THEN 21420 tt = -t 21421 dpnonc = -pnonc 21422 21423 ELSE 21424 tt = t 21425 dpnonc = pnonc 21426 END IF 21427 21428 pnonc2 = dpnonc*dpnonc 21429 t2 = tt*tt 21430 21431 IF (abs(tt).LE.tiny) THEN 21432ccccc CALL cumnor(-pnonc,cum,ccum) 21433 CALL nodcdf(-pnonc,cum) 21434 ccum=1.0d0 - cum 21435 RETURN 21436 21437 END IF 21438 21439 lambda = half*pnonc2 21440 x = df/ (df+t2) 21441 omx = one - x 21442 21443 lnx = log(x) 21444 lnomx = log(omx) 21445 21446 halfdf = half*df 21447ccccc alghdf = gamln(halfdf) 21448 alghdf = DLNGAM(halfdf) 21449 21450C ******************** Case i = lambda 21451 21452 cent = int(lambda) 21453 21454 IF (cent.LT.one) cent = one 21455 21456C Compute d=T(2i) in log space and offset by exp(-lambda) 21457 21458ccccc xlnd = cent*log(lambda) - gamln(cent+one) - lambda 21459 xlnd = cent*log(lambda) - dlngam(cent+one) - lambda 21460 21461 dcent = exp(xlnd) 21462 21463C Compute e=t(2i+1) in log space offset by exp(-lambda) 21464 21465ccccc xlne = (cent+half)*log(lambda) - gamln(cent+onep5) - lambda 21466 xlne = (cent+half)*log(lambda) - dlngam(cent+onep5) - lambda 21467 ecent = exp(xlne) 21468 21469 IF (dpnonc.LT.zero) ecent = -ecent 21470 21471C Compute bcent=B(2*cent) 21472 21473 CALL bratio(halfdf,cent+half,x,omx,bcent,dum1,ierr) 21474CCCCC bcent=dbetai(x,halfdf,cent+half) 21475 21476C compute bbcent=B(2*cent+1) 21477 21478 CALL bratio(halfdf,cent+one,x,omx,bbcent,dum2,ierr) 21479CCCCC bbcent=dbetai(x,halfdf,cent+one) 21480 21481C Case bcent and bbcent are essentially zero 21482C Thus t is effectively infinite 21483 21484 IF ((bcent+bbcent).LT.tiny) THEN 21485 IF (qrevs) THEN 21486 cum = zero 21487 ccum = one 21488 21489 ELSE 21490 cum = one 21491 ccum = zero 21492 END IF 21493 21494 RETURN 21495 21496 END IF 21497 21498C Case bcent and bbcent are essentially one 21499C Thus t is effectively zero 21500 21501 IF ((dum1+dum2).LT.tiny) THEN 21502ccccc CALL cumnor(-pnonc,cum,ccum) 21503 CALL nodcdf(-pnonc,cum) 21504 ccum=1.0d0 - cum 21505 RETURN 21506 21507 END IF 21508 21509C First term in ccum is D*B + E*BB 21510 21511 ccum = dcent*bcent + ecent*bbcent 21512 21513C compute s(cent) = B(2*(cent+1)) - B(2*cent)) 21514 21515ccccc scent = gamln(halfdf+cent+half) - gamln(cent+onep5) - alghdf + 21516 scent = dlngam(halfdf+cent+half) - dlngam(cent+onep5) - alghdf + 21517 + halfdf*lnx + (cent+half)*lnomx 21518 scent = exp(scent) 21519 21520C compute ss(cent) = B(2*cent+3) - B(2*cent+1) 21521 21522ccccc sscent = gamln(halfdf+cent+one) - gamln(cent+two) - alghdf + 21523 sscent = dlngam(halfdf+cent+one) - dlngam(cent+two) - alghdf + 21524 + halfdf*lnx + (cent+one)*lnomx 21525 sscent = exp(sscent) 21526 21527C ******************** Sum Forward 21528 21529 xi = cent + one 21530 twoi = two*xi 21531 21532 d = dcent 21533 21534 e = ecent 21535 21536 b = bcent 21537 21538 bb = bbcent 21539 21540 s = scent 21541 21542 ss = sscent 21543 21544 10 b = b + s 21545 bb = bb + ss 21546 21547 d = (lambda/xi)*d 21548 e = (lambda/ (xi+half))*e 21549 21550 term = d*b + e*bb 21551 21552 ccum = ccum + term 21553 21554 s = s*omx* (df+twoi-one)/ (twoi+one) 21555 21556 ss = ss*omx* (df+twoi)/ (twoi+two) 21557 21558 xi = xi + one 21559 twoi = two*xi 21560 21561 IF (abs(term).GT.conv*ccum) GO TO 10 21562 21563C ******************** Sum Backward 21564 21565 xi = cent 21566 twoi = two*xi 21567 21568 d = dcent 21569 21570 e = ecent 21571 21572 b = bcent 21573 21574 bb = bbcent 21575 21576 s = scent* (one+twoi)/ ((df+twoi-one)*omx) 21577 21578 ss = sscent* (two+twoi)/ ((df+twoi)*omx) 21579 21580 20 b = b - s 21581 bb = bb - ss 21582 21583 d = d* (xi/lambda) 21584 21585 e = e* ((xi+half)/lambda) 21586 21587 term = d*b + e*bb 21588 21589 ccum = ccum + term 21590 21591 xi = xi - one 21592 21593 IF (xi.LT.half) GO TO 30 21594 21595 twoi = two*xi 21596 21597 s = s* (one+twoi)/ ((df+twoi-one)*omx) 21598 21599 ss = ss* (two+twoi)/ ((df+twoi)*omx) 21600 21601 IF (abs(term).GT.conv*ccum) GO TO 20 21602 21603 30 CONTINUE 21604 21605 IF (qrevs) THEN 21606 cum = half*ccum 21607 ccum = one - cum 21608 21609 ELSE 21610 ccum = half*ccum 21611 cum = one - ccum 21612 END IF 21613 21614C Due to roundoff error the answer may not lie between zero and one 21615C Force it to do so 21616 21617 cum = max(min(cum,one),zero) 21618 ccum = max(min(ccum,one),zero) 21619 21620 RETURN 21621 21622 END 21623 SUBROUTINE CURVE (P, X, N0, N, EPS, MAXITR, MU, SIGMA, ITER, 21624 1 SEMU, SESIG, COVAR, E0, EX, CHISQ, 21625 1 F, F1, XN, 21626 1 FUNC, 21627 1 IFAULT) 21628C 21629C ALGORITHM AS 95 APPL. STATIST. (1976) VOL.25, NO.1 21630C 21631C ESTIMATES MU AND SIGMA OF DISTRIBUTION FUNCTION 21632C F( (X-MU)/SIGMA ) FROM A GROUPED SAMPLE OF X VALUES. 21633C NOTE ON ARRAY SIZES 21634C THE ARRAYS IN THE SECOND DIMENSION STATEMENT MUST HAVE 21635C MINIMUM SIZE P. IF P IS TO EXCEED 20, A SUITABLE SIZE 21636C MUST BE SET FOR THEM, AND THE IF STATEMENT WHICH CHECKS 21637C THE VALUE OF P MUST BE AMENDED. 21638C 21639C Auxiliary routines required: FUNC & DEVIAT (both user-supplied) 21640C 21641 PARAMETER (MAXCLA=1000) 21642C 21643 INTEGER P 21644 REAL NN, NI, NP, MU, ONE, ZERO 21645 DIMENSION X(*), N(*), EX(*) 21646 DIMENSION F(*), F1(*), XN(*) 21647C 21648 EXTERNAL FUNC 21649C 21650 DATA RR/1.0E-10/ 21651 DATA ONE/1.0/ 21652 DATA ZERO/0.0/ 21653C 21654 E=0.0 21655 D=0.0 21656 C=0.0 21657 DENOM=0.0 21658C 21659C ERROR EXIT IF P TOO SMALL OR TOO LARGE 21660C 21661 IF (P.LT.2 .OR. P.GT.MAXCLA) THEN 21662 IFAULT = 1 21663 GOTO9000 21664 END IF 21665C 21666 IFAULT = 0 21667C 21668C SET FREQUENCIES IN FLOATING POINT 21669C 21670 XN0 = N0 21671 NSUM = N0 21672 DO 10 I = 1, P 21673 XN(I) = N(I) 21674 NSUM = NSUM + N(I) 21675 10 CONTINUE 21676 K = P - 1 21677 XNSUM = REAL(NSUM) 21678 NP = XN(P) 21679C 21680C ITERATIVE APPROXIMATION 21681C 21682 DO 40 ITER = 1, MAXITR 21683C 21684C COMPUTE VALUES OF DISTRIBUTION AND DENSITY FUNCTIONS, 21685C USING CURRENT VALUES OF MU, SIGMA 21686C 21687 DO 20 I = 1, P 21688 CALL FUNC ((X(I) - MU)/SIGMA, F(I), F1(I)) 21689 20 CONTINUE 21690 DM = ONE - F(P) 21691C 21692C 21693C TEST FOR SMALL DIVISOR TO AVOID OVERFLOW 21694C 21695 IF (ABS(DM).LT.RR) THEN 21696 IFAULT=2 21697 GO TO 9000 21698 ENDIF 21699C 21700 F1P = F1(P) 21701 IF (ABS(F(1)).LT.RR) THEN 21702 IFAULT=2 21703 GO TO 9000 21704 ENDIF 21705C 21706 XI1 = X(1) - MU 21707 XP = X(P) - MU 21708 R = F1(1)/F(1) 21709 S = F1P/DM 21710 T = -XN0*R 21711 U = NP*S 21712 A = T + U 21713 B = XI1*T + XP*U 21714 R = F1(1)*R 21715 S = F1P*S 21716 C = R + S 21717 R = XI1*S 21718 S = XP*S 21719 D = R + S 21720 E = XI1*R + XP*S 21721 DO 30 I = 1, K 21722 FI = F(I) 21723 FI1 = F(I + 1) 21724 F1I1 = F1(I + 1) 21725 F1I = F1(I) 21726 XI = XI1 21727 XI1 = X(I + 1) - MU 21728 NI = XN(I) 21729 R = FI1 - FI 21730C 21731 IF (ABS(R).LT.RR) THEN 21732 IFAULT=2 21733 GO TO 9000 21734 ENDIF 21735C 21736 S = F1I1 - F1I 21737 U = XI1*F1I1 - XI*F1I 21738 SR = S/R 21739 UR = U/R 21740 A = A - NI*SR 21741 B = B - NI*UR 21742 C = C + S*SR 21743 D = D + S*UR 21744 E = E + U*UR 21745 30 CONTINUE 21746 DENOM = (C*E - D*D)*XNSUM 21747C 21748C COMPUTE ADJUSTMENTS TO MU, SIGMA 21749C 21750 SIGDEN = SIGMA/DENOM 21751 DMU = (E*A - D*B)*SIGDEN 21752 DSIGMA = (C*B - D*A)*SIGMA*SIGDEN 21753 MU = MU + DMU 21754 SIGMA = SIGMA + DSIGMA 21755 ERR = ABS(DMU) + ABS(DSIGMA) 21756C 21757C TEST FOR CONVERGENCE 21758C 21759 IF (ERR.LT.EPS) GOTO50 21760 40 CONTINUE 21761C 21762C SET FAULT IF LIMIT FOR NUMBER OF ITERATIONS IS 21763C REACHED, THEN PROCEED 21764C 21765 IFAULT = 4 21766 ITER = MAXITR 21767C 21768 50 CONTINUE 21769 DO 60 I = 1, P 21770 CALL FUNC ((X(I) - MU)/SIGMA, F(I), DUM) 21771 60 CONTINUE 21772C 21773C COMPUTE VARIANCES AND COVARIANCE OF ESTIMATES 21774C 21775 SIGDEN = SIGMA*SIGMA/DENOM 21776 VARMU = E*SIGDEN 21777 SIGDEN = SIGMA*SIGDEN 21778 COVAR = -D*SIGDEN 21779 VARSIG = C*SIGMA*SIGDEN 21780 IF (VARMU.LT.ZERO .OR. VARSIG.LT.ZERO) THEN 21781 IFAULT=3 21782 GO TO 9000 21783 ENDIF 21784C 21785 SEMU = SQRT(VARMU) 21786 SESIG = SQRT(VARSIG) 21787C 21788C COMPUTE EXPECTED FREQUENCIES AND CHI SQUARE 21789C 21790 E0 = XNSUM*F(1) 21791 EP = XNSUM*(ONE - F(P)) 21792 EX(P) = EP 21793 CHISQ = ((XN0 - E0)**2)/E0 + ((NP - EP)**2)/EP 21794 DO 70 I = 1, K 21795 NN = XNSUM*(F(I+1) - F(I)) 21796 CHISQ = CHISQ + ((NN - XN(I))**2)/NN 21797 EX(I) = NN 21798 70 CONTINUE 21799C 21800 9000 CONTINUE 21801 RETURN 21802 END 21803 SUBROUTINE CUSARL(X,NX,IWRITE,Y,ICASE,IBUGA3,IERROR) 21804C 21805C PURPOSE--COMPUTE CUMULATIVE SUM ARL. 21806C USE APPLIED STATISTICS ALGORITHM AS 258. 21807C WRITTEN BY--ALAN HECKERT 21808C STATISTICAL ENGINEERING DIVISION 21809C INFORMATION TECHNOLOGY LABORATORY 21810C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 21811C GAITHERSBURG, MD 20899 21812C PHONE--301-975-2899 21813C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 21814C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 21815C LANGUAGE--ANSI FORTRAN (1977) 21816C VERSION NUMBER--99/3 21817C ORIGINAL VERSION--MARCH 1999. 21818C 21819C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 21820C 21821 CHARACTER*4 IWRITE 21822 CHARACTER*4 ICASE 21823 CHARACTER*4 IBUGA3 21824 CHARACTER*4 IERROR 21825C 21826 CHARACTER*4 ISUBN1 21827 CHARACTER*4 ISUBN2 21828 CHARACTER*4 IHWUSE 21829 CHARACTER*4 MESSAG 21830 CHARACTER*4 IHP 21831 CHARACTER*4 IHP2 21832C 21833C--------------------------------------------------------------------- 21834C 21835 DIMENSION X(*) 21836 DIMENSION Y(*) 21837C 21838C--------------------------------------------------------------------- 21839C 21840 INCLUDE 'DPCOPA.INC' 21841 INCLUDE 'DPCOHK.INC' 21842 INCLUDE 'DPCOP2.INC' 21843C 21844C-----START POINT----------------------------------------------------- 21845C 21846 ISUBN1='CUSA' 21847 ISUBN2='RL ' 21848 IERROR='NO' 21849C 21850 IF(IBUGA3.EQ.'ON')THEN 21851 WRITE(ICOUT,999) 21852 999 FORMAT(1X) 21853 CALL DPWRST('XXX','BUG ') 21854 WRITE(ICOUT,51) 21855 51 FORMAT('***** AT THE BEGINNING OF CUSARL--') 21856 CALL DPWRST('XXX','BUG ') 21857 WRITE(ICOUT,52)ICASE,IBUGA3,IWRITE,NX 21858 52 FORMAT('ICAE,IBUGA3,IWRITE,NX = ',3(A4,2X),I8) 21859 CALL DPWRST('XXX','BUG ') 21860 DO55I=1,NX 21861 WRITE(ICOUT,56)I,X(I) 21862 56 FORMAT('I,X(I) = ',I8,G15.7) 21863 CALL DPWRST('XXX','BUG ') 21864 55 CONTINUE 21865 ENDIF 21866C 21867C ********************************************* 21868C ** CHECK FOR PARAMERERS: DELTA, S0, K, H ** 21869C ********************************************* 21870C 21871 IHP='S0 ' 21872 IHP2=' ' 21873 IHWUSE='P' 21874 MESSAG='NO' 21875 CALL CHECKN(IHP,IHP2,IHWUSE, 21876 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 21877 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 21878 IF(IERROR.EQ.'YES')THEN 21879 S0=0.0 21880 ELSE 21881 S0=VALUE(ILOCP) 21882 ENDIF 21883C 21884 IHP='K ' 21885 IHP2=' ' 21886 IHWUSE='P' 21887 MESSAG='YES' 21888 CALL CHECKN(IHP,IHP2,IHWUSE, 21889 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 21890 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 21891 IF(IERROR.EQ.'YES')GOTO9000 21892 AK=VALUE(ILOCP) 21893C 21894 IF(AK.LT.0)THEN 21895 WRITE(ICOUT,999) 21896 CALL DPWRST('XXX','BUG ') 21897 WRITE(ICOUT,16211) 2189816211 FORMAT('***** ERROR IN CUSARL--') 21899 CALL DPWRST('XXX','BUG ') 21900 WRITE(ICOUT,16212) 2190116212 FORMAT(' THE SPECIFIED PARAMETER K') 21902 CALL DPWRST('XXX','BUG ') 21903 WRITE(ICOUT,16213) 2190416213 FORMAT(' FOR THE CUMULATIVE SUM AVERAGE RUN LENGTH') 21905 CALL DPWRST('XXX','BUG ') 21906 WRITE(ICOUT,16214) 2190716214 FORMAT(' MUST BE GREATER THAN OR EQUAL TO 0;') 21908 CALL DPWRST('XXX','BUG ') 21909 WRITE(ICOUT,16215) 2191016215 FORMAT(' SUCH WAS NOT THE CASE HERE.') 21911 CALL DPWRST('XXX','BUG ') 21912 WRITE(ICOUT,16216)AK 2191316216 FORMAT(' THE SPECIFIED VALUE OF K = ',E15.7) 21914 CALL DPWRST('XXX','BUG ') 21915 IERROR='YES' 21916 GOTO9000 21917 ENDIF 21918C 21919 IHP='H ' 21920 IHP2=' ' 21921 IHWUSE='P' 21922 MESSAG='YES' 21923 CALL CHECKN(IHP,IHP2,IHWUSE, 21924 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 21925 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) 21926 IF(IERROR.EQ.'YES')GOTO9000 21927 AH=VALUE(ILOCP) 21928C 21929 IF(AH.LT.0)THEN 21930 WRITE(ICOUT,999) 21931 CALL DPWRST('XXX','BUG ') 21932 WRITE(ICOUT,16311) 2193316311 FORMAT('***** ERROR IN CUSARL--') 21934 CALL DPWRST('XXX','BUG ') 21935 WRITE(ICOUT,16312) 2193616312 FORMAT(' THE SPECIFIED PARAMETER H') 21937 CALL DPWRST('XXX','BUG ') 21938 WRITE(ICOUT,16313) 2193916313 FORMAT(' FOR THE CUMULATIVE SUM AVERAGE RUN LENGTH') 21940 CALL DPWRST('XXX','BUG ') 21941 WRITE(ICOUT,16314) 2194216314 FORMAT(' MUST BE GREATER THAN OR EQUAL TO 0;') 21943 CALL DPWRST('XXX','BUG ') 21944 WRITE(ICOUT,16315) 2194516315 FORMAT(' SUCH WAS NOT THE CASE HERE.') 21946 CALL DPWRST('XXX','BUG ') 21947 WRITE(ICOUT,16316)AH 2194816316 FORMAT(' THE SPECIFIED VALUE OF K = ',E15.7) 21949 CALL DPWRST('XXX','BUG ') 21950 IERROR='YES' 21951 GOTO9000 21952 ENDIF 21953C 21954 DO100I=1,NX 21955 DELTA=X(I) 21956 IF(ICASE.EQ.'TWOS')THEN 21957 CALL ARL2(DELTA,AK,AH,S0,ARL,ARLFIR,IFAULT) 21958 ELSE 21959 CALL ARL1(DELTA,AK,AH,S0,ARL,ARLFIR,IFAULT) 21960 ENDIF 21961 IF(IFAULT.EQ.1)THEN 21962 WRITE(ICOUT,999) 21963 CALL DPWRST('XXX','BUG ') 21964 WRITE(ICOUT,141) 21965 141 FORMAT('***** ERROR IN CUSARL--') 21966 CALL DPWRST('XXX','BUG ') 21967 WRITE(ICOUT,143) 21968 143 FORMAT(' ERROR IN INPUT ARGUMENTS TO ARL ROUTINE.') 21969 CALL DPWRST('XXX','BUG ') 21970 IERROR='YES' 21971 GOTO9000 21972 ELSEIF(IFAULT.EQ.2)THEN 21973 WRITE(ICOUT,999) 21974 CALL DPWRST('XXX','BUG ') 21975 WRITE(ICOUT,151) 21976 151 FORMAT('***** ERROR IN CUSARL--') 21977 CALL DPWRST('XXX','BUG ') 21978 WRITE(ICOUT,153)DELTA 21979 153 FORMAT(' FOR X = ',G15.7,', EQUATIONS ARE SINGULAR.') 21980 CALL DPWRST('XXX','BUG ') 21981 IERROR='YES' 21982 GOTO9000 21983 ELSEIF(IFAULT.EQ.3)THEN 21984 WRITE(ICOUT,999) 21985 CALL DPWRST('XXX','BUG ') 21986 WRITE(ICOUT,161) 21987 161 FORMAT('***** ERROR IN CUSARL--') 21988 CALL DPWRST('XXX','BUG ') 21989 WRITE(ICOUT,163)DELTA 21990 163 FORMAT(' FOR X = ',G15.7,', VALUE OF S0 IS TOO LARGE.') 21991 CALL DPWRST('XXX','BUG ') 21992 IERROR='YES' 21993 GOTO9000 21994 ENDIF 21995 IF(S0.GT.0.0)THEN 21996 Y(I)=ARLFIR 21997 ELSE 21998 Y(I)=ARL 21999 ENDIF 22000 100 CONTINUE 22001C 22002C ***************** 22003C ** STEP 90-- ** 22004C ** EXIT. ** 22005C ***************** 22006C 22007 9000 CONTINUE 22008C 22009 IF(IBUGA3.EQ.'OFF')GOTO9090 22010 WRITE(ICOUT,999) 22011 CALL DPWRST('XXX','BUG ') 22012 WRITE(ICOUT,9011) 22013 9011 FORMAT('***** AT THE END OF CUSARL--') 22014 CALL DPWRST('XXX','BUG ') 22015 WRITE(ICOUT,9012)IBUGA3,IERROR 22016 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 22017 CALL DPWRST('XXX','BUG ') 22018 WRITE(ICOUT,9013)NX 22019 9013 FORMAT('NX = ',I8) 22020 CALL DPWRST('XXX','BUG ') 22021 DO9015I=1,NX 22022 WRITE(ICOUT,9016)I,X(I),Y(I) 22023 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) 22024 CALL DPWRST('XXX','BUG ') 22025 9015 CONTINUE 22026 9090 CONTINUE 22027C 22028 RETURN 22029 END 22030 double precision function cvflow(cv) 22031 implicit double precision (a-h,o-z) 22032 common /cvc/ estcv,sqrtn,df,ratio,alphad2,omad2 22033c 22034 xncp = sqrtn/cv 22035ccccc call cdftnc(1,p,q,ratio,df,xncp,ier,bound) 22036 call nctcd2(ratio,df,xncp,p) 22037ccccc if (ier .ne. 0) then 22038ccccc write(6,10) 22039ccccc write(7,10) 22040c10 format(/,1x,'The ier value from a call', 22041cccccx ' to cdftnc was nonzero. Please contact',/, 22042cccccx 1x,'Steve Verrill at sverrill@fs.fed.us.',/) 22043ccccc stop 22044ccccc endif 22045 cvflow = alphad2 - p 22046 return 22047 end 22048 double precision function cvfup(cv) 22049 implicit double precision (a-h,o-z) 22050 common /cvc/ estcv,sqrtn,df,ratio,alphad2,omad2 22051 xncp = sqrtn/cv 22052 call nctcd2(ratio,df,xncp,p) 22053ccccc if (ier .ne. 0) then 22054ccccc write(6,10) 22055ccccc write(7,10) 22056c10 format(/,1x,'The ier value from a call', 22057cccccx ' to cdftnc was nonzero. Please contact',/, 22058cccccx 1x,'Steve Verrill at sverrill@fs.fed.us.',/) 22059ccccc stop 22060ccccc endif 22061 cvfup = omad2 - p 22062 return 22063 end 22064