1 SUBROUTINE MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL, 2 1 MAXNPP,ISEED,IBOOSS, 3 1 IX1TSV,IX2TSV,IY1TSV,IY2TSV, 4 1 IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV, 5 1 BARHEF,BARWEF, 6 1 IRHSTG,IHSTCW,IHSTEB,IHSTOU,IASHWT, 7 1 IHSTMC,IHSTOP, 8 1 ICAPSW,IFORSW,IGUIFL,IERRFA, 9 1 IAND1,IAND2,ICONT,NUMHPP,NUMVPP,MAXNXT, 10 1 ISUBRO,IFOUND,IERROR) 11C 12C PURPOSE--THIS IS SUBROUTING MAINGR. 13C (THE GR AT THE END OF MAINGR STANDS FOR GRAPHICS) 14C THIS SUBROUTINE SEARCHES FOR AND EXECUTES GRAPHICS COMMANDS. 15C THE GRAPHICS COMMANDS SEARCHED FOR BY MAINGR ARE AS FOLLOWS-- 16C 17C ANOP PLOT (= PROPORTION PLOT) 18C ... BOX PLOT 19C BOX-COX NORMALITY PLOT 20C BOX-COX HOMOSCEDASTICITY PLOT 21C BOX-COX SYMMETRY PLOT (NOT DONE) 22C BOX-COX LINEARITY PLOT 23C BOX-COX STANDARDIZED EFFECTS PLOT (NOT DONE) 24C COMPLEX DEMODULATION ... PLOT 25C CONTOUR PLOT 26C ... CONTROL CHART 27C ... CORRELATION PLOT 28C ... FFT PLOT (NOT DONE) 29C ... FREQUENCY PLOT 30C ... HISTOGRAM 31C ... HOMOSCEDASTICITY PLOT 32C ... I PLOT 33C INTERACTION PLOT 34C LAG ... PLOT 35C ... NORMALITY PLOT 36C PERCENT POINT PLOT 37C ... PERIODOGRAM 38C PIE CHART 39C PLOT 40C ... PROBABILITY PLOT 41C ... PPCC (PROBABILITY PLOT CORRELATION 42C COEFFICIENT) PLOT 43C ... ROOTOGRAM 44C RUN SEQUENCE PLOT 45C RUNS ... PLOT 46C ... SPECTRAL PLOT 47C 3-D PLOT 48C 3-D ... FREQUENCY PLOT (NOT DONE) 49C 3-D ... HISTOGRAM (NOT DONE) 50C 4-PLOT ... ANALYSIS (DONE IN MAIN) 51C BAR CHART 52C STEM AND LEAF DIAGRAM 53C ... STATISTIC PLOT 54C YOUDEN PLOT 55C ... BIHISTOGRAM 56C ERROR BAR PLOT OCTOBER 1988 57C FRACTAL PLOT DECEMBER 1988 58C POINCARE PLOT DECEMBER 1988 59C (REPLACED BY PHASE PLANE DIAGRAM JULY 1989) 60C JACKNIFE ... STATISTIC PLOT JANUARY 1989 61C BOOTSTRAP ... STATISTIC PLOT JANUARY 1989 62C DEX/DOE EXP DESIGN ... PLOT MAY 1989 63C TAIL AREA PLOT 1989 64C NORMAL PLOT MAY 1990 65C PHD PLOT (KER-CHAU LIE) OCTOBER 1991 66C (NOT IMPLEMENTED YET) 67C BLOCK PLOT APRIL 1992. 68C <STAT> BLOCK JUNE 1992. 69C SYMBOL PLOT AUGUST 1992. 70C VECTOR PLOT AUGUST 1992 71C ANDREWS PLOT NOVEMBER 1992 72C PARTIAL AUTOCORR. PLOT FEBRUARY 1993 73C Q ... CONTROL CHART DECEMBER 1993 74C CME (CONT. MEAN EXCEEDANCE) PLOT DECEMBER 1993 75C CONDITIONAL ... PLOT DECEMBER 1993 76C ... COMOVEMENT PLOT OCTOBER 1997 77C KAPLAN MEIER PLOT MAY 1998 78C DUANE PLOT MAY 1998 79C EMPIRICAL CDF PLOT MAY 1998 80C EXPONENTIAL HAZARD PLOT MAY 1998 81C NORMAL HAZARD PLOT MAY 1998 82C LOGNORMAL HAZARD PLOT MAY 1998 83C WEIBULL HAZARD PLOT MAY 1998 84C HOTELLING CONTROL CHART MAY 1998 85C SEASONAL SUBSERIES PLOT FEBRUARY 1999 86C SPREAD-LOCATION PLOT AUGUST 1999 87C TUKEY MEAN-DIFFERENCE PLOT SEPTEMBER 1999 88C INTERACTION PLOT OCTOBER 1999 89C ... INTERACTION STAT PLOT OCTOBER 1999 90C CROSS TABULATE <STAT> PLOT DECEMBER 1999 91C DEX CONTOUR PLOT JANUARY 2000 92C YATES CUBE PLOT JANUARY 2000 93C BAG PLOT JANUARY 2001 94C (NOT IMPLEMENTED YET) 95C KERNEL DENSITY PLOT AUGUST 2001 96C CONSENSUS MEAN PLOT AUGUST 2001 97C PARTIAL RESIDUAL PLOT JUNE 2002 98C PARTIAL REGRESSION PLOT JUNE 2002 99C PARTIAL LEVERAGE PLOT JUNE 2002 100C CCPR PLOT JUNE 2002 101C INFLUENCE CURVE <STAT> PLOT JULY 2002 102C SHIFT PLOT FEBRUARY 2003 103C VIOLIN PLOT FEBRUARY 2003 104C PARALLEL COORDINATES PLOT MARCH 2003 105C PEAKS OVER THRESHOLD PLOT APRIL 2005 106C REPAIR PLOT OCTOBER 2006 107C MEAN REPAIR FUNCTION PLOT OCTOBER 2006 108C TRILINEAR PLOT DECEMBER 2006 109C ROC CURVE APRIL 2007 110C ROSE PLOT APRIL 2007 111C BIVARIATE NORMAL TOLERANCE 112C REGION PLOT MAY 2007 113C BIVARIATE NORMAL CONFIDENCE 114C REGION PLOT NOVEMBER 2013 115C BINARY <TYPE> PLOT MAY 2007 116C ORD PLOT MAY 2007 117C POISSON PLOT MAY 2007 118C BINOMIAL PLOT MAY 2007 119C NEGATIVE BINOMIAL PLOT MAY 2007 120C GEOMETRIC PLOT MAY 2007 121C LOGARITHMIC SERIES PLOT MAY 2007 122C ASSOCIATION PLOT JUNE 2007 123C SIEVE PLOT JUNE 2007 124C PSUEDO ROC CURVE JULY 2007 125C LEVEL PLOT MARCH 2008 126C (DISCRETE CONTOUR PLOT) 127C IMAGE PLOT MARCH 2008 128C SPATIAL DISTRIBUTION PLOT APRIL 2008 129C (UNDER DEVELOPMENT) 130C FLUCUATION PLOT MAY 2008 131C STRIP PLOT OCTOBER 2008 132C DETECTIION LIMIT PLOT DECEMBER 2008 133C (UNDER DEVELOPMENT) 134C TABULATION PLOT SEPTEMBER 2009 135C ISO 13528 PLOT FEBRUARY 2012 136C ISO 13528 ZSCORE PLOT FEBRUARY 2012 137C ISO 13528 JSCORE PLOT FEBRUARY 2012 138C ISO 13528 RLP PLOT FEBRUARY 2012 139C FRECHET PLOT OCTOBER 2013 140C DISTRIBUTIONAL FIT PLOT AUGUST 2014 141C LORENZ CURVE FEBRUARY 2015 142C H CONSISTENCY PLOT MAY 2015 143C K CONSISTENCY PLOT MAY 2015 144C COCHRAN VARIANCE PLOT MAY 2015 145C MOVING STATISTIC PLOT MAY 2015 146C CUMULATIVE STATISTIC PLOT MAY 2015 147C TWO-WAY <ROW/COLUMN> PLOT JUNE 2015 148C TWO FACTOR PLOT JUNE 2015 149C EMPIRICAL QUANTILE PLOT FEBRUARY 2017 150C TIQ PLOT MARCH 2017 151C QUANTILE BOX PLOT MARCH 2017 152C BLAND ALTMAN PLOT JULY 2017 153C NORM KERN DENSITY MIXT PLOT JULY 2017 154C DEX ORDER PLOT FEBRUARY 2018 155C CLASSIFICATION ... PLOT FEBRUARY 2019 156C 157C WRITTEN BY--JAMES J. FILLIBEN 158C STATISTICAL ENGINEERING DIVISION 159C INFORMATION TECHNOLOGY LABORATORY 160C GAITHERSBURG, MD 20899-8980 161C PHONE--301-975-2855 162C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 163C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 164C LANGUAGE--ANSI FORTRAN (1977) 165C VERSION NUMBER--82.6 166C ORIGINAL VERSION--NOVEMBER 1980. 167C UPDATED --JANUARY 1981. 168C UPDATED --MARCH 1981. 169C UPDATED --AUGUST 1981. 170C UPDATED --SEPTEMBER 1981. 171C UPDATED --OCTOBER 1981. 172C UPDATED --DECEMBER 1981. 173C UPDATED --MAY 1982. 174C ETC. 175C UPDATED --AUGUST 1987. BOX-COX STANDARDIZED EFFECTS PLOT 176C UPDATED --JANUARY 1988. (... STATISTIC PLOTS) 177C UPDATED --JANUARY 1988. (... CHARTS) 178C UPDATED --FEBRUARY 1988. PROFILE PLOT 179C UPDATED --FEBRUARY 1988. STAR PLOT 180C UPDATED --AUGUST 1988. CONTOUR PLOT 181C UPDATED --AUGUST 1988. PARETO PLOT 182C UPDATED --SEPTEMBER 1988. EQUATE PROPROTION PLOT TO ANOP PLOT 183C UPDATED --SEPTEMBER 1988. YOUDEN PLOT (= PLOT WITH 3 ARGS) 184C UPDATED --SEPTEMBER 1988. BIHISTOGRAM 185C UPDATED --NOVEMBER 1988. ERROR BAR PLOT 186C UPDATED --DECEMBER 1988. ISEED ARGUMENT--FRACTAL PLOT 187C UPDATED --DECEMBER 1988. POINCARE PLOT 188C UPDATED --JANUARY 1989. JACKNIFE ... STAT PLOTS 189C UPDATED --JANUARY 1989. BOOTSTRAP ... STAT PLOTS 190C UPDATED --FEBRUARY 1989. CONTINUE CHARACTER CONFLICT (ALAN) 191C UPDATED --APRIL 1989. SCATTER PLOT (= SYNONYM FOR PLOT) 192C UPDATED --MAY 1989. DEX/DOE ... PLOT 193C UPDATED --MAY 1989. TAIL AREA PLOT 194C UPDATED --JULY 1989. POINCARE PLOT TO PHASE PLANE DIAG 195C UPDATED --MAY 1990. NORMAL PLOT 196C UPDATED --OCTOBER 1991. PHD PLOT (NOT DONE YET) 197C UPDATED --APRIL 1992. BLOCK PLOT 198C UPDATED --JUNE 1992. <STAT> BLOCK PLOT 199C UPDATED --AUGUST 1992. VECTOR PLOT, SYMBOL PLOT 200C UPDATED --NOVEMBER 1992. ANDREWS PLOT 201C UPDATED --FEBRUARY 1993. PARTIAL AUTOCORRELATION PLOT 202C UPDATED --JULY 1993. ARGUMENTS TO FRACTAL PLOT 203C UPDATED --AUGUST 1993. CONFLICT WITH MEDIAN POLISH 204C UPDATED --DECEMBER 1993. ADD ARG IN CALL DPPP() 205C UPDATED --DECEMBER 1993. Q ... CONTROL CHART 206C UPDATED --DECEMBER 1993. CME PLOT 207C UPDATED --DECEMBER 1993. COND. ... EXCEEDANCE PLOT 208C UPDATED --DECEMBER 1994. AUGMENT DPPARE() ARG. LIST 209C UPDATED --MARCH 1995. ADD MAXNXT TO DPBLOC 210C UPDATED --MARCH 1996. ADD IRHSTG TO DPHIST 211C UPDATED --OCTOBER 1997. COMOVEMENT PLOT 212C UPDATED --OCTOBER 1997. AUTO COMOVEMENT PLOT 213C UPDATED --MAY 1998. KAPLAN MEIER PLOT 214C UPDATED --MAY 1998. DUANE PLOT 215C UPDATED --MAY 1998. EMPIRICAL CDF PLOT 216C UPDATED --SEPTEMBER 1998. HOTELLING CONTROL CHART 217C UPDATED --FEBRUARY 1999. SEASONAL SUBSERIES PLOT 218C UPDATED --AUGUST 1999. SPREAD-LOCATION PLOT 219C UPDATED --SEPTEMBER 1999. TUKEY MEAN-DIFFERENCE PLOT 220C UPDATED --OCTOBER 1999. INTERACTION PLOT 221C UPDATED --OCTOBER 1999. INTERACTION STATISTIC PLOT 222C UPDATED --DECEMBER 1999. IMPLEMENT SUB-REGIONS 223C UPDATED --DECEMBER 1999. SAVE SOME INTERNAL PARAMETERS 224C FOR ALL PLOTS 225C UPDATED --DECEMBER 1999. CROSS TABULATE PLOT 226C UPDATED --JANUARY 2000. DEX CONTOUR PLOT 227C UPDATED --JANUARY 2001. BAG PLOT (NOT WORKING) 228C UPDATED --AUGUST 2001. KERNEL DENSITY PLOT 229C UPDATED --AUGUST 2001. CONSENSUS MEAN PLOT 230C UPDATED --MARCH 2002. ROBUSTNESS PLOT SYNONUM 231C FOR BLOCK PLOT 232C UPDATED --JULY 2002. INFLUENCE CURVE 233C UPDATED --OCTOBER 2002. CALL LIST TO CONSENUSE MEAN 234C PLOT 235C UPDATED --FEBRUARY 2003. SHIFT PLOT 236C UPDATED --FEBRUARY 2003. VIOLIN PLOT 237C UPDATED --MARCH 2003. PARALLEL COORDINATES PLOT 238C UPDATED --SEPTEMBER 2003. BCA <BOOTSTRAP/JACKINFE> 239C UPDATED --MAY 2004. KOLMOGOROV SMIRNOV PLOT AS 240C VARIANT OF PPCC PLOT 241C UPDATED --SEPTEMBER 2004. CALL LIST TO DPHIST 242C UPDATED --APRIL 2005. PEAKS OVER THRESHOLD PLOT 243C UPDATED --MARCH 2006. ADD IFORSW TO CONSENSUS MEAN 244C PLOT 245C UPDATED --OCTOBER 2006. REPAIR PLOT 246C UPDATED --OCTOBER 2006. MEAN REPAIR FUNCTION PLOT 247C UPDATED --DECEMBER 2006. TRILINEAR PLOT 248C UPDATED --APRIL 2007. ROC CURVE 249C UPDATED --APRIL 2007. ROSE PLOT 250C UPDATED --MAY 2007. BIVARIATE NORMAL TOLERANCE 251C REGION PLOT 252C UPDATED --MAY 2007. BINARY PLOT 253C UPDATED --MAY 2007. ORD PLOT 254C UPDATED --JUNE 2007. ASSOCIATION PLOT 255C UPDATED --JUNE 2007. SIEVE PLOT 256C UPDATED --AUGUST 2007. MOVE SOME ARRAY STORAGE TO 257C COMMON 258C UPDATED --JANUARY 2008. ADJUST USE OF DPCOZ3.INC 259C STORAGE 260C UPDATED --MARCH 2008. LEVEL (DISCRETE CONTOUR) PLOT 261C UPDATED --MARCH 2008. IMAGE PLOT 262C UPDATED --APRIL 2008. SPATIAL DISTRIBUTION PLOT 263C (STILL UNDER DEVELOPMENT) 264C UPDATED --MAY 2008. FLUCUATION PLOT 265C UPDATED --OCTOBER 2008. STRIP PLOT 266C UPDATED --SEPTEMBER 2009. TABLE <STAT> PLOT 267C UPDATED --OCTOBER 2009. "BATCH MULTIPLE" OPTION 268C FOR STRIP PLOT 269C UPDATED --JANUARY 2010. CALL LIST TO DPHIST 270C UPDATED --FEBRUARY 2012. ISO 13528 PLOT 271C UPDATED --FEBRUARY 2012. ISO 13528 ZSCORE PLOT 272C UPDATED --FEBRUARY 2012. ISO 13528 JSCORE PLOT 273C UPDATED --FEBRUARY 2012. ISO 13528 RLP PLOT 274C UPDATED --OCTOBER 2013. FRECHET PLOT 275C UPDATED --NOVEMBER 2013. BIVARIATE NORMAL CONFIDENCE 276C REGION PLOT 277C UPDATED --AUGUST 2014. DISTRIBUTIONAL FIT PLOT 278C UPDATED --FEBRUARY 2015. LORENZ CURVE 279C UPDATED --MAY 2015. H CONSISTENCY PLOT 280C UPDATED --MAY 2015. K CONSISTENCY PLOT 281C UPDATED --MAY 2015. COCHRAN VARIANCE PLOT 282C UPDATED --MAY 2015. <stat> CUMULATIVE STATISTIC PLOT 283C UPDATED --MAY 2015. <stat> MOVING STATISTIC PLOT 284C UPDATED --JUNE 2015. TWO WAY <ROW/COLUMN> PLOT 285C UPDATED --JUNE 2015. TWO FACTOR PLOT 286C UPDATED --JUNE 2016. <stat> WINDOW STATISTIC PLOT 287C UPDATED --FEBRUARY 2017. EMPIRICAL QUANTILE PLOT 288C UPDATED --MARCH 2017. TIQ PLOT 289C UPDATED --JULY 2017. BLAND ALTMAN PLOT 290C UPDATED --JULY 2017. NORMAL KERNEL DENSITY MIXTURE PLOT 291C UPDATED --FEBRUARY 2018. DEX ORDER PLOT 292C UPDATED --FEBRUARY 2019. CLASSIFICATION ... PLOT 293C UPDATED --MARCH 2019. CALL LIST TO DPBLOC 294C 295C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 296C 297 CHARACTER*4 ICASPL 298 CHARACTER*4 ICASP2 299 CHARACTER*4 ICAPSW 300 CHARACTER*4 IFORSW 301CCCCC CHARACTER*4 ICASSW 302 CHARACTER*4 IX1TSV 303 CHARACTER*4 IX2TSV 304 CHARACTER*4 IY1TSV 305 CHARACTER*4 IY2TSV 306 CHARACTER*4 IX1ZSV 307 CHARACTER*4 IX2ZSV 308 CHARACTER*4 IY1ZSV 309 CHARACTER*4 IY2ZSV 310 CHARACTER*4 IAND1 311 CHARACTER*4 IAND2 312 CHARACTER*4 ICONT 313 CHARACTER*4 IDIREC 314 CHARACTER*4 IWRITE 315 CHARACTER*4 IH 316 CHARACTER*4 IH2 317 CHARACTER*4 ISUBN0 318 CHARACTER*4 ISUBRO 319 CHARACTER*4 IFOUND 320 CHARACTER*4 IERROR 321 CHARACTER*4 IRHSTG 322 CHARACTER*4 IBCABT 323 CHARACTER*4 IHSTCW 324 CHARACTER*4 IHSTEB 325 CHARACTER*4 IHSTOU 326 CHARACTER*4 IHSTOP 327 CHARACTER*4 IASHWT 328 CHARACTER*4 IGUIFL 329 CHARACTER*4 IERRFA 330 CHARACTER*4 ISUBN1 331 CHARACTER*4 ISUBN2 332C 333CCCCC DIMENSION TEMP(*) 334CCCCC DIMENSION TEMP2(*) 335CCCCC DIMENSION TEMP3(*) 336CCCCC DIMENSION XTEMP1(*) 337CCCCC DIMENSION XTEMP2(*) 338C 339C-----COMMON---------------------------------------------------------- 340C 341 INCLUDE 'DPCOPA.INC' 342 INCLUDE 'DPCOMC.INC' 343 INCLUDE 'DPCODB.INC' 344 INCLUDE 'DPCOHK.INC' 345 INCLUDE 'DPCOPC.INC' 346 INCLUDE 'DPCOSU.INC' 347 INCLUDE 'DPCODA.INC' 348 INCLUDE 'DPCOCO.INC' 349 INCLUDE 'DPCOHO.INC' 350C 351CCCCC TO AVOID NAME CONFLICTS, ONLY BRING IN THE SPECIFIC 352CCCCC COMMON BLOCK (NOT ALL OF DPCOST.INC) 353C 354 CHARACTER*4 IERRST 355 COMMON/CSETG/IERRST 356C 357C 358 INCLUDE 'DPCOZ3.INC' 359C 360 DIMENSION TEMP(MAXOBV) 361 DIMENSION TEMP2(MAXOBV) 362 EQUIVALENCE (G3RBAG(KGARB5),TEMP(1)) 363 EQUIVALENCE (G3RBAG(KGARB6),TEMP2(1)) 364C 365C-----COMMON VARIABLES (GENERAL)-------------------------------------- 366C 367 INCLUDE 'DPCOP2.INC' 368C 369C-----START POINT----------------------------------------------------- 370C 371CCCCC ICONT=IDEVCN(1) 372CCCCC ICOLOR=IDEVCL(1) 373CCCCC NUMHPP=IDEVPP(1,1) 374CCCCC NUMVPP=IDEVPP(1,2) 375 ISUBN1='MAIN' 376 ISUBN2='GR ' 377C 378 NACC=0 379 NREJ=0 380 NTOT=0 381C 382 IF(IBUGGR.EQ.'ON'.OR.ISUBRO.EQ.'INGR')THEN 383 WRITE(ICOUT,999) 384 999 FORMAT(1X) 385 CALL DPWRST('XXX','BUG ') 386 WRITE(ICOUT,51) 387 51 FORMAT('***** AT THE BEGINNING OF MAINGR--') 388 CALL DPWRST('XXX','BUG ') 389 WRITE(ICOUT,52)ICONT,ICOLOR,NUMHPP,NUMVPP 390 52 FORMAT('ICONT,ICOLOR,NUMHPP,NUMVPP = ',2(A4,2X),2I8) 391 CALL DPWRST('XXX','BUG ') 392 WRITE(ICOUT,53)IBUGGR,IBUGG2,IBUGG3 393 53 FORMAT('IBUGGR,IBUGG2,IBUGG3 = ',2(A4,2X),A4) 394 CALL DPWRST('XXX','BUG ') 395 WRITE(ICOUT,54)IBUGPL,IBUGP,IBUGP1,IBUGP2,IBUGP3 396 54 FORMAT('IBUGPL,IBUGP,IBUGP1,IBUGP2,IBUGP3 = ',4(A4,2X),A4) 397 CALL DPWRST('XXX','BUG ') 398 WRITE(ICOUT,55)IBUGCO,IBUGEV,IBUGQ,ISUBRO 399 55 FORMAT('IBUGCO,IBUGEV,IBUGQ,ISUBRO = ',3(A4,2X),A4) 400 CALL DPWRST('XXX','BUG ') 401 WRITE(ICOUT,57)IANGLU,MAXNPP,ISEED,IBOOSS 402 57 FORMAT('IANGLU,MAXNPP,ISEED,IBOOSS = ',A4,3I8) 403 CALL DPWRST('XXX','BUG ') 404 WRITE(ICOUT,59)ICASPL,IAND1,IAND2,IFENSW 405 59 FORMAT('ICASPL,IAND1,IAND2,IFENSW = ',3(A4,2X),A4) 406 CALL DPWRST('XXX','BUG ') 407 WRITE(ICOUT,60)IFOUND,IERROR,ICOM,ICOM2 408 60 FORMAT('IFOUND,IERROR,ICOM,ICOM2 = ',3(A4,2X),A4) 409 CALL DPWRST('XXX','BUG ') 410 WRITE(ICOUT,68)NUMARG,MAXNPP,ANOPL1,ANOPL2 411 68 FORMAT('NUMARG,MAXNPP,ANOPL1,ANOPL2 = ',2I8,2G15.7) 412 CALL DPWRST('XXX','BUG ') 413 DO70I=1,NUMARG 414 WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) 415 71 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ', 416 1 I8,3(2X,A4),2X,I8,G15.7) 417 CALL DPWRST('XXX','BUG ') 418 70 CONTINUE 419 WRITE(ICOUT,81)IX1TSC,IX2TSC,IY1TSC,IY2TSC 420 81 FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',3(A4,2X),A4) 421 CALL DPWRST('XXX','BUG ') 422 WRITE(ICOUT,82)IX1TSV,IX2TSV,IY1TSV,IY2TSV 423 82 FORMAT('IX1TSV,IX2TSV,IY1TSV,IY2TSV = ',3(A4,2X),A4) 424 CALL DPWRST('XXX','BUG ') 425 ENDIF 426C 427 IFOUND='NO' 428 IERROR='NO' 429 IF(ICOM.EQ.'LET ')GOTO9000 430 IBCABT='OFF' 431C 432C *********************************************** 433C ** TREAT THE EMPIRICAL QUANTILE PLOT CASE ** 434C ** QUANTILE BOX PLOT CASE ** 435C *********************************************** 436C 437 IF((ICOM.EQ.'EMPI' .AND. IHARG(1).EQ.'QUAN') .OR. 438 1 (IHARG(1).EQ.'EMPI' .AND. IHARG(2).EQ.'QUAN'))THEN 439 CALL DPEQFU(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 440 1 ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 441 IF(IFOUND.EQ.'YES')GOTO9000 442 ELSEIF(ICOM.EQ.'QUAN' .AND. IHARG(1).EQ.'BOX ' .AND. 443 1 IHARG(2).EQ.'PLOT')THEN 444 CALL DPEQFU(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 445 1 ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 446 IF(IFOUND.EQ.'YES')GOTO9000 447 ENDIF 448C 449C ******************************* 450C ** TREAT THE BOX PLOT CASE ** 451C ******************************* 452C 453 IF( 454 1 ICOM.EQ.'BOX' .OR. IHARG(1).EQ.'BOX' .OR. 455 1 IHARG(2).EQ.'BOX')THEN 456 CALL DPBOX(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 457 1 ICONT,IFENSW,IBUGG2,IBUGG3,IBUGQ,ISUBRO, 458 1 IFOUND,IERROR) 459 IF(IFOUND.EQ.'YES')GOTO9000 460 ENDIF 461C 462C ********************************************** 463C ** TREAT THE DISTRIBUTIONAL FIT PLOT CASE ** 464C ********************************************** 465C 466 IF(ICOM.EQ.'DIST' .AND. IHARG(1).EQ.'FIT ' .AND. 467 1 IHARG(2).EQ.'PLOT')THEN 468 CALL DPDFPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ISEED, 469 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 470 IF(IFOUND.EQ.'YES')GOTO9000 471 ELSEIF(IHARG(1).EQ.'DIST' .AND. IHARG(2).EQ.'FIT ' .AND. 472 1 IHARG(3).EQ.'PLOT')THEN 473 CALL DPDFPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ISEED, 474 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 475 IF(IFOUND.EQ.'YES')GOTO9000 476 ENDIF 477C 478C ********************************** 479C ** TREAT THE VIOLIN PLOT CASE ** 480C ********************************** 481C 482 IF( 483 1 ICOM.EQ.'VIOL' .OR. IHARG(1).EQ.'VIOL' .OR. 484 1 IHARG(2).EQ.'VIOL')THEN 485 CALL DPVIOL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 486 1 ICONT,IFENSW,IKDETY,IKDENP,PKDEWI, 487 1 ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 488 IF(IFOUND.EQ.'YES')GOTO9000 489 ENDIF 490C 491C **************************************************** 492C ** TREAT THE COMPLEX DEMODULATION ... PLOT CASE ** 493C **************************************************** 494C 495CCCCC IF(ICOM.EQ.'COMP')GOTO200 496 IF(ICOM.EQ.'COMP'.AND.NUMARG.GE.1.AND. 497 1IHARG(1).EQ.'DEMO')THEN 498 CALL DPCD(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 499 1 IANGLU,DEMOFR,DEMODF, 500 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 501 IF(IFOUND.EQ.'YES')GOTO9000 502 ENDIF 503C 504C **************************************** 505C ** TREAT THE ... CONTROL CHART CASE ** 506C **************************************** 507C 508CCCCC THE FOLLOWING LINE WAS COMMENTED OUT FEBRUARY 1989 509CCCCC AND REPLACED BY THE SUCCEEDING LINE FEBRUARY 1989 510CCCCC TO AVOID A CONFLICT WITH THE CONTINUE CHARACTER FEBRUARY 1989 511CCCCC IF(ICOM.EQ.'CONT')GOTO300 512CCCCC ADD HOTELLING CONTROL CHART (= MULTIVARIATE CONTROL 513CCCCC CHART) SEPTEMBER 1998 514CCCCC SUPPORT FOUR DISTINCT CASES FOR HOTELLING CONTROL FEBRUARY 2003 515CCCCC CHART: 516CCCCC 1) PHASE I HOTELLING CONTROL CHART 517CCCCC 2) PHASE I HOTELLING INDIVIDUAL CONTROL CHART 518CCCCC 3) PHASE II HOTELLING CONTROL CHART 519CCCCC 4) PHASE II HOTELLING INDIVIDUAL CONTROL CHART 520CCCCC IF PHASE <I/II> OMITTED, ASSUME A PHASE I CHART. 521C 522 IF(ICOM.EQ.'CONT'.AND.ICOM2.NE.'INUE')GOTO300 523 IF(ICOM.EQ.'CONT'.AND.ICOM2.NE.'OUR ')GOTO300 524 IF(ICOM.EQ.'CONT'.AND.IHARG(1).NE.'LOOP')GOTO300 525C 526 IF(ICOM.EQ.'PHAS')THEN 527 IF(IHARG(1).EQ.'I'.OR.IHARG(1).EQ.'ONE'.OR.IHARG(1).EQ.'1')THEN 528 CALL DPHTCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 529 1 ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 530 IF(IFOUND.EQ.'YES')GOTO9000 531 ELSEIF(IHARG(1).EQ.'II'.OR.IHARG(1).EQ.'TWO'.OR. 532 1 IHARG(1).EQ.'2')THEN 533 CALL DPHTCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 534 1 ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 535 IF(IFOUND.EQ.'YES')GOTO9000 536 ENDIF 537 ELSEIF(ICOM.EQ.'HOTE'.OR. 538 1 (ICOM.EQ.'MULT'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'CONT'))THEN 539 CALL DPHTCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 540 1 ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 541 IF(IFOUND.EQ.'YES')GOTO9000 542 ENDIF 543C 544C 2015/09: CHECK FOR CONFLICT WITH CONTOUR OR DEX CONTOUR 545C 546 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CONT'.AND. 547 1 IHARG2(1).NE.'OUR ')GOTO300 548 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHAR')GOTO300 549 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CONT'.AND. 550 1 IHARG2(2).NE.'OUR ')GOTO300 551 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CHAR')GOTO300 552 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'CONT'.AND. 553 1 IHARG2(3).NE.'OUR ')GOTO300 554 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'CHAR')GOTO300 555 GOTO399 556C 557 300 CONTINUE 558 CALL DPCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 559 1 ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 560 IF(IFOUND.EQ.'YES')GOTO9000 561C 562 399 CONTINUE 563C 564C ******************************************* 565C ** TREAT THE ... CORRELATION PLOT CASE ** 566C ******************************************* 567C 568C 2012/1: FOLD IN COMOVEMENT PLOT IN WITH CORRELATION PLOT. 569C 570 IF(ICOM.EQ.'AUTO' .OR. ICOM.EQ.'CROS' .OR. 571 1 ICOM.EQ.'PART' .OR. ICOM.EQ.'COMO' .OR. 572 1 IHARG(1).EQ.'AUTO' .OR. IHARG(2).EQ.'CROS' .OR. 573 1 IHARG(1).EQ.'PART' .OR. IHARG(1).EQ.'COMO')THEN 574 CALL DPCORR(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 575 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 576 IF(IFOUND.EQ.'YES')GOTO9000 577 ENDIF 578C 579C ***************************************** 580C ** TREAT THE ... FREQUENCY PLOT CASE ** 581C ***************************************** 582C 583 IF(ICOM.EQ.'FREQ' .OR. IHARG(1).EQ.'FREQ' .OR. 584 1 IHARG(2).EQ.'FREQ' .OR. IHARG(3).EQ.'FREQ' .OR. 585 1 IHARG(4).EQ.'FREQ')THEN 586 CALL DPFREQ(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 587 1 CLLIMI,CLWIDT, 588 1 IRHSTG,IHSTCW,IHSTEB,IHSTOU, 589 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 590 IF(IFOUND.EQ.'YES')GOTO9000 591 ENDIF 592C 593C ************************************ 594C ** TREAT THE ... HISTOGRAM CASE ** 595C ************************************ 596C 597 IF(ICOM.EQ.'HIST' .OR. ICOM.EQ.'ASH ')GOTO600 598 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'HIST')GOTO600 599 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'HIST')GOTO600 600 GOTO699 601C 602 600 CONTINUE 603 CALL DPHIST(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 604 1CLLIMI,CLWIDT, 605CCCCC MARCH 1996. ADD FOLLOWING LINE 606 1IRHSTG,IHSTCW,IASHWT,IHSTEB,IHSTOU,IHSTMC,IHSTOP, 607 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 608 IF(IFOUND.EQ.'YES')GOTO9000 609C 610 699 CONTINUE 611C 612C ***************************** 613C ** TREAT THE I PLOT CASE ** 614C ***************************** 615C 616C 10/18/2013: THERE ARE A NUMBER OF NEW VARIANTS TO THIS 617C COMMAND. SO CALL THIS ROUTINE AND LET DPI 618C DETERMINE IF A VALID I PLOT COMMAND HAS BEEN 619C ENTERED. 620C 621CCCCC IF( 622CCCCC1 ICOM.EQ.'I' .OR. IHARG(1).EQ.'I' .OR. 623CCCCC1 IHARG(2).EQ.'I' .OR. IHARG(3).EQ.'I')THEN 624 CALL DPI(NPLOTV,NPLOTP,NS,ICASPL,ISEED,IAND1,IAND2, 625 1 ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 626 IF(IFOUND.EQ.'YES')GOTO9000 627CCCCC ENDIF 628C 629C *********************************** 630C ** TREAT THE LAG ... PLOT CASE ** 631C *********************************** 632C 633 IF(ICOM.EQ.'LAG' .OR. IHARG(1).EQ.'LAG')THEN 634 CALL DPLAG(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 635 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 636 IF(IFOUND.EQ.'YES')GOTO9000 637 ENDIF 638C 639C ***************************************** 640C ** TREAT THE PERCENT POINT PLOT CASE ** 641C ***************************************** 642C 643 IMAX=NUMARG-1 644 IF(IMAX.LE.0)GOTO1099 645 IFLAG1=0 646 IFLAG2=0 647 IFLAG3=0 648 IF(ICOM.EQ.'PERC' .AND. ICOM2.NE.'ENTI')IFLAG1=1 649 DO1010I=1,NUMARG 650 IF(IHARG(I).EQ.'PERC' .AND. IHARG2(I).NE.'ENTI')IFLAG1=1 651 IF(IHARG(I).EQ.'POIN')IFLAG2=1 652 IF(IHARG(I).EQ.'PLOT')IFLAG3=1 653 1010 CONTINUE 654 IF(IFLAG1*IFLAG2*IFLAG3.EQ.1)THEN 655 CALL DPPERC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 656 1 CLLIMI,CLWIDT, 657 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 658 IF(IFOUND.EQ.'YES')GOTO9000 659 ENDIF 660C 661 1099 CONTINUE 662C 663C ************************************** 664C ** TREAT THE ... PERIODOGRAM CASE ** 665C ************************************** 666C 667CCCCC 2012/1: HANDLE WITH SPECTRAL PLOT 668C 669CCCCC IF(NUMARG.GE.4.AND.IHARG(4).EQ.'ASD')GOTO9399 670CCCCC IF(ICOM.EQ.'PERI')GOTO1100 671CCCCC IF(ICOM2.EQ.'PERI')GOTO1100 672CCCCC IF(ICOM2.EQ.'SPER')GOTO1100 673CCCCC IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PERI')GOTO1100 674CCCCC GOTO1199 675C 676C1100 CONTINUE 677CCCCC CALL DPPERI(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 678CCCCC1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 679CCCCC IF(IFOUND.EQ.'YES')GOTO9000 680C 681C1199 CONTINUE 682C 683C ******************************** 684C ** TREAT THE PIE CHART CASE ** 685C ******************************** 686C 687 IF(ICOM.EQ.'PIE')THEN 688 CALL DPPIE(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 689 1 CLLIMI,CLWIDT, 690 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 691 IF(IFOUND.EQ.'YES')GOTO9000 692 ENDIF 693C 694C ************************************ 695C ** TREAT THE PLOT CASE. ** 696C ** TREAT THE YOUDEN PLOT ** 697C ** AS A SPECIAL CASE OF PLOT ** 698C ** (PLOT WITH 3 ARGUMENTS). ** 699C ** TREAT THE SCATTER PLOT ** 700C ** AS A SYNONYM FOR PLOT ** 701C ************************************ 702C 703 IF((ICOM.EQ.'YOUD' .OR. ICOM.EQ.'SCAT') .AND. 704 1 IHARG(1).NE.'INDE')THEN 705 ISHIFT=1 706 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 707 1 IBUGA2,IERROR) 708 ELSEIF(ICOM.NE.'PLOT')THEN 709 GOTO1399 710 ENDIF 711C 712 IAND1=IAND2 713 CALL DPPLOT(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 714 1 IANGLU,MAXNPP, 715 1 IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,ISUBRO, 716 1 IFOUND,IERROR) 717C 718 IF(IBUGGR.EQ.'ON'.OR.ISUBRO.EQ.'INGR')THEN 719 WRITE(ICOUT,333)IFOUND,IERROR,IAND1,IAND2 720 333 FORMAT('IFOUND,IERROR,IAND1,IAND2 = ',3(A4,2X),A4) 721 CALL DPWRST('XXX','BUG ') 722 ENDIF 723C 724 IF(IFOUND.EQ.'YES')GOTO9000 725CCCCC IF(IAND2.EQ.'YES')GOTO100 726CCCCC IF(IAND2.EQ.'NO')GOTO9000 727C 728 1399 CONTINUE 729C 730C **************************************************** 731C ** TREAT THE ... MOVING STATISTIC PLOT CASE ** 732C ** TREAT THE ... CUMULATIVE STATISTIC PLOT CASE ** 733C ** TREAT THE ... WINDOW STATISTIC PLOT CASE ** 734C *************************************************** 735C 736 IF(ICOM.EQ.'FLUC')GOTO6399 737 DO6302I=1,NUMARG 738 IF(IHARG(I).EQ.'INTE'.AND.IHARG2(I).EQ.'RACT')GOTO6399 739 IF(IHARG(I).EQ.'INFL'.AND.IHARG2(I).EQ.'UENC')GOTO6399 740 IF(IHARG(I).EQ.'BLOC')GOTO6399 741 6302 CONTINUE 742 DO6303I=1,NUMARG-1 743 IF(IHARG(I).EQ.'PROB' .AND. IHARG(I+1).EQ.'PLOT')GOTO6399 744 IF(IHARG(I).EQ.'PPCC' .AND. IHARG(I+1).EQ.'PLOT')GOTO6399 745 6303 CONTINUE 746C 747 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')GOTO6300 748 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'PLOT')GOTO6300 749 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'PLOT')GOTO6300 750 IF(NUMARG.GE.4.AND.IHARG(4).EQ.'PLOT')GOTO6300 751 IF(NUMARG.GE.5.AND.IHARG(5).EQ.'PLOT')GOTO6300 752 IF(NUMARG.GE.6.AND.IHARG(6).EQ.'PLOT')GOTO6300 753 GOTO6399 754C 755 6300 CONTINUE 756 CALL DPMOSP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 757 1 MAXNXT,ISEED,FILWID, 758 1 ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 759 IF(IFOUND.EQ.'YES')GOTO9000 760C 761 6399 CONTINUE 762C 763C *********************************************** 764C ** TREAT THE <DIST> TIQP PLOT CASE ** 765C *********************************************** 766C 767 IF(ICOM.EQ.'TIQ ' .OR. IHARG(1).EQ.'TIQ ' .OR. 768 1 IHARG(2).EQ.'TIQ ' .OR. IHARG(3).EQ.'TIQ ')THEN 769 CALL DPTIQP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 770 1 ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 771 IF(IFOUND.EQ.'YES')GOTO9000 772 ELSEIF(ICOM.EQ.'TRUN' .AND. IHARG(1).EQ.'INFO' .AND. 773 1 IHARG(2).EQ.'QUAN')THEN 774 CALL DPTIQP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 775 1 ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 776 IF(IFOUND.EQ.'YES')GOTO9000 777 ELSEIF(IHARG(1).EQ.'TRUN' .OR. IHARG(2).EQ.'TRUN' .OR. 778 1 IHARG(3).EQ.'TRUN' .OR. IHARG(4).EQ.'TRUN')THEN 779 CALL DPTIQP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 780 1 ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 781 IF(IFOUND.EQ.'YES')GOTO9000 782 ENDIF 783C 784C **************************************** 785C ** TREAT THE ... STATISTIC PLOT CASE ** 786C **************************************** 787C 788 IF(ICOM.EQ.'FLUC')GOTO6699 789 DO6602I=1,NUMARG 790 IF(IHARG(I).EQ.'INTE'.AND.IHARG2(I).EQ.'RACT')GOTO6699 791 IF(IHARG(I).EQ.'INFL'.AND.IHARG2(I).EQ.'UENC')GOTO6699 792 IF(IHARG(I).EQ.'BLOC')GOTO6699 793 6602 CONTINUE 794 DO6603I=1,NUMARG-1 795 IF(IHARG(I).EQ.'PROB' .AND. IHARG(I+1).EQ.'PLOT')GOTO6699 796 IF(IHARG(I).EQ.'PPCC' .AND. IHARG(I+1).EQ.'PLOT')GOTO6699 797 6603 CONTINUE 798C 799 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')GOTO6600 800 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'PLOT')GOTO6600 801 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'PLOT')GOTO6600 802 IF(NUMARG.GE.4.AND.IHARG(4).EQ.'PLOT')GOTO6600 803 IF(NUMARG.GE.5.AND.IHARG(5).EQ.'PLOT')GOTO6600 804 IF(NUMARG.GE.6.AND.IHARG(6).EQ.'PLOT')GOTO6600 805 GOTO6699 806C 807 6600 CONTINUE 808 CALL DPSP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 809CCCCC1TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, 810 1MAXNXT, 811CCCCC JULY 2002. ADD ISEED FOR HODGES-LEHMAN PLOT 812 1ISEED, 813 1ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 814 IF(IFOUND.EQ.'YES')GOTO9000 815C 816 6699 CONTINUE 817C 818C ******************************************* 819C ** TREAT THE ... PROBABILITY PLOT CASE ** 820C ******************************************* 821C 822 IMAX=NUMARG-1 823 IF(IMAX.GT.1)THEN 824 DO1410I=1,NUMARG 825 IF(IHARG(I).EQ.'PROB')THEN 826 CALL DPPP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 827 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 828 IF(IFOUND.EQ.'YES')GOTO9000 829 ENDIF 830 1410 CONTINUE 831 ENDIF 832C 833C ************************************ 834C ** TREAT THE ... PPCC PLOT CASE ** 835C ************************************ 836C 837C SINCE A NUMBER OF GOODNESS-OF-FIT STATISTICS ARE NOW 838C SUPPORTED, JUST CALL THIS COMMAND AND SEE IF DPPPCC 839C RECOGNIZES ONE OF THE SUPPORTED STATISTICS. NO NEED TO 840C DUPLICATE HERE. 841C 842 CALL DPPPCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 843 1ICASP2, 844 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 845 IF(IFOUND.EQ.'YES')GOTO9000 846C 847C **************************************** 848C ** TREAT THE RUN SEQUENCE PLOT CASE ** 849C **************************************** 850C 851 IF((ICOM.EQ.'RUN'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'SEQU') .OR. 852 1 (IHARG(1).EQ.'RUN'.AND.IHARG(2).EQ.'SEQU') .OR. 853 1 (IHARG(2).EQ.'RUN'.AND.IHARG(3).EQ.'SEQU'))THEN 854 CALL DPRUNS(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 855 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 856 IF(IFOUND.EQ.'YES')GOTO9000 857 ENDIF 858C 859C ************************************ 860C ** TREAT THE RUNS ... PLOT CASE ** 861C ************************************ 862C 863 IF(ICOM.EQ.'RUNS'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')THEN 864 CALL DPRUPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 865 1 IANGLU,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 866 IF(IFOUND.EQ.'YES')GOTO9000 867 ENDIF 868C 869C **************************************** 870C ** TREAT THE ... SPECTRAL PLOT CASE ** 871C **************************************** 872C 873 IF(ICOM.EQ.'CHAR' .AND. IHARG(1).EQ.'AUTO')GOTO1899 874 IF(ICOM.EQ.'PHAS' .AND. IHARG(1).EQ.'PLAN')GOTO1899 875 IF(ICOM.EQ.'PHAS' .AND. IHARG(1).EQ.'I ')GOTO1899 876 IF(ICOM.EQ.'PHAS' .AND. IHARG(1).EQ.'1 ')GOTO1899 877 IF(ICOM.EQ.'PHAS' .AND. IHARG(1).EQ.'ONE ')GOTO1899 878 IF(ICOM.EQ.'PHAS' .AND. IHARG(1).EQ.'II ')GOTO1899 879 IF(ICOM.EQ.'PHAS' .AND. IHARG(1).EQ.'2 ')GOTO1899 880 IF(ICOM.EQ.'PHAS' .AND. IHARG(1).EQ.'TWO ')GOTO1899 881 IF(ICOM.EQ.'QUAD' .AND. IHARG(1).EQ.'SPLIN')GOTO1899 882 IF(ICOM.EQ.'QUAD' .AND. IHARG(1).EQ.'FIT')GOTO1899 883C 884 IF(ICOM.EQ.'AUTO' .OR. IHARG(1).EQ.'AUTO')GOTO1800 885 IF(ICOM.EQ.'SPEC' .OR. IHARG(1).EQ.'SPEC')GOTO1800 886 IF(ICOM.EQ.'PERI' .OR. IHARG(1).EQ.'PERI')GOTO1800 887 IF(ICOM.EQ.'COSP' .OR. IHARG(1).EQ.'COSP')GOTO1800 888 IF(ICOM.EQ.'QUAD' .AND. IHARG(1).EQ.'SPEC')GOTO1800 889 IF(IHARG(1).EQ.'QUAD' .AND. IHARG(2).EQ.'SPEC')GOTO1800 890 IF(ICOM.EQ.'CROS'.AND.IHARG(1).EQ.'SPEC')GOTO1800 891 IF(IHARG(1).EQ.'CROS'.AND.IHARG(2).EQ.'SPEC')GOTO1800 892 IF(ICOM.EQ.'COHE' .OR. IHARG(1).EQ.'COHE')GOTO1800 893 IF(ICOM.EQ.'AMPL' .OR. IHARG(1).EQ.'AMPL')GOTO1800 894 IF(ICOM.EQ.'PHAS' .OR. IHARG(1).EQ.'PHAS')GOTO1800 895 IF(ICOM.EQ.'GAIN' .OR. IHARG(1).EQ.'GAIN')GOTO1800 896 IF(ICOM.EQ.'ARGA' .OR. IHARG(1).EQ.'ARGA')GOTO1800 897 GOTO1899 898C 899 1800 CONTINUE 900 CALL DPSPEC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 901 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 902 IF(IFOUND.EQ.'YES')GOTO9000 903C 904 1899 CONTINUE 905C 906C ********************************************* 907C ** TREAT THE 3-D ... FREQUENCY PLOT CASE ** 908C ********************************************* 909C 910C NOTE: THIS COMMAND IS NOT IMPLEMENTED YET. 911C 912CCCCC IF(ICOM.EQ.'3D' .AND. IHARG(1).EQ.'FREQ')THEN 913C 914CCCCC CALL DP3DFR(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 915CCCCC1 IANGLU,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 916CCCCC ENDIF 917CCCCC IF(IFOUND.EQ.'YES')GOTO9000 918C 919C2099 CONTINUE 920C 921C **************************************** 922C ** TREAT THE 3-D ... HISTOGRAM CASE ** 923C **************************************** 924C 925C NOTE: THIS COMMAND IS NOT IMPLEMENTED YET. 926C 927CCCCC IF(ICOM.EQ.'3D' .AND. IHARG(1).EQ.'HIST')THEN 928CCCCC CALL DP3DHI(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 929CCCCC1 IANGLU,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 930CCCCC ENDIF 931CCCCC IF(IFOUND.EQ.'YES')GOTO9000 932C 933C2199 CONTINUE 934C 935C ******************************* 936C ** TREAT THE 3-D PLOT CASE ** 937C ******************************* 938C 939 IF(ICOM.EQ.'3D' .OR. ICOM.EQ.'3DPL' .OR. 940 1 (ICOM.EQ.'3' .AND. IHARG(1).NE.'PARA'))THEN 941 CALL DP3DPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 942 1 IANGLU,IFORSW,MAXNPP, 943 1 IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,ISUBRO, 944 1 IFOUND,IERROR) 945C 946 IF(IBUGGR.EQ.'ON'.OR.ISUBRO.EQ.'INGR')THEN 947 WRITE(ICOUT,1933)IFOUND,IERROR,IAND1,IAND2 948 1933 FORMAT('IFOUND,IERROR,IAND1,IAND2 = ',3(A4,2X),A4) 949 CALL DPWRST('XXX','BUG ') 950 ENDIF 951 ENDIF 952 IF(IFOUND.EQ.'YES')GOTO9000 953CCCCC IF(IAND2.EQ.'YES')GOTO100 954CCCCC IF(IAND2.EQ.'NO')GOTO9000 955C 956C *********************************************** 957C ** TREAT THE BOX-COX NORMALITY PLOT ** 958C ** TREAT THE BOX-COX LINEARITY PLOT ** 959C ** TREAT THE BOX-COX HOMOSCEDASTICITY PLOT ** 960C *********************************************** 961C 962 IF( 963 1 (ICOM.EQ.'BOX' .AND. IHARG(1).EQ.'COX') .OR. 964 1 (IHARG(1).EQ.'BOX' .AND. IHARG(2).EQ.'COX'))THEN 965 CALL DPBCNP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 966 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 967 IF(IFOUND.EQ.'YES')GOTO9000 968 ENDIF 969C 970C ************************************** 971C ** TREAT THE PROPORTION PLOT CASE ** 972C ** = THE ANOP PLOT CASE ** 973C ************************************** 974C 975 IF( 976 1 (ICOM.EQ.'PROP'.AND.IHARG(1).EQ.'PLOT') .OR. 977 1 (ICOM.EQ.'ANOP'.AND.IHARG(1).EQ.'PLOT') .OR. 978 1 (ICOM.EQ.'ANAL'.AND.IHARG(1).EQ.'OF ' .AND. 979 1 IHARG(2).EQ.'PROP'.AND.IHARG(3).EQ.'PLOT') .OR. 980 1 ICOM.EQ.'MULT')THEN 981C 982 CALL DPANPP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 983 1 IANGLU,MAXNPP, 984 1 ANOPL1,ANOPL2, 985 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 986 IF(IFOUND.EQ.'YES')GOTO9000 987C 988 ENDIF 989C 990C ************************************ 991C ** TREAT THE BAR PLOT CASE ** 992C ************************************ 993C 994 IF(ICOM.EQ.'BAR'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT') 995 1GOTO2600 996 IF(ICOM.EQ.'BAR'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'CHAR') 997 1GOTO2600 998 GOTO2699 999C 1000 2600 CONTINUE 1001 CALL DPBARP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1002 1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1003 IF(IFOUND.EQ.'YES')GOTO9000 1004C 1005 2699 CONTINUE 1006C 1007C ******************************* 1008C ** TREAT THE FFT PLOT CASE ** 1009C ******************************* 1010C 1011CCCCC IF(ICOM.EQ.'FFT'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT') 1012CCCCC1GOTO2700 1013CCCCC GOTO2799 1014C 1015C2700 CONTINUE 1016CCCCC CALL DPFFTP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1017CCCCC1IANGLU,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1018CCCCC IF(IFOUND.EQ.'YES')GOTO9000 1019C 1020C2799 CONTINUE 1021C 1022C ************************************ 1023C ** TREAT THE ... ROOTOGRAM CASE ** 1024C ************************************ 1025C 1026 IF(ICOM.EQ.'ROOT')GOTO2800 1027 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ROOT')GOTO2800 1028 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'ROOT')GOTO2800 1029 GOTO2899 1030C 1031 2800 CONTINUE 1032CCCCC CALL DPROGR(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1033CCCCC1CLLIMI,CLWIDT, 1034CCCCC1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1035 CALL DPHIST(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1036 1CLLIMI,CLWIDT, 1037 1IRHSTG,IHSTCW,IASHWT,IHSTEB,IHSTOU,IHSTMC,IHSTOP, 1038 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1039 IF(IFOUND.EQ.'YES')GOTO9000 1040C 1041 2899 CONTINUE 1042C 1043C ******************************************** 1044C ** TREAT THE STEM AND LEAF DIAGRAM CASE ** 1045C ******************************************** 1046C 1047 IF(ICOM.EQ.'STEM')THEN 1048 CALL DPSTEM(IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) 1049 IF(IFOUND.EQ.'YES')GOTO9000 1050 ENDIF 1051C 1052C ***************************************************** 1053C ** TREAT THE ALLAN VARIANCE PLOT CASE ** 1054C ** TREAT THE ALLAN STANDARD DEVIATION PLOT CASE ** 1055C ***************************************************** 1056C 1057 IF(ICOM.EQ.'ALLA' .OR. ICOM.EQ.'AV' .OR. ICOM.EQ.'ASD' .OR. 1058 1 ICOM.EQ.'AS ' .OR. 1059 1 IHARG(1).EQ.'ALLA' .OR. IHARG(1).EQ.'AV ' .OR. 1060 1 IHARG(1).EQ.'ASD ' .OR. IHARG(1).EQ.'AS ')THEN 1061 CALL DPALLA(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1062 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1063 IF(IFOUND.EQ.'YES')GOTO9000 1064 ENDIF 1065C 1066C **************************************************** 1067C ** TREAT THE COMPLEX REMODULATION PLOT CASE ** 1068C **************************************************** 1069C 1070 IF(ICOM.EQ.'REMO')GOTO3300 1071 IF(ICOM.EQ.'COMP'.AND.NUMARG.GE.1.AND. 1072 1IHARG(1).EQ.'REMO')GOTO3300 1073 GOTO3399 1074C 1075 3300 CONTINUE 1076 CALL DPREMO(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1077 1IANGLU,DEMOFR,DEMODF,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1078 IF(IFOUND.EQ.'YES')GOTO9000 1079C 1080 3399 CONTINUE 1081C 1082C ************************************ 1083C ** TREAT THE SYMMETRY PLOT CASE ** 1084C ************************************ 1085C 1086 IF(ICOM.EQ.'SYMM' .OR. IHARG(1).EQ.'SYMM')THEN 1087 CALL DPSYMM(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1088 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1089 IF(IFOUND.EQ.'YES')GOTO9000 1090 ENDIF 1091C 1092C ******************************************** 1093C ** TREAT THE BOX-COX SYMMETRY PLOT CASE ** 1094C ******************************************** 1095C 1096CNNNN IF(NUMARG.GE.2.AND.ICOM.EQ.'BOX'.AND. 1097CNNNN1IHARG(1).EQ.'COX'.AND.IHARG(2).EQ.'SYMM')GOTO4200 1098CNNNN GOTO4299 1099C 1100C4200 CONTINUE 1101CNNNN CALL DPBCSP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1102CNNNN1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1103CNNNN IF(IFOUND.EQ.'YES')GOTO9000 1104C 1105C4299 CONTINUE 1106C 1107C ********************************************* 1108C ** TREAT THE QUANTILE-QUANTILE PLOT CASE ** 1109C ********************************************* 1110C 1111 IF(ICOM.EQ.'QUAN' .OR. 1112 1 ((ICOM.EQ.'HIGH'.OR.ICOM.EQ.'SUBS') .AND. 1113 1 IHARG(1).EQ.'QUAN'))THEN 1114 CALL DPQUAN(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1115 1 IANGLU,MAXNPP,IBOOSS,ISEED, 1116 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1117 IF(IFOUND.EQ.'YES')GOTO9000 1118 ENDIF 1119C 1120C ********************************************* 1121C ** TREAT THE BAG PLOT CASE ** 1122C ********************************************* 1123C 1124C THIS IS NOT YET IMPLEMENTED. 1125C 1126 IF(ICOM.EQ.'BAG ')THEN 1127CCCCC CALL DPBAGP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1128CCCCC1 ISEED,MAXNPP, 1129CCCCC1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1130CCCCC IF(IFOUND.EQ.'YES')GOTO9000 1131 ENDIF 1132C 1133C ******************************************** 1134C ** TREAT THE HOMOSCEDASTICITY PLOT CASE ** 1135C ******************************************** 1136C 1137 IF(ICOM.EQ.'HOMO')GOTO4400 1138 IF(ICOM.EQ.'SUBS'.AND.IHARG(1).EQ.'HOMO')GOTO4400 1139 IF(ICOM.EQ.'HIGH'.AND.IHARG(1).EQ.'HOMO')GOTO4400 1140 IF(ICOM.EQ.'SUMM'.AND.IHARG(1).EQ.'HOMO')GOTO4400 1141 IF(ICOM.EQ.'REPL'.AND.IHARG(1).EQ.'HOMO')GOTO4400 1142 IF(ICOM.EQ.'MULT'.AND.IHARG(1).EQ.'HOMO')GOTO4400 1143 IF(ICOM.EQ.'SUBS'.AND.IHARG(1).EQ.'SUMM'.AND. 1144 1 IHARG(2).EQ.'HOMO')GOTO4400 1145 IF(ICOM.EQ.'SUBS'.AND.IHARG(1).EQ.'HOMO'.AND. 1146 1 IHARG(2).EQ.'SUMM')GOTO4400 1147 IF(ICOM.EQ.'SUMM'.AND.IHARG(1).EQ.'SUBS'.AND. 1148 1 IHARG(2).EQ.'HOMO')GOTO4400 1149 IF(ICOM.EQ.'HIGH'.AND.IHARG(1).EQ.'SUMM'.AND. 1150 1 IHARG(2).EQ.'HOMO')GOTO4400 1151 IF(ICOM.EQ.'HIGH'.AND.IHARG(1).EQ.'HOMO'.AND. 1152 1 IHARG(2).EQ.'SUMM')GOTO4400 1153 IF(ICOM.EQ.'SUMM'.AND.IHARG(1).EQ.'HIGH'.AND. 1154 1 IHARG(2).EQ.'HOMO')GOTO4400 1155 IF(ICOM.EQ.'SUMM'.AND.IHARG(1).EQ.'HOMO'.AND. 1156 1 IHARG(2).EQ.'HIGH')GOTO4400 1157 IF(ICOM.EQ.'SUMM'.AND.IHARG(1).EQ.'HOMO'.AND. 1158 1 IHARG(2).EQ.'SUBS')GOTO4400 1159 GOTO4499 1160C 1161 4400 CONTINUE 1162 CALL DPHOMO(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1163 1ISEED, 1164 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1165 IF(IFOUND.EQ.'YES')GOTO9000 1166C 1167 4499 CONTINUE 1168C 1169C *************************************** 1170C ** TREAT THE BIHISTOGRAM PLOT CASE ** 1171C *************************************** 1172C 1173 IF(ICOM.EQ.'BIHI' .OR. IHARG(1).EQ.'BIHI' .OR. 1174 1 IHARG(2).EQ.'BIHI' .OR. IHARG(3).EQ.'BIHI' .OR. 1175 1 ICOM.EQ.'BIRO' .OR. IHARG(1).EQ.'BIRO' .OR. 1176 1 IHARG(2).EQ.'BIRO' .OR. IHARG(3).EQ.'BIRO' .OR. 1177 1 (ICOM.EQ.'BIAS' .AND. ICOM2.EQ.'H ') .OR. 1178 1 IHARG(1).EQ.'BIAS' .OR. IHARG(2).EQ.'BIAS')THEN 1179 CALL DPBIHI(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1180 1 CLLIMI,CLWIDT, 1181 1 IRHSTG,IHSTCW,IASHWT,IHSTEB,IHSTOU, 1182 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1183 IF(IFOUND.EQ.'YES')GOTO9000 1184 ENDIF 1185C 1186C ************************************ 1187C ** TREAT THE YOUDEN PLOT CASE ** 1188C ************************************ 1189C 1190CNNNN IF(ICOM.EQ.'YOUDEN')GOTO4700 1191CNNNN GOTO4799 1192C 1193C4700 CONTINUE 1194CNNNN CALL DPYOUD(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1195CNNNN1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1196CNNNN IF(IFOUND.EQ.'YES')GOTO9000 1197C 1198C4799 CONTINUE 1199C 1200C ************************************ 1201C ** TREAT THE GANOVA PLOT CASE ** 1202C ************************************ 1203C 1204CNNNN IF(ICOM.EQ.'GANO'.AND.ICOM2.EQ.'VA ')GOTO4800 1205CNNNN GOTO4899 1206C 1207C4800 CONTINUE 1208CNNNN CALL DPGANO(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1209CNNNN1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1210CNNNN IF(IFOUND.EQ.'YES')GOTO9000 1211C 1212C4899 CONTINUE 1213C 1214C ************************************* 1215C ** TREAT THE DRAFTSMAN PLOT CASE ** 1216C ************************************* 1217C 1218CNNNN IF(ICOM.EQ.'DRSF')GOTO6100 1219CNNNN GOTO6199 1220C 1221C6100 CONTINUE 1222CNNNN CALL DPDRAF(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1223CNNNN1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1224CNNNN IF(IFOUND.EQ.'YES')GOTO9000 1225C 1226C6199 CONTINUE 1227C 1228C *********************************** 1229C ** TREAT THE CONTOUR PLOT CASE ** 1230C *********************************** 1231C 1232 IF(ICOM.EQ.'CONT'.AND.IHARG(1).EQ.'PLOT')THEN 1233 CALL DPCOPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1234 1 IANGLU,MAXNPP, 1235 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1236C 1237 IF(IBUGGR.EQ.'ON'.OR.ISUBRO.EQ.'INGR')THEN 1238 WRITE(ICOUT,6233)IFOUND,IERROR,IAND1,IAND2 1239 6233 FORMAT('IFOUND,IERROR,IAND1,IAND2 = ',3(A4,2X),A4) 1240 CALL DPWRST('XXX','BUG ') 1241 ENDIF 1242 IF(IFOUND.EQ.'YES')GOTO9000 1243 ENDIF 1244C 1245C ********************************************************* 1246C ** TREAT THE BOX-COX STANDARDIZED EFFECTS PLOT CASE ** 1247C ********************************************************* 1248C 1249 IF(NUMARG.GE.3.AND.ICOM.EQ.'BOX'.AND. 1250 1IHARG(1).EQ.'COX'.AND.IHARG(2).EQ.'STAN'.AND. 1251 1IHARG(3).EQ.'EFFE')GOTO6400 1252 GOTO6499 1253C 1254 6400 CONTINUE 1255CCCCC CALL DPBCSE(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1256CCCCC1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1257CCCCC IF(IFOUND.EQ.'YES')GOTO9000 1258C 1259 6499 CONTINUE 1260C 1261C ************************************ 1262C ** TREAT THE WEIBULL PLOT CASE ** 1263C ************************************ 1264C 1265C OCTOBER 2013: ADD FRECHET PLOT 1266C 1267 IF((ICOM.EQ.'WEIB' .OR. ICOM.EQ.'FREC') .AND. 1268 1 IHARG(1).EQ.'PLOT')GOTO6510 1269 IF(ICOM.EQ.'HIGH' .AND. 1270 1 (IHARG(1).EQ.'WEIB' .OR. IHARG(1).EQ.'FREC') .AND. 1271 1 IHARG(2).EQ.'PLOT')GOTO6510 1272 IF(ICOM.EQ.'SUBS' .AND. 1273 1 (IHARG(1).EQ.'WEIB' .OR. IHARG(1).EQ.'FREC') .AND. 1274 1 IHARG(2).EQ.'PLOT')GOTO6510 1275 GOTO6599 1276C 1277 6510 CONTINUE 1278 CALL DPWEIB(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1279 1 IANGLU,MAXNPP, 1280 1 IX1TSC,IX2TSC,IY1TSC,IY2TSC, 1281 1 IX1TSV,IX2TSV,IY1TSV,IY2TSV, 1282 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1283 IF(IFOUND.EQ.'YES')GOTO9000 1284C 1285 6599 CONTINUE 1286C 1287CCCCCC ADD FOLLOWING COMMAND DECEMBER 1999. 1288C **************************************************** 1289C ** TREAT THE CROSS TABULATE <STATISTIC> PLOT CASE** 1290C **************************************************** 1291C 1292 IF(NUMARG.GE.2.AND.ICOM.EQ.'CROS'.AND.IHARG(1).EQ.'TABU')THEN 1293 DO16602I=2,NUMARG 1294 IF(IHARG(I).EQ.'PLOT')GOTO16600 129516602 CONTINUE 1296 GOTO16699 1297C 129816600 CONTINUE 1299 CALL DPCRPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1300CCCCC1 TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, 1301 1 MAXNXT, 1302 1 ISEED, 1303 1 ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1304 IF(IFOUND.EQ.'YES')GOTO9000 1305 ENDIF 1306C 130716699 CONTINUE 1308C 1309C *********************************** 1310C ** TREAT THE PROFILE PLOT CASE ** 1311C *********************************** 1312C 1313 IF(ICOM.EQ.'PROF')GOTO6700 1314 GOTO6799 1315C 1316 6700 CONTINUE 1317 CALL DPPROF(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1318 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1319 IF(IFOUND.EQ.'YES')GOTO9000 1320C 1321 6799 CONTINUE 1322C 1323C *********************************** 1324C ** TREAT THE STAR PLOT CASE ** 1325C *********************************** 1326C 1327 IF(ICOM.EQ.'STAR')GOTO6800 1328 GOTO6899 1329C 1330 6800 CONTINUE 1331 CALL DPSTAR(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1332 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1333 IF(IFOUND.EQ.'YES')GOTO9000 1334C 1335 6899 CONTINUE 1336C 1337C ********************************** 1338C ** TREAT THE PARETO PLOT CASE ** 1339C ********************************** 1340C 1341 IF(ICOM.EQ.'PARE'.AND.NUMARG.GE.1.AND. 1342 1IHARG(1).EQ.'PLOT')GOTO6900 1343 GOTO6999 1344C 1345 6900 CONTINUE 1346 IDIREC='DECR' 1347CCCCC THE FOLLOWING ARGUMENT LIST WAS AUGMENTED DECEMBER 1994 1348 CALL DPPARE(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1349CCCCC1ICONT,IDIREC,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1350 1ICONT,IDIREC,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1351 IF(IFOUND.EQ.'YES')GOTO9000 1352C 1353 6999 CONTINUE 1354C 1355C ************************************* 1356C ** TREAT THE ERROR BAR PLOT CASE ** 1357C ************************************* 1358C 1359 IF(ICOM.EQ.'ERRO')GOTO7100 1360 GOTO7199 1361C 1362 7100 CONTINUE 1363 IF(IHARG(1).EQ.'PROB' .AND. IHARG(2).EQ.'PLOT')GOTO7199 1364 IF(IHARG(1).EQ.'PPCC' .AND. IHARG(2).EQ.'PLOT')GOTO7199 1365 IF(IHARG(1).EQ.'KOLM' .AND. IHARG(2).EQ.'SMIR')GOTO7199 1366 IF(IHARG(1).EQ.'CHI ' .AND. IHARG(2).EQ.'SQUA')GOTO7199 1367 IF(IHARG(1).EQ.'CHIS' .AND. IHARG(2).EQ.'GOOD')GOTO7199 1368 CALL DPERBA(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ICONT, 1369 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1370 IF(IFOUND.EQ.'YES')GOTO9000 1371C 1372 7199 CONTINUE 1373C 1374C ************************************* 1375C ** TREAT THE FRACTAL PLOT CASE ** 1376C ************************************* 1377C 1378 IF(ICOM.EQ.'FRAC' .AND. 1379 1 (IHARG(1).EQ.'ITER' .OR. IHARG(1).EQ.'TYPE'))THEN 1380 CALL DPFRAC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ICONT, 1381 1 IANGLU,ISEED, 1382CCCCC JULY 1993. ADD FOLLOWING LINE 1383 1 IFRAIT,IFRATY, 1384 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1385 IF(IFOUND.EQ.'YES')GOTO9000 1386 ENDIF 1387C 1388CCCCC THE FOLLOWING SECTION WAS CHANGED FROM POINCARE PLOT JULY 1989 1389CCCCC TO PHASE PLANE DIAGRAM JULY 1989 1390C ****************************************** 1391C ** TREAT THE PHASE PLANE DIAGRAM CASE ** 1392C ****************************************** 1393C 1394 IF(NUMARG.GE.2.AND.ICOM.EQ.'PHAS'.AND. IHARG(1).EQ.'PLAN' .AND. 1395 1 (IHARG(2).EQ.'DIAG' .OR. IHARG(2).EQ.'PLOT'))THEN 1396 CALL DPPPD(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1397 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1398 IF(IFOUND.EQ.'YES')GOTO9000 1399 ENDIF 1400C 1401C ************************************************** 1402C ** TREAT THE JACKNIFE ... STATISTIC PLOT CASE ** 1403C ** AND THE BOOTSTRAP ... STATISTIC PLOT CASE ** 1404C ************************************************** 1405C 1406CCCCC SEPTEMBER 2003: ADD BCA BOOTSTRAP/JACKNIFE 1407C 1408 IF(ICOM.EQ.'JACK')GOTO7400 1409 IF(ICOM.EQ.'BOOT')GOTO7400 1410 IF(ICOM.EQ.'BCA'.AND. 1411 1 (IHARG(1).EQ.'BOOT'.OR.IHARG(1).EQ.'JACK'))GOTO7400 1412 GOTO7499 1413C 1414 7400 CONTINUE 1415 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FIT')GOTO7499 1416C 1417 IF(ICOM.EQ.'BCA')THEN 1418 ICOM=IHARG(1) 1419 ISHIFT=1 1420 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1421 1 IBUGG2,IERROR) 1422 IBCABT='ON' 1423 ENDIF 1424C 1425 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'PLOT')GOTO7410 1426 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'PLOT')GOTO7410 1427 IF(NUMARG.GE.4.AND.IHARG(4).EQ.'PLOT')GOTO7410 1428 IF(NUMARG.GE.5.AND.IHARG(5).EQ.'PLOT')GOTO7410 1429 IF(NUMARG.GE.6.AND.IHARG(6).EQ.'PLOT')GOTO7410 1430 IF(NUMARG.GE.7.AND.IHARG(7).EQ.'PLOT')GOTO7410 1431 IF(NUMARG.GE.8.AND.IHARG(8).EQ.'PLOT')GOTO7410 1432 IF(NUMARG.GE.9.AND.IHARG(9).EQ.'PLOT')GOTO7410 1433 IF(NUMARG.GE.10.AND.IHARG(10).EQ.'PLOT')GOTO7410 1434 GOTO7499 1435 7410 CONTINUE 1436 CALL DPJBSP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1437 1IBOOSS,ISEED,IBCABT, 1438CCCCC1TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, 1439 1MAXNXT, 1440 1ICAPSW,ICAPTY,IFORSW, 1441 1CLLIMI,CLWIDT, 1442 1ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1443 IF(IFOUND.EQ.'YES')GOTO9000 1444C 1445 7499 CONTINUE 1446C 1447C **************************************** 1448C ** TREAT THE DEX CONTOUR PLOT CASE ** 1449C **************************************** 1450C 1451 IF(ICOM.EQ.'DEX'.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'CONT'.AND. 1452 1 IHARG(2).EQ.'PLOT')THEN 1453 CALL DPDCNT(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1454 1 ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1455 IF(IFOUND.EQ.'YES')GOTO9000 1456 ENDIF 1457C 1458C **************************************** 1459C ** TREAT THE YATES CUBE PLOT CASE ** 1460C **************************************** 1461C 1462 IF((ICOM.EQ.'DEX'.OR.ICOM.EQ.'YATE').AND.NUMARG.GE.2.AND. 1463 1 IHARG(1).EQ.'CUBE'.AND.IHARG(2).EQ.'PLOT')THEN 1464 CALL DPYACB(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1465 1 ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1466 IF(IFOUND.EQ.'YES')GOTO9000 1467 ENDIF 1468C 1469C **************************************** 1470C ** TREAT THE DEX/DOE ... PLOT CASE ** 1471C **************************************** 1472C 1473 IF(ICOM.EQ.'DEX ' .OR. ICOM.EQ.'DEXP' .OR. ICOM.EQ.'DOE ' .OR. 1474 1 ICOM.EQ.'DOX ' .OR. ICOM.EQ.'CLAS')THEN 1475 CALL DPDEXP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1476 1 MAXNXT,ISEED,ICONT, 1477 1 ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1478 IF(IFOUND.EQ.'YES')GOTO9000 1479 ENDIF 1480C 1481C **************************************** 1482C ** TREAT THE TAIL AREA PLOT CASE ** 1483C ** (A SYNONYM IS SURVIVAL PLOT) ** 1484C ** (MAY 1989) ** 1485C **************************************** 1486C 1487 IF(ICOM.EQ.'TAIL' .OR. ICOM.EQ.'SURV' .OR. 1488 1 IHARG(1).EQ.'TAIL' .OR. IHARG(1).EQ.'SURV')THEN 1489 CALL DPTAIL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1490 1 IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR) 1491 IF(IFOUND.EQ.'YES')GOTO9000 1492 ENDIF 1493C 1494CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2017 1495C ************************************************** 1496C ** TREAT THE NORMAL KERNEL DENSITY MIXTURE ** 1497C ** PLOT CASE ** 1498C ************************************************** 1499C 1500 IF(ICOM.EQ.'NORM' .AND. IHARG(1).EQ.'KERN' .AND. 1501 1 IHARG(2).EQ.'DENS' .AND. IHARG(3).EQ.'MIXT' .AND. 1502 1 IHARG(4).EQ.'PLOT')THEN 1503 CALL DPNMPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1504 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1505 IF(IFOUND.EQ.'YES')GOTO9000 1506 ENDIF 1507C 1508CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1998 1509C ************************************************** 1510C ** TREAT THE <NORMAL/LOGNORMAL/WEIBULL/HAZARD> ** 1511C ** PLOT CASE ** 1512C ************************************************** 1513C 1514 IF(ICOM.EQ.'NORM'.OR.ICOM.EQ.'LOGN'.OR.ICOM.EQ.'EXPO'.OR. 1515 1 ICOM.EQ.'WEIB'.OR.ICOM.EQ.'GUMB')THEN 1516 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'HAZA'.AND. 1517 1 IHARG(2).EQ.'PLOT')THEN 1518 CALL DPHAZA(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1519 1 IANGLU,MAXNPP, 1520 1 IX1TSC,IX2TSC,IY1TSC,IY2TSC, 1521 1 IX1TSV,IX2TSV,IY1TSV,IY2TSV, 1522 1 IX1ZFM,IX2ZFM,IY1ZFM,IY2ZFM, 1523 1 IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV, 1524 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1525 IF(IFOUND.EQ.'YES')GOTO9000 1526 ENDIF 1527 ENDIF 1528C 1529 IF(ICOM.EQ.'EXTR'.AND.IHARG(1).EQ.'VALU')THEN 1530 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'HAZA'.AND. 1531 1 IHARG(3).EQ.'PLOT')THEN 1532 CALL DPHAZA(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1533 1 IANGLU,MAXNPP, 1534 1 IX1TSC,IX2TSC,IY1TSC,IY2TSC, 1535 1 IX1TSV,IX2TSV,IY1TSV,IY2TSV, 1536 1 IX1ZFM,IX2ZFM,IY1ZFM,IY2ZFM, 1537 1 IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV, 1538 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1539 IF(IFOUND.EQ.'YES')GOTO9000 1540 ENDIF 1541 ENDIF 1542C 1543CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1990 1544C ************************************ 1545C ** TREAT THE NORMAL PLOT CASE ** 1546C ************************************ 1547C 1548 IF(ICOM.EQ.'NORM' .AND. IHARG(1).EQ.'PLOT')GOTO7710 1549 IF(ICOM.EQ.'HIGH' .AND. IHARG(1).EQ.'NORM' .AND. 1550 1 IHARG(2).EQ.'PLOT')GOTO7710 1551 IF(ICOM.EQ.'SUBS' .AND. IHARG(1).EQ.'NORM' .AND. 1552 1 IHARG(2).EQ.'PLOT')GOTO7710 1553 GOTO7799 1554C 1555 7710 CONTINUE 1556 CALL DPNORM(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1557 1 IANGLU,MAXNPP, 1558 1 IX1TSC,IX2TSC,IY1TSC,IY2TSC, 1559 1 IX1TSV,IX2TSV,IY1TSV,IY2TSV, 1560 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1561 IF(IFOUND.EQ.'YES')GOTO9000 1562C 1563 7799 CONTINUE 1564C 1565CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1992 (JJF) 1566C ********************************* 1567C ** TREAT THE BLOCK PLOT CASE ** 1568C ********************************* 1569C 1570CCCCC THE FOLLOWING 3 LINES WERE COMMENTED OUT JUNE 1992 JJF 1571CCCCC TO ACCOMODATE THE <STAT> BLOCK PLOTS JUNE 1992 JJF 1572CCCCC IF(NUMARG.GE.1.AND.ICOM.EQ.'BLOC'.AND. 1573CCCCC1IHARG(1).EQ.'PLOT')GOTO7800 1574CCCCC GOTO7899 1575C 1576CCCCC THE FOLLOWING 10 LINES WERE ADDED TO AVOID AUGUST 1993 1577CCCCC A CONFLICT WITH MEIDAN POLISH COMMAND AUGUST 1993 1578 IF(ICOM.EQ.'ROBU'.AND.IHARG(1).EQ.'SMOO')GOTO7899 1579 IF(NUMARG.GE.1)THEN 1580 IF((ICOM.EQ.'BLOC'.OR.ICOM.EQ.'ROBU').AND. 1581 1 IHARG(1).EQ.'PLOT')GOTO7800 1582 ENDIF 1583 IF(NUMARG.GE.2)THEN 1584 IF((IHARG(1).EQ.'BLOC'.OR.IHARG(1).EQ.'ROBU').AND. 1585 1 IHARG(2).EQ.'PLOT')GOTO7800 1586 ENDIF 1587 IF(NUMARG.GE.3)THEN 1588 IF((IHARG(2).EQ.'BLOC'.OR.IHARG(2).EQ.'ROBU').AND. 1589 1 IHARG(3).EQ.'PLOT')GOTO7800 1590 ENDIF 1591CCCCC FOLLOWING 3 LINES ADDED MARCH 1995. 1592 IF(NUMARG.GE.4)THEN 1593 IF((IHARG(3).EQ.'BLOC'.OR.IHARG(3).EQ.'ROBU').AND. 1594 1 IHARG(4).EQ.'PLOT')GOTO7800 1595 ENDIF 1596 GOTO7899 1597C 1598 7800 CONTINUE 1599CCCCC MARCH 1995. ADD MAXNXT TO ARGUMENT LIST. 1600CCCCC MARCH 2019. ADD ICHMAP TO ARGUMENT LIST. 1601 CALL DPBLOC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1602 1 BARHEF,BARWEF,MAXNXT,ISEED,ICHMAP,ICONT, 1603 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1604 IF(IFOUND.EQ.'YES')GOTO9000 1605C 1606 7899 CONTINUE 1607C 1608CCCCC THE FOLLOWING SECTION WAS ADDED OCTOBER 1991 (JJF) 1609C ********************************* 1610C ** TREAT THE PHD PLOT CASE ** 1611C ********************************* 1612C 1613 IF(NUMARG.GE.1.AND.ICOM.EQ.'PHD'.AND. 1614 1IHARG(1).EQ.'PLOT')THEN 1615CCCCC CALL DPPHDP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1616CCCCC1 TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, 1617CCCCC1 ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1618 IF(IFOUND.EQ.'YES')GOTO9000 1619 ENDIF 1620C 1621CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 1992 (ALAN) 1622C ********************************* 1623C ** TREAT THE VECTOR PLOT CASE ** 1624C ********************************* 1625C 1626 IF(NUMARG.GE.1.AND.ICOM.EQ.'VECT'.AND. 1627 1 IHARG(1).EQ.'PLOT')THEN 1628 CALL DPVECT(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1629 1 IVCFMT,IVCARR,IANGLU, 1630 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1631 IF(IFOUND.EQ.'YES')GOTO9000 1632 ENDIF 1633C 1634CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 1992 (ALAN) 1635C ********************************* 1636C ** TREAT THE SYMBOL PLOT CASE ** 1637C ********************************* 1638C 1639 IF(NUMARG.GE.1.AND.ICOM.EQ.'SYMB'.AND. 1640 1 IHARG(1).EQ.'PLOT')THEN 1641 CALL DPPLSY(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1642 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1643 IF(IFOUND.EQ.'YES')GOTO9000 1644 ENDIF 1645C 1646CCCCC THE FOLLOWING SECTION WAS ADDED NOVEMBER 1992 (ALAN) 1647C ********************************** 1648C ** TREAT THE ANDREWS PLOT CASE ** 1649C ********************************** 1650C 1651 IF(NUMARG.GE.1.AND.ICOM.EQ.'ANDR'.AND. 1652 1 IHARG(1).EQ.'PLOT')THEN 1653CCCCC PANINC=0.1 1654 CALL DPANDR(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ANDINC, 1655 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1656 IF(IFOUND.EQ.'YES')GOTO9000 1657 ENDIF 1658C 1659CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2003 (ALAN) 1660C *********************************************** 1661C ** TREAT THE PARALLEL COORDINATES PLOT CASE ** 1662C *********************************************** 1663C 1664 IF(NUMARG.GE.2.AND.ICOM.EQ.'PARA'.AND. 1665 1IHARG(1).EQ.'COOR'.AND.IHARG(2).EQ.'PLOT')THEN 1666 CALL DPPCPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1667 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1668 IF(IFOUND.EQ.'YES')GOTO9000 1669 ELSEIF(NUMARG.GE.3.AND.ICOM.EQ.'GROU'.AND. 1670 1 IHARG(1).EQ.'PARA'.AND. IHARG(2).EQ.'COOR'.AND. 1671 1 IHARG(3).EQ.'PLOT')THEN 1672 CALL DPPCPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1673 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1674 IF(IFOUND.EQ.'YES')GOTO9000 1675 ENDIF 1676C 1677CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 1993 1678C ****************************************** 1679C ** TREAT THE Q ... CONTROL CHART CASE ** 1680C ****************************************** 1681C 1682 IF(ICOM.EQ.'Q' .AND. IHARG(1).NE.'QUAN')THEN 1683 CALL DPQCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1684 1 ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1685 IF(IFOUND.EQ.'YES')GOTO9000 1686 ENDIF 1687C 1688CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 1993 1689C ************************************************ 1690C ** TREAT THE CME PLOT CASE ** 1691C ** TREAT THE COND. ... EXCEEDANCE PLOT CASE ** 1692C ************************************************ 1693C 1694C MAY 1998. CHECK FOR CONFLICT WITH "CME ESTIMATE" OR 1695C "CME GENERALIZED PARETO". 1696 IF(ICOM.EQ.'CME')GOTO8500 1697 IF(ICOM.EQ.'COND')GOTO8500 1698 IF(ICOM.EQ.'YANG')GOTO8500 1699 IF(ICOM.EQ.'LIFE')GOTO8500 1700 IF(ICOM.EQ.'MEAN')GOTO8500 1701 GOTO8599 1702C 1703 8500 CONTINUE 1704 IF(NUMARG.GE.1.AND.(IHARG(1).EQ.'ESTI'.OR.IHARG(1).EQ.'GENE')) 1705 1GOTO8599 1706 CALL DPCME(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1707 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1708 IF(IFOUND.EQ.'YES')GOTO9000 1709C 1710 8599 CONTINUE 1711C 1712C ******************************************* 1713C ** TREAT THE ... COMOVEMENT PLOT CASE ** 1714C ******************************************* 1715C 1716C NOTE: FOLD COMOVEMENT PLOT IN WITH CORRELATION PLOT. 1717C 1718CCCCC IF(ICOM.EQ.'AUTO' .OR. ICOM.EQ.'CROS' .OR. ICOM.EQ.'COMO' .OR. 1719CCCCC1 IHARG(1).EQ.'AUTO' .OR. IHARG(1).EQ.'CROS' .OR. 1720CCCCC1 IHARG(1).EQ.'COMO')THEN 1721CCCCC CALL DPCOMV(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1722CCCCC1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1723CCCCC IF(IFOUND.EQ.'YES')GOTO9000 1724CCCCC ENDIF 1725C 1726C **************************************** 1727C ** TREAT THE KAPLAN MEIER PLOT CASE ** 1728C ** (MAY 1998) ** 1729C **************************************** 1730C 1731 IF(ICOM.EQ.'KAPL' .OR. ICOM.EQ.'MODI')THEN 1732 CALL DPKAPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1733 1 IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR) 1734 IF(IFOUND.EQ.'YES')GOTO9000 1735 ENDIF 1736C 1737C **************************************** 1738C ** TREAT THE DUANE PLOT CASE ** 1739C ** (MAY 1998) ** 1740C **************************************** 1741C 1742 IF(ICOM.EQ.'DUAN')THEN 1743 CALL DPDUAN(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1744 1 IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR) 1745 IF(IFOUND.EQ.'YES')GOTO9000 1746 ENDIF 1747C 1748C **************************************** 1749C ** TREAT THE EMPIRICAL CDF PLOT CASE ** 1750C ** (MAY 1998) ** 1751C **************************************** 1752C 1753 IF(ICOM.EQ.'EMPI' .OR. ICOM.EQ.'ECDF')THEN 1754 CALL DPECDF(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1755 1 IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR) 1756 IF(IFOUND.EQ.'YES')GOTO9000 1757 ENDIF 1758C 1759C ********************************************* 1760C ** TREAT THE SEASONAL SUBSERIES PLOT CASE ** 1761C ** (FEBRUARY 1999) ** 1762C ********************************************* 1763C 1764 IF(ICOM.EQ.'SEAS' .OR. IHARG(1).EQ.'SEAS')THEN 1765 CALL DPSESB(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1766 1 IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR) 1767 IF(IFOUND.EQ.'YES')GOTO9000 1768 ENDIF 1769C 1770C ********************************************* 1771C ** TREAT THE SPREAD-LOCATION PLOT CASE ** 1772C ** (AUGUST 1999) ** 1773C ********************************************* 1774C 1775 IF(ICOM.EQ.'SPRE' .OR. IHARG(1).EQ.'SPRE')THEN 1776 CALL DPSLOC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1777 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1778 IF(IFOUND.EQ.'YES')GOTO9000 1779 ENDIF 1780C 1781C ************************************************ 1782C ** TREAT THE TUKEY MEAN-DIFFERENCE PLOT CASE ** 1783C ************************************************ 1784C 1785 IF((ICOM.EQ.'TUKE'.AND.IHARG(1).NE.'LAMB') .OR. 1786 1 (ICOM.EQ.'HIGH'.AND.IHARG(1).EQ.'TUKE') .OR. 1787 1 (ICOM.EQ.'SUBS'.AND.IHARG(1).EQ.'TUKE'))THEN 1788 CALL DPTUMD(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1789 1 IANGLU,MAXNPP, 1790 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1791 IF(IFOUND.EQ.'YES')GOTO9000 1792 ENDIF 1793C 1794C ************************************************ 1795C ** TREAT THE SHIFT PLOT CASE ** 1796C ************************************************ 1797C 1798 IF(ICOM.EQ.'SHIF' .OR. 1799 1 (ICOM.EQ.'HIGH' .AND. IHARG(1).EQ.'SHIF') .OR. 1800 1 (ICOM.EQ.'SUBS' .AND. IHARG(1).EQ.'SHIF'))THEN 1801 CALL DPSHPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1802 1 IANGLU,MAXNPP, 1803 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1804 IF(IFOUND.EQ.'YES' .OR. IERROR.EQ.'YES')GOTO9000 1805 ENDIF 1806C 1807C ************************************************ 1808C ** TREAT THE BLAND ALTMAN PLOT CASE ** 1809C ************************************************ 1810C 1811 IF((ICOM.EQ.'BLAN'.AND.IHARG(1).EQ.'ALTM') .OR. 1812 1 (ICOM.EQ.'HIGH'.AND.IHARG(1).EQ.'BLAN') .OR. 1813 1 (ICOM.EQ.'SUBS'.AND.IHARG(1).EQ.'BLAN'))THEN 1814 CALL DPBAPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1815 1 IANGLU,ISEED,IBOOSS,MAXNPP, 1816 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1817 IF(IFOUND.EQ.'YES')GOTO9000 1818 ENDIF 1819C 1820C ************************************************ 1821C ** TREAT THE INTERACTION PLOT CASE ** 1822C ************************************************ 1823C 1824 IF(ICOM.EQ.'INTE'.AND.NUMARG.GE.1.AND. 1825 1IHARG(1).EQ.'PLOT')GOTO9500 1826 GOTO9599 1827C 1828 9500 CONTINUE 1829 ISHIFT=1 1830 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1831 1IBUGG2,IERROR) 1832 CALL DPINPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1833 1MAXNPP, 1834 1ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1835 IF(IFOUND.EQ.'YES')GOTO9000 1836C 1837 9599 CONTINUE 1838C 1839C **************************************************** 1840C ** TREAT THE ... STATISTIC INTERACTION PLOT CASE ** 1841C **************************************************** 1842C 1843 IF(NUMARG.LT.2)GOTO9699 1844 DO9602I=1,NUMARG-1 1845 IF(IHARG(I).EQ.'INTE'.AND.IHARG(I+1).EQ.'PLOT')GOTO9600 1846 9602 CONTINUE 1847 IF(NUMARG.LT.3)GOTO9699 1848 DO9604I=1,NUMARG-2 1849 IF(IHARG(I).EQ.'INTE'.AND.IHARG(I+1).EQ.'STAT'.AND. 1850 1 IHARG(I+2).EQ.'PLOT')GOTO9600 1851 9604 CONTINUE 1852 GOTO9699 1853C 1854 9600 CONTINUE 1855 CALL DPISP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1856CCCCC1TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, 1857 1MAXNXT, 1858 1ISEED, 1859 1ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1860 IF(IFOUND.EQ.'YES')GOTO9000 1861C 1862 9699 CONTINUE 1863C 1864C ******************************************* 1865C ** TREAT THE KERNEL DENSITY PLOT CASE ** 1866C ******************************************* 1867C 1868 IF((ICOM.EQ.'KERN' .OR. ICOM.EQ.'DENS') .OR. 1869 1 IHARG(1).EQ.'KERN' .OR. IHARG(2).EQ.'KERN' .OR. 1870 1 IHARG(3).EQ.'KERN')THEN 1871 CALL DPKDEN(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1872 1 IKDENP,PKDEWI,ISEED, 1873 1 ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1874 IF(IFOUND.EQ.'YES')GOTO9000 1875 ENDIF 1876C 1877C ******************************************* 1878C ** TREAT THE LORENZ CURVE CASE ** 1879C ******************************************* 1880C 1881 IF(ICOM.EQ.'LORE' .OR. 1882 1 IHARG(1).EQ.'LORE' .OR. IHARG(2).EQ.'LORE' .OR. 1883 1 IHARG(3).EQ.'LORE')THEN 1884 CALL DPLORE(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1885 1 ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1886 IF(IFOUND.EQ.'YES')GOTO9000 1887 ENDIF 1888C 1889C ******************************************* 1890C ** TREAT THE H CONSISTENCY PLOT CASE ** 1891C ******************************************* 1892C 1893 IF( 1894 1 (ICOM.EQ.'H ' .AND. IHARG(1).EQ.'CONS' .AND. 1895 1 IHARG(2).EQ.'PLOT') .OR. 1896 1 (ICOM.EQ.'K ' .AND. IHARG(1).EQ.'CONS' .AND. 1897 1 IHARG(2).EQ.'PLOT') .OR. 1898 1 (ICOM.EQ.'COCH' .AND. IHARG(1).EQ.'VARI' .AND. 1899 1 IHARG(2).EQ.'PLOT') 1900 1 )THEN 1901 CALL DPHKCP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1902 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1903 IF(IFOUND.EQ.'YES')GOTO9000 1904 ENDIF 1905C 1906C ******************************************* 1907C ** TREAT THE TWO FACTOR PLOT CASE ** 1908C ******************************************* 1909C 1910 IF(ICOM.EQ.'TWO ' .AND. IHARG(1).EQ.'FACT' .AND. 1911 1 IHARG(2).EQ.'PLOT')THEN 1912 CALL DPTWFP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1913 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1914 IF(IFOUND.EQ.'YES')GOTO9000 1915 ENDIF 1916C 1917C ******************************************* 1918C ** TREAT THE CONSENSUS MEAN PLOT CASE ** 1919C ******************************************* 1920C 1921 IF(ICOM.EQ.'CONS')THEN 1922 IF(NUMARG.GE.2.AND. 1923 1 IHARG(1).EQ.'MEAN'.AND.IHARG(2).EQ.'PLOT')THEN 1924 CALL DPCMPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1925 1 ICAPSW,ICAPTY, 1926 1 IFORSW,ISEED,IBOOSS, 1927 1 ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1928 IF(IFOUND.EQ.'YES')GOTO9000 1929 ENDIF 1930 ENDIF 1931C 1932C ********************************************* 1933C ** TREAT THE PARTIAL REGRESSION PLOT CASE ** 1934C ** TREAT THE PARTIAL RESIDUAL PLOT CASE ** 1935C ** TREAT THE PARTIAL LEVERAGE PLOT CASE ** 1936C ********************************************* 1937C 1938 IF(ICOM.EQ.'PART')THEN 1939 IF(NUMARG.GE.2.AND. 1940 1 (IHARG(1).EQ.'REGR'.AND.IHARG(2).EQ.'PLOT') .OR. 1941 1 (IHARG(1).EQ.'RESI'.AND.IHARG(2).EQ.'PLOT') .OR. 1942 1 (IHARG(1).EQ.'LEVE'.AND.IHARG(2).EQ.'PLOT'))THEN 1943 ICASPL='PREG' 1944 CALL DPPREG(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1945 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1946 IF(IFOUND.EQ.'YES')GOTO9000 1947 ENDIF 1948 ELSEIF(ICOM.EQ.'ADDE')THEN 1949 ICASPL='PREG' 1950 IF(NUMARG.GE.2.AND. 1951 1 IHARG(1).EQ.'VARI'.AND.IHARG(2).EQ.'PLOT')THEN 1952 CALL DPPREG(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1953 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1954 IF(IFOUND.EQ.'YES')GOTO9000 1955 ENDIF 1956 ELSEIF(ICOM.EQ.'COMP')THEN 1957 ICASPL='PREG' 1958 IF(NUMARG.GE.3.AND. 1959 1 IHARG(1).EQ.'PLUS'.AND.IHARG(2).EQ.'RESI'.AND. 1960 1 IHARG(3).EQ.'PLOT')THEN 1961 CALL DPPREG(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1962 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1963 IF(IFOUND.EQ.'YES')GOTO9000 1964 ENDIF 1965 ELSEIF(ICOM.EQ.'CCPR')THEN 1966 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')THEN 1967 ICASPL='CCPR' 1968 CALL DPPREG(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1969 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 1970 IF(IFOUND.EQ.'YES')GOTO9000 1971 ENDIF 1972 ENDIF 1973C 1974C ***************************************** 1975C ** TREAT THE ... INFLUENCE CURVE CASE ** 1976C ***************************************** 1977C 1978 IF(NUMARG.GE.2)THEN 1979 DO9710I=1,NUMARG-1 1980 IF(IHARG(I).EQ.'INFL' .AND. IHARG(I+1).EQ.'CURV')THEN 1981 CALL DPINCU(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1982CCCCC1 TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, 1983 1 MAXNXT, 1984 1 ISEED, 1985 1 ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1986 IF(IFOUND.EQ.'YES')GOTO9000 1987 GOTO9719 1988 ENDIF 1989 9710 CONTINUE 1990 ENDIF 1991 9719 CONTINUE 1992C 1993CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 2005 1994C ************************************************ 1995C ** TREAT THE PEAKS OVER THRESHOLD PLOT CASE ** 1996C ** POT PLOT ** 1997C ************************************************ 1998C 1999 IF(ICOM.EQ.'PEAK')THEN 2000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'OVER'.AND. 2001 1 IHARG(2).EQ.'THRE'.AND.IHARG(3).EQ.'PLOT')THEN 2002 CALL DPPOTP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2003 1 IBOOSS,ISEED, 2004 1 ICAPSW,ICAPTY,IFORSW, 2005 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2006 IF(IFOUND.EQ.'YES')GOTO9000 2007 ENDIF 2008 ELSEIF(ICOM.EQ.'POT ')THEN 2009 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')THEN 2010 CALL DPPOTP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2011 1 IBOOSS,ISEED, 2012 1 ICAPSW,ICAPTY,IFORSW, 2013 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2014 IF(IFOUND.EQ.'YES')GOTO9000 2015 ENDIF 2016 ENDIF 2017C 2018C ************************************************* 2019C ** TREAT THE REPAIR PLOT CASE ** 2020C ** (OCTOBER 2006) ** 2021C ************************************************* 2022C 2023 IF(ICOM.EQ.'REPA')THEN 2024 CALL DPRPLO(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2025 1 IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR) 2026 IF(IFOUND.EQ.'YES')GOTO9000 2027 ENDIF 2028C 2029C ************************************************* 2030C ** TREAT THE MEAN REPAIR FUNCTION PLOT CASE ** 2031C ** (OCTOBER 2006) ** 2032C ************************************************* 2033C 2034 IF(ICOM.EQ.'MEAN' .OR. ICOM.EQ.'AVER')THEN 2035 CALL DPMRFP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2036 1 IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR) 2037 IF(IFOUND.EQ.'YES')GOTO9000 2038 ENDIF 2039C 2040C ************************************** 2041C ** TREAT THE TRILINEAR PLOT CASE. ** 2042C ************************************** 2043C 2044 IF(ICOM.EQ.'TRIL' .AND. IHARG(1).EQ.'PLOT')THEN 2045 CALL DPTRPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2046 1 IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR) 2047 IF(IFOUND.EQ.'YES')GOTO9000 2048 ENDIF 2049C 2050C **************************************** 2051C ** TREAT THE ROC PLOT CASE. ** 2052C ** TREAT THE PSUEDO ROC PLOT CASE. ** 2053C **************************************** 2054C 2055 IF(ICOM.EQ.'ROC ')THEN 2056 CALL DPROC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2057 1 IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR) 2058 IF(IFOUND.EQ.'YES')GOTO9000 2059 ELSEIF(ICOM.EQ.'PSUE' .AND. IHARG(1).EQ.'ROC ')THEN 2060 CALL DPROC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2061 1 IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR) 2062 IF(IFOUND.EQ.'YES')GOTO9000 2063 ENDIF 2064C 2065C ************************************** 2066C ** TREAT THE ROSE PLOT CASE. ** 2067C ************************************** 2068C 2069 IF(ICOM.EQ.'ROSE')THEN 2070 CALL DPROSE(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2071 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2072 IF(IFOUND.EQ.'YES')GOTO9000 2073 ENDIF 2074C 2075C ******************************************* 2076C ** TREAT THE BIVARIATE NORMAL TOLERANCE ** 2077C ** REGION PLOT CASE. ** 2078C ******************************************* 2079C 2080 IF(ICOM.EQ.'BIVA' .OR. ICOM.EQ.'POIN')THEN 2081 CALL DPBNTR(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2082 1 IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR) 2083 IF(IFOUND.EQ.'YES')GOTO9000 2084 ENDIF 2085C 2086C ************************************** 2087C ** TREAT THE BINARY PLOT CASE. ** 2088C ************************************** 2089C 2090 IF(ICOM.EQ.'BINA' .AND. IHARG(1).NE.'TABU')THEN 2091 CALL DPBIPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2092 1 IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR) 2093 IF(IFOUND.EQ.'YES')GOTO9000 2094 ENDIF 2095C 2096C ***************************************** 2097C ** TREAT THE ORD PLOT CASE ** 2098C ***************************************** 2099C 2100 IF(ICOM.EQ.'ORD ')THEN 2101 CALL DPORD(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2102 1 CLLIMI,CLWIDT, 2103 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2104 IF(IFOUND.EQ.'YES')GOTO9000 2105 ENDIF 2106C 2107C ***************************************** 2108C ** TREAT THE POISSON PLOT CASE ** 2109C ***************************************** 2110C 2111 IF(ICOM.EQ.'POIS' .AND. IHARG(1).EQ.'PLOT')THEN 2112 CALL DPPOIS(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2113 1 CLLIMI,CLWIDT, 2114 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2115 IF(IFOUND.EQ.'YES')GOTO9000 2116 ELSEIF(ICOM.EQ.'GEOM' .AND. IHARG(1).EQ.'PLOT')THEN 2117 CALL DPPOIS(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2118 1 CLLIMI,CLWIDT, 2119 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2120 IF(IFOUND.EQ.'YES')GOTO9000 2121 ELSEIF(ICOM.EQ.'BINO' .AND. IHARG(1).EQ.'PLOT')THEN 2122 CALL DPPOIS(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2123 1 CLLIMI,CLWIDT, 2124 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2125 IF(IFOUND.EQ.'YES')GOTO9000 2126 ELSEIF(ICOM.EQ.'LOGA' .AND. IHARG(1).EQ.'SERI' .AND. 2127 1 IHARG(2).EQ.'PLOT')THEN 2128 CALL DPPOIS(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2129 1 CLLIMI,CLWIDT, 2130 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2131 IF(IFOUND.EQ.'YES')GOTO9000 2132 ELSEIF(ICOM.EQ.'NEGA' .AND. IHARG(1).EQ.'BINO' .AND. 2133 1 IHARG(2).EQ.'PLOT')THEN 2134 CALL DPPOIS(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2135 1 CLLIMI,CLWIDT, 2136 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2137 IF(IFOUND.EQ.'YES')GOTO9000 2138 ENDIF 2139C 2140C ***************************************** 2141C ** TREAT THE ASSOCIATION PLOT CASE ** 2142C ***************************************** 2143C 2144 IF(ICOM.EQ.'ASSO' .AND. IHARG(1).EQ.'PLOT')THEN 2145 CALL DPASSO(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2146 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2147 IF(IFOUND.EQ.'YES')GOTO9000 2148 ENDIF 2149C 2150C ***************************************** 2151C ** TREAT THE SIEVE PLOT CASE ** 2152C ***************************************** 2153C 2154 IF(ICOM.EQ.'SIEV' .AND. IHARG(1).EQ.'PLOT')THEN 2155 CALL DPSIEV(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2156 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2157 IF(IFOUND.EQ.'YES')GOTO9000 2158 ENDIF 2159C 2160C ***************************************** 2161C ** TREAT THE LEVEL PLOT CASE ** 2162C ***************************************** 2163C 2164 IF(ICOM.EQ.'LEVE' .AND. IHARG(1).EQ.'PLOT')THEN 2165 ISHIFT=1 2166 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 2167 1 IBUGG2,IERROR) 2168 CALL DPLEPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2169 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2170 IF(IFOUND.EQ.'YES')GOTO9000 2171 ELSEIF(ICOM.EQ.'DISC' .AND. IHARG(1).EQ.'CONT' .AND. 2172 1 IHARG(2).EQ.'PLOT')THEN 2173 ISHIFT=2 2174 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 2175 1 IBUGG2,IERROR) 2176 CALL DPLEPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2177 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2178 IF(IFOUND.EQ.'YES')GOTO9000 2179 ENDIF 2180C 2181C ***************************************** 2182C ** TREAT THE IMAGE PLOT CASE ** 2183C ***************************************** 2184C 2185 IF(ICOM.EQ.'IMAG' .AND. IHARG(1).EQ.'PLOT')THEN 2186 ISHIFT=1 2187 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 2188 1 IBUGG2,IERROR) 2189 CALL DPIMAG(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2190 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2191 IF(IFOUND.EQ.'YES')GOTO9000 2192 ENDIF 2193C 2194C ************************************************* 2195C ** TREAT THE SPATIAL DISTRIBUTION PLOT CASE ** 2196C ************************************************* 2197C 2198 IF(ICOM.EQ.'SPAT' .AND. IHARG(1).EQ.'DIST' .AND. 2199 1 IHARG(2).EQ.'PLOT')THEN 2200 ISHIFT=2 2201 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 2202 1 IBUGG2,IERROR) 2203 CALL DPSDPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2204 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2205 IF(IFOUND.EQ.'YES')GOTO9000 2206 ENDIF 2207C 2208C ***************************************** 2209C ** TREAT THE FLUCUATION PLOT CASE ** 2210C ***************************************** 2211C 2212 IF(ICOM.EQ.'FLUC')THEN 2213 CALL DPFLUC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2214 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2215 IF(IFOUND.EQ.'YES')GOTO9000 2216 ENDIF 2217C 2218C ***************************************** 2219C ** TREAT THE STRIP PLOT CASE ** 2220C ***************************************** 2221C 2222 IF(ICOM.EQ.'STRI'.AND.IHARG(1).EQ.'PLOT')THEN 2223 CALL DPSTRI(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ISEED, 2224 1 ISUBRO,IBUGG2,IBUGG3,IBUGQ, 2225 1 IFOUND,IERROR) 2226 IF(IFOUND.EQ.'YES')GOTO9000 2227 ELSEIF(ICOM.EQ.'BATC'.AND.IHARG(1).EQ.'STRI'.AND. 2228 1 IHARG(2).EQ.'PLOT')THEN 2229 CALL DPSTRI(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ISEED, 2230 1 ISUBRO,IBUGG2,IBUGG3,IBUGQ, 2231 1 IFOUND,IERROR) 2232 IF(IFOUND.EQ.'YES')GOTO9000 2233C 2234C FOLLOWING SECTION ADDED TO SUPPORT "BATCH MULTIPLE" 2235C OPTION FOR STRIP PLOT--10/2009 2236C 2237 ELSEIF(ICOM.EQ.'BATC'.AND.IHARG(1).EQ.'MULT'.AND. 2238 1 IHARG(2).EQ.'STRI'.AND.IHARG(3).EQ.'PLOT')THEN 2239 CALL DPSTRI(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ISEED, 2240 1 ISUBRO,IBUGG2,IBUGG3,IBUGQ, 2241 1 IFOUND,IERROR) 2242 IF(IFOUND.EQ.'YES')GOTO9000 2243 ELSEIF(ICOM.EQ.'MULT'.AND.IHARG(1).EQ.'BATC'.AND. 2244 1 IHARG(2).EQ.'STRI'.AND.IHARG(3).EQ.'PLOT')THEN 2245 CALL DPSTRI(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ISEED, 2246 1 ISUBRO,IBUGG2,IBUGG3,IBUGQ, 2247 1 IFOUND,IERROR) 2248 IF(IFOUND.EQ.'YES')GOTO9000 2249 ENDIF 2250C 2251C ******************************************* 2252C ** TREAT THE DETECTION LIMIT PLOT CASE ** 2253C ******************************************* 2254C 2255 IF(ICOM.EQ.'DETE'.AND.IHARG(1).EQ.'LIMI'.AND. 2256 1 IHARG(2).EQ.'PLOT')THEN 2257 CALL DPDLPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ISEED, 2258 1 ISUBRO,IBUGG2,IBUGG3,IBUGQ, 2259 1 IFOUND,IERROR) 2260 IF(IFOUND.EQ.'YES')GOTO9000 2261 ELSEIF(ICOM.EQ.'NORM'.AND.IHARG(1).EQ.'DETE'.AND. 2262 1 IHARG(2).EQ.'LIMI'.AND.IHARG(3).EQ.'PLOT')THEN 2263 CALL DPDLPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ISEED, 2264 1 ISUBRO,IBUGG2,IBUGG3,IBUGQ, 2265 1 IFOUND,IERROR) 2266 IF(IFOUND.EQ.'YES')GOTO9000 2267 ENDIF 2268C 2269C ***************************************** 2270C ** TREAT THE TABULATION PLOT CASE ** 2271C ***************************************** 2272C 2273 IF(ICOM.EQ.'TABU' .OR. 2274 1 (ICOM.EQ.'CHAR' .AND. IHARG(1).EQ.'TABU'))THEN 2275 CALL DPTAPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2276 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2277 IF(IFOUND.EQ.'YES')GOTO9000 2278 ENDIF 2279C 2280C ******************************************** 2281C ** TREAT THE ISO 13528 ZSCORE PLOT CASE ** 2282C ** ISO 13528 JSCORE PLOT CASE ** 2283C ******************************************** 2284C 2285 IF(ICOM.EQ.'ISO ' .AND. IHARG(1).EQ.'1352' .AND. 2286 1 (IHARG(2).EQ.'ZSCO' .OR. IHARG(2).EQ.'JSCO').AND. 2287 1 IHARG(3).EQ.'PLOT')THEN 2288 CALL DPZSCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2289 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2290 IF(IFOUND.EQ.'YES')GOTO9000 2291 ENDIF 2292C 2293C ***************************************** 2294C ** TREAT THE ISO 13528 PLOT CASE ** 2295C ***************************************** 2296C 2297 IF(ICOM.EQ.'ISO ' .AND. IHARG(1).EQ.'1352' .AND. 2298 1 IHARG(2).EQ.'PLOT')THEN 2299 CALL DPISOP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2300 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2301 IF(IFOUND.EQ.'YES')GOTO9000 2302 ENDIF 2303C 2304C ****************************************** 2305C ** TREAT THE ISO 13528 RLP PLOT CASE ** 2306C ****************************************** 2307C 2308 IF(ICOM.EQ.'ISO ' .AND. IHARG(1).EQ.'1352' .AND. 2309 1 IHARG(2).EQ.'RLP' .AND. IHARG(3).EQ.'PLOT')THEN 2310 CALL DPRLPP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2311 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2312 IF(IFOUND.EQ.'YES')GOTO9000 2313 ENDIF 2314C 2315C ************************************************* 2316C ** TREAT THE TWO-WAY <ROW/COLUMN> PLOT CASE ** 2317C ************************************************* 2318C 2319 IF(ICOM.EQ.'TWO ' .AND. IHARG(1).EQ.'WAY ')THEN 2320 CALL DPTWPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 2321 1 ICAPSW,ICAPTY,IFORSW, 2322 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) 2323 IF(IFOUND.EQ.'YES')GOTO9000 2324 ENDIF 2325C 2326C ******************************************* 2327C ** END OF SEARCH FOR GRAPHICS COMMANDS ** 2328C ******************************************* 2329 IFOUND='NO' 2330 IERROR='NO' 2331 GOTO9001 2332C 2333C ******************************************* 2334C ** STEP 90A-- ** 2335C ** DO THE FOLLOWING FOR ALL PLOTS: ** 2336C ** 1) SAVE SOME INTERNAL PARAMETERS ** 2337C ** 2) IMPLEMENT SUB-REGIONS ** 2338C ******************************************* 2339C 2340 9000 CONTINUE 2341 IF(IFOUND.EQ.'NO')GOTO9001 2342 IF(IERROR.EQ.'YES')GOTO9001 2343 IF(NPLOTP.LT.1)GOTO9001 2344 IF(ICASPL(1:2).EQ.'3D')GOTO9001 2345C 2346C FIND PLOT MIN AND MAX AND CORRESPONDING INDEX AND SAVE AS 2347C INTERNAL PARAMETERS. 2348C 2349 AYMIN=CPUMAX 2350 AYMAX=CPUMIN 2351 AXMIN=CPUMAX 2352 AXMAX=CPUMIN 2353 IYMIN=0 2354 IYMAX=0 2355 IXMIN=0 2356 IXMAX=0 2357 DO10001I=1,NPLOTP 2358 IF(Y(I).LT.AYMIN)THEN 2359 AYMIN=Y(I) 2360 IYMIN=I 2361 ENDIF 2362 IF(Y(I).GT.AYMAX)THEN 2363 AYMAX=Y(I) 2364 IYMAX=I 2365 ENDIF 2366 IF(X(I).LT.AXMIN)THEN 2367 AXMIN=X(I) 2368 IXMIN=I 2369 ENDIF 2370 IF(X(I).GT.AXMAX)THEN 2371 AXMAX=X(I) 2372 IXMAX=I 2373 ENDIF 237410001 CONTINUE 2375 ISUBN0='INGR' 2376 IH='PLOT' 2377 IH2='YMAX' 2378 VALUE0=AYMAX 2379 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2380 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2381 1IANS,IWIDTH,IBUGG3,IERROR) 2382 IH='YMAX' 2383 IH2='INDE' 2384 VALUE0=REAL(IYMAX) 2385 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2386 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2387 1IANS,IWIDTH,IBUGG3,IERROR) 2388 IH='PLOT' 2389 IH2='YMIN' 2390 VALUE0=AYMIN 2391 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2392 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2393 1IANS,IWIDTH,IBUGG3,IERROR) 2394 IH='YMIN' 2395 IH2='INDE' 2396 VALUE0=REAL(IYMIN) 2397 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2398 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2399 1IANS,IWIDTH,IBUGG3,IERROR) 2400 IH='PLOT' 2401 IH2='XMAX' 2402 VALUE0=AXMAX 2403 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2404 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2405 1IANS,IWIDTH,IBUGG3,IERROR) 2406 IH='XMAX' 2407 IH2='INDE' 2408 VALUE0=REAL(IXMAX) 2409 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2410 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2411 1IANS,IWIDTH,IBUGG3,IERROR) 2412 IH='PLOT' 2413 IH2='XMIN' 2414 VALUE0=AXMIN 2415 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2416 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2417 1IANS,IWIDTH,IBUGG3,IERROR) 2418 IH='XMIN' 2419 IH2='INDE' 2420 VALUE0=REAL(IXMIN) 2421 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2422 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2423 1IANS,IWIDTH,IBUGG3,IERROR) 2424C 2425C FIND CORRELATION OF PLOT POINTS. FIND 2 CORRELATIIONS: 2426C ONE WITH ALL POINTS, ONE WITH TAGPLO=1. 2427C 2428 IWRITE='OFF' 2429 CALL CORR(Y,X,NPLOTP,IWRITE,ACORR,IBUGG3,IERROR) 2430 IH='PLOT' 2431 IH2='CORR' 2432 VALUE0=ACORR 2433 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2434 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2435 1IANS,IWIDTH,IBUGG3,IERROR) 2436 J=0 2437 DO10101I=1,NPLOTP 2438 IF(D(I).EQ.1.0)THEN 2439 J=J+1 2440 TEMP(J)=Y(I) 2441 TEMP2(J)=X(I) 2442 ENDIF 244310101 CONTINUE 2444 ACORR=0.0 2445 IF(J.GE.1)CALL CORR(TEMP,TEMP2,J,IWRITE,ACORR,IBUGG3,IERROR) 2446 IH='PLOT' 2447 IH2='COR1' 2448 VALUE0=ACORR 2449 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2450 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2451 1IANS,IWIDTH,IBUGG3,IERROR) 2452C 2453C IMPLEMENT SUB-REGIONS 2454C 2455 NUMSBR=0 2456 DO10200I=MAXSUB,1,-1 2457 IF(ISUBSW(I).EQ.'ON')THEN 2458 NUMSBR=NUMSBR+1 2459 IF(NPLOTP+5.GT.MAXPOP)THEN 2460 WRITE(ICOUT,999) 2461 CALL DPWRST('XXX','BUG ') 2462 WRITE(ICOUT,10205) 246310205 FORMAT('***** FROM MAINGR--') 2464 CALL DPWRST('XXX','BUG ') 2465 WRITE(ICOUT,10208)I 246610208 FORMAT(' UNABLE TO IMPLEMENT SUB-REGION ',I5) 2467 CALL DPWRST('XXX','BUG ') 2468 WRITE(ICOUT,10212)MAXPOP 246910212 FORMAT(' THE NUMBER OF PLOT POINTS WOULD EXCEED ', 2470 1 'MAXIMUM OF ',I8,'.') 2471 CALL DPWRST('XXX','BUG ') 2472 WRITE(ICOUT,10214)NPLOTP 247310214 FORMAT(' THE CURRENT NUMBER OF PLOT POINTS = ',I8) 2474 CALL DPWRST('XXX','BUG ') 2475 GOTO10299 2476 ELSE 2477 DO10220II=NPLOTP,1,-1 2478 X(II+5)=X(II) 2479 Y(II+5)=Y(II) 2480 X3D(II+5)=X3D(II) 2481 DSIZE(II+5)=DSIZE(II) 2482 DSYMB(II+5)=DSYMB(II) 2483 DCOLOR(II+5)=DCOLOR(II) 2484 DFILL(II+5)=DFILL(II) 2485 D(II+5)=D(II)+1.0 248610220 CONTINUE 2487 NPLOTP=NPLOTP+5 2488 X(1)=ASUBXL(I) 2489 IF(X(1).EQ.CPUMIN)X(1)=AXMIN 2490 X(2)=ASUBXU(I) 2491 IF(X(2).EQ.CPUMAX)X(2)=AXMAX 2492 X(3)=ASUBXU(I) 2493 IF(X(3).EQ.CPUMAX)X(3)=AXMAX 2494 X(4)=ASUBXL(I) 2495 IF(X(4).EQ.CPUMIN)X(4)=AXMIN 2496 Y(1)=ASUBYL(I) 2497 IF(Y(1).EQ.CPUMIN)Y(1)=AYMIN 2498 Y(2)=ASUBYL(I) 2499 IF(Y(2).EQ.CPUMIN)Y(2)=AYMIN 2500 Y(3)=ASUBYU(I) 2501 IF(Y(3).EQ.CPUMAX)Y(3)=AYMAX 2502 Y(4)=ASUBYU(I) 2503 IF(Y(4).EQ.CPUMAX)Y(4)=AYMAX 2504 X(5)=X(1) 2505 Y(5)=Y(1) 2506 DO10225JJ=1,5 2507 X3D(JJ)=1.0 2508 DSIZE(JJ)=1.0 2509 DSYMB(JJ)=1.0 2510 DCOLOR(JJ)=1.0 2511 DFILL(JJ)=1.0 2512 D(JJ)=1.0 251310225 CONTINUE 2514 ENDIF 2515 ENDIF 251610200 CONTINUE 2517 NACC=0 2518 NREJ=0 2519 NTOT=0 2520 IF(NUMSBR.GT.0)THEN 2521 NSTRT=NUMSBR*4+1 2522 IF(NSTRT.GT.NPLOTP)GOTO10299 2523 NTOT=0 2524 NACC=0 2525 NREJ=0 2526 XLOW=X(1) 2527 XHIGH=X(2) 2528 YLOW=Y(1) 2529 YHIGH=Y(4) 2530 DO10260I=NSTRT,NPLOTP 2531 NTOT=NTOT+1 2532 XPNT=X(I) 2533 YPNT=Y(I) 2534 IF( 2535 1 (XPNT.LT.XLOW.OR. XPNT.GT.XHIGH) .OR. 2536 1 (YPNT.LT.YLOW.OR.YPNT.GT.YHIGH) 2537 1 )THEN 2538 NREJ=NREJ+1 2539 ELSE 2540 NACC=NACC+1 2541 ENDIF 254210260 CONTINUE 2543 ENDIF 254410299 CONTINUE 2545 IH='NACC' 2546 IH2='EPT ' 2547 VALUE0=REAL(NACC) 2548 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2549 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2550 1IANS,IWIDTH,IBUGG3,IERROR) 2551 IH='NREJ' 2552 IH2='ECT ' 2553 VALUE0=REAL(NREJ) 2554 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2555 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2556 1IANS,IWIDTH,IBUGG3,IERROR) 2557 IH='NTOT' 2558 IH2='AL ' 2559 VALUE0=REAL(NTOT) 2560 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 2561 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 2562 1IANS,IWIDTH,IBUGG3,IERROR) 2563C 2564C ***************** 2565C ** STEP 90-- ** 2566C ** EXIT ** 2567C ***************** 2568C 2569 9001 CONTINUE 2570C 2571C APRIL 2007. CHECK FOR FATAL ERROR 2572C 2573 IERRST=IERROR 2574C 2575 IF(IERROR.EQ.'YES')THEN 2576 CALL DPERRO(IERRFA,IANSLC,IWIDTH,IGUIFL, 2577 1 ISUBN1,ISUBN2,ICASPL, 2578 1 IBUGG2,ISUBRO,IERROR) 2579 ENDIF 2580C 2581 IF(IBUGGR.EQ.'ON'.OR.ISUBRO.EQ.'INGR')THEN 2582 WRITE(ICOUT,999) 2583 CALL DPWRST('XXX','BUG ') 2584 WRITE(ICOUT,9011) 2585 9011 FORMAT('***** AT THE END OF MAINGR--') 2586 CALL DPWRST('XXX','BUG ') 2587 WRITE(ICOUT,9020)IFOUND,IERROR 2588 9020 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 2589 CALL DPWRST('XXX','BUG ') 2590 ENDIF 2591C 2592 RETURN 2593 END 2594 SUBROUTINE MAININ(IBUGIN,ICOMHO,ICOMH2,IRSCNT) 2595C 2596C PURPOSE--THIS IS SUBROUTINE MAININ. 2597C (THE IN AT THE END OF MAINPC STANDS FOR INITIAL 2598C THIS SUBROUTINE INITIALIZES ALL NEEDED CONSTANTS 2599C FOR THE AREAS--MC = MACHINE CONSTANTS 2600C --DB = DEBUGGING 2601C --HK = HOUSEKEEPING 2602C --PC = PLOT CONTROL 2603C --OD = OUTPUT DEVICES 2604C --SU = SUPPORT 2605C --GR = GRAPHICS 2606C --AN = ANALYSIS 2607C --DA = DATA 2608C --DG = DIAGRAMMATIC GRAPHICS 2609C --H2 = HOUSEKEEPING (PART 2) 2610C --3D = 3-DIMENSIONAL 2611C THIS ROUTINE IS TYPICALLY CALLED ONLY ONCE PER DATAPLOT RUN 2612C (IMMEDIATELY AFTER SIGN-ON). 2613C 2614C WRITTEN BY--JAMES J. FILLIBEN 2615C STATISTICAL ENGINEERING DIVISION 2616C INFORMATION TECHNOLOGY LABORATORY 2617C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 2618C GAITHERSBURG, MD 20899-8980 2619C PHONE--301-975-2855 2620C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 2621C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 2622C LANGUAGE--ANSI FORTRAN (1977) 2623C VERSION NUMBER--86/1 2624C ORIGINAL VERSION--NOVEMBER 1980. 2625C UPDATED --FEBRUARY 1981. 2626C UPDATED --MAY 1981. 2627C UPDATED --AUGUST 1981. 2628C UPDATED --OCTOBER 1981. 2629C UPDATED --NOVEMBER 1981. 2630C UPDATED --MAY 1982. 2631C UPDATED --DECEMBER 1986. 2632C UPDATED --SEPTEMBER 1988. GENERAL 3-D 2633C UPDATED --DECEMBER 1988. RESET2 2634C UPDATED --MAY 1989. INITIALIZE DES. OF EXP. COMMON 2635C UPDATED --AUGUST 1990. INITIALIZE WINDOW SYSTEM 2636C UPDATED --DECEMBER 2015. ADD "IRSCNT". IF IRSCNT > 0, 2637C DO NOT RESET DEVICE 1 UNDER 2638C WINDOWS (THIS CAUSES A CRASH 2639C WITH THE QWIN DEVICE). 2640C 2641C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 2642C 2643 CHARACTER*4 IBUGIN 2644 CHARACTER*4 ICOMHO 2645 CHARACTER*4 ICOMH2 2646C 2647C-----COMMON---------------------------------------------------------- 2648C 2649 INCLUDE 'DPCOPA.INC' 2650 INCLUDE 'DPCOHK.INC' 2651 INCLUDE 'DPCODA.INC' 2652 INCLUDE 'DPCOHO.INC' 2653 INCLUDE 'DPCO3D.INC' 2654 INCLUDE 'DPCOP2.INC' 2655C 2656C-----START POINT----------------------------------------------------- 2657C 2658 IF(IBUGIN.EQ.'ON')THEN 2659 WRITE(ICOUT,999) 2660 999 FORMAT(1X) 2661 CALL DPWRST('XXX','BUG ') 2662 WRITE(ICOUT,51) 2663 51 FORMAT('AT THE BEGINNING OF MAININ--') 2664 CALL DPWRST('XXX','BUG ') 2665 WRITE(ICOUT,53)IBUGPC,ICOMHO,ICOMH2,IRSCNT 2666 53 FORMAT('IBUGPC,ICOMHO,ICONH2,IRSCNT = ',3(A4,2X),I8) 2667 CALL DPWRST('XXX','BUG ') 2668 ENDIF 2669C 2670C **************************************************************** 2671C ** STEP 1-- 2672C ** INITIALIZE VARIABLES AND PARAMETERS. 2673C ** 11 INITIALIZATION SUBROUTINES ARE CALLED-- 2674C ** INITMC--INITIALIZE MACHINE CONSTANTS 2675C ** INITFO--INITIALIZE FILE OPERATIONS 2676C ** INITHK--INITIALIZE HOUSEKEEPING VARIABLES AN 2677C ** INITDA--INITIALIZE DATA VARIABLES. 2678C ** INITPC--INITIALIZE PLOT CONTROL COMMANDS VARIABLES AN 2679C ** INITDG--INITIALIZE DIAGRAMMATIC GRAPHICS COMMANDS VAR 2680C ** INITOD--INITIALIZE OUTPUT DEVICE COMMANDS VARIABLES AN 2681C ** INITSU--INITIALIZE SUPPORT COMMANDS VARIABLES AN 2682C ** INITH2--INITIALIZE HOUSEKEEPING (PART 2) VARIABLES AN 2683C ** INITDB--INITIALIZE DEBUGGING VARIABLES. 2684C ** INIT3D--INITIALIZE 3-DIMENSIONAL VARIABLES. 2685C **************************************************************** 2686C 2687 IBUGIN='OFF' 2688 IFLAG=0 2689 IF(ICOMHO.EQ.'RESE'.AND.ICOMH2.EQ.'T2 ')IFLAG=1 2690 IF(IFLAG.EQ.0)THEN 2691 CALL INITMC(IBUGIN) 2692 CALL INITFO(IBUGIN) 2693 ENDIF 2694C 2695 CALL INITHK(IBUGIN) 2696 CALL INITDA(IBUGIN) 2697 CALL INITPC(IBUGIN) 2698CCCCC CALL INITDG(IBUGIN) 2699C DIAGRAMMATIC GRAPHICS INITIALIZATION IS NOW DONE (NOV 1983) 2700C IN INITPC 2701C 2702 IF(IFLAG.EQ.0 .AND. IRSCNT.EQ.0)THEN 2703 CALL INITOD(IBUGIN) 2704 ENDIF 2705C 2706 CALL INITSU(IBUGIN) 2707CCCCC THE FOLLOWING DES. OF EXP. LINE WAS ADDED MAY 1989 2708 CALL INITDE(IBUGIN) 2709 CALL INIT3D(IBUGIN) 2710CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1990 2711CCCCC CALL INITWI(IBUGIN) 2712C 2713 CALL INITH2(IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP, 2714 1IVALUE,VALUE,NUMNAM,MAXN,MAXCOL,IBUGIN) 2715 CALL INITDB 2716C 2717C ***************** 2718C ** STEP 90-- ** 2719C ** EXIT ** 2720C ***************** 2721C 2722 IF(IBUGIN.EQ.'ON')THEN 2723 WRITE(ICOUT,999) 2724 CALL DPWRST('XXX','BUG ') 2725 WRITE(ICOUT,9011) 2726 9011 FORMAT('AT THE END OF MAININ--') 2727 CALL DPWRST('XXX','BUG ') 2728 WRITE(ICOUT,9013)IBUGIN 2729 9013 FORMAT('IBUGIN = ',A4) 2730 CALL DPWRST('XXX','BUG ') 2731 ENDIF 2732C 2733 RETURN 2734 END 2735 SUBROUTINE MAINOD(IBUGOD,IBUGO2,ISUBRO, 2736 1 ICAPSW, 2737 1 IFOUND,IERROR) 2738C 2739C PURPOSE--THIS IS SUBROUTING MAINOD. 2740C (THE OD AT THE END OF MAINOD STANDS FOR OUTPUT DEVICE 2741C THIS SUBROUTINE SEARCHES FOR AND EXECUTES OUTPUT DEVICE COMMANDS. 2742C THE OUTPUT DEVICE COMMANDS SEARCHED FOR BY MAINOD ARE AS FOLLOWS- 2743C 2744C 1) DEVICE ... POWER ON/OFF 2745C 2) DEVICE ... MANUFACTURER A MANUFACTURER AND MODE 2746C 3) DEVICE ... CONTINUOUS ON/OFF 2747C 4) DEVICE ... COLOR ON/OFF 2748C 5) DEVICE ... PICTURE POINTS 2 NUMBERS 2749C 6) DEVICE ... UNIT NUMBER A NUMBER 2750C 2751C 7) TERMINAL POWER ON/OFF 2752C 8) TERMINAL MANUFACTURER A MANUFACTURER AND MODE 2753C 8) TERMINAL CONTINUOUS ON/OFF 2754C 9) TERMINAL COLOR ON/OFF 2755C 10) TERMINAL PICTURE POINTS 2 NUMBERS 2756C 6) TERMINAL UNIT NUMBER A NUMBER 2757C 2758C 11) POWER ON/OFF 2759C 12) MANUFACTURER A MANUFACTURER AND MODE 2760C 13) CONTINUOUS ON/OFF 2761C 14) COLOR ON/OFF 2762C 15) PICTURE POINTS 2 NUMBERS 2763C 16) UNIT NUMBER A NUMBER 2764C 2765C 16) DISCRETE ON/OFF 2766C 17) DISCRETE NARROW-WIDTH ON/OFF 2767C 18) DISCRETE WIDE-CARRIAGE ON/OFF 2768C 19) BATCH ON/OFF 2769C 2770C 20) FILE ON/OFF 2771C 20) CALCOMP ON/OFF 2772C 21) VERSATEC ON/OFF 2773C 22) ZETA ON/OFF 2774C 2775C 22) METAFILE ON/OFF 2776C 2777C 23) HARDCOPY ON/OFF AND OPTIONALLY A 2778C 24) PENPLOTTER ON/OFF AND OPTIONALLY A 2779C 2780C WRITTEN BY--JAMES J. FILLIBEN 2781C STATISTICAL ENGINEERING DIVISION 2782C INFORMATION TECHNOLOGY LABORATORY 2783C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 2784C GAITHERSBURG, MD 20899-8980 2785C PHONE--301-975-2855 2786C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 2787C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 2788C LANGUAGE--ANSI FORTRAN (1977) 2789C VERSION NUMBER--82.6 2790C ORIGINAL VERSION--SEPTEMBER 1980. 2791C UPDATED --MARCH 1981. 2792C UPDATED --SEPTEMBER 1981. 2793C UPDATED --NOVEMBER 1981. 2794C UPDATED --FEBRUARY 1982. 2795C UPDATED --MARCH 1982. 2796C UPDATED --MAY 1982. 2797C UPDATED --FEBRUARY 1989. 2 OFFSET ARGUMENTS IN CALLS TO DPDEMN 2798C UPDATED --FEBRUARY 1989. ADD CHECKS FOR NEW DEVICES (ALAN)-- 2799C GENERAL CGM (OR CGM) 2800C QUIC (OR QMS) 2801C POSTSCRIPT 2802C PCL (OR LASERJET) 2803C DICOMED 2804C UPDATED --MARCH 1990. ADD CHECK FOR X11 DEVICE 2805C UPDATED --MAY 1990. CHECK FOR [HPGL/ZETA/CALC] PEN MAP, 2806C DISTINGUISH BETWEEN ON/OFF AND 2807C OPEN/CLOSE 2808C UPDATED --JANUARY 1991. ADD REGIS TO PEN MAP COMMAND 2809C UPDATED --MAY 1991. ADD TURBO-C/VGA (JJF) 2810C UPDATED --JUNE 1991. ADD X11 TO PEN MAP COMMAND 2811C UPDATED --OCTOBER 1991. ADD "POSTSCRIPT SHOW FONT" COMMAND 2812C UPDATED --APRIL 1992. PRINT PLOT, P, PP 2813C UPDATED --MAY 1992. POSTSCRIPT BLANK PAGE SWITCH 2814C UPDATED --JUNE 1992. ARGUMENT LIST TO DPDEMN 2815C UPDATED --AUGUST 1992. ADD "SHOW COLORS" COMMAND. 2816C UPDATED --APRIL 1993. CHECK FOR CONFLICT WITH 2817C P CONTROL CHART (ALAN) 2818C UPDATED --OCTOBER 1993. BUG FOR DISCRETE ON 2819C UPDATED --DECEMBER 1993. COMMENT OUT GENERAL 2820C UPDATED --MAY 1994. CHECK CONFLICT BETWEEN REGIS 2821C AND REGION 2822C UPDATED --SEPTEMBER 1994. CHECK CONFLICT BETWEEN DISCR 2823C AND DISCR UNIFORM PROB PLOT 2824C UPDATED --APRIL 1995. CHECK CONFLICT BETWEEN POWER 2825C AND POWER NORMAL AND POWER 2826C LOGNORMAL (PROB PLOT, PPCC 2827C PLOT) 2828C UPDATED --OCTOBER 1995. CHECK CONFLICT BETWEEN GENERAL 2829C AND GENERALIZED EXTREME VALUE 2830C AND GENERALIZED HALF LOGISTIC 2831C (PROB AND PPCC PLOTS) 2832C UPDATED --DECEMBER 1995. CHECK CONFLICT BETWEEN GENERAL 2833C AND GENERALIZED LOGISTIC 2834C UPDATED --FEBRUARY 1996. CHECK CONFLICT BETWEEN GENERAL 2835C AND GENERALIZED EXPONENTIAL 2836C UPDATED --JULY 1996. DEVICE ... FONT COMMAND 2837C UPDATED --OCTOBER 1996. ADD CHECKS FOR NEW DEVICES (ALAN)-- 2838C MICROSOFT QUICKWIN 2839C PBM (PORTABLE BIT MAP) 2840C UPDATED --JUNE 1998. NAME CONFLICT WITH POWER MLE 2841C UPDATED --JUNE 2000. ADD CHECKS FOR NEW DEVICES (ALAN)-- 2842C OPEN-GL 2843C GD JPEG 2844C GD PNG 2845C GD WBMP 2846C WINDOWS BITMAP 2847C UPDATED --MARCH 2002. ADD CHECKS FOR NEW DEVICES (ALAN)-- 2848C SVG 2849C UPDATED --SEPTEMBER 2002. ICAPSW FOR DPDEMN, DPDEPW 2850C UPDATED --SEPTEMBER 2007. IERRST 2851C UPDATED --SEPTEMBER 2011. VIEW PLOT COMMAND 2852C UPDATED --OCTOBER 2016. UPDATES TO VIEW PLOT COMMAND 2853C UPDATED --DECEMBER 2018. DEVICE SCALE 2854C 2855C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 2856C 2857 CHARACTER*4 IOP 2858 CHARACTER*4 ICAPSW 2859C 2860 CHARACTER*4 IBUGOD 2861 CHARACTER*4 IBUGO2 2862 CHARACTER*4 ISUBRO 2863C 2864 CHARACTER*4 IFOUND 2865 CHARACTER*4 IERROR 2866C 2867 INCLUDE 'DPCOPA.INC' 2868C 2869 CHARACTER*4 IFTYPE 2870 CHARACTER*4 ICASE2 2871 CHARACTER*4 ICASE3 2872 CHARACTER*4 ISUBN1 2873 CHARACTER*4 ISUBN2 2874 CHARACTER*4 ISTEPN 2875 CHARACTER*4 ICASEZ 2876C 2877 CHARACTER (LEN=MAXSTR) :: ICANS 2878 CHARACTER (LEN=MAXSTR) :: ISTRIN 2879 CHARACTER (LEN=MAXFNC) :: ICMDTI 2880 CHARACTER (LEN=MAXFNC) :: IFILEZ 2881 CHARACTER (LEN=MAXFNC) :: ITEMP 2882C 2883C-----COMMON---------------------------------------------------------- 2884C 2885 INCLUDE 'DPCOHK.INC' 2886 INCLUDE 'DPCOPC.INC' 2887 INCLUDE 'DPCOF2.INC' 2888CCCCC THE FOLLOWING LINE WAS ADDED MAY 1992 (JJF) 2889 INCLUDE 'DPCODV.INC' 2890 INCLUDE 'DPCOST.INC' 2891 INCLUDE 'DPCOP2.INC' 2892C 2893C-----START POINT----------------------------------------------------- 2894C 2895 I=1 2896 IOP='-999' 2897 ISUBN1='MAIN' 2898 ISUBN2='OD ' 2899 IFOUND='NO' 2900 IERROR='NO' 2901C 2902 IF(IBUGOD.EQ.'ON'.OR.ISUBRO.EQ.'INOD')THEN 2903 WRITE(ICOUT,999) 2904 999 FORMAT(1X) 2905 CALL DPWRST('XXX','BUG ') 2906 WRITE(ICOUT,51) 2907 51 FORMAT('***** AT THE BEGINNING OF MAINOD--') 2908 CALL DPWRST('XXX','BUG ') 2909 WRITE(ICOUT,53)IBUGOD,IBUGO2,ISUBRO 2910 53 FORMAT('IBUGOD,IBUGO2,ISUBRO = ',3(A4,2X),A4) 2911 CALL DPWRST('XXX','BUG ') 2912 WRITE(ICOUT,60)IFOUND,IERROR,ICOM,ICOM2,IPSTBP,NUMARG 2913 60 FORMAT('IFOUND,IERROR,ICOM,ICOM2,IPSTBP,NUMARG = ', 2914 1 5(A4,2X),G15.7) 2915 CALL DPWRST('XXX','BUG ') 2916 DO70I=1,NUMARG 2917 WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) 2918 71 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ', 2919 1 I8,3(2X,A4),2X,I8,G15.7) 2920 CALL DPWRST('XXX','BUG ') 2921 70 CONTINUE 2922 ENDIF 2923C 2924C ***************************************************** 2925C ** TREAT THE GENERAL (= DEVICE-INDEPENDENT) CASE ** 2926C ***************************************************** 2927C 2928C CHECK FOR NAME CONFLICTS WITH "GENERAL" 2929C 2930 IF(NUMARG.GE.2)THEN 2931 IF(IHARG(2).EQ.'PROB')GOTO9000 2932 IF(IHARG(2).EQ.'PPCC')GOTO9000 2933 ELSEIF(NUMARG.GE.1)THEN 2934 IF(IHARG(1).EQ.'JACC')GOTO9000 2935 IF(IHARG(1).EQ.'PARE')GOTO9000 2936 IF(IHARG(1).EQ.'LOGI')GOTO9000 2937 IF(IHARG(1).EQ.'PPCC')GOTO9000 2938 IF(IHARG(1).EQ.'PROB')GOTO9000 2939 IF(IHARG(1).EQ.'GAMM')GOTO9000 2940 IF(IHARG(1).EQ.'EXTR')GOTO9000 2941 IF(IHARG(1).EQ.'HALF')GOTO9000 2942 IF(IHARG(1).EQ.'LOGI')GOTO9000 2943 IF(IHARG(1).EQ.'EXPO')GOTO9000 2944 IF(IHARG(1).EQ.'LAMB')GOTO9000 2945 IF(IHARG(1).EQ.'TRAP')GOTO9000 2946 IF(IHARG(1).EQ.'MCLE')GOTO9000 2947 IF(IHARG(1).EQ.'INVE'.AND.IHARG(2).EQ.'GAUS')GOTO9000 2948 IF(IHARG(1).EQ.'ASYM'.AND.IHARG(2).EQ.'LAPL')GOTO9000 2949 IF(IHARG(1).EQ.'ASYM'.AND.IHARG(2).EQ.'DOUB')GOTO9000 2950 IF(IHARG(1).EQ.'TUKE'.AND.IHARG(2).EQ.'LAMB')GOTO9000 2951 IF(IHARG(1).EQ.'LOGA'.AND.IHARG(2).EQ.'SERI')GOTO9000 2952 IF(IHARG(1).EQ.'NEGA'.AND.IHARG(2).EQ.'BINO')GOTO9000 2953 IF(IHARG(1).EQ.'LOST'.AND.IHARG(2).EQ.'GAME')GOTO9000 2954 IF(IHARG(1).EQ.'TOPP'.AND.IHARG(2).EQ.'LEON')GOTO9000 2955 IF(IHARG(1).EQ.'TOPP'.AND.IHARG(2).EQ.'AND '.AND. 2956 1 IHARG(3).EQ.'LEON')GOTO9000 2957 ENDIF 2958C 2959C DEVICE PEN MAP CASE 2960C 2961 IF((ICOM.EQ.'HPGL'.AND.IHARG(1).EQ.'MAP') .OR. 2962 1 (ICOM.EQ.'HPGL'.AND.IHARG(1).EQ.'PEN') .OR. 2963 1 (ICOM.EQ.'HP-G'.AND.IHARG(1).EQ.'PEN') .OR. 2964 1 (ICOM.EQ.'HP-G'.AND.IHARG(1).EQ.'MAP') .OR. 2965 1 (ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'PEN') .OR. 2966 1 (ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'MAP') .OR. 2967 1 (ICOM.EQ.'CALC'.AND.IHARG(1).EQ.'PEN') .OR. 2968 1 (ICOM.EQ.'CALC'.AND.IHARG(1).EQ.'MAP') .OR. 2969 1 (ICOM.EQ.'HPGL'.AND.IHARG(1).EQ.'COLO') .OR. 2970 1 (ICOM.EQ.'HP-G'.AND.IHARG(1).EQ.'COLO') .OR. 2971 1 (ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'COLO') .OR. 2972 1 (ICOM.EQ.'CALC'.AND.IHARG(1).EQ.'COLO') .OR. 2973 1 (ICOM.EQ.'REGI'.AND.ICOM2.EQ.'S '.AND. 2974 1 IHARG(1).EQ.'MAP') .OR. 2975 1 (ICOM.EQ.'REGI'.AND.ICOM2.EQ.'S '.AND. 2976 1 IHARG(1).EQ.'PEN') .OR. 2977 1 (ICOM.EQ.'REGI'.AND.ICOM2.EQ.'S '.AND. 2978 1 IHARG(1).EQ.'COLO') .OR. 2979 1 (ICOM.EQ.'X11 '.AND.IHARG(1).EQ.'MAP') .OR. 2980 1 (ICOM.EQ.'X11 '.AND.IHARG(1).EQ.'PEN') .OR. 2981 1 (ICOM.EQ.'X11 '.AND.IHARG(1).EQ.'COLO'))THEN 2982 CALL DPDEPM(ICOM,IHARG,IHARG2,IARGT,IARG,NUMARG, 2983 1 IBUGO2,ISUBRO,IFOUND,IERROR) 2984 GOTO9000 2985C 2986C FOLLOWING LINES ADDED OCTOBER, 1991. ADD "POSTSCRIPT SHOW FONTS" COMMAND 2987C 2988 ELSEIF((ICOM.EQ.'POST'.AND.IHARG(1).EQ.'SHOW') .OR. 2989 1 (ICOM.EQ.'POST'.AND.IHARG(1).EQ.'LIST') .OR. 2990 1 (ICOM.EQ.'POST'.AND.IHARG(1).EQ.'PRIN') .OR. 2991 1 (ICOM.EQ.'POST'.AND.IHARG(1).EQ.'FONT') .OR. 2992 1 (ICOM.EQ.'SHOW' .AND. IHARG(1).EQ.'FONT'))THEN 2993 CALL DPDEFN(ICOM,IHARG,IHARG2,IARGT,IARG,NUMARG, 2994 1 IBUGO2,ISUBRO,IFOUND,IERROR) 2995 GOTO9000 2996C 2997C SHOW COLORS CASE 2998C 2999 ELSEIF(ICOM.EQ.'SHOW' .AND. IHARG(1).EQ.'COLO')THEN 3000 CALL DPDEPM(ICOM,IHARG,IHARG2,IARGT,IARG,NUMARG, 3001 1 IBUGO2,ISUBRO,IFOUND,IERROR) 3002 GOTO9000 3003C 3004C GENERAL DEVICE (METAFILE) 3005C 3006 ELSEIF((ICOM.EQ.'GENE' .AND. NUMARG.LT.1) .OR. 3007 1 ICOM.EQ.'CGM ' .OR. 3008 1 (ICOM.EQ.'DEVI'.AND.NUMARG.GE.1.AND. 3009 1 IHARG(1).EQ.'GENE') .OR. 3010 1 (ICOM.EQ.'DEVI'.AND.NUMARG.GE.1.AND. 3011 1 IHARG(1).EQ.'INDE'))THEN 3012 IOP='ON' 3013 IF(NUMARG.GE.1.AND.IHARG(NUMARG).EQ.'OFF')IOP='OFF' 3014 ICOM='DEVI' 3015 ICOM2='CE ' 3016C 3017 ISHIFT=2 3018 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 3019 1 IBUGO2,IERROR) 3020 IHARG(1)='1 ' 3021 IHARG2(1)=' ' 3022 IARGT(1)='NUMB' 3023 IARG(1)=1 3024C 3025 IF(IOP.EQ.'ON')THEN 3026 IHARG(2)='MANU' 3027 IHARG2(2)='FACT' 3028 IARGT(2)='WORD' 3029 IHARG(3)='GENE' 3030 IHARG2(3)='RAL ' 3031 IARGT(3)='WORD' 3032 NUMARG=3 3033 IF(IHARG(4).EQ.'CODE')NUMARG=4 3034 IF(IHARG(4).EQ.'CGM')NUMARG=4 3035 CALL DPDEMN(IHARG,IHARG2,IARGT,IARG,NUMARG, 3036 1 IPL1NU,IPL1NA,IPL2NU,IPL2NA, 3037 1 IPL1CS,IPL2CS, 3038 1 IDEFMA,IDEFMO,IDEFM2,IDEFM3, 3039 1 IDEFPO,IDEFCN,IDEFDC,IDEFVP,IDEFHP,IDEFUN, 3040 1 NUMDEV,MAXDEV, 3041 1 IDMANU,IDMODE,IDMOD2,IDMOD3, 3042 1 IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT, 3043 1 IDNVOF,IDNHOF, 3044 1 ICAPSW,ICAPNU, 3045 1 IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR) 3046 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3047 ELSE 3048 IHARG(2)='POWE' 3049 IHARG2(2)='R ' 3050 IARGT(2)='WORD' 3051 IHARG(3)='OFF ' 3052 IHARG2(3)=' ' 3053 IARGT(3)='WORD' 3054 NUMARG=3 3055 CALL DPDEPW(IHARG,IHARG2,IARGT,IARG,NUMARG, 3056 1 IPL1NU,IPL1NA,IPL2NU,IPL2NA, 3057 1 IDEFPO, 3058 1 NUMDEV,MAXDEV, 3059 1 IDMANU,IDMODE,IDMOD2,IDMOD3, 3060 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 3061 1 IDNVOF,IDNHOF, 3062 1 ICAPSW,ICAPNU, 3063 1 IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR) 3064 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3065 ENDIF 3066 GOTO1099 3067C 3068 ELSE 3069 GOTO1099 3070 ENDIF 3071C 3072 1099 CONTINUE 3073C 3074CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1992 (JJF) 3075C **************************************** 3076C ** TREAT THE P CASE ** 3077C ** TREAT THE PP CASE ** 3078C ** TREAT THE PRINT PLOT CASE ** 3079C **************************************** 3080C 3081 ISTEPN='2' 3082 IF(IBUGOD.EQ.'ON'.OR.ISUBRO.EQ.'INOD') 3083 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 3084C 3085CCCCC APRIL 1993 CHECK FOR CONFLICT WITH P CHART 3086CCCCC APRIL 1993 AND P CONTROL CHART (ALAN) 3087 IF(ICOM.EQ.'P'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'CONT')GOTO9000 3088 IF(ICOM.EQ.'P'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'CHAR')GOTO9000 3089C 3090 IF(ICOM.EQ.'P' .OR. ICOM.EQ.'PP' .OR. 3091 1 (NUMARG.GE.1 .AND. ICOM.EQ.'PRIN' .AND. 3092 1 IHARG(1).EQ.'PLOT' .AND. IHARG2(1).EQ.' '))THEN 3093C 3094 IFOUND='YES' 3095 IF(IPL2CS.NE.'CLOS')THEN 3096 CALL DPDEV(3,'CLOS','POST',ICAPSW,IBUGOD,ISUBRO,IERROR) 3097 IF(IERROR.EQ.'YES')THEN 3098 WRITE(ICOUT,999) 3099 CALL DPWRST('XXX','BUG ') 3100 WRITE(ICOUT,7011) 3101 7011 FORMAT('***** ERROR IN MAINOD') 3102 CALL DPWRST('XXX','BUG ') 3103 WRITE(ICOUT,7012) 3104 7012 FORMAT(' IN ATTEMPTING TO CLOSE DEVICE 3') 3105 CALL DPWRST('XXX','BUG ') 3106 GOTO9000 3107 ENDIF 3108 ENDIF 3109 IFTYPE='POST' 3110 CALL PRINFI(IPL2NA,IFTYPE,IBUGO2,ISUBRO,IERROR) 3111 GOTO9000 3112C 3113 ENDIF 3114C 3115CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 2011 3116C **************************************** 3117C ** TREAT THE PSVIEW CASE ** 3118C ** (VIEWS DPPL2F.DAT FILE) ** 3119C **************************************** 3120C 3121 IF(ICOM.EQ.'PSVI' .OR. 3122 1 (NUMARG.EQ.0 .AND. ICOM.EQ.'SHOW'))THEN 3123 IFOUND='YES' 3124C 3125C VIEW DEVICE 3 OUTPUT 3126C 3127 IF(NUMARG.LE.0)THEN 3128 IF(IPL2CS.NE.'CLOS')THEN 3129 CALL DPDEV(3,'CLOS','POST',ICAPSW,IBUGOD,ISUBRO,IERROR) 3130 IF(IERROR.EQ.'YES')THEN 3131 WRITE(ICOUT,999) 3132 CALL DPWRST('XXX','BUG ') 3133 WRITE(ICOUT,7011) 3134 CALL DPWRST('XXX','BUG ') 3135 WRITE(ICOUT,7012) 3136 CALL DPWRST('XXX','BUG ') 3137 GOTO9000 3138 ENDIF 3139 ENDIF 3140 ICASE3='IPL2' 3141 CALL VIEWFI(IPL2NA,ICASE3,IBUGO2,ISUBRO,IERROR) 3142 GOTO9000 3143 ELSEIF((IHARG(1).LE.'DEVI' .AND. IHARG(2).EQ.'2') .OR. 3144 1 (IHARG(1).EQ.'DPPL' .AND. IHARG2(1)(1:2).EQ.'1F') .OR. 3145 1 (IHARG(1).EQ.'IPL1' .AND. IHARG2(1).EQ.'NA '))THEN 3146C 3147C VIEW DEVICE 2 OUTPUT. SET PSVIEW CLOSE FILE COMMAND SPECIFIES 3148C WHETHER USER WANTS TO CLOSE FILE OR NOT. 3149C 3150 IF(IPSVCL.EQ.'ON')THEN 3151 IF(IPL1CS.NE.'CLOS')THEN 3152 CALL DPDEV(2,'CLOS','POST',ICAPSW,IBUGOD,ISUBRO,IERROR) 3153 IF(IERROR.EQ.'YES')THEN 3154 WRITE(ICOUT,999) 3155 CALL DPWRST('XXX','BUG ') 3156 WRITE(ICOUT,7011) 3157 CALL DPWRST('XXX','BUG ') 3158 WRITE(ICOUT,7014) 3159 7014 FORMAT(' IN ATTEMPTING TO CLOSE DEVICE 2') 3160 CALL DPWRST('XXX','BUG ') 3161 GOTO9000 3162 ELSE 3163 IF(IFEEDB.EQ.'ON')THEN 3164 WRITE(ICOUT,999) 3165 CALL DPWRST('XXX','BUG ') 3166 WRITE(ICOUT,7016) 3167 7016 FORMAT(' DEVICE 2 OUTPUT FILE HAS BEEN CLOSED.') 3168 CALL DPWRST('XXX','BUG ') 3169 ENDIF 3170 ENDIF 3171 ENDIF 3172 ELSE 3173 IF(IFEEDB.EQ.'ON')THEN 3174 WRITE(ICOUT,999) 3175 CALL DPWRST('XXX','BUG ') 3176 WRITE(ICOUT,7018) 3177 7018 FORMAT(' DEVICE 2 OUTPUT FILE HAS NOT BEEN ', 3178 1 'CLOSED.') 3179 CALL DPWRST('XXX','BUG ') 3180 WRITE(ICOUT,7019) 3181 7019 FORMAT(' THE LAST PLOT MAY NOT BE COMPLETE.') 3182 CALL DPWRST('XXX','BUG ') 3183 ENDIF 3184 ENDIF 3185 ICASE3='IPL1' 3186 CALL VIEWFI(IPL1NA,ICASE3,IBUGO2,ISUBRO,IERROR) 3187 GOTO9000 3188 ELSEIF(NUMARG.GE.1)THEN 3189C 3190C ARBITRARY FILE NAME 3191C 3192 IWORD=2 3193 MAXTMP=80 3194 ICASEZ='NULL' 3195 ICMDTI='THE POSTSCRIPT FILE NAME FOR THE PSVIEW COMMAND = ' 3196 CALL DPEXFN(IANS,IANSLC,ICANS,MAXTMP,IWIDTH,NUMARG, 3197 1 ISTRIN,IWORD,ICMDTI,ITEMP, 3198 1 ICASEZ,IFILEZ,NCFILE, 3199 1 IBUGO2,ISUBRO,IFOUND,IERROR) 3200 IF(NCFILE.LE.80)THEN 3201 ICASE3='FILE' 3202 CALL VIEWFI(ISTRIN,ICASE3,IBUGO2,ISUBRO,IERROR) 3203 ELSE 3204 WRITE(ICOUT,999) 3205 CALL DPWRST('XXX','BUG ') 3206 WRITE(ICOUT,7013) 3207 7013 FORMAT(' THE SPECIFIED FILE NAME HAS MORE THAN 80 ', 3208 1 'CHARACTERS.') 3209 IERROR='YES' 3210 ENDIF 3211 GOTO9000 3212 ENDIF 3213 ENDIF 3214C 3215C *********************************** 3216C ** PRE-TREAT THE TERMINAL CASE ** 3217C *********************************** 3218C 3219 IF(ICOM.EQ.'TERM'.AND.IHARG(1).EQ.'CHAR')GOTO9000 3220 IF(ICOM.EQ.'TERM')THEN 3221 ISHIFT=1 3222 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 3223 1 IBUGO2,IERROR) 3224 IHARG(1)='1 ' 3225 IHARG2(1)=' ' 3226 IARGT(1)='NUMB' 3227 IARG(1)=1 3228 ENDIF 3229C 3230C ************************************************ 3231C ** TREAT THE DEVICE ... POWER CASE ** 3232C ** TREAT THE DEVICE ... CONTINUOUS CASE ** 3233C ** TREAT THE DEVICE ... COLOR CASE ** 3234C ** TREAT THE DEVICE ... PICTURE POINTS CASE ** 3235C ** TREAT THE DEVICE ... UNIT CASE ** 3236C ** TREAT THE DEVICE ... FONT CASE ** 3237C ** TREAT THE DEVICE ... SCALE CASE ** 3238C ** TREAT THE DEVICE ... (MANUFACTURER) CASE ** 3239C ************************************************ 3240C 3241 IF(ICOM.EQ.'DEVI' .OR. ICOM.EQ.'TERM')THEN 3242 CALL DPDEPW(IHARG,IHARG2,IARGT,IARG,NUMARG, 3243 1 IPL1NU,IPL1NA, 3244 1 IPL2NU,IPL2NA, 3245 1 IDEFPO, 3246 1 NUMDEV,MAXDEV, 3247 1 IDMANU,IDMODE,IDMOD2,IDMOD3, 3248 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 3249 1 IDNVOF,IDNHOF, 3250 1 ICAPSW,ICAPNU, 3251 1 IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR) 3252 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3253C 3254 CALL DPDECN(IHARG,IARGT,IARG,NUMARG, 3255 1 IDEFCN, 3256 1 NUMDEV,MAXDEV, 3257 1 IDMANU,IDMODE,IDMOD2,IDMOD3, 3258 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 3259 1 IFOUND,IERROR) 3260 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3261C 3262 CALL DPDECL(IHARG,IARGT,IARG,NUMARG, 3263 1 IDEFDC, 3264 1 NUMDEV,MAXDEV, 3265 1 IDMANU,IDMODE,IDMOD2,IDMOD3, 3266 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 3267 1 IFOUND,IERROR) 3268 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3269C 3270 CALL DPDEPP(IHARG,IARGT,IARG,NUMARG, 3271 1 IDEFVP,IDEFHP, 3272 1 NUMDEV,MAXDEV, 3273 1 IDMANU,IDMODE,IDMOD2,IDMOD3, 3274 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 3275 1 IFOUND,IERROR) 3276 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3277C 3278 CALL DPDEUN(IHARG,IARGT,IARG,NUMARG, 3279 1 IDEFUN, 3280 1 NUMDEV,MAXDEV, 3281 1 IDMANU,IDMODE,IDMOD2,IDMOD3, 3282 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 3283 1 IFOUND,IERROR) 3284 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3285C 3286 CALL DPDEFT(IHARG,IARGT,IARG,NUMARG, 3287 1 IDEFFN,NUMDEV,MAXDEV, 3288 1 IDMANU,IDMODE,IDMOD2,IDMOD3,IDPOWE, 3289 1 IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT, 3290 1 IFOUND,IERROR) 3291 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3292C 3293 CALL DPDESC(IHARG,IARGT,IARG,ARG,NUMARG, 3294 1 NUMDEV,MAXDEV, 3295 1 IDMANU,IDMODE,IDMOD2,IDMOD3,IDPOWE, 3296 1 IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT, 3297 1 PDSCAL, 3298 1 IFOUND,IERROR) 3299 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3300C 3301 CALL DPDEMN(IHARG,IHARG2,IARGT,IARG,NUMARG, 3302 1 IPL1NU,IPL1NA, 3303 1 IPL2NU,IPL2NA, 3304 1 IPL1CS,IPL2CS, 3305 1 IDEFMA,IDEFMO,IDEFM2,IDEFM3, 3306 1 IDEFPO,IDEFCN,IDEFDC,IDEFVP,IDEFHP,IDEFUN, 3307 1 NUMDEV,MAXDEV, 3308 1 IDMANU,IDMODE,IDMOD2,IDMOD3, 3309 1 IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT, 3310 1 IDNVOF,IDNHOF, 3311 1 ICAPSW,ICAPNU, 3312 1 IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR) 3313 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3314 ENDIF 3315C 3316CCCCC THE FOLLOWING SECTION WAS INSERTED BY ALAN. FEBRUARY 1989 3317CCCCC MAY, 1990. DISTINGUISH BETWEEN ON/OFF AND OPEN/CLOSE 3318C ***************************************************** 3319C ** TREAT THE DEVICE ... ON/OFF (OR OPEN/CLOSE) CASE* 3320C ***************************************************** 3321C 3322 IF(NUMARG.GE.1)THEN 3323 IF((ICOM.EQ.'DEVI'.OR.ICOM.EQ.'TERM').AND.NUMARG.GE.1.AND. 3324 1 IHARG(NUMARG).EQ.'OFF')THEN 3325 IOP='OFF' 3326 ELSEIF((ICOM.EQ.'DEVI'.OR.ICOM.EQ.'TERM').AND.NUMARG.GE.1.AND. 3327 1 IHARG(NUMARG).EQ.'CLOS')THEN 3328 IOP='CLOS' 3329 ELSEIF((ICOM.EQ.'DEVI'.OR.ICOM.EQ.'TERM').AND.NUMARG.GE.1.AND. 3330 1 IHARG(NUMARG).EQ.'ON')THEN 3331 IOP='ON' 3332 ELSEIF((ICOM.EQ.'DEVI'.OR.ICOM.EQ.'TERM').AND.NUMARG.GE.1.AND. 3333 1 IHARG(NUMARG).EQ.'OPEN')THEN 3334 IOP='OPEN' 3335 ELSE 3336 GOTO1799 3337 ENDIF 3338C 3339 IF(NUMARG.LE.1)THEN 3340 ISHIFT=1 3341 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 3342 1 IBUGO2,IERROR) 3343 IHARG(1)='1 ' 3344 IHARG2(1)=' ' 3345 IARGT(1)='NUMB' 3346 IARG(1)=1 3347 ELSE 3348 ISHIFT=1 3349 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 3350 1 IBUGO2,IERROR) 3351 IHARG(1)=IHARG(2) 3352 IHARG2(1)=IHARG2(2) 3353 IARGT(1)=IARGT(2) 3354 IARG(1)=IARG(2) 3355 ENDIF 3356C 3357 IHARG(2)='POWE' 3358 IHARG2(2)='ER ' 3359 IARGT(2)='WORD' 3360 IHARG(3)=IOP 3361 IHARG2(3)=' ' 3362 IARGT(3)='WORD' 3363 NUMARG=3 3364 CALL DPDEPW(IHARG,IHARG2,IARGT,IARG,NUMARG, 3365 1 IPL1NU,IPL1NA, 3366 1 IPL2NU,IPL2NA, 3367 1 IDEFPO, 3368 1 NUMDEV,MAXDEV, 3369 1 IDMANU,IDMODE,IDMOD2,IDMOD3, 3370 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 3371 1 IDNVOF,IDNHOF, 3372 1 ICAPSW,ICAPNU, 3373 1 IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR) 3374 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3375C 3376 ENDIF 3377C 3378 1799 CONTINUE 3379C 3380C **************************** 3381C ** TREAT THE POWER CASE ** 3382C **************************** 3383C 3384CCCCC MAY 1995. CHECK NAME CONFLICTS 3385 IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'NORM')GOTO9000 3386 IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'LOGN')GOTO9000 3387 IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'EXPO')GOTO9000 3388 IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'LOG ')GOTO9000 3389 IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'FUNC')GOTO9000 3390 IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'PROB')GOTO9000 3391 IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'PPCC')GOTO9000 3392 IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'MAXI')GOTO9000 3393 IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'MLE ')GOTO9000 3394 IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'KS ')GOTO9000 3395 IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'KOLM')GOTO9000 3396 IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'LAW ')GOTO9000 3397 IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'CHI ')GOTO9000 3398 IF(ICOM.EQ.'POWE'.AND.IHARG(1).EQ.'CHIS')GOTO9000 3399C 3400 IF(ICOM.EQ.'POWE')THEN 3401 ISHIFT=2 3402 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 3403 1 IBUGO2,IERROR) 3404 IHARG(1)='1 ' 3405 IHARG2(1)=' ' 3406 IARGT(1)='NUMB' 3407 IARG(1)=1 3408 IHARG(2)=ICOM 3409 IHARG2(2)=ICOM2 3410 IARGT(2)='WORD' 3411 CALL DPDEPW(IHARG,IHARG2,IARGT,IARG,NUMARG, 3412 1 IPL1NU,IPL1NA,IPL2NU,IPL2NA, 3413 1 IDEFPO, 3414 1 NUMDEV,MAXDEV, 3415 1 IDMANU,IDMODE,IDMOD2,IDMOD3, 3416 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 3417 1 IDNVOF,IDNHOF, 3418 1 ICAPSW,ICAPNU, 3419 1 IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR) 3420 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3421 ENDIF 3422C 3423C ********************************* 3424C ** TREAT THE CONTINUITY CASE ** 3425C ********************************* 3426C 3427 IF((ICOM.EQ.'CONT'.AND.ICOM2.EQ.'INUO') .OR. 3428 1 (ICOM.EQ.'CONT'.AND.ICOM2.EQ.'INUI'))THEN 3429 ISHIFT=2 3430 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 3431 1 IBUGO2,IERROR) 3432 IHARG(1)='1 ' 3433 IHARG2(1)=' ' 3434 IARGT(1)='NUMB' 3435 IARG(1)=1 3436 IHARG(2)=ICOM 3437 IHARG2(2)=ICOM2 3438 IARGT(2)='WORD' 3439 CALL DPDECN(IHARG,IARGT,IARG,NUMARG, 3440 1 IDEFCN, 3441 1 NUMDEV,MAXDEV, 3442 1 IDMANU,IDMODE,IDMOD2,IDMOD3, 3443 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 3444 1 IFOUND,IERROR) 3445 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3446 ENDIF 3447C 3448C **************************** 3449C ** TREAT THE COLOR CASE ** 3450C **************************** 3451C 3452 IF(ICOM.EQ.'COLO')THEN 3453 ISHIFT=2 3454 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 3455 1 IBUGO2,IERROR) 3456 IHARG(1)='1 ' 3457 IHARG2(1)=' ' 3458 IARGT(1)='NUMB' 3459 IARG(1)=1 3460 IHARG(2)=ICOM 3461 IHARG2(2)=ICOM2 3462 IARGT(2)='WORD' 3463 CALL DPDECL(IHARG,IARGT,IARG,NUMARG, 3464 1 IDEFDC, 3465 1 NUMDEV,MAXDEV, 3466 1 IDMANU,IDMODE,IDMOD2,IDMOD3, 3467 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 3468 1 IFOUND,IERROR) 3469 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3470 ENDIF 3471C 3472C ************************************* 3473C ** TREAT THE PICTURE POINTS CASE ** 3474C ************************************* 3475C 3476 IF(ICOM.EQ.'PICT' .OR. ICOM.EQ.'PP')THEN 3477 ISHIFT=2 3478 IF(ICOM.EQ.'PP')ISHIFT=3 3479 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 3480 1 IBUGO2,IERROR) 3481 IHARG(1)='1 ' 3482 IHARG2(1)=' ' 3483 IARGT(1)='NUMB' 3484 IARG(1)=1 3485 IHARG(2)='PICT' 3486 IHARG2(2)='TURE' 3487 IARGT(2)='WORD' 3488 IF(ICOM.EQ.'NE')THEN 3489 IHARG(3)='POIN' 3490 IHARG2(3)='TS ' 3491 IARGT(3)='WORD' 3492 ENDIF 3493 CALL DPDEPP(IHARG,IARGT,IARG,NUMARG, 3494 1 IDEFVP,IDEFHP, 3495 1 NUMDEV,MAXDEV, 3496 1 IDMANU,IDMODE,IDMOD2,IDMOD3, 3497 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 3498 1 IFOUND,IERROR) 3499 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3500 ENDIF 3501C 3502C ************************************* 3503C ** TREAT THE UNIT NUMBER CASE ** 3504C ************************************* 3505C 3506 IF(ICOM.EQ.'UNIT')THEN 3507 ISHIFT=2 3508 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 3509 1 IBUGO2,IERROR) 3510 IHARG(1)='1 ' 3511 IHARG2(1)=' ' 3512 IARGT(1)='NUMB' 3513 IARG(1)=1 3514 IHARG(2)=ICOM 3515 IHARG2(2)=ICOM2 3516 IARGT(2)='WORD' 3517 CALL DPDEUN(IHARG,IARGT,IARG,NUMARG, 3518 1 IDEFUN, 3519 1 NUMDEV,MAXDEV, 3520 1 IDMANU,IDMODE,IDMOD2,IDMOD3, 3521 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 3522 1 IFOUND,IERROR) 3523 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3524 ENDIF 3525C 3526C ********************************************* 3527C ** TREAT THE EXPLICIT MANUFACTURER CASE ** 3528C ** (FOR A SUBSET OF AVAILABLE TERMINALS) ** 3529C ********************************************* 3530C 3531 IF(ICOM.EQ.'TEKT'.AND.IHARG(1).NE.'META')GOTO3600 3532 IF(ICOM.EQ.'HEWL')GOTO3600 3533 IF(ICOM.EQ.'HP')GOTO3600 3534 IF(ICOM.EQ.'HPGL')GOTO3600 3535 IF(ICOM.EQ.'RAMT')GOTO3600 3536 IF(ICOM.EQ.'TELE')GOTO3600 3537 IF(ICOM.EQ.'VT')GOTO3600 3538 IF(ICOM.EQ.'DEC')GOTO3600 3539CCCCC MAY, 1994. CHECK FOR CONFLICT WITH REGION COMMAND. 3540CCCCC IF(ICOM.EQ.'REGI')GOTO3600 3541 IF(ICOM.EQ.'REGI'.AND.ICOM2.EQ.'S ')GOTO3600 3542 IF(ICOM.EQ.'RAMT')GOTO3600 3543CCCCC THE FOLLOWING 5 LINES WERE ADDED BY ALAN. FEBRUARY 1989 3544 IF(ICOM.EQ.'SUN')GOTO3600 3545 IF(ICOM.EQ.'PCL')GOTO3600 3546 IF(ICOM.EQ.'POST')GOTO3600 3547CCCCC MARCH 1995. ADD FOLLOWING 3 LINES 3548 IF(ICOM.EQ.'ENCA')THEN 3549 IF(IHARG(1).EQ.'POST'.OR.IHARG(1).EQ.'PS')THEN 3550 ICOM='POST' 3551 IHARG(1)='ENCA' 3552 ELSE 3553 ISHIFT=1 3554 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 3555 1 IBUGO2,IERROR) 3556 ICOM='POST' 3557 IHARG(1)='ENCA' 3558 IHARG2(1)=' ' 3559 IARGT(1)='WORD' 3560 ENDIF 3561 GOTO3600 3562 ENDIF 3563CCCCC OCTOBER 1996. ADD FOLLOWING LINES 3564 IF(ICOM.EQ.'DISP')THEN 3565 IF(IHARG(1).EQ.'POST'.OR.IHARG(1).EQ.'PS')THEN 3566 ICOM='POST' 3567 IHARG(1)='DISP' 3568 GOTO3600 3569 ENDIF 3570 ENDIF 3571C 3572 IF(ICOM.EQ.'PS ')THEN 3573 ICOM='POST' 3574 GOTO3600 3575 ENDIF 3576 IF(ICOM.EQ.'EPS ')THEN 3577 IF(IHARG(1).EQ.'POST')THEN 3578 ICOM='POST' 3579 IHARG(1)='ENCA' 3580 ELSE 3581 ISHIFT=1 3582 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 3583 1 IBUGO2,IERROR) 3584 ICOM='POST' 3585 IHARG(1)='ENCA' 3586 IHARG2(1)=' ' 3587 IARGT(1)='WORD' 3588 ENDIF 3589 GOTO3600 3590 ENDIF 3591C 3592 IF(ICOM.EQ.'DICO')GOTO3600 3593 IF((ICOM.EQ.'QUIC'.AND.ICOM2.EQ.'KWIN').OR. 3594 1 (ICOM.EQ.'QUIC'.AND.ICOM2.EQ.'K-WI').OR. 3595 1 (ICOM.EQ.'MS'.AND.IHARG(1).EQ.'WIND').OR. 3596 1 (ICOM.EQ.'MICR'.AND.IHARG(1).EQ.'WIND'))THEN 3597 ICOM='QWIN' 3598 IHARG(1)=' ' 3599 IARGT(1)='WORD' 3600 GOTO3600 3601 ENDIF 3602 IF(ICOM.EQ.'QUIC')GOTO3600 3603CCCCC FOLLOWING LINE ADDED MARCH 1990 BY ALAN. 3604 IF(ICOM.EQ.'X11 ')GOTO3600 3605CCCCC FOLLOWING 2 LINES ADDED FOR CONFLICT WITH DISCRET UNIFORM 3606CCCCC PROBABILITY PLOT. SEPTEMBER 1994. 3607 IF(NUMARG.GE.2.AND.ICOM.EQ.'DISC'.AND.IHARG(1).EQ.'UNIF')GOTO9000 3608 IF(NUMARG.GE.2.AND.ICOM.EQ.'DISC'.AND.IHARG(1).EQ.'PROB')GOTO9000 3609 IF(NUMARG.GE.2.AND.ICOM.EQ.'DISC'.AND.IHARG(1).EQ.'ARCS')GOTO9000 3610 IF(NUMARG.GE.2.AND.ICOM.EQ.'DISC'.AND.IHARG(1).EQ.'WEIB')GOTO9000 3611 IF(NUMARG.GE.2.AND.ICOM.EQ.'DISC'.AND.IHARG(1).EQ.'CONT'.AND. 3612 1 IHARG(2).EQ.'PLOT')GOTO9000 3613 IF(ICOM.EQ.'DISC')GOTO3600 3614CCCCC NOVEMBER 2008: CHECK FOR CONFLICT WITH "BATCH STRIP PLOT" 3615 IF(NUMARG.GE.2.AND.ICOM.EQ.'BATC'.AND.IHARG(1).EQ.'STRI'.AND. 3616 1 IHARG(2).EQ.'PLOT')GOTO9000 3617 IF(NUMARG.GE.3.AND.ICOM.EQ.'BATC'.AND.IHARG(1).EQ.'MULT'.AND. 3618 1 IHARG(2).EQ.'STRI'.AND.IHARG(3).EQ.'PLOT')GOTO9000 3619 IF(ICOM.EQ.'BATC')GOTO3600 3620CCCCC SEPTEMBER 1997. CHECK FOR CONFLICT WITH ANDERSON DARLING TEST 3621CCCCC IF(ICOM.EQ.'ANDE')GOTO3600 3622 IF(ICOM.EQ.'ANDE')THEN 3623 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DARL')GOTO9000 3624 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')GOTO9000 3625 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'NORM')GOTO9000 3626 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'WEIB')GOTO9000 3627 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'EXPO')GOTO9000 3628 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LOGI')GOTO9000 3629 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'EXPO')GOTO9000 3630 GOTO3600 3631 ENDIF 3632 IF(ICOM.EQ.'AJ')GOTO3600 3633 IF(ICOM.EQ.'HAZE')GOTO3600 3634 IF(ICOM.EQ.'OMRO')GOTO3600 3635 IF(ICOM.EQ.'TERM'.AND.ICOM2.EQ.'INET')GOTO3600 3636 IF(ICOM.EQ.'TEXA')GOTO3600 3637 IF(ICOM.EQ.'TI')GOTO3600 3638CCCCC THE FOLLOWING 4 LINES WERE ADDED MAY 1991 (JJF) 3639 3640 IF(ICOM.EQ.'TURB')GOTO3600 3641 IF(ICOM.EQ.'TC')GOTO3600 3642 IF(ICOM.EQ.'VGA')GOTO3600 3643 IF(ICOM.EQ.'EGA')GOTO3600 3644 IF(ICOM.EQ.'LAHE ')THEN 3645 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'INTE')THEN 3646 ICOM='INTE' 3647 IHARG(1)=' ' 3648 NUMARG=0 3649 ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'WINT')THEN 3650 ICOM='WINT' 3651 IHARG(1)=' ' 3652 NUMARG=0 3653 ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'WIN '.AND. 3654 1 IHARG(2).EQ.'INTE')THEN 3655 ICOM='WINT' 3656 IHARG(1)=' ' 3657 IHARG(2)=' ' 3658 NUMARG=0 3659 ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'WIND'.AND. 3660 1 IHARG(2).EQ.'INTE')THEN 3661 ICOM='WINT' 3662 IHARG(1)=' ' 3663 IHARG(2)=' ' 3664 NUMARG=0 3665 ELSE 3666 ISHIFT=1 3667 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 3668 1 IBUGO2,IERROR) 3669 ICOM='POST' 3670 IHARG(1)='ENCA' 3671 IHARG2(1)=' ' 3672 IARGT(1)='WORD' 3673 ENDIF 3674 GOTO3600 3675 ENDIF 3676C 3677 IF(ICOM.EQ.'GKS ')GOTO3600 3678 IF(ICOM.EQ.'GD ')GOTO3600 3679 IF(ICOM.EQ.'SVG ')GOTO3600 3680 IF(ICOM.EQ.'OPEN'.AND.ICOM2.EQ.'GL ')THEN 3681 ICOM='OPGL' 3682 GOTO3600 3683 ENDIF 3684 IF(ICOM.EQ.'OPEN'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'GL ')THEN 3685 ICOM='OPGL' 3686 ISHIFT=1 3687 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 3688 1 IBUGO2,IERROR) 3689 GOTO3600 3690 ENDIF 3691C 3692 GOTO3699 3693C 3694 3600 CONTINUE 3695C 3696 ISHIFT=2 3697 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 3698 1IBUGO2,IERROR) 3699 IHARG(1)='1 ' 3700 IHARG2(1)=' ' 3701 IARGT(1)='NUMB' 3702 IARG(1)=1 3703 IHARG(2)=ICOM 3704 IHARG2(2)=ICOM2 3705 IARGT(2)='WORD' 3706CCCCC OCTOBER 1993. FIX BUG WHERE DISCRETE ON, BATCH ON ACT 3707CCCCC LIKE DISCRETE OFF, ETC. STRIP OFF ON ARGUMENT. 3708 IF(IHARG(2).EQ.'DISC'.OR.IHARG(2).EQ.'BATC')THEN 3709 IF(NUMARG.GE.3.AND.IHARG(NUMARG).EQ.'ON')THEN 3710 IHARG(NUMARG)=' ' 3711 NUMARG=NUMARG-1 3712 ENDIF 3713 ENDIF 3714CCCCC END CHANGE 3715 CALL DPDEMN(IHARG,IHARG2,IARGT,IARG,NUMARG, 3716 1IPL1NU,IPL1NA, 3717 1IPL2NU,IPL2NA, 3718 1IPL1CS,IPL2CS, 3719 1IDEFMA,IDEFMO,IDEFM2,IDEFM3, 3720 1IDEFPO,IDEFCN,IDEFDC,IDEFVP,IDEFHP,IDEFUN, 3721 1NUMDEV,MAXDEV, 3722 1IDMANU,IDMODE,IDMOD2,IDMOD3, 3723 1IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT, 3724 1IDNVOF,IDNHOF, 3725 1ICAPSW,ICAPNU, 3726 1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR) 3727 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3728C 3729 3699 CONTINUE 3730C 3731C ********************************************* 3732C ** TREAT THE DISCRETE CASE ** 3733C ** TREAT THE DISCRETE NARROW-WIDTH CASE ** 3734C ** TREAT THE DISCRETE WIDE-CARRIAGE CASE ** 3735C ** TREAT THE BATCH CASE ** 3736C ********************************************* 3737C 3738 IF(ICOM.EQ.'DISC')GOTO4100 3739 IF(ICOM.EQ.'BATC')GOTO4100 3740 GOTO4199 3741C 3742 4100 CONTINUE 3743 ISHIFT=3 3744 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 3745 1IBUGO2,IERROR) 3746 IHARG(1)='1 ' 3747 IHARG2(1)=' ' 3748 IARGT(1)='NUMB' 3749 IARG(1)=1 3750 IHARG(2)='MANU' 3751 IHARG2(2)='FACT' 3752 IARGT(2)='WORD' 3753 IHARG(3)=ICOM 3754 IHARG2(3)=ICOM2 3755 IARGT(3)='WORD' 3756CCCCC OCTOBER 1993. FIX BUG WHERE DISCRETE ON, BATCH ON ACT 3757CCCCC LIKE DISCRETE OFF, ETC. STRIP OFF ON ARGUMENT. 3758 IF(IHARG(2).EQ.'DISC'.OR.IHARG(2).EQ.'BATC')THEN 3759 IF(NUMARG.GE.3.AND.IHARG(NUMARG).EQ.'ON')THEN 3760 IHARG(NUMARG)=' ' 3761 NUMARG=NUMARG-1 3762 ENDIF 3763 ENDIF 3764CCCCC END CHANGE 3765 CALL DPDEMN(IHARG,IHARG2,IARGT,IARG,NUMARG, 3766 1IPL1NU,IPL1NA, 3767 1IPL2NU,IPL2NA, 3768 1IPL1CS,IPL2CS, 3769 1IDEFMA,IDEFMO,IDEFM2,IDEFM3, 3770 1IDEFPO,IDEFCN,IDEFDC,IDEFVP,IDEFHP,IDEFUN, 3771 1NUMDEV,MAXDEV, 3772 1IDMANU,IDMODE,IDMOD2,IDMOD3, 3773 1IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT, 3774 1IDNVOF,IDNHOF, 3775 1ICAPSW,ICAPNU, 3776 1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR) 3777 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3778C 3779 4199 CONTINUE 3780C 3781C 3782C ********************************* 3783C ** TREAT THE PENPLOTTER CASE ** 3784C ********************************* 3785C 3786 IF(ICOM.EQ.'PENP')GOTO4200 3787 GOTO4299 3788C 3789 4200 CONTINUE 3790 IF(NUMARG.LE.0)IOP='ON' 3791 IF(NUMARG.GE.1)IOP=IHARG(1) 3792 IF(IOP.EQ.'OPEN')IOP='ON' 3793 IF(IOP.EQ.'AUTO')IOP='ON' 3794 IF(IOP.EQ.'DEFA')IOP='ON' 3795 IF(IOP.EQ.'CLOS')IOP='OFF' 3796C 3797 ISHIFT=2 3798 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 3799 1IBUGO2,IERROR) 3800 IHARG(1)='1 ' 3801 IHARG2(1)=' ' 3802 IARGT(1)='NUMB' 3803 IARG(1)=1 3804C 3805 IF(IOP.EQ.'ON')GOTO4210 3806 GOTO4220 3807C 3808 4210 CONTINUE 3809 IHARG(2)='MANU' 3810 IHARG2(2)='FACT' 3811 IARGT(2)='WORD' 3812 IHARG(3)='TEKT' 3813 IHARG2(3)='RONI' 3814 IARGT(3)='WORD' 3815 IHARG(4)='4662' 3816 IHARG2(I)=' ' 3817 IARGT(4)='WORD' 3818 NUMARG=4 3819 CALL DPDEMN(IHARG,IHARG2,IARGT,IARG,NUMARG, 3820 1IPL1NU,IPL1NA, 3821 1IPL2NU,IPL2NA, 3822 1IPL1CS,IPL2CS, 3823 1IDEFMA,IDEFMO,IDEFM2,IDEFM3, 3824 1IDEFPO,IDEFCN,IDEFDC,IDEFVP,IDEFHP,IDEFUN, 3825 1NUMDEV,MAXDEV, 3826 1IDMANU,IDMODE,IDMOD2,IDMOD3, 3827 1IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT, 3828 1IDNVOF,IDNHOF, 3829 1ICAPSW,ICAPNU, 3830 1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR) 3831 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3832 GOTO4299 3833C 3834 4220 CONTINUE 3835 IHARG(2)='POWE' 3836 IHARG2(2)='R ' 3837 IARGT(2)='WORD' 3838 IHARG(3)='OFF ' 3839 IHARG2(3)=' ' 3840 IARGT(3)='WORD' 3841 NUMARG=3 3842 CALL DPDEPW(IHARG,IHARG2,IARGT,IARG,NUMARG, 3843 1IPL1NU,IPL1NA, 3844 1IPL2NU,IPL2NA, 3845 1IDEFPO, 3846 1NUMDEV,MAXDEV, 3847 1IDMANU,IDMODE,IDMOD2,IDMOD3, 3848 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 3849 1IDNVOF,IDNHOF, 3850 1ICAPSW,ICAPNU, 3851 1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR) 3852 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3853 GOTO4299 3854C 3855 4299 CONTINUE 3856C 3857C ******************************* 3858C ** TREAT THE HARDCOPY CASE ** 3859C ******************************* 3860C 3861 IF(ICOM.EQ.'HARD')GOTO4300 3862 GOTO4399 3863C 3864 4300 CONTINUE 3865 CALL DPHAPW(IHARG,IHARG2,IARGT,IARG,NUMARG, 3866 1 ICOPSW,NUMCOP, 3867 1 IBUGO2,ISUBRO,IFOUND,IERROR) 3868 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3869C 3870 4399 CONTINUE 3871C 3872C ****************************** 3873C ** TREAT THE FILE CASE ** 3874C ** TREAT THE CALCOMP CASE ** 3875C ** TREAT THE VERSATEC CASE ** 3876C ** TREAT THE ZETA CASE ** 3877C ****************************** 3878C 3879 IF(ICOM.EQ.'TEKT'.AND.IHARG(1).EQ.'META')GOTO5100 3880 IF(ICOM.EQ.'CALC')GOTO5100 3881 IF(ICOM.EQ.'VERS')GOTO5100 3882 IF(ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'CHI ')GOTO9000 3883 IF(ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'CHIS')GOTO9000 3884 IF(ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'KS ')GOTO9000 3885 IF(ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'KOLM')GOTO9000 3886 IF(ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'PROB')GOTO9000 3887 IF(ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'PPCC')GOTO9000 3888 IF(ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'MLE ')GOTO9000 3889 IF(ICOM.EQ.'ZETA'.AND.IHARG(1).EQ.'MAXI')GOTO9000 3890 IF(ICOM.EQ.'ZETA')GOTO5100 3891 GOTO5199 3892C 3893 5100 CONTINUE 3894 IDMANU(1)=ICOM 3895 IDMODE(1)=' ' 3896 IDMOD2(1)=' ' 3897 IDMOD3(1)=' ' 3898 IF(NUMARG.LE.0)IOP='ON' 3899 IF(NUMARG.GE.1)IOP=IHARG(1) 3900 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'META')IOP='ON' 3901 IF(IOP.EQ.'OPEN')IOP='ON' 3902 IF(IOP.EQ.'AUTO')IOP='ON' 3903 IF(IOP.EQ.'DEFA')IOP='ON' 3904 IF(IOP.EQ.'CLOS')IOP='OFF' 3905C 3906 ISHIFT=2 3907 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 3908 1IBUGO2,IERROR) 3909 IHARG(1)='2 ' 3910 IHARG2(1)=' ' 3911 IARGT(1)='NUMB' 3912 IARG(1)=2 3913C 3914 IF(IOP.EQ.'ON')GOTO5110 3915 GOTO5120 3916C 3917 5110 CONTINUE 3918 IHARG(2)='MANU' 3919 IHARG2(2)='FACT' 3920 IARGT(2)='WORD' 3921 IHARG(3)=IDMANU(1) 3922 IHARG2(3)=' ' 3923 IARGT(3)='WORD' 3924 IHARG(4)=IDMODE(1) 3925 IHARG2(4)=' ' 3926 IARGT(4)='WORD' 3927 IHARG(5)=IDMOD2(1) 3928 IHARG2(5)=' ' 3929 IARGT(5)='WORD' 3930 IHARG(6)=IDMOD3(1) 3931 IHARG2(6)=' ' 3932 IARGT(6)='WORD' 3933 NUMARG=6 3934 CALL DPDEMN(IHARG,IHARG2,IARGT,IARG,NUMARG, 3935 1IPL1NU,IPL1NA, 3936 1IPL2NU,IPL2NA, 3937 1IPL1CS,IPL2CS, 3938 1IDEFMA,IDEFMO,IDEFM2,IDEFM3, 3939 1IDEFPO,IDEFCN,IDEFDC,IDEFVP,IDEFHP,IDEFUN, 3940 1NUMDEV,MAXDEV, 3941 1IDMANU,IDMODE,IDMOD2,IDMOD3, 3942 1IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT, 3943 1IDNVOF,IDNHOF, 3944 1ICAPSW,ICAPNU, 3945 1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR) 3946 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3947 GOTO5199 3948C 3949 5120 CONTINUE 3950 IHARG(2)='POWE' 3951 IHARG2(2)='R ' 3952 IARGT(2)='WORD' 3953 IHARG(3)='OFF ' 3954 IHARG2(3)=' ' 3955 IARGT(3)='WORD' 3956 NUMARG=3 3957 CALL DPDEPW(IHARG,IHARG2,IARGT,IARG,NUMARG, 3958 1IPL1NU,IPL1NA, 3959 1IPL2NU,IPL2NA, 3960 1IDEFPO, 3961 1NUMDEV,MAXDEV, 3962 1IDMANU,IDMODE,IDMOD2,IDMOD3, 3963 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 3964 1IDNVOF,IDNHOF, 3965 1ICAPSW,ICAPNU, 3966 1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR) 3967 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 3968 GOTO5199 3969C 3970 5199 CONTINUE 3971C 3972C ****************************** 3973C ** TREAT THE GENERAL METAFILE CASE ** 3974C ****************************** 3975C 3976 IF(ICOM.EQ.'META')GOTO5200 3977 IF(ICOM.EQ.'GENE'.AND.IHARG(1).EQ.'META')GOTO5200 3978 GOTO5299 3979C 3980 5200 CONTINUE 3981 IF(NUMARG.LE.0)IOP='ON' 3982 IF(NUMARG.GE.1)IOP=IHARG(1) 3983 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'META')IOP='ON' 3984 IF(IOP.EQ.'OPEN')IOP='ON' 3985 IF(IOP.EQ.'AUTO')IOP='ON' 3986 IF(IOP.EQ.'DEFA')IOP='ON' 3987 IF(IOP.EQ.'CLOS')IOP='OFF' 3988C 3989 ISHIFT=2 3990 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 3991 1IBUGO2,IERROR) 3992 IHARG(1)='3 ' 3993 IHARG2(1)=' ' 3994 IARGT(1)='NUMB' 3995 IARG(1)=3 3996C 3997 IF(IOP.EQ.'ON')GOTO5210 3998 GOTO5220 3999C 4000 5210 CONTINUE 4001 IHARG(2)='MANU' 4002 IHARG2(2)='FACT' 4003 IARGT(2)='WORD' 4004 IHARG(3)='META' 4005 IHARG2(3)='FILE' 4006 IARGT(3)='WORD' 4007 NUMARG=3 4008 CALL DPDEMN(IHARG,IHARG2,IARGT,IARG,NUMARG, 4009 1IPL1NU,IPL1NA, 4010 1IPL2NU,IPL2NA, 4011 1IPL1CS,IPL2CS, 4012 1IDEFMA,IDEFMO,IDEFM2,IDEFM3, 4013 1IDEFPO,IDEFCN,IDEFDC,IDEFVP,IDEFHP,IDEFUN, 4014 1NUMDEV,MAXDEV, 4015 1IDMANU,IDMODE,IDMOD2,IDMOD3, 4016 1IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT, 4017 1IDNVOF,IDNHOF, 4018 1ICAPSW,ICAPNU, 4019 1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR) 4020 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4021 GOTO5299 4022C 4023 5220 CONTINUE 4024 IHARG(2)='POWE' 4025 IHARG2(2)='R ' 4026 IARGT(2)='WORD' 4027 IHARG(3)='OFF ' 4028 IHARG2(3)=' ' 4029 IARGT(3)='WORD' 4030 NUMARG=3 4031 CALL DPDEPW(IHARG,IHARG2,IARGT,IARG,NUMARG, 4032 1IPL1NU,IPL1NA, 4033 1IPL2NU,IPL2NA, 4034 1IDEFPO, 4035 1NUMDEV,MAXDEV, 4036 1IDMANU,IDMODE,IDMOD2,IDMOD3, 4037 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 4038 1IDNVOF,IDNHOF, 4039 1ICAPSW,ICAPNU, 4040 1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR) 4041 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4042 GOTO5299 4043C 4044 5299 CONTINUE 4045C 4046CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1992 (JJF) 4047C ********************************* 4048C ** TREAT THE BLANK PAGE CASE ** 4049C ********************************* 4050C 4051 IF(ICOM.EQ.'BLAN' .AND. IHARG(1).NE.'ALTM')THEN 4052 CALL DPBLPA(IHARG,NUMARG, 4053 1 IPSTBP,IFOUND,IERROR) 4054 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4055 ENDIF 4056C 4057C ***************************************** 4058C ** OUTPUT DEVICE COMMAND NOT FOUND-- ** 4059C ** BRANCH TO EXIT. ** 4060C ***************************************** 4061C 4062 GOTO9000 4063C 4064C ***************** 4065C ** STEP 90-- ** 4066C ** EXIT ** 4067C ***************** 4068C 4069 9000 CONTINUE 4070C 4071 IERRST=IERROR 4072C 4073C SEPTEMBER 2012. CHECK FOR FATAL ERROR 4074C 4075 IF(IERROR.EQ.'YES')THEN 4076 ICASE2='DEVI' 4077 CALL DPERRO(IERRFA,IANSLC,IWIDTH,IGUIFL, 4078 1 ISUBN1,ISUBN2,ICASE2, 4079 1 IBUGO2,ISUBRO,IERROR) 4080 ENDIF 4081C 4082C 4083 IF(IBUGOD.EQ.'ON'.OR.ISUBRO.EQ.'INOD')THEN 4084 WRITE(ICOUT,999) 4085 CALL DPWRST('XXX','BUG ') 4086 WRITE(ICOUT,9011) 4087 9011 FORMAT('***** AT THE END OF MAINOD--') 4088 CALL DPWRST('XXX','BUG ') 4089 WRITE(ICOUT,9020)IFOUND,IERROR 4090 9020 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 4091 CALL DPWRST('XXX','BUG ') 4092 ENDIF 4093C 4094 RETURN 4095 END 4096 SUBROUTINE MAINPC(IBUGPC,IBUGP2,IBUGQ,ISUBRO, 4097 1 IVGMSW,IHGMSW, 4098 1 IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9, 4099CCCCC ADD FOLLOWING LINE AUGUST 1999. 4100 1 IMPARG, 4101 1 PMXMIN,PMXMAX,PMYMIN,PMYMAX, 4102 1 IERASV, 4103 1 PWXMIS,PWXMAS,PWYMIS,PWYMAS, 4104CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1992 4105 1 BARHEF,BARWEF, 4106CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1992 4107 1 ITIAUT,IX1AUT,IX2AUT,IX3AUT,IY1AUT,IY2AUT, 4108 1 IFOUND,IERROR) 4109C 4110C PURPOSE--THIS IS SUBROUTING MAINPC. 4111C (THE PC AT THE END OF MAINPC STANDS FOR PLOT 4112C THIS SUBROUTINE SEARCHES FOR AND EXECUTES PLOT CONTROL CO 4113C THE PLOT CONTROL COMMANDS SEARCHED FOR BY MAINPC ARE AS F 4114C 4115C ARROW ... COLOR A COLOR 4116C ARROW ... COORDINATES 2 NUMBERS 4117C BACKGROUND COLOR A COLOR 4118C BELL ON/OFF 4119C BOX ... COLOR A COLOR 4120C BOX ... CORNER COORDINATES 4 NUMBERS 4121C CHARACTERS A LIST OF CHARA 4122C CHARACTER COLORS A LIST OF COLOR 4123C CHARACTER SIZES A LIST OF NUMBE 4124C CHARACTER FILL A LIST OF ON/OF 4125C EYE COORDINATES 3 NUMBERS 4126C ...FRAME ON/OFF 4127C ...FRAME COLOR A COLOR 4128C FRAME CORNER COORDINATES 4 NUMBERS 4129C WINDOW CORNER COORDINATES 4 NUMBERS 4130C ...GRID ON/OFF 4131C GRID COLOR A COLOR 4132C GRID PATTERN PATTERN 4133C ...LABEL A STRING OF CHA 4134C LABEL COLOR A COLOR 4135C LABEL SIZE A NUMBER 4136C LEGEND ... A STRING OF CHA 4137C LEGEND ... COLOR A COLOR 4138C LEGEND ... COORDINATES 2 NUMBERS 4139C LEGEND ... SIZE A NUMBER 4140C ...LIMITS 2 NUMBERS 4141C LINES A LIST OF LINE 4142C LINE COLORS A LIST OF COLOR 4143C LINE THICKNESSES A LIST OF THICK 4144C ...LOG ON/OFF 4145C MARGIN COLOR A COLOR 4146C ...MAXIMUM A NUMBER 4147C ...MINIMUM A NUMBER 4148C NEGATE ON/OFF 4149C ORIGIN COORDINATES 3 NUMBERS 4150C PEDESTAL ON/OFF 4151C PEDESTAL COLOR A COLOR 4152C PEDESTAL HEIGHT A NUMBER 4153C PRE-SORT ON/OFF 4154C SEGMENT ... COLOR A COLOR 4155C SEGMENT ... COORDINATES 2 NUMBERS 4156C SEQUENCE ON/OFF 4157C ...TIC ON/OFF 4158CCCCCC ...TIC COLOR A COLOR 4159CCCCCC ...TIC DECIMALS A NUMBER 4160CCCCCC ...TIC COORDINATES A LIST OF NUMBE 4161C ...TIC POSITION (JUSTIFICATION) INSIDE/OUTSIDE/ 4162C ...TIC SIZE A NUMBER 4163C ...TIC LABELS ON/OFF 4164C ...TIC LABEL COLOR A COLOR 4165C ...TIC LABEL SIZE A NUMBER 4166C TITLE A STRING OF CHA 4167C TITLE COLOR A COLOR 4168C TITLE SIZE A NUMBER 4169C VISIBLE ON/OFF 4170C 4171C BAR SWITCH A SERIES OF ON/ 4172C BAR WIDTH A SERIES OF NUM 4173C BAR BASE A SERIES OF NUM 4174C BAR BORDER COLOR A SERIES OF COL 4175C BAR BORDER THICKNESS A SERIES OF NUM 4176C BAR BORDER LINE A SERIES OF LIN 4177C BAR FILL SWITCH A SERIES OF ON/ 4178C BAR FILL COLOR A SERIES OF COL 4179C BAR PATTERN TYPE A SERIES OF PAT 4180C BAR PATTERN COLOR A SERIES OF COL 4181C BAR PATTERN SPACING A SERIES OF NUM 4182C BAR PATTERN THICKNESS A SERIES OF NUM 4183C BAR PATTERN LINE A SERIES OF LIN 4184C BAR TYPES A SERIES OF NUMBERS 4185C 4186C BAR EXPANSION FACTORS 2 NUMBERS 4187C 4188C REGION BASE A SERIES OF NUM 4189C REGION BORDER COLOR A SERIES OF COL 4190C REGION BORDER THICKNESS A SERIES OF NUM 4191C REGION BORDER LINE A SERIES OF LIN 4192C REGION FILL SWITCH A SERIES OF ON/ 4193C REGION FILL COLOR A SERIES OF COL 4194C REGION PATTERN TYPE A SERIES OF PAT 4195C REGION PATTERN COLOR A SERIES OF COL 4196C REGION PATTERN SPACING A SERIES OF NUM 4197C REGION PATTERN THICKNESS A SERIES OF NUM 4198C REGION PATTERN LINE A SERIES OF LIN 4199C 4200C TEXT BORDER COLOR A SERIES OF COL 4201C TEXT BORDER THICKNESS A SERIES OF NUM 4202C TEXT BORDER LINE A SERIES OF LIN 4203C TEXT FILL SWITCH A SERIES OF ON/ 4204C TEXT FILL COLOR A SERIES OF COL 4205C TEXT PATTERN TYPE A SERIES OF PAT 4206C TEXT PATTERN COLOR A SERIES OF COL 4207C TEXT PATTERN SPACING A SERIES OF NUM 4208C TEXT PATTERN THICKNESS A SERIES OF NUM 4209C TEXT PATTERN LINE A SERIES OF LIN 4210C 4211C MAJOR ...TIC MARK NUMBER A NUMBER 4212C MINOR ...TIC MARK NUMBER A NUMBER 4213C 4214C WRITTEN BY--JAMES J. FILLIBEN 4215C STATISTICAL ENGINEERING DIVISION 4216C INFORMATION TECHNOLOGY LABORATORY 4217C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 4218C GAITHERSBURG, MD 20899-8980 4219C PHONE--301-975-2855 4220C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 4221C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 4222C LANGUAGE--ANSI FORTRAN (1977) 4223C VERSION NUMBER--82.6 4224C ORIGINAL VERSION--SEPTEMBER 1980. 4225C UPDATED --MARCH 1981. 4226C UPDATED --APRIL 1981. 4227C UPDATED --AUGUST 1981. 4228C UPDATED --SEPTEMBER 1981. 4229C UPDATED --NOVEMBER 1981. 4230C UPDATED --MAY 1982. 4231C UPDATED --JULY 1986. 4232C UPDATED --SEPTEMBER 1988. 3D PROJECTION (ORTHOGRAP./PERSPECT.) 4233C UPDATED --SEPTEMBER 1988. INCLUDE DPCO3D.INC 4234C UPDATED --APRIL 1992. BAR EXPANSION FACTORS ... ... 4235C UPDATED --AUGUST 1992. ADD SWITCHES FOR AUTOMATIC 4236C UPDATED --SEPTEMBER 1993. CHAR*4 FOR AUTOMATIC SWITCHES 4237C UPDATED --AUGUST 1999. ARGUMENT LIST TO MAIPC2 4238C UPDATED --SEPTEMBER 2007. IERRST 4239C UPDATED --SEPTEMBER 2012. SET FATAL ERROR 4240C 4241C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 4242C 4243 CHARACTER*4 IBUGPC 4244 CHARACTER*4 IBUGP2 4245 CHARACTER*4 IBUGQ 4246 CHARACTER*4 ISUBRO 4247C 4248 CHARACTER*4 IVGMSW 4249 CHARACTER*4 IHGMSW 4250C 4251 CHARACTER*4 IMPSW 4252 CHARACTER*4 IERASV 4253C 4254CCCCC THE FOLLOWING 6 LINES WERE ADDED SEPTEMBER 1993 4255 CHARACTER*4 ITIAUT 4256 CHARACTER*4 IX1AUT 4257 CHARACTER*4 IX2AUT 4258 CHARACTER*4 IX3AUT 4259 CHARACTER*4 IY1AUT 4260 CHARACTER*4 IY2AUT 4261C 4262 CHARACTER*4 IFOUND 4263 CHARACTER*4 IERROR 4264C 4265 CHARACTER*4 ICASE2 4266 CHARACTER*4 ISUBN1 4267 CHARACTER*4 ISUBN2 4268C 4269C-----COMMON---------------------------------------------------------- 4270C 4271 INCLUDE 'DPCOPA.INC' 4272 INCLUDE 'DPCOHK.INC' 4273 INCLUDE 'DPCOPC.INC' 4274 INCLUDE 'DPCO3D.INC' 4275 INCLUDE 'DPCOSU.INC' 4276 INCLUDE 'DPCODA.INC' 4277 INCLUDE 'DPCOST.INC' 4278 INCLUDE 'DPCOP2.INC' 4279C 4280C-----START POINT----------------------------------------------------- 4281C 4282 IF(IBUGPC.EQ.'ON' .OR. ISUBRO.EQ.'INPC')THEN 4283 WRITE(ICOUT,999) 4284 999 FORMAT(1X) 4285 CALL DPWRST('XXX','BUG ') 4286 WRITE(ICOUT,51) 4287 51 FORMAT('***** AT THE BEGINNING OF MAINPC--') 4288 CALL DPWRST('XXX','BUG ') 4289 WRITE(ICOUT,53)IBUGPC,IBUGP2,ISUBRO,IANGLU 4290 53 FORMAT('IBUGPC,IBUGP2,ISUBRO,IANGLU = ',3(A4,2X),A4) 4291 CALL DPWRST('XXX','BUG ') 4292 WRITE(ICOUT,67)ICOM,ICOM2,NUMARG 4293 67 FORMAT('ICOM,ICOM2,NUMARG = ',2(A4,2X),I8) 4294 CALL DPWRST('XXX','BUG ') 4295 DO70I=1,NUMARG 4296 WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) 4297 71 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ', 4298 1 I8,3(2X,A4),2X,I8,G15.7) 4299 CALL DPWRST('XXX','BUG ') 4300 70 CONTINUE 4301 WRITE(ICOUT,81)IMPSW,IMPNR,IMPNC,IMPCO 4302 81 FORMAT('IMPSW,IMPNR,IMPNC,IMPCO = ',A4,3I8) 4303 CALL DPWRST('XXX','BUG ') 4304 WRITE(ICOUT,82)PMXMIN,PMXMAX,PMYMIN,PMYMAX 4305 82 FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4G15.7) 4306 CALL DPWRST('XXX','BUG ') 4307 WRITE(ICOUT,83)IERASV,I3DPRO,IERASW 4308 83 FORMAT('IERASV,I3DPRO,IERASW = ',2(A4,2X),A4) 4309 CALL DPWRST('XXX','BUG ') 4310 WRITE(ICOUT,84)PWXMIS,PWXMAS,PWYMIS,PWYMAS 4311 84 FORMAT('PWXMIS,PWXMAS,PWYMIS,PWYMAS = ',4G15.7) 4312 CALL DPWRST('XXX','BUG ') 4313 WRITE(ICOUT,86)PWXMIN,PWXMAX,PWYMIN,PWYMAX 4314 86 FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4G15.7) 4315 CALL DPWRST('XXX','BUG ') 4316 WRITE(ICOUT,87)PXMIN,PXMAX,PYMIN,PYMAX 4317 87 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4G15.7) 4318 CALL DPWRST('XXX','BUG ') 4319 ENDIF 4320C 4321 IFOUND='NO' 4322 IERROR='NO' 4323C 4324 CALL MAIPC1(IBUGPC,IBUGP2,IBUGQ,ISUBRO, 4325 1 IVGMSW,IHGMSW, 4326 1 IMPSW,IMPNR,IMPNC,IMPCO, 4327 1 PMXMIN,PMXMAX,PMYMIN,PMYMAX, 4328 1 IERASV,ICHAOF,ICHADY,ICHAVN, 4329 1 PWXMIS,PWXMAS,PWYMIS,PWYMAS, 4330CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1992 4331 1 IX1AUT,IX2AUT,IX3AUT,IY1AUT,IY2AUT, 4332 1 IFOUND,IERROR) 4333 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4334C 4335 CALL MAIPC2(IBUGPC,IBUGP2,ISUBRO, 4336 1 IVGMSW,IHGMSW, 4337 1 IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9, 4338CCCCC ADD FOLLOWING LINE AUGUST 1999. 4339 1 IMPARG, 4340 1 PMXMIN,PMXMAX,PMYMIN,PMYMAX, 4341 1 IERASV, 4342 1 PWXMIS,PWXMAS,PWYMIS,PWYMAS, 4343CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1992 4344 1 ITIAUT, 4345 1 IFOUND,IERROR) 4346 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4347C 4348 CALL MAIPC3(IBUGPC,IBUGP2,ISUBRO, 4349 1 IVGMSW,IHGMSW, 4350 1 IMPSW,IMPNR,IMPNC,IMPCO, 4351 1 PMXMIN,PMXMAX,PMYMIN,PMYMAX, 4352 1 IERASV, 4353 1 PWXMIS,PWXMAS,PWYMIS,PWYMAS, 4354CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1992 4355 1 BARHEF,BARWEF, 4356 1 IFOUND,IERROR) 4357 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4358C 4359 CALL MAIPC4(IBUGPC,IBUGP2,ISUBRO,IFOUND,IERROR) 4360 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4361C 4362C ***************** 4363C ** STEP 90-- ** 4364C ** EXIT ** 4365C ***************** 4366C 4367 9000 CONTINUE 4368C 4369 IERRST=IERROR 4370C 4371C SEPTEMBER 2012. CHECK FOR FATAL ERROR 4372C 4373 IF(IERROR.EQ.'YES')THEN 4374 ISUBN1='MAIN' 4375 ISUBN2='IN ' 4376 ICASE2='INPC' 4377 CALL DPERRO(IERRFA,IANSLC,IWIDTH,IGUIFL, 4378 1 ISUBN1,ISUBN2,ICASE2, 4379 1 IBUGP2,ISUBRO,IERROR) 4380 ENDIF 4381C 4382C 4383 IF(IBUGPC.EQ.'ON' .OR. ISUBRO.EQ.'INPC')THEN 4384 WRITE(ICOUT,999) 4385 CALL DPWRST('XXX','BUG ') 4386 WRITE(ICOUT,9031) 4387 9031 FORMAT('***** AT THE END OF MAINPC--') 4388 CALL DPWRST('XXX','BUG ') 4389 WRITE(ICOUT,9033)IFOUND,IERROR,IANGLU 4390 9033 FORMAT('IFOUND,IERROR,IANGLU = ',2(A4,2X),A4) 4391 CALL DPWRST('XXX','BUG ') 4392 WRITE(ICOUT,9041)IMPSW,IMPNR,IMPNC,IMPCO 4393 9041 FORMAT('IMPSW,IMPNR,IMPNC,IMPCO = ',A4,3I8) 4394 CALL DPWRST('XXX','BUG ') 4395 WRITE(ICOUT,9042)PMXMIN,PMXMAX,PMYMIN,PMYMAX 4396 9042 FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4G15.7) 4397 CALL DPWRST('XXX','BUG ') 4398 WRITE(ICOUT,9043)IERASV,I3DPRO,IERASW 4399 9043 FORMAT('IERASV,I3DPRO,IERASW = ',2(A4,2X),A4) 4400 CALL DPWRST('XXX','BUG ') 4401 WRITE(ICOUT,9044)PWXMIS,PWXMAS,PWYMIS,PWYMAS 4402 9044 FORMAT('PWXMIS,PWXMAS,PWYMIS,PWYMAS = ',4E15.7) 4403 CALL DPWRST('XXX','BUG ') 4404 WRITE(ICOUT,9046)PWXMIN,PWXMAX,PWYMIN,PWYMAX 4405 9046 FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4G15.7) 4406 CALL DPWRST('XXX','BUG ') 4407 WRITE(ICOUT,9047)PXMIN,PXMAX,PYMIN,PYMAX 4408 9047 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4G15.7) 4409 CALL DPWRST('XXX','BUG ') 4410CCCCC THE FOLLOWING 2 LINES WERE ADDED APRIL 1992 4411 WRITE(ICOUT,9048)BARHEF,BARWEF 4412 9048 FORMAT('BARHEF,BARWEF = ',2G15.7) 4413 CALL DPWRST('XXX','BUG ') 4414 ENDIF 4415 RETURN 4416 END 4417 SUBROUTINE MAIPC1(IBUGPC,IBUGP2,IBUGQ,ISUBRO, 4418 1 IVGMSW,IHGMSW, 4419 1 IMPSW,IMPNR,IMPNC,IMPCO, 4420 1 PMXMIN,PMXMAX,PMYMIN,PMYMAX, 4421 1 IERASV,ICHAOF,ICHADY,ICHAVN, 4422 1 PWXMIS,PWXMAS,PWYMIS,PWYMAS, 4423CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1992 4424 1 IX1AUT,IX2AUT,IX3AUT,IY1AUT,IY2AUT, 4425 1 IFOUND,IERROR) 4426C 4427C PURPOSE--THIS IS SUBROUTING MAIPC1. 4428C (THE PC AT THE END OF MAIPC1 STANDS FOR PLOT CONTROL 4429C THIS SUBROUTINE SEARCHES FOR AND EXECUTES 4430C PLOT CONTROL COMMANDS (PART 1). 4431C THE PLOT CONTROL COMMANDS SEARCHED FOR BY MAIPC1 ARE AS F 4432C 4433C WRITTEN BY--JAMES J. FILLIBEN 4434C STATISTICAL ENGINEERING DIVISION 4435C INFORMATION TECHNOLOGY LABORATORY 4436C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 4437C GAITHERSBURG, MD 20899-8980 4438C PHONE--301-975-2855 4439C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 4440C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 4441C LANGUAGE--ANSI FORTRAN (1977) 4442C VERSION NUMBER--82.6 4443C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--JULY 1986. 4444C UPDATED--JULY 1987 LEGEND HW 4445C UPDATED--FEBRUARY 1988 FURTHER RESOLVE CONFLICT--MIN VS MIN PLOT 4446C AND MAX VS MAX PLO 4447C UPDATED--MARCH 1988. FURTHER RESOLVE CONFLICT--MIN VS MIN PLOT 4448C AND MAX VS MAX PLO 4449C UPDATED--SEPTEMBER 1988. MOVE EYE/ORIGIN/PEDESTAL COMMANDS 4450C TO MAIPC4 FOR GENERAL 3-D. 4451C UPDATED --SEPTEMBER 1988. CHANGE 'BACK' TO 'BACKGROU' 4452C UPDATED --DECEMBER 1988. LABEL AND LEGEND DEFAULT WIDTH 4453C UPDATED --FEBRUARY 1989. ADD MANY ATTRIBUTE COMMANDS (ALAN) 4454C UPDATED --MAY 1989. DES. OF EXP. WIDTH/DEPTH/HOR. AXIS 4455C UPDATED --JULY 1989. ...LABEL DISPLACEMENT 4456C UPDATED --FEBRUARY 1992. FIX LEGEND DIRECTION CONFLICT 4457C UPDATED --APRIL 1992. IDEXHO TO IDEXHA 4458C UPDATED --AUGUST 1992. ADD SWITCHES FOR AUTOMATIC 4459C UPDATED --AUGUST 1992. BOX SHADOW HEIGHT/WIDTH 4460C UPDATED --AUGUST 1992. BOX FILL COLOR 4461C UPDATED --AUGUST 1992. BOX FILL PATTERN 4462C UPDATED --AUGUST 1992. BOX FILL THICK 4463C UPDATED --AUGUST 1992. BOX FILL GAP 4464C UPDATED --MARCH 1993. BUG IN CALL TO DPBOTH 4465C UPDATED --SEPTEMBER 1993. LOWER CASE LABELS 4466C UPDATED --SEPTEMBER 1993. LOWER CASE LEGENDS 4467C UPDATED --SEPTEMBER 1993. 3-D FRAME SWITCH 4468C UPDATED --SEPTEMBER 1993. CHAR*4 FOR AUTOMATIC SWITCHES 4469C UPDATED --OCTOBER 1993. BACKGROUND COLOR SETS THE 4470C MARGIN COLOR AS WELL 4471C UPDATED --DECEMBER 1994. EXACT CHARACTER MAPPING 4472C UPDATED --JANUARY 1995. FIX DEFAULT CHAR SIZE 4473C UPDATED --APRIL 1995. CHECK FOR COMMAND CONFLICT 4474C UPDATED --AUGUST 1995. SEGMENT PATTERN, FRAME PATTERN, 4475C BUG (DASH2, ETC) 4476C UPDATED --NOVEMBER 1997. CALL TO DPLIM 4477C UPDATED --JANUARY 1998. NAME CONFLICTS FOR MAXI, MINI 4478C UPDATED --FEBRUARY 1998. LINE/CHAR <SAVE/RESTORE> 4479C UPDATED --OCTOBER 1999. LABEL JUSTIFICIATION 4480C UPDATED --OCTOBER 1999. LABEL OFFSET 4481C UPDATED --DECEMBER 1999. LEGEND UNITS 4482C UPDATED --OCTOBER 2018. LABEL COORDINATES 4483C 4484C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 4485C 4486 CHARACTER*4 ICHADY 4487 CHARACTER*8 ICHAVN 4488 CHARACTER*4 IBUGPC 4489 CHARACTER*4 IBUGP2 4490 CHARACTER*4 IBUGQ 4491 CHARACTER*4 ISUBRO 4492C 4493 CHARACTER*4 IVGMSW 4494 CHARACTER*4 IHGMSW 4495 CHARACTER*4 IMPSW 4496 CHARACTER*4 IERASV 4497C 4498CCCCC THE FOLLOWING 5 LINES WERE ADDED SEPTEMBER 1993 4499 CHARACTER*4 IX1AUT 4500 CHARACTER*4 IX2AUT 4501 CHARACTER*4 IX3AUT 4502 CHARACTER*4 IY1AUT 4503 CHARACTER*4 IY2AUT 4504C 4505 CHARACTER*4 IFOUND 4506 CHARACTER*4 IERROR 4507C 4508C-----COMMON---------------------------------------------------------- 4509C 4510 INCLUDE 'DPCOPA.INC' 4511 INCLUDE 'DPCOHK.INC' 4512 INCLUDE 'DPCOPC.INC' 4513 INCLUDE 'DPCOSU.INC' 4514 INCLUDE 'DPCODA.INC' 4515CCCCC THE FOLLOWING DES. OF EXP. LINE WAS ADDED MAY 1989 4516 INCLUDE 'DPCODE.INC' 4517CCCCC THE FOLLOWING 3D LINE WAS ADDED SEPTEMBER 1993 4518 INCLUDE 'DPCO3D.INC' 4519 INCLUDE 'DPCOP2.INC' 4520C 4521C-----START POINT----------------------------------------------------- 4522C 4523 IF(IBUGPC.EQ.'ON' .OR. ISUBRO.EQ.'IPC1')THEN 4524 WRITE(ICOUT,999) 4525 999 FORMAT(1X) 4526 CALL DPWRST('XXX','BUG ') 4527 WRITE(ICOUT,51) 4528 51 FORMAT('***** AT THE BEGINNING OF MAIPC1--') 4529 CALL DPWRST('XXX','BUG ') 4530 WRITE(ICOUT,53)IBUGPC,IBUGP2,ISUBRO,IANGLU,IERASV 4531 53 FORMAT('IBUGPC,IBUGP2,ISUBRO,IANGLU,IERASV = ',4(A4,2X),A4) 4532 CALL DPWRST('XXX','BUG ') 4533 WRITE(ICOUT,67)ICOM,ICOM2,NUMARG 4534 67 FORMAT('ICOM,ICOM2,NUMARG = ',2(A4,2X),I8) 4535 CALL DPWRST('XXX','BUG ') 4536 WRITE(ICOUT,68)ICHADY,ICHAOF,ICHAVN 4537 68 FORMAT('ICHADY,ICHAOF,ICHAVN = ',2(A4,2X),A8) 4538 CALL DPWRST('XXX','BUG ') 4539 DO70I=1,NUMARG 4540 WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) 4541 71 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ', 4542 1 I8,3(2X,A4),2X,I8,G15.7) 4543 CALL DPWRST('XXX','BUG ') 4544 70 CONTINUE 4545 WRITE(ICOUT,81)IMPSW,IMPNR,IMPNC,IMPCO,IMPCO2 4546 81 FORMAT('IMPSW,IMPNR,IMPNC,IMPCO,IMPCO2 = ',A4,4I8) 4547 CALL DPWRST('XXX','BUG ') 4548 WRITE(ICOUT,82)PMXMIN,PMXMAX,PMYMIN,PMYMAX 4549 82 FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4G15.7) 4550 CALL DPWRST('XXX','BUG ') 4551 WRITE(ICOUT,84)PWXMIS,PWXMAS,PWYMIS,PWYMAS 4552 84 FORMAT('PWXMIS,PWXMAS,PWYMIS,PWYMAS = ',4G15.7) 4553 CALL DPWRST('XXX','BUG ') 4554 WRITE(ICOUT,86)PWXMIN,PWXMAX,PWYMIN,PWYMAX 4555 86 FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4G15.7) 4556 CALL DPWRST('XXX','BUG ') 4557 WRITE(ICOUT,87)PXMIN,PXMAX,PYMIN,PYMAX 4558 87 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4G15.7) 4559 CALL DPWRST('XXX','BUG ') 4560 WRITE(ICOUT,88)IVGMSW,IHGMSW 4561 88 FORMAT('IVGMSW,IHGMSW = ',A4,2X,A4) 4562 CALL DPWRST('XXX','BUG ') 4563 ENDIF 4564C 4565 IFOUND='NO' 4566 IERROR='NO' 4567C 4568C ******************************************** 4569C ** TREAT THE ARROW ... COLOR CASE ** 4570C ** ARROW ... PATTERN CASE ** 4571C ** ARROW ... THICKNESS CASE ** 4572C ** ARROW ... COORDINATES CASE ** 4573C ******************************************** 4574C 4575 IF(ICOM.EQ.'ARRO')THEN 4576 CALL DPARCL(IHARG,IARGT,IARG,NUMARG,IDEFCO, 4577 1 MAXARR,IARRCO,IFOUND,IERROR) 4578 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4579C 4580 CALL DPARPA(IHARG,IHARG2,IARGT,IARG,NUMARG,IDEFPA, 4581 1 MAXARR,IARRPA,IFOUND,IERROR) 4582 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4583C 4584 CALL DPARTH(IHARG,IARGT,IARG,ARG,NUMARG,PDEFTH, 4585 1 MAXARR,PARRTH,IFOUND,IERROR) 4586 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4587C 4588 CALL DPARCO(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 4589 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM, 4590 1 MAXNAM,IANS,IWIDTH, 4591 1 MAXARR,PARRXC,PARRYC,NUMARR,IBUGP2,IFOUND,IERROR) 4592 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4593C 4594 ENDIF 4595C 4596C *************************************** 4597C ** TREAT THE BACKGROUND COLOR CASE ** 4598C *************************************** 4599C 4600 IF(ICOM.EQ.'BACK'.AND.ICOM2.EQ.'GROU')THEN 4601 CALL DPBACL(IHARG,NUMARG,IDEFBK,IBACCO,IFOUND,IERROR) 4602CCCCC OCTOBER 1993. HAVE THE MARGIN BE THE SAME AS THE BACKGROUND 4603CCCCC (USER CAN OVERRIDE WITH SUBSEQUENT MARGIN COLOR COMMAND) 4604 IF(IERROR.EQ.'NO')IMARCO=IBACCO 4605 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4606 ENDIF 4607C 4608C *************************** 4609C ** TREAT THE BELL CASE ** 4610C *************************** 4611C 4612 IF(ICOM.EQ.'BELL')THEN 4613 CALL DPBELL(IHARG,NUMARG,IBELSW,IFOUND,IERROR) 4614 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4615 ENDIF 4616C 4617C ************************************************* 4618C ** TREAT THE BOX ... CORNER COORDINATES CASE ** 4619C ** BOX ... COLOR CASE ** 4620C ** BOX ... PATTERN CASE ** 4621C ** BOX ... THICKNESS CASE ** 4622C ** BOX ... FILL COLOR CASE ** 4623C ** BOX ... FILL PATTTERN CASE ** 4624C ** BOX ... FILL LINE CASE ** 4625C ** BOX ... FILL THICKNESS CASE ** 4626C ** BOX ... FILL GAP CASE ** 4627C ** BOX ... SHADOW HW CASE ** 4628C ************************************************* 4629C 4630 IF(ICOM.EQ.'BOX')THEN 4631C 4632 IF((NUMARG.GE.1.AND.IHARG(1).EQ.'COOR') .OR. 4633 1 (NUMARG.GE.2.AND.IHARG(2).EQ.'COOR') .OR. 4634 1 (NUMARG.GE.2.AND.IHARG(1).EQ.'CORN'.AND. 4635 1 IHARG(2).EQ.'COOR') .OR. 4636 1 (NUMARG.GE.3.AND.IHARG(2).EQ.'CORN'.AND. 4637 1 IHARG(3).EQ.'COOR'))THEN 4638 CALL DPBOCC(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 4639 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM, 4640 1 MAXNAM,IANS,IWIDTH, 4641 1 MAXBOX,PBOXXC,PBOXYC,NUMBOX,IBUGP2, 4642 1 IFOUND,IERROR) 4643 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4644 ENDIF 4645C 4646 IF((NUMARG.GE.1.AND.IHARG(1).EQ.'COLO') .OR. 4647 1 (NUMARG.GE.2.AND.IHARG(2).EQ.'COLO'.AND. 4648 1 IHARG(1).NE.'FILL'))THEN 4649 CALL DPBOCL(IHARG,IARGT,IARG,NUMARG,IDEFCO, 4650 1 MAXBOX,IBOBCO,IFOUND,IERROR) 4651 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4652 ENDIF 4653C 4654 IF((NUMARG.GE.1.AND.IHARG(1).EQ.'PATT') .OR. 4655 1 (NUMARG.GE.2.AND.IHARG(2).EQ.'PATT'.AND. 4656 1 IHARG(1).NE.'FILL'))THEN 4657 CALL DPBOPA(IHARG,IHARG2,IARGT,IARG,NUMARG,IDEFFI, 4658 1 MAXBOX,IBOBPA,IFOUND,IERROR) 4659 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4660 ENDIF 4661C 4662 IF((NUMARG.GE.1.AND.IHARG(1).EQ.'THIC') .OR. 4663 1 (NUMARG.GE.2.AND.IHARG(2).EQ.'THIC'.AND. 4664 1 IHARG(1).NE.'FILL'))THEN 4665 CALL DPBOTH(IHARG,IARGT,IARG,ARG,NUMARG,PDEFTH, 4666 1 MAXBOX,PBOPTH,IFOUND,IERROR) 4667 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4668 ENDIF 4669C 4670 IF(NUMARG.GE.2)THEN 4671 IF(IHARG(1).EQ.'FILL'.AND.IHARG(2).EQ.'COLO')THEN 4672 CALL DPBOFC(IHARG,IARGT,IARG,NUMARG,IDEFXC, 4673 1 MAXBOX,IBOFCO,IFOUND,IERROR) 4674 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4675 ENDIF 4676 ENDIF 4677 IF(NUMARG.GE.3)THEN 4678 IF(IHARG(2).EQ.'FILL'.AND.IHARG(3).EQ.'COLO')THEN 4679 CALL DPBOFC(IHARG,IARGT,IARG,NUMARG,IDEFXC, 4680 1 MAXBOX,IBOFCO,IFOUND,IERROR) 4681 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4682 ENDIF 4683 ENDIF 4684C 4685 IF(NUMARG.GE.2)THEN 4686 IF(IHARG(1).EQ.'FILL'.AND.IHARG(2).EQ.'PATT')THEN 4687 CALL DPBOFP(IHARG,IARGT,IARG,NUMARG,IDEFFI, 4688 1 MAXBOX,IBOFPA,IFOUND,IERROR) 4689 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4690 ENDIF 4691 ENDIF 4692 IF(NUMARG.GE.3)THEN 4693 IF(IHARG(2).EQ.'FILL'.AND.IHARG(3).EQ.'PATT')THEN 4694 CALL DPBOFP(IHARG,IARGT,IARG,NUMARG,IDEFFI, 4695 1 MAXBOX,IBOFPA,IFOUND,IERROR) 4696 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4697 ENDIF 4698 ENDIF 4699C 4700C 4701 IF(NUMARG.GE.2)THEN 4702 IF(IHARG(1).EQ.'FILL'.AND.IHARG(2).EQ.'LINE')THEN 4703 CALL DPBOFL(IHARG,IHARG2,IARGT,IARG,NUMARG,IDEFPA, 4704 1 MAXBOX,IBOPPA,IFOUND,IERROR) 4705 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4706 ENDIF 4707 ENDIF 4708 IF(NUMARG.GE.3)THEN 4709 IF(IHARG(2).EQ.'FILL'.AND.IHARG(3).EQ.'LINE')THEN 4710 CALL DPBOFL(IHARG,IHARG2,IARGT,IARG,NUMARG,IDEFPA, 4711 1 MAXBOX,IBOPPA,IFOUND,IERROR) 4712 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4713 ENDIF 4714 ENDIF 4715C 4716 IF(NUMARG.GE.2)THEN 4717 IF(IHARG(1).EQ.'FILL'.AND.IHARG(2).EQ.'THIC')THEN 4718 CALL DPBOFT(IHARG,IARGT,IARG,ARG,NUMARG,PDEFTH, 4719 1 MAXBOX,PBOFTH,IFOUND,IERROR) 4720 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4721 ENDIF 4722 ENDIF 4723 IF(NUMARG.GE.3)THEN 4724 IF(IHARG(2).EQ.'FILL'.AND.IHARG(3).EQ.'THIC')THEN 4725 CALL DPBOFT(IHARG,IARGT,IARG,ARG,NUMARG,PDEFTH, 4726 1 MAXBOX,PBOFTH,IFOUND,IERROR) 4727 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4728 ENDIF 4729 ENDIF 4730C 4731 IF(NUMARG.GE.2)THEN 4732 IF(IHARG(1).EQ.'FILL'.AND.IHARG(2).EQ.'GAP')THEN 4733 CALL DPBOFG(IHARG,IARGT,IARG,ARG,NUMARG,PDEFGA, 4734 1 MAXBOX,PBOPGA,IFOUND,IERROR) 4735 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4736 ENDIF 4737 ENDIF 4738 IF(NUMARG.GE.3)THEN 4739 IF(IHARG(2).EQ.'FILL'.AND.IHARG(3).EQ.'GAP')THEN 4740 CALL DPBOFG(IHARG,IARGT,IARG,ARG,NUMARG,PDEFGA, 4741 1 MAXBOX,PBOPGA,IFOUND,IERROR) 4742 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4743 ENDIF 4744 ENDIF 4745C 4746 IF(NUMARG.GE.1)THEN 4747 IF(IHARG(1).EQ.'SHAD')THEN 4748 CALL DPBSHW(IHARG,IARGT,IARG,ARG,NUMARG,PDEFSH,PDEFSW, 4749 1 MAXBOX,PBOSHE,PBOSWI,IFOUND,IERROR) 4750 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4751 ENDIF 4752 ENDIF 4753 IF(NUMARG.GE.2)THEN 4754 IF(IHARG(2).EQ.'SHAD')THEN 4755 CALL DPBSHW(IHARG,IARGT,IARG,ARG,NUMARG,PDEFSH,PDEFSW, 4756 1 MAXBOX,PBOSHE,PBOSWI,IFOUND,IERROR) 4757 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4758 ENDIF 4759 ENDIF 4760C 4761 ENDIF 4762C 4763C ************************************************* 4764C ** TREAT THE FRAME (CORNER) COORDINATES CASE ** 4765C ************************************************* 4766C 4767 IF(ICOM.EQ.'FRAM')THEN 4768 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CORN'.AND. 4769 1 IHARG(2).EQ.'COOR')THEN 4770 ISHIFT=1 4771 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 4772 1 IBUGP2,IERROR) 4773 ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'COOR')THEN 4774 CONTINUE 4775 ELSE 4776 GOTO1299 4777 ENDIF 4778 CALL DPFRCC(IHARG,IHARG2,IARGT,ARG,NUMARG, 4779 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM, 4780 1 MAXNAM,IANS,IWIDTH, 4781 1 PXMIN,PXMAX,PYMIN,PYMAX, 4782 1 IBUGP2,IFOUND,IERROR) 4783 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4784 ENDIF 4785C 4786 1299 CONTINUE 4787C 4788C ************************************** 4789C ** TREAT THE FRAME COLOR CASE ** 4790C ** FRAME PATTERN CASE ** 4791C ** FRAME THICKNESS CASE ** 4792C ** FRAME CASE ** 4793C ************************************** 4794C 4795 IF(ICOM.EQ.'XFRA' .OR. ICOM.EQ.'X1FR' .OR. ICOM.EQ.'X2FR' .OR. 4796 1 ICOM.EQ.'YFRA' .OR. ICOM.EQ.'Y1FR' .OR. ICOM.EQ.'Y2FR' .OR. 4797 1 ICOM.EQ.'XYFR' .OR. ICOM.EQ.'YXFR' .OR. ICOM.EQ.'FRAM' .OR. 4798 1 ICOM.EQ.'3DFR')THEN 4799C 4800 IF(ICOM.EQ.'3DFR')GOTO1310 4801C 4802 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')THEN 4803 CALL DPFRCL(ICOM,IHARG,NUMARG, 4804 1 IDEFCO,IX1FCO,IX2FCO,IY1FCO,IY2FCO, 4805 1 IFOUND,IERROR) 4806 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4807C 4808 ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'PATT')THEN 4809 CALL DPFRPA(ICOM,IHARG,IHARG2,NUMARG, 4810 1 IDEFPA,IX1FPA,IX2FPA,IY1FPA,IY2FPA, 4811 1 IFOUND,IERROR) 4812 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4813C 4814 ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'THIC')THEN 4815 CALL DPFRTH(ICOM,IHARG,ARG,NUMARG, 4816 1 PDEFTH,PFRATH, 4817 1 IFOUND,IERROR) 4818 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4819 ENDIF 4820C 4821 1310 CONTINUE 4822C 4823 CALL DPFRAM(ICOM,IHARG,NUMARG, 4824 1 IX1FSW,IX2FSW,IY1FSW,IY2FSW,FRAM3D, 4825 1 IFOUND,IERROR) 4826 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4827 ENDIF 4828C 4829C ************************************** 4830C ** TREAT THE GRID THICKNESS CASE ** 4831C ** GRID COLOR CASE ** 4832C ** GRID PATTERN CASE ** 4833C ** GRID CASE ** 4834C ************************************** 4835C 4836 IF(ICOM.EQ.'XGRI' .OR. ICOM.EQ.'YGRI' .OR. ICOM.EQ.'XYGR' .OR. 4837 1 ICOM.EQ.'YXGR' .OR. ICOM.EQ.'GRID')THEN 4838C 4839 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'THIC')THEN 4840 CALL DPGRTH(ICOM,IHARG,ARG,NUMARG, 4841 1 PDEFTH,PVGRTH,PHGRTH, 4842 1 IFOUND,IERROR) 4843 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4844C 4845 ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')THEN 4846 CALL DPGRCL(ICOM,IHARG,NUMARG, 4847 1 IDEFCO,IVGRCO,IHGRCO, 4848 1 IFOUND,IERROR) 4849 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4850 ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'PATT')THEN 4851 CALL DPGRPA(ICOM,IHARG,IHARG2,NUMARG, 4852 1 IDEFPA,IVGRPA,IHGRPA, 4853 1 IFOUND,IERROR) 4854 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4855 ELSE 4856C 4857 CALL DPGRID(ICOM,IHARG,NUMARG,IVGRSW,IHGRSW,IFOUND,IERROR) 4858 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4859C 4860 ENDIF 4861C 4862 ENDIF 4863C 4864C ******************************************** 4865C ** TREAT THE LABEL FONT CASE ** 4866C ** LABEL CASE CASE ** 4867C ** LABEL FILL CASE ** 4868C ** LABEL JUSTIFICATION CASE ** 4869C ** LABEL THICKNESS CASE ** 4870C ** LABEL DISPLACEMENT CASE ** 4871C ** LABEL OFFSET CASE ** 4872C ** LABEL ANGLE CASE ** 4873C ** LABEL DIRECTION CASE ** 4874C ** LABEL COLORS CASE ** 4875C ** LABEL SIZES CASE ** 4876C ** LABEL REFERENCE POINT CASE ** 4877C ** LABEL CASE ** 4878C ******************************************** 4879C 4880 IF(ICOM.EQ.'LABE' .OR. ICOM.EQ.'XLAB' .OR. ICOM.EQ.'X1LA' .OR. 4881 1 ICOM.EQ.'X2LA' .OR. ICOM.EQ.'X3LA' .OR. ICOM.EQ.'YLAB' .OR. 4882 1 ICOM.EQ.'Y1LA' .OR. ICOM.EQ.'Y2LA')THEN 4883C 4884 CALL DPLAFO(ICOM,IHARG,NUMARG, 4885 1 IDEFFO,IX1LFO,IX2LFO,IX3LFO,IY1LFO,IY2LFO, 4886 1 IFOUND,IERROR) 4887 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4888C 4889 CALL DPLACA(ICOM,IHARG,NUMARG, 4890 1 IDEFCA,IX1LCA,IX2LCA,IX3LCA,IY1LCA,IY2LCA, 4891 1 IFOUND,IERROR) 4892 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4893C 4894 CALL DPLAFI(ICOM,IHARG,NUMARG, 4895 1 IDEFFI,IX1LFI,IX2LFI,IX3LFI,IY1LFI,IY2LFI, 4896 1 IFOUND,IERROR) 4897 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4898C 4899 CALL DPLAJU(ICOM,IHARG,NUMARG, 4900 1 IDEFJU,IX1LJU,IX2LJU,IX3LJU,IY1LJU,IY2LJU, 4901 1 IBUGPC,IFOUND,IERROR) 4902 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4903C 4904 CALL DPLATH(ICOM,IHARG,ARG,NUMARG, 4905 1 PDEFTH,PX1LTH,PX2LTH,PX3LTH,PY1LTH,PY2LTH, 4906 1 IFOUND,IERROR) 4907 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4908C 4909 CALL DPLADS(ICOM,IHARG,ARG,NUMARG, 4910 1 PDEFDS,PX1LDS,PX2LDS,PX3LDS,PY1LDS,PY2LDS, 4911 1 IFOUND,IERROR) 4912 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4913C 4914 CALL DPLAOF(ICOM,IHARG,IARGT,ARG,NUMARG, 4915 1 PDEFOF,PX1LOF,PX2LOF,PX3LOF,PY1LOF,PY2LOF, 4916 1 IFOUND,IERROR) 4917 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4918C 4919 CALL DPLAAN(ICOM,IHARG,IARGT,ARG,NUMARG, 4920 1 ADEFAN,PX1LAN,PX2LAN,PX3LAN,PY1LAN,PY2LAN, 4921 1 IFOUND,IERROR) 4922 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4923C 4924 CALL DPLADI(ICOM,IHARG,NUMARG, 4925 1 IDEFDI,IX1LDI,IX2LDI,IX3LDI,IY1LDI,IY2LDI, 4926 1 IFOUND,IERROR) 4927 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4928C 4929 CALL DPLACL(ICOM,IHARG,NUMARG, 4930 1 IDEFCO,IX1LCO,IX2LCO,IX3LCO,IY1LCO,IY2LCO, 4931 1 IFOUND,IERROR) 4932 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4933C 4934 CALL DPLASZ(ICOM,IHARG,IARGT,ARG,NUMARG, 4935 1 PDEFHE,PDEFWI, 4936 1 PX1LHE,PX1LWI,PX1LVG,PX1LHG, 4937 1 PX2LHE,PX2LWI,PX2LVG,PX2LHG, 4938 1 PX3LHE,PX3LWI,PX3LVG,PX3LHG, 4939 1 PY1LHE,PY1LWI,PY1LVG,PY1LHG, 4940 1 PY2LHE,PY2LWI,PY2LVG,PY2LHG, 4941 1 IFOUND,IERROR) 4942 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4943C 4944 CALL DPLACO(ICOM,IHARG,IARGT,ARG,NUMARG, 4945 1 PX1LXC,PX1LYC,PX2LXC,PX2LYC,PX3LXC,PX3LYC, 4946 1 PY1LXC,PY1LYC,PY2LXC,PY2LYC, 4947 1 IFOUND,IERROR) 4948 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4949C 4950 CALL DPLAB(IANS,IANSLC,IWIDTH,IHARG,IHARG2,NUMARG, 4951 1 IX1LTE,NCX1LA,IX1AUT, 4952 1 IX2LTE,NCX2LA,IX2AUT, 4953 1 IX3LTE,NCX3LA,IX3AUT, 4954 1 IY1LTE,NCY1LA,IY1AUT, 4955 1 IY2LTE,NCY2LA,IY2AUT, 4956 1 IBUGP2,IFOUND,IERROR) 4957 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4958C 4959 ENDIF 4960C 4961C *********************************************** 4962C ** TREAT THE LEGEND ... FONT CASE ** 4963C ** LEGEND ... CASE CASE ** 4964C ** LEGEND ... JUSTIFICATION CASE ** 4965C ** LEGEND ... DIRECTION CASE ** 4966C ** LEGEND ... UNITS CASE ** 4967C ** LEGEND ... FILL CASE ** 4968C ** LEGEND ... THICKNESS CASE ** 4969C ** LEGEND ... ANGLE CASE ** 4970C ** LEGEND ... COLORS CASE ** 4971C ** LEGEND ... COORDINATES CASE ** 4972C ** LEGEND ... SIZES CASE ** 4973C ** LEGEND ... HW CASE ** 4974C ** LEGEND ... CASE ** 4975C *********************************************** 4976C 4977 IF(ICOM.EQ.'LEGE')THEN 4978C 4979 CALL DPLEFO(IHARG,IARGT,IARG,NUMARG,IDEFFO, 4980 1 MAXLEG,ILEGFO,IFOUND,IERROR) 4981 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4982C 4983 CALL DPLECA(IHARG,IARGT,IARG,NUMARG,IDEFCA, 4984 1 MAXLEG,ILEGCA,IFOUND,IERROR) 4985 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4986C 4987 CALL DPLEJU(IHARG,IARGT,IARG,NUMARG,IDEFJU, 4988 1 MAXLEG,ILEGJU,IFOUND,IERROR) 4989 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4990C 4991 CALL DPLEDI(IHARG,IHARG2,IARGT,IARG,NUMARG,IDEFDI, 4992 1 MAXLEG,ILEGDI,IFOUND,IERROR) 4993 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4994C 4995 CALL DPLEUN(IHARG,IARGT,IARG,NUMARG,IDEFUZ, 4996 1 MAXLEG,ILEGUN,IFOUND,IERROR) 4997 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 4998C 4999 CALL DPLEFI(IHARG,IARGT,IARG,NUMARG,IDEFFI, 5000 1 MAXLEG,ILEGFI,IFOUND,IERROR) 5001 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5002C 5003 CALL DPLETH(IHARG,IARGT,IARG,ARG,NUMARG,PDEFTH, 5004 1 MAXLEG,PLEGTH,IFOUND,IERROR) 5005 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5006C 5007 CALL DPLEAN(IHARG,IARGT,IARG,ARG,NUMARG,ADEFAN, 5008 1 MAXLEG,ALEGAN,IFOUND,IERROR) 5009 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5010C 5011 CALL DPLECL(IHARG,IARGT,IARG,NUMARG,IDEFCO, 5012 1 MAXLEG,ILEGCO,IFOUND,IERROR) 5013 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5014C 5015 CALL DPLECO(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 5016 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM, 5017 1 MAXNAM,IANS,IWIDTH, 5018 1 MAXLEG,PLEGXC,PLEGYC,IBUGP2,IFOUND,IERROR) 5019 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5020C 5021 CALL DPLESZ(IHARG,IARGT,IARG,ARG,NUMARG, 5022 1 PDEFHE,PDEFWI,MAXLEG, 5023 1 PLEGHE,PLEGWI,PLEGVG,PLEGHG, 5024 1 IFOUND,IERROR) 5025 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5026C 5027 CALL DPLEHW(IHARG,IARGT,IARG,ARG,NUMARG, 5028 1 PDEFHE,MAXLEG,PLEGHE,PLEGWI,PLEGVG,PLEGHG, 5029 1 IFOUND,IERROR) 5030 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5031C 5032 CALL DPLEG(IHARG,IARG,ARG,IARGT,NUMARG,IANS,IANSLC,IWIDTH, 5033 1 ILEGNA,ILEGST,ILEGSP,NUMLEG,MAXLEG, 5034 1 ILEGTE,NCLEG,MXCLEG,IFOUND,IERROR,IBUGP2) 5035 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5036C 5037 ENDIF 5038C 5039C ******************************** 5040C ** TREAT THE ...LIMITS CASE ** 5041C ******************************** 5042C 5043 IF(ICOM.EQ.'XLIM' .OR. ICOM.EQ.'X1LI' .OR. ICOM.EQ.'X2LI' .OR. 5044 1 ICOM.EQ.'YLIM' .OR. ICOM.EQ.'Y1LI' .OR. ICOM.EQ.'Y2LI' .OR. 5045 1 ICOM.EQ.'XYLI' .OR. ICOM.EQ.'YXLI' .OR. ICOM.EQ.'LIMI')THEN 5046C 5047 IF(IHARG(1).EQ.'OF '.AND.IHARG(2).EQ.'DETE')GOTO2499 5048C 5049 CALL DPLIM(ICOM,IHARG,IARGT,ARG,NUMARG, 5050 1 GX1MIN,GX1MAX,GY1MIN,GY1MAX, 5051 1 GX2MIN,GX2MAX,GY2MIN,GY2MAX, 5052 1 FX1MIN,FX1MAX,FY1MIN,FY1MAX, 5053 1 FX2MIN,FX2MAX,FY2MIN,FY2MAX, 5054 1 IX1MIN,IX1MAX,IY1MIN,IY1MAX, 5055 1 IX2MIN,IX2MAX,IY2MIN,IY2MAX, 5056 1 FX1MNZ,FX1MXZ,FX2MNZ,FX2MXZ, 5057 1 FY1MNZ,FY1MXZ,FY2MNZ,FY2MXZ, 5058 1 IFOUND,IERROR) 5059 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5060C 5061 ENDIF 5062C 5063 2499 CONTINUE 5064C 5065C **************************************** 5066C ** TREAT THE LINE COLORS CASE ** 5067C ** TREAT THE LINE THICKNESS CASE ** 5068C ** TREAT THE LINE UNITS CASE ** 5069C ** TREAT THE LINE CASE ** 5070C **************************************** 5071C 5072 IF(ICOM.EQ.'LINE')THEN 5073C 5074 IF(IHARG(1).EQ.'COLO')THEN 5075 CALL DPLICL(IHARG,NUMARG,IDEFCO,MAXLIN,ILINCO,IFOUND,IERROR) 5076 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5077C 5078 ELSEIF(IHARG(1).EQ.'UNIT')THEN 5079 CALL DPLIUN(IHARG,NUMARG,MAXLIN,ILINTY,IFOUND,IERROR) 5080 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5081C 5082 ELSEIF(IHARG(1).EQ.'THIC')THEN 5083 CALL DPLITH(IHARG,IARGT,ARG,NUMARG,PDEFLT,MAXLIN,PLINTH, 5084 1 IBUGP2,IFOUND,IERROR) 5085 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5086C 5087 ELSE 5088 IF(ICOM2.NE.'AR ')THEN 5089 CALL DPLINE(IHARG,IHARG2,NUMARG,MAXLIN,ILINPA,ILINPO, 5090 1 IFOUND,IERROR) 5091 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5092 ENDIF 5093 ENDIF 5094C 5095 ENDIF 5096C 5097C ***************************** 5098C ** TREAT THE ...LOG CASE ** 5099C ***************************** 5100C 5101 IF(ICOM.EQ.'XLOG' .OR. ICOM.EQ.'X1LO' .OR. ICOM.EQ.'X2LO' .OR. 5102 1 ICOM.EQ.'YLOG' .OR. ICOM.EQ.'Y1LO' .OR. ICOM.EQ.'Y2LO' .OR. 5103 1 ICOM.EQ.'LOG ' .OR. ICOM.EQ.'LOGL' .OR. 5104 1 (ICOM.EQ.'XYLO'.AND.ICOM2.EQ.'G ') .OR. 5105 1 (ICOM.EQ.'YXLO'.AND.ICOM2.EQ.'G '))THEN 5106C 5107CCCCC APRIL 1995. CHECK FOR LOG LOGISTIC PROB PLOT, LOG LOGISTIC PPCC 5108CCCCC PLOT (ALSO ENTERED AS LOGLOGISTIC PROB PLOT) 5109CCCCC SEPTEMBER 2001. CHECK FOR LOG DOUBLE EXPO PROB PLOT, 5110CCCCC LOG DOUBLE EPXO PPCC PLOT 5111C 5112 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PROB')GOTO2899 5113 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'PROB')GOTO2899 5114 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'PROB')GOTO2899 5115 IF(NUMARG.GE.4.AND.IHARG(4).EQ.'PROB')GOTO2899 5116 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PPCC')GOTO2899 5117 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'PPCC')GOTO2899 5118 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'PPCC')GOTO2899 5119 IF(NUMARG.GE.4.AND.IHARG(4).EQ.'PPCC')GOTO2899 5120 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'KOLM')GOTO2899 5121 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'KOLM')GOTO2899 5122 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'KOLM')GOTO2899 5123 IF(NUMARG.GE.4.AND.IHARG(4).EQ.'KOLM')GOTO2899 5124 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'KS ')GOTO2899 5125 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'KS ')GOTO2899 5126 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'KS ')GOTO2899 5127 IF(NUMARG.GE.4.AND.IHARG(4).EQ.'KS ')GOTO2899 5128 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHI ')GOTO2899 5129 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CHI ')GOTO2899 5130 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'CHI ')GOTO2899 5131 IF(NUMARG.GE.4.AND.IHARG(4).EQ.'CHI ')GOTO2899 5132 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHIS')GOTO2899 5133 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CHIS')GOTO2899 5134 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'CHIS')GOTO2899 5135 IF(NUMARG.GE.4.AND.IHARG(4).EQ.'CHIS')GOTO2899 5136 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'BETA')GOTO2899 5137C 5138 CALL DPTISC(ICOM,IHARG,NUMARG, 5139 1 IX1TSC,IX2TSC,IY1TSC,IY2TSC, 5140 1 IFOUND,IERROR) 5141 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5142C 5143 ENDIF 5144C 5145 2899 CONTINUE 5146C 5147C *********************************** 5148C ** TREAT THE MARGIN COLOR CASE ** 5149C *********************************** 5150C 5151 IF(ICOM.EQ.'MARG'.AND.IHARG(1).EQ.'COLO')THEN 5152 CALL DPMACL(IHARG,NUMARG,IDEFMC,IMARCO,IFOUND,IERROR) 5153 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5154 ENDIF 5155C 5156C ********************************* 5157C ** TREAT THE ...MAXIMUM CASE ** 5158C ********************************* 5159C 5160 IF(ICOM.EQ.'XMAX' .OR. ICOM.EQ.'X1MA' .OR. ICOM.EQ.'X2MA' .OR. 5161 1 ICOM.EQ.'YMAX' .OR. ICOM.EQ.'Y1MA' .OR. ICOM.EQ.'Y2MA' .OR. 5162 1 ICOM.EQ.'XYMA' .OR. ICOM.EQ.'YXMA' .OR. ICOM.EQ.'MAXI' .OR. 5163 1 ICOM.EQ.'MAX ')THEN 5164 IF(NUMARG.GE.1.AND.ICOM.EQ.'MAXI')THEN 5165 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'STAT'.AND.IHARG(2).EQ.'PLOT') 5166 1 GOTO3099 5167 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND.IHARG(2).EQ.'PLOT') 5168 1 GOTO3099 5169 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'WIND'.AND.IHARG(2).EQ.'STAT' 5170 1 .AND.IHARG(3).EQ.'PLOT')GOTO3199 5171 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'CUMU'.AND.IHARG(2).EQ.'STAT' 5172 1 .AND.IHARG(3).EQ.'PLOT')GOTO3199 5173 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MOVI'.AND.IHARG(2).EQ.'STAT' 5174 1 .AND.IHARG(3).EQ.'PLOT')GOTO3199 5175 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')GOTO3099 5176 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'GRUB')GOTO3099 5177 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TIET')GOTO3099 5178 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DIXO')GOTO3099 5179 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'GRUB')GOTO3099 5180 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'TIET')GOTO3099 5181 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'DIXO')GOTO3099 5182 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'RECO'.AND.IHARG(2).EQ.'LENG') 5183 1 GOTO3099 5184 ENDIF 5185C 5186 CALL DPMAX(ICOM,IHARG,IARGT,ARG,NUMARG, 5187 1 GX1MAX,GY1MAX,GX2MAX,GY2MAX, 5188 1 IX1MAX,IY1MAX,IX2MAX,IY2MAX, 5189 1 IFOUND,IERROR) 5190 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5191C 5192 ENDIF 5193C 5194 3099 CONTINUE 5195C 5196C ********************************* 5197C ** TREAT THE ...MINIMUM CASE ** 5198C ********************************* 5199C 5200 IF(ICOM.EQ.'XMIN' .OR. ICOM.EQ.'X1MI' .OR. ICOM.EQ.'X2MI' .OR. 5201 1 ICOM.EQ.'YMIN' .OR. ICOM.EQ.'Y1MI' .OR. ICOM.EQ.'Y2MI' .OR. 5202 1 ICOM.EQ.'XYMI' .OR. ICOM.EQ.'YXMI' .OR. ICOM.EQ.'MINI' .OR. 5203 1 ICOM.EQ.'MIN ')THEN 5204C 5205 IF(NUMARG.GE.1.AND.ICOM.EQ.'MINI')THEN 5206 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'STAT'.AND.IHARG(2).EQ.'PLOT') 5207 1 GOTO3199 5208 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND.IHARG(2).EQ.'PLOT') 5209 1 GOTO3199 5210 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'WIND'.AND.IHARG(2).EQ.'STAT' 5211 1 .AND.IHARG(3).EQ.'PLOT')GOTO3199 5212 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'CUMU'.AND.IHARG(2).EQ.'STAT' 5213 1 .AND.IHARG(3).EQ.'PLOT')GOTO3199 5214 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MOVI'.AND.IHARG(2).EQ.'STAT' 5215 1 .AND.IHARG(3).EQ.'PLOT')GOTO3199 5216 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')GOTO3199 5217 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'GRUB')GOTO3199 5218 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TIET')GOTO3199 5219 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DIXO')GOTO3199 5220 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'GRUB')GOTO3199 5221 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'TIET')GOTO3199 5222 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'DIXO')GOTO3199 5223 ENDIF 5224C 5225 CALL DPMIN(ICOM,IHARG,IARGT,ARG,NUMARG, 5226 1 GX1MIN,GY1MIN,GX2MIN,GY2MIN, 5227 1 IX1MIN,IY1MIN,IX2MIN,IY2MIN, 5228 1 IFOUND,IERROR) 5229 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5230C 5231 ENDIF 5232C 5233 3199 CONTINUE 5234C 5235C ******************************* 5236C ** TREAT THE PRE-SORT CASE ** 5237C ******************************* 5238C 5239 IF(ICOM.EQ.'PRE')THEN 5240 CALL DPPRES(IHARG,NUMARG,ISORSW,IFOUND,IERROR) 5241 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5242 ENDIF 5243C 5244C ******************************************* 5245C ** TREAT THE ...WEIB (SCALE) AXIS CASE ** 5246C ******************************************* 5247C 5248 IF(ICOM.EQ.'XWEI' .OR. ICOM.EQ.'X1WE' .OR. ICOM.EQ.'X2WE' .OR. 5249 1 ICOM.EQ.'YWEI' .OR. ICOM.EQ.'Y1WE' .OR. ICOM.EQ.'Y2WE' .OR. 5250 1 (ICOM.EQ.'XYWE'.AND.ICOM2.EQ.'IB ') .OR. 5251 1 (ICOM.EQ.'YXWE'.AND.ICOM2.EQ.'IB '))THEN 5252C 5253 CALL DPTIS2(ICOM,IHARG,NUMARG, 5254 1 IX1TSC,IX2TSC,IY1TSC,IY2TSC, 5255 1 IFOUND,IERROR) 5256 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5257C 5258 ENDIF 5259C 5260C ********************************************* 5261C ** TREAT THE SEGMENT ... COLOR CASE ** 5262C ** SEGMENT ... PATTERN CASE ** 5263C ** SEGMENT ... THICKNESS CASE ** 5264C ** SEGMENT ... COORDINATES CASE ** 5265C ********************************************* 5266C 5267 IF(ICOM.EQ.'SEGM')THEN 5268 CALL DPSECL(IHARG,IARGT,IARG,NUMARG,IDEFCO, 5269 1 MAXSEG,ISEGCO,IFOUND,IERROR) 5270 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5271C 5272 CALL DPSEPA(IHARG,IHARG2,IARGT,IARG,NUMARG,IDEFPA, 5273 1 MAXSEG,ISEGPA,IFOUND,IERROR) 5274 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5275C 5276 CALL DPSETH(IHARG,IARGT,IARG,ARG,NUMARG,PDEFTH, 5277 1 MAXSEG,PSEGTH,IFOUND,IERROR) 5278 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5279C 5280 CALL DPSECO(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 5281 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 5282 1 IANS,IWIDTH, 5283 1 MAXSEG,PSEGXC,PSEGYC,NUMSEG,IBUGP2,IFOUND,IERROR) 5284 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5285C 5286 ENDIF 5287C 5288C ******************************* 5289C ** TREAT THE SEQUENCE CASE ** 5290C ******************************* 5291C 5292 IF(ICOM.EQ.'SEQU')THEN 5293 CALL DPSEQ(IHARG,IARGT,IARG,NUMARG, 5294 1 ISEQSW,NUMSEQ,IFOUND,IERROR) 5295 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5296 ENDIF 5297C 5298C *************************************************** 5299C ** TREAT THE CHARACTER COLORS CASE ** 5300C ** CHARACTER FONT CASE ** 5301C ** CHARACTER CASE CASE ** 5302C ** CHARACTER MAPPING CASE ** 5303C ** CHARACTER THICKNESS CASE ** 5304C ** CHARACTER SIZES CASE ** 5305C ** CHARACTER FILL CASE ** 5306C ** CHARACTER WIDTH CASE ** 5307C ** CHARACTER JUSTIFICATION CASE ** 5308C ** CHARACTER OFFSET CASE ** 5309C ** CHARACTER ANGLE CASE ** 5310C ** CHARACTER HW (HEIGHT & WIDTH) CASE ** 5311C ** CHARACTER UNIT CASE ** 5312C ** CHARACTERS CASE ** 5313C *************************************************** 5314C 5315 IF(ICOM.EQ.'CHAR')THEN 5316 IF(IHARG(1).EQ.'COLO')THEN 5317 CALL DPCHCL(IHARG,NUMARG,IDEFCO,MAXCHA,ICHACO,IFOUND,IERROR) 5318 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5319 ELSEIF(IHARG(1).EQ.'FONT')THEN 5320 CALL DPCHFO(IHARG,NUMARG,IDEFFO,MAXCHA,ICHAFO,IFOUND,IERROR) 5321 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5322 ELSEIF(IHARG(1).EQ.'CASE')THEN 5323 CALL DPCHCA(IHARG,NUMARG,IDEFCA,MAXCHA,ICHACA,IFOUND,IERROR) 5324 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5325 ELSEIF(IHARG(1).EQ.'MAP'.OR.IHARG(1).EQ.'MAPP')THEN 5326 CALL DPCMAP(IHARG,NUMARG,IDCMAP,ICHMAP,IFOUND,IERROR) 5327 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5328 ELSEIF(IHARG(1).EQ.'THIC')THEN 5329 CALL DPCHTH(IHARG,ARG,NUMARG,PDEFTH,MAXCHA,PCHATH, 5330 1 IFOUND,IERROR) 5331 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5332 ELSEIF(IHARG(1).EQ.'SIZE' .OR. IHARG(1).EQ.'HEIG')THEN 5333 CALL DPCHSZ(PDEFHE,MAXCHA,PCHAHE,PCHAWI,PCHAVG,PCHAHG, 5334 1 IBUGP2,IBUGQ,IFOUND,IERROR) 5335 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5336 ELSEIF(IHARG(1).EQ.'FILL')THEN 5337 CALL DPCHFI(IHARG,NUMARG,IDEFFI,MAXCHA,ICHAFI,IFOUND,IERROR) 5338 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5339 ELSEIF(IHARG(1).EQ.'WIDT'.OR.IHARG(2).EQ.'WIDT')THEN 5340 CALL DPCHWI(IHARG,IARGT,ARG,NUMARG, 5341 1 PDEFWI,MAXCHA,PCHAWI,PCHAHG, 5342 1 IFOUND,IERROR) 5343 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5344 ELSEIF(IHARG(1).EQ.'JUST'.AND.IHARG2(1).EQ.'IFIC')THEN 5345 CALL DPCHJU(IHARG,NUMARG,MAXCHA,ICHAJU,IFOUND,IERROR) 5346 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5347 ELSEIF((IHARG(1).EQ.'OFFS'.AND.IHARG2(1).EQ.'ET ').OR. 5348 1 (IHARG(1).EQ.'DISP'.AND.IHARG2(1).EQ.'LACE'))THEN 5349 CALL DPCHOF(IHARG,IARGT,ARG,NUMARG, 5350 1 MAXCHA,PCHAHO,PCHAVO, 5351 1 IFOUND,IERROR) 5352 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5353 ELSEIF(IHARG(1).EQ.'ANGL'.AND.IHARG2(1).EQ.'E ')THEN 5354 CALL DPCHAN(MAXCHA,ACHAAN,IBUGP2,IBUGQ,IFOUND,IERROR) 5355 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5356 ELSEIF(IHARG(1).EQ.'HW')THEN 5357 CALL DPCHHW(IHARG,IARGT,ARG,NUMARG, 5358 1 MAXCHA,PCHAHE,PCHAWI,PDEFHE,PDEFWI, 5359 1 IFOUND,IERROR) 5360 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5361 ELSEIF(IHARG(1).EQ.'UNIT')THEN 5362 CALL DPCHUN(IHARG,NUMARG,MAXCHA,ICHATY,IFOUND,IERROR) 5363 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5364 ELSE 5365 CALL DPCHAR(MAXCHA,ICHAPA,ICHAPO, 5366 1 IBUGP2,IBUGQ,ISUBRO,IFOUND,IERROR) 5367 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5368 ENDIF 5369 ENDIF 5370C 5371CCCCC THE FOLLOWING ANIMATION SWITCH CHUNK WAS ADDED APRIL 1989 5372C ************************************************** 5373C ** TREAT THE ANIMATION SWITCH CASE ** 5374C ************************************************** 5375C 5376 IF(ICOM.EQ.'ANIM' .OR. ICOM.EQ.'UNDR')THEN 5377 CALL DPANIM(IHARG,NUMARG,IANISW,IFOUND,IERROR) 5378 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5379 ENDIF 5380C 5381CCCCC THE FOLLOWING 3 DES. FOP EXP. SECTIONS WERE ADDED MAY 1989 5382C ****************************************** 5383C ** TREAT THE DEX WIDTH CASE ** 5384C ** DEX DEPTH CASE ** 5385C ** DEX HORIZONTAL AXIS CASE ** 5386C ****************************************** 5387C 5388 IF(ICOM.EQ.'DEX')THEN 5389C 5390 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'WIDT')THEN 5391 CALL DPDEWI(IHARG,ARG,NUMARG,DEFDEW, 5392 1 DEXWID,IFOUND,IERROR) 5393 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5394C 5395 ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'DEPT')THEN 5396 CALL DPDEDE(IHARG,IARG,NUMARG,IDEDED, 5397 1 IDEXDE,IFOUND,IERROR) 5398 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5399C 5400 ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'HORI'.AND. 5401 1 IHARG(2).EQ.'AXIS')THEN 5402 CALL DPDEHA(IHARG,NUMARG,IDEFHA, 5403 1 IDEXHA,IFOUND,IERROR) 5404 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5405C 5406 ENDIF 5407 ENDIF 5408C 5409C ***************** 5410C ** STEP 90-- ** 5411C ** EXIT ** 5412C ***************** 5413C 5414 9000 CONTINUE 5415 IF(IBUGPC.EQ.'ON' .OR. ISUBRO.EQ.'IPC1')THEN 5416 WRITE(ICOUT,999) 5417 CALL DPWRST('XXX','BUG ') 5418 WRITE(ICOUT,9011) 5419 9011 FORMAT('***** AT THE END OF MAIPC1--') 5420 CALL DPWRST('XXX','BUG ') 5421 WRITE(ICOUT,9020)IFOUND,IERROR 5422 9020 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 5423 CALL DPWRST('XXX','BUG ') 5424 WRITE(ICOUT,9051)DEXWID,IDEXDE,IDEXHA 5425 9051 FORMAT('DEXWID,IDEXDE,IDEXHA = ',E15.7,I8,2X,A4) 5426 CALL DPWRST('XXX','BUG ') 5427 ENDIF 5428C 5429 RETURN 5430 END 5431 SUBROUTINE MAIPC2(IBUGPC,IBUGP2,ISUBRO, 5432 1 IVGMSW,IHGMSW, 5433 1 IMPSW,IMPNR,IMPNC,IMPCO,IMPCO2, 5434CCCCC ADD FOLLOWING LINE AUGUST 1999. 5435 1 IMPARG, 5436 1 PMXMIN,PMXMAX,PMYMIN,PMYMAX, 5437 1 IERASV, 5438 1 PWXMIS,PWXMAS,PWYMIS,PWYMAS, 5439CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1992 5440 1 ITIAUT, 5441 1 IFOUND,IERROR) 5442C 5443C PURPOSE--THIS IS SUBROUTING MAIPC2. 5444C (THE PC AT THE END OF MAIPC2 STANDS FOR PLOT CONTROL 5445C THIS SUBROUTINE SEARCHES FOR AND EXECUTES 5446C PLOT CONTROL COMMANDS (PART 2). 5447C 5448C WRITTEN BY--JAMES J. FILLIBEN 5449C STATISTICAL ENGINEERING DIVISION 5450C INFORMATION TECHNOLOGY LABORATORY 5451C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5452C GAITHERSBURG, MD 20899-8980 5453C PHONE--301-975-2855 5454C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5455C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5456C LANGUAGE--ANSI FORTRAN (1977) 5457C VERSION NUMBER--82.6 5458C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--JULY 1986. 5459C UPDATED JANUARY 1988. (OPTIONAL OMISSION OF WORD MAJOR) 5460C UPDATED --SEPTEMBER 1988. 3D PROJECTION (ORTHOGRAP./PERSPECT.) 5461C UPDATED --SEPTEMBER 1988. PROJECTION (ORTHOGRAPHIC/PERSPECTIVE) 5462C MOVED TO MAIPC4 FOR GENERAL 3-D. 5463C UPDATED --SEPTEMBER 1988. VISIBLE 5464C MOVED TO MAIPC4 FOR GENERAL 3-D. 5465C UPDATED --DECEMBER 1988. TIC/TIC LABEL/TITLE SIZE DEFAULT WIDTH 5466C UPDATED --FEBRUARY 1989. ADDED MANY ATTRIBUTE COMMANDS (ALAN) 5467C UPDATED --JULY 1989. TITLE DISPLACEMENT 5468C UPDATED --MAY 1990. TIC MARK OFFSET 5469C UPDATED --AUGUST 1990. MP FOR MULTIPLOT 5470C UPDATED --AUGUST 1990. WINDOW SYSTEM 5471C UPDATED --AUGUST 1990. WINDOW POINTER 5472C UPDATED --AUGUST 1990. WINDOW SYSTEM COMMON 5473C UPDATED --AUGUST 1991. TIC LABEL DISPLACEMENT 5474C UPDATED --APRIL 1992. GRID PATTERN CODE REDUNDANT 5475C UPDATED --AUGUST 1992. ADD TITLE SWITCH FOR AUTOMATIC 5476C UPDATED --DECEMBER 1992. FIX CALL TO DPTLDS 5477C UPDATED --SEPTEMBER 1993. LOWER CASE--TIC LABEL CONTENTS 5478C UPDATED --SEPTEMBER 1993. LOWER CASE FOR TITLE 5479C UPDATED --SEPTEMBER 1993. CHAR*4 FOR ITIAUT 5480C UPDATED --AUGUST 1995. DASH2 BUG (VARIOUS) 5481C UPDATED --APRIL 1997. PIXMAP TITLE COMMAND 5482C UPDATED --SEPTEMBER 1998. CALL TO DPMULT 5483C UPDATED --AUGUST 1999. CALL TO DPMULT 5484C UPDATED --NOVEMBER 1999. SUBREGION SWITCH 5485C UPDATED --MAY 2015. EMBED 5486C EMBDED HW 5487C EMBDED CORNER COORDINATES 5488C EMBDED POSITION 5489C EMBDED HORIZONTAL JUSTIFICATION 5490C EMBDED VERTICAL JUSTIFICATION 5491C 5492C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5493C 5494 CHARACTER*4 IBUGPC 5495 CHARACTER*4 IBUGP2 5496 CHARACTER*4 ISUBRO 5497C 5498 CHARACTER*4 IVGMSW 5499 CHARACTER*4 IHGMSW 5500C 5501 CHARACTER*4 IMPSW 5502 CHARACTER*4 IERASV 5503C 5504CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1993 5505 CHARACTER*4 ITIAUT 5506CCCCC OCTOBER 1996 5507CCCCC CHARACTER*4 IWINPO 5508C 5509 CHARACTER*4 IFOUND 5510 CHARACTER*4 IERROR 5511C 5512C-----COMMON---------------------------------------------------------- 5513C 5514 INCLUDE 'DPCOPA.INC' 5515 INCLUDE 'DPCOHK.INC' 5516 INCLUDE 'DPCOPC.INC' 5517 INCLUDE 'DPCOSU.INC' 5518 INCLUDE 'DPCODA.INC' 5519CCCCC THE FOLLOWING WINDOW SYSTEM COMMON WAS ADDED AUGUST 1990 5520 INCLUDE 'DPCOWI.INC' 5521 INCLUDE 'DPCOP2.INC' 5522C 5523C-----START POINT----------------------------------------------------- 5524C 5525 IF(IBUGPC.EQ.'ON' .OR. ISUBRO.EQ.'IPC2')THEN 5526 WRITE(ICOUT,999) 5527 999 FORMAT(1X) 5528 CALL DPWRST('XXX','BUG ') 5529 WRITE(ICOUT,51) 5530 51 FORMAT('***** AT THE BEGINNING OF MAIPC2--') 5531 CALL DPWRST('XXX','BUG ') 5532 WRITE(ICOUT,53)IBUGPC,IBUGP2,ISUBRO,IANGLU,IERASV 5533 53 FORMAT('IBUGPC,IBUGP2,ISUBRO,IANGLU,IERASV = ',4(A4,2X),A4) 5534 CALL DPWRST('XXX','BUG ') 5535 WRITE(ICOUT,67)ICOM,ICOM2,NUMARG 5536 67 FORMAT('ICOM,ICOM2,NUMARG = ',2(A4,2X),I8) 5537 CALL DPWRST('XXX','BUG ') 5538 DO70I=1,NUMARG 5539 WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) 5540 71 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ', 5541 1 I8,3(2X,A4),2X,I8,G15.7) 5542 CALL DPWRST('XXX','BUG ') 5543 70 CONTINUE 5544 WRITE(ICOUT,81)IMPSW,IMPNR,IMPNC,IMPCO,IMPCO2 5545 81 FORMAT('IMPSW,IMPNR,IMPNC,IMPCO,IMPCO2 = ',A4,4I8) 5546 CALL DPWRST('XXX','BUG ') 5547 WRITE(ICOUT,82)PMXMIN,PMXMAX,PMYMIN,PMYMAX 5548 82 FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4G15.7) 5549 CALL DPWRST('XXX','BUG ') 5550 WRITE(ICOUT,84)PWXMIS,PWXMAS,PWYMIS,PWYMAS 5551 84 FORMAT('PWXMIS,PWXMAS,PWYMIS,PWYMAS = ',4G15.7) 5552 CALL DPWRST('XXX','BUG ') 5553 WRITE(ICOUT,86)PWXMIN,PWXMAX,PWYMIN,PWYMAX 5554 86 FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4G15.7) 5555 CALL DPWRST('XXX','BUG ') 5556 WRITE(ICOUT,87)PXMIN,PXMAX,PYMIN,PYMAX 5557 87 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4G15.7) 5558 CALL DPWRST('XXX','BUG ') 5559 ENDIF 5560C 5561 IFOUND='NO' 5562 IERROR='NO' 5563C 5564C 5565C 5566C ************************************** 5567C ** TREAT THE ...TIC PATTERN CASE ** 5568C ************************************** 5569C NOTE: THIS CASE NOT STORED IN COMMON BLOCKS (INCLUDE FILE "DPCOPC") 5570C OR IMPLEMENTED IN CODE 5571C 5572C 5573CCCCC IF(ICOM.EQ.'XTIC')GOTO4220 5574CCCCC IF(ICOM.EQ.'X1TI')GOTO4220 5575CCCCC IF(ICOM.EQ.'X2TI')GOTO4220 5576CCCCC IF(ICOM.EQ.'YTIC')GOTO4220 5577CCCCC IF(ICOM.EQ.'Y1TI')GOTO4220 5578CCCCC IF(ICOM.EQ.'Y2TI')GOTO4220 5579CCCCC IF(ICOM.EQ.'TIC')GOTO4220 5580CCCCC IF(ICOM.EQ.'TICS')GOTO4220 5581CCCCC IF(ICOM.EQ.'XYTI')GOTO4220 5582CCCCC IF(ICOM.EQ.'YXTI')GOTO4220 5583CCCCC GOTO4229 5584C 5585C4220 CONTINUE 5586CCCCC CALL DPTCPA(ICOM,IHARG,NUMARG, 5587CCCCC1IDEFPA, 5588CCCCC1IX1TPA,IX2TPA,IY1TPA,IY2TPA, 5589CCCCC1IFOUND,IERROR) 5590CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5591C 5592C4229 CONTINUE 5593C 5594C **************************************** 5595C ** TREAT THE ...TIC THICKNESS CASE ** 5596C **************************************** 5597C 5598 IF(ICOM.EQ.'XTIC')GOTO4230 5599 IF(ICOM.EQ.'X1TI')GOTO4230 5600 IF(ICOM.EQ.'X2TI')GOTO4230 5601 IF(ICOM.EQ.'YTIC')GOTO4230 5602 IF(ICOM.EQ.'Y1TI')GOTO4230 5603 IF(ICOM.EQ.'Y2TI')GOTO4230 5604 IF(ICOM.EQ.'TIC')GOTO4230 5605 IF(ICOM.EQ.'TICS')GOTO4230 5606 IF(ICOM.EQ.'XYTI')GOTO4230 5607 IF(ICOM.EQ.'YXTI')GOTO4230 5608 GOTO4239 5609C 5610 4230 CONTINUE 5611 CALL DPTCTH(ICOM,IHARG,ARG,NUMARG, 5612 1PDEFTH, 5613 1PTICTH, 5614 1IFOUND,IERROR) 5615 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5616C 5617 4239 CONTINUE 5618C ***************************** 5619C ** TREAT THE ...TIC CASE ** 5620C ***************************** 5621C 5622 IF(ICOM.EQ.'XTIC')GOTO4100 5623 IF(ICOM.EQ.'X1TI')GOTO4100 5624 IF(ICOM.EQ.'X2TI')GOTO4100 5625 IF(ICOM.EQ.'YTIC')GOTO4100 5626 IF(ICOM.EQ.'Y1TI')GOTO4100 5627 IF(ICOM.EQ.'Y2TI')GOTO4100 5628 IF(ICOM.EQ.'TIC ')GOTO4100 5629 IF(ICOM.EQ.'TICS')GOTO4100 5630 IF(ICOM.EQ.'XYTI')GOTO4100 5631 IF(ICOM.EQ.'YXTI')GOTO4100 5632 GOTO4199 5633C 5634 4100 CONTINUE 5635 CALL DPTIC(ICOM,IHARG,NUMARG, 5636 1IX1TSW,IX2TSW,IY1TSW,IY2TSW, 5637 1IFOUND,IERROR) 5638 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5639C 5640 4199 CONTINUE 5641C 5642C ************************************ 5643C ** TREAT THE ...TIC COLOR CASE ** 5644C ************************************ 5645C 5646 IF(ICOM.EQ.'XTIC')GOTO4200 5647 IF(ICOM.EQ.'X1TI')GOTO4200 5648 IF(ICOM.EQ.'X2TI')GOTO4200 5649 IF(ICOM.EQ.'YTIC')GOTO4200 5650 IF(ICOM.EQ.'Y1TI')GOTO4200 5651 IF(ICOM.EQ.'Y2TI')GOTO4200 5652 IF(ICOM.EQ.'TIC')GOTO4200 5653 IF(ICOM.EQ.'TICS')GOTO4200 5654 IF(ICOM.EQ.'XYTI')GOTO4200 5655 IF(ICOM.EQ.'YXTI')GOTO4200 5656 GOTO4299 5657C 5658 4200 CONTINUE 5659 CALL DPTCCL(ICOM,IHARG,NUMARG, 5660 1IDEFCO, 5661 1IX1TCO,IX2TCO,IY1TCO,IY2TCO, 5662 1IFOUND,IERROR) 5663 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5664C 5665 4299 CONTINUE 5666C 5667C ************************************ 5668C ** TREAT THE ...TIC DECIMALS CASE** 5669C ************************************ 5670C 5671 IF(ICOM.EQ.'XTIC')GOTO4300 5672 IF(ICOM.EQ.'X1TI')GOTO4300 5673 IF(ICOM.EQ.'X2TI')GOTO4300 5674 IF(ICOM.EQ.'YTIC')GOTO4300 5675 IF(ICOM.EQ.'Y1TI')GOTO4300 5676 IF(ICOM.EQ.'Y2TI')GOTO4300 5677 IF(ICOM.EQ.'TIC')GOTO4300 5678 IF(ICOM.EQ.'TICS')GOTO4300 5679 IF(ICOM.EQ.'XYTI')GOTO4300 5680 IF(ICOM.EQ.'YXTI')GOTO4300 5681 GOTO4399 5682C 5683 4300 CONTINUE 5684 CALL DPTCDP(ICOM,IHARG,IARG,NUMARG, 5685 1 IDEFDP, 5686 1 IX1ZDP,IX2ZDP,IY1ZDP,IY2ZDP, 5687 1 IFOUND,IERROR) 5688 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5689C 5690 4399 CONTINUE 5691C 5692C *************************************** 5693C ** TREAT THE ...TIC POSITION CASE ** 5694C *************************************** 5695C 5696 IF(ICOM.EQ.'XTIC')GOTO4400 5697 IF(ICOM.EQ.'X1TI')GOTO4400 5698 IF(ICOM.EQ.'X2TI')GOTO4400 5699 IF(ICOM.EQ.'YTIC')GOTO4400 5700 IF(ICOM.EQ.'Y1TI')GOTO4400 5701 IF(ICOM.EQ.'Y2TI')GOTO4400 5702 IF(ICOM.EQ.'TIC')GOTO4400 5703 IF(ICOM.EQ.'TICS')GOTO4400 5704 IF(ICOM.EQ.'XYTI')GOTO4400 5705 IF(ICOM.EQ.'YXTI')GOTO4400 5706 GOTO4499 5707C 5708 4400 CONTINUE 5709 CALL DPTCJU(ICOM,IHARG,NUMARG, 5710 1IX1TJU,IX2TJU,IY1TJU,IY2TJU, 5711 1IFOUND,IERROR) 5712 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5713C 5714 4499 CONTINUE 5715C 5716C ************************************* 5717C ** TREAT THE ...TIC SIZE CASE ** 5718C ************************************* 5719C 5720 IF(ICOM.EQ.'XTIC')GOTO4500 5721 IF(ICOM.EQ.'X1TI')GOTO4500 5722 IF(ICOM.EQ.'X2TI')GOTO4500 5723 IF(ICOM.EQ.'YTIC')GOTO4500 5724 IF(ICOM.EQ.'Y1TI')GOTO4500 5725 IF(ICOM.EQ.'Y2TI')GOTO4500 5726 IF(ICOM.EQ.'TIC')GOTO4500 5727 IF(ICOM.EQ.'TICS')GOTO4500 5728 IF(ICOM.EQ.'XYTI')GOTO4500 5729 IF(ICOM.EQ.'YXTI')GOTO4500 5730 GOTO4599 5731C 5732 4500 CONTINUE 5733 CALL DPTCSZ(ICOM,IHARG,IARGT,ARG,NUMARG, 5734 1DEFTL, 5735 1PX1TLE,PX2TLE,PY1TLE,PY2TLE, 5736 1IFOUND,IERROR) 5737 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5738C 5739 4599 CONTINUE 5740C 5741C ************************************* 5742C ** TREAT THE ...TIC OFFSET CASE ** 5743C ************************************* 5744C 5745 IF(ICOM.EQ.'XTIC')GOTO9400 5746 IF(ICOM.EQ.'X1TI')GOTO9400 5747 IF(ICOM.EQ.'X2TI')GOTO9400 5748 IF(ICOM.EQ.'YTIC')GOTO9400 5749 IF(ICOM.EQ.'Y1TI')GOTO9400 5750 IF(ICOM.EQ.'Y2TI')GOTO9400 5751 IF(ICOM.EQ.'TIC')GOTO9400 5752 IF(ICOM.EQ.'TICS')GOTO9400 5753 IF(ICOM.EQ.'XYTI')GOTO9400 5754 IF(ICOM.EQ.'YXTI')GOTO9400 5755 GOTO9499 5756C 5757 9400 CONTINUE 5758 CALL DPTCOF(ICOM,IHARG,IARGT,ARG,NUMARG, 5759 1DEFTOF,IDEFTU, 5760 1ITICUN, 5761 1PX1TOL,PX2TOL,PY1TOB,PY2TOB, 5762 1PX1TOR,PX2TOR,PY1TOT,PY2TOT, 5763 1IFOUND,IERROR) 5764 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5765C 5766 9499 CONTINUE 5767C 5768C 5769C ************************************************* 5770C ** TREAT THE ...TIC LABEL DISPLACEMENT CASE ** 5771C ************************************************* 5772C 5773 IF(ICOM.EQ.'XTIC')GOTO4700 5774 IF(ICOM.EQ.'X1TI')GOTO4700 5775 IF(ICOM.EQ.'X2TI')GOTO4700 5776 IF(ICOM.EQ.'YTIC')GOTO4700 5777 IF(ICOM.EQ.'Y1TI')GOTO4700 5778 IF(ICOM.EQ.'Y2TI')GOTO4700 5779 IF(ICOM.EQ.'TIC')GOTO4700 5780 IF(ICOM.EQ.'TICS')GOTO4700 5781 IF(ICOM.EQ.'XYTI')GOTO4700 5782 IF(ICOM.EQ.'YXTI')GOTO4700 5783 GOTO4709 5784C 5785CCCCC DECEMBER 1992. FIX BUG. PDEFHG AND PDEFVG ARE THE DEFAULT 5786CCCCC HORIZONTAL AND VERTICAL GAPS, NOT THE DEFAULT DISPLACEMENT. 5787 4700 CONTINUE 5788CCCCC FOLLOWING LINE ADDED DECEMBER 1992. (DEFAULT VERTICAL DISPLACEMENT 5789CCCCC DISPLACEMENT IS 0.5 GREATER THAN DEFAULT HORIZONTAL. 5790 PJUNK=PDEFDS-0.5 5791 CALL DPTLDS(ICOM,IHARG,IARGT,ARG,NUMARG, 5792CCCCC FOLLOWING LINE MODIFIED DECEMBER 1992. 5793CCCCC1PDEFHG,PDEFVG, 5794 1PDEFDS,PJUNK, 5795 1PX1ZDS,PX2ZDS,PY1ZDS,PY2ZDS, 5796 1IFOUND,IERROR) 5797 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5798C 5799 4709 CONTINUE 5800C 5801C ***************************************** 5802C ** TREAT THE ...TIC LABEL FONT CASE ** 5803C ***************************************** 5804C 5805 IF(ICOM.EQ.'XTIC')GOTO4710 5806 IF(ICOM.EQ.'X1TI')GOTO4710 5807 IF(ICOM.EQ.'X2TI')GOTO4710 5808 IF(ICOM.EQ.'YTIC')GOTO4710 5809 IF(ICOM.EQ.'Y1TI')GOTO4710 5810 IF(ICOM.EQ.'Y2TI')GOTO4710 5811 IF(ICOM.EQ.'TIC')GOTO4710 5812 IF(ICOM.EQ.'TICS')GOTO4710 5813 IF(ICOM.EQ.'XYTI')GOTO4710 5814 IF(ICOM.EQ.'YXTI')GOTO4710 5815 GOTO4719 5816C 5817 4710 CONTINUE 5818 CALL DPTLFO(ICOM,IHARG,NUMARG, 5819 1IDEFFO, 5820 1IX1ZFO,IX2ZFO,IY1ZFO,IY2ZFO, 5821 1IFOUND,IERROR) 5822 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5823C 5824 4719 CONTINUE 5825C 5826C ***************************************** 5827C ** TREAT THE ...TIC LABEL CASE CASE ** 5828C ***************************************** 5829C 5830 IF(ICOM.EQ.'XTIC')GOTO4720 5831 IF(ICOM.EQ.'X1TI')GOTO4720 5832 IF(ICOM.EQ.'X2TI')GOTO4720 5833 IF(ICOM.EQ.'YTIC')GOTO4720 5834 IF(ICOM.EQ.'Y1TI')GOTO4720 5835 IF(ICOM.EQ.'Y2TI')GOTO4720 5836 IF(ICOM.EQ.'TIC')GOTO4720 5837 IF(ICOM.EQ.'TICS')GOTO4720 5838 IF(ICOM.EQ.'XYTI')GOTO4720 5839 IF(ICOM.EQ.'YXTI')GOTO4720 5840 GOTO4729 5841C 5842 4720 CONTINUE 5843 CALL DPTLCA(ICOM,IHARG,NUMARG, 5844 1IDEFCA, 5845 1IX1ZCA,IX2ZCA,IY1ZCA,IY2ZCA, 5846 1IFOUND,IERROR) 5847 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5848C 5849 4729 CONTINUE 5850C 5851C ************************************************* 5852C ** TREAT THE ...TIC LABEL JUSTIFICATION CASE ** 5853C ************************************************* 5854C 5855 IF(ICOM.EQ.'XTIC')GOTO4730 5856 IF(ICOM.EQ.'X1TI')GOTO4730 5857 IF(ICOM.EQ.'X2TI')GOTO4730 5858 IF(ICOM.EQ.'YTIC')GOTO4730 5859 IF(ICOM.EQ.'Y1TI')GOTO4730 5860 IF(ICOM.EQ.'Y2TI')GOTO4730 5861 IF(ICOM.EQ.'TIC')GOTO4730 5862 IF(ICOM.EQ.'TICS')GOTO4730 5863 IF(ICOM.EQ.'XYTI')GOTO4730 5864 IF(ICOM.EQ.'YXTI')GOTO4730 5865 GOTO4739 5866C 5867 4730 CONTINUE 5868 CALL DPTLJU(ICOM,IHARG,NUMARG, 5869 1IDEFJU, 5870 1IX1ZJU,IX2ZJU,IY1ZJU,IY2ZJU, 5871 1IFOUND,IERROR) 5872 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5873C 5874 4739 CONTINUE 5875C 5876C ********************************************* 5877C ** TREAT THE ...TIC LABEL DIRECTION CASE ** 5878C ********************************************* 5879C 5880 IF(ICOM.EQ.'XTIC')GOTO4740 5881 IF(ICOM.EQ.'X1TI')GOTO4740 5882 IF(ICOM.EQ.'X2TI')GOTO4740 5883 IF(ICOM.EQ.'YTIC')GOTO4740 5884 IF(ICOM.EQ.'Y1TI')GOTO4740 5885 IF(ICOM.EQ.'Y2TI')GOTO4740 5886 IF(ICOM.EQ.'TIC')GOTO4740 5887 IF(ICOM.EQ.'TICS')GOTO4740 5888 IF(ICOM.EQ.'XYTI')GOTO4740 5889 IF(ICOM.EQ.'YXTI')GOTO4740 5890 GOTO4749 5891C 5892 4740 CONTINUE 5893 CALL DPTLDI(ICOM,IHARG,NUMARG, 5894 1IDEFDI, 5895 1IX1ZDI,IX2ZDI,IY1ZDI,IY2ZDI, 5896 1IFOUND,IERROR) 5897 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5898C 5899 4749 CONTINUE 5900C 5901C ***************************************** 5902C ** TREAT THE ...TIC LABEL FILL CASE ** 5903C ***************************************** 5904C 5905 IF(ICOM.EQ.'XTIC')GOTO4750 5906 IF(ICOM.EQ.'X1TI')GOTO4750 5907 IF(ICOM.EQ.'X2TI')GOTO4750 5908 IF(ICOM.EQ.'YTIC')GOTO4750 5909 IF(ICOM.EQ.'Y1TI')GOTO4750 5910 IF(ICOM.EQ.'Y2TI')GOTO4750 5911 IF(ICOM.EQ.'TIC')GOTO4750 5912 IF(ICOM.EQ.'TICS')GOTO4750 5913 IF(ICOM.EQ.'XYTI')GOTO4750 5914 IF(ICOM.EQ.'YXTI')GOTO4750 5915 GOTO4759 5916C 5917 4750 CONTINUE 5918 CALL DPTLFI(ICOM,IHARG,NUMARG, 5919 1IDEFFI, 5920 1IX1ZFI,IX2ZFI,IY1ZFI,IY2ZFI, 5921 1IFOUND,IERROR) 5922 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5923C 5924 4759 CONTINUE 5925C 5926C ********************************************* 5927C ** TREAT THE ...TIC LABEL THICKNESS CASE ** 5928C ********************************************* 5929C 5930 IF(ICOM.EQ.'XTIC')GOTO4760 5931 IF(ICOM.EQ.'X1TI')GOTO4760 5932 IF(ICOM.EQ.'X2TI')GOTO4760 5933 IF(ICOM.EQ.'YTIC')GOTO4760 5934 IF(ICOM.EQ.'Y1TI')GOTO4760 5935 IF(ICOM.EQ.'Y2TI')GOTO4760 5936 IF(ICOM.EQ.'TIC')GOTO4760 5937 IF(ICOM.EQ.'TICS')GOTO4760 5938 IF(ICOM.EQ.'XYTI')GOTO4760 5939 IF(ICOM.EQ.'YXTI')GOTO4760 5940 GOTO4769 5941C 5942 4760 CONTINUE 5943 CALL DPTLTH(ICOM,IHARG,ARG,NUMARG, 5944 1PDEFTH, 5945 1PTIZTH, 5946 1IFOUND,IERROR) 5947 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5948C 5949 4769 CONTINUE 5950C 5951C ***************************************** 5952C ** TREAT THE ...TIC LABEL ANGLE CASE ** 5953C ***************************************** 5954C 5955 IF(ICOM.EQ.'XTIC')GOTO4770 5956 IF(ICOM.EQ.'X1TI')GOTO4770 5957 IF(ICOM.EQ.'X2TI')GOTO4770 5958 IF(ICOM.EQ.'YTIC')GOTO4770 5959 IF(ICOM.EQ.'Y1TI')GOTO4770 5960 IF(ICOM.EQ.'Y2TI')GOTO4770 5961 IF(ICOM.EQ.'TIC')GOTO4770 5962 IF(ICOM.EQ.'TICS')GOTO4770 5963 IF(ICOM.EQ.'XYTI')GOTO4770 5964 IF(ICOM.EQ.'YXTI')GOTO4770 5965 GOTO4779 5966C 5967 4770 CONTINUE 5968 CALL DPTLAN(ICOM,IHARG,ARG,NUMARG, 5969 1ADEFAN, 5970 1AX1ZAN,AX2ZAN,AY1ZAN,AY2ZAN, 5971 1IFOUND,IERROR) 5972 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5973C 5974 4779 CONTINUE 5975C ************************************* 5976C ** TREAT THE ...TIC LABEL CASE ** 5977C ************************************* 5978C 5979 IF(ICOM.EQ.'XTIC')GOTO4780 5980 IF(ICOM.EQ.'X1TI')GOTO4780 5981 IF(ICOM.EQ.'X2TI')GOTO4780 5982 IF(ICOM.EQ.'YTIC')GOTO4780 5983 IF(ICOM.EQ.'Y1TI')GOTO4780 5984 IF(ICOM.EQ.'Y2TI')GOTO4780 5985 IF(ICOM.EQ.'TIC')GOTO4780 5986 IF(ICOM.EQ.'TICS')GOTO4780 5987 IF(ICOM.EQ.'XYTI')GOTO4780 5988 IF(ICOM.EQ.'YXTI')GOTO4780 5989 GOTO4789 5990C 5991 4780 CONTINUE 5992 CALL DPTL(ICOM,IHARG,NUMARG, 5993 1IX1ZSW,IX2ZSW,IY1ZSW,IY2ZSW, 5994 1IFOUND,IERROR) 5995 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 5996C 5997 4789 CONTINUE 5998C 5999C ***************************************** 6000C ** TREAT THE ...TIC LABEL COLOR CASE ** 6001C ***************************************** 6002C 6003 IF(ICOM.EQ.'XTIC')GOTO4790 6004 IF(ICOM.EQ.'X1TI')GOTO4790 6005 IF(ICOM.EQ.'X2TI')GOTO4790 6006 IF(ICOM.EQ.'YTIC')GOTO4790 6007 IF(ICOM.EQ.'Y1TI')GOTO4790 6008 IF(ICOM.EQ.'Y2TI')GOTO4790 6009 IF(ICOM.EQ.'TIC')GOTO4790 6010 IF(ICOM.EQ.'TICS')GOTO4790 6011 IF(ICOM.EQ.'XYTI')GOTO4790 6012 IF(ICOM.EQ.'YXTI')GOTO4790 6013 GOTO4799 6014C 6015 4790 CONTINUE 6016 CALL DPTLCL(ICOM,IHARG,NUMARG, 6017 1IDEFCO, 6018 1IX1ZCO,IX2ZCO,IY1ZCO,IY2ZCO, 6019 1IFOUND,IERROR) 6020 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6021C 6022 4799 CONTINUE 6023C 6024C ***************************************** 6025C ** TREAT THE ...TIC LABEL SIZE CASE ** 6026C ***************************************** 6027C 6028 IF(ICOM.EQ.'XTIC')GOTO4800 6029 IF(ICOM.EQ.'X1TI')GOTO4800 6030 IF(ICOM.EQ.'X2TI')GOTO4800 6031 IF(ICOM.EQ.'YTIC')GOTO4800 6032 IF(ICOM.EQ.'Y1TI')GOTO4800 6033 IF(ICOM.EQ.'Y2TI')GOTO4800 6034 IF(ICOM.EQ.'TIC')GOTO4800 6035 IF(ICOM.EQ.'TICS')GOTO4800 6036 IF(ICOM.EQ.'XYTI')GOTO4800 6037 IF(ICOM.EQ.'YXTI')GOTO4800 6038 GOTO4809 6039C 6040 4800 CONTINUE 6041 CALL DPTLSZ(ICOM,IHARG,IARGT,ARG,NUMARG, 6042 1PDEFHE,PDEFWI, 6043 1PX1ZHE,PX1ZWI,PX1ZVG,PX1ZHG, 6044 1PX2ZHE,PX2ZWI,PX2ZVG,PX2ZHG, 6045 1PY1ZHE,PY1ZWI,PY1ZVG,PY1ZHG, 6046 1PY2ZHE,PY2ZWI,PY2ZVG,PY2ZHG, 6047 1IFOUND,IERROR) 6048 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6049C 6050 4809 CONTINUE 6051C 6052C ***************************************** 6053C ** TREAT THE ...TIC LABEL FORMAT CASE ** 6054C ***************************************** 6055C 6056 IF(ICOM.EQ.'XTIC')GOTO4810 6057 IF(ICOM.EQ.'X1TI')GOTO4810 6058 IF(ICOM.EQ.'X2TI')GOTO4810 6059 IF(ICOM.EQ.'YTIC')GOTO4810 6060 IF(ICOM.EQ.'Y1TI')GOTO4810 6061 IF(ICOM.EQ.'Y2TI')GOTO4810 6062 IF(ICOM.EQ.'TIC')GOTO4810 6063 IF(ICOM.EQ.'TICS')GOTO4810 6064 IF(ICOM.EQ.'XYTI')GOTO4810 6065 IF(ICOM.EQ.'YXTI')GOTO4810 6066 GOTO4819 6067C 6068 4810 CONTINUE 6069 CALL DPTLFM(ICOM,IHARG,NUMARG, 6070 1IDETLF, 6071 1IX1ZFM,IX2ZFM,IY1ZFM,IY2ZFM, 6072 1IFOUND,IERROR) 6073 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6074C 6075 4819 CONTINUE 6076C 6077C ******************************************* 6078C ** TREAT THE ...TIC LABEL CONTENTS CASE ** 6079C ******************************************* 6080C 6081 IF(ICOM.EQ.'XTIC')GOTO4820 6082 IF(ICOM.EQ.'X1TI')GOTO4820 6083 IF(ICOM.EQ.'X2TI')GOTO4820 6084 IF(ICOM.EQ.'YTIC')GOTO4820 6085 IF(ICOM.EQ.'Y1TI')GOTO4820 6086 IF(ICOM.EQ.'Y2TI')GOTO4820 6087 IF(ICOM.EQ.'TIC')GOTO4820 6088 IF(ICOM.EQ.'TICS')GOTO4820 6089 IF(ICOM.EQ.'XYTI')GOTO4820 6090 IF(ICOM.EQ.'YXTI')GOTO4820 6091 GOTO4829 6092C 6093 4820 CONTINUE 6094 CALL DPTLCN(ICOM,IHARG,NUMARG, 6095CCCCC THE FOLLOWING LINE WAS AUGMENTED SEPTEMBER 1993 6096CCCCC SO AS TO ALLOW LOWER CASE SEPTEMBER 1993 6097CCCCC1IANS,IWIDTH, 6098 1IANS,IANSLC,IWIDTH, 6099 1IX1ZCN,IX2ZCN,IY1ZCN,IY2ZCN, 6100 1IFOUND,IERROR) 6101 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6102C 6103 4829 CONTINUE 6104C 6105C 2019/02: ADD TIC MARK LABEL GAP COMMAND 6106C 6107C ************************************************* 6108C ** TREAT THE ...TIC LABEL GAP CASE ** 6109C ************************************************* 6110C 6111 IF(ICOM.EQ.'XTIC')GOTO4830 6112 IF(ICOM.EQ.'X1TI')GOTO4830 6113 IF(ICOM.EQ.'X2TI')GOTO4830 6114 IF(ICOM.EQ.'YTIC')GOTO4830 6115 IF(ICOM.EQ.'Y1TI')GOTO4830 6116 IF(ICOM.EQ.'Y2TI')GOTO4830 6117 IF(ICOM.EQ.'TIC')GOTO4830 6118 IF(ICOM.EQ.'TICS')GOTO4830 6119 IF(ICOM.EQ.'XYTI')GOTO4830 6120 IF(ICOM.EQ.'YXTI')GOTO4830 6121 GOTO4839 6122C 6123 4830 CONTINUE 6124CCCCC CALL DPTLGA(ICOM,IHARG,IARGT,ARG,NUMARG, 6125CCCCC1 PX1ZGA,PX2ZGA,PY1ZGA,PY2ZGA, 6126CCCCC1 IFOUND,IERROR) 6127 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6128C 6129 4839 CONTINUE 6130C 6131C ********************************** 6132C ** TREAT THE TITLE FONT CASE ** 6133C ********************************** 6134C 6135 IF(ICOM.EQ.'TITL')THEN 6136 CALL DPTIFO(IHARG,NUMARG,IDEFFO,ITITFO,IFOUND,IERROR) 6137 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6138C 6139C ********************************** 6140C ** TREAT THE TITLE CASE CASE ** 6141C ********************************** 6142C 6143 CALL DPTICA(IHARG,NUMARG,IDEFCA,ITITCA,IFOUND,IERROR) 6144 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6145C 6146C ************************************** 6147C ** TREAT THE TITLE THICKNESS CASE ** 6148C ************************************** 6149C 6150 CALL DPTITH(IHARG,ARG,NUMARG,PDEFTH,PTITTH,IFOUND,IERROR) 6151 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6152C 6153CCCCC THE FOLLOWING SECTION WAS ADDED JULY 1989 6154C ************************************** 6155C ** TREAT THE TITLE DISPLACEMENT CASE ** 6156C ************************************** 6157C 6158 CALL DPTIDS(IHARG,ARG,NUMARG,PDEFDS,PTITDS,IFOUND,IERROR) 6159 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6160C 6161C **************************** 6162C ** TREAT THE TITLE CASE ** 6163C **************************** 6164C 6165 CALL DPTIT(IANS,IANSLC,IWIDTH,IHARG,IHARG2,NUMARG, 6166 1 ITITTE,NCTITL,ITIAUT,IBUGP2,IFOUND,IERROR) 6167 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6168C 6169C ********************************** 6170C ** TREAT THE TITLE COLOR CASE ** 6171C ********************************** 6172C 6173 CALL DPTICL(IHARG,NUMARG,IDEFCO,ITITCO,IFOUND,IERROR) 6174 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6175C 6176C ********************************** 6177C ** TREAT THE TITLE SIZE CASE ** 6178C ********************************** 6179C 6180 CALL DPTISZ(IHARG,IARGT,ARG,NUMARG, 6181 1 PDEFHE,PDEFWI, 6182 1 PTITHE,PTITWI,PTITVG,PTITHG, 6183 1 IFOUND,IERROR) 6184 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6185C 6186 ENDIF 6187C 6188C ***************************** 6189C ** TREAT THE NEGATE CASE ** 6190C ***************************** 6191C 6192 IF(ICOM.EQ.'NEGA')THEN 6193 CALL DPNEGA(IHARG,NUMARG,INEGSW,IFOUND,IERROR) 6194 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6195 ENDIF 6196C 6197C ************************************************* 6198C ** TREAT THE WINDOW (CORNER) COORDINATES CASE ** 6199C ************************************************* 6200C 6201 IF(ICOM.EQ.'WIND')GOTO5400 6202 GOTO5499 6203C 6204 5400 CONTINUE 6205 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CORN'.AND. 6206 1IHARG(2).EQ.'COOR')GOTO5411 6207 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COOR') 6208 1GOTO5430 6209 GOTO5499 6210 5411 CONTINUE 6211 ISHIFT=1 6212 GOTO5420 6213 5420 CONTINUE 6214 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 6215 1IBUGP2,IERROR) 6216 GOTO5430 6217 5430 CONTINUE 6218 CALL DPWICC(IHARG,IHARG2,IARGT,ARG,NUMARG, 6219 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,IANS,IWIDTH, 6220 1PWXMIN,PWXMAX,PWYMIN,PWYMAX, 6221 1IBUGP2,IFOUND,IERROR) 6222 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6223C 6224 5499 CONTINUE 6225C 6226C ********************************* 6227C ** TREAT THE HORIZONTAL CASE ** 6228C ********************************* 6229C 6230 IF(ICOM.EQ.'HORI'.AND.IHARG(1).EQ.'SWIT')THEN 6231 CALL DPHRIZ(IHARG,NUMARG,IHORSW,IFOUND,IERROR) 6232 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6233 ENDIF 6234C 6235C ********************************************** 6236C ** TREAT THE MAJOR TIC MARK NUMBER CASE ** 6237C ********************************************** 6238C 6239 IF(ICOM.EQ.'MAJO')GOTO5800 6240C FEBRUARY, 1988: CHECK FOR "MINOR TIC MARK NUMBER" 6241 IF(ICOM.EQ.'MINO')GOTO5899 6242C END CHANGE 6243 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'NUMB')GOTO5800 6244 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'NUMB')GOTO5800 6245 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'NUMB')GOTO5800 6246 IF(NUMARG.GE.4.AND.IHARG(4).EQ.'NUMB')GOTO5800 6247 GOTO5899 6248C 6249 5800 CONTINUE 6250 CALL DPMATN(ICOM,IHARG,IARGT,IARG,NUMARG, 6251 1IX1JSW,IX2JSW,IY1JSW,IY2JSW, 6252 1NMJX1T,NMJX2T,NMJY1T,NMJY2T, 6253 1IFOUND,IERROR) 6254 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6255 6256 5899 CONTINUE 6257C 6258C ********************************************** 6259C ** TREAT THE MINOR TIC MARK NUMBER CASE ** 6260C ********************************************** 6261C 6262 IF(ICOM.EQ.'MINO')GOTO5900 6263 GOTO5999 6264C 6265 5900 CONTINUE 6266 CALL DPMITN(IHARG,IARGT,IARG,NUMARG, 6267 1IX1NSW,IX2NSW,IY1NSW,IY2NSW, 6268 1NMNX1T,NMNX2T,NMNY1T,NMNY2T, 6269 1IFOUND,IERROR) 6270 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6271C 6272 5999 CONTINUE 6273C 6274C ***************************************** 6275C ** TREAT THE ...TIC LABEL HW CASE ** 6276C ***************************************** 6277C 6278 IF(ICOM.EQ.'XTIC')GOTO6000 6279 IF(ICOM.EQ.'X1TI')GOTO6000 6280 IF(ICOM.EQ.'X2TI')GOTO6000 6281 IF(ICOM.EQ.'YTIC')GOTO6000 6282 IF(ICOM.EQ.'Y1TI')GOTO6000 6283 IF(ICOM.EQ.'Y2TI')GOTO6000 6284 IF(ICOM.EQ.'TIC')GOTO6000 6285 IF(ICOM.EQ.'TICS')GOTO6000 6286 IF(ICOM.EQ.'XYTI')GOTO6000 6287 IF(ICOM.EQ.'YXTI')GOTO6000 6288 GOTO6099 6289C 6290 6000 CONTINUE 6291 CALL DPTLHW(ICOM,IHARG,IARGT,ARG,NUMARG, 6292 1PDEFHE,PDEFWI, 6293 1PX1ZHE,PX1ZWI,PX1ZVG,PX1ZHG, 6294 1PX2ZHE,PX2ZWI,PX2ZVG,PX2ZHG, 6295 1PY1ZHE,PY1ZWI,PY1ZVG,PY1ZHG, 6296 1PY2ZHE,PY2ZWI,PY2ZVG,PY2ZHG, 6297 1IFOUND,IERROR) 6298 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6299C 6300 6099 CONTINUE 6301C 6302C ******************************************** 6303C ** TREAT THE MAJOR TIC COORDINATES CASE ** 6304C ******************************************** 6305C 6306 IF(ICOM.EQ.'MAJO')THEN 6307 CALL DPMJTC(ICOM,IHARG,IARGT,ARG,NUMARG, 6308 1 IX1TSW,IX2TSW,IY1TSW,IY2TSW, 6309 1 X1COOR,X2COOR,Y1COOR,Y2COOR, 6310 1 NX1COO,NX2COO,NY1COO,NY2COO, 6311 1 MAXTIC, 6312 1 IFOUND,IERROR) 6313 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6314 ENDIF 6315C 6316C ******************************************** 6317C ** TREAT THE MINOR TIC COORDINATES CASE ** 6318C ******************************************** 6319C 6320 IF(ICOM.EQ.'MINO')THEN 6321 CALL DPMNTC(ICOM,IHARG,IARGT,ARG,NUMARG, 6322 1 X1COMN,X2COMN,Y1COMN,Y2COMN, 6323 1 NX1CMN,NX2CMN,NY1CMN,NY2CMN, 6324 1 MAXTIC, 6325 1 IFOUND,IERROR) 6326 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6327 ENDIF 6328C 6329C *********************************** 6330C ** TREAT THE FILL COLORS CASE ** 6331C *********************************** 6332C 6333CCCCC IF(ICOM.EQ.'FILL'.AND.IHARG(1).EQ.'COLO')GOTO6500 6334CCCCC GOTO6599 6335C 6336C6500 CONTINUE 6337CCCCC CALL DPFICO(IHARG,NUMARG,IDEFFC,MAXFIL,IFILCO, 6338CCCCC1IBUGP2,IFOUND,IERROR) 6339CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6340C 6341C6599 CONTINUE 6342C 6343C *********************************** 6344C ** TREAT THE FILL SPACING CASE ** 6345C *********************************** 6346C 6347CCCCC IF(ICOM.EQ.'FILL'.AND.IHARG(1).EQ.'SPAC')GOTO6600 6348CCCCC GOTO6699 6349C 6350C6600 CONTINUE 6351CCCCC CALL DPFISP(IHARG,IARGT,ARG,NUMARG,PDPFFG,MAXFIL,PFILSP, 6352CCCCC1IBUGP2,IFOUND,IERROR) 6353CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6354C 6355C6699 CONTINUE 6356C 6357C ************************************* 6358C ** TREAT THE FILL THICKNESS CASE ** 6359C ************************************* 6360C 6361CCCCC IF(ICOM.EQ.'FILL'.AND.IHARG(1).EQ.'THIC')GOTO6700 6362CCCCC GOTO6799 6363C 6364C6700 CONTINUE 6365CCCCC CALL DPFITH(IHARG,IARGT,ARG,NUMARG,PDEFFT,MAXFIL,PFILTH, 6366CCCCC1IBUGP2,IFOUND,IERROR) 6367CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6368C 6369C6799 CONTINUE 6370C 6371C ******************************** 6372C ** TREAT THE FILL BASE CASE ** 6373C ******************************** 6374C 6375CCCCC IF(ICOM.EQ.'FILL'.AND.IHARG(1).EQ.'BASE')GOTO6800 6376CCCCC IF(ICOM.EQ.'FILL'.AND.IHARG(1).EQ.'REFE')GOTO6800 6377CCCCC1 GOTO6899 6378C 6379C6800 CONTINUE 6380CCCCC CALL DPFIBA(IHARG,IARGT,ARG,NUMARG,ADEFFB,MAXFIL,AFILBA, 6381CCCCC1IBUGP2,IFOUND,IERROR) 6382CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6383C 6384C6899 CONTINUE 6385C 6386C *********************************** 6387C ** TREAT THE FILL (SWITCH) CASE ** 6388C *********************************** 6389C 6390CCCCC IF(ICOM.EQ.'FILL')GOTO6900 6391CCCCC GOTO6999 6392C 6393C6900 CONTINUE 6394CCCCC IF(IHARG(1).EQ.'ON')GOTO6910 6395CCCCC IF(IHARG(2).EQ.'ON')GOTO6910 6396CCCCC IF(IHARG(1).EQ.'OFF')GOTO6910 6397CCCCC IF(IHARG(2).EQ.'OFF')GOTO6910 6398CCCCC GOTO6999 6399C6910 CONTINUE 6400CCCCC CALL DPFISW(IHARG,NUMARG,IDEFFS,MAXFIL,IFILSW, 6401CCCCC1IBUGP2,IFOUND,IERROR) 6402CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6403C 6404C6999 CONTINUE 6405C 6406C ************************************* 6407C ** TREAT THE FILL (PATTERN) CASE ** 6408C ************************************* 6409C 6410CCCCC IF(ICOM.EQ.'FILL')GOTO7000 6411CCCCC GOTO7099 6412C 6413C7000 CONTINUE 6414CCCCC CALL DPFIPA(IHARG,NUMARG,IDEFFP,MAXFIL,IFILPA, 6415CCCCC1IBUGP2,IFOUND,IERROR) 6416CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6417C 6418C7099 CONTINUE 6419C 6420C ************************************* 6421C ** TREAT THE PATTERN LINE CASE ** 6422C ************************************* 6423C 6424 IF(ICOM.EQ.'PATT'.AND.IHARG(1).EQ.'LINE')GOTO7100 6425 GOTO7199 6426C 6427 7100 CONTINUE 6428 CALL DPPALI(IHARG,NUMARG,IDEFPL,MAXPAT,IPATLI, 6429 1IBUGP2,IFOUND,IERROR) 6430 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6431C 6432 7199 CONTINUE 6433C 6434C ************************************** 6435C ** TREAT THE PATTERN SPACING CASE ** 6436C ************************************** 6437C 6438 IF(ICOM.EQ.'PATT'.AND.IHARG(1).EQ.'SPAC')GOTO7200 6439 GOTO7299 6440C 6441 7200 CONTINUE 6442 CALL DPPASP(IHARG,IARGT,ARG,NUMARG, 6443 1 PDEFPG,MAXPAT,PPATSP, 6444 1 IBUGP2,IFOUND,IERROR) 6445 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6446C 6447 7299 CONTINUE 6448C 6449C **************************************** 6450C ** TREAT THE PATTERN THICKNESS CASE ** 6451C **************************************** 6452C 6453 IF(ICOM.EQ.'PATT'.AND.IHARG(1).EQ.'THIC')GOTO7300 6454 GOTO7399 6455C 6456 7300 CONTINUE 6457 CALL DPPATH(IHARG,IARGT,ARG,NUMARG,PDEFPT,MAXPAT,PPATTH, 6458 1IBUGP2,IFOUND,IERROR) 6459 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6460C 6461 7399 CONTINUE 6462C 6463C **************************************** 6464C ** TREAT THE PATTERN HEIGHT CASE ** 6465C **************************************** 6466C 6467 IF(ICOM.EQ.'PATT'.AND.IHARG(1).EQ.'HEIG')GOTO7400 6468 GOTO7499 6469C 6470 7400 CONTINUE 6471 CALL DPPAHE(IHARG,IARGT,ARG,NUMARG,PDEFPH,MAXPAT,PPATHE, 6472 1IBUGP2,IFOUND,IERROR) 6473 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6474C 6475 7499 CONTINUE 6476C 6477C **************************************** 6478C ** TREAT THE PATTERN WIDTH CASE ** 6479C **************************************** 6480C 6481 IF(ICOM.EQ.'PATT'.AND.IHARG(1).EQ.'WIDT')GOTO7500 6482 GOTO7599 6483C 6484 7500 CONTINUE 6485 CALL DPPAWI(IHARG,IARGT,ARG,NUMARG,PDEFPW,MAXPAT,PPATWI, 6486 1IBUGP2,IFOUND,IERROR) 6487 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6488C 6489 7599 CONTINUE 6490C 6491C ************************************* 6492C ** TREAT THE PATTERN COLOR CASE ** 6493C ************************************* 6494C 6495 IF(ICOM.EQ.'PATT'.AND.IHARG(1).EQ.'COLO')GOTO7600 6496 GOTO7699 6497C 6498 7600 CONTINUE 6499 CALL DPPACO(IHARG,NUMARG,IDEFPC,MAXPAT,IPATCO, 6500 1IBUGP2,IFOUND,IERROR) 6501 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6502C 6503 7699 CONTINUE 6504C 6505C ************************************** 6506C ** TREAT THE PATTERN (SWITCH) CASE ** 6507C ************************************** 6508C 6509 IF(ICOM.EQ.'PATT')GOTO7700 6510 GOTO7799 6511C 6512 7700 CONTINUE 6513 IF(IHARG(1).EQ.'ON')GOTO7710 6514 IF(IHARG(2).EQ.'ON')GOTO7710 6515 IF(IHARG(1).EQ.'OFF')GOTO7710 6516 IF(IHARG(2).EQ.'OFF')GOTO7710 6517 GOTO7799 6518 7710 CONTINUE 6519 CALL DPPASW(IHARG,NUMARG,IDEFPS,MAXPAT,IPATSW, 6520 1IBUGP2,IFOUND,IERROR) 6521 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6522C 6523 7799 CONTINUE 6524C 6525C **************************************** 6526C ** TREAT THE PATTERN (PATTERN) CASE ** 6527C **************************************** 6528C 6529 IF(ICOM.EQ.'PATT')GOTO7800 6530 GOTO7899 6531C 6532 7800 CONTINUE 6533 CALL DPPAPA(IHARG,NUMARG,IDEFPP,MAXPAT,IPATPA, 6534 1IBUGP2,IFOUND,IERROR) 6535 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6536C 6537 7899 CONTINUE 6538C 6539C *********************************** 6540C ** TREAT THE SPIKE COLORS CASE ** 6541C *********************************** 6542C 6543 IF(ICOM.EQ.'SPIK'.AND.IHARG(1).EQ.'COLO')GOTO8100 6544 GOTO8199 6545C 6546 8100 CONTINUE 6547 CALL DPSPCO(IHARG,NUMARG,IDEFSC,MAXSPI,ISPICO, 6548 1IBUGP2,IFOUND,IERROR) 6549 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6550C 6551 8199 CONTINUE 6552C 6553C ************************************* 6554C ** TREAT THE SPIKE THICKNESS CASE ** 6555C ************************************* 6556C 6557 IF(ICOM.EQ.'SPIK'.AND.IHARG(1).EQ.'THIC')GOTO8200 6558 GOTO8299 6559C 6560 8200 CONTINUE 6561 CALL DPSPTH(IHARG,IARGT,ARG,NUMARG,PDEFST,MAXSPI,PSPITH, 6562 1IBUGP2,IFOUND,IERROR) 6563 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6564C 6565 8299 CONTINUE 6566C 6567C ************************************* 6568C ** TREAT THE SPIKE LINE CASE ** 6569C ************************************* 6570C 6571 IF(ICOM.EQ.'SPIK'.AND.IHARG(1).EQ.'LINE')GOTO8300 6572 GOTO8399 6573C 6574 8300 CONTINUE 6575CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC 6576CCCCC CALL DPSPLI(IHARG,NUMARG,IDEFSL,MAXSPI,ISPILI, 6577 CALL DPSPLI(IHARG,IHARG2,NUMARG,IDEFSL,MAXSPI,ISPILI, 6578 1IBUGP2,IFOUND,IERROR) 6579 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6580C 6581 8399 CONTINUE 6582C 6583C ******************************** 6584C ** TREAT THE SPIKE BASE CASE ** 6585C ******************************** 6586C 6587 IF(ICOM.EQ.'SPIK'.AND.IHARG(1).EQ.'BASE')GOTO8400 6588 IF(ICOM.EQ.'SPIK'.AND.IHARG(1).EQ.'REFE')GOTO8400 6589 GOTO8499 6590C 6591 8400 CONTINUE 6592CCCCC CALL DPSPBA(IHARG,IARGT,ARG,NUMARG,ADEFSB,MAXSPI,ASPIBA, 6593 CALL DPSPBA(ADEFSB,MAXSPI,ASPIBA, 6594 1IBUGP2,IFOUND,IERROR) 6595 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6596C 6597 8499 CONTINUE 6598C 6599C ************************************** 6600C ** TREAT THE SPIKE DIRECTION CASE ** 6601C ************************************** 6602C 6603 IF(ICOM.EQ.'SPIK'.AND.IHARG(1).EQ.'DIRE')GOTO8500 6604 GOTO8599 6605C 6606 8500 CONTINUE 6607 CALL DPSPDI(IHARG,NUMARG,IDEFSD,MAXSPI,ISPIDI, 6608 1IBUGP2,IFOUND,IERROR) 6609 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6610C 6611 8599 CONTINUE 6612C 6613C *********************************** 6614C ** TREAT THE SPIKE (SWITCH) CASE** 6615C *********************************** 6616C 6617 IF(ICOM.EQ.'SPIK')GOTO8600 6618 GOTO8699 6619C 6620 8600 CONTINUE 6621 IF(IHARG(1).EQ.'ON')GOTO8610 6622 IF(IHARG(2).EQ.'ON')GOTO8610 6623 IF(IHARG(1).EQ.'OFF')GOTO8610 6624 IF(IHARG(2).EQ.'OFF')GOTO8610 6625 GOTO8699 6626 8610 CONTINUE 6627 CALL DPSPSW(IHARG,NUMARG,IDEFSS,MAXSPI,ISPISW, 6628 1IBUGP2,IFOUND,IERROR) 6629 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6630C 6631 8699 CONTINUE 6632C 6633C ************************************* 6634C ** TREAT THE SPIKE (PATTERN) CASE ** 6635C ** (SAME AS SPIKE LINES CASE) ** 6636C ************************************* 6637C 6638 IF(ICOM.EQ.'SPIK')GOTO8700 6639 GOTO8799 6640C 6641 8700 CONTINUE 6642CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC 6643CCCCC CALL DPSPPA(IHARG,NUMARG,IDEFSL,MAXSPI,ISPILI, 6644 CALL DPSPPA(IHARG,IHARG2,NUMARG,IDEFSL,MAXSPI,ISPILI, 6645 1IBUGP2,IFOUND,IERROR) 6646 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6647C 6648 8799 CONTINUE 6649C 6650C *************************************** 6651C ** TREAT THE SUBREGION (SWITCH) CASE** 6652C *************************************** 6653C 6654 IF(ICOM.EQ.'SUBR')THEN 6655 IF(IHARG(1).EQ.'ON'.OR.IHARG(2).EQ.'ON'.OR. 6656 1 IHARG(1).EQ.'OFF'.OR.IHARG(2).EQ.'OFF')THEN 6657 CALL DPSBSW(IHARG,NUMARG,IDEFSB,MAXSUB,ISUBSW, 6658 1 IBUGP2,IFOUND,IERROR) 6659 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6660 ENDIF 6661 ENDIF 6662C 6663C *************************************** 6664C ** TREAT THE SUBREGION LIMITS CASE** 6665C *************************************** 6666C 6667 IF(ICOM.EQ.'SUBR')THEN 6668 CALL DPSBLI(ICOM,IHARG,IARGT,ARG,NUMARG, 6669 1 ASUBXL,ASUBXU,ASUBYL,ASUBYU, 6670 1 MAXSUB, 6671 1 IFOUND,IERROR) 6672 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6673 ENDIF 6674C 6675C 6676C *************************** 6677C ** TREAT THE MINOR GRID CASE ** 6678C *************************** 6679C 6680 IF(ICOM.EQ.'XGMI')GOTO8800 6681 IF(ICOM.EQ.'YGMI')GOTO8800 6682 IF(ICOM.EQ.'XYGM')GOTO8800 6683 IF(ICOM.EQ.'YXGM')GOTO8800 6684 IF(ICOM.EQ.'GMIN')GOTO8800 6685 IF(ICOM.EQ.'MINO')GOTO8800 6686 GOTO8899 6687C 6688 8800 CONTINUE 6689 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO8899 6690 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PATT')GOTO8899 6691 CALL DPGRMN(ICOM,IHARG,NUMARG,IVGMSW,IHGMSW,IFOUND,IERROR) 6692 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6693C 6694 8899 CONTINUE 6695C 6696C **************************************************** 6697C ** TREAT THE MULTIPLOT (CORNER) COORDINATES CASE ** 6698C **************************************************** 6699C 6700 IF((ICOM.EQ.'MULT' .AND. IHARG(1).EQ.'CORN') .OR. 6701 1 (ICOM.EQ.'MULT' .AND. IHARG(1).EQ.'COOR') .OR. 6702 1 (ICOM.EQ.'MP ' .AND. IHARG(1).EQ.'CORN') .OR. 6703 1 (ICOM.EQ.'MP ' .AND. IHARG(1).EQ.'COOR'))THEN 6704C 6705 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CORN'.AND. 6706 1 IHARG(2).EQ.'COOR')THEN 6707 ISHIFT=1 6708 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 6709 1 IBUGP2,IERROR) 6710 ENDIF 6711C 6712 CALL DPMUCC(IHARG,IHARG2,IARGT,ARG,NUMARG, 6713 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE, 6714 1 NUMNAM,MAXNAM,IANS,IWIDTH, 6715 1 PMXMIN,PMXMAX,PMYMIN,PMYMAX, 6716 1 IBUGP2,IFOUND,IERROR) 6717 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6718C 6719 ENDIF 6720C 6721C **************************************************** 6722C ** TREAT THE END OF MULTIPLOT CASE ** 6723C **************************************************** 6724C 6725 IF(ICOM.EQ.'END')GOTO9200 6726CCCCC THE FOLLOWING 2 LINES WERE ADDED AUGUST 1990 6727 IF(ICOM.EQ.'EOMP')GOTO9210 6728 IF(ICOM.EQ.'EMP')GOTO9210 6729 GOTO9299 6730C 6731 9200 CONTINUE 6732 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'OF'.AND. 6733 1IHARG(2).EQ.'MULT')GOTO9210 6734 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MULT') 6735 1GOTO9210 6736 GOTO9299 6737 9210 CONTINUE 6738 CALL DPENMU(IMPSW, 6739 1IERASV, 6740 1PWXMIS,PWXMAS,PWYMIS,PWYMAS, 6741 1IERASW, 6742 1PWXMIN,PWXMAX,PWYMIN,PWYMAX, 6743 1IBUGP2,IFOUND,IERROR) 6744 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6745C 6746 9299 CONTINUE 6747C 6748C **************************************************** 6749C ** TREAT THE MULTIPLOT CASE ** 6750C **************************************************** 6751C 6752 IF(ICOM.EQ.'MULT' .OR. ICOM.EQ.'MP')GOTO9300 6753 GOTO9399 6754C 6755 9300 CONTINUE 6756 IF(ICOM2.EQ.'IPLE')GOTO9399 6757 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CONT')GOTO9399 6758 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'GRUB')GOTO9399 6759 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TIET')GOTO9399 6760 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ESD ')GOTO9399 6761 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FREQ')GOTO9399 6762 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'FREQ')GOTO9399 6763 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'FREQ')GOTO9399 6764 IF(NUMARG.GE.4.AND.IHARG(4).EQ.'FREQ')GOTO9399 6765 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'KERN')GOTO9399 6766 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'KERN')GOTO9399 6767 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'KERN')GOTO9399 6768 IF(NUMARG.GE.4.AND.IHARG(4).EQ.'KERN')GOTO9399 6769 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LORE')GOTO9399 6770 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'LORE')GOTO9399 6771 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'LORE')GOTO9399 6772 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ADJA')GOTO9399 6773 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'ADJA')GOTO9399 6774 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ADJA')GOTO9399 6775 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ALLA')GOTO9399 6776 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'ALLA')GOTO9399 6777 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'AV')GOTO9399 6778 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'AV')GOTO9399 6779 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'AS')GOTO9399 6780 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'AS')GOTO9399 6781 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ASD')GOTO9399 6782 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'ASD')GOTO9399 6783 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SPEC')GOTO9399 6784 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PERI')GOTO9399 6785 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'AUTO')GOTO9399 6786 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PART')GOTO9399 6787 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CO ')GOTO9399 6788 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COSP')GOTO9399 6789 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'QUAD')GOTO9399 6790 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CROS')GOTO9399 6791 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COHE')GOTO9399 6792 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'AMPL')GOTO9399 6793 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PHAS')GOTO9399 6794 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'GAIN')GOTO9399 6795 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ARGA')GOTO9399 6796 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TAIL')GOTO9399 6797 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SURV')GOTO9399 6798 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CONF')GOTO9399 6799 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DIFF')GOTO9399 6800 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LEVE')GOTO9399 6801 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COCH')GOTO9399 6802 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PROP')GOTO9399 6803 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ANOP')GOTO9399 6804 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ANAL')GOTO9399 6805 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'COMM' .AND. 6806 1 IHARG(2).EQ.'WEIB')GOTO9399 6807 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'EMPI' .AND. 6808 1 IHARG(2).EQ.'QUAN')GOTO9399 6809 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CUMU' .AND. 6810 1 IHARG(2).EQ.'SUM')GOTO9399 6811 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LJUN' .AND. 6812 1 IHARG(2).EQ.'BOX')GOTO9399 6813 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BOX' .AND. 6814 1 IHARG(2).EQ.'COX')GOTO9399 6815 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'BOX')GOTO9399 6816 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'BOX')GOTO9399 6817 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SYMM')GOTO9399 6818C 6819 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'I')GOTO9399 6820 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'I')GOTO9399 6821 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MEAN'.AND. 6822 1 IHARG(2).EQ.'CONF')GOTO9399 6823 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MEAN'.AND. 6824 1 IHARG(3).EQ.'CONF')GOTO9399 6825 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MEDI'.AND. 6826 1 IHARG(2).EQ.'CONF')GOTO9399 6827 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MEDI'.AND. 6828 1 IHARG(3).EQ.'CONF')GOTO9399 6829 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'TRIM'.AND. 6830 1 IHARG(2).EQ.'MEAN')GOTO9399 6831 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'TRIM'.AND. 6832 1 IHARG(3).EQ.'MEAN')GOTO9399 6833 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BIWE'.AND. 6834 1 IHARG(2).EQ.'CONF')GOTO9399 6835 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'BIWE'.AND. 6836 1 IHARG(3).EQ.'CONF')GOTO9399 6837 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'QUAN'.AND. 6838 1 IHARG(2).EQ.'CONF')GOTO9399 6839 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'QUAN'.AND. 6840 1 IHARG(3).EQ.'CONF')GOTO9399 6841 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ONE '.AND. 6842 1 IHARG(2).EQ.'STAN'.AND.IHARG(3).EQ.'ERRO')GOTO9399 6843 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'ONE '.AND. 6844 1 IHARG(3).EQ.'STAN'.AND.IHARG(4).EQ.'ERRO')GOTO9399 6845 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'TWO '.AND. 6846 1 IHARG(2).EQ.'STAN'.AND.IHARG(3).EQ.'ERRO')GOTO9399 6847 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'TWO '.AND. 6848 1 IHARG(3).EQ.'STAN'.AND.IHARG(4).EQ.'ERRO')GOTO9399 6849 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ONE '.AND. 6850 1 IHARG(2).EQ.'STAN'.AND.IHARG(3).EQ.'DEVI')GOTO9399 6851 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'ONE '.AND. 6852 1 IHARG(3).EQ.'STAN'.AND.IHARG(4).EQ.'DEVI')GOTO9399 6853 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'TWO '.AND. 6854 1 IHARG(2).EQ.'STAN'.AND.IHARG(3).EQ.'DEVI')GOTO9399 6855 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'TWO '.AND. 6856 1 IHARG(3).EQ.'STAN'.AND.IHARG(4).EQ.'DEVI')GOTO9399 6857 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'NORM'.AND. 6858 1 IHARG(2).EQ.'TOLE')GOTO9399 6859 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'NORM'.AND. 6860 1 IHARG(3).EQ.'TOLE')GOTO9399 6861 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'NORM'.AND. 6862 1 IHARG(2).EQ.'PRED')GOTO9399 6863 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'NORM'.AND. 6864 1 IHARG(3).EQ.'PRED')GOTO9399 6865 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'AGRE'.AND. 6866 1 IHARG(2).EQ.'COUL')GOTO9399 6867 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'AGRE'.AND. 6868 1 IHARG(3).EQ.'COUL')GOTO9399 6869C 6870 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'VIOL')GOTO9399 6871 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'VIOL')GOTO9399 6872 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'HOMO')GOTO9399 6873 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'PERC'.AND. 6874 1 IHARG(2).EQ.'POIN'.AND.IHARG(3).EQ.'PLOT')GOTO9399 6875 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'BEST' .AND. 6876 1 IHARG(2).EQ.'DIST'.AND.IHARG(3).EQ.'FIT')GOTO9399 6877 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'RUN ' .AND. 6878 1 IHARG(2).EQ.'SEQU')GOTO9399 6879 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'KRUS' .AND. 6880 1 IHARG(2).EQ.'WALL')GOTO9399 6881 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SQUA' .AND. 6882 1 IHARG(2).EQ.'RANK')GOTO9399 6883 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MEDI' .AND. 6884 1 IHARG(2).EQ.'TEST')GOTO9399 6885 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'ANDE' .AND. 6886 1 IHARG(2).EQ.'DARL')GOTO9399 6887 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'VAN ' .AND. 6888 1 IHARG(2).EQ.'DER '.AND.IHARG(3).EQ.'WAER')GOTO9399 6889 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ONE ' .AND. 6890 1 IHARG(2).EQ.'WAY '.AND.IHARG(3).EQ.'NORM')GOTO9399 6891 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'WILK' .AND. 6892 1 IHARG(2).EQ.'SHAP')GOTO9399 6893 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SHAP' .AND. 6894 1 IHARG(2).EQ.'WILK')GOTO9399 6895 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'NORM' .AND. 6896 1 IHARG(2).EQ.'TOLE')GOTO9399 6897 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'NONP' .AND. 6898 1 IHARG(2).EQ.'TOLE')GOTO9399 6899 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TOLE')GOTO9399 6900 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BEST' .AND. 6901 1 IHARG(2).EQ.'DIST')GOTO9399 6902 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'T '.AND. 6903 1 IHARG(2).EQ.'TEST')GOTO9399 6904 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'T '.AND. 6905 1 IHARG(3).EQ.'TEST')GOTO9399 6906 IF(NUMARG.GE.4.AND.IHARG(3).EQ.'T '.AND. 6907 1 IHARG(4).EQ.'TEST')GOTO9399 6908 IF(NUMARG.GE.5.AND.IHARG(4).EQ.'T '.AND. 6909 1 IHARG(5).EQ.'TEST')GOTO9399 6910 IF(NUMARG.GE.6.AND.IHARG(5).EQ.'T '.AND. 6911 1 IHARG(6).EQ.'TEST')GOTO9399 6912 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BART'.AND. 6913 1 IHARG(2).EQ.'TEST')GOTO9399 6914 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'DM '.AND. 6915 1 IHARG(2).EQ.'BART')GOTO9399 6916 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'DIXO' .AND. 6917 1 IHARG(2).EQ.'MASS'.AND.IHARG(3).EQ.'BART')GOTO9399 6918 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'F '.AND. 6919 1 IHARG(2).EQ.'LOC ')GOTO9399 6920 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SUMM')GOTO9399 6921 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CAPA')GOTO9399 6922 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'RUNS')GOTO9399 6923 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'JARQ'.AND. 6924 1 IHARG(2).EQ.'BERA')GOTO9399 6925 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PRED')GOTO9399 6926 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LOWE')GOTO9399 6927 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'UPPE')GOTO9399 6928 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SD ' .AND. 6929 1 IHARG(2).EQ.'CONF')GOTO9399 6930 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'STAN' .AND. 6931 1 IHARG(2).EQ.'DEVI'.AND.IHARG(3).EQ.'CONF')GOTO9399 6932 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'STAN' .AND. 6933 1 IHARG(2).EQ.'DEVI'.AND.IHARG(3).EQ.'PRED')GOTO9399 6934 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'ONE ' .AND. 6935 1 IHARG(2).EQ.'SIDE')GOTO9399 6936 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'DIST' .AND. 6937 1 IHARG(2).EQ.'FIT '.AND.IHARG(3).EQ.'PLOT')GOTO9399 6938 IF(NUMARG.GE.4.AND.IHARG(1).EQ.'COEF' .AND. 6939 1 IHARG(2).EQ.'OF '.AND. IHARG(3).EQ.'VARI' .AND. 6940 1 IHARG(4).EQ.'CONF')GOTO9399 6941 IF(NUMARG.GE.4.AND.IHARG(1).EQ.'COEF' .AND. 6942 1 IHARG(2).EQ.'OF '.AND. IHARG(3).EQ.'DISP' .AND. 6943 1 IHARG(4).EQ.'CONF')GOTO9399 6944 IF(NUMARG.GE.4.AND.IHARG(1).EQ.'COEF' .AND. 6945 1 IHARG(2).EQ.'OF '.AND.IHARG(3).EQ.'QUAR' .AND. 6946 1 IHARG(4).EQ.'DISP'.AND.IHARG(5).EQ.'CONF')GOTO9399 6947 IF(NUMARG.GE.4.AND.IHARG(1).EQ.'COEF' .AND. 6948 1 IHARG(2).EQ.'OF '.AND.IHARG(3).EQ.'QUAR' .AND. 6949 1 IHARG(4).EQ.'VARI'.AND.IHARG(5).EQ.'CONF')GOTO9399 6950 IF(NUMARG.GE.4.AND.IHARG(1).EQ.'QUAR' .AND. 6951 1 IHARG(2).EQ.'COEF'.AND.IHARG(3).EQ.'OF ' .AND. 6952 1 IHARG(4).EQ.'DISP'.AND.IHARG(5).EQ.'CONF')GOTO9399 6953 IF(NUMARG.GE.4.AND.IHARG(1).EQ.'QUAR' .AND. 6954 1 IHARG(2).EQ.'COEF'.AND.IHARG(3).EQ.'OF ' .AND. 6955 1 IHARG(4).EQ.'VARI'.AND.IHARG(5).EQ.'CONF')GOTO9399 6956C 6957 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT'.AND. 6958 1IHARG2(1).EQ.' ') 6959 1GOTO9311 6960 GOTO9330 6961 9311 CONTINUE 6962 ISHIFT=1 6963 GOTO9320 6964 9320 CONTINUE 6965 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 6966 1IBUGP2,IERROR) 6967 GOTO9330 6968 9330 CONTINUE 6969 CALL DPMULT(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 6970 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,IANS,IWIDTH, 6971 1IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9, 6972CCCCC ADD FOLLOWING LINE. AUGUST 1999. 6973 1IMPARG, 6974CCCCC ADD FOLLOWING LINE. SEPTEMBER 1998. 6975 1AMPSCH,AMPSCW, 6976 1PMXMIN,PMXMAX,PMYMIN,PMYMAX, 6977 1IERASW, 6978 1PWXMIN,PWXMAX,PWYMIN,PWYMAX, 6979 1IERASV, 6980 1PWXMIS,PWXMAS,PWYMIS,PWYMAS, 6981 1IBUGP2,IFOUND,IERROR) 6982 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6983C 6984 9399 CONTINUE 6985C 6986C **************************************************** 6987C ** TREAT THE EMBED CASE ** 6988C **************************************************** 6989C 6990 IF(ICOM.EQ.'EMBE')THEN 6991 CALL DPEMBE(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,ICOM,IERASW, 6992 1 IEMBSW,IEMCNT,PEMXC1,PEMXC2,PEMYC1,PEMYC2, 6993 1 PWXMIN,PWXMAX,PWYMIN,PWYMAX, 6994 1 IBUGP2,ISUBRO,IFOUND,IERROR) 6995 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 6996 ENDIF 6997C 6998CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 1990 6999C ************************************* 7000C ** TREAT THE WINDOW SYSTEM CASE ** 7001C ************************************* 7002C 7003CCCCC IF(ICOM.EQ.'WIND'.AND.IHARG(1).EQ.'SYST')GOTO11100 7004CCCCC IF(ICOM.EQ.'WIND'.AND.IHARG(1).EQ.'MANA')GOTO11100 7005CCCCC GOTO11199 7006C 7007C11100 CONTINUE 7008CCCCC CALL DPWISY(IHARG,NUMARG,IDEFWS,IWINSY, 7009CCCCC 1IBUGP2,IFOUND,IERROR) 7010CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7011C 7012C11199 CONTINUE 7013C 7014CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 1990 7015C ************************************* 7016C ** TREAT THE WINDOW POINTER CASE ** 7017C ************************************* 7018C 7019CCCCC IF(ICOM.EQ.'WIND'.AND.IHARG(1).EQ.'POIN')GOTO11200 7020CCCCC IF(ICOM.EQ.'WIND'.AND.IHARG(1).EQ.'SELE')GOTO11200 7021CCCCC GOTO11299 7022C 7023C11200 CONTINUE 7024CCCCC CALL DPWIPO(IHARG,NUMARG,IDEFWP,IWINPO, 7025CCCCC 1IBUGP2,IFOUND,IERROR) 7026CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7027C 7028C *********************************** 7029C ** TREAT THE PIXMAP TITLE CASE ** 7030C *********************************** 7031C 7032 IF(ICOM.EQ.'PIXM'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'TITL')THEN 7033 CALL DPPMTI(IANS,IANSLC,IWIDTH,IHARG,IHARG2,NUMARG, 7034 1 IBUGP2,IFOUND,IERROR) 7035 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7036 ENDIF 7037C 7038C ***************** 7039C ** STEP 90-- ** 7040C ** EXIT ** 7041C ***************** 7042C 7043 9000 CONTINUE 7044 IF(IBUGPC.EQ.'ON' .OR. ISUBRO.EQ.'IPC2')THEN 7045 WRITE(ICOUT,999) 7046 CALL DPWRST('XXX','BUG ') 7047 WRITE(ICOUT,9011) 7048 9011 FORMAT('***** AT THE END OF MAIPC2--') 7049 CALL DPWRST('XXX','BUG ') 7050 WRITE(ICOUT,9020)IFOUND,IERROR 7051 9020 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 7052 CALL DPWRST('XXX','BUG ') 7053 ENDIF 7054C 7055 RETURN 7056 END 7057 SUBROUTINE MAIPC3(IBUGPC,IBUGP2,ISUBRO, 7058 1 IVGMSW,IHGMSW, 7059 1 IMPSW,IMPNR,IMPNC,IMPCO, 7060 1 PMXMIN,PMXMAX,PMYMIN,PMYMAX, 7061 1 IERASV, 7062 1 PWXMIS,PWXMAS,PWYMIS,PWYMAS, 7063CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1992 7064 1 BARHEF,BARWEF, 7065 1 IFOUND,IERROR) 7066C 7067C PURPOSE--THIS IS SUBROUTING MAIPC3. 7068C (THE PC AT THE END OF MAIPC3 STANDS FOR PLOT CONTROL 7069C THIS SUBROUTINE SEARCHES FOR AND EXECUTES 7070C PLOT CONTROL COMMANDS (PART 3). 7071C 7072C WRITTEN BY--JAMES J. FILLIBEN 7073C STATISTICAL ENGINEERING DIVISION 7074C INFORMATION TECHNOLOGY LABORATORY 7075C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 7076C GAITHERSBURG, MD 20899-8980 7077C PHONE--301-975-2855 7078C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 7079C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 7080C LANGUAGE--ANSI FORTRAN (1977) 7081C VERSION NUMBER--82.6 7082C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--JULY 1986. 7083C UPDATED --APRIL 1992. BAR EXPANSION FACTORS ... ... 7084C UPDATED --OCTOBER1993. ARGUMENTS TO BAR BASE (DPBABA) 7085C UPDATED --OCTOBER1993. ARGUMENTS TO REGION BASE (DPREBA) 7086C UPDATED --MARCH 1994. ARGUMENTS TO REGION BASE (DPREBA) 7087C UPDATED --AUGUST 1995. DASH2 BUG (VARIOUS) 7088C 7089C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 7090C 7091 CHARACTER*4 IBUGPC 7092 CHARACTER*4 IBUGP2 7093 CHARACTER*4 ISUBRO 7094C 7095 CHARACTER*4 IVGMSW 7096 CHARACTER*4 IHGMSW 7097C 7098 CHARACTER*4 IMPSW 7099 CHARACTER*4 IERASV 7100 CHARACTER*4 ICASCL 7101C 7102 CHARACTER*4 IFOUND 7103 CHARACTER*4 IERROR 7104C 7105C-----COMMON---------------------------------------------------------- 7106C 7107 INCLUDE 'DPCOPA.INC' 7108 INCLUDE 'DPCOHK.INC' 7109 INCLUDE 'DPCOPC.INC' 7110 INCLUDE 'DPCOSU.INC' 7111 INCLUDE 'DPCODA.INC' 7112 INCLUDE 'DPCOP2.INC' 7113C 7114C-----START POINT----------------------------------------------------- 7115C 7116 IF(IBUGPC.EQ.'ON' .OR. ISUBRO.EQ.'IPC3')THEN 7117 WRITE(ICOUT,999) 7118 999 FORMAT(1X) 7119 CALL DPWRST('XXX','BUG ') 7120 WRITE(ICOUT,51) 7121 51 FORMAT('***** AT THE BEGINNING OF MAIPC3--') 7122 CALL DPWRST('XXX','BUG ') 7123 WRITE(ICOUT,53)IBUGPC,IBUGP2,ISUBRO,IANGLU,IERASV 7124 53 FORMAT('IBUGPC,IBUGP2,ISUBRO,IANGLU,IERASV = ',4(A4,2X),A4) 7125 CALL DPWRST('XXX','BUG ') 7126 WRITE(ICOUT,67)ICOM,ICOM2,NUMARG 7127 67 FORMAT('ICOM,ICOM2,NUMARG = ',2(A4,2X),I8) 7128 CALL DPWRST('XXX','BUG ') 7129 DO70I=1,NUMARG 7130 WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) 7131 71 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ', 7132 1 I8,3(2X,A4),2X,I8,G15.7) 7133 CALL DPWRST('XXX','BUG ') 7134 70 CONTINUE 7135 WRITE(ICOUT,81)IMPSW,IMPNR,IMPNC,IMPCO 7136 81 FORMAT('IMPSW,IMPNR,IMPNC,IMPCO = ',A4,3I8) 7137 CALL DPWRST('XXX','BUG ') 7138 WRITE(ICOUT,82)PMXMIN,PMXMAX,PMYMIN,PMYMAX 7139 82 FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4G15.7) 7140 CALL DPWRST('XXX','BUG ') 7141 WRITE(ICOUT,84)PWXMIS,PWXMAS,PWYMIS,PWYMAS 7142 84 FORMAT('PWXMIS,PWXMAS,PWYMIS,PWYMAS = ',4G15.7) 7143 CALL DPWRST('XXX','BUG ') 7144 WRITE(ICOUT,86)PWXMIN,PWXMAX,PWYMIN,PWYMAX 7145 86 FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4G15.7) 7146 CALL DPWRST('XXX','BUG ') 7147 WRITE(ICOUT,87)PXMIN,PXMAX,PYMIN,PYMAX 7148 87 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4G15.7) 7149 CALL DPWRST('XXX','BUG ') 7150 WRITE(ICOUT,88)IVGMSW,IHGMSW 7151 88 FORMAT('IVGMSW,IHGMSW = ',A4,2X,A4) 7152 CALL DPWRST('XXX','BUG ') 7153 ENDIF 7154C 7155 IFOUND='NO' 7156 IERROR='NO' 7157C 7158C ***************************************** 7159C ** TREAT THE ORIENTATION SWITCH CASE ** 7160C ***************************************** 7161C 7162C 7163 IF(ICOM.EQ.'ORIE')THEN 7164 CALL DPORSW(IHARG,NUMARG,IFOUND,IERROR) 7165 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7166 ENDIF 7167C 7168C ----------BARS-------------------------------------------------- 7169C 7170C ****************************************** 7171C ** STEP XX-- ** 7172C ** TREAT THE VARIOUS BAR ... COMMANDS ** 7173C ****************************************** 7174C 7175 IF(ICOM.EQ.'BAR')GOTO11000 7176 GOTO19999 717711000 CONTINUE 7178C 7179C ********************************************** 7180C ** TREAT THE BAR PATTERN LINE (TYPE) CASE ** 7181C ********************************************** 7182C 7183 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'PATT'.AND. 7184 1IHARG(2).EQ.'LINE'.AND.IHARG(3).EQ.'TYPE')GOTO11120 7185 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'PATT'.AND. 7186 1IHARG(2).EQ.'LINE')GOTO11100 7187 GOTO11199 7188C 718911100 CONTINUE 7190 ISHIFT=1 7191 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 7192 1IBUGP2,IERROR) 7193 IHARG(3)='TYPE' 7194 IHARG2(3)=' ' 719511120 CONTINUE 7196CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC 7197CCCCC CALL DPBPLI(IHARG,NUMARG,IDEBPL,MAXBAR,IBAPLI, 7198 CALL DPBPLI(IHARG,IHARG2,NUMARG,IDEBPL,MAXBAR,IBAPLI, 7199 1IBUGP2,IFOUND,IERROR) 7200 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7201C 720211199 CONTINUE 7203C 7204C **************************************** 7205C ** TREAT THE BAR PATTERN COLOR CASE ** 7206C **************************************** 7207C 7208 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'PATT'.AND. 7209 1IHARG(2).EQ.'COLO')GOTO11200 7210 GOTO11299 7211C 721211200 CONTINUE 7213 CALL DPBPCO(IHARG,NUMARG,IDEBPC,MAXBAR,IBAPCO, 7214 1IBUGP2,IFOUND,IERROR) 7215 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7216C 721711299 CONTINUE 7218C 7219C ******************************************** 7220C ** TREAT THE BAR PATTERN THICKNESS CASE ** 7221C ******************************************** 7222C 7223 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'PATT'.AND. 7224 1IHARG(2).EQ.'THIC')GOTO11300 7225 GOTO11399 7226C 722711300 CONTINUE 7228 CALL DPBPTH(IHARG,IARGT,ARG,NUMARG,PDEBPT,MAXBAR,PBAPTH, 7229 1IBUGP2,IFOUND,IERROR) 7230 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7231C 723211399 CONTINUE 7233C 7234C ******************************************** 7235C ** TREAT THE BAR PATTERN SPACING CASE ** 7236C ******************************************** 7237C 7238 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'PATT'.AND. 7239 1IHARG(2).EQ.'SPAC')GOTO11420 7240 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'SPAC')GOTO11400 7241 GOTO11499 7242C 724311400 CONTINUE 7244 ISHIFT=1 7245 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 7246 1IBUGP2,IERROR) 7247 IHARG(2)='PATT' 7248 IHARG2(2)='ERN ' 724911420 CONTINUE 7250 CALL DPBPSP(IHARG,IARGT,ARG,NUMARG,PDEBPS,MAXBAR,PBAPSP, 7251 1IBUGP2,IFOUND,IERROR) 7252 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7253C 725411499 CONTINUE 7255C 7256C ******************************************* 7257C ** TREAT THE BAR PATTERN (TYPE) CASE ** 7258C ******************************************* 7259C 7260 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'PATT'.AND. 7261 1IHARG(2).EQ.'TYPE')GOTO11520 7262 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'PATT')GOTO11500 7263 GOTO11599 7264C 726511500 CONTINUE 7266 ISHIFT=1 7267 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 7268 1IBUGP2,IERROR) 7269 IHARG(2)='TYPE' 7270 IHARG2(2)=' ' 727111520 CONTINUE 7272 CALL DPBPTY(IHARG,NUMARG,IDEBPT,MAXBAR,IBAPTY, 7273 1IBUGP2,IFOUND,IERROR) 7274 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7275C 727611599 CONTINUE 7277C 7278C ************************************* 7279C ** TREAT THE BAR FILL COLOR CASE ** 7280C ************************************* 7281C 7282 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'FILL'.AND. 7283 1IHARG(2).EQ.'COLO')GOTO11750 7284 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'COLO')GOTO11710 7285 GOTO11799 7286C 728711710 CONTINUE 7288 ISHIFT=1 7289 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 7290 1IBUGP2,IERROR) 7291 IHARG(1)='FILL' 7292 IHARG2(1)=' ' 7293 IHARG(2)='COLO' 7294 IHARG2(2)=' ' 7295 GOTO11750 7296C 729711750 CONTINUE 7298 CALL DPBFCO(IHARG,NUMARG,IDEBFC,MAXBAR,IBAFCO, 7299 1IBUGP2,IFOUND,IERROR) 7300 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7301C 730211799 CONTINUE 7303C 7304C **************************************** 7305C ** TREAT THE BAR FILL (SWITCH) CASE ** 7306C **************************************** 7307C 7308 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'FILL'.AND. 7309 1IHARG(2).EQ.'SWIT')GOTO11820 7310 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'FILL')GOTO11800 7311 GOTO11899 7312C 731311800 CONTINUE 7314CCCCC IF(IHARG(1).EQ.'ON')GOTO11810 MAY 5, 1987 FOR BAR SHADING 7315CCCCC IF(IHARG(2).EQ.'ON')GOTO11810 MAY 5, 1987 FOR BAR SHADING 7316CCCCC IF(IHARG(1).EQ.'OFF')GOTO11810 MAY 5, 1987 FOR BAR SHADING 7317CCCCC IF(IHARG(2).EQ.'OFF')GOTO11810 MAY 5, 1987 FOR BAR SHADING 7318CCCCC GOTO11899 MAY 5, 1987 FOR BAR SHADING 7319 GOTO11810 732011810 CONTINUE 7321 ISHIFT=1 7322 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 7323 1IBUGP2,IERROR) 7324 IHARG(2)='SWIT' 7325 IHARG2(2)='CH ' 732611820 CONTINUE 7327 CALL DPBFSW(IHARG,NUMARG,IDEBFS,MAXBAR,IBAFSW, 7328 1IBUGP2,IFOUND,IERROR) 7329 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7330C 733111899 CONTINUE 7332C 7333C *************************************** 7334C ** TREAT THE BAR BORDER COLOR CASE ** 7335C *************************************** 7336C 7337 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'BORD'.AND. 7338 1IHARG(2).EQ.'COLO')GOTO12100 7339 GOTO12199 7340C 734112100 CONTINUE 7342 CALL DPBBCO(IHARG,NUMARG,IDEBBC,MAXBAR,IBABCO, 7343 1IBUGP2,IFOUND,IERROR) 7344 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7345C 734612199 CONTINUE 7347C 7348C ******************************************* 7349C ** TREAT THE BAR BORDER THICKNESS CASE ** 7350C ******************************************* 7351C 7352 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'BORD'.AND. 7353 1IHARG(2).EQ.'THIC')GOTO12200 7354 GOTO12299 7355C 735612200 CONTINUE 7357 CALL DPBBTH(IHARG,IARGT,ARG,NUMARG,PDEBBT,MAXBAR,PBABTH, 7358 1IBUGP2,IFOUND,IERROR) 7359 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7360C 736112299 CONTINUE 7362C 7363C *********************************************** 7364C ** TREAT THE BAR BORDER LINE (TYPE) CASE ** 7365C *********************************************** 7366C 7367 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'BORD'.AND. 7368 1IHARG(2).EQ.'LINE'.AND.IHARG(3).EQ.'TYPE')GOTO12330 7369 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'BORD'.AND. 7370 1IHARG(2).EQ.'TYPE')GOTO12320 7371 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'BORD'.AND. 7372 1IHARG(2).EQ.'LINE')GOTO12320 7373 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'BORD')GOTO12310 7374 GOTO12399 7375C 737612310 CONTINUE 7377 ISHIFT=2 7378 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 7379 1IBUGP2,IERROR) 7380 IHARG(2)='LINE' 7381 IHARG2(2)=' ' 7382 IHARG(3)='TYPE' 7383 IHARG2(3)=' ' 7384 GOTO12330 7385C 738612320 CONTINUE 7387 ISHIFT=1 7388 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 7389 1IBUGP2,IERROR) 7390 IHARG(2)='LINE' 7391 IHARG2(2)=' ' 7392 IHARG(3)='TYPE' 7393 IHARG2(3)=' ' 7394 GOTO12330 7395C 739612330 CONTINUE 7397CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC 7398CCCCC CALL DPBBLI(IHARG,NUMARG,IDEBBL,MAXBAR,IBABLI, 7399 CALL DPBBLI(IHARG,IHARG2,NUMARG,IDEBBL,MAXBAR,IBABLI, 7400 1IBUGP2,IFOUND,IERROR) 7401 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7402C 740312399 CONTINUE 7404C 7405C ************************************* 7406C ** TREAT THE BAR WIDTH CASE ** 7407C ************************************* 7408C 7409 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'WIDT')GOTO12500 7410 GOTO12599 7411C 741212500 CONTINUE 7413CCCCC CALL DPBAWI(IHARG,IARGT,ARG,NUMARG,ADEBWI,MAXBAR,ABARWI, 7414 CALL DPBAWI(ADEBWI,MAXBAR,ABARWI, 7415 1IBUGP2,IFOUND,IERROR) 7416 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7417C 741812599 CONTINUE 7419C 7420C ******************************** 7421C ** TREAT THE BAR BASE CASE ** 7422C ******************************** 7423C 7424 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'BASE')GOTO12600 7425 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'REFE')GOTO12600 7426 GOTO12699 7427C 742812600 CONTINUE 7429CCCCC OCTOBER 1993. MODIFY CALL LIST (DPCOHK.INC NOW IN SUBROUTINE) 7430CCCCC CALL DPBABA(IHARG,IARGT,ARG,NUMARG,ADEBBA,MAXBAR,ABARBA, 7431 CALL DPBABA(ADEBBA,MAXBAR,ABARBA, 7432 1IBUGP2,IFOUND,IERROR) 7433 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7434C 743512699 CONTINUE 7436C 7437C *********************************** 7438C ** TREAT THE BAR (SWITCH) CASE** 7439C *********************************** 7440C 7441 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'SWIT')GOTO12720 7442 IF(ICOM.EQ.'BAR')GOTO12700 7443 GOTO12799 7444C 744512700 CONTINUE 7446 IF(IHARG(1).EQ.'ON')GOTO12710 7447 IF(IHARG(2).EQ.'ON')GOTO12710 7448 IF(IHARG(1).EQ.'OFF')GOTO12710 7449 IF(IHARG(2).EQ.'OFF')GOTO12710 7450 GOTO12799 745112710 CONTINUE 7452 ISHIFT=1 7453 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 7454 1IBUGP2,IERROR) 7455 IHARG(1)='SWIT' 7456 IHARG2(1)='CH ' 745712720 CONTINUE 7458 CALL DPBASW(IHARG,NUMARG,IDEBSW,MAXBAR,IBARSW, 7459 1IBUGP2,IFOUND,IERROR) 7460 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7461C 746212799 CONTINUE 7463C 7464C ************************************* 7465C ** TREAT THE BAR DIMENSION CASE ** 7466C ************************************* 7467C 7468 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'DIME')GOTO12800 7469 GOTO12899 7470C 747112800 CONTINUE 7472 CALL DPBATY(IHARG,NUMARG,IDEBTY,MAXBAR,IBARTY, 7473 1IBUGP2,IFOUND,IERROR) 7474 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7475C 747612899 CONTINUE 7477C 7478C **************************************** 7479C ** TREAT THE BAR DIRECTION CASE ** 7480C **************************************** 7481C 7482 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'DIRE')GOTO12900 7483 GOTO12999 7484C 748512900 CONTINUE 7486 CALL DPBADI(IHARG,NUMARG,IDEBDI,MAXBAR,IBARDI, 7487 1IBUGP2,IFOUND,IERROR) 7488 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7489C 749012999 CONTINUE 7491C 7492CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1992 7493C ********************************************** 7494C ** TREAT THE BAR EXPANSION FACTORS CASE ** 7495C ** (USED ONLY BY BLOCK PLOT COMMAND) ** 7496C ********************************************** 7497C 7498 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'EXPA')GOTO13000 7499 IF(ICOM.EQ.'BAR'.AND.IHARG(1).EQ.'FACT')GOTO13000 7500 GOTO13099 7501C 750213000 CONTINUE 7503 CALL DPBAEF(IHARG,IARGT,ARG,NUMARG,BARHEF,BARWEF, 7504 1IBUGP2,IFOUND,IERROR) 7505 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7506C 750713099 CONTINUE 7508C 7509C ********************************** 7510C ** END POINT FOR BAR COMMANDS ** 7511C ********************************** 7512C 751319999 CONTINUE 7514C 7515C ----------END OF BARS--------------------------------------- 7516C 7517C ----------REGIONS----------------------------------------------- 7518C 7519C ******************************************** 7520C ** STEP XX-- ** 7521C ** TREAT THE VARIOUS REGION ... COMMANDS ** 7522C ******************************************** 7523C 7524 IF(ICOM.EQ.'REGI')GOTO21000 7525 GOTO22999 752621000 CONTINUE 7527C 7528C ************************************************* 7529C ** TREAT THE REGION PATTERN LINE (TYPE) CASE ** 7530C ************************************************* 7531C 7532 IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'PATT'.AND. 7533 1IHARG(2).EQ.'LINE'.AND.IHARG(3).EQ.'TYPE')GOTO21120 7534 IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'PATT'.AND. 7535 1IHARG(2).EQ.'LINE')GOTO21100 7536 GOTO21199 7537C 753821100 CONTINUE 7539 ISHIFT=1 7540 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 7541 1IBUGP2,IERROR) 7542 IHARG(3)='TYPE' 7543 IHARG2(3)=' ' 754421120 CONTINUE 7545CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC 7546CCCCC CALL DPRPLI(IHARG,NUMARG,IDERPL,MAXREG,IREPLI, 7547 CALL DPRPLI(IHARG,IHARG2,NUMARG,IDERPL,MAXREG,IREPLI, 7548 1IBUGP2,IFOUND,IERROR) 7549 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7550C 755121199 CONTINUE 7552C 7553C ******************************************* 7554C ** TREAT THE REGION PATTERN COLOR CASE ** 7555C ******************************************* 7556C 7557 IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'PATT'.AND. 7558 1IHARG(2).EQ.'COLO')GOTO21200 7559 GOTO21299 7560C 756121200 CONTINUE 7562 CALL DPRPCO(IHARG,NUMARG,IDERPC,MAXREG,IREPCO, 7563 1IBUGP2,IFOUND,IERROR) 7564 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7565C 756621299 CONTINUE 7567C 7568C *********************************************** 7569C ** TREAT THE REGION PATTERN THICKNESS CASE ** 7570C *********************************************** 7571C 7572 IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'PATT'.AND. 7573 1IHARG(2).EQ.'THIC')GOTO21300 7574 GOTO21399 7575C 757621300 CONTINUE 7577 CALL DPRPTH(IHARG,IARGT,ARG,NUMARG,PDERPT,MAXREG,PREPTH, 7578 1IBUGP2,IFOUND,IERROR) 7579 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7580C 758121399 CONTINUE 7582C 7583C *********************************************** 7584C ** TREAT THE REGION PATTERN SPACING CASE ** 7585C *********************************************** 7586C 7587 IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'PATT'.AND. 7588 1IHARG(2).EQ.'SPAC')GOTO21400 7589 GOTO21499 7590C 759121400 CONTINUE 7592 CALL DPRPSP(IHARG,IARGT,ARG,NUMARG,PDERPS,MAXREG,PREPSP, 7593 1IBUGP2,IFOUND,IERROR) 7594 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7595C 759621499 CONTINUE 7597C 7598C ********************************************** 7599C ** TREAT THE REGION PATTERN (TYPE) CASE ** 7600C ********************************************** 7601C 7602 IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'PATT'.AND. 7603 1IHARG(2).EQ.'TYPE')GOTO21520 7604 IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'PATT')GOTO21500 7605 GOTO21599 7606C 760721500 CONTINUE 7608 ISHIFT=1 7609 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 7610 1IBUGP2,IERROR) 7611 IHARG(2)='TYPE' 7612 IHARG2(2)=' ' 761321520 CONTINUE 7614 CALL DPRPTY(IHARG,NUMARG,IDERPT,MAXREG,IREPTY, 7615 1IBUGP2,IFOUND,IERROR) 7616 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7617C 761821599 CONTINUE 7619C 7620C **************************************** 7621C ** TREAT THE REGION FILL COLOR CASE ** 7622C **************************************** 7623C 7624CCCCC JANUARY, 1991. CHECK FOR "REGIS COLOR" COMMAND. 7625 IF(ICOM.EQ.'REGI' .AND. ICOM2.EQ.'S ')GOTO21799 7626C 7627 IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'FILL'.AND. 7628 1 IHARG(2).EQ.'COLO')THEN 7629 ICASCL='STAN' 7630 ELSEIF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'FILL'.AND. 7631 1 IHARG(2).EQ.'RGB '.AND.IHARG(3).EQ.'COLO')THEN 7632 ICASCL='RGB' 7633 ISHIFT=1 7634 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 7635 1 IBUGP2,IERROR) 7636 IHARG(1)='FILL' 7637 IHARG2(1)=' ' 7638 IHARG(2)='COLO' 7639 IHARG2(2)=' ' 7640 ELSEIF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'COLO')THEN 7641 ICASCL='STAN' 7642 ISHIFT=1 7643 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 7644 1 IBUGP2,IERROR) 7645 IHARG(1)='FILL' 7646 IHARG2(1)=' ' 7647 IHARG(2)='COLO' 7648 IHARG2(2)=' ' 7649 ELSE 7650 GOTO21799 7651 ENDIF 7652C 7653 CALL DPRFCO(IHARG,IARG,NUMARG,IDERFC,MAXREG,IREFCO, 7654 1 ICASCL,IREFC2, 7655 1 IBUGP2,ISUBRO,IFOUND,IERROR) 7656 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7657C 765821799 CONTINUE 7659C 7660C ******************************************* 7661C ** TREAT THE REGION FILL (SWITCH) CASE ** 7662C ******************************************* 7663C 7664 IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'FILL'.AND. 7665 1IHARG(2).EQ.'SWIT')GOTO21820 7666 IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'FILL')GOTO21800 7667 GOTO21899 7668C 766921800 CONTINUE 7670CCCCC IF(IHARG(1).EQ.'ON')GOTO21810 MAY 5, 1987 FOR 3D FIGURES 7671CCCCC IF(IHARG(2).EQ.'ON')GOTO21810 MAY 5, 1987 FOR 3D FIGURES 7672CCCCC IF(IHARG(1).EQ.'OFF')GOTO21810 MAY 5, 1987 FOR 3D FIGURES 7673CCCCC IF(IHARG(2).EQ.'OFF')GOTO21810 MAY 5, 1987 FOR 3D FIGURES 7674CCCCC GOTO21899 MAY 5, 1987 FOR 3D FIGURES 7675 GOTO21810 767621810 CONTINUE 7677 ISHIFT=1 7678 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 7679 1IBUGP2,IERROR) 7680 IHARG(2)='SWIT' 7681 IHARG2(2)='CH ' 768221820 CONTINUE 7683 CALL DPRFSW(IHARG,NUMARG,IDERFS,MAXREG,IREFSW, 7684 1IBUGP2,IFOUND,IERROR) 7685 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7686C 768721899 CONTINUE 7688C 7689C ****************************************** 7690C ** TREAT THE REGION BORDER COLOR CASE ** 7691C ****************************************** 7692C 7693 IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'BORD'.AND. 7694 1IHARG(2).EQ.'COLO')GOTO22100 7695 GOTO22199 7696C 769722100 CONTINUE 7698 CALL DPRBCO(IHARG,NUMARG,IDERBC,MAXREG,IREBCO, 7699 1IBUGP2,IFOUND,IERROR) 7700 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7701C 770222199 CONTINUE 7703C 7704C ********************************************** 7705C ** TREAT THE REGION BORDER THICKNESS CASE ** 7706C ********************************************** 7707C 7708 IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'BORD'.AND. 7709 1IHARG(2).EQ.'THIC')GOTO22200 7710 GOTO22299 7711C 771222200 CONTINUE 7713 CALL DPRBTH(IHARG,IARGT,ARG,NUMARG,PDERBT,MAXREG,PREBTH, 7714 1IBUGP2,IFOUND,IERROR) 7715 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7716C 771722299 CONTINUE 7718C 7719C ************************************************** 7720C ** TREAT THE REGION BORDER LINE (TYPE) CASE ** 7721C ************************************************** 7722C 7723 IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'BORD'.AND. 7724 1IHARG(2).EQ.'LINE'.AND.IHARG(3).EQ.'TYPE')GOTO22330 7725 IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'BORD'.AND. 7726 1IHARG(2).EQ.'TYPE')GOTO22320 7727 IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'BORD'.AND. 7728 1IHARG(2).EQ.'LINE')GOTO22320 7729 IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'BORD')GOTO22310 7730 GOTO22399 7731C 773222310 CONTINUE 7733 ISHIFT=2 7734 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 7735 1IBUGP2,IERROR) 7736 IHARG(2)='LINE' 7737 IHARG2(2)=' ' 7738 IHARG(3)='TYPE' 7739 IHARG2(3)=' ' 7740 GOTO22330 7741C 774222320 CONTINUE 7743 ISHIFT=1 7744 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 7745 1IBUGP2,IERROR) 7746 IHARG(2)='LINE' 7747 IHARG2(2)=' ' 7748 IHARG(3)='TYPE' 7749 IHARG2(3)=' ' 7750 GOTO22330 7751C 775222330 CONTINUE 7753CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC 7754CCCCC CALL DPRBLI(IHARG,NUMARG,IDERBL,MAXREG,IREBLI, 7755 CALL DPRBLI(IHARG,IHARG2,NUMARG,IDERBL,MAXREG,IREBLI, 7756 1IBUGP2,IFOUND,IERROR) 7757 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7758C 775922399 CONTINUE 7760C 7761C *********************************** 7762C ** TREAT THE REGION BASE CASE ** 7763C *********************************** 7764C 7765 IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'BASE')GOTO22600 7766 IF(ICOM.EQ.'REGI'.AND.IHARG(1).EQ.'REFE')GOTO22600 7767 GOTO22699 7768C 776922600 CONTINUE 7770CCCCC OCTOBER 1993. CHANGE ARGUMENT LIST (INCLUDE FILES IN SUBROUTINE) 7771CCCCC MARCH 1994. ADD IREBPL TO ARGUMENT LIST. 7772 CALL DPREBA(ADERBA,MAXREG,AREGBA,IREBIN,IREBPL, 7773CCCCC CALL DPREBA(ADERBA,MAXREG,AREGBA,IREBIN, 7774CCCCC CALL DPREBA(IHARG,IARGT,ARG,NUMARG,ADERBA,MAXREG,AREGBA, 7775 1IBUGP2,IFOUND,IERROR) 7776 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7777C 777822699 CONTINUE 7779C 7780C ************************************* 7781C ** END POINT FOR REGION COMMANDS ** 7782C ************************************* 7783C 778422999 CONTINUE 7785C 7786C ----------END OF REGIONS------------------------------------------ 7787C 7788C ----------MARKERS------------------------------------------------- 7789C 7790C ********************************************* 7791C ** STEP XX-- ** 7792C ** TREAT THE VARIOUS MARKER ... COMMANDS ** 7793C ********************************************* 7794C 7795 IF(ICOM.EQ.'MARK')GOTO31000 7796 GOTO32999 779731000 CONTINUE 7798C 7799C ************************************************* 7800C ** TREAT THE MARKER PATTERN LINE (TYPE) CASE ** 7801C ************************************************* 7802C 7803 IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'PATT'.AND. 7804 1IHARG(2).EQ.'LINE'.AND.IHARG(3).EQ.'TYPE')GOTO31120 7805 IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'PATT'.AND. 7806 1IHARG(2).EQ.'LINE')GOTO31100 7807 GOTO31199 7808C 780931100 CONTINUE 7810 ISHIFT=1 7811 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 7812 1IBUGP2,IERROR) 7813 IHARG(3)='TYPE' 7814 IHARG2(3)=' ' 781531120 CONTINUE 7816CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC 7817CCCCC CALL DPMPLI(IHARG,NUMARG,IDEMPL,MAXMAR,IMAPLI, 7818 CALL DPMPLI(IHARG,IHARG2,NUMARG,IDEMPL,MAXMAR,IMAPLI, 7819 1IBUGP2,IFOUND,IERROR) 7820 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7821C 782231199 CONTINUE 7823C 7824C ******************************************* 7825C ** TREAT THE MARKER PATTERN COLOR CASE ** 7826C ******************************************* 7827C 7828 IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'PATT'.AND. 7829 1IHARG(2).EQ.'COLO')GOTO31200 7830 GOTO31299 7831C 783231200 CONTINUE 7833 CALL DPMPCO(IHARG,NUMARG,IDEMPC,MAXMAR,IMAPCO, 7834 1IBUGP2,IFOUND,IERROR) 7835 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7836C 783731299 CONTINUE 7838C 7839C *********************************************** 7840C ** TREAT THE MARKER PATTERN THICKNESS CASE ** 7841C *********************************************** 7842C 7843 IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'PATT'.AND. 7844 1IHARG(2).EQ.'THIC')GOTO31300 7845 GOTO31399 7846C 784731300 CONTINUE 7848 CALL DPMPTH(IHARG,IARGT,ARG,NUMARG,PDEMPT,MAXMAR,PMAPTH, 7849 1IBUGP2,IFOUND,IERROR) 7850 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7851C 785231399 CONTINUE 7853C 7854C *********************************************** 7855C ** TREAT THE MARKER PATTERN SPACING CASE ** 7856C *********************************************** 7857C 7858 IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'PATT'.AND. 7859 1IHARG(2).EQ.'SPAC')GOTO31400 7860 GOTO31499 7861C 786231400 CONTINUE 7863 CALL DPMPSP(IHARG,IARGT,ARG,NUMARG,PDEMPS,MAXMAR,PMAPSP, 7864 1IBUGP2,IFOUND,IERROR) 7865 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7866C 786731499 CONTINUE 7868C 7869C ********************************************** 7870C ** TREAT THE MARKER PATTERN (TYPE) CASE ** 7871C ********************************************** 7872C 7873 IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'PATT'.AND. 7874 1IHARG(2).EQ.'TYPE')GOTO31520 7875 IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'PATT')GOTO31500 7876 GOTO31599 7877C 787831500 CONTINUE 7879 ISHIFT=1 7880 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 7881 1IBUGP2,IERROR) 7882 IHARG(2)='TYPE' 7883 IHARG2(2)=' ' 788431520 CONTINUE 7885 CALL DPMPTY(IHARG,NUMARG,IDEMPT,MAXMAR,IMAPTY, 7886 1IBUGP2,IFOUND,IERROR) 7887 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7888C 788931599 CONTINUE 7890C 7891C **************************************** 7892C ** TREAT THE MARKER FILL COLOR CASE ** 7893C **************************************** 7894C 7895 IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'FILL'.AND. 7896 1IHARG(2).EQ.'COLO')GOTO31750 7897 IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'COLO')GOTO31710 7898 GOTO31799 7899C 790031710 CONTINUE 7901 ISHIFT=1 7902 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 7903 1IBUGP2,IERROR) 7904 IHARG(1)='FILL' 7905 IHARG2(1)=' ' 7906 IHARG(2)='COLO' 7907 IHARG2(2)=' ' 7908 GOTO31750 7909C 791031750 CONTINUE 7911 CALL DPMFCO(IHARG,NUMARG,IDEMFC,MAXMAR,IMAFCO, 7912 1IBUGP2,IFOUND,IERROR) 7913 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7914C 791531799 CONTINUE 7916C 7917C ******************************************* 7918C ** TREAT THE MARKER FILL (SWITCH) CASE ** 7919C ******************************************* 7920C 7921 IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'FILL'.AND. 7922 1IHARG(2).EQ.'SWIT')GOTO31820 7923 IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'FILL')GOTO31800 7924 GOTO31899 7925C 792631800 CONTINUE 7927 IF(IHARG(1).EQ.'ON')GOTO31810 7928 IF(IHARG(2).EQ.'ON')GOTO31810 7929 IF(IHARG(1).EQ.'OFF')GOTO31810 7930 IF(IHARG(2).EQ.'OFF')GOTO31810 7931 GOTO31899 793231810 CONTINUE 7933 ISHIFT=1 7934 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 7935 1IBUGP2,IERROR) 7936 IHARG(2)='SWIT' 7937 IHARG2(2)='CH ' 793831820 CONTINUE 7939 CALL DPMFSW(IHARG,NUMARG,IDEMFS,MAXMAR,IMAFSW, 7940 1IBUGP2,IFOUND,IERROR) 7941 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7942C 794331899 CONTINUE 7944C 7945C ****************************************** 7946C ** TREAT THE MARKER BORDER COLOR CASE ** 7947C ****************************************** 7948C 7949 IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'BORD'.AND. 7950 1IHARG(2).EQ.'COLO')GOTO32100 7951 GOTO32199 7952C 795332100 CONTINUE 7954 CALL DPMBCO(IHARG,NUMARG,IDEMBC,MAXMAR,IMABCO, 7955 1IBUGP2,IFOUND,IERROR) 7956 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7957C 795832199 CONTINUE 7959C 7960C ********************************************** 7961C ** TREAT THE MARKER BORDER THICKNESS CASE ** 7962C ********************************************** 7963C 7964 IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'BORD'.AND. 7965 1IHARG(2).EQ.'THIC')GOTO32200 7966 GOTO32299 7967C 796832200 CONTINUE 7969 CALL DPMBTH(IHARG,IARGT,ARG,NUMARG,PDEMBT,MAXMAR,PMABTH, 7970 1IBUGP2,IFOUND,IERROR) 7971 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 7972C 797332299 CONTINUE 7974C 7975C ************************************************** 7976C ** TREAT THE MARKER BORDER LINE (TYPE) CASE ** 7977C ************************************************** 7978C 7979 IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'BORD'.AND. 7980 1IHARG(2).EQ.'LINE'.AND.IHARG(3).EQ.'TYPE')GOTO32330 7981 IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'BORD'.AND. 7982 1IHARG(2).EQ.'TYPE')GOTO32320 7983 IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'BORD'.AND. 7984 1IHARG(2).EQ.'LINE')GOTO32320 7985 IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'BORD')GOTO32310 7986 GOTO32399 7987C 798832310 CONTINUE 7989 ISHIFT=2 7990 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 7991 1IBUGP2,IERROR) 7992 IHARG(2)='LINE' 7993 IHARG2(2)=' ' 7994 IHARG(3)='TYPE' 7995 IHARG2(3)=' ' 7996 GOTO32330 7997C 799832320 CONTINUE 7999 ISHIFT=1 8000 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 8001 1IBUGP2,IERROR) 8002 IHARG(2)='LINE' 8003 IHARG2(2)=' ' 8004 IHARG(3)='TYPE' 8005 IHARG2(3)=' ' 8006 GOTO32330 8007C 800832330 CONTINUE 8009CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC 8010CCCCC CALL DPMBLI(IHARG,NUMARG,IDEMBL,MAXMAR,IMABLI, 8011 CALL DPMBLI(IHARG,IHARG2,NUMARG,IDEMBL,MAXMAR,IMABLI, 8012 1IBUGP2,IFOUND,IERROR) 8013 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8014C 801532399 CONTINUE 8016C 8017C *********************************** 8018C ** TREAT THE MARKER BASE CASE ** 8019C *********************************** 8020C 8021 IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'BASE')GOTO32600 8022 IF(ICOM.EQ.'MARK'.AND.IHARG(1).EQ.'REFE')GOTO32600 8023 GOTO32699 8024C 802532600 CONTINUE 8026 CALL DPMABA(IHARG,IARGT,ARG,NUMARG,ADEMBA,MAXMAR,AMARBA, 8027 1IBUGP2,IFOUND,IERROR) 8028 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8029C 803032699 CONTINUE 8031C 8032C ************************************* 8033C ** END POINT FOR MARKER COMMANDS ** 8034C ************************************* 8035C 803632999 CONTINUE 8037C 8038C ----------END OF MARKERS--------------------------------------- 8039C 8040C ----------TEXTS-------------------------------------------------- 8041C 8042C *********************************************** 8043C ** STEP XX-- ** 8044C ** TREAT THE VARIOUS TEXT ... COMMANDS ** 8045C ** TREAT THE TEXT PATTERN LINE (TYPE) CASE ** 8046C ** TREAT THE TEXT PATTERN COLOR CASE ** 8047C ** TREAT THE TEXT PATTERN THICKNESS CASE ** 8048C ** TREAT THE TEXT PATTERN SPACING CASE ** 8049C ** TREAT THE TEXT PATTERN (TYPE) CASE ** 8050C ** TREAT THE TEXT FILL COLOR CASE ** 8051C ** TREAT THE TEXT FILL (SWITCH) CASE ** 8052C ** TREAT THE TEXT BORDER COLOR CASE ** 8053C ** TREAT THE TEXT BORDER THICKNESS CASE ** 8054C ** TREAT THE TEXT BORDER LINE (TYPE) CASE ** 8055C ** TREAT THE TEXT BASE CASE ** 8056C *********************************************** 8057C 8058 IF(ICOM.EQ.'TEXT')THEN 8059C 8060 IF(IHARG(1).EQ.'PATT'.AND.IHARG(2).EQ.'LINE'.AND. 8061 1 IHARG(3).EQ.'TYPE')THEN 8062 CALL DPTPLI(IHARG,IHARG2,NUMARG,IDETPL,MAXTEX,ITEPLI, 8063 1 IBUGP2,IFOUND,IERROR) 8064 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8065 ELSEIF(IHARG(1).EQ.'PATT'.AND.IHARG(2).EQ.'LINE')THEN 8066 ISHIFT=1 8067 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 8068 1 IBUGP2,IERROR) 8069 IHARG(3)='TYPE' 8070 IHARG2(3)=' ' 8071 CALL DPTPLI(IHARG,IHARG2,NUMARG,IDETPL,MAXTEX,ITEPLI, 8072 1 IBUGP2,IFOUND,IERROR) 8073 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8074C 8075 ELSEIF(IHARG(1).EQ.'PATT'.AND.IHARG(2).EQ.'COLO'.AND. 8076 1 IHARG2(2).EQ.'R ')THEN 8077 CALL DPTPCO(IHARG,NUMARG,IDETPC,MAXTEX,ITEPCO, 8078 1 IBUGP2,IFOUND,IERROR) 8079 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8080C 8081 ELSEIF(IHARG(1).EQ.'PATT'.AND.IHARG(2).EQ.'THIC')THEN 8082 CALL DPTPTH(IHARG,IARGT,ARG,NUMARG,PDETPT,MAXTEX,PTEPTH, 8083 1 IBUGP2,IFOUND,IERROR) 8084 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8085C 8086 ELSEIF(IHARG(1).EQ.'PATT'.AND.IHARG(2).EQ.'SPAC')THEN 8087 CALL DPTPSP(IHARG,IARGT,ARG,NUMARG,PDETPS,MAXTEX,PTEPSP, 8088 1 IBUGP2,IFOUND,IERROR) 8089 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8090C 8091 ELSEIF(IHARG(1).EQ.'PATT'.AND.IHARG(2).EQ.'TYPE')THEN 8092 CALL DPTPTY(IHARG,NUMARG,IDETPT,MAXTEX,ITEPTY, 8093 1 IBUGP2,IFOUND,IERROR) 8094 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8095 ELSEIF(IHARG(1).EQ.'PATT')THEN 8096 ISHIFT=1 8097 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 8098 1 IBUGP2,IERROR) 8099 IHARG(2)='TYPE' 8100 IHARG2(2)=' ' 8101 CALL DPTPTY(IHARG,NUMARG,IDETPT,MAXTEX,ITEPTY, 8102 1 IBUGP2,IFOUND,IERROR) 8103 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8104C 8105 ELSEIF(IHARG(1).EQ.'FILL'.AND.IHARG(2).EQ.'COLO'.AND. 8106 1 IHARG2(2).EQ.'R ')THEN 8107 CALL DPTFCO(IHARG,NUMARG,IDETFC,MAXTEX,ITEFCO, 8108 1 IBUGP2,IFOUND,IERROR) 8109 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8110 ELSEIF(IHARG(1).EQ.'COLO'.AND.IHARG2(1).EQ.'R ')THEN 8111 ISHIFT=1 8112 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 8113 1 IBUGP2,IERROR) 8114 IHARG(1)='FILL' 8115 IHARG2(1)=' ' 8116 IHARG(2)='COLO' 8117 IHARG2(2)=' ' 8118 CALL DPTFCO(IHARG,NUMARG,IDETFC,MAXTEX,ITEFCO, 8119 1 IBUGP2,IFOUND,IERROR) 8120 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8121C 8122 ELSEIF(IHARG(1).EQ.'FILL'.AND.IHARG(2).EQ.'SWIT')THEN 8123 CALL DPTFSW(IHARG,NUMARG,IDETFS,MAXTEX,ITEFSW, 8124 1 IBUGP2,IFOUND,IERROR) 8125 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8126 ELSEIF(IHARG(1).EQ.'FILL')THEN 8127 IF(IHARG(1).EQ.'ON'.OR.IHARG(2).EQ.'ON'.OR. 8128 1 IHARG(1).EQ.'OFF'.OR.IHARG(2).EQ.'OFF')THEN 8129 ISHIFT=1 8130 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 8131 1 IBUGP2,IERROR) 8132 IHARG(2)='SWIT' 8133 IHARG2(2)='CH ' 8134 CALL DPTFSW(IHARG,NUMARG,IDETFS,MAXTEX,ITEFSW, 8135 1 IBUGP2,IFOUND,IERROR) 8136 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8137 ENDIF 8138C 8139 ELSEIF(IHARG(1).EQ.'BORD'.AND.IHARG(2).EQ.'COLO'.AND. 8140 1 IHARG2(2).EQ.'R ')THEN 8141 CALL DPTBCO(IHARG,NUMARG,IDETBC,MAXTEX,ITEBCO, 8142 1 IBUGP2,IFOUND,IERROR) 8143 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8144C 8145 ELSEIF(IHARG(1).EQ.'BORD'.AND.IHARG(2).EQ.'THIC')THEN 8146 CALL DPTBTH(IHARG,IARGT,ARG,NUMARG,PDETBT,MAXTEX,PTEBTH, 8147 1 IBUGP2,IFOUND,IERROR) 8148 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8149C 8150 ELSEIF(IHARG(1).EQ.'BORD'.AND.IHARG(2).EQ.'LINE'.AND. 8151 1 IHARG(3).EQ.'TYPE')THEN 8152 CALL DPTBLI(IHARG,IHARG2,NUMARG,IDETBL,MAXTEX,ITEBLI, 8153 1 IBUGP2,IFOUND,IERROR) 8154 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8155 ELSEIF(IHARG(1).EQ.'BORD'.AND. 8156 1 (IHARG(2).EQ.'LINE' .OR. IHARG(2).EQ.'TYPE'))THEN 8157 ISHIFT=1 8158 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 8159 1 IBUGP2,IERROR) 8160 IHARG(2)='LINE' 8161 IHARG2(2)=' ' 8162 IHARG(3)='TYPE' 8163 IHARG2(3)=' ' 8164 CALL DPTBLI(IHARG,IHARG2,NUMARG,IDETBL,MAXTEX,ITEBLI, 8165 1 IBUGP2,IFOUND,IERROR) 8166 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8167 ELSEIF(ICOM.EQ.'TEXT'.AND.IHARG(1).EQ.'BORD')THEN 8168 ISHIFT=2 8169 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 8170 1 IBUGP2,IERROR) 8171 IHARG(2)='LINE' 8172 IHARG2(2)=' ' 8173 IHARG(3)='TYPE' 8174 IHARG2(3)=' ' 8175 CALL DPTBLI(IHARG,IHARG2,NUMARG,IDETBL,MAXTEX,ITEBLI, 8176 1 IBUGP2,IFOUND,IERROR) 8177 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8178C 8179CCCCC ELSEIF(IHARG(1).EQ.'BASE'.OR.IHARG(1).EQ.'REFE')THEN 8180CCCCC CALL DPTEBA(IHARG,IARGT,ARG,NUMARG,ADETBA,MAXTEX,ATEXBA, 8181CCCCC1 IBUGP2,IFOUND,IERROR) 8182CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8183 ENDIF 8184 ENDIF 8185C 8186C *********************************** 8187C ** END POINT FOR TEXT COMMANDS ** 8188C *********************************** 8189C 8190C 8191C ----------END OF TEXTS--------------------------------------- 8192C 8193C ***************** 8194C ** STEP 90-- ** 8195C ** EXIT ** 8196C ***************** 8197C 8198 9000 CONTINUE 8199 IF(IBUGPC.EQ.'ON' .OR. ISUBRO.EQ.'IPC3')THEN 8200 WRITE(ICOUT,999) 8201 CALL DPWRST('XXX','BUG ') 8202 WRITE(ICOUT,9011) 8203 9011 FORMAT('***** AT THE END OF MAIPC3--') 8204 CALL DPWRST('XXX','BUG ') 8205 WRITE(ICOUT,9020)IFOUND,IERROR 8206 9020 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 8207 CALL DPWRST('XXX','BUG ') 8208 ENDIF 8209C 8210 RETURN 8211 END 8212 SUBROUTINE MAIPC4(IBUGPC,IBUGP2,ISUBRO,IFOUND,IERROR) 8213C 8214C PURPOSE--THIS IS SUBROUTING MAIPC4. 8215C (THE PC AT THE END OF MAIPC4 STANDS FOR PLOT CONTROL 8216C THIS SUBROUTINE SEARCHES FOR AND EXECUTES 8217C PLOT CONTROL COMMANDS (PART 1). 8218C THE PLOT CONTROL COMMANDS SEARCHED FOR BY MAIPC4 8219C ARE THE FOLLOWING 3D-RELATED COMMANDS-- 8220C 8221C EYE (COORDINATES) 8222C ORIGIN COORDINATES 8223C VISIBLE (HIDDENLINES, BACKLINES) 8224C PROJECTION 8225C 8226C PEDESTAL ON/OFF 8227C PEDESTAL BASE 8228C PEDESTAL SIZE 8229C PEDESTAL COLOR 8230C PEDESTAL GRID 8231C PEDESTAL GRID PATTERN 8232C PEDESTAL GRID COLOR 8233C 8234C BASEPLANE ON/OFF 8235C BASEPLANE COLOR 8236C BASEPLANE GRID 8237C BASEPLANE GRID PATTERN 8238C BASEPLANE GRID COLOR 8239C 8240C BACKPLANE ON/OFF 8241C BACKPLANE COLOR 8242C BACKPLANE GRID 8243C BACKPLANE GRID PATTERN 8244C BACKPLANE GRID COLOR 8245C 8246C SIDEFACE ON/OFF 8247C SIDEFACE COLOR 8248C SIDEFACE GRID 8249C SIDEFACE GRID PATTERN 8250C SIDEFACE GRID COLOR 8251C 8252C TIC PLANE 8253C 8254C ROTATE EYE 8255C 8256C WRITTEN BY--JAMES J. FILLIBEN 8257C STATISTICAL ENGINEERING DIVISION 8258C INFORMATION TECHNOLOGY LABORATORY 8259C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 8260C GAITHERSBURG, MD 20899-8980 8261C PHONE--301-975-2855 8262C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 8263C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 8264C LANGUAGE--ANSI FORTRAN (1977) 8265C VERSION NUMBER --88.10 8266C ORIGINAL VERSION--SEPTEMBER 1988. 8267C UPDATED --APRIL 1992. DEPBA=DEFBA COMMENTED OUT 8268C UPDATED --SEPTEMBER 1993. ALLOW EYE FOR EYE COOR 8269C UPDATED --SEPTEMBER 1993. NEW COMMAND--ROTATE EYE 8270C 8271C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 8272C 8273 CHARACTER*4 IBUGPC 8274 CHARACTER*4 IBUGP2 8275 CHARACTER*4 ISUBRO 8276 CHARACTER*4 IFOUND 8277 CHARACTER*4 IERROR 8278C 8279C-----COMMON---------------------------------------------------------- 8280C 8281 INCLUDE 'DPCOPA.INC' 8282 INCLUDE 'DPCOHK.INC' 8283 INCLUDE 'DPCOPC.INC' 8284 INCLUDE 'DPCO3D.INC' 8285 INCLUDE 'DPCOSU.INC' 8286 INCLUDE 'DPCODA.INC' 8287 INCLUDE 'DPCOP2.INC' 8288C 8289C-----START POINT----------------------------------------------------- 8290C 8291 IF(IBUGPC.EQ.'ON' .OR. ISUBRO.EQ.'IPC4')THEN 8292 WRITE(ICOUT,999) 8293 999 FORMAT(1X) 8294 CALL DPWRST('XXX','BUG ') 8295 WRITE(ICOUT,51) 8296 51 FORMAT('***** AT THE BEGINNING OF MAIPC4--') 8297 CALL DPWRST('XXX','BUG ') 8298 WRITE(ICOUT,53)IBUGPC,IBUGP2,ISUBRO 8299 53 FORMAT('IBUGPC,IBUGP2,ISUBRO = ',2(A4,2X),A4) 8300 CALL DPWRST('XXX','BUG ') 8301 WRITE(ICOUT,67)ICOM,ICOM2,NUMARG 8302 67 FORMAT('ICOM,ICOM2,NUMARG = ',2(A4,2X),I8) 8303 CALL DPWRST('XXX','BUG ') 8304 DO70I=1,NUMARG 8305 WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) 8306 71 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ', 8307 1 I8,3(2X,A4),2X,I8,G15.7) 8308 CALL DPWRST('XXX','BUG ') 8309 70 CONTINUE 8310 ENDIF 8311C 8312 IFOUND='NO' 8313 IERROR='NO' 8314C 8315CCCCC THE FOLLOWING SECTION WAS REWRITTEN SEPTEMBER 1993 8316C *************************************** 8317C ** TREAT THE EYE (COORDINATES) CASE ** 8318C *************************************** 8319C 8320 IF(ICOM.EQ.'EYE')THEN 8321 IF(NUMARG.GE.1)THEN 8322 IF(IHARG(1).EQ.'COOR')THEN 8323 ISHIFT=1 8324 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG, 8325 1 IARGT,NUMARG,IBUGPC,IERROR) 8326 ENDIF 8327 ENDIF 8328 CALL DPEYCO(IHARG,IARGT,ARG,NUMARG, 8329 1 AEYEXC,AEYEYC,AEYEZC, 8330 1 X3DEYE,Y3DEYE,Z3DEYE, 8331 1 IFOUND,IERROR) 8332 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8333 ENDIF 8334C 8335C ***************************************** 8336C ** TREAT THE ORIGIN COORDINATES CASE ** 8337C ***************************************** 8338C 8339 IF(ICOM.EQ.'ORIG')THEN 8340 CALL DPORCO(IHARG,IARGT,ARG,NUMARG, 8341 1 AORIXC,AORIYC,AORIZC, 8342 1 IFOUND,IERROR) 8343 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8344 ENDIF 8345C 8346C ******************************* 8347C ** TREAT THE VISIBLE CASE ** 8348C ** HIDDEN LINES, BACKLINES ** 8349C ******************************* 8350C 8351 IF(ICOM.EQ.'VISI')GOTO1300 8352 IF(ICOM.EQ.'HIDD')GOTO1300 8353 IF(ICOM.EQ.'BACK'.AND.ICOM2.EQ.'LINE')GOTO1300 8354 IF(ICOM.EQ.'BACK'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'LINE') 8355 1GOTO1300 8356 GOTO1399 8357C 8358 1300 CONTINUE 8359 CALL DPVIS(IHARG,NUMARG,IVISSW,IFOUND,IERROR) 8360 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8361C 8362 1399 CONTINUE 8363C 8364C ************************************************** 8365C ** TREAT THE PROJECTION CASE (3D) ** 8366C ************************************************** 8367C 8368 IF(ICOM.EQ.'PROJ')GOTO1400 8369 IF(ICOM.EQ.'ORTH')GOTO1400 8370 IF(ICOM.EQ.'PERS')GOTO1400 8371 GOTO1499 8372C 8373 1400 CONTINUE 8374 CALL DPPROJ(ICOM,IHARG,NUMARG,I3DPRO, 8375 1IFOUND,IERROR) 8376 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8377C 8378 1499 CONTINUE 8379C 8380CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1993 8381C ************************************** 8382C ** TREAT THE ROTATE EYE CASE ** 8383C ************************************** 8384C 8385 IF(ICOM.EQ.'ROTA')THEN 8386 CALL DPROEY(IHARG,IARGT,ARG,NUMARG, 8387 1 X3DEYE,Y3DEYE,Z3DEYE, 8388 1 X3DMID,Y3DMID,Z3DMID, 8389 1 AEYEXC,AEYEYC,AEYEZC, 8390 1 IFOUND,IERROR) 8391 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8392 ENDIF 8393C 8394C -----PEDESTAL----- 8395C 8396C ****************************************** 8397C ** TREAT THE PEDESTAL GRID COLOR CASE ** 8398C ****************************************** 8399C 8400 IF(ICOM.EQ.'PEDE')GOTO2100 8401 GOTO2199 8402C 8403 2100 CONTINUE 8404 IF(NUMARG.GE.2.AND. 8405 1IHARG(1).EQ.'GRID'.AND.IHARG(2).EQ.'COLO')GOTO2110 8406 GOTO2199 8407 2110 CONTINUE 8408 CALL DPPEGC(IHARG,NUMARG,IDEPGC,IPEDGC,IFOUND,IERROR) 8409 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8410C 8411 2199 CONTINUE 8412C 8413C ********************************************* 8414C ** TREAT THE PEDESTAL GRID PATTERN CASE ** 8415C ********************************************* 8416C 8417 IF(ICOM.EQ.'PEDE')GOTO2200 8418 GOTO2299 8419C 8420 2200 CONTINUE 8421 IF(NUMARG.GE.2.AND. 8422 1IHARG(1).EQ.'GRID'.AND.IHARG(2).EQ.'PATT')GOTO2210 8423 GOTO2299 8424 2210 CONTINUE 8425 CALL DPPEGP(IHARG,NUMARG,IDEPGP,IPEDGP,IFOUND,IERROR) 8426 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8427C 8428 2299 CONTINUE 8429C 8430C ************************************* 8431C ** TREAT THE PEDESTAL GRID CASE ** 8432C ************************************* 8433C 8434 IF(ICOM.EQ.'PEDE')GOTO2300 8435 GOTO2399 8436C 8437 2300 CONTINUE 8438 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'GRID')GOTO2310 8439 GOTO2399 8440 2310 CONTINUE 8441 CALL DPPEGR(IHARG,NUMARG,IDEPGR,IPEDGR,IFOUND,IERROR) 8442 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8443C 8444 2399 CONTINUE 8445C 8446C ************************************* 8447C ** TREAT THE PEDESTAL COLOR CASE ** 8448C ************************************* 8449C 8450 IF(ICOM.EQ.'PEDE')GOTO2400 8451 GOTO2499 8452C 8453 2400 CONTINUE 8454 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO2410 8455 GOTO2499 8456 2410 CONTINUE 8457 CALL DPPECL(IHARG,NUMARG,IDEPCO,IPEDCO,IFOUND,IERROR) 8458 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8459C 8460 2499 CONTINUE 8461C 8462C ************************************** 8463C ** TREAT THE PEDESTAL SIZE CASE ** 8464C ************************************** 8465C 8466 IF(ICOM.EQ.'PEDE')GOTO2500 8467 GOTO2599 8468C 8469 2500 CONTINUE 8470 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SIZE')GOTO2510 8471 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'HEIG')GOTO2510 8472 GOTO2599 8473 2510 CONTINUE 8474 CALL DPPESZ(IHARG,IARGT,ARG,NUMARG, 8475 1ADEPSZ,APEDSZ, 8476 1IFOUND,IERROR) 8477 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8478C 8479 2599 CONTINUE 8480C 8481C ************************************* 8482C ** TREAT THE PEDESTAL BASE CASE ** 8483C ************************************* 8484C 8485 IF(ICOM.EQ.'PEDE')GOTO2600 8486 GOTO2699 8487C 8488 2600 CONTINUE 8489 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'BASE')GOTO2610 8490 GOTO2699 8491 2610 CONTINUE 8492CCCCC THE FOLLOWING LINE WAS COMMENTED OUT APRIL 1992 (ALAN) 8493CCCCC DEPBA=DEFBA 8494 CALL DPPEBA(IHARG,IARGT,ARG,NUMARG, 8495 1ADEPBA,APEDBA, 8496 1IFOUND,IERROR) 8497 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8498C 8499 2699 CONTINUE 8500C 8501C ******************************* 8502C ** TREAT THE PEDESTAL CASE ** 8503C ******************************* 8504C 8505 IF(ICOM.EQ.'PEDE')GOTO2700 8506 GOTO2799 8507C 8508 2700 CONTINUE 8509 CALL DPPED(IHARG,NUMARG,IPEDSW,IFOUND,IERROR) 8510 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8511C 8512 2799 CONTINUE 8513C 8514C -----BASEPLANE----- 8515C 8516C ****************************************** 8517C ** TREAT THE BASEPLANE GRID COLOR CASE ** 8518C ****************************************** 8519C 8520 IF(ICOM.EQ.'BASE')GOTO3100 8521 GOTO3199 8522C 8523 3100 CONTINUE 8524 IF(NUMARG.GE.2.AND. 8525 1IHARG(1).EQ.'GRID'.AND.IHARG(2).EQ.'COLO')GOTO3110 8526 GOTO3199 8527 3110 CONTINUE 8528 CALL DPBSGC(IHARG,NUMARG,IDBSGC,IBSPGC,IFOUND,IERROR) 8529 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8530C 8531 3199 CONTINUE 8532C 8533C ********************************************* 8534C ** TREAT THE BASEPLANE GRID PATTERN CASE ** 8535C ********************************************* 8536C 8537 IF(ICOM.EQ.'BASE')GOTO3200 8538 GOTO3299 8539C 8540 3200 CONTINUE 8541 IF(NUMARG.GE.2.AND. 8542 1IHARG(1).EQ.'GRID'.AND.IHARG(2).EQ.'PATT')GOTO3210 8543 GOTO3299 8544 3210 CONTINUE 8545 CALL DPBSGP(IHARG,NUMARG,IDBSGP,IBSPGP,IFOUND,IERROR) 8546 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8547C 8548 3299 CONTINUE 8549C 8550C ************************************* 8551C ** TREAT THE BASEPLANE GRID CASE ** 8552C ************************************* 8553C 8554 IF(ICOM.EQ.'BASE')GOTO3300 8555 GOTO3399 8556C 8557 3300 CONTINUE 8558 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'GRID')GOTO3310 8559 GOTO3399 8560 3310 CONTINUE 8561 CALL DPBSGR(IHARG,NUMARG,IDBSGR,IBSPGR,IFOUND,IERROR) 8562 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8563C 8564 3399 CONTINUE 8565C 8566C ************************************* 8567C ** TREAT THE BASEPLANE COLOR CASE ** 8568C ************************************* 8569C 8570 IF(ICOM.EQ.'BASE')GOTO3400 8571 GOTO3499 8572C 8573 3400 CONTINUE 8574 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO3410 8575 GOTO3499 8576 3410 CONTINUE 8577 CALL DPBSCL(IHARG,NUMARG,IDBSCO,IBSPCO,IFOUND,IERROR) 8578 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8579C 8580 3499 CONTINUE 8581C 8582C ******************************* 8583C ** TREAT THE BASEPLANE CASE ** 8584C ******************************* 8585C 8586 IF(ICOM.EQ.'BASE')GOTO3500 8587 GOTO3599 8588C 8589 3500 CONTINUE 8590 CALL DPBSP(IHARG,NUMARG,IBSPSW,IFOUND,IERROR) 8591 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8592C 8593 3599 CONTINUE 8594C 8595C -----BACKPLANE----- 8596C 8597C ****************************************** 8598C ** TREAT THE BACKPLANE GRID COLOR CASE ** 8599C ****************************************** 8600C 8601 IF(ICOM.EQ.'BACK'.AND.ICOM2.EQ.'PLAN')GOTO4100 8602 GOTO4199 8603C 8604 4100 CONTINUE 8605 IF(NUMARG.GE.2.AND. 8606 1IHARG(1).EQ.'GRID'.AND.IHARG(2).EQ.'COLO')GOTO4110 8607 GOTO4199 8608 4110 CONTINUE 8609 CALL DPBKGC(IHARG,NUMARG,IDBKGC,IBKPGC,IFOUND,IERROR) 8610 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8611C 8612 4199 CONTINUE 8613C 8614C ********************************************* 8615C ** TREAT THE BACKPLANE GRID PATTERN CASE ** 8616C ********************************************* 8617C 8618 IF(ICOM.EQ.'BACK'.AND.ICOM2.EQ.'PLAN')GOTO4200 8619 GOTO4299 8620C 8621 4200 CONTINUE 8622 IF(NUMARG.GE.2.AND. 8623 1IHARG(1).EQ.'GRID'.AND.IHARG(2).EQ.'PATT')GOTO4210 8624 GOTO4299 8625 4210 CONTINUE 8626 CALL DPBKGP(IHARG,NUMARG,IDBKGP,IBKPGP,IFOUND,IERROR) 8627 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8628C 8629 4299 CONTINUE 8630C 8631C ************************************* 8632C ** TREAT THE BACKPLANE GRID CASE ** 8633C ************************************* 8634C 8635 IF(ICOM.EQ.'BACK'.AND.ICOM2.EQ.'PLAN')GOTO4300 8636 GOTO4399 8637C 8638 4300 CONTINUE 8639 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'GRID')GOTO4310 8640 GOTO4399 8641 4310 CONTINUE 8642 CALL DPBKGR(IHARG,NUMARG,IDBKGR,IBKPGR,IFOUND,IERROR) 8643 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8644C 8645 4399 CONTINUE 8646C 8647C ************************************* 8648C ** TREAT THE BACKPLANE COLOR CASE ** 8649C ************************************* 8650C 8651 IF(ICOM.EQ.'BACK'.AND.ICOM2.EQ.'PLAN')GOTO4400 8652 GOTO4499 8653C 8654 4400 CONTINUE 8655 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO4410 8656 GOTO4499 8657 4410 CONTINUE 8658 CALL DPBKCL(IHARG,NUMARG,IDBKCO,IBKPCO,IFOUND,IERROR) 8659 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8660C 8661 4499 CONTINUE 8662C 8663C ******************************* 8664C ** TREAT THE BACKPLANE CASE ** 8665C ******************************* 8666C 8667 IF(ICOM.EQ.'BACK'.AND.ICOM2.EQ.'PLAN')GOTO4500 8668 GOTO4599 8669C 8670 4500 CONTINUE 8671 CALL DPBKP(IHARG,NUMARG,IBKPSW,IFOUND,IERROR) 8672 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8673C 8674 4599 CONTINUE 8675C 8676C -----SIDEFACE----- 8677C 8678C ****************************************** 8679C ** TREAT THE SIDEFACE GRID COLOR CASE ** 8680C ****************************************** 8681C 8682 IF(ICOM.EQ.'SIDE')GOTO5100 8683 GOTO5199 8684C 8685 5100 CONTINUE 8686 IF(NUMARG.GE.2.AND. 8687 1IHARG(1).EQ.'GRID'.AND.IHARG(2).EQ.'COLO')GOTO5110 8688 GOTO5199 8689 5110 CONTINUE 8690 CALL DPSDGC(IHARG,NUMARG,IDSDGC,ISDFGC,IFOUND,IERROR) 8691 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8692C 8693 5199 CONTINUE 8694C 8695C ********************************************* 8696C ** TREAT THE SIDEFACE GRID PATTERN CASE ** 8697C ********************************************* 8698C 8699 IF(ICOM.EQ.'SIDE')GOTO5200 8700 GOTO5299 8701C 8702 5200 CONTINUE 8703 IF(NUMARG.GE.2.AND. 8704 1IHARG(1).EQ.'GRID'.AND.IHARG(2).EQ.'PATT')GOTO5210 8705 GOTO5299 8706 5210 CONTINUE 8707 CALL DPSDGP(IHARG,NUMARG,IDSDGP,ISDFGP,IFOUND,IERROR) 8708 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8709C 8710 5299 CONTINUE 8711C 8712C ************************************* 8713C ** TREAT THE SIDEFACE GRID CASE ** 8714C ************************************* 8715C 8716 IF(ICOM.EQ.'SIDE')GOTO5300 8717 GOTO5399 8718C 8719 5300 CONTINUE 8720 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'GRID')GOTO5310 8721 GOTO5399 8722 5310 CONTINUE 8723 CALL DPSDGR(IHARG,NUMARG,IDSDGR,ISDFGR,IFOUND,IERROR) 8724 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8725C 8726 5399 CONTINUE 8727C 8728C ************************************* 8729C ** TREAT THE SIDEFACE COLOR CASE ** 8730C ************************************* 8731C 8732 IF(ICOM.EQ.'SIDE')GOTO5400 8733 GOTO5499 8734C 8735 5400 CONTINUE 8736 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO5410 8737 GOTO5499 8738 5410 CONTINUE 8739 CALL DPSDCL(IHARG,NUMARG,IDSDCO,ISDFCO,IFOUND,IERROR) 8740 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8741C 8742 5499 CONTINUE 8743C 8744C ******************************* 8745C ** TREAT THE SIDEFACE CASE ** 8746C ******************************* 8747C 8748 IF(ICOM.EQ.'SIDE')GOTO5500 8749 GOTO5599 8750C 8751 5500 CONTINUE 8752 CALL DPSDF(IHARG,NUMARG,ISDFSW,IFOUND,IERROR) 8753 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 8754C 8755 5599 CONTINUE 8756C 8757C ***************** 8758C ** STEP 90-- ** 8759C ** EXIT ** 8760C ***************** 8761C 8762 9000 CONTINUE 8763 IF(IBUGPC.EQ.'ON' .OR. ISUBRO.EQ.'IPC4')THEN 8764 WRITE(ICOUT,999) 8765 CALL DPWRST('XXX','BUG ') 8766 WRITE(ICOUT,9011) 8767 9011 FORMAT('***** AT THE END OF MAIPC4--') 8768 CALL DPWRST('XXX','BUG ') 8769 WRITE(ICOUT,9020)IFOUND,IERROR 8770 9020 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 8771 CALL DPWRST('XXX','BUG ') 8772 ENDIF 8773C 8774 RETURN 8775 END 8776 SUBROUTINE MAINSU(IDEFSE,ISEED,ANOPL1,ANOPL2, 8777 1 ISQUAR,IBOOSS,IDEBOO, 8778 1 IANSSV,IREPMX,ILISMX,IPOINT, 8779 1 ISACNC,IAUTSW,IAUTEX,ITOPIC,MAXNXT,IPROSW, 8780 1 IMACRO,IMACNU,IMACCS,IMACL1,IMACL2,IMACLR, 8781 1 IOFILE,IMALEV,IPROGR,ICONCL, 8782 1 ICOM3,ICOM4,ICOM5,NUMCOM,NCOM5, 8783 1 ICTRA1,NCTRA1,ICTRA2,NCTRA2,NUMTRA, 8784 1 IBASLC,IREPCH,IOSW,ICAPSW,IPRDEF, 8785 1 IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO, 8786 1 IBUGEX,IBUGE2,IBUGHE,IBUGH2,IBUGLO, 8787 1 ICPREH,NCPREH,ICPOSH,NCPOSH,IOUTTY,IPRITY, 8788 1 IHELMX,IFTEXP,IFTORD,ALOWFR,ALOWDG, 8789 1 IFORSW,ICREAF,NCREAF,ICWRIF,NCWRIF, 8790 1 IREARW,IWRIRW, 8791 1 IUNFOF,IUNFNR,IUNFMC, 8792 1 IRHSTG,IMPSW,IERRFA,IGUIFL,IGUIFB, 8793 1 ITABTI,NCTABT,ITABBR,ITABSP,ITABWD,ITABHT, 8794 1 IANSLO,ILOOST,ILOOLI,NUMLIL,NUMLOS,IWIDLL, 8795 1 IIFSW,NUMIF, 8796 1 NPLOTP,IFOUND,IERROR) 8797C 8798CCCCC IBASLC WAS ADDED TO ABOVE INPUT ARGUMENT LIST JUNE 1989 8799CCCCC ICAPSW AND IPRDEF WERE ADDED TO ABOVE ARGUMENT LIST JUNE 1989 8800CCCCC ADD "LOOP" ARGUMENTS (FOR READ COMMAND) JANUARY 2015. 8801C 8802C PURPOSE--THIS IS SUBROUTING MAINSU. 8803C 8804C (THE SU AT THE END OF MAINSU STANDS FOR SUPPORT) 8805C THIS SUBROUTINE SEARCHES FOR AND EXECUTES SUPPORT COMMANDS. 8806C THE SUPPORT COMMANDS SEARCHED FOR BY MAINSU ARE AS FOLLOWS-- 8807C 8808C ADD N/A ADD CAL 8809C ANOP LIMITS (= PROPORTION LIMITS) +-INFINITY 8810C BAUD 9600 BAUD 12 8811C BUGS N/A BUGS 8812C CLASS ... LOWER AUTOMATIC CLASS L 8813C CLASS ... UPPER AUTOMATIC FROM DATA CLASS U 8814C CLASS ... WIDTH AUTOMATIC FROM DATA CLASS W 8815C COLUMN LIMITS 1 132 COLUMN 8816C COMMENT N/A COMMENT 8817C CURSOR SIZE 1.0 CURSOR 8818C DEFAULT COMMAND NO COMMAND DEFAULT 8819C DELETE N/A DELETE 8820C DEMODULATION FREQUENCY 0.25 DEMODUL 8821C DIMENSION 1000 ROWS 10 COLS DIMENSI 8822C DOUBLE PRECISION OFF = SING. PREC. DOUBLE 8823C ECHO OFF = NO ECHO ECHO ON 8824C END N/A END 8825C ERASE DELAY 1 ERASE D 8826C FEEDBACK ON = FEEDBACK FEEDBAC 8827C FILTER WIDTH 3 FILTER 8828C FIT CONSTRAINT ALL UNCONSTRAINED FIT CON 8829C FIT ITERATIONS 50 FIT ITE 8830C FIT STANDARD DEVIATION .000005 FIT STA 8831C HARDCOPY DELAY 1 HARDCOP 8832C HELP N/A HELP PL 8833C HOST THE LOCAL HOST HOS 8834C HOST LINK THE LOCAL HOST HOS 8835C IMPLEMENT ORIG. INITIALIZ. IMPLEM 8836C KNOTS OFF = NO KNOTS KNOTS K 8837C MACRO (CREATE) OFF MACRO 8838C MAIL N/A MAIL JO 8839C MAXIMUM RECORD LENGTH N/A MAIL JO 8840C NAME N/A NAME Y 8841C NEWS N/A NEWS 8842C OPERATOR N/A OPERAT 8843C POLYNOMIAL DEGREE 1 = LINEAR POLYNOM 8844C PRECISION SINGLE PRECISI 8845C PRE-ERASE ON = PRE-ERASE PRE-ERA 8846C PRINTING ON = PRINTING PRINTIN 8847C PROBE N/A PROBE N 8848C QUADRUPLE PRECISION OFF = SING. PREC. QUADRUP 8849C QUERY N/A QUERY H 8850C READ N/A READ CA 8851C RESET N/A RESET 8852C RESTORE N/A RESTORE 8853C RETAIN N/A RETAIN 8854C ROW LIMITS 1 INFINITY ROW LIM 8855C SAVE N/A SAVE SC 8856C SEED 20867350019 SEED 8857C TERMIANATOR CHARACTER ; SEPAR 8858C SERIAL READ N/A SERIAL 8859C SET OFF SET IBU 8860C SINGLE PRECISION ON SINGLE 8861C SKIP 0 = NO LINES SKIP 5 8862C STATUS N/A STATUS 8863C TIME N/A TIME 8864C TRIPLE PRECISION OFF = SING. PREC. TRIPLE 8865C WEIGHTS OFF = EQUI-WEIGHTED WEIGHTS 8866C WRITE N/A WRITE C 8867C . N/A . CARRY 8868C CONTINUE CHARACTER ... CONTI 8869C PRINTER FORMAT ASCII/POSTSCRIPT 8870C FILE FORMAT ASCII/POSTSCRIPT 8871C 8872C VECTOR FORMAT <ANGLE/POINT/DELTA> 8873C VECTOR ARROW <FIXED/VARIABLE> 8874C VECTOR ARROW <OPEN/CLOSED> 8875C ANDREWS INCREMENT 8876C OPTIMIZATION METHOD 8877C WEB HELP 8878C RECIPE SATTERWAITE APPROXIMATION 8879C RECIPE OUTPUT 8880C RECIPE PROBABILITY CONTENT (OR RECIPE CONTENT) 8881C RECIPE CONFIDENCE 8882C RECIPE FIT DEGREE (OR RECIPE DEGREE) 8883C RECIPE ANOVA FACTORS (OR RECIPE FACTORS) 8884C RECIPE CORRELATION 8885C RECIPE SIMCOV REPLICATES 8886C RECIPE SIMPVT REPLICATES 8887C 8888C GUI WRITE/PRINT 8889C GUI STATUS 8890C GUI PLOT CONTROL <N> 8891C 8892C VARIABLE LABEL 8893C 8894C ORTHOGONAL DISTANCE ERROR 8895C ORTHOGONAL DISTANCE DELTA 8896C 8897C KERNEL DENSITY WIDTH 8898C KERNEL DENSITY POINTS 8899C 8900C AUTO TEXT 8901C 8902C SYSTEM 8903C PROCES ID (OR PID) 8904C CPU TIME 8905C PWD (OR GETCWD, CURRENT DIRECTORY) 8906C CLIPBOARD CLEAR (OR CLEAR CLIPBOARD) 8907C CLIPBOARD 8908C 8909C WRITTEN BY--JAMES J. FILLIBEN 8910C STATISTICAL ENGINEERING DIVISION 8911C INFORMATION TECHNOLOGY LABORATORY 8912C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 8913C GAITHERSBURG, MD 20899-8980 8914C PHONE--301-975-2855 8915C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 8916C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 8917C LANGUAGE--ANSI FORTRAN (1977) 8918C VERSION NUMBER--82.6 8919C ORIGINAL VERSION--NOVEMBER 1980. 8920C UPDATED --MARCH 1981. 8921C UPDATED --AUGUST 1981. 8922C UPDATED --SEPTEMBER 1981. 8923C UPDATED --OCTOBER 1981. 8924C UPDATED --JANUARY 1982. 8925C UPDATED --FEBRUARY 1982. 8926C UPDATED --MARCH 1982. 8927C UPDATED --MAY 1982. 8928C UPDATED --SEPTEMBER 1983. 8929C UPDATED --JANUARY 1986. 8930C UPDATED --OCTOBER 1987. (ISUBRO FOR DPAPPE AND DPEXTE) 8931C UPDATED --AUGUST 1988. EQUATE PROPORTION LIMITS WITH ANOP LIM 8932C UPDATED --DECEMBER 1988. ADJUST RESET FOR RESET2 8933C UPDATED --DECEMBER 1988. RESET DATA, IO, PC, ETC. 8934C UPDATED --DECEMBER 1988. SET WRITE FORMAT 8935C UPDATED --DECEMBER 1988. SET READ REWIND 8936C UPDATED --DECEMBER 1988. SET WRITE REWIND 8937C UPDATED --DECEMBER 1988. LOWESS FRACTION 8938C UPDATED --DECEMBER 1988. READ/WRITE DECI, FORMAT, REWIND 8939C UPDATED --JANUARY 1989. BOOTSTRAP SAMPLE SIZE 8940C UPDATED --FEBRUARY 1989. CONTINUE CHARACTER (ALAN) 8941C UPDATED --FEBRUARY 1989. SOFT-CODED LIMITS FOR IANSSV (ALAN) 8942C UPDATED --FEBRUARY 1989. SYSTEM COMMAND (ALAN) 8943C UPDATED --JUNE 1989. REPLACEMENT/SUBSTITUTION CHARACTER 8944C UPDATED --JUNE 1989. CAPTURE (TEXT OUTPUT) 8945C UPDATED --JULY 1989. MORE/PAUSE TO LIST 8946C UPDATED --NOVEMBER 1989. COLUMN RULER 8947C UPDATED --NOVEMBER 1989. NLIST 8948C UPDATED --NOVEMBER 1989. ADD ARG TO CALL TO DPSYST 8949C UPDATED --MARCH 1990. ADD ARGUMENT TO SYSTEM COMMAND (ALAN) 8950C UPDATED --MAY 1990. ADD ARGUMENTS TO DPREAD, DPREAL 8951C UPDATED --MAY 1990. COMMENT CHARACTER COMMAND 8952C UPDATED --JUNE 1990. IBUGD2 TO IBUGS2 IN CALL TO DPSYST 8953C UPDATED --JULY 1990. ICOMFL RENAMED AS ICOMSW 8954C UPDATED --SEPTEMBER 1990. DOS, UNIX, ETC. FOR SYSTEM 8955C UPDATED --SEPTEMBER 1990. DATE SYNONYM FOR TIME 8956C UPDATED --MARCH 1992. PRINTER FORMAT ASCI/POST 8957C UPDATED --MARCH 1992. FILE FORMAT ASCI/POST 8958C UPDATED --APRIL 1992. ADD NPLOTP TO ARGS 8959C UPDATED --AUGUST 1992. VECTOR FORMAT, VECTOR ARROW 8960C UPDATED --SEPTEMBER 1992. LIST SYNONYMS: VIEW/PREVIEW 8961C UPDATED --NOVEMBER 1992. ANDREWS INCREMENT 8962C UPDATED --JULY 1993. FRACTAL ITERATIONS 8963C UPDATED --JULY 1993. FRACTAL TYPE 8964C UPDATED --JULY 1993. PRINCIPLE COMPONENT TYPE 8965C UPDATED --JULY 1993. ADD ARGS TO DPLICO: MORE 8966C UPDATED --SEPTEMBER 1993. REWRITE CODE AROUND DPLICO 8967C UPDATED --DECEMBER 1993. CHECK FOR "SAVE" AND "S CHART" 8968C CONFLICT. 8969C UPDATED --JANUARY 1994. SEARCH1 8970C UPDATED --MAY 1994. COPY FILE => COPY 8971C UPDATED --JUNE 1994. OPTIMIZATION TOLERANCE 8972C UPDATED --AUGUST 1994. EXECUTE SUBSET OF MACRO 8973C UPDATED --SEPTEMBER 1994. CHECK FOR NAME CONFLICT 8974C UPDATED --NOVEMBER 1994. DECLARE NEWNAM (BOMB ON VAX) 8975C UPDATED --FEBRUARY 1995. OPTIMIZATION METHOD 8976C UPDATED --APRIL 1995. IUNFOF, IUNFNR, IUNFMC 8977C UPDATED --AUGUST 1995. ADD IFTORD 8978C UPDATED --SEPTEMBER 1995. ISUBRO ADDED TO CALL DPDELE 8979C UPDATED --SEPTEMBER 1995. INIT COMMAND (FOR DEBUGGING) 8980C UPDATED --OCTOBER 1995. NAME CONFLICT WITH DOUBLE 8981C UPDATED --MARCH 1997. SUPPORT FOR DEVICE FONT (ALAN) 8982C UPDATED --APRIL 1997. WEB HELP COMMAND (ALAN) 8983C UPDATED --APRIL 1997. LIST GRAPH (ALAN) 8984C UPDATED --APRIL 1997. SAVE GRAPH (ALAN) 8985C UPDATED --APRIL 1997. REPEAT GRAPH (ALAN) 8986C UPDATED --APRIL 1997. CYCLE GRAPH (ALAN) 8987C UPDATED --AUGUST 1997. SLEEP (= PAUSE <n>) 8988C UPDATED --AUGUST 1997. CD COMMAND 8989C UPDATED --AUGUST 1997. 6 RECIPE COMMANDS 8990C UPDATED --NOVEMBER 1997. GUI PRINT/WRITE 8991C UPDATED --NOVEMBER 1997. GUI STATUS 8992C UPDATED --NOVEMBER 1997. GUI SAVE PLOT CONTROL 8993C UPDATED --JANUARY 1998. CALL TO DPDIME 8994C UPDATED --NOVEMBER 1998. CALL LIST TO DPSET, DPPROB 8995C UPDATED --MARCH 1998. NAME CONFLICT WITH CP AND CP PLOT 8996C UPDATED --APRIL 1997. RECIPE FIT FACTORS COMMANDS 8997C UPDATED --MARCH 1999. NAME CONFLICT FOR SINGLE 8998C UPDATED --NOVEMBER 1999. VARIABLE LABEL 8999C UPDATED --APRIL 2001. ORTHOGONAL DISTANCE ERROR 9000C UPDATED --APRIL 2001. ORTHOGONAL DISTANCE DELTA 9001C UPDATED --AUGUST 2001. KERNEL DENSITY WIDTH/POINTS 9002C UPDATED --JUNE 2002. ICAPTY IN DPCAPT CALL 9003C UPDATED --FEBRUARY 2003. CALL TO DPREAD, DPSERI 9004C UPDATED --FEBRUARY 2003. CALL TO DPCOLL 9005C UPDATED --FEBRUARY 2003. ADD: MAXIMUM RECORD LENGTH 9006C UPDATED --FEBRUARY 2003. CALL LIST TO DPSEAR 9007C UPDATED --SEPTEMBER 2003. CALL LIST TO DPWRIT 9008C UPDATED --SEPTEMBER 2005. CALL LIST TO DPMACR 9009C UPDATED --SEPTEMBER 2005. MACRO SUBSTITUTION CHARACTER 9010C UPDATED --JANUARY 2006. ARGUMENT LIST TO DPCAPT 9011C UPDATED --MARCH 2006. PROCESS ID 9012C UPDATED --AUGUST 2007. USER-DEFINED ACTION ON 9013C ERROR 9014C UPDATED --SEPTEMBER 2007. IERRST 9015C UPDATED --MAY 2008. GUI FEEDBACK SWITCH 9016C UPDATED --APRIL 2009. TABLE WIDTH COMMAND 9017C UPDATED --APRIL 2009. CALL LIST TO DPWRIT 9018C UPDATED --MAY 2009. ADD CPU TIME COMMAND 9019C UPDATED --MAY 2010. REMOVE "MAIL" AND "QUERY" 9020C COMMANDS 9021C UPDATED --JANUARY 2011. ADD PWD COMMAND 9022C UPDATED --NOVEMBER 2014. CLIPBOARD CLEAR 9023C UPDATED --NOVEMBER 2014. CLIPBOARD RUN 9024C UPDATED --JANUARY 2015. LOOP ARGUMENTS TO DPREAD 9025C UPDATED --MARCH 2015. CALL LIST TO DPINFU 9026C UPDATED --MARCH 2015. CALL LIST TO UPDATF 9027C UPDATED --NOVEMBER 2015. CALL LIST TO DPMACR 9028C UPDATED --DECEMBER 2015. CALL LIST TO MAININ 9029C UPDATED --JULY 2016. STREAM READ 9030C UPDATED --JULY 2017. CALL LIST TO DPMACR, 9031C CALL LIST TO MAINSU 9032C UPDATED --JULY 2017. INSERT CALL ARGUMENTS COMMAND 9033C UPDATED --JULY 2017. ISSUE WITH COMMAND LINE 9034C ARGUMENTS IN LOOP STORE MODE, 9035C DO COMMAND LINE SUBSTITUTION 9036C FOR FILE NAME, BUT NOT ARGUMENTS 9037C UPDATED --APRIL 2018. CALL LISTS TO DPHELW, DPHANW, 9038C DPWEB 9039C UPDATED --DECEMBER 2018. SUPPORT FOR "DEVICE ... SCALE" 9040C COMMAND 9041C UPDATED --FEBRUARY 2019. SUPPORT FOR "CALL CLIPBOARD" 9042C UPDATED --SEPTEMBER 2019. SUPPORT FOR "GREP" AS SEARCH 9043C OPTION 9044C UPDATED --SEPTEMBER 2019. ADD "RM" AND "RMDIR" COMMANDS 9045C UPDATED --SEPTEMBER 2019. ADD "MKDIR" COMMAND 9046C UPDATED --SEPTEMBER 2019. ADD "CAT" COMMAND 9047C UPDATED --SEPTEMBER 2019. ADD "DIR" COMMAND 9048C UPDATED --SEPTEMBER 2019. FOR LIST AND SAVE, CHECK IF 9049C FIRST ARGUMENT IS "=" 9050C UPDATED --OCTOBER 2019. "HEAD" AND "TAIL" OPTIONS FOR 9051C WRITE COMMAND 9052C UPDATED --NOVEMBER 2019. "RSCRIPT" AND "PYTHON" 9053C COMMANDS 9054C UPDATED --FEBRUARY 2020. FOR "CLIPBOARD" COMMANDS, 9055C CHECK IF "CLIPBOARD" ARGUMENT 9056C IS ACTUALLY A FILE NAME. 9057C 9058C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 9059C 9060 INCLUDE 'DPCOPA.INC' 9061C 9062 CHARACTER*4 IMPSW 9063 CHARACTER*4 ILOOST 9064 CHARACTER*4 IIFSW 9065C 9066 CHARACTER*4 ISQUAR 9067 CHARACTER*4 ITOPIC 9068 CHARACTER*4 IPROSW 9069C 9070 CHARACTER*4 IMACRO 9071 CHARACTER*12 IMACCS 9072 CHARACTER*4 IOFILE 9073C 9074 CHARACTER*4 IPROGR 9075 CHARACTER*4 ICONCL 9076C 9077 CHARACTER*4 ICOM3 9078 CHARACTER*4 ICOM4 9079 CHARACTER*40 ICOM5 9080C 9081 CHARACTER*30 ICTRA1 9082 CHARACTER*30 ICTRA2 9083C 9084 CHARACTER*1 IBASLC 9085 CHARACTER*1 IREPCH 9086 CHARACTER*4 IOSW 9087 CHARACTER*4 IBUGUG 9088 CHARACTER*4 IBUGU2 9089 CHARACTER*4 IBUGU3 9090 CHARACTER*4 IBUGU4 9091 CHARACTER*4 IBUGEX 9092 CHARACTER*4 IBUGE2 9093 CHARACTER*4 IBUGHE 9094 CHARACTER*4 IBUGH2 9095 CHARACTER*4 IBUGLO 9096C 9097 CHARACTER*40 ICPREH 9098 CHARACTER*40 ICPOSH 9099C 9100CCCCC THE FOLLOWING 2 LINES WERE ADDED MARCH 1992 9101 CHARACTER*4 IPRITY 9102 CHARACTER*4 IOUTTY 9103C 9104 CHARACTER*4 IFTEXP 9105CCCCC AUGUST 1995. ADD FOLLOWING LINE 9106 CHARACTER*4 IFTORD 9107C 9108 CHARACTER*4 IFORSW 9109 CHARACTER*80 ICREAF 9110 CHARACTER*80 ICWRIF 9111C 9112 CHARACTER*4 IREARW 9113 CHARACTER*4 IWRIRW 9114 CHARACTER*4 ISUBRO 9115 CHARACTER*4 IFOUND 9116 CHARACTER*4 IERROR 9117C 9118 CHARACTER*4 IDEFHL 9119 CHARACTER*4 IHOSLI 9120C 9121 CHARACTER*1 IANSSV 9122CCCCC CHARACTER*80 ISACNC 9123 CHARACTER (LEN=MAXFNC) :: ISACNC 9124C 9125 CHARACTER*4 IAUTSW 9126 CHARACTER*4 IAUTEX 9127 CHARACTER*4 IBELSJ 9128 CHARACTER*4 IERASJ 9129 CHARACTER*4 IBACCJ 9130 CHARACTER*4 ICOPSJ 9131C 9132 CHARACTER*4 ISEART 9133C 9134CCCCC THE FOLLOWING LINE WAS ADDED JUNE 1989 9135 CHARACTER*4 ICAPSW 9136C 9137CCCCC THE FOLLOWING 5 LINES WERE ADDED FEBRUARY 1993 9138 CHARACTER*24 CURRTI 9139 CHARACTER*24 CURRDA 9140 CHARACTER*4 IC4 9141 CHARACTER*4 IFOUNN 9142 CHARACTER*4 IERRON 9143C 9144CCCCC THE FOLLOWING LINE NOVEMBER 1994 9145 CHARACTER*4 NEWNAM 9146CCCCC THE FOLLOWING 2 LINES WERE ADDED SEPTEMBER 1995 9147 CHARACTER*4 ICOMHO 9148 CHARACTER*4 ICOMH2 9149CCCCC THE FOLLOWING 2 LINES WERE ADDED OCTOBER 1996 9150 CHARACTER*4 IRHSTG 9151CCCCC THE FOLLOWING 2 LINES WERE ADDED SEPTEMBER 2003 9152 CHARACTER*4 ITABBR 9153 CHARACTER*80 ITABTI 9154C 9155 CHARACTER*4 ICASOD 9156C 9157 CHARACTER*4 IERRFA 9158 CHARACTER*4 IGUIFL 9159 CHARACTER*4 IGUIFB 9160 CHARACTER*4 ISUBN1 9161 CHARACTER*4 ISUBN2 9162 CHARACTER*4 ICASE2 9163C 9164 CHARACTER*4 IFUTMP(100) 9165C 9166 CHARACTER*4 IH 9167 CHARACTER*4 IH2 9168 CHARACTER*4 ISUBN0 9169C 9170 CHARACTER*1 IQUOTE 9171CCCCC CHARACTER*255 ICANS 9172 CHARACTER (LEN=MAXSTR) :: ICANS 9173C 9174 DIMENSION IDEFHL(10) 9175 DIMENSION IHOSLI(10) 9176C 9177CCCCC DIMENSION IANSSV(50,80) 9178 DIMENSION IANSSV(MAXLIS,MAXCIS) 9179 CHARACTER*4 IANSLO(MAXLIL,MAXCIL) 9180 DIMENSION IWIDLL(MAXLIL) 9181C 9182 DIMENSION ICOM3(*) 9183 DIMENSION ICOM4(*) 9184 DIMENSION ICOM5(*) 9185 DIMENSION NCOM5(*) 9186C 9187 DIMENSION ICTRA1(*) 9188 DIMENSION NCTRA1(*) 9189 DIMENSION ICTRA2(*) 9190 DIMENSION NCTRA2(*) 9191C 9192 CHARACTER*4 IFEESV 9193C 9194 CHARACTER*255 CURDIR 9195 CHARACTER*4 IFUNC9(255) 9196C 9197C-----COMMON---------------------------------------------------------- 9198C 9199 INCLUDE 'DPCOFO.INC' 9200 INCLUDE 'DPCOMC.INC' 9201 INCLUDE 'DPCODB.INC' 9202 INCLUDE 'DPCOHK.INC' 9203 INCLUDE 'DPCOPC.INC' 9204 INCLUDE 'DPCODG.INC' 9205 INCLUDE 'DPCOSU.INC' 9206 INCLUDE 'DPCODA.INC' 9207 INCLUDE 'DPCOHO.INC' 9208 INCLUDE 'DPCOGR.INC' 9209CCCCC THE FOLLOWING LINE WAS INSERTED NOVEMBER 1989 9210 INCLUDE 'DPCODE.INC' 9211C 9212CCCCC TO AVOID NAME CONFLICTS, ONLY BRING IN THE SPECIFIC 9213CCCCC COMMON BLOCK 9214C 9215 CHARACTER*4 IERRST 9216 COMMON/CSETG/IERRST 9217C 9218C 9219C-----COMMON VARIABLES (GENERAL)-------------------------------------- 9220C 9221 INCLUDE 'DPCOP2.INC' 9222C 9223C-----START POINT----------------------------------------------------- 9224C 9225 IF(IBUGSU.EQ.'ON'.OR.ISUBRO.EQ.'INSU')THEN 9226 WRITE(ICOUT,999) 9227 999 FORMAT(1X) 9228 CALL DPWRST('XXX','BUG ') 9229 WRITE(ICOUT,51) 9230 51 FORMAT('***** AT THE BEGINNING OF MAINSU--') 9231 CALL DPWRST('XXX','BUG ') 9232 WRITE(ICOUT,55)IBUGSU,IBUGS2,IBUGCO,IBUGEV,IBUGQ 9233 55 FORMAT('IBUGSU,IBUGS2,IBUGCO,IBUGEV,IBUGQ = ',4(A4,2X),A4) 9234 CALL DPWRST('XXX','BUG ') 9235 WRITE(ICOUT,58)IANGLU,ISQUAR,IFENSW,IBOOSS,IDEBOO 9236 58 FORMAT('IANGLU,ISQUAR,IFENSW,IBOOSS,IDEBOO = ',3(A4,2X),2I8) 9237 CALL DPWRST('XXX','BUG ') 9238 WRITE(ICOUT,59)IMACRO,IMACNU,IMACCS,IOFILE 9239 59 FORMAT('IMACRO,IMACNU,IMACCS,IOFILE = ',A4,I8,2X,A12,2X,A4) 9240 CALL DPWRST('XXX','BUG ') 9241 WRITE(ICOUT,62)IFOUND,IERROR,ICOM,ICOM2,NUMARG 9242 62 FORMAT('IFOUND,IERROR,ICOM,ICOM2,NUMARG = ',4(A4,2X),I8) 9243 CALL DPWRST('XXX','BUG ') 9244 DO70I=1,NUMARG 9245 WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) 9246 71 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ', 9247 1 I8,3(2X,A4),2X,I8,G15.7) 9248 CALL DPWRST('XXX','BUG ') 9249 70 CONTINUE 9250 WRITE(ICOUT,73)(IA(I),I=1,100) 9251 73 FORMAT('(IA(I),I=1,100) = ',100A1) 9252 CALL DPWRST('XXX','BUG ') 9253 WRITE(ICOUT,75)IMACRO,IPROGR,ICONCL,NUMCHA 9254 75 FORMAT('IMACRO,IPROGR,ICONCL,NUMCHA = ',3(A4,2X),I8) 9255 CALL DPWRST('XXX','BUG ') 9256 WRITE(ICOUT,81)ISACNC 9257 81 FORMAT('ISACNC = ',80A1) 9258 CALL DPWRST('XXX','BUG ') 9259 WRITE(ICOUT,82)IAUTSW,IAUTEX,ITOPIC,MAXNXT 9260 82 FORMAT('IAUTSW,IAUTEX,ITOPIC,MAXNXT = ',3(A4,2X),I8) 9261 CALL DPWRST('XXX','BUG ') 9262 WRITE(ICOUT,83)IHELMX,IFTEXP,IFORSW,ALOWFR 9263 83 FORMAT('IHELMX,IFTEXP,IFORSW,ALOWFR = ',I8,2(2X,A4),G15.7) 9264 CALL DPWRST('XXX','BUG ') 9265CCCCC THE FOLLOWING 2 LINES WERE INSERTED NOVEMBER 1989 9266 WRITE(ICOUT,86)YATCCU,YATTCU,YATRCU,IYATOS,IYATRS 9267 86 FORMAT('YATCCU,YATTCU,YATRCU,IYATOS,IYATRS = ',3G15.7, 9268 1 2(2X,A4)) 9269 CALL DPWRST('XXX','BUG ') 9270 WRITE(ICOUT,87)IRHSTG,IPRITY,IOUTTY,ALOWDG 9271 87 FORMAT('IRHSTG,IPRITY,IOUTTY,ALOWDG = ',3(A4,2X),G15.7) 9272 CALL DPWRST('XXX','BUG ') 9273 WRITE(ICOUT,88)ITABBR,ITABSP,ITABWD,ITABHT,NCTABT 9274 88 FORMAT('ITABBR,ITABSP,ITABWD,ITABHT,NCTABT = ',A4,2X,4I8) 9275 CALL DPWRST('XXX','BUG ') 9276 WRITE(ICOUT,89)ITABTI 9277 89 FORMAT('ITABTI = ',A80) 9278 CALL DPWRST('XXX','BUG ') 9279 ENDIF 9280C 9281 IFOUND='NO' 9282 IERROR='NO' 9283C 9284C ****************************** 9285C ** TREAT THE ADD CASE ** 9286C ** TREAT THE CALL CASE ** 9287C ** TREAT THE EXECUTE CASE ** 9288C ** TREAT THE RUN CASE ** 9289C ****************************** 9290C 9291C 2015/03: CALL EXIT AND CALL EXIT ALL CASES SUPPORTED 9292C 9293 IF(ICOM.EQ.'ADD' .OR. ICOM.EQ.'CALL' .OR. 9294 1 ICOM.EQ.'EXEC' .OR. ICOM.EQ.'RUN ')THEN 9295C 9296 IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'CLIP' .AND. 9297 1 IHARG2(1).EQ.'BOAR')THEN 9298C 9299C CHECK IF ARGUMENT IS A FILE NAME STARTING WITH 9300C "CLIPBOARD. 9301C 9302 IWORD=2 9303 IOFILE='NO' 9304 CALL DPFILE(IANSLC,IWIDTH,IWORD, 9305 1 IOFILE,IBUGS2,ISUBRO,IERROR) 9306 IF(IOFILE.EQ.'NO')GOTO13390 9307 ENDIF 9308C 9309 IF(NUMARG.EQ.1 .AND. 9310 1 IHARG(1).EQ.'EXIT')THEN 9311 IMACCS='CLO2 ' 9312 IMACRO='EOF' 9313 IFOUND='YES' 9314 ELSE 9315C 9316C 2015/11: COMMAND LINE SUBSTITUTION (ISSUE FOR LOOPS) 9317C 9318 IF(ILOOST.NE.'STOR')THEN 9319 CALL DPREP2(IANSLC,IWIDTH, 9320 1 IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 9321 1 IVARLB,IROWLB,MAXOBV, 9322 1 IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,IMALEV, 9323 1 IBUGS2,ISUBRO,IERROR) 9324 ELSE 9325C 9326C IN PROCESSING THE CALL COMMAND IN STORE MODE, WE ACTUALLY WANT 9327C TO PERFORM COMMAND LINE SUBSTITION FOR THE FILE NAME, BUT NOT 9328C FOR THE COMMAND LINE ARGUMENTS. IF THERE ARE NO COMMAND LINE 9329C ARGUMENTS, THEN NO SPECIAL PROCESSING NEEDED. 9330C 9331 ICANS=' ' 9332 DO13301II=1,IWIDTH 9333 ICANS(II:II)=IANSLC(II)(1:1) 933413301 CONTINUE 9335C 9336C NOW SEARCH FOR THE LOCATION OF THE FIRST TWO WORDS. 9337C 9338 IQUOTE='"' 9339 ISTART=0 9340 DO13303II=1,IWIDTH 9341 IF(ICANS(II:II).NE.' ')THEN 9342 ISTART=1 9343 GOTO13309 9344 ENDIF 934513303 CONTINUE 9346 GOTO13399 934713309 CONTINUE 9348C 9349 IQFLAG=0 9350 IF(ICANS(ISTART:ISTART).EQ.IQUOTE)IQFLAG=1 9351 DO13310KK=1,2 9352 DO13311II=ISTART,IWIDTH 9353 IF(IQFLAG.EQ.0)THEN 9354 IF(ICANS(II:II).EQ.' ')THEN 9355 ISTOP=II-1 9356 GOTO13319 9357 ENDIF 9358 ELSE 9359 IF(ICANS(II:II).EQ.IQUOTE)THEN 9360 ISTOP=II 9361 GOTO13319 9362 ENDIF 9363 ENDIF 936413311 CONTINUE 9365 CALL DPREP2(IANSLC,IWIDTH, 9366 1 IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 9367 1 IVARLB,IROWLB,MAXOBV, 9368 1 IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,IMALEV, 9369 1 IBUGS2,ISUBRO,IERROR) 9370 GOTO13399 937113319 CONTINUE 9372 IF(KK.EQ.1)THEN 9373 ISTART=ISTOP+2 9374 ENDIF 937513310 CONTINUE 9376C 9377C NOW DO COMMAND LINE SUBSTITUTION FOR THE FIRST ISTOP 9378C CHARACTERS. 9379C 9380 ISTOP2=ISTOP 9381 CALL DPREP2(IANSLC,ISTOP, 9382 1 IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 9383 1 IVARLB,IROWLB,MAXOBV, 9384 1 IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,IMALEV, 9385 1 IBUGS2,ISUBRO,IERROR) 9386 ICNT=ISTOP 9387 DO13321II=ISTOP2+1,IWIDTH 9388 ICNT=ICNT+1 9389 IANSLC(ICNT)(1:1)=ICANS(II:II) 939013321 CONTINUE 9391 IWIDTH=ICNT 9392 ENDIF 9393 ENDIF 9394C 939513399 CONTINUE 9396 CALL DPMACR(ICOM,ICOM2, 9397CCCCC THE FOLOWING LINE WAS AUGMENTED AUGUST 1994 9398CCCCC1 IMACRO,IMACNU,IMACCS, 9399 1 IMACRO,IMACNU,IMACCS,IMACL1,IMACL2,IMACLR,IMALEV, 9400 1 IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,MAXNAM, 9401 1 IANSLC,IWIDTH, 9402 1 IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 9403 1 IOFILE, 9404 1 ILOOST,ILOOLI,NUMLIL,NUMLOS, 9405 1 IANSLO,IWIDLL,MAXCIL,MAXLIL, 9406 1 IBUGS2,ISUBRO,IFOUND,IERROR) 9407C 9408C IF "CALL EXIT" OR "CALL EXIT ALL" ENTERED, THEN DEPRECATE 9409C CURRENT IF SWITCH SETTING. 9410C 9411 IF(ICOM.EQ.'CALL' .AND. IHARG(1).EQ.'EXIT')THEN 9412 IF(IIFSW.EQ.'TRUE' .AND. NUMIF.GT.0)NUMIF=NUMIF-1 9413 ENDIF 9414 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9415 ENDIF 9416C 941713390 CONTINUE 9418C ********************************************** 9419C ** TREAT THE INSERT CALL ARGUMENTS CASE ** 9420C ********************************************** 9421C 9422 IF(ICOM.EQ.'INSE' .AND. IHARG(1).EQ.'CALL' .AND. 9423 1 IHARG(2).EQ.'ARGU')THEN 9424 CALL DPICLA(ICOM,ICOM2, 9425 1 IMACRO,IMACNU,IMACCS, 9426 1 IMACL1,IMACL2, 9427 1 IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,MAXNAM, 9428 1 IANSLC,IWIDTH, 9429 1 IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 9430 1 IBUGS2,ISUBRO,IFOUND,IERROR) 9431 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9432 ENDIF 9433C 9434C 9435C ****************************** 9436C ** TREAT THE DEFINE CASE ** 9437C ****************************** 9438C 9439 IF(ICOM.EQ.'DEFI')THEN 9440 CALL DPDEFI(IHARG,IHARG2,IHARLC,NUMARG, 9441 1 ICOM3,ICOM4,ICOM5,NUMCOM,NCOM5, 9442 1 ICPREP,NCPREP,ICPOST,NCPOST, 9443 1 ICPREH,NCPREH,ICPOSH,NCPOSH, 9444 1 IBUGS2,ISUBRO,IFOUND,IERROR) 9445 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9446 ENDIF 9447C 9448C ******************************** 9449C ** TREAT THE TRANSLATE CASE ** 9450C ******************************** 9451C 9452 IF(ICOM.EQ.'TRAN')THEN 9453 CALL DPTRAN(IHARG,IHARG2,NUMARG, 9454 1 ICTRA1,NCTRA1,ICTRA2,NCTRA2,NUMTRA, 9455 1 IBUGS2,ISUBRO,IFOUND,IERROR) 9456 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9457 ENDIF 9458C 9459C *************************** 9460C ** TREAT THE BAUD CASE ** 9461C *************************** 9462C 9463 IF(ICOM.EQ.'BAUD')THEN 9464 CALL DPBAUD(IHARG,IARGT,IARG,NUMARG,IDEFBA, 9465 1 IBAUD,IFOUND,IERROR) 9466 IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')THEN 9467 IGBAUD=IBAUD 9468 DO415I=1,MAXDEV 9469 IDBAUD(I)=IBAUD 9470 415 CONTINUE 9471 ENDIF 9472 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9473 ENDIF 9474C 9475C ************************************ 9476C ** TREAT THE COLUMN LIMITS CASE ** 9477C ************************************ 9478C 9479CCCCC IF(ICOM.EQ.'COLU')GOTO500 9480C DECEMBER, 1989. CHECK FOR CONFLICT WWITH COLUMN RULER COMMAND. 9481 IF(ICOM.EQ.'COLU'.AND.IHARG(1).NE.'RULE')GOTO500 9482 GOTO599 9483C 9484 500 CONTINUE 9485 CALL DPCOLL(IDEFC1,IDEFC2,IFCOL1,IFCOL2, 9486CCCCC FEBRUARY 2003: ADD FOLLOWING LINE 9487 1NUMRCM, 9488 1IFCOLL,IFCOLU, 9489 1IFOUND,IERROR) 9490 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9491C 9492 599 CONTINUE 9493C 9494C ************************************ 9495C ** TREAT THE TABLE WIDTH CASE ** 9496C ************************************ 9497C 9498 IF(ICOM.EQ.'TABL'.AND.IHARG(1).EQ.'WIDT')THEN 9499 CALL DPTAWI(IFORWI,IFORWR,MAXNWI, 9500 1 ISUBRO,IBUGS2,IFOUND,IERROR) 9501 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9502 ENDIF 9503C 9504C ******************************************** 9505C ** TREAT THE MAXIMUM RECORD LENGTH CASE ** 9506C ******************************************** 9507C 9508 IF(ICOM.EQ.'MAXI'.AND.IHARG(1).EQ.'RECO'.AND.IHARG(2).EQ.'LENG') 9509 1 THEN 9510 CALL DPMXRL(IHARG,IARGT,IARG,NUMARG,IDEFRL,NUMRCM,MAXRCL, 9511 1 IFOUND,IERROR) 9512 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9513 ENDIF 9514C 9515C ****************************** 9516C ** TREAT THE DEGREES CASE ** 9517C ****************************** 9518C 9519C (THE FOLLOWING IS COMMENTED OUT 9520C (THE FOLLOWING IS COMMENTED OUT 9521C (THE FOLLOWING IS COMMENTED OUT 9522C IN THE SUBROUTINE MAINDG) 9523C 9524CCCCC IF(ICOM.EQ.'DEGR'.AND.ICOM2.EQ.'EES ')GOTO700 9525CCCCC GOTO799 9526C 9527CC700 CONTINUE 9528CCCCC CALL DPDEGS(IHARG,NUMARG,IDEFAU, 9529CCCCC1IANGLU,IFOUND,IERROR) 9530CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9531C 9532CC799 CONTINUE 9533C 9534C ***************************** 9535C ** TREAT THE DELETE CASE ** 9536C ***************************** 9537C 9538 IF(ICOM.EQ.'DELE')THEN 9539CCCCC THE FOLLOWING LINE WAS FIXED SEPTEMBER 1995 9540CCCCC CALL DPDELE(IBUGS2,IBUGQ,IFOUND,IERROR) 9541 CALL DPDELE(IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR) 9542 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9543 ENDIF 9544C 9545C ********************************************* 9546C ** TREAT THE DEMODULATION FREQUENCY CASE ** 9547C ********************************************* 9548C 9549 IF(ICOM.EQ.'DEMO')THEN 9550 CALL DPDEFR(IHARG,IARGT,ARG,NUMARG,DEFDMF, 9551 1 DEMOFR,IFOUND,IERROR) 9552 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9553 ENDIF 9554C 9555C ********************************** 9556C ** TREAT THE DIMENSION CASE ** 9557C ** TREAT THE REDIMENSION CASE ** 9558C ********************************** 9559C 9560 IF(ICOM.EQ.'DIME' .OR. ICOM.EQ.'REDI' .OR. 9561 1 (ICOM.EQ.'MATR' .AND. IHARG(1).EQ.'DIME'))THEN 9562 CALL DPDIME(IANS,IHARG,IARGT,IARG,NUMARG,IDEMXN,IDEMXC, 9563 1 IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP, 9564 1 IVALUE,VALUE,NUMNAM,MAXNAM, 9565 1 V,MAXNK,NUMN,MAXN,MAXNXT, 9566CCCCC JANUARY 1998. ADD FOLLOWING LINE 9567 1 MAXTOM,MAXROM,MAXCOM,MAXOBV, 9568 1 NUMCOL,MAXCOL,IFOUND,IERROR,IBUGS2) 9569 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9570 ENDIF 9571C 9572C *************************************** 9573C ** TREAT THE DOUBLE PRECISION CASE ** 9574C *************************************** 9575C 9576 IF(ICOM.EQ.'DOUB')THEN 9577CCCCC CHECK FOR CONFLICT WITH DOUBLY NON-CENTRAL F PROB PLOT. 9578CCCCC SEPTEMBER 1994 9579CCCCC CHECK FOR CONFLICT WITH DOUBLE EXPONENTIAL PROB PLOT. 9580CCCCC OCTOBER 1995 9581 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'NONC')GOTO9000 9582 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'NON-')GOTO9000 9583 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'WEIB')GOTO9000 9584 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'EXPO')GOTO9000 9585 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'GAMM')GOTO9000 9586 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SAMP')GOTO9000 9587 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PARE')GOTO9000 9588 CALL DPDOUB(IHARG,NUMARG,IDEFPR,IHMXPR, 9589 1 IPREC,IFOUND,IERROR) 9590 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9591 ENDIF 9592C 9593C *************************** 9594C ** TREAT THE ECHO CASE ** 9595C *************************** 9596C 9597 IF(ICOM.EQ.'ECHO')THEN 9598 CALL DPECSW(IHARG,NUMARG, 9599 1 IECHO,IFOUND,IERROR) 9600 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9601 ENDIF 9602C 9603C **************************** 9604C ** TREAT THE EXIT CASE ** 9605C ** TREAT THE END CASE ** 9606C ** TREAT THE HALT CASE ** 9607C ** TREAT THE STOP CASE ** 9608C **************************** 9609C 9610 IF((ICOM.EQ.'END ' .AND. NUMARG.LE.0) .OR. 9611 1 ICOM.EQ.'EXIT' .OR. 9612 1 ICOM.EQ.'HALT' .OR. ICOM.EQ.'STOP' .OR. 9613 1 ICOM.EQ.'BYE ' .OR. ICOM.EQ.'QUIT')THEN 9614 CALL DPEXIT(ICAPSW,IBUGS2,ISUBRO,IFOUND,IERROR) 9615 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9616 ENDIF 9617C 9618C ********************************** 9619C ** TREAT THE ERASE DELAY CASE ** 9620C ********************************** 9621C 9622 IF(ICOM.EQ.'ERAS')THEN 9623 CALL DPERDE(IHARG,IARGT,ARG,NUMARG,DEFERD, 9624 1 ERASDE,IFOUND,IERROR) 9625 IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')AGERDE=ERASDE 9626 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9627 ENDIF 9628C 9629C ************************************** 9630C ** TREAT THE FIT CONSTRAINT CASE ** 9631C ************************************** 9632C 9633 IF(ICOM.EQ.'FIT'.AND.NUMARG.GE.1.AND. 9634 1 IHARG(1).EQ.'CONS')THEN 9635 CALL DPFICN(ICOM,IHARG,IHARG2,IARGT,ARG,NUMARG, 9636 1 IPARNC,IPANC2,IPAROP, 9637 1 PARLIM,PARLLM,PARULM, 9638 1 NUMCON,MAXCON,IFOUND,IERROR,IBUGS2) 9639 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9640 ENDIF 9641C 9642C ************************************* 9643C ** TREAT THE FIT ITERATIONS CASE ** 9644C ************************************* 9645C 9646 IF(ICOM.EQ.'FIT'.AND.NUMARG.GE.1.AND. 9647 1 IHARG(1).EQ.'ITER')THEN 9648 CALL DPFIIT(IHARG,IARGT,IARG,NUMARG,IDEFNI, 9649 1 IFITIT,IFOUND,IERROR) 9650 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9651 ENDIF 9652C 9653C ******************************** 9654C ** TREAT THE FIT POWER CASE ** 9655C ******************************** 9656C 9657 IF(ICOM.EQ.'FIT'.AND.NUMARG.GE.1.AND. 9658 1 IHARG(1).EQ.'POWE')THEN 9659 CALL DPFIPW(IHARG,IARGT,ARG,NUMARG,DEFFPW, 9660 1 FITPOW,IFOUND,IERROR) 9661 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9662 ENDIF 9663C 9664C ********************************************* 9665C ** TREAT THE FIT STANDARD DEVIATION CASE ** 9666C ********************************************* 9667C 9668 IF(ICOM.EQ.'FIT'.AND.NUMARG.GE.1.AND. 9669 1 IHARG(1).EQ.'STAN')THEN 9670 CALL DPFISD(IHARG,IARGT,ARG,NUMARG,DEFFSD, 9671 1 FITSD,IFOUND,IERROR) 9672 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9673 ENDIF 9674C 9675C **************************** 9676C ** TREAT THE GRADS CASE ** 9677C **************************** 9678C 9679C (THE FOLLOWING IS COMMENTED OUT 9680C BECAUSE THE ANGLE COMMAND IS NOW DONE 9681C IN THE SUBROUTINE MAINDG) 9682C 9683CCCCC IF(ICOM.EQ.'GRAD')GOTO2100 9684CCCCC GOTO2199 9685C 9686C2100 CONTINUE 9687CCCCC CALL DPGRAD(IHARG,NUMARG,IDEFAU, 9688CCCCC1IANGLU,IFOUND,IERROR) 9689CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9690C 9691C2199 CONTINUE 9692C 9693C ************************************** 9694C ** TREAT THE HARDCOPY DELAY CASE ** 9695C ************************************** 9696C 9697 IF(ICOM.EQ.'HARD')THEN 9698 CALL DPHADE(IHARG,IARGT,ARG,NUMARG,DEFHAD, 9699 1 HARDDE,IFOUND,IERROR) 9700 IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')AGCODE=HARDDE 9701 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9702 ENDIF 9703C 9704C *************************** 9705C ** TREAT THE HELP CASE ** 9706C *************************** 9707C 9708 IF(ICOM.EQ.'HELP')THEN 9709C 9710CCCCC THE FOLLOWING CALL WAS CHANGED JULY 1990 9711CCCCC CALL DPHELP(IHARG,IHARG2,NUMARG,IANS,IWIDTH, 9712CCCCC1IHELMX, 9713CCCCC1ICPREH,NCPREH,ICPOSH,NCPOSH, 9714CCCCC1IBUGS2,ISUBRO,IFOUND,IERROR) 9715C 9716CCCCC THE FOLLOWING CALL WAS INSERTED JULY 1990 9717CCCCC AND THEN COMMENTED OUT NOVEMBER 1991 9718CCCCC CALL DPHELP(IHARG,IHARG2,NUMARG,IANS,IWIDTH, 9719CCCCC1IHE1CO,IHE1AL, 9720CCCCC1IHE2CO,IHE2AL, 9721CCCCC1IHE3CO,IHE3AL, 9722CCCCC1IHE4CO,IHE4AL, 9723CCCCC1IHE5CO,IHE5AL, 9724CCCCC1IHE6CO,IHE6AL, 9725CCCCC1IHE7CO,IHE7AL, 9726CCCCC1IHE8CO,IHE8AL, 9727CCCCC1IHE9CO,IHE9AL, 9728CCCCC1IHELMX, 9729CCCCC1ICPREH,NCPREH,ICPOSH,NCPOSH, 9730CCCCC1IBUGS2,ISUBRO,IFOUND,IERROR) 9731C 9732CCCCC THE FOLLOWING CALL WAS CHANGED BACK NOVEMBER 1991 9733 CALL DPHELP(IHARG,IHARG2,NUMARG,IANS,IWIDTH, 9734 1 IHELMX, 9735 1 ICPREH,NCPREH,ICPOSH,NCPOSH, 9736 1 IBUGS2,ISUBRO,IFOUND,IERROR) 9737 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9738 ENDIF 9739C 9740C *************************** 9741C ** TREAT THE HOST CASE ** 9742C *************************** 9743C 9744 IF(ICOM.EQ.'HOST'.AND.IHARG(1).NE.'LINK')THEN 9745 CALL DPHOST(IHARG,NUMARG,IDEFHO, 9746 1 IHOST,IHOST1,IHOST2,IFOUND,IERROR) 9747 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9748 ENDIF 9749C 9750C ******************************** 9751C ** TREAT THE HOST LINK CASE ** 9752C ******************************** 9753C 9754 IF(ICOM.EQ.'HOST'.AND.NUMARG.GE.1.AND. 9755 1IHARG(1).EQ.'LINK')GOTO2500 9756 IF(ICOM.EQ.'COMM'.AND.NUMARG.GE.1.AND. 9757 1IHARG(1).EQ.'LINK')GOTO2500 9758 IF(ICOM.EQ.'LINK')GOTO2500 9759 GOTO2599 9760C 9761 2500 CONTINUE 9762 IF(IHARG(1).EQ.'LINK')THEN 9763 ISHIFT=1 9764 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 9765 1 IBUGS2,IERROR) 9766 IHARG(1)='LINK' 9767 IHARG2(1)=' ' 9768 ENDIF 9769 CALL DPHOSL(IHARG,NUMARG,IDEFHL, 9770 1IHOSLI,IFOUND,IERROR) 9771 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9772C 9773 2599 CONTINUE 9774C 9775C **************************** 9776C ** TREAT THE KNOTS CASE ** 9777C **************************** 9778C 9779 IF(ICOM.EQ.'KNOT')THEN 9780 CALL DPKNOT(IHARG,IHARG2,NUMARG,IDEFK1,IDEFK2, 9781 1 IKNOT1,IKNOT2,IFOUND,IERROR) 9782 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9783 ENDIF 9784C 9785C ************************************ 9786C ** TREAT THE MACRO CASE ** 9787C ** TREAT THE END MACRO CASE ** 9788C ** TREAT THE END OF MACRO CASE ** 9789C ** TREAT THE CREATE CASE ** 9790C ** TREAT THE END CREATE CASE ** 9791C ** TREAT THE END OF CREATE CASE ** 9792C ************************************ 9793C 9794 IF(ICOM.EQ.'MACR' .OR. ICOM.EQ.'CREA')GOTO2700 9795 IF(ICOM.EQ.'END ' .AND. NUMARG.GE.1 .AND. 9796 1 (IHARG(1).EQ.'MACR' .OR. IHARG(1).EQ.'CREA'))GOTO2700 9797 IF(ICOM.EQ.'END ' .AND. NUMARG.GE.2 .AND. IHARG(1).EQ.'OF ' .AND. 9798 1 (IHARG(2).EQ.'MACR' .OR. IHARG(2).EQ.'CREA'))GOTO2700 9799 GOTO2799 9800C 9801 2700 CONTINUE 9802 CALL DPMACR(ICOM,ICOM2, 9803CCCCC THE FOLOWING LINE WAS AUGMENTED AUGUST 1994 9804CCCCC1 IMACRO,IMACNU,IMACCS, 9805 1 IMACRO,IMACNU,IMACCS,IMACL1,IMACL2,IMACLR,IMALEV, 9806 1 IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,MAXNAM, 9807 1 IANSLC,IWIDTH, 9808 1 IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 9809 1 IOFILE, 9810 1 ILOOST,ILOOLI,NUMLIL,NUMLOS, 9811 1 IANSLO,IWIDLL,MAXCIL,MAXLIL, 9812 1 IBUGS2,ISUBRO,IFOUND,IERROR) 9813 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9814C 9815 2799 CONTINUE 9816C 9817C ******************************* 9818C ** TREAT THE OPERATOR CASE ** 9819C ** TREAT THE CONSOLE CASE ** 9820C ******************************* 9821C 9822 IF((ICOM.EQ.'CONS'.AND.ICOM2.EQ.'OLE ') .OR. 9823 1 ICOM.EQ.'OPER')THEN 9824 CALL DPOPMS(IANSLC,IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR) 9825 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9826 ENDIF 9827C 9828C *************************** 9829C ** TREAT THE NAME CASE ** 9830C *************************** 9831C 9832 IF(ICOM.EQ.'NAME' .OR. ICOM.EQ.'RENA')THEN 9833 CALL DPNAME(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 9834 1 IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP, 9835 1 IVALUE,VALUE,NUMNAM,MAXNAM, 9836 1 IVARLB, 9837 1 NUMCOL,MAXCOL,MAXN,IANS,IWIDTH, 9838 1 IBUGS2,IFOUND,IERROR) 9839 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9840 ENDIF 9841C 9842C ************************************* 9843C ** TREAT THE VARIABLE LABEL CASE ** 9844C ** NAME CONFLICTS WITH "VARIANCE" ** 9845C ** COMMANDS. ** 9846C ************************************* 9847C 9848 IF(ICOM.EQ.'VARI'.AND.ICOM2.EQ.'ABLE')THEN 9849 CALL DPVLAB(IHARG,IHARG2,IARG,NUMARG, 9850 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE, 9851 1 NUMNAM,MAXNAM,IVARLB, 9852 1 IANS,IANSLC,IWIDTH,IBUGS2,IFOUND,IERROR) 9853 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9854 ENDIF 9855C 9856C **************************************** 9857C ** TREAT THE POLYNOMIAL DEGREE CASE ** 9858C ** TREAT THE DEGREE CASE ** 9859C **************************************** 9860C 9861 IF((ICOM.EQ.'DEGR'.AND.ICOM2.EQ.'EE ') .OR. 9862 1 (ICOM.EQ.'POLY'.AND.IHARG(1).NE.'AEPP'))THEN 9863C 9864C CHECK FOR NAME CONFLICTS 9865C 9866 IF(NUMARG.GE.2. AND. IHARG(1).EQ.'MLE')GOTO3199 9867 IF(NUMARG.GE.3. AND. IHARG(1).EQ.'MAXI' .AND. 9868 1 IHARG(2).EQ.'LIKE')GOTO3199 9869 IF(IHARG(1).EQ.'FIT' .OR. IHARG(2).EQ.'FIT' .OR. 9870 1 IHARG(3).EQ.'FIT')GOTO3199 9871C 9872 CALL DPDEGR(IHARG,IARGT,IARG,NUMARG,IDEFDG,IDEG,IFOUND,IERROR) 9873 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9874 ENDIF 9875C 9876 3199 CONTINUE 9877C 9878C ******************************** 9879C ** TREAT THE PRECISION CASE ** 9880C ******************************** 9881C 9882 IF(ICOM.EQ.'PREC' .AND. IHARG(1).NE.'PLOT')THEN 9883 CALL DPPREC(IHARG,NUMARG,IDEFPR,IHMXPR, 9884 1 IPREC,IFOUND,IERROR) 9885 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9886 ENDIF 9887C 9888C ******************************** 9889C ** TREAT THE PRE-ERASE CASE ** 9890C ******************************** 9891C 9892 IF(ICOM.EQ.'PRE')THEN 9893 CALL DPPREE(IHARG,NUMARG, 9894 1 IERASW,IFOUND,IERROR) 9895 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9896 ENDIF 9897C 9898C ******************************* 9899C ** TREAT THE PRINTING CASE ** 9900C ******************************* 9901C 9902 IF(ICOM.EQ.'PRIN'.AND.ICOM2.EQ.'TING')THEN 9903 CALL DPPRSW(IHARG,NUMARG, 9904 1 IPRIN2,IFOUND,IERROR) 9905 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9906 ENDIF 9907C 9908C **************************** 9909C ** TREAT THE PROBE CASE ** 9910C **************************** 9911C 9912 IF(ICOM.EQ.'PROB' .OR. ICOM.EQ.'DUMP')THEN 9913 CALL DPPROB(ILISMX,IREPCH,IOSW, 9914 1 IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO, 9915 1 IBUGEX,IBUGE2,IBUGHE,IBUGH2,IBUGLO, 9916 1 IHELMX,IFTEXP,IFTORD, 9917 1 IFORSW,ICREAF,NCREAF,ICWRIF,NCWRIF, 9918 1 IREARW,IWRIRW,NPLOTP,IPRITY, 9919 1 IUNFOF,IUNFNR,IUNFMC,IMACRO,IMALEV, 9920 1 IANSLO,ILOOST,ILOOLI, 9921 1 NUMIF,ISEED, 9922 1 IFOUND,IERROR) 9923 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9924 ENDIF 9925C 9926C ****************************************** 9927C ** TREAT THE QUADRUPLE PRECISION CASE ** 9928C ****************************************** 9929C 9930 IF(ICOM.EQ.'QUAD'.AND.ICOM2.EQ.'RUPL')THEN 9931 CALL DPQUAD(IHARG,NUMARG,IDEFPR,IHMXPR, 9932 1 IPREC,IFOUND,IERROR) 9933 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9934 ENDIF 9935C 9936C ****************************** 9937C ** TREAT THE RADIANS CASE ** 9938C ****************************** 9939C 9940C (THE FOLLOWING IS COMMENTED OUT 9941C BECAUSE THE ANGLE COMMAND IS NOW DONE 9942C IN THE SUBROUTINE MAINDG) 9943C 9944CCCCC IF(ICOM.EQ.'RADI')GOTO3700 9945CCCCC GOTO3799 9946C 9947C3700 CONTINUE 9948CCCCC CALL DPRADI(IHARG,NUMARG,IDEFAU, 9949CCCCC1IANGLU,IFOUND,IERROR) 9950CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9951C 9952C3799 CONTINUE 9953C 9954C *************************** 9955C ** TREAT THE READ CASE ** 9956C *************************** 9957C 9958 IF(ICOM.EQ.'READ')THEN 9959 INTINF=I1MACH(9) 9960 CALL DPREAD(IFROW1,IFROW2,IFCOL1,IFCOL2,ISKIP,INTINF, 9961 1 IMACRO,IMACNU,IMACCS,IMALEV,IOSW,ICREAF,NCREAF, 9962 1 IREARW,ICOMCH,ICOMSW, 9963 1 IUNFOF,IUNFNR,IUNFMC,NUMRCM, 9964 1 IFCOLL,IFCOLU, 9965 1 IANSLO,ILOOST,ILOOLI,IREPCH, 9966 1 IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR) 9967 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9968 ENDIF 9969C 9970C ********************************** 9971C ** TREAT THE STREAM READ CASE ** 9972C ********************************** 9973C 9974 IF(ICOM.EQ.'STRE' .AND. IHARG(1).EQ.'READ')THEN 9975 INTINF=I1MACH(9) 9976 CALL DPSTRE(IFROW1,IFROW2,IFCOL1,IFCOL2,ISKIP,INTINF, 9977 1 IMACRO,IMACNU,IMACCS,IMALEV,IOSW,ICREAF,NCREAF, 9978 1 ICWRIF,NCWRIF,IREARW,ICOMCH,ICOMSW, 9979 1 IUNFOF,IUNFNR,IUNFMC,NUMRCM, 9980 1 IFCOLL,IFCOLU, 9981 1 IANSLO,ILOOST,ILOOLI,IREPCH, 9982 1 IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR) 9983 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9984 ENDIF 9985C 9986C **************************** 9987C ** TREAT THE RESET CASE ** 9988C **************************** 9989C 9990 IF(ICOM.EQ.'CLEA' .AND. ICOM2.NE.'N ' .AND. 9991 1 IHARG(1).NE.'CLIP')THEN 9992 ICOM='RESE' 9993 ICOM2='T ' 9994 ENDIF 9995C 9996 IF(ICOM.EQ.'RESE')THEN 9997 CALL DPRESE(IFOUND,IERROR) 9998 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 9999 ENDIF 10000C 10001C ****************************** 10002C ** TREAT THE RESTORE CASE ** 10003C ****************************** 10004C 10005 IF(NUMARG.GE.1.AND.ICOM.EQ.'REST'.AND. 10006 1IHARG(1).EQ.'MEMO'.AND.IHARG2(1).EQ.'RY ')GOTO4000 10007 IF(NUMARG.GE.1.AND.ICOM.EQ.'REST'.AND. 10008 1IHARG(1).EQ.'ALL '.AND.IHARG2(1).EQ.' ')GOTO4000 10009 IF(ICOM.EQ.'REST')GOTO4000 10010 GOTO4099 10011C 10012 4000 CONTINUE 10013 CALL DPREST(IFOUND,IERROR) 10014 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10015C 10016 4099 CONTINUE 10017C 10018C ***************************** 10019C ** TREAT THE RETAIN CASE ** 10020C ** TREAT THE KEEP CASE ** 10021C ** TREAT THE PACK CASE ** 10022C ***************************** 10023C 10024 IF(ICOM.EQ.'RETA' .OR. ICOM.EQ.'KEEP' .OR. 10025 1 ICOM.EQ.'PACK')THEN 10026 CALL DPRETA(IBUGS2,IBUGQ,IFOUND,IERROR) 10027 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10028 ENDIF 10029C 10030C ********************************* 10031C ** TREAT THE ROW LIMITS CASE ** 10032C ********************************* 10033C 10034 IF(ICOM.EQ.'ROW')THEN 10035 CALL DPROWL(IHARG,IARGT,IARG,NUMARG,IDEFR1,IDEFR2, 10036 1 IFROW1,IFROW2,IFOUND,IERROR) 10037 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10038 ENDIF 10039C 10040C ****************************************** 10041C ** TREAT THE TERMINATOR CHARACTOR CASE ** 10042C ** TREAT THE SEPARATOR CHARACTOR CASE ** 10043C ****************************************** 10044C 10045 IF((ICOM.EQ.'TERM'.AND.ICOM2.EQ.'INAT') .OR. 10046 1 (ICOM.EQ.'SEPA'.AND.ICOM2.EQ.'RATO'))THEN 10047 CALL DPTECH(IHARG,NUMARG, 10048 1 IDEFTC,ITERCH, 10049 1 IBUGS2,IFOUND,IERROR) 10050 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10051 ENDIF 10052C 10053C ****************************************** 10054C ** TREAT THE CONTINUE CHARACTOR CASE ** 10055C ****************************************** 10056C 10057 IF(ICOM.EQ.'CONT' .AND. ICOM2.EQ.'INUE' .AND. 10058 1 IHARG(1).NE.'LOOP')THEN 10059 CALL DPCONC(IHARG,NUMARG, 10060 1 IDEFCC, 10061 1 ICONCH, 10062 1 IBUGS2,IFOUND,IERROR) 10063 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10064 ENDIF 10065C 10066CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 1989 10067C ******************************************** 10068C ** TREAT THE REPLACEMENT CHARACTOR CASE ** 10069C ** TREAT THE SUBSTITUTION CHARACTOR CASE ** 10070C ******************************************** 10071C 10072 IF((ICOM.EQ.'REPL'.AND.ICOM2.EQ.'ACEM') .OR. 10073 1 (ICOM.EQ.'SUBS'.AND.ICOM2.EQ.'TITU'))THEN 10074 CALL DPRECH(IHARG,NUMARG, 10075 1 IBASLC,IREPCH, 10076 1 IBUGS2,IFOUND,IERROR) 10077 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10078 ENDIF 10079C 10080CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 2005 10081C ************************************************** 10082C ** TREAT THE MACRO SUBSTITUTION CHARACTOR CASE ** 10083C ************************************************** 10084C 10085 IF(ICOM.EQ.'MACR'.AND.IHARG(1).EQ.'SUBS'.AND. 10086 1 IHARG(2).EQ.'CHAR')THEN 10087 CALL DPREMA(IHARG,NUMARG, 10088 1 IMACSC,IDEFMS, 10089 1 IBUGS2,ISUBRO,IFOUND,IERROR) 10090 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10091 ENDIF 10092C 10093C ********************************** 10094C ** TREAT THE SERIAL READ CASE ** 10095C ********************************** 10096C 10097 IF(ICOM.EQ.'SERI')THEN 10098C 10099CCCCC MAY, 1990. ADD ICOMCH, ICOMSW TO CALL LIST 10100CCCCC MARCH, 1996. ADD IMALEV TO CALL LIST 10101 INTINF=I1MACH(9) 10102 CALL DPSERI(IFROW1,IFROW2,IFCOL1,IFCOL2,ISKIP,INTINF, 10103 1 IMACRO,IMACNU,IMACCS,IOSW,IMALEV, 10104 1 IREARW,ICOMCH,ICOMSW, 10105CCCCC FEBRAURY 2003. ADD FOLLOWING LINE 10106 1 NUMRCM, 10107 1 IFCOLL,IFCOLU, 10108 1 IANSLO,ILOOST,ILOOLI,IREPCH, 10109 1 IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR) 10110 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10111 ENDIF 10112C 10113C *************************************** 10114C ** TREAT THE SINGLE PRECISION CASE ** 10115C *************************************** 10116C 10117 IF(ICOM.EQ.'SING' .AND. IHARG(1).NE.'SAMP')THEN 10118 CALL DPSING(IHARG,NUMARG,IDEFPR,IHMXPR, 10119 1 IPREC,IFOUND,IERROR) 10120 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10121 ENDIF 10122C 10123C *************************** 10124C ** TREAT THE SKIP CASE ** 10125C *************************** 10126C 10127 IF(ICOM.EQ.'SKIP')THEN 10128 CALL DPSKIP(IHARG,IARGT,IARG,NUMARG,IDEFSK, 10129 1 ISKIP,IFOUND,IERROR) 10130 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10131 ENDIF 10132C 10133C ***************************** 10134C ** TREAT THE STATUS CASE ** 10135C ***************************** 10136C 10137CCCCC NOVEMBER 1997. GUI STATUS (DON'T STORE IN SAVED COMMAND 10138CCCCC LIST) 10139CCCCC SEPTEMBER 2010. MAKE LS A SYNONYM FOR STATUS 10140C 10141 IFEESV=IFEEDB 10142 IF(ICOM.EQ.'GUI ' .AND. 10143 1 (IHARG(1).EQ.'STAT' .OR. IHARG(1).EQ.'LS '))THEN 10144 IF(NUMARG.GE.1.AND. 10145 1 (IHARG(1).EQ.'STAT' .OR. IHARG(1).EQ.'LS '))THEN 10146 ISHIFT=1 10147 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 10148 1 IBUGA2,IERROR) 10149 ICOM='STAT' 10150 ICOM2='US ' 10151 IFEEDB=IGUIFB 10152 ENDIF 10153 ENDIF 10154 IF(ICOM.EQ.'STAT' .OR. ICOM.EQ.'LS ')THEN 10155 CALL DPSTAT(ISUBRO,IFOUND,IERROR) 10156 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10157 ENDIF 10158C 10159 IFEEDB=IFEESV 10160C 10161C **************************** 10162C ** TREAT THE TIME CASE ** 10163C ** TREAT THE CLOCK CASE ** 10164C **************************** 10165C 10166 IF(ICOM.EQ.'TIME' .OR. ICOM.EQ.'CLOC' .OR. 10167 1 ICOM.EQ.'DATE')THEN 10168 CALL DPTIME(CURRTI,NCURRT,CURRDA,NCURRD, 10169 1 IBUGS2,ISUBRO,IFOUND,IERROR) 10170 IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')THEN 10171 DO5110I=1,NCURRT 10172 IC4(1:4)=' ' 10173 IC4(1:1)=CURRTI(I:I) 10174 IFUTMP(I)=IC4(1:4) 101755110 CONTINUE 10176 CALL UPDATF('CURR','TIME',IFUTMP,NCURRT,'CHAD','NO ', 10177 1 IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP, 10178 1 NUMNAM,MAXNAM,IANS,IWIDTH,ILISTL,NEWNAM,MAXNAM, 10179 1 IFUNC,NUMCHF,MAXCHF,IBUGS2,ILOCN,IFOUNN,IERRON) 10180 DO5120I=1,NCURRD 10181 IC4(1:4)=' ' 10182 IC4(1:1)=CURRDA(I:I) 10183 IFUTMP(I)=IC4(1:4) 101845120 CONTINUE 10185 CALL UPDATF('CURR','DATE',IFUTMP,NCURRD,'CHAD','NO ', 10186 1 IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP, 10187 1 NUMNAM,MAXNAM,IANS,IWIDTH,ILISTL,NEWNAM,MAXNAM, 10188 1 IFUNC,NUMCHF,MAXCHF,IBUGS2,ILOCN,IFOUNN,IERRON) 10189 ENDIF 10190 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10191 ENDIF 10192C 10193C ******************************** 10194C ** TREAT THE CPU TIME CASE ** 10195C ******************************** 10196C 10197 IF(ICOM.EQ.'CPU ')THEN 10198 CALL DPCPU(ICOM,IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 10199 1 ATIME, 10200 1 IBUGS2,ISUBRO,IFOUND,IERROR) 10201 IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')THEN 10202 IH='CPUT' 10203 IH2='IME ' 10204 VALUE0=ATIME 10205 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 10206 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 10207 1 IANS,IWIDTH,IBUGS2,IERROR) 10208 ENDIF 10209 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10210 ENDIF 10211C 10212C ********************************** 10213C ** TREAT THE PROCESS-ID CASE ** 10214C ********************************** 10215C 10216 IFOUND='NO' 10217 IF(ICOM.EQ.'PID ' .OR. 10218 1 (ICOM.EQ.'PROC' .AND. IHARG(1).EQ.'ID'))THEN 10219 CALL DPPID(IPID,IBUGS2,ISUBRO,IFOUND,IERROR) 10220 10221 IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO'.AND.IPID.GT.0)THEN 10222 IH='PID ' 10223 IH2=' ' 10224 VALUE0=REAL(IPID) 10225 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 10226 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 10227 1 IANS,IWIDTH,IBUGS2,IERROR) 10228 ENDIF 10229 ENDIF 10230 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10231C 10232C ******************************** 10233C ** TREAT THE PWD CASE ** 10234C ******************************** 10235C 10236 IF(ICOM.EQ.'PWD ' .OR. 10237 1 (ICOM.EQ.'GETC' .AND. ICOM2.EQ.'WD ') .OR. 10238 1 (ICOM.EQ.'CURR' .AND. IHARG(1).EQ.'DIRE'))THEN 10239 MAXTMP=255 10240 CALL DPPWD(CURDIR,MAXTMP,ICNT,IBUGS2,ISUBRO,IFOUND,IERROR) 10241 IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')THEN 10242 IH='CURD' 10243 IH2='IR ' 10244 NEWNAM='YES' 10245 DO5130I=1,NUMNAM 10246 I2=I 10247 IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I))THEN 10248 IF(IUSE(I2).EQ.'F')THEN 10249 NEWNAM='NO' 10250 GOTO5139 10251 ELSE 10252 NEWNAM='NULL' 10253 ENDIF 10254 ENDIF 10255 5130 CONTINUE 10256 5139 CONTINUE 10257C 10258 IF(NEWNAM.NE.'NULL')THEN 10259 ILISTL=NUMNAM+1 10260 DO5140I=1,ICNT 10261 IFUNC9(I)=' ' 10262 IFUNC9(I)(1:1)=CURDIR(I:I) 10263 5140 CONTINUE 10264 CALL DPINFU(IFUNC9,ICNT,IHNAME,IHNAM2,IUSE,IN, 10265 1 IVSTAR,IVSTOP, 10266 1 NUMNAM,IANS,IWIDTH,IH,IH2,ILISTL, 10267 1 NEWNAM,MAXNAM, 10268 1 IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR) 10269 ENDIF 10270 ENDIF 10271 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10272 ENDIF 10273C 10274C *************************************** 10275C ** TREAT THE CLIPBOARD CLEAR CASE ** 10276C *************************************** 10277C 10278 IFOUND='NO' 10279 IF((ICOM.EQ.'CLIP' .AND. IHARG(1).EQ.'CLEA') .OR. 10280 1 (ICOM.EQ.'CLEA' .AND. IHARG(1).EQ.'CLIP'))THEN 10281 CALL DPCLI3(IBUGS2,ISUBRO,IERROR) 10282 IFOUND='YES' 10283 GOTO9000 10284 ENDIF 10285C 10286C *************************************** 10287C ** TREAT THE CLIPBOARD LOOP CASE ** 10288C *************************************** 10289C 10290 IFOUND='NO' 10291 IF((ICOM.EQ.'CLIP' .AND. IHARG(1).EQ.'LOOP') .OR. 10292 1 (ICOM.EQ.'LOOP' .AND. IHARG(1).EQ.'CLIP'))THEN 10293 IF(NUMARG.EQ.1)THEN 10294 ICLILO='ON' 10295 ICLIL2=0 10296 IFOUND='YES' 10297 GOTO9000 10298 ENDIF 10299 ENDIF 10300C 10301C *************************************** 10302C ** TREAT THE CLIPBOARD LOOP END CASE** 10303C *************************************** 10304C 10305 IFOUND='NO' 10306 IF((ICOM.EQ.'CLIP' .AND. IHARG(1).EQ.'LOOP' .AND. 10307 1 IHARG(2).EQ.'END') .OR. 10308 1 (ICOM.EQ.'CLIP' .AND. IHARG(1).EQ.'END ' .AND. 10309 1 IHARG(2).EQ.'LOOP') .OR. 10310 1 (ICOM.EQ.'CLIP' .AND. IHARG(1).EQ.'END ' .AND. 10311 1 IHARG(2).EQ.'OF ' .AND. IHARG(3).EQ.'LOOP'))THEN 10312 ICLILO='OFF' 10313 ICLIL2=0 10314 ICLIFL='OFF' 10315 ICLILN=0 10316 IFOUND='YES' 10317 CALL DPCLI3(IBUGS2,ISUBRO,IERROR) 10318 IF(IFEEDB.EQ.'ON')THEN 10319 WRITE(ICOUT,5150) 10320 CALL DPWRST('XXX','BUG ') 10321 ENDIF 10322 GOTO9000 10323 ENDIF 10324C 10325C *************************************** 10326C ** TREAT THE CLIPBOARD PAUSE CASE ** 10327C *************************************** 10328C 10329 IFOUND='NO' 10330 IF((ICOM.EQ.'CLIP' .AND. IHARG(1).EQ.'PAUS') .OR. 10331 1 (ICOM.EQ.'PAUS' .AND. IHARG(1).EQ.'CLIP'))THEN 10332 ICLIFL='PAUS' 10333 IF(ICLILO.EQ.'ON')ICLILO='PAUS' 10334 IFOUND='YES' 10335 IF(IFEEDB.EQ.'ON')THEN 10336 WRITE(ICOUT,5150) 10337 5150 FORMAT('COMMANDS WILL NOW BE ENTERED FROM KEYBOARD') 10338 CALL DPWRST('XXX','BUG ') 10339 ENDIF 10340 GOTO9000 10341 ENDIF 10342C 10343C *************************************** 10344C ** TREAT THE CLIPBOARD RESUME CASE ** 10345C *************************************** 10346C 10347 IFOUND='NO' 10348 IF((ICOM.EQ.'CLIP' .AND. IHARG(1).EQ.'RESU') .OR. 10349 1 (ICOM.EQ.'RESU' .AND. IHARG(1).EQ.'CLIP'))THEN 10350 ICLIFL='ON' 10351 IF(ICLILO.EQ.'PAUS')ICLILO='ON' 10352 IFOUND='YES' 10353 GOTO9000 10354 ENDIF 10355C 10356C *************************************** 10357C ** TREAT THE CLIPBOARD RUN CASE ** 10358C *************************************** 10359C 10360 IFOUND='NO' 10361 IF((ICOM.EQ.'CLIP' .AND. IHARG(1).EQ.'RUN ') .OR. 10362 1 (ICOM.EQ.'RUN ' .AND. IHARG(1).EQ.'CLIP') .OR. 10363 1 (ICOM.EQ.'CALL' .AND. IHARG(1).EQ.'CLIP') .OR. 10364 1 ICOM.EQ.'CB' .OR. 10365 1 (NUMARG.EQ.0 .AND. ICOM.EQ.'CLIP'))THEN 10366 ICLIFL='ON' 10367 ICLILN=0 10368 IFOUND='YES' 10369 GOTO9000 10370 ENDIF 10371C 10372C *************************************** 10373C ** TREAT THE TRIPLE PRECISION CASE ** 10374C *************************************** 10375C 10376 IF(ICOM.EQ.'TRIP')THEN 10377 CALL DPTRIP(IHARG,NUMARG,IDEFPR,IHMXPR, 10378 1 IPREC,IFOUND,IERROR) 10379 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10380 ENDIF 10381C 10382C ****************************** 10383C ** TREAT THE WEIGHTS CASE ** 10384C ****************************** 10385C 10386 IF(ICOM.EQ.'WEIG')THEN 10387 CALL DPWEIG(IHARG,IHARG2,NUMARG,IDEFW1,IDEFW2, 10388 1 IWEIG1,IWEIG2,IWEIGH,IFOUND,IERROR) 10389 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10390 ENDIF 10391C 10392C ************************************************ 10393C ** TREAT THE ORTHOGONAL DISTANCE ERROR CASE ** 10394C ************************************************ 10395C 10396 IF(ICOM.EQ.'ORTH')THEN 10397 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'DIST'.AND.IHARG(2).EQ.'ERRO') 10398 1 THEN 10399 ISHIFT=2 10400 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 10401 1 IBUGA2,IERROR) 10402 CALL DPORER(IHARG,IHARG2,NUMARG, 10403 1 IODRE1,IODRE2,IFOUND,IERROR) 10404 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10405 ENDIF 10406 ENDIF 10407C 10408C ************************************************ 10409C ** TREAT THE ORTHOGONAL DISTANCE DELTA CASE ** 10410C ************************************************ 10411C 10412 IF(ICOM.EQ.'ORTH')THEN 10413 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'DIST'.AND.IHARG(2).EQ.'DELT') 10414 1 THEN 10415 ICASOD='DELT' 10416 ISHIFT=2 10417 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 10418 1 IBUGA2,IERROR) 10419 CALL DPORDE(IHARG,IHARG2,NUMARG, 10420 1 IODRD1,IODRD2,IODRD3,IODRD4, 10421 1 IWEIN1,IWEIN2, 10422 1 ICASOD,IFOUND,IERROR) 10423 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10424 ENDIF 10425 ENDIF 10426C 10427 IF(ICOM.EQ.'ORTH')THEN 10428 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'DIST'.AND.IHARG(2).EQ.'Y ') 10429 1 THEN 10430 ICASOD='Y ' 10431 ISHIFT=2 10432 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 10433 1 IBUGA2,IERROR) 10434 CALL DPORDE(IHARG,IHARG2,NUMARG, 10435 1 IODRD1,IODRD2,IODRD3,IODRD4, 10436 1 IWEIN1,IWEIN2, 10437 1 ICASOD,IFOUND,IERROR) 10438 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10439 ENDIF 10440 ENDIF 10441C 10442C ************************************** 10443C ** TREAT THE CLASS ... LOWER CASE ** 10444C ** TREAT THE CLASS ... UPPER CASE ** 10445C ** TREAT THE CLASS ... WIDTH CASE ** 10446C ************************************** 10447C 10448 IF(ICOM.EQ.'CLAS')THEN 10449 CALL DPCLLO(IHARG,IARGT,ARG,NUMARG, 10450 1 CLLIMI,IFOUND,IERROR) 10451 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10452C 10453 CALL DPCLUP(IHARG,IARGT,ARG,NUMARG, 10454 1 CLLIMI,IFOUND,IERROR) 10455 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10456C 10457 CALL DPCLWI(IHARG,IARGT,ARG,NUMARG, 10458 1 CLWIDT,IFOUND,IERROR) 10459 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10460 ENDIF 10461C 10462C **************************** 10463C ** TREAT THE WRITE CASE ** 10464C ** TREAT THE PRINT CASE ** 10465C **************************** 10466C 10467CCCCC NOVEMBER 1997. GUI PRINT/WRITE (DON'T STORE IN SAVED COMMAND 10468CCCCC LIST) 10469 IFEESV=IFEEDB 10470 IF(ICOM.EQ.'GUI ')THEN 10471 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PRIN'.OR. 10472 1 IHARG(1).EQ.'WRIT')THEN 10473 ISHIFT=1 10474 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 10475 1 IBUGA2,IERROR) 10476 ICOM='WRIT' 10477 ICOM2='E ' 10478 IFEEDB=IGUIFB 10479 ENDIF 10480 ENDIF 10481 IF(ICOM.EQ.'WRIT')GOTO5800 10482 IF(ICOM.EQ.'PRIN'.AND.ICOM2.EQ.'T ')GOTO5800 10483 IF(ICOM.EQ.'PRIN'.AND.ICOM2.EQ.'T1 ')GOTO5800 10484 IF(ICOM.EQ.'PRIN'.AND.ICOM2.EQ.'T2 ')GOTO5800 10485 IF(ICOM.EQ.'PRIN'.AND.ICOM2.EQ.'T3 ')GOTO5800 10486 IF(ICOM.EQ.'HEAD'.AND.ICOM2.EQ.' ')GOTO5800 10487 IF(ICOM.EQ.'TAIL'.AND.ICOM2.EQ.' '.AND. 10488 1 IHARG(1).NE.'AREA')GOTO5800 10489 GOTO5899 10490C 10491 5800 CONTINUE 10492CCCCC IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DECI'.AND. 10493CCCCC1IHARG2(1).EQ.'MALS')GOTO5899 10494CCCCC IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DECI'.AND. 10495CCCCC1IHARG2(1).EQ.'MAL')GOTO5899 10496CCCCC IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FORM'.AND. 10497CCCCC1IHARG2(1).EQ.'AT')GOTO5899 10498CCCCC IF(NUMARG.GE.1.AND.IHARG(1).EQ.'REWI'.AND. 10499CCCCC1IHARG2(1).EQ.'ND')GOTO5899 10500C 10501 CALL DPWRIT(IMACRO,IMACNU,IMACCS, 10502 1 IFORSW,ICWRIF,NCWRIF, 10503 1 IWRIRW, 10504 1 IFORWI,IFORWR,MAXNWI, 10505 1 IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR) 10506C 10507 IFEEDB=IFEESV 10508 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10509C 10510 5899 CONTINUE 10511C 10512C ****************************** 10513C ** TREAT THE COMMENT CASE ** 10514C ** TREAT THE . CASE ** 10515C ****************************** 10516C 10517C MAY, 1990. SOFT-CODE THE COMMENT CHARACTER. ALSO, A COMMENT 10518C CHARACTER AND A COMMENT CHECK COMMAND WERE ADDED. ALWAYS TREAT 10519C PERIOD AS COMMENT ON COMMAND LINE. 10520C 10521 IF(ICOM.EQ.'.' .OR. ICOM.EQ.ICOMCH .OR. ICOM.EQ.'COMM')THEN 10522 IF(ICOM.EQ.'COMM'.AND. IHARG(1).EQ.'CHAR')GOTO5999 10523 IF(ICOM.EQ.'COMM'.AND. IHARG(1).EQ.'CHEC')GOTO5999 10524 IF(ICOM.EQ.'COMM'.AND. IHARG(1).EQ.'COEF')GOTO5999 10525 IF(ICOM.EQ.'COMM'.AND. IHARG(2).EQ.'COEF')GOTO5999 10526 IF(ICOM.EQ.'COMM'.AND. IHARG(1).EQ.'WEIB' .AND. 10527 1 IHARG(2).EQ.'SHAP')GOTO5999 10528 CALL DPDOT(IFOUND,IERROR) 10529 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10530 ENDIF 10531C 10532 5999 CONTINUE 10533C 10534C ******************************* 10535C ** TREAT THE FEEDBACK CASE ** 10536C ******************************* 10537C 10538 IF(ICOM.EQ.'FEED')THEN 10539 CALL DPFEED(IHARG,NUMARG, 10540 1 IFEED2,IFOUND,IERROR) 10541 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10542 ENDIF 10543C 10544C *********************************** 10545C ** TREAT THE FILTER WIDTH CASE ** 10546C *********************************** 10547C 10548 IF(ICOM.EQ.'FILT')THEN 10549 CALL DPFIWI(IHARG,IARGT,ARG,NUMARG,DEFFW, 10550 1 FILWID,IFOUND,IERROR) 10551 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10552 ENDIF 10553C 10554C ************************************** 10555C ** TREAT THE DEFAULT COMMAND CASE ** 10556C ************************************** 10557C 10558 IF(ICOM.EQ.'DEFA')THEN 10559 CALL DPDECO(IANS,IWIDTH,IHARG,NUMARG, 10560 1 IDEFCM,IWIDDC,IDEFC,IBUGS2,IFOUND,IERROR) 10561 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10562 ENDIF 10563C 10564C *************************** 10565C ** TREAT THE BUGS CASE ** 10566C *************************** 10567C 10568 IF(ICOM.EQ.'BUGS' .OR. ICOM.EQ.'BUG ')THEN 10569 CALL DPBUGS(IBUGS2,ISUBRO,IFOUND,IERROR) 10570 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10571 ENDIF 10572C 10573C *************************** 10574C ** TREAT THE MAIL CASE ** 10575C *************************** 10576C 10577CCCCC IF(ICOM.EQ.'MAIL')GOTO6700 10578CCCCC GOTO6799 10579C 10580C6700 CONTINUE 10581CCCCC CALL DPMAIL(IANSLC,IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR) 10582CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10583C 10584C6799 CONTINUE 10585C 10586C *************************** 10587C ** TREAT THE NEWS CASE ** 10588C *************************** 10589C 10590 IF(ICOM.EQ.'NEWS')THEN 10591 CALL DPNEWS(IBUGS2,ISUBRO,IFOUND,IERROR) 10592 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10593 ENDIF 10594C 10595C **************************** 10596C ** TREAT THE QUERY CASE ** 10597C **************************** 10598C 10599CCCCC IF(ICOM.EQ.'QUER')GOTO6900 10600CCCCC IF(ICOM.EQ.'QUES')GOTO6900 10601CCCCC IF(ICOM.EQ.'MESS')GOTO6900 10602CCCCC GOTO6999 10603C 10604C6900 CONTINUE 10605CCCCC CALL DPQUER(IANSLC,IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR) 10606CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10607C 10608C6999 CONTINUE 10609C 10610C **************************** 10611C ** TREAT THE SET CASE ** 10612C **************************** 10613C 10614 IF(ICOM.EQ.'SET ')GOTO7110 10615C 10616CCCCC IF(ICOM.EQ.'READ')GOTO7105 10617CCCCC IF(ICOM.EQ.'WRIT')GOTO7105 10618CCCCC IF(ICOM.EQ.'PRIN'.AND.ICOM2.EQ.'T ')GOTO7105 10619CCCCC GOTO7199 10620C 10621C7105 CONTINUE 10622CCCCC IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DECI'.AND. 10623CCCCC1IHARG2(1).EQ.'MALS')GOTO7110 10624CCCCC IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DECI'.AND. 10625CCCCC1IHARG2(1).EQ.'MAL')GOTO7110 10626CCCCC IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FORM'.AND. 10627CCCCC1IHARG2(1).EQ.'AT')GOTO7110 10628CCCCC IF(NUMARG.GE.1.AND.IHARG(1).EQ.'REWI'.AND. 10629CCCCC1IHARG2(1).EQ.'ND')GOTO7110 10630 GOTO7199 10631C 10632 7110 CONTINUE 10633 CALL DPSET(ILISMX,IREPCH,IOSW, 10634 1IPPDE1,IPPDE2, 10635 1IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO, 10636 1IBUGEX,IBUGE2,IBUGHE,IBUGH2,IBUGLO, 10637CCCCC AUGUST 1995. ADD IFTORD 10638CCCCC1IHELMX,IFTEXP, 10639 1IHELMX,IFTEXP,IFTORD, 10640 1IFORSW,ICREAF,NCREAF,ICWRIF,NCWRIF, 10641 1IREARW,IWRIRW, 10642CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1992 10643 1NPLOTP, 10644CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1993 10645 1IPRITY, 10646CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1995 10647 1IUNFOF,IUNFNR,IUNFMC, 10648CCCCC FOLLOWING LINE ADD MARCH 1996 10649CCCCC1IRHSTG, 10650 1IFOUND,IERROR) 10651 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10652C 10653 7199 CONTINUE 10654C 10655C ******************************** 10656C ** TREAT THE IMPLEMENT CASE ** 10657C ******************************** 10658C 10659 IF(ICOM.EQ.'IMPL')THEN 10660 CALL DPIMPL(IHARG,IARGT,IARG,NUMARG, 10661 1 IX2TSW,IY2TSW,IX2ZSW,IY2ZSW,NCY2LA, 10662 1 ISQUAR, 10663 1 PXMIN,PYMIN,PXMAX,PYMAX, 10664 1 IBUGS2,IFOUND,IERROR) 10665 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10666 ENDIF 10667C 10668C ***************************** 10669C ** TREAT THE REWIND CASE ** 10670C ***************************** 10671C 10672CCCCC IF(ICOM.EQ.'REWI')GOTO7300 10673CCCCC GOTO7399 10674CCCCC 10675C7300 CONTINUE 10676CCCCC CALL DPREWI(IBUGS2,IBUGQ,IFOUND,IERROR) 10677CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10678CCCCC 10679C7399 CONTINUE 10680C 10681C ****************************** 10682C ** TREAT THE ENDFILE CASE ** 10683C ****************************** 10684C 10685CCCCC IF(ICOM.EQ.'ENDF')GOTO7400 10686CCCCC GOTO7499 10687CCCCC 10688C7400 CONTINUE 10689CCCCC CALL DPENDF(IBUGS2,IBUGQ,IFOUND,IERROR) 10690CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10691CCCCC 10692C7499 CONTINUE 10693C 10694C ***************************** 10695C ** TREAT THE RELEASE CASE ** 10696C ***************************** 10697C 10698CCCCC IF(ICOM.EQ.'RELE')GOTO7500 10699CCCCC IF(ICOM.EQ.'CLOS')GOTO7500 10700CCCCC IF(ICOM.EQ.'FREE')GOTO7500 10701CCCCC GOTO7599 10702CCCCC 10703C7500 CONTINUE 10704CCCCC CALL DPREWI(IBUGS2,IBUGQ,IFOUND,IERROR) 10705CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10706CCCCC 10707C7599 CONTINUE 10708C 10709C *************************** 10710C ** TREAT THE SEED CASE ** 10711C *************************** 10712C 10713 IF(ICOM.EQ.'SEED')THEN 10714 CALL DPSEED(IHARG,IARGT,IARG,NUMARG,IDEFSE, 10715 1 ISEED,IFOUND,IERROR) 10716 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10717 ENDIF 10718C 10719C ************************************** 10720C ** TREAT THE THE PROPORTION LIMITS CASE ** 10721C ** = THE ANOP LIMITS CASE ** 10722C ************************************** 10723C 10724 IF(ICOM.EQ.'PROP'.AND.NUMARG.GE.1.AND. 10725 1IHARG(1).EQ.'LIMI'.AND.IHARG2(1).EQ.'TS ')GOTO8100 10726 IF(ICOM.EQ.'PROP'.AND.NUMARG.GE.1.AND. 10727 1IHARG(1).EQ.'REGI'.AND.IHARG2(1).EQ.'ON ')GOTO8100 10728 IF(ICOM.EQ.'ANOP'.AND.NUMARG.GE.1.AND. 10729 1IHARG(1).EQ.'LIMI'.AND.IHARG2(1).EQ.'TS ')GOTO8100 10730 IF(ICOM.EQ.'ANOP'.AND.NUMARG.GE.1.AND. 10731 1IHARG(1).EQ.'REGI'.AND.IHARG2(1).EQ.'ON ')GOTO8100 10732 GOTO8199 10733C 10734 8100 CONTINUE 10735 CALL DPANOL(IHARG,IARGT,ARG,NUMARG,DEFAL1,DEFAL2, 10736 1ANOPL1,ANOPL2,IFOUND,IERROR) 10737 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10738C 10739 8199 CONTINUE 10740C 10741C **************************** 10742C ** TREAT THE FENCE CASE ** 10743C **************************** 10744C 10745 IF(ICOM.EQ.'FENC')THEN 10746 CALL DPFENC(IHARG,NUMARG, 10747 1 IFENSW,IFOUND,IERROR) 10748 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10749 ENDIF 10750C 10751C **************************** 10752C ** TREAT THE PAUSE CASE ** 10753C **************************** 10754C 10755 IF(ICOM.EQ.'PAUS' .AND. NUMARG.EQ.0)THEN 10756 CALL DPPAUS(IBUGS2,IFOUND,IERROR) 10757 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10758 ENDIF 10759C 10760C **************************** 10761C ** TREAT THE SLEEP CASE ** 10762C **************************** 10763C 10764 IF(ICOM.EQ.'SLEE')THEN 10765 CALL DPSLEE(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 10766 1 IBUGD2,ISUBRO,IFOUND,IERROR) 10767 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10768 ENDIF 10769C 10770C ****************************** 10771C ** TREAT THE APPEND CASE ** 10772C ****************************** 10773C 10774 IF(ICOM.EQ.'APPE' .OR. ICOM.EQ.'AUGM')THEN 10775 CALL DPAPPE(IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR) 10776 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10777 ENDIF 10778C 10779C ****************************** 10780C ** TREAT THE EXTEND CASE ** 10781C ****************************** 10782C 10783 IF(ICOM.EQ.'EXTE')THEN 10784 CALL DPEXTE(IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR) 10785 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10786 ENDIF 10787C 10788C ************************************** 10789C ** TREAT THE SUGGESTION CASE ** 10790C ** TREAT THE RECOMMENDATION CASE ** 10791C ** TREAT THE PROGRAM CASE ** 10792C ** TREAT THE CODE CASE ** 10793C ** TREAT THE EXPERT CASE ** 10794C ************************************** 10795C 10796CCCCC IF(ICOM.EQ.'SUGG')GOTO8600 10797CCCCC IF(ICOM.EQ.'RECO')GOTO8600 10798CCCCC IF(ICOM.EQ.'PROG')GOTO8600 10799CCCCC IF(ICOM.EQ.'CODE')GOTO8600 10800CCCCC IF(ICOM.EQ.'EXPE')GOTO8600 10801CCCCC GOTO8699 10802CCCCC 10803C8600 CONTINUE 10804CCCCC CALL DPSUPR(IHARG,IHARG2,NUMARG, 10805CCCCC1ITOPIC, 10806CCCCC1IANS,IWIDTH,IBUGS2,IFOUND,IERROR) 10807CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10808CCCCC 10809C8699 CONTINUE 10810CCCCC 10811CCCCC ************************************** 10812CCCCC ** TREAT THE GO CASE ** 10813CCCCC ************************************** 10814CCCCC 10815CCCCC IF(ICOM.EQ.'GO')GOTO8700 10816CCCCC GOTO8799 10817CCCCC 10818C8700 CONTINUE 10819CCCCC CALL DPWRPF(IPRONU,IPROFS,IPROST, 10820CCCCC1ITOPIC, 10821CCCCC1IHARG,IHARG2,NUMARG, 10822CCCCC1IANS,IWIDTH,IBUGS2,IFOUND,IERROR) 10823CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10824CCCCC 10825C8799 CONTINUE 10826CCCCC 10827CCCCC ************************************** 10828CCCCC ** TREAT THE CONCLUSIONS CASE ** 10829CCCCC ************************************** 10830CCCCC 10831CCCCC IF(ICOM.EQ.'CONC')GOTO8800 10832CCCCC GOTO8899 10833CCCCC 10834C8800 CONTINUE 10835CCCCC CALL DPLICF(ICONNU,ICONFS,ICONST, 10836CCCCC1IANS,IWIDTH,IBUGS2,IFOUND,IERROR) 10837CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10838C8899 CONTINUE 10839CCCCC 10840CCCCC 10841C ************************************** 10842C ** TREAT THE ROOT ACCURACY CASE ** 10843C ************************************** 10844C 10845 IF(ICOM.EQ.'ROOT'.AND.NUMARG.GE.1.AND. 10846 1IHARG(1).EQ.'ACCU')THEN 10847 CALL DPROAC(IHARG,IARGT,ARG,NUMARG,DEFRAC, 10848 1 ROOTAC,IFOUND,IERROR) 10849 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10850 ENDIF 10851C 10852CCCCC *************************** 10853CCCCC ** TREAT THE MENU CASE ** 10854CCCCC *************************** 10855CCCCC 10856CCCCC IF(ICOM.EQ.'MENU')GOTO9100 10857CCCCC GOTO9199 10858CCCCC 10859C9100 CONTINUE 10860CCCCC CALL DPMENU(IMENNU,IMENFS,IMENST, 10861CCCCC1IHARG,NUMARG,IANS,IWIDTH,IBUGS2,IFOUND,IERROR) 10862CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10863CCCCC 10864C9199 CONTINUE 10865CCCCC 10866C ***************************** 10867C ** TREAT THE PROMPT CASE ** 10868C ***************************** 10869C 10870 IF(ICOM.EQ.'PROM')THEN 10871 CALL DPPROM(IHARG,NUMARG,IPROSW,IFOUND,IERROR) 10872 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10873 ENDIF 10874C 10875C ************************************** 10876C ** TREAT THE LIST (COMMANDS) CASE ** 10877C ** (SAME AS THE RECALL CASE) ** 10878C ************************************** 10879C 10880CCCCC THE FOLLOWING PARAGRAPH WAS REWRITTEN SEPTEMBER 1993 10881C 10882 IF(NUMARG.LE.0)THEN 10883 IF(ICOM.EQ.'LIST' .OR. ICOM.EQ.'TYPE' .OR. 10884 1 ICOM.EQ.'L' .OR. ICOM.EQ.'RECA' .OR. 10885 1 ICOM.EQ.'V' .OR. ICOM.EQ.'PREV' .OR. 10886 1 (ICOM.EQ.'VIEW' .AND. IHARG(1).NE.'PLOT'))THEN 10887 CALL DPLICO(IHARG,NUMARG,IANSSV,IREPMX,ILISMX,IPOINT, 10888 1 IHELMX, 10889 1 ICPREH,NCPREH,ICPOSH,NCPOSH, 10890 1 IBUGS2,ISUBRO,IFOUND,IERROR) 10891 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10892 ENDIF 10893 ENDIF 10894C 10895C **************************** 10896C ** TREAT THE LIST CASE ** 10897C **************************** 10898C 10899CCCCC APRIL 1997: CHECK FOR CONFLICT WITH LIST GRAPH, LIST PLOT, 10900CCCCC VIEW PLOTS, AND VIEW GRAPHS. 10901C 10902 IF(ICOM.EQ.'VIEW'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT'.AND. 10903 1IHARG2(1).EQ.' ')GOTO9499 10904 IF(ICOM.EQ.'VIEW'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT'.AND. 10905 1IHARG2(1).EQ.'S ')GOTO9499 10906 IF(ICOM.EQ.'VIEW'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'GRAP'.AND. 10907 1IHARG2(1).EQ.'H ')GOTO9499 10908 IF(ICOM.EQ.'VIEW'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'GRAP'.AND. 10909 1IHARG2(1).EQ.'HS ')GOTO9499 10910 IF(ICOM.EQ.'LIST'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT'.AND. 10911 1IHARG2(1).EQ.' ')GOTO9499 10912 IF(ICOM.EQ.'LIST'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT'.AND. 10913 1IHARG2(1).EQ.'S ')GOTO9499 10914 IF(ICOM.EQ.'LIST'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'GRAP'.AND. 10915 1IHARG2(1).EQ.'H ')GOTO9499 10916 IF(ICOM.EQ.'LIST'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'GRAP'.AND. 10917 1IHARG2(1).EQ.'HS ')GOTO9499 10918C 10919 IF((ICOM.EQ.'LIST' .OR. ICOM.EQ.'L ' .OR. ICOM.EQ.'VIEW' .OR. 10920 1 ICOM.EQ.'PREV' .OR. ICOM.EQ.'NLIS' .OR. ICOM.EQ.'NTYP' .OR. 10921 1 ICOM.EQ.'NVIE' .OR. ICOM.EQ.'NPRE') .AND. 10922 1 IHARG(1).NE.'= ')THEN 10923CCCCC 2 LINES OF ARGS (IHELMX THROUGH NCPOSH) WERE ADDED JULY 1989 10924CCCCC THE FOLLOWING LINE WAS CHANGED NOVEMBER 1989 10925 CALL DPLIST(ICOM,IANSLC,IWIDTH,IHARG,IHARG2,IARGT, 10926 1 IARG,ARG,NUMARG, 10927 1 ICOM3,ICOM4,ICOM5,NUMCOM,NCOM5, 10928CCCCC1 IHELMX, 10929 1 ILISMX, 10930 1 ICPREH,NCPREH,ICPOSH,NCPOSH, 10931 1 ILOOST,ILOOLI,NUMLIL,NUMLOS, 10932 1 IANSLO,IWIDLL, 10933 1 IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR) 10934 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10935 ENDIF 10936C 10937 9499 CONTINUE 10938C 10939CCCCC FOLLOWING SECTION ADDED APRIL 1997. 10940C ********************************** 10941C ** TREAT THE SAVE PLOT CASE ** 10942C ********************************** 10943C 10944 IF(NUMARG.GE.1.AND.ICOM.EQ.'SAVE'.AND. 10945 1IHARG(1).EQ.'PLOT'.AND.IHARG2(1).EQ.' ')GOTO9500 10946 IF(NUMARG.GE.1.AND.ICOM.EQ.'SAVE'.AND. 10947 1IHARG(1).EQ.'PLOT'.AND.IHARG2(1).EQ.'S ')GOTO9500 10948 IF(NUMARG.GE.1.AND.ICOM.EQ.'SAVE'.AND. 10949 1IHARG(1).EQ.'GRAP'.AND.IHARG2(1).EQ.'H ')GOTO9500 10950 IF(NUMARG.GE.1.AND.ICOM.EQ.'SAVE'.AND. 10951 1IHARG(1).EQ.'GRAP'.AND.IHARG2(1).EQ.'HS ')GOTO9500 10952 IF(ICOM.EQ.'SG ')GOTO9500 10953 IF(ICOM.EQ.'SP ')GOTO9500 10954 GOTO9509 10955C 10956 9500 CONTINUE 10957 CALL DPSAPL(IANSLC,IWIDTH,IHARG,NUMARG, 10958CCCCC1 IANSSV,IREPMX,IPOINT, 10959 1 IBUGS2,ISUBRO,IFOUND,IERROR) 10960 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10961 GOTO9509 10962C 10963C 10964C ********************************** 10965C ** TREAT THE SAVE MEMORY CASE ** 10966C ********************************** 10967C 10968 9509 CONTINUE 10969 IF(NUMARG.GE.1.AND.ICOM.EQ.'SAVE'.AND. 10970 1IHARG(1).EQ.'MEMO'.AND.IHARG2(1).EQ.'RY ')GOTO9510 10971 IF(NUMARG.GE.1.AND.ICOM.EQ.'SAVE'.AND. 10972 1IHARG(1).EQ.'ALL '.AND.IHARG2(1).EQ.' ')GOTO9510 10973 GOTO9599 10974C 10975 9510 CONTINUE 10976 CALL DPSAVE(IFOUND,IERROR) 10977 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10978 GOTO9599 10979C 10980 9599 CONTINUE 10981C 10982C ************************************** 10983C ** TREAT THE GUI SAVE PLOT CONTROL ** 10984C ************************************** 10985C 10986 IFEESV=IFEEDB 10987 IF(ICOM.EQ.'GUI')THEN 10988 IFEEDB=IGUIFB 10989 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'SAVE'.AND. 10990 1 IHARG(2).EQ.'PLOT'.AND.IHARG(3).EQ.'CONT')THEN 10991 CALL DPSAPC(IBUGS2,ISUBRO,IFOUND,IERROR) 10992 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 10993 ENDIF 10994 ENDIF 10995 IFEEDB=IFEESV 10996C 10997C ************************************** 10998C ** TREAT THE SAVE (COMMANDS) CASE ** 10999C ************************************** 11000C 11001CCCCC DECEMBER 1993. CHECK FOR CONFLICT WITH S CHART COMMAND 11002C 11003 IF(ICOM.EQ.'SAVE' .OR. ICOM.EQ.'S ' .AND. 11004 1 IHARG(1).NE.'CONT' .AND. IHARG(1).NE.'CHAR' .AND. 11005 1 IHARG(1).NE.'= ')THEN 11006 CALL DPSACO(IANSLC,IWIDTH,IHARG,IARGT,IARG,NUMARG, 11007 1 IANSSV,IREPMX,IPOINT,ISACNC, 11008 1 IBUGS2,ISUBRO,IFOUND,IERROR) 11009 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11010 ENDIF 11011C 11012C **************************************** 11013C ** TREAT THE AUTOPLOT (SWITCH) CASE ** 11014C **************************************** 11015C 11016 IF(ICOM.EQ.'AUTO'.AND.ICOM2.EQ.'PLOT')THEN 11017 CALL DPAUPL(IHARG,NUMARG, 11018 1 IAUTSW,IAUTEX,IFOUND,IERROR) 11019 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11020 ENDIF 11021C 11022C ********************************** 11023C ** TREAT THE CURSOR SIZE CASE ** 11024C ********************************** 11025C 11026 IF(ICOM.EQ.'CURS'.AND.NUMARG.GE.1.AND. 11027 1IHARG(1).EQ.'SIZE')GOTO10100 11028 IF(ICOM.EQ.'CURS'.AND.NUMARG.GE.1.AND. 11029 1IHARG(1).EQ.'HEIG')GOTO10100 11030 IF(ICOM.EQ.'DIAL'.AND.NUMARG.GE.1.AND. 11031 1IHARG(1).EQ.'SIZE')GOTO10100 11032 IF(ICOM.EQ.'DIAL'.AND.NUMARG.GE.1.AND. 11033 1IHARG(1).EQ.'HEIG')GOTO10100 11034 GOTO10199 11035C 1103610100 CONTINUE 11037 CALL DPCUSZ(IHARG,IARGT,ARG,NUMARG,DEFCSZ, 11038 1ACURSZ,IFOUND,IERROR) 11039 PDIAHE=ACURSZ 11040 PDIAWI=PDIAHE/2.0 11041 IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')GOTO10110 11042 GOTO10119 11043C 1104410110 CONTINUE 11045CCCCC ICOPSW='OFF' 11046CCCCC NUMCOP=0 11047CCCCC CALL DPCLPL(ICOPSW,NUMCOP, 11048CCCCC1PGRAXF,PGRAYF, 11049CCCCC1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 11050CCCCC1PDIAHE,PDIAWI,PDIAVG,PDIAHG) 11051CCCCC CALL DPCLDE 11052C0119 CONTINUE 11053 IF(NUMDEV.LE.0)GOTO10119 11054 DO10112IDEVIC=1,NUMDEV 11055 IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO10112 11056 IMANUF=IDMANU(IDEVIC) 11057 IMODEL=IDMODE(IDEVIC) 11058 IMODE2=IDMOD2(IDEVIC) 11059 IMODE3=IDMOD3(IDEVIC) 11060 IGCONT=IDCONT(IDEVIC) 11061 IGCOLO=IDCOLO(IDEVIC) 11062 IGFONT=IDFONT(IDEVIC) 11063 NUMVPP=IDNVPP(IDEVIC) 11064 NUMHPP=IDNHPP(IDEVIC) 11065 ANUMVP=NUMVPP 11066 ANUMHP=NUMHPP 11067 IGUNIT=IDUNIT(IDEVIC) 11068 PCHSCA=PDSCAL(IDEVIC) 11069C 11070 CALL DPOPDE 11071 IBELSJ='OFF' 11072 NUMRIJ=0 11073 IERASJ='OFF' 11074 IBACCJ='JUNK' 11075 CALL DPOPPL(IGRASW,IBELSJ,NUMRIJ,IERASJ,IBACCJ) 11076 ICOPSJ='OFF' 11077 NUMCOJ=0 11078 CALL DPCLPL(ICOPSJ,NUMCOJ, 11079 1 PGRAXF,PGRAYF, 11080 1 IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 11081 1 PDIAHE,PDIAWI,PDIAVG,PDIAHG) 11082 CALL DPCLDE 1108310112 CONTINUE 1108410119 CONTINUE 11085 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11086C 11087 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11088C 1108910199 CONTINUE 11090C 11091C ************************************* 11092C ** TREAT THE CURSOR SPACING CASE ** 11093C ************************************* 11094C 11095 IF(ICOM.EQ.'CURS'.AND.NUMARG.GE.1.AND. 11096 1IHARG(1).EQ.'SPAC')GOTO10200 11097 IF(ICOM.EQ.'CURS'.AND.NUMARG.GE.1.AND. 11098 1IHARG(1).EQ.'GAP')GOTO10200 11099 IF(ICOM.EQ.'DIAL'.AND.NUMARG.GE.1.AND. 11100 1IHARG(1).EQ.'SPAC')GOTO10200 11101 IF(ICOM.EQ.'DIAL'.AND.NUMARG.GE.1.AND. 11102 1IHARG(1).EQ.'GAP')GOTO10200 11103 GOTO10299 11104C 1110510200 CONTINUE 11106 DEFCSP=0.0 11107 CALL DPCUSP(IHARG,IARGT,ARG,NUMARG,DEFCSP, 11108 1PDIAVG,IFOUND,IERROR) 11109 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11110C 1111110299 CONTINUE 11112C 11113C ***************************************** 11114C ** TREAT THE CURSOR COORDINATES CASE ** 11115C ***************************************** 11116C 11117 IF(ICOM.EQ.'CURS'.AND.NUMARG.GE.1.AND. 11118 1IHARG(1).EQ.'COOR')GOTO10300 11119 IF(ICOM.EQ.'CURS'.AND.NUMARG.GE.1.AND. 11120 1IHARG(1).EQ.'LOCA')GOTO10300 11121 IF(ICOM.EQ.'DIAL'.AND.NUMARG.GE.1.AND. 11122 1IHARG(1).EQ.'COOR')GOTO10300 11123 IF(ICOM.EQ.'DIAL'.AND.NUMARG.GE.1.AND. 11124 1IHARG(1).EQ.'LOCA')GOTO10300 11125 GOTO10399 11126C 1112710300 CONTINUE 11128 CALL DPCUCO(IHARG,IARGT,ARG,NUMARG,PDIAYC, 11129 1PDIAY2,IFOUND,IERROR) 11130 IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')GOTO10310 11131 GOTO10319 11132C 1113310310 CONTINUE 11134 IF(NUMDEV.LE.0)GOTO10319 11135 DO10312IDEVIC=1,NUMDEV 11136 IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO10312 11137 IMANUF=IDMANU(IDEVIC) 11138 IMODEL=IDMODE(IDEVIC) 11139 IMODE2=IDMOD2(IDEVIC) 11140 IMODE3=IDMOD3(IDEVIC) 11141 IGCONT=IDCONT(IDEVIC) 11142 IGCOLO=IDCOLO(IDEVIC) 11143 IGFONT=IDFONT(IDEVIC) 11144 NUMVPP=IDNVPP(IDEVIC) 11145 NUMHPP=IDNHPP(IDEVIC) 11146 ANUMVP=NUMVPP 11147 ANUMHP=NUMHPP 11148 IGUNIT=IDUNIT(IDEVIC) 11149 PCHSCA=PDSCAL(IDEVIC) 11150C 11151 CALL DPOPDE 11152 IBELSJ='OFF' 11153 NUMRIJ=0 11154 IERASJ='OFF' 11155 IBACCJ='JUNK' 11156 CALL DPOPPL(IGRASW,IBELSJ,NUMRIJ,IERASJ,IBACCJ) 11157 ICOPSJ='OFF' 11158 NUMCOJ=0 11159 CALL DPCLPL(ICOPSJ,NUMCOJ, 11160 1 PGRAXF,PGRAYF, 11161 1 IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 11162 1 PDIAHE,PDIAWI,PDIAVG,PDIAHG) 11163 CALL DPCLDE 1116410312 CONTINUE 1116510319 CONTINUE 11166 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11167C 1116810399 CONTINUE 11169C 11170C ************************************** 11171C ** TREAT THE PREPOST DEVICE CASE ** 11172C ************************************** 11173C 11174 IF(ICOM.EQ.'PREP'.AND.ICOM2.EQ.'OST')THEN 11175 CALL DPPRPO(ICOM,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 11176 1 IPPDE1,IPPDE2, 11177 1 IBUGS2,IFOUND,IERROR) 11178 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11179 ENDIF 11180C 11181C **************************** 11182C ** TREAT THE SEARCH CASE ** 11183C **************************** 11184C 11185 IF(ICOM.EQ.'SEAR' .OR. ICOM.EQ.'? ' .OR. 11186 1 ICOM.EQ.'??? ' .OR. ICOM.EQ.'GREP' .OR. 11187 1 (ICOM.EQ.'FIND' .AND. ICOM2.EQ.'STR '))THEN 11188 ISEART='1LIN' 11189 IF(ICOM2.EQ.'CHB')ISEART='BLAN' 11190 IF(ICOM2.EQ.'CHBL')ISEART='BLAN' 11191 IF(ICOM2.EQ.'CHD')ISEART='----' 11192 IF(ICOM2.EQ.'CHDA')ISEART='----' 11193 IF(ICOM.EQ.'GREP')ISEART='GREP' 11194 IF(ICOM.EQ.'FIND' .AND. ICOM2.EQ.'STR ')ISEART='FIND' 11195CCCCC THE FOLLOWING LINE WAS ADDED JANUARY 1994 11196 IF(ICOM2.EQ.'CH1 ')ISEART='FIRS' 11197 CALL DPSEAR(IANS,IANSLC,IWIDTH,ICOM,IHARG,IHARG2,NUMARG,ISEART, 11198CCCCC FEBRUARY 2003: ADD FOLLOWING LINE 11199 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 11200 1 IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR) 11201 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11202 ENDIF 11203C 11204C **************************************** 11205C ** TREAT THE LOWESS FRACTION CASE ** 11206C **************************************** 11207C 11208 IF(ICOM.EQ.'LOWE'.AND.NUMARG.GE.1.AND. 11209 1IHARG(1).EQ.'FRAC')GOTO10600 11210 IF(ICOM.EQ.'LOWE'.AND.NUMARG.GE.1.AND. 11211 1IHARG(1).EQ.'DECI')GOTO10600 11212 IF(ICOM.EQ.'LOWE'.AND.NUMARG.GE.1.AND. 11213 1IHARG(1).EQ.'PROP')GOTO10600 11214 IF(ICOM.EQ.'LOWE'.AND.NUMARG.GE.1.AND. 11215 1IHARG(1).EQ.'PERC')GOTO10600 11216 GOTO10699 11217C 1121810600 CONTINUE 11219C 11220 CALL DPLOFR(IHARG,IARGT,ARG,NUMARG, 11221 1ALOWFR,IFOUND,IERROR) 11222 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11223C 1122410699 CONTINUE 11225C 11226C ********************************************* 11227C ** TREAT THE KERNEL DENSITY WIDTH CASE ** 11228C ********************************************* 11229C 11230 IF(ICOM.EQ.'KERN')THEN 11231 IF(IHARG(1).EQ.'DENS'.AND.IHARG(2).EQ.'WIDT')THEN 11232 ISHIFT=1 11233 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 11234 1 IBUGA2,IERROR) 11235 CALL DPKDWI(IHARG,IARGT,ARG,NUMARG, 11236 1 PKDEWI,DEFKWI,IFOUND,IERROR) 11237 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11238 ELSEIF(IHARG(1).EQ.'WIDT')THEN 11239 CALL DPKDWI(IHARG,IARGT,ARG,NUMARG, 11240 1 PKDEWI,DEFKWI,IFOUND,IERROR) 11241 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11242 ENDIF 11243 IF(IHARG(1).EQ.'DENS'.AND.IHARG(2).EQ.'POIN')THEN 11244 ISHIFT=1 11245 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 11246 1 IBUGA2,IERROR) 11247 CALL DPKDNP(IHARG,IARGT,ARG,NUMARG, 11248 1 IKDENP,IDEFKN,IFOUND,IERROR) 11249 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11250 ELSEIF(IHARG(1).EQ.'POIN')THEN 11251 CALL DPKDNP(IHARG,IARGT,ARG,NUMARG, 11252 1 IKDENP,IDEFKN,IFOUND,IERROR) 11253 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11254 ELSEIF(IHARG(1).EQ.'DENS'.AND.IHARG(2).EQ.'NUMB'.AND. 11255 1 IHARG(3).EQ.'OF '.AND.IHARG(4).EQ.'POIN')THEN 11256 ISHIFT=3 11257 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 11258 1 IBUGA2,IERROR) 11259 CALL DPKDNP(IHARG,IARGT,ARG,NUMARG, 11260 1 IKDENP,IDEFKN,IFOUND,IERROR) 11261 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11262 ELSEIF(IHARG(1).EQ.'DENS'.AND.IHARG(2).EQ.'NUMB'.AND. 11263 1 IHARG(3).EQ.'POIN')THEN 11264 ISHIFT=2 11265 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 11266 1 IBUGA2,IERROR) 11267 CALL DPKDNP(IHARG,IARGT,ARG,NUMARG, 11268 1 IKDENP,IDEFKN,IFOUND,IERROR) 11269 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11270 ENDIF 11271 ENDIF 11272C 11273C ********************************************* 11274C ** TREAT THE BOOSTRAP SAMPLE SIZE CASE ** 11275C ********************************************* 11276C 11277 IF(ICOM.EQ.'BOOT'.AND.NUMARG.GE.1.AND. 11278 1IHARG(1).EQ.'SAMP')GOTO10700 11279 IF(ICOM.EQ.'BOOT'.AND.NUMARG.GE.1.AND. 11280 1IHARG(1).EQ.'SIZE')GOTO10700 11281 GOTO10799 11282C 1128310700 CONTINUE 11284C 11285 CALL DPBOSS(IHARG,IARGT,IARG,NUMARG, 11286 1IBOOSS,IDEBOO,IFOUND,IERROR) 11287 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11288C 1128910799 CONTINUE 11290C 11291C *************************** 11292C ** TREAT THE SYSTEM CASE** 11293C *************************** 11294C 11295 IF(ICOM.EQ.'SYST' .OR. ICOM.EQ.'DOS' .OR. 11296 1 ICOM.EQ.'UNIX' .OR. ICOM.EQ.'VMS' .OR. 11297 1 ICOM.EQ.'OS')THEN 11298 CALL DPSYST(IANS,IANSLC,IWIDTH, 11299 1 IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 11300 1 IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, 11301 1 IBUGS2,ISUBRO,IFOUND,IERROR) 11302 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11303 ENDIF 11304C 11305C ************************************* 11306C ** TREAT THE RSCRIPT/PYTHON CASE ** 11307C ************************************* 11308C 11309 IF(ICOM.EQ.'RSCR' .OR. ICOM.EQ.'PYTH')THEN 11310 CALL DPEXRP(IANS,IANSLC,IWIDTH,ICOM,ICOM2, 11311 1 IBUGS2,ISUBRO,IFOUND,IERROR) 11312 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11313 ENDIF 11314C 11315CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 1989 11316C ************************************* 11317C ** TREAT THE CAPTURE CASE ** 11318C ** TREAT THE END CAPTURE CASE ** 11319C ** TREAT THE END OF CAPTURE CASE ** 11320C ** TREAT THE REDIRECT CASE ** 11321C ** TREAT THE END REDIRECT CASE ** 11322C ** TREAT THE END OF REDIRECT CASE ** 11323C ************************************* 11324C 11325 IF(ICOM.EQ.'CAPT')GOTO11100 11326 IF(ICOM.EQ.'END '.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'CAPT')GOTO11100 11327 IF(ICOM.EQ.'END '.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'OF '.AND. 11328 1IHARG(2).EQ.'CAPT')GOTO11100 11329 IF(ICOM.EQ.'REDI')GOTO11100 11330 IF(ICOM.EQ.'END '.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'REDI')GOTO11100 11331 IF(ICOM.EQ.'END '.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'OF '.AND. 11332 1IHARG(2).EQ.'REDI')GOTO11100 11333 GOTO11199 11334C 1133511100 CONTINUE 11336 CALL DPCAPT(ICOM,ICOM2, 11337CCCCC JUNE 2002. ADD ICAPTY 11338CCCCC JANUARY 2006. ADD ICAPSC 11339 1ICAPSW,ICAPTY,ICAPSC,IPRDEF, 11340 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,MAXNAM,IANSLC,IANS,IWIDTH, 11341 1IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 11342 1IOFILE, 11343CCCCC JUNE 2002. ADD FOLLOWING ARGUMENTS TO ALLOW "CALL DPERAS". 11344 1IBACCO,IGRASW,IDIASW, 11345 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 11346 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 11347 1NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3, 11348 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 11349 1IDNVOF,IDNHOF,IDFONT,PDSCAL, 11350 1IREPCH,IMPSW, 11351 1IBUGS2,ISUBRO,IFOUND,IERROR) 11352 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11353C 1135411199 CONTINUE 11355C 11356CCCCC THE FOLLOWING SECTION WAS INSERTED NOVERMBER 1989 11357C ************************************************** 11358C ** TREAT THE YATES COEF/T/RESSD CUTOFF CASE ** 11359C ************************************************** 11360C 11361 IF(ICOM.EQ.'YATE')GOTO11210 11362 GOTO11299 11363C 1136411210 CONTINUE 11365 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CUTO'.AND. 11366 1IHARG2(2).EQ.'FF')GOTO11220 11367 GOTO11299 1136811220 CONTINUE 11369 CALL DPYACU(IHARG,IARGT,ARG,NUMARG, 11370 1YATCCU,YATTCU,YATRCU,IFOUND,IERROR) 11371 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11372C 1137311299 CONTINUE 11374C 11375CCCCC THE FOLLOWING SECTION WAS INSERTED NOVERMBER 1989 11376C ************************************************** 11377C ** TREAT THE YATES OUTPUT CASE ** 11378C ************************************************** 11379C 11380 IF(ICOM.EQ.'YATE')GOTO11310 11381 GOTO11399 11382C 1138311310 CONTINUE 11384 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'OUTP'.AND. 11385 1IHARG2(1).EQ.'UT')GOTO11320 11386 GOTO11399 1138711320 CONTINUE 11388 CALL DPYAOU(IHARG,NUMARG, 11389 1IYATOS,IFOUND,IERROR) 11390 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11391C 1139211399 CONTINUE 11393C 11394CCCCC THE FOLLOWING SECTION WAS INSERTED NOVERMBER 1989 11395C ************************************************** 11396C ** TREAT THE COLUMN RULER CASE ** 11397C ** TREAT THE RULER CASE ** 11398C ************************************************** 11399C 11400 IF(ICOM.EQ.'COLU'.AND.NUMARG.GE.1.AND. 11401 1IHARG(1).EQ.'RULE')GOTO11410 11402 IF(ICOM.EQ.'RULE')GOTO11410 11403 IF(ICOM.EQ.'COLU'.AND.NUMARG.GE.1.AND. 11404 1IHARG(1).EQ.'NRUL')GOTO11410 11405 IF(ICOM.EQ.'NRUL')GOTO11410 11406 GOTO11499 11407C 1140811410 CONTINUE 11409 CALL DPCORU(ICOM,IHARG,NUMARG, 11410 1IFOUND,IERROR) 11411 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11412C 1141311499 CONTINUE 11414C 11415CCCCC THE FOLLOWING SECTION WAS ADDED BY ALAN MAY 1990 11416C ****************************************** 11417C ** TREAT THE COMMENT CHARACTER CASE ** 11418C ****************************************** 11419C 11420 IF(ICOM.EQ.'COMM')THEN 11421 CALL DPCOMM(IHARG,NUMARG, 11422 1 IDEFCZ, 11423 1 ICOMCH, 11424 1 ICOMSW, 11425 1 IBUGS2,IFOUND,IERROR) 11426 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11427 ENDIF 11428C 11429CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 1992 11430C ****************************************** 11431C ** TREAT THE PRINTER TYPE/FORMAT CASE ** 11432C ****************************************** 11433C 11434 IF(ICOM.EQ.'PRIN'.AND.ICOM2.EQ.'TER ')GOTO11610 11435 IF(ICOM.EQ.'LP ' .AND. IHARG(1).NE.'LOCA')GOTO11610 11436 GOTO11699 11437C 1143811610 CONTINUE 11439CCCCC CALL DPPRFO(IHARG,NUMARG,IPRITY,IBUGS2,IERROR) 11440 CALL DPPRFO(IHARG,NUMARG,IPRITY,IFOUND,IERROR) 11441 IF(IERROR.EQ.'YES')GOTO9000 11442C 1144311699 CONTINUE 11444C 11445CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 1992 11446C ****************************************** 11447C ** TREAT THE FILE TYPE/FORMAT CASE ** 11448C ****************************************** 11449C 11450 IF(ICOM.EQ.'FILE')THEN 11451 CALL DPFIFO(IHARG,NUMARG,IOUTTY,IFOUND,IERROR) 11452 IF(IERROR.EQ.'YES')GOTO9000 11453 ENDIF 11454C 11455CCCCC THE FOLLOWING SECTION WAS ADDED BY ALAN AUGUST 1992 11456C ****************************************** 11457C ** TREAT THE VECTOR FORMAT CASE ** 11458C ****************************************** 11459C 11460 IF(ICOM.EQ.'VECT'.AND.IHARG(1).EQ.'FORM')THEN 11461 CALL DPVCFM(IHARG,NUMARG, 11462 1 IDEFVF, 11463 1 IVCFMT, 11464 1 IBUGS2,IFOUND,IERROR) 11465 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11466 ENDIF 11467C 11468CCCCC THE FOLLOWING SECTION WAS ADDED BY ALAN AUGUST 1992 11469C ****************************************** 11470C ** TREAT THE VECTOR ARROW CASE ** 11471C ****************************************** 11472C 11473 IF(ICOM.EQ.'VECT'.AND.IHARG(1).EQ.'ARRO')THEN 11474 CALL DPVCAR(IHARG,NUMARG, 11475 1 IDEFVA,IDEFVO, 11476 1 IVCARR,IVCOPN, 11477 1 IBUGS2,IFOUND,IERROR) 11478 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11479 ENDIF 11480C 11481CCCCC THE FOLLOWING SECTION WAS ADDED BY ALAN NOVEMBER 1992 11482C ****************************************** 11483C ** TREAT THE ANDREWS INCREMENT CASE ** 11484C ****************************************** 11485C 11486 IF(ICOM.EQ.'ANDR'.AND.IHARG(1).EQ.'INCR')THEN 11487 CALL DPANIN(IHARG,IARGT,ARG,NUMARG,DEFAIN, 11488 1 ANDINC,IFOUND,IERROR) 11489 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11490 ENDIF 11491C 11492CCCCC THE FOLLOWING SECTION WAS ADDED BY ALAN JULY 1993 11493C ****************************************** 11494C ** TREAT THE FRACTAL ITERATIONS CASE ** 11495C ****************************************** 11496C 11497 IF(ICOM.EQ.'FRAC'.AND.IHARG(1).EQ.'ITER')THEN 11498 CALL DPFRIT(IHARG,IARGT,ARG,NUMARG,MAXPOP, 11499 1 IFRAIT,IFOUND,IERROR) 11500 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11501 ENDIF 11502C 11503CCCCC THE FOLLOWING SECTION WAS ADDED BY ALAN JULY 1993 11504C ****************************************** 11505C ** TREAT THE FRACTAL TYPE CASE ** 11506C ****************************************** 11507C 11508 IF(ICOM.EQ.'FRAC'.AND.IHARG(1).EQ.'TYPE')THEN 11509 CALL DPFRTY(IHARG,NUMARG, 11510 1 IDEFFT, 11511 1 IFRATY, 11512 1 IBUGS2,IFOUND,IERROR) 11513 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11514 ENDIF 11515C 11516CCCCC THE FOLLOWING SECTION WAS ADDED BY ALAN JULY 1993 11517C ********************************************** 11518C ** TREAT THE PRINCIPLE COMPONENT TYPE CASE ** 11519C ********************************************** 11520C 11521 IF(ICOM.EQ.'PRIN'.AND.IHARG(1).EQ.'COMP'.AND. 11522 1 IHARG(2).EQ.'TYPE')THEN 11523 CALL DPPCTY(IHARG,NUMARG, 11524 1 IDEFPT, 11525 1 IPCMTY, 11526 1 IBUGS2,IFOUND,IERROR) 11527 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11528 ENDIF 11529C 11530C **************************************** 11531C ** TREAT THE LOWESS DEGREE CASE ** 11532C **************************************** 11533C 11534 IF(ICOM.EQ.'LOWE'.AND.NUMARG.GE.1.AND. 11535 1 IHARG(1).EQ.'DEGR')THEN 11536 CALL DPLODG(IHARG,IARGT,ARG,NUMARG, 11537 1 ALOWDG,IFOUND,IERROR) 11538 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11539 ENDIF 11540C 11541CCCCC FOLLOWING SECTION ADDED JUNE 1994. 11542C *********************************************** 11543C ** TREAT THE OPTIMIZATION TOLERANCE CASE ** 11544C *********************************************** 11545C 11546 IF(ICOM.EQ.'OPTI'.AND.NUMARG.GE.1.AND. 11547 1IHARG(1).EQ.'TOLE')GOTO12600 11548 IF(ICOM.EQ.'OPTI'.AND.NUMARG.GE.1.AND. 11549 1IHARG(1).EQ.'ACCU')GOTO12600 11550 GOTO12699 11551C 1155212600 CONTINUE 11553C 11554 CALL DPOPAC(IHARG,IARGT,ARG,NUMARG,DEFOAC, 11555 1OPTACC,IFOUND,IERROR) 11556 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11557C 1155812699 CONTINUE 11559C 11560CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1994 (JJF) 11561C ***************************************** 11562C ** TREAT THE COPY (= COPY FILE) CASE ** 11563C ***************************************** 11564C 11565 IF(NUMARG.GE.1)THEN 11566 IF(ICOM.EQ.'COPY')THEN 11567 CALL DPCOFI(ICOM,IANSLC,IWIDTH,IHARG,IHARG2,NUMARG, 11568 1 IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR) 11569 IFOUND='YES' 11570 GOTO9000 11571 ENDIF 11572 ENDIF 11573C 11574CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2019 11575C ***************************************** 11576C ** TREAT THE PRINTFILE CASE ** 11577C ***************************************** 11578C 11579 IF(NUMARG.GE.1)THEN 11580 IF(ICOM.EQ.'PRIN' .AND. ICOM2.EQ.'TFIL')THEN 11581 CALL DPPRFI(ICOM,IANSLC,IWIDTH,IHARG,IHARG2,NUMARG, 11582 1 IBUGS2,ISUBRO,IFOUND,IERROR) 11583 IFOUND='YES' 11584 GOTO9000 11585 ENDIF 11586 ENDIF 11587C 11588CCCCC THE FOLLOWING SECTION WAS ADDED BY ALAN FEBRUARY 1995 11589C ********************************************** 11590C ** TREAT THE OPTIMIZATION METHOD CASE ** 11591C ********************************************** 11592C 11593 IF(ICOM.EQ.'OPTI'.AND.NUMARG.GE.1.AND. 11594 1 IHARG(1).EQ.'METH')THEN 11595 CALL DPOPME(IHARG,NUMARG, 11596 1 IDEFOM,IDEFHS, 11597 1 IOPTME,IOPTHE, 11598 1 IBUGS2,IFOUND,IERROR) 11599 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11600 ENDIF 11601C 11602CCCCC THE FOLLOWING SECTION WAS ADDED BY JIM SEPTEMBER 1995 11603C ********************************************** 11604C ** TREAT THE INIT CASE ** 11605C ** (USEFUL FOR SIGN-ON DEBUGGING) ** 11606C ********************************************** 11607C 11608 IF(ICOM.EQ.'INIT')THEN 11609 IBUGIN='ON' 11610C 11611 ICOMHO=ICOM 11612 ICOMH2=ICOM2 11613C 11614 WRITE(ICOUT,10811) 1161510811 FORMAT('FROM MAINSU--BEFORE CALL TO MAININ') 11616 CALL DPWRST('XXX','BUG ') 11617 WRITE(ICOUT,10812)IBUGMA,IBUGIN,ICOM,ICOM2,ICOMHO,ICOMH2,NUMDEV 1161810812 FORMAT('IBUGMA,IBUGIN,ICOM,ICOM2,ICOMHO,ICOMH2,NUMDEV = ', 11619 1 A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4,I8) 11620 CALL DPWRST('XXX','BUG ') 11621C 11622 IRSCNT=1 11623 CALL MAININ(IBUGIN,ICOMHO,ICOMH2,IRSCNT) 11624 IBUGIN='OFF' 11625 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11626 ENDIF 11627C 11628CCCCC FOLLOWING SECTION ADDED APRIL 1997. 11629C ******************************* 11630C ** TREAT THE WEB HELP CASE ** 11631C ******************************* 11632C 11633 1201 CONTINUE 11634C 11635 IF((ICOM.EQ.'WEB'.AND.IHARG(1).EQ.'HELP') .OR. 11636 1 ICOM.EQ.'?? ')THEN 11637 CALL DPHELW(ICOM,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 11638 1 IANS,IWIDTH, 11639 1 IBUGS2,ISUBRO,IFOUND,IERROR) 11640 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11641 ENDIF 11642C 11643CCCCC FOLLOWING SECTION ADDED MARCH 1999. 11644C *********************************** 11645C ** TREAT THE WEB HANDBOOK CASE ** 11646C *********************************** 11647C 11648 IF(ICOM.EQ.'HAND' .OR. ICOM.EQ.'HB ' .OR. 11649 1 ICOM.EQ.'WHB ' .OR. 11650 1 (ICOM.EQ.'????' .AND. ICOM2.EQ.' ') .OR. 11651 1 (ICOM.EQ.'WEB'.AND.IHARG(1).EQ.'HAND'))THEN 11652 CALL DPHANW(ICOM,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,IANS, 11653 1 IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR) 11654 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11655 ENDIF 11656C 11657CCCCC FOLLOWING SECTION ADDED APRIL 1997. 11658C ******************************* 11659C ** TREAT THE WEB CASE ** 11660C ** NOTE: SET "HANDBOOK" = ** 11661C ** "WEB HANDBOOK ** 11662C ******************************* 11663C 11664CCCCC 2019/11: IF THE FIRST ARGUMENT DOES NOT START WITH ONE OF THE 11665C FOLLOWING 11666C 11667C http 11668C file: 11669C www. 11670C A PERIOD "." WITHIN THE FIRST 8 CHARACTERS, THEN 11671C 11672C THEN ASSUME THIS IS NOT A URL ADDRESS AND CONVERT THE 11673C "WEB" COMMAND TO A "WEB HELP" COMMAND. 11674C 11675 IF(ICOM.EQ.'WEB' .OR. ICOM.EQ.'W ' .OR. 11676 1 ICOM.EQ.'WS ' .OR. 11677 1 (ICOM.EQ.'????' .AND. ICOM2.EQ.'? '))THEN 11678C 11679 IFLAG=0 11680 IF(ICOM.EQ.'WS ')IFLAG=1 11681 IF(ICOM.EQ.'????' .AND. ICOM2.EQ.'? ')IFLAG=1 11682 IF(IHARG(1).EQ.'SEAR' .AND. IHARG2(1).EQ.'CH ')IFLAG=1 11683 IF(IHARG(1).EQ.'HTTP' .AND. IHARG2(1)(1:1).EQ.':')IFLAG=1 11684 IF(IHARG(1).EQ.'HTTP' .AND. IHARG2(1)(1:2).EQ.'S:')IFLAG=1 11685 IF(IHARG(1).EQ.'FILE' .AND. IHARG2(1)(1:1).EQ.':')IFLAG=1 11686 IF(IHARG(1).EQ.'"HTT' .AND. IHARG2(1)(1:2).EQ.'P:')IFLAG=1 11687 IF(IHARG(1).EQ.'"HTT' .AND. IHARG2(1)(1:3).EQ.'PS:')IFLAG=1 11688 IF(IHARG(1).EQ.'"FIL' .AND. IHARG2(1)(1:2).EQ.'E:')IFLAG=1 11689 IF(IHARG(1).EQ.'WWW.')IFLAG=1 11690 IF(IHARG(1)(1:1).EQ.'.')IFLAG=1 11691 IF(IHARG(1)(2:2).EQ.'.')IFLAG=1 11692 IF(IHARG(1)(3:3).EQ.'.')IFLAG=1 11693 IF(IHARG(1)(4:4).EQ.'.')IFLAG=1 11694 IF(IHARG2(1)(1:1).EQ.'.')IFLAG=1 11695 IF(IHARG2(1)(2:2).EQ.'.')IFLAG=1 11696 IF(IHARG2(1)(3:3).EQ.'.')IFLAG=1 11697 IF(IHARG2(1)(4:4).EQ.'.')IFLAG=1 11698C 11699 IF(IFLAG.EQ.1)THEN 11700 CALL DPWEB(ICOM,ICOM2,IHARG,IHARG2,NUMARG, 11701 1 IANSLC,IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR) 11702 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11703 ELSE 11704 ISHIFT=1 11705 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 11706 1 IBUGS2,IERROR) 11707 ISTRT=-1 11708 DO1210II=1,30 11709 IF(IANS(II)(1:1).EQ.IHARG(1)(1:1) .AND. 11710 1 IANS(II+1)(1:1).EQ.IHARG(1)(2:2) .AND. 11711 1 IANS(II+2)(1:1).EQ.IHARG(1)(3:3) .AND. 11712 1 IANS(II+3)(1:1).EQ.IHARG(1)(4:4))THEN 11713 ISTRT=II 11714 GOTO1219 11715 ENDIF 11716 1210 CONTINUE 11717 1219 CONTINUE 11718 IF(ISTRT.GE.1)THEN 11719 DO1220II=ISTRT,IWIDTH 11720 IF(II+5.LE.MAXSTR)THEN 11721 IANS(II+5)=IANS(II) 11722 IANSLC(II+5)=IANSLC(II) 11723 ENDIF 11724 1220 CONTINUE 11725 IANS(ISTRT)='H ' 11726 IANS(ISTRT+1)='E ' 11727 IANS(ISTRT+2)='L ' 11728 IANS(ISTRT+3)='P ' 11729 IANS(ISTRT+4)=' ' 11730 IANSLC(ISTRT)='H ' 11731 IANSLC(ISTRT+1)='E ' 11732 IANSLC(ISTRT+2)='L ' 11733 IANSLC(ISTRT+3)='P ' 11734 IANSLC(ISTRT+4)=' ' 11735 ENDIF 11736 IHARG(1)='HELP' 11737 IHARG2(1)=' ' 11738 GOTO1201 11739 ENDIF 11740 ENDIF 11741C 11742CCCCC FOLLOWING SECTION ADDED APRIL 1997. 11743C ********************************** 11744C ** TREAT THE REPEAT GRAPH CASE ** 11745C ********************************** 11746C 11747 IF(NUMARG.GE.1.AND.ICOM.EQ.'REPE'.AND. 11748 1IHARG(1).EQ.'PLOT'.AND.IHARG2(1).EQ.' ')GOTO12900 11749 IF(NUMARG.GE.1.AND.ICOM.EQ.'REPE'.AND. 11750 1IHARG(1).EQ.'PLOT'.AND.IHARG2(1).EQ.'S ')GOTO12900 11751 IF(NUMARG.GE.1.AND.ICOM.EQ.'REPE'.AND. 11752 1IHARG(1).EQ.'GRAP'.AND.IHARG2(1).EQ.'H ')GOTO12900 11753 IF(NUMARG.GE.1.AND.ICOM.EQ.'REPE'.AND. 11754 1IHARG(1).EQ.'GRAP'.AND.IHARG2(1).EQ.'HS ')GOTO12900 11755 IF(ICOM.EQ.'RG ')GOTO12900 11756 IF(ICOM.EQ.'RP ')GOTO12900 11757 IF(NUMARG.GE.1.AND.ICOM.EQ.'VIEW'.AND. 11758 1IHARG(1).EQ.'PLOT'.AND.IHARG2(1).EQ.' ')GOTO12900 11759 IF(NUMARG.GE.1.AND.ICOM.EQ.'VIEW'.AND. 11760 1IHARG(1).EQ.'PLOT'.AND.IHARG2(1).EQ.'S ')GOTO12900 11761 IF(NUMARG.GE.1.AND.ICOM.EQ.'VIEW'.AND. 11762 1IHARG(1).EQ.'GRAP'.AND.IHARG2(1).EQ.'H ')GOTO12900 11763 IF(NUMARG.GE.1.AND.ICOM.EQ.'VIEW'.AND. 11764 1IHARG(1).EQ.'GRAP'.AND.IHARG2(1).EQ.'HS ')GOTO12900 11765 IF(ICOM.EQ.'VG ')GOTO12900 11766 IF(ICOM.EQ.'VP ')GOTO12900 11767 GOTO12990 11768C 1176912900 CONTINUE 11770 CALL DPREGR(IANSLC,IWIDTH,IHARG,IARGT,IARG,NUMARG, 11771 1IBUGS2,ISUBRO,IFOUND,IERROR) 11772 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 1177312990 CONTINUE 11774C 11775CCCCC FOLLOWING SECTION ADDED APRIL 1997. 11776C ********************************** 11777C ** TREAT THE LIST GRAPH CASE ** 11778C ********************************** 11779C 11780 IF(NUMARG.GE.1.AND.ICOM.EQ.'LIST'.AND. 11781 1IHARG(1).EQ.'PLOT'.AND.IHARG2(1).EQ.' ')GOTO13000 11782 IF(NUMARG.GE.1.AND.ICOM.EQ.'LIST'.AND. 11783 1IHARG(1).EQ.'PLOT'.AND.IHARG2(1).EQ.'S ')GOTO13000 11784 IF(NUMARG.GE.1.AND.ICOM.EQ.'LIST'.AND. 11785 1IHARG(1).EQ.'GRAP'.AND.IHARG2(1).EQ.'H ')GOTO13000 11786 IF(NUMARG.GE.1.AND.ICOM.EQ.'LIST'.AND. 11787 1IHARG(1).EQ.'GRAP'.AND.IHARG2(1).EQ.'HS ')GOTO13000 11788 IF(ICOM.EQ.'LG ')GOTO13000 11789 IF(ICOM.EQ.'LP ' .AND. IHARG(1).NE.'LOCA')GOTO13000 11790 GOTO13090 11791C 1179213000 CONTINUE 11793 CALL DPLIGR(IANSLC,IWIDTH,IHARG,IARGT,IARG,NUMARG, 11794 1IBUGS2,ISUBRO,IFOUND,IERROR) 11795 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 1179613090 CONTINUE 11797C 11798CCCCC FOLLOWING SECTION ADDED APRIL 1997. 11799C ********************************** 11800C ** TREAT THE CYCLE GRAPH CASE ** 11801C ********************************** 11802C 11803 IF(NUMARG.GE.1.AND.ICOM.EQ.'CYCL'.AND. 11804 1IHARG(1).EQ.'PLOT'.AND.IHARG2(1).EQ.' ')GOTO13100 11805 IF(NUMARG.GE.1.AND.ICOM.EQ.'CYCL'.AND. 11806 1IHARG(1).EQ.'PLOT'.AND.IHARG2(1).EQ.'S ')GOTO13100 11807 IF(NUMARG.GE.1.AND.ICOM.EQ.'CYCL'.AND. 11808 1IHARG(1).EQ.'GRAP'.AND.IHARG2(1).EQ.'H ')GOTO13100 11809 IF(NUMARG.GE.1.AND.ICOM.EQ.'CYCL'.AND. 11810 1IHARG(1).EQ.'GRAP'.AND.IHARG2(1).EQ.'HS ')GOTO13100 11811 IF(ICOM.EQ.'CG ')GOTO13100 11812CCCCC MARCH 1998. CONFLICT WITH CP PLOT COMMAND. 11813 IF(ICOM.EQ.'CP '.AND.IHARG(1).NE.'PLOT')GOTO13100 11814 GOTO13190 11815C 1181613100 CONTINUE 11817 CALL DPCYGR(IANSLC,IWIDTH,IHARG,IARGT,IARG,NUMARG, 11818 1IBUGS2,ISUBRO,IFOUND,IERROR) 11819 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 1182013190 CONTINUE 11821C 11822C *************************** 11823C ** TREAT THE CD CASE** 11824C *************************** 11825C 11826 IF(ICOM.EQ.'CD ')THEN 11827 CALL DPCDIR(IANS,IANSLC,IWIDTH, 11828 1 IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 11829 1 IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, 11830 1 IBUGS2,ISUBRO,IFOUND,IERROR) 11831 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11832 ENDIF 11833C 11834C ******************************** 11835C ** TREAT THE RM CASE ** 11836C ******************************** 11837C 11838 IF(ICOM.EQ.'RM ' .OR. 11839 1 (ICOM.EQ.'RMDI' .AND. ICOM2.EQ.'R '))THEN 11840 CALL DPRM(IANS,IANSLC,IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR) 11841 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11842 ENDIF 11843C 11844C ******************************** 11845C ** TREAT THE MKDIR CASE ** 11846C ******************************** 11847C 11848 IF(ICOM.EQ.'MKDI' .AND. ICOM2.EQ.'R ')THEN 11849 CALL DPMKDR(IANS,IANSLC,IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR) 11850 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11851 ENDIF 11852C 11853C ******************************** 11854C ** TREAT THE CAT CASE ** 11855C ******************************** 11856C 11857 IF(ICOM.EQ.'CAT ' .OR. 11858 1 (ICOM.EQ.'TYPE' .AND. ICOM2.EQ.' '))THEN 11859 CALL DPCAT(IANS,IANSLC,IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR) 11860 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11861 ENDIF 11862C 11863C ******************************** 11864C ** TREAT THE DIR CASE ** 11865C ******************************** 11866C 11867 IF(ICOM.EQ.'DIR ' .OR. ICOM.EQ.'LS ')THEN 11868 CALL DPDIR(IANS,IANSLC,IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR) 11869 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11870 ENDIF 11871C 11872C ****************************************************** 11873C ** TREAT THE RECIPE SATTERWAITE APPROXIMATION CASE ** 11874C ****************************************************** 11875C 11876 IF(ICOM.EQ.'RECI')THEN 11877 IF((NUMARG.GE.2.AND.IHARG(1).EQ.'SATT'.AND. 11878 1 IHARG(2).EQ.'APPR') .OR. 11879 1 (NUMARG.GE.1.AND.IHARG(1).EQ.'SATT') .OR. 11880 1 (NUMARG.GE.1.AND.IHARG(1).EQ.'APPR'))THEN 11881 CALL DPRESA(IHARG,NUMARG,IDEFSA,IRECSA,IBUGS2,IFOUND,IERROR) 11882 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11883C 11884C ****************************************************** 11885C ** TREAT THE RECIPE PROBABILITY CONTENT CASE ** 11886C ****************************************************** 11887C 11888 ELSEIF((NUMARG.GE.2.AND.IHARG(1).EQ.'PROB'.AND. 11889 1 IHARG(2).EQ.'PLOT') .OR. 11890 1 (NUMARG.GE.2.AND.IHARG(1).EQ.'PROB'.AND. 11891 1 IHARG(2).EQ.'CONT') .OR. 11892 1 (NUMARG.GE.1.AND.IHARG(1).EQ.'CONT') .OR. 11893 1 (NUMARG.GE.1.AND.IHARG(1).EQ.'PROB'))THEN 11894 CALL DPREPC(IHARG,IARGT,ARG,NUMARG,DEFRPC,RECIPC, 11895 1 IFOUND,IERROR) 11896 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11897C 11898C ****************************************************** 11899C ** TREAT THE RECIPE CONFIDENCE CASE ** 11900C ****************************************************** 11901C 11902 ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'CONF')THEN 11903 CALL DPRECO(IHARG,IARGT,ARG,NUMARG,DEFRCO,RECICO, 11904 1 IFOUND,IERROR) 11905 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11906C 11907C ****************************************************** 11908C ** TREAT THE RECIPE FIT DEGREE CASE ** 11909C ****************************************************** 11910C 11911 ELSEIF((NUMARG.GE.2.AND.IHARG(1).EQ.'FIT '.AND. 11912 1 IHARG(2).EQ.'DEGR') .OR. 11913 1 (NUMARG.GE.1.AND.IHARG(1).EQ.'DEGR'))THEN 11914 CALL DPREDG(IHARG,IARGT,ARG,NUMARG,DEFRDG,RECIDG, 11915 1 IFOUND,IERROR) 11916 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11917C 11918C ****************************************************** 11919C ** TREAT THE RECIPE ANOVA FACTORS CASE ** 11920C ****************************************************** 11921C 11922 ELSEIF((NUMARG.GE.2.AND.IHARG(1).EQ.'ANOV'.AND. 11923 1 IHARG(2).EQ.'FACT') .OR. 11924 1 (NUMARG.GE.1.AND.IHARG(1).EQ.'FACT'))THEN 11925 CALL DPREFA(IHARG,IARGT,ARG,NUMARG,DEFRFA,RECIFA, 11926 1 IFOUND,IERROR) 11927 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11928C 11929C ****************************************************** 11930C ** TREAT THE RECIPE OUTPUT CASE ** 11931C ****************************************************** 11932C 11933 ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'OUTP')THEN 11934 CALL DPRETN(IHARG,NUMARG,IDEFTN,IRECTN, 11935 1 IBUGS2,IFOUND,IERROR) 11936 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11937C 11938C ****************************************************** 11939C ** TREAT THE RECIPE CORRELATION CASE ** 11940C ****************************************************** 11941C 11942 ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'CORR')THEN 11943 CALL DPRECR(IHARG,IARGT,IARG,NUMARG,IDEFR9,IRECC1, 11944 1 IFOUND,IERROR) 11945 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11946C 11947C ****************************************************** 11948C ** TREAT THE RECIPE SIMCOV REPLICATES CASE ** 11949C ****************************************************** 11950C 11951 ELSEIF((NUMARG.GE.2.AND.IHARG(1).EQ.'SIMC'.AND. 11952 1 IHARG(2).EQ.'REPL') .OR. 11953 1 (NUMARG.GE.2.AND.IHARG(1).EQ.'REPL'.AND. 11954 1 IHARG(2).EQ.'SIMC') .OR. 11955 1 (NUMARG.GE.1.AND.IHARG(1).EQ.'SIMC') .OR. 11956 1 (NUMARG.GE.1.AND.IHARG(1).EQ.'REPL'))THEN 11957 CALL DPRES1(IHARG,IARGT,IARG,NUMARG,IDEFR7,IRECR1, 11958 1 IFOUND,IERROR) 11959 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11960C 11961C ****************************************************** 11962C ** TREAT THE RECIPE SIMPVT REPLICATES CASE ** 11963C ****************************************************** 11964C 11965 ELSEIF((NUMARG.GE.2.AND.IHARG(1).EQ.'SIMP'.AND. 11966 1 IHARG(2).EQ.'REPL') .OR. 11967 1 (NUMARG.GE.2.AND.IHARG(1).EQ.'REPL'.AND. 11968 1 IHARG(2).EQ.'SIMP') .OR. 11969 1 (NUMARG.GE.1.AND.IHARG(1).EQ.'SIMP'))THEN 11970 CALL DPRESZ(IHARG,IARGT,IARG,NUMARG,IDEFR8,IRECR2, 11971 1 IFOUND,IERROR) 11972 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11973C 11974CCCCC FOLLOWING SECTION ADDED APRIL 1998. 11975C ****************************************************** 11976C ** TREAT THE RECIPE FIT FACTORS CASE ** 11977C ****************************************************** 11978C 11979 ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'FIT '.AND. 11980 1 IHARG(2).EQ.'FACT')THEN 11981 CALL DPREFF(IHARG,IARGT,ARG,NUMARG,DEFRFF,RECIFF, 11982 1 IFOUND,IERROR) 11983 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11984 ENDIF 11985C 11986 ENDIF 11987C 11988C ******************************** 11989C ** TREAT THE AUTO TEXT CASE ** 11990C ******************************** 11991C 11992 IF(ICOM.EQ.'AUTO'.AND. 11993 1 NUMARG.GE.1.AND.IHARG(1).EQ.'TEXT')THEN 11994 CALL DPAUTX(IHARG,NUMARG,IATXSW,IFOUND,IERROR) 11995 IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 11996 ENDIF 11997C 11998C 11999C ***************** 12000C ** STEP 90-- ** 12001C ** EXIT ** 12002C ***************** 12003C 12004 9000 CONTINUE 12005C 12006 IERRST=IERROR 12007C 12008C AUGUST 2007. CHECK FOR FATAL ERROR 12009C 12010 IF(IERROR.EQ.'YES')THEN 12011 ISUBN1='MAIN' 12012 ISUBN2='SU ' 12013 ICASE2='SUPP' 12014 CALL DPERRO(IERRFA,IANSLC,IWIDTH,IGUIFL, 12015 1 ISUBN1,ISUBN2,ICASE2, 12016 1 IBUGS2,ISUBRO,IERROR) 12017 ENDIF 12018C 12019C 12020 IF(IBUGSU.EQ.'ON'.OR.ISUBRO.EQ.'INSU')THEN 12021 WRITE(ICOUT,999) 12022 CALL DPWRST('XXX','BUG ') 12023 WRITE(ICOUT,9011) 12024 9011 FORMAT('***** AT THE END OF MAINSU--') 12025 CALL DPWRST('XXX','BUG ') 12026 WRITE(ICOUT,9022)IFOUND,IERROR 12027 9022 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 12028 CALL DPWRST('XXX','BUG ') 12029 ENDIF 12030C 12031 RETURN 12032 END 12033 SUBROUTINE MAKCDF(X,XI,LAMBDA,THETA,CDF) 12034C 12035C THIS SUBROUTINE COMPUTES THE GOMPERTZ-MAKEHAM CUMULATIVE 12036C DISTRIBUTION FUNCTION. IT HAS THE FOLLOWING CDF: 12037C F(X,XI,LAMBDA,THETA) = 1 - 12038C EXP[-XI*(EXP(LAMBDA*X) -1) - XI*THETA*LAMBDA*X) 12039C X > 0; LAMBDA, XI > 0, THETA >= 0 12040C NOTE THAT THIS IS THE PARAMETERIZATION USED BY THE DIGITAL 12041C LIBRARY OF MATHEMATICAL FUNCTIONS (DLMF). TO USE THE 12042C PARAMETERIZATION GIVEN ON PAGE 108-109 OF MEEKER AND ESCOBAR, 12043C DO THE FOLLOWING BEFORE CALLING THIS ROUTINE: 12044C 12045C XI(DLMF) = GAMMA(MEEKER)/K(MEEKER) 12046C LAMBDA(DLMF) = K(MEEKER) 12047C THETA(DLMF) = LAMBDA(MEEKER)/GAMMA(MEEKER) 12048C 12049C WRITTEN BY--JAMES J. FILLIBEN 12050C STATISTICAL ENGINEERING DIVISION 12051C INFORMATION TECHNOLOGY LABORATORY 12052C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 12053C GAITHERSBURG, MD 20899-8980 12054C PHONE--301-975-2855 12055C REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA", 12056C MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109. 12057C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12058C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 12059C LANGUAGE--ANSI FORTRAN (1977) 12060C VERSION NUMBER--2003/12 12061C ORIGINAL VERSION--DECEMBER 2003. 12062C 12063C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12064C 12065 REAL LAMBDA 12066C 12067 DOUBLE PRECISION DCDF 12068 DOUBLE PRECISION DXI 12069 DOUBLE PRECISION DLMBDA 12070 DOUBLE PRECISION DTHETA 12071 DOUBLE PRECISION DX 12072 DOUBLE PRECISION DTERM1 12073C 12074C--------------------------------------------------------------------- 12075C 12076 INCLUDE 'DPCOP2.INC' 12077C 12078C-----START POINT----------------------------------------------------- 12079C 12080 CDF=0.0 12081 IF(X.LE.0.0)GOTO9999 12082 IF(XI.LE.0.0)THEN 12083 WRITE(ICOUT,101) 12084 CALL DPWRST('XXX','BUG ') 12085 WRITE(ICOUT,102)XI 12086 CALL DPWRST('XXX','BUG ') 12087 GOTO9999 12088 ENDIF 12089 IF(LAMBDA.LE.0.0)THEN 12090 WRITE(ICOUT,106) 12091 CALL DPWRST('XXX','BUG ') 12092 WRITE(ICOUT,107)LAMBDA 12093 CALL DPWRST('XXX','BUG ') 12094 GOTO9999 12095 ENDIF 12096 IF(THETA.LT.0.0)THEN 12097 WRITE(ICOUT,111) 12098 CALL DPWRST('XXX','BUG ') 12099 WRITE(ICOUT,112)THETA 12100 CALL DPWRST('XXX','BUG ') 12101 GOTO9999 12102 ENDIF 12103 101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER (XI) TO MAKCDF') 12104 102 FORMAT(' IS NON-POSITIVE. IT HAS THE VALUE ',E15.7) 12105 106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (LAMBDA) TO') 12106 107 FORMAT(' MAKCDF IS NON-POSITIVE. IT HAS THE VALUE ',E15.7) 12107 111 FORMAT('***** ERROR--THE THIRD SHAPE PARAMETER (THETA) TO') 12108 112 FORMAT(' MAKCDF IS NEGATIVE. IT HAS THE VALUE ',E15.7) 12109C 12110 DX=DBLE(X) 12111 DXI=DBLE(XI) 12112 DLMBDA=DBLE(LAMBDA) 12113 DTHETA=DBLE(THETA) 12114C 12115 DTERM1=-DXI*(DEXP(DLMBDA*DX) - 1.0D0) - DXI*DLMBDA*DTHETA*DX 12116C 12117 IF(DTERM1.LE.-80.D0)THEN 12118 CDF=1.0 12119 GOTO9999 12120 ELSEIF(DTERM1.GE.80.D0)THEN 12121 CDF=0.0 12122 WRITE(ICOUT,401) 12123 CALL DPWRST('XXX','BUG ') 12124 GOTO9999 12125 ELSE 12126 DCDF=1.0D0 - DEXP(DTERM1) 12127 CDF=REAL(DCDF) 12128 ENDIF 12129 401 FORMAT('***** NON-FATAL DIAGNOSTIC FROM MAKCDF. THE COMPUTED ', 12130 1'CDF VALUE EXCEEDS MACHINE PRECISION.') 12131C 12132 9999 CONTINUE 12133 RETURN 12134 END 12135 REAL FUNCTION MAKFU2(X) 12136C 12137C PURPOSE--MAKPPF CALLS FZERO TO FIND A ROOT FOR THE PERCENT 12138C POINT FUNCTION. MAKFU2 IS THE FUNCTION FOR WHICH 12139C THE ZERO IS FOUND. IT IS: 12140C P - MAKCDF(X,XI,LAMBDA,THETA) 12141C WHERE P IS THE DESIRED PERCENT POINT. 12142C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT 12143C WHICH THE CUMULATIVE DISTRIBUTION 12144C FUNCTION IS TO BE EVALUATED. 12145C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY 12146C FUNCTION VALUE MAKFU2. 12147C PRINTING--NONE. 12148C RESTRICTIONS--NONE. 12149C OTHER DATAPAC SUBROUTINES NEEDED--MAKCDF. 12150C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 12151C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 12152C LANGUAGE--ANSI FORTRAN (1977) 12153C REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA", 12154C MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109. 12155C WRITTEN BY--JAMES J. FILLIBEN 12156C STATISTICAL ENGINEERING DIVISION 12157C INFORMATION TECHNOLOGY LABORATORY 12158C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY 12159C GAITHERSBURG, MD 20899-8980 12160C PHONE--301-975-2855 12161C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12162C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. 12163C LANGUAGE--ANSI FORTRAN (1977) 12164C VERSION NUMBER--2003.12 12165C ORIGINAL VERSION--DECEMBER 2003. 12166C 12167C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12168C 12169C--------------------------------------------------------------------- 12170C 12171 REAL P 12172 COMMON/MA2COM/P 12173C 12174 REAL XI 12175 REAL LAMBDA 12176 REAL THETA 12177 COMMON/MAKCOM/XI,LAMBDA,THETA 12178C 12179C-----COMMON---------------------------------------------------------- 12180C 12181 INCLUDE 'DPCOP2.INC' 12182C 12183C-----START POINT----------------------------------------------------- 12184C 12185 CALL MAKCDF(X,XI,LAMBDA,THETA,CDF) 12186 MAKFU2=P - CDF 12187 RETURN 12188 END 12189 SUBROUTINE MAKCHA(X,XI,LAMBDA,THETA,HAZ) 12190C 12191C THIS SUBROUTINE COMPUTES THE GOMPERTZ-MAKEHAM CUMULATIVE 12192C HAZARD FUNCTION WHICH HAS THE FOLLOWING FORMULA: 12193C H(X,XI,LAMBDA,THETA) = 12194C -[-XI*(EXP(LAMBDA*X) - 1) - XI*THETA*LAMBDA*X] 12195C X > 0; LAMBDA, XI > 0, THETA >= 0 12196C NOTE THAT THIS IS THE PARAMETERIZATION USED BY THE DIGITAL 12197C LIBRARY OF MATHEMATICAL FUNCTIONS (DLMF). TO USE THE 12198C PARAMETERIZATION GIVEN ON PAGE 108-109 OF MEEKER AND ESCOBAR, 12199C DO THE FOLLOWING BEFORE CALLING THIS ROUTINE: 12200C 12201C XI(DLMF) = GAMMA(MEEKER)/K(MEEKER) 12202C LAMBDA(DLMF) = K(MEEKER) 12203C THETA(DLMF) = LAMBDA(MEEKER)/GAMMA(MEEKER) 12204C 12205C WRITTEN BY--JAMES J. FILLIBEN 12206C STATISTICAL ENGINEERING DIVISION 12207C INFORMATION TECHNOLOGY LABORATORY 12208C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 12209C GAITHERSBURG, MD 20899-8980 12210C PHONE--301-975-2855 12211C REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA", 12212C MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109. 12213C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12214C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 12215C LANGUAGE--ANSI FORTRAN (1977) 12216C VERSION NUMBER--2004/7 12217C ORIGINAL VERSION--JULY 2004. 12218C 12219C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12220C 12221 REAL LAMBDA 12222C 12223 DOUBLE PRECISION DHAZ 12224 DOUBLE PRECISION DXI 12225 DOUBLE PRECISION DLMBDA 12226 DOUBLE PRECISION DTHETA 12227 DOUBLE PRECISION DX 12228C 12229C-----COMMON---------------------------------------------------------- 12230C 12231 INCLUDE 'DPCOP2.INC' 12232C 12233C-----START POINT----------------------------------------------------- 12234C 12235 HAZ=0.0 12236 IF(X.LE.0.0)GOTO9999 12237 IF(XI.LE.0.0)THEN 12238 WRITE(ICOUT,101) 12239 CALL DPWRST('XXX','BUG ') 12240 WRITE(ICOUT,102)XI 12241 CALL DPWRST('XXX','BUG ') 12242 GOTO9999 12243 ENDIF 12244 IF(LAMBDA.LE.0.0)THEN 12245 WRITE(ICOUT,106) 12246 CALL DPWRST('XXX','BUG ') 12247 WRITE(ICOUT,107)LAMBDA 12248 CALL DPWRST('XXX','BUG ') 12249 GOTO9999 12250 ENDIF 12251 IF(THETA.LT.0.0)THEN 12252 WRITE(ICOUT,111) 12253 CALL DPWRST('XXX','BUG ') 12254 WRITE(ICOUT,112)THETA 12255 CALL DPWRST('XXX','BUG ') 12256 GOTO9999 12257 ENDIF 12258 101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER (XI) TO MAKCHAZ') 12259 102 FORMAT(' IS NON-POSITIVE. IT HAS THE VALUE ',E15.7) 12260 106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (LAMBDA) TO') 12261 107 FORMAT(' MAKCHAZ IS NON-POSITIVE. IT HAS THE VALUE ',E15.7) 12262 111 FORMAT('***** ERROR--THE THIRD SHAPE PARAMETER (THETA) TO') 12263 112 FORMAT(' MAKCHAZ IS NEGATIVE. IT HAS THE VALUE ',E15.7) 12264C 12265 DX=DBLE(X) 12266 DXI=DBLE(XI) 12267 DLMBDA=DBLE(LAMBDA) 12268 DTHETA=DBLE(THETA) 12269C 12270 DHAZ=-DXI*(DEXP(DLMBDA*DX) - 1.0D0) - DXI*DLMBDA*DTHETA*DX 12271 HAZ=-REAL(DHAZ) 12272C 12273 9999 CONTINUE 12274 RETURN 12275 END 12276 SUBROUTINE MAKHAZ(X,XI,LAMBDA,THETA,HAZ) 12277C 12278C THIS SUBROUTINE COMPUTES THE GOMPERTZ-MAKEHAM 12279C HAZARD FUNCTION WHICH HAS THE FOLLOWING FORMULA: 12280C h(X,XI,LAMBDA,THETA) = f(X,XI,LAMBDA,THETA)/ 12281C -LOG[1 - F(x,XI,LAMBDA,THETA)] 12282C = XI*THETA*LAMBDA + XI*LAMBDA* 12283C EXP(LAMBDA*X) 12284C X > 0; LAMBDA, XI > 0, THETA >= 0 12285C WHERE f IS THE PROBABILITY DENSITY AND F IS THE 12286C CUMULATIVE DISTRIBUTION FUNCTION. 12287C 12288C NOTE THAT THIS IS THE PARAMETERIZATION USED BY THE DIGITAL 12289C LIBRARY OF MATHEMATICAL FUNCTIONS (DLMF). TO USE THE 12290C PARAMETERIZATION GIVEN ON PAGE 108-109 OF MEEKER AND ESCOBAR, 12291C DO THE FOLLOWING BEFORE CALLING THIS ROUTINE: 12292C 12293C XI(DLMF) = GAMMA(MEEKER)/K(MEEKER) 12294C LAMBDA(DLMF) = K(MEEKER) 12295C THETA(DLMF) = LAMBDA(MEEKER)/GAMMA(MEEKER) 12296C 12297C WRITTEN BY--JAMES J. FILLIBEN 12298C STATISTICAL ENGINEERING DIVISION 12299C INFORMATION TECHNOLOGY LABORATORY 12300C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 12301C GAITHERSBURG, MD 20899-8980 12302C PHONE--301-975-2855 12303C REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA", 12304C MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109. 12305C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12306C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 12307C LANGUAGE--ANSI FORTRAN (1977) 12308C VERSION NUMBER--2004/7 12309C ORIGINAL VERSION--JULY 2004. 12310C 12311C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12312C 12313 REAL LAMBDA 12314C 12315 DOUBLE PRECISION DHAZ 12316 DOUBLE PRECISION DXI 12317 DOUBLE PRECISION DLMBDA 12318 DOUBLE PRECISION DTHETA 12319 DOUBLE PRECISION DX 12320 DOUBLE PRECISION DTERM1 12321 DOUBLE PRECISION DTERM2 12322C 12323C-----COMMON---------------------------------------------------------- 12324C 12325 INCLUDE 'DPCOP2.INC' 12326C 12327C-----START POINT----------------------------------------------------- 12328C 12329 HAZ=0.0 12330 IF(X.LE.0.0)GOTO9999 12331 IF(XI.LE.0.0)THEN 12332 WRITE(ICOUT,101) 12333 CALL DPWRST('XXX','BUG ') 12334 WRITE(ICOUT,102)XI 12335 CALL DPWRST('XXX','BUG ') 12336 GOTO9999 12337 ENDIF 12338 IF(LAMBDA.LE.0.0)THEN 12339 WRITE(ICOUT,106) 12340 CALL DPWRST('XXX','BUG ') 12341 WRITE(ICOUT,107)LAMBDA 12342 CALL DPWRST('XXX','BUG ') 12343 GOTO9999 12344 ENDIF 12345 IF(THETA.LT.0.0)THEN 12346 WRITE(ICOUT,111) 12347 CALL DPWRST('XXX','BUG ') 12348 WRITE(ICOUT,112)THETA 12349 CALL DPWRST('XXX','BUG ') 12350 GOTO9999 12351 ENDIF 12352 101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER (XI) TO MAKHAZZ') 12353 102 FORMAT(' IS NON-POSITIVE. IT HAS THE VALUE ',E15.7) 12354 106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (LAMBDA) TO') 12355 107 FORMAT(' MAKHAZZ IS NON-POSITIVE. IT HAS THE VALUE ',E15.7) 12356 111 FORMAT('***** ERROR--THE THIRD SHAPE PARAMETER (THETA) TO') 12357 112 FORMAT(' MAKHAZZ IS NEGATIVE. IT HAS THE VALUE ',E15.7) 12358C 12359 DX=DBLE(X) 12360 DXI=DBLE(XI) 12361 DLMBDA=DBLE(LAMBDA) 12362 DTHETA=DBLE(THETA) 12363C 12364 DTERM1=DXI*DTHETA*DLMBDA 12365 DTERM2=DXI*DLMBDA*DEXP(DLMBDA*DX) 12366 DHAZ=DTERM1 + DTERM2 12367 HAZ=REAL(DHAZ) 12368 HAZ=REAL(DHAZ) 12369C 12370 9999 CONTINUE 12371 RETURN 12372 END 12373 SUBROUTINE MAKPDF(X,XI,LAMBDA,THETA,PDF) 12374C 12375C THIS SUBROUTINE COMPUTES THE GOMPERTZ-MAKEHAM PROBABILITY 12376C DENSITY FUNCTION. VALUE DISTRIBUTION. IT HAS THE FOLLOWING 12377C PDF: 12378C F(X,XI,LAMBDA,THETA) = XI*LAMBDA*(THETA + EXP(LAMBDA*X))* 12379C EXP[-XI*(EXP(LAMBDA*X) -1) - XI*THETA*LAMBDA*X) 12380C X > 0; LAMBDA, XI > 0, THETA >= 0 12381C NOTE THAT THIS IS THE PARAMETERIZATION USED BY THE DIGITAL 12382C LIBRARY OF MATHEMATICAL FUNCTIONS (DLMF). TO USE THE 12383C PARAMETERIZATION GIVEN ON PAGE 108-109 OF MEEKER AND ESCOBAR, 12384C DO THE FOLLOWING BEFORE CALLING THIS ROUTINE: 12385C 12386C XI(DLMF) = GAMMA(MEEKER)/K(MEEKER) 12387C LAMBDA(DLMF) = K(MEEKER) 12388C THETA(DLMF) = LAMBDA(MEEKER)/GAMMA(MEEKER) 12389C 12390C WRITTEN BY--JAMES J. FILLIBEN 12391C STATISTICAL ENGINEERING DIVISION 12392C LAMBDA = THETA*LAMBDA*XI 12393C INFORMATION TECHNOLOGY LABORATORY 12394C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 12395C GAITHERSBURG, MD 20899-8980 12396C PHONE--301-975-2855 12397C REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA", 12398C MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109. 12399C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12400C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 12401C LANGUAGE--ANSI FORTRAN (1977) 12402C VERSION NUMBER--2003/12 12403C ORIGINAL VERSION--DECEMBER 2003. 12404C 12405C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12406C 12407 REAL LAMBDA 12408C 12409 DOUBLE PRECISION DPDF 12410 DOUBLE PRECISION DXI 12411 DOUBLE PRECISION DLMBDA 12412 DOUBLE PRECISION DTHETA 12413 DOUBLE PRECISION DX 12414 DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4 12415C 12416C-----COMMON---------------------------------------------------------- 12417C 12418 INCLUDE 'DPCOP2.INC' 12419C 12420C-----START POINT----------------------------------------------------- 12421C 12422 PDF=0.0 12423 IF(X.LE.0.0)THEN 12424 WRITE(ICOUT,301) 12425 CALL DPWRST('XXX','BUG ') 12426 WRITE(ICOUT,302)X 12427 CALL DPWRST('XXX','BUG ') 12428 GOTO9999 12429 ENDIF 12430 IF(XI.LE.0.0)THEN 12431 WRITE(ICOUT,101) 12432 CALL DPWRST('XXX','BUG ') 12433 WRITE(ICOUT,102)XI 12434 CALL DPWRST('XXX','BUG ') 12435 GOTO9999 12436 ENDIF 12437 IF(LAMBDA.LE.0.0)THEN 12438 WRITE(ICOUT,106) 12439 CALL DPWRST('XXX','BUG ') 12440 WRITE(ICOUT,107)LAMBDA 12441 CALL DPWRST('XXX','BUG ') 12442 GOTO9999 12443 ENDIF 12444 IF(THETA.LT.0.0)THEN 12445 WRITE(ICOUT,111) 12446 CALL DPWRST('XXX','BUG ') 12447 WRITE(ICOUT,112)THETA 12448 CALL DPWRST('XXX','BUG ') 12449 GOTO9999 12450 ENDIF 12451 101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER (XI) TO MAKPDF') 12452 102 FORMAT(' IS NON-POSITIVE. IT HAS THE VALUE ',E15.7) 12453 106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (LAMBDA) TO') 12454 107 FORMAT(' MAKPDF IS NON-POSITIVE. IT HAS THE VALUE ',E15.7) 12455 111 FORMAT('***** ERROR--THE THIRD SHAPE PARAMETER (THETA) TO') 12456 112 FORMAT(' MAKPDF IS NEGATIVE. IT HAS THE VALUE ',E15.7) 12457 301 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO MAKPDF IS') 12458 302 FORMAT(' NON-POSITIVE. IT HAS THE VALUE ',E15.7) 12459C 12460 DX=DBLE(X) 12461 DXI=DBLE(XI) 12462 DLMBDA=DBLE(LAMBDA) 12463 DTHETA=DBLE(THETA) 12464C 12465 DTERM1=DLOG(DXI) + DLOG(DLMBDA) 12466 DTERM2=DLOG(DTHETA + DEXP(DLMBDA*DX)) 12467 DTERM3=-DXI*(DEXP(DLMBDA*DX) - 1.0D0) - DXI*DLMBDA*DTHETA*DX 12468 DTERM4=DTERM1 + DTERM2 + DTERM3 12469C 12470 IF(DTERM4.LE.-80.D0)THEN 12471 PDF=0.0 12472 GOTO9999 12473 ELSEIF(DTERM4.GE.80.D0)THEN 12474 PDF=0.0 12475 WRITE(ICOUT,401) 12476 CALL DPWRST('XXX','BUG ') 12477 GOTO9999 12478 ENDIF 12479 401 FORMAT('***** NON-FATAL DIAGNOSTIC FROM MAKPDF. THE COMPUTED ', 12480 1'PDF VALUE EXCEEDS MACHINE PRECISION.') 12481C 12482 DPDF=DEXP(DTERM4) 12483 PDF=REAL(DPDF) 12484C 12485 9999 CONTINUE 12486 RETURN 12487 END 12488 SUBROUTINE MAKPPF(P,XI,LAMBDA,THETA,PPF) 12489C 12490C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT 12491C FUNCTION VALUE FOR THE GOMPERTZ-MAKEHAM DISTRIBUTION 12492C WITH SHAPE PARAMETERS XI, LAMBDA, AND THETA. 12493C THIS DISTRIBUTION IS DEFINED FOR POSITIVE X AND THE 12494C PERCENT POINT FUNCTION IS COMPUTED BY 12495C NUMERICALLY INVERTING THE CDF FUNCTION. 12496C 12497C NOTE THAT THIS IS THE PARAMETERIZATION USED BY THE DIGITAL 12498C LIBRARY OF MATHEMATICAL FUNCTIONS (DLMF). TO USE THE 12499C PARAMETERIZATION GIVEN ON PAGE 108-109 OF MEEKER AND ESCOBAR, 12500C DO THE FOLLOWING BEFORE CALLING THIS ROUTINE: 12501C 12502C XI(DLMF) = GAMMA(MEEKER)/K(MEEKER) 12503C LAMBDA(DLMF) = K(MEEKER) 12504C THETA(DLMF) = LAMBDA(MEEKER)/GAMMA(MEEKER) 12505C 12506C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE AT 12507C WHICH THE PERCENT POINT 12508C FUNCTION IS TO BE EVALUATED. 12509C --XI = THE FIRST SHAPE PARAMETER 12510C --LAMBDA = THE SECOND SHAPE PARAMETER 12511C --THETA = THE THIRD SHAPE PARAMETER 12512C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION CUMULATIVE 12513C DISTRIBUTION FUNCTION VALUE. 12514C OUTPUT--THE SINGLE PRECISION PERCENT POINT 12515C FUNCTION VALUE PPF. 12516C PRINTING--NONE. 12517C RESTRICTIONS--NONE. 12518C OTHER DATAPAC SUBROUTINES NEEDED--FZERO. 12519C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 12520C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 12521C LANGUAGE--ANSI FORTRAN (1977) 12522C REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA", 12523C MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109. 12524C WRITTEN BY--JAMES J. FILLIBEN 12525C STATISTICAL ENGINEERING DIVISION 12526C INFORMATION TECHNOLOGY LABORATORY 12527C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY 12528C GAITHERSBURG, MD 20899-8980 12529C PHONE--301-975-2855 12530C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12531C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. 12532C LANGUAGE--ANSI FORTRAN (1977) 12533C VERSION NUMBER--2003.12 12534C ORIGINAL VERSION--DECEMBER 2003. 12535C 12536C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12537C 12538C--------------------------------------------------------------------- 12539C 12540 REAL LAMBDA 12541 REAL PPF 12542C 12543 REAL MAKFU2 12544 EXTERNAL MAKFU2 12545C 12546 REAL P2 12547 COMMON/MA2COM/P2 12548C 12549 REAL XI2 12550 REAL LAMBD2 12551 REAL THETA2 12552 COMMON/MAKCOM/XI2,LAMBD2,THETA2 12553C 12554 INCLUDE 'DPCOP2.INC' 12555C 12556C-----START POINT----------------------------------------------------- 12557C 12558C ******************************************** 12559C ** STEP 1-- ** 12560C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 12561C ******************************************** 12562C 12563 PPF=0.0 12564C 12565 IF(P.LT.0.0.OR.P.GE.1.0)THEN 12566 WRITE(ICOUT,61) 12567 61 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 12568 1 'TO THE MAKPPF SUBROUTINE ') 12569 CALL DPWRST('XXX','BUG ') 12570 WRITE(ICOUT,62) 12571 62 FORMAT(' IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL ***') 12572 CALL DPWRST('XXX','BUG ') 12573 WRITE(ICOUT,63)P 12574 63 FORMAT(' VALUE OF ARGUMENT = ',G15.7) 12575 CALL DPWRST('XXX','BUG ') 12576 PPF=0.0 12577 GOTO9000 12578 ENDIF 12579C 12580 IF(XI.LE.0.0)THEN 12581 WRITE(ICOUT,101) 12582 CALL DPWRST('XXX','BUG ') 12583 WRITE(ICOUT,102)XI 12584 CALL DPWRST('XXX','BUG ') 12585 GOTO9000 12586 ENDIF 12587 IF(LAMBDA.LE.0.0)THEN 12588 WRITE(ICOUT,106) 12589 CALL DPWRST('XXX','BUG ') 12590 WRITE(ICOUT,107)LAMBDA 12591 CALL DPWRST('XXX','BUG ') 12592 GOTO9000 12593 ENDIF 12594 IF(THETA.LT.0.0)THEN 12595 WRITE(ICOUT,111) 12596 CALL DPWRST('XXX','BUG ') 12597 WRITE(ICOUT,112)THETA 12598 CALL DPWRST('XXX','BUG ') 12599 GOTO9000 12600 ENDIF 12601 101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER (XI) TO MAKPPF') 12602 102 FORMAT(' IS NON-POSITIVE. IT HAS THE VALUE ',E15.7) 12603 106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (LAMBDA) TO') 12604 107 FORMAT(' MAKPPF IS NON-POSITIVE. IT HAS THE VALUE ',E15.7) 12605 111 FORMAT('***** ERROR--THE THIRD SHAPE PARAMETER (THETA) TO') 12606 112 FORMAT(' MAKPPF IS NEGATIVE. IT HAS THE VALUE ',E15.7) 12607C 12608 IF(P.EQ.0.0)THEN 12609 PPF=0.0 12610 GOTO9000 12611 ENDIF 12612C 12613C STEP 1: FIND BRACKETING INTERVAL. LOWER BOUND IS ZERO. START WITH 12614C 10 AS GUESS FOR UPPER BOUND. MULTIPLY BY 10 UNTIL 12615C BRACKETING INTERVAL FOUND. 12616C 12617 XLOW=0.0000001 12618 XUP2=10.0 12619 200 CONTINUE 12620 CALL MAKCDF(XUP2,XI,LAMBDA,THETA,PTEMP) 12621 IF(PTEMP.GT.P)THEN 12622 XUP=XUP2 12623 ELSE 12624 XUP2=XUP2*10.0 12625 IF(XUP2.GT.CPUMAX/100.)THEN 12626 WRITE(ICOUT,201) 12627 201 FORMAT('***** ERROR FROM MAKPPF--UNABLE TO FIND A ', 12628 1 'BRACKETING INTERVAL') 12629 CALL DPWRST('XXX','BUG ') 12630 GOTO9000 12631 ENDIF 12632 GOTO200 12633 ENDIF 12634C 12635 AE=1.E-6 12636 RE=1.E-6 12637 P2=P 12638 XI2=XI 12639 LAMBD2=LAMBDA 12640 THETA2=THETA 12641 CALL FZERO(MAKFU2,XLOW,XUP,XUP,RE,AE,IFLAG) 12642C 12643 PPF=XLOW 12644C 12645 IF(IFLAG.EQ.2)THEN 12646C 12647C NOTE: SUPPRESS THIS MESSAGE FOR NOW. 12648CCCCC WRITE(ICOUT,999) 12649 999 FORMAT(1X) 12650CCCCC CALL DPWRST('XXX','BUG ') 12651CCCCC WRITE(ICOUT,111) 12652CC111 FORMAT('***** WARNING FROM MAKPPF--') 12653CCCCC CALL DPWRST('XXX','BUG ') 12654CCCCC WRITE(ICOUT,113) 12655CC113 FORMAT(' PPF VALUE MAY NOT BE COMPUTED TO DESIRED ', 12656CCCCC1 'TOLERANCE.') 12657CCCCC CALL DPWRST('XXX','BUG ') 12658 ELSEIF(IFLAG.EQ.3)THEN 12659 WRITE(ICOUT,999) 12660 CALL DPWRST('XXX','BUG ') 12661 WRITE(ICOUT,121) 12662 121 FORMAT('***** WARNING FROM MAKPPF--') 12663 CALL DPWRST('XXX','BUG ') 12664 WRITE(ICOUT,123) 12665 123 FORMAT(' PPF VALUE MAY BE NEAR A SINGULAR POINT.') 12666 CALL DPWRST('XXX','BUG ') 12667 ELSEIF(IFLAG.EQ.4)THEN 12668 WRITE(ICOUT,999) 12669 CALL DPWRST('XXX','BUG ') 12670 WRITE(ICOUT,131) 12671 131 FORMAT('***** ERROR FROM MAKPPF--') 12672 CALL DPWRST('XXX','BUG ') 12673 WRITE(ICOUT,133) 12674 133 FORMAT(' APPROPRIATE BRACKETING INTERVAL NOT FOUND.') 12675 CALL DPWRST('XXX','BUG ') 12676 ELSEIF(IFLAG.EQ.5)THEN 12677 WRITE(ICOUT,999) 12678 CALL DPWRST('XXX','BUG ') 12679 WRITE(ICOUT,141) 12680 141 FORMAT('***** WARNING FROM MAKPPF--') 12681 CALL DPWRST('XXX','BUG ') 12682 WRITE(ICOUT,143) 12683 143 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') 12684 CALL DPWRST('XXX','BUG ') 12685 ENDIF 12686C 12687 9000 CONTINUE 12688 RETURN 12689 END 12690 SUBROUTINE MAKRAN(N,XI,LAMBDA,THETA,ISEED,X) 12691C 12692C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N 12693C FROM THE THE GOMPERTZ-MAKEHAM DISTIBUTION WITH 12694C LOCATION = 0 AND SCALE = 1. THIS DISTRIBUTION IS 12695C DEFINED FOR POSITIVE X AND HAS THE PROBABILITY DENSITY 12696C FUNCTION: 12697C F(X,XI,LAMBDA,THETA) = XI*LAMBDA*(THETA + EXP(LAMBDA*X)) 12698C *EXP[-XI*(EXP(LAMBDA*X) -1) - XI*THETA*LAMBDA*X) 12699C X > 0; LAMBDA, XI > 0, THETA >= 0 12700C XI, LAMBDA, AND THETA ARE SHAPE PARAMETERS. 12701C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER 12702C OF RANDOM NUMBERS TO BE 12703C GENERATED. 12704C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR 12705C (OF DIMENSION AT LEAST N) 12706C INTO WHICH THE GENERATED 12707C RANDOM SAMPLE WILL BE PLACED. 12708C --XI = A SINGLE PRECISON SCALAR THAT DEFINES 12709C THE FIRST SHAPE PARAMETER. 12710C --LAMBDA = A SINGLE PRECISON SCALAR THAT DEFINES 12711C THE SECOND SHAPE PARAMETER. 12712C --THETA = A SINGLE PRECISON SCALAR THAT DEFINES 12713C THE THIRD SHAPE PARAMETER. 12714C OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE COMPERTZ-MAKEHAM 12715C DISTRIBUTION WITH LOCATION = 0 AND SCALE = 1. 12716C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 12717C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 12718C OF N FOR THIS SUBROUTINE. 12719C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, MAKPPF. 12720C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 12721C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 12722C LANGUAGE--ANSI FORTRAN (1977) 12723C METHOD--TRANSFORM NORMAL RANDOM NUMBERS 12724C REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA", 12725C MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109. 12726C WRITTEN BY--JAMES J. FILLIBEN 12727C STATISTICAL ENGINEERING DIVISION 12728C INFORMATION TECHNOLOGY LABORATORY 12729C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 12730C GAITHERSBURG, MD 20899-8980 12731C PHONE--301-975-2855 12732C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12733C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 12734C LANGUAGE--ANSI FORTRAN (1966) 12735C VERSION NUMBER--2003.12 12736C ORIGINAL VERSION--DECEMBER 2003. 12737C 12738C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12739C 12740C--------------------------------------------------------------------- 12741C 12742 DIMENSION X(*) 12743 REAL XI 12744 REAL THETA 12745 REAL LAMBDA 12746C 12747C--------------------------------------------------------------------- 12748C 12749 INCLUDE 'DPCOP2.INC' 12750C 12751C-----START POINT----------------------------------------------------- 12752C 12753C CHECK THE INPUT ARGUMENTS FOR ERRORS 12754C 12755 IF(N.LT.1)THEN 12756 WRITE(ICOUT, 5) 12757 CALL DPWRST('XXX','BUG ') 12758 WRITE(ICOUT,47)N 12759 CALL DPWRST('XXX','BUG ') 12760 GOTO9999 12761 ELSEIF(XI.LE.0.0)THEN 12762 WRITE(ICOUT, 6) 12763 CALL DPWRST('XXX','BUG ') 12764 WRITE(ICOUT,48)XI 12765 CALL DPWRST('XXX','BUG ') 12766 GOTO9999 12767 ELSEIF(LAMBDA.LE.0.0)THEN 12768 WRITE(ICOUT, 7) 12769 CALL DPWRST('XXX','BUG ') 12770 WRITE(ICOUT,48)LAMBDA 12771 CALL DPWRST('XXX','BUG ') 12772 GOTO9999 12773 ELSEIF(THETA.LT.0.0)THEN 12774 WRITE(ICOUT,8) 12775 CALL DPWRST('XXX','BUG ') 12776 WRITE(ICOUT,48)THETA 12777 CALL DPWRST('XXX','BUG ') 12778 GOTO9999 12779 ENDIF 12780 5 FORMAT('***** FATAL ERROR--THE FIRST (N) INPUT ARGUMENT TO THE ', 12781 1'MAKRAN SUBROUTINE IS NON-POSITIVE *****') 12782 6 FORMAT('***** FATAL ERROR--THE SECOND (XI) INPUT ARGUMENT TO ', 12783 1'THE MAKRAN SUBROUTINE IS NON-POSITIVE *****') 12784 7 FORMAT('***** FATAL ERROR--THE THIRD (LAMBDA) INPUT ARGUMENT ', 12785 1'TO THE MAKRAN SUBROUTINE IS NON-POSITIVE *****') 12786 8 FORMAT('***** FATAL ERROR--THE FOURTH (THETA) INPUT ARGUMENT ', 12787 1'TO THE MAKRAN SUBROUTINE IS NEGATIVE *****') 12788 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') 12789 48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',F15.7,' *****') 12790C 12791C GENERATE N UNIFORM NUMBERS; 12792C 12793 CALL UNIRAN(N,ISEED,X) 12794C 12795C GENERATE N GOMPERTZ-MAKEHAM RANDON NUMBERS USING THE 12796C PERCENT POINT FUNCTION TRANSFORMATION. 12797C 12798 DO100I=1,N 12799 XTEMP=X(I) 12800 CALL MAKPPF(XTEMP,XI,LAMBDA,THETA,PPF) 12801 X(I)=PPF 12802 100 CONTINUE 12803C 12804 9999 CONTINUE 12805 RETURN 12806 END 12807 SUBROUTINE MA2CDF(X,ZETA,ETA,CDF) 12808C 12809C THIS SUBROUTINE COMPUTES THE GOMPERTZ-MAKEHAM CUMULATIVE 12810C DISTRIBUTION FUNCTION. THIS USES THE MEEKER AND ESCOBAR 12811C PARAMETERIZATION (THIS TAKES THE 3-SHAPE PARAMETER CASE AND 12812C RE-PARAMETERRIZES IT TO 2-SHAPE PARAMETERS AND A SCALE 12813C PARAMETER. IT HAS THE FOLLOWING CDF: 12814C F(X,ZETA,ETA) = 1 - EXP[C1 - EXP(C2) - C3] 12815C X, > 0; ETA >= 0 12816C WITH 12817C C1 = EXP(-ZETA) 12818C C2 = EXP(LOG(X)) - ZETA 12819C = X - ZETA 12820C C3 = ETA*EXP(LOG(X)) 12821C = ETA*X 12822C 12823C PUTTING THIS TOGETHER GIVES 12824C F(X,ZETA,ETA) = 1 - EXP[EXP(-ZETA) - EXP(X-ZETA) - ETA*X] 12825C X, > 0; ETA >= 0 12826C 12827C WRITTEN BY--JAMES J. FILLIBEN 12828C STATISTICAL ENGINEERING DIVISION 12829C INFORMATION TECHNOLOGY LABORATORY 12830C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 12831C GAITHERSBURG, MD 20899-8980 12832C PHONE--301-975-2855 12833C REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA", 12834C MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109. 12835C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12836C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 12837C LANGUAGE--ANSI FORTRAN (1977) 12838C VERSION NUMBER--2004/7 12839C ORIGINAL VERSION--JULY 2004. 12840C 12841C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12842C 12843 REAL ZETA 12844 REAL ETA 12845C 12846 DOUBLE PRECISION DCDF 12847 DOUBLE PRECISION DETA 12848 DOUBLE PRECISION DZETA 12849 DOUBLE PRECISION DX 12850 DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4 12851C 12852C--------------------------------------------------------------------- 12853C 12854 INCLUDE 'DPCOP2.INC' 12855C 12856C-----START POINT----------------------------------------------------- 12857C 12858 CDF=0.0 12859 IF(X.LE.0.0)GOTO9000 12860CCCCC IF(ETA.LE.0.0)THEN 12861CCCCC WRITE(ICOUT,101) 12862CCCCC CALL DPWRST('XXX','BUG ') 12863CCCCC WRITE(ICOUT,102)ETA 12864CCCCC CALL DPWRST('XXX','BUG ') 12865CCCCC GOTO9000 12866CCCCC ENDIF 12867 IF(ETA.LT.0.0)THEN 12868 WRITE(ICOUT,106) 12869 CALL DPWRST('XXX','BUG ') 12870 WRITE(ICOUT,107)ZETA 12871 CALL DPWRST('XXX','BUG ') 12872 GOTO9000 12873 ENDIF 12874CC101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER (ETA) TO MA2CDF') 12875CC102 FORMAT(' IS NON-POSITIVE. IT HAS THE VALUE ',E15.7) 12876 106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (ZETA) TO') 12877 107 FORMAT(' MAKCDF IS NEGATIVE. IT HAS THE VALUE ',E15.7) 12878C 12879 DX=DBLE(X) 12880 DETA=DBLE(ETA) 12881 DZETA=DBLE(ZETA) 12882C 12883 DTERM1=DEXP(-DZETA) 12884 DTERM2=DEXP(DX - DZETA) 12885 DTERM3=DETA*DX 12886 DTERM4=DTERM1 - DTERM2 - DTERM3 12887C 12888 IF(DTERM4.LE.-80.D0)THEN 12889 CDF=1.0 12890 ELSEIF(DTERM4.GE.80.D0)THEN 12891 CDF=0.0 12892 WRITE(ICOUT,401) 12893 CALL DPWRST('XXX','BUG ') 12894 ELSE 12895 DCDF=1.0D0 - DEXP(DTERM4) 12896 CDF=REAL(DCDF) 12897 ENDIF 12898 401 FORMAT('***** NON-FATAL DIAGNOSTIC FROM MAKCDF. THE ', 12899 1'COMPUTED CDF VALUE EXCEEDS MACHINE PRECISION.') 12900C 12901 9000 CONTINUE 12902 RETURN 12903 END 12904 REAL FUNCTION MA2FU2(X) 12905C 12906C PURPOSE--MA2PPF CALLS FZERO TO FIND A ROOT FOR THE PERCENT 12907C POINT FUNCTION. MA2FU2 IS THE FUNCTION FOR WHICH 12908C THE ZERO IS FOUND. IT IS: 12909C P - MA2CDF(X,ZETA,ETA) 12910C WHERE P IS THE DESIRED PERCENT POINT. 12911C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT 12912C WHICH THE CUMULATIVE DISTRIBUTION 12913C FUNCTION IS TO BE EVALUATED. 12914C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY 12915C FUNCTION VALUE MA2FU2. 12916C PRINTING--NONE. 12917C RESTRICTIONS--NONE. 12918C OTHER DATAPAC SUBROUTINES NEEDED--MA2CDF. 12919C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 12920C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 12921C LANGUAGE--ANSI FORTRAN (1977) 12922C REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA", 12923C MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109. 12924C WRITTEN BY--JAMES J. FILLIBEN 12925C STATISTICAL ENGINEERING DIVISION 12926C INFORMATION TECHNOLOGY LABORATORY 12927C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY 12928C GAITHERSBURG, MD 20899-8980 12929C PHONE--301-975-2855 12930C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12931C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. 12932C LANGUAGE--ANSI FORTRAN (1977) 12933C VERSION NUMBER--2004.7 12934C ORIGINAL VERSION--JULY 2004. 12935C 12936C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12937C 12938C--------------------------------------------------------------------- 12939C 12940 REAL P 12941 COMMON/MA4COM/P 12942C 12943 REAL ETA 12944 REAL ZETA 12945 COMMON/MA3COM/ETA,ZETA 12946C 12947 INCLUDE 'DPCOP2.INC' 12948C 12949C-----START POINT----------------------------------------------------- 12950C 12951 CALL MA2CDF(X,ZETA,ETA,CDF) 12952 MA2FU2=P - CDF 12953 RETURN 12954 END 12955 SUBROUTINE MA2CHA(X,ZETA,ETA,CHAZ) 12956C 12957C THIS SUBROUTINE COMPUTES THE GOMPERTZ-MAKEHAM CUMULATIVE 12958C HAZARD FUNCTION. THIS USES THE MEEKER AND ESCOBAR 12959C PARAMETERIZATION (THIS TAKES THE 3-SHAPE PARAMETER CASE AND 12960C RE-PARAMETERRIZES IT TO 2-SHAPE PARAMETERS AND A SCALE 12961C PARAMETER. IT HAS THE FOLLOWING CDF: 12962C F(X,ZETA,ETA) = 1 - 12963C EXP[EXP(-ZETA) - EXP(X - ZETA) - ETA*X] 12964C X, > 0; ETA >= 0 12965C THE CUMULATIVE HAZARD IS: 12966C H(X,ZETA,ETA) = -LOG(1 - F(X,ZETA,ETA)) 12967C = -EXP(-ZETA) + EXP(X-ZETA) + ETA*X 12968C 12969C WRITTEN BY--JAMES J. FILLIBEN 12970C STATISTICAL ENGINEERING DIVISION 12971C INFORMATION TECHNOLOGY LABORATORY 12972C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 12973C GAITHERSBURG, MD 20899-8980 12974C PHONE--301-975-2855 12975C REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA", 12976C MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109. 12977C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 12978C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 12979C LANGUAGE--ANSI FORTRAN (1977) 12980C VERSION NUMBER--2004/7 12981C ORIGINAL VERSION--JULY 2004. 12982C 12983C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 12984C 12985 REAL ZETA 12986 REAL ETA 12987C 12988 DOUBLE PRECISION DETA 12989 DOUBLE PRECISION DZETA 12990 DOUBLE PRECISION DX 12991 DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4 12992C 12993C--------------------------------------------------------------------- 12994C 12995 INCLUDE 'DPCOP2.INC' 12996C 12997C-----START POINT----------------------------------------------------- 12998C 12999 CHAZ=0.0 13000 IF(X.LE.0.0)GOTO9000 13001 IF(ETA.LT.0.0)THEN 13002 WRITE(ICOUT,106) 13003 CALL DPWRST('XXX','BUG ') 13004 WRITE(ICOUT,107)ETA 13005 CALL DPWRST('XXX','BUG ') 13006 GOTO9000 13007 ENDIF 13008 106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (ETA) TO') 13009 107 FORMAT(' MAKCHAZ IS NEGATIVE. IT HAS THE VALUE ',E15.7) 13010C 13011 DX=DBLE(X) 13012 DETA=DBLE(ETA) 13013 DZETA=DBLE(ZETA) 13014C 13015 DTERM1=DEXP(-DZETA) 13016 DTERM2=DEXP(DX - DZETA) 13017 DTERM3=DETA*DX 13018 DTERM4=DTERM1 - DTERM2 - DTERM3 13019 CHAZ=-REAL(DTERM4) 13020C 13021 9000 CONTINUE 13022 RETURN 13023 END 13024 SUBROUTINE MA2HAZ(X,ZETA,ETA,HAZ) 13025C 13026C THIS SUBROUTINE COMPUTES THE GOMPERTZ-MAKEHAM HAZARD 13027C FUNCTION. THIS USES THE MEEKER AND ESCOBAR 13028C PARAMETERIZATION (THIS TAKES THE 3-SHAPE PARAMETER CASE AND 13029C RE-PARAMETERRIZES IT TO 2-SHAPE PARAMETERS AND A SCALE 13030C PARAMETER. IT HAS THE FOLLOWING HAZARD FUNCTION: 13031C h(X,ZETA,ETA) = ETA + EXP(-ZETA)*EXP(X) 13032C X, ETA >= 0 13033C WRITTEN BY--JAMES J. FILLIBEN 13034C STATISTICAL ENGINEERING DIVISION 13035C INFORMATION TECHNOLOGY LABORATORY 13036C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13037C GAITHERSBURG, MD 20899-8980 13038C PHONE--301-975-2855 13039C REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA", 13040C MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109. 13041C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13042C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13043C LANGUAGE--ANSI FORTRAN (1977) 13044C VERSION NUMBER--2004/7 13045C ORIGINAL VERSION--JULY 2004. 13046C 13047C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13048C 13049 REAL ZETA 13050 REAL ETA 13051C 13052 DOUBLE PRECISION DHAZ 13053 DOUBLE PRECISION DETA 13054 DOUBLE PRECISION DZETA 13055 DOUBLE PRECISION DX 13056C 13057C--------------------------------------------------------------------- 13058C 13059 INCLUDE 'DPCOP2.INC' 13060C 13061C-----START POINT----------------------------------------------------- 13062C 13063 HAZ=0.0 13064 IF(X.LE.0.0)THEN 13065 WRITE(ICOUT,103) 13066 CALL DPWRST('XXX','BUG ') 13067 WRITE(ICOUT,104)X 13068 CALL DPWRST('XXX','BUG ') 13069 GOTO9000 13070 ENDIF 13071 IF(ETA.LT.0.0)THEN 13072 WRITE(ICOUT,106) 13073 CALL DPWRST('XXX','BUG ') 13074 WRITE(ICOUT,107)ETA 13075 CALL DPWRST('XXX','BUG ') 13076 GOTO9000 13077 ENDIF 13078 103 FORMAT('***** ERROR--THE INPUT ARGUMENT TO MA2HAZ IS') 13079 104 FORMAT(' NON-POSITIVE. IT HAS THE VALUE ',E15.7) 13080 106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (ETA) TO') 13081 107 FORMAT(' MAKHAZ IS NEGATIVE. IT HAS THE VALUE ',E15.7) 13082C 13083 DX=DBLE(X) 13084 DETA=DBLE(ETA) 13085 DZETA=DBLE(ZETA) 13086C 13087 DHAZ=DETA + DEXP(-DZETA)*DEXP(DX) 13088 HAZ=REAL(DHAZ) 13089C 13090 9000 CONTINUE 13091 RETURN 13092 END 13093 SUBROUTINE MA2PDF(X,ZETA,ETA,PDF) 13094C 13095C THIS SUBROUTINE COMPUTES THE GOMPERTZ-MAKEHAM PROBABILITY 13096C DENSITY FUNCTION. THIS USES THE MEEKER AND ESCOBAR 13097C PARAMETERIZATION (THIS TAKES THE 3-SHAPE PARAMETER CASE AND 13098C RE-PARAMETERRIZES IT TO 2-SHAPE PARAMETERS AND A SCALE 13099C PARAMETER. IT HAS THE FOLLOWING PROBABILITY DENSITY FUNCTION: 13100C f(X,ZETA,ETA) = (ETA + EXP(X-ZETA))* 13101C EXP[EXP(-ZETA)-EXP(X-ZETA)-ETA*X] 13102C X, ETA > 0 13103C WRITTEN BY--JAMES J. FILLIBEN 13104C STATISTICAL ENGINEERING DIVISION 13105C INFORMATION TECHNOLOGY LABORATORY 13106C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13107C GAITHERSBURG, MD 20899-8980 13108C PHONE--301-975-2855 13109C REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA", 13110C MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109. 13111C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13112C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13113C LANGUAGE--ANSI FORTRAN (1977) 13114C VERSION NUMBER--2004/7 13115C ORIGINAL VERSION--JULY 2004. 13116C 13117C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13118C 13119 REAL ZETA 13120 REAL ETA 13121C 13122 DOUBLE PRECISION DPDF 13123 DOUBLE PRECISION DETA 13124 DOUBLE PRECISION DZETA 13125 DOUBLE PRECISION DX 13126 DOUBLE PRECISION DTERM1 13127 DOUBLE PRECISION DTERM2 13128C 13129C--------------------------------------------------------------------- 13130C 13131 INCLUDE 'DPCOP2.INC' 13132C 13133C-----START POINT----------------------------------------------------- 13134C 13135 PDF=0.0 13136 IF(X.LE.0.0)THEN 13137 WRITE(ICOUT,103) 13138 CALL DPWRST('XXX','BUG ') 13139 WRITE(ICOUT,104)X 13140 CALL DPWRST('XXX','BUG ') 13141 GOTO9000 13142 ENDIF 13143CCCCC IF(ZETA.LE.0.0)THEN 13144CCCCC WRITE(ICOUT,101) 13145CCCCC CALL DPWRST('XXX','BUG ') 13146CCCCC WRITE(ICOUT,102)ZETA 13147CCCCC CALL DPWRST('XXX','BUG ') 13148CCCCC GOTO9000 13149CCCCC ENDIF 13150 IF(ETA.LT.0.0)THEN 13151 WRITE(ICOUT,106) 13152 CALL DPWRST('XXX','BUG ') 13153 WRITE(ICOUT,107)ETA 13154 CALL DPWRST('XXX','BUG ') 13155 GOTO9000 13156 ENDIF 13157 103 FORMAT('***** ERROR--THE INPUT ARGUMENT TO MA2PDF IS') 13158 104 FORMAT(' NON-POSITIVE. IT HAS THE VALUE ',E15.7) 13159 106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (ETA) TO') 13160 107 FORMAT(' MAKPDF IS NEGATIVE. IT HAS THE VALUE ',E15.7) 13161C 13162 DX=DBLE(X) 13163 DZETA=DBLE(ZETA) 13164 DETA=DBLE(ETA) 13165C 13166 DTERM1=DETA + EXP(DX-DZETA) 13167 DTERM2=DEXP(-DZETA) - DEXP(DX-DZETA) - DETA*DX 13168 DPDF=DTERM1*DEXP(DTERM2) 13169 PDF=REAL(DPDF) 13170C 13171 9000 CONTINUE 13172 RETURN 13173 END 13174 SUBROUTINE MA2PPF(P,ZETA,ETA,PPF) 13175C 13176C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT 13177C FUNCTION VALUE FOR THE GOMPERTZ-MAKEHAM DISTRIBUTION 13178C WITH SHAPE PARAMETERS ETA AND ZETA. 13179C THIS DISTRIBUTION IS DEFINED FOR POSITIVE X AND THE 13180C PERCENT POINT FUNCTION IS COMPUTED BY 13181C NUMERICALLY INVERTING THE CDF FUNCTION. 13182C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE AT 13183C WHICH THE PERCENT POINT 13184C FUNCTION IS TO BE EVALUATED. 13185C --ZETA l = THE FIRST SHAPE PARAMETER 13186C --ETA = THE SECOND SHAPE PARAMETER 13187C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION CUMULATIVE 13188C DISTRIBUTION FUNCTION VALUE. 13189C OUTPUT--THE SINGLE PRECISION PERCENT POINT 13190C FUNCTION VALUE PPF. 13191C PRINTING--NONE. 13192C RESTRICTIONS--NONE. 13193C OTHER DATAPAC SUBROUTINES NEEDED--FZERO. 13194C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 13195C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 13196C LANGUAGE--ANSI FORTRAN (1977) 13197C REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA", 13198C MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109. 13199C WRITTEN BY--JAMES J. FILLIBEN 13200C STATISTICAL ENGINEERING DIVISION 13201C INFORMATION TECHNOLOGY LABORATORY 13202C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY 13203C GAITHERSBURG, MD 20899-8980 13204C PHONE--301-975-2855 13205C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13206C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. 13207C LANGUAGE--ANSI FORTRAN (1977) 13208C VERSION NUMBER--2004.7 13209C ORIGINAL VERSION--JULY 2004. 13210C 13211C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13212C 13213C--------------------------------------------------------------------- 13214C 13215 REAL ETA 13216 REAL ZETA 13217 REAL PPF 13218C 13219 REAL MA2FU2 13220 EXTERNAL MA2FU2 13221C 13222 REAL P2 13223 COMMON/MA4COM/P2 13224C 13225 REAL ETA2 13226 REAL ZETA2 13227 COMMON/MA3COM/ETA2,ZETA2 13228C 13229 INCLUDE 'DPCOP2.INC' 13230C 13231C-----START POINT----------------------------------------------------- 13232C 13233C ******************************************** 13234C ** STEP 1-- ** 13235C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 13236C ******************************************** 13237C 13238 PPF=0.0 13239C 13240 IF(P.LE.0.0.OR.P.GE.1.0)THEN 13241 WRITE(ICOUT,61) 13242 61 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 13243 1 'TO THE MA2PPF SUBROUTINE ') 13244 CALL DPWRST('XXX','BUG ') 13245 WRITE(ICOUT,62) 13246 62 FORMAT(' IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL ***') 13247 CALL DPWRST('XXX','BUG ') 13248 WRITE(ICOUT,63)P 13249 63 FORMAT(' VALUE OF ARGUMENT = ',G15.7) 13250 CALL DPWRST('XXX','BUG ') 13251 PPF=0.0 13252 GOTO9000 13253 ENDIF 13254C 13255 IF(ETA.LT.0.0)THEN 13256 WRITE(ICOUT,106) 13257 CALL DPWRST('XXX','BUG ') 13258 WRITE(ICOUT,107)ETA 13259 CALL DPWRST('XXX','BUG ') 13260 GOTO9000 13261 ENDIF 13262 106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (ETA) TO') 13263 107 FORMAT(' MAKPPF IS NEGATIVE. IT HAS THE VALUE ',E15.7) 13264C 13265C STEP 1: FIND BRACKETING INTERVAL. LOWER BOUND IS ZERO. START WITH 13266C 10 AS GUESS FOR UPPER BOUND. MULTIPLY BY 10 UNTIL 13267C BRACKETING INTERVAL FOUND. 13268C 13269 XLOW=0.0000001 13270 XUP2=10.0 13271 200 CONTINUE 13272 CALL MA2CDF(XUP2,ZETA,ETA,PTEMP) 13273 IF(PTEMP.GT.P)THEN 13274 XUP=XUP2 13275 ELSE 13276 XUP2=XUP2*10.0 13277 IF(XUP2.GT.CPUMAX/100.)THEN 13278 WRITE(ICOUT,201) 13279 201 FORMAT('***** ERROR FROM MA2PPF--UNABLE TO FIND A ', 13280 1 'BRACKETING INTERVAL') 13281 CALL DPWRST('XXX','BUG ') 13282 GOTO9000 13283 ENDIF 13284 GOTO200 13285 ENDIF 13286C 13287 AE=1.E-6 13288 RE=1.E-6 13289 P2=P 13290 ETA2=ETA 13291 ZETA2=ZETA 13292 CALL FZERO(MA2FU2,XLOW,XUP,XUP,RE,AE,IFLAG) 13293C 13294 PPF=XLOW 13295C 13296 IF(IFLAG.EQ.2)THEN 13297C 13298C NOTE: SUPPRESS THIS MESSAGE FOR NOW. 13299CCCCC WRITE(ICOUT,999) 13300 999 FORMAT(1X) 13301CCCCC CALL DPWRST('XXX','BUG ') 13302CCCCC WRITE(ICOUT,111) 13303CC111 FORMAT('***** WARNING FROM MA2PPF--') 13304CCCCC CALL DPWRST('XXX','BUG ') 13305CCCCC WRITE(ICOUT,113) 13306CC113 FORMAT(' PPF VALUE MAY NOT BE COMPUTED TO DESIRED ', 13307CCCCC1 'TOLERANCE.') 13308CCCCC CALL DPWRST('XXX','BUG ') 13309 ELSEIF(IFLAG.EQ.3)THEN 13310 WRITE(ICOUT,999) 13311 CALL DPWRST('XXX','BUG ') 13312 WRITE(ICOUT,121) 13313 121 FORMAT('***** WARNING FROM MAKPPF--') 13314 CALL DPWRST('XXX','BUG ') 13315 WRITE(ICOUT,123) 13316 123 FORMAT(' PPF VALUE MAY BE NEAR A SINGULAR POINT.') 13317 CALL DPWRST('XXX','BUG ') 13318 ELSEIF(IFLAG.EQ.4)THEN 13319 WRITE(ICOUT,999) 13320 CALL DPWRST('XXX','BUG ') 13321 WRITE(ICOUT,131) 13322 131 FORMAT('***** ERROR FROM MAKPPF--') 13323 CALL DPWRST('XXX','BUG ') 13324 WRITE(ICOUT,133) 13325 133 FORMAT(' APPROPRIATE BRACKETING INTERVAL NOT FOUND.') 13326 CALL DPWRST('XXX','BUG ') 13327 ELSEIF(IFLAG.EQ.5)THEN 13328 WRITE(ICOUT,999) 13329 CALL DPWRST('XXX','BUG ') 13330 WRITE(ICOUT,141) 13331 141 FORMAT('***** WARNING FROM MAKPPF--') 13332 CALL DPWRST('XXX','BUG ') 13333 WRITE(ICOUT,143) 13334 143 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') 13335 CALL DPWRST('XXX','BUG ') 13336 ENDIF 13337C 13338 9000 CONTINUE 13339 RETURN 13340 END 13341 SUBROUTINE MA2RAN(N,ZETA,ETA,ISEED,X) 13342C 13343C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N 13344C FROM THE THE GOMPERTZ-MAKEHAM DISTIBUTION WITH 13345C LOCATION = 0 AND SCALE = 1. THIS DISTRIBUTION IS 13346C DEFINED FOR POSITIVE X AND HAS THE PROBABILITY DENSITY 13347C FUNCTION: 13348C f(X,ETA,ZETA) = (1/X)*EXP(LOG(X))* 13349C [ZETA + EXP[EXP(LOG(X)) - ETA]* 13350C [1 - MA2CDF(X,ETA,ZETA)] 13351C X, ZETA > 0 13352C WHERE MA2CDF IS: 13353C F(X,ETA,ZETA) = 1 - EXP[C1 - EXP(C2) - C3] 13354C X, ZETA > 0 13355C WITH 13356C C1 = EXP(-ETA) 13357C C2 = EXP(LOG(X) - ETA) 13358C C3 = ZETA*EXP(LOG(X)) 13359C 13360C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER 13361C OF RANDOM NUMBERS TO BE 13362C GENERATED. 13363C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR 13364C (OF DIMENSION AT LEAST N) 13365C INTO WHICH THE GENERATED 13366C RANDOM SAMPLE WILL BE PLACED. 13367C --ETA = A SINGLE PRECISON SCALAR THAT DEFINES 13368C THE FIRST SHAPE PARAMETER. 13369C --ZETA = A SINGLE PRECISON SCALAR THAT DEFINES 13370C THE SECOND SHAPE PARAMETER. 13371C OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE COMPERTZ-MAKEHAM 13372C DISTRIBUTION WITH LOCATION = 0 AND SCALE = 1. 13373C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EETASTS. 13374C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAETAMUM VALUE 13375C OF N FOR THIS SUBROUTINE. 13376C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, MA2PPF. 13377C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 13378C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 13379C LANGUAGE--ANSI FORTRAN (1977) 13380C METHOD--TRANSFORM NORMAL RANDOM NUMBERS 13381C REFERENCE--"STATISTICAL METHODS FOR RELIABILITY DATA", 13382C MEEKER AND ESCOBAR, WILEY, 1998, PP. 108-109. 13383C WRITTEN BY--JAMES J. FILLIBEN 13384C STATISTICAL ENGINEERING DIVISION 13385C INFORMATION TECHNOLOGY LABORATORY 13386C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13387C GAITHERSBURG, MD 20899-8980 13388C PHONE--301-975-2855 13389C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13390C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13391C LANGUAGE--ANSI FORTRAN (1977) 13392C VERSION NUMBER--2004.7 13393C ORIGINAL VERSION--JULY 2004. 13394C 13395C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13396C 13397C--------------------------------------------------------------------- 13398C 13399 DIMENSION X(*) 13400 REAL ETA 13401 REAL ZETA 13402C 13403C--------------------------------------------------------------------- 13404C 13405 INCLUDE 'DPCOP2.INC' 13406C 13407C-----START POINT----------------------------------------------------- 13408C 13409C CHECK THE INPUT ARGUMENTS FOR ERRORS 13410C 13411 IF(N.LT.1)THEN 13412 WRITE(ICOUT, 5) 13413 CALL DPWRST('XXX','BUG ') 13414 WRITE(ICOUT, 6) 13415 CALL DPWRST('XXX','BUG ') 13416 WRITE(ICOUT,47)N 13417 CALL DPWRST('XXX','BUG ') 13418 GOTO9999 13419 ELSEIF(ZETA.LT.0.0)THEN 13420 WRITE(ICOUT,106) 13421 CALL DPWRST('XXX','BUG ') 13422 WRITE(ICOUT,107) 13423 CALL DPWRST('XXX','BUG ') 13424 WRITE(ICOUT,48)ZETA 13425 CALL DPWRST('XXX','BUG ') 13426 GOTO9999 13427 ENDIF 13428 106 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (ZETA) TO THE') 13429 107 FORMAT(' GOMPERTZ MAKEHAM RANDOM NUMBERS ROUTINE IS ', 13430 1 'NON-POSITIVE.') 13431 5 FORMAT('***** THE REQUESTED NUMBER OF RANDOM NUMBERS FOR THE') 13432 6 FORMAT(' GOMPERTZ-MAKEHAM DISTRIBUTION IS NON-POSITIVE.') 13433 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 13434 48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',F15.7) 13435C 13436C GENERATE N UNIFORM NUMBERS; 13437C 13438 CALL UNIRAN(N,ISEED,X) 13439C 13440C GENERATE N GOMPERTZ-MAKEHAM RANDON NUMBERS USING THE 13441C PERCENT POINT FUNCTION TRANSFORMATION. 13442C 13443 DO100I=1,N 13444 XTEMP=X(I) 13445 CALL MA2PPF(XTEMP,ZETA,ETA,PPF) 13446 X(I)=PPF 13447 100 CONTINUE 13448C 13449 9999 CONTINUE 13450 RETURN 13451 END 13452 SUBROUTINE MANDIS(X,Y,N,IWRITE,STATVA,IBUGA3,ISUBRO,IERROR) 13453C 13454C PURPOSE--THIS SUBROUTINE COMPUTES THE MANHATTAN DISTANCE BETWEEN THE 13455C TWO SETS OF DATA IN THE INPUT VECTORS X AND Y. THE 13456C SAMPLE MANHATTAN DISTANCE WILL BE A SINGLE PRECISION VALUE 13457C CALCULATED AS: 13458C 13459C DISTANCE = SUM[i=1 to n][|X(i) - Y(i)|] 13460C 13461C THIS IS EQUIVALENT TO A MINKOWSKY DISTANCE WITH 13462C P = 1 AND IS ALSO KNOWN CITY BLOCK OR TAXI-CAB 13463C DISTANCE. 13464C 13465C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 13466C (UNSORTED) OBSERVATIONS WHICH 13467C CONSTITUTE THE FIRST SET OF DATA. 13468C --Y = THE SINGLE PRECISION VECTOR OF 13469C (UNSORTED) OBSERVATIONS WHICH 13470C CONSTITUTE THE SECOND SET OF DATA. 13471C --N = THE INTEGER NUMBER OF OBSERVATIONS 13472C IN THE VECTORS X AND Y. 13473C OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE 13474C COMPUTED SAMPLE COSINE DISTANCE 13475C BETWEEN THE TWO SETS OF DATA IN THE 13476C INPUT VECTORS X AND Y. THIS SINGLE 13477C PRECISION VALUE WILL BE BETWEEN 0.0 13478C AND 1.0 (INCLUSIVELY). 13479C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE 13480C SAMPLE MANHATTAN DISTANCE BETWEEN THE 2 SETS 13481C OF DATA IN THE INPUT VECTORS X AND Y. 13482C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 13483C OF N FOR THIS SUBROUTINE. 13484C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 13485C FORTRAN LIBRARY SUBROUTINES NEEDED--ABS. 13486C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 13487C LANGUAGE--ANSI FORTRAN (1977) 13488C REFERENCES--XXX 13489C WRITTEN BY--ALAN HECKERT 13490C STATISTICAL ENGINEERING DIVISION 13491C INFORMATION TECHNOLOGY LABORATORY 13492C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 13493C GAITHERSBURG, MD 20899 13494C PHONE--301-975-2899 13495C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13496C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 13497C LANGUAGE--ANSI FORTRAN (1977) 13498C VERSION NUMBER--2017/03 13499C ORIGINAL VERSION--MARCH 2017. 13500C 13501C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13502C 13503 CHARACTER*4 IWRITE 13504 CHARACTER*4 IBUGA3 13505 CHARACTER*4 ISUBRO 13506 CHARACTER*4 IERROR 13507C 13508 CHARACTER*4 ISUBN1 13509 CHARACTER*4 ISUBN2 13510C 13511C--------------------------------------------------------------------- 13512C 13513 DIMENSION X(*) 13514 DIMENSION Y(*) 13515C 13516C--------------------------------------------------------------------- 13517C 13518 INCLUDE 'DPCOP2.INC' 13519C 13520C-----START POINT----------------------------------------------------- 13521C 13522 ISUBN1='MAND' 13523 ISUBN2='IS ' 13524 IERROR='NO' 13525 STATVA=CPUMIN 13526C 13527 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NDIS')THEN 13528 WRITE(ICOUT,999) 13529 999 FORMAT(1X) 13530 CALL DPWRST('XXX','BUG ') 13531 WRITE(ICOUT,51) 13532 51 FORMAT('***** AT THE BEGINNING OF MANDIS--') 13533 CALL DPWRST('XXX','BUG ') 13534 WRITE(ICOUT,52)IBUGA3,ISUBRO,N 13535 52 FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8) 13536 CALL DPWRST('XXX','BUG ') 13537 DO55I=1,N 13538 WRITE(ICOUT,56)I,X(I),Y(I) 13539 56 FORMAT('I,X(I),Y(I) = ',I8,2G15.7) 13540 CALL DPWRST('XXX','BUG ') 13541 55 CONTINUE 13542 ENDIF 13543C 13544C ******************************************** 13545C ** STEP 1-- ** 13546C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 13547C ******************************************** 13548C 13549 AN=N 13550C 13551 IF(N.LT.1)THEN 13552 WRITE(ICOUT,999) 13553 CALL DPWRST('XXX','BUG ') 13554 WRITE(ICOUT,111) 13555 111 FORMAT('***** ERROR IN MANHATTAN DISTANCE--') 13556 CALL DPWRST('XXX','BUG ') 13557 WRITE(ICOUT,112) 13558 112 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE RESPONSE') 13559 CALL DPWRST('XXX','BUG ') 13560 WRITE(ICOUT,113) 13561 113 FORMAT(' VARIABLES IS LESS THAN 1.') 13562 CALL DPWRST('XXX','BUG ') 13563 WRITE(ICOUT,117)N 13564 117 FORMAT(' THE NUMBER OF OBSERVATIONS HERE = ',I8,'.') 13565 CALL DPWRST('XXX','BUG ') 13566 IERROR='YES' 13567 GOTO9000 13568 ENDIF 13569C 13570C ************************************************ 13571C ** STEP 2-- ** 13572C ** COMPUTE THE MANHATTAN DISTANCE. ** 13573C ************************************************ 13574C 13575 STATVA=0.0 13576 DO200I=1,N 13577 STATVA=STATVA + ABS(X(I) - Y(I)) 13578 200 CONTINUE 13579C 13580C ******************************* 13581C ** STEP 3-- ** 13582C ** WRITE OUT A LINE ** 13583C ** OF SUMMARY INFORMATION. ** 13584C ******************************* 13585C 13586 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 13587 WRITE(ICOUT,999) 13588 CALL DPWRST('XXX','BUG ') 13589 WRITE(ICOUT,811)N,STATVA 13590 811 FORMAT('THE MANHATTAN DISTANCE OF THE ',I8, 13591 1 ' OBSERVATIONS = ',G15.7) 13592 CALL DPWRST('XXX','BUG ') 13593 ENDIF 13594C 13595C ***************** 13596C ** STEP 90-- ** 13597C ** EXIT. ** 13598C ***************** 13599C 13600 9000 CONTINUE 13601 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NDIS')THEN 13602 WRITE(ICOUT,999) 13603 CALL DPWRST('XXX','BUG ') 13604 WRITE(ICOUT,9011) 13605 9011 FORMAT('***** AT THE END OF MANDIS--') 13606 CALL DPWRST('XXX','BUG ') 13607 WRITE(ICOUT,9012)IERROR,STATVA 13608 9012 FORMAT('IERROR,STATVA = ',A4,2X,G15.7) 13609 CALL DPWRST('XXX','BUG ') 13610 ENDIF 13611C 13612 RETURN 13613 END 13614 SUBROUTINE MATARI(YM1,NR1,NC1,YM2,NR2,NC2,NR3,NC3,MAXROM,MAXCOM, 13615CCCCC JANUARY 1998. RECODE TO USE LESS MATRICES. 13616CCCCC SUBROUTINE MATARI(YM1,NR1,NC1,YM2,NR2,NC2,YM3,NR3,NC3, 13617 1Y1,N1,Y2,N2,Y3,N3,Y4,N4, 13618 1INDEX,IZROV,IPOSV, 13619 1DMEAN,DSSQD,P1,P2,BETA, 13620 1YS1,YS2,YS3,YS4, 13621 1IMCASE,IUPFLG,IMSUBC,ITYPA1,ITYPA2,ITYPA3,ITYPA4,NUMVAR,IWRITE, 13622 1YM9,NR9,NC9,VECT9,NVECT9,SCAL9,ITYP9, 13623CCCCC AUGUST 1993. 13624CCCCC JANUARY 1998. RECODE TO USE LESS MATRICES. 13625CCCCC1YMJUNK,YMJUN2, 13626 1IBUGA3,ISUBRO,IERROR) 13627C 13628C PURPOSE--CARRY OUT MATRIX ARITHMETIC OPERATIONS 13629C OF THE REAL DATA IN MATRICES YM1 AND YM2. 13630C 13631C OPERATIONS--ADDITION 13632C SUBTRACTION 13633C MULTIPLICATION 13634C TRUNCATION 13635C 13636C NUMBER OF ROWS 13637C NUMBER OF COLUMNS 13638C ROW 13639C ELEMENT 13640C REPLACE ROW 13641C REPLACE ELEMENT 13642C DIAGONAL 13643C 13644C SOLUTION 13645C ITERATIVE SOLUTION 13646C TRIDIAGONAL SOLVE 13647C TRIANGULAR SOLVE 13648C SIMPLEX SOLUTION 13649C RANK 13650C 13651C CONDITION NUMBER 13652C RECIPROCAL CONDITION NUMBER 13653C INVERSE 13654C TRIANGULAR INVERSE 13655C DETERMINANT 13656C TRACE 13657C PERMANENT 13658C ADJOINT 13659C SUBMATRIX 13660C MINOR 13661C COFACTOR 13662C 13663C DEFINITION 13664C AUGMENT 13665C TRANSPOSE 13666C 13667C CHARACTERISTIC EQUATION (NOT YET IMPLEMENED) 13668C 13669C EIGENVALUES 13670C EIGENVECTORS 13671C SINGULAR VALUE 13672C SINGULAR VALUE DECOMPOSITION 13673C CHOLESKY DECOMPOSITION 13674C SPECTRAL NORM 13675C SPECTRAL RADIUS 13676C EUCLIDEAN NORM 13677C 13678C VARIANCE-COVARIANCE MATRIX 13679C CORRELATION MATRIX 13680C PRINCIPLE COMPONENTS ... 13681C ... PRINCIPLE COMPONENT ... 13682C COMOVEMENT MATRIX 13683C 13684C EXAMPLES--LET M3 = MATRIX ADDITION M1 M2 13685C LET M3 = MATRIX ADDITION M1 P1 13686C --LET M3 = MATRIX SUBTRACTION M1 M2 13687C LET M3 = MATRIX SUBTRACTION M1 P1 13688C --LET M3 = MATRIX MULTIPLICATION M1 M2 13689C LET M3 = MATRIX MULTIPLICATION M1 V1 13690C LET M3 = MATRIX MULTIPLICATION M1 P1 13691C --LET V3 = MATRIX SOLUTION M1 V2 13692C --LET V3 = MATRIX ITERATIVE SOLUTION M1 V2 13693C --LET M3 = MATRIX INVERSE M1 13694C --LET P3 = MATRIX CONDITION NUMBER M1 13695C --LET P3 = MATRIX RECIPROCAL CONDITION NUMBER M1 13696C --LET M3 = MATRIX TRANSPOSE M1 13697C --LET M3 = MATRIX ADJOINT M1 13698C --LET V3 = MATRIX CHARACTERISTIC EQUATION M1 13699C --LET V3 = MATRIX EIGENVALUES M1 13700C --LET P3 = MATRIX EIGENVECTORS M1 13701C --LET P3 = MATRIX RANK M1 13702C --LET P3 = MATRIX DETERMINANT M1 13703C --LET P3 = MATRIX PERMANENT M1 13704C --LET P3 = MATRIX SPECTRAL NORM M1 13705C --LET P3 = MATRIX SPECTRAL RADIUS M1 13706C --LET P3 = MATRIX NUMBER OF ROWS M1 13707C --LET P3 = MATRIX NUMBER OF COLUMNS M1 13708C --LET V4 = MATRIX SIMPLEX SOLUTION V1 M1 V2 V3 13709C --LET P3 = MATRIX TRACE M1 13710C --LET M3 = MATRIX SUBMATRIX M1 P1 P2 13711C --LET P3 = MATRIX MINOR M1 P1 P2 13712C --LET P3 = MATRIX COFACTOR M1 P1 P2 13713C --LET M3 = MATRIX DEFINITION V1 P1 P2 13714C --LET M3 = MATRIX DEFINITION V1 P1 P2 P3 13715C --LET P3 = MATRIX EUCLIDEAN NORM M1 13716C --LET V3 = MATRIX ROW M1 P1 13717C --LET P3 = MATRIX ELEMENT M1 P1 P2 13718C --LET M3 = MATRIX REPLACE ROW M1 V1 P1 13719C --LET M3 = MATRIX REPLACE ELEMENT M1 P1 P2 13720C --LET M3 = MATRIX AUGMENT M1 13721C --LET V3 = MATRIX DIAGONAL M1 13722C --LET M3 = DIAGONAL MATRIX V1 13723C --LET M3 = VARIANCE-COVARIANCE MATRIX M1 13724C --LET M3 = CORRELATION MATRIX M1 13725C --LET M3 = PRINCIPLE COMPONENTS M1 13726C --LET M3 = PRINCIPLE COMPONENTS EIGENVECTORS M1 13727C --LET V3 = PRINCIPLE COMPONENTS EIGENVALUES M1 13728C --LET V3 = ... PRINCIPLE COMPONENT M1 13729C --LET V3 = ... PRINCIPLE COMPONENT EIGENVECTOR M1 13730C --LET P3 = ... PRINCIPLE COMPONENT EIGENVALUE M1 13731C --LET V3 = MATRIX SINGULAR VALUES M1 13732C --LET M3 V3 M2 = MATRIX SINGULAR VALUE DECOMP M1 13733C --LET M3 V3 M2 = MATRIX SINGULAR VALUE FACTOR M1 13734C --LET M3 = CHOLESKY DECOMP M1 13735C --LET V4 = TRIDIAGONAL SOLVE V1 V2 V3 13736C --LET V4 = TRIANGULAR SOLVE M1 V2 13737C --LET M3 = TRIANGULAR INVERSE M2 13738C --LET M3 = MATRIX TRUNCATION M1 P1 13739C --LET M3 = MATRIX UPPPER TRUNCATION M1 P1 13740C 13741C INPUT ARGUMENTS--YM1 (REAL MATRIX) 13742C --NR1 13743C --NC1 13744C --YM2 (REAL MATRIX) 13745C --NR2 13746C --NC2 13747C --YM3 (REAL MATRIX) 13748C --NR3 13749C --NC3 13750C --Y1 (REAL VECTOR) 13751C --N1 13752C --Y2 (REAL VECTOR) 13753C --N2 13754C --Y3 (REAL VECTOR) 13755C --N3 13756C --Y4 (REAL VECTOR) 13757C --N4 13758C OUTPUT ARGUMENTS--YM9 (REAL MATRIX) 13759C --NR9 13760C --NC9 13761C --VECT9 (REAL VECTOR) 13762C --NVECT9 13763C --SCAL9 (REAL SCALAR) 13764C --ITYP9 13765C 13766C NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT MATRIX YM9(.) 13767C BEING IDENTICAL TO THE INPUT MATRIX YM1(.), YM2(.), OR YM3(.). 13768C WRITTEN BY--JAMES J. FILLIBEN 13769C STATISTICAL ENGINEERING DIVISION 13770C INFORMATION TECHNOLOGY LABORATORY 13771C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13772C GAITHERSBURG, MD 20899-8980 13773C PHONE--301-975-2855 13774C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13775C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13776C LANGUAGE--ANSI FORTRAN (1977) 13777C VERSION NUMBER--87/10 13778C ORIGINAL VERSION--SEPTEMBER 1987 13779C UPDATED --AUGUST 1988 (VARIANCE-COVARIANCE MATRIX) 13780C UPDATED --AUGUST 1988 (CORRELATION MATRIX) 13781C UPDATED --AUGUST 1988 (PRINCIPLE COMPONENTS) 13782C UPDATED --AUGUST 1988 (... PRINCIPLE COMPONENTS) 13783C UPDATED --APRIL 1992 DEFINE D999 13784C UPDATED --JULY 1993 FOR MATRIX SOLUTION, 13785C DETERMINANT, INVERSE, REPLACE 13786C NUMERICAL RECIPES CODE WITH 13787C LINPACK CODE 13788C UPDATED --JULY 1993 EIGENVALUES AND EIGENVECTORS 13789C EXTENDED TO NON-SYMMETRIC CASE 13790C UPDATED --JULY 1993 IMPLEMENT RANK, ADJOINT, 13791C SINGULAR VALUES, SINGULAR VALUE 13792C DECOMP 13793C UPDATED --SEPT 1993 ROW, ELEMENT CASES 13794C UPDATED --OCTOBER 1993 CHOLESKY DECOMPOSITION, REPLACE 13795C ROW, REPLACE ELEMENT, AUGMENT, 13796C DIAGONAL, ADD ARGUMENT TO 13797C MATRIX DEFINITION, TRIDIAGONAL 13798C SOLVE. 13799C UPDATED --OCTOBER 1993 MOVE SOME OPERATIONS TO MATAR2 13800C UPDATED --DECEMBER 1994 MATRIX SUBMATRIX FOR NON-SQUARE 13801C MATRICES 13802C UPDATED --JUNE 1995 EXTEND SPECTRAL RADIUS TO 13803C NON-SYMMETRIC CASE 13804C UPDATED --JANUARY 1998 RECODE TO USE FEWER MATRICES 13805C UPDATED --JULY 2002 SUPPORT FOR DIFFERENT TYPES OF 13806C COVARIANCE AND CORRELATION MATRIX 13807C UPDATED --NOVEMBER 2004 SUPPORT FOR DIFFERENT TYPES OF 13808C UPDATED --MARCH 2006 MATRIX <LOWER/UPPER> TRUNCATE 13809C UPDATED --NOVEMBER 2007 COMOVEMENT MATRIX 13810C UPDATED --SEPTEMBER 2011 MATRIX CONDITION NUMBER 13811C UPDATED --SEPTEMBER 2011 MATRIX RECIPROCAL CONDITION 13812C NUMBER 13813C UPDATED --JUNE 2012 PARTIAL CORRELATION MATRIX 13814C UPDATED --JUNE 2012 PARTIAL CORRELATION CDF MATRIX 13815C UPDATED --JUNE 2012 PARTIAL CORRELATION PVALUE MATRIX 13816C UPDATED --JUNE 2012 CORRELATION CDF MATRIX 13817C UPDATED --JUNE 2012 CORRELATION PVALUE MATRIX 13818C UPDATED --SEPTEMBER 2016 CORRELATION ABSOLUTE VALUE 13819C UPDATED --SEPTEMBER 2016 CORRELATION PERCENTAGE VALUE 13820C UPDATED --SEPTEMBER 2016 CORRELATION DIGITS 13821C UPDATED --AUGUST 2019 CALL LIST TO KENTAU 13822C 13823C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13824C 13825 CHARACTER*4 IMCASE 13826 CHARACTER*4 IUPFLG 13827 CHARACTER*4 IMSUBC 13828 CHARACTER*4 PCCASE 13829 CHARACTER*4 ITYPA1 13830 CHARACTER*4 ITYPA2 13831 CHARACTER*4 ITYPA3 13832 CHARACTER*4 ITYPA4 13833 CHARACTER*4 IWRITE 13834 CHARACTER*4 ITYP9 13835 CHARACTER*4 IBUGA3 13836 CHARACTER*4 ISUBRO 13837 CHARACTER*4 IERROR 13838C 13839 CHARACTER*4 ISUBN1 13840 CHARACTER*4 ISUBN2 13841 CHARACTER*4 ICASZZ 13842C 13843C-----DOUBLE PRECISION STATEMENTS FOR NON-COMMON VARIABLES------------------- 13844C 13845 DOUBLE PRECISION DYM1 13846 DOUBLE PRECISION DYM2 13847 DOUBLE PRECISION DYM9 13848 DOUBLE PRECISION DSUM 13849 DOUBLE PRECISION DSUM1 13850 DOUBLE PRECISION DSUM2 13851 DOUBLE PRECISION DDEL 13852C 13853 DOUBLE PRECISION DNR1 13854 DOUBLE PRECISION DNC1 13855 DOUBLE PRECISION DMEAN 13856 DOUBLE PRECISION DSSQD 13857 DOUBLE PRECISION DDENOM 13858 DOUBLE PRECISION DDEL1 13859 DOUBLE PRECISION DDEL2 13860 DOUBLE PRECISION DCOV 13861CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1992 13862 DOUBLE PRECISION D999 13863C 13864C--------------------------------------------------------------------- 13865C 13866 INCLUDE 'DPCOPA.INC' 13867C 13868 DIMENSION YM1(MAXROM,MAXCOM) 13869 DIMENSION YM2(MAXROM,MAXCOM) 13870CCCCC DIMENSION YM3(MAXROM,MAXCOM) 13871 DIMENSION Y1(*) 13872 DIMENSION Y2(*) 13873 DIMENSION Y3(*) 13874 DIMENSION Y4(*) 13875 DIMENSION YM9(MAXROM,MAXCOM) 13876 DIMENSION VECT9(*) 13877C 13878CCCCC DIMENSION YMJUNK(MAXROM,MAXCOM) 13879CCCCC DIMENSION YMJUN2(MAXROM,MAXCOM) 13880CCCCC JANUARY 1998. FOLLOWINF DIMENSIONS TO MAXOBV. 13881CCCCC DIMENSION INDEX(MAXROM) 13882CCCCC DIMENSION VJUNK(MAXROM) 13883CCCCC DIMENSION VJUNK2(MAXROM) 13884CCCCC DIMENSION AINDE2(MAXROM) 13885CCCCC DIMENSION AINDE3(MAXROM) 13886C 13887CCCCC DIMENSION IZROV(MAXROM) 13888CCCCC DIMENSION IPOSV(MAXROM) 13889C 13890CCCCC DIMENSION DMEAN(MAXROM) 13891CCCCC DIMENSION DSSQD(MAXROM) 13892C 13893CCCCC DIMENSION INDEX(MAXOBV) 13894 DIMENSION INDEX(*) 13895CCCCC REPLACE VJUNK, VJUNK2 WITH Y3 AND Y4 BELOW (TO SAVE SPACE) 13896CCCCC DIMENSION VJUNK(MAXOBV) 13897CCCCC DIMENSION VJUNK2(MAXOBV) 13898CCCCC REPLACE AINDE2, AINDE3 WITH Y1 AND Y2 BELOW (TO SAVE SPACE) 13899CCCCC DIMENSION AINDE2(MAXOBV) 13900CCCCC DIMENSION AINDE3(MAXOBV) 13901C 13902CCCCC DIMENSION IZROV(MAXOBV) 13903CCCCC DIMENSION IPOSV(MAXOBV) 13904 DIMENSION IZROV(*) 13905 DIMENSION IPOSV(*) 13906C 13907CCCCC DIMENSION DMEAN(MAXOBV) 13908CCCCC DIMENSION DSSQD(MAXOBV) 13909 DIMENSION DMEAN(*) 13910 DIMENSION DSSQD(*) 13911C 13912C--------------------------------------------------------------------- 13913C 13914CCCCC JULY 1993. ADD FOLLOWING COMMON BLOCK FOR PRINCIPLE COMPONENTS 13915 INCLUDE 'DPCOSU.INC' 13916 INCLUDE 'DPCOST.INC' 13917 INCLUDE 'DPCOP2.INC' 13918C 13919CCCCC JULY 1993. FOLLOWING LINE ADDED FOR RANK. 13920 DATA RMXINT /134217727. / 13921C 13922C-----START POINT----------------------------------------------------- 13923C 13924 ISUBN1='MATA' 13925 ISUBN2='RI ' 13926 IERROR='NO' 13927C 13928CCCCC JULY 1993. 13929CCCCC PCCASE='DACR' 13930 PCCASE=IPCMTY 13931 AMINOR=CPUMIN 13932 SCAL9=CPUMIN 13933 COFACT=CPUMIN 13934 DET=CPUMIN 13935C 13936 IYS1=(-999) 13937 IYS2=(-999) 13938 IYS3=(-999) 13939 IYS23=(-999) 13940C 13941 NRJ=(-999) 13942 NCJ=(-999) 13943C 13944CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1992 13945 D999=(-999.0D0) 13946C 13947 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'TARI')GOTO190 13948C 13949 WRITE(ICOUT,999) 13950 999 FORMAT(1X) 13951 CALL DPWRST('XXX','BUG ') 13952 WRITE(ICOUT,51) 13953 51 FORMAT('***** AT THE BEGINNING OF MATARI--') 13954 CALL DPWRST('XXX','BUG ') 13955 WRITE(ICOUT,52)IBUGA3,ISUBRO,ITYPA1,ITYPA2,ITYPA3,ITYPA4 13956 52 FORMAT('IBUGA3,ISUBRO,ITYPA1,ITYPA2,ITYPA3,ITYPA4 = ', 13957 1 (A4,2X),A4) 13958 CALL DPWRST('XXX','BUG ') 13959 WRITE(ICOUT,53)IMCASE,IMSUBC,IWRITE 13960 53 FORMAT('IMCASE,IMSUBC,IWRITE = ',2(A4,2X),A4) 13961 CALL DPWRST('XXX','BUG ') 13962 WRITE(ICOUT,55)NUMVAR,YS1,YS2,YS3,YS4,DSSQD(1) 13963 55 FORMAT('NUMVAR,YS1,YS2,YS3,YS4,DSSQD(1) = ',I8,5G15.7) 13964 CALL DPWRST('XXX','BUG ') 13965C 13966 WRITE(ICOUT,999) 13967 CALL DPWRST('XXX','BUG ') 13968 WRITE(ICOUT,61)NR1,NC1 13969 61 FORMAT('NR1,NC1 = ',2I8) 13970 CALL DPWRST('XXX','BUG ') 13971 IF(NR1.LE.0)GOTO69 13972 IF(NC1.LE.0)GOTO69 13973 JMAX=NC1 13974 IF(JMAX.GT.10)JMAX=10 13975 DO62I=1,NR1 13976 WRITE(ICOUT,63)I,(YM1(I,J),J=1,JMAX) 13977 63 FORMAT('I,YM1(I,.) = ',I8,10E10.3) 13978 CALL DPWRST('XXX','BUG ') 13979 62 CONTINUE 13980 69 CONTINUE 13981C 13982 WRITE(ICOUT,999) 13983 CALL DPWRST('XXX','BUG ') 13984 WRITE(ICOUT,71)NR2,NC2 13985 71 FORMAT('NR2,NC2 = ',2I8) 13986 CALL DPWRST('XXX','BUG ') 13987 IF(NR2.LE.0)GOTO79 13988 IF(NC2.LE.0)GOTO79 13989 JMAX=NC2 13990 IF(JMAX.GT.10)JMAX=10 13991 DO72I=1,NR2 13992 WRITE(ICOUT,73)I,(YM2(I,J),J=1,JMAX) 13993 73 FORMAT('I,YM2(I,.) = ',I8,10E10.3) 13994 CALL DPWRST('XXX','BUG ') 13995 72 CONTINUE 13996 79 CONTINUE 13997C 13998 WRITE(ICOUT,999) 13999 CALL DPWRST('XXX','BUG ') 14000 WRITE(ICOUT,81)NR3,NC3 14001 81 FORMAT('NR3,NC3 = ',2I8) 14002 CALL DPWRST('XXX','BUG ') 14003 IF(NR3.LE.0)GOTO89 14004 IF(NC3.LE.0)GOTO89 14005 JMAX=NC3 14006 IF(JMAX.GT.10)JMAX=10 14007 DO82I=1,NR3 14008 WRITE(ICOUT,83)I,(YM9(I,J),J=1,JMAX) 14009 83 FORMAT('I,YM9(I,.) = ',I8,10E10.3) 14010 CALL DPWRST('XXX','BUG ') 14011 82 CONTINUE 14012 89 CONTINUE 14013C 14014 WRITE(ICOUT,999) 14015 CALL DPWRST('XXX','BUG ') 14016 WRITE(ICOUT,111)N1 14017 111 FORMAT('N1 = ',I8) 14018 CALL DPWRST('XXX','BUG ') 14019 IF(N1.LE.0)GOTO119 14020 DO112I=1,N1 14021 WRITE(ICOUT,113)I,Y1(I) 14022 113 FORMAT('I,Y1(I) = ',I8,E15.7) 14023 CALL DPWRST('XXX','BUG ') 14024 112 CONTINUE 14025 119 CONTINUE 14026C 14027 WRITE(ICOUT,999) 14028 CALL DPWRST('XXX','BUG ') 14029 WRITE(ICOUT,121)N2 14030 121 FORMAT('N2 = ',I8) 14031 CALL DPWRST('XXX','BUG ') 14032 IF(N2.LE.0)GOTO129 14033 DO122I=1,N2 14034 WRITE(ICOUT,123)I,Y2(I) 14035 123 FORMAT('I,Y2(I) = ',I8,E15.7) 14036 CALL DPWRST('XXX','BUG ') 14037 122 CONTINUE 14038 129 CONTINUE 14039C 14040 WRITE(ICOUT,999) 14041 CALL DPWRST('XXX','BUG ') 14042 WRITE(ICOUT,131)N3 14043 131 FORMAT('N3 = ',I8) 14044 CALL DPWRST('XXX','BUG ') 14045 IF(N3.LE.0)GOTO139 14046 DO132I=1,N3 14047 WRITE(ICOUT,133)I,Y3(I) 14048 133 FORMAT('I,Y3(I) = ',I8,E15.7) 14049 CALL DPWRST('XXX','BUG ') 14050 132 CONTINUE 14051 139 CONTINUE 14052C 14053 WRITE(ICOUT,999) 14054 CALL DPWRST('XXX','BUG ') 14055 WRITE(ICOUT,141)N4 14056 141 FORMAT('N4 = ',I8) 14057 CALL DPWRST('XXX','BUG ') 14058 IF(N4.LE.0)GOTO149 14059 DO142I=1,N4 14060 WRITE(ICOUT,143)I,Y4(I) 14061 143 FORMAT('I,Y4(I) = ',I8,E15.7) 14062 CALL DPWRST('XXX','BUG ') 14063 142 CONTINUE 14064 149 CONTINUE 14065C 14066 190 CONTINUE 14067C 14068C ************************************************** 14069C ** CARRY OUT MATRIX ARITHMETIC OPERATIONS ** 14070C ************************************************** 14071C 14072 DNR1=NR1 14073 DNC1=NC1 14074C 14075C ******************************************** 14076C ** STEP 11-- ** 14077C ** CHECK NUMBER OF INPUT OBSERVATIONS. ** 14078C ******************************************** 14079C 14080 IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1.AND.NR1.LE.0)GOTO1100 14081 IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1.AND.NC1.LE.0)GOTO1100 14082 IF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2.AND.NR2.LE.0)GOTO1100 14083 IF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2.AND.NC2.LE.0)GOTO1100 14084 IF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3.AND.NR3.LE.0)GOTO1100 14085 IF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3.AND.NC3.LE.0)GOTO1100 14086C 14087 IF(ITYPA1.EQ.'VARI'.AND.NUMVAR.GE.1.AND.N1.LE.0)GOTO1100 14088 IF(ITYPA2.EQ.'VARI'.AND.NUMVAR.GE.2.AND.N2.LE.0)GOTO1100 14089 IF(ITYPA3.EQ.'VARI'.AND.NUMVAR.GE.3.AND.N3.LE.0)GOTO1100 14090C 14091 GOTO1190 14092C 14093 1100 CONTINUE 14094 IERROR='YES' 14095 WRITE(ICOUT,999) 14096 CALL DPWRST('XXX','BUG ') 14097 WRITE(ICOUT,1111) 14098 1111 FORMAT('***** ERROR IN MATARI--') 14099 CALL DPWRST('XXX','BUG ') 14100 WRITE(ICOUT,1112) 14101 1112 FORMAT(' THE INPUT NUMBER OF ROWS AND/OR COLUMNS') 14102 CALL DPWRST('XXX','BUG ') 14103 WRITE(ICOUT,1113) 14104 1113 FORMAT(' IN THE MATRIX AND/OR VECTOR FOR WHICH') 14105 CALL DPWRST('XXX','BUG ') 14106 IF(IMCASE.EQ.'MAAD')WRITE(ICOUT,1121) 14107 1121 FORMAT(' THE MATRIX ADDITION IS TO BE ', 14108 1'COMPUTED') 14109 IF(IMCASE.EQ.'MAAD')CALL DPWRST('XXX','BUG ') 14110 IF(IMCASE.EQ.'MASU')WRITE(ICOUT,1122) 14111 1122 FORMAT(' THE MATRIX SUBTRACTION IS TO BE ', 14112 1'COMPUTED') 14113 IF(IMCASE.EQ.'MASU')CALL DPWRST('XXX','BUG ') 14114 IF(IMCASE.EQ.'MAMU')WRITE(ICOUT,1123) 14115 1123 FORMAT(' THE MATRIX MULTIPLICATION IS TO BE ', 14116 1'COMPUTED') 14117 IF(IMCASE.EQ.'MAMU')CALL DPWRST('XXX','BUG ') 14118 IF(IMCASE.EQ.'MASO')WRITE(ICOUT,1124) 14119 1124 FORMAT(' THE MATRIX SOLUTION IS TO BE ', 14120 1'COMPUTED') 14121 IF(IMCASE.EQ.'MASO')CALL DPWRST('XXX','BUG ') 14122 IF(IMCASE.EQ.'MAIN')WRITE(ICOUT,1125) 14123 1125 FORMAT(' THE MATRIX INVERSE IS TO BE ', 14124 1'COMPUTED') 14125 IF(IMCASE.EQ.'MAIN')CALL DPWRST('XXX','BUG ') 14126 IF(IMCASE.EQ.'MATR')WRITE(ICOUT,1126) 14127 1126 FORMAT(' THE MATRIX TRANSPOSE IS TO BE ', 14128 1'COMPUTED') 14129 IF(IMCASE.EQ.'MATR')CALL DPWRST('XXX','BUG ') 14130 IF(IMCASE.EQ.'MAAJ')WRITE(ICOUT,1127) 14131 1127 FORMAT(' THE MATRIX ADJOINT IS TO BE ', 14132 1'COMPUTED') 14133 IF(IMCASE.EQ.'MAAJ')CALL DPWRST('XXX','BUG ') 14134 IF(IMCASE.EQ.'MACE')WRITE(ICOUT,1128) 14135 1128 FORMAT(' THE MATRIX CHARACTERISTIC EQUATION IS TO BE ', 14136 1'COMPUTED') 14137 IF(IMCASE.EQ.'MACE')CALL DPWRST('XXX','BUG ') 14138 IF(IMCASE.EQ.'MAEA')WRITE(ICOUT,1129) 14139 1129 FORMAT(' THE MATRIX EIGENVALUES ARE TO BE ', 14140 1'COMPUTED') 14141 IF(IMCASE.EQ.'MAEA')CALL DPWRST('XXX','BUG ') 14142 IF(IMCASE.EQ.'MAEE')WRITE(ICOUT,1130) 14143 1130 FORMAT(' THE MATRIX EIGENVECTORS ARE TO BE ', 14144 1'COMPUTED') 14145 IF(IMCASE.EQ.'MAEE')CALL DPWRST('XXX','BUG ') 14146 IF(IMCASE.EQ.'MARA')WRITE(ICOUT,1131) 14147 1131 FORMAT(' THE MATRIX RANK IS TO BE ', 14148 1'COMPUTED') 14149 IF(IMCASE.EQ.'MARA')CALL DPWRST('XXX','BUG ') 14150 IF(IMCASE.EQ.'MADE')WRITE(ICOUT,1132) 14151 1132 FORMAT(' THE MATRIX DETERMINANT IS TO BE ', 14152 1'COMPUTED') 14153 IF(IMCASE.EQ.'MADE')CALL DPWRST('XXX','BUG ') 14154 IF(IMCASE.EQ.'MAPE')WRITE(ICOUT,1133) 14155 1133 FORMAT(' THE MATRIX PERMANENT IS TO BE ', 14156 1'COMPUTED') 14157 IF(IMCASE.EQ.'MAPE')CALL DPWRST('XXX','BUG ') 14158 IF(IMCASE.EQ.'MASN')WRITE(ICOUT,1134) 14159 1134 FORMAT(' THE MATRIX SPECTRAL NORM IS TO BE ', 14160 1'COMPUTED') 14161 IF(IMCASE.EQ.'MASN')CALL DPWRST('XXX','BUG ') 14162 IF(IMCASE.EQ.'MASR')WRITE(ICOUT,1135) 14163 1135 FORMAT(' THE MATRIX SPECTRAL RADIUS IS TO BE ', 14164 1'COMPUTED') 14165 IF(IMCASE.EQ.'MASR')CALL DPWRST('XXX','BUG ') 14166 IF(IMCASE.EQ.'MANR')WRITE(ICOUT,1136) 14167 1136 FORMAT(' THE MATRIX NUMBER OF ROWS IS TO BE ', 14168 1'COMPUTED') 14169 IF(IMCASE.EQ.'MANR')CALL DPWRST('XXX','BUG ') 14170 IF(IMCASE.EQ.'MANC')WRITE(ICOUT,1137) 14171 1137 FORMAT(' THE MATRIX NUMBER OF COLUMNS IS TO BE ', 14172 1'COMPUTED') 14173 IF(IMCASE.EQ.'MANC')CALL DPWRST('XXX','BUG ') 14174 IF(IMCASE.EQ.'MANC')WRITE(ICOUT,1138) 14175 1138 FORMAT(' THE MATRIX SIMPLEX SOLUTION IS TO BE ', 14176 1'COMPUTED') 14177 IF(IMCASE.EQ.'MANC')CALL DPWRST('XXX','BUG ') 14178 IF(IMCASE.EQ.'MATC')WRITE(ICOUT,1141) 14179 1141 FORMAT(' THE MATRIX TRACE IS TO BE ', 14180 1'COMPUTED') 14181 IF(IMCASE.EQ.'MATC')CALL DPWRST('XXX','BUG ') 14182 IF(IMCASE.EQ.'MASM')WRITE(ICOUT,1142) 14183 1142 FORMAT(' THE MATRIX SUBMATRIX IS TO BE ', 14184 1'COMPUTED') 14185 IF(IMCASE.EQ.'MASM')CALL DPWRST('XXX','BUG ') 14186 IF(IMCASE.EQ.'MAMI')WRITE(ICOUT,1143) 14187 1143 FORMAT(' THE MATRIX MINOR IS TO BE ', 14188 1'COMPUTED') 14189 IF(IMCASE.EQ.'MAMI')CALL DPWRST('XXX','BUG ') 14190 IF(IMCASE.EQ.'MACF')WRITE(ICOUT,1144) 14191 1144 FORMAT(' THE MATRIX COFACTOR IS TO BE ', 14192 1'COMPUTED') 14193 IF(IMCASE.EQ.'MACF')CALL DPWRST('XXX','BUG ') 14194 IF(IMCASE.EQ.'MADF')WRITE(ICOUT,1145) 14195 1145 FORMAT(' THE MATRIX DEFINITION IS TO BE ', 14196 1'COMPUTED') 14197 IF(IMCASE.EQ.'MADF')CALL DPWRST('XXX','BUG ') 14198 IF(IMCASE.EQ.'MAEN')WRITE(ICOUT,1146) 14199 1146 FORMAT(' THE MATRIX EUCLIDEAN NORM IS TO BE ', 14200 1'COMPUTED') 14201 IF(IMCASE.EQ.'MAEN')CALL DPWRST('XXX','BUG ') 14202 IF(IMCASE.EQ.'MAVC')WRITE(ICOUT,1151) 14203 1151 FORMAT(' THE VARIANCE-COVARIANCE MATRIX IS TO BE ', 14204 1'COMPUTED') 14205 IF(IMCASE.EQ.'MAVC')CALL DPWRST('XXX','BUG ') 14206 IF(IMCASE.EQ.'MACO')WRITE(ICOUT,1152) 14207 1152 FORMAT(' THE CORRELATION MATRIX IS TO BE ', 14208 1'COMPUTED') 14209 IF(IMCASE.EQ.'MACO')CALL DPWRST('XXX','BUG ') 14210 IF(IMCASE.EQ.'MAPC')WRITE(ICOUT,1153) 14211 1153 FORMAT(' THE PRINCIPLE COMPONENTS ARE TO BE ', 14212 1'COMPUTED') 14213 IF(IMCASE.EQ.'MAPC')CALL DPWRST('XXX','BUG ') 14214 IF(IMCASE(1:3).EQ.'MAP'.AND.IMCASE(4:4).NE.'C')THEN 14215 WRITE(ICOUT,1154) 14216 1154 FORMAT(' THE ... PRINCIPLE COMPONENT TO BE ', 14217 1 'COMPUTED') 14218 CALL DPWRST('XXX','BUG ') 14219 ENDIF 14220 WRITE(ICOUT,1181) 14221 1181 FORMAT(' MUST BE 1 OR LARGER;') 14222 CALL DPWRST('XXX','BUG ') 14223 WRITE(ICOUT,1182) 14224 1182 FORMAT(' SUCH WAS NOT THE CASE HERE.') 14225 CALL DPWRST('XXX','BUG ') 14226 IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1)WRITE(ICOUT,1183)NR1,NC1 14227 1183 FORMAT(' MATRIX 1--',I8,' ROWS BY ',I8,' COLUMNS') 14228 IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1)CALL DPWRST('XXX','BUG ') 14229 IF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2)WRITE(ICOUT,1184)NR2,NC2 14230 1184 FORMAT(' MATRIX 2--',I8,' ROWS BY ',I8,' COLUMNS') 14231 IF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2)CALL DPWRST('XXX','BUG ') 14232 IF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3)WRITE(ICOUT,1185)NR3,NC3 14233 1185 FORMAT(' MATRIX 3--',I8,' ROWS BY ',I8,' COLUMNS') 14234 IF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3)CALL DPWRST('XXX','BUG ') 14235 IF(ITYPA1.EQ.'VARI'.AND.NUMVAR.GE.1)WRITE(ICOUT,1186)N1 14236 1186 FORMAT(' VECTOR 1--',I8,' ROWS') 14237 IF(ITYPA1.EQ.'VARI'.AND.NUMVAR.GE.1)CALL DPWRST('XXX','BUG ') 14238 IF(ITYPA2.EQ.'VARI'.AND.NUMVAR.GE.2)WRITE(ICOUT,1187)N2 14239 1187 FORMAT(' VECTOR 2--',I8,' ROWS') 14240 IF(ITYPA2.EQ.'VARI'.AND.NUMVAR.GE.2)CALL DPWRST('XXX','BUG ') 14241 IF(ITYPA3.EQ.'VARI'.AND.NUMVAR.GE.3)WRITE(ICOUT,1188)N3 14242 1188 FORMAT(' VECTOR 3--',I8,' ROWS') 14243 IF(ITYPA3.EQ.'VARI'.AND.NUMVAR.GE.3)CALL DPWRST('XXX','BUG ') 14244 GOTO9000 14245C 14246 1190 CONTINUE 14247C 14248C ********************************* 14249C ** STEP 12-- ** 14250C ** BRANCH TO THE PROPER CASE ** 14251C ********************************* 14252C 14253 IF(IMCASE.EQ.'MAAD')GOTO2100 14254 IF(IMCASE.EQ.'MASU')GOTO2200 14255 IF(IMCASE.EQ.'MAMU')GOTO2300 14256 IF(IMCASE.EQ.'MASO')GOTO2400 14257 IF(IMCASE.EQ.'MAIN')GOTO2500 14258 IF(IMCASE.EQ.'MACN')GOTO2560 14259 IF(IMCASE.EQ.'MARC')GOTO2560 14260 IF(IMCASE.EQ.'MATR')GOTO2600 14261 IF(IMCASE.EQ.'MAAJ')GOTO2700 14262 IF(IMCASE.EQ.'MACE')GOTO2800 14263 IF(IMCASE.EQ.'MAEA')GOTO2900 14264 IF(IMCASE.EQ.'MAEE')GOTO3000 14265 IF(IMCASE.EQ.'MARA')GOTO3100 14266 IF(IMCASE.EQ.'MADE')GOTO3200 14267 IF(IMCASE.EQ.'MAPE')GOTO3300 14268 IF(IMCASE.EQ.'MASN')GOTO3400 14269 IF(IMCASE.EQ.'MASR')GOTO3500 14270 IF(IMCASE.EQ.'MANR')GOTO3600 14271 IF(IMCASE.EQ.'MANC')GOTO3700 14272 IF(IMCASE.EQ.'MASS')GOTO3800 14273 IF(IMCASE.EQ.'MATC')GOTO4100 14274 IF(IMCASE.EQ.'MASM')GOTO4200 14275 IF(IMCASE.EQ.'MAMI')GOTO4300 14276 IF(IMCASE.EQ.'MACF')GOTO4400 14277 IF(IMCASE.EQ.'MADF')GOTO4500 14278 IF(IMCASE.EQ.'MAEN')GOTO4600 14279 IF(IMCASE.EQ.'MAVC')GOTO5100 14280 IF(IMCASE.EQ.'MACO')GOTO5200 14281 IF(IMCASE.EQ.'MACC')GOTO5200 14282 IF(IMCASE.EQ.'MACP')GOTO5200 14283C 14284 IF(IMCASE.EQ.'MAPC')GOTO5300 14285 IF(IMCASE.EQ.'MAP1')GOTO5300 14286 IF(IMCASE.EQ.'MAP2')GOTO5300 14287 IF(IMCASE.EQ.'MAP3')GOTO5300 14288 IF(IMCASE.EQ.'MAP4')GOTO5300 14289 IF(IMCASE.EQ.'MAP5')GOTO5300 14290 IF(IMCASE.EQ.'MAP6')GOTO5300 14291 IF(IMCASE.EQ.'MAP7')GOTO5300 14292 IF(IMCASE.EQ.'MAP8')GOTO5300 14293 IF(IMCASE.EQ.'MAP9')GOTO5300 14294 IF(IMCASE.EQ.'MA10')GOTO5300 14295CCCCCC OCTOBER 1993. FOLLOWING OPERATIONS MOVED TO MATAR2 14296CCCCC JULY 1993. ADD FOLLOWING 3 LINES 14297CCCCC IF(IMCASE.EQ.'MASV')GOTO5800 14298CCCCC IF(IMCASE.EQ.'MASD')GOTO5900 14299CCCCC IF(IMCASE.EQ.'MASF')GOTO6000 14300CCCCC SEPTEMBER 1993. ADD FOLLOWING 2 LINES 14301CCCCC IF(IMCASE.EQ.'MARW')GOTO6100 14302CCCCC IF(IMCASE.EQ.'MAEL')GOTO6200 14303CCCCC OCTOBER 1993. ADD FOLLOWING LINE 14304CCCCC IF(IMCASE.EQ.'MACH')GOTO6300 14305CCCCC IF(IMCASE.EQ.'MAAU')GOTO6400 14306CCCCC IF(IMCASE.EQ.'MADI')GOTO6500 14307CCCCC IF(IMCASE.EQ.'DIMA')GOTO6600 14308CCCCC IF(IMCASE.EQ.'MARR')GOTO6700 14309CCCCC IF(IMCASE.EQ.'MARE')GOTO6800 14310CCCCC IF(IMCASE.EQ.'MATD')GOTO6900 14311CCCCC IF(IMCASE.EQ.'MATS')GOTO7000 14312CCCCC IF(IMCASE.EQ.'MATI')GOTO7100 14313CCCCC IF(IMCASE.EQ.'MAIS')GOTO7200 14314C 14315 IF(IMCASE.EQ.'MATZ')GOTO6100 14316 IF(IMCASE.EQ.'MAUZ')GOTO6200 14317 IF(IMCASE.EQ.'MACM')GOTO6300 14318 IF(IMCASE.EQ.'MPCO')GOTO6400 14319 IF(IMCASE.EQ.'MPCC')GOTO6400 14320 IF(IMCASE.EQ.'MPCP')GOTO6400 14321C 14322 WRITE(ICOUT,999) 14323 CALL DPWRST('XXX','BUG ') 14324 WRITE(ICOUT,1211) 14325 1211 FORMAT('***** INTERNAL ERROR IN MATARI--') 14326 CALL DPWRST('XXX','BUG ') 14327 WRITE(ICOUT,1212) 14328 1212 FORMAT(' IMCASE NOT EQUAL TO') 14329 CALL DPWRST('XXX','BUG ') 14330 WRITE(ICOUT,1213) 14331 1213 FORMAT(' MAAD, MASU, MAMU, MASO, ') 14332 CALL DPWRST('XXX','BUG ') 14333 WRITE(ICOUT,1214) 14334 1214 FORMAT(' MAIN, MATR, MAAJ, MACE, ') 14335 CALL DPWRST('XXX','BUG ') 14336 WRITE(ICOUT,1215) 14337 1215 FORMAT(' MAEA, MAEE, MARA, MADE, ') 14338 CALL DPWRST('XXX','BUG ') 14339 WRITE(ICOUT,1216) 14340 1216 FORMAT(' MAPE, MASN, MASR, MANR, ') 14341 CALL DPWRST('XXX','BUG ') 14342 WRITE(ICOUT,1217) 14343 1217 FORMAT(' MANC, MASS,') 14344 CALL DPWRST('XXX','BUG ') 14345 WRITE(ICOUT,1221) 14346 1221 FORMAT(' MAVC, MACO, MAPC, OR MAPX ') 14347 CALL DPWRST('XXX','BUG ') 14348 WRITE(ICOUT,1228)IMCASE 14349 1228 FORMAT(' IMCASE = ',A4) 14350 CALL DPWRST('XXX','BUG ') 14351 IERROR='YES' 14352 GOTO9000 14353C 14354C ********************************************* 14355C ** STEP 21-- ** 14356C ** TREAT THE MATRIX ADDITION CASE ** 14357C ********************************************* 14358C 14359 2100 CONTINUE 14360C 14361 IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'MATR')GOTO2110 14362 IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'VARI')GOTO2130 14363 IF(ITYPA1.EQ.'VARI'.AND.ITYPA2.EQ.'MATR')GOTO2150 14364 IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'PARA')GOTO2170 14365 IF(ITYPA1.EQ.'PARA'.AND.ITYPA2.EQ.'MATR')GOTO2180 14366C 14367 WRITE(ICOUT,999) 14368 CALL DPWRST('XXX','BUG ') 14369 WRITE(ICOUT,2101) 14370 2101 FORMAT('***** ERROR IN MATARI--') 14371 CALL DPWRST('XXX','BUG ') 14372 WRITE(ICOUT,2102) 14373 2102 FORMAT(' ILLEGAL ARGUMENT TYPES FOR MATRIX ADDITION.') 14374 CALL DPWRST('XXX','BUG ') 14375 WRITE(ICOUT,2103)ITYPA1 14376 2103 FORMAT(' TYPE FOR ARGUMENT 1 = ',A4) 14377 CALL DPWRST('XXX','BUG ') 14378 WRITE(ICOUT,2104)ITYPA2 14379 2104 FORMAT(' TYPE FOR ARGUMENT 2 = ',A4) 14380 CALL DPWRST('XXX','BUG ') 14381 IERROR='YES' 14382 GOTO9000 14383C 14384 2110 CONTINUE 14385 IF(NR1.EQ.NR2.AND.NC1.EQ.NC2)GOTO2119 14386 WRITE(ICOUT,999) 14387 CALL DPWRST('XXX','BUG ') 14388 WRITE(ICOUT,2111) 14389 2111 FORMAT('***** ERROR IN MATARI--') 14390 CALL DPWRST('XXX','BUG ') 14391 WRITE(ICOUT,2112) 14392 2112 FORMAT(' FOR MATRIX ADDITION OF MATRIX 1 & MATRIX 2,') 14393 CALL DPWRST('XXX','BUG ') 14394 WRITE(ICOUT,2113) 14395 2113 FORMAT(' THE NUMBER OF ROWS AND COLUMNS IN MATRIX 1') 14396 CALL DPWRST('XXX','BUG ') 14397 WRITE(ICOUT,2114) 14398 2114 FORMAT(' MUST EQUAL') 14399 CALL DPWRST('XXX','BUG ') 14400 WRITE(ICOUT,2115) 14401 2115 FORMAT(' THE NUMBER OF ROWS AND COLUMNS IN MATRIX 2;') 14402 CALL DPWRST('XXX','BUG ') 14403 WRITE(ICOUT,2116) 14404 2116 FORMAT(' SUCH WAS NOT THE CASE HERE.') 14405 CALL DPWRST('XXX','BUG ') 14406 WRITE(ICOUT,2117)NR1,NC1 14407 2117 FORMAT(' MATRIX 1--',I8,' ROWS BY ',I8,' COLUMNS') 14408 CALL DPWRST('XXX','BUG ') 14409 WRITE(ICOUT,2118)NR2,NC2 14410 2118 FORMAT(' MATRIX 2--',I8,' ROWS BY ',I8,' COLUMNS') 14411 CALL DPWRST('XXX','BUG ') 14412 IERROR='YES' 14413 GOTO9000 14414 2119 CONTINUE 14415C 14416 DO2121I=1,NR1 14417 DO2122J=1,NC1 14418 DYM1=YM1(I,J) 14419 DYM2=YM2(I,J) 14420 DYM9=DYM1+DYM2 14421 YM9(I,J)=DYM9 14422 2122 CONTINUE 14423 2121 CONTINUE 14424 ITYP9='MATR' 14425 NR9=NR1 14426 NC9=NC1 14427 GOTO9000 14428C 14429 2130 CONTINUE 14430 IF(NR1.EQ.N2)GOTO2139 14431 WRITE(ICOUT,999) 14432 CALL DPWRST('XXX','BUG ') 14433 WRITE(ICOUT,2131) 14434 2131 FORMAT('***** ERROR IN MATARI--') 14435 CALL DPWRST('XXX','BUG ') 14436 WRITE(ICOUT,2132) 14437 2132 FORMAT(' FOR MATRIX ADDITION OF MATRIX 1 & VECTOR 2,') 14438 CALL DPWRST('XXX','BUG ') 14439 WRITE(ICOUT,2133) 14440 2133 FORMAT(' THE NUMBER OF ROWS AND COLUMNS IN MATRIX 1') 14441 CALL DPWRST('XXX','BUG ') 14442 WRITE(ICOUT,2134) 14443 2134 FORMAT(' MUST EQUAL') 14444 CALL DPWRST('XXX','BUG ') 14445 WRITE(ICOUT,2135) 14446 2135 FORMAT(' THE NUMBER OF ROWS IN VECTOR 2;') 14447 CALL DPWRST('XXX','BUG ') 14448 WRITE(ICOUT,2136) 14449 2136 FORMAT(' SUCH WAS NOT THE CASE HERE.') 14450 CALL DPWRST('XXX','BUG ') 14451 WRITE(ICOUT,2137)NR1,NC1 14452 2137 FORMAT(' MATRIX 1--',I8,' ROWS BY ',I8,' COLUMNS') 14453 CALL DPWRST('XXX','BUG ') 14454 WRITE(ICOUT,2138)N2 14455 2138 FORMAT(' VECTOR 2--',I8,' ROWS') 14456 CALL DPWRST('XXX','BUG ') 14457 IERROR='YES' 14458 GOTO9000 14459 2139 CONTINUE 14460C 14461 DO2141I=1,NR1 14462 DYM2=Y2(I) 14463 DO2142J=1,NC1 14464 DYM1=YM1(I,J) 14465 DYM9=DYM1+DYM2 14466 YM9(I,J)=DYM9 14467 2142 CONTINUE 14468 2141 CONTINUE 14469 ITYP9='MATR' 14470 NR9=NR1 14471 NC9=NC1 14472 IUPFLG='SUBS' 14473 GOTO9000 14474C 14475 2150 CONTINUE 14476 IF(N1.EQ.NR2)GOTO2159 14477 WRITE(ICOUT,999) 14478 CALL DPWRST('XXX','BUG ') 14479 WRITE(ICOUT,2151) 14480 2151 FORMAT('***** ERROR IN MATARI--') 14481 CALL DPWRST('XXX','BUG ') 14482 WRITE(ICOUT,2152) 14483 2152 FORMAT(' FOR MATRIX ADDITION OF VECTOR 1 & MATRIX 2,') 14484 CALL DPWRST('XXX','BUG ') 14485 WRITE(ICOUT,2153) 14486 2153 FORMAT(' THE NUMBER OF ROWS IN VECTOR 1;') 14487 CALL DPWRST('XXX','BUG ') 14488 WRITE(ICOUT,2154) 14489 2154 FORMAT(' MUST EQUAL') 14490 CALL DPWRST('XXX','BUG ') 14491 WRITE(ICOUT,2155) 14492 2155 FORMAT(' THE NUMBER OF ROWS AND COLUMNS IN MATRIX 2') 14493 CALL DPWRST('XXX','BUG ') 14494 WRITE(ICOUT,2156) 14495 2156 FORMAT(' SUCH WAS NOT THE CASE HERE.') 14496 CALL DPWRST('XXX','BUG ') 14497 WRITE(ICOUT,2157)N1 14498 2157 FORMAT(' VECTOR 1--',I8,' ROWS') 14499 CALL DPWRST('XXX','BUG ') 14500 WRITE(ICOUT,2158)NR2,NC2 14501 2158 FORMAT(' MATRIX 2--',I8,' ROWS BY ',I8,' COLUMNS') 14502 CALL DPWRST('XXX','BUG ') 14503 IERROR='YES' 14504 GOTO9000 14505 2159 CONTINUE 14506C 14507 DO2161I=1,NR2 14508 DYM1=Y1(I) 14509 DO2162J=1,NC2 14510 DYM2=YM2(I,J) 14511 DYM9=DYM1+DYM2 14512 YM9(I,J)=DYM9 14513 2162 CONTINUE 14514 2161 CONTINUE 14515 ITYP9='MATR' 14516 NR9=NR2 14517 NC9=NC2 14518 GOTO9000 14519C 14520 2170 CONTINUE 14521 DYM2=YS2 14522 DO2171I=1,NR1 14523 DO2172J=1,NC1 14524 DYM1=YM1(I,J) 14525 DYM9=DYM1+DYM2 14526 YM9(I,J)=DYM9 14527 2172 CONTINUE 14528 2171 CONTINUE 14529 ITYP9='MATR' 14530 NR9=NR1 14531 NC9=NC1 14532 IUPFLG='SUBS' 14533 GOTO9000 14534C 14535 2180 CONTINUE 14536 DYM1=YS1 14537 DO2181I=1,NR2 14538 DO2182J=1,NC2 14539 DYM2=YM2(I,J) 14540 DYM9=DYM1+DYM2 14541 YM9(I,J)=DYM9 14542 2182 CONTINUE 14543 2181 CONTINUE 14544 ITYP9='MATR' 14545 NR9=NR2 14546 NC9=NC2 14547 IUPFLG='SUBS' 14548 GOTO9000 14549C 14550C ********************************************* 14551C ** STEP 22-- ** 14552C ** TREAT THE MATRIX SUBTRACTION CASE ** 14553C ********************************************* 14554C 14555 2200 CONTINUE 14556C 14557 IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'MATR')GOTO2210 14558 IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'VARI')GOTO2230 14559 IF(ITYPA1.EQ.'VARI'.AND.ITYPA2.EQ.'MATR')GOTO2250 14560 IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'PARA')GOTO2270 14561 IF(ITYPA1.EQ.'PARA'.AND.ITYPA2.EQ.'MATR')GOTO2280 14562C 14563 WRITE(ICOUT,999) 14564 CALL DPWRST('XXX','BUG ') 14565 WRITE(ICOUT,2201) 14566 2201 FORMAT('***** ERROR IN MATARI--') 14567 CALL DPWRST('XXX','BUG ') 14568 WRITE(ICOUT,2202) 14569 2202 FORMAT(' ILLEGAL ARGUMENT TYPES FOR MATRIX SUBTRACTION.') 14570 CALL DPWRST('XXX','BUG ') 14571 WRITE(ICOUT,2203)ITYPA1 14572 2203 FORMAT(' TYPE FOR ARGUMENT 1 = ',A4) 14573 CALL DPWRST('XXX','BUG ') 14574 WRITE(ICOUT,2204)ITYPA2 14575 2204 FORMAT(' TYPE FOR ARGUMENT 2 = ',A4) 14576 CALL DPWRST('XXX','BUG ') 14577 IERROR='YES' 14578 GOTO9000 14579C 14580 2210 CONTINUE 14581 IF(NR1.EQ.NR2.AND.NC1.EQ.NC2)GOTO2219 14582 WRITE(ICOUT,999) 14583 CALL DPWRST('XXX','BUG ') 14584 WRITE(ICOUT,2211) 14585 2211 FORMAT('***** ERROR IN MATARI--') 14586 CALL DPWRST('XXX','BUG ') 14587 WRITE(ICOUT,2212) 14588 2212 FORMAT(' FOR MATRIX SUBTRACTION OF MATRIX 1 & MATRIX 2,') 14589 CALL DPWRST('XXX','BUG ') 14590 WRITE(ICOUT,2213) 14591 2213 FORMAT(' THE NUMBER OF ROWS AND COLUMNS IN MATRIX 1') 14592 CALL DPWRST('XXX','BUG ') 14593 WRITE(ICOUT,2214) 14594 2214 FORMAT(' MUST EQUAL') 14595 CALL DPWRST('XXX','BUG ') 14596 WRITE(ICOUT,2215) 14597 2215 FORMAT(' THE NUMBER OF ROWS AND COLUMNS IN MATRIX 2;') 14598 CALL DPWRST('XXX','BUG ') 14599 WRITE(ICOUT,2216) 14600 2216 FORMAT(' SUCH WAS NOT THE CASE HERE.') 14601 CALL DPWRST('XXX','BUG ') 14602 WRITE(ICOUT,2217)NR1,NC1 14603 2217 FORMAT(' MATRIX 1--',I8,' ROWS BY ',I8,' COLUMNS') 14604 CALL DPWRST('XXX','BUG ') 14605 WRITE(ICOUT,2218)NR2,NC2 14606 2218 FORMAT(' MATRIX 2--',I8,' ROWS BY ',I8,' COLUMNS') 14607 CALL DPWRST('XXX','BUG ') 14608 IERROR='YES' 14609 GOTO9000 14610 2219 CONTINUE 14611C 14612C 14613 DO2221I=1,NR1 14614 DO2222J=1,NC1 14615 DYM1=YM1(I,J) 14616 DYM2=YM2(I,J) 14617 DYM9=DYM1-DYM2 14618 YM9(I,J)=DYM9 14619 2222 CONTINUE 14620 2221 CONTINUE 14621 ITYP9='MATR' 14622 NR9=NR1 14623 NC9=NC1 14624 IUPFLG='SUBS' 14625 GOTO9000 14626C 14627 2230 CONTINUE 14628 IF(NR1.EQ.N2)GOTO2239 14629 WRITE(ICOUT,999) 14630 CALL DPWRST('XXX','BUG ') 14631 WRITE(ICOUT,2231) 14632 2231 FORMAT('***** ERROR IN MATARI--') 14633 CALL DPWRST('XXX','BUG ') 14634 WRITE(ICOUT,2232) 14635 2232 FORMAT(' FOR MATRIX SUBTRACTION OF MATRIX 1 & VECTOR 2,') 14636 CALL DPWRST('XXX','BUG ') 14637 WRITE(ICOUT,2233) 14638 2233 FORMAT(' THE NUMBER OF ROWS AND COLUMNS IN MATRIX 1') 14639 CALL DPWRST('XXX','BUG ') 14640 WRITE(ICOUT,2234) 14641 2234 FORMAT(' MUST EQUAL') 14642 CALL DPWRST('XXX','BUG ') 14643 WRITE(ICOUT,2235) 14644 2235 FORMAT(' THE NUMBER OF ROWS IN VECTOR 2;') 14645 CALL DPWRST('XXX','BUG ') 14646 WRITE(ICOUT,2236) 14647 2236 FORMAT(' SUCH WAS NOT THE CASE HERE.') 14648 CALL DPWRST('XXX','BUG ') 14649 WRITE(ICOUT,2237)NR1,NC1 14650 2237 FORMAT(' MATRIX 1--',I8,' ROWS BY ',I8,' COLUMNS') 14651 CALL DPWRST('XXX','BUG ') 14652 WRITE(ICOUT,2238)N2 14653 2238 FORMAT(' VECTOR 2--',I8,' ROWS') 14654 CALL DPWRST('XXX','BUG ') 14655 IERROR='YES' 14656 GOTO9000 14657 2239 CONTINUE 14658C 14659 DO2241I=1,NR1 14660 DYM2=Y2(I) 14661 DO2242J=1,NC1 14662 DYM1=YM1(I,J) 14663 DYM9=DYM1-DYM2 14664 YM9(I,J)=DYM9 14665 2242 CONTINUE 14666 2241 CONTINUE 14667 ITYP9='MATR' 14668 NR9=NR1 14669 NC9=NC1 14670 IUPFLG='SUBS' 14671 GOTO9000 14672C 14673 2250 CONTINUE 14674 IF(N1.EQ.NR2)GOTO2259 14675 WRITE(ICOUT,999) 14676 CALL DPWRST('XXX','BUG ') 14677 WRITE(ICOUT,2251) 14678 2251 FORMAT('***** ERROR IN MATARI--') 14679 CALL DPWRST('XXX','BUG ') 14680 WRITE(ICOUT,2252) 14681 2252 FORMAT(' FOR MATRIX SUBTRACTION OF VECTOR 1 & MATRIX 2,') 14682 CALL DPWRST('XXX','BUG ') 14683 WRITE(ICOUT,2253) 14684 2253 FORMAT(' THE NUMBER OF ROWS IN VECTOR 1;') 14685 CALL DPWRST('XXX','BUG ') 14686 WRITE(ICOUT,2254) 14687 2254 FORMAT(' MUST EQUAL') 14688 CALL DPWRST('XXX','BUG ') 14689 WRITE(ICOUT,2255) 14690 2255 FORMAT(' THE NUMBER OF ROWS AND COLUMNS IN MATRIX 2') 14691 CALL DPWRST('XXX','BUG ') 14692 WRITE(ICOUT,2256) 14693 2256 FORMAT(' SUCH WAS NOT THE CASE HERE.') 14694 CALL DPWRST('XXX','BUG ') 14695 WRITE(ICOUT,2257)N1 14696 2257 FORMAT(' VECTOR 1--',I8,' ROWS') 14697 CALL DPWRST('XXX','BUG ') 14698 WRITE(ICOUT,2258)NR2,NC2 14699 2258 FORMAT(' MATRIX 2--',I8,' ROWS BY ',I8,' COLUMNS') 14700 CALL DPWRST('XXX','BUG ') 14701 IERROR='YES' 14702 GOTO9000 14703 2259 CONTINUE 14704C 14705 DO2261I=1,NR2 14706 DYM1=Y1(I) 14707 DO2262J=1,NC2 14708 DYM2=YM2(I,J) 14709 DYM9=DYM1-DYM2 14710 YM9(I,J)=DYM9 14711 2262 CONTINUE 14712 2261 CONTINUE 14713 ITYP9='MATR' 14714 NR9=NR2 14715 NC9=NC2 14716 IUPFLG='SUBS' 14717 GOTO9000 14718C 14719 2270 CONTINUE 14720 DYM2=YS2 14721 DO2271I=1,NR1 14722 DO2272J=1,NC1 14723 DYM1=YM1(I,J) 14724 DYM9=DYM1-DYM2 14725 YM9(I,J)=DYM9 14726 2272 CONTINUE 14727 2271 CONTINUE 14728 ITYP9='MATR' 14729 NR9=NR1 14730 NC9=NC1 14731 IUPFLG='SUBS' 14732 GOTO9000 14733C 14734 2280 CONTINUE 14735 DYM1=YS1 14736 DO2281I=1,NR2 14737 DO2282J=1,NC2 14738 DYM2=YM2(I,J) 14739 DYM9=DYM1-DYM2 14740 YM9(I,J)=DYM9 14741 2282 CONTINUE 14742 2281 CONTINUE 14743 ITYP9='MATR' 14744 NR9=NR2 14745 NC9=NC2 14746 IUPFLG='SUBS' 14747 GOTO9000 14748C 14749C ********************************************* 14750C ** STEP 23-- ** 14751C ** TREAT THE MATRIX MULTIPLICATION CASE ** 14752C ********************************************* 14753C 14754 2300 CONTINUE 14755C 14756 IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'MATR')GOTO2310 14757 IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'VARI')GOTO2330 14758 IF(ITYPA1.EQ.'VARI'.AND.ITYPA2.EQ.'MATR')GOTO2350 14759 IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'PARA')GOTO2370 14760 IF(ITYPA1.EQ.'PARA'.AND.ITYPA2.EQ.'MATR')GOTO2380 14761C 14762 WRITE(ICOUT,999) 14763 CALL DPWRST('XXX','BUG ') 14764 WRITE(ICOUT,2301) 14765 2301 FORMAT('***** ERROR IN MATARI--') 14766 CALL DPWRST('XXX','BUG ') 14767 WRITE(ICOUT,2302) 14768 2302 FORMAT(' ILLEGAL ARGUMENT TYPES FOR MATRIX MULTIPLIC.') 14769 CALL DPWRST('XXX','BUG ') 14770 WRITE(ICOUT,2303)ITYPA1 14771 2303 FORMAT(' TYPE FOR ARGUMENT 1 = ',A4) 14772 CALL DPWRST('XXX','BUG ') 14773 WRITE(ICOUT,2304)ITYPA2 14774 2304 FORMAT(' TYPE FOR ARGUMENT 2 = ',A4) 14775 CALL DPWRST('XXX','BUG ') 14776 IERROR='YES' 14777 GOTO9000 14778C 14779 2310 CONTINUE 14780 IF(NC1.EQ.NR2)GOTO2319 14781 WRITE(ICOUT,999) 14782 CALL DPWRST('XXX','BUG ') 14783 WRITE(ICOUT,2311) 14784 2311 FORMAT('***** ERROR IN MATARI--') 14785 CALL DPWRST('XXX','BUG ') 14786 WRITE(ICOUT,2312) 14787 2312 FORMAT(' FOR MATRIX MULTIPLIC. OF MATRIX 1 & MATRIX 2,') 14788 CALL DPWRST('XXX','BUG ') 14789 WRITE(ICOUT,2313) 14790 2313 FORMAT(' THE NUMBER OF COLUMNS IN MATRIX 1') 14791 CALL DPWRST('XXX','BUG ') 14792 WRITE(ICOUT,2314) 14793 2314 FORMAT(' MUST EQUAL') 14794 CALL DPWRST('XXX','BUG ') 14795 WRITE(ICOUT,2315) 14796 2315 FORMAT(' THE NUMBER OF ROWS IN MATRIX 2;') 14797 CALL DPWRST('XXX','BUG ') 14798 WRITE(ICOUT,2316) 14799 2316 FORMAT(' SUCH WAS NOT THE CASE HERE.') 14800 CALL DPWRST('XXX','BUG ') 14801 WRITE(ICOUT,2317)NR1,NC1 14802 2317 FORMAT(' MATRIX 1--',I8,' ROWS BY ',I8,' COLUMNS') 14803 CALL DPWRST('XXX','BUG ') 14804 WRITE(ICOUT,2318)NR2,NC2 14805 2318 FORMAT(' MATRIX 2--',I8,' ROWS BY ',I8,' COLUMNS') 14806 CALL DPWRST('XXX','BUG ') 14807 IERROR='YES' 14808 GOTO9000 14809 2319 CONTINUE 14810C 14811 DO2321I=1,NR1 14812 DO2322J=1,NC2 14813 DSUM=0.0D0 14814 DO2323K=1,NC1 14815 DYM1=YM1(I,K) 14816 DYM2=YM2(K,J) 14817 DYM9=DYM1*DYM2 14818 DSUM=DSUM+DYM9 14819 2323 CONTINUE 14820 YM9(I,J)=DSUM 14821 2322 CONTINUE 14822 2321 CONTINUE 14823 ITYP9='MATR' 14824 NR9=NR1 14825 NC9=NC2 14826 IUPFLG='FULL' 14827 GOTO9000 14828C 14829 2330 CONTINUE 14830 IF(NC1.EQ.N2)GOTO2339 14831 WRITE(ICOUT,999) 14832 CALL DPWRST('XXX','BUG ') 14833 WRITE(ICOUT,2331) 14834 2331 FORMAT('***** ERROR IN MATARI--') 14835 CALL DPWRST('XXX','BUG ') 14836 WRITE(ICOUT,2332) 14837 2332 FORMAT(' FOR MATRIX MULTIPLIC. OF MATRIX 1 & VECTOR 2,') 14838 CALL DPWRST('XXX','BUG ') 14839 WRITE(ICOUT,2333) 14840 2333 FORMAT(' THE NUMBER OF COLUMNS IN MATRIX 1') 14841 CALL DPWRST('XXX','BUG ') 14842 WRITE(ICOUT,2334) 14843 2334 FORMAT(' MUST EQUAL') 14844 CALL DPWRST('XXX','BUG ') 14845 WRITE(ICOUT,2335) 14846 2335 FORMAT(' THE NUMBER OF ROWS IN VECTOR 2;') 14847 CALL DPWRST('XXX','BUG ') 14848 WRITE(ICOUT,2336) 14849 2336 FORMAT(' SUCH WAS NOT THE CASE HERE.') 14850 CALL DPWRST('XXX','BUG ') 14851 WRITE(ICOUT,2337)NR1,NC1 14852 2337 FORMAT(' MATRIX 1--',I8,' ROWS BY ',I8,' COLUMNS') 14853 CALL DPWRST('XXX','BUG ') 14854 WRITE(ICOUT,2338)N2 14855 2338 FORMAT(' VECTOR 2--',I8,' ROWS') 14856 CALL DPWRST('XXX','BUG ') 14857 IERROR='YES' 14858 GOTO9000 14859 2339 CONTINUE 14860C 14861 DO2341I=1,NR1 14862 J=1 14863 DSUM=0.0D0 14864 DO2343K=1,NC1 14865 DYM1=YM1(I,K) 14866 DYM2=Y2(K) 14867 DYM9=DYM1*DYM2 14868 DSUM=DSUM+DYM9 14869 2343 CONTINUE 14870 VECT9(I)=DSUM 14871 2341 CONTINUE 14872 ITYP9='VECT' 14873 NVECT9=NR1 14874 IUPFLG='FULL' 14875 GOTO9000 14876C 14877 2350 CONTINUE 14878 IF(1.EQ.NR2)GOTO2359 14879 WRITE(ICOUT,999) 14880 CALL DPWRST('XXX','BUG ') 14881 WRITE(ICOUT,2351) 14882 2351 FORMAT('***** ERROR IN MATARI--') 14883 CALL DPWRST('XXX','BUG ') 14884 WRITE(ICOUT,2352) 14885 2352 FORMAT(' FOR MATRIX MULTIPLIC. OF VECTOR 1 & MATRIX 2,') 14886 CALL DPWRST('XXX','BUG ') 14887 WRITE(ICOUT,2355) 14888 2355 FORMAT(' THE NUMBER OF ROWS IN MATRIX 2 MUST = 1') 14889 CALL DPWRST('XXX','BUG ') 14890 WRITE(ICOUT,2356) 14891 2356 FORMAT(' SUCH WAS NOT THE CASE HERE.') 14892 CALL DPWRST('XXX','BUG ') 14893 WRITE(ICOUT,2358)NR2,NC2 14894 2358 FORMAT(' MATRIX 2--',I8,' ROWS BY ',I8,' COLUMNS') 14895 CALL DPWRST('XXX','BUG ') 14896 IERROR='YES' 14897 GOTO9000 14898 2359 CONTINUE 14899C 14900 DO2361I=1,NR1 14901 DO2362J=1,NC2 14902 DSUM=0.0D0 14903 K=1 14904 DYM1=Y1(I) 14905 DYM2=YM2(K,J) 14906 DYM9=DYM1*DYM2 14907 DSUM=DSUM+DYM9 14908 YM9(I,J)=DSUM 14909 2362 CONTINUE 14910 2361 CONTINUE 14911 ITYP9='MATR' 14912 NR9=N1 14913 NC9=NC2 14914 IUPFLG='FULL' 14915 GOTO9000 14916C 14917 2370 CONTINUE 14918 DYM2=YS2 14919 DO2371I=1,NR1 14920 DO2372J=1,NC1 14921 DYM1=YM1(I,J) 14922 DYM9=DYM1*DYM2 14923 YM9(I,J)=DYM9 14924 2372 CONTINUE 14925 2371 CONTINUE 14926 ITYP9='MATR' 14927 NR9=NR1 14928 NC9=NC1 14929 IUPFLG='FULL' 14930 GOTO9000 14931C 14932 2380 CONTINUE 14933 DYM1=YS1 14934 DO2381I=1,NR2 14935 DO2382J=1,NC2 14936 DYM2=YM2(I,J) 14937 DYM9=DYM1*DYM2 14938 YM9(I,J)=DYM9 14939 2382 CONTINUE 14940 2381 CONTINUE 14941 ITYP9='MATR' 14942 NR9=NR2 14943 NC9=NC2 14944 IUPFLG='FULL' 14945 GOTO9000 14946C 14947C ********************************************* 14948C ** STEP 24-- ** 14949C ** TREAT THE MATRIX SOLUTION CASE ** 14950C ** REFERENCE--PRESS ET AL, PAGE 37 ** 14951C ********************************************* 14952C 14953 2400 CONTINUE 14954C 14955 IF(NR1.EQ.N2)GOTO2409 14956 WRITE(ICOUT,999) 14957 CALL DPWRST('XXX','BUG ') 14958 WRITE(ICOUT,2401) 14959 2401 FORMAT('***** ERROR IN MATARI--') 14960 CALL DPWRST('XXX','BUG ') 14961 WRITE(ICOUT,2402) 14962 2402 FORMAT(' FOR SOLVING A MATRIX EQUATION SUCH AS A*X = B,') 14963 CALL DPWRST('XXX','BUG ') 14964 WRITE(ICOUT,2403) 14965 2403 FORMAT(' THE NUMBER OF ROWS IN THE LEFT-SIDE MATRIX') 14966 CALL DPWRST('XXX','BUG ') 14967 WRITE(ICOUT,2404) 14968 2404 FORMAT(' MUST EQUAL') 14969 CALL DPWRST('XXX','BUG ') 14970 WRITE(ICOUT,2405) 14971 2405 FORMAT(' THE NUMBER OF ROWS IN THE RIGHT-SIDE VECTOR;') 14972 CALL DPWRST('XXX','BUG ') 14973 WRITE(ICOUT,2406) 14974 2406 FORMAT(' SUCH WAS NOT THE CASE HERE.') 14975 CALL DPWRST('XXX','BUG ') 14976 WRITE(ICOUT,2407)NR1 14977 2407 FORMAT(' NUMBER OF ROWS IN THE MATRIX = ',I8) 14978 CALL DPWRST('XXX','BUG ') 14979 WRITE(ICOUT,2408)N2 14980 2408 FORMAT(' NUMBER OF ROWS IN THE VECTOR = ',I8) 14981 CALL DPWRST('XXX','BUG ') 14982 IERROR='YES' 14983 GOTO9000 14984 2409 CONTINUE 14985C 14986 DO2451I=1,N2 14987CCCCC VECT9(I)=YM2(1,I) 14988CCCCC VECT9(I)=YM2(I,1) 14989 VECT9(I)=Y2(I) 14990 2451 CONTINUE 14991C 14992CCCCC JULY 1993. REPLACE NUMERICAL RECIPES ALGORITHM WITH LINPACK 14993CCCCC ALGORITHM. 14994CCCCC CALL LUDCMP(YMJUNK,NR1,MAXROM,INDEX,DP1M1) 14995CCCCC CALL LUBKSB(YMJUNK,NR1,MAXROM,INDEX,VECT9) 14996 CALL SGECO(YM1,MAXROM,NR1,INDEX,RCOND,Y3) 14997 IF(IFEEDB.EQ.'ON')THEN 14998 WRITE(ICOUT,999) 14999 CALL DPWRST('XXX','BUG ') 15000 WRITE(ICOUT,2461)RCOND 15001 CALL DPWRST('XXX','TEXT ') 15002 ENDIF 15003 2461 FORMAT('THE RECIPROCAL CONDITION NUMBER FOR THE MATRIX = ',E15.7) 15004 EPS=1.0E-20 15005 IF(RCOND.LE.EPS)THEN 15006 WRITE(ICOUT,999) 15007 CALL DPWRST('XXX','BUG ') 15008 WRITE(ICOUT,2471) 15009 CALL DPWRST('XXX','ERRO ') 15010 WRITE(ICOUT,2472) 15011 CALL DPWRST('XXX','ERRO ') 15012 IERROR='YES' 15013 ELSE 15014 IJOB=0 15015 CALL SGESL(YM1,MAXROM,NR1,INDEX,VECT9,IJOB) 15016 END IF 15017 2471 FORMAT('****** ERROR IN MATARI ********') 15018 2472 FORMAT(' THE INPUT MATRIX IS SINGULAR') 15019CCCCC END CHANGE 15020C 15021 ITYP9='VECT' 15022 NVECT9=NR1 15023 IUPFLG='FULL' 15024 GOTO9000 15025C 15026C ********************************************* 15027C ** STEP 25-- ** 15028C ** TREAT THE MATRIX INVERSE CASE ** 15029C ** REFERENCE--PRESS ET AL, PAGE 38 ** 15030C ********************************************* 15031C 15032 2500 CONTINUE 15033C 15034 IF(NR1.NE.NC1)THEN 15035 WRITE(ICOUT,999) 15036 CALL DPWRST('XXX','BUG ') 15037 WRITE(ICOUT,2501) 15038 2501 FORMAT('***** ERROR IN MATRIX INVERSE--') 15039 CALL DPWRST('XXX','BUG ') 15040 WRITE(ICOUT,2502) 15041 2502 FORMAT(' FOR MATRIX INVERSE, THE NUMBER OF ROWS IN THE') 15042 CALL DPWRST('XXX','BUG ') 15043 WRITE(ICOUT,2503) 15044 2503 FORMAT(' MATRIX MUST EQUAL THE NUMBER OF COLUMNS IN THE ', 15045 1 'MATRIX.') 15046 CALL DPWRST('XXX','BUG ') 15047 WRITE(ICOUT,2504)NR1 15048 2504 FORMAT(' NUMBER OF ROWS = ',I8) 15049 CALL DPWRST('XXX','BUG ') 15050 WRITE(ICOUT,2505)NC1 15051 2505 FORMAT(' NUMBER OF COLUMNS = ',I8) 15052 CALL DPWRST('XXX','BUG ') 15053 IERROR='YES' 15054 GOTO9000 15055 ENDIF 15056C 15057 DO2511I=1,NR1 15058 DO2512J=1,NC1 15059 YM9(I,J)=0.0 15060 2512 CONTINUE 15061 YM9(I,I)=1.0 15062 2511 CONTINUE 15063CCCCC JULY 1993. REPLACE NUMERICAL RECIPES ALGORITHM WITH LINPACK 15064CCCCC ALGORITHM. 15065C 15066CCCCC CALL LUDCMP(YMJUNK,NR1,MAXROM,INDEX,DP1M1) 15067C 15068CCCCC DO2521J=1,NR1 15069CCCCC CALL LUBKSB(YMJUNK,NR1,MAXROM,INDEX,YM9(1,J)) 15070C2521 CONTINUE 15071 CALL SGECO(YM1,MAXROM,NR1,INDEX,RCOND,Y3) 15072 IF(IFEEDB.EQ.'ON')THEN 15073 WRITE(ICOUT,999) 15074 CALL DPWRST('XXX','BUG ') 15075 WRITE(ICOUT,2521)RCOND 15076 CALL DPWRST('XXX','TEXT ') 15077 ENDIF 15078 2521 FORMAT('THE RECIPROCAL CONDITION NUMBER FOR THE MATRIX = ',G15.7) 15079 EPS=1.0E-20 15080 IF(RCOND.LE.EPS)THEN 15081 WRITE(ICOUT,999) 15082 CALL DPWRST('XXX','BUG ') 15083 WRITE(ICOUT,2561) 15084 CALL DPWRST('XXX','ERRO') 15085 WRITE(ICOUT,2523) 15086 2523 FORMAT(' THE INPUT MATRIX IS SINGULAR.') 15087 CALL DPWRST('XXX','ERRO') 15088 IERROR='YES' 15089 ELSE 15090 IJOB=1 15091 CALL SGEDI(YM1,MAXROM,NR1,INDEX,Y3,Y4,IJOB) 15092 DO2531J=1,NC1 15093 DO2532I=1,NR1 15094 YM9(I,J)=YM1(I,J) 15095 2532 CONTINUE 15096 2531 CONTINUE 15097 END IF 15098CCCCC END CHANGE 15099C 15100 ITYP9='MATR' 15101 NR9=NR1 15102 NC9=NC1 15103 IUPFLG='FULL' 15104 GOTO9000 15105C 15106C ********************************************* 15107C ** STEP 25B- ** 15108C ** TREAT THE MATRIX CONDITION NUMBER CASE ** 15109C ********************************************* 15110C 15111 2560 CONTINUE 15112C 15113 IF(NR1.NE.NC1)THEN 15114 WRITE(ICOUT,999) 15115 CALL DPWRST('XXX','BUG ') 15116 WRITE(ICOUT,2561) 15117 2561 FORMAT('***** ERROR IN MATRIX CONDITION--') 15118 CALL DPWRST('XXX','BUG ') 15119 WRITE(ICOUT,2562) 15120 2562 FORMAT(' FOR MATRIX CONDITION NUMBER, THE NUMBER OF ', 15121 1 'ROWS IN THE') 15122 CALL DPWRST('XXX','BUG ') 15123 WRITE(ICOUT,2563) 15124 2563 FORMAT(' MATRIX MUST EQUAL THE NUMBER OF COLUMNS IN THE ', 15125 1 'MATRIX.') 15126 CALL DPWRST('XXX','BUG ') 15127 WRITE(ICOUT,2564)NR1 15128 2564 FORMAT(' NUMBER OF ROWS = ',I8) 15129 CALL DPWRST('XXX','BUG ') 15130 WRITE(ICOUT,2565)NC1 15131 2565 FORMAT(' NUMBER OF COLUMNS = ',I8) 15132 CALL DPWRST('XXX','BUG ') 15133 IERROR='YES' 15134 GOTO9000 15135 ENDIF 15136C 15137 CALL SGECO(YM1,MAXROM,NR1,INDEX,RCOND,Y3) 15138 IF(IFEEDB.EQ.'ON')THEN 15139 WRITE(ICOUT,999) 15140 CALL DPWRST('XXX','BUG ') 15141 WRITE(ICOUT,2521)RCOND 15142 CALL DPWRST('XXX','TEXT ') 15143 ENDIF 15144C 15145 ITYP9='SCAL' 15146 SCAL9=RCOND 15147 IF(IMCASE.EQ.'MACN')SCAL9=1.0/RCOND 15148 IUPFLG='FULL' 15149 GOTO9000 15150C 15151C ********************************************* 15152C ** STEP 26-- ** 15153C ** TREAT THE MATRIX TRANSPOSE CASE ** 15154C ********************************************* 15155C 15156 2600 CONTINUE 15157C 15158 IF(NR1.GT.MAXCOM)THEN 15159 WRITE(ICOUT,999) 15160 CALL DPWRST('XXX','BUG ') 15161 WRITE(ICOUT,2601) 15162 2601 FORMAT('***** ERROR IN MATARI--') 15163 CALL DPWRST('XXX','BUG ') 15164 WRITE(ICOUT,2603)NR1 15165 2603 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX,',I5, 15166 1 'EXCEEDS THE MAXIMUM') 15167 CALL DPWRST('XXX','BUG ') 15168 WRITE(ICOUT,2605)MAXCOM 15169 2605 FORMAT(' NUMBER OF COLUMNS FOR A MATRIX,',I5,'.') 15170 CALL DPWRST('XXX','BUG ') 15171 WRITE(ICOUT,2607) 15172 2607 FORMAT(' THE MATRIX TRANSPOSE WAS NOT COMPUTED.') 15173 CALL DPWRST('XXX','BUG ') 15174 IERROR='YES' 15175 GOTO9000 15176 ENDIF 15177C 15178 DO2611I=1,NR1 15179 DO2612J=1,NC1 15180 YM9(J,I)=YM1(I,J) 15181 2612 CONTINUE 15182 2611 CONTINUE 15183C 15184 ITYP9='MATR' 15185 NR9=NC1 15186 NC9=NR1 15187 IUPFLG='FULL' 15188 GOTO9000 15189C 15190C ********************************************* 15191C ** STEP 27-- ** 15192C ** TREAT THE MATRIX ADJOINT CASE ** 15193C ********************************************* 15194CCCCC JULY 1993. IMPLENENT THIS COMMAND. NOTE THAT THE CLASSICAL 15195CCCCC ADJOINT IS ESSENTIALLY THE MATRIX CONTAINING THE COFACTORS 15196CCCCC FOR EACH ELEMENT. THIS CALCULATES THE DETERMINANT AT 15197CCCCC EACH MATRIX SUB-ELEMENT, SO CAN GET TIME-CONSUMING FOR LARGE 15198CCCCC MATRICES. 15199C 15200 2700 CONTINUE 15201C 15202CCCCC WRITE(ICOUT,999) 15203CCCCC CALL DPWRST('XXX','BUG ') 15204CCCCC WRITE(ICOUT,2711) 15205C2711 FORMAT('***** ERROR IN MATARI--') 15206CCCCC CALL DPWRST('XXX','BUG ') 15207CCCCC WRITE(ICOUT,2712) 15208C2712 FORMAT(' THE MATRIX ADJOINT COMMAND') 15209CCCCC CALL DPWRST('XXX','BUG ') 15210CCCCC WRITE(ICOUT,2713) 15211C2713 FORMAT(' IS NOT YET IMPLEMENTED.') 15212CCCCC CALL DPWRST('XXX','BUG ') 15213CCCCC IERROR='YES' 15214C 15215 IF(NR1.EQ.NC1)GOTO2709 15216 WRITE(ICOUT,999) 15217 CALL DPWRST('XXX','BUG ') 15218 WRITE(ICOUT,2701) 15219 2701 FORMAT('***** ERROR IN MATARI--') 15220 CALL DPWRST('XXX','BUG ') 15221 WRITE(ICOUT,2702) 15222 2702 FORMAT(' FOR MATRIX ADJOINT,') 15223 CALL DPWRST('XXX','BUG ') 15224 WRITE(ICOUT,2703) 15225 2703 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX') 15226 CALL DPWRST('XXX','BUG ') 15227 WRITE(ICOUT,2704) 15228 2704 FORMAT(' MUST EQUAL') 15229 CALL DPWRST('XXX','BUG ') 15230 WRITE(ICOUT,2705) 15231 2705 FORMAT(' THE NUMBER OF COLUMNS IN THE MATRIX;') 15232 CALL DPWRST('XXX','BUG ') 15233 WRITE(ICOUT,2706) 15234 2706 FORMAT(' SUCH WAS NOT THE CASE HERE.') 15235 CALL DPWRST('XXX','BUG ') 15236 WRITE(ICOUT,2707)NR1 15237 2707 FORMAT(' NUMBER OF ROWS =',I8) 15238 CALL DPWRST('XXX','BUG ') 15239 WRITE(ICOUT,2708)NC1 15240 2708 FORMAT(' NUMBER OF COLUMNS =',I8) 15241 CALL DPWRST('XXX','BUG ') 15242 IERROR='YES' 15243 GOTO9000 15244 2709 CONTINUE 15245C 15246 DO2790IROWID=1,NR1 15247 IYS2=IROWID 15248 DO2780ICOLID=1,NC1 15249 IYS3=ICOLID 15250 I2=0 15251 J2=0 15252 DO2711I=1,NR1 15253 IF(I.EQ.IYS2)GOTO2711 15254 I2=I2+1 15255 NRJ=I2 15256 J2=0 15257 DO2712J=1,NC1 15258 IF(J.EQ.IYS3)GOTO2712 15259 J2=J2+1 15260 NCJ=J2 15261 YM2(I2,J2)=YM1(I,J) 15262 2712 CONTINUE 15263 2711 CONTINUE 15264C 15265 IF(NRJ.GE.1.AND.NCJ.GE.1)GOTO2729 15266 WRITE(ICOUT,999) 15267 CALL DPWRST('XXX','BUG ') 15268 WRITE(ICOUT,2721) 15269 2721 FORMAT('***** ERROR IN MATARI--') 15270 CALL DPWRST('XXX','BUG ') 15271 WRITE(ICOUT,2722) 15272 2722 FORMAT(' FOR MATRIX COFACTOR,') 15273 CALL DPWRST('XXX','BUG ') 15274 WRITE(ICOUT,2723) 15275 2723 FORMAT(' THE NUMBER OF ROWS IN THE SUBMATRIX, AND') 15276 CALL DPWRST('XXX','BUG ') 15277 WRITE(ICOUT,2724) 15278 2724 FORMAT(' THE NUMBER OF COLUMNS IN THE SUBMATRIX') 15279 CALL DPWRST('XXX','BUG ') 15280 WRITE(ICOUT,2725) 15281 2725 FORMAT(' MUST BOTH BE 1 OR LARGER;') 15282 CALL DPWRST('XXX','BUG ') 15283 WRITE(ICOUT,2726) 15284 2726 FORMAT(' SUCH WAS NOT THE CASE HERE.') 15285 CALL DPWRST('XXX','BUG ') 15286 WRITE(ICOUT,2727)NRJ 15287 2727 FORMAT(' NUMBER OF ROWS =',I8) 15288 CALL DPWRST('XXX','BUG ') 15289 WRITE(ICOUT,2728)NCJ 15290 2728 FORMAT(' NUMBER OF COLUMNS =',I8) 15291 CALL DPWRST('XXX','BUG ') 15292 IERROR='YES' 15293 GOTO9000 15294 2729 CONTINUE 15295C 15296 IF(NRJ.EQ.NCJ)GOTO2739 15297 WRITE(ICOUT,999) 15298 CALL DPWRST('XXX','BUG ') 15299 WRITE(ICOUT,2731) 15300 2731 FORMAT('***** ERROR IN MATARI--') 15301 CALL DPWRST('XXX','BUG ') 15302 WRITE(ICOUT,2732) 15303 2732 FORMAT(' FOR MATRIX ADJOINT,') 15304 CALL DPWRST('XXX','BUG ') 15305 WRITE(ICOUT,2733) 15306 2733 FORMAT(' THE NUMBER OF ROWS IN THE SUBMATRIX') 15307 CALL DPWRST('XXX','BUG ') 15308 WRITE(ICOUT,2734) 15309 2734 FORMAT(' MUST EQUAL') 15310 CALL DPWRST('XXX','BUG ') 15311 WRITE(ICOUT,2735) 15312 2735 FORMAT(' THE NUMBER OF COLUMNS IN THE SUBMATRIX;') 15313 CALL DPWRST('XXX','BUG ') 15314 WRITE(ICOUT,2736) 15315 2736 FORMAT(' SUCH WAS NOT THE CASE HERE.') 15316 CALL DPWRST('XXX','BUG ') 15317 WRITE(ICOUT,2737)NRJ 15318 2737 FORMAT(' NUMBER OF ROWS =',I8) 15319 CALL DPWRST('XXX','BUG ') 15320 WRITE(ICOUT,2738)NCJ 15321 2738 FORMAT(' NUMBER OF COLUMNS =',I8) 15322 CALL DPWRST('XXX','BUG ') 15323 IERROR='YES' 15324 GOTO9000 15325 2739 CONTINUE 15326C 15327 CALL SGECO(YM2,MAXROM,NRJ,INDEX,RCOND,Y3) 15328 EPS=1.0E-20 15329 IF(RCOND.LE.EPS)THEN 15330 WRITE(ICOUT,999) 15331 CALL DPWRST('XXX','BUG ') 15332 WRITE(ICOUT,2771) 15333 CALL DPWRST('XXX','ERRO ') 15334 WRITE(ICOUT,2772) 15335 CALL DPWRST('XXX','ERRO ') 15336 WRITE(ICOUT,2773)IROWID,ICOLID 15337 CALL DPWRST('XXX','ERRO ') 15338 COFACT=0.0 15339 IERROR='YES' 15340 ELSE 15341 IJOB=10 15342 CALL SGEDI(YM2,MAXROM,NRJ,INDEX,Y3,Y4,IJOB) 15343 DET=Y3(1)*10.0**Y3(2) 15344 COFACT=DET 15345 IYS23=IYS2+IYS3 15346 IREM=IYS23-2*(IYS23/2) 15347 IF(IREM.EQ.1)COFACT=(-COFACT) 15348 END IF 15349 2771 FORMAT('****** ERROR IN MATARI ********') 15350 2772 FORMAT(' UNABLE TO COMPUTE THE DETERMINANT FOR') 15351 2773 FORMAT(' ROW ',I4,' AND COLUMN ',I4) 15352CCCCC END CHANGE 15353C 15354 YM9(IROWID,ICOLID)=COFACT 15355 2780 CONTINUE 15356 2790 CONTINUE 15357C 15358 ITYP9='MATR' 15359 NC9=NR1 15360 NR9=NR1 15361 SCAL9=COFACT 15362 IUPFLG='FULL' 15363 GOTO9000 15364C 15365C ******************************************************* 15366C ** STEP 28-- ** 15367C ** TREAT THE MATRIX CHARACTERISTIC EQUATION CASE ** 15368C ******************************************************* 15369C 15370 2800 CONTINUE 15371C 15372 WRITE(ICOUT,999) 15373 CALL DPWRST('XXX','BUG ') 15374 WRITE(ICOUT,2811) 15375 2811 FORMAT('***** ERROR IN MATARI--') 15376 CALL DPWRST('XXX','BUG ') 15377 WRITE(ICOUT,2812) 15378 2812 FORMAT(' THE MATRIX CHARACTERISTIC EQUATION COMMAND') 15379 CALL DPWRST('XXX','BUG ') 15380 WRITE(ICOUT,2813) 15381 2813 FORMAT(' IS NOT YET IMPLEMENTED.') 15382 CALL DPWRST('XXX','BUG ') 15383 IERROR='YES' 15384 GOTO9000 15385C 15386C 15387C ********************************************* 15388C ** STEP 29-- ** 15389C ** TREAT THE MATRIX EIGENVALUES CASE ** 15390C ********************************************* 15391C 15392 2900 CONTINUE 15393C 15394 IF(NR1.NE.NC1)THEN 15395 WRITE(ICOUT,999) 15396 CALL DPWRST('XXX','BUG ') 15397 WRITE(ICOUT,2901) 15398 2901 FORMAT('***** ERROR IN MATRIX EIGENVALUES--') 15399 CALL DPWRST('XXX','BUG ') 15400 WRITE(ICOUT,2903) 15401 2903 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX MUST EQUAL THE') 15402 CALL DPWRST('XXX','BUG ') 15403 WRITE(ICOUT,2905) 15404 2905 FORMAT(' NUMBER OF COLUMNS IN THE MATRIX; SUCH WAS NOT ', 15405 1 'THE CASE HERE.') 15406 CALL DPWRST('XXX','BUG ') 15407 WRITE(ICOUT,2907)NR1 15408 2907 FORMAT(' NUMBER OF ROWS =',I8) 15409 CALL DPWRST('XXX','BUG ') 15410 WRITE(ICOUT,2908)NC1 15411 2908 FORMAT(' NUMBER OF COLUMNS =',I8) 15412 CALL DPWRST('XXX','BUG ') 15413 IERROR='YES' 15414 GOTO9000 15415 ENDIF 15416C 15417 DO2911I=1,NR1 15418 I2=I 15419 DO2912J=I,NC1 15420 J2=J 15421 YM1IJ=YM1(I,J) 15422 YM1JI=YM1(J,I) 15423 IF(YM1IJ.NE.YM1JI)GOTO2930 15424 2912 CONTINUE 15425 2911 CONTINUE 15426 GOTO2939 15427C 15428CCCCC JULY 1993. ADD SUPPORT FOR NON-SYMMETRIC CASE. THIS CASE 15429CCCCC CAN HAVE COMPLEX EIGENVALUES. ROWS 1 THROUGH N OF THE OUTPUT 15430CCCCC VECTOR WILL CONTAIN THE REAL COMPONENT, ROWS N+1 THROUGH 2*N 15431CCCCC WILL CONTAIN THE COMPLEX COMPONENT. 15432 2930 CONTINUE 15433CCCCC WRITE(ICOUT,999) 15434CCCCC CALL DPWRST('XXX','BUG ') 15435CCCCC WRITE(ICOUT,2931) 15436C2931 FORMAT('***** ERROR IN MATARI--') 15437CCCCC CALL DPWRST('XXX','BUG ') 15438CCCCC WRITE(ICOUT,2932) 15439C2932 FORMAT(' FOR MATRIX EIGENVALUES,') 15440CCCCC CALL DPWRST('XXX','BUG ') 15441CCCCC WRITE(ICOUT,2933) 15442C2933 FORMAT(' THE MATRIX MUST BE SYMMETRIC') 15443CCCCC CALL DPWRST('XXX','BUG ') 15444CCCCC WRITE(ICOUT,2935) 15445C2935 FORMAT(' ( A(I,J) = A(J,I) FOR ALL I AND J ).') 15446CCCCC CALL DPWRST('XXX','BUG ') 15447CCCCC WRITE(ICOUT,2936) 15448C2936 FORMAT(' SUCH WAS NOT THE CASE HERE.') 15449CCCCC CALL DPWRST('XXX','BUG ') 15450CCCCC WRITE(ICOUT,2937)I2,J2,YM1IJ 15451C2937 FORMAT(' ELEMENT',I8,',',I8,' = ',E15.7) 15452CCCCC CALL DPWRST('XXX','BUG ') 15453CCCCC WRITE(ICOUT,2938)J2,I2,YM1JI 15454C2938 FORMAT(' ELEMENT',I8,',',I8,' = ',E15.7) 15455CCCCC CALL DPWRST('XXX','BUG ') 15456CCCCC IERROR='YES' 15457C 15458 IERR2=0 15459 IJOB=0 15460 CALL SGEEV(YM1,MAXROM,NR1,VECT9,YM2,MAXROM,Y3, 15461 1IJOB,IERR2) 15462 IF(IERR2.EQ.-1)THEN 15463 IERROR='YES' 15464 WRITE(ICOUT,2941) 15465 WRITE(ICOUT,2942) 15466 ELSE IF(IERR2.GT.0)THEN 15467 IERROR='YES' 15468 WRITE(ICOUT,2941) 15469 WRITE(ICOUT,2947) 15470 WRITE(ICOUT,2948)IERR2 15471 WRITE(ICOUT,2949)IERR2-1 15472 END IF 15473 2941 FORMAT('******** ERROR FROM MATRIX EIGENVALUES--') 15474 2942 FORMAT(' PROBLEM WITH MATRIX DIMENSIONS') 15475 2947 FORMAT(' THE EIGENVALUE ALGORITHM FAILED TO CONVERGE ') 15476 2948 FORMAT(' FOR EIGENVALUE ',I4) 15477 2949 FORMAT(' EIGENVALUES 1 THRU ',I4,' ARE CORRECT') 15478CCCCC END CHANGE 15479C 15480 ITYP9='VECT' 15481 NVECT9=2*NR1 15482 GOTO9000 15483CCCCC END CHANGES 15484 2939 CONTINUE 15485C 15486CCCCC JULY 1993. REPLACE NUMERICAL RECIPES ALGORITHM WITH EISPACK 15487CCCCC ALGORITHM. 15488CCCCC CALL JACOBI(YMJUNK,NR1,MAXROM,VECT9,YMJUN2,NJACIT) 15489C 15490 IERR2=0 15491 IJOB=0 15492 CALL SSIEV(YM1,MAXROM,NR1,VECT9,Y3,IJOB,IERR2) 15493 IF(IERR2.EQ.-1)THEN 15494 IERROR='YES' 15495 WRITE(ICOUT,2961) 15496 WRITE(ICOUT,2962) 15497 ELSE IF(IERR2.EQ.-2)THEN 15498 IERROR='YES' 15499 WRITE(ICOUT,2961) 15500 WRITE(ICOUT,2963) 15501 ELSE IF(IERR2.GT.0)THEN 15502 IERROR='YES' 15503 WRITE(ICOUT,2961) 15504 WRITE(ICOUT,2967) 15505 WRITE(ICOUT,2968)IERR2 15506 WRITE(ICOUT,2969)IERR2-1 15507 END IF 15508 2961 FORMAT('******** ERROR FROM MATARI ************') 15509 2962 FORMAT(' THE NUMBER OF ROWS GREATER THAN MAXIMUM') 15510 2963 FORMAT(' LESS THAN 1 ROW') 15511 2967 FORMAT(' THE EIGENVALUE ALGORITHM FAILED TO CONVERGE ') 15512 2968 FORMAT(' FOR EIGENVALUE ',I4) 15513 2969 FORMAT(' EIGENVALUES 1 THRU ',I4,' ARE CORRECT') 15514CCCCC END CHANGE 15515C 15516 ITYP9='VECT' 15517 NVECT9=NR1 15518 IUPFLG='FULL' 15519 GOTO9000 15520C 15521C ********************************************* 15522C ** STEP 30-- ** 15523C ** TREAT THE MATRIX EIGENVECTORS CASE ** 15524C ********************************************* 15525C 15526 3000 CONTINUE 15527C 15528 IF(NR1.NE.NC1)THEN 15529 WRITE(ICOUT,999) 15530 CALL DPWRST('XXX','BUG ') 15531 WRITE(ICOUT,3001) 15532 3001 FORMAT('***** ERROR IN MATRIX EIGENVECTORS--') 15533 CALL DPWRST('XXX','BUG ') 15534 WRITE(ICOUT,2903) 15535 CALL DPWRST('XXX','BUG ') 15536 WRITE(ICOUT,2905) 15537 CALL DPWRST('XXX','BUG ') 15538 WRITE(ICOUT,2907)NR1 15539 CALL DPWRST('XXX','BUG ') 15540 WRITE(ICOUT,2908)NC1 15541 CALL DPWRST('XXX','BUG ') 15542 IERROR='YES' 15543 GOTO9000 15544 ENDIF 15545C 15546 DO3011I=1,NR1 15547 I2=I 15548 DO3012J=I,NC1 15549 J2=J 15550 YM1IJ=YM1(I,J) 15551 YM1JI=YM1(J,I) 15552 IF(YM1IJ.NE.YM1JI)GOTO3030 15553 3012 CONTINUE 15554 3011 CONTINUE 15555 GOTO3039 15556C 15557 3030 CONTINUE 15558CCCCC JULY 1993. ADD SUPPORT FOR NON-SYMMETRIC CASE. THIS CASE 15559CCCCC CAN HAVE COMPLEX EIGENVECTORS. ROWS 1 THROUGH N OF THE OUTPUT 15560CCCCC MATRIX WILL CONTAIN THE REAL COMPONENT, ROWS N+1 THROUGH 2*N 15561CCCCC WILL CONTAIN THE COMPLEX COMPONENT. 15562CCCCC WRITE(ICOUT,999) 15563CCCCC CALL DPWRST('XXX','BUG ') 15564CCCCC WRITE(ICOUT,3031) 15565C3031 FORMAT('***** ERROR IN MATARI--') 15566CCCCC CALL DPWRST('XXX','BUG ') 15567CCCCC WRITE(ICOUT,3032) 15568C3032 FORMAT(' FOR MATRIX EIGENVECTORS,') 15569CCCCC CALL DPWRST('XXX','BUG ') 15570CCCCC WRITE(ICOUT,3033) 15571C3033 FORMAT(' THE MATRIX MUST BE SYMMETRIC') 15572CCCCC CALL DPWRST('XXX','BUG ') 15573CCCCC WRITE(ICOUT,3035) 15574C3035 FORMAT(' ( A(I,J) = A(J,I) FOR ALL I AND J ).') 15575CCCCC CALL DPWRST('XXX','BUG ') 15576CCCCC WRITE(ICOUT,3036) 15577C3036 FORMAT(' SUCH WAS NOT THE CASE HERE.') 15578CCCCC CALL DPWRST('XXX','BUG ') 15579CCCCC WRITE(ICOUT,3037)I2,J2,YM1IJ 15580C3037 FORMAT(' ELEMENT',I8,',',I8,' = ',E15.7) 15581CCCCC CALL DPWRST('XXX','BUG ') 15582CCCCC WRITE(ICOUT,3038)J2,I2,YM1JI 15583C3038 FORMAT(' ELEMENT',I8,',',I8,' = ',E15.7) 15584CCCCC CALL DPWRST('XXX','BUG ') 15585CCCCC IERROR='YES' 15586C 15587 IERR2=0 15588 IJOB=1 15589 DO3021J=1,MAXCOM 15590 DO3022I=1,MAXROM 15591 IF(J.GT.NR1 .OR. I.GT.NR1)YM1(I,J)=0.0 15592 YM2(I,J)=0.0 15593 YM9(I,J)=0.0 15594 3022 CONTINUE 15595 3021 CONTINUE 15596 DO3023I=1,MAXOBV 15597 VECT9(I)=0.0 15598 Y3(I)=0.0 15599 3023 CONTINUE 15600C 15601 CALL SGEEV(YM1,MAXROM,NR1,VECT9,YM2,MAXROM,Y3, 15602 1IJOB,IERR2) 15603 IF(IERR2.EQ.-1)THEN 15604 IERROR='YES' 15605 WRITE(ICOUT,3001) 15606 WRITE(ICOUT,3042) 15607 ELSE IF(IERR2.GT.0)THEN 15608 IERROR='YES' 15609 WRITE(ICOUT,3001) 15610 WRITE(ICOUT,3047) 15611 WRITE(ICOUT,3048)IERR2 15612 WRITE(ICOUT,3049)IERR2-1 15613 ELSE 15614 DO3045J=1,NR1 15615 DO3044I=1,2*NR1 15616 YM9(I,J)=YM2(I,J) 15617 3044 CONTINUE 15618 3045 CONTINUE 15619 END IF 15620 3042 FORMAT(' PROBLEM WITH MATRIX DIMENSIONS') 15621 3047 FORMAT(' THE EIGENVALUE ALGORITHM FAILED TO CONVERGE ') 15622 3048 FORMAT(' FOR EIGENVALUE ',I4) 15623 3049 FORMAT(' EIGENVECTORS 1 THRU ',I4,' ARE CORRECT') 15624CCCCC END CHANGE 15625C 15626 ITYP9='MATR' 15627 NR9=2*NR1 15628 NC9=NC1 15629 IUPFLG='FULL' 15630CCCCC END CHANGES 15631 GOTO9000 15632 3039 CONTINUE 15633C 15634CCCCC JULY 1993. REPLACE NUMERICAL RECIPES ALGORITHM WITH EISPACK 15635CCCCC ALGORITHM. 15636CCCCC CALL JACOBI(YMJUNK,NR1,MAXROM,VJUNK,YM9,NJACIT) 15637C 15638 IERR2=0 15639 IJOB=1 15640 DO3071I=1,MAXOBV 15641 VECT9(I)=0.0 15642 Y3(I)=0.0 15643 3071 CONTINUE 15644 CALL SSIEV(YM1,MAXROM,NR1,VECT9,Y3,IJOB,IERR2) 15645 IF(IERR2.EQ.-1)THEN 15646 IERROR='YES' 15647 WRITE(ICOUT,3001) 15648 WRITE(ICOUT,3062) 15649 ELSE IF(IERR2.EQ.-2)THEN 15650 IERROR='YES' 15651 WRITE(ICOUT,3001) 15652 WRITE(ICOUT,3063) 15653 ELSE IF(IERR2.GT.0)THEN 15654 IERROR='YES' 15655 WRITE(ICOUT,3001) 15656 WRITE(ICOUT,3067) 15657 WRITE(ICOUT,3068)IERR2 15658 WRITE(ICOUT,3069)IERR2-1 15659 ELSE 15660 DO3080J=1,NR1 15661 DO3082I=1,NR1 15662 YM9(I,J)=YM1(I,J) 15663 3082 CONTINUE 15664 3080 CONTINUE 15665 END IF 15666 3062 FORMAT(' THE NUMBER OF ROWS GREATER THAN MAXIMUM') 15667 3063 FORMAT(' LESS THAN 1 ROW') 15668 3067 FORMAT(' THE EIGENVALUE ALGORITHM FAILED TO CONVERGE ') 15669 3068 FORMAT(' FOR EIGENVALUE ',I4) 15670 3069 FORMAT(' EIGENVALUES 1 THRU ',I4,' ARE CORRECT') 15671CCCCC END CHANGE 15672C 15673 ITYP9='MATR' 15674 NR9=NR1 15675 NC9=NC1 15676 IUPFLG='FULL' 15677 GOTO9000 15678C 15679C ************************************************ 15680C ** STEP 31-- ** 15681C ** TREAT THE MATRIX RANK CASE ** 15682C ** COMPUTE FROM SINGULAR VALUE DECOMPOSITION ** 15683C ************************************************ 15684C 15685CCCCC IMPLEMENTED JULY 1993. 15686 3100 CONTINUE 15687C 15688 IERR2=0 15689 IJOB=0 15690 CALL SSVDC(YM1,MAXROM,NR1,NC1,VECT9,Y3,YM1,MAXROM, 15691 1YM1,MAXROM,Y4,IJOB,IERR2) 15692 ARANK=0. 15693 IF(ITYPA2.EQ.'PARA')THEN 15694 ATOL=YS2 15695 ELSE 15696CCCCC ATOL=0.0000001 15697 CALL SPDIV(RMXINT,2.0,IND,RESULT) 15698 ETA=RESULT+1.0 15699 CALL SPDIV(1.0,ETA,IND,ETA) 15700 ATOL=REAL(MAX(NR1,NC1))*VECT9(1)*ETA 15701 ENDIF 15702 NLAST=MIN(NR1,NC1) 15703 DO3120I=1,NLAST 15704 IF(VECT9(I).LE.ATOL)THEN 15705 ARANK=REAL(I-1) 15706 GOTO3129 15707 ENDIF 15708 3120 CONTINUE 15709 ARANK=REAL(NLAST) 15710 3129 CONTINUE 15711C 15712 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'TARI')GOTO3190 15713C 15714 WRITE(ICOUT,999) 15715 CALL DPWRST('XXX','BUG ') 15716 WRITE(ICOUT,3151) 15717 3151 FORMAT('***** COMPUTING RANK--') 15718 CALL DPWRST('XXX','BUG ') 15719 WRITE(ICOUT,3152)EPS,VECT9(1),ATOL 15720 3152 FORMAT('EPS,VECT((1),ATOL = ', 15721 1E15.7,2X,E15.7,2X,E15.7) 15722 CALL DPWRST('XXX','BUG ') 15723 NLAST=MIN(NR1+1,NC1) 15724 DO3180I=1,NLAST 15725 WRITE(ICOUT,3183)I,VECT9(I) 15726 3183 FORMAT('I,VECT9(I) = ',I4,2X,E15.7) 15727 CALL DPWRST('XXX','BUG ') 15728 3180 CONTINUE 15729C 15730 3190 CONTINUE 15731C 15732CCCCC END CHANGE 15733C 15734 ITYP9='SCAL' 15735 SCAL9=ARANK 15736 IUPFLG='FULL' 15737 GOTO9000 15738C 15739C ********************************************* 15740C ** STEP 32-- ** 15741C ** TREAT THE MATRIX DETERMINANT CASE ** 15742C ** REFERENCE--PRESS ET AL, PAGE 39 ** 15743C ********************************************* 15744C 15745 3200 CONTINUE 15746C 15747 IF(NR1.EQ.NC1)GOTO3209 15748 WRITE(ICOUT,999) 15749 CALL DPWRST('XXX','BUG ') 15750 WRITE(ICOUT,3201) 15751 3201 FORMAT('***** ERROR IN MATARI--') 15752 CALL DPWRST('XXX','BUG ') 15753 WRITE(ICOUT,3202) 15754 3202 FORMAT(' FOR MATRIX DETERMINANT,') 15755 CALL DPWRST('XXX','BUG ') 15756 WRITE(ICOUT,3203) 15757 3203 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX') 15758 CALL DPWRST('XXX','BUG ') 15759 WRITE(ICOUT,3204) 15760 3204 FORMAT(' MUST EQUAL') 15761 CALL DPWRST('XXX','BUG ') 15762 WRITE(ICOUT,3205) 15763 3205 FORMAT(' THE NUMBER OF COLUMNS IN THE MATRIX;') 15764 CALL DPWRST('XXX','BUG ') 15765 WRITE(ICOUT,3206) 15766 3206 FORMAT(' SUCH WAS NOT THE CASE HERE.') 15767 CALL DPWRST('XXX','BUG ') 15768 WRITE(ICOUT,3207)NR1 15769 3207 FORMAT(' NUMBER OF ROWS =',I8) 15770 CALL DPWRST('XXX','BUG ') 15771 WRITE(ICOUT,3208)NC1 15772 3208 FORMAT(' NUMBER OF COLUMNS =',I8) 15773 CALL DPWRST('XXX','BUG ') 15774 IERROR='YES' 15775 GOTO9000 15776 3209 CONTINUE 15777C 15778CCCCC JULY 1993. REPLACE NUMERICAL RECIPES ALGORITHM WITH LINPACK 15779CCCCC ALGORITHM. 15780CCCCC CALL LUDCMP(YMJUNK,NR1,MAXROM,INDEX,DP1M1) 15781C 15782CCCCC DET=DP1M1 15783CCCCC DO3221I=1,NR1 15784CCCCC DET=DET*YMJUNK(I,I) 15785C3221 CONTINUE 15786 CALL SGECO(YM1,MAXROM,NR1,INDEX,RCOND,Y3) 15787 WRITE(ICOUT,3261)RCOND 15788 CALL DPWRST('XXX','TEXT ') 15789 3261 FORMAT('THE RECIPROCAL CONDITION NUMBER FOR THE MATRIX = ',E15.7) 15790 EPS=1.0E-20 15791 IF(RCOND.LE.EPS)THEN 15792 WRITE(ICOUT,3271) 15793 CALL DPWRST('XXX','ERRO ') 15794 WRITE(ICOUT,3272) 15795 CALL DPWRST('XXX','ERRO ') 15796 IERROR='YES' 15797 ELSE 15798 IJOB=10 15799 CALL SGEDI(YM1,MAXROM,NR1,INDEX,Y3,Y4,IJOB) 15800 DET=Y3(1)*10.0**Y3(2) 15801 END IF 15802 3271 FORMAT('****** ERROR IN MATARI ********') 15803 3272 FORMAT(' THE INPUT MATRIX IS SINGULAR') 15804CCCCC END CHANGE 15805C 15806 ITYP9='SCAL' 15807 SCAL9=DET 15808 IUPFLG='FULL' 15809 GOTO9000 15810C 15811C ********************************************* 15812C ** STEP 33-- ** 15813C ** TREAT THE MATRIX PERMANENT CASE ** 15814C ********************************************* 15815C 15816 3300 CONTINUE 15817C 15818 IF(NR1.NE.NC1)THEN 15819 WRITE(ICOUT,999) 15820 CALL DPWRST('XXX','BUG ') 15821 WRITE(ICOUT,3301) 15822 3301 FORMAT('***** ERROR IN MATARI--') 15823 CALL DPWRST('XXX','BUG ') 15824 WRITE(ICOUT,3302) 15825 3302 FORMAT(' FOR MATRIX PERMANENT, THE NUMBER OF ROWS IN THE') 15826 CALL DPWRST('XXX','BUG ') 15827 WRITE(ICOUT,3305) 15828 3305 FORMAT(' MATRIX MUST EQUAL THE NUMBER OF COLUMNS IN') 15829 CALL DPWRST('XXX','BUG ') 15830 WRITE(ICOUT,3306) 15831 3306 FORMAT(' THE MATRIX; SUCH WAS NOT THE CASE HERE.') 15832 CALL DPWRST('XXX','BUG ') 15833 WRITE(ICOUT,3307)NR1 15834 3307 FORMAT(' NUMBER OF ROWS =',I8) 15835 CALL DPWRST('XXX','BUG ') 15836 WRITE(ICOUT,3308)NC1 15837 3308 FORMAT(' NUMBER OF COLUMNS =',I8) 15838 CALL DPWRST('XXX','BUG ') 15839 IERROR='YES' 15840 GOTO9000 15841 ENDIF 15842C 15843 IF(NR1.GT.50)THEN 15844 WRITE(ICOUT,999) 15845 CALL DPWRST('XXX','BUG ') 15846 WRITE(ICOUT,3311) 15847 3311 FORMAT('***** ERROR IN MATARI--') 15848 CALL DPWRST('XXX','BUG ') 15849 WRITE(ICOUT,3312) 15850 3312 FORMAT(' FOR MATRIX PERMANENT, THE NUMBER OF ROWS IN THE') 15851 CALL DPWRST('XXX','BUG ') 15852 WRITE(ICOUT,3315) 15853 3315 FORMAT(' MATRIX IS CURRENTLY RESTRICTED TO 50 OR LESS.') 15854 CALL DPWRST('XXX','BUG ') 15855 WRITE(ICOUT,3317)NR1 15856 3317 FORMAT(' NUMBER OF ROWS =',I8) 15857 CALL DPWRST('XXX','BUG ') 15858 IERROR='YES' 15859 GOTO9000 15860 ENDIF 15861C 15862 CALL PERMAN(YM1,MAXROM,NR1,INDEX,Y3,APERM) 15863C 15864 ITYP9='SCAL' 15865 SCAL9=APERM 15866 IUPFLG='FULL' 15867 GOTO9000 15868C 15869C ******************************************************* 15870C ** STEP 34-- ** 15871C ** TREAT THE MATRIX SPECTRAL NORM CASE ** 15872C ** SPECTRAL NORM = COMPUTE MATRIX TIMES ITS ** 15873C ** TRANSPOSE, THEN FIND THE SQUARE ** 15874C ** ROOT OF THE EIGENVALUE WITH THE ** 15875C ** LARGEST ABSOLUTE VALUE. ** 15876C ** REFERENCE--RALSTON ** 15877C ******************************************************* 15878C 15879 3400 CONTINUE 15880C 15881 IF(NR1.GT.MAXCOM)THEN 15882 WRITE(ICOUT,999) 15883 CALL DPWRST('XXX','BUG ') 15884 WRITE(ICOUT,3411) 15885 3411 FORMAT('***** ERROR IN MATARI--') 15886 CALL DPWRST('XXX','BUG ') 15887 WRITE(ICOUT,3413)NR1 15888 3413 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX,',I5, 15889 1 'EXCEEDS THE MAXIMUM') 15890 CALL DPWRST('XXX','BUG ') 15891 WRITE(ICOUT,3415)MAXCOM 15892 3415 FORMAT(' NUMBER OF COLUMNS FOR A MATRIX,',I5,'.') 15893 CALL DPWRST('XXX','BUG ') 15894 WRITE(ICOUT,3417) 15895 3417 FORMAT(' THE MATRIX TRANSPOSE WAS NOT COMPUTED.') 15896 CALL DPWRST('XXX','BUG ') 15897 IERROR='YES' 15898 GOTO9000 15899 ENDIF 15900C 15901 DO3421I=1,NR1 15902 DO3422J=1,NR1 15903 DSUM=0.0D0 15904 DO3423K=1,NC1 15905 DYM1=YM1(I,K) 15906 DYM2=YM1(J,K) 15907 DYM9=DYM1*DYM2 15908 DSUM=DSUM+DYM9 15909 3423 CONTINUE 15910 YM2(I,J)=DSUM 15911 3422 CONTINUE 15912 3421 CONTINUE 15913 NRJ=NR1 15914 NCJ=NR1 15915C 15916CCCCC JULY 1993. REPLACE NUMERICAL RECIPES ALGORITHM WITH THE EISPACK 15917CCCCC ALGORITHM. NOTE THAT MATRIX TIMES IT TRANSPOSE IS SYMMETRIC, SO 15918CCCCC USE SYMMERIC VERSION. 15919CCCCC CALL JACOBI(YMJUNK,NRJ,MAXROM,VJUNK,YMJUN2,NJACIT) 15920C 15921 IERR2=0 15922 IJOB=0 15923 CALL SSIEV(YM2,MAXROM,NR1,Y3,Y4,IJOB,IERR2) 15924 IF(IERR2.EQ.-1)THEN 15925 IERROR='YES' 15926 WRITE(ICOUT,3451) 15927 WRITE(ICOUT,3452) 15928 GOTO9000 15929 ELSE IF(IERR2.EQ.-2)THEN 15930 IERROR='YES' 15931 WRITE(ICOUT,3451) 15932 WRITE(ICOUT,3453) 15933 GOTO9000 15934 ELSE IF(IERR2.GT.0)THEN 15935 IERROR='YES' 15936 WRITE(ICOUT,3451) 15937 WRITE(ICOUT,3457) 15938 WRITE(ICOUT,3458)IERR2 15939 WRITE(ICOUT,3459)IERR2-1 15940 GOTO9000 15941 END IF 15942 3451 FORMAT('******** ERROR FROM MATARI ************') 15943 3452 FORMAT(' THE NUMBER OF ROWS GREATER THAN MAXIMUM') 15944 3453 FORMAT(' LESS THAN 1 ROW') 15945 3457 FORMAT(' THE EIGENVALUE ALGORITHM FAILED TO CONVERGE ') 15946 3458 FORMAT(' FOR EIGENVALUE ',I4) 15947 3459 FORMAT(' EIGENVALUES 1 THRU ',I4,' ARE CORRECT') 15948CCCCC END CHANGES 15949 AMAX=ABS(Y3(1)) 15950 DO3461I=1,NR1 15951 IF(ABS(Y3(I)).GT.AMAX)AMAX=ABS(Y3(I)) 15952 3461 CONTINUE 15953 AMAX2=0.0 15954 IF(AMAX.GT.0.0)AMAX2=SQRT(AMAX) 15955C 15956 ITYP9='SCAL' 15957 SCAL9=AMAX2 15958 IUPFLG='FULL' 15959 GOTO9000 15960C 15961C ******************************************************* 15962C ** STEP 35-- ** 15963C ** TREAT THE MATRIX SPECTRAL RADIUS CASE ** 15964C ** SPECTRAL RADIUS = LARGEST ABS(EIGENVALUE) OF A ** 15965C ** REFERENCE--RALSTON ** 15966C ******************************************************* 15967C 15968 3500 CONTINUE 15969C 15970CCCCC JUNE 1995. EISPACK WILL HANDLE NON-SYMMETRIC MATRICES (FOR 15971CCCCC EIGENVALUES). NO NEED TO RESTRICT TO SYMMETRIC MATRICES). 15972CCCCC IF(NR1.EQ.NC1)GOTO3509 15973CCCCC WRITE(ICOUT,999) 15974CCCCC CALL DPWRST('XXX','BUG ') 15975CCCCC WRITE(ICOUT,3501) 15976C3501 FORMAT('***** ERROR IN MATARI--') 15977CCCCC CALL DPWRST('XXX','BUG ') 15978CCCCC WRITE(ICOUT,3502) 15979C3502 FORMAT(' FOR MATRIX SPECTRAL RADIUS,') 15980CCCCC CALL DPWRST('XXX','BUG ') 15981CCCCC WRITE(ICOUT,3503) 15982C3503 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX') 15983CCCCC CALL DPWRST('XXX','BUG ') 15984CCCCC WRITE(ICOUT,3504) 15985C3504 FORMAT(' MUST EQUAL') 15986CCCCC CALL DPWRST('XXX','BUG ') 15987CCCCC WRITE(ICOUT,3505) 15988C3505 FORMAT(' THE NUMBER OF COLUMNS IN THE MATRIX;') 15989CCCCC CALL DPWRST('XXX','BUG ') 15990CCCCC WRITE(ICOUT,3506) 15991C3506 FORMAT(' SUCH WAS NOT THE CASE HERE.') 15992CCCCC CALL DPWRST('XXX','BUG ') 15993CCCCC WRITE(ICOUT,3507)NR1 15994C3507 FORMAT(' NUMBER OF ROWS =',I8) 15995CCCCC CALL DPWRST('XXX','BUG ') 15996CCCCC WRITE(ICOUT,3508)NC1 15997C3508 FORMAT(' NUMBER OF COLUMNS =',I8) 15998CCCCC CALL DPWRST('XXX','BUG ') 15999CCCCC IERROR='YES' 16000CCCCC GOTO9000 16001C 16002 DO3511I=1,NR1 16003 I2=I 16004 DO3512J=I,NC1 16005 J2=J 16006 YM1IJ=YM1(I,J) 16007 YM1JI=YM1(J,I) 16008 IF(YM1IJ.EQ.YM1JI)GOTO3512 16009 GOTO3530 16010 3512 CONTINUE 16011 3511 CONTINUE 16012 GOTO3539 16013CCCCC JULY 1993. REPLACE NUMERICAL RECIPES ALGORITHM WITH EISPACK 16014CCCCC EISPACK CAN HANDLE NON-SYMMETRIC MATRICES. 16015 3530 CONTINUE 16016CCCCC WRITE(ICOUT,999) 16017CCCCC CALL DPWRST('XXX','BUG ') 16018CCCCC WRITE(ICOUT,3531) 16019C3531 FORMAT('***** ERROR IN MATARI--') 16020CCCCC CALL DPWRST('XXX','BUG ') 16021CCCCC WRITE(ICOUT,3532) 16022C3532 FORMAT(' FOR MATRIX SPECTRAL RADIUS,') 16023CCCCC CALL DPWRST('XXX','BUG ') 16024CCCCC WRITE(ICOUT,3533) 16025C3533 FORMAT(' THE MATRIX MUST BE SYMMETRIC') 16026CCCCC CALL DPWRST('XXX','BUG ') 16027CCCCC WRITE(ICOUT,3535) 16028C3535 FORMAT(' ( A(I,J) = A(J,I) FOR ALL I AND J ).') 16029CCCCC CALL DPWRST('XXX','BUG ') 16030CCCCC WRITE(ICOUT,3536) 16031C3536 FORMAT(' SUCH WAS NOT THE CASE HERE.') 16032CCCCC CALL DPWRST('XXX','BUG ') 16033CCCCC WRITE(ICOUT,3537)I2,J2,YM1IJ 16034C3537 FORMAT(' ELEMENT',I8,',',I8,' = ',E15.7) 16035CCCCC CALL DPWRST('XXX','BUG ') 16036CCCCC WRITE(ICOUT,3538)J2,I2,YM1JI 16037C3538 FORMAT(' ELEMENT',I8,',',I8,' = ',E15.7) 16038CCCCC CALL DPWRST('XXX','BUG ') 16039CCCCC IERROR='YES' 16040CCCCC GOTO9000 16041C 16042 IERR2=0 16043 IJOB=0 16044 CALL SGEEV(YM1,MAXROM,NR1,Y3,YM2,MAXROM,Y4, 16045 1IJOB,IERR2) 16046 IF(IERR2.EQ.-1)THEN 16047 IERROR='YES' 16048 WRITE(ICOUT,3541) 16049 WRITE(ICOUT,3542) 16050 ELSE IF(IERR2.GT.0)THEN 16051 IERROR='YES' 16052 WRITE(ICOUT,3541) 16053 WRITE(ICOUT,3547) 16054 WRITE(ICOUT,3548)IERR2 16055 WRITE(ICOUT,3549)IERR2-1 16056 END IF 16057 3541 FORMAT('******** ERROR FROM MATARI ************') 16058 3542 FORMAT(' PROBLEM WITH MATRIX DIMENSIONS') 16059 3547 FORMAT(' THE EIGENVALUE ALGORITHM FAILED TO CONVERGE ') 16060 3548 FORMAT(' FOR EIGENVALUE ',I4) 16061 3549 FORMAT(' EIGENVALUES 1 THRU ',I4,' ARE CORRECT') 16062C 16063C COMPLEX ABSOLUTE VALUE IS DEFINED TO BE: SQRT(REAL**2+COMPLEX**2) 16064C 16065 AMAX=0.0 16066 ATEMP1=Y3(1)**2 + Y3(1+NR1)**2 16067 IF(ATEMP1.GE.0.0)AMAX=SQRT(ATEMP1) 16068 DO3538I=1,NR1 16069 ATEMP1=0.0 16070 ATEMP2=Y3(I)**2 + Y3(I+NR1)**2 16071 IF(ATEMP2.GE.0.0)ATEMP1=SQRT(ATEMP2) 16072 IF(ATEMP1.GT.AMAX)AMAX=ATEMP1 16073 3538 CONTINUE 16074 GOTO3599 16075C 16076CCCCC END CHANGE 16077 3539 CONTINUE 16078C 16079CCCCC JULY 1993. REPLACE NUMERICAL RECIPES ALGORITHM WITH EISPACK 16080CCCCC CALL JACOBI(YMJUNK,NR1,MAXROM,VJUNK,YMJUN2,NJACIT) 16081C 16082 IERR2=0 16083 IJOB=0 16084 CALL SSIEV(YM1,MAXROM,NR1,Y3,Y4,IJOB,IERR2) 16085 IF(IERR2.EQ.-1)THEN 16086 IERROR='YES' 16087 WRITE(ICOUT,3561) 16088 WRITE(ICOUT,3562) 16089 GOTO9000 16090 ELSE IF(IERR2.EQ.-2)THEN 16091 IERROR='YES' 16092 WRITE(ICOUT,3561) 16093 WRITE(ICOUT,3563) 16094 GOTO9000 16095 ELSE IF(IERR2.GT.0)THEN 16096 IERROR='YES' 16097 WRITE(ICOUT,3561) 16098 WRITE(ICOUT,3567) 16099 WRITE(ICOUT,3568)IERR2 16100 WRITE(ICOUT,3569)IERR2-1 16101 GOTO9000 16102 END IF 16103 3561 FORMAT('******** ERROR FROM MATARI ************') 16104 3562 FORMAT(' THE NUMBER OF ROWS GREATER THAN MAXIMUM') 16105 3563 FORMAT(' LESS THAN 1 ROW') 16106 3567 FORMAT(' THE EIGENVALUE ALGORITHM FAILED TO CONVERGE ') 16107 3568 FORMAT(' FOR EIGENVALUE ',I4) 16108 3569 FORMAT(' EIGENVALUES 1 THRU ',I4,' ARE CORRECT') 16109CCCCC END CHANGES 16110C 16111 AMAX=ABS(Y3(1)) 16112 DO3591I=1,NR1 16113 IF(ABS(Y3(I)).GT.AMAX)AMAX=ABS(Y3(I)) 16114 3591 CONTINUE 16115C 16116 3599 CONTINUE 16117 ITYP9='SCAL' 16118 SCAL9=AMAX 16119 IUPFLG='FULL' 16120 GOTO9000 16121C 16122C *************************************************** 16123C ** STEP 36-- ** 16124C ** TREAT THE MATRIX NUMBER OF ROWS CASE ** 16125C *************************************************** 16126C 16127 3600 CONTINUE 16128C 16129 SCAL9=NR1 16130C 16131 ITYP9='SCAL' 16132 NR9=1 16133 NC9=1 16134 IUPFLG='FULL' 16135 GOTO9000 16136C 16137C *************************************************** 16138C ** STEP 37-- ** 16139C ** TREAT THE MATRIX NUMBER OF COLUMNS CASE ** 16140C *************************************************** 16141C 16142 3700 CONTINUE 16143C 16144 SCAL9=NC1 16145C 16146 ITYP9='SCAL' 16147C 16148 NR9=1 16149 NC9=1 16150 IUPFLG='FULL' 16151 GOTO9000 16152C 16153C ***************************************************** 16154C ** STEP 38-- ** 16155C ** TREAT THE MATRIX SIMPLEX SOLUTION CASE ** 16156C ** REFERENCE--PRESS ET AL, PAGE 322 ** 16157C ***************************************************** 16158C 16159 3800 CONTINUE 16160C 16161 NC2M2=NC2-2 16162C 16163 IF(N1.EQ.NC2M2)GOTO3809 16164 WRITE(ICOUT,999) 16165 CALL DPWRST('XXX','BUG ') 16166 WRITE(ICOUT,3801) 16167 3801 FORMAT('***** ERROR IN MATARI--') 16168 CALL DPWRST('XXX','BUG ') 16169 WRITE(ICOUT,3802) 16170 3802 FORMAT(' FOR MATRIX SIMPLEX SOLUTION OF OBJ. FUNCT. F.X') 16171 CALL DPWRST('XXX','BUG ') 16172 WRITE(ICOUT,3803) 16173 3803 FORMAT(' SUBJECT TO THE CONSTRAINTS IN MATRIX C') 16174 CALL DPWRST('XXX','BUG ') 16175 WRITE(ICOUT,3804) 16176 3804 FORMAT(' VIA LET V = MATRIX SIMPLEX SOLUTION F C') 16177 CALL DPWRST('XXX','BUG ') 16178 WRITE(ICOUT,3805) 16179 3805 FORMAT(' NUMBER OF ROWS IN OBJ. FUNCTION VECTOR F MUST') 16180 CALL DPWRST('XXX','BUG ') 16181 WRITE(ICOUT,3806) 16182 3806 FORMAT(' BE EXACTLY 2 LESS THAN NUMBER OF COLUMNS IN C;') 16183 CALL DPWRST('XXX','BUG ') 16184 WRITE(ICOUT,3807)N1 16185 3807 FORMAT(' VECTOR--',I8,' ROWS') 16186 CALL DPWRST('XXX','BUG ') 16187 WRITE(ICOUT,3808)NR2,NC2 16188 3808 FORMAT(' MATRIX--',I8,' ROWS BY ',I8,' COLUMNS') 16189 CALL DPWRST('XXX','BUG ') 16190 IERROR='YES' 16191 GOTO9000 16192 3809 CONTINUE 16193C 16194 IF(1.LE.N1.AND.N1.LE.MAXCOM)GOTO3819 16195 WRITE(ICOUT,999) 16196 CALL DPWRST('XXX','BUG ') 16197 WRITE(ICOUT,3811) 16198 3811 FORMAT('***** ERROR IN MATARI--') 16199 CALL DPWRST('XXX','BUG ') 16200 WRITE(ICOUT,3812) 16201 3812 FORMAT(' FOR MATRIX SIMPLEX SOLUTION OF OBJ. FUNCT. F.X') 16202 CALL DPWRST('XXX','BUG ') 16203 WRITE(ICOUT,3813) 16204 3813 FORMAT(' SUBJECT TO THE CONSTRAINTS IN MATRIX C') 16205 CALL DPWRST('XXX','BUG ') 16206 WRITE(ICOUT,3814) 16207 3814 FORMAT(' VIA LET V = MATRIX SIMPLEX SOLUTION F C') 16208 CALL DPWRST('XXX','BUG ') 16209 WRITE(ICOUT,3815) 16210 3815 FORMAT(' THE NUMBER OF ROWS IN OBJ. FUNCTION VECTOR F') 16211 CALL DPWRST('XXX','BUG ') 16212 WRITE(ICOUT,3816)MAXCOM 16213 3816 FORMAT(' MUST BE AT LEAST 1, AND AT MOST ',I8) 16214 CALL DPWRST('XXX','BUG ') 16215 WRITE(ICOUT,3817)N1 16216 3817 FORMAT(' NUMBER OF ROWS = ',I8) 16217 CALL DPWRST('XXX','BUG ') 16218 IERROR='YES' 16219 GOTO9000 16220 3819 CONTINUE 16221C 16222 IF(1.LE.NR2.AND.NR2.LE.MAXROM)GOTO3829 16223 WRITE(ICOUT,999) 16224 CALL DPWRST('XXX','BUG ') 16225 WRITE(ICOUT,3821) 16226 3821 FORMAT('***** ERROR IN MATARI--') 16227 CALL DPWRST('XXX','BUG ') 16228 WRITE(ICOUT,3822) 16229 3822 FORMAT(' FOR MATRIX SIMPLEX SOLUTION OF OBJ. FUNCT. F.X') 16230 CALL DPWRST('XXX','BUG ') 16231 WRITE(ICOUT,3823) 16232 3823 FORMAT(' SUBJECT TO THE CONSTRAINTS IN MATRIX C') 16233 CALL DPWRST('XXX','BUG ') 16234 WRITE(ICOUT,3824) 16235 3824 FORMAT(' VIA LET V = MATRIX SIMPLEX SOLUTION F C') 16236 CALL DPWRST('XXX','BUG ') 16237 WRITE(ICOUT,3825) 16238 3825 FORMAT(' THE NUMBER OF CONSTRAINTS') 16239 CALL DPWRST('XXX','BUG ') 16240 WRITE(ICOUT,3826) 16241 3826 FORMAT(' (THAT IS, THE NUMBER OF ROWS IN THE MATRIX C)') 16242 CALL DPWRST('XXX','BUG ') 16243 WRITE(ICOUT,3827)MAXROM 16244 3827 FORMAT(' MUST BE AT LEAST 1, AND AT MOST ',I8) 16245 CALL DPWRST('XXX','BUG ') 16246 WRITE(ICOUT,3828)NR2 16247 3828 FORMAT(' NUMBER OF CONSTRAINTS = ',I8) 16248 CALL DPWRST('XXX','BUG ') 16249 IERROR='YES' 16250 GOTO9000 16251 3829 CONTINUE 16252C 16253 IF(3.LE.NC2.AND.NC2.LE.MAXCOM)GOTO3839 16254 WRITE(ICOUT,999) 16255 CALL DPWRST('XXX','BUG ') 16256 WRITE(ICOUT,3831) 16257 3831 FORMAT('***** ERROR IN MATARI--') 16258 CALL DPWRST('XXX','BUG ') 16259 WRITE(ICOUT,3832) 16260 3832 FORMAT(' FOR MATRIX SIMPLEX SOLUTION OF OBJ. FUNCT. F.X') 16261 CALL DPWRST('XXX','BUG ') 16262 WRITE(ICOUT,3833) 16263 3833 FORMAT(' SUBJECT TO THE CONSTRAINTS IN MATRIX C') 16264 CALL DPWRST('XXX','BUG ') 16265 WRITE(ICOUT,3834) 16266 3834 FORMAT(' VIA LET V = MATRIX SIMPLEX SOLUTION F C') 16267 CALL DPWRST('XXX','BUG ') 16268 WRITE(ICOUT,3835) 16269 3835 FORMAT(' THE NUMBER OF COLUMNS IN THE CONSTRAINTS') 16270 CALL DPWRST('XXX','BUG ') 16271 WRITE(ICOUT,3836)MAXCOM 16272 3836 FORMAT(' MATRIX C MUST BE AT LEAST 3, AND AT MOST ',I8) 16273 CALL DPWRST('XXX','BUG ') 16274 WRITE(ICOUT,3837)NC2 16275 3837 FORMAT(' NUMBER OF COLUMNS = ',I8) 16276 CALL DPWRST('XXX','BUG ') 16277 IERROR='YES' 16278 GOTO9000 16279 3839 CONTINUE 16280C 16281 EPS=0.000001 16282 NR2P1=NR2+1 16283 NC2P=NC2-2 16284 NC2PP1=NC2P+1 16285 NC2M1=NC2-1 16286C 16287 DO3850J=1,NC2PP1 16288 YM9(1,J)=0.0 16289 3850 CONTINUE 16290C 16291 N1P1=N1+1 16292 DO3860J=2,N1P1 16293 JM1=J-1 16294 YM9(1,J)=Y1(JM1) 16295 3860 CONTINUE 16296C 16297 K=1 16298 DO3871ILOOP=1,3 16299C 16300 DO3872I=2,NR2P1 16301 IM1=I-1 16302 YTARG=YM2(IM1,NC2M1) 16303 IF(ILOOP.EQ.1.AND.YTARG.LT.-EPS)GOTO3873 16304 IF(ILOOP.EQ.1)GOTO3872 16305 IF(ILOOP.EQ.2.AND.EPS.LT.YTARG)GOTO3873 16306 IF(ILOOP.EQ.2)GOTO3872 16307 IF(ILOOP.EQ.3.AND.-EPS.LE.YTARG.AND. 16308 1 YTARG.LE.EPS)GOTO3873 16309 IF(ILOOP.EQ.3)GOTO3872 16310 3873 CONTINUE 16311 K=K+1 16312C 16313 YM9(K,1)=YM2(IM1,NC2) 16314 DO3874J=2,NC2PP1 16315 JM1=J-1 16316 YM9(K,J)=(-YM2(IM1,JM1)) 16317 3874 CONTINUE 16318C 16319 3872 CONTINUE 16320C 16321 3871 CONTINUE 16322C 16323 NLTZ=0 16324 NGTZ=0 16325 NEQZ=0 16326 DO3877I=1,NR2 16327 YTARG=YM2(I,NC2M1) 16328 IF(YTARG.LT.-EPS)NLTZ=NLTZ+1 16329 IF(EPS.LT.YTARG)NGTZ=NGTZ+1 16330 IF(-EPS.LE.YTARG.AND.YTARG.LE.EPS)NEQZ=NEQZ+1 16331 3877 CONTINUE 16332C 16333 CALL SIMPLX(YM9,NR2,NC2P,MAXROM,MAXCOM,NLTZ,NGTZ,NEQZ, 16334 1ICASE,IZROV,IPOSV,IBUGA3,ISUBRO,IERROR) 16335 IF(IERROR.EQ.'YES')GOTO9000 16336C 16337 DO3881I=1,N1 16338 VECT9(I)=0.0 16339 3881 CONTINUE 16340C 16341 DO3882I=1,NR2 16342 INDEX2=IPOSV(I) 16343 IP1=I+1 16344 IF(INDEX2.LE.N1)VECT9(INDEX2)=YM9(IP1,1) 16345 3882 CONTINUE 16346C 16347 ITYP9='VECT' 16348 NVECT9=N1 16349 IUPFLG='FULL' 16350 GOTO9000 16351C 16352C ***************************************************** 16353C ** STEP 41-- ** 16354C ** TREAT THE MATRIX TRACE CASE ** 16355C ** REFERENCE--RALSTON, PAGE XXX ** 16356C ***************************************************** 16357C 16358 4100 CONTINUE 16359C 16360 IF(NR1.EQ.NC1)GOTO4109 16361 WRITE(ICOUT,999) 16362 CALL DPWRST('XXX','BUG ') 16363 WRITE(ICOUT,4101) 16364 4101 FORMAT('***** ERROR IN MATARI--') 16365 CALL DPWRST('XXX','BUG ') 16366 WRITE(ICOUT,4102) 16367 4102 FORMAT(' FOR MATRIX TRACE,') 16368 CALL DPWRST('XXX','BUG ') 16369 WRITE(ICOUT,4103) 16370 4103 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX') 16371 CALL DPWRST('XXX','BUG ') 16372 WRITE(ICOUT,4104) 16373 4104 FORMAT(' MUST EQUAL') 16374 CALL DPWRST('XXX','BUG ') 16375 WRITE(ICOUT,4105) 16376 4105 FORMAT(' THE NUMBER OF COLUMNS IN THE MATRIX;') 16377 CALL DPWRST('XXX','BUG ') 16378 WRITE(ICOUT,4106) 16379 4106 FORMAT(' SUCH WAS NOT THE CASE HERE.') 16380 CALL DPWRST('XXX','BUG ') 16381 WRITE(ICOUT,4107)NR1 16382 4107 FORMAT(' NUMBER OF ROWS =',I8) 16383 CALL DPWRST('XXX','BUG ') 16384 WRITE(ICOUT,4108)NC1 16385 4108 FORMAT(' NUMBER OF COLUMNS =',I8) 16386 CALL DPWRST('XXX','BUG ') 16387 IERROR='YES' 16388 GOTO9000 16389 4109 CONTINUE 16390C 16391 DSUM1=0.0D0 16392 DO4111I=1,NR1 16393 DYM1=YM1(I,I) 16394 DSUM1=DSUM1+DYM1 16395 4111 CONTINUE 16396C 16397 ITYP9='SCAL' 16398 SCAL9=DSUM1 16399 IUPFLG='FULL' 16400 GOTO9000 16401C 16402C ***************************************************** 16403C ** STEP 42-- ** 16404C ** TREAT THE MATRIX SUBMATRIX CASE ** 16405C ** REFERENCE--RALSTON, PAGE XXX ** 16406C ***************************************************** 16407C 16408 4200 CONTINUE 16409C 16410CCCCC NO REASON FOR RESTRICTION ON SQUARE MATRICES FOR THIS 16411CCCCC COMMAND. COMMENT OUT FOLLOWING SECTION. DECEMBER 1994. 16412CCCCC IF(NR1.EQ.NC1)GOTO4209 16413CCCCC WRITE(ICOUT,999) 16414CCCCC CALL DPWRST('XXX','BUG ') 16415CCCCC WRITE(ICOUT,4201) 16416C4201 FORMAT('***** ERROR IN MATARI--') 16417CCCCC CALL DPWRST('XXX','BUG ') 16418CCCCC WRITE(ICOUT,4202) 16419C4202 FORMAT(' FOR MATRIX SUBMATRIX,') 16420CCCCC CALL DPWRST('XXX','BUG ') 16421CCCCC WRITE(ICOUT,4203) 16422C4203 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX') 16423CCCCC CALL DPWRST('XXX','BUG ') 16424CCCCC WRITE(ICOUT,4204) 16425C4204 FORMAT(' MUST EQUAL') 16426CCCCC CALL DPWRST('XXX','BUG ') 16427CCCCC WRITE(ICOUT,4205) 16428C4205 FORMAT(' THE NUMBER OF COLUMNS IN THE MATRIX;') 16429CCCCC CALL DPWRST('XXX','BUG ') 16430CCCCC WRITE(ICOUT,4206) 16431C4206 FORMAT(' SUCH WAS NOT THE CASE HERE.') 16432CCCCC CALL DPWRST('XXX','BUG ') 16433CCCCC WRITE(ICOUT,4207)NR1 16434C4207 FORMAT(' NUMBER OF ROWS =',I8) 16435CCCCC CALL DPWRST('XXX','BUG ') 16436CCCCC WRITE(ICOUT,4208)NC1 16437C4208 FORMAT(' NUMBER OF COLUMNS =',I8) 16438CCCCC CALL DPWRST('XXX','BUG ') 16439CCCCC IERROR='YES' 16440CCCCC GOTO9000 16441C4209 CONTINUE 16442C 16443 IYS2=INT(YS2+0.1) 16444 IYS3=INT(YS3+0.1) 16445 I2=0 16446 J2=0 16447 DO4211I=1,NR1 16448 IF(I.EQ.IYS2)GOTO4211 16449 I2=I2+1 16450 NRJ=I2 16451 J2=0 16452 DO4212J=1,NC1 16453 IF(J.EQ.IYS3)GOTO4212 16454 J2=J2+1 16455 NCJ=J2 16456 YM2(I2,J2)=YM1(I,J) 16457 4212 CONTINUE 16458 4211 CONTINUE 16459C 16460 IF(NRJ.GE.1.AND.NCJ.GE.1)GOTO4229 16461 WRITE(ICOUT,999) 16462 CALL DPWRST('XXX','BUG ') 16463 WRITE(ICOUT,4221) 16464 4221 FORMAT('***** ERROR IN MATARI--') 16465 CALL DPWRST('XXX','BUG ') 16466 WRITE(ICOUT,4222) 16467 4222 FORMAT(' FOR MATRIX SUBMATRIX,') 16468 CALL DPWRST('XXX','BUG ') 16469 WRITE(ICOUT,4223) 16470 4223 FORMAT(' THE NUMBER OF ROWS IN THE SUBMATRIX, AND') 16471 CALL DPWRST('XXX','BUG ') 16472 WRITE(ICOUT,4224) 16473 4224 FORMAT(' THE NUMBER OF COLUMNS IN THE SUBMATRIX') 16474 CALL DPWRST('XXX','BUG ') 16475 WRITE(ICOUT,4225) 16476 4225 FORMAT(' MUST BOTH BE 1 OR LARGER;') 16477 CALL DPWRST('XXX','BUG ') 16478 WRITE(ICOUT,4226) 16479 4226 FORMAT(' SUCH WAS NOT THE CASE HERE.') 16480 CALL DPWRST('XXX','BUG ') 16481 WRITE(ICOUT,4227)NRJ 16482 4227 FORMAT(' NUMBER OF ROWS =',I8) 16483 CALL DPWRST('XXX','BUG ') 16484 WRITE(ICOUT,4228)NCJ 16485 4228 FORMAT(' NUMBER OF COLUMNS =',I8) 16486 CALL DPWRST('XXX','BUG ') 16487 IERROR='YES' 16488 GOTO9000 16489 4229 CONTINUE 16490C 16491 DO4231I=1,NRJ 16492 DO4232J=1,NCJ 16493 YM9(I,J)=YM2(I,J) 16494 4232 CONTINUE 16495 4231 CONTINUE 16496C 16497 ITYP9='MATR' 16498CCCCC DECEMBER 1994. FOLLOWING IS BACKWARDS. 16499CCCCC NR9=NCJ 16500CCCCC NC9=NRJ 16501 NR9=NRJ 16502 NC9=NCJ 16503 IUPFLG='FULL' 16504 GOTO9000 16505C 16506C ***************************************************** 16507C ** STEP 43-- ** 16508C ** TREAT THE MATRIX MINOR CASE ** 16509C ** REFERENCE--RALSTON, PAGE XXX ** 16510C ***************************************************** 16511C 16512 4300 CONTINUE 16513C 16514 IF(NR1.EQ.NC1)GOTO4309 16515 WRITE(ICOUT,999) 16516 CALL DPWRST('XXX','BUG ') 16517 WRITE(ICOUT,4301) 16518 4301 FORMAT('***** ERROR IN MATARI--') 16519 CALL DPWRST('XXX','BUG ') 16520 WRITE(ICOUT,4302) 16521 4302 FORMAT(' FOR MATRIX MINOR,') 16522 CALL DPWRST('XXX','BUG ') 16523 WRITE(ICOUT,4303) 16524 4303 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX') 16525 CALL DPWRST('XXX','BUG ') 16526 WRITE(ICOUT,4304) 16527 4304 FORMAT(' MUST EQUAL') 16528 CALL DPWRST('XXX','BUG ') 16529 WRITE(ICOUT,4305) 16530 4305 FORMAT(' THE NUMBER OF COLUMNS IN THE MATRIX;') 16531 CALL DPWRST('XXX','BUG ') 16532 WRITE(ICOUT,4306) 16533 4306 FORMAT(' SUCH WAS NOT THE CASE HERE.') 16534 CALL DPWRST('XXX','BUG ') 16535 WRITE(ICOUT,4307)NR1 16536 4307 FORMAT(' NUMBER OF ROWS =',I8) 16537 CALL DPWRST('XXX','BUG ') 16538 WRITE(ICOUT,4308)NC1 16539 4308 FORMAT(' NUMBER OF COLUMNS =',I8) 16540 CALL DPWRST('XXX','BUG ') 16541 IERROR='YES' 16542 GOTO9000 16543 4309 CONTINUE 16544C 16545 IYS2=INT(YS2+0.1) 16546 IYS3=INT(YS3+0.1) 16547 I2=0 16548 J2=0 16549 DO4311I=1,NR1 16550 IF(I.EQ.IYS2)GOTO4311 16551 I2=I2+1 16552 NRJ=I2 16553 J2=0 16554 DO4312J=1,NC1 16555 IF(J.EQ.IYS3)GOTO4312 16556 J2=J2+1 16557 NCJ=J2 16558 YM2(I2,J2)=YM1(I,J) 16559 4312 CONTINUE 16560 4311 CONTINUE 16561C 16562 IF(NRJ.GE.1.AND.NCJ.GE.1)GOTO4329 16563 WRITE(ICOUT,999) 16564 CALL DPWRST('XXX','BUG ') 16565 WRITE(ICOUT,4321) 16566 4321 FORMAT('***** ERROR IN MATARI--') 16567 CALL DPWRST('XXX','BUG ') 16568 WRITE(ICOUT,4322) 16569 4322 FORMAT(' FOR MATRIX MINOR,') 16570 CALL DPWRST('XXX','BUG ') 16571 WRITE(ICOUT,4323) 16572 4323 FORMAT(' THE NUMBER OF ROWS IN THE SUBMATRIX, AND') 16573 CALL DPWRST('XXX','BUG ') 16574 WRITE(ICOUT,4324) 16575 4324 FORMAT(' THE NUMBER OF COLUMNS IN THE SUBMATRIX') 16576 CALL DPWRST('XXX','BUG ') 16577 WRITE(ICOUT,4325) 16578 4325 FORMAT(' MUST BOTH BE 1 OR LARGER;') 16579 CALL DPWRST('XXX','BUG ') 16580 WRITE(ICOUT,4326) 16581 4326 FORMAT(' SUCH WAS NOT THE CASE HERE.') 16582 CALL DPWRST('XXX','BUG ') 16583 WRITE(ICOUT,4327)NRJ 16584 4327 FORMAT(' NUMBER OF ROWS =',I8) 16585 CALL DPWRST('XXX','BUG ') 16586 WRITE(ICOUT,4328)NCJ 16587 4328 FORMAT(' NUMBER OF COLUMNS =',I8) 16588 CALL DPWRST('XXX','BUG ') 16589 IERROR='YES' 16590 GOTO9000 16591 4329 CONTINUE 16592C 16593 IF(NRJ.EQ.NCJ)GOTO4339 16594 WRITE(ICOUT,999) 16595 CALL DPWRST('XXX','BUG ') 16596 WRITE(ICOUT,4331) 16597 4331 FORMAT('***** ERROR IN MATARI--') 16598 CALL DPWRST('XXX','BUG ') 16599 WRITE(ICOUT,4332) 16600 4332 FORMAT(' FOR MATRIX MINOR,') 16601 CALL DPWRST('XXX','BUG ') 16602 WRITE(ICOUT,4333) 16603 4333 FORMAT(' THE NUMBER OF ROWS IN THE SUBMATRIX') 16604 CALL DPWRST('XXX','BUG ') 16605 WRITE(ICOUT,4334) 16606 4334 FORMAT(' MUST EQUAL') 16607 CALL DPWRST('XXX','BUG ') 16608 WRITE(ICOUT,4335) 16609 4335 FORMAT(' THE NUMBER OF COLUMNS IN THE SUBMATRIX;') 16610 CALL DPWRST('XXX','BUG ') 16611 WRITE(ICOUT,4336) 16612 4336 FORMAT(' SUCH WAS NOT THE CASE HERE.') 16613 CALL DPWRST('XXX','BUG ') 16614 WRITE(ICOUT,4337)NRJ 16615 4337 FORMAT(' NUMBER OF ROWS =',I8) 16616 CALL DPWRST('XXX','BUG ') 16617 WRITE(ICOUT,4338)NCJ 16618 4338 FORMAT(' NUMBER OF COLUMNS =',I8) 16619 CALL DPWRST('XXX','BUG ') 16620 IERROR='YES' 16621 GOTO9000 16622 4339 CONTINUE 16623C 16624CCCCC JULY 1993. USE LINPACK ROUTINE TO COMPUTE THE DETERMINANT. 16625CCCCC CALL LUDCMP(YMJUNK,NRJ,MAXROM,INDEX,DP1M1) 16626C 16627CCCCC DPROD=DP1M1 16628CCCCC DO4341I=1,NRJ 16629CCCCC DYM9=YMJUNK(I,I) 16630CCCCC DPROD=DPROD*DYM9 16631C4341 CONTINUE 16632CCCCC DET=DPROD 16633CCCCC AMINOR=DET 16634C 16635 CALL SGECO(YM2,MAXROM,NRJ,INDEX,RCOND,Y3) 16636 EPS=1.0E-20 16637 IF(RCOND.LE.EPS)THEN 16638 WRITE(ICOUT,4371) 16639 CALL DPWRST('XXX','ERRO ') 16640 WRITE(ICOUT,4372) 16641 CALL DPWRST('XXX','ERRO ') 16642 COFACT=0.0 16643 IERROR='YES' 16644 ELSE 16645 IJOB=10 16646 CALL SGEDI(YM2,MAXROM,NRJ,INDEX,Y3,Y4,IJOB) 16647 DET=Y3(1)*10.0**Y3(2) 16648 AMINOR=DET 16649 END IF 16650 4371 FORMAT('****** ERROR IN MATARI ********') 16651 4372 FORMAT(' UNABLE TO COMPUTE THE DETERMINANT') 16652CCCCC END CHANGE 16653C 16654 ITYP9='SCAL' 16655 SCAL9=AMINOR 16656 IUPFLG='FULL' 16657 GOTO9000 16658C 16659C ***************************************************** 16660C ** STEP 44-- ** 16661C ** TREAT THE MATRIX COFACTOR CASE ** 16662C ** REFERENCE--RALSTON, PAGE XXX ** 16663C ***************************************************** 16664C 16665 4400 CONTINUE 16666C 16667 IF(NR1.EQ.NC1)GOTO4409 16668 WRITE(ICOUT,999) 16669 CALL DPWRST('XXX','BUG ') 16670 WRITE(ICOUT,4401) 16671 4401 FORMAT('***** ERROR IN MATARI--') 16672 CALL DPWRST('XXX','BUG ') 16673 WRITE(ICOUT,4402) 16674 4402 FORMAT(' FOR MATRIX COFACTOR,') 16675 CALL DPWRST('XXX','BUG ') 16676 WRITE(ICOUT,4403) 16677 4403 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX') 16678 CALL DPWRST('XXX','BUG ') 16679 WRITE(ICOUT,4404) 16680 4404 FORMAT(' MUST EQUAL') 16681 CALL DPWRST('XXX','BUG ') 16682 WRITE(ICOUT,4405) 16683 4405 FORMAT(' THE NUMBER OF COLUMNS IN THE MATRIX;') 16684 CALL DPWRST('XXX','BUG ') 16685 WRITE(ICOUT,4406) 16686 4406 FORMAT(' SUCH WAS NOT THE CASE HERE.') 16687 CALL DPWRST('XXX','BUG ') 16688 WRITE(ICOUT,4407)NR1 16689 4407 FORMAT(' NUMBER OF ROWS =',I8) 16690 CALL DPWRST('XXX','BUG ') 16691 WRITE(ICOUT,4408)NC1 16692 4408 FORMAT(' NUMBER OF COLUMNS =',I8) 16693 CALL DPWRST('XXX','BUG ') 16694 IERROR='YES' 16695 GOTO9000 16696 4409 CONTINUE 16697C 16698 IYS2=INT(YS2+0.1) 16699 IYS3=INT(YS3+0.1) 16700 I2=0 16701 J2=0 16702 DO4411I=1,NR1 16703 IF(I.EQ.IYS2)GOTO4411 16704 I2=I2+1 16705 NRJ=I2 16706 J2=0 16707 DO4412J=1,NC1 16708 IF(J.EQ.IYS3)GOTO4412 16709 J2=J2+1 16710 NCJ=J2 16711 YM2(I2,J2)=YM1(I,J) 16712 4412 CONTINUE 16713 4411 CONTINUE 16714C 16715 IF(NRJ.GE.1.AND.NCJ.GE.1)GOTO4429 16716 WRITE(ICOUT,999) 16717 CALL DPWRST('XXX','BUG ') 16718 WRITE(ICOUT,4421) 16719 4421 FORMAT('***** ERROR IN MATARI--') 16720 CALL DPWRST('XXX','BUG ') 16721 WRITE(ICOUT,4422) 16722 4422 FORMAT(' FOR MATRIX COFACTOR,') 16723 CALL DPWRST('XXX','BUG ') 16724 WRITE(ICOUT,4423) 16725 4423 FORMAT(' THE NUMBER OF ROWS IN THE SUBMATRIX, AND') 16726 CALL DPWRST('XXX','BUG ') 16727 WRITE(ICOUT,4424) 16728 4424 FORMAT(' THE NUMBER OF COLUMNS IN THE SUBMATRIX') 16729 CALL DPWRST('XXX','BUG ') 16730 WRITE(ICOUT,4425) 16731 4425 FORMAT(' MUST BOTH BE 1 OR LARGER;') 16732 CALL DPWRST('XXX','BUG ') 16733 WRITE(ICOUT,4426) 16734 4426 FORMAT(' SUCH WAS NOT THE CASE HERE.') 16735 CALL DPWRST('XXX','BUG ') 16736 WRITE(ICOUT,4427)NRJ 16737 4427 FORMAT(' NUMBER OF ROWS =',I8) 16738 CALL DPWRST('XXX','BUG ') 16739 WRITE(ICOUT,4428)NCJ 16740 4428 FORMAT(' NUMBER OF COLUMNS =',I8) 16741 CALL DPWRST('XXX','BUG ') 16742 IERROR='YES' 16743 GOTO9000 16744 4429 CONTINUE 16745C 16746 IF(NRJ.EQ.NCJ)GOTO4439 16747 WRITE(ICOUT,999) 16748 CALL DPWRST('XXX','BUG ') 16749 WRITE(ICOUT,4431) 16750 4431 FORMAT('***** ERROR IN MATARI--') 16751 CALL DPWRST('XXX','BUG ') 16752 WRITE(ICOUT,4432) 16753 4432 FORMAT(' FOR MATRIX COFACTOR,') 16754 CALL DPWRST('XXX','BUG ') 16755 WRITE(ICOUT,4433) 16756 4433 FORMAT(' THE NUMBER OF ROWS IN THE SUBMATRIX') 16757 CALL DPWRST('XXX','BUG ') 16758 WRITE(ICOUT,4434) 16759 4434 FORMAT(' MUST EQUAL') 16760 CALL DPWRST('XXX','BUG ') 16761 WRITE(ICOUT,4435) 16762 4435 FORMAT(' THE NUMBER OF COLUMNS IN THE SUBMATRIX;') 16763 CALL DPWRST('XXX','BUG ') 16764 WRITE(ICOUT,4436) 16765 4436 FORMAT(' SUCH WAS NOT THE CASE HERE.') 16766 CALL DPWRST('XXX','BUG ') 16767 WRITE(ICOUT,4437)NRJ 16768 4437 FORMAT(' NUMBER OF ROWS =',I8) 16769 CALL DPWRST('XXX','BUG ') 16770 WRITE(ICOUT,4438)NCJ 16771 4438 FORMAT(' NUMBER OF COLUMNS =',I8) 16772 CALL DPWRST('XXX','BUG ') 16773 IERROR='YES' 16774 GOTO9000 16775 4439 CONTINUE 16776C 16777CCCCC JULY 1993. USE LINPACK ROUTINE TO COMPUTE THE DETERMINANT. 16778CCCCC CALL LUDCMP(YMJUNK,NRJ,MAXROM,INDEX,DP1M1) 16779C 16780CCCCC DPROD=DP1M1 16781CCCCC DO4441I=1,NRJ 16782CCCCC DYM9=YMJUNK(I,I) 16783CCCCC DPROD=DPROD*DYM9 16784C4441 CONTINUE 16785CCCCC DET=DPROD 16786C 16787 CALL SGECO(YM2,MAXROM,NRJ,INDEX,RCOND,Y3) 16788 EPS=1.0E-20 16789 IF(RCOND.LE.EPS)THEN 16790 WRITE(ICOUT,4471) 16791 CALL DPWRST('XXX','ERRO ') 16792 WRITE(ICOUT,4472) 16793 CALL DPWRST('XXX','ERRO ') 16794 COFACT=0.0 16795 IERROR='YES' 16796 ELSE 16797 IJOB=10 16798 CALL SGEDI(YM2,MAXROM,NRJ,INDEX,Y3,Y4,IJOB) 16799 DET=Y3(1)*10.0**Y3(2) 16800 COFACT=DET 16801 IYS23=IYS2+IYS3 16802 IREM=IYS23-2*(IYS23/2) 16803 IF(IREM.EQ.1)COFACT=(-COFACT) 16804 END IF 16805 4471 FORMAT('****** ERROR IN MATARI ********') 16806 4472 FORMAT(' UNABLE TO COMPUTE THE DETERMINANT') 16807CCCCC END CHANGE 16808C 16809 ITYP9='SCAL' 16810 SCAL9=COFACT 16811 IUPFLG='FULL' 16812 GOTO9000 16813C 16814C ***************************************************** 16815C ** STEP 45-- ** 16816C ** TREAT THE MATRIX DEFINITION CASE ** 16817C ** REFERENCE--RALSTON, PAGE XXX ** 16818C ***************************************************** 16819C 16820CCCCC OCTOBER 1993. ADD OPTIONAL SYNTAX. IF FOURTH PARAMETER 16821CCCCC SPECIFIED, LET IT BE THE STARTING ROW NUMBER. 16822 4500 CONTINUE 16823C 16824 IF(ITYPA4.EQ.'PARA')GOTO4560 16825 DO4511I=1,NR1 16826 DO4512J=1,NC1 16827 YM9(I,J)=YM1(I,J) 16828 4512 CONTINUE 16829 4511 CONTINUE 16830C 16831 ITYP9='MATR' 16832 NR9=NR1 16833 NC9=NC1 16834 GOTO9000 16835CCCCC OCTOBER 1993. ADD FOLLOWING SECTION 16836 4560 CONTINUE 16837 IROWID=INT(YS4+0.5) 16838 IF(IROWID.LT.1.OR.IROWID.GT.NR1)IROWID=1 16839 ICOUNT=0 16840CCCCC NLAST=IROWID+NR1-1 16841 NLAST=NR1 16842 IF(NLAST.GT.MAXROM)NLAST=MAXROM 16843 DO4561I=IROWID,NLAST 16844 ICOUNT=ICOUNT+1 16845 DO4562J=1,NC1 16846 YM9(ICOUNT,J)=YM1(I,J) 16847 4562 CONTINUE 16848 4561 CONTINUE 16849C 16850 ITYP9='MATR' 16851 NR9=ICOUNT 16852 NC9=NC1 16853 IUPFLG='FULL' 16854 GOTO9000 16855C 16856C ***************************************************** 16857C ** STEP 46-- ** 16858C ** TREAT THE MATRIX EUCLIDEAN NORM CASE ** 16859C ** REFERENCE--RALSTON, PAGE XXX ** 16860C ***************************************************** 16861C 16862 4600 CONTINUE 16863C 16864 DSUM1=0.0D0 16865 DO4621I=1,NR1 16866 DO4622J=1,NC1 16867 DYM1=YM1(I,J) 16868 DSUM1=DSUM1+DYM1*DYM1 16869 4622 CONTINUE 16870 4621 CONTINUE 16871 DSUM2=0.0D0 16872 IF(DSUM1.GT.0.0D0)DSUM2=SQRT(DSUM1) 16873C 16874 ITYP9='SCAL' 16875 SCAL9=DSUM2 16876 IUPFLG='FULL' 16877 GOTO9000 16878C 16879C ************************************************************** 16880C ** STEP 51-- ** 16881C ** TREAT THE VARIANCE-COVARIANCE CASE ** 16882C ************************************************************** 16883C 16884 5100 CONTINUE 16885C 16886CCCCC JULY 2002. SUPPORT FOR WINSORIZED CORRELATION. 16887C 16888CCCCC NOVEMBER 2004. SUPPORT FOR ROW BASED (AS OPPOSSED TO COLUMN 16889CCCCC BASED COVARIANCES. 16890C 16891 NTRIM1=-1 16892 NTRIM2=-1 16893 IF(ICOVDI.EQ.'COLU')THEN 16894 IWRITE='OFF' 16895 DO5151J=1,NC1 16896 DO5161K=1,NC1 16897 DO5155I=1,NR1 16898 Y3(I)=YM1(I,J) 16899 Y4(I)=YM1(I,K) 16900 5155 CONTINUE 16901 IF(ICOVTY.EQ.'RANK')THEN 16902 CALL RANKCV(Y3,Y4,NR1,IWRITE,Y1,Y2,VECT9,MAXOBV,RIGHT, 16903 1 IBUGA3,IERROR) 16904 ELSEIF(ICOVTY.EQ.'WINS')THEN 16905 CALL WINSOR(Y3,NR1,P1,P2,NTRIM1,NTRIM2,IWRITE, 16906 1 Y1,MAXOBV,Y2, 16907 1 IBUGA3,ISUBRO,IERROR) 16908 DO5181I=1,NR1 16909 Y3(I)=Y2(I) 16910 5181 CONTINUE 16911 CALL WINSOR(Y4,NR1,P1,P2,NTRIM1,NTRIM2,IWRITE, 16912 1 Y1,MAXOBV,Y2, 16913 1 IBUGA3,ISUBRO,IERROR) 16914 DO5186I=1,NR1 16915 Y4(I)=Y2(I) 16916 5186 CONTINUE 16917 CALL COV(Y3,Y4,NR1,IWRITE,RIGHT,IBUGA3,IERROR) 16918 ELSEIF(ICOVTY.EQ.'BIWE')THEN 16919 CALL BIWMCV(Y3,Y4,NR1,IWRITE,Y1,Y2,MAXOBV,RIGHT, 16920 1 IBUGA3,IERROR) 16921 ELSE 16922 CALL COV(Y3,Y4,NR1,IWRITE,RIGHT,IBUGA3,IERROR) 16923 ENDIF 16924 YM9(J,K)=RIGHT 16925 5161 CONTINUE 16926 5151 CONTINUE 16927 NR9=NC1 16928 NC9=NC1 16929 ELSE 16930 IWRITE='OFF' 16931 DO5121J=1,NR1 16932 DO5131K=1,NR1 16933 DO5125I=1,NC1 16934 Y3(I)=YM1(J,I) 16935 Y4(I)=YM1(K,I) 16936 5125 CONTINUE 16937 IF(ICOVTY.EQ.'RANK')THEN 16938 CALL RANKCV(Y3,Y4,NC1,IWRITE,Y1,Y2,VECT9,MAXOBV,RIGHT, 16939 1 IBUGA3,IERROR) 16940 ELSEIF(ICOVTY.EQ.'WINS')THEN 16941 CALL WINSOR(Y3,NC1,P1,P2,NTRIM1,NTRIM2,IWRITE, 16942 1 Y1,MAXOBV,Y2, 16943 1 IBUGA3,ISUBRO,IERROR) 16944 DO5141I=1,NC1 16945 Y3(I)=Y2(I) 16946 5141 CONTINUE 16947 CALL WINSOR(Y4,NC1,P1,P2,NTRIM1,NTRIM2,IWRITE, 16948 1 Y1,MAXOBV,Y2, 16949 1 IBUGA3,ISUBRO,IERROR) 16950 DO5146I=1,NC1 16951 Y4(I)=Y2(I) 16952 5146 CONTINUE 16953 CALL COV(Y3,Y4,NC1,IWRITE,RIGHT,IBUGA3,IERROR) 16954 ELSEIF(ICOVTY.EQ.'BIWE')THEN 16955 CALL BIWMCV(Y3,Y4,NC1,IWRITE,Y1,Y2,MAXOBV,RIGHT, 16956 1 IBUGA3,IERROR) 16957 ELSE 16958 CALL COV(Y3,Y4,NC1,IWRITE,RIGHT,IBUGA3,IERROR) 16959 ENDIF 16960 YM9(J,K)=RIGHT 16961 5131 CONTINUE 16962 5121 CONTINUE 16963 NR9=NC1 16964 NC9=NC1 16965 ENDIF 16966C 16967C 16968 ITYP9='MATR' 16969 IUPFLG='FULL' 16970 GOTO9000 16971C 16972C ****************************************************** 16973C ** STEP 52-- ** 16974C ** TREAT THE CORRELATION CASE ** 16975C ****************************************************** 16976C 16977 5200 CONTINUE 16978C 16979CCCCC JULY 2002. SUPPORT FOR WINSORIZED CORRELATION, RANK CORRELATION, 16980CCCCC BIWEIGHT MID CORRELATION. 16981CCCCC NOVEMBER 2004. SUPPORT FOR ROW BASED (AS OPPOSSED TO COLUMN 16982CCCCC BASED CORRELATIONS. ALSO, ADD SUPPORT FOR 16983CCCCC KENDELL'S TAU CORRELATION. 16984CCCCC JUNE 2012. SUPPORT FOR CORRELATION CDF MATRIX AND 16985CCCCC CORRELATION PVALUE MATRIX 16986CCCCC SEPTEMBER 2016. SUPPORT FOR: 16987CCCCC SET CORRELATION ABSOLUTE VALUE <ON/OFF> 16988CCCCC SET CORRELATION PERCENTAGE VALUE <ON/OFF> 16989CCCCC SET CORRELATION DIGITS <VALUE> 16990C 16991 NTRIM1=-1 16992 NTRIM2=-1 16993 IF(ICORDI.EQ.'COLU')THEN 16994 IWRITE='OFF' 16995 DO5251J=1,NC1 16996 DO5261K=1,NC1 16997 DO5255I=1,NR1 16998 Y3(I)=YM1(I,J) 16999 Y4(I)=YM1(I,K) 17000 5255 CONTINUE 17001 IF(ICORTY.EQ.'RANK')THEN 17002 CALL RANKCR(Y3,Y4,NR1,IRCRTA,IWRITE,Y1,Y2,VECT9,MAXOBV, 17003 1 RIGHT,STATCD,PVAL,PVALLT,PVALUT, 17004 1 CUTU90,CUTU95,CTU975,CUTU99,CTU995,CTU999, 17005 1 CUTL90,CUTL95,CTL975,CUTL99,CTL995,CTL999, 17006 1 IBUGA3,ISUBRO,IERROR) 17007 ELSEIF(ICORTY.EQ.'WINS')THEN 17008 CALL WINSOR(Y3,NR1,P1,P2,NTRIM1,NTRIM2,IWRITE, 17009 1 Y1,MAXOBV,Y2, 17010 1 IBUGA3,ISUBRO,IERROR) 17011 DO5281I=1,NR1 17012 Y3(I)=Y2(I) 17013 5281 CONTINUE 17014 CALL WINSOR(Y4,NR1,P1,P2,NTRIM1,NTRIM2,IWRITE, 17015 1 Y1,MAXOBV,Y2, 17016 1 IBUGA3,ISUBRO,IERROR) 17017 DO5286I=1,NR1 17018 Y4(I)=Y2(I) 17019 5286 CONTINUE 17020 CALL CORR(Y3,Y4,NR1,IWRITE,RIGHT,IBUGA3,IERROR) 17021 ELSEIF(ICORTY.EQ.'PBCR')THEN 17022 CALL PBNCOR(Y3,Y4,NR1,IWRITE,Y1,Y2,MAXOBV,RIGHT,BETA, 17023 1 IBUGA3,IERROR) 17024 ELSEIF(ICOVTY.EQ.'BIWE')THEN 17025 CALL BIWMDV(Y3,NR1,IWRITE,Y1,Y2,MAXOBV,RIGH1, 17026 1 IBUGA3,IERROR) 17027 CALL BIWMDV(Y4,NR1,IWRITE,Y1,Y2,MAXOBV,RIGH2, 17028 1 IBUGA3,IERROR) 17029 CALL BIWMCV(Y3,Y4,NR1,IWRITE,Y1,Y2,MAXOBV,RIGH3, 17030 1 IBUGA3,IERROR) 17031 RIGH4=RIGH1*RIGH2 17032 IF(RIGH4.GT.0.0)THEN 17033 RIGHT=RIGH3/SQRT(RIGH4) 17034 ELSE 17035 RIGHT=0.0 17036 ENDIF 17037 ELSEIF(ICORTY.EQ.'KTAU')THEN 17038 ICASZZ='TWOS' 17039 CALL KENTAU(Y3,Y4,NR1,ICASZZ,IKTATA,IWRITE,Y1,Y2,MAXOBV, 17040 1 RIGHT,AKTAUA,AKTAUB,AKTAUC, 17041 1 STATCD,PVAL,PVALLT,PVALUT, 17042 1 CUTU90,CUTU95,CTU975,CUTU99,CTU995, 17043 1 CUTL90,CUTL95,CTL975,CUTL99,CTL995, 17044 1 IBUGA3,ISUBRO,IERROR) 17045 ELSE 17046 CALL CORR(Y3,Y4,NR1,IWRITE,RIGHT,IBUGA3,IERROR) 17047 ENDIF 17048 IF(ICORAV.EQ.'ON')RIGHT=ABS(RIGHT) 17049 IF(ICORPV.EQ.'ON')RIGHT=100.*RIGHT 17050 IF(ICORDG.EQ.0)THEN 17051 RIGHT=INT(RIGHT+0.5) 17052 ELSEIF(ICORDG.GE.1 .AND. ICORDG.LE.6)THEN 17053 IPOWER=INT(AINT(ICORDG+0.5)) 17054 RIGHT=REAL(INT(RIGHT*10**IPOWER + 0.5))/10**IPOWER 17055 ENDIF 17056 YM9(J,K)=RIGHT 17057 5261 CONTINUE 17058 5251 CONTINUE 17059 NR9=NC1 17060 NC9=NC1 17061 ELSE 17062 IWRITE='OFF' 17063 DO5221J=1,NR1 17064 DO5231K=1,NR1 17065 DO5225I=1,NC1 17066 Y3(I)=YM1(J,I) 17067 Y4(I)=YM1(K,I) 17068 5225 CONTINUE 17069 IF(ICORTY.EQ.'RANK')THEN 17070 CALL RANKCR(Y3,Y4,NC1,IRCRTA,IWRITE,Y1,Y2,VECT9,MAXOBV, 17071 1 RIGHT,STATCD,PVAL,PVALLT,PVALUT, 17072 1 CUTU90,CUTU95,CTU975,CUTU99,CTU995,CTU999, 17073 1 CUTL90,CUTL95,CTL975,CUTL99,CTL995,CTL999, 17074 1 IBUGA3,ISUBRO,IERROR) 17075 ELSEIF(ICORTY.EQ.'WINS')THEN 17076 CALL WINSOR(Y3,NC1,P1,P2,NTRIM1,NTRIM2,IWRITE, 17077 1 Y1,MAXOBV,Y2, 17078 1 IBUGA3,ISUBRO,IERROR) 17079 DO5241I=1,NC1 17080 Y3(I)=Y2(I) 17081 5241 CONTINUE 17082 CALL WINSOR(Y4,NC1,P1,P2,NTRIM1,NTRIM2,IWRITE, 17083 1 Y1,MAXOBV,Y2, 17084 1 IBUGA3,ISUBRO,IERROR) 17085 DO5246I=1,NC1 17086 Y4(I)=Y2(I) 17087 5246 CONTINUE 17088 CALL CORR(Y3,Y4,NC1,IWRITE,RIGHT,IBUGA3,IERROR) 17089 ELSEIF(ICORTY.EQ.'PBCR')THEN 17090 CALL PBNCOR(Y3,Y4,NC1,IWRITE,Y1,Y2,MAXOBV,RIGHT,BETA, 17091 1 IBUGA3,IERROR) 17092 ELSEIF(ICOVTY.EQ.'BIWE')THEN 17093 CALL BIWMDV(Y3,NC1,IWRITE,Y1,Y2,MAXOBV,RIGH1, 17094 1 IBUGA3,IERROR) 17095 CALL BIWMDV(Y4,NC1,IWRITE,Y1,Y2,MAXOBV,RIGH2, 17096 1 IBUGA3,IERROR) 17097 CALL BIWMCV(Y3,Y4,NC1,IWRITE,Y1,Y2,MAXOBV,RIGH3, 17098 1 IBUGA3,IERROR) 17099 RIGH4=RIGH1*RIGH2 17100 IF(RIGH4.GT.0.0)THEN 17101 RIGHT=RIGH3/SQRT(RIGH4) 17102 ELSE 17103 RIGHT=0.0 17104 ENDIF 17105 ELSEIF(ICORTY.EQ.'KTAU')THEN 17106 ICASZZ='TWOS' 17107 CALL KENTAU(Y3,Y4,NC1,ICASZZ,IKTATA,IWRITE,Y1,Y2,MAXOBV, 17108 1 RIGHT,AKTAUA,AKTAUB,AKTAUC, 17109 1 STATCD,PVAL,PVALLT,PVALUT, 17110 1 CUTU90,CUTU95,CTU975,CUTU99,CTU995, 17111 1 CUTL90,CUTL95,CTL975,CUTL99,CTL995, 17112 1 IBUGA3,ISUBRO,IERROR) 17113 ELSE 17114 CALL CORR(Y3,Y4,NC1,IWRITE,RIGHT,IBUGA3,IERROR) 17115 ENDIF 17116 IF(ICORAV.EQ.'ON')RIGHT=ABS(RIGHT) 17117 IF(ICORPV.EQ.'ON')RIGHT=100.*RIGHT 17118 IF(ICORDG.EQ.0)THEN 17119 RIGHT=INT(RIGHT+0.5) 17120 ELSEIF(ICORDG.GE.1 .AND. ICORDG.LE.6)THEN 17121 IPOWER=INT(AINT(ICORDG+0.5)) 17122 RIGHT=REAL(INT(RIGHT*10**IPOWER + 0.5))/10**IPOWER 17123 ENDIF 17124 YM9(J,K)=RIGHT 17125 5231 CONTINUE 17126 5221 CONTINUE 17127 NR9=NR1 17128 NC9=NR1 17129 ENDIF 17130C 17131C SAVE EITHER THE CDF VALUES OR THE P-VALUES. 17132C 17133 IF(IMCASE.EQ.'MACC')THEN 17134 IDF1=1 17135 IDF2=NR1 - 2 17136 DO5291J=1,NC9 17137 DO5292I=1,NR9 17138 IF(I.EQ.J)THEN 17139 YM9(I,J)=0.0 17140 ELSE 17141 ANUM=REAL(NR1 - 2)*YM9(I,J)**2 17142 DENOM=1.0 - YM9(I,J)**2 17143 CDF=0.0 17144 IF(DENOM.NE.0.0)THEN 17145 AVAL=ABS(ANUM/DENOM) 17146 CALL FCDF(AVAL,IDF1,IDF2,CDF) 17147 ENDIF 17148 YM9(I,J)=CDF 17149 ENDIF 17150 5292 CONTINUE 17151 5291 CONTINUE 17152 ELSEIF(IMCASE.EQ.'MACP')THEN 17153 IDF1=1 17154 IDF2=NR1 - 2 17155 DO5296J=1,NC9 17156 DO5297I=1,NR9 17157 IF(I.EQ.J)THEN 17158 YM9(I,J)=1.0 17159 ELSE 17160 ANUM=REAL(NR1 - 2)*YM9(I,J)**2 17161 DENOM=1.0 - YM9(I,J)**2 17162 CDF=0.0 17163 IF(DENOM.NE.0.0)THEN 17164 AVAL=ABS(ANUM/DENOM) 17165 CALL FCDF(AVAL,IDF1,IDF2,CDF) 17166 ENDIF 17167 YM9(I,J)=1.0 - CDF 17168 ENDIF 17169 5297 CONTINUE 17170 5296 CONTINUE 17171 ENDIF 17172C 17173 ITYP9='MATR' 17174 IUPFLG='FULL' 17175 GOTO9000 17176C 17177C ************************************************************** 17178C ** STEP 53-- ** 17179C ** TREAT THE PRINCIPLE COMPONENTS CASE ** 17180C ** TREAT THE PRINCIPLE COMPONENTS EIGENVECTORS CASE ** 17181C ** TREAT THE PRINCIPLE COMPONENTS EIGENVALUES CASE ** 17182C ** REFERENCE--JACKSON, J. E. (1980, 1981) ** 17183C ** PRINCIPLE COMPONENTS AND FACTOR ANALYSIS: ** 17184C ** PART 1--PRINCIPLE COMPONENTS, ** 17185C ** JQT OCT 1980, PAGES 201-213. ** 17186C ** PART 2--ADDITIONAL TOPICS RELATED ** 17187C ** TO PRINCIPLE COMPONENTS, ** 17188C ** JQT JAN 1981, PAGES 46-58. ** 17189C ** PART 3--WHAT IS FACTOR ANALYSIS?, ** 17190C ** JQT APR 1981, PAGES 125-130. ** 17191C ** REFERENCE--LAWTON, W. H., SYLVESTRE, E. A., ** 17192C ** AND MAGGIA, M. S. (1972). ** 17193C ** SELF MODELING NONLINEAR REGRESSION. ** 17194C ** TECHNOMETRICS, AUGUST, 1972, ** 17195C ** PAGES 513-532. ** 17196C ************************************************************** 17197C 17198 5300 CONTINUE 17199C 17200 IF(PCCASE.EQ.'DACV')GOTO5310 17201 IF(PCCASE.EQ.'DACR')GOTO5310 17202 GOTO5329 17203C 17204 5310 CONTINUE 17205 DO5311J=1,NC1 17206 DSUM1=0.0D0 17207 DO5312I=1,NR1 17208 DYM1=YM1(I,J) 17209 DSUM1=DSUM1+DYM1 17210 5312 CONTINUE 17211 DMEAN(J)=D999 17212 DDENOM=DNR1 17213 IF(DDENOM.NE.0.0D0)DMEAN(J)=DSUM1/DDENOM 17214 5311 CONTINUE 17215C 17216 DO5321J=1,NC1 17217 DO5322K=J,NC1 17218 DSUM1=0.0D0 17219 DO5323I=1,NR1 17220 DYM1=YM1(I,J) 17221 DYM2=YM1(I,K) 17222 DDEL1=DYM1-DMEAN(J) 17223 DDEL2=DYM2-DMEAN(K) 17224 DSUM1=DSUM1+DDEL1*DDEL2 17225 5323 CONTINUE 17226 DCOV=D999 17227 DDENOM=DNR1-1.0D0 17228 IF(DDENOM.NE.0.0D0)DCOV=DSUM1/DDENOM 17229 YM2(J,K)=DCOV 17230 YM2(K,J)=DCOV 17231 5322 CONTINUE 17232 5321 CONTINUE 17233 5329 CONTINUE 17234C 17235 IF(PCCASE.EQ.'DACV')GOTO5360 17236 IF(PCCASE.EQ.'DACR')GOTO5340 17237 IF(PCCASE.EQ.'CVCV')GOTO5330 17238 IF(PCCASE.EQ.'CVCR')GOTO5330 17239 IF(PCCASE.EQ.'CRCV')GOTO5350 17240 IF(PCCASE.EQ.'CRCR')GOTO5330 17241 GOTO5360 17242C 17243 5330 CONTINUE 17244 DO5331I=1,NR1 17245 DO5332J=1,NC1 17246 YM2(I,J)=YM1(I,J) 17247 5332 CONTINUE 17248 5331 CONTINUE 17249 IF(PCCASE.EQ.'CVCR')GOTO5340 17250 GOTO5360 17251C 17252 5340 CONTINUE 17253 DO5341I=1,NC1 17254 S1=YM2(I,I) 17255 S1=SQRT(S1) 17256 DO5342J=1,NC1 17257 S2=YM2(J,J) 17258 S2=SQRT(S2) 17259 IF(I.EQ.J)GOTO5342 17260 S1S2=S1*S2 17261 IF(S1S2.LE.0.0)YM2(I,J)=(-999.99) 17262 IF(S1S2.GT.0.0)YM2(I,J)=YM2(I,J)/S1S2 17263 5342 CONTINUE 17264 5341 CONTINUE 17265 DO5343I=1,NC1 17266 YM2(I,I)=1.0 17267 5343 CONTINUE 17268 GOTO5360 17269C 17270 5350 CONTINUE 17271 WRITE(ICOUT,999) 17272 CALL DPWRST('XXX','BUG ') 17273 WRITE(ICOUT,5351) 17274 5351 FORMAT('***** ERROR IN MATARI--') 17275 CALL DPWRST('XXX','BUG ') 17276 WRITE(ICOUT,5352) 17277 5352 FORMAT(' ILLEGAL PRINCIPLE COMPONENTS TYPE.') 17278 CALL DPWRST('XXX','BUG ') 17279 WRITE(ICOUT,5353) 17280 5353 FORMAT(' YOU CANNOT SPECIFY THAT THE STARTING MATRIX') 17281 CALL DPWRST('XXX','BUG ') 17282 WRITE(ICOUT,5354) 17283 5354 FORMAT(' IS THE CORRELATION MATRIX,') 17284 CALL DPWRST('XXX','BUG ') 17285 WRITE(ICOUT,5355) 17286 5355 FORMAT(' AND THEN SPECIFY THAT THE INTERMEDIATE MATRIX') 17287 CALL DPWRST('XXX','BUG ') 17288 WRITE(ICOUT,5356) 17289 5356 FORMAT(' IS THE COVARIANCE MATRIX') 17290 CALL DPWRST('XXX','BUG ') 17291 WRITE(ICOUT,5357) 17292 5357 FORMAT(' (SINCE LATTER CANNOT BE DERIVED FROM FORMER).') 17293 CALL DPWRST('XXX','BUG ') 17294 WRITE(ICOUT,5358) 17295 5358 FORMAT(' FIX BY USING THE PRINCIPLE COMPONENTS TYPE') 17296 CALL DPWRST('XXX','BUG ') 17297 WRITE(ICOUT,5359) 17298 5359 FORMAT(' COMMAND.') 17299 CALL DPWRST('XXX','BUG ') 17300 IERROR='YES' 17301 GOTO9000 17302C 17303 5360 CONTINUE 17304 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TARI')GOTO5361 17305 GOTO5369 17306 5361 CONTINUE 17307 WRITE(ICOUT,999) 17308 CALL DPWRST('XXX','BUG ') 17309 WRITE(ICOUT,5362) 17310 5362 FORMAT('***** FROM THE MIDDLE OF MATARI--') 17311 CALL DPWRST('XXX','BUG ') 17312 WRITE(ICOUT,5363)NC1,MAXCOM 17313 5363 FORMAT('NC1,MAXCOM = ',2I8) 17314 CALL DPWRST('XXX','BUG ') 17315 DO5364I=1,NC1 17316 DO5365J=1,NC1 17317 WRITE(ICOUT,5366)I,J,YM2(I,J) 17318 5366 FORMAT('I,J,YM2(I,J) = ',2I8,E15.7) 17319 CALL DPWRST('XXX','BUG ') 17320 5365 CONTINUE 17321 5364 CONTINUE 17322 5369 CONTINUE 17323C 17324CCCCC JULY 1993. USE EISPACK ROUTINES (NOTE THAT CORRELATION OR 17325CCCCC COVARIANCE MATRIX IS SYMMETRIC). 17326CCCCC ALSO, SINCE MAXROM AND MAXCOM NO LONGER EQUAL, BE SURE TO SEND 17327CCCCC MAXROM AS MATRIX LEADING DIMENSION. 17328CCCCC CALL JACOBI(YMJUNK,NC1,MAXCOM,VJUNK,YM9,NJACIT) 17329C 17330 IERR2=0 17331 IJOB=1 17332 DO5650J=1,NC1 17333 DO5651I=1,NC1 17334 YM9(I,J)=YM2(I,J) 17335 5651 CONTINUE 17336 5650 CONTINUE 17337 CALL SSIEV(YM9,MAXROM,NC1,Y3,Y4,IJOB,IERR2) 17338 IF(IERR2.NE.0)THEN 17339 IERROR='YES' 17340 WRITE(ICOUT,5661) 17341 WRITE(ICOUT,5662) 17342 WRITE(ICOUT,5663) 17343 GOTO9000 17344 END IF 17345 5661 FORMAT('******** ERROR FROM MATARI ************') 17346 5662 FORMAT(' UNABLE TO CALCULATE EIGENVALUES CORRECTLY.') 17347 5663 FORMAT(' PRINCIPLE COMPONENTS WERE NOT COMPUTED.') 17348CCCCC END CHANGE 17349C 17350 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TARI')GOTO5371 17351 GOTO5379 17352 5371 CONTINUE 17353 WRITE(ICOUT,999) 17354 CALL DPWRST('XXX','BUG ') 17355 WRITE(ICOUT,5372) 17356 5372 FORMAT('***** FROM THE MIDDLE OF MATARI--') 17357 CALL DPWRST('XXX','BUG ') 17358CCCCC WRITE(ICOUT,5373)NC1,MAXCOM,NJACIT 17359C5373 FORMAT('NC1,MAXCOM,NJACIT = ',3I8) 17360 WRITE(ICOUT,5373)NC1,MAXCOM 17361 5373 FORMAT('NC1,MAXCOM= ',2I8) 17362 CALL DPWRST('XXX','BUG ') 17363 DO5374I=1,NC1 17364 DO5375J=1,NC1 17365 WRITE(ICOUT,5376)I,J,YM9(I,J),Y3(I) 17366 5376 FORMAT('I,J,YM9(I,J),Y3(I) = ',2I8,2E15.7) 17367 CALL DPWRST('XXX','BUG ') 17368 5375 CONTINUE 17369 5374 CONTINUE 17370 5379 CONTINUE 17371C 17372 DO5380I=1,NC1 17373CCCCC AINDE2(I)=I 17374 Y1(I)=I 17375 5380 CONTINUE 17376C 17377CCCCC CALL SORTC(Y3,AINDE2,NC1,Y4,AINDE3) 17378 CALL SORTC(Y3,Y1,NC1,Y4,Y2) 17379C 17380 DO5390J=1,NC1 17381 JREV=NC1-J+1 17382CCCCC INDEX3=AINDE3(JREV)+0.5 17383 INDEX3=INT(Y2(JREV)+0.5) 17384 VECT9(J)=Y3(INDEX3) 17385 5390 CONTINUE 17386C 17387 DO5411J=1,NC1 17388 JREV=NC1-J+1 17389CCCCC INDEX3=AINDE3(JREV)+0.5 17390 INDEX3=INT(Y2(JREV)+0.5) 17391 DO5412I=1,NC1 17392 YM2(I,J)=YM9(I,INDEX3) 17393 5412 CONTINUE 17394 5411 CONTINUE 17395C 17396 DO5416I=1,NC1 17397 DO5417J=1,NC1 17398 YM9(I,J)=YM2(I,J) 17399 5417 CONTINUE 17400 5416 CONTINUE 17401C 17402 IF(IMCASE.EQ.'MAPC')GOTO5430 17403 GOTO5500 17404C 17405 5430 CONTINUE 17406 IF(IMSUBC.EQ.'EVEC')GOTO5440 17407 IF(IMSUBC.EQ.'EVAL')GOTO5450 17408 GOTO5460 17409C 17410 5440 CONTINUE 17411 ITYP9='MATR' 17412 NR9=NC1 17413 NC9=NC1 17414 IUPFLG='FULL' 17415 GOTO9000 17416C 17417 5450 CONTINUE 17418 ITYP9='VECT' 17419 NVECT9=NC1 17420 IUPFLG='FULL' 17421 GOTO9000 17422C 17423 5460 CONTINUE 17424 DO5461I=1,NR1 17425 DO5462J=1,NC1 17426 DSUM=0.0D0 17427 DO5463K=1,NC1 17428 DYM1=YM1(I,K) 17429 DDEL=DYM1-DMEAN(K) 17430 DYM2=YM9(K,J) 17431 DYM9=DDEL*DYM2 17432 DSUM=DSUM+DYM9 17433 5463 CONTINUE 17434 YM2(I,J)=DSUM 17435 5462 CONTINUE 17436 5461 CONTINUE 17437 DO5465I=1,NR1 17438 DO5466J=1,NC1 17439 YM9(I,J)=YM2(I,J) 17440 5466 CONTINUE 17441 5465 CONTINUE 17442 ITYP9='MATR' 17443 NR9=NR1 17444 NC9=NC1 17445 IUPFLG='FULL' 17446 GOTO9000 17447C 17448 5500 CONTINUE 17449 L=1 17450 IF(IMCASE.EQ.'MAP2')L=2 17451 IF(IMCASE.EQ.'MAP3')L=3 17452 IF(IMCASE.EQ.'MAP4')L=4 17453 IF(IMCASE.EQ.'MAP5')L=5 17454 IF(IMCASE.EQ.'MAP6')L=6 17455 IF(IMCASE.EQ.'MAP7')L=7 17456 IF(IMCASE.EQ.'MAP8')L=8 17457 IF(IMCASE.EQ.'MAP9')L=9 17458 IF(IMCASE.EQ.'MA10')L=10 17459C 17460 IF(IMSUBC.EQ.'EVEC')GOTO5530 17461 IF(IMSUBC.EQ.'EVAL')GOTO5540 17462 GOTO5550 17463C 17464 5530 CONTINUE 17465 DO5531I=1,NC1 17466 VECT9(I)=YM9(I,L) 17467 5531 CONTINUE 17468 ITYP9='VECT' 17469 NVECT9=NC1 17470 IUPFLG='FULL' 17471 GOTO9000 17472C 17473 5540 CONTINUE 17474 ITYP9='SCAL' 17475 SCAL9=VECT9(L) 17476 IUPFLG='FULL' 17477 GOTO9000 17478C 17479 5550 CONTINUE 17480 DO5551I=1,NR1 17481 DSUM=0.0D0 17482 DO5553K=1,NC1 17483 DYM1=YM1(I,K) 17484 DDEL=DYM1-DMEAN(K) 17485 DYM2=YM9(K,L) 17486 DYM9=DDEL*DYM2 17487 DSUM=DSUM+DYM9 17488 5553 CONTINUE 17489 VECT9(I)=DSUM 17490 5551 CONTINUE 17491 ITYP9='VECT' 17492 NVECT9=NR1 17493 IUPFLG='FULL' 17494 GOTO9000 17495C 17496C ************************************************** 17497C ** STEP 54-- ** 17498C ** TREAT THE MATRIX TRUNCATION CASE ** 17499C ** THIS COMMAND SETS ANY VALUE BELOW THE ** 17500C ** TRUNCATION VALUE TO THAT TRUNCATION ** 17501C ** VALUE. A COMMON USE OF THIS COMMAND ** 17502C ** MIGHT BE TO REMOVE BACKGROUND (USE ** 17503C ** MATRIX SUBTRACTION TO REMOVE THE ** 17504C ** BACKGROUND AND THEN USE MATRIX TRUNCATION ** 17505C ** TO SET ANY RESULTING NEGATIVE VALUES (I.E., ** 17506C ** POINTS BELOW THE BACKGROUND LEVEL) TO ZERO. ** 17507C ************************************************** 17508C 17509 6100 CONTINUE 17510C 17511 IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'PARA')GOTO6170 17512 IF(ITYPA1.EQ.'PARA'.AND.ITYPA2.EQ.'MATR')GOTO6180 17513C 17514 WRITE(ICOUT,999) 17515 CALL DPWRST('XXX','BUG ') 17516 WRITE(ICOUT,6101) 17517 6101 FORMAT('***** ERROR IN MATARI--') 17518 CALL DPWRST('XXX','BUG ') 17519 WRITE(ICOUT,6102) 17520 6102 FORMAT(' ILLEGAL ARGUMENT TYPES FOR MATRIX TRUNCATION.') 17521 CALL DPWRST('XXX','BUG ') 17522 WRITE(ICOUT,6103)ITYPA1 17523 6103 FORMAT(' TYPE FOR ARGUMENT 1 = ',A4) 17524 CALL DPWRST('XXX','BUG ') 17525 WRITE(ICOUT,6104)ITYPA2 17526 6104 FORMAT(' TYPE FOR ARGUMENT 2 = ',A4) 17527 CALL DPWRST('XXX','BUG ') 17528 IERROR='YES' 17529 GOTO9000 17530C 17531 6170 CONTINUE 17532 DO6171I=1,NR1 17533 DO6172J=1,NC1 17534 YM9(I,J)=MAX(YM1(I,J),YS2) 17535 6172 CONTINUE 17536 6171 CONTINUE 17537 ITYP9='MATR' 17538 NR9=NR1 17539 NC9=NC1 17540 IUPFLG='SUBS' 17541 GOTO9000 17542C 17543 6180 CONTINUE 17544 DO6181I=1,NR1 17545 DO6182J=1,NC1 17546 YM9(I,J)=MAX(YM2(I,J),YS1) 17547 6182 CONTINUE 17548 6181 CONTINUE 17549 ITYP9='MATR' 17550 NR9=NR1 17551 NC9=NC1 17552 IUPFLG='SUBS' 17553 GOTO9000 17554C 17555C ************************************************** 17556C ** STEP 55-- ** 17557C ** TREAT THE MATRIX UPPER TRUNCATION CASE ** 17558C ** THIS COMMAND SETS ANY VALUE ABOVE THE ** 17559C ** TRUNCATION VALUE TO THAT TRUNCATION ** 17560C ** VALUE. ** 17561C ************************************************** 17562C 17563 6200 CONTINUE 17564C 17565 IF(ITYPA1.EQ.'MATR'.AND.ITYPA2.EQ.'PARA')GOTO6270 17566 IF(ITYPA1.EQ.'PARA'.AND.ITYPA2.EQ.'MATR')GOTO6280 17567C 17568 WRITE(ICOUT,999) 17569 CALL DPWRST('XXX','BUG ') 17570 WRITE(ICOUT,6201) 17571 6201 FORMAT('***** ERROR IN MATARI--') 17572 CALL DPWRST('XXX','BUG ') 17573 WRITE(ICOUT,6202) 17574 6202 FORMAT(' ILLEGAL ARGUMENT TYPES FOR MATRIX UPPER ', 17575 1 'TRUNCATION.') 17576 CALL DPWRST('XXX','BUG ') 17577 WRITE(ICOUT,6203)ITYPA1 17578 6203 FORMAT(' TYPE FOR ARGUMENT 1 = ',A4) 17579 CALL DPWRST('XXX','BUG ') 17580 WRITE(ICOUT,6204)ITYPA2 17581 6204 FORMAT(' TYPE FOR ARGUMENT 2 = ',A4) 17582 CALL DPWRST('XXX','BUG ') 17583 IERROR='YES' 17584 GOTO9000 17585C 17586 6270 CONTINUE 17587 DO6271I=1,NR1 17588 DO6272J=1,NC1 17589 YM9(I,J)=MIN(YM1(I,J),YS2) 17590 6272 CONTINUE 17591 6271 CONTINUE 17592 ITYP9='MATR' 17593 NR9=NR1 17594 NC9=NC1 17595 IUPFLG='SUBS' 17596 GOTO9000 17597C 17598 6280 CONTINUE 17599 DO6281I=1,NR1 17600 DO6282J=1,NC1 17601 YM9(I,J)=MIN(YM2(I,J),YS1) 17602 6282 CONTINUE 17603 6281 CONTINUE 17604 ITYP9='MATR' 17605 NR9=NR1 17606 NC9=NC1 17607 IUPFLG='SUBS' 17608 GOTO9000 17609C 17610C ****************************************************** 17611C ** STEP 63-- ** 17612C ** TREAT THE COMOVEMENT CASE ** 17613C ****************************************************** 17614C 17615 6300 CONTINUE 17616C 17617 IF(ICORDI.EQ.'COLU')THEN 17618 IWRITE='OFF' 17619 DO6351J=1,NC1 17620 DO6361K=1,NC1 17621 DO6355I=1,NR1 17622 Y3(I)=YM1(I,J) 17623 Y4(I)=YM1(I,K) 17624 6355 CONTINUE 17625 IF(ICORTY.EQ.'RANK')THEN 17626 CALL RANKCM(Y3,Y4,NR1,IWRITE,Y1,Y2,VECT9,MAXOBV,RIGHT, 17627 1 IBUGA3,IERROR) 17628 ELSE 17629 CALL COMOVE(Y3,Y4,NR1,IWRITE,RIGHT,IBUGA3,IERROR) 17630 ENDIF 17631 YM9(J,K)=RIGHT 17632 6361 CONTINUE 17633 6351 CONTINUE 17634 NR9=NC1 17635 NC9=NC1 17636 ELSE 17637 IWRITE='OFF' 17638 DO6321J=1,NR1 17639 DO6331K=1,NR1 17640 DO6325I=1,NC1 17641 Y3(I)=YM1(J,I) 17642 Y4(I)=YM1(K,I) 17643 6325 CONTINUE 17644 IF(ICORTY.EQ.'RANK')THEN 17645 CALL RANKCM(Y3,Y4,NC1,IWRITE,Y1,Y2,VECT9,MAXOBV,RIGHT, 17646 1 IBUGA3,IERROR) 17647 ELSE 17648 CALL COMOVE(Y3,Y4,NC1,IWRITE,RIGHT,IBUGA3,IERROR) 17649 ENDIF 17650 YM9(J,K)=RIGHT 17651 6331 CONTINUE 17652 6321 CONTINUE 17653 NR9=NR1 17654 NC9=NR1 17655 ENDIF 17656C 17657 ITYP9='MATR' 17658 IUPFLG='FULL' 17659 GOTO9000 17660C 17661C ****************************************************** 17662C ** STEP 64-- ** 17663C ** TREAT THE PARTIAL CORRELATION CASE ** 17664C ****************************************************** 17665C 17666 6400 CONTINUE 17667C 17668CCCCC COMPUTE THE PARTIAL CORRELATION MATRIX. AS WITH THE REGULAR 17669CCCCC CORRELATION MATRIX, SUPPORT FOR: 17670CCCCC 17671CCCCC 1. EITHER COLUMN (DEFAULT) OR ROW BASED CORRELATIONS 17672CCCCC 2. SUPPORT FOR PEARSON CORRELATION, WINSORIZED CORRELATION, 17673CCCCC BIWEIGHT MID-CORRELATION, RANK CORRELATION, OR KENDALL TAU 17674CCCCC CORRELATION. 17675CCCCC 17676CCCCC ALGORITHM IS: 17677CCCCC 17678CCCCC 1. COMPUTE THE STANDARD CORRELATION MATRIX 17679CCCCC 2. INVERT THE CORELATION MATRIX 17680CCCCC 3. R(ij.) = -R(ij)/SQRT(R(ii)*R(jj)) 17681CCCCC WHERE R(IJ) IS THE IJ-TH ELEMENT OF THE INVERTED CORRELATION 17682CCCCC MATRIX. 17683CCCCC 17684CCCCC AUTOMATICALLY SET THE DIAGONAL ELEMENTS TO +1. 17685C 17686C NUMBER OF ROWS (N) MUST BE GREATER THAN NUMBER OF COLUMNS 17687C 17688 IF(ICORDI.EQ.'COLU')THEN 17689 IF(NR1-NC1.LT.1)THEN 17690 WRITE(ICOUT,999) 17691 CALL DPWRST('XXX','BUG ') 17692 WRITE(ICOUT,6423) 17693 CALL DPWRST('XXX','ERRO') 17694 WRITE(ICOUT,6491) 17695 6491 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX MUST BE ', 17696 1 'GREATER THAN THE NUMBER OF COLUMNS.') 17697 CALL DPWRST('XXX','ERRO') 17698 WRITE(ICOUT,6493)NR1 17699 6493 FORMAT(' THE NUMBER OF ROWS = ',I8) 17700 CALL DPWRST('XXX','ERRO') 17701 WRITE(ICOUT,6495)NC1 17702 6495 FORMAT(' THE NUMBER OF COLUMNS = ',I8) 17703 CALL DPWRST('XXX','ERRO') 17704 IERROR='YES' 17705 GOTO9000 17706 ENDIF 17707 ELSE 17708 IF(NC1-NR1.LT.1)THEN 17709 WRITE(ICOUT,999) 17710 CALL DPWRST('XXX','BUG ') 17711 WRITE(ICOUT,6423) 17712 CALL DPWRST('XXX','ERRO') 17713 WRITE(ICOUT,6492) 17714 6492 FORMAT(' THE NUMBER OF COLUMNS IN THE MATRIX MUST BE ', 17715 1 'GREATER THAN THE NUMBER OF ROWS.') 17716 CALL DPWRST('XXX','ERRO') 17717 WRITE(ICOUT,6493)NR1 17718 CALL DPWRST('XXX','ERRO') 17719 WRITE(ICOUT,6495)NC1 17720 CALL DPWRST('XXX','ERRO') 17721 IERROR='YES' 17722 GOTO9000 17723 ENDIF 17724 ENDIF 17725C 17726 NTRIM1=-1 17727 NTRIM2=-1 17728 IF(ICORDI.EQ.'COLU')THEN 17729 IWRITE='OFF' 17730 DO6401J=1,NC1 17731 DO6402K=1,NC1 17732 DO6403I=1,NR1 17733 Y3(I)=YM1(I,J) 17734 Y4(I)=YM1(I,K) 17735 6403 CONTINUE 17736 IF(ICORTY.EQ.'RANK')THEN 17737 CALL RANKCR(Y3,Y4,NR1,IRCRTA,IWRITE,Y1,Y2,VECT9,MAXOBV, 17738 1 RIGHT,STATCD,PVAL,PVALLT,PVALUT, 17739 1 CUTU90,CUTU95,CTU975,CUTU99,CTU995,CTU999, 17740 1 CUTL90,CUTL95,CTL975,CUTL99,CTL995,CTL999, 17741 1 IBUGA3,ISUBRO,IERROR) 17742 ELSEIF(ICORTY.EQ.'WINS')THEN 17743 CALL WINSOR(Y3,NR1,P1,P2,NTRIM1,NTRIM2,IWRITE, 17744 1 Y1,MAXOBV,Y2, 17745 1 IBUGA3,ISUBRO,IERROR) 17746 DO6406I=1,NR1 17747 Y3(I)=Y2(I) 17748 6406 CONTINUE 17749 CALL WINSOR(Y4,NR1,P1,P2,NTRIM1,NTRIM2,IWRITE, 17750 1 Y1,MAXOBV,Y2, 17751 1 IBUGA3,ISUBRO,IERROR) 17752 DO6407I=1,NR1 17753 Y4(I)=Y2(I) 17754 6407 CONTINUE 17755 CALL CORR(Y3,Y4,NR1,IWRITE,RIGHT,IBUGA3,IERROR) 17756 ELSEIF(ICORTY.EQ.'PBCR')THEN 17757 CALL PBNCOR(Y3,Y4,NR1,IWRITE,Y1,Y2,MAXOBV,RIGHT,BETA, 17758 1 IBUGA3,IERROR) 17759 ELSEIF(ICOVTY.EQ.'BIWE')THEN 17760 CALL BIWMDV(Y3,NR1,IWRITE,Y1,Y2,MAXOBV,RIGH1, 17761 1 IBUGA3,IERROR) 17762 CALL BIWMDV(Y4,NR1,IWRITE,Y1,Y2,MAXOBV,RIGH2, 17763 1 IBUGA3,IERROR) 17764 CALL BIWMCV(Y3,Y4,NR1,IWRITE,Y1,Y2,MAXOBV,RIGH3, 17765 1 IBUGA3,IERROR) 17766 RIGH4=RIGH1*RIGH2 17767 IF(RIGH4.GT.0.0)THEN 17768 RIGHT=RIGH3/SQRT(RIGH4) 17769 ELSE 17770 RIGHT=0.0 17771 ENDIF 17772 ELSEIF(ICORTY.EQ.'KTAU')THEN 17773 ICASZZ='TWOS' 17774 CALL KENTAU(Y3,Y4,NR1,ICASZZ,IKTATA,IWRITE,Y1,Y2,MAXOBV, 17775 1 RIGHT,AKTAUA,AKTAUB,AKTAUC, 17776 1 STATCD,PVAL,PVALLT,PVALUT, 17777 1 CUTU90,CUTU95,CTU975,CUTU99,CTU995, 17778 1 CUTL90,CUTL95,CTL975,CUTL99,CTL995, 17779 1 IBUGA3,ISUBRO,IERROR) 17780 ELSE 17781 CALL CORR(Y3,Y4,NR1,IWRITE,RIGHT,IBUGA3,IERROR) 17782 ENDIF 17783 YM9(J,K)=RIGHT 17784 6402 CONTINUE 17785 6401 CONTINUE 17786 NR9=NC1 17787 NC9=NC1 17788 ELSE 17789 IWRITE='OFF' 17790 DO6411J=1,NR1 17791 DO6412K=1,NR1 17792 DO6413I=1,NC1 17793 Y3(I)=YM1(J,I) 17794 Y4(I)=YM1(K,I) 17795 6413 CONTINUE 17796 IF(ICORTY.EQ.'RANK')THEN 17797 CALL RANKCR(Y3,Y4,NC1,IRCRTA,IWRITE,Y1,Y2,VECT9,MAXOBV, 17798 1 RIGHT,STATCD,PVAL,PVALLT,PVALUT, 17799 1 CUTU90,CUTU95,CTU975,CUTU99,CTU995,CTU999, 17800 1 CUTL90,CUTL95,CTL975,CUTL99,CTL995,CTL999, 17801 1 IBUGA3,ISUBRO,IERROR) 17802 ELSEIF(ICORTY.EQ.'WINS')THEN 17803 CALL WINSOR(Y3,NC1,P1,P2,NTRIM1,NTRIM2,IWRITE, 17804 1 Y1,MAXOBV,Y2, 17805 1 IBUGA3,ISUBRO,IERROR) 17806 DO6414I=1,NC1 17807 Y3(I)=Y2(I) 17808 6414 CONTINUE 17809 CALL WINSOR(Y4,NC1,P1,P2,NTRIM1,NTRIM2,IWRITE, 17810 1 Y1,MAXOBV,Y2, 17811 1 IBUGA3,ISUBRO,IERROR) 17812 DO6415I=1,NC1 17813 Y4(I)=Y2(I) 17814 6415 CONTINUE 17815 CALL CORR(Y3,Y4,NC1,IWRITE,RIGHT,IBUGA3,IERROR) 17816 ELSEIF(ICORTY.EQ.'PBCR')THEN 17817 CALL PBNCOR(Y3,Y4,NC1,IWRITE,Y1,Y2,MAXOBV,RIGHT,BETA, 17818 1 IBUGA3,IERROR) 17819 ELSEIF(ICOVTY.EQ.'BIWE')THEN 17820 CALL BIWMDV(Y3,NC1,IWRITE,Y1,Y2,MAXOBV,RIGH1, 17821 1 IBUGA3,IERROR) 17822 CALL BIWMDV(Y4,NC1,IWRITE,Y1,Y2,MAXOBV,RIGH2, 17823 1 IBUGA3,IERROR) 17824 CALL BIWMCV(Y3,Y4,NC1,IWRITE,Y1,Y2,MAXOBV,RIGH3, 17825 1 IBUGA3,IERROR) 17826 RIGH4=RIGH1*RIGH2 17827 IF(RIGH4.GT.0.0)THEN 17828 RIGHT=RIGH3/SQRT(RIGH4) 17829 ELSE 17830 RIGHT=0.0 17831 ENDIF 17832 ELSEIF(ICORTY.EQ.'KTAU')THEN 17833 ICASZZ='TWOS' 17834 CALL KENTAU(Y3,Y4,NC1,ICASZZ,IKTATA,IWRITE,Y1,Y2,MAXOBV, 17835 1 RIGHT,AKTAUA,AKTAUB,AKTAUC, 17836 1 STATCD,PVAL,PVALLT,PVALUT, 17837 1 CUTU90,CUTU95,CTU975,CUTU99,CTU995, 17838 1 CUTL90,CUTL95,CTL975,CUTL99,CTL995, 17839 1 IBUGA3,ISUBRO,IERROR) 17840 ELSE 17841 CALL CORR(Y3,Y4,NC1,IWRITE,RIGHT,IBUGA3,IERROR) 17842 ENDIF 17843 YM9(J,K)=RIGHT 17844 6412 CONTINUE 17845 6411 CONTINUE 17846 NR9=NR1 17847 NC9=NR1 17848 ENDIF 17849C 17850C NOW INVERT THE CORRELATION MATRIX 17851C 17852 CALL SGECO(YM9,MAXROM,NR9,INDEX,RCOND,Y3) 17853 IF(IFEEDB.EQ.'ON')THEN 17854 WRITE(ICOUT,999) 17855 CALL DPWRST('XXX','BUG ') 17856 WRITE(ICOUT,6421)RCOND 17857 CALL DPWRST('XXX','TEXT ') 17858 ENDIF 17859 6421 FORMAT('THE RECIPROCAL CONDITION NUMBER FOR THE CORRELATION ', 17860 1 'MATRIX = ',G15.7) 17861 EPS=1.0E-20 17862 IF(RCOND.LE.EPS)THEN 17863 WRITE(ICOUT,999) 17864 CALL DPWRST('XXX','BUG ') 17865 WRITE(ICOUT,6423) 17866 6423 FORMAT('***** ERROR IN PARTIAL CORRELATION MATRIX--') 17867 CALL DPWRST('XXX','ERRO') 17868 WRITE(ICOUT,6425) 17869 6425 FORMAT(' THE CORRELATION MATRIX IS SINGULAR.') 17870 CALL DPWRST('XXX','ERRO') 17871 IERROR='YES' 17872 ELSE 17873 IJOB=1 17874 CALL SGEDI(YM9,MAXROM,NR9,INDEX,Y3,Y4,IJOB) 17875C 17876 DO6431J=1,NC9 17877 DO6432I=1,NR9 17878 YM1(I,J)=PSTAMV 17879 IF(I.EQ.J)THEN 17880 YM1(I,J)=1.0 17881 ELSE 17882 DENOM=YM9(I,I)*YM9(J,J) 17883 IF(DENOM.GT.0.0)YM1(I,J)=-YM9(I,J)/SQRT(DENOM) 17884 ENDIF 17885 6432 CONTINUE 17886 6431 CONTINUE 17887C 17888C SAVE EITHER THE PARTIAL CORRELATION MATRIX, THE CDF 17889C VALUES, OR THE P-VALUES. 17890C 17891 IF(IMCASE.EQ.'MPCO')THEN 17892 DO6441J=1,NC9 17893 DO6442I=1,NR9 17894 YM9(I,J)=YM1(I,J) 17895 6442 CONTINUE 17896 6441 CONTINUE 17897 ELSEIF(IMCASE.EQ.'MPCC')THEN 17898 IF(ICORDI.EQ.'COLU')THEN 17899 IDF1=1 17900 IDF2=NR1 - NC9 17901 ELSE 17902 IDF1=1 17903 IDF2=NC1 - NR9 17904 ENDIF 17905 DO6451J=1,NC9 17906 DO6452I=1,NR9 17907 YM9(I,J)=YM1(I,J) 17908 IF(I.EQ.J)THEN 17909 YM9(I,J)=0.0 17910 ELSE 17911 ANUM=REAL(NR1 - NC9)*YM1(I,J)**2 17912 DENOM=1.0 - YM1(I,J)**2 17913 CDF=0.0 17914 IF(DENOM.NE.0.0)THEN 17915 AVAL=ABS(ANUM/DENOM) 17916 CALL FCDF(AVAL,IDF1,IDF2,CDF) 17917 ENDIF 17918 YM9(I,J)=CDF 17919 ENDIF 17920 6452 CONTINUE 17921 6451 CONTINUE 17922 ELSEIF(IMCASE.EQ.'MPCP')THEN 17923 IF(ICORDI.EQ.'COLU')THEN 17924 IDF1=1 17925 IDF2=NR1 - NC9 17926 ELSE 17927 IDF1=1 17928 IDF2=NC1 - NR9 17929 ENDIF 17930 DO6461J=1,NC9 17931 DO6462I=1,NR9 17932 YM9(I,J)=YM1(I,J) 17933 IF(I.EQ.J)THEN 17934 YM9(I,J)=1.0 17935 ELSE 17936 ANUM=REAL(NR1 - NC9)*YM1(I,J)**2 17937 DENOM=1.0 - YM1(I,J)**2 17938 CDF=0.0 17939 IF(DENOM.NE.0.0)THEN 17940 AVAL=ABS(ANUM/DENOM) 17941 CALL FCDF(AVAL,IDF1,IDF2,CDF) 17942 ENDIF 17943 YM9(I,J)=1.0 - CDF 17944 ENDIF 17945 6462 CONTINUE 17946 6461 CONTINUE 17947 ENDIF 17948C 17949 END IF 17950C 17951 ITYP9='MATR' 17952 IUPFLG='FULL' 17953 GOTO9000 17954C ***************** 17955C ** STEP 90-- ** 17956C ** EXIT. ** 17957C ***************** 17958C 17959 9000 CONTINUE 17960C 17961 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'TARI')GOTO9090 17962C 17963 WRITE(ICOUT,999) 17964 CALL DPWRST('XXX','BUG ') 17965 WRITE(ICOUT,9011) 17966 9011 FORMAT('***** AT THE END OF MATARI--') 17967 CALL DPWRST('XXX','BUG ') 17968 WRITE(ICOUT,9012)IBUGA3,ISUBRO,IMCASE,ITYPA1,ITYPA2,ITYPA3,ITYPA4 17969 9012 FORMAT('IBUGA3,ISUBRO,IMCASE,ITYPA1,ITYPA2,ITYPA3,ITYPA4 = ', 17970 1A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4) 17971 CALL DPWRST('XXX','BUG ') 17972 WRITE(ICOUT,9013)IMCASE,IMSUBC 17973 9013 FORMAT('IMCASE,IMSUBC = ',A4,2X,A4) 17974 CALL DPWRST('XXX','BUG ') 17975 WRITE(ICOUT,9014)NUMVAR,IWRITE 17976 9014 FORMAT('NUMVAR,IWRITE = ',I8,2X,A4) 17977 CALL DPWRST('XXX','BUG ') 17978 WRITE(ICOUT,9015)YS1,YS2,YS3,YS4 17979 9015 FORMAT('YS1,YS2,YS3,YS4 = ',4E15.7) 17980 CALL DPWRST('XXX','BUG ') 17981 WRITE(ICOUT,9016)IERROR 17982 9016 FORMAT('IERROR = ',A4) 17983 CALL DPWRST('XXX','BUG ') 17984 WRITE(ICOUT,9017)IYS2,IYS3,IYS23,NRJ,NCJ 17985 9017 FORMAT('IYS2,IYS3,IYS23,NRJ,NCJ = ',5I8) 17986 CALL DPWRST('XXX','BUG ') 17987C 17988 WRITE(ICOUT,999) 17989 CALL DPWRST('XXX','BUG ') 17990 WRITE(ICOUT,9031)NR1,NC1 17991 9031 FORMAT('NR1,NC1 = ',2I8) 17992 CALL DPWRST('XXX','BUG ') 17993 IF(NR1.LE.0)GOTO9039 17994 IF(NC1.LE.0)GOTO9039 17995 JMAX=NC1 17996 IF(JMAX.GT.10)JMAX=10 17997 DO9032I=1,NR1 17998 WRITE(ICOUT,9033)I,(YM1(I,J),J=1,JMAX) 17999 9033 FORMAT('I,YM1(I,.) = ',I8,10E10.3) 18000 CALL DPWRST('XXX','BUG ') 18001 9032 CONTINUE 18002 9039 CONTINUE 18003C 18004 WRITE(ICOUT,999) 18005 CALL DPWRST('XXX','BUG ') 18006 WRITE(ICOUT,9041)NR2,NC2 18007 9041 FORMAT('NR2,NC2 = ',2I8) 18008 CALL DPWRST('XXX','BUG ') 18009 IF(NR2.LE.0)GOTO9049 18010 IF(NC2.LE.0)GOTO9049 18011 JMAX=NC2 18012 IF(JMAX.GT.10)JMAX=10 18013 DO9042I=1,NR2 18014 WRITE(ICOUT,9043)I,(YM2(I,J),J=1,JMAX) 18015 9043 FORMAT('I,YM2(I,.) = ',I8,10E10.3) 18016 CALL DPWRST('XXX','BUG ') 18017 9042 CONTINUE 18018 9049 CONTINUE 18019C 18020 WRITE(ICOUT,999) 18021 CALL DPWRST('XXX','BUG ') 18022 WRITE(ICOUT,9051)NR9,NC9 18023 9051 FORMAT('NR9,NC9 = ',2I8) 18024 CALL DPWRST('XXX','BUG ') 18025 IF(NR9.LE.0)GOTO9059 18026 IF(NC9.LE.0)GOTO9059 18027 JMAX=NC9 18028 IF(JMAX.GT.10)JMAX=10 18029 DO9055I=1,NR9 18030 WRITE(ICOUT,9056)I,(YM9(I,J),J=1,JMAX) 18031 9056 FORMAT('I,YM9(I,.) = ',I8,10E10.3) 18032 CALL DPWRST('XXX','BUG ') 18033 9055 CONTINUE 18034 9059 CONTINUE 18035C 18036 WRITE(ICOUT,999) 18037 CALL DPWRST('XXX','BUG ') 18038 WRITE(ICOUT,9111)N1 18039 9111 FORMAT('N1 = ',I8) 18040 CALL DPWRST('XXX','BUG ') 18041 IF(N1.LE.0)GOTO9119 18042 DO9112I=1,N1 18043 WRITE(ICOUT,9113)I,Y1(I) 18044 9113 FORMAT('I,Y1(I) = ',I8,E15.7) 18045 CALL DPWRST('XXX','BUG ') 18046 9112 CONTINUE 18047 9119 CONTINUE 18048C 18049 WRITE(ICOUT,999) 18050 CALL DPWRST('XXX','BUG ') 18051 WRITE(ICOUT,9121)N2 18052 9121 FORMAT('N2 = ',I8) 18053 CALL DPWRST('XXX','BUG ') 18054 IF(N2.LE.0)GOTO9129 18055 DO9122I=1,N2 18056 WRITE(ICOUT,9123)I,Y2(I) 18057 9123 FORMAT('I,Y2(I) = ',I8,E15.7) 18058 CALL DPWRST('XXX','BUG ') 18059 9122 CONTINUE 18060 9129 CONTINUE 18061C 18062 WRITE(ICOUT,999) 18063 CALL DPWRST('XXX','BUG ') 18064 WRITE(ICOUT,9131)N3 18065 9131 FORMAT('N3 = ',I8) 18066 CALL DPWRST('XXX','BUG ') 18067 IF(N3.LE.0)GOTO9139 18068 DO9132I=1,N3 18069 WRITE(ICOUT,9133)I,Y3(I) 18070 9133 FORMAT('I,Y3(I) = ',I8,E15.7) 18071 CALL DPWRST('XXX','BUG ') 18072 9132 CONTINUE 18073 9139 CONTINUE 18074C 18075 WRITE(ICOUT,999) 18076 CALL DPWRST('XXX','BUG ') 18077 WRITE(ICOUT,9141)N4 18078 9141 FORMAT('N4 = ',I8) 18079 CALL DPWRST('XXX','BUG ') 18080 IF(N4.LE.0)GOTO9149 18081 DO9142I=1,N4 18082 WRITE(ICOUT,9143)I,Y4(I) 18083 9143 FORMAT('I,Y4(I) = ',I8,E15.7) 18084 CALL DPWRST('XXX','BUG ') 18085 9142 CONTINUE 18086 9149 CONTINUE 18087C 18088 WRITE(ICOUT,999) 18089 CALL DPWRST('XXX','BUG ') 18090 WRITE(ICOUT,9151)ITYP9,SCAL9 18091 9151 FORMAT('ITYP9,SCAL9 = ',A4,2X,E15.7) 18092 CALL DPWRST('XXX','BUG ') 18093C 18094 WRITE(ICOUT,999) 18095 CALL DPWRST('XXX','BUG ') 18096 WRITE(ICOUT,9161)NVECT9 18097 9161 FORMAT('NVECT9 = ',I8) 18098 CALL DPWRST('XXX','BUG ') 18099 IF(NVECT9.LE.0)GOTO9169 18100 DO9162I=1,NVECT9 18101 WRITE(ICOUT,9163)I,VECT9(I) 18102 9163 FORMAT('I,VECT9(I) = ',I8,E15.7) 18103 CALL DPWRST('XXX','BUG ') 18104 9162 CONTINUE 18105 9169 CONTINUE 18106C 18107 WRITE(ICOUT,999) 18108 CALL DPWRST('XXX','BUG ') 18109 WRITE(ICOUT,9171)NR9,NC9 18110 9171 FORMAT('NR9,NC9 = ',2I8) 18111 CALL DPWRST('XXX','BUG ') 18112 IF(NR9.LE.0)GOTO9179 18113 IF(NC9.LE.0)GOTO9179 18114 JMAX=NC9 18115 IF(JMAX.GT.10)JMAX=10 18116 DO9172I=1,NR9 18117 WRITE(ICOUT,9173)I,(YM9(I,J),J=1,JMAX) 18118 9173 FORMAT('I,YM9(I,.) = ',I8,10E10.3) 18119 CALL DPWRST('XXX','BUG ') 18120 9172 CONTINUE 18121 9179 CONTINUE 18122C 18123 IF(IMCASE.NE.'MASS')GOTO9189 18124 WRITE(ICOUT,9181)NR2,NC2 18125 9181 FORMAT('NR2,NC2 = ',2I8) 18126 CALL DPWRST('XXX','BUG ') 18127 IF(NR2.LE.0)GOTO9189 18128 IF(NC2.LE.0)GOTO9189 18129 JMAX=NC2+1 18130 IF(JMAX.GT.10)JMAX=10 18131 NR2P1=NR2+1 18132 DO9182I=1,NR2P1 18133 WRITE(ICOUT,9183)I,(YM2(I,J),J=1,JMAX) 18134 9183 FORMAT('I,YM2(I,.) = ',I8,10E10.3) 18135 CALL DPWRST('XXX','BUG ') 18136 9182 CONTINUE 18137 DO9185I=1,N3 18138 WRITE(ICOUT,9186)ICASE,I,IZROV(I),IPOSV(I) 18139 9186 FORMAT('ICASE,I,IZROV(I),IPOSV(I) = ',4I8) 18140 CALL DPWRST('XXX','BUG ') 18141 9185 CONTINUE 18142 WRITE(ICOUT,9187)NR2,NLTZ,NGTZ,NEQZ 18143 9187 FORMAT('NR2,NLTZ,NGTZ,NEQZ = ',4I8) 18144 CALL DPWRST('XXX','BUG ') 18145 9189 CONTINUE 18146C 18147 9090 CONTINUE 18148C 18149 RETURN 18150 END 18151 SUBROUTINE MATAR2(YM1,NR1,NC1,YM2,NR2,NC2,NR3,NC3,MAXROM,MAXCOM, 18152CCCCC JANUARY 1998. RECODE TO USE LESS MATRICES. 18153CCCCC SUBROUTINE MATAR2(YM1,NR1,NC1,YM2,NR2,NC2,YM3,NR3,NC3, 18154 1Y1,N1,Y2,N2,Y3,N3,Y4,N4, 18155 1INDEX, 18156 1YS1,YS2,YS3,YS4, 18157 1IMCASE,IUPFLG,IMSUBC,ITYPA1,ITYPA2,ITYPA3,ITYPA4,NUMVAR,IWRITE, 18158 1IBPLSC,PBPLCO, 18159 1YM9,NR9,NC9,VECT9,NVECT9,SCAL9,ITYP9, 18160CCCCC JANUARY 1998. RECODE TO USE LESS MATRICES. 18161CCCCC1YMJUNK,YMJUN2, 18162 1IBUGA3,ISUBRO,IERROR) 18163C 18164C PURPOSE--CARRY OUT MATRIX ARITHMETIC OPERATIONS 18165C OF THE REAL DATA IN MATRICES YM1 AND YM2. 18166C 18167C OPERATIONS--ADDITION 18168C SUBTRACTION 18169C MULTIPLICATION 18170C SOLUTION 18171C ITERATIVE SOLUTION 18172C INVERSE 18173C TRANSPOSE 18174C ADJOINT 18175C CHARACTERISTIC EQUATION (NOT YET IMPLEMENED) 18176C EIGENVALUES 18177C EIGENVECTORS 18178C RANK 18179C DETERMINANT 18180C PERMANENT 18181C SPECTRAL NORM 18182C SPECTRAL RADIUS 18183C NUMBER OF ROWS 18184C NUMBER OF COLUMNS 18185C SIMPLEX SOLUTION 18186C TRACE 18187C SUBMATRIX 18188C MINOR 18189C COFACTOR 18190C DEFINITION 18191C EUCLIDEAN NORM 18192C SINGULAR VALUE 18193C SINGULAR VALUE DECOMPOSITION 18194C SINGULAR VALUE FACTORIZATION 18195C ROW 18196C ELEMENT 18197C REPLACE ROW 18198C REPLACE ELEMENT 18199C AUGMENT 18200C DIAGONAL 18201C CHOLESKY DECOMPOSITION 18202C TRIDIAGONAL SOLVE 18203C TRIANGULAR SOLVE 18204C TRIANGULAR INVERSE 18205C 18206C VARIANCE-COVARIANCE MATRIX 18207C CORRELATION MATRIX 18208C PRINCIPLE COMPONENTS ... 18209C ... PRINCIPLE COMPONENT ... 18210C BIPLOT 18211C 18212C EXAMPLES--LET M3 = MATRIX ADDITION M1 M2 18213C LET M3 = MATRIX ADDITION M1 P1 18214C --LET M3 = MATRIX SUBTRACTION M1 M2 18215C LET M3 = MATRIX SUBTRACTION M1 P1 18216C --LET M3 = MATRIX MULTIPLICATION M1 M2 18217C LET M3 = MATRIX MULTIPLICATION M1 V1 18218C LET M3 = MATRIX MULTIPLICATION M1 P1 18219C --LET V3 = MATRIX SOLUTION M1 V2 18220C --LET M3 = MATRIX INVERSE M1 18221C --LET A = MATRIX CONDITION NUMBER M1 18222C --LET M3 = MATRIX TRANSPOSE M1 18223C --LET M3 = MATRIX ADJOINT M1 18224C --LET V3 = MATRIX CHARACTERISTIC EQUATION M1 18225C --LET V3 = MATRIX EIGENVALUES M1 18226C --LET P3 = MATRIX EIGENVECTORS M1 18227C --LET P3 = MATRIX RANK M1 18228C --LET P3 = MATRIX DETERMINANT M1 18229C --LET P3 = MATRIX PERMANENT M1 18230C --LET P3 = MATRIX SPECTRAL NORM M1 18231C --LET P3 = MATRIX SPECTRAL RADIUS M1 18232C --LET P3 = MATRIX NUMBER OF ROWS M1 18233C --LET P3 = MATRIX NUMBER OF COLUMNS M1 18234C --LET V4 = MATRIX SIMPLEX SOLUTION V1 M1 V2 V3 18235C --LET P3 = MATRIX TRACE M1 18236C --LET M3 = MATRIX SUBMATRIX M1 P1 P2 18237C --LET P3 = MATRIX MINOR M1 P1 P2 18238C --LET P3 = MATRIX COFACTOR M1 P1 P2 18239C --LET M3 = MATRIX DEFINITION V1 P1 P2 18240C --LET P3 = MATRIX EUCLIDEAN NORM M1 18241C --LET V3 = MATRIX ROW M1 P1 18242C --LET P3 = MATRIX ELEMENT M1 P1 P2 18243C --LET M3 = MATRIX REPLACE ROW M1 V1 P1 18244C --LET M3 = MATRIX REPLACE ELEMENT M1 P1 P2 18245C --LET M3 = MATRIX AUGMENT M1 18246C --LET V3 = MATRIX DIAGONAL M1 18247C --LET M3 = DIAGONAL MATRIX V1 18248C --LET M3 = VARIANCE-COVARIANCE MATRIX M1 18249C --LET M3 = CORRELATION MATRIX M1 18250C --LET M3 = PRINCIPLE COMPONENTS M1 18251C --LET M3 = PRINCIPLE COMPONENTS EIGENVECTORS M1 18252C --LET V3 = PRINCIPLE COMPONENTS EIGENVALUES M1 18253C --LET V3 = ... PRINCIPLE COMPONENT M1 18254C --LET V3 = ... PRINCIPLE COMPONENT EIGENVECTOR M1 18255C --LET P3 = ... PRINCIPLE COMPONENT EIGENVALUE M1 18256C --LET V3 = MATRIX SINGULAR VALUES M1 18257C --LET M3 V3 M2 = MATRIX SINGULAR VALUE DECOMP M1 18258C --LET M3 V3 M2 = MATRIX SINGULAR VALUE FACTOR M1 18259C --LET M3 = CHOLESKY DECOMP M1 18260C --LET V4 = TRIDIAGONAL SOLVE V1 V2 V3 18261C 18262C INPUT ARGUMENTS--YM1 (REAL MATRIX) 18263C --NR1 18264C --NC1 18265C --YM2 (REAL MATRIX) 18266C --NR2 18267C --NC2 18268C --YM3 (REAL MATRIX) 18269C --NR3 18270C --NC3 18271C --Y1 (REAL VECTOR) 18272C --N1 18273C --Y2 (REAL VECTOR) 18274C --N2 18275C --Y3 (REAL VECTOR) 18276C --N3 18277C --Y4 (REAL VECTOR) 18278C --N4 18279C OUTPUT ARGUMENTS--YM9 (REAL MATRIX) 18280C --NR9 18281C --NC9 18282C --VECT9 (REAL VECTOR) 18283C --NVECT9 18284C --SCAL9 (REAL SCALAR) 18285C --ITYP9 18286C 18287C NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT MATRIX YM9(.) 18288C BEING IDENTICAL TO THE INPUT MATRIX YM1(.), YM2(.), OR YM3(.). 18289C WRITTEN BY--JAMES J. FILLIBEN 18290C STATISTICAL ENGINEERING DIVISION 18291C INFORMATION TECHNOLOGY LABORATORY 18292C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 18293C GAITHERSBURG, MD 20899-8980 18294C PHONE--301-975-2855 18295C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 18296C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 18297C LANGUAGE--ANSI FORTRAN (1977) 18298C VERSION NUMBER--87/10 18299C ORIGINAL VERSION--SEPTEMBER 1987. 18300C UPDATED --AUGUST 1988 (VARIANCE-COVARIANCE MATRIX) 18301C UPDATED --AUGUST 1988 (CORRELATION MATRIX) 18302C UPDATED --AUGUST 1988 (PRINCIPLE COMPONENTS) 18303C UPDATED --AUGUST 1988 (... PRINCIPLE COMPONENTS) 18304C UPDATED --APRIL 1992 DEFINE D999 18305C UPDATED --JULY 1993 FOR MATRIX SOLUTION, 18306C DETERMINANT, INVERSE, REPLACE 18307C NUMERICAL RECIPES CODE WITH 18308C LINPACK CODE 18309C UPDATED --JULY 1993 EIGENVALUES AND EIGENVECTORS 18310C EXTENDED TO NON-SYMMETRIC CASE 18311C UPDATED --JULY 1993 IMPLEMENT RANK, ADJOINT, 18312C SINGULAR VALUES, SINGULAR VALUE 18313C DECOMP. 18314C UPDATED --SEPT 1993 ROW, ELEMENT CASES 18315C UPDATED --OCT 1993 CHOLESKY DECOMPOSITION, REPLACE 18316C ROW, REPLACE ELEMENT, AUGMENT, 18317C DIAGONAL, ADD ARGUMENT TO 18318C MATRIX DEFINITION, TRIDIAGONAL 18319C SOLVE. 18320C UPDATED --JANUARY 1998 RECODE TO MINIMIZE NUMBER OF 18321C MATRICES NEEDED. 18322C UPDATED --APRIL 2009 ADD BIPLOT 18323C 18324C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 18325C 18326 CHARACTER*4 IMCASE 18327 CHARACTER*4 IUPFLG 18328 CHARACTER*4 IMSUBC 18329 CHARACTER*4 ITYPA1 18330 CHARACTER*4 ITYPA2 18331 CHARACTER*4 ITYPA3 18332 CHARACTER*4 ITYPA4 18333 CHARACTER*4 IWRITE 18334 CHARACTER*4 ITYP9 18335 CHARACTER*4 IBPLSC 18336 CHARACTER*4 IBUGA3 18337 CHARACTER*4 ISUBRO 18338 CHARACTER*4 IERROR 18339C 18340 CHARACTER*4 ISUBN1 18341 CHARACTER*4 ISUBN2 18342C 18343C-----DOUBLE PRECISION STATEMENTS FOR NON-COMMON VARIABLES------------------- 18344C 18345 DOUBLE PRECISION DNR1 18346 DOUBLE PRECISION DNC1 18347CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1992 18348 DOUBLE PRECISION D999 18349 DOUBLE PRECISION DSUM1 18350 DOUBLE PRECISION DYM1 18351C 18352C--------------------------------------------------------------------- 18353C 18354 INCLUDE 'DPCOPA.INC' 18355C 18356 DIMENSION YM1(MAXROM,MAXCOM) 18357 DIMENSION YM2(MAXROM,MAXCOM) 18358CCCCC JANUARY 1998. RECODE TO USE LESS MATRICES. 18359CCCCC DIMENSION YM3(MAXROM,MAXCOM) 18360 DIMENSION Y1(*) 18361 DIMENSION Y2(*) 18362 DIMENSION Y3(*) 18363 DIMENSION Y4(*) 18364 DIMENSION YM9(MAXROM,MAXCOM) 18365CCCCC DIMENSION VECT9(MAXROM) 18366 DIMENSION VECT9(*) 18367C 18368CCCCC JANUARY 1998. RECODE TO USE LESS MATRICES. 18369CCCCC DIMENSION YMJUNK(MAXROM,MAXCOM) 18370CCCCC DIMENSION YMJUN2(MAXROM,MAXCOM) 18371CCCCC DIMENSION INDEX(MAXROM) 18372CCCCC DIMENSION VJUNK(MAXROM) 18373CCCCC DIMENSION VJUNK2(MAXROM) 18374 DIMENSION INDEX(*) 18375CCCCC DIMENSION VJUNK(MAXOBV) 18376CCCCC DIMENSION VJUNK2(MAXOBV) 18377C 18378C--------------------------------------------------------------------- 18379C 18380 INCLUDE 'DPCOP2.INC' 18381C 18382C-----START POINT----------------------------------------------------- 18383C 18384 ISUBN1='MATA' 18385 ISUBN2='R2 ' 18386 IERROR='NO' 18387C 18388 IYS1=(-999) 18389 IYS2=(-999) 18390 IYS3=(-999) 18391 IYS23=(-999) 18392C 18393 NRJ=(-999) 18394 NCJ=(-999) 18395C 18396CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1992 18397 D999=(-999.0D0) 18398C 18399 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'TAR2')GOTO190 18400C 18401 WRITE(ICOUT,999) 18402 999 FORMAT(1X) 18403 CALL DPWRST('XXX','BUG ') 18404 WRITE(ICOUT,51) 18405 51 FORMAT('***** AT THE BEGINNING OF MATAR2--') 18406 CALL DPWRST('XXX','BUG ') 18407 WRITE(ICOUT,52)IBUGA3,ISUBRO,ITYPA1,ITYPA2,ITYPA3,ITYPA4 18408 52 FORMAT('IBUGA3,ISUBRO,ITYPA1,ITYPA2,ITYPA3,ITYPA4 = ', 18409 1A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4) 18410 CALL DPWRST('XXX','BUG ') 18411 WRITE(ICOUT,53)IMCASE,IMSUBC 18412 53 FORMAT('IMCASE,IMSUBC = ',A4,2X,A4) 18413 CALL DPWRST('XXX','BUG ') 18414 WRITE(ICOUT,54)NUMVAR,IWRITE 18415 54 FORMAT('NUMVAR,IWRITE = ',I8,2X,A4) 18416 CALL DPWRST('XXX','BUG ') 18417 WRITE(ICOUT,55)YS1,YS2,YS3,YS4 18418 55 FORMAT('YS1,YS2,YS3,YS4 = ',4E15.7) 18419 CALL DPWRST('XXX','BUG ') 18420C 18421 WRITE(ICOUT,999) 18422 CALL DPWRST('XXX','BUG ') 18423 WRITE(ICOUT,61)NR1,NC1 18424 61 FORMAT('NR1,NC1 = ',2I8) 18425 CALL DPWRST('XXX','BUG ') 18426 IF(NR1.LE.0)GOTO69 18427 IF(NC1.LE.0)GOTO69 18428 JMAX=NC1 18429 IF(JMAX.GT.10)JMAX=10 18430 DO62I=1,NR1 18431 WRITE(ICOUT,63)I,(YM1(I,J),J=1,JMAX) 18432 63 FORMAT('I,YM1(I,.) = ',I8,10E10.3) 18433 CALL DPWRST('XXX','BUG ') 18434 62 CONTINUE 18435 69 CONTINUE 18436C 18437 WRITE(ICOUT,999) 18438 CALL DPWRST('XXX','BUG ') 18439 WRITE(ICOUT,71)NR2,NC2 18440 71 FORMAT('NR2,NC2 = ',2I8) 18441 CALL DPWRST('XXX','BUG ') 18442 IF(NR2.LE.0)GOTO79 18443 IF(NC2.LE.0)GOTO79 18444 JMAX=NC2 18445 IF(JMAX.GT.10)JMAX=10 18446 DO72I=1,NR2 18447 WRITE(ICOUT,73)I,(YM2(I,J),J=1,JMAX) 18448 73 FORMAT('I,YM2(I,.) = ',I8,10E10.3) 18449 CALL DPWRST('XXX','BUG ') 18450 72 CONTINUE 18451 79 CONTINUE 18452C 18453 WRITE(ICOUT,999) 18454 CALL DPWRST('XXX','BUG ') 18455 WRITE(ICOUT,81)NR3,NC3 18456 81 FORMAT('NR3,NC3 = ',2I8) 18457 CALL DPWRST('XXX','BUG ') 18458 IF(NR3.LE.0)GOTO89 18459 IF(NC3.LE.0)GOTO89 18460 JMAX=NC3 18461 IF(JMAX.GT.10)JMAX=10 18462 DO82I=1,NR3 18463 WRITE(ICOUT,83)I,(YM9(I,J),J=1,JMAX) 18464 83 FORMAT('I,YM9(I,.) = ',I8,10E10.3) 18465 CALL DPWRST('XXX','BUG ') 18466 82 CONTINUE 18467 89 CONTINUE 18468C 18469 WRITE(ICOUT,999) 18470 CALL DPWRST('XXX','BUG ') 18471 WRITE(ICOUT,111)N1 18472 111 FORMAT('N1 = ',I8) 18473 CALL DPWRST('XXX','BUG ') 18474 IF(N1.LE.0)GOTO119 18475 DO112I=1,N1 18476 WRITE(ICOUT,113)I,Y1(I) 18477 113 FORMAT('I,Y1(I) = ',I8,E15.7) 18478 CALL DPWRST('XXX','BUG ') 18479 112 CONTINUE 18480 119 CONTINUE 18481C 18482 WRITE(ICOUT,999) 18483 CALL DPWRST('XXX','BUG ') 18484 WRITE(ICOUT,121)N2 18485 121 FORMAT('N2 = ',I8) 18486 CALL DPWRST('XXX','BUG ') 18487 IF(N2.LE.0)GOTO129 18488 DO122I=1,N2 18489 WRITE(ICOUT,123)I,Y2(I) 18490 123 FORMAT('I,Y2(I) = ',I8,E15.7) 18491 CALL DPWRST('XXX','BUG ') 18492 122 CONTINUE 18493 129 CONTINUE 18494C 18495 WRITE(ICOUT,999) 18496 CALL DPWRST('XXX','BUG ') 18497 WRITE(ICOUT,131)N3 18498 131 FORMAT('N3 = ',I8) 18499 CALL DPWRST('XXX','BUG ') 18500 IF(N3.LE.0)GOTO139 18501 DO132I=1,N3 18502 WRITE(ICOUT,133)I,Y3(I) 18503 133 FORMAT('I,Y3(I) = ',I8,E15.7) 18504 CALL DPWRST('XXX','BUG ') 18505 132 CONTINUE 18506 139 CONTINUE 18507C 18508 WRITE(ICOUT,999) 18509 CALL DPWRST('XXX','BUG ') 18510 WRITE(ICOUT,141)N4 18511 141 FORMAT('N4 = ',I8) 18512 CALL DPWRST('XXX','BUG ') 18513 IF(N4.LE.0)GOTO149 18514 DO142I=1,N4 18515 WRITE(ICOUT,143)I,Y4(I) 18516 143 FORMAT('I,Y4(I) = ',I8,E15.7) 18517 CALL DPWRST('XXX','BUG ') 18518 142 CONTINUE 18519 149 CONTINUE 18520C 18521 190 CONTINUE 18522C 18523C ************************************************** 18524C ** CARRY OUT MATRIX ARITHMETIC OPERATIONS ** 18525C ************************************************** 18526C 18527 DNR1=NR1 18528 DNC1=NC1 18529C 18530C ******************************************** 18531C ** STEP 11-- ** 18532C ** CHECK NUMBER OF INPUT OBSERVATIONS. ** 18533C ******************************************** 18534C 18535 IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1.AND.NR1.LE.0)GOTO1100 18536 IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1.AND.NC1.LE.0)GOTO1100 18537 IF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2.AND.NR2.LE.0)GOTO1100 18538 IF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2.AND.NC2.LE.0)GOTO1100 18539 IF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3.AND.NR3.LE.0)GOTO1100 18540 IF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3.AND.NC3.LE.0)GOTO1100 18541C 18542 IF(ITYPA1.EQ.'VARI'.AND.NUMVAR.GE.1.AND.N1.LE.0)GOTO1100 18543 IF(ITYPA2.EQ.'VARI'.AND.NUMVAR.GE.2.AND.N2.LE.0)GOTO1100 18544 IF(ITYPA3.EQ.'VARI'.AND.NUMVAR.GE.3.AND.N3.LE.0)GOTO1100 18545C 18546 GOTO1190 18547C 18548 1100 CONTINUE 18549 IERROR='YES' 18550 WRITE(ICOUT,999) 18551 CALL DPWRST('XXX','BUG ') 18552 WRITE(ICOUT,1111) 18553 1111 FORMAT('***** ERROR IN MATAR2--') 18554 CALL DPWRST('XXX','BUG ') 18555 WRITE(ICOUT,1112) 18556 1112 FORMAT(' THE INPUT NUMBER OF ROWS AND/OR COLUMNS') 18557 CALL DPWRST('XXX','BUG ') 18558 WRITE(ICOUT,1113) 18559 1113 FORMAT(' IN THE MATRIX AND/OR VECTOR FOR WHICH') 18560 CALL DPWRST('XXX','BUG ') 18561 WRITE(ICOUT,1121) 18562 1121 FORMAT(' THE MATRIX OPERATION IS TO BE COMPUTED') 18563 WRITE(ICOUT,1181) 18564 1181 FORMAT(' MUST BE 1 OR LARGER;') 18565 CALL DPWRST('XXX','BUG ') 18566 WRITE(ICOUT,1182) 18567 1182 FORMAT(' SUCH WAS NOT THE CASE HERE.') 18568 CALL DPWRST('XXX','BUG ') 18569C 18570 IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1)WRITE(ICOUT,1183)NR1,NC1 18571 1183 FORMAT(' MATRIX 1--',I8,' ROWS BY ',I8,' COLUMNS') 18572 IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1)CALL DPWRST('XXX','BUG ') 18573 IF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2)WRITE(ICOUT,1184)NR2,NC2 18574 1184 FORMAT(' MATRIX 2--',I8,' ROWS BY ',I8,' COLUMNS') 18575 IF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2)CALL DPWRST('XXX','BUG ') 18576 IF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3)WRITE(ICOUT,1185)NR3,NC3 18577 1185 FORMAT(' MATRIX 3--',I8,' ROWS BY ',I8,' COLUMNS') 18578 IF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3)CALL DPWRST('XXX','BUG ') 18579 IF(ITYPA1.EQ.'VARI'.AND.NUMVAR.GE.1)WRITE(ICOUT,1186)N1 18580 1186 FORMAT(' VECTOR 1--',I8,' ROWS') 18581 IF(ITYPA1.EQ.'VARI'.AND.NUMVAR.GE.1)CALL DPWRST('XXX','BUG ') 18582 IF(ITYPA2.EQ.'VARI'.AND.NUMVAR.GE.2)WRITE(ICOUT,1187)N2 18583 1187 FORMAT(' VECTOR 2--',I8,' ROWS') 18584 IF(ITYPA2.EQ.'VARI'.AND.NUMVAR.GE.2)CALL DPWRST('XXX','BUG ') 18585 IF(ITYPA3.EQ.'VARI'.AND.NUMVAR.GE.3)WRITE(ICOUT,1188)N3 18586 1188 FORMAT(' VECTOR 3--',I8,' ROWS') 18587 IF(ITYPA3.EQ.'VARI'.AND.NUMVAR.GE.3)CALL DPWRST('XXX','BUG ') 18588 GOTO9000 18589C 18590 1190 CONTINUE 18591C 18592C ********************************* 18593C ** STEP 12-- ** 18594C ** BRANCH TO THE PROPER CASE ** 18595C ********************************* 18596C 18597CCCCC JULY 1993. ADD FOLLOWING 3 LINES 18598 IF(IMCASE.EQ.'MASV')GOTO5800 18599 IF(IMCASE.EQ.'MASD')GOTO5900 18600 IF(IMCASE.EQ.'MASF')GOTO6000 18601CCCCC SEPTEMBER 1993. ADD FOLLOWING 2 LINES 18602 IF(IMCASE.EQ.'MARW')GOTO6100 18603 IF(IMCASE.EQ.'MAEL')GOTO6200 18604CCCCC OCTOBER 1993. ADD FOLLOWING LINE 18605 IF(IMCASE.EQ.'MACH')GOTO6300 18606 IF(IMCASE.EQ.'MAAU')GOTO6400 18607 IF(IMCASE.EQ.'MADI')GOTO6500 18608 IF(IMCASE.EQ.'DIMA')GOTO6600 18609 IF(IMCASE.EQ.'MARR')GOTO6700 18610 IF(IMCASE.EQ.'MARE')GOTO6800 18611 IF(IMCASE.EQ.'MATD')GOTO6900 18612 IF(IMCASE.EQ.'MATS')GOTO7000 18613 IF(IMCASE.EQ.'MATI')GOTO7100 18614 IF(IMCASE.EQ.'MAIS')GOTO7200 18615 IF(IMCASE.EQ.'BIPL')GOTO7300 18616C 18617 WRITE(ICOUT,999) 18618 CALL DPWRST('XXX','BUG ') 18619 WRITE(ICOUT,1211) 18620 1211 FORMAT('***** INTERNAL ERROR IN MATAR2--') 18621 CALL DPWRST('XXX','BUG ') 18622 WRITE(ICOUT,1212) 18623 1212 FORMAT(' IMCASE NOT EQUAL TO') 18624 CALL DPWRST('XXX','BUG ') 18625 WRITE(ICOUT,1213) 18626 1213 FORMAT(' MASV, MASD, MASF, MARW, ') 18627 CALL DPWRST('XXX','BUG ') 18628 WRITE(ICOUT,1214) 18629 1214 FORMAT(' MAEL, MACH, MAAU, MADI, ') 18630 CALL DPWRST('XXX','BUG ') 18631 WRITE(ICOUT,1215) 18632 1215 FORMAT(' DIMA, MARR, MARE, MATD, ') 18633 CALL DPWRST('XXX','BUG ') 18634 WRITE(ICOUT,1216) 18635 1216 FORMAT(' MATS, MATI, MAIS ') 18636 CALL DPWRST('XXX','BUG ') 18637 WRITE(ICOUT,1228)IMCASE 18638 1228 FORMAT(' IMCASE = ',A4) 18639 CALL DPWRST('XXX','BUG ') 18640 IERROR='YES' 18641 GOTO9000 18642C 18643C ************************************************ 18644C ** STEP 58-- ** 18645C ** TREAT THE MATRIX SINGULAR VALUES CASE ** 18646C ************************************************ 18647C 18648CCCCC IMPLEMENTED JULY 1993. 18649 5800 CONTINUE 18650C 18651 IERR2=0 18652 IJOB=0 18653 CALL SSVDC(YM1,MAXROM,NR1,NC1,VECT9,Y1,YM1,MAXROM, 18654 1YM1,MAXROM,Y2,IJOB,IERR2) 18655C 18656 ITYP9='VECT' 18657 NVECT9=MIN(NR1,NC1) 18658 IUPFLG='FULL' 18659 GOTO9000 18660C 18661C ************************************************ 18662C ** STEP 59-- ** 18663C ** TREAT THE MATRIX SINGULAR VALUES ** 18664C ** DECOMPOSITION CASE ** 18665C ************************************************ 18666C 18667CCCCC IMPLEMENTED JULY 1993. 18668 5900 CONTINUE 18669C 18670 IF(NR1.LE.MAXCOM)GOTO5909 18671 WRITE(ICOUT,999) 18672 CALL DPWRST('XXX','BUG ') 18673 WRITE(ICOUT,5901) 18674 5901 FORMAT('***** ERROR IN MATAR2--') 18675 CALL DPWRST('XXX','BUG ') 18676 WRITE(ICOUT,5902) 18677 5902 FORMAT(' FOR MATRIX SINGULAR VALUE DECOMPOSITION,') 18678 CALL DPWRST('XXX','BUG ') 18679 WRITE(ICOUT,5903) 18680 5903 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX') 18681 CALL DPWRST('XXX','BUG ') 18682 WRITE(ICOUT,5904) 18683 5904 FORMAT(' CAN NOT EXCEED ') 18684 CALL DPWRST('XXX','BUG ') 18685 WRITE(ICOUT,5905) 18686 5905 FORMAT(' THE MAXIMUM NUMBER OF COLUMNS IN THE MATRIX;') 18687 CALL DPWRST('XXX','BUG ') 18688 WRITE(ICOUT,5906) 18689 5906 FORMAT(' SUCH WAS NOT THE CASE HERE.') 18690 CALL DPWRST('XXX','BUG ') 18691 WRITE(ICOUT,5907)NR1 18692 5907 FORMAT(' NUMBER OF ROWS =',I8) 18693 CALL DPWRST('XXX','BUG ') 18694 WRITE(ICOUT,5908)MAXCOM 18695 5908 FORMAT(' MAXIMUM NUMBER OF COLUMNS =',I8) 18696 CALL DPWRST('XXX','BUG ') 18697 IERROR='YES' 18698 GOTO9000 18699C 18700 5909 CONTINUE 18701 DO5922J=1,MAXCOM 18702 DO5921I=1,MAXROM 18703 YM9(I,J)=0.0 18704 YM2(I,J)=0.0 18705 5921 CONTINUE 18706 5922 CONTINUE 18707C 18708 IERR2=0 18709 IJOB=22 18710 NTEMP1=NR1 18711 NTEMP2=NC1 18712 CALL SSVDC(YM1,MAXROM,NTEMP1,NTEMP2,VECT9,Y1,YM9,MAXROM, 18713 1YM2,MAXROM,Y2,IJOB,IERR2) 18714C 18715 ITYP9='MATR' 18716 MM=NR1 18717 IF(MM.GT.NC1)MM=NC1 18718 NR9=NR1 18719 NC9=NR1 18720 NR2=NC1 18721 NC2=NC1 18722 NVECT9=MM 18723 IUPFLG='FULL' 18724 GOTO9000 18725C 18726C ************************************************ 18727C ** STEP 60-- ** 18728C ** TREAT THE MATRIX SINGULAR VALUES ** 18729C ** FACTORIZATION CASE ** 18730C ************************************************ 18731C 18732CCCCC IMPLEMENTED JULY 1993. 18733 6000 CONTINUE 18734C 18735 DO6022J=1,MAXCOM 18736 DO6021I=1,MAXROM 18737 YM9(I,J)=0.0 18738 YM2(I,J)=0.0 18739 6021 CONTINUE 18740 6022 CONTINUE 18741C 18742 IERR2=0 18743 IJOB=22 18744 NTEMP1=NR1 18745 NTEMP2=NC1 18746 CALL SSVDC(YM1,MAXROM,NTEMP1,NTEMP2,VECT9,Y1,YM9,MAXROM, 18747 1YM2,MAXROM,Y2,IJOB,IERR2) 18748C 18749 ITYP9='MATR' 18750 MM=NR1 18751 IF(MM.GT.NC1)MM=NC1 18752 NR9=NR1 18753 NC9=NC1 18754 NR2=NC1 18755 NC2=NC1 18756 NVECT9=MM 18757 IUPFLG='FULL' 18758 GOTO9000 18759C 18760C ***************************************************** 18761C ** STEP 61-- ** 18762C ** TREAT THE MATRIX ROW CASE ** 18763C ***************************************************** 18764C 18765 6100 CONTINUE 18766 IROWID=INT(YS2+0.5) 18767 IF(IROWID.LT.1 .OR. IROWID.GT.NR1)THEN 18768 WRITE(ICOUT,999) 18769 CALL DPWRST('XXX','BUG ') 18770 WRITE(ICOUT,6101) 18771 CALL DPWRST('XXX','BUG ') 18772 WRITE(ICOUT,6102) 18773 CALL DPWRST('XXX','BUG ') 18774 WRITE(ICOUT,6103) 18775 WRITE(ICOUT,6104)NR1 18776 CALL DPWRST('XXX','BUG ') 18777 WRITE(ICOUT,6105)IROWID 18778 CALL DPWRST('XXX','BUG ') 18779 IERROR='YES' 18780 GOTO9000 18781 ENDIF 18782 6101 FORMAT('***** ERROR IN MATAR2--') 18783 6102 FORMAT(' FOR MATRIX ROW,') 18784 6103 FORMAT(' THE REQUESTED ROW IN THE MATRIX MUST BE BETWEEN') 18785 6104 FORMAT(' 1 AND ',I8,'. SUCH WAS NOT THE CASE HERE.') 18786 6105 FORMAT(' THE REQUESTED ROW NUMBER = ',I8) 18787C 18788 DO6120J=1,NC1 18789 VECT9(J)=YM1(IROWID,J) 18790 6120 CONTINUE 18791C 18792 ITYP9='VECT' 18793 NVECT9=NC1 18794 IUPFLG='FULL' 18795 GOTO9000 18796C 18797C ***************************************************** 18798C ** STEP 62-- ** 18799C ** TREAT THE MATRIX ELEMENT CASE ** 18800C ***************************************************** 18801C 18802 6200 CONTINUE 18803 IROWID=INT(YS2+0.5) 18804 ICOLID=INT(YS3+0.5) 18805 IF(IROWID.LT.1 .OR. IROWID.GT.NR1)THEN 18806 WRITE(ICOUT,999) 18807 CALL DPWRST('XXX','BUG ') 18808 WRITE(ICOUT,6201) 18809 CALL DPWRST('XXX','BUG ') 18810 WRITE(ICOUT,6202) 18811 CALL DPWRST('XXX','BUG ') 18812 WRITE(ICOUT,6203) 18813 WRITE(ICOUT,6204)NR1 18814 CALL DPWRST('XXX','BUG ') 18815 WRITE(ICOUT,6205)IROWID 18816 CALL DPWRST('XXX','BUG ') 18817 IERROR='YES' 18818 GOTO9000 18819 ENDIF 18820 6201 FORMAT('***** ERROR IN MATAR2--') 18821 6202 FORMAT(' FOR MATRIX ELEMENT,') 18822 6203 FORMAT(' THE REQUESTED ROW IN THE MATRIX MUST BE BETWEEN') 18823 6204 FORMAT(' 1 AND ',I8,'. SUCH WAS NOT THE CASE HERE.') 18824 6205 FORMAT(' THE REQUESTED ROW NUMBER = ',I8) 18825C 18826 IF(ICOLID.LT.1 .OR. ICOLID.GT.NC1)THEN 18827 WRITE(ICOUT,999) 18828 CALL DPWRST('XXX','BUG ') 18829 WRITE(ICOUT,6211) 18830 CALL DPWRST('XXX','BUG ') 18831 WRITE(ICOUT,6212) 18832 CALL DPWRST('XXX','BUG ') 18833 WRITE(ICOUT,6213) 18834 WRITE(ICOUT,6214)NC1 18835 CALL DPWRST('XXX','BUG ') 18836 WRITE(ICOUT,6215)ICOLID 18837 CALL DPWRST('XXX','BUG ') 18838 IERROR='YES' 18839 GOTO9000 18840 ENDIF 18841 6211 FORMAT('***** ERROR IN MATAR2--') 18842 6212 FORMAT(' FOR MATRIX ELEMENT,') 18843 6213 FORMAT(' THE REQUESTED COLUMN IN THE MATRIX MUST BE') 18844 6214 FORMAT(' BETWEEN 1 AND ',I8,'. SUCH WAS NOT THE CASE') 18845 6215 FORMAT(' HERE. THE REQUESTED COLUMN NUMBER = ',I8) 18846C 18847 ITYP9='SCAL' 18848 SCAL9=YM1(IROWID,ICOLID) 18849 IUPFLG='FULL' 18850 GOTO9000 18851C 18852C ********************************************* 18853C ** STEP 63-- ** 18854C ** TREAT THE MATRIX CHOLESKY DECOMP CASE ** 18855C ** REFERENCE--LINPACK USER'S GUIDE ** 18856C ********************************************* 18857C 18858 6300 CONTINUE 18859C 18860 IF(NR1.EQ.NC1)GOTO6309 18861 WRITE(ICOUT,999) 18862 CALL DPWRST('XXX','BUG ') 18863 WRITE(ICOUT,6301) 18864 6301 FORMAT('***** ERROR IN MATAR2--') 18865 CALL DPWRST('XXX','BUG ') 18866 WRITE(ICOUT,6302) 18867 6302 FORMAT(' FOR MATRIX CHOLESKY DECOMPOSITION,') 18868 CALL DPWRST('XXX','BUG ') 18869 WRITE(ICOUT,6303) 18870 6303 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX') 18871 CALL DPWRST('XXX','BUG ') 18872 WRITE(ICOUT,6304) 18873 6304 FORMAT(' MUST EQUAL') 18874 CALL DPWRST('XXX','BUG ') 18875 WRITE(ICOUT,6305) 18876 6305 FORMAT(' THE NUMBER OF COLUMNS IN THE MATRIX;') 18877 CALL DPWRST('XXX','BUG ') 18878 WRITE(ICOUT,6306) 18879 6306 FORMAT(' SUCH WAS NOT THE CASE HERE.') 18880 CALL DPWRST('XXX','BUG ') 18881 WRITE(ICOUT,6307)NR1 18882 6307 FORMAT(' NUMBER OF ROWS =',I8) 18883 CALL DPWRST('XXX','BUG ') 18884 WRITE(ICOUT,6308)NC1 18885 6308 FORMAT(' NUMBER OF COLUMNS =',I8) 18886 CALL DPWRST('XXX','BUG ') 18887 IERROR='YES' 18888 GOTO9000 18889 6309 CONTINUE 18890C 18891 CALL SPOCO(YM1,MAXROM,NR1,RCOND,Y1,INFO) 18892C 18893 IF(INFO.NE.0)THEN 18894 WRITE(ICOUT,999) 18895 CALL DPWRST('XXX','BUG ') 18896 WRITE(ICOUT,6351) 18897 6351 FORMAT('***** ERROR IN MATAR2--') 18898 CALL DPWRST('XXX','BUG ') 18899 WRITE(ICOUT,6352) 18900 6352 FORMAT(' FOR MATRIX CHOLESKY DECOMPOSITION,') 18901 CALL DPWRST('XXX','BUG ') 18902 WRITE(ICOUT,6353) 18903 6353 FORMAT(' THE INPUT MATRIX IS NOT SINGULAR.') 18904 CALL DPWRST('XXX','BUG ') 18905 IERROR='YES' 18906 ENDIF 18907C 18908 WRITE(ICOUT,6361)RCOND 18909 CALL DPWRST('XXX','TEXT ') 18910 6361 FORMAT('THE RECIPROCAL CONDITION NUMBER FOR THE MATRIX = ',E15.7) 18911 IF(1.0+RCOND.EQ.1.0)THEN 18912 WRITE(ICOUT,999) 18913 CALL DPWRST('XXX','BUG ') 18914 WRITE(ICOUT,6371) 18915 CALL DPWRST('XXX','ERRO ') 18916 WRITE(ICOUT,6372) 18917 CALL DPWRST('XXX','ERRO ') 18918 IERROR='YES' 18919 END IF 18920 6371 FORMAT('****** ERROR IN MATAR2 ********') 18921 6372 FORMAT(' THE INPUT MATRIX IS SINGULAR') 18922C 18923 DO6380I=1,NR1 18924 DO6382J=I,NR1 18925 YM9(J,I)=0. 18926 YM9(I,J)=YM1(I,J) 18927 6382 CONTINUE 18928 6380 CONTINUE 18929C 18930 ITYP9='MATR' 18931 NVECT9=NR1 18932 NR9=NR1 18933 NC9=NC1 18934 IUPFLG='FULL' 18935 GOTO9000 18936C 18937C 18938C ****************************************************** 18939C ** STEP 64-- ** 18940C ** TREAT THE MATRIX AUGMENT CASE ** 18941C ****************************************************** 18942C 18943 6400 CONTINUE 18944C 18945 IF(NR1.EQ.NR2)GOTO6409 18946 WRITE(ICOUT,999) 18947 CALL DPWRST('XXX','BUG ') 18948 WRITE(ICOUT,6401) 18949 6401 FORMAT('***** ERROR IN MATAR2--') 18950 CALL DPWRST('XXX','BUG ') 18951 WRITE(ICOUT,6402) 18952 6402 FORMAT(' FOR MATRIX AUGMENT,') 18953 CALL DPWRST('XXX','BUG ') 18954 WRITE(ICOUT,6403) 18955 6403 FORMAT(' THE NUMBER OF ROWS IN THE TWO MATRICES') 18956 CALL DPWRST('XXX','BUG ') 18957 WRITE(ICOUT,6404) 18958 6404 FORMAT(' MUST BE EQUAL. SUCH WAS NOT THE CASE HERE.') 18959 CALL DPWRST('XXX','BUG ') 18960 WRITE(ICOUT,6407)NR1 18961 6407 FORMAT(' NUMBER OF ROWS FOR MATRIX 1 =',I8) 18962 CALL DPWRST('XXX','BUG ') 18963 WRITE(ICOUT,6408)NR2 18964 6408 FORMAT(' NUMBER OF ROWS FOR MATRIX 2 =',I8) 18965 CALL DPWRST('XXX','BUG ') 18966 IERROR='YES' 18967 GOTO9000 18968 6409 CONTINUE 18969C 18970 IF(NC1+NC2.LE.MAXCOM)GOTO6419 18971 WRITE(ICOUT,999) 18972 CALL DPWRST('XXX','BUG ') 18973 WRITE(ICOUT,6411) 18974 6411 FORMAT('***** ERROR IN MATAR2--') 18975 CALL DPWRST('XXX','BUG ') 18976 WRITE(ICOUT,6412) 18977 6412 FORMAT(' FOR MATRIX AUGMENT,') 18978 CALL DPWRST('XXX','BUG ') 18979 WRITE(ICOUT,6413) 18980 6413 FORMAT(' THE NUMBER OF COLUMNS IN THE NEW MATRIX') 18981 CALL DPWRST('XXX','BUG ') 18982 WRITE(ICOUT,6414) 18983 6414 FORMAT(' WOULD EXCEED THE ALLOWABLE MAXIMUM.') 18984 CALL DPWRST('XXX','BUG ') 18985 WRITE(ICOUT,6417)NC1 18986 6417 FORMAT(' NUMBER OF COLUMNS FOR MATRIX 1 = ',I8) 18987 CALL DPWRST('XXX','BUG ') 18988 WRITE(ICOUT,6418)NC2 18989 6418 FORMAT(' NUMBER OF COLUMNS FOR MATRIX 2 =',I8) 18990 CALL DPWRST('XXX','BUG ') 18991 IERROR='YES' 18992 GOTO9000 18993 6419 CONTINUE 18994C 18995 DO6430J=1,NC1 18996 DO6435I=1,NR1 18997 YM9(I,J)=YM1(I,J) 18998 6435 CONTINUE 18999 6430 CONTINUE 19000C 19001 DO6440J=1,NC2 19002 DO6445I=1,NR2 19003 J2=J+NC1 19004 YM9(I,J2)=YM2(I,J) 19005 6445 CONTINUE 19006 6440 CONTINUE 19007C 19008 ITYP9='MATR' 19009 NR9=NR1 19010 NC9=NC1+NC2 19011 IUPFLG='SUBS' 19012 GOTO9000 19013C 19014C ***************************************************** 19015C ** STEP 65-- ** 19016C ** TREAT THE MATRIX DIAGONAL CASE ** 19017C ***************************************************** 19018C 19019 6500 CONTINUE 19020 IF(NR1.EQ.NC1)GOTO6509 19021 WRITE(ICOUT,999) 19022 CALL DPWRST('XXX','BUG ') 19023 WRITE(ICOUT,6501) 19024 6501 FORMAT('***** ERROR IN MATAR2--') 19025 CALL DPWRST('XXX','BUG ') 19026 WRITE(ICOUT,6502) 19027 6502 FORMAT(' FOR MATRIX DIAGONAL,') 19028 CALL DPWRST('XXX','BUG ') 19029 WRITE(ICOUT,6503) 19030 6503 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX') 19031 CALL DPWRST('XXX','BUG ') 19032 WRITE(ICOUT,6504) 19033 6504 FORMAT(' MUST EQUAL') 19034 CALL DPWRST('XXX','BUG ') 19035 WRITE(ICOUT,6505) 19036 6505 FORMAT(' THE NUMBER OF COLUMNS IN THE MATRIX;') 19037 CALL DPWRST('XXX','BUG ') 19038 WRITE(ICOUT,6506) 19039 6506 FORMAT(' SUCH WAS NOT THE CASE HERE.') 19040 CALL DPWRST('XXX','BUG ') 19041 WRITE(ICOUT,6507)NR1 19042 6507 FORMAT(' NUMBER OF ROWS =',I8) 19043 CALL DPWRST('XXX','BUG ') 19044 WRITE(ICOUT,6508)NC1 19045 6508 FORMAT(' NUMBER OF COLUMNS =',I8) 19046 CALL DPWRST('XXX','BUG ') 19047 IERROR='YES' 19048 GOTO9000 19049 6509 CONTINUE 19050C 19051 DO6520I=1,NC1 19052 VECT9(I)=YM1(I,I) 19053 6520 CONTINUE 19054C 19055 ITYP9='VECT' 19056 NVECT9=NC1 19057 IUPFLG='FULL' 19058 GOTO9000 19059C 19060C ***************************************************** 19061C ** STEP 66-- ** 19062C ** TREAT THE DIAGONAL MATRIX CASE ** 19063C ***************************************************** 19064C 19065 6600 CONTINUE 19066C 19067 IF(N1.LE.MAXCOM)GOTO6609 19068 WRITE(ICOUT,999) 19069 CALL DPWRST('XXX','BUG ') 19070 WRITE(ICOUT,6601) 19071 6601 FORMAT('***** ERROR IN MATAR2--') 19072 CALL DPWRST('XXX','BUG ') 19073 WRITE(ICOUT,6602) 19074 6602 FORMAT(' FOR DIAGONAL MATRIX,') 19075 CALL DPWRST('XXX','BUG ') 19076 WRITE(ICOUT,6603) 19077 6603 FORMAT(' THE NUMBER OF ROWS IN THE VECTOR MUST BE LESS') 19078 CALL DPWRST('XXX','BUG ') 19079 WRITE(ICOUT,6604) 19080 6604 FORMAT(' THAN ',I8) 19081 CALL DPWRST('XXX','BUG ') 19082 WRITE(ICOUT,6606) 19083 6606 FORMAT(' SUCH WAS NOT THE CASE HERE.') 19084 CALL DPWRST('XXX','BUG ') 19085 WRITE(ICOUT,6607)N1 19086 6607 FORMAT(' NUMBER OF ROWS =',I8) 19087 CALL DPWRST('XXX','BUG ') 19088 IERROR='YES' 19089 GOTO9000 19090C 19091 6609 CONTINUE 19092 DO6610J=1,N1 19093 DO6615I=1,N1 19094 YM9(I,J)=0.0 19095 6615 CONTINUE 19096 6610 CONTINUE 19097 DO6620I=1,N1 19098 YM9(I,I)=Y1(I) 19099 6620 CONTINUE 19100C 19101 ITYP9='MATR' 19102 NR9=N1 19103 NC9=N1 19104 IUPFLG='FULL' 19105 GOTO9000 19106C 19107C ***************************************************** 19108C ** STEP 67-- ** 19109C ** TREAT THE MATRIX REPLACE ROW CASE ** 19110C ***************************************************** 19111C 19112 6700 CONTINUE 19113 IROWID=INT(YS3+0.5) 19114 IF(IROWID.LT.1 .OR. IROWID.GT.NR1)THEN 19115 WRITE(ICOUT,999) 19116 CALL DPWRST('XXX','BUG ') 19117 WRITE(ICOUT,6701) 19118 CALL DPWRST('XXX','BUG ') 19119 WRITE(ICOUT,6702) 19120 CALL DPWRST('XXX','BUG ') 19121 WRITE(ICOUT,6703) 19122 WRITE(ICOUT,6704)NR1 19123 CALL DPWRST('XXX','BUG ') 19124 WRITE(ICOUT,6705)IROWID 19125 CALL DPWRST('XXX','BUG ') 19126 IERROR='YES' 19127 GOTO9000 19128 ENDIF 19129 6701 FORMAT('***** ERROR IN MATAR2--') 19130 6702 FORMAT(' FOR MATRIX REPLACE ROW,') 19131 6703 FORMAT(' THE REQUESTED ROW IN THE MATRIX MUST BE BETWEEN') 19132 6704 FORMAT(' 1 AND ',I8,'. SUCH WAS NOT THE CASE HERE.') 19133 6705 FORMAT(' THE REQUESTED ROW NUMBER = ',I8) 19134C 19135 IF(N2.NE.NC1)THEN 19136 WRITE(ICOUT,999) 19137 CALL DPWRST('XXX','BUG ') 19138 WRITE(ICOUT,6711) 19139 CALL DPWRST('XXX','BUG ') 19140 WRITE(ICOUT,6712) 19141 CALL DPWRST('XXX','BUG ') 19142 WRITE(ICOUT,6713) 19143 CALL DPWRST('XXX','BUG ') 19144 WRITE(ICOUT,6714) 19145 CALL DPWRST('XXX','BUG ') 19146 WRITE(ICOUT,6715) 19147 CALL DPWRST('XXX','BUG ') 19148 WRITE(ICOUT,6716)NC1 19149 CALL DPWRST('XXX','BUG ') 19150 WRITE(ICOUT,6717)N2 19151 CALL DPWRST('XXX','BUG ') 19152 IERROR='YES' 19153 GOTO9000 19154 ENDIF 19155 6711 FORMAT('***** ERROR IN MATAR2--') 19156 6712 FORMAT(' FOR MATRIX REPLACE ROW,') 19157 6713 FORMAT(' THE NUMBER OF COLUMNS IN THE MATRIX MUST EQUAL') 19158 6714 FORMAT(' THE NUMBER OF COLUMNS IN THE VECTOR. SUCH WAS') 19159 6715 FORMAT(' NOT THE CASE HERE.') 19160 6716 FORMAT(' THE NUMBER OF COLUMNS IN THE MATRIX = ',I8) 19161 6717 FORMAT(' THE NUMBER OF COLUMNS IN THE VECTOR = ',I8) 19162C 19163 DO6720J=1,NC1 19164 DO6725I=1,NR1 19165 YM9(I,J)=YM1(I,J) 19166 6725 CONTINUE 19167 6720 CONTINUE 19168 DO6730J=1,N2 19169 YM9(IROWID,J)=Y2(J) 19170 6730 CONTINUE 19171C 19172 ITYP9='MATR' 19173 NR9=NR1 19174 NC9=NC1 19175 IUPFLG='SUBS' 19176 GOTO9000 19177C 19178C ***************************************************** 19179C ** STEP 68-- ** 19180C ** TREAT THE MATRIX REPLACE ELEMENT CASE ** 19181C ***************************************************** 19182C 19183 6800 CONTINUE 19184 IROWID=INT(YS2+0.5) 19185 ICOLID=INT(YS3+0.5) 19186 IF(IROWID.LT.1 .OR. IROWID.GT.NR1)THEN 19187 WRITE(ICOUT,999) 19188 CALL DPWRST('XXX','BUG ') 19189 WRITE(ICOUT,6801) 19190 CALL DPWRST('XXX','BUG ') 19191 WRITE(ICOUT,6802) 19192 CALL DPWRST('XXX','BUG ') 19193 WRITE(ICOUT,6803) 19194 WRITE(ICOUT,6804)NR1 19195 CALL DPWRST('XXX','BUG ') 19196 WRITE(ICOUT,6805)IROWID 19197 CALL DPWRST('XXX','BUG ') 19198 IERROR='YES' 19199 GOTO9000 19200 ENDIF 19201 6801 FORMAT('***** ERROR IN MATAR2--') 19202 6802 FORMAT(' FOR MATRIX REPLACE ELEMENT,') 19203 6803 FORMAT(' THE REQUESTED ROW IN THE MATRIX MUST BE BETWEEN') 19204 6804 FORMAT(' 1 AND ',I8,'. SUCH WAS NOT THE CASE HERE.') 19205 6805 FORMAT(' THE REQUESTED ROW NUMBER = ',I8) 19206C 19207 IF(ICOLID.LT.1 .OR. ICOLID.GT.NC1)THEN 19208 WRITE(ICOUT,999) 19209 CALL DPWRST('XXX','BUG ') 19210 WRITE(ICOUT,6811) 19211 CALL DPWRST('XXX','BUG ') 19212 WRITE(ICOUT,6812) 19213 CALL DPWRST('XXX','BUG ') 19214 WRITE(ICOUT,6813) 19215 WRITE(ICOUT,6814)NC1 19216 CALL DPWRST('XXX','BUG ') 19217 WRITE(ICOUT,6815)ICOLID 19218 CALL DPWRST('XXX','BUG ') 19219 IERROR='YES' 19220 GOTO9000 19221 ENDIF 19222 6811 FORMAT('***** ERROR IN MATAR2--') 19223 6812 FORMAT(' FOR MATRIX REPLACE ELEMENT,') 19224 6813 FORMAT(' THE REQUESTED COLUMN IN THE MATRIX MUST BE') 19225 6814 FORMAT(' BETWEEN 1 AND ',I8,'. SUCH WAS NOT THE CASE') 19226 6815 FORMAT(' HERE. THE REQUESTED COLUMN NUMBER = ',I8) 19227C 19228 DO6820J=1,NC1 19229 DO6825I=1,NR1 19230 YM9(I,J)=YM1(I,J) 19231 6825 CONTINUE 19232 6820 CONTINUE 19233 YM9(IROWID,ICOLID)=YS4 19234C 19235 ITYP9='MATR' 19236 NR9=NR1 19237 NC9=NC1 19238 IUPFLG='SUBS' 19239 GOTO9000 19240C 19241C ********************************************* 19242C ** STEP 69-- ** 19243C ** TREAT THE TRIDIAGONAL SOLUTION CASE ** 19244C ** REFERENCE--LINPACK (CHAPTER 7) ** 19245C ********************************************* 19246C 19247 6900 CONTINUE 19248C 19249 IF((N1.EQ.N2).AND.(N2.EQ.N3).AND.(N3.EQ.N4))GOTO6909 19250 WRITE(ICOUT,999) 19251 CALL DPWRST('XXX','BUG ') 19252 WRITE(ICOUT,6901) 19253 6901 FORMAT('***** ERROR IN MATAR2--') 19254 CALL DPWRST('XXX','BUG ') 19255 WRITE(ICOUT,6902) 19256 6902 FORMAT(' FOR SOLVING A TRIDIAGONAL EQUATION,') 19257 CALL DPWRST('XXX','BUG ') 19258 WRITE(ICOUT,6903) 19259 6903 FORMAT(' THE NUMBER OF ROWS IN THE FOUR INPUT VECTORS') 19260 CALL DPWRST('XXX','BUG ') 19261 WRITE(ICOUT,6904) 19262 6904 FORMAT(' MUST BE EQUAL. SUCH WAS NOT THE CASE HERE.') 19263 CALL DPWRST('XXX','BUG ') 19264 WRITE(ICOUT,6907)N1,N2,N3,N4 19265 6907 FORMAT(' NUMBER OF ROWS IN THE VECTORS = ',4(I8,1X)) 19266 CALL DPWRST('XXX','BUG ') 19267 IERROR='YES' 19268 GOTO9000 19269 6909 CONTINUE 19270C 19271 CALL SGTSL(N1,Y1,Y2,Y3,Y4,INFO) 19272 IF(INFO.EQ.0)GOTO6919 19273 WRITE(ICOUT,999) 19274 CALL DPWRST('XXX','BUG ') 19275 WRITE(ICOUT,6911) 19276 6911 FORMAT('***** ERROR IN MATAR2--') 19277 CALL DPWRST('XXX','BUG ') 19278 WRITE(ICOUT,6912) 19279 6912 FORMAT(' IN SOLVING A TRIDIAGONAL EQUATION,') 19280 CALL DPWRST('XXX','BUG ') 19281 WRITE(ICOUT,6913) 19282 6913 FORMAT(' A ZERO PIVOT ELEMENT WAS DETECTED.') 19283 CALL DPWRST('XXX','BUG ') 19284 IERROR='YES' 19285 GOTO9000 19286 6919 CONTINUE 19287C 19288 DO6920I=1,N1 19289 VECT9(I)=Y4(I) 19290 6920 CONTINUE 19291C 19292 ITYP9='VECT' 19293 NVECT9=N1 19294 IUPFLG='FULL' 19295 GOTO9000 19296C 19297C ********************************************* 19298C ** STEP 70-- ** 19299C ** TREAT THE TRIANGULAR SOLVE CASE ** 19300C ** REFERENCE--LINPACK (CHAPTER 6) ** 19301C ********************************************* 19302C 19303 7000 CONTINUE 19304C 19305 IF(NR1.EQ.N2)GOTO7009 19306 WRITE(ICOUT,999) 19307 CALL DPWRST('XXX','BUG ') 19308 WRITE(ICOUT,7001) 19309 7001 FORMAT('***** ERROR IN MATAR2--') 19310 CALL DPWRST('XXX','BUG ') 19311 WRITE(ICOUT,7002) 19312 7002 FORMAT(' FOR SOLVING A MATRIX EQUATION SUCH AS A*X = B,') 19313 CALL DPWRST('XXX','BUG ') 19314 WRITE(ICOUT,7003) 19315 7003 FORMAT(' THE NUMBER OF ROWS IN THE LEFT-SIDE MATRIX') 19316 CALL DPWRST('XXX','BUG ') 19317 WRITE(ICOUT,7004) 19318 7004 FORMAT(' MUST EQUAL') 19319 CALL DPWRST('XXX','BUG ') 19320 WRITE(ICOUT,7005) 19321 7005 FORMAT(' THE NUMBER OF ROWS IN THE RIGHT-SIDE VECTOR;') 19322 CALL DPWRST('XXX','BUG ') 19323 WRITE(ICOUT,7006) 19324 7006 FORMAT(' SUCH WAS NOT THE CASE HERE.') 19325 CALL DPWRST('XXX','BUG ') 19326 WRITE(ICOUT,7007)NR1 19327 7007 FORMAT(' NUMBER OF ROWS IN THE MATRIX = ',I8) 19328 CALL DPWRST('XXX','BUG ') 19329 WRITE(ICOUT,7008)N2 19330 7008 FORMAT(' NUMBER OF ROWS IN THE VECTOR = ',I8) 19331 CALL DPWRST('XXX','BUG ') 19332 IERROR='YES' 19333 GOTO9000 19334 7009 CONTINUE 19335C 19336 IJOB=1 19337 DO7046I=1,NR1 19338 DO7047J=I+1,NC1 19339 IF(YM1(I,J).NE.0.0)GOTO7049 19340 7047 CONTINUE 19341 7046 CONTINUE 19342 IJOB=0 19343 7049 CONTINUE 19344C 19345 DO7051I=1,N2 19346 VECT9(I)=Y2(I) 19347 7051 CONTINUE 19348C 19349 CALL STRSL(YM1,MAXROM,NR1,VECT9,IJOB,INFO) 19350 IF(INFO.NE.0)THEN 19351 WRITE(ICOUT,999) 19352 CALL DPWRST('XXX','BUG ') 19353 WRITE(ICOUT,7071) 19354 CALL DPWRST('XXX','ERRO ') 19355 WRITE(ICOUT,7072) 19356 CALL DPWRST('XXX','ERRO ') 19357 IERROR='YES' 19358 END IF 19359 7071 FORMAT('****** ERROR IN MATAR2 ********') 19360 7072 FORMAT(' THE INPUT MATRIX IS SINGULAR') 19361C 19362 ITYP9='VECT' 19363 NVECT9=NR1 19364 IUPFLG='FULL' 19365 GOTO9000 19366C 19367C ********************************************* 19368C ** STEP 71-- ** 19369C ** TREAT THE TRIANGULAR INVERSE CASE ** 19370C ** REFERENCE--LINPACK (CHAPTER 6) ** 19371C ********************************************* 19372C 19373 7100 CONTINUE 19374C 19375 IF(NR1.EQ.NC1)GOTO7109 19376 WRITE(ICOUT,999) 19377 CALL DPWRST('XXX','BUG ') 19378 WRITE(ICOUT,7101) 19379 7101 FORMAT('***** ERROR IN MATAR2--') 19380 CALL DPWRST('XXX','BUG ') 19381 WRITE(ICOUT,7102) 19382 7102 FORMAT(' FOR TRIANGULAR INVERSE,') 19383 CALL DPWRST('XXX','BUG ') 19384 WRITE(ICOUT,7103) 19385 7103 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX') 19386 CALL DPWRST('XXX','BUG ') 19387 WRITE(ICOUT,7104) 19388 7104 FORMAT(' MUST EQUAL') 19389 CALL DPWRST('XXX','BUG ') 19390 WRITE(ICOUT,7105) 19391 7105 FORMAT(' THE NUMBER OF COLUMNS IN THE MATRIX;') 19392 CALL DPWRST('XXX','BUG ') 19393 WRITE(ICOUT,7106) 19394 7106 FORMAT(' SUCH WAS NOT THE CASE HERE.') 19395 CALL DPWRST('XXX','BUG ') 19396 WRITE(ICOUT,7107)NR1 19397 7107 FORMAT(' NUMBER OF ROWS =',I8) 19398 CALL DPWRST('XXX','BUG ') 19399 WRITE(ICOUT,7108)NC1 19400 7108 FORMAT(' NUMBER OF COLUMNS =',I8) 19401 CALL DPWRST('XXX','BUG ') 19402 IERROR='YES' 19403 GOTO9000 19404 7109 CONTINUE 19405C 19406 IJOB=11 19407 DO7126I=1,NR1 19408 DO7127J=I+1,NC1 19409 IF(YM1(I,J).NE.0.0)GOTO7129 19410 7127 CONTINUE 19411 7126 CONTINUE 19412 IJOB=10 19413 7129 CONTINUE 19414 CALL STRDI(YM1,MAXROM,NR1,Y1,IJOB,INFO) 19415 IF(INFO.NE.0)THEN 19416 WRITE(ICOUT,999) 19417 CALL DPWRST('XXX','BUG ') 19418 WRITE(ICOUT,7171) 19419 CALL DPWRST('XXX','ERRO') 19420 WRITE(ICOUT,7172) 19421 CALL DPWRST('XXX','ERRO') 19422 IERROR='YES' 19423 GOTO9000 19424 END IF 19425 7171 FORMAT('****** ERROR IN MATAR2 ********') 19426 7172 FORMAT(' THE INPUT MATRIX IS SINGULAR') 19427C 19428 DO7181J=1,NC1 19429 DO7182I=1,NR1 19430 YM9(I,J)=YM1(I,J) 19431 7182 CONTINUE 19432 7181 CONTINUE 19433CCCCC END CHANGE 19434C 19435 ITYP9='MATR' 19436 NR9=NR1 19437 NC9=NC1 19438 IUPFLG='FULL' 19439 GOTO9000 19440C 19441C ********************************************* 19442C ** STEP 72-- ** 19443C ** TREAT THE MATRIX ITERATIVE SOLUTION CASE* 19444C ** REFERENCE--LINPACk (PAGE 1.9) ** 19445C ********************************************* 19446C 19447 7200 CONTINUE 19448C 19449 IF(NR1.EQ.N2)GOTO7209 19450 WRITE(ICOUT,999) 19451 CALL DPWRST('XXX','BUG ') 19452 WRITE(ICOUT,7201) 19453 7201 FORMAT('***** ERROR IN MATARI--') 19454 CALL DPWRST('XXX','BUG ') 19455 WRITE(ICOUT,7202) 19456 7202 FORMAT(' FOR SOLVING A MATRIX EQUATION SUCH AS A*X = B,') 19457 CALL DPWRST('XXX','BUG ') 19458 WRITE(ICOUT,7203) 19459 7203 FORMAT(' THE NUMBER OF ROWS IN THE LEFT-SIDE MATRIX') 19460 CALL DPWRST('XXX','BUG ') 19461 WRITE(ICOUT,7204) 19462 7204 FORMAT(' MUST EQUAL') 19463 CALL DPWRST('XXX','BUG ') 19464 WRITE(ICOUT,7205) 19465 7205 FORMAT(' THE NUMBER OF ROWS IN THE RIGHT-SIDE VECTOR;') 19466 CALL DPWRST('XXX','BUG ') 19467 WRITE(ICOUT,7206) 19468 7206 FORMAT(' SUCH WAS NOT THE CASE HERE.') 19469 CALL DPWRST('XXX','BUG ') 19470 WRITE(ICOUT,7207)NR1 19471 7207 FORMAT(' NUMBER OF ROWS IN THE MATRIX = ',I8) 19472 CALL DPWRST('XXX','BUG ') 19473 WRITE(ICOUT,7208)N2 19474 7208 FORMAT(' NUMBER OF ROWS IN THE VECTOR = ',I8) 19475 CALL DPWRST('XXX','BUG ') 19476 IERROR='YES' 19477 GOTO9000 19478 7209 CONTINUE 19479C 19480 DO7241J=1,NC1 19481 DO7242I=1,NR1 19482 YM2(I,J)=YM1(I,J) 19483 7242 CONTINUE 19484 VECT9(J)=Y2(J) 19485 7241 CONTINUE 19486C 19487 CALL SGEFA(YM2,MAXROM,NR1,INDEX,INFO) 19488 IF(INFO.NE.0)THEN 19489 WRITE(ICOUT,999) 19490 CALL DPWRST('XXX','BUG ') 19491 WRITE(ICOUT,7271) 19492 CALL DPWRST('XXX','ERRO ') 19493 WRITE(ICOUT,7272) 19494 CALL DPWRST('XXX','ERRO ') 19495 IERROR='YES' 19496 GOTO9000 19497 END IF 19498 7271 FORMAT('****** ERROR IN MATAR2 ********') 19499 7272 FORMAT(' THE INPUT MATRIX IS SINGULAR') 19500C 19501 IJOB=0 19502 CALL SGESL(YM2,MAXROM,NR1,INDEX,VECT9,IJOB) 19503 XNORM=SASUM(NR1,VECT9,1) 19504 RELERR=0.0 19505 IF(XNORM.EQ.0.0)GOTO7295 19506 DO7280ITER=1,20 19507 DO7285I=1,NR1 19508 Y3(I)=SDSDOT(NR1,YM1(I,1),MAXROM,VECT9(1),1,-Y2(I)) 19509 7285 CONTINUE 19510 CALL SGESL(YM2,MAXROM,NR1,INDEX,Y3,IJOB) 19511 DO7290I=1,NR1 19512 VECT9(I)=VECT9(I)-Y3(I) 19513 7290 CONTINUE 19514 RNORM=SASUM(NR1,Y3,1) 19515 IF(ITER.EQ.1)RELERR=RNORM/XNORM 19516 YS1=XNORM+RNORM 19517 IF(YS1.EQ.XNORM)GOTO7295 19518 7280 CONTINUE 19519 IERROR='YES' 19520 WRITE(ICOUT,999) 19521 CALL DPWRST('XXX','BUG ') 19522 WRITE(ICOUT,7281) 19523 CALL DPWRST('XXX','ERRO ') 19524 WRITE(ICOUT,7282) 19525 CALL DPWRST('XXX','ERRO ') 19526 GOTO9000 19527 7281 FORMAT('****** ERROR IN MATARI ********') 19528 7282 FORMAT(' SOLUTION FAILED TO CONVERGE.') 19529C 19530 7295 CONTINUE 19531 ITYP9='VECT' 19532 NVECT9=NR1 19533 IF(IFEEDB.EQ.'OFF')GOTO7299 19534 WRITE(ICOUT,999) 19535 CALL DPWRST('XXX','BUG ') 19536 WRITE(ICOUT,7296)RCOND 19537 CALL DPWRST('XXX','TEXT ') 19538 7296 FORMAT('THE RELATIVE ERROR = ',E15.7) 19539 7299 CONTINUE 19540 IUPFLG='FULL' 19541 GOTO9000 19542C 19543C ************************************************ 19544C ** STEP 73-- ** 19545C ** TREAT THE BIPLOT CASE ** 19546C ************************************************ 19547C 19548CCCCC IMPLEMENTED JULY 1993. 19549 7300 CONTINUE 19550C 19551 DO7322J=1,MAXCOM 19552 DO7321I=1,MAXROM 19553 YM9(I,J)=0.0 19554 YM2(I,J)=0.0 19555 7321 CONTINUE 19556 7322 CONTINUE 19557C 19558C STEP 1: SCALE MATRIX (BASED ON IBPLSC) 19559C 19560C 1) GMEA - SUBTRACT GRAND MEAN (DEFAULT) 19561C 2) CMEA - SUBTRACT COLUMN MEAN 19562C 3) NONE - NO SCALING 19563C 19564 IF(IBPLSC.EQ.'CMEA')THEN 19565 DO7330J=1,NC1 19566 DSUM1=0.0D0 19567 DO7335I=1,NR1 19568 DSUM1=DSUM1 + DBLE(YM1(I,J)) 19569 7335 CONTINUE 19570 AMEAN=REAL(DSUM1/DBLE(NR1)) 19571 DO7338I=1,NR1 19572 YM1(I,J)=YM1(I,J) - AMEAN 19573 7338 CONTINUE 19574 7330 CONTINUE 19575 ELSEIF(IBPLSC.EQ.'GMEA')THEN 19576 DSUM1=0.0D0 19577 DO7340J=1,NC1 19578 DO7345I=1,NR1 19579 DSUM1=DSUM1 + DBLE(YM1(I,J)) 19580 7345 CONTINUE 19581 7340 CONTINUE 19582 AMEAN=REAL(DSUM1/DBLE(NR1*NC1)) 19583 DO7349J=1,NC1 19584 DO7348I=1,NR1 19585 YM1(I,J)=YM1(I,J) - AMEAN 19586 7348 CONTINUE 19587 7349 CONTINUE 19588 ENDIF 19589C 19590C STEP 2: COMPUTE EUCLIDEAN NORM 19591C 19592 DSUM1=0.0D0 19593 DO7361I=1,NR1 19594 DO7362J=1,NC1 19595 DYM1=YM1(I,J) 19596 DSUM1=DSUM1+DYM1*DYM1 19597 7362 CONTINUE 19598 7361 CONTINUE 19599 DYM1=0.0D0 19600 IF(DSUM1.GT.0.0D0)DYM1=DSQRT(DSUM1) 19601 SCAL9=REAL(DYM1) 19602C 19603C STEP 3: COMPUTE SINGULAR VALUE FACTORIZATION 19604C 19605 IERR2=0 19606 IJOB=22 19607 NTEMP1=NR1 19608 NTEMP2=NC1 19609 CALL SSVDC(YM1,MAXROM,NTEMP1,NTEMP2,VECT9,Y1,YM9,MAXROM, 19610 1YM2,MAXROM,Y2,IJOB,IERR2) 19611C 19612 S1=VECT9(1) 19613 S2=VECT9(2) 19614 AFACT1=S1**PBPLCO 19615 AFACT2=S2**PBPLCO 19616 SCAL9=(S1**2 + S2**2)/SCAL9**2 19617 DO7670I=1,NTEMP1 19618 VECT9(I)=YM9(I,1)*AFACT1 19619 Y2(I)=YM9(I,2)*AFACT2 19620 Y3(I)=1.0 19621 7670 CONTINUE 19622 ICNT=NTEMP1 19623 AFACT1=S1**(1.0-PBPLCO) 19624 AFACT2=S2**(1.0-PBPLCO) 19625 DO7680I=1,NTEMP2 19626 ICNT=ICNT+1 19627 VECT9(ICNT)=YM2(1,I)*AFACT1 19628 Y2(ICNT)=YM2(2,I)*AFACT2 19629 Y3(ICNT)=2.0 19630 7680 CONTINUE 19631C 19632 ITYP9='VECT' 19633 NVECT9=ICNT 19634 IUPFLG='FULL' 19635 GOTO9000 19636C 19637C ***************** 19638C ** STEP 90-- ** 19639C ** EXIT. ** 19640C ***************** 19641C 19642 9000 CONTINUE 19643C 19644 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'TAR2')GOTO9090 19645C 19646 WRITE(ICOUT,999) 19647 CALL DPWRST('XXX','BUG ') 19648 WRITE(ICOUT,9011) 19649 9011 FORMAT('***** AT THE END OF MATAR2--') 19650 CALL DPWRST('XXX','BUG ') 19651 WRITE(ICOUT,9012)IBUGA3,ISUBRO,IMCASE,ITYPA1,ITYPA2,ITYPA3,ITYPA4 19652 9012 FORMAT('IBUGA3,ISUBRO,IMCASE,ITYPA1,ITYPA2,ITYPA3,ITYPA4 = ', 19653 1A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4) 19654 CALL DPWRST('XXX','BUG ') 19655 WRITE(ICOUT,9013)IMCASE,IMSUBC 19656 9013 FORMAT('IMCASE,IMSUBC = ',A4,2X,A4) 19657 CALL DPWRST('XXX','BUG ') 19658 WRITE(ICOUT,9014)NUMVAR,IWRITE 19659 9014 FORMAT('NUMVAR,IWRITE = ',I8,2X,A4) 19660 CALL DPWRST('XXX','BUG ') 19661 WRITE(ICOUT,9015)YS1,YS2,YS3,YS4 19662 9015 FORMAT('YS1,YS2,YS3,YS4 = ',4E15.7) 19663 CALL DPWRST('XXX','BUG ') 19664 WRITE(ICOUT,9016)IERROR 19665 9016 FORMAT('IERROR = ',A4) 19666 CALL DPWRST('XXX','BUG ') 19667 WRITE(ICOUT,9017)IYS2,IYS3,IYS23,NRJ,NCJ 19668 9017 FORMAT('IYS2,IYS3,IYS23,NRJ,NCJ = ',5I8) 19669 CALL DPWRST('XXX','BUG ') 19670C 19671 WRITE(ICOUT,999) 19672 CALL DPWRST('XXX','BUG ') 19673 WRITE(ICOUT,9031)NR1,NC1 19674 9031 FORMAT('NR1,NC1 = ',2I8) 19675 CALL DPWRST('XXX','BUG ') 19676 IF(NR1.LE.0)GOTO9039 19677 IF(NC1.LE.0)GOTO9039 19678 JMAX=NC1 19679 IF(JMAX.GT.10)JMAX=10 19680 DO9032I=1,NR1 19681 WRITE(ICOUT,9033)I,(YM1(I,J),J=1,JMAX) 19682 9033 FORMAT('I,YM1(I,.) = ',I8,10E10.3) 19683 CALL DPWRST('XXX','BUG ') 19684 9032 CONTINUE 19685 9039 CONTINUE 19686C 19687 WRITE(ICOUT,999) 19688 CALL DPWRST('XXX','BUG ') 19689 WRITE(ICOUT,9041)NR2,NC2 19690 9041 FORMAT('NR2,NC2 = ',2I8) 19691 CALL DPWRST('XXX','BUG ') 19692 IF(NR2.LE.0)GOTO9049 19693 IF(NC2.LE.0)GOTO9049 19694 JMAX=NC2 19695 IF(JMAX.GT.10)JMAX=10 19696 DO9042I=1,NR2 19697 WRITE(ICOUT,9043)I,(YM2(I,J),J=1,JMAX) 19698 9043 FORMAT('I,YM2(I,.) = ',I8,10E10.3) 19699 CALL DPWRST('XXX','BUG ') 19700 9042 CONTINUE 19701 9049 CONTINUE 19702C 19703 WRITE(ICOUT,999) 19704 CALL DPWRST('XXX','BUG ') 19705 WRITE(ICOUT,9051)NR9,NC9 19706 9051 FORMAT('NR9,NC9 = ',2I8) 19707 CALL DPWRST('XXX','BUG ') 19708 IF(NR9.LE.0)GOTO9059 19709 IF(NC9.LE.0)GOTO9059 19710 JMAX=NC9 19711 IF(JMAX.GT.10)JMAX=10 19712 DO9055I=1,NR9 19713 WRITE(ICOUT,9056)I,(YM9(I,J),J=1,JMAX) 19714 9056 FORMAT('I,YM9(I,.) = ',I8,10E10.3) 19715 CALL DPWRST('XXX','BUG ') 19716 9055 CONTINUE 19717 9059 CONTINUE 19718C 19719 WRITE(ICOUT,999) 19720 CALL DPWRST('XXX','BUG ') 19721 WRITE(ICOUT,9111)N1 19722 9111 FORMAT('N1 = ',I8) 19723 CALL DPWRST('XXX','BUG ') 19724 IF(N1.LE.0)GOTO9119 19725 DO9112I=1,N1 19726 WRITE(ICOUT,9113)I,Y1(I) 19727 9113 FORMAT('I,Y1(I) = ',I8,E15.7) 19728 CALL DPWRST('XXX','BUG ') 19729 9112 CONTINUE 19730 9119 CONTINUE 19731C 19732 WRITE(ICOUT,999) 19733 CALL DPWRST('XXX','BUG ') 19734 WRITE(ICOUT,9121)N2 19735 9121 FORMAT('N2 = ',I8) 19736 CALL DPWRST('XXX','BUG ') 19737 IF(N2.LE.0)GOTO9129 19738 DO9122I=1,N2 19739 WRITE(ICOUT,9123)I,Y2(I) 19740 9123 FORMAT('I,Y2(I) = ',I8,E15.7) 19741 CALL DPWRST('XXX','BUG ') 19742 9122 CONTINUE 19743 9129 CONTINUE 19744C 19745 WRITE(ICOUT,999) 19746 CALL DPWRST('XXX','BUG ') 19747 WRITE(ICOUT,9131)N3 19748 9131 FORMAT('N3 = ',I8) 19749 CALL DPWRST('XXX','BUG ') 19750 IF(N3.LE.0)GOTO9139 19751 DO9132I=1,N3 19752 WRITE(ICOUT,9133)I,Y3(I) 19753 9133 FORMAT('I,Y3(I) = ',I8,E15.7) 19754 CALL DPWRST('XXX','BUG ') 19755 9132 CONTINUE 19756 9139 CONTINUE 19757C 19758 WRITE(ICOUT,999) 19759 CALL DPWRST('XXX','BUG ') 19760 WRITE(ICOUT,9141)N4 19761 9141 FORMAT('N4 = ',I8) 19762 CALL DPWRST('XXX','BUG ') 19763 IF(N4.LE.0)GOTO9149 19764 DO9142I=1,N4 19765 WRITE(ICOUT,9143)I,Y4(I) 19766 9143 FORMAT('I,Y4(I) = ',I8,E15.7) 19767 CALL DPWRST('XXX','BUG ') 19768 9142 CONTINUE 19769 9149 CONTINUE 19770C 19771 WRITE(ICOUT,999) 19772 CALL DPWRST('XXX','BUG ') 19773 WRITE(ICOUT,9151)ITYP9,SCAL9 19774 9151 FORMAT('ITYP9,SCAL9 = ',A4,2X,E15.7) 19775 CALL DPWRST('XXX','BUG ') 19776C 19777 WRITE(ICOUT,999) 19778 CALL DPWRST('XXX','BUG ') 19779 WRITE(ICOUT,9161)NVECT9 19780 9161 FORMAT('NVECT9 = ',I8) 19781 CALL DPWRST('XXX','BUG ') 19782 IF(NVECT9.LE.0)GOTO9169 19783 DO9162I=1,NVECT9 19784 WRITE(ICOUT,9163)I,VECT9(I) 19785 9163 FORMAT('I,VECT9(I) = ',I8,E15.7) 19786 CALL DPWRST('XXX','BUG ') 19787 9162 CONTINUE 19788 9169 CONTINUE 19789C 19790 WRITE(ICOUT,999) 19791 CALL DPWRST('XXX','BUG ') 19792 WRITE(ICOUT,9171)NR9,NC9 19793 9171 FORMAT('NR9,NC9 = ',2I8) 19794 CALL DPWRST('XXX','BUG ') 19795 IF(NR9.LE.0)GOTO9179 19796 IF(NC9.LE.0)GOTO9179 19797 JMAX=NC9 19798 IF(JMAX.GT.10)JMAX=10 19799 DO9172I=1,NR9 19800 WRITE(ICOUT,9173)I,(YM9(I,J),J=1,JMAX) 19801 9173 FORMAT('I,YM9(I,.) = ',I8,10E10.3) 19802 CALL DPWRST('XXX','BUG ') 19803 9172 CONTINUE 19804 9179 CONTINUE 19805C 19806 IF(IMCASE.NE.'MASS')GOTO9189 19807 WRITE(ICOUT,9181)NR2,NC2 19808 9181 FORMAT('NR2,NC2 = ',2I8) 19809 CALL DPWRST('XXX','BUG ') 19810 IF(NR2.LE.0)GOTO9189 19811 IF(NC2.LE.0)GOTO9189 19812 JMAX=NC2+1 19813 IF(JMAX.GT.10)JMAX=10 19814 NR2P1=NR2+1 19815 DO9182I=1,NR2P1 19816 WRITE(ICOUT,9183)I,(YM2(I,J),J=1,JMAX) 19817 9183 FORMAT('I,YM2(I,.) = ',I8,10E10.3) 19818 CALL DPWRST('XXX','BUG ') 19819 9182 CONTINUE 19820CCCCC WRITE(ICOUT,9187)NR2,NLTZ,NGTZ,NEQZ 19821C9187 FORMAT('NR2,NLTZ,NGTZ,NEQZ = ',4I8) 19822 WRITE(ICOUT,9187)NR2 19823 9187 FORMAT('NR2 = ',I8) 19824 CALL DPWRST('XXX','BUG ') 19825 9189 CONTINUE 19826C 19827 9090 CONTINUE 19828C 19829 RETURN 19830 END 19831 SUBROUTINE MATAR3(YM1,NR1,NC1,YM2,NR2,NC2,NR3,NC3, 19832 1 MAXROM,MAXCOM,MAXOBV, 19833 1 Y1,N1,Y2,N2,Y3,N3, 19834 1 Y4,N4,Y5,Y6, 19835 1 INDEX, 19836 1 DTEMP1,DTEMP2,DTEMP3, 19837 1 P,ABSE,RELE,AERROR, 19838 1 YS1,YS2,YS3,YS4, 19839 1 ASIG90,ASIG95,ASIG99,ASG995, 19840 1 IMCASE,IUPFLG,IMSUBC, 19841 1 ITYPA1,ITYPA2,ITYPA3,ITYPA4,NUMVAR,IWRITE, 19842 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4, 19843 1 ITEMP5,ITEMP6,ITEMP7, 19844 1 YM9,NR9,NC9,VECT9,NVECT9,SCAL9,ITYP9, 19845 1 ICASS7, 19846 1 IRELAT,CLWID,XSTART,XSTOP, 19847 1 STME,STMEC,ST2T,ST2TC,STC,STT, 19848 1 IBUGA3,ISUBRO,IERROR) 19849C 19850C PURPOSE--CARRY OUT MATRIX ARITHMETIC OPERATIONS 19851C OF THE REAL DATA IN MATRICES YM1 AND YM2. 19852C ADD SOME ADDITIONAL FUNCTIONALITY 19853C 19854C OPERATIONS--QUADRATIC FORM (X'MX) 19855C 1-SAMPLE HOTELLING T-SQUARE 19856C 2-SAMPLE HOTELLING T-SQUARE 19857C POOLED SAMPLE VARIANCE-COVARIANCE MATRIX 19858C MATRIX <ROW/COLUMN> SCALE 19859C <ROW/COLUMN> <STATISTIC> 19860C PARTITION <STATISTIC> 19861C MATRIX <STATISTIC> 19862C MATRIX BIN 19863C EUCLIDEAN <ROW/COLUMN> DISTANCE 19864C CHEBYCHEV <ROW/COLUMN> DISTANCE 19865C L1 NORM <ROW/COLUMN> DISTANCE 19866C MINKOWSKY <ROW/COLUMN> DISTANCE 19867C MAHALANOBIS <ROW/COLUMN> DISTANCE 19868C MATRIX MEAN (I.E., GRAND MEAN) 19869C MATRIX SUM 19870C MATRIX ADD ROW 19871C MATRIX DELETE ROW 19872C LINEAR COMBINATION 19873C VECTOR TIMES TRANSPOSE 19874C MATRIX GROUP MEAN 19875C MATRIX GROUP STANDARD DEVIATION 19876C CATCHER MATRIX 19877C MULTIVARIATE NORMAL RANDOM NUMBERS 19878C MULTINOMIAL RANDOM NUMBERS 19879C MULTINOMIAL PDF 19880C XTXINV MATRIX 19881C VARIANCE INFLATION FACTORS 19882C CONDITION INDICES 19883C CREATE MATRIX 19884C QR DECOMPOSITION (NOT DONE) 19885C PSEUDO INVERSE 19886C WISHART RANDOM NUMBERS 19887C INDEPENDENT UNIFORM RANDOM NUMBERS 19888C CORRELATED UNIFORM RANDOM NUMBERS 19889C MULTIVARIATE NORMAL CDF 19890C DIRICHLET RANDOM NUMBERS 19891C MATRIX BIN 19892C MATRIX PARTITION <STAT> 19893C MATRIX <STAT> 19894C MINIMAL SPANNING TREE 19895C MATRIX RENUMBER 19896C EDGES TO ADJACENCY MATRIX 19897C MATRIX <ROW/COLUMN> FIT 19898C VARIABLE TO MATRIX 19899C MATRIX TO VARIABLE 19900C MATRIX COMBINE ROWS 19901C MATRIX COMBINE COLUMNS 19902C GENERATE MATRIX <STAT> 19903C DEX CORE 19904C DEX CONFOUND 19905C DEX CHECK CLASSIC 19906C DEX CHECK CENTER POINT 19907C 19908C EXAMPLES--LET A1 = QUADRATIC FORM M X 19909C --LET A1 = HOTELLING T-SQUARE M U0 19910C --LET Y1 = MATRIX ROW MEAN M 19911C LET Y1 = MATRIX COLUMN MEAN M 19912C 19913C INPUT ARGUMENTS--YM1 (REAL MATRIX) 19914C --NR1 19915C --NC1 19916C --YM2 (REAL MATRIX) 19917C --NR2 19918C --NC2 19919C --YM3 (REAL MATRIX) 19920C --NR3 19921C --NC3 19922C --Y1 (REAL VECTOR) 19923C --N1 19924C --Y2 (REAL VECTOR) 19925C --N2 19926C --Y3 (REAL VECTOR) 19927C --N3 19928C --Y4 (REAL VECTOR) 19929C --N4 19930C OUTPUT ARGUMENTS--YM9 (REAL MATRIX) 19931C --NR9 19932C --NC9 19933C --VECT9 (REAL VECTOR) 19934C --NVECT9 19935C --SCAL9 (REAL SCALAR) 19936C --ITYP9 19937C 19938C NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT MATRIX YM9(.) 19939C BEING IDENTICAL TO THE INPUT MATRIX YM1(.), YM2(.), OR YM3(.). 19940C WRITTEN BY--JAMES J. FILLIBEN 19941C STATISTICAL ENGINEERING DIVISION 19942C INFORMATION TECHNOLOGY LABORATORY 19943C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 19944C GAITHERSBURG, MD 20899-8980 19945C PHONE--301-975-2855 19946C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 19947C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 19948C LANGUAGE--ANSI FORTRAN (1977) 19949C VERSION NUMBER--98/06 19950C ORIGINAL VERSION--JUNE 1998. 19951C UPDATED --MAY 2002. MULTIVARIATE NORM RAND NUMB 19952C UPDATED --MAY 2002. MULTINOMIAL RAND NUMB 19953C UPDATED --MAY 2002. WISHART RAND NUMB 19954C UPDATED --JUNE 2002. CATCHER MATRIX 19955C UPDATED --JUNE 2002. XTXINV MATRIX 19956C UPDATED --JUNE 2002. VARIANCE INFLATION FACTORS 19957C UPDATED --JUNE 2002. CONDITION NUMBERS 19958C UPDATED --JUNE 2002. CREATE MATRIX 19959C UPDATED --AUGUST 2002. USE "CMPSTA" TO COMPUTE 19960C STATISTIC FOR 19961C MATRIX <ROW/COLU> <STAT> 19962C UPDATED --APRIL 2003. FIX WISHART RANDOM NUMBERS 19963C UPDATED --APRIL 2003. MULTIVARIATE T RANDOM NUMBERS 19964C UPDATED --APRIL 2003. INDPENDENT UNIFORM RANDOM NUMB 19965C UPDATED --APRIL 2003. MULTIVARIATE NORMAL CDF 19966C UPDATED --APRIL 2003. MULTIVARIATE T CDF 19967C UPDATED --APRIL 2003. ARGUMENT LIST TO CMPSTA 19968C UPDATED --SEPTEMBER 2003. CORRELATED UNIFORM RANDOM NUMB 19969C UPDATED --JUNE 2005. MATRIX PARTITION <STAT> 19970C UPDATED --JUNE 2005. MATRIX <STAT> 19971C UPDATED --JULY 2005. MATRIX PARTITION <STAT> 19972C EXTENDED TO UNEQUAL PARTITION 19973C CASE 19974C UPDATED --MARCH 2006. MATRIX BIN 19975C UPDATED --MAY 2008. MATRIX RENUMBER 19976C UPDATED --JUNE 2008. EDGES TO ADJACENCY MATRIX 19977C UPDATED --SEPTEMBER 2008. ACTIVATE PSEUDO INVERSE COMMAND 19978C (ACTUALLY RETURNS TRANSPOSE OF 19979C PSEUDO INVERSE) 19980C UPDATED --JANUARY 2009. DISTINCTION BETWEEN DIRECTED AND 19981C UNDIRECTED ADJACENCY MATRIX 19982C UPDATED --FEBRUARY 2010. MATRIX <ROW/COLUMN> FIT 19983C UPDATED --JUNE 2010. CALL LIST TO CMPSTA 19984C UPDATED --NOVEMBER 2010. VARIABLE TO MATRIX 19985C UPDATED --NOVEMBER 2010. MATRIX TO VARIABLE 19986C UPDATED --JANUARY 2011. MATRIX COMBINE ROWS 19987C UPDATED --JANUARY 2011. MATRIX COMBINE COLUMNS 19988C UPDATED --AUGUST 2017. GENERATE MATRIX <STAT> 19989C UPDATED --JANUARY 2018. DEX CORE 19990C UPDATED --JANUARY 2018. DEX CONFOUND 19991C UPDATED --AUGUST 2018. HAVE ALL DISTANCE MATRIX 19992C (EUCLIDEAN, MINKOWSKY, BLOCK, 19993C CHEBYCHEV) GO THROUGH A SINGLE 19994C ROUTINE 19995C UPDATED --AUGUST 2018. ADDED ADDITIONAL DISTANCE 19996C MATRIX OPTIONS 19997C UPDATED --SEPTEMBER 2018. DEX CHECK CENTER POINTS 19998C 19999C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 20000C 20001C 20002 CHARACTER*4 IMCASE 20003 CHARACTER*4 ICASS7 20004 CHARACTER*4 IUPFLG 20005 CHARACTER*4 IMSUBC 20006 CHARACTER*4 ITYPA1 20007 CHARACTER*4 ITYPA2 20008 CHARACTER*4 ITYPA3 20009 CHARACTER*4 ITYPA4 20010 CHARACTER*4 IWRITE 20011 CHARACTER*4 ITYP9 20012 CHARACTER*4 IBUGA3 20013 CHARACTER*4 ISUBRO 20014 CHARACTER*4 IERROR 20015C 20016 CHARACTER*4 IRELAT 20017 CHARACTER*4 ICASE 20018 CHARACTER*4 ISUBN1 20019 CHARACTER*4 ISUBN2 20020 CHARACTER*4 ICASE2 20021C 20022CCCCC MAY 2002. ADD FOLLOWING LINE 20023 LOGICAL LTF 20024C 20025C-----DOUBLE PRECISION STATEMENTS FOR NON-COMMON VARIABLES------------------- 20026C 20027 DOUBLE PRECISION DNR1 20028 DOUBLE PRECISION DNC1 20029 DOUBLE PRECISION D999 20030 DOUBLE PRECISION DSUM1 20031 DOUBLE PRECISION DSUM2 20032 DOUBLE PRECISION ABSEPS 20033 DOUBLE PRECISION RELEPS 20034 DOUBLE PRECISION VALS 20035 DOUBLE PRECISION ERRS 20036 DOUBLE PRECISION DN 20037 DOUBLE PRECISION DNORM 20038 DOUBLE PRECISION DLNPDF 20039 DOUBLE PRECISION DLNGAM 20040C 20041C--------------------------------------------------------------------- 20042C 20043 DIMENSION YM1(MAXROM,MAXCOM) 20044 DIMENSION YM2(MAXROM,MAXCOM) 20045 DIMENSION Y1(*) 20046 DIMENSION Y2(*) 20047 DIMENSION Y3(*) 20048 DIMENSION Y4(*) 20049 DIMENSION Y5(*) 20050 DIMENSION Y6(*) 20051 DIMENSION YM9(MAXROM,MAXCOM) 20052 DIMENSION VECT9(*) 20053 DOUBLE PRECISION DTEMP1(*) 20054 DOUBLE PRECISION DTEMP2(*) 20055 DOUBLE PRECISION DTEMP3(*) 20056 INTEGER INDEX(*) 20057 INTEGER ITEMP1(*) 20058 INTEGER ITEMP2(*) 20059 INTEGER ITEMP3(*) 20060 INTEGER ITEMP4(*) 20061 INTEGER ITEMP5(*) 20062 INTEGER ITEMP6(*) 20063 INTEGER ITEMP7(*) 20064C 20065 CHARACTER*40 STME(500) 20066 CHARACTER*40 STMEC(500) 20067 CHARACTER*40 ST2T(500) 20068 CHARACTER*40 ST2TC(500) 20069 CHARACTER*40 STC(500) 20070 CHARACTER*40 STT(500) 20071C 20072C-----COMMON---------------------------------------------------------- 20073C 20074 INCLUDE 'DPCOST.INC' 20075 INCLUDE 'DPCOP2.INC' 20076C 20077C-----START POINT----------------------------------------------------- 20078C 20079 ISUBN1='MATA' 20080 ISUBN2='R3 ' 20081 IERROR='NO' 20082C 20083 IYS1=(-999) 20084 IYS2=(-999) 20085 IYS3=(-999) 20086 IYS23=(-999) 20087 NRJ=(-999) 20088 NCJ=(-999) 20089 D999=(-999.0D0) 20090C 20091 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ATR3')THEN 20092C 20093 WRITE(ICOUT,999) 20094 999 FORMAT(1X) 20095 CALL DPWRST('XXX','BUG ') 20096 WRITE(ICOUT,51) 20097 51 FORMAT('***** AT THE BEGINNING OF MATAR3--') 20098 CALL DPWRST('XXX','BUG ') 20099 WRITE(ICOUT,52)IBUGA3,ISUBRO,ITYPA1,ITYPA2,ITYPA3,ITYPA4 20100 52 FORMAT('IBUGA3,ISUBRO,ITYPA1,ITYPA2,ITYPA3,ITYPA4 = ', 20101 1 5(A4,2X),A4) 20102 CALL DPWRST('XXX','BUG ') 20103 WRITE(ICOUT,53)IMCASE,IMSUBC,IWRITE,NUMVAR 20104 53 FORMAT('IMCASE,IMSUBC,IWRITE,NUMVAR = ',3(A4,2X),I8) 20105 CALL DPWRST('XXX','BUG ') 20106 WRITE(ICOUT,55)YS1,YS2,YS3,YS4,Y6(1) 20107 55 FORMAT('YS1,YS2,YS3,YS4,Y6(1) = ',5G15.7) 20108 CALL DPWRST('XXX','BUG ') 20109C 20110 WRITE(ICOUT,999) 20111 CALL DPWRST('XXX','BUG ') 20112 WRITE(ICOUT,61)NR1,NC1 20113 61 FORMAT('NR1,NC1 = ',2I8) 20114 CALL DPWRST('XXX','BUG ') 20115 IF(NR1.GE.1 .AND. NC1.GE.1)THEN 20116 JMAX=NC1 20117 IF(JMAX.GT.10)JMAX=10 20118 DO62I=1,NR1 20119 WRITE(ICOUT,63)I,(YM1(I,J),J=1,JMAX) 20120 63 FORMAT('I,YM1(I,.) = ',I8,10E10.3) 20121 CALL DPWRST('XXX','BUG ') 20122 62 CONTINUE 20123 ENDIF 20124C 20125 WRITE(ICOUT,999) 20126 CALL DPWRST('XXX','BUG ') 20127 WRITE(ICOUT,71)NR2,NC2 20128 71 FORMAT('NR2,NC2 = ',2I8) 20129 CALL DPWRST('XXX','BUG ') 20130 IF(NR2.GE.1 .AND. NC2.GE.1)THEN 20131 JMAX=NC2 20132 IF(JMAX.GT.10)JMAX=10 20133 DO72I=1,NR2 20134 WRITE(ICOUT,73)I,(YM2(I,J),J=1,JMAX) 20135 73 FORMAT('I,YM2(I,.) = ',I8,10E10.3) 20136 CALL DPWRST('XXX','BUG ') 20137 72 CONTINUE 20138 ENDIF 20139C 20140 WRITE(ICOUT,999) 20141 CALL DPWRST('XXX','BUG ') 20142 WRITE(ICOUT,81)NR3,NC3 20143 81 FORMAT('NR3,NC3 = ',2I8) 20144 CALL DPWRST('XXX','BUG ') 20145 IF(NR3.GE.1 .AND. NC3.GE.1)THEN 20146 JMAX=NC3 20147 IF(JMAX.GT.10)JMAX=10 20148 DO82I=1,NR3 20149 WRITE(ICOUT,83)I,(YM9(I,J),J=1,JMAX) 20150 83 FORMAT('I,YM9(I,.) = ',I8,10E10.3) 20151 CALL DPWRST('XXX','BUG ') 20152 82 CONTINUE 20153 ENDIF 20154C 20155 WRITE(ICOUT,999) 20156 CALL DPWRST('XXX','BUG ') 20157 WRITE(ICOUT,111)N1 20158 111 FORMAT('N1 = ',I8) 20159 CALL DPWRST('XXX','BUG ') 20160 IF(N1.GE.1)THEN 20161 DO112I=1,N1 20162 WRITE(ICOUT,113)I,Y1(I) 20163 113 FORMAT('I,Y1(I) = ',I8,E15.7) 20164 CALL DPWRST('XXX','BUG ') 20165 112 CONTINUE 20166 ENDIF 20167C 20168 WRITE(ICOUT,999) 20169 CALL DPWRST('XXX','BUG ') 20170 WRITE(ICOUT,121)N2 20171 121 FORMAT('N2 = ',I8) 20172 CALL DPWRST('XXX','BUG ') 20173 IF(N2.GE.1)THEN 20174 DO122I=1,N2 20175 WRITE(ICOUT,123)I,Y2(I) 20176 123 FORMAT('I,Y2(I) = ',I8,E15.7) 20177 CALL DPWRST('XXX','BUG ') 20178 122 CONTINUE 20179 ENDIF 20180C 20181 WRITE(ICOUT,999) 20182 CALL DPWRST('XXX','BUG ') 20183 WRITE(ICOUT,131)N3 20184 131 FORMAT('N3 = ',I8) 20185 CALL DPWRST('XXX','BUG ') 20186 IF(N3.GE.1)THEN 20187 DO132I=1,N3 20188 WRITE(ICOUT,133)I,Y3(I) 20189 133 FORMAT('I,Y3(I) = ',I8,E15.7) 20190 CALL DPWRST('XXX','BUG ') 20191 132 CONTINUE 20192 ENDIF 20193C 20194 WRITE(ICOUT,999) 20195 CALL DPWRST('XXX','BUG ') 20196 WRITE(ICOUT,141)N4 20197 141 FORMAT('N4 = ',I8) 20198 CALL DPWRST('XXX','BUG ') 20199 IF(N4.GE.1)THEN 20200 DO142I=1,N4 20201 WRITE(ICOUT,143)I,Y4(I) 20202 143 FORMAT('I,Y4(I) = ',I8,E15.7) 20203 CALL DPWRST('XXX','BUG ') 20204 142 CONTINUE 20205 ENDIF 20206C 20207 ENDIF 20208C 20209C ************************************************** 20210C ** CARRY OUT MATRIX ARITHMETIC OPERATIONS ** 20211C ************************************************** 20212C 20213 DNR1=NR1 20214 DNC1=NC1 20215C 20216C ******************************************** 20217C ** STEP 11-- ** 20218C ** CHECK NUMBER OF INPUT OBSERVATIONS. ** 20219C ******************************************** 20220C 20221 IF(IMCASE.EQ.'CRMA')GOTO8500 20222 IF(IMCASE.EQ.'GMST')GOTO8550 20223 IF(IMCASE.EQ.'CORE')GOTO10800 20224 IF(IMCASE.EQ.'CONF')GOTO10900 20225 IF(IMCASE.EQ.'CKCL')GOTO11000 20226 IF(IMCASE.EQ.'CKCP')GOTO11100 20227 IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1.AND.NR1.LE.0)GOTO1100 20228 IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1.AND.NC1.LE.0)GOTO1100 20229 IF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2.AND.NR2.LE.0)GOTO1100 20230 IF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2.AND.NC2.LE.0)GOTO1100 20231 IF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3.AND.NR3.LE.0)GOTO1100 20232 IF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3.AND.NC3.LE.0)GOTO1100 20233C 20234 IF(ITYPA1.EQ.'VARI'.AND.NUMVAR.GE.1.AND.N1.LE.0)GOTO1100 20235 IF(ITYPA2.EQ.'VARI'.AND.NUMVAR.GE.2.AND.N2.LE.0)GOTO1100 20236 IF(ITYPA3.EQ.'VARI'.AND.NUMVAR.GE.3.AND.N3.LE.0)GOTO1100 20237C 20238 GOTO1190 20239C 20240 1100 CONTINUE 20241 IERROR='YES' 20242 WRITE(ICOUT,999) 20243 CALL DPWRST('XXX','BUG ') 20244 WRITE(ICOUT,1111) 20245 1111 FORMAT('***** ERROR IN MATAR3--') 20246 CALL DPWRST('XXX','BUG ') 20247 WRITE(ICOUT,1112) 20248 1112 FORMAT(' THE INPUT NUMBER OF ROWS AND/OR COLUMNS IN THE') 20249 CALL DPWRST('XXX','BUG ') 20250 WRITE(ICOUT,1113) 20251 1113 FORMAT(' MATRIX AND/OR VECTOR FOR WHICH THE MATRIX') 20252 CALL DPWRST('XXX','BUG ') 20253 WRITE(ICOUT,1121) 20254 1121 FORMAT(' OPERATION IS TO BE COMPUTED MUST BE 1 OR') 20255 WRITE(ICOUT,1182) 20256 1182 FORMAT(' LARGER; SUCH WAS NOT THE CASE HERE.') 20257 CALL DPWRST('XXX','BUG ') 20258C 20259 IF(ITYPA1.EQ.'MATR'.AND.NUMVAR.GE.1)THEN 20260 WRITE(ICOUT,1183)NR1,NC1 20261 1183 FORMAT(' MATRIX 1--',I8,' ROWS BY ',I8,' COLUMNS') 20262 CALL DPWRST('XXX','BUG ') 20263 ELSEIF(ITYPA2.EQ.'MATR'.AND.NUMVAR.GE.2)THEN 20264 WRITE(ICOUT,1184)NR2,NC2 20265 1184 FORMAT(' MATRIX 2--',I8,' ROWS BY ',I8,' COLUMNS') 20266 CALL DPWRST('XXX','BUG ') 20267 ELSEIF(ITYPA3.EQ.'MATR'.AND.NUMVAR.GE.3)THEN 20268 WRITE(ICOUT,1185)NR3,NC3 20269 1185 FORMAT(' MATRIX 3--',I8,' ROWS BY ',I8,' COLUMNS') 20270 CALL DPWRST('XXX','BUG ') 20271 ELSEIF(ITYPA1.EQ.'VARI'.AND.NUMVAR.GE.1)THEN 20272 WRITE(ICOUT,1186)N1 20273 1186 FORMAT(' VECTOR 1--',I8,' ROWS') 20274 CALL DPWRST('XXX','BUG ') 20275 ELSEIF(ITYPA2.EQ.'VARI'.AND.NUMVAR.GE.2)THEN 20276 WRITE(ICOUT,1187)N2 20277 1187 FORMAT(' VECTOR 2--',I8,' ROWS') 20278 CALL DPWRST('XXX','BUG ') 20279 ELSEIF(ITYPA3.EQ.'VARI'.AND.NUMVAR.GE.3)THEN 20280 WRITE(ICOUT,1188)N3 20281 1188 FORMAT(' VECTOR 3--',I8,' ROWS') 20282 CALL DPWRST('XXX','BUG ') 20283 ENDIF 20284 GOTO9000 20285C 20286 1190 CONTINUE 20287C 20288C ********************************* 20289C ** STEP 12-- ** 20290C ** BRANCH TO THE PROPER CASE ** 20291C ********************************* 20292C 20293 IF(IMCASE.EQ.'MPVC')GOTO5600 20294 IF(IMCASE.EQ.'MQFO')GOTO5800 20295 IF(IMCASE.EQ.'MHT1')GOTO5900 20296 IF(IMCASE.EQ.'MHT2')GOTO5700 20297 IF(IMCASE.EQ.'MROW')GOTO6000 20298 IF(IMCASE.EQ.'MCOL')GOTO6100 20299C 20300 IF(IMCASE.EQ.'MDER')THEN 20301 ICASE='ROW ' 20302 GOTO6200 20303 ENDIF 20304 IF(IMCASE.EQ.'MDEC')THEN 20305 ICASE='COLU' 20306 GOTO6200 20307 ENDIF 20308C 20309 IF(IMCASE.EQ.'MDKR')THEN 20310 ICASE='ROW ' 20311 GOTO6200 20312 ENDIF 20313 IF(IMCASE.EQ.'MDKC')THEN 20314 ICASE='COLU' 20315 GOTO6200 20316 ENDIF 20317C 20318 IF(IMCASE.EQ.'MDBR')THEN 20319 ICASE='ROW ' 20320 GOTO6200 20321 ENDIF 20322 IF(IMCASE.EQ.'MDBC')THEN 20323 ICASE='COLU' 20324 GOTO6200 20325 ENDIF 20326C 20327 IF(IMCASE.EQ.'MDCR')THEN 20328 ICASE='ROW ' 20329 GOTO6200 20330 ENDIF 20331 IF(IMCASE.EQ.'MDCC')THEN 20332 ICASE='COLU' 20333 GOTO6200 20334 ENDIF 20335C 20336 IF(IMCASE.EQ.'MCSR')THEN 20337 ICASE='ROW ' 20338 GOTO6200 20339 ENDIF 20340 IF(IMCASE.EQ.'MCSC')THEN 20341 ICASE='COLU' 20342 GOTO6200 20343 ENDIF 20344C 20345 IF(IMCASE.EQ.'MCDR')THEN 20346 ICASE='ROW ' 20347 GOTO6200 20348 ENDIF 20349 IF(IMCASE.EQ.'MCDC')THEN 20350 ICASE='COLU' 20351 GOTO6200 20352 ENDIF 20353C 20354 IF(IMCASE.EQ.'MZSR')THEN 20355 ICASE='ROW ' 20356 GOTO6200 20357 ENDIF 20358 IF(IMCASE.EQ.'MASC')THEN 20359 ICASE='COLU' 20360 GOTO6200 20361 ENDIF 20362C 20363 IF(IMCASE.EQ.'MZDR')THEN 20364 ICASE='ROW ' 20365 GOTO6200 20366 ENDIF 20367 IF(IMCASE.EQ.'MADC')THEN 20368 ICASE='COLU' 20369 GOTO6200 20370 ENDIF 20371C 20372 IF(IMCASE.EQ.'MJSR')THEN 20373 ICASE='ROW ' 20374 GOTO6200 20375 ENDIF 20376 IF(IMCASE.EQ.'MJSC')THEN 20377 ICASE='COLU' 20378 GOTO6200 20379 ENDIF 20380C 20381 IF(IMCASE.EQ.'MJDR')THEN 20382 ICASE='ROW ' 20383 GOTO6200 20384 ENDIF 20385 IF(IMCASE.EQ.'MJDC')THEN 20386 ICASE='COLU' 20387 GOTO6200 20388 ENDIF 20389C 20390 IF(IMCASE.EQ.'MPDR')THEN 20391 ICASE='ROW ' 20392 GOTO6200 20393 ENDIF 20394 IF(IMCASE.EQ.'MPDC')THEN 20395 ICASE='COLU' 20396 GOTO6200 20397 ENDIF 20398C 20399 IF(IMCASE.EQ.'MHDR')THEN 20400 ICASE='ROW ' 20401 GOTO6200 20402 ENDIF 20403 IF(IMCASE.EQ.'MHDC')THEN 20404 ICASE='COLU' 20405 GOTO6200 20406 ENDIF 20407C 20408 IF(IMCASE.EQ.'MXDR')THEN 20409 ICASE='ROW ' 20410 GOTO6200 20411 ENDIF 20412 IF(IMCASE.EQ.'MXDC')THEN 20413 ICASE='COLU' 20414 GOTO6200 20415 ENDIF 20416C 20417 IF(IMCASE.EQ.'MRSC')THEN 20418 ICASE='ROW ' 20419 GOTO6500 20420 ENDIF 20421 IF(IMCASE.EQ.'MCSC')THEN 20422 ICASE='COLU' 20423 GOTO6500 20424 ENDIF 20425C 20426 IF(IMCASE.EQ.'MDMR')THEN 20427 ICASE='ROW ' 20428 GOTO6600 20429 ENDIF 20430 IF(IMCASE.EQ.'MDMC')THEN 20431 ICASE='COLU' 20432 GOTO6600 20433 ENDIF 20434C 20435 IF(IMCASE.EQ.'MQRD')GOTO6300 20436 IF(IMCASE.EQ.'MPIN')GOTO6400 20437 IF(IMCASE.EQ.'MAMM')GOTO7000 20438 IF(IMCASE.EQ.'MSUM')GOTO7030 20439 IF(IMCASE.EQ.'MAAR')GOTO7100 20440 IF(IMCASE.EQ.'MADR')GOTO7200 20441 IF(IMCASE.EQ.'MADM')GOTO7300 20442 IF(IMCASE.EQ.'MALC')GOTO7400 20443 IF(IMCASE.EQ.'MAVT')GOTO7500 20444 IF(IMCASE.EQ.'MAGM')GOTO7600 20445 IF(IMCASE.EQ.'MAGS')GOTO7700 20446 IF(IMCASE.EQ.'MVRN')GOTO7800 20447 IF(IMCASE.EQ.'MURN')GOTO7900 20448 IF(IMCASE.EQ.'MPDF')GOTO7950 20449 IF(IMCASE.EQ.'WIRN')GOTO8000 20450 IF(IMCASE.EQ.'MACA')GOTO8100 20451 IF(IMCASE.EQ.'XTXI')GOTO8200 20452 IF(IMCASE.EQ.'VINF')GOTO8300 20453 IF(IMCASE.EQ.'CIND')GOTO8400 20454 IF(IMCASE.EQ.'CRMA')GOTO8500 20455 IF(IMCASE.EQ.'GMST')GOTO8550 20456 IF(IMCASE.EQ.'IURN')GOTO8600 20457 IF(IMCASE.EQ.'NCDF')GOTO8700 20458 IF(IMCASE.EQ.'TCDF')GOTO8800 20459 IF(IMCASE.EQ.'TCDF')GOTO8800 20460 IF(IMCASE.EQ.'MTRN')GOTO8900 20461 IF(IMCASE.EQ.'DIRN')GOTO8950 20462 IF(IMCASE.EQ.'DPDF')GOTO9300 20463 IF(IMCASE.EQ.'DLPD')GOTO9300 20464 IF(IMCASE.EQ.'INRN')GOTO9400 20465 IF(IMCASE.EQ.'MPAR')GOTO9500 20466 IF(IMCASE.EQ.'MGRA')GOTO9600 20467 IF(IMCASE.EQ.'MATB')GOTO9700 20468 IF(IMCASE.EQ.'MARB')GOTO9700 20469 IF(IMCASE.EQ.'MSPT')GOTO9800 20470 IF(IMCASE.EQ.'MSP2')GOTO9900 20471 IF(IMCASE.EQ.'MARN')GOTO10000 20472 IF(IMCASE.EQ.'ADMA')GOTO10100 20473 IF(IMCASE.EQ.'ADMD')GOTO10100 20474 IF(IMCASE.EQ.'MFTR')GOTO10200 20475 IF(IMCASE.EQ.'MFTC')GOTO10300 20476 IF(IMCASE.EQ.'VMAT')GOTO10400 20477 IF(IMCASE.EQ.'MVAR')GOTO10500 20478 IF(IMCASE.EQ.'MCRO')GOTO10600 20479 IF(IMCASE.EQ.'MCCO')GOTO10700 20480C 20481 WRITE(ICOUT,999) 20482 CALL DPWRST('XXX','BUG ') 20483 WRITE(ICOUT,1211) 20484 1211 FORMAT('***** INTERNAL ERROR IN MATAR3--') 20485 CALL DPWRST('XXX','BUG ') 20486 WRITE(ICOUT,1212)IMCASE 20487 1212 FORMAT(' IMCASE NOT MATCHED. IMCASE = ',A4) 20488 CALL DPWRST('XXX','BUG ') 20489 IERROR='YES' 20490 GOTO9000 20491C 20492C ******************************************************* 20493C ** STEP 56-- ** 20494C ** TREAT THE POOLED VARIANCE-COVARIANCE MATRIX CASE** 20495C ******************************************************* 20496C 20497 5600 CONTINUE 20498C 20499 IF(ITYPA2.EQ.'VARI')GOTO5650 20500C 20501 IF(NC1.EQ.NC2)GOTO5609 20502 WRITE(ICOUT,999) 20503 CALL DPWRST('XXX','BUG ') 20504 WRITE(ICOUT,5601) 20505 5601 FORMAT('***** ERROR IN MATARI--') 20506 CALL DPWRST('XXX','BUG ') 20507 WRITE(ICOUT,5602) 20508 5602 FORMAT(' FOR THE POOLED VARIANCE-COVARIANCE COMMAND,') 20509 CALL DPWRST('XXX','BUG ') 20510 WRITE(ICOUT,5603) 20511 5603 FORMAT(' THE NUMBER OF COLUMNS FOR THE TWO MATRICES') 20512 CALL DPWRST('XXX','BUG ') 20513 WRITE(ICOUT,5604) 20514 5604 FORMAT(' MUST BE EQUAL.') 20515 CALL DPWRST('XXX','BUG ') 20516 WRITE(ICOUT,5606) 20517 5606 FORMAT(' SUCH WAS NOT THE CASE HERE.') 20518 CALL DPWRST('XXX','BUG ') 20519 WRITE(ICOUT,5607)NC1 20520 5607 FORMAT(' NUMBER OF COLUMNS FOR MATRIX 1 =',I8) 20521 CALL DPWRST('XXX','BUG ') 20522 WRITE(ICOUT,5608)NC2 20523 5608 FORMAT(' NUMBER OF COLUMNS FOR MATRIX 2 =',I8) 20524 CALL DPWRST('XXX','BUG ') 20525 IERROR='YES' 20526 GOTO9000 20527 5609 CONTINUE 20528C 20529 CALL VARPOO(YM1,YM2,YM9,MAXROM,MAXCOM,NR1,NC1,NR2, 20530 1DTEMP1,IBUGA3,IERROR) 20531C 20532 ITYP9='MATR' 20533 NR9=NC1 20534 NC9=NC1 20535 IUPFLG='FULL' 20536 GOTO9000 20537C 20538 5650 CONTINUE 20539C 20540 IF(NR1.EQ.N2)GOTO5659 20541 WRITE(ICOUT,999) 20542 CALL DPWRST('XXX','BUG ') 20543 WRITE(ICOUT,5651) 20544 5651 FORMAT('***** ERROR IN MATARI--') 20545 CALL DPWRST('XXX','BUG ') 20546 WRITE(ICOUT,5652) 20547 5652 FORMAT(' FOR THE POOLED VARIANCE-COVARIANCE COMMAND,') 20548 CALL DPWRST('XXX','BUG ') 20549 WRITE(ICOUT,5653) 20550 5653 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX') 20551 CALL DPWRST('XXX','BUG ') 20552 WRITE(ICOUT,5654) 20553 5654 FORMAT(' MUST EQUAL THE NUMBER OF ROWS IN THE GROUP-ID ', 20554 1'VARIABLE..') 20555 CALL DPWRST('XXX','BUG ') 20556 WRITE(ICOUT,5656) 20557 5656 FORMAT(' SUCH WAS NOT THE CASE HERE.') 20558 CALL DPWRST('XXX','BUG ') 20559 WRITE(ICOUT,5657)NC1 20560 5657 FORMAT(' NUMBER OF ROWS FOR MATRIX =',I8) 20561 CALL DPWRST('XXX','BUG ') 20562 WRITE(ICOUT,5658)NC2 20563 5658 FORMAT(' NUMBER OF ROWS FOR GROUP ID VARIABLE =',I8) 20564 CALL DPWRST('XXX','BUG ') 20565 IERROR='YES' 20566 GOTO9000 20567 5659 CONTINUE 20568C 20569 CALL VARPO2(YM1,YM2,YM9,MAXROM,MAXCOM,NR1,NC1,MAXROM, 20570 1Y2,Y3,INDEX,NK,DTEMP1,IBUGA3,IERROR) 20571C 20572 ITYP9='MATR' 20573 NR9=NC1 20574 NC9=NC1 20575 IUPFLG='FULL' 20576 GOTO9000 20577C 20578C ******************************************************* 20579C ** STEP 57-- ** 20580C ** TREAT THE MATRIX 2-SAMPLE HOTELLING T-SQUARE CASE** 20581C ******************************************************* 20582C 20583 5700 CONTINUE 20584C 20585 IF(NC1.EQ.NC2)GOTO5709 20586 WRITE(ICOUT,999) 20587 CALL DPWRST('XXX','BUG ') 20588 WRITE(ICOUT,5701) 20589 5701 FORMAT('***** ERROR IN MATARI--') 20590 CALL DPWRST('XXX','BUG ') 20591 WRITE(ICOUT,5702) 20592 5702 FORMAT(' FOR THE 2-SAMPLE HOTELLING T-SQUARE TEST,') 20593 CALL DPWRST('XXX','BUG ') 20594 WRITE(ICOUT,5703) 20595 5703 FORMAT(' THE NUMBER OF COLUMNS FOR THE TWO MATRICES') 20596 CALL DPWRST('XXX','BUG ') 20597 WRITE(ICOUT,5704) 20598 5704 FORMAT(' MUST BE EQUAL.') 20599 CALL DPWRST('XXX','BUG ') 20600 WRITE(ICOUT,5706) 20601 5706 FORMAT(' SUCH WAS NOT THE CASE HERE.') 20602 CALL DPWRST('XXX','BUG ') 20603 WRITE(ICOUT,5707)NC1 20604 5707 FORMAT(' NUMBER OF COLUMNS FOR MATRIX 1 =',I8) 20605 CALL DPWRST('XXX','BUG ') 20606 WRITE(ICOUT,5708)NC2 20607 5708 FORMAT(' NUMBER OF COLUMNS FOR MATRIX 2 =',I8) 20608 CALL DPWRST('XXX','BUG ') 20609 IERROR='YES' 20610 GOTO9000 20611 5709 CONTINUE 20612C 20613 CALL HTTSQ2(YM1,YM2,YM9,MAXROM,MAXCOM,NR1,NR2,NC1, 20614 1TSTAT,ASIG90,ASIG95,ASIG99,ASG995, 20615 1DTEMP1,Y1,Y2,Y3,INDEX, 20616 1IBUGA3,IERROR) 20617C 20618 SCAL9=TSTAT 20619 ITYP9='SCAL' 20620 NR9=1 20621 NC9=1 20622 IUPFLG='FULL' 20623 GOTO9000 20624C 20625C ************************************************ 20626C ** STEP 58-- ** 20627C ** TREAT THE MATRIX QUADRATIC FORM CASE ** 20628C ** QUADRATIC FORM = x'Mx ** 20629C ** x IS A VECTOR AND M IS A MATRIX ** 20630C ************************************************ 20631C 20632 5800 CONTINUE 20633C 20634 IF(NR1.EQ.NC1)GOTO5809 20635 WRITE(ICOUT,999) 20636 CALL DPWRST('XXX','BUG ') 20637 WRITE(ICOUT,5801) 20638 5801 FORMAT('***** ERROR IN MATARI--') 20639 CALL DPWRST('XXX','BUG ') 20640 WRITE(ICOUT,5802) 20641 5802 FORMAT(' FOR QUADRATIC FORM,') 20642 CALL DPWRST('XXX','BUG ') 20643 WRITE(ICOUT,5803) 20644 5803 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX') 20645 CALL DPWRST('XXX','BUG ') 20646 WRITE(ICOUT,5804) 20647 5804 FORMAT(' MUST EQUAL') 20648 CALL DPWRST('XXX','BUG ') 20649 WRITE(ICOUT,5805) 20650 5805 FORMAT(' THE NUMBER OF COLUMNS IN THE MATRIX;') 20651 CALL DPWRST('XXX','BUG ') 20652 WRITE(ICOUT,5806) 20653 5806 FORMAT(' SUCH WAS NOT THE CASE HERE.') 20654 CALL DPWRST('XXX','BUG ') 20655 WRITE(ICOUT,5807)NR1 20656 5807 FORMAT(' NUMBER OF ROWS =',I8) 20657 CALL DPWRST('XXX','BUG ') 20658 WRITE(ICOUT,5808)NC1 20659 5808 FORMAT(' NUMBER OF COLUMNS =',I8) 20660 CALL DPWRST('XXX','BUG ') 20661 IERROR='YES' 20662 GOTO9000 20663 5809 CONTINUE 20664C 20665 IF(N2.EQ.NR1)GOTO5859 20666 WRITE(ICOUT,999) 20667 CALL DPWRST('XXX','BUG ') 20668 WRITE(ICOUT,5851) 20669 5851 FORMAT('***** ERROR IN MATARI--') 20670 CALL DPWRST('XXX','BUG ') 20671 WRITE(ICOUT,5852) 20672 5852 FORMAT(' FOR QUADRATIC FORM, THE NUMBER OF ROWS IN THE') 20673 CALL DPWRST('XXX','BUG ') 20674 WRITE(ICOUT,5855) 20675 5855 FORMAT(' MATRIX MUST = NUMBER OF ROWS IN THE VECTOR') 20676 CALL DPWRST('XXX','BUG ') 20677 WRITE(ICOUT,5856) 20678 5856 FORMAT(' SUCH WAS NOT THE CASE HERE.') 20679 CALL DPWRST('XXX','BUG ') 20680 WRITE(ICOUT,5858)NR1,N1 20681 5858 FORMAT(' MATRIX --',I8,' ROWS, VECTOR ',I8,' COLUMNS') 20682 CALL DPWRST('XXX','BUG ') 20683 IERROR='YES' 20684 GOTO9000 20685 5859 CONTINUE 20686C 20687 CALL QUAFRM(YM1,MAXROM,MAXCOM,NR1,NC1,Y2,IWRITE,SCAL9, 20688 1IBUGA3,IERROR) 20689C 20690 ITYP9='SCAL' 20691 NR9=1 20692 NC9=1 20693 IUPFLG='FULL' 20694 GOTO9000 20695C 20696C ******************************************************* 20697C ** STEP 59-- ** 20698C ** TREAT THE MATRIX 1-SAMPLE HOTELLING T-SQUARE CASE** 20699C ** H0: U=U0 ** 20700C ** T-SQUARE = N*(XBAR-U0)'*SINV*(XBAR-U0) ** 20701C ** WHERE SINV = SAMPLE VARIANCE-COVARIANCE MATRIX ** 20702C ******************************************************* 20703C 20704 5900 CONTINUE 20705C 20706 IF(NC1.EQ.N2)GOTO5909 20707 WRITE(ICOUT,999) 20708 CALL DPWRST('XXX','BUG ') 20709 WRITE(ICOUT,5901) 20710 5901 FORMAT('***** ERROR IN MATARI--') 20711 CALL DPWRST('XXX','BUG ') 20712 WRITE(ICOUT,5902) 20713 5902 FORMAT(' FOR THE 1-SAMPLE HOTELLING T-SQUARE TEST,') 20714 CALL DPWRST('XXX','BUG ') 20715 WRITE(ICOUT,5903) 20716 5903 FORMAT(' THE NUMBER OF COLUMNS IN THE MATRIX') 20717 CALL DPWRST('XXX','BUG ') 20718 WRITE(ICOUT,5904) 20719 5904 FORMAT(' MUST EQUAL') 20720 CALL DPWRST('XXX','BUG ') 20721 WRITE(ICOUT,5905) 20722 5905 FORMAT(' THE NUMBER OF ROWS IN THE MEAN VECTOR;') 20723 CALL DPWRST('XXX','BUG ') 20724 WRITE(ICOUT,5906) 20725 5906 FORMAT(' SUCH WAS NOT THE CASE HERE.') 20726 CALL DPWRST('XXX','BUG ') 20727 WRITE(ICOUT,5907)NC1 20728 5907 FORMAT(' NUMBER OF COLUMNS FOR MATRIX =',I8) 20729 CALL DPWRST('XXX','BUG ') 20730 WRITE(ICOUT,5908)N2 20731 5908 FORMAT(' NUMBER OF ROWS FOR MEAN VECTOR =',I8) 20732 CALL DPWRST('XXX','BUG ') 20733 IERROR='YES' 20734 GOTO9000 20735 5909 CONTINUE 20736C 20737 CALL HTTSQ1(YM1,YM2,MAXROM,MAXCOM,NR1,NC1, 20738 1TSTAT,ASIG90,ASIG95,ASIG99,ASG995, 20739 1DTEMP1,Y2,Y1,Y3,INDEX, 20740 1IBUGA3,IERROR) 20741C 20742 SCAL9=TSTAT 20743 ITYP9='SCAL' 20744 NR9=1 20745 NC9=1 20746 IUPFLG='FULL' 20747 GOTO9000 20748C 20749C ************************************************ 20750C ** STEP 60-- ** 20751C ** TREAT THE MATRIX ROW STATISTIC CASE ** 20752C ************************************************ 20753C 20754CCCCC IMPLEMENTED JULY 1993. 20755 6000 CONTINUE 20756C 20757 IWRITE='OFF' 20758 MAXNXT=MAXOBV 20759 IF(ICASS7.EQ.'INTE')NUMV2=1 20760C 20761 DO6010I=1,NR1 20762 DO6015J=1,NC1 20763 Y1(J)=YM1(I,J) 20764 6015 CONTINUE 20765 ASTAT=0.0 20766 CALL CMPSTA( 20767 1 Y1,Y2,Y2,Y3,Y4,Y5,MAXNXT,NC1,NC1,NC1,NUMV2,ICASS7, 20768 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 20769 1 DTEMP1,DTEMP2,DTEMP3, 20770CCCCC1 IQUAME,IQUASE,PSTAMV, 20771 1 ASTAT, 20772 1 ISUBRO,IBUGA3,IERROR) 20773 VECT9(I)=ASTAT 20774 6010 CONTINUE 20775C 20776 ITYP9='VECT' 20777 NR9=1 20778 NC9=1 20779 NVECT9=NR1 20780 IUPFLG='SUBS' 20781 GOTO9000 20782C 20783C ***************************************************** 20784C ** STEP 61-- ** 20785C ** TREAT THE MATRIX COLUMN STATISTIC CASE ** 20786C ***************************************************** 20787C 20788 6100 CONTINUE 20789C 20790 IWRITE='OFF' 20791 MAXNXT=MAXOBV 20792 IF(ICASS7.EQ.'INTE')NUMV2=1 20793C 20794 DO6110I=1,NC1 20795 DO6115J=1,NR1 20796 Y1(J)=YM1(J,I) 20797 6115 CONTINUE 20798 ASTAT=0.0 20799 CALL CMPSTA( 20800 1 Y1,Y2,Y2,Y3,Y4,Y5,MAXNXT,NR1,NR1,NR1,NUMV2,ICASS7, 20801 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 20802 1 DTEMP1,DTEMP2,DTEMP3, 20803CCCCC1 IQUAME,IQUASE,PSTAMV, 20804 1 ASTAT, 20805 1 ISUBRO,IBUGA3,IERROR) 20806 VECT9(I)=ASTAT 20807 6110 CONTINUE 20808C 20809 ITYP9='VECT' 20810 NR9=1 20811 NC9=1 20812 NVECT9=NC1 20813 IUPFLG='FULL' 20814 GOTO9000 20815C 20816C ***************************************************** 20817C ** STEP 62-- ** 20818C ** TREAT THE MATRIX EUCLIDEAN DISTANCE CASE ** 20819C ** MATRIX CHEBYCHEV DISTANCE CASE ** 20820C ** MATRIX MINKOWSKY DISTANCE CASE ** 20821C ** MATRIX BLOCK DISTANCE CASE ** 20822C ** MATRIX COSINE DISTANCE CASE ** 20823C ** MATRIX COSINE SIMILARITY CASE ** 20824C ** MATRIX JACCARD DISTANCE CASE ** 20825C ** MATRIX JACCARD SIMILARITY CASE ** 20826C ***************************************************** 20827C 20828 6200 CONTINUE 20829C 20830 IF(ICASE.EQ.'ROW '.AND.NR1.GT.MAXCOM)THEN 20831 WRITE(ICOUT,999) 20832 CALL DPWRST('XXX','BUG ') 20833 WRITE(ICOUT,6211) 20834 6211 FORMAT('***** ERROR IN MATAR3--') 20835 CALL DPWRST('XXX','BUG ') 20836 WRITE(ICOUT,6213) 20837 6213 FORMAT(' FOR MATRIX ROW DISTANCES, THE NUMBER OF ') 20838 CALL DPWRST('XXX','BUG ') 20839 WRITE(ICOUT,6215)NR1 20840 6215 FORMAT(' CREATED COLUMNS, ',I8,', WOULD EXCEED THE ') 20841 CALL DPWRST('XXX','BUG ') 20842 WRITE(ICOUT,6217)MAXCOM 20843 6217 FORMAT(' MAXIMUM NUMBER OF ALLOWED COLUMNS, ',I8,'.') 20844 CALL DPWRST('XXX','BUG ') 20845 IERROR='YES' 20846 GOTO9000 20847 ENDIF 20848C 20849 IWRITE='OFF' 20850 ICASE2='EUCL' 20851 IF(IMCASE(1:3).EQ.'MDK')ICASE2='MINK' 20852 IF(IMCASE(1:3).EQ.'MDB')ICASE2='BLOC' 20853 IF(IMCASE(1:3).EQ.'MDC')ICASE2='CHEB' 20854 IF(IMCASE(1:3).EQ.'MCS')ICASE2='COSS' 20855 IF(IMCASE(1:3).EQ.'MCD')ICASE2='COSD' 20856 IF(IMCASE(1:3).EQ.'MJS')ICASE2='JACS' 20857 IF(IMCASE(1:3).EQ.'MJD')ICASE2='JACD' 20858 IF(IMCASE(1:4).EQ.'MZSR')ICASE2='ACSS' 20859 IF(IMCASE(1:4).EQ.'MASC')ICASE2='ACSS' 20860 IF(IMCASE(1:4).EQ.'MZDR')ICASE2='ACSD' 20861 IF(IMCASE(1:4).EQ.'MADC')ICASE2='ACSD' 20862 IF(IMCASE(1:3).EQ.'MPD')ICASE2='PDIS' 20863 IF(IMCASE(1:3).EQ.'MPS')ICASE2='PSIM' 20864 IF(IMCASE(1:3).EQ.'MHD')ICASE2='HAMM' 20865 IF(IMCASE(1:3).EQ.'MXD')ICASE2='CANB' 20866C 20867 CALL EUCDIS(YM1,YM9,MAXROM,MAXCOM,NR1,NC1, 20868 1 ICASE,ICASE2,P,IWRITE, 20869 1 Y1,Y2, 20870 1 IBUGA3,ISUBRO,IERROR) 20871C 20872 ITYP9='MATR' 20873 IF(ICASE.EQ.'ROW')THEN 20874 NR9=NR1 20875 NC9=NR1 20876 IUPFLG='SUBS' 20877 ELSEIF(ICASE.EQ.'COLU')THEN 20878 NR9=NC1 20879 NC9=NC1 20880 IUPFLG='FULL' 20881 ELSE 20882 NR9=NR1 20883 NC9=NR1 20884 IUPFLG='SUBS' 20885 ENDIF 20886 GOTO9000 20887C 20888C ********************************************* 20889C ** STEP 63-- ** 20890C ** TREAT THE MATRIX QR DECOMP CASE ** 20891C ** REFERENCE--LINPACK USER'S GUIDE ** 20892C ********************************************* 20893C 20894 6300 CONTINUE 20895C 20896CCCCC IF(NR1.LE.MAXCOM)GOTO6309 20897CCCCC WRITE(ICOUT,999) 20898CCCCC CALL DPWRST('XXX','BUG ') 20899CCCCC WRITE(ICOUT,6301) 20900C6301 FORMAT('***** ERROR IN MATAR2--') 20901CCCCC CALL DPWRST('XXX','BUG ') 20902CCCCC WRITE(ICOUT,6302) 20903C6302 FORMAT(' FOR MATRIX SINGULAR VALUE DECOMPOSITION,') 20904CCCCC CALL DPWRST('XXX','BUG ') 20905CCCCC WRITE(ICOUT,6303) 20906C6303 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX') 20907CCCCC CALL DPWRST('XXX','BUG ') 20908CCCCC WRITE(ICOUT,6304) 20909C6304 FORMAT(' CAN NOT EXCEED ') 20910CCCCC CALL DPWRST('XXX','BUG ') 20911CCCCC WRITE(ICOUT,6305) 20912C6305 FORMAT(' THE MAXIMUM NUMBER OF COLUMNS IN THE MATRIX;') 20913CCCCC CALL DPWRST('XXX','BUG ') 20914CCCCC WRITE(ICOUT,6306) 20915C6306 FORMAT(' SUCH WAS NOT THE CASE HERE.') 20916CCCCC CALL DPWRST('XXX','BUG ') 20917CCCCC WRITE(ICOUT,6307)NR1 20918C6307 FORMAT(' NUMBER OF ROWS =',I8) 20919CCCCC CALL DPWRST('XXX','BUG ') 20920CCCCC WRITE(ICOUT,6308)MAXCOM 20921C6308 FORMAT(' MAXIMUM NUMBER OF COLUMNS =',I8) 20922CCCCC CALL DPWRST('XXX','BUG ') 20923CCCCC IERROR='YES' 20924CCCCC GOTO9000 20925C 20926C6309 CONTINUE 20927 DO6322J=1,MAXCOM 20928 DO6321I=1,MAXROM 20929 YM9(I,J)=0.0 20930 YM2(I,J)=0.0 20931 6321 CONTINUE 20932 6322 CONTINUE 20933C 20934 IERR2=0 20935 IJOB=11 20936 NTEMP1=NR1 20937 NTEMP2=NC1 20938 CALL SSVDC(YM1,MAXROM,NTEMP1,NTEMP2,VECT9,Y1,YM9,MAXROM, 20939 1YM2,MAXROM,Y2,IJOB,IERR2) 20940C 20941 ITYP9='MATR' 20942 MM=NR1 20943 IF(MM.GT.NC1)MM=NC1 20944 NR9=NR1 20945 NC9=NR1 20946 NR2=NC1 20947 NC2=NC1 20948 NVECT9=MM 20949 IUPFLG='FULL' 20950 GOTO9000 20951C 20952C ****************************************************** 20953C ** STEP 64-- ** 20954C ** TREAT THE MATRIX PSEUDO INVERSE CASE ** 20955C ****************************************************** 20956C 20957 6400 CONTINUE 20958C 20959 IF(NR1.LT.NC1)THEN 20960 WRITE(ICOUT,999) 20961 CALL DPWRST('XXX','BUG ') 20962 WRITE(ICOUT,6401) 20963 6401 FORMAT('***** ERROR IN PSEUDO INVERSE--') 20964 CALL DPWRST('XXX','BUG ') 20965 WRITE(ICOUT,6402) 20966 6402 FORMAT(' FOR THE MATRIX PSEUDO INVERSE, THE NUMBER OF') 20967 CALL DPWRST('XXX','BUG ') 20968 WRITE(ICOUT,6403) 20969 6403 FORMAT(' ROWS IN THE MATRIX MUST BE GREATER THAN OR') 20970 CALL DPWRST('XXX','BUG ') 20971 WRITE(ICOUT,6404) 20972 6404 FORMAT(' EQUAL TO THE NUMBER OF COLUMNS IN THE MATRIX;') 20973 CALL DPWRST('XXX','BUG ') 20974 WRITE(ICOUT,6406) 20975 6406 FORMAT(' SUCH WAS NOT THE CASE HERE.') 20976 CALL DPWRST('XXX','BUG ') 20977 WRITE(ICOUT,6407)NR1 20978 6407 FORMAT(' NUMBER OF ROWS =',I8) 20979 CALL DPWRST('XXX','BUG ') 20980 WRITE(ICOUT,6408)NC1 20981 6408 FORMAT(' NUMBER OF COLUMNS =',I8) 20982 CALL DPWRST('XXX','BUG ') 20983 IERROR='YES' 20984 GOTO9000 20985 ENDIF 20986C 20987 IF(NR1.GT.MAXROM)THEN 20988 WRITE(ICOUT,999) 20989 CALL DPWRST('XXX','BUG ') 20990 WRITE(ICOUT,6411) 20991 6411 FORMAT('***** ERROR IN PSEUDO INVERSE--') 20992 CALL DPWRST('XXX','BUG ') 20993 WRITE(ICOUT,6412) 20994 6412 FORMAT(' FOR THE MATRIX PSEUDO INVERSE, THE NUMBER OF') 20995 CALL DPWRST('XXX','BUG ') 20996 WRITE(ICOUT,6413) 20997 6413 FORMAT(' ROWS IN THE MATRIX EXCEEDS THE MAXIMUM') 20998 CALL DPWRST('XXX','BUG ') 20999 WRITE(ICOUT,6414) 21000 6414 FORMAT(' ALLOWABLE NUMBER OF ROWS.') 21001 CALL DPWRST('XXX','BUG ') 21002 WRITE(ICOUT,6417)NR1 21003 6417 FORMAT(' NUMBER OF ROWS = ',I8) 21004 CALL DPWRST('XXX','BUG ') 21005 WRITE(ICOUT,6418)MAXROM 21006 6418 FORMAT(' MAXIMUM NUMBER OF ROWS = ',I8) 21007 CALL DPWRST('XXX','BUG ') 21008 IERROR='YES' 21009 GOTO9000 21010 ENDIF 21011C 21012 IF(NC1.GT.MAXCOM)THEN 21013 WRITE(ICOUT,999) 21014 CALL DPWRST('XXX','BUG ') 21015 WRITE(ICOUT,6421) 21016 6421 FORMAT('***** ERROR IN PSEUDO INVERSE--') 21017 CALL DPWRST('XXX','BUG ') 21018 WRITE(ICOUT,6422) 21019 6422 FORMAT(' FOR THE MATRIX PSEUDO INVERSE, THE NUMBER OF') 21020 CALL DPWRST('XXX','BUG ') 21021 WRITE(ICOUT,6423) 21022 6423 FORMAT(' COLUMNS IN THE MATRIX EXCEEDS THE MAXIMUM') 21023 CALL DPWRST('XXX','BUG ') 21024 WRITE(ICOUT,6424) 21025 6424 FORMAT(' ALLOWABLE NUMBER OF COLUMNS.') 21026 CALL DPWRST('XXX','BUG ') 21027 WRITE(ICOUT,6427)NR1 21028 6427 FORMAT(' NUMBER OF COLUMNS = ',I8) 21029 CALL DPWRST('XXX','BUG ') 21030 WRITE(ICOUT,6428)MAXROM 21031 6428 FORMAT(' MAXIMUM NUMBER OF COLUMNS = ',I8) 21032 CALL DPWRST('XXX','BUG ') 21033 IERROR='YES' 21034 GOTO9000 21035 ENDIF 21036C 21037 KTEMP=0 21038 CALL MATMPI(YM1,Y1,Y2,Y3,YM2,NR1,NC1,MAXROM,MAXROM,KTEMP,IFLAG) 21039C 21040 IF(IFLAG.EQ.3)THEN 21041 WRITE(ICOUT,999) 21042 CALL DPWRST('XXX','BUG ') 21043 WRITE(ICOUT,6431) 21044 6431 FORMAT('***** ERROR IN PSEUDO INVERSE--') 21045 CALL DPWRST('XXX','BUG ') 21046 WRITE(ICOUT,6432) 21047 6432 FORMAT(' UNABLE TO COMPUTE THE SINGULAR VALUE') 21048 CALL DPWRST('XXX','BUG ') 21049 WRITE(ICOUT,6433) 21050 6433 FORMAT(' DECOMPOSITION, SO UNABLE TO COMPUTE THE') 21051 CALL DPWRST('XXX','BUG ') 21052 WRITE(ICOUT,6434) 21053 6434 FORMAT(' PSEUDO INVERSE.') 21054 CALL DPWRST('XXX','BUG ') 21055 IERROR='YES' 21056 GOTO9000 21057 ELSE 21058 DO6450J=1,NC1 21059 DO6460I=1,NR1 21060 YM9(I,J)=YM1(I,J) 21061 6460 CONTINUE 21062 6450 CONTINUE 21063 ENDIF 21064C 21065 ITYP9='MATR' 21066 NR9=NR1 21067 NC9=NC1 21068 IUPFLG='FULL' 21069 GOTO9000 21070C 21071C ***************************************************** 21072C ** STEP 65-- ** 21073C ** TREAT THE MATRIX SCALE CASE ** 21074C ***************************************************** 21075C 21076 6500 CONTINUE 21077C 21078 IWRITE='OFF' 21079 CALL MATSCA(YM1,YM9,MAXROM,MAXCOM,NR1,NC1,Y1,Y2,Y3, 21080 1IMATSC,ICASE,IWRITE, 21081 1IBUGA3,IERROR) 21082C 21083 ITYP9='MATR' 21084 NR9=NR1 21085 NC9=NC1 21086 IUPFLG='SUBS' 21087 GOTO9000 21088C 21089C ***************************************************** 21090C ** STEP 66-- ** 21091C ** TREAT THE MATRIX MAHALONOBIS DISTANCE CASE ** 21092C ***************************************************** 21093C 21094 6600 CONTINUE 21095C 21096 IF(ICASE.EQ.'ROW '.AND.NR1.GT.MAXCOM)THEN 21097 WRITE(ICOUT,999) 21098 CALL DPWRST('XXX','BUG ') 21099 WRITE(ICOUT,6611) 21100 6611 FORMAT('***** ERROR IN MATAR3--') 21101 CALL DPWRST('XXX','BUG ') 21102 WRITE(ICOUT,6613) 21103 6613 FORMAT(' FOR MAHALANOBIS ROW DISTANCES, THE NUMBER OF ') 21104 CALL DPWRST('XXX','BUG ') 21105 WRITE(ICOUT,6615)NR1 21106 6615 FORMAT(' CREATED COLUMNS, ',I8,', WOULD EXCEED THE ') 21107 CALL DPWRST('XXX','BUG ') 21108 WRITE(ICOUT,6617)MAXCOM 21109 6617 FORMAT(' MAXIMUM NUMBER OF ALLOWED COLUMNS, ',I8,'.') 21110 CALL DPWRST('XXX','BUG ') 21111 IERROR='YES' 21112 GOTO9000 21113 ENDIF 21114C 21115 IWRITE='OFF' 21116 CALL MAHDIS(YM1,YM2,YM9,MAXROM,MAXCOM,NR1,NC1, 21117 1Y1,Y2,INDEX,DTEMP1, 21118 1ICASE,IWRITE,IBUGA3,IERROR) 21119C 21120 ITYP9='MATR' 21121 IF(ICASE.EQ.'ROW')THEN 21122 NR9=NR1 21123 NC9=NR1 21124 IUPFLG='SUBS' 21125 ELSEIF(ICASE.EQ.'COLU')THEN 21126 NR9=NC1 21127 NC9=NC1 21128 IUPFLG='FULL' 21129 ELSE 21130 NR9=NR1 21131 NC9=NR1 21132 IUPFLG='SUBS' 21133 ENDIF 21134 GOTO9000 21135C 21136C ***************************************************** 21137C ** STEP 70-- ** 21138C ** TREAT THE MATRIX MEAN CASE ** 21139C ***************************************************** 21140C 21141 7000 CONTINUE 21142C 21143 ITYP9='SCAL' 21144 D999=0.0D0 21145 DO7010J=1,NC1 21146 DO7020I=1,NR1 21147 D999=D999+DBLE(YM1(I,J)) 21148 7020 CONTINUE 21149 7010 CONTINUE 21150 D999=D999/DBLE(NR1*NC1) 21151 SCAL9=REAL(D999) 21152 NR9=1 21153 NC9=1 21154 IUPFLG='FULL' 21155 GOTO9000 21156C 21157C ***************************************************** 21158C ** STEP 70.B-- ** 21159C ** TREAT THE MATRIX SUM CASE ** 21160C ***************************************************** 21161C 21162 7030 CONTINUE 21163C 21164 ITYP9='SCAL' 21165 D999=0.0D0 21166 DO7040J=1,NC1 21167 DO7050I=1,NR1 21168 D999=D999+DBLE(YM1(I,J)) 21169 7050 CONTINUE 21170 7040 CONTINUE 21171 SCAL9=REAL(D999) 21172 NR9=1 21173 NC9=1 21174 IUPFLG='FULL' 21175 GOTO9000 21176C 21177C ***************************************************** 21178C ** STEP 71-- ** 21179C ** TREAT THE MATRIX ADD ROW CASE ** 21180C ***************************************************** 21181C 21182 7100 CONTINUE 21183C 21184 IF(NC1.NE.N2)THEN 21185 WRITE(ICOUT,999) 21186 CALL DPWRST('XXX','BUG ') 21187 WRITE(ICOUT,7111) 21188 7111 FORMAT('***** ERROR IN MATAR3--') 21189 CALL DPWRST('XXX','BUG ') 21190 WRITE(ICOUT,7113) 21191 7113 FORMAT(' FOR MATRIX ADD ROW, THE NUMBER OF COLUMNS') 21192 CALL DPWRST('XXX','BUG ') 21193 WRITE(ICOUT,7115)NC1 21194 7115 FORMAT(' IN THE MATRIX, ',I8,', DOES NOT EQUAL THE') 21195 CALL DPWRST('XXX','BUG ') 21196 WRITE(ICOUT,7117)N2 21197 7117 FORMAT(' NUMBER OF ROWS IN THE VARIABLE, ',I8,'.') 21198 CALL DPWRST('XXX','BUG ') 21199 IERROR='YES' 21200 GOTO9000 21201 ENDIF 21202C 21203 DO7110J=1,NC1 21204 DO7120I=1,NR1 21205 YM9(I,J)=YM1(I,J) 21206 7120 CONTINUE 21207 YM9(NR1+1,J)=Y2(J) 21208 7110 CONTINUE 21209C 21210 ITYP9='MATR' 21211 NC9=NC1 21212 NR9=NR1+1 21213 IUPFLG='SUBS' 21214 GOTO9000 21215C ***************************************************** 21216C ** STEP 72-- ** 21217C ** TREAT THE MATRIX DELETE ROW CASE ** 21218C ***************************************************** 21219C 21220 7200 CONTINUE 21221C 21222 IYS2=INT(YS2+0.5) 21223 IF(IYS2.LT.1.OR.IYS2.GT.NR1)THEN 21224 WRITE(ICOUT,999) 21225 CALL DPWRST('XXX','BUG ') 21226 WRITE(ICOUT,7211) 21227 7211 FORMAT('***** ERROR IN MATAR3--') 21228 CALL DPWRST('XXX','BUG ') 21229 WRITE(ICOUT,7213) 21230 7213 FORMAT(' FOR MATRIX DELETE ROW, THE ROW TO BE ') 21231 CALL DPWRST('XXX','BUG ') 21232 WRITE(ICOUT,7215)IYS2 21233 7215 FORMAT(' DELETED IN THE MATRIX, ',I8,', MUST BE >=1') 21234 CALL DPWRST('XXX','BUG ') 21235 WRITE(ICOUT,7217)NR1 21236 7217 FORMAT(' AND <= ',I8,'.') 21237 CALL DPWRST('XXX','BUG ') 21238 IERROR='YES' 21239 GOTO9000 21240 ENDIF 21241C 21242 DO7210J=1,NC1 21243 ICOUNT=0 21244 DO7220I=1,NR1 21245 IF(IYS2.NE.I)THEN 21246 ICOUNT=ICOUNT+1 21247 YM9(ICOUNT,J)=YM1(I,J) 21248 ENDIF 21249 7220 CONTINUE 21250 7210 CONTINUE 21251C 21252 ITYP9='MATR' 21253 NC9=NC1 21254 NR9=NR1-1 21255 IUPFLG='SUBS' 21256 GOTO9000 21257C 21258C ***************************************************** 21259C ** STEP 73-- ** 21260C ** TREAT THE DISTANCE FROM MEAN CASE ** 21261C ***************************************************** 21262C 21263 7300 CONTINUE 21264C 21265 ICASE='COLU' 21266 CALL VARCOV(YM1,YM2,MAXROM,MAXCOM,NR1,NC1,DTEMP1, 21267 1 ICASE,IBUGA3,IERROR) 21268C 21269 CALL SGECO(YM2,MAXROM,NC1,INDEX,RCOND,Y1) 21270 EPS=1.0E-20 21271 IF(RCOND.LE.EPS)THEN 21272 WRITE(ICOUT,999) 21273 CALL DPWRST('XXX','BUG ') 21274 WRITE(ICOUT,7371) 21275 CALL DPWRST('XXX','ERRO ') 21276 WRITE(ICOUT,7372) 21277 CALL DPWRST('XXX','ERRO ') 21278 WRITE(ICOUT,7373) 21279 CALL DPWRST('XXX','ERRO ') 21280 IERROR='YES' 21281 GOTO9000 21282 ENDIF 21283 7371 FORMAT('*** ERROR FROM MATAR3: UNABLE TO COMPUTE THE INVERSE OF ', 21284 1 'THE COVARIANCE MATRIX.') 21285 7372 FORMAT(' PROBLEM: SOME COLUMNS ARE LINEARLY DEPDENDENT ON ', 21286 1 ' OTHER COLUMNS.') 21287 7373 FORMAT(' SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ', 21288 1 'ORIGINAL COLUMNS.') 21289C 21290 IJOB=1 21291 CALL SGEDI(YM2,MAXROM,NC1,INDEX,Y1,Y2,IJOB) 21292C 21293 IWRITE='OFF' 21294 DO7320I=1,NR1 21295 DO7330J=1,NC1 21296 Y3(J)=YM1(I,J)-REAL(DTEMP1(J)) 21297 7330 CONTINUE 21298 CALL QUAFRM(YM2,MAXROM,MAXCOM,NC1,NC1,Y3,IWRITE,SCAL9, 21299 1 IBUGA3,IERROR) 21300 VECT9(I)=SCAL9 21301 7320 CONTINUE 21302C 21303 ITYP9='VECT' 21304 NVECT9=NR1 21305 IUPFLG='SUBS' 21306 GOTO9000 21307C 21308C ***************************************************** 21309C ** STEP 74-- ** 21310C ** TREAT THE LINEAR COMBINATION CASE ** 21311C ***************************************************** 21312C 21313 7400 CONTINUE 21314C 21315 IF(N2.NE.NC1)THEN 21316 WRITE(ICOUT,999) 21317 CALL DPWRST('XXX','BUG ') 21318 WRITE(ICOUT,7411) 21319 7411 FORMAT('***** ERROR IN MATAR3--') 21320 CALL DPWRST('XXX','BUG ') 21321 WRITE(ICOUT,7413) 21322 7413 FORMAT(' FOR lINEAR COMBINATION, THE NUMER OF ROWS ') 21323 CALL DPWRST('XXX','BUG ') 21324 WRITE(ICOUT,7415)N2 21325 7415 FORMAT(' IN THE VECTOR, ',I8,' DOES NOT EQUAL THE ') 21326 CALL DPWRST('XXX','BUG ') 21327 WRITE(ICOUT,7417)NC1 21328 7417 FORMAT(' NUMBER OF COLUMNS IN THE MATRIX, ',I8,'.') 21329 CALL DPWRST('XXX','BUG ') 21330 IERROR='YES' 21331 GOTO9000 21332 ENDIF 21333C 21334 ICASE='COLU' 21335 CALL VARCOV(YM1,YM2,MAXROM,MAXCOM,NR1,NC1,DTEMP1, 21336 1 ICASE,IBUGA3,IERROR) 21337C 21338 DO7430J=1,NR1 21339 DSUM1=0.0D0 21340 DO7440L=1,NC1 21341 DSUM1=DSUM1 + DBLE(Y2(L))*DBLE(YM1(J,L)) 21342 7440 CONTINUE 21343 VECT9(J)=REAL(DSUM1) 21344 7430 CONTINUE 21345C 21346 ITYP9='VECT' 21347 NVECT9=NR1 21348 IUPFLG='SUBS' 21349 GOTO9000 21350C 21351C ***************************************************** 21352C ** STEP 75-- ** 21353C ** TREAT THE VECTOR TIMES TRANSPOSE CASE ** 21354C ***************************************************** 21355C 21356 7500 CONTINUE 21357C 21358 IF(N1.GT.MAXCOM)THEN 21359 WRITE(ICOUT,999) 21360 CALL DPWRST('XXX','BUG ') 21361 WRITE(ICOUT,7501) 21362 7501 FORMAT('***** ERROR IN MATAR3--') 21363 CALL DPWRST('XXX','BUG ') 21364 WRITE(ICOUT,7502) 21365 7502 FORMAT(' FOR VECTOR TIMES TRANSPOSE') 21366 CALL DPWRST('XXX','BUG ') 21367 WRITE(ICOUT,7503) 21368 7503 FORMAT(' THE NUMBER OF ROWS IN THE VECTOR MUST BE LESS') 21369 CALL DPWRST('XXX','BUG ') 21370 WRITE(ICOUT,7504) 21371 7504 FORMAT(' THAN ',I8) 21372 CALL DPWRST('XXX','BUG ') 21373 WRITE(ICOUT,7506) 21374 7506 FORMAT(' SUCH WAS NOT THE CASE HERE.') 21375 CALL DPWRST('XXX','BUG ') 21376 WRITE(ICOUT,7507)N1 21377 7507 FORMAT(' NUMBER OF ROWS =',I8) 21378 CALL DPWRST('XXX','BUG ') 21379 IERROR='YES' 21380 ENDIF 21381C 21382 DO7520I=1,N1 21383 DO7530J=1,N1 21384 YM9(I,J)=Y1(I)*Y1(J) 21385 7530 CONTINUE 21386 7520 CONTINUE 21387C 21388 ITYP9='MATR' 21389 NR9=N1 21390 NC9=N1 21391 IUPFLG='FULL' 21392 GOTO9000 21393C 21394C ******************************************************* 21395C ** STEP 76-- ** 21396C ** TREAT THE MATRIX GROUP MEANS CASE ** 21397C ******************************************************* 21398C 21399 7600 CONTINUE 21400C 21401 IF(NR1.EQ.N2)GOTO7609 21402 WRITE(ICOUT,999) 21403 CALL DPWRST('XXX','BUG ') 21404 WRITE(ICOUT,7601) 21405 7601 FORMAT('***** ERROR IN MATARI--') 21406 CALL DPWRST('XXX','BUG ') 21407 WRITE(ICOUT,7602) 21408 7602 FORMAT(' FOR THE MATRIX GROUP MEANS CASE,') 21409 CALL DPWRST('XXX','BUG ') 21410 WRITE(ICOUT,7603) 21411 7603 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX MUST EQUAL') 21412 CALL DPWRST('XXX','BUG ') 21413 WRITE(ICOUT,7605) 21414 7605 FORMAT(' THE NUMBER OF ROWS IN THE GROUP ID VARIABLE;') 21415 CALL DPWRST('XXX','BUG ') 21416 WRITE(ICOUT,7606) 21417 7606 FORMAT(' SUCH WAS NOT THE CASE HERE.') 21418 CALL DPWRST('XXX','BUG ') 21419 WRITE(ICOUT,7607)NR1 21420 7607 FORMAT(' NUMBER OF ROWS FOR MATRIX =',I8) 21421 CALL DPWRST('XXX','BUG ') 21422 WRITE(ICOUT,7608)N2 21423 7608 FORMAT(' NUMBER OF ROWS FOR GROUP ID VARIABLE =',I8) 21424 CALL DPWRST('XXX','BUG ') 21425 IERROR='YES' 21426 GOTO9000 21427 7609 CONTINUE 21428C 21429 CALL GRPMEA(YM1,YM9,MAXROM,MAXCOM,NR1,NC1, 21430 1Y2,Y3,INDEX,N2,NK,Y4,IBUGA3,IERROR) 21431C 21432 ITYP9='MATR' 21433 NR9=NK 21434 NC9=NC1 21435 IUPFLG='FULL' 21436 GOTO9000 21437C 21438C ******************************************************* 21439C ** STEP 77-- ** 21440C ** TREAT THE MATRIX GROUP STANDARD DEVIATIONS CASE ** 21441C ******************************************************* 21442C 21443 7700 CONTINUE 21444C 21445 IF(NR1.EQ.N2)GOTO7709 21446 WRITE(ICOUT,999) 21447 CALL DPWRST('XXX','BUG ') 21448 WRITE(ICOUT,7701) 21449 7701 FORMAT('***** ERROR IN MATARI--') 21450 CALL DPWRST('XXX','BUG ') 21451 WRITE(ICOUT,7702) 21452 7702 FORMAT(' FOR THE MATRIX GROUP STANDARD DEVIATIONS CASE,') 21453 CALL DPWRST('XXX','BUG ') 21454 WRITE(ICOUT,7703) 21455 7703 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX MUST EQUAL') 21456 CALL DPWRST('XXX','BUG ') 21457 WRITE(ICOUT,7705) 21458 7705 FORMAT(' THE NUMBER OF ROWS IN THE GROUP ID VARIABLE;') 21459 CALL DPWRST('XXX','BUG ') 21460 WRITE(ICOUT,7706) 21461 7706 FORMAT(' SUCH WAS NOT THE CASE HERE.') 21462 CALL DPWRST('XXX','BUG ') 21463 WRITE(ICOUT,7707)NR1 21464 7707 FORMAT(' NUMBER OF ROWS FOR MATRIX =',I8) 21465 CALL DPWRST('XXX','BUG ') 21466 WRITE(ICOUT,7708)N2 21467 7708 FORMAT(' NUMBER OF ROWS FOR GROUP ID VARIABLE =',I8) 21468 CALL DPWRST('XXX','BUG ') 21469 IERROR='YES' 21470 GOTO9000 21471 7709 CONTINUE 21472C 21473 CALL GRPSD(YM1,YM9,MAXROM,MAXCOM,NR1,NC1, 21474 1Y2,Y3,INDEX,N2,NK,Y4,IBUGA3,IERROR) 21475C 21476 ITYP9='MATR' 21477 NR9=NK 21478 NC9=NC1 21479 IUPFLG='FULL' 21480 GOTO9000 21481C 21482C ******************************************************* 21483C ** STEP 78-- ** 21484C ** TREAT THE MULTIVARIATE NORM RANDOM NUMBERS CASE ** 21485C ******************************************************* 21486C 21487 7800 CONTINUE 21488C 21489 IF(N1.EQ.NR2)GOTO7809 21490 WRITE(ICOUT,999) 21491 CALL DPWRST('XXX','BUG ') 21492 WRITE(ICOUT,7801) 21493 7801 FORMAT('***** ERROR IN MATARI--') 21494 CALL DPWRST('XXX','BUG ') 21495 WRITE(ICOUT,7802) 21496 7802 FORMAT(' FOR THE MULTIVARIATE NORMAL RANDOM NUMBERS CASE,') 21497 CALL DPWRST('XXX','BUG ') 21498 WRITE(ICOUT,7803) 21499 7803 FORMAT(' THE NUMBER OF ROWS IN THE SIGMA MATRIX MUST EQUAL') 21500 CALL DPWRST('XXX','BUG ') 21501 WRITE(ICOUT,7805) 21502 7805 FORMAT(' THE NUMBER OF ROWS IN THE MEAN VARIABLE;') 21503 CALL DPWRST('XXX','BUG ') 21504 WRITE(ICOUT,7806) 21505 7806 FORMAT(' SUCH WAS NOT THE CASE HERE.') 21506 CALL DPWRST('XXX','BUG ') 21507 WRITE(ICOUT,7807)NR1 21508 7807 FORMAT(' NUMBER OF ROWS FOR SIGMA MATRIX =',I8) 21509 CALL DPWRST('XXX','BUG ') 21510 WRITE(ICOUT,7808)N2 21511 7808 FORMAT(' NUMBER OF ROWS FOR MEAN VARIABLE =',I8) 21512 CALL DPWRST('XXX','BUG ') 21513 IERROR='YES' 21514 GOTO9000 21515 7809 CONTINUE 21516C 21517 NTEMP=INT(YS3) 21518 LDSIG=MAXROM 21519 LTF=.TRUE. 21520 IFLAG=0 21521C 21522 DO7820I=1,NTEMP 21523 CALL RDMNOR(Y1,YM2,LDSIG,NR2,LTF,Y4,IFLAG,ISEED) 21524 IF(IFLAG.EQ.1)THEN 21525 WRITE(ICOUT,999) 21526 CALL DPWRST('XXX','BUG ') 21527 WRITE(ICOUT,7821) 21528 7821 FORMAT('***** ERROR IN MATARI--') 21529 CALL DPWRST('XXX','BUG ') 21530 WRITE(ICOUT,7822) 21531 7822 FORMAT(' FOR THE MULTIVARIATE NORMAL RANDOM NUMBERS ', 21532 1 'CASE,') 21533 CALL DPWRST('XXX','BUG ') 21534 WRITE(ICOUT,7823) 21535 7823 FORMAT(' UNABLE TO COMPUTE THE CHOLESKY DECOMPOSITION ', 21536 1 'OF THE') 21537 CALL DPWRST('XXX','BUG ') 21538 WRITE(ICOUT,7824) 21539 7824 FORMAT(' SIGMA MATRIX. THIS IMPLIES SIGMA IS NOT ', 21540 1 'POSITIVE DEFINITE.') 21541 CALL DPWRST('XXX','BUG ') 21542 WRITE(ICOUT,7825) 21543 7825 FORMAT(' THE MULTIVARIATE RANDOM NUMBERS WERE NOT ', 21544 1 'GENERATED.') 21545 CALL DPWRST('XXX','BUG ') 21546 IERROR='YES' 21547 GOTO9000 21548 ENDIF 21549 DO7830J=1,NR2 21550 YM9(I,J)=Y4(J) 21551 7830 CONTINUE 21552 7820 CONTINUE 21553C 21554 ITYP9='MATR' 21555 NR9=NTEMP 21556 NC9=NR2 21557 IUPFLG='FULL' 21558 GOTO9000 21559C 21560C ******************************************************* 21561C ** STEP 79-- ** 21562C ** TREAT THE MULTINOMIAL RANDOM NUMBERS CASE ** 21563C ** LET M = MULTINOMIAL RANDOM NUMBERS P N NEVENTS ** 21564C ******************************************************* 21565C 21566 7900 CONTINUE 21567C 21568 DSUM1=0.0D0 21569 DO7909I=1,N1 21570 DSUM1=DSUM1 + DBLE(Y1(I)) 21571 IF(Y1(I).LE.0.0 .OR. Y1(I).GE.1.0)THEN 21572 WRITE(ICOUT,999) 21573 CALL DPWRST('XXX','BUG ') 21574 WRITE(ICOUT,7911) 21575 CALL DPWRST('XXX','BUG ') 21576 WRITE(ICOUT,7901) 21577 7901 FORMAT(' THE SPECIFIED PROBABILITIES MUST BE IN ', 21578 1 'THE INTERVAL (0,1).') 21579 CALL DPWRST('XXX','BUG ') 21580 WRITE(ICOUT,7903)I,Y1(I) 21581 7903 FORMAT(' ROW ',I8,' = ',E15.7) 21582 CALL DPWRST('XXX','BUG ') 21583 IERROR='YES' 21584 GOTO9000 21585 ENDIF 21586 IF(DSUM1.GT.1.000001D0)THEN 21587 WRITE(ICOUT,999) 21588 CALL DPWRST('XXX','BUG ') 21589 WRITE(ICOUT,7911) 21590 7911 FORMAT('***** ERROR IN MULTINOMIAL RANDOM NUMBERS--') 21591 CALL DPWRST('XXX','BUG ') 21592 WRITE(ICOUT,7013) 21593 7013 FORMAT(' THE SUM OF THE SPECIFIED PROBABILITIES ') 21594 CALL DPWRST('XXX','BUG ') 21595 WRITE(ICOUT,7015) 21596 7015 FORMAT(' HAS JUST EXCEEDED 1.') 21597 CALL DPWRST('XXX','BUG ') 21598 IERROR='YES' 21599 GOTO9000 21600 ENDIF 21601 7909 CONTINUE 21602C 21603 NTRIAL=INT(YS2+0.5) 21604 NEVENT=INT(YS3+0.5) 21605C 21606 IF(NTRIAL.LT.1)THEN 21607 WRITE(ICOUT,999) 21608 CALL DPWRST('XXX','BUG ') 21609 WRITE(ICOUT,7911) 21610 CALL DPWRST('XXX','BUG ') 21611 WRITE(ICOUT,7916) 21612 7916 FORMAT(' THE NUMBER OF TRIALS IS LESS THAN 1. ', 21613 1 'NTRIALS = ',I8) 21614 CALL DPWRST('XXX','BUG ') 21615 IERROR='YES' 21616 GOTO9000 21617 ENDIF 21618 IF(NEVENT.LT.1)THEN 21619 WRITE(ICOUT,999) 21620 CALL DPWRST('XXX','BUG ') 21621 WRITE(ICOUT,7911) 21622 CALL DPWRST('XXX','BUG ') 21623 WRITE(ICOUT,7918) 21624 7918 FORMAT(' THE NUMBER OF EVENTS IS LESS THAN 1. ', 21625 1 'NEVENTS = ',I8) 21626 CALL DPWRST('XXX','BUG ') 21627 IERROR='YES' 21628 GOTO9000 21629 ENDIF 21630C 21631 NCAT=N1 21632 IERROR='NO' 21633C 21634 DO7920I=1,NEVENT 21635 CALL MULRAN(NTRIAL,Y1,NCAT,ITEMP1,ISEED,IERROR) 21636 IF(IERROR.EQ.'YES')GOTO9000 21637 DO7930J=1,NCAT 21638 YM9(I,J)=REAL(ITEMP1(J)) 21639 7930 CONTINUE 21640 7920 CONTINUE 21641C 21642 ITYP9='MATR' 21643 NR9=NEVENT 21644 NC9=NCAT 21645 IUPFLG='FULL' 21646 GOTO9000 21647C 21648C ******************************************************* 21649C ** STEP 79.5-- ** 21650C ** TREAT THE MULTINOMIAL PDF CASE ** 21651C ** LET M = MULTINOMIAL PDF X P ** 21652C ******************************************************* 21653C 21654 7950 CONTINUE 21655C 21656 IERROR='NO' 21657 IF(N1.NE.N2)THEN 21658 WRITE(ICOUT,999) 21659 CALL DPWRST('XXX','BUG ') 21660 WRITE(ICOUT,7951) 21661 7951 FORMAT('***** ERROR IN MULTINOMIAL PDF--') 21662 CALL DPWRST('XXX','BUG ') 21663 WRITE(ICOUT,7953) 21664 7953 FORMAT(' THE NUMBER OF ROWS IN THE NUMBER OF SUCCESSES') 21665 CALL DPWRST('XXX','BUG ') 21666 WRITE(ICOUT,7955) 21667 7955 FORMAT(' VECTOR AND THE PROBABILITY OF SUCCESS VECTORS') 21668 CALL DPWRST('XXX','BUG ') 21669 WRITE(ICOUT,7956) 21670 7956 FORMAT(' ARE NOT EQUAL.') 21671 CALL DPWRST('XXX','BUG ') 21672 WRITE(ICOUT,7957)N1 21673 7957 FORMAT(' NUMBER OF ROWS FOR NUMBER OF SUCCESSES = ' 21674 1 ,I8) 21675 CALL DPWRST('XXX','BUG ') 21676 WRITE(ICOUT,7958)N2 21677 7958 FORMAT(' NUMBER OF ROWS FOR PROBABILITY OF ', 21678 1 'SUCCESS = ',I8) 21679 CALL DPWRST('XXX','BUG ') 21680 IERROR='YES' 21681 GOTO9000 21682 ENDIF 21683C 21684 DO7960I=1,N1 21685 IF(Y1(I).GE.0.0)THEN 21686 Y1(I)=REAL(INT(Y1(I)+0.1)) 21687 ELSE 21688 WRITE(ICOUT,999) 21689 CALL DPWRST('XXX','BUG ') 21690 WRITE(ICOUT,7951) 21691 CALL DPWRST('XXX','BUG ') 21692 WRITE(ICOUT,7961) 21693 7961 FORMAT(' THE NUMBER OF SUCCESSES MUST BE A ', 21694 1 'NON-NEGATIVE INTEGER.') 21695 CALL DPWRST('XXX','BUG ') 21696 WRITE(ICOUT,7963)I,Y1(I) 21697 7963 FORMAT(' ROW ',I8,' = ',E15.7) 21698 CALL DPWRST('XXX','BUG ') 21699 IERROR='YES' 21700 GOTO9000 21701 ENDIF 21702 7960 CONTINUE 21703C 21704 DSUM1=0.0D0 21705 DO7970I=1,N1 21706 DSUM1=DSUM1 + DBLE(Y2(I)) 21707 IF(Y2(I).LE.0.0 .OR. Y2(I).GE.1.0)THEN 21708 WRITE(ICOUT,999) 21709 CALL DPWRST('XXX','BUG ') 21710 WRITE(ICOUT,7951) 21711 CALL DPWRST('XXX','BUG ') 21712 WRITE(ICOUT,7971) 21713 7971 FORMAT(' THE SPECIFIED PROBABILITIES MUST BE IN ', 21714 1 'THE INTERVAL (0,1).') 21715 CALL DPWRST('XXX','BUG ') 21716 WRITE(ICOUT,7973)I,Y2(I) 21717 7973 FORMAT(' ROW ',I8,' = ',E15.7) 21718 CALL DPWRST('XXX','BUG ') 21719 IERROR='YES' 21720 GOTO9000 21721 ENDIF 21722 IF(DSUM1.GT.1.000001D0)THEN 21723 WRITE(ICOUT,999) 21724 CALL DPWRST('XXX','BUG ') 21725 WRITE(ICOUT,7951) 21726 CALL DPWRST('XXX','BUG ') 21727 WRITE(ICOUT,7981) 21728 7981 FORMAT(' THE SUM OF THE SPECIFIED PROBABILITIES ') 21729 CALL DPWRST('XXX','BUG ') 21730 WRITE(ICOUT,7983) 21731 7983 FORMAT(' HAS JUST EXCEEDED 1.') 21732 CALL DPWRST('XXX','BUG ') 21733 IERROR='YES' 21734 GOTO9000 21735 ENDIF 21736 7970 CONTINUE 21737C 21738 DSUM1=0.0D0 21739 DSUM2=0.0D0 21740 DO7990I=1,N1 21741 DSUM1=DSUM1+DBLE(Y1(I)) 21742 DSUM2=DSUM2+DBLE(Y2(I)) 21743 7990 CONTINUE 21744 DN=DSUM1 21745 DNORM=DSUM2 21746C 21747 NTRIAL=INT(DN) 21748C 21749 DSUM1=0.0D0 21750 DSUM2=0.0D0 21751 DLNPDF=DLNGAM(DN+1.0D0) 21752C 21753 DO7992I=1,N1 21754 DLNPDF=DLNPDF - DLNGAM(DBLE(Y1(I) + 1.0D0)) 21755 7992 CONTINUE 21756 DO7995I=1,N1 21757 DLNPDF=DLNPDF + DLOG(DBLE(Y2(I))/DNORM)*DBLE(Y1(I)) 21758 7995 CONTINUE 21759C 21760 IF(DLNPDF.LT.LOG(CPUMAX))THEN 21761 DLNPDF=DEXP(DLNPDF) 21762 ELSE 21763 WRITE(ICOUT,7998) 21764 7998 FORMAT('***** WARNING: LOGARITHM OF MULTINOMIAL PDF ', 21765 1 'RETURNED TO AVOID OVERFLOW.') 21766 CALL DPWRST('XXX','BUG ') 21767 ENDIF 21768C 21769 SCAL9=REAL(DLNPDF) 21770 ITYP9='SCAL' 21771 NR9=1 21772 NC9=1 21773 IUPFLG='FULL' 21774 GOTO9000 21775C 21776C ******************************************************* 21777C ** STEP 80-- ** 21778C ** TREAT THE WISHART RANDOM NUMBERS CASE ** 21779C ** LET M = WISHART RANDOM NUMBERS MU SIGMA N ** 21780C ******************************************************* 21781C 21782 8000 CONTINUE 21783C 21784 IF(N1.EQ.NR2)GOTO8009 21785 WRITE(ICOUT,999) 21786 CALL DPWRST('XXX','BUG ') 21787 WRITE(ICOUT,8001) 21788 8001 FORMAT('***** ERROR IN MATAR3--') 21789 CALL DPWRST('XXX','BUG ') 21790 WRITE(ICOUT,8002) 21791 8002 FORMAT(' FOR THE WISHART RANDOM NUMBERS CASE,') 21792 CALL DPWRST('XXX','BUG ') 21793 WRITE(ICOUT,8003) 21794 8003 FORMAT(' THE NUMBER OF ROWS IN THE SIGMA MATRIX MUST EQUAL') 21795 CALL DPWRST('XXX','BUG ') 21796 WRITE(ICOUT,8005) 21797 8005 FORMAT(' THE NUMBER OF ROWS IN THE MEAN VARIABLE;') 21798 CALL DPWRST('XXX','BUG ') 21799 WRITE(ICOUT,8006) 21800 8006 FORMAT(' SUCH WAS NOT THE CASE HERE.') 21801 CALL DPWRST('XXX','BUG ') 21802 WRITE(ICOUT,8007)NR2 21803 8007 FORMAT(' NUMBER OF ROWS FOR SIGMA MATRIX =',I8) 21804 CALL DPWRST('XXX','BUG ') 21805 WRITE(ICOUT,8008)N1 21806 8008 FORMAT(' NUMBER OF ROWS FOR MEAN VARIABLE =',I8) 21807 CALL DPWRST('XXX','BUG ') 21808 IERROR='YES' 21809 GOTO9000 21810 8009 CONTINUE 21811C 21812 IF(NR2.NE.NC2)THEN 21813 WRITE(ICOUT,999) 21814 CALL DPWRST('XXX','BUG ') 21815 WRITE(ICOUT,8011) 21816 8011 FORMAT('***** ERROR IN MATAR3--') 21817 CALL DPWRST('XXX','BUG ') 21818 WRITE(ICOUT,8012) 21819 8012 FORMAT(' FOR WISHART RANDOM NUMBERS,') 21820 CALL DPWRST('XXX','BUG ') 21821 WRITE(ICOUT,8013) 21822 8013 FORMAT(' THE NUMBER OF ROWS IN THE SIGMA MATRIX MUST ', 21823 1 'EQUAL') 21824 CALL DPWRST('XXX','BUG ') 21825 WRITE(ICOUT,8014) 21826 8014 FORMAT(' THE NUMBER OF COLUMNS; SUCH WAS NOT THE CASE ', 21827 1 'HERE.') 21828 CALL DPWRST('XXX','BUG ') 21829 WRITE(ICOUT,8017)NR1 21830 8017 FORMAT(' NUMBER OF ROWS =',I8) 21831 CALL DPWRST('XXX','BUG ') 21832 WRITE(ICOUT,8018)NC1 21833 8018 FORMAT(' NUMBER OF COLUMNS =',I8) 21834 CALL DPWRST('XXX','BUG ') 21835 IERROR='YES' 21836 GOTO9000 21837 ENDIF 21838C 21839 CALL SPOCO(YM2,MAXROM,NR2,RCOND,Y4,INFO) 21840C 21841 IF(INFO.NE.0)THEN 21842 WRITE(ICOUT,999) 21843 CALL DPWRST('XXX','BUG ') 21844 WRITE(ICOUT,8021) 21845 8021 FORMAT('***** ERROR IN MATAR3--') 21846 CALL DPWRST('XXX','BUG ') 21847 WRITE(ICOUT,8022) 21848 8022 FORMAT(' FOR MATRIX CHOLESKY DECOMPOSITION,') 21849 CALL DPWRST('XXX','BUG ') 21850 WRITE(ICOUT,8023) 21851 8023 FORMAT(' THE INPUT MATRIX IS NOT SINGULAR.') 21852 CALL DPWRST('XXX','BUG ') 21853 IERROR='YES' 21854 ENDIF 21855C 21856 WRITE(ICOUT,8061)RCOND 21857 CALL DPWRST('XXX','TEXT ') 21858 8061 FORMAT('THE RECIPROCAL CONDITION NUMBER FOR THE SIGMA MATRIX = ', 21859 1 E15.7) 21860 IF(1.0+RCOND.EQ.1.0)THEN 21861 WRITE(ICOUT,999) 21862 CALL DPWRST('XXX','BUG ') 21863 WRITE(ICOUT,8071) 21864 CALL DPWRST('XXX','ERRO ') 21865 WRITE(ICOUT,8072) 21866 CALL DPWRST('XXX','ERRO ') 21867 IERROR='YES' 21868 END IF 21869 8071 FORMAT('****** ERROR FOR WISHART RANDOM NUMBERS ********') 21870 8072 FORMAT(' THE SIGMA MATRIX IS SINGULAR') 21871C 21872 ICOUNT=0 21873 DO8080I=1,NR2 21874 DO8082J=I,NC2 21875 IF(J.GE.I)THEN 21876 ICOUNT=ICOUNT+1 21877 Y2(ICOUNT)=YM2(I,J) 21878 ENDIF 21879 8082 CONTINUE 21880 8080 CONTINUE 21881C 21882C 21883 NTEMP=INT(YS3) 21884 NP=NR2 21885 NNP=NP*(NP+1)/2 21886C 21887 CALL WSHRT(Y2,NTEMP,NP,NNP,Y3,Y4,ISEED) 21888C 21889 ICOUNT=0 21890 DO8090J=1,NP 21891 DO8092I=1,NP 21892 IF(I.LE.J)THEN 21893 ICOUNT=ICOUNT+1 21894 YM9(I,J)=Y4(ICOUNT) 21895 IF(I.NE.J)YM9(J,I)=YM9(I,J) 21896 ENDIF 21897 8092 CONTINUE 21898 8090 CONTINUE 21899C 21900 ITYP9='MATR' 21901 NR9=NP 21902 NC9=NP 21903 IUPFLG='FULL' 21904 GOTO9000 21905C 21906C *********************************************** 21907C ** STEP 81-- ** 21908C ** TREAT THE CATCHER MATRIX CASE ** 21909C ** C = X(X'X)**(-1) ** 21910C *********************************************** 21911C 21912 8100 CONTINUE 21913C 21914 CALL CATCHR(YM1,YM2,YM9,Y1,Y2,INDEX, 21915 1MAXROM,MAXCOM,NR1,NC1, 21916 1IBUGA3,IERROR) 21917C 21918 ITYP9='MATR' 21919 NR9=NR1 21920 NC9=NC1 21921 IUPFLG='FULL' 21922 GOTO9000 21923C 21924C *********************************************** 21925C ** STEP 82-- ** 21926C ** TREAT THE (X'X)**(-1) MATRIX CASE ** 21927C ** C = X(X'X)**(-1) ** 21928C *********************************************** 21929C 21930 8200 CONTINUE 21931C 21932 CALL XTXINV(YM1,YM9,Y1,Y2,INDEX, 21933 1MAXROM,MAXCOM,NR1,NC1, 21934 1IBUGA3,IERROR) 21935C 21936 ITYP9='MATR' 21937 NR9=NC1 21938 NC9=NC1 21939 IUPFLG='FULL' 21940 GOTO9000 21941C 21942C ************************************************ 21943C ** STEP 83-- ** 21944C ** TREAT THE VARIANCE INFLATION FACTORS CASE ** 21945C ************************************************ 21946C 21947 8300 CONTINUE 21948C 21949 CALL CATCHR(YM1,YM2,YM9,Y1,Y2,INDEX, 21950 1MAXROM,MAXCOM,NR1,NC1, 21951 1IBUGA3,IERROR) 21952C 21953 DO8310J=1,NC1 21954 DSUM1=0.0D0 21955 DSUM2=0.0D0 21956 DO8320I=1,NR1 21957 DSUM1=DSUM1 + DBLE(YM9(I,J))**2 21958 DSUM2=DSUM2 + DBLE(YM1(I,J)) 21959 8320 CONTINUE 21960 DMEAN=DSUM2/DBLE(NR1) 21961 DSUM2=0.0D0 21962 DO8330I=1,NR1 21963 DSUM2=DSUM2 + (DBLE(YM1(I,J)) - DMEAN)**2 21964 8330 CONTINUE 21965 VECT9(J)=REAL(DSUM1*DSUM2) 21966 8310 CONTINUE 21967C 21968 ITYP9='VECT' 21969 NVECT9=NC1 21970 IUPFLG='FULL' 21971 GOTO9000 21972C 21973C *********************************************** 21974C ** STEP 84-- ** 21975C ** TREAT THE CONDITION INDICES CASE ** 21976C ** (USEFUL FOR REGRESSION DIAGNOSTICS) ** 21977C *********************************************** 21978C 21979 8400 CONTINUE 21980C 21981C SCALE DESIGN MATRIX 21982C 21983 DO8410J=1,NC1 21984 DSUM1=0.0D0 21985 DO8420I=1,NR1 21986 DSUM1=DSUM1 + DBLE(YM1(I,J))*DBLE(YM1(I,J)) 21987 8420 CONTINUE 21988 DSUM1=DSQRT(DSUM1) 21989 DO8430I=1,NR1 21990 YM1(I,J)=YM1(I,J)/REAL(DSUM1) 21991 8430 CONTINUE 21992 8410 CONTINUE 21993C 21994C COMPUTE SINGULAR VALUES OF SCALED MATRIX 21995C 21996 IERR2=0 21997 IJOB=0 21998 CALL SSVDC(YM1,MAXROM,NR1,NC1,VECT9,Y1,YM1,MAXROM, 21999 1YM1,MAXROM,Y2,IJOB,IERR2) 22000C 22001 DO8440I=1,NC1 22002 VECT9(I)=VECT9(I)*VECT9(I) 22003 8440 CONTINUE 22004C 22005 CALL MAXIM(VECT9,NC1,IWRITE,XMAX,IBUGA3,IERROR) 22006 DO8450I=1,NC1 22007 IF(VECT9(I).NE.0.0)THEN 22008 VECT9(I)=XMAX/VECT9(I) 22009 ELSE 22010 VECT9(I)=0.0 22011 ENDIF 22012 8450 CONTINUE 22013C 22014 ITYP9='VECT' 22015 NVECT9=NC1 22016 IUPFLG='FULL' 22017 GOTO9000 22018C 22019C *********************************************** 22020C ** STEP 85-- ** 22021C ** TREAT THE CREATE MATRIX CASE ** 22022C ** LET M = CREATE MATRIX V1 V2 ... VK ** 22023C ** NOTE: MOST OF THE REAL WORK OF THIS ** 22024C ** FUNCTION ACTUALLY DONE IN DPMAT2, HERE ** 22025C ** SIMPLY DOING A MATRIX COPY. ** 22026C *********************************************** 22027C 22028 8500 CONTINUE 22029C 22030 DO8510J=1,NC1 22031 DO8520I=1,NR1 22032 YM9(I,J)=YM1(I,J) 22033 8520 CONTINUE 22034 8510 CONTINUE 22035C 22036 ITYP9='MATR' 22037 NR9=NR1 22038 NC9=NC1 22039 IUPFLG='FULL' 22040 GOTO9000 22041C 22042C **************************************************** 22043C ** STEP 85B- ** 22044C ** TREAT THE GENERATE MATRIX CASE ** 22045C ** LET M = GENERATE MATRIX <STAT> V1 V2 ... VK ** 22046C ** NOTE: MOST OF THE REAL WORK OF THIS ** 22047C ** FUNCTION ACTUALLY DONE IN DPMAT2, HERE ** 22048C ** SIMPLY DOING A MATRIX COPY. ** 22049C **************************************************** 22050C 22051 8550 CONTINUE 22052C 22053 DO8560J=1,NC1 22054 DO8570I=1,NR1 22055 YM9(I,J)=YM1(I,J) 22056 8570 CONTINUE 22057 8560 CONTINUE 22058C 22059 ITYP9='MATR' 22060 NR9=NR1 22061 NC9=NC1 22062 IUPFLG='FULL' 22063 GOTO9000 22064C 22065C ********************************************************************* 22066C ** STEP 86-- ** 22067C ** TREAT THE INDEPENDENT UNIFORM RANDOM NUMBERS CASE ** 22068C ** LET M = INDEPENDENT UNIFORM RANDOM NUMBER LOWLIM UPPLIM NP ** 22069C ********************************************************************* 22070C 22071 8600 CONTINUE 22072C 22073 NROW=INT(YS3 + 0.1) 22074 NCOL=N1 22075C 22076 DO8620J=1,NCOL 22077 ATEMP1=AMIN1(Y1(J),Y2(J)) 22078 ATEMP2=ABS(Y2(J)-Y1(J)) 22079 CALL UNIRAN(NROW,ISEED,Y4) 22080 DO8630I=1,NROW 22081 YM9(I,J)=ATEMP1 + ATEMP2*Y4(I) 22082 8630 CONTINUE 22083 8620 CONTINUE 22084C 22085 ITYP9='MATR' 22086 NR9=NROW 22087 NC9=NCOL 22088 IUPFLG='FULL' 22089 GOTO9000 22090C 22091C ******************************************************* 22092C ** STEP 87-- ** 22093C ** TREAT THE MULTIVARIATE NORMAL CDF CASE ** 22094C ******************************************************* 22095C 22096 8700 CONTINUE 22097C 22098 IF(NR1.NE.NC1)THEN 22099 WRITE(ICOUT,999) 22100 CALL DPWRST('XXX','BUG ') 22101 WRITE(ICOUT,8701) 22102 8701 FORMAT('***** ERROR IN MULTIVARIATE NORMAL CDF--') 22103 CALL DPWRST('XXX','BUG ') 22104 WRITE(ICOUT,8702) 22105 8702 FORMAT(' FOR THE MULTIVARIATE NORMAL CDF CASE, THE') 22106 CALL DPWRST('XXX','BUG ') 22107 WRITE(ICOUT,8703) 22108 8703 FORMAT(' CORRELATION MATRIX MUST BE SQUARE.') 22109 CALL DPWRST('XXX','BUG ') 22110 WRITE(ICOUT,8706) 22111 8706 FORMAT(' SUCH WAS NOT THE CASE HERE.') 22112 CALL DPWRST('XXX','BUG ') 22113 WRITE(ICOUT,8707)NR1 22114 8707 FORMAT(' NUMBER OF ROWS FOR SIGMA MATRIX =',I8) 22115 CALL DPWRST('XXX','BUG ') 22116 WRITE(ICOUT,8708)NC1 22117 8708 FORMAT(' NUMBER OF COLUMNS FOR SIGMA MATRIX =',I8) 22118 CALL DPWRST('XXX','BUG ') 22119 IERROR='YES' 22120 GOTO9000 22121 ELSE 22122 N=NR1 22123 ENDIF 22124C 22125 IF(N3.EQ.0)THEN 22126 IF(N2.NE.N)THEN 22127 WRITE(ICOUT,999) 22128 CALL DPWRST('XXX','BUG ') 22129 WRITE(ICOUT,8711) 22130 8711 FORMAT('***** ERROR IN MULTIVARIATE NORMAL CDF--') 22131 CALL DPWRST('XXX','BUG ') 22132 WRITE(ICOUT,8712) 22133 8712 FORMAT(' FOR THE MULTIVARIATE NORMAL CDF CASE, THE') 22134 CALL DPWRST('XXX','BUG ') 22135 WRITE(ICOUT,8713) 22136 8713 FORMAT(' NUMBER OF ROWS FOR THE UPPER LIMIT VARIABLE') 22137 CALL DPWRST('XXX','BUG ') 22138 WRITE(ICOUT,8714) 22139 8714 FORMAT(' NUMBER OF ROWS/COLUMNS FOR THE SIGMA MATRRIX.') 22140 CALL DPWRST('XXX','BUG ') 22141 WRITE(ICOUT,8716) 22142 8716 FORMAT(' SUCH WAS NOT THE CASE HERE.') 22143 CALL DPWRST('XXX','BUG ') 22144 WRITE(ICOUT,8717)NR1 22145 8717 FORMAT(' NUMBER OF ROWS FOR SIGMA MATRIX ', 22146 1 ' = ',I8) 22147 CALL DPWRST('XXX','BUG ') 22148 WRITE(ICOUT,8718)N2 22149 8718 FORMAT(' NUMBER OF ROWS FOR THE UPPER LIMIT ', 22150 1 'VECTOR = ',I8) 22151 CALL DPWRST('XXX','BUG ') 22152 IERROR='YES' 22153 GOTO9000 22154 ENDIF 22155 ELSE 22156 IF(N2.NE.N .OR. N3.NE.N)THEN 22157 WRITE(ICOUT,999) 22158 CALL DPWRST('XXX','BUG ') 22159 WRITE(ICOUT,8721) 22160 8721 FORMAT('***** ERROR IN MULTIVARIATE NORMAL CDF--') 22161 CALL DPWRST('XXX','BUG ') 22162 WRITE(ICOUT,8722) 22163 8722 FORMAT(' FOR THE MULTIVARIATE NORMAL CDF CASE, THE') 22164 CALL DPWRST('XXX','BUG ') 22165 WRITE(ICOUT,8723) 22166 8723 FORMAT(' NUMBER OF ROWS FOR THE UPPER LIMIT VARIABLE') 22167 CALL DPWRST('XXX','BUG ') 22168 WRITE(ICOUT,8724) 22169 8724 FORMAT(' NUMBER OF ROWS/COLUMNS FOR THE SIGMA MATRRIX.') 22170 CALL DPWRST('XXX','BUG ') 22171 WRITE(ICOUT,8726) 22172 8726 FORMAT(' SUCH WAS NOT THE CASE HERE.') 22173 CALL DPWRST('XXX','BUG ') 22174 WRITE(ICOUT,8727)NR1 22175 8727 FORMAT(' NUMBER OF ROWS FOR SIGMA MATRIX ', 22176 1 ' = ',I8) 22177 CALL DPWRST('XXX','BUG ') 22178 WRITE(ICOUT,8728)N2 22179 8728 FORMAT(' NUMBER OF ROWS FOR THE LOWER LIMIT ', 22180 1 'VECTOR = ',I8) 22181 CALL DPWRST('XXX','BUG ') 22182 WRITE(ICOUT,8729)N3 22183 8729 FORMAT(' NUMBER OF ROWS FOR THE UPPER LIMIT ', 22184 1 'VECTOR = ',I8) 22185 CALL DPWRST('XXX','BUG ') 22186 IERROR='YES' 22187 GOTO9000 22188 ENDIF 22189 ENDIF 22190C 22191 IF(N.LT.1 .OR. N .GT.20)THEN 22192 WRITE(ICOUT,999) 22193 CALL DPWRST('XXX','BUG ') 22194 WRITE(ICOUT,8731) 22195 8731 FORMAT('***** ERROR IN MULTIVARIATE NORMAL CDF--') 22196 CALL DPWRST('XXX','BUG ') 22197 WRITE(ICOUT,8732) 22198 8732 FORMAT(' CORRELATION MATRIX HAS LESS THAN ONE OR MORE') 22199 CALL DPWRST('XXX','BUG ') 22200 WRITE(ICOUT,8733)N 22201 8733 FORMAT(' THAN 20 VARIABLES. NUMBER OF VARIABLES = ',I8) 22202 CALL DPWRST('XXX','BUG ') 22203 IERROR='YES' 22204 GOTO9000 22205 ENDIF 22206C 22207 DO8741I=1,N 22208 DTEMP1(I)=0.0D0 22209 DTEMP2(I)=0.0D0 22210 DTEMP3(I)=0.0D0 22211 8741 CONTINUE 22212 ICNT=0 22213 DO8760J=1,N 22214 DO8765I=1,N 22215 IF(J.LT.I)THEN 22216 ICNT=ICNT+1 22217 INDX=J + ((I-2)*(I-1))/2 22218 DTEMP1(INDX)=DBLE(YM1(I,J)) 22219 ENDIF 22220 8765 CONTINUE 22221 8760 CONTINUE 22222C 22223 IF(N3.EQ.0)THEN 22224 DO8770I=1,N 22225 ITEMP1(I)=0 22226 DTEMP3(I)=DBLE(Y2(I)) 22227 DTEMP2(I)=DBLE(Y2(I)) 22228 8770 CONTINUE 22229 ELSE 22230 DO8775I=1,N 22231 ITEMP1(I)=2 22232 DTEMP2(I)=DBLE(Y2(I)) 22233 DTEMP3(I)=DBLE(Y3(I)) 22234 IF(Y2(I).EQ.CPUMIN.AND.Y3(I).EQ.CPUMAX)THEN 22235 ITEMP1(I)=-1 22236 DTEMP2(I)=0.0D0 22237 DTEMP3(I)=0.0D0 22238 ELSEIF(Y2(I).EQ.CPUMIN)THEN 22239 ITEMP1(I)=0 22240 DTEMP2(I)=DBLE(Y3(I)) 22241 DTEMP3(I)=DBLE(Y3(I)) 22242 ELSEIF(Y3(I).EQ.CPUMAX)THEN 22243 ITEMP1(I)=1 22244 DTEMP3(I)=DBLE(Y2(I)) 22245 DTEMP2(I)=DBLE(Y2(I)) 22246 ENDIF 22247 8775 CONTINUE 22248 ENDIF 22249C 22250 MAXPTS=5000*N*N*N 22251CCCCC ABSEPS=0.00005D0 22252CCCCC RELEPS=0.0D0 22253 ABSEPS=DBLE(ABSE) 22254 RELEPS=DBLE(RELE) 22255 VALS=0.0D0 22256 ERRS=0.0D0 22257 IFTS=0 22258C 22259 IF(IMVNTY.EQ.'SADM')THEN 22260 CALL SADMVN(N,DTEMP2,DTEMP3,ITEMP1,DTEMP1, 22261 1 MAXPTS,ABSEPS,RELEPS,ERRS,VALS,IFTS) 22262 ELSEIF(IMVNTY.EQ.'RANM')THEN 22263 CALL RANMVN(N,DTEMP2,DTEMP3,ITEMP1,DTEMP1, 22264 1 MAXPTS,ABSEPS,RELEPS,ERRS,VALS,IFTS) 22265 ELSEIF(IMVNTY.EQ.'KROM')THEN 22266 CALL KROMVN(N,DTEMP2,DTEMP3,ITEMP1,DTEMP1, 22267 1 MAXPTS,ABSEPS,RELEPS,ERRS,VALS,IFTS) 22268 ELSEIF(IMVNTY.EQ.'SPHM')THEN 22269 CALL SPHMVN(N,DTEMP2,DTEMP3,ITEMP1,DTEMP1, 22270 1 MAXPTS,ABSEPS,RELEPS,ERRS,VALS,IFTS) 22271 ELSE 22272 CALL SADMVN(N,DTEMP2,DTEMP3,ITEMP1,DTEMP1, 22273 1 MAXPTS,ABSEPS,RELEPS,ERRS,VALS,IFTS) 22274 ENDIF 22275C 22276 IF(IFTS.EQ.1)THEN 22277 WRITE(ICOUT,999) 22278 CALL DPWRST('XXX','BUG ') 22279 WRITE(ICOUT,8791) 22280 8791 FORMAT('***** WARNING IN MULTIVARIATE NORMAL CDF--') 22281 CALL DPWRST('XXX','BUG ') 22282 WRITE(ICOUT,8792)ABSEPS 22283 8792 FORMAT(' ERROR IS GREATER THAN REQUESTED VALUE OF ', 22284 1 E15.7) 22285 CALL DPWRST('XXX','BUG ') 22286 ENDIF 22287C 22288 ITYP9='SCAL' 22289 SCAL9=REAL(VALS) 22290 NR9=1 22291 NC9=1 22292 IUPFLG='FULL' 22293 AERROR=ERRS 22294 GOTO9000 22295C 22296C ******************************************************* 22297C ** STEP 88-- ** 22298C ** TREAT THE MULTIVARIATE T CDF CASE ** 22299C ******************************************************* 22300C 22301 8800 CONTINUE 22302C 22303 IF(NR1.NE.NC1)THEN 22304 WRITE(ICOUT,999) 22305 CALL DPWRST('XXX','BUG ') 22306 WRITE(ICOUT,8801) 22307 8801 FORMAT('***** ERROR IN MULTIVARIATE T CDF--') 22308 CALL DPWRST('XXX','BUG ') 22309 WRITE(ICOUT,8802) 22310 8802 FORMAT(' FOR THE MULTIVARIATE T CDF CASE, THE') 22311 CALL DPWRST('XXX','BUG ') 22312 WRITE(ICOUT,8803) 22313 8803 FORMAT(' CORRELATION MATRIX MUST BE SQUARE.') 22314 CALL DPWRST('XXX','BUG ') 22315 WRITE(ICOUT,8806) 22316 8806 FORMAT(' SUCH WAS NOT THE CASE HERE.') 22317 CALL DPWRST('XXX','BUG ') 22318 WRITE(ICOUT,8807)NR1 22319 8807 FORMAT(' NUMBER OF ROWS FOR SIGMA MATRIX =',I8) 22320 CALL DPWRST('XXX','BUG ') 22321 WRITE(ICOUT,8808)NC1 22322 8808 FORMAT(' NUMBER OF COLUMNS FOR SIGMA MATRIX =',I8) 22323 CALL DPWRST('XXX','BUG ') 22324 IERROR='YES' 22325 GOTO9000 22326 ELSE 22327 N=NR1 22328 ENDIF 22329C 22330 IF(N4.EQ.0)THEN 22331 IF(N3.NE.N)THEN 22332 WRITE(ICOUT,999) 22333 CALL DPWRST('XXX','BUG ') 22334 WRITE(ICOUT,8811) 22335 8811 FORMAT('***** ERROR IN MULTIVARIATE T CDF--') 22336 CALL DPWRST('XXX','BUG ') 22337 WRITE(ICOUT,8812) 22338 8812 FORMAT(' FOR THE MULTIVARIATE T CDF CASE, THE') 22339 CALL DPWRST('XXX','BUG ') 22340 WRITE(ICOUT,8813) 22341 8813 FORMAT(' NUMBER OF ROWS FOR THE UPPER LIMIT VARIABLE') 22342 CALL DPWRST('XXX','BUG ') 22343 WRITE(ICOUT,8814) 22344 8814 FORMAT(' NUMBER OF ROWS/COLUMNS FOR THE SIGMA MATRRIX.') 22345 CALL DPWRST('XXX','BUG ') 22346 WRITE(ICOUT,8816) 22347 8816 FORMAT(' SUCH WAS NOT THE CASE HERE.') 22348 CALL DPWRST('XXX','BUG ') 22349 WRITE(ICOUT,8817)NR1 22350 8817 FORMAT(' NUMBER OF ROWS FOR SIGMA MATRIX ', 22351 1 ' = ',I8) 22352 CALL DPWRST('XXX','BUG ') 22353 WRITE(ICOUT,8818)N3 22354 8818 FORMAT(' NUMBER OF ROWS FOR THE UPPER LIMIT ', 22355 1 'VECTOR = ',I8) 22356 CALL DPWRST('XXX','BUG ') 22357 IERROR='YES' 22358 GOTO9000 22359 ENDIF 22360 ELSE 22361 IF(N3.NE.N .OR. N4.NE.N)THEN 22362 WRITE(ICOUT,999) 22363 CALL DPWRST('XXX','BUG ') 22364 WRITE(ICOUT,8821) 22365 8821 FORMAT('***** ERROR IN MULTIVARIATE T CDF--') 22366 CALL DPWRST('XXX','BUG ') 22367 WRITE(ICOUT,8822) 22368 8822 FORMAT(' FOR THE MULTIVARIATE T CDF CASE, THE') 22369 CALL DPWRST('XXX','BUG ') 22370 WRITE(ICOUT,8823) 22371 8823 FORMAT(' NUMBER OF ROWS FOR THE UPPER LIMIT VARIABLE') 22372 CALL DPWRST('XXX','BUG ') 22373 WRITE(ICOUT,8824) 22374 8824 FORMAT(' NUMBER OF ROWS/COLUMNS FOR THE SIGMA MATRRIX.') 22375 CALL DPWRST('XXX','BUG ') 22376 WRITE(ICOUT,8826) 22377 8826 FORMAT(' SUCH WAS NOT THE CASE HERE.') 22378 CALL DPWRST('XXX','BUG ') 22379 WRITE(ICOUT,8827)NR1 22380 8827 FORMAT(' NUMBER OF ROWS FOR SIGMA MATRIX ', 22381 1 ' = ',I8) 22382 CALL DPWRST('XXX','BUG ') 22383 WRITE(ICOUT,8828)N3 22384 8828 FORMAT(' NUMBER OF ROWS FOR THE LOWER LIMIT ', 22385 1 'VECTOR = ',I8) 22386 CALL DPWRST('XXX','BUG ') 22387 WRITE(ICOUT,8829)N4 22388 8829 FORMAT(' NUMBER OF ROWS FOR THE UPPER LIMIT ', 22389 1 'VECTOR = ',I8) 22390 CALL DPWRST('XXX','BUG ') 22391 IERROR='YES' 22392 GOTO9000 22393 ENDIF 22394 ENDIF 22395C 22396 IF(N.LT.1 .OR. N .GT.20)THEN 22397 WRITE(ICOUT,999) 22398 CALL DPWRST('XXX','BUG ') 22399 WRITE(ICOUT,8831) 22400 8831 FORMAT('***** ERROR IN MULTIVARIATE T CDF--') 22401 CALL DPWRST('XXX','BUG ') 22402 WRITE(ICOUT,8832) 22403 8832 FORMAT(' CORRELATION MATRIX HAS LESS THAN ONE OR MORE') 22404 CALL DPWRST('XXX','BUG ') 22405 WRITE(ICOUT,8833)N 22406 8833 FORMAT(' THAN 20 VARIABLES. NUMBER OF VARIABLES = ',I8) 22407 CALL DPWRST('XXX','BUG ') 22408 IERROR='YES' 22409 GOTO9000 22410 ENDIF 22411C 22412 NU=INT(YS2+0.1) 22413C 22414 DO8841I=1,N 22415 DTEMP1(I)=0.0D0 22416 DTEMP2(I)=0.0D0 22417 DTEMP3(I)=0.0D0 22418 8841 CONTINUE 22419 ICNT=0 22420 DO8860J=1,N 22421 DO8865I=1,N 22422 IF(J.LT.I)THEN 22423 ICNT=ICNT+1 22424 INDX=J + ((I-2)*(I-1))/2 22425 DTEMP1(INDX)=DBLE(YM1(I,J)) 22426 ENDIF 22427 8865 CONTINUE 22428 8860 CONTINUE 22429C 22430 IF(N4.EQ.0)THEN 22431 DO8870I=1,N 22432 ITEMP1(I)=0 22433 DTEMP3(I)=DBLE(Y3(I)) 22434 DTEMP2(I)=DBLE(Y3(I)) 22435 8870 CONTINUE 22436 ELSE 22437 DO8875I=1,N 22438 ITEMP1(I)=2 22439 DTEMP2(I)=DBLE(Y3(I)) 22440 DTEMP3(I)=DBLE(Y4(I)) 22441 IF(Y3(I).EQ.CPUMIN.AND.Y4(I).EQ.CPUMAX)THEN 22442 ITEMP1(I)=-1 22443 DTEMP2(I)=0.0D0 22444 DTEMP3(I)=0.0D0 22445 ELSEIF(Y3(I).EQ.CPUMIN)THEN 22446 ITEMP1(I)=0 22447 DTEMP2(I)=DBLE(Y4(I)) 22448 DTEMP3(I)=DBLE(Y4(I)) 22449 ELSEIF(Y3(I).EQ.CPUMAX)THEN 22450 ITEMP1(I)=1 22451 DTEMP3(I)=DBLE(Y3(I)) 22452 DTEMP2(I)=DBLE(Y3(I)) 22453 ENDIF 22454 8875 CONTINUE 22455 ENDIF 22456C 22457 MAXPTS=5000*N*N*N 22458CCCCC ABSEPS=0.00005D0 22459CCCCC RELEPS=0.0D0 22460 ABSEPS=DBLE(ABSE) 22461 RELEPS=DBLE(RELE) 22462 VALS=0.0D0 22463 ERRS=0.0D0 22464 IFTS=0 22465C 22466 IF(IMVNTY.EQ.'SADM')THEN 22467 CALL SADMVT(N,NU,DTEMP2,DTEMP3,ITEMP1,DTEMP1, 22468 1 MAXPTS,ABSEPS,RELEPS,ERRS,VALS,IFTS) 22469 ELSEIF(IMVNTY.EQ.'RANM')THEN 22470 CALL RANMVT(N,NU,DTEMP2,DTEMP3,ITEMP1,DTEMP1, 22471 1 MAXPTS,ABSEPS,RELEPS,ERRS,VALS,IFTS) 22472 ELSEIF(IMVNTY.EQ.'KROM')THEN 22473 CALL KROMVT(N,NU,DTEMP2,DTEMP3,ITEMP1,DTEMP1, 22474 1 MAXPTS,ABSEPS,RELEPS,ERRS,VALS,IFTS) 22475 ELSE 22476 CALL SADMVT(N,NU,DTEMP2,DTEMP3,ITEMP1,DTEMP1, 22477 1 MAXPTS,ABSEPS,RELEPS,ERRS,VALS,IFTS) 22478 ENDIF 22479C 22480 IF(IFTS.EQ.1)THEN 22481 WRITE(ICOUT,999) 22482 CALL DPWRST('XXX','BUG ') 22483 WRITE(ICOUT,8891) 22484 8891 FORMAT('***** WARNING IN MULTIVARIATE T CDF--') 22485 CALL DPWRST('XXX','BUG ') 22486 WRITE(ICOUT,8892)ABSEPS 22487 8892 FORMAT(' ERROR IS GREATER THAN REQUESTED VALUE OF ', 22488 1 E15.7) 22489 CALL DPWRST('XXX','BUG ') 22490 ENDIF 22491C 22492 ITYP9='SCAL' 22493 SCAL9=REAL(VALS) 22494 NR9=1 22495 NC9=1 22496 IUPFLG='FULL' 22497 GOTO9000 22498C 22499C ******************************************************* 22500C ** STEP 89-- ** 22501C ** TREAT THE MULTIVARIATE T RANDOM NUMBERS CASE ** 22502C ******************************************************* 22503C 22504 8900 CONTINUE 22505C 22506 IF(N1.EQ.NR2)GOTO8909 22507 WRITE(ICOUT,999) 22508 CALL DPWRST('XXX','BUG ') 22509 WRITE(ICOUT,8901) 22510 8901 FORMAT('***** ERROR IN MATARI--') 22511 CALL DPWRST('XXX','BUG ') 22512 WRITE(ICOUT,8902) 22513 8902 FORMAT(' FOR THE MULTIVARIATE T RANDOM NUMBERS CASE,') 22514 CALL DPWRST('XXX','BUG ') 22515 WRITE(ICOUT,8903) 22516 8903 FORMAT(' THE NUMBER OF ROWS IN THE SIGMA MATRIX MUST EQUAL') 22517 CALL DPWRST('XXX','BUG ') 22518 WRITE(ICOUT,8905) 22519 8905 FORMAT(' THE NUMBER OF ROWS IN THE MEAN VARIABLE;') 22520 CALL DPWRST('XXX','BUG ') 22521 WRITE(ICOUT,8906) 22522 8906 FORMAT(' SUCH WAS NOT THE CASE HERE.') 22523 CALL DPWRST('XXX','BUG ') 22524 WRITE(ICOUT,8907)NR1 22525 8907 FORMAT(' NUMBER OF ROWS FOR SIGMA MATRIX =',I8) 22526 CALL DPWRST('XXX','BUG ') 22527 WRITE(ICOUT,8908)N2 22528 8908 FORMAT(' NUMBER OF ROWS FOR MEAN VARIABLE =',I8) 22529 CALL DPWRST('XXX','BUG ') 22530 IERROR='YES' 22531 GOTO9000 22532 8909 CONTINUE 22533C 22534 NTEMP=INT(YS4) 22535 LDSIG=MAXROM 22536 LTF=.TRUE. 22537C 22538 DO8920I=1,NTEMP 22539 CALL RDMNOR(Y1,YM2,LDSIG,NR2,LTF,Y4,IFLAG,ISEED) 22540 DO8930J=1,NR2 22541 YM9(I,J)=Y4(J) 22542 8930 CONTINUE 22543 8920 CONTINUE 22544C 22545C NOW DIVIDE BY SQRT(CHIRAN(NU)/NU) 22546C 22547 NU=INT(YS3+0.1) 22548 DO8940J=1,NR2 22549 CALL CHSRAN(NTEMP,REAL(NU),ISEED,Y4) 22550 DO8945I=1,NTEMP 22551 YM9(I,J)=YM9(I,J)/SQRT(Y4(I)/REAL(NU)) 22552 8945 CONTINUE 22553 8940 CONTINUE 22554C 22555 ITYP9='MATR' 22556 NR9=NTEMP 22557 NC9=NR2 22558 IUPFLG='FULL' 22559 GOTO9000 22560C 22561C ***************************************************************** 22562C ** STEP 89.5-- ** 22563C ** TREAT THE DIRICHLET RANDOM NUMBERS CASE ** 22564C ** LET M = DIRICHLET RANDOM NUMBER ALPHA N ** 22565C ***************************************************************** 22566C 22567 8950 CONTINUE 22568C 22569 NTEMP=INT(YS2 + 0.1) 22570 NRAN=1 22571C 22572 DO8959J=1,N1 22573 IF(Y1(J).LE.0.0)THEN 22574 WRITE(ICOUT,999) 22575 CALL DPWRST('XXX','BUG ') 22576 WRITE(ICOUT,8951) 22577 8951 FORMAT('***** ERROR FOR DIRICHLET RANDOM NUMBERS--') 22578 CALL DPWRST('XXX','BUG ') 22579 WRITE(ICOUT,8953) 22580 8953 FORMAT(' THE SHAPE PARAMETERS FOR THE DIRICHLET') 22581 CALL DPWRST('XXX','BUG ') 22582 WRITE(ICOUT,8954) 22583 8954 FORMAT(' MUST BE POSITIVE. AT LEAST ONE OF THE SHAPE') 22584 CALL DPWRST('XXX','BUG ') 22585 WRITE(ICOUT,8955) 22586 8955 FORMAT(' PARAMETERS IS NOT POSITIVE.') 22587 CALL DPWRST('XXX','BUG ') 22588 IERROR='YES' 22589 GOTO9000 22590 ENDIF 22591 8959 CONTINUE 22592C 22593 IF(NTEMP.LT.2)THEN 22594 WRITE(ICOUT,999) 22595 CALL DPWRST('XXX','BUG ') 22596 WRITE(ICOUT,8961) 22597 8961 FORMAT('***** ERROR FOR DIRICHLET RANDOM NUMBERS--') 22598 CALL DPWRST('XXX','BUG ') 22599 WRITE(ICOUT,8963) 22600 8963 FORMAT(' THE REQUESTEND NUMBER OF ROWS MUST BE AT LEAST') 22601 CALL DPWRST('XXX','BUG ') 22602 WRITE(ICOUT,8965) 22603 8965 FORMAT(' ONE. SUCH WAS NOT THE CASE HERE.') 22604 CALL DPWRST('XXX','BUG ') 22605 IERROR='YES' 22606 GOTO9000 22607 ENDIF 22608C 22609 NRAN=1 22610 DO8970I=1,NTEMP 22611 DSUM=0.0D0 22612 DO8980J=1,N1 22613 CALL GAMRAN(NRAN,Y1(J),ISEED,Y4(J)) 22614 DSUM=DSUM+DBLE(Y4(J)) 22615 8980 CONTINUE 22616 DO8985J=1,N1 22617 YM9(I,J)=REAL(DBLE(Y4(J))/DSUM) 22618 8985 CONTINUE 22619 8970 CONTINUE 22620C 22621 ITYP9='MATR' 22622 NR9=NTEMP 22623 NC9=N1 22624 IUPFLG='FULL' 22625 GOTO9000 22626C 22627C ***************************************************************** 22628C ** STEP 93-- - ** 22629C ** TREAT THE DIRICHLET PDF CASE ** 22630C ** LET M = DIRICHLET PDF X THETA ** 22631C ** LET M = DIRICHLET LOG PDF X THETA ** 22632C ***************************************************************** 22633C 22634 9300 CONTINUE 22635C 22636 IERROR='NO' 22637 IF(N1.NE.N2)THEN 22638 WRITE(ICOUT,999) 22639 CALL DPWRST('XXX','BUG ') 22640 WRITE(ICOUT,9351) 22641 9351 FORMAT('***** ERROR IN DIRICHELET PDF--') 22642 CALL DPWRST('XXX','BUG ') 22643 WRITE(ICOUT,9353) 22644 9353 FORMAT(' THE NUMBER OF ROWS IN THE X VECTOR AND THE') 22645 CALL DPWRST('XXX','BUG ') 22646 WRITE(ICOUT,9355) 22647 9355 FORMAT(' ALPHA VECTOR ARE NOT EQUAL') 22648 CALL DPWRST('XXX','BUG ') 22649 WRITE(ICOUT,9357)N1 22650 9357 FORMAT(' NUMBER OF ROWS FOR THE X VECTOR = ', 22651 1 I8) 22652 CALL DPWRST('XXX','BUG ') 22653 WRITE(ICOUT,9358)N2 22654 9358 FORMAT(' NUMBER OF ROWS FOR THE ALPHA VECTOR = ', 22655 1 I8) 22656 CALL DPWRST('XXX','BUG ') 22657 IERROR='YES' 22658 GOTO9000 22659 ENDIF 22660C 22661 DSUM1=0.0D0 22662 DSUM2=0.0D0 22663 DO9360I=1,N1 22664 DSUM1=DSUM1+DBLE(Y2(I)-1.0)*DBLE(LOG(Y1(I))) 22665 9360 CONTINUE 22666 DLNPDF=DSUM1 22667C 22668 DO9370I=1,N1 22669 DSUM2=DSUM2 + DBLE(Y2(I)) 22670 9370 CONTINUE 22671 DLNPDF=DLNPDF + DLNGAM(DSUM2) 22672 DO9380I=1,N1 22673 DLNPDF=DLNPDF - DLNGAM(DBLE(Y2(I))) 22674 9380 CONTINUE 22675C 22676 SCAL9=REAL(DLNPDF) 22677 IF(IMCASE.EQ.'DPDF')THEN 22678 SCAL9=EXP(SCAL9) 22679 ENDIF 22680 ITYP9='SCAL' 22681 NR9=1 22682 NC9=1 22683 IUPFLG='FULL' 22684 GOTO9000 22685C 22686C *********************************************************** 22687C ** STEP 94-- ** 22688C ** TREAT THE UNIFORM RANDOM NUMBERS CASE ** 22689C ** (CORRELATED CASE) ** 22690C ** LET M = MULTIVARIATE UNIFORM RANDOM NUMBERS SIGMA N ** 22691C ** ALGORITHM FROM GENTLE (2003), 'RANDOM NUMBER ** 22692C ** GENERATION AND MONTE CARLO METHODS', 2ND. ED., P. 207** 22693C ** GENERATE NORMAL RANDOM NUMBERS AND THEN TAKE NORCDF ** 22694C ** OF THOSE NUMBERS. NOTE THAT THE LOCATION PARAMETER ** 22695C ** IS ASSUMED TO BE ZERO. ** 22696C *********************************************************** 22697C 22698 9400 CONTINUE 22699C 22700 NTEMP=INT(YS2) 22701 LDSIG=MAXROM 22702 LTF=.TRUE. 22703C 22704 DO9410I=1,NR1 22705 Y1(I)=0.0 22706 9410 CONTINUE 22707C 22708 DO9420I=1,NTEMP 22709 CALL RDMNOR(Y1,YM1,LDSIG,NR1,LTF,Y4,IFLAG,ISEED) 22710 DO9430J=1,NR1 22711 CALL NORCDF(Y4(J),YM9(I,J)) 22712 9430 CONTINUE 22713 9420 CONTINUE 22714C 22715 ITYP9='MATR' 22716 NR9=NTEMP 22717 NC9=NR1 22718 IUPFLG='FULL' 22719 GOTO9000 22720C 22721C ***************************************************** 22722C ** STEP 95-- ** 22723C ** TREAT THE MATRIX PARTITION STATISTIC CASE ** 22724C ***************************************************** 22725C 22726C THIS COMMAND SPLITS THE FULL MATRIX INTO SUB-PARTITIONS 22727C (DETERMINED BY NROWPA AND NCOLPA) AND CREATE A NEW MATRIX 22728C CONTAINING THE COMPUTED STATISTIC FOR EACH OF THESE SUB-MATRICES. 22729C 22730C TWO CASES ARE SUPPORTED: 22731C 22732C 1) IF THE SECOND AND THIRD ARGUMENTS ARE BOTH SCALAR, THEN 22733C EXTRACT EQUI-SIZED PARTITIONS. 22734C 22735C 2) IF EITHER THE SECOND OR THIRD ARGUMENT IS A VECTOR, THEN 22736C EXTRACT UNEQUAL PARTITIONS. THE VECTOR IS TREATED AS A 22737C TAG VARIABLE WHICH IDENTIFIES THE SUB-MATRICES. WITH THIS 22738C APPROACH, THE SUB-MATRICES DO NOT NEED TO BE OF EQUAL SIZE 22739C AND DO NOT NEED TO DEFINE CONTIGUOUS SUBSETS. 22740C 22741 9500 CONTINUE 22742C 22743 IWRITE='OFF' 22744 MAXNXT=MAXOBV 22745 IF(ICASS7.EQ.'INTE')NUMV2=1 22746C 22747 NROWPA=INT(ABS(YS2+0.5)) 22748 NCOLPA=INT(ABS(YS3+0.5)) 22749 IF(N2.LE.0 .AND. N3.LE.0)THEN 22750C 22751 IF(NROWPA.EQ.0)NROWPA=2 22752 IF(NCOLPA.EQ.0)NCOLPA=2 22753C 22754 IROW=0 22755 ICOL=0 22756 DO9510I=1,NC1,NCOLPA 22757 ICOL=ICOL+1 22758 ICOL1=I 22759 ICOL2=I+NCOLPA-1 22760 IF(ICOL2.GT.NC1)ICOL2=NC1 22761 IROW=0 22762 DO9515J=1,NR1,NROWPA 22763 IROW=IROW+1 22764 IROW1=J 22765 IROW2=J+NROWPA-1 22766 IF(IROW2.GT.NR1)IROW2=NR1 22767 III=0 22768 DO9520II=ICOL1,ICOL2 22769 DO9530JJ=IROW1,IROW2 22770 III=III+1 22771 NTEMP=III 22772 Y1(III)=YM1(JJ,II) 22773 9530 CONTINUE 22774 9520 CONTINUE 22775 ASTAT=0.0 22776 CALL CMPSTA( 22777 1 Y1,Y2,Y2,Y3,Y4,Y5,MAXNXT,NTEMP,NTEMP,NTEMP,NUMV2,ICASS7, 22778 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 22779 1 DTEMP1,DTEMP2,DTEMP3, 22780CCCCC1 IQUAME,IQUASE,PSTAMV, 22781 1 ASTAT, 22782 1 ISUBRO,IBUGA3,IERROR) 22783 YM9(IROW,ICOL)=ASTAT 22784 9515 CONTINUE 22785 9510 CONTINUE 22786C 22787 ITYP9='MATR' 22788 NR9=IROW 22789 NC9=ICOL 22790 IUPFLG='FULL' 22791 GOTO9000 22792C 22793 ELSE 22794C 22795 IF(N2.GE.1)THEN 22796 IF(N2.NE.NR1)THEN 22797 WRITE(ICOUT,999) 22798 CALL DPWRST('XXX','BUG ') 22799 WRITE(ICOUT,9551) 22800 9551 FORMAT('***** ERROR IN MATRIX PARTITION <STATISTIC>--') 22801 CALL DPWRST('XXX','BUG ') 22802 WRITE(ICOUT,9552)N2 22803 9552 FORMAT(' THE NUMBER OF ELEMENTS IN THE ROW VECTOR ', 22804 1 '= ',I8) 22805 CALL DPWRST('XXX','BUG ') 22806 WRITE(ICOUT,9553)NR1 22807 9553 FORMAT(' WHILE THE NUMBER OF ROWS IN THE MATRIX = ', 22808 1 I8) 22809 CALL DPWRST('XXX','BUG ') 22810 IERROR='YES' 22811 GOTO9000 22812 ENDIF 22813 CALL DISTIN(Y2,N2,IWRITE,Y5,NROWPA,IBUGA3,IERROR) 22814 DO9557I=1,NROWPA 22815 DTEMP1(I)=DBLE(Y5(I)) 22816 9557 CONTINUE 22817 ELSE 22818 NROWPA=1 22819 DTEMP1(1)=1.0D0 22820 DO9558I=1,NR1 22821 Y2(I)=1.0 22822 9558 CONTINUE 22823 ENDIF 22824C 22825 IF(N3.GE.1)THEN 22826 IF(N3.NE.NC1)THEN 22827 WRITE(ICOUT,999) 22828 CALL DPWRST('XXX','BUG ') 22829 WRITE(ICOUT,9561) 22830 9561 FORMAT('***** ERROR IN MATRIX PARTITION <STATISTIC>--') 22831 CALL DPWRST('XXX','BUG ') 22832 WRITE(ICOUT,9562)N2 22833 9562 FORMAT(' THE NUMBER OF ELEMENTS IN THE COLUMN ', 22834 1 'VECTOR = ',I8) 22835 CALL DPWRST('XXX','BUG ') 22836 WRITE(ICOUT,9563)NC1 22837 9563 FORMAT(' WHILE THE NUMBER OF COLUMNS IN THE ', 22838 1 'MATRIX = ',I8) 22839 CALL DPWRST('XXX','BUG ') 22840 IERROR='YES' 22841 GOTO9000 22842 ENDIF 22843 CALL DISTIN(Y3,N3,IWRITE,Y5,NCOLPA,IBUGA3,IERROR) 22844 DO9567I=1,NCOLPA 22845 DTEMP2(I)=DBLE(Y5(I)) 22846 9567 CONTINUE 22847 ELSE 22848 NCOLPA=1 22849 DTEMP2(1)=1.0D0 22850 DO9568I=1,NC1 22851 Y3(I)=1.0 22852 9568 CONTINUE 22853 ENDIF 22854C 22855 DO9571IROW=1,NROWPA 22856 AROW=REAL(DTEMP1(IROW)) 22857 DO9572ICOL=1,NCOLPA 22858 ACOL=REAL(DTEMP2(ICOL)) 22859C 22860 NTEMP=0 22861 DO9580JJ=1,NC1 22862 DO9590II=1,NR1 22863 IF(AROW.EQ.Y2(II) .AND. ACOL.EQ.Y3(JJ))THEN 22864 NTEMP=NTEMP+1 22865 Y1(NTEMP)=YM1(II,JJ) 22866 ENDIF 22867 9590 CONTINUE 22868 9580 CONTINUE 22869 IF(NTEMP.GE.1)THEN 22870 ASTAT=0.0 22871 CALL CMPSTA( 22872 1 Y1,Y5,Y5,YM2(1,1),YM2(1,2),YM2(1,3),MAXNXT, 22873 1 NTEMP,NTEMP,NTEMP,NUMV2,ICASS7, 22874 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 22875 1 DTEMP1,DTEMP2,DTEMP3, 22876CCCCC1 IQUAME,IQUASE,PSTAMV, 22877 1 ASTAT, 22878 1 ISUBRO,IBUGA3,IERROR) 22879 YM9(IROW,ICOL)=ASTAT 22880 ELSE 22881 YM9(IROW,ICOL)=0.0 22882 ENDIF 22883 9572 CONTINUE 22884 9571 CONTINUE 22885C 22886 ITYP9='MATR' 22887 NR9=NROWPA 22888 NC9=NCOLPA 22889 IUPFLG='FULL' 22890 GOTO9000 22891C 22892 ENDIF 22893C 22894C ***************************************************** 22895C ** STEP 96-- ** 22896C ** TREAT THE MATRIX STATISTIC CASE ** 22897C ***************************************************** 22898C 22899C THIS COMMAND COMPUTES A SPECIFIED STATISTIC FOR THE ENTIRE MATRIX. 22900C 22901C NOTE 3/2007: ADD CRAMER CONTINGENCY COEFFICIENT AND 22902C PEARSON CONTINGENCY COEFFICIENT. THESE WORK 22903C DIFFERENTLY THAN THE OTHER STATISTICS IN THAT 22904C THEY ARE INTERPRETED AS RXC TABLES RATHER THAN 22905C ONE ARRAY CONTAINING ALL THE MATRIX OBSERVATIONS. 22906C 22907 9600 CONTINUE 22908C 22909 IWRITE='OFF' 22910 MAXNXT=MAXOBV 22911 IF(ICASS7.EQ.'INTE')NUMV2=1 22912C 22913 IF(ICASS7.EQ.'CRAM')THEN 22914 CALL CRAME2(YM1,MAXROM,NR1,NC1,IWRITE,Y1,ASTAT, 22915 1 IBUGA3,IERROR) 22916 GOTO9699 22917 ELSEIF(ICASS7.EQ.'PEAR')THEN 22918 CALL PEARC2(YM1,MAXROM,NR1,NC1,IWRITE,Y1,ASTAT, 22919 1 IBUGA3,IERROR) 22920 GOTO9699 22921 ENDIF 22922C 22923 ICNT=0 22924 DO9610I=1,NC1 22925 DO9620J=1,NR1 22926 ICNT=ICNT+1 22927 IF(ICNT.GT.MAXOBV)THEN 22928 WRITE(ICOUT,999) 22929 CALL DPWRST('XXX','BUG ') 22930 WRITE(ICOUT,9611) 22931 9611 FORMAT('***** ERROR FROM MATRIX STATISTIC--') 22932 CALL DPWRST('XXX','BUG ') 22933 WRITE(ICOUT,9613)MAXOBV 22934 9613 FORMAT(' THE NUMBER OF ELEMENTS IS GREATER THAN ', 22935 1 I10) 22936 CALL DPWRST('XXX','BUG ') 22937 IERROR='YES' 22938 GOTO9000 22939 ENDIF 22940 Y1(ICNT)=YM1(I,J) 22941 9620 CONTINUE 22942 9610 CONTINUE 22943 ASTAT=0.0 22944 CALL CMPSTA( 22945 1 Y1,Y2,Y2,Y3,Y4,Y5,MAXNXT,ICNT,ICNT,ICNT,NUMV2,ICASS7, 22946 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 22947 1 DTEMP1,DTEMP2,DTEMP3, 22948CCCCC1 IQUAME,IQUASE,PSTAMV, 22949 1 ASTAT, 22950 1 ISUBRO,IBUGA3,IERROR) 22951C 22952 9699 CONTINUE 22953 SCAL9=ASTAT 22954 ITYP9='SCAL' 22955 NR9=1 22956 NC9=1 22957 IUPFLG='FULL' 22958 GOTO9000 22959C 22960C ***************************************************** 22961C ** STEP 97-- ** 22962C ** TREAT THE MATRIX BIN CASE ** 22963C ***************************************************** 22964C 22965C THIS COMMAND BINS THE DATA IN A MATRIX (I.E., USEFUL FOR 22966C GENERATING A HISTOGRAM OF ALL THE POINTS IN THE MATRIX. 22967C 22968 9700 CONTINUE 22969C 22970 IWRITE='OFF' 22971 MAXNXT=MAXOBV 22972C 22973 ICNT=0 22974 DO9710I=1,NC1 22975 DO9720J=1,NR1 22976 ICNT=ICNT+1 22977 IF(ICNT.GT.MAXOBV)THEN 22978 WRITE(ICOUT,999) 22979 CALL DPWRST('XXX','BUG ') 22980 WRITE(ICOUT,9711) 22981 9711 FORMAT('***** ERROR FROM MATRIX STATISTIC--') 22982 CALL DPWRST('XXX','BUG ') 22983 WRITE(ICOUT,9713)MAXOBV 22984 9713 FORMAT(' THE NUMBER OF ELEMENTS IS GREATER THAN ', 22985 1 I10) 22986 CALL DPWRST('XXX','BUG ') 22987 IERROR='YES' 22988 GOTO9000 22989 ENDIF 22990 Y1(ICNT)=YM1(J,I) 22991 9720 CONTINUE 22992 9710 CONTINUE 22993C 22994 CALL DPBIN(Y1,ICNT,IRELAT,CLWID,XSTART,XSTOP,IRHSTG, 22995 1 Y4,MAXNXT,IHSTCW,IHSTOU, 22996 1 Y2,Y3,N2,IBUGA3,IERROR) 22997C 22998 ITYP9='VECT' 22999 NVECT9=N2 23000 IUPFLG='FULL' 23001 DO9760I=1,NVECT9 23002 VECT9(I)=Y2(I) 23003 Y2(I)=Y3(I) 23004 9760 CONTINUE 23005 GOTO9000 23006C 23007C ***************************************************** 23008C ** STEP 98-- ** 23009C ** TREAT THE MINIMAL SPANNING TREE CASE ** 23010C ** STEP 1: CREATE A DISTANCE MATRIX FROM THE ** 23011C ** TWO INPUT VECTORS (THE (X,Y) ** 23012C ** COORDINATES) ** 23013C ** STEP 2: CALL MINSPT TO COMPUTE THE EDGES OF ** 23014C ** THE MINIMAL SPANNING TREE ** 23015C ** STEP 3: CONVERT THESE EDGES TO A LIST OF ** 23016C ** VERTICES THAT CAN BE EASILY PLOTTED ** 23017C ***************************************************** 23018C 23019 9800 CONTINUE 23020C 23021C STEP 1: COMPUTE A DISTANCE MATRIX 23022C 23023 IF(N1.GT.MAXROM)THEN 23024 WRITE(ICOUT,999) 23025 CALL DPWRST('XXX','BUG ') 23026 WRITE(ICOUT,9801) 23027 9801 FORMAT('***** ERROR IN MATAR3--') 23028 CALL DPWRST('XXX','BUG ') 23029 WRITE(ICOUT,9803) 23030 9803 FORMAT(' FOR THE MINIMAL SPANNING TREE, UNABLE TO COMPUTE') 23031 CALL DPWRST('XXX','BUG ') 23032 WRITE(ICOUT,9805) 23033 9805 FORMAT(' DISTANCE MATRIX (TOO MANY POINTS).') 23034 CALL DPWRST('XXX','BUG ') 23035 WRITE(ICOUT,9806)N1 23036 9806 FORMAT(' THE NUMBER OF VERTICES = ',I8) 23037 CALL DPWRST('XXX','BUG ') 23038 WRITE(ICOUT,9807)MAXROM 23039 9807 FORMAT(' MAXIMUM NUMBER OF ALLOWED ROWS = ',I8,'.') 23040 CALL DPWRST('XXX','BUG ') 23041 IERROR='YES' 23042 GOTO9000 23043 ENDIF 23044C 23045 DO9810I=1,N1 23046 YM1(I,I)=0.0 23047 IF(I.EQ.N1)GOTO9810 23048 AY1=Y1(I) 23049 AX1=Y2(I) 23050 DO9820J=I+1,N1 23051 AY2=Y1(J) 23052 AX2=Y2(J) 23053 ADIST=SQRT((AX1 - AX2)**2 + (AY1 - AY2)**2) 23054 IF(ADIST.LE.0.0)THEN 23055 WRITE(ICOUT,999) 23056 CALL DPWRST('XXX','BUG ') 23057 WRITE(ICOUT,9801) 23058 CALL DPWRST('XXX','BUG ') 23059 WRITE(ICOUT,9823)I,J 23060 9823 FORMAT(' FOR ROW ',I8,' AND COLUMN ',I8,' THE ') 23061 CALL DPWRST('XXX','BUG ') 23062 WRITE(ICOUT,9825) 23063 9825 FORMAT(' COMPUTED DISTANCE IS ZERO.') 23064 CALL DPWRST('XXX','BUG ') 23065 IERROR='YES' 23066 GOTO9000 23067 ENDIF 23068 YM1(I,J)=ADIST 23069 YM1(J,I)=ADIST 23070 9820 CONTINUE 23071 9810 CONTINUE 23072 NR1=N1 23073C 23074C STEP 2: COMPUTE THE EDGES OF THE MINIMAL SPANNING TREE 23075C 23076 CALL MINSPT(YM1,MAXROM,NR1,ITEMP1,ITEMP2,ITEMP3,Y3) 23077C 23078C STEP 3: CONVERT TO A LIST OF VERTICES. NOTE THAT THERE ARE 23079C N-1 EDGES. AN EDGE ESSENTIALLY DEFINES TWO VERTICES. 23080C WE WILL ALSO DEFINED A "TAG" VARIABLE (THIS SIMPLIFIES 23081C PLOTTING). 23082C 23083 ICNT1=0 23084 DO9830I=1,NR1-1 23085 IINDX1=ITEMP1(I) 23086 IINDX2=ITEMP2(I) 23087 ICNT1=ICNT1+1 23088 Y3(ICNT1)=Y1(IINDX1) 23089 Y4(ICNT1)=Y2(IINDX1) 23090 ICNT1=ICNT1+1 23091 Y3(ICNT1)=Y1(IINDX2) 23092 Y4(ICNT1)=Y2(IINDX2) 23093 9830 CONTINUE 23094 NVECT9=ICNT1 23095C 23096 DO9840I=1,NVECT9 23097 VECT9(I)=Y3(I) 23098 Y2(I)=Y4(I) 23099 9840 CONTINUE 23100C 23101 NTAG=NVECT9/2 23102 ICNT1=0 23103 ICNT2=0 23104 DO9850I=1,NTAG 23105 ICNT2=ICNT2+1 23106 ICNT1=ICNT1+1 23107 Y3(ICNT1)=REAL(ICNT2) 23108 ICNT1=ICNT1+1 23109 Y3(ICNT1)=REAL(ICNT2) 23110 9850 CONTINUE 23111C 23112 ITYP9='VECT' 23113 IUPFLG='FULL' 23114 GOTO9000 23115C 23116C ***************************************************** 23117C ** STEP 99-- ** 23118C ** TREAT THE MINIMAL SPANNING TREE CASE ** 23119C ** FOR THIS VARIANT, WE START WITH A DISTANCE ** 23120C ** MATRIX (RATHER THAN THE VERTICES). THE ** 23121C ** DISTANCES MAY IN FACT REFLECT "COSTS" OR ** 23122C ** "WEIGHTINGS" AS OPPOSSED TO ACTUAL DISTANCES. ** 23123C ** IN THIS CASE, THE RETURNED OUTPUT IS THE ** 23124C ** LIST OF EDGES (I.E., WE DO NOT CONVERT BACK ** 23125C ** TO ORIGINAL VERTICES). ** 23126C ***************************************************** 23127C 23128 9900 CONTINUE 23129C 23130C STEP 1: CHECK FOR A SQUARE MATRIX 23131C 23132 IF(NR1.NE.NC1)THEN 23133 WRITE(ICOUT,999) 23134 CALL DPWRST('XXX','BUG ') 23135 WRITE(ICOUT,9901) 23136 9901 FORMAT('***** ERROR IN MATARI--') 23137 CALL DPWRST('XXX','BUG ') 23138 WRITE(ICOUT,9902) 23139 9902 FORMAT(' FOR MINIMUM SPANNING TREE, THE NUMBER OF ROWS') 23140 CALL DPWRST('XXX','BUG ') 23141 WRITE(ICOUT,9903) 23142 9903 FORMAT(' IN THE MATRIX MUST EQUAL THE NUMBER OF COLUMNS') 23143 CALL DPWRST('XXX','BUG ') 23144 WRITE(ICOUT,9905) 23145 9905 FORMAT(' IN THE MATRIX; SUCH WAS NOT THE CASE HERE.') 23146 CALL DPWRST('XXX','BUG ') 23147 WRITE(ICOUT,9907)NR1 23148 9907 FORMAT(' NUMBER OF ROWS =',I8) 23149 CALL DPWRST('XXX','BUG ') 23150 WRITE(ICOUT,9908)NC1 23151 9908 FORMAT(' NUMBER OF COLUMNS =',I8) 23152 CALL DPWRST('XXX','BUG ') 23153 IERROR='YES' 23154 GOTO9000 23155 ENDIF 23156C 23157C STEP 2: CHECK FOR A VALID DISTANCE MATRIX 23158C 23159C A) DIAGONAL ELEMENTS SHOULD BE ZERO 23160C B) ALL NON-DIAGONAL ELEMENTS SHOULD BE NON-ZERO 23161C C) DIST(I,J) = DIST(J,I) 23162C 23163C 23164 DO9910I=1,N1 23165C 23166 IF(ABS(YM1(I,I)).GT.0.1E-12)THEN 23167 WRITE(ICOUT,999) 23168 CALL DPWRST('XXX','BUG ') 23169 WRITE(ICOUT,9901) 23170 CALL DPWRST('XXX','BUG ') 23171 WRITE(ICOUT,9913) 23172 9913 FORMAT(' FOR THE MINIMAL SPANNING TREE, A DIAGONAL') 23173 CALL DPWRST('XXX','BUG ') 23174 WRITE(ICOUT,9915) 23175 9915 FORMAT(' ELEMENT OF THE DISTANCE MATRIX IS NON-ZERO.') 23176 CALL DPWRST('XXX','BUG ') 23177 WRITE(ICOUT,9917)I,YM1(I,I) 23178 9917 FORMAT(' THE VALUE OF ROW ',I8,' = ',G15.7) 23179 CALL DPWRST('XXX','BUG ') 23180 IERROR='YES' 23181 GOTO9000 23182 ENDIF 23183C 23184 DO9920J=I+1,N1 23185 IF(YM1(I,J).LE.0.0)THEN 23186 WRITE(ICOUT,999) 23187 CALL DPWRST('XXX','BUG ') 23188 WRITE(ICOUT,9901) 23189 CALL DPWRST('XXX','BUG ') 23190 WRITE(ICOUT,9921)I,J 23191 9921 FORMAT(' ROW ',I8,' AND COLUMN ',I8,' OF THE ') 23192 CALL DPWRST('XXX','BUG ') 23193 WRITE(ICOUT,9923) 23194 9923 FORMAT(' DISTANCE MATRIX IS NON-POSITIVE.') 23195 CALL DPWRST('XXX','BUG ') 23196 WRITE(ICOUT,9925) 23197 9925 FORMAT(' THE VALUE IS ',G15.7) 23198 CALL DPWRST('XXX','BUG ') 23199 IERROR='YES' 23200 GOTO9000 23201 ELSEIF(YM1(I,J).NE.YM1(J,I))THEN 23202 WRITE(ICOUT,999) 23203 CALL DPWRST('XXX','BUG ') 23204 WRITE(ICOUT,9901) 23205 CALL DPWRST('XXX','BUG ') 23206 WRITE(ICOUT,9931) 23207 9931 FORMAT(' THE DISTANCE MATRIX IS NOT SYMMETRIC.') 23208 CALL DPWRST('XXX','BUG ') 23209 WRITE(ICOUT,9933)I,J,YM1(I,J) 23210 9933 FORMAT(' ROW ',I8,' COLUMN ',I8,' = ',G15.7) 23211 CALL DPWRST('XXX','BUG ') 23212 WRITE(ICOUT,9933)J,I,YM1(J,I) 23213 CALL DPWRST('XXX','BUG ') 23214 IERROR='YES' 23215 GOTO9000 23216 ENDIF 23217 9920 CONTINUE 23218 9910 CONTINUE 23219 NR1=N1 23220C 23221C STEP 3: COMPUTE THE EDGES OF THE MINIMAL SPANNING TREE 23222C 23223 CALL MINSPT(YM1,MAXROM,NR1,ITEMP1,ITEMP2,ITEMP3,Y3) 23224C 23225C STEP 3: CONVERT TO A LIST OF VERTICES. NOTE THAT THERE ARE 23226C N-1 EDGES. AN EDGE ESSENTIALLY DEFINES TWO VERTICES. 23227C WE WILL ALSO DEFINED A "TAG" VARIABLE (THIS SIMPLIFIES 23228C PLOTTING). 23229C 23230 NVECT9=NR1-1 23231 DO9950I=1,NVECT9 23232 VECT9(I)=REAL(ITEMP1(I)) 23233 Y2(I)=REAL(ITEMP2(I)) 23234 9950 CONTINUE 23235C 23236 ITYP9='VECT' 23237 IUPFLG='FULL' 23238 GOTO9000 23239C 23240C ***************************************************** 23241C ** STEP 10000-- ** 23242C ** TREAT THE MATRIX RENUMBER CASE ** 23243C ***************************************************** 23244C 23245C THIS COMMAND REORDERS THE ROWS (BASED ON Y2) AND COLUMNS 23246C (BASED ON Y3) OF A MATRIX. 23247C 2324810000 CONTINUE 23249C 23250 IWRITE='OFF' 23251C 23252C STEP 1: CHECK Y2 AND Y3 23253C 23254 IF(N2.NE.NR1)THEN 23255 WRITE(ICOUT,999) 23256 CALL DPWRST('XXX','BUG ') 23257 WRITE(ICOUT,10001) 2325810001 FORMAT('***** ERROR FROM MATRIX RENUMBER--') 23259 CALL DPWRST('XXX','BUG ') 23260 WRITE(ICOUT,10003) 2326110003 FORMAT(' THE NUMBER OF ELEMENTS IN THE ROW ', 23262 1 'PERMUATION VECTOR') 23263 CALL DPWRST('XXX','BUG ') 23264 WRITE(ICOUT,10005) 2326510005 FORMAT(' IS NOT EQUAL TO THE NUMBER OF ROWS IN ', 23266 1 'THE MATRIX.') 23267 CALL DPWRST('XXX','BUG ') 23268 WRITE(ICOUT,10007)N2 2326910007 FORMAT(' NUMBER OF ELEMENTS IN THE ROW PERMUATION ', 23270 1 'VECTOR = ',I8) 23271 CALL DPWRST('XXX','BUG ') 23272 WRITE(ICOUT,10009)NR1 2327310009 FORMAT(' NUMBER OF ROWS IN THE MATRIX ', 23274 1 ' = ',I8) 23275 CALL DPWRST('XXX','BUG ') 23276 IERROR='YES' 23277 GOTO9000 23278 ENDIF 23279C 23280 DO10010I=1,N2 23281 ITEMP1(I)=INT(Y2(I)+0.1) 23282 Y4(I)=REAL(ITEMP1(I)) 2328310010 CONTINUE 23284 CALL DISTIN(Y4,N2,IWRITE,Y5,NDIST,IBUGA3,IERROR) 23285 CALL MINIM(Y4,N2,IWRITE,XMIN,IBUGA3,IERROR) 23286 CALL MAXIM(Y4,N2,IWRITE,XMAX,IBUGA3,IERROR) 23287C 23288 IF(N2.NE.NDIST)THEN 23289CCCCC WRITE(ICOUT,999) 23290CCCCC CALL DPWRST('XXX','BUG ') 23291CCCCC WRITE(ICOUT,10001) 23292CCCCC CALL DPWRST('XXX','BUG ') 23293CCCCC WRITE(ICOUT,10013) 23294C10013 FORMAT(' THE VALUES IN THE ROW PERMUTATION ', 23295CCCCC1 'VECTOR ARE NOT ALL UNIQUE.') 23296CCCCC CALL DPWRST('XXX','BUG ') 23297CCCCC IERROR='YES' 23298CCCCC GOTO9000 23299 ELSEIF(XMIN.LT.1.0)THEN 23300 WRITE(ICOUT,999) 23301 CALL DPWRST('XXX','BUG ') 23302 WRITE(ICOUT,10001) 23303 CALL DPWRST('XXX','BUG ') 23304 WRITE(ICOUT,10023) 2330510023 FORMAT(' THE MINIMUM VALUE IN THE ROW PERMUTATION ', 23306 1 'VECTOR') 23307 CALL DPWRST('XXX','BUG ') 23308 WRITE(ICOUT,10025) 2330910025 FORMAT(' IS LESS THAN ONE.') 23310 CALL DPWRST('XXX','BUG ') 23311 WRITE(ICOUT,10027)XMIN 2331210027 FORMAT(' THE MINIMUM VALUE IS ',G15.7) 23313 CALL DPWRST('XXX','BUG ') 23314 IERROR='YES' 23315 GOTO9000 23316 ELSEIF(XMAX.GT.REAL(N2))THEN 23317 WRITE(ICOUT,999) 23318 CALL DPWRST('XXX','BUG ') 23319 WRITE(ICOUT,10001) 23320 CALL DPWRST('XXX','BUG ') 23321 WRITE(ICOUT,10033) 2332210033 FORMAT(' THE MAXIMUM VALUE IN THE ROW PERMUTATION ', 23323 1 'VECTOR') 23324 CALL DPWRST('XXX','BUG ') 23325 WRITE(ICOUT,10035) 2332610035 FORMAT(' IS GREATER THAN THE NUMBER OF ELEMENTS.') 23327 CALL DPWRST('XXX','BUG ') 23328 WRITE(ICOUT,10037)XMAX 2332910037 FORMAT(' THE MAXIMUM VALUE IS ',G15.7) 23330 CALL DPWRST('XXX','BUG ') 23331 WRITE(ICOUT,10038)N2 2333210038 FORMAT(' THE NUMBER OF ELEMENTS IS ',I8) 23333 CALL DPWRST('XXX','BUG ') 23334 IERROR='YES' 23335 GOTO9000 23336 ENDIF 23337C 23338 IF(N3.NE.NC1)THEN 23339 WRITE(ICOUT,999) 23340 CALL DPWRST('XXX','BUG ') 23341 WRITE(ICOUT,10001) 23342 CALL DPWRST('XXX','BUG ') 23343 WRITE(ICOUT,10043) 2334410043 FORMAT(' THE NUMBER OF ELEMENTS IN THE COLUMN ', 23345 1 'PERMUATION VECTOR') 23346 CALL DPWRST('XXX','BUG ') 23347 WRITE(ICOUT,10045) 2334810045 FORMAT(' IS NOT EQUAL TO THE NUMBER OF COLUMNS IN ', 23349 1 'THE MATRIX.') 23350 CALL DPWRST('XXX','BUG ') 23351 WRITE(ICOUT,10047)N3 2335210047 FORMAT(' NUMBER OF ELEMENTS IN THE COLUMN PERMUATION ', 23353 1 'VECTOR = ',I8) 23354 CALL DPWRST('XXX','BUG ') 23355 WRITE(ICOUT,10049)NC1 2335610049 FORMAT(' NUMBER OF COLUMNS IN THE MATRIX ', 23357 1 ' = ',I8) 23358 CALL DPWRST('XXX','BUG ') 23359 IERROR='YES' 23360 GOTO9000 23361 ENDIF 23362C 23363 DO10050I=1,N3 23364 ITEMP2(I)=INT(Y3(I)+0.1) 23365 Y4(I)=REAL(ITEMP2(I)) 2336610050 CONTINUE 23367 CALL DISTIN(Y4,N3,IWRITE,Y5,NDIST,IBUGA3,IERROR) 23368 CALL MINIM(Y4,N3,IWRITE,XMIN,IBUGA3,IERROR) 23369 CALL MAXIM(Y4,N3,IWRITE,XMAX,IBUGA3,IERROR) 23370C 23371 IF(N3.NE.NDIST)THEN 23372CCCCC WRITE(ICOUT,999) 23373CCCCC CALL DPWRST('XXX','BUG ') 23374CCCCC WRITE(ICOUT,10001) 23375CCCCC CALL DPWRST('XXX','BUG ') 23376CCCCC WRITE(ICOUT,10053) 23377C10053 FORMAT(' THE VALUES IN THE COLUMN PERMUTATION ', 23378CCCCC1 'VECTOR ARE NOT ALL UNIQUE.') 23379CCCCC CALL DPWRST('XXX','BUG ') 23380CCCCC IERROR='YES' 23381CCCCC GOTO9000 23382 ELSEIF(XMIN.LT.1.0)THEN 23383 WRITE(ICOUT,999) 23384 CALL DPWRST('XXX','BUG ') 23385 WRITE(ICOUT,10001) 23386 CALL DPWRST('XXX','BUG ') 23387 WRITE(ICOUT,10063) 2338810063 FORMAT(' THE MINIMUM VALUE IN THE COLUMN PERMUTATION ', 23389 1 'VECTOR') 23390 CALL DPWRST('XXX','BUG ') 23391 WRITE(ICOUT,10065) 2339210065 FORMAT(' IS LESS THAN ONE.') 23393 CALL DPWRST('XXX','BUG ') 23394 WRITE(ICOUT,10067)XMIN 2339510067 FORMAT(' THE MINIMUM VALUE IS ',G15.7) 23396 CALL DPWRST('XXX','BUG ') 23397 IERROR='YES' 23398 GOTO9000 23399 ELSEIF(XMAX.GT.REAL(N3))THEN 23400 WRITE(ICOUT,999) 23401 CALL DPWRST('XXX','BUG ') 23402 WRITE(ICOUT,10001) 23403 CALL DPWRST('XXX','BUG ') 23404 WRITE(ICOUT,10073) 2340510073 FORMAT(' THE MAXIMUM VALUE IN THE ROW PERMUTATION ', 23406 1 'VECTOR') 23407 CALL DPWRST('XXX','BUG ') 23408 WRITE(ICOUT,10075) 2340910075 FORMAT(' IS GREATER THAN THE NUMBER OF ELEMENTS.') 23410 CALL DPWRST('XXX','BUG ') 23411 WRITE(ICOUT,10077)XMAX 2341210077 FORMAT(' THE MAXIMUM VALUE IS ',G15.7) 23413 CALL DPWRST('XXX','BUG ') 23414 WRITE(ICOUT,10078)N2 2341510078 FORMAT(' THE NUMBER OF ELEMENTS IS ',I8) 23416 CALL DPWRST('XXX','BUG ') 23417 IERROR='YES' 23418 GOTO9000 23419 ENDIF 23420C 23421 DO10081I=1,NR1 23422 DO10082J=1,NC1 23423 IROW=ITEMP1(I) 23424 ICOL=ITEMP2(J) 23425 YM9(IROW,ICOL)=YM1(I,J) 2342610082 CONTINUE 2342710081 CONTINUE 23428C 23429 ITYP9='MATR' 23430 NR9=NR1 23431 NC9=NC1 23432 IUPFLG='FULL' 23433 GOTO9000 23434C 23435C ***************************************************** 23436C ** STEP 10100-- ** 23437C ** TREAT THE ADJACENCY MATRIX CASE ** 23438C ***************************************************** 23439C 23440C THIS COMMAND CREATES AN ADJACENCY MATRIX FROM A LIST OF EDGES. 23441C 2344210100 CONTINUE 23443C 23444 IWRITE='OFF' 23445 NVERT=INT(YS3+0.1) 23446 NVERT=MAX(NVERT,N1) 23447 NVERT=MAX(NVERT,N2) 23448C 23449C STEP 1: CHECK TO SEE IF THE MATRIX WILL FIT 23450C 23451 IF(NVERT.GT.MAXROM)THEN 23452 WRITE(ICOUT,999) 23453 CALL DPWRST('XXX','BUG ') 23454 WRITE(ICOUT,10101) 2345510101 FORMAT('***** ERROR FROM ADJACENCY MATRIX--') 23456 CALL DPWRST('XXX','BUG ') 23457 WRITE(ICOUT,10103) 2345810103 FORMAT(' THE NUMBER OF VERTICES EXCEEDS THE ', 23459 1 'MAXIMUM') 23460 CALL DPWRST('XXX','BUG ') 23461 WRITE(ICOUT,10105) 2346210105 FORMAT(' NUMBER OF ROWS FOR A MATRIX.') 23463 CALL DPWRST('XXX','BUG ') 23464 WRITE(ICOUT,10107)NVERT 2346510107 FORMAT(' THE NUMBER OF VERTICES = ',I8) 23466 CALL DPWRST('XXX','BUG ') 23467 WRITE(ICOUT,10109)MAXROM 2346810109 FORMAT(' THE MAXIMUM NUMBER OF ROWS IN A MATRIX = ',I8) 23469 CALL DPWRST('XXX','BUG ') 23470 IERROR='YES' 23471 GOTO9000 23472 ENDIF 23473C 23474 IF(NVERT.GT.MAXCOM)THEN 23475 WRITE(ICOUT,999) 23476 CALL DPWRST('XXX','BUG ') 23477 WRITE(ICOUT,10101) 23478 CALL DPWRST('XXX','BUG ') 23479 WRITE(ICOUT,10113) 2348010113 FORMAT(' THE NUMBER OF VERTICES EXCEEDS THE ', 23481 1 'MAXIMUM') 23482 CALL DPWRST('XXX','BUG ') 23483 WRITE(ICOUT,10115) 2348410115 FORMAT(' NUMBER OF COLUMNS FOR A MATRIX.') 23485 CALL DPWRST('XXX','BUG ') 23486 WRITE(ICOUT,10117)NVERT 2348710117 FORMAT(' THE NUMBER OF VERTICES = ',I8) 23488 CALL DPWRST('XXX','BUG ') 23489 WRITE(ICOUT,10119)MAXROM 2349010119 FORMAT(' THE MAXIMUM NUMBER OF COLUMNS IN A MATRIX = ',I8) 23491 CALL DPWRST('XXX','BUG ') 23492 IERROR='YES' 23493 GOTO9000 23494 ENDIF 23495C 23496C STEP 2: NOW CREATE THE ADJACENCY MATRIX 23497C 23498C 23499 DO10120J=1,N1 23500 DO10130I=1,N1 23501 YM9(I,J)=0.0 2350210130 CONTINUE 2350310120 CONTINUE 23504C 23505 DO10140I=1,N1 23506 IROW=INT(Y1(I)+0.1) 23507C 23508 IF(IROW.LT.1 .OR. IROW.GT.NVERT)THEN 23509 WRITE(ICOUT,999) 23510 CALL DPWRST('XXX','BUG ') 23511 WRITE(ICOUT,10101) 23512 CALL DPWRST('XXX','BUG ') 23513 WRITE(ICOUT,10143)I 2351410143 FORMAT(' FOR EDGE ',I8,' THE ROW INDEX IS OUT OF') 23515 CALL DPWRST('XXX','BUG ') 23516 WRITE(ICOUT,10145)IROW 2351710145 FORMAT(' ROW INDEX = ',I8) 23518 CALL DPWRST('XXX','BUG ') 23519 IERROR='YES' 23520 GOTO9000 23521 ENDIF 23522C 23523 ICOL=INT(Y2(I)+0.1) 23524C 23525 IF(ICOL.LT.1 .OR. ICOL.GT.NVERT)THEN 23526 WRITE(ICOUT,999) 23527 CALL DPWRST('XXX','BUG ') 23528 WRITE(ICOUT,10101) 23529 CALL DPWRST('XXX','BUG ') 23530 WRITE(ICOUT,10153)I 2353110153 FORMAT(' FOR EDGE ',I8,' THE COLUMN INDEX IS OUT OF ', 23532 1 'RANGE.') 23533 CALL DPWRST('XXX','BUG ') 23534 WRITE(ICOUT,10155)ICOL 2353510155 FORMAT(' COLUMN INDEX = ',I8) 23536 CALL DPWRST('XXX','BUG ') 23537 IERROR='YES' 23538 GOTO9000 23539 ENDIF 23540C 23541 YM9(IROW,ICOL)=1.0 23542 IF(IMCASE.EQ.'ADMA')YM9(ICOL,IROW)=1.0 2354310140 CONTINUE 23544C 23545 ITYP9='MATR' 23546 NR9=NVERT 23547 NC9=NVERT 23548 IUPFLG='FULL' 23549 GOTO9000 23550C 23551C ************************************************ 23552C ** STEP 10200-- ** 23553C ** TREAT THE MATRIX ROW FIT CASE ** 23554C ** PERFORM A FIT OF EACH ROW OF THE MATRIX ** 23555C ** AGAINST A COMMON X VARIABLE. RIGHT NOW, ** 23556C ** LIMIT TO LINEAR FIT (BUT MAYBE ADD ** 23557C ** QUADRATIC FIT IN FUTURE). ** 23558C ************************************************ 23559C 23560CCCCC IMPLEMENTED FEBRUARY 2010. 2356110200 CONTINUE 23562C 23563 IF(N2.NE.NC1)THEN 23564 WRITE(ICOUT,999) 23565 CALL DPWRST('XXX','BUG ') 23566 WRITE(ICOUT,10201) 2356710201 FORMAT('****** ERROR IN MATRIX ROW FIT--') 23568 CALL DPWRST('XXX','BUG ') 23569 WRITE(ICOUT,10202)NC1 2357010202 FORMAT(' THE NUMBER OF COLUMNS IN THE MATRIX (',I8,') ', 23571 1 'IS NOT EQUAL') 23572 CALL DPWRST('XXX','BUG ') 23573 WRITE(ICOUT,10203)N1 2357410203 FORMAT(' THE NUMBER OF ROWS IN THE X VARIABLE (',I8,').') 23575 CALL DPWRST('XXX','BUG ') 23576 IERROR='YES' 23577 GOTO9000 23578 ENDIF 23579C 23580 DO10210I=1,NR1 23581 DO10220J=1,NC1 23582 Y3(J)=YM1(I,J) 2358310220 CONTINUE 23584 ICNT=0 23585 DO10230J=1,NC1 23586 IF(Y3(J).EQ.PSTAMV)GOTO10230 23587 ICNT=ICNT+1 23588 Y4(ICNT)=Y2(J) 23589 Y3(ICNT)=Y3(J) 2359010230 CONTINUE 23591 NPTS=ICNT 23592 IF(NPTS.LE.0)THEN 23593 PPA0=PSTAMV 23594 PPA1=PSTAMV 23595 PPA0SD=PSTAMV 23596 PPA1SD=PSTAMV 23597 ELSE 23598 CALL LINFIT(Y3,Y4,NPTS, 23599 1 PPA0,PPA1,XRESSD,XRESDF,PPCC,SDPPA0,SDPPA1,CCALBE, 23600 1 ISUBRO,IBUGA3,IERROR) 23601 ENDIF 23602 YM9(I,1)=PPA0 23603 YM9(I,2)=PPA1 23604 YM9(I,3)=SDPPA0 23605 YM9(I,4)=SDPPA1 2360610210 CONTINUE 23607C 23608 ITYP9='VECT' 23609 NR9=1 23610 NC9=1 23611 DO10240I=1,NR1 23612 VECT9(I)=YM9(I,1) 23613 Y2(I)=YM9(I,2) 23614 Y3(I)=YM9(I,3) 23615 Y4(I)=YM9(I,4) 2361610240 CONTINUE 23617 NVECT9=NR1 23618 IUPFLG='FULL' 23619 GOTO9000 23620C 23621C ************************************************* 23622C ** STEP 10300-- ** 23623C ** TREAT THE MATRIX COLUMN FIT CASE ** 23624C ** PERFORM A FIT OF EACH COLUMN OF THE MATRIX ** 23625C ** AGAINST A COMMON X VARIABLE. RIGHT NOW, ** 23626C ** LIMIT TO LINEAR FIT (BUT MAYBE ADD ** 23627C ** QUADRATIC FIT IN FUTURE). ** 23628C ************************************************* 23629C 23630CCCCC IMPLEMENTED FEBRUARY 2010. 2363110300 CONTINUE 23632C 23633 IF(N2.NE.NR1)THEN 23634 WRITE(ICOUT,999) 23635 CALL DPWRST('XXX','BUG ') 23636 WRITE(ICOUT,10301) 2363710301 FORMAT('****** ERROR IN MATRIX COLUMN FIT--') 23638 CALL DPWRST('XXX','BUG ') 23639 WRITE(ICOUT,10302)NR1 2364010302 FORMAT(' THE NUMBER OF ROWS IN THE MATRIX (',I8,') ', 23641 1 'IS NOT EQUAL') 23642 CALL DPWRST('XXX','BUG ') 23643 WRITE(ICOUT,10303)N1 2364410303 FORMAT(' THE NUMBER OF ROWS IN THE X VARIABLE (',I8,').') 23645 CALL DPWRST('XXX','BUG ') 23646 IERROR='YES' 23647 GOTO9000 23648 ENDIF 23649C 23650 DO10310I=1,NC1 23651 DO10320J=1,NR1 23652 Y3(J)=YM1(J,I) 2365310320 CONTINUE 23654 ICNT=0 23655 DO10330J=1,NR1 23656 IF(Y3(J).EQ.PSTAMV)GOTO10330 23657 ICNT=ICNT+1 23658 Y4(ICNT)=Y2(J) 23659 Y3(ICNT)=Y3(J) 2366010330 CONTINUE 23661 NPTS=ICNT 23662 IF(NPTS.LE.0)THEN 23663 PPA0=PSTAMV 23664 PPA1=PSTAMV 23665 PPA0SD=PSTAMV 23666 PPA1SD=PSTAMV 23667 ELSE 23668 CALL LINFIT(Y3,Y4,NPTS, 23669 1 PPA0,PPA1,XRESSD,XRESDF,PPCC,SDPPA0,SDPPA1,CCALBE, 23670 1 ISUBRO,IBUGA3,IERROR) 23671 ENDIF 23672 YM9(I,1)=PPA0 23673 YM9(I,2)=PPA1 23674 YM9(I,3)=SDPPA0 23675 YM9(I,4)=SDPPA1 2367610310 CONTINUE 23677C 23678 ITYP9='VECT' 23679 NR9=1 23680 NC9=1 23681 DO10340I=1,NC1 23682 VECT9(I)=YM9(I,1) 23683 Y2(I)=YM9(I,2) 23684 Y3(I)=YM9(I,3) 23685 Y4(I)=YM9(I,4) 2368610340 CONTINUE 23687 NVECT9=NC1 23688 IUPFLG='FULL' 23689 GOTO9000 23690C 23691C ************************************************* 23692C ** STEP 10400-- ** 23693C ** TREAT THE VARIABLE TO MATRIX CASE ** 23694C ************************************************* 23695C 23696CCCCC IMPLEMENTED NOVEMBER 2010. 2369710400 CONTINUE 23698C 23699 NROW=INT(YS2+0.1) 23700 NCOL=N1/NROW 23701 NREM=N1 - (NROW*NCOL) 23702 IF(NREM.GT.0)NCOL=NCOL+1 23703C 23704 IF(NROW.GT.MAXROM)THEN 23705 WRITE(ICOUT,999) 23706 CALL DPWRST('XXX','BUG ') 23707 WRITE(ICOUT,10401) 2370810401 FORMAT('****** ERROR IN VARIABLE TO MATRIX--') 23709 CALL DPWRST('XXX','BUG ') 23710 WRITE(ICOUT,10402)NROW 2371110402 FORMAT(' THE REQUESTED NUMBER OF ROWS FOR THE MATRIX (', 23712 1 I8,') ','IS TOO LARGE.') 23713 CALL DPWRST('XXX','BUG ') 23714 WRITE(ICOUT,10403)MAXROM 2371510403 FORMAT(' THE MAXIMUM NUMBER OF ROWS = (',I8,').') 23716 CALL DPWRST('XXX','BUG ') 23717 IERROR='YES' 23718 GOTO9000 23719 ENDIF 23720C 23721 IF(NCOL.GT.MAXCOM)THEN 23722 WRITE(ICOUT,999) 23723 CALL DPWRST('XXX','BUG ') 23724 WRITE(ICOUT,10411) 2372510411 FORMAT('****** ERROR IN VARIABLE TO MATRIX--') 23726 CALL DPWRST('XXX','BUG ') 23727 WRITE(ICOUT,10412)NCOL 2372810412 FORMAT(' THE REQUESTED NUMBER OF COLUMNS FOR THE MATRIX (', 23729 1 I8,') ','IS TOO LARGE.') 23730 CALL DPWRST('XXX','BUG ') 23731 WRITE(ICOUT,10413)MAXCOM 2373210413 FORMAT(' THE MAXIMUM NUMBER OF COLUMNS = (',I8,').') 23733 CALL DPWRST('XXX','BUG ') 23734 IERROR='YES' 23735 GOTO9000 23736 ENDIF 23737C 23738 IF(IVARMA.EQ.'COLU')THEN 23739 ICNT=0 23740 DO10420J=1,NCOL 23741 DO10430I=1,NROW 23742 ICNT=ICNT+1 23743 IF(ICNT.LE.N1)THEN 23744 YM9(I,J)=Y1(ICNT) 23745 ELSE 23746 YM9(I,J)=PSTAMV 23747 ENDIF 2374810430 CONTINUE 2374910420 CONTINUE 23750 ELSE 23751 ICNT=0 23752 DO10470I=1,NROW 23753 DO10480J=1,NCOL 23754 ICNT=ICNT+1 23755 IF(ICNT.LE.N1)THEN 23756 YM9(I,J)=Y1(ICNT) 23757 ELSE 23758 YM9(I,J)=PSTAMV 23759 ENDIF 2376010480 CONTINUE 2376110470 CONTINUE 23762 ENDIF 23763C 23764 ITYP9='MATR' 23765 NR9=NROW 23766 NC9=NCOL 23767 IUPFLG='FULL' 23768 GOTO9000 23769C 23770C ************************************************* 23771C ** STEP 10500-- ** 23772C ** TREAT THE MATRIX TO VARIABLE CASE ** 23773C ************************************************* 23774C 23775CCCCC IMPLEMENTED NOVEMBER 2010. 2377610500 CONTINUE 23777C 23778 IF(IMATVA.EQ.'COLU')THEN 23779 ICNT=0 23780 DO10520J=1,NC1 23781 DO10530I=1,NR1 23782 ICNT=ICNT+1 23783 IF(ICNT.LE.MAXOBV)THEN 23784 VECT9(ICNT)=YM1(I,J) 23785 ELSE 23786 WRITE(ICOUT,999) 23787 CALL DPWRST('XXX','BUG ') 23788 WRITE(ICOUT,10501) 2378910501 FORMAT('****** ERROR IN MATRIX TO VARIABLE--') 23790 CALL DPWRST('XXX','BUG ') 23791 WRITE(ICOUT,10502)MAXOBV 2379210502 FORMAT(' MAXIMUM NUMBER OF ROWS IN VARIABLE (', 23793 1 I8,') EXCEEDED.') 23794 CALL DPWRST('XXX','BUG ') 23795 IERROR='YES' 23796 GOTO9000 23797 ENDIF 2379810530 CONTINUE 2379910520 CONTINUE 23800 ELSE 23801 ICNT=0 23802 DO10570I=1,NR1 23803 DO10580J=1,NC1 23804 ICNT=ICNT+1 23805 IF(ICNT.LE.MAXOBV)THEN 23806 VECT9(ICNT)=YM1(I,J) 23807 ELSE 23808 WRITE(ICOUT,999) 23809 CALL DPWRST('XXX','BUG ') 23810 WRITE(ICOUT,10501) 23811 CALL DPWRST('XXX','BUG ') 23812 WRITE(ICOUT,10502)MAXOBV 23813 CALL DPWRST('XXX','BUG ') 23814 IERROR='YES' 23815 GOTO9000 23816 ENDIF 2381710580 CONTINUE 2381810570 CONTINUE 23819 ENDIF 23820C 23821 ITYP9='VECT' 23822 NVECT9=ICNT 23823 IUPFLG='FULL' 23824 GOTO9000 23825C 23826C ***************************************************** 23827C ** STEP 10600- ** 23828C ** TREAT THE MATRIX COMBINE ROW CASE ** 23829C ***************************************************** 23830C 2383110600 CONTINUE 23832C 23833 IF(NC1.NE.NC2)THEN 23834 WRITE(ICOUT,999) 23835 CALL DPWRST('XXX','BUG ') 23836 WRITE(ICOUT,10611) 2383710611 FORMAT('***** ERROR IN MATRIX COMBINE ROW--') 23838 CALL DPWRST('XXX','BUG ') 23839 WRITE(ICOUT,10613) 2384010613 FORMAT(' THE NUMBER OF COLUMNS IN THE TWO MATRICES IS ', 23841 1 'NOT EQUAL.') 23842 CALL DPWRST('XXX','BUG ') 23843 WRITE(ICOUT,10615)NC1 2384410615 FORMAT(' THE NUMBER OF COLUMNS FOR THE FIRST MATRIX: ', 23845 1 I8) 23846 CALL DPWRST('XXX','BUG ') 23847 WRITE(ICOUT,10617)NC2 2384810617 FORMAT(' THE NUMBER OF COLUMNS FOR THE SECOND MATRIX: ', 23849 1 I8) 23850 CALL DPWRST('XXX','BUG ') 23851 IERROR='YES' 23852 GOTO9000 23853 ENDIF 23854C 23855 DO10610J=1,NC1 23856 DO10620I=1,NR1 23857 YM9(I,J)=YM1(I,J) 2385810620 CONTINUE 23859 DO10630I=1,NR2 23860 IINDX=I+NR1 23861 IF(IINDX.GT.MAXROM)THEN 23862 WRITE(ICOUT,999) 23863 CALL DPWRST('XXX','BUG ') 23864 WRITE(ICOUT,10611) 23865 CALL DPWRST('XXX','BUG ') 23866 WRITE(ICOUT,10633) 2386710633 FORMAT(' THE MAXIMUM NUMBER OF ROWS FOR THE ', 23868 1 'OUTPUT MATRIX HAS BEEN EXCEEDED.') 23869 CALL DPWRST('XXX','BUG ') 23870 WRITE(ICOUT,10635)MAXROM 2387110635 FORMAT(' THE MAXIMUM NUMBER OF ROWS = ',I8) 23872 CALL DPWRST('XXX','BUG ') 23873 WRITE(ICOUT,10637)NR1+NR2 2387410637 FORMAT(' THE REQUIRED NUMBER OF ROWS = ',I8) 23875 CALL DPWRST('XXX','BUG ') 23876 IERROR='YES' 23877 GOTO9000 23878 ENDIF 23879 YM9(I+NR1,J)=YM2(I,J) 2388010630 CONTINUE 2388110610 CONTINUE 23882C 23883 ITYP9='MATR' 23884 NC9=NC1 23885 NR9=NR1+NR2 23886 IUPFLG='FULL' 23887 GOTO9000 23888C 23889C ***************************************************** 23890C ** STEP 10700- ** 23891C ** TREAT THE MATRIX COMBINE COLUMN CASE ** 23892C ***************************************************** 23893C 2389410700 CONTINUE 23895C 23896 IF(NR1.NE.NR2)THEN 23897 WRITE(ICOUT,999) 23898 CALL DPWRST('XXX','BUG ') 23899 WRITE(ICOUT,10711) 2390010711 FORMAT('***** ERROR IN MATRIX COMBINE COLUMN--') 23901 CALL DPWRST('XXX','BUG ') 23902 WRITE(ICOUT,10713) 2390310713 FORMAT(' THE NUMBER OF ROWS IN THE TWO MATRICES IS ', 23904 1 'NOT EQUAL.') 23905 CALL DPWRST('XXX','BUG ') 23906 WRITE(ICOUT,10715)NR1 2390710715 FORMAT(' THE NUMBER OF ROWS FOR THE FIRST MATRIX: ', 23908 1 I8) 23909 CALL DPWRST('XXX','BUG ') 23910 WRITE(ICOUT,10717)NR2 2391110717 FORMAT(' THE NUMBER OF ROWS FOR THE SECOND MATRIX: ', 23912 1 I8) 23913 CALL DPWRST('XXX','BUG ') 23914 IERROR='YES' 23915 GOTO9000 23916 ENDIF 23917C 23918 DO10710I=1,NR1 23919 DO10720J=1,NC1 23920 YM9(I,J)=YM1(I,J) 2392110720 CONTINUE 23922 DO10730J=1,NC2 23923 IINDX=I+NC1 23924 IF(IINDX.GT.MAXCOM)THEN 23925 WRITE(ICOUT,999) 23926 CALL DPWRST('XXX','BUG ') 23927 WRITE(ICOUT,10711) 23928 CALL DPWRST('XXX','BUG ') 23929 WRITE(ICOUT,10733) 2393010733 FORMAT(' THE MAXIMUM NUMBER OF COLUMNS FOR THE ', 23931 1 'OUTPUT MATRIX HAS BEEN EXCEEDED.') 23932 CALL DPWRST('XXX','BUG ') 23933 WRITE(ICOUT,10735)MAXCOM 2393410735 FORMAT(' THE MAXIMUM NUMBER OF COLUMNS = ',I8) 23935 CALL DPWRST('XXX','BUG ') 23936 WRITE(ICOUT,10737)NC1+NC2 2393710737 FORMAT(' THE REQUIRED NUMBER OF COLUMNS = ',I8) 23938 CALL DPWRST('XXX','BUG ') 23939 IERROR='YES' 23940 GOTO9000 23941 ENDIF 23942 YM9(I,J+NC1)=YM2(I,J) 2394310730 CONTINUE 2394410710 CONTINUE 23945C 23946 ITYP9='MATR' 23947 NC9=NC1+NC2 23948 NR9=NR1 23949 IUPFLG='FULL' 23950 GOTO9000 23951C 23952C ***************************************************** 23953C ** STEP 10800- ** 23954C ** TREAT THE DEX CORE CASE ** 23955C ***************************************************** 23956C 2395710800 CONTINUE 23958C 23959 MAXK=25 23960 NROW=10000 23961 CALL DPCORE(YM1,NC1,NR1,MAXROM,MAXK, 23962 1 YM9,ITEMP1,NROW,NUMCOR, 23963 1 ITEMP2,Y1,Y2, 23964 1 IBUGA3,ISUBRO,IERROR) 23965C 23966 ITYP9='MATR' 23967 NC9=5 23968 NR9=NUMCOR 23969 IUPFLG='FULL' 23970 GOTO9000 23971C 23972C ***************************************************** 23973C ** STEP 10900- ** 23974C ** TREAT THE DEX CONFOUND CASE ** 23975C ***************************************************** 23976C 2397710900 CONTINUE 23978C 23979 MAXK=25 23980 MAX2T=500 23981 IF(NR1*MAX2T.GT.46*MAXOBV/3)THEN 23982 WRITE(ICOUT,10901) 2398310901 FORMAT('***** ERROR IN DEX CONFOUND--') 23984 CALL DPWRST('XXX','BUG ') 23985 WRITE(ICOUT,10903) 2398610903 FORMAT(' INSUFFICIENT SPACE TO GENERATE CONFOUNDING ', 23987 1 'STRUCTURE.') 23988 CALL DPWRST('XXX','BUG ') 23989 IERROR='YES' 23990 GOTO9000 23991 ENDIF 23992 CALL DPDCF2(YM1,NC1,NR1,MAXK,MAXROM, 23993 1 YM2,MAX2T, 23994 1 Y1,Y3,Y4,VECT9,Y2, 23995 1 INDEX,ITEMP1, 23996 1 ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,ITEMP7, 23997 1 STME,STMEC,ST2T,ST2TC,STC,STT, 23998 1 NUMCON, 23999 1 IBUGA3,ISUBRO,IERROR) 24000C 24001 ITYP9='VECT' 24002 NVECT9=NUMCON 24003 IUPFLG='FULL' 24004 GOTO9000 24005C 24006C ***************************************************** 24007C ** STEP 11000- ** 24008C ** TREAT THE DEX CHECK CLASSIC CASE ** 24009C ***************************************************** 24010C 2401111000 CONTINUE 24012C 24013C CHECK IF MATRIX IS IN "CLASSIC" FORM FOR 2-LEVEL FACTORIAL DESIGN. 24014C THAT IS, IF A VALUE OTHER THAN -1, 0, OR 1 IS DETECTED, THEN THE 24015C MATRIX IS NOT IN CLASSIC FORM. SET OUTPUT TO 1 FOR THE CLASSIC 24016C CASE AND 0 OTHERWISE. 24017C 24018 SCAL9=1.0 24019 DO11010J=1,NC1 24020 DO11020I=1,NR1 24021 IF(YM1(I,J).EQ.-1.0 .OR. YM1(I,J).EQ.0.0 .OR. 24022 1 YM1(I,J).EQ.1.0)GOTO11020 24023 SCAL9=0.0 24024 GOTO11030 2402511020 CONTINUE 2402611010 CONTINUE 24027C 2402811030 CONTINUE 24029 ITYP9='SCAL' 24030 IUPFLG='FULL' 24031 GOTO9000 24032C 24033C ***************************************************** 24034C ** STEP 11000- ** 24035C ** TREAT THE DEX CHECK CENTER POINT CASE ** 24036C ***************************************************** 24037C 2403811100 CONTINUE 24039C 24040C CHECK FOR CENTER POINTS IN A LIST OF FACTOR VARIABLES. CREATE 24041C A TAG VARIABLE THAT WILL BE 1 FOR ROWS THAT ARE NOT CENTER POINTS 24042C 0 FOR ROWS THAT ARE CENTER POINTS. 24043C 24044C 2018/10: UPDATE SO THAT WE DO NOT ASSUME THE FACTORS ARE IN 24045C CLASSIC UNITS (I.E., CENTER POINT EQUAL 0). INSTEAD, 24046C CHECK IF EQUAL TO THE MEDIAN VALUE OF THE DISTINCT 24047C VALUES (FOR EVEN NUMBER OF DISTINCT LEVELS NO CENTER 24048C POINT WILL BE DETECTED, FOR ODD NUMBER OF DISTINCT 24049C LEVELS, CENTER POINT EQUALS THE MEDIAN). 24050C 24051 SCAL9=1.0 24052 DO11110I=1,NR1 24053 IFLAG=0 24054 DO11120J=1,NC1 24055C 24056C FOR COLUMN J, DETERMINE THE CENTER POINT (= THE MEDIAN 24057C OF THE DISTINCT VALUES) 24058C 24059 DO11130K=1,NR1 24060 Y1(K)=YM1(K,J) 2406111130 CONTINUE 24062 CALL DISTIN(Y1,NR1,IWRITE,Y2,NDIST,IBUGA3,IERROR) 24063 CALL MEDIAN(Y2,NDIST,IWRITE,Y3,MAXOBV,YMED,IBUGA3,IERROR) 24064C 24065C NOW CHECK WHETHER THE CURRENT ROW IS EQUAL TO THE MEDIAN 24066C 24067 IF(YM1(I,J).NE.YMED)THEN 24068 IFLAG=1 24069 GOTO11129 24070 ENDIF 2407111120 CONTINUE 2407211129 CONTINUE 24073 VECT9(I)=REAL(IFLAG) 2407411110 CONTINUE 24075C 24076 ITYP9='VECT' 24077 NVECT9=NR1 24078 IUPFLG='FULL' 24079 GOTO9000 24080C 24081C ***************** 24082C ** STEP 90-- ** 24083C ** EXIT. ** 24084C ***************** 24085C 24086 9000 CONTINUE 24087C 24088 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'ATR3')GOTO9090 24089C 24090 WRITE(ICOUT,999) 24091 CALL DPWRST('XXX','BUG ') 24092 WRITE(ICOUT,9011) 24093 9011 FORMAT('***** AT THE END OF MATAR3--') 24094 CALL DPWRST('XXX','BUG ') 24095 WRITE(ICOUT,9012)IBUGA3,ISUBRO,IMCASE,ITYPA1,ITYPA2,ITYPA3,ITYPA4 24096 9012 FORMAT('IBUGA3,ISUBRO,IMCASE,ITYPA1,ITYPA2,ITYPA3,ITYPA4 = ', 24097 1A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4) 24098 CALL DPWRST('XXX','BUG ') 24099 WRITE(ICOUT,9013)IMCASE,IMSUBC 24100 9013 FORMAT('IMCASE,IMSUBC = ',A4,2X,A4) 24101 CALL DPWRST('XXX','BUG ') 24102 WRITE(ICOUT,9014)NUMVAR,IWRITE 24103 9014 FORMAT('NUMVAR,IWRITE = ',I8,2X,A4) 24104 CALL DPWRST('XXX','BUG ') 24105 WRITE(ICOUT,9015)YS1,YS2,YS3,YS4 24106 9015 FORMAT('YS1,YS2,YS3,YS4 = ',4E15.7) 24107 CALL DPWRST('XXX','BUG ') 24108 WRITE(ICOUT,9016)IERROR 24109 9016 FORMAT('IERROR = ',A4) 24110 CALL DPWRST('XXX','BUG ') 24111 WRITE(ICOUT,9017)IYS2,IYS3,IYS23,NRJ,NCJ 24112 9017 FORMAT('IYS2,IYS3,IYS23,NRJ,NCJ = ',5I8) 24113 CALL DPWRST('XXX','BUG ') 24114C 24115 WRITE(ICOUT,999) 24116 CALL DPWRST('XXX','BUG ') 24117 WRITE(ICOUT,9031)NR1,NC1 24118 9031 FORMAT('NR1,NC1 = ',2I8) 24119 CALL DPWRST('XXX','BUG ') 24120 IF(NR1.LE.0)GOTO9039 24121 IF(NC1.LE.0)GOTO9039 24122 JMAX=NC1 24123 IF(JMAX.GT.10)JMAX=10 24124 DO9032I=1,NR1 24125 WRITE(ICOUT,9033)I,(YM1(I,J),J=1,JMAX) 24126 9033 FORMAT('I,YM1(I,.) = ',I8,10E10.3) 24127 CALL DPWRST('XXX','BUG ') 24128 9032 CONTINUE 24129 9039 CONTINUE 24130C 24131 WRITE(ICOUT,999) 24132 CALL DPWRST('XXX','BUG ') 24133 WRITE(ICOUT,9041)NR2,NC2 24134 9041 FORMAT('NR2,NC2 = ',2I8) 24135 CALL DPWRST('XXX','BUG ') 24136 IF(NR2.LE.0)GOTO9049 24137 IF(NC2.LE.0)GOTO9049 24138 JMAX=NC2 24139 IF(JMAX.GT.10)JMAX=10 24140 DO9042I=1,NR2 24141 WRITE(ICOUT,9043)I,(YM2(I,J),J=1,JMAX) 24142 9043 FORMAT('I,YM2(I,.) = ',I8,10E10.3) 24143 CALL DPWRST('XXX','BUG ') 24144 9042 CONTINUE 24145 9049 CONTINUE 24146C 24147 WRITE(ICOUT,999) 24148 CALL DPWRST('XXX','BUG ') 24149 WRITE(ICOUT,9051)NR9,NC9 24150 9051 FORMAT('NR9,NC9 = ',2I8) 24151 CALL DPWRST('XXX','BUG ') 24152 IF(NR9.LE.0)GOTO9059 24153 IF(NC9.LE.0)GOTO9059 24154 JMAX=NC9 24155 IF(JMAX.GT.10)JMAX=10 24156 DO9055I=1,NR9 24157 WRITE(ICOUT,9056)I,(YM9(I,J),J=1,JMAX) 24158 9056 FORMAT('I,YM9(I,.) = ',I8,10E10.3) 24159 CALL DPWRST('XXX','BUG ') 24160 9055 CONTINUE 24161 9059 CONTINUE 24162C 24163 WRITE(ICOUT,999) 24164 CALL DPWRST('XXX','BUG ') 24165 WRITE(ICOUT,9111)N1 24166 9111 FORMAT('N1 = ',I8) 24167 CALL DPWRST('XXX','BUG ') 24168 IF(N1.LE.0)GOTO9119 24169 DO9112I=1,N1 24170 WRITE(ICOUT,9113)I,Y1(I) 24171 9113 FORMAT('I,Y1(I) = ',I8,E15.7) 24172 CALL DPWRST('XXX','BUG ') 24173 9112 CONTINUE 24174 9119 CONTINUE 24175C 24176 WRITE(ICOUT,999) 24177 CALL DPWRST('XXX','BUG ') 24178 WRITE(ICOUT,9121)N2 24179 9121 FORMAT('N2 = ',I8) 24180 CALL DPWRST('XXX','BUG ') 24181 IF(N2.LE.0)GOTO9129 24182 DO9122I=1,N2 24183 WRITE(ICOUT,9123)I,Y2(I) 24184 9123 FORMAT('I,Y2(I) = ',I8,E15.7) 24185 CALL DPWRST('XXX','BUG ') 24186 9122 CONTINUE 24187 9129 CONTINUE 24188C 24189 WRITE(ICOUT,999) 24190 CALL DPWRST('XXX','BUG ') 24191 WRITE(ICOUT,9131)N3 24192 9131 FORMAT('N3 = ',I8) 24193 CALL DPWRST('XXX','BUG ') 24194 IF(N3.LE.0)GOTO9139 24195 DO9132I=1,N3 24196 WRITE(ICOUT,9133)I,Y3(I) 24197 9133 FORMAT('I,Y3(I) = ',I8,E15.7) 24198 CALL DPWRST('XXX','BUG ') 24199 9132 CONTINUE 24200 9139 CONTINUE 24201C 24202 WRITE(ICOUT,999) 24203 CALL DPWRST('XXX','BUG ') 24204 WRITE(ICOUT,9141)N4 24205 9141 FORMAT('N4 = ',I8) 24206 CALL DPWRST('XXX','BUG ') 24207 IF(N4.LE.0)GOTO9149 24208 DO9142I=1,N4 24209 WRITE(ICOUT,9143)I,Y4(I) 24210 9143 FORMAT('I,Y4(I) = ',I8,E15.7) 24211 CALL DPWRST('XXX','BUG ') 24212 9142 CONTINUE 24213 9149 CONTINUE 24214C 24215 WRITE(ICOUT,999) 24216 CALL DPWRST('XXX','BUG ') 24217 WRITE(ICOUT,9151)ITYP9,SCAL9 24218 9151 FORMAT('ITYP9,SCAL9 = ',A4,2X,E15.7) 24219 CALL DPWRST('XXX','BUG ') 24220C 24221 WRITE(ICOUT,999) 24222 CALL DPWRST('XXX','BUG ') 24223 WRITE(ICOUT,9161)NVECT9 24224 9161 FORMAT('NVECT9 = ',I8) 24225 CALL DPWRST('XXX','BUG ') 24226 IF(NVECT9.LE.0)GOTO9169 24227 DO9162I=1,NVECT9 24228 WRITE(ICOUT,9163)I,VECT9(I) 24229 9163 FORMAT('I,VECT9(I) = ',I8,E15.7) 24230 CALL DPWRST('XXX','BUG ') 24231 9162 CONTINUE 24232 9169 CONTINUE 24233C 24234 WRITE(ICOUT,999) 24235 CALL DPWRST('XXX','BUG ') 24236 WRITE(ICOUT,9171)NR9,NC9 24237 9171 FORMAT('NR9,NC9 = ',2I8) 24238 CALL DPWRST('XXX','BUG ') 24239 IF(NR9.LE.0)GOTO9179 24240 IF(NC9.LE.0)GOTO9179 24241 JMAX=NC9 24242 IF(JMAX.GT.10)JMAX=10 24243 DO9172I=1,NR9 24244 WRITE(ICOUT,9173)I,(YM9(I,J),J=1,JMAX) 24245 9173 FORMAT('I,YM9(I,.) = ',I8,10E10.3) 24246 CALL DPWRST('XXX','BUG ') 24247 9172 CONTINUE 24248 9179 CONTINUE 24249C 24250 IF(IMCASE.NE.'MASS')GOTO9189 24251 WRITE(ICOUT,9181)NR2,NC2 24252 9181 FORMAT('NR2,NC2 = ',2I8) 24253 CALL DPWRST('XXX','BUG ') 24254 IF(NR2.LE.0)GOTO9189 24255 IF(NC2.LE.0)GOTO9189 24256 JMAX=NC2+1 24257 IF(JMAX.GT.10)JMAX=10 24258 NR2P1=NR2+1 24259 DO9182I=1,NR2P1 24260 WRITE(ICOUT,9183)I,(YM2(I,J),J=1,JMAX) 24261 9183 FORMAT('I,YM2(I,.) = ',I8,10E10.3) 24262 CALL DPWRST('XXX','BUG ') 24263 9182 CONTINUE 24264CCCCC WRITE(ICOUT,9187)NR2,NLTZ,NGTZ,NEQZ 24265C9187 FORMAT('NR2,NLTZ,NGTZ,NEQZ = ',4I8) 24266 WRITE(ICOUT,9187)NR2 24267 9187 FORMAT('NR2 = ',I8) 24268 CALL DPWRST('XXX','BUG ') 24269 9189 CONTINUE 24270C 24271 9090 CONTINUE 24272C 24273 RETURN 24274 END 24275 SUBROUTINE MATCH(X,Z,NX,VAL,NVAL,IWRITE,Y,ICASE, 24276 1 IBUGA3,ISUBRO,IERROR) 24277C 24278C PURPOSE--MATCH EACH VALUE IN THE VALUE ARRAY TO THE 24279C CLOSEST VALUE IN THE X ARRAY. THE RETURNED 24280C Y ARRAY WILL CONTAIN THE CORRESPONDING INDEX 24281C VALUES OF THE X ARRAY (I.E., DON'T RETURN 24282C THE MATCHING VALUE, JUST THE INDEX OF THE 24283C MATCHING VALUE). 24284C IF ICASE IS TRAN, THEN RETURN THE VALUE OF THE 24285C ARRAY Z CORRESPONDING TO INDEX. 24286C WRITTEN BY--ALAN HECKERT 24287C STATISTICAL ENGINEERING DIVISION 24288C INFORMATION TECHNOLOGY LABORATORY 24289C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 24290C GAITHERSBURG, MD 20899-8980 24291C PHONE--301-975-2855 24292C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 24293C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 24294C LANGUAGE--ANSI FORTRAN (1977) 24295C VERSION NUMBER--2001/10 24296C ORIGINAL VERSION--OCTOBER 2001. 24297C UPDATED --DECEMBER 2019. ADD ISUBRO 24298C 24299C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES---------------- 24300C 24301 CHARACTER*4 ICASE 24302 CHARACTER*4 IWRITE 24303 CHARACTER*4 IBUGA3 24304 CHARACTER*4 ISUBRO 24305 CHARACTER*4 IERROR 24306C 24307 CHARACTER*4 ISUBN1 24308 CHARACTER*4 ISUBN2 24309C 24310C 24311C------------------------------------------------------------------ 24312C 24313 DIMENSION X(*) 24314 DIMENSION Y(*) 24315 DIMENSION Z(*) 24316 DIMENSION VAL(*) 24317C 24318C-----COMMON---------------------------------------------------- 24319C 24320 INCLUDE 'DPCOP2.INC' 24321C 24322C-----START POINT-------------------------------------------------- 24323C 24324 ISUBN1='MATC' 24325 ISUBN2='H ' 24326 IERROR='NO' 24327C 24328 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ATCH')THEN 24329 WRITE(ICOUT,999) 24330 999 FORMAT(1X) 24331 CALL DPWRST('XXX','BUG ') 24332 WRITE(ICOUT,51) 24333 51 FORMAT('***** AT THE BEGINNING OF MATCH--') 24334 CALL DPWRST('XXX','BUG ') 24335 WRITE(ICOUT,52)IBUGA3,ISUBRO,IWRITE,NX,NVAL 24336 52 FORMAT('IBUGA3,ISUBRO,IWRITE,NX,NVAL = ',3(A4,2X),2I8) 24337 CALL DPWRST('XXX','BUG ') 24338 DO55I=1,NX 24339 WRITE(ICOUT,56)I,X(I),Z(I) 24340 56 FORMAT('I,X(I),Z(I) = ',I8,2G15.7) 24341 CALL DPWRST('XXX','BUG ') 24342 55 CONTINUE 24343 ENDIF 24344C 24345C **************************************** 24346C ** COMPUTE INDICES OF MATCHING VALUES * 24347C **************************************** 24348C 24349 DO100I=1,NVAL 24350 VALTMP=VAL(I) 24351 INDTMP=1 24352 YDIFF=CPUMAX 24353 DO200J=1,NX 24354 APROD=X(J)*VALTMP 24355 TERM1=MAX(X(J),VALTMP) 24356 TERM2=MIN(X(J),VALTMP) 24357 IF(APROD.GT.0.0)THEN 24358 ADIFF=ABS(ABS(TERM1) - ABS(TERM2)) 24359 ELSEIF(APROD.LT.0.0)THEN 24360 ADIFF=TERM1+ABS(TERM2) 24361 ELSE 24362 ADIFF=ABS(TERM1-TERM2) 24363 ENDIF 24364 IF(ADIFF.LT.YDIFF)THEN 24365 INDTMP=J 24366 YDIFF=ADIFF 24367 ENDIF 24368 200 CONTINUE 24369 IF(ICASE.EQ.'INDE')THEN 24370 Y(I)=REAL(INDTMP) 24371 ELSE 24372 Y(I)=Z(INDTMP) 24373 ENDIF 24374 100 CONTINUE 24375C 24376C ***************** 24377C ** STEP 90-- ** 24378C ** EXIT. ** 24379C ***************** 24380C 24381 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ATCH')THEN 24382 WRITE(ICOUT,999) 24383 CALL DPWRST('XXX','BUG ') 24384 WRITE(ICOUT,9011) 24385 9011 FORMAT('***** AT THE END OF MATCH--') 24386 CALL DPWRST('XXX','BUG ') 24387 WRITE(ICOUT,9012)IERROR,NX 24388 9012 FORMAT('IERROR,NX = ',A4,2X,I8) 24389 CALL DPWRST('XXX','BUG ') 24390 DO9015I=1,NVAL 24391 WRITE(ICOUT,9016)I,VAL(I),Y(I) 24392 9016 FORMAT('I,VAL(I),Y(I) = ',I8,2G15.7) 24393 CALL DPWRST('XXX','BUG ') 24394 9015 CONTINUE 24395 ENDIF 24396C 24397 RETURN 24398 END 24399 SUBROUTINE MATCH2(X,NX,VAL,NVAL,Y,IWRITE,ISUBRO,IBUGA3,IERROR) 24400C 24401C PURPOSE--SORT THE VALUES IN X. FIND THE INDEX, IVAL, 24402C SUCH THAT 24403C 24404C X(I) <= VAL < X(I+1) 24405C 24406C IF VAL < X(1), RETURN A 0 AND IF VAL > X(NX) RETURN 24407C NX + 1. 24408C 24409C DO THIS FOR EACH ROW OF THE VAL VECTOR. 24410C 24411C WRITTEN BY--ALAN HECKERT 24412C STATISTICAL ENGINEERING DIVISION 24413C INFORMATION TECHNOLOGY LABORATORY 24414C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 24415C GAITHERSBURG, MD 20899-8980 24416C PHONE--301-975-2899 24417C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 24418C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 24419C LANGUAGE--ANSI FORTRAN (1977) 24420C VERSION NUMBER--2018/08 24421C ORIGINAL VERSION--AUGUST 2018. 24422C 24423C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES---------------- 24424C 24425 CHARACTER*4 IWRITE 24426 CHARACTER*4 ISUBRO 24427 CHARACTER*4 IBUGA3 24428 CHARACTER*4 IERROR 24429C 24430 CHARACTER*4 ISUBN1 24431 CHARACTER*4 ISUBN2 24432C 24433C------------------------------------------------------------------ 24434C 24435 DIMENSION X(*) 24436 DIMENSION VAL(*) 24437 DIMENSION Y(*) 24438C 24439C--------------------------------------------------------------- 24440C 24441 INCLUDE 'DPCOP2.INC' 24442C 24443C-----START POINT-------------------------------------------------- 24444C 24445 ISUBN1='MATC' 24446 ISUBN2='H2 ' 24447 IERROR='NO' 24448C 24449 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TCH2')THEN 24450 WRITE(ICOUT,999) 24451 999 FORMAT(1X) 24452 CALL DPWRST('XXX','BUG ') 24453 WRITE(ICOUT,51) 24454 51 FORMAT('***** AT THE BEGINNING OF MATCH2--') 24455 CALL DPWRST('XXX','BUG ') 24456 WRITE(ICOUT,52)IBUGA3,ISUBRO,IWRITE,NX 24457 52 FORMAT('IBUGA3,ISUBRO,IWRITE,NX = ',3(A4,2X),I8) 24458 CALL DPWRST('XXX','BUG ') 24459 DO55I=1,NX 24460 WRITE(ICOUT,56)I,X(I) 24461 56 FORMAT('I,X(I), VAL(I) = ',I8,G15.7) 24462 CALL DPWRST('XXX','BUG ') 24463 55 CONTINUE 24464 ENDIF 24465C 24466C **************************************** 24467C ** ERROR CHECKING ** 24468C **************************************** 24469C 24470 IF(NX.LT.1)THEN 24471 WRITE(ICOUT,999) 24472 CALL DPWRST('XXX','BUG ') 24473 WRITE(ICOUT,101) 24474 101 FORMAT('***** ERROR IN MATCH2--') 24475 CALL DPWRST('XXX','BUG ') 24476 WRITE(ICOUT,103)NX 24477 103 FORMAT(' THE NUMBER OF OBSERVATIONS IN THE RESPONSE ', 24478 1 'VARIABLE (',I5,') IS NON-POSITIVE.') 24479 CALL DPWRST('XXX','BUG ') 24480 IERROR='YES' 24481 GOTO9000 24482 ELSEIF(NVAL.LT.1)THEN 24483 WRITE(ICOUT,999) 24484 CALL DPWRST('XXX','BUG ') 24485 WRITE(ICOUT,101) 24486 CALL DPWRST('XXX','BUG ') 24487 WRITE(ICOUT,105)NVAL 24488 105 FORMAT(' THE NUMBER OF OBSERVATIONS IN THE MATCH ', 24489 1 'VARIABLE (',I5,') IS NON-POSITIVE.') 24490 CALL DPWRST('XXX','BUG ') 24491 IERROR='YES' 24492 GOTO9000 24493 ENDIF 24494C 24495C **************************************** 24496C ** COMPUTE INDICES OF MATCHING VALUES * 24497C **************************************** 24498C 24499 CALL SORT(X,NX,X) 24500C 24501 DO100I=1,NVAL 24502 VALTMP=VAL(I) 24503 IF(VALTMP.LT.X(1))THEN 24504 Y(I)=0. 24505 ELSEIF(VALTMP.GT.X(NX))THEN 24506 Y(I)=REAL(NX+1) 24507 ELSE 24508 DO200J=1,NX-1 24509 IF(VALTMP.GE.X(J) .AND. VALTMP.LT.X(J+1))THEN 24510 Y(I)=REAL(J) 24511 GOTO100 24512 ENDIF 24513 200 CONTINUE 24514 ENDIF 24515 100 CONTINUE 24516C 24517C ***************** 24518C ** STEP 90-- ** 24519C ** EXIT. ** 24520C ***************** 24521C 24522 9000 CONTINUE 24523C 24524 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ATC2')THEN 24525 WRITE(ICOUT,999) 24526 CALL DPWRST('XXX','BUG ') 24527 WRITE(ICOUT,9011) 24528 9011 FORMAT('***** AT THE END OF MATCH2--') 24529 CALL DPWRST('XXX','BUG ') 24530 WRITE(ICOUT,9012)IERROR 24531 9012 FORMAT('IERROR = ',A4) 24532 CALL DPWRST('XXX','BUG ') 24533 DO9015I=1,NVAL 24534 WRITE(ICOUT,9016)I,Y(I) 24535 9016 FORMAT('I,Y(I) = ',I8,G15.7) 24536 CALL DPWRST('XXX','BUG ') 24537 9015 CONTINUE 24538 ENDIF 24539C 24540 RETURN 24541 END 24542 SUBROUTINE MATCDF(X,K,CDF) 24543C 24544C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION 24545C FUNCTION VALUE FOR THE CLASSICAL MATCHING 24546C DISTRIBUTION ON THE INTERVAL (0,K). 24547C THIS DISTRIBUTION HAS MEAN = 1 24548C AND STANDARD DEVIATION = 1 24549C THIS DISTRIBUTION HAS THE PROBABILITY 24550C MASS FUNCTION: 24551C 24552C P(X;K) = (1/X!)*SUM[i=1 to k-1][(-1)**i/i!] 24553C X = 0, 1, ..., K 24554C 24555C GIVEN K ENTITIES NUMBERED 1 TO K THAT ARE 24556C ARRANGED IN A RANDOM ORDER. THE MATCHING 24557C DISTRIBUTION IS THE NUMBER OF ENTITITIES FOR 24558C WHICH THE NUMBERED ORDER IS THE SAME AS THE RANDM 24559C ORDER. 24560C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT 24561C WHICH THE CUMULATIVE DISTRIBUTION 24562C FUNCTION IS TO BE EVALUATED. 24563C K = THE INTEGER VALUE THAT SPECIFIES 24564C THE MAXIMUM VALUE 24565C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE 24566C DISTRIBUTION FUNCTION VALUE. 24567C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION 24568C DISTRIBUTION VALUE CDF. 24569C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 24570C RESTRICTIONS--X SHOULD BE BETWEEN 0 AND N, INCLUSIVELY. 24571C OTHER DATAPAC SUBROUTINES NEEDED--DGAMMA. 24572C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP, POIPDF. 24573C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 24574C LANGUAGE--ANSI FORTRAN. 24575C REFERENCES--JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE 24576C DISCRETE DISTRIBUTIONS" SECOND EDITION, 24577C PAGES 409-414. 24578C WRITTEN BY--JAMES J. FILLIBEN 24579C STATISTICAL ENGINEERING DIVISION 24580C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 24581C GAITHERSBURG, MD 20899-8980 24582C PHONE: 301-975-2855 24583C ORIGINAL VERSION--JUNE 2006. 24584C 24585C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 24586C 24587C--------------------------------------------------------------------- 24588C 24589 DOUBLE PRECISION DX 24590 DOUBLE PRECISION DK 24591 DOUBLE PRECISION DI 24592 DOUBLE PRECISION DTERM1 24593 DOUBLE PRECISION DSUM1 24594 DOUBLE PRECISION DCDF 24595 DOUBLE PRECISION DPDF 24596 DOUBLE PRECISION DGAMMA 24597C 24598 INCLUDE 'DPCOP2.INC' 24599C 24600C--------------------------------------------------------------------- 24601C 24602C CHECK THE INPUT ARGUMENTS FOR ERRORS 24603C 24604 CDF=0.0 24605C 24606 IF(K.LT.0)THEN 24607 WRITE(ICOUT,12) 24608 CALL DPWRST('XXX','BUG ') 24609 WRITE(ICOUT,46)N 24610 CALL DPWRST('XXX','BUG ') 24611 GOTO9000 24612 ENDIF 24613 12 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 24614 1 'MATCDF SUBROUTINE IS LESS THAN 0.') 24615C 24616 IX=INT(X+0.5) 24617 IF(IX.LT.0 .OR. IX.GT.K)THEN 24618 WRITE(ICOUT,2) 24619 CALL DPWRST('XXX','BUG ') 24620 WRITE(ICOUT,46)IX 24621 CALL DPWRST('XXX','BUG ') 24622 GOTO9000 24623 ENDIF 24624 2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 24625 1 'MATCDF SUBROUTINE IS OUTSIDE THE (0,N) INTERVAL') 24626C 24627 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 24628C 24629C-----START POINT----------------------------------------------------- 24630C 24631C FOR K SUFFICENTLY LARGE, USE POISSON (WITH LAMBDA = 1) 24632C APPROXIMATION 24633C 24634 IF(K.GE.20)THEN 24635 ALAMB=1.0 24636 CALL POICDF(X,ALAMB,CDF) 24637 ELSE 24638 DK=DBLE(K) 24639 DCDF=0.0D0 24640 DO200J=0,IX 24641 IX2=J 24642 DX=DBLE(J) 24643 DTERM1=1.0D0/DGAMMA(DX+1.0D0) 24644 DSUM1=0.0D0 24645 DO100I=0,K-IX2 24646 DI=DBLE(I) 24647 DSUM1=DSUM1 + (-1.0D0)**DI/DGAMMA(DI+1.0D0) 24648 100 CONTINUE 24649 DPDF=DTERM1*DSUM1 24650 DCDF=DCDF + DPDF 24651 200 CONTINUE 24652 CDF=REAL(DCDF) 24653 ENDIF 24654C 24655 9000 CONTINUE 24656 RETURN 24657 END 24658 SUBROUTINE MATPDF(X,K,PDF) 24659C 24660C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY 24661C FUNCTION VALUE FOR THE CLASSICAL MATCHING 24662C DISTRIBUTION ON THE INTERVAL (0,K). 24663C THIS DISTRIBUTION HAS MEAN = 1 24664C AND STANDARD DEVIATION = 1 24665C THIS DISTRIBUTION HAS THE PROBABILITY 24666C MASS FUNCTION: 24667C 24668C P(X;K) = (1/X!)*SUM[i=1 to k-1][(-1)**i/i!] 24669C X = 0, 1, ..., K 24670C 24671C GIVEN K ENTITIES NUMBERED 1 TO K THAT ARE 24672C ARRANGED IN A RANDOM ORDER. THE MATCHING 24673C DISTRIBUTION IS THE NUMBER OF ENTITITIES FOR 24674C WHICH THE NUMBERED ORDER IS THE SAME AS THE RANDM 24675C ORDER. 24676C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT 24677C WHICH THE PROBABILITY DENSITY 24678C FUNCTION IS TO BE EVALUATED. 24679C K = THE INTEGER VALUE THAT SPECIFIES 24680C THE MAXIMUM VALUE 24681C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY 24682C DENSITY FUNCTION VALUE. 24683C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY 24684C FUNCTION VALUE PDF. 24685C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 24686C RESTRICTIONS--X SHOULD BE BETWEEN 0 AND N, INCLUSIVELY. 24687C OTHER DATAPAC SUBROUTINES NEEDED--DGAMMA, DLNGAM. 24688C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. 24689C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 24690C LANGUAGE--ANSI FORTRAN. 24691C REFERENCES--JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE 24692C DISCRETE DISTRIBUTIONS" SECOND EDITION, 24693C PAGES 409-414. 24694C WRITTEN BY--JAMES J. FILLIBEN 24695C STATISTICAL ENGINEERING DIVISION 24696C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 24697C GAITHERSBURG, MD 20899-8980 24698C PHONE: 301-975-2855 24699C ORIGINAL VERSION--JUNE 2006. 24700C 24701C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 24702C 24703C--------------------------------------------------------------------- 24704C 24705 DOUBLE PRECISION DX 24706 DOUBLE PRECISION DK 24707 DOUBLE PRECISION DI 24708 DOUBLE PRECISION DTERM1 24709 DOUBLE PRECISION DSUM1 24710 DOUBLE PRECISION DPDF 24711 DOUBLE PRECISION DGAMMA 24712 DOUBLE PRECISION DLNGAM 24713C 24714 INCLUDE 'DPCOP2.INC' 24715C 24716C--------------------------------------------------------------------- 24717C 24718C CHECK THE INPUT ARGUMENTS FOR ERRORS 24719C 24720 PDF=0.0 24721C 24722 IF(K.LT.0)THEN 24723 WRITE(ICOUT,12) 24724 CALL DPWRST('XXX','BUG ') 24725 WRITE(ICOUT,46)N 24726 CALL DPWRST('XXX','BUG ') 24727 GOTO9000 24728 ENDIF 24729 12 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 24730 1 'MATPDF SUBROUTINE IS LESS THAN 0.') 24731C 24732 IX=INT(X+0.5) 24733 IF(IX.LT.0 .OR. IX.GT.K)THEN 24734 WRITE(ICOUT,2) 24735 CALL DPWRST('XXX','BUG ') 24736 WRITE(ICOUT,46)IX 24737 CALL DPWRST('XXX','BUG ') 24738 GOTO9000 24739 ENDIF 24740 2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 24741 1 'MATPDF SUBROUTINE IS OUTSIDE THE (0,N) INTERVAL') 24742C 24743 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 24744C 24745C-----START POINT----------------------------------------------------- 24746C 24747 DX=DBLE(IX) 24748 DK=DBLE(K) 24749C 24750C FOR K SUFFICENTLY LARGE, USE APPROXIMATION EXP(-1)/X! 24751C 24752 IF(K.GE.20)THEN 24753 DPDF=DEXP(-1.0D0 - DLNGAM(DX+1.0D0)) 24754 ELSE 24755 DTERM1=1.0D0/DGAMMA(DX+1.0D0) 24756 DSUM1=0.0D0 24757 DO100I=0,K-IX 24758 DI=DBLE(I) 24759 DSUM1=DSUM1 + (-1.0D0)**DI/DGAMMA(DI+1.0D0) 24760 100 CONTINUE 24761 DPDF=DTERM1*DSUM1 24762 ENDIF 24763 PDF=REAL(DPDF) 24764C 24765 9000 CONTINUE 24766 RETURN 24767 END 24768 SUBROUTINE MATPPF(P,K,PPF) 24769C 24770C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT 24771C FUNCTION VALUE FOR THE CLASSICAL MATCHING 24772C DISTRIBUTION ON THE INTERVAL (0,K). 24773C THIS DISTRIBUTION HAS MEAN = 1 24774C AND STANDARD DEVIATION = 1 24775C THIS DISTRIBUTION HAS THE PROBABILITY 24776C MASS FUNCTION: 24777C 24778C P(X;K) = (1/X!)*SUM[i=1 to k-1][(-1)**i/i!] 24779C X = 0, 1, ..., K 24780C 24781C GIVEN K ENTITIES NUMBERED 1 TO K THAT ARE 24782C ARRANGED IN A RANDOM ORDER. THE MATCHING 24783C DISTRIBUTION IS THE NUMBER OF ENTITITIES FOR 24784C WHICH THE NUMBERED ORDER IS THE SAME AS THE RANDM 24785C ORDER. 24786C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE AT 24787C WHICH THE PERCENT POINT 24788C FUNCTION IS TO BE EVALUATED. 24789C K = THE INTEGER VALUE THAT SPECIFIES 24790C THE MAXIMUM VALUE 24791C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT POINT 24792C FUNCTION VALUE. 24793C OUTPUT--THE SINGLE PRECISION PERCENT POINT 24794C DISTRIBUTION VALUE PPF. 24795C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 24796C RESTRICTIONS--X SHOULD BE BETWEEN 0 AND N, INCLUSIVELY. 24797C OTHER DATAPAC SUBROUTINES NEEDED--DGAMMA. 24798C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP, POIPPF. 24799C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 24800C LANGUAGE--ANSI FORTRAN. 24801C REFERENCES--JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE 24802C DISCRETE DISTRIBUTIONS" SECOND EDITION, 24803C PAGES 409-414. 24804C WRITTEN BY--JAMES J. FILLIBEN 24805C STATISTICAL ENGINEERING DIVISION 24806C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 24807C GAITHERSBURG, MD 20899-8980 24808C PHONE: 301-975-2855 24809C ORIGINAL VERSION--JUNE 2006. 24810C 24811C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 24812C 24813C--------------------------------------------------------------------- 24814C 24815 DOUBLE PRECISION DX 24816 DOUBLE PRECISION DP 24817 DOUBLE PRECISION DK 24818 DOUBLE PRECISION DI 24819 DOUBLE PRECISION DTERM1 24820 DOUBLE PRECISION DSUM1 24821 DOUBLE PRECISION DCDF 24822 DOUBLE PRECISION DPDF 24823 DOUBLE PRECISION DGAMMA 24824 DOUBLE PRECISION DEPS 24825C 24826 INCLUDE 'DPCOP2.INC' 24827C 24828C--------------------------------------------------------------------- 24829C 24830C CHECK THE INPUT ARGUMENTS FOR ERRORS 24831C 24832 PPF=0.0 24833C 24834 IF(K.LT.0)THEN 24835 WRITE(ICOUT,12) 24836 CALL DPWRST('XXX','BUG ') 24837 WRITE(ICOUT,46)N 24838 CALL DPWRST('XXX','BUG ') 24839 GOTO9000 24840 ENDIF 24841 12 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 24842 1 'MATCDF SUBROUTINE IS LESS THAN 0.') 24843C 24844 IF(P.LT.0.0 .OR. P.GT.1.0)THEN 24845 WRITE(ICOUT,2) 24846 CALL DPWRST('XXX','BUG ') 24847 WRITE(ICOUT,47)P 24848 CALL DPWRST('XXX','BUG ') 24849 GOTO9000 24850 ENDIF 24851 2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO ', 24852 1 'MATPPF IS OUTSIDE THE (0,1) INTERVAL') 24853C 24854 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 24855 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 24856C 24857C-----START POINT----------------------------------------------------- 24858C 24859C P = 0 AND P = 1 CASES 24860C 24861 IF(P.LE.0.0)THEN 24862 PPF=0.0 24863 GOTO9000 24864 ELSEIF(P.GE.1.0)THEN 24865 PPF=REAL(K) 24866 GOTO9000 24867 ENDIF 24868C 24869C FOR K SUFFICENTLY LARGE, USE POISSON (WITH LAMBDA = 1) 24870C APPROXIMATION 24871C 24872 IF(K.GE.20)THEN 24873 ALAMB=1.0 24874 CALL POIPPF(P,ALAMB,PPF) 24875 GOTO9000 24876 ELSE 24877 DK=DBLE(K) 24878 DP=DBLE(P) 24879 DCDF=0.0D0 24880 DEPS=1.0D-7 24881 DO200J=0,K 24882 IX2=J 24883 DX=DBLE(J) 24884 DTERM1=1.0D0/DGAMMA(DX+1.0D0) 24885 DSUM1=0.0D0 24886 DO100I=0,K-IX2 24887 DI=DBLE(I) 24888 DSUM1=DSUM1 + (-1.0D0)**DI/DGAMMA(DI+1.0D0) 24889 100 CONTINUE 24890 DPDF=DTERM1*DSUM1 24891 DCDF=DCDF + DPDF 24892 IF(DCDF.GE.DP-DEPS)THEN 24893 PPF=REAL(J) 24894 GOTO9000 24895 ENDIF 24896C 24897 200 CONTINUE 24898 PPF=1.0 24899 ENDIF 24900C 24901 9000 CONTINUE 24902 RETURN 24903 END 24904 SUBROUTINE MATRAN(N,K,ISEED,X) 24905C 24906C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N 24907C FROM THE MATCHING DISTRIBUTION 24908C WITH SHAPE PARAMETER K. 24909C THIS DISTRIBUTION HAS THE PROBABILITY 24910C MASS FUNCTION: 24911C 24912C P(X;K) = (1/X!)*SUM[i=1 to k-1][(-1)**i/i!] 24913C X = 0, 1, ..., K 24914C 24915C GIVEN K ENTITIES NUMBERED 1 TO K THAT ARE 24916C ARRANGED IN A RANDOM ORDER. THE MATCHING 24917C DISTRIBUTION IS THE NUMBER OF ENTITITIES FOR 24918C WHICH THE NUMBERED ORDER IS THE SAME AS THE RANDM 24919C ORDER. 24920C 24921C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER 24922C OF RANDOM NUMBERS TO BE 24923C GENERATED. 24924C --NPAR = THE INTEGER VALUE 24925C OF THE SHAPE PARAMETER. 24926C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR 24927C (OF DIMENSION AT LEAST N) 24928C INTO WHICH THE GENERATED 24929C RANDOM SAMPLE WILL BE PLACED. 24930C OUTPUT--A RANDOM SAMPLE OF SIZE N 24931C FROM THE MATCHING DISTRIBUTION 24932C WITH SHAPE PARAMETERS N AND NPAR. 24933C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 24934C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 24935C OF N FOR THIS SUBROUTINE. 24936C --NPAR > 0 24937C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, LCTPPF 24938C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 24939C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 24940C LANGUAGE--ANSI FORTRAN (1977) 24941C REFERENCES--JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE 24942C DISCRETE DISTRIBUTIONS", SECOND EDITION, 24943C WILEY, PP. 242-244. 24944C WRITTEN BY--JAMES J. FILLIBEN 24945C STATISTICAL ENGINEERING DIVISION 24946C INFORMATION TECHNOLOGY LABORATORY 24947C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 24948C GAITHERSBURG, MD 20899-8980 24949C PHONE--301-975-2899 24950C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 24951C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 24952C LANGUAGE--ANSI FORTRAN (1977) 24953C VERSION NUMBER--2006/6 24954C ORIGINAL VERSION--JUNE 2006. 24955C 24956C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 24957C 24958C--------------------------------------------------------------------- 24959C 24960 INTEGER N 24961 INTEGER K 24962 DIMENSION X(*) 24963C 24964C-----COMMON---------------------------------------------------------- 24965C 24966 INCLUDE 'DPCOP2.INC' 24967C 24968C-----START POINT----------------------------------------------------- 24969C 24970C CHECK THE INPUT ARGUMENTS FOR ERRORS 24971C 24972 IF(N.LT.1)THEN 24973 WRITE(ICOUT, 5) 24974 CALL DPWRST('XXX','BUG ') 24975 WRITE(ICOUT,47)N 24976 CALL DPWRST('XXX','BUG ') 24977 GOTO9999 24978 ENDIF 24979C 24980 IF(K.LE.0.0)THEN 24981 WRITE(ICOUT,12) 24982 CALL DPWRST('XXX','BUG ') 24983 WRITE(ICOUT,47)K 24984 CALL DPWRST('XXX','BUG ') 24985 GOTO9999 24986 ENDIF 24987 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ', 24988 1'MATCHING RANDOM NUMBERS IS NON-POSITIVE') 24989 12 FORMAT('***** ERROR--THE K PARAMETER FOR THE ', 24990 1'MATCHING RANDOM NUMBERS IS NON-POSITIVE') 24991 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 24992C 24993C 100 CONTINUE 24994C 24995 IF(K.LT.20)THEN 24996 CALL UNIRAN(N,ISEED,X) 24997 DO100I=1,N 24998 XTEMP=X(I) 24999 CALL MATPPF(XTEMP,K,PPF) 25000 X(I)=PPF 25001 100 CONTINUE 25002 ELSE 25003 ALAMB=1.0 25004 CALL POIRAN(N,ALAMB,ISEED,X) 25005 ENDIF 25006C 25007 9999 CONTINUE 25008C 25009 RETURN 25010 END 25011