SUBROUTINE DPC4HI(IHVAL,IVAL,IBUGA3,IERROR) C C PURPOSE--CONVERT A CHARACTER VARIABLE C INTO THE CORRESPONDING INTEGER VALUE. C NOTE--INASMUCH AS THE ASSUMED INPUT WORD HAS 4 CHARACTERS AT MOST, C THEN THE VALID RANGE OF THE OUTPUT INTEGER VARIABLE C IS -999 TO 9999 . C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--JANUARY 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHVAL CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IHTEMP CHARACTER*4 ISIGN C C--------------------------------------------------------------------- C DIMENSION IHTEMP(4) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IERROR='NO' NUMASC=4 IVAL=0 C ITERM=0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPC4HI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IHVAL,IBUGA3,IERROR 52 FORMAT('IHVAL,IBUGA3,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************************* C ** STEP 1-- ** C ** DECOMPOSE THE 4-CHARACTERS IN IHVAL ** C ** INTO 4 1-CHARACTER WORDS. ** C ******************************************* C DO200J=1,NUMASC IHTEMP(J)=' ' ISTAR1=NUMBPC*(J-1) CALL DPCHEX(ISTAR1,NUMBPC,IHVAL,0,NUMBPC,IHTEMP(J)) 200 CONTINUE C C ****************************************************** C ** STEP 2-- ** C ** CARRY OUT THE HOLLERITH TO INTEGER CONVERSION. ** C ****************************************************** C ISIGN='+' NUMSIG=0 IDIGI=0 ISUM=0 DO400I=1,NUMASC IREV=NUMASC-I+1 IF(IHTEMP(IREV).EQ.' ')GOTO400 IF(IHTEMP(IREV).EQ.'0')GOTO410 IF(IHTEMP(IREV).EQ.'1')GOTO411 IF(IHTEMP(IREV).EQ.'2')GOTO412 IF(IHTEMP(IREV).EQ.'3')GOTO413 IF(IHTEMP(IREV).EQ.'4')GOTO414 IF(IHTEMP(IREV).EQ.'5')GOTO415 IF(IHTEMP(IREV).EQ.'6')GOTO416 IF(IHTEMP(IREV).EQ.'7')GOTO417 IF(IHTEMP(IREV).EQ.'8')GOTO418 IF(IHTEMP(IREV).EQ.'9')GOTO419 IF(IHTEMP(IREV).EQ.'+')GOTO420 IF(IHTEMP(IREV).EQ.'-')GOTO421 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,431) 431 FORMAT('***** ERROR IN DPC4HI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,432) 432 FORMAT(' CHARACTER ENCOUNTERED IN THE CONVERSION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,433) 433 FORMAT(' WHICH WAS NOT 0 THROUGH 9, +, - OR SPACE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,434)IHTEMP(IREV) 434 FORMAT(' CHARACTER IN QUESTION IHTEMP(IREV) = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,435)IHVAL 435 FORMAT(' IHVAL = ',A4) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 410 ITERM=0 GOTO425 411 ITERM=1 GOTO425 412 ITERM=2 GOTO425 413 ITERM=3 GOTO425 414 ITERM=4 GOTO425 415 ITERM=5 GOTO425 416 ITERM=6 GOTO425 417 ITERM=7 GOTO425 418 ITERM=8 GOTO425 419 ITERM=9 GOTO425 420 NUMSIG=NUMSIG+1 GOTO400 421 NUMSIG=NUMSIG+1 ISIGN='-' GOTO400 425 IDIGI=IDIGI+1 IEXP=IDIGI-1 CCCCC ISUM=ISUM+ITERM*(10**IEXP) IJUNK=INT(10.0**IEXP + 0.01) ISUM=ISUM+ITERM*IJUNK 400 CONTINUE C IF(NUMSIG.LE.1)GOTO459 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,451) 451 FORMAT('***** ERROR IN DPC4HI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,452) 452 FORMAT(' MULTIPLE SIGNS (+/-) ENCOUNTERED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,453) 453 FORMAT(' IN THE CONVERSION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,454)NUMSIG 454 FORMAT(' NUMBER OF SIGNS NUMSIG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,456)(IHTEMP(J),J=1,NUMASC) 456 FORMAT(' (IHTEMP(J),J=1,NUMASC) = ',4A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,457)IHVAL 457 FORMAT(' IHVAL = ',A4) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 459 CONTINUE IF(ISIGN.EQ.'-')ISUM=-ISUM IVAL=ISUM C C **************** C ** STEP 90-- ** C ** EXIT. ** C **************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPC4HI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IHVAL 9012 FORMAT('IHVAL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)(IHTEMP(J),J=1,NUMASC) 9014 FORMAT('(IHTEMP(J),J=1,NUMASC) = ',4A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NUMASC,ISIGN,NUMSIG,ISUM,ITERM 9015 FORMAT('NUMASC,ISIGN,NUMSIG,ISUM,ITERM = ',I8,2X,A4,3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)IBUGA3,IERROR 9016 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)IVAL 9017 FORMAT('IVAL = ',I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPC4IH(IVAL,IHVAL,IBUGA3,IERROR) C C PURPOSE--CONVERT AN INTEGER VARIABLE C TO A 4-CHARACTER-PER-WORD HOLLERITH STRING. C NOTE--CONVERT ONLY THE FIRST 4 CHARACTERS OF THE C INTEGER VARIABLE (INCLUDING THE NEGATIVE C SIGN, IF EXISTENT). C NOTE--INCORRECT VALUERS WILL RESULT IF THE INPUT INTEGER C IS LARGER THAN 9999 OR SMALLER THAN -999 . C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--JANUARY 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHVAL CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IHTEMP CHARACTER*4 ISIGN CHARACTER*4 IHDIG C C--------------------------------------------------------------------- C DIMENSION IHTEMP(4) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IERROR='NO' NUMASC=4 IVAL2=IVAL IHVAL=' ' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPC4IH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IVAL,IBUGA3,IERROR 52 FORMAT('IVAL,IBUGA3,IERROR = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *********************** C ** STEP 2-- ** C ** DETERMINE SIGN. ** C *********************** C ISIGN='+' IF(IVAL2.LT.0)ISIGN='-' IVAL2=IABS(IVAL2) C C *********************************** C ** STEP 3-- ** C ** DETERMINE NUMBER OF DIGITS. ** C *********************************** C IMIN=1 IMAX=NUMASC DO300I=IMIN,IMAX IREV=IMAX-I+IMIN IDIV=INT(10.0**(IREV-1) + 0.01) IDIG=IVAL2/IDIV IF(IDIG.NE.0)GOTO350 300 CONTINUE NUMDIG=1 GOTO390 350 CONTINUE NUMDIG=IREV 390 CONTINUE C C *************************************** C ** STEP 4-- ** C ** IF NEGATIVE, ** C ** INSERT SIGN INTO OUTPUT VECTOR. ** C *************************************** C J=0 IF(ISIGN.EQ.'-')J=J+1 IF(ISIGN.EQ.'-')IHTEMP(J)='-' C C ************************** C ** STEP 5-- ** C ** INSERT DIGITS INTO ** C ** OUTPUT VECTOR. ** C ************************** C IMIN=1 IMAX=NUMDIG IF(IMAX.GE.NUMASC.AND.ISIGN.EQ.'-')IMAX=NUMASC-1 IF(IMAX.GE.NUMASC.AND.ISIGN.EQ.'+')IMAX=NUMASC DO500I=IMIN,IMAX IREV=IMAX-I+IMIN IDIV=INT(10.0**(IREV-1) + 0.01) IDIG=IVAL2/IDIV C IF(IDIG.EQ.0)GOTO510 IF(IDIG.EQ.1)GOTO511 IF(IDIG.EQ.2)GOTO512 IF(IDIG.EQ.3)GOTO513 IF(IDIG.EQ.4)GOTO514 IF(IDIG.EQ.5)GOTO515 IF(IDIG.EQ.6)GOTO516 IF(IDIG.EQ.7)GOTO517 IF(IDIG.EQ.8)GOTO518 IF(IDIG.EQ.9)GOTO519 510 CONTINUE IHDIG='0' GOTO529 511 CONTINUE IHDIG='1' GOTO529 512 CONTINUE IHDIG='2' GOTO529 513 CONTINUE IHDIG='3' GOTO529 514 CONTINUE IHDIG='4' GOTO529 515 CONTINUE IHDIG='5' GOTO529 516 CONTINUE IHDIG='6' GOTO529 517 CONTINUE IHDIG='7' GOTO529 518 CONTINUE IHDIG='8' GOTO529 519 CONTINUE IHDIG='9' GOTO529 529 CONTINUE C J=J+1 IF(J.GT.NUMASC)GOTO550 IHTEMP(J)=IHDIG IVAL2=IVAL2-IDIG*IDIV 500 CONTINUE C NTEMP=J GOTO590 C 550 CONTINUE NTEMP=J-1 GOTO590 C 590 CONTINUE C C *************************************** C ** STEP 6-- ** C ** PACK THE CHARACTERS INTO 1 WORD ** C *************************************** C IHVAL=' ' IMAX=NUMASC IF(NTEMP.LE.IMAX)IMAX=NTEMP IF(IMAX.LE.0)GOTO690 DO600J=1,IMAX ISTAR2=NUMBPC*(J-1) CALL DPCHEX(0,NUMBPC,IHTEMP(J),ISTAR2,NUMBPC,IHVAL) 600 CONTINUE 690 CONTINUE C C **************** C ** STEP 90-- ** C ** EXIT. ** C **************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPC4IH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IVAL 9012 FORMAT('IVAL = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ISIGN,NUMDIG,NUMASC,IMAX 9013 FORMAT('ISIGN,NUMDIG,NUMASC,IMAX = ',A4,3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NTEMP 9014 FORMAT('NTEMP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)(IHTEMP(I),I=1,NTEMP) 9015 FORMAT('IHTEMP(.) = ',80A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)ISTAR2,IHVAL 9016 FORMAT('ISTAR2,IHVAL = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)IBUGA3,IERROR 9017 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPCAAN(XTEMP1,XTEMP2,MAXNXT, 1IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE A TABLE OF CAPABILITY ANALYSIS STATISTICS C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--90/9 C ORIGINAL VERSION--SEPTEMBER 1990. C UPDATED --APRIL 2001. 1) ARGUMENT LIST TO DPCAA2 C 2) SAVE RESULTS FROM DPCAA2 C AS INTERNAL PARAMETERS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 C CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IERRO2 C CHARACTER*4 ISUBN0 CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C DIMENSION W(MAXOBV) C INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),W(1)) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOSU.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPCA' ISUBN2='AN ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 C IFOUND='NO' IERROR='NO' C MAXV2=1 MINN2=2 C IFOUND='YES' C NLEFT=0 C ICASEQ='UNKN' C C ******************************************** C ** TREAT THE CAPABILITY ANALYSIS CASE ** C ******************************************** C IF(IBUGA2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPCAAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA2,IBUGA3 52 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGQ 53 FORMAT('IBUGQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)MAXNXT 55 FORMAT('MAXNXT = ',I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ******************************************** C ** STEP 3-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='3' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(1) IHLEF2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) C C *********************************************************** C ** STEP 4-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS 2 OR MORE. ** C *********************************************************** C ISTEPN='4' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPCAAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312) 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) 313 FORMAT(' (FOR WHICH A CAPABILITY ANALYSIS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' WAS TO HAVE BEEN CARRIED OUT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)MINN2 315 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,316) 316 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,317) 317 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,318)(IANS(I),I=1,IWIDTH) 318 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 390 CONTINUE C C ***************************************** C ** STEP 5-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='5' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO490 DO400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO420 400 CONTINUE GOTO490 410 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO490 420 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO490 490 CONTINUE IF(IBUGA2.EQ.'OFF')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ 491 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C ********************************************* C ** STEP 5-- ** C ** TEMPORARILY FORM THE VARIABLE Y(.) ** C ** WHICH WILL HOLD THE RESPONSE VARIABLE. ** C ** FORM THIS VARIABLE BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C ********************************************* C ISTEPN='5' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO510 IF(ICASEQ.EQ.'SUBS')GOTO520 IF(ICASEQ.EQ.'FOR')GOTO530 C 510 CONTINUE DO515I=1,NLEFT ISUB(I)=1 515 CONTINUE NQ=NLEFT GOTO550 C 520 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO550 C 530 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO550 C 550 CONTINUE IF(NQ.GE.MINN2)GOTO560 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,551) 551 FORMAT('***** ERROR IN DPCAAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,552) 552 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,553)IHLEFT,IHLEF2 553 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,554) 554 FORMAT(' (FOR WHICH A CAPABILITY ANALYSIS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,555) 555 FORMAT(' IS TO BE GENERATED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,556)MINN2 556 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,557) 557 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,558) 558 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,559)(IANS(I),I=1,IWIDTH) 559 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 560 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO570I=1,IMAX IF(ISUB(I).EQ.0)GOTO570 J=J+1 C IJ=MAXN*(ICOLL-1)+I IF(ICOLL.LE.MAXCOL)Y(J)=V(IJ) IF(ICOLL.EQ.MAXCP1)Y(J)=PRED(I) IF(ICOLL.EQ.MAXCP2)Y(J)=RES(I) IF(ICOLL.EQ.MAXCP3)Y(J)=YPLOT(I) IF(ICOLL.EQ.MAXCP4)Y(J)=XPLOT(I) IF(ICOLL.EQ.MAXCP5)Y(J)=X2PLOT(I) IF(ICOLL.EQ.MAXCP6)Y(J)=TAGPLO(I) C 570 CONTINUE NS=J C C **************************************************************** C ** STEP 7-- ** C ** DETERMINE IF THE ANALYST ** C ** HAS SPECIFIED C ** LSL (LOWER SPEC LIMIT) C ** USL (UPPER SPEC LIMIT) C ** USLCOST (UPPER SPEC LIMIT COST) C ** TARGET C **************************************************************** C ISTEPN='7' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCLSL=CPUMIN IH='LSL ' IH2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IF(IERRO2.EQ.'NO')CCLSL=VALUE(ILOCP) C CCUSL=CPUMIN IH='USL ' IH2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IF(IERRO2.EQ.'NO')CCUSL=VALUE(ILOCP) C CCTARG=CPUMIN IH='TARG' IH2='ET ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IF(IERRO2.EQ.'NO')CCTARG=VALUE(ILOCP) C CCUSLC=CPUMIN IH='USLC' IH2='OST ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IF(IERRO2.EQ.'NO')CCUSLC=VALUE(ILOCP) C C ****************************************************** C ** STEP 8-- ** C ** PREPARE FOR ENTRANCE INTO DPCAA2-- ** C ** SET THE WEIGHT VECTOR TO UNITY THROUGHOUT. ** C ****************************************************** C ISTEPN='8' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1110I=1,NS W(I)=1.0 1110 CONTINUE C C ****************************************** C ** STEP 9-- ** C ** FORM THE CAPABILITY ANALYSIS TABLE. ** C ****************************************** C ISTEPN='9' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'OFF')GOTO1290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** FROM DPCAAN, AS WE ARE ABOUT TO CALL DPCAA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212)NLEFT,MAXN,NS 1212 FORMAT('NLEFT,MAXN,NS = ',3I8) CALL DPWRST('XXX','BUG ') DO1215I=1,NS WRITE(ICOUT,1216)I,Y(I),W(I) 1216 FORMAT('I,Y(I),W(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 1215 CONTINUE CCCCC IBUGA3='ABCD' WRITE(ICOUT,1231)IBUGA3 1231 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') 1290 CONTINUE C CALL DPCAA2(Y,W,NS,XTEMP1,XTEMP2,MAXNXT, 1CCLSL,CCUSL,CCTARG,CCUSLC, 1YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL, 1YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL, 1YCNPK,YCPM,YCPMLL,YCPMUL,YCC, 1YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO, 1IBUGA3,IERROR) C C *************************************** C ** STEP 10-- ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C ISTEPN='10' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IH='CPST' IH2='AT ' VALUE0=YCP CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CPLL' IH2=' ' VALUE0=YCPLL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CPUL' IH2=' ' VALUE0=YCPUL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CPKS' IH2='TAT ' VALUE0=YCPK CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CPKL' IH2='L ' VALUE0=YCPKLL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CPKU' IH2='L ' VALUE0=YCPKUL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CPLS' IH2='TAT ' VALUE0=YCPL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CPLL' IH2='L ' VALUE0=YCPLLL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CPLU' IH2='L ' VALUE0=YCPLUL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CPUS' IH2='TAT ' VALUE0=YCPU CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CPUL' IH2='L ' VALUE0=YCPULL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CPUU' IH2='L ' VALUE0=YCPUUL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CNPK' IH2='STAT' VALUE0=YCNPK CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CPMS' IH2='TAT ' VALUE0=YCPM CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CPML' IH2='L ' VALUE0=YCPMLL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CPMU' IH2='L ' VALUE0=YCPMUL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CCST' IH2='AT ' VALUE0=YCC CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='ACTU' IH2='ALPD' VALUE0=YACTPD CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='THEO' IH2='RPD ' VALUE0=YTHEPD CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='ACTU' IH2='ALLL' VALUE0=YACTL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='THEO' IH2='RLL ' VALUE0=YTHEL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='ACTU' IH2='ALUL' VALUE0=YACTU CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='THEO' IH2='RUL ' VALUE0=YTHEU CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='EXPL' IH2='OSS ' VALUE0=YEXPLO CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPCAAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA2,IBUGA3 9012 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGQ 9013 FORMAT('IBUGQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NLEFT,NS 9014 FORMAT('NLEFT,NS = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)ICASEQ 9015 FORMAT('ICASEQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)IFOUND,IERROR 9016 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)CCLSL,CCUSL,CCTARG,CCUSLC 9021 FORMAT('CCLSL,CCUSL,CCTARG,CCUSLC = ',4E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPCAA2(Y,W,N,XTEMP1,XTEMP2,MAXNXT, 1CCLSL,CCUSL,CCTARG,CCUSLC, 1YCP,YCPLL,YCPUL,YCPK,YCPKLL,YCPKUL, 1YCPL,YCPLLL,YCPLUL,YCPU,YCPULL,YCPUUL, 1YCNPK,YCPM,YCPMLL,YCPMUL,YCC, 1YACTPD,YTHEPD,YACTL,YTHEL,YACTU,YTHEU,YEXPLO, 1IBUGA3,IERROR) C C PURPOSE--THIS ROUTINE GENERATES A CAPABILITY ANALYSIS C TABULATION THE DATA IN THE INPUT VECTOR Y. C NOTE--NORMALITY IS ASSUMED C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR C OF EQUALLY-SPACED OBSERVATIONS C TO BE SMOOTHED. C N = THE INTEGER NUMBER OF C OBSERVATIONS IN THE VECTOR Y. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--90/9 C ORIGINAL VERSION--SEPTEMBER 1990. C UPDATED --APRIL 2001. EXPAND TABLE: C 1) ADD CC, CPM, CPL, CPU, C CNPK C 2) 95% CONFIDENCE INTERVAL C FOR CP, CPK, CPL, CPU, CPM C 3) ADD COMPUTED STATS TO C CALL LIST SO THEY CAN BE C SAVED AS INTERNAL C PARAMETERS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IWRITE CHARACTER*4 IFLAG C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION W(*) DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPCA' ISUBN2='A2 ' C IERROR='NO' C C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('**** AT THE BEGINNING OF DPCAA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N,IBUGA3 52 FORMAT('N,IBUGA3 = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)CCLSL,CCUSL,CCTARG,CCUSLC 54 FORMAT('CCLSL,CCUSL,CCTARG,CCUSLC = ',4E15.7) CALL DPWRST('XXX','BUG ') DO56I=1,N WRITE(ICOUT,57)I,Y(I),W(I) 57 FORMAT('I,Y(I),W(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 56 CONTINUE 90 CONTINUE C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(N.LT.1)GOTO110 GOTO119 110 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN DPCAA2--THE NUMBER OF OBSERVATIONS ', 1'IN THE RESPONSE VARIABLE IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112)N 112 FORMAT('SAMPLE SIZE = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** NOTE FROM DPCAA2--THE RESPONSE VARIABLE ', 1'ONLY HAS 1 ELEMENT') CALL DPWRST('XXX','BUG ') GOTO9000 129 CONTINUE C HOLD=Y(1) DO135I=2,N IF(Y(I).NE.HOLD)GOTO139 135 CONTINUE 130 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131)HOLD 131 FORMAT('***** NOTE FROM DPCAA2--THE RESPONSE VARIABLE ', 1'HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') GOTO9000 139 CONTINUE C C ********************************************** C ** STEP 3-- ** C ** COMPUTE VARIOUS CAPABILITY STATISTICS-- ** C ** 1) CP ** C ** 2) CPK ** C ** 3) PERCENT DEFECTIVE ** C ** 4) EXPECTED LOSS ** C ********************************************** C ISTEPN='3' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IWRITE='OFF' IFLAG='BOTH' C CALL MEAN(Y,N,IWRITE,XMEAN,IBUGA3,IERROR) CALL SD(Y,N,IWRITE,XSD,IBUGA3,IERROR) C YCP=CPUMIN YCPLL=CPUMIN YCPUL=CPUMIN YCPK=CPUMIN YCPKLL=CPUMIN YCPKUL=CPUMIN YCNPK=CPUMIN YCPL=CPUMIN YCPLLL=CPUMIN YCPLUL=CPUMIN YCPU=CPUMIN YCPULL=CPUMIN YCPUUL=CPUMIN YCC=CPUMIN YCPM=CPUMIN YCPMLL=CPUMIN YCPMUL=CPUMIN YTHEPD=CPUMIN YTHEL=CPUMIN YTHEU=CPUMIN YACTPD=CPUMIN YACTL=CPUMIN YACTU=CPUMIN YEXPLO=CPUMIN C IF(CCLSL.NE.CPUMIN.AND.CCUSL.NE.CPUMIN) 1CALL CP(Y,N,CCLSL,CCUSL,IWRITE,YCP,YCPLL,YCPUL, 1IBUGA3,IERROR) IF(CCLSL.NE.CPUMIN.AND.CCUSL.NE.CPUMIN) 1CALL CPL(Y,N,CCLSL,CCUSL,IWRITE,YCPL,YCPLLL,YCPLUL, 1IBUGA3,IERROR) IF(CCLSL.NE.CPUMIN.AND.CCUSL.NE.CPUMIN) 1CALL CPU(Y,N,CCLSL,CCUSL,IWRITE,YCPU,YCPULL,YCPUUL, 1IBUGA3,IERROR) IF(CCLSL.NE.CPUMIN.AND.CCUSL.NE.CPUMIN) 1CALL CPK(Y,N,CCLSL,CCUSL,IWRITE,YCPK,YCPKLL,YCPKUL, 1IBUGA3,IERROR) IF(CCLSL.NE.CPUMIN.AND.CCUSL.NE.CPUMIN) 1CALL CNPK(Y,N,XTEMP1,MAXNXT,CCLSL,CCUSL,IWRITE,YCNPK, 1IBUGA3,IERROR) IF(CCLSL.NE.CPUMIN.AND.CCUSL.NE.CPUMIN) 1CALL CPM(Y,N,CCLSL,CCUSL,CCTARG,IWRITE,YCPM,YCPMLL,YCPMUL, 1IBUGA3,IERROR) IF(CCLSL.NE.CPUMIN.AND.CCUSL.NE.CPUMIN) 1CALL CC(Y,N,CCLSL,CCUSL,CCTARG,IWRITE,YCC, 1IBUGA3,IERROR) IF(CCLSL.NE.CPUMIN.AND.CCUSL.NE.CPUMIN) 1CALL PERDEF(Y,N,CCLSL,CCUSL,IWRITE,YACTPD,YTHEPD, 1YACTL,YTHEL,YACTU,YTHEU, 1IFLAG,IBUGA3,IERROR) IF(CCUSLC.NE.CPUMIN) 1CALL EXPLOS(Y,N,CCLSL,CCUSL,CCUSLC,IWRITE,YEXPLO, 1IBUGA3,IERROR) C C **************************** C ** STEP 7-- ** C ** WRITE EVERYTHING OUT ** C **************************** C ISTEPN='7' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,801) 801 FORMAT(10X,'****************************************************') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,805) CALL DPWRST('XXX','BUG ') 805 FORMAT(10X,'* CAPABILITY ANALYSIS *') WRITE(ICOUT,806)N CALL DPWRST('XXX','BUG ') 806 FORMAT(10X,'* NUMBER OF OBSERVATIONS = ',I8,' *') WRITE(ICOUT,808)XMEAN CALL DPWRST('XXX','BUG ') 808 FORMAT(10X,'* MEAN = ',F12.5,' *') WRITE(ICOUT,809)XSD CALL DPWRST('XXX','BUG ') 809 FORMAT(10X,'* STANDARD DEVIATION = ',F12.5,' *') WRITE(ICOUT,801) CALL DPWRST('XXX','BUG ') IF(CCLSL.EQ.CPUMIN)THEN WRITE(ICOUT,821) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,822)CCLSL CALL DPWRST('XXX','BUG ') ENDIF IF(CCUSL.EQ.CPUMIN)THEN WRITE(ICOUT,823) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,824)CCUSL CALL DPWRST('XXX','BUG ') ENDIF IF(CCTARG.EQ.CPUMIN)THEN WRITE(ICOUT,825) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,826)CCTARG CALL DPWRST('XXX','BUG ') ENDIF IF(CCUSLC.EQ.CPUMIN)THEN WRITE(ICOUT,827) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,828)CCUSLC CALL DPWRST('XXX','BUG ') ENDIF 821 FORMAT(10X,'* LOWER SPEC LIMIT (LSL) = UNDEFINED *') 822 FORMAT(10X,'* LOWER SPEC LIMIT (LSL) = ',F12.5,' *') 823 FORMAT(10X,'* UPPER SPEC LIMIT (USL) = UNDEFINED *') 824 FORMAT(10X,'* UPPER SPEC LIMIT (USL) = ',F12.5,' *') 825 FORMAT(10X,'* TARGET (TARGET) = UNDEFINED *') 826 FORMAT(10X,'* TARGET (TARGET) = ',F12.5,' *') 827 FORMAT(10X,'* USL COST (USLCOST) = UNDEFINED *') 828 FORMAT(10X,'* USL COST (USLCOST) = ',F12.5,' *') WRITE(ICOUT,801) CALL DPWRST('XXX','BUG ') IF(YCP.EQ.CPUMIN)THEN WRITE(ICOUT,831) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,832)YCP CALL DPWRST('XXX','BUG ') ENDIF IF(YCPLL.EQ.CPUMIN)THEN WRITE(ICOUT,861) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,862)YCPLL CALL DPWRST('XXX','BUG ') ENDIF IF(YCPUL.EQ.CPUMIN)THEN WRITE(ICOUT,863) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,864)YCPUL CALL DPWRST('XXX','BUG ') ENDIF IF(YCPL.EQ.CPUMIN)THEN WRITE(ICOUT,841) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,842)YCPL CALL DPWRST('XXX','BUG ') ENDIF IF(YCPLLL.EQ.CPUMIN)THEN WRITE(ICOUT,881) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,882)YCPLLL CALL DPWRST('XXX','BUG ') ENDIF IF(YCPLUL.EQ.CPUMIN)THEN WRITE(ICOUT,883) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,884)YCPLUL CALL DPWRST('XXX','BUG ') ENDIF IF(YCPU.EQ.CPUMIN)THEN WRITE(ICOUT,843) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,844)YCPU CALL DPWRST('XXX','BUG ') ENDIF IF(YCPULL.EQ.CPUMIN)THEN WRITE(ICOUT,891) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,892)YCPULL CALL DPWRST('XXX','BUG ') ENDIF IF(YCPUUL.EQ.CPUMIN)THEN WRITE(ICOUT,893) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,894)YCPUUL CALL DPWRST('XXX','BUG ') ENDIF IF(YCPK.EQ.CPUMIN)THEN WRITE(ICOUT,833) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,834)YCPK CALL DPWRST('XXX','BUG ') ENDIF IF(YCPKLL.EQ.CPUMIN)THEN WRITE(ICOUT,871) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,872)YCPKLL CALL DPWRST('XXX','BUG ') ENDIF IF(YCPKUL.EQ.CPUMIN)THEN WRITE(ICOUT,873) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,874)YCPKUL CALL DPWRST('XXX','BUG ') ENDIF IF(YCNPK.EQ.CPUMIN)THEN WRITE(ICOUT,845) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,846)YCNPK CALL DPWRST('XXX','BUG ') ENDIF IF(YCPM.EQ.CPUMIN)THEN WRITE(ICOUT,847) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,848)YCPM CALL DPWRST('XXX','BUG ') ENDIF IF(YCPMLL.EQ.CPUMIN)THEN WRITE(ICOUT,849) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,850)YCPMLL CALL DPWRST('XXX','BUG ') ENDIF IF(YCPMUL.EQ.CPUMIN)THEN WRITE(ICOUT,851) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,852)YCPMUL CALL DPWRST('XXX','BUG ') ENDIF IF(YCC.EQ.CPUMIN)THEN WRITE(ICOUT,853) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,854)YCC CALL DPWRST('XXX','BUG ') ENDIF IF(YACTPD.EQ.CPUMIN)THEN WRITE(ICOUT,835) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,836)YACTPD CALL DPWRST('XXX','BUG ') ENDIF IF(YTHEPD.EQ.CPUMIN)THEN WRITE(ICOUT,837) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,838)YTHEPD CALL DPWRST('XXX','BUG ') ENDIF IF(YACTL.EQ.CPUMIN)THEN WRITE(ICOUT,895) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,896)YACTL CALL DPWRST('XXX','BUG ') ENDIF IF(YTHEL.EQ.CPUMIN)THEN WRITE(ICOUT,897) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,898)YTHEL CALL DPWRST('XXX','BUG ') ENDIF IF(YACTU.EQ.CPUMIN)THEN WRITE(ICOUT,905) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,906)YACTL CALL DPWRST('XXX','BUG ') ENDIF IF(YTHEU.EQ.CPUMIN)THEN WRITE(ICOUT,907) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,908)YTHEU CALL DPWRST('XXX','BUG ') ENDIF IF(YEXPLO.EQ.CPUMIN)THEN WRITE(ICOUT,839) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,840)YEXPLO CALL DPWRST('XXX','BUG ') ENDIF 831 FORMAT(10X,'* CP = UNDEFINED *') 832 FORMAT(10X,'* CP = ',F12.5,' *') 861 FORMAT(10X,'* CP LOWER 95% CI = UNDEFINED *') 862 FORMAT(10X,'* CP LOWER 95% CI = ',F12.5,' *') 863 FORMAT(10X,'* CP UPPER 95% CI = UNDEFINED *') 864 FORMAT(10X,'* CP UPPER 95% CI = ',F12.5,' *') 833 FORMAT(10X,'* CPK = UNDEFINED *') 834 FORMAT(10X,'* CPK = ',F12.5,' *') 871 FORMAT(10X,'* CPK LOWER 95% CI = UNDEFINED *') 872 FORMAT(10X,'* CPK LOWER 95% CI = ',F12.5,' *') 873 FORMAT(10X,'* CPK UPPER 95% CI = UNDEFINED *') 874 FORMAT(10X,'* CPK UPPER 95% CI = ',F12.5,' *') 835 FORMAT(10X,'* ACTUAL % DEFECTIVE = UNDEFINED *') 836 FORMAT(10X,'* ACTUAL % DEFECTIVE = ',F12.5,' *') 837 FORMAT(10X,'* THEORETICAL % DEFECTIVE = UNDEFINED *') 838 FORMAT(10X,'* THEORETICAL % DEFECTIVE = ',F12.5,' *') 895 FORMAT(10X,'* ACTUAL (BELOW) % DEFECTIVE = UNDEFINED *') 896 FORMAT(10X,'* ACTUAL (BELOW) % DEFECTIVE = ',F12.5,' *') 897 FORMAT(10X,'* THEORETICAL (BELOW) % DEFECTIVE = UNDEFINED *') 898 FORMAT(10X,'* THEORETICAL(BELOW) % DEFECTIVE = ',F12.5,' *') 905 FORMAT(10X,'* ACTUAL (ABOVE) % DEFECTIVE = UNDEFINED *') 906 FORMAT(10X,'* ACTUAL (ABOVE) % DEFECTIVE = ',F12.5,' *') 907 FORMAT(10X,'* THEORETICAL (ABOVE) % DEFECTIVE = UNDEFINED *') 908 FORMAT(10X,'* THEORETICAL(ABOVE) % DEFECTIVE = ',F12.5,' *') 839 FORMAT(10X,'* EXPECTED LOSS = UNDEFINED *') 840 FORMAT(10X,'* EXPECTED LOSS = ',F12.5,' *') 841 FORMAT(10X,'* CPL = UNDEFINED *') 842 FORMAT(10X,'* CPL = ',F12.5,' *') 881 FORMAT(10X,'* CPL LOWER 95% CI = UNDEFINED *') 882 FORMAT(10X,'* CPL LOWER 95% CI = ',F12.5,' *') 883 FORMAT(10X,'* CPL UPPER 95% CI = UNDEFINED *') 884 FORMAT(10X,'* CPL UPPER 95% CI = ',F12.5,' *') 843 FORMAT(10X,'* CPU = UNDEFINED *') 844 FORMAT(10X,'* CPU = ',F12.5,' *') 891 FORMAT(10X,'* CPU LOWER 95% CI = UNDEFINED *') 892 FORMAT(10X,'* CPU LOWER 95% CI = ',F12.5,' *') 893 FORMAT(10X,'* CPU UPPER 95% CI = UNDEFINED *') 894 FORMAT(10X,'* CPU UPPER 95% CI = ',F12.5,' *') 845 FORMAT(10X,'* CNPK = UNDEFINED *') 846 FORMAT(10X,'* CNPK = ',F12.5,' *') 847 FORMAT(10X,'* CPM = UNDEFINED *') 848 FORMAT(10X,'* CPM = ',F12.5,' *') 849 FORMAT(10X,'* CPM LOWER 95% CI = UNDEFINED *') 850 FORMAT(10X,'* CPM LOWER 95% CI = ',F12.5,' *') 851 FORMAT(10X,'* CPM UPPER 95% CI = UNDEFINED *') 852 FORMAT(10X,'* CPM UPPER 95% CI = ',F12.5,' *') 853 FORMAT(10X,'* CC = UNDEFINED *') 854 FORMAT(10X,'* CC = ',F12.5,' *') WRITE(ICOUT,801) CALL DPWRST('XXX','BUG ') C 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPCAA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)N,IBUGA3,IERROR 9012 FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)CCLSL,CCUSL,CCTARG,CCUSLC 9013 FORMAT('CCLSL,CCUSL,CCTARG,CCUSLC = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IFLAG 9014 FORMAT('IFLAG = ',A4) CALL DPWRST('XXX','BUG ') DO9016I=1,N WRITE(ICOUT,9017)I,Y(I),W(I) 9017 FORMAT('I,Y(I),W(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9016 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPCAPA(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--DRAW ONE OR MORE CAPACITORS C (DEPENDING ON HOW MANY NUMBERS ARE PROVIDED). C THE COORDINATES ARE IN STANDARDIZED UNITS C OF 0 TO 100. C NOTE--THE INPUT COORDINATES DEFINE THE BACK CENTER AND THE FRONT CENTER C OF THE CAPACITOR. C NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 2 C AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*2 = 4. C NOTE--IF 2 NUMBERS ARE PROVIDED, C THEN THE DRAWN CAPACITOR WILL GO C FROM THE LAST CURSOR POSITION C TO THE (X,Y) POINT C (EITHER ABSOLUTE OR RELATIVE) C AS DEFINED BY THE 2 NUMBERS. C NOTE--IF 4 NUMBERS ARE PROVIDED, C THEN THE DRAWN CAPACITOR WILL GO C FROM THE ABSOLUTE (X,Y) POSITION C AS DEFINED BY THE FIRST 2 NUMBERS C TO THE (X,Y) POINT C (EITHER ABSOLUTE OR RELATIVE) C AS DEFINED BY THE THIRD AND FOURTH NUMBERS. C NOTE--IF 6 NUMBERS ARE PROVIDED, C THEN THE DRAWN CAPACITOR WILL GO C FROM THE (X,Y) POSITION C AS RESULTING FROM THE THIRD AND FOURTH NUMBERS C TO THE (X,Y) POINT C (EITHER ABSOLUTE OR RELATIVE) C AS DEFINED BY THE FIFTH AND SIXTH NUMBERS. C NOTE--AND SO FORTH FOR 8, 10, 12, ... NUMBERS. C INPUT ARGUMENTS--IHARG C --IARGT C --ARG C --NUMARG C --PXSTAR C --PYSTAR C OUTPUT ARGUMENTS--PXEND C --PYEND C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--APRIL 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --NOVEMBER 1982. C UPDATED --JANUARY 1989. CALL LIST FOR OFFSET VAR (ALAN) C UPDATED --MARCH 1997. SUPPORT FOR DEVICE FONT (ALAN) C UPDATED --JULY 1997. SUPPORT FOR "DATA" UNITS (ALAN) C C-----NON-COMMON VARIABLES----------------------------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT C CHARACTER*4 ILINPA CHARACTER*4 ILINCO C CHARACTER*4 IREBLI CHARACTER*4 IREBCO CHARACTER*4 IREFSW CHARACTER*4 IREFCO CHARACTER*4 IREPTY CHARACTER*4 IREPLI CHARACTER*4 IREPCO C CHARACTER*4 IGRASW CHARACTER*4 IDIASW C CHARACTER*4 IDMANU CHARACTER*4 IDMODE CHARACTER*4 IDMOD2 CHARACTER*4 IDMOD3 CHARACTER*4 IDPOWE CHARACTER*4 IDCONT CHARACTER*4 IDCOLO CCCCC ADD FOLLOWING LINE MARCH 1997. CHARACTER*4 IDFONT CCCCC ADD FOLLOWING LINE JULY 1997. CHARACTER*4 UNITSW C CHARACTER*4 IFOUND CHARACTER*4 IBUGD2 CHARACTER*4 IERROR CHARACTER*4 ISUBRO C CHARACTER*4 IFIG CHARACTER*4 IBELSW CHARACTER*4 IERASW CHARACTER*4 IBACCO CHARACTER*4 ICOPSW CHARACTER*4 ITYPEO C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) C DIMENSION ILINPA(*) DIMENSION ILINCO(*) DIMENSION PLINTH(*) C DIMENSION AREGBA(*) DIMENSION IREBLI(*) DIMENSION IREBCO(*) DIMENSION PREBTH(*) DIMENSION IREFSW(*) DIMENSION IREFCO(*) DIMENSION IREPTY(*) DIMENSION IREPLI(*) DIMENSION IREPCO(*) DIMENSION PREPTH(*) DIMENSION PREPSP(*) C DIMENSION IDMANU(*) DIMENSION IDMODE(*) DIMENSION IDMOD2(*) DIMENSION IDMOD3(*) DIMENSION IDPOWE(*) DIMENSION IDCONT(*) DIMENSION IDCOLO(*) CCCCC ADD FOLLOWING LINE MARCH 1997. DIMENSION IDFONT(*) DIMENSION IDNVPP(*) DIMENSION IDNHPP(*) DIMENSION IDUNIT(*) C DIMENSION IDNVOF(*) DIMENSION IDNHOF(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' IERRG4=IERROR CCCCC IBUGG4=IBUGD2 CCCCC ISUBG4=ISUBRO C ILOCFN=0 NUMNUM=0 C X1=0.0 Y1=0.0 X2=0.0 Y2=0.0 C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CAPA')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPCAPA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NUMARG 53 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NUMARG WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I) 56 FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2X,A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,57)PXSTAR,PYSTAR 57 FORMAT('PXSTAR,PYSTAR = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,58)PXEND,PYEND 58 FORMAT('PXEND,PYEND = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1) 61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)AREGBA(1) 62 FORMAT('AREGBA(1) = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1) 63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)IREFSW(1),IREFCO(1) 64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) 65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ', 1A4,2X,A4,2X,A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,69)PTEXHE,PTEXWI 69 FORMAT('PTEXHE,PTEXWI= ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70)PTEXVG,PTEXHG 70 FORMAT('PTEXVG,PTEXHG= ',2E15.6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,76)IGRASW,IDIASW 76 FORMAT('IGRASW,IDIASW = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC 77 FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG 78 FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,80)NUMDEV 80 FORMAT('NUMDEV= ',I8) CALL DPWRST('XXX','BUG ') DO81I=1,NUMDEV WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) 82 FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ', 1A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I) 83 FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ', 1A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I) 84 FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ', 1I8,I8,I8) CALL DPWRST('XXX','BUG ') 81 CONTINUE WRITE(ICOUT,87)IFOUND 87 FORMAT('IFOUND= ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,88)IBUGG4,ISUBG4,IERRG4 88 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,89)IBUGD2,IERROR 89 FORMAT('IBUGD2,IERROR= ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C IFIG='CAPA' NUMPT=2 NUMPT2=2*NUMPT C C ******************************** C ** STEP 0-- ** C ** STEP THROUGH EACH DEVICE ** C ******************************** C IF(NUMDEV.LE.0)GOTO9000 DO8000IDEVIC=1,NUMDEV C IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000 C IMANUF=IDMANU(IDEVIC) IMODEL=IDMODE(IDEVIC) IMODE2=IDMOD2(IDEVIC) IMODE3=IDMOD3(IDEVIC) IGCONT=IDCONT(IDEVIC) IGCOLO=IDCOLO(IDEVIC) CCCCC ADD FOLLOWING LINE MARCH 1997. IGFONT=IDFONT(IDEVIC) NUMVPP=IDNVPP(IDEVIC) NUMHPP=IDNHPP(IDEVIC) ANUMVP=NUMVPP ANUMHP=NUMHPP C AUGUST 1988. ADD OFFSET VARIABLE IOFFSV=IDNVOF(IDEVIC) IOFFSH=IDNHOF(IDEVIC) C IGUNIT=IDUNIT(IDEVIC) C C ************************************ C ** STEP 1-- ** C ** CARRY OUT OPENING OPERATIONS ** C ** ON THE GRAPHICS DEVICES ** C ************************************ C CALL DPOPDE C IBELSW='OFF' NUMRIN=0 IERASW='OFF' IBACCO='JUNK' C CALL DPOPPL(IGRASW, 1IBELSW,NUMRIN,IERASW, 1IBACCO) C C ***************************************** C ** STEP 2-- ** C ** SEARCH FOR COMMAND SPECIFICATIONS ** C ***************************************** C IF(NUMARG.GE.2.AND. 1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB') 1GOTO1111 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND. 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 1GOTO1112 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND. 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 1GOTO1113 GOTO1130 C 1111 CONTINUE ITYPEO='ABSO' ILOCFN=1 GOTO1119 C 1112 CONTINUE ITYPEO='ABSO' ILOCFN=2 GOTO1119 C 1113 CONTINUE ITYPEO='RELA' ILOCFN=2 GOTO1119 1119 CONTINUE C IF(ILOCFN.GT.NUMARG)GOTO1129 DO1120I=ILOCFN,NUMARG IF(IARGT(I).EQ.'NUMB')GOTO1120 GOTO1129 1120 CONTINUE IFOUND='YES' GOTO1149 1129 CONTINUE GOTO1130 C 1130 CONTINUE IERRG4='YES' WRITE(ICOUT,1131) 1131 FORMAT('***** ERROR IN DPCAPA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1132) 1132 FORMAT(' ILLEGAL FORM FOR DRAW ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1134) 1134 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1135) 1135 FORMAT(' SUPPOSE IT IS DESIRED TO DRAW A CAPACITOR ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1136) 1136 FORMAT(' WITH BACK CENTER AT 20 20 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1137) 1137 FORMAT(' AND FRONT CENTER AT 40 60') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT(' THEN THE ALLOWABLE FORMS ARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' CAPACITOR 20 20 40 60 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' CAPACITOR ABSOLUTE 20 20 40 60 ') CALL DPWRST('XXX','BUG ') GOTO9000 1149 CONTINUE C C **************************** C ** STEP 3-- ** C ** DRAW OUT THE LINE(S) ** C **************************** C NUMNUM=NUMARG-ILOCFN+1 IF(NUMNUM.LT.NUMPT2)GOTO1151 GOTO1152 C 1151 CONTINUE J=ILOCFN-1 X1=PXSTAR Y1=PYSTAR GOTO1159 C 1152 CONTINUE J=ILOCFN IF(J.GT.NUMARG)GOTO1190 X1=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,IBUGD2,ISUBRO,IERROR) J=J+1 IF(J.GT.NUMARG)GOTO1190 Y1=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBRO,IERROR) GOTO1159 1159 CONTINUE C 1160 CONTINUE J=J+1 IF(J.GT.NUMARG)GOTO1190 X2=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')X2=X1+X2 J=J+1 IF(J.GT.NUMARG)GOTO1190 Y2=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2 C 1170 CONTINUE CALL DPCAP2(X1,Y1,X2,Y2, 1IFIG, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) C X1=X2 Y1=Y2 C GOTO1160 1190 CONTINUE C PXEND=X2 PYEND=Y2 C C ************************************ C ** STEP 4-- ** C ** CARRY OUT CLOSING OPERATIONS ** C ** ON THE GRAPHICS DEVICES ** C ************************************ C ICOPSW='OFF' NUMCOP=0 CALL DPCLPL(ICOPSW,NUMCOP, 1PGRAXF,PGRAYF, 1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG) C CALL DPCLDE C 8000 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CAPA')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPCAPA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ILOCFN,NUMNUM 9012 FORMAT('ILOCFN,NUMNUM = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)X1,Y1,X2,Y2 9013 FORMAT('X1,Y1,X2,Y2 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)PXSTAR,PYSTAR 9015 FORMAT('PXSTAR,PYSTAR = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)PXEND,PYEND 9016 FORMAT('PXEND,PYEND = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)IFIG 9017 FORMAT('IFIG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9027)IFOUND 9027 FORMAT('IFOUND = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9028)IBUGG4,ISUBG4,IERRG4 9028 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9029)IBUGD2,IERROR 9029 FORMAT('IBUGD2,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPCAP2(X1,Y1,X2,Y2, 1IFIG, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) C C PURPOSE--DRAW AN CAPACITOR C WITH THE BACK CENTER AT (X1,Y1) C AND THE FRONT CENTER AT (X2,Y2). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--APRIL 1981. C UPDATED --MAY 1982. C UPDATED --JANUARY 1989. MODIFY CALLS TO DPDRPL (ALAN) C C-----NON-COMMON VARIABLES------------------------------------- C CHARACTER*4 IFIG C CHARACTER*4 ILINPA CHARACTER*4 ILINCO C CHARACTER*4 IREBLI CHARACTER*4 IREBCO CHARACTER*4 IREFSW CHARACTER*4 IREFCO CHARACTER*4 IREPTY CHARACTER*4 IREPLI CHARACTER*4 IREPCO C CHARACTER*4 IPATT CCCCC CHARACTER*4 ICOLF CCCCC CHARACTER*4 ICOLP CHARACTER*4 ICOL CHARACTER*4 IFLAG C DIMENSION PX(10) DIMENSION PY(10) CCCCC DIMENSION PX3(10) CCCCC DIMENSION PY3(10) C DIMENSION ILINPA(*) DIMENSION ILINCO(*) DIMENSION PLINTH(*) C DIMENSION AREGBA(*) DIMENSION IREBLI(*) DIMENSION IREBCO(*) DIMENSION PREBTH(*) DIMENSION IREFSW(*) DIMENSION IREFCO(*) DIMENSION IREPTY(*) DIMENSION IREPLI(*) DIMENSION IREPCO(*) DIMENSION PREPTH(*) DIMENSION PREPSP(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CAP2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPCAP2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)X1,Y1 53 FORMAT('X1,Y1 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)X2,Y2 54 FORMAT('X2,Y2 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IFIG 59 FORMAT('IFIG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1) 61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)AREGBA(1) 62 FORMAT('AREGBA(1) = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1) 63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)IREFSW(1),IREFCO(1) 64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) 65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ', 1A4,2X,A4,2X,A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,69)PTEXHE,PTEXWI 69 FORMAT('PTEXHE,PTEXWI= ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70)PTEXVG,PTEXHG 70 FORMAT('PTEXVG,PTEXHG= ',2E15.6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4 79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************* C ** STEP 1-- ** C ** DETERMINE THE COORDINATES ** C ** FOR THE CAPACITOR ** C ********************************* C DELX=X2-X1 DELY=Y2-Y1 LEN=SQRT((X2-X1)**2+(Y2-Y1)**2) ALEN=LEN IF(ABS(DELX).GE.0.00001)THETA=ATAN(DELY/DELX) IF(ABS(DELX).LT.0.00001.AND.DELY.GE.0.0)THETA=3.1415926/2.0 IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0)THETA=-3.1415926/2.0 C AJXMIN=PTEXWI AJXDEL=PTEXWI AJYDEL=PTEXHE AJXMAX=ALEN-AJXDEL C XMIN=AJXMIN XDEL=AJXDEL YDEL=AJYDEL XMAX=AJXMAX C K=0 C X=0 CCCCC Y=-ALEN/2.0 Y=(-YDEL/2.0) CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C X=0 CCCCC Y=ALEN/2.0 Y=YDEL/2.0 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C NP=K C IPATT=ILINPA(1) PTHICK=PLINTH(1) ICOL=ILINCO(1) IFLAG='ON' CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3, CCCCC1IFIG,IPATT,PTHICK,ICOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) C K=0 C X=ALEN CCCCC Y=-ALEN/2.0 Y=(-YDEL/2.0) CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C X=ALEN CCCCC Y=ALEN/2.0 Y=YDEL/2.0 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C NP=K C IFLAG='ON' CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3, CCCCC1IFIG,IPATT,PTHICK,ICOL) CALL DPDRPL(PX,PY,NP, 1IFIG,IPATT,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CAP2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPCAP2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NP 9014 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NP WRITE(ICOUT,9016)I,PX(I),PY(I) 9016 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4 9039 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPCAPT(ICOM,ICOM2, CCCCC JUNE 2002. ADD ICAPTY SWITCH. 1ICAPSW,ICAPTY,ICAPSC,IPRDEF, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,MAXNAM,IANSLC,IANS,IWIDTH, 1IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 1IOFILE, CCCCC JUNE 2002. ADD FOLLOWING ARGUMENTS TO ALLOW "CALL DPERAS". 1IBACCO, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, 1IDFONT, CCCCC END OF NEW ARGUMENTS 1IREPCH,IMPSW, 1IBUGS2,ISUBRO,IFOUND,IERROR) C C PURPOSE--INITIATE/TERMINATE A CAPTURE FILE C FOR CAPTURING/REDIRECTIUNG ALPHANUMERIC C OUTPUT (ONLY)--NOT EFFECT GRAPHICS OUTPUT. C THERE ARE 2 CAPABILITITES IN THIS REGARD-- C 1) TURN THE CAPTURE SWITCH 'ON' WHICH WILL C ALLOW A CAPTURE FILE TO BE OPENED. C 2) TURN THE CAPTURE SWITCH 'OFF' WHICH WILL C TERMINATE THE ENTRY OF TEXT OUTPUT C INTO THE CAPTURE FILE. C NOTE--THESE CAPABILITITIES C WILL ALLOW THE ALPHANUMERIC OUTPUT C (NOT GRAPHICS OUTPUT) C FROM ANY DATAPLOT COMMAND TO C BE CAPTURED (OR REDIRECTED) C TO ANY FILE. C ALL SUBSEQUENT DATAPLOT ALPHANUMERIC OUTPUT C ARE AUTOMATICALLY DIVERTED FROM THE SCREEN C TO THE SPECIFIED SYSTEM FILE OR SUBFILE. C WHEN THE CAPTURE SWITCH IS OFF, C NO SUCH DIVERSION IS DONE. C THE SPECIFIED STATUS (ON/OFF) OF THE CAPTURE C WILL BE PLACED C IN THE HOLLERITH VARIABLE ICAPSW. C INPUT ARGUMENTS--ICOM C --ICOM2 C --ICAPSW C --ICAPTY C --IANSLC (A HOLLERITH VECTOR WHOSE C I-TH ELEMENT CONTAINS THE C I-TH CHARACTER OF THE C ORIGINAL INPUT COMMAND LINE. C --IWIDTH (AN INTEGER VARIABLE WHICH C CONTAINS THE NUMBER OF CHARACTERS C IN THE ORIGINAL COMMAND LINE. C --IHARG (A HOLLERITH VECTOR) C --NUMARG (AN INTEGER VARIABLE) C --IBUG (A HOLLERITH VARIABLE C FOR DEBUGGING C PRIMARY CHANGED VARIABLE--IPR (IN COMMON) C OUTPUT ARGUMENTS--ICAPSW (AN INTEGER VARIABLE C WHICH IF 'ON' INDICATES THAT C CURRENT COMMANDS ARE C BEING DIVERTED C TO A CAPTURE TEXT; AND C IF OFF INDICATES THAT C A CAPTURE FILE IS NOT BEING CONSTRUCTED. C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89/6 C ORIGINAL VERSION--JUNE 1989. C UPDATED --JUNE 2002. ADD SUPPORT FOR: C CAPTURE FLUSH C CAPTURE HTML FILE. C CAPTURE LATEX FILE. C UPDATED --JANUARY 2003. FOR CAPTURE HTML, OPTIONALLY C READ HEADER AND FOOTER FILES C UPDATED --JULY 2003. BUG: FILE NAME < 80 C CHARACTERS, BUT COMMAND LINE C > 80 CHARACTERS C UPDATED --SEPTEMBER 2003. START IMPLEMENTING THE LATEX C CODE C UPDATED --FEBRUARY 2005. START IMPLEMENTING THE RTF C CODE C UPDATED --DECEMBER 2005. SUSPEND/RESUME CASES C UPDATED --JANUARY 2006. CAPTURE SCREEN C UPDATED --FEBRUARY 2006. ADD EPIC, EEPIC, GRAPHICS C PACKAGES TO LATEX PRE-AMBLE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICOM CHARACTER*4 ICOM2 CHARACTER*4 ICAPSW CHARACTER*4 ICAPTY CHARACTER*4 ICAPSC CHARACTER*4 IHNAME CHARACTER*4 IHNAM2 CHARACTER*4 IUSE CHARACTER*4 IANSLC CHARACTER*4 IANS CHARACTER*4 IHARG CHARACTER*4 IHARG2 CHARACTER*4 IARGT CHARACTER*4 IOFILE C CHARACTER*240 IATEMP CHARACTER*4 IATMP2 CHARACTER*1 ITEMP C CHARACTER*4 IREPCH CHARACTER*4 IMPSW C CHARACTER*4 IBUGS2 CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IPROT CHARACTER*12 ICURST CHARACTER*4 IENDFI CHARACTER*4 IREWIN CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI C CHARACTER*80 IFILE2 CHARACTER*12 ISTAT2 CHARACTER*12 IFORM2 CHARACTER*12 IACCE2 CHARACTER*12 IPROT2 CHARACTER*12 ICURS2 CHARACTER*4 IERRF2 CHARACTER*4 IENDF2 CHARACTER*4 IREWI2 C CHARACTER*4 IANSI CCCCC CHARACTER*80 ICANS CHARACTER*200 ICANS C CHARACTER*4 IH CHARACTER*4 IH2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 IFILQ2 C CHARACTER*1 IBASLC C C --------------------------------------------------------------------- C DIMENSION IANSLC(*) DIMENSION IANS(*) DIMENSION IHARG(*) DIMENSION IHARG2(*) DIMENSION IARGT(*) DIMENSION IARG(*) DIMENSION ARG(*) C DIMENSION IHNAME(*) DIMENSION IHNAM2(*) DIMENSION IUSE(*) DIMENSION IVALUE(*) DIMENSION VALUE(*) C CHARACTER*4 IBACCO C CHARACTER*4 IGRASW CHARACTER*4 IDIASW C CHARACTER*4 IDMANU CHARACTER*4 IDMODE CHARACTER*4 IDMOD2 CHARACTER*4 IDMOD3 C CHARACTER*4 IDPOWE CHARACTER*4 IDCONT CHARACTER*4 IDCOLO CHARACTER*4 IDFONT C CHARACTER*4 IFLAG C DIMENSION IDMANU(*) DIMENSION IDMODE(*) DIMENSION IDMOD2(*) DIMENSION IDMOD3(*) C DIMENSION IDPOWE(*) DIMENSION IDCONT(*) DIMENSION IDCOLO(*) DIMENSION IDFONT(*) DIMENSION IDNVPP(*) DIMENSION IDNHPP(*) DIMENSION IDUNIT(*) C DIMENSION IDNVOF(*) DIMENSION IDNHOF(*) C C-----COMMON---------------------------------------------------------- C CHARACTER*4 IRTFMD COMMON/COMRTF/IRTFMD C INCLUDE 'DPCOST.INC' INCLUDE 'DPCOFO.INC' INCLUDE 'DPCOF2.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPCA' ISUBN2='PT ' C IFOUND='YES' IERROR='NO' C IFILQ2=IFILQU IFILQU='ON' C KMIN=0 KDEL=0 KMAX=0 JP3=0 JP4=0 JP5=0 IH='UNKN' IH2='UNKN' J12=0 J22=0 J32=0 J42=0 J52=0 J62=0 J72=0 J82=0 J92=0 J102=0 IPAR2=0 IPAR3=0 IPAR4=0 IPAR5=0 IPAR6=0 IPAR7=0 IPAR8=0 IPAR9=0 IPAR10=0 C P2=0.0 C CALL DPCONA(92,IBASLC) C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'CAPT')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPCAPT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICAPSW,ICAPTY,ICAPNU,ICAPCS,IPR,IPRDEF 52 FORMAT('ICAPSW,ICAPTY,ICAPNU,ICAPCS,IPR,IPRDEF = ', 1 2A4,I8,2X,A12,2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGS2,IERROR 53 FORMAT('IBUGS2,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ICOM,ICOM2,IWIDTH 54 FORMAT('ICOM,ICOM2,IWIDTH = ',A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)(IANSLC(I),I=1,MIN(120,IWIDTH)) 55 FORMAT('IANSLC(.) = ',120A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)NUMARG 56 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMARG.LE.0)GOTO59 DO57I=1,NUMARG WRITE(ICOUT,58)I,IHARG(I),IHARG2(I) 58 FORMAT('I,IHARG(I),IHARG2(I) = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 57 CONTINUE 59 CONTINUE WRITE(ICOUT,62)NUMNAM,MAXNAM 62 FORMAT('NUMNAM,MAXNAM = ',2I8) CALL DPWRST('XXX','BUG ') DO65I=1,NUMNAM WRITE(ICOUT,66)I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) 66 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) = ', 1I8,2X,A4,2X,A4,2X,A4,I8,E15.7) CALL DPWRST('XXX','BUG ') 65 CONTINUE WRITE(ICOUT,72)NUMCHA 72 FORMAT('NUMCHA = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)(IA(I),I=1,MIN(100,NUMCHA)) 73 FORMAT('(IA(I),I=1,NUMCHA) = ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,81)ICAPNU 81 FORMAT('ICAPNU = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,82)ICAPNA 82 FORMAT('ICAPNA = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,83)ICAPST 83 FORMAT('ICAPST = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,84)ICAPFO 84 FORMAT('ICAPFO = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,85)ICAPAC 85 FORMAT('ICAPAC = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,86)ICAPFO 86 FORMAT('ICAPFO = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,87)ICAPCS 87 FORMAT('ICAPCS = ',A12) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C **************************************************** C ** STEP 11-- ** C ** FOR THE SPECIAL CASE WHEN THE ** C ** CAPTURING OF ALPHA TEXT HAS JUST BEEN FINISHED, ** C ** JUMP TO CLOSING THE FILE ** C **************************************************** C ISTEPN='11' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICAPCS.EQ.'CLO2 ')GOTO5000 C C *********************************************** C ** STEP 12-- ** C ** FOR THE SPECIAL CASE WHEN HAVE THE ** C ** END CAPTURE COMMAND, OR THE ** C ** END REDIRECT COMMAND, OR THE ** C ** END OF CAPTURE COMMAND, ** C ** END OF REDIRECT COMMAND, ** C ** JUMP IMMEDIATELY TO THE SECTION OF CODE ** C ** WHICH PUTS ON AN END OF FILE AND ** C ** CLOSES THE FILE/SUBFILE. ** C *********************************************** C ISTEPN='12' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICOM.EQ.'END ')THEN IF(NUMARG.LE.0)GOTO1290 IF(IHARG(1).EQ.'CAPT')GOTO4000 IF(IHARG(1).EQ.'REDI')GOTO4000 IF(IHARG(1).EQ.'DIVE')GOTO4000 IF(IHARG(1).EQ.'PIPE')GOTO4000 IF(NUMARG.LE.1)GOTO1290 IF(IHARG(1).EQ.'OF '.AND.IHARG(2).EQ.'CAPT')GOTO4000 IF(IHARG(1).EQ.'OF '.AND.IHARG(2).EQ.'REDI')GOTO4000 IF(IHARG(1).EQ.'OF '.AND.IHARG(2).EQ.'DIVE')GOTO4000 IF(IHARG(1).EQ.'OF '.AND.IHARG(2).EQ.'PIPE')GOTO4000 ELSEIF(ICOM.EQ.'FLUS')THEN IF(NUMARG.LT.1)GOTO1290 IF(IHARG(1).EQ.'CAPT')GOTO6000 ELSEIF(ICOM.EQ.'CAPT')THEN IF(NUMARG.LT.1)GOTO1290 IF(IHARG(1).EQ.'FLUS')GOTO6000 ENDIF C 1290 CONTINUE C C **************************************************************** C ** STEP 13-- C ** DETERMINE THE TYPE CASE-- C ** 1) CREATE AN EXPLICIT CAPTURE FILE; C ** 2) OMIT THE FILE NAME; C ** NOTE--IOFILE WILL EQUAL 'YES' ONLY IN FILE CASE. C ** IN OTHER WORDS, THIS STEP MAKES SURE C ** THAT A FILE NAME IS EXISTENT AFTER THE C ** CAPTURE AND REDIRECT COMMANDS. C **************************************************************** C ISTEPN='13' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'SUSP')GOTO2000 IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'OFF ')GOTO2000 IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'RESU')GOTO2000 IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'ON ')GOTO2000 IF(NUMARG.GE.1 .AND. IHARG(1).EQ.'SCRE')GOTO2000 C IWORD=2 IF(IHARG(1).EQ.'HTML'.OR.IHARG(1).EQ.'LATE'.OR. 1 IHARG(1).EQ.'RTF ')IWORD=3 CALL DPFILE(IANSLC,IWIDTH,IWORD, 1IOFILE,IBUGS2,ISUBRO,IERROR) C C ********************************************** C ** STEP 14-- ** C ** IF NO FILE NAME GIVEN, ** C ** THEN GENERATE AN ERROR MESSAGE. ** C ********************************************** C 1401 CONTINUE ISTEPN='14' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IOFILE.EQ.'YES')GOTO1490 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1411) 1411 FORMAT('***** ERROR IN DPCAPT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1412) 1412 FORMAT(' THE DESIRED CAPTURE OPERATION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1413) 1413 FORMAT(' CANNOT BE CARRIED OUT BECAUSE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1414) 1414 FORMAT(' NO USER FILE NAME WAS GIVEN.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1415) 1415 FORMAT(' ILLUSTRATIVE EXAMPLE TO DEMONSTRATE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1416) 1416 FORMAT(' THE PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1417) 1417 FORMAT(' SUPPOSE THE ANALYST WISHES TO CAPTURE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1419) 1419 FORMAT(' TEXT OUTPUT TO THE FILE TEMP1. ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1420) 1420 FORMAT(' THEN THE FOLLOWING COMMAND LINE IS ENTERED--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1421) 1421 FORMAT(' CAPTURE TEMP1.') CALL DPWRST('XXX','BUG ') GOTO9000 1490 CONTINUE C C ************************************* C ** STEP 15-- ** C ** IF HAVE THE FILE INPUT CASE ** C ** (WHICH WE MUST HAVE)-- ** C ** COPY OVER VARIABLES ** C ************************************* C ISTEPN='15' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOUNIT=ICAPNU IFILE=ICAPNA ISTAT=ICAPST IF(IFILE.EQ.ISYSNA)ISTAT=ISYSST IF(IFILE.EQ.ILOGNA)ISTAT=ILOGST IFORM=ICAPFO IACCES=ICAPAC IPROT=ICAPPR C (SEE ADDITIONAL RESETTING OF IPROT BELOW C IF HAVE THE SYSTEM LOGIN AND/OR THE LOCAL LOGIN CAPTURE FILES) ICURST=ICAPCS C ISUBN0='CAPT' IERRFI='NO' C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'CAPT')GOTO1519 WRITE(ICOUT,1513)IOUNIT 1513 FORMAT('IOUNIT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1514)IFILE 1514 FORMAT('IFILE = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1515)ISTAT,IFORM,IACCES,IPROT,ICURST 1515 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ', 1A12,2X,A12,2X,A12,2X,A12,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1516)ISUBN0,IERRFI 1516 FORMAT('ISUBN0,IERRFI = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 1519 CONTINUE C C *********************************************** C ** STEP 16-- ** C ** IF HAVE THE FILE CASE-- ** C ** (WHICH WE MUST HAVE)-- ** C ** CHECK TO SEE IF THE CAPTURE FILE MAY EXIST ** C *********************************************** C ISTEPN='16' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ISTAT.EQ.'NONE')GOTO1610 GOTO1690 C 1610 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1611) 1611 FORMAT('***** IMPLEMENTATION ERROR IN DPCAPT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1612) 1612 FORMAT(' THE DESIRED CAPTURE OPERATION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1613) 1613 FORMAT(' CANNOT BE CARRIED OUT BECAUSE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1614) 1614 FORMAT(' THE INTERNAL VARIABLE ICAPST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1615) 1615 FORMAT(' WHICH ALLOWS SUCH CAPTURE OPERATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1616) 1616 FORMAT(' HAS BEEN SET TO NONE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1617)ISTAT,ICAPST 1617 FORMAT('ISTAT,ICAPST = ',A12,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1618) 1618 FORMAT(' PLEASE CONTACT YOUR DATAPLOT IMPLEMENTOR') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1619) 1619 FORMAT(' TO CORRECT THE SETTING IN SUBROUTINE INITFO.') CALL DPWRST('XXX','BUG ') GOTO9000 C 1690 CONTINUE C C ******************************** C ** STEP 17-- ** C ** EXTRACT THE FILE NAME. ** C ** THIS IS NEEDED FOR MOST ** C ** (BUT NOT ALL) VARIATIONS ** C ** OF THE CAPTURE COMMAND. ** C ******************************** C ISTEPN='17' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC JUNE 2002. CHECK TO SEE IF FIRST ARGUMENT IS: CCCCC HTML CCCCC LATEX CCCCC RTF (FEBRUARY 2005) C NSTRT=1 C IF(IHARG(1).EQ.'HTML')THEN ICAPTY='HTML' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1771) 1771 FORMAT('THE CAPTURE OUTPUT WILL BE WRITTEN IN HTML FORMAT.') CALL DPWRST('XXX','BUG ') ELSEIF(IHARG(1).EQ.'LATE')THEN ICAPTY='LATE' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1791) 1791 FORMAT('THE CAPTURE OUTPUT WILL BE WRITTEN IN LATEX FORMAT.') CALL DPWRST('XXX','BUG ') ELSEIF(IHARG(1).EQ.'RTF ')THEN ICAPTY='RTF ' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1793) 1793 FORMAT('THE CAPTURE OUTPUT WILL BE WRITTEN IN ', 1 'RTF (RICH TEXT FORMAT) FORMAT.') CALL DPWRST('XXX','BUG ') ENDIF C DO1710I=1,200 IANSI=IANSLC(I) ICANS(I:I)=IANSI(1:1) 1710 CONTINUE C ISTART=1 ISTOP=IWIDTH IWORD=2 IF(ICAPTY.EQ.'HTML')IWORD=3 IF(ICAPTY.EQ.'LATE')IWORD=3 IF(ICAPTY.EQ.'RTF ')IWORD=3 CALL DPEXWO(ICANS,ISTART,ISTOP,IWORD, 1ICOL1,ICOL2,IFILE,NCFILE, 1IBUGS2,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IF(NCFILE.GE.1)GOTO1749 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1741) 1741 FORMAT('***** ERROR IN DPCAPT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1742) 1742 FORMAT(' A USER FILE NAME IS REQUIRED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1743) 1743 FORMAT(' IN THE CAPTURE/REDIRECT COMMANDS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1744) 1744 FORMAT(' (FOR EXAMPLE, CAPTURE TEMP1.)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1745) 1745 FORMAT(' BUT NONE WAS GIVEN HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1746) 1746 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1747)(IANSLC(I),I=1,IWIDTH) 1747 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IF(IWIDTH.LE.0)WRITE(ICOUT,999) IF(IWIDTH.LE.0)CALL DPWRST('XXX','BUG ') GOTO9000 1749 CONTINUE C 1790 CONTINUE IF(IERROR.EQ.'YES')GOTO9000 IF(IFILE.EQ.ISYSNA)IPROT=ISYSPR IF(IFILE.EQ.ILOGNA)IPROT=ILOGPR C C ***************************************** C ** STEP 20-- ** C ** CHECK THE DESIRED CAPTURE OPERATION ** C ** (ON, OFF, OR EXECUTE). ** C ***************************************** C 2000 CONTINUE C ISTEPN='20' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICOM.EQ.'CAPT')GOTO2100 IF(ICOM.EQ.'REDI')GOTO2100 IF(ICOM.EQ.'DIVE')GOTO2100 IF(ICOM.EQ.'PIPE')GOTO2100 IF(ICOM.EQ.'END '.AND.ICOM2.EQ.' ')GOTO2200 GOTO2900 C 2100 CONTINUE CCCCC IF(NUMARG.LE.0)GOTO2900 IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'SUSP')GOTO3800 IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'OFF ')GOTO3800 IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'RESU')GOTO3900 IF(NUMARG.EQ.1 .AND. IHARG(1).EQ.'ON ')GOTO3900 IF(NUMARG.GE.1 .AND. IHARG(1).EQ.'SCRE')THEN ICAPSC='ON' IF(NUMARG.GE.2 .AND. IHARG(2).EQ.'OFF ')ICAPSC='OFF ' IF(NUMARG.GE.2 .AND. IHARG(2).EQ.'END ')ICAPSC='OFF ' IF(NUMARG.GE.2 .AND. IHARG(2).EQ.'NO ')ICAPSC='OFF ' IF(NUMARG.GE.2 .AND. IHARG(2).EQ.'NONE')ICAPSC='OFF ' IF(NUMARG.GE.2 .AND. IHARG(2).EQ.'CLOS')ICAPSC='OFF ' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IF(IFEEDB.EQ.'OFF')GOTO9000 IF(ICAPSC.EQ.'ON')THEN WRITE(ICOUT,2111) 2111 FORMAT('CAPTURE OUTPUT WILL BE WRITTEN TO BOTH THE ', 1 'CAPTURE FILE AND THE SCREEN.') ELSE WRITE(ICOUT,2113) 2113 FORMAT('CAPTURE OUTPUT WILL BE WRITTEN TO THE ', 1 'CAPTURE FILE ONLY.') ENDIF CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF GOTO3000 C 2200 CONTINUE IF(NUMARG.LE.0)GOTO2900 IF(IHARG(1).EQ.'CAPT')GOTO4000 IF(IHARG(1).EQ.'REDI')GOTO4000 IF(IHARG(1).EQ.'DIVE')GOTO4000 IF(IHARG(1).EQ.'PIPE')GOTO4000 IF(NUMARG.LE.1)GOTO2900 IF(IHARG(1).EQ.'OF '.AND.IHARG(2).EQ.'CAPT')GOTO4000 IF(IHARG(1).EQ.'OF '.AND.IHARG(2).EQ.'REDI')GOTO4000 IF(IHARG(1).EQ.'OF '.AND.IHARG(2).EQ.'DIVE')GOTO4000 IF(IHARG(1).EQ.'OF '.AND.IHARG(2).EQ.'PIPE')GOTO4000 GOTO2900 C 2900 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2911) 2911 FORMAT('***** ERROR IN DPCAPT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2912) 2912 FORMAT(' THE DESIRED CAPTURE OPERATION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2913) 2913 FORMAT(' CANNOT BE CARRIED OUT BECAUSE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2914) 2914 FORMAT(' SPECIFIED OPERATION WAS ILLEGAL.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2915) 2915 FORMAT(' ILLUSTRATIVE EXAMPLE TO DEMONSTRATE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2916) 2916 FORMAT(' THE PROPER FORMS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2917) 2917 FORMAT(' CAPTURE TEMP1.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2918) 2918 FORMAT(' END OF CAPTURE') CALL DPWRST('XXX','BUG ') GOTO9000 C C **************************************************************** C ** STEP 30-- C ** TREAT THE CAPTURE CASE. C ** CARRY OUT WHATEVER SYSTEM OPERATIONS ARE NEEDED C ** IN ORDER TO OPERATE ON THE FILE OR SUBFILE. C ** FOR MOST INSTALLATIONS, THIS REQUIRES C ** 1) AN OPENING OF THE FILE OR SUBFILE; C ** 2) AN EQUIVALENCING OF THE FILE OR SUBFILE; C ** 3) A REWINDING OF THE FILE OR SUBFILE. C ** THE CODE BELOW C ** OPENS THE FILE OR SUBFILE (VIA @ASG,AX ON THE UNIVAC 1108). C ** THE CODE ALSO EQUIVALENCES THE FILES OR SUBFILES (VIA @USE O C ** UNIVAC 1108) TO THE FORTRAN LOGICAL UNIT NUMBER DESIGNATED C ** IN THE VARIABLE ICAPNU (IN THE SUBROUTINE C ** INITFO); C ** THE CODE ALSO REWINDS THE FILE OR SUBFILE. (VIA @REWIND ON T C ** UNIVAC 1108). C **************************************************************** C 3000 CONTINUE ISTEPN='30' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICAPSW='ON' IOUNIT=ICAPNU C ICAPNA=IFILE C IREWIN='ON' CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IF(IERRFI.EQ.'YES')GOTO9000 ICAPCS=ICURST C IF(IFEEDB.EQ.'OFF')GOTO3029 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3011) 3011 FORMAT('THE CAPTURE SWITCH HAS JUST BEEN TURNED ON.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3012)ICAPNA 3012 FORMAT('NAME OF CAPTURE FILE = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3013) 3013 FORMAT('ALL SUBSEQUENT TEXT OUTPUT FROM ANY DATAPLOT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3014) 3014 FORMAT('COMMAND WILL BE CAPTURED/REDIRECTED INTO THIS FILE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3015) 3015 FORMAT('ONLY TEXT OUTPUT IS CAPTURED--NOT GRAPHICS OUTPUT.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3016) 3016 FORMAT('THE CAPTURED INFO WILL OVERWRITE THE PREVIOUS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3017) 3017 FORMAT('CONTENTS OF THE SPECIFIED FILE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3018) 3018 FORMAT('THE TEXT CAPTURING WILL CONTINUE UNTIL YOU ENTER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3019) 3019 FORMAT('THE COMMAND END OF CAPTURE') CALL DPWRST('XXX','BUG ') 3029 CONTINUE C IPR=ICAPNU C CCCCC JUNE 2002. SPECIAL CASE OF GRAPHICS, LATEK, OR HTML. ADD CCCCC ANY SPECIAL NEEDED INITIALIZATION CODE HERE. C CCCCC JANUARY 2003. SET HTML HEADER FILE CAN BE USED TO SPECIFY A CCCCC A FILE TO INCORPORATE THE HEADER FILE. C CCCCC IF(ICAPTY.EQ.'GRAP')THEN CCCCC CONTINUE IF(ICAPTY.EQ.'HTML')THEN IF(IHTMHE.EQ.'NULL')THEN WRITE(ICOUT,3071) 3071 FORMAT('') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,3073) 3073 FORMAT('') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,3075) 3075 FORMAT('') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,3077) 3077 FORMAT('Dataplot Output') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,3079) 3079 FORMAT('') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,3081) 3081 FORMAT('') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,3083) 3083 FORMAT('') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,3085) 3085 FORMAT('') CALL DPWRST('XXX','WRIT') ELSE IOUNI2=IST1NU IFILE2=IHTMHE ISTAT2='OLD' IFORM2='FORMATTED' IACCE2='SEQUENTIAL' IPROT2='READONLY' ICURS2='CLOSED' ISUBN0='CAPT' IERRF2='NO' C IREWI2='ON' CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1 IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C C NOW LOOP THROUGH FILE (ASSUME MAXIMUM OF 1,000 LINES). C DO3091I=1,1000 IATEMP=' ' READ(IOUNI2,3092,END=3099,ERR=3099)IATEMP 3092 FORMAT(A240) ILAST=1 DO3096J=240,1,-1 IF(IATEMP(J:J).NE.' ')THEN ILAST=J GOTO3098 ENDIF 3096 CONTINUE 3098 CONTINUE WRITE(ICOUT,3094)(IATEMP(J:J),J=1,ILAST) NCOUT=ILAST 3094 FORMAT(240A1) CALL DPWRST('XXX','WRIT') 3091 CONTINUE 3099 CONTINUE IENDF2='OFF' IREWI2='ON' CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1 IENDF2,IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 ENDIF WRITE(ICOUT,3087) 3087 FORMAT('
')
        CALL DPWRST('XXX','WRIT')
      ELSEIF(ICAPTY.EQ.'LATE')THEN
        IF(ILATHE.EQ.'NULL')THEN
          WRITE(ICOUT,3171)IBASLC
 3171     FORMAT(A1,'documentclass[12pt]{article}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3173)IBASLC
 3173     FORMAT(A1,'usepackage{epsfig}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3174)IBASLC
 3174     FORMAT(A1,'usepackage{epic,eepic}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3175)IBASLC
 3175     FORMAT(A1,'usepackage{graphics,color}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,13171)IBASLC,IBASLC
13171     FORMAT(A1,'setlength{',A1,'textwidth}{6.25in}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,13172)IBASLC,IBASLC
13172     FORMAT(A1,'setlength{',A1,'textheight}{9in}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,13173)IBASLC,IBASLC
13173     FORMAT(A1,'setlength{',A1,'oddsidemargin}{0.25in}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,13174)IBASLC,IBASLC
13174     FORMAT(A1,'setlength{',A1,'evensidemargin}{0in}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,13175)IBASLC,IBASLC
13175     FORMAT(A1,'setlength{',A1,'headheight}{0.5in}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,13176)IBASLC,IBASLC
13176     FORMAT(A1,'setlength{',A1,'headsep}{0.5in}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,13177)IBASLC,IBASLC
13177     FORMAT(A1,'setlength{',A1,'topmargin}{-1in}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,13178)IBASLC,IBASLC
13178     FORMAT(A1,'setlength{',A1,'parindent}{0in}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,13179)IBASLC,IBASLC
13179     FORMAT(A1,'setlength{',A1,'parskip}{10pt}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,13180)IBASLC,IBASLC
13180     FORMAT(A1,'setlength{',A1,'textfloatsep}{4ex}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,13181)IBASLC,IBASLC
13181     FORMAT(A1,'addtolength{',A1,'footskip}{0.25in}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,13182)IBASLC
13182     FORMAT(A1,'overfullrule=0pt')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,13183)IBASLC
13183     FORMAT(A1,'baselineskip=12pt')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3181)IBASLC,IBASLC,IBASLC
 3181     FORMAT(A1,'newcommand{',A1,'PGRAPHIC}[1]{',A1,'begin{figure}',
     1           '[h]')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3182)IBASLC
 3182     FORMAT(23X,A1,'epsfig{file=#1,width=6.0in}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3183)IBASLC
 3183     FORMAT(23X,A1,'end{figure}}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3186)IBASLC,IBASLC,IBASLC
 3186     FORMAT(A1,'newcommand{',A1,'LGRAPHIC}[1]{',A1,'begin{figure}',
     1           '[h]')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3187)IBASLC
 3187     FORMAT(23X,A1,'epsfig{file=#1,angle=-90,width=6.0in}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3188)IBASLC
 3188     FORMAT(23X,A1,'end{figure}}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3191)IBASLC
 3191     FORMAT(A1,'begin{document}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3197)IBASLC
 3197     FORMAT(A1,'begin{verbatim}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
        ELSE
          IOUNI2=IST1NU
          IFILE2=ILATHE
          ISTAT2='OLD'
          IFORM2='FORMATTED'
          IACCE2='SEQUENTIAL'
          IPROT2='READONLY'
          ICURS2='CLOSED'
          ISUBN0='CAPT'
          IERRF2='NO'
C
          IREWI2='ON'
          CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
     1                IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR)
          IF(IERRF2.EQ.'YES')GOTO9000
C
C  NOW LOOP THROUGH FILE (ASSUME MAXIMUM OF 1,000 LINES).
C
          DO3291I=1,1000
            IATEMP=' '
            READ(IOUNI2,3292,END=3299,ERR=3299)IATEMP
 3292       FORMAT(A240)
            ILAST=1
            DO3296J=240,1,-1
              IF(IATEMP(J:J).NE.' ')THEN
                ILAST=J
                GOTO3298
              ENDIF
 3296       CONTINUE
 3298       CONTINUE
            WRITE(ICOUT,3294)(IATEMP(J:J),J=1,ILAST)
            NCOUT=ILAST
 3294       FORMAT(240A1)
            CALL DPWRST('WRIT','BUG ')
 3291     CONTINUE
 3299     CONTINUE
          IENDF2='OFF'
          IREWI2='ON'
          CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
     1                IENDF2,IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR)
          IF(IERRF2.EQ.'YES')GOTO9000
          WRITE(ICOUT,3197)IBASLC
          CALL DPWRST('XXX','WRIT')
        ENDIF
      ELSEIF(ICAPTY.EQ.'RTF ')THEN
CCCCC   IF(IRTFHE.EQ.'NULL')THEN
          WRITE(ICOUT,3351)IBASLC,IBASLC,IBASLC
 3351     FORMAT('{',A1,'rtf1',A1,'ansi',A1,'deff0')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3361)IBASLC
 3361     FORMAT('{',A1,'fonttbl')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3363)IBASLC,IBASLC
 3363     FORMAT('{',A1,'f0',A1,'froman Times New Roman;}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3367)IBASLC,IBASLC
 3367     FORMAT('{',A1,'f1',A1,'fmodern Courier New;}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3369)IBASLC,IBASLC
 3369     FORMAT('{',A1,'f2',A1,'froman Arial;}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3371)IBASLC,IBASLC
 3371     FORMAT('{',A1,'f3',A1,'froman Bookman;}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3373)IBASLC,IBASLC
 3373     FORMAT('{',A1,'f4',A1,'froman Georgia;}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3375)IBASLC,IBASLC
 3375     FORMAT('{',A1,'f5',A1,'fswiss Tahoma;}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3376)IBASLC,IBASLC
 3376     FORMAT('{',A1,'f6',A1,'fswiss Lucida Sans;}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3377)IBASLC,IBASLC
 3377     FORMAT('{',A1,'f7',A1,'fswiss Verdana;}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3378)IBASLC,IBASLC
 3378     FORMAT('{',A1,'f8',A1,'fmodern Lucida Console;}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3379)
 3379     FORMAT('}')
          CALL DPWRST('XXX','WRIT')
C
          WRITE(ICOUT,3384)IBASLC
 3384     FORMAT('{',A1,'info')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3385)IBASLC
 3385     FORMAT('{',A1,'title Dataplot RTF Document}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3386)IBASLC
 3386     FORMAT('{',A1,'author Alan Heckert}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3387)IBASLC
 3387     FORMAT('{',A1,'company Statistical Engineering Division, ',
     1           'NIST}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3379)
          CALL DPWRST('XXX','WRIT')
C
CCCCC     IPTSZ=2*IRTFPS
          IPTSZ=IRTFPS
          IF(IPTSZ.LT.0 .OR. IPTSZ.GT.99)IPTSZ=20
          ITEMP='0'
          IF(IRTFFP.EQ.'Arial')ITEMP='2'
          IF(IRTFFP.EQ.'Bookman')ITEMP='3'
          IF(IRTFFP.EQ.'Georgia')ITEMP='4'
          IF(IRTFFP.EQ.'Tahoma')ITEMP='5'
          IF(IRTFFP.EQ.'Lucida Sans')ITEMP='6'
          IF(IRTFFP.EQ.'Verdana')ITEMP='7'
          IF(IPTSZ.LE.9)THEN
            WRITE(ICOUT,3381)IBASLC,IBASLC,IBASLC,IBASLC,ITEMP,
     1                       IBASLC,IPTSZ
 3381       FORMAT(A1,'delang1033',A1,'widowctrl',A1,'plain',
     1             A1,'f',A1,A1,'fs',I1)
          ELSE
            WRITE(ICOUT,3382)IBASLC,IBASLC,IBASLC,IBASLC,ITEMP,
     1                       IBASLC,IPTSZ
 3382       FORMAT(A1,'delang1033',A1,'widowctrl',A1,'plain',
     1             A1,'f',A1,A1,'fs',I2)
          ENDIF
          CALL DPWRST('XXX','WRIT')
C
          WRITE(ICOUT,3389)IBASLC
 3389     FORMAT('{',A1,'pard')
          CALL DPWRST('XXX','WRIT')
          IRTFMD='VERB'
        ELSE
CCCCC     IOUNI2=IST1NU
CCCCC     IFILE2=ILATHE
CCCCC     ISTAT2='OLD'
CCCCC     IFORM2='FORMATTED'
CCCCC     IACCE2='SEQUENTIAL'
CCCCC     IPROT2='READONLY'
CCCCC     ICURS2='CLOSED'
CCCCC     ISUBN0='CAPT'
CCCCC     IERRF2='NO'
C
CCCCC     IREWI2='ON'
CCCCC     CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
CCCCC1                IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR)
CCCCC     IF(IERRF2.EQ.'YES')GOTO9000
C
C  NOW LOOP THROUGH FILE (ASSUME MAXIMUM OF 1,000 LINES).
C
CCCCC     DO3491I=1,1000
CCCCC       IATEMP=' '
CCCCC       READ(IOUNI2,3492,END=3299,ERR=3299)IATEMP
C3492       FORMAT(A240)
CCCCC       ILAST=1
CCCCC       DO3496J=240,1,-1
CCCCC         IF(IATEMP(J:J).NE.' ')THEN
CCCCC           ILAST=J
CCCCC           GOTO3498
CCCCC         ENDIF
C3496       CONTINUE
C3498       CONTINUE
CCCCC       WRITE(ICOUT,3494)(IATEMP(J:J),J=1,ILAST)
CCCCC       NCOUT=ILAST
C3494       FORMAT(240A1)
CCCCC       CALL DPWRST('WRIT','BUG ')
C3491     CONTINUE
C3499     CONTINUE
CCCCC     IENDF2='OFF'
CCCCC     IREWI2='ON'
CCCCC     CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
CCCCC1                IENDF2,IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR)
CCCCC     IF(IERRF2.EQ.'YES')GOTO9000
CCCCC     WRITE(ICOUT,3197)IBASLC
CCCCC     CALL DPWRST('XXX','WRIT')
CCCCC   ENDIF
      ENDIF
C
      GOTO9000
C
C               ******************************************************
C               **  STEP 38--                                       **
C               **  TREAT THE CAPTURE SUSPEND CASE.                 **
C               **  RESET OUTPUT UNIT TO IPR, BUT DO NOT CLOSE      **
C               **  THE CAPTURE FILE.                               **
C               ******************************************************
C
 3800 CONTINUE
      ISTEPN='38'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ICAPSW.EQ.'OFF')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3811)
 3811   FORMAT('****** WARNING: THE CAPTURE SWITCH IS CURRENTLY OFF.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3813)
 3813   FORMAT('       CAPTURE SUSPEND COMMAND IGNORED.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      ICAPSW='OFF'
      IOUNIT=ICAPNU
      IPR=IPRDEF
C
      GOTO9000
C
C               ******************************************************
C               **  STEP 39--                                       **
C               **  TREAT THE CAPTURE RESUME  CASE.                 **
C               **  RESET OUTPUT UNIT TO CAPTURE UNIT, BUT DO NOT   **
C               **  REOPEN THE CAPTURE FILE.                        **
C               ******************************************************
C
 3900 CONTINUE
      ISTEPN='39'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ICAPSW.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3911)
 3911   FORMAT('****** WARNING: THE CAPTURE SWITCH IS CURRENTLY ON.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3913)
 3913   FORMAT('       CAPTURE RESUME COMMAND IGNORED.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      ICAPSW='ON'
      IPR=ICAPNU
C
      GOTO9000
C
C               ****************************************************************
C               **  STEP 40--
C               **  TREAT THE END OF CAPTURE CASE.
C               **  CARRY OUT WHATEVER SYSTEM OPERATIONS ARE NEEDED
C               **  IN ORDER TO OPERATE ON THE FILE OR SUBFILE.
C               **  FOR MOST INSTALLATIONS, THIS REQUIRES
C               **      1) A PLACING OF AN END MARK OF THE FILE OR SUBFILE;
C               **      2) A FREEING (DEASSIGNING) OF THE FILE OR SUBFILE;
C               ****************************************************************
C
 4000 CONTINUE
      ISTEPN='40'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICAPSW='OFF'
CCCCC JUNE 2002.  SPECIAL CASE OF GRAPHICS, LATEK, OR HTML.  ADD
CCCCC ANY SPECIAL NEED TERMINATION CODE HERE.
C
CCCCC JANUARY 2003.  SET HTML FOOTER FILE CAN BE USED TO SPECIFY A
CCCCC A FILE TO INCORPORATE THE FOOTER FILE.
C
CCCCC IF(ICAPTY.EQ.'GRAP')THEN
CCCCC   IPR=IPRDEF
CCCCC   IF(IFEEDB.EQ.'ON')THEN
CCCCC     WRITE(ICOUT,999)
CCCCC     CALL DPWRST('XXX','BUG ')
CCCCC     WRITE(ICOUT,4111)
C4111     FORMAT('THE CAPTURE GRAPHICS SWITCH HAS JUST BEEN TURNED ',
CCCCC1           'OFF.')
CCCCC     CALL DPWRST('XXX','BUG ')
CCCCC     WRITE(ICOUT,4113)
C4113     FORMAT('ALL FUTURE TEXT OUTPUT WILL NOW REVERT TO ',
CCCCC1           'THE SCREEN.')
CCCCC     CALL DPWRST('XXX','BUG ')
C4119     CONTINUE
CCCCC     GOTO9000
CCCCC   ENDIF
      IF(ICAPTY.EQ.'HTML')THEN
        WRITE(ICOUT,4110)
 4110   FORMAT('
') CALL DPWRST('XXX','WRIT') IF(IHTMFO.EQ.'NULL')THEN WRITE(ICOUT,4112) 4112 FORMAT('') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4114) 4114 FORMAT('') CALL DPWRST('XXX','WRIT') ELSE IOUNI2=IST1NU IFILE2=IHTMFO ISTAT2='OLD' IFORM2='FORMATTED' IACCE2='SEQUENTIAL' IPROT2='READONLY' ICURS2='CLOSED' ISUBN0='CAPT' IERRF2='NO' C IREWI2='ON' CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1 IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C C NOW LOOP THROUGH FILE (ASSUME MAXIMUM OF 1,000 LINES). C DO4121I=1,1000 IATEMP=' ' READ(IOUNI2,4122,END=4129,ERR=4129)IATEMP 4122 FORMAT(A240) ILAST=1 DO4126J=240,1,-1 IF(IATEMP(J:J).NE.' ')THEN ILAST=J GOTO4128 ENDIF 4126 CONTINUE 4128 CONTINUE WRITE(ICOUT,4124)(IATEMP(J:J),J=1,ILAST) NCOUT=ILAST 4124 FORMAT(240A1) CALL DPWRST('XXX','WRIT') 4121 CONTINUE 4129 CONTINUE IENDF2='OFF' IREWI2='ON' CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1 IENDF2,IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 ENDIF ELSEIF(ICAPTY.EQ.'LATE')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4208)IBASLC 4208 FORMAT(A1,'end{verbatim}') CALL DPWRST('XXX','WRIT') IF(ILATFO.EQ.'NULL')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4210)IBASLC 4210 FORMAT(A1,'end{document}') CALL DPWRST('XXX','WRIT') ELSE IOUNI2=IST1NU IFILE2=ILATFO ISTAT2='OLD' IFORM2='FORMATTED' IACCE2='SEQUENTIAL' IPROT2='READONLY' ICURS2='CLOSED' ISUBN0='CAPT' IERRF2='NO' C IREWI2='ON' CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1 IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C C NOW LOOP THROUGH FILE (ASSUME MAXIMUM OF 1,000 LINES). C DO4221I=1,1000 IATEMP=' ' READ(IOUNI2,4222,END=4229,ERR=4229)IATEMP 4222 FORMAT(A240) ILAST=1 DO4226J=240,1,-1 IF(IATEMP(J:J).NE.' ')THEN ILAST=J GOTO4228 ENDIF 4226 CONTINUE 4228 CONTINUE WRITE(ICOUT,4224)(IATEMP(J:J),J=1,ILAST) NCOUT=ILAST 4224 FORMAT(240A1) CALL DPWRST('XXX','WRIT') 4221 CONTINUE 4229 CONTINUE IENDF2='OFF' IREWI2='ON' CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1 IENDF2,IREWI2,ISUBN0,IERRF2,IBUGS2,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 ENDIF ELSEIF(ICAPTY.EQ.'RTF ')THEN IRTFMD='OFF' WRITE(ICOUT,4301)IBASLC 4301 FORMAT(A1,'par}') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4303) 4303 FORMAT('}') CALL DPWRST('XXX','WRIT') ENDIF C ICAPTY='TEXT' IOUNIT=ICAPNU IPR=IPRDEF C IENDFI='ON' IREWIN='ON' CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IF(IERRFI.EQ.'YES')GOTO9000 C 4090 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO4019 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4011) 4011 FORMAT('THE CAPTURE SWITCH HAS JUST BEEN TURNED OFF.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4012)ICAPNA 4012 FORMAT('NAME OF (JUST-CLOSED) CAPTURE FILE = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4013) 4013 FORMAT('ALL FUTURE TEXT OUTPUT WILL NOW REVERT TO ', 1'THE SCREEN.') CALL DPWRST('XXX','BUG ') 4019 CONTINUE GOTO9000 C C **************************************************************** C ** STEP 50-- C ** TREAT THE CAPTURE FILE CLOSE CASE. C **************************************************************** C 5000 CONTINUE ISTEPN='50' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC ICAPSW='OFF' CCCCC JUNE 2002. SUPPORT FOR SPECIAL CAPTURE OPERATIONS. CCCCC IF(ICAPTY.EQ.'GRAP')THEN CCCCC IPR=IPRDEF IF(ICAPTY.EQ.'HTML')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5111) 5111 FORMAT('') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5113) 5113 FORMAT('') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5115) 5115 FORMAT('') CALL DPWRST('XXX','WRIT') ELSEIF(ICAPTY.EQ.'LATE')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5208)IBASLC 5208 FORMAT(A1,'end{verbatim}') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5210)IBASLC 5210 FORMAT(A1,'end{document}') CALL DPWRST('XXX','WRIT') ELSEIF(ICAPTY.EQ.'RTF ')THEN IRTFMD='OFF' WRITE(ICOUT,5301)IBASLC 5301 FORMAT(A1,'par}') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5303) 5303 FORMAT('}') CALL DPWRST('XXX','WRIT') ENDIF C ICAPTY='TEXT' IOUNIT=ICAPNU C IENDFI='OFF' C ***** DO WE NEED THE FOLLOWING REWIND ????? ***** IREWIN='ON' CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IF(IERRFI.EQ.'YES')GOTO9000 C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'CAPT')GOTO5019 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5011)ICAPNU 5011 FORMAT('THE CAPTURE FILE NUMBER ',I8,' HAS JUST BEEN CLOSED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5012)ICAPNA 5012 FORMAT('NAME OF (JUST-CLOSED) CAPTURE FILE = ',A80) CALL DPWRST('XXX','BUG ') 5019 CONTINUE GOTO9000 C C ********************************************************** C ** STEP 60-- ** C ** TREAT THE FLUSH CAPTURE CASE. ** C ** 1) CLEAR GRAPHICS SCREEN (DPERAS) ** C ** 2) CLOSE CAPTURE FILE (IF CURRENTLY OPEN) ** C ** 3) OPEN THE CAPTURE FILE ** C ** 4) LOOP THROUGH THE FILE AND CALL DPWRSG ** C ** 5) CLOSE THE CAPTURE FILE ** C ** 6) RE-OPEN THE CAPTURE FILE ** C ********************************************************** C 6000 CONTINUE ISTEPN='40' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'CAPT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C C STEP 2: CLEAR THE GRAPHICS SCREEN C (SKIP IF MULTIPLOTTING ON) C IF(IMPSW.NE.'ON')THEN CALL DPERAS(IHARG,IARGT,IARG,NUMARG, 1 IBACCO, 1 IGRASW,IDIASW, 1 PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1 PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1 NUMDEV, 1 IDMANU,IDMODE,IDMOD2,IDMOD3, 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1 IDNVOF,IDNHOF, 1 IDFONT, 1 ICAPSW, 1 IBUGS2,ISUBRO,IFOUND,IERROR) ENDIF C C STEP 2: CLOSE THE FILE C IOUNIT=ICAPNU IFILE=ICAPNA ISTAT=ICAPST IFORM=ICAPFO IACCES=ICAPAC IPROT=ICAPPR ICURST=ICAPCS ICURST=ICAPCS IF(ICAPCS.EQ.'CLOSED')GOTO6090 IENDFI='ON' IREWIN='ON' CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IF(IERRFI.EQ.'YES')GOTO9000 C 6090 CONTINUE C C STEP 3: RE-OPEN THE FILE C IREWIN='ON' CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IF(IERRFI.EQ.'YES')GOTO9000 ICAPCS=ICURST C C STEP 4: LOOP THROUGH THE FILE C ILINE=0 ICOUNT=1 DO6110I=1,10000 ICOUT=' ' READ(ICAPNU,'(A120)',END=6129,ERR=6119)ICOUT ILINE=ILINE+1 IF(ILINE.GT.ICAPLI(ICOUNT).AND.IMPSW.NE.'ON')THEN CALL DPERAS(IHARG,IARGT,IARG,NUMARG, 1 IBACCO, 1 IGRASW,IDIASW, 1 PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1 PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1 NUMDEV, 1 IDMANU,IDMODE,IDMOD2,IDMOD3, 1 IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1 IDNVOF,IDNHOF, 1 IDFONT, 1 ICAPSW, 1 IBUGS2,ISUBRO,IFOUND,IERROR) ILINE=1 ICOUNT=ICOUNT+1 IF(ICOUNT.GT.MAXCLI)ICOUNT=1 ENDIF IF(I.EQ.1)THEN IFLAG='INIT' ELSEIF(ILINE.EQ.1)THEN IFLAG='NEW' ELSE IFLAG='OLD' ENDIF CALL DPWRSG('XXXX','BUG ',IREPCH,IMPSW,IFLAG,ICAPNM,ICAPBX, 1 ILINE) 6110 CONTINUE 6119 CONTINUE 6129 CONTINUE C C STEP 5: CLOSE THE FILE C IENDFI='ON' IREWIN='ON' CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) ICAPCS=ICURST IF(IERRFI.EQ.'YES')GOTO9000 C C STEP 6: RE-OPEN THE FILE C IFILE=ICAPNA IOUNIT=ICAPNU IREWIN='ON' CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IF(IERRFI.EQ.'YES')GOTO9000 ICAPCS=ICURST C GOTO9000 C C **************** C ** STEP 90-- ** C ** EXIT. ** C **************** C 9000 CONTINUE C IFILQU=IFILQ2 C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'CAPT')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPCAPT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICAPSW,ICAPNU,ICAPCS,IPR,IPRDEF 9012 FORMAT('ICAPSW,ICAPNU,ICAPCS,IPR,IPRDEF = ',A4,I8,2X,A12,2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGS2,IFOUND,IERROR 9013 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IOUNIT 9014 FORMAT('IOUNIT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)ICOM,ICOM2,IWIDTH 9015 FORMAT('ICOM,ICOM2,IWIDTH = ',A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)(IANSLC(I),I=1,IWIDTH) 9017 FORMAT('IANSLC(.) = ',120A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)NUMARG 9018 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMARG.LE.0)GOTO9022 DO9019I=1,NUMARG WRITE(ICOUT,9020)I,IHARG(I),IHARG2(I) 9020 FORMAT('I,IHARG(I),IHARG2(I) = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9019 CONTINUE 9022 CONTINUE WRITE(ICOUT,9025)IOFILE 9025 FORMAT('IOFILE = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9031)JP3,JP4,JP5,KMIN,KDEL,KMAX 9031 FORMAT('JP2,JP3,JP4,KMIN,KDEL,KMAX = ',6I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9032)NUMNAM,MAXNAM 9032 FORMAT('NUMNAM,MAXNAM = ',2I8) CALL DPWRST('XXX','BUG ') DO9035I=1,NUMNAM WRITE(ICOUT,9036)I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) 9036 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) = ', 1I8,2X,A4,2X,A4,2X,A4,I8,E15.7) CALL DPWRST('XXX','BUG ') 9035 CONTINUE WRITE(ICOUT,9042)NUMCHA 9042 FORMAT('NUMCHA = ',I8) CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,9043)(IA(I),I=1,MIN(100,IMAX)) C9043 FORMAT('(IA(I),I=1,IMAX) = ',100A1) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9051)IOUNIT 9051 FORMAT('IOUNIT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9052)IFILE 9052 FORMAT('IFILE = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9053)ISTAT 9053 FORMAT('ISTAT = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9054)IFORM 9054 FORMAT('IFORM = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9055)IACCES 9055 FORMAT('IACCES = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9056)IPROT 9056 FORMAT('IPROT = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9057)ICURST 9057 FORMAT('ICURST = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9058)IENDFI 9058 FORMAT('IENDFI = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9059)IREWIN 9059 FORMAT('IREWIN = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9061)ISUBN0 9061 FORMAT('ISUBN0 = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9062)IERRFI 9062 FORMAT('IERRFI = ',A12) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPCASE(ICOM,IHARG,NUMARG, 1IDEFCA, 1ITEXCA, 1IBUGD2,ISUBRO,IFOUND,IERROR) C C PURPOSE--DEFINE THE CASE (UPPER OR LOWER) TYPE FOR C TITLE, LABEL, AND LEGEND SCRIPT C ON A PLOT. C THE CASE (UPPER OR LOWER) FOR THE SCRIPT WILL BE PLACED C IN THE CHARACTER VARIABLE ITEXCA. C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEFCA C --IBUGD2 C OUTPUT ARGUMENTS--ITEXCA C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--APRIL 1981. C UPDATED --MAY 1982. C UPDATED --OCTOBER 1993. ACCEPT "ASIS" AS ARGUMENT C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICOM CHARACTER*4 IHARG CHARACTER*4 IDEFCA CHARACTER*4 ITEXCA CHARACTER*4 IBUGD2 CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(IBUGD2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPCASE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICOM,NUMARG,IDEFCA 53 FORMAT('ICOM,NUMARG,IDEFCA = ',A4,2X,I8,2X,A4) CALL DPWRST('XXX','BUG ') DO55I=1,NUMARG WRITE(ICOUT,56)I,IHARG(I) 56 FORMAT('I,IHARG(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ************************************************ C ** TREAT THE CASE (UPPER VERSUS LOWER) CASE ** C ************************************************ C 1110 CONTINUE IF(ICOM.EQ.'CASE')GOTO1120 IF(ICOM.EQ.'UPPE')GOTO1130 IF(ICOM.EQ.'LOWE')GOTO1140 CCCCC OCTOBER 1993. ADD FOLLOWING LINE IF(ICOM.EQ.'ASIS')GOTO1150 GOTO9000 C 1120 CONTINUE IF(NUMARG.LE.0)GOTO1161 IF(IHARG(NUMARG).EQ.'ON')GOTO1161 IF(IHARG(NUMARG).EQ.'OFF')GOTO1162 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1161 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165 IF(IHARG(NUMARG).EQ.'UPPE')GOTO1161 IF(IHARG(NUMARG).EQ.'LOWE')GOTO1162 CCCCC OCTOBER 1993. ADD FOLLOWING LINE IF(IHARG(NUMARG).EQ.'ASIS')GOTO1163 IF(IHARG(NUMARG).EQ.'?')GOTO8100 GOTO1170 C 1130 CONTINUE IF(NUMARG.LE.0)GOTO9000 IF(IHARG(1).NE.'CASE')GOTO9000 IF(NUMARG.LE.1)GOTO1161 IF(IHARG(NUMARG).EQ.'ON')GOTO1161 IF(IHARG(NUMARG).EQ.'OFF')GOTO1162 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1161 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165 GOTO9000 C 1140 CONTINUE IF(NUMARG.LE.0)GOTO9000 IF(IHARG(1).NE.'CASE')GOTO9000 IF(NUMARG.LE.1)GOTO1162 IF(IHARG(NUMARG).EQ.'ON')GOTO1162 IF(IHARG(NUMARG).EQ.'OFF')GOTO1161 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1162 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165 GOTO9000 CCCCC OCTOBER 1993. ADD FOLLOWING SECTION C 1150 CONTINUE IF(NUMARG.LE.0)GOTO9000 IF(IHARG(1).NE.'CASE')GOTO9000 IF(NUMARG.LE.1)GOTO1163 IF(IHARG(NUMARG).EQ.'ON')GOTO1162 IF(IHARG(NUMARG).EQ.'OFF')GOTO1161 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1162 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165 GOTO9000 C 1161 CONTINUE ITEXCA='UPPE' GOTO1180 C 1162 CONTINUE ITEXCA='LOWE' GOTO1180 CCCCC OCTOBER 1993. ADD FOLLOWING SECTION C 1163 CONTINUE ITEXCA='ASIS' GOTO1180 C 1165 CONTINUE ITEXCA=IDEFCA GOTO1180 C 1170 CONTINUE IERROR='YES' WRITE(ICOUT,1171) 1171 FORMAT('***** ERROR IN DPCASE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1172) 1172 FORMAT(' ILLEGAL ENTRY FOR CASE ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1173) 1173 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1174) 1174 FORMAT(' SUPPOSE THE THE ANALYST WISHES TO HAVE CASE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1175) 1175 FORMAT(' FOR ALL PLOT TITLES, LABELS, AND LEGENDS,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1176) 1176 FORMAT(' THEN ALLOWABLE FORMS ARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1177) 1177 FORMAT(' CASE UPPER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1178) 1178 FORMAT(' UPPER CASE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1179) 1179 FORMAT(' CASE') CALL DPWRST('XXX','BUG ') GOTO9000 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE CASE (FOR PLOT SCRIPT AND TEXT) ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)ITEXCA 1182 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO9000 C C ******************************************** C ** STEP 81-- ** C ** TREAT THE ? CASE-- ** C ** DUMP OUT CURRENT AND DEFAULT VALUES. ** C ******************************************** C 8100 CONTINUE IFOUND='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8111)ITEXCA 8111 FORMAT('THE CURRENT CASE IS ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8112)IDEFCA 8112 FORMAT('THE DEFAULT CASE IS ',A4) CALL DPWRST('XXX','BUG ') GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGD2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPCASE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ITEXCA,IDEFCA 9013 FORMAT('ITEXCA,IDEFCA = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1ICONT,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE ONE OF THE FOLLOWING 4 CONTROL CHARTS-- C 1) MEAN C 2) RANGE C 3) STANDARD DEVIATION C 4) CUSUM C 5) P C 6) PN C 7) C C 8) U C 9) EWMA (EXPONENTIALLY WEIGHTED MOVING AVERAGE) C 10) MOVING AVERAGE C 11) MOVING RANGE C 12) MOVING STANDARD DEVIATION C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--JUNE 1978. C UPDATED --JULY 1978. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C UPDATED --JANUARY 1988. (P, PN, C, AND U CHARTS) C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C UPDATED --JULY 1990. ADD R CHART CHECK C UPDATED --JULY 1990. FIX P, NP, C, & U CHARTS C UPDATED --SEPTEMBER 1990. LSL, USL, TARGET C UPDATED --AUGUST 1991. TURN OFF MESS.--LSL/USL/TARGET C UPDATED --MARCH 1997. EWMA, ACTIVATE CUSUM C UPDATED --MARCH 1997. MOVING AVERAGE C UPDATED --MARCH 1997. MOVING RANGE C UPDATED --MARCH 1997. MOVING STANDARD DEVIATION C UPDATED --SEPTEMBER 1998. ACTIVATED CUSUM MEAN CHART C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CCCCC ADD FOLLING LINE 3/97 CHARACTER*4 ICASP2 CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 ICONT CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IERRO2 CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHHOR CHARACTER*4 IHHOR2 C CCCCC THE FOLLOWING 2 LINES WERE ADDED JULY 1990 CHARACTER*4 IHEXT CHARACTER*4 IHEXT2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(MAXOBV) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1990 DIMENSION Y2(MAXOBV) DIMENSION X1(MAXOBV) C DIMENSION XIDTEM(MAXOBV) DIMENSION TEMP(MAXOBV) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1990 DIMENSION TEMP2(MAXOBV) CCCCC FOLLOWING 5 LINES ADDED JUNE, 1990 (ALAN) INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),X1(1)) EQUIVALENCE (GARBAG(IGARB2),Y1(1)) CCCCC THE FOLLOWING 2 LINES WERE REPLACED BY THE SUCCEEDING 4 LINES JULY 190 CCCCC EQUIVALENCE (GARBAG(IGARB3),XIDTEM(1)) CCCCC EQUIVALENCE (GARBAG(IGARB4),TEMP(1)) EQUIVALENCE (GARBAG(IGARB3),Y2(1)) EQUIVALENCE (GARBAG(IGARB4),XIDTEM(1)) EQUIVALENCE (GARBAG(IGARB5),TEMP(1)) EQUIVALENCE (GARBAG(IGARB6),TEMP2(1)) C C-----COMMON---------------------------------------------------------- C CCCCC ADD FOLLOWING LINE APRIL 1997 INCLUDE 'DPCOST.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IERROR='NO' C ISUBN1='DPCC' ISUBN2=' ' C CCCCC ADD FOLLOWING LINE 3/97 (FOR CUSUM CHARTS) ICASP2='NONE' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=2 MINN2=2 C ICOLH=0 C C ************************************ C ** TREAT THE CONTROL CHART CASE ** C ************************************ C IF(IBUGG2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPCC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICASPL,IAND1,IAND2 52 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICONT,IBUGG2,IBUGG3,IBUGQ 53 FORMAT('ICONT,IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ************************************* C ** STEP 1.1-- ** C ** SEARCH FOR MEAN CONTROL CHART ** C ************************************* C ICASPL='MECC' C IF(NUMARG.GE.3.AND. 1ICOM.EQ.'X'.AND.IHARG(1).EQ.'BAR'.AND.IHARG(2).EQ.'CONT'.AND. 1IHARG(3).EQ.'CHAR')GOTO113 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'XBAR'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 1GOTO112 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'MEAN'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 1GOTO112 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'AVER'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 1GOTO112 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'CONT'.AND.IHARG(1).EQ.'CHAR') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'MEAN'.AND.IHARG(1).EQ.'CHAR') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'XBAR'.AND.IHARG(1).EQ.'CHAR') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'AVER'.AND.IHARG(1).EQ.'CHAR') 1GOTO111 CCCCC ADD FOLLOWING SECTION FEBRUARY 1994. IF(NUMARG.GE.2.AND. 1ICOM.EQ.'X'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 1GOTO112 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'X'.AND.IHARG(1).EQ.'CHAR')GOTO111 C C *************************************************** C ** STEP 1.2-- ** C ** SEARCH FOR STANDARD DEVIATION CONTROL CHART ** C *************************************************** C ICASPL='SDCC' C IF(NUMARG.GE.3.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'DEVI'.AND.IHARG(2).EQ.'CONT'.AND. 1IHARG(3).EQ.'CHAR')GOTO113 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'SD'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 1GOTO112 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'S'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 1GOTO112 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SD'.AND.IHARG(1).EQ.'CHAR') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'S'.AND.IHARG(1).EQ.'CHAR') 1GOTO111 C C ************************************** C ** STEP 1.3-- ** C ** SEARCH FOR RANGE CONTROL CHART ** C ************************************** C ICASPL='RACC' C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'RANG'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 1GOTO112 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'R'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 1GOTO112 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'RANG'.AND.IHARG(1).EQ.'CHAR') 1GOTO111 CCCCC THE FOLLOWING 3 LINES WERE ADDED JULY 1990 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'R'.AND.IHARG(1).EQ.'CHAR') 1GOTO111 C C ************************************** C ** STEP 1.4-- ** C ** SEARCH FOR CUSUM CONTROL CHART ** C ************************************** C ICASPL='CUCC' ICASP2='MEAN' C IF(NUMARG.GE.3.AND. 1ICOM.EQ.'CUMU'.AND.IHARG(1).EQ.'SUM'.AND.IHARG(2).EQ.'CONT'.AND. 1IHARG(3).EQ.'CHAR')GOTO113 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'CUSU'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 1GOTO112 CCCCC FOLLOWING SECTIONS ADDED 3/97 IF(NUMARG.GE.4.AND. 1ICOM.EQ.'MEAN'.AND.IHARG(1).EQ.'CUMU'.AND. 1IHARG(2).EQ.'SUM'.AND.IHARG(3).EQ.'CONT'.AND. 1IHARG(4).EQ.'CHAR')GOTO114 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'MEAN'.AND.IHARG(1).EQ.'CUSU'.AND. 1IHARG(2).EQ.'CONT'.AND.IHARG(3).EQ.'CHAR') 1GOTO113 C ICASP2='MEAN' IF(NUMARG.GE.4.AND. 1ICOM.EQ.'RANG'.AND.IHARG(1).EQ.'CUMU'.AND. 1IHARG(2).EQ.'SUM'.AND.IHARG(3).EQ.'CONT'.AND. 1IHARG(4).EQ.'CHAR')GOTO114 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'RANGE'.AND.IHARG(1).EQ.'CUSU'.AND. 1IHARG(2).EQ.'CONT'.AND.IHARG(3).EQ.'CHAR') 1GOTO113 C ICASP2='MEAN' IF(NUMARG.GE.4.AND. 1ICOM.EQ.'SD '.AND.IHARG(1).EQ.'CUMU'.AND. 1IHARG(2).EQ.'SUM'.AND.IHARG(3).EQ.'CONT'.AND. 1IHARG(4).EQ.'CHAR')GOTO114 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'SD '.AND.IHARG(1).EQ.'CUSU'.AND. 1IHARG(2).EQ.'CONT'.AND.IHARG(3).EQ.'CHAR') 1GOTO113 C IF(NUMARG.GE.5.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'DEVI'.AND. 1IHARG(2).EQ.'CUMU'.AND.IHARG(2).EQ.'SUM'.AND. 1IHARG(3).EQ.'CONT'.AND.IHARG(4).EQ.'CHAR')GOTO115 IF(NUMARG.GE.4.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'DEVI'.AND. 1IHARG(2).EQ.'CUSU'.AND.IHARG(3).EQ.'CONT'.AND. 1IHARG(4).EQ.'CHAR')GOTO114 ICASP2='NONE' C C ************************************** C ** STEP 1.5-- ** C ** SEARCH FOR P CONTROL CHART ** C ************************************** C ICASPL='PCC' C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'P'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 1GOTO112 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'P'.AND.IHARG(1).EQ.'CHAR') 1GOTO111 C C ************************************** C ** STEP 1.6-- ** C ** SEARCH FOR PN CONTROL CHART ** C ************************************** C ICASPL='PNCC' C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'PN'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 1GOTO112 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'PN'.AND.IHARG(1).EQ.'CHAR') 1GOTO111 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'NP'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 1GOTO112 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'NP'.AND.IHARG(1).EQ.'CHAR') 1GOTO111 C C ************************************** C ** STEP 1.7-- ** C ** SEARCH FOR C CONTROL CHART ** C ************************************** C ICASPL='CCC' C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'C'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 1GOTO112 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'C'.AND.IHARG(1).EQ.'CHAR') 1GOTO111 C C ************************************** C ** STEP 1.8-- ** C ** SEARCH FOR U CONTROL CHART ** C ************************************** C ICASPL='UCC' C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'U'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 1GOTO112 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'U'.AND.IHARG(1).EQ.'CHAR') 1GOTO111 C C ************************************** C ** STEP 1.9-- ** C ** SEARCH FOR EWMA CONTROL CHART ** C ************************************** C ICASPL='EWCC' C IF(NUMARG.GE.5.AND. 1ICOM.EQ.'EXPO'.AND.IHARG(1).EQ.'WEIG'.AND.IHARG(2).EQ.'MOVI'.AND. 1IHARG(3).EQ.'AVER'.AND.IHARG(4).EQ.'CONT'.AND. 1IHARG(5).EQ.'CHAR')GOTO115 IF(NUMARG.GE.4.AND. 1ICOM.EQ.'EXPO'.AND.IHARG(1).EQ.'WEIG'.AND.IHARG(2).EQ.'MOVI'.AND. 1IHARG(3).EQ.'CONT'.AND.IHARG(4).EQ.'CHAR')GOTO114 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'EXPO'.AND.IHARG(1).EQ.'WEIG'.AND.IHARG(2).EQ.'CONT'.AND. 1IHARG(3).EQ.'CHAR')GOTO113 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'EWMA'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 1GOTO112 C C ************************************************ C ** STEP 1.10-- ** C ** SEARCH FOR MOVING AVERAGE CONTROL CHART ** C ************************************************ C ICASPL='MACC' C IF(NUMARG.GE.3.AND. 1ICOM.EQ.'MOVI'.AND.IHARG(1).EQ.'AVER'.AND.IHARG(2).EQ.'CONT'.AND. 1IHARG(3).EQ.'CHAR')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'MOVI'.AND.IHARG(1).EQ.'MEAN'.AND.IHARG(2).EQ.'CONT'.AND. 1IHARG(3).EQ.'CHAR')GOTO113 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'MA'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 1GOTO112 C C ************************************************ C ** STEP 1.11-- ** C ** SEARCH FOR MOVING RANGE CONTROL CHART ** C ************************************************ C ICASPL='MRCC' C IF(NUMARG.GE.3.AND. 1ICOM.EQ.'MOVI'.AND.IHARG(1).EQ.'RANG'.AND.IHARG(2).EQ.'CONT'.AND. 1IHARG(3).EQ.'CHAR')GOTO113 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'MR'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 1GOTO112 C C ************************************************ C ** STEP 1.12-- ** C ** SEARCH FOR MOVING STANDARD DEVIATION ** C ** CONTROL CHART ** C ************************************************ C ICASPL='MSCC' C IF(NUMARG.GE.3.AND. 1ICOM.EQ.'MOVI'.AND.IHARG(1).EQ.'SD '.AND.IHARG(2).EQ.'CONT'.AND. 1IHARG(3).EQ.'CHAR')GOTO113 IF(NUMARG.GE.4.AND. 1ICOM.EQ.'MOVI'.AND.IHARG(1).EQ.'STAN'.AND.IHARG(2).EQ.'DEVI'.AND. 1IHARG(3).EQ.'CONT'.AND.IHARG(4).EQ.'CHAR')GOTO114 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'MSD'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 1GOTO112 C ICASPL=' ' C IFOUND='NO' GOTO9000 C 111 CONTINUE ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 112 CONTINUE ILASTC=2 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 113 CONTINUE ILASTC=3 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 114 CONTINUE ILASTC=4 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 115 CONTINUE ILASTC=5 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 180 CONTINUE IFOUND='YES' GOTO190 C 190 CONTINUE C C *********************************************************** C ** STEP 1-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C *********************************************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ******************************************** C ** STEP 2-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='2' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(1) IHLEF2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,211)IHLEFT,ICOLL,NLEFT 211 FORMAT('IHLEFT,ICOLL,NLEFT = ',A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') C C *************************************************************** C ** STEP 3-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS 2 OR LARGER. ** C *************************************************************** C ISTEPN='3' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPCC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312) 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MECC')WRITE(ICOUT,321) 321 FORMAT(' (FOR WHICH A MEAN CONTROL CHART ') IF(ICASPL.EQ.'MECC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'SDCC')WRITE(ICOUT,322) 322 FORMAT(' (FOR WHICH A STANDARD DEVIATION CONTROL CHART ') IF(ICASPL.EQ.'SDCC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'RACC')WRITE(ICOUT,323) 323 FORMAT(' (FOR WHICH A RANGE CONTROL CHART ') IF(ICASPL.EQ.'RACC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'CUCC')WRITE(ICOUT,324) 324 FORMAT(' (FOR WHICH A CUSUM CONTROL CHART ') IF(ICASPL.EQ.'CUCC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'PCC')WRITE(ICOUT,325) 325 FORMAT(' (FOR WHICH A P CONTROL CHART ') IF(ICASPL.EQ.'PCC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'PNCC')WRITE(ICOUT,326) 326 FORMAT(' (FOR WHICH A NP CONTROL CHART ') IF(ICASPL.EQ.'PNCC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'CCC')WRITE(ICOUT,327) 327 FORMAT(' (FOR WHICH A C CONTROL CHART ') IF(ICASPL.EQ.'CCC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'UCC')WRITE(ICOUT,328) 328 FORMAT(' (FOR WHICH A U CONTROL CHART ') IF(ICASPL.EQ.'UCC')CALL DPWRST('XXX','BUG ') CCCCC ADD FOLLOWING 12 LINES 3/97 IF(ICASPL.EQ.'EWCC')WRITE(ICOUT,329) 329 FORMAT(' (FOR WHICH A EWMA CONTROL CHART ') IF(ICASPL.EQ.'EWCC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MACC')WRITE(ICOUT,330) 330 FORMAT(' (FOR WHICH A MOVING AVERAGE CONTROL CHART ') IF(ICASPL.EQ.'MACC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MRCC')WRITE(ICOUT,331) 331 FORMAT(' (FOR WHICH A MOVING RANGE CONTROL CHART ') IF(ICASPL.EQ.'MRCC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MSCC')WRITE(ICOUT,332) 332 FORMAT(' (FOR WHICH A MOVING STANDARD DEVIATION ', 1'CONTROL CHART ') IF(ICASPL.EQ.'MSCC')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,334) 334 FORMAT(' WAS TO HAVE BEEN FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,335)MINN2 335 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,336) 336 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,337) 337 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,338)(IANS(I),I=1,IWIDTH) 338 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 390 CONTINUE C C ***************************************** C ** STEP 4-- ** C ** CHECK TO SEE THE TYPE SUBCASE ** C ** (BASED ON THE QUALIFIER)-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='4' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO480 DO400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO420 400 CONTINUE GOTO490 410 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO490 420 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO490 C 480 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,481) 481 FORMAT('***** INTERNAL ERROR IN DPCC') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,482) 482 FORMAT(' AT BRANCH POINT 481--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,483) 483 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,484) 484 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,485)NUMARG 485 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,486) 486 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,487)(IANS(I),I=1,IWIDTH) 487 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 490 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ,ICASEQ 491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C ************************************************************ C ** STEP 5-- ** C ** IF A SECOND ARGUMENT EXISTS, THEN THIS ** C ** INDICATES THAT THE VALUES IN THE ** C ** FIRST VARIABLE ARE TO BE GROUPED ** C ** BASED ON VALUES OF THE SECOND VARIABLE; ** C ** THAT IS, THE SECOND VARAIBLE DEFINES THE ** C ** GROUP NUMBERS WITHIN WHICH THE MEANS, ** C ** STANDARD DEVIATIONS, RANGES, AND ** C ** CUMULATIVE SUMS ARE TO BE COMPUTED. ** C ** THE VALUES IN THE SECOND VARIABLE ** C ** ARE THE X VALUES FOR EACH MEAN, STANDARD DEVIATION, ** C ** ETC. IN THE RESULTING CONTROL CHART. ** C ** THE VALUES IN THE SECOND VARIABLE ** C ** NEED NOT HAVE BEEN PREVIOUSLY ** C ** SORTED OR HAVE COMMON VALUES ADJACENT. ** C ** IF WE HAVE THE 2-VARIABLE CASE, ** C ** CHECK THE VALIDITY OF THE SECOND (X) VARIABLE. ** C ************************************************************ C ISTEPN='5' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IF(NUMV2.EQ.1)GOTO599 IF(NUMV2.EQ.2)GOTO530 IF(NUMV2.EQ.3)GOTO540 GOTO510 C 510 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,511) 511 FORMAT('***** ERROR IN DPCC--') CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MECC')WRITE(ICOUT,512) 512 FORMAT(' FOR A MEAN CONTROL CHART, ') IF(ICASPL.EQ.'MECC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'SDCC')WRITE(ICOUT,513) 513 FORMAT(' FOR A STANDARD DEVIATION CONTROL CHART, ') IF(ICASPL.EQ.'SDCC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'RACC')WRITE(ICOUT,514) 514 FORMAT(' FOR A RANGE CONTROL CHART, ') IF(ICASPL.EQ.'RACC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'CUCC')WRITE(ICOUT,515) 515 FORMAT(' FOR A CUSUM CONTROL CHART, ') IF(ICASPL.EQ.'CUCC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'PCC')WRITE(ICOUT,516) 516 FORMAT(' (FOR WHICH A P CONTROL CHART ') IF(ICASPL.EQ.'PCC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'PNCC')WRITE(ICOUT,517) 517 FORMAT(' (FOR WHICH A NP CONTROL CHART ') IF(ICASPL.EQ.'PNCC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'CCC')WRITE(ICOUT,518) 518 FORMAT(' (FOR WHICH A C CONTROL CHART ') IF(ICASPL.EQ.'CCC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'UCC')WRITE(ICOUT,519) 519 FORMAT(' (FOR WHICH A U CONTROL CHART ') IF(ICASPL.EQ.'UCC')CALL DPWRST('XXX','BUG ') CCCCC FOLLOWING 12 LINES ADDED 3/97 IF(ICASPL.EQ.'EWCC')WRITE(ICOUT,520) 520 FORMAT(' (FOR WHICH A EWMA CONTROL CHART ') IF(ICASPL.EQ.'EWCC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MACC')WRITE(ICOUT,521) 521 FORMAT(' (FOR WHICH A MOVING AVERAGE CONTROL CHART ') IF(ICASPL.EQ.'MACC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MRCC')WRITE(ICOUT,522) 522 FORMAT(' (FOR WHICH A MOVING RANGE CONTROL CHART ') IF(ICASPL.EQ.'MRCC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MSCC')WRITE(ICOUT,535) 535 FORMAT(' (FOR WHICH A MOVING STANDARD DEVIATION ', 1'CONTROL CHART ') IF(ICASPL.EQ.'MSCC')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,523) 523 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,524) 524 FORMAT(' MUST BE EITHER 1 OR 2 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,525) 525 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,526) 526 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,527)NUMV2 527 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,528) 528 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,529)(IANS(I),I=1,IWIDTH) 529 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 530 CONTINUE IHHOR=IHARG(2) IHHOR2=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHHOR,IHHOR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLH=IVALUE(ILOCV) NHOR=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,531)IHHOR,ICOLH,NHOR 531 FORMAT('IHHOR,ICOLH,NHOR = ',A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(NHOR.NE.NLEFT)GOTO570 GOTO599 C 540 CONTINUE C IHEXT AS IN "EXTRA" IHEXT=IHARG(2) IHEXT2=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHEXT,IHEXT2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLE=IVALUE(ILOCV) NEXT=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,541)IHEXT,ICOLE,NEXT 541 FORMAT('IHEXT,ICOLE,NEXT = ',A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(NEXT.NE.NLEFT)GOTO570 C IHHOR=IHARG(3) IHHOR2=IHARG2(3) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHHOR,IHHOR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLH=IVALUE(ILOCV) NHOR=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,542)IHHOR,ICOLH,NHOR 542 FORMAT('IHHOR,ICOLH,NHOR = ',A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(NHOR.NE.NLEFT)GOTO570 GOTO599 C 570 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,571) 571 FORMAT('***** ERROR IN DPCC--') CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MECC')WRITE(ICOUT,572) 572 FORMAT(' FOR A MEAN CONTROL CHART, ') IF(ICASPL.EQ.'MECC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'SDCC')WRITE(ICOUT,573) 573 FORMAT(' FOR A STANDARD DEVIATION CONTROL CHART,') IF(ICASPL.EQ.'SDCC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'RACC')WRITE(ICOUT,574) 574 FORMAT(' FOR A RANGE CONTROL CHART, ') IF(ICASPL.EQ.'RACC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'CUCC')WRITE(ICOUT,575) 575 FORMAT(' FOR A CUSUM CONTROL CHART,') IF(ICASPL.EQ.'CUCC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'PCC')WRITE(ICOUT,576) 576 FORMAT(' (FOR WHICH A P CONTROL CHART ') IF(ICASPL.EQ.'PCC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'PNCC')WRITE(ICOUT,577) 577 FORMAT(' (FOR WHICH A NP CONTROL CHART ') IF(ICASPL.EQ.'PNCC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'CCC')WRITE(ICOUT,578) 578 FORMAT(' (FOR WHICH A C CONTROL CHART ') IF(ICASPL.EQ.'CCC')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'UCC')WRITE(ICOUT,579) 579 FORMAT(' (FOR WHICH A U CONTROL CHART ') IF(ICASPL.EQ.'UCC')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,584) 584 FORMAT(' WHEN HAVE 2 (OR 3) VARAIBLES SPECIFIED, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,585) 585 FORMAT(' THE NUMBER OF ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,586) 586 FORMAT(' IN THE 2 (OR 3) VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,587) 587 FORMAT(' MUST BE THE SAME; ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,588) 588 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,589) 589 FORMAT(' THE FIRST VARIABLE (RESPONSE VALUES)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,590)IHLEFT,NLEFT 590 FORMAT(' ',A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,591) 591 FORMAT(' THE 2ND VARIABLE--') CALL DPWRST('XXX','BUG ') IF(NUMV2.EQ.3)WRITE(ICOUT,592)IHEXT,NEXT IF(NUMV2.EQ.3)CALL DPWRST('XXX','BUG ') IF(NUMV2.EQ.2)WRITE(ICOUT,592)IHHOR,NHOR 592 FORMAT(' ',A4,' HAS ',I8,' ELEMENTS') IF(NUMV2.EQ.2)CALL DPWRST('XXX','BUG ') IF(NUMV2.EQ.3)WRITE(ICOUT,593) 593 FORMAT(' THE 3ND VARIABLE (HORIZ. AXIS VALUES)--') IF(NUMV2.EQ.3)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,594)IHHOR,NHOR 594 FORMAT(' ',A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,595) 595 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,596)(IANS(I),I=1,IWIDTH) 596 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 599 CONTINUE C C ************************************************* C ** STEP 6-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** (BASED ON THE QUALIFIER) ** C ** THEN FORM THE RESPONSE VARIABLE ** C ** AND THE SECOND VARIABLE (IF EXISTENT) ** C ************************************************* C ISTEPN='6' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO610 IF(ICASEQ.EQ.'SUBS')GOTO620 IF(ICASEQ.EQ.'FOR')GOTO630 C 610 CONTINUE DO615I=1,NLEFT ISUB(I)=1 615 CONTINUE NQ=NLEFT GOTO650 C 620 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO650 C 630 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO650 C 650 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO660I=1,IMAX IF(ISUB(I).EQ.0)GOTO660 J=J+1 C IJ=MAXN*(ICOLL-1)+I IF(ICOLL.LE.MAXCOL)Y1(J)=V(IJ) IF(ICOLL.EQ.MAXCP1)Y1(J)=PRED(I) IF(ICOLL.EQ.MAXCP2)Y1(J)=RES(I) IF(ICOLL.EQ.MAXCP3)Y1(J)=YPLOT(I) IF(ICOLL.EQ.MAXCP4)Y1(J)=XPLOT(I) IF(ICOLL.EQ.MAXCP5)Y1(J)=X2PLOT(I) IF(ICOLL.EQ.MAXCP6)Y1(J)=TAGPLO(I) IF(NUMV2.LE.1)GOTO660 C IF(NUMV2.EQ.2)GOTO652 GOTO653 C 652 CONTINUE IJ=MAXN*(ICOLH-1)+I IF(ICOLH.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLH.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLH.EQ.MAXCP2)X1(J)=RES(I) IF(ICOLH.EQ.MAXCP3)X1(J)=YPLOT(I) IF(ICOLH.EQ.MAXCP4)X1(J)=XPLOT(I) IF(ICOLH.EQ.MAXCP5)X1(J)=X2PLOT(I) IF(ICOLH.EQ.MAXCP6)X1(J)=TAGPLO(I) GOTO660 C 653 CONTINUE IJ=MAXN*(ICOLE-1)+I IF(ICOLE.LE.MAXCOL)Y2(J)=V(IJ) IF(ICOLE.EQ.MAXCP1)Y2(J)=PRED(I) IF(ICOLE.EQ.MAXCP2)Y2(J)=RES(I) IF(ICOLE.EQ.MAXCP3)Y2(J)=YPLOT(I) IF(ICOLE.EQ.MAXCP4)Y2(J)=XPLOT(I) IF(ICOLE.EQ.MAXCP5)Y2(J)=X2PLOT(I) IF(ICOLE.EQ.MAXCP6)Y2(J)=TAGPLO(I) C IJ=MAXN*(ICOLH-1)+I IF(ICOLH.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLH.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLH.EQ.MAXCP2)X1(J)=RES(I) IF(ICOLH.EQ.MAXCP3)X1(J)=YPLOT(I) IF(ICOLH.EQ.MAXCP4)X1(J)=XPLOT(I) IF(ICOLH.EQ.MAXCP5)X1(J)=X2PLOT(I) IF(ICOLH.EQ.MAXCP6)X1(J)=TAGPLO(I) GOTO660 C 660 CONTINUE NLOCAL=J C C **************************************************************** C ** STEP 7-- ** C ** FOR THE 1-VARIABLE CASE ONLY, * C ** DETERMINE IF THE ANALYST ** C ** HAS SPECIFIED THE GROUP SIZE, ** C ** FOR THE CONTROL CHART ANALYSIS. ** C ** THE GROUP SIZE SETTING IS DEFINED BY SEARCHING THE ** C ** INTERNAL TABLE FOR THE PARAMETER NAME NI ; ** C ** IF FOUND, USE THE SPECIFIED VALUE. ** C ** IF NOT FOUND, GENERATE AN ERROR MESSAGE. ** C **************************************************************** C ISTEPN='7' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMV2.GE.2)GOTO790 C IH='NI ' IH2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IF(IERRO2.EQ.'YES')THEN ISIZE=1 ELSE ISIZE=VALUE(ILOCP)+0.5 ENDIF 790 CONTINUE C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEBMER 1990 C **************************************************************** C ** STEP 8-- ** C ** DETERMINE IF THE ANALYST ** C ** HAS SPECIFIED C ** LSL (LOWER SPEC LIMIT) C ** USL (UPPER SPEC LIMIT) C ** USLCOST (UPPER SPEC LIMIT COST) C ** TARGET C ** P (FOR EWMA CHARTS) C ** K (FOR UNGROUPED DATA, FILTER WIDTH) C ** WIDTH AS ALTERNATIVE TO K C ** WEIGHT AS ALTERNATIVE TO P C ** FOR THE CONTROL CHART ANALYSIS. ** C **************************************************************** C ISTEPN='8' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCLSL=CPUMIN IH='LSL ' IH2=' ' IHWUSE='P' CCCCC THE FOLLOWING LINE WAS CHANGED AUGUST 1991 CCCCC MESSAG='YES' MESSAG='NO' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IF(IERRO2.EQ.'NO')CCLSL=VALUE(ILOCP) C CCUSL=CPUMIN IH='USL ' IH2=' ' IHWUSE='P' CCCCC THE FOLLOWING LINE WAS CHANGED AUGUST 1991 CCCCC MESSAG='YES' MESSAG='NO' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IF(IERRO2.EQ.'NO')CCUSL=VALUE(ILOCP) C CCTARG=CPUMIN IH='TARG' IH2='ET ' IHWUSE='P' CCCCC THE FOLLOWING LINE WAS CHANGED AUGUST 1991 CCCCC MESSAG='YES' MESSAG='NO' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IF(IERRO2.EQ.'NO')CCTARG=VALUE(ILOCP) C P=CPUMIN IH='P ' IH2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IF(IERRO2.EQ.'NO')THEN P=VALUE(ILOCP) ELSE IH='WEIG' IH2='HT ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IH,IH2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IF(IERRO2.EQ.'NO')P=VALUE(ILOCP) ENDIF C KWIDTH=3 IH='K ' IH2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IF(IERRO2.EQ.'NO')THEN KWIDTH=INT(VALUE(ILOCP)+0.5) ELSE IH='WIDT' IH2='H ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IH,IH2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IF(IERRO2.EQ.'NO')KWIDTH=INT(VALUE(ILOCP)+0.5) ENDIF C USRSIG=CPUMIN IH='SIGM' IH2='AE ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IF(IERRO2.EQ.'NO')USRSIG=VALUE(ILOCP) C AK=0.5 IH='K ' IH2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IF(IERRO2.EQ.'NO')AK=VALUE(ILOCP) C H=5.0 IH='H ' IH2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IF(IERRO2.EQ.'NO')H=VALUE(ILOCP) C H=5.0 IH='H ' IH2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IF(IERRO2.EQ.'NO')H=VALUE(ILOCP) C SHI=CPUMIN IH='SHI ' IH2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IF(IERRO2.EQ.'NO')SHI=VALUE(ILOCP) C SLI=CPUMIN IH='SLI ' IH2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IF(IERRO2.EQ.'NO')SLI=VALUE(ILOCP) C C ******************************************************* C ** STEP 9-- ** C ** COMPUTE THE APPROPRIATE CONTROL CHART STATISTIC--** C ** MEAN, STANDARD DEVIATION, RANGE, CUSUM, ** C ** P, NP, C, U. ** C ** COMPUTE CONFIDENCE LINES. ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** C ** DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S ** C ** FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE LINE,** C ** AND THE UPPER CONFIDENCE LINE. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ******************************************************* C ISTEPN='8' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C 809 CONTINUE CCCCC THE FOLLOWING 2 LINES WERE UPDATED JULY 1990 CCCCC CALL DPCC2(Y1,X1,NLOCAL,NUMV2,ICASPL,ISIZE,ICONT, CCCCC1XIDTEM,TEMP, CALL DPCC2(Y1,Y2,X1,NLOCAL,NUMV2,ICASPL,ISIZE,ICONT, CCCCC THE FOLLOWING LINE WAS FIXED SEPTEBMER 1990 CCCCC THE FOLLOWING LINE WAS FIXED MARCH 1997 CCCCC1XIDTEM,TEMP,TEMP2, CCCCC1XIDTEM,TEMP,TEMP2,CCLSL,CCUSL,CCTARG, 1XIDTEM,TEMP,TEMP2,CCLSL,CCUSL,CCTARG,P,KWIDTH, CCCCC ADD FOLLOWING LINE APRIL 1997 1ICCHPR,ICCHWT,USRSIG, CCCCC ADD FOLLOWING LINE SEPTEMBER 1998 1AK,H,SHI,SLI, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPCC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9013 FORMAT('PNLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ISIZE 9014 FORMAT('ISIZE = ',I8) CALL DPWRST('XXX','BUG ') IF(NPLOTP.LE.0)GOTO9090 DO9015I=1,NPLOTP WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPCC2(Y,YN,X,N,NUMV2,ICASPL,ISIZE,ICONT, CCCCC THE FOLLOWING LINE WAS FIXED SEPTEMBER 1990 CCCCC1XIDTEM,TEMP,TEMP2, CCCCC THE FOLLOWING LINE WAS FIXED MARCH 1997 CCCCC1XIDTEM,TEMP,TEMP2,CCLSL,CCUSL,CCTARG, 1XIDTEM,TEMP,TEMP2,CCLSL,CCUSL,CCTARG,P,KWIDTH, CCCCC ADD FOLLOWING LINE APRIL 1997 1ICCHPR,ICCHWT,USRSIG, CCCCC ADD FOLLOWING LINE SEPTEMBER 1998 1AK,H,SHI,SLI, 1Y2,X2,D2,N2,NPLOTV,IBUGG3,IERROR) CCCCC THE YN AND TEMP2 ARGUMENTS WERE ADDED ABOVE JULY 1990 C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE A CONTROL CHART C OF THE FOLLOWING TYPES-- C 1) MEAN CONTROL CHART Y X C 2) STANDARD DEVIATION CONTROL CHART Y X C 3) RANGE CONTROL CHART Y X C 4) CUSUM CONTROL CHART Y X C 5) P CONTROL CHART NUMDEF NUMTOT X C 6) PN CONTROL CHART NUMDEF NUMTOT X C 7) U CONTROL CHART NUMDEF SIZE X C 8) P CONTROL CHART NUMDEF SIZE X C 9) EWMA CONTROL CHART Y X C 10) MOVING AVERAGE CONTROL CHART Y X C 11) MOVING RANGE CONTROL CHART Y X C 12) MOVING STANDARD DEVIATION CONTROL CHART Y X C NOTE--USE P AND PN CHARTS IF KNOW HOW MANY ITEMS HAVE DEFECTS C --USE U AND C CHARTS IF KNOW HOW MANY DEFECTS C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105 C REFERENCE--ISHIKAWA, GUIDE TO QUALITY CONTROL C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--JUNE 1978. C UPDATED --OCTOBER 1978. C UPDATED --JANUARY 1981. C UPDATED --DECEMBER 1981. C UPDATED --APRIL 1982. C UPDATED --MAY 1982. C UPDATED --JANUARY 1988. P, PN, U, AND C CHARTS C UPDATED --JULY 1990. FIX P, PN, U, & C CHARTS C UPDATED --SEPTEMBER 1990. LSL, USL, TARGET C UPDATED --MARCH 1997. EWMA CHART, ACTIVATE CUSUM C UPDATED --MARCH 1997. MOVING AVERAGE CHART C UPDATED --MARCH 1997. MOVING RANGE CHART C UPDATED --MARCH 1997. MOVING STANDARD DEVIATION CHART C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CCCCC ADD FOLLOWING LINE MARCH 1997. CCCCC CHARACTER*4 ICASP2 CHARACTER*4 ICONT CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 ICCHPR CHARACTER*4 ICCHWT C C--------------------------------------------------------------------- C DIMENSION Y(*) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1990 DIMENSION YN(*) DIMENSION X(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) C DIMENSION XIDTEM(*) DIMENSION TEMP(*) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1990 DIMENSION TEMP2(*) C CCCCC DIMENSION A(30) CCCCC DIMENSION A0(30) CCCCC DIMENSION A1(30) CCCCC DIMENSION A2(30) DIMENSION A3(30) CCCCC DIMENSION C2(30) DIMENSION C4(30) CCCCC DIMENSION B1(30) CCCCC DIMENSION B2(30) DIMENSION B3(30) DIMENSION B4(30) DIMENSION E2(30) CCCCC DIMENSION D1(30) DIMENSION D22(30) DIMENSION D3(30) DIMENSION D4(30) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C CCCCC DATA(A(I),I= 1, 25) CCCCC1/9.999,2.121,1.732,1.500,1.342,1.225,1.134,1.061,1.000,0.945, CCCCC1 0.905,0.866,0.832,0.802,0.775,0.750,0.723,0.707,0.688,0.671, CCCCC1 0.655,0.640,0.626,0.612,0.600/ CCCCC DATA(A0(I),I= 1, 25) CCCCC1/9.999,3.760,3.070,2.914,2.884,2.899,2.935,2.980,3.030,3.085, CCCCC1 3.136,3.189,3.242,3.295,3.347,3.398,3.448,3.497,3.545,3.592, CCCCC1 3.639,3.684,3.729,3.773,3.816/ CCCCC DATA(A1(I),I= 1, 25) CCCCC1/9.999,3.760,2.394,1.880,1.596,1.410,1.277,1.175,1.094,1.028, CCCCC1 0.973,0.925,0.884,0.848,0.816,0.788,0.762,0.738,0.717,0.697, CCCCC1 0.679,0.662,0.647,0.632,0.619/ CCCCC DATA(A2(I),I= 1, 25) CCCCC1/9.999,1.880,1.023,0.729,0.577,0.483,0.419,0.373,0.337,0.308, CCCCC1 0.285,0.266,0.249,0.235,0.223,0.212,0.203,0.194,0.187,0.180, CCCCC1 0.173,0.167,0.162,0.157,0.153/ DATA(A3(I),I= 1, 25) 1/9.999,2.659,1.954,1.628,1.427, 1 1.287,1.182,1.099,1.032,0.975, 1 0.927,0.886,0.850,0.817,0.789, 1 0.763,0.739,0.718,0.698,0.680, 1 0.663,0.647,0.633,0.619,0.606/ CCCCC DATA(C2(I),I= 1, 25) CCCCC1/9.9999,0.5642,0.7236,0.7979,0.8407, CCCCC1 0.8686,0.8882,0.9027,0.9139,0.9227, CCCCC1 0.9300,0.9359,0.9410,0.9453,0.9490, CCCCC1 0.9523,0.9551,0.9576,0.9599,0.9619, CCCCC1 0.9638,0.9655,0.9670,0.9684,0.9696/ DATA(C4(I),I= 1, 25) 1/9.9999,0.7979,0.8862,0.9213,0.9400, 1 0.9515,0.9594,0.9650,0.9693,0.9727, 1 0.9754,0.9776,0.9794,0.9810,0.9823, 1 0.9835,0.9845,0.9854,0.9862,0.9869, 1 0.9876,0.9882,0.9887,0.9892,0.9896/ CCCCC DATA(B1(I),I= 1, 25) CCCCC1/0.000,0.000,0.000,0.000,0.000,0.026,0.105,0.167,0.219,0.262, CCCCC1 0.299,0.331,0.359,0.384,0.406,0.427,0.445,0.461,0.477,0.491, CCCCC1 0.504,0.516,0.527,0.538,0.548/ CCCCC DATA(B2(I),I= 1, 25) CCCCC1/9.999,1.843,1.858,1.808,1.756,1.711,1.672,1.638,1.609,1.584, CCCCC1 1.561,1.541,1.523,1.507,1.492,1.478,1.465,1.454,1.443,1.433, CCCCC1 1.424,1.415,1.407,1.399,1.392/ DATA(B3(I),I= 1, 25) 1/0.000,0.000,0.000,0.000,0.000,0.030,0.118,0.185,0.239,0.284, 1 0.321,0.354,0.382,0.406,0.428,0.448,0.466,0.482,0.497,0.510, 1 0.523,0.534,0.545,0.555,0.565/ DATA(B4(I),I= 1, 25) 1/9.999,3.267,2.568,2.266,2.089,1.970,1.882,1.815,1.761,1.716, 1 1.679,1.646,1.618,1.594,1.572,1.552,1.534,1.518,1.503,1.490, 1 1.477,1.466,1.455,1.445,1.435/ DATA(E2(I),I= 1, 25) 1/9.999,1.128,1.693,2.059,2.326,2.534,2.704,2.847,2.970,3.078, 1 3.173,3.258,3.336,3.407,3.472,3.532,3.588,3.640,3.689,3.735, 1 3.778,3.819,3.858,3.895,3.931/ CCCCC DATA(D1(I),I= 1, 25) CCCCC1/0.000,0.000,0.000,0.000,0.000,0.000,0.205,0.387,0.546,0.687, CCCCC1 0.812,0.924,1.026,1.121,1.207,1.285,1.359,1.426,1.490,1.548, CCCCC1 1.606,1.659,1.710,1.759,1.804/ DATA(D22(I),I= 1, 25) 1/9.999,3.686,4.358,4.698,4.918,5.078,5.203,5.307,5.394,5.469, 1 5.534,5.592,5.646,5.693,5.737,5.779,5.817,5.854,5.888,5.922, 1 5.950,5.979,6.006,6.031,6.058/ DATA(D3(I),I= 1, 25) 1/0.000,0.000,0.000,0.000,0.000,0.000,0.076,0.136,0.184,0.223, 1 0.256,0.284,0.308,0.329,0.348,0.364,0.379,0.392,0.404,0.414, 1 0.425,0.434,0.443,0.452,0.459/ DATA(D4(I),I= 1, 25) 1/9.999,3.267,2.575,2.282,2.115,2.004,1.924,1.864,1.816,1.777, 1 1.744,1.716,1.692,1.671,1.652,1.636,1.621,1.608,1.596,1.586, 1 1.575,1.566,1.557,1.548,1.541/ C C-----START POINT----------------------------------------------------- C ISUBN1='DPCC' ISUBN2='2 ' C I2=0 ISIZE2=0 C AN=0.0 XBARG=0.0 SDG=0.0 RANGEG=0.0 YUPPER=0.0 YLOWER=0.0 C ANUMSE=0.0 SDI=0.0 SIGMAE=0.0 RANGEE=0.0 SADJ=0.0 RADJ=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.GE.1)GOTO39 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN DPCC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) 32 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,33) 33 FORMAT(' MUST BE AT LEAST 1;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,34)N 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 39 CONTINUE C IF(N.GE.2)GOTO49 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46) 46 FORMAT('***** ERROR IN DPCC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47) 47 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48) 48 FORMAT(' WAS EXACTLY EQUAL TO 1.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 49 CONTINUE C HOLD=Y(1) DO60I=1,N IF(Y(I).NE.HOLD)GOTO69 60 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61) 61 FORMAT('***** ERROR IN DPCC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' ALL RESPONSE VARIABLE ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)HOLD 63 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 69 CONTINUE C IF(IBUGG3.EQ.'OFF')GOTO90 WRITE(ICOUT,70) 70 FORMAT('AT THE BEGINNING OF DPCC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)N,ICASPL,NUMV2,ISIZE,ICONT 71 FORMAT('N,ICASPL,NUMV2,ISIZE,ICONT = ',I8,2X,A4,I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') DO72I=1,N WRITE(ICOUT,73)I,Y(I),X(I) 73 FORMAT('I, Y(I), X(I) = ',I8,3F15.7) CALL DPWRST('XXX','BUG ') 72 CONTINUE IF(NUMV2.LE.2)GOTO79 DO75I=1,N WRITE(ICOUT,76)I,YN(I),X(I) 76 FORMAT('I,YN(I),X(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 75 CONTINUE 79 CONTINUE 90 CONTINUE C C ******************************************************** C ** STEP 1-- ** C ** DETERMINE THE NUMBER OF DISTINCT VALUES ** C ** FOR VARIABLE 2 (THE GROUP VARIABLE). ** C ** IF ALL VALUES ARE DISTINCT, THEN THIS ** C ** IMPLIES WE HAVE THE NO REPLICATION CASE ** C ** WHICH IS AN ERROR CONDITION FOR A CONTROL CHART. ** C ******************************************************** C ISTEPN='1' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMV2.EQ.1)GOTO110 CCCCC THE FOLLOWING LINE WAS CHANGED JULY 1990 CCCCC IF(NUMV2.EQ.2)GOTO150 IF(NUMV2.GE.2)GOTO150 C CCCCC SEPTEMBER 1998. RECODE THIS SECTION. 110 CONTINUE NUMSET=0 IF(ISIZE.EQ.1)THEN DO120I=1,N XIDTEM(I)=REAL(I) X(I)=XIDTEM(I) 120 CONTINUE ELSE NUMSET=0 ILOOP=N/ISIZE DO145I=1,ILOOP NUMSET=NUMSET+1 XIDTEM(NUMSET)=REAL(NUMSET) ISTART=(I-1)*ISIZE+1 ISTOP=I*ISIZE DO147J=ISTART,ISTOP X(J)=XIDTEM(NUMSET) 147 CONTINUE 145 CONTINUE ILEFT=MOD(N,ISIZE) IF(ILEFT.NE.0)THEN ISTART=ILOOP*ISIZE+1 NUMSET=NUMSET+1 XIDTEM(NUMSET)=REAL(NUMSET) DO148J=ISTART,N X(J)=XIDTEM(NUMSET) 148 CONTINUE ENDIF ENDIF C 150 CONTINUE NUMSET=0 DO160I=1,N IF(NUMSET.EQ.0)GOTO165 DO170J=1,NUMSET IF(X(I).EQ.XIDTEM(J))GOTO160 170 CONTINUE 165 CONTINUE NUMSET=NUMSET+1 XIDTEM(NUMSET)=X(I) 160 CONTINUE CALL SORT(XIDTEM,NUMSET,XIDTEM) C 190 CONTINUE C IF(NUMSET.GE.1)GOTO194 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,191) 191 FORMAT('***** ERROR IN DPCC2 SUBROUTINE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,192) 192 FORMAT(' NUMBER OF SETS NUMSET = 0 ') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 194 CONTINUE C CCCCC THE FOLLOWING 4 LINES WERE ADDED JULY 1990 IF(ICASPL.EQ.'PCC')GOTO199 IF(ICASPL.EQ.'PNCC')GOTO199 IF(ICASPL.EQ.'UCC')GOTO199 IF(ICASPL.EQ.'CCC')GOTO199 CCCCC THE FOLLOWING LINES ADDED MARCH 1997 IF(ICASPL.EQ.'EWCC')GOTO199 IF(ICASPL.EQ.'MACC')GOTO199 IF(ICASPL.EQ.'MRCC')GOTO199 IF(ICASPL.EQ.'MSCC')GOTO199 IF(ICASPL.EQ.'CUCC')GOTO199 C IF(NUMSET.NE.N)GOTO199 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,195) 195 FORMAT('***** ERROR IN DPCC2 SUBROUTINE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,196) 196 FORMAT(' NUMBER OF SETS NUMSET IDENTICAL TO ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,197) 197 FORMAT(' NUMBER OF OBSERVATIONS N .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,198)NUMSET 198 FORMAT(' NUMSET = N = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 199 CONTINUE C AN=N ANUMSE=NUMSET C C ******************************************* C ** STEP 3.0-- ** C ** DETERMINE STATISTICS FOR THE ENTIRE ** C ** DATA SET ** C ******************************************* C 1000 CONTINUE C ISTEPN='3.0' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C SUMXBG=0.0 SUMSDG=0.0 SUMRAG=0.0 SUMSIE=0.0 SUMRIE=0.0 J=0 DO1010ISET=1,NUMSET J=J+1 C K=0 DO1020I=1,N IF(X(I).EQ.XIDTEM(ISET))K=K+1 IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I) 1020 CONTINUE NI=K ANI=NI C SUM=0.0 IF(NI.LE.0)GOTO1040 DO1030I=1,NI SUM=SUM+TEMP(I) 1030 CONTINUE XBARI=SUM/ANI C SUM=0.0 DO1032I=1,NI SUM=SUM+(TEMP(I)-XBARI)**2 1032 CONTINUE DENOM=ANI-1.0 VARI=0.0 IF(NI.GE.2)VARI=SUM/DENOM SDI=0.0 IF(VARI.GT.0.0)SDI=SQRT(VARI) C XTMIN=TEMP(1) XTMAX=TEMP(1) DO1034I=1,NI IF(TEMP(I).LT.XTMIN)XTMIN=TEMP(I) IF(TEMP(I).GT.XTMAX)XTMAX=TEMP(I) 1034 CONTINUE RANGEI=XTMAX-XTMIN GOTO1049 C 1040 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1041) 1041 FORMAT('***** INTERNAL ERROR IN DPCC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1042) 1042 FORMAT('NI FOR SOME CLASS = 0') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1043)ISET,XIDTEM(ISET),NI 1043 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1049 CONTINUE C SUMXBG=SUMXBG+ANI*XBARI SUMSDG=SUMSDG+ANI*SDI SUMRAG=SUMRAG+ANI*RANGEI C4LARG=1.0 IF(NI.LE.25)SUMSIE=SUMSIE+SDI/C4(NI) IF(NI.GE.26)SUMSIE=SUMSIE+SDI/C4LARG D22LAR=2.0*SQRT(2.0*ALOG(2.0*ANI)) IF(NI.LE.25)SUMRIE=SUMRIE+RANGEI/D22(NI) IF(NI.GE.26)SUMRIE=SUMRIE+RANGEI/D22LAR C IF(IBUGG3.EQ.'OFF')GOTO1069 WRITE(ICOUT,1061)ISET,NI,ANI 1061 FORMAT('ISET,NI,ANI = ',I8,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1062)XBARI 1062 FORMAT('XBARI = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1063)SDI,C4(NI),C4LARG,SUMSIE 1063 FORMAT('SDI,C4(NI),C4LARG,SUMSIE = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1064)RANGEI,D22(NI),D22LAR,SUMRIE 1064 FORMAT('RANGEI,D22(NI),D22LAR,SUMRIE = ',4E15.7) CALL DPWRST('XXX','BUG ') 1069 CONTINUE C 1010 CONTINUE C XBARG=SUMXBG/AN SDG=SUMSDG/AN RANGEG=SUMRAG/AN SIGMAE=SUMSIE/ANUMSE RANGEE=SUMRIE/ANUMSE C C FOR UNGROUPED DATA, USE THE MOVING RANGE OR THE MOVING STANDARD C DEVIATION TO COMPUTE AN ESTIMATE FOR SIGMAE. MARCH 1997. C RANGEM=0.0 SDM=0.0 IF(N.EQ.NUMSET)THEN IF(KWIDTH.LT.2)KWIDTH=2 IF(KWIDTH.GT.N-1)KWIDTH=N-1 NBEF=KWIDTH/2 NAFT=NBEF IF(MOD(KWIDTH,2).EQ.0)NAFT=NBEF-1 IF(1+NBEF.GT.NUMSET-NAFT)THEN WRITE(ICOUT,1071)KWIDTH CALL DPWRST('XXXX','BUG') IERROR='YES' GOTO9000 ENDIF 1071 FORMAT( 1'***** ERROR: THERE ARE NOT ENOUGH DATA POINTS TO FORM THE'/, 1' MOVING RANGE ESTIMATE OF THE ERROR STANDARD DEVIATION'/, 1' FOR UNGROUPED DATA. YOU PROBABLY NEED TO SET A '/, 1' SMALLER VALUE FOR THE FILTER WIDTH. FOR EXAMPLE, '//, 1' LET K = 3'//, 1' THE PARAMETER K DEFINES HOW MANY VALUES ARE USED TO '/, 1' COMPUTE THE MOVING RANGE (3 IS THE TYPICALY VALUE).'/, 1' THE CURRENT VALUE OF K IS ',I5,' .') SUM=0.0 SUM2=0.0 ICOUNT=0 DO1073I=1+NBEF,NUMSET-NAFT ICOUNT=ICOUNT+1 SUM1=0.0 XTMIN=Y(I-NBEF) XTMAX=Y(I+NAFT) DO1076II=I-NBEF,I+NAFT IF(Y(II).LT.XTMIN)XTMIN=Y(II) IF(Y(II).GT.XTMAX)XTMAX=Y(II) SUM1=SUM1+Y(II) 1076 CONTINUE SUM=SUM+(XTMAX-XTMIN) XMEAN=SUM1/REAL(KWIDTH) SUM1=0.0 DO1077II=I-NBEF,I+NAFT SUM1=SUM1+(Y(II)-XMEAN)**2 1077 CONTINUE SUM2=SUM2+SQRT(SUM1/REAL(KWIDTH-1)) 1073 CONTINUE RANGEM=SUM/REAL(ICOUNT) SDM=SUM2/REAL(ICOUNT) ENDIF C C ************************************************************** C ** STEP 4-- ** C ** IN ORDER TO DETERMINE THE PROPER PLOT COOORDINATES ** C ** FOR THE DESIRED PLOT, ** C ** BRANCH TO THE PROPER SUBCASE-- ** C ** 1) MEAN CONTROL CHART; ** C ** 2) STANDARD DEVIATION CONTROL CHART; ** C ** 3) RANGE CONTROL CHART; ** C ** 4) CUSUM CONTROL CHART; ** C ** 5) P CONTROL CHART; ** C ** 6) PN CONTROL CHART; ** C ** 7) C CONTROL CHART; ** C ** 8) U CONTROL CHART; ** C ** 9) EWMA CONTROL CHART; ** C ** 10) MOVING AVERAGE CONTROL CHART; ** C ** 11) MOVING RANGE CONTROL CHART; ** C ** 12) MOVING SD CONTROL CHART; ** C ************************************************************** C ISTEPN='4' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASPL.EQ.'MECC')GOTO1100 IF(ICASPL.EQ.'SDCC')GOTO1200 IF(ICASPL.EQ.'RACC')GOTO1300 IF(ICASPL.EQ.'CUCC')GOTO1400 IF(ICASPL.EQ.'PCC')GOTO1500 IF(ICASPL.EQ.'PNCC')GOTO1600 IF(ICASPL.EQ.'UCC')GOTO1700 IF(ICASPL.EQ.'CCC')GOTO1800 CCCCC ADD FOLLOWING LINES MARCH 1997 IF(ICASPL.EQ.'EWCC')GOTO1900 IF(ICASPL.EQ.'MACC')GOTO2000 IF(ICASPL.EQ.'MRCC')GOTO2100 IF(ICASPL.EQ.'MSCC')GOTO2200 C 1050 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1051) 1051 FORMAT('***** INTERNAL ERROR IN DPCC2') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1052) 1052 FORMAT(' AT BRANCH POINT 261--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1053) 1053 FORMAT(' ICASPL NOT EQUAL ONE OF THE ALLOWABLE 8--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1054) 1054 FORMAT(' MECC, SDCC, RACC, CSCC, PCC, PNCC, UCC, CCC.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1056)ICASPL 1056 FORMAT(' ICASPL = ',A4) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C C ***************************************** C ** STEP 5.1-- ** C ** TREAT THE MEAN CONTROL CHART CASE ** C ***************************************** C 1100 CONTINUE C ISTEPN='5.1' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C J=0 DO1110ISET=1,NUMSET C K=0 DO1120I=1,N IF(X(I).EQ.XIDTEM(ISET))K=K+1 IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I) 1120 CONTINUE NI=K ANI=NI C IF(NI.GE.1)GOTO1139 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1131) 1131 FORMAT('***** INTERNAL ERROR IN DPCC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1132) 1132 FORMAT('NI FOR SOME CLASS = 0') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1133)ISET,XIDTEM(ISET),NI 1133 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1139 CONTINUE C SUM=0.0 DO1140I=1,NI SUM=SUM+TEMP(I) 1140 CONTINUE XBARI=SUM/ANI C YMID=XBARG C C4LARG=1.0 IF(NI.LE.25)SADJ=C4(NI)*SIGMAE IF(NI.GE.26)SADJ=C4LARG*SIGMAE C A3LARG=3.0/SQRT(ANI) IF(NI.LE.25)YUPPER=XBARG+A3(NI)*SADJ IF(NI.GE.26)YUPPER=XBARG+A3LARG*SADJ C IF(NI.LE.25)YLOWER=XBARG-A3(NI)*SADJ IF(NI.GE.26)YLOWER=XBARG-A3LARG*SADJ C IF(IBUGG3.EQ.'OFF')GOTO1169 WRITE(ICOUT,1161)ISET,NI,ANI 1161 FORMAT('ISET,NI,ANI = ',I8,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1162)XBARI 1162 FORMAT('XBARI = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1163)SDI,C4(NI),C4LARG,SIGMAE,SADJ 1163 FORMAT('SDI,C4(NI),C4LARG,SIGMAE,SADJ = ',5E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1164)XBARG,YMID 1164 FORMAT('XBARG,YMID = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1165)NI,ANI,A3(NI),A3LARG,YUPPER 1165 FORMAT('NI,ANI,A3(NI),A3LARG,YUPPER = ',I8,4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1166)NI,ANI,A3(NI),A3LARG,YLOWER 1166 FORMAT('NI,ANI,A3(NI),A3LARG,YLOWER = ',I8,4E15.7) CALL DPWRST('XXX','BUG ') 1169 CONTINUE C J=J+1 Y2(J)=XBARI X2(J)=XIDTEM(ISET) D2(J)=1.0 C J=J+1 Y2(J)=YMID X2(J)=XIDTEM(ISET) D2(J)=2.0 C J=J+1 Y2(J)=YUPPER X2(J)=XIDTEM(ISET) D2(J)=3.0 C J=J+1 Y2(J)=YLOWER X2(J)=XIDTEM(ISET) D2(J)=4.0 C CCCCC THE FOLLOWING 3 SECTIONS WERE ADDED SEPTEMBER IF(CCTARG.EQ.CPUMIN)GOTO1171 J=J+1 Y2(J)=CCTARG X2(J)=XIDTEM(ISET) D2(J)=5.0 1171 CONTINUE C IF(CCUSL.EQ.CPUMIN)GOTO1172 J=J+1 Y2(J)=CCUSL X2(J)=XIDTEM(ISET) D2(J)=6.0 1172 CONTINUE C IF(CCLSL.EQ.CPUMIN)GOTO1173 J=J+1 Y2(J)=CCLSL X2(J)=XIDTEM(ISET) D2(J)=7.0 1173 CONTINUE C 1110 CONTINUE N2=J NPLOTV=3 GOTO9000 C C ******************************************************** C ** STEP 5.2-- ** C ** TREAT THE STANDARD DEVIATION CONTROL CHART CASE ** C ******************************************************** C 1200 CONTINUE C ISTEPN='5.2' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C J=0 DO1210ISET=1,NUMSET C K=0 DO1220I=1,N IF(X(I).EQ.XIDTEM(ISET))K=K+1 IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I) 1220 CONTINUE NI=K ANI=NI C IF(NI.GE.1)GOTO1239 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1231) 1231 FORMAT('***** INTERNAL ERROR IN DPCC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1232) 1232 FORMAT('NI FOR SOME CLASS = 0') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1233)ISET,XIDTEM(ISET),NI 1233 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1239 CONTINUE C SUM=0.0 DO1240I=1,NI SUM=SUM+TEMP(I) 1240 CONTINUE XBARI=SUM/ANI C IF(NI.LE.1)GOTO1210 C SUM=0.0 DO1250I=1,NI SUM=SUM+(TEMP(I)-XBARI)**2 1250 CONTINUE DENOM=ANI-1.0 VARI=0.0 IF(NI.GE.2)VARI=SUM/DENOM SDI=0.0 IF(VARI.GT.0.0)SDI=SQRT(VARI) C C4LARG=1.0 IF(NI.LE.25)SADJ=C4(NI)*SIGMAE IF(NI.GE.26)SADJ=C4LARG*SIGMAE C YMID=SADJ C B4LARG=1.0+3.0/SQRT(2.0*(ANI-1.0)) IF(NI.LE.25)YUPPER=B4(NI)*SADJ IF(NI.GE.26)YUPPER=B4LARG*SADJ C B3LARG=1.0-3.0/SQRT(2.0*(ANI-1.0)) IF(NI.LE.25)YLOWER=B3(NI)*SADJ IF(NI.GE.26)YLOWER=B3LARG*SADJ C IF(IBUGG3.EQ.'OFF')GOTO1269 WRITE(ICOUT,1261)ISET,NI,ANI 1261 FORMAT('ISET,NI,ANI = ',I8,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1262)XBARI 1262 FORMAT('XBARI = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1263)SDI,C4(NI),C4LARG,SIGMAE,SADJ 1263 FORMAT('SDI,C4(NI),C4LARG,SIGMAE,SADJ = ',5E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1264)SADJ,YMID 1264 FORMAT('SADJ,YMID = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1265)NI,ANI,B4(NI),B4LARG,YUPPER 1265 FORMAT('NI,ANI,B4(NI),B4LARG,YUPPER = ',I8,4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1266)NI,ANI,B3(NI),B3LARG,YLOWER 1266 FORMAT('NI,ANI,B3(NI),B3LARG,YLOWER = ',I8,4E15.7) CALL DPWRST('XXX','BUG ') 1269 CONTINUE C J=J+1 Y2(J)=SDI X2(J)=XIDTEM(ISET) D2(J)=1.0 C J=J+1 Y2(J)=YMID X2(J)=XIDTEM(ISET) D2(J)=2.0 C J=J+1 Y2(J)=YUPPER X2(J)=XIDTEM(ISET) D2(J)=3.0 C J=J+1 Y2(J)=YLOWER X2(J)=XIDTEM(ISET) D2(J)=4.0 C CCCCC THE FOLLOWING 3 SECTIONS WERE ADDED SEPTEMBER IF(CCTARG.EQ.CPUMIN)GOTO1271 J=J+1 Y2(J)=CCTARG X2(J)=XIDTEM(ISET) D2(J)=5.0 1271 CONTINUE C IF(CCUSL.EQ.CPUMIN)GOTO1272 J=J+1 Y2(J)=CCUSL X2(J)=XIDTEM(ISET) D2(J)=6.0 1272 CONTINUE C IF(CCLSL.EQ.CPUMIN)GOTO1273 J=J+1 Y2(J)=CCLSL X2(J)=XIDTEM(ISET) D2(J)=7.0 1273 CONTINUE C 1210 CONTINUE N2=J NPLOTV=3 GOTO9000 C C ****************************************** C ** STEP 5.3-- ** C ** TREAT THE RANGE CONTROL CHART CASE ** C ****************************************** C 1300 CONTINUE C ISTEPN='5.3' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C D4FACT=1.25 D3FACT=1.0/1.25 C J=0 DO1310ISET=1,NUMSET C K=0 DO1320I=1,N IF(X(I).EQ.XIDTEM(ISET))K=K+1 IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I) 1320 CONTINUE NI=K ANI=NI C IF(NI.GE.1)GOTO1339 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1331) 1331 FORMAT('***** INTERNAL ERROR IN DPCC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1332) 1332 FORMAT('NI FOR SOME CLASS = 0') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1333)ISET,XIDTEM(ISET),NI 1333 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1339 CONTINUE C IF(NI.LE.1)GOTO1310 C XTMIN=TEMP(1) XTMAX=TEMP(1) DO1340I=1,NI IF(TEMP(I).LT.XTMIN)XTMIN=TEMP(I) IF(TEMP(I).GT.XTMAX)XTMAX=TEMP(I) 1340 CONTINUE RANGEI=XTMAX-XTMIN C D22LAR=2.0*SQRT(2.0*ALOG(2.0*ANI)) IF(NI.LE.25)RADJ=D22(NI)*RANGEE IF(NI.GE.26)RADJ=D22LAR*RANGEE C YMID=RADJ C D4LARG=1.0+3.0*D4FACT/SQRT(2.0*(ANI-1.0)) IF(NI.LE.25)YUPPER=D4(NI)*RADJ IF(NI.GE.26)YUPPER=D4LARG*RADJ C D3LARG=1.0-3.0*D3FACT/SQRT(2.0*(ANI-1.0)) IF(NI.LE.25)YLOWER=D3(NI)*RADJ IF(NI.GE.26)YLOWER=D3LARG*RADJ C IF(IBUGG3.EQ.'OFF')GOTO1369 WRITE(ICOUT,1361)ISET,NI,ANI 1361 FORMAT('ISET,NI,ANI = ',I8,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1362)RANGEI 1362 FORMAT('RANGEI = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1363)RANGEI,D22(NI),D22LAR,RANGEE,SADJ 1363 FORMAT('RANGEI,D22(NI),D22LAR,RANGEE,SADJ = ',5E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1364)RADJ,YMID 1364 FORMAT('RADJ,YMID = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1365)NI,ANI,D4(NI),D4LARG,YUPPER 1365 FORMAT('NI,ANI,D4(NI),D4LARG,YUPPER = ',I8,4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1366)NI,ANI,D3(NI),D3LARG,YLOWER 1366 FORMAT('NI,ANI,D3(NI),D3LARG,YLOWER = ',I8,4E15.7) CALL DPWRST('XXX','BUG ') 1369 CONTINUE C J=J+1 Y2(J)=RANGEI X2(J)=XIDTEM(ISET) D2(J)=1.0 C J=J+1 Y2(J)=YMID X2(J)=XIDTEM(ISET) D2(J)=2.0 C J=J+1 Y2(J)=YUPPER X2(J)=XIDTEM(ISET) D2(J)=3.0 C J=J+1 Y2(J)=YLOWER X2(J)=XIDTEM(ISET) D2(J)=4.0 C CCCCC THE FOLLOWING 3 SECTIONS WERE ADDED SEPTEMBER IF(CCTARG.EQ.CPUMIN)GOTO1371 J=J+1 Y2(J)=CCTARG X2(J)=XIDTEM(ISET) D2(J)=5.0 1371 CONTINUE C IF(CCUSL.EQ.CPUMIN)GOTO1372 J=J+1 Y2(J)=CCUSL X2(J)=XIDTEM(ISET) D2(J)=6.0 1372 CONTINUE C IF(CCLSL.EQ.CPUMIN)GOTO1373 J=J+1 Y2(J)=CCLSL X2(J)=XIDTEM(ISET) D2(J)=7.0 1373 CONTINUE C 1310 CONTINUE N2=J NPLOTV=3 GOTO9000 C C ****************************************************** C ** STEP 5.4-- ** C ** DETERMINE PLOT COORDINATES ** C ** FOR THE CUSUM CONTROL CHART PLOT SUBCASE. ** C ****************************************************** C 1400 CONTINUE C ISTEPN='3.4' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC WRITE(ICOUT,1405) C1405 FORMAT('CUSUM CAPABILITY NOT YET AVAILABLE.') CCCCC CALL DPWRST('XXX','BUG ') C J=0 C SUMH=0.0 SUML=0.0 IF(SHI.NE.CPUMIN)SUMH=SHI IF(SLI.NE.CPUMIN)SUML=SLI ZHIGH=3.5 IF(CCUSL.NE.CPUMIN)ZHIGH=CCUSL C DO1410ISET=1,NUMSET C K=0 DO1420I=1,N IF(X(I).EQ.XIDTEM(ISET))K=K+1 IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I) 1420 CONTINUE NI=K ANI=NI C IF(NI.GE.1)GOTO1439 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1431) 1431 FORMAT('***** INTERNAL ERROR IN DPCC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1432) 1432 FORMAT('NI FOR SOME CLASS = 0') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1433)ISET,XIDTEM(ISET),NI 1433 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1439 CONTINUE C IF(NI.EQ.1)THEN ZI=(TEMP(1)-XBARG)/RANGEM ELSE SUM=0.0 DO1441I=1,NI SUM=SUM+TEMP(I) 1441 CONTINUE XBARI=SUM/ANI ZI=(XBARI-XBARG)/SIGMAE ENDIF C SUMH=MAX(0.0,SUMH+(ZI-AK)) SUML=MAX(0.0,SUML+(-ZI-AK)) C IF(IBUGG3.EQ.'OFF')GOTO1469 WRITE(ICOUT,1461)ISET,NI,ANI 1461 FORMAT('ISET,NI,ANI = ',I8,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1462)XBARI 1462 FORMAT('XBARI = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1463)ZI,SUMH,SUML 1463 FORMAT('ZI,SUMH,SUML = ',3E15.7) CALL DPWRST('XXX','BUG ') 1469 CONTINUE C YUPPER=H YLOWER=-H C J=J+1 Y2(J)=SUMH X2(J)=XIDTEM(ISET) D2(J)=1.0 C J=J+1 Y2(J)=-SUML X2(J)=XIDTEM(ISET) D2(J)=2.0 C J=J+1 Y2(J)=0.0 X2(J)=XIDTEM(ISET) D2(J)=3.0 C J=J+1 Y2(J)=YUPPER X2(J)=XIDTEM(ISET) D2(J)=4.0 C J=J+1 Y2(J)=YLOWER X2(J)=XIDTEM(ISET) D2(J)=5.0 C IF(ZI.LE.ZHIGH)GOTO1472 J=J+1 Y2(J)=SUMH X2(J)=XIDTEM(ISET) D2(J)=6.0 J=J+1 Y2(J)=SUML X2(J)=XIDTEM(ISET) D2(J)=7.0 1472 CONTINUE C 1410 CONTINUE C 1490 CONTINUE N2=J NPLOTV=3 GOTO9000 C CCCCC THE FOLLOWING SECTION WAS COMPLETELY REWRITTEN JULY 1990 C ******************************************************** C ** STEP 5.5-- ** C ** TREAT THE P CONTROL CHART CASE ** C ** PROPORTION DEFECTIVE PER BATCH (SUBSAMPLE) ** C ** NUMBER DEFECTIVE PER BATCH / TOTAL NUMBER IN BATCH C ** THE INPUT IS A DUAL SERIES-- C ** 1) NUMBER OF DEFECTIVE ITEMS IN THE SUBSAMPLE C ** 2) TOTAL NUMBER OF ITEMS IN THE SAMPLE C ** THE CONFIDENCE BAND IS GOTTEN BY ASSUMING BINOMIAL** C ******************************************************** C 1500 CONTINUE C ISTEPN='5.5' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C SUM1=0.0 SUM2=0.0 DO1510ISET=1,NUMSET SUM1=SUM1+Y(ISET) SUM2=SUM2+YN(ISET) 1510 CONTINUE CTOTAL=SUM1 ANTOT=SUM2 PBARG=CTOTAL/ANTOT PRBARG=100.0*PBARG C J=0 DO1550ISET=1,NUMSET C CI=Y(ISET) ANI=YN(ISET) NI=ANI+0.5 IF(NI.LE.0)GOTO1550 C PI=CI/ANI PROPI=100.0*PI TAGI=XIDTEM(ISET) C J=J+1 Y2(J)=PROPI X2(J)=TAGI D2(J)=1.0 C J=J+1 YMID=PRBARG Y2(J)=YMID X2(J)=TAGI D2(J)=2.0 C J=J+1 VARPI=0.0 IF(ANI.GT.0.0)VARPI=PBARG*(1.0-PBARG)/ANI SDPI=0.0 IF(VARPI.GT.0.0)SDPI=SQRT(VARPI) SDPRI=100.0*SDPI YUPPER=YMID+3.0*SDPRI IF(YUPPER.GT.100.0)YUPPER=100.0 Y2(J)=YUPPER X2(J)=TAGI D2(J)=3.0 C J=J+1 YLOWER=YMID-3.0*SDPRI IF(YLOWER.LT.0.0)YLOWER=0.0 Y2(J)=YLOWER X2(J)=TAGI D2(J)=4.0 C CCCCC THE FOLLOWING 3 SECTIONS WERE ADDED SEPTEMBER IF(CCTARG.EQ.CPUMIN)GOTO1571 J=J+1 Y2(J)=CCTARG X2(J)=XIDTEM(ISET) D2(J)=5.0 1571 CONTINUE C IF(CCUSL.EQ.CPUMIN)GOTO1572 J=J+1 Y2(J)=CCUSL X2(J)=XIDTEM(ISET) D2(J)=6.0 1572 CONTINUE C IF(CCLSL.EQ.CPUMIN)GOTO1573 J=J+1 Y2(J)=CCLSL X2(J)=XIDTEM(ISET) D2(J)=7.0 1573 CONTINUE C 1550 CONTINUE N2=J NPLOTV=3 GOTO9000 C CCCCC THE FOLLOWING SECTION WAS COMPLETELY REWRITTEN JULY 1990 C ******************************************************** C ** STEP 5.6-- ** C ** TREAT THE PN CONTROL CHART CASE ** C ** TOTAL NUMBER DEFECTIVE IN A BATCH (SUBSAMPLE) ** C ** SUM UP THE NUMBER OF DEFECTIVES PER BATCH (SUBSAMPLE) C ** THE NUMBER WILL BE A NON-NEGATIVE INTEGER C ** THE INPUT IS A DUAL SERIES-- C ** 1) NUMBER OF DEFECTIVE ITEMS IN THE SUBSAMPLE C ** 2) TOTAL NUMBER OF ITEMS IN THE SAMPLE C ** THE CONFIDENCE BAND IS GOTTEN BY ASSUMING BINOMIAL** C ** NOTE--THE PN CHART SHOULD BE USED ONLY WHEN C ** THE SUBSAMPLE SIZE IS CONSTANT. C ** FOR VARYING SUBSAMPLE SIZE, USE THE P CHART C ** (ISHIKAWA, GUIDE TO QUALITY CONTROL, PAGE 77) C ******************************************************** C 1600 CONTINUE C ISTEPN='5.6' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C SUM1=0.0 SUM2=0.0 ANUMSE=NUMSET DO1610ISET=1,NUMSET SUM1=SUM1+Y(ISET) SUM2=SUM2+YN(ISET) 1610 CONTINUE CTOTAL=SUM1 ANTOT=SUM2 PBARG=CTOTAL/ANTOT ANBARG=ANTOT/ANUMSE CBARG=PBARG*ANBARG C J=0 DO1650ISET=1,NUMSET C CI=Y(ISET) ANI=YN(ISET) NI=ANI+0.5 IF(NI.LE.0)GOTO1650 C PI=CI/ANI TAGI=XIDTEM(ISET) C J=J+1 Y2(J)=CI X2(J)=TAGI D2(J)=1.0 C J=J+1 YMID=CBARG Y2(J)=YMID X2(J)=TAGI D2(J)=2.0 C J=J+1 VARCI=0.0 IF(ANBARG.GT.0.0)VARCI=ANBARG*PBARG*(1.0-PBARG) SDCI=0.0 IF(VARCI.GT.0.0)SDCI=SQRT(VARCI) YUPPER=YMID+3.0*SDCI Y2(J)=YUPPER X2(J)=TAGI D2(J)=3.0 C J=J+1 YLOWER=YMID-3.0*SDCI IF(YLOWER.LT.0.0)YLOWER=0.0 Y2(J)=YLOWER X2(J)=TAGI D2(J)=4.0 C CCCCC THE FOLLOWING 3 SECTIONS WERE ADDED SEPTEMBER IF(CCTARG.EQ.CPUMIN)GOTO1671 J=J+1 Y2(J)=CCTARG X2(J)=XIDTEM(ISET) D2(J)=5.0 1671 CONTINUE C IF(CCUSL.EQ.CPUMIN)GOTO1672 J=J+1 Y2(J)=CCUSL X2(J)=XIDTEM(ISET) D2(J)=6.0 1672 CONTINUE C IF(CCLSL.EQ.CPUMIN)GOTO1673 J=J+1 Y2(J)=CCLSL X2(J)=XIDTEM(ISET) D2(J)=7.0 1673 CONTINUE C 1650 CONTINUE N2=J NPLOTV=3 GOTO9000 C CCCCC THE FOLLOWING SECTION WAS COMPLETELY REWRITTEN JULY 1990 C ******************************************************** C ** STEP 5.7-- ** C ** TREAT THE U CONTROL CHART CASE (POISSON) ** C ** DEFECTIVE PER UNIT C ** DEFECTIVE PER UNIT AREA C ** NUMBER DEFECTIVE PER SUB-BATCH / LENGTH OR AREA C ** THE INPUT IS A DUAL SERIES-- C ** 1) NUMBER OF DEFECTIVE ITEMS IN THE SUBSAMPLE C ** 2) LENGTH OR AREA OF THE ITEM C ** THE CONFIDENCE BAND IS GOTTEN BY ASSUMING POISSON** C ******************************************************** C 1700 CONTINUE C ISTEPN='5.7' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C SUM1=0.0 SUM2=0.0 DO1710ISET=1,NUMSET SUM1=SUM1+Y(ISET) SUM2=SUM2+YN(ISET) 1710 CONTINUE CTOTAL=SUM1 SIZTOT=SUM2 CBARG=CTOTAL/SIZTOT C J=0 DO1750ISET=1,NUMSET C CI=Y(ISET) SIZEI=YN(ISET) NSIZEI=SIZEI+0.5 IF(NSIZEI.LE.0)GOTO1750 C TAGI=XIDTEM(ISET) C J=J+1 Y2(J)=(-1.0) IF(SIZEI.NE.0.0)Y2(J)=CI/SIZEI X2(J)=TAGI D2(J)=1.0 C J=J+1 YMID=CBARG Y2(J)=YMID X2(J)=TAGI D2(J)=2.0 C J=J+1 VARCI=0.0 IF(ANI.GT.0.0)VARCI=CBARG/SIZEI SDCI=0.0 IF(VARCI.GT.0.0)SDCI=SQRT(VARCI) YUPPER=YMID+3.0*SDCI Y2(J)=YUPPER X2(J)=TAGI D2(J)=3.0 C J=J+1 YLOWER=YMID-3.0*SDCI IF(YLOWER.LT.0.0)YLOWER=0.0 Y2(J)=YLOWER X2(J)=TAGI D2(J)=4.0 C CCCCC THE FOLLOWING 3 SECTIONS WERE ADDED SEPTEMBER IF(CCTARG.EQ.CPUMIN)GOTO1771 J=J+1 Y2(J)=CCTARG X2(J)=XIDTEM(ISET) D2(J)=5.0 1771 CONTINUE C IF(CCUSL.EQ.CPUMIN)GOTO1772 J=J+1 Y2(J)=CCUSL X2(J)=XIDTEM(ISET) D2(J)=6.0 1772 CONTINUE C IF(CCLSL.EQ.CPUMIN)GOTO1773 J=J+1 Y2(J)=CCLSL X2(J)=XIDTEM(ISET) D2(J)=7.0 1773 CONTINUE C 1750 CONTINUE N2=J NPLOTV=3 GOTO9000 C CCCCC THE FOLLOWING SECTION WAS COMPLETELY REWRITTEN JULY 1990 C ******************************************************** C ** STEP 5.8-- ** C ** TREAT THE C CONTROL CHART CASE (POISSON) ** C ** TOTAL NUMBER DEFECTIVE IN A BATCH (SUBSAMPLE) ** C ** SUM OF DEFECTIVES IN A BATCH (SUBSAMPLE) ** C ** THE INPUT IS USUALLY A SERIES OF INTEGERS ** C ** THE VALUE WILL BE A NON-NEGATIVE INTEGER ** C ** THE CONFIDENCE BAND IS GOTTEN BY ASSUMING POISSON** C ** NOTE--THE C CHART SHOULD BE USED ONLY WHEN C ** THE SUBSAMPLE SIZE IS CONSTANT. C ** FOR VARYING SUBSAMPLE SIZE, USE THE U CHART C ** (ISHIKAWA, GUIDE TO QUALITY CONTROL, PAGE 77) C ******************************************************** C 1800 CONTINUE C ISTEPN='5.8' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C SUM1=0.0 SUM2=0.0 ANUMSE=NUMSET DO1810ISET=1,NUMSET SUM1=SUM1+Y(ISET) IF(NUMV2.LE.2)SUM2=SUM2+1 IF(NUMV2.GE.3)SUM2=SUM2+YN(ISET) 1810 CONTINUE CTOTAL=SUM1 CBARG=CTOTAL/ANUMSE C J=0 DO1850ISET=1,NUMSET C CI=Y(ISET) SIZEI=YN(ISET) NSIZEI=SIZEI+0.5 IF(NSIZEI.LE.0)GOTO1850 C TAGI=XIDTEM(ISET) C J=J+1 Y2(J)=CI X2(J)=TAGI D2(J)=1.0 C J=J+1 YMID=CBARG Y2(J)=YMID X2(J)=TAGI D2(J)=2.0 C J=J+1 VARCI=0.0 IF(ANI.GT.0.0)VARCI=CBARG SDCI=0.0 IF(VARCI.GT.0.0)SDCI=SQRT(VARCI) YUPPER=YMID+3.0*SDCI Y2(J)=YUPPER X2(J)=TAGI D2(J)=3.0 C J=J+1 YLOWER=YMID-3.0*SDCI IF(YLOWER.LT.0.0)YLOWER=0.0 Y2(J)=YLOWER X2(J)=TAGI D2(J)=4.0 C CCCCC THE FOLLOWING 3 SECTIONS WERE ADDED SEPTEMBER IF(CCTARG.EQ.CPUMIN)GOTO1871 J=J+1 Y2(J)=CCTARG X2(J)=XIDTEM(ISET) D2(J)=5.0 1871 CONTINUE C IF(CCUSL.EQ.CPUMIN)GOTO1872 J=J+1 Y2(J)=CCUSL X2(J)=XIDTEM(ISET) D2(J)=6.0 1872 CONTINUE C IF(CCLSL.EQ.CPUMIN)GOTO1873 J=J+1 Y2(J)=CCLSL X2(J)=XIDTEM(ISET) D2(J)=7.0 1873 CONTINUE C 1850 CONTINUE N2=J NPLOTV=3 GOTO9000 C C ***************************************** C ** STEP 5.9-- ** C ** TREAT THE EXPONETIALLY WEIGHTED ** C ** CONTROL CHART CASE ** C ***************************************** C 1900 CONTINUE C ISTEPN='5.9' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(P.GE.1.0 .AND. P.LE.100.)P=P/100. IF(P.LE.0.0 .OR. P.GE.1.0)THEN WRITE(ICOUT,1901) 1901 FORMAT('***** ERROR: FOR EWMA CONTROL CHARTS, THE WEIGHTING', 1 ' PARAMETER P MUST BE SPECIFIED') CALL DPWRST('XXX','BUG') WRITE(ICOUT,1902) 1902 FORMAT(' AND IN THE RANGE (0,1). IT IS TYPICALLY ', 1 ' BETWEEN 0.1 AND 0.5 .') CALL DPWRST('XXX','BUG') WRITE(ICOUT,1903) 1903 FORMAT(' FOR EXAMPLE: LET P = 0.2 ') CALL DPWRST('XXX','BUG') IERROR='YES' GOTO9000 ENDIF C J=0 IF(CCTARG.NE.CPUMIN)THEN AK0=CCTARG ELSE AK0=XBARG ENDIF YMID=AK0 C DO1910ISET=1,NUMSET C K=0 DO1920I=1,N IF(X(I).EQ.XIDTEM(ISET))K=K+1 IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I) 1920 CONTINUE NI=K ANI=NI C IF(NI.GE.1)GOTO1939 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1931) 1931 FORMAT('***** INTERNAL ERROR IN DPCC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1932) 1932 FORMAT('NI FOR SOME CLASS = 0') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1933)ISET,XIDTEM(ISET),NI 1933 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1939 CONTINUE C SUM=0.0 DO1940I=1,NI SUM=SUM+TEMP(I) 1940 CONTINUE XBARI=SUM/ANI C AK1=P*XBARI + (1.0-P)*AK0 IF(N.NE.NUMSET)THEN SADJ=SIGMAE*3.0902*SQRT(P/(ANI*(2.0-P))) ELSE IF(KWIDTH.LE.25)THEN SADJ=(RANGEM/E2(KWIDTH))*3.0902*SQRT(P/(ANI*(2.0-P))) ELSE SADJ=(RANGEM/E2(25))*3.0902*SQRT(P/(ANI*(2.0-P))) ENDIF ENDIF YUPPER=XBARG+SADJ YLOWER=XBARG-SADJ C IF(IBUGG3.EQ.'OFF')GOTO1969 WRITE(ICOUT,1961)ISET,NI,ANI 1961 FORMAT('ISET,NI,ANI = ',I8,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1962)XBARI 1962 FORMAT('XBARI = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1963)SDI,SIGMAE,SADJ 1963 FORMAT('SDI,SIGMAE,SADJ = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1964)XBARG,AK0,AK1 1964 FORMAT('XBARG,AK0,AK1 = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1965)YLOWER,YUPPER 1965 FORMAT('YLOWER,YUPPER = ',2E15.7) CALL DPWRST('XXX','BUG ') 1969 CONTINUE C J=J+1 Y2(J)=AK1 X2(J)=XIDTEM(ISET) D2(J)=1.0 C J=J+1 Y2(J)=XBARG X2(J)=XIDTEM(ISET) D2(J)=2.0 C J=J+1 Y2(J)=YUPPER X2(J)=XIDTEM(ISET) D2(J)=3.0 C J=J+1 Y2(J)=YLOWER X2(J)=XIDTEM(ISET) D2(J)=4.0 C CCCCC THE FOLLOWING 3 SECTIONS WERE ADDED SEPTEMBER IF(CCTARG.EQ.CPUMIN)GOTO1971 J=J+1 Y2(J)=CCTARG X2(J)=XIDTEM(ISET) D2(J)=5.0 1971 CONTINUE C IF(CCUSL.EQ.CPUMIN)GOTO1972 J=J+1 Y2(J)=CCUSL X2(J)=XIDTEM(ISET) D2(J)=6.0 1972 CONTINUE C IF(CCLSL.EQ.CPUMIN)GOTO1973 J=J+1 Y2(J)=CCLSL X2(J)=XIDTEM(ISET) D2(J)=7.0 1973 CONTINUE C AK0=AK1 C 1910 CONTINUE N2=J NPLOTV=3 GOTO9000 C C ***************************************** C ** STEP 5.10-- ** C ** TREAT THE MOVING AVERAGE ** C ** CONTROL CHART CASE ** C ***************************************** C 2000 CONTINUE C ISTEPN='5.10' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(KWIDTH.LT.2)KWIDTH=2 IF(KWIDTH.GT.N-1)KWIDTH=N-1 AK=REAL(KWIDTH) NBEF=KWIDTH/2 NAFT=NBEF IF(MOD(KWIDTH,2).EQ.0)NAFT=NBEF-1 C J=0 C DO2010ISET=1,NUMSET C K=0 DO2020I=1,N IF(X(I).EQ.XIDTEM(ISET))K=K+1 IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I) 2020 CONTINUE NI=K ANI=NI C IF(NI.GE.1)GOTO2039 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2031) 2031 FORMAT('***** INTERNAL ERROR IN DPCC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2032) 2032 FORMAT('NI FOR SOME CLASS = 0') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2033)ISET,XIDTEM(ISET),NI 2033 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2039 CONTINUE C IF(NI.EQ.1)THEN TEMP2(ISET)=TEMP(1) ELSE SUM=0.0 DO2040I=1,NI SUM=SUM+TEMP(I) 2040 CONTINUE TEMP2(ISET)=SUM/ANI ENDIF C 2010 CONTINUE C IF(IBUGG3.EQ.'OFF')GOTO2069 WRITE(ICOUT,2061)ISET,NI,ANI 2061 FORMAT('ISET,NI,ANI = ',I8,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2062)XBARI 2062 FORMAT('XBARI = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2063)SDI,SIGMAE,SADJ 2063 FORMAT('SDI,SIGMAE,SADJ = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2064)XBARG,AK0,AK1 2064 FORMAT('XBARG,AK0,AK1 = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2065)YLOWER,YUPPER 2065 FORMAT('YLOWER,YUPPER = ',2E15.7) CALL DPWRST('XXX','BUG ') 2069 CONTINUE C IF(1+NBEF.GT.NUMSET-NAFT)THEN WRITE(ICOUT,2085)KWIDTH,NUMSET CALL DPWRST('XXX','BUG') IERROR='YES' GOTO9000 ENDIF 2085 FORMAT( 1'***** ERROR: THERE ARE NOT ENOUGH GROUPS TO FORM THE MOVING', 1/, 1' AVERAGE PLOT. THE FILTER WIDTH IS ',I5,' AND THE ',/, 1' NUMBER OF GROUPS IS ',I5,' .') C DO2090ISET=1,NUMSET C SUM=0.0 IF(ISET.LT.1+NBEF)THEN DO2092II=1,ISET+NAFT SUM=SUM+TEMP2(II) 2092 CONTINUE YVAL=SUM/REAL(ISET+NAFT) ELSEIF(ISET.GT.NUMSET-NAFT)THEN DO2094II=ISET-NBEF,NUMSET SUM=SUM+TEMP2(II) 2094 CONTINUE YVAL=SUM/REAL(NUMSET-(ISET-NBEF)+1) ELSE DO2096II=ISET-NBEF,ISET+NAFT SUM=SUM+TEMP2(II) 2096 CONTINUE YVAL=SUM/REAL(KWIDTH) ENDIF J=J+1 Y2(J)=YVAL XVAL=XIDTEM(ISET) IF(NBEF.NE.NAFT)THEN IF(ISET.GT.1)THEN XVAL=(XIDTEM(ISET)+XIDTEM(ISET-1))/2.0 ELSE XVAL=XIDTEM(1) ENDIF ENDIF X2(J)=XVAL D2(J)=1.0 C J=J+1 Y2(J)=XBARG X2(J)=XVAL D2(J)=2.0 C IF(N.NE.NUMSET)THEN YUPPER=XBARG+3.09*SIGMAE/SQRT(AK) YLOWER=XBARG-3.09*SIGMAE/SQRT(AK) ELSE IF(KWIDTH.LE.25)THEN YUPPER=XBARG+3.09*RANGEM/(E2(KWIDTH)*SQRT(AK)) YLOWER=XBARG-3.09*RANGEM/(E2(KWIDTH)*SQRT(AK)) ELSE YUPPER=XBARG+3.09*RANGEM/(E2(25)*SQRT(AK)) YLOWER=XBARG-3.09*RANGEM/(E2(25)*SQRT(AK)) ENDIF ENDIF C J=J+1 Y2(J)=YUPPER X2(J)=XVAL D2(J)=3.0 C J=J+1 Y2(J)=YLOWER X2(J)=XVAL D2(J)=4.0 C CCCCC THE FOLLOWING 3 SECTIONS WERE ADDED SEPTEMBER IF(CCTARG.EQ.CPUMIN)GOTO2071 J=J+1 Y2(J)=CCTARG X2(J)=XVAL D2(J)=5.0 2071 CONTINUE C IF(CCUSL.EQ.CPUMIN)GOTO2072 J=J+1 Y2(J)=CCUSL X2(J)=XVAL D2(J)=6.0 2072 CONTINUE C IF(CCLSL.EQ.CPUMIN)GOTO2073 J=J+1 Y2(J)=CCLSL X2(J)=XVAL D2(J)=7.0 2073 CONTINUE C 2090 CONTINUE N2=J NPLOTV=3 GOTO9000 C C ***************************************** C ** STEP 5.11-- ** C ** TREAT THE MOVING RANGE ** C ** CONTROL CHART CASE ** C ***************************************** C 2100 CONTINUE C ISTEPN='5.11' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(KWIDTH.LT.2)KWIDTH=2 IF(KWIDTH.GT.N-1)KWIDTH=N-1 AK=REAL(KWIDTH) NBEF=KWIDTH/2 NAFT=NBEF IF(MOD(KWIDTH,2).EQ.0)NAFT=NBEF-1 C J=0 C C 2 CASES: C 1) UNGROUPED DATA (N=NUMSET) C 2) GROUPED DATA (N> NUMSET). FOR GROUPED DATA, EACH GROUP C SHOULD HAVE AT LEAST 2 VALUES. C C UNGROUPED CASE C IF(N.EQ.NUMSET)THEN DO2102ISET=1,N TEMP2(ISET)=Y(ISET) 2102 CONTINUE GOTO2119 ENDIF C C GROUPED CASE C DO2110ISET=1,NUMSET C K=0 DO2120I=1,N IF(X(I).EQ.XIDTEM(ISET))K=K+1 IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I) 2120 CONTINUE NI=K ANI=NI C IF(NI.GE.1)GOTO2139 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2131) 2131 FORMAT('***** INTERNAL ERROR IN DPCC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2132) 2132 FORMAT('NI FOR SOME CLASS = 0') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2133)ISET,XIDTEM(ISET),NI 2133 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2139 CONTINUE C XTMIN=TEMP(1) XTMAX=TEMP(1) DO2140I=1,NI IF(TEMP(I).LT.XTMIN)XTMIN=TEMP(I) IF(TEMP(I).GT.XTMAX)XTMAX=TEMP(I) 2140 CONTINUE C TEMP2(ISET)=XTMAX-XTMIN C 2110 CONTINUE 2119 CONTINUE C IF(IBUGG3.EQ.'OFF')GOTO2169 WRITE(ICOUT,2161)ISET,NI,ANI 2161 FORMAT('ISET,NI,ANI = ',I8,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2162)XBARI 2162 FORMAT('XBARI = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2163)SDI,SIGMAE,SADJ 2163 FORMAT('SDI,SIGMAE,SADJ = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2164)XBARG,AK0,AK1 2164 FORMAT('XBARG,AK0,AK1 = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2165)YLOWER,YUPPER 2165 FORMAT('YLOWER,YUPPER = ',2E15.7) CALL DPWRST('XXX','BUG ') 2169 CONTINUE C IF(1+NBEF.GT.NUMSET-NAFT)THEN WRITE(ICOUT,2168)KWIDTH,NUMSET CALL DPWRST('XXX','BUG') IERROR='YES' GOTO9000 ENDIF 2168 FORMAT( 1'***** ERROR: THERE ARE NOT ENOUGH GROUPS TO FORM THE MOVING', 1/, 1' RANGE PLOT. THE FILTER WIDTH IS ',I5,' AND THE ',/, 1' NUMBER OF GROUPS IS ',I5,' .') C SUM2=0.0 NUMRAN=0 DO2190ISET=1,NUMSET C C GROUPED DATA C IF(N.NE.NUMSET)THEN SUM=0.0 IF(ISET.LT.1+NBEF)THEN DO2192II=1,ISET+NAFT SUM=SUM+TEMP2(II) 2192 CONTINUE YVAL=SUM/REAL(ISET+NAFT) ELSEIF(ISET.GT.NUMSET-NAFT)THEN DO2194II=ISET-NBEF,NUMSET SUM=SUM+TEMP2(II) 2194 CONTINUE YVAL=SUM/REAL(NUMSET-(ISET-NBEF)+1) ELSE DO2196II=ISET-NBEF,ISET+NAFT SUM=SUM+TEMP2(II) 2196 CONTINUE YVAL=SUM/AK ENDIF C J=J+1 Y2(J)=YVAL C C UNGROUPED DATA C ELSE IF(ISET.LT.1+NBEF)THEN XTMIN=TEMP2(1) XTMMAX=TEMP2(1) DO2182II=1,ISET+NAFT IF(TEMP2(II).LT.XTMIN)XTMIN=TEMP2(II) IF(TEMP2(II).GT.XTMAX)XTMAX=TEMP2(II) 2182 CONTINUE YVAL=XTMAX-XTMIN ELSEIF(ISET.GT.NUMSET-NAFT)THEN XTMIN=TEMP2(ISET-NBEF) XTMMAX=TEMP2(ISET-NBEF) DO2184II=ISET-NBEF,NUMSET IF(TEMP2(II).LT.XTMIN)XTMIN=TEMP2(II) IF(TEMP2(II).GT.XTMAX)XTMAX=TEMP2(II) 2184 CONTINUE YVAL=XTMAX-XTMIN ELSE XTMIN=TEMP2(ISET-NBEF) XTMMAX=TEMP2(ISET-NBEF) DO2186II=ISET-NBEF,ISET+NAFT IF(TEMP2(II).LT.XTMIN)XTMIN=TEMP2(II) IF(TEMP2(II).GT.XTMAX)XTMAX=TEMP2(II) 2186 CONTINUE YVAL=XTMAX-XTMIN ENDIF C J=J+1 Y2(J)=YVAL ENDIF XVAL=XIDTEM(ISET) IF(NBEF.NE.NAFT)XVAL=(XIDTEM(ISET)+XIDTEM(ISET-1))/2.0 X2(J)=XVAL D2(J)=1.0 C IF(KWIDTH.LE.25)THEN YUPPER=D4(KWIDTH)*RANGEM YLOWER=D3(KWIDTH)*RANGEM ELSE YUPPER=(1.0+3.0*D4FACT/SQRT(2.0*(REAL(KWIDTH)-1.0)))*RANGEM 1 /E2(25) YLOWER=(1.0-3.0*D3FACT/SQRT(2.0*(REAL(KWIDTH)-1.0)))*RANGEM 1 /E2(25) ENDIF IF(YLOWER.LT.0.0)YLOWER=0.0 C J=J+1 Y2(J)=RANGEM X2(J)=XVAL D2(J)=2.0 C J=J+1 Y2(J)=YUPPER X2(J)=XVAL D2(J)=3.0 C J=J+1 Y2(J)=YLOWER X2(J)=XVAL D2(J)=4.0 C CCCCC THE FOLLOWING 3 SECTIONS WERE ADDED SEPTEMBER IF(CCTARG.EQ.CPUMIN)GOTO2171 J=J+1 Y2(J)=CCTARG X2(J)=XVAL D2(J)=5.0 2171 CONTINUE C IF(CCUSL.EQ.CPUMIN)GOTO2172 J=J+1 Y2(J)=CCUSL X2(J)=XVAL D2(J)=6.0 2172 CONTINUE C IF(CCLSL.EQ.CPUMIN)GOTO2173 J=J+1 Y2(J)=CCLSL X2(J)=XVAL D2(J)=7.0 2173 CONTINUE C 2190 CONTINUE N2=J NPLOTV=3 GOTO9000 C C ***************************************** C ** STEP 5.12-- ** C ** TREAT THE MOVING STANDARD DEVIATION** C ** CONTROL CHART CASE ** C ***************************************** C 2200 CONTINUE C ISTEPN='5.12' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(KWIDTH.LT.2)KWIDTH=2 IF(KWIDTH.GT.N-1)KWIDTH=N-1 AK=REAL(KWIDTH) NBEF=KWIDTH/2 NAFT=NBEF IF(MOD(KWIDTH,2).EQ.0)NAFT=NBEF-1 C J=0 C C 2 CASES: C 1) UNGROUPED DATA (N=NUMSET) C 2) GROUPED DATA (N> NUMSET). FOR GROUPED DATA, EACH GROUP C SHOULD HAVE AT LEAST 2 VALUES. C C UNGROUPED CASE C IF(N.EQ.NUMSET)THEN DO2202ISET=1,N TEMP2(ISET)=Y(ISET) 2202 CONTINUE GOTO2219 ENDIF C C GROUPED CASE C DO2210ISET=1,NUMSET C K=0 DO2220I=1,N IF(X(I).EQ.XIDTEM(ISET))K=K+1 IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I) 2220 CONTINUE NI=K ANI=NI C IF(NI.GE.2)GOTO2239 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2231) 2231 FORMAT('***** ERROR IN DPCC2 FOR MOVING STANDARD DEVIATION', 1' CONTROL CHART--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2232) 2232 FORMAT('NI FOR SOME CLASS <= 1') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2233)ISET,XIDTEM(ISET),NI 2233 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2239 CONTINUE C SUM1=0.0 DO2240I=1,NI SUM1=SUM1+TEMP(I) 2240 CONTINUE XMEAN=SUM1/ANI SUM1=0.0 DO2242I=1,NI SUM1=SUM1+(TEMP(I)-XMEAN)**2 2242 CONTINUE SD=SQRT(SUM1/(ANI-1.0)) C TEMP2(ISET)=SD C 2210 CONTINUE 2219 CONTINUE C IF(IBUGG3.EQ.'OFF')GOTO2269 WRITE(ICOUT,2261)ISET,NI,ANI 2261 FORMAT('ISET,NI,ANI = ',I8,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2262)XBARI 2262 FORMAT('XBARI = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2263)SDI,SIGMAE,SADJ 2263 FORMAT('SDI,SIGMAE,SADJ = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2264)XBARG,AK0,AK1 2264 FORMAT('XBARG,AK0,AK1 = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2265)YLOWER,YUPPER 2265 FORMAT('YLOWER,YUPPER = ',2E15.7) CALL DPWRST('XXX','BUG ') 2269 CONTINUE C IF(1+NBEF.GT.NUMSET-NAFT)THEN WRITE(ICOUT,2268)KWIDTH,NUMSET CALL DPWRST('XXX','BUG') IERROR='YES' GOTO9000 ENDIF 2268 FORMAT( 1'***** ERROR: THERE ARE NOT ENOUGH GROUPS TO FORM THE MOVING', 1/, 1' STANDARD DEVIATION PLOT. THE FILTER WIDTH IS ',I5, 1' AND THE NUMBER OF GROUPS IS ',I5,' .') C SUM2=0.0 NUMSD=0 DO2290ISET=1,NUMSET C C GROUPED DATA C IF(N.NE.NUMSET)THEN SUM=0.0 IF(ISET.LT.1+NBEF)THEN DO2292II=1,ISET+NAFT SUM=SUM+TEMP2(II) 2292 CONTINUE YVAL=SUM/REAL(ISET+NAFT) ELSEIF(ISET.GT.NUMSET-NAFT)THEN DO2294II=ISET-NBEF,NUMSET SUM=SUM+TEMP2(II) 2294 CONTINUE YVAL=SUM/REAL(NUMSET-(ISET-NBEF)+1) ELSE DO2296II=ISET-NBEF,ISET+NAFT SUM=SUM+TEMP2(II) 2296 CONTINUE YVAL=SUM/AK ENDIF C J=J+1 Y2(J)=YVAL C C UNGROUPED DATA C ELSE IF(ISET.LT.1+NBEF)THEN SUM1=0.0 ICOUNT=0 DO2282II=1,ISET+NAFT ICOUNT=ICOUNT+1 SUM1=SUM1+TEMP2(II) 2282 CONTINUE XMEAN=SUM1/REAL(ICOUNT) SUM1=0.0 DO2283II=1,ISET+NAFT SUM1=SUM1+(TEMP2(II)-XMEAN)**2 2283 CONTINUE IF(ICOUNT.LT.2)GOTO2290 YVAL=SQRT(SUM1/REAL(ICOUNT-1)) ELSEIF(ISET.GT.NUMSET-NAFT)THEN SUM1=0.0 ICOUNT=0 DO2284II=ISET-NBEF,NUMSET ICOUNT=ICOUNT+1 SUM1=SUM1+TEMP2(II) 2284 CONTINUE XMEAN=SUM1/REAL(ICOUNT) SUM1=0.0 DO2285II=ISET-NBEF,NUMSET SUM1=SUM1+(TEMP2(II)-XMEAN)**2 2285 CONTINUE IF(ICOUNT.LT.2)GOTO2290 YVAL=SQRT(SUM1/REAL(ICOUNT-1)) ELSE SUM1=0.0 ICOUNT=0 DO2286II=ISET-NBEF,ISET+NAFT ICOUNT=ICOUNT+1 SUM1=SUM1+TEMP2(II) 2286 CONTINUE XMEAN=SUM1/REAL(ICOUNT) SUM1=0.0 DO2287II=ISET-NBEF,ISET+NAFT SUM1=SUM1+(TEMP2(II)-XMEAN)**2 2287 CONTINUE YVAL=SQRT(SUM1/REAL(ICOUNT-1)) ENDIF C J=J+1 Y2(J)=YVAL ENDIF XVAL=XIDTEM(ISET) IF(NBEF.NE.NAFT)XVAL=(XIDTEM(ISET)+XIDTEM(ISET-1))/2.0 X2(J)=XVAL D2(J)=1.0 C IF(KWIDTH.LE.25)THEN YUPPER=B4(KWIDTH)*SDM YLOWER=B3(KWIDTH)*SDM ELSE YUPPER=(1.0+3.0/SQRT(2.0*(REAL(KWIDTH)-1.0)))*SDM YLOWER=(1.0-3.0/SQRT(2.0*(REAL(KWIDTH)-1.0)))*SDM ENDIF IF(YLOWER.LT.0.0)YLOWER=0.0 C J=J+1 Y2(J)=SDM X2(J)=XVAL D2(J)=2.0 C J=J+1 Y2(J)=YUPPER X2(J)=XVAL D2(J)=3.0 C J=J+1 Y2(J)=YLOWER X2(J)=XVAL D2(J)=4.0 C CCCCC THE FOLLOWING 3 SECTIONS WERE ADDED SEPTEMBER IF(CCTARG.EQ.CPUMIN)GOTO2271 J=J+1 Y2(J)=CCTARG X2(J)=XVAL D2(J)=5.0 2271 CONTINUE C IF(CCUSL.EQ.CPUMIN)GOTO2272 J=J+1 Y2(J)=CCUSL X2(J)=XVAL D2(J)=6.0 2272 CONTINUE C IF(CCLSL.EQ.CPUMIN)GOTO2273 J=J+1 Y2(J)=CCLSL X2(J)=XVAL D2(J)=7.0 2273 CONTINUE C 2290 CONTINUE N2=J NPLOTV=3 GOTO9000 C C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPCC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,N,NUMSET,N2,IERROR 9012 FORMAT('ICASPL,N,NUMSET,N2,IERROR = ',A4,3I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NUMV2,ISIZE 9013 FORMAT('NUMV2,ISIZE = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)AN,XBARG,SDG,RANGEG 9014 FORMAT('AN,XBARG,SDG,RANGEG = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)ANUMSE,SIGMAE,RANGEE 9015 FORMAT('ANUMSE,SIGMAE,RANGEE = ',3E15.7) CALL DPWRST('XXX','BUG ') DO9020I=1,N2 WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I) 9021 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9020 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPCD(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IANGLU,DEMOFR,DEMODF,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE ONE OF THE FOLLOWING 2 C COMPLEX DEMODULATION PLOTS-- C 1) AMPLITUDE; C 2) PHASE; C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--JUNE 1978. C UPDATED --JULY 1981. C UPDATED --JANUARY 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IANGLU CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),Y1(1)) CCCCC END CHANGE C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA PI/3.141592653/ C C-----START POINT----------------------------------------------------- C IERROR='NO' C ISUBN1='DPCD' ISUBN2=' ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=1 MINN2=2 C C *********************************************** C ** TREAT THE COMPLEX DEMODULATION CASE ** C *********************************************** C IF(IBUGG2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPCD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICASPL,IAND1,IAND2 52 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ 53 FORMAT('IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.GE.3.AND. 1ICOM.EQ.'COMP'.AND.IHARG(1).EQ.'DEMO'.AND.IHARG(2).EQ.'AMPL'.AND. 1IHARG(3).EQ.'PLOT')GOTO110 C IF(NUMARG.GE.3.AND. 1ICOM.EQ.'COMP'.AND.IHARG(1).EQ.'DEMO'.AND.IHARG(2).EQ.'PHAS'.AND. 1IHARG(3).EQ.'PLOT')GOTO120 C IFOUND='NO' GOTO9000 C 110 CONTINUE ICASPL='CDAM' ILASTC=3 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 120 CONTINUE ICASPL='CDPH' ILASTC=3 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 180 CONTINUE IFOUND='YES' GOTO190 C 190 CONTINUE C C *********************************************************** C ** STEP 1-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C *********************************************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ******************************************** C ** STEP 2-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='2' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(1) IHLEF2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,211)IHLEFT,ICOLL,NLEFT 211 FORMAT('IHLEFT,ICOLL,NLEFT = ',A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') C C *************************************************************** C ** STEP 3-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS POSITIVE. ** C *************************************************************** C ISTEPN='3' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO390 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPCD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312) 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'CDAM')WRITE(ICOUT,321) 321 FORMAT(' (FOR WHICH A COMPLEX DEMODULATION ', 1'AMPLITUDE PLOT ') IF(ICASPL.EQ.'CDAM')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'CDPH')WRITE(ICOUT,322) 322 FORMAT(' (FOR WHICH A COMPLEX DEMODULATION ', 1'PHASE PLOT ') IF(ICASPL.EQ.'CDPH')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' WAS TO HAVE BEEN FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)MINN2 315 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,316) 316 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,317) 317 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,318)(IANS(I),I=1,IWIDTH) 318 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 390 CONTINUE C C ***************************************** C ** STEP 4-- ** C ** CHECK TO SEE THE TYPE SUBCASE ** C ** (BASED ON THE QUALIFIER)-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='4' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO480 DO400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO420 400 CONTINUE GOTO490 410 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO490 420 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO490 C 480 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,481) 481 FORMAT('***** INTERNAL ERROR IN DPCD') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,482) 482 FORMAT(' AT BRANCH POINT 481--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,483) 483 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,484) 484 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,485)NUMARG 485 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,486) 486 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,487)(IANS(I),I=1,IWIDTH) 487 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 490 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ,ICASEQ 491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C ********************************************* C ** STEP 5-- ** C ** CHECK FOR PROPER NUMBER OF VARIABLES. ** C ** FOR A COMPLEX DEMODULATION PLOT, ** C ** THE PROPER NUMBER OF VARIABLES IS ** C ** EXACTLY 1. ** C ********************************************* C ISTEPN='5' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IF(NUMV2.EQ.1)GOTO590 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,551) 551 FORMAT('***** ERROR IN DPCD--') CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'CDAM')WRITE(ICOUT,552) 552 FORMAT(' FOR A COMPLEX DEMODULATION ', 1'AMPLITUDE PLOT,') IF(ICASPL.EQ.'CDAM')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'CDPH')WRITE(ICOUT,553) 553 FORMAT(' FOR A COMPLEX DEMODULATION ', 1'PHASE PLOT,') IF(ICASPL.EQ.'CDPH')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,558) 558 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) 559 FORMAT(' MUST BE EXACTLY 1 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,560) 560 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,561) 561 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,562)NUMV2 562 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,563) 563 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,564)(IANS(I),I=1,IWIDTH) 564 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 590 CONTINUE C C ************************************************* C ** STEP 6-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** (BASED ON THE QUALIFIER) ** C ** THEN FORM THE RESPONSE VARIABLE ** C ** AND THE SECOND VARIABLE (IF EXISTENT) ** C ************************************************* C ISTEPN='6' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO610 IF(ICASEQ.EQ.'SUBS')GOTO620 IF(ICASEQ.EQ.'FOR')GOTO630 C 610 CONTINUE DO615I=1,NLEFT ISUB(I)=1 615 CONTINUE NQ=NLEFT GOTO650 C 620 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO650 C 630 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO650 C 650 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO660I=1,IMAX IF(ISUB(I).EQ.0)GOTO660 J=J+1 IJ=MAXN*(ICOLL-1)+I IF(ICOLL.LE.MAXCOL)Y1(J)=V(IJ) IF(ICOLL.EQ.MAXCP1)Y1(J)=PRED(I) IF(ICOLL.EQ.MAXCP2)Y1(J)=RES(I) IF(ICOLL.EQ.MAXCP3)Y1(J)=YPLOT(I) IF(ICOLL.EQ.MAXCP4)Y1(J)=XPLOT(I) IF(ICOLL.EQ.MAXCP5)Y1(J)=X2PLOT(I) IF(ICOLL.EQ.MAXCP6)Y1(J)=TAGPLO(I) 660 CONTINUE NLOCAL=J C C *********************************************************** C ** STEP 7-- ** C ** DETERMINE IF THE ANALYST ** C ** HAS SPECIFIED THE DEMODULATION FREQUENCY ** C ** FOR THE COMPLEX DEMODULATION ANALYSIS. ** C ** THE FREQUENCY SETTING IS DEFINED BY PRE-USE ** C ** OF THE DEMODULATION FREQUENCY COMMAND. ** C ** IF FOUND, USE THE SPECIFIED VALUE. ** C ** IF NOT FOUND, GENERATE AN ERROR MESSAGE. ** C *********************************************************** C ISTEPN='7' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DEMOF2=DEMOFR IF(IANGLU.EQ.'DEGR')DEMOF2=DEMOF2*PI/180.0 IF(IANGLU.EQ.'GRAD')DEMOF2=DEMOF2*PI/200.0 IF(0.0.LT.DEMOF2.AND.DEMOF2.LT.0.5)GOTO790 C 740 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,741) 741 FORMAT('****** ERROR IN DPCD--') CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'CDAM')WRITE(ICOUT,742) 742 FORMAT(' FOR A COMPLEX DEMODULATION ', 1'AMPLITUDE PLOT,') IF(ICASPL.EQ.'CDAM')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'CDPH')WRITE(ICOUT,743) 743 FORMAT(' FOR A COMPLEX DEMODULATION ', 1'PHASE PLOT,') IF(ICASPL.EQ.'CDPH')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,744) 744 FORMAT(' THE FREQUENCY AT WHICH THE DEMODULATION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,745) 745 FORMAT(' IS TO BE PERFORMED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,746) 746 FORMAT(' MUST BE PRE-SPECIFIED BY THE ANALYST,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,747) 747 FORMAT(' AND MUST BE BETWEEN 0 AND 0.5 RADIANS;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,748) 748 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,749)DEMOFR,IANGLU 749 FORMAT(' THE DEMODULATION FREQUENCY = ',E15.7,2X,A4) CALL DPWRST('XXX','BUG ') IF(IANGLU.NE.'RADI')WRITE(ICOUT,750)DEMOF2 750 FORMAT(' THE DEMODULATION FREQUENCY = ',E15.7,2X, 1'RADIANS') IF(IANGLU.NE.'RADI')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,751) 751 FORMAT(' TO DEFINE THE DEMODULATION FREQUENCY,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,752) 752 FORMAT(' THE ANALYST USES THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,753) 753 FORMAT(' DEMODULATION FREQUENCY COMMAND, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,754) 754 FORMAT(' DEMODULATION FREQUENCY 0.3') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,755) 755 FORMAT(' DEMODULATION FREQUENCY 0.155') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 790 CONTINUE C C **************************************************************** C ** STEP 8-- * C ** COMPUTE THE APPROPRIATE COMPLEX DEMODULATION * C ** PLOT (AMPLITUDE OR PHASE). * C ** FORM THE VERTICAL AND HORIZONTAL AXIS * C ** VALUES Y(.) AND X(.) FOR THE PLOT. * C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). * C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). * C **************************************************************** C ISTEPN='8' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPCD2(Y1,NLEFT,ICASPL,DEMOF2,DEMODF, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPHIST--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)DEMOFR,IANGLU,DEMOF2 9014 FORMAT('DEMOFR,IANGLU,DEMOF2 = ',E15.7,2X,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') IF(NPLOTP.LE.0)GOTO9090 DO9015I=1,NPLOTP WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPCD2(Y,N,ICASPL,F,DEMODF, 1Y2,X2,D2,N2,NPLOTV,IBUGG3,IERROR) C C PURPOSE--THIS SUBROUTINE PERFORMS A COMPLEX DEMODULATION C ON THE DATA IN THE INPUT VECTOR X C AT THE INPUT DEMODULATION FREQUENCY = F. C THE COMPLEX DEMODULATION CONSISTS OF THE FOLLOWING-- C 1) AN AMPLITUDE VERSUS TIME PLOT; C 2) A PHASE VERSUS TIME PLOT; C 3) AN UPDATED DEMODULATION FREQUENCY ESTIMATE C TO ASSIST THE ANALYST IN DETERMINING A C MORE APPROPRIATE FREQUENCY AT WHICH C TO DEMODULATE IN CASE THE SPECIFIED C INPUT DEMODULATION FREQUENCY F C DOES NOT FLATTEN SUFFICIENTLY THE C PHASE PLOT. C C THE ALLOWABLE RANGE OF THE INPUT DEMODULATION C FREQUENCY F IS 0.0 TO 0.5 (EXCLUSIVELY). C THE INPUT DEMODULATION FREQUENCY F IS MEASURED OF C IN UNITS OF CYCLES PER 'DATA POINT' OR, C MORE PRECISELY, IN CYCLES PER UNIT TIME WHERE C 'UNIT TIME' IS DEFINED AS THE C ELAPSED TIME BETWEEN ADJACENT OBSERVATIONS. C C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR OF C (UNSORTED) OBSERVATIONS. C N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C FREQ = THE SINGLE PRECISION C DEMODULATION FREQUENCY. C F IS IN UNITS OF CYCLES PER DATA POINT. C F IS BETWEEN 0.0 AND 0.5 (EXCLUSIVELY). C OUTPUT--2 PAGES OF AUTOMATIC PRINTOUT-- C 1) AN AMPLITUDE PLOT; C 2) A PHASE PLOT; AND C 3) AN UPDATED DEMODULATION FREQUENCY ESTIMATE. C PRINTING--YES. C RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N C FOR THIS SUBROUTINE IS 5000. C --THE SAMPLE SIZE N MUST BE GREATER C THAN OR EQUAL TO 3. C --THE INPUT FREQUENCY F MUST BE C GREATER THAN OR EQUAL TO 2/(N-2). C --THE INPUT FREQUENCY F MUST BE C SMALLER THAN 0.5. C OTHER DATAPAC SUBROUTINES NEEDED--PLOTX. C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, SIN, COS, ATAN. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--IN ORDER THAT THE RESULTS OF THE COMPLEX DEMODULATION C BE VALID AND PROPERLY INTERPRETED, THE INPUT DATA C IN X SHOULD BE EQUI-SPACED IN TIME C (OR WHATEVER VARIABLE CORRESPONDS TO TIME). C --IF THE INPUT OBSERVATIONS IN X ARE CONSIDERED C TO HAVE BEEN COLLECTED 1 SECOND APART IN TIME, C THEN THE DEMODULATION FREQUENCY F C WOULD BE IN UNITS OF HERTZ C (= CYCLES PER SECOND). C --A FREQUENCY OF 0.0 CORRESPONDS TO A CYCLE C IN THE DATA OF INFINITE (= 1/(0.0)) C LENGTH OR PERIOD. C A FREQUENCY OF 0.5 CORRESPONDS TO A CYCLE C IN THE DATA OF LENGTH = 1/(0.5) = 2 DATA POINTS. C --IN EXAMINING THE AMPLITUDE AND PHASE PLOTS, C ATTENTION SHOULD BE PAID NOT ONLY TO THE C STRUCTURE OF THE PHASE PLOT C (NEAR-ZERO SLOPE VERSUS NON-ZERO SLOPE) C BUT ALSO TO THE RANGE C OF VALUES ON THE VERTICAL AXIS. C A PLOT WITH MUCH STRUCTURE BUT C WITH A SMALL RANGE ON THE VERTICAL AXIS C IS USUALLY MORE INDICATIVE OF A C DEFINITE CYCLIC COMPONENT AT THE C SPECIFIED INPUT DEMODULATION FREQUENCY, C THAN IS A PLOT WITH LESS STRUCTURE BUT C A WIDER RANGE ON THE VERTICAL AXIS. C --INTERNAL TO THIS SUBROUTINE, 2 MOVING C AVERAGES ARE APPLIED, EACH OF LENGTH 1/F. C HENCE THE AMPLITUDE AND PHASE PLOTS C HAVE N - 2/F VALUES C (RATHER THAN N VALUES) ALONG THE C HORIZONTAL (TIME) AXIS. C IN ORDER THAT THE AMPLITUDE AND PHASE C PLOTS BE NON-EMPTY, AN INPUT C REQUIREMENT ON F FOR THIS SUBROUTINE C IS THAT THE SAMPLE SIZE N C AND THE DEMODULATION FREQUENCY F C MUST BE SUCH THAT C N - 2/F BE GREATER THAN ZERO. C FURTHER, SINCE A PLOT WITH BUT C 1 POINT IS MEANINGLESS C AND OUGHT ALSO BE EXCLUDED, C THE REQUIREMENT IS EXTENDED C SO THAT N - 2/F MUST BE GREATER THAN 1. C REFERENCES--GRANGER AND HATANAKA, PAGES 170 TO 189, C ESPECIALLY PAGES 173, 177, AND 182. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82/7 C ORIGINAL VERSION--NOVEMBER 1972. C UPDATED --NOVEMBER 1975. C UPDATED --FEBRUARY 1976. C UPDATED --JUNE 1978. C UPDATED --JANUARY 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y(*) C DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA PI/3.141592653/ C C-----START POINT----------------------------------------------------- C ISUBN1='DPCD' ISUBN2='2 ' C IF(IBUGG3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPCD2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N,ICASPL 52 FORMAT('N,ICASPL = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C ILOWER=3 IUPPER=MAXOBV AN=N FMIN=2.0/(AN-2.0) C C ******************************************** C ** STEP 0-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.LT.ILOWER.OR.N.GT.IUPPER)GOTO50 IF(F.LE.FMIN.OR.F.GE.0.5)GOTO60 HOLD=Y(1) DO65I=2,N IF(Y(I).NE.HOLD)GOTO95 65 CONTINUE WRITE(ICOUT, 9)HOLD CALL DPWRST('XXX','BUG ') GOTO9000 50 WRITE(ICOUT,17)ILOWER,IUPPER CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 60 WRITE(ICOUT,27)FMIN CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)F CALL DPWRST('XXX','BUG ') WRITE(ICOUT,28)FMIN,N CALL DPWRST('XXX','BUG ') GOTO9000 95 CONTINUE 9 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUME', 1'NT (A VECTOR) TO THE DPCD2 SUBROUTINE HAS ALL ELEMENTS = ', 1E15.8) 17 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'DPCD2 SUBROUTINE IS OUTSIDE THE ALLOWABLE (',I6,',',I6,') ', 1'INTERVAL') 27 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1'DPCD2 SUBROUTINE IS OUTSIDE THE ALLOWABLE (',I6,'0.5) ', 1'INTERVAL') 28 FORMAT(' THE ABOVE LOWER LIMIT (',F10.8, 1') = 2/(N-2) WHERE N = THE INPUT SAMPLE SIZE = ',I8) 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C C ****************************** C ** STEP 1-- ** C ** FORM THE COSINE SERIES ** C ****************************** C DO100I=1,N AI=I Y2(I)=Y(I)*COS(2.0*PI*F*AI) 100 CONTINUE C C DEFINE THE LENGTH OF THE 2 MOVING AVERAGES C LENMA1=1.0/F LENMA2=1.0/F ALEN1=LENMA1 ALEN2=LENMA2 IMAX1=N-LENMA1 IMAX2=IMAX1-LENMA2 C C *********************************************************** C ** STEP 2-- ** C ** FORM THE FIRST MOVING AVERAGE FOR THE COSINE SERIES ** C *********************************************************** C DO200I=1,IMAX1 ISTART=I+1 IEND=I+LENMA1-1 IENDP1=I+LENMA1 SUM=0.0 DO300J=ISTART,IEND SUM=SUM+Y2(J) 300 CONTINUE SUM=SUM+Y2(I)/2.0+Y2(IENDP1)/2.0 D2(I)=SUM/ALEN1 200 CONTINUE C C ************************************************************ C ** STEP 3-- ** C ** FORM THE SECOND MOVING AVERAGE FOR THE COSINE SERIES ** C ************************************************************ C DO400I=1,IMAX2 ISTART=I+1 IEND=I+LENMA2-1 IENDP1=I+LENMA2 SUM=0.0 DO500J=ISTART,IEND SUM=SUM+D2(J) 500 CONTINUE SUM=SUM+D2(I)/2.0+D2(IENDP1)/2.0 Y2(I)=SUM/ALEN2 400 CONTINUE C C **************************** C ** STEP 4-- ** C ** FORM THE SINE SERIES ** C **************************** C DO700I=1,N AI=I X2(I)=Y(I)*SIN(2.0*PI*F*AI) 700 CONTINUE C C ********************************************************* C ** STEP 5-- ** C ** FORM THE FIRST MOVING AVERAGE FOR THE SINE SERIES ** C ********************************************************* C DO800I=1,IMAX1 ISTART=I+1 IEND=I+LENMA1-1 IENDP1=I+LENMA1 SUM=0.0 DO900J=ISTART,IEND SUM=SUM+X2(J) 900 CONTINUE SUM=SUM+X2(I)/2.0+X2(IENDP1)/2.0 D2(I)=SUM/ALEN1 800 CONTINUE C C ********************************************************** C ** STEP 6-- ** C ** FORM THE SECOND MOVING AVERAGE FOR THE SINE SERIES ** C ********************************************************** C DO1000I=1,IMAX2 ISTART=I+1 IEND=I+LENMA1-1 IENDP1=I+LENMA1 SUM=0.0 DO1100J=ISTART,IEND SUM=SUM+D2(J) 1100 CONTINUE SUM=SUM+D2(I)/2.0+D2(IENDP1)/2.0 X2(I)=SUM/ALEN2 1000 CONTINUE C C CHECK FOR DESIRED CASE C AND BRANCH ACCORDINGLY. C IF(ICASPL.EQ.'CDAM')GOTO1400 IF(ICASPL.EQ.'CDPH')GOTO1700 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1311) 1311 FORMAT('***** INTERNAL ERROR IN DPCD2 ', 1'AT BRANCH POINT 1311--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1312) 1312 FORMAT(' ICASPL SHOULD BE EITHER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1313) 1313 FORMAT(' CDAM OR CDPH, BUT IS NEITHER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1314)ICASPL 1314 FORMAT(' ICASPL = ',A4) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C C ***************************************** C ** STEP 7-- ** C ** FORM THE AMPLITUDES AND PLOT THEM ** C ***************************************** C 1400 CONTINUE DO1450I=1,IMAX2 Y2(I)=2.0*SQRT(Y2(I)*Y2(I)+X2(I)*X2(I)) X2(I)=I D2(I)=1.0 1450 CONTINUE N2=IMAX2 NPLOTV=2 CCCCC WRITE(ICOUT,1451)F C1451 FORMAT(30X, 48HAMPLITUDE PLOT FOR THE DEMODULATION FREQUENCY = CCCCC1 ,F8.6,21H CYCLES PER UNIT TIME) CCCCC CALL DPWRST('XXX','BUG ') C C COMPUTE THE DIFFERENCE BETWEEN THE MAX AND MIN AMPLITUDES AND WRITE IT OUT C Y2MIN=Y2(1) Y2MAX=Y2(1) DO1600I=1,IMAX2 IF(Y2(I).LT.Y2MIN)Y2MIN=Y2(I) IF(Y2(I).GT.Y2MAX)Y2MAX=Y2(I) 1600 CONTINUE RANGE=Y2MAX-Y2MIN CCCCC WRITE(ICOUT,1651)Y2MIN,Y2MAX,RANGE C1651 FORMAT(9X,20HMINIMUM AMPLITUDE = ,E15.8,5X,20HMAXIMUM AMPLITUD CCCCC1E = ,E15.8,5X,22HRANGE OF AMPLITUDES = ,E15.8) CCCCC CALL DPWRST('XXX','BUG ') GOTO9000 C C ************************************* C ** STEP 8-- ** C ** FORM THE PHASES AND PLOT THEM ** C ************************************* C 1700 CONTINUE DO1750I=1,IMAX2 Y2(I)=ATAN(Y2(I)/X2(I)) X2(I)=I D2(I)=1.0 1750 CONTINUE N2=IMAX2 NPLOTV=2 C CCCCC WRITE(ICOUT,1751)F C1751 FORMAT(32X, 44HPHASE PLOT FOR THE DEMODULATION FREQUENCY = ,F8 CCCCC1.6,21H CYCLES PER UNIT TIME) CCCCC CALL DPWRST('XXX','BUG ') C C COMPUTE A NEW ESTIMATE FOR THE DEMODULATION FREQUENCY AND WRITE IT OUT C AIMAX2=IMAX2 IMAX2M=IMAX2-1 IFLAG=0 Y2MIN=Y2(1) Y2MAX=Y2(1) DO1800I=1,IMAX2M IP1=I+1 DEL=Y2(IP1)-Y2(I) IF(DEL.GT.2.5)IFLAG=IFLAG-1 IF(DEL.LT.-2.5)IFLAG=IFLAG+1 AIFLAG=IFLAG Y2NEW=Y2(IP1)+AIFLAG*PI IF(Y2NEW.LT.Y2MIN)Y2MIN=Y2NEW IF(Y2NEW.GT.Y2MAX)Y2MAX=Y2NEW 1800 CONTINUE RANGE=Y2MAX-Y2MIN SLOPER=RANGE/AIMAX2 SLOPEH=SLOPER/(2.0*PI) FEST=F+SLOPEH DEMODF=FEST CCCCC WRITE(ICOUT,2025)Y2MIN,Y2MAX,RANGE C2025 FORMAT(3X,16HMINIMUM PHASE = ,E15.8,11H RADIANS ,16HMAXIMUM CCCCC1PHASE = ,E15.8,11H RADIANS ,18HRANGE OF PHASES = ,E15.8,8H RADIA CCCCC1NS) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,2030)SLOPER,SLOPEH,FEST C2030 FORMAT(8HSLOPE = ,E14.8,11H RADIANS = ,E14.6,52H CYCLES PER UN CCCCC1IT TIME EST. OF NEW DEMOD. FREQ. = ,E15.8,15H CYC./UNIT TIME) CCCCC CALL DPWRST('XXX','BUG ') C GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE RETURN END SUBROUTINE DPCHAL(ICHAR2,ICHARN,IBUG,IFOUND) C C PURPOSE--CONVERT AN ALPHABETIC CHARACTER C (A TO Z) INTO A NUMERIC VALUE C (1 TO 26). C INPUT ARGUMENTS--ICHAR2 (A HOLLERITH VARIABLE C CONTAINING THE HOLLERITH C CHARACTER(S) OF INTEREST. C OUTPUT ARGUMENTS--ICHARN (AN INTEGER VARIABLE C CONTAINING THE NUMERIC C DESIGNATION FOR THE C ALPHABETIC CHARACTER. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--MARCH 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR2 CHARACTER*4 IBUG CHARACTER*4 IFOUND C CHARACTER*1 ICH1 CHARACTER*1 ICH2 C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOBE.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' C ICH1='-' ICH2='-' C ICH1N=(-999) ICH2N=(-999) C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CHAL')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPCHAL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHAR2 52 FORMAT('ICHAR2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGG4,ISUBG4 59 FORMAT('IBUGG4,ISUBG4 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************** C ** STEP 1-- ** C ** CONVERT THE CHARACTER ** C ********************************** C ICH2(1:1)=ICHAR2(2:2) CCCCC ICH2N=ICHAR(ICH2) CALL DPCOAN(ICH2,ICH2N) IF(ICH2N.EQ.32)GOTO1100 GOTO7900 C 1100 CONTINUE ICH1(1:1)=ICHAR2(1:1) CCCCC ICH1N=ICHAR(ICH1) CALL DPCOAN(ICH1,ICH1N) ICHARN=ICH1N-64 IF(1.LE.ICHARN.AND.ICHARN.LE.26)GOTO8000 GOTO7900 C 7900 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7911) C7911 FORMAT('***** ERROR IN DPCHAL--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7912) C7912 FORMAT(' NO MATCH FOUND FOR INPUT CHARACTER.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7913)ICHAR C7913 FORMAT(' INPUT CHARACTER = ',A4) CCCCC CALL DPWRST('XXX','BUG ') IFOUND='NO' GOTO9000 C 8000 CONTINUE IFOUND='YES' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CHAL')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPCHAL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICH1,ICH1N 9012 FORMAT('ICH1,ICH1N = ',A1,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICH2,ICH2N 9013 FORMAT('ICH2,ICH2N = ',A1,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ICHAR2,ICHARN 9014 FORMAT('ICHAR2,ICHARN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)IBUGG4,ISUBG4,IFOUND 9019 FORMAT('IBUGG4,ISUBG4,IFOUND = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPCHAN(MAXCHA,ACHAAN, 1IBUGP2,IBUGQ,IFOUND,IERROR) C C PURPOSE--DEFINE PLOT CHARACTER ANGLES FOR USE IN MULTI-TRACE PLOTS. C THE ANGLE FOR THE CHARACTER FOR THE I-TH TRACE C WILL BE PLACED C IN THE I-TH ELEMENT OF THE FLOATING POINT C VECTOR ACHAAN(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --ARG (A HOLLERITH VECTOR) C --NUMARG C --MAXCHA C OUTPUT ARGUMENTS--ACHAAN (A FLOATING POINT VECTOR C WHOSE I-TH ELEMENT IS THE ANGLE C FOR THE CHARACTER C ASSIGNED TO THE I-TH TRACE IN C A MULTI-TRACE PLOT. C --ACHAAN = CHARACTER ANGLE C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--86/11 C ORIGINAL VERSION--NOVEMBER 1986. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CCCCC CHARACTER*4 IHARG DECEMBER 1986 CCCCC CHARACTER*4 IARGT DECEMBER 1986 C CHARACTER*4 IBUGP2 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ICASEQ CHARACTER*4 IWRITE C C--------------------------------------------------------------------- C CCCCC DIMENSION IHARG(*) DECEMBER 1986 CCCCC DIMENSION IARGT(*) DECEMBER 1986 CCCCC DIMENSION IARG(*) DECEMBER 1986 CCCCC DIMENSION ARG(*) DECEMBER 1986 C DIMENSION ACHAAN(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPCH' ISUBN2='AN ' C IFOUND='NO' IERROR='NO' C 1100 CONTINUE C IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'ANGL')GOTO1160 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'ANGL')GOTO1105 GOTO9000 C 1105 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1110 IF(IHARG(NUMARG).EQ.'OFF')GOTO1110 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 C IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140 C IF(NUMARG.GE.3.AND.IHARG(2).EQ.'AUTO')GOTO3000 C GOTO1150 C 1110 CONTINUE DO1115I=1,MAXCHA ACHAAN(I)=0.0 1115 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1119 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ACHAAN(I) 1116 FORMAT('ALL CHARACTER ANGLES HAVE JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') 1119 CONTINUE GOTO8000 C 1120 CONTINUE I=1 IF(IARGT(2).NE.'NUMB')GOTO1180 ACHAAN(1)=ARG(2) C IF(IFEEDB.EQ.'OFF')GOTO1129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1126)I,ACHAAN(I) 1126 FORMAT('THE ANGLE FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') 1129 CONTINUE GOTO8000 C 1130 CONTINUE I=1 IF(IARGT(3).NE.'NUMB')GOTO1180 DO1135I=1,MAXCHA ACHAAN(I)=ARG(3) 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ACHAAN(I) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO8000 C 1140 CONTINUE I=1 IF(IARGT(2).NE.'NUMB')GOTO1180 DO1145I=1,MAXCHA ACHAAN(I)=ARG(2) 1145 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1149 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ACHAAN(I) CALL DPWRST('XXX','BUG ') 1149 CONTINUE GOTO8000 C 1150 CONTINUE IMAX=NUMARG-1 IF(MAXCHA.LT.IMAX)IMAX=MAXCHA DO1155I=1,IMAX IP1=I+1 IF(IARGT(IP1).NE.'NUMB')GOTO1180 ACHAAN(I)=ARG(IP1) 1155 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1159 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1156I=1,IMAX WRITE(ICOUT,1126)I,ACHAAN(I) CALL DPWRST('XXX','BUG ') 1156 CONTINUE 1159 CONTINUE GOTO8000 C 1160 CONTINUE DO1165I=1,MAXCHA ACHAAN(I)=0.0 1165 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1169 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ACHAAN(I) CALL DPWRST('XXX','BUG ') 1169 CONTINUE GOTO8000 C 1180 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('***** ERROR IN DPCHAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182) 1182 FORMAT('CHARACTER ANGLES MUST BE NUMERIC;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1183) 1183 FORMAT('HOWEVER, THE SPECIFIED CHARACTER ANGLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1184)I 1184 FORMAT('FOR CHARACTER ',I6,' WAS NON-NUMERIC.') CALL DPWRST('XXX','BUG ') GOTO9000 C C *********************************************************** C ** STEP 30-- ** C ** TREAT THE CHARACTER ANGLE AUTOMATIC CASE ** C *********************************************************** C 3000 CONTINUE C C ******************************************** C ** STEP 31-- ** C ** CHECK THE VALIDITY OF ARGUMENT 3 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='31' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(3) IHLEF2=IHARG2(3) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) C C ***************************************** C ** STEP 32-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='32' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO3290 DO3200J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO3210 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO3210 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO3220 3200 CONTINUE GOTO3290 3210 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO3290 3220 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO3290 3290 CONTINUE IF(IBUGP2.EQ.'OFF')GOTO3295 WRITE(ICOUT,3291)NUMARG,ILOCQ 3291 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 3295 CONTINUE C C ********************************************* C ** STEP 33-- ** C ** TEMPORARILY FORM THE VARIABLE Y(.) ** C ** WHICH WILL HOLD THE RESPONSE VARIABLE. ** C ** FORM THIS VARIABLE BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C ********************************************* C ISTEPN='33' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO3310 IF(ICASEQ.EQ.'SUBS')GOTO3320 IF(ICASEQ.EQ.'FOR')GOTO3330 C 3310 CONTINUE DO3315I=1,NLEFT ISUB(I)=1 3315 CONTINUE NQ=NLEFT GOTO3350 C 3320 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO3350 C 3330 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO3350 C 3350 CONTINUE MINN2=1 IF(NQ.GE.MINN2)GOTO3360 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3351) 3351 FORMAT('***** ERROR IN DPCHAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3352) 3352 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3353)IHLEFT,IHLEF2 3353 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3354) 3354 FORMAT(' (FOR WHICH CHARACTER ANGLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3355) 3355 FORMAT(' ARE TO BE GENERATED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3356)MINN2 3356 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3357) 3357 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3358) 3358 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3359)(IANS(I),I=1,IWIDTH) 3359 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3360 CONTINUE MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO3370I=1,IMAX IF(ISUB(I).EQ.0)GOTO3370 J=J+1 C IJ=MAXN*(ICOLL-1)+I IF(ICOLL.LE.MAXCOL)Y(J)=V(IJ) IF(ICOLL.EQ.MAXCP1)Y(J)=PRED(I) IF(ICOLL.EQ.MAXCP2)Y(J)=RES(I) IF(ICOLL.EQ.MAXCP3)Y(J)=YPLOT(I) IF(ICOLL.EQ.MAXCP4)Y(J)=XPLOT(I) IF(ICOLL.EQ.MAXCP5)Y(J)=X2PLOT(I) IF(ICOLL.EQ.MAXCP6)Y(J)=TAGPLO(I) C 3370 CONTINUE NS=J NY=J C C ***************************************** C ** STEP 34-- ** C ** EXTRACT THE DISTINCT VALUES ** C ** FROM THE TARGET VARIABLE Y(.) . ** C ** STORE THEM IN X(.) . ** C ***************************************** C IWRITE='OFF' CALL DISTIN(Y,NY,IWRITE,X,NX,IBUGP2,IERROR) C C *********************************** C ** STEP 35-- ** C ** SORT THESE DISTINCT VALUES ** C ** (IN PLACE). ** C *********************************** C CALL SORT(X,NX,X) C C ****************************************** C ** STEP 36-- ** C ** COPY THE NUMERIC VALUES IN X(.) ** C ** INTO INDIVIDUAL ELEMENTS ** C ** OF ACHAAN(.) ** C ** NOTE--MAX NUMBER OF VALUES = 100 ** C ****************************************** C IMAX=NX IF(IMAX.GT.MAXCHA)IMAX=MAXCHA DO3650I=1,IMAX ACHAAN(I)=X(I) 3650 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO3679 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO3675I=1,IMAX WRITE(ICOUT,3676)I,ACHAAN(I) 3676 FORMAT('CHARACTER ANGLE ',I6,' HAS JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') 3675 CONTINUE 3679 CONTINUE GOTO8000 C 8000 CONTINUE IFOUND='YES' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGP2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPCHAR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGP2 9012 FORMAT('IBUGP2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IFOUND,IERROR 9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IMAX 9014 FORMAT('IMAX = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)NY 9021 FORMAT('NY = ',I8) CALL DPWRST('XXX','BUG ') IF(NY.LE.0)GOTO9022 DO9023I=1,NY WRITE(ICOUT,9024)I,Y(I) 9024 FORMAT('I,Y(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 9023 CONTINUE 9022 CONTINUE WRITE(ICOUT,9031)NX 9031 FORMAT('NX = ',I8) CALL DPWRST('XXX','BUG ') IF(NX.LE.0)GOTO9032 DO9033I=1,NX WRITE(ICOUT,9034)I,X(I) 9034 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 9033 CONTINUE 9032 CONTINUE WRITE(ICOUT,9041)MAXCHA 9041 FORMAT('MAXCHA = ',I8) CALL DPWRST('XXX','BUG ') IF(NX.LE.0)GOTO9042 DO9043I=1,NX WRITE(ICOUT,9044)I,ACHAAN(I) 9044 FORMAT('I,ACHAAN(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9043 CONTINUE 9042 CONTINUE 9090 CONTINUE RETURN END SUBROUTINE DPCHAR(MAXCHA,ICHAPA,ICHAPO, CCCCC AUGMENT ARGUMENT LIST FEBRUARY 1998. CCCCC SUBROUTINE DPCHAR(MAXCHA,ICHAPA, 1IBUGP2,IBUGQ,IFOUND,IERROR) C C PURPOSE--DEFINE PLOT CHARACTERS FOR USE IN MULTI-TRACE PLOTS. C THE CHARACTER FOR THE I-TH TRACE WILL BE PLACED C IN THE I-TH ELEMENT OF THE HOLLERITH C VECTOR ICHAPA(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG C --MAXCHA C OUTPUT ARGUMENTS--ICHAPA (A HOLLERITH VECTOR C WHOSE I-TH ELEMENT IS THE CHARACTER C ASSIGNED TO THE I-TH TRACE IN C A MULTI-TRACE PLOT. C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 1977. C UPDATED --SEPTEMBER 1980. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --JULY 1983. C UPDATED --NOVEMBER 1986. C UPDATED --JANAURY 1988 (OMIT SORTING FOR CHAR AUTOMATIC) C UPDATED --AUGUST 1987. TUFTE BOX PLOT C UPDATED --NOVEMBER 1988. ERROR BAR PLOT C UPDATED --JUNE 1989. CHAR AUTOMATIC DISTINCT C UPDATED --SEPTEMBER 1990. AUGMENT CONTROL CHART C UPDATED --NOVEMBER 1995. SUPPORT CASE ASIS C UPDATED --FEBRUARY 1998. CHAR C UPDATED --JANUARY 2001. CHAR AUTOMATIC SIGN C UPDATED --FEBRUARY 2003. CHAR VIOLIN PLOT C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CCCCC CHARACTER*4 IHARG DECEMBER 1986 CHARACTER*4 ICHAPA CCCCC ADD FOLLOWING LINE FEBRUARY 1998. CHARACTER*4 ICHAPO CHARACTER*4 IBUGP2 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ICASEQ CHARACTER*4 IWRITE CHARACTER*4 ICTEXT CHARACTER*4 ICTEX4 CHARACTER*1 ICTEX1 CHARACTER*4 ICHAP4 CCCCC FOLLOWING LINE JANAURY 2001 CHARACTER*4 ISIGNF C C--------------------------------------------------------------------- C CCCCC DIMENSION IHARG(*) DECEMBER 1986 DIMENSION ICHAPA(*) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. DIMENSION ICHAPO(*) DIMENSION ICTEXT(100) C C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPCH' ISUBN2='AR ' C IFOUND='NO' IERROR='NO' C 1100 CONTINUE C IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO9000 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SIZE')GOTO9000 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FILL')GOTO9000 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TYPE')GOTO9000 C CCCCC ADD FOLLOWING 2 LINES ADDED FEBRUARY 1998. IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SAVE')GOTO2160 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'REST')GOTO2165 C IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BOX'.AND.IHARG(2).EQ.'PLOT') 1GOTO2110 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'TUFT'.AND. 1 IHARG(2).EQ.'BOX'.AND.IHARG(3).EQ.'PLOT') 1GOTO2140 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ERRO'.AND. 1 IHARG(2).EQ.'BAR'.AND.IHARG(3).EQ.'PLOT') 1GOTO2150 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'BOX'.AND.IHARG(3).EQ.'PLOT') 1GOTO2110 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'I'.AND.IHARG(2).EQ.'PLOT') 1GOTO2120 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'I'.AND.IHARG(3).EQ.'PLOT') 1GOTO2120 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR') 1GOTO2130 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'CONT'.AND.IHARG(3).EQ.'CHAR') 1GOTO2130 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'VIOL'.AND.IHARG(2).EQ.'PLOT') 1GOTO2145 IF(NUMARG.GE.4.AND.IHARG(1).EQ.'VIOL'.AND. 1IHARG(2).EQ.'BOX'.AND.IHARG(4).EQ.'PLOT') 1GOTO2148 IF(NUMARG.GE.4.AND.IHARG(1).EQ.'VIOL'.AND.IHARG(2).EQ.'TUFT' 1.AND.IHARG(3).EQ.'BOX'.AND.IHARG(4).EQ.'PLOT') 1GOTO2145 C IF(NUMARG.LE.0)GOTO1160 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'ALL')GOTO1160 C IF(IHARG(NUMARG).EQ.'ON')GOTO1110 IF(IHARG(NUMARG).EQ.'OFF')GOTO1160 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1160 C IF(NUMARG.EQ.1)GOTO1120 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'ALL')GOTO1130 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'ALL')GOTO1140 C IF(NUMARG.GE.2.AND.IHARG(2).EQ.'SUBS'.AND. 1IHARG2(2).EQ.'ET ')GOTO4110 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'EXCE'.AND. 1IHARG2(2).EQ.'PT ')GOTO4110 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'FOR '.AND. 1IHARG2(2).EQ.' ')GOTO4120 C IF(NUMARG.GE.2.AND.IHARG(1).EQ.'AUTO')GOTO3000 C GOTO1150 C 1110 CONTINUE DO1115I=1,MAXCHA ICHAPA(I)='X ' 1115 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1119 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHAPA(I) 1116 FORMAT('ALL CHARACTERS HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1119 CONTINUE GOTO8000 C 1120 CONTINUE IF(NUMARG.EQ.0)ICHAPA(1)=' ' CCCCC NOVEMBER 1995. SUPPORT CASE ASIS CCCCC IF(NUMARG.GE.1)ICHAPA(1)=IHARG(1) CCCCC IF(ICHAPA(1).EQ.'BOX')ICHAPA(1)='SQUA' IF(NUMARG.GE.1)THEN IF(IHARG(1).EQ.'BOX')THEN ICHAPA(1)='SQUA' ELSE ICHAPA(1)=IHARLC(1) ENDIF ENDIF C IF(IFEEDB.EQ.'OFF')GOTO1129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1126)I,ICHAPA(I) 1126 FORMAT('CHARACTER ',I6,' HAS JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1129 CONTINUE GOTO8000 C 1130 CONTINUE DO1135I=1,MAXCHA CCCCC NOVEMBER 1995. SUPPORT CASE ASIS CCCCC ICHAPA(I)=IHARG(2) CCCCC IF(ICHAPA(I).EQ.'BOX')ICHAPA(I)='SQUA' IF(IHARG(2).EQ.'BOX')THEN ICHAPA(I)='SQUA' ELSE ICHAPA(I)=IHARLC(2) ENDIF 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHAPA(I) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO8000 C 1140 CONTINUE DO1145I=1,MAXCHA CCCCC NOVEMBER 1995. SUPPORT CASE ASIS CCCCC ICHAPA(I)=IHARG(1) CCCCC IF(ICHAPA(I).EQ.'BOX')ICHAPA(I)='SQUA' IF(IHARG(1).EQ.'BOX')THEN ICHAPA(I)='SQUA' ELSE ICHAPA(I)=IHARLC(1) ENDIF 1145 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1149 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHAPA(I) CALL DPWRST('XXX','BUG ') 1149 CONTINUE GOTO8000 C 1150 CONTINUE IMAX=NUMARG IF(MAXCHA.LT.IMAX)IMAX=MAXCHA DO1155I=1,IMAX CCCCC NOVEMBER 1995. SUPPORT CASE ASIS CCCCC ICHAPA(I)=IHARG(I) CCCCC IF(ICHAPA(I).EQ.'BOX')ICHAPA(I)='SQUA' IF(IHARG(I).EQ.'BOX')THEN ICHAPA(I)='SQUA' ELSE ICHAPA(I)=IHARLC(I) ENDIF 1155 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1159 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1156I=1,IMAX WRITE(ICOUT,1126)I,ICHAPA(I) CALL DPWRST('XXX','BUG ') 1156 CONTINUE 1159 CONTINUE GOTO8000 C 1160 CONTINUE DO1165I=1,MAXCHA ICHAPA(I)=' ' 1165 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1169 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHAPA(I) CALL DPWRST('XXX','BUG ') 1169 CONTINUE GOTO8000 C 2110 CONTINUE IMAX=24 ICHAPA(1)='X' ICHAPA(2)=' ' ICHAPA(3)=' ' ICHAPA(4)='X' ICHAPA(5)=' ' ICHAPA(6)=' ' ICHAPA(7)='X' ICHAPA(8)=' ' ICHAPA(9)=' ' ICHAPA(10)=' ' ICHAPA(11)=' ' ICHAPA(12)=' ' ICHAPA(13)=' ' ICHAPA(14)=' ' ICHAPA(15)=' ' ICHAPA(16)=' ' ICHAPA(17)=' ' ICHAPA(18)=' ' ICHAPA(19)=' ' ICHAPA(20)=' ' ICHAPA(21)='CIRC' ICHAPA(22)='CIRC' ICHAPA(23)='CIRC' ICHAPA(24)='CIRC' GOTO2170 C 2120 CONTINUE IMAX=5 ICHAPA(1)='-' ICHAPA(2)='X' ICHAPA(3)='-' ICHAPA(4)=' ' ICHAPA(5)=' ' GOTO2170 C 2130 CONTINUE CCCCC THE FOLLOWING SECTION WAS CHANGED SEPTEMBER 1990 IMAX=7 ICHAPA(1)='CIRC' ICHAPA(2)=' ' ICHAPA(3)=' ' ICHAPA(4)=' ' ICHAPA(5)=' ' ICHAPA(6)=' ' ICHAPA(7)=' ' GOTO2170 C 2140 CONTINUE IMAX=24 ICHAPA(1)=' ' ICHAPA(2)=' ' ICHAPA(3)=' ' ICHAPA(4)='X' ICHAPA(5)=' ' ICHAPA(6)=' ' ICHAPA(7)=' ' ICHAPA(8)=' ' ICHAPA(9)=' ' ICHAPA(10)=' ' ICHAPA(11)=' ' ICHAPA(12)=' ' ICHAPA(13)=' ' ICHAPA(14)=' ' ICHAPA(15)=' ' ICHAPA(16)=' ' ICHAPA(17)=' ' ICHAPA(18)=' ' ICHAPA(19)=' ' ICHAPA(20)=' ' ICHAPA(21)='CIRC' ICHAPA(22)='CIRC' ICHAPA(23)='CIRC' ICHAPA(24)='CIRC' GOTO2170 C 2145 CONTINUE IMAX=25 ICHAPA(1)=' ' ICHAPA(2)=' ' ICHAPA(3)=' ' ICHAPA(4)=' ' ICHAPA(5)='X' ICHAPA(6)=' ' ICHAPA(7)=' ' ICHAPA(8)=' ' ICHAPA(9)=' ' ICHAPA(10)=' ' ICHAPA(11)=' ' ICHAPA(12)=' ' ICHAPA(13)=' ' ICHAPA(14)=' ' ICHAPA(15)=' ' ICHAPA(16)=' ' ICHAPA(17)=' ' ICHAPA(18)=' ' ICHAPA(19)=' ' ICHAPA(20)=' ' ICHAPA(21)=' ' ICHAPA(22)='CIRC' ICHAPA(23)='CIRC' ICHAPA(24)='CIRC' ICHAPA(25)='CIRC' GOTO2170 C 2148 CONTINUE IMAX=25 ICHAPA(1)=' ' ICHAPA(2)='X' ICHAPA(3)=' ' ICHAPA(4)=' ' ICHAPA(5)='X' ICHAPA(6)=' ' ICHAPA(7)=' ' ICHAPA(8)='X' ICHAPA(9)=' ' ICHAPA(10)=' ' ICHAPA(11)=' ' ICHAPA(12)=' ' ICHAPA(13)=' ' ICHAPA(14)=' ' ICHAPA(15)=' ' ICHAPA(16)=' ' ICHAPA(17)=' ' ICHAPA(18)=' ' ICHAPA(19)=' ' ICHAPA(20)=' ' ICHAPA(21)=' ' ICHAPA(22)='CIRC' ICHAPA(23)='CIRC' ICHAPA(24)='CIRC' ICHAPA(25)='CIRC' GOTO2170 C 2150 CONTINUE IMAX=7 ICHAPA(1)='CIRC' ICHAPA(2)='-' ICHAPA(3)='-' ICHAPA(4)='|' ICHAPA(5)='|' ICHAPA(6)=' ' ICHAPA(7)=' ' GOTO2170 C 2160 CONTINUE CCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 1998 DO2163I=1,MAXCHA ICHAPO(I)=ICHAPA(I) 2163 CONTINUE IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2164) 2164 FORMAT('THE CURRENT CHARACTER SETTINGS HAVE BEEN SAVED.') CALL DPWRST('XXX','BUG ') ENDIF IFOUND='YES' GOTO9000 C 2165 CONTINUE CCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 1998 DO2168I=1,MAXCHA ICHAPA(I)=ICHAPO(I) 2168 CONTINUE IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2169) 2169 FORMAT('THE SAVED CHARACTER SETTINGS HAVE BEEN RESTORED.') CALL DPWRST('XXX','BUG ') ENDIF IFOUND='YES' GOTO9000 C 2170 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO2179 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO2175I=1,IMAX WRITE(ICOUT,2176)I,ICHAPA(I) 2176 FORMAT('CHARACTER ',I6,' HAS JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 2175 CONTINUE 2179 CONTINUE GOTO8000 C C *********************************************************** C ** STEP 30-- ** C ** TREAT THE CHARACTERS AUTOMATIC CASE ** C *********************************************************** C 3000 CONTINUE C C ******************************************** C ** STEP 31-- ** C ** CHECK THE VALIDITY OF ARGUMENT 2 (OR 3)** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='31' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(2) IHLEF2=IHARG2(2) CCCCC THE FOLLOWING 2 LINES WERE ADDED JUNE 1989 IF(IHARG(2).EQ.'DIST'.AND.IHARG2(2).EQ.'INCT')IHLEFT=IHARG(3) IF(IHARG(2).EQ.'DIST'.AND.IHARG2(2).EQ.'INCT')IHLEF2=IHARG2(3) CCCCC THE FOLLOWING 4 LINES WERE ADDED JANUARY 2001 ISIGNF='OFF' IF(IHARG(2).EQ.'SIGN'.AND.IHARG2(2).EQ.' ')ISIGNF='ON' IF(IHARG(2).EQ.'SIGN'.AND.IHARG2(2).EQ.' ')IHLEFT=IHARG(3) IF(IHARG(2).EQ.'SIGN'.AND.IHARG2(2).EQ.' ')IHLEF2=IHARG2(3) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) C C ***************************************** C ** STEP 32-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='32' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO3290 DO3200J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO3210 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO3210 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO3220 3200 CONTINUE GOTO3290 3210 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO3290 3220 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO3290 3290 CONTINUE IF(IBUGP2.EQ.'OFF')GOTO3295 WRITE(ICOUT,3291)NUMARG,ILOCQ 3291 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 3295 CONTINUE C C ********************************************* C ** STEP 33-- ** C ** TEMPORARILY FORM THE VARIABLE Y(.) ** C ** WHICH WILL HOLD THE RESPONSE VARIABLE. ** C ** FORM THIS VARIABLE BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C ********************************************* C ISTEPN='33' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO3310 IF(ICASEQ.EQ.'SUBS')GOTO3320 IF(ICASEQ.EQ.'FOR')GOTO3330 C 3310 CONTINUE DO3315I=1,NLEFT ISUB(I)=1 3315 CONTINUE NQ=NLEFT GOTO3350 C 3320 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO3350 C 3330 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO3350 C 3350 CONTINUE MINN2=1 IF(NQ.GE.MINN2)GOTO3360 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3351) 3351 FORMAT('***** ERROR IN DPCHAR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3352) 3352 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3353)IHLEFT,IHLEF2 3353 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3354) 3354 FORMAT(' (FOR WHICH CHARACTER DEFINITIONS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3355) 3355 FORMAT(' ARE TO BE GENERATED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3356)MINN2 3356 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3357) 3357 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3358) 3358 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3359)(IANS(I),I=1,IWIDTH) 3359 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3360 CONTINUE MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO3370I=1,IMAX IF(ISUB(I).EQ.0)GOTO3370 J=J+1 C IJ=MAXN*(ICOLL-1)+I IF(ICOLL.LE.MAXCOL)Y(J)=V(IJ) IF(ICOLL.EQ.MAXCP1)Y(J)=PRED(I) IF(ICOLL.EQ.MAXCP2)Y(J)=RES(I) IF(ICOLL.EQ.MAXCP3)Y(J)=YPLOT(I) IF(ICOLL.EQ.MAXCP4)Y(J)=XPLOT(I) IF(ICOLL.EQ.MAXCP5)Y(J)=X2PLOT(I) IF(ICOLL.EQ.MAXCP6)Y(J)=TAGPLO(I) CCCCC FOLLOWING BLOCK OF CODE JANUARY 2001 IF(ISIGNF.EQ.'ON')THEN IF(Y(J).GT.0.0)THEN ICHAPA(J)='+ ' ELSEIF(Y(J).LT.0.0)THEN ICHAPA(J)='- ' ELSEIF(Y(J).EQ.0.0)THEN ICHAPA(J)='0 ' ELSE ICHAPA(J)='0 ' ENDIF ENDIF C 3370 CONTINUE NS=J NY=J CCCCC FOLLOWING LINE JANUARY 2001 IF(ISIGNF.EQ.'ON')GOTO8000 C C ***************************************** C ** STEP 34-- ** C ** IF HAVE THE FORM-- ** C ** CHARACTERS AUTOMATIC DISTINCT X ** C ** EXTRACT THE DISTINCT VALUES ** C ** FROM THE TARGET VARIABLE Y(.) . ** C ** STORE THEM IN X(.) . ** C ** IF HAVE THE FORM-- ** C ** CHARACTERS AUTOMATIC X ** C ** DO NOTHING ** C ***************************************** C CCCCC THE FOLLOWING SECTION WAS REWRITTEN JUNE 1989 IF(IHARG(2).EQ.'DIST'.AND.IHARG2(2).EQ.'INCT')GOTO3420 C 3410 CONTINUE DO3411I=1,NY X(I)=Y(I) 3411 CONTINUE NX=NY GOTO3490 C 3420 CONTINUE IWRITE='OFF' CALL DISTIN(Y,NY,IWRITE,X,NX,IBUGP2,IERROR) GOTO3490 C 3490 CONTINUE C C *********************************** C ** STEP 35-- ** C ** SORT THESE DISTINCT VALUES ** C ** (IN PLACE). ** C *********************************** C CCCCC CALL SORT(X,NX,X) C C ****************************************** C ** STEP 36-- ** C ** CONVERT THE NUMERIC VALUES IN X(.) ** C ** TO CHARACTER STRINGS. ** C ** THEN LOAD THESE STRINGS ** C ** INTO INDIVIDUAL ELEMENTS ** C ** OF ICHAPA(.) ** C ** NOTE--MAX CHARACTERS/STRING = 4 ** C ** MAX NUMBER OF STRINGS = 100 ** C ****************************************** C IMAX=NX IF(IMAX.GT.MAXCHA)IMAX=MAXCHA DO3650I=1,IMAX VAL=X(I) IVAL=VAL+0.5 IF(VAL.LT.0.0)IVAL=VAL-0.5 NUMDID=(-1) CALL DPCON2(IVAL,VAL,ICTEXT,NCTEXT,NUMDID,IBUGP2,IERROR) JMAX=NCTEXT IF(JMAX.GT.4)JMAX=4 ICTEX4=' ' ICTEX1=' ' ICHAP4=' ' DO3660J=1,JMAX ICTEX4=ICTEXT(J) ICTEX1=ICTEX4(1:1) ICHAP4(J:J)=ICTEX1 3660 CONTINUE ICHAPA(I)=ICHAP4 3650 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO3679 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO3675I=1,IMAX WRITE(ICOUT,3676)I,ICHAPA(I) 3676 FORMAT('CHARACTER ',I6,' HAS JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 3675 CONTINUE 3679 CONTINUE GOTO8000 C C *********************************************************** C ** STEP 40-- ** C ** TREAT THE CHARACTERS ... SUBSET/EXCEPT/FOR CASE ** C ** FOR REDEFINING SPECIFIED CHARACTERS ** C *********************************************************** C 4000 CONTINUE C C ***************************************** C ** STEP 41-- ** C ** DEFINE THE TYPE CASE-- ** C ** 1) SUBSET/EXCEPT ** C ** 2) FOR. ** C ***************************************** C ISTEPN='41' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C 4110 CONTINUE ICASEQ='SUBS' GOTO4190 4120 CONTINUE ICASEQ='FOR' GOTO4190 4190 CONTINUE ILOCQ=2 IF(IBUGP2.EQ.'OFF')GOTO4195 WRITE(ICOUT,4191)ICASEQ,ILOCQ,NUMARG 4191 FORMAT('ICASEQ,ILOCQ,NUMARG = ',3I8) CALL DPWRST('XXX','BUG ') 4195 CONTINUE C C ********************************************* C ** STEP 42-- ** C ** DETERMINE WHICH ELEMENTS ARE ** C ** TO BE REDEFINED. ** C ********************************************* C ISTEPN='42' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NQ=0 IF(ICASEQ.EQ.'SUBS')GOTO4220 IF(ICASEQ.EQ.'FOR')GOTO4230 GOTO4250 C 4220 CONTINUE NIOLD=MAXCHA CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO4250 C 4230 CONTINUE NIOLD=MAXCHA CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO4250 C 4250 CONTINUE IF(NQ.GE.1)GOTO4290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4251) 4251 FORMAT('***** ERROR IN DPCHAR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4252) 4252 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4253)IHLEFT,IHLEF2 4253 FORMAT(' EXTRACTED, NO CHARACTER ELEMENTS ', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4254) 4254 FORMAT(' REMAINED TO BE REDEFINED. ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4255)ICASEQ 4255 FORMAT('ICASEQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4258) 4258 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,4259)(IANS(I),I=1,IWIDTH) 4259 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 4290 CONTINUE C C ********************************************* C ** STEP 43-- ** C ** REDEFINE THE DESIGNATED ** C ** CHARACTERS. ** C ********************************************* C ISTEPN='43' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IMAX=MAXCHA IF(NQ.LT.MAXCHA)IMAX=NQ DO4310I=1,IMAX IF(ISUB(I).EQ.0)GOTO4310 CCCCC NOVEMBER 1995. SUPPORT CASE ASIS CCCCC ICHAPA(I)=IHARG(1) ICHAPA(I)=IHARLC(1) 4310 CONTINUE C C ********************************************* C ** STEP 44-- ** C ** IF CALLED FOR, ** C ** PRINT OUT A MESSAGE. ** C ********************************************* C ISTEPN='44' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IFEEDB.EQ.'OFF')GOTO4490 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO4410I=1,IMAX IF(ISUB(I).EQ.0)GOTO4410 WRITE(ICOUT,4411)I,ICHAPA(I) 4411 FORMAT('CHARACTER ',I6,' HAS JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 4410 CONTINUE 4490 CONTINUE GOTO8000 C 8000 CONTINUE IFOUND='YES' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGP2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPCHAR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGP2 9012 FORMAT('IBUGP2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IFOUND,IERROR 9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IMAX 9014 FORMAT('IMAX = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)NY 9021 FORMAT('NY = ',I8) CALL DPWRST('XXX','BUG ') IF(NY.LE.0)GOTO9022 DO9023I=1,NY WRITE(ICOUT,9024)I,Y(I) 9024 FORMAT('I,Y(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 9023 CONTINUE 9022 CONTINUE WRITE(ICOUT,9031)NX 9031 FORMAT('NX = ',I8) CALL DPWRST('XXX','BUG ') IF(NX.LE.0)GOTO9032 DO9033I=1,NX WRITE(ICOUT,9034)I,X(I) 9034 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 9033 CONTINUE 9032 CONTINUE WRITE(ICOUT,9041)MAXCHA 9041 FORMAT('MAXCHA = ',I8) CALL DPWRST('XXX','BUG ') IF(NX.LE.0)GOTO9042 DO9043I=1,NX WRITE(ICOUT,9044)I,ICHAPA(I) 9044 FORMAT('I,ICHAPA(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9043 CONTINUE 9042 CONTINUE 9090 CONTINUE RETURN END SUBROUTINE DPCHCA(IHARG,NUMARG,IDEFCA,MAXCHA,ICHACA,IFOUND,IERROR) C C PURPOSE--DEFINE PLOT CHARACTER CASES FOR USE IN MULTI-TRACE PLOTS. C THE CASE FOR THE CHARACTER FOR THE I-TH TRACE C WILL BE PLACED C IN THE I-TH ELEMENT OF THE HOLLERITH C VECTOR ICHACA(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFCA C --MAXCHA C OUTPUT ARGUMENTS--ICHACA (A HOLLERITH VECTOR C WHOSE I-TH ELEMENT IS THE CASE C FOR THE CHARACTER C ASSIGNED TO THE I-TH TRACE IN C A MULTI-TRACE PLOT. C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--ALAN HECKERT C COMPUTER SERVICES DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 1977. C UPDATED --SEPTEMBER 1980. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFCA CHARACTER*4 ICHACA CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION ICHACA(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C 1100 CONTINUE IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'CASE')GOTO1160 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CASE')GOTO1105 GOTO1199 C 1105 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1110 IF(IHARG(NUMARG).EQ.'OFF')GOTO1110 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 C IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140 C GOTO1150 C 1110 CONTINUE DO1115I=1,MAXCHA ICHACA(I)=IDEFCA 1115 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1119 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHACA(I) 1116 FORMAT('ALL CHARACTER CASES HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1119 CONTINUE GOTO1190 C 1120 CONTINUE ICHACA(1)=IHARG(2) C IF(IFEEDB.EQ.'OFF')GOTO1129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1126)I,ICHACA(I) 1126 FORMAT('THE CASE FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1129 CONTINUE GOTO1190 C 1130 CONTINUE DO1135I=1,MAXCHA ICHACA(I)=IHARG(3) 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHACA(I) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO1190 C 1140 CONTINUE DO1145I=1,MAXCHA ICHACA(I)=IHARG(2) 1145 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1149 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHACA(I) CALL DPWRST('XXX','BUG ') 1149 CONTINUE GOTO1190 C 1150 CONTINUE IMAX=NUMARG-1 IF(MAXCHA.LT.IMAX)IMAX=MAXCHA DO1155I=1,IMAX IP1=I+1 ICHACA(I)=IHARG(IP1) 1155 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1159 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1156I=1,IMAX WRITE(ICOUT,1126)I,ICHACA(I) CALL DPWRST('XXX','BUG ') 1156 CONTINUE 1159 CONTINUE GOTO1190 C 1160 CONTINUE DO1165I=1,MAXCHA ICHACA(I)=IDEFCA 1165 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1169 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHACA(I) CALL DPWRST('XXX','BUG ') 1169 CONTINUE GOTO1190 C 1190 CONTINUE IFOUND='YES' C 1199 CONTINUE RETURN END SUBROUTINE DPCHCL(IHARG,NUMARG,IDEFCO,MAXCHA,ICHACO,IFOUND,IERROR) C C PURPOSE--DEFINE PLOT CHARACTER COLORS FOR USE IN MULTI-TRACE PLOTS. C THE COLOR FOR THE CHARACTER FOR THE I-TH TRACE C WILL BE PLACED C IN THE I-TH ELEMENT OF THE HOLLERITH C VECTOR ICHACO(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFCO C --MAXCHA C OUTPUT ARGUMENTS--ICHACO (A HOLLERITH VECTOR C WHOSE I-TH ELEMENT IS THE COLOR C FOR THE CHARACTER C ASSIGNED TO THE I-TH TRACE IN C A MULTI-TRACE PLOT. C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 1977. C UPDATED --SEPTEMBER 1980. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFCO CHARACTER*4 ICHACO CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION ICHACO(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C 1100 CONTINUE IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'COLO')GOTO1160 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'COLO')GOTO1105 GOTO1199 C 1105 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1110 IF(IHARG(NUMARG).EQ.'OFF')GOTO1110 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 C IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140 C GOTO1150 C 1110 CONTINUE DO1115I=1,MAXCHA ICHACO(I)=IDEFCO 1115 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1119 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHACO(I) 1116 FORMAT('ALL CHARACTER COLORS HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1119 CONTINUE GOTO1190 C 1120 CONTINUE ICHACO(1)=IHARG(2) C IF(IFEEDB.EQ.'OFF')GOTO1129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1126)I,ICHACO(I) 1126 FORMAT('THE COLOR FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1129 CONTINUE GOTO1190 C 1130 CONTINUE DO1135I=1,MAXCHA ICHACO(I)=IHARG(3) 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHACO(I) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO1190 C 1140 CONTINUE DO1145I=1,MAXCHA ICHACO(I)=IHARG(2) 1145 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1149 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHACO(I) CALL DPWRST('XXX','BUG ') 1149 CONTINUE GOTO1190 C 1150 CONTINUE IMAX=NUMARG-1 IF(MAXCHA.LT.IMAX)IMAX=MAXCHA DO1155I=1,IMAX IP1=I+1 ICHACO(I)=IHARG(IP1) 1155 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1159 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1156I=1,IMAX WRITE(ICOUT,1126)I,ICHACO(I) CALL DPWRST('XXX','BUG ') 1156 CONTINUE 1159 CONTINUE GOTO1190 C 1160 CONTINUE DO1165I=1,MAXCHA ICHACO(I)=IDEFCO 1165 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1169 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHACO(I) CALL DPWRST('XXX','BUG ') 1169 CONTINUE GOTO1190 C 1190 CONTINUE IFOUND='YES' C 1199 CONTINUE RETURN END SUBROUTINE DPCHEC(K,IHOL,IHOL2, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1INT1,FLOAT1,IBUGA3,IERROR) C C PURPOSE--EXAMINE COMPONENT K OF IHOL(.) AND IHOL2(.). C IF IT IS A PARAMETER NAME, DETERMINE THE VALUE C OF THE PARAMETER AND PLACE THIS VALUE C IN INT1(K) AND FLOAT1(K). C IF OTHERWISE, DO NOTHING. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--JANUARY 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHOL CHARACTER*4 IHOL2 CHARACTER*4 IHNAME CHARACTER*4 IHNAM2 CHARACTER*4 IUSE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IH CHARACTER*4 IH2 C C--------------------------------------------------------------------- C DIMENSION IHOL(*) DIMENSION IHOL2(*) C DIMENSION IHNAME(*) DIMENSION IHNAM2(*) DIMENSION IUSE(*) DIMENSION IVALUE(*) DIMENSION VALUE(*) C DIMENSION INT1(*) DIMENSION FLOAT1(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('****** AT THE BEGINNING OF DPCHEC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)K,IHOL(K),IHOL2(K) 52 FORMAT('K,IHOL(K),IHOL2(K) = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NUMNAM,IBUGA3,IERROR 53 FORMAT('NUMNAM,IBUGA3,IERROR = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') DO55I=1,NUMNAM WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) 56 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) = ', 1I8,2X,A4,2X,A4,2X,A4,I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,57)K,INT1(K),FLOAT1(K) 57 FORMAT('K,INT1(K),FLOAT1(K) = ',I8,I8,E15.7) CALL DPWRST('XXX','BUG ') 90 CONTINUE C IH=IHOL(K) IH2=IHOL2(K) IF(NUMNAM.LE.0)GOTO2799 DO2795I=1,NUMNAM IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO2796 GOTO2795 2796 CONTINUE INT1(K)=IVALUE(I) FLOAT1(K)=VALUE(I) GOTO2799 2795 CONTINUE 2799 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('****** AT THE END OF DPCHEC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)K,IHOL(K),IHOL2(K) 9012 FORMAT('K,IHOL(K),IHOL2(K) = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NUMNAM,IBUGA3,IERROR 9013 FORMAT('NUMNAM,IBUGA3,IERROR = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') DO9015I=1,NUMNAM WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) 9016 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) = ', 1I8,2X,A4,2X,A4,2X,A4,I8,E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9017)K,INT1(K),FLOAT1(K) 9017 FORMAT('K,INT1(K),FLOAT1(K) = ',I8,I8,E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPCHEX(ISTAR1,ILEN1,IX1,ISTAR2,ILEN2,IX2) C C PURPOSE--CHARACTER EXTRACTION-- C GIVEN A CHARACTER STRING IN A WORD (IX1), C MOVE THE BIT STRING WHICH STARTS IN BIT ISTAR1 C (ISTAR1 RANGES FROM 0 TO 35 IN A UNIVAC 1108, C 0 TO 31 IN AN IBM 3033, C 0 TO 59 IN A CDC 7600, ETC. C AND IS OF LENGTH ILEN1 BITS) C INTO BITS STARTING AT ISTAR2 OF LENGTH ILEN2 C (HERE ILEN2 USUALLY = ILEN1) IN THE WORD IX2. C OUTPUT THE NEW CHARACTER VARIABLE (IX2). C NOTE--0 DENOTES THE LEFT-MOST (THAT IS, THE HIGH-ORDER) BIT. C NOTE--ISTAR1 AND ISTAR2 RANGE FROM 0 TO NUMBPW-1 C THAT IS, FROM 0 TO ONE LESS THAN THE TOTLA NUMBER OF BITS PER WORD. C (FOR EXAMPLE, ON UNIVAC 1100/82--FROM 0 TO 35 C ON VAX 11/780 --FROM 0 TO 31) C NOTE--IX1 AND IX2 ARE CHARACTER*4 VARIABLES. C NOTE--THIS SUBROUTINE HAS BEEN CONSTRAINED SO THAT C NEITHER ILEN1 NOR ILEN2 ARE EXPLICITELY USED. C THIS SUBROUTINE, AS CODED, OPERATES ON THE ASSUMPTIONS THAT C 1) ILEN1 = NUMBPC (THAT IS, THE LENGTH C OF THE BIT STRING BEING MOVED IS IDENTICAL C TO THE NUMBER OF BITS PER CHARACTER ON C YOUR COMPUTER). C 2) ILEN2 = ILEN1 (THAT IS, THE LENGTH OF THE OUTPUT STRING = C THE LENGTH OF THE INPUT STRING), C 3) ISTAR1 IS SUCH THAT THE START OF THE BIT STRING C IS ALWAYS AT THE BEGINNING OF A CHARACTER C THE NET RESULT IS THAT THIS SUBROUTINE, AS CODED, C EXTRACTS EXACTLY 1 CHARACTER AND C MOVES IT TO THE POSITION OF ANOTHER CHARACTER. C THESE CONSTRAINTS WILL BE ACCEPTABLE FOR ALL USES C OF THIS SUBROUTINE BY ANY OTHER DATAPLOT SUBROUTINE. C NOTE--THE VALUES FOR NUMBPC (NUMBER OF BITS PER CHARACTER) C AND NUMBPW (NUMBER OF BITS PER WORD) ARE SET C FOR YOUR COMPUTER IN DATAPLOT SUBROUTINE INITMC. C NOTE--ALGORITHM PROVIDED BY MICHAEL VOGT C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--OCTOBER 1978. C UPDATED --JUNE 1981. C UPDATED --OCTOBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IX1 CHARACTER*4 IX2 C C--------------------------------------------------------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C **************************************************************** C ** THE FOLLOWING CODE WILL CARRY OUT C ** THE CHARACTER EXTRACTION FOR ALL COMPUTERS C ** WITH AN ANSI 77 FORTRAN COMPILER--IT MAKES C ** USE OF THE ANSI FORTRAN 77 CONSTRUCT-- C ** IY(IC:ID)=IX(IA:IB) C ** WHERE IX AND IY ARE CHARACTER*4 VARIABLES, C ** WHERE IA, IB, IC, AND ID ARE INTEGER VARIABLES, C ** AND WHERE IY(IC:ID)=IX(IA:IB) MEANS C ** TO COPY CHARACTERS IA THROUGH IB OF VARIABLE IX AND C ** PLACE THEM INTO CHARACTERS IC THROUGH ID OF VARIABLE IY. C ** WITH ALL OTHER CHARACTERS IN IY BEING UNAFFECTED. C ** USUALLY IA, IB, IC, AND ID RANGE FROM 1 TO 4. C **************************************************************** C IBYTE1=(ISTAR1+NUMBPC)/NUMBPC IBYTE2=(ISTAR2+NUMBPC)/NUMBPC IX2(IBYTE2:IBYTE2)=IX1(IBYTE1:IBYTE1) GOTO9000 C C **************************************************************** C ** CHARACTER EXTRACTION FOR THE UNIVAC 1100 SERIES. FOR COMPILE C ** (FORTRAN 1966 COMPILER) C **************************************************************** C CCCCC ISTAR1=IABS(ISTAR1) CCCCC ISTAR2=IABS(ISTAR2) C CCCCC FLD(ISTAR2,ILEN2,IX2)=FLD(ISTAR1,ILEN1,IX1) C C **************************************************************** C ** CHARACTER EXTRACTION FOR THE UNIVAC 1100 SERIES. FTN COMPILE C ** (FORTRAN 1977 COMPILER) C **************************************************************** C CCCCC ISTR1P=ISTAR1+1 CCCCC ISTR2P=ISTAR2+1 C CCCCC BITS(IX2,ISTR2P,ILEN2)=BITS(IX1,ISTR1P,ILEN1) C C *********************************************** C ** CHARACTER EXTRACTION FOR THE VAX-11/780 ** C ** (FORTRAN 1966 COMPILER) C *********************************************** C CCCCC LOGICAL*1 IX1(4) CCCCC LOGICAL*1 IX2(4) C CCCCC I1=(ISTAR1+8)/8 CCCCC I2=(ISTAR2+8)/8 CCCCC IX2(I2)=IX1(I1) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE RETURN END SUBROUTINE DPCHFI(IHARG,NUMARG,IDEFFI,MAXCHA,ICHAFI,IFOUND,IERROR) C C PURPOSE--DEFINE PLOT CHARACTER FILL SWITCH FOR USE IN MULTI-TRACE PLOTS. C THE FILL SWITCH FOR THE CHARACTER FOR THE I-TH TRACE C WILL BE PLACED C IN THE I-TH ELEMENT OF THE HOLLERITH C VECTOR ICHAFI(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFFI C --MAXCHA C OUTPUT ARGUMENTS--ICHAFI (A HOLLERITH VECTOR C WHOSE I-TH ELEMENT IS THE FILL SWITCH C FOR THE CHARACTER C ASSIGNED TO THE I-TH TRACE IN C A MULTI-TRACE PLOT. C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 1977. C UPDATED --SEPTEMBER 1980. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --JUNE 1998. CHECK FOR CHARCTER FILL COLOR C (SKIP IF ABOVE FOUND) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFFI CHARACTER*4 ICHAFI CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION ICHAFI(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C 1100 CONTINUE IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'FILL')GOTO1160 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'FILL')GOTO1105 GOTO1199 C 1105 CONTINUE CCCCC IF(IHARG(NUMARG).EQ.'ON')GOTO1110 CCCCC IF(IHARG(NUMARG).EQ.'OFF')GOTO1110 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 CCCCC ADD FOLLOWING LINE JUNE 1998 IF(IHARG(NUMARG).EQ.'COLO')GOTO1199 C IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140 C GOTO1150 C 1110 CONTINUE DO1115I=1,MAXCHA ICHAFI(I)=IDEFFI IF(IHARG(NUMARG).EQ.'ON')ICHAFI(I)='ON' IF(IHARG(NUMARG).EQ.'OFF')ICHAFI(I)='OFF' IF(IHARG(NUMARG).EQ.'AUTO')ICHAFI(I)='ON' 1115 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1119 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHAFI(I) 1116 FORMAT('ALL CHARACTER FILL SWITCHES HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1119 CONTINUE GOTO1190 C 1120 CONTINUE ICHAFI(1)=IHARG(2) C IF(IFEEDB.EQ.'OFF')GOTO1129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1126)I,ICHAFI(I) 1126 FORMAT('THE FILL SWITCH FOR CHARACTER ',I6, 1' HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1129 CONTINUE GOTO1190 C 1130 CONTINUE DO1135I=1,MAXCHA ICHAFI(I)=IHARG(3) 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHAFI(I) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO1190 C 1140 CONTINUE DO1145I=1,MAXCHA ICHAFI(I)=IHARG(2) 1145 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1149 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHAFI(I) CALL DPWRST('XXX','BUG ') 1149 CONTINUE GOTO1190 C 1150 CONTINUE IMAX=NUMARG-1 IF(MAXCHA.LT.IMAX)IMAX=MAXCHA DO1155I=1,IMAX IP1=I+1 ICHAFI(I)=IHARG(IP1) 1155 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1159 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1156I=1,IMAX WRITE(ICOUT,1126)I,ICHAFI(I) CALL DPWRST('XXX','BUG ') 1156 CONTINUE 1159 CONTINUE GOTO1190 C 1160 CONTINUE DO1165I=1,MAXCHA ICHAFI(I)=IDEFFI IF(IHARG(1).EQ.'ON')ICHAFI(I)='ON' IF(IHARG(1).EQ.'OFF')ICHAFI(I)='OFF' IF(IHARG(1).EQ.'AUTO')ICHAFI(I)='ON' IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'FILL')ICHAFI(I)='ON' 1165 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1169 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHAFI(I) CALL DPWRST('XXX','BUG ') 1169 CONTINUE GOTO1190 C 1190 CONTINUE IFOUND='YES' C 1199 CONTINUE RETURN END SUBROUTINE DPCHFO(IHARG,NUMARG,IDEFFO,MAXCHA,ICHAFO,IFOUND,IERROR) C C PURPOSE--DEFINE PLOT CHARACTER FONTS FOR USE IN MULTI-TRACE PLOTS. C THE FONT FOR THE CHARACTER FOR THE I-TH TRACE C WILL BE PLACED C IN THE I-TH ELEMENT OF THE HOLLERITH C VECTOR ICHAFO(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFFO C --MAXCHA C OUTPUT ARGUMENTS--ICHAFO (A HOLLERITH VECTOR C WHOSE I-TH ELEMENT IS THE FONT C FOR THE CHARACTER C ASSIGNED TO THE I-TH TRACE IN C A MULTI-TRACE PLOT. C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--ALAN HECKERT C COMPUTER SERVICES DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 1977. C UPDATED --SEPTEMBER 1980. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFFO CHARACTER*4 ICHAFO CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION ICHAFO(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C 1100 CONTINUE IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'FONT')GOTO1160 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'FONT')GOTO1105 GOTO1199 C 1105 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1110 IF(IHARG(NUMARG).EQ.'OFF')GOTO1110 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 C IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140 C GOTO1150 C 1110 CONTINUE DO1115I=1,MAXCHA ICHAFO(I)=IDEFFO 1115 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1119 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHAFO(I) 1116 FORMAT('ALL CHARACTER FONTS HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1119 CONTINUE GOTO1190 C 1120 CONTINUE ICHAFO(1)=IHARG(2) C IF(IFEEDB.EQ.'OFF')GOTO1129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1126)I,ICHAFO(I) 1126 FORMAT('THE FONT FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1129 CONTINUE GOTO1190 C 1130 CONTINUE DO1135I=1,MAXCHA ICHAFO(I)=IHARG(3) 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHAFO(I) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO1190 C 1140 CONTINUE DO1145I=1,MAXCHA ICHAFO(I)=IHARG(2) 1145 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1149 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHAFO(I) CALL DPWRST('XXX','BUG ') 1149 CONTINUE GOTO1190 C 1150 CONTINUE IMAX=NUMARG-1 IF(MAXCHA.LT.IMAX)IMAX=MAXCHA DO1155I=1,IMAX IP1=I+1 ICHAFO(I)=IHARG(IP1) 1155 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1159 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1156I=1,IMAX WRITE(ICOUT,1126)I,ICHAFO(I) CALL DPWRST('XXX','BUG ') 1156 CONTINUE 1159 CONTINUE GOTO1190 C 1160 CONTINUE DO1165I=1,MAXCHA ICHAFO(I)=IDEFFO 1165 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1169 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHAFO(I) CALL DPWRST('XXX','BUG ') 1169 CONTINUE GOTO1190 C 1190 CONTINUE IFOUND='YES' C 1199 CONTINUE RETURN END SUBROUTINE DPCHGR(ICHAR2,ICHARN,IBUG,IFOUND) C C PURPOSE--NUMERICALLY CONVERT A GREEK ALPHABETIC CHARACTER. C CONVERT A PACKED ALPHABETIC STRING C (PACKED INTO 1 COMPUTER WORD C WITH ONLY THE FIRST 4 CHARACTERS BEING SIGNIFICANT) C (ALPH... TO OMEG...) INTO A NUMERIC VALUE C (1 TO 24). C INPUT ARGUMENTS--ICHAR2 (A HOLLERITH VARIABLE C CONTAINING THE HOLLERITH C CHARACTER(S) OF INTEREST. C OUTPUT ARGUMENTS--ICHARN (AN INTEGER VARIABLE C CONTAINING THE NUMERIC C DESIGNATION FOR THE C ALPHABETIC CHARACTER. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--MARCH 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR2 CHARACTER*4 IBUG CHARACTER*4 IFOUND C C-----COMMON VARIABLES (BUGS & ERROR)------------------------------------------- C CHARACTER*4 IBUGG4 CHARACTER*4 ISUBG4 CHARACTER*4 IERRG4 C COMMON /ICOMBE/IBUGG4,ISUBG4,IERRG4 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CHGR')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPCHGR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHAR2 52 FORMAT('ICHAR2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGG4,ISUBG4 59 FORMAT('IBUGG4,ISUBG4 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************** C ** STEP 1-- ** C ** CONVERT THE CHARACTER ** C ********************************** C IF(ICHAR2.EQ.'ALPH')GOTO100 IF(ICHAR2.EQ.'BETA')GOTO200 IF(ICHAR2.EQ.'GAMM')GOTO300 IF(ICHAR2.EQ.'DELT')GOTO400 IF(ICHAR2.EQ.'EPSI')GOTO500 IF(ICHAR2.EQ.'ZETA')GOTO600 IF(ICHAR2.EQ.'ETA')GOTO700 IF(ICHAR2.EQ.'THET')GOTO800 IF(ICHAR2.EQ.'IOTA')GOTO900 IF(ICHAR2.EQ.'KAPP')GOTO1000 IF(ICHAR2.EQ.'LAMB')GOTO1100 IF(ICHAR2.EQ.'MU')GOTO1200 IF(ICHAR2.EQ.'NU')GOTO1300 IF(ICHAR2.EQ.'XI')GOTO1400 IF(ICHAR2.EQ.'OMIC')GOTO1500 IF(ICHAR2.EQ.'PI')GOTO1600 IF(ICHAR2.EQ.'RHO')GOTO1700 IF(ICHAR2.EQ.'SIGM')GOTO1800 IF(ICHAR2.EQ.'TAU')GOTO1900 IF(ICHAR2.EQ.'UPSI')GOTO2000 IF(ICHAR2.EQ.'PHI')GOTO2100 IF(ICHAR2.EQ.'CHI')GOTO2200 IF(ICHAR2.EQ.'PSI')GOTO2300 IF(ICHAR2.EQ.'OMEG')GOTO2400 GOTO7900 C 100 CONTINUE ICHARN=1 GOTO8000 C 200 CONTINUE ICHARN=2 GOTO8000 C 300 CONTINUE ICHARN=3 GOTO8000 C 400 CONTINUE ICHARN=4 GOTO8000 C 500 CONTINUE ICHARN=5 GOTO8000 C 600 CONTINUE ICHARN=6 GOTO8000 C 700 CONTINUE ICHARN=7 GOTO8000 C 800 CONTINUE ICHARN=8 GOTO8000 C 900 CONTINUE ICHARN=9 GOTO8000 C 1000 CONTINUE ICHARN=10 GOTO8000 C 1100 CONTINUE ICHARN=11 GOTO8000 C 1200 CONTINUE ICHARN=12 GOTO8000 C 1300 CONTINUE ICHARN=13 GOTO8000 C 1400 CONTINUE ICHARN=14 GOTO8000 C 1500 CONTINUE ICHARN=15 GOTO8000 C 1600 CONTINUE ICHARN=16 GOTO8000 C 1700 CONTINUE ICHARN=17 GOTO8000 C 1800 CONTINUE ICHARN=18 GOTO8000 C 1900 CONTINUE ICHARN=19 GOTO8000 C 2000 CONTINUE ICHARN=20 GOTO8000 C 2100 CONTINUE ICHARN=21 GOTO8000 C 2200 CONTINUE ICHARN=22 GOTO8000 C 2300 CONTINUE ICHARN=23 GOTO8000 C 2400 CONTINUE ICHARN=24 GOTO8000 C 7900 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7911) C7911 FORMAT('***** ERROR IN DPCHNU--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7912) C7912 FORMAT(' NO MATCH FOUND FOR INPUT CHARACTER.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7913)ICHAR2 C7913 FORMAT(' INPUT CHAR2ACTER = ',A4) CCCCC CALL DPWRST('XXX','BUG ') IFOUND='NO' GOTO9000 C 8000 CONTINUE IFOUND='YES' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CHGR')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPCHGR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND 9012 FORMAT('IFOUND = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICHAR2,ICHARN 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)IBUGG4,ISUBG4,IFOUND 9019 FORMAT('IBUGG4,ISUBG4,IFOUND = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPCHHW(IHARG,IARGT,IARG,ARG,NUMARG, 1MAXCHA, 1PCHAHE,PCHAWI,PDEFHE,PDEFWI, 1IFOUND,IERROR) C C PURPOSE--DEFINE PLOT CHARACTER HEIGHT AND WIDTH C FOR USE IN MULTI-TRACE PLOTS. C THE HEIGHT AND WIDTH FOR THE CHARACTER FOR THE I-TH TRACE C WILL BE PLACED C IN THE I-TH ELEMENT OF THE FLOATING POINT C VECTORS PCHAHE(.) AND PCHAWI(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --ARG (A HOLLERITH VECTOR) C --NUMARG C --MAXCHA C OUTPUT ARGUMENTS--PCHAHE (A FLOATING POINT VECTOR C WHOSE I-TH ELEMENT IS THE HEIGHT C FOR THE CHARACTER C ASSIGNED TO THE I-TH TRACE IN C A MULTI-TRACE PLOT. C --PCHAWI (A FLOATING POINT VECTOR C WHOSE I-TH ELEMENT IS THE WIDTH C FOR THE CHARACTER C ASSIGNED TO THE I-TH TRACE IN C A MULTI-TRACE PLOT. C --PDEFHE = DEFAULT CHARACTER HEIGHT C --PDEFWI = DEFAULT CHARACTER WIDTH C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--88/8 C ORIGINAL VERSION--AUGUST 1988. C UPDATED --JANUARY 1995. ALLOW ? AS ARGUMENT (FOR HELP) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) DIMENSION ARG(*) C DIMENSION PCHAHE(*) DIMENSION PCHAWI(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C 1100 CONTINUE C IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'HW')GOTO1160 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'HW')GOTO1105 GOTO9000 C 1105 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1110 IF(IHARG(NUMARG).EQ.'OFF')GOTO1110 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 IF(IHARG(NUMARG).EQ.'?')GOTO1200 C IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160 IF(NUMARG.EQ.3)GOTO1120 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'ALL')GOTO1130 IF(NUMARG.GE.4.AND.IHARG(4).EQ.'ALL')GOTO1140 C GOTO1150 C 1110 CONTINUE DO1115I=1,MAXCHA PCHAWI(I)=PDEFHE PCHAHE(I)=PDEFWI 1115 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1119 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116) 1116 FORMAT('THE HEIGHTS AND WIDTHS OF ALL CHARACTERS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1117)PCHAHE(I),PCHAWI(I) 1117 FORMAT(' HAVE JUST BEEN SET TO ',2E15.7) CALL DPWRST('XXX','BUG ') 1119 CONTINUE GOTO2190 C 1120 CONTINUE I=1 IF(IARGT(2).NE.'NUMB'.OR.IARGT(3).NE.'NUMB')GOTO1180 PCHAHE(1)=ARG(2) PCHAWI(1)=ARG(3) C IF(IFEEDB.EQ.'OFF')GOTO1129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1126)I 1126 FORMAT('THE HEIGHT AND WIDTH OF CHARACTER ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1127)PCHAHE(I),PCHAWI(I) 1127 FORMAT(' HAS JUST BEEN SET TO ',2E15.7) CALL DPWRST('XXX','BUG ') 1129 CONTINUE GOTO2190 C 1130 CONTINUE I=1 IF(IARGT(3).NE.'NUMB'.OR.IARGT(4).NE.'NUMB')GOTO1180 DO1135I=1,MAXCHA PCHAHE(I)=ARG(3) PCHAWI(I)=ARG(4) 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1117)PCHAHE(I),PCHAWI(I) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO2190 C 1140 CONTINUE I=1 IF(IARGT(2).NE.'NUMB'.OR.IARGT(3).NE.'NUMB')GOTO1180 DO1145I=1,MAXCHA PCHAHE(I)=ARG(2) PCHAWI(I)=ARG(3) 1145 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1149 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1117)PCHAHE(I),PCHAWI(I) CALL DPWRST('XXX','BUG ') 1149 CONTINUE GOTO2190 C 1150 CONTINUE IMAX=NUMARG-1 IF(MAXCHA.LT.IMAX)IMAX=MAXCHA J=0 DO1155I=1,IMAX,2 IP1=I+1 IP2=I+2 IF(IARGT(IP1).NE.'NUMB')GOTO1180 IF(IARGT(IP2).NE.'NUMB')GOTO1180 J=J+1 PCHAHE(J)=ARG(IP1) PCHAWI(J)=ARG(IP2) 1155 CONTINUE JMAX=J C IF(IFEEDB.EQ.'OFF')GOTO1159 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1156I=1,JMAX WRITE(ICOUT,1126)I CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1127)PCHAHE(I),PCHAWI(I) CALL DPWRST('XXX','BUG ') 1156 CONTINUE 1159 CONTINUE GOTO2190 C 1160 CONTINUE DO1165I=1,MAXCHA PCHAHE(I)=PDEFHE PCHAWI(I)=PDEFWI 1165 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1169 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1117)PCHAHE(I),PCHAWI(I) CALL DPWRST('XXX','BUG ') 1169 CONTINUE GOTO2190 C 1180 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('***** ERROR IN DPCHHW--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182) 1182 FORMAT('THE HEIGHTS AND WIDTHS OF CHARACTERS MUST BE NUMERIC') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1183) 1183 FORMAT('HOWEVER, THE SPECIFIED CHARACTER HEIGHT AND WIDTH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1184)I 1184 FORMAT('FOR CHARACTER ',I6,' WAS NON-NUMERIC.') CALL DPWRST('XXX','BUG ') GOTO9000 C CCCCC THE FOLLOWING SECTION WAS ADDED JANUARY 1995 1200 CONTINUE IFOUND='YES' IF(IFEEDB.EQ.'OFF')GOTO1229 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1221)I,PCHAHE(I) 1221 FORMAT('THE CURRENT HEIGHT FOR CHARACTER ',I6,' IS ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1222)I,PCHAWI(I) 1222 FORMAT('THE CURRENT WIDTH FOR CHARACTER ',I6,' IS ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1223)I,PDEFHE 1223 FORMAT('THE DEFAULT HEIGHT FOR CHARACTER ',I6,' IS ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1224)I,PDEFWI 1224 FORMAT('THE DEFAULT WIDTH FOR CHARACTER ',I6,' IS ',E15.7) CALL DPWRST('XXX','BUG ') 1229 CONTINUE GOTO9000 C 2190 CONTINUE IFOUND='YES' C 9000 CONTINUE RETURN END SUBROUTINE DPCHJU(IHARG,NUMARG,MAXCHA,ICHAJU,IFOUND,IERROR) C C PURPOSE--DEFINE PLOT CHARACTER JUSTIFICATION FOR USE IN MULTI-TRACE PLOTS. C THE JUSTIFICATION FOR THE CHARACTER FOR THE I-TH TRACE C WILL BE PLACED C IN THE I-TH ELEMENT OF THE HOLLERITH C VECTOR ICHAJU(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG C --MAXCHA C OUTPUT ARGUMENTS--ICHAJU (A HOLLERITH VECTOR C WHOSE I-TH ELEMENT IS THE JUSTIFICATION C FOR THE CHARACTER C ASSIGNED TO THE I-TH TRACE IN C A MULTI-TRACE PLOT. C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--NOVEMBER 1986. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 ICHAJU CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION ICHAJU(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C 1100 CONTINUE IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'JUST')GOTO1160 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'JUST')GOTO1105 GOTO1199 C 1105 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1110 IF(IHARG(NUMARG).EQ.'OFF')GOTO1110 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 C IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140 C GOTO1150 C 1110 CONTINUE DO1115I=1,MAXCHA ICHAJU(I)='CENT' 1115 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1119 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHAJU(I) 1116 FORMAT('ALL CHARACTER JUSTIFICATIONS HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1119 CONTINUE GOTO1190 C 1120 CONTINUE ICHAJU(1)=IHARG(2) C IF(IFEEDB.EQ.'OFF')GOTO1129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1126)I,ICHAJU(I) 1126 FORMAT('THE JUSTIFICATION FOR CHARACTER ',I6, 1' HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1129 CONTINUE GOTO1190 C 1130 CONTINUE DO1135I=1,MAXCHA ICHAJU(I)=IHARG(3) 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHAJU(I) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO1190 C 1140 CONTINUE DO1145I=1,MAXCHA ICHAJU(I)=IHARG(2) 1145 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1149 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHAJU(I) CALL DPWRST('XXX','BUG ') 1149 CONTINUE GOTO1190 C 1150 CONTINUE IMAX=NUMARG-1 IF(MAXCHA.LT.IMAX)IMAX=MAXCHA DO1155I=1,IMAX IP1=I+1 ICHAJU(I)=IHARG(IP1) 1155 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1159 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1156I=1,IMAX WRITE(ICOUT,1126)I,ICHAJU(I) CALL DPWRST('XXX','BUG ') 1156 CONTINUE 1159 CONTINUE GOTO1190 C 1160 CONTINUE DO1165I=1,MAXCHA ICHAJU(I)='CENT' 1165 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1169 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116)ICHAJU(I) CALL DPWRST('XXX','BUG ') 1169 CONTINUE GOTO1190 C 1190 CONTINUE IFOUND='YES' C 1199 CONTINUE RETURN END SUBROUTINE DPCHLI(ICONT,NUMCPL,YSTART,YSTOP,XSTART,XSTOP, 1J,JD,Y2,X2,D2,IERROR) C C PURPOSE--GENERATE PLOT COORDINATES FOR A POINT C OR FOR A LINE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--JANUARY 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICONT CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IERROR='NO' C NUMCP2=NUMCPL IF(ICONT.EQ.'ON')NUMCP2=2 ANUMC2=NUMCP2 C IF(YSTART.EQ.YSTOP)GOTO200 IF(XSTART.EQ.XSTOP)GOTO1300 GOTO1400 C 200 CONTINUE IF(XSTART.EQ.XSTOP)GOTO1100 GOTO1200 C C *************************** C ** STEP 2.1-- ** C ** TREAT THE CASE WHEN ** C ** Y HAS NO CHANGE ** C ** X HAS NO CHANGE ** C *************************** C 1100 CONTINUE J=J+1 JD=JD+1 Y2(J)=YSTART X2(J)=XSTART D2(J)=JD GOTO9000 C C *************************** C ** STEP 2.2-- ** C ** TREAT THE CASE WHEN ** C ** Y HAS NO CHANGE ** C ** X HAS CHANGE ** C *************************** C 1200 CONTINUE JD=JD+1 XDEL=XSTOP-XSTART DO1210I=1,NUMCP2 J=J+1 AI=I P=(AI-1.0)/(ANUMC2-1.0) XP=XSTART+P*XDEL Y2(J)=YSTART X2(J)=XP D2(J)=JD 1210 CONTINUE GOTO9000 C C *************************** C ** STEP 2.3-- ** C ** TREAT THE CASE WHEN ** C ** Y HAS CHANGE ** C ** X HAS NO CHANGE ** C *************************** C 1300 CONTINUE JD=JD+1 YDEL=YSTOP-YSTART DO1310I=1,NUMCP2 J=J+1 AI=I P=(AI-1.0)/(ANUMC2-1.0) YP=YSTART+P*YDEL Y2(J)=YP X2(J)=XSTART D2(J)=JD 1310 CONTINUE GOTO9000 C C *************************** C ** STEP 2.4-- ** C ** TREAT THE CASE WHEN ** C ** Y HAS CHANGE ** C ** X HAS CHANGE ** C *************************** C 1400 CONTINUE JD=JD+1 XDEL=XSTOP-XSTART YDEL=YSTOP-YSTART DO1410I=1,NUMCP2 J=J+1 AI=I P=(AI-1.0)/(ANUMC2-1.0) XP=XSTART+P*XDEL YP=YSTART+P*YDEL Y2(J)=YP X2(J)=XP D2(J)=JD 1410 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE RETURN END SUBROUTINE DPCHLR(ISTRIN,NUMCHS,ILOCLP,ILOCRP,IFOULR,IBUG,IERROR) C C PURPOSE--CHECK FOR A LEFT AND RIGHT PARENTHESIS. C CHECK FOR A LEFT PARENTHESIS IN LOCATION ILOCLP. C CHECK FOR A RIGHT PARENTHESIS IN LOCATION ILOCRP. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--APRIL 1981. C UPDATED --FEBRUARY 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ISTRIN CHARACTER*4 IFOULR CHARACTER*4 IBUG CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION ISTRIN(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOBE.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOULR='NO' IERROR='NO' C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CHLR')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPCHLR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NUMCHS,ILOCLP,ILOCRP 52 FORMAT('NUMCHS,ILOCLP,ILOCRP = ',I8,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)(ISTRIN(I),I=1,NUMCHS) 53 FORMAT('(ISTRIN(I),I=1,NUMCHS) = ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGG4,ISUBG4,IERRG4 59 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C IF(ILOCLP.LT.1)GOTO1200 IF(ILOCLP.GT.NUMCHS)GOTO1200 C IF(ILOCRP.LT.1)GOTO1200 IF(ILOCRP.GT.NUMCHS)GOTO1200 C IF(ISTRIN(ILOCLP).NE.'(')GOTO1200 IF(ISTRIN(ILOCRP).NE.')')GOTO1200 C 1100 CONTINUE IFOULR='YES' GOTO9000 C 1200 CONTINUE IFOULR='NO' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CHLR')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPCHLR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOULR 9012 FORMAT('IFOULR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)IBUGG4,ISUBG4,IERRG4 9019 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPCHMA(ICHAR2,ICHARN,IBUG,IFOUND) C C PURPOSE--CONVERT A MATHEMATICAL SYMBOL C INTO A NUMERIC VALUE C (1 TO 66). C INPUT ARGUMENTS--ICHAR2 (A HOLLERITH VARIABLE C CONTAINING THE HOLLERITH C CHARACTER(S) OF INTEREST. C OUTPUT ARGUMENTS--ICHARN (AN INTEGER VARIABLE C CONTAINING THE NUMERIC C DESIGNATION FOR THE C ALPHABETIC CHARACTER. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--MARCH 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MAY 1982. C UPDATED --APRIL 1987. C UPDATED --AUGUST 1992. ADD SYNONYMS FOR REVERSE C TRIANGLE (TO AGREE WITH C DOCUMENTATION), ADD ARROW CASE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR2 CHARACTER*4 IBUG CHARACTER*4 IFOUND C CHARACTER*1 IBASLC C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOBE.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CHMA')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPCHMA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHAR2 52 FORMAT('ICHAR2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGG4,ISUBG4 59 FORMAT('IBUGG4,ISUBG4 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************** C ** STEP 1-- ** C ** CONVERT THE CHARACTER ** C ********************************** C IF(ICHAR2.EQ.'/ ')GOTO100 IF(ICHAR2.EQ.'( ')GOTO200 IF(ICHAR2.EQ.') ')GOTO300 IF(ICHAR2.EQ.'[ ')GOTO400 IF(ICHAR2.EQ.'LBRA')GOTO400 IF(ICHAR2.EQ.'] ')GOTO500 IF(ICHAR2.EQ.'RBRA')GOTO500 IF(ICHAR2.EQ.'{ ')GOTO600 IF(ICHAR2.EQ.'LCBR')GOTO600 IF(ICHAR2.EQ.'} ')GOTO700 IF(ICHAR2.EQ.'RCBR')GOTO700 IF(ICHAR2.EQ.'LELB')GOTO800 IF(ICHAR2.EQ.'RELB')GOTO900 IF(ICHAR2.EQ.'| ')GOTO1000 IF(ICHAR2.EQ.'VBAR')GOTO1000 IF(ICHAR2.EQ.': ')GOTO1100 IF(ICHAR2.EQ.'DVBA')GOTO1100 IF(ICHAR2.EQ.'COLO')GOTO1100 IF(ICHAR2.EQ.'- ')GOTO1200 IF(ICHAR2.EQ.'MINU')GOTO1200 IF(ICHAR2.EQ.'+ ')GOTO1300 IF(ICHAR2.EQ.'PLUS')GOTO1300 IF(ICHAR2.EQ.'CROS')GOTO1300 IF(ICHAR2.EQ.'+- ')GOTO1400 IF(ICHAR2.EQ.'-+ ')GOTO1500 IF(ICHAR2.EQ.'TIME')GOTO1600 IF(ICHAR2.EQ.'DOTP')GOTO1700 IF(ICHAR2.EQ.'/ ')GOTO1800 IF(ICHAR2.EQ.'DIVI')GOTO1800 IF(ICHAR2.EQ.'SLAS')GOTO1800 IF(ICHAR2.EQ.'= ')GOTO1900 IF(ICHAR2.EQ.'EQUA')GOTO1900 IF(ICHAR2.EQ.'NOT=')GOTO2000 IF(ICHAR2.EQ.'<>')GOTO2000 IF(ICHAR2.EQ.'><')GOTO2000 IF(ICHAR2.EQ.'EQUI')GOTO2100 IF(ICHAR2.EQ.'< ')GOTO2200 IF(ICHAR2.EQ.'LT ')GOTO2200 IF(ICHAR2.EQ.'> ')GOTO2300 IF(ICHAR2.EQ.'GT ')GOTO2300 IF(ICHAR2.EQ.'<= ')GOTO2400 IF(ICHAR2.EQ.'=< ')GOTO2400 IF(ICHAR2.EQ.'LTEQ')GOTO2400 IF(ICHAR2.EQ.'>= ')GOTO2500 IF(ICHAR2.EQ.'=> ')GOTO2500 IF(ICHAR2.EQ.'GTEQ')GOTO2500 IF(ICHAR2.EQ.'VARI')GOTO2600 IF(ICHAR2.EQ.'APPR')GOTO2700 IF(ICHAR2.EQ.'~ ')GOTO2700 IF(ICHAR2.EQ.'TILD')GOTO2700 IF(ICHAR2.EQ.'CARA')GOTO2800 IF(ICHAR2.EQ.'PRIM')GOTO2900 IF(ICHAR2.EQ.'` ')GOTO3000 IF(ICHAR2.EQ.'LACC')GOTO3000 IF(ICHAR2.EQ.'BREV')GOTO3100 IF(ICHAR2.EQ.'RQUO')GOTO3200 IF(ICHAR2.EQ.'LQUO')GOTO3300 IF(ICHAR2.EQ.'NASP')GOTO3400 IF(ICHAR2.EQ.'IASP')GOTO3500 IF(ICHAR2.EQ.'RADI')GOTO3600 IF(ICHAR2.EQ.'SUBS')GOTO3700 IF(ICHAR2.EQ.'UNIO')GOTO3800 IF(ICHAR2.EQ.'SUPE')GOTO3900 IF(ICHAR2.EQ.'INTR')GOTO4000 IF(ICHAR2.EQ.'ELEM')GOTO4100 IF(ICHAR2.EQ.'RARR')GOTO4200 IF(ICHAR2.EQ.'^ ')GOTO4300 IF(ICHAR2.EQ.'UARR')GOTO4300 IF(ICHAR2.EQ.'LARR')GOTO4400 IF(ICHAR2.EQ.'DARR')GOTO4500 IF(ICHAR2.EQ.'PART')GOTO4600 IF(ICHAR2.EQ.'DEL ')GOTO4700 IF(ICHAR2.EQ.'LRAD')GOTO4800 IF(ICHAR2.EQ.'INTE')GOTO4900 IF(ICHAR2.EQ.'CINT')GOTO5000 IF(ICHAR2.EQ.'INFI')GOTO5100 IF(ICHAR2.EQ.'% ')GOTO5200 IF(ICHAR2.EQ.'& ')GOTO5300 IF(ICHAR2.EQ.'@ ')GOTO5400 IF(ICHAR2.EQ.'$ ')GOTO5500 IF(ICHAR2.EQ.'# ')GOTO5600 IF(ICHAR2.EQ.'PARA')GOTO5700 IF(ICHAR2.EQ.'DAGG')GOTO5800 IF(ICHAR2.EQ.'DDAG')GOTO5900 IF(ICHAR2.EQ.'THEX')GOTO6000 IF(ICHAR2.EQ.'PROD')GOTO6100 IF(ICHAR2.EQ.'SUMM')GOTO6200 IF(ICHAR2.EQ.'THFO')GOTO6300 IF(ICHAR2.EQ.'LVBA')GOTO6400 IF(ICHAR2.EQ.'HBAR')GOTO6500 IF(ICHAR2.EQ.'LHBA')GOTO6600 C IF(ICHAR2.EQ.'. ')GOTO10100 IF(ICHAR2.EQ.'POIN')GOTO10100 IF(ICHAR2.EQ.'PO ')GOTO10100 IF(ICHAR2.EQ.'PT ')GOTO10100 IF(ICHAR2.EQ.'CIRC')GOTO10200 IF(ICHAR2.EQ.'CI ')GOTO10200 IF(ICHAR2.EQ.'SQUA')GOTO10300 IF(ICHAR2.EQ.'SQ ')GOTO10300 IF(ICHAR2.EQ.'TRIA')GOTO10400 IF(ICHAR2.EQ.'TR ')GOTO10400 IF(ICHAR2.EQ.'DIAM')GOTO10500 IF(ICHAR2.EQ.'DI ')GOTO10500 IF(ICHAR2.EQ.'STAR')GOTO10600 IF(ICHAR2.EQ.'ST ')GOTO10600 IF(ICHAR2.EQ.'* ')GOTO10700 IF(ICHAR2.EQ.'ASTE')GOTO10700 IF(ICHAR2.EQ.'AS ')GOTO10700 IF(ICHAR2.EQ.'TRIR')GOTO10800 IF(ICHAR2.EQ.'TRII')GOTO10800 C AUGUST 1992. ADD FOLLOWING 2 LINES (TO MAKE DOCUMENTATION CORRECT) IF(ICHAR2.EQ.'REVT')GOTO10800 IF(ICHAR2.EQ.'RT ')GOTO10800 C IF(ICHAR2.EQ.'BARU')GOTO10900 IF(ICHAR2.EQ.'BU ')GOTO10900 IF(ICHAR2.EQ.'BARV')GOTO10900 IF(ICHAR2.EQ.'BV ')GOTO10900 IF(ICHAR2.EQ.'BARH')GOTO11000 IF(ICHAR2.EQ.'BH ')GOTO11000 IF(ICHAR2.EQ.'ARRU')GOTO11100 IF(ICHAR2.EQ.'AU ')GOTO11100 IF(ICHAR2.EQ.'ARRD')GOTO11200 IF(ICHAR2.EQ.'AD ')GOTO11200 IF(ICHAR2.EQ.'ARRL')GOTO11300 IF(ICHAR2.EQ.'AL ')GOTO11300 IF(ICHAR2.EQ.'ARRR')GOTO11400 IF(ICHAR2.EQ.'AR ')GOTO11400 CALL DPCONA(92,IBASLC) IF(ICHAR2.EQ.IBASLC)GOTO11500 IF(ICHAR2.EQ.'BASL')GOTO11500 IF(ICHAR2.EQ.'BACK')GOTO11500 IF(ICHAR2.EQ.'BS ')GOTO11500 IF(ICHAR2.EQ.'_ ')GOTO11600 IF(ICHAR2.EQ.'UNDE')GOTO11600 IF(ICHAR2.EQ.'CUBE')GOTO11700 IF(ICHAR2.EQ.'PYRA')GOTO11800 C AUGUST 1992. ADD AN ARROW OPTION IF(ICHAR2.EQ.'ARRO')GOTO11900 IF(ICHAR2.EQ.'ARRH')GOTO11900 IF(ICHAR2.EQ.'VECT')GOTO11900 C GOTO17900 C 100 CONTINUE ICHARN=1 GOTO18000 C 200 CONTINUE ICHARN=2 GOTO18000 C 300 CONTINUE ICHARN=3 GOTO18000 C 400 CONTINUE ICHARN=4 GOTO18000 C 500 CONTINUE ICHARN=5 GOTO18000 C 600 CONTINUE ICHARN=6 GOTO18000 C 700 CONTINUE ICHARN=7 GOTO18000 C 800 CONTINUE ICHARN=8 GOTO18000 C 900 CONTINUE ICHARN=9 GOTO18000 C 1000 CONTINUE ICHARN=10 GOTO18000 C 1100 CONTINUE ICHARN=11 GOTO18000 C 1200 CONTINUE ICHARN=12 GOTO18000 C 1300 CONTINUE ICHARN=13 GOTO18000 C 1400 CONTINUE ICHARN=14 GOTO18000 C 1500 CONTINUE ICHARN=15 GOTO18000 C 1600 CONTINUE ICHARN=16 GOTO18000 C 1700 CONTINUE ICHARN=17 GOTO18000 C 1800 CONTINUE ICHARN=18 GOTO18000 C 1900 CONTINUE ICHARN=19 GOTO18000 C 2000 CONTINUE ICHARN=20 GOTO18000 C 2100 CONTINUE ICHARN=21 GOTO18000 C 2200 CONTINUE ICHARN=22 GOTO18000 C 2300 CONTINUE ICHARN=23 GOTO18000 C 2400 CONTINUE ICHARN=24 GOTO18000 C 2500 CONTINUE ICHARN=25 GOTO18000 C 2600 CONTINUE ICHARN=26 GOTO18000 C 2700 CONTINUE ICHARN=27 GOTO18000 C 2800 CONTINUE ICHARN=28 GOTO18000 C 2900 CONTINUE ICHARN=29 GOTO18000 C 3000 CONTINUE ICHARN=30 GOTO18000 C 3100 CONTINUE ICHARN=31 GOTO18000 C 3200 CONTINUE ICHARN=32 GOTO18000 C 3300 CONTINUE ICHARN=33 GOTO18000 C 3400 CONTINUE ICHARN=34 GOTO18000 C 3500 CONTINUE ICHARN=35 GOTO18000 C 3600 CONTINUE ICHARN=36 GOTO18000 C 3700 CONTINUE ICHARN=37 GOTO18000 C 3800 CONTINUE ICHARN=38 GOTO18000 C 3900 CONTINUE ICHARN=39 GOTO18000 C 4000 CONTINUE ICHARN=40 GOTO18000 C 4100 CONTINUE ICHARN=41 GOTO18000 C 4200 CONTINUE ICHARN=42 GOTO18000 C 4300 CONTINUE ICHARN=43 GOTO18000 C 4400 CONTINUE ICHARN=44 GOTO18000 C 4500 CONTINUE ICHARN=45 GOTO18000 C 4600 CONTINUE ICHARN=46 GOTO18000 C 4700 CONTINUE ICHARN=47 GOTO18000 C 4800 CONTINUE ICHARN=48 GOTO18000 C 4900 CONTINUE ICHARN=49 GOTO18000 C 5000 CONTINUE ICHARN=50 GOTO18000 C 5100 CONTINUE ICHARN=51 GOTO18000 C 5200 CONTINUE ICHARN=52 GOTO18000 C 5300 CONTINUE ICHARN=53 GOTO18000 C 5400 CONTINUE ICHARN=54 GOTO18000 C 5500 CONTINUE ICHARN=55 GOTO18000 C 5600 CONTINUE ICHARN=56 GOTO18000 C 5700 CONTINUE ICHARN=57 GOTO18000 C 5800 CONTINUE ICHARN=58 GOTO18000 C 5900 CONTINUE ICHARN=59 GOTO18000 C 6000 CONTINUE ICHARN=60 GOTO18000 C 6100 CONTINUE ICHARN=61 GOTO18000 C 6200 CONTINUE ICHARN=62 GOTO18000 C 6300 CONTINUE ICHARN=63 GOTO18000 C 6400 CONTINUE ICHARN=64 GOTO18000 C 6500 CONTINUE ICHARN=65 GOTO18000 C 6600 CONTINUE ICHARN=66 GOTO18000 C 10100 CONTINUE ICHARN=101 GOTO18000 C 10200 CONTINUE ICHARN=102 GOTO18000 C 10300 CONTINUE ICHARN=103 GOTO18000 C 10400 CONTINUE ICHARN=104 GOTO18000 C 10500 CONTINUE ICHARN=105 GOTO18000 C 10600 CONTINUE ICHARN=106 GOTO18000 C 10700 CONTINUE ICHARN=107 GOTO18000 C 10800 CONTINUE ICHARN=108 GOTO18000 C 10900 CONTINUE ICHARN=109 GOTO18000 C 11000 CONTINUE ICHARN=110 GOTO18000 C 11100 CONTINUE ICHARN=111 GOTO18000 C 11200 CONTINUE ICHARN=112 GOTO18000 C 11300 CONTINUE ICHARN=113 GOTO18000 C 11400 CONTINUE ICHARN=114 GOTO18000 C 11500 CONTINUE ICHARN=115 GOTO18000 C 11600 CONTINUE ICHARN=116 GOTO18000 C 11700 CONTINUE ICHARN=117 GOTO18000 C 11800 CONTINUE ICHARN=118 GOTO18000 C AUGUST 1992. ADDED FOLLOWING 3 LINES 11900 CONTINUE ICHARN=119 GOTO18000 C 17900 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7911) C7911 FORMAT('***** ERROR IN DPCHMA--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7912) C7912 FORMAT(' NO MATCH FOUND FOR INPUT CHARACTER.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7913)ICHAR2 C7913 FORMAT(' INPUT CHARACTER = ',A4) CCCCC CALL DPWRST('XXX','BUG ') IFOUND='NO' GOTO19000 C 18000 CONTINUE IFOUND='YES' GOTO19000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 19000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CHMA')GOTO19090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,19011) 19011 FORMAT('***** AT THE END OF DPCHMA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,19012)IFOUND 19012 FORMAT('IFOUND = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,19013)ICHAR2,ICHARN 19013 FORMAT('ICHAR2,ICHARN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,19019)IBUGG4,ISUBG4,IFOUND 19019 FORMAT('IBUGG4,ISUBG4,IFOUND = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 19090 CONTINUE C RETURN END SUBROUTINE DPCHNU(ICHAR2,ICHARN,IBUG,IFOUND) C C PURPOSE--CONVERT AN ALPHABETIC CHARACTER C (0 TO 9) INTO A NUMERIC VALUE C (1 TO 10). C INPUT ARGUMENTS--ICHAR2 (A HOLLERITH VARIABLE C CONTAINING THE HOLLERITH C CHARACTER(S) OF INTEREST. C OUTPUT ARGUMENTS--ICHARN (AN INTEGER VARIABLE C CONTAINING THE NUMERIC C DESIGNATION FOR THE C ALPHABETIC CHARACTER. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--MARCH 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR2 CHARACTER*4 IBUG CHARACTER*4 IFOUND C CHARACTER*1 ICH1 CHARACTER*1 ICH2 C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOBE.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' C ICH1='-' ICH2='-' C ICH1N=(-999) ICH2N=(-999) C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CHNU')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPCHNU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHAR2 52 FORMAT('ICHAR2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGG4,ISUBG4 59 FORMAT('IBUGG4,ISUBG4 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************** C ** STEP 1-- ** C ** CONVERT THE CHARACTER ** C ********************************** C ICH2(1:1)=ICHAR2(2:2) CCCCC ICH2N=ICHAR(ICH2) CALL DPCOAN(ICH2,ICH2N) IF(ICH2N.EQ.32)GOTO1100 GOTO7900 C 1100 CONTINUE ICH1(1:1)=ICHAR2(1:1) CCCCC ICH1N=ICHAR(ICH1) CALL DPCOAN(ICH1,ICH1N) ICHARN=ICH1N-47 IF(1.LE.ICHARN.AND.ICHARN.LE.10)GOTO8000 GOTO7900 C 7900 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7911) C7911 FORMAT('***** ERROR IN DPCHNU--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7912) C7912 FORMAT(' NO MATCH FOUND FOR INPUT CHARACTER.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7913)ICHAR C7913 FORMAT(' INPUT CHARACTER = ',A4) CCCCC CALL DPWRST('XXX','BUG ') IFOUND='NO' GOTO9000 C 8000 CONTINUE IFOUND='YES' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CHNU')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPCHAL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICH1,ICH1N 9012 FORMAT('ICH1,ICH1N = ',A1,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICH2,ICH2N 9013 FORMAT('ICH2,ICH2N = ',A1,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ICHAR2,ICHARN 9014 FORMAT('ICHAR2,ICHARN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)IBUGG4,ISUBG4,IFOUND 9019 FORMAT('IBUGG4,ISUBG4,IFOUND = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPCHOF(IHARG,IARGT,IARG,ARG,NUMARG, 1MAXCHA, 1PCHAHO,PCHAVO, 1IFOUND,IERROR) C C PURPOSE--DEFINE PLOT CHARACTER (HORIZONTAL AND VERTICAL) OFFSET C FOR USE IN MULTI-TRACE PLOTS. C THE OFFSET FOR THE CHARACTER FOR THE I-TH TRACE C WILL BE PLACED C IN THE I-TH ELEMENT OF THE FLOATING POINT C VECTORS PCHAHO(.) AND PCHAVO(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --ARG (A HOLLERITH VECTOR) C --NUMARG C --MAXCHA C OUTPUT ARGUMENTS--PCHAHO (A FLOATING POINT VECTOR C WHOSE I-TH ELEMENT IS THE HORIZONTAL OFFSET C FOR THE CHARACTER C ASSIGNED TO THE I-TH TRACE IN C A MULTI-TRACE PLOT. C --PCHAVO (A FLOATING POINT VECTOR C WHOSE I-TH ELEMENT IS THE VERTICAL OFFSET C FOR THE CHARACTER C ASSIGNED TO THE I-TH TRACE IN C A MULTI-TRACE PLOT. C --PCHAHO = CHARACTER WIDTH C --PCHAVG = VERTICAL GAP BETWEEN CHARACTERS C --PCHAHG = HORIZONTAL GAP BETWEEN CHARACTERS C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--NOVEMBER 1986. C UPDATED --AUGUST 1988. CORRECTED FORMAT STATEMENT C UPDATED --AUGUST 1988. CORRECTED LOOP LOGIC C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) DIMENSION ARG(*) C DIMENSION PCHAHO(*) DIMENSION PCHAVO(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C 1100 CONTINUE C IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'OFFS')GOTO1160 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'DISP')GOTO1160 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'OFFS')GOTO1105 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'DISP')GOTO1105 GOTO2199 C 1105 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1110 IF(IHARG(NUMARG).EQ.'OFF')GOTO1110 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 C IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160 IF(NUMARG.EQ.3)GOTO1120 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'ALL')GOTO1130 IF(NUMARG.GE.4.AND.IHARG(4).EQ.'ALL')GOTO1140 C GOTO1150 C 1110 CONTINUE DO1115I=1,MAXCHA PCHAVO(I)=0.0 PCHAHO(I)=0.0 1115 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1119 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116) 1116 FORMAT('ALL CHARACTER (HORIZ. AND VERT.) OFFSETS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1117)PCHAHO(I),PCHAVO(I) 1117 FORMAT(' HAVE JUST BEEN SET TO ',2E15.7) CALL DPWRST('XXX','BUG ') 1119 CONTINUE GOTO2190 C 1120 CONTINUE I=1 IF(IARGT(2).NE.'NUMB'.OR.IARGT(3).NE.'NUMB')GOTO1180 PCHAHO(1)=ARG(2) PCHAVO(1)=ARG(3) C IF(IFEEDB.EQ.'OFF')GOTO1129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1126)I 1126 FORMAT('THE (HORIZ. AND VERT.) OFFSET FOR CHARACTER ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1127)PCHAHO(I),PCHAVO(I) 1127 FORMAT(' HAS JUST BEEN SET TO ',2E15.7) CALL DPWRST('XXX','BUG ') 1129 CONTINUE GOTO2190 C 1130 CONTINUE I=1 IF(IARGT(3).NE.'NUMB'.OR.IARGT(4).NE.'NUMB')GOTO1180 DO1135I=1,MAXCHA PCHAHO(I)=ARG(3) PCHAVO(I)=ARG(4) 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1117)PCHAHO(I),PCHAVO(I) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO2190 C 1140 CONTINUE I=1 IF(IARGT(2).NE.'NUMB'.OR.IARGT(3).NE.'NUMB')GOTO1180 DO1145I=1,MAXCHA PCHAHO(I)=ARG(2) PCHAVO(I)=ARG(3) 1145 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1149 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1117)PCHAHO(I),PCHAVO(I) CALL DPWRST('XXX','BUG ') 1149 CONTINUE GOTO2190 C 1150 CONTINUE IMAX=NUMARG-1 IF(MAXCHA.LT.IMAX)IMAX=MAXCHA CCCCC THE FOLLOWING 1 LINE WAS INSERTED IN AUGUST 1988 J=0 DO1155I=1,IMAX,2 IP1=I+1 IP2=I+2 IF(IARGT(IP1).NE.'NUMB')GOTO1180 IF(IARGT(IP2).NE.'NUMB')GOTO1180 CCCCC PCHAHO(I)=ARG(IP1) AUGUST 1988 CCCCC PCHAVO(I)=ARG(IP2) AUGUST 1988 CCCCC THE FOLLOWING 3 LINES WERE INSERTED IN AUGUST 1988 J=J+1 PCHAHO(J)=ARG(IP1) PCHAVO(J)=ARG(IP2) 1155 CONTINUE CCCCC THE FOLLOWING 1 LINE WAS INSERTED IN AUGUST 1988 JMAX=J C IF(IFEEDB.EQ.'OFF')GOTO1159 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') CCCCC DO1156I=1,IMAX AUGUST 1988 CCCCC THE FOLLOWING 1 LINE WAS INSERTED IN AUGUST 1988 DO1156I=1,JMAX WRITE(ICOUT,1126)I CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1127)I,PCHAHO(I),PCHAVO(I) AUGUST 1988 CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1127)PCHAHO(I),PCHAVO(I) CALL DPWRST('XXX','BUG ') 1156 CONTINUE 1159 CONTINUE GOTO2190 C 1160 CONTINUE DO1165I=1,MAXCHA PCHAHO(I)=0.0 PCHAVO(I)=0.0 1165 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1169 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1116) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1117)PCHAHO(I),PCHAVO(I) CALL DPWRST('XXX','BUG ') 1169 CONTINUE GOTO2190 C 1180 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('***** ERROR IN DPCHOF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182) 1182 FORMAT('CHARACTER (HORIZ. AND VERT.) OFFSETS MUST BE NUMERIC') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1183) 1183 FORMAT('HOWEVER, THE SPECIFIED CHARACTER OFFSET') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1184)I 1184 FORMAT('FOR CHARACTER ',I6,' WAS NON-NUMERIC.') CALL DPWRST('XXX','BUG ') GOTO2199 C 2190 CONTINUE IFOUND='YES' C 2199 CONTINUE RETURN END SUBROUTINE DPCHSQ(X1,X2,Y1,MAXNXT, 1ICAPSW, 1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--COMPUTE A CHI-SQUARE GOODNESS OF FIT ANALYSIS C FOR ONE OF THE FOLLOWING DISTRIBUTIONS-- C 1 ) UNIFORM C 2 ) NORMAL C 3 ) LOGISTIC C 4 ) DOUBLE EXPONENTIAL C 5 ) CAUCHY C 6 ) TUKEY LAMBDA C 7 ) LOGNORMAL C 8 ) HALFNORMAL C 9 ) T C 10) CHI-SQUARED C 11) F C 12) EXPONENTIAL C 13) GAMMA C 14) BETA C 15) WEIBULL---MIN & MAX MAY 1993 C 16) EXTREME VALUE TYPE 1 (GUMBEL)--MIN & MAX MAY 1993 C 17) EXTREME VALUE TYPE 2 (FRECHET)--MIN & MAX MAY 1993 C 18) PARETO C 19) BINOMIAL C 20) GEOMETRIC C 21) POISSON C 22) NEGATIVE BINOMIAL C 23) SEMI-CIRCULAR C 24) TRIANGULAR C 25) INVERSE GAUUSIAN C 26) WALD C 27) RECIPROCAL INVERSE GAUUSIAN C 28) FAILURE TIME C 29) GENERALIZED PARETO C 30) DISCRETE UNIFORM C 31) NON-CENTRAL T C 32) NON-CENTRAL F C 33) NON-CENTRAL CHI-SQUARE C 34) NON-CENTRAL BETA C 35) DOUBLY NON-CENTRAL T C 36) DOUBLY NON-CENTRAL F C 36) HYPER-GEOMETRIC C 37) VON-MISES C 38) POWER NORMAL C 39) POWER LOGNORMAL C 40) COSINE C 41) ALPHA C 42) POWER FUNCTION C 43) CHI C 44) LOGARITMIC SERIES C 45) LOG LOGISTIC C 46) GENERALIZED GAMMA C 47) WARING C 48) ANGLIT C 49) ARCSIN C 50) FOLDED NORMAL C 51) TRUNCATED NORMAL C 52) LOG GAMMA C 53) HYPERBOLIC SECANT C 54) GOMPERTZ C 55) PARETO SECOND KIND C 56) DOUBLE WEIBULL C 57) WRAPPED-UP CAUCHY C 58) EXPONENTIAL WEIBULL C 59) TRUNCATED EXPONENTIAL C 60) GENERALIZED LOGISTIC C 61) EXPONENTIAL POWER C 62) DOUBLE GAMMA C 63) MIELKE'S BETA-KAPPA C 64) FOLDED CAUCHY C 65) BETA BINOMIAL C 66) BETA PASCAL C 67) GENERALIZED EXPONENTIAL CHI-SQUARE GOODNESS OF FIT C 68) RECIPROCAL CHI-SQUARE GOODNESS OF FIT C 69) NORMAL MIXTURE C 70) INVERTED GAMMA C 71) INVERTED WEIBULL C 72) LOG DOUBLE EXPONENTIAL C 73) GENERALIZED TUKEY-LAMBDA C 74) JOHNSON SU C 75) JOHNSON SB C 76) GEOMETRIC EXTREME EXPONENTIAL C 77) TWO-SIDED POWER C 78) BIWEIBULL C 79) LANDAU C 80) ERROR (= EXPONENTIAL POWER = SUBBOTIN) C 81) TRAPEZOID C 82) GENERALIZED TRAPEZOID C 83) FOLDED T C 83) SLASH C 84) SKEWED NORMAL C 85) SKEWED T C 86) INVERTED BETA C 87) GOMPERTZ-MAKEHAM C 88) GENERALIZED INVERSE GAUSSIAN C 89) GENERALIZED F C 90) G-H C 91) LOG SKEW NORMAL C 92) LOG SKEW T C 93) GENERALIZED HALF-LOGISTIC C 94) POLYA (NOT WORKING) C 95) HERMITE C 96) SKEWED DOUBLE EXPONENTIAL C 97) ASYMMETRIC DOUBLE EXPONENTIAL C 98) MAXWELL C 99) RAYLEIGH C 100) GENERALIZED ASYMMETRIC DOUBLE EXPONENTIAL C 101) MCLEISH C 102) BESSEL I-FUNCTION C 103) BESSEL K-FUNCTION C 104) GENERALIZED MCLEISH C 105) GENERALIZED LOGISTIC TYPE 5 C 106) WAKEBY C 107) BETA-NORMAL C 108) GENERALIZED LOGISTIC TYPE 2 C 109) GENERALIZED LOGISTIC TYPE 3 C 110) GENERALIZED LOGISTIC TYPE 4 C 111) ASYMMETRIC LOG DOUBLE EXPONENTIAL C 112) BETA GEOMETRIC C 113) ZETA C 114) ZIPF C 115) BETA NEGATIVE BINOMIAL C (ALSO CALLED GENERALIZED WARING) C 116) BOREL-TANNER C 117) LAGRANGE-POISSON (CONSUL GENERALIZED POISSON) C 118) LEADS IN COIN TOSSING (DISCRETE ARCSINE) C 119) MATCHING C 120) CLASSICAL OCCUPANCY (NOT ACTIVE YET) C 121) LOG BETA C 122) POLYA AEPPLI C 123) NEYMANN TYPE A (NOT ACTIVE YET) C 124) DXG (NOT ACTIVE YET) C 125) LOST GAMES C 126) GENERALIZED LOGARITHMIC SERIES C 127) GENERALIZED NEGATIVE BINOMIAL C 128) GEETA C 129) POISSON-INVERSE GAUSSIAN (NOT ACTIVE YET) C 130) QUASI BINOMIAL TYPE I C 131) CONSUL C 132) LAGRANGE KATZ (NOT ACTIVE YET) C 133) KATZ (NOT ACTIVE YET) C 134) DISCRETE WEIBULL C 135) GENERALIZED LOST GAMES C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--98/11 C ORIGINAL VERSION--NOVEMBER 1998. C UPDATED --OCTOBER 2001. C UPDATED --NOVEMBER 2001. C UPDATED --MAY 2002. TWO-SIDED POWER C UPDATED --MAY 2002. BIWEIBULL C UPDATED --MAY 2003. LANDAU C UPDATED --MAY 2003. ERROR (= EXPONENTIAL POWER) C UPDATED --JUNE 2003. TRAPEZOID C UPDATED --JUNE 2003. GENERALIZED TRAPEZOID C UPDATED --OCTOBER 2003. SUPPORT FOR HTML, LATEX OUTPUT C UPDATED --NOVEMBER 2003. FOLDED T C UPDATED --DECEMBER 2003. SUPPORT FOR MU PARAMETER FOR C INVERSE GAUSSIAN, RECIPROCAL C INVERSE GAUSSIAN C UPDATED --DECEMBER 2003. SLASH, SKEW NORMAL, C SKEW T, INVERTED BETA, C GOMPERTZ-MAKEHAM, G-H C UPDATED --MARCH 2004. LOG-SKEW-NORMAL C UPDATED --MARCH 2004. LOG-SKEW-T C UPDATED --MARCH 2004. POLYA C UPDATED --APRIL 2004. HERMITE C UPDATED --JUNE 2004. SKEW DOUBLE EXPONENTIAL C UPDATED --JUNE 2004. ASYMMETRIC DOUBLE EXPONENTIAL C UPDATED --JUNE 2004. MAXWELL, RAYLEIGH C UPDATED --AUGUST 2004. GENERALIZED ASYMMETRIC C DOUBLE EXPONENTIAL C UPDATED --AUGUST 2004. MCLEISH C UPDATED --AUGUST 2004. BESSEL I-FUNCTION C UPDATED --AUGUST 2004. BESSEL K-FUNCTION C UPDATED --SEPTEMBER 2004. GENERALIZED MCLEISH C UPDATED --DECEMBER 2004. CLARIFY SHAPE PARAMETERS FOR C PARETO PARETO SECOND KIND C UPDATED --FEBRUARY 2006. GENERALIZED LOGISTIC TYPE 5 C UPDATED --FEBRUARY 2006. WAKEBY C UPDATED --FEBRUARY 2006. FMKL PARAMETERIZATION FOR C GENERALZIED TUKEY LAMBDA C UPDATED --MARCH 2006. SUPPORT FOR DIFFERENT C DEFAULT BINNING ALGORITHMS C UPDATED --MARCH 2006. BETA-BINOMIAL C UPDATED --MARCH 2006. GENERALIZED LOGISTIC TYPE 2 C UPDATED --MARCH 2006. GENERALIZED LOGISTIC TYPE 3 C UPDATED --MARCH 2006. GENERALIZED LOGISTIC TYPE 4 C UPDATED --MARCH 2006. ASYMMETRIC LOG DOUBLE C EXPONENTIAL C UPDATED --MAY 2006. BETA GEOMETRIC C UPDATED --MAY 2006. ZETA C UPDATED --MAY 2006. ZIPF C UPDATED --MAY 2006. BOREL-TANNER C UPDATED --MAY 2006. BETA NEGATIVE BINOMIAL (= C GENERALIZED WARING) C UPDATED --JUNE 2006. LAGRANGE-POISSON C UPDATED --JUNE 2006. LEADS IN COIN TOSSING C UPDATED --JUNE 2006. MATCHING C UPDATED --JUNE 2006. LOG BETA C UPDATED --JUNE 2006. POLYA-AEPPLI C UPDATED --JUNE 2006. LOST GAMES C UPDATED --JUNE 2006. NEYMAN TYPE A (NOT ACTIVE YET) C UPDATED --JUNE 2006. DXG (NOT ACTIVE YET) C UPDATED --JUNE 2006. CLASSICAL OCCUPANCY (NOT ACTIVE) C UPDATED --JUNE 2006. GENERALIZED LOGARITHMIC SERIES C UPDATED --JULY 2006. GENERALIZED NEGATIVE BINOMIAL C UPDATED --JULY 2006. GEETA C UPDATED --JULY 2006. QUASI BINOMIAL TYPE I C UPDATED --AUGUST 2006. CONSUL C UPDATED --AUGUST 2006. LAGRANGE KATZ C UPDATED --SEPTEMBER 2006. KATZ C UPDATED --OCTOBER 2006. FRACTIONAL DEGREES OF C FREEDOM FOR T DISTRIBUTION C UPDATED --OCTOBER 2006. SHAPE PARAMETER FOR C SEMI-CIRCULAR DISTRIBUTION C UPDATED --NOVEMBER 2006. DISCRETE WEIBULL C UPDATED --NOVEMBER 2006. GENERALIZED LOST GAMES C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 ICAPSW CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IWRITE C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IDATSW CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHRIGH CHARACTER*4 IHRIG2 CHARACTER*4 IHTHIR CHARACTER*4 IHTHI2 CHARACTER*4 IERRO4 C CHARACTER*4 LOWLTY CHARACTER*4 UPPLTY CHARACTER*30 IDIST C CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 ISUBN0 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*80 IFILE1 CHARACTER*12 ISTAT1 CHARACTER*12 IFORM1 CHARACTER*12 IACCE1 CHARACTER*12 IPROT1 CHARACTER*12 ICURS1 CHARACTER*4 IERRF1 CHARACTER*4 IENDF1 CHARACTER*4 IREWI1 C REAL LOC2 C PARAMETER (NUMCHS=230) CHARACTER*4 INAME(NUMCHS,4) CHARACTER*4 INCASE(NUMCHS) C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(*) DIMENSION X1(*) DIMENSION X2(*) DIMENSION XTEMP(MAXOBV) DIMENSION XTEMP2(MAXOBV) DIMENSION XTEMP3(MAXOBV) DIMENSION YOBS(MAXOBV) DIMENSION YEXP(MAXOBV) INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),XTEMP(1)) EQUIVALENCE (GARBAG(IGARB2),YOBS(1)) EQUIVALENCE (GARBAG(IGARB3),YEXP(1)) EQUIVALENCE (GARBAG(IGARB4),XTEMP2(1)) EQUIVALENCE (GARBAG(IGARB5),XTEMP3(1)) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOSU.INC' INCLUDE 'DPCOST.INC' INCLUDE 'DPCOS2.INC' INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOMC.INC' INCLUDE 'DPCOF2.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C AUGUST 1998. MAKE SEARCH TABLE DRIVEN C DATA INCASE(1)/'UNPP'/ DATA (INAME(1,J),J=1,4)/'UNIF',' ',' ',' '/ DATA INCASE(2)/'UNPP'/ DATA (INAME(2,J),J=1,4)/'RECT',' ',' ',' '/ DATA INCASE(3)/'NMPP'/ DATA (INAME(3,J),J=1,4)/'NORM','MIXT',' ',' '/ DATA INCASE(4)/'NMPP'/ DATA (INAME(4,J),J=1,4)/'GAUS','MIXT',' ',' '/ DATA INCASE(5)/'NOPP'/ DATA (INAME(5,J),J=1,4)/'NORM',' ',' ',' '/ DATA INCASE(6)/'NOPP'/ DATA (INAME(6,J),J=1,4)/'GAUS',' ',' ',' '/ DATA INCASE(7)/'LOPP'/ DATA (INAME(7,J),J=1,4)/'LOGI',' ',' ',' '/ DATA INCASE(8)/'DEPP'/ DATA (INAME(8,J),J=1,4)/'DOUB','EXPO',' ',' '/ DATA INCASE(9)/'DEPP'/ DATA (INAME(9,J),J=1,4)/'LAPL',' ',' ',' '/ DATA INCASE(10)/'CAPP'/ DATA (INAME(10,J),J=1,4)/'CAUC',' ',' ',' '/ DATA INCASE(11)/'LAPP'/ DATA (INAME(11,J),J=1,4)/'TUKE','LAMB',' ',' '/ DATA INCASE(12)/'LAPP'/ DATA (INAME(12,J),J=1,4)/'TUKE',' ',' ',' '/ DATA INCASE(13)/'LAPP'/ DATA (INAME(13,J),J=1,4)/'LAMB',' ',' ',' '/ DATA INCASE(14)/'LNPP'/ DATA (INAME(14,J),J=1,4)/'LOG ','NORM',' ',' '/ DATA INCASE(15)/'LNPP'/ DATA (INAME(15,J),J=1,4)/'LOGN',' ',' ',' '/ DATA INCASE(16)/'HNPP'/ DATA (INAME(16,J),J=1,4)/'HALF','NORM',' ',' '/ DATA INCASE(17)/'HNPP'/ DATA (INAME(17,J),J=1,4)/'HALF',' ',' ',' '/ DATA INCASE(18)/'TPP'/ DATA (INAME(18,J),J=1,4)/'T ',' ',' ',' '/ DATA INCASE(19)/'TPP'/ DATA (INAME(19,J),J=1,4)/'STUD','T ',' ',' '/ DATA INCASE(20)/'CSPP'/ DATA (INAME(20,J),J=1,4)/'CHIS',' ',' ',' '/ DATA INCASE(21)/'CSPP'/ DATA (INAME(21,J),J=1,4)/'CHI ','SQUA',' ',' '/ DATA INCASE(22)/'FPP'/ DATA (INAME(22,J),J=1,4)/'F ',' ',' ',' '/ DATA INCASE(23)/'FPP'/ DATA (INAME(23,J),J=1,4)/'SNED','F ',' ',' '/ DATA INCASE(24)/'EXPP'/ DATA (INAME(24,J),J=1,4)/'EXPO',' ',' ',' '/ DATA INCASE(25)/'EXPP'/ DATA (INAME(25,J),J=1,4)/'NEGA','EXPO',' ',' '/ DATA INCASE(26)/'GAPP'/ DATA (INAME(26,J),J=1,4)/'GAMM',' ',' ',' '/ DATA INCASE(27)/'BNPP'/ DATA (INAME(27,J),J=1,4)/'BETA','NORM',' ',' '/ DATA INCASE(28)/'WEPP'/ DATA (INAME(28,J),J=1,4)/'WEIB',' ',' ',' '/ DATA INCASE(29)/'E1PP'/ DATA (INAME(29,J),J=1,4)/'EXTR','VALU','TYPE','1 '/ DATA INCASE(30)/'E1PP'/ DATA (INAME(30,J),J=1,4)/'EXTR','VALU','TYPE','I '/ DATA INCASE(31)/'E1PP'/ DATA (INAME(31,J),J=1,4)/'EV1 ',' ',' ',' '/ DATA INCASE(32)/'E1PP'/ DATA (INAME(32,J),J=1,4)/'EVI ',' ',' ',' '/ DATA INCASE(33)/'E1PP'/ DATA (INAME(33,J),J=1,4)/'GUMB',' ',' ',' '/ DATA INCASE(34)/'E2PP'/ DATA (INAME(34,J),J=1,4)/'EXTR','VALU','TYPE','2 '/ DATA INCASE(35)/'E2PP'/ DATA (INAME(35,J),J=1,4)/'EXTR','VALU','TYPE','II '/ DATA INCASE(36)/'E2PP'/ DATA (INAME(36,J),J=1,4)/'EVII',' ',' ',' '/ DATA INCASE(37)/'E2PP'/ DATA (INAME(37,J),J=1,4)/'EV2 ',' ',' ',' '/ DATA INCASE(38)/'E2PP'/ DATA (INAME(38,J),J=1,4)/'FREC',' ',' ',' '/ DATA INCASE(39)/'PAPP'/ DATA (INAME(39,J),J=1,4)/'PARE',' ',' ',' '/ DATA INCASE(40)/'BIPP'/ DATA (INAME(40,J),J=1,4)/'BINO',' ',' ',' '/ DATA INCASE(41)/'GEPP'/ DATA (INAME(41,J),J=1,4)/'GEOM',' ',' ',' '/ DATA INCASE(42)/'POPP'/ DATA (INAME(42,J),J=1,4)/'POIS',' ',' ',' '/ DATA INCASE(43)/'NBPP'/ DATA (INAME(43,J),J=1,4)/'NEGA','BINO',' ',' '/ DATA INCASE(44)/'SEPP'/ DATA (INAME(44,J),J=1,4)/'SEMI','CIRC',' ',' '/ DATA INCASE(45)/'SEPP'/ DATA (INAME(45,J),J=1,4)/'SEMI',' ',' ',' '/ DATA INCASE(46)/'TRPP'/ DATA (INAME(46,J),J=1,4)/'TRIA',' ',' ',' '/ DATA INCASE(47)/'IGPP'/ DATA (INAME(47,J),J=1,4)/'INVE','GAUS',' ',' '/ DATA INCASE(48)/'IGPP'/ DATA (INAME(48,J),J=1,4)/'IG ',' ',' ',' '/ DATA INCASE(49)/'WAPP'/ DATA (INAME(49,J),J=1,4)/'WALD',' ',' ',' '/ DATA INCASE(50)/'RIPP'/ DATA (INAME(50,J),J=1,4)/'RIG ',' ',' ',' '/ DATA INCASE(51)/'RIPP'/ DATA (INAME(51,J),J=1,4)/'TWEE',' ',' ',' '/ DATA INCASE(52)/'RIPP'/ DATA (INAME(52,J),J=1,4)/'RECI','INVE','GAUS',' '/ DATA INCASE(53)/'FLPP'/ DATA (INAME(53,J),J=1,4)/'FATI','LIFE',' ',' '/ DATA INCASE(54)/'FLPP'/ DATA (INAME(54,J),J=1,4)/'FL ',' ',' ',' '/ DATA INCASE(55)/'FLPP'/ DATA (INAME(55,J),J=1,4)/'BIRN','SAUN',' ',' '/ DATA INCASE(56)/'FLPP'/ DATA (INAME(56,J),J=1,4)/'SAUN','BIRN',' ',' '/ DATA INCASE(57)/'GPPP'/ DATA (INAME(57,J),J=1,4)/'GENE','PARE',' ',' '/ DATA INCASE(58)/'GPPP'/ DATA (INAME(58,J),J=1,4)/'GEP ',' ',' ',' '/ DATA INCASE(59)/'GPPP'/ DATA (INAME(59,J),J=1,4)/'GP ',' ',' ',' '/ DATA INCASE(60)/'DUPP'/ DATA (INAME(60,J),J=1,4)/'DISC','UNIF',' ',' '/ DATA INCASE(61)/'NTPP'/ DATA (INAME(61,J),J=1,4)/'NONC','T ',' ',' '/ DATA INCASE(62)/'NTPP'/ DATA (INAME(62,J),J=1,4)/'NON-','T ',' ',' '/ DATA INCASE(63)/'NTPP'/ DATA (INAME(63,J),J=1,4)/'NON ','CENT','T ',' '/ DATA INCASE(64)/'NFPP'/ DATA (INAME(64,J),J=1,4)/'NONC','F ',' ',' '/ DATA INCASE(65)/'NFPP'/ DATA (INAME(65,J),J=1,4)/'NON-','F ',' ',' '/ DATA INCASE(66)/'NFPP'/ DATA (INAME(66,J),J=1,4)/'NON ','CENT','F ',' '/ DATA INCASE(67)/'NCBP'/ DATA (INAME(67,J),J=1,4)/'NONC','BETA',' ',' '/ DATA INCASE(68)/'NCBP'/ DATA (INAME(68,J),J=1,4)/'NON-','BETA',' ',' '/ DATA INCASE(69)/'NCBP'/ DATA (INAME(69,J),J=1,4)/'NON ','CENT','BETA',' '/ DATA INCASE(70)/'NCPP'/ DATA (INAME(70,J),J=1,4)/'NON ','CENT','CHIS',' '/ DATA INCASE(71)/'NCPP'/ DATA (INAME(71,J),J=1,4)/'NON ','CENT','CHI-',' '/ DATA INCASE(72)/'NCPP'/ DATA (INAME(72,J),J=1,4)/'NONC','CHI ','SQUA',' '/ DATA INCASE(73)/'NCPP'/ DATA (INAME(73,J),J=1,4)/'NON-','CHI ','SQUA',' '/ DATA INCASE(74)/'NCPP'/ DATA (INAME(74,J),J=1,4)/'NONC','CHI-',' ',' '/ DATA INCASE(75)/'NCPP'/ DATA (INAME(75,J),J=1,4)/'NON-','CHI-',' ',' '/ DATA INCASE(76)/'NCPP'/ DATA (INAME(76,J),J=1,4)/'NONC','CHIS',' ',' '/ DATA INCASE(77)/'NCPP'/ DATA (INAME(77,J),J=1,4)/'NON-','CHIS','CHIS',' '/ DATA INCASE(78)/'DNCF'/ DATA (INAME(78,J),J=1,4)/'DOUB','NONC','F ',' '/ DATA INCASE(79)/'DNCF'/ DATA (INAME(79,J),J=1,4)/'DOUB','NON-','F ',' '/ DATA INCASE(80)/'DNCT'/ DATA (INAME(80,J),J=1,4)/'DOUB','NONC','T ',' '/ DATA INCASE(81)/'DNCT'/ DATA (INAME(81,J),J=1,4)/'DOUB','NON-','T ',' '/ DATA INCASE(82)/'HYPP'/ DATA (INAME(82,J),J=1,4)/'HYPE',' ',' ',' '/ DATA INCASE(83)/'HYPP'/ DATA (INAME(83,J),J=1,4)/'HYPE','GEO ',' ',' '/ DATA INCASE(84)/'VMPP'/ DATA (INAME(84,J),J=1,4)/'VON ','MISE',' ',' '/ DATA INCASE(85)/'VMPP'/ DATA (INAME(85,J),J=1,4)/'VONM',' ',' ',' '/ DATA INCASE(86)/'VMPP'/ DATA (INAME(86,J),J=1,4)/'VON-',' ',' ',' '/ DATA INCASE(87)/'PNPP'/ DATA (INAME(87,J),J=1,4)/'POWE','NORM',' ',' '/ DATA INCASE(88)/'PLPP'/ DATA (INAME(88,J),J=1,4)/'POWE','LOGN',' ',' '/ DATA INCASE(89)/'PLPP'/ DATA (INAME(89,J),J=1,4)/'POWE','LGNO',' ',' '/ DATA INCASE(90)/'PLPP'/ DATA (INAME(90,J),J=1,4)/'POWE','LOG-',' ',' '/ DATA INCASE(91)/'COPP'/ DATA (INAME(91,J),J=1,4)/'COSI',' ',' ',' '/ DATA INCASE(92)/'ALPP'/ DATA (INAME(92,J),J=1,4)/'ALPH',' ',' ',' '/ DATA INCASE(93)/'PEPP'/ DATA (INAME(93,J),J=1,4)/'POWE','EXPO',' ',' '/ DATA INCASE(94)/'PFPP'/ DATA (INAME(94,J),J=1,4)/'POWE','FUNC',' ',' '/ DATA INCASE(95)/'CHPP'/ DATA (INAME(95,J),J=1,4)/'CHI ',' ',' ',' '/ DATA INCASE(96)/'DLPP'/ DATA (INAME(96,J),J=1,4)/'LOGA','SERI',' ',' '/ DATA INCASE(97)/'LLPP'/ DATA (INAME(97,J),J=1,4)/'LOG ','LOGI',' ',' '/ DATA INCASE(98)/'LLPP'/ DATA (INAME(98,J),J=1,4)/'LOG-','LOGI',' ',' '/ DATA INCASE(99)/'LLPP'/ DATA (INAME(99,J),J=1,4)/'LOGL',' ',' ',' '/ DATA INCASE(100)/'GGPP'/ DATA (INAME(100,J),J=1,4)/'GENE','GAMM',' ',' '/ DATA INCASE(101)/'GIPP'/ DATA (INAME(101,J),J=1,4)/'INVE','GAMM',' ',' '/ DATA INCASE(102)/'WRPP'/ DATA (INAME(102,J),J=1,4)/'WARI',' ',' ',' '/ DATA INCASE(103)/'YUPP'/ DATA (INAME(103,J),J=1,4)/'YULE',' ',' ',' '/ DATA INCASE(104)/'ANPP'/ DATA (INAME(104,J),J=1,4)/'ANGL',' ',' ',' '/ DATA INCASE(105)/'ARPP'/ DATA (INAME(105,J),J=1,4)/'ARSE',' ',' ',' '/ DATA INCASE(106)/'FNPP'/ DATA (INAME(106,J),J=1,4)/'FOLD','NORM',' ',' '/ DATA INCASE(107)/'TNPP'/ DATA (INAME(107,J),J=1,4)/'TRUN','NORM',' ',' '/ DATA INCASE(108)/'LGPP'/ DATA (INAME(108,J),J=1,4)/'LOG ','GAMM',' ',' '/ DATA INCASE(109)/'HSPP'/ DATA (INAME(109,J),J=1,4)/'HYPE','SECA',' ',' '/ DATA INCASE(110)/'GOPP'/ DATA (INAME(110,J),J=1,4)/'GOMP',' ',' ',' '/ DATA INCASE(111)/'HLPP'/ DATA (INAME(111,J),J=1,4)/'HALF','LOGI',' ',' '/ DATA INCASE(112)/'GVPP'/ DATA (INAME(112,J),J=1,4)/'GENE','EXTR','VALU',' '/ DATA INCASE(113)/'GVPP'/ DATA (INAME(113,J),J=1,4)/'GEV ',' ',' ',' '/ DATA INCASE(114)/'HCPP'/ DATA (INAME(114,J),J=1,4)/'HALF','CAUC',' ',' '/ DATA INCASE(115)/'P2PP'/ DATA (INAME(115,J),J=1,4)/'PARE','SECO','KIND',' '/ DATA INCASE(116)/'P2PP'/ DATA (INAME(116,J),J=1,4)/'PARE','TYPE','2 ',' '/ DATA INCASE(117)/'P2PP'/ DATA (INAME(117,J),J=1,4)/'PARE','TYPE','II ',' '/ DATA INCASE(118)/'DWPP'/ DATA (INAME(118,J),J=1,4)/'DOUB','WEIB',' ',' '/ DATA INCASE(119)/'EWPP'/ DATA (INAME(119,J),J=1,4)/'EXPO','WEIB',' ',' '/ DATA INCASE(120)/'TEPP'/ DATA (INAME(120,J),J=1,4)/'TRUN','EXPO',' ',' '/ DATA INCASE(121)/'WCPP'/ DATA (INAME(121,J),J=1,4)/'WRAP','CAUC',' ',' '/ DATA INCASE(122)/'WKPP'/ DATA (INAME(122,J),J=1,4)/'WAKE',' ',' ',' '/ DATA INCASE(123)/'PEPP'/ DATA (INAME(123,J),J=1,4)/'EXPO','POWE',' ',' '/ DATA INCASE(124)/'DGPP'/ DATA (INAME(124,J),J=1,4)/'DOUB','GAMM',' ',' '/ DATA INCASE(125)/'KAPP'/ DATA (INAME(125,J),J=1,4)/'BETA','KAPP',' ',' '/ DATA INCASE(126)/'KAPP'/ DATA (INAME(126,J),J=1,4)/'MIEL','BETA','KAPP',' '/ DATA INCASE(127)/'FCPP'/ DATA (INAME(127,J),J=1,4)/'FOLD','CAUC',' ',' '/ DATA INCASE(128)/'BBPP'/ DATA (INAME(128,J),J=1,4)/'BETA','BINO',' ',' '/ DATA INCASE(129)/'BRPP'/ DATA (INAME(129,J),J=1,4)/'BRAD',' ',' ',' '/ DATA INCASE(130)/'GXPP'/ DATA (INAME(130,J),J=1,4)/'GENE','EXPO',' ',' '/ DATA INCASE(131)/'REPP'/ DATA (INAME(131,J),J=1,4)/'RECI',' ',' ',' '/ DATA INCASE(132)/'IWPP'/ DATA (INAME(132,J),J=1,4)/'INVE','WEIB',' ',' '/ DATA INCASE(133)/'LXPP'/ DATA (INAME(133,J),J=1,4)/'LOG ','DOUB','EXPO',' '/ DATA INCASE(134)/'LDPP'/ DATA (INAME(134,J),J=1,4)/'GENE','TUKE','LAMB',' '/ DATA INCASE(135)/'JBPP'/ DATA (INAME(135,J),J=1,4)/'JOHN','SB ',' ',' '/ DATA INCASE(136)/'JUPP'/ DATA (INAME(136,J),J=1,4)/'JOHN','SU ',' ',' '/ DATA INCASE(137)/'EEPP'/ DATA (INAME(137,J),J=1,4)/'GEOM','EXTR','EXPO',' '/ DATA INCASE(138)/'TSPP'/ DATA (INAME(138,J),J=1,4)/'TWO ','SIDE','POWE',' '/ DATA INCASE(139)/'BWPP'/ DATA (INAME(139,J),J=1,4)/'BI ','WEIB',' ',' '/ DATA INCASE(140)/'BWPP'/ DATA (INAME(140,J),J=1,4)/'BIWE',' ',' ',' '/ DATA INCASE(141)/'LUPP'/ DATA (INAME(141,J),J=1,4)/'LAND',' ',' ',' '/ DATA INCASE(142)/'ERPP'/ DATA (INAME(142,J),J=1,4)/'ERRO',' ',' ',' '/ DATA INCASE(143)/'ERPP'/ DATA (INAME(143,J),J=1,4)/'SUBB',' ',' ',' '/ DATA INCASE(144)/'PFPP'/ DATA (INAME(144,J),J=1,4)/'POWE',' ',' ',' '/ DATA INCASE(145)/'TZPP'/ DATA (INAME(145,J),J=1,4)/'TRAP',' ',' ',' '/ DATA INCASE(146)/'GTPP'/ DATA (INAME(146,J),J=1,4)/'GENE','TRAP',' ',' '/ DATA INCASE(147)/'FTPP'/ DATA (INAME(147,J),J=1,4)/'FOLD','T ',' ',' '/ DATA INCASE(148)/'SNPP'/ DATA (INAME(148,J),J=1,4)/'SKEW','NORM',' ',' '/ DATA INCASE(149)/'STPP'/ DATA (INAME(149,J),J=1,4)/'SKEW','T ',' ',' '/ DATA INCASE(150)/'SLPP'/ DATA (INAME(150,J),J=1,4)/'SLAS',' ',' ',' '/ DATA INCASE(151)/'IBPP'/ DATA (INAME(151,J),J=1,4)/'INVE','BETA',' ',' '/ DATA INCASE(152)/'GMPP'/ DATA (INAME(152,J),J=1,4)/'GOMP','MAKE',' ',' '/ DATA INCASE(153)/'GIGP'/ DATA (INAME(153,J),J=1,4)/'GENE','INVE','GAUS',' '/ DATA INCASE(154)/'GFPP'/ DATA (INAME(154,J),J=1,4)/'GENE','F ',' ',' '/ DATA INCASE(155)/'GHPP'/ DATA (INAME(155,J),J=1,4)/'G-H ',' ',' ',' '/ DATA INCASE(156)/'GHPP'/ DATA (INAME(156,J),J=1,4)/'GH ',' ',' ',' '/ DATA INCASE(157)/'GHPP'/ DATA (INAME(157,J),J=1,4)/'G ','H ',' ',' '/ DATA INCASE(158)/'GHPP'/ DATA (INAME(158,J),J=1,4)/'G ','AND ','H ',' '/ DATA INCASE(159)/'LZPP'/ DATA (INAME(159,J),J=1,4)/'LOG ','SKEW','NORM',' '/ DATA INCASE(160)/'LTPP'/ DATA (INAME(160,J),J=1,4)/'LOG ','SKEW','T ',' '/ DATA INCASE(161)/'GZPP'/ DATA (INAME(161,J),J=1,4)/'GENE','HALF','LOGI',' '/ DATA INCASE(162)/'ASPP'/ DATA (INAME(162,J),J=1,4)/'ARCS',' ',' ',' '/ DATA INCASE(163)/'AEPP'/ DATA (INAME(163,J),J=1,4)/'POLY','AEPP',' ',' '/ DATA INCASE(164)/'HEPP'/ DATA (INAME(164,J),J=1,4)/'HERM',' ',' ',' '/ DATA (INAME(165,J),J=1,4)/'SKEW','DOUB','EXPO',' '/ DATA INCASE(165)/'SDPP'/ DATA (INAME(166,J),J=1,4)/'SKEW','LAPL',' ',' '/ DATA INCASE(166)/'SDPP'/ DATA (INAME(167,J),J=1,4)/'ASYM','DOUB','EXPO',' '/ DATA INCASE(167)/'ADPP'/ DATA (INAME(168,J),J=1,4)/'ASYM','LAPL',' ',' '/ DATA INCASE(168)/'ADPP'/ DATA (INAME(169,J),J=1,4)/'MAXW',' ',' ',' '/ DATA INCASE(169)/'MXPP'/ DATA (INAME(170,J),J=1,4)/'RAYL',' ',' ',' '/ DATA INCASE(170)/'RAPP'/ DATA (INAME(171,J),J=1,4)/'GENE','ASYM','DOUB','EXPO'/ DATA INCASE(171)/'GALP'/ DATA (INAME(172,J),J=1,4)/'GENE','ASYM','LAPL',' '/ DATA INCASE(172)/'GALP'/ DATA (INAME(173,J),J=1,4)/'MCLE',' ',' ',' '/ DATA INCASE(173)/'MCLP'/ DATA (INAME(174,J),J=1,4)/'BESS','I ','FUNC',' '/ DATA INCASE(174)/'BEIP'/ DATA (INAME(175,J),J=1,4)/'BESS','I ',' ',' '/ DATA INCASE(175)/'BEIP'/ DATA (INAME(176,J),J=1,4)/'BESS','K ','FUNC',' '/ DATA INCASE(176)/'BEKP'/ DATA (INAME(177,J),J=1,4)/'BESS','K ',' ',' '/ DATA INCASE(177)/'BEKP'/ DATA INCASE(178)/'GMCP'/ DATA (INAME(178,J),J=1,4)/'GENE','MCLE',' ',' '/ DATA INCASE(179)/'G5PP'/ DATA (INAME(179,J),J=1,4)/'GENE','LOGI','TYPE','5 '/ DATA INCASE(180)/'G5PP'/ DATA (INAME(180,J),J=1,4)/'GENE','LOGI','TYPE','V '/ DATA INCASE(181)/'G5PP'/ DATA (INAME(181,J),J=1,4)/'GENE','LOGI','HOSK',' '/ DATA INCASE(182)/'G5PP'/ DATA (INAME(182,J),J=1,4)/'HOSK','GENE','LOGI',' '/ DATA INCASE(183)/'G5PP'/ DATA (INAME(183,J),J=1,4)/'TYPE','5 ','GENE','LOGI'/ DATA INCASE(184)/'G5PP'/ DATA (INAME(184,J),J=1,4)/'TYPE','V ','GENE','LOGI'/ DATA INCASE(185)/'G2PP'/ DATA (INAME(185,J),J=1,4)/'GENE','LOGI','TYPE','2 '/ DATA INCASE(186)/'G2PP'/ DATA (INAME(186,J),J=1,4)/'GENE','LOGI','TYPE','II '/ DATA INCASE(187)/'G2PP'/ DATA (INAME(187,J),J=1,4)/'TYPE','2 ','GENE','LOGI'/ DATA INCASE(188)/'G2PP'/ DATA (INAME(188,J),J=1,4)/'TYPE','II ','GENE','LOGI'/ DATA INCASE(189)/'G3PP'/ DATA (INAME(189,J),J=1,4)/'GENE','LOGI','TYPE','3 '/ DATA INCASE(190)/'G3PP'/ DATA (INAME(190,J),J=1,4)/'GENE','LOGI','TYPE','III '/ DATA INCASE(191)/'G3PP'/ DATA (INAME(191,J),J=1,4)/'TYPE','3 ','GENE','LOGI'/ DATA INCASE(192)/'G3PP'/ DATA (INAME(192,J),J=1,4)/'TYPE','III ','GENE','LOGI'/ DATA INCASE(193)/'G4PP'/ DATA (INAME(193,J),J=1,4)/'GENE','LOGI','TYPE','4 '/ DATA INCASE(194)/'G4PP'/ DATA (INAME(194,J),J=1,4)/'GENE','LOGI','TYPE','IV '/ DATA INCASE(195)/'G4PP'/ DATA (INAME(195,J),J=1,4)/'TYPE','4 ','GENE','LOGI'/ DATA INCASE(196)/'G4PP'/ DATA (INAME(196,J),J=1,4)/'TYPE','IV ','GENE','LOGI'/ DATA INCASE(197)/'GLPP'/ DATA (INAME(197,J),J=1,4)/'GENE','LOGI',' ',' '/ DATA INCASE(198)/'BGPP'/ DATA (INAME(198,J),J=1,4)/'BETA','GEOM',' ',' '/ DATA INCASE(199)/'LXPP'/ DATA (INAME(199,J),J=1,4)/'LOG ','LAPL',' ',' '/ DATA INCASE(200)/'AXPP'/ DATA (INAME(200,J),J=1,4)/'ASYM','LOG ','DOUB','EXPO'/ DATA INCASE(201)/'AXPP'/ DATA (INAME(201,J),J=1,4)/'ASYM','LOG ','LAPL',' '/ DATA INCASE(202)/'BZPP'/ DATA (INAME(202,J),J=1,4)/'BETA','NEGA','BINO',' '/ DATA INCASE(203)/'ZEPP'/ DATA (INAME(203,J),J=1,4)/'ZETA',' ',' ',' '/ DATA INCASE(204)/'ZIPP'/ DATA (INAME(204,J),J=1,4)/'ZIPF',' ',' ',' '/ DATA INCASE(205)/'BEPP'/ DATA (INAME(205,J),J=1,4)/'BETA',' ',' ',' '/ DATA INCASE(206)/'BTPP'/ DATA (INAME(206,J),J=1,4)/'BORE','TANN',' ',' '/ DATA INCASE(207)/'BZPP'/ DATA (INAME(207,J),J=1,4)/'GENE','WARI',' ',' '/ DATA INCASE(208)/'LPPP'/ DATA (INAME(208,J),J=1,4)/'LAGR','POIS',' ',' '/ DATA INCASE(209)/'LPPP'/ DATA (INAME(209,J),J=1,4)/'CONS','GENE','POIS',' '/ DATA INCASE(210)/'LCPP'/ DATA (INAME(210,J),J=1,4)/'LEAD','IN ','COIN','TOSS'/ DATA INCASE(211)/'LCPP'/ DATA (INAME(211,J),J=1,4)/'DISC','ARCS',' ',' '/ DATA INCASE(212)/'MAPP'/ DATA (INAME(212,J),J=1,4)/'MATC',' ',' ',' '/ DATA INCASE(213)/'OCPP'/ DATA (INAME(213,J),J=1,4)/'CLAS','OCCU',' ',' '/ DATA INCASE(214)/'LBPP'/ DATA (INAME(214,J),J=1,4)/'LOG ','BETA',' ',' '/ DATA INCASE(215)/'PZPP'/ DATA (INAME(215,J),J=1,4)/'POLY',' ',' ',' '/ DATA INCASE(216)/'NZPP'/ DATA (INAME(216,J),J=1,4)/'NEYM','TYPE','A ',' '/ DATA INCASE(217)/'DXPP'/ DATA (INAME(217,J),J=1,4)/'DXG ',' ',' ',' '/ DATA INCASE(218)/'LOST'/ DATA (INAME(218,J),J=1,4)/'LOST','GAME',' ',' '/ DATA INCASE(219)/'GSPP'/ DATA (INAME(219,J),J=1,4)/'GENE','LOGA','SERI',' '/ DATA INCASE(220)/'GNBP'/ DATA (INAME(220,J),J=1,4)/'GENE','NEGA','BINO',' '/ DATA INCASE(221)/'GETP'/ DATA (INAME(221,J),J=1,4)/'GEET',' ',' ',' '/ DATA INCASE(222)/'QBPP'/ DATA (INAME(222,J),J=1,4)/'QUAS','BINO','TYPE','I '/ DATA INCASE(223)/'QBPP'/ DATA (INAME(223,J),J=1,4)/'QUAS','BINO','TYPE','1 '/ DATA INCASE(224)/'QBPP'/ DATA (INAME(224,J),J=1,4)/'QUAS','BINO','I ',' '/ DATA INCASE(225)/'QBPP'/ DATA (INAME(225,J),J=1,4)/'QUAS','BINO','1 ',' '/ DATA INCASE(226)/'CNPP'/ DATA (INAME(226,J),J=1,4)/'CONS',' ',' ',' '/ DATA INCASE(227)/'LKPP'/ DATA (INAME(227,J),J=1,4)/'LAGR','KATZ',' ',' '/ DATA INCASE(228)/'KZPP'/ DATA (INAME(228,J),J=1,4)/'KATZ',' ',' ',' '/ DATA INCASE(229)/'DIWP'/ DATA (INAME(229,J),J=1,4)/'DISC','WEIB',' ',' '/ DATA INCASE(230)/'GLGP'/ DATA (INAME(230,J),J=1,4)/'GENE','LOST','GAME',' '/ C C-----START POINT----------------------------------------------------- C IERROR='NO' C ISUBN1='DPCH' ISUBN2='SQ ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=2 MINN2=3 C ICOLR=0 C C *************************************** C ** TREAT THE CHI-SQUARE GOODNESS OF FIT CASE ** C *************************************** C IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CHSQ')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPCHSQ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICASPL 52 FORMAT('ICASPL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGA2,IBUGA3,IBUGQ 53 FORMAT('IBUGA2,IBUGA3,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) DO100I=1,NUMCHS IROW=I IF(INAME(I,1).NE.ICOM)GOTO100 DO102J=1,4 IF(INAME(I,J).NE.' ')GOTO102 ITEMP=J-1 GOTO104 102 CONTINUE ITEMP=4 104 CONTINUE ILASTC=0 IF(ITEMP.GT.1)THEN DO108J=2,ITEMP IF(INAME(I,J).NE.IHARG(J-1))GOTO100 108 CONTINUE ILASTC=ITEMP-1 ENDIF I1=ILASTC+1 I2=ILASTC+2 I3=ILASTC+3 I4=ILASTC+4 I5=ILASTC+5 I6=ILASTC+6 IF(IHARG(I1).EQ.'CHI '.AND.IHARG(I2).EQ.'SQUA'.AND. 1 IHARG(I3).EQ.'GOOD'.AND.IHARG(I4).EQ.'OF '.AND. 1 IHARG(I5).EQ.'FIT '.AND.IHARG(I6).EQ.'TEST')THEN ILASTC=I6 GOTO112 END IF IF(IHARG(I1).EQ.'CHI '.AND.IHARG(I2).EQ.'SQUA'.AND. 1 IHARG(I3).EQ.'GOOD'.AND.IHARG(I4).EQ.'OF '.AND. 1 IHARG(I5).EQ.'FIT ')THEN ILASTC=I5 GOTO112 END IF IF(IHARG(I1).EQ.'CHI '.AND.IHARG(I2).EQ.'GOOD'.AND. 1 IHARG(I3).EQ.'OF '.AND.IHARG(I4).EQ.'FIT '.AND. 1 IHARG(I5).EQ.'TEST')THEN ILASTC=I5 GOTO112 END IF IF(IHARG(I1).EQ.'CHI '.AND.IHARG(I2).EQ.'GOOD'.AND. 1 IHARG(I3).EQ.'OF '.AND.IHARG(I4).EQ.'FIT ')THEN ILASTC=I4 GOTO112 END IF IF(IHARG(I1).EQ.'CHIS'.AND.IHARG(I2).EQ.'GOOD'.AND. 1 IHARG(I3).EQ.'OF '.AND.IHARG(I4).EQ.'FIT '.AND. 1 IHARG(I5).EQ.'TEST')THEN ILASTC=I5 GOTO112 END IF IF(IHARG(I1).EQ.'CHIS'.AND.IHARG(I2).EQ.'GOOD'.AND. 1 IHARG(I3).EQ.'OF '.AND.IHARG(I4).EQ.'FIT ')THEN ILASTC=I4 GOTO112 END IF IF(IHARG(I1).EQ.'CHI '.AND.IHARG(I2).EQ.'TEST')THEN ILASTC=I2 GOTO112 END IF IF(IHARG(I1).EQ.'CHIS'.AND.IHARG(I2).EQ.'TEST')THEN ILASTC=I2 GOTO112 END IF C CCCCC ICASPL=' ' CCCCC IFOUND='NO' CCCCC GOTO9000 100 CONTINUE C C ----------NO MATCH FOUND---------- C ICASPL=' ' IFOUND='NO' GOTO9000 C 112 CONTINUE ICASPL=INCASE(IROW) CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) IFOUND='YES' GOTO190 C 190 CONTINUE C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ******************************************** C ** STEP 3-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='3' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(1) IHLEF2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) IF(IBUGA2.EQ.'ON')WRITE(ICOUT,211)IHLEFT,IHLEF2,ICOLL,NLEFT 211 FORMAT('IHLEFT,IHLEF2,ICOLL,NLEFT = ',A4,A4,I8,I8) IF(IBUGA2.EQ.'ON')CALL DPWRST('XXX','BUG ') C C ******************************************************* C ** STEP 4-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) C ** FOR THE RESPONSE VARIABLE IS POSITIVE. ** C ******************************************************* C ISTEPN='4' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPCHSQ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312)IHLEFT,IHLEF2 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS ', 1'IN VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) 313 FORMAT(' (FOR WHICH A CHI-SQUARE GOODNESS OF FIT TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' WAS TO HAVE BEEN FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)MINN2 315 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,316) 316 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,317) 317 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,318)(IANS(I),I=1,IWIDTH) 318 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 390 CONTINUE C C ***************************************** C ** STEP 5-- ** C ** CHECK TO SEE THE TYPE SUBCASE ** C ** (BASED ON THE QUALIFIER)-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='5' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO480 DO400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO420 400 CONTINUE GOTO490 410 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO490 420 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO490 C 480 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,481) 481 FORMAT('***** INTERNAL ERROR IN DPCHSQ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,482) 482 FORMAT(' AT BRANCH POINT 481--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,483) 483 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,484) 484 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,485)NUMARG 485 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,486) 486 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,487)(IANS(I),I=1,IWIDTH) 487 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 490 CONTINUE IF(IBUGA2.EQ.'OFF')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ,ICASEQ 491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C ****************************************************** C ** STEP 6-- ** C ** IF A SECOND ARGUMENT EXISTS, THEN THIS ** C ** INDICATES THAT THE VALUES IN THE ** C ** FIRST VARIABLE ARE NOT DATA POINTS ** C ** BUT ALREADY-COMPUTED FREQUENCIES, ** C ** AND THE VALUES IN THE SECOND VARIABLE ** C ** ARE THE CORRESPONDING X VALUES FOR EACH ** C ** FREQUENCY. IF WE HAVE THE 2-VARIABLE CASE, ** C ** CHECK THE VALIDITY OF THE SECOND (X) VARIABLE. ** C ****************************************************** C ISTEPN='6' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IDATSW='RAW' IF(NUMV2.EQ.1)IDATSW='RAW' IF(NUMV2.EQ.1)GOTO590 IF(NUMV2.EQ.2)IDATSW='FREQ' IF(NUMV2.EQ.2)GOTO509 IF(NUMV2.EQ.3)IDATSW='CLAS' IF(NUMV2.EQ.3)GOTO509 GOTO550 C 509 CONTINUE IHRIGH=IHARG(2) IHRIG2=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHRIGH,IHRIG2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLR=IVALUE(ILOCV) NRIGHT=IN(ILOCV) IF(IBUGA2.EQ.'ON')WRITE(ICOUT,511)IHRIGH,IHRIG2,ICOLR,NRIGHT 511 FORMAT('IHRIGH,IHRIG2,ICOLR,NRIGHT = ',A4,2X,A4,I8,I8) IF(IBUGA2.EQ.'ON')CALL DPWRST('XXX','BUG ') 510 CONTINUE C IF(NRIGHT.NE.NLEFT)GOTO570 IF(NUMV2.GT.2)GOTO519 GOTO590 C 519 CONTINUE IHTHIR=IHARG(3) IHTHI2=IHARG2(3) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHTHIR,IHTHI2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOL3=IVALUE(ILOCV) NRIGH2=IN(ILOCV) IF(IBUGA2.EQ.'ON')WRITE(ICOUT,521)IHTHIR,IHTHI2,ICOL3,NRIGH2 521 FORMAT('IHTHIR,IHTHI2,ICOL3,NRIGH2 = ',A4,2X,A4,I8,I8) IF(IBUGA2.EQ.'ON')CALL DPWRST('XXX','BUG ') 530 CONTINUE C IF(NRIGH2.NE.NLEFT)GOTO570 GOTO590 C C 550 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,551) 551 FORMAT('***** ERROR IN DPCHSQ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,552) 552 FORMAT(' FOR A ... CHI-SQUARE GOODNESS OF FIT TEST, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,558) 558 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) 559 FORMAT(' MUST BE EITHER 1, 2, OR 3 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,560) 560 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,561) 561 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,562)NUMV2 562 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,563) 563 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,564)(IANS(I),I=1,MIN(IWIDTH,80)) 564 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 570 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,571) 571 FORMAT('***** ERROR IN DPCHSQ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,572) 572 FORMAT(' FOR A ... CHI-SQUARE GOODNESS OF FIT TEST, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,578) 578 FORMAT(' WHEN HAVE 2 (OR 3) VARIABLES SPECIFIED, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,579) 579 FORMAT(' THE NUMBER OF ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,580) 580 FORMAT(' IN THE 2 (OR 3) VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,581) 581 FORMAT(' MUST BE THE SAME; ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,582) 582 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,583) 583 FORMAT(' THE FIRST VARIABLE (FREQUENCIES)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,584)IHLEFT,IHLEF2,NLEFT 584 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,585) 585 FORMAT(' THE SECOND VARIABLE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,586)IHRIGH,IHRIG2,NRIGHT 586 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') IF(NUMV2.GE.3)THEN WRITE(ICOUT,1585) 1585 FORMAT(' THE THIRD VARIABLE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1586)IHTHIR,IHTHI2,NRIGH2 1586 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,587) 587 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,588)(IANS(I),I=1,IWIDTH) 588 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 590 CONTINUE C C ***************************************** C ** STEP 7-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** (BASED ON THE QUALIFIER) ** C ** THEN FORM THE RESPONSE VARIABLE ** C ** AND THE FACTORS ** C ** AND CARRY OUT THE PLOTS. ** C ***************************************** C ISTEPN='7' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO610 IF(ICASEQ.EQ.'SUBS')GOTO620 IF(ICASEQ.EQ.'FOR')GOTO630 C 610 CONTINUE DO615I=1,NLEFT ISUB(I)=1 615 CONTINUE NQ=NLEFT GOTO650 C 620 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4) NQ=NIOLD GOTO650 C 630 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO650 C 650 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO660I=1,IMAX IF(ISUB(I).EQ.0)GOTO660 J=J+1 C IF(NUMV2.GE.1)THEN IJ=MAXN*(ICOLL-1)+I IF(ICOLL.LE.MAXCOL)Y1(J)=V(IJ) IF(ICOLL.EQ.MAXCP1)Y1(J)=PRED(I) IF(ICOLL.EQ.MAXCP2)Y1(J)=RES(I) IF(ICOLL.EQ.MAXCP3)Y1(J)=YPLOT(I) IF(ICOLL.EQ.MAXCP4)Y1(J)=XPLOT(I) IF(ICOLL.EQ.MAXCP5)Y1(J)=X2PLOT(I) IF(ICOLL.EQ.MAXCP6)Y1(J)=TAGPLO(I) ENDIF C IF(NUMV2.GE.2)THEN IJ=MAXN*(ICOLR-1)+I IF(ICOLR.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLR.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLR.EQ.MAXCP2)X1(J)=RES(I) IF(ICOLR.EQ.MAXCP3)X1(J)=YPLOT(I) IF(ICOLR.EQ.MAXCP4)X1(J)=XPLOT(I) IF(ICOLR.EQ.MAXCP5)X1(J)=X2PLOT(I) IF(ICOLR.EQ.MAXCP6)X1(J)=TAGPLO(I) ENDIF C IF(NUMV2.GE.3)THEN IJ=MAXN*(ICOL3-1)+I IF(ICOL3.LE.MAXCOL)X2(J)=V(IJ) IF(ICOL3.EQ.MAXCP1)X2(J)=PRED(I) IF(ICOL3.EQ.MAXCP2)X2(J)=RES(I) IF(ICOL3.EQ.MAXCP3)X2(J)=YPLOT(I) IF(ICOL3.EQ.MAXCP4)X2(J)=XPLOT(I) IF(ICOL3.EQ.MAXCP5)X2(J)=X2PLOT(I) IF(ICOL3.EQ.MAXCP6)X2(J)=TAGPLO(I) ENDIF C 660 CONTINUE NLOCAL=J C C *********************************************** C ** STEP 8-- ** C ** FOR THOSE DISTRIBUTIONS REQUIRING THEM, ** C ** DETERMINE IF THE ANALYST ** C ** HAS SPECIFIED PARAMETER VALUES ** C *********************************************** C ISTEPN='8' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASPL.EQ.'LAPP')THEN IHP='LAMB' IHP2='DA ' IDIST='LAMBDA' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST, 1 ALAMBA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'TPP')THEN IHP='NU ' IHP2=' ' IDIST='T' CCCCC ILOWLM=1 CCCCC IUPPLM=I1MACH(9) CCCCC LOWLTY='>= ' CCCCC UPPLTY='<= ' CCCCC CALL PARCHI(IHP,IHP2,IDIST,NU,ILOWLM,IUPPLM,LOWLTY,UPPLTY, CCCCC1 ISUBN1,ISUBN2,IERROR) ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST, 1 ANU,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'CSPP')THEN IHP='NU ' IHP2=' ' IDIST='CHI-SQUARED' ILOWLM=1 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,NU,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'FPP')THEN IHP='NU1 ' IHP2=' ' IDIST='F ' ILOWLM=1 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,NU1,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='NU2 ' IHP2=' ' CALL PARCHI(IHP,IHP2,IDIST,NU2,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) GOTO4999 ENDIF IF(ICASPL.EQ.'GAPP')THEN IHP='GAMM' IHP2='A ' IDIST='GAMMA' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'BEPP')THEN IHP='ALPH' IHP2='A ' IDIST='BETA' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2=' ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) GOTO4999 ENDIF IF(ICASPL.EQ.'BNPP')THEN IHP='ALPH' IHP2='A ' IDIST='BETA' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2=' ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) GOTO4999 ENDIF IF(ICASPL.EQ.'WEPP')THEN IHP='GAMM' IHP2='A ' IDIST='WEIBULL' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'E2PP')THEN IHP='GAMM' IHP2='A ' IDIST='EXTREME VALUE TYPE 2' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'PAPP')THEN IHP='GAMM' IHP2='A ' IDIST='PARETO' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='A ' IHP2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN A=1.0 ELSE A=VALUE(ILOCP) ENDIF C GOTO4999 ENDIF IF(ICASPL.EQ.'BIPP')THEN IDIST='BINOMIAL' IHP='N ' IHP2=' ' ILOWLM=1 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,NPAR,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='P ' IHP2=' ' ALOWLM=0.0 AUPPLM=1.0 LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,P,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'GEPP')THEN IHP='P ' IHP2=' ' IDIST='GEOMETRIC' ALOWLM=0.0 AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,P,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'POPP')THEN IHP='LAMB' IHP2='DA ' IDIST='POISSON' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALAMBA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'NBPP')THEN IDIST='NEGATIVE BINOMIAL' IHP='K ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,AK,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='P ' IHP2=' ' ALOWLM=0.0 AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,P,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'IGPP')THEN IHP='GAMM' IHP2='A ' IDIST='INVERSE GAUSSIAN' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='MU ' IHP2=' ' IDIST='INVERSE GAUSSIAN' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,AMU,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')THEN AMU=1.0 ENDIF GOTO4999 ENDIF IF(ICASPL.EQ.'WAPP')THEN IHP='GAMM' IHP2='A ' IDIST='WALD' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'RIPP')THEN IHP='GAMM' IHP2='A ' IDIST='RECIRPOCAL INVERSE GAUSSIAN' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='MU ' IHP2=' ' IDIST='RECIPROCAL INVERSE GAUSSIAN' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,AMU,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')THEN AMU=1.0 ENDIF GOTO4999 ENDIF IF(ICASPL.EQ.'FLPP')THEN IHP='GAMM' IHP2='A ' IDIST='FATIGUE LIFE' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'GPPP')THEN IHP='GAMM' IHP2='A ' IDIST='GENERALIZED PARETO' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'TRPP')THEN IHP='C ' IHP2=' ' IHWUSE='P' MESSAG='NO ' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN C=0.0 ELSE C=VALUE(ILOCP) ENDIF GOTO4999 ENDIF IF(ICASPL.EQ.'DUPP')THEN IHP='N ' IHP2=' ' IDIST='DISCRETE UNIFORM' ILOWLM=1 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,NDUN,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'LCPP')THEN IDIST='LEADS IN COIN TOSSING' IHP='N ' IHP2=' ' ILOWLM=0 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,NDUN,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'MAPP')THEN IDIST='MATCHING' IHP='K ' IHP2=' ' ILOWLM=0 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,K,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'OCPP')THEN IDIST='CLASSICAL OCCUPANCY' IHP='B ' IHP2=' ' ILOWLM=1 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,NDUN,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='C ' IHP2=' ' ILOWLM=1 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,K,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) GOTO4999 ENDIF IF(ICASPL.EQ.'NCBP')THEN IHP='ALPH' IHP2='A ' IDIST='NON-CENTRAL BETA' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='LAMB' IHP2='DA ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALAMBA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'NCPP')THEN IHP='NU ' IHP2=' ' IDIST='NON-CENTRAL CHI-SQUARED' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ANU,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='LAMB' IHP2='DA ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALAMBA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'NFPP')THEN IHP='NU1 ' IHP2=' ' IDIST='NON-CENTRAL F' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ANU1,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='NU2 ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ANU2,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='LAMB' IHP2='DA ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALAMBA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'NTPP')THEN IHP='NU ' IHP2=' ' IDIST='NON-CENTRAL T' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ANU,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='LAMB' IHP2='DA ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALAMBA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'DNCF')THEN IHP='NU1 ' IHP2=' ' IDIST='DOUBLY NON-CENTRAL F' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ANU1,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='NU2 ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ANU2,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='LAMB' IHP2='DA1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALAMB1,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='LAMB' IHP2='DA2 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALAMB2,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'DNCT')THEN IHP='NU ' IHP2=' ' IDIST='DOUBLY NON-CENTRAL T' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ANU,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='LAMB' IHP2='DA1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALAMB1,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='LAMB' IHP2='DA2 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALAMB2,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'HYPP')THEN IHP='M ' IHP2=' ' IDIST='HYPERGEOMETRIC' ILOWLM=1 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,MPAR,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='N ' IHP2=' ' ILOWLM=1 IUPPLM=MPAR LOWLTY='>= ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,NPAR,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='K ' IHP2=' ' ILOWLM=1 IUPPLM=MPAR LOWLTY='>= ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,K,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'VMPP')THEN IHP='B ' IHP2=' ' IDIST='VON MISES' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,B,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'PNPP')THEN IHP='P ' IHP2=' ' IDIST='POWER NORMAL' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,P,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='SD ' IHP2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES'.OR.VALUE(ILOCP).LE.0.0)THEN SD=1.0 ELSE SD=VALUE(ILOCP) ENDIF GOTO4999 ENDIF IF(ICASPL.EQ.'PLPP')THEN IHP='P ' IHP2=' ' IDIST='POWER LOG-NORMAL' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,P,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='SD ' IHP2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES'.OR.VALUE(ILOCP).LE.0.0)THEN SD=1.0 ELSE SD=VALUE(ILOCP) ENDIF GOTO4999 ENDIF IF(ICASPL.EQ.'ALPP')THEN IHP='ALPH' IHP2='A ' IDIST='ALPHA' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'LNPP')THEN IHP='SIGM' IHP2='A ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES'.OR.VALUE(ILOCP).LE.0.0)THEN SIGMA=1.0 ELSE SIGMA=VALUE(ILOCP) ENDIF GOTO4999 ENDIF IF(ICASPL.EQ.'PFPP')THEN IDIST='POWER FUNCTION' IHP='C ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,C,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'CHPP')THEN IDIST='CHI' IHP='NU ' IHP2=' ' IDIST='CHI' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ANU,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'DLPP')THEN IDIST='LOGARITHMIC SERIES' IHP='THET' IHP2='A ' ALOWLM=0. AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,THETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'GSPP')THEN IDIST='GENERALIZED LOGARITHMIC SERIES' IHP='THET' IHP2='A ' ALOWLM=0. AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,THETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2=' ' ALOWLM=1.0 AUPPLM=1.0/THETA LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'GNBP')THEN IDIST='GENERALIZED NEGATIVE BINOMIAL' IHP='THET' IHP2='A ' ALOWLM=0. AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,THETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2=' ' ALOWLM=1.0 AUPPLM=1.0/THETA LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')THEN IF(BETA.NE.0.0)THEN GOTO9000 ENDIF ENDIF IHP='M ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,AM,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'QBPP')THEN IDIST='QUASI BINOMIAL TYPE I' IHP='P ' IHP2=' ' ALOWLM=0. AUPPLM=1.0 LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,P,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='M ' IHP2=' ' ILOWLM=0 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,IM,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) AM=REAL(IM) IF(IERROR.EQ.'YES')GOTO9000 IHP='PHI ' IHP2=' ' ALOWLM=-P/AM AUPPLM=(1.0-P)/AM LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,PHI,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'LKPP')THEN IDIST='LAGRANGE KATZ' IHP='A ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,A,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2=' ' ALOWLM=CPUMIN AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='B ' IHP2=' ' ALOWLM=-BETA AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,B,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'KZPP')THEN IDIST='KATZ' IHP='ALPH' IHP2='A ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2=' ' ALOWLM=CPUMIN AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'QBPP')THEN IDIST='QUASI BINOMIAL TYPE I' IHP='P ' IHP2=' ' ALOWLM=0. AUPPLM=1.0 LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,P,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='M ' IHP2=' ' ILOWLM=0 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,IM,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) AM=REAL(IM) IF(IERROR.EQ.'YES')GOTO9000 IHP='PHI ' IHP2=' ' ALOWLM=-P/AM AUPPLM=(1.0-P)/AM LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,PHI,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'GETP')THEN IDIST='GEETA' IF(IGETDF.EQ.'THET')THEN IHP='THET' IHP2='A ' ALOWLM=0. AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,THETA,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2=' ' ALOWLM=1.0 AUPPLM=1.0/THETA LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')THEN IF(BETA.NE.0.0)THEN GOTO9000 ENDIF ENDIF IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ELSE IHP='MU ' IHP2=' ' ALOWLM=1.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,AMU,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2=' ' ALOWLM=1.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF ENDIF IF(ICASPL.EQ.'CNPP')THEN IDIST='CONSUL (GENERALIZED GEOMETRIC)' IF(ICONDF.EQ.'THET')THEN IHP='THET' IHP2='A ' ALOWLM=0. AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,THETA,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='M ' IHP2=' ' ALOWLM=1.0 AUPPLM=1.0/THETA LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,AM,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ELSE IHP='MU ' IHP2=' ' ALOWLM=1.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,AMU,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='M ' IHP2=' ' ALOWLM=1.0 AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,AM,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF ENDIF IF(ICASPL.EQ.'AEPP')THEN IDIST='POLYA-AEPPLI' IHP='THET' IHP2='A ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,THETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='P ' IHP2=' ' ALOWLM=0. AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,P,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'LOST')THEN IDIST='LOST GAMES' IHP='P ' IHP2=' ' ALOWLM=0.5 AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,P,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='R ' IHP2=' ' ILOWLM=0 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,NU,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'GLGP')THEN IDIST='GENERALIZED LOST GAMES' IHP='P ' IHP2=' ' ALOWLM=0.5 AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,P,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='A ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,A,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='J ' IHP2=' ' ILOWLM=0 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,NU,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'DIWP')THEN IDIST='DISCRETE WEIBULL' IHP='Q ' IHP2=' ' ALOWLM=0. AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,P,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'LLPP')THEN IHP='DELT' IHP2='A ' IDIST='LOG-LOGISTIC' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,DELTA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'GGPP')THEN IHP='ALPH' IHP2='A ' IDIST='GENERALIZED GAMMA' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='C ' IHP2=' ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,C,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(C.NE.0.0)GOTO4829 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4821) 4821 FORMAT('***** ERROR IN DPCHSQ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4822) 4822 FORMAT(' THE SPECIFIED SHAPE PARAMETER C') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4823) 4823 FORMAT(' FOR THE GENERALIZED GAMMA DISTRIBUTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4824) 4824 FORMAT(' CANNOT BE EQUAL TO 0;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4825) 4825 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4826)C 4826 FORMAT(' THE SPECIFIED VALUE OF C = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 4829 CONTINUE GOTO4999 ENDIF IF(ICASPL.EQ.'YUPP')THEN IDIST='YULE' IHP='P ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,P,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'WRPP')THEN IDIST='WARING' IHP='C ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,C,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='A ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,A,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IF(C.LE.A)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4911) 4911 FORMAT('***** ERROR--CHI-SQUARE GOODNESS OF FIT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4912) 4912 FORMAT(' THE VALUE FOR THE SPECIFIED SHAPE PARAMETER ', 1 'C FOR THE WARING DISTRIBUTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4913) 4913 FORMAT(' MUST BE GREATER THAN THE VALUE FOR THE ', 1 'SPECIFIED SHAPE PARAMETER A.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4915) 4915 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4916)C 4916 FORMAT(' THE SPECIFIED VALUE OF C = ',G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4918)A 4918 FORMAT(' THE SPECIFIED VALUE OF A = ',G15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF GOTO4999 ENDIF IF(ICASPL.EQ.'FNPP')THEN IHP='MU ' IHP2=' ' IHWUSE='P' MESSAG='NO ' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN AM=0.0 ELSE AM=VALUE(ILOCP) ENDIF C IHP='SD ' IHP2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES'.OR.VALUE(ILOCP).LE.0.0)THEN SD=1.0 ELSE SD=VALUE(ILOCP) ENDIF GOTO4999 ENDIF IF(ICASPL.EQ.'TNPP')THEN IHP='A ' IHP2=' ' IHWUSE='P' MESSAG='NO ' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN A=-99.9 ELSE A=VALUE(ILOCP) ENDIF C IHP='B ' IHP2=' ' IHWUSE='P' MESSAG='NO ' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN B=-99.9 ELSE B=VALUE(ILOCP) ENDIF C IHP='M ' IHP2=' ' IHWUSE='P' MESSAG='NO ' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN AM=0.0 ELSE AM=VALUE(ILOCP) ENDIF C IHP='SD ' IHP2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES'.OR.VALUE(ILOCP).LE.0.0)THEN SD=1.0 ELSE SD=VALUE(ILOCP) ENDIF GOTO4999 ENDIF IF(ICASPL.EQ.'LGPP')THEN IHP='GAMM' IHP2='A ' IDIST='LOG-GAMMA' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'GOPP')THEN IHP='C ' IHP2=' ' IDIST='GOMPERTZ' ALOWLM=1. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,C,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='B ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,B,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'GVPP')THEN IHP='GAMM' IHP2='A ' IDIST='GENERALIZED EXTREME VALUE' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF C CCCCC MAY 2005. FOLLOWING SHOULD BE FOR GENERALIZED HALF-LOGISTIC, CCCCC NOT REGULAR HALF-LOGISITC. C CCCCC IF(ICASPL.EQ.'HLPP')THEN IF(ICASPL.EQ.'GZPP')THEN IHP='GAMM' IHP2='A ' IDIST='GENERALIZED HALF-LOGISTIC' ALOWLM=0.0 AUPPLM=5.0 LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'P2PP')THEN IHP='GAMM' IHP2='A ' IDIST='PARETO TYPE 2' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='A ' IHP2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN A=1.0 ELSE A=VALUE(ILOCP) ENDIF C GOTO4999 ENDIF IF(ICASPL.EQ.'DWPP')THEN IHP='GAMM' IHP2='A ' IDIST='DOUBLE WEIBULL' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'WCPP')THEN IHP='P ' IHP2=' ' IDIST='WRAPPED CAUCHY' ALOWLM=0. AUPPLM=1. LOWLTY='>= ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,P,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'EWPP')THEN IHP='GAMM' IHP2='A ' IDIST='EXPONENTIATED WEIBULL' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='THET' IHP2='A ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,THETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'TEPP')THEN IHP='X0 ' IHP2=' ' IDIST='TRUNCATED EXPONENTIAL' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,X0,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='M ' IHP2=' ' IHWUSE='P' MESSAG='NO ' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN AM=0.0 ELSE AM=VALUE(ILOCP) ENDIF C IHP='SD ' IHP2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES'.OR.VALUE(ILOCP).LE.0.0)THEN SD=1.0 ELSE SD=VALUE(ILOCP) ENDIF GOTO4999 ENDIF IF(ICASPL.EQ.'GLPP')THEN IHP='ALPH' IHP2='A ' IDIST='GENERALIZED LOGISTIC' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'G2PP')THEN IHP='ALPH' IHP2='A ' IDIST='GENERALIZED LOGISTIC TYPE 2' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'G3PP')THEN IHP='ALPH' IHP2='A ' IDIST='GENERALIZED LOGISTIC TYPE 3' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'G4PP')THEN IDIST='GENERALIZED LOGISTIC TYPE 4' IHP='P ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,P,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='Q ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,Q,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'G5PP')THEN IDIST='GENERALIZED LOGISTIC TYPE 5 (HOSKING)' C IHP='ALPH' IHP2='A ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF C IF(ICASPL.EQ.'WAKE')THEN IDIST='WAKEBY' C IHP='GAMM' IHP2='A ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2=' ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='DELT' IHP2='A ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,DELTA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'PEPP')THEN IDIST='EXPONENTIAL POWER' IHP='ALPH' IHP2='A ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'DGPP')THEN IHP='GAMM' IHP2='A ' IDIST='DOUBLE GAMMA' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'KAPP')THEN IHP='BETA' IHP2=' ' IDIST='MIELKE BETA-KAPPA' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='THET' IHP2='A ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,THETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='K ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ANU,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'FCPP')THEN IHP='LOC ' IHP2=' ' IHWUSE='P' MESSAG='NO ' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN AM=0.0 ELSE AM=VALUE(ILOCP) ENDIF C IHP='SCAL' IHP2='E ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES'.OR.VALUE(ILOCP).LE.0.0)THEN SD=1.0 ELSE SD=VALUE(ILOCP) ENDIF GOTO4999 ENDIF IF(ICASPL.EQ.'BBPP')THEN IHP='ALPH' IHP2='A ' IDIST='BETA-BINOMIAL' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='N ' IHP2=' ' ILOWLM=0 IUPPLM=I1MACH(9) LOWLTY='> ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,NU,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'PZPP')THEN IDIST='POLYA' IHP='ALPH' IHP2='A ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='N ' IHP2=' ' ILOWLM=0 IUPPLM=I1MACH(9) LOWLTY='> ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,NU,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'BGPP')THEN IDIST='BETA-GEOMETRIC' IHP='ALPH' IHP2='A ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'BZPP')THEN IDIST='BETA-NEGATIVE BINOMIAL' IHP='ALPH' IHP2='A ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='K ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,AK,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'ZEPP')THEN IHP='ALPH' IHP2='A ' IDIST='ZETA' ALOWLM=1. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'ZIPP')THEN IDIST='ZIPF' IHP='ALPH' IHP2='A ' ALOWLM=1. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='N ' IHP2=' ' ILOWLM=1 IUPPLM=I1MACH(9) LOWLTY='> ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,NU,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'BRPP')THEN IHP='BETA' IHP2=' ' IDIST='BRADFORD' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'GXPP')THEN IHP='LAMB' IHP2='DA1 ' IDIST='GENERALIZED EXPONENTIAL' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALAMB1,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='LAMB' IHP2='DA2 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALAMB2,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='S ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'REPP')THEN IHP='B ' IHP2=' ' IDIST='RECIPROCAL' ALOWLM=1. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,B,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'NMPP')THEN IHP='U1 ' IHP2=' ' IDIST='NORMAL MIXTURE' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,U1,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='U2 ' IHP2=' ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,U2,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='SD1 ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,SD1,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='SD2 ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,SD2,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='P ' IHP2=' ' ALOWLM=0.0 AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,P,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'GIPP')THEN IHP='GAMM' IHP2='A ' IDIST='INVERTED GAMMA' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'IWPP')THEN IHP='GAMM' IHP2='A ' IDIST='INVERTED WEIBULL' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'LXPP')THEN IHP='ALPH' IHP2='A ' IDIST='LOG DOUBLE EXPONENTIAL' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST, 1 ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'AXPP')THEN IDIST='ASYMMETRIC LOG DOUBLE EXPONENTIAL' IHP='ALPH' IHP2='A ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST, 1 ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST, 1 BETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'JUPP')THEN IHP='ALPH' IHP2='A1 ' IDIST='JOHNSON SU' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST, 1 ALPHA1,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='ALPH' IHP2='A2 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST, 1 ALPHA2,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'JBPP')THEN IHP='ALPH' IHP2='A1 ' IDIST='JOHNSON SB' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST, 1 ALPHA1,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='ALPH' IHP2='A2 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST, 1 ALPHA2,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'LDPP')THEN IHP='LAMB' IHP2='DA3 ' IDIST='GENERALIZED TUKEY-LAMBDA' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST, 1 ALAMB3,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='LAMB' IHP2='DA4 ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST, 1 ALAMB4,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) CCCCC IWRITE='OFF' CCCCC ZSCALE=1.0 CCCCC CALL GLDCHK(ALAMB3,ALAMB4,ALOWER,AUPPER,IFLAG,ISIGN,IWRITE) CCCCC IF(ISIGN.LT.0)ZSCALE=-1.0 IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'EEPP')THEN IHP='GAMM' IHP2='A ' IDIST='GEOMETRIC EXTREME EXPONENTIAL' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF C IF(ICASPL.EQ.'ERPP')THEN IHP='ALPH' IHP2='A ' IDIST='ERROR (EXPONENTIAL POWER)' ALOWLM=1.0 AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF C IF(ICASPL.EQ.'TSPP')THEN IHP='THET' IHP2='A ' IDIST='TWO-SIDED POWER' ALOWLM=0. AUPPLM=1.0 LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,THETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='N ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ANU,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF IF(ICASPL.EQ.'BWPP')THEN IHP='SCAL' IHP2='E1 ' IDIST='BIWEIBULL' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,SCALE1,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='SCAL' IHP2='E2 ' IDIST='BIWEIBULL' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,SCALE2,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='GAMM' IHP2='A1 ' IDIST='BIWEIBULL' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA1,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='GAMM' IHP2='A2 ' IDIST='BIWEIBULL' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA2,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='LOC2' IHP2=' ' IDIST='BIWEIBULL' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,LOC2,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF C IF(ICASPL.EQ.'TZPP')THEN IHP='A ' IHP2=' ' IHWUSE='P' MESSAG='YES' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 A=VALUE(ILOCP) C IHP='B ' IHP2=' ' IHWUSE='P' MESSAG='YES' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 B=VALUE(ILOCP) C IHP='C ' IHP2=' ' IHWUSE='P' MESSAG='YES' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C=VALUE(ILOCP) C IHP='D ' IHP2=' ' IHWUSE='P' MESSAG='YES' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 DZ=VALUE(ILOCP) C IF(A.GE.B .OR. B.GE.C .OR. C.GE.DZ)THEN WRITE(ICOUT,7312) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7313) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7314) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7316)A,B,C,DZ CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF 7312 FORMAT( 1'***** FATAL ERROR--FOR THE TRAPEZOID DISTRIBUTION, THE FOUR') 7313 FORMAT( 1' SHAPE PARAMETERS (A, B, C, D) MUST SATISFY') 7314 FORMAT( 1' A < B < C < D') 7316 FORMAT( 1' A, B, C, D = ',4E15.7) C ENDIF C IF(ICASPL.EQ.'GTPP')THEN IHP='A ' IHP2=' ' IHWUSE='P' MESSAG='YES' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 A=VALUE(ILOCP) C IHP='B ' IHP2=' ' IHWUSE='P' MESSAG='YES' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 B=VALUE(ILOCP) C IHP='C ' IHP2=' ' IHWUSE='P' MESSAG='YES' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C=VALUE(ILOCP) C IHP='D ' IHP2=' ' IHWUSE='P' MESSAG='YES' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 DZ=VALUE(ILOCP) C IHP='ALPH' IHP2='A ' IDIST='GENERALIZED TRAPEZOID' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='NU1 ' IHP2=' ' IDIST='GENERALIZED TRAPEZOID' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ANU1,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='NU3 ' IHP2=' ' IDIST='GENERALIZED TRAPEZOID' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ANU3,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IF(A.GE.B .OR. B.GE.C .OR. C.GE.DZ)THEN WRITE(ICOUT,7322) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7323) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7324) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7326)A,B,C,DZ CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF 7322 FORMAT( 1'***** FATAL ERROR--FOR THE GENERALZIED TRAPEZOID DISTRIBUTION,') 7323 FORMAT( 1' THE FOUR SHAPE PARAMETERS (A, B, C, D) MUST SATISFY') 7324 FORMAT( 1' A < B < C < D') 7326 FORMAT( 1' A, B, C, D = ',4E15.7) C ENDIF C IF(ICASPL.EQ.'FTPP')THEN IHP='NU ' IHP2=' ' IDIST='FOLDED T' ALOWLM=1.0 AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ANU,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 NU=INT(ANU+0.5) GOTO4999 ENDIF C IF(ICASPL.EQ.'SNPP')THEN IHP='LAMB' IHP2='DA ' IDIST='SKEWED NORMAL' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,ALAMBA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF C IF(ICASPL.EQ.'STPP')THEN IHP='NU ' IHP2=' ' IDIST='SKEWED T' ALOWLM=1.0 AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ANU,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) NU=INT(ANU+0.5) IF(IERROR.EQ.'YES')GOTO9000 C IHP='LAMB' IHP2='DA ' IDIST='SKEWED NORMAL' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,ALAMBA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF C IF(ICASPL.EQ.'IBPP')THEN IHP='ALPH' IHP2='A ' IDIST='INVERTED BETA' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2=' ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) GOTO4999 ENDIF C IF(ICASPL.EQ.'GMPP')THEN IF(IMAKDF.EQ.'DLMF')THEN IDIST='GOMPERTZ-MAKEHAM' IHP='XI ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,XI,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='LAMB' IHP2='DA ' CALL PARCHR(IHP,IHP2,IDIST,ALAMBA,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) LOWLTY='>= ' IHP='THET' IHP2='A ' CALL PARCHR(IHP,IHP2,IDIST,THETA,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) ELSEIF(IMAKDF.EQ.'MEEK')THEN IDIST='GOMPERTZ-MAKEHAM' IHP='GAMM' IHP2='A ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,GAMMA,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 LOWLTY='>= ' IHP='LAMB' IHP2='DA ' CALL PARCHR(IHP,IHP2,IDIST,ALAMBA,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) LOWLTY='> ' IHP='K ' IHP2=' ' CALL PARCHR(IHP,IHP2,IDIST,AK,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) ELSEIF(IMAKDF.EQ.'REPA')THEN IDIST='GOMPERTZ-MAKEHAM' IHP='ETA ' IHP2=' ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ETA,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' IHP='ZETA' IHP2=' ' CALL PARCHR(IHP,IHP2,IDIST,ZETA,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) ENDIF GOTO4999 ENDIF C IF(ICASPL.EQ.'GIGP')THEN IHP='CHI ' IHP2=' ' IDIST='GOMPERTZ-MAKEHAM' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,CHI,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='LAMB' IHP2='DA ' CALL PARCHR(IHP,IHP2,IDIST,ALAMBA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' IHP='THET' IHP2='A ' LOWLTY='>= ' CALL PARCHR(IHP,IHP2,IDIST,THETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) GOTO4999 ENDIF C IF(ICASPL.EQ.'GHPP')THEN IHP='G ' IHP2=' ' IDIST='G-H' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,G,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ALOWLM=0.0 IHP='H ' IHP2=' ' CALL PARCHR(IHP,IHP2,IDIST,H,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) GOTO4999 ENDIF C IF(ICASPL.EQ.'HEPP')THEN IHP='ALPH' IHP2='A ' IDIST='HERMITE' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF C IF(ICASPL.EQ.'SDPP')THEN IDIST='SKEWED DOUBLE EXPONENTIAL' IHP='LAMB' IHP2='DA ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,ALAMBA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF C IF(ICASPL.EQ.'ADPP')THEN IDIST='ASYMMETRIC DOUBLE EXPONENTIAL' IF(IADEDF.EQ.'K')THEN IHP='K ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,AK,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ELSE IHP='MU ' IHP2=' ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,AMU,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF ENDIF C IF(ICASPL.EQ.'MXPP')THEN IDIST='MAXWELL' IHP='SIGM' IHP2='A ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,SIGMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF C IF(ICASPL.EQ.'GALP')THEN IDIST='GENERALIZED ASYMMETRIC DOUBLE EXPONENTIAL' IF(IADEDF.EQ.'K')THEN IHP='K ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,AK,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='TAU ' IHP2=' ' CALL PARCHR(IHP,IHP2,IDIST,TAU,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSE IHP='MU ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,AMU,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ENDIF GOTO4999 ENDIF C IF(ICASPL.EQ.'MCPP')THEN IDIST='MCLEISH' IHP='ALPH' IHP2='A ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF C IF(ICASPL.EQ.'GMCP')THEN IDIST='GENERALIZED MCLEISH' IHP='ALPH' IHP2='A ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='A ' IHP2=' ' ALOWLM=-1.0 AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,A,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF C IF(ICASPL.EQ.'BEIP' .OR. ICASPL.EQ.'BEKP')THEN IDIST='BESSEL I-FUNCTION' IF(ICASPL.EQ.'BEKP')IDIST='BESSEL K-FUNCTION' IF(IBEIDF.EQ.'1')THEN IHP='SIGM' IHP2='A1SQ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,SD1,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='SIGM' IHP2='A2SQ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,SD2,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='NU ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ANU,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ELSE IHP='B ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,B,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='C ' IHP2=' ' ALOWLM=1.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,C,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='M ' IHP2=' ' ALOWLM=0.5 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,AM,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF ENDIF C IF(ICASPL.EQ.'BTPP')THEN IDIST='BOREL-TANNER' IHP='LAMB' IHP2='DA ' ALOWLM=0.0 AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST, 1 ALAMBA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='K ' IHP2=' ' ILOWLM=1 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,K,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF C IF(ICASPL.EQ.'LPPP')THEN IDIST='LAGRANGE-POISSON' IHP='LAMB' IHP2='DA ' ALOWLM=0.0 AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST, 1 ALAMBA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='THET' IHP2='A ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST, 1 THETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF C IF(ICASPL.EQ.'LBPP')THEN IDIST='LOG-BETA' IHP='ALPH' IHP2='A ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALPHA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,BETA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='C ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,YLOWLM,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='D ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,YUPPLM,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF C CCCCC IF(ICASPL.EQ.'SEPP')THEN CCCCC IDIST='SEMI-CIRCULAR' CCCCC IHP='R ' CCCCC IHP2=' ' CCCCC ALOWLM=0. CCCCC AUPPLM=CPUMAX CCCCC LOWLTY='> ' CCCCC UPPLTY='< ' CCCCC CALL PARCHR(IHP,IHP2,IDIST, CCCCC1 SIGMA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, CCCCC1 ISUBN1,ISUBN2,IERROR) CCCCC IF(IERROR.EQ.'YES')GOTO9000 CCCCC GOTO4999 CCCCC ENDIF C 4999 CONTINUE C C LOCATION AND SCALE FOR ALL DISTRIBUTIONS C IHP='CHSL' IHP2='OC ' IHWUSE='P' MESSAG='NO ' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN CHSLOC=0.0 ELSE CHSLOC=VALUE(ILOCP) ENDIF C IHP='CHSS' IHP2='CALE' IHWUSE='P' MESSAG='NO ' CALL CHECKN(IHP,IHP2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN CHSCAL=1.0 ELSE CHSCAL=VALUE(ILOCP) ENDIF IF(CHSCAL.LE.0.0)CHSCAL=1.0 C C ***************************************************** C ** STEP 9-- ** C ** COMPUTE THE CHI-SQUARE GOODNESS OF FIT ** C ** TEST ** C ***************************************************** C ISTEPN='9' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'OFF')GOTO5190 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5111) 5111 FORMAT('***** FROM THE MIDDLE OF DPCHSQ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5112)ICASPL,NUMV2,NLOCAL,IDATSW 5112 FORMAT('ICASPL,NUMV2,NLOCAL,IDATSW = ',A4,I8,2X,I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5113)ALAMBA,NU,NU1,NU2 5113 FORMAT('ALAMBA,NU,NU1,NU2 = ',E15.7,I8,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5114)GAMMA,ALPHA,BETA,NPAR,P,K 5114 FORMAT('GAMMA,ALPHA,BETA,NPAR,P,K = ',3E15.7,I8,E15.7,I8) CALL DPWRST('XXX','BUG ') DO5116I=1,NLOCAL WRITE(ICOUT,5117)I,X1(I),Y1(I) 5117 FORMAT('I,X1(I),Y1(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 5116 CONTINUE 5190 CONTINUE C CLWID=CLWIDT(1) XSTART=CLLIMI(1) XSTOP=CLLIMI(2) IWRITE='ON' C CALL DPCHS2(Y1,X1,X2,NLOCAL,ICASPL,IDATSW,IRHSTG, 1ALAMBA,NU,NU1,NU2,GAMMA,ALPHA,BETA,NPAR,P,K,MINMAX, 1ANU,ANU1,ANU2,NDUN,C,ALAMB1,ALAMB2,MPAR,B,SD,THETA, 1DELTA,A,AM,X0, 1U1,SD1,U2,SD2,DZ,ANU3, 1ALAMB3,ALAMB4,ALPHA1,ALPHA2, CCCCC MAY 2002: ADD FOLLOWING LINE 1SCALE1,GAMMA1,LOC2,SCALE2,GAMMA2, 1AMU,XI,CHI,G,H,AK,SIGMA, 1ETA,ZETA,TAU,Q,AKAPPA,PHI, 1YLOWLM,YUPPLM, 1CLWID,XSTART,XSTOP, 1XTEMP3,IHSTCW,MAXOBV, 1CHSLOC,CHSCAL, 1STATVA,STATCD,STATNU,CUTU90,CUTU95,CUTU99, 1ICAPSW,ICAPTY,IWRITE,IADEDF,IGEPDF,IMAKDF,IBEIDF, 1ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF, 1PCHSLM, 1YOBS,XTEMP,XTEMP2,YEXP,NFREQ,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C *************************************** C ** STEP 61-- ** C ** WRITE INFO TO FILE ** C *************************************** C ISTEPN='61' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOUNI1=IST1NU IFILE1=IST1NA ISTAT1=IST1ST IFORM1=IST1FO IACCE1=IST1AC IPROT1=IST1PR ICURS1=IST1CS ISUBN0='FIT2' IERRF1='NO' C IREWI1='ON' CALL DPOPFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IF(NUMV2.LE.2)THEN DO6101I=1,NFREQ WRITE(IOUNI1,6109)I,XTEMP(I),YOBS(I),YEXP(I) 6101 CONTINUE 6109 FORMAT(I6,1X,3E15.7) ELSEIF(NUMV2.EQ.3)THEN DO6111I=1,NFREQ WRITE(IOUNI1,6112)I,XTEMP(I),XTEMP2(I),YOBS(I),YEXP(I) 6111 CONTINUE 6112 FORMAT(I6,1X,4E15.7) ENDIF C IENDF1='OFF' IREWI1='ON' CALL DPCLFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1IENDF1,IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IF(IPRINT.EQ.'OFF')GOTO6119 IF(NUMV2.LE.2)THEN WRITE(ICOUT,6120) 6120 FORMAT(6X,'CELL NUMBER, BIN MIDPOINT, OBSERVED FREQUENCY, ', 1'AND EXPECTED FREQUENCY ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6121) 6121 FORMAT(6X,'WRITTEN TO FILE DPST1F.DAT') CALL DPWRST('XXX','BUG ') ELSEIF(NUMV2.EQ.3)THEN WRITE(ICOUT,6122) 6122 FORMAT(6X,'CELL NUMBER, LOWER BIN POINT, UPPER BIN POINT, ', 1'OBSERVED FREQUENCY, AND EXPECTED FREQUENCY ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6123) 6123 FORMAT(6X,'WRITTEN TO FILE DPST1F.DAT') CALL DPWRST('XXX','BUG ') ENDIF C 6119 CONTINUE C C *************************************** C ** STEP 7-- ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C ISTEPN='7' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ISUBN0='DPCH' C IH='STAT' IH2='VAL ' VALUE0=STATVA CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='STAT' IH2='NU ' VALUE0=STATNU CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='STAT' IH2='CDF ' VALUE0=STATCD CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTU' IH2='PP90' VALUE0=CUTU90 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTU' IH2='PP95' VALUE0=CUTU95 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTU' IH2='PP99' VALUE0=CUTU99 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPCHSQ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NS,ICASPL 9013 FORMAT('NS,ICASPL = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ALAMBA,NU,NU1,NU2 9014 FORMAT('ALAMBA,NU,NU1,NU2 = ',E15.7,I8,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)GAMMA,ALPHA,BETA,NPAR,P,K 9015 FORMAT('GAMMA,ALPHA,BETA,NPAR,P,K = ',3E15.7,I8,E15.7,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)MINMAX 9016 FORMAT('MINMAX = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)ALPHA,BETA 9017 FORMAT('ALPHA,BETA = ',2E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPCHS2(Y,X,Z,N,ICASPL,IDATSW,IRHSTG, 1ALAMBA,NU,NU1,NU2,GAMMA,ALPHA,BETA,NPAR,P,K,MINMAX, 1ANU,ANU1,ANU2,NDUN,C,ALAMB1,ALAMB2,MPAR,B,SD,THETA,DELTA,A,AM,X0, 1U1,SD1,U2,SD2,DZ,ANU3, 1ALAMB3,ALAMB4,ALPHA1,ALPHA2, CCCCC MAY 2002: ADD FOLLOWING LINE 1ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2, 1AMU,XI,CHI,G,H,AK,SIGMA, 1ETA,ZETA,TAU,Q,AKAPPA,PHI, 1YLOWLM,YUPPLM, 1CLWID,XSTART,XSTOP, 1XTEMP3,IHSTCW,MAXOBV, 1CHSLOC,CHSCAL, 1STATVA,STATCD,STATNU,CUTU90,CUTU95,CUTU99, 1ICAPSW,ICAPTY,IWRIT2,IADEDF,IGEPDF,IMAKDF,IBEIDF, 1ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF, 1PCHSLM, 1Y2,X2,Z2,D2,N2,IBUGA3,IERROR) C C PURPOSE--COMPUTE A CHI-SQUARE GOODNESS OF FIT TEST C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--98/11 C ORIGINAL VERSION--NOVEMBER 1998. C UPDATED --OCTOBER 2001. C UPDATED --NOVEMBER 2001. GEOMETRIC EXTREME EXPONENTIAL C UPDATED --MAY 2003. LANDAU C UPDATED --MAY 2003. ERROR (=EXPONENTIAL POWER) C UPDATED --JUNE 2003. TRAPEZOID C UPDATED --JUNE 2003. GENERALIZED TRAPEZOID C UPDATED --OCTOBER 2003. ADD SUPPORT FOR HTML, LATEX C UPDATED --NOVEMBER 2003. FOLDED T C UPDATED --DECEMBER 2003. SUPPORT FOR MU PARAMETER FOR C INVERSE GAUSSIAN C UPDATED --DECEMBER 2003. SKEWED NORMAL, SKEWED T, C SLASH, INVERTED BETA, C GOMPERTZ-MAKEHAM, G-H C UPDATED --MARCH 2004. LOG SKEWED NORMAL C LOG SKEWED T C UPDATED --APRIL 2004. HERMITE, YULE C UPDATED --JUNE 2004. SKEWED DOUBLE EXPONENTIAL C UPDATED --JUNE 2004. ASYMMETRIC DOUBLE EXPONENTIAL C UPDATED --JUNE 2004. MAXWELL, RAYLEIGH C UPDATED --JULY 2004. FOR DISCRETE DISTRIBUTIONS C WHERE CDF COMPUTED BY C SUMMING PDF, KEEP RUNNING C TO COMPUTE CDF FOR BETTER C EFFICIENCY C UPDATED --JULY 2004. ALTERNATE DEFINITION FOR C GOMPERTZ-MAKEHAM C UPDATED --AUGUST 2004. MCLEISH C UPDATED --AUGUST 2004. BESSEL I-FUNCTION C UPDATED --SEPTEMBER 2004. GENERALIZED MCLEISH C UPDATED --DECEMBER 2004. FOR A FEW DISCRETE C DISTRIBUTIONS WHERE THE CDF C IS COMPUTED BY BRUTE FORCE C (YULE, WARING, BETA-BINOMIAL, C POLYA), USE DIFFERENT METHOD C FOR COMPUTING CDF FUNCTION C UPDATED --JULY 2005. CALL LIST TO LCACDF AND SNCDF C UPDATED --FEBRUARY 2006. GENERALIZED LOGISTIC TYPE 5 C UPDATED --FEBRUARY 2006. WAKEBY C UPDATED --FEBRUARY 2006. FMKL PARAMETERIZATION OF C GENERALIZED TUKEY LAMBDA C UPDATED --MARCH 2006. SUPPORT FOR DIFFERENT DEFAULT C BINNING ALGORITHMS C UPDATED --MARCH 2006. BETA-NORMAL C UPDATED --MARCH 2006. GENERALIZED LOGISTIC TYPE 2 C UPDATED --MARCH 2006. GENERALIZED LOGISTIC TYPE 3 C UPDATED --MARCH 2006. GENERALIZED LOGISTIC TYPE 4 C UPDATED --MARCH 2006. ASYMMETRIC LOG DOUBLE C EXPONENTIAL C UPDATED --MAY 2006. BETA GEOMETRIC C UPDATED --MAY 2006. ZETA C UPDATED --MAY 2006. ZIPF C UPDATED --MAY 2006. BOREL-TANNER C UPDATED --MAY 2006. FOR DISCRETE DISTRIBUTIONS, C FIX "Y X" CASE C UPDATED --MAY 2006. BETA NEGATIVE BINOMIAL C UPDATED --JUNE 2006. LAGRANGE POISSON C UPDATED --JUNE 2006. LEADS IN COIN TOSSING C UPDATED --JUNE 2006. CLASSICAL MATCHING C UPDATED --JUNE 2006. CLASSICAL OCCUPANCY C UPDATED --JUNE 2006. LOG BETA C UPDATED --JUNE 2006. POLYA AEPPLI C UPDATED --JUNE 2006. LOST GAMES C UPDATED --JUNE 2006. GENERALIZED LOGARITHMIC SERIES C UPDATED --JULY 2006. GENERALIZED NEGATIVE BINOMIAL C UPDATED --JULY 2006. GEETA C UPDATED --JULY 2006. PCHSLM SPECIFIES A MAXIMUM C VALUE FOR THE TEST STATISTIC. C USE THIS SO CHI-SQUARE PLOT C DOES NOT BLOW UP FOR LARGE C VALUES C UPDATED --AUGUST 2006. CONSUL C UPDATED --AUGUST 2006. LAGRANGE KATZ C UPDATED --SEPTEMBER 2006. KATZ C UPDATED --OCTOBER 2006. SHAPE PARAMETER FOR C SEMI-CIRCULAR DISTRIBUTION C UPDATED --NOVEMBER 2006. DISCRETE WEIBULL C UPDATED --NOVEMBER 2006. GENERALIZED LOST GAMES C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C LOGICAL POINT C CHARACTER*4 ICASPL CHARACTER*4 ICAPSW CHARACTER*4 ICAPTY CHARACTER*4 IDATSW CHARACTER*4 IHSTCW CHARACTER*4 IRHSTG CHARACTER*4 IBUGA3 CHARACTER*4 IWRITE CHARACTER*4 IWRIT2 CHARACTER*4 IADEDF CHARACTER*4 IGEPDF CHARACTER*4 IMAKDF CHARACTER*4 IBEIDF CHARACTER*4 ILGADF CHARACTER*4 ISKNDF CHARACTER*4 IGLDDF CHARACTER*4 IBGEDF CHARACTER*4 IGETDF CHARACTER*4 ICONDF CHARACTER*4 IERROR C CHARACTER*1 IBASLC C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 IRELAT CHARACTER*4 IDISFL C CHARACTER*6 ICONC1 CHARACTER*6 ICONC2 CHARACTER*6 ICONC3 CHARACTER*50 IDIST C DOUBLE PRECISION DSUM1 DOUBLE PRECISION DTEMP1 DOUBLE PRECISION DTEMP2 DOUBLE PRECISION DOUT1 DOUBLE PRECISION DOUT2 DOUBLE PRECISION DCDFL DOUBLE PRECISION DCDFU DOUBLE PRECISION CDFGLO DOUBLE PRECISION CDFWAK DOUBLE PRECISION XPAR(5) DOUBLE PRECISION DPDF DOUBLE PRECISION DZETA C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X(*) DIMENSION Z(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) DIMENSION Z2(*) DIMENSION XTEMP3(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA PI/3.141593/ C C-----START POINT----------------------------------------------------- C C ISUBN1='DPCH' ISUBN2='S2 ' C IRELAT='OFF' IERROR='NO' C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.GE.1)GOTO39 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN DPCHS2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) 32 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,33) 33 FORMAT(' MUST BE AT LEAST 1;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,34)N 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 39 CONTINUE C IF(N.GE.2)GOTO49 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46) 46 FORMAT('***** ERROR IN DPCHS2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47) 47 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48) 48 FORMAT(' WAS EXACTLY EQUAL TO 1.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 49 CONTINUE C HOLD=Y(1) DO60I=1,N IF(Y(I).NE.HOLD)GOTO69 60 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61) 61 FORMAT('***** ERROR IN DPCHS2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' ALL INPUT VERTICAL AXIS ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)HOLD 63 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 69 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO80 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71) 71 FORMAT('***** AT THE BEGINNING OF DPCHS2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)ICASPL,IDATSW,N 72 FORMAT('ICASPL,IDATSW,N, = ',A4,2X,A4,2X,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)ALAMBA,NU,NU1,NU2 73 FORMAT('ALAMBA,NU,NU1,NU2 = ',E15.7,I8,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,74)GAMMA,ALPHA,BETA,NPAR,P,K 74 FORMAT('GAMMA,ALPHA,BETA,NPAR,P,K = ',3E15.7,I8,E15.7,I8) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE ADDED MAY 1993 WRITE(ICOUT,75)MINMAX 75 FORMAT('MINMAX = ',I8) CALL DPWRST('XXX','BUG ') IF(N.LE.0)GOTO80 DO85I=1,N WRITE(ICOUT,86)I,Y(I),X(I) 86 FORMAT('I,Y(I),X(I) = ',I8,2E12.5) CALL DPWRST('XXX','BUG ') 85 CONTINUE 80 CONTINUE C C ************************************** C ** STEP 4-- ** C ** IF DATA NOT ALREADY BINNED, THEN** C ** BIN THE DATA ** C ************************************** C IDISFL='CONT' ILOWLM=0 IF(ICASPL.EQ.'BIPP' .OR. ICASPL.EQ.'GEPP' .OR. 1 ICASPL.EQ.'POPP' .OR. ICASPL.EQ.'NBPP '.OR. 1 ICASPL.EQ.'NZPP '.OR. ICASPL.EQ.'BZPP' .OR. 1 ICASPL.EQ.'DUPP' .OR. ICASPL.EQ.'HYPP' .OR. 1 ICASPL.EQ.'BBPP' .OR. ICASPL.EQ.'PZPP' .OR. 1 ICASPL.EQ.'HEPP' .OR. ICASPL.EQ.'YUPP' .OR. 1 ICASPL.EQ.'BGPP' .OR. ICASPL.EQ.'ZEPP' .OR. 1 ICASPL.EQ.'ZIPP' .OR. ICASPL.EQ.'BTPP' .OR. 1 ICASPL.EQ.'LPPP' .OR. ICASPL.EQ.'OCPP' .OR. 1 ICASPL.EQ.'LCPP' .OR. ICASPL.EQ.'MAPP' .OR. 1 ICASPL.EQ.'AEPP' .OR. ICASPL.EQ.'NZPP' .OR. 1 ICASPL.EQ.'DXPP' .OR. ICASPL.EQ.'LOST' .OR. 1 ICASPL.EQ.'GSPP' .OR. ICASPL.EQ.'GNBP' .OR. 1 ICASPL.EQ.'GETP' .OR. ICASPL.EQ.'QBPP' .OR. 1 ICASPL.EQ.'CNPP' .OR. ICASPL.EQ.'LKPP' .OR. 1 ICASPL.EQ.'KZPP' .OR. ICASPL.EQ.'DIWP' .OR. 1 ICASPL.EQ.'GLGP' .OR. 1 ICASPL.EQ.'DLPP' .OR. ICASPL.EQ.'WRPP')THEN IDISFL='DISC' IF(ICASPL.EQ.'DLPP')ILOWLM=1 IF(ICASPL.EQ.'GSPP')ILOWLM=1 IF(ICASPL.EQ.'GETP')ILOWLM=1 IF(ICASPL.EQ.'CNPP')ILOWLM=1 IF(ICASPL.EQ.'ZEPP')THEN ILOWLM=1 CALL ZETA2(DBLE(ALPHA),DZETA) DZETA=DZETA+1.0D0 ENDIF IF(ICASPL.EQ.'ZIPP')ILOWLM=1 IF(ICASPL.EQ.'BGPP')THEN ILOWLM=1 IF(IBGEDF.EQ.'SHIF')ILOWLM=0 ENDIF IF(ICASPL.EQ.'BTPP')ILOWLM=K IF(ICASPL.EQ.'LOST')ILOWLM=NU IF(ICASPL.EQ.'GLGP')ILOWLM=NU ENDIF C IF(IDATSW.EQ.'RAW')THEN AN=REAL(N) CALL MAXIM(Y,N,IWRITE,AMAX,IBUGA3,IERROR) IF(IDISFL.EQ.'CONT')THEN CALL DPBIN(Y,N,IRELAT,CLWID,XSTART,XSTOP,IRHSTG, 1 XTEMP3,MAXOBV,IHSTCW, 1 Y2,X2,N2,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSE CALL DPBINI(Y,N,IRELAT,CLWID,XSTART,XSTOP,IRHSTG, 1 Y2,X2,N2,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ENDIF CALL SORTC(X2,Y2,N2,X2,Y2) ELSEIF(IDATSW.EQ.'FREQ')THEN AN=0.0 AMAX=CPUMIN DEL=(X(2)-X(1))/2.0 DO1009I=1,N AN=AN+Y(I) Y2(I)=Y(I) X2(I)=X(I)-DEL Z2(I)=X(I)+DEL IF(Z2(I).GT.AMAX)AMAX=Z2(I) 1009 CONTINUE N2=N IDATSW='CLAS' ELSEIF(IDATSW.EQ.'CLAS')THEN AN=0.0 AMAX=CPUMIN DO1019I=1,N AN=AN+Y(I) Y2(I)=Y(I) X2(I)=X(I) Z2(I)=Z(I) IF(Z2(I).GT.AMAX)AMAX=Z2(I) 1019 CONTINUE N2=N DO1029I=1,N2 IF(X2(I).GT.Z2(I))THEN AJUNK=X2(I) X2(I)=Z2(I) Z2(I)=AJUNK ENDIF 1029 CONTINUE CALL SORTC(X,X2,N2,D2,X2) CALL SORTC(X,Y2,N2,D2,Y2) CALL SORTC(X,Z2,N2,D2,Z2) ELSE CALL MAXIM(Y,N,IWRITE,AMAX,IBUGA3,IERROR) AN=REAL(N) CALL DPBIN(Y,N,IRELAT,CLWID,XSTART,XSTOP,IRHSTG, 1 XTEMP3,MAXOBV,IHSTCW, 1 Y2,X2,N2,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 CALL SORTC(X2,Y2,N2,X2,Y2) ENDIF C IF(ICASPL.EQ.'ZIPP')THEN IMAX=INT(AMAX+0.00001) IF(NU.LT.IMAX)NU=IMAX CALL HNM(NU,DBLE(ALPHA),DZETA) ENDIF C C **************************************** C ** STEP 4.1-- ** C ** COMPUTE CHI-SQUARE OBSERVED AND ** C ** EXPECTED ** C **************************************** C 1100 CONTINUE C DSUM1=0.0D0 CLWIDT=X2(2)-X2(1) NUMPAR=0 NEMPTY=0 C C NOTE: HANDLE DISCRETE DISTRIBUTIONS DIFFERENTLY. FOR DISCRETE, C BIN MID-POINTS SHOULD BE AT INTEGER VALUES! C NOTE: A FEW DISCRETE DISTRIBUTIONS ARE COMPUTED BY BRUTE C FORCE. FOR THESE (ESPECIALLY WHEN THE TAILS CAN BE C LONG), INSTEAD OF COMPUTING CDF FUNCTION, KEEP RUNNING C TALLY BASED ON CDF FUNCTION. THIS AVOIDS EXCESIVE C REDUNDANT COMPUTATION. C DCDFL=0.0D0 DCDFU=0.0D0 IXLPV=-1 IXUPV=-1 C IF(IDISFL.EQ.'DISC')THEN IF(IDATSW.EQ.'CLAS')THEN IDIFF=0 ELSE ADIFF=X2(2) - X2(1) IDIFF=INT(ADIFF+0.1) ENDIF ENDIF C DO1199I=1,N2 C IF(IDISFL.EQ.'DISC')THEN IF(IDATSW.EQ.'CLAS')THEN IXL=CEILDP(X2(I)) CCCCC IXU=FLOOR(Z2(I)) C ARG1=Z2(I) IF(ARG1.LE.0.0)THEN IARG2=INT(ARG1) ARG3=REAL(IARG2) ARG4=ARG1-ARG3 TERM=ARG3 IF(ARG4.NE.0.0)TERM=TERM-1.0 ELSE IARG2=INT(ARG1) TERM=REAL(IARG2) ENDIF IXU=INT(TERM) C ELSE IXU=INT(X2(I) + 0.5) IXL=IXU-IDIFF ENDIF ELSE IF(IDATSW.EQ.'CLAS')THEN XL=X2(I) XU=Z2(I) ELSE XL=X2(I) - CLWIDT/2.0 XU=X2(I) + CLWIDT/2.0 ENDIF ENDIF XMIN=X2(1) - CLWIDT/2.0 C C FOLLOWING ARE DISCRETE DISTRIBUTIONS C IF(ICASPL.EQ.'BIPP')GOTO1290 IF(ICASPL.EQ.'GEPP')GOTO1300 IF(ICASPL.EQ.'POPP')GOTO1310 IF(ICASPL.EQ.'NBPP')GOTO1320 IF(ICASPL.EQ.'NZPP')GOTO1320 IF(ICASPL.EQ.'DUPP')GOTO1400 IF(ICASPL.EQ.'HYPP')GOTO1470 IF(ICASPL.EQ.'DLPP')GOTO1550 IF(ICASPL.EQ.'WRPP')GOTO1580 IF(ICASPL.EQ.'YUPP')GOTO1585 IF(ICASPL.EQ.'BBPP')GOTO1790 IF(ICASPL.EQ.'PZPP')GOTO2090 IF(ICASPL.EQ.'HEPP')GOTO2100 IF(ICASPL.EQ.'BGPP')GOTO2270 IF(ICASPL.EQ.'ZEPP')GOTO2280 IF(ICASPL.EQ.'ZIPP')GOTO2290 IF(ICASPL.EQ.'BTPP')GOTO2300 IF(ICASPL.EQ.'BZPP')GOTO2320 IF(ICASPL.EQ.'LPPP')GOTO2330 IF(ICASPL.EQ.'LCPP')GOTO2340 IF(ICASPL.EQ.'MAPP')GOTO2350 IF(ICASPL.EQ.'OCPP')GOTO2350 IF(ICASPL.EQ.'AEPP')GOTO2380 IF(ICASPL.EQ.'LOST')GOTO2390 IF(ICASPL.EQ.'GSPP')GOTO2400 IF(ICASPL.EQ.'GNBP')GOTO2410 IF(ICASPL.EQ.'GETP')GOTO2420 IF(ICASPL.EQ.'QBPP')GOTO2430 IF(ICASPL.EQ.'CNPP')GOTO2440 IF(ICASPL.EQ.'CNPP')GOTO2440 IF(ICASPL.EQ.'LKPP')GOTO2450 IF(ICASPL.EQ.'LZPP')GOTO2460 IF(ICASPL.EQ.'DIWP')GOTO2470 IF(ICASPL.EQ.'GLGP')GOTO2480 C C FOLLOWING ARE CONTINUOUS DISTRIBUTIONS C IF(ICASPL.EQ.'UNPP')GOTO1110 IF(ICASPL.EQ.'NOPP')GOTO1120 IF(ICASPL.EQ.'LOPP')GOTO1130 IF(ICASPL.EQ.'DEPP')GOTO1140 IF(ICASPL.EQ.'CAPP')GOTO1150 IF(ICASPL.EQ.'LAPP')GOTO1160 IF(ICASPL.EQ.'LNPP')GOTO1170 IF(ICASPL.EQ.'HNPP')GOTO1180 IF(ICASPL.EQ.'TPP')GOTO1190 IF(ICASPL.EQ.'CSPP')GOTO1200 IF(ICASPL.EQ.'FPP')GOTO1210 IF(ICASPL.EQ.'EXPP')GOTO1220 IF(ICASPL.EQ.'GAPP')GOTO1230 IF(ICASPL.EQ.'BEPP')GOTO1240 IF(ICASPL.EQ.'WEPP')GOTO1250 IF(ICASPL.EQ.'E1PP')GOTO1260 IF(ICASPL.EQ.'E2PP')GOTO1270 IF(ICASPL.EQ.'PAPP')GOTO1280 IF(ICASPL.EQ.'SEPP')GOTO1330 IF(ICASPL.EQ.'TRPP')GOTO1340 IF(ICASPL.EQ.'IGPP')GOTO1350 IF(ICASPL.EQ.'WAPP')GOTO1360 IF(ICASPL.EQ.'RIPP')GOTO1370 IF(ICASPL.EQ.'FLPP')GOTO1380 IF(ICASPL.EQ.'GPPP')GOTO1390 IF(ICASPL.EQ.'NTPP')GOTO1410 IF(ICASPL.EQ.'NFPP')GOTO1420 IF(ICASPL.EQ.'NCPP')GOTO1430 IF(ICASPL.EQ.'NCBP')GOTO1440 IF(ICASPL.EQ.'DNCT')GOTO1450 IF(ICASPL.EQ.'DNCF')GOTO1460 IF(ICASPL.EQ.'VMPP')GOTO1480 IF(ICASPL.EQ.'PNPP')GOTO1490 IF(ICASPL.EQ.'PLPP')GOTO1500 IF(ICASPL.EQ.'ALPP')GOTO1510 IF(ICASPL.EQ.'COPP')GOTO1520 IF(ICASPL.EQ.'PFPP')GOTO1530 IF(ICASPL.EQ.'CHPP')GOTO1540 IF(ICASPL.EQ.'LLPP')GOTO1560 IF(ICASPL.EQ.'GGPP')GOTO1570 IF(ICASPL.EQ.'ANPP')GOTO1590 IF(ICASPL.EQ.'ARPP')GOTO1600 IF(ICASPL.EQ.'FNPP')GOTO1610 IF(ICASPL.EQ.'TNPP')GOTO1620 IF(ICASPL.EQ.'LGPP')GOTO1630 IF(ICASPL.EQ.'HSPP')GOTO1640 IF(ICASPL.EQ.'GOPP')GOTO1650 IF(ICASPL.EQ.'HCPP')GOTO1660 IF(ICASPL.EQ.'HLPP')THEN IDIST='HALF LOGISTIC' GAMMA=-1.0 GOTO1670 ENDIF IF(ICASPL.EQ.'GZPP')THEN IDIST='GENERALIZED HALF LOGISTIC' GOTO1670 ENDIF IF(ICASPL.EQ.'GVPP')GOTO1680 IF(ICASPL.EQ.'P2PP')GOTO1690 IF(ICASPL.EQ.'DWPP')GOTO1700 IF(ICASPL.EQ.'WCPP')GOTO1710 IF(ICASPL.EQ.'EWPP')GOTO1720 IF(ICASPL.EQ.'TEPP')GOTO1730 IF(ICASPL.EQ.'GLPP')GOTO1740 IF(ICASPL.EQ.'PEPP')GOTO1750 IF(ICASPL.EQ.'DGPP')GOTO1760 IF(ICASPL.EQ.'KAPP')GOTO1770 IF(ICASPL.EQ.'FCPP')GOTO1780 IF(ICASPL.EQ.'BRPP')GOTO1800 IF(ICASPL.EQ.'GXPP')GOTO1810 IF(ICASPL.EQ.'REPP')GOTO1820 IF(ICASPL.EQ.'NMPP')GOTO1830 IF(ICASPL.EQ.'GIPP')GOTO1840 IF(ICASPL.EQ.'IWPP')GOTO1850 IF(ICASPL.EQ.'LXPP')GOTO1860 IF(ICASPL.EQ.'LDPP')GOTO1870 IF(ICASPL.EQ.'JBPP')GOTO1880 IF(ICASPL.EQ.'JUPP')GOTO1890 IF(ICASPL.EQ.'EEPP')GOTO1900 IF(ICASPL.EQ.'TSPP')GOTO1910 IF(ICASPL.EQ.'BWPP')GOTO1920 IF(ICASPL.EQ.'LUPP')GOTO1930 IF(ICASPL.EQ.'ERPP')GOTO1940 IF(ICASPL.EQ.'TZPP')GOTO1950 IF(ICASPL.EQ.'GTPP')GOTO1960 IF(ICASPL.EQ.'FTPP')GOTO1970 IF(ICASPL.EQ.'SLPP')GOTO1980 IF(ICASPL.EQ.'SNPP')GOTO1990 IF(ICASPL.EQ.'STPP')GOTO2000 IF(ICASPL.EQ.'IBPP')GOTO2010 IF(ICASPL.EQ.'GMPP')GOTO2020 IF(ICASPL.EQ.'GIGP')GOTO2030 IF(ICASPL.EQ.'GFPP')GOTO2040 IF(ICASPL.EQ.'GHPP')GOTO2050 IF(ICASPL.EQ.'LZPP')GOTO2060 IF(ICASPL.EQ.'LTPP')GOTO2070 IF(ICASPL.EQ.'ASPP')GOTO2080 IF(ICASPL.EQ.'SDPP')GOTO2110 IF(ICASPL.EQ.'ADPP')GOTO2120 IF(ICASPL.EQ.'MXPP')GOTO2130 IF(ICASPL.EQ.'RAPP')GOTO2140 IF(ICASPL.EQ.'GALP')GOTO2150 IF(ICASPL.EQ.'MCPP')GOTO2160 IF(ICASPL.EQ.'BEIP')GOTO2170 IF(ICASPL.EQ.'BEKP')GOTO2180 IF(ICASPL.EQ.'GMCP')GOTO2190 IF(ICASPL.EQ.'G5PP')GOTO2200 IF(ICASPL.EQ.'WKPP')GOTO2210 IF(ICASPL.EQ.'BNPP')GOTO2220 IF(ICASPL.EQ.'G2PP')GOTO2230 IF(ICASPL.EQ.'G3PP')GOTO2240 IF(ICASPL.EQ.'G4PP')GOTO2250 IF(ICASPL.EQ.'AXPP')GOTO2260 IF(ICASPL.EQ.'LBPP')GOTO2370 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011) 1011 FORMAT('***** ERROR DPCHS2--UNKNOWN DISTRIBUTION') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1110 CONTINUE IDIST='UNIFORM' ZSCALE=CHSCAL-CHSLOC XL=(XL-CHSLOC)/ZSCALE XU=(XU-CHSLOC)/ZSCALE NUMPAR=2 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 IF(XL.LT.0.0)XL=0.0 IF(XL.GT.1.0)XL=1.0 IF(XU.LT.0.0)XU=0.0 IF(XU.GT.1.0)XU=1.0 CALL UNICDF(XL,XOUT1) CALL UNICDF(XU,XOUT2) GOTO2990 C 1120 CONTINUE IDIST='NORMAL' NUMPAR=2 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 CALL NORCDF(XL,XOUT1) CALL NORCDF(XU,XOUT2) GOTO2990 C 1130 CONTINUE IDIST='LOGISTIC' NUMPAR=2 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 CALL LOGCDF(XL,XOUT1) CALL LOGCDF(XU,XOUT2) GOTO2990 C 1140 CONTINUE IDIST='DOUBLE EXPONENTIAL' NUMPAR=2 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 CALL DEXCDF(XL,XOUT1) CALL DEXCDF(XU,XOUT2) GOTO2990 C 1150 CONTINUE IDIST='CAUCHY' NUMPAR=2 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 CALL CAUCDF(XL,XOUT1) CALL CAUCDF(XU,XOUT2) GOTO2990 C 1160 CONTINUE IDIST='TUKEY-LAMBDA' NUMPAR=3 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 IF(ALAMBA.GT.0.0)THEN XMAX=1.0/ALAMBA XMIN=-XMAX IF(XL.LT.XMIN)XL=XMIN IF(XU.LT.XMIN)XU=XMIN IF(XL.GT.XMAX)XL=XMAX IF(XU.GT.XMAX)XU=XMAX ENDIF CALL LAMCDF(XL,ALAMBA,XOUT1) CALL LAMCDF(XU,ALAMBA,XOUT2) GOTO2990 C 1170 CONTINUE IDIST='LOG-NORMAL' NUMPAR=3 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL LGNCDF(XL,SIGMA,XOUT1) CALL LGNCDF(XU,SIGMA,XOUT2) GOTO2990 C 1180 CONTINUE IDIST='HALF-NORMAL' NUMPAR=2 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL HFNCDF(XL,XOUT1) CALL HFNCDF(XU,XOUT2) GOTO2990 C 1190 CONTINUE IDIST='T' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CCCCC CALL TCDF(XL,NU,XOUT1) CCCCC CALL TCDF(XU,NU,XOUT2) CALL TCDF(XL,ANU,XOUT1) CALL TCDF(XU,ANU,XOUT2) GOTO2990 C 1200 CONTINUE IDIST='CHI-SQUARE' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL CHSCDF(XL,NU,XOUT1) CALL CHSCDF(XU,NU,XOUT2) GOTO2990 C 1210 CONTINUE IDIST='F' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL FCDF(XL,NU1,NU2,XOUT1) CALL FCDF(XU,NU1,NU2,XOUT2) GOTO2990 C 1220 CONTINUE IDIST='EXPONENTIAL' NUMPAR=2 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL EXPCDF(XL,XOUT1) CALL EXPCDF(XU,XOUT2) GOTO2990 C 1230 CONTINUE IDIST='GAMMA' NUMPAR=3 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL GAMCDF(XL,GAMMA,XOUT1) CALL GAMCDF(XU,GAMMA,XOUT2) GOTO2990 C 1240 CONTINUE IDIST='BETA' NUMPAR=4 ZSCALE=CHSCAL-CHSLOC XL=(XL-CHSLOC)/ZSCALE XU=(XU-CHSLOC)/ZSCALE IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 IF(XL.LT.0.0)XL=0.0 IF(XL.GT.1.0)XL=1.0 IF(XU.LT.0.0)XU=0.0 IF(XU.GT.1.0)XU=1.0 CALL BETCDF(XL,ALPHA,BETA,XOUT1) CALL BETCDF(XU,ALPHA,BETA,XOUT2) GOTO2990 C 1250 CONTINUE IDIST='WEIBULL' NUMPAR=3 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL WEICDF(XL,GAMMA,MINMAX,XOUT1) CALL WEICDF(XU,GAMMA,MINMAX,XOUT2) GOTO2990 C 1260 CONTINUE IDIST='EXTREME VALUE TYPE 1' NUMPAR=2 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 CALL EV1CDF(XL,MINMAX,XOUT1) CALL EV1CDF(XU,MINMAX,XOUT2) GOTO2990 C 1270 CONTINUE IDIST='EXTREME VALUE TYPE 2' NUMPAR=3 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 IF(MINMAX.EQ.1)THEN IF(XL.GT.0.0)XL=0.0 IF(XU.GT.0.0)XU=0.0 ELSEIF(MINMAX.EQ.2)THEN IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 ENDIF CALL EV2CDF(XL,GAMMA,MINMAX,XOUT1) CALL EV2CDF(XU,GAMMA,MINMAX,XOUT2) GOTO2990 C 1280 CONTINUE IDIST='PARETO' NUMPAR=4 ZLOC=A IF(ZLOC.GT.XMIN)ZLOC=XMIN XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 CALL PARCDF(XL,GAMMA,ZLOC,XOUT1) CALL PARCDF(XU,GAMMA,ZLOC,XOUT2) GOTO2990 C 1290 CONTINUE IDIST='BINOMIAL' NUMPAR=2 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTOP.GT.NPAR)ISTOP=NPAR IF(ISTRT.LE.ISTOP)THEN DCDFL=0.0D0 DO1291ITEMP=ISTRT,ISTOP C CALL BINCDF(REAL(ITEMP),P,NPAR,ATEMP1) ATEMP2=0.0 IF(ITEMP-1.GE.ILOWLM) 1 CALL BINCDF(REAL(ITEMP-1),P,NPAR,ATEMP2) ATEMP=ATEMP1-ATEMP2 C DCDFL=DCDFL + DBLE(ATEMP) 1291 CONTINUE XOUT2=REAL(DCDFL) ENDIF CCCCC IF(IXL.GT.NPAR)THEN CCCCC XOUT2=0.0 CCCCC XOUT2=0.0 CCCCC GOTO2990 CCCCC ENDIF CCCCC IF(IXH.GT.NPAR)THEN CCCCC IXH=NPAR CCCCC IF(IXL.GE.NPAR)IXL=IXH-1 CCCCC ENDIF CCCCC XOUT2=0.0 CCCCC CALL BINCDF(REAL(IXU),P,NPAR,XOUT2) CCCCC IF(IXL.GE.0) CALL BINCDF(REAL(IXL),P,NPAR,XOUT2) GOTO2990 C 1300 CONTINUE IDIST='GEOMETRIC' NUMPAR=1 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DCDFL=0.0D0 DO1301ITEMP=ISTRT,ISTOP CALL GEOPDF(REAL(ITEMP),P,ATEMP) DCDFL=DCDFL + DBLE(ATEMP) 1301 CONTINUE XOUT2=REAL(DCDFL) ENDIF CCCCC XOUT2=0.0 CCCCC CALL GEOCDF(REAL(IXU),P,XOUT2) CCCCC IF(IXL.GE.0) CALL GEOCDF(REAL(IXL),P,XOUT2) GOTO2990 C 1310 CONTINUE IDIST='POISSON' NUMPAR=1 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DCDFL=0.0D0 DTEMP2=0.0 IF(ISTRT-1.GE.ILOWLM) 1 CALL PODCDF(DBLE(ISTRT-1),DBLE(ALAMBA),DTEMP2) CALL PODCDF(DBLE(ISTOP),DBLE(ALAMBA),DTEMP1) DCDFL=DTEMP1 - DTEMP2 XOUT2=REAL(DCDFL) ENDIF CCCCC XOUT2=0.0 CCCCC IF(ALAMBA.LE.60.0)THEN CCCCC CALL POICDF(REAL(IXU),ALAMBA,XOUT2) CCCCC IF(IXL.GE.0) CALL POICDF(REAL(IXL),ALAMBA,XOUT2) CCCCC ELSE CCCCC SQRTAL=SQRT(ALAMBA) CCCCC CALL NORCDF(REAL(IXU),XOUT2) CCCCC XOUT2=ALAMBA+SQRTAL*XOUT2 CCCCC IF(IXL.GE.0)THEN CCCCC CALL NORCDF(REAL(IXL),XOUT2) CCCCC XOUT2=ALAMBA+SQRTAL*XOUT1 CCCCC ENDIF CCCCC ENDIF GOTO2990 C 1320 CONTINUE IDIST='NEGATIVE BINOMIAL' NUMPAR=2 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DCDFL=0.0D0 DO1321ITEMP=ISTRT,ISTOP CALL NBPDF(REAL(ITEMP),P,AK,ATEMP) DCDFL=DCDFL + DBLE(ATEMP) 1321 CONTINUE XOUT2=REAL(DCDFL) ENDIF CCCCC XOUT2=0.0 CCCCC CALL NBCDF(REAL(IXU),P,AK,XOUT2) CCCCC IF(IXL.GE.0) CALL NBCDF(REAL(IXL),P,AK,XOUT2) GOTO2990 C 1330 CONTINUE IDIST='SEMI-CIRCULAR' NUMPAR=2 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=XL-CHSLOC XU=XU-CHSLOC IF(XL.LT.-CHSCAL)XL=-CHSCAL IF(XL.GT.CHSCAL)XR=CHSCAL IF(XU.LT.-CHSCAL)XU=-CHSCAL IF(XU.GT.CHSCAL)XU=CHSCAL CALL SEMCDF(XL,CHSCAL,XOUT1) CALL SEMCDF(XU,CHSCAL,XOUT2) GOTO2990 C 1340 CONTINUE IDIST='TRIANGULAR' NUMPAR=3 C IF(CHSLOC.EQ.0.0 .AND. CHSCAL.EQ.1.0)THEN ZLOWLM=-1.0 ZUPPLM=1.0 ELSE ZLOWLM=CHSLOC ZUPPLM=CHSCAL ENDIF C IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 IF(XL.LT.ZLOWLM)XL=ZLOWLM IF(XL.GT.ZUPPLM)XL=ZUPPLM IF(XU.LT.ZLOWLM)XU=ZLOWLM IF(XU.GT.ZUPPLM)XU=ZUPPLM CALL TRICDF(XL,C,ZLOWLM,ZUPPLM,XOUT1) CALL TRICDF(XU,C,ZLOWLM,ZUPPLM,XOUT2) GOTO2990 C 1350 CONTINUE IDIST='INVERSE GAUSSIAN' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL IGCDF(XL,GAMMA,AMU,XOUT1) CALL IGCDF(XU,GAMMA,AMU,XOUT2) GOTO2990 C 1360 CONTINUE IDIST='WALD' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL WALCDF(XL,GAMMA,XOUT1) CALL WALCDF(XU,GAMMA,XOUT2) GOTO2990 C 1370 CONTINUE IDIST='RECIPROCAL INVERSE GAUSSIAN' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL RIGCDF(XL,GAMMA,AMU,XOUT1) CALL RIGCDF(XU,GAMMA,AMU,XOUT2) GOTO2990 C 1380 CONTINUE IDIST='FATIGUE LIFE' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL FLCDF(XL,GAMMA,XOUT1) CALL FLCDF(XU,GAMMA,XOUT2) GOTO2990 C 1390 CONTINUE IDIST='GENERALIZED PARETO' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL GEPCDF(XL,GAMMA,MINMAX,IGEPDF,XOUT1) CALL GEPCDF(XU,GAMMA,MINMAX,IGEPDF,XOUT2) GOTO2990 C 1400 CONTINUE IDIST='DISCRETE UNIFORM' NUMPAR=1 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTOP.GT.NDUN)ISTOP=NDUN IF(ISTRT.LE.ISTOP)THEN DCDFL=0.0D0 DO1401ITEMP=ISTRT,ISTOP CCCCC CALL DISPDF(REAL(ITEMP),NDUN,ATEMP) CALL DISPDF(ITEMP,NDUN,ATEMP) DCDFL=DCDFL + DBLE(ATEMP) 1401 CONTINUE XOUT2=REAL(DCDFL) ENDIF CCCCC IF(IXL.GT.NDUN)THEN CCCCC XOUT2=0.0 CCCCC XOUT2=0.0 CCCCC GOTO2990 CCCCC ENDIF CCCCC IF(IXH.GT.NDUN)THEN CCCCC IXH=NPAR CCCCC IF(IXL.GE.NDUN)IXL=IXH-1 CCCCC ENDIF CCCCC XOUT2=0.0 CCCCC IF(IXL.LT.0)IXL=0 CCCCC IF(IXU.LT.0)IXU=0 CCCCC CALL DISCDF(REAL(IXU),NDUN,XOUT2) CCCCC IF(IXL.GE.0) CALL DISCDF(REAL(IXL),NDUN,XOUT2) GOTO2990 C 1410 CONTINUE IDIST='NON-CENTRAL T' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL NCTCDF(XL,ANU,ALAMBA,XOUT1) CALL NCTCDF(XU,ANU,ALAMBA,XOUT2) GOTO2990 C 1420 CONTINUE IDIST='NON-CENTRAL F' NUMPAR=5 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL NCFCDF(XL,ANU1,ANU2,ALAMBA,XOUT1) CALL NCFCDF(XU,ANU1,ANU2,ALAMBA,XOUT2) GOTO2990 C 1430 CONTINUE IDIST='NON-CENTRAL CHI-SQUARE' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL NCCCDF(XL,ANU,ALAMBA,XOUT1) CALL NCCCDF(XU,ANU,ALAMBA,XOUT2) GOTO2990 C 1440 CONTINUE IDIST='NON-CENTRAL BETA' NUMPAR=5 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XL.GT.1.0)XL=1.0 IF(XU.LT.0.0)XU=0.0 IF(XU.GT.1.0)XU=1.0 CALL NCBCDF(XL,ALPHA,BETA,ALAMBA,XOUT1) CALL NCBCDF(XU,ALPHA,BETA,ALAMBA,XOUT2) GOTO2990 C 1450 CONTINUE IDIST='DOUBLY NON-CENTRAL T' NUMPAR=5 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL DNTCDF(XL,ANU,ALAMB1,ALAMB2,XOUT1) CALL DNTCDF(XU,ANU,ALAMB1,ALAMB2,XOUT2) GOTO2990 C 1460 CONTINUE IDIST='DOUBLY NON-CENTRAL F' NUMPAR=6 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL DNFCDF(XL,ANU1,ANU2,ALAMB1,ALAMB2,XOUT1) CALL DNFCDF(XU,ANU1,ANU2,ALAMB1,ALAMB2,XOUT2) GOTO2990 C 1470 CONTINUE IDIST='HYPERGEOMETRIC' NUMPAR=3 POINT=.TRUE. XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DCDFL=0.0D0 DO1471ITEMP=ISTRT,ISTOP CALL HYPCDF(REAL(ITEMP),K,NPAR,MPAR,POINT,ATEMP) DCDFL=DCDFL + DBLE(ATEMP) 1471 CONTINUE XOUT2=REAL(DCDFL) ENDIF CCCCC POINT=.FALSE. CCCCC IF(IXL.GT.K)THEN CCCCC XOUT2=0.0 CCCCC XOUT2=0.0 CCCCC GOTO2990 CCCCC ENDIF CCCCC IF(IXH.GT.K)THEN CCCCC IXH=K CCCCC IF(IXL.GE.K)IXL=IXH-1 CCCCC ENDIF CCCCC XOUT2=0.0 CCCCC CALL HYPCDF(IXU,K,NPAR,MPAR,POINT,XOUT2) CCCCC IF(IXL.GE.0) CALL HYPCDF(IXL,K,NPAR,MPAR,POINT,XOUT2) GOTO2990 C 1480 CONTINUE IDIST='VON MISES' NUMPAR=2 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 XL=XL-CHSLOC XU=XU-CHSLOC CALL VONCDF(XL,B,XOUT1) CALL VONCDF(XU,B,XOUT2) GOTO2990 C 1490 CONTINUE IDIST='POWER NORMAL' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CCCCC CALL PNRCDF(XL,P,SD,XOUT2) CALL PNRCDF(XL,P,XOUT1) CCCCC CALL PNRCDF(XU,P,SD,XOUT2) CALL PNRCDF(XU,P,XOUT2) GOTO2990 C 1500 CONTINUE IDIST='POWER LOG-NORMAL' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL PLNCDF(XL,P,SD,XOUT1) CALL PLNCDF(XU,P,SD,XOUT2) GOTO2990 C 1510 CONTINUE IDIST='ALPHA' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL ALPCDF(XL,ALPHA,BETA,XOUT1) CALL ALPCDF(XU,ALPHA,BETA,XOUT2) GOTO2990 C 1520 CONTINUE IDIST='COSINE' NUMPAR=2 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL COSCDF(XL,XOUT1) CALL COSCDF(XU,XOUT2) GOTO2990 C 1530 CONTINUE IDIST='POWER' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XL.GT.1.0)XL=1.0 IF(XU.LT.0.0)XU=0.0 IF(XU.GT.1.0)XU=1.0 CALL POWCDF(XL,C,XOUT1) CALL POWCDF(XU,C,XOUT2) GOTO2990 C 1540 CONTINUE IDIST='CHI' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL CHCDF(XL,ANU,XOUT1) CALL CHCDF(XU,ANU,XOUT2) GOTO2990 C 1550 CONTINUE IDIST='LOGARITHMIC SERIES' NUMPAR=1 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DCDFL=0.0D0 DO1551ITEMP=ISTRT,ISTOP CALL DLGPDF(REAL(ITEMP),THETA,ATEMP) DCDFL=DCDFL + DBLE(ATEMP) 1551 CONTINUE XOUT2=REAL(DCDFL) ENDIF CCCCC XOUT2=0.0 CCCCC CALL DLGCDF(REAL(IXU),THETA,XOUT2) CCCCC IF(IXL.GE.1) CALL DLGCDF(REAL(IXL),THETA,XOUT2) GOTO2990 C 1560 CONTINUE IDIST='LOG LOGISTIC' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL LLGCDF(XL,DELTA,XOUT1) CALL LLGCDF(XU,DELTA,XOUT2) GOTO2990 C 1570 CONTINUE IDIST='GENERALIZED GAMMA' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL GGDCDF(XL,ALPHA,C,XOUT1) CALL GGDCDF(XU,ALPHA,C,XOUT2) GOTO2990 C 1580 CONTINUE IDIST='WARING' NUMPAR=2 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DCDFL=0.0D0 DO1581ITEMP=ISTRT,ISTOP CALL WARPDF(REAL(ITEMP),C,A,ATEMP) DCDFL=DCDFL + DBLE(ATEMP) 1581 CONTINUE XOUT2=REAL(DCDFL) ENDIF CCCCC XOUT2=0.0 CCCCC CALL WARCDF(REAL(IXU),C,A,XOUT2,'NOTR') CCCCC IF(IXL.GE.0) CALL WARCDF(REAL(IXL),C,A,XOUT2,'NOTR') GOTO2990 C 1585 CONTINUE IDIST='YULE' NUMPAR=1 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DCDFL=0.0D0 DO1586ITEMP=ISTRT,ISTOP CALL YULPDF(REAL(ITEMP),P,ATEMP) DCDFL=DCDFL + DBLE(ATEMP) 1586 CONTINUE XOUT2=REAL(DCDFL) ENDIF CCCCC CALL YULCDF(REAL(IXU),P,XOUT2) CCCCC IF(IXL.GE.0) CALL YULCDF(REAL(IXL),P,XOUT1) GOTO2990 C 1590 CONTINUE IDIST='ANGLIT' NUMPAR=2 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL ANGCDF(XL,XOUT1) CALL ANGCDF(XU,XOUT2) GOTO2990 C 1600 CONTINUE IDIST='ARCSINE' NUMPAR=2 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XL.GT.1.0)XL=1.0 IF(XU.LT.0.0)XU=0.0 IF(XU.GT.1.0)XU=1.0 CALL ARSCDF(XL,XOUT1) CALL ARSCDF(XU,XOUT2) GOTO2990 C 1610 CONTINUE IDIST='FOLDED NORMAL' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL FNRCDF(XL,AM,SD,XOUT1) CALL FNRCDF(UL,AM,SD,XOUT2) GOTO2990 C 1620 CONTINUE IDIST='TRUNCATED NORMAL' NUMPAR=6 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.A)XL=A IF(XL.GT.B)XL=B IF(XU.LT.A)XU=A IF(XU.GT.B)XU=B CALL TNRCDF(XL,A,B,AM,SD,XOUT1) CALL TNRCDF(XU,A,B,AM,SD,XOUT2) GOTO2990 C 1630 CONTINUE IDIST='LOG GAMMA' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL LGACDF(XL,GAMMA,ILGADF,XOUT1) CALL LGACDF(XU,GAMMA,ILGADF,XOUT2) GOTO2990 C 1640 CONTINUE IDIST='HYPERBOLIC SECANT' NUMPAR=2 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL HSECDF(XL,XOUT1) CALL HSECDF(XU,XOUT2) GOTO2990 C 1650 CONTINUE IDIST='GOMPERTZ' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL GOMCDF(XL,C,B,XOUT1) CALL GOMCDF(XU,C,B,XOUT2) GOTO2990 C 1660 CONTINUE IDIST='HALF CAUCHY' NUMPAR=2 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL HFCCDF(XL,XOUT1) CALL HFCCDF(XU,XOUT2) GOTO2990 C 1670 CONTINUE NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL HFLCDF(XL,GAMMA,XOUT1) CALL HFLCDF(XU,GAMMA,XOUT2) GOTO2990 C 1680 CONTINUE IDIST='GENERALIZED EXTREME VALUE' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL GEVCDF(XL,GAMMA,MINMAX,XOUT1) CALL GEVCDF(XU,GAMMA,MINMAX,XOUT2) GOTO2990 C 1690 CONTINUE IDIST='PARETO OF THE SECOND KIND' NUMPAR=4 ZLOC=A IF(ZLOC.LE.XMIN)ZLOC=XMIN XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 CALL PA2CDF(XL,GAMMA,ZLOC,XOUT1) CALL PA2CDF(XU,GAMMA,ZLOC,XOUT2) GOTO2990 C 1700 CONTINUE IDIST='DOUBLE WEIBULL' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL DWECDF(XL,GAMMA,XOUT1) CALL DWECDF(XU,GAMMA,XOUT2) GOTO2990 C 1710 CONTINUE IDIST='WRAPPED CAUCHY' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CONST=2.0*PI IF(XL.LT.0.0)XL=0.0 IF(XL.GT.CONST)XL=CONST IF(XU.LT.0.0)XU=0.0 IF(XU.GT.CONST)XU=CONST CALL WCACDF(XL,P,XOUT1) CALL WCACDF(XU,P,XOUT2) GOTO2990 C 1720 CONTINUE IDIST='EXPONENTIATED WEIBULL' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 IARG1=1 CALL EWECDF(XL,GAMMA,THETA,IARG1,XOUT1) CALL EWECDF(XU,GAMMA,THETA,IARG1,XOUT2) GOTO2990 C 1730 CONTINUE IDIST='TRUNCATED EXPONENTIAL' NUMPAR=5 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.AM)XL=AM IF(XU.LT.AM)XU=AM IF(XL.GT.X0)XL=X0 IF(XU.GT.X0)XU=X0 CALL TNECDF(XL,X0,AM,SD,XOUT1) CALL TNECDF(XU,X0,AM,SD,XOUT2) GOTO2990 C 1740 CONTINUE IDIST='GENERALIZED LOGISTIC' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL GLOCDF(XL,ALPHA,XOUT1) CALL GLOCDF(XU,ALPHA,XOUT2) GOTO2990 C 1750 CONTINUE IDIST='POWER EXPONENTIAL' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL PEXCDF(XL,ALPHA,BETA,XOUT1) CALL PEXCDF(XU,ALPHA,BETA,XOUT2) GOTO2990 C 1760 CONTINUE IDIST='DOUBLE GAMMA' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL DGACDF(XL,GAMMA,XOUT1) CALL DGACDF(XU,GAMMA,XOUT2) GOTO2990 C 1770 CONTINUE IDIST='MEILKE BETA-KAPPA' NUMPAR=5 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL KAPCDF(XL,ANU,BETA,THETA,XOUT1) CALL KAPCDF(XU,ANU,BETA,THETA,XOUT2) GOTO2990 C 1780 CONTINUE IDIST='FOLDED CAUCHY' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL FCACDF(XL,AM,SD,XOUT1) CALL FCACDF(XU,AM,SD,XOUT2) GOTO2990 C 1790 CONTINUE IDIST='BETA BINOMIAL' NUMPAR=3 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DCDFL=0.0D0 DO1791ITEMP=ISTRT,ISTOP CALL BBNPDF(REAL(ITEMP),ALPHA,BETA,NU,ATEMP) DCDFL=DCDFL + DBLE(ATEMP) 1791 CONTINUE XOUT2=REAL(DCDFL) ENDIF CCCCC XOUT1=0.0 CCCCC CALL BBNCDF(REAL(IXU),ALPHA,BETA,NU,XOUT2) CCCCC IF(IXL.GE.0) CALL BBNCDF(REAL(IXL),ALPHA,BETA,NU,XOUT1) GOTO2990 C 1800 CONTINUE IDIST='BRADFORD' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XL.GT.1.0)XL=1.0 IF(XU.LT.0.0)XU=0.0 IF(XU.GT.1.0)XU=1.0 CALL BRACDF(XL,BETA,XOUT1) CALL BRACDF(XU,BETA,XOUT2) GOTO2990 C 1810 CONTINUE IDIST='GENERALIZED EXPONENTIAL' NUMPAR=5 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL GEXCDF(XL,ALAMB1,ALAMB2,GAMMA,XOUT1) CALL GEXCDF(XU,ALAMB1,ALAMB2,GAMMA,XOUT2) GOTO2990 C 1820 CONTINUE IDIST='RECIPROCAL' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL RECCDF(XL,B,XOUT1) CALL RECCDF(XU,B,XOUT2) GOTO2990 C 1830 CONTINUE IDIST='MIXTURE OF 2 NORMALS' NUMPAR=7 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL NMXCDF(XL,U1,SD1,U2,SD2,P,XOUT1) CALL NMXCDF(XU,U1,SD1,U2,SD2,P,XOUT2) GOTO2990 C 1840 CONTINUE IDIST='INVERTED GAMMA' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL IGACDF(XL,GAMMA,XOUT1) CALL IGACDF(XU,GAMMA,XOUT2) GOTO2990 C 1850 CONTINUE IDIST='INVERTED WEIBULL' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL IWECDF(XL,GAMMA,XOUT1) CALL IWECDF(XU,GAMMA,XOUT2) GOTO2990 C 1860 CONTINUE IDIST='LOG DOUBLE EXPONENTIAL' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL LDECDF(XL,ALPHA,XOUT1) CALL LDECDF(XU,ALPHA,XOUT2) GOTO2990 C 1870 CONTINUE IDIST='GENERALIZED TUKEY-LAMBDA' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL GLDCDF(DBLE(XL),DBLE(ALAMB3),DBLE(ALAMB4), 1 DOUT1,IGLDDF,IWRITE) XOUT1=REAL(DOUT1) CALL GLDCDF(DBLE(XU),DBLE(ALAMB3),DBLE(ALAMB4), 1 DOUT2,IGLDDF,IWRITE) XOUT2=REAL(DOUT2) GOTO2990 C 1880 CONTINUE IDIST='JOHNSON SB' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XL.GT.1.0)XL=1.0 IF(XU.LT.0.0)XU=0.0 IF(XU.GT.1.0)XU=1.0 CALL JSBCDF(XL,ALPHA1,ALPHA2,XOUT1) CALL JSBCDF(XU,ALPHA1,ALPHA2,XOUT2) GOTO2990 C 1890 CONTINUE IDIST='JOHNSON SU' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL JSUCDF(XL,ALPHA1,ALPHA2,XOUT1) CALL JSUCDF(XU,ALPHA1,ALPHA2,XOUT2) GOTO2990 C 1900 CONTINUE IDIST='GEOMETRIC EXTREME EXPONENTIAL' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL GEECDF(XL,GAMMA,XOUT1) CALL GEECDF(XU,GAMMA,XOUT2) GOTO2990 C 1910 CONTINUE IDIST='TWO-SIDED POWER' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XL.GT.1.0)XL=1.0 IF(XU.LT.0.0)XU=0.0 IF(XU.GT.1.0)XU=1.0 CALL TSPCDF(XL,THETA,ANU,XOUT1) CALL TSPCDF(XU,THETA,ANU,XOUT2) GOTO2990 C 1920 CONTINUE IDIST='BIWEIBULL' NUMPAR=7 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL BWECDF(XL,ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,XOUT1,DTEMP1) CALL BWECDF(XU,ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,XOUT2,DTEMP1) GOTO2990 C 1930 CONTINUE IDIST='LANDAU' NUMPAR=2 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL DTEMP1=LANCDF(XL) XOUT1=REAL(DTEMP1) DTEMP2=LANCDF(XU) XOUT2=REAL(DTEMP1) GOTO2990 C 1940 CONTINUE IDIST='ERROR (= EXPONENTIAL POWER)' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL ERRCDF(XL,ALPHA,XOUT1) CALL ERRCDF(XU,ALPHA,XOUT2) GOTO2990 C 1950 CONTINUE IDIST='TRAPEZOID' NUMPAR=6 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL TRACDF(XL,A,B,C,DZ,XOUT1) CALL TRACDF(XU,A,B,C,DZ,XOUT2) GOTO2990 C 1960 CONTINUE IDIST='GENERALIZED TRAPEZOID' NUMPAR=9 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL GTRCDF(XL,A,B,C,DZ,ANU1,ANU3,ALPHA,XOUT1) CALL GTRCDF(XU,A,B,C,DZ,ANU1,ANU3,ALPHA,XOUT2) GOTO2990 C 1970 CONTINUE IDIST='FOLDED T' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL FTCDF(XL,NU,XOUT1) CALL FTCDF(XU,NU,XOUT2) GOTO2990 C 1980 CONTINUE IDIST='SLASH' NUMPAR=2 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL SLACDF(XL,XOUT1) CALL SLACDF(XU,XOUT2) GOTO2990 C 1990 CONTINUE IDIST='SKEW NORMAL' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL SNCDF(XL,ALAMBA,ISKNDF,XOUT1) CALL SNCDF(XU,ALAMBA,ISKNDF,XOUT2) GOTO2990 C 2000 CONTINUE IDIST='SKEW T' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL STCDF(XL,NU,ALAMBA,XOUT1) CALL STCDF(XU,NU,ALAMBA,XOUT2) GOTO2990 C 2010 CONTINUE IDIST='INVERTED BETA' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL IBCDF(XL,ALPHA,BETA,XOUT1) CALL IBCDF(XU,ALPHA,BETA,XOUT2) GOTO2990 C 2020 CONTINUE IDIST='GOMPERTZ-MAKEHAM' NUMPAR=5 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 IF(IMAKDF.EQ.'DLMF')THEN CALL MAKCDF(XL,XI,ALAMB,THETA,XOUT1) CALL MAKCDF(XU,XI,ALAMB,THETA,XOUT2) ELSEIF(IMAKDF.EQ.'MEEK')THEN XI=GAMMA/AK THETA=ALAMB/GAMMA ALAMB=AK CALL MAKCDF(XL,XI,ALAMB,THETA,XOUT1) CALL MAKCDF(XU,XI,ALAMB,THETA,XOUT2) ELSEIF(IMAKDF.EQ.'REPA')THEN CALL MA2CDF(XL,ZETA,ETA,XOUT1) CALL MA2CDF(XU,ZETA,ETA,XOUT2) ENDIF GOTO2990 C 2030 CONTINUE IDIST='GENERALIZED INVERSE GAUSSIAN' NUMPAR=5 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL GIGCDF(DBLE(XL),DBLE(CHI),DBLE(ALAMBA),DBLE(THETA),DOUT1) CALL GIGCDF(DBLE(XU),DBLE(CHI),DBLE(ALAMBA),DBLE(THETA),DOUT2) XOUT1=DOUT1 XOUT2=DOUT2 GOTO2990 C 2040 CONTINUE IDIST='GENERALIZED F' NUMPAR=6 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CCCCC CALL GFCDF(XL,XI,ALAMB,NU1,NU2,XOUT1) CCCCC CALL GFCDF(XU,XI,ALAMB,NU1,NU2,XOUT2) GOTO2990 C 2050 CONTINUE IDIST='G-H' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL GHCDF(XL,G,H,XOUT1) CALL GHCDF(XU,G,H,XOUT2) GOTO2990 C 2060 CONTINUE IDIST='LOG SKEW NORMAL' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL LSNCDF(XL,ALAMBA,SD,XOUT1) CALL LSNCDF(XU,ALAMBA,SD,XOUT2) GOTO2990 C 2070 CONTINUE IDIST='LOG SKEW T' NUMPAR=5 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL LSTCDF(XL,NU,ALAMBA,SD,XOUT1) CALL LSTCDF(XU,NU,ALAMBA,SD,XOUT2) GOTO2990 C 2080 CONTINUE IDIST='ARCSIN' NUMPAR=2 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XL.GT.1.0)XL=1.0 IF(XU.LT.0.0)XU=0.0 IF(XU.GT.1.0)XU=1.0 CALL ARSCDF(XL,XOUT1) CALL ARSCDF(XU,XOUT2) GOTO2990 C 2090 CONTINUE IDIST='POLYA' NUMPAR=3 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DCDFL=0.0D0 DO2091ITEMP=ISTRT,ISTOP CALL POLPDF(REAL(ITEMP),W,ALPHA,BETA,NU,ATEMP) DCDFL=DCDFL + DBLE(ATEMP) 2091 CONTINUE XOUT2=REAL(DCDFL) ENDIF CCCCC XOUT1=0.0 CCCCC CALL POLCDF(REAL(IXU),ALPHA,BETA,NU,XOUT2) CCCCC IF(IXL.GE.0) CALL POLCDF(REAL(IXL),ALPHA,BETA,NU,XOUT1) GOTO2990 C 2100 CONTINUE IDIST='HERMITE' NUMPAR=2 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DCDFL=0.0D0 DO2101ITEMP=ISTRT,ISTOP CALL HERPDF(REAL(ITEMP),ALPHA,BETA,ATEMP) DCDFL=DCDFL + DBLE(ATEMP) 2101 CONTINUE XOUT2=REAL(DCDFL) ENDIF CCCCC XOUT1=0.0 CCCCC CALL HERCDF(REAL(IXU),ALPHA,BETA,XOUT2) CCCCC IF(IXL.GE.0) CALL HERCDF(REAL(IXL),ALPHA,BETA,XOUT1) GOTO2990 C 2110 CONTINUE IDIST='SKEW DOUBLE EXPONENTIAL' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL SDECDF(XL,ALAMBA,XOUT1) CALL SDECDF(XU,ALAMBA,XOUT2) GOTO2990 C 2120 CONTINUE IDIST='ASYMMETRIC DOUBLE EXPONENTIAL' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(IADEDF.EQ.'K')THEN CALL ADECDF(XL,AK,IADEDF,XOUT1) CALL ADECDF(XU,AK,IADEDF,XOUT2) ELSE CALL ADECDF(XL,AMU,IADEDF,XOUT1) CALL ADECDF(XU,AMU,IADEDF,XOUT2) ENDIF GOTO2990 C 2130 CONTINUE IDIST='MAXWELL' NUMPAR=2 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL MAXCDF(XL,SIGMA,XOUT1) CALL MAXCDF(XU,SIGMA,XOUT2) GOTO2990 C 2140 CONTINUE IDIST='RAYLEIGH' NUMPAR=2 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(XL.LT.0.0)XL=0.0 IF(XU.LT.0.0)XU=0.0 CALL RAYCDF(XL,XOUT1) CALL RAYCDF(XU,XOUT2) GOTO2990 C 2150 CONTINUE IDIST='GENERALIZED ASYMMETRIC DOUBLE EXPONENTIAL' NUMPAR=2 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL GALCDF(DBLE(XL),DBLE(AK),DBLE(TAU),IADEDF,DOUT1) CALL GALCDF(DBLE(XU),DBLE(AK),DBLE(TAU),IADEDF,DOUT2) XOUT1=DOUT1 XOUT2=DOUT2 GOTO2990 C 2160 CONTINUE IDIST='MCLEISH' NUMPAR=2 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL MCLCDF(DBLE(XL),DBLE(ALPHA),DOUT1) CALL MCLCDF(DBLE(XU),DBLE(ALPHA),DOUT2) XOUT1=DOUT1 XOUT2=DOUT2 GOTO2990 C 2170 CONTINUE IDIST='BESSEL I-FUNCTION' NUMPAR=2 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(IBEIDF.EQ.'1')THEN CALL BEICDF(DBLE(XL),DBLE(SD1),DBLE(SD2),DBLE(ANU),IBEIDF, 1 DOUT1) CALL BEICDF(DBLE(XU),DBLE(SD1),DBLE(SD2),DBLE(ANU),IBEIDF, 1 DOUT2) ELSE CALL BEICDF(DBLE(XL),DBLE(B),DBLE(C),DBLE(AM),IBEIDF, 1 DOUT1) CALL BEICDF(DBLE(XU),DBLE(B),DBLE(C),DBLE(AM),IBEIDF, 1 DOUT2) ENDIF XOUT1=DOUT1 XOUT2=DOUT2 GOTO2990 C 2180 CONTINUE IDIST='BESSEL K-FUNCTION' NUMPAR=2 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CCCCC CALL BEKCDF(DBLE(XL),DBLE(SD1),DBLE(SD2),DBLE(ANU),DOUT1) CCCCC CALL BEKCDF(DBLE(XU),DBLE(SD1),DBLE(SD2),DBLE(ANU),DOUT2) XOUT1=DOUT1 XOUT2=DOUT2 GOTO2990 C 2190 CONTINUE IDIST='GENERALIZED MCLEISH' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL GMCCDF(DBLE(XL),DBLE(ALPHA),DBLE(A),DOUT1) CALL GMCCDF(DBLE(XU),DBLE(ALPHA),DBLE(A),DOUT2) XOUT1=DOUT1 XOUT2=DOUT2 GOTO2990 C 2200 CONTINUE IDIST='GENERALIZED LOGISTIC TYPE 5 (HOSKING)' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 CCCCC XL=(XL-CHSLOC)/CHSCAL CCCCC XU=(XU-CHSLOC)/CHSCAL XPAR(1)=DBLE(CHSLOC) XPAR(2)=DBLE(CHSCAL) XPAR(3)=DBLE(ALPHA) DOUT1=CDFGLO(DBLE(XL),XPAR) DOUT2=CDFGLO(DBLE(XU),XPAR) XOUT1=DOUT1 XOUT2=DOUT2 GOTO2990 C 2210 CONTINUE IDIST='WAKEBY' NUMPAR=5 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 CCCCC XL=(XL-CHSLOC)/CHSCAL CCCCC XU=(XU-CHSLOC)/CHSCAL XPAR(1)=DBLE(CHSLOC) XPAR(2)=DBLE(CHSCAL) XPAR(3)=DBLE(BETA) XPAR(4)=DBLE(GAMMA) XPAR(5)=DBLE(DELTA) DOUT1=CDFWAK(DBLE(XL),XPAR) DOUT2=CDFWAK(DBLE(XU),XPAR) XOUT1=DOUT1 XOUT2=DOUT2 GOTO2990 C 2220 CONTINUE IDIST='BETA-NORMAL' NUMPAR=4 ZSCALE=CHSCAL-CHSLOC XL=(XL-CHSLOC)/ZSCALE XU=(XU-CHSLOC)/ZSCALE IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 CALL BNOCDF(DBLE(XL),DBLE(ALPHA),DBLE(BETA),DOUT1) CALL BNOCDF(DBLE(XU),DBLE(ALPHA),DBLE(BETA),DOUT2) XOUT1=REAL(DOUT1) XOUT2=REAL(DOUT2) GOTO2990 C 2230 CONTINUE IDIST='GENERALIZED LOGISTIC TYPE 2' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL GL2CDF(DBLE(XL),DBLE(ALPHA),DOUT1) CALL GL2CDF(DBLE(XU),DBLE(ALPHA),DOUT2) XOUT1=DOUT1 XOUT2=DOUT2 GOTO2990 C 2240 CONTINUE IDIST='GENERALIZED LOGISTIC TYPE 3' NUMPAR=3 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL GL3CDF(DBLE(XL),DBLE(ALPHA),DOUT1) CALL GL3CDF(DBLE(XU),DBLE(ALPHA),DOUT2) XOUT1=DOUT1 XOUT2=DOUT2 GOTO2990 C 2250 CONTINUE IDIST='GENERALIZED LOGISTIC TYPE 4' NUMPAR=4 IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL CALL GL4CDF(DBLE(XL),DBLE(P),DBLE(Q),DOUT1) CALL GL4CDF(DBLE(XU),DBLE(P),DBLE(Q),DOUT2) XOUT1=DOUT1 XOUT2=DOUT2 GOTO2990 C 2260 CONTINUE IDIST='ASYMMETRIC LOG DOUBLE EXPONENTIAL' NUMPAR=4 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 CALL ALDCDF(DBLE(XL),DBLE(ALPHA),DBLE(BETA),DOUT1) CALL ALDCDF(DBLE(XU),DBLE(ALPHA),DBLE(BETA),DOUT2) XOUT1=REAL(DOUT1) XOUT2=REAL(DOUT2) GOTO2990 C 2270 CONTINUE IDIST='BETA GEOMETRIC' NUMPAR=2 DCDFL=0.0D0 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DO2271ITEMP=ISTRT,ISTOP IF(IBGEDF.EQ.'UNSH')THEN CALL BGEPDF(REAL(ITEMP),ALPHA,BETA,ATEMP) ELSE CALL BG2PDF(REAL(ITEMP),ALPHA,BETA,ATEMP) ENDIF DCDFL=DCDFL + DBLE(ATEMP) 2271 CONTINUE XOUT2=REAL(DCDFL) ENDIF GOTO2990 C C ZETA CAN HAVE EXTREMELY LONG TAILS. COMPUTE ZETA C FUNCTION ONCE AND COMPUTE PDF INLINE FOR GREATER C EFFICIENCY. C 2280 CONTINUE IDIST='ZETA' NUMPAR=1 DCDFL=0.0D0 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DO2281ITEMP=ISTRT,ISTOP CCCCC CALL ZETPDF(REAL(ITEMP),ALPHA,ATEMP) CCCCC DCDFL=DCDFL + DBLE(ATEMP) DPDF=DLOG(1.0D0) - DLOG(DZETA) - 1 DBLE(ALPHA)*DLOG(DBLE(ITEMP)) DCDFL=DCDFL + DEXP(DPDF) 2281 CONTINUE XOUT2=REAL(DCDFL) ENDIF GOTO2990 C C ZIPF CAN HAVE EXTREMELY LONG TAILS. COMPUTE DENOMINATOR C FUNCTION ONCE AND COMPUTE PDF INLINE FOR GREATER C EFFICIENCY. C 2290 CONTINUE IDIST='ZIPF' NUMPAR=1 DCDFL=0.0D0 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DO2291ITEMP=ISTRT,ISTOP DPDF=DLOG(1.0D0) - DLOG(DZETA) - 1 DBLE(ALPHA)*DLOG(DBLE(ITEMP)) DCDFL=DCDFL + DEXP(DPDF) 2291 CONTINUE XOUT2=REAL(DCDFL) ENDIF GOTO2990 C 2300 CONTINUE IDIST='BOREL-TANNER' NUMPAR=2 DCDFL=0.0D0 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DO2301ITEMP=ISTRT,ISTOP CALL BTAPDF(REAL(ITEMP),ALAMBA,REAL(K),ATEMP) DCDFL=DCDFL + DBLE(ATEMP) 2301 CONTINUE XOUT2=REAL(DCDFL) ENDIF GOTO2990 C 2320 CONTINUE IDIST='BETA NEGATIVE BINOMIAL' NUMPAR=3 DCDFL=0.0D0 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DO2321ITEMP=ISTRT,ISTOP CALL GWAPDF(DBLE(ITEMP),DBLE(ALPHA),DBLE(BETA), 1 DBLE(AK),DTEMP1) DCDFL=DCDFL + DTEMP1 2321 CONTINUE XOUT2=REAL(DCDFL) ENDIF GOTO2990 C 2330 CONTINUE IDIST='LAGRANGE-POISSON' NUMPAR=2 DCDFL=0.0D0 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DO2331ITEMP=ISTRT,ISTOP CALL LPOPDF(REAL(ITEMP),ALAMBA,THETA,ATEMP) DCDFL=DCDFL + DBLE(ATEMP) 2331 CONTINUE XOUT2=REAL(DCDFL) ENDIF GOTO2990 C 2340 CONTINUE IDIST='LEADS IN COIN TOSSING' NUMPAR=1 DCDFL=0.0D0 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DO2341ITEMP=ISTRT,ISTOP CALL LCTPDF(REAL(ITEMP),NDUN,ATEMP) DCDFL=DCDFL + DBLE(ATEMP) 2341 CONTINUE XOUT2=REAL(DCDFL) ENDIF GOTO2990 C 2350 CONTINUE IDIST='CLASSICAL MATCHING' NUMPAR=1 DCDFL=0.0D0 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DO2351ITEMP=ISTRT,ISTOP CALL MATPDF(REAL(ITEMP),K,ATEMP) DCDFL=DCDFL + DBLE(ATEMP) 2351 CONTINUE XOUT2=REAL(DCDFL) ENDIF GOTO2990 C 2360 CONTINUE IDIST='CLASSICAL OCCUPANCY' NUMPAR=1 DCDFL=0.0D0 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DO2361ITEMP=ISTRT,ISTOP CCCCC CALL OCCPDF(REAL(ITEMP),NDUN,K,ATEMP) DCDFL=DCDFL + DBLE(ATEMP) 2361 CONTINUE XOUT2=REAL(DCDFL) ENDIF GOTO2990 C 2370 CONTINUE IDIST='LOG BETA' NUMPAR=6 XL=(XL-CHSLOC)/CHSCAL XU=(XU-CHSLOC)/CHSCAL IF(CHSLOC.EQ.0.0)NUMPAR=NUMPAR-1 IF(CHSCAL.EQ.1.0)NUMPAR=NUMPAR-1 CALL LBECDF(XL,ALPHA,BETA,YLOWLM,YUPPLM,XOUT1) CALL LBECDF(XU,ALPHA,BETA,YLOWLM,YUPPLM,XOUT2) GOTO2990 C 2380 CONTINUE IDIST='POLYA-AEPPLI' NUMPAR=2 DCDFL=0.0D0 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DO2381ITEMP=ISTRT,ISTOP CALL PAPPDF(DBLE(ITEMP),DBLE(THETA),DBLE(P),DTEMP1) DCDFL=DCDFL + DTEMP1 2381 CONTINUE XOUT2=REAL(DCDFL) ENDIF GOTO2990 C 2390 CONTINUE IDIST='LOST GAMES' NUMPAR=2 DCDFL=0.0D0 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DO2391ITEMP=ISTRT,ISTOP CALL LOSPDF(REAL(ITEMP),P,NU,ATEMP1) DCDFL=DCDFL + ATEMP1 2391 CONTINUE XOUT2=REAL(DCDFL) ENDIF GOTO2990 C 2400 CONTINUE IDIST='GENERALIZED LOGARITHMIC SERIES' NUMPAR=2 DCDFL=0.0D0 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DO2401ITEMP=ISTRT,ISTOP CALL GLSPDF(REAL(ITEMP),THETA,BETA,ATEMP1) DCDFL=DCDFL + ATEMP1 2401 CONTINUE XOUT2=REAL(DCDFL) ENDIF GOTO2990 C 2410 CONTINUE IDIST='GENERALIZED NEGATIVE BINOMIAL' NUMPAR=3 DCDFL=0.0D0 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DO2411ITEMP=ISTRT,ISTOP CALL GNBPDF(REAL(ITEMP),THETA,BETA,AM,ATEMP1) DCDFL=DCDFL + ATEMP1 2411 CONTINUE XOUT2=REAL(DCDFL) ENDIF GOTO2990 C 2420 CONTINUE IDIST='GEETA' NUMPAR=2 DCDFL=0.0D0 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(IGETDF.EQ.'THET')THEN SHAPE=THETA ELSE SHAPE=AMU ENDIF IF(ISTRT.LE.ISTOP)THEN DO2421ITEMP=ISTRT,ISTOP CALL GETPDF(DBLE(ITEMP),DBLE(SHAPE),DBLE(BETA), 1 IGETDF,DTEMP1) DCDFL=DCDFL + DTEMP1 2421 CONTINUE XOUT2=REAL(DCDFL) ENDIF GOTO2990 C 2430 CONTINUE IDIST='QUASI BINOMIAL TYPE I' NUMPAR=3 DCDFL=0.0D0 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DO2431ITEMP=ISTRT,ISTOP CALL QBIPDF(REAL(ITEMP),P,PHI,AM,ATEMP1) DCDFL=DCDFL + ATEMP1 2431 CONTINUE XOUT2=REAL(DCDFL) ENDIF GOTO2990 C 2440 CONTINUE IDIST='CONSUL (GENERALIZED GEOMETRIC)' NUMPAR=2 DCDFL=0.0D0 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ICONDF.EQ.'THET')THEN SHAPE=THETA ELSE SHAPE=AMU ENDIF IF(ISTRT.LE.ISTOP)THEN DO2441ITEMP=ISTRT,ISTOP CALL CONPDF(DBLE(ITEMP),DBLE(SHAPE),DBLE(AM), 1 ICONDF,DTEMP1) DCDFL=DCDFL + DTEMP1 2441 CONTINUE XOUT2=REAL(DCDFL) ENDIF GOTO2990 C 2450 CONTINUE IDIST='LAGRANGE KATZ' NUMPAR=3 DCDFL=0.0D0 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DO2451ITEMP=ISTRT,ISTOP CALL LKPDF(DBLE(ITEMP),DBLE(A),DBLE(B),DBLE(BETA),DTEMP1) DCDFL=DCDFL + DTEMP1 2451 CONTINUE XOUT2=REAL(DCDFL) ENDIF GOTO2990 C 2460 CONTINUE IDIST='KATZ' NUMPAR=2 B=0.0 DCDFL=0.0D0 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DO2461ITEMP=ISTRT,ISTOP CALL LKPDF(DBLE(ITEMP),DBLE(ALPHA),DBLE(B),DBLE(BETA), 1 DTEMP1) DCDFL=DCDFL + DTEMP1 2461 CONTINUE XOUT2=REAL(DCDFL) ENDIF GOTO2990 C 2470 CONTINUE IDIST='DISCRETE WEIBULL' NUMPAR=2 DCDFL=0.0D0 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DO2471ITEMP=ISTRT,ISTOP CALL DIWPDF(DBLE(ITEMP),DBLE(P),DBLE(BETA),DTEMP1) DCDFL=DCDFL + DTEMP1 2471 CONTINUE XOUT2=REAL(DCDFL) ENDIF GOTO2990 C 2480 CONTINUE IDIST='GENERALIZED LOST GAMES' NUMPAR=3 DCDFL=0.0D0 XOUT1=0.0 XOUT2=0.0 ISTRT=IXL IF(ISTRT.LT.ILOWLM)ISTRT=ILOWLM ISTOP=IXU IF(ISTRT.LE.ISTOP)THEN DO2481ITEMP=ISTRT,ISTOP CALL GLGPDF(REAL(ITEMP),P,NU,A,ATEMP1) DCDFL=DCDFL + ATEMP1 2481 CONTINUE XOUT2=REAL(DCDFL) ENDIF GOTO2990 C 2990 CONTINUE C CCCCC IF(I.EQ.1)THEN CCCCC D2(I)=XOUT2 CCCCC ELSEIF(I.EQ.N2)THEN CCCCC D2(I)=1.0-XOUT1 CCCCC ELSE D2(I)=XOUT2-XOUT1 CCCCC ENDIF C IF(D2(I).EQ.0.0)THEN NEMPTY=NEMPTY+1 GOTO1199 ENDIF D2(I)=D2(I)*AN C DTEMP1=DBLE(Y2(I)) DTEMP2=DBLE(D2(I)) IF(DTEMP2.GT.0.0D0)DSUM1=DSUM1 + (DTEMP1-DTEMP2)**2/DTEMP2 C 1199 CONTINUE C C JULY 2006. THE CHI-SQUARE TEST STATISTIC CAN BE QUITE C LARGE WHEN THE PARAMETERS ARE NOT NEAR THEIR C OPTIMAL VALUES. FOR THIS REASON, ALLOW THE C USER TO SPECIFY AN UPPER LIMIT (PCHSLM). THIS C CAN PREVENT THE CHI-SQUARE PLOT FROM BLOWING UP. C N2=N2-NEMPTY STAT=REAL(DSUM1) IF(STAT.GT.PCHSLM)STAT=PCHSLM IDF=N2-NUMPAR-1 IF(IDF.LT.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2011) 2011 FORMAT('***** ERROR DPCHS2--NON-POSITIVE DEGREES OF FREEDOM') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2013)N2 2013 FORMAT(' NUMBER OF CELLS = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2015)NUMPAR 2015 FORMAT(' NUMBER OF PARAMETERS = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2017)IDF 2017 FORMAT(' DEGREES OF FREEDOM = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C CALL CHSCDF(STAT,IDF,CDF) C ICONC1='REJECT' ICONC2='REJECT' ICONC3='REJECT' C STATVA=STAT STATCD=CDF STATNU=IDF CALL CHSPPF(.90,IDF,CUTU90) CALL CHSPPF(.95,IDF,CUTU95) CALL CHSPPF(.99,IDF,CUTU99) C IF(STATVA.LE.CUTU90)ICONC1='ACCEPT' IF(STATVA.LE.CUTU95)ICONC2='ACCEPT' IF(STATVA.LE.CUTU99)ICONC3='ACCEPT' C IF(IWRIT2.EQ.'OFF')GOTO9000 C C ******************************* C ** STEP 32-- ** C ** WRITE OUT EVERYTHING ** C ** FOR A CHI-SQUARED TEST ** C ******************************* C ISTEPN='32' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'ON')THEN IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN WRITE(ICOUT,5101) 5101 FORMAT('') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5107) 5107 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5111) 5111 FORMAT('') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5113) 5113 FORMAT(' ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5141) 5141 FORMAT(' Null Hypothesis H0:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5151) 5151 FORMAT(' Distribution Fits the Data') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5142) 5142 FORMAT(' Alternate Hypothesis Ha:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152) 5152 FORMAT(' Distribution Does Not Fit the Data') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5143) 5143 FORMAT(' Distribution:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5153)IDIST 5153 FORMAT(' ',A50) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5121) 5121 FORMAT(' ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) 5123 FORMAT(' ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) 5126 FORMAT(' ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5184) 5184 FORMAT(' Number of Non-Empty Cells:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5154)N2 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5186) 5186 FORMAT(' Number of Parameters:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5154)NUMPAR CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5145) 5145 FORMAT(' Chi-Square Test Statistic:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5155)STAT 5155 FORMAT(' ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5146) 5146 FORMAT(' Degrees of Freedom:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5154)IDF CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5147) 5147 FORMAT(' Chi-Square CDF Value:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5155)CDF CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5991) 5991 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5115) 5115 FORMAT(' CHI-SQUARE GOODNESS-OF-FIT TEST') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5119) 5119 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5144) 5144 FORMAT(' Number of Observations:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) 5127 FORMAT(' ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5154)N 5154 FORMAT(' ',I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) 5128 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5993) 5993 FORMAT('
') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5995) 5995 FORMAT('
') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5307) 5307 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5311) 5311 FORMAT('') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5321) 5321 FORMAT(' ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5323) 5323 FORMAT(' ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5323) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5351) 5351 FORMAT(' Cutoff') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5329) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5323) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5353) 5353 FORMAT(' Conclusion') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5329) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5328) 5328 FORMAT(' ') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5321) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5313) 5313 FORMAT(' ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5328) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5321) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5440) 5440 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5341) 5341 FORMAT(' Alpha
    Level') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5329) 5329 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5319) 5319 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5327) 5327 FORMAT('     		') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5441) 5441 FORMAT(' 10%') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5327) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5440) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5442)CUTU90 5442 FORMAT(' ',F10.5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5327) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5440) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5443)ICONC1 5443 FORMAT(' ',A6,' H0') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5327) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5328) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5321) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5440) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5541) 5541 FORMAT(' 5%') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5327) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5440) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5442)CUTU95 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5327) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5440) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5443)ICONC2 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5327) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5328) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5321) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5440) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5641) 5641 FORMAT(' 1%') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5327) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5440) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5442)CUTU99 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5327) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5440) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5443)ICONC3 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5327) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5328) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5991) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5993) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5499) 5499 FORMAT('
    ')
        CALL DPWRST('XXX','WRIT')
C
CCCCC OCTOBER 2003: ADD LATEX SUPPORT.
      ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN
 8001 FORMAT('{',A1,'bf CHI-SQUARE GOODNESS-OF-FIT TEST}')
 8002 FORMAT(A1,A1)
 8003 FORMAT(A1,'end{table}')
 8007 FORMAT(A1,'begin{center}')
 8009 FORMAT(5X,'$ ',A1,1X,A1,' $ ',A1,A1,' ')
 8010 FORMAT(A1,'end{center}')
 8012 FORMAT(A1,'end{verbatim}')
 8013 FORMAT(A1,'begin{table}')
 8014 FORMAT(5X,'$ ',A1,1X,A1,' $ ',A1,A1,' ')
 8016 FORMAT(5X,'} ',A1,A1)
C
        CALL DPCONA(92,IBASLC)
C
        WRITE(ICOUT,8012)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8013)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8007)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8001)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8014)IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8014)IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8010)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
 8020 FORMAT(5X,A1,'begin{tabular} {lr}')
 8021 FORMAT(5X,'Null Hypothesis $H_0$: & Distribution Fits the Data',
     1       2X,A1,A1)
 8022 FORMAT(5X,'Alternate Hypothesis $H_a$: & Distribution Does Not ',
     1       'Fit the Data',2X,A1,A1)
 8023 FORMAT(5X,'Distribution: & ',A50,2X,A1,A1)
 8024 FORMAT(5X,'Number of Observations: & ',I8,2X,A1,A1)
 8025 FORMAT(5X,'Number of Non-Empty Cells: & ',I8,2X,A1,A1)
 8026 FORMAT(5X,'Number of Parameters: & ',I8,2X,A1,A1)
 8027 FORMAT(5X,'Chi-Square Test Statistic & ',G15.7,2X,A1,A1)
 8028 FORMAT(5X,'Degrees of Freedom: & ',I8,2X,A1,A1)
 8029 FORMAT(5X,'Chi-Square CDF Value & ',G15.7,2X,A1,A1)
 8030 FORMAT(A1,'end{tabular}')
        WRITE(ICOUT,8007)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8020)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8021)IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8022)IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8023)IDIST,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8024)INT(AN+0.1),IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8025)N2,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8026)NUMPAR,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8027)STAT,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8028)IDF,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8029)CDF,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8030)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8010)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
 8040 FORMAT(5X,A1,'begin{tabular} {rrr}')
 8041 FORMAT(5X,'Alpha Level & Cutoff & Conclusion',2X,A1,A1,
     1       2x,A1,'hline')
 8042 FORMAT(5X,'10',A1,'% & ',F10.5,' & ',A6,' $H_0$',2X,A1,A1)
 8043 FORMAT(5X,'5',A1,'% & ',F10.5,' & ',A6,' $H_0$',2X,A1,A1)
 8044 FORMAT(5X,'1',A1,'% & ',F10.5,' & ',A6,' $H_0$',2X,A1,A1)
 8049 FORMAT(A1,'end{table}')
 8050 FORMAT(A1,'end{tabular}')
        WRITE(ICOUT,8007)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8040)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8041)IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8042)IBASLC,CUTU90,ICONC1,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8043)IBASLC,CUTU95,ICONC2,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8044)IBASLC,CUTU99,ICONC3,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8030)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8010)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
 8092   FORMAT(A1,'begin{verbatim}')
        WRITE(ICOUT,8003)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8092)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
      ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN
C  JUST A PLACEHOLDER FOR NOW.
C
C
      ELSE
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3211)
 3211   FORMAT(
     1'                  CHI-SQUARED GOODNESS-OF-FIT TEST')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3212)
 3212   FORMAT(
     1'NULL HYPOTHESIS H0:      DISTRIBUTION FITS THE DATA')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,13212)
13212   FORMAT(
     1'ALTERNATE HYPOTHESIS HA: DISTRIBUTION DOES NOT FIT THE DATA')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3213)IDIST
 3213   FORMAT(
     1         'DISTRIBUTION:            ',A50)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,3220)
 3220   FORMAT('SAMPLE:')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3221)INT(AN+0.1)
 3221   FORMAT(3X,'NUMBER OF OBSERVATIONS      = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3222)N2
 3222   FORMAT(3X,'NUMBER OF NON-EMPTY CELLS   = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3224)NUMPAR
 3224   FORMAT(3X,'NUMBER OF PARAMETERS USED   = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,3240)
 3240   FORMAT('TEST:')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3242)STAT
 3242   FORMAT('CHI-SQUARED TEST STATISTIC     = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3243)IDF
 3243   FORMAT(3X,'DEGREES OF FREEDOM          = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3244)CDF
 3244   FORMAT(3X,'CHI-SQUARED CDF VALUE       = ',F11.6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,3253)
 3253   FORMAT('   ALPHA LEVEL         CUTOFF              CONCLUSION')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3255)CUTU90,ICONC1
 3255   FORMAT('           10%',5X,F10.5,15X,A6,' H0')
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,3265)CUTU95,ICONC2
 3265   FORMAT('            5%',5X,F10.5,15X,A6,' H0')
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,3275)CUTU99,ICONC3
 3275   FORMAT('            1%',5X,F10.5,15X,A6,' H0')
        CALL DPWRST('XXX','WRIT')
C
      ENDIF
      ENDIF
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPCHS2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)ICASPL,IDATSW,N2,IERROR
 9012 FORMAT('ICASPL,IDATSW,N2,IERROR = ',A4,2X,A4,I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)INT(AN+0.1),NPAR,STATCD
 9014 FORMAT('NTOT,NPAR,STATCD = ',I8,2X,I8,2X,G15.7)
      CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 2 LINES WERE ADDED   MAY 1993
      WRITE(ICOUT,9015)MINMAX
 9015 FORMAT('MINMAX = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9020I=1,N2
      WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I)
 9021 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2)
      CALL DPWRST('XXX','BUG ')
 9020 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPCHSY(ICHAR2,ICHARN,IBUG,IFOUND)
C
C     PURPOSE--CONVERT A KEYBOARD SYMBOL
C              (. , ; : ETC.) INTO A NUMERIC VALUE
C              (1 TO 23).
C              (1 TO 24).
C     INPUT  ARGUMENTS--ICHAR2 (A HOLLERITH VARIABLE
C                              CONTAINING THE HOLLERITH
C                              CHARACTER(S) OF INTEREST.
C     OUTPUT ARGUMENTS--ICHARN (AN INTEGER VARIABLE
C                              CONTAINING THE NUMERIC
C                              DESIGNATION FOR THE
C                              ALPHABETIC CHARACTER.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--MARCH     1981.
C     UPDATED         --NOVEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MAY       1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICHAR2
      CHARACTER*4 IBUG
      CHARACTER*4 IFOUND
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOBE.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IFOUND='NO'
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CHSY')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPCHSY--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ICHAR2
   52 FORMAT('ICHAR2 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,59)IBUGG4,ISUBG4
   59 FORMAT('IBUGG4,ISUBG4 = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               **********************************
C               **  STEP 1--                    **
C               **  CONVERT THE CHARACTER       **
C               **********************************
C
      IF(ICHAR2.EQ.'.')GOTO100
      IF(ICHAR2.EQ.',')GOTO200
      IF(ICHAR2.EQ.':')GOTO300
      IF(ICHAR2.EQ.';')GOTO400
      IF(ICHAR2.EQ.'!')GOTO500
      IF(ICHAR2.EQ.'?')GOTO600
      IF(ICHAR2.EQ.'&')GOTO700
      IF(ICHAR2.EQ.'$')GOTO800
      IF(ICHAR2.EQ.'/')GOTO900
      IF(ICHAR2.EQ.'(')GOTO1000
      IF(ICHAR2.EQ.')')GOTO1100
      IF(ICHAR2.EQ.'*')GOTO1200
      IF(ICHAR2.EQ.'-')GOTO1300
      IF(ICHAR2.EQ.'+')GOTO1400
      IF(ICHAR2.EQ.'=')GOTO1500
      IF(ICHAR2.EQ.'''')GOTO1600
      IF(ICHAR2.EQ.'"')GOTO1700
      IF(ICHAR2.EQ.'DEGR')GOTO1800
      IF(ICHAR2.EQ.'NOSP')GOTO1900
      IF(ICHAR2.EQ.'HASP')GOTO2000
      IF(ICHAR2.EQ.' ')GOTO2100
      IF(ICHAR2.EQ.'LAPO')GOTO2200
      IF(ICHAR2.EQ.'RAPO')GOTO2300
      IF(ICHAR2.EQ.'|')GOTO2400
      GOTO7900
C
  100 CONTINUE
      ICHARN=1
      GOTO8000
C
  200 CONTINUE
      ICHARN=2
      GOTO8000
C
  300 CONTINUE
      ICHARN=3
      GOTO8000
C
  400 CONTINUE
      ICHARN=4
      GOTO8000
C
  500 CONTINUE
      ICHARN=5
      GOTO8000
C
  600 CONTINUE
      ICHARN=6
      GOTO8000
C
  700 CONTINUE
      ICHARN=7
      GOTO8000
C
  800 CONTINUE
      ICHARN=8
      GOTO8000
C
  900 CONTINUE
      ICHARN=9
      GOTO8000
C
 1000 CONTINUE
      ICHARN=10
      GOTO8000
C
 1100 CONTINUE
      ICHARN=11
      GOTO8000
C
 1200 CONTINUE
      ICHARN=12
      GOTO8000
C
 1300 CONTINUE
      ICHARN=13
      GOTO8000
C
 1400 CONTINUE
      ICHARN=14
      GOTO8000
C
 1500 CONTINUE
      ICHARN=15
      GOTO8000
C
 1600 CONTINUE
      ICHARN=16
      GOTO8000
C
 1700 CONTINUE
      ICHARN=17
      GOTO8000
C
 1800 CONTINUE
      ICHARN=18
      GOTO8000
C
 1900 CONTINUE
      ICHARN=19
      GOTO8000
C
 2000 CONTINUE
      ICHARN=20
      GOTO8000
C
 2100 CONTINUE
      ICHARN=21
      GOTO8000
C
 2200 CONTINUE
      ICHARN=22
      GOTO8000
C
 2300 CONTINUE
      ICHARN=23
      GOTO8000
C
 2400 CONTINUE
      ICHARN=24
      GOTO8000
C
 7900 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,7911)
C7911 FORMAT('***** ERROR IN DPCHSY--')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,7912)
C7912 FORMAT('      NO MATCH FOUND FOR INPUT CHARACTER.')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,7913)ICHAR2
C7913 FORMAT('      INPUT CHARACTER = ',A4)
CCCCC CALL DPWRST('XXX','BUG ')
      IFOUND='NO'
      GOTO9000
C
 8000 CONTINUE
      IFOUND='YES'
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'CHSY')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPCHSY--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IFOUND
 9012 FORMAT('IFOUND = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)ICHAR2,ICHARN
 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9019)IBUGG4,ISUBG4,IFOUND
 9019 FORMAT('IBUGG4,ISUBG4,IFOUND = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPCHSZ(PDEFHE,MAXCHA,
     1PCHAHE,PCHAWI,PCHAVG,PCHAHG,
     1IBUGP2,IBUGQ,IFOUND,IERROR)
C
C     PURPOSE--DEFINE PLOT CHARACTER SIZES FOR USE IN MULTI-TRACE PLOTS.
C              THE SIZE FOR THE CHARACTER FOR THE I-TH TRACE
C              WILL BE PLACED
C              IN THE I-TH ELEMENT OF THE FLOATING POINT
C              VECTOR PCHAHE(.).
C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
C                     --IARGT  (A  HOLLERITH VECTOR)
C                     --ARG    (A  HOLLERITH VECTOR)
C                     --NUMARG
C                     --PDEFHE
C                     --MAXCHA
C     OUTPUT ARGUMENTS--PCHAHE  (A  FLOATING POINT VECTOR
C                       WHOSE I-TH ELEMENT IS THE SIZE (= HEIGHT)
C                       FOR THE CHARACTER
C                       ASSIGNED TO THE I-TH    TRACE    IN
C                       A MULTI-TRACE PLOT.
C                     --PCHAWI = CHARACTER WIDTH
C                     --PCHAVG = VERTICAL GAP BETWEEN CHARACTERS
C                     --PCHAHG = HORIZONTAL GAP BETWEEN CHARACTERS
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--DECEMBER  1977.
C     UPDATED         --SEPTEMBER 1980.
C     UPDATED         --MARCH     1982.
C     UPDATED         --MAY       1982.
C     UPDATED         --DECEMBER  1982.
C     UPDATED         --JANUARY   1995. ALLOW ? AS ARGUMENT (FOR HELP)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CCCCC CHARACTER*4 IHARG          DECEMBER 1986
CCCCC CHARACTER*4 IARGT          DECEMBER 1986
C
      CHARACTER*4 IBUGP2
      CHARACTER*4 IBUGQ
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IHLEFT
      CHARACTER*4 IHLEF2
      CHARACTER*4 IHWUSE
      CHARACTER*4 MESSAG
      CHARACTER*4 ISTEPN
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ICASEQ
      CHARACTER*4 IWRITE
C
C---------------------------------------------------------------------
C
CCCCC DIMENSION IHARG(*)          DECEMBER 1986
CCCCC DIMENSION IARGT(*)          DECEMBER 1986
CCCCC DIMENSION IARG(*)          DECEMBER 1986
CCCCC DIMENSION ARG(*)          DECEMBER 1986
C
      DIMENSION PCHAHE(*)
      DIMENSION PCHAWI(*)
      DIMENSION PCHAVG(*)
      DIMENSION PCHAHG(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOHK.INC'
      INCLUDE 'DPCODA.INC'
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='DPCH'
      ISUBN2='SZ  '
C
      IFOUND='NO'
      IERROR='NO'
C
 1100 CONTINUE
C
      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'SIZE'.AND.
     1IHARG(2).EQ.'BOX'.AND.IHARG(3).EQ.'PLOT')GOTO2110
      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'HEIG'.AND.
     1IHARG(2).EQ.'BOX'.AND.IHARG(3).EQ.'PLOT')GOTO2110
      IF(NUMARG.GE.4.AND.IHARG(2).EQ.'SIZE'.AND.
     1IHARG(3).EQ.'BOX'.AND.IHARG(4).EQ.'PLOT')GOTO2110
      IF(NUMARG.GE.4.AND.IHARG(2).EQ.'HEIG'.AND.
     1IHARG(3).EQ.'BOX'.AND.IHARG(4).EQ.'PLOT')GOTO2110
C
      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'SIZE')GOTO1160
      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'HEIG')GOTO1160
      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SIZE')GOTO1105
      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'HEIG')GOTO1105
      GOTO9000
C
 1105 CONTINUE
      IF(IHARG(NUMARG).EQ.'ON')GOTO1110
      IF(IHARG(NUMARG).EQ.'OFF')GOTO1110
      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110
      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110
CCCCC THE FOLLOWING LINE WAS ADDED    JANUARY 1995
      IF(IHARG(NUMARG).EQ.'?')GOTO1200
C
      IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160
      IF(NUMARG.EQ.2)GOTO1120
      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130
      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140
C
      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'AUTO')GOTO3000
C
      GOTO1150
C
 1110 CONTINUE
      DO1115I=1,MAXCHA
      PCHAHE(I)=PDEFHE
 1115 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO1119
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      I=1
      WRITE(ICOUT,1116)PCHAHE(I)
 1116 FORMAT('ALL CHARACTER SIZES HAVE JUST BEEN SET TO ',
     1E15.7)
      CALL DPWRST('XXX','BUG ')
 1119 CONTINUE
      GOTO8000
C
 1120 CONTINUE
      I=1
      IF(IARGT(2).NE.'NUMB')GOTO1180
      PCHAHE(1)=ARG(2)
C
      IF(IFEEDB.EQ.'OFF')GOTO1129
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      I=1
      WRITE(ICOUT,1126)I,PCHAHE(I)
 1126 FORMAT('THE SIZE FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ',
     1E15.7)
      CALL DPWRST('XXX','BUG ')
 1129 CONTINUE
      GOTO8000
C
 1130 CONTINUE
      I=1
      IF(IARGT(3).NE.'NUMB')GOTO1180
      DO1135I=1,MAXCHA
      PCHAHE(I)=ARG(3)
 1135 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO1139
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      I=1
      WRITE(ICOUT,1116)PCHAHE(I)
      CALL DPWRST('XXX','BUG ')
 1139 CONTINUE
      GOTO8000
C
 1140 CONTINUE
      I=1
      IF(IARGT(2).NE.'NUMB')GOTO1180
      DO1145I=1,MAXCHA
      PCHAHE(I)=ARG(2)
 1145 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO1149
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      I=1
      WRITE(ICOUT,1116)PCHAHE(I)
      CALL DPWRST('XXX','BUG ')
 1149 CONTINUE
      GOTO8000
C
 1150 CONTINUE
      IMAX=NUMARG-1
      IF(MAXCHA.LT.IMAX)IMAX=MAXCHA
      DO1155I=1,IMAX
      IP1=I+1
      IF(IARGT(IP1).NE.'NUMB')GOTO1180
      PCHAHE(I)=ARG(IP1)
 1155 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO1159
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      DO1156I=1,IMAX
      WRITE(ICOUT,1126)I,PCHAHE(I)
      CALL DPWRST('XXX','BUG ')
 1156 CONTINUE
 1159 CONTINUE
      GOTO8000
C
 1160 CONTINUE
      DO1165I=1,MAXCHA
      PCHAHE(I)=PDEFHE
 1165 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO1169
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      I=1
      WRITE(ICOUT,1116)PCHAHE(I)
      CALL DPWRST('XXX','BUG ')
 1169 CONTINUE
      GOTO8000
C
 1180 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)
 1181 FORMAT('***** ERROR IN DPCHSZ--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)
 1182 FORMAT('CHARACTER SIZES MUST BE NUMERIC;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1183)
 1183 FORMAT('HOWEVER, THE SPECIFIED CHARACTER SIZE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1184)I
 1184 FORMAT('FOR CHARACTER ',I6,' WAS NON-NUMERIC.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 1995
 1200 CONTINUE
      IFOUND='YES'
      IF(IFEEDB.EQ.'OFF')GOTO1229
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      I=1
      WRITE(ICOUT,1226)I,PCHAHE(I)
 1226 FORMAT('THE CURRENT SIZE FOR CHARACTER ',I6,' IS ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1227)I,PDEFHE
 1227 FORMAT('THE DEFAULT SIZE FOR CHARACTER ',I6,' IS ',E15.7)
      CALL DPWRST('XXX','BUG ')
 1229 CONTINUE
      GOTO9000
C
 2110 CONTINUE
      IMAX=24
      PCHAHE(1)=2.0
      PCHAHE(2)=2.0
      PCHAHE(3)=2.0
      PCHAHE(4)=2.0
      PCHAHE(5)=2.0
      PCHAHE(6)=2.0
      PCHAHE(7)=2.0
      PCHAHE(8)=2.0
      PCHAHE(9)=2.0
      PCHAHE(10)=2.0
      PCHAHE(11)=2.0
      PCHAHE(12)=2.0
      PCHAHE(13)=2.0
      PCHAHE(14)=2.0
      PCHAHE(15)=2.0
      PCHAHE(16)=2.0
      PCHAHE(17)=2.0
      PCHAHE(18)=2.0
      PCHAHE(19)=2.0
      PCHAHE(20)=2.0
      PCHAHE(21)=3.0
      PCHAHE(22)=2.0
      PCHAHE(23)=2.0
      PCHAHE(24)=3.0
      GOTO2170
C
 2170 CONTINUE
      IF(IFEEDB.EQ.'OFF')GOTO2179
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      DO2175I=1,IMAX
      WRITE(ICOUT,2176)I,PCHAHE(I)
 2176 FORMAT('THE SIZE FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ',
     1E15.7)
      CALL DPWRST('XXX','BUG ')
 2175 CONTINUE
 2179 CONTINUE
      GOTO8000
C
C               ***********************************************************
C               **  STEP 30--                                            **
C               **  TREAT THE   CHARACTER SIZE AUTOMATIC   CASE **
C               ***********************************************************
C
 3000 CONTINUE
C
C               ********************************************
C               **  STEP 31--                             **
C               **  CHECK THE VALIDITY OF ARGUMENT 3      **
C               **  (THIS WILL BE THE RESPONSE VARIABLE)  **
C               ********************************************
C
      ISTEPN='31'
      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IHLEFT=IHARG(3)
      IHLEF2=IHARG2(3)
      IHWUSE='V'
      MESSAG='YES'
      CALL CHECKN(IHLEFT,IHLEF2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      ICOLL=IVALUE(ILOCV)
      NLEFT=IN(ILOCV)
C
C               *****************************************
C               **  STEP 32--                          **
C               **  CHECK TO SEE THE TYPE CASE--       **
C               **    1) UNQUALIFIED (THAT IS, FULL);  **
C               **    2) SUBSET/EXCEPT; OR             **
C               **    3) FOR.                          **
C               *****************************************
C
      ISTEPN='32'
      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICASEQ='FULL'
      ILOCQ=NUMARG+1
      IF(NUMARG.LT.1)GOTO3290
      DO3200J=1,NUMARG
      J1=J
      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ') GOTO3210
      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ') GOTO3210
      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ') GOTO3220
 3200 CONTINUE
      GOTO3290
 3210 CONTINUE
      ICASEQ='SUBS'
      ILOCQ=J1
      GOTO3290
 3220 CONTINUE
      ICASEQ='FOR'
      ILOCQ=J1
      GOTO3290
 3290 CONTINUE
      IF(IBUGP2.EQ.'OFF')GOTO3295
      WRITE(ICOUT,3291)NUMARG,ILOCQ
 3291 FORMAT('NUMARG,ILOCQ = ',2I8)
      CALL DPWRST('XXX','BUG ')
 3295 CONTINUE
C
C               *********************************************
C               **  STEP 33--                              **
C               **  TEMPORARILY FORM THE VARIABLE Y(.)     **
C               **  WHICH WILL HOLD THE RESPONSE VARIABLE. **
C               **  FORM THIS VARIABLE BY                  **
C               **  BRANCHING TO THE APPROPRIATE SUBCASE   **
C               **  (FULL, SUBSET, OR FOR).                **
C               *********************************************
C
      ISTEPN='33'
      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ICASEQ.EQ.'FULL')GOTO3310
      IF(ICASEQ.EQ.'SUBS')GOTO3320
      IF(ICASEQ.EQ.'FOR')GOTO3330
C
 3310 CONTINUE
      DO3315I=1,NLEFT
      ISUB(I)=1
 3315 CONTINUE
      NQ=NLEFT
      GOTO3350
C
 3320 CONTINUE
      NIOLD=NLEFT
      CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
      NQ=NIOLD
      GOTO3350
C
 3330 CONTINUE
      NIOLD=NLEFT
      CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
      NQ=NFOR
      GOTO3350
C
 3350 CONTINUE
      MINN2=1
      IF(NQ.GE.MINN2)GOTO3360
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3351)
 3351 FORMAT('***** ERROR IN DPCHSZ--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3352)
 3352 FORMAT('      AFTER THE APPROPRIATE SUBSET HAS BEEN ',
     1'EXTRACTED,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3353)IHLEFT,IHLEF2
 3353 FORMAT('      THE NUMBER OF OBSERVATIONS REMAINING',
     1'FROM VARIABLE ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3354)
 3354 FORMAT('      (FOR WHICH CHARACTER SIZES ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3355)
 3355 FORMAT('      ARE TO BE GENERATED)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3356)MINN2
 3356 FORMAT('      MUST BE ',I8,' OR LARGER;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3357)
 3357 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3358)
 3358 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,3359)(IANS(I),I=1,IWIDTH)
 3359 FORMAT('      ',80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 3360 CONTINUE
      MAXCP1=MAXCOL+1
      MAXCP2=MAXCOL+2
      MAXCP3=MAXCOL+3
      MAXCP4=MAXCOL+4
      MAXCP5=MAXCOL+5
      MAXCP6=MAXCOL+6
      J=0
      IMAX=NLEFT
      IF(NQ.LT.NLEFT)IMAX=NQ
      DO3370I=1,IMAX
      IF(ISUB(I).EQ.0)GOTO3370
      J=J+1
C
      IJ=MAXN*(ICOLL-1)+I
      IF(ICOLL.LE.MAXCOL)Y(J)=V(IJ)
      IF(ICOLL.EQ.MAXCP1)Y(J)=PRED(I)
      IF(ICOLL.EQ.MAXCP2)Y(J)=RES(I)
      IF(ICOLL.EQ.MAXCP3)Y(J)=YPLOT(I)
      IF(ICOLL.EQ.MAXCP4)Y(J)=XPLOT(I)
      IF(ICOLL.EQ.MAXCP5)Y(J)=X2PLOT(I)
      IF(ICOLL.EQ.MAXCP6)Y(J)=TAGPLO(I)
C
 3370 CONTINUE
      NS=J
      NY=J
C
C               *****************************************
C               **  STEP 34--                          **
C               **  EXTRACT THE DISTINCT VALUES        **
C               **  FROM THE TARGET VARIABLE Y(.)   .  **
C               **  STORE THEM IN X(.)   .             **
C               *****************************************
C
      IWRITE='OFF'
      CALL DISTIN(Y,NY,IWRITE,X,NX,IBUGP2,IERROR)
C
C               ***********************************
C               **  STEP 35--                    **
C               **  SORT THESE DISTINCT VALUES   **
C               **  (IN PLACE).                  **
C               ***********************************
C
      CALL SORT(X,NX,X)
C
C               ******************************************
C               **  STEP 36--                           **
C               **  COPY    THE NUMERIC VALUES IN X(.)  **
C               **  INTO INDIVIDUAL ELEMENTS            **
C               **  OF PCHAHE(.)                        **
C               **  NOTE--MAX NUMBER OF VALUES  = 100   **
C               ******************************************
C
      IMAX=NX
      IF(IMAX.GT.MAXCHA)IMAX=MAXCHA
      DO3650I=1,IMAX
      PCHAHE(I)=X(I)
 3650 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO3679
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      DO3675I=1,IMAX
      WRITE(ICOUT,3676)I,PCHAHE(I)
 3676 FORMAT('CHARACTER SIZE ',I6,' HAS JUST BEEN SET TO ',
     1E15.7)
      CALL DPWRST('XXX','BUG ')
 3675 CONTINUE
 3679 CONTINUE
      GOTO8000
C
 8000 CONTINUE
      IFOUND='YES'
      DO8010I=1,MAXCHA
      PCHAWI(I)=PCHAHE(I)*0.5
      PCHAVG(I)=PCHAHE(I)*0.5
      PCHAHG(I)=PCHAWI(I)*0.5
 8010 CONTINUE
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGP2.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPCHAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGP2
 9012 FORMAT('IBUGP2 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IFOUND,IERROR
 9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)PDEFHE,IMAX
 9014 FORMAT('PDEFHE,IMAX = ',E15.7,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)NY
 9021 FORMAT('NY = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NY.LE.0)GOTO9022
      DO9023I=1,NY
      WRITE(ICOUT,9024)I,Y(I)
 9024 FORMAT('I,Y(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
 9023 CONTINUE
 9022 CONTINUE
      WRITE(ICOUT,9031)NX
 9031 FORMAT('NX = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NX.LE.0)GOTO9032
      DO9033I=1,NX
      WRITE(ICOUT,9034)I,X(I)
 9034 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
 9033 CONTINUE
 9032 CONTINUE
      WRITE(ICOUT,9041)MAXCHA
 9041 FORMAT('MAXCHA = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NX.LE.0)GOTO9042
      DO9043I=1,NX
      WRITE(ICOUT,9044)I,PCHAHE(I),PCHAWI(I),PCHAVG(I),PCHAHG(I)
 9044 FORMAT('I,PCHAHE(I),PCHAWI(I),PCHAVG(I),PCHAHG(I) = ',I8,2X,
     14E15.7)
      CALL DPWRST('XXX','BUG ')
 9043 CONTINUE
 9042 CONTINUE
 9090 CONTINUE
      RETURN
      END
      SUBROUTINE DPCHTH(IHARG,ARG,NUMARG,PDEFTH,MAXCHA,PCHATH,
     1IFOUND,IERROR)
C
C     PURPOSE--DEFINE PLOT CHARACTER THICKNESSS FOR USE IN MULTI-TRACE PLOTS.
C              THE THICKNESS FOR THE CHARACTER FOR THE I-TH TRACE
C              WILL BE PLACED
C              IN THE I-TH ELEMENT OF THE HOLLERITH
C              VECTOR PCHATH(.).
C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
C                     --ARG    (A REAL VECTOR)
C                     --NUMARG
C                     --PDEFTH
C                     --MAXCHA
C     OUTPUT ARGUMENTS--PCHATH  (A  REAL VECTOR
C                       WHOSE I-TH ELEMENT IS THE THICKNESS
C                       FOR THE CHARACTER
C                       ASSIGNED TO THE I-TH    TRACE    IN
C                       A MULTI-TRACE PLOT.
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--ALAN HECKERT
C                 COMPUTER SERVICES DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--DECEMBER  1977.
C     UPDATED         --SEPTEMBER 1980.
C     UPDATED         --MARCH     1982.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION ARG(*)
      DIMENSION PCHATH(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IFOUND='NO'
      IERROR='NO'
C
 1100 CONTINUE
      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'THIC')GOTO1160
      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'THIC')GOTO1105
      GOTO1199
C
 1105 CONTINUE
      IF(IHARG(NUMARG).EQ.'ON')GOTO1110
      IF(IHARG(NUMARG).EQ.'OFF')GOTO1110
      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110
      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110
C
      IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160
      IF(NUMARG.EQ.2)GOTO1120
      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130
      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140
C
      GOTO1150
C
 1110 CONTINUE
      DO1115I=1,MAXCHA
      PCHATH(I)=PDEFTH
 1115 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO1119
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      I=1
      WRITE(ICOUT,1116)PCHATH(I)
 1116 FORMAT('ALL CHARACTER THICKNESSS HAVE JUST BEEN SET TO ',
     1E15.7)
      CALL DPWRST('XXX','BUG ')
 1119 CONTINUE
      GOTO1190
C
 1120 CONTINUE
      PCHATH(1)=ARG(2)
C
      IF(IFEEDB.EQ.'OFF')GOTO1129
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      I=1
      WRITE(ICOUT,1126)I,PCHATH(I)
 1126 FORMAT('THE THICKNESS FOR CHARACTER ',I6,' HAS JUST BEEN ',
     1'SET TO ',E15.7)
      CALL DPWRST('XXX','BUG ')
 1129 CONTINUE
      GOTO1190
C
 1130 CONTINUE
      DO1135I=1,MAXCHA
      PCHATH(I)=ARG(3)
 1135 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO1139
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      I=1
      WRITE(ICOUT,1116)PCHATH(I)
      CALL DPWRST('XXX','BUG ')
 1139 CONTINUE
      GOTO1190
C
 1140 CONTINUE
      DO1145I=1,MAXCHA
      PCHATH(I)=ARG(2)
 1145 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO1149
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      I=1
      WRITE(ICOUT,1116)PCHATH(I)
      CALL DPWRST('XXX','BUG ')
 1149 CONTINUE
      GOTO1190
C
 1150 CONTINUE
      IMAX=NUMARG-1
      IF(MAXCHA.LT.IMAX)IMAX=MAXCHA
      DO1155I=1,IMAX
      IP1=I+1
      PCHATH(I)=ARG(IP1)
 1155 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO1159
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      DO1156I=1,IMAX
      WRITE(ICOUT,1126)I,PCHATH(I)
      CALL DPWRST('XXX','BUG ')
 1156 CONTINUE
 1159 CONTINUE
      GOTO1190
C
 1160 CONTINUE
      DO1165I=1,MAXCHA
      PCHATH(I)=PDEFTH
 1165 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO1169
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      I=1
      WRITE(ICOUT,1116)PCHATH(I)
      CALL DPWRST('XXX','BUG ')
 1169 CONTINUE
      GOTO1190
C
 1190 CONTINUE
      IFOUND='YES'
C
 1199 CONTINUE
      RETURN
      END
      SUBROUTINE DPCHWI(IHARG,IARGT,IARG,ARG,NUMARG,
     1PDEFWI,
     1MAXCHA,
     1PCHAWI,PCHAHG,
     1IFOUND,IERROR)
C
C     PURPOSE--DEFINE PLOT CHARACTER WIDTHS FOR USE IN MULTI-TRACE PLOTS.
C              THE WIDTH FOR THE CHARACTER FOR THE I-TH TRACE
C              WILL BE PLACED
C              IN THE I-TH ELEMENT OF THE FLOATING POINT
C              VECTOR PCHAWI(.).
C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
C                     --IARGT  (A  HOLLERITH VECTOR)
C                     --ARG    (A  HOLLERITH VECTOR)
C                     --NUMARG
C                     --PDEFWI
C                     --MAXCHA
C     OUTPUT ARGUMENTS--PCHAWI  (A  FLOATING POINT VECTOR
C                       WHOSE I-TH ELEMENT IS THE WIDTH (= WIDTHT)
C                       FOR THE CHARACTER
C                       ASSIGNED TO THE I-TH    TRACE    IN
C                       A MULTI-TRACE PLOT.
C                     --PCHAWI = CHARACTER WIDTH
C                     --PCHAHG = HORIZONTAL GAP BETWEEN CHARACTERS
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--DECEMBER  1977.
C     UPDATED         --SEPTEMBER 1980.
C     UPDATED         --MARCH     1982.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IARGT
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION IARGT(*)
      DIMENSION IARG(*)
      DIMENSION ARG(*)
C
      DIMENSION PCHAWI(*)
      DIMENSION PCHAHG(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IFOUND='NO'
      IERROR='NO'
C
 1100 CONTINUE
C
      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'WIDTH'.AND.
     1IHARG(2).EQ.'BOX'.AND.IHARG(3).EQ.'PLOT')GOTO2110
      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'WIDT'.AND.
     1IHARG(2).EQ.'BOX'.AND.IHARG(3).EQ.'PLOT')GOTO2110
      IF(NUMARG.GE.4.AND.IHARG(2).EQ.'WIDTH'.AND.
     1IHARG(3).EQ.'BOX'.AND.IHARG(4).EQ.'PLOT')GOTO2110
      IF(NUMARG.GE.4.AND.IHARG(2).EQ.'WIDT'.AND.
     1IHARG(3).EQ.'BOX'.AND.IHARG(4).EQ.'PLOT')GOTO2110
C
      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'WIDTH')GOTO1160
      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'WIDT')GOTO1160
      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'WIDTH')GOTO1105
      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'WIDT')GOTO1105
      GOTO2199
C
 1105 CONTINUE
      IF(IHARG(NUMARG).EQ.'ON')GOTO1110
      IF(IHARG(NUMARG).EQ.'OFF')GOTO1110
      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110
      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110
C
      IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ALL')GOTO1160
      IF(NUMARG.EQ.2)GOTO1120
      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'ALL')GOTO1130
      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'ALL')GOTO1140
C
      GOTO1150
C
 1110 CONTINUE
      DO1115I=1,MAXCHA
      PCHAWI(I)=PDEFWI
 1115 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO1119
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      I=1
      WRITE(ICOUT,1116)PCHAWI(I)
 1116 FORMAT('ALL CHARACTER WIDTHS HAVE JUST BEEN SET TO ',
     1E15.7)
      CALL DPWRST('XXX','BUG ')
 1119 CONTINUE
      GOTO2190
C
 1120 CONTINUE
      I=1
      IF(IARGT(2).NE.'NUMB')GOTO1180
      PCHAWI(1)=ARG(2)
C
      IF(IFEEDB.EQ.'OFF')GOTO1129
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      I=1
      WRITE(ICOUT,1126)I,PCHAWI(I)
 1126 FORMAT('THE WIDTH FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ',
     1E15.7)
      CALL DPWRST('XXX','BUG ')
 1129 CONTINUE
      GOTO2190
C
 1130 CONTINUE
      I=1
      IF(IARGT(3).NE.'NUMB')GOTO1180
      DO1135I=1,MAXCHA
      PCHAWI(I)=ARG(3)
 1135 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO1139
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      I=1
      WRITE(ICOUT,1116)PCHAWI(I)
      CALL DPWRST('XXX','BUG ')
 1139 CONTINUE
      GOTO2190
C
 1140 CONTINUE
      I=1
      IF(IARGT(2).NE.'NUMB')GOTO1180
      DO1145I=1,MAXCHA
      PCHAWI(I)=ARG(2)
 1145 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO1149
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      I=1
      WRITE(ICOUT,1116)PCHAWI(I)
      CALL DPWRST('XXX','BUG ')
 1149 CONTINUE
      GOTO2190
C
 1150 CONTINUE
      IMAX=NUMARG-1
      IF(MAXCHA.LT.IMAX)IMAX=MAXCHA
      DO1155I=1,IMAX
      IP1=I+1
      IF(IARGT(IP1).NE.'NUMB')GOTO1180
      PCHAWI(I)=ARG(IP1)
 1155 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO1159
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      DO1156I=1,IMAX
      WRITE(ICOUT,1126)I,PCHAWI(I)
      CALL DPWRST('XXX','BUG ')
 1156 CONTINUE
 1159 CONTINUE
      GOTO2190
C
 1160 CONTINUE
      DO1165I=1,MAXCHA
      PCHAWI(I)=PDEFWI
 1165 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO1169
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      I=1
      WRITE(ICOUT,1116)PCHAWI(I)
      CALL DPWRST('XXX','BUG ')
 1169 CONTINUE
      GOTO2190
C
 1180 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)
 1181 FORMAT('***** ERROR IN DPCHWI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)
 1182 FORMAT('CHARACTER WIDTHS MUST BE NUMERIC;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1183)
 1183 FORMAT('HOWEVER, THE SPECIFIED CHARACTER WIDTH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1184)I
 1184 FORMAT('FOR CHARACTER ',I6,' WAS NON-NUMERIC.')
      CALL DPWRST('XXX','BUG ')
      GOTO2199
C
 2110 CONTINUE
      IMAX=24
      PCHAWI(1)=1.0
      PCHAWI(2)=1.0
      PCHAWI(3)=1.0
      PCHAWI(4)=1.0
      PCHAWI(5)=1.0
      PCHAWI(6)=1.0
      PCHAWI(7)=1.0
      PCHAWI(8)=1.0
      PCHAWI(9)=1.0
      PCHAWI(10)=1.0
      PCHAWI(11)=1.0
      PCHAWI(12)=1.0
      PCHAWI(13)=1.0
      PCHAWI(14)=1.0
      PCHAWI(15)=1.0
      PCHAWI(16)=1.0
      PCHAWI(17)=1.0
      PCHAWI(18)=1.0
      PCHAWI(19)=1.0
      PCHAWI(20)=1.0
      PCHAWI(21)=1.5
      PCHAWI(22)=1.0
      PCHAWI(23)=1.0
      PCHAWI(24)=1.5
      GOTO2170
C
 2170 CONTINUE
      IF(IFEEDB.EQ.'OFF')GOTO2179
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      DO2175I=1,IMAX
      WRITE(ICOUT,2176)I,PCHAWI(I)
 2176 FORMAT('THE WIDTH FOR CHARACTER ',I6,' HAS JUST BEEN SET TO ',
     1E15.7)
      CALL DPWRST('XXX','BUG ')
 2175 CONTINUE
 2179 CONTINUE
      GOTO2180
C
 2180 CONTINUE
      IFOUND='YES'
      GOTO2190
C
 2190 CONTINUE
      IFOUND='YES'
      DO2191I=1,MAXCHA
      PCHAHG(I)=PCHAWI(I)*0.25
 2191 CONTINUE
C
 2199 CONTINUE
      RETURN
      END
      SUBROUTINE DPCMAP(IHARG,NUMARG,IDCMAP,ICHMAP,IFOUND,IERROR)
C
C     PURPOSE--DEFINE PLOT CHARACTER MAPPING
C              (BY RANK    OR    BY EXACT)
C              WHICH LINKS TRACE ID AND CHARACTER
C              (THE CURRENT DEFAULT IS BY RANK).
C     EXAMPLE--IF HAVE DATA: X: 1 1 2 2 3 3
C                            Y: 1 2 3 4 5 6
C                          TAG: 1 1 3 3 5 5
C              AND CHARACTERS 1 2 3 4 5
C              AND DESIRE TO HAVE THE TRACES SHOW 1 3 AND 5
C              THEN CURRENTLY BY DEFAULT WOULD GET
C              TRACES SHOWING 1 2 3 (SINCE MAP VIA RANK)
C              BUT IF ENTER      CHARACTER MAP EXACT
C              THEN WOULD GET TRACES SHOWING 1 3 5 (AS DESIRED)
C     COMMAND EXAMPLE--CHARACTER MAP RANK (= DEFAULT)
C                      CHARACTER MAP EXACT
C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
C                     --NUMARG
C                     --IDCMAP
C     OUTPUT ARGUMENTS--ICHMAP  (A  CHARACTER VARIABLE
C                       WHICH DEFINES THE MAP
C                       (RANK OR EXAC)
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--94/12
C     ORIGINAL VERSION--DECEMBER  1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IDCMAP
      CHARACTER*4 ICHMAP
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IFOUND='NO'
      IERROR='NO'
C
      IF(NUMARG.EQ.1)THEN
         ICHMAP=IDCMAP
         GOTO1150
      ENDIF
C
      IF(NUMARG.GE.2)THEN
         IF(IHARG(NUMARG).EQ.'ON'.OR.
     1   IHARG(NUMARG).EQ.'OFF'.OR.
     1   IHARG(NUMARG).EQ.'AUTO'.OR.
     1   IHARG(NUMARG).EQ.'DEFA')THEN
            ICHMAP=IDCMAP
            GOTO1150
         ELSE IF(IHARG(NUMARG).EQ.'EXAC'.OR.
     1   IHARG(NUMARG).EQ.'1TO1')THEN
            ICHMAP='EXAC'
            GOTO1150
         ELSE IF(IHARG(NUMARG).EQ.'?')THEN
            GOTO1160
         ELSE
            ICHMAP=IHARG(2)
            GOTO1150
         ENDIF
      ENDIF
C
 1150 CONTINUE
      IF(IFEEDB.EQ.'ON')THEN
         WRITE(ICOUT,999)
  999    FORMAT(1X)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1151)ICHMAP
 1151    FORMAT('THE CHARACTER MAPPING HAS JUST BEEN SET TO ',
     1   A4)
         CALL DPWRST('XXX','BUG ')
      ENDIF
      IFOUND='YES'
      GOTO9000
C
 1160 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1161)
 1161 FORMAT('CHARACTER MAPPING HAS 2 POSSIBLE SETTINGS:')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1162)
 1162 FORMAT('   RANK   AND   EXACT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1163)ICHMAP
 1163 FORMAT('THE CURRENT CHARACTER MAPPING IS    ',A4)
      CALL DPWRST('XXX','BUG ')
      IFOUND='YES'
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE DPCONC(IHARG,NUMARG,
     1IDEFCC,
     1ICONCH,
     1IBUGS2,IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE CONTINUE CHARACTOR WHICH MAY
C              BE USED TO CONTINUE A COMMAND TO A SECOND
C              LINE (NO MORE THAN 2 LINES ALLOWED)
C              ABOUT THE ONLY PLACE THIS IS NECCESSARY
C              IN DATAPLOT IS IN ENTERING TITLES, ESPECIALLY
C              IF MANY SHIFTS ARE INCLUDED FOR UPPER, LOWER CASE
C              AND SPECIAL SYMBOLS
C
C              THE CONTINUE CHARACTER CAN BE UP TO 4 CHARACTERS LONG
C
C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
C                     --NUMARG (AN INTEGER VARIABLE)
C                     --IDEFCC (A  CHARACTER VARIABLE)
C                     --IBUGS2 (A  CHARACTER VARIABLE)
C     OUTPUT ARGUMENTS--ICONCH (A CHARACTER VARIABLE)
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--ALAN HECKERT
C                 COMPUTER SERVICES DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER 1980.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IDEFCC
      CHARACTER*4 ICONCH
      CHARACTER*4 IBUGS2
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IHOLD
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGS2.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPCONC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IDEFCC
   53 FORMAT('IDEFCC = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)NUMARG
   54 FORMAT('NUMARG = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NUMARG
      WRITE(ICOUT,56)I,IHARG(I)
   56 FORMAT('I,IHARG(I) = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
      IFOUND='NO'
      IERROR='NO'
C
      IF(NUMARG.LE.0)GOTO1150
      GOTO1110
C
 1110 CONTINUE
      IF(NUMARG.LE.1)GOTO1150
      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
      GOTO1160
C
 1150 CONTINUE
      IHOLD=IDEFCC
      GOTO1180
C
 1160 CONTINUE
      IHOLD=IHARG(NUMARG)
      GOTO1180
C
 1180 CONTINUE
      IFOUND='YES'
      ICONCH=IHOLD
C
      IF(IFEEDB.EQ.'OFF')GOTO1189
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)ICONCH
 1181 FORMAT('THE CONTINUE CHARACTER HAS JUST BEEN SET TO ',
     1A4)
      CALL DPWRST('XXX','BUG ')
 1189 CONTINUE
      GOTO9000
C
 9000 CONTINUE
      IF(IBUGS2.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPCONC-')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGS2,IFOUND,IERROR
 9012 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IDEFCC,ICONCH
 9013 FORMAT('IDEFCC,ICONCH = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END