SUBROUTINE DPPLO1(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1MAXNPP, 1IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--FORM A Y PLOT, A Y VERSUS X PLOT, A SUBSET PLOT, C AND OTHER SIMILAR TYPE PLOTS C WHEN HAVE NO VERSUS AND NO EQUALS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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 --JANUARY 1978. C UPDATED --FEBRUARY 1978. C UPDATED --MAY 1978. C UPDATED --JUNE 1978. C UPDATED --JULY 1978. C UPDATED --NOVEMBER 1978. C UPDATED --FEBRUARY 1979. C UPDATED --MARCH 1979. C UPDATED --JULY 1979. C UPDATED --JANUARY 1981. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 1988. FIX PLOT Y FOR ... WHEN I OUT OF BOUNDS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IHVERT CHARACTER*4 IHVER2 CHARACTER*4 IHHOR CHARACTER*4 IHHOR2 CHARACTER*4 IHSET CHARACTER*4 IHSET2 CHARACTER*4 IERRO4 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.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 ISUBN1='DPPL' ISUBN2='O1 ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C NUMAR1=0 C D2MIN=0.0 DEL=0.0 C C ******************************** C ** STEP 10-- ** C ** TREAT THE CASE WHEN HAVE ** C ** NO VERSUS AND ** C ** NO FOR X = ** C ******************************** C 1000 CONTINUE 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 DPPLO1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPLOTV,NPLOTP,NS 52 FORMAT('NPLOTV,NPLOTP,NS = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGG3,IBUGQ 54 FORMAT('IBUGG3,IBUGQ = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IFOUND,IERROR 55 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)MAXNPP 56 FORMAT('MAXNPP = ',I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C ISTEPN='10' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ******************************************** C ** STEP 11-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE VERTICAL VARIABLE) ** C ******************************************** C ISTEPN='11' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHVERT=IHARG(1) IHVER2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHVERT,IHVER2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IVAV=IVALUE(ILOCV) NLOCAL=IN(ILOCV) C IF(IBUGG3.EQ.'ON')WRITE(ICOUT,1107)IHVERT,IHVER2,ILOCV,IERROR, 1IVAV,NLOCAL 1107 FORMAT('IHVERT,IHVER2,ILOCV,IERROR,IVAV,NLOCAL = ', 1A4,A4,2X,I8,2X,A4,I8,I8) IF(IBUGG3.EQ.'ON')CALL DPWRST('XXX','BUG ') C C ***************************************** C ** STEP 12-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='12' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO1290 DO1200J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO1210 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO1210 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO1220 1200 CONTINUE GOTO1290 1210 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO1290 1220 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO1290 1290 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO1295 WRITE(ICOUT,1291)NUMARG,ILOCQ 1291 FORMAT('NUMARG,ILOCQ = ',12I8) CALL DPWRST('XXX','BUG ') 1295 CONTINUE C C ********************************************* C ** STEP 13-- ** C ** FORM THE VECTOR ISUB(.) ** C ** DEPENDING ON THE TYPE OF CASE ** C ** FOR THE QUALIFIER. ** C ********************************************* C ISTEPN='13' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO1310 IF(ICASEQ.EQ.'SUBS')GOTO1320 IF(ICASEQ.EQ.'FOR')GOTO1330 C 1310 CONTINUE DO1315I=1,NLOCAL ISUB(I)=1 1315 CONTINUE NQ=NLOCAL GOTO1350 C 1320 CONTINUE NIOLD=NLOCAL CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4) NQ=NIOLD GOTO1350 C 1330 CONTINUE NIOLD=NLOCAL CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERRO4) NQ=NFOR CCCCC THE FOLLOWING LINE WAS INSERTED MARCH 1988 IF(NS.GT.NIOLD)NS=NIOLD GOTO1350 C 1350 CONTINUE C C ********************************************************** C ** STEP 14-- ** C ** BRANCH ACCORDING TO THE NUMBER OF ARGUMENTS BEFORE ** C ** 'SUBS', 'FOR', AND 'AND'. ** C ********************************************************** C ISTEPN='14' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ILOCA=NUMARG+1 IF(IHARG(NUMARG).EQ.'AND')ILOCA=NUMARG IF(ILOCA.LT.ILOCQ)NUMAR1=ILOCA-1 IF(ILOCQ.LT.ILOCA)NUMAR1=ILOCQ-1 IF(ILOCA.EQ.ILOCQ)NUMAR1=NUMARG IF(NUMAR1.EQ.1)GOTO1500 IF(NUMAR1.EQ.2)GOTO1600 IF(NUMAR1.EQ.3)GOTO1700 WRITE(ICOUT,1401) 1401 FORMAT('***** ERROR IN DPPLO1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1402) 1402 FORMAT(' NUMAR1 NOT = 1, 2, OR 3. ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1403)NUMAR1 1403 FORMAT(' NUMAR1 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1404)NUMARG,IHARG(NUMARG),ILOCA,ILOCQ 1404 FORMAT(' NUMARG,IHARG(NUMARG),ILOCA,ILOCQ = ', 1I6,2X,A4,2I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1408) 1408 FORMAT(' THE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1409)(IANS(I),I=1,IWIDTH) 1409 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C C ************************************************************* C ** STEP 15-- ** C ** TREAT THE 1 VARIABLE CASE (WITH NO VS AND NO =) CASE. ** C ************************************************************* C 1500 CONTINUE ISTEPN='15' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C **************************************** C ** STEP 15.1-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C **************************************** C ISTEPN='15.1' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHVERT=IHARG(1) IHVER2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHVERT,IHVER2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IVAV=IVALUE(ILOC) C C ************************************************************* C ** STEP 15.2-- ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR THE PLOT. ** C ** RESET THE D(.) VECTOR TO ONES. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ************************************************************* C ISTEPN='15.2' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IAND1.EQ.'NO')GOTO1519 IF(NPLOTP.LE.0)GOTO1519 D1MAX=D(1) DO1510I=1,NPLOTP IF(D(I).GT.D1MAX)D1MAX=D(I) 1510 CONTINUE D2MIN=1.0 IF(IAND1.EQ.'YES')DEL=D1MAX-D2MIN+1.0 1519 CONTINUE C L=NPLOTP C DO1520I=1,NLOCAL IF(ISUB(I).EQ.0)GOTO1520 L=L+1 C IF(L.LE.MAXNPP)GOTO1529 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1521) 1521 FORMAT('***** ERROR IN DPPLO1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1523) 1523 FORMAT(' THE NUMBER OF PLOT POINTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1524)MAXNPP 1524 FORMAT(' HAS JUST EXCEEDED ',I8,' *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1525)I,NLOCAL,L,MAXN,MAXNPP,NPLOTP 1525 FORMAT('I,NLOCAL,L,MAXN,MAXNPP,NPLOTP = ',6I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1526)IAND1,IAND2,IFOUND,IERROR 1526 FORMAT('IAND1,IAND2,IFOUND,IERROR = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') GOTO9000 1529 CONTINUE C IJ=MAXN*(IVAV-1)+I IF(IVAV.LE.MAXCOL)Y(L)=V(IJ) IF(IVAV.EQ.MAXCP1)Y(L)=PRED(I) IF(IVAV.EQ.MAXCP2)Y(L)=RES(I) IF(IVAV.EQ.MAXCP3)Y(L)=YPLOT(I) IF(IVAV.EQ.MAXCP4)Y(L)=XPLOT(I) IF(IVAV.EQ.MAXCP5)Y(L)=X2PLOT(I) IF(IVAV.EQ.MAXCP6)Y(L)=TAGPLO(I) X(L)=L IF(IAND1.EQ.'NO')D(L)=1.0 IF(IAND1.EQ.'YES')D(L)=1.0+DEL 1520 CONTINUE NPLOTP=L NPLOTV=1 IF(IAND1.EQ.'YES'.AND.NPLOTV.GT.1)NPLOTV=NPLOTV GOTO9000 C C ************************************************************* C ** STEP 16-- ** C ** TREAT THE 2 VARIABLE CASE (WITH NO VS AND NO =) CASE. ** C ************************************************************* C 1600 CONTINUE ISTEPN='16' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C **************************************** C ** STEP 16.1-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C **************************************** C ISTEPN='16.1' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHVERT=IHARG(1) IHVER2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHVERT,IHVER2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IVAV=IVALUE(ILOCV) C C **************************************** C ** STEP 16.2-- ** C ** CHECK THE VALIDITY OF ARGUMENT 2 ** C **************************************** C ISTEPN='16.2' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C 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,ILOCH,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHAV=IVALUE(ILOCH) C C ************************************************************* C ** STEP 16.3-- ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR THE PLOT. ** C ** RESET THE D(.) VECTOR TO ONES. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ************************************************************* C ISTEPN='16.3' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IAND1.EQ.'NO')GOTO1619 IF(NPLOTP.LE.0)GOTO1619 D1MAX=D(1) DO1610I=1,NPLOTP IF(D(I).GT.D1MAX)D1MAX=D(I) 1610 CONTINUE D2MIN=1.0 IF(IAND1.EQ.'YES')DEL=D1MAX-D2MIN+1.0 1619 CONTINUE C L=NPLOTP C NLOCAL=IN(ILOCV) DO1620I=1,NLOCAL IF(ISUB(I).EQ.0)GOTO1620 L=L+1 C IF(L.LE.MAXNPP)GOTO1629 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1621) 1621 FORMAT('***** ERROR IN DPPLO1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1623) 1623 FORMAT(' THE NUMBER OF PLOT POINTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1624)MAXNPP 1624 FORMAT(' HAS JUST EXCEEDED ',I8,' *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1625)I,NLOCAL,L,MAXN,MAXNPP,NPLOTP 1625 FORMAT('I,NLOCAL,L,MAXN,MAXNPP,NPLOTP = ',6I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1626)IAND1,IAND2,IFOUND,IERROR 1626 FORMAT('IAND1,IAND2,IFOUND,IERROR = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') GOTO9000 1629 CONTINUE C IJ=MAXN*(IVAV-1)+I IF(IVAV.LE.MAXCOL)Y(L)=V(IJ) IF(IVAV.EQ.MAXCP1)Y(L)=PRED(I) IF(IVAV.EQ.MAXCP2)Y(L)=RES(I) IF(IVAV.EQ.MAXCP3)Y(L)=YPLOT(I) IF(IVAV.EQ.MAXCP4)Y(L)=XPLOT(I) IF(IVAV.EQ.MAXCP5)Y(L)=X2PLOT(I) IF(IVAV.EQ.MAXCP6)Y(L)=TAGPLO(I) IJ=MAXN*(IHAV-1)+I IF(IHAV.LE.MAXCOL)X(L)=V(IJ) IF(IHAV.EQ.MAXCP1)X(L)=PRED(I) IF(IHAV.EQ.MAXCP2)X(L)=RES(I) IF(IHAV.EQ.MAXCP3)X(L)=YPLOT(I) IF(IHAV.EQ.MAXCP4)X(L)=XPLOT(I) IF(IHAV.EQ.MAXCP5)X(L)=X2PLOT(I) IF(IHAV.EQ.MAXCP6)X(L)=TAGPLO(I) IF(IAND1.EQ.'NO')D(L)=1.0 IF(IAND1.EQ.'YES')D(L)=1.0+DEL 1620 CONTINUE NPLOTP=L NPLOTV=2 IF(IAND1.EQ.'YES'.AND.NPLOTV.GT.2)NPLOTV=NPLOTV GOTO9000 C C ************************************************************* C ** STEP 17-- ** C ** TREAT THE 3 VARIABLE CASE (WITH NO VS AND NO =) CASE. ** C ************************************************************* C 1700 CONTINUE ISTEPN='17' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C **************************************** C ** STEP 17.1-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C **************************************** C ISTEPN='17.1' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHVERT=IHARG(1) IHVER2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHVERT,IHVER2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IVAV=IVALUE(ILOCV) C C **************************************** C ** STEP 17.2-- ** C ** CHECK THE VALIDITY OF ARGUMENT 2 ** C **************************************** C ISTEPN='17.2' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C 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,ILOCH,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHAV=IVALUE(ILOCH) C C **************************************** C ** STEP 17.3-- ** C ** CHECK THE VALIDITY OF ARGUMENT 3 ** C **************************************** C ISTEPN='17.3' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHSET=IHARG(3) IHSET2=IHARG2(3) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHSET,IHSET2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCD,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ISETV=IVALUE(ILOCD) C C ************************************************************* C ** STEP 17.4-- ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR THE PLOT. ** C ** RESET THE D(.) VECTOR TO ONES. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ************************************************************* C ISTEPN='17.4' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IAND1.EQ.'NO')GOTO1719 IF(NPLOTP.LE.0)GOTO1719 D1MAX=D(1) DO1710I=1,NPLOTP IF(D(I).GT.D1MAX)D1MAX=D(I) 1710 CONTINUE I=1 IJ=MAXN*(ISETV-1)+I IF(ISETV.LE.MAXCOL)D2MIN=V(IJ) IF(ISETV.EQ.MAXCP1)D2MIN=PRED(I) IF(ISETV.EQ.MAXCP2)D2MIN=RES(I) IF(ISETV.EQ.MAXCP3)D2MIN=YPLOT(I) IF(ISETV.EQ.MAXCP4)D2MIN=XPLOT(I) IF(ISETV.EQ.MAXCP5)D2MIN=X2PLOT(I) IF(ISETV.EQ.MAXCP6)D2MIN=TAGPLO(I) NLOCAL=IN(ILOCV) DO1711I=1,NLOCAL IJ=MAXN*(ISETV-1)+I IF(ISETV.LE.MAXCOL)GOTO1712 IF(ISETV.EQ.MAXCP1)GOTO1713 IF(ISETV.EQ.MAXCP2)GOTO1714 IF(ISETV.EQ.MAXCP3)GOTO1715 IF(ISETV.EQ.MAXCP4)GOTO1716 IF(ISETV.EQ.MAXCP5)GOTO1717 IF(ISETV.EQ.MAXCP6)GOTO1718 1712 CONTINUE IF(V(IJ).LT.D2MIN)D2MIN=V(IJ) GOTO1711 1713 CONTINUE IF(PRED(I).LT.D2MIN)D2MIN=PRED(I) GOTO1711 1714 CONTINUE IF(RES(I).LT.D2MIN)D2MIN=RES(I) GOTO1711 1715 CONTINUE IF(YPLOT(I).LT.D2MIN)D2MIN=YPLOT(I) GOTO1711 1716 CONTINUE IF(XPLOT(I).LT.D2MIN)D2MIN=XPLOT(I) GOTO1711 1717 CONTINUE IF(X2PLOT(I).LT.D2MIN)D2MIN=X2PLOT(I) GOTO1711 1718 CONTINUE IF(TAGPLO(I).LT.D2MIN)D2MIN=TAGPLO(I) GOTO1711 1711 CONTINUE IF(IAND1.EQ.'YES')DEL=D1MAX-D2MIN+1.0 1719 CONTINUE C L=NPLOTP C NLOCAL=IN(ILOCV) DO1720I=1,NLOCAL IF(ISUB(I).EQ.0)GOTO1720 L=L+1 C IF(L.LE.MAXNPP)GOTO1729 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1721) 1721 FORMAT('***** ERROR IN DPPLO1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1723) 1723 FORMAT(' THE NUMBER OF PLOT POINTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1724)MAXNPP 1724 FORMAT(' HAS JUST EXCEEDED ',I8,' *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1725)I,NLOCAL,L,MAXN,MAXNPP,NPLOTP 1725 FORMAT('I,NLOCAL,L,MAXN,MAXNPP,NPLOTP = ',6I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1726)IAND1,IAND2,IFOUND,IERROR 1726 FORMAT('IAND1,IAND2,IFOUND,IERROR = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') GOTO9000 1729 CONTINUE C IJ=MAXN*(IVAV-1)+I IF(IVAV.LE.MAXCOL)Y(L)=V(IJ) IF(IVAV.EQ.MAXCP1)Y(L)=PRED(I) IF(IVAV.EQ.MAXCP2)Y(L)=RES(I) IF(IVAV.EQ.MAXCP3)Y(L)=YPLOT(I) IF(IVAV.EQ.MAXCP4)Y(L)=XPLOT(I) IF(IVAV.EQ.MAXCP5)Y(L)=X2PLOT(I) IF(IVAV.EQ.MAXCP6)Y(L)=TAGPLO(I) IJ=MAXN*(IHAV-1)+I IF(IHAV.LE.MAXCOL)X(L)=V(IJ) IF(IHAV.EQ.MAXCP1)X(L)=PRED(I) IF(IHAV.EQ.MAXCP2)X(L)=RES(I) IF(IHAV.EQ.MAXCP3)X(L)=YPLOT(I) IF(IHAV.EQ.MAXCP4)X(L)=XPLOT(I) IF(IHAV.EQ.MAXCP5)X(L)=X2PLOT(I) IF(IHAV.EQ.MAXCP6)X(L)=TAGPLO(I) IJ=MAXN*(ISETV-1)+I IF(IAND1.EQ.'NO'.AND.ISETV.LE.MAXCOL)D(L)=V(IJ) IF(IAND1.EQ.'NO'.AND.ISETV.EQ.MAXCP1)D(L)=PRED(I) IF(IAND1.EQ.'NO'.AND.ISETV.EQ.MAXCP2)D(L)=RES(I) IF(IAND1.EQ.'NO'.AND.ISETV.EQ.MAXCP3)D(L)=YPLOT(I) IF(IAND1.EQ.'NO'.AND.ISETV.EQ.MAXCP4)D(L)=XPLOT(I) IF(IAND1.EQ.'NO'.AND.ISETV.EQ.MAXCP5)D(L)=X2PLOT(I) IF(IAND1.EQ.'NO'.AND.ISETV.EQ.MAXCP6)D(L)=TAGPLO(I) IF(IAND1.EQ.'YES'.AND.ISETV.LE.MAXCOL)D(L)=V(IJ)+DEL IF(IAND1.EQ.'YES'.AND.ISETV.EQ.MAXCP1)D(L)=PRED(I)+DEL IF(IAND1.EQ.'YES'.AND.ISETV.EQ.MAXCP2)D(L)=RES(I)+DEL IF(IAND1.EQ.'YES'.AND.ISETV.EQ.MAXCP3)D(L)=YPLOT(I)+DEL IF(IAND1.EQ.'YES'.AND.ISETV.EQ.MAXCP4)D(L)=XPLOT(I)+DEL IF(IAND1.EQ.'YES'.AND.ISETV.EQ.MAXCP5)D(L)=X2PLOT(I)+DEL IF(IAND1.EQ.'YES'.AND.ISETV.EQ.MAXCP6)D(L)=TAGPLO(I)+DEL 1720 CONTINUE NPLOTP=L NPLOTV=3 IF(IAND1.EQ.'YES'.AND.NPLOTV.GT.3)NPLOTV=NPLOTV GOTO9000 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 DPPLO1--') 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)IBUGG3,IBUGQ 9014 FORMAT('IBUGG3,IBUGQ = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IFOUND,IERROR 9015 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)MAXNPP 9016 FORMAT('MAXNPP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020) 9020 FORMAT('I,Y(.),X(.),D(.),ISUB(.)--') CALL DPWRST('XXX','BUG ') DO9021I=1,NPLOTP WRITE(ICOUT,9022)I,Y(I),X(I),D(I),ISUB(I) 9022 FORMAT(I8,F15.7,F15.7,F15.7,I8) CALL DPWRST('XXX','BUG ') 9021 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPLO2(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IVSLOC,NUMVS, 1MAXNPP, 1IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--FORM A Y PLOT, A Y VERSUS X PLOT, A SUBSET PLOT, C AND OTHER SIMILAR TYPE PLOTS C WHEN HAVE 1 OR MORE VERSUS ENTERED. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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 --JANUARY 1978. C UPDATED --FEBRUARY 1978. C UPDATED --MAY 1978. C UPDATED --JUNE 1978. C UPDATED --JULY 1978. C UPDATED --NOVEMBER 1978. C UPDATED --FEBRUARY 1979. C UPDATED --MARCH 1979. C UPDATED --JULY 1979. C UPDATED --JANUARY 1981. C UPDATED --AUGUST 1981. C UPDATED --OCTOBER 1981. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 1988. FIX PLOT Y X FOR .. WHEN I OUT OF BOUNDS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ICASEQ CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 IHVERT CHARACTER*4 IHVER2 CHARACTER*4 IHHOR CHARACTER*4 IHHOR2 CHARACTER*4 IERRO4 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION IVSLOC(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.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 ISUBN1='DPPL' ISUBN2='O2 ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C CCCCC MAXNPP=1000 C KSTART=0 C DEL=0.0 C C *********************************************************** C ** STEP 20-- ** C ** TREAT THE CASE WHEN HAVE 1 OR MORE 'VERSUS' ENTERED ** C *********************************************************** C 2000 CONTINUE 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 DPPLO2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPLOTV,NPLOTP,NS 52 FORMAT('NPLOTV,NPLOTP,NS = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGG3,IBUGQ 54 FORMAT('IBUGG3,IBUGQ = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IFOUND,IERROR 55 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)MAXNPP 56 FORMAT('MAXNPP = ',I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C ISTEPN='20' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ***************************************** C ** STEP 21-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='21' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO2190 DO2100J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO2110 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO2110 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO2120 2100 CONTINUE GOTO2190 2110 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO2190 2120 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO2190 2190 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO2195 WRITE(ICOUT,2191)NUMARG,ILOCQ 2191 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 2195 CONTINUE C C ********************************** C ** STEP 22-- ** C ** DETERMINE WHICH VARIABLES ** C ** ARE TO BE GROUPED TOGETHER ** C ********************************** C ISTEPN='22' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C L=NPLOTP C NEWSET=0 DO2200J=1,NUMVS JM1=J-1 IF(J.EQ.1)KSTART=1 IF(J.GE.2)KSTART=IVSLOC(JM1)+2 KSTOP=IVSLOC(J)-1 IVS=IVSLOC(J) C IVSP1=IVS+1 DO2210K=KSTART,KSTOP NEWSET=NEWSET+1 C IHVERT=IHARG(K) IHVER2=IHARG2(K) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHVERT,IHVER2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IVAV=IVALUE(ILOCV) NLOCAL=IN(ILOCV) C IHHOR=IHARG(IVSP1) IHHOR2=IHARG2(IVSP1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHHOR,IHHOR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCH,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHAV=IVALUE(ILOCH) C ISETV=NEWSET C IF(IAND1.EQ.'NO')GOTO2280 IF(NPLOTP.LE.0)GOTO2280 D1MAX=D(1) DO2220I=1,NPLOTP IF(D(I).GT.D1MAX)D1MAX=D(I) 2220 CONTINUE D2MIN=1.0 IF(IAND1.EQ.'YES')DEL=D1MAX-D2MIN+1.0 2280 CONTINUE C IF(IBUGG3.EQ.'ON')WRITE(ICOUT,2282)IHVERT,ILOCV,IERROR,IVAV,NLOCAL 2282 FORMAT('IHVERT,ILOCV,IERROR,IVAV,NLOCAL = ', 1A4,2X,I8,2X,A4,2X,A4,2X,I8) IF(IBUGG3.EQ.'ON')CALL DPWRST('XXX','BUG ') C C ********************************************* C ** STEP 23-- ** C ** FORM THE VECTOR ISUB(.) ** C ** DEPENDING ON THE TYPE OF CASE ** C ** FOR THE QUALIFIER. ** C ** BRANCH TO THE PROPER CASE. ** C ********************************************* C ISTEPN='23' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO2310 IF(ICASEQ.EQ.'SUBS')GOTO2320 IF(ICASEQ.EQ.'FOR')GOTO2330 CCCCC IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO2320 CCCCC IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO2320 CCCCC IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO2330 C 2310 CONTINUE DO2315I=1,NLOCAL ISUB(I)=1 2315 CONTINUE NQ=NLOCAL GOTO2350 C 2320 CONTINUE NIOLD=NLOCAL CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4) NQ=NIOLD GOTO2350 C 2330 CONTINUE NIOLD=NLOCAL CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERRO4) NQ=NFOR CCCCC THE FOLLOWING LINE WAS INSERTED MARCH 1988 IF(NS.GT.NIOLD)NS=NIOLD GOTO2350 C 2350 CONTINUE C DO2360I=1,NLOCAL IF(ISUB(I).EQ.0)GOTO2360 L=L+1 C IF(L.LE.MAXNPP)GOTO2369 WRITE(ICOUT,2362) 2362 FORMAT('***** PLOT FORMATION ERROR IN DPPLO2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2363) 2363 FORMAT(' THE NUMBER OF PLOT POINTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2364)MAXNPP 2364 FORMAT(' HAS JUST EXCEEDED ',I8,' *****') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2369 CONTINUE C IJ=MAXN*(IVAV-1)+I IF(IVAV.LE.MAXCOL)Y(L)=V(IJ) IF(IVAV.EQ.MAXCP1)Y(L)=PRED(I) IF(IVAV.EQ.MAXCP2)Y(L)=RES(I) IF(IVAV.EQ.MAXCP3)Y(L)=YPLOT(I) IF(IVAV.EQ.MAXCP4)Y(L)=XPLOT(I) IF(IVAV.EQ.MAXCP5)Y(L)=X2PLOT(I) IF(IVAV.EQ.MAXCP6)Y(L)=TAGPLO(I) IJ=MAXN*(IHAV-1)+I IF(IHAV.LE.MAXCOL)X(L)=V(IJ) IF(IHAV.EQ.MAXCP1)X(L)=PRED(I) IF(IHAV.EQ.MAXCP2)X(L)=RES(I) IF(IHAV.EQ.MAXCP3)Y(L)=YPLOT(I) IF(IHAV.EQ.MAXCP4)Y(L)=XPLOT(I) IF(IHAV.EQ.MAXCP5)Y(L)=X2PLOT(I) IF(IHAV.EQ.MAXCP6)Y(L)=TAGPLO(I) IF(IAND1.EQ.'NO')D(L)=ISETV IF(IAND1.EQ.'YES')D(L)=ISETV+DEL 2360 CONTINUE 2210 CONTINUE 2200 CONTINUE NPLOTP=L C DHOLD=D(1) DO2370I=1,NPLOTP IF(D(I).NE.DHOLD)GOTO2375 2370 CONTINUE NPLOTV=2 GOTO2399 2375 CONTINUE NPLOTV=3 GOTO2399 C 2399 CONTINUE 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 DPPLO2--') 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)IBUGG3,IBUGQ 9014 FORMAT('IBUGG3,IBUGQ = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IFOUND,IERROR 9015 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)MAXNPP 9016 FORMAT('MAXNPP = ',I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPPLO3(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1PARAM,IPARN,IPARN2,NUMPAR,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD, 1IFOLOC, 1MAXNPP, 1IANGLU,IBUGG3,IBUGCO,IBUGEV,IBUGQ,IFOUND,IERROR) C C PURPOSE--FORM A PLOT OF A FUNCTION C WHEN HAVE 1 OR MORE = ENTERED, C THAT IS, WHEN HAVE PLOT Y = ... FOR X = ... C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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 --JANUARY 1978. C UPDATED --FEBRUARY 1978. C UPDATED --MAY 1978. C UPDATED --JUNE 1978. C UPDATED --JULY 1978. C UPDATED --NOVEMBER 1978. C UPDATED --FEBRUARY 1979. C UPDATED --MARCH 1979. C UPDATED --JULY 1979. C UPDATED --JANUARY 1981. C UPDATED --FEBRUARY 1981. C UPDATED --AUGUST 1981. C UPDATED --OCTOBER 1981. C UPDATED --DECEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --APRIL 1992. FIX PLOT CONSTANT C UPDATED --MAY 1994. SUPPRESS MESSAGE FOR POINT PLOT C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IPARN CHARACTER*4 IPARN2 CHARACTER*4 ITYPEH CHARACTER*4 IW2HOL CHARACTER*4 IW22HO CHARACTER*4 IANGLU CHARACTER*4 IBUGG3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 IWD1 CHARACTER*4 IWD12 CHARACTER*4 IWD2 CHARACTER*4 IWD22 CHARACTER*4 IVERTI CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IHPARN CHARACTER*4 IHPAR2 CHARACTER*4 IVDU11 CHARACTER*4 IVDU12 CCCCC CHARACTER*4 IA C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION PARAM(*) DIMENSION IPARN(*) DIMENSION IPARN2(*) C DIMENSION ITYPEH(*) DIMENSION IW2HOL(*) DIMENSION IW22HO(*) DIMENSION W2HOLD(*) C DIMENSION IFOLOC(*) C CCCCC DIMENSION IA(132) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.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 ISUBN1='DPPL' ISUBN2='O3 ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 C CCCCC MAXNPP=1000 C LOCDU1=0 I2=0 C DEL=0.0 C NUMIT=1 C C ************************************************************** C ** TREAT THE CASE WHEN HAVE 1 OR MORE '=' ENTERED C ** THAT IS, TREAT THE PLOT Y = ... FOR X = ... CASE C ************************************************************** C 3000 CONTINUE 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 DPPLO3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPLOTV,NPLOTP,NS,MAXNPP 52 FORMAT('NPLOTV,NPLOTP,NS,MAXNPP = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IANGLU,IBUGG3,IBUGCO,IBUGEV,IBUGQ 54 FORMAT('IANGLU,IBUGG3,IBUGCO,IBUGEV,IBUGQ = ', 1A4,2X,A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IFOUND,IERROR 55 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************************* C ** STEP 2-- ** C ** DETERMINE THE MAX TRACE DESIGNATION ** C ** (A NUMBER) AS CONTAINED ** C ** IN THE VECTOR D(.). ** C ******************************************* C ISTEPN='2' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IAND1.EQ.'NO')GOTO119 IF(NPLOTP.LE.0)GOTO119 D1MAX=D(1) DO110I=1,NPLOTP IF(D(I).GT.D1MAX)D1MAX=D(I) 110 CONTINUE D2MIN=1.0 IF(IAND1.EQ.'YES')DEL=D1MAX-D2MIN+1.0 119 CONTINUE C C ************************************************ C ** STEP 3-- ** C ** DETERMINE THE NAME OF THE DUMMY VARIABLE ** C ** (IT NEVER GETS STORED PERMANENTLY) ** C ** IMMEDIATELY FOLLOWING 'FOR'. ** C ************************************************ C ISTEPN='3' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO3100J=1,NUMARG J2=J IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO3110 3100 CONTINUE IBRAN=3101 WRITE(ICOUT,3101) 3101 FORMAT('***** ERROR IN DPPLO3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3102) 3102 FORMAT(' THE STRING FOR NOT FOUND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3103) 3103 FORMAT(' EVEN THOUGH THE STRING = WAS FOUND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3104) 3104 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3105)(IANS(I),I=1,IWIDTH) 3105 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 3110 CONTINUE IFOLP0=J2 C IF(IFOLP0.LT.NUMARG)GOTO3190 WRITE(ICOUT,3121) 3121 FORMAT('***** ERROR IN DPPLO3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3122) 3122 FORMAT(' THE WORD FOR WAS THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3123) 3123 FORMAT(' FINAL WORD ON THE COMMAND LINE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3124) 3124 FORMAT(' THE WORD FOR SHOULD HAVE BEEN FOLLOWED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3125) 3125 FORMAT(' BY 5 WORDS --') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3126) 3126 FORMAT(' 1) A DUMMY VARIABLE NAME;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3127) 3127 FORMAT(' 2) AN EQUAL SIGN;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3128) 3128 FORMAT(' 3) ONE LIMIT (LOWER OR UPPER) ', 1'FOR THE DUMMY VARIABLE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3129) 3129 FORMAT(' 4) THE INCREMENT FOR THE DUMMY VARIABLE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3130) 3130 FORMAT(' 5) THE OTHER LIMIT (UPPER OR LOWER) ', 1'FOR THE DUMMY VARIABLE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3131) 3131 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3132)(IANS(I),I=1,IWIDTH) 3132 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 3190 CONTINUE IFOLP1=IFOLP0+1 IVDU11=IHARG(IFOLP1) IVDU12=IHARG2(IFOLP1) C C ******************************************* C ** STEP 4-- ** C ** EVALUATE THE FUNCTION OVER ** C ** THE VARIOUS POINTS IN THE INTERVAL. ** C ******************************************* C ISTEPN='4' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMAM1=NUMARG-1 NUMAM2=NUMARG-2 NUMAM3=NUMARG-3 C 3210 CONTINUE ILOCA=NUMAM2 IF(IHARG(NUMARG).EQ.'AND '.AND.IHARG2(NUMARG).EQ.' ') 1ILOCA=NUMAM3 IF(IARGT(ILOCA).EQ.'NUMB')GOTO3211 IF(IARGT(ILOCA).EQ.'WORD')GOTO3212 GOTO3270 3211 CONTINUE START=ARG(ILOCA) GOTO3220 3212 CONTINUE IH=IHARG(ILOCA) IH2=IHARG2(ILOCA) IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 START=VALUE(ILOC) GOTO3220 C 3220 CONTINUE ILOCA=NUMAM1 IF(IHARG(NUMARG).EQ.'AND '.AND.IHARG2(NUMARG).EQ.' ') 1ILOCA=NUMAM2 IF(IARGT(ILOCA).EQ.'NUMB')GOTO3221 IF(IARGT(ILOCA).EQ.'WORD')GOTO3222 GOTO3270 3221 CONTINUE AINC=ARG(ILOCA) GOTO3230 3222 CONTINUE IH=IHARG(ILOCA) IH2=IHARG2(ILOCA) IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 AINC=VALUE(ILOC) GOTO3230 C 3230 CONTINUE ILOCA=NUMARG IF(IHARG(NUMARG).EQ.'AND '.AND.IHARG2(NUMARG).EQ.' ') 1ILOCA=NUMAM1 IF(IARGT(ILOCA).EQ.'NUMB')GOTO3231 IF(IARGT(ILOCA).EQ.'WORD')GOTO3232 GOTO3270 3231 CONTINUE STOP=ARG(ILOCA) GOTO3280 3232 CONTINUE IH=IHARG(ILOCA) IH2=IHARG2(ILOCA) IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 STOP=VALUE(ILOC) GOTO3280 C 3270 CONTINUE WRITE(ICOUT,3271) 3271 FORMAT('***** INTERNAL ERROR IN DPPLO3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3272) 3272 FORMAT(' AN ARGUMENT TYPE WHICH SHOULD BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3273) 3273 FORMAT(' EITHER A NUMBER OR A WORD, IS NEITHER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3274)IHARG(ILOCA),IHARG2(ILOCA) 3274 FORMAT(' ARGUMENT = ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3275)ILOCA 3275 FORMAT(' LOCATION IN ARGUMENT LIST = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3276)IARGT(ILOCA) 3276 FORMAT(' ARGUMENT TYPE = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3277) 3277 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3278)(IANS(I),I=1,IWIDTH) 3278 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3280 CONTINUE C CCCCC THE OUTPUT MESSAGE IN THE FOLLOWING SECTION WAS MAY 1994 CCCCC COMMENTED OUT BECAUSE IT WAS GETTING IN THE WAY MAY 1994 CCCCC WHEN PLOTTING AN INDIVIDUAL POINT MAY 1994 C IF(START.NE.STOP.AND.AINC.NE.0.0)GOTO3870 CCCCC WRITE(ICOUT,3281) C3281 FORMAT('***** NOTE FROM DPPLO3--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3282) C3282 FORMAT(' THE LOWER AND UPPER LIMITS') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3283) C3283 FORMAT(' OF THE FUNCTION INTERVAL OF INTEREST') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3284) C3284 FORMAT(' ARE IDENTICAL; OR THE INCREMENT') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3285) C3285 FORMAT(' IS IDENTICALLY ZERO.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3286)START C3286 FORMAT(' FIRST LIMIT = ',D15.8) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3287)AINC C3287 FORMAT(' INCREMENT = ',D15.8) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3288)STOP C3288 FORMAT(' SECOND LIMIT = ',D15.8) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3289) C3289 FORMAT(' THE COMMAND LINE WAS AS FOLLOWS--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC IF(IWIDTH.GE.1)WRITE(ICOUT,3290)(IANS(I),I=1,IWIDTH) C3290 FORMAT(' ',100A1) CCCCC IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,3291) C3291 FORMAT(' RESULTING ACTION--ONLY A SINGLE POINT ', CCCCC1'WAS OUTPUTTED FOR PLOTTING.') CCCCC CALL DPWRST('XXX','BUG ') NUMIT=1 GOTO3880 3870 CONTINUE C C *****THE FOLLOWING CORRECTIVE LINE ADDED AUGUST 1983***** IF(START.EQ.STOP)AINC=0.0 IF(START.LT.STOP.AND.AINC.LT.0.0)AINC=-AINC IF(START.GT.STOP.AND.AINC.GT.0.0)AINC=-AINC C C *****THE FOLLOWING 2 CORRECTIVE LINES ADDED AUGUST 1983***** IF(AINC.EQ.0.0)NUMIT=1 IF(AINC.NE.0.0)NUMIT=(STOP-START)/AINC IF(NUMIT.LT.0)NUMIT=-NUMIT NUMIT=NUMIT+1 C 3880 CONTINUE C *********************************************************** C ** STEP 5-- ** C ** EXTRACT THE FUNCTIONAL ** C ** EXPRESSION FROM THE INPUT COMMAND LINE. ** C *********************************************************** C ISTEPN='5' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MAXN2=MAXCHF MAXN3=MAXCHF MAXN4=MAXCHF C IF(IHARG(2).EQ.'= '.AND.IHARG2(2).EQ.' ')IWD1='= ' IF(IHARG(2).EQ.'= '.AND.IHARG2(2).EQ.' ')IWD12=' ' IF(IHARG(2).NE.'= '.OR.IHARG2(2).NE.' ')IWD1='PLOT' IF(IHARG(2).NE.'= '.OR.IHARG2(2).NE.' ')IWD12=' ' IWD2='FOR' IWD22=' ' CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2, 1IFUNC2,N2F,IBUGG3,IFOUND,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(IFOUND.EQ.'YES')GOTO3379 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3371) 3371 FORMAT('***** ERROR IN DPPLO3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3372) 3372 FORMAT(' INVALID COMMAND FORM FOR FUNCTION PLOTTING.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3373) 3373 FORMAT(' GENERAL FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3374) 3374 FORMAT(' PLOT ... = ... ', 1'FOR ... = ... ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3375) 3375 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3376)(IANS(I),I=1,IWIDTH) 3376 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 3379 CONTINUE C C *********************************************************** C ** STEP 5.1-- ** C ** FIRST CHECK TO SEE IF HAVE THE VERTICAL LINES CASE; ** C ** THEN EXTRACT THE UNDERLYING FUNCTION FROM ** C ** FUNCTION DEFINITIONS. ** C *********************************************************** C ISTEPN='5.1' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IVERTI='NO' IVERT1=0 IVERT2=0 DO3380I=1,NUMARG IF(IHARG(I).EQ.'VERT'.AND.IHARG2(I).EQ.'ICAL')GOTO3385 3380 CONTINUE GOTO3399 3385 CONTINUE C CCCCC IMAX=N2F-12 NOVEMBER 1986 CCCCC IF(IMAX.LE.0)GOTO3389 NOVEMBER 1986 CCCCC DO3386I=1,IMAX NOVEMBER 1986 I=1 IP1=I+1 IP2=I+2 IP3=I+3 IP4=I+4 IP5=I+5 IP6=I+6 IP7=I+7 IF(IP7.GT.N2F)GOTO3389 IF(IFUNC2(I).NE.'V')GOTO3386 IF(IFUNC2(IP1).NE.'E')GOTO3386 IF(IFUNC2(IP2).NE.'R')GOTO3386 IF(IFUNC2(IP3).NE.'T')GOTO3386 IF(IFUNC2(IP4).NE.'I')GOTO3386 IF(IFUNC2(IP5).NE.'C')GOTO3386 IF(IFUNC2(IP6).NE.'A')GOTO3386 IF(IFUNC2(IP7).NE.'L')GOTO3386 IVERTI='YES' IVERT1=I IVERT2=IP7 IP8=I+8 IP9=I+9 IP10=I+10 IF(IP8.GT.N2F)GOTO3389 IF(IFUNC2(IP8).EQ.' ')IVERT2=IP8 IF(IP10.GT.N2F)GOTO3389 IF(IFUNC2(IP8).EQ.'L'.AND.IFUNC2(IP9).EQ.'Y'.AND. 1IFUNC2(IP10).EQ.' ')IVERT2=IP10 GOTO3389 3386 CONTINUE 3389 CONTINUE C IF(IVERTI.EQ.'NO')GOTO3399 IC=0 DO3391I=1,N2F IF(IVERT1.LE.I.AND.I.LE.IVERT2)GOTO3391 IC=IC+1 IFUNC2(IC)=IFUNC2(I) 3391 CONTINUE N2FOLD=N2F N2FNEW=IC C N2FNP1=N2FNEW+1 IF(N2FNP1.GT.N2FOLD)GOTO3393 DO3392IC=N2FNP1,N2FOLD IFUNC2(IC)=' ' 3392 CONTINUE 3393 CONTINUE N2F=N2FNEW 3399 CONTINUE C CALL DPEXFU(IFUNC2,N2F,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP, 1NUMNAM,IANS,IWIDTH,IFUNC,NUMCHF,MAXCHF,IFUNC3,N3F,MAXN3, 1IBUGG3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C CCCCC J=0 CCCCC DO3390I=1,N3F CCCCC J=J+1 CCCCC IA(J)=IFUNC3(I) C3390 CONTINUE CCCCC NUMCHA=J C C ********************************************************** C ** STEP 6-- ** C ** MAKE A NON-CALCULATING PASS AT THE FUNCTION ** C ** SO AS TO EXTRACT ALL PARAMETER AND VARIABLE NAMES. ** C ********************************************************** C ISTEPN='6' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C IPASS=1 CALL COMPIM(IFUNC3,N3F,IPASS,PARAM,IPARN,IPARN2,NUMPV, 1IANGLU,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,AJUNK, 1IBUGCO,IBUGEV,IERROR) IF(IBUGG3.EQ.'ON')WRITE(ICOUT,3411)NUMPV,IPARN(1),IPARN2(1), 1PARAM(1) 3411 FORMAT('NUMPV,IPARN(1),IPARN2(1),PARAM(1) = ', 1I8,2X,A4,2X,A4,E15.7) IF(IBUGG3.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(IERROR.EQ.'YES')GOTO9000 C C *********************************************** C ** STEP 7-- ** C ** CHECK THAT ALL PARAMETERS ** C ** IN THE FUNCTION ARE ALREADY PRESENT ** C ** IN THE AVAILABLE NAME LIST IHNAME(.). ** C ** ALSO CHECK THAT THE VARIABLE NAME ** C ** THAT FOLLOWS FOR (THAT IS, THE DUMMY VARIABLE) ** C ** IS IN THE FUNCTION. ** C *********************************************** C ISTEPN='7' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IP=0 IV=0 IF(NUMPV.LE.0)GOTO3650 DO3600J=1,NUMPV IHPARN=IPARN(J) IHPAR2=IPARN2(J) IF(IHPARN.EQ.IVDU11.AND.IHPAR2.EQ.IVDU12)GOTO3620 IHWUSE='P' MESSAG='YES' CALL CHECKN(IHPARN,IHPAR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C 3610 CONTINUE IP=IP+1 PARAM(J)=VALUE(ILOCP) GOTO3600 C 3620 CONTINUE IV=IV+1 LOCDU1=J 3600 CONTINUE 3650 CONTINUE CCCCC THE FOLLOWING 5 LINES WERE ADDED APRIL 1992 (JJF) IF(LOCDU1.LE.0)THEN IV=IV+1 NUMPV=NUMPV+1 LOCDU1=NUMPV ENDIF NUMPAR=IP NUMVAR=IV C C ****************************** C ** STEP 8-- ** C ** EVALUATE THE FUNCTION. ** C ****************************** C ISTEPN='8' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IPASS=2 L=NPLOTP L2=L DO3800I=1,NUMIT I2=I I2M1=I2-1 AI=I RESULT=START+(AI-1.0)*AINC C IF(I.EQ.1)GOTO3819 IF(START.LT.STOP.AND.RESULT.GT.STOP)GOTO3888 IF(START.GT.STOP.AND.RESULT.LT.STOP)GOTO3888 3819 CONTINUE L2=L2+1 CCCCC WRITE(ICOUT,3818)I,RESULT,L,L2,MAXNPP C3818 FORMAT('I,RESULT,L,L2,MAXNPP = ',I8,F15.7,3I8) CCCCC CALL DPWRST('XXX','BUG ') C IF(L2.LE.MAXNPP)GOTO3829 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3821) 3821 FORMAT('***** PLOT FORMATION ERROR IN DPPLO3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3822) 3822 FORMAT(' THE NUMBER OF PLOT POINTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3823)MAXNPP 3823 FORMAT(' HAS JUST EXCEEDED ',I8,' *****') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 3829 CONTINUE C XTEMP=RESULT C PARAM(LOCDU1)=XTEMP CALL COMPIM(IFUNC3,N3F,IPASS,PARAM,IPARN,IPARN2,NUMPV, 1IANGLU,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,YTEMP, 1IBUGCO,IBUGEV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IF(IVERTI.EQ.'NO')GOTO3839 HOLD=YTEMP YTEMP=XTEMP XTEMP=HOLD 3839 CONTINUE C Y(L2)=YTEMP X(L2)=XTEMP IF(IAND1.EQ.'NO')D(L2)=1.0 IF(IAND1.EQ.'YES')D(L2)=1.0+DEL 3800 CONTINUE N2=I2 GOTO3889 3888 CONTINUE N2=I2M1 3889 CONTINUE L=L2 NPLOTP=L C C ***************************** C ** STEP 9-- ** C ** DETERMINE THE NUMBER ** C ** OF PLOT VARIABLES. ** C ** STORE THIS IN NPLOTV. ** C ***************************** C ISTEPN='9' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DHOLD=D(1) DO3830I=1,NPLOTP IF(D(I).NE.DHOLD)GOTO3835 3830 CONTINUE NPLOTV=2 GOTO3890 3835 CONTINUE NPLOTV=3 GOTO3890 C 3890 CONTINUE GOTO9000 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 DPPLO3--') 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,MAXNPP,ICASPL,IAND1,IAND2 9013 FORMAT('NPLOTV,NPLOTP,NS,MAXNPP,ICASPL,IAND1,IAND2 = ', 14I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IANGLU,IBUGG3,IBUGCO,IBUGEV,IBUGQ 9014 FORMAT('IANGLU,IBUGG3,IBUGCO,IBUGEV,IBUGQ = ', 1A4,2X,A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IFOUND,IERROR 9015 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPPLOT(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IANGLU,MAXNPP, 1IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,IFOUND,IERROR) C C PURPOSE--FORM A Y PLOT, A Y VS. X PLOT, A SUBSET PLOT, C AND OTHER SIMILAR TYPE PLOTS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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 --JANUARY 1978. C UPDATED --FEBRUARY 1978. C UPDATED --MAY 1978. C UPDATED --JUNE 1978. C UPDATED --JULY 1978. C UPDATED --NOVEMBER 1978. C UPDATED --FEBRUARY 1979. C UPDATED --MARCH 1979. C UPDATED --JULY 1979. C UPDATED --JANUARY 1981. C UPDATED --MARCH 1981. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C UPDATED --APRIL 1992. FIX PLOT WITH NO ARGS 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 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ITYPEH CHARACTER*4 IW2HOL CHARACTER*4 IW22HO CHARACTER*4 IPARN CHARACTER*4 IPARN2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C C ***** THE FOLLOWING 4 DIMENSIONS RAISED FROM 150 TO 225 AUGUST 1983 ***** C ***** THE FOLLOWING 4 DIMENSIONS RAISED FROM 225 TO 1000 AUGUST 1986 ***** CCCCC DIMENSION ITYPEH(225) CCCCC DIMENSION IW2HOL(225) CCCCC DIMENSION IW22HO(225) CCCCC DIMENSION W2HOLD(225) DIMENSION ITYPEH(1000) DIMENSION IW2HOL(1000) DIMENSION IW22HO(1000) DIMENSION W2HOLD(1000) C DIMENSION PARAM(100) DIMENSION IPARN(100) DIMENSION IPARN2(100) C DIMENSION IVSLOC(100) DIMENSION IEQLOC(100) DIMENSION IFOLOC(100) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.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 IFOUND='NO' IERROR='NO' C ISUBN1='DPPL' ISUBN2='OT ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C C ***** THE FOLLOWING 6 LINES INSERTED AUGUST 1983 ***** CCCCC DO40I=1,225 DO40I=1,1000 ITYPEH(I)=' ' IW2HOL(I)=' ' IW22HO(I)=' ' W2HOLD(I)=0.0 40 CONTINUE C C *************************** C ** TREAT THE PLOT 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 DPPLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPLOTV,NPLOTP,NS 52 FORMAT('NPLOTV,NPLOTP,NS = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IANGLU,IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ 54 FORMAT('IANGLU,IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ = ', 1A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IFOUND,IERROR 55 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)MAXNPP 56 FORMAT('MAXNPP = ',I8) CALL DPWRST('XXX','BUG ') 90 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=0 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ******************************************* C ** STEP 2-- ** C ** DETERMINE IF HAD OR HAVE THE 'AND' ** C ** CONTINUATION CASE. ** C ** IF THE PREVIOUS PLOT COMMAND LINE ** C ** HAD AN 'AND' CONTINUATION, ** C ** OR IF THE PRESENT PLOT COMMAND LINE ** C ** HAS AN 'AND' CONTINUATION, ** C ** THEN SET SOME FLAG VARIABLES. ** C ******************************************* C ISTEPN='2' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IAND1.EQ.'NO')NPLOTV=0 IF(IAND1.EQ.'NO')NPLOTP=0 IAND2='NO' IF(NUMARG.LE.0)IAND2='NO' CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1992 CCCCC IF(NUMARG.GE.1.AND.IHARG(NUMARG).EQ.'AND')IAND2='YES' IF(NUMARG.GE.1)THEN IF(IHARG(NUMARG).EQ.'AND')IAND2='YES' ENDIF L=NPLOTP C C *************************************** C ** STEP 3-- ** C ** DETERMINE THE TYPE OF PLOT CASE ** C ** (FOR THIS COMMAND LINE ONLY)-- ** C ** 1) PLOT ** C ** 2) PLOT ... VERSUS ** C ** 3) PLOT ... FOR X = ** C ** 4) OTHER THAN THE ABOVE. ** C *************************************** C ISTEPN='3' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.0)GOTO800 GOTO809 800 CONTINUE ICASPL='NODA' IFOUND='YES' IERROR='NO' NS=0 GOTO9000 809 CONTINUE C ICASPL='NOVE' C NUMEQ=0 NUMFO=0 NUMVS=0 NUMDV=0 DO811J=1,NUMARG J2=J IF(IHARG(J).EQ.'=')GOTO816 IF(IHARG(J).EQ.'VS')GOTO826 IF(IHARG(J).EQ.'VS.')GOTO826 IF(IHARG(J).EQ.'VERS'.AND.IHARG2(J).EQ.'US ')GOTO826 IF(IHARG(J).EQ.'FOR')GOTO836 GOTO811 C 816 CONTINUE NUMEQ=NUMEQ+1 IEQLOC(NUMEQ)=J2 GOTO811 C 826 CONTINUE NUMVS=NUMVS+1 IVSLOC(NUMVS)=J2 GOTO811 C 836 CONTINUE JP1=J+1 IF(JP1.GT.NUMARG)GOTO837 IF(IHARG(JP1).EQ.'I '.AND.IHARG2(JP1).EQ.' ')GOTO837 IF(IHARG(JP1).EQ.'ROW '.AND.IHARG2(JP1).EQ.' ')GOTO837 NUMDV=NUMDV+1 837 CONTINUE NUMFO=NUMFO+1 IFOLOC(NUMFO)=J2 GOTO811 C 811 CONTINUE C IF(NUMEQ.EQ.0)ICASPL='NOVE' IF(NUMEQ.EQ.1.AND.NUMFO.EQ.1.AND.NUMDV.LE.0)ICASPL='NOVE' IF(NUMEQ.EQ.1.AND.NUMFO.EQ.1.AND.NUMDV.GE.1)ICASPL='EFE' IF(NUMEQ.GE.2)ICASPL='EFE' IF(NUMVS.GE.1)ICASPL='VS' C 899 CONTINUE C C ****************************************** C ** STEP 4-- ** C ** BRANCH ACCORDING TO THE PLOT CASE. ** C ****************************************** C ISTEPN='4' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IFOUND='YES' C IF(ICASPL.EQ.'NOVE')GOTO1000 IF(ICASPL.EQ.'VS')GOTO2000 IF(ICASPL.EQ.'EFE')GOTO3000 C 1000 CONTINUE CALL DPPLO1(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1MAXNPP, 1IBUGG3,IBUGQ,IFOUND,IERROR) GOTO9000 C 2000 CONTINUE CALL DPPLO2(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IVSLOC,NUMVS, 1MAXNPP, 1IBUGG3,IBUGQ,IFOUND,IERROR) GOTO9000 C 3000 CONTINUE CALL DPPLO3(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1PARAM,IPARN,IPARN2,NUMPAR,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD, 1IFOLOC, 1MAXNPP, 1IANGLU,IBUGG3,IBUGCO,IBUGEV,IBUGQ,IFOUND,IERROR) GOTO9000 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 DPPLOT--') 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)IANGLU,IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ 9014 FORMAT('IANGLU,IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ = ', 1A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)MAXNPP 9016 FORMAT('MAXNPP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020) 9020 FORMAT('I,Y(.),X(.),D(.),ISUB(.)--') CALL DPWRST('XXX','BUG ') DO9021I=1,NPLOTP WRITE(ICOUT,9022)I,Y(I),X(I),D(I),ISUB(I) 9022 FORMAT(I8,E15.7,E15.7,E15.7,I8) CALL DPWRST('XXX','BUG ') 9021 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPLSY(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--GENERATE A SYMBOL PLOT-- C THE COMMAND HAS THE FOLLOWING FORMAT: C SYMBOL PLOT Y X C ONLY THE Y VARIABLE IS REQUIRED. IF ONLY Y AND X ARE C GIVEN, THIS COMMAND IS SIMILAR TO THE PLOT Y X C COMMAND. IF A SIZE VARIABLE IS GIVEN, THE CHARACTER C SIZE OF PLOT CHARACTER WILL BE SCALED ACCORDING TO THAT C VARIABLE. THE SYMBOL VARIABLE IDENTIFIES THE SYMBOL C TO USE (SPECIFY AS AN INDEX BETWEEN 1 AND 100, USE THE C CORRESPONDING VALUE FROM THE CHARACTER ... COMMAND). C THE COLOR COMMAND IDENTIFIES THE COLOR FOR THE PLOT C CHARACTER (AGAIN AN INDEX FROM 1 TO 100, USE CHAR COLOR C COMMAND SETTINGS). THE FILL VARIABLE IDENTIFIES C WHETHER THE PLOT SYMBOL WILL BE FILLED (0 FOR NO FILL C ANYTHING ELSE TO FILL WITH SOLID PATTERN). C PLSYOR ARROW C EXAMPLE--SYMBOL PLOT Y X SIZE SYMBOL COLOR FILL C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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--92/8 C ORIGINAL VERSION--AUGUST 1992. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CCCCC CHARACTER*4 IHRI11 CCCCC CHARACTER*4 IHRI12 CHARACTER*4 IH1 CHARACTER*4 IH2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG C CHARACTER*4 ICASEQ C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(MAXOBV) DIMENSION Y2(MAXOBV) DIMENSION Y3(MAXOBV) DIMENSION Y4(MAXOBV) DIMENSION Y5(MAXOBV) DIMENSION Y6(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),Y1(1)) EQUIVALENCE (GARBAG(IGARB2),Y2(1)) EQUIVALENCE (GARBAG(IGARB3),Y3(1)) EQUIVALENCE (GARBAG(IGARB4),Y4(1)) EQUIVALENCE (GARBAG(IGARB5),Y5(1)) EQUIVALENCE (GARBAG(IGARB6),Y6(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-----START POINT----------------------------------------------------- C IERROR='NO' IFOUND='NO' C ISUBN1='DPPL' ISUBN2='SY ' C ICASPL='SYMB' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=6 MINN2=1 C ICOLH=0 C C *********************************** C ** TREAT THE SYMBOL PLOT CASE ** C *********************************** C IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PLSY')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPLSY--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGG2,IBUGG3,IBUGQ,ISUBRO 52 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)MAXN 54 FORMAT('MAXN = ',I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='11' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PLSY') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')GOTO111 GOTO119 C 111 CONTINUE ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO119 C 119 CONTINUE IFOUND='YES' GOTO190 C 190 CONTINUE C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ** AT LEAST 1 REQUIRED ** C ******************************************************* C ISTEPN='2' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PLSY') 1CALL 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.1-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='2.1' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PLSY') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO2190 DO2100J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO2110 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO2110 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO2120 2100 CONTINUE GOTO2190 2110 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO2190 2120 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO2190 2190 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PLSY')GOTO2195 WRITE(ICOUT,2191)NUMARG,ILOCQ 2191 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 2195 CONTINUE C C ************************************************** C ** STEP 2.2-- ** C ** DETERMINE THE NUMBER OF VARIABLES ** C ** TO BE INCLUDED AS PLOT COMPONENTS ** C ************************************************** C ISTEPN='2.2' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PLSY') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IF(NUMV2.GE.1.AND.NUMV2.LE.6)GOTO2290 C WRITE(ICOUT,2211) 2211 FORMAT('***** ERROR IN DPPLSY--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2212) 2212 FORMAT(' ILLEGAL SYNTAX--THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2213) 2213 FORMAT(' TO BE INCLUDED AS ARGUMENTS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2214) 2214 FORMAT(' IN A SYMBOL PLOT COMMAND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2215) 2215 FORMAT(' MUST BE AT LEAST 1 AND AT MOST 6;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2216)NUMV2 2216 FORMAT(' SUCH WAS NOT THE CASE HERE. NUMV2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2217) 2217 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2218)(IANS(I),I=1,IWIDTH) 2218 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 2290 CONTINUE C C *************************************** C ** STEP 2.3 ** C ** CHECK THE VALIDITY OF EACH ** C ** OF THE VARIABLES. ** C *************************************** C ISTEPN='2.3' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PLSY') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO2300I=1,NUMV2 IH1=IHARG(I) IH2=IHARG2(I) IHWUSE='V' MESSAG='YES' CALL CHECKN(IH1,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(I.EQ.1)ICOL1=IVALUE(ILOCV) IF(I.EQ.2)ICOL2=IVALUE(ILOCV) IF(I.EQ.3)ICOL3=IVALUE(ILOCV) IF(I.EQ.4)ICOL4=IVALUE(ILOCV) IF(I.EQ.5)ICOL5=IVALUE(ILOCV) IF(I.EQ.6)ICOL6=IVALUE(ILOCV) IF(I.EQ.1)N1=IN(ILOCV) IF(I.EQ.2)N2=IN(ILOCV) IF(I.EQ.3)N3=IN(ILOCV) IF(I.EQ.4)N4=IN(ILOCV) IF(I.EQ.5)N5=IN(ILOCV) IF(I.EQ.6)N6=IN(ILOCV) 2300 CONTINUE C C ************************************************** C ** STEP 2.4-- ** C ** CHECK THAT ALL ARGUMENTS ** C ** HAVE THE SAME NUMBER OF OBSERVATIONS. ** C ************************************************** C ISTEPN='2.4' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PLSY') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(N2.NE.N1)GOTO2410 IF(NUMV2.LE.2)GOTO2490 IF(N3.NE.N1)GOTO2410 IF(NUMV2.LE.3)GOTO2490 IF(N4.NE.N1)GOTO2410 IF(NUMV2.LE.4)GOTO2490 IF(N5.NE.N1)GOTO2410 IF(NUMV2.LE.5)GOTO2490 IF(N6.NE.N1)GOTO2410 GOTO2490 C 2410 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2411) 2411 FORMAT('***** ERROR IN DPPLSY--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2412) 2412 FORMAT(' FOR A SYMBOL PLOT,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2413) 2413 FORMAT(' ALL VARIABLES MUST HAVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2414) 2414 FORMAT(' THE SAME NUMBER OF ELEMENTS;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2415) 2415 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2421)N1 2421 FORMAT('THE FIRST VARIABLE HAD ',I8,' ELEMENTS;') CALL DPWRST('XXX','BUG ') IF(NUMV2.LE.1)GOTO2490 WRITE(ICOUT,2422)N2 2422 FORMAT('THE SECOND VARIABLE HAD ',I8,' ELEMENTS;') CALL DPWRST('XXX','BUG ') IF(NUMV2.LE.2)GOTO2490 WRITE(ICOUT,2423)N3 2423 FORMAT('THE THIRD VARIABLE HAD ',I8,' ELEMENTS;') CALL DPWRST('XXX','BUG ') IF(NUMV2.LE.3)GOTO2490 WRITE(ICOUT,2424)N4 2424 FORMAT('THE FOURTH VARIABLE HAD ',I8,' ELEMENTS;') CALL DPWRST('XXX','BUG ') IF(NUMV2.LE.4)GOTO2490 WRITE(ICOUT,2425)N5 2425 FORMAT('THE FIFTH VARIABLE HAD ',I8,' ELEMENTS;') CALL DPWRST('XXX','BUG ') IF(NUMV2.LE.5)GOTO2490 WRITE(ICOUT,2426)N6 2426 FORMAT('THE SIXTH VARIABLE HAD ',I8,' ELEMENTS;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2427) 2427 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2428)(IANS(I),I=1,IWIDTH) 2428 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 2490 CONTINUE C C ****************************************************** C ** STEP 2.5-- ** C ** CHECK THAT VARIABLES HAVE AT LEAST 1 ELEMENT ** C ****************************************************** C 4100 CONTINUE ISTEPN='2.5' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PLSY') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(N1.GE.1)GOTO2590 C 2510 CONTINUE WRITE(ICOUT,2511) 2511 FORMAT('***** ERROR IN DPPLSY--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2513) 2513 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2514) 2514 FORMAT(' MUST BE AT LEAST 1;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2515) 2515 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,2516)IHRI11,IHRI12,N1 C2516 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8, WRITE(ICOUT,2516)N1 2516 FORMAT(' VARIABLE HAS ',I8,' OBSERVATIONS;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2520) 2520 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2521)(IANS(I),I=1,IWIDTH) 2521 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2590 CONTINUE C C ************************************************* C ** STEP 3-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** (BASED ON THE QUALIFIER) ** C ** THEN FOR EACH OF THE RESPONSE VARIABLES ** C ** EXTRACT THE DATA SUBSET ** C ************************************************* C ISTEPN='3' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PLSY') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO3010 IF(ICASEQ.EQ.'SUBS')GOTO3020 IF(ICASEQ.EQ.'FOR')GOTO3030 C 3010 CONTINUE DO3015I=1,N1 ISUB(I)=1 3015 CONTINUE NQ=N1 GOTO3050 C 3020 CONTINUE NIOLD=N1 CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO3050 C 3030 CONTINUE NIOLD=N1 CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO3050 C 3050 CONTINUE J=0 IMAX=N1 IF(NQ.LT.N1)IMAX=NQ DO3060I=1,IMAX IF(ISUB(I).EQ.0)GOTO3060 J=J+1 C IJ=MAXN*(ICOL1-1)+I IF(ICOL1.LE.MAXCOL)Y1(J)=V(IJ) IF(ICOL1.EQ.MAXCP1)Y1(J)=PRED(I) IF(ICOL1.EQ.MAXCP2)Y1(J)=RES(I) IF(ICOL1.EQ.MAXCP3)Y1(J)=YPLOT(I) IF(ICOL1.EQ.MAXCP4)Y1(J)=XPLOT(I) IF(ICOL1.EQ.MAXCP5)Y1(J)=X2PLOT(I) IF(ICOL1.EQ.MAXCP6)Y1(J)=TAGPLO(I) C IF(NUMV2.LE.1)GOTO3060 IJ=MAXN*(ICOL2-1)+I IF(ICOL2.LE.MAXCOL)Y2(J)=V(IJ) IF(ICOL2.EQ.MAXCP1)Y2(J)=PRED(I) IF(ICOL2.EQ.MAXCP2)Y2(J)=RES(I) IF(ICOL2.EQ.MAXCP3)Y2(J)=YPLOT(I) IF(ICOL2.EQ.MAXCP4)Y2(J)=XPLOT(I) IF(ICOL2.EQ.MAXCP5)Y2(J)=X2PLOT(I) IF(ICOL2.EQ.MAXCP6)Y2(J)=TAGPLO(I) C IF(NUMV2.LE.2)GOTO3060 IJ=MAXN*(ICOL3-1)+I IF(ICOL3.LE.MAXCOL)Y3(J)=V(IJ) IF(ICOL3.EQ.MAXCP1)Y3(J)=PRED(I) IF(ICOL3.EQ.MAXCP3)Y3(J)=RES(I) IF(ICOL3.EQ.MAXCP3)Y3(J)=YPLOT(I) IF(ICOL3.EQ.MAXCP4)Y3(J)=XPLOT(I) IF(ICOL3.EQ.MAXCP5)Y3(J)=X2PLOT(I) IF(ICOL3.EQ.MAXCP6)Y3(J)=TAGPLO(I) C IF(NUMV2.LE.3)GOTO3060 IJ=MAXN*(ICOL4-1)+I IF(ICOL4.LE.MAXCOL)Y4(J)=V(IJ) IF(ICOL4.EQ.MAXCP1)Y4(J)=PRED(I) IF(ICOL4.EQ.MAXCP4)Y4(J)=RES(I) IF(ICOL4.EQ.MAXCP3)Y4(J)=YPLOT(I) IF(ICOL4.EQ.MAXCP4)Y4(J)=XPLOT(I) IF(ICOL4.EQ.MAXCP5)Y4(J)=X2PLOT(I) IF(ICOL4.EQ.MAXCP6)Y4(J)=TAGPLO(I) C IF(NUMV2.LE.4)GOTO3060 IJ=MAXN*(ICOL5-1)+I IF(ICOL5.LE.MAXCOL)Y5(J)=V(IJ) IF(ICOL5.EQ.MAXCP1)Y5(J)=PRED(I) IF(ICOL5.EQ.MAXCP5)Y5(J)=RES(I) IF(ICOL5.EQ.MAXCP3)Y5(J)=YPLOT(I) IF(ICOL5.EQ.MAXCP4)Y5(J)=XPLOT(I) IF(ICOL5.EQ.MAXCP5)Y5(J)=X2PLOT(I) IF(ICOL5.EQ.MAXCP6)Y5(J)=TAGPLO(I) C IF(NUMV2.LE.5)GOTO3060 IJ=MAXN*(ICOL6-1)+I IF(ICOL6.LE.MAXCOL)Y6(J)=V(IJ) IF(ICOL6.EQ.MAXCP1)Y6(J)=PRED(I) IF(ICOL6.EQ.MAXCP6)Y6(J)=RES(I) IF(ICOL6.EQ.MAXCP3)Y6(J)=YPLOT(I) IF(ICOL6.EQ.MAXCP4)Y6(J)=XPLOT(I) IF(ICOL6.EQ.MAXCP5)Y6(J)=X2PLOT(I) IF(ICOL6.EQ.MAXCP6)Y6(J)=TAGPLO(I) C 3060 CONTINUE NLOCAL=J C C C ******************************************************* C ** STEP 8-- ** 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='5' IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PLSY')GOTO5099 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) WRITE(ICOUT,5001)NLOCAL,ICASPL 5001 FORMAT('NLOCAL,ICASPL=',I5,1X,A4) CALL DPWRST('XXX','BUG ') 5099 CONTINUE C CALL DPPLS2(Y1,Y2,Y3,Y4,Y5,Y6,NLOCAL,ICASPL,NUMV2, 1Y,X,D,DSIZE,DSYMB,DCOLOR,DFILL, 1NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) C C ***************** C ** STEP 9-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PLSY')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPLSY--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGG2,IBUGG3,IBUGQ,ISUBRO 9012 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IFOUND,IERROR 9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NPLOTV,NPLOTP,NLOCAL,ICASPL,IAND1,IAND2 9014 FORMAT('NPLOTV,NPLOTP,NLOCAL,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9041)NLOCAL 9041 FORMAT('NLOCAL = ',I8) CALL DPWRST('XXX','BUG ') IF(NLOCAL.LE.0)GOTO9044 DO9042I=1,NLOCAL WRITE(ICOUT,9043)I,Y1(I),Y2(I),Y3(I),Y4(I),Y5(I),Y6(I) 9043 FORMAT('I,Y1(I),Y2(I),Y3(I),Y4(I)Y5(I),Y(6) = ', 1 I8,6E15.7) CALL DPWRST('XXX','BUG ') 9042 CONTINUE 9044 CONTINUE WRITE(ICOUT,9051)NPLOTP 9051 FORMAT('NPLOTP = ',I8) CALL DPWRST('XXX','BUG ') IF(NPLOTP.LE.0)GOTO9054 DO9052I=1,NPLOTP WRITE(ICOUT,9053)I,Y(I),X(I),D(I),DSIZE(I),DSYMB(I),DCOLOR(I), 1DFILL(I) 9053 FORMAT('I,Y(I),X(I),D(I),DSIZE(I),DSYMB(I),DCOLOR(I),', 1 'DFILL(I) = ',I8,7F12.5) CALL DPWRST('XXX','BUG ') 9052 CONTINUE 9054 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPLS2(Y1,Y2,Y3,Y4,Y5,Y6,NZ,ICASPL,NUMV2, 1Y,X,D,DSIZE,DSYMB,DCOLOR,DFILL, 1N2,NPLOTV,IBUGG3,ISUBRO,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE C A SYMBOL PLOT C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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--92/8 C ORIGINAL VERSION--AUGUST 1992. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION Y1(*) DIMENSION Y2(*) DIMENSION Y3(*) DIMENSION Y4(*) DIMENSION Y5(*) DIMENSION Y6(*) C DIMENSION Y(*) DIMENSION X(*) DIMENSION D(*) DIMENSION DSIZE(*) DIMENSION DSYMB(*) DIMENSION DCOLOR(*) DIMENSION DFILL(*) 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='DPPL' ISUBN2='S2 ' C IERROR='NO' C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(NZ.GE.1)GOTO39 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN DPPLS2--') 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)NZ 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(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'PLS2')GOTO90 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71) 71 FORMAT('***** AT THE BEGINNING OF DPPLS2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)ICASPL,NZ,N2,NPLOTV,NUMV2 72 FORMAT('ICASPL,NZ,N2,NPLOTV,NUMV2 = ',A4,2X,4I8) CALL DPWRST('XXX','BUG ') IF(NZ.LE.0)GOTO83 CCCCC DO81I=1,NZ CCCCC WRITE(ICOUT,82)I,Y1(I),Y2(I),Y3(I),Y4(I),Y5(I),Y6(I) CCC82 FORMAT('I,Y1(I),Y2(I),Y3(I),Y4(I),Y5(I),Y6(I) = ', CCCCC CALL DPWRST('XXX','BUG ') CCCCC1 I8,6E12.5) 81 CONTINUE 83 CONTINUE 90 CONTINUE C C **************************************** C ** STEP 1-- ** C ** INITIALIZE DSIZE, ETC. ** C **************************************** C DO100I=1,NZ Y(I)=Y1(I) D(I)=1.0 DSIZE(I)=1.0 DSYMB(I)=1.0 DCOLOR(I)=1.0 DFILL(I)=0.0 100 CONTINUE C C **************************************** C ** STEP 2-- ** C ** IF NO X, CREATE IT ** C **************************************** C IF(NUMV2.LT.2)THEN DO200I=1,NZ X(I)=REAL(I) 200 CONTINUE GOTO8000 ELSE DO210I=1,NZ X(I)=Y2(I) 210 CONTINUE ENDIF C C **************************************** C ** STEP 3-- ** C ** HANDLE THE SIZE VARIABLE ** C **************************************** C IF(NUMV2.LT.3)GOTO8000 AMAXSZ=0.0 DO300I=1,NZ ATEMP=ABS(Y3(I)) IF(ATEMP.GT.AMAXSZ)AMAXSZ=ATEMP 300 CONTINUE DO310I=1,NZ ATEMP=ABS(Y3(I))/AMAXSZ IF(ATEMP.GT.1.0)ATEMP=1.0 IF(ATEMP.LT.0.05)ATEMP=0.05 DSIZE(I)=ATEMP 310 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'PLS2')GOTO390 WRITE(ICOUT,371) 371 FORMAT('***** AFTER CALCULATING SIZE --') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,372)AMAXSZ 372 FORMAT('AMAXSZ = ',E15.7) CALL DPWRST('XXX','BUG ') DO381I=1,10 WRITE(ICOUT,382)I,Y3(I),DSIZE(I) 382 FORMAT('I,Y3(I),DSIZE(I) = ',I4,E15.7,1X,F8.5) CALL DPWRST('XXX','BUG ') 381 CONTINUE 390 CONTINUE C C **************************************** C ** STEP 4-- ** C ** HANDLE THE SYMBOL VARIABLE ** C ** SHOULD BE AN INDEX BETWEEN 1 AND ** C ** 100 ** C **************************************** C IF(NUMV2.LT.4)GOTO8000 DO400I=1,NZ DSYMB(I)=Y4(I) DSYMB(I)=ABS(DSYMB(I)) IF(DSYMB(I).LT.0.5)DSYMB(I)=1.0 IF(DSYMB(I).GT.99.5)DSYMB(I)=100.0 400 CONTINUE C C **************************************** C ** STEP 5-- ** C ** HANDLE THE COLOR VARIABLE ** C ** SHOULD BE AN INDEX BETWEEN 1 AND ** C ** 100 ** C **************************************** C IF(NUMV2.LT.5)GOTO8000 DO500I=1,NZ DCOLOR(I)=Y5(I) DCOLOR(I)=ABS(DCOLOR(I)) IF(DCOLOR(I).LT.0.5)DCOLOR(I)=1.0 IF(DCOLOR(I).GT.99.5)DCOLOR(I)=100.0 500 CONTINUE C C **************************************** C ** STEP 6-- ** C ** HANDLE THE FILL VARIABLE ** C ** SHOULD BE 0 FOR NO FILL, ANYTHING ** C ** ELSE FOR SOLID FILL ** C **************************************** C IF(NUMV2.LT.5)GOTO8000 DO600I=1,NZ DFILL(I)=Y6(I) IF(DFILL(I).GE.-0.5.AND.DFILL(I).LE.0.5)THEN DFILL(I)=0.0 ELSE DFILL(I)=1.0 ENDIF 600 CONTINUE C 8000 CONTINUE N2=NZ NPLOTV=3 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'PLS2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPLS2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,NZ,N2,IERROR 9012 FORMAT('ICASPL,NZ,N2,IERROR = ',A4,2I8,2X,A4) CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,9013)N2,J,K C9013 FORMAT('N2,J,K = ',3I8) WRITE(ICOUT,9013)N2 9013 FORMAT('N2 = ',I8) CALL DPWRST('XXX','BUG ') IF(NZ.LE.0)GOTO9023 DO9021I=1,NZ WRITE(ICOUT,9022)I,Y1(I),Y2(I),Y3(I),Y4(I) 9022 FORMAT('I,Y1(I),Y2(I),Y3(I) = ',I8,4E12.5) CALL DPWRST('XXX','BUG ') 9021 CONTINUE 9023 CONTINUE WRITE(ICOUT,9031)N2,NPLOTV 9031 FORMAT('N2,NPLOTV = ',2I8) CALL DPWRST('XXX','BUG ') DO9035I=1,N2 WRITE(ICOUT,9036)I,Y(I),X(I),D(I) 9036 FORMAT('I,Y(I),X(I),D(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPMTI(IANS,IANSLC,IWIDTH,IHARG,IHARG2,NUMARG, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--EXTRACT THE STRING TO BE USED AS A TITLE C FOR SUBSEQUENT SAVED PIXMAPS; C INPUT ARGUMENTS--IANS (A CHARACTER VECTOR) C --IWIDTH C --IHARG (A CHARACTER VECTOR) C --IHARG2 (A CHARACTER VECTOR) C --NUMARG C OUTPUT ARGUMENTS--IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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--97/4 C ORIGINAL VERSION--APRIL 1997. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IANS CHARACTER*4 IANSLC CHARACTER*4 IHARG CHARACTER*4 IHARG2 C CHARACTER*4 IBUGP2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IANS(*) DIMENSION IANSLC(*) DIMENSION IHARG(*) DIMENSION IHARG2(*) C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOPM.INC' 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(IBUGP2.NE.'ON')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('AT THE BEGINNING OF DPPMTI--') CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ***************************************** C ** STEP 1-- ** C ** DETERMINE THE COMMAND ** C ** (TITLE) AND ITS LOCATION ** C ** ON THE LINE. ** C ***************************************** C DO1000I=1,IWIDTH I2=I IP1=I+1 IP2=I+2 IP3=I+3 IP4=I+4 IP5=I+5 IP6=I+6 IF(IANS(I).EQ.'T'.AND.IANS(IP1).EQ.'I' 1.AND.IANS(IP2).EQ.'T'.AND.IANS(IP3).EQ.'L' 1.AND.IANS(IP4).EQ.'E') 1GOTO100 C 1000 CONTINUE WRITE(ICOUT,1001) 1001 FORMAT('***** ERROR IN DPPMTI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1002) 1002 FORMAT(' NO MATCH FOR COMMAND.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO800 C C ********************************************************** C ** STEP 2-- ** C ** DEFINE THE START POSITION (ISTART) FOR THE STRING. ** C ********************************************************** C 100 CONTINUE ISTART=I2+6 GOTO300 C C ******************************************************** C ** STEP 3-- ** C ** DEFINE THE STOP POSITION (ISTOP) FOR THE STRING. ** C ******************************************************** C 300 CONTINUE IFOUND='YES' ISTOP=0 IF(ISTART.GT.IWIDTH)GOTO329 DO320I=ISTART,IWIDTH IREV=IWIDTH-I+ISTART IF(IANS(IREV).NE.' ')GOTO325 320 CONTINUE GOTO329 325 CONTINUE ISTOP=IREV 329 CONTINUE C C ***************************************** C ** STEP 4-- ** C ** COPY OVER THE STRING OF INTEREST. ** C ***************************************** C IF(ISTART.GT.ISTOP)GOTO359 IF(ISTOP.EQ.0)GOTO359 IPXMCM(NUMPXM+1)=' ' J=0 DO350I=ISTART,ISTOP J=J+1 IPXMCM(NUMPXM+1)(J:J)=IANSLC(I)(1:1) 350 CONTINUE NCTITL=J GOTO800 359 CONTINUE C C ************************************ C ** STEP 5-- ** C ** TREAT THE EMPTY-STRING CASE. ** C ************************************ C NCTITL=0 GOTO800 C C *************************** C ** STEP 6-- ** C ** PRINT OUT A MESSAGE ** C *************************** C 800 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO889 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811) 811 FORMAT('THE TITLE FOR THE NEXT SAVED PIXMAP HAS JUST BEEN ', 1'SET TO') CALL DPWRST('XXX','BUG ') IF(NCTITL.EQ.0)THEN WRITE(ICOUT,999) ELSE IF(NCTITL.GE.1)THEN WRITE(ICOUT,812)(IPXMCM(NUMPXM+1)(I:I),I=1,NCTITL) ENDIF CALL DPWRST('XXX','BUG ') 812 FORMAT(10X,120A1) 889 CONTINUE GOTO9000 C C **************** C ** STEP 90-- ** C ** EXIT ** C **************** C 9000 CONTINUE IF(IBUGP2.NE.'ON')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('AT THE END OF DPPMTI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NCTITL 9012 FORMAT('NCTITL = ',I5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPPOI2(X1,Y1, 1IFIG, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) C C PURPOSE--DRAW A POINT C WITH THE COORDINATES (X1,Y1) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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 UPDATED --JANUARY 1989. MODIFY CALL TO DPFIRE (ALAN) C C-----NON-COMMON VARIABLES------------------------------------- C CHARACTER*4 IFIG CHARACTER*4 IPATT2 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 CHARACTER*4 ICOLF 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.'POI2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPOI2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)X1,Y1 53 FORMAT('X1,Y1 = ',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 POINT ** C ********************************* C PX(1)=X1 PY(1)=Y1 C PX(2)=X1 PY(2)=Y1 C NP=2 C C *********************** C ** STEP 2-- ** C ** FILL THE FIGURE ** C ** (IF CALLED FOR) ** C *********************** C IF(IREFSW(1).EQ.'OFF')GOTO2190 IPATT=IREPTY(1) IPATT2='SOLI' PTHICK=PREPTH(1) PXGAP=PREPSP(1) PYGAP=PREPSP(1) ICOLF=IREFCO(1) ICOLP=IREPCO(1) CALL DPFIRE(PX,PY,NP, 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2) 2190 CONTINUE C C *************************** C ** STEP 3-- ** C ** DRAW OUT THE FIGURE ** C *************************** 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 C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'POI2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPOI2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NP 9013 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 DPPOIN(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 POINTS 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 C POINT. C NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 1 C AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*1 = 2. C NOTE--IF NO NUMBERS ARE PROVIDED, C THEN THE DRAWN POINT WILL BE C AT THE LAST CURSOR POSITION C NOTE--IF 2 NUMBERS ARE PROVIDED, C THEN THE DRAWN POINT WILL BE C AT THE ABSOLUTE (X,Y) POSITION C AS DEFINED BY THE 2 NUMBERS C NOTE--AND SO FORTH FOR 2, 3, 4, ... 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 CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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.'POIN')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPOIN--') 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='POIN' NUMPT=1 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 DPPOIN--') 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 POINT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1136) 1136 FORMAT(' AT 20 20 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT(' THEN THE ALLOWABLE FORMS ARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' POINT 20 20 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' BOX ABSOLUTE 20 20 ') 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 GOTO1170 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) GOTO1170 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 X1=X2 Y1=Y2 GOTO1170 C 1170 CONTINUE CALL DPPOI2(X1,Y1, 1IFIG, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) C X1=X1 Y1=Y1 C GOTO1160 1190 CONTINUE C PXEND=X1 PYEND=Y1 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.'POIN')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPOIN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ILOCFN,NUMNUM 9012 FORMAT('ILOCFN,NUMNUM = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)X1,Y1 9013 FORMAT('X1,Y1 = ',2E15.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 DPPOLY( 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, 1IDFONT, 1UNITSW, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--DRAW A POLYGON C THE COORDINATES ARE IN STANDARDIZED UNITS C OF 0 TO 100. C NOTE--THE INPUT COORDINATES ARE AN ARRAY OF X AND Y VALUES 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 CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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--97/7 C ORIGINAL VERSION--JULY 1997. C C-----NON-COMMON VARIABLES----------------------------------------- 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 CHARACTER*4 IDFONT CHARACTER*4 UNITSW C CHARACTER*4 IFOUND CHARACTER*4 IBUGD2 CHARACTER*4 IBUGQ CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN 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 CHARACTER*4 IHFACT CHARACTER*4 IHFAC2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ C INCLUDE 'DPCOPA.INC' C DIMENSION XP(MAXOBV) DIMENSION YP(MAXOBV) 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 DIMENSION ICOLIV(2) DIMENSION NIV(2) C INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),XP(1)) EQUIVALENCE (GARBAG(IGARB2),YP(1)) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOM2.INC' 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='YES' IERROR='NO' IERRG4=IERROR IBUGQ=IBUGD2 ISUBN1='DPPO' ISUBN2='LY ' C ILOCFN=0 NPTS=0 C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'POLY')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPOLY--') 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='POLY' NUMPT=3 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) IGFONT=IDFONT(IDEVIC) NUMVPP=IDNVPP(IDEVIC) NUMHPP=IDNHPP(IDEVIC) ANUMVP=NUMVPP ANUMHP=NUMHPP 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.3.AND.IHARG(1).EQ.'ABSO')GOTO1112 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA')GOTO1113 IF(NUMARG.GE.2) GOTO1111 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 GOTO1149 1129 CONTINUE GOTO1130 C 1130 CONTINUE IERRG4='YES' WRITE(ICOUT,1131) 1131 FORMAT('***** ERROR IN DPPOLY--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1132) 1132 FORMAT(' ILLEGAL FORM FOR POLYGON ', 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 AN POLYGON ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1136) 1136 FORMAT(' WITH COORDINATES STORED IN THE ARRAYS X AND Y') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT(' THEN THE ALLOWABLE FORMS ARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' POLYGON X Y') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' POLYGON ABSOLUTE X Y') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' POLYGON RELATIVE X Y') CALL DPWRST('XXX','BUG ') GOTO9000 1149 CONTINUE C C ***************************************** C ** STEP 4-- ** C ** SEARCH FOR COMMAND ARGUMENTS ** C ***************************************** C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO2190 DO2100J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO2110 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO2110 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO2120 2100 CONTINUE GOTO2190 2110 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO2190 2120 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO2190 2190 CONTINUE IF(IBUGD2.EQ.'OFF')GOTO2195 WRITE(ICOUT,2191)NUMARG,ILOCQ 2191 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 2195 CONTINUE C DO530J=ILOCFN,ILOCFN+1 IFAC=J-ILOCFN+1 IHFACT=IHARG(IFAC) IHFAC2=IHARG2(IFAC) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHFACT,IHFAC2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLIV(IFAC)=IVALUE(ILOCV) NIV(IFAC)=IN(ILOCV) IF(IBUGD2.EQ.'ON')WRITE(ICOUT,532)IFAC,IHFACT,IHFAC2,ICOLIV(IFAC), 1NIV(IFAC) 532 FORMAT('I,IHFACT,IHFAC2,ICOLIV(IFAC),NIV(IFAC) = ', 1I8,2X,A4,2X,A4,I8,I8) IF(IBUGD2.EQ.'ON')CALL DPWRST('XXX','BUG ') 530 CONTINUE C IF(NIV(1).NE.NIV(2))GOTO550 GOTO590 C 550 CONTINUE WRITE(ICOUT,551) 551 FORMAT('***** ERROR IN DPPOLY--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,552) 552 FORMAT(' FOR A POLYGON, THE NUMBER OF ELEMENTS IN THE', 1' TWO ARRAYS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,555) 555 FORMAT(' SHOULD HAVE THE SAME AS THE NUMBER OF ELEMENTS;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,557) 557 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,561) 561 FORMAT(' THE TWO VARIABLES HAVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,566)NIV(ILOCFN),NIV(ILOCFN) 566 FORMAT(' ',I8,I8,' ELEMENTS RESPECTIVELY.') CALL DPWRST('XXX','BUG ') 565 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,567) 567 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,568)(IANS(I),I=1,IWIDTH) 568 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 ** THEN FORM THE RESPONSE VARIABLE ** C ** AND THE FACTORS ** C ***************************************** C ISTEPN='7' C IF(ICASEQ.EQ.'FULL')GOTO610 IF(ICASEQ.EQ.'SUBS')GOTO620 IF(ICASEQ.EQ.'FOR')GOTO630 C 610 CONTINUE DO615I=1,NIV(1) ISUB(I)=1 615 CONTINUE NQ=NIV(1) GOTO650 C 620 CONTINUE NIOLD=NIV(1) CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO650 C 630 CONTINUE NIOLD=NIV(1) CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO650 C 650 CONTINUE J=0 IMAX=NIV(1) IF(NQ.LT.NIV(1))IMAX=NQ DO660I=1,IMAX IF(ISUB(I).EQ.0)GOTO660 J=J+1 C IJ=MAXN*(ICOLIV(1)-1)+I IF(ICOLIV(1).LE.MAXCOL)XP(J)=V(IJ) IF(ICOLIV(1).EQ.MAXCP1)XP(J)=PRED(I) IF(ICOLIV(1).EQ.MAXCP2)XP(J)=RES(I) IF(ICOLIV(1).EQ.MAXCP3)XP(J)=YPLOT(I) IF(ICOLIV(1).EQ.MAXCP4)XP(J)=XPLOT(I) IF(ICOLIV(1).EQ.MAXCP5)XP(J)=X2PLOT(I) IF(ICOLIV(1).EQ.MAXCP6)XP(J)=TAGPLO(I) C ICOLR=ICOLIV(2) IJ=MAXN*(ICOLR-1)+I IF(ICOLR.LE.MAXCOL)YP(J)=V(IJ) IF(ICOLR.EQ.MAXCP1)YP(J)=PRED(I) IF(ICOLR.EQ.MAXCP2)YP(J)=RES(I) IF(ICOLR.EQ.MAXCP3)YP(J)=YPLOT(I) IF(ICOLR.EQ.MAXCP4)YP(J)=XPLOT(I) IF(ICOLR.EQ.MAXCP5)YP(J)=X2PLOT(I) IF(ICOLR.EQ.MAXCP6)YP(J)=TAGPLO(I) C 660 CONTINUE NPTS=J C C **************************** C ** STEP 3-- ** C ** DRAW OUT THE LINE(S) ** C **************************** C 1151 CONTINUE C IF(UNITSW.EQ.'DATA')THEN CALL DPCODS('X',XP(1),XP(1),IBUGD2,ISUBRO,IERROR) CALL DPCODS('Y',YP(1),YP(1),IBUGD2,ISUBRO,IERROR) ENDIF DO1170I=2,NPTS IF(UNITSW.EQ.'DATA')THEN CALL DPCODS('X',XP(I),XP(I),IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')XP(I)=XP(I-1)+XP(I) CALL DPCODS('Y',YP(I),YP(I),IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')YP(I)=YP(I-1)+YP(I) ENDIF C 1170 CONTINUE C CALL DPPOL2(XP,YP,NPTS, 1IFIG, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) C PXEND=XP(NPTS) PYEND=YP(NPTS) 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.'POLY')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPOLY--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ILOCFN,NPTS 9012 FORMAT('ILOCFN,NPTS = ',2I8) CALL DPWRST('XXX','BUG ') IF(NPTS.GT.0)THEN DO9013I=1,NPTS WRITE(ICOUT,9014)I,XP(I),YP(I) 9014 FORMAT('I,XP(I),YP(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9013 CONTINUE ENDIF 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 DPPOL2(X,Y,NPTS, 1IFIG, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) C C PURPOSE--DRAW A POLYGON C COORDINATES OF THE POLYGON ARE STORED IN C THE ARRAYS X AND Y C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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--97/7 C ORIGINAL VERSION--JULY 1997. C C-----NON-COMMON VARIABLES------------------------------------- C CHARACTER*4 IPATT2 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 CHARACTER*4 ICOLF CHARACTER*4 ICOLP CHARACTER*4 ICOL CHARACTER*4 IFLAG C DIMENSION X(*) DIMENSION Y(*) 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.'POL2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPOL2--') CALL DPWRST('XXX','BUG ') DO52I=1,NPTS WRITE(ICOUT,53)I,X(I),Y(I) 53 FORMAT('I,X,Y = ',I6,2E15.7) 52 CONTINUE 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 POLYGON ** C ********************************* C C IF(X(1).EQ.X(NPTS).AND.Y(1).EQ.Y(NPTS))THEN NP=NPTS ELSE NP=NPTS+1 X(NP)=X(1) Y(NP)=Y(1) ENDIF C C *********************** C ** STEP 2-- ** C ** FILL THE FIGURE ** C ** (IF CALLED FOR) ** C *********************** C IF(IREFSW(1).EQ.'OFF')GOTO2190 IPATT=IREPTY(1) IPATT2='SOLI' PTHICK=PREPTH(1) PXGAP=PREPSP(1) PYGAP=PREPSP(1) ICOLF=IREFCO(1) ICOLP=IREPCO(1) CALL DPFIRE(X,Y,NP, 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2) 2190 CONTINUE C C *************************** C ** STEP 3-- ** C ** DRAW OUT THE FIGURE ** C *************************** 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(X,Y,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.'POL2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPOL2--') CALL DPWRST('XXX','BUG ') DO9015I=1,NP WRITE(ICOUT,9016)I,X(I),Y(I) 9016 FORMAT('I,X(I),Y(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 DPPOTP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IBOOSS,ISEED, 1ICAPSW,ICAPTY, 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE A PEAKS OVER THRESHOLD PLOT-- 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 BUREAU OF STANDARDS. 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--2005/4 C ORIGINAL VERSION--APRIL 2005. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 ICAPSW CHARACTER*4 ICAPTY CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHRIGH CHARACTER*4 IHRIG2 CHARACTER*4 IERRO4 C CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 ISUBN0 C CHARACTER*4 IHP CHARACTER*4 IHP2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 IWRITE C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(MAXOBV) DIMENSION XTEMP1(MAXOBV) DIMENSION XTEMP2(MAXOBV) DIMENSION XTEMP3(MAXOBV) DIMENSION XTEMP4(MAXOBV) DIMENSION XTEMP5(MAXOBV) DIMENSION XTEMP6(MAXOBV) DIMENSION XTEMP7(MAXOBV) DIMENSION XTEMP8(MAXOBV) DIMENSION XTEMP9(MAXOBV) DIMENSION XTMP10(MAXOBV) DIMENSION ITEMP1(MAXOBV) DIMENSION R(MAXOBV) INCLUDE 'DPCOZZ.INC' INCLUDE 'DPCOZI.INC' EQUIVALENCE (GARBAG(IGARB1),Y1(1)) EQUIVALENCE (GARBAG(IGARB2),XTEMP1(1)) EQUIVALENCE (GARBAG(IGARB3),XTEMP2(1)) EQUIVALENCE (GARBAG(IGARB4),XTEMP3(1)) EQUIVALENCE (GARBAG(IGARB5),XTEMP4(1)) EQUIVALENCE (GARBAG(IGARB6),XTEMP5(1)) EQUIVALENCE (GARBAG(IGARB7),XTEMP6(1)) EQUIVALENCE (GARBAG(IGARB8),XTEMP7(1)) EQUIVALENCE (GARBAG(IGARB9),XTEMP8(1)) EQUIVALENCE (GARBAG(IGAR10),XTEMP9(1)) EQUIVALENCE (GARBAG(JGAR11),XTMP10(1)) EQUIVALENCE (GARBAG(JGAR12),R(1)) EQUIVALENCE (IGARBG(1),ITEMP1(1)) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOST.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 DATA MINSIZ/5/ DATA MINSI2/30/ C IFOUND='NO' IERROR='NO' C ISUBN1='DPPO' ISUBN2='TP ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=2 MINN2=MINSI2 C ICOLR=0 C C ************************************************** C ** TREAT THE PEAKS OVER THRESHOLD PLOT CASE ** C ************************************************** C IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'POTP')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPOTP--') 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,ISUBRO 53 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'POTP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASPL='POTP' C IF(ICOM.EQ.'POT ')THEN IF(NUMARG.GE.1)THEN IF(IHARG(1).EQ.'PLOT')THEN ILASTC=1 GOTO119 ENDIF ENDIF ENDIF C IF(ICOM.EQ.'PEAK')THEN IF(NUMARG.GE.3)THEN IF(IHARG(1).EQ.'OVER'.AND.IHARG(2).EQ.'THRE'.AND. 1 IHARG(3).EQ.'PLOT')THEN ILASTC=3 GOTO119 ENDIF ENDIF ENDIF C GOTO9000 C 119 CONTINUE CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) IFOUND='YES' C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'POTP') 1CALL 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(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'POTP') 1CALL 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'.OR.ISUBRO.EQ.'POTP')THEN WRITE(ICOUT,311)IHLEFT,IHLEF2,ICOLL,NLEFT 311 FORMAT('IHLEFT,IHLEF2,ICOLL,NLEFT = ',A4,A4,I8,I8) CALL DPWRST('XXX','BUG ') ENDIF C C ****************************************************** C ** STEP 4-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS ** C ** (NLEFT) FOR THE RESPONSE VARIABLE IS POSITIVE. ** C ****************************************************** C ISTEPN='4' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'POTP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.LT.MINN2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,411) 411 FORMAT('***** ERROR IN PEAKS OVER THRESHOLD PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,412)IHLEFT,IHLEF2 412 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS IN VARIABLE ', 1 A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,413) 413 FORMAT(' FOR WHICH A PEAKS OVER THRESHOLD PLOT WAS TO') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,415)MINN2 415 FORMAT(' HAVE BEEN FORMED MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,416) 416 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,417) 417 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,418)(IANS(I),I=1,MIN(80,IWIDTH)) 418 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF 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(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'POTP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,581) 581 FORMAT('***** INTERNAL ERROR IN DPPOTP') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,582) 582 FORMAT(' AT BRANCH POINT 481--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,583) 583 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH NUMARG HAD ', 1 'PREVIOUSLY') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,585)NUMARG 585 FORMAT(' PASSED THIS TEST ONCE ALREADY. VALUE OF ', 1 'NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,586) 586 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,417) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,418)(IANS(I),I=1,MIN(80,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C DO500J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')THEN ICASEQ='SUBS' ILOCQ=J1 GOTO590 ELSEIF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')THEN ICASEQ='SUBS' ILOCQ=J1 GOTO590 ELSEIF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')THEN ICASEQ='FOR' ILOCQ=J1 GOTO590 ENDIF 500 CONTINUE C 590 CONTINUE IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'POTP')THEN WRITE(ICOUT,591)NUMARG,ILOCQ,ICASEQ 591 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF C C ****************************************************** C ** STEP 6-- ** C ** THIS COMMAND WILL ACCEPT EITHER A ONE VARIABLE ** C ** SYNTAX OR A TWO VARIABLE SYNTAX. ZERO ** C ** OR MORE THAN TWO VARIABLES IS AN ERROR. ** C ****************************************************** C ISTEPN='6' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'POTP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 C IF(NUMV2.EQ.2)THEN IHRIGH=IHARG(2) IHRIG2=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHRIGH,IHRIG2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLR=IVALUE(ILOCV) NRIGH=IN(ILOCV) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'POTP')THEN WRITE(ICOUT,661)IHRIGH,IHRIG2,ICOLR,NRIGH 661 FORMAT('IHRIGH,IHRIG2,ICOLR,NRIGH = ',A4,A4,I8,I8) CALL DPWRST('XXX','BUG ') ENDIF C IF(NRIGH.LT.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,671) 671 FORMAT('***** ERROR IN PEAKS OVER THRESHOLD PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,672)IHLEFT,IHLEF2 672 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS IN ', 1 'VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,673) 673 FORMAT(' FOR WHICH A PEAKS OVER THRESHOLD PLOT WAS TO') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,675) 675 FORMAT(' HAVE BEEN FORMED MUST BE AT LEAST 1;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,676) 676 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,677) 677 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,678)(IANS(I),I=1,MIN(80,IWIDTH)) 678 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C ENDIF C IF(NUMV2.GT.2 .OR. NUMV2.LT.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,601) 601 FORMAT('***** ERROR IN PEAKS OVER THRESHOLD PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,602) 602 FORMAT(' FOR A PEAKS OVER THRESHOLD PLOT, THE NUMBER OF') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,609) 609 FORMAT(' VARIABLES MUST BE 1 OR 2; SUCH WAS NOT THE ', 1 'CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,612)NUMV2 612 FORMAT(' THE SPECIFIED NUMBER OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,613) 613 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,418)(IANS(I),I=1,MIN(80,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF 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(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'POTP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'SUBS')THEN NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4) NQ=NIOLD ELSEIF(ICASEQ.EQ.'FOR')THEN NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1 NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR ELSE DO715I=1,NLEFT ISUB(I)=1 715 CONTINUE NQ=NLEFT ENDIF C J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO760I=1,IMAX IF(ISUB(I).EQ.0)GOTO760 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) 760 CONTINUE NLOCAL=J C C VALUES FOR MEAN RETURN INTERVALS. THESE DO NOT USE C SUBSET/EXCEPT/FOR CLAUSE. C IF(NUMV2.EQ.2)THEN DO770I=1,NRIGH IJ=MAXN*(ICOLR-1)+I IF(ICOLR.LE.MAXCOL)R(I)=V(IJ) IF(ICOLR.EQ.MAXCP1)R(I)=PRED(I) IF(ICOLR.EQ.MAXCP2)R(I)=RES(I) IF(ICOLR.EQ.MAXCP3)R(I)=YPLOT(I) IF(ICOLR.EQ.MAXCP4)R(I)=XPLOT(I) IF(ICOLR.EQ.MAXCP5)R(I)=X2PLOT(I) IF(ICOLR.EQ.MAXCP6)R(I)=TAGPLO(I) 770 CONTINUE NRET=NRIGH ELSE NRET=0 ENDIF C C ***************************************************** C ** STEP 8-- ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** C ** RESET THE VECTOR D(.) TO ALL ONES. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ***************************************************** C ISTEPN='8' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'POTP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPOTME.EQ.'PPCC')THEN IHP='GAMM' IHP2='A1 ' 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 GAMMA1=-3.0 ELSE GAMMA1=VALUE(ILOCP) ENDIF C IHP='GAMM' IHP2='A2 ' 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 GAMMA2=3.0 ELSE GAMMA2=VALUE(ILOCP) ENDIF C IF(GAMMA1.GT.GAMMA2)THEN GAMMSV=GAMMA1 GAMMA1=GAMMA2 GAMMA2=GAMMSV ENDIF ENDIF C IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'POTP')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811) 811 FORMAT('***** FROM THE MIDDLE OF DPPOTP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,812)ICASPL,IPOTME,NUMV2 812 FORMAT('ICASPL,IPOTME,NUMV2 = ',A4,2X,I8) CALL DPWRST('XXX','BUG ') ENDIF C CALL DPPOT2(Y1,NLOCAL,ICASPL,IPOTME,IPOTDI,IPOTLF,IPOTAX, 1IPOTIT,IPOTNP,PPOTTH,PPOTIN,PPOTPE,PPOTTO, 1IGEPDF,MINSIZ,MINSI2, 1XTEMP1,XTEMP2,XTEMP3,XTEMP4,XTEMP5,XTEMP6,XTEMP7, 1XTEMP8,XTEMP9,XTMP10,ITEMP1,MAXOBV, 1R,NRET, 1ICAPSW,ICAPTY,GAMMA1,GAMMA2, 1IBOOSS,IBOOPA,ISEED, 1IRTFPS,IRTFFF,NCRTF1,IRTFFP,NCRTF2, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'POTP')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPOTP--') 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 = ', 1 I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') IF(NPLOTP.GE.1)THEN DO9020I=1,NPLOTP WRITE(ICOUT,9021)I,Y(I),X(I),D(I) 9021 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9020 CONTINUE ENDIF ENDIF C RETURN END SUBROUTINE DPPOT2(Y,N,ICASPL,IPOTME,IPOTDI,IPOTLF,IPOTAX, 1IPOTIT,IPOTNP,APOTTH,APOTIN,APOTPE,APOTTO, 1IGEPDF,MINSIZ,MINSI2, 1XTEMP1,XTEMP2,XTEMP3,XTEMP4,XTEMP5,XTEMP6,XTEMP7, 1XTEMP8,XTEMP9,XTMP10,ITEMP1,MAXNXT, 1R,NRET, 1ICAPSW,ICAPTY,GAMMA1,GAMMA2, 1IBOOSS,IBOOPA,ISEED, 1IRTFPS,IRTFFF,NCRTF1,IRTFFP,NCRTF2, 1Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE A PEAKS OVER THRESHOLD PLOT 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 BUREAU OF STANDARDS. 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--2005/04 C ORIGINAL VERSION--APRIL 2005. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IPOTME CHARACTER*4 IPOTDI CHARACTER*4 IPOTLF CHARACTER*4 IPOTAX CHARACTER*4 IGEPDF CHARACTER*4 IBOOPA CHARACTER*4 ICAPSW CHARACTER*4 ICAPTY CHARACTER*4 IRTFFF CHARACTER*4 IRTFFP CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 IWRITE CHARACTER*4 IPRISV CHARACTER*4 IFEESV CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 IADEDF CHARACTER*4 ILGADF CHARACTER*4 ISKNDF CHARACTER*4 IMETHD CHARACTER*4 ICASJB CHARACTER*4 ICENSO CHARACTER*4 IQUAME CHARACTER*4 ICASP2 CHARACTER*4 ISUBN0 C PARAMETER (MAXHED=50) INTEGER IWIDTH(MAXHED) INTEGER NUMDI2(MAXHED) CHARACTER*8 ALIGN(MAXHED) CHARACTER*8 VALIGN(MAXHED) COMMON/HTML4/IWIDTH,NUMDI2,ALIGN,VALIGN CHARACTER*40 IVALUE(MAXHED) INTEGER NCHAR(MAXHED) REAL AVALUE(MAXHED) C LOGICAL IFLAG1 LOGICAL IFLAG2 LOGICAL IFLAG3 C CHARACTER*1 IBASLC CHARACTER*132 ITTEMP CHARACTER*132 IHEAD C CHARACTER*4 IRTFMD COMMON/COMRTF/IRTFMD C DOUBLE PRECISION DP DOUBLE PRECISION DG DOUBLE PRECISION DPPF DOUBLE PRECISION DTEMP DOUBLE PRECISION DXR C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) DIMENSION XTEMP3(*) DIMENSION XTEMP4(*) DIMENSION XTEMP5(*) DIMENSION XTEMP6(*) DIMENSION XTEMP7(*) DIMENSION XTEMP8(*) DIMENSION XTEMP9(*) DIMENSION XTMP10(*) DIMENSION R(*) DIMENSION ITEMP1(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) C INCLUDE 'DPCOF2.INC' 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 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 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='DPPO' ISUBN2='T2 ' CALL DPCONA(92,IBASLC) C IERROR='NO' IWRITE='OFF' IPRISV=IPRINT IFEESV=IFEEDB C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C ISTEPN='1' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'POT2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(N.LT.MINSI2)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN PEAKS OVER THRESHOLD PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32)MINSI2 32 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST ', 1 I8,';') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,34)N 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'POT2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71) 71 FORMAT('***** AT THE BEGINNING OF DPPOT2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)ICASPL,IPOTME,IPOTIT,IPOTNP,N 72 FORMAT('ICASPL,IPOTME,IPOTIT,IPOTNP,N, = ',A4,2X,A4,3(2X,I8)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,74)APOTTH,APOTIN 74 FORMAT('APOTTH,APOTIN = ',2G15.7) CALL DPWRST('XXX','BUG ') DO85I=1,N WRITE(ICOUT,86)I,Y(I) 86 FORMAT('I,Y(I) = ',I8,E12.5) CALL DPWRST('XXX','BUG ') 85 CONTINUE ENDIF C C THE BASIC ALGORITHM FOR GENERATING A PEAKS OVER THRESHOLDS C PLOT IS: C C 1. START WITH AN INITIAL THRESHOLD VALUE C USER CAN SPECIFY INITIAL THRESHOLD OR THE NUMBER OF POINTS C TO BE EXTRACTED FOR THE INITIAL THRESHOLD C 2. EXTRACT THE POINTS IN THE DATA SET ABOVE THIS THRESHOLD C 3. FOR THIS EXTRACTED DATA SET, ESTIMATE THE PARAMETERS OF C THE DISTRIBUTION. NOTE THAT DATAPLOT ALLOWS YOU TO SELECT C BOTH THE TYPE OF DISTRIBUTION BEING ESTIMATED (GENERALIZED C PATRETO, WEIBULL, GUMBEL, OR FRECHET) AND THE METHOD USED C TO ESTIMATE THE PARAMETERS (AVAILABLE METHODS DEPEND ON C THE DISTRIBUTION). C 4. CALCULATE A STANDARD DEVIATION FOR THE PARAMETER ESTIMATES. C 5. INCREMENT THE THRESHOLD AND REPEAT STEPS 1-4. C 6. PLOT THE RESULTING PARAMETER ESTIMATES ALONG WITH THE C "CONFIDENCE LIMITS" (USUALLY +/- 2*SD). C C ******************************************** C ** STEP 2-- ** C ** SORT THE DATA ** C ******************************************** C ISTEPN='2' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'POT2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NRET.GT.0)THEN IR50=0 DO101I=1,NRET IF(ABS(R(I) - 50.0).LT.1.0)THEN IR50=1 GOTO109 ENDIF 101 CONTINUE 109 CONTINUE IF(IR50.EQ.0)THEN NRET=NRET+1 R(NRET)=50.0 ENDIF CALL SORT(R,NRET,R) IR50=0 DO111I=1,NRET IF(ABS(R(I) - 50.0).LT.1.0)THEN IR50=I GOTO119 ENDIF 111 CONTINUE 119 CONTINUE ENDIF C CALL SORT(Y,N,XTEMP1) DO210I=1,N Y(I)=XTEMP1(I) 210 CONTINUE C IF(APOTTH.GT.0.0)THEN ATHRSH=APOTTH ELSEIF(IPOTNP.GT.0)THEN INDX=N-IPOTNP+1 IF(INDX.LT.1)INDX=1 IF(INDX.GT.N)INDX=N ATHRSH=Y(INDX) ELSE NKEEP=INT(REAL(N)*0.025 + 0.5) IF(NKEEP.LT.MINSIZ)NKEEP=MINSIZ ATHRSH=Y(N-NKEEP+1) ENDIF C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'POT2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,211) 211 FORMAT('ATHRSH,NKEEP = ',G15.7,2X,I8) CALL DPWRST('XXX','BUG ') ENDIF C IOUNI1=IST1NU IFILE1=IST1NA ISTAT1=IST1ST IFORM1=IST1FO IACCE1=IST1AC IPROT1=IST1PR ICURS1=IST1CS ISUBN0='POT2' IERRF1='NO' C IREWI1='ON' CALL DPOPFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1 IREWI1,ISUBN0,IERRF1,IBUGG3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IF(NRET.GT.0)THEN IOUNI2=IST2NU IFILE2=IST2NA ISTAT2=IST2ST IFORM2=IST2FO IACCE2=IST2AC IPROT2=IST2PR ICURS2=IST2CS ISUBN0='POT2' IERRF2='NO' C IREWI2='ON' CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1 IREWI2,ISUBN0,IERRF2,IBUGG3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 ENDIF C C ******************************************** C ** STEP 3-- ** C ** LOOP THROUGH THE THRESHOLDS ** C ******************************************** C ISTEPN='3' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'POT2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'ON')THEN IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN NCTIT=0 IFLAG1=.TRUE. IFLAG2=.FALSE. CALL DPHTM1(ITTEMP,NCTIT,IFLAG1,IFLAG2) WRITE(ICOUT,1261) 1261 FORMAT('

Peaks Over Threshold Analysis

') CALL DPWRST('XXX','WRIT') ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN CCCCC ITTEMP='Peaks Over Threshold Analysis' CCCCC NCTIT=29 ITTEMP=' ' NCTIT=0 IFLAG1=.TRUE. IFLAG2=.FALSE. CALL DPLAT8(ITTEMP,NCTIT,IFLAG1,IFLAG2) ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN 6591 FORMAT(A1,'f',I1) IF(IRTFFF.EQ.'Times New Roman')THEN ITEMP=0 ELSEIF(IRTFFF.EQ.'Lucida Sans')THEN ITEMP=6 ELSEIF(IRTFFF.EQ.'Arial')THEN ITEMP=2 ELSEIF(IRTFFF.EQ.'Bookman')THEN ITEMP=3 ELSEIF(IRTFFF.EQ.'Georgia')THEN ITEMP=4 ELSEIF(IRTFFF.EQ.'Tahoma')THEN ITEMP=5 ELSEIF(IRTFFF.EQ.'Verdana')THEN ITEMP=7 ELSE ITEMP=0 ENDIF IRTFMD='OFF' ITTEMP=' b Peaks Over Threshold Analysis' ITTEMP(1:1)=IBASLC C NCTIT=32 IFLAG1=.TRUE. CALL DPRTF8(ITTEMP,NCTIT,ITEMP,IFLAG1) ELSE WRITE(ICOUT,261) 261 FORMAT(10X,'PEAKS OVER THRESHOLD ANALYSIS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') ENDIF ENDIF C ICNT=0 NLOCSV=0 DO300I=1,IPOTIT C U=ATHRSH + REAL(I-1)*APOTIN NLOCAL=0 DO310J=1,N IF(Y(J).GE.U)THEN NLOCAL=NLOCAL+1 XTEMP1(NLOCAL)=Y(J) ENDIF 310 CONTINUE C IF(NLOCAL.EQ.NLOCSV)GOTO300 NLOCSV=NLOCAL C IF(NLOCAL.LT.MINSIZ)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311)U 311 FORMAT('***** WARNING--FOR A THRESHOLD OF ',G12.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313)NLOCAL 313 FORMAT(' ONLY ',I8,' ABOVE THE THRESHOLD. THIS IS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)MINSIZ 315 FORMAT(' BELOW THE REQUIRED ',I8,'. THIS ITERATION ', 1 'SKIPPED.') CALL DPWRST('XXX','BUG ') GOTO300 ENDIF C IF(IPOTDI.EQ.'GPAR')THEN C C DEHAAN METHOD C IF(IPOTME.EQ.'DEHA')THEN C IFEEDB='OFF' IPRINT='OFF' C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'POT2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,321) 321 FORMAT('ATHRSH,NKEEP = ',G15.7,2X,I8) CALL DPWRST('XXX','BUG ') ENDIF C THRESH=CPUMIN CALL DPDEGP(XTEMP1,NLOCAL, 1 XTEMP2,MAXNXT, 1 GAMMA,A,GAMMSD,THRESH, 1 GAMMA2,ALOC,SCALE, 1 IGEPDF,ICAPSW,ICAPTY, 1 APOTTO, 1 ISUBRO,IBUGG3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(IGEPDF.NE.'SIMI')THEN GAMMA=-GAMMA ENDIF C ICNT=ICNT+1 Y2(ICNT)=GAMMA IF(IPOTAX.EQ.'POIN')THEN X2(ICNT)=REAL(NLOCAL) ELSE X2(ICNT)=U ENDIF D2(ICNT)=1.0 IF(GAMMSD.GT.0.0)THEN ICNT=ICNT+1 Y2(ICNT)=GAMMA + 2.0*GAMMSD IF(IPOTAX.EQ.'POIN')THEN X2(ICNT)=REAL(NLOCAL) ELSE X2(ICNT)=U ENDIF D2(ICNT)=2.0 ICNT=ICNT+1 Y2(ICNT)=GAMMA - 2.0*GAMMSD IF(IPOTAX.EQ.'POIN')THEN X2(ICNT)=REAL(NLOCAL) ELSE X2(ICNT)=U ENDIF D2(ICNT)=3.0 ENDIF C ASCALE=A ALOC=U C IFEEDB=IFEESV IPRINT=IPRISV C C CME METHOD C ELSEIF(IPOTME.EQ.'CME')THEN C IFEEDB='OFF' IPRINT='OFF' C THRESH=0.0 CALL DPCMGP(XTEMP1,NLOCAL, 1 XTEMP2,MAXNXT, 1 GAMMA,A,GAMMSD,THRESH, 1 XTEMP2,XTEMP3,XTEMP4,ITEMP1, 1 IGEPDF,ICAPSW,ICAPTY, 1 APOTTO, 1 ISUBRO,IBUGG3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(IGEPDF.NE.'SIMI')THEN GAMMA=-GAMMA ENDIF C ICNT=ICNT+1 Y2(ICNT)=GAMMA IF(IPOTAX.EQ.'POIN')THEN X2(ICNT)=REAL(NLOCAL) ELSE X2(ICNT)=U ENDIF D2(ICNT)=1.0 IF(GAMMSD.GT.0.0)THEN ICNT=ICNT+1 Y2(ICNT)=GAMMA + 2.0*GAMMSD IF(IPOTAX.EQ.'POIN')THEN X2(ICNT)=REAL(NLOCAL) ELSE X2(ICNT)=U ENDIF D2(ICNT)=2.0 ICNT=ICNT+1 Y2(ICNT)=GAMMA - 2.0*GAMMSD IF(IPOTAX.EQ.'POIN')THEN X2(ICNT)=REAL(NLOCAL) ELSE X2(ICNT)=U ENDIF D2(ICNT)=3.0 ENDIF C ASCALE=A ALOC=U C IFEEDB=IFEESV IPRINT=IPRISV C C PPCC METHOD C ELSEIF(IPOTME.EQ.'PPCC')THEN C IFEEDB='OFF' IPRINT='OFF' C NUMDIS=50 ANUMDI=REAL(NUMDIS) GAMLL=GAMMA1 GAMUL=GAMMA2 CORRMX=-99.0 MINMAX=1 CALL UNIMED(NLOCAL,XTEMP2) DO360IDIS=1,50 AIDIS=IDIS SHAPE=GAMLL+((AIDIS-1.0)/(ANUMDI-1.0))*(GAMUL-GAMLL) ICNT2=0 DO370II=1,NLOCAL ICNT2=ICNT2+1 CALL GEPPPF(XTEMP2(II),SHAPE,MINMAX,IGEPDF, 1 XTEMP3(ICNT2)) 370 CONTINUE C IWRITE='OFF' CALL CORR(XTEMP3,XTEMP1,NLOCAL,IWRITE,CC,IBUGG3,IERROR) IF(CC.GT.CORRMX)THEN CORRMX=CC SHAPE1=SHAPE CALL LINFI2(XTEMP3,XTEMP1,NLOCAL, 1 ALOC,SCALE, 1 ISUBRO,IBUGG3,IERROR) ENDIF 360 CONTINUE C C USE BOOTSTRAP TO OBTAIN 95% CONFIDENCE INTERVAL FOR C SHAPE PARAMETER C ICASP2='GECP' ICASJB='BOOT' ICENSO='OFF' IADEDF='OFF' ILGADF='OFF' ISKNDF='OFF' IMETHD='KAPL' NHOR1=0 NPERC=0 IPPCDP=0 C DO380IRESAM=1,IBOOSS IF(IBOOPA.EQ.'PARA')THEN IF(SHAPE1.EQ.0.0)THEN CALL EXPRAN(NLOCAL,ISEED,XTEMP5) ELSE CALL UNIRAN(NLOCAL,ISEED,XTEMP5) DG=DBLE(SHAPE1) IF(IGEPDF.EQ.'JOHN')THEN DO381II=1,NLOCAL DP=DBLE(XTEMP5(II)) DPPF=(-1.0D0/DG)*(((1.0D0-DP)**DG)-1.0D0) XTEMP5(II)=REAL(DPPF) 381 CONTINUE ELSE DO382II=1,NLOCAL DP=DBLE(XTEMP5(II)) DPPF=(1.0D0/DG)*(((1.0D0-DP)**(-DG))-1.0D0) XTEMP5(II)=REAL(DPPF) 382 CONTINUE ENDIF ENDIF NS3=NLOCAL C ELSE CALL DPJBS3(XTEMP1,NLOCAL,ICASJB,IRESAM,ISEED, 1 XTEMP5,NS3, 1 ITEMP1, 1 XTEMP6, 1 IBUGG3,IERROR) ENDIF CALL DPJBCP( 1 XTEMP5,XTEMP6,NS3, 1 ICASP2,ICENSO,IMETHD,IPPCDP,MAXNXT,MINMAX, 1 XTEMP2,XTEMP3,XTEMP4,XTEMP7, 1 NHOR1,IGEPDF,IADEDF,ILGADF,ISKNDF, 1 XTEMP8,XTEMP9,NPERC, 1 PPA0,PPA1,SHAPE,ACORR, 1 IBUGG3,ISUBRO,IERROR) XTMP10(IRESAM)=SHAPE 380 CONTINUE C IQUAME='ORDE' QNT=0.025 NTEMP=IBOOSS CALL QUANT(QNT,XTMP10,NTEMP,IWRITE,XTEMP2,MAXNXT, 1 IQUAME, 1 XQU025,IBUGG3,IERROR) QNT=0.975 CALL QUANT(QNT,XTMP10,NTEMP,IWRITE,XTEMP2,MAXNXT, 1 IQUAME, 1 XQU975,IBUGG3,IERROR) C ICNT=ICNT+1 Y2(ICNT)=SHAPE1 IF(IPOTAX.EQ.'POIN')THEN X2(ICNT)=REAL(NLOCAL) ELSE X2(ICNT)=U ENDIF D2(ICNT)=1.0 ICNT=ICNT+1 Y2(ICNT)=XQU025 IF(IPOTAX.EQ.'POIN')THEN X2(ICNT)=REAL(NLOCAL) ELSE X2(ICNT)=U ENDIF D2(ICNT)=2.0 ICNT=ICNT+1 Y2(ICNT)=XQU975 IF(IPOTAX.EQ.'POIN')THEN X2(ICNT)=REAL(NLOCAL) ELSE X2(ICNT)=U ENDIF D2(ICNT)=3.0 C ASCALE=SCALE GAMMA=SHAPE1 C IFEEDB=IFEESV IPRINT=IPRISV C C METHOD OF MOMENTS C ELSEIF(IPOTME.EQ.'MOME')THEN C IFEEDB='OFF' IPRINT='OFF' C CALL MEAN(XTEMP1,NLOCAL,IWRITE,XMEAN,IBUGG3,IERROR) CALL SD(XTEMP1,NLOCAL,IWRITE,XSD,IBUGG3,IERROR) XVAR=XSD**2 C GAMMA=0.5*(XMEAN*XMEAN/XVAR - 1.0) SCALE=0.5*XMEAN*(XMEAN*XMEAN/XVAR + 1.0) IF(IGEPDF.EQ.'SIMI')THEN GAMMA=-GAMMA ENDIF C ICNT=ICNT+1 Y2(ICNT)=GAMMA X2(ICNT)=REAL(NLOCAL) D2(ICNT)=1.0 C IFEEDB=IFEESV IPRINT=IPRISV C C MAXIMUM LIKELIHOOD METHOD C ELSEIF(IPOTME.EQ.'MLE ')THEN ENDIF C C NOW DO THE FOLLOWING: C C 1) WRITE INFO TO DPST1F.DAT (POINTS ABOVE THRESHOLD, C THRESHOLD, ESTIMATES OF GAMMA, LOC, SCALE C C 2) IF REQUESTED, COMPUTE MEAN RECURRENCE INTERVALS. C C 3) WRITE MEAN RECURRENCE INTERVAL INFO TO FILE. C WRITE(IOUNI1,'(I8,2X,4E15.7)')NLOCAL,U,GAMMA,ALOC,ASCALE IF(NRET.GT.0)THEN ALAMB=1.0 IF(APOTPE.GT.0.0)THEN ALAMB=REAL(NLOCAL)/(REAL(N)/APOTPE) ENDIF C IF(IPRINT.EQ.'ON')THEN IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN C NCTIT=0 IFLAG1=.FALSE. IFLAG2=.TRUE. CALL DPHTM1(ITTEMP,NCTIT,IFLAG1,IFLAG2) IWDT1=350 IWDT2=150 C ITTEMP='
Iteration :' WRITE(ITTEMP(18:19),'(I2)')I NCTEMP=24 NUMDIG=-1 AVAL=0.0 CALL DPHTM3(ITTEMP,NCTEMP,AVAL,NUMDIG,IWDT1,IWDT2) ITTEMP='Sample Size:' NCTEMP=12 NUMDIG=0 AVAL=REAL(N) CALL DPHTM3(ITTEMP,NCTEMP,AVAL,NUMDIG,IWDT1,IWDT2) ITTEMP='Threshold:' NCTEMP=10 NUMDIG=-2 AVAL=U CALL DPHTM3(ITTEMP,NCTEMP,AVAL,NUMDIG,IWDT1,IWDT2) ITTEMP='Number of Points Above the Threshold:' NCTEMP=37 NUMDIG=0 AVAL=REAL(NLOCAL) CALL DPHTM3(ITTEMP,NCTEMP,AVAL,NUMDIG,IWDT1,IWDT2) ITTEMP='Value of Lambda:' NCTEMP=16 NUMDIG=-2 AVAL=ALAMB CALL DPHTM3(ITTEMP,NCTEMP,AVAL,NUMDIG,IWDT1,IWDT2) ITTEMP=' ' NCTEMP=0 NUMDIG=-1 AVAL=0.0 CALL DPHTM3(ITTEMP,NCTEMP,AVAL,NUMDIG,IWDT1,IWDT2) IF(IPOTME.EQ.'DEHA')THEN ITTEMP='Parameter Estimation (de Haan Method):' NCTEMP=38 NUMDIG=-1 AVAL=0.0 CALL DPHTM3(ITTEMP,NCTEMP,AVAL,NUMDIG,IWDT1,IWDT2) ELSEIF(IPOTME.EQ.'CME')THEN ITTEMP='Parameter Estimation (CME Method):' NCTEMP=34 NUMDIG=-1 AVAL=0.0 CALL DPHTM3(ITTEMP,NCTEMP,AVAL,NUMDIG,IWDT1,IWDT2) ELSEIF(IPOTME.EQ.'PPCC')THEN ITTEMP='Parameter Estimation (PPCC Method):' NCTEMP=35 NUMDIG=-1 AVAL=0.0 CALL DPHTM3(ITTEMP,NCTEMP,AVAL,NUMDIG,IWDT1,IWDT2) ENDIF ITTEMP='Estimate of Shape Parameter (Gamma):' NCTEMP=36 NUMDIG=-2 AVAL=GAMMA CALL DPHTM3(ITTEMP,NCTEMP,AVAL,NUMDIG,IWDT1,IWDT2) IF(IPOTME.EQ.'DEHA' .OR. IPOTME.EQ.'CME')THEN ITTEMP='Standard Deviation of Gamma:' NCTEMP=28 NUMDIG=-2 AVAL=GAMMA CALL DPHTM3(ITTEMP,NCTEMP,AVAL,NUMDIG,IWDT1,IWDT2) ELSEIF(IPOTME.EQ.'PPCC')THEN ITTEMP='Lower 95% Confidence Limit for Gamma:' NCTEMP=37 NUMDIG=-2 AVAL=XQU025 CALL DPHTM3(ITTEMP,NCTEMP,AVAL,NUMDIG,IWDT1,IWDT2) ITTEMP='Upper 95% Confidence Limit for Gamma:' NCTEMP=37 NUMDIG=-2 AVAL=XQU975 CALL DPHTM3(ITTEMP,NCTEMP,AVAL,NUMDIG,IWDT1,IWDT2) ENDIF ITTEMP='Estimate of Location Parameter:' NCTEMP=31 NUMDIG=-2 AVAL=ALOC CALL DPHTM3(ITTEMP,NCTEMP,AVAL,NUMDIG,IWDT1,IWDT2) ITTEMP='Estimate of Scale Parameter:' NCTEMP=28 NUMDIG=-2 AVAL=ASCALE CALL DPHTM3(ITTEMP,NCTEMP,AVAL,NUMDIG,IWDT1,IWDT2) C IFLAG1=.TRUE. IFLAG2=.FALSE. NHEAD=0 CALL DPHTM2(IFLAG1,IFLAG2,NHEAD) C IFLAG1=.FALSE. IFLAG2=.TRUE. NCTIT=0 CALL DPHTM1(ITTEMP,NCTIT,IFLAG1,IFLAG2) IWIDTH(1)=200 IWIDTH(2)=200 IWIDTH(3)=200 VALIGN(1)='CENTER' VALIGN(2)='CENTER' VALIGN(3)='CENTER' ALIGN(1)='RIGHT' ALIGN(2)='RIGHT' ALIGN(3)='RIGHT' NUMDI2(1)=-2 NUMDI2(2)=-2 NUMDI2(3)=-2 IVALUE(1)='Mean Reccurence
Interval (R)' NCHAR(1)=31 IVALUE(2)='XR' NCHAR(2)=2 IFLAG1=.TRUE. IFLAG2=.TRUE. NHEAD=2 CALL DPHTM4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) C ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN C C FOLLOWING ATTEMPT TO RESOLVE PROBLEM WHERE LATEX HAS TOO C MANY TABLES TO RESOLVE. C IF(MOD(I,6).EQ.0)THEN WRITE(ICOUT,3301)IBASLC 3301 FORMAT(A1,'clearpage') CALL DPWRST('XXX','WRIT') ENDIF C IF(I.EQ.1)THEN ITTEMP='Peaks Over Threshold Analysis' NCTIT=29 ELSE ITTEMP=' ' NCTIT=0 ENDIF IHEAD=' ' NHEAD=0 IFLAG1=.TRUE. CALL DPLAT1(ITTEMP,NCTIT,IHEAD,NHEAD,IFLAG1) C IWIDTH(1)=0 IWIDTH(2)=0 IWIDTH(3)=0 VALIGN(1)=' ' VALIGN(2)=' ' VALIGN(3)=' ' ALIGN(1)='l' ALIGN(2)='r' ALIGN(3)='r' NUMDI2(1)=-2 NUMDI2(2)=-2 NUMDI2(3)=-2 AVALUE(1)=0.0 AVALUE(2)=0.0 NCHAR(1)=0 NCHAR(2)=0 IVALUE(1)=' ' IVALUE(2)=' ' NHEAD=2 IFLAG1=.FALSE. IFLAG2=.FALSE. IFLAG3=.TRUE. CALL DPLAT4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2,IFLAG3) C NHEAD=1 IFLAG1=.FALSE. IVALUE(1)='{ bf Iteration: }' WRITE(IVALUE(1)(17:18),'(I2)')I WRITE(IVALUE(1)(2:2),'(A1)')IBASLC NCHAR(1)=19 NCHAR(2)=0 NUMDI2(1)=-3 NHEAD=1 CALL DPLAT5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) NHEAD=1 IVALUE(1)='Sample Size:' NCHAR(1)=12 AVALUE(1)=REAL(N) NUMDI2(1)=0 CALL DPLAT5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) IVALUE(1)='Threshold:' NCHAR(1)=10 NUMDI2(1)=-2 AVALUE(1)=U CALL DPLAT5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) IVALUE(1)='Number of Points Above the Threshold:' NCHAR(1)=37 NUMDI2(1)=0 AVALUE(1)=REAL(NLOCAL) CALL DPLAT5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) IVALUE(1)='Value of Lambda:' NCHAR(1)=16 NUMDI2(1)=-2 AVALUE(1)=ALAMB CALL DPLAT5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) IVALUE(1)=' ' NCHAR(1)=1 NUMDI2(1)=-1 AVALUE(1)=0.0 CALL DPLAT5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) IF(IPOTME.EQ.'DEHA')THEN IVALUE(1)='Parameter Estimation (de Haan Method):' NCHAR(1)=38 NUMDI2(1)=-3 AVALUE(1)=0.0 CALL DPLAT5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) ELSEIF(IPOTME.EQ.'CME')THEN IVALUE(1)='Parameter Estimation (CME Method):' NCHAR(1)=34 NUMDI2(1)=-1 AVALUE(1)=0.0 CALL DPLAT5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) ELSEIF(IPOTME.EQ.'PPCC')THEN IVALUE(1)='Parameter Estimation (PPCC Method):' NCHAR(1)=35 NUMDI2(1)=-1 AVALUE(1)=0.0 CALL DPLAT5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) ENDIF IVALUE(1)='Estimate of Shape Parameter (Gamma):' NCHAR(1)=36 NUMDI2(1)=-2 AVALUE(1)=GAMMA CALL DPLAT5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) IF(IPOTME.EQ.'DEHA' .OR. IPOTME.EQ.'CME')THEN IVALUE(1)='Standard Deviation of Gamma:' NCHAR(1)=28 NUMDI2(1)=-2 AVALUE(1)=GAMMSD CALL DPLAT5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) ELSEIF(IPOTME.EQ.'PPCC')THEN IVALUE(1)='Lower 95% Confidence Limit for Gamma:' NCHAR(1)=37 NUMDI2(1)=-2 AVALUE(1)=XQU025 CALL DPLAT5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) IVALUE(1)='Upper 95% Confidence Limit for Gamma:' NCHAR(1)=37 NUMDI2(1)=-2 AVALUE(1)=XQU975 CALL DPLAT5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) ENDIF IVALUE(1)='Estimate of Location Parameter:' NCHAR(1)=31 NUMDI2(1)=-2 AVALUE(1)=ALOC CALL DPLAT5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) IVALUE(1)='Estimate of Scale Parameter:' NCHAR(1)=28 NUMDI2(1)=-2 AVALUE(1)=ASCALE CALL DPLAT5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C IFLAG1=.TRUE. IFLAG2=.FALSE. IFLAG3=.FALSE. NHEAD=0 CALL DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD) C ITTEMP=' ' NCTIT=0 IHEAD=' ' NHEAD=0 IFLAG1=.FALSE. CALL DPLAT1(ITTEMP,NCTIT,IHEAD,NHEAD,IFLAG1) NHEAD=2 IFLAG1=.TRUE. IFLAG2=.TRUE. IVALUE(1)='Mean Reccurence Interval (R)' NCHAR(1)=28 IVALUE(2)='XR' NCHAR(2)=2 IFLAG3=.TRUE. CALL DPLAT4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2,IFLAG3) C ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN CALL DPCONA(92,IBASLC) CCCCC ITTEMP=' ' CCCCC NCTIT=0 CCCCC IHEAD=' ' CCCCC NHEAD=0 CCCCC IFLAG1=.TRUE. CCCCC CALL DPLAT1(ITTEMP,NCTIT,IHEAD,NHEAD,IFLAG1) C IDEFPS=20 IFRST=IRTFPS*5000/IDEFPS IINC1=IRTFPS*2000/IDEFPS IWIDTH(1)=IFRST IWIDTH(2)=IFRST+IINC1 IWIDTH(3)=IWIDTH(2)+IINC1 VALIGN(1)='b' VALIGN(2)='b' VALIGN(3)='b' ALIGN(1)='l' ALIGN(2)='r' ALIGN(3)='r' NUMDI2(1)=-2 NUMDI2(2)=-2 NUMDI2(3)=-2 AVALUE(1)=0.0 AVALUE(2)=0.0 NCHAR(1)=0 NCHAR(2)=0 IVALUE(1)=' ' IVALUE(2)=' ' NHEAD=2 IFLAG1=.FALSE. IFLAG2=.FALSE. CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) ALIGN(1)='l' ALIGN(2)='r' ALIGN(3)='r' C IFLAG1=.FALSE. IVALUE(1)=' b Iteration:' IVALUE(1)(1:1)=IBASLC NCHAR(1)=13 NUMDI2(2)=0 AVALUE(2)=REAL(I) NHEAD=1 CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) NHEAD=1 IVALUE(1)='Sample Size:' NCHAR(1)=12 AVALUE(2)=REAL(N) NUMDI2(2)=0 CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) IVALUE(1)='Threshold:' NCHAR(1)=10 NUMDI2(2)=-2 AVALUE(2)=U CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) IVALUE(1)='Number of Points Above the Threshold:' NCHAR(1)=37 NUMDI2(2)=0 AVALUE(2)=REAL(NLOCAL) CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) IVALUE(1)='Value of Lambda:' NCHAR(1)=16 NUMDI2(2)=-2 AVALUE(2)=ALAMB CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) IF(IPOTME.EQ.'DEHA')THEN IVALUE(1)=' b Parameter Estimation (de Haan Method):' IVALUE(1)(1:1)=IBASLC NCHAR(1)=41 NCHAR(2)=0 IFLAG1=.FALSE. IFLAG2=.FALSE. NHEAD2=2 CALL DPRTF4(IVALUE,NCHAR,NHEAD2,IFLAG1,IFLAG2) ELSEIF(IPOTME.EQ.'CME')THEN IVALUE(1)=' b Parameter Estimation (CME Method):' IVALUE(1)(1:1)=IBASLC NCHAR(1)=37 NCHAR(2)=0 IFLAG1=.FALSE. IFLAG2=.FALSE. NHEAD2=2 CALL DPRTF4(IVALUE,NCHAR,NHEAD2,IFLAG1,IFLAG2) ELSEIF(IPOTME.EQ.'PPCC')THEN IVALUE(1)=' b Parameter Estimation (PPCC Method):' IVALUE(1)(1:1)=IBASLC NCHAR(1)=38 NCHAR(2)=0 IFLAG1=.FALSE. IFLAG2=.FALSE. NHEAD2=2 CALL DPRTF4(IVALUE,NCHAR,NHEAD2,IFLAG1,IFLAG2) ENDIF IVALUE(1)='Estimate of Shape Parameter (Gamma):' NCHAR(1)=36 NUMDI2(2)=-2 AVALUE(2)=GAMMA CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) IF(IPOTME.EQ.'DEHA' .OR. IPOTME.EQ.'CME')THEN IVALUE(1)='Standard Deviation of Gamma:' NCHAR(1)=28 NUMDI2(2)=-2 AVALUE(2)=GAMMSD CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) ELSEIF(IPOTME.EQ.'PPCC')THEN IVALUE(1)='Lower 95% Confidence Limit for Gamma:' NCHAR(1)=37 NUMDI2(2)=-2 AVALUE(2)=XQU025 CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) IVALUE(1)='Upper 95% Confidence Limit for Gamma:' NCHAR(1)=37 NUMDI2(2)=-2 AVALUE(2)=XQU975 CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) ENDIF IVALUE(1)='Estimate of Location Parameter:' NCHAR(1)=31 NUMDI2(2)=-2 AVALUE(2)=ALOC CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) IVALUE(1)='Estimate of Scale Parameter:' NCHAR(1)=28 NUMDI2(2)=-2 AVALUE(2)=ASCALE CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NHEAD=2 CALL DPRTF6(NHEAD) IF(IRTFFF.EQ.'Times New Roman')THEN ITEMP=0 ELSEIF(IRTFFF.EQ.'Lucida Sans')THEN ITEMP=6 ELSEIF(IRTFFF.EQ.'Arial')THEN ITEMP=2 ELSEIF(IRTFFF.EQ.'Bookman')THEN ITEMP=3 ELSEIF(IRTFFF.EQ.'Georgia')THEN ITEMP=4 ELSEIF(IRTFFF.EQ.'Tahoma')THEN ITEMP=5 ELSEIF(IRTFFF.EQ.'Verdana')THEN ITEMP=7 ELSE ITEMP=0 ENDIF WRITE(ICOUT,6591)IBASLC,ITEMP CALL DPWRST(ICOUT,'WRIT') C ITTEMP=' ' NCTIT=0 IHEAD=' ' NHEAD=0 CALL DPRTF1(ITTEMP,NCTIT,IHEAD,NHEAD) IFRST=IRTFPS*2500/IDEFPS IINC1=IRTFPS*2500/IDEFPS IWIDTH(1)=IFRST IWIDTH(2)=IFRST+IINC1 IWIDTH(3)=IWIDTH(2)+IINC1 ALIGN(1)='r' ALIGN(2)='r' ALIGN(3)='r' NHEAD=2 IFLAG1=.TRUE. IFLAG2=.TRUE. IVALUE(1)=' b Mean Reccurence Interval (R)' IVALUE(1)(1:1)=IBASLC NCHAR(1)=31 IVALUE(2)=' b XR' IVALUE(2)(1:1)=IBASLC NCHAR(2)=5 CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) C ELSE WRITE(ICOUT,451)N 451 FORMAT('SAMPLE SIZE: ',I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,452)U 452 FORMAT('THRESHOLD: ',F12.5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,453)NLOCAL 453 FORMAT('NUMBER OF POINTS ABOVE THRESHOLD: ',I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,455)ALAMB 455 FORMAT('VALUE OF LAMBDA: ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') IF(IPOTME.EQ.'DEHA')THEN WRITE(ICOUT,461) 461 FORMAT('PARAMETER ESTIMATION (DEHAAN METHOD):') CALL DPWRST('XXX','WRIT') ELSEIF(IPOTME.EQ.'CME')THEN WRITE(ICOUT,463) 463 FORMAT('PARAMETER ESTIMATION (CME METHOD):') CALL DPWRST('XXX','WRIT') ELSEIF(IPOTME.EQ.'PPCC')THEN WRITE(ICOUT,465) 465 FORMAT('PARAMETER ESTIMATION (PPCC METHOD):') CALL DPWRST('XXX','WRIT') ENDIF WRITE(ICOUT,471)GAMMA 471 FORMAT('ESTIMATE OF SHAPE PARAMETER (GAMMA): ',G15.7) CALL DPWRST('XXX','WRIT') IF(IPOTME.EQ.'DEHA' .OR. IPOTME.EQ.'CME')THEN WRITE(ICOUT,472)GAMMSD 472 FORMAT('STANDARD DEVIATION OF GAMMA: ',G15.7) CALL DPWRST('XXX','WRIT') ELSEIF(IPOTME.EQ.'PPCC')THEN WRITE(ICOUT,473)XQU025 473 FORMAT('LOWER 95% CONFIDENCED LIMIT: ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,474)XQU975 474 FORMAT('UPPER 95% CONFIDENCED LIMIT: ',G15.7) CALL DPWRST('XXX','WRIT') ENDIF WRITE(ICOUT,476)ALOC 476 FORMAT('ESTIMATE OF LOCATION PARAMETER: ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,478)ASCALE 478 FORMAT('ESTIMATE OF SCALE PARAMETER: ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,483) 483 FORMAT('MEAN RECURRENCE ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,485) 485 FORMAT('INTERVAL (R) XR') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,489) 489 FORMAT('=====================================') CALL DPWRST('XXX','WRIT') ENDIF ENDIF C DG=DBLE(GAMMA) IF(IPOTLF.EQ.'ON' .AND. GAMMA.LT.0.0)THEN XMAX=U - (ASCALE/GAMMA) CCCCC DTEMP=1.0D0 - 1.0D0/(DBLE(ALAMB)*50.0D0) CCCCC CALL GEDPPF(DTEMP,DBLE(GAMMA),MINMAX,IGEPDF,DXR) DXR=DBLE(ALOC) - DBLE(ASCALE)* 1 (1.0D0 - (DBLE(ALAMB*50.0))**DG)/DG XR50=REAL(DXR) IF(IR50.GT.0)THEN XLF50=(XMAX/XR50)**2 ELSE XLF50=-99.0 ENDIF ENDIF C DO410II=1,NRET CCCCC DTEMP=1.0D0 - 1.0D0/(DBLE(ALAMB)*DBLE(R(II))) CCCCC CALL GEDPPF(DTEMP,DBLE(GAMMA),MINMAX,IGEPDF,DXR) DXR=DBLE(ALOC) - DBLE(ASCALE)* 1 (1.0D0 - (DBLE(ALAMB*R(II)))**DG)/DG XR=REAL(DXR) IF(IPOTLF.EQ.'ON')THEN IF(GAMMA.LT.0.0 .AND. R(II).GE.51.0)THEN XLF=(XR/XR50)**2 ELSE XLF=-99.0 ENDIF WRITE(IOUNI2,'(2(I8,2X),4E15.7)')I,NLOCAL,U,R(II), 1 XR,XLF ELSE WRITE(IOUNI2,'(2(I8,2X),3E15.7)')I,NLOCAL,U,R(II),XR ENDIF IF(IPRINT.EQ.'ON')THEN IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN NCHAR(1)=0 IVALUE(1)=' ' AVALUE(1)=R(II) AVALUE(2)=XR NHEAD=2 CALL DPHTM5(IVALUE,NCHAR(1),AVALUE,NHEAD) ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN IFLAG1=.FALSE. IVALUE(1)=' ' NCHAR(1)=0 AVALUE(1)=R(II) AVALUE(2)=XR NHEAD=2 CALL DPLAT5(IVALUE,NCHAR,AVALUE,NHEAD,IFLAG1) ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN IFLAG1=.FALSE. IVALUE(1)=' ' NCHAR(1)=0 AVALUE(1)=R(II) AVALUE(2)=XR NHEAD=2 CALL DPRTF5(IVALUE,NCHAR,AVALUE,NHEAD,IFLAG1) ELSE WRITE(ICOUT,418)R(II),XR 418 FORMAT(F12.2,13X,F12.5) CALL DPWRST('XXX','WRIT') ENDIF ENDIF 410 CONTINUE IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN IFLAG1=.TRUE. IFLAG2=.FALSE. NHEAD=0 CALL DPHTM2(IFLAG1,IFLAG2,NHEAD) IF(IPOTLF.EQ.'ON' .AND. GAMMA.LT.0.0)THEN WRITE(ICOUT,1426) 1426 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1427)XMAX 1427 FORMAT('Maximum Wind Speed: ',F12.5,'
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1429)XLF 1429 FORMAT('Load Factor ', 1 '(MAX/XR50)2: ',F12.5, 1 '
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1428) 1428 FORMAT('

') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') ENDIF ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN IFLAG1=.TRUE. IFLAG2=.FALSE. IFLAG3=.FALSE. NHEAD=0 CALL DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD) IF(IPOTLF.EQ.'ON' .AND. GAMMA.LT.0.0)THEN IVALUE(1)='Maximum Wind Speed: ' NCHAR(1)=20 AVAL=XMAX CALL DPLAT7(IVALUE(1),NCHAR(1),AVAL) IVALUE(1)='Load Factor $(Max/XR_{50})^2$:' NCHAR(1)=29 AVAL=XLF CALL DPLAT7(IVALUE(1),NCHAR(1),AVAL) ENDIF IFLAG1=.FALSE. IFLAG2=.FALSE. IFLAG3=.TRUE. CALL DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD) ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN NHEAD=2 CALL DPRTF6(NHEAD) NHEAD=0 NCTIT=0 CALL DPRTF1(ITTEMP,NCTIT,IHEAD,NHEAD) IF(IPOTLF.EQ.'ON' .AND. GAMMA.LT.0.0)THEN IVALUE(1)='Maximum Wind Speed: ' NCHAR(1)=20 AVAL=XMAX CALL DPRTF7(IVALUE(1),NCHAR(1),AVAL) IVALUE(1)='Load Factor (Max/XR(50)^2:' NCHAR(1)=26 AVAL=XLF CALL DPRTF7(IVALUE(1),NCHAR(1),AVAL) NHEAD=2 CALL DPRTF6(NHEAD) NHEAD=0 NCTIT=0 CALL DPRTF1(ITTEMP,NCTIT,IHEAD,NHEAD) ENDIF ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') IF(IPOTLF.EQ.'ON' .AND. GAMMA.LT.0.0)THEN WRITE(ICOUT,427)XMAX 427 FORMAT('MAXIMUM WIND SPEED: ',F12.5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,429)XLF 429 FORMAT('LOAD FACTOR (MAX/XR(50))**2: ',F12.5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') ENDIF ENDIF ENDIF C ELSEIF(IPOTDI.EQ.'WEIB')THEN ELSEIF(IPOTDI.EQ.'GUMB')THEN ELSEIF(IPOTDI.EQ.'FREC')THEN ENDIF C 300 CONTINUE C N2=ICNT NPLOTV=2 C IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN IFLAG1=.FALSE. IFLAG2=.TRUE. CALL DPHTM2(IFLAG1,IFLAG2,NHEAD) ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN IFLAG1=.FALSE. IFLAG2=.TRUE. IFLAG3=.FALSE. CALL DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD) ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN NHEAD=0 CALL DPRTF6(NHEAD) ELSE ENDIF C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE C IPRINT=IPRISV IFEEDB=IFEESV C IENDF1='OFF' IREWI1='ON' CALL DPCLFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1 IENDF1,IREWI1,ISUBN0,IERRF1,IBUGG3,ISUBRO,IERROR) C IF(NRET.GT.0)THEN IENDF2='OFF' IREWI2='ON' CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1 IENDF2,IREWI2,ISUBN0,IERRF2,IBUGG3,ISUBRO,IERROR) ENDIF C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'POT2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPOT2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,N,IERROR 9012 FORMAT('ICASPL,N,IERROR = ',A4,I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)N2,NPLOTV 9014 FORMAT('N2,NPLOTV = ',2I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N2 WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I) 9016 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE ENDIF C RETURN END SUBROUTINE DPPP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, CCCCC THE FOLLOWING LINE WAS CHANGED DECEMBER 1993 CCCCC1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--GENERATE A PROBABILITY PLOT 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 MAY 1990 C 26) WALD MAY 1990 C 27) RECIPROCAL INVERSE GAUUSIAN MAY 1990 C 28) FAILURE TIME MAY 1990 C 29) GENERALIZED PARETO DECEMBER 1993 C 30) DISCRETE UNIFORM SEPTEMBER 1994 C 31) NON-CENTRAL T SEPTEMBER 1994 C 32) NON-CENTRAL F SEPTEMBER 1994 C 33) NON-CENTRAL CHI-SQUARE SEPTEMBER 1994 C 34) NON-CENTRAL BETA SEPTEMBER 1994 C 35) DOUBLY NON-CENTRAL T SEPTEMBER 1994 C 36) DOUBLY NON-CENTRAL F SEPTEMBER 1994 C 36) HYPER-GEOMETRIC SEPTEMBER 1994 C 37) VON-MISES OCTOBER 1994 C 38) POWER NORMAL APRIL 1995 C 39) POWER LOGNORMAL APRIL 1995 C 40) COSINE APRIL 1995 C 41) ALPHA APRIL 1995 C 42) POWER FUNCTION APRIL 1995 C 43) CHI APRIL 1995 C 44) LOGARITMIC SERIES APRIL 1995 C 45) LOG LOGISTIC APRIL 1995 C 46) GENERALIZED GAMMA APRIL 1995 C 47) WARING PROBABILTY PLOT MAY 1995 C 48) ANGLIT PROBABILTY PLOT SEPTEMBER 1995 C 49) ARCSIN PROBABILTY PLOT SEPTEMBER 1995 C 50) FOLDED NORMAL PROBABILTY PLOT SEPTEMBER 1995 C 51) TRUNCATED NORMAL PROBABILTY PLOT SEPTEMBER 1995 C 52) LOG GAMMA PROBABILTY PLOT OCTOBER 1995 C 53) HYPERBOLIC SECANT PROBABILTY PLOT OCTOBER 1995 C 54) GOMPERTZ PROBABILTY PLOT OCTOBER 1995 C 55) PARETO SECOND KIND PROBABILTY PLOT OCTOBER 1995 C 56) DOUBLE WEIBULL PROBABILTY PLOT OCTOBER 1995 C 57) WRAPPED-UP CAUCHY PROBABILTY PLOT OCTOBER 1995 C 58) EXPONENTIAL WEIBULL PROBABILTY PLOT OCTOBER 1995 C 59) TRUNCATED EXPONENTIAL PROBABILTY PLOT OCTOBER 1995 C 60) GENERALIZED LOGISTIC PROBABILTY PLOT DECEMBER 1995 C 61) EXPONENTIAL POWER PROBABILTY PLOT DECEMBER 1995 C 62) DOUBLE GAMMA PROBABILTY PLOT JANUARY 1996 C 63) MIELKE'S BETA-KAPPA PROBABILTY PLOT JANUARY 1996 C 64) FOLDED CAUCHY PROBABILTY PLOT JANUARY 1996 C 65) BETA BINOMIAL PROBABILTY PLOT FEBRUARY 1996 C 66) BETA PASCAL PROBABILTY PLOT FEBRUARY 1996 C 67) GENERALIZED EXPONENTIAL PROB PLOT FEBRUARY 1996 C 68) RECIPROCAL PROB PLOT MAY 1996 C 69) NORMAL MIXTURE PROB PLOT MAY 1998 C 70) INVERTED GAMMA PROB PLOT MAY 1998 C 71) GENERALIZED TUKEY LAMBDA PROB PLOT AUGUST 2001 C 72) JOHNSON SB PROB PLOT SEPTEMBER 2001 C 73) JOHNSON SU PROB PLOT SEPTEMBER 2001 C 74) INVERTED WEIBULL PROB PLOT SEPTEMBER 2001 C 75) LOG DOUBLE EXPONENTIAL PROB PLOT SEPTEMBER 2001 C 76) GEOMETRIC EXTREME EXPONENTIAL PROB PLOT NOV 2001 C 77) TWO-SIDED POWER PROB PLOT MAY 2002 C 78) BIWEIBULL PROB PLOT MAY 2002 C 79) G-AND-H PROB PLOT JANUARY 2003 C 80) LANDAU PROB PLOT APRIL 2003 C 81) ERROR PROB PLOT MAY 2003 C 82) TRAPEZOID PROB PLOT JUNE 2003 C 83) GENERALIZED TRAPEZOID PROB PLOT JUNE 2003 C 84) FOLDED T PROB PLOT NOVEMBER 2003 C 85) SLASH PROB PLOT DECEMBER 2003 C 86) SKEWED NORMAL PROB PLOT DECEMBER 2003 C 87) SKEWED T PROB PLOT DECEMBER 2003 C 88) INVERTED BETA PROB PLOT DECEMBER 2003 C 89) GOMPERTZ-MAKEHAM PROB PLOT DECEMBER 2003 C 90) LOG-SKEW-NORMAL PROB PLOT MARCH 2004 C 91) LOG-SKEW-T PROB PLOT MARCH 2004 C 92) GENERALIZED HALF-LOGISTIC PROB PLOT MARCH 2004 C 93) POLYA PROB PLOT MARCH 2004 C 94) HERMITE PROB PLOT MARCH 2004 C 95) YULE PROBABILTY PLOT APRIL 2004 C 96) SKEW DOUBLE EXPONENTYIAL PROBABILTY PLOT JUNE 2004 C 97) ASYMMETRIC DOUBLE EXPONENTIAL PROBABILTY PLOT C JUNE 2004 C 98) MAXWELL PROBABILTY PLOT JUNE 2004 C 99) RAYLEIGH PROBABILTY PLOT JUNE 2004 C 100) GENERALIZED ASYMMETRIC DOUBLE EXPONENTIAL C PROBABILTY PLOT AUGUST 2004 C 101) GENERALIZED INVERSE GAUSSIAN PROBABILTY PLOT C 102) MCLEISH PROBABILTY PLOT C 103) BESSEL I FUNCTION PROBABILTY PLOT C 104) BESSEL K FUNCTION PROBABILTY PLOT (NOT WORKING) C 105) GENERALIZED MCLEISH PROBABILTY PLOT C 106) HYPERBOLIC PROBABILTY PLOT (NOT WORKING) C 107) GENERALIZED LOGISTIC TYPE 5 PROBABILTY PLOT C 108) GENERALIZED LOGISTIC TYPE 2 PROBABILTY PLOT C 109) WAKEBY PROBABILTY PLOT C 110) BETA NORMAL PROBABILTY PLOT C 111) GENERALIZED LOGISTIC TYPE 3 PROBABILTY PLOT C 114) GENERALIZED LOGISTIC TYPE 4 PROBABILTY PLOT C 115) ASYMMETRIC LOG DOUBLE EXPONENTIAL C 116) BETA GEOMETRIC C 117) ZETA C 118) ZIPF C 118) BOREL-TANNER C 119) BETA NEGATIVE BINOMIAL C 120) LAGRANGE POISON C 121) LEADS IN COIN TOSSING (DISCRETE ARCSINE) C 122) MATCHING C 123) LOST GAMES C 124) LOG BETA C 125) POLYA AEPPLI C 126) CLASSICAL OCCUPANCY (NOT ACTIVE) C 127) GENERALIZED LOGARITHMIC SERIES C 128) GENERALIZED NEGATIVE BINOMIAL C 129) GEETA C 130) QUASI BINOMIAL TYPE I C 131) CONSUL (GENERALIZED GEOMETRIC) C 132) LAGRANGE KATZ (NOT ACTIVE) C 133) KATZ (NOT ACTIVE) C 134) DISCRETE WEIBULL C 135) GENERALIZED LOST GAMES C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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 1978. C UPDATED --MAY 1978. C UPDATED --JULY 1978. C UPDATED --JANUARY 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --MAY 1990. IG, WALD, RIG, FL (SAUNDERS) C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C UPDATED --MAY 1993. MINMAX FOR EV1/EV2/WEIB DIST. C UPDATED --MAY 1993. ADD GUMBEL NAME FOR EV1 C UPDATED --MAY 1993. ADD FRECHET NAME FOR EV2 C UPDATED --MAY 1993. COMPUTE & STORE PPCC C UPDATED --DECEMBER 1993. SIMPLIFY STORAGE OF PPCC C UPDATED --DECEMBER 1993. CALC & STORE OTHER PP STAT C UPDATED --DECEMBER 1993. GENERALIZED PARETO C UPDATED --DECEMBER 1993. LINFIT ARGS C UPDATED --SEPTEMBER 1994. NEW DISTRIBUTIONS C UPDATED --APRIL 1995. NEW DISTRIBUTIONS C UPDATED --SEPTEMBER 1995. ARCSIN AND ANGLIT DISTRIBUTIONS C UPDATED --SEPTEMBER 1995. FOLDED NORMAL DISTRIBUTIONS C UPDATED --SEPTEMBER 1995. TRUNCATED NORMAL DISTRIBUTIONS C UPDATED --OCTOBER 1995. LOG GAMMA DISTRIBUTIONS C UPDATED --OCTOBER 1995. HYPERBOLIC SECANT DISTRIBUTIONS C UPDATED --OCTOBER 1995. GOMPERTZ DISTRIBUTION C UPDATED --OCTOBER 1995. HALF-LOGISTIC C UPDATED --OCTOBER 1995. GENERALIZED EXTREME VALUE C UPDATED --OCTOBER 1995. HALF CAUCHY C UPDATED --OCTOBER 1995. PARETO SECOND KIND C UPDATED --OCTOBER 1995. DOUBLE WEIBULL C UPDATED --OCTOBER 1995. EXPONENTIAL WEIBULL C UPDATED --OCTOBER 1995. TRUNCATED EXPONENTIAL C UPDATED --OCTOBER 1995. WRAPPED CAUCHY C UPDATED --DECEMBER 1995. GENERALIZED LOGISTIC C UPDATED --JANUARY 1996. DOUBLE GAMMA C UPDATED --JANUARY 1996. MIELKE BETA KAPPA C UPDATED --JANUARY 1996. FOLDED CAUCHY C UPDATED --FEBRUARY 1996. BETA BINOMIAL C UPDATED --FEBRUARY 1996. BETA PASCAL C UPDATED --FEBRUARY 1996. GENERALIZED EXPONENTIAL C UPDATED --MAY 1996. RECIPROCAL C UPDATED --MAY 1998. NORMAL MIXTURE C UPDATED --MAY 1998. INVERTED GAMMA C UPDATED --AUGUST 2001. GENERALIZED LAMBDA C UPDATED --SEPTEMBER 2001. JOHNSON SB C UPDATED --SEPTEMBER 2001. JOHNSON SU C UPDATED --SEPTEMBER 2001. INVERTED WEIBULL C UPDATED --SEPTEMBER 2001. LOG DOUBLE EXPONENTIAL C UPDATED --SEPTEMBER 2001. BUG FIX FOR TRIANGULAR C UPDATED --NOVEMBER 2001. GEOMETRIC EXTREME EXPO C UPDATED --MAY 2002. TWO-SIDED POWER C UPDATED --MAY 2002. BIWEIBULL C UPDATED --JANUARY 2003. G-AND-H C UPDATED --APRIL 2003. LANDAU C UPDATED --MAY 2003. ERROR C UPDATED --JUNE 2003. TRAPEZOID C UPDATED --JUNE 2003. GENERALIZED TRAPEZOID 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, SKEWED NORMAL, C UPDATED -- INVERTED BETA, SKEWED T, C UPDATED -- GOMPERTZ-MAKEHAM C UPDATED --MARCH 2004. LOG-SKEW-NORMAL C UPDATED --MARCH 2004. LOG-SKEW-T C UPDATED --MARCH 2004. MAKE COMMAND SEARCH TABLE C DRIVEN C UPDATED --MARCH 2004. POLYA C UPDATED --APRIL 2004. HERMITE C UPDATED --APRIL 2004. YULE C UPDATED --MAY 2004. PERFORM A BIWEIGHT FIT TO C OBTAIN ALTERNATE ESTIMATES C FOR LOCATION AND SCALE (FOR C LONG TAILED DISTRIBUTIONS SUCH C AS CAUCHY) C UPDATED --JUNE 2004. SKEW DOUBLE EXPONENTIAL C UPDATED --JUNE 2004. ASYMMETRIC DOUBLE EXPONENTIAL C UPDATED --JUNE 2004. MAXWELL, RAYLEIGH C UPDATED --JULY 2004. ALTERNATE DEFINITION FOR C GOMPERTZ-MAKEHAM C UPDATED --AUGUST 2004. GENERALIZED ASYMMETRIC DOUBLE C EXPONENTIAL C UPDATED --AUGUST 2004. GENERALIZED INVERSE GAUSSIAN C UPDATED --SEPTEMBER 2004. MCLEISH C UPDATED --SEPTEMBER 2004. BESSEL I FUNCTION C UPDATED --SEPTEMBER 2004. BESSEL K FUNCTION C UPDATED --SEPTEMBER 2004. GENERALIZED MCLEISH C UPDATED --SEPTEMBER 2004. HYPERBOLIC C UPDATED --SEPTEMBER 2004. SUPPORT FOR: C SET PROBABILITY PLOT DATA C POINTS C UPDATED --OCTOBER 2004. SUPPORT FOR CENSORED DATA C UPDATED --DECEMBER 2004. CLARIFY SHAPE PARAMETERS FOR C PARETO PARETO SECOND KIND C UPDATED --APRIL 2005. FOR BINNED DATA, SUPPORT CASE C WHERE LOWER AND UPPER BIN C BOUNDARIES SPECIFIED RATHER C THAN THE MID-POINTS. THIS C ALLOWS USER FLEXIBILITY IN C COMBINING BINS C UPDATED --AUGUST 2005. LOG LAPLACE AS SYNONYM FOR C LOG DOUBLE EXPONENTIAL 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. 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 EXPO 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 UPDATED --JUNE 2006. LAGRANGE POISSON C UPDATED --JUNE 2006. LOG BETA C UPDATED --JUNE 2006. LEADS IN COIN TOSSING C UPDATED --JUNE 2006. MATCHING C UPDATED --JUNE 2006. CLASSICAL OCCUPANCY (NOT ACTIVE) 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. 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 FREEDOM C FOR T DISTRIBUTION C UPDATED --OCTOBER 2006. SHAPE PARAMETER FOR SEMI-CIRCULAR C 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 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CCCCC THE FOLLOWING LINE WAS ADDED DECEMBER 1993 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 IHRI2H CHARACTER*4 IHRI22 CHARACTER*4 IERRO4 C CHARACTER*4 IH CHARACTER*4 IH2 CCCCC THE FOLLOWING LINE WAS ADDED DECEMBER 1993 CHARACTER*4 ISUBN0 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 LOWLTY CHARACTER*4 UPPLTY CHARACTER*4 ICENSO CHARACTER*4 IMETHD C CHARACTER*30 IDIST C PARAMETER (NUMCHS=231) CHARACTER*4 INAME(NUMCHS,4) CHARACTER*4 INCASE(NUMCHS) C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(MAXOBV) DIMENSION X1(MAXOBV) DIMENSION XHIGH(MAXOBV) DIMENSION WEIGHH(MAXOBV) DIMENSION WEIGHV(MAXOBV) DIMENSION PREDBW(MAXOBV) DIMENSION RESBW(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),X1(1)) EQUIVALENCE (GARBAG(IGARB2),Y1(1)) EQUIVALENCE (GARBAG(IGARB3),WEIGHH(1)) EQUIVALENCE (GARBAG(IGARB4),WEIGHV(1)) EQUIVALENCE (GARBAG(IGARB5),PREDBW(1)) EQUIVALENCE (GARBAG(IGARB6),RESBW(1)) EQUIVALENCE (GARBAG(IGARB7),XHIGH(1)) CCCCC END CHANGE C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' CCCCC THE FOLLOWING LINE WAS ADDED (FOR MINMAX) MAY 1993 INCLUDE 'DPCOSU.INC' INCLUDE 'DPCOS2.INC' CCCCC THE FOLLOWING LINE WAS ADDED (FOR IHOST1/2) MAY 1993 INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOMC.INC' INCLUDE 'DPCOST.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 MARCH 2004. 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)/'HLPP'/ DATA (INAME(17,J),J=1,4)/'HALF','LOGI',' ',' '/ 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)/'HCPP'/ DATA (INAME(111,J),J=1,4)/'HALF','CAUC',' ',' '/ 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)/'HNPP'/ DATA (INAME(114,J),J=1,4)/'HALF',' ',' ',' '/ 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 INCASE(165)/'SDPP'/ DATA (INAME(165,J),J=1,4)/'SKEW','DOUB','EXPO',' '/ DATA INCASE(166)/'SDPP'/ DATA (INAME(166,J),J=1,4)/'SKEW','LAPL',' ',' '/ DATA INCASE(167)/'ADPP'/ DATA (INAME(167,J),J=1,4)/'ASYM','DOUB','EXPO',' '/ DATA INCASE(168)/'ADPP'/ DATA (INAME(168,J),J=1,4)/'ASYM','LAPL',' ',' '/ DATA INCASE(169)/'MXPP'/ DATA (INAME(169,J),J=1,4)/'MAXW',' ',' ',' '/ DATA INCASE(170)/'RAPP'/ DATA (INAME(170,J),J=1,4)/'RAYL',' ',' ',' '/ DATA INCASE(171)/'GALP'/ DATA (INAME(171,J),J=1,4)/'GENE','ASYM','DOUB','EXPO'/ DATA INCASE(172)/'GALP'/ DATA (INAME(172,J),J=1,4)/'GENE','ASYM','LAPL',' '/ DATA (INAME(173,J),J=1,4)/'MCLE',' ',' ',' '/ DATA INCASE(173)/'MCPP'/ 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 (INAME(178,J),J=1,4)/'GENE','MCLE',' ',' '/ DATA INCASE(178)/'GMCP'/ DATA INCASE(179)/'LXPP'/ DATA (INAME(179,J),J=1,4)/'LOG ','LAPL',' ',' '/ DATA INCASE(180)/'G5PP'/ DATA (INAME(180,J),J=1,4)/'GENE','LOGI','TYPE','5 '/ DATA INCASE(181)/'G5PP'/ DATA (INAME(181,J),J=1,4)/'GENE','LOGI','TYPE','V '/ DATA INCASE(182)/'G5PP'/ DATA (INAME(182,J),J=1,4)/'GENE','LOGI','HOSK',' '/ DATA INCASE(183)/'G5PP'/ DATA (INAME(183,J),J=1,4)/'HOSK','GENE','LOGI',' '/ DATA INCASE(184)/'G5PP'/ DATA (INAME(184,J),J=1,4)/'TYPE','5 ','GENE','LOGI'/ DATA INCASE(185)/'G5PP'/ DATA (INAME(185,J),J=1,4)/'TYPE','V ','GENE','LOGI'/ DATA INCASE(186)/'G2PP'/ DATA (INAME(186,J),J=1,4)/'GENE','LOGI','TYPE','2 '/ DATA INCASE(187)/'G2PP'/ DATA (INAME(187,J),J=1,4)/'GENE','LOGI','TYPE','II '/ DATA INCASE(188)/'G2PP'/ DATA (INAME(188,J),J=1,4)/'TYPE','2 ','GENE','LOGI'/ DATA INCASE(189)/'G2PP'/ DATA (INAME(189,J),J=1,4)/'TYPE','II ','GENE','LOGI'/ DATA INCASE(190)/'G3PP'/ DATA (INAME(190,J),J=1,4)/'GENE','LOGI','TYPE','3 '/ DATA INCASE(191)/'G3PP'/ DATA (INAME(191,J),J=1,4)/'GENE','LOGI','TYPE','III '/ DATA INCASE(192)/'G3PP'/ DATA (INAME(192,J),J=1,4)/'TYPE','3 ','GENE','LOGI'/ DATA INCASE(193)/'G3PP'/ DATA (INAME(193,J),J=1,4)/'TYPE','III ','GENE','LOGI'/ DATA INCASE(194)/'G4PP'/ DATA (INAME(194,J),J=1,4)/'GENE','LOGI','TYPE','4 '/ DATA INCASE(195)/'G4PP'/ DATA (INAME(195,J),J=1,4)/'GENE','LOGI','TYPE','IV '/ DATA INCASE(196)/'G4PP'/ DATA (INAME(196,J),J=1,4)/'TYPE','4 ','GENE','LOGI'/ DATA INCASE(197)/'G4PP'/ DATA (INAME(197,J),J=1,4)/'TYPE','IV ','GENE','LOGI'/ DATA INCASE(198)/'GLPP'/ DATA (INAME(198,J),J=1,4)/'GENE','LOGI',' ',' '/ DATA INCASE(199)/'LDPP'/ DATA (INAME(199,J),J=1,4)/'GENE','LAMB',' ',' '/ DATA INCASE(200)/'BGPP'/ DATA (INAME(200,J),J=1,4)/'BETA','GEOM',' ',' '/ DATA INCASE(201)/'LXPP'/ DATA (INAME(201,J),J=1,4)/'LOG ','LAPL',' ',' '/ DATA INCASE(202)/'AXPP'/ DATA (INAME(202,J),J=1,4)/'ASYM','LOG ','DOUB','EXPO'/ DATA INCASE(203)/'AXPP'/ DATA (INAME(203,J),J=1,4)/'ASYM','LOG ','LAPL',' '/ DATA INCASE(204)/'ZEPP'/ DATA (INAME(204,J),J=1,4)/'ZETA',' ',' ',' '/ DATA INCASE(205)/'ZIPP'/ DATA (INAME(205,J),J=1,4)/'ZIPF',' ',' ',' '/ DATA INCASE(206)/'BZPP'/ DATA (INAME(206,J),J=1,4)/'BETA','NEGA','BINO',' '/ DATA INCASE(207)/'BTPP'/ DATA (INAME(207,J),J=1,4)/'BORE','TANN',' ',' '/ DATA INCASE(208)/'BZPP'/ DATA (INAME(208,J),J=1,4)/'GENE','WARI',' ',' '/ DATA INCASE(209)/'LBPP'/ DATA (INAME(209,J),J=1,4)/'LOG ','BETA',' ',' '/ DATA INCASE(210)/'BEPP'/ DATA (INAME(210,J),J=1,4)/'BETA',' ',' ',' '/ DATA INCASE(211)/'LPPP'/ DATA (INAME(211,J),J=1,4)/'LAGR','POIS',' ',' '/ DATA INCASE(212)/'LPPP'/ DATA (INAME(212,J),J=1,4)/'CONS','GENE','POIS',' '/ DATA INCASE(213)/'LCPP'/ DATA (INAME(213,J),J=1,4)/'LEAD','IN ','COIN','TOSS'/ DATA INCASE(214)/'LCPP'/ DATA (INAME(214,J),J=1,4)/'DISC','ARCS',' ',' '/ DATA INCASE(215)/'MAPP'/ DATA (INAME(215,J),J=1,4)/'MATC',' ',' ',' '/ DATA INCASE(216)/'OCPP'/ DATA (INAME(216,J),J=1,4)/'CLAS','OCCU',' ',' '/ DATA INCASE(217)/'LBPP'/ DATA (INAME(217,J),J=1,4)/'LOG ','BETA',' ',' '/ DATA INCASE(218)/'PZPP'/ DATA (INAME(218,J),J=1,4)/'POLY',' ',' ',' '/ DATA INCASE(219)/'LOST'/ DATA (INAME(219,J),J=1,4)/'LOST','GAME',' ',' '/ DATA INCASE(220)/'GSPP'/ DATA (INAME(220,J),J=1,4)/'GENE','LOGA','SERI',' '/ DATA INCASE(221)/'GNBP'/ DATA (INAME(221,J),J=1,4)/'GENE','NEGA','BINO',' '/ DATA INCASE(222)/'GETP'/ DATA (INAME(222,J),J=1,4)/'GEET',' ',' ',' '/ DATA INCASE(223)/'QBPP'/ DATA (INAME(223,J),J=1,4)/'QUAS','BINO','TYPE','I '/ DATA INCASE(224)/'QBPP'/ DATA (INAME(224,J),J=1,4)/'QUAS','BINO','TYPE','1 '/ DATA INCASE(225)/'QBPP'/ DATA (INAME(225,J),J=1,4)/'QUAS','BINO','I ',' '/ DATA INCASE(226)/'QBPP'/ DATA (INAME(226,J),J=1,4)/'QUAS','BINO','1 ',' '/ DATA INCASE(227)/'CNPP'/ DATA (INAME(227,J),J=1,4)/'CONS',' ',' ',' '/ DATA INCASE(228)/'LKPP'/ DATA (INAME(228,J),J=1,4)/'LAGR','KATZ',' ',' '/ DATA INCASE(229)/'KZPP'/ DATA (INAME(229,J),J=1,4)/'KATZ',' ',' ',' '/ DATA INCASE(230)/'DIWP'/ DATA (INAME(230,J),J=1,4)/'DISC','WEIB',' ',' '/ DATA INCASE(231)/'GLGP'/ DATA (INAME(231,J),J=1,4)/'GENE','LOST','GAME',' '/ C C-----START POINT----------------------------------------------------- C IERROR='NO' ICENSO='OFF' IMETHD='UNIM' IF(IPPLCN.EQ.'KAPL')IMETHD=IPPLCN C ISUBN1='DPPP' ISUBN2=' ' 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 ICOLR2=0 C C *************************************** C ** TREAT THE PROBABILITY PLOT CASE ** C *************************************** C IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'DPPP')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPP--') 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 ') ENDIF C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPPP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C 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 IF(IHARG(I1).EQ.'PROB'.AND.IHARG(I2).EQ.'PLOT')THEN ILASTC=I2 GOTO112 ELSEIF(IHARG(I1).EQ.'CENS'.AND.IHARG(I2).EQ.'PROB'.AND. 1 IHARG(I3).EQ.'PLOT')THEN ICENSO='ON' ILASTC=I3 GOTO112 END IF C 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' C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPPP') 1CALL 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(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPPP') 1CALL 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' .OR. ISUBRO.EQ.'DPPP')THEN WRITE(ICOUT,311)IHLEFT,IHLEF2,ICOLL,NLEFT 311 FORMAT('IHLEFT,IHLEF2,ICOLL,NLEFT = ',A4,A4,I8,I8) CALL DPWRST('XXX','BUG ') ENDIF C C ****************************************************** C ** STEP 4-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS ** C ** (NLEFT) FOR THE RESPONSE VARIABLE IS POSITIVE. ** C ****************************************************** C ISTEPN='4' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPPP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.LT.MINN2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,411) 411 FORMAT('***** ERROR IN PROBABILITY PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,412)IHLEFT,IHLEF2 412 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS ', 1 'IN VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,413) 413 FORMAT(' (FOR WHICH A PROBABILITY PLOT WAS TO HAVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,415)MINN2 415 FORMAT(' BEEN FORMED) MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,416) 416 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,417) 417 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,418)(IANS(I),I=1,MIN(80,IWIDTH)) 418 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF 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(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPPP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,581) 581 FORMAT('***** INTERNAL ERROR IN DPPP') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,582) 582 FORMAT(' AT BRANCH POINT 481--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,583) 583 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH NUMARG HAD ', 1 'PREVIOUSLY') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,585)NUMARG 585 FORMAT(' PASSED THIS TEST ONCE ALREADY. VALUE OF ', 1 'NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,586) 586 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,417) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,418)(IANS(I),I=1,MIN(80,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C DO500J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')THEN ICASEQ='SUBS' ILOCQ=J1 GOTO590 ELSEIF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')THEN ICASEQ='SUBS' ILOCQ=J1 GOTO590 ELSEIF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')THEN ICASEQ='FOR' ILOCQ=J1 GOTO590 ENDIF 500 CONTINUE C 590 CONTINUE IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPCC')THEN WRITE(ICOUT,591)NUMARG,ILOCQ,ICASEQ 591 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF C C ********************************************************* C ** STEP 6-- ** C ** THE FOLLOWING CASES OF MORE THAN ONE ARGUMENT ** C ** ARE SUPPORTED: ** C ** ... PROB PLOT Y X1 - FREQUENCY DATA ** C ** ... PROB PLOT Y XLOW XUPP - FREQUENCY DATA ** C ** ... PROB PLOT Y X1 - CENSORED DATA ** C ********************************************************* C ISTEPN='6' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPPP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IRESV=1 ICENV=0 IFREV=0 IFREV2=0 C NUMEXP=1 IF(ICENSO.EQ.'ON')NUMEXP=NUMEXP+1 C IF(NUMV2.EQ.NUMEXP)THEN IDATSW='RAW' IF(ICENSO.EQ.'ON')ICENV=2 ELSEIF(NUMV2.EQ.NUMEXP+1)THEN IDATSW='FREQ' IF(ICENSO.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,611) 611 FORMAT('***** ERROR IN PROBABILITY PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,613) 613 FORMAT(' FREQUENCY DATA NOT SUPPORTED FOR CENSORED ', 1 'CASE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,417) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,418)(IANS(I),I=1,MIN(80,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ELSE IFREV=2 IFREV2=0 ENDIF ELSEIF(NUMV2.EQ.NUMEXP+2)THEN IDATSW='FRE2' IF(ICENSO.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,611) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,613) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,417) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,418)(IANS(I),I=1,MIN(80,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ELSE IFREV=2 IFREV2=3 ENDIF ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,611) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,623)NUMEXP,NUMEXP+1,NUMEXP+2 623 FORMAT(' EITHER ',I8,', ',I8,' OR ',I8, 1 ' VARIABLES EXPECTED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,625)NUMV2 625 FORMAT(' NUMBER OF VARIABLES ENTERED = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,417) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,418)(IANS(I),I=1,MIN(80,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C IF(NUMV2.GE.2)THEN IHRIGH=IHARG(2) IHRIG2=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHRIGH,IHRIG2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLR=IVALUE(ILOCV) NRIGHT=IN(ILOCV) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPCC')THEN WRITE(ICOUT,641)IHRIGH,IHRIG2,ICOLR,NRIGHT 641 FORMAT('IHRIGH,IHRIG2,ICOLR,NRIGHT = ',A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') ENDIF C IF(NRIGHT.NE.NLEFT)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,611) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,652) 652 FORMAT(' FOR A ... PROBABILITY PLOT WITH TWO ', 1 'VARIABLES SPECIFIED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,653) 653 FORMAT(' THE NUMBER OF ELEMENTS IN THE TWO VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,655) 655 FORMAT(' MUST BE THE SAME; SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,657)IHLEFT,IHLEF2,NLEFT 657 FORMAT(' THE FIRST VARIABLE (',A4,A4,') HAS ',I8, 1 'ELEMENTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,658)IHRIGH,IHRIG2,NRIGHT 658 FORMAT(' THE SECOND VARIABLE (',A4,A4,') HAS ',I8, 1 'ELEMENTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,417) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,418)(IANS(I),I=1,MIN(80,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF ENDIF C IF(NUMV2.GE.3)THEN IHRI2H=IHARG(3) IHRI22=IHARG2(3) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHRI2H,IHRI22,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLR2=IVALUE(ILOCV) NRIGH2=IN(ILOCV) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPCC')THEN WRITE(ICOUT,661)IHRI2H,IHRI22,ICOLR2,NRIGH2 661 FORMAT('IHRI2H,IHRI22,ICOLR2,NRIGH2 = ',A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') ENDIF C IF(NRIGH2.NE.NLEFT)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,611) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,672) 672 FORMAT(' FOR A ... PROBABILITY PLOT WITH THREE ', 1 'VARIABLES SPECIFIED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,673) 673 FORMAT(' THE NUMBER OF ELEMENTS IN THE THREE VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,675) 675 FORMAT(' MUST BE THE SAME; SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,677)IHLEFT,IHLEF2,NLEFT 677 FORMAT(' THE FIRST VARIABLE (',A4,A4,') HAS ',I8, 1 'ELEMENTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,678)IHRI2H,IHRI22,NRIGH2 678 FORMAT(' THE THIRD VARIABLE (',A4,A4,') HAS ',I8, 1 'ELEMENTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,417) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,418)(IANS(I),I=1,MIN(80,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF ENDIF 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(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPPP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'SUBS')THEN NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4) NQ=NIOLD ELSEIF(ICASEQ.EQ.'FOR')THEN NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1 NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR ELSE DO715I=1,NLEFT ISUB(I)=1 715 CONTINUE NQ=NLEFT ENDIF C J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO760I=1,IMAX IF(ISUB(I).EQ.0)GOTO760 J=J+1 C C RESPONSE VARIABLE IN Y1 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) C C CLASS VARIABLE IN X1 FOR FREQUENCY DATA C IF(IFREV.GT.0)THEN ICOLT=ICOLR IJ=MAXN*(ICOLT-1)+I IF(ICOLT.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLT.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLT.EQ.MAXCP2)X1(J)=RES(I) IF(ICOLT.EQ.MAXCP3)X1(J)=YPLOT(I) IF(ICOLT.EQ.MAXCP4)X1(J)=XPLOT(I) IF(ICOLT.EQ.MAXCP5)X1(J)=X2PLOT(I) IF(ICOLT.EQ.MAXCP6)X1(J)=TAGPLO(I) ENDIF C C IF FREQUENCY DATA GIVEN WITH LOWER AND UPPER CLASS LIMITS, THEN C UPPER CLASS LIMIT VARIABLE IN XHIGH C IF(IFREV2.GT.0)THEN ICOLT=ICOLR2 IJ=MAXN*(ICOLT-1)+I IF(ICOLT.LE.MAXCOL)XHIGH(J)=V(IJ) IF(ICOLT.EQ.MAXCP1)XHIGH(J)=PRED(I) IF(ICOLT.EQ.MAXCP2)XHIGH(J)=RES(I) IF(ICOLT.EQ.MAXCP3)XHIGH(J)=YPLOT(I) IF(ICOLT.EQ.MAXCP4)XHIGH(J)=XPLOT(I) IF(ICOLT.EQ.MAXCP5)XHIGH(J)=X2PLOT(I) IF(ICOLT.EQ.MAXCP6)XHIGH(J)=TAGPLO(I) ENDIF C C CENSORING VARIABLE IN X1 FOR CENSORED DATA (CENSORING NOT C SUPPORTED FOR GROUPED DATA) C IF(ICENSO.EQ.'ON')THEN ICOLT=ICOLR IJ=MAXN*(ICOLT-1)+I IF(ICOLT.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLT.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLT.EQ.MAXCP2)X1(J)=RES(I) IF(ICOLT.EQ.MAXCP3)X1(J)=YPLOT(I) IF(ICOLT.EQ.MAXCP4)X1(J)=XPLOT(I) IF(ICOLT.EQ.MAXCP5)X1(J)=X2PLOT(I) IF(ICOLT.EQ.MAXCP6)X1(J)=TAGPLO(I) ENDIF C 760 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(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPPP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASPL.EQ.'LAPP')THEN IDIST='LAMBDA' IHP='LAMB' IHP2='DA ' 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=1.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 IHP='N ' IHP2=' ' IDIST='BINOMIAL' 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 IHP='K ' IHP2=' ' IDIST='NEGATIVE BINOMIAL' 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=' ' IDIST='TRIANGULAR' ALOWLM=-1.0 AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' CALL PARCHR(IHP,IHP2,IDIST,C,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')THEN C=0.0 ENDIF GOTO4999 ENDIF IF(ICASPL.EQ.'DUPP')THEN IHP='N ' IHP2=' ' IDIST='T' 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 IDIST='NON-CENTRAL 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='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 IDIST='DOUBLY NON-CENTRAL T' IHP='NU ' 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 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 IF(ICOM2.EQ.'BOLO')THEN IDIST='HYPERBOLIC' 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='XI ' IHP2='A ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,XI,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSE IDIST='HYPERGEOMETRIC' IHP='M ' IHP2=' ' 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 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 IHP='C ' IHP2=' ' IDIST='POWER FUNCTION' 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 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.'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.1 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=' ' 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 IN WARING PROBABILITY PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4912) 4912 FORMAT(' THE VALUE FOR THE SHAPE PARAMETER C IS ', 1 'LESS THAN OR EQUAL TO') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4913) 4913 FORMAT(' THE VALUE FOR THE SHAPE PARAMETER A.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4915)C 4915 FORMAT(' THE SPECIFIED VALUE OF C = ',G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4916)A 4916 FORMAT(' THE SPECIFIED VALUE OF A = ',G15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF GOTO4999 ENDIF IF(ICASPL.EQ.'FNPP')THEN 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.'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 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 IDIST='TRUNCATED EXPONENTIAL' IHP='X0 ' IHP2=' ' 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.'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.'G2PP')THEN IDIST='GENERALIZED LOGISTIC TYPE 2' C 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.'G3PP')THEN IDIST='GENERALIZED LOGISTIC TYPE 3' C 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.'G4PP')THEN IDIST='GENERALIZED LOGISTIC TYPE 4' C IHP='P ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,P,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='Q ' IHP2=' ' ALOWLM=0.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 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 IHP='BETA' IHP2=' ' 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 IDIST='MIELKE BETA-KAPPA' 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='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.'HEPP')THEN IDIST='HERMITE' 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.'BGPP')THEN IHP='ALPH' IHP2='A ' IDIST='BETA-GEOMETRIC' 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 IDIST='ZETA' 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 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=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,ALOC2,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.'TNPP')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,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) LOWLTY='>= ' IHP='THET' IHP2='A ' CALL PARCHR(IHP,IHP2,IDIST,THETA,ALOWLM,AUPPLM,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,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 LOWLTY='>= ' IHP='LAMB' IHP2='DA ' CALL PARCHR(IHP,IHP2,IDIST,ALAMBA,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) LOWLTY='> ' IHP='K ' IHP2=' ' CALL PARCHR(IHP,IHP2,IDIST,AK,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) ELSE 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 IDIST='GENERALIZED INVERSE GAUSSIAN' IHP='CHI ' IHP2=' ' 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.'LZPP')THEN IHP='LAMB' IHP2='DA ' IDIST='LOG-SKEW-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 C IHP='SD ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,SD,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO4999 ENDIF C IF(ICASPL.EQ.'LTPP')THEN IHP='LAMB' IHP2='DA ' IDIST='LOG-SKEW-T' 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 C IHP='SD ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' CALL PARCHR(IHP,IHP2,IDIST,SD,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='NU ' IHP2=' ' 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 GOTO4999 ENDIF C IF(ICASPL.EQ.'SDPP')THEN IDIST='SKEWED DOUBLE EXPONENTIAL' IHP='LAMB' IHP2='DA ' 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 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 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.'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='LAGRFANGE-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.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 ***************************************************** C ** STEP 9-- ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** C ** RESET THE VECTOR D(.) TO ALL ONES. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ***************************************************** C ISTEPN='9' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPPP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'DPPP')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5111) 5111 FORMAT('***** FROM THE MIDDLE OF DPPP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5112)ICASPL,NUMV2,IDATSW,NPLOTP,NPLOTV 5112 FORMAT('ICASPL,NUMV2,IDATSW,NPLOTP,NPLOTV = ', 1 A4,I8,2X,A4,2I8) 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 ') IF(NPLOTP.GE.1)THEN DO5115I=1,NPLOTP WRITE(ICOUT,5116)I,Y(I),X(I),D(I) 5116 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 5115 CONTINUE ENDIF ENDIF C CALL DPPP2(Y1,X1,XHIGH,NLOCAL,ICASPL,IDATSW, 1ALAMBA,NU,NU1,NU2,GAMMA,ALPHA,BETA,NPAR,P,K,MINMAX, 1ANU,ANU1,ANU2,NDUN,C,ALAMB1,ALAMB2,MPAR,B,SD,THETA,DELTA,A, 1AM,X0, 1U1,SD1,U2,SD2,DZ, CCCCC ADD FOLLOWING LINE AUGUST 2001. 1ALAMB3,ALAMB4,ALPHA1,ALPHA2, CCCC ADD FOLLOWING LINE MAY 2002. 1ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2, CCCC ADD FOLLOWING LINE JANUARY 2003. 1G,H,ANU3, 1AMU,XI,AK,SIGMA, 1ETA,ZETA,CHI,TAU,Q,PHI, 1YLOWLM,YUPPLM, 1IADEDF,IGEPDF,IMAKDF,IBEIDF, 1ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF, 1IPPLDP,MAXOBV,ICENSO,IMETHD, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) CCCCC MINMAX WAS ADDED ABOVE AS AN ARGUMENT MAY 1993 CCCCC ANU, ANU1, ANU2, NDUN, C, B ADDED AS ARGUMENTS SEPTEMBER 1994 CCCCC AM ADDED AS ARGUMENTS SEPTEMBER 1995 C CCCCC THE FOLLOWING ENTIRE SECTION WAS ADDED MAY 1993 CCCCC TO ALLOW AUTO-COMPUTATION OF THE PROB. PLOT CORR. COEF MAY 1993 CCCCC THE FOLLOWING ENTIRE SECTION WAS THEN CHANGED DECEMBER 1993 C C *************************************** C ** STEP 61-- ** C ** COMPUTE PROB PLOT STAT ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C ISTEPN='61' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPPP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ISUBN0='DPPP' CCCCC CALL CORR(Y,X,NPLOTP,IWRITE,PPCC,IBUGG3,IERROR) CALL LINFIT(Y,X,NPLOTP, 1ALPHA,BETA,XRESSD,XRESDF,CCXY,SDALPH,SDBETA,CCALBE, 1ISUBRO,IBUGG3,IERROR) C IH='PPCC' IH2=' ' VALUE0=CCXY CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,IERROR) C IH='PPA0' IH2=' ' VALUE0=ALPHA CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,IERROR) C IH='PPA1' IH2=' ' VALUE0=BETA CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,IERROR) C IH='SDPP' IH2='A0 ' VALUE0=SDALPH CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,IERROR) C IH='SDPP' IH2='A1 ' VALUE0=SDBETA CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,IERROR) C IH='PPRE' IH2='SSD ' VALUE0=XRESSD CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,IERROR) C IH='PPRE' IH2='SDF ' VALUE0=XRESDF CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,IERROR) C CCCCC MAY 2004: NOW DO 1 ITERATION OF BIWEIGHT ON RESIDUALS. CCCCC THIS SEEMS TO PRODUCE BETTER ESTIMATES OF CCCCC LOCATION AND SCALE FOR SOME HEAVY TAILED CCCCC DISTRIBUTIONS (E.G., CAUCHY, SLASH). C DO6010I=1,NPLOTP RESBW(I)=Y(I) - (ALPHA + BETA*X(I)) WEIGHH(I)=1.0 WEIGHV(I)=1.0 6010 CONTINUE IWRITE='OFF' CALL BIWEIG(RESBW,NPLOTP,IWRITE,WEIGHV,IBUGG3,IERROR) C IT=1 I1=1 I2=NPLOTP I3=1 I4=NPLOTP XMAXHF=1.0 C CALL LINEAR(IT,I1,I2,X,Y,WEIGHH,WEIGHV,NPLOTP,XMAXHF,I3,I4, 1PPA0BW,PPA1BW,PREDBW,RESBW, 1ISUBRO,IBUGG3,IERROR) C DO6020I=1,NPLOTP RESBW(I)=Y(I) - (PPA0BW + PPA1BW*X(I)) 6020 CONTINUE CALL BIWEIG(RESBW,NPLOTP,IWRITE,WEIGHV,IBUGG3,IERROR) CALL LINEAR(IT,I1,I2,X,Y,WEIGHH,WEIGHV,NPLOTP,XMAXHF,I3,I4, 1PPA0BW,PPA1BW,PREDBW,RESBW, 1ISUBRO,IBUGG3,IERROR) C IH='PPA0' IH2='BW ' VALUE0=PPA0BW CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,IERROR) C IH='PPA1' IH2='BW ' VALUE0=PPA1BW CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,IERROR) C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'DPPP')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPP--') 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 = ', 1 I8,I8,I8,2X,A4,2X,A4,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 ') IF(NPLOTP.GE.1)THEN DO9020I=1,NPLOTP WRITE(ICOUT,9021)I,Y(I),X(I),D(I) 9021 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9020 CONTINUE ENDIF ENDIF C RETURN END SUBROUTINE DPPP2(Y,X,XHIGH,N,ICASPL,IDATSW, 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, CCCCC ADD FOLLOWING LINE AUGUST 2001. 1ALAMB3,ALAMB4,ALPHA1,ALPHA2, CCCC ADD FOLLOWING LINE MAY 2002. 1ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2, CCCC ADD FOLLOWING LINE JANUARY 2003. 1G,H,ANU3, 1AMU,XI,AK,SIGMA, 1ETA,ZETA,CHI,TAU,Q,PHI, 1YLOWLM,YUPPLM, 1IADEDF,IGEPDF,IMAKDF,IBEIDF, 1ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF, 1IPPLDP,MAXOBV,ICENSO,IMETHD, 1Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR) CCCCC MINMAX WAS ADDED ABOVE AS ANA RGUMENT MAY 1993 CCCCC ANU, ANU1, ANU2, NDUN, C, B ADDED AS ARGUMENTS SEPTEMBER 1994 CCCCC AM ADDED AS ARGUMENT SEPTEMBER 1995 C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE C A PROBABILITY PLOT FOR SOME DISTRIBUTION. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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 1978. C UPDATED --MAY 1978. C UPDATED --JUNE 1978. C UPDATED --OCTOBER 1978. C UPDATED --MARCH 1979. C UPDATED --APRIL 1979. C UPDATED --JANUARY 1981. C UPDATED --DECEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --MAY 1990. IG, WALD, RIG, FL (SAUNDERS) C UPDATED --MAY 1992. MOVE KPAR SINCE UNDEFINED C UPDATED --MAY 1993. MINMAX FOR EV1/EV2/WEIB DIST. C UPDATED --DECEMBER 1993. GENERALIZED PARETO C UPDATED --DECEMBER 1993. FIX TRACE INFO C UPDATED --SEPTEMBER 1994. ADD 9 DISTRIBUTIONS, FIX TRIANG C UPDATED --APRIL 1995. ADD NEW DISTRIBUTIONS C UPDATED --SEPTEMBER 1995. ADD NEW DISTRIBUTIONS C UPDATED --OCTOBER 1995. ADD NEW DISTRIBUTIONS C UPDATED --DECEMBER 1995. ADD NEW DISTRIBUTIONS C UPDATED --JANUARY 1996. ADD DOUBLE GAMMA, MIELKE'S C BETA-KAPPA, FOLDED CAUCHY C UPDATED --JANUARY 1996. DO NOT HANDLE LOG-NORMAL SEPARATELY C UPDATED --FEBRUARY 1996. BETA-BINOMIAL, BETA-PASCAL, C GENERALIZED EXPONENTIAL C UPDATED --MAY 1996. RECIPROCAL C UPDATED --FEBRUARY 1998. FOR BINNED DATA, CHECK FOR C ZERO COUNT BINS C UPDATED --MAY 1998. NORMAL MIXTURE C UPDATED --MAY 1998. INVERTED GAMMA C UPDATED --AUGUST 2001. GENERALIZED LAMBDA C UPDATED --SEPTEMBER 2001. JOHNSON SB, JOHNSON SU, C INVERTED WEIBULL, C LOG DOUBLE EXPONENTIAL C UPDATED --MAY 2002. TWO-SIDED POWER C UPDATED --MAY 2002. BIWEIBULL C UPDATED --JANUARY 2003. G-AND-H C UPDATED --APRIL 2003. LANDAU C UPDATED --MAY 2003. ERROR C UPDATED --JUNE 2003. TRAPEZOID C UPDATED --JUNE 2003. GENERALIZED TRAPEZOID C UPDATED --NOVEMBER 2003. FOLDED T C UPDATED --DECEMBER 2003. SLASH, INVERTED BETA, C SKEWED NORMAL, SKEWED T, C GOMPERTZ-MAKEHAM 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 --JULY 2004. ALTERNATE DEFINITION FOR C GOMPERTZ-MAKEHAM C UPDATED --AUGUST 2004. GENERALIZED INVERSE GAUSSIAN C UPDATED --AUGUST 2004. MCLEISH C UPDATED --AUGUST 2004. BESSEL I-FUNCTION C UPDATED --SEPTEMBER 2004. SUPPORT FOR: C SET PROBABILITY PLOT DATA C POINTS C UPDATED --OCTOBER 2004. SUPPORT FOR CENSORED DATA C UPDATED --OCTOBER 2004. FOR BINNED DATA, REMOVE C ZERO FREQUENCY BINS C UPDATED --MAY 2005. FOR BINNED DATA, SUPPORT C CASE WHERE LOWER AND UPPER C LIMITS OF BIN GIVEN (AS C OPPOSSED TO JUST MID-POINTS) C UPDATED --MAY 2005. ADD ISUBRO BUG SWITCH C UPDATED --JULY 2005. CALL LIST TO LGAPPF AND SNPPF C UPDATED --FEBRUARY 2006. GENERALIZED LOGISTIC TYPE 5 C UPDATED --FEBRUARY 2006. WAKEBY C UPDATED --FEBRUARY 2006. FMLK PARAMERIZATION OF C GENERALIZED TUKEY-LAMBDA 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 LAPLACE 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 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 C SERIES C UPDATED --JULY 2006. GENERALIZED NEGATIVE C BINOMIAL C UPDATED --JULY 2006. GEETA C UPDATED --JULY 2006. QUASI BINOMIAL TYPE I C UPDATED --AUGUST 2006. CONSUL (GENERALIZED GEOMTRIC) C UPDATED --AUGUST 2006. LAGRANGE KATZ C UPDATED --SEPTEMBER 2006. KATZ C UPDATED --OCTOBER 2006. SHAPE PARAMETER FOR SEMI-CIRCULAR C 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 IDATSW 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 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ICENSO CHARACTER*4 IMETHD C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C CHARACTER*4 IWRITE C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X(*) DIMENSION XHIGH(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) C REAL LANPPF DOUBLE PRECISION DX2OUT C DOUBLE PRECISION QUAGLO DOUBLE PRECISION QUAWAK DOUBLE PRECISION XPAR(5) 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 ISUBN1='DPPP' ISUBN2='2 ' C IERROR='NO' C CCCCC THE FOLLOWING LINE WAS COMMENTED OUT/MOVED MAY 1992 (JJF) CCCCC KPAR=K C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.LE.1)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46) 46 FORMAT('***** ERROR IN PROBABILITY PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47) 47 FORMAT(' THE NUMBER OF OBSERVATIONS WAS LESS THAN OR') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48) 48 FORMAT(' EQUAL TO 1.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,49)N 49 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C IF(IDATSW.EQ.'RAW')THEN 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 PROBABILITY PLOT--') 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 ENDIF 69 CONTINUE C IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PPP2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71) 71 FORMAT('***** AT THE BEGINNING OF DPPP2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)ICASPL,IDATSW,N,NPLOTV 72 FORMAT('ICASPL,IDATSW,N,NPLOTV = ',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 ') WRITE(ICOUT,75)MINMAX 75 FORMAT('MINMAX = ',I8) CALL DPWRST('XXX','BUG ') IF(N.GE.1)THEN DO85I=1,N WRITE(ICOUT,86)I,Y(I),X(I),XHIGH(I) 86 FORMAT('I,Y(I),X(I),XHIGH(I) = ',I8,3G12.5) CALL DPWRST('XXX','BUG ') 85 CONTINUE ENDIF WRITE(ICOUT,89)IPPLDP,IDATSW 89 FORMAT(' IPPLDP, IDATSW = ',I8,1X,A4) CALL DPWRST('XXX','BUG ') ENDIF C C ************************************************** C ** STEP 1B- ** C ** IF SET PROBABILITY PLOT DATA POINTS COMMAND ** C ** WAS ENTERED, THIN DATA SET BY COMPUTING ** C ** PERCENTILES OF THE DATA. CURRENTLY ** C ** ONLY SUPPORTED FOR UNBINNED DATA. ** C ************************************************** IF(IPPLDP.GT.0 .AND. IDATSW.EQ.'RAW' .AND. ICENSO.EQ.'OFF')THEN NPERC=MAX(20,IPPLDP) NPERC=MIN(NPERC,N) CALL SORT(Y,N,Y2) ASTRT=0.0 ASTOP=100.0 AINC=(ASTOP - ASTRT)/REAL(NPERC+1) IWRITE='OFF' DO110I=1,NPERC P100=ASTRT + REAL(I)*AINC CALL PERCEN(P100,Y2,N,IWRITE,X2,MAXOBV, 1 XPERC,IBUGG3,IERROR) Y(I)=XPERC 110 CONTINUE N=NPERC IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PPP2')THEN WRITE(ICOUT,113)IPPLDP,NPERC,N 113 FORMAT(' IPPLDP, NPERC, N = ',3I8) CALL DPWRST('XXX','BUG ') DO117I=1,N WRITE(ICOUT,118)I,Y(I) 118 FORMAT(' I, Y(I) = ',I8,G15.7) CALL DPWRST('XXX','BUG ') 117 CONTINUE ENDIF ENDIF C C ************************************** C ** STEP 4-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ** AND DETERMINE PLOT COORDINATES ** C ************************************** C IF(IDATSW.EQ.'RAW')GOTO1100 IF(IDATSW.EQ.'FREQ')GOTO2100 IF(IDATSW.EQ.'FRE2')GOTO2100 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011) 1011 FORMAT('***** INTERNAL ERROR IN DPPP2 ', 1'AT BRANCH POINT 1011--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1012) 1012 FORMAT(' IDATSW SHOULD BE EITHER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1013) 1013 FORMAT(' RAW, FRE2, OR FREQ, BUT IS NONE OF THESE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1014)IDATSW 1014 FORMAT(' IDATSW = ',A4) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C C **************************************** C ** STEP 4.1-- ** C ** DETERMINE PLOT COORDINATES ** C ** FOR THE 1-VARIABLE CASE ** C ** (THAT IS, FOR THE RAW DATA CASE) ** C **************************************** C 1100 CONTINUE C CCCCC OCTOBER 2004. FOR CENSORED CASE, CHECK THAT SECOND VARIABLE CCCCC CONTAINS TWO DISTINCT VALUES, SET TO 1 AND 0. C IF(ICENSO.EQ.'ON')THEN CALL DISTIN(X,N,IWRITE,X2,NDIST,IBUGG3,IERROR) IF(NDIST.EQ.1)THEN DO1102I=1,N X(I)=1.0 1102 CONTINUE ELSEIF(NDIST.EQ.2)THEN IF(X2(1).EQ.1.0 .OR. X2(2).EQ.1.0)THEN DO1103I=1,N IF(X(I).NE.1.0)X(I)=0.0 1103 CONTINUE ELSE ATEMP1=MIN(X2(1),X2(2)) ATEMP2=MAX(X2(1),X2(2)) DO1108I=1,N IF(X(I).EQ.ATEMP1)X(I)=1.0 IF(X(I).EQ.ATEMP2)X(I)=0.0 1108 CONTINUE ENDIF ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1104) 1104 FORMAT('***** ERROR IN PROBABILITY PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1105) 1105 FORMAT(' FOR CENSORED DATA, THE CENSORING VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1106) 1106 FORMAT(' SHOULD CONTAIN AT MOST TWO DISTINCT VALUES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1107)NDIST 1107 FORMAT(' ',I8,' DISTINCT VALUES FOUND.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF CALL SORTC(Y,X,N,Y2,X) XMIN=Y2(1) XMAX=Y2(N) CALL UNIME3(N,X2,X,IMETHD) ELSE CALL SORT(Y,N,Y2) XMIN=Y2(1) XMAX=Y2(N) CALL UNIMED(N,X2) ENDIF C EPS=0.00001 IF(XMIN.LT.YLOWLM)YLOWLM=XMIN-EPS IF(XMAX.GT.YUPPLM)YUPPLM=XMAX+EPS C IF(ICASPL.EQ.'MAPP')THEN IF(INT(XMAX+0.5).GT.K)K=INT(XMAX+0.5) ELSEIF(ICASPL.EQ.'LCPP')THEN IF(INT(XMAX+0.5).GT.NDUN)NDUN=INT(XMAX+0.5) ENDIF C ICNT=0 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.'BIPP')GOTO1290 IF(ICASPL.EQ.'GEPP')GOTO1300 IF(ICASPL.EQ.'POPP')GOTO1310 IF(ICASPL.EQ.'NBPP')GOTO1320 IF(ICASPL.EQ.'SEPP')GOTO1330 IF(ICASPL.EQ.'TRPP')GOTO1340 CCCCC THE FOLLOWING 4 LINES WERE ADDED MAY 1990 IF(ICASPL.EQ.'IGPP')GOTO1350 IF(ICASPL.EQ.'WAPP')GOTO1360 IF(ICASPL.EQ.'RIPP')GOTO1370 IF(ICASPL.EQ.'FLPP')GOTO1380 CCCCC THE FOLLOWING LINE WAS ADDED DECEMBER 1993 IF(ICASPL.EQ.'GPPP')GOTO1390 CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1994 IF(ICASPL.EQ.'DUPP')GOTO1400 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.'HYPP')GOTO1470 IF(ICASPL.EQ.'VMPP')GOTO1480 CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1995 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.'DLPP')GOTO1550 IF(ICASPL.EQ.'LLPP')GOTO1560 IF(ICASPL.EQ.'GGPP')GOTO1570 IF(ICASPL.EQ.'WRPP')GOTO1580 IF(ICASPL.EQ.'YUPP')GOTO1585 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 GAMMA=-1.0 GOTO1670 ENDIF IF(ICASPL.EQ.'GZPP')GOTO1670 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.'BBPP')GOTO1790 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.'LDPP')GOTO1850 IF(ICASPL.EQ.'JBPP')GOTO1860 IF(ICASPL.EQ.'JUPP')GOTO1870 IF(ICASPL.EQ.'IWPP')GOTO1880 IF(ICASPL.EQ.'LXPP')GOTO1890 IF(ICASPL.EQ.'EEPP')GOTO11900 IF(ICASPL.EQ.'TSPP')GOTO11910 IF(ICASPL.EQ.'BWPP')GOTO11920 IF(ICASPL.EQ.'GHPP')GOTO11930 IF(ICASPL.EQ.'LUPP')GOTO11940 IF(ICASPL.EQ.'ERPP')GOTO11950 IF(ICASPL.EQ.'TZPP')GOTO11960 IF(ICASPL.EQ.'GTPP')GOTO11970 IF(ICASPL.EQ.'FTPP')GOTO11980 IF(ICASPL.EQ.'SLPP')GOTO11990 IF(ICASPL.EQ.'SNPP')GOTO11200 IF(ICASPL.EQ.'STPP')GOTO11210 IF(ICASPL.EQ.'IBPP')GOTO11220 IF(ICASPL.EQ.'GMPP')GOTO11230 IF(ICASPL.EQ.'LZPP')GOTO11240 IF(ICASPL.EQ.'LTPP')GOTO11250 IF(ICASPL.EQ.'ASPP')GOTO11260 IF(ICASPL.EQ.'PZPP')GOTO11270 IF(ICASPL.EQ.'HEPP')GOTO11280 IF(ICASPL.EQ.'SDPP')GOTO11290 IF(ICASPL.EQ.'ADPP')GOTO11300 IF(ICASPL.EQ.'MXPP')GOTO11310 IF(ICASPL.EQ.'RAPP')GOTO11320 IF(ICASPL.EQ.'GIGP')GOTO11330 IF(ICASPL.EQ.'GALP')GOTO11340 IF(ICASPL.EQ.'MCPP')GOTO11350 IF(ICASPL.EQ.'BEIP')GOTO11360 IF(ICASPL.EQ.'BEIK')GOTO11370 IF(ICASPL.EQ.'GMCP')GOTO11380 IF(ICASPL.EQ.'G5PP')GOTO11390 IF(ICASPL.EQ.'WKPP')GOTO11400 IF(ICASPL.EQ.'BNPP')GOTO11410 IF(ICASPL.EQ.'G2PP')GOTO11420 IF(ICASPL.EQ.'G3PP')GOTO11430 IF(ICASPL.EQ.'G4PP')GOTO11440 IF(ICASPL.EQ.'AXPP')GOTO11450 IF(ICASPL.EQ.'BGPP')GOTO11460 IF(ICASPL.EQ.'ZEPP')GOTO11470 IF(ICASPL.EQ.'ZIPP')GOTO11480 IF(ICASPL.EQ.'BTPP')GOTO11490 IF(ICASPL.EQ.'BZPP')GOTO11500 IF(ICASPL.EQ.'LPPP')GOTO11510 IF(ICASPL.EQ.'LCPP')GOTO11520 IF(ICASPL.EQ.'MAPP')GOTO11530 IF(ICASPL.EQ.'LBPP')GOTO11540 IF(ICASPL.EQ.'AEPP')GOTO11550 IF(ICASPL.EQ.'LOST')GOTO11560 IF(ICASPL.EQ.'GSPP')GOTO11570 IF(ICASPL.EQ.'GNBP')GOTO11580 IF(ICASPL.EQ.'GETP')GOTO11590 IF(ICASPL.EQ.'QBPP')GOTO11600 IF(ICASPL.EQ.'CNPP')GOTO11610 IF(ICASPL.EQ.'LKPP')GOTO11620 IF(ICASPL.EQ.'KZPP')GOTO11630 IF(ICASPL.EQ.'DIWP')GOTO11640 IF(ICASPL.EQ.'GLGP')GOTO11650 C 1110 CONTINUE DO1111I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1111 ICNT=ICNT+1 CALL UNIPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1111 CONTINUE GOTO1900 C 1120 CONTINUE DO1121I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1121 ICNT=ICNT+1 CALL NORPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1121 CONTINUE GOTO1900 C 1130 CONTINUE DO1131I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1131 ICNT=ICNT+1 CALL LOGPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1131 CONTINUE GOTO1900 C 1140 CONTINUE DO1141I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1141 ICNT=ICNT+1 CALL DEXPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1141 CONTINUE GOTO1900 C 1150 CONTINUE DO1151I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1151 ICNT=ICNT+1 CALL CAUPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1151 CONTINUE GOTO1900 C 1160 CONTINUE DO1161I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1161 ICNT=ICNT+1 CALL LAMPPF(X2(I),ALAMBA,X2OUT) X2(ICNT)=X2OUT 1161 CONTINUE GOTO1900 C 1170 CONTINUE DO1171I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1171 ICNT=ICNT+1 CALL LGNPPF(X2(I),SIGMA,X2OUT) X2(ICNT)=X2OUT 1171 CONTINUE GOTO1900 C 1180 CONTINUE DO1181I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1181 ICNT=ICNT+1 CALL HFNPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1181 CONTINUE GOTO1900 C 1190 CONTINUE DO1191I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1191 ICNT=ICNT+1 CCCCC CALL TPPF(X2(I),NU,X2OUT) CALL TPPF(X2(I),ANU,X2OUT) X2(ICNT)=X2OUT 1191 CONTINUE GOTO1900 C 1200 CONTINUE DO1201I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1201 ICNT=ICNT+1 CALL CHSPPF(X2(I),NU,X2OUT) X2(ICNT)=X2OUT 1201 CONTINUE GOTO1900 C 1210 CONTINUE DO1211I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1211 ICNT=ICNT+1 CALL FPPF(X2(I),NU1,NU2,X2OUT) X2(ICNT)=X2OUT 1211 CONTINUE GOTO1900 C 1220 CONTINUE DO1221I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1221 ICNT=ICNT+1 CALL EXPPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1221 CONTINUE GOTO1900 C 1230 CONTINUE DO1231I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1231 ICNT=ICNT+1 CALL GAMPPF(X2(I),GAMMA,X2OUT) X2(ICNT)=X2OUT 1231 CONTINUE GOTO1900 C 1240 CONTINUE DO1241I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1241 ICNT=ICNT+1 CALL BETPPF(X2(I),ALPHA,BETA,X2OUT) X2(ICNT)=X2OUT 1241 CONTINUE GOTO1900 C 1250 CONTINUE DO1251I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1251 ICNT=ICNT+1 CALL WEIPPF(X2(I),GAMMA,MINMAX,X2OUT) X2(ICNT)=X2OUT 1251 CONTINUE GOTO1900 C 1260 CONTINUE DO1261I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1261 ICNT=ICNT+1 CALL EV1PPF(X2(I),MINMAX,X2OUT) X2(ICNT)=X2OUT 1261 CONTINUE GOTO1900 C 1270 CONTINUE DO1271I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1271 ICNT=ICNT+1 CALL EV2PPF(X2(I),GAMMA,MINMAX,X2OUT) X2(ICNT)=X2OUT 1271 CONTINUE GOTO1900 C 1280 CONTINUE ZLOC=A IF(ZLOC.GT.XMIN)ZLOC=XMIN DO1281I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1281 ICNT=ICNT+1 CALL PARPPF(X2(I),GAMMA,ZLOC,X2OUT) X2(ICNT)=X2OUT 1281 CONTINUE GOTO1900 C 1290 CONTINUE DO1291I=1,N ICNT=ICNT+1 CALL BINPPF(X2(I),P,NPAR,X2OUT) X2(ICNT)=X2OUT 1291 CONTINUE GOTO1900 C 1300 CONTINUE DO1301I=1,N ICNT=ICNT+1 CALL GEOPPF(X2(I),P,X2OUT) X2(ICNT)=X2OUT 1301 CONTINUE GOTO1900 C 1310 CONTINUE IF(ALAMBA.LE.60.0)GOTO1311 GOTO1313 1311 CONTINUE DO1312I=1,N ICNT=ICNT+1 CALL POIPPF(X2(I),ALAMBA,X2OUT) X2(ICNT)=X2OUT 1312 CONTINUE GOTO1900 1313 CONTINUE SQRTAL=SQRT(ALAMBA) DO1314I=1,N ICNT=ICNT+1 CALL NORPPF(X2(I),X2OUT) X2OUT=ALAMBA+SQRTAL*X2OUT X2(ICNT)=X2OUT 1314 CONTINUE GOTO1900 C 1320 CONTINUE DO1321I=1,N ICNT=ICNT+1 CALL NBPPF(X2(I),P,AK,X2OUT) X2(ICNT)=X2OUT 1321 CONTINUE GOTO1900 C 1330 CONTINUE ASCALE=1.0 DO1331I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1331 ICNT=ICNT+1 CALL SEMPPF(X2(I),ASCALE,X2OUT) X2(ICNT)=X2OUT 1331 CONTINUE GOTO1900 C 1340 CONTINUE ZLOWLM=-1.0 ZUPPLM=1.0 DO1341I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1341 ICNT=ICNT+1 CALL TRIPPF(X2(I),C,ZLOWLM,ZUPPLM,X2OUT) X2(ICNT)=X2OUT 1341 CONTINUE GOTO1900 C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1990 1350 CONTINUE DO1351I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1351 ICNT=ICNT+1 CALL IGPPF(X2(I),GAMMA,AMU,X2OUT) X2(ICNT)=X2OUT 1351 CONTINUE GOTO1900 C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1990 1360 CONTINUE DO1361I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1361 ICNT=ICNT+1 CALL WALPPF(X2(I),GAMMA,X2OUT) X2(ICNT)=X2OUT 1361 CONTINUE GOTO1900 C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1990 1370 CONTINUE DO1371I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1371 ICNT=ICNT+1 CALL RIGPPF(X2(I),GAMMA,AMU,X2OUT) X2(ICNT)=X2OUT 1371 CONTINUE GOTO1900 C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1990 1380 CONTINUE DO1381I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1381 ICNT=ICNT+1 CALL FLPPF(X2(I),GAMMA,X2OUT) X2(ICNT)=X2OUT 1381 CONTINUE GOTO1900 C CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 1993 1390 CONTINUE DO1391I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1391 ICNT=ICNT+1 CALL GEPPPF(X2(I),GAMMA,MINMAX,IGEPDF,X2OUT) X2(ICNT)=X2OUT 1391 CONTINUE GOTO1900 C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1994 1400 CONTINUE DO1401I=1,N ICNT=ICNT+1 CALL DISPPF(X2(I),NDUN,X2OUT) X2(ICNT)=X2OUT 1401 CONTINUE GOTO1900 C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1994 1410 CONTINUE DO1411I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1411 ICNT=ICNT+1 CALL NCTPPF(X2(I),ANU,ALAMBA,X2OUT) X2(ICNT)=X2OUT 1411 CONTINUE GOTO1900 C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1994 1420 CONTINUE DO1421I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1421 ICNT=ICNT+1 CALL NCFPPF(X2(I),ANU1,ANU2,ALAMBA,X2OUT) X2(ICNT)=X2OUT 1421 CONTINUE GOTO1900 C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1994 1430 CONTINUE DO1431I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1431 ICNT=ICNT+1 CALL NCCPPF(X2(I),ANU,ALAMBA,X2OUT) X2(ICNT)=X2OUT 1431 CONTINUE GOTO1900 C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1994 1440 CONTINUE DO1441I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1441 ICNT=ICNT+1 CALL NCBPPF(X2(I),ALPHA,BETA,ALAMBA,X2OUT) X2(ICNT)=X2OUT 1441 CONTINUE GOTO1900 C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1994 1450 CONTINUE DO1451I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1451 ICNT=ICNT+1 CALL DNTPPF(X2(I),ANU,ALAMB1,ALAMB2,X2OUT) X2(ICNT)=X2OUT 1451 CONTINUE GOTO1900 C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1994 1460 CONTINUE DO1461I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1461 ICNT=ICNT+1 CALL DNFPPF(X2(I),ANU1,ANU2,ALAMB1,ALAMB2,X2OUT) X2(ICNT)=X2OUT 1461 CONTINUE GOTO1900 C 1470 CONTINUE DO1471I=1,N ICNT=ICNT+1 CALL HYPPPF(X2(I),K,NPAR,MPAR,X2OUT) X2(ICNT)=X2OUT 1471 CONTINUE GOTO1900 C 1480 CONTINUE DO1481I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1481 ICNT=ICNT+1 CALL VONPPF(X2(I),B,X2OUT) X2(ICNT)=X2OUT 1481 CONTINUE GOTO1900 C 1490 CONTINUE DO1491I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1491 ICNT=ICNT+1 CALL PNRPPF(X2(I),P,SD,X2OUT) X2(ICNT)=X2OUT 1491 CONTINUE GOTO1900 C 1500 CONTINUE DO1501I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1501 ICNT=ICNT+1 CALL PLNPPF(X2(I),P,SD,X2OUT) X2(ICNT)=X2OUT 1501 CONTINUE GOTO1900 C 1510 CONTINUE DO1511I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1511 ICNT=ICNT+1 CALL ALPPPF(X2(I),ALPHA,BETA,X2OUT) X2(ICNT)=X2OUT 1511 CONTINUE GOTO1900 C 1520 CONTINUE DO1521I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1521 ICNT=ICNT+1 CALL COSPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1521 CONTINUE GOTO1900 C 1530 CONTINUE DO1531I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1531 ICNT=ICNT+1 CALL POWPPF(X2(I),C,X2OUT) X2(ICNT)=X2OUT 1531 CONTINUE GOTO1900 C 1540 CONTINUE DO1541I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1541 ICNT=ICNT+1 CALL CHPPF(X2(I),ANU,X2OUT) X2(ICNT)=X2OUT 1541 CONTINUE GOTO1900 C 1550 CONTINUE DO1551I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1551 ICNT=ICNT+1 CALL DLGPPF(X2(I),THETA,X2OUT) X2(ICNT)=X2OUT 1551 CONTINUE GOTO1900 C 1560 CONTINUE DO1561I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1561 ICNT=ICNT+1 CALL LLGPPF(X2(I),DELTA,X2OUT) X2(ICNT)=X2OUT 1561 CONTINUE GOTO1900 C 1570 CONTINUE DO1571I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1571 ICNT=ICNT+1 CALL GGDPPF(X2(I),ALPHA,C,X2OUT) X2(ICNT)=X2OUT 1571 CONTINUE GOTO1900 C 1580 CONTINUE DO1581I=1,N ICNT=ICNT+1 CALL WARPPF(X2(I),C,A,X2OUT,'NOTR') X2(ICNT)=X2OUT 1581 CONTINUE GOTO1900 C 1585 CONTINUE DO1586I=1,N ICNT=ICNT+1 CALL YULPPF(X2(I),P,X2OUT) X2(ICNT)=X2OUT 1586 CONTINUE GOTO1900 C 1590 CONTINUE DO1591I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1591 ICNT=ICNT+1 CALL ANGPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1591 CONTINUE GOTO1900 C 1600 CONTINUE DO1601I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1601 ICNT=ICNT+1 CALL ARSPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1601 CONTINUE GOTO1900 C 1610 CONTINUE DO1611I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1611 ICNT=ICNT+1 CALL FNRPPF(X2(I),AMU,SD,X2OUT) X2(ICNT)=X2OUT 1611 CONTINUE GOTO1900 C 1620 CONTINUE DO1621I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1621 ICNT=ICNT+1 CALL TNRPPF(X2(I),A,B,AM,SD,X2OUT) X2(ICNT)=X2OUT 1621 CONTINUE GOTO1900 C 1630 CONTINUE DO1631I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1631 ICNT=ICNT+1 CALL LGAPPF(X2(I),GAMMA,ILGADF,X2OUT) X2(ICNT)=X2OUT 1631 CONTINUE GOTO1900 C 1640 CONTINUE DO1641I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1641 ICNT=ICNT+1 CALL HSEPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1641 CONTINUE GOTO1900 C 1650 CONTINUE DO1651I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1651 ICNT=ICNT+1 CALL GOMPPF(X2(I),C,B,X2OUT) X2(ICNT)=X2OUT 1651 CONTINUE GOTO1900 C 1660 CONTINUE DO1661I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1661 ICNT=ICNT+1 CALL HFCPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 1661 CONTINUE GOTO1900 C 1670 CONTINUE DO1671I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1671 ICNT=ICNT+1 CALL HFLPPF(X2(I),GAMMA,X2OUT) X2(ICNT)=X2OUT 1671 CONTINUE GOTO1900 C 1680 CONTINUE DO1681I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1681 ICNT=ICNT+1 CALL GEVPPF(X2(I),GAMMA,MINMAX,X2OUT) X2(ICNT)=X2OUT 1681 CONTINUE GOTO1900 C 1690 CONTINUE ZLOC=A IF(ZLOC.LE.0.0)ZLOC=1.0 DO1691I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1691 ICNT=ICNT+1 CALL PA2PPF(X2(I),GAMMA,ZLOC,X2OUT) X2(ICNT)=X2OUT 1691 CONTINUE GOTO1900 C 1700 CONTINUE DO1701I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1701 ICNT=ICNT+1 CALL DWEPPF(X2(I),GAMMA,X2OUT) X2(ICNT)=X2OUT 1701 CONTINUE GOTO1900 C 1710 CONTINUE DO1711I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1711 ICNT=ICNT+1 CALL WCAPPF(X2(I),P,X2OUT) X2(ICNT)=X2OUT 1711 CONTINUE GOTO1900 C 1720 CONTINUE IARG1=1 DO1721I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1721 ICNT=ICNT+1 CALL EWEPPF(X2(I),GAMMA,THETA,IARG1,X2OUT) X2(ICNT)=X2OUT 1721 CONTINUE GOTO1900 C 1730 CONTINUE DO1731I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1731 ICNT=ICNT+1 CALL TNEPPF(X2(I),X0,AM,SD,X2OUT) X2(ICNT)=X2OUT 1731 CONTINUE GOTO1900 C 1740 CONTINUE DO1741I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1741 ICNT=ICNT+1 CALL GLOPPF(X2(I),ALPHA,X2OUT) X2(ICNT)=X2OUT 1741 CONTINUE GOTO1900 C 1750 CONTINUE DO1751I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1751 ICNT=ICNT+1 CALL PEXPPF(X2(I),ALPHA,BETA,X2OUT) X2(ICNT)=X2OUT 1751 CONTINUE GOTO1900 C 1760 CONTINUE DO1761I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1761 ICNT=ICNT+1 CALL DGAPPF(X2(I),GAMMA,X2OUT) X2(ICNT)=X2OUT 1761 CONTINUE GOTO1900 C 1770 CONTINUE DO1771I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1771 ICNT=ICNT+1 CALL KAPPPF(X2(I),ANU,BETA,THETA,X2OUT) X2(ICNT)=X2OUT 1771 CONTINUE GOTO1900 C 1780 CONTINUE DO1781I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1781 ICNT=ICNT+1 CALL FCAPPF(X2(I),AM,SD,X2OUT) X2(ICNT)=X2OUT 1781 CONTINUE GOTO1900 C 1790 CONTINUE DO1791I=1,N ICNT=ICNT+1 CALL BBNPPF(X2(I),ALPHA,BETA,NU,X2OUT) X2(ICNT)=X2OUT 1791 CONTINUE GOTO1900 C 1800 CONTINUE DO1801I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1801 ICNT=ICNT+1 CALL BRAPPF(X2(I),BETA,X2OUT) X2(ICNT)=X2OUT 1801 CONTINUE GOTO1900 C 1810 CONTINUE DO1811I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1811 ICNT=ICNT+1 CALL GEXPPF(X2(I),ALAMB1,ALAMB2,GAMMA,X2OUT) X2(ICNT)=X2OUT 1811 CONTINUE GOTO1900 C 1820 CONTINUE DO1821I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1821 ICNT=ICNT+1 CALL RECPPF(X2(I),B,X2OUT) X2(ICNT)=X2OUT 1821 CONTINUE GOTO1900 C 1830 CONTINUE DO1831I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1831 ICNT=ICNT+1 CALL NMXPPF(X2(I),U1,SD1,U2,SD2,P,X2OUT) X2(ICNT)=X2OUT 1831 CONTINUE GOTO1900 C 1840 CONTINUE DO1841I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1841 ICNT=ICNT+1 CALL IGAPPF(X2(I),GAMMA,X2OUT) X2(ICNT)=X2OUT 1841 CONTINUE GOTO1900 C 1850 CONTINUE DO1851I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1851 ICNT=ICNT+1 IWRITE='OFF' CCCCC IF(IGLDDF.EQ.'RAMB')THEN CCCCC IARG1=1 CCCCC ARG3=-1.0 CCCCC ZSCALE=1.0 CCCCC CALL GLDCHK(ALAMB3,ALAMB4,ALOWER,AUPPER,IFLAG,ISIGN,IWRITE) CCCCC IF(ISIGN.LT.0)ZSCALE=-1.0 CCCCC ENDIF CALL GLDPPF(DBLE(X2(I)),DBLE(ALAMB3),DBLE(ALAMB4),DX2OUT, 1 IGLDDF,IWRITE) IF(IGLDDF.EQ.'RAMB')THEN X2OUT=ZSCALE*REAL(DX2OUT) ELSE X2OUT=REAL(DX2OUT) ENDIF X2(ICNT)=X2OUT 1851 CONTINUE GOTO1900 C 1860 CONTINUE DO1861I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1861 ICNT=ICNT+1 CALL JSBPPF(X2(I),ALPHA1,ALPHA2,X2OUT) X2(ICNT)=X2OUT 1861 CONTINUE GOTO1900 C 1870 CONTINUE DO1871I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1871 ICNT=ICNT+1 CALL JSUPPF(X2(I),ALPHA1,ALPHA2,X2OUT) X2(ICNT)=X2OUT 1871 CONTINUE GOTO1900 C 1880 CONTINUE DO1881I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1881 ICNT=ICNT+1 CALL IWEPPF(X2(I),GAMMA,X2OUT) X2(ICNT)=X2OUT 1881 CONTINUE GOTO1900 C 1890 CONTINUE DO1891I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1891 ICNT=ICNT+1 CALL LDEPPF(X2(I),ALPHA,X2OUT) X2(ICNT)=X2OUT 1891 CONTINUE GOTO1900 C 11900 CONTINUE DO11901I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11901 ICNT=ICNT+1 CALL GEEPPF(X2(I),GAMMA,X2OUT) X2(ICNT)=X2OUT 11901 CONTINUE GOTO1900 C 11910 CONTINUE DO11911I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11911 ICNT=ICNT+1 CALL TSPPPF(X2(I),THETA,ANU,X2OUT) X2(ICNT)=X2OUT 11911 CONTINUE GOTO1900 C 11920 CONTINUE DO11921I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11921 ICNT=ICNT+1 CALL BWEPPF(X2(I),ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,X2OUT,DX2OUT) X2(ICNT)=X2OUT 11921 CONTINUE GOTO1900 C 11930 CONTINUE DO11931I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11931 ICNT=ICNT+1 CALL GHPPF(X2(I),G,H,X2OUT,DBLE(X2(I)),DX2OUT) X2(ICNT)=X2OUT 11931 CONTINUE GOTO1900 C 11940 CONTINUE DO11941I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11941 ICNT=ICNT+1 X2OUT=LANPPF(X2(I)) X2(ICNT)=X2OUT 11941 CONTINUE GOTO1900 C 11950 CONTINUE DO11951I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11951 ICNT=ICNT+1 X2IN=X2(I) CALL ERRPPF(X2IN,ALPHA,X2OUT) X2(ICNT)=X2OUT 11951 CONTINUE GOTO1900 C 11960 CONTINUE DO11961I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11961 ICNT=ICNT+1 CALL TRAPPF(X2(I),A,B,C,DZ,X2OUT) X2(ICNT)=X2OUT 11961 CONTINUE GOTO1900 C 11970 CONTINUE DO11971I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11971 ICNT=ICNT+1 CALL GTRPPF(X2(I),A,B,C,DZ,ANU1,ANU3,ALPHA,X2OUT) X2(ICNT)=X2OUT 11971 CONTINUE GOTO1900 C 11980 CONTINUE DO11981I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11981 ICNT=ICNT+1 CALL FTPPF(X2(I),NU,X2OUT) X2(ICNT)=X2OUT 11981 CONTINUE GOTO1900 C 11990 CONTINUE DO11991I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11991 ICNT=ICNT+1 CALL SLAPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 11991 CONTINUE GOTO1900 C 11200 CONTINUE DO11201I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11201 ICNT=ICNT+1 CALL SNPPF(X2(I),ALAMBA,ISKNDF,X2OUT) X2(ICNT)=X2OUT 11201 CONTINUE GOTO1900 C 11210 CONTINUE DO11211I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11211 ICNT=ICNT+1 CALL STPPF(X2(I),NU,ALAMBA,X2OUT) X2(ICNT)=X2OUT 11211 CONTINUE GOTO1900 C 11220 CONTINUE DO11221I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11221 ICNT=ICNT+1 CALL IBPPF(X2(I),ALPHA,BETA,X2OUT) X2(ICNT)=X2OUT 11221 CONTINUE GOTO1900 C 11230 CONTINUE DO11231I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11231 ICNT=ICNT+1 IF(IMAKDF.EQ.'DLMF')THEN CALL MAKPPF(X2(I),XI,ALAMBA,THETA,X2OUT) ELSEIF(IMAKDF.EQ.'MEEK')THEN XI=GAMMA/AK THETA=ALAMB/GAMMA ALAMB=AK CALL MAKPPF(X2(I),XI,ALAMBA,THETA,X2OUT) ELSEIF(IMAKDF.EQ.'REPA')THEN CALL MA2PPF(X2(I),ZETA,ETA,X2OUT) ENDIF X2(ICNT)=X2OUT 11231 CONTINUE GOTO1900 C 11240 CONTINUE DO11241I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11241 ICNT=ICNT+1 CALL LSNPPF(X2(I),ALAMBA,SD,X2OUT) X2(ICNT)=X2OUT 11241 CONTINUE GOTO1900 C 11250 CONTINUE DO11251I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11251 ICNT=ICNT+1 CALL LSTPPF(X2(I),NU,ALAMBA,SD,X2OUT) X2(ICNT)=X2OUT 11251 CONTINUE GOTO1900 C 11260 CONTINUE DO11261I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11261 ICNT=ICNT+1 CALL ARSPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 11261 CONTINUE GOTO1900 C 11270 CONTINUE DO11271I=1,N ICNT=ICNT+1 CALL POLPPF(X2(I),ALPHA,BETA,NU,X2OUT) X2(ICNT)=X2OUT 11271 CONTINUE GOTO1900 C 11280 CONTINUE DO11281I=1,N ICNT=ICNT+1 CALL HERPPF(X2(I),ALPHA,BETA,X2OUT) X2(ICNT)=X2OUT 11281 CONTINUE GOTO1900 C 11290 CONTINUE DO11291I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11291 ICNT=ICNT+1 CALL SDEPPF(X2(I),ALAMBA,X2OUT) X2(ICNT)=X2OUT 11291 CONTINUE GOTO1900 C 11300 CONTINUE DO11301I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11301 ICNT=ICNT+1 IF(IADEDF.EQ.'K')THEN CALL ADEPPF(X2(I),AK,IADEDF,X2OUT) ELSE CALL ADEPPF(X2(I),AMU,IADEDF,X2OUT) ENDIF X2(ICNT)=X2OUT 11301 CONTINUE GOTO1900 C 11310 CONTINUE DO11311I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11311 ICNT=ICNT+1 CALL MAXPPF(X2(I),SIGMA,X2OUT) X2(ICNT)=X2OUT 11311 CONTINUE GOTO1900 C 11320 CONTINUE DO11321I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11321 ICNT=ICNT+1 CALL RAYPPF(X2(I),X2OUT) X2(ICNT)=X2OUT 11321 CONTINUE GOTO1900 C 11330 CONTINUE DO11331I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11331 ICNT=ICNT+1 CALL GIGPPF(DBLE(X2(I)),DBLE(CHI),DBLE(ALAMBA),DBLE(THETA), 1 DX2OUT) X2OUT=REAL(DX2OUT) X2(ICNT)=X2OUT 11331 CONTINUE GOTO1900 C 11340 CONTINUE DO11341I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11341 ICNT=ICNT+1 CALL GALPPF(DBLE(X2(I)),DBLE(AK),DBLE(TAU),IADEDF,DX2OUT) X2OUT=REAL(DX2OUT) X2(ICNT)=X2OUT 11341 CONTINUE GOTO1900 C 11350 CONTINUE DO11351I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11351 ICNT=ICNT+1 CALL MCLPPF(DBLE(X2(I)),DBLE(ALPHA),DX2OUT) X2OUT=REAL(DX2OUT) X2(ICNT)=X2OUT 11351 CONTINUE GOTO1900 C 11360 CONTINUE IF(IBEIDF.EQ.'1')THEN DO11361I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11361 ICNT=ICNT+1 CALL BEIPPF(DBLE(X2(I)),DBLE(SD1),DBLE(SD2),DBLE(ANU),IBEIDF, 1 DX2OUT) X2OUT=REAL(DX2OUT) X2(ICNT)=X2OUT 11361 CONTINUE ELSE DO11366I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11366 ICNT=ICNT+1 CALL BEIPPF(DBLE(X2(I)),DBLE(B),DBLE(C),DBLE(AM),IBEIDF, 1 DX2OUT) X2OUT=REAL(DX2OUT) X2(ICNT)=X2OUT 11366 CONTINUE ENDIF GOTO1900 C 11370 CONTINUE DO11371I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11371 ICNT=ICNT+1 CCCCC CALL BEKPPF(DBLE(X2(I)),DBLE(SD1),DBLE(SD2),DBLE(ANU),DX2OUT) X2OUT=REAL(DX2OUT) X2(ICNT)=X2OUT 11371 CONTINUE GOTO1900 C 11380 CONTINUE DO11381I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11381 ICNT=ICNT+1 CALL GMCPPF(DBLE(X2(I)),DBLE(ALPHA),DBLE(A),DX2OUT) X2OUT=REAL(DX2OUT) X2(ICNT)=X2OUT 11381 CONTINUE GOTO1900 C 11390 CONTINUE XPAR(1)=0.0D0 XPAR(2)=1.0D0 XPAR(3)=DBLE(ALPHA) DO11391I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11391 ICNT=ICNT+1 DX2OUT=QUAGLO(DBLE(X2(I)),XPAR) X2OUT=REAL(DX2OUT) X2(ICNT)=X2OUT 11391 CONTINUE GOTO1900 C 11400 CONTINUE XPAR(1)=0.0D0 XPAR(2)=1.0D0 XPAR(3)=DBLE(BETA) XPAR(4)=DBLE(GAMMA) XPAR(5)=DBLE(DELTA) DO11401I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11401 ICNT=ICNT+1 DX2OUT=QUAWAK(DBLE(X2(I)),XPAR) X2OUT=REAL(DX2OUT) X2(ICNT)=X2OUT 11401 CONTINUE GOTO1900 C 11410 CONTINUE DO11411I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11411 ICNT=ICNT+1 CALL BNOPPF(DBLE(X2(I)),DBLE(ALPHA),DBLE(BETA),DX2OUT) X2OUT=REAL(DX2OUT) X2(ICNT)=X2OUT 11411 CONTINUE GOTO1900 C 11420 CONTINUE DO11421I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11421 ICNT=ICNT+1 CALL GL2PPF(DBLE(X2(I)),DBLE(ALPHA),DX2OUT) X2OUT=REAL(DX2OUT) X2(ICNT)=X2OUT 11421 CONTINUE GOTO1900 C 11430 CONTINUE DO11431I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11431 ICNT=ICNT+1 CALL GL3PPF(DBLE(X2(I)),DBLE(ALPHA),DX2OUT) X2OUT=REAL(DX2OUT) X2(ICNT)=X2OUT 11431 CONTINUE GOTO1900 C 11440 CONTINUE DO11441I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11441 ICNT=ICNT+1 CALL GL4PPF(DBLE(X2(I)),DBLE(P),DBLE(Q),DX2OUT) X2OUT=REAL(DX2OUT) X2(ICNT)=X2OUT 11441 CONTINUE GOTO1900 C 11450 CONTINUE DO11451I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11451 ICNT=ICNT+1 CALL ALDPPF(DBLE(X2(I)),DBLE(ALPHA),DBLE(BETA),DX2OUT) X2OUT=REAL(DX2OUT) X2(ICNT)=X2OUT 11451 CONTINUE GOTO1900 C 11460 CONTINUE IF(IBGEDF.EQ.'UNSH')THEN DO11461I=1,N ICNT=ICNT+1 CALL BGEPPF(X2(I),ALPHA,BETA,X2OUT) X2(ICNT)=X2OUT 11461 CONTINUE ELSE DO11463I=1,N ICNT=ICNT+1 CALL BG2PPF(X2(I),ALPHA,BETA,X2OUT) X2(ICNT)=X2OUT 11463 CONTINUE ENDIF GOTO1900 C 11470 CONTINUE DO11471I=1,N ICNT=ICNT+1 CALL ZETPPF(X2(I),ALPHA,X2OUT) X2(ICNT)=X2OUT 11471 CONTINUE GOTO1900 C 11480 CONTINUE DO11481I=1,N ICNT=ICNT+1 CALL ZIPPPF(X2(I),ALPHA,NU,X2OUT) X2(ICNT)=X2OUT 11481 CONTINUE GOTO1900 C 11490 CONTINUE DO11491I=1,N ICNT=ICNT+1 CALL BTAPPF(X2(I),ALAMBA,REAL(K),X2OUT) X2(ICNT)=X2OUT 11491 CONTINUE GOTO1900 C 11500 CONTINUE DO11501I=1,N ICNT=ICNT+1 CALL GWAPPF(DBLE(X2(I)),DBLE(ALPHA),DBLE(BETA),DBLE(AK), 1 DX2OUT) X2(ICNT)=REAL(X2OUT) 11501 CONTINUE GOTO1900 C 11510 CONTINUE DO11511I=1,N ICNT=ICNT+1 CALL LPOPPF(X2(I),ALAMBA,THETA,X2OUT) X2(ICNT)=X2OUT 11511 CONTINUE GOTO1900 C 11520 CONTINUE DO11521I=1,N ICNT=ICNT+1 CALL LCTPPF(X2(I),NDUN,X2OUT) X2(ICNT)=X2OUT 11521 CONTINUE GOTO1900 C 11530 CONTINUE DO11531I=1,N ICNT=ICNT+1 CALL MATPPF(X2(I),K,X2OUT) X2(ICNT)=X2OUT 11531 CONTINUE GOTO1900 C 11540 CONTINUE DO11541I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO11541 ICNT=ICNT+1 CALL LBEPPF(X2(I),ALPHA,BETA,YLOWLM,YUPPLM,X2OUT) X2(ICNT)=X2OUT 11541 CONTINUE GOTO1900 C 11550 CONTINUE DO11551I=1,N ICNT=ICNT+1 CALL PAPPPF(DBLE(X2(I)),DBLE(THETA),DBLE(P),DX2OUT) X2(ICNT)=REAL(DX2OUT) 11551 CONTINUE GOTO1900 C 11560 CONTINUE DO11561I=1,N ICNT=ICNT+1 CALL LOSPPF(X2(I),P,NU,X2OUT) X2(ICNT)=X2OUT 11561 CONTINUE GOTO1900 C 11570 CONTINUE DO11571I=1,N ICNT=ICNT+1 CALL GLSPPF(X2(I),THETA,BETA,X2OUT) X2(ICNT)=X2OUT 11571 CONTINUE GOTO1900 C 11580 CONTINUE DO11581I=1,N ICNT=ICNT+1 CALL GNBPPF(X2(I),THETA,BETA,AM,X2OUT) X2(ICNT)=X2OUT 11581 CONTINUE GOTO1900 C 11590 CONTINUE IF(IGETDF.EQ.'THET')THEN SHAPE=THETA ELSE SHAPE=AMU ENDIF DO11591I=1,N ICNT=ICNT+1 CALL GETPPF(DBLE(X2(I)),DBLE(SHAPE),DBLE(BETA),IGETDF,DX2OUT) X2(ICNT)=REAL(DX2OUT) 11591 CONTINUE GOTO1900 C 11600 CONTINUE DO11601I=1,N ICNT=ICNT+1 CALL QBIPPF(X2(I),P,PHI,AM,X2OUT) X2(ICNT)=X2OUT 11601 CONTINUE GOTO1900 C 11610 CONTINUE IF(ICONDF.EQ.'THET')THEN SHAPE=THETA ELSE SHAPE=AMU ENDIF DO11611I=1,N ICNT=ICNT+1 CALL CONPPF(DBLE(X2(I)),DBLE(SHAPE),DBLE(AM),ICONDF,DX2OUT) X2(ICNT)=REAL(DX2OUT) 11611 CONTINUE GOTO1900 C 11620 CONTINUE DO11621I=1,N ICNT=ICNT+1 CALL LKPPF(DBLE(X2(I)),DBLE(A),DBLE(B),DBLE(BETA),DX2OUT) X2(ICNT)=REAL(DX2OUT) 11621 CONTINUE GOTO1900 C 11630 CONTINUE B=0.0 DO11631I=1,N ICNT=ICNT+1 CALL LKPPF(DBLE(X2(I)),DBLE(ALPHA),DBLE(B),DBLE(BETA),DX2OUT) X2(ICNT)=REAL(DX2OUT) 11631 CONTINUE GOTO1900 C 11640 CONTINUE DO11641I=1,N ICNT=ICNT+1 CALL DIWPPF(DBLE(X2(I)),DBLE(P),DBLE(BETA),DX2OUT) X2(ICNT)=REAL(DX2OUT) 11641 CONTINUE GOTO1900 C 11650 CONTINUE DO11651I=1,N ICNT=ICNT+1 CALL GLGPPF(X2(I),P,NU,A,X2OUT) X2(ICNT)=X2OUT 11651 CONTINUE GOTO1900 C 1900 CONTINUE N2=ICNT DO1910I=1,N2 D2(I)=1.0 1910 CONTINUE ICNT=0 DO1912I=1,N IF(ICENSO.EQ.'ON' .AND. X(I).EQ.0.0)GOTO1912 ICNT=ICNT+1 Y2(ICNT)=Y2(I) 1912 CONTINUE NPLOTV=2 GOTO9000 C C ******************************************** C ** STEP 4.2-- ** C ** DETERMINE PLOT COORDINATES ** C ** FOR THE 2-VARIABLE CASE ** C ** (THAT IS, FOR THE GROUPED DATA CASE) ** C ******************************************** C 2100 CONTINUE C CCCCC OCTOBER 2004: REMOVE BINS WITH ZERO FREQUENCY C ICNT=0 DO22101I=1,N IF(Y(I).GT.0.0)THEN ICNT=ICNT+1 Y2(ICNT)=Y(I) X2(ICNT)=X(I) D2(ICNT)=XHIGH(I) ENDIF 22101 CONTINUE N=ICNT DO22103I=1,N Y(I)=Y2(I) X(I)=X2(I) XHIGH(I)=D2(I) 22103 CONTINUE C CCCCC MAY 2005: FOR CASE WHERE BINS SPECIFIED AS LOWER AND UPPER CCCCC LIMITS, COMPUTE THE MID-POINTS OF EACH OF THE BINS. C IF(IDATSW.EQ.'FRE2')THEN DO22111I=1,N X(I)=(X(I) + XHIGH(I))/2.0 22111 CONTINUE ENDIF C CALL SORTC(X,Y,N,Y2,D2) XMIN=Y2(1) XMAX=Y2(N) C EPS=0.00001 IF(XMIN.LT.YLOWLM)YLOWLM=XMIN-EPS IF(XMAX.GT.YUPPLM)YUPPLM=XMAX+EPS C IF(ICASPL.EQ.'MAPP')THEN IF(INT(XMAX+0.5).GT.K)K=INT(XMAX+0.5) ELSEIF(ICASPL.EQ.'LCPP')THEN IF(INT(XMAX+0.5).GT.NDUN)NDUN=INT(XMAX+0.5) ENDIF C C CCCCC JANUARY 1996. DO NOT HANDLE LOG-NORMAL CASE SEPARATELY. CCCCC IF(ICASPL.EQ.'LNPP')GOTO2101 CCCCC GOTO2108 C2101 CONTINUE CCCCC DO2102I=1,N CCCCC Y2HOLD=Y2(I) CCCCC IF(Y2HOLD.LE.0.0)GOTO2103 CCCCC Y2(I)=ALOG(Y2HOLD) C2102 CONTINUE CCCCC GOTO2108 C2103 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,2104) C2104 FORMAT('***** ERROR IN PROBABILITY PLOT--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,2105) C2105 FORMAT(' A LOGNORMAL PROBABILITY PLOT WAS ATTEMPTED') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,2106) C2106 FORMAT(' ON A DATA SET THAT HAD A NON-POSITIVE VALUE.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,2107)Y2HOLD C2107 FORMAT(' THE NON-POSITIVE VALUE = ',E15.7) CCCCC CALL DPWRST('XXX','BUG ') CCCCC IERROR='YES' CCCCC GOTO9000 C2108 CONTINUE C SUM=0.0 DO2009I=1,N SUM=SUM+Y(I) 2009 CONTINUE NTOT=SUM+0.5 C IF(ICASPL.EQ.'UNPP')GOTO2110 IF(ICASPL.EQ.'NOPP')GOTO2120 IF(ICASPL.EQ.'LOPP')GOTO2130 IF(ICASPL.EQ.'DEPP')GOTO2140 IF(ICASPL.EQ.'CAPP')GOTO2150 IF(ICASPL.EQ.'LAPP')GOTO2160 IF(ICASPL.EQ.'LNPP')GOTO2170 IF(ICASPL.EQ.'HNPP')GOTO2180 IF(ICASPL.EQ.'TPP')GOTO2190 IF(ICASPL.EQ.'CSPP')GOTO2200 IF(ICASPL.EQ.'FPP')GOTO2210 IF(ICASPL.EQ.'EXPP')GOTO2220 IF(ICASPL.EQ.'GAPP')GOTO2230 IF(ICASPL.EQ.'BEPP')GOTO2240 IF(ICASPL.EQ.'WEPP')GOTO2250 IF(ICASPL.EQ.'E1PP')GOTO2260 IF(ICASPL.EQ.'E2PP')GOTO2270 IF(ICASPL.EQ.'PAPP')GOTO2280 IF(ICASPL.EQ.'BIPP')GOTO2290 IF(ICASPL.EQ.'GEPP')GOTO2300 IF(ICASPL.EQ.'POPP')GOTO2310 IF(ICASPL.EQ.'NBPP')GOTO2320 IF(ICASPL.EQ.'SEPP')GOTO2330 IF(ICASPL.EQ.'TRPP')GOTO2340 CCCCC FOLLOWING SECTION ADDED DECEMBER 1994. IF(ICASPL.EQ.'IGPP')GOTO2350 IF(ICASPL.EQ.'WAPP')GOTO2360 IF(ICASPL.EQ.'RIPP')GOTO2370 IF(ICASPL.EQ.'FLPP')GOTO2380 IF(ICASPL.EQ.'GPPP')GOTO2390 IF(ICASPL.EQ.'DUPP')GOTO2400 IF(ICASPL.EQ.'NTPP')GOTO2410 IF(ICASPL.EQ.'NFPP')GOTO2420 IF(ICASPL.EQ.'NCPP')GOTO2430 IF(ICASPL.EQ.'NCBP')GOTO2440 IF(ICASPL.EQ.'DNCT')GOTO2450 IF(ICASPL.EQ.'DNCF')GOTO2460 IF(ICASPL.EQ.'HYPP')GOTO2470 IF(ICASPL.EQ.'VMPP')GOTO2480 IF(ICASPL.EQ.'PNPP')GOTO2490 IF(ICASPL.EQ.'PLPP')GOTO2500 IF(ICASPL.EQ.'ALPP')GOTO2510 IF(ICASPL.EQ.'COPP')GOTO2520 IF(ICASPL.EQ.'PFPP')GOTO2530 IF(ICASPL.EQ.'CHPP')GOTO2540 IF(ICASPL.EQ.'DLPP')GOTO2550 IF(ICASPL.EQ.'LLPP')GOTO2560 IF(ICASPL.EQ.'GGPP')GOTO2570 IF(ICASPL.EQ.'WRPP')GOTO2580 IF(ICASPL.EQ.'YUPP')GOTO2585 IF(ICASPL.EQ.'ANPP')GOTO2590 IF(ICASPL.EQ.'ARPP')GOTO2600 IF(ICASPL.EQ.'FNPP')GOTO2610 IF(ICASPL.EQ.'TNPP')GOTO2620 IF(ICASPL.EQ.'LGPP')GOTO2630 IF(ICASPL.EQ.'HSPP')GOTO2640 IF(ICASPL.EQ.'GOPP')GOTO2650 IF(ICASPL.EQ.'HCPP')GOTO2660 IF(ICASPL.EQ.'HLPP')THEN GAMMA=-1.0 GOTO2670 ENDIF IF(ICASPL.EQ.'GZPP')GOTO2670 IF(ICASPL.EQ.'GVPP')GOTO2680 IF(ICASPL.EQ.'P2PP')GOTO2690 IF(ICASPL.EQ.'DWPP')GOTO2700 IF(ICASPL.EQ.'WCPP')GOTO2710 IF(ICASPL.EQ.'EWPP')GOTO2720 IF(ICASPL.EQ.'TEPP')GOTO2730 IF(ICASPL.EQ.'GLPP')GOTO2740 IF(ICASPL.EQ.'PEPP')GOTO2750 IF(ICASPL.EQ.'DGPP')GOTO2760 IF(ICASPL.EQ.'KAPP')GOTO2770 IF(ICASPL.EQ.'FCPP')GOTO2780 IF(ICASPL.EQ.'BBPP')GOTO2790 IF(ICASPL.EQ.'BRPP')GOTO2800 IF(ICASPL.EQ.'GXPP')GOTO2810 IF(ICASPL.EQ.'REPP')GOTO2820 IF(ICASPL.EQ.'NMPP')GOTO2830 IF(ICASPL.EQ.'GIPP')GOTO2840 IF(ICASPL.EQ.'LDPP')GOTO2850 IF(ICASPL.EQ.'JBPP')GOTO2860 IF(ICASPL.EQ.'JUPP')GOTO2870 IF(ICASPL.EQ.'IWPP')GOTO2880 IF(ICASPL.EQ.'LXPP')GOTO2890 IF(ICASPL.EQ.'EEPP')GOTO12900 IF(ICASPL.EQ.'TSPP')GOTO12910 IF(ICASPL.EQ.'BWPP')GOTO12920 IF(ICASPL.EQ.'GHPP')GOTO12930 IF(ICASPL.EQ.'LUPP')GOTO12940 IF(ICASPL.EQ.'ERPP')GOTO12950 IF(ICASPL.EQ.'TZPP')GOTO12960 IF(ICASPL.EQ.'GTPP')GOTO12970 IF(ICASPL.EQ.'FTPP')GOTO12980 IF(ICASPL.EQ.'SLPP')GOTO12990 IF(ICASPL.EQ.'SNPP')GOTO13000 IF(ICASPL.EQ.'STPP')GOTO13010 IF(ICASPL.EQ.'IBPP')GOTO13020 IF(ICASPL.EQ.'GMPP')GOTO13030 IF(ICASPL.EQ.'LZPP')GOTO13040 IF(ICASPL.EQ.'LTPP')GOTO13050 IF(ICASPL.EQ.'ASPP')GOTO13060 IF(ICASPL.EQ.'PZPP')GOTO13070 IF(ICASPL.EQ.'HEPP')GOTO13080 IF(ICASPL.EQ.'SDPP')GOTO13090 IF(ICASPL.EQ.'ADPP')GOTO13100 IF(ICASPL.EQ.'MXPP')GOTO13110 IF(ICASPL.EQ.'RAPP')GOTO13120 IF(ICASPL.EQ.'GIGP')GOTO13130 IF(ICASPL.EQ.'GALP')GOTO13140 IF(ICASPL.EQ.'MCPP')GOTO13150 IF(ICASPL.EQ.'BEIP')GOTO13160 IF(ICASPL.EQ.'BEKP')GOTO13170 IF(ICASPL.EQ.'GMCP')GOTO13180 IF(ICASPL.EQ.'G5PP')GOTO13190 IF(ICASPL.EQ.'WKPP')GOTO13200 IF(ICASPL.EQ.'BNPP')GOTO13210 IF(ICASPL.EQ.'G2PP')GOTO13220 IF(ICASPL.EQ.'G3PP')GOTO13230 IF(ICASPL.EQ.'G4PP')GOTO13240 IF(ICASPL.EQ.'AXPP')GOTO13250 IF(ICASPL.EQ.'BGPP')GOTO13260 IF(ICASPL.EQ.'ZEPP')GOTO13270 IF(ICASPL.EQ.'ZIPP')GOTO13280 IF(ICASPL.EQ.'BTPP')GOTO13290 IF(ICASPL.EQ.'BZPP')GOTO13300 IF(ICASPL.EQ.'LPPP')GOTO13310 IF(ICASPL.EQ.'LCPP')GOTO13320 IF(ICASPL.EQ.'MAPP')GOTO13330 IF(ICASPL.EQ.'LBPP')GOTO13340 IF(ICASPL.EQ.'AEPP')GOTO13350 IF(ICASPL.EQ.'LOST')GOTO13360 IF(ICASPL.EQ.'GSPP')GOTO13370 IF(ICASPL.EQ.'GNBP')GOTO13380 IF(ICASPL.EQ.'GETP')GOTO13390 IF(ICASPL.EQ.'QBPP')GOTO13400 IF(ICASPL.EQ.'CNPP')GOTO13410 IF(ICASPL.EQ.'LKPP')GOTO13420 IF(ICASPL.EQ.'KAPP')GOTO13430 IF(ICASPL.EQ.'DIWP')GOTO13440 IF(ICASPL.EQ.'GLGP')GOTO13450 C 2110 CONTINUE I2=0 DO2111I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2111 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2112K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL UNIPPF(UNIOSM,DISOSM) SUM=SUM+DISOSM 2112 CONTINUE X2(I)=SUM/ANI 2111 CONTINUE GOTO2900 C 2120 CONTINUE I2=0 DO2121I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2121 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2122K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL NORPPF(UNIOSM,DISOSM) SUM=SUM+DISOSM 2122 CONTINUE X2(I)=SUM/ANI 2121 CONTINUE GOTO2900 C 2130 CONTINUE I2=0 DO2131I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2131 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2132K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL LOGPPF(UNIOSM,DISOSM) SUM=SUM+DISOSM 2132 CONTINUE X2(I)=SUM/ANI 2131 CONTINUE GOTO2900 C 2140 CONTINUE I2=0 DO2141I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2141 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2142K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL DEXPPF(UNIOSM,DISOSM) SUM=SUM+DISOSM 2142 CONTINUE X2(I)=SUM/ANI 2141 CONTINUE GOTO2900 C 2150 CONTINUE I2=0 DO2151I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2151 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2152K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL CAUPPF(UNIOSM,DISOSM) SUM=SUM+DISOSM 2152 CONTINUE X2(I)=SUM/ANI 2151 CONTINUE GOTO2900 C 2160 CONTINUE I2=0 DO2161I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2161 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2162K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL LAMPPF(UNIOSM,ALAMBA,DISOSM) SUM=SUM+DISOSM 2162 CONTINUE X2(I)=SUM/ANI 2161 CONTINUE GOTO2900 C 2170 CONTINUE I2=0 DO2171I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2171 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2172K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CCCCC APRIL 1995. CHANGE FOLLOWING LINE. CCCCC CALL NORPPF(UNIOSM,DISOSM) CALL LGNPPF(UNIOSM,SIGMA,DISOSM) SUM=SUM+DISOSM 2172 CONTINUE X2(I)=SUM/ANI 2171 CONTINUE GOTO2900 C 2180 CONTINUE I2=0 DO2181I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2181 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2182K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL HFNPPF(UNIOSM,DISOSM) SUM=SUM+DISOSM 2182 CONTINUE X2(I)=SUM/ANI 2181 CONTINUE GOTO2900 C 2190 CONTINUE I2=0 DO2191I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2191 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2192K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CCCCC CALL TPPF(UNIOSM,NU,DISOSM) CALL TPPF(UNIOSM,ANU,DISOSM) SUM=SUM+DISOSM 2192 CONTINUE X2(I)=SUM/ANI 2191 CONTINUE GOTO2900 C 2200 CONTINUE I2=0 DO2201I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2201 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2202K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL CHSPPF(UNIOSM,NU,DISOSM) SUM=SUM+DISOSM 2202 CONTINUE X2(I)=SUM/ANI 2201 CONTINUE GOTO2900 C 2210 CONTINUE I2=0 DO2211I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2211 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2212K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL FPPF(UNIOSM,NU1,NU2,DISOSM) SUM=SUM+DISOSM 2212 CONTINUE X2(I)=SUM/ANI 2211 CONTINUE GOTO2900 C 2220 CONTINUE I2=0 DO2221I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2221 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2222K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL EXPPPF(UNIOSM,DISOSM) SUM=SUM+DISOSM 2222 CONTINUE X2(I)=SUM/ANI 2221 CONTINUE GOTO2900 C 2230 CONTINUE I2=0 DO2231I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2231 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2232K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GAMPPF(UNIOSM,GAMMA,DISOSM) SUM=SUM+DISOSM 2232 CONTINUE X2(I)=SUM/ANI 2231 CONTINUE GOTO2900 C 2240 CONTINUE I2=0 DO2241I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2241 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2242K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL BETPPF(UNIOSM,ALPHA,BETA,DISOSM) SUM=SUM+DISOSM 2242 CONTINUE X2(I)=SUM/ANI 2241 CONTINUE GOTO2900 C 2250 CONTINUE I2=0 DO2251I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2251 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2252K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CCCCC THE FOLLOWING LINE WAS CHANGED MAY 1993 CCCCC CALL WEIPPF(UNIOSM,GAMMA,DISOSM) CALL WEIPPF(UNIOSM,GAMMA,MINMAX,DISOSM) SUM=SUM+DISOSM 2252 CONTINUE X2(I)=SUM/ANI 2251 CONTINUE GOTO2900 C 2260 CONTINUE I2=0 DO2261I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2261 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2262K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CCCCC THE FOLLOWING LINE WAS CHANGED MAY 1993 CCCCC CALL EV1PPF(UNIOSM,DISOSM) CALL EV1PPF(UNIOSM,MINMAX,DISOSM) SUM=SUM+DISOSM 2262 CONTINUE X2(I)=SUM/ANI 2261 CONTINUE GOTO2900 C 2270 CONTINUE I2=0 DO2271I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2271 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2272K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CCCCC THE FOLLOWING LINE WAS CHANGED MAY 1993 CCCCC CALL EV2PPF(UNIOSM,GAMMA,DISOSM) CALL EV2PPF(UNIOSM,GAMMA,MINMAX,DISOSM) SUM=SUM+DISOSM 2272 CONTINUE X2(I)=SUM/ANI 2271 CONTINUE GOTO2900 C 2280 CONTINUE I2=0 ZLOC=A IF(ZLOC.GT.XMIN)ZLOC=XMIN DO2281I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2281 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2282K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL PARPPF(UNIOSM,GAMMA,ZLOC,DISOSM) SUM=SUM+DISOSM 2282 CONTINUE X2(I)=SUM/ANI 2281 CONTINUE GOTO2900 C 2290 CONTINUE I2=0 DO2291I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2291 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2292K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL BINPPF(UNIOSM,P,NPAR,DISOSM) SUM=SUM+DISOSM 2292 CONTINUE X2(I)=SUM/ANI 2291 CONTINUE GOTO2900 C 2300 CONTINUE I2=0 DO2301I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2301 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2302K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GEOPPF(UNIOSM,P,DISOSM) SUM=SUM+DISOSM 2302 CONTINUE X2(I)=SUM/ANI 2301 CONTINUE GOTO2900 C 2310 CONTINUE I2=0 DO2311I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2311 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2312K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL POIPPF(UNIOSM,ALAMBA,DISOSM) SUM=SUM+DISOSM 2312 CONTINUE X2(I)=SUM/ANI 2311 CONTINUE GOTO2900 C 2320 CONTINUE I2=0 DO2321I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2321 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2322K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CCCCC THE FOLLOWING LINE WAS ADDED MAY 1992 (JJF) CCCCC KPAR=K CALL NBPPF(UNIOSM,P,AK,DISOSM) SUM=SUM+DISOSM 2322 CONTINUE X2(I)=SUM/ANI 2321 CONTINUE GOTO2900 C 2330 CONTINUE ASCALE=1.0 I2=0 DO2331I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2331 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2332K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL SEMPPF(UNIOSM,ASCALE,DISOSM) SUM=SUM+DISOSM 2332 CONTINUE X2(I)=SUM/ANI 2331 CONTINUE GOTO2900 C 2340 CONTINUE ZLOWLM=-1.0 ZUPPLM=1.0 I2=0 DO2341I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2341 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2342K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CCCCC CALL TRIPPF(UNIOSM,DISOSM) CALL TRIPPF(UNIOSM,C,ZLOWLM,ZUPPLM,DISOSM) SUM=SUM+DISOSM 2342 CONTINUE X2(I)=SUM/ANI 2341 CONTINUE GOTO2900 C CCCCC ADDED SEPTEMBER 1994. 2350 CONTINUE I2=0 DO2351I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2351 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2352K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL IGPPF(UNIOSM,GAMMA,AMU,DISOSM) SUM=SUM+DISOSM 2352 CONTINUE X2(I)=SUM/ANI 2351 CONTINUE GOTO2900 C CCCCC ADDED SEPTEMBER 1994. 2360 CONTINUE I2=0 DO2361I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2361 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2362K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL WALPPF(UNIOSM,GAMMA,DISOSM) SUM=SUM+DISOSM 2362 CONTINUE X2(I)=SUM/ANI 2361 CONTINUE GOTO2900 C CCCCC ADDED SEPTEMBER 1994. 2370 CONTINUE I2=0 DO2371I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2371 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2372K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL RIGPPF(UNIOSM,GAMMA,AMU,DISOSM) SUM=SUM+DISOSM 2372 CONTINUE X2(I)=SUM/ANI 2371 CONTINUE GOTO2900 C CCCCC ADDED SEPTEMBER 1994. 2380 CONTINUE I2=0 DO2381I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2381 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2382K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL FLPPF(UNIOSM,GAMMA,DISOSM) SUM=SUM+DISOSM 2382 CONTINUE X2(I)=SUM/ANI 2381 CONTINUE GOTO2900 C CCCCC ADDED SEPTEMBER 1994. 2390 CONTINUE I2=0 DO2391I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2391 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2392K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GEPPPF(UNIOSM,GAMMA,MINMAX,IGEPDF,DISOSM) SUM=SUM+DISOSM 2392 CONTINUE X2(I)=SUM/ANI 2391 CONTINUE GOTO2900 C CCCCC ADDED SEPTEMBER 1994. 2400 CONTINUE I2=0 DO2401I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2401 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2402K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL DISPPF(UNIOSM,NDUN,DISOSM) SUM=SUM+DISOSM 2402 CONTINUE X2(I)=SUM/ANI 2401 CONTINUE GOTO2900 C CCCCC ADDED SEPTEMBER 1994. 2410 CONTINUE I2=0 DO2411I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2411 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2412K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL NCTPPF(UNIOSM,ANU,ALAMBA,DISOSM) SUM=SUM+DISOSM 2412 CONTINUE X2(I)=SUM/ANI 2411 CONTINUE GOTO2900 C CCCCC ADDED SEPTEMBER 1994. 2420 CONTINUE I2=0 DO2421I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2421 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2422K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL NCFPPF(UNIOSM,ANU1,ANU2,ALAMBA,DISOSM) SUM=SUM+DISOSM 2422 CONTINUE X2(I)=SUM/ANI 2421 CONTINUE GOTO2900 C CCCCC ADDED SEPTEMBER 1994. 2430 CONTINUE I2=0 DO2431I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2431 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2432K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL NCCPPF(UNIOSM,ANU,ALAMBA,DISOSM) SUM=SUM+DISOSM 2432 CONTINUE X2(I)=SUM/ANI 2431 CONTINUE GOTO2900 C CCCCC ADDED SEPTEMBER 1994. 2440 CONTINUE I2=0 DO2441I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2441 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2442K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL NCBPPF(UNIOSM,ALPHA,BETA,ALAMBA,DISOSM) SUM=SUM+DISOSM 2442 CONTINUE X2(I)=SUM/ANI 2441 CONTINUE GOTO2900 C CCCCC ADDED SEPTEMBER 1994. 2450 CONTINUE I2=0 DO2451I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2451 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2452K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL DNTPPF(UNIOSM,ANU,ALAMB1,ALAMB2,DISOSM) SUM=SUM+DISOSM 2452 CONTINUE X2(I)=SUM/ANI 2451 CONTINUE GOTO2900 C CCCCC ADDED SEPTEMBER 1994. 2460 CONTINUE I2=0 DO2461I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2461 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2462K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL DNFPPF(UNIOSM,ANU1,ANU2,ALAMB1,ALAMB2,DISOSM) SUM=SUM+DISOSM 2462 CONTINUE X2(I)=SUM/ANI 2461 CONTINUE GOTO2900 C 2470 CONTINUE I2=0 DO2471I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2471 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2472K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL HYPPPF(UNIOSM,K,NPAR,MPAR,DISOSM) SUM=SUM+DISOSM 2472 CONTINUE X2(I)=SUM/ANI 2471 CONTINUE GOTO2900 C 2480 CONTINUE I2=0 DO2481I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2481 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2482K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL VONPPF(UNIOSM,B,DISOSM) SUM=SUM+DISOSM 2482 CONTINUE X2(I)=SUM/ANI 2481 CONTINUE GOTO2900 C 2490 CONTINUE I2=0 DO2491I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2491 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2492K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL PNRPPF(UNIOSM,P,SD,DISOSM) SUM=SUM+DISOSM 2492 CONTINUE X2(I)=SUM/ANI 2491 CONTINUE GOTO2900 C 2500 CONTINUE I2=0 DO2501I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2501 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2502K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL PLNPPF(UNIOSM,P,SD,DISOSM) SUM=SUM+DISOSM 2502 CONTINUE X2(I)=SUM/ANI 2501 CONTINUE GOTO2900 C 2510 CONTINUE I2=0 DO2511I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2511 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2512K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL ALPPPF(UNIOSM,ALPHA,BETA,DISOSM) SUM=SUM+DISOSM 2512 CONTINUE X2(I)=SUM/ANI 2511 CONTINUE GOTO2900 C 2520 CONTINUE I2=0 DO2521I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2521 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2522K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL COSPPF(UNIOSM,DISOSM) SUM=SUM+DISOSM 2522 CONTINUE X2(I)=SUM/ANI 2521 CONTINUE GOTO2900 C 2530 CONTINUE I2=0 DO2531I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2531 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2532K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL POWPPF(UNIOSM,C,DISOSM) SUM=SUM+DISOSM 2532 CONTINUE X2(I)=SUM/ANI 2531 CONTINUE GOTO2900 C 2540 CONTINUE I2=0 DO2541I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2541 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2542K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL CHPPF(UNIOSM,ANU,DISOSM) SUM=SUM+DISOSM 2542 CONTINUE X2(I)=SUM/ANI 2541 CONTINUE GOTO2900 C 2550 CONTINUE I2=0 DO2551I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2551 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2552K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL DLGPPF(UNIOSM,THETA,DISOSM) SUM=SUM+DISOSM 2552 CONTINUE X2(I)=SUM/ANI 2551 CONTINUE GOTO2900 C 2560 CONTINUE I2=0 DO2561I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2561 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2562K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL LLGPPF(UNIOSM,DELTA,DISOSM) SUM=SUM+DISOSM 2562 CONTINUE X2(I)=SUM/ANI 2561 CONTINUE GOTO2900 C 2570 CONTINUE I2=0 DO2571I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2571 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2572K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GGDPPF(UNIOSM,GAMMA,C,DISOSM) SUM=SUM+DISOSM 2572 CONTINUE X2(I)=SUM/ANI 2571 CONTINUE GOTO2900 C 2580 CONTINUE I2=0 DO2581I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2581 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2582K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL WARPPF(UNIOSM,C,A,DISOSM,'NOTR') SUM=SUM+DISOSM 2582 CONTINUE X2(I)=SUM/ANI 2581 CONTINUE GOTO2900 C 2585 CONTINUE I2=0 DO2586I=1,N NI=D2(I) IF(NI.LE.0)GOTO2586 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2587K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL YULPPF(UNIOSM,P,DISOSM) SUM=SUM+DISOSM 2587 CONTINUE X2(I)=SUM/ANI 2586 CONTINUE GOTO2900 C 2590 CONTINUE I2=0 DO2591I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2591 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2592K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL ANGPPF(UNIOSM,DISOSM) SUM=SUM+DISOSM 2592 CONTINUE X2(I)=SUM/ANI 2591 CONTINUE GOTO2900 C 2600 CONTINUE I2=0 DO2601I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2601 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2602K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL ARSPPF(UNIOSM,DISOSM) SUM=SUM+DISOSM 2602 CONTINUE X2(I)=SUM/ANI 2601 CONTINUE GOTO2900 C 2610 CONTINUE I2=0 DO2611I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2611 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2612K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL FNRPPF(UNIOSM,AM,SD,DISOSM) SUM=SUM+DISOSM 2612 CONTINUE X2(I)=SUM/ANI 2611 CONTINUE GOTO2900 C 2620 CONTINUE I2=0 DO2621I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2621 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2622K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL TNRPPF(UNIOSM,A,B,AM,SD,DISOSM) SUM=SUM+DISOSM 2622 CONTINUE X2(I)=SUM/ANI 2621 CONTINUE GOTO2900 C 2630 CONTINUE I2=0 DO2631I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2631 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2632K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL LGAPPF(UNIOSM,GAMMA,ILGADF,DISOSM) SUM=SUM+DISOSM 2632 CONTINUE X2(I)=SUM/ANI 2631 CONTINUE GOTO2900 C 2640 CONTINUE I2=0 DO2641I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2641 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2642K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL HSEPPF(UNIOSM,DISOSM) SUM=SUM+DISOSM 2642 CONTINUE X2(I)=SUM/ANI 2641 CONTINUE GOTO2900 C 2650 CONTINUE I2=0 DO2651I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2651 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2652K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GOMPPF(UNIOSM,C,B,DISOSM) SUM=SUM+DISOSM 2652 CONTINUE X2(I)=SUM/ANI 2651 CONTINUE GOTO2900 C 2660 CONTINUE I2=0 DO2661I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2661 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2662K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL HFCPPF(UNIOSM,DISOSM) SUM=SUM+DISOSM 2662 CONTINUE X2(I)=SUM/ANI 2661 CONTINUE GOTO2900 C 2670 CONTINUE I2=0 DO2671I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2671 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2672K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL HFLPPF(UNIOSM,GAMMA,DISOSM) SUM=SUM+DISOSM 2672 CONTINUE X2(I)=SUM/ANI 2671 CONTINUE GOTO2900 C 2680 CONTINUE I2=0 DO2681I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2681 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2682K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GEVPPF(UNIOSM,GAMMA,MINMAX,DISOSM) SUM=SUM+DISOSM 2682 CONTINUE X2(I)=SUM/ANI 2681 CONTINUE GOTO2900 C 2690 CONTINUE I2=0 ZLOC=A IF(ZLOC.LE.0.0)ZLOC=1.0 DO2691I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2691 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2692K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL PA2PPF(UNIOSM,GAMMA,ZLOC,DISOSM) SUM=SUM+DISOSM 2692 CONTINUE X2(I)=SUM/ANI 2691 CONTINUE GOTO2900 C 2700 CONTINUE I2=0 DO2701I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2701 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2702K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL DWEPPF(UNIOSM,GAMMA,DISOSM) SUM=SUM+DISOSM 2702 CONTINUE X2(I)=SUM/ANI 2701 CONTINUE GOTO2900 C 2710 CONTINUE I2=0 DO2711I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2711 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2712K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL WCAPPF(UNIOSM,P,DISOSM) SUM=SUM+DISOSM 2712 CONTINUE X2(I)=SUM/ANI 2711 CONTINUE GOTO2900 C 2720 CONTINUE I2=0 DO2721I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2721 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2722K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IARG1=1 CALL EWEPPF(UNIOSM,GAMMA,THETA,IARG1,DISOSM) SUM=SUM+DISOSM 2722 CONTINUE X2(I)=SUM/ANI 2721 CONTINUE GOTO2900 C 2730 CONTINUE I2=0 DO2731I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2731 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2732K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IARG1=1 CALL TNEPPF(UNIOSM,X0,AM,SD,DISOSM) SUM=SUM+DISOSM 2732 CONTINUE X2(I)=SUM/ANI 2731 CONTINUE GOTO2900 C 2740 CONTINUE I2=0 DO2741I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2741 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2742K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IARG1=1 CALL GLOPPF(UNIOSM,ALPHA,DISOSM) SUM=SUM+DISOSM 2742 CONTINUE X2(I)=SUM/ANI 2741 CONTINUE GOTO2900 C 2750 CONTINUE I2=0 DO2751I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2751 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2752K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IARG1=1 CALL PEXPPF(UNIOSM,ALPHA,BETA,DISOSM) SUM=SUM+DISOSM 2752 CONTINUE X2(I)=SUM/ANI 2751 CONTINUE GOTO2900 C 2760 CONTINUE I2=0 DO2761I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2761 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2762K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IARG1=1 CALL DGAPPF(UNIOSM,GAMMA,DISOSM) SUM=SUM+DISOSM 2762 CONTINUE X2(I)=SUM/ANI 2761 CONTINUE GOTO2900 C 2770 CONTINUE I2=0 DO2771I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2771 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2772K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IARG1=1 CALL KAPPPF(UNIOSM,ANU,BETA,THETA,DISOSM) SUM=SUM+DISOSM 2772 CONTINUE X2(I)=SUM/ANI 2771 CONTINUE GOTO2900 C 2780 CONTINUE I2=0 DO2781I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2781 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2782K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IARG1=1 CALL FCAPPF(UNIOSM,AM,SD,DISOSM) SUM=SUM+DISOSM 2782 CONTINUE X2(I)=SUM/ANI 2781 CONTINUE GOTO2900 C 2790 CONTINUE I2=0 DO2791I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2791 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2792K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IARG1=1 CALL BBNPPF(UNIOSM,ALPHA,BETA,NU,DISOSM) SUM=SUM+DISOSM 2792 CONTINUE X2(I)=SUM/ANI 2791 CONTINUE GOTO2900 C 2800 CONTINUE I2=0 DO2801I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2801 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2802K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IARG1=1 CALL BRAPPF(UNIOSM,BETA,DISOSM) SUM=SUM+DISOSM 2802 CONTINUE X2(I)=SUM/ANI 2801 CONTINUE GOTO2900 C 2810 CONTINUE I2=0 DO2811I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2811 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2812K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IARG1=1 CALL GEXPPF(UNIOSM,ALAMB1,ALAMB2,GAMMA,DISOSM) SUM=SUM+DISOSM 2812 CONTINUE X2(I)=SUM/ANI 2811 CONTINUE GOTO2900 C 2820 CONTINUE I2=0 DO2821I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2821 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2822K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IARG1=1 CALL RECPPF(UNIOSM,B,DISOSM) SUM=SUM+DISOSM 2822 CONTINUE X2(I)=SUM/ANI 2821 CONTINUE GOTO2900 C 2830 CONTINUE I2=0 DO2831I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2831 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2832K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IARG1=1 CALL NMXPPF(UNIOSM,U1,SD1,U2,SD2,P,DISOSM) SUM=SUM+DISOSM 2832 CONTINUE X2(I)=SUM/ANI 2831 CONTINUE GOTO2900 C 2840 CONTINUE I2=0 DO2841I=1,N NI=D2(I) CCCCC ADD FOLLOWING LINE FEBRUARY 1998. IF(NI.LE.0)GOTO2841 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2842K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IARG1=1 CALL IGAPPF(UNIOSM,GAMMA,DISOSM) SUM=SUM+DISOSM 2842 CONTINUE X2(I)=SUM/ANI 2841 CONTINUE GOTO2900 C 2850 CONTINUE I2=0 DO2851I=1,N NI=D2(I) IF(NI.LE.0)GOTO2851 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2852K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IWRITE='OFF' IF(IGLDDF.EQ.'RAMB')THEN IARG1=1 ARG3=-1.0 ZSCALE=1.0 CALL GLDCHK(ALAMB3,ALAMB4,ALOWER,AUPPER,IFLAG,ISIGN,IWRITE) ENDIF CALL GLDPPF(DBLE(UNIOSM),DBLE(ALAMB3),DBLE(ALAMB4), 1 DX2OUT,IGLDDF,IWRITE) DISOSM=REAL(DX2OUT) IF(IGLDDF.EQ.'RAMB')THEN SUM=SUM+(ZSCALE*DISOSM) ELSE SUM=SUM+DISOSM ENDIF 2852 CONTINUE X2(I)=SUM/ANI 2851 CONTINUE GOTO2900 C 2860 CONTINUE I2=0 DO2861I=1,N NI=D2(I) IF(NI.LE.0)GOTO2861 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2862K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL JSBPPF(UNIOSM,ALPHA1,ALPHA2,DISOSM) SUM=SUM+DISOSM 2862 CONTINUE X2(I)=SUM/ANI 2861 CONTINUE GOTO2900 C 2870 CONTINUE I2=0 DO2871I=1,N NI=D2(I) IF(NI.LE.0)GOTO2871 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2872K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL JSUPPF(UNIOSM,ALPHA1,ALPHA2,DISOSM) SUM=SUM+DISOSM 2872 CONTINUE X2(I)=SUM/ANI 2871 CONTINUE GOTO2900 C 2880 CONTINUE I2=0 DO2881I=1,N NI=D2(I) IF(NI.LE.0)GOTO2881 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2882K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL IWEPPF(UNIOSM,GAMMA,DISOSM) SUM=SUM+DISOSM 2882 CONTINUE X2(I)=SUM/ANI 2881 CONTINUE GOTO2900 C 2890 CONTINUE I2=0 DO2891I=1,N NI=D2(I) IF(NI.LE.0)GOTO2891 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2892K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL LDEPPF(UNIOSM,ALPHA,DISOSM) SUM=SUM+DISOSM 2892 CONTINUE X2(I)=SUM/ANI 2891 CONTINUE GOTO2900 C 12900 CONTINUE I2=0 DO12901I=1,N NI=D2(I) IF(NI.LE.0)GOTO12901 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO12902K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GEEPPF(UNIOSM,GAMMA,DISOSM) SUM=SUM+DISOSM 12902 CONTINUE X2(I)=SUM/ANI 12901 CONTINUE GOTO2900 C 12910 CONTINUE I2=0 DO12911I=1,N NI=D2(I) IF(NI.LE.0)GOTO12911 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO12912K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL TSPPPF(UNIOSM,THETA,ANU,DISOSM) SUM=SUM+DISOSM 12912 CONTINUE X2(I)=SUM/ANI 12911 CONTINUE GOTO2900 C 12920 CONTINUE I2=0 DO12921I=1,N NI=D2(I) IF(NI.LE.0)GOTO12921 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO12922K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL BWEPPF(UNIOSM,ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,DISOSM, 1 DX2OUT) SUM=SUM+DISOSM 12922 CONTINUE X2(I)=SUM/ANI 12921 CONTINUE GOTO2900 C 12930 CONTINUE I2=0 DO12931I=1,N NI=D2(I) IF(NI.LE.0)GOTO12931 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO12932K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GHPPF(UNIOSM,G,H,DISOSM,DBLE(UNIOSM),DX2OUT) SUM=SUM+DISOSM 12932 CONTINUE X2(I)=SUM/ANI 12931 CONTINUE GOTO2900 C 12940 CONTINUE I2=0 DO12941I=1,N NI=D2(I) IF(NI.LE.0)GOTO12941 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO12942K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) DISOSM=LANPPF(UNIOSM) SUM=SUM+DISOSM 12942 CONTINUE X2(I)=SUM/ANI 12941 CONTINUE GOTO2900 C 12950 CONTINUE I2=0 DO12951I=1,N NI=D2(I) IF(NI.LE.0)GOTO12951 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO12952K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL ERRPPF(UNIOSM,ALPHA,DISOSM) SUM=SUM+DISOSM 12952 CONTINUE X2(I)=SUM/ANI 12951 CONTINUE GOTO2900 C 12960 CONTINUE I2=0 DO12961I=1,N NI=D2(I) IF(NI.LE.0)GOTO12961 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO12962K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL TRAPPF(UNIOSM,A,B,C,DZ,DISOSM) SUM=SUM+DISOSM 12962 CONTINUE X2(I)=SUM/ANI 12961 CONTINUE GOTO2900 C 12970 CONTINUE I2=0 DO12971I=1,N NI=D2(I) IF(NI.LE.0)GOTO12971 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO12972K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GTRPPF(UNIOSM,A,B,C,DZ,ANU1,ANU3,ALPHA,DISOSM) SUM=SUM+DISOSM 12972 CONTINUE X2(I)=SUM/ANI 12971 CONTINUE GOTO2900 C 12980 CONTINUE I2=0 DO12981I=1,N NI=D2(I) IF(NI.LE.0)GOTO12981 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO12982K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL FTPPF(UNIOSM,NU,DISOSM) SUM=SUM+DISOSM 12982 CONTINUE X2(I)=SUM/ANI 12981 CONTINUE GOTO2900 C 12990 CONTINUE I2=0 DO12991I=1,N NI=D2(I) IF(NI.LE.0)GOTO12991 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO12992K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL SLAPPF(UNIOSM,DISOSM) SUM=SUM+DISOSM 12992 CONTINUE X2(I)=SUM/ANI 12991 CONTINUE GOTO2900 C 13000 CONTINUE I2=0 DO13001I=1,N NI=D2(I) IF(NI.LE.0)GOTO13001 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13002K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL SNPPF(UNIOSM,ALAMBA,ISKNDF,DISOSM) SUM=SUM+DISOSM 13002 CONTINUE X2(I)=SUM/ANI 13001 CONTINUE GOTO2900 C 13010 CONTINUE I2=0 DO13011I=1,N NI=D2(I) IF(NI.LE.0)GOTO13011 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13012K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL STPPF(UNIOSM,NU,ALAMBA,DISOSM) SUM=SUM+DISOSM 13012 CONTINUE X2(I)=SUM/ANI 13011 CONTINUE GOTO2900 C 13020 CONTINUE I2=0 DO13021I=1,N NI=D2(I) IF(NI.LE.0)GOTO13021 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13022K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL IBPPF(UNIOSM,ALPHA,BETA,DISOSM) SUM=SUM+DISOSM 13022 CONTINUE X2(I)=SUM/ANI 13021 CONTINUE GOTO2900 C 13030 CONTINUE I2=0 DO13031I=1,N NI=D2(I) IF(NI.LE.0)GOTO13031 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13032K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IF(IMAKDF.EQ.'DLMF')THEN CALL MAKPPF(UNIOSM,XI,ALAMB,THETA,DISOSM) ELSEIF(IMAKDF.EQ.'MEEK')THEN XI=GAMMA/AK THETA=ALAMB/GAMMA ALAMB=AK CALL MAKPPF(UNIOSM,XI,ALAMB,THETA,DISOSM) ELSEIF(IMAKDF.EQ.'REPA')THEN CALL MA2PPF(UNIOSM,ZETA,ETA,DISOSM) ENDIF SUM=SUM+DISOSM 13032 CONTINUE X2(I)=SUM/ANI 13031 CONTINUE GOTO2900 C 13040 CONTINUE I2=0 DO13041I=1,N NI=D2(I) IF(NI.LE.0)GOTO13041 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13042K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL LSNPPF(UNIOSM,ALAMBA,SD,DISOSM) SUM=SUM+DISOSM 13042 CONTINUE X2(I)=SUM/ANI 13041 CONTINUE GOTO2900 C 13050 CONTINUE I2=0 DO13051I=1,N NI=D2(I) IF(NI.LE.0)GOTO13051 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13052K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL LSTPPF(UNIOSM,NU,ALAMBA,SD,DISOSM) SUM=SUM+DISOSM 13052 CONTINUE X2(I)=SUM/ANI 13051 CONTINUE GOTO2900 C 13060 CONTINUE I2=0 DO13061I=1,N NI=D2(I) IF(NI.LE.0)GOTO13061 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13062K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL ARSPPF(UNIOSM,DISOSM) SUM=SUM+DISOSM 13062 CONTINUE X2(I)=SUM/ANI 13061 CONTINUE GOTO2900 C 13070 CONTINUE I2=0 DO13071I=1,N NI=D2(I) IF(NI.LE.0)GOTO13071 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13072K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IARG1=1 CALL POLPPF(UNIOSM,ALPHA,BETA,NU,DISOSM) SUM=SUM+DISOSM 13072 CONTINUE X2(I)=SUM/ANI 13071 CONTINUE GOTO2900 C 13080 CONTINUE I2=0 DO13081I=1,N NI=D2(I) IF(NI.LE.0)GOTO13081 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13082K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IARG1=1 CALL HERPPF(UNIOSM,ALPHA,BETA,DISOSM) SUM=SUM+DISOSM 13082 CONTINUE X2(I)=SUM/ANI 13081 CONTINUE GOTO2900 C 13090 CONTINUE I2=0 DO13091I=1,N NI=D2(I) IF(NI.LE.0)GOTO13091 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13092K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL SDEPPF(UNIOSM,ALAMBA,DISOSM) SUM=SUM+DISOSM 13092 CONTINUE X2(I)=SUM/ANI 13091 CONTINUE GOTO2900 C 13100 CONTINUE I2=0 DO13101I=1,N NI=D2(I) IF(NI.LE.0)GOTO13101 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13102K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IF(IADEDF.EQ.'K')THEN CALL ADEPPF(UNIOSM,AK,IADEDF,DISOSM) ELSE CALL ADEPPF(UNIOSM,AMU,IADEDF,DISOSM) ENDIF SUM=SUM+DISOSM 13102 CONTINUE X2(I)=SUM/ANI 13101 CONTINUE GOTO2900 C 13110 CONTINUE I2=0 DO13111I=1,N NI=D2(I) IF(NI.LE.0)GOTO13111 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13112K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL MAXPPF(UNIOSM,SIGMA,DISOSM) SUM=SUM+DISOSM 13112 CONTINUE X2(I)=SUM/ANI 13111 CONTINUE GOTO2900 C 13120 CONTINUE I2=0 DO13121I=1,N NI=D2(I) IF(NI.LE.0)GOTO13121 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13122K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL RAYPPF(UNIOSM,DISOSM) SUM=SUM+DISOSM 13122 CONTINUE X2(I)=SUM/ANI 13121 CONTINUE GOTO2900 C 13130 CONTINUE I2=0 DO13131I=1,N NI=D2(I) IF(NI.LE.0)GOTO13131 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13132K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GIGPPF(DBLE(UNIOSM),DBLE(CHI),DBLE(ALAMBA),DBLE(THETA), 1 DX2OUT) DISOSM=REAL(DX2OUT) SUM=SUM+DISOSM 13132 CONTINUE X2(I)=SUM/ANI 13131 CONTINUE GOTO2900 C 13140 CONTINUE I2=0 DO13141I=1,N NI=D2(I) IF(NI.LE.0)GOTO13141 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13142K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GALPPF(DBLE(UNIOSM),DBLE(AK),DBLE(TAU),IADEDF,DX2OUT) DISOSM=REAL(DX2OUT) SUM=SUM+DISOSM 13142 CONTINUE X2(I)=SUM/ANI 13141 CONTINUE GOTO2900 C 13150 CONTINUE I2=0 DO13151I=1,N NI=D2(I) IF(NI.LE.0)GOTO13151 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13152K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL MCLPPF(DBLE(UNIOSM),DBLE(ALPHA),DX2OUT) DISOSM=REAL(DX2OUT) SUM=SUM+DISOSM 13152 CONTINUE X2(I)=SUM/ANI 13151 CONTINUE GOTO2900 C 13160 CONTINUE I2=0 IF(IBEIDF.EQ.'1')THEN DO13161I=1,N NI=D2(I) IF(NI.LE.0)GOTO13161 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13162K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL BEIPPF(DBLE(UNIOSM),DBLE(SD1),DBLE(SD2),DBLE(ANU),IBEIDF, 1 DX2OUT) DISOSM=REAL(DX2OUT) SUM=SUM+DISOSM 13162 CONTINUE X2(I)=SUM/ANI 13161 CONTINUE ELSE DO13166I=1,N NI=D2(I) IF(NI.LE.0)GOTO13166 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13167K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL BEIPPF(DBLE(UNIOSM),DBLE(B),DBLE(C),DBLE(AM),IBEIDF, 1 DX2OUT) DISOSM=REAL(DX2OUT) SUM=SUM+DISOSM 13167 CONTINUE X2(I)=SUM/ANI 13166 CONTINUE ENDIF GOTO2900 C 13170 CONTINUE I2=0 IF(IBEIDF.EQ.'1')THEN DO13171I=1,N NI=D2(I) IF(NI.LE.0)GOTO13171 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13172K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CCCCC CALL BEKPPF(DBLE(UNIOSM),DBLE(SD1),DBLE(SD2),DBLE(ANU),DX2OUT) DISOSM=REAL(DX2OUT) SUM=SUM+DISOSM 13172 CONTINUE X2(I)=SUM/ANI 13171 CONTINUE ELSE DO13176I=1,N NI=D2(I) IF(NI.LE.0)GOTO13176 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13177K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CCCCC CALL BEKPPF(DBLE(UNIOSM),DBLE(B),DBLE(C),DBLE(AM),DX2OUT) DISOSM=REAL(DX2OUT) SUM=SUM+DISOSM 13177 CONTINUE X2(I)=SUM/ANI 13176 CONTINUE ENDIF GOTO2900 C 13180 CONTINUE I2=0 DO13181I=1,N NI=D2(I) IF(NI.LE.0)GOTO13181 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13182K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GMCPPF(DBLE(UNIOSM),DBLE(ALPHA),DBLE(A),DX2OUT) DISOSM=REAL(DX2OUT) SUM=SUM+DISOSM 13182 CONTINUE X2(I)=SUM/ANI 13181 CONTINUE GOTO2900 C 13190 CONTINUE I2=0 XPAR(1)=0.0D0 XPAR(2)=1.0D0 XPAR(3)=DBLE(ALPHA) DO13191I=1,N NI=D2(I) IF(NI.LE.0)GOTO13191 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13192K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) DX2OUT=QUAGLO(DBLE(UNIOSM),XPAR) DISOSM=REAL(DX2OUT) SUM=SUM+DISOSM 13192 CONTINUE X2(I)=SUM/ANI 13191 CONTINUE GOTO2900 C 13200 CONTINUE I2=0 XPAR(1)=0.0D0 XPAR(2)=1.0D0 XPAR(3)=DBLE(BETA) XPAR(4)=DBLE(GAMMA) XPAR(5)=DBLE(DELTA) DO13201I=1,N NI=D2(I) IF(NI.LE.0)GOTO13201 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13202K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) DX2OUT=QUAWAK(DBLE(UNIOSM),XPAR) DISOSM=REAL(DX2OUT) SUM=SUM+DISOSM 13202 CONTINUE X2(I)=SUM/ANI 13201 CONTINUE GOTO2900 C 13210 CONTINUE I2=0 DO13211I=1,N NI=D2(I) IF(NI.LE.0)GOTO13211 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13212K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL BNOPPF(DBLE(UNIOSM),DBLE(ALPHA),DBLE(BETA),DX2OUT) DISOSM=REAL(DX2OUT) SUM=SUM+DISOSM 13212 CONTINUE X2(I)=SUM/ANI 13211 CONTINUE GOTO2900 C 13220 CONTINUE I2=0 DO13221I=1,N NI=D2(I) IF(NI.LE.0)GOTO13221 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13222K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GL2PPF(DBLE(UNIOSM),DBLE(ALPHA),DX2OUT) DISOSM=REAL(DX2OUT) SUM=SUM+DISOSM 13222 CONTINUE X2(I)=SUM/ANI 13221 CONTINUE GOTO2900 C 13230 CONTINUE I2=0 DO13231I=1,N NI=D2(I) IF(NI.LE.0)GOTO13231 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13232K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GL3PPF(DBLE(UNIOSM),DBLE(ALPHA),DX2OUT) DISOSM=REAL(DX2OUT) SUM=SUM+DISOSM 13232 CONTINUE X2(I)=SUM/ANI 13231 CONTINUE GOTO2900 C 13240 CONTINUE I2=0 DO13241I=1,N NI=D2(I) IF(NI.LE.0)GOTO13241 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13242K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GL4PPF(DBLE(UNIOSM),DBLE(P),DBLE(Q),DX2OUT) DISOSM=REAL(DX2OUT) SUM=SUM+DISOSM 13242 CONTINUE X2(I)=SUM/ANI 13241 CONTINUE GOTO2900 C 13250 CONTINUE I2=0 DO13251I=1,N NI=D2(I) IF(NI.LE.0)GOTO13251 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13252K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL ALDPPF(DBLE(UNIOSM),DBLE(ALPHA),DBLE(BETA),DX2OUT) DISOSM=REAL(DX2OUT) SUM=SUM+DISOSM 13252 CONTINUE X2(I)=SUM/ANI 13251 CONTINUE GOTO2900 C 13260 CONTINUE I2=0 DO13261I=1,N NI=D2(I) IF(NI.LE.0)GOTO13261 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 IF(IBGEDF.EQ.'UNSH')THEN DO13262K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IARG1=1 CALL BGEPPF(UNIOSM,ALPHA,BETA,DISOSM) SUM=SUM+DISOSM 13262 CONTINUE ELSE DO13264K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IARG1=1 CALL BG2PPF(UNIOSM,ALPHA,BETA,DISOSM) SUM=SUM+DISOSM 13264 CONTINUE ENDIF X2(I)=SUM/ANI 13261 CONTINUE GOTO2900 C 13270 CONTINUE I2=0 DO13271I=1,N NI=D2(I) IF(NI.LE.0)GOTO13271 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13272K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IARG1=1 CALL ZETPPF(UNIOSM,ALPHA,DISOSM) SUM=SUM+DISOSM 13272 CONTINUE X2(I)=SUM/ANI 13271 CONTINUE GOTO2900 C 13280 CONTINUE I2=0 DO13281I=1,N NI=D2(I) IF(NI.LE.0)GOTO13281 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13282K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL ZIPPPF(UNIOSM,ALPHA,NU,DISOSM) SUM=SUM+DISOSM 13282 CONTINUE X2(I)=SUM/ANI 13281 CONTINUE GOTO2900 C 13290 CONTINUE I2=0 DO13291I=1,N NI=D2(I) IF(NI.LE.0)GOTO13291 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13292KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) IARG1=1 CALL BTAPPF(UNIOSM,ALAMBA,REAL(K),DISOSM) SUM=SUM+DISOSM 13292 CONTINUE X2(I)=SUM/ANI 13291 CONTINUE GOTO2900 C 13300 CONTINUE I2=0 DO13301I=1,N NI=D2(I) IF(NI.LE.0)GOTO13301 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13302K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IARG1=1 CALL GWAPPF(DBLE(UNIOSM),DBLE(ALPHA),DBLE(BETA),DBLE(AK), 1 DX2OUT) DISOSM=REAL(DX2OUT) SUM=SUM+DISOSM 13302 CONTINUE X2(I)=SUM/ANI 13301 CONTINUE GOTO2900 C 13310 CONTINUE I2=0 DO13311I=1,N NI=D2(I) IF(NI.LE.0)GOTO13311 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13312KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL LPOPPF(UNIOSM,ALAMBA,THETA,DISOSM) SUM=SUM+DISOSM 13312 CONTINUE X2(I)=SUM/ANI 13311 CONTINUE GOTO2900 C 13320 CONTINUE I2=0 DO13321I=1,N NI=D2(I) IF(NI.LE.0)GOTO13321 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13322KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL LCTPPF(UNIOSM,NDUN,DISOSM) SUM=SUM+DISOSM 13322 CONTINUE X2(I)=SUM/ANI 13321 CONTINUE GOTO2900 C 13330 CONTINUE I2=0 DO13331I=1,N NI=D2(I) IF(NI.LE.0)GOTO13331 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13332KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL MATPPF(UNIOSM,K,DISOSM) SUM=SUM+DISOSM 13332 CONTINUE X2(I)=SUM/ANI 13331 CONTINUE GOTO2900 C 13340 CONTINUE I2=0 DO13341I=1,N NI=D2(I) IF(NI.LE.0)GOTO13341 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13342K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL LBEPPF(UNIOSM,ALPHA,BETA,YLOWLM,YUPPLM,DISOSM) SUM=SUM+DISOSM 13342 CONTINUE X2(I)=SUM/ANI 13341 CONTINUE GOTO2900 C 13350 CONTINUE I2=0 DO13351I=1,N NI=D2(I) IF(NI.LE.0)GOTO13351 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13352KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL PAPPPF(DBLE(UNIOSM),DBLE(THETA),DBLE(P),DX2OUT) SUM=SUM+REAL(DX2OUT) 13352 CONTINUE X2(I)=SUM/ANI 13351 CONTINUE GOTO2900 C 13360 CONTINUE I2=0 DO13361I=1,N NI=D2(I) IF(NI.LE.0)GOTO13361 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13362KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL LOSPPF(UNIOSM,P,NU,X2OUT) SUM=SUM+X2OUT 13362 CONTINUE X2(I)=SUM/ANI 13361 CONTINUE GOTO2900 C 13370 CONTINUE I2=0 DO13371I=1,N NI=D2(I) IF(NI.LE.0)GOTO13371 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13372KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL GLSPPF(UNIOSM,THETA,BETA,X2OUT) SUM=SUM+X2OUT 13372 CONTINUE X2(I)=SUM/ANI 13371 CONTINUE GOTO2900 C 13380 CONTINUE I2=0 DO13381I=1,N NI=D2(I) IF(NI.LE.0)GOTO13381 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13382KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL GNBPPF(UNIOSM,THETA,BETA,AM,X2OUT) SUM=SUM+X2OUT 13382 CONTINUE X2(I)=SUM/ANI 13381 CONTINUE GOTO2900 C 13390 CONTINUE IF(IGETDF.EQ.'THET')THEN SHAPE=THETA ELSE SHAPE=AMU ENDIF I2=0 DO13391I=1,N NI=D2(I) IF(NI.LE.0)GOTO13391 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13392KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL GETPPF(DBLE(UNIOSM),DBLE(SHAPE),DBLE(BETA),IGETDF,DX2OUT) SUM=SUM+REAL(DX2OUT) 13392 CONTINUE X2(I)=SUM/ANI 13391 CONTINUE GOTO2900 C 13400 CONTINUE I2=0 DO13401I=1,N NI=D2(I) IF(NI.LE.0)GOTO13401 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13402KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL QBIPPF(UNIOSM,P,PHI,AM,X2OUT) SUM=SUM+X2OUT 13402 CONTINUE X2(I)=SUM/ANI 13401 CONTINUE GOTO2900 C 13410 CONTINUE IF(ICONDF.EQ.'THET')THEN SHAPE=THETA ELSE SHAPE=AMU ENDIF I2=0 DO13411I=1,N NI=D2(I) IF(NI.LE.0)GOTO13411 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13412KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL CONPPF(DBLE(UNIOSM),DBLE(SHAPE),DBLE(AM),ICONDF,DX2OUT) SUM=SUM+REAL(DX2OUT) 13412 CONTINUE X2(I)=SUM/ANI 13411 CONTINUE GOTO2900 C 13420 CONTINUE I2=0 DO13421I=1,N NI=D2(I) IF(NI.LE.0)GOTO13421 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13422KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL LKPPF(DBLE(UNIOSM),DBLE(A),DBLE(B),DBLE(BETA),DX2OUT) SUM=SUM+REAL(DX2OUT) 13422 CONTINUE X2(I)=SUM/ANI 13421 CONTINUE GOTO2900 C 13430 CONTINUE I2=0 B=0.0 DO13431I=1,N NI=D2(I) IF(NI.LE.0)GOTO13431 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13432KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL LKPPF(DBLE(UNIOSM),DBLE(ALPHA),DBLE(B),DBLE(BETA),DX2OUT) SUM=SUM+REAL(DX2OUT) 13432 CONTINUE X2(I)=SUM/ANI 13431 CONTINUE GOTO2900 C 13440 CONTINUE I2=0 DO13441I=1,N NI=D2(I) IF(NI.LE.0)GOTO13441 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13442KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL DIWPPF(DBLE(UNIOSM),DBLE(P),DBLE(BETA),DX2OUT) SUM=SUM+REAL(DX2OUT) 13442 CONTINUE X2(I)=SUM/ANI 13441 CONTINUE GOTO2900 C 13450 CONTINUE I2=0 DO13451I=1,N NI=D2(I) IF(NI.LE.0)GOTO13451 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO13452KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL GLGPPF(UNIOSM,P,NU,A,X2OUT) SUM=SUM+X2OUT 13452 CONTINUE X2(I)=SUM/ANI 13451 CONTINUE GOTO2900 C 2900 CONTINUE DO2910I=1,N D2(I)=1.0 2910 CONTINUE N2=N NPLOTV=2 GOTO9000 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 DPPP2--') 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)NTOT 9014 FORMAT('NTOT = ',I8) 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 DPPPCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1ICASP2, 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--GENERATE A PROBABILITY PLOT CORRELATION COEFFICIENT PLOT C FOR ONE OF THE FOLLOWING DISTRIBUTIONAL FAMILIES-- C UNIVARIATE CONTINUOUS (ONE SHAPE PARAMETER) C 1) TUKEY LAMBDA C 2) T C 3) CHI-SQUARED C 4) GAMMA C 5) WEIBULL --MIN & MAX C 6) EXTREME VALUE TYPE 2 (FRECHET) --MIN & MAX C 7) PARETO C 8) WALD C 9) FATIGUE LIFE C 10) EXTREME VALUE (GENERAL) C EXTREME VALUE PPCC PLOT Y C EXTREME PPCC PLOT Y C EV PPCCC PLOT Y C 11) GENERALIZED PARETO C GENERALIZED PARETO PPCC PLOT Y C GEP PPCC PLOT Y C GP PPCC PLOT Y C 12) LOGNORMAL C 13) POWER NORMAL C 14) POWER FUNCTION C 15) CHI C 16) VON MISES C 17) LOG LOGISTIC C 18) LOG GAMMA C 19) DOUBLE WEIBULL C 20) GENERALIZED EXTREME VALUE C 21) PARETO SECOND KIND C 22) GENERALIZED HALF LOGISTIC C 23) WRAPPED CAUCHY C 24) GENERALIZED LOGISTIC C 25) DOUBLE GAMMA C 26) BRADFORD C 27) RECIPROCAL C 28) INVERTED GAMMA C 29) INVERTED WEIBULL C 30) LOG DOUBLE EXPONENTIAL C 31) GEOMETRIC EXTREME EXPONENTIAL C 32) ERROR (SUBBOTIN/EXPONENTIAL POWER) C 33) FOLDED T C 34) SKEW NORMAL C 35) SKEW DOUBLE EXPONENTIAL C 36) ASYMMETRIC DOUBLE EXPONENTIAL C 37) MAXWELL C 38) MCLEISH C 39) GENERALIZED LOGISTIC TYPE 5 C 40) GENERALIZED LOGISTIC TYPE 2 C 41) GENERALIZED LOGISTIC TYPE 3 C C NOTE: EVEN THOUGH PARETO, PARETO SECOND KIND C ACTUALLY HAVE A SECOND SHAPE PARAMETER, TREAT C THIS AS KNOWN AND FIXED (SET TO MINIMUM OF C THE DATA FOR THE PARETO, LET USER SET FOR C PARETO SECOND KIND (DEFAULT TO 1)). C C UNIVARIATE DISCRETE (USE A LITTLE IFFY HERE, BUT C INCLUDE FOR EXPERIMENTAL PURPOSES, KS PLOT WORKS C BETTER THAN THE PPCC PLOT HERE) C 1) GEOMETRIC C 2) POISSON C 3) LOGARITHMIC SERIES C 4) NEGATIVE BIONOMIAL C 5) BETA-BINOMIAL (ASSUME N PARAMETER KNOWN) C 6) POLYA (ASSUME N PARAMETER KNOWN) C 7) HYPERGEOMETRIC (NOT SUPPORTED) C 8) YULE (SUPPORT CHI-SQUARE PLOT, BUT NOT PPCC) C 9) WARING (SUPPORT CHI-SQUARE PLOT, BUT NOT PPCC) C 10) HERMITE C 11) BINOMIAL C 12) BETA GEOMETRIC (RE-PARAMETERIZED WARING) C 13) ZETA (SUPPORT CHI-SQUARE PLOT, BUT NOT PPCC) C 14) ZIPF (SUPPORT CHI-SQUARE PLOT, BUT NOT PPCC) C 15) BOREL-TANNER C 16) LAGRANGE-POISSON C 17) POLYA-AEPPLI C 18) LOST GAMES C 19) GENERALIZED LOGARITHMIC SERIES C 20) GEETA C 21) CONSUL (GENERALIZED GEOMTRIC) C 22) KATZ (NOT ACTIVE) C 23) DISCRETE WEIBULL C 24) GENERALIZED LOST GAMES C C WE DO NOT INCLUDE DISCRETE UNIFORM, MATCHING, OR C LEADS IN COIN TOSSING (DISCRETE ARCSINE) SINCE THE C PARAMETER ESTIMATES ARE SIMPLY THE MINIMUM AND/OR C MAXIMUM POINTS IN THE DATA. ALSO, WE DO NOT C INCLUDE THE BETA-NEGATIVE BINOMIAL (= GENERALIZED C WARING) SINCE THIS HAS 3 SHAPE PARAMETERS. C C SUPPORT FOR FOLLOWING DISTRIBUTIONS WITH 2 SHAPE C PARAMETERS (AUGUST 2001). FOR THESE, WE WILL C GENERATE A 3-D PLOT. FOR SOME OF THESE, PPCC PLOT C CAN BE SLOW DUE TO FACT THAT PPCC MAY BE EXPENSIVE C TO COMPUTE. C 1) GENERALIZED TUKEY LAMBDA C 2) BETA C 3) GENERALIZED GAMMA C 4) GOMPERTZ C 5) EXPONENTIAL POWER C 6) POWER LOGNORMAL C 7) ALPHA C 8) EXPONENTIATED WEIBULL C 9) JOHNSON SB C 10) JOHNSON SU C 11) TWO-SIDED POWER C 12) F C 13) INVERSE GAUSSIAN C 14) RECIPROCAL INVERSE GAUSSIAN C 15) SKEW T C 16) INVERTED BETA C 17) G-AND-H C 18) LOG-SKEW-NORMAL C 19) NON-CENTRAL T C 20) NON-CENTRAL CHI-SQUARE C 21) FOLDED NORMAL C 22) FOLDED CAUCHY C 23) TRUNCATED EXPONENTIAL C (ASSUME TRUNCATION POINT X0 IS KNOWN) C 24) GOMPERTZ-MAKEHAM (FOR MEEKER REPARAMETERIZATION TO C CASE WITH TWO SHAPE PARAMETERS AND SCALE PARAMETER) C 25) GENERALIZED ASYMMETRIC LAPLACE C 26) GENERALIZED MCLEISH C 27) BETA NORMAL C 28) HYPERBOLIC (NOT WORKING) C 29) GENERALIZED LOGISTIC TYPE 4 C 30) ASYMMETRIC LOG DOUBLE EXPONENTIAL C 31) LOG BETA (ESTIMATE ALPHA, BETA, ASSUME FIXED C VALUES FOR C AND D) C C NOTE 1: FOR THE TRUNCATED EXPONENTIAL, IF YOU SET C MU1 =MU2, A PPCC PLOT FOR SD ONLY IS GENERATED. C C NOTE 2: THE NON-CENTRAL T, NON-CENTRAL CHI-SQUARE, C SKEW T, INVERTED BETA, LOG-SKEW-NORMAL, C GENERALIZED ASYMMETRIC LAPLACE, C GENERALIZED MCLEISH, HYPERBOLIC C HAVE EXPENSIVE PERCENT POINT FUNCTIONS, SO C THE PPCC PLOT CAN TAKE A LONG TIME (SO MAY C NOT BE PRACTICAL EXCEPT FOR RATHER SMALL DATA C SETS). WE ADDRESS THIS WITH THE COMMAND C C SET PPCC PLOT DATA POINTS C C IF THIS VALUE IS SET, THEN THE PPCC/KS C PLOT WILL COMPUTE THAT NUMBER OF EQUALLY C SPACED PERCENTILES OF THE DATA RATHER C THAN THE RAW DATA. C C FOLLOWING DATAPLOT SUPPORTED DISTRIBUTIONS ONLY C HAVE LOCATION AND SCALE PARAMETERS, SO PPCC PLOT C IS NOT APPLICABLE (I.E., JUST GENERATE PROB PLOT) C 1) NORMAL C 2) UNIFORM C 3) LOGISTIC C 4) DOUBLE EXPONENTIAL C 5) CAUCHY C 6) SEMI-CIRCULAR C 7) COSINE C 8) ANGLIT C 9) HYPERBOLIC SECANT C 10) HALF-NORMAL C 11) ARCSIN C 12) EXPONENTIAL C 13) EXTREME VALUE TYPE I (GUMBEL) C 14) HALF-CAUCHY C 15) LANDAU C 16) SLASH C 17) RAYLEIGH C C FOLLOWING HAVE MORE THAN 2 SHAPE PARAMETERS, SO C NOTHING IMPLEMENTED AT THIS TIME C 1) TRUNCATED NORMAL C 2) NON-CENTRAL F C 3) DOUBLY NON-CENTRAL F C 4) DOUBLY NON-CENTRAL T C 5) LOG-SKEW-T C 6) NON-CENTRAL BETA C 7) GENERALIZED EXPONENTIAL C 8) GOMPERTZ-MAKEHAM C NOTE: AVAILABLE IF MEEKER REPARAMERIZATION TO C TWO SHAPE PARAMETERS AND A SCALE PARAMETER IS USED C 9) MIELKE'S BETA-KAPPA C 10) NORMAL MIXTURE (MAXIMUM LIKELIHOOD ESTIMATE AVAILABLE) C 11) BI-WEIBULL C 12) GENERALIZED INVERSE GAUSSIAN C 13) BESSEL I-FUNCTION C 14) BESSEL K-FUNCTION C 15) WAKEBY (L-MOMENT ESTIMATES AVAILABLE) C 16) GENERALIZED NEGATIVE BINOMIAL C 17) LAGRANGE KATZ C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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--FEBRUARY 1981. C UPDATED --MAY 1982. C UPDATED --MAY 1990. IG, WALD, RIG, FL (SAUNDERS) C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C UPDATED --MAY 1993. MINMAX FOR EV1/EV2/WEIB DIST. C UPDATED --MAY 1993. ADD FRECHET NAME FOR EV2 C UPDATED --DECEMBER 1993. ADD EXTREME VALUE (GENERAL) C UPDATED --DECEMBER 1993. ADD GENERALIZED PARETO C UPDATED --APRIL 1995. ADD LOGNORMAL C UPDATED --APRIL 1995. ADD POWER NORMAL C UPDATED --APRIL 1995. ADD POWER LOGNORMAL C UPDATED --APRIL 1995. ADD POWER FUNCTION C UPDATED --APRIL 1995. ADD CHI C UPDATED --APRIL 1995. ADD VON MISES C UPDATED --APRIL 1995. ADD LOG LOGISTIC C UPDATED --OCTOBER 1995. ADD LOG GAMMA, 5 OTHERS C UPDATED --JANUARY 1996. ADD DOUBLE GAMMA C UPDATED --FEBRUARY 1996. ADD BRADFORD C UPDATED --MAY 1996. ADD RECIPROCAL C UPDATED --JANUARY 1998. ADD LOG SERIES, BINOMIAL, C NEGATIVE BINOMIAL C UPDATED --MAY 1998. ADD INVERTED GAMMA C UPDATED --AUGUST 2001. SUPPORT FOR A NUMBER OF C 2-SHAPE PARAMETER C DISTRIBUTIONS C UPDATED --SEPTEMBER 2001. 4 ADDITIONAL DISTRIBUTIONS C UPDATED --NOVEMBER 2001. GEOM EXTREME EXPONENTIAL C UPDATED --MAY 2002. TWO-SIDED POWER C UPDATED --MAY 2003. ERROR (=SUBBOTIN/EXPO POWE) C UPDATED --NOVEMBER 2003. FOLDED T C UPDATED --NOVEMBER 2003. F C UPDATED --DECEMBER 2003. SKEW NORMAL C UPDATED --DECEMBER 2003. SKEW T C UPDATED --DECEMBER 2003. INVERTED BETA C UPDATED --DECEMBER 2003. G-AND-H C UPDATED --MARCH 2004. MAKE COMMAND SEARCH TABLE C DRIVEN C UPDATED --MARCH 2004. SIGNIFICANT CLEAN-UP/BUG FIXES C FOR 2 SHAPE PARAMETER CASES C AND DISCRETE CASES C UPDATED --MARCH 2004. NON-CENTRAL CHI-SQUARE C UPDATED --MARCH 2004. NON-CENTRAL T C UPDATED --MARCH 2004. LOG-SKEW-NORMAL C UPDATED --APRIL 2004. HERMITE C UPDATED --MAY 2004. SUPPORT FOR ROBUST CORRELATION C MEASURES C UPDATED --MAY 2004. SUPPORT FOR A KOLMOGOROV-SMIRNOV C PLOT VARIANT C UPDATED --MAY 2004. SUPPORT FOR GENERATING 2-SHAPE C PARAMETER CASE AS A MULTI-TRACE C PLOT C UPDATED --JUNE 2004. SKEW DOUBLE EXPONENTIAL C UPDATED --JUNE 2004. ASYMMETRIC DOUBLE EXPONENTIAL C UPDATED --JUNE 2004. ARGUMENT LIST TO GEPPPF C UPDATED --JUNE 2004. MAXWELL C UPDATED --JULY 2004. GOMPERTZ-MAKEHAM IF MEEKER C REPARAMETERIZATION CASE USED C UPDATED --AUGUST 2004. GENERALIZED ASYMMETRIC LAPLACE C UPDATED --AUGUST 2004. BINOMIAL C UPDATED --AUGUST 2004. MCLEISH C UPDATED --SEPTEMBER 2004. GENERALIZED MCLEISH C UPDATED --SEPTEMBER 2004. HYPERBOLIC C UPDATED --SEPTEMBER 2004. SUPPORT FOR FOLLOWING OPTIONS: C 1) SET PPCC PLOT DATA POINTS C 2) SET PPCC PLOT AXIS POINTS C 3) SET PPCC PLOT AXIS ORDER C UPDATED --OCTOBER 2004. SUPPORT FOR CENSORED DATA C (UNBINNED CASE ONLY) C UPDATED --APRIL 2005. SUPPORT FOR REPLICATION (I.E., C GROUPS AS OPPOSSED TO BINS) C UPDATED --APRIL 2005. FOR BINNED DATA, SUPPORT CASE C WHERE LOWER AND UPPER BIN C BOUNDARIES SPECIFIED RATHER C THAN THE MID-POINTS. THIS C ALLOWS USER FLEXIBILITY IN C COMBINING BINS C UPDATED --AUGUST 2005. LOG LAPLACE AS SYNONYM FOR C LOG DOUBLE EXPONENTIAL C UPDATED --FEBRUARY 2006. GENERALIZED LOGISTIC TYPE 5 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 LAPLACE C UPDATED --MAY 2006. BETA GEOMETRIC C UPDATED --MAY 2006. ZETA C UPDATED --MAY 2006. BOREL-TANNER C UPDATED --JUNE 2006. LAGRANGE-POISSON 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. GEETA C UPDATED --AUGUST 2006. QUASI BINOMIAL TYPE I C UPDATED --AUGUST 2006. CONSUL (GENERALIZED GEOMETRIC) C UPDATED --SEPTEMBER 2006. KATZ C UPDATED --OCTOBER 2006. FRACTIONAL DEGREES OF FREEDOM C FOR T 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 ICASP2 CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IDATSW CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 IERRO2 CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHRIGH CHARACTER*4 IHRIG2 CHARACTER*4 IHRI2H CHARACTER*4 IHRI22 CHARACTER*4 IHRI3H CHARACTER*4 IHRI32 CHARACTER*4 IERRO4 C CCCCC THE FOLLOWING 3 LINES WERE ADDED MAY 1993 CHARACTER*4 IWRITE CHARACTER*4 IH CHARACTER*4 IH2 C CCCCC THE FOLLOWING LINE WAS ADDED DECEMBER 1993 CHARACTER*4 ISUBN0 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 LOWLTY CHARACTER*4 UPPLTY CHARACTER*30 IDIST CHARACTER*4 ICENSO CHARACTER*4 IREPL CHARACTER*4 IMETHD C PARAMETER (NUMCHS=161) CHARACTER*4 INAME(NUMCHS,4) CHARACTER*4 INCASE(NUMCHS) INTEGER ISHAPE(NUMCHS) C REAL KSLOC REAL KSSCAL C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(MAXOBV) DIMENSION X1(MAXOBV) DIMENSION X1UPP(MAXOBV) DIMENSION X1UTMP(MAXOBV) DIMENSION XCENS(MAXOBV) DIMENSION XREPL(MAXOBV) DIMENSION XREPDS(MAXOBV) DIMENSION DISPAR(MAXOBV) DIMENSION DISPA2(MAXOBV) DIMENSION DISPA3(MAXOBV) DIMENSION CORR(MAXOBV) DIMENSION CORR2(MAXOBV) DIMENSION XTEMP1(MAXOBV) DIMENSION XTEMP2(MAXOBV) DIMENSION XTEMP3(MAXOBV) DIMENSION XTEMP4(MAXOBV) DIMENSION XTEMP5(MAXOBV) DIMENSION XTEMP6(MAXOBV) DIMENSION XTEMP7(MAXOBV) DIMENSION XTEMP8(MAXOBV) DIMENSION XTEMP9(MAXOBV) DIMENSION X2TEMP(MAXOBV) DIMENSION Y2TEMP(MAXOBV) DIMENSION D2TEMP(MAXOBV) DIMENSION Y3(MAXOBV) DIMENSION XLOW(MAXOBV) DIMENSION XHIGH(MAXOBV) DIMENSION WEIGHH(MAXOBV) DIMENSION WEIGHV(MAXOBV) DIMENSION RESBW(MAXOBV) DIMENSION PREDBW(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZ2.INC' EQUIVALENCE (G2RBAG(IGAR11),X1(1)) EQUIVALENCE (G2RBAG(IGAR12),Y1(1)) EQUIVALENCE (G2RBAG(IGAR13),DISPAR(1)) EQUIVALENCE (G2RBAG(IGAR14),DISPA2(1)) EQUIVALENCE (G2RBAG(IGAR15),DISPA3(1)) EQUIVALENCE (G2RBAG(IGAR16),CORR(1)) EQUIVALENCE (G2RBAG(IGAR17),XTEMP1(1)) EQUIVALENCE (G2RBAG(IGAR18),XTEMP2(1)) EQUIVALENCE (G2RBAG(IGAR19),CORR2(1)) EQUIVALENCE (G2RBAG(IGAR20),XTEMP3(1)) EQUIVALENCE (G2RBAG(IGAR21),XTEMP4(1)) EQUIVALENCE (G2RBAG(IGAR22),XTEMP5(1)) EQUIVALENCE (G2RBAG(IGAR23),XTEMP6(1)) EQUIVALENCE (G2RBAG(IGAR24),XREPL(1)) EQUIVALENCE (G2RBAG(IGAR25),XCENS(1)) EQUIVALENCE (G2RBAG(IGAR26),Y3(1)) EQUIVALENCE (G2RBAG(IGAR27),XLOW(1)) EQUIVALENCE (G2RBAG(IGAR28),XHIGH(1)) EQUIVALENCE (G2RBAG(IGAR29),XREPDS(1)) EQUIVALENCE (G2RBAG(IGAR30),Y2TEMP(1)) EQUIVALENCE (G2RBAG(IGAR31),D2TEMP(1)) EQUIVALENCE (G2RBAG(IGAR32),X2TEMP(1)) EQUIVALENCE (G2RBAG(IGAR33),X1UPP(1)) EQUIVALENCE (G2RBAG(IGAR34),X1UTMP(1)) EQUIVALENCE (G2RBAG(IGAR35),XTEMP7(1)) EQUIVALENCE (G2RBAG(IGAR36),XTEMP8(1)) EQUIVALENCE (G2RBAG(IGAR37),XTEMP9(1)) EQUIVALENCE (G2RBAG(IGAR38),WEIGHH(1)) EQUIVALENCE (G2RBAG(IGAR39),WEIGHV(1)) EQUIVALENCE (G2RBAG(IGAR40),RESBW(1)) EQUIVALENCE (G2RBAG(IGAR41),PREDBW(1)) CCCCC END CHANGE C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' CCCCC THE FOLLOWING LINE WAS ADDED (FOR MINMAX) MAY 1993 INCLUDE 'DPCOSU.INC' CCCCC THE FOLLOWING LINE WAS ADDED (FOR MINMAX) MAY 1993 INCLUDE 'DPCOS2.INC' CCCCC THE FOLLOWING LINE WAS ADDED (FOR IHOST1/2) MAY 1993 INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOMC.INC' INCLUDE 'DPCOST.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 MARCH 2004. MAKE SEARCH TABLE DRIVEN C DATA INCASE(1)/'LACP'/ DATA ISHAPE(1)/1/ DATA (INAME(1,J),J=1,4)/'TUKE','LAMB',' ',' '/ DATA INCASE(2)/'LACP'/ DATA ISHAPE(2)/1/ DATA (INAME(2,J),J=1,4)/'TUKE',' ',' ',' '/ DATA INCASE(3)/'LACP'/ DATA ISHAPE(3)/1/ DATA (INAME(3,J),J=1,4)/'LAMB',' ',' ',' '/ DATA INCASE(4)/'LNCP'/ DATA ISHAPE(4)/1/ DATA (INAME(4,J),J=1,4)/'LOG ','NORM',' ',' '/ DATA INCASE(5)/'LNCP'/ DATA ISHAPE(5)/1/ DATA (INAME(5,J),J=1,4)/'LOGN',' ',' ',' '/ DATA INCASE(6)/'TCP'/ DATA ISHAPE(6)/1/ DATA (INAME(6,J),J=1,4)/'T ',' ',' ',' '/ DATA INCASE(7)/'TCP'/ DATA ISHAPE(7)/1/ DATA (INAME(7,J),J=1,4)/'STUD','T ',' ',' '/ DATA INCASE(8)/'CSCP'/ DATA ISHAPE(8)/1/ DATA (INAME(8,J),J=1,4)/'CHIS',' ',' ',' '/ DATA INCASE(9)/'CSCP'/ DATA ISHAPE(9)/1/ DATA (INAME(9,J),J=1,4)/'CHI ','SQUA',' ',' '/ DATA INCASE(10)/'FCP'/ DATA ISHAPE(10)/2/ DATA (INAME(10,J),J=1,4)/'F ',' ',' ',' '/ DATA INCASE(11)/'FCP'/ DATA ISHAPE(11)/2/ DATA (INAME(11,J),J=1,4)/'SNED','F ',' ',' '/ DATA INCASE(12)/'GACP'/ DATA ISHAPE(12)/1/ DATA (INAME(12,J),J=1,4)/'GAMM',' ',' ',' '/ DATA INCASE(13)/'BNCP'/ DATA ISHAPE(13)/2/ DATA (INAME(13,J),J=1,4)/'BETA','NORM',' ',' '/ DATA INCASE(14)/'WECP'/ DATA ISHAPE(14)/1/ DATA (INAME(14,J),J=1,4)/'WEIB',' ',' ',' '/ DATA INCASE(15)/'E2CP'/ DATA ISHAPE(15)/1/ DATA (INAME(15,J),J=1,4)/'EXTR','VALU','TYPE','2 '/ DATA INCASE(16)/'E2CP'/ DATA ISHAPE(16)/1/ DATA (INAME(16,J),J=1,4)/'EXTR','VALU','TYPE','II '/ DATA INCASE(17)/'E2CP'/ DATA ISHAPE(17)/1/ DATA (INAME(17,J),J=1,4)/'EVII',' ',' ',' '/ DATA INCASE(18)/'E2CP'/ DATA ISHAPE(18)/1/ DATA (INAME(18,J),J=1,4)/'EV2 ',' ',' ',' '/ DATA INCASE(19)/'E2CP'/ DATA ISHAPE(19)/1/ DATA (INAME(19,J),J=1,4)/'FREC',' ',' ',' '/ DATA INCASE(20)/'PACP'/ DATA ISHAPE(20)/1/ DATA (INAME(20,J),J=1,4)/'PARE',' ',' ',' '/ DATA INCASE(21)/'BICP'/ DATA ISHAPE(21)/1/ DATA (INAME(21,J),J=1,4)/'BINO',' ',' ',' '/ DATA INCASE(22)/'GECP'/ DATA ISHAPE(22)/1/ DATA (INAME(22,J),J=1,4)/'GEOM',' ',' ',' '/ DATA INCASE(23)/'POCP'/ DATA ISHAPE(23)/1/ DATA (INAME(23,J),J=1,4)/'POIS',' ',' ',' '/ DATA INCASE(24)/'NBCP'/ DATA ISHAPE(24)/2/ DATA (INAME(24,J),J=1,4)/'NEGA','BINO',' ',' '/ DATA INCASE(25)/'TRCP'/ DATA ISHAPE(25)/1/ DATA (INAME(25,J),J=1,4)/'TRIA',' ',' ',' '/ DATA INCASE(26)/'IGCP'/ DATA ISHAPE(26)/2/ DATA (INAME(26,J),J=1,4)/'INVE','GAUS',' ',' '/ DATA INCASE(27)/'IGCP'/ DATA ISHAPE(27)/2/ DATA (INAME(27,J),J=1,4)/'IG ',' ',' ',' '/ DATA INCASE(28)/'WACP'/ DATA ISHAPE(28)/1/ DATA (INAME(28,J),J=1,4)/'WALD',' ',' ',' '/ DATA INCASE(29)/'RICP'/ DATA ISHAPE(29)/2/ DATA (INAME(29,J),J=1,4)/'RIG ',' ',' ',' '/ DATA INCASE(30)/'RICP'/ DATA ISHAPE(30)/2/ DATA (INAME(30,J),J=1,4)/'TWEE',' ',' ',' '/ DATA INCASE(31)/'RICP'/ DATA ISHAPE(31)/2/ DATA (INAME(31,J),J=1,4)/'RECI','INVE','GAUS',' '/ DATA INCASE(32)/'FLCP'/ DATA ISHAPE(32)/1/ DATA (INAME(32,J),J=1,4)/'FATI','LIFE',' ',' '/ DATA INCASE(33)/'FLCP'/ DATA ISHAPE(33)/1/ DATA (INAME(33,J),J=1,4)/'FL ',' ',' ',' '/ DATA INCASE(34)/'FLCP'/ DATA ISHAPE(34)/1/ DATA (INAME(34,J),J=1,4)/'BIRN','SAUN',' ',' '/ DATA INCASE(35)/'FLCP'/ DATA ISHAPE(35)/1/ DATA (INAME(35,J),J=1,4)/'SAUN','BIRN',' ',' '/ DATA INCASE(36)/'GPCP'/ DATA ISHAPE(36)/1/ DATA (INAME(36,J),J=1,4)/'GENE','PARE',' ',' '/ DATA INCASE(37)/'GPCP'/ DATA ISHAPE(37)/1/ DATA (INAME(37,J),J=1,4)/'GEP ',' ',' ',' '/ DATA INCASE(38)/'GPCP'/ DATA ISHAPE(38)/1/ DATA (INAME(38,J),J=1,4)/'GP ',' ',' ',' '/ DATA ISHAPE(39)/2/ DATA INCASE(39)/'NTCP'/ DATA (INAME(39,J),J=1,4)/'NONC','T ',' ',' '/ DATA INCASE(40)/'NTCP'/ DATA ISHAPE(40)/2/ DATA (INAME(40,J),J=1,4)/'NON-','T ',' ',' '/ DATA INCASE(41)/'NTCP'/ DATA ISHAPE(41)/2/ DATA (INAME(41,J),J=1,4)/'NON ','CENT','T ',' '/ DATA INCASE(42)/'NCCP'/ DATA ISHAPE(42)/2/ DATA (INAME(42,J),J=1,4)/'NON ','CENT','CHIS',' '/ DATA INCASE(43)/'NCCP'/ DATA ISHAPE(43)/2/ DATA (INAME(43,J),J=1,4)/'NON ','CENT','CHI ','SQUA'/ DATA INCASE(44)/'NCCP'/ DATA ISHAPE(44)/2/ DATA (INAME(44,J),J=1,4)/'NONC','CHI ','SQUA',' '/ DATA INCASE(45)/'NCCP'/ DATA ISHAPE(45)/2/ DATA (INAME(45,J),J=1,4)/'NON ','CHI ','SQUA',' '/ DATA INCASE(46)/'NCCP'/ DATA ISHAPE(46)/2/ DATA (INAME(46,J),J=1,4)/'NONC','CHI ','SQUA',' '/ DATA INCASE(47)/'NCCP'/ DATA ISHAPE(47)/2/ DATA (INAME(47,J),J=1,4)/'NONC','CHIS',' ',' '/ DATA INCASE(48)/'VMCP'/ DATA ISHAPE(48)/1/ DATA (INAME(48,J),J=1,4)/'VON ','MISE',' ',' '/ DATA INCASE(49)/'VMCP'/ DATA ISHAPE(49)/1/ DATA (INAME(49,J),J=1,4)/'VONM',' ',' ',' '/ DATA INCASE(50)/'PNCP'/ DATA ISHAPE(50)/1/ DATA (INAME(50,J),J=1,4)/'POWE','NORM',' ',' '/ DATA INCASE(51)/'PLCP'/ DATA ISHAPE(51)/2/ DATA (INAME(51,J),J=1,4)/'POWE','LOGN',' ',' '/ DATA INCASE(52)/'PLCP'/ DATA ISHAPE(52)/2/ DATA (INAME(52,J),J=1,4)/'POWE','LGNO',' ',' '/ DATA INCASE(53)/'PLCP'/ DATA ISHAPE(53)/2/ DATA (INAME(53,J),J=1,4)/'POWE','LOG ',' ',' '/ DATA INCASE(54)/'ALCP'/ DATA ISHAPE(54)/2/ DATA (INAME(54,J),J=1,4)/'ALPH',' ',' ',' '/ DATA INCASE(55)/'PECP'/ DATA ISHAPE(55)/2/ DATA (INAME(55,J),J=1,4)/'POWE','EXPO',' ',' '/ DATA INCASE(56)/'PFCP'/ DATA ISHAPE(56)/1/ DATA (INAME(56,J),J=1,4)/'POWE','FUNC',' ',' '/ DATA INCASE(57)/'CHCP'/ DATA ISHAPE(57)/1/ DATA (INAME(57,J),J=1,4)/'CHI ',' ',' ',' '/ DATA INCASE(58)/'DLCP'/ DATA ISHAPE(58)/1/ DATA (INAME(58,J),J=1,4)/'LOGA','SERI',' ',' '/ DATA INCASE(59)/'LLCP'/ DATA ISHAPE(59)/1/ DATA (INAME(59,J),J=1,4)/'LOG ','LOGI',' ',' '/ DATA INCASE(60)/'LLCP'/ DATA ISHAPE(60)/1/ DATA (INAME(60,J),J=1,4)/'LOGL',' ',' ',' '/ DATA INCASE(61)/'GGCP'/ DATA ISHAPE(61)/2/ DATA (INAME(61,J),J=1,4)/'GENE','GAMM',' ',' '/ DATA INCASE(62)/'GICP'/ DATA ISHAPE(62)/1/ DATA (INAME(62,J),J=1,4)/'INVE','GAMM',' ',' '/ DATA INCASE(63)/'FNCP'/ DATA ISHAPE(63)/2/ DATA (INAME(63,J),J=1,4)/'FOLD','NORM',' ',' '/ DATA INCASE(64)/'LGCP'/ DATA ISHAPE(64)/1/ DATA (INAME(64,J),J=1,4)/'LOG ','GAMM',' ',' '/ DATA INCASE(65)/'GOCP'/ DATA ISHAPE(65)/2/ DATA (INAME(65,J),J=1,4)/'GOMP',' ',' ',' '/ DATA INCASE(66)/'GVCP'/ DATA ISHAPE(66)/1/ DATA (INAME(66,J),J=1,4)/'GENE','EXTR','VALU',' '/ DATA INCASE(67)/'GVCP'/ DATA ISHAPE(67)/1/ DATA (INAME(67,J),J=1,4)/'GEV ',' ',' ',' '/ DATA INCASE(68)/'P2CP'/ DATA ISHAPE(68)/1/ DATA (INAME(68,J),J=1,4)/'PARE','SECO','KIND',' '/ DATA INCASE(69)/'P2CP'/ DATA ISHAPE(69)/1/ DATA (INAME(69,J),J=1,4)/'PARE','TYPE','2 ',' '/ DATA INCASE(70)/'P2CP'/ DATA ISHAPE(70)/1/ DATA (INAME(70,J),J=1,4)/'PARE','TYPE','II ',' '/ DATA INCASE(71)/'DWCP'/ DATA ISHAPE(71)/1/ DATA (INAME(71,J),J=1,4)/'DOUB','WEIB',' ',' '/ DATA INCASE(72)/'EWCP'/ DATA ISHAPE(72)/2/ DATA (INAME(72,J),J=1,4)/'EXPO','WEIB',' ',' '/ DATA INCASE(73)/'WCCP'/ DATA ISHAPE(73)/1/ DATA (INAME(73,J),J=1,4)/'WRAP','CAUC',' ',' '/ DATA INCASE(74)/'G5CP'/ DATA ISHAPE(74)/1/ DATA (INAME(74,J),J=1,4)/'GENE','LOGI','TYPE','5 '/ DATA INCASE(75)/'PECP'/ DATA ISHAPE(75)/2/ DATA (INAME(75,J),J=1,4)/'EXPO','POWE',' ',' '/ DATA INCASE(76)/'DGCP'/ DATA ISHAPE(76)/1/ DATA (INAME(76,J),J=1,4)/'DOUB','GAMM',' ',' '/ DATA INCASE(77)/'FCCP'/ DATA ISHAPE(77)/2/ DATA (INAME(77,J),J=1,4)/'FOLD','CAUC',' ',' '/ DATA INCASE(78)/'BBCP'/ DATA ISHAPE(78)/2/ DATA (INAME(78,J),J=1,4)/'BETA','BINO',' ',' '/ DATA INCASE(79)/'BRCP'/ DATA ISHAPE(79)/1/ DATA (INAME(79,J),J=1,4)/'BRAD',' ',' ',' '/ DATA INCASE(80)/'RECP'/ DATA ISHAPE(80)/1/ DATA (INAME(80,J),J=1,4)/'RECI',' ',' ',' '/ DATA INCASE(81)/'IWCP'/ DATA ISHAPE(81)/1/ DATA (INAME(81,J),J=1,4)/'INVE','WEIB',' ',' '/ DATA INCASE(82)/'LXCP'/ DATA ISHAPE(82)/1/ DATA (INAME(82,J),J=1,4)/'LOG ','DOUB','EXPO',' '/ DATA INCASE(83)/'LDCP'/ DATA ISHAPE(83)/2/ DATA (INAME(83,J),J=1,4)/'GENE','TUKE','LAMB',' '/ DATA INCASE(84)/'JBCP'/ DATA ISHAPE(84)/2/ DATA (INAME(84,J),J=1,4)/'JOHN','SB ',' ',' '/ DATA INCASE(85)/'JUCP'/ DATA ISHAPE(85)/2/ DATA (INAME(85,J),J=1,4)/'JOHN','SU ',' ',' '/ DATA INCASE(86)/'EECP'/ DATA ISHAPE(86)/1/ DATA (INAME(86,J),J=1,4)/'GEOM','EXTR','EXPO',' '/ DATA INCASE(87)/'TSCP'/ DATA ISHAPE(87)/2/ DATA (INAME(87,J),J=1,4)/'TWO ','SIDE','POWE',' '/ DATA INCASE(88)/'ERCP'/ DATA ISHAPE(88)/1/ DATA (INAME(88,J),J=1,4)/'ERRO',' ',' ',' '/ DATA INCASE(89)/'ERCP'/ DATA ISHAPE(89)/1/ DATA (INAME(89,J),J=1,4)/'SUBB',' ',' ',' '/ DATA INCASE(90)/'PFCP'/ DATA ISHAPE(90)/1/ DATA (INAME(90,J),J=1,4)/'POWE',' ',' ',' '/ CCCCC DATA INCASE(90)/'ERCP'/ CCCCC DATA ISHAPE(90)/1/ CCCCC DATA (INAME(90,J),J=1,4)/'EXPO','POWE',' ',' '/ DATA INCASE(91)/'FTCP'/ DATA ISHAPE(91)/1/ DATA (INAME(91,J),J=1,4)/'FOLD','T ',' ',' '/ DATA INCASE(92)/'SNCP'/ DATA ISHAPE(92)/1/ DATA (INAME(92,J),J=1,4)/'SKEW','NORM',' ',' '/ DATA INCASE(93)/'STCP'/ DATA ISHAPE(93)/2/ DATA (INAME(93,J),J=1,4)/'SKEW','T ',' ',' '/ DATA INCASE(94)/'IBCP'/ DATA ISHAPE(94)/2/ DATA (INAME(94,J),J=1,4)/'INVE','BETA',' ',' '/ DATA INCASE(95)/'GHCP'/ DATA ISHAPE(95)/2/ DATA (INAME(95,J),J=1,4)/'G-H ',' ',' ',' '/ DATA INCASE(96)/'GHCP'/ DATA ISHAPE(96)/2/ DATA (INAME(96,J),J=1,4)/'GH ',' ',' ',' '/ DATA INCASE(97)/'GHCP'/ DATA ISHAPE(97)/2/ DATA (INAME(97,J),J=1,4)/'G ','H ',' ',' '/ DATA INCASE(98)/'GHCP'/ DATA ISHAPE(98)/2/ DATA (INAME(98,J),J=1,4)/'G ','AND ','H ',' '/ DATA INCASE(99)/'LZCP'/ DATA ISHAPE(99)/2/ DATA (INAME(99,J),J=1,4)/'LOG ','SKEW','NORM',' '/ DATA INCASE(100)/'GZCP'/ DATA ISHAPE(100)/1/ DATA (INAME(100,J),J=1,4)/'GENE','HALF','LOGI',' '/ DATA INCASE(101)/'TECP'/ DATA ISHAPE(101)/2/ DATA (INAME(101,J),J=1,4)/'TRUN','EXPO',' ',' '/ DATA INCASE(102)/'WRCP'/ DATA ISHAPE(102)/2/ DATA (INAME(102,J),J=1,4)/'WARI',' ',' ',' '/ DATA INCASE(103)/'YUCP'/ DATA ISHAPE(103)/1/ DATA (INAME(103,J),J=1,4)/'YULE',' ',' ',' '/ DATA INCASE(104)/'AECP'/ DATA ISHAPE(104)/2/ DATA (INAME(104,J),J=1,4)/'POLY','AEPP',' ',' '/ DATA INCASE(105)/'HYCP'/ DATA ISHAPE(105)/2/ DATA (INAME(105,J),J=1,4)/'HYPE',' ',' ',' '/ DATA INCASE(106)/'HECP'/ DATA ISHAPE(106)/2/ DATA (INAME(106,J),J=1,4)/'HERM',' ',' ',' '/ DATA INCASE(107)/'SDCP'/ DATA ISHAPE(107)/1/ DATA (INAME(107,J),J=1,4)/'SKEW','DOUB','EXPO',' '/ DATA INCASE(108)/'SDCP'/ DATA ISHAPE(108)/1/ DATA (INAME(108,J),J=1,4)/'SKEW','LAPL',' ',' '/ DATA INCASE(109)/'ADCP'/ DATA ISHAPE(109)/1/ DATA (INAME(109,J),J=1,4)/'ASYM','DOUB','EXPO',' '/ DATA INCASE(110)/'ADCP'/ DATA ISHAPE(110)/1/ DATA (INAME(110,J),J=1,4)/'ASYM','LAPL',' ',' '/ DATA INCASE(111)/'MXCP'/ DATA ISHAPE(111)/1/ DATA (INAME(111,J),J=1,4)/'MAXW',' ',' ',' '/ DATA INCASE(112)/'GMCP'/ DATA ISHAPE(112)/2/ DATA (INAME(112,J),J=1,4)/'GOMP','MAKE',' ',' '/ DATA INCASE(113)/'GALP'/ DATA ISHAPE(113)/2/ DATA (INAME(113,J),J=1,4)/'GENE','ASYM','DOUB','EXPO'/ DATA INCASE(114)/'GALP'/ DATA ISHAPE(114)/2/ DATA (INAME(114,J),J=1,4)/'GENE','ASYM','LAPL',' '/ DATA INCASE(115)/'MCCP'/ DATA ISHAPE(115)/1/ DATA (INAME(115,J),J=1,4)/'MCLE',' ',' ',' '/ DATA INCASE(116)/'GMLP'/ DATA ISHAPE(116)/2/ DATA (INAME(116,J),J=1,4)/'GENE','MCLE',' ',' '/ DATA INCASE(117)/'LXCP'/ DATA ISHAPE(117)/1/ DATA (INAME(117,J),J=1,4)/'LOG ','LAPL',' ',' '/ DATA INCASE(118)/'LDCP'/ DATA ISHAPE(118)/2/ DATA (INAME(118,J),J=1,4)/'GENE','LAMB',' ',' '/ DATA INCASE(119)/'BGCP'/ DATA ISHAPE(119)/2/ DATA (INAME(119,J),J=1,4)/'BETA','GEOM',' ',' '/ DATA INCASE(120)/'G5CP'/ DATA ISHAPE(120)/1/ DATA (INAME(120,J),J=1,4)/'GENE','LOGI','TYPE','V '/ DATA INCASE(121)/'G5CP'/ DATA ISHAPE(121)/1/ DATA (INAME(121,J),J=1,4)/'GENE','LOGI','HOSK',' '/ DATA INCASE(122)/'G5CP'/ DATA ISHAPE(122)/1/ DATA (INAME(122,J),J=1,4)/'TYPE','5 ','GENE','LOGI'/ DATA INCASE(123)/'G5CP'/ DATA ISHAPE(123)/1/ DATA (INAME(123,J),J=1,4)/'TYPE','V ','GENE','LOGI'/ DATA INCASE(124)/'G5CP'/ DATA ISHAPE(124)/1/ DATA (INAME(124,J),J=1,4)/'HOSK','GENE','LOGI',' '/ DATA INCASE(125)/'G5CP'/ DATA ISHAPE(125)/1/ DATA (INAME(125,J),J=1,4)/'GENE','LOGI','TYPE','V '/ DATA INCASE(126)/'G5CP'/ DATA ISHAPE(126)/1/ DATA (INAME(126,J),J=1,4)/'GENE','LOGI','TYPE','5 '/ DATA INCASE(127)/'G2CP'/ DATA ISHAPE(127)/1/ DATA (INAME(127,J),J=1,4)/'TYPE','2 ','GENE','LOGI'/ DATA INCASE(128)/'G2CP'/ DATA ISHAPE(128)/1/ DATA (INAME(128,J),J=1,4)/'TYPE','II ','GENE','LOGI'/ DATA INCASE(129)/'G2CP'/ DATA ISHAPE(129)/1/ DATA (INAME(129,J),J=1,4)/'GENE','LOGI','TYPE','2 '/ DATA INCASE(130)/'G2CP'/ DATA ISHAPE(130)/1/ DATA (INAME(130,J),J=1,4)/'GENE','LOGI','TYPE','II '/ DATA INCASE(131)/'G3CP'/ DATA ISHAPE(131)/1/ DATA (INAME(131,J),J=1,4)/'TYPE','3 ','GENE','LOGI'/ DATA INCASE(132)/'G3CP'/ DATA ISHAPE(132)/1/ DATA (INAME(132,J),J=1,4)/'TYPE','III ','GENE','LOGI'/ DATA INCASE(133)/'G3CP'/ DATA ISHAPE(133)/1/ DATA (INAME(133,J),J=1,4)/'GENE','LOGI','TYPE','3 '/ DATA INCASE(134)/'G3CP'/ DATA ISHAPE(134)/1/ DATA (INAME(134,J),J=1,4)/'GENE','LOGI','TYPE','III '/ DATA INCASE(135)/'G4CP'/ DATA ISHAPE(135)/2/ DATA (INAME(135,J),J=1,4)/'TYPE','4 ','GENE','LOGI'/ DATA INCASE(136)/'G4CP'/ DATA ISHAPE(136)/2/ DATA (INAME(136,J),J=1,4)/'TYPE','IV ','GENE','LOGI'/ DATA INCASE(137)/'G4CP'/ DATA ISHAPE(137)/2/ DATA (INAME(137,J),J=1,4)/'GENE','LOGI','TYPE','4 '/ DATA INCASE(138)/'G4CP'/ DATA ISHAPE(138)/2/ DATA (INAME(138,J),J=1,4)/'GENE','LOGI','TYPE','IV '/ DATA INCASE(139)/'GLCP'/ DATA ISHAPE(139)/1/ DATA (INAME(139,J),J=1,4)/'GENE','LOGI',' ',' '/ DATA INCASE(140)/'LXCP'/ DATA ISHAPE(140)/1/ DATA (INAME(140,J),J=1,4)/'LOG ','LAPL',' ',' '/ DATA INCASE(141)/'AXCP'/ DATA ISHAPE(141)/2/ DATA (INAME(141,J),J=1,4)/'ASYM','LOG ','DOUB','EXPO'/ DATA INCASE(142)/'AXCP'/ DATA ISHAPE(142)/2/ DATA (INAME(142,J),J=1,4)/'ASYM','LOG ','LAPL',' '/ DATA INCASE(143)/'BECP'/ DATA ISHAPE(143)/2/ DATA (INAME(143,J),J=1,4)/'BETA',' ',' ',' '/ DATA INCASE(144)/'ZECP'/ DATA ISHAPE(144)/1/ DATA (INAME(144,J),J=1,4)/'ZETA',' ',' ',' '/ DATA INCASE(145)/'ZICP'/ DATA ISHAPE(145)/1/ DATA (INAME(145,J),J=1,4)/'ZIPF',' ',' ',' '/ DATA INCASE(146)/'BTCP'/ DATA ISHAPE(146)/1/ DATA (INAME(146,J),J=1,4)/'BORE','TANN',' ',' '/ DATA INCASE(147)/'LPCP'/ DATA ISHAPE(147)/2/ DATA (INAME(147,J),J=1,4)/'LAGR','POIS',' ',' '/ DATA INCASE(148)/'LPCP'/ DATA ISHAPE(148)/2/ DATA (INAME(148,J),J=1,4)/'CONS','GENE','POIS',' '/ DATA INCASE(149)/'LBCP'/ DATA ISHAPE(149)/2/ DATA (INAME(149,J),J=1,4)/'LOG ','BETA',' ',' '/ DATA INCASE(150)/'PZCP'/ DATA ISHAPE(150)/2/ DATA (INAME(150,J),J=1,4)/'POLY',' ',' ',' '/ DATA INCASE(151)/'LOST'/ DATA ISHAPE(151)/1/ DATA (INAME(151,J),J=1,4)/'LOST','GAME',' ',' '/ DATA INCASE(152)/'GSCP'/ DATA ISHAPE(152)/2/ DATA (INAME(152,J),J=1,4)/'GENE','LOGA','SERI',' '/ DATA INCASE(153)/'GETC'/ DATA ISHAPE(153)/2/ DATA (INAME(153,J),J=1,4)/'GEET',' ',' ',' '/ DATA INCASE(154)/'QBCP'/ DATA ISHAPE(154)/2/ DATA (INAME(154,J),J=1,4)/'QUAS','BINO','TYPE','I '/ DATA INCASE(155)/'QBCP'/ DATA ISHAPE(155)/2/ DATA (INAME(155,J),J=1,4)/'QUAS','BINO','TYPE','1 '/ DATA INCASE(156)/'QBCP'/ DATA ISHAPE(156)/2/ DATA (INAME(156,J),J=1,4)/'QUAS','BINO','I ',' '/ DATA INCASE(157)/'QBCP'/ DATA ISHAPE(157)/2/ DATA (INAME(157,J),J=1,4)/'QUAS','BINO','1 ',' '/ DATA INCASE(158)/'CNCP'/ DATA ISHAPE(158)/2/ DATA (INAME(158,J),J=1,4)/'CONS',' ',' ',' '/ DATA INCASE(159)/'KZCP'/ DATA ISHAPE(159)/2/ DATA (INAME(159,J),J=1,4)/'KATZ',' ',' ',' '/ DATA INCASE(160)/'DIWP'/ DATA ISHAPE(160)/2/ DATA (INAME(160,J),J=1,4)/'DISC','WEIB',' ',' '/ DATA INCASE(161)/'GLGP'/ DATA ISHAPE(161)/2/ DATA (INAME(161,J),J=1,4)/'GENE','LOST','GAME',' '/ C C-----START POINT----------------------------------------------------- C IERROR='NO' ICENSO='OFF' IREPL='OFF' IMETHD='UNIM' IF(IPPCCN.EQ.'KAPL')IMETHD='KAPL' C ISUBN1='DPPP' ISUBN2='CC ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=2 MINN2=3 NUMSHA=1 C ICOLR=0 ICOLR2=0 C C ********************************************* C ** TREAT THE PROBABILITY PLOT CORRELATION ** C ** COEFFICIENT (PPCC) PLOT CASE ** C ********************************************* C IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPCC')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPPCC--') 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,ISUBRO 53 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPCC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C 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 IF(IHARG(I1).EQ.'PPCC'.AND.IHARG(I2).EQ.'PLOT')THEN ILASTC=I2 GOTO112 ELSEIF(IHARG(I1).EQ.'KS '.AND.IHARG(I2).EQ.'PLOT')THEN ILASTC=I2 GOTO112 ELSEIF(IHARG(I1).EQ.'KOLM'.AND.IHARG(I2).EQ.'SMIR'.AND. 1 IHARG(I3).EQ.'PLOT')THEN ILASTC=I3 GOTO112 ELSEIF(IHARG(I1).EQ.'CENS'.AND. 1 IHARG(I2).EQ.'PPCC'.AND.IHARG(I3).EQ.'PLOT')THEN ICENSO='ON' ILASTC=I3 GOTO112 ELSEIF(IHARG(I1).EQ.'CENS'.AND. 1 IHARG(I2).EQ.'KS '.AND.IHARG(I3).EQ.'PLOT')THEN ICENSO='ON' ILASTC=I3 GOTO112 ELSEIF(IHARG(I1).EQ.'CENS'.AND. 1 IHARG(I2).EQ.'KOLM'.AND.IHARG(I3).EQ.'SMIR'.AND. 1 IHARG(I4).EQ.'PLOT')THEN ICENSO='ON' ILASTC=I4 GOTO112 ELSEIF(IHARG(I1).EQ.'REPL'.AND. 1 IHARG(I2).EQ.'PPCC'.AND.IHARG(I3).EQ.'PLOT')THEN IREPL='ON' ILASTC=I3 GOTO112 ELSEIF(IHARG(I1).EQ.'REPL'.AND. 1 IHARG(I2).EQ.'KS '.AND.IHARG(I3).EQ.'PLOT')THEN IREPL='ON' ILASTC=I3 GOTO112 ELSEIF(IHARG(I1).EQ.'REPL'.AND. 1 IHARG(I2).EQ.'KOLM'.AND.IHARG(I3).EQ.'SMIR'.AND. 1 IHARG(I4).EQ.'PLOT')THEN IREPL='ON' ILASTC=I4 GOTO112 ELSEIF(IHARG(I1).EQ.'REPL'.AND.IHARG(I2).EQ.'CENS'.AND. 1 IHARG(I3).EQ.'PPCC'.AND.IHARG(I4).EQ.'PLOT')THEN IREPL='ON' ICENSO='ON' ILASTC=I4 GOTO112 ELSEIF(IHARG(I1).EQ.'REPL'.AND.IHARG(I2).EQ.'CENS'.AND. 1 IHARG(I3).EQ.'KS '.AND.IHARG(I4).EQ.'PLOT')THEN IREPL='ON' ICENSO='ON' ILASTC=I4 GOTO112 ELSEIF(IHARG(I1).EQ.'REPL'.AND.IHARG(I2).EQ.'CENS'.AND. 1 IHARG(I3).EQ.'KOLM'.AND.IHARG(I4).EQ.'SMIR'.AND. 1 IHARG(I5).EQ.'PLOT')THEN IREPL='ON' ICENSO='ON' ILASTC=I5 GOTO112 ELSEIF(IHARG(I1).EQ.'CENS'.AND.IHARG(I2).EQ.'REPL'.AND. 1 IHARG(I3).EQ.'PPCC'.AND.IHARG(I4).EQ.'PLOT')THEN IREPL='ON' ICENSO='ON' ILASTC=I4 GOTO112 ELSEIF(IHARG(I1).EQ.'CENS'.AND.IHARG(I2).EQ.'REPL'.AND. 1 IHARG(I3).EQ.'KS '.AND.IHARG(I4).EQ.'PLOT')THEN IREPL='ON' ICENSO='ON' ILASTC=I4 GOTO112 ELSEIF(IHARG(I1).EQ.'CENS'.AND.IHARG(I2).EQ.'REPL'.AND. 1 IHARG(I3).EQ.'KOLM'.AND.IHARG(I4).EQ.'SMIR'.AND. 1 IHARG(I5).EQ.'PLOT')THEN IREPL='ON' ICENSO='ON' ILASTC=I5 GOTO112 END IF C 100 CONTINUE C C ----------NO MATCH FOUND---------- C ICASPL=' ' IFOUND='NO' GOTO9000 C 112 CONTINUE ICASPL=INCASE(IROW) NUMSHA=ISHAPE(IROW) CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) IFOUND='YES' C DO121I=1,MAXOBV Y1(I)=0.0 X1(I)=0.0 X1UPP(I)=0.0 XCENS(I)=0.0 XREPL(I)=0.0 121 CONTINUE C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPCC') 1CALL 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(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPCC') 1CALL 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'.OR.ISUBRO.EQ.'PPCC')THEN WRITE(ICOUT,311)IHLEFT,IHLEF2,ICOLL,NLEFT 311 FORMAT('IHLEFT,IHLEF2,ICOLL,NLEFT = ',A4,A4,I8,I8) CALL DPWRST('XXX','BUG ') ENDIF C C ******************************************************* C ** STEP 4-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS ** C ** (NLEFT) FOR THE RESPONSE VARIABLE IS POSITIVE. ** C ******************************************************* C ISTEPN='4' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPCC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.LT.MINN2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,411) 411 FORMAT('***** ERROR IN PPCC PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,412)IHLEFT,IHLEF2 412 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS IN ', 1 'VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,413) 413 FORMAT(' FOR WHICH A PPCC PLOT WAS TO HAVE BEEN FORMED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,415)MINN2 415 FORMAT(' MUST BE ',I8,' OR LARGER; SUCH WAS NOT THE ', 1 'CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,417) 417 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,418)(IANS(I),I=1,MIN(80,IWIDTH)) 418 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF 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(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPCC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,581) 581 FORMAT('***** INTERNAL ERROR IN DPPPCC') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,582) 582 FORMAT(' AT BRANCH POINT 481--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,583) 583 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH NUMARG HAD ', 1 'PREVIOUSLY') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,585)NUMARG 585 FORMAT(' PASSED THIS TEST ONCE ALREADY. VALUE OF ', 1 'NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,586) 586 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,417) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,418)(IANS(I),I=1,MIN(80,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C DO500J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')THEN ICASEQ='SUBS' ILOCQ=J1 GOTO590 ELSEIF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')THEN ICASEQ='SUBS' ILOCQ=J1 GOTO590 ELSEIF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')THEN ICASEQ='FOR' ILOCQ=J1 GOTO590 ENDIF 500 CONTINUE C 590 CONTINUE IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPCC')THEN WRITE(ICOUT,591)NUMARG,ILOCQ,ICASEQ 591 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF C C ********************************************************* C ** STEP 6-- ** C ** THE FOLLOWING CASES OF MORE THAN ONE ARGUMENT ** C ** ARE SUPPORTED: ** C ** ... PPCC PLOT Y X1 - FREQUENCY DATA ** C ** ... PPCC PLOT Y XLOW XUPP - FREQUENCY DATA ** C ** ... PPCC PLOT Y X1 - CENSORED DATA ** C ** ... PPCC PLOT Y X1 - REPLICATED DATA ** C ** ... PPCC PLOT Y X1 X2 - FREQUENCY DATA WITH ** C ** REPLICATION ** C ** ... PPCC PLOT Y XLOW XUPP X1 - FREQUENCY DATA WITH ** C ** REPLICATION ** C ** ... PPCC PLOT Y X1 X2 - CENSORED DATA WITH ** C ** REPLICATION ** C ********************************************************* C ISTEPN='6' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPCC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IRESV=1 IREPV=0 ICENV=0 IFREV=0 IFREV2=0 C NUMEXP=1 IF(ICENSO.EQ.'ON')NUMEXP=NUMEXP+1 IF(IREPL.EQ.'ON')NUMEXP=NUMEXP+1 C IF(NUMV2.EQ.NUMEXP)THEN IDATSW='RAW' IF(ICENSO.EQ.'ON')ICENV=2 IF(IREPL.EQ.'ON')THEN IF(ICENSO.EQ.'ON')IREPV=3 IF(ICENSO.EQ.'OFF')IREPV=2 ENDIF ELSEIF(NUMV2.EQ.NUMEXP+1)THEN IDATSW='FREQ' IF(ICENSO.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,611) 611 FORMAT('***** ERROR IN PPCC PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,613) 613 FORMAT(' FREQUENCY DATA NOT SUPPORTED FOR CENSORED ', 1 'CASE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,417) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,418)(IANS(I),I=1,MIN(80,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ELSE IFREV=2 IFREV2=0 IF(IREPL.EQ.'ON')IREPV=3 ENDIF ELSEIF(NUMV2.EQ.NUMEXP+2)THEN IDATSW='FRE2' IF(ICENSO.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,616) 616 FORMAT('***** ERROR IN PPCC PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,618) 618 FORMAT(' FREQUENCY DATA NOT SUPPORTED FOR CENSORED ', 1 'CASE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,417) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,418)(IANS(I),I=1,MIN(80,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ELSE IFREV=2 IFREV2=3 IF(IREPL.EQ.'ON')IREPV=4 ENDIF ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,621) 621 FORMAT('***** ERROR IN PPCC PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,623)NUMEXP,NUMEXP+1,NUMEXP+2 623 FORMAT(' EITHER ',I8,', ',I8,' OR ',I8, 1 ' VARIABLES EXPECTED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,625)NUMV2 625 FORMAT(' NUMBER OF VARIABLES ENTERED = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,417) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,418)(IANS(I),I=1,MIN(80,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C IF(NUMV2.GE.2)THEN IHRIGH=IHARG(2) IHRIG2=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHRIGH,IHRIG2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLR=IVALUE(ILOCV) NRIGHT=IN(ILOCV) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPCC')THEN WRITE(ICOUT,641)IHRIGH,IHRIG2,ICOLR,NRIGHT 641 FORMAT('IHRIGH,IHRIG2,ICOLR,NRIGHT = ',A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') ENDIF C IF(NRIGHT.NE.NLEFT)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,651) 651 FORMAT('***** ERROR IN PPCC PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,652) 652 FORMAT(' FOR A ... PPCC PLOT WITH TWO VARIABLES ', 1 'SPECIFIED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,653) 653 FORMAT(' THE NUMBER OF ELEMENTS IN THE TWO VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,655) 655 FORMAT(' MUST BE THE SAME; SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,657)IHLEFT,IHLEF2,NLEFT 657 FORMAT(' THE FIRST VARIABLE (',A4,A4,') HAS ',I8, 1 'ELEMENTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,658)IHRIGH,IHRIG2,NRIGHT 658 FORMAT(' THE SECOND VARIABLE (',A4,A4,') HAS ',I8, 1 'ELEMENTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,417) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,418)(IANS(I),I=1,MIN(80,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF ENDIF C IF(NUMV2.GE.3)THEN IHRI2H=IHARG(3) IHRI22=IHARG2(3) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHRI2H,IHRI22,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLR2=IVALUE(ILOCV) NRIGH2=IN(ILOCV) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPCC')THEN WRITE(ICOUT,661)IHRI2H,IHRI22,ICOLR2,NRIGH2 661 FORMAT('IHRI2H,IHRI22,ICOLR2,NRIGH2 = ',A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') ENDIF C IF(NRIGH2.NE.NLEFT)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,671) 671 FORMAT('***** ERROR IN PPCC PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,672) 672 FORMAT(' FOR A ... PPCC PLOT WITH THREE VARIABLES ', 1 'SPECIFIED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,673) 673 FORMAT(' THE NUMBER OF ELEMENTS IN THE THREE VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,675) 675 FORMAT(' MUST BE THE SAME; SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,677)IHLEFT,IHLEF2,NLEFT 677 FORMAT(' THE FIRST VARIABLE (',A4,A4,') HAS ',I8, 1 'ELEMENTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,678)IHRI2H,IHRI22,NRIGH2 678 FORMAT(' THE THIRD VARIABLE (',A4,A4,') HAS ',I8, 1 'ELEMENTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,417) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,418)(IANS(I),I=1,MIN(80,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF ENDIF C IF(NUMV2.GE.4)THEN IHRI3H=IHARG(4) IHRI32=IHARG2(4) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHRI2H,IHRI22,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLR3=IVALUE(ILOCV) NRIGH3=IN(ILOCV) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPCC')THEN WRITE(ICOUT,681)IHRI3H,IHRI32,ICOLR3,NRIGH3 681 FORMAT('IHRI3H,IHRI32,ICOLR3,NRIGH3 = ',A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') ENDIF C IF(NRIGH3.NE.NLEFT)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,691) 691 FORMAT('***** ERROR IN PPCC PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,692) 692 FORMAT(' FOR A ... PPCC PLOT WITH FOUR VARIABLES ', 1 'SPECIFIED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,693) 693 FORMAT(' THE NUMBER OF ELEMENTS IN THE FOUR VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,695) 695 FORMAT(' MUST BE THE SAME; SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,697)IHLEFT,IHLEF2,NLEFT 697 FORMAT(' THE FIRST VARIABLE (',A4,A4,') HAS ',I8, 1 'ELEMENTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,698)IHRI3H,IHRI32,NRIGH3 698 FORMAT(' THE FOURTH VARIABLE (',A4,A4,') HAS ',I8, 1 'ELEMENTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,417) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,418)(IANS(I),I=1,MIN(80,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF ENDIF 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(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPCC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'SUBS')THEN NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4) NQ=NIOLD ELSEIF(ICASEQ.EQ.'FOR')THEN NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1 NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR ELSE DO715I=1,NLEFT ISUB(I)=1 715 CONTINUE NQ=NLEFT ENDIF C J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO760I=1,IMAX IF(ISUB(I).EQ.0)GOTO760 J=J+1 C C RESPONSE VARIABLE IN Y1 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) C C CLASS VARIABLE IN X1 FOR FREQUENCY DATA C IF(IFREV.GT.0)THEN ICOLT=ICOLR IJ=MAXN*(ICOLT-1)+I IF(ICOLT.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLT.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLT.EQ.MAXCP2)X1(J)=RES(I) IF(ICOLT.EQ.MAXCP3)X1(J)=YPLOT(I) IF(ICOLT.EQ.MAXCP4)X1(J)=XPLOT(I) IF(ICOLT.EQ.MAXCP5)X1(J)=X2PLOT(I) IF(ICOLT.EQ.MAXCP6)X1(J)=TAGPLO(I) ENDIF C C IF FREQUENCY DATA GIVEN WITH LOWER AND UPPER CLASS LIMITS, THEN C UPPER CLASS LIMIT VARIABLE IN X1UPP C IF(IFREV2.GT.0)THEN ICOLT=ICOLR2 IJ=MAXN*(ICOLT-1)+I IF(ICOLT.LE.MAXCOL)X1UPP(J)=V(IJ) IF(ICOLT.EQ.MAXCP1)X1UPP(J)=PRED(I) IF(ICOLT.EQ.MAXCP2)X1UPP(J)=RES(I) IF(ICOLT.EQ.MAXCP3)X1UPP(J)=YPLOT(I) IF(ICOLT.EQ.MAXCP4)X1UPP(J)=XPLOT(I) IF(ICOLT.EQ.MAXCP5)X1UPP(J)=X2PLOT(I) IF(ICOLT.EQ.MAXCP6)X1UPP(J)=TAGPLO(I) ENDIF C C CENSORING VARIABLE IN XCENS FOR CENSORED DATA C IF(ICENSO.EQ.'ON')THEN ICOLT=ICOLR IJ=MAXN*(ICOLT-1)+I IF(ICOLT.LE.MAXCOL)XCENS(J)=V(IJ) IF(ICOLT.EQ.MAXCP1)XCENS(J)=PRED(I) IF(ICOLT.EQ.MAXCP2)XCENS(J)=RES(I) IF(ICOLT.EQ.MAXCP3)XCENS(J)=YPLOT(I) IF(ICOLT.EQ.MAXCP4)XCENS(J)=XPLOT(I) IF(ICOLT.EQ.MAXCP5)XCENS(J)=X2PLOT(I) IF(ICOLT.EQ.MAXCP6)XCENS(J)=TAGPLO(I) ENDIF C C REPLICATION VARIABLE IN XREPL FOR REPLICATED DATA C IF(IREPL.EQ.'ON')THEN ICOLT=ICOLR IF(IREPV.EQ.3)ICOLT=ICOLR2 IF(IREPV.EQ.4)ICOLT=ICOLR3 IJ=MAXN*(ICOLT-1)+I IF(ICOLT.LE.MAXCOL)XREPL(J)=V(IJ) IF(ICOLT.EQ.MAXCP1)XREPL(J)=PRED(I) IF(ICOLT.EQ.MAXCP2)XREPL(J)=RES(I) IF(ICOLT.EQ.MAXCP3)XREPL(J)=YPLOT(I) IF(ICOLT.EQ.MAXCP4)XREPL(J)=XPLOT(I) IF(ICOLT.EQ.MAXCP5)XREPL(J)=X2PLOT(I) IF(ICOLT.EQ.MAXCP6)XREPL(J)=TAGPLO(I) ENDIF 760 CONTINUE C NLOCAL=J C IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPCC')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,771)NLOCAL 771 FORMAT('NLOCAL = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,772)IRESV,IREPV,ICENV,IFREV 772 FORMAT('IRESV,IREPV,ICENV,IFREV=',4I8) CALL DPWRST('XXX','BUG ') DO773I=1,NLOCAL WRITE(ICOUT,775)I,Y1(I),X1(I),X1UPP(I),XCENS(I),XREPL(I) 775 FORMAT('I,Y1(I),X1(I),X1UPP(I),XCENS(I),XREPL(I) = ', 1 I8,5G15.7) CALL DPWRST('XXX','BUG ') 773 CONTINUE ENDIF C C *********************************************** C ** STEP 8-- ** C ** DETERMINE IF THE ANALYST ** C ** HAS SPECIFIED LIMITS ** C ** FOR THE PARAMETER VALUES ** C ** (THIS WILL DICTATE WHAT WILL APPEAR ** C ** ON THE HORIZONTAL AXIS OF THE PPCC PLOT) ** C *********************************************** C ISTEPN='8' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPCC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASPL.EQ.'LACP')THEN IDIST='TUKEY-LAMBDA' IHP='LAMB' IHP2='DA1 ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=-2.0 CALL PARCH2(IHP,IHP2,IDIST,ALAMB1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='LAMB' IHP2='DA2 ' ADEF=2.0 CALL PARCH2(IHP,IHP2,IDIST, 1 ALAMB2,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERRO2) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'TCP')THEN IDIST='T' IHP='NU1 ' IHP2=' ' CCCCC ILOWLM=1 CCCCC IUPPLM=I1MACH(9) CCCCC LOWLTY='>= ' CCCCC UPPLTY='<= ' CCCCC IDEF=1 CCCCC CALL PARCI2(IHP,IHP2,IDIST,NU1,IDEF,ILOWLM,IUPPLM,LOWLTY,UPPLTY, CCCCC1 ISUBN1,ISUBN2,IERRO2) ALOWLM=1.0 AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,ANU1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='NU2 ' IHP2=' ' CCCCC IDEF=50 CCCCC CALL PARCI2(IHP,IHP2,IDIST,NU2,IDEF,ILOWLM,IUPPLM,LOWLTY,UPPLTY, CCCCC1 ISUBN1,ISUBN2,IERRO2) ADEF=50.0 CALL PARCH2(IHP,IHP2,IDIST,ANU2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'CSCP')THEN IDIST='CHI-SQUARED' IHP='NU1 ' IHP2=' ' ILOWLM=1 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' IDEF=1 CALL PARCI2(IHP,IHP2,IDIST,NU1,IDEF,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='NU2 ' IHP2=' ' IDEF=50 CALL PARCI2(IHP,IHP2,IDIST,NU2,IDEF,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'FCP')THEN IDIST='F ' IHP='NU11' IHP2=' ' ILOWLM=1 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' IDEF=1 CALL PARCI2(IHP,IHP2,IDIST,NU11,IDEF,ILOWLM,IUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='NU12' IHP2=' ' IDEF=25 CALL PARCI2(IHP,IHP2,IDIST,NU12,IDEF,ILOWLM,IUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='NU21' IHP2=' ' IDEF=1 CALL PARCI2(IHP,IHP2,IDIST,NU21,IDEF,ILOWLM,IUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='NU22' IHP2=' ' IDEF=25 CALL PARCI2(IHP,IHP2,IDIST,NU22,IDEF,ILOWLM,IUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'GACP')THEN IDIST='GAMMA' IHP='GAMM' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='GAMM' IHP2='A2 ' ADEF=50.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'BECP')THEN IDIST='BETA' IHP='ALPH' IHP2='A1 ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='1 ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,BETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,BETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'BNCP')THEN IDIST='BETA-NORMAL' IHP='ALPH' IHP2='A1 ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='1 ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,BETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,BETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'BBCP')THEN IDIST='BETA-BINOMIAL' C 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 C IHP='ALPH' IHP2='A1 ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='1 ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,BETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,BETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'BGCP')THEN IDIST='BETA-GEOMETRIC' C IHP='ALPH' IHP2='A1 ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='1 ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,BETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,BETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'ZECP')THEN IDIST='ZETA' C IHP='ALPH' IHP2='A1 ' ALOWLM=1.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=1.5 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'ZICP')THEN IDIST='ZIPF' C 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 C IHP='ALPH' IHP2='A1 ' ALOWLM=1.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=1.5 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'PZCP')THEN IDIST='POLYA' C 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 C IHP='ALPH' IHP2='A1 ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='1 ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,BETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,BETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'HECP')THEN IDIST='HERMITE' IHP='ALPH' IHP2='A1 ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.1 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='1 ' ADEF=0.1 CALL PARCH2(IHP,IHP2,IDIST,BETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,BETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'WECP')THEN IDIST='WEIBULL' IHP='GAMM' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='GAMM' IHP2='A2 ' ADEF=50.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'E2CP')THEN IDIST='EXTREME VALUE TYPE 2' IHP='GAMM' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='GAMM' IHP2='A2 ' ADEF=50.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'PACP')THEN IDIST='PARETO' IHP='GAMM' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.2 CALL PARCH2(IHP,IHP2,IDIST,GAMMA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='GAMM' IHP2='A2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA2,ADEF,ALOWLM,AUPPLM, 1 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 A1=1.0 ELSE A1=VALUE(ILOCP) ENDIF IF(A1.LE.0.0)A1=1.0 GOTO899 C ENDIF IF(ICASPL.EQ.'BICP')THEN IDIST='BINOMIAL' C IHP='N ' IHP2=' ' ILOWLM=1 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,NBINOM,ILOWLM,IUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='P1 ' IHP2=' ' ALOWLM=0.0 AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' ADEF=0.05 CALL PARCH2(IHP,IHP2,IDIST,P1,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='P2 ' IHP2=' ' ADEF=0.95 CALL PARCH2(IHP,IHP2,IDIST,P2,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'BTCP')THEN IDIST='BOREL-TANNER' C IHP='K ' IHP2=' ' ILOWLM=1 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,K,ILOWLM,IUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 AK1=REAL(K) C IHP='LAMB' IHP2='DA1 ' ALOWLM=0.0 AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' ADEF=0.2 CALL PARCH2(IHP,IHP2,IDIST,ALAMB1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='LAMB' IHP2='DA2 ' ADEF=0.95 CALL PARCH2(IHP,IHP2,IDIST,ALAMB2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'LOST')THEN IDIST='LOST GAMES' C IHP='R ' IHP2=' ' ILOWLM=1 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,NU1,ILOWLM,IUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='P1 ' IHP2=' ' ALOWLM=0.5 AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' ADEF=0.51 CALL PARCH2(IHP,IHP2,IDIST,P1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='P2 ' IHP2=' ' ADEF=0.95 CALL PARCH2(IHP,IHP2,IDIST,P2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'GLGP')THEN IDIST='GENERALIZED LOST GAMES' C IHP='J ' IHP2=' ' ILOWLM=0 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,NU1,ILOWLM,IUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='P1 ' IHP2=' ' ALOWLM=0.5 AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' ADEF=0.55 CALL PARCH2(IHP,IHP2,IDIST,P1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='P2 ' IHP2=' ' ADEF=0.95 CALL PARCH2(IHP,IHP2,IDIST,P2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='A1 ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,A1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='A2 ' IHP2=' ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,A2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'LPCP')THEN IDIST='LAGRANGE-POISSON' C IHP='LAMB' IHP2='DA1 ' ALOWLM=0.0 AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' ADEF=0.2 CALL PARCH2(IHP,IHP2,IDIST,ALAMB1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='LAMB' IHP2='DA2 ' ADEF=0.95 CALL PARCH2(IHP,IHP2,IDIST,ALAMB2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='THET' IHP2='A1 ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,THETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='THET' IHP2='A2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,THETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'AECP')THEN IDIST='POLYA-AEPPLI' C IHP='THET' IHP2='A1 ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,THETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='THET' IHP2='A2 ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,THETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='P1 ' IHP2=' ' ALOWLM=0.0 AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' ADEF=0.05 CALL PARCH2(IHP,IHP2,IDIST,P1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='P2 ' IHP2=' ' ADEF=0.95 CALL PARCH2(IHP,IHP2,IDIST,P2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'GECP')THEN IDIST='GEOMETRIC' IHP='P1 ' IHP2=' ' ALOWLM=0.0 AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' ADEF=0.01 CALL PARCH2(IHP,IHP2,IDIST,P1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='P2 ' IHP2=' ' ADEF=0.99 CALL PARCH2(IHP,IHP2,IDIST,P2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'POCP')THEN IDIST='POISSON' IHP='LAMB' IHP2='DA1 ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,ALAMB1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='LAMB' IHP2='DA2 ' ADEF=50.0 IDIST='POISSON' CALL PARCH2(IHP,IHP2,IDIST,ALAMB2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) GOTO899 ENDIF IF(ICASPL.EQ.'NBCP')THEN IDIST='NEGATIVE BINOMIAL' IHP='K1 ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,AK1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='K2 ' IHP2=' ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,AK2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='P1 ' IHP2=' ' ALOWLM=0.0 AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' ADEF=0.05 CALL PARCH2(IHP,IHP2,IDIST,P1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='P2 ' IHP2=' ' ADEF=0.95 CALL PARCH2(IHP,IHP2,IDIST,P2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'IGCP')THEN IDIST='INVERSE GAUSSIAN' IHP='GAMM' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,GAMMA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='GAMM' IHP2='A2 ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='MU1 ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,AMU1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='MU2 ' IHP2=' ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,AMU2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'EECP')THEN IDIST='GEOMETRIC EXTREME EXPONENTIAL' IHP='GAMM' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.1 CALL PARCH2(IHP,IHP2,IDIST,GAMMA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) C IHP='GAMM' IHP2='A2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF C IF(ICASPL.EQ.'ERCP')THEN IDIST='ERROR' IHP='ALPH' IHP2='A1 ' ALOWLM=1. AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) C IHP='ALPH' IHP2='A2 ' ADEF=6.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF C IF(ICASPL.EQ.'WACP')THEN IHP='GAMM' IHP2='A1 ' IDIST='WALD' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,GAMMA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='GAMM' IHP2='A2 ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'RICP')THEN IDIST='RECIRPOCAL INVERSE GAUSSIAN' IHP='GAMM' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,GAMMA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='GAMM' IHP2='A2 ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IDIST='RECIPROCAL INVERSE GAUSSIAN' IHP='MU1 ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,AMU1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='MU2 ' IHP2=' ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,AMU2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'FLCP')THEN IDIST='FATIGUE LIFE' IHP='GAMM' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,GAMMA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='GAMM' IHP2='A2 ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'GPCP')THEN IDIST='GENERALIZED PARETO' IHP='GAMM' IHP2='A1 ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=-3.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='GAMM' IHP2='A2 ' ADEF=3.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'TRCP')THEN IDIST='TRIANGULAR' IHP='C1 ' IHP2=' ' ALOWLM=-1.0 AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' ADEF=-0.99 CALL PARCH2(IHP,IHP2,IDIST,C1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='C2 ' IHP2=' ' ADEF=0.99 CALL PARCH2(IHP,IHP2,IDIST,C2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'NCCP')THEN IDIST='NON-CENTRAL CHI-SQUARED' IHP='NU1 ' IHP2=' ' ILOWLM=1 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' IDEF=5 CALL PARCI2(IHP,IHP2,IDIST,NU1,IDEF,ILOWLM,IUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='NU2 ' IHP2=' ' IDEF=15 CALL PARCI2(IHP,IHP2,IDIST,NU2,IDEF,ILOWLM,IUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='LAMB' IHP2='DA1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=0.0 CALL PARCH2(IHP,IHP2,IDIST,ALAMB1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='LAMB' IHP2='DA2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,ALAMB2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'NTCP')THEN IDIST='NON-CENTRAL T' IHP='NU1 ' IHP2=' ' ILOWLM=1 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' IDEF=5 CALL PARCI2(IHP,IHP2,IDIST,NU1,IDEF,ILOWLM,IUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='NU2 ' IHP2=' ' IDEF=20 CALL PARCI2(IHP,IHP2,IDIST,NU2,IDEF,ILOWLM,IUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='LAMB' IHP2='DA1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=0.0 CALL PARCH2(IHP,IHP2,IDIST,ALAMB1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='LAMB' IHP2='DA2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,ALAMB2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'VMCP')THEN IDIST='VON MISES' IHP='B1 ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,B1,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='B2 ' IHP2=' ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,B2,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'PNCP')THEN IDIST='POWER NORMAL' IHP='P1 ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,P1,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='P2 ' IHP2=' ' ADEF=50.0 CALL PARCH2(IHP,IHP2,IDIST,P2,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'PLCP')THEN IDIST='POWER LOG-NORMAL' IHP='P1 ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,P1,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='P2 ' IHP2=' ' ADEF=20.0 CALL PARCH2(IHP,IHP2,IDIST,P2,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='SD1 ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,SD1,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='SD2 ' IHP2=' ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,SD2,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'ALCP')THEN IDIST='ALPHA' IHP='ALPH' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.1 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.1 CALL PARCH2(IHP,IHP2,IDIST,BETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,BETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'LNCP')THEN IDIST='LOGNORMAL' IHP='SIGM' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,SIGMA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='SIGM' IHP2='A2 ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,SIGMA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'PFCP')THEN IDIST='POWER FUNCTION' IHP='C1 ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,C1,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='C2 ' IHP2=' ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,C2,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'CHCP')THEN IHP='NU1 ' IHP2=' ' IDIST='CHI' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,ANU1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='NU2 ' IHP2=' ' ADEF=50.0 CALL PARCH2(IHP,IHP2,IDIST,ANU2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'DLCP')THEN IDIST='LOGARITHMIC SERIES' IHP='THET' IHP2='A1 ' ALOWLM=0. AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' ADEF=0.05 CALL PARCH2(IHP,IHP2,IDIST,THETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='THET' IHP2='A2 ' ADEF=0.95 CALL PARCH2(IHP,IHP2,IDIST,THETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'GSCP')THEN IDIST='GENERALIZED LOGARITHMIC SERIES' IHP='THET' IHP2='A1 ' ALOWLM=0. AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' ADEF=0.05 CALL PARCH2(IHP,IHP2,IDIST,THETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='THET' IHP2='A2 ' ADEF=0.95 CALL PARCH2(IHP,IHP2,IDIST,THETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2='1 ' ALOWLM=1.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=1.05 CALL PARCH2(IHP,IHP2,IDIST,BETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,BETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'KZCP')THEN IDIST='KATZ' IHP='ALPH' IHP2='A1 ' ALOWLM=0. AUPPLM=10.0 LOWLTY='> ' UPPLTY='< ' ADEF=0.1 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2='1 ' ALOWLM=CPUMIN AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' ADEF=-5.0 CALL PARCH2(IHP,IHP2,IDIST,BETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='2 ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,BETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'GETC')THEN IDIST='GEETA' IF(IGETDF.EQ.'THET')THEN IHP='THET' IHP2='A1 ' ALOWLM=0. AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' ADEF=0.05 CALL PARCH2(IHP,IHP2,IDIST,THETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='THET' IHP2='A2 ' ADEF=0.95 CALL PARCH2(IHP,IHP2,IDIST,THETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2='1 ' ALOWLM=1.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=1.05 CALL PARCH2(IHP,IHP2,IDIST,BETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,BETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSE IHP='MU1 ' IHP2=' ' ALOWLM=1.0 AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='< ' ADEF=1.05 CALL PARCH2(IHP,IHP2,IDIST,AMU1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='MU2 ' IHP2=' ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,AMU2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2='1 ' ALOWLM=1.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=1.05 CALL PARCH2(IHP,IHP2,IDIST,BETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,BETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ENDIF GOTO899 ENDIF IF(ICASPL.EQ.'CNCP')THEN IDIST='CONSUL (GENERALIZED GEOMETRIC)' IF(ICONDF.EQ.'THET')THEN IHP='THET' IHP2='A1 ' ALOWLM=0. AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' ADEF=0.05 CALL PARCH2(IHP,IHP2,IDIST,THETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='THET' IHP2='A2 ' ADEF=0.95 CALL PARCH2(IHP,IHP2,IDIST,THETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='M1 ' IHP2=' ' ALOWLM=1.0 AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='< ' ADEF=1.05 CALL PARCH2(IHP,IHP2,IDIST,AM1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='M2 ' IHP2=' ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,AM2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSE IHP='MU1 ' IHP2=' ' ALOWLM=1.0 AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='< ' ADEF=1.05 CALL PARCH2(IHP,IHP2,IDIST,AMU1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='MU2 ' IHP2=' ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,AMU2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='M1 ' IHP2=' ' ALOWLM=1.0 AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='< ' ADEF=1.05 CALL PARCH2(IHP,IHP2,IDIST,AM1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='M2 ' IHP2=' ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,AM2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ENDIF GOTO899 ENDIF IF(ICASPL.EQ.'QBCP')THEN IDIST='QUASI BINOMIAL TYPE I' C IHP='M ' IHP2=' ' ILOWLM=1 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' CALL PARCHI(IHP,IHP2,IDIST,IM,ILOWLM,IUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 AM=REAL(IM) C IHP='P1 ' IHP2=' ' ALOWLM=0. AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' ADEF=0.05 CALL PARCH2(IHP,IHP2,IDIST,P1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='P2 ' IHP2=' ' ADEF=0.95 CALL PARCH2(IHP,IHP2,IDIST,P2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='PHI1' IHP2=' ' ALOWLM=-P1/AM AUPPLM=(1.0-P1)/AM AINC=(AUPPLM-ALOWLM)/50.0 LOWLTY='>= ' UPPLTY='<= ' ADEF=ALOWLM+AINC CALL PARCH2(IHP,IHP2,IDIST,PHI1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='PHI2' IHP2=' ' ADEF=AUPPLM-AINC CALL PARCH2(IHP,IHP2,IDIST,PHI2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'YUCP')THEN IDIST='YULE' IHP='P1 ' IHP2=' ' ALOWLM=0.3 AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='< ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,P1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='P2 ' IHP2=' ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,P2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'WRCP')THEN IDIST='WARING' IHP='C1 ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,C1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='C2 ' IHP2=' ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,C2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='A1 ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='< ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,A1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='A2 ' IHP2=' ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,A2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C GOTO899 ENDIF IF(ICASPL.EQ.'DIWP')THEN IDIST='DISCRETE WEIBULL' IHP='Q1 ' IHP2=' ' ALOWLM=0. AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' ADEF=0.05 CALL PARCH2(IHP,IHP2,IDIST,P1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='Q2 ' IHP2=' ' ADEF=0.95 CALL PARCH2(IHP,IHP2,IDIST,P2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2='1 ' ALOWLM=0.01 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=0.1 CALL PARCH2(IHP,IHP2,IDIST,BETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='2 ' ADEF=3.0 CALL PARCH2(IHP,IHP2,IDIST,BETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'LLCP')THEN IDIST='LOG-LOGISTIC' IHP='DELT' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.2 CALL PARCH2(IHP,IHP2,IDIST,DELTA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='DELT' IHP2='A2 ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,DELTA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'GGCP')THEN IDIST='GENERALIZED GAMMA' IHP='ALPH' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='C1 ' IHP2=' ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.1 CALL PARCH2(IHP,IHP2,IDIST,C1,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(C1.EQ.0.0)C1=ADEF C IHP='C2 ' IHP2=' ' ADEF=3.0 CALL PARCH2(IHP,IHP2,IDIST,C2,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'WRCP')THEN IDIST='WARING' IHP='C1 ' IHP2=' ' ALOWLM=1.0 AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,C1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='C2 ' IHP2=' ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,C2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='A1 ' IHP2=' ' ALOWLM=1.0 AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,A1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='A2 ' IHP2=' ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,A2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'FNCP')THEN IDIST='FOLDED NORMAL' IHP='MU1 ' IHP2=' ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=-25.0 CALL PARCH2(IHP,IHP2,IDIST,AMU1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='MU2 ' IHP2=' ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,AMU2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='SD1 ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,SD1,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='SD2 ' IHP2=' ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,SD2,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'LGCP')THEN IDIST='LOG-GAMMA' IHP='GAMM' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,GAMMA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='GAMM' IHP2='A2 ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'GOCP')THEN IDIST='GOMPERTZ' IHP='C1 ' IHP2=' ' ALOWLM=1.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=1.1 CALL PARCH2(IHP,IHP2,IDIST,C1,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='C2 ' IHP2=' ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,C2,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='B1 ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.1 CALL PARCH2(IHP,IHP2,IDIST,B1,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='B2 ' IHP2=' ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,B2,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'GVCP')THEN IDIST='GENERALIZED EXTREME VALUE' IHP='GAMM' IHP2='A1 ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=-5.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='GAMM' IHP2='A2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'GZCP')THEN IDIST='GENERALIZED HALF-LOGISTIC' IHP='GAMM' IHP2='A1 ' ALOWLM=0.0 AUPPLM=5.0 LOWLTY='> ' UPPLTY='<= ' ADEF=0.1 CALL PARCH2(IHP,IHP2,IDIST,GAMMA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='GAMM' IHP2='A2 ' ADEF=2.5 CALL PARCH2(IHP,IHP2,IDIST,GAMMA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'P2CP')THEN IDIST='PARETO TYPE 2' IHP='GAMM' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.1 CALL PARCH2(IHP,IHP2,IDIST,GAMMA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='GAMM' IHP2='A2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA2,ADEF,ALOWLM,AUPPLM, 1 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 A1=1.0 ELSE A1=VALUE(ILOCP) ENDIF IF(A1.LE.0.0)A1=1.0 C GOTO899 ENDIF IF(ICASPL.EQ.'DWCP')THEN IDIST='DOUBLE WEIBULL' IHP='GAMM' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,GAMMA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='GAMM' IHP2='A2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'WCCP')THEN IDIST='WRAPPED CAUCHY' IHP='P1 ' IHP2=' ' ALOWLM=0. AUPPLM=1. LOWLTY='>= ' UPPLTY='< ' ADEF=0.0 CALL PARCH2(IHP,IHP2,IDIST,P1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='P2 ' IHP2=' ' ADEF=0.99 CALL PARCH2(IHP,IHP2,IDIST,P2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'EWCP')THEN IDIST='EXPONENTIATED WEIBULL' IHP='GAMM' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,GAMMA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='GAMM' IHP2='A2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='THET' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,THETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='THET' IHP2='A2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,THETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'GLCP')THEN IDIST='GENERALIZED LOGISTIC' IHP='ALPH' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.2 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'G2CP')THEN IDIST='GENERALIZED LOGISTIC TYPE 2' IHP='ALPH' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.1 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'G3CP')THEN IDIST='GENERALIZED LOGISTIC TYPE 3' IHP='ALPH' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.1 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=3.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'G4CP')THEN IDIST='GENERALIZED LOGISTIC TYPE 4' IHP='P1 ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,P1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='P2 ' IHP2=' ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,P2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='Q1 ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,Q1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='Q2 ' IHP2=' ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,Q2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'G5CP')THEN IDIST='GENERALIZED LOGISTIC TYPE 5 (HOSKING)' IHP='ALPH' IHP2='A1 ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=-2.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=2.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'PECP')THEN IDIST='EXPONENTIAL POWER' IHP='ALPH' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,BETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,BETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'DGCP')THEN IDIST='DOUBLE GAMMA' IHP='GAMM' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,GAMMA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='GAMM' IHP2='A2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'FCCP')THEN IDIST='FOLDED CAUCHY' IHP='LOC1' IHP2=' ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=-25.0 CALL PARCH2(IHP,IHP2,IDIST,AMU1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='LOC2' IHP2=' ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,AMU2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='SCAL' IHP2='E1 ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,SD1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='SCAL' IHP2='E2 ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,SD2,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'BRCP')THEN IDIST='BRADFORD' IHP='BETA' IHP2='1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,BETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='2 ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,BETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'RECP')THEN IDIST='RECIPROCAL' IHP='B1 ' IHP2=' ' ALOWLM=1. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=1.5 CALL PARCH2(IHP,IHP2,IDIST,B1,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='B2 ' IHP2=' ' ADEF=20.0 CALL PARCH2(IHP,IHP2,IDIST,B2,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'GICP')THEN IDIST='INVERTED GAMMA' IHP='GAMM' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,GAMMA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='GAMM' IHP2='A2 ' ADEF=25.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'IWCP')THEN IDIST='INVERTED WEIBULL' IHP='GAMM' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,GAMMA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='GAMM' IHP2='A2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,GAMMA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'LXCP')THEN IDIST='LOG DOUBLE EXPONENTIAL' IHP='ALPH' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'AXCP')THEN IDIST='ASYMMETRIC LOG DOUBLE EXPONENTIAL' IHP='ALPH' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=5.4 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2='1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,BETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='2 ' ADEF=5.4 CALL PARCH2(IHP,IHP2,IDIST,BETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'JUCP')THEN IDIST='JOHNSON SU' IHP='ALPH' IHP2='A11 ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=-1.0 CALL PARCH2(IHP,IHP2,IDIST,ALPH11,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A12 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,ALPH12,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A21 ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,ALPH21,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A22 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,ALPH22,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'JBCP')THEN IDIST='JOHNSON SB' IHP='ALPH' IHP2='A11 ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=-3.0 CALL PARCH2(IHP,IHP2,IDIST,ALPH11,ADEF, 1 ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A12 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,ALPH12,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A21 ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,ALPH21,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A22 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,ALPH22,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'LDCP')THEN IDIST='GENERALIZED TUKEY-LAMBDA' IHP='LAMB' IHP2='DA31' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=-1.0 CALL PARCH2(IHP,IHP2,IDIST,ALMB31,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='LAMB' IHP2='DA32' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,ALMB32,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='LAMB' IHP2='DA41' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=-1.0 CALL PARCH2(IHP,IHP2,IDIST,ALMB41,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='LAMB' IHP2='DA42' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,ALMB42,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF C IF(ICASPL.EQ.'TSCP')THEN IDIST='TWO-SIDED POWER' IHP='THET' IHP2='A1 ' ALOWLM=0. AUPPLM=1.0 LOWLTY='>= ' UPPLTY='<= ' ADEF=0.05 CALL PARCH2(IHP,IHP2,IDIST,THETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='THET' IHP2='A2 ' ADEF=0.95 CALL PARCH2(IHP,IHP2,IDIST,THETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='N1 ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.1 CALL PARCH2(IHP,IHP2,IDIST,ANU1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='N2 ' IHP2=' ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,ANU2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'FTCP')THEN IDIST='FOLDED T' IHP='NU1 ' IHP2=' ' ILOWLM=1 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' IDEF=1 CALL PARCI2(IHP,IHP2,IDIST,NU1,IDEF,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERRO2) IF(IERROR.EQ.'YES')GOTO9000 C IHP='NU2 ' IHP2=' ' IDEF=50 CALL PARCI2(IHP,IHP2,IDIST,NU2,IDEF,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERRO2) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF C IF(ICASPL.EQ.'SNCP')THEN IDIST='SKEWED NORMAL' IHP='LAMB' IHP2='DA1 ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=-5.0 CALL PARCH2(IHP,IHP2,IDIST,ALAMB1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='LAMB' IHP2='DA2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,ALAMB2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF C IF(ICASPL.EQ.'STCP')THEN IDIST='SKEWED T' IHP='NU1 ' IHP2=' ' ILOWLM=1 IUPPLM=I1MACH(9) LOWLTY='>= ' UPPLTY='<= ' IDEF=1 CALL PARCI2(IHP,IHP2,IDIST,NU1,IDEF,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERRO2) IF(IERROR.EQ.'YES')GOTO9000 C IHP='NU2 ' IHP2=' ' IDEF=25 CALL PARCI2(IHP,IHP2,IDIST,NU2,IDEF,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERRO2) IF(IERROR.EQ.'YES')GOTO9000 C IHP='LAMB' IHP2='DA1 ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=-3.0 CALL PARCH2(IHP,IHP2,IDIST,ALAMB1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='LAMB' IHP2='DA2 ' ADEF=3.0 CALL PARCH2(IHP,IHP2,IDIST,ALAMB2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF C IF(ICASPL.EQ.'IBCP')THEN IDIST='INVERTED BETA' IHP='ALPH' IHP2='A1 ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='1 ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,BETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,BETA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF IF(ICASPL.EQ.'LBCP')THEN IDIST='LOG BETA' IHP='ALPH' IHP2='A1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHP='BETA' IHP2='1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,BETA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='BETA' IHP2='2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,BETA2,ADEF,ALOWLM,AUPPLM, 1 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 GOTO899 ENDIF IF(ICASPL.EQ.'GHCP')THEN IDIST='G-H' IHP='G1 ' IHP2=' ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=-1.0 CALL PARCH2(IHP,IHP2,IDIST,G1,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='G2 ' IHP2=' ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,G2,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='H1 ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=0.0 CALL PARCH2(IHP,IHP2,IDIST,H1,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='H2 ' IHP2=' ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,H2,ADEF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF C IF(ICASPL.EQ.'LZCP')THEN IDIST='LOG-SKEW-NORMAL' IHP='LAMB' IHP2='DA1 ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=0.0 CALL PARCH2(IHP,IHP2,IDIST,ALAMB1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='LAMB' IHP2='DA2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,ALAMB2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='SD1 ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,SD1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='SD2 ' IHP2=' ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,SD2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF C IF(ICASPL.EQ.'TECP')THEN IDIST='TRUNCATED EXPONENTIAL' C IHP='X0 ' IHP2=' ' 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 C IHP='M1 ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=0.0 CALL PARCH2(IHP,IHP2,IDIST,AMU1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='M2 ' IHP2=' ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,AMU2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='SD1 ' IHP2=' ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.1 CALL PARCH2(IHP,IHP2,IDIST,SD1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='SD2 ' IHP2=' ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,SD2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF C IF(ICASPL.EQ.'SDCP')THEN IDIST='SKEWED DOUBLE EXPONENTIAL' IHP='LAMB' IHP2='DA1 ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='< ' ADEF=0.0 CALL PARCH2(IHP,IHP2,IDIST,ALAMB1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='LAMB' IHP2='DA2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,ALAMB2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF C IF(ICASPL.EQ.'ADCP')THEN IDIST='ASYMMETRIC DOUBLE EXPONENTIAL' IF(IADEDF.EQ.'K')THEN IHP='K1 ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=0.2 CALL PARCH2(IHP,IHP2,IDIST,AK1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='K2 ' IHP2=' ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,AK2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ELSE IHP='MU1 ' IHP2=' ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=-5.0 CALL PARCH2(IHP,IHP2,IDIST,AMU1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='MU2 ' IHP2=' ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,AMU2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF ENDIF C IF(ICASPL.EQ.'MXCP')THEN IDIST='MAXWELL' IHP='SIGM' IHP2='A1 ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=0.1 CALL PARCH2(IHP,IHP2,IDIST,SIGMA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='SIGM' IHP2='A2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,SIGMA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF C IF(ICASPL.EQ.'GMCP')THEN IF(IMAKDF.NE.'REPA')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,810) 810 FORMAT('***** ERROR IN PPCC/KS PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811) 811 FORMAT(' FOR GOMPERTZ-MAKEHAM, THE PPCC/KS PLOT IS ONLY') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,813) 813 FORMAT(' ALLOWED FOR THE "REPARAMETERIZATION MEEKER" ', 1 'DEFINTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,815) 815 FORMAT(' ENTER THE COMMAND:') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,817) 817 FORMAT(' HELP MAKPDF') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,819) 819 FORMAT(' FOR DETAILS.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF IDIST='GOMPERTZ-MAKEHAM' IHP='ETA1' IHP2=' ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=0.1 CALL PARCH2(IHP,IHP2,IDIST,ETA1,ADEF,ALOWLM,AUPPLM,LOWLTY, 1 UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ETA2' IHP2=' ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,ETA2,ADEF,ALOWLM,AUPPLM,LOWLTY, 1 UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ZETA' IHP2='1 ' ALOWLM=0. AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='<= ' ADEF=0.1 CALL PARCH2(IHP,IHP2,IDIST,ZETA1,ADEF,ALOWLM,AUPPLM,LOWLTY, 1 UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ZETA' IHP2='2 ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,ZETA2,ADEF,ALOWLM,AUPPLM,LOWLTY, 1 UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF C IF(ICASPL.EQ.'GALP')THEN IDIST='GENERALIZED ASYMMETRIC DOUBLE EXPONENTIAL' IF(IADEDF.EQ.'K')THEN IHP='K1 ' IHP2=' ' ALOWLM=0.2 AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='< ' ADEF=0.2 CALL PARCH2(IHP,IHP2,IDIST,AK1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='K2 ' IHP2=' ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,AK2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='TAU1' IHP2=' ' ALOWLM=0.2 AUPPLM=CPUMAX LOWLTY='>= ' UPPLTY='< ' ADEF=0.2 CALL PARCH2(IHP,IHP2,IDIST,TAU1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='TAU2' IHP2=' ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,TAU2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ELSE IHP='MU1 ' IHP2=' ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=-5.0 CALL PARCH2(IHP,IHP2,IDIST,AMU1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='MU2 ' IHP2=' ' ADEF=5.0 CALL PARCH2(IHP,IHP2,IDIST,AMU2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF ENDIF C IF(ICASPL.EQ.'MCCP')THEN IDIST='MCLEISH' IHP='ALPH' IHP2='A1 ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=1.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=15.5 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF C IF(ICASPL.EQ.'GMLP')THEN IDIST='GENERALIZED MCLEISH' IHP='ALPH' IHP2='A1 ' ALOWLM=CPUMIN AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.5 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='A1 ' IHP2=' ' ALOWLM=-1.0 AUPPLM=1.0 LOWLTY='> ' UPPLTY='< ' ADEF=-0.8 CALL PARCH2(IHP,IHP2,IDIST,A1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='A2 ' IHP2=' ' ADEF=0.8 CALL PARCH2(IHP,IHP2,IDIST,A2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF C IF(ICASPL.EQ.'HYCP')THEN IF(ICOM2.EQ.'BOLI')THEN IDIST='HYPERBOLIC' IHP='ALPH' IHP2='A1 ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='<= ' ADEF=0.2 CALL PARCH2(IHP,IHP2,IDIST,ALPHA1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='ALPH' IHP2='A2 ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,ALPHA2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='XI1 ' IHP2=' ' ALOWLM=0.0 AUPPLM=CPUMAX LOWLTY='> ' UPPLTY='< ' ADEF=0.2 CALL PARCH2(IHP,IHP2,IDIST,XI1,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IHP='XI2 ' IHP2=' ' ADEF=10.0 CALL PARCH2(IHP,IHP2,IDIST,XI2,ADEF,ALOWLM,AUPPLM, 1 LOWLTY,UPPLTY, 1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ELSE IDIST='HYPERGEOMETRIC' CCCCC IHP='MU1 ' CCCCC IHP2=' ' CCCCC ALOWLM=CPUMIN CCCCC AUPPLM=CPUMAX CCCCC LOWLTY='> ' CCCCC UPPLTY='< ' CCCCC ADEF=-5.0 CCCCC CALL PARCH2(IHP,IHP2,IDIST,AMU1,ADEF,ALOWLM,AUPPLM, CCCCC1 LOWLTY,UPPLTY, CCCCC1 ISUBN1,ISUBN2,IERROR) CCCCC IF(IERROR.EQ.'YES')GOTO9000 C CCCCC IHP='MU2 ' CCCCC IHP2=' ' CCCCC ADEF=5.0 CCCCC CALL PARCH2(IHP,IHP2,IDIST,AMU2,ADEF,ALOWLM,AUPPLM, CCCCC1 LOWLTY,UPPLTY, CCCCC1 ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO899 ENDIF ENDIF C 899 CONTINUE C IF(ICASP2.EQ.'KS ')THEN C C LOCATION AND SCALE FOR KS PLOT C IHP='KSLO' IHP2='C ' 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 KSLOC=CPUMIN ELSE KSLOC=VALUE(ILOCP) ENDIF C IHP='KSSC' IHP2='ALE ' 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 KSSCAL=CPUMIN ELSE KSSCAL=VALUE(ILOCP) ENDIF IF(KSSCAL.LE.0.0)KSSCAL=CPUMIN ENDIF C IHP='MINS' IHP2='IZE ' 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 MINSIZ=5 ELSE MINSIZ=INT(VALUE(ILOCP)+0.5) IF(MINSIZ.LE.0)MINSIZ=5 ENDIF C IF(NUMSHA.GT.1 .AND. IREPL.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,901) 901 FORMAT('***** WARNING FOR PPCC PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,903) 903 FORMAT(' REPLICATION NOT SUPPORTED FOR CASES WITH MORE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,905) 905 FORMAT(' THAN ONE SHAPE PARAMETER. THE REPLICATION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,907) 907 FORMAT(' VARIABLE WILL BE IGNORED.') CALL DPWRST('XXX','BUG ') IREPL='OFF' ENDIF C C ***************************************************** C ** STEP 9-- ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** C ** RESET THE VECTOR D(.) TO ALL ONES. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ***************************************************** C ISTEPN='9' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPCC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PPCC')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,911) 911 FORMAT('***** FROM THE MIDDLE OF DPPPCC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,912)ICASPL,NUMV2,IDATSW,NPLOTP,NPLOTV 912 FORMAT('ICASPL,NUMV2,IDATSW,NPLOTP,NPLOTV = ',A4,I8,2X,A4,2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,913)ALAMB1,ALAMB2,NU1,NU2 913 FORMAT('ALAMB1,ALAMB2,NU1,NU2 = ',2E15.7,2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,914)GAMMA1,GAMMA2,P1,P2 914 FORMAT('GAMMA1,GAMMA2,P1,P2 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,921)NLOCAL,NUMSHA 921 FORMAT('NLOCAL,NUMSHA = ',2I8) CALL DPWRST('XXX','BUG ') IF(NLOCAL.GE.1)THEN DO922I=1,NLOCAL WRITE(ICOUT,923)I,Y1(I),X1(I) 923 FORMAT('I,Y1(I),X1(I) = ',I8,2F12.5) CALL DPWRST('XXX','BUG ') 922 CONTINUE 929 ENDIF IF(NPLOTP.GT.0)THEN DO935I=1,NPLOTP WRITE(ICOUT,936)I,Y(I),X(I),D(I) 936 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 935 CONTINUE ENDIF ENDIF C CALL DPPPC2(Y1,X1,X1UPP,XCENS,XREPL,XREPDS,NLOCAL, 1ICASPL,ICASP2,IDATSW, 1ALAMB1,ALAMB2,NU1,NU2,GAMMA1,GAMMA2,P1,P2,MINMAX, 1SD,SD1,SD2,C1,C2,ANU1,ANU2,B1,B2,DELTA1,DELTA2,ALPHA1,ALPHA2, 1BETA1,BETA2,THETA1,THETA2,NBINOM, 1ALMB11,ALMB12,ALMB21,ALMB22,ALMB31,ALMB32,ALMB41,ALMB42, 1ALPH11,ALPH12,ALPH21,ALPH22, 1NU11,NU12,NU21,NU22, 1AMU1,AMU2,G1,G2,H1,H2,AK1,AK2, 1A1,A2,NU,X0,SIGMA1,SIGMA2, 1ETA1,ETA2,ZETA1,ZETA2, 1TAU1,TAU2,Q1,Q2, 1PHI1,PHI2,AM,AM1,AM2, 1YLOWLM,YUPPLM, 1DISPAR,DISPA2,DISPA3,CORR,CORR2,NUMSHA, 1XTEMP1,XTEMP2,XTEMP3,XTEMP4,XTEMP5,XTEMP6,XTEMP7,XTEMP8,X1UTMP, 1XTEMP9,IHSTCW, 1X2TEMP,Y2TEMP,D2TEMP, 1IPPCCC,IPPCFO,KSLOC,KSSCAL, 1Y3,XLOW,XHIGH,MINSIZ, 1WEIGHH,WEIGHV,RESBW,PREDBW,IPPCBW, 1IADEDF,IGEPDF,IMAKDF,IBEIDF, 1ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF, 1IPPCDP,IPPCAP,IPPCAO,IMETHD,ICENSO,IREPL, 1PCHSLM, 1Y,X,X3D,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) C CCCCC THE FOLLOWING ENTIRE SECTION WAS ADDED MAY 1993 CCCCC TO ALLOW AUTO-COMPUTATION OF THE PROB. PLOT CORR. COEF MAY 1993 CCCCC THE FOLLOWING SECTION WAS SIMPLIFED DECEMBER 1993 C C *************************************** C ** STEP 61-- ** C ** COMPUTE PROB. PLOT CORR. COEF ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C ISTEPN='61' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IWRITE='OFF' C CCCCC IF ALTERNATE CORRELATION MEASURE USED, THEN SHAPE WILL CCCCC BE STANDARD CORRELATION, SHAPE2 WILL BE ALTERNATIVE MEASURE C IF(ICASP2.EQ.'KS ')THEN CALL MINIM(Y,NPLOTP,IWRITE,AKSMIN,IBUGG3,IERROR) IF(NUMSHA.LE.1)THEN DO6050I=1,NPLOTP I2=I IF(Y(I).EQ.AKSMIN)GOTO6059 6050 CONTINUE 6059 CONTINUE SHAPE=X(I2) A0=XTEMP3(I2) A1=XTEMP4(I2) ELSE DO6060I=1,NPLOTP I2=I IF(Y(I).EQ.AKSMIN)GOTO6069 6060 CONTINUE 6069 CONTINUE IF(IPPCFO.EQ.'TRAC')THEN SHAPE2=X(I2) SHAPE1=X3D(I2) ELSE SHAPE1=X(I2) SHAPE2=X3D(I2) ENDIF A0=XTEMP3(I2) A1=XTEMP4(I2) ENDIF ELSEIF(IPPCCC.EQ.'LINE')THEN CALL MAXIM(Y,NPLOTP,IWRITE,PPCCMX,IBUGG3,IERROR) IF(NUMSHA.LE.1)THEN DO6000I=1,NPLOTP I2=I IF(Y(I).EQ.PPCCMX)GOTO6009 6000 CONTINUE 6009 CONTINUE SHAPE=X(I2) ELSE DO6010I=1,NPLOTP I2=I IF(Y(I).EQ.PPCCMX)GOTO6019 6010 CONTINUE 6019 CONTINUE IF(IPPCFO.EQ.'TRAC')THEN SHAPE2=X(I2) SHAPE1=X3D(I2) ELSE SHAPE1=X(I2) SHAPE2=X3D(I2) ENDIF ENDIF ELSE IF(NUMSHA.LE.1)THEN PPCCMX=-99.0 PPCCM2=-99.0 DO6100I=1,NPLOTP IF(D(I).EQ.1.0 .AND. Y(I).GT.PPCCMX)PPCCMX=Y(I) IF(D(I).EQ.2.0 .AND. Y(I).GT.PPCCM2)PPCCM2=Y(I) 6100 CONTINUE DO6120I=1,NPLOTP I2=I IF(D(I).EQ.1.0 .AND. Y(I).EQ.PPCCMX)GOTO6129 6120 CONTINUE 6129 CONTINUE SHAPE=X(I2) C DO6130I=1,NPLOTP I2=I IF(D(I).EQ.2.0 .AND. Y(I).EQ.PPCCM2)GOTO6139 6130 CONTINUE 6139 CONTINUE SHAPE2=X(I2) ELSE PPCCMX=-99.0 DO6300I=1,NPLOTP IF(Y(I).GT.PPCCMX)PPCCMX=Y(I) 6300 CONTINUE DO6310I=1,NPLOTP I2=I IF(Y(I).EQ.PPCCMX)GOTO6319 6310 CONTINUE 6319 CONTINUE IF(IPPCFO.EQ.'TRAC')THEN SHAPE2=X(I2) SHAPE1=X3D(I2) ELSE SHAPE1=X(I2) SHAPE2=X3D(I2) ENDIF ENDIF ENDIF C ISUBN0='PPCC' C IF(ICASP2.EQ.'PPCC')THEN IH='MAXP' IH2='PCC ' VALUE0=PPCCMX CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1 IANS,IWIDTH,IBUGG3,IERROR) ELSE IH='MINK' IH2='S ' VALUE0=AKSMIN CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1 IANS,IWIDTH,IBUGG3,IERROR) IH='KSLO' IH2='CS ' VALUE0=A0 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1 IANS,IWIDTH,IBUGG3,IERROR) IH='KSSC' IH2='ALES' VALUE0=A1 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1 IANS,IWIDTH,IBUGG3,IERROR) ENDIF C IF(NUMSHA.LE.1)THEN IH='SHAP' IH2='E ' VALUE0=SHAPE CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1 IANS,IWIDTH,IBUGG3,IERROR) IF(IPPCCC.NE.'LINE')THEN IH='SHAP' IH2='E2 ' VALUE0=SHAPE2 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1 IANS,IWIDTH,IBUGG3,IERROR) ENDIF ELSE IH='SHAP' IH2='E1 ' VALUE0=SHAPE1 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1 IANS,IWIDTH,IBUGG3,IERROR) IH='SHAP' IH2='E2 ' VALUE0=SHAPE2 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1 IANS,IWIDTH,IBUGG3,IERROR) ENDIF C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PPCC')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPPCC--') 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)ALAMB1,ALAMB2,NU1,NU2 9014 FORMAT('ALAMB1,ALAMB2,NU1,NU2 = ',2E15.7,2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)GAMMA1,GAMMA2,P1,P2 9015 FORMAT('GAMMA1,GAMMA2,P1,P2 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)NLOCAL 9021 FORMAT('NLOCAL = ',I8) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 4 LINES WERE ADDED MAY 1993 WRITE(ICOUT,9016)MINMAX 9016 FORMAT('MINMAX = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)PPCCMX,SHAPE 9017 FORMAT('PPCCMX,SHAPE = ',2E15.7) CALL DPWRST('XXX','BUG ') IF(NLOCAL.LE.0)GOTO9029 DO9022I=1,NLOCAL WRITE(ICOUT,9023)I,Y1(I),X1(I) 9023 FORMAT('I,Y1(I),X1(I) = ',I8,2F12.5) CALL DPWRST('XXX','BUG ') 9022 CONTINUE 9029 CONTINUE IF(NPLOTP.LE.0)GOTO9090 DO9032I=1,NPLOTP WRITE(ICOUT,9033)I,Y(I),X(I),D(I) 9033 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9032 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPPC2(Y1,X1,X1UPP,XCENS,XREPL,XREPDS,N1, 1ICASPL,ICASP2,IDATSW, 1ALAMB1,ALAMB2,NU1,NU2,GAMMA1,GAMMA2,P1,P2,MINMAX, 1SD,SD1,SD2,C1,C2,ANU1,ANU2,B1,B2,DELTA1,DELTA2,ALPHA1,ALPHA2, 1BETA1,BETA2,THETA1,THETA2,NBINOM, 1ALMB11,ALMB12,ALMB21,ALMB22,ALMB31,ALMB32,ALMB41,ALMB42, 1ALPH11,ALPH12,ALPH21,ALPH22, 1NU11,NU12,NU21,NU22, 1AMU1,AMU2,G1,G2,H1,H2,AK1,AK2, 1A1,A2,NU,X0,SIGMA1,SIGMA2, 1ETA1,ETA2,ZETA1,ZETA2, 1TAU1,TAU2,Q1,Q2, 1PHI1,PHI2,AM,AM1,AM2, 1YLOWLM,YUPPLM, 1DISPAR,DISPA2,DISPA3,CORRV,CORRZ,NUMSHA, 1XTEMP1,XTEMP2,XTEMP3,XTEMP4,XTEMP5,XTEMP6,XTEMP7,XTEMP8,X1UTMP, 1XTEMP9,IHSTCW, 1X2TEMP,Y2TEMP,D2TEMP, 1IPPCCC,IPPCFO,KSLOC,KSSCAL, 1Y3,XLOW,XHIGH,MINSIZ, 1WEIGHH,WEIGHV,RESBW,PREDBW,IPPCBW, 1IADEDF,IGEPDF,IMAKDF,IBEIDF, 1ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF, 1IPPCDP,IPPCAP,IPPCAO,IMETHD,ICENSO,IREPL, 1PCHSLM, 1Y2,X2,X3D2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR) CCCCC THE MINMAX ARGUMENT WAS ADDED ABOVE MAY 1993 CCCCC PARAMETERS FOR NEW DISTRIBUTION APRIL 1995 CCCCC PARAMETERS FOR NEW DISTRIBUTION DECEMBER 1995 C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE C THE PROBABILITY PLOT CORRELATION COEFFICIENT TRACE C FOR SOME DISTRIBUTIONAL FAMILY. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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--FEBRUARY 1981. C UPDATED --JUNE 1981. C UPDATED --AUGUST 1981. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C UPDATED --MAY 1990. IG, WALD, RIG, FL (SAUNDERS) C UPDATED --APRIL 1992. AN TO AN1 C UPDATED --DECEMBER 1993. MINMAX FOR EV1/EV2/WEIB DIST. C UPDATED --MAY 1993. EXTREME VALUE (GENERAL) C UPDATED --MAY 1993. GENERALIZED PARETO C UPDATED --APRIL 1995. NEW DISTRIBUTIONS C UPDATED --OCTOBER 1995. LOG GAMMA DISTRIBUTION C UPDATED --OCTOBER 1995. 5 DISTRIBUTIONS C UPDATED --DECEMBER 1995. GENERALIZED LOGISTIC C UPDATED --JANUARY 1996. DOUBLE GAMMA C UPDATED --FEBRUARY 1996. BRADFORD C UPDATED --MAY 1996. RECIPROCAL C UPDATED --JANUARY 1998. BINOMIAL C UPDATED --JANUARY 1998. NEGATIVE BINOMIAL C UPDATED --JANUARY 1998. LOGARITHMIC SERIES C UPDATED --FEBRUARY 1998. CHECK FOR 0 COUNT FREQUENCIES C FOR BINNED DATA C UPDATED --AUGUST 2001. SUPPORT FOR A NUMBER OF C 2 SHAPE PARAMETER C DISTRIBUTIONS. C UPDATED --SEPTEMBER 2001. SUPPORT FOR 4 ADDITIONAL C DISTRIBUTIONS C UPDATED --NOVEMBER 2001. GEE DISTRIBUTION C UPDATED --NOVEMBER 2001. ALPHA DISTRIBUTION C UPDATED --NOVEMBER 2001. POWER LOGNORMAL SUPPORT C 2 SHAPE PARAMETERS C UPDATED --MAY 2003. ERROR (=SUBBOTIN=EXPO POWER) C UPDATED --NOVEMBER 2003. FOLDED T C UPDATED --DECEMBER 2003. SKEW NORMAL, SKEW T, C INVERTED BETA, C G-AND-H C UPDATED --MARCH 2004. LOG SKEW NORMAL, C NON-CENTRAL T C NON-CENTRAL CHI-SQUARE C UPDATED --MARCH 2004. FOR 2 SHAPE PARAMETER CASE, C WRITE COORDINATES TO FILE C UPDATED --APRIL 2004. HERMITE C UPDATED --MAY 2004. SUPPORT DIFFERENT CORRELATION C MEASURES C UPDATED --MAY 2004. SUPPORT FOR KS PLOT C UPDATED --MAY 2004. SUPPORT FOR GENERATING 2-SHAPE C PARAMETER CASE AS MULTI-TRACE C PLOT C UPDATED --JUNE 2004. SKEW DOUBLE EXPONENTIAL C UPDATED --JUNE 2004. ASYMMETRIC DOUBLE EXPONENTIAL C UPDATED --JUNE 2004. MAXWELL C UPDATED --JULY 2004. GOMPERTZ-MAKEHAM C UPDATED --AUGUST 2004. GENERALIZED ASYMMETRIC C DOUBLE EXPONENTIAL C UPDATED --AUGUST 2004. MCLEISH C UPDATED --SEPTEMBER 2004. GENERALIZED MCLEISH C UPDATED --SEPTEMBER 2004. HYPERBOLIC (NOT WORKING YET) C UPDATED --SEPTEMBER 2004. SUPPORT FOR FOLLOWING OPTIONS: C 1) SET PPCC PLOT DATA POINTS C 2) SET PPCC PLOT AXIS POINTS C 3) SET PPCC PLOT AXIS ORDER C UPDATED --OCTOBER 2004. MODIFY HOW "ALOC" C PARAMETER HANDLED C FOR PARETO DISTRIBUTION C UPDATED --OCTOBER 2004. WRITE LOCATION AND SCALE C PARAMETERS TO FILE C UPDATED --OCTOBER 2004. FOR BINNED CASE, USE CHI-SQUARE C RATHER THAN K-S TEST C UPDATED --OCTOBER 2004. FOR UNBINNED DATA, SUPPORT C CENSORING C UPDATED --OCTOBER 2004. WRITE : PPCC, LOC, SCALE, C SHAPE1, SHAPE2 TO C DPST2F.DAT C UPDATED --DECEMBER 2004. IF USER HAS NOT SET KSLOC C AND KSSCAL, SET THEM TO 0 AND C 1 FOR PARETO DISTRIBUTIONS C UPDATED --APRIL 2005. FOR ONE SHAPE PARAMETER CASE, C ADD SUPPORT FOR REPLICATION C CASE (GROUPS, AS OPPOSSED TO C BINS, IN THE DATA) C UPDATED --APRIL 2005. FOR BINNED DATA, SUPPORT CASE C WHERE BINS GIVEN AS LOWER AND C UPPER LIMITS (INSTEAD OF C JUST THE MID-POINT). THIS C ALLOWS UNEQUALLY SPACED BINS. C UPDATED --JULY 2005. CALL LIST TO LGAPPF AND SNPPF C CALL LIST TO DP1KS2 C CALL LIST TO DPCHS2 C UPDATED --FEBRUARY 2006. GENERALIZED LOGISTIC TYPE 5 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 LAPLACE C UPDATED --MAY 2006. FOR KS PLOT, ALLOW BIWEIGHT C ADJUSTMENT FOR LOCATION AND C SCALE PARAMETERS. C UPDATED --MAY 2006. BETA-GEOMETRIC C UPDATED --MAY 2006. ZETA, ZIPF C UPDATED --MAY 2006. BOREL-TANNER C UPDATED --JUNE 2006. LAGRANGE-POISSON 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. GEETA C UPDATED --JULY 2006. QUASI BINOMIAL TYPE 1 C UPDATED --AUGUST 2006. CONSUL C UPDATED --SEPTEMBER 2006. KATZ 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 ICASP2 CHARACTER*4 ICASP3 CHARACTER*4 IPPCCC CHARACTER*4 IPPCFO CHARACTER*4 IPPCAO 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 IMETHD CHARACTER*4 ICENSO CHARACTER*4 IREPL CHARACTER*4 IWRITE CHARACTER*4 IDATSW CHARACTER*4 IDATS2 CHARACTER*4 IRHSTG CHARACTER*4 ICAPSW CHARACTER*4 ICAPTY CHARACTER*4 IHSTCW CHARACTER*4 IPPCBW CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C CHARACTER*4 IFOUND C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOF2.INC' C CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG 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 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*80 IFILE3 CHARACTER*12 ISTAT3 CHARACTER*12 IFORM3 CHARACTER*12 IACCE3 CHARACTER*12 IPROT3 CHARACTER*12 ICURS3 CHARACTER*4 IERRF3 CHARACTER*4 IENDF3 CHARACTER*4 IREWI3 C CHARACTER*4 ISUBN0 C C--------------------------------------------------------------------- C INTEGER IPPCDP INTEGER IPPCAP(2) C DIMENSION Y1(*) DIMENSION X1(*) DIMENSION X1UPP(*) DIMENSION XCENS(*) DIMENSION XREPL(*) DIMENSION XREPDS(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION X3D2(*) DIMENSION D2(*) DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) DIMENSION XTEMP3(*) DIMENSION XTEMP4(*) DIMENSION XTEMP5(*) DIMENSION XTEMP6(*) DIMENSION XTEMP7(*) DIMENSION XTEMP8(*) DIMENSION X1UTMP(*) DIMENSION XTEMP9(*) DIMENSION X2TEMP(*) DIMENSION Y2TEMP(*) DIMENSION D2TEMP(*) DIMENSION Y3(*) DIMENSION XLOW(*) DIMENSION XHIGH(*) DIMENSION WEIGHH(*) DIMENSION WEIGHV(*) DIMENSION RESBW(*) DIMENSION PREDBW(*) C CCCCC THE FOLLOWING 2 LINES WERE CHANGED DECEMBER 1993 CCCCC DIMENSION DISPAR(100) CCCCC DIMENSION DISPAR(100) DIMENSION DISPAR(*) DIMENSION DISPA2(*) DIMENSION DISPA3(*) DIMENSION CORRV(*) DIMENSION CORRZ(*) C REAL KSLOC REAL KSSCAL DOUBLE PRECISION DP DOUBLE PRECISION DPPF C DOUBLE PRECISION QUAGLO DOUBLE PRECISION XPAR(3) 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.1415926535 / C C-----START POINT----------------------------------------------------- C ISUBN1='DPPP' ISUBN2='C2 ' C C-----START POINT----------------------------------------------------- C ISUBN1='DPPP' ISUBN2='C2 ' IERROR='NO' ICAPSW='OFF' ICAPTY='NULL' C IF(ICASPL.EQ.'PACP' .OR. ICASPL.EQ.'P2CP')THEN IF(KSLOC.EQ.CPUMIN .AND. KSSCAL.EQ.CPUMIN)THEN KSLOC=0.0 KSSCAL=1.0 ENDIF ENDIF AN1=0.0 C IFLAG=0 IF(ICASPL.EQ.'GECP')IFLAG=1 IF(ICASPL.EQ.'BICP')IFLAG=1 IF(ICASPL.EQ.'POCP')IFLAG=1 IF(ICASPL.EQ.'NBCP')IFLAG=1 IF(ICASPL.EQ.'HYCP')IFLAG=1 IF(ICASPL.EQ.'DLCP')IFLAG=1 IF(ICASPL.EQ.'HECP')IFLAG=1 IF(ICASPL.EQ.'YUCP')IFLAG=1 IF(ICASPL.EQ.'WRCP')IFLAG=1 IF(ICASPL.EQ.'BBCP')IFLAG=1 IF(ICASPL.EQ.'PZCP')IFLAG=1 IF(ICASPL.EQ.'BZCP')IFLAG=1 IF(ICASPL.EQ.'BGCP')IFLAG=1 IF(ICASPL.EQ.'ZECP')IFLAG=1 IF(ICASPL.EQ.'ZICP')IFLAG=1 IF(ICASPL.EQ.'BTCP')IFLAG=1 IF(ICASPL.EQ.'LPCP')IFLAG=1 IF(ICASPL.EQ.'AECP')IFLAG=1 IF(ICASPL.EQ.'LOST')IFLAG=1 IF(ICASPL.EQ.'GSCP')IFLAG=1 IF(ICASPL.EQ.'GETC')IFLAG=1 IF(ICASPL.EQ.'QBCP')IFLAG=1 IF(ICASPL.EQ.'CNCP')IFLAG=1 IF(ICASPL.EQ.'KZCP')IFLAG=1 IF(ICASPL.EQ.'DIWP')IFLAG=1 IF(ICASPL.EQ.'GLGP')IFLAG=1 C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PPC2')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11) 11 FORMAT('***** AT THE BEGINNING OF DPPPC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12)ICASPL,IDATSW,N1,NPLOTV 12 FORMAT('ICASPL,IDATSW,N1,NPLOTV = ',A4,2X,A4,2X,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,13)ALAMB1,ALAMB2,NU1,NU2 13 FORMAT('ALAMB1,ALAMB2,NU1,NU2 = ',2E15.7,2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,14)GAMMA1,GAMMA2,P1,P2 14 FORMAT('GAMMA1,GAMMA2,P1,P2 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,15)MINMAX 15 FORMAT('MINMAX = ',I8) CALL DPWRST('XXX','BUG ') IF(N1.GT.0)THEN DO25I=1,MIN(N1,200) WRITE(ICOUT,26)I,Y1(I),X1(I),X1UPP(I),XCENS(I),XREPL(I) 26 FORMAT('I,Y1(I),X1(I),X1UPP(I),XCENS(I),XREPL(I) = ', 1 I8,5E12.5) CALL DPWRST('XXX','BUG ') 25 CONTINUE ENDIF ENDIF C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N1.LE.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46) 46 FORMAT('***** ERROR IN PPCC PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47) 47 FORMAT(' THE NUMBER OF OBSERVATIONS WAS LESS THAN OR ', 1 'EQUAL TO 1.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C IF(IDATSW.EQ.'RAW')THEN HOLD=Y1(1) DO60I=1,N1 IF(Y1(I).NE.HOLD)GOTO69 60 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61) 61 FORMAT('***** ERROR IN PPCC PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' ALL INPUT RESPONSE VARIABLE ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)HOLD 63 FORMAT(' ARE IDENTICALLY EQUAL TO ',G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 69 CONTINUE ELSEIF(IDATSW.EQ.'FREQ')THEN CALL DISTIN(X1,N1,IWRITE,XTEMP6,NDIST,IBUGG3,IERROR) IF(N1.NE.NDIST)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71) 71 FORMAT('***** ERROR IN PPCC PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72) 72 FORMAT(' THE CLASS VARIABLE ELEMENTS ARE NOT ALL ', 1 'DISTINCT.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF DO73I=1,N1-1 IF(X1(I).GE.X1(I+1))THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,74)I 74 FORMAT(' ELEMENT ',I8,' OF THE BIN MID-POINTS ', 1 'VARIABLE IS') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,75)I+1 75 FORMAT(' LARGER THAN ELEMENT ',I8) WRITE(ICOUT,999) IERROR='YES' GOTO9000 ENDIF 73 CONTINUE ELSEIF(IDATSW.EQ.'FRE2')THEN CALL DISTIN(X1,N1,IWRITE,XTEMP6,NDIST,IBUGG3,IERROR) IF(N1.NE.NDIST)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF CALL DISTIN(X1UPP,N1,IWRITE,XTEMP6,NDIST,IBUGG3,IERROR) IF(N1.NE.NDIST)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF DO81I=1,N1 IF(X1(I).GE.X1UPP(I))THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,86) 86 FORMAT('FOR CLASS ',I8,', THE LOWER CLASS LIMIT IS ', 1 'GREATER THAN THE UPPER CLASS LIMIT.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF 81 CONTINUE DO91I=1,N1-1 IF(X1(I).GE.X1(I+1))THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,92)I 92 FORMAT(' ELEMENT ',I8,' OF THE BIN LOWER CLASS ', 1 'LIMITS VARIABLE IS') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,93)I+1 93 FORMAT(' LARGER THAN ELEMENT ',I8) WRITE(ICOUT,999) IERROR='YES' GOTO9000 ENDIF 91 CONTINUE DO96I=1,N1-1 IF(X1UPP(I).GE.X1UPP(I+1))THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,97)I 97 FORMAT(' ELEMENT ',I8,' OF THE BIN UPPER CLASS ', 1 'LIMITS VARIABLE IS') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,98)I+1 98 FORMAT(' LARGER THAN ELEMENT ',I8) WRITE(ICOUT,999) IERROR='YES' GOTO9000 ENDIF 96 CONTINUE ENDIF C C ******************************************** C ** STEP 1B- ** C ** IF SET PPCC DATA POINTS COMMAND WAS ** C ** ENTERED, THIN DATA SET BY COMPUTING ** C ** PERCENTILES OF THE DATA. CURRENTLY ** C ** ONLY SUPPORTED FOR UNBINNED DATA. ** C ******************************************** IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PPC2')THEN WRITE(ICOUT,111)IPPCDP,IDATSW 111 FORMAT(' IPPCDP, IDATSW = ',I8,1X,A4) CALL DPWRST('XXX','BUG ') ENDIF C IF(IPPCDP.GT.0 .AND. IDATSW.EQ.'RAW')THEN NPERC=MAX(20,IPPCDP) NPERC=MIN(NPERC,N1) CALL SORT(Y1,N1,Y2) ASTRT=0.0 ASTOP=100.0 AINC=(ASTOP - ASTRT)/REAL(NPERC+1) IWRITE='OFF' DO110I=1,NPERC P100=ASTRT + REAL(I)*AINC CALL PERCEN(P100,Y2,N1,IWRITE,X2,MAXOBV, 1 XPERC,IBUGG3,IERROR) Y1(I)=XPERC 110 CONTINUE N1=NPERC IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PPC2')THEN WRITE(ICOUT,113)IPPCDP,NPERC,N1 113 FORMAT(' IPPCDP, NPER, N1 = ',3I8) CALL DPWRST('XXX','BUG ') DO117I=1,N1 WRITE(ICOUT,118)I,Y1(I) 118 FORMAT(' I, Y1(I) = ',I8,G15.7) CALL DPWRST('XXX','BUG ') 117 CONTINUE ENDIF ENDIF C C ******************************************************* C ** STEP 2-- ** C ** BRANCH TO THE APPROPRIATE DISTRIBUTIONAL FAMILY ** C ** AND DETERMINE THE SET OF PARAMETER VALUES ** C ** TO BE USED FOR THE PROBABILITY PLOTS ** C ******************************************************* C 500 CONTINUE C NHOR1=IPPCAP(1) NHOR2=IPPCAP(2) C IF(ICASPL.EQ.'LACP')GOTO510 IF(ICASPL.EQ.'TCP')GOTO520 IF(ICASPL.EQ.'CSCP')GOTO530 IF(ICASPL.EQ.'GACP')GOTO540 IF(ICASPL.EQ.'WECP')GOTO550 IF(ICASPL.EQ.'E2CP')GOTO560 IF(ICASPL.EQ.'PACP')GOTO570 IF(ICASPL.EQ.'GECP')GOTO580 IF(ICASPL.EQ.'POCP')GOTO590 IF(ICASPL.EQ.'IGCP')GOTO600 IF(ICASPL.EQ.'WACP')GOTO610 IF(ICASPL.EQ.'RICP')GOTO620 IF(ICASPL.EQ.'FLCP')GOTO630 IF(ICASPL.EQ.'EVCP')GOTO640 IF(ICASPL.EQ.'GPCP')GOTO650 IF(ICASPL.EQ.'LNCP')GOTO660 IF(ICASPL.EQ.'PNCP')GOTO670 IF(ICASPL.EQ.'PLCP')GOTO680 IF(ICASPL.EQ.'PFCP')GOTO690 IF(ICASPL.EQ.'CHCP')GOTO700 IF(ICASPL.EQ.'VMCP')GOTO710 IF(ICASPL.EQ.'LLCP')GOTO720 IF(ICASPL.EQ.'LGCP')GOTO730 IF(ICASPL.EQ.'DWCP')GOTO740 IF(ICASPL.EQ.'GVCP')GOTO750 IF(ICASPL.EQ.'P2CP')GOTO760 IF(ICASPL.EQ.'GZCP')GOTO770 IF(ICASPL.EQ.'WCCP')GOTO780 IF(ICASPL.EQ.'GLCP')GOTO790 IF(ICASPL.EQ.'DGCP')GOTO800 IF(ICASPL.EQ.'BRCP')GOTO810 IF(ICASPL.EQ.'RECP')GOTO820 IF(ICASPL.EQ.'BICP')GOTO830 IF(ICASPL.EQ.'NBCP')GOTO840 IF(ICASPL.EQ.'DLCP')GOTO850 IF(ICASPL.EQ.'GICP')GOTO860 IF(ICASPL.EQ.'LDCP')GOTO870 IF(ICASPL.EQ.'BECP')GOTO880 IF(ICASPL.EQ.'GGCP')GOTO890 IF(ICASPL.EQ.'GOCP')GOTO900 IF(ICASPL.EQ.'PECP')GOTO910 IF(ICASPL.EQ.'EWCP')GOTO920 IF(ICASPL.EQ.'JBCP')GOTO930 IF(ICASPL.EQ.'JUCP')GOTO940 IF(ICASPL.EQ.'IWCP')GOTO950 IF(ICASPL.EQ.'LXCP')GOTO960 IF(ICASPL.EQ.'TRCP')GOTO970 IF(ICASPL.EQ.'EECP')GOTO980 IF(ICASPL.EQ.'ALCP')GOTO11510 IF(ICASPL.EQ.'TSCP')GOTO11520 IF(ICASPL.EQ.'ERCP')GOTO11530 IF(ICASPL.EQ.'FTCP')GOTO11540 IF(ICASPL.EQ.'FCP')GOTO11550 IF(ICASPL.EQ.'SNCP')GOTO11560 IF(ICASPL.EQ.'STCP')GOTO11570 IF(ICASPL.EQ.'IBCP')GOTO11580 IF(ICASPL.EQ.'GHCP')GOTO11590 IF(ICASPL.EQ.'LZCP')GOTO11600 IF(ICASPL.EQ.'NCCP')GOTO11610 IF(ICASPL.EQ.'NTCP')GOTO11620 IF(ICASPL.EQ.'FNCP')GOTO11630 IF(ICASPL.EQ.'FCCP')GOTO11640 IF(ICASPL.EQ.'TECP')GOTO11650 IF(ICASPL.EQ.'BBCP')GOTO11660 IF(ICASPL.EQ.'PZCP')GOTO11670 IF(ICASPL.EQ.'YUCP')GOTO11680 IF(ICASPL.EQ.'WRCP')GOTO11690 IF(ICASPL.EQ.'HECP')GOTO11700 IF(ICASPL.EQ.'SDCP')GOTO11710 IF(ICASPL.EQ.'ADCP')GOTO11720 IF(ICASPL.EQ.'MXCP')GOTO11730 IF(ICASPL.EQ.'GMCP')GOTO11740 IF(ICASPL.EQ.'GALP')GOTO11750 IF(ICASPL.EQ.'MCCP')GOTO11760 IF(ICASPL.EQ.'GMLP')GOTO11770 IF(ICASPL.EQ.'G5CP')GOTO11780 IF(ICASPL.EQ.'BNCP')GOTO11790 IF(ICASPL.EQ.'G2CP')GOTO11800 IF(ICASPL.EQ.'G3CP')GOTO11810 IF(ICASPL.EQ.'G4CP')GOTO11820 IF(ICASPL.EQ.'AXCP')GOTO11830 IF(ICASPL.EQ.'BGCP')GOTO11840 IF(ICASPL.EQ.'ZECP')GOTO11850 IF(ICASPL.EQ.'ZICP')GOTO11850 IF(ICASPL.EQ.'BTCP')GOTO11860 IF(ICASPL.EQ.'LPCP')GOTO11870 IF(ICASPL.EQ.'LBCP')GOTO11880 IF(ICASPL.EQ.'AECP')GOTO11890 IF(ICASPL.EQ.'LOST')GOTO11900 IF(ICASPL.EQ.'GSCP')GOTO11910 IF(ICASPL.EQ.'GETC'.AND.IGETDF.EQ.'THET')GOTO11920 IF(ICASPL.EQ.'GETC'.AND.IGETDF.EQ.'MU ')GOTO11930 IF(ICASPL.EQ.'QBCP')GOTO11940 IF(ICASPL.EQ.'CNCP'.AND.ICONDF.EQ.'THET')GOTO11950 IF(ICASPL.EQ.'CNCP'.AND.ICONDF.EQ.'MU ')GOTO11960 IF(ICASPL.EQ.'KZCP')GOTO11970 IF(ICASPL.EQ.'DIWP')GOTO11980 IF(ICASPL.EQ.'GLGP')GOTO11990 C 510 CONTINUE NUMDIS=41 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO511IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ALAMB1+((AIDIS-1.0)/(ANUMDI-1.0))*(ALAMB2-ALAMB1) 511 CONTINUE GOTO990 C 520 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS CCCCC ANU1=NU1 CCCCC ANU2=NU2 DO521IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ANU1+((AIDIS-1.0)/(ANUMDI-1.0))*(ANU2-ANU1) 521 CONTINUE GOTO990 C 530 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS ANU1=NU1 ANU2=NU2 DO531IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ANU1+((AIDIS-1.0)/(ANUMDI-1.0))*(ANU2-ANU1) 531 CONTINUE GOTO990 C 540 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO541IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=GAMMA1+((AIDIS-1.0)/(ANUMDI-1.0))*(GAMMA2-GAMMA1) 541 CONTINUE GOTO990 C 550 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO551IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=GAMMA1+((AIDIS-1.0)/(ANUMDI-1.0))*(GAMMA2-GAMMA1) 551 CONTINUE GOTO990 C 560 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO561IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=GAMMA1+((AIDIS-1.0)/(ANUMDI-1.0))*(GAMMA2-GAMMA1) 561 CONTINUE GOTO990 C 570 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO571IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=GAMMA1+((AIDIS-1.0)/(ANUMDI-1.0))*(GAMMA2-GAMMA1) 571 CONTINUE GOTO990 C 580 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO581IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=P1+((AIDIS-1.0)/(ANUMDI-1.0))*(P2-P1) 581 CONTINUE GOTO990 C 590 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO591IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ALAMB1+((AIDIS-1.0)/(ANUMDI-1.0))*(ALAMB2-ALAMB1) 591 CONTINUE GOTO990 C 600 CONTINUE NUMDI1=50 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=50 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO606IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=AMU1+((AIDI1-1.0)/(ANMDI1-1.0))*(AMU2-AMU1) DO608IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=GAMMA1+((AIDI2-1.0)/(ANMDI2-1.0))*(GAMMA2-GAMMA1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 608 CONTINUE 606 CONTINUE NUMDIS=ICOUNT GOTO990 C 610 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO611IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=GAMMA1+((AIDIS-1.0)/(ANUMDI-1.0))*(GAMMA2-GAMMA1) 611 CONTINUE GOTO990 C 620 CONTINUE NUMDI1=50 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=50 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO626IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=AMU1+((AIDI1-1.0)/(ANMDI1-1.0))*(AMU2-AMU1) DO628IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=GAMMA1+((AIDI2-1.0)/(ANMDI2-1.0))*(GAMMA2-GAMMA1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 628 CONTINUE 626 CONTINUE NUMDIS=ICOUNT GOTO990 C 630 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO631IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=GAMMA1+((AIDIS-1.0)/(ANUMDI-1.0))*(GAMMA2-GAMMA1) 631 CONTINUE GOTO990 C 640 CONTINUE NUMD1=50 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANUMD1=NUMD1 NUMD2=50 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANUMD2=NUMD2 ICOUNT=0 DO641IDIS=1,NUMD1 AIDI1=IDIS1 A1=GAMMA1+((AIDI1-1.0)/(ANMDI1-1.0))*(GAMMA2-GAMMA1) DO642IDIS2=1,NUMD2 AIDI2=IDIS2 A2=THETA1+((AIDI2-1.0)/(ANMDI2-1.0))*(THETA2-THETA1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 642 CONTINUE 641 CONTINUE NUMDIS=NUMD1+NUMD2 GOTO990 C 650 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO651IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=GAMMA1+((AIDIS-1.0)/(ANUMDI-1.0))*(GAMMA2-GAMMA1) 651 CONTINUE GOTO990 C 660 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO661IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=SIGMA1+((AIDIS-1.0)/(ANUMDI-1.0))*(SIGMA2-SIGMA1) 661 CONTINUE GOTO990 C 670 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO671IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=P1+((AIDIS-1.0)/(ANUMDI-1.0))*(P2-P1) 671 CONTINUE GOTO990 C 680 CONTINUE NUMDI1=50 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=50 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO681IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=SD1+((AIDI1-1.0)/(ANMDI1-1.0))*(SD2-SD1) DO683IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=P1+((AIDI2-1.0)/(ANMDI2-1.0))*(P2-P1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 683 CONTINUE 681 CONTINUE NUMDIS=ICOUNT GOTO990 C 690 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO691IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=C1+((AIDIS-1.0)/(ANUMDI-1.0))*(C2-C1) 691 CONTINUE GOTO990 C 700 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO701IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ANU1+((AIDIS-1.0)/(ANUMDI-1.0))*(ANU2-ANU1) 701 CONTINUE GOTO990 C 710 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO711IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=B1+((AIDIS-1.0)/(ANUMDI-1.0))*(B2-B1) 711 CONTINUE GOTO990 C 720 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO721IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=DELTA1+((AIDIS-1.0)/(ANUMDI-1.0))*(DELTA2-DELTA1) 721 CONTINUE GOTO990 C 730 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO731IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=GAMMA1+((AIDIS-1.0)/(ANUMDI-1.0))*(GAMMA2-GAMMA1) 731 CONTINUE GOTO990 C 740 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO741IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=GAMMA1+((AIDIS-1.0)/(ANUMDI-1.0))*(GAMMA2-GAMMA1) 741 CONTINUE GOTO990 C 750 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO751IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=GAMMA1+((AIDIS-1.0)/(ANUMDI-1.0))*(GAMMA2-GAMMA1) 751 CONTINUE GOTO990 C 760 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO761IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=GAMMA1+((AIDIS-1.0)/(ANUMDI-1.0))*(GAMMA2-GAMMA1) 761 CONTINUE GOTO990 C 770 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO771IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=GAMMA1+((AIDIS-1.0)/(ANUMDI-1.0))*(GAMMA2-GAMMA1) 771 CONTINUE GOTO990 C 780 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO781IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=P1+((AIDIS-1.0)/(ANUMDI-1.0))*(P2-P1) 781 CONTINUE GOTO990 C 790 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO791IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ALPHA1+((AIDIS-1.0)/(ANUMDI-1.0))*(ALPHA2-ALPHA1) 791 CONTINUE GOTO990 C 800 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO801IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=GAMMA1+((AIDIS-1.0)/(ANUMDI-1.0))*(GAMMA2-GAMMA1) 801 CONTINUE GOTO990 C 810 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO811IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=BETA1+((AIDIS-1.0)/(ANUMDI-1.0))*(BETA2-BETA1) 811 CONTINUE GOTO990 C 820 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO821IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=B1+((AIDIS-1.0)/(ANUMDI-1.0))*(B2-B1) 821 CONTINUE GOTO990 C 830 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO831IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=P1+((AIDIS-1.0)/(ANUMDI-1.0))*(P2-P1) 831 CONTINUE GOTO990 C 840 CONTINUE IF(AK1.LT.AK2)THEN NUMDI1=37 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=25 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI2=NUMDI2 ICOUNT=0 DO841IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=P1+((AIDI1-1.0)/(ANMDI1-1.0))*(P2-P1) DO843IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=AK1+((AIDI2-1.0)/(ANMDI2-1.0))*(AK2-AK1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 843 CONTINUE 841 CONTINUE NUMDIS=ICOUNT ELSE ICASPL='NZCP' NUMSHA=1 NUMDI1=25 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANMDI1=NUMDI1 ICOUNT=0 DO846IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=P1+((AIDI1-1.0)/(ANMDI1-1.0))*(P2-P1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 846 CONTINUE NUMDIS=ICOUNT ENDIF GOTO990 C 850 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO851IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=THETA1+((AIDIS-1.0)/(ANUMDI-1.0))*(THETA2-THETA1) 851 CONTINUE GOTO990 C 860 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO861IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=GAMMA1+((AIDIS-1.0)/(ANUMDI-1.0))*(GAMMA2-GAMMA1) 861 CONTINUE GOTO990 C 870 CONTINUE NUMDI1=50 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=50 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO871IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=ALMB31+((AIDI1-1.0)/(ANMDI1-1.0))*(ALMB32-ALMB31) DO873IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=ALMB41+((AIDI2-1.0)/(ANMDI2-1.0))*(ALMB42-ALMB41) IF(IGLDDF.EQ.'RAMB')THEN IWRITE='OFF' CALL GLDCHK(ALAMB3,ALAMB4,ALOWER,AUPPER,IFLAG, 1 ISIGN,IWRITE) IF(IFLAG.EQ.0)THEN ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 ENDIF ELSE ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 ENDIF 873 CONTINUE 871 CONTINUE NUMDIS=ICOUNT GOTO990 C 880 CONTINUE NUMDI1=25 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=25 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO881IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=ALPHA1+((AIDI1-1.0)/(ANMDI1-1.0))*(ALPHA2-ALPHA1) DO883IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=BETA1+((AIDI2-1.0)/(ANMDI2-1.0))*(BETA2-BETA1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 883 CONTINUE 881 CONTINUE NUMDIS=ICOUNT GOTO990 C 890 CONTINUE NUMDI1=25 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANMDI1=NUMDI1 NUMDI2=25 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI2=NUMDI2 ICOUNT=0 DO891IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=C1+((AIDI1-1.0)/(ANMDI1-1.0))*(C2-C1) DO893IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=ALPHA1+((AIDI2-1.0)/(ANMDI2-1.0))*(ALPHA2-ALPHA1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 893 CONTINUE 891 CONTINUE NUMDIS=ICOUNT GOTO990 C 900 CONTINUE NUMDI1=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANMDI1=NUMDI1 NUMDI2=50 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI2=NUMDI2 ICOUNT=0 DO901IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=C1+((AIDI1-1.0)/(ANMDI1-1.0))*(C2-C1) DO903IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=B1+((AIDI2-1.0)/(ANMDI2-1.0))*(B2-B1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 903 CONTINUE 901 CONTINUE NUMDIS=ICOUNT GOTO990 C 910 CONTINUE NUMDI1=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANMDI1=NUMDI1 NUMDI2=50 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO911IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=ALPHA1+((AIDI1-1.0)/(ANMDI1-1.0))*(ALPHA2-ALPHA1) DO913IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=BETA1+((AIDI2-1.0)/(ANMDI2-1.0))*(BETA2-BETA1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 913 CONTINUE 911 CONTINUE NUMDIS=ICOUNT GOTO990 C 920 CONTINUE NUMDI1=50 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=50 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI2=NUMDI2 ICOUNT=0 DO921IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=GAMMA1+((AIDI1-1.0)/(ANMDI1-1.0))*(GAMMA2-GAMMA1) DO923IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=THETA1+((AIDI2-1.0)/(ANMDI2-1.0))*(THETA2-THETA1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 923 CONTINUE 921 CONTINUE NUMDIS=ICOUNT GOTO990 C 930 CONTINUE NUMDI1=50 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=50 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO931IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=ALPH11+((AIDI1-1.0)/(ANMDI1-1.0))*(ALPH12-ALPH11) DO933IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=ALPH21+((AIDI2-1.0)/(ANMDI2-1.0))*(ALPH22-ALPH21) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 933 CONTINUE 931 CONTINUE NUMDIS=ICOUNT GOTO990 C 940 CONTINUE NUMDI1=50 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=50 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO941IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=ALPH11+((AIDI1-1.0)/(ANMDI1-1.0))*(ALPH12-ALPH11) DO943IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=ALPH21+((AIDI2-1.0)/(ANMDI2-1.0))*(ALPH22-ALPH21) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 943 CONTINUE 941 CONTINUE NUMDIS=ICOUNT GOTO990 C 950 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO951IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=GAMMA1+((AIDIS-1.0)/(ANUMDI-1.0))*(GAMMA2-GAMMA1) 951 CONTINUE GOTO990 C 960 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO961IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ALPHA1+((AIDIS-1.0)/(ANUMDI-1.0))*(ALPHA2-ALPHA1) 961 CONTINUE GOTO990 C 970 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO971IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=C1+((AIDIS-1.0)/(ANUMDI-1.0))*(C2-C1) 971 CONTINUE GOTO990 C 980 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO981IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=GAMMA1+((AIDIS-1.0)/(ANUMDI-1.0))*(GAMMA2-GAMMA1) 981 CONTINUE GOTO990 C 11510 CONTINUE NUMDI1=50 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=50 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11511IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=ALPHA1+((AIDI1-1.0)/(ANMDI1-1.0))*(ALPHA2-ALPHA1) DO11513IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=BETA1+((AIDI2-1.0)/(ANMDI2-1.0))*(BETA2-BETA1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11513 CONTINUE 11511 CONTINUE NUMDIS=ICOUNT GOTO990 C 11520 CONTINUE NUMDI1=50 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=50 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11521IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=THETA1+((AIDI1-1.0)/(ANMDI1-1.0))*(THETA2-THETA1) DO11523IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=ANU1+((AIDI2-1.0)/(ANMDI2-1.0))*(ANU2-ANU1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11523 CONTINUE 11521 CONTINUE NUMDIS=ICOUNT GOTO990 C 11530 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO11531IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ALPHA1+((AIDIS-1.0)/(ANUMDI-1.0))*(ALPHA2-ALPHA1) 11531 CONTINUE GOTO990 C 11540 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS NU2=NU1 + NUMDIS - 1 ANU1=REAL(NU1) ANU2=REAL(NU2) DO11541IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ANU1+((AIDIS-1.0)/(ANUMDI-1.0))*(ANU2-ANU1) 11541 CONTINUE GOTO990 C 11550 CONTINUE NUMDI1=NU12 - NU11 + 1 IF(NHOR1.GT.0)NUMDI1=NHOR1 IF(NUMDI1.LT.10)NUMDI1=10 ANMDI1=NUMDI1 NUMDI2=NU22 - NU21 + 1 IF(NHOR2.GT.0)NUMDI2=NHOR2 IF(NUMDI2.LT.10)NUMDI2=10 ANMDI2=NUMDI2 ICOUNT=0 DO11551IDIS1=1,NUMDI1 NTEMP1=NU11 + IDIS1 - 1 DO11553IDIS2=1,NUMDI2 NTEMP2=NU21 + IDIS2 - 1 ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=REAL(NTEMP1) DISPA2(ICOUNT)=REAL(NTEMP2) 11553 CONTINUE 11551 CONTINUE NUMDIS=ICOUNT GOTO990 C 11560 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO11561IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ALAMB1+((AIDIS-1.0)/(ANUMDI-1.0))*(ALAMB2-ALAMB1) 11561 CONTINUE GOTO990 C 11570 CONTINUE NUMDI1=NU2 - NU1 + 1 IF(NHOR1.GT.0)NUMDI1=NHOR1 IF(NUMDI1.LT.10)NUMDI1=10 ANMDI1=NUMDI1 NUMDI2=25 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11571IDIS1=1,NUMDI1 NTEMP1=NU1 + IDIS1 - 1 DO11573IDIS2=1,NUMDI2 AIDIS2=IDIS2 A2=ALAMB1+((AIDIS2-1.0)/(ANMDI2-1.0))*(ALAMB2-ALAMB1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=REAL(NTEMP1) DISPA2(ICOUNT)=A2 11573 CONTINUE 11571 CONTINUE NUMDIS=ICOUNT GOTO990 C 11580 CONTINUE NUMDI1=25 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=25 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11581IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=ALPHA1+((AIDI1-1.0)/(ANMDI1-1.0))*(ALPHA2-ALPHA1) DO11583IDIS2=1,NUMDI2 AIDIS2=IDIS2 ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=BETA1+ 1 ((AIDIS2-1.0)/(ANMDI2-1.0))*(BETA2-BETA1) 11583 CONTINUE 11581 CONTINUE NUMDIS=ICOUNT GOTO990 C 11590 CONTINUE NUMDI1=21 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=41 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11591IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=H1+((AIDI1-1.0)/(ANMDI1-1.0))*(H2-H1) DO11593IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=G1+((AIDI2-1.0)/(ANMDI2-1.0))*(G2-G1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11593 CONTINUE 11591 CONTINUE NUMDIS=ICOUNT GOTO990 C 11600 CONTINUE NUMDI1=25 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=25 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11601IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=SD1+((AIDI1-1.0)/(ANMDI1-1.0))*(SD2-SD1) DO11603IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=ALAMB1+((AIDI2-1.0)/(ANMDI2-1.0))*(ALAMB2-ALAMB1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11603 CONTINUE 11601 CONTINUE NUMDIS=ICOUNT GOTO990 C 11610 CONTINUE C IF(NU1.EQ.NU2)THEN NUMSHA=1 ICASPL='NXCP' NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO11616IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ALAMB1+((AIDIS-1.0)/(ANUMDI-1.0))*(ALAMB2-ALAMB1) 11616 CONTINUE GOTO990 ENDIF C NUMDI1=10 IF(NHOR1.GT.0)NUMDI1=NHOR1 NTEMP=NU2 - NU1 + 1 IF(NTEMP.LE.10)THEN NUMDI1=NU2 - NU1 + 1 AINC=1.0 ELSE AINC=REAL(NU2-NU1+1)/REAL(NUMDI1) IF(AINC.LT.1.0)AINC=1.0 ENDIF ANMDI1=NUMDI1 ANMDI1=NUMDI1 NUMDI2=21 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ANU1=REAL(NU1) ANU2=REAL(NU2) ICOUNT=0 DO11611IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=ANU1+(AIDI1-1.0)*AINC IA1=INT(A1+0.5) A1=REAL(IA1) DO11613IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=ALAMB1+((AIDI2-1.0)/(ANMDI2-1.0))*(ALAMB2-ALAMB1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11613 CONTINUE 11611 CONTINUE NUMDIS=ICOUNT GOTO990 C 11620 CONTINUE C IF(NU1.EQ.NU2)THEN NUMSHA=1 ICASPL='NYCP' NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO11626IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ALAMB1+((AIDIS-1.0)/(ANUMDI-1.0))*(ALAMB2-ALAMB1) 11626 CONTINUE GOTO990 ENDIF C NUMDI1=10 IF(NHOR1.GT.0)NUMDI1=NHOR1 NTEMP=NU2 - NU1 + 1 IF(NTEMP.LE.10)THEN NUMDI1=NU2 - NU1 + 1 AINC=1.0 ELSE AINC=REAL(NU2-NU1+1)/REAL(NUMDI1) IF(AINC.LT.1.0)AINC=1.0 ENDIF ANMDI1=NUMDI1 NUMDI2=21 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ANU1=REAL(NU1) ANU2=REAL(NU2) ICOUNT=0 DO11621IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=ANU1+(AIDI1-1.0)*AINC IA1=INT(A1+0.5) A1=REAL(IA1) DO11623IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=ALAMB1+((AIDI2-1.0)/(ANMDI2-1.0))*(ALAMB2-ALAMB1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11623 CONTINUE 11621 CONTINUE NUMDIS=ICOUNT GOTO990 C 11630 CONTINUE NUMDI1=51 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=51 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11631IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=AMU1+((AIDI1-1.0)/(ANMDI1-1.0))*(AMU2-AMU1) DO11633IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=SD1+((AIDI2-1.0)/(ANMDI2-1.0))*(SD2-SD1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11633 CONTINUE 11631 CONTINUE NUMDIS=ICOUNT GOTO990 C 11640 CONTINUE NUMDI1=51 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=51 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11641IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=AMU1+((AIDI1-1.0)/(ANMDI1-1.0))*(AMU2-AMU1) DO11643IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=SD1+((AIDI2-1.0)/(ANMDI2-1.0))*(SD2-SD1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11643 CONTINUE 11641 CONTINUE NUMDIS=ICOUNT GOTO990 C 11650 CONTINUE IWRITE='OFF' IF(AMU1.EQ.AMU2)THEN NUMSHA=1 ICASPL='TXCP' NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO11656IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=SD1+((AIDIS-1.0)/(ANUMDI-1.0))*(SD2-SD1) 11656 CONTINUE GOTO990 ENDIF C CALL MINIM(X1,N1,IWRITE,XMIN,IBUGG3,IERROR) C IF(AMU2.GE.XMIN)THEN AMU2=XMIN-0.1 IF(AMU1.GE.AMU2)THEN AMU1=AMU2-5.0 IF(AMU1.LT.0.0)AMU1=0.0 ENDIF ENDIF C NUMDI1=21 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=51 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11651IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=AMU1+((AIDI1-1.0)/(ANMDI1-1.0))*(AMU2-AMU1) DO11653IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=SD1+((AIDI2-1.0)/(ANMDI2-1.0))*(SD2-SD1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11653 CONTINUE 11651 CONTINUE NUMDIS=ICOUNT GOTO990 C 11660 CONTINUE NUMDI1=51 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=51 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11661IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=ALPHA1+((AIDI1-1.0)/(ANMDI1-1.0))*(ALPHA2-ALPHA1) DO11663IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=BETA1+((AIDI2-1.0)/(ANMDI2-1.0))*(BETA2-BETA1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11663 CONTINUE 11661 CONTINUE NUMDIS=ICOUNT GOTO990 C 11670 CONTINUE NUMDI1=51 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=51 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11671IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=ALPHA1+((AIDI1-1.0)/(ANMDI1-1.0))*(ALPHA2-ALPHA1) DO11673IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=BETA1+((AIDI2-1.0)/(ANMDI2-1.0))*(BETA2-BETA1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11673 CONTINUE 11671 CONTINUE NUMDIS=ICOUNT GOTO990 C 11680 CONTINUE NUMDIS=25 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO11681IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=P1+((AIDIS-1.0)/(ANUMDI-1.0))*(P2-P1) 11681 CONTINUE GOTO990 C 11690 CONTINUE NUMDI1=50 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=50 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11691IDIS1=1,NUMDI1 AIDI1=IDIS1 AA1=C1+((AIDI1-1.0)/(ANMDI1-1.0))*(C2-C1) DO11693IDIS2=1,NUMDI2 AIDI2=IDIS2 AA2=A1+((AIDI2-1.0)/(ANMDI2-1.0))*(A2-A1) IF(AA1.GT.AA2)THEN ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=AA1 DISPA2(ICOUNT)=AA2 ENDIF 11693 CONTINUE 11691 CONTINUE NUMDIS=ICOUNT GOTO990 C 11700 CONTINUE NUMDI1=51 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=51 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11701IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=ALPHA1+((AIDI1-1.0)/(ANMDI1-1.0))*(ALPHA2-ALPHA1) DO11703IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=BETA1+((AIDI2-1.0)/(ANMDI2-1.0))*(BETA2-BETA1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11703 CONTINUE 11701 CONTINUE NUMDIS=ICOUNT GOTO990 C 11710 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO11711IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ALAMB1+((AIDIS-1.0)/(ANUMDI-1.0))*(ALAMB2-ALAMB1) 11711 CONTINUE GOTO990 C 11720 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS IF(IADEDF.EQ.'K')THEN DO11721IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=AK1+((AIDIS-1.0)/(ANUMDI-1.0))*(AK2-AK1) 11721 CONTINUE ELSE DO11723IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=AMU1+((AIDIS-1.0)/(ANUMDI-1.0))*(AMU2-AMU1) 11723 CONTINUE ENDIF GOTO990 C 11730 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO11731IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=SIGMA1+((AIDIS-1.0)/(ANUMDI-1.0))*(SIGMA2-SIGMA1) 11731 CONTINUE GOTO990 C 11740 CONTINUE NUMDI1=50 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=50 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11741IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=ETA1+((AIDI1-1.0)/(ANMDI1-1.0))*(ETA2-ETA1) DO11743IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=ZETA1+((AIDI2-1.0)/(ANMDI2-1.0))*(ZETA2-ZETA1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11743 CONTINUE 11741 CONTINUE NUMDIS=ICOUNT GOTO990 C 11750 CONTINUE NUMDI1=20 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=20 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11751IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=TAU1+((AIDI1-1.0)/(ANMDI1-1.0))*(TAU2-TAU1) DO11753IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=AK1+((AIDI2-1.0)/(ANMDI2-1.0))*(AK2-AK1) IF(A2.LT.1.0 .AND. TAU.LT.0.7)GOTO11753 ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11753 CONTINUE 11751 CONTINUE NUMDIS=ICOUNT GOTO990 C 11760 CONTINUE NUMDIS=30 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO11761IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ALPHA1+((AIDIS-1.0)/(ANUMDI-1.0))*(ALPHA2-ALPHA1) 11761 CONTINUE GOTO990 C 11770 CONTINUE NUMDI1=17 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=20 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11771IDIS1=1,NUMDI1 AIDI1=IDIS1 A1TEMP=A1+((AIDI1-1.0)/(ANMDI1-1.0))*(A2-A1) DO11773IDIS2=1,NUMDI2 AIDI2=IDIS2 A2TEMP=ALPHA1+((AIDI2-1.0)/(ANMDI2-1.0))*(ALPHA2-ALPHA1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1TEMP DISPA2(ICOUNT)=A2TEMP 11773 CONTINUE 11771 CONTINUE NUMDIS=ICOUNT GOTO990 C 11780 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO11781IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ALPHA1+((AIDIS-1.0)/(ANUMDI-1.0))*(ALPHA2-ALPHA1) 11781 CONTINUE GOTO990 C 11790 CONTINUE NUMDI1=25 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=25 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11791IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=ALPHA1+((AIDI1-1.0)/(ANMDI1-1.0))*(ALPHA2-ALPHA1) DO11793IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=BETA1+((AIDI2-1.0)/(ANMDI2-1.0))*(BETA2-BETA1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11793 CONTINUE 11791 CONTINUE NUMDIS=ICOUNT GOTO990 C 11800 CONTINUE NUMDIS=50 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO11801IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ALPHA1+((AIDIS-1.0)/(ANUMDI-1.0))*(ALPHA2-ALPHA1) 11801 CONTINUE GOTO990 C 11810 CONTINUE NUMDIS=30 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO11811IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ALPHA1+((AIDIS-1.0)/(ANUMDI-1.0))*(ALPHA2-ALPHA1) 11811 CONTINUE GOTO990 C 11820 CONTINUE NUMDI1=15 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=15 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11821IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=P1+((AIDI1-1.0)/(ANMDI1-1.0))*(P2-P1) DO11823IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=Q1+((AIDI2-1.0)/(ANMDI2-1.0))*(Q2-Q1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11823 CONTINUE 11821 CONTINUE NUMDIS=ICOUNT GOTO990 C 11830 CONTINUE NUMDI1=50 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=50 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11831IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=ALPHA1+((AIDI1-1.0)/(ANMDI1-1.0))*(ALPHA2-ALPHA1) DO11833IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=BETA1+((AIDI2-1.0)/(ANMDI2-1.0))*(BETA2-BETA1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11833 CONTINUE 11831 CONTINUE NUMDIS=ICOUNT GOTO990 C 11840 CONTINUE NUMDI1=51 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=51 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11841IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=ALPHA1+((AIDI1-1.0)/(ANMDI1-1.0))*(ALPHA2-ALPHA1) DO11843IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=BETA1+((AIDI2-1.0)/(ANMDI2-1.0))*(BETA2-BETA1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11843 CONTINUE 11841 CONTINUE NUMDIS=ICOUNT GOTO990 C 11850 CONTINUE NUMDIS=30 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO11851IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ALPHA1+((AIDIS-1.0)/(ANUMDI-1.0))*(ALPHA2-ALPHA1) 11851 CONTINUE GOTO990 C 11860 CONTINUE NUMDIS=30 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO11861IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ALAMB1+((AIDIS-1.0)/(ANUMDI-1.0))*(ALAMB2-ALAMB1) 11861 CONTINUE GOTO990 C 11870 CONTINUE NUMDI1=31 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=31 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11871IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=ALAMB1+((AIDI1-1.0)/(ANMDI1-1.0))*(ALAMB2-ALAMB1) DO11873IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=THETA1+((AIDI2-1.0)/(ANMDI2-1.0))*(THETA2-THETA1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11873 CONTINUE 11871 CONTINUE NUMDIS=ICOUNT GOTO990 C 11880 CONTINUE NUMDI1=25 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=25 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11881IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=ALPHA1+((AIDI1-1.0)/(ANMDI1-1.0))*(ALPHA2-ALPHA1) DO11883IDIS2=1,NUMDI2 AIDIS2=IDIS2 ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=BETA1+ 1 ((AIDIS2-1.0)/(ANMDI2-1.0))*(BETA2-BETA1) 11883 CONTINUE 11881 CONTINUE NUMDIS=ICOUNT GOTO990 C 11890 CONTINUE NUMDI1=25 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=18 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11891IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=THETA1+((AIDI1-1.0)/(ANMDI1-1.0))*(THETA2-THETA1) DO11893IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=P1+((AIDI2-1.0)/(ANMDI2-1.0))*(P2-P1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11893 CONTINUE 11891 CONTINUE NUMDIS=ICOUNT GOTO990 C 11900 CONTINUE NUMDIS=45 IF(NHOR1.GT.0)NUMDIS=NHOR1 ANUMDI=NUMDIS DO11901IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=P1+((AIDIS-1.0)/(ANUMDI-1.0))*(P2-P1) 11901 CONTINUE GOTO990 C CCCCC NOTE: FOR GENERALIZED LOGARITHMIC SERIES, 1 < BETA < 1/THETA. CCCCC SO SET RANGE FOR BETA DEPENDENT ON THETA. C 11910 CONTINUE NUMDI1=25 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=20 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11911IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=THETA1+((AIDI1-1.0)/(ANMDI1-1.0))*(THETA2-THETA1) BETA1Z=BETA1 BETA2Z=BETA2 ZMAXBE=1.0/A1 IF(BETA1Z.GE.ZMAXBE)BETA1Z=1.0 + (ZMAXBE-1.0)/20.0 IF(BETA2Z.GE.ZMAXBE)BETA2Z=1.0 + 19.0*(ZMAXBE-1.0)/20.0 DO11913IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=BETA1Z+((AIDI2-1.0)/(ANMDI2-1.0))*(BETA2Z-BETA1Z) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11913 CONTINUE 11911 CONTINUE NUMDIS=ICOUNT GOTO990 C CCCCC NOTE: FOR GEETA, 1 < BETA < 1/THETA FOR THE THETA CCCCC PARAMETERIZATION. CCCCC SO SET RANGE FOR BETA DEPENDENT ON THETA. C 11920 CONTINUE NUMDI1=25 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=20 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11921IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=THETA1+((AIDI1-1.0)/(ANMDI1-1.0))*(THETA2-THETA1) BETA1Z=BETA1 BETA2Z=BETA2 ZMAXBE=1.0/A1 IF(BETA1Z.GE.ZMAXBE)BETA1Z=1.0 + (ZMAXBE-1.0)/20.0 IF(BETA2Z.GE.ZMAXBE)BETA2Z=1.0 + 19.0*(ZMAXBE-1.0)/20.0 DO11923IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=BETA1Z+((AIDI2-1.0)/(ANMDI2-1.0))*(BETA2Z-BETA1Z) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11923 CONTINUE 11921 CONTINUE NUMDIS=ICOUNT GOTO990 C CCCCC NOTE: FOR GEETA USING MU PARAMETERIZATION, THERE IS NO CCCCC UPPER LIMIT ON BETA. C 11930 CONTINUE NUMDI1=25 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=25 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11931IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=AMU1+((AIDI1-1.0)/(ANMDI1-1.0))*(AMU2-AMU1) DO11933IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=BETA1+((AIDI2-1.0)/(ANMDI2-1.0))*(BETA2-BETA1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11933 CONTINUE 11931 CONTINUE NUMDIS=ICOUNT GOTO990 C CCCCC NOTE: FOR QUASI BINOMIAL TYPE 1, -P/M < PHI < (1-P)/M CCCCC SO SET RANGE FOR PHI DEPENDENT ON P. C 11940 CONTINUE NUMDI1=19 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=20 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11941IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=P1+((AIDI1-1.0)/(ANMDI1-1.0))*(P2-P1) ZMINPH=-A1/AM ZMAXPH=(1.0-A1)/AM AINC=(ZMAXPH-ZMINPH)/REAL(NUMDI2) ZMINPH=ZMINPH + AINC ZMAXPH=ZMAXPH - AINC PHI1Z=PHI1 PHI2Z=PHI2 IF(PHI1Z.LT.ZMINPH)PHI1Z=ZMINPH IF(PHI2Z.GT.ZMAXPH)PHI2Z=ZMAXPH DO11943IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=PHI1Z+((AIDI2-1.0)/(ANMDI2-1.0))*(PHI2Z-PHI1Z) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11943 CONTINUE 11941 CONTINUE NUMDIS=ICOUNT GOTO990 C CCCCC NOTE: FOR CONSUL, 1 <= M <= 1/THETA FOR THE THETA CCCCC PARAMETERIZATION. CCCCC SO SET RANGE FOR M DEPENDENT ON THETA. C 11950 CONTINUE NUMDI1=25 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=20 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11951IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=THETA1+((AIDI1-1.0)/(ANMDI1-1.0))*(THETA2-THETA1) AM1Z=AM1 AM2Z=AM2 ZMAXAM=1.0/A1 IF(AM1Z.GE.ZMAXAM)AM1Z=1.0 + (ZMAXAM-1.0)/20.0 IF(AM2Z.GE.ZMAXAM)AM2Z=1.0 + 19.0*(ZMAXAM-1.0)/20.0 DO11953IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=AM1Z+((AIDI2-1.0)/(ANMDI2-1.0))*(AM2Z-AM1Z) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11953 CONTINUE 11951 CONTINUE NUMDIS=ICOUNT GOTO990 C CCCCC NOTE: FOR CONSUL USING MU PARAMETERIZATION, THERE IS NO CCCCC UPPER LIMIT ON BETA. C 11960 CONTINUE NUMDI1=25 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=25 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11961IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=AMU1+((AIDI1-1.0)/(ANMDI1-1.0))*(AMU2-AMU1) DO11963IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=AM1+((AIDI2-1.0)/(ANMDI2-1.0))*(AM2-AM1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11963 CONTINUE 11961 CONTINUE NUMDIS=ICOUNT GOTO990 C 11970 CONTINUE NUMDI1=25 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=25 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11971IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=ALPHA1+((AIDI1-1.0)/(ANMDI1-1.0))*(ALPHA2-ALPHA1) DO11973IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=BETA1+((AIDI2-1.0)/(ANMDI2-1.0))*(BETA2-BETA1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11973 CONTINUE 11971 CONTINUE NUMDIS=ICOUNT GOTO990 C 11980 CONTINUE NUMDI1=21 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=25 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11981IDIS1=1,NUMDI1 AIDI1=IDIS1 A1=P1+((AIDI1-1.0)/(ANMDI1-1.0))*(P2-P1) DO11983IDIS2=1,NUMDI2 AIDI2=IDIS2 A2=BETA1+((AIDI2-1.0)/(ANMDI2-1.0))*(BETA2-BETA1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=A1 DISPA2(ICOUNT)=A2 11983 CONTINUE 11981 CONTINUE NUMDIS=ICOUNT GOTO990 C 11990 CONTINUE NUMDI1=21 IF(NHOR1.GT.0)NUMDI1=NHOR1 ANMDI1=NUMDI1 NUMDI2=25 IF(NHOR2.GT.0)NUMDI2=NHOR2 ANMDI2=NUMDI2 ICOUNT=0 DO11991IDIS1=1,NUMDI1 AIDI1=IDIS1 Z1=P1+((AIDI1-1.0)/(ANMDI1-1.0))*(P2-P1) DO11993IDIS2=1,NUMDI2 AIDI2=IDIS2 Z2=A1+((AIDI2-1.0)/(ANMDI2-1.0))*(A2-A1) ICOUNT=ICOUNT+1 DISPAR(ICOUNT)=Z1 DISPA2(ICOUNT)=Z2 11993 CONTINUE 11991 CONTINUE NUMDIS=ICOUNT GOTO990 C 990 CONTINUE C C ************************************** C ** STEP 4-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ** AND DETERMINE PLOT COORDINATES ** C ************************************** C IF(IDATSW.EQ.'RAW')GOTO1100 IF(IDATSW.EQ.'FREQ' .OR. IDATSW.EQ.'FRE2')GOTO2100 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011) 1011 FORMAT('***** INTERNAL ERROR IN DPPPC2 AT BRANCH POINT 1011--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1012) 1012 FORMAT(' IDATSW SHOULD BE EITHER RAW OR FREQ, BUT ', 1 'NEITHER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1014)IDATSW 1014 FORMAT(' IDATSW = ',A4) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C C **************************************** C ** STEP 4.1-- ** C ** DETERMINE PLOT COORDINATES ** C ** FOR THE 1-VARIABLE CASE ** C ** (THAT IS, FOR THE RAW DATA CASE) ** C **************************************** C 1100 CONTINUE C AMIN=CPUMIN AMAX=CPUMAX C CCCCC OCTOBER 2004. FOR CENSORED CASE, CHECK THAT SECOND VARIABLE CCCCC CONTAINS TWO DISTINCT VALUES, SET TO 1 AND 0. CCCCC APRIL 2005. CENSORING VARIABLE NOW IN XCENS. CCCCC APRIL 2005. ADD SUPPORT FOR REPLICATION. C IF(ICENSO.EQ.'ON')THEN CALL DISTIN(XCENS,N1,IWRITE,X2,NDIST,IBUGG3,IERROR) IF(NDIST.EQ.1)THEN DO11102I=1,N1 XCENS(I)=1.0 11102 CONTINUE ELSEIF(NDIST.EQ.2)THEN IF(X2(1).EQ.1.0 .OR. X2(2).EQ.1.0)THEN DO11103I=1,N1 IF(XCENS(I).NE.1.0)XCENS(I)=0.0 11103 CONTINUE ELSE ATEMP1=MIN(X2(1),X2(2)) ATEMP2=MAX(X2(1),X2(2)) DO11108I=1,N1 IF(XCENS(I).EQ.ATEMP1)XCENS(I)=1.0 IF(XCENS(I).EQ.ATEMP2)XCENS(I)=0.0 11108 CONTINUE ENDIF ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11104) 11104 FORMAT('***** ERROR IN PPCC PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11105) 11105 FORMAT(' FOR CENSORED DATA, THE CENSORING VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11106) 11106 FORMAT(' SHOULD CONTAIN AT MOST TWO DISTINCT VALUES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11107)NDIST 11107 FORMAT(' ',I8,' DISTINCT VALUES FOUND.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF CALL SORTC(Y1,XCENS,N1,Y2,XCENS) CALL UNIME3(N1,D2,XCENS,IMETHD) ELSE CALL SORT(Y1,N1,Y2) CALL UNIMED(N1,D2) ENDIF C IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PPC2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11201) 11201 FORMAT('AFTER UNIMED ROUTINE--') CALL DPWRST('XXX','BUG ') DO11203II=1,N1 WRITE(ICOUT,11204) 11204 FORMAT('I,Y1(I),D2(I)=',I8,2G15.7) CALL DPWRST('XXX','BUG ') 11203 CONTINUE ENDIF C IOUNI1=IST1NU IFILE1=IST1NA ISTAT1=IST1ST IFORM1=IST1FO IACCE1=IST1AC IPROT1=IST1PR ICURS1=IST1CS ISUBN0='PPC2' IERRF1='NO' C IREWI1='ON' CALL DPOPFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1 IREWI1,ISUBN0,IERRF1,IBUGG3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C CCCCC OCTOBER 2004: WRITE PPCC VALUE, LOCATION, SCALE, SHAPE 1, CCCCC SHAPE2 TO FILE DPST2F.DAT. C IOUNI2=IST2NU IFILE2=IST2NA ISTAT2=IST2ST IFORM2=IST2FO IACCE2=IST2AC IPROT2=IST2PR ICURS2=IST2CS ISUBN0='PPC2' IERRF2='NO' C IREWI2='ON' CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1 IREWI2,ISUBN0,IERRF2,IBUGG3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C IOUNI3=IST3NU IFILE3=IST3NA ISTAT3=IST3ST IFORM3=IST3FO IACCE3=IST3AC IPROT3=IST3PR ICURS3=IST3CS ISUBN0='PPC2' IERRF3='NO' C IREWI3='ON' CALL DPOPFI(IOUNI3,IFILE3,ISTAT3,IFORM3,IACCE3,IPROT3,ICURS3, 1 IREWI3,ISUBN0,IERRF3,IBUGG3,ISUBRO,IERROR) IF(IERRF3.EQ.'YES')GOTO9000 C C START REPLICATION LOOP C IF(IREPL.EQ.'OFF')THEN NREPL=1 ELSE DO51010I=1,N1 XTEMP6(I)=Y1(I) 51010 CONTINUE CALL DISTIN(XREPL,N1,IWRITE,XREPDS,NREPL,IBUGG3,IERROR) NREPL=NREPL+1 ENDIF C N1SAVE=N1 ICNTPT=0 DO52000IIREPL=1,NREPL C N1=N1SAVE SHAPMX=CPUMIN PPCCMX=CPUMIN C IF(IIREPL.GT.1)THEN REPTMP=XREPDS(IIREPL-1) NTEMP=0 DO52100II=1,N1 IF(XREPL(II).EQ.REPTMP)THEN NTEMP=NTEMP+1 Y1(NTEMP)=XTEMP6(II) X1(NTEMP)=XCENS(II) ENDIF 52100 CONTINUE N1=NTEMP IF(ICENSO.EQ.'ON')THEN CALL SORTC(Y1,XCENS,N1,Y2,XCENS) CALL UNIME3(N1,D2,XCENS,IMETHD) ELSE CALL SORT(Y1,N1,Y2) CALL UNIMED(N1,D2) ENDIF IF(N1.LE.1)THEN WRITE(ICOUT,52104) 52104 FORMAT('***** WARNING IN PPCC PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52105) 52105 FORMAT(' REPLICATION ',I8,' CONTAINS FEWER THAN ', 1 'TWO ELEMENTS AND WILL BE SKIPPED.') GOTO52000 ENDIF ELSE DO52210II=1,N1 X1(II)=XCENS(II) 52210 CONTINUE ENDIF C IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PPC2')THEN WRITE(ICOUT,52204)IREPL,N1 52204 FORMAT('IREPL,N1 = ',2I8) CALL DPWRST('XXX','BUG ') DO52206II=1,N1 WRITE(ICOUT,52207)II,X1(II),Y2(II),D2(II) 52207 FORMAT('II,X1(II),Y2(II),D2(I)) = ',I8,3G15.7) CALL DPWRST('XXX','BUG ') 52206 CONTINUE ENDIF C C COMPUTE SOME VALUES THAT ARE NEEDED BY A FEW DISTRIBUTIONS. C XMIN=Y2(1) XMAX=Y2(N1) IF(MOD(N1,2).EQ.1)THEN XMED=Y2((N1/2)+1) ELSE XMED=(Y2(N1/2)+Y2((N1/2)+1))/2.0 ENDIF DO1105IDIS=1,NUMDIS C ICNT=0 C IF(ICASPL.EQ.'LACP')GOTO1110 IF(ICASPL.EQ.'TCP')GOTO1120 IF(ICASPL.EQ.'CSCP')GOTO1130 IF(ICASPL.EQ.'GACP')GOTO1140 IF(ICASPL.EQ.'WECP')GOTO1150 IF(ICASPL.EQ.'E2CP')GOTO1160 IF(ICASPL.EQ.'PACP')GOTO1170 IF(ICASPL.EQ.'GECP')GOTO1180 IF(ICASPL.EQ.'POCP')GOTO1190 IF(ICASPL.EQ.'IGCP')GOTO1200 IF(ICASPL.EQ.'WACP')GOTO1210 IF(ICASPL.EQ.'RICP')GOTO1220 IF(ICASPL.EQ.'FLCP')GOTO1230 IF(ICASPL.EQ.'EVCP')GOTO1240 IF(ICASPL.EQ.'GPCP')GOTO1250 IF(ICASPL.EQ.'LNCP')GOTO1260 IF(ICASPL.EQ.'PNCP')GOTO1270 IF(ICASPL.EQ.'PLCP')GOTO1280 IF(ICASPL.EQ.'PFCP')GOTO1290 IF(ICASPL.EQ.'CHCP')GOTO1300 IF(ICASPL.EQ.'VMCP')GOTO1310 IF(ICASPL.EQ.'LLCP')GOTO1320 IF(ICASPL.EQ.'LGCP')GOTO1330 IF(ICASPL.EQ.'DWCP')GOTO1340 IF(ICASPL.EQ.'GVCP')GOTO1350 IF(ICASPL.EQ.'P2CP')GOTO1360 IF(ICASPL.EQ.'GZCP')GOTO1370 IF(ICASPL.EQ.'WCCP')GOTO1380 IF(ICASPL.EQ.'GLCP')GOTO1390 IF(ICASPL.EQ.'DGCP')GOTO1400 IF(ICASPL.EQ.'BRCP')GOTO1410 IF(ICASPL.EQ.'RECP')GOTO1420 IF(ICASPL.EQ.'BICP')GOTO1430 IF(ICASPL.EQ.'NBCP')GOTO1440 IF(ICASPL.EQ.'NZCP')GOTO1440 IF(ICASPL.EQ.'DLCP')GOTO1450 IF(ICASPL.EQ.'GICP')GOTO1460 IF(ICASPL.EQ.'LDCP')GOTO1470 IF(ICASPL.EQ.'BECP')GOTO1480 IF(ICASPL.EQ.'GGCP')GOTO1490 IF(ICASPL.EQ.'GOCP')GOTO1500 IF(ICASPL.EQ.'PECP')GOTO1510 IF(ICASPL.EQ.'EWCP')GOTO1520 IF(ICASPL.EQ.'JBCP')GOTO1530 IF(ICASPL.EQ.'JUCP')GOTO1540 IF(ICASPL.EQ.'IWCP')GOTO1550 IF(ICASPL.EQ.'LXCP')GOTO1560 IF(ICASPL.EQ.'TRCP')GOTO1570 IF(ICASPL.EQ.'EECP')GOTO1580 IF(ICASPL.EQ.'ALCP')GOTO1590 IF(ICASPL.EQ.'TSCP')GOTO1600 IF(ICASPL.EQ.'ERCP')GOTO1610 IF(ICASPL.EQ.'FTCP')GOTO1620 IF(ICASPL.EQ.'FCP')GOTO1630 IF(ICASPL.EQ.'SNCP')GOTO1640 IF(ICASPL.EQ.'STCP')GOTO1650 IF(ICASPL.EQ.'IBCP')GOTO1660 IF(ICASPL.EQ.'GHCP')GOTO1670 IF(ICASPL.EQ.'LZCP')GOTO1680 IF(ICASPL.EQ.'NCCP')GOTO1690 IF(ICASPL.EQ.'NXCP')GOTO1695 IF(ICASPL.EQ.'NTCP')GOTO1700 IF(ICASPL.EQ.'NYCP')GOTO1705 IF(ICASPL.EQ.'FNCP')GOTO1710 IF(ICASPL.EQ.'FCCP')GOTO1720 IF(ICASPL.EQ.'TECP')GOTO1730 IF(ICASPL.EQ.'TXCP')GOTO1730 IF(ICASPL.EQ.'BBCP')GOTO1740 IF(ICASPL.EQ.'PZCP')GOTO1750 IF(ICASPL.EQ.'YUCP')GOTO1760 IF(ICASPL.EQ.'WRCP')GOTO1770 IF(ICASPL.EQ.'HECP')GOTO1780 IF(ICASPL.EQ.'SDCP')GOTO1790 IF(ICASPL.EQ.'ADCP')GOTO12800 IF(ICASPL.EQ.'MXCP')GOTO12810 IF(ICASPL.EQ.'GMCP')GOTO12820 IF(ICASPL.EQ.'GALP')GOTO12830 IF(ICASPL.EQ.'MCCP')GOTO12840 IF(ICASPL.EQ.'GMLP')GOTO12850 IF(ICASPL.EQ.'G5CP')GOTO12860 IF(ICASPL.EQ.'BNCP')GOTO12870 IF(ICASPL.EQ.'G2CP')GOTO12880 IF(ICASPL.EQ.'G3CP')GOTO12890 IF(ICASPL.EQ.'G4CP')GOTO12900 IF(ICASPL.EQ.'AXCP')GOTO12910 IF(ICASPL.EQ.'BGCP')GOTO12920 IF(ICASPL.EQ.'ZECP')GOTO12930 IF(ICASPL.EQ.'ZICP')GOTO12940 IF(ICASPL.EQ.'BTCP')GOTO12950 IF(ICASPL.EQ.'LPCP')GOTO12960 IF(ICASPL.EQ.'LBCP')GOTO12970 IF(ICASPL.EQ.'AECP')GOTO12980 IF(ICASPL.EQ.'LOST')GOTO12990 IF(ICASPL.EQ.'GSCP')GOTO13000 IF(ICASPL.EQ.'GETC')GOTO13010 IF(ICASPL.EQ.'QBCP')GOTO13020 IF(ICASPL.EQ.'CNCP')GOTO13030 IF(ICASPL.EQ.'KZCP')GOTO13040 IF(ICASPL.EQ.'DIWP')GOTO13050 IF(ICASPL.EQ.'GLGP')GOTO13060 C 1110 CONTINUE ALAMBA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN IF(ALAMBA.GT.0.0)THEN AMAX=ABS(1.0/ALAMBA) AMIN=-AMAX ELSE AMIN=CPUMIN AMAX=CPUMAX ENDIF IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1111I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1111 ICNT=ICNT+1 CALL LAMPPF(D2(I),ALAMBA,X2(ICNT)) Y3(ICNT)=Y2(I) 1111 CONTINUE GOTO1800 C 1120 CONTINUE CCCCC NU=DISPAR(IDIS)+0.5 ANU=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1121I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1121 ICNT=ICNT+1 CCCCC CALL TPPF(D2(I),NU,X2(ICNT)) CALL TPPF(D2(I),ANU,X2(ICNT)) Y3(ICNT)=Y2(I) 1121 CONTINUE GOTO1800 C 1130 CONTINUE NU=DISPAR(IDIS)+0.5 C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1131I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1131 ICNT=ICNT+1 CALL CHSPPF(D2(I),NU,X2(ICNT)) Y3(ICNT)=Y2(I) 1131 CONTINUE GOTO1800 C 1140 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1141I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1141 ICNT=ICNT+1 CALL GAMPPF(D2(I),GAMMA,X2(ICNT)) Y3(ICNT)=Y2(I) 1141 CONTINUE GOTO1800 C 1150 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN IF(MINMAX.EQ.1)THEN AMIN=0.0 AMAX=CPUMAX ELSE AMIN=CPUMIN AMAX=0.0 ENDIF IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1151I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1151 ICNT=ICNT+1 CALL WEIPPF(D2(I),GAMMA,MINMAX,X2(ICNT)) Y3(ICNT)=Y2(I) 1151 CONTINUE GOTO1800 C 1160 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN IF(MINMAX.EQ.1)THEN AMIN=CPUMIN AMAX=0.0 ELSE AMIN=0.0 AMAX=CPUMAX ENDIF IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1161I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1161 ICNT=ICNT+1 CALL EV2PPF(D2(I),GAMMA,MINMAX,X2(ICNT)) Y3(ICNT)=Y2(I) 1161 CONTINUE GOTO1800 C 1170 CONTINUE A=A1 IF(A.GT.XMIN)A=XMIN GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=A AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1171I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1171 ICNT=ICNT+1 CALL PARPPF(D2(I),GAMMA,A,X2(ICNT)) Y3(ICNT)=Y2(I) 1171 CONTINUE GOTO1800 C 1180 CONTINUE P=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO1181I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1181 ICNT=ICNT+1 CALL GEOPPF(D2(I),P,X2(ICNT)) Y3(ICNT)=Y2(I) 1181 CONTINUE GOTO1800 C 1190 CONTINUE ALAMBA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO1191I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1191 ICNT=ICNT+1 CALL POIPPF(D2(I),ALAMBA,X2(ICNT)) Y3(ICNT)=Y2(I) 1191 CONTINUE GOTO1800 C 1200 CONTINUE AMU=DISPAR(IDIS) GAMMA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1206I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1206 ICNT=ICNT+1 CALL IGPPF(D2(I),GAMMA,AMU,X2(ICNT)) Y3(ICNT)=Y2(I) 1206 CONTINUE GOTO1800 C 1210 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1211I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1211 ICNT=ICNT+1 CALL WALPPF(D2(I),GAMMA,X2(ICNT)) Y3(ICNT)=Y2(I) 1211 CONTINUE GOTO1800 C 1220 CONTINUE IF(NUMSHA.EQ.1)THEN GAMMA=DISPA2(IDIS) AMU=1.0 C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1221I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1221 ICNT=ICNT+1 CALL RIGPPF(D2(I),GAMMA,AMU,X2(ICNT)) Y3(ICNT)=Y2(I) 1221 CONTINUE ELSE GAMMA=DISPA2(IDIS) AMU=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1226I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1226 ICNT=ICNT+1 CALL RIGPPF(D2(I),GAMMA,AMU,X2(ICNT)) Y3(ICNT)=Y2(I) 1226 CONTINUE ENDIF GOTO1800 C 1230 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1231I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1231 ICNT=ICNT+1 CALL FLPPF(D2(I),GAMMA,X2(ICNT)) Y3(ICNT)=Y2(I) 1231 CONTINUE GOTO1800 C 1240 CONTINUE IF(1.LE.IDIS.AND.IDIS.LE.NUMD1)THEN GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1243 ENDIF C DO1241I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1241 ICNT=ICNT+1 CALL EV2PPF(D2(I),GAMMA,MINMAX,X2(ICNT)) Y3(ICNT)=Y2(I) 1241 CONTINUE GOTO1800 ENDIF 1243 CONTINUE IF(NUMD1+1.LE.IDIS.AND.IDIS.LE.NUMDIS)THEN GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1242I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1242 ICNT=ICNT+1 CALL WEIPPF(D2(I),GAMMA,MINMAX,X2(ICNT)) Y3(ICNT)=Y2(I) 1242 CONTINUE GOTO1800 ENDIF C 1250 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN IF(IGEPDF.EQ.'JOHN')THEN IF(GAMMA.LE.0.0)THEN AMIN=0.0 AMAX=CPUMAX ELSE AMIN=0.0 AMAX=(1.0/GAMMA) ENDIF ELSE IF(GAMMA.GE.0.0)THEN AMIN=0.0 AMAX=CPUMAX ELSE AMIN=0.0 AMAX=-(1.0/GAMMA) ENDIF ENDIF IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1251I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1251 ICNT=ICNT+1 CALL GEPPPF(D2(I),GAMMA,MINMAX,IGEPDF,X2(ICNT)) Y3(ICNT)=Y2(I) 1251 CONTINUE GOTO1800 C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1995 1260 CONTINUE SIGMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1261I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1261 ICNT=ICNT+1 CALL LGNPPF(D2(I),SIGMA,X2(ICNT)) Y3(ICNT)=Y2(I) 1261 CONTINUE GOTO1800 C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1995 1270 CONTINUE P=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1271I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1271 ICNT=ICNT+1 CALL PNRPPF(D2(I),P,SD,X2(ICNT)) Y3(ICNT)=Y2(I) 1271 CONTINUE GOTO1800 C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1995 1280 CONTINUE P=DISPAR(IDIS) SD=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1281I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1281 ICNT=ICNT+1 CALL PLNPPF(D2(I),P,SD,X2(ICNT)) Y3(ICNT)=Y2(I) 1281 CONTINUE GOTO1800 C 1290 CONTINUE C=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=1.0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1291I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1291 ICNT=ICNT+1 CALL POWPPF(D2(I),C,X2(ICNT)) Y3(ICNT)=Y2(I) 1291 CONTINUE GOTO1800 C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1995 1300 CONTINUE ANU=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1301I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1301 ICNT=ICNT+1 CALL CHPPF(D2(I),ANU,X2(ICNT)) Y3(ICNT)=Y2(I) 1301 CONTINUE GOTO1800 C 1310 CONTINUE B=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=-PI AMAX=PI IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1311I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1311 ICNT=ICNT+1 CALL VONPPF(D2(I),B,X2(ICNT)) Y3(ICNT)=Y2(I) 1311 CONTINUE GOTO1800 C 1320 CONTINUE DELTA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1321I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1321 ICNT=ICNT+1 CALL LLGPPF(D2(I),DELTA,X2(ICNT)) Y3(ICNT)=Y2(I) 1321 CONTINUE GOTO1800 C CCCCC THE FOLLOWING SECTION WAS ADDED OCTOBER 1995 1330 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1331I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1331 ICNT=ICNT+1 CALL LGAPPF(D2(I),GAMMA,ILGADF,X2(ICNT)) Y3(ICNT)=Y2(I) 1331 CONTINUE GOTO1800 C 1340 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1341I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1341 ICNT=ICNT+1 CALL DWEPPF(D2(I),GAMMA,X2(ICNT)) Y3(ICNT)=Y2(I) 1341 CONTINUE GOTO1800 C 1350 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN IF(GAMMA.GT.0.0)THEN AMIN=CPUMIN AMAX=(1.0/GAMMA) - 0.1E-6 ELSE AMIN=(1.0/GAMMA) + 0.1E-6 AMAX=CPUMAX ENDIF ELSE IF(GAMMA.GT.0.0)THEN AMIN=(-1.0/GAMMA) + 0.1E-6 AMAX=CPUMAX ELSE AMIN=CPUMIN AMAX=(-1.0/GAMMA) - 0.1E-6 ENDIF ENDIF IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1351I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1351 ICNT=ICNT+1 CALL GEVPPF(D2(I),GAMMA,MINMAX,X2(ICNT)) Y3(ICNT)=Y2(I) 1351 CONTINUE GOTO1800 C 1360 CONTINUE A=A1 IF(A.LE.0.0)A=1.0 GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1361I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1361 ICNT=ICNT+1 CALL PA2PPF(D2(I),GAMMA,A,X2(ICNT)) Y3(ICNT)=Y2(I) 1361 CONTINUE GOTO1800 C 1370 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=1.0/GAMMA IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1371I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1371 ICNT=ICNT+1 CALL HFLPPF(D2(I),GAMMA,X2(ICNT)) Y3(ICNT)=Y2(I) 1371 CONTINUE GOTO1800 C 1380 CONTINUE P=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=2.0*PI IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1381I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1381 ICNT=ICNT+1 CALL WCAPPF(D2(I),P,X2(ICNT)) Y3(ICNT)=Y2(I) 1381 CONTINUE GOTO1800 C 1390 CONTINUE ALPHA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1391I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1391 ICNT=ICNT+1 CALL GLOPPF(D2(I),ALPHA,X2(ICNT)) Y3(ICNT)=Y2(I) 1391 CONTINUE GOTO1800 C CCCCC THE FOLLOWING SECTION WAS ADDED JANUARY 1996 1400 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1401I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1401 ICNT=ICNT+1 CALL DGAPPF(D2(I),GAMMA,X2(ICNT)) Y3(ICNT)=Y2(I) 1401 CONTINUE GOTO1800 C 1410 CONTINUE BETA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=1.0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1411I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1411 ICNT=ICNT+1 CALL BRAPPF(D2(I),BETA,X2(ICNT)) Y3(ICNT)=Y2(I) 1411 CONTINUE GOTO1800 C 1420 CONTINUE B=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=1.0/B AMAX=1.0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1421I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1421 ICNT=ICNT+1 CALL RECPPF(D2(I),B,X2(ICNT)) Y3(ICNT)=Y2(I) 1421 CONTINUE GOTO1800 C 1430 CONTINUE P=DISPAR(IDIS) NPAR=NBINOM C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO1431I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1431 ICNT=ICNT+1 CALL BINPPF(D2(I),P,NBINOM,X2(ICNT)) Y3(ICNT)=Y2(I) 1431 CONTINUE GOTO1800 C 1440 CONTINUE P=DISPAR(IDIS) IF(ICASPL.EQ.'NZCP')THEN AK=AK1 ELSE AK=DISPA2(IDIS) ENDIF C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO1441I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1441 ICNT=ICNT+1 CALL NBPPF(D2(I),P,AK,X2(ICNT)) Y3(ICNT)=Y2(I) 1441 CONTINUE GOTO1800 C 1450 CONTINUE THETA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO1451I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1451 ICNT=ICNT+1 CALL DLGPPF(D2(I),THETA,X2(ICNT)) Y3(ICNT)=Y2(I) 1451 CONTINUE GOTO1800 C 1460 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1461I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1461 ICNT=ICNT+1 CALL IGAPPF(D2(I),GAMMA,X2(ICNT)) Y3(ICNT)=Y2(I) 1461 CONTINUE GOTO1800 C 1470 CONTINUE IWRITE='OFF' ALAM3=DISPAR(IDIS) ALAM4=DISPA2(IDIS) CCCCC IF(IGLDDF.EQ.'RAMB')THEN CCCCC ZSCALE=1.0 CCCCC IWRITE='OFF' CCCCC CALL GLDCHK(ALAM3,ALAM4,ALOWER,AUPPER,IFLAG, CCCCC1 ISIGN,IWRITE) CCCCC IF(ISIGN.LT.0)ZSCALE=-1.0 CCCCC ENDIF C IF(ICASP2.EQ.'KS ')THEN CCCCC WRITE(ICOUT,1478)ALAM3,ALAM4 C1478 FORMAT('ALAM3,ALAM4=',2G15.7) CCCCC CALL DPWRST('XXX','BUG ') IWRITE='ERRO' IF(ALAM3.LE.0.0 .AND. ALAM4.LE.0.0)THEN AMIN=CPUMIN AMAX=CPUMAX ELSEIF(ALAM3.LE.0.0)THEN AMIN=CPUMIN CALL GLDPPF(1.0D0,DBLE(ALAM3),DBLE(ALAM4),DPPF, 1 IGLDDF,IWRITE) AMAX=REAL(DPPF) ELSEIF(ALAM4.LE.0.0)THEN AMAX=CPUMAX CCCCC CALL GLDPPF(0.0D0,DBLE(ALAM3),DBLE(ALAM4),DPPF, CCCCC1 IGLDDF,IWRITE) CCCCC AMIN=REAL(DPPF) AMIN=1.0/ALAM4 ELSE CALL GLDPPF(0.0D0,DBLE(ALAM3),DBLE(ALAM4),DPPF, 1 IGLDDF,IWRITE) AMIN=REAL(DPPF) CALL GLDPPF(1.0D0,DBLE(ALAM3),DBLE(ALAM4),DPPF, 1 IGLDDF,IWRITE) AMAX=REAL(DPPF) ENDIF IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1471I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1471 ICNT=ICNT+1 CALL GLDPPF(DBLE(D2(I)),DBLE(ALAM3),DBLE(ALAM4), 1 DPPF,IGLDDF,IWRITE) IF(IGLDDF.EQ.'RAMB')THEN CCCCC X2(I)=ZSCALE*REAL(DPPF) X2(I)=REAL(DPPF) ELSE X2(I)=REAL(DPPF) ENDIF Y3(ICNT)=Y2(I) 1471 CONTINUE GOTO1800 C 1480 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=1.0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1481I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1481 ICNT=ICNT+1 CALL BETPPF(D2(I),ALPHA,BETA,X2(ICNT)) Y3(ICNT)=Y2(I) 1481 CONTINUE GOTO1800 C 1490 CONTINUE C=DISPAR(IDIS) ALPHA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1491I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1491 ICNT=ICNT+1 CALL GGDPPF(D2(I),ALPHA,C,X2(ICNT)) Y3(ICNT)=Y2(I) 1491 CONTINUE GOTO1800 C 1500 CONTINUE C=DISPAR(IDIS) B=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1501I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1501 ICNT=ICNT+1 CALL GOMPPF(D2(I),C,B,X2(ICNT)) Y3(ICNT)=Y2(I) 1501 CONTINUE GOTO1800 C 1510 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1511I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1511 ICNT=ICNT+1 CALL PEXPPF(D2(I),ALPHA,BETA,X2(ICNT)) Y3(ICNT)=Y2(I) 1511 CONTINUE GOTO1800 C 1520 CONTINUE GAMMA=DISPAR(IDIS) THETA=DISPA2(IDIS) IARG1=1 C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1521I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1521 ICNT=ICNT+1 CALL EWEPPF(D2(I),GAMMA,THETA,IARG1,X2(ICNT)) Y3(ICNT)=Y2(I) 1521 CONTINUE GOTO1800 C 1530 CONTINUE ALPHA1=DISPAR(IDIS) ALPHA2=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=1.0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1531I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1531 ICNT=ICNT+1 CALL JSBPPF(D2(I),ALPHA1,ALPHA2,X2(ICNT)) Y3(ICNT)=Y2(I) 1531 CONTINUE GOTO1800 C 1540 CONTINUE ALPHA1=DISPAR(IDIS) ALPHA2=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1541I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1541 ICNT=ICNT+1 CALL JSUPPF(D2(I),ALPHA1,ALPHA2,X2(ICNT)) Y3(ICNT)=Y2(I) 1541 CONTINUE GOTO1800 C 1550 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C AMIN=0.0 AMAX=CPUMAX DO1551I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1551 ICNT=ICNT+1 CALL IWEPPF(D2(I),GAMMA,X2(ICNT)) Y3(ICNT)=Y2(I) 1551 CONTINUE GOTO1800 C 1560 CONTINUE ALPHA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1561I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1561 ICNT=ICNT+1 CALL LDEPPF(D2(I),ALPHA,X2(ICNT)) Y3(ICNT)=Y2(I) 1561 CONTINUE GOTO1800 C 1570 CONTINUE ZLOWLM=-1.0 ZUPPLM=1.0 C=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=-1.0 AMAX=1.0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1571I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1571 ICNT=ICNT+1 CALL TRIPPF(D2(I),C,ZLOWLM,ZUPPLM,X2(ICNT)) Y3(ICNT)=Y2(I) 1571 CONTINUE GOTO1800 C 1580 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1581I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1581 ICNT=ICNT+1 CALL GEEPPF(D2(I),GAMMA,X2(ICNT)) Y3(ICNT)=Y2(I) 1581 CONTINUE GOTO1800 C 1590 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1591I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1591 ICNT=ICNT+1 CALL ALPPPF(D2(I),ALPHA,BETA,X2(ICNT)) Y3(ICNT)=Y2(I) 1591 CONTINUE GOTO1800 C 1600 CONTINUE THETA=DISPAR(IDIS) ANU=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=1.0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1601I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1601 ICNT=ICNT+1 CALL TSPPPF(D2(I),THETA,ANU,X2(ICNT)) Y3(ICNT)=Y2(I) 1601 CONTINUE GOTO1800 C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 2003 1610 CONTINUE ALPHA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1611I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1611 ICNT=ICNT+1 D2IN=D2(I) CALL ERRPPF(D2IN,ALPHA,X2(ICNT)) Y3(ICNT)=Y2(I) 1611 CONTINUE GOTO1800 C 1620 CONTINUE NU=INT(DISPAR(IDIS) + 0.5) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1621I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1621 ICNT=ICNT+1 CALL FTPPF(D2(I),NU,X2(ICNT)) Y3(ICNT)=Y2(I) 1621 CONTINUE GOTO1800 C 1630 CONTINUE NU1=INT(DISPAR(IDIS)+0.5) NU2=INT(DISPA2(IDIS)+0.5) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1631I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1631 ICNT=ICNT+1 CALL FPPF(D2(I),NU1,NU2,X2(ICNT)) Y3(ICNT)=Y2(I) 1631 CONTINUE GOTO1800 C 1640 CONTINUE ALAMBA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1641I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1641 ICNT=ICNT+1 CALL SNPPF(D2(I),ALAMBA,ISKNDF,X2(ICNT)) Y3(ICNT)=Y2(I) 1641 CONTINUE GOTO1800 C 1650 CONTINUE NU=INT(DISPAR(IDIS)+0.5) ALAMBA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1651I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1651 ICNT=ICNT+1 CALL STPPF(D2(I),NU,ALAMBA,X2(ICNT)) Y3(ICNT)=Y2(I) 1651 CONTINUE GOTO1800 C 1660 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1661I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1661 ICNT=ICNT+1 CALL IBPPF(D2(I),ALPHA,BETA,X2(ICNT)) Y3(ICNT)=Y2(I) 1661 CONTINUE GOTO1800 C 1670 CONTINUE H=DISPAR(IDIS) G=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DP=-1.0D0 DO1671I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1671 ICNT=ICNT+1 CALL GHPPF(D2(I),G,H,X2(ICNT),DBLE(D2(I)),DPPF) Y3(ICNT)=Y2(I) 1671 CONTINUE GOTO1800 C 1680 CONTINUE SD=DISPAR(IDIS) ALAMBA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1681I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1681 ICNT=ICNT+1 CALL LSNPPF(D2(I),ALAMBA,SD,X2(ICNT)) Y3(ICNT)=Y2(I) 1681 CONTINUE GOTO1800 C 1690 CONTINUE ANU=DISPAR(IDIS) ALAMBA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1691I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1691 ICNT=ICNT+1 CALL NCCPPF(D2(I),ANU,ALAMBA,X2(ICNT)) Y3(ICNT)=Y2(I) 1691 CONTINUE GOTO1800 C 1695 CONTINUE ANU=REAL(NU1) ALAMBA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1696I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1696 ICNT=ICNT+1 CALL NCCPPF(D2(I),ANU,ALAMBA,X2(ICNT)) Y3(ICNT)=Y2(I) 1696 CONTINUE GOTO1800 C 1700 CONTINUE ANU=DISPAR(IDIS) ALAMBA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1701I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1701 ICNT=ICNT+1 CALL NCTPPF(D2(I),ANU,ALAMBA,X2(ICNT)) Y3(ICNT)=Y2(I) 1701 CONTINUE GOTO1800 C 1705 CONTINUE ANU=REAL(NU1) ALAMBA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1706I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1706 ICNT=ICNT+1 CALL NCTPPF(D2(I),ANU,ALAMBA,X2(ICNT)) Y3(ICNT)=Y2(I) 1706 CONTINUE GOTO1800 C 1710 CONTINUE AM=DISPAR(IDIS) SD=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1711I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1711 ICNT=ICNT+1 CALL FNRPPF(D2(I),AM,SD,X2(ICNT)) Y3(ICNT)=Y2(I) 1711 CONTINUE GOTO1800 C 1720 CONTINUE AM=DISPAR(IDIS) SD=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1721I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1721 ICNT=ICNT+1 CALL FCAPPF(D2(I),AM,SD,X2(ICNT)) Y3(ICNT)=Y2(I) 1721 CONTINUE GOTO1800 C 1730 CONTINUE IF(ICASPL.EQ.'TECP')THEN AMU=DISPAR(IDIS) SD=DISPA2(IDIS) ELSE AMU=AMU1 SD=DISPAR(IDIS) ENDIF C IF(ICASP2.EQ.'KS ')THEN AMIN=AMU AMAX=X0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1731I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1731 ICNT=ICNT+1 CALL TNEPPF(D2(I),X0,AMU,SD,X2(ICNT)) Y3(ICNT)=Y2(I) 1731 CONTINUE GOTO1800 C 1740 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO1741I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1741 ICNT=ICNT+1 CALL BBNPPF(D2(I),ALPHA,BETA,NU,X2(ICNT)) Y3(ICNT)=Y2(I) 1741 CONTINUE GOTO1800 C 1750 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO1751I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1751 ICNT=ICNT+1 CALL POLPPF(D2(I),ALPHA,BETA,NU,X2(ICNT)) Y3(ICNT)=Y2(I) 1751 CONTINUE GOTO1800 C 1760 CONTINUE P=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO1761I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1761 ICNT=ICNT+1 CALL YULPPF(D2(I),P,X2(ICNT)) Y3(ICNT)=Y2(I) 1761 CONTINUE GOTO1800 C 1770 CONTINUE C=DISPAR(IDIS) A=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO1771I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1771 ICNT=ICNT+1 CALL WARPPF(D2(I),C,A,X2(I),'NOTR') Y3(ICNT)=Y2(I) 1771 CONTINUE GOTO1800 C 1780 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO1781I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1781 ICNT=ICNT+1 CALL HERPPF(D2(I),ALPHA,BETA,X2(ICNT)) Y3(ICNT)=Y2(I) 1781 CONTINUE GOTO1800 C 1790 CONTINUE ALAMBA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO1791I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO1791 ICNT=ICNT+1 CALL SDEPPF(D2(I),ALAMBA,X2(ICNT)) Y3(ICNT)=Y2(I) 1791 CONTINUE GOTO1800 C 12800 CONTINUE IF(IADEDF.EQ.'K')THEN AK=DISPAR(IDIS) AJUNK=AK ELSE AMU=DISPAR(IDIS) AJUNK=AMU ENDIF C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO12801I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO12801 ICNT=ICNT+1 CALL ADEPPF(D2(I),AJUNK,IADEDF,X2(ICNT)) Y3(ICNT)=Y2(I) 12801 CONTINUE GOTO1800 C 12810 CONTINUE SIGMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO12811I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO12811 ICNT=ICNT+1 CALL MAXPPF(D2(I),SIGMA,X2(ICNT)) Y3(ICNT)=Y2(I) 12811 CONTINUE GOTO1800 C 12820 CONTINUE ETA=DISPAR(IDIS) ZETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO12821I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO12821 ICNT=ICNT+1 CALL MA2PPF(D2(I),ZETA,ETA,X2(ICNT)) Y3(ICNT)=Y2(I) 12821 CONTINUE GOTO1800 C 12830 CONTINUE AK=DISPAR(IDIS) TAU=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO12831I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO12831 ICNT=ICNT+1 CALL GALPPF(DBLE(D2(I)),DBLE(AK),DBLE(TAU),IADEDF,DPPF) X2(ICNT)=DPPF Y3(ICNT)=Y2(I) 12831 CONTINUE GOTO1800 C 12840 CONTINUE ALPHA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO12841I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO12841 ICNT=ICNT+1 CALL MCLPPF(DBLE(D2(I)),DBLE(ALPHA),DPPF) X2(ICNT)=DPPF Y3(ICNT)=Y2(I) 12841 CONTINUE GOTO1800 C 12850 CONTINUE A=DISPAR(IDIS) ALPHA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO12851I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO12851 ICNT=ICNT+1 CALL GMCPPF(DBLE(D2(I)),DBLE(ALPHA),DBLE(A),DPPF) X2(ICNT)=DPPF Y3(ICNT)=Y2(I) 12851 CONTINUE GOTO1800 C 12860 CONTINUE ALPHA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C XPAR(1)=0.0D0 XPAR(2)=1.0D0 XPAR(3)=DBLE(ALPHA) DO12861I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO12861 ICNT=ICNT+1 DPPF=QUAGLO(DBLE(D2(I)),XPAR) X2(ICNT)=REAL(DPPF) Y3(ICNT)=Y2(I) 12861 CONTINUE GOTO1800 C 12870 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO12871I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO12871 ICNT=ICNT+1 CALL BNOPPF(DBLE(D2(I)),DBLE(ALPHA),DBLE(BETA),DPPF) X2(ICNT)=REAL(DPPF) Y3(ICNT)=Y2(I) 12871 CONTINUE GOTO1800 C 12880 CONTINUE ALPHA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO12881I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO12881 ICNT=ICNT+1 CALL GL2PPF(DBLE(D2(I)),DBLE(ALPHA),DPPF) X2(ICNT)=DPPF Y3(ICNT)=Y2(I) 12881 CONTINUE GOTO1800 C 12890 CONTINUE ALPHA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO12891I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO12891 ICNT=ICNT+1 CALL GL3PPF(DBLE(D2(I)),DBLE(ALPHA),DPPF) X2(ICNT)=DPPF Y3(ICNT)=Y2(I) 12891 CONTINUE GOTO1800 C 12900 CONTINUE P=DISPAR(IDIS) Q=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO12901I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO12901 ICNT=ICNT+1 CALL GL4PPF(DBLE(D2(I)),DBLE(P),DBLE(Q),DPPF) X2(ICNT)=REAL(DPPF) Y3(ICNT)=Y2(I) 12901 CONTINUE GOTO1800 C 12910 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO12911I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO12911 ICNT=ICNT+1 CALL ALDPPF(DBLE(D2(I)),DBLE(ALPHA),DBLE(BETA),DPPF) X2(ICNT)=REAL(DPPF) Y3(ICNT)=Y2(I) 12911 CONTINUE GOTO1800 C 12920 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO12921I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO12921 ICNT=ICNT+1 IF(IBGEDF.EQ.'UNSH')THEN CALL BGEPPF(D2(I),ALPHA,BETA,X2(ICNT)) ELSE CALL BG2PPF(D2(I),ALPHA,BETA,X2(ICNT)) ENDIF Y3(ICNT)=Y2(I) 12921 CONTINUE GOTO1800 C 12930 CONTINUE ALPHA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO12931I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO12931 ICNT=ICNT+1 CALL ZETPPF(D2(I),ALPHA,X2(ICNT)) Y3(ICNT)=Y2(I) 12931 CONTINUE GOTO1800 C 12940 CONTINUE ALPHA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO12941I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO12941 ICNT=ICNT+1 CALL ZIPPPF(D2(I),ALPHA,NU,X2(ICNT)) Y3(ICNT)=Y2(I) 12941 CONTINUE GOTO1800 C 12950 CONTINUE ALAMBA=DISPAR(IDIS) IF(AK1.GT.XMIN)AK1=XMIN K=INT(AK1+0.5) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO12951I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO12951 ICNT=ICNT+1 CALL BTAPPF(D2(I),ALAMBA,AK1,X2(ICNT)) Y3(ICNT)=Y2(I) 12951 CONTINUE GOTO1800 C 12960 CONTINUE ALAMBA=DISPAR(IDIS) THETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO12961I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO12961 ICNT=ICNT+1 CALL LPOPPF(D2(I),ALAMBA,THETA,X2(ICNT)) Y3(ICNT)=Y2(I) 12961 CONTINUE GOTO1800 C 12970 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO1800 ENDIF C DO12971I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO12971 ICNT=ICNT+1 CALL LBEPPF(D2(I),ALPHA,BETA,YLOWLM,YUPPLM,X2(ICNT)) Y3(ICNT)=Y2(I) 12971 CONTINUE GOTO1800 C 12980 CONTINUE THETA=DISPAR(IDIS) P=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO12981I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO12981 ICNT=ICNT+1 CALL PAPPPF(DBLE(D2(I)),DBLE(THETA),DBLE(P),DPPF) X2(ICNT)=REAL(DPPF) Y3(ICNT)=Y2(I) 12981 CONTINUE GOTO1800 C 12990 CONTINUE P=DISPAR(IDIS) IF(REAL(NU1).GT.XMIN)NU1=INT(XMIN+0.5) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO12991I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO12991 ICNT=ICNT+1 CALL LOSPPF(D2(I),P,NU1,X2(ICNT)) Y3(ICNT)=Y2(I) 12991 CONTINUE GOTO1800 C 13000 CONTINUE THETA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO13001I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO13001 ICNT=ICNT+1 CALL GLSPPF(D2(I),THETA,BETA,PPF) X2(ICNT)=PPF Y3(ICNT)=Y2(I) 13001 CONTINUE GOTO1800 C 13010 CONTINUE SHAPE=DISPAR(IDIS) IF(IGETDF.EQ.'THET')THEN THETA=SHAPE ELSE AMU=SHAPE ENDIF BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO13011I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO13011 ICNT=ICNT+1 CALL GETPPF(DBLE(D2(I)),DBLE(SHAPE),DBLE(BETA),IGETDF,DPPF) X2(ICNT)=REAL(DPPF) Y3(ICNT)=Y2(I) 13011 CONTINUE GOTO1800 C 13020 CONTINUE P=DISPAR(IDIS) PHI=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO13021I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO13021 ICNT=ICNT+1 CALL QBIPPF(D2(I),P,PHI,AM,PPF) X2(ICNT)=PPF Y3(ICNT)=Y2(I) 13021 CONTINUE GOTO1800 C 13030 CONTINUE SHAPE=DISPAR(IDIS) IF(ICONDF.EQ.'THET')THEN THETA=SHAPE ELSE AMU=SHAPE ENDIF AM=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO13031I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO13031 ICNT=ICNT+1 CALL CONPPF(DBLE(D2(I)),DBLE(SHAPE),DBLE(AM),ICONDF,DPPF) X2(ICNT)=REAL(DPPF) Y3(ICNT)=Y2(I) 13031 CONTINUE GOTO1800 C 13040 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) A=ALPHA B=0.0 C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO13041I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO13041 ICNT=ICNT+1 CALL LKPPF(DBLE(D2(I)),DBLE(ALPHA),DBLE(B),DBLE(BETA), 1 DPPF) X2(ICNT)=REAL(DPPF) Y3(ICNT)=Y2(I) 13041 CONTINUE GOTO1800 C 13050 CONTINUE P=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO13051I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO13051 ICNT=ICNT+1 CALL DIWPPF(DBLE(D2(I)),DBLE(P),DBLE(BETA),DPPF) X2(ICNT)=REAL(DPPF) Y3(ICNT)=Y2(I) 13051 CONTINUE GOTO1800 C 13060 CONTINUE P=DISPAR(IDIS) A=DISPA2(IDIS) NU=NU1 IF(REAL(NU).GT.XMIN)NU=INT(XMIN+0.5) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO1800 ENDIF C DO13061I=1,N1 IF(ICENSO.EQ.'ON' .AND. X1(I).EQ.0.0)GOTO13061 ICNT=ICNT+1 CALL GLGPPF(D2(I),P,NU1,A,X2(ICNT)) Y3(ICNT)=Y2(I) 13061 CONTINUE GOTO1800 C 1800 CONTINUE C CCCCC MAY 2004: SUPPORT BIWEIGHT MIDCORRELATION, PERCENTAGE BEND CCCCC CORRELATION, AND WINSORIZED CORRELATION AS ALTERNATIVES CCCCC TO THE STANDARD CORRELATION FOR THIS PLOT. CCCCC MAY 2004: SUPPORT A "MINIMUM KOLM-SMIR" OPTION. CALL LINFI2 CCCCC TO OBTAIN ESTIMATES OF LOCATION AND SCALE, THE CALL CCCCC DP1KS2 TO OBTAIN VALUE OF K-S STATISTIC. C IWRITE='OFF' NTEMP=ICNT C IF(ICASP2.EQ.'KS ')THEN C CCCCC DETERMINE LOCATION AND SCALE PARAMETERS. CCCCC 1) USER SPECIFIED KSLOC AND KSSCALE CCCCC 2) FIT A LINE TO THE PROBABILITY PLOT AND USE INTERCEPT CCCCC AND SLOPE CCCCC 3) FOR BOUNDED DISTRIBUTIONS, CHECK THAT XMIN AND XMAX CCCCC WILL BE IN RANGE. IF NOT, SET LOCATION TO MINIMUM CCCCC AND SCALE TO MAXIMUM - MINIMUM C EPS=0.000001 ICASP3=ICASPL IF(ICASP3.EQ.'GMLP')THEN ICASP3='GMCP' ELSEIF(ICASP3.EQ.'GETC')THEN ICASP3='GETP' ELSEIF(ICASP3.EQ.'DIWP')THEN ICASP3='DIWP' ELSEIF(ICASP3(3:4).EQ.'CP')THEN ICASP3(3:4)='PP' ELSEIF(ICASP3(2:3).EQ.'CP')THEN ICASP3(2:3)='PP' ENDIF IF((KSLOC.EQ.CPUMIN .OR. KSSCAL.EQ.CPUMIN) .AND. 1 IFLAG.EQ.0)THEN C C HANDLE BETA SEPARATELY C IF(ICASPL.EQ.'BECP')THEN IF(XMIN.GE.0.0 .AND. XMIN.LE.1.0 .AND. 1 XMAX.GE.0.0 .AND. XMAX.LE.1.0)THEN A0TEMP=0.0 A1TEMP=1.0 ELSE A0TEMP=XMIN-EPS A1TEMP=XMAX+EPS ENDIF C C HANDLE TUKEY-LAMBDA SEPARATELY C ELSEIF(ICASPL.EQ.'LACP' .AND. ALAMBA.GT.0.0)THEN CALL LINFI2(Y3,X2,NTEMP, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) IF((XMIN-A0TEMP)/A1TEMP.LT.AMIN .OR. 1 (XMAX-A0TEMP)/A1TEMP.GT.AMAX)THEN A0TEMP=XMED ATEMP1=ALAMBA*ABS(XMAX-A0TEMP) + 0.1 ATEMP2=ALAMBA*ABS(XMIN-A0TEMP) + 0.1 A1TEMP=MAX(ATEMP1,ATEMP2) ENDIF C C HANDLE VON-MISES, WRAPPED CAUCHY SEPARATELY C ELSEIF(ICASPL.EQ.'VMCP' .OR. ICASPL.EQ.'WCCP')THEN CALL LINFI2(Y3,X2,NTEMP, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) IF((XMIN-A0TEMP)/A1TEMP.LT.AMIN .OR. 1 (XMAX-A0TEMP)/A1TEMP.GT.AMAX)THEN A0TEMP=XMED ATEMP1=(XMAX-A0TEMP)/AMAX ENDIF C C HANDLE CASE WHERE DOMAIN BOUNDED BOTH ABOVE AND BELOW. SOLVE C C (XMIN-A0)/A1 = AMIN C (XMAX-A0)/A1 = AMAX C C NOTE: OF AMIN = -AMAX (E.G., VON MISES), THEN GET DIVISION BY C ZERO. IN THIS CASE, SET A0 TO DATA MINIMUM MINUS C EPS, THEN SET A1 = (XMAX-A0)/AMAX C ELSEIF(AMIN.GT.CPUMIN .AND. AMAX.LT.CPUMAX)THEN CALL LINFI2(Y3,X2,NTEMP, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) C IF(IPPCBW.EQ.'BIWE')THEN DO66310I=1,NTEMP RESBW(I)=Y3(I) - (A0TEMP + A1TEMP*X2(I)) WEIGHH(I)=1.0 WEIGHV(I)=1.0 66310 CONTINUE IWRITE='OFF' CALL BIWEIG(RESBW,NTEMP,IWRITE,WEIGHV,IBUGG3,IERROR) C IT=1 I1=1 I2=NTEMP I3=1 I4=NTEMP XMAXHF=1.0 C CALL LINEAR(IT,I1,I2,X2,Y3,WEIGHH,WEIGHV,NTEMP, 1 XMAXHF,I3,I4, 1 PPA0BW,PPA1BW,PREDBW,RESBW, 1 ISUBRO,IBUGG3,IERROR) C DO66320I=1,NTEMP RESBW(I)=Y3(I) - (PPA0BW + PPA1BW*X2(I)) 66320 CONTINUE CALL BIWEIG(RESBW,NTEMP,IWRITE,WEIGHV,IBUGG3,IERROR) CALL LINEAR(IT,I1,I2,X2,Y3,WEIGHH,WEIGHV,NTEMP, 1 XMAXHF,I3,I4, 1 PPA0BW,PPA1BW,PREDBW,RESBW, 1 ISUBRO,IBUGG3,IERROR) A0TEMP=PPA0BW A1TEMP=PPA1BW C ENDIF C IF((XMIN-A0TEMP)/A1TEMP.LT.AMIN .OR. 1 (XMAX-A0TEMP)/A1TEMP.GT.AMAX)THEN CMIN=AMIN CMAX=AMAX CONST=CMIN/CMAX IF(CONST.NE.-1.0)THEN A0TEMP=(XMIN-CONST*XMAX)/(1.0+CONST) - EPS A1TEMP=(XMAX-A0TEMP)/CMAX + EPS ELSE A0TEMP=XMIN - EPS A1TEMP=(XMAX - A0TEMP)/AMAX ENDIF ENDIF C C HANDLE CASE WHERE DOMAIN BOUNDED ON MINIMUM ONLY C ELSEIF(AMIN.GT.CPUMIN .AND. AMAX.EQ.CPUMAX)THEN CALL LINFI2(Y3,X2,NTEMP, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) C IF(IPPCBW.EQ.'BIWE')THEN C DO66110I=1,NTEMP RESBW(I)=Y3(I) - (A0TEMP + A1TEMP*X2(I)) WEIGHH(I)=1.0 WEIGHV(I)=1.0 66110 CONTINUE IWRITE='OFF' CALL BIWEIG(RESBW,NTEMP,IWRITE,WEIGHV,IBUGG3,IERROR) C IT=1 I1=1 I2=NTEMP I3=1 I4=NTEMP XMAXHF=1.0 C CALL LINEAR(IT,I1,I2,X2,Y3,WEIGHH,WEIGHV,NTEMP, 1 XMAXHF,I3,I4, 1 PPA0BW,PPA1BW,PREDBW,RESBW, 1 ISUBRO,IBUGG3,IERROR) C DO66120I=1,NTEMP RESBW(I)=Y3(I) - (PPA0BW + PPA1BW*X2(I)) 66120 CONTINUE CALL BIWEIG(RESBW,NTEMP,IWRITE,WEIGHV,IBUGG3,IERROR) CALL LINEAR(IT,I1,I2,X2,Y3,WEIGHH,WEIGHV,NTEMP, 1 XMAXHF,I3,I4, 1 PPA0BW,PPA1BW,PREDBW,RESBW, 1 ISUBRO,IBUGG3,IERROR) A0TEMP=PPA0BW A1TEMP=PPA1BW C ENDIF C IF((XMIN-A0TEMP)/A1TEMP.LT.AMIN)THEN A0TEMP=XMIN-EPS ENDIF C C HANDLE CASE WHERE DOMAIN BOUNDED ON MAXIMUM ONLY C ELSEIF(AMIN.EQ.CPUMIN .AND. AMAX.LT.CPUMAX)THEN CALL LINFI2(Y3,X2,NTEMP, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) C IF(IPPCBW.EQ.'BIWE')THEN C DO66210I=1,NTEMP RESBW(I)=Y3(I) - (A0TEMP + A1TEMP*X2(I)) WEIGHH(I)=1.0 WEIGHV(I)=1.0 66210 CONTINUE IWRITE='OFF' CALL BIWEIG(RESBW,NTEMP,IWRITE,WEIGHV,IBUGG3,IERROR) C IT=1 I1=1 I2=NTEMP I3=1 I4=NTEMP XMAXHF=1.0 C CALL LINEAR(IT,I1,I2,X2,Y3,WEIGHH,WEIGHV,NTEMP, 1 XMAXHF,I3,I4, 1 PPA0BW,PPA1BW,PREDBW,RESBW, 1 ISUBRO,IBUGG3,IERROR) C DO66220I=1,NTEMP RESBW(I)=Y3(I) - (PPA0BW + PPA1BW*X2(I)) 66220 CONTINUE CALL BIWEIG(RESBW,NTEMP,IWRITE,WEIGHV,IBUGG3,IERROR) CALL LINEAR(IT,I1,I2,X2,Y3,WEIGHH,WEIGHV,NTEMP, 1 XMAXHF,I3,I4, 1 PPA0BW,PPA1BW,PREDBW,RESBW, 1 ISUBRO,IBUGG3,IERROR) A0TEMP=PPA0BW A1TEMP=PPA1BW C ENDIF C CTEMP=(XMAX-A0TEMP)/A1TEMP IF(CTEMP.GE.AMAX)THEN A0TEMP=(XMAX-EPS) - A1TEMP*AMAX ENDIF C C HANDLE UNBOUNDED CASE C C MAY 2006: IF REQUESTED, PERFORM ONE STEP OF BIWEIGHT FITTING C OF RESIDUALS. DO THIS TO OBTAIN BETTER ESTIMATE OF C LOCATION AND SCALE (THIS CAN BE HELPFUL FOR LONG-TAILED C DISTRIBUTIONS. C ELSE CALL LINFI2(Y3,X2,NTEMP, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) C IF(IPPCBW.EQ.'BIWE')THEN C DO66010I=1,NTEMP RESBW(I)=Y3(I) - (A0TEMP + A1TEMP*X2(I)) WEIGHH(I)=1.0 WEIGHV(I)=1.0 66010 CONTINUE IWRITE='OFF' CALL BIWEIG(RESBW,NTEMP,IWRITE,WEIGHV,IBUGG3,IERROR) C IT=1 I1=1 I2=NTEMP I3=1 I4=NTEMP XMAXHF=1.0 C CALL LINEAR(IT,I1,I2,X2,Y3,WEIGHH,WEIGHV,NTEMP, 1 XMAXHF,I3,I4, 1 PPA0BW,PPA1BW,PREDBW,RESBW, 1 ISUBRO,IBUGG3,IERROR) C DO66020I=1,NTEMP RESBW(I)=Y3(I) - (PPA0BW + PPA1BW*X2(I)) 66020 CONTINUE CALL BIWEIG(RESBW,NTEMP,IWRITE,WEIGHV,IBUGG3,IERROR) CALL LINEAR(IT,I1,I2,X2,Y3,WEIGHH,WEIGHV,NTEMP, 1 XMAXHF,I3,I4, 1 PPA0BW,PPA1BW,PREDBW,RESBW, 1 ISUBRO,IBUGG3,IERROR) A0TEMP=PPA0BW A1TEMP=PPA1BW C ENDIF C ENDIF C ELSE NTEMP=N1 A0TEMP=KSLOC A1TEMP=KSSCAL ENDIF C XTEMP3(IDIS)=A0TEMP XTEMP4(IDIS)=A1TEMP C IF(IFLAG.EQ.0)THEN CALL DP1KS2(Y2,NTEMP,ICASP3, 1 X1,ICENSO, 1 ALAMBA,NU,NU1,NU2,GAMMA,ALPHA,BETA, 1 NPAR,P,K,MINMAX, 1 ANU,ANU1,ANU2,NDUN,C,ALAMB1,ALAMB2, 1 MPAR,B,SD,THETA, 1 DELTA,A,AM,X0, 1 U1,SD1,U2,SD2,DZ, 1 ALAMB3,ALAMB4,ALPHA1,ALPHA2, 1 ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2, 1 AMU,XI,CHI,G,H,AK,SIGMA, 1 ETA,ZETA,TAU,Q, 1 YLOWLM,YUPPLM, 1 A0TEMP,A1TEMP, 1 STATVA,CDF1,CDF2,CDF3, 1 ICAPSW,ICAPTY, 1 IWRITE,IADEDF,IGEPDF,IMAKDF,IBEIDF, 1 ILGADF,ISKNDF,IGLDDF, 1 XTEMP1,XTEMP2,NXTEMP,IBUGG3,IERROR) ELSE IRHSTG='AREA' CLWID=CPUMIN XSTART=CPUMIN XSTOP=CPUMAX CALL DPCHS2(Y3,X1,XTEMP5,NTEMP,ICASP3,IDATSW,IRHSTG, 1 ALAMBA,NU,NU1,NU2,GAMMA,ALPHA,BETA,NPAR, 1 P,K,MINMAX, 1 ANU,ANU1,ANU2,NDUN,C,ALAMB1,ALAMB2,MPAR, 1 B,SD,THETA, 1 DELTA,A,AM,X0, 1 U1,SD1,U2,SD2,DZ,ANU3, 1 ALAMB3,ALAMB4,ALPHA1,ALPHA2, 1 ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2, 1 AMU,XI,CHI,G,H,AK,SIGMA, 1 ETA,ZETA,TAU,Q,AKAPPA,PHI, 1 YLOWLM,YUPPLM, 1 CLWID,XSTART,XSTOP, 1 XTEMP9,IHSTCW,MAXOBV, 1 A0TEMP,A1TEMP, 1 STATVA,STATCD,STATNU,CDF1,CDF2,CDF3, 1 ICAPSW,ICAPTY,IWRITE, 1 IADEDF,IGEPDF,IMAKDF,IBEIDF, 1 ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF, 1 PCHSLM, 1 XTEMP1,XTEMP2,XTEMP7,XTEMP8,NXTEMP, 1 IBUGG3,IERROR) ENDIF CORRV(IDIS)=STATVA IF(CORRV(IDIS).LT.PPCCMX .OR. PPCCMX.EQ.CPUMIN)THEN A0SAVE=XTEMP3(IDIS) A1SAVE=XTEMP4(IDIS) PPCCMX=CORRV(IDIS) SHAPMX=DISPAR(IDIS) ENDIF ELSE CALL CORR(Y3,X2,NTEMP,IWRITE,CC,IBUGG3,IERROR) CORRV(IDIS)=CC CALL LINFI2(Y3,X2,NTEMP, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) C IF(CORRV(IDIS).GT.PPCCMX)THEN A0SAVE=A0TEMP A1SAVE=A1TEMP PPCCMX=CORRV(IDIS) SHAPMX=DISPAR(IDIS) ENDIF C IF(IPPCCC.EQ.'WINS')THEN IHP='P1 ' 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 PROP1=10.0 ELSE PROP1=VALUE(ILOCP) ENDIF IF(PROP1.LE.0.0 .OR. PROP1.GE.25.0)PROP1=10.0 C IHP='P2 ' IHP2=' ' 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 PROP2=10.0 ELSE PROP2=VALUE(ILOCP) ENDIF IF(PROP2.LE.0.0 .OR. PROP2.GE.25.0)PROP2=10.0 C CALL WINSOR(Y3,NTEMP,PROP1,PROP2,IWRITE,XTEMP1, 1 MAXOBV,XTEMP2, 1 IBUGG3,IERROR) DO12072I=1,N1 Y1(I)=XTEMP2(I) 12072 CONTINUE CALL WINSOR(X2,NTEMP,PROP1,PROP2,IWRITE,XTEMP1, 1 MAXOBV,XTEMP2, 1 IBUGG3,IERROR) DO12074I=1,NTEMP X2(I)=XTEMP2(I) 12074 CONTINUE CALL CORR(Y3,X2,NTEMP,IWRITE,CC,IBUGG3,IERROR) CORRZ(IDIS)=CC ELSEIF(IPPCCC.EQ.'PERB')THEN IHP='BETA' 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 BETA=0.1 ELSE BETA=VALUE(ILOCP) ENDIF IF(BETA.LE.0.0 .OR. BETA.GE.0.25)BETA=0.1 C CALL PBNCOR(Y3,X2,NTEMP,IWRITE,XTEMP1,XTEMP2,MAXOBV, 1 CC,BETA, 1 IBUGG3,IERROR) CORRZ(IDIS)=CC ELSEIF(IPPCCC.EQ.'BIWE')THEN CALL BIWMDV(Y3,NTEMP,IWRITE,XTEMP1,XTEMP2,MAXOBV,VAR1, 1 IBUGG3,IERROR) CALL BIWMDV(X2,NTEMP,IWRITE,XTEMP1,XTEMP2,MAXOBV,VAR2, 1 IBUGG3,IERROR) CALL BIWMCV(Y3,X2,NTEMP,IWRITE,XTEMP1,XTEMP2,MAXOBV,COV, 1 IBUGG3,IERROR) CC=0.0 IF(COV.GT.0.0)CC=COV/SQRT(VAR1*VAR2) CORRZ(IDIS)=CC ENDIF ENDIF C CCCCC OCTOBER 2004: WRITE PPCC VALUE, LOCATION, SHAPE, AND CCCCC SHAPE PARAMETERS TO DPST2F.DAT. C IF(NUMSHA.LE.1)THEN IF(IREPL.EQ.'ON')THEN WRITE(IOUNI2,'(I5,2X,4E15.7)')IIREPL-1,CORRV(IDIS), 1 A0TEMP,A1TEMP,DISPAR(IDIS) ELSE WRITE(IOUNI2,'(4E15.7)')CORRV(IDIS),A0TEMP,A1TEMP, 1 DISPAR(IDIS) ENDIF ELSE WRITE(IOUNI2,'(5E15.7)')CORRV(IDIS),A0TEMP,A1TEMP, 1 DISPAR(IDIS),(IDIS) ENDIF C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PPC2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1831)NUMDIS,IDIS,DISPAR(IDIS),DISPA2(IDIS) 1831 FORMAT('NUMDIS,IDIS,DISPAR(IDIS),DISPA2(IDIS) = ',2I8,2E15.7) CALL DPWRST('XXX','BUG ') DO1832I=1,N1 WRITE(ICOUT,1833)I,Y1(I),X1(I),Y2(I),X2(I),D2(I) 1833 FORMAT('I,Y1(I),X1(I),Y2(I),X2(I),D2(I) = ',I8,5E15.7) CALL DPWRST('XXX','BUG ') 1832 CONTINUE WRITE(ICOUT,1834)ICASPL,IDATSW 1834 FORMAT('ICASPL,IDATSW = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1835)NUMDIS,IDIS,DISPAR(IDIS),CORRV(IDIS) 1835 FORMAT('NUMDIS,IDIS,DISPAR(IDIS),CORRV(IDIS) = ',2I8,2E15.7) CALL DPWRST('XXX','BUG ') ENDIF C 1108 CONTINUE 1105 CONTINUE C CCCCC THREE BASIC CASES: CCCCC CCCCC 1) ONE SHAPE PARAMETER CCCCC 2) TWO SHAPE PARAMETERS - GENERATE MULTI-TRACE PLOT CCCCC 3) TWO SHAPE PARAMETERS - GENERATE A 3D-PLOT C CCCCC FOR EACH OF THESE, THERE ARE SEVERAL SUB-CASES TO CONSIDER: CCCCC CCCCC 1) K-S PLOT PRINTS LOCATION AND SCALE ESTIMATES USED (FOR CCCCC CONTINUOUS DISTRIBUTIONS ONLY) CCCCC 2) PPCC PLOT MAY PRINT AN ALTERNATE ESTIMATE OF CORRELATION CCCCC AS A SECOND TRACE CCCCC 3) EXTREME VALUE PLOT WILL PRINT SEPARATE TRACES FOR MIN AND CCCCC MAX CASES C AHOLD=CPUMIN ATAG=0.0 C CCCCC CASE 1: ONE SHAPE PARAMETER C IF(NUMSHA.EQ.1)THEN NLAST=NUMDIS IF(ICASPL.EQ.'EVCP')NLAST=NUMD1 DO1930IDIS=1,NLAST ICNTPT=ICNTPT+1 X2TEMP(ICNTPT)=DISPAR(IDIS) IF(ICASPL.NE.'EVCP' .OR. IPPCCC.EQ.'LINE')THEN Y2TEMP(ICNTPT)=CORRV(IDIS) D2TEMP(ICNTPT)=REAL(IIREPL) ELSE Y2TEMP(ICNTPT)=CORRZ(IDIS) D2TEMP(ICNTPT)=REAL(IIREPL-1)+1.0 ENDIF IF(IFLAG.EQ.0 .AND. ICASP2.EQ.'KS ')THEN WRITE(IOUNI1,'(5E15.7,I8)')Y2TEMP(ICNTPT), 1 XTEMP3(IDIS),XTEMP4(IDIS), 1 X2TEMP(ICNTPT), 1 D2TEMP(ICNTPT),IIREPL-1 ELSE WRITE(IOUNI1,'(3E15.7,I8)')Y2TEMP(ICNTPT), 1 X2TEMP(ICNTPT), 1 D2TEMP(ICNTPT),IIREPL-1 ENDIF 1930 CONTINUE N2=ICNTPT NPLOTV=2 C IF(ICASPL.EQ.'EVCP')THEN NUMD1P=NUMD1+1 DO1932IDIS=NUMD1P,NUMDIS ICNTPT=ICNTPT+1 Y2TEMP(ICNTPT)=CORRV(IDIS) IF(IPPCCC.NE.'LINE')Y2TEMP(ICNTPT)=CORRZ(IDIS) X2TEMP(ICNTPT)=DISPAR(IDIS) D2TEMP(ICNTPT)=REAL(IIREPL)*2.0 1932 CONTINUE N2=ICNTPT NPLOTV=3 ELSEIF(IPPCCC.NE.'LINE' .AND. ICASP2.EQ.'PPCC')THEN NUMD1P=NUMD1+1 DO1934IDIS=1,NUMDIS ICNTPT=ICNTPT+1 Y2TEMP(ICNTPT)=CORRZ(IDIS) X2TEMP(ICNTPT)=DISPAR(IDIS) D2TEMP(ICNTPT)=REAL(IIREPL)*2.0 1934 CONTINUE N2=ICNTPT NPLOTV=3 ENDIF C CCCCC CASE 2: TWO SHAPE PARAMETERS, MULTI-TRACE PLOT C ELSEIF(NUMSHA.EQ.2 .AND. IPPCFO.EQ.'TRAC')THEN DO1940IDIS=1,NUMDIS ICNTPT=ICNTPT+1 IF(IPPCAO.EQ.'DEFA')THEN IF(DISPAR(IDIS).NE.AHOLD)THEN ATAG=ATAG+1.0 AHOLD=DISPAR(IDIS) ENDIF ELSE DO1942JJ=1,NUMDIS IF(DISPA2(IDIS).EQ.DISPA2(JJ))THEN ATAG=REAL(JJ) GOTO1945 ENDIF 1942 CONTINUE 1945 CONTINUE ENDIF IF(ICASP2.EQ.'PPCC' .AND. IPPCCC.NE.'LINE')THEN Y2TEMP(ICNTPT)=CORRZ(IDIS) ELSE Y2TEMP(ICNTPT)=CORRV(IDIS) ENDIF IF(IPPCAO.EQ.'DEFA')THEN X2TEMP(ICNTPT)=DISPA2(IDIS) X3D2(ICNTPT)=DISPAR(IDIS) ELSE X3D2(ICNTPT)=DISPA2(IDIS) X2TEMP(ICNTPT)=DISPAR(IDIS) ENDIF D2TEMP(ICNTPT)=ATAG IF(IFLAG.EQ.0 .AND. ICASP2.EQ.'KS ')THEN WRITE(IOUNI1,'(6E15.7)')Y2TEMP(ICNTPT), 1 XTEMP3(IDIS),XTEMP4(IDIS), 1 X2TEMP(ICNTPT),X3D2(ICNTPT), 1 D2TEMP(ICNTPT) ELSE WRITE(IOUNI1,'(4E15.7)')Y2TEMP(ICNTPT), 1 X2TEMP(ICNTPT),X3D2(ICNTPT), 1 D2TEMP(ICNTPT) ENDIF 1940 CONTINUE N2=ICNTPT NPLOTV=3 C CCCCC CASE 3: TWO SHAPE PARAMETERS, 3D-PLOT C ELSEIF(NUMSHA.EQ.2 .AND. IPPCFO.EQ.'3D ')THEN IWRITE='OFF' CALL DISTIN(DISPA2,NUMDIS,IWRITE,DISPA3,NTEMP,IBUGG3,IERROR) IF(IERROR.EQ.'YES'.OR.IERROR.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1941) 1941 FORMAT('****** ERROR FROM DPPPC2 DURING CALL TO DISTIN') CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C DO1960IDIS=1,NUMDIS ICNTPT=ICNTPT+1 IF(DISPAR(IDIS).NE.AHOLD)THEN ATAG=ATAG+1.0 AHOLD=DISPAR(IDIS) ENDIF IF(ICASP2.EQ.'PPCC' .AND. IPPCCC.NE.'LINE')THEN Y2TEMP(ICNTPT)=CORRZ(IDIS) ELSE Y2TEMP(ICNTPT)=CORRV(IDIS) ENDIF IF(IPPCAO.EQ.'DEFA')THEN X2TEMP(ICNTPT)=DISPAR(IDIS) X3D2(ICNTPT)=DISPA2(IDIS) ELSE X3D2(ICNTPT)=DISPAR(IDIS) X2TEMP(ICNTPT)=DISPA2(IDIS) ENDIF D2TEMP(ICNTPT)=ATAG IF(IFLAG.EQ.0 .AND. ICASP2.EQ.'KS ')THEN WRITE(IOUNI1,'(6E15.7)')Y2TEMP(ICNTPT), 1 XTEMP3(IDIS),XTEMP4(IDIS), 1 X2TEMP(ICNTPT),X3D2(ICNTPT), 1 D2TEMP(ICNTPT) ELSE WRITE(IOUNI1,'(4E15.7)')Y2TEMP(ICNTPT), 1 X2TEMP(ICNTPT),X3D2(ICNTPT), 1 D2TEMP(ICNTPT) ENDIF 1960 CONTINUE C DO1970J=1,NTEMP AHOLD=DISPA3(J) ATAG=ATAG+1.0 DO1975IDIS=1,NUMDIS IF(DISPA2(IDIS).EQ.AHOLD)THEN ICNTPT=ICNTPT+1 N2=N2+1 IF(ICASP2.EQ.'PPCC' .AND. IPPCCC.NE.'LINE')THEN Y2TEMP(ICNTPT)=CORRZ(IDIS) ELSE Y2TEMP(ICNTPT)=CORRV(IDIS) ENDIF IF(IPPCAO.EQ.'DEFA')THEN X2TEMP(ICNTPT)=DISPAR(IDIS) X3D2(ICNTPT)=DISPA2(IDIS) ELSE X3D2(ICNTPT)=DISPAR(IDIS) X2TEMP(ICNTPT)=DISPA2(IDIS) ENDIF D2TEMP(ICNTPT)=ATAG ENDIF 1975 CONTINUE 1970 CONTINUE C NPLOTV=3 N2=ICNTPT ENDIF C IF(IIREPL.EQ.1)THEN CALL DPWCPP(Y1,X1,N1,ICASPL,IDATSW, 1 CORRV,DISPAR,NUMDIS, 1 IBUGG3,ISUBRO,IFOUND,IERROR) ENDIF C WRITE(IOUNI3,'(I8,4E15.7)')IIREPL-1,PPCCMX,SHAPMX, 1 A0SAVE,A1SAVE C 52000 CONTINUE C DO52910II=1,ICNTPT X2(II)=X2TEMP(II) Y2(II)=Y2TEMP(II) D2(II)=D2TEMP(II) 52910 CONTINUE C IENDF1='OFF' IREWI1='ON' CALL DPCLFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1 IENDF1,IREWI1,ISUBN0,IERRF1,IBUGG3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IENDF2='OFF' IREWI2='ON' CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1 IENDF2,IREWI2,ISUBN0,IERRF2,IBUGG3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C IENDF3='OFF' IREWI3='ON' CALL DPCLFI(IOUNI3,IFILE3,ISTAT3,IFORM3,IACCE3,IPROT3,ICURS3, 1 IENDF3,IREWI3,ISUBN0,IERRF3,IBUGG3,ISUBRO,IERROR) IF(IERRF3.EQ.'YES')GOTO9000 C GOTO9000 C C ******************************************** C ** STEP 4.2-- ** C ** DETERMINE PLOT COORDINATES ** C ** FOR THE 2-VARIABLE CASE ** C ** (THAT IS, FOR THE GROUPED DATA CASE) ** C ******************************************** C 2100 CONTINUE C ICNT=0 C CCCCC APRIL 2005. ADD SUPPORT FOR REPLICATION. CCCCC NOTE: FOR GROUPED CASE, DO NOT SUPPORT A CCCCC "COMBINED" FULL SAMPLE OPTION AS WE CCCCC DO FOR UNGROUPED DATA. CCCCC APRIL 2005. ADD SUPPORT FOR UNEQUAL SIZE BINS CCCCC (X1 = LOWER LIMITS, X1UPP = UPPER LIMITS) C C C REMOVE ZERO-FREQUENCY CELLS C DO2009I=1,N1 IF(Y1(I).GT.0.0)THEN ICNT=ICNT+1 Y2(ICNT)=Y1(I) D2(ICNT)=X1(I) X1UTMP(ICNT)=X1UPP(I) XTEMP6(ICNT)=XREPL(I) ENDIF 2009 CONTINUE N1=ICNT DO2019I=1,N1 Y1(I)=REAL(INT(Y2(I)+0.5)) X1(I)=D2(I) X1UPP(I)=X1UTMP(I) XREPL(I)=XTEMP6(I) 2019 CONTINUE C IF(MINSIZ.LT.1)MINSIZ=1 C IOUNI1=IST1NU IFILE1=IST1NA ISTAT1=IST1ST IFORM1=IST1FO IACCE1=IST1AC IPROT1=IST1PR ICURS1=IST1CS ISUBN0='PPC2' IERRF1='NO' C IREWI1='ON' CALL DPOPFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1 IREWI1,ISUBN0,IERRF1,IBUGG3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C CCCCC OCTOBER 2004. WRITE PPCC VALUE, LOCATION, SCALE, AND SHAPE CCCCC PARAMETERS TO FILE DPST1F.DAT. C IOUNI2=IST2NU IFILE2=IST2NA ISTAT2=IST2ST IFORM2=IST2FO IACCE2=IST2AC IPROT2=IST2PR ICURS2=IST2CS ISUBN0='PPC2' IERRF2='NO' C IREWI2='ON' CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1 IREWI2,ISUBN0,IERRF2,IBUGG3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C IOUNI3=IST3NU IFILE3=IST3NA ISTAT3=IST3ST IFORM3=IST3FO IACCE3=IST3AC IPROT3=IST3PR ICURS3=IST3CS ISUBN0='PPC2' IERRF3='NO' C IREWI3='ON' CALL DPOPFI(IOUNI3,IFILE3,ISTAT3,IFORM3,IACCE3,IPROT3,ICURS3, 1 IREWI3,ISUBN0,IERRF3,IBUGG3,ISUBRO,IERROR) IF(IERRF3.EQ.'YES')GOTO9000 C C START REPLICATION LOOP C IF(IREPL.EQ.'OFF')THEN NREPL=1 ELSE DO71010I=1,N1 XTEMP6(I)=Y1(I) XCENS(I)=X1(I) X1UTMP(I)=X1UPP(I) 71010 CONTINUE NREPL=NREPL+1 ENDIF C N1SAVE=N1 ICNTPT=0 DO72000IIREPL=1,NREPL C N1=N1SAVE SHAPMX=CPUMIN PPCCMX=CPUMIN C IF(NREPL.GT.1)THEN REPTMP=XREPDS(IIREPL-1) NTEMP=0 DO72100II=1,N1 IF(XREPL(II).EQ.REPTMP)THEN NTEMP=NTEMP+1 Y1(NTEMP)=XTEMP6(II) X1(NTEMP)=XCENS(II) Y3(NTEMP)=Y1(NTEMP) XLOW(NTEMP)=X1(NTEMP) IF(IDATSW.EQ.'FREQ')THEN XHIGH(NTEMP)=X1(NTEMP) ELSE X1UPP(NTEMP)=X1UTMP(II) XHIGH(NTEMP)=X1UPP(NTEMP) X1(NTEMP)=(XLOW(NTEMP) + XHIGH(NTEMP))/2.0 ENDIF ENDIF 72100 CONTINUE N1=NTEMP IF(N1.LE.1)THEN WRITE(ICOUT,72104) 72104 FORMAT('***** WARNING IN PPCC PLOT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72105) 72105 FORMAT(' REPLICATION ',I8,' CONTAINS FEWER THAN ', 1 'TWO ELEMENTS AND WILL BE SKIPPED.') GOTO72000 ENDIF ELSE DO72108I=1,N1 Y3(I)=Y1(I) IF(IDATSW.EQ.'FREQ')THEN XLOW(I)=X1(I) XHIGH(I)=X1(I) ELSE XLOW(I)=X1(I) XHIGH(I)=X1UPP(I) X1(I)=(XLOW(I) + XHIGH(I))/2.0 ENDIF 72108 CONTINUE ENDIF C IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PPC2')THEN WRITE(ICOUT,72111)IIREPL,N1 72111 FORMAT('IIREPL,N1,NCLASS = ',3I8) CALL DPWRST('XXX','BUG ') DO72113II=1,N1 WRITE(ICOUT,72112)II,X1(II),XLOW(II),XHIGH(II),Y1(II) 72112 FORMAT('II,X1(II),XLOW(II),XHIGH(II),Y1(II) = ', 1 I8,4G15.7) CALL DPWRST('XXX','BUG ') 72113 CONTINUE ENDIF C CCCCC CALL DPCOMB(Y1,X1,N1,MINSIZ, CCCCC1 Y3,XLOW,XHIGH,N3,'OFF ',IERROR) N3=N1 C CALL SORTC(X1,Y1,N1,Y2,D2) C SUM=0.0 DO2001I=1,N1 SUM=SUM+Y1(I) 2001 CONTINUE NTOT=SUM+0.5 IF(IDATSW.EQ.'FREQ')THEN XDEL=Y2(2)-Y2(1) XMIN=Y2(1) - (XDEL/2.0) ELSE XMIN=Y2(1) ENDIF C IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PPC2')THEN WRITE(ICOUT,72204)IIREPL,N1 72204 FORMAT('IIREPL,N1 = ',2I8) CALL DPWRST('XXX','BUG ') DO72206II=1,N1 WRITE(ICOUT,72207)II,X1(II),Y1(II),Y2(II),D2(II) 72207 FORMAT('II,X1(II),Y1(II),Y2(II),D2(I)) = ',I8,4G15.7) CALL DPWRST('XXX','BUG ') 72206 CONTINUE ENDIF C DO2105IDIS=1,NUMDIS C IF(ICASPL.EQ.'LACP')GOTO2110 IF(ICASPL.EQ.'TCP')GOTO2120 IF(ICASPL.EQ.'CSCP')GOTO2130 IF(ICASPL.EQ.'GACP')GOTO2140 IF(ICASPL.EQ.'WECP')GOTO2150 IF(ICASPL.EQ.'E2CP')GOTO2160 IF(ICASPL.EQ.'PACP')GOTO2170 IF(ICASPL.EQ.'GECP')GOTO2180 IF(ICASPL.EQ.'POCP')GOTO2190 IF(ICASPL.EQ.'IGCP')GOTO2200 IF(ICASPL.EQ.'WACP')GOTO2210 IF(ICASPL.EQ.'RICP')GOTO2220 IF(ICASPL.EQ.'FLCP')GOTO2230 IF(ICASPL.EQ.'GPCP')GOTO2250 IF(ICASPL.EQ.'LNCP')GOTO2260 IF(ICASPL.EQ.'PNCP')GOTO2270 IF(ICASPL.EQ.'PLCP')GOTO2280 IF(ICASPL.EQ.'PFCP')GOTO2290 IF(ICASPL.EQ.'CHCP')GOTO2300 IF(ICASPL.EQ.'VMCP')GOTO2310 IF(ICASPL.EQ.'LLCP')GOTO2320 IF(ICASPL.EQ.'LGCP')GOTO2330 IF(ICASPL.EQ.'DWCP')GOTO2340 IF(ICASPL.EQ.'GVCP')GOTO2350 IF(ICASPL.EQ.'P2CP')GOTO2360 IF(ICASPL.EQ.'GZCP')GOTO2370 IF(ICASPL.EQ.'WCCP')GOTO2380 IF(ICASPL.EQ.'GLCP')GOTO2390 IF(ICASPL.EQ.'DGCP')GOTO2400 IF(ICASPL.EQ.'BRCP')GOTO2410 IF(ICASPL.EQ.'RECP')GOTO2420 IF(ICASPL.EQ.'BICP')GOTO2430 IF(ICASPL.EQ.'NBCP')GOTO2440 IF(ICASPL.EQ.'DLCP')GOTO2450 IF(ICASPL.EQ.'GICP')GOTO2460 IF(ICASPL.EQ.'IWCP')GOTO2470 IF(ICASPL.EQ.'LXCP')GOTO2480 IF(ICASPL.EQ.'TRCP')GOTO2490 IF(ICASPL.EQ.'EECP')GOTO2500 IF(ICASPL.EQ.'ERCP')GOTO2510 IF(ICASPL.EQ.'FTCP')GOTO2520 IF(ICASPL.EQ.'FCP')GOTO2530 IF(ICASPL.EQ.'SNCP')GOTO2540 IF(ICASPL.EQ.'SDCP')GOTO2550 IF(ICASPL.EQ.'ADCP')GOTO2560 IF(ICASPL.EQ.'MXCP')GOTO2570 IF(ICASPL.EQ.'MCCP')GOTO2580 IF(ICASPL.EQ.'NZCP')GOTO2590 IF(ICASPL.EQ.'LDCP')GOTO2600 IF(ICASPL.EQ.'BECP')GOTO2610 IF(ICASPL.EQ.'GGCP')GOTO2620 IF(ICASPL.EQ.'GOCP')GOTO2630 IF(ICASPL.EQ.'PECP')GOTO2640 IF(ICASPL.EQ.'EWCP')GOTO2650 IF(ICASPL.EQ.'JBCP')GOTO2660 IF(ICASPL.EQ.'JUCP')GOTO2670 IF(ICASPL.EQ.'ALCP')GOTO2680 IF(ICASPL.EQ.'TSCP')GOTO2690 IF(ICASPL.EQ.'STCP')GOTO2700 IF(ICASPL.EQ.'IBCP')GOTO2710 IF(ICASPL.EQ.'GHCP')GOTO2720 IF(ICASPL.EQ.'LZCP')GOTO2730 IF(ICASPL.EQ.'NCCP')GOTO2740 IF(ICASPL.EQ.'NXCP')GOTO2750 IF(ICASPL.EQ.'NTCP')GOTO2760 IF(ICASPL.EQ.'NYCP')GOTO2770 IF(ICASPL.EQ.'FNCP')GOTO2780 IF(ICASPL.EQ.'FCCP')GOTO2790 IF(ICASPL.EQ.'TECP')GOTO22800 IF(ICASPL.EQ.'TXCP')GOTO22810 IF(ICASPL.EQ.'BBCP')GOTO22820 IF(ICASPL.EQ.'PZCP')GOTO22830 IF(ICASPL.EQ.'YUCP')GOTO22840 IF(ICASPL.EQ.'WRCP')GOTO22850 IF(ICASPL.EQ.'HECP')GOTO22860 IF(ICASPL.EQ.'GMCP')GOTO22870 IF(ICASPL.EQ.'GACP')GOTO22880 IF(ICASPL.EQ.'GMLP')GOTO22890 IF(ICASPL.EQ.'G5CP')GOTO22900 IF(ICASPL.EQ.'BNCP')GOTO22910 IF(ICASPL.EQ.'G2CP')GOTO22920 IF(ICASPL.EQ.'G3CP')GOTO22930 IF(ICASPL.EQ.'G4CP')GOTO22940 IF(ICASPL.EQ.'AXCP')GOTO22950 IF(ICASPL.EQ.'BGCP')GOTO22960 IF(ICASPL.EQ.'ZECP')GOTO22970 IF(ICASPL.EQ.'ZICP')GOTO22980 IF(ICASPL.EQ.'BTCP')GOTO22990 IF(ICASPL.EQ.'LPCP')GOTO23000 IF(ICASPL.EQ.'LBCP')GOTO23010 IF(ICASPL.EQ.'AECP')GOTO23020 IF(ICASPL.EQ.'LOST')GOTO23030 IF(ICASPL.EQ.'GSCP')GOTO23040 IF(ICASPL.EQ.'GETC')GOTO23050 IF(ICASPL.EQ.'QBCP')GOTO23060 IF(ICASPL.EQ.'CNCP')GOTO23070 IF(ICASPL.EQ.'KZCP')GOTO23080 IF(ICASPL.EQ.'DIWP')GOTO23090 IF(ICASPL.EQ.'GLGP')GOTO23100 C 2110 CONTINUE ALAMBA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN IF(ALAMBA.GT.0.0)THEN AMAX=ABS(1.0/ALAMBA) AMIN=-AMAX ELSE AMIN=CPUMIN AMAX=CPUMAX ENDIF IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2111I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2111 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2112K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL LAMPPF(UNIOSM,ALAMBA,DISOSM) SUM=SUM+DISOSM 2112 CONTINUE X2(I)=SUM/ANI 2111 CONTINUE GOTO2800 C 2120 CONTINUE CCCCC NU=DISPAR(IDIS)+0.5 ANU=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2121I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2121 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2122K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CCCCC CALL TPPF(UNIOSM,NU,DISOSM) CALL TPPF(UNIOSM,ANU,DISOSM) SUM=SUM+DISOSM 2122 CONTINUE X2(I)=SUM/ANI 2121 CONTINUE GOTO2800 C 2130 CONTINUE NU=DISPAR(IDIS)+0.5 C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2131I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2131 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2132K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL CHSPPF(UNIOSM,NU,DISOSM) SUM=SUM+DISOSM 2132 CONTINUE X2(I)=SUM/ANI 2131 CONTINUE GOTO2800 C 2140 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2141I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2141 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2142K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GAMPPF(UNIOSM,GAMMA,DISOSM) SUM=SUM+DISOSM 2142 CONTINUE X2(I)=SUM/ANI 2141 CONTINUE GOTO2800 C 2150 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN IF(MINMAX.EQ.1)THEN AMIN=0.0 AMAX=CPUMAX ELSE AMIN=CPUMIN AMAX=0.0 ENDIF IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2151I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2151 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2152K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL WEIPPF(UNIOSM,GAMMA,MINMAX,DISOSM) SUM=SUM+DISOSM 2152 CONTINUE X2(I)=SUM/ANI 2151 CONTINUE GOTO2800 C 2160 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN IF(MINMAX.EQ.1)THEN AMIN=CPUMIN AMAX=0.0 ELSE AMIN=0.0 AMAX=CPUMAX ENDIF IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2161I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2161 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2162K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL EV2PPF(UNIOSM,GAMMA,MINMAX,DISOSM) SUM=SUM+DISOSM 2162 CONTINUE X2(I)=SUM/ANI 2161 CONTINUE GOTO2800 C 2170 CONTINUE A=A1 IF(A.GT.XMIN)A=XMIN GAMMA=DISPAR(IDIS) IF(ICASP2.EQ.'KS ')THEN AMIN=A AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2171I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2171 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2172K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL PARPPF(UNIOSM,GAMMA,A,DISOSM) SUM=SUM+DISOSM 2172 CONTINUE X2(I)=SUM/ANI 2171 CONTINUE GOTO2800 C 2180 CONTINUE P=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO2181I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2181 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2182K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GEOPPF(UNIOSM,P,DISOSM) SUM=SUM+DISOSM 2182 CONTINUE X2(I)=SUM/ANI 2181 CONTINUE GOTO2800 C 2190 CONTINUE ALAMBA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO2191I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2191 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2192K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL POIPPF(UNIOSM,ALAMBA,DISOSM) SUM=SUM+DISOSM 2192 CONTINUE X2(I)=SUM/ANI 2191 CONTINUE GOTO2800 C 2200 CONTINUE GAMMA=DISPAR(IDIS) AMU=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2201I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2201 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2202K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL IGPPF(UNIOSM,GAMMA,AMU,DISOSM) SUM=SUM+DISOSM 2202 CONTINUE X2(I)=SUM/ANI 2201 CONTINUE GOTO2800 C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1990 2210 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2211I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2211 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2212K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL WALPPF(UNIOSM,GAMMA,DISOSM) SUM=SUM+DISOSM 2212 CONTINUE X2(I)=SUM/ANI 2211 CONTINUE GOTO2800 C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1990 2220 CONTINUE GAMMA=DISPAR(IDIS) AMU=DISPA2(IDIS) AMUTMP=1.0 C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2221I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2221 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2222K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL RIGPPF(UNIOSM,GAMMA,AMUTMP,DISOSM) SUM=SUM+DISOSM 2222 CONTINUE X2(I)=SUM/ANI 2221 CONTINUE GOTO2800 C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1990 2230 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2231I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2231 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2232K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL FLPPF(UNIOSM,GAMMA,DISOSM) SUM=SUM+DISOSM 2232 CONTINUE X2(I)=SUM/ANI 2231 CONTINUE GOTO2800 C 2250 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN IF(GAMMA.GE.0.0)THEN AMIN=0.0 AMAX=CPUMAX ELSE AMIN=0.0 AMAX=-(1.0/GAMMA) ENDIF IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2251I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2251 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2252K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GEPPPF(UNIOSM,GAMMA,MINMAX,IGEPDF,DISOSM) SUM=SUM+DISOSM 2252 CONTINUE X2(I)=SUM/ANI 2251 CONTINUE GOTO2800 C 2260 CONTINUE SIGMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2261I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2261 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2262K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL LGNPPF(UNIOSM,SIGMA,DISOSM) SUM=SUM+DISOSM 2262 CONTINUE X2(I)=SUM/ANI 2261 CONTINUE GOTO2800 C 2270 CONTINUE P=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2271I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2271 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2272K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL PNRPPF(UNIOSM,P,SD,DISOSM) SUM=SUM+DISOSM 2272 CONTINUE X2(I)=SUM/ANI 2271 CONTINUE GOTO2800 C 2280 CONTINUE P=DISPAR(IDIS) SD=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2281I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2281 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2282K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL PLNPPF(UNIOSM,P,SD,DISOSM) SUM=SUM+DISOSM 2282 CONTINUE X2(I)=SUM/ANI 2281 CONTINUE GOTO2800 C 2290 CONTINUE C=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=1.0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2291I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2291 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2292K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL POWPPF(UNIOSM,C,DISOSM) SUM=SUM+DISOSM 2292 CONTINUE X2(I)=SUM/ANI 2291 CONTINUE GOTO2800 C 2300 CONTINUE ANU=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2301I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2301 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2302K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL CHPPF(UNIOSM,ANU,DISOSM) SUM=SUM+DISOSM 2302 CONTINUE X2(I)=SUM/ANI 2301 CONTINUE GOTO2800 C 2310 CONTINUE B=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=-PI AMAX=PI IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2311I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2311 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2312K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL VONPPF(UNIOSM,B,DISOSM) SUM=SUM+DISOSM 2312 CONTINUE X2(I)=SUM/ANI 2311 CONTINUE GOTO2800 C 2320 CONTINUE DELTA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2321I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2321 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2322K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL LLGPPF(UNIOSM,DELTA,DISOSM) SUM=SUM+DISOSM 2322 CONTINUE X2(I)=SUM/ANI 2321 CONTINUE GOTO2800 C 2330 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2331I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2331 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2332K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL LGAPPF(UNIOSM,GAMMA,ILGADF,DISOSM) SUM=SUM+DISOSM 2332 CONTINUE X2(I)=SUM/ANI 2331 CONTINUE GOTO2800 C 2340 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2341I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2341 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2342K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL DWEPPF(UNIOSM,GAMMA,DISOSM) SUM=SUM+DISOSM 2342 CONTINUE X2(I)=SUM/ANI 2341 CONTINUE GOTO2800 C 2350 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN IF(GAMMA.GT.0.0)THEN AMIN=CPUMIN AMAX=(1.0/GAMMA) - 0.1E-6 ELSE AMIN=(1.0/GAMMA) + 0.1E-6 AMAX=CPUMAX ENDIF ELSE IF(GAMMA.GT.0.0)THEN AMIN=(-1.0/GAMMA) + 0.1E-6 AMAX=CPUMAX ELSE AMIN=CPUMIN AMAX=(-1.0/GAMMA) - 0.1E-6 ENDIF ENDIF IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2351I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2351 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2352K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GEVPPF(UNIOSM,GAMMA,MINMAX,DISOSM) SUM=SUM+DISOSM 2352 CONTINUE X2(I)=SUM/ANI 2351 CONTINUE GOTO2800 C 2360 CONTINUE IF(A.LE.0.0)A=1.0 GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2361I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2361 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2362K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL PA2PPF(UNIOSM,GAMMA,A,DISOSM) SUM=SUM+DISOSM 2362 CONTINUE X2(I)=SUM/ANI 2361 CONTINUE GOTO2800 C 2370 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=1.0/GAMMA IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2371I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2371 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2372K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL HFLPPF(UNIOSM,GAMMA,DISOSM) SUM=SUM+DISOSM 2372 CONTINUE X2(I)=SUM/ANI 2371 CONTINUE GOTO2800 C 2380 CONTINUE P=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=2.0*PI IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2381I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2381 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2382K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL WCAPPF(UNIOSM,P,DISOSM) SUM=SUM+DISOSM 2382 CONTINUE X2(I)=SUM/ANI 2381 CONTINUE GOTO2800 C 2390 CONTINUE ALPHA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2391I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2391 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2392K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GLOPPF(UNIOSM,ALPHA,DISOSM) SUM=SUM+DISOSM 2392 CONTINUE X2(I)=SUM/ANI 2391 CONTINUE GOTO2800 C 2400 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2401I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2401 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2402K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL DGAPPF(UNIOSM,GAMMA,DISOSM) SUM=SUM+DISOSM 2402 CONTINUE X2(I)=SUM/ANI 2401 CONTINUE GOTO2800 C 2410 CONTINUE BETA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=1.0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2411I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2411 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2412K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL BRAPPF(UNIOSM,BETA,DISOSM) SUM=SUM+DISOSM 2412 CONTINUE X2(I)=SUM/ANI 2411 CONTINUE GOTO2800 C 2420 CONTINUE B=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=1.0/B AMAX=1.0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2421I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2421 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2422K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL RECPPF(UNIOSM,B,DISOSM) SUM=SUM+DISOSM 2422 CONTINUE X2(I)=SUM/ANI 2421 CONTINUE GOTO2800 C 2430 CONTINUE P=DISPAR(IDIS) NPAR=NBINOM C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO2431I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2431 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2432K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL BINPPF(UNIOSM,P,NBINOM,DISOSM) SUM=SUM+DISOSM 2432 CONTINUE X2(I)=SUM/ANI 2431 CONTINUE GOTO2800 C 2440 CONTINUE P=DISPAR(IDIS) AK=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO2441I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2441 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2442K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL NBPPF(UNIOSM,P,AK,DISOSM) SUM=SUM+DISOSM 2442 CONTINUE X2(I)=SUM/ANI 2441 CONTINUE GOTO2800 C 2450 CONTINUE THETA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO2451I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2451 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2452K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL DLGPPF(UNIOSM,THETA,DISOSM) SUM=SUM+DISOSM 2452 CONTINUE X2(I)=SUM/ANI 2451 CONTINUE GOTO2800 C 2460 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2461I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2461 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2462K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL IGAPPF(UNIOSM,GAMMA,DISOSM) SUM=SUM+DISOSM 2462 CONTINUE X2(I)=SUM/ANI 2461 CONTINUE GOTO2800 C 2470 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2471I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2471 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2472K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL IWEPPF(UNIOSM,GAMMA,DISOSM) SUM=SUM+DISOSM 2472 CONTINUE X2(I)=SUM/ANI 2471 CONTINUE GOTO2800 C 2480 CONTINUE ALPHA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2481I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2481 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2482K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL LDEPPF(UNIOSM,ALPHA,DISOSM) SUM=SUM+DISOSM 2482 CONTINUE X2(I)=SUM/ANI 2481 CONTINUE GOTO2800 C 2490 CONTINUE ZLOWLM=-1.0 ZUPPLM=1.0 C=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=-1.0 AMAX=1.0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2491I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2491 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2492K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL TRIPPF(UNIOSM,C,ZLOWLM,ZUPPLM,DISOSM) SUM=SUM+DISOSM 2492 CONTINUE X2(I)=SUM/ANI 2491 CONTINUE GOTO2800 C 2500 CONTINUE GAMMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2501I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2501 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2502K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GEEPPF(UNIOSM,GAMMA,DISOSM) SUM=SUM+DISOSM 2502 CONTINUE X2(I)=SUM/ANI 2501 CONTINUE GOTO2800 C 2510 CONTINUE ALPHA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2511I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2511 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2512K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL ERRPPF(UNIOSM,ALPHA,DISOSM) SUM=SUM+DISOSM 2512 CONTINUE X2(I)=SUM/ANI 2511 CONTINUE GOTO2800 C 2520 CONTINUE NU=INT(DISPAR(IDIS)+0.5) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2521I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2521 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2522K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL FTPPF(UNIOSM,NU,DISOSM) SUM=SUM+DISOSM 2522 CONTINUE X2(I)=SUM/ANI 2521 CONTINUE GOTO2800 C 2530 CONTINUE NU1=INT(DISPAR(IDIS)+0.5) NU2=INT(DISPA2(IDIS)+0.5) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2531I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2531 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2532K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL FPPF(UNIOSM,NU1,NU2,DISOSM) SUM=SUM+DISOSM 2532 CONTINUE X2(I)=SUM/ANI 2531 CONTINUE GOTO2800 C 2540 CONTINUE ALAMB=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2541I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2541 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2542K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL SNPPF(UNIOSM,ALAMB,ISKNDF,DISOSM) SUM=SUM+DISOSM 2542 CONTINUE X2(I)=SUM/ANI 2541 CONTINUE GOTO2800 C 2550 CONTINUE ALAMB=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2551I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2551 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2552K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL SDEPPF(UNIOSM,ALAMB,DISOSM) SUM=SUM+DISOSM 2552 CONTINUE X2(I)=SUM/ANI 2551 CONTINUE GOTO2800 C 2560 CONTINUE IF(IADEDF.EQ.'K')THEN AK=DISPAR(IDIS) ATEMP=AK ELSE AMU=DISPAR(IDIS) ATEMP=AMU ENDIF C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2561I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2561 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2562K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL ADEPPF(UNIOSM,ATEMP,IADEDF,DISOSM) SUM=SUM+DISOSM 2562 CONTINUE X2(I)=SUM/ANI 2561 CONTINUE GOTO2800 C 2570 CONTINUE SIGMA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2571I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2571 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2572K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL MAXPPF(UNIOSM,SIGMA,DISOSM) SUM=SUM+DISOSM 2572 CONTINUE X2(I)=SUM/ANI 2571 CONTINUE GOTO2800 C 2580 CONTINUE ALPHA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2581I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2581 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2582K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL MCLPPF(DBLE(UNIOSM),DBLE(ALPHA),DPPF) DISOSM=REAL(DPPF) SUM=SUM+DISOSM 2582 CONTINUE X2(I)=SUM/ANI 2581 CONTINUE GOTO2800 C 2590 CONTINUE P=DISPAR(IDIS) AK=AK1 C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO2591I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2591 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2592K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL NBPPF(UNIOSM,P,AK,DISOSM) SUM=SUM+DISOSM 2592 CONTINUE X2(I)=SUM/ANI 2591 CONTINUE GOTO2800 C 2600 CONTINUE ALAM3=DISPAR(IDIS) ALAM4=DISPA2(IDIS) CCCCC IF(IGLDDF.EQ.'RAMB')THEN CCCCC ZSCALE=1.0 CCCCC IWRITE='OFF' CCCCC CALL GLDCHK(ALAM3,ALAM4,ALOWER,AUPPER,IFLAG,ISIGN,IWRITE) CCCCC IF(ISIGN.LT.0)ZSCALE=-1.0 CCCCC ENDIF C IF(ICASP2.EQ.'KS ')THEN IWRITE='ERRO' IF(ALAM3.EQ.0.0 .AND. ALAM4.EQ.0.0)THEN AMIN=CPUMIN AMAX=CPUMAX ELSEIF(ALAM3.EQ.0.0)THEN AMIN=CPUMIN CALL GLDPPF(1.0D0,DBLE(ALAM3),DBLE(ALAM4),DPPF, 1 IGLDDF,IWRITE) AMAX=REAL(DPPF) ELSEIF(ALAM4.EQ.0.0)THEN AMAX=CPUMAX CALL GLDPPF(0.0D0,DBLE(ALAM3),DBLE(ALAM4),DPPF, 1 IGLDDF,IWRITE) AMIN=REAL(DPPF) ELSE CALL GLDPPF(0.0D0,DBLE(ALAM3),DBLE(ALAM4),DPPF, 1 IGLDDF,IWRITE) AMIN=REAL(DPPF) CALL GLDPPF(1.0D0,DBLE(ALAM3),DBLE(ALAM4),DPPF, 1 IGLDDF,IWRITE) AMAX=REAL(DPPF) ENDIF IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2601I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2601 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2602K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GLDPPF(DBLE(UNIOSM),DBLE(ALAM3),DBLE(ALAM4), 1 DPPF,IGLDDF,IWRITE) DISOSM=REAL(DPPF) SUM=SUM+DISOSM 2602 CONTINUE X2(I)=SUM/ANI 2601 CONTINUE GOTO2800 C 2610 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=1.0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2611I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2611 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2612K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL BETPPF(UNIOSM,ALPHA,BETA,DISOSM) SUM=SUM+DISOSM 2612 CONTINUE X2(I)=SUM/ANI 2611 CONTINUE GOTO2800 C 2620 CONTINUE C=DISPAR(IDIS) ALPHA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2621I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2621 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2622K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GGDPPF(UNIOSM,ALPHA,C,DISOSM) SUM=SUM+DISOSM 2622 CONTINUE X2(I)=SUM/ANI 2621 CONTINUE GOTO2800 C 2630 CONTINUE C=DISPAR(IDIS) B=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2631I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2631 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2632K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GOMPPF(UNIOSM,C,B,DISOSM) SUM=SUM+DISOSM 2632 CONTINUE X2(I)=SUM/ANI 2631 CONTINUE GOTO2800 C 2640 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2641I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2641 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2642K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL PEXPPF(UNIOSM,ALPHA,BETA,DISOSM) SUM=SUM+DISOSM 2642 CONTINUE X2(I)=SUM/ANI 2641 CONTINUE GOTO2800 C 2650 CONTINUE GAMMA=DISPAR(IDIS) THETA=DISPA2(IDIS) IARG1=1 C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2651I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2651 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2652K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL EWEPPF(UNIOSM,GAMMA,THETA,IARG1,DISOSM) SUM=SUM+DISOSM 2652 CONTINUE X2(I)=SUM/ANI 2651 CONTINUE GOTO2800 C 2660 CONTINUE ALPHA1=DISPAR(IDIS) ALPHA2=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=1.0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2661I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2661 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2662K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL JSBPPF(UNIOSM,ALPHA1,ALPHA2,DISOSM) SUM=SUM+DISOSM 2662 CONTINUE X2(I)=SUM/ANI 2661 CONTINUE GOTO2800 C 2670 CONTINUE ALPHA1=DISPAR(IDIS) ALPHA2=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2671I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2671 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2672K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL JSUPPF(UNIOSM,ALPHA1,ALPHA2,DISOSM) SUM=SUM+DISOSM 2672 CONTINUE X2(I)=SUM/ANI 2671 CONTINUE GOTO2800 C 2680 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2681I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2681 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2682K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL ALPPPF(UNIOSM,ALPHA,BETA,DISOSM) SUM=SUM+DISOSM 2682 CONTINUE X2(I)=SUM/ANI 2681 CONTINUE GOTO2800 C 2690 CONTINUE THETA=DISPAR(IDIS) ANU=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=1.0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2691I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2691 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2692K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL TSPPPF(UNIOSM,THETA,ANU,DISOSM) SUM=SUM+DISOSM 2692 CONTINUE X2(I)=SUM/ANI 2691 CONTINUE GOTO2800 C 2700 CONTINUE NU=INT(DISPAR(IDIS)+0.5) ALAMBA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2701I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2701 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2702K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL STPPF(UNIOSM,NU,ALAMBA,DISOSM) SUM=SUM+DISOSM 2702 CONTINUE X2(I)=SUM/ANI 2701 CONTINUE GOTO2800 C 2710 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2711I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2711 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2712K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL IBPPF(UNIOSM,ALPHA,BETA,DISOSM) SUM=SUM+DISOSM 2712 CONTINUE X2(I)=SUM/ANI 2711 CONTINUE GOTO2800 C 2720 CONTINUE H=DISPAR(IDIS) G=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2721I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2721 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2722K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GHPPF(UNIOSM,G,H,DISOSM,DBLE(UNIOSM),DPPF) DISOSM=REAL(DPPF) SUM=SUM+DISOSM 2722 CONTINUE X2(I)=SUM/ANI 2721 CONTINUE GOTO2800 C 2730 CONTINUE SD=DISPAR(IDIS) ALAMBA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2731I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2731 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2732K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL LSNPPF(UNIOSM,ALAMBA,SD,DISOSM) SUM=SUM+DISOSM 2732 CONTINUE X2(I)=SUM/ANI 2731 CONTINUE GOTO2800 C 2740 CONTINUE ANU=DISPAR(IDIS) ALAMBA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2741I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2741 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2742K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL NCCPPF(UNIOSM,ANU,ALAMBA,DISOSM) SUM=SUM+DISOSM 2742 CONTINUE X2(I)=SUM/ANI 2741 CONTINUE GOTO2800 C 2750 CONTINUE ANU=REAL(NU1) ALAMBA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2751I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2751 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2752K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL NCCPPF(UNIOSM,ANU,ALAMBA,DISOSM) SUM=SUM+DISOSM 2752 CONTINUE X2(I)=SUM/ANI 2751 CONTINUE GOTO2800 C 2760 CONTINUE ANU=DISPAR(IDIS) ALAMBA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2761I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2761 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2762K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL NCTPPF(UNIOSM,ANU,ALAMBA,DISOSM) SUM=SUM+DISOSM 2762 CONTINUE X2(I)=SUM/ANI 2761 CONTINUE GOTO2800 C 2770 CONTINUE ANU=REAL(NU1) ALAMBA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2771I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2771 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2772K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL NCTPPF(UNIOSM,ANU,ALAMBA,DISOSM) SUM=SUM+DISOSM 2772 CONTINUE X2(I)=SUM/ANI 2771 CONTINUE GOTO2800 C 2780 CONTINUE AM=DISPAR(IDIS) SD=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2781I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2781 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2782K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL FNRPPF(UNIOSM,AM,SD,DISOSM) SUM=SUM+DISOSM 2782 CONTINUE X2(I)=SUM/ANI 2781 CONTINUE GOTO2800 C 2790 CONTINUE AM=DISPAR(IDIS) SD=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO2791I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO2791 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2792K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL FCAPPF(UNIOSM,AM,SD,DISOSM) SUM=SUM+DISOSM 2792 CONTINUE X2(I)=SUM/ANI 2791 CONTINUE GOTO2800 C 22800 CONTINUE AMU=DISPAR(IDIS) SD=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=AMU AMAX=X0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO22801I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO22801 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO22802K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL TNEPPF(UNIOSM,X0,AMU,SD,DISOSM) SUM=SUM+DISOSM 22802 CONTINUE X2(I)=SUM/ANI 22801 CONTINUE GOTO2800 C 22810 CONTINUE AMU=AMU1 SD=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=AMU AMAX=X0 IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO22811I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO22811 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO22812K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL TNEPPF(UNIOSM,X0,AMU,SD,DISOSM) SUM=SUM+DISOSM 22812 CONTINUE X2(I)=SUM/ANI 22811 CONTINUE GOTO2800 C 22820 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO22821I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO22821 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO22822K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL BBNPPF(UNIOSM,ALPHA,BETA,NU,DISOSM) SUM=SUM+DISOSM 22822 CONTINUE X2(I)=SUM/ANI 22821 CONTINUE GOTO2800 C 22830 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO22831I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO22831 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO22832K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL POLPPF(UNIOSM,ALPHA,BETA,NU,DISOSM) SUM=SUM+DISOSM 22832 CONTINUE X2(I)=SUM/ANI 22831 CONTINUE GOTO2800 C 22840 CONTINUE P=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO22841I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO22841 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO22842K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL YULPPF(UNIOSM,P,DISOSM) SUM=SUM+DISOSM 22842 CONTINUE X2(I)=SUM/ANI 22841 CONTINUE GOTO2800 C 22850 CONTINUE C=DISPAR(IDIS) A=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO22851I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO22851 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO22852K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL WARPPF(UNIOSM,C,A,DISOSM,'NOTR') SUM=SUM+DISOSM 22852 CONTINUE X2(I)=SUM/ANI 22851 CONTINUE GOTO2800 C 22860 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO22861I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO22861 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO22862K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL HERPPF(UNIOSM,ALPHA,BETA,DISOSM) SUM=SUM+DISOSM 22862 CONTINUE X2(I)=SUM/ANI 22861 CONTINUE GOTO2800 C 22870 CONTINUE ETA=DISPAR(IDIS) ZETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=0.0 AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO22871I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO22871 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO22872K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL MA2PPF(UNIOSM,ZETA,ETA,DISOSM) SUM=SUM+DISOSM 22872 CONTINUE X2(I)=SUM/ANI 22871 CONTINUE GOTO2800 C 22880 CONTINUE AK=DISPAR(IDIS) TAU=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO22881I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO22881 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO22882K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GALPPF(DBLE(UNIOSM),DBLE(AK),DBLE(TAU),IADEDF,DPPF) DISOSM=REAL(DPPF) SUM=SUM+DISOSM 22882 CONTINUE X2(I)=SUM/ANI 22881 CONTINUE GOTO2800 C 22890 CONTINUE A=DISPAR(IDIS) ALPHA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO22891I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO22891 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO22892K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GMCPPF(DBLE(UNIOSM),DBLE(ALPHA),DBLE(A),DPPF) DISOSM=REAL(DPPF) SUM=SUM+DISOSM 22892 CONTINUE X2(I)=SUM/ANI 22891 CONTINUE GOTO2800 C 22900 CONTINUE ALPHA=DISPAR(IDIS) XPAR(1)=0.0D0 XPAR(2)=1.0D0 XPAR(3)=DBLE(ALPHA) C IF(ICASP2.EQ.'KS ')THEN IF(ALPHA.GT.0.0)THEN AMIN=CPUMIN AMAX=1.0/ALPHA ELSEIF(ALPHA.LT.0.0)THEN AMIN=1.0/ALPHA AMAX=CPUMAX ELSE AMIN=CPUMIN AMAX=CPUMAX ENDIF IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO22901I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO22901 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO22902K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) DPPF=QUAGLO(DBLE(UNIOSM),XPAR) DISOSM=REAL(DPPF) SUM=SUM+DISOSM 22902 CONTINUE X2(I)=SUM/ANI 22901 CONTINUE GOTO2800 C 22910 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO22911I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO22911 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO22912K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL BNOPPF(DBLE(UNIOSM),DBLE(ALPHA),DBLE(BETA),DPPF) DISOSM=REAL(DPPF) SUM=SUM+DISOSM 22912 CONTINUE X2(I)=SUM/ANI 22911 CONTINUE GOTO2800 C 22920 CONTINUE ALPHA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO22921I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO22921 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO22922K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GL2PPF(DBLE(UNIOSM),DBLE(ALPHA),DPPF) DISOSM=REAL(DPPF) SUM=SUM+DISOSM 22922 CONTINUE X2(I)=SUM/ANI 22921 CONTINUE GOTO2800 C 22930 CONTINUE ALPHA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO22931I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO22931 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO22932K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GL3PPF(DBLE(UNIOSM),DBLE(ALPHA),DPPF) DISOSM=REAL(DPPF) SUM=SUM+DISOSM 22932 CONTINUE X2(I)=SUM/ANI 22931 CONTINUE GOTO2800 C 22940 CONTINUE P=DISPAR(IDIS) Q=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO22941I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO22941 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO22942K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL GL4PPF(DBLE(UNIOSM),DBLE(P),DBLE(Q),DPPF) DISOSM=REAL(DPPF) SUM=SUM+DISOSM 22942 CONTINUE X2(I)=SUM/ANI 22941 CONTINUE GOTO2800 C 22950 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO22951I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO22951 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO22952K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL ALDPPF(DBLE(UNIOSM),DBLE(ALPHA),DBLE(BETA),DPPF) DISOSM=REAL(DPPF) SUM=SUM+DISOSM 22952 CONTINUE X2(I)=SUM/ANI 22951 CONTINUE GOTO2800 C 22960 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO22961I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO22961 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO22962K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) IF(IBGEDF.EQ.'UNSH')THEN CALL BGEPPF(UNIOSM,ALPHA,BETA,DISOSM) ELSE CALL BG2PPF(UNIOSM,ALPHA,BETA,DISOSM) ENDIF SUM=SUM+DISOSM 22962 CONTINUE X2(I)=SUM/ANI 22961 CONTINUE GOTO2800 C 22970 CONTINUE ALPHA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO22971I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO22971 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO22972K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL ZETPPF(UNIOSM,ALPHA,DISOSM) SUM=SUM+DISOSM 22972 CONTINUE X2(I)=SUM/ANI 22971 CONTINUE GOTO2800 C 22980 CONTINUE ALPHA=DISPAR(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO22981I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO22981 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO22982K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL ZIPPPF(UNIOSM,ALPHA,NU,DISOSM) SUM=SUM+DISOSM 22982 CONTINUE X2(I)=SUM/ANI 22981 CONTINUE GOTO2800 C 22990 CONTINUE ALAMBA=DISPAR(IDIS) IF(AK1.GT.XMIN)AK1=XMIN K=INT(AK1+0.5) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO22991I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO22991 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO22992KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL BTAPPF(UNIOSM,ALAMBA,AK1,DISOSM) SUM=SUM+DISOSM 22992 CONTINUE X2(I)=SUM/ANI 22991 CONTINUE GOTO2800 C 23000 CONTINUE ALAMBA=DISPAR(IDIS) THETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO23001I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO23001 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO23002KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL LPOPPF(UNIOSM,ALAMBA,THETA,DISOSM) SUM=SUM+DISOSM 23002 CONTINUE X2(I)=SUM/ANI 23001 CONTINUE GOTO2800 C 23010 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(KSLOC.NE.CPUMIN .AND. KSSCAL.NE.CPUMIN)GOTO2800 ENDIF C I2=0 DO23011I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO23011 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO23012K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL LBEPPF(UNIOSM,ALPHA,BETA,YLOWLM,YUPPLM,DISOSM) SUM=SUM+DISOSM 23012 CONTINUE X2(I)=SUM/ANI 23011 CONTINUE GOTO2800 C 23020 CONTINUE THETA=DISPAR(IDIS) P=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO23021I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO23021 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO23022KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL PAPPPF(DBLE(UNIOSM),DBLE(THETA),DBLE(P),DPPF) DISOSM=REAL(DPPF) SUM=SUM+DISOSM 23022 CONTINUE X2(I)=SUM/ANI 23021 CONTINUE GOTO2800 C 23030 CONTINUE P=DISPAR(IDIS) IF(REAL(NU1).GT.XMIN)NU1=INT(XMIN+0.5) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO23031I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO23031 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO23032KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL LOSPPF(UNIOSM,P,NU1,DISOSM) SUM=SUM+DISOSM 23032 CONTINUE X2(I)=SUM/ANI 23031 CONTINUE GOTO2800 C 23040 CONTINUE THETA=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO23041I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO23041 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO23042KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL GLSPPF(UNIOSM,THETA,BETA,DISOSM) SUM=SUM+DISOSM 23042 CONTINUE X2(I)=SUM/ANI 23041 CONTINUE GOTO2800 C 23050 CONTINUE SHAPE=DISPAR(IDIS) IF(IGETDF.EQ.'THET')THEN THETA=SHAPE ELSE AMU=SHAPE ENDIF BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO23051I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO23051 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO23052KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL GETPPF(DBLE(UNIOSM),DBLE(SHAPE),DBLE(BETA), 1 IGETDF,DPPF) SUM=SUM+REAL(DPPF) 23052 CONTINUE X2(I)=SUM/ANI 23051 CONTINUE GOTO2800 C 23060 CONTINUE P=DISPAR(IDIS) PHI=DISPA2(IDIS) IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PPC2')THEN WRITE(ICOUT,23067)P,PHI,AM 23067 FORMAT('QBIPPF: P,PHI,AM=',3G15.7) CALL DPWRST('XXX','BUG ') ENDIF C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO23061I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO23061 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO23062KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL QBIPPF(UNIOSM,P,PHI,AM,PPF) SUM=SUM+PPF 23062 CONTINUE X2(I)=SUM/ANI 23061 CONTINUE IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PPC2')THEN WRITE(ICOUT,23068) 23068 FORMAT('AT END OF QBIPPF') CALL DPWRST('XXX','BUG ') ENDIF GOTO2800 C 23070 CONTINUE SHAPE=DISPAR(IDIS) IF(ICONDF.EQ.'THET')THEN THETA=SHAPE ELSE AMU=SHAPE ENDIF AM=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO23071I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO23071 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO23072KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL CONPPF(DBLE(UNIOSM),DBLE(SHAPE),DBLE(AM), 1 ICONDF,DPPF) SUM=SUM+REAL(DPPF) 23072 CONTINUE X2(I)=SUM/ANI 23071 CONTINUE GOTO2800 C 23080 CONTINUE ALPHA=DISPAR(IDIS) BETA=DISPA2(IDIS) A=ALPHA B=0.0 C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO23081I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO23081 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO23082KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL LKPPF(DBLE(UNIOSM),DBLE(ALPHA),DBLE(B),DBLE(BETA), 1 DPPF) SUM=SUM+REAL(DPPF) 23082 CONTINUE X2(I)=SUM/ANI 23081 CONTINUE GOTO2800 C 23090 CONTINUE P=DISPAR(IDIS) BETA=DISPA2(IDIS) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO23091I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO23091 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO23092KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL DIWPPF(DBLE(UNIOSM),DBLE(P),DBLE(BETA),DPPF) SUM=SUM+REAL(DPPF) 23092 CONTINUE X2(I)=SUM/ANI 23091 CONTINUE GOTO2800 C 23100 CONTINUE P=DISPAR(IDIS) A=DISPA2(IDIS) NU=NU1 IF(REAL(NU).GT.XMIN)NU=INT(XMIN+0.5) C IF(ICASP2.EQ.'KS ')THEN AMIN=CPUMIN AMAX=CPUMAX IF(IFLAG.EQ.1)GOTO2800 ENDIF C I2=0 DO23101I=1,N1 NI=D2(I) IF(NI.LE.0)GOTO23101 ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO23102KK=I1,I2 CALL UNIME2(NTOT,KK,UNIOSM) CALL GLGPPF(UNIOSM,P,NU,A,DISOSM) SUM=SUM+DISOSM 23102 CONTINUE X2(I)=SUM/ANI 23101 CONTINUE GOTO2800 C 2800 CONTINUE C IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PPC2')THEN WRITE(ICOUT,2801)ICASP2,IFLAG 2801 FORMAT('AT 2800: ICASP2,IFLAG=',A4,I4) CALL DPWRST('XXX','BUG ') ENDIF C CCCCC MAY 2004: SUPPORT BIWEIGHT MIDCORRELATION, PERCENTAGE BEND CCCCC CORRELATION, AND WINSORIZED CORRELATION AS ALTERNATIVES CCCCC TO THE STANDARD CORRELATION FOR THIS PLOT. C IWRITE='OFF' C CCCCC MAY 2004: SUPPORT A "MINIMUM KOLM-SMIR" OPTION. CALL LINFI2 CCCCC TO OBTAIN ESTIMATES OF LOCATION AND SCALE, THE CALL CCCCC DP1KS2 TO OBTAIN VALUE OF K-S STATISTIC. C IF(ICASP2.EQ.'KS ')THEN C ICASP3=ICASPL IF(ICASP3.EQ.'GMLP')THEN ICASP3='GMCP' ELSEIF(ICASP3.EQ.'GETC')THEN ICASP3='GETP' ELSEIF(ICASP3.EQ.'DIWP')THEN ICASP3='DIWP' ELSEIF(ICASP3.EQ.'GLGP')THEN ICASP3='GLGP' ELSEIF(ICASP3(3:4).EQ.'CP')THEN ICASP3(3:4)='PP' ELSEIF(ICASP3(2:3).EQ.'CP')THEN ICASP3(2:3)='PP' ENDIF IF(KSLOC.EQ.CPUMIN .AND. KSSCAL.EQ.CPUMIN .AND. 1 IFLAG.EQ.0)THEN C C HANDLE BETA SEPARATELY C IF(ICASPL.EQ.'BECP')THEN IF(XMIN.GE.0.0 .AND. XMIN.LE.1.0 .AND. 1 XMAX.GE.0.0 .AND. XMAX.LE.1.0)THEN A0TEMP=0.0 A1TEMP=1.0 ELSE A0TEMP=XMIN-EPS A1TEMP=XMAX+EPS ENDIF C C HANDLE TUKEY-LAMBDA SEPARATELY C ELSEIF(ICASPL.EQ.'LACP' .AND. ALAMBA.GT.0.0)THEN CALL LINFI2(Y2,X2,N1, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) IF((XMIN-A0TEMP)/A1TEMP.LT.AMIN .OR. 1 (XMAX-A0TEMP)/A1TEMP.GT.AMAX)THEN A0TEMP=XMED ATEMP1=ALAMBA*ABS(XMAX-A0TEMP) + 0.1 ATEMP2=ALAMBA*ABS(XMIN-A0TEMP) + 0.1 A1TEMP=MAX(ATEMP1,ATEMP2) ENDIF C C HANDLE CASE WHERE DOMAIN BOUNDED BOTH ABOVE AND BELOW. SOLVE C C (XMIN-A0TEMP)/A1TEMP = AMIN C (XMAX-A0TEMP)/A1TEMP = AMAX C ELSEIF(AMIN.GT.CPUMIN .AND. AMAX.LT.CPUMAX)THEN CALL LINFI2(Y2,X2,N1, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) IF((XMIN-A0TEMP)/A1TEMP.LT.AMIN .OR. 1 (XMAX-A0TEMP)/A1TEMP.GT.AMAX)THEN CMIN=AMIN CMAX=AMAX CONST=CMIN/CMAX A0TEMP=(XMIN-CONST*XMAX)/(1.0+CONST) - EPS A1TEMP=(XMAX-A0TEMP)/CMAX + EPS ENDIF C C HANDLE CASE WHERE DOMAIN BOUNDED ON MINIMUM ONLY C ELSEIF(AMIN.GT.CPUMIN .AND. AMAX.EQ.CPUMAX)THEN CALL LINFI2(Y2,X2,N1, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) IF(XMIN-A0TEMP.LT.AMIN)A0TEMP=XMIN-EPS C C HANDLE CASE WHERE DOMAIN BOUNDED ON MAXIMUM ONLY C ELSEIF(AMIN.EQ.CPUMIN .AND. AMAX.LT.CPUMAX)THEN CALL LINFI2(Y2,X2,N1, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) CTEMP=(XMAX-A0TEMP)/A1TEMP IF(CTEMP.GE.AMAX)THEN A0TEMP=(XMAX-EPS) - A1TEMP*AMAX ENDIF C C HANDLE UNBOUNDED CASE C ELSE CALL LINFI2(Y2,X2,N1, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) ENDIF C ELSE A0TEMP=KSLOC A1TEMP=KSSCAL ENDIF C XTEMP3(IDIS)=A0TEMP XTEMP4(IDIS)=A1TEMP C CCCCC OCTOBER 2004. FOR BINNED DATA, USE CHI-SQUARE TEST INSTEAD CCCCC OF K-S TEST SINCE CHI-SQUARE IS SPECIFICALLY FOR BINNED CCCCC DATA. CALL DPCOMB TO COMBINE FREQUENCIES WITH LESS THAN CCCCC 5 OBSERVATIONS. C CCCCC IF(IFLAG.EQ.0)THEN CCCCC CALL DP1KS2(X1,N1,ICASP3, CCCCC1 ALAMBA,NU,NU1,NU2,GAMMA,ALPHA,BETA, CCCCC1 NPAR,P,K,MINMAX, CCCCC1 ANU,ANU1,ANU2,NDUN,C,ALAMB1,ALAMB2, CCCCC1 MPAR,B,SD,THETA, CCCCC1 DELTA,A,AM,X0, CCCCC1 U1,SD1,U2,SD2,DZ, CCCCC1 ALAMB3,ALAMB4,ALPHA1,ALPHA2, CCCCC1 ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2, CCCCC1 AMU,XI,CHI,G,H,AK,SIGMA, CCCCC1 ETA,ZETA,TAU,Q, CCCCC1 YLOWLM,YUPPLM, CCCCC1 A0TEMP,A1TEMP, CCCCC1 STATVA,CDF1,CDF2,CDF3, CCCCC1 ICAPSW,ICAPTY, CCCCC1 IWRITE,IADEDF,IGEPDF,IMAKDF,IBEIDF, CCCCC1 ILGADF,ISKNDF,IGLDDF, CCCCC1 XTEMP1,XTEMP2,NXTEMP,IBUGG3,IERROR) CCCCC ELSE IRHSTG='AREA' CLWID=CPUMIN XSTART=CPUMIN XSTOP=CPUMAX IF(IDATSW.EQ.'FREQ')THEN IDATS2='FREQ' ELSE IDATS2='CLAS' ENDIF C IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PPC2')THEN WRITE(ICOUT,13070) 13070 FORMAT('DPPPC2: BEFORE CALL TO DPCHS2') CALL DPWRST('XXX','BUG ') ENDIF CALL DPCHS2(Y3,XLOW,XHIGH,N3,ICASP3,IDATS2,IRHSTG, 1 ALAMBA,NU,NU1,NU2,GAMMA,ALPHA,BETA, 1 NPAR,P,K,MINMAX, 1 ANU,ANU1,ANU2,NDUN,C,ALAMB1,ALAMB2, 1 MPAR,B,SD,THETA, 1 DELTA,A,AM,X0, 1 U1,SD1,U2,SD2,DZ,ANU3, 1 ALAMB3,ALAMB4,ALPHA1,ALPHA2, 1 ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2, 1 AMU,XI,CHI,G,H,AK,SIGMA, 1 ETA,ZETA,TAU,Q,AKAPPA,PHI, 1 YLOWLM,YUPPLM, 1 CLWID,XSTART,XSTOP, 1 XTEMP9,IHSTCW,MAXOBV, 1 A0TEMP,A1TEMP, 1 STATVA,STATCD,STATNU,CDF1,CDF2,CDF3, 1 ICAPSW,ICAPTY,IWRITE, 1 IADEDF,IGEPDF,IMAKDF,IBEIDF, 1 ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF, 1 PCHSLM, 1 XTEMP1,XTEMP2,XTEMP7,XTEMP8,NXTEMP, 1 IBUGG3,IERROR) IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'PPC2')THEN WRITE(ICOUT,13071) 13071 FORMAT('DPPPC2: AFTER CALL TO DPCHS2') CALL DPWRST('XXX','BUG ') ENDIF CCCCC ENDIF CORRV(IDIS)=STATVA IF(CORRV(IDIS).LT.PPCCMX .OR. PPCCMX.EQ.CPUMIN)THEN A0SAVE=XTEMP3(IDIS) A1SAVE=XTEMP4(IDIS) PPCCMX=CORRV(IDIS) SHAPMX=DISPAR(IDIS) ENDIF ELSE CALL CORR(Y2,X2,N1,IWRITE,CC,IBUGG3,IERROR) CORRV(IDIS)=CC CALL LINFI2(Y2,X2,N1, 1 A0TEMP,A1TEMP, 1 ISUBRO,IBUGG3,IERROR) C IF(CORRV(IDIS).GT.PPCCMX)THEN A0SAVE=A0TEMP A1SAVE=A1TEMP PPCCMX=CORRV(IDIS) SHAPMX=DISPAR(IDIS) ENDIF C IF(IPPCCC.EQ.'WINS')THEN IHP='P1 ' 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 PROP1=10.0 ELSE PROP1=VALUE(ILOCP) ENDIF IF(PROP1.LE.0.0 .OR. PROP1.GE.25.0)PROP1=10.0 C IHP='P2 ' IHP2=' ' 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 PROP2=10.0 ELSE PROP2=VALUE(ILOCP) ENDIF IF(PROP2.LE.0.0 .OR. PROP2.GE.25.0)PROP2=10.0 C CALL WINSOR(Y2,N1,PROP1,PROP2,IWRITE,XTEMP1,MAXOBV,XTEMP2, 1 IBUGG3,IERROR) DO13072I=1,N1 Y1(I)=XTEMP2(I) 13072 CONTINUE CALL WINSOR(X2,N1,PROP1,PROP2,IWRITE,XTEMP1,MAXOBV,XTEMP2, 1 IBUGG3,IERROR) DO13074I=1,N1 X2(I)=XTEMP2(I) 13074 CONTINUE CALL CORR(Y2,X2,N1,IWRITE,CC,IBUGG3,IERROR) CORRZ(IDIS)=CC ELSEIF(IPPCCC.EQ.'PERB')THEN IHP='BETA' 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 BETA=0.1 ELSE BETA=VALUE(ILOCP) ENDIF IF(BETA.LE.0.0 .OR. BETA.GE.0.25)BETA=0.1 C CALL PBNCOR(Y2,X2,N1,IWRITE,XTEMP1,XTEMP2,MAXOBV, 1 CC,BETA, 1 IBUGG3,IERROR) CORRZ(IDIS)=CC ELSEIF(IPPCCC.EQ.'BIWE')THEN CALL BIWMDV(Y2,N1,IWRITE,XTEMP1,XTEMP2,MAXOBV,VAR1, 1 IBUGG3,IERROR) CALL BIWMDV(X2,N1,IWRITE,XTEMP1,XTEMP2,MAXOBV,VAR2, 1 IBUGG3,IERROR) CALL BIWMCV(Y2,X2,N1,IWRITE,XTEMP1,XTEMP2,MAXOBV,COV, 1 IBUGG3,IERROR) CC=0.0 IF(COV.GT.0.0)CC=COV/SQRT(VAR1*VAR2) CORRZ(IDIS)=CC ENDIF ENDIF C CCCCC OCTOBER 2004: WRITE PPCC VALUE, LOCATION, SHAPE, AND CCCCC SHAPE PARAMETERS TO DPST2F.DAT. C IF(NUMSHA.LE.1)THEN WRITE(IOUNI2,'(I8,4E15.7)')IIREPL-1,CORRV(IDIS), 1 A0TEMP,A1TEMP,DISPAR(IDIS) ELSE WRITE(IOUNI2,'(I8,5E15.7)')IIREPL-1,CORRV(IDIS),A0TEMP, 1 A1TEMP,DISPAR(IDIS),DISPA2(IDIS) ENDIF C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PPC2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2831)NUMDIS,IDIS,DISPAR(IDIS) 2831 FORMAT('NUMDIS,IDIS,DISPAR(IDIS) = ',2I8,E15.7) CALL DPWRST('XXX','BUG ') DO2832I=1,N1 WRITE(ICOUT,2833)I,Y1(I),X1(I),Y2(I),X2(I),D2(I) 2833 FORMAT('I,Y1(I),X1(I),Y2(I),X2(I),D2(I) = ',I8,5G15.7) CALL DPWRST('XXX','BUG ') 2832 CONTINUE WRITE(ICOUT,2834)ICASPL,IDATSW 2834 FORMAT('ICASPL,IDATSW = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2835)NUMDIS,IDIS,DISPAR(IDIS),CORRV(IDIS) 2835 FORMAT('NUMDIS,IDIS,DISPAR(IDIS),CORRV(IDIS) = ',2I8,2E15.7) CALL DPWRST('XXX','BUG ') ENDIF C 2105 CONTINUE C 2900 CONTINUE C CCCCC THREE BASIC CASES: C C 1) ONE SHAPE PARAMETER C 2) TWO SHAPE PARAMETERS - GENERATE MULTI-TRACE PLOT C 3) TWO SHAPE PARAMETERS - GENERATE A 3D-PLOT C C FOR EACH OF THESE, THERE ARE SEVERAL SUB-CASES TO CONSIDER: C C 1) K-S PLOT PRINTS LOCATION AND SCALE ESTIMATES USED (FOR C CONTINUOUS DISTRIBUTIONS ONLY) C 2) PPCC PLOT MAY PRINT AN ALTERNATE ESTIMATE OF CORRELATION C AS A SECOND TRACE C 3) EXTREME VALUE PLOT WILL PRINT SEPARATE TRACES FOR MIN AND C MAX CASES C AHOLD=CPUMIN ATAG=0.0 C CCCCC CASE 1: ONE SHAPE PARAMETER C IF(NUMSHA.EQ.1)THEN NLAST=NUMDIS IF(ICASPL.EQ.'EVCP')NLAST=NUMD1 DO2930IDIS=1,NLAST ICNTPT=ICNTPT+1 IF(ICASPL.NE.'EVCP' .OR. IPPCCC.EQ.'LINE')THEN Y2TEMP(ICNTPT)=CORRV(IDIS) ELSE Y2TEMP(ICNTPT)=CORRZ(IDIS) ENDIF X2TEMP(ICNTPT)=DISPAR(IDIS) D2TEMP(ICNTPT)=REAL(IIREPL) IF(IFLAG.EQ.0 .AND. ICASP2.EQ.'KS ')THEN WRITE(IOUNI1,'(5E15.7,I8)')Y2TEMP(ICNTPT), 1 XTEMP3(IDIS),XTEMP4(IDIS), 1 X2TEMP(ICNTPT), 1 D2TEMP(ICNTPT),IIREPL-1 ELSE WRITE(IOUNI1,'(3E15.7,I8)')Y2TEMP(ICNTPT), 1 X2TEMP(ICNTPT), 1 D2TEMP(ICNTPT),IIREPL-1 ENDIF 2930 CONTINUE N2=ICNTPT NPLOTV=2 C IF(ICASPL.EQ.'EVCP')THEN NUMD1P=NUMD1+1 DO2932IDIS=NUMD1P,NUMDIS ICNTPT=ICNTPT+1 Y2TEMP(ICNTPT)=CORRV(IDIS) IF(IPPCCC.NE.'LINE')Y2TEMP(ICNTPT)=CORRZ(IDIS) X2TEMP(ICNTPT)=DISPAR(IDIS) D2TEMP(ICNTPT)=REAL(IIREPL)*2.0 2932 CONTINUE N2=ICNTPT NPLOTV=3 ELSEIF(IPPCCC.NE.'LINE' .AND. ICASP2.EQ.'PPCC')THEN NUMD1P=NUMD1+1 DO2934IDIS=1,NUMDIS ICNTPT=ICNTPT+1 Y2TEMP(ICNTPT)=CORRZ(IDIS) X2TEMP(ICNTPT)=DISPAR(IDIS) D2TEMP(ICNTPT)=REAL(IIREPL)*2.0 2934 CONTINUE N2=ICNTPT NPLOTV=3 ENDIF C CCCCC CASE 2: TWO SHAPE PARAMETERS, MULTI-TRACE PLOT C ELSEIF(NUMSHA.EQ.2 .AND. IPPCFO.EQ.'TRAC')THEN DO2940IDIS=1,NUMDIS ICNTPT=ICNTPT+1 IF(IPPCAO.EQ.'DEFA')THEN IF(DISPAR(IDIS).NE.AHOLD)THEN ATAG=ATAG+1.0 AHOLD=DISPAR(IDIS) ENDIF ELSE DO2942JJ=1,NUMDIS IF(DISPA2(IDIS).EQ.DISPA2(JJ))THEN ATAG=REAL(JJ) GOTO2945 ENDIF 2942 CONTINUE 2945 CONTINUE ENDIF IF(ICASP2.EQ.'PPCC' .AND. IPPCCC.NE.'LINE')THEN Y2TEMP(ICNTPT)=CORRZ(IDIS) ELSE Y2TEMP(ICNTPT)=CORRV(IDIS) ENDIF IF(IPPCAO.EQ.'DEFA')THEN X2TEMP(ICNTPT)=DISPA2(IDIS) X3D2(ICNTPT)=DISPAR(IDIS) ELSE X3D2(ICNTPT)=DISPA2(IDIS) X2TEMP(ICNTPT)=DISPAR(IDIS) ENDIF D2TEMP(ICNTPT)=ATAG IF(IFLAG.EQ.0 .AND. ICASP2.EQ.'KS ')THEN WRITE(IOUNI1,'(6E15.7)')Y2TEMP(ICNTPT), 1 XTEMP3(IDIS),XTEMP4(IDIS), 1 X2TEMP(ICNTPT),X3D2(ICNTPT), 1 D2TEMP(ICNTPT) ELSE WRITE(IOUNI1,'(4E15.7)')Y2TEMP(ICNTPT), 1 X2TEMP(ICNTPT),X3D2(ICNTPT), 1 D2TEMP(ICNTPT) ENDIF 2940 CONTINUE N2=ICNTPT NPLOTV=3 C CCCCC CASE 3: TWO SHAPE PARAMETERS, 3D-PLOT C ELSEIF(NUMSHA.EQ.2 .AND. IPPCFO.EQ.'3D ')THEN IWRITE='OFF' CALL DISTIN(DISPA2,NUMDIS,IWRITE,DISPA3,NTEMP,IBUGG3,IERROR) IF(IERROR.EQ.'YES'.OR.IERROR.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2941) 2941 FORMAT('****** ERROR FROM PPCC PLOT DURING CALL TO DISTIN') CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C DO2960IDIS=1,NUMDIS IF(DISPAR(IDIS).NE.AHOLD)THEN ATAG=ATAG+1.0 AHOLD=DISPAR(IDIS) ENDIF ICNTPT=ICNTPT+1 IF(ICASP2.EQ.'PPCC' .AND. IPPCCC.NE.'LINE')THEN Y2TEMP(ICNTPT)=CORRZ(IDIS) ELSE Y2TEMP(ICNTPT)=CORRV(IDIS) ENDIF IF(IPPCAO.EQ.'DEFA')THEN X2TEMP(ICNTPT)=DISPAR(IDIS) X3D2(ICNTPT)=DISPA2(IDIS) ELSE X3D2(ICNTPT)=DISPAR(IDIS) X2TEMP(ICNTPT)=DISPA2(IDIS) ENDIF D2TEMP(ICNTPT)=ATAG IF(IFLAG.EQ.0 .AND. ICASP2.EQ.'KS ')THEN WRITE(IOUNI1,'(6E15.7)')Y2TEMP(ICNTPT), 1 XTEMP3(IDIS),XTEMP4(IDIS), 1 X2TEMP(ICNTPT),X3D2(ICNTPT), 1 D2TEMP(ICNTPT) ELSE WRITE(IOUNI1,'(4E15.7)')Y2TEMP(ICNTPT), 1 X2TEMP(ICNTPT),X3D2(ICNTPT), 1 D2TEMP(ICNTPT) ENDIF 2960 CONTINUE C DO2970J=1,NTEMP AHOLD=DISPA3(J) ATAG=ATAG+1.0 DO2975IDIS=1,NUMDIS IF(DISPA2(IDIS).EQ.AHOLD)THEN ICNTPT=ICNTPT+1 IF(ICASP2.EQ.'PPCC' .AND. IPPCCC.NE.'LINE')THEN Y2TEMP(ICNTPT)=CORRZ(IDIS) ELSE Y2TEMP(ICNTPT)=CORRV(IDIS) ENDIF IF(IPPCAO.EQ.'DEFA')THEN X2TEMP(ICNTPT)=DISPAR(IDIS) X3D2(ICNTPT)=DISPA2(IDIS) ELSE X3D2(ICNTPT)=DISPAR(IDIS) X2TEMP(ICNTPT)=DISPA2(IDIS) ENDIF D2TEMP(ICNTPT)=ATAG ENDIF 2975 CONTINUE 2970 CONTINUE C N2=ICNTPT NPLOTV=3 ENDIF C WRITE(IOUNI3,'(I8,3E15.7)')IIREPL-1,SHAPMX,A0SAVE,A1SAVE C 72000 CONTINUE C DO72910II=1,ICNTPT X2(II)=X2TEMP(II) Y2(II)=Y2TEMP(II) D2(II)=D2TEMP(II) 72910 CONTINUE C IENDF1='OFF' IREWI1='ON' CALL DPCLFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1 IENDF1,IREWI1,ISUBN0,IERRF1,IBUGG3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IENDF2='OFF' IREWI2='ON' CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1 IENDF2,IREWI2,ISUBN0,IERRF2,IBUGG3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C IENDF3='OFF' IREWI3='ON' CALL DPCLFI(IOUNI3,IFILE3,ISTAT3,IFORM3,IACCE3,IPROT3,ICURS3, 1 IENDF3,IREWI3,ISUBN0,IERRF3,IBUGG3,ISUBRO,IERROR) IF(IERRF3.EQ.'YES')GOTO9000 C GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'PPC2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPPC2--') 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)NTOT 9014 FORMAT('NTOT = ',I8) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 3 LINES WERE ADDED MAY 1993 WRITE(ICOUT,9015)MINMAX 9015 FORMAT('MINMAX = ',I8) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 3 LINES WERE ADDED DECEMBER 1993 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 DPPPD(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE A PHASE PLANE DIAGRAM C (USED IN TIME SERIES MODELING). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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/8 C ORIGINAL VERSION--JULY 1989. 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 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASQ CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHVA21 CHARACTER*4 IHVA22 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(MAXOBV) DIMENSION Y2(MAXOBV) C CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),Y1(1)) EQUIVALENCE (GARBAG(IGARB2),Y2(1)) CCCCC END CHANGE 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-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C ISUBN1='DPPP' ISUBN2='D ' 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 ICOLV2=0 C C ************************************* C ** TREAT THE PHASE PLANE DIAGRAM CASE ** C ************************************* C IF(IBUGG2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPPD--') 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.'PHAS'.AND.IHARG(1).EQ.'PLAN'.AND. 1IHARG(2).EQ.'DIAG')GOTO112 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'PHAS'.AND.IHARG(1).EQ.'PLAN'.AND. 1IHARG(2).EQ.'PLOT')GOTO112 C IFOUND='NO' GOTO9000 C 112 CONTINUE ILASTC=2 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 180 CONTINUE IFOUND='YES' GOTO190 C 190 CONTINUE C C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' 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 ******************************************** C ** STEP 3-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='3' 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) 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(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 DPPPD--') 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 PHASE PLANE DIAGRAM ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' IS TO BE 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 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(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASQ='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 ICASQ='SUBS' ILOCQ=J1 GOTO490 420 CONTINUE ICASQ='FOR' ILOCQ=J1 GOTO490 490 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ 491 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C *********************************************** C ** STEP 6-- ** C ** CHECK FOR A VALID NUMBER ** C ** OF VARIABLES ** C ** (EITHER 1 OR 2) ** C ** ALSO, FOR THE 2-VARIABLE CASE, ** C ** CHECK THE VALIDITY ** C ** OF THE SECOND VARIABLE. ** C ** DOES THE NAME EXIST IN THE TABLE? ** C ** DOES THE NUMBER OF ELEMENTS ** C ** IN THE SECOND VARIABLE ** C ** AGREE WITH THE NUMBER OF ELEMENTS ** C ** IN THE FIRST VARIABLE? ** C *********************************************** C ISTEPN='6' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IF(1.LE.NUMV2.AND.NUMV2.LE.MAXV2)GOTO509 GOTO550 C 509 CONTINUE ICASPL=' ' IF(NUMV2.EQ.1)ICASPL='PPD1' IF(NUMV2.EQ.2)ICASPL='PPD2' IF(NUMV2.LE.1)GOTO590 IHVA21=IHARG(2) IHVA22=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHVA21,IHVA22,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLV2=IVALUE(ILOCV) NVAR2=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,511)IHVA21,IHVA22,ICOLV2,NVAR2 511 FORMAT('IHVA21,IHVA22,ICOLV2,NVAR2 = ',A4,2X,A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') 510 CONTINUE C IF(NVAR2.NE.NLEFT)GOTO570 GOTO590 C 550 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,551) 551 FORMAT('***** ERROR IN DPPPD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,552) 552 FORMAT(' FOR A 2-VARIABLE PHASE PLANE DIAGRAM, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,553) 553 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,554) 554 FORMAT(' MUST BE EXACTLY 2 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,555) 555 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,556) 556 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,557)NUMV2 557 FORMAT(' OF VARIABLES WAS ',I8) 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 570 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,571) 571 FORMAT('***** ERROR IN DPPPD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,572) 572 FORMAT(' FOR A 2-VARIABLE PHASE PLANE DIAGRAM, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,573) 573 FORMAT(' THE NUMBER OF ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,574) 574 FORMAT(' IN THE 2 VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,575) 575 FORMAT(' MUST BE THE SAME; ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,576) 576 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,577)IHLEFT,IHLEF2,NLEFT 577 FORMAT(' THE FIRST VARIABLE ', 1'(',A4,A4,') HAS ',I8, 'ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,578)IHVA21,IHVA22,NVAR2 578 FORMAT(' THE SECOND VARIABLE ', 1'(',A4,A4,') HAS ',I8, 'ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,579) 579 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,580)(IANS(I),I=1,IWIDTH) 580 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 590 CONTINUE C C ********************************************** C ** STEP 7-- ** C ** FORM THE VARIABLE Y1(.) ** C ** WHICH WILL CONTAIN THE FIRST VARIABLE; ** C ** ALSO, FOR A 2-VARIABLE PHASE PLANE DIAGRAM, ** C ** FORM THE VARIABLE Y2(.) ** C ** WHICH WILL CONTAIN THE SECOND VARIABLE. ** C ** FORM THESE VARIABLES BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C ********************************************** C ISTEPN='7' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASQ.EQ.'FULL')GOTO610 IF(ICASQ.EQ.'SUBS')GOTO620 IF(ICASQ.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 IF(NQ.GE.MINN2)GOTO660 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,651) 651 FORMAT('***** ERROR IN DPPPD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,652) 652 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,653)IHLEFT,IHLEF2 653 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,654) 654 FORMAT(' (FOR WHICH A 1- OR 2-VARIABLE ', 1'PHASE PLANE DIAGRAM ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,655) 655 FORMAT(' IS TO BE FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,656)MINN2 656 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,657) 657 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,658) 658 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,659)(IANS(I),I=1,IWIDTH) 659 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 660 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO670I=1,IMAX IF(ISUB(I).EQ.0)GOTO670 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) CCCCC IF(MAXV2.LE.1)GOTO670 JUNE 9, 1987 IF(NUMV2.LE.1)GOTO670 C IJ=MAXN*(ICOLV2-1)+I IF(ICOLV2.LE.MAXCOL)Y2(J)=V(IJ) IF(ICOLV2.EQ.MAXCP1)Y2(J)=PRED(I) IF(ICOLV2.EQ.MAXCP2)Y2(J)=RES(I) IF(ICOLV2.EQ.MAXCP3)Y2(J)=YPLOT(I) IF(ICOLV2.EQ.MAXCP4)Y2(J)=XPLOT(I) IF(ICOLV2.EQ.MAXCP5)Y2(J)=X2PLOT(I) IF(ICOLV2.EQ.MAXCP6)Y2(J)=TAGPLO(I) C 670 CONTINUE NS=J C C **************************************************************** C ** STEP 9-- * C ** FORM THE VERTICAL AND HORIZONTAL AXIS * C ** VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR THE PLOT. * C ** FORM THE CURVE DESIGNATION VARIABLE D(.) . * C ** THIS WILL BE BOTH ONES FOR BOTH CASES * C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). * C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). * C **************************************************************** C ISTEPN='9' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPPPD2(Y1,Y2,NS,ICASPL, 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 DPPPD--') 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 ') 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 DPPPD2(Y1,Y2,N,ICASPL, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE C 1) A 1-VARIABLE PHASE PLANE DIAGRAM C 2) A 2-VARIABLE PHASE PLANE DIAGRAM C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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 1989. C UPDATED --JANUARY 1989. DIVISION BY 0 TRAP C UPDATED --APRIL 1992. ICASPLN TO ICASPL 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 DIMENSION Y1(*) DIMENSION Y2(*) DIMENSION Y(*) DIMENSION X(*) DIMENSION D(*) 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='DPPP' ISUBN2='D2 ' C IERROR='NO' C IF(IBUGG3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70) 70 FORMAT('***** AT THE BEGINNING OF DPPPD2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)N,ICASPL 71 FORMAT('N,ICASPL = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') DO73I=1,N WRITE(ICOUT,74)I,Y1(I),Y2(I) 74 FORMAT('I, Y1(I), Y2(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 73 CONTINUE 90 CONTINUE C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.GE.1)GOTO39 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN DPPPD2--') 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 DPPPD2--') 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 C ************************************** C ** STEP 3-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ** AND DETERMINE PLOT COORDINATES ** C ************************************** C IF(ICASPL.EQ.'PPD1')GOTO1100 IF(ICASPL.EQ.'PPD2')GOTO1200 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011) 1011 FORMAT('***** INTERNAL ERROR IN DPPPD2 ', 1'AT BRANCH POINT 1011--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1012) 1012 FORMAT(' ICASPL SHOULD BE EITHER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1013) 1013 FORMAT(' PPD1 OR PPD2, BUT IS NEITHER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1014)ICASPL 1014 FORMAT(' ICASPL = ',A4) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C C ***************************************** C ** STEP 4.1-- ** C ** FORM THE 1-VARIABLE PHASE PLANE DIAGRAM ** C ***************************************** C 1100 CONTINUE IMIN=1 IMAX=N-1 J=0 DO1110I=IMIN,IMAX J=J+1 IP1=I+1 Y(J)=Y1(IP1)-Y1(I) X(J)=Y1(I) D(J)=1.0 1110 CONTINUE NPLOTP=J NPLOTV=2 GOTO9000 C C ***************************************** C ** STEP 4.2-- ** C ** FORM THE 2-VARIABLE PHASE PLANE DIAGRAM ** C ***************************************** C 1200 CONTINUE IMIN=1 IMAX=N-1 J=0 DO1210I=IMIN,IMAX J=J+1 IP1=I+1 ANUM=Y1(IP1)-Y1(I) ADEN=Y2(IP1)-Y2(I) C IF(ADEN.EQ.0.0)GOTO1230 GOTO1239 1230 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1231) 1231 FORMAT('***** ERROR IN DPPPD2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1232) 1232 FORMAT(' A DIVISION BY ZERO WAS ATTEMPTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1233) 1233 FORMAT(' BECAUSE THE INPUT DATA HAD 2 REPEATED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1234) 1234 FORMAT(' X VALUES AND THEREFORE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1235) 1235 FORMAT(' YIELDED A 0 IN THE COMPUTATION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1236) 1236 FORMAT(' OF DELY / DELX .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1237)Y2(I) 1237 FORMAT(' THE REPEAT WAS AT X = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1239 CONTINUE C Y(J)=ANUM/ADEN X(J)=Y1(I) D(J)=1.0 1210 CONTINUE NPLOTP=J NPLOTV=2 GOTO9000 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 DPPPD2--') CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE FIXED APRIL 1992 CCCCC WRITE(ICOUT,9012)ICASPLN,NPLOTP,IERROR C9012 FORMAT('ICASPLN,NPLOTP,IERROR = ',A4,2I8,2X,A4) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,NPLOTP,IERROR 9012 FORMAT('ICASPL,NPLOTP,IERROR = ',A4,2I8,2X,A4) CALL DPWRST('XXX','BUG ') DO9015I=1,NPLOTP WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPRCL(XTEMP1,XTEMP2,MAXNXT,ICASAN,ANOPL1,ANOPL2, 1IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE (SYMMETRIC) CONFIDENCE LIMITS FOR THE C PROPORTION OF SUCCESSES FOR PROBABILITY VALUE C P = .90, .95, .99, .999, AND .9999. C ALSO HANDLE THE DIFFERENCE OF TWO PROPORTIONS. C NOTE: 1 = SUCCESS, 0 = FAILURE C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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--99/3 C ORIGINAL VERSION--MARCH 1999. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASAN 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 CHARACTER*4 IH21 CHARACTER*4 IH22 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.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='DPCO' ISUBN2='NF ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C IFOUND='NO' IERROR='NO' C MAXV2=1 IF(ICASAN.EQ.'DPRO')MAXV2=2 MINN2=2 NUMVAR=(-999) C IFOUND='YES' C NLEFT=0 N2=0 C ICASEQ='UNKN' C C *************************************************** C ** TREAT THE PROPORTION CONFIDENCE LIMITS CASE ** C *************************************************** C IF(IBUGA2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPRCL--') 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 ') WRITE(ICOUT,56)ICASAN 56 FORMAT('ICASAN = ',A4) 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) NUMVAR=1 C C ****************************************************** C ** STEP 4-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS ** C ** (NLEFT) 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 DPPRCL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312) 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) 313 FORMAT(' (FROM WHICH CONFIDENCE LIMITS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' WERE TO HAVE BEEN CALCULATED)') 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 3A-- ** C ** CHECK THE VALIDITY OF ARGUMENT 2 ** C ** (THIS MUST BE A VARIABLE ** C **************************************** C ISTEPN='3A' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASAN.NE.'DPRO')GOTO440 IH21=IHARG(2) IH22=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IH21,IH22,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOL2=IVALUE(ILOCV) N2=IN(ILOCV) NUMVAR=2 C C ******************************************************** C ** STEP 3B-- ** C ** IF ARGUMENT 2 IS A VARIABLE, ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (N2) ** C ** FOR ARGUMENT 2 IS 2 OR MORE. ** C ******************************************************** C ISTEPN='3B' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(N2.GE.MINN2)GOTO419 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,401) 401 FORMAT('***** ERROR IN DPPRCL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,402) 402 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,403) 403 FORMAT(' A DIFFERENCE OF PROPORTIONS CONFIDENCE INTERVAL') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,404) 404 FORMAT(' WAS TO HAVE BEEN CARRIED OUT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,405)MINN2 405 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,406) 406 FORMAT(' SUCH WAS NOT THE CASE HERE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,407)IH21,IH22 407 FORMAT(' FOR VARIABLE ',A4,A4,' WHICH HAD') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,408)N2 408 FORMAT(' NUMBER OF OBSERVATIONS = ',I8,';') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,409) 409 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,410)(IANS(I),I=1,MAX(IWIDTH,80)) 410 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 419 CONTINUE C C ******************************************************** C ** STEP 3C-- ** C ** IF ARGUMENT 2 IS A VARIABLE, ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (N2) ** C ** FOR ARGUMENT 2 IS THE SAME AS ARGUMENT 1 ** C ******************************************************** C ISTEPN='3B' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC IF(N2.NE.NLEFT)GOTO439 CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,421) CC421 FORMAT('***** ERROR IN DPPRCL--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,422) CC422 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR WHICH') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,423) CC423 FORMAT(' A DIFFERENCE OF PROPORTIONS CONFIDENCE INTERVAL') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,424) CC424 FORMAT(' WAS TO HAVE BEEN CARRIED OUT MUST HAVE THE') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,425)MINN2 CC425 FORMAT(' SAME NUMNER OF OBSERVATIONS FOR BOTH VARIABLES.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,426) CC426 FORMAT(' SUCH WAS NOT THE CASE HERE') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,427)IHLEFT,IHLEF2,NLEFT CC427 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,427)IH21,IH22,N2 CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,429) CC429 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC IF(IWIDTH.GE.1)WRITE(ICOUT,430)(IANS(I),I=1,MAX(IWIDTH,80)) CC430 FORMAT(80A1) CCCCC IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') CCCCC IERROR='YES' CCCCC GOTO9000 439 CONTINUE C 440 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 DO450J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO460 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO460 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO470 450 CONTINUE GOTO490 460 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO490 470 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,MAX(NLEFT,N2) ISUB(I)=1 515 CONTINUE NQ=MAX(NLEFT,N2) GOTO550 C 520 CONTINUE NIOLD=MAX(NLEFT,N2) CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO550 C 530 CONTINUE NIOLD=MAX(NLEFT,N2) 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 DPPRCL--') 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(' (FROM WHICH PROPORTION CONFIDENCE LIMITS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,555) 555 FORMAT(' ARE TO BE CALCULATED)') 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,MAX(IWIDTH,80)) 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) 570 CONTINUE NS=J C IF(NUMVAR.GE.2)THEN C J=0 IMAX=N2 IF(NQ.LT.N2)IMAX=NQ DO580I=1,IMAX IF(ISUB(I).EQ.0)GOTO580 J=J+1 C IJ=MAXN*(ICOL2-1)+I IF(ICOL2.LE.MAXCOL)X(J)=V(IJ) IF(ICOL2.EQ.MAXCP1)X(J)=PRED(I) IF(ICOL2.EQ.MAXCP2)X(J)=RES(I) IF(ICOL2.EQ.MAXCP3)X(J)=YPLOT(I) IF(ICOL2.EQ.MAXCP4)X(J)=XPLOT(I) IF(ICOL2.EQ.MAXCP5)X(J)=X2PLOT(I) IF(ICOL2.EQ.MAXCP6)X(J)=TAGPLO(I) C 580 CONTINUE NS2=J ENDIF C C ****************************************************** C ** STEP 8-- ** C ** PREPARE FOR ENTRANCE INTO DPPRC2-- ** C ****************************************************** C ISTEPN='8' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ********************************* C ** STEP 9-- ** C ** FORM THE CONFIDENCE LIMITS ** 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 DPPRCL, AS WE ARE ABOUT TO CALL DPPRC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212)NLEFT,N2,MAXN,NS 1212 FORMAT('NLEFT,N2,MAXN,NS = ',4I8) CALL DPWRST('XXX','BUG ') DO1215I=1,NS WRITE(ICOUT,1216)I,Y(I),X(I) 1216 FORMAT('I,Y(I),X(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 1215 CONTINUE WRITE(ICOUT,1231)IBUGA3 1231 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') 1290 CONTINUE C CALL DPPRC2(Y,NS,X,NS2,XTEMP1,XTEMP2,MAXNXT,ICASAN, 1ANOPL1,ANOPL2,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 DPPRCL--') 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 ') 9090 CONTINUE C RETURN END SUBROUTINE DPPRC2(Y,N,X,N2,XTEMP1,XTEMP2,MAXNXT,ICASAN, 1ANOPL1,ANOPL2, 1IBUGA3,IERROR) C C PURPOSE--THIS ROUTINE GENERATES CONFIDENCE LIMITS C FOR THE PROPORTIONS C FOR THE DATA IN THE INPUT VECTOR Y. C ALSO HANDLES THE DIFFERENCE OF TWO PROPORTIONS CASE. C NOTE--ASSUMPTION--MODEL IS RESPONSE = CONSTANT + ERROR. C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR C OF OBSERVATIONS FOR BOTH CASES C X = THE SINGLE PRECISION VECTOR C OF OBSERVATIONS FOR THE DIFFERENCE C OF PROPORTIONS CASE C N = THE INTEGER NUMBER OF C OBSERVATIONS IN THE VECTOR Y. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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--99/3 C ORIGINAL VERSION--MARCH 1999. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASAN CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CCCCC CHARACTER*4 IWRITE C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X(*) DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C DIMENSION CONF(10) DIMENSION T(10) CCCCC DIMENSION TSDM(10) DIMENSION ALOWER(10) DIMENSION AUPPER(10) 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='DPPR' ISUBN2='C2 ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,51) 51 FORMAT('**** AT THE BEGINNING OF DPPRC2--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,52)N,IBUGA3 52 FORMAT('N,IBUGA3 = ',I8,2X,A4) CALL DPWRST('XXX','WRIT') DO56I=1,N WRITE(ICOUT,57)I,Y(I),X(I) 57 FORMAT('I,Y(I),X(I) = ',I8,2E15.7) CALL DPWRST('XXX','WRIT') 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.LE.1)GOTO110 GOTO119 110 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN DPPRC2--THE NUMBER OF OBSERVATIONS ', 1'IN THE RESPONSE VARIABLE IS LESS THAN 2.') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,112)N 112 FORMAT('SAMPLE SIZE = ',I8) CALL DPWRST('XXX','WRIT') IERROR='YES' GOTO9000 119 CONTINUE C C *************************************************** C ** STEP 3-- ** C ** COMPUTE THE NUMBER OF SUCCESSES. ** C *************************************************** C C ISTEPN='3' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C YMIN=ANOPL1 IF(ANOPL1.GT.ANOPL2)YMIN=ANOPL2 YMAX=ANOPL2 IF(ANOPL1.GT.ANOPL2)YMAX=ANOPL1 C AN=REAL(N) NR1=0 DO2120J=1,N IF(YMIN.LE.Y(J).AND.Y(J).LE.YMAX)NR1=NR1+1 2120 CONTINUE ANR1=NR1 C PR1=ANR1/AN IF(ICASAN.EQ.'PROP'.AND.PR1.LE.0.0 .OR. PR1.GE.1.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,201) 201 FORMAT('***** ERROR FROM DPPRC2--PROPORTION OF SUCCESSES IS ', 1'EITHER 0 OR 1') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,203) 203 FORMAT(' (EITHER ALL SUCCESSES OR ALL FAILURES).') CALL DPWRST('XXX','WRIT') IERROR='YES' GOTO9000 ENDIF C IF(ICASAN.EQ.'DPRO')THEN AN2=REAL(N2) NR2=0 DO2130J=1,N2 IF(YMIN.LE.X(J).AND.X(J).LE.YMAX)NR2=NR2+1 2130 CONTINUE ANR2=NR2 C PR2=ANR2/AN2 ENDIF C C *************************************** C ** STEP 4-- ** C ** COMPUTE CONFIDENCE LIMITS ** C ** FOR VARIOUS PROBABILITY VALUES. ** C *************************************** C ISTEPN='4' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CONF(1)=50.0 CONF(2)=75.0 CONF(3)=90.0 CONF(4)=95.0 CONF(5)=99.0 CONF(6)=99.9 CONF(7)=99.99 CONF(8)=99.999 C IF(ICASAN.EQ.'PROP')THEN DO1400I=1,8 PCONF=1.0-(CONF(I)/100.0) PCONF=PCONF/2.0 CDF=1.0-PCONF CALL BINPPF(CDF,PR1,N,T(I)) AUPPER(I)=T(I)/REAL(N) CDF=PCONF CALL BINPPF(CDF,PR1,N,T(I)) ALOWER(I)=T(I)/REAL(N) 1400 CONTINUE ELSEIF(ICASAN.EQ.'DPRO')THEN PDIFF=PR1-PR2 PSE=SQRT(PR1*(1.0-PR1)/REAL(N) + PR2*(1.0-PR2)/REAL(N2)) DO1500I=1,8 PCONF=1.0-(CONF(I)/100.0) PCONF=PCONF/2.0 CDF=1.0-PCONF CALL NORPPF(CDF,T(I)) AUPPER(I)=PDIFF+PSE*T(I) ALOWER(I)=PDIFF-PSE*T(I) 1500 CONTINUE ENDIF 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','WRIT') IF(ICASAN.EQ.'PROP')THEN WRITE(ICOUT,811) 811 FORMAT( 1' CONFIDENCE LIMITS FOR A PROPORTION') ELSE WRITE(ICOUT,911) 911 FORMAT( 1' CONFIDENCE LIMITS FOR DIFFERENCE OF PROPORTIONS') ENDIF CALL DPWRST('XXX','WRIT') WRITE(ICOUT,812) 812 FORMAT( 1' (2-SIDED)') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') IF(ICASAN.EQ.'PROP')THEN WRITE(ICOUT,821)N 821 FORMAT( 1' NUMBER OF OBSERVATIONS = ',I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,822)NR1 822 FORMAT( 1' NUMBER OF SUCCESSES = ',I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,823)PR1 823 FORMAT( 1' PORPORTION OF SUCCESS = ',G15.7) CALL DPWRST('XXX','WRIT') ELSE WRITE(ICOUT,920)N 920 FORMAT( 1' NUMBER OF OBSERVATIONS FOR SAMPLE 1 = ',I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,922)NR1 922 FORMAT( 1' NUMBER OF SUCCESSES FOR SAMPLE 1 = ',I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,923)PR1 923 FORMAT( 1' PORPORTION OF SUCCESS FOR SAMPLE 1 = ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,930)N2 930 FORMAT( 1' NUMBER OF OBSERVATIONS FOR SAMPLE 2 = ',I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,932)NR2 932 FORMAT( 1' NUMBER OF SUCCESSES FOR SAMPLE 2 = ',I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,933)PR2 933 FORMAT( 1' PORPORTION OF SUCCESS FOR SAMPLE 2 = ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,943)PDIFF 943 FORMAT( 1' DIFFERENCE BETWEEN PROPORTIONS = ',G15.7) CALL DPWRST('XXX','WRIT') IF(N.LE.30 .OR. N2.LE.30)THEN WRITE(ICOUT,946) 946 FORMAT( 1' WARNING: IF EITHER OF THE SAMPLE SIZES') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,948) 948 FORMAT( 1' IS LESS THAN 30, THE NORMAL APPROXIMATION') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,949) 949 FORMAT( 1' MAY NOT BE ACCURATE.') CALL DPWRST('XXX','WRIT') ENDIF ENDIF WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,832) 832 FORMAT( 1' CONFIDENCE LOWER UPPER ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,833) 833 FORMAT( 1' VALUE (%) LIMIT LIMIT ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,834) 834 FORMAT( 1'------------------------------------') CALL DPWRST('XXX','WRIT') DO840I=1,8 WRITE(ICOUT,841)CONF(I),ALOWER(I),AUPPER(I) 841 FORMAT( 1' ',F8.3,2X,G12.6,2X,G12.6) CALL DPWRST('XXX','WRIT') 840 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPRC2--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,9012)N,IBUGA3,IERROR 9012 FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','WRIT') DO9016I=1,N WRITE(ICOUT,9017)I,Y(I),X(I) 9017 FORMAT('I,Y(I),X(I) = ',I8,2E15.7) CALL DPWRST('XXX','WRIT') 9016 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPRE2(Y,X1,X2,X3,X4,X5,NUMVAR,IVARN3,IVARN4,W,N, 1MODEL,NUMCHA,PARAM3,IPARN3,IPARN4,NUMPAR,ICON3,IANGLU,IPARO3, 1PARLI3,V,MAXITS,FITSD,FITPOW,CPUEPS, 1ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD, 1IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 1IREP,REPSD,REPDF,RESSD,RESDF,PRED2,RES2,ALFCDF, CCCCC THE FOLLOWING LINE WAS AUGMENTED NOVEMBER 1995 CCCCC1DUM1,DUM2, 1DUM1,DUM2,IANS,IWIDTH, 1IBUGA3,IBUGCO,IBUGEV,IERROR) C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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--OCTOBER 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 1988. ADD LOFCDF C UPDATED --MAY 1990. MOVE SOME DIMENSIONING TO DPPREF C UPDATED --NOVEMBER 1995. IANS, IWIDTH => INPUT ARGS C UPDATED --NOVEMBER 1995. ALL ITERATIONS => DPST1F.DAT C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IVARN3 CHARACTER*4 IVARN4 CHARACTER*4 IPARN3 CHARACTER*4 IPARN4 CHARACTER*4 IANGLU CHARACTER*4 IPARO3 CHARACTER*4 ITYPEH CHARACTER*4 IW2HOL CHARACTER*4 IW22HO CHARACTER*4 IHARG CHARACTER*4 IHARG2 CHARACTER*4 IARGT CHARACTER*4 IREP CHARACTER*4 IBUGA3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IERROR C CHARACTER*4 ICASLS CHARACTER*4 IHPN CHARACTER*4 IHPN2 CHARACTER*4 IHPNV CHARACTER*4 IHPNV2 CHARACTER*4 IPARN5 CHARACTER*4 IPARN6 CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IH3 CHARACTER*4 IH4 CHARACTER*4 IH5 CHARACTER*4 IH6 CHARACTER*4 IH7 CHARACTER*4 IH8 CHARACTER*4 IH9 CHARACTER*4 IH10 CHARACTER*4 MODEL CHARACTER*4 IFOUNF CHARACTER*4 IANS C CCCCC THE FOLLOWING SECTION WAS ADDED NOVEMBER 1995 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 CHARACTER*4 ISUBN0 CHARACTER*4 ISUBRO C CCCCC THE FOLLOWING LINE WAS ADDED NOVEMBER 1995 CHARACTER*4 ISMALL C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C CCCCC JUNE 1990. FOLLOWING INCLUDE FILE NO LONGER NEEDED. CCCCC INCLUDE 'DPCOPA.INC' C CCCCC THE FOLLOWING INCLUDE STATEMENT WAS ADDED NOVEMBER 1995 INCLUDE 'DPCOF2.INC' C DIMENSION IHPNV(200) DIMENSION IHPNV2(200) DIMENSION ASTARV(200) DIMENSION AINCV(200) DIMENSION ASTOPV(200) DIMENSION NUMINV(200) C DIMENSION WORST(200) DIMENSION BEST(200) C DIMENSION Y(*) DIMENSION X1(*) DIMENSION X2(*) DIMENSION X3(*) DIMENSION X4(*) DIMENSION X5(*) C DIMENSION PRED2(*) DIMENSION RES2(*) C DIMENSION IHARG(*) DIMENSION IHARG2(*) DIMENSION IARGT(*) DIMENSION IARG(*) DIMENSION ARG(*) C DIMENSION W(*) C DIMENSION V(*) C DIMENSION MODEL(*) C DIMENSION IVARN3(*) DIMENSION IVARN4(*) DIMENSION PARAM3(*) DIMENSION IPARN3(*) DIMENSION IPARN4(*) DIMENSION ICON3(*) DIMENSION IPARO3(*) DIMENSION PARLI3(*) C DIMENSION ITYPEH(*) DIMENSION IW2HOL(*) DIMENSION IW22HO(*) DIMENSION W2HOLD(*) C DIMENSION IPARN5(100) DIMENSION IPARN6(100) DIMENSION PARAM5(100) C CCCCC FOLLOWING TWO ARRAYS NOW DIMENSIONED IN DPPREF (JUNE, 1990) CCCCC DIMENSION DUM1(MAXOBV) CCCCC DIMENSION DUM2(MAXOBV) DIMENSION DUM1(*) DIMENSION DUM2(*) C CCCCC THE FOLLOWING LINE WAS ADDED NOVEMBER 1995 DIMENSION IANS(*) 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='DPPR' ISUBN2='E2 ' C IERROR='NO' C IPASS=2 C IRESDF=0 IMIN=0 KMAX=0 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 IH2='UNKN' 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 DPPRE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N,NUMVAR,NUMPAR,NUMCHA 52 FORMAT('N,NUMVAR,NUMPAR,NUMCHA = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGA3,IBUGCO,IBUGEV 53 FORMAT('IBUGA3,IBUGCO,IBUGEV = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Y(I),X1(I),W(I) 56 FORMAT('I,Y(I),X1(I),W(I) = ',I5,3F20.10) CALL DPWRST('XXX','BUG ') 55 CONTINUE DO61J=1,NUMVAR WRITE(ICOUT,62)J,IVARN3(J),IVARN4(J) 62 FORMAT('I,IVARN3(I),IVARN4(I) = ',I8,2X,A4,A4) CALL DPWRST('XXX','BUG ') 61 CONTINUE DO66J=1,NUMPAR WRITE(ICOUT,67)J,IPARN3(J),IPARN4(J),PARAM3(J),ICON3(J) 67 FORMAT('I,IPARN3(I),IPARN4(I),PARAM3(I),ICON3(I) = ', 1I8,2X,A4,A4,E15.7,I8) CALL DPWRST('XXX','BUG ') 66 CONTINUE WRITE(ICOUT,71)(MODEL(J),J=1,NUMCHA) 71 FORMAT('FUNCTIONAL EXPRESSION--',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)FITPOW 72 FORMAT('FITPOW = ',E15.7) CALL DPWRST('XXX','BUG ') 90 CONTINUE C CCCCCC THE FOLLOWING SECTION WAS ADDED NOVEMBER 1995 C ************************************************** C ** STEP 15-- ** C ** OPEN THE STORAGE FILES ** C ************************************************** C 1500 CONTINUE ISTEPN='15' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PRE2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOUNI1=IST1NU IFILE1=IST1NA ISTAT1=IST1ST IFORM1=IST1FO IACCE1=IST1AC IPROT1=IST1PR ICURS1=IST1CS ISUBN0='PRE2' 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 C ************************************************** C ** STEP 1-- ** C ** DETERMINE THE PARAMETER NAMES IN THE MODEL ** C ** AND THE NUMBER NUMPAR OF PARAMETERS. ** C ************************************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IPASS=2 C DO1100I=1,100 IPARN5(I)='JUNK' IPARN6(I)='JUNK' PARAM5(I)=-999.0 1100 CONTINUE IF(NUMPAR.LE.0)GOTO1000 DO1150I=1,NUMPAR IPARN5(I)=IPARN3(I) IPARN6(I)=IPARN4(I) PARAM5(I)=PARAM3(I) 1150 CONTINUE 1000 CONTINUE C IF(NUMVAR.LE.0)GOTO1200 DO1300I=1,NUMVAR IPARN5(NUMPAR+I)=IVARN3(I) IPARN6(NUMPAR+I)=IVARN4(I) 1300 CONTINUE 1200 CONTINUE C NUMPV=NUMPAR+NUMVAR C C *************************************************************** C ** STEP 2-- ** C ** DEFINE VARIOUS CONSTANTS. ** C ** DEFINE EPS = MACHINE EPSILON. ** C ** DEFINE TOL = CUTOFF TOLERANCE FOR SUCCESSIVE ESTIMATES. ** C ** DEFINE MAXITS = MAX NUMBER OF ITERATIONS. ** C ** DEFINE EXPND = EXPANSION FACTOR ** C ** DEFINE COMPR = COMPRESSION FACTOR ** C ** DEFINE NCONST = NUMBER OF PARAMETERS HELD CONSTANT. ** C ** DEFINE NP = NUMBER OF NON-CONSTANT PARAMETERS. ** C ** DEFINE DF = DEGREES OF FREEDOM. ** C ** DEFINE SOME WORKING STORAGE START POINTS IN WS. ** C *************************************************************** C ISTEPN='2' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IREP='NO' REPSD=0.0 REPDF=0.0 IREPDF=REPDF+0.5 RESSD=0.0 RESDF=0.0 ALFCDF=(-999.99) IF(NUMPAR.LE.0)GOTO2000 EPS = 1.E-8 DEPS=EPS TOL=0.00001 DTOL=TOL CCCCC MAXITS=50 CCCCC ALAMBA=1. ALAMBA=0.01 EXPND=1.5 COMPR=0.5 NPST=NUMPAR NCONST=0 DO501I=1,NUMPAR IF(ICON3(I).EQ.1)NCONST=NCONST+1 501 CONTINUE NP=NUMPAR-NCONST IF(NP.GT.0) GO TO 35 WRITE(ICOUT,117) NP 117 FORMAT(10X,'NO. OF PARAMETERS TO BE VARIED = ',I8, *'(LESS THAN ONE)') CALL DPWRST('XXX','BUG ') IER = 5 IERROR='YES' CCCCC THE FOLLOWING LINE WAS CHANGED NOVEMBER 1995 CCCCC GOTO9000 GOTO8100 35 CONTINUE DF=N-NP RESDF=DF IRESDF=DF+0.5 IC=0 IER=2 IDA=NP*NP IDU=IDA+NP ID =IDU+NP IDX=ID +NP IY =IDX+NP 2000 CONTINUE C ICASLS='ON' IF(FITPOW.LE.1.999)ICASLS='OFF' IF(FITPOW.GE.2.001)ICASLS='OFF' C IF(IPRINT.EQ.'OFF')GOTO109 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IF(NUMPAR.GE.1.AND.ICASLS.EQ.'ON')WRITE(ICOUT,101) 101 FORMAT('LEAST SQUARES NON-LINEAR PRE-FIT') IF(NUMPAR.GE.1.AND.ICASLS.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(NUMPAR.GE.1.AND.ICASLS.EQ.'OFF')WRITE(ICOUT,102)FITPOW 102 FORMAT('NON-LINEAR PRE-FIT (FIT POWER = ',F10.5,')') IF(NUMPAR.GE.1.AND.ICASLS.EQ.'OFF')CALL DPWRST('XXX','BUG ') IF(NUMPAR.LE.0)WRITE(ICOUT,105) 105 FORMAT('FULLY-SPECIFIED MODEL') IF(NUMPAR.LE.0)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,106)N 106 FORMAT(' SAMPLE SIZE N = ',I8) CALL DPWRST('XXX','BUG ') 109 CONTINUE C IF(IPRINT.EQ.'OFF')GOTO2290 IF(MODEL(1).NE.' ')IMIN=1 IF(MODEL(1).EQ.' ')IMIN=2 IMAX=NUMCHA IDEL=IMAX-IMIN+1 NUMLIN=((IDEL-1)/100)+1 C IF(NUMLIN.LE.0)GOTO2290 DO2240KLINE=1,NUMLIN IF(KLINE.EQ.1)GOTO2250 IF(KLINE.GE.2)GOTO2260 C 2250 CONTINUE KMIN=IMIN KMAX=KMIN+100-1 IF(KMAX.GT.IMAX)KMAX=IMAX WRITE(ICOUT,2252)(MODEL(K),K=KMIN,KMAX) 2252 FORMAT(' MODEL--',100A1) CALL DPWRST('XXX','BUG ') GOTO2240 C 2260 CONTINUE KMIN=KMAX+1 KMAX=KMIN+100-1 IF(KMAX.GT.IMAX)KMAX=IMAX WRITE(ICOUT,2262)(MODEL(K),K=KMIN,KMAX) 2262 FORMAT(13X,100A1) CALL DPWRST('XXX','BUG ') GOTO2240 2240 CONTINUE 2290 CONTINUE C C ************************************************************** C ** STEP 2.5-- ** C ** CHECK FOR REPLICATION AND IF EXISTENT ** C ** COMPUTE A (MODEL-FREE) REPLICATION STANDARD DEVIATION. ** C ************************************************************** C ISTEPN='2.5' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPREPS(Y,X1,X2,X3,X4,X5,N,NUMVAR,DUM1,DUM2, 1IREP,REPSS,REPMS,REPSD,REPDF,NUMSET,IBUGA3,IERROR) IREPDF=REPDF+0.5 C IF(IREP.EQ.'NO')GOTO2800 GOTO2900 C 2800 CONTINUE IF(IPRINT.EQ.'OFF')GOTO2819 WRITE(ICOUT,2811) 2811 FORMAT(' NO REPLICATION CASE') CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') 2819 CONTINUE GOTO2999 C 2900 CONTINUE IF(IPRINT.EQ.'OFF')GOTO2929 WRITE(ICOUT,2911) 2911 FORMAT(' REPLICATION CASE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2922)REPSD 2922 FORMAT(' REPLICATION STANDARD DEVIATION = ',D20.10) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2923)IREPDF 2923 FORMAT(' REPLICATION DEGREES OF FREEDOM = ',2X,I9) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2924)NUMSET 2924 FORMAT(' NUMBER OF DISTINCT SUBSETS = ',2X,I9) CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') 2929 CONTINUE GOTO2999 C 2999 CONTINUE C C *************************************************************** C ** STEP 3-- ** C ** TREAT THE SPECIAL CASE WHERE NO PARAMETERS ** C ** EXIST IN THE MODEL-- ** C ** THAT IS, WE ARE REALLY INTERESTED ** C ** IN GENERATING PREDICTED VALUES AND RESIDUALS ** C ** FROM A FULLY-SPECIFIED MODEL. ** C ** (THIS IS USEFUL FOR MANUALLY ARRIVING AT ** C ** REASONABLE STARTING VALUES FOR A MORE COMPLICATED PRE-FIT;** C ** AND ALSO FOR TESTING THE GOODNESS OF AN ALREADY-DERIVED ** C ** PRE-FIT FOR ONE DOMAIN OVER A SECOND DOMAIN.) ** C *************************************************************** C ISTEPN='3' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMPAR.GE.1)GOTO2664 CALL DPPRE3(MODEL,NUMCHA,IPASS,PARAM5,IPARN5,IPARN6,NUMPV, 1IPARN3,IVARN3,PARAM3,IPARN4,IVARN4,ICON3, 1NUMPAR,NUMVAR,Y,X1,X2,X3,X4,X5,W,N,FITPOW, 1IANGLU,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,PRED2,RES2, 1RESSS,RESSD,RESDF,IBUGA3,IBUGCO,IBUGEV,IERROR) CCCCC THE FOLLOWING LINE WAS CHANGED NOVEMBER 1995 CCCCC IF(IERROR.EQ.'YES')GOTO9000 IF(IERROR.EQ.'YES')GOTO8100 2664 CONTINUE C C ************************************************* C ** STEP 5-- ** C ** DETERMINE THE LATTICE OF PARAMETER VALUES ** C ************************************************* C ISTEPN='5' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ************************************************* C ** STEP 5.1-- ** C ** SEARCH FOR THE FIRST OCCURRANCE OF FOR ** C ************************************************* C ISTEPN='5.1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMPF=0 JMAX=NUMARG-1 DO3100J=1,JMAX J2=J JP1=J+1 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' '.AND. 1IHARG(JP1).EQ.'I '.AND.IHARG2(JP1).EQ.' ')GOTO3150 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO3190 3100 CONTINUE 3150 CONTINUE CALL DPPRE3(MODEL,NUMCHA,IPASS,PARAM5,IPARN5,IPARN6,NUMPV, 1IPARN3,IVARN3,PARAM3,IPARN4,IVARN4,ICON3, 1NUMPAR,NUMVAR,Y,X1,X2,X3,X4,X5,W,N,FITPOW, 1IANGLU,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,PRED2,RES2, 1RESSS,RESSD,RESDF,IBUGA3,IBUGCO,IBUGEV,IERROR) CCCCC THE FOLLOWING LINE WAS CHANGED NOVEMBER 1995 CCCCC IF(IERROR.EQ.'YES')GOTO9000 IF(IERROR.EQ.'YES')GOTO8100 DO3160I=1,NUMPAR BEST(I)=PARAM3(I) 3160 CONTINUE RESSMN=RESSD GOTO6100 3190 CONTINUE IFOLOC=J2 ILALOC=IFOLOC-1 C C ************************************************ C ** STEP 5.2-- ** C ** EXTRACT START,INCREMENT, AND STOP VALUES ** C ** FOR EACH PARAMETER GIVEN ** C ** VIA EACH FOR QUALIFICATION. ** C ************************************************ C ISTEPN='5.2' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMPF=0 IF(IPRINT.EQ.'ON')WRITE(ICOUT,999) IF(IPRINT.EQ.'ON')CALL DPWRST('XXX','BUG ') DO3200ITER=1,1000 IFOLOC=ILALOC+1 J=IFOLOC JP1=J+1 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' '.AND. 1IHARG(JP1).EQ.'I '.AND.IHARG2(JP1).EQ.' ')GOTO3280 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO3220 GOTO3280 3220 CONTINUE CALL DPEXSE(IFOLOC,IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 1IANS,IWIDTH, 1IHPN,IHPN2,ASTART,AINC,ASTOP,NUMINC,ILALOC,IBUGA3,IFOUNF,IERROR) IF(IFOUNF.EQ.'NO')GOTO3280 NUMPF=NUMPF+1 IHPNV(NUMPF)=IHPN IHPNV2(NUMPF)=IHPN2 ASTARV(NUMPF)=ASTART AINCV(NUMPF)=AINC ASTOPV(NUMPF)=ASTOP NUMINV(NUMPF)=NUMINC IF(IPRINT.EQ.'ON'.AND.NUMPF.GE.1) 1WRITE(ICOUT,3221)IHPN,IHPN2,ASTART,AINC,ASTOP 3221 FORMAT(' LATTICE VALUES FOR ',A4,A4,' = ',3E15.7) IF(IPRINT.EQ.'ON'.AND.NUMPF.GE.1) 1CALL DPWRST('XXX','BUG ') IF(IBUGA3.EQ.'OFF')GOTO3239 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3231)NUMPF 3231 FORMAT('NUMPF = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3232)IHPNV(NUMPF),IHPNV2(NUMPF) 3232 FORMAT('IHPNV(NUMPF),IHPNV2(NUMPF) = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3233)ASTARV(NUMPF),AINCV(NUMPF),ASTOPV(NUMPF) 3233 FORMAT('ASTARV(NUMPF),AINCV(NUMPF),ASTOPV(NUMPF) = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3234)NUMINV(NUMPF) 3234 FORMAT('NUMINV(NUMPF) = ',I8) CALL DPWRST('XXX','BUG ') 3239 CONTINUE 3200 CONTINUE 3280 CONTINUE C IPROD=1 IF(NUMPF.LE.0)GOTO3289 DO3285I=1,NUMPF IPROD=IPROD*NUMINV(I) 3285 CONTINUE 3289 CONTINUE NUMLAP=IPROD IF(IPRINT.EQ.'ON'.AND.NUMPF.GE.1)WRITE(ICOUT,999) IF(IPRINT.EQ.'ON'.AND.NUMPF.GE.1)CALL DPWRST('XXX','BUG ') IF(IPRINT.EQ.'ON'.AND.NUMPF.GE.1)WRITE(ICOUT,3291)NUMLAP 3291 FORMAT(' NUMBER OF LATTICE POINTS = ',2X,I9) IF(IPRINT.EQ.'ON'.AND.NUMPF.GE.1)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3292)NUMINV(NUMPF) 3292 FORMAT('NUMINV(NUMPF) = ',I8) IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') C C *************************** C ** STEP 5.3-- ** C ** PRINT OUT A HEADING ** C *************************** C ISTEPN='5.3' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'OFF')GOTO3390 WRITE(ICOUT,3311) 3311 FORMAT(' STEP RESIDUAL * PARAMETER') CALL DPWRST('XXX','BUG ') IF(ICASLS.EQ.'ON')WRITE(ICOUT,3312) 3312 FORMAT(' NUMBER STANDARD * ESTIMATES') IF(ICASLS.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(ICASLS.EQ.'OFF')WRITE(ICOUT,3313) 3313 FORMAT(' NUMBER NORM * ESTIMATES') IF(ICASLS.EQ.'OFF')CALL DPWRST('XXX','BUG ') IF(ICASLS.EQ.'ON')WRITE(ICOUT,3314) 3314 FORMAT(' DEVIATION * ') IF(ICASLS.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(ICASLS.EQ.'OFF')WRITE(ICOUT,3315) 3315 FORMAT(' * ') IF(ICASLS.EQ.'OFF')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3316) 3316 FORMAT('----------------------------------*-----------') CALL DPWRST('XXX','BUG ') 3390 CONTINUE C C **************************************************** C ** STEP 5.4-- ** C ** STEP THROUGH THE VARIOUS VALUES ** C ** OF THE PARAMETER LATTICE; ** C ** COMPUTE RESIDUAL STANDARD DEVIATION FOR EACH ** C ** LATTICE VALUE. ** C **************************************************** C ISTEPN='5.4' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C RESSMN=CPUMAX RESSMX=CPUMIN C N1=0 N2=0 N3=0 N4=0 N5=0 N6=0 N7=0 N8=0 N9=0 N10=0 C I1=1 I2=1 I3=1 I4=1 I5=1 I6=1 I7=1 I8=1 I9=1 I10=1 C IF(NUMPF.LE.0)GOTO4090 N1=NUMINV(1) IF(NUMPF.LE.1)GOTO4090 N2=NUMINV(2) IF(NUMPF.LE.2)GOTO4090 N3=NUMINV(3) IF(NUMPF.LE.3)GOTO4090 N4=NUMINV(4) IF(NUMPF.LE.4)GOTO4090 N5=NUMINV(5) IF(NUMPF.LE.5)GOTO4090 N6=NUMINV(6) IF(NUMPF.LE.6)GOTO4090 N7=NUMINV(7) IF(NUMPF.LE.7)GOTO4090 N8=NUMINV(8) IF(NUMPF.LE.8)GOTO4090 N9=NUMINV(9) IF(NUMPF.LE.9)GOTO4090 N10=NUMINV(10) IF(NUMPF.LE.10)GOTO4090 4090 CONTINUE C ISTEP=0 C IPAR1=1 I1=0 4100 CONTINUE I1=I1+1 AI1=I1 P1=ASTARV(IPAR1)+(AI1-1.0)*AINCV(IPAR1) IF(I1.EQ.N1)P1=ASTOPV(IPAR1) IF(I1.GE.2)GOTO4115 IH=IHPNV(IPAR1) IH2=IHPNV2(IPAR1) DO4110J1=1,NUMPAR J12=J1 IF(IH.EQ.IPARN5(J1).AND.IH2.EQ.IPARN6(J1))GOTO4115 4110 CONTINUE GOTO4119 4115 CONTINUE PARAM3(J12)=P1 PARAM5(J12)=P1 4119 CONTINUE IF(NUMPF.LE.1)GOTO5100 C IPAR2=2 I2=0 4200 CONTINUE I2=I2+1 AI2=I2 P2=ASTARV(IPAR2)+(AI2-1.0)*AINCV(IPAR2) IF(I2.EQ.N2)P2=ASTOPV(IPAR2) IF(I2.GE.2)GOTO4215 IH=IHPNV(IPAR2) IH2=IHPNV2(IPAR2) DO4210J2=1,NUMPAR J22=J2 IF(IH.EQ.IPARN5(J2).AND.IH2.EQ.IPARN6(J2))GOTO4215 4210 CONTINUE GOTO4219 4215 CONTINUE PARAM3(J22)=P2 PARAM5(J22)=P2 4219 CONTINUE IF(NUMPF.LE.2)GOTO5100 C IPAR3=3 I3=0 4300 CONTINUE I3=I3+1 AI3=I3 P3=ASTARV(IPAR3)+(AI3-1.0)*AINCV(IPAR3) IF(I3.EQ.N3)P3=ASTOPV(IPAR3) IF(I3.GE.2)GOTO4315 IH=IHPNV(IPAR3) IH3=IHPNV2(IPAR3) DO4310J3=1,NUMPAR J32=J3 IF(IH.EQ.IPARN5(J3).AND.IH2.EQ.IPARN6(J3))GOTO4315 4310 CONTINUE GOTO4319 4315 CONTINUE PARAM3(J32)=P3 PARAM5(J32)=P3 4319 CONTINUE IF(NUMPF.LE.3)GOTO5100 C IPAR4=4 I4=0 4400 CONTINUE I4=I4+1 AI4=I4 P4=ASTARV(IPAR4)+(AI4-1.0)*AINCV(IPAR4) IF(I4.EQ.N4)P4=ASTOPV(IPAR4) IF(I4.GE.2)GOTO4415 IH=IHPNV(IPAR4) IH4=IHPNV2(IPAR4) DO4410J4=1,NUMPAR J42=J4 IF(IH.EQ.IPARN5(J4).AND.IH2.EQ.IPARN6(J4))GOTO4415 4410 CONTINUE GOTO4419 4415 CONTINUE PARAM3(J42)=P4 PARAM5(J42)=P4 4419 CONTINUE IF(NUMPF.LE.4)GOTO5100 C IPAR5=5 I5=0 4500 CONTINUE I5=I5+1 AI5=I5 P5=ASTARV(IPAR5)+(AI5-1.0)*AINCV(IPAR5) IF(I5.EQ.N5)P5=ASTOPV(IPAR5) IF(I5.GE.2)GOTO4515 IH=IHPNV(IPAR5) IH5=IHPNV2(IPAR5) DO4510J5=1,NUMPAR J52=J5 IF(IH.EQ.IPARN5(J5).AND.IH2.EQ.IPARN6(J5))GOTO4515 4510 CONTINUE GOTO4519 4515 CONTINUE PARAM3(J52)=P5 PARAM5(J52)=P5 4519 CONTINUE IF(NUMPF.LE.5)GOTO5100 C IPAR6=6 I6=0 4600 CONTINUE I6=I6+1 AI6=I6 P6=ASTARV(IPAR6)+(AI6-1.0)*AINCV(IPAR6) IF(I6.EQ.N6)P6=ASTOPV(IPAR6) IF(I6.GE.2)GOTO4615 IH=IHPNV(IPAR6) IH6=IHPNV2(IPAR6) DO4610J6=1,NUMPAR J62=J6 IF(IH.EQ.IPARN5(J6).AND.IH2.EQ.IPARN6(J6))GOTO4615 4610 CONTINUE GOTO4619 4615 CONTINUE PARAM3(J62)=P6 PARAM5(J62)=P6 4619 CONTINUE IF(NUMPF.LE.6)GOTO5100 C IPAR7=7 I7=0 4700 CONTINUE I7=I7+1 AI7=I7 P7=ASTARV(IPAR7)+(AI7-1.0)*AINCV(IPAR7) IF(I7.EQ.N7)P7=ASTOPV(IPAR7) IF(I7.GE.2)GOTO4715 IH=IHPNV(IPAR7) IH7=IHPNV2(IPAR7) DO4710J7=1,NUMPAR J72=J7 IF(IH.EQ.IPARN5(J7).AND.IH2.EQ.IPARN6(J7))GOTO4715 4710 CONTINUE GOTO4719 4715 CONTINUE PARAM3(J72)=P7 PARAM5(J72)=P7 4719 CONTINUE IF(NUMPF.LE.7)GOTO5100 C IPAR8=8 I8=0 4800 CONTINUE I8=I8+1 AI8=I8 P8=ASTARV(IPAR8)+(AI8-1.0)*AINCV(IPAR8) IF(I8.EQ.N8)P8=ASTOPV(IPAR8) IF(I8.GE.2)GOTO4815 IH=IHPNV(IPAR8) IH8=IHPNV2(IPAR8) DO4810J8=1,NUMPAR J82=J8 IF(IH.EQ.IPARN5(J8).AND.IH2.EQ.IPARN6(J8))GOTO4815 4810 CONTINUE GOTO4819 4815 CONTINUE PARAM3(J82)=P8 PARAM5(J82)=P8 4819 CONTINUE IF(NUMPF.LE.8)GOTO5100 C IPAR9=9 I9=0 4900 CONTINUE I9=I9+1 AI9=I9 P9=ASTARV(IPAR9)+(AI9-1.0)*AINCV(IPAR9) IF(I9.EQ.N9)P9=ASTOPV(IPAR9) IF(I9.GE.2)GOTO4915 IH=IHPNV(IPAR9) IH9=IHPNV2(IPAR9) DO4910J9=1,NUMPAR J92=J9 IF(IH.EQ.IPARN5(J9).AND.IH2.EQ.IPARN6(J9))GOTO4915 4910 CONTINUE GOTO4919 4915 CONTINUE PARAM3(J92)=P9 PARAM5(J92)=P9 4919 CONTINUE IF(NUMPF.LE.9)GOTO5100 C IPAR10=10 I10=0 5000 CONTINUE I10=I10+1 AI10=I10 P10=ASTARV(IPAR10)+(AI10-1.0)*AINCV(IPAR10) IF(I10.EQ.N10)P10=ASTOPV(IPAR10) IF(I10.GE.2)GOTO5015 IH=IHPNV(IPAR10) IH10=IHPNV2(IPAR10) DO5010J10=1,NUMPAR J102=J10 IF(IH.EQ.IPARN5(J10).AND.IH2.EQ.IPARN6(J10))GOTO5015 5010 CONTINUE GOTO5019 5015 CONTINUE PARAM3(J102)=P10 PARAM5(J102)=P10 5019 CONTINUE IF(NUMPF.LE.10)GOTO5100 C 5100 CONTINUE ISTEP=ISTEP+1 CALL DPPRE3(MODEL,NUMCHA,IPASS,PARAM5,IPARN5,IPARN6,NUMPV, 1IPARN3,IVARN3,PARAM3,IPARN4,IVARN4,ICON3, 1NUMPAR,NUMVAR,Y,X1,X2,X3,X4,X5,W,N,FITPOW, 1IANGLU,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,PRED2,RES2, 1RESSS,RESSD,RESDF,IBUGA3,IBUGCO,IBUGEV,IERROR) CCCCC THE FOLLOWING LINE WAS CHANGE NOVEMBER 1995 CCCCC IF(IERROR.EQ.'YES')GOTO9000 IF(IERROR.EQ.'YES')GOTO8100 C IF(RESSD.GT.RESSMX)GOTO5110 GOTO5119 5110 CONTINUE DO5115I=1,NUMPAR WORST(I)=PARAM5(I) 5115 CONTINUE RESSMX=RESSD 5119 CONTINUE C CCCCC THE FOLLOWING 19 LINES WERE REWRITTEN NOVEMBER 1995 ISMALL='NO' IF(RESSD.LT.RESSMN)THEN DO5125I=1,NUMPAR BEST(I)=PARAM5(I) 5125 CONTINUE RESSMN=RESSD ISMALL='YES' END IF C IF(ISMALL.EQ.'YES')THEN IF(IPRINT.EQ.'ON')THEN WRITE(ICOUT,5191)ISTEP,RESSD,(PARAM3(J),J=1,NUMPAR) 5191 FORMAT(I5,'--',4X,9X,1X,E12.5,' *',8E12.5) CALL DPWRST('XXX','BUG ') END IF END IF C WRITE(IOUNI1,5192)RESSD,(PARAM3(J),J=1,NUMPAR) 5192 FORMAT(1X,E12.5,8E12.5) C IF(I10.LT.N10)GOTO5000 IF(I9.LT.N9)GOTO4900 IF(I8.LT.N8)GOTO4800 IF(I7.LT.N7)GOTO4700 IF(I6.LT.N6)GOTO4600 IF(I5.LT.N5)GOTO4500 IF(I4.LT.N4)GOTO4400 IF(I3.LT.N3)GOTO4300 IF(I2.LT.N2)GOTO4200 IF(I1.LT.N1)GOTO4100 C C ******************************************************* C ** STEP 12-- ** C ** PRINT OUT FINAL PARAMETER ESTIMATES ** C ** AND THEIR STANDARD DEVIATIONS. ** C ** ALSO PRINT OUT THE RESIDUAL STANDARD DEVIATION. ** C ******************************************************* C 6100 CONTINUE ISTEPN='12' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO6110I=1,NUMPAR PARAM3(I)=BEST(I) 6110 CONTINUE RESSD=RESSMN C IF(IPRINT.EQ.'OFF')GOTO6119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') CCCCC IF(NUMPF.GE.1)WRITE(ICOUT,999) CCCCC IF(NUMPF.GE.1)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6111) 6111 FORMAT (7X,'FINAL PARAMETER ESTIMATES ') CALL DPWRST('XXX','BUG ') 6119 CONTINUE C IF(IPRINT.EQ.'OFF')GOTO6129 DO6120I=1,NUMPAR WRITE(ICOUT,6121)I,IPARN3(I),IPARN4(I), 1PARAM3(I) 6121 FORMAT(I8,2X,A4,A4,2X,G22.6) CALL DPWRST('XXX','BUG ') 6120 CONTINUE 6129 CONTINUE C C ********************************************* C ** STEP 13-- ** C ** PRINT OUT GOODNESS OF FIT INFORMATION ** C ********************************************* C 7000 CONTINUE ISTEPN='13' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'OFF')GOTO7129 IF(NUMPAR.GE.1)WRITE(ICOUT,999) IF(NUMPAR.GE.1)CALL DPWRST('XXX','BUG ') IF(ICASLS.EQ.'ON')WRITE(ICOUT,7125)RESSD 7125 FORMAT(' RESIDUAL STANDARD DEVIATION = ',F20.10) IF(ICASLS.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(ICASLS.EQ.'OFF')WRITE(ICOUT,7126)RESSD 7126 FORMAT(' RESIDUAL NORM = ',F20.10) IF(ICASLS.EQ.'OFF')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7127)IRESDF 7127 FORMAT(' RESIDUAL DEGREES OF FREEDOM = ',2X,I9) CALL DPWRST('XXX','BUG ') 7129 CONTINUE C IF(IREP.EQ.'NO')GOTO7250 IFITDF=IRESDF-IREPDF IF(IPRINT.EQ.'OFF')GOTO7269 WRITE(ICOUT,7227)REPSD 7227 FORMAT(' REPLICATION STANDARD DEVIATION = ',F20.10) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7228)IREPDF 7228 FORMAT(' REPLICATION DEGREES OF FREEDOM = ',2X,I9) CALL DPWRST('XXX','BUG ') IF(IFITDF.GE.1)GOTO7261 WRITE(ICOUT,7236) 7236 FORMAT(' LACK OF FIT F TEST CANNOT BE DONE BECAUSE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7237) 7237 FORMAT(' HAVE ONLY 0 DEGREES OF FREEDOM IN ', 1'NUMERATOR OF F RATIO.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7238) 7238 FORMAT(' THIS HAPPENS WHEN NUMBER OF PARAMETERS ', 1'FITTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7239) 7239 FORMAT(' IS IDENTICAL TO NUMBER OF DISTINCT ', 1'SUBSETS.') CALL DPWRST('XXX','BUG ') 7269 CONTINUE GOTO7250 7261 CONTINUE C FITDF=IFITDF FITSS=RESSS-REPSS FITMS=FITSS/FITDF FSTAT=FITMS/REPMS CALL FCDF(FSTAT,IFITDF,IREPDF,CDF) CDF2=100.0*CDF CCCCC THE FOLLOWING LINE WAS INSERTED MARCH 1988. ALFCDF=CDF C IF(IPRINT.EQ.'OFF')GOTO7259 WRITE(ICOUT,7240)FSTAT,CDF2 7240 FORMAT(' LACK OF FIT F RATIO = ',F10.4,' = THE ', 1F8.4,'% POINT OF THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7245)IFITDF,IREPDF 7245 FORMAT(' F DISTRIBUTION WITH ',I6,' AND ',I6, 1' DEGREES OF FREEDOM') CALL DPWRST('XXX','BUG ') 7259 CONTINUE 7250 CONTINUE CCCCC THE FOLLOWING LINE WAS CHANGED NOVEMBER 1995 CCCCC IF(NUMPAR.LE.0)GOTO9000 IF(NUMPAR.LE.0)GOTO8100 C CCCCCC THE FOLLOWING SECTION WAS ADDED NOVEMBER 1995 C ************************************** C ** STEP 81-- ** C ** CLOSE THE STORAGE FILES. ** C ************************************** C 8100 CONTINUE C ISTEPN='81' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PRE2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 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 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 DPPRE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IERROR 9012 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N,NUMVAR,NUMPAR,NUMCHA 9013 FORMAT('N,NUMVAR,NUMPAR,NUMCHA = ',4I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NUMPAR WRITE(ICOUT,9016)I,IPARN3(I),IPARN4(I),PARAM3(I) 9016 FORMAT('I,IPARN3(I),IPARN4(I),PARAM3(I) = ',I8,2X,A4,A4,E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9017)IBUGA3,IBUGCO,IBUGEV 9017 FORMAT('IBUGA3,IBUGCO,IBUGEV = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') DO9020I=1,N WRITE(ICOUT,9021)I,Y(I),X1(I),X2(I),W(I),PRED2(I),RES2(I) 9021 FORMAT('I,Y(I),X1(I),X2(I),W(I),PRED2(I),RES2(I) = ', 1I8,6E13.7) CALL DPWRST('XXX','BUG ') 9020 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPRE3(MODEL,NUMCHA,IPASS,PARAM5,IPARN5,IPARN6,NUMPV, 1IPARN3,IVARN3,PARAM3,IPARN4,IVARN4,ICON3, 1NUMPAR,NUMVAR,Y,X1,X2,X3,X4,X5,W,N,FITPOW, 1IANGLU,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,PRED2,RES2, 1RESSS,RESSD,RESDF,IBUGA3,IBUGCO,IBUGEV,IERROR) C C PURPOSE--TAKE A MODEL AND A DATA SET C AND A SET OF PARAMETER VALUES C AND COMPUTE A RESIDUAL STANDARD DEVIATION. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 MODEL CHARACTER*4 IPARN5 CHARACTER*4 IPARN6 CHARACTER*4 IPARN3 CHARACTER*4 IVARN3 CHARACTER*4 IPARN4 CHARACTER*4 IVARN4 CHARACTER*4 IANGLU CHARACTER*4 ITYPEH CHARACTER*4 IW2HOL CHARACTER*4 IW22HO CHARACTER*4 IBUGA3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN3 C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X1(*) DIMENSION X2(*) DIMENSION X3(*) DIMENSION X4(*) DIMENSION X5(*) DIMENSION W(*) C DIMENSION PRED2(*) DIMENSION RES2(*) C DIMENSION MODEL(*) C DIMENSION IVARN3(*) DIMENSION IVARN4(*) DIMENSION PARAM3(*) DIMENSION IPARN3(*) DIMENSION IPARN4(*) DIMENSION ICON3(*) DIMENSION ITYPEH(*) DIMENSION IW2HOL(*) DIMENSION IW22HO(*) DIMENSION W2HOLD(*) C DIMENSION IPARN5(*) DIMENSION IPARN6(*) DIMENSION PARAM5(*) 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='DPPR' ISUBN3='E3 ' 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 DPPRE3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N,NUMVAR,NUMPAR,NUMPV,NUMCHA 52 FORMAT('N,NUMVAR,NUMPAR,NUMPV,NUMCHA = ',5I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGA3,IBUGCO,IBUGEV 53 FORMAT('IBUGA3,IBUGCO,IBUGEV = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Y(I),X1(I),W(I) 56 FORMAT('I,Y(I),X1(I),W(I) = ',I5,3F20.10) CALL DPWRST('XXX','BUG ') 55 CONTINUE DO61J=1,NUMVAR WRITE(ICOUT,62)J,IVARN3(J),IVARN4(J) 62 FORMAT('I,IVARN3(I),IVARN4(I) = ',I8,2X,A4,A4) CALL DPWRST('XXX','BUG ') 61 CONTINUE DO66J=1,NUMPV WRITE(ICOUT,67)J,IPARN3(J),IPARN4(J),PARAM3(J),ICON3(J) 67 FORMAT('I,IPARN3(I),IPARN4(I),PARAM3(I),ICON3(I) = ', 1I8,2X,A4,A4,E15.7,I8) CALL DPWRST('XXX','BUG ') 66 CONTINUE WRITE(ICOUT,71)(MODEL(J),J=1,NUMCHA) 71 FORMAT('FUNCTIONAL EXPRESSION--',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)FITPOW 72 FORMAT('FITPOW = ',E15.7) CALL DPWRST('XXX','BUG ') 90 CONTINUE C DO2100I=1,N W(I)=1.0 2100 CONTINUE C DO3000I=1,N IF(NUMVAR.LE.0)GOTO3090 PARAM5(NUMPAR+1)=X1(I) IF(NUMVAR.LE.1)GOTO3090 PARAM5(NUMPAR+2)=X2(I) IF(NUMVAR.LE.2)GOTO3090 PARAM5(NUMPAR+3)=X3(I) IF(NUMVAR.LE.3)GOTO3090 PARAM5(NUMPAR+4)=X4(I) IF(NUMVAR.LE.4)GOTO3090 PARAM5(NUMPAR+5)=X5(I) 3090 CONTINUE IF(IBUGA3.EQ.'ON')WRITE(ICOUT,888)NUMPAR,NUMVAR,NUMPV 888 FORMAT('NUMPAR,NUMVAR,NUMPV = ',3I8) IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(IBUGA3.EQ.'ON')WRITE(ICOUT,889)X1(1),X1(I),IPARN5(3),IPARN6(3), 1PARAM5(3) 889 FORMAT('X1(1),X1(I),IPARN5(3),IPARN6(3),PARAM5(3) = ', 1E15.7,E15.7,2X,A4,2X,A4,E15.7) IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM5,IPARN5,IPARN6,NUMPV, 1IANGLU,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,PRED2(I), 1IBUGCO,IBUGEV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 3000 CONTINUE C DO3100I=1,N RES2(I)=Y(I)-PRED2(I) 3100 CONTINUE C SUM=0.0 DO3200I=1,N IF(RES2(I).EQ.0.0)GOTO3200 SUM=SUM+ABS(RES2(I))**FITPOW 3200 CONTINUE RESSS=SUM C IRESDF=N-NUMPAR RESDF=IRESDF RESMS=RESSS/RESDF IF(RESMS.LE.0.0)RESSD=0.0 IF(RESMS.GT.0.0)RESSD=SQRT(RESMS) 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 DPPRE3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IERROR 9012 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N,NUMVAR,NUMPAR,NUMCHA 9013 FORMAT('N,NUMVAR,NUMPAR,NUMCHA = ',4I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NUMPAR WRITE(ICOUT,9016)I,IPARN3(I),IPARN4(I),PARAM3(I) 9016 FORMAT('I,IPARN3(I),IPARN4(I),PARAM3(I) = ',I8,2X,A4,A4,E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9017)IBUGA3,IBUGCO,IBUGEV 9017 FORMAT('IBUGA3,IBUGCO,IBUGEV = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)RESSS,RESSD,RESDF 9018 FORMAT('RESSS,RESSD,RESDF = ',3E15.7) CALL DPWRST('XXX','BUG ') DO9020I=1,N WRITE(ICOUT,9021)I,Y(I),X1(I),X2(I),W(I),PRED2(I),RES2(I) 9021 FORMAT('I,Y(I),X1(I),X2(I),W(I),PRED2(I),RES2(I) = ', 1I8,6E13.7) CALL DPWRST('XXX','BUG ') 9020 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPREC(IHARG,NUMARG,IDEFPR,IHMXPR, 1IPREC,IFOUND,IERROR) C C PURPOSE--SPECIFY THE PRECISION SWITCH WHICH IN TURN C DETERMINES WHETHER SUBSEQUENT CALCULATIONS WILL BE C CARRIED OUT IN SINGLE, DOUBLE, C TRIPLE, OR QUADRUPLE PRECISION C (IF AVAILABLE ON THE HOST COMPUTER). C THE SPECIFIED PRECISION SWITCH SPECIFICATION C WILL BE PLACED IN THE HOLLERITH VARIABLE IPREC. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG (AN INTEGER VARIABLE) C --IDEFPR (A HOLLERITH VARIABLE) C --IHMXPR (A HOLLERITH VARIABLE) C OUTPUT ARGUMENTS--IPREC (A HOLLERITH VARIABLE) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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 --SEPTEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFPR CHARACTER*4 IHMXPR CHARACTER*4 IPREC 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 IFOUND='NO' IERROR='NO' C IFOUND='YES' C 1110 CONTINUE IF(NUMARG.LE.0)GOTO1120 IF(IHARG(NUMARG).EQ.'ON')GOTO1120 IF(IHARG(NUMARG).EQ.'OFF')GOTO1120 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1120 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1120 C IF(IHARG(NUMARG).EQ.'SING')GOTO1130 IF(IHARG(NUMARG).EQ.'DOUB')GOTO1130 IF(IHARG(NUMARG).EQ.'TRIP')GOTO1130 IF(IHARG(NUMARG).EQ.'QUAD')GOTO1130 GOTO1120 C 1120 CONTINUE IHOLD=IDEFPR GOTO1160 C 1130 CONTINUE IHOLD=IHARG(NUMARG) GOTO1160 C 1160 CONTINUE IF(IHOLD.EQ.'DOUB'.AND.IHMXPR.EQ.'SING')GOTO1170 IF(IHOLD.EQ.'TRIP'.AND.IHMXPR.EQ.'SING')GOTO1170 IF(IHOLD.EQ.'TRIP'.AND.IHMXPR.EQ.'DOUB')GOTO1170 IF(IHOLD.EQ.'QUAD'.AND.IHMXPR.EQ.'SING')GOTO1170 IF(IHOLD.EQ.'QUAD'.AND.IHMXPR.EQ.'DOUB')GOTO1170 IF(IHOLD.EQ.'QUAD'.AND.IHMXPR.EQ.'TRIP')GOTO1170 GOTO1180 C 1170 CONTINUE IERROR='YES' WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1172) 1172 FORMAT('***** ERROR IN DPPREC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1173) 1173 FORMAT(' THE DESIRED PRECISION IS HIGHER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1174) 1174 FORMAT(' THAN PERMITTED ON THIS COMPUTER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1175)IHOLD 1175 FORMAT(' DESIRED PRECISION = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1176)IHMXPR 1176 FORMAT(' MAXIMUM ALLOWABLE PRECISION = ',A4) CALL DPWRST('XXX','BUG ') GOTO1199 C 1180 CONTINUE IPREC=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1188)IPREC 1188 FORMAT('THE PRECISION SWITCH HAS JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPPREE(IHARG,NUMARG, 1IERASW,IFOUND,IERROR) C C PURPOSE--SPECIFY THE PRE-ERASE SWITCH WHICH IN TURN C DETERMINES WHETHER A PRE-ERASE WILL C AUTOMATICALLY OCCUR BEFORE PLOTS. C THIS CAPABILITY IS USEFUL FOR AUTOMATICALLY C CLEARING THE SCREEN BEFORE PLOTS. C THE SPECIFIED PRE-ERASE SWITCH SPECIFICATION C WILL BE PLACED IN THE HOLLERITH VARIABLE IERASW. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG (AN INTEGER VARIABLE) C OUTPUT ARGUMENTS--IERASW (A HOLLERITH VARIABLE) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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 IERASW 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 IFOUND='NO' IERROR='NO' C IF(NUMARG.EQ.0)GOTO1199 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ERAS')GOTO1110 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.0)GOTO1150 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1160 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 GOTO1150 C 1150 CONTINUE IHOLD='ON' GOTO1180 C 1160 CONTINUE IHOLD='OFF' GOTO1180 C 1180 CONTINUE IFOUND='YES' IERASW=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IERASW 1181 FORMAT('THE PRE-ERASE SWITCH HAS JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPPREF(IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO, 1IFOUND,IERROR) C C PURPOSE--CARRY OUT A (LINEAR OR) NON-LINEAR PRE-FIT C = A FIT OVER A SPECIFIED LATTICE OF PARAMETER VALUES. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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--OCTOBER 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 1988. ADD LOFCDF C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C UPDATED --JUNE 1990. MOVE DIMENSIONING OF ARRAYS C UPDATED --NOVEMBER 1995. IANS, IWIDTH => CALLING ARGS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ICASFI CHARACTER*4 ICASEQ CHARACTER*4 IKEY CHARACTER*4 IWD CHARACTER*4 IWD1 CHARACTER*4 IWD12 CHARACTER*4 IWD2 CHARACTER*4 IWD22 CHARACTER*4 ICH CHARACTER*4 ITYPEH CHARACTER*4 IW2HOL CHARACTER*4 IW22HO CHARACTER*4 IOP CHARACTER*4 IPAROC CHARACTER*4 IPARO3 CHARACTER*4 IREPU CHARACTER*4 IRESU CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IPARN CHARACTER*4 IPARN2 CHARACTER*4 IPARN3 CHARACTER*4 IPARN4 CHARACTER*4 IHPARN CHARACTER*4 IHPAR2 CHARACTER*4 IVARN3 CHARACTER*4 IVARN4 CHARACTER*4 IREP C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION IPAROC(100) C CCCCC DIMENSION ITYPEH(225) CCCCC DIMENSION IW2HOL(225) CCCCC DIMENSION IW22HO(225) CCCCC DIMENSION W2HOLD(225) DIMENSION ITYPEH(1000) DIMENSION IW2HOL(1000) DIMENSION IW22HO(1000) DIMENSION W2HOLD(1000) C DIMENSION PARAM(100) DIMENSION IPARN(100) DIMENSION IPARN2(100) C DIMENSION X1(MAXOBV) DIMENSION X2(MAXOBV) DIMENSION X3(MAXOBV) DIMENSION X4(MAXOBV) DIMENSION X5(MAXOBV) C DIMENSION W(MAXOBV) C DIMENSION PRED2(MAXOBV) DIMENSION RES2(MAXOBV) C DIMENSION PARAM3(100) DIMENSION IPARN3(100) DIMENSION IPARN4(100) DIMENSION ICON3(100) DIMENSION IPARO3(100) DIMENSION PARLI3(100) DIMENSION IVARN3(100) DIMENSION IVARN4(100) DIMENSION ICOLV3(100) DIMENSION NIV(100) C DIMENSION ICH(10) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOSU.INC' INCLUDE 'DPCODA.INC' C C--------------------------------------------------------------------- C EQUIVALENCE (W(1),X3D(1)) EQUIVALENCE (PRED2(1),X(1)) EQUIVALENCE (RES2(1),D(1)) C CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' DIMENSION DUM1(MAXOBV) DIMENSION DUM2(MAXOBV) EQUIVALENCE (GARBAG(IGARB1),X1(1)) EQUIVALENCE (GARBAG(IGARB2),X2(1)) EQUIVALENCE (GARBAG(IGARB3),X3(1)) EQUIVALENCE (GARBAG(IGARB4),X4(1)) EQUIVALENCE (GARBAG(IGARB5),X5(1)) EQUIVALENCE (GARBAG(IGARB6),DUM1(1)) EQUIVALENCE (GARBAG(IGARB7),DUM2(1)) CCCCC END CHANGE 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='DPPR' ISUBN2='EF ' C IERROR='NO' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C IPAROC(1)='NONE' C MAXV2=5 MINN2=2 C MAXITS=IFITIT CPUEPS=R1MACH(3) C MAXN2=MAXCHF MAXN3=MAXCHF MAXN4=MAXCHF C NUMPV=(-999) IP=(-999) IV=(-999) C IWIDMO=(-999) C CUTOFF=2**(NUMBPW-3) C C ****************************** C ** TREAT THE PRE-FIT CASE ** C ****************************** C IF(IBUGA2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPREF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGA2,IBUGA3 53 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGCO,IBUGEV,IBUGQ 54 FORMAT('IBUGCO,IBUGEV,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)NUMNAM 56 FORMAT('NUMNAM = ',I8) CALL DPWRST('XXX','BUG ') DO57I=1,NUMNAM WRITE(ICOUT,58)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I), 1VALUE(I) 58 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I)', 1'VALUE(I) = ',I8,2X,A4,A4,2X,A4,I8,I8,E15.7) CALL DPWRST('XXX','BUG ') 57 CONTINUE 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL CKPREF(ICASFI,ILOCFI,IBUGA3,IFOUND,IERROR) IF(ICASFI.EQ.' '.OR.IFOUND.EQ.'NO')GOTO9000 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=0 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C **************************************************************** C ** STEP 3-- C ** FOR THE CASES WHEN HAVE PRE-FIT Y = SOME EXPRESSION C ** ROBUST PRE-FIT Y = SOME EXPRESSION , C ** DETERMINE IF WE HAVE A VALID FUNCTIONAL EXPRESSION-- C ** IN PARTICULAR, CHECK THAT THE NUMBER OF ARGUMENTS C ** IS AT LEAST 1, C ** AND ALSO CHECK THAT THERE IS EXACTLY 1 EQUAL SIGN C ** AND THAT THIS EQUAL SIGN OCCURS AS THE SECOND ARGUMENT. C **************************************************************** C ISTEPN='3' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.GE.1)GOTO2090 WRITE(ICOUT,2001) 2001 FORMAT('***** ERROR IN DPPREF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2002) 2002 FORMAT(' NUMBER OF ARGUMENTS DETECTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2003)NUMARG 2003 FORMAT(' IN PRE-FIT COMMAND = 0. NUMARG = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2007)IWIDTH 2007 FORMAT(' NUMBER OF CHARACTERS IN COMMAND LINE = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2008)(IANS(J),J=1,IWIDTH) 2008 FORMAT(' COMMAND LINE--',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2090 CONTINUE C DO2100J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO2110 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO2110 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO2110 2100 CONTINUE ILOCQ=NUMARG+1 GOTO2120 2110 CONTINUE ILOCQ=J1 GOTO2120 2120 CONTINUE C IF(ICASFI.EQ.'FIT')GOTO2125 IF(ICASFI.EQ.'RFIT')GOTO2125 GOTO2190 2125 CONTINUE NUMEQ=0 IMAX=ILOCQ-1 DO2130I=1,IMAX IF(IHARG(I).EQ.'= '.AND.IHARG2(I).EQ.' ')NUMEQ=NUMEQ+1 2130 CONTINUE IF(NUMEQ.EQ.1)GOTO2190 WRITE(ICOUT,2131) 2131 FORMAT('***** ERROR IN DPPREF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2132) 2132 FORMAT(' NUMBER OF EQUAL SIGNS DETECTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2133)NUMEQ 2133 FORMAT(' IN MODEL NOT EQUAL 1. NUMEQ = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2134)NUMARG,IMAX 2134 FORMAT(' NUMARG, IMAX = ',2I10) CALL DPWRST('XXX','BUG ') DO2135I=1,NUMARG WRITE(ICOUT,2136)I,IHARG(I),IHARG2(I) 2136 FORMAT('I,IHARG(I),IHARG2(I) = ',I8,A4,A4) CALL DPWRST('XXX','BUG ') 2135 CONTINUE WRITE(ICOUT,2137)IWIDTH 2137 FORMAT(' NUMBER OF CHARACTERS IN COMMAND LINE = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2138)(IANS(J),J=1,IWIDTH) 2138 FORMAT(' COMMAND LINE--',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2190 CONTINUE C IF(ICASFI.EQ.'FIT'.AND.IHARG(2).NE.'=')GOTO2200 IF(ICASFI.EQ.'RFIT'.AND.IHARG(3).NE.'=')GOTO2200 GOTO2290 C 2200 CONTINUE WRITE(ICOUT,2201) 2201 FORMAT('***** ERROR IN DPPREF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2202) 2202 FORMAT(' WHEN PRE-FITTING GENERAL EXPRESSIONS,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2203) 2203 FORMAT(' THE SECOND ARGUMENT AFTER THE WORD PRE-FIT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2204) 2204 FORMAT(' SHOULD BE (BUT WAS NOT) AN EQUAL SIGN.') CALL DPWRST('XXX','BUG ') IF(ICASFI.EQ.'FIT')WRITE(ICOUT,2205)IHARG(2),IHARG2(2) 2205 FORMAT(' THE ARGUMENT WAS ',A4,A4) IF(ICASFI.EQ.'FIT')CALL DPWRST('XXX','BUG ') IF(ICASFI.EQ.'RFIT')WRITE(ICOUT,2205)IHARG(3),IHARG2(3) IF(ICASFI.EQ.'RFIT')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2207)IWIDTH 2207 FORMAT(' NUMBER OF CHARACTERS IN COMMAND LINE = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2208)(IANS(J),J=1,IWIDTH) 2208 FORMAT(' COMMAND LINE--',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2290 CONTINUE C C ********************************************************** C ** STEP 4-- ** C ** FOR ALL VARIATIONS OF THE PRE-FIT COMMAND, ** C ** THE WORD AFTER PRE-FIT SHOULD BE THE RESPONSE ** C ** VARIABLE (= THE DEPENDENT VARIABLE). ** C ** EXTRACT THE RESPONSE VARIABLE AND DETERMINE ** C ** IF IT IS ALREADY IN THE NAME LIST AND IS, IN FACT, ** C ** A VARIABLE (AS OPPOSED TO A PARAMETER). ** C ********************************************************** C ISTEPN='4' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C I=0 I2=I IP1=I+1 C CCCCC IF(ICASFI.EQ.'FIT')GOTO2319 IF(ICASFI.EQ.'RFIT')GOTO2319 GOTO2349 2319 CONTINUE C IMAX=ILOCQ-1 DO2330I=1,IMAX I2=I IF(IHARG(I).EQ.'PREF')GOTO2349 IF(IHARG(I).EQ.'PRE ')GOTO2349 2330 CONTINUE WRITE(ICOUT,2331) 2331 FORMAT('***** INTERNAL ERROR IN DPPREF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2332) 2332 FORMAT(' THE WORD PRE NOT FOUND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2333) 2333 FORMAT(' IN THE ARGUMENT LIST, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3334) 3334 FORMAT(' EVEN THOUGH IT HAD BEEN PREVIOSULY FOUND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2335)NUMARG,IMAX 2335 FORMAT(' NUMARG, IMAX = ',2I10) CALL DPWRST('XXX','BUG ') DO2336I=1,NUMARG WRITE(ICOUT,2337)I,IHARG(I),IHARG2(I) 2337 FORMAT('I,IHARG(I),IHARG2(I) = ',I8,A4,A4) CALL DPWRST('XXX','BUG ') 2336 CONTINUE WRITE(ICOUT,2338)IWIDTH 2338 FORMAT(' NUMBER OF CHARACTERS IN COMMAND LINE = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2339)(IANS(J),J=1,IWIDTH) 2339 FORMAT(' COMMAND LINE--',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2349 CONTINUE ILOCFI=I2 C ILOCF1=ILOCFI+1 IHLEFT=IHARG(ILOCF1) IHLEF2=IHARG2(ILOCF1) DO2350I=1,NUMNAM I2=I IF(IHLEFT.EQ.IHNAME(I2).AND.IHLEF2.EQ.IHNAM2(I2).AND. 1IUSE(I2).EQ.'V')GOTO2379 2350 CONTINUE WRITE(ICOUT,2361) 2361 FORMAT('***** ERROR IN DPPREF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2362) 2362 FORMAT(' THE NAME FOLLOWING THE WORD PRE-FIT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2363) 2363 FORMAT(' (WHICH SHOULD BE THE RESPONSE VARIABLE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2364) 2364 FORMAT(' EITHER DOES NOT EXIST,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2365) 2365 FORMAT(' OR IS A PARAMETER (AS OPPOSED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2366) 2366 FORMAT(' TO A VARIABLE) IN THE CURRENT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2367) 2367 FORMAT(' LIST OF AVAILABLE VARIABLE AND PARAMETER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2368) 2368 FORMAT(' NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2369)IHLEFT,IHLEF2 2369 FORMAT(' NAME AFTER THE WORD PRE-FIT = ',A4,A4) CALL DPWRST('XXX','BUG ') C IF(IBUGA2.EQ.'OFF')GOTO2377 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2372) 2372 FORMAT(' CURRENT LIST OF DEFINED VARIABLES AND ', 1'PARAMETERS--') CALL DPWRST('XXX','BUG ') DO2373K2=1,NUMNAM WRITE(ICOUT,2374)IHNAME(K2),IHNAM2(K2),IUSE(K2),IVALUE(K2), 1VALUE(K2) 2374 FORMAT(6X,A4,A4,6X,A4,6X,I6,6X,E15.7) CALL DPWRST('XXX','BUG ') 2373 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2375)IWIDTH 2375 FORMAT(' NUMBER OF CHARACTERS IN COMMAND LINE = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2376)IHLEFT,IHLEF2,ILOCFI,ILOCF1,I2 2376 FORMAT(' IHLEFT,IHLEF2,ILOCFI,ILOCF1,I2 = ',A4,2X,A4,3I8) CALL DPWRST('XXX','BUG ') 2377 CONTINUE C IF(IWIDTH.GE.1)WRITE(ICOUT,2378)(IANS(J),J=1,IWIDTH) 2378 FORMAT(' COMMAND LINE--',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2379 CONTINUE ILOCV=I2 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) 2390 CONTINUE C C *********************************************************** C ** STEP 5-- ** C ** FOR ALL VARIATIONS OF THE PRE-FIT COMMAND, ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS 2 OR LARGER. ** C *********************************************************** C ISTEPN='5' 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 DPPREF--') 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 LEAST-SQUARES PRE-FIT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' WAS TO HAVE BEEN PERFORMED)') 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)NLEFT 317 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS NLEFT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,318) 318 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,319)(IANS(I),I=1,IWIDTH) 319 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 390 CONTINUE C C **************************************************************** C ** STEP 6.1-- C ** FOR THE CASES WHEN HAVE PRE-FIT Y = SOME EXPRESSION C ** ROBUST PRE-FIT Y = SOME EXPRESSION , C ** EXTRACT THE ENTIRE (LEFT AND RIGHT SIDE) FUNCTIONAL C ** EXPRESSION FROM THE INPUT COMMAND LINE. C ** COPY OUT TO IWIDTH, OR OUT TO 'SUBS' (EXCLUSIVE), C ** OR OUT THE 'EXCE' (EXCLUSIVE) C ** OR OUT THE 'FOR' (EXCLUSIVE). C **************************************************************** C ISTEPN='6.1' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASFI.EQ.'FIT')GOTO4100 IF(ICASFI.EQ.'RFIT')GOTO4100 GOTO4190 4100 CONTINUE IF(NUMARG.EQ.0)GOTO4160 IF(IHARG(1).EQ.'SUBS'.AND.IHARG2(1).EQ.'ET ')GOTO4160 IF(IHARG(1).EQ.'EXCE'.AND.IHARG2(1).EQ.'PT ')GOTO4160 IF(IHARG(1).EQ.'FOR '.AND.IHARG2(1).EQ.' ')GOTO4160 ISTART=-99 ISTOP=-99 DO4110I=1,IWIDTH IP1=I+1 IP2=I+2 IP3=I+3 IP4=I+4 IP5=I+5 IP6=I+6 IP7=I+7 C IF(IP2.GT.IWIDTH)GOTO4120 IF(IANS(I).EQ.'F'.AND.IANS(IP1).EQ.'I'. 1AND.IANS(IP2).EQ.'T') 1ISTART=IP3 C IF(IP4.GT.IWIDTH)GOTO4120 IF(IANS(I).EQ.' '.AND.IANS(IP1).EQ.'F'. 1AND.IANS(IP2).EQ.'O'.AND.IANS(IP3).EQ.'R'. 1AND.IANS(IP4).EQ.' ')ISTOP=I C IF(IP7.GT.IWIDTH)GOTO4120 IF(IANS(I).EQ.' '.AND.IANS(IP1).EQ.'S'. 1AND.IANS(IP2).EQ.'U'.AND.IANS(IP3).EQ.'B'. 1AND.IANS(IP4).EQ.'S'.AND.IANS(IP5).EQ.'E'. 1AND.IANS(IP6).EQ.'T'.AND.IANS(IP7).EQ.' ')ISTOP=I C 4110 CONTINUE 4120 CONTINUE IF(ISTART.GE.1)GOTO4129 IBRAN=4120 WRITE(ICOUT,4121)IBRAN 4121 FORMAT('*****INTERNAL ERROR IN DPPREF--', 1'IMPOSSIBLE CONDITION AT BRANCH POINT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4122) 4122 FORMAT('THE STRING PRE-FIT NOT FOUND FOR MODEL EXTRACTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4123) 4123 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,4124)(IANS(I),I=1,IWIDTH) 4124 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 4129 CONTINUE C 4130 CONTINUE IF(ISTOP.EQ.-99)ISTOP=IWIDTH IF(ISTART.LE.ISTOP)GOTO4139 IBRAN=4130 WRITE(ICOUT,4131) 4131 FORMAT('INTERNAL ERROR IN DPPREF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4132)IBRAN 4132 FORMAT('AT BRANCH POINT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4133) 4133 FORMAT('ISTART GREATER THAN ISTOP FOR MODEL EXTRACTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4134)ISTART,ISTOP 4134 FORMAT('ISTART, ISTOP = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4135) 4135 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,4136)(IANS(I),I=1,IWIDTH) 4136 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 4139 CONTINUE C J=0 DO4150I=ISTART,ISTOP J=J+1 MODEL(J)=IANS(I) 4150 CONTINUE NUMCHA=ISTOP-ISTART+1 4160 CONTINUE 4190 CONTINUE C C *************************************************** C ** STEP 6.2-- ** C ** FOR THE CASES WHEN HAVE ... PRE-FIT Y X , ** C ** EXTRACT THE INDEPENDENT VARIABLE, ** C ** AND FORM THE 1 CHARACTER PER WORD ** C ** REPRESENTATION OF THE MODEL. ** C *************************************************** C ISTEPN='6.2' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASFI.EQ.'FIT')GOTO4290 IF(ICASFI.EQ.'RFIT')GOTO4290 C ILOCRV=ILOCFI+1 ILOCIV=ILOCFI+2 C IDEGRE=0 IF(ICASFI.EQ.'0FIT')IDEGRE=0 IF(ICASFI.EQ.'1FIT')IDEGRE=1 IF(ICASFI.EQ.'2FIT')IDEGRE=2 IF(ICASFI.EQ.'3FIT')IDEGRE=3 IF(ICASFI.EQ.'4FIT')IDEGRE=4 IF(ICASFI.EQ.'5FIT')IDEGRE=5 IF(ICASFI.EQ.'6FIT')IDEGRE=6 IF(ICASFI.EQ.'7FIT')IDEGRE=7 IF(ICASFI.EQ.'8FIT')IDEGRE=8 IF(ICASFI.EQ.'9FIT')IDEGRE=9 IF(ICASFI.EQ.'10FI')IDEGRE=10 K1=IDEGRE+1 C I=0 C IWD=IHARG(ILOCRV) CALL DPXH1H(IWD,ICH,IEND,IBUGA3) IF(IEND.LE.0)GOTO4219 DO4210J=1,IEND I=I+1 MODEL(I)=ICH(J) 4210 CONTINUE 4219 CONTINUE C IWD=IHARG2(ILOCRV) CALL DPXH1H(IWD,ICH,IEND,IBUGA3) IF(IEND.LE.0)GOTO4229 DO4220J=1,IEND I=I+1 MODEL(I)=ICH(J) 4220 CONTINUE 4229 CONTINUE C KMAX=IDEGRE+1 I=I+1 MODEL(I)='=' C KMAX=IDEGRE+1 DO4250K=1,KMAX KM1=K-1 C IF(KM1.LE.0)GOTO4251 I=I+1 MODEL(I)='+' 4251 CONTINUE C I=I+1 MODEL(I)='A' C IF(0.LE.KM1.AND.KM1.LE.10)I=I+1 IF(KM1.EQ.0)MODEL(I)='0' IF(KM1.EQ.1)MODEL(I)='1' IF(KM1.EQ.2)MODEL(I)='2' IF(KM1.EQ.3)MODEL(I)='3' IF(KM1.EQ.4)MODEL(I)='4' IF(KM1.EQ.5)MODEL(I)='5' IF(KM1.EQ.6)MODEL(I)='6' IF(KM1.EQ.7)MODEL(I)='7' IF(KM1.EQ.8)MODEL(I)='8' IF(KM1.EQ.9)MODEL(I)='9' IF(KM1.EQ.10)MODEL(I)='1' IF(KM1.EQ.10)I=I+1 IF(J.EQ.10)MODEL(I)='0' C IF(KM1.LE.0)GOTO4250 C I=I+1 MODEL(I)='*' C IWD=IHARG(ILOCIV) CALL DPXH1H(IWD,ICH,IEND,IBUGA3) IF(IEND.LE.0)GOTO4269 DO4260J=1,IEND I=I+1 MODEL(I)=ICH(J) 4260 CONTINUE 4269 CONTINUE C IWD=IHARG2(ILOCIV) CALL DPXH1H(IWD,ICH,IEND,IBUGA3) IF(IEND.LE.0)GOTO4279 DO4270J=1,IEND I=I+1 MODEL(I)=ICH(J) 4270 CONTINUE 4279 CONTINUE C IF(KM1.LE.1)GOTO4250 C I=I+1 MODEL(I)='*' I=I+1 MODEL(I)='*' C IF(0.LE.KM1.AND.KM1.LE.10)I=I+1 IF(KM1.EQ.0)MODEL(I)='0' IF(KM1.EQ.1)MODEL(I)='1' IF(KM1.EQ.2)MODEL(I)='2' IF(KM1.EQ.3)MODEL(I)='3' IF(KM1.EQ.4)MODEL(I)='4' IF(KM1.EQ.5)MODEL(I)='5' IF(KM1.EQ.6)MODEL(I)='6' IF(KM1.EQ.7)MODEL(I)='7' IF(KM1.EQ.8)MODEL(I)='8' IF(KM1.EQ.9)MODEL(I)='9' IF(KM1.EQ.10)MODEL(I)='1' IF(KM1.EQ.10)I=I+1 IF(J.EQ.10)MODEL(I)='0' C 4250 CONTINUE 4290 CONTINUE IWIDMO=I NUMCHA=IWIDMO C C ************************************************** C ** STEP 6.3-- ** C ** FOR ALL VARIATIONS OF THE PRE-FIT COMMAND, ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ************************************************** C ISTEPN='6.3' 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' IKEY='SUBS' IF(IHARG(J1).EQ.'EXCE')IKEY='EXCE' 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 6.4-- ** C ** FOR ALL VARIATIONS OF THE PRE-FIT COMMAND, ** C ** EXTRACT THE UNDERLYING FUNCTION ** C ** FROM FUNCTION DEFINITIONS. ** C ************************************************** C C ISTEPN='6.4' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO5170I=1,NUMCHA I2=I IF(MODEL(I).EQ.'=')GOTO5175 5170 CONTINUE IBRAN=5170 WRITE(ICOUT,5171)IBRAN 5171 FORMAT('*****INTERNAL ERROR IN DPPREF--', 1'IMPOSSIBLE CONDITION AT BRANCH POINT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5172) 5172 FORMAT('NO EQUAL SIGN FOUND FOR MODEL EXTRACTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5173) 5173 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,5174)(IANS(I),I=1,IWIDTH) 5174 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 5175 CONTINUE ILOCEQ=I2 C IWD1='= ' IWD12=' ' IF(ICASEQ.EQ.'FULL')IWD2=' ' IF(ICASEQ.EQ.'FULL')IWD22=' ' IF(ICASEQ.EQ.'SUBS'.AND.IKEY.EQ.'SUBS')IWD2='SUBS' IF(ICASEQ.EQ.'SUBS'.AND.IKEY.EQ.'SUBS')IWD22='ET ' IF(ICASEQ.EQ.'SUBS'.AND.IKEY.EQ.'EXCE')IWD2='EXCE' IF(ICASEQ.EQ.'SUBS'.AND.IKEY.EQ.'EXCE')IWD22='PT ' IF(ICASEQ.EQ.'FOR')IWD2='FOR ' IF(ICASEQ.EQ.'FOR')IWD22=' ' C IF(ICASFI.EQ.'FIT'.OR.ICASFI.EQ.'RFIT') 1CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2, 1IFUNC2,N2,IBUGA3,IFOUND,IERROR) IF(ICASFI.NE.'FIT'.AND.ICASFI.NE.'RFIT') 1CALL DPEXST(MODEL,IWIDMO,IWD1,IWD12,IWD2,IWD22,MAXN2, 1IFUNC2,N2,IBUGA3,IFOUND,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(IFOUND.EQ.'YES')GOTO3379 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3371) 3371 FORMAT('***** ERROR IN DPPREF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3372) 3372 FORMAT(' INVALID COMMAND FORM FOR PRE-FITTING.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3373) 3373 FORMAT(' GENERAL FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3374) 3374 FORMAT(' PRE-FIT ... = ... ', 1'SUBSET ... ... ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3375) 3375 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3376)(IANS(I),I=1,IWIDTH) 3376 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 3379 CONTINUE C CALL DPEXFU(IFUNC2,N2,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP, 1NUMNAM,IANS,IWIDTH,IFUNC,NUMCHF,MAXCHF,IFUNC3,N3,MAXN3, 1IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C J=ILOCEQ DO5180I=1,N3 J=J+1 MODEL(J)=IFUNC3(I) 5180 CONTINUE NUMCHA=J C C ********************************************************** C ** STEP 7-- ** C ** MAKE A NON-CALCULATING PASS AT THE MODEL ** C ** SO AS TO EXTRACT ALL PARAMETER AND VARIABLE NAMES. ** C ********************************************************** C ISTEPN='7' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IPASS=1 CCCCC CALL COMPI2(MODEL,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPV, CCCCC1IANGLU,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,PRED, CCCCC1IBUGCO,IBUGEV,IERROR) CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPV, 1IANGLU,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,AJUNK, 1IBUGCO,IBUGEV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ******************************************** C ** STEP 8-- ** C ** CHECK TO MAKE SURE THAT THE COMBINED ** C ** NUMBER OF PARAMETERS AND VARIABLES ** C ** IN THE MODEL IS AT LEAST 1. ** C ******************************************** C ISTEPN='8' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMPV.GE.1)GOTO4400 WRITE(ICOUT,4401) 4401 FORMAT('***** ERROR IN DPPREF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4402) 4402 FORMAT(' COMBINED NUMBER OF PARAMETERS AND VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4403)NUMVAR 4403 FORMAT(' DETECTED IN THE MODEL IS 0. NUMVP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4407)NUMCHA 4407 FORMAT(' NUMBER OF CHARACTERS IN MODEL = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMCHA.GE.1)WRITE(ICOUT,4408)(MODEL(J),J=1,NUMCHA) 4408 FORMAT(' MODEL--',100A1) IF(NUMCHA.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 4400 CONTINUE C C ************************************************************** C ** STEP 9-- ** C ** CHECK THAT ALL VARIABLES ** C ** IN THE MODEL ARE ALREADY PRESENT ** C ** IN THE AVAILABLE NAME LIST IHNAME(.) AND IHNAM2(.). ** C ** CHECK THAT ALL PARAMETERS ** C ** IN THE MODEL ARE ALREADY PRESENT ** C ** IN THE AVAILABLE NAME LIST IHNAME(.) AND IHNAM2(.). ** C ** ALL NAMES IN THE MODEL THAT ARE NOT ** C ** IN THE NAME LIST AT ALL WILL BE ADDED ** C ** TO THE LIST, DEFINED AS PARAMETERS, ** C ** AND GIVEN A VALUE OF 1.0. ** C ** THIS ALLOWS US TO MAKE AN INITIAL PRE-FIT C ** WITHOUT HAVING TO DEFINE STARTING VALUES AT ALL ** C ** (THEY WILL BE AUTOMATICALLY SET TO 1.0). ** C ** ALSO, FORM A NEW VECTOR WHICH HAS ONLY PARAMETER NAMES ** C ** AND ANOTHER VECTOR WHICH HAS ONLY VARIABLE NAMES. ** C ************************************************************** C ISTEPN='9' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IP=0 IV=0 DO4165J=1,NUMPV IHPARN=IPARN(J) IHPAR2=IPARN2(J) DO4166I=1,NUMNAM I2=I IF(IHPARN.EQ.IHNAME(I).AND.IHPAR2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO4180 IF(IHPARN.EQ.IHNAME(I).AND.IHPAR2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO4170 4166 CONTINUE IP=IP+1 IPARN3(IP)=IPARN(J) IPARN4(IP)=IPARN2(J) PARAM3(IP)=1.0 C IF(NUMNAM.LT.MAXNAM)GOTO7769 WRITE(ICOUT,7751) 7751 FORMAT('***** ERROR IN DPEXAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7752) 7752 FORMAT(' THE TOTAL NUMBER OF (VARIABLE + PARAMETER)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7753)MAXNAM 7753 FORMAT(' NAMES MUST BE AT MOST ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7754) 7754 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7755) 7755 FORMAT(' THE MAXIMUM ALLOWABLE NUMBER OF NAMES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7756) 7756 FORMAT(' WAS JUST EXCEEDED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7757) 7757 FORMAT(' SUGGESTED ACTION--ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7758) 7758 FORMAT(' TO DETERMINE THE IMPORTANT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7759) 7759 FORMAT(' (VERSUS UNIMPORTANT) VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7760) 7760 FORMAT(' AND PARAMETERS, AND THEN REUSE SOME') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7761) 7761 FORMAT(' OF THE NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7762) 7762 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,7763)(IANS(I),I=1,IWIDTH) 7763 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 7769 CONTINUE C I2=NUMNAM+1 IHNAME(I2)=IPARN(J) IHNAM2(I2)=IPARN2(J) IUSE(I2)='P' IVALUE(I2)=1 VALUE(I2)=1.0 IN(I2)=1 NUMNAM=I2 CCCCC IF(IFEEDB.EQ.'OFF')GOTO4259 CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,4252) C4252 FORMAT(' NOTE--A NAME USED IN AN EXPRESSION') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,4253)IPARN(J),IPARN2(J) C4253 FORMAT(' HAS NOT YET BEEN DEFINED. NAME = ',A4,A4) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,4255) C4255 FORMAT(' THIS NAME HAS BEEN ADDED TO THE LIST,') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,4256) C4256 FORMAT(' SPECIFIED AS A PARAMETER,') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,4257) C4257 FORMAT(' AND GIVEN THE VALUE 1.0 .') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,4258)(MODEL(I),I=1,NUMCHA) C4258 FORMAT(' FUNCTION EXPRESSION--'100A1) CCCCC CALL DPWRST('XXX','BUG ') C4259 CONTINUE GOTO4165 4170 CONTINUE IP=IP+1 IPARN3(IP)=IPARN(J) IPARN4(IP)=IPARN2(J) PARAM3(IP)=VALUE(I2) GOTO4165 4180 CONTINUE IV=IV+1 CCCCC LOCX(IV)=J IVARN3(IV)=IPARN(J) IVARN4(IV)=IPARN2(J) ICOLV3(IV)=IVALUE(I2) NIV(IV)=IN(I2) GOTO4165 4165 CONTINUE NUMPAR=IP NUMVAR=IV C C ******************************************* C ** STEP 10-- ** C ** CHECK FOR A VALID NUMBER ** C ** OF INDEPENDENT VARIABLES (1 TO 5). ** C ** CHECK THE VALIDITY OF EACH ** C ** OF THE INDEPENDENT VARIABLES. ** C ** DOES THE NAME EXIST IN THE TABLE? ** C ** DOES THE NUMBER OF ELEMENTS ** C ** AGREE WITH THE NUMBER OF ELEMENTS ** C ** IN THE RESPONSE VARIABLE? ** C ******************************************* C ISTEPN='10' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMVAR.GE.1.AND.NUMVAR.LE.MAXV2)GOTO520 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,551) 551 FORMAT('***** ERROR IN DPPREF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,552) 552 FORMAT(' FOR A LEAST SQUARES PRE-FIT,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,553) 553 FORMAT(' THE NUMBER OF INDEPENDENT VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,554)MAXV2 554 FORMAT(' MUST BE AT LEAST 1 AND AT MOST ',I8,' ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,555) 555 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,556) 556 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,557)NUMVAR 557 FORMAT(' OF INDEPENDENT VARIABLES WAS ',I8) 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 ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4507)NUMCHA 4507 FORMAT(' NUMBER OF CHARACTERS IN MODEL = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4508)(MODEL(J),J=1,NUMCHA) 4508 FORMAT(' MODEL--',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4504) 4504 FORMAT(' VARIABLES EXTRACTED FROM MODEL--') CALL DPWRST('XXX','BUG ') DO4505J=1,NUMVAR WRITE(ICOUT,4506)J,IVARN3(J),IVARN4(J),ICOLV3(J) 4506 FORMAT('I,IVARN3(I),IVARN4(I),ICOLV3(I) = ',I8,2X,A4,A4,2X,I8) CALL DPWRST('XXX','BUG ') 4505 CONTINUE IERROR='YES' GOTO9000 C 520 CONTINUE DO540J=1,NUMVAR IF(NIV(J).NE.NLEFT)GOTO560 540 CONTINUE GOTO590 C 560 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,561) 561 FORMAT('***** ERROR IN DPPREF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,562) 562 FORMAT(' FOR A LEAST SQUARES PRE-FIT,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,563) 563 FORMAT(' THE NUMBER OF ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,564) 564 FORMAT(' IN EACH INDEPENDENT VARIABLE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,565) 565 FORMAT(' SHOULD BE THE SAME AS THE NUMBER OF ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,566) 566 FORMAT(' IN THE DEPENDENT VARIABLE (RESPONSE);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,567) 567 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,571) 571 FORMAT(' DEPENDENT VARIABLE (RESPONSE)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,572)IHLEFT,IHLEF2,NLEFT 572 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,576) 576 FORMAT(' INDEPENDENT VARIABLES --') CALL DPWRST('XXX','BUG ') DO580J=1,NUMVAR WRITE(ICOUT,578)IVARN3(J),IVARN4(J),NIV(J) 578 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') 580 CONTINUE 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 11-- C ** DUMP THE COMMON VECTOR V(.) OUT ONTO MASS STORAGE C ** SO AS TO PRESERVE THEIR CONTENTS FOR LATER USE C ** (AFTER DPPRE2). C ** THE ABOVE DUMP TO MASS STORAGE IS UNNECESSARY AND IS NOT DON C ** FOR THE SPECIAL CASE WHEN THE NUMBER OF PARAMETERS C ** IS 0 (A NO-PRE-FIT CASE WHEREBY WE ARE REALLY INTERESTED C ** IN GENERATING PREDICTED VALUES AND RESIDUALS C ** FOR A GIVEN FULLY-SPECIFIED MODEL). C **************************************************************** C ISTEPN='11' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOP='WRIT' CALL DPSWAP(IOP,V,NUMNAM,IHNAME,IHNAM2,IUSE,IN, 1IVALUE,MAXN,MAXCOL,MAXN2,MAXCO2,MAXIJ2,IBUGA3,ISUBRO,IERROR) C C ************************************************************* C ** STEP 12-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; THEN ** C ** COPY OVER THE RESPONSE VECTOR TO BE USED IN THE MODEL ** C ** INTO THE VECTOR Y; AND ** C ** COPY OVER THE VECTORS THAT WERE USED IN THE MODEL ** C ** INTO THE VECTORS X1, X2, X3,X4, AND X5. ** C ** (MAX NUMBER OF ALLOWABLE VECTORS = 5.) ** C ************************************************************* C ISTEPN='12' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'ON')WRITE(ICOUT,601)N,NUMVAR 601 FORMAT('N,NUMVAR = ',2I8) IF(IBUGA2.EQ.'ON')CALL DPWRST('XXX','BUG ') 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 DPSUB3(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 K=ICOLL J=0 DO4500I=1,NLEFT IF(ISUB(I).EQ.0)GOTO4500 J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)Y(J)=V(IJ) IF(K.EQ.MAXCP1)Y(J)=PRED(I) IF(K.EQ.MAXCP2)Y(J)=RES(I) IF(K.EQ.MAXCP3)Y(J)=YPLOT(I) IF(K.EQ.MAXCP4)Y(J)=XPLOT(I) IF(K.EQ.MAXCP5)Y(J)=X2PLOT(I) IF(K.EQ.MAXCP6)Y(J)=TAGPLO(I) 4500 CONTINUE C K=ICOLV3(1) J=0 DO4510I=1,NLEFT IF(ISUB(I).EQ.0)GOTO4510 J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)X1(J)=V(IJ) IF(K.EQ.MAXCP1)X1(J)=PRED(I) IF(K.EQ.MAXCP2)X1(J)=RES(I) IF(K.EQ.MAXCP3)X1(J)=YPLOT(I) IF(K.EQ.MAXCP4)X1(J)=XPLOT(I) IF(K.EQ.MAXCP5)X1(J)=X2PLOT(I) IF(K.EQ.MAXCP6)X1(J)=TAGPLO(I) 4510 CONTINUE IF(NUMVAR.LE.1)GOTO4590 C K=ICOLV3(2) J=0 DO4520I=1,NLEFT IF(ISUB(I).EQ.0)GOTO4520 J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)X2(J)=V(IJ) IF(K.EQ.MAXCP1)X2(J)=PRED(I) IF(K.EQ.MAXCP2)X2(J)=RES(I) IF(K.EQ.MAXCP3)X2(J)=YPLOT(I) IF(K.EQ.MAXCP4)X2(J)=XPLOT(I) IF(K.EQ.MAXCP5)X2(J)=X2PLOT(I) IF(K.EQ.MAXCP6)X2(J)=TAGPLO(I) 4520 CONTINUE IF(NUMVAR.LE.2)GOTO4590 C K=ICOLV3(3) J=0 DO4530I=1,NLEFT IF(ISUB(I).EQ.0)GOTO4530 J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)X3(J)=V(IJ) IF(K.EQ.MAXCP1)X3(J)=PRED(I) IF(K.EQ.MAXCP2)X3(J)=RES(I) IF(K.EQ.MAXCP3)X3(J)=YPLOT(I) IF(K.EQ.MAXCP4)X3(J)=XPLOT(I) IF(K.EQ.MAXCP5)X3(J)=X2PLOT(I) IF(K.EQ.MAXCP6)X3(J)=TAGPLO(I) 4530 CONTINUE IF(NUMVAR.LE.3)GOTO4590 C K=ICOLV3(4) J=0 DO4540I=1,NLEFT IF(ISUB(I).EQ.0)GOTO4540 J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)X4(J)=V(IJ) IF(K.EQ.MAXCP1)X4(J)=PRED(I) IF(K.EQ.MAXCP2)X4(J)=RES(I) IF(K.EQ.MAXCP3)X4(J)=YPLOT(I) IF(K.EQ.MAXCP4)X4(J)=XPLOT(I) IF(K.EQ.MAXCP5)X4(J)=X2PLOT(I) IF(K.EQ.MAXCP6)X4(J)=TAGPLO(I) 4540 CONTINUE IF(NUMVAR.LE.4)GOTO4590 C K=ICOLV3(5) J=0 DO4550I=1,NLEFT IF(ISUB(I).EQ.0)GOTO4550 J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)X5(J)=V(IJ) IF(K.EQ.MAXCP1)X5(J)=PRED(I) IF(K.EQ.MAXCP2)X5(J)=RES(I) IF(K.EQ.MAXCP3)X5(J)=YPLOT(I) IF(K.EQ.MAXCP4)X5(J)=XPLOT(I) IF(K.EQ.MAXCP5)X5(J)=X2PLOT(I) IF(K.EQ.MAXCP6)X5(J)=TAGPLO(I) 4550 CONTINUE 4590 CONTINUE NS=J C C **************************************************************** C ** STEP 13-- C ** PREPARE FOR ENTRANCE INTO DPPRE2-- C ** SET THE WEIGHT VECTOR TO UNITY THROUGHOUT. C ** SET THE ICON3 VECTOR C ** (WHICH INDICATES WHICH PARAMETERS ARE TO BE HELD CONSTANT) C ** EQUAL TO 0 THROUGHOUT. C ** DEFINE CONSTRAINTS AND LIMITS. C **************************************************************** C ISTEPN='13' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO4592I=1,NS W(I)=1.0 4592 CONTINUE C DO4195I=1,NUMPAR ICON3(I)=0 4195 CONTINUE C IF(NUMCON.EQ.0)GOTO4890 DO4700I=1,NUMPAR DO4800J=1,NUMCON J2=J IF(IPARN3(I).EQ.IPARNC(J).AND.IPARN4(I).EQ.IPANC2(J))GOTO4810 4800 CONTINUE IPARO3(I)='NONE' GOTO4700 4810 CONTINUE IPARO3(I)=IPAROC(J2) PARLI3(I)=PARLIM(J2) 4700 CONTINUE 4890 CONTINUE C C ******************** C ** STEP 14-- ** C ** ENTER DPPRE2. ** C ******************** C ISTEPN='14' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'OFF')GOTO6099 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6081) 6081 FORMAT('***** FROM DPPREF, AS WE ARE ABOUT TO CALL DPPRE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6082)NUMCHA,NLEFT,MAXN,NS,NUMPV,NUMPAR,NUMVAR 6082 FORMAT('NUMCHA,NLEFT,MAXN,NS,NUMPV,NUMPAR,NUMVAR = ',7I8) CALL DPWRST('XXX','BUG ') DO6083I=1,NS WRITE(ICOUT,6084)I,Y(I),X1(I),X2(I),X3(I),X4(I),X5(I),W(I) 6084 FORMAT('I,Y(I),X1(I),X2(I),X3(I),X4(I),X5(I),W(I) = ', 1I6,2X,7F10.5) CALL DPWRST('XXX','BUG ') 6083 CONTINUE WRITE(ICOUT,6085)(MODEL(I),I=1,NUMCHA) 6085 FORMAT('MODEL(.)--',120A1) CALL DPWRST('XXX','BUG ') DO6086J=1,NUMPAR WRITE(ICOUT,6087)J,IPARN3(J),IPARN4(J),PARAM3(J),ICON3(J) 6087 FORMAT('I,IPARN3(I),IPARN4(I),PARAM3(I),ICON3(I) = ', 1I8,2X,A4,A4,E15.7,A4) CALL DPWRST('XXX','BUG ') 6086 CONTINUE DO6088J=1,NUMVAR WRITE(ICOUT,6089)J,IVARN3(J),IVARN4(J),ICOLV3(J) 6089 FORMAT('I,IVARN3(I),IVARN4(I),ICOLV3(I) = ',I8,2X,A4,A4,2X,I8) CALL DPWRST('XXX','BUG ') 6088 CONTINUE CCCCC IBUGA3='ABCD' CCCCC IBUGCO='EFGH' CCCCC IBUGEV='IJKL' WRITE(ICOUT,6091)IBUGA3,IBUGCO,IBUGEV 6091 FORMAT('IBUGA3,IBUGCO,IBUGEV = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 6099 CONTINUE C CCCCC JUNE 1990. DIMENSION DUM1, DUM2 IN DPPREF RATHER THAN DPPRE2. CALL DPPRE2(Y,X1,X2,X3,X4,X5,NUMVAR,IVARN3,IVARN4,W,NS, 1MODEL,NUMCHA,PARAM3,IPARN3,IPARN4,NUMPAR,ICON3,IANGLU,IPARO3, 1PARLI3,V,MAXITS,FITSD,FITPOW,CPUEPS, 1ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD, 1IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 1IREP,REPSD,REPDF,RESSD,RESDF,PRED2,RES2,ALFCDF, CCCCC THE FOLLOWING LINE WAS AUGMENTED NOVEMBER 1995 CCCCC1DUM1,DUM2, 1DUM1,DUM2,IANS,IWIDTH, 1IBUGA3,IBUGCO,IBUGEV,IERROR) IF(IERROR.EQ.'YES')GOTO8000 C C *************************************** C ** STEP 15-- ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C 7000 CONTINUE C ISTEPN='15' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICOLPR=MAXCP1 ICOLRE=MAXCP2 IREPU='ON' IRESU='ON' CALL UPDAPR(ICOLPR,ICOLRE,PRED2,RES2,PRED,RES,ISUB,NLEFT, 1IREPU,REPSD,REPDF,IRESU,RESSD,RESDF,ALFCDF, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,ILOCN,IBUGA3,IERROR) C IF(ICASFI.EQ.'FIT')GOTO7900 IF(ICASFI.EQ.'RFIT')GOTO7900 C L=0 DO7600J=1,K1 L=L+1 IH2=' ' IF(J.EQ.1)IH='A0 ' IF(J.EQ.2)IH='A1 ' IF(J.EQ.3)IH='A2 ' IF(J.EQ.4)IH='A3 ' IF(J.EQ.5)IH='A4 ' IF(J.LE.5)GOTO7640 IF(J.EQ.6)IH='A5 ' IF(J.EQ.7)IH='A6 ' IF(J.EQ.8)IH='A7 ' IF(J.EQ.9)IH='A8 ' IF(J.EQ.10)IH='A9 ' IF(J.LE.10)GOTO7640 IF(J.EQ.11)IH='A10 ' IF(J.LE.11)GOTO7640 C 7640 CONTINUE DO7650I=1,NUMNAM I2=I IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO7680 7650 CONTINUE IF(NUMNAM.LT.MAXNAM)GOTO7670 WRITE(ICOUT,7651) 7651 FORMAT('***** ERROR IN DPPREF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7652) 7652 FORMAT(' THE TOTAL NUMBER OF (VARIABLE + PARAMETER)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7653)MAXNAM 7653 FORMAT(' NAMES MUST BE AT MOST ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7654) 7654 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7655) 7655 FORMAT(' THE MAXIMUM ALLOWABLE NUMBER OF NAMES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7656) 7656 FORMAT(' WAS JUST EXCEEDED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7657) 7657 FORMAT(' SUGGESTED ACTION--ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7658) 7658 FORMAT(' TO DETERMINE THE IMPORTANT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7659) 7659 FORMAT(' (VERSUS UNIMPORTANT) VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7660) 7660 FORMAT(' AND PARAMETERS, AND THEN REUSE SOME') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7661) 7661 FORMAT(' OF THE NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7662) 7662 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,7663)(IANS(I),I=1,IWIDTH) 7663 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 7670 CONTINUE NUMNAM=NUMNAM+1 ILOC=NUMNAM IHNAME(ILOC)=IH IHNAM2(ILOC)=IH2 IUSE(ILOC)='P' VALUE(ILOC)=PARAM3(L) CCCCC IVALUE(ILOC)=VALUE(ILOC)+0.5 JUNE 10, 1987 VAL=VALUE(ILOC) IF((-CUTOFF).LE.VAL.AND.VAL.LE.CUTOFF)IVAL=VAL+0.5 IF(VAL.GT.CUTOFF)IVAL=CUTOFF IF(VAL.LT.(-CUTOFF))IVAL=(-CUTOFF) IVALUE(ILOC)=IVAL GOTO7600 C 7680 CONTINUE VALUE(I2)=PARAM3(L) CCCCC IVALUE(ILOC)=VALUE(ILOC)+0.5 JUNE 9, 1987 CCCCC IVALUE(I2)=VALUE(I2)+0.5 JUNE 10, 1987 VAL=VALUE(I2) IF((-CUTOFF).LE.VAL.AND.VAL.LE.CUTOFF)IVAL=VAL+0.5 IF(VAL.GT.CUTOFF)IVAL=CUTOFF IF(VAL.LT.(-CUTOFF))IVAL=(-CUTOFF) IVALUE(I2)=IVAL GOTO7600 C 7600 CONTINUE 7900 CONTINUE C C **************************************************************** C ** STEP 16-- C ** READ BACK IN FROM MASS STORAGE C ** THE CONTENTS OF THE V(.) VECTOR. C ** THE ABOVE RETRIEVAL FROM MASS STORAGE IS UNNECESSARY AND IS C ** FOR THE SPECIAL CASE WHEN THE NUMBER OF PARAMETERS C ** IS 0 (A NO-PRE-FIT CASE WHEREBY WE ARE REALLY INTERESTED C ** IN GENERATING PREDICTED VALUES AND RESIDUALS C ** FOR A GIVEN FULLY-SPECIFIED MODEL). C **************************************************************** C 8000 CONTINUE C ISTEPN='16' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'OFF')GOTO8109 WRITE(ICOUT,8101) 8101 FORMAT('WE ARE IN DPPREF AND ARE ABOUT TO READ V BACK IN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8102)MAXN2,MAXCO2,MAXIJ2,NLEFT,NS,V(1),PRED(1),RES(1) 8102 FORMAT('MAXN2,MAXCO2,MAXIJ2,NLEFT,NS,V(1),PRED(1),RES(1) = ', 15I6,3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8103) 8103 FORMAT('NOTE THAT IF NUMBER OF PARAMETERS = 0, THEN ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8104) 8104 FORMAT('NO DUMP TO/RETRIEVAL FROM MASS STORAGE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8105) 8105 FORMAT('IS DONE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8106)NUMPAR 8106 FORMAT('NUMPAR = ',I8) CALL DPWRST('XXX','BUG ') 8109 CONTINUE C IOP='READ' CALL DPSWAP(IOP,V,NUMNAM,IHNAME,IHNAM2,IUSE,IN, 1IVALUE,MAXN,MAXCOL,MAXN2,MAXCO2,MAXIJ2,IBUGA3,ISUBRO,IERROR) C IF(IBUGA2.EQ.'OFF')GOTO8129 WRITE(ICOUT,8121) 8121 FORMAT('WE ARE IN DPPREF AND HAVE JUST READ ', 1'V(.) BACK IN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8122)MAXN2,MAXCO2,MAXIJ2,NLEFT,NS,V(1),PRED(1),RES(1) 8122 FORMAT('MAXN2,MAXCO2,MAXIJ2,NLEFT,NS,V(1),PRED(1),RES(1) = ', 15I6,3E15.7) CALL DPWRST('XXX','BUG ') 8129 CONTINUE C C ************************************************* C ** STEP 17-- ** C ** COPY THE FINAL ESTIMATES FROM THE PRE-FIT ** C ** BACK INTO THE PARAMETERS. ** C ** THESE FINAL ESTIMATES WILL THUS OVERWRITE ** C ** THE STARTING VALUES THAT WERE ** C ** ORIGINALLY ASSIGNED TO THE PARAMETERS. ** C ************************************************* C 6000 CONTINUE C ISTEPN='17' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMPAR.LE.0)GOTO6190 DO6100J=1,NUMPAR IH=IPARN3(J) IH2=IPARN4(J) IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 VALUE(ILOCP)=PARAM3(J) CCCCC IVALUE(ILOCP)=VALUE(ILOCP)+0.5 JUNE 10, 1987 VAL=VALUE(ILOCP) IF((-CUTOFF).LE.VAL.AND.VAL.LE.CUTOFF)IVAL=VAL+0.5 IF(VAL.GT.CUTOFF)IVAL=CUTOFF IF(VAL.LT.(-CUTOFF))IVAL=(-CUTOFF) IVALUE(ILOCP)=IVAL 6100 CONTINUE 6190 CONTINUE 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 DPPREF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA2,IBUGA3 9012 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGCO,IBUGEV,IBUGQ 9013 FORMAT('IBUGCO,IBUGEV,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NS,ICASFI 9015 FORMAT('NS,ICASFI = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NUMNAM 9016 FORMAT('NUMNAM = ',I8) CALL DPWRST('XXX','BUG ') DO9017I=1,NUMNAM WRITE(ICOUT,9018)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I), 1VALUE(I) 9018 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I)', 1'VALUE(I) = ',I8,2X,A4,A4,2X,A4,I8,I8,E15.7) CALL DPWRST('XXX','BUG ') 9017 CONTINUE WRITE(ICOUT,9021)NUMPV 9021 FORMAT('NUMPV = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMPV.LE.0)GOTO9029 DO9022I=1,NUMPV WRITE(ICOUT,9023)I,IPARN(I),IPARN2(I) 9023 FORMAT('I,IPARN(I),IPARN2(I) = ',I8,2X,A4,A4) CALL DPWRST('XXX','BUG ') 9022 CONTINUE 9029 CONTINUE WRITE(ICOUT,9031)IP 9031 FORMAT('IP = ',I8) CALL DPWRST('XXX','BUG ') IF(IP.LE.0)GOTO9039 DO9032I=1,IP WRITE(ICOUT,9033)I,IPARN3(I),IPARN4(I) 9033 FORMAT('I,IPARN3(I),IPARN4(I) = ',I8,2X,A4,A4) CALL DPWRST('XXX','BUG ') 9032 CONTINUE 9039 CONTINUE WRITE(ICOUT,9041)IV 9041 FORMAT('IV = ',I8) CALL DPWRST('XXX','BUG ') IF(IV.LE.0)GOTO9049 DO9042I=1,IV WRITE(ICOUT,9043)I,IVARN3(I),IVARN4(I) 9043 FORMAT('I,IVARN3(I),IVARN4(I) = ',I8,2X,A4,A4) CALL DPWRST('XXX','BUG ') 9042 CONTINUE 9049 CONTINUE WRITE(ICOUT,9051)MAXN2,NLEFT,NS,V(1),PRED(1),RES(1) 9051 FORMAT('MAXN2,NLEFT,NS,V(1),PRED(1),RES(1) = ',3I8,3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9052)ICASEQ 9052 FORMAT('ICASEQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9061)IWIDTH 9061 FORMAT('IWIDTH = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,9062)(IANS(I),I=1,IWIDTH) 9062 FORMAT('(IANS(I),I=1,IWIDTH) = ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9063)IWIDMO 9063 FORMAT('IWIDMO = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDMO.GE.1)WRITE(ICOUT,9064)(MODEL(I),I=1,IWIDMO) 9064 FORMAT('(MODEL(I),I=1,IWIDMO) = ',100A1) IF(IWIDMO.GE.1)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9069)IFOUND,IERROR 9069 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPPREG(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--GENERATE ONE OF THE FOLLOWING PLOTS: C 1) A PARTIAL REGRESSION PLOT C 2) A PARTIAL RESIDUAL PLOT C 3) A PARTIAL LEVERAGE PLOT C 4) A CCPR (COMPONENT AND COMPONENT-PLUS-RESIDUAL) PLOT C DPPRPL GENERATES THE PARTIAL REGRESSION PLOTS FOR ALL C OF THE X VARIABLES WHILE THIS COMMAND GENERATES THE C COORDINATES FOR A SINGLE X VARIABLE. NOTE THAT THIS C COMMAND ASSUMES THE FIT HAS ALREADY BEEN GENERATED C (THIS IS DONE AUTOMATICALLY IN DPPRPL) AND THE SYNTAX C IS THEN: PARTIAL Y X1 TO XK INDEX C WHERE INDEX IS A PARAMETER THAT IDENTIFIES WHICH OF C THE X VARIABLES TO USE. C WRITTEN BY--ALAN HECKERT C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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--2002/6 C ORIGINAL VERSION--JUNE 2002. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IHRIGH CHARACTER*4 IHRIG2 CHARACTER*4 IVARN1 CHARACTER*4 IVARN2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C C MAXPRG IS THE MAXIMUM NUMBER OF VARIABLES TO USE IN CREATING THE C PARTIAL REGRESSION PLOT C PARAMETER(MAXPRG=30) C DIMENSION IVARN1(MAXPRG) DIMENSION IVARN2(MAXPRG) DIMENSION ILIS(MAXPRG) DIMENSION XMAT(15*MAXOBV) DIMENSION XSCRT1(15*MAXOBV) DIMENSION XSCRT2(15*MAXOBV) DIMENSION Y1(MAXOBV) DIMENSION YTEMP2(MAXOBV) DIMENSION YTEMP3(MAXOBV) DIMENSION RES2(MAXOBV) DIMENSION COEF(MAXPRG) C INCLUDE 'DPCOZ2.INC' INCLUDE 'DPCOZZ.INC' INCLUDE 'DPCOZI.INC' EQUIVALENCE (G2RBAG(1),XMAT(1)) EQUIVALENCE (G2RBAG(15*MAXOBV+1),XSCRT1(1)) EQUIVALENCE (G2RBAG(30*MAXOBV+1),XSCRT2(1)) EQUIVALENCE (GARBAG(IGARB1),Y1(1)) EQUIVALENCE (GARBAG(IGARB2),YTEMP2(1)) EQUIVALENCE (GARBAG(IGARB3),YTEMP3(1)) EQUIVALENCE (GARBAG(IGARB4),RES2(1)) 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-----START POINT----------------------------------------------------- C IERROR='NO' C ISUBN1='DPPR' ISUBN2='EG ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=2 MINN2=1 NLOCAL=0 NPLOTP=0 NZ=0 NPLOTV=0 NS=0 C ICOLH=0 C C *********************************************** C ** TREAT THE PARTIAL REGRESSSION PLOT CASE ** C *********************************************** C IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PREG')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPPREG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGG2,IBUGG3,IBUGQ,ISUBRO 52 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)NUMARG 55 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO59I=1,NUMARG WRITE(ICOUT,57)I,IHARG(I),IHARG2(I) 57 FORMAT('I,IHARG(I),IHARG2(I) = ',I8,A4,2X,A4) CALL DPWRST('XXX','BUG ') 59 CONTINUE 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='11' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PREG') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.GE.2.AND.IHARG(1).EQ.'REGR'.AND. 1 IHARG(2).EQ.'PLOT')THEN ICASPL='PREG' GOTO112 ENDIF C IF(NUMARG.GE.2.AND.IHARG(1).EQ.'VARI'.AND. 1 IHARG(2).EQ.'PLOT')THEN ICASPL='PREG' GOTO112 ENDIF C IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LEVE'.AND. 1 IHARG(2).EQ.'PLOT')THEN ICASPL='PLEV' GOTO112 ENDIF C IF(NUMARG.GE.2.AND.IHARG(1).EQ.'RESI'.AND. 1 IHARG(2).EQ.'PLOT')THEN ICASPL='PRES' GOTO112 ENDIF C IF(NUMARG.GE.3.AND.IHARG(1).EQ.'PLUS'.AND. 1 IHARG(2).EQ.'RESI'.AND.IHARG(3).EQ.'PLOT')THEN ICASPL='PRES' GOTO112 ENDIF C IF(ICASPL.EQ.'CCPR'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')THEN ICASPL='CCPR' GOTO111 ENDIF C IFOUND='NO' GOTO9000 C 111 CONTINUE ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO119 C 112 CONTINUE ILASTC=2 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO119 C 119 CONTINUE 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(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PREG') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=3 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ***************************************** C ** STEP 11-- ** 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='11' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PREG') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO1180 DO1100J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO1110 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO1110 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO1120 1100 CONTINUE GOTO1180 1110 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO1190 1120 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO1190 C 1180 CONTINUE GOTO1190 C 1190 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PREG')GOTO1195 WRITE(ICOUT,1191)NUMARG,ILOCQ,ICASEQ 1191 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 1195 CONTINUE C C ************************************************** C ** STEP 12-- ** C ** DETERMINE THE NUMBER OF VARIABLES ** C ** TO BE INCLUDED AS PLOT COMPONENTS ** C ** IF THE TO FEATURE IS USED IN THE ** C ** ARGUMENT LIST, TRANSLATE THE TO TO ** C ** EXPLICIT VARIABLE NAMES ** C ** NOTE: LAST "VARIABLE" SHOULD BE A PARAMETER ** C ** CONTAINING THE "INDEX" OF THE PRIMARY ** C ** VARIABLE OF THE PLOT. ** C ************************************************** C ISTEPN='12' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PREG') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C JMIN=1 JMAX=ILOCQ-1 CALL EXTVAR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXPRG, 1IHNAME,IHNAM2,IUSE,NUMNAM, 1IVARN1,IVARN2,NUMVAR,IBUGG2,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C 1290 CONTINUE C C *************************************** C ** STEP 13-- ** C ** CHECK THE VALIDITY OF EACH ** C ** OF THE VARIABLES. ** C ** ALSO CHECK TO ASSURE THAT EACH ** C ** OF THE VARIABLES HAS AT LEAST ** C ** 2 OBSERVATIONS AND THE SAME ** C ** NUMBER OF OBSERVATIONS ** C *************************************** C ISTEPN='13' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PREG') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IFLAG=0 NVTOT=NUMVAR NUMVAR=NUMVAR-1 DO1300I=1,NVTOT C IHRIGH=IVARN1(I) IHRIG2=IVARN2(I) 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 C NRIGHT=IN(ILOCV) IF(I.EQ.1)NTEMP=NRIGHT ILIS(I)=ILOCV IF(NRIGHT.LT.MINN2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1311) 1311 FORMAT('***** ERROR IN DPPREG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1312) 1312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1321) 1321 FORMAT(' (FOR WHICH A PARTIAL REGRESSSION PLOT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1325) 1325 FORMAT(' WAS TO HAVE BEEN FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1326)MINN2 1326 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1327) 1327 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1328) 1328 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,1329)(IANS(J),J=1,MIN(80,IWIDTH)) 1329 FORMAT(' ',80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ELSE IF(NRIGHT.NE.NTEMP)THEN WRITE(ICOUT,1411) 1411 FORMAT('***** ERROR IN DPPREG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1413) 1413 FORMAT(' THE NUMBER OF OBSERVATIONS IN ALL VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1414) 1414 FORMAT(' MUST BE THE SAME; SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') I2=ILIS(I) WRITE(ICOUT,1416)IVARN1(I2),IVARN2(I2),IN(I2) 1416 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8, 1 ' OBSERVATIONS;') CALL DPWRST('XXX','BUG ') 1417 CONTINUE WRITE(ICOUT,1420) 1420 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,1421)(IANS(L),L=1,MIN(100,IWIDTH)) 1421 FORMAT(' ',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C 1300 CONTINUE C IF(NUMVAR*NRIGHT.GT.15*MAXOBV)THEN WRITE(ICOUT,1501) 1501 FORMAT('***** ERROR IN DPPREG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1503) 1503 FORMAT(' SCRATCH SPACE EXCEEDED. USE FEWER VARIABLES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1505)15*MAXOBV 1505 FORMAT(' ROWS TIMES COLUMMS MUST BE <= ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1507)NRIGHT,NUMVAR,NUMVAR*NRIGHT 1507 FORMAT(' CURRENT: ROWS = ',I8,', COLUMNS = ',I8, 1 ', TOTAL = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C C ****************************************************** C ** STEP 1.5-- ** C ** LAST VARIABLE IDENTIFIES THE PRIMARY VARIABLE ** C ** (WHICH SHOULD ALREADY BE IN THE LIST) ** C ****************************************************** C IHRIGH=IVARN1(NVTOT) IHRIG2=IVARN2(NVTOT) C DO1521I=2,NUMVAR IF(IHRIGH.EQ.IVARN1(I).AND.IHRIG2.EQ.IVARN2(I))THEN IX=I GOTO1529 ENDIF 1521 CONTINUE WRITE(ICOUT,1523) 1523 FORMAT('***** ERROR IN DPPREG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1525)IHRIGH,IHRIG2 1525 FORMAT(' THE NAME OF THE PRIMARY VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1527) 1527 FORMAT(' DOES NOT MATCH ANY OF THE INDEPENDENT VARIABLES.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1529 CONTINUE C C ****************************************************** C ** STEP 1.6-- ** C ** EXTRACT FIT COEFFICIENTS FROM PREVIOUS FIT. ** C ** (A0, A1, ....) ** C ****************************************************** C IHP='A0 ' IHP2=' ' IHWUSE='P' MESSAG='YES' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 COEF(1)=VALUE(ILOCP) C NX=NUMVAR-1 DO1610I=1,MIN(9,NX) IHP='A ' WRITE(IHP(2:2),'(I1)')I 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 COEF(I+1)=VALUE(ILOCP) 1610 CONTINUE IF(NX.GE.10)THEN DO1620I=1,MIN(10,NX) IHP='A ' WRITE(IHP(2:3),'(I2)')I 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 COEF(I+1)=VALUE(ILOCP) 1620 CONTINUE ENDIF C NX=NUMVAR-1 C C ************************************************* C ** STEP 21-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** (BASED ON THE QUALIFIER) ** C ** THEN FOR EACH OF THE RESPONSE VARIABLES ** C ** EXTRACT THE DATA SUBSET ** C ** (USUALLY ONLY 1 OBSERVATION) ** C ** AND ALSO EXTRACT THE ** C ** MIN AND MAX FOR THE FULL VARIABLE ** C ************************************************* C ISTEPN='21' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PREG') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO2110 IF(ICASEQ.EQ.'SUBS')GOTO2120 IF(ICASEQ.EQ.'FOR')GOTO2130 C 2110 CONTINUE DO2115I=1,NRIGHT ISUB(I)=1 2115 CONTINUE NQ=NRIGHT GOTO2190 C 2120 CONTINUE NIOLD=NRIGHT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO2190 C 2130 CONTINUE NIOLD=NRIGHT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO2190 C 2190 CONTINUE C C ************************************************* C ** STEP 22-- ** C ** FOR EACH OF THE RESPONSE VARIABLES, ** C ** EXTRACT THE DATA SUBSET ** C ** (FREQUENTLY ONLY 1 OBSERVATION) ** C ** AND ALSO EXTRACT THE ** C ** MIN AND MAX FOR THE FULL VARIABLE ** C ************************************************* C ISTEPN='22' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PREG') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO2200K=1,NVTOT-1 IHRIGH=IVARN1(K) IHRIG2=IVARN2(K) C DO2210I=1,NUMNAM I2=I IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO2219 2210 CONTINUE WRITE(ICOUT,2211) 2211 FORMAT('***** INTERNAL ERROR IN DPPREG AT POINT 2210--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2212)IHRIGH,IHRIG2 2212 FORMAT(' THE VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2213) 2213 FORMAT(' NOT NOW FOUND IN INTERNAL NAME LIST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2214) 2214 FORMAT(' ALTHOUGH ALREADY FOUND EARLIER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2215) 2215 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2216)(IANS(I),I=1,IWIDTH) 2216 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2219 CONTINUE C ILISTR=I2 ICOLR=IVALUE(ILISTR) NRIGHT=IN(ILISTR) C J=0 IMAX=NRIGHT IF(NQ.LT.NRIGHT)IMAX=NQ DO2240I=1,IMAX IF(ISUB(I).EQ.0)GOTO2240 J=J+1 IJ=MAXN*(ICOLR-1)+I IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PREG') 1WRITE(ICOUT,2241)I,J,MAXN,ICOLR,IJ,NRIGHT,NQ,IMAX 2241 FORMAT('I,J,MAXN,ICOLR,IJ,NRIGHT,NQ,IMAX = ',8I8) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PREG') 1CALL DPWRST('XXX','BUG ') IF(K.EQ.1)THEN IF(ICOLR.LE.MAXCOL)Y1(J)=V(IJ) IF(ICOLR.EQ.MAXCP1)Y1(J)=PRED(I) IF(ICOLR.EQ.MAXCP2)Y1(J)=RES(I) IF(ICOLR.EQ.MAXCP3)Y1(J)=YPLOT(I) IF(ICOLR.EQ.MAXCP4)Y1(J)=XPLOT(I) IF(ICOLR.EQ.MAXCP5)Y1(J)=X2PLOT(I) IF(ICOLR.EQ.MAXCP6)Y1(J)=TAGPLO(I) RES2(J)=RES(I) XMAT(J)=1.0 ELSE IJK=(K-1)*NQ+J IF(ICOLR.LE.MAXCOL)XMAT(IJK)=V(IJ) IF(ICOLR.EQ.MAXCP1)XMAT(IJK)=PRED(I) IF(ICOLR.EQ.MAXCP2)XMAT(IJK)=RES(I) IF(ICOLR.EQ.MAXCP3)XMAT(IJK)=YPLOT(I) IF(ICOLR.EQ.MAXCP4)XMAT(IJK)=XPLOT(I) IF(ICOLR.EQ.MAXCP5)XMAT(IJK)=X2PLOT(I) IF(ICOLR.EQ.MAXCP6)XMAT(IJK)=TAGPLO(I) ENDIF 2240 CONTINUE NLOCAL=J NSUB=NLOCAL C 2200 CONTINUE NZ=NUMVAR C C ******************************************************* C ** STEP 31-- ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** C ** DEFINE THE VECTOR D(.) SO THAT EACH ANDREW'S ** C ** CURVE HAS ITS OWNS TAG NUMBER. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ******************************************************* C ISTEPN='8' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PREG') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPPRG2(Y1,YTEMP2,YTEMP3,RES2,COEF,ITEMP1, 1XMAT,XSCRT1,XSCRT2,ICASPL, 1NLOCAL,NUMVAR,IX,MAXPRG, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PREG')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPREG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGG2,IBUGG3,IBUGQ,ISUBRO 9012 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IFOUND,IERROR 9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9014 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)NLOCAL 9021 FORMAT('NLOCAL = ',I8) CALL DPWRST('XXX','BUG ') IF(NLOCAL.LE.0)GOTO9024 DO9022I=1,NLOCAL WRITE(ICOUT,9023)I,Y1(I),RES2(I),XMAT(I) 9023 FORMAT('I,YTEMP1(I),RES(I),XMAT(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 9022 CONTINUE 9024 CONTINUE WRITE(ICOUT,9041)NZ,NPLOTV,NPLOTP 9041 FORMAT('NZ,NPLOTV,NPLOTP = ',3I8) CALL DPWRST('XXX','BUG ') IF(NPLOTP.LE.0)GOTO9054 DO9052I=1,NPLOTP WRITE(ICOUT,9053)I,Y(I),X(I),D(I) 9053 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9052 CONTINUE 9054 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPRG2(Y1,Y2,Y3,RES,COEF,ITEMP1, 1XMAT,XSCRT1,XSCRT2,ICASPL, 1N,NUMVAR,IX,MAXPRG, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) C C PURPOSE--GENERATE ONE OF THE FOLLOWING PLOTS: C 1) A PARTIAL REGRESSION PLOT C 2) A PARTIAL RESIDUAL PLOT C 3) A PARTIAL LEVERAGE PLOT C 4) A CCPR (COMPONENT AND COMPONENT-PLUS-RESIDUAL) PLOT C DPPRPL GENERATES THE PARTIAL REGRESSION PLOTS FOR ALL C OF THE X VARIABLES WHILE THIS COMMAND GENERATES THE C COORDINATES FOR A SINGLE X VARIABLE. NOTE THAT THIS C COMMAND ASSUMES THE FIT HAS ALREADY BEEN GENERATED C (THIS IS DONE AUTOMATICALLY IN DPPRPL) AND THE SYNTAX C IS THEN: PARTIAL Y X1 TO XK INDEX C WHERE INDEX IS A PARAMETER THAT IDENTIFIES WHICH OF C THE X VARIABLES TO USE. C WRITTEN BY--ALAN HECKERT C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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--2002/6 C ORIGINAL VERSION--JUNE 2002. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DSUM1 C DIMENSION XMAT(N,NUMVAR) DIMENSION XSCRT1(N,NUMVAR) DIMENSION XSCRT2(N,NUMVAR) C DIMENSION Y1(*) DIMENSION Y2(*) DIMENSION Y3(*) DIMENSION RES(*) DIMENSION ITEMP1(*) DIMENSION COEF(*) C DIMENSION Y(*) DIMENSION X(*) DIMENSION D(*) 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='DPPR' ISUBN2='G2 ' C IERROR='NO' C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.LE.1)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN DPPRG2--') 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 ENDIF C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'PRG2')GOTO90 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71) 71 FORMAT('***** AT THE BEGINNING OF DPPRG2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)ICASPL,NUMVAR,N,IX 72 FORMAT('ICASPL,NUMVAR,N,IX = ',A4,2X,3I8) CALL DPWRST('XXX','BUG ') IF(N.GT.0)THEN DO81I=1,N WRITE(ICOUT,82)I,Y(I),(XMAT(I,K),K=1,MIN(5,NUMVAR)) 82 FORMAT('I,Y(I),XMAT(I,K) = ',I8,6E12.5) CALL DPWRST('XXX','BUG ') 81 CONTINUE ENDIF DO85I=1,NUMVAR WRITE(ICOUT,87)I,COEF(I) 87 FORMAT('I,COEF(I) = ',I8,E12.5) CALL DPWRST('XXX','BUG ') 85 CONTINUE 90 CONTINUE C C **************************************** C ** STEP 11-- ** C ** DETERMINE PLOT COORDINATES ** C ** PARTIAL REGRESSION PLOT CASE ** C **************************************** C IF(ICASPL.EQ.'PREG')THEN C CALL CATCHR(XMAT,XSCRT1,XSCRT2,Y2,Y3,ITEMP1, 1 N,NUMVAR,N,NUMVAR, 1 IBUGG3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PRG2')THEN IF(N.GT.0)THEN DO101I=1,N WRITE(ICOUT,102)I,(XSCRT2(I,K),K=1,MIN(7,NUMVAR)) 102 FORMAT('I,XSCRT(I,K) = ',I8,7E12.5) CALL DPWRST('XXX','BUG ') 101 CONTINUE ENDIF ENDIF C DSUM1=0.0D0 DO110I=1,N DSUM1=DSUM1 + DBLE(XSCRT2(I,IX))**2 110 CONTINUE DENOM=REAL(DSUM1) DO120I=1,N XJDOTJ=XSCRT2(I,IX)/DENOM Y(I)=RES(I) + COEF(IX)*XJDOTJ X(I)=XJDOTJ D(I)=1.0 120 CONTINUE C NPLOTP=N NPLOTV=2 GOTO9000 ELSEIF(ICASPL.EQ.'PLEV')THEN C CALL CATCHR(XMAT,XSCRT1,XSCRT2,Y2,Y3,ITEMP1, 1 N,NUMVAR,N,NUMVAR, 1 IBUGG3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PRG2')THEN IF(N.GT.0)THEN DO201I=1,N WRITE(ICOUT,202)I,(XSCRT2(I,K),K=1,MIN(7,NUMVAR)) 202 FORMAT('I,XSCRT(I,K) = ',I8,7E12.5) CALL DPWRST('XXX','BUG ') 201 CONTINUE ENDIF ENDIF C DSUM1=0.0D0 DO210I=1,N DSUM1=DSUM1 + DBLE(XSCRT2(I,IX))**2 210 CONTINUE DENOM=REAL(DSUM1) DSUM1=0.0 DO220I=1,N XJDOTJ=XSCRT2(I,IX)/DENOM XJDOTJ=XJDOTJ*XJDOTJ DSUM1=DSUM1 + DBLE(XJDOTJ) 220 CONTINUE DENOM2=REAL(DSUM1) DO230I=1,N XJDOTJ=XSCRT2(I,IX)/DENOM XJDOTJ=XJDOTJ*XJDOTJ Y(I)=XJDOTJ/DENOM2 X(I)=REAL(I) D(I)=1.0 230 CONTINUE C NPLOTP=N NPLOTV=2 GOTO9000 ELSEIF(ICASPL.EQ.'PRES')THEN C DO420I=1,N Y(I)=RES(I) + COEF(IX)*XMAT(I,IX) X(I)=XMAT(I,IX) D(I)=1.0 420 CONTINUE C NPLOTP=N NPLOTV=2 GOTO9000 ELSEIF(ICASPL.EQ.'CCPR')THEN C DO520I=1,N Y(I)=RES(I) + COEF(IX)*XMAT(I,IX) X(I)=XMAT(I,IX) D(I)=1.0 520 CONTINUE C DO530I=1,N Y(I+N)=COEF(IX)*XMAT(I,IX) X(I+N)=XMAT(I,IX) D(I+N)=2.0 530 CONTINUE C NPLOTP=2*N NPLOTV=2 GOTO9000 ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,410)ICASPL 410 FORMAT('***** ERROR IN DPPRG2: PLOT TYPE ',A4,' NOT ', 1 'RECOGNIZED.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'PRG2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPRG2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,NUMVAR,NPLOTP,IERROR 9012 FORMAT('ICASPL,NUMVAR,NPLOTP,IERROR = ',A4,2I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9031)NPLOTP,NPLOTV 9031 FORMAT('NPLOTP,NPLOTV = ',2I8) CALL DPWRST('XXX','BUG ') DO9035I=1,NPLOTP WRITE(ICOUT,9036)I,Y(I),X(I),D(I) 9036 FORMAT('I,Y(I),X(I),D(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPPRES(IHARG,NUMARG,ISORSW,IFOUND,IERROR) C C PURPOSE--DEFINE THE PRE-SORT SWITCH ISORSW. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG C OUTPUT ARGUMENTS--ISORSW ('ON' OR 'OFF') C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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 1978. C UPDATED --SEPTEMBER 1980. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 ISORSW 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.LE.0)GOTO1199 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'SORT')GOTO1150 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SORT')GOTO1110 GOTO1199 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1160 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 GOTO1199 C 1150 CONTINUE ISORSW='ON' GOTO1180 C 1160 CONTINUE ISORSW='OFF' GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)ISORSW 1181 FORMAT('THE PRE-SORT SWITCH HAS JUST BEEN TURNED ', 1A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPPRFO(IHARG,NUMARG, 1IPRITY,IFOUND,IERROR) C C PURPOSE--SET THE FORMAT/TYPE SWITCH FOR THE PRINTER. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG (AN INTEGER VARIABLE) C OUTPUT ARGUMENTS--IPRITY (A HOLLERITH VARIABLE) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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--92/4 C ORIGINAL VERSION--MARCH 1992. C UPDATED --FEBRUARY 1993. DEFAULT CHANGED TO POSTSCRIPT C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IPRITY 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 IFOUND='NO' IERROR='NO' C 1110 CONTINUE IF(NUMARG.LE.0)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 IF(IHARG(NUMARG).EQ.'?')GOTO1160 GOTO1170 C 1150 CONTINUE CCCCC THE FOLLOWING LINE WAS CHANGED FEBRUARY 1993 CCCCC IHOLD='ASCI' IHOLD='POST' GOTO1180 C 1160 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1169 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1161)IPRITY 1161 FORMAT('THE CURRENT FORMAT FOR THE PRINTER IS ',A4) CALL DPWRST('XXX','BUG ') 1169 CONTINUE IFOUND='YES' GOTO1199 C 1170 CONTINUE IHOLD=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' IPRITY=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IPRITY 1181 FORMAT('THE PRINTER FORMAT SWITCH HAS JUST ', 1'BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPPRIF(ILAB,NUMWDL,IFUNC,NCF,IBUGA3) C C PURPOSE--PRINT OUT A FUNCTION IN A NEAT FORM. C NOTE--THIS SUBROUTINE IS NECESSITATED BECAUSE C SOME STORED WORDS HAVE 1 CHARACTER (E.G, A, B, C, ETC.) C WHILE OTHERS HAVE SEVERAL CHARACTERS PACKED INTO C A SINGLE WORD (E.G., SQRT, ARCT, ETC.). C NOTE--ILAB(.) AND IFUNC(.) ARE HOLLERITH A4 VECTORS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. 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 1979. C UPDATED --JULY 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ILAB CHARACTER*4 IFUNC CHARACTER*4 IBUGA3 C CHARACTER*4 IBLANK CHARACTER*4 IBUF CHARACTER*4 ILAST CHARACTER*4 IB CHARACTER*4 ICH C C--------------------------------------------------------------------- C DIMENSION ILAB(*) DIMENSION IFUNC(*) C DIMENSION IB(140) DIMENSION ICH(10) 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 MAXCPL/128/ DATA NUMASC/4/ C C-----START POINT----------------------------------------------------- C ILAST='UNKN' C C ******************************************************* C ** DECOMPOSE EACH WORD INTO INDIVIDUAL CHARACTERS. ** C ** PRINT OUT ONLY THE LEADING NON-BLANK CHARACTERS. ** C ******************************************************* C IBLANK=' ' 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 DPPRIF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NUMWDL 52 FORMAT('NUMWDL = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)(ILAB(I),I=1,NUMWDL) 53 FORMAT('ILAB(.) = ',30A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)NCF 55 FORMAT('NCF = ',I8) CALL DPWRST('XXX','BUG ') CCCCC FEBRUARY 1995. CHECK FOR NCF > 30. NPRINT=NCF IF(NPRINT.GT.30)NPRINT=30 CCCCC IF(NCF.GE.1)WRITE(ICOUT,56)(IFUNC(I),I=1,NCF) IF(NPRINT.GE.1)WRITE(ICOUT,56)(IFUNC(I),I=1,NPRINT) 56 FORMAT('IFUNC(.) = ',30A4) IF(NCF.GE.1)CALL DPWRST('XXX','BUG ') 90 CONTINUE C NUMCPL=MAXCPL-NUMWDL*NUMASC C L=0 IL=0 ICF=0 IF(NCF.LE.0)ILAST='YES' IF(NCF.GE.1)ILAST='NO' IBUF='NO' 100 CONTINUE ICF=ICF+1 IF(IBUGA3.EQ.'ON')WRITE(ICOUT,101)ICF,L,IBUF,ILAST,IL 101 FORMAT('ICF,L,IBUF,ILAST,IL = ',I8,I8,2X,A4,2X,A4,I8) IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(ICF.GT.NCF)GOTO300 IF(ICF.EQ.NCF)ILAST='YES' C CALL DPXH1H(IFUNC(ICF),ICH,IEND,IBUGA3) C ITEST=L+IEND IF(ITEST.LE.NUMCPL)GOTO200 IBUF='YES' GOTO300 C 200 CONTINUE DO400I=1,IEND L=L+1 IB(L)=ICH(I) 400 CONTINUE GOTO100 C 300 CONTINUE NUMCTL=L L=0 IL=IL+1 C IF(NUMWDL.EQ.0)GOTO600 IF(NUMWDL.EQ.1)GOTO610 IF(NUMWDL.EQ.2)GOTO620 IF(NUMWDL.EQ.3)GOTO630 IF(NUMWDL.EQ.4)GOTO640 IF(NUMWDL.EQ.5)GOTO650 IF(NUMWDL.EQ.6)GOTO660 IF(NUMWDL.EQ.7)GOTO670 IF(NUMWDL.EQ.8)GOTO680 IF(NUMWDL.GE.9)GOTO690 C 600 CONTINUE IF(NUMCTL.LE.0)WRITE(ICOUT,606) IF(NUMCTL.LE.0)CALL DPWRST('XXX','BUG ') IF(NUMCTL.LE.0)GOTO609 IF(IL.EQ.1)WRITE(ICOUT,606)(IB(K),K=1,MIN(NUMCTL,128)) IF(IL.EQ.1)CALL DPWRST('XXX','BUG ') IF(IL.GE.2)WRITE(ICOUT,606)(IB(K),K=1,MIN(NUMCTL,128)) 606 FORMAT(128A1) IF(IL.GE.2)CALL DPWRST('XXX','BUG ') 605 CONTINUE 609 CONTINUE GOTO700 C 610 CONTINUE IF(NUMCTL.LE.0)WRITE(ICOUT,616)(ILAB(J),J=1,NUMWDL) IF(NUMCTL.LE.0)CALL DPWRST('XXX','BUG ') IF(NUMCTL.LE.0)GOTO619 IF(IL.EQ.1)WRITE(ICOUT,616)(ILAB(J),J=1,NUMWDL), 1 (IB(K),K=1,MIN(NUMCTL,124)) IF(IL.EQ.1)CALL DPWRST('XXX','BUG ') IF(IL.GE.2)WRITE(ICOUT,616)(IBLANK ,J=1,NUMWDL), 1 (IB(K),K=1,MIN(NUMCTL,128)) 616 FORMAT(A4,124A1) IF(IL.GE.2)CALL DPWRST('XXX','BUG ') 615 CONTINUE 619 CONTINUE GOTO700 C 620 CONTINUE IF(NUMCTL.LE.0)WRITE(ICOUT,626)(ILAB(J),J=1,NUMWDL) IF(NUMCTL.LE.0)CALL DPWRST('XXX','BUG ') IF(NUMCTL.LE.0)GOTO629 IF(IL.EQ.1)WRITE(ICOUT,626)(ILAB(J),J=1,NUMWDL), 1 (IB(K),K=1,MIN(NUMCTL,120)) IF(IL.EQ.1)CALL DPWRST('XXX','BUG ') IF(IL.GE.2)WRITE(ICOUT,626)(IBLANK ,J=1,NUMWDL), 1 (IB(K),K=1,MIN(NUMCTL,120)) 626 FORMAT(2A4,120A1) IF(IL.GE.2)CALL DPWRST('XXX','BUG ') 625 CONTINUE 629 CONTINUE GOTO700 C 630 CONTINUE IF(NUMCTL.LE.0)WRITE(ICOUT,636)(ILAB(J),J=1,NUMWDL) IF(NUMCTL.LE.0)CALL DPWRST('XXX','BUG ') IF(NUMCTL.LE.0)GOTO639 IF(IL.EQ.1)WRITE(ICOUT,636)(ILAB(J),J=1,NUMWDL), 1(IB(K),K=1,MIN(NUMCTL,116)) IF(IL.EQ.1)CALL DPWRST('XXX','BUG ') IF(IL.GE.2)WRITE(ICOUT,636)(IBLANK ,J=1,NUMWDL), 1 (IB(K),K=1,MIN(NUMCTL,116)) 636 FORMAT(3A4,116A1) IF(IL.GE.2)CALL DPWRST('XXX','BUG ') 635 CONTINUE 639 CONTINUE GOTO700 C 640 CONTINUE IF(NUMCTL.LE.0)WRITE(ICOUT,646)(ILAB(J),J=1,NUMWDL) IF(NUMCTL.LE.0)CALL DPWRST('XXX','BUG ') IF(NUMCTL.LE.0)GOTO649 IF(IL.EQ.1)WRITE(ICOUT,646)(ILAB(J),J=1,NUMWDL), 1 (IB(K),K=1,MIN(NUMCTL,112)) IF(IL.EQ.1)CALL DPWRST('XXX','BUG ') IF(IL.GE.2)WRITE(ICOUT,646)(IBLANK ,J=1,NUMWDL), 1 (IB(K),K=1,MIN(NUMCTL,112)) 646 FORMAT(4A4,112A1) IF(IL.GE.2)CALL DPWRST('XXX','BUG ') 645 CONTINUE 649 CONTINUE GOTO700 C 650 CONTINUE IF(NUMCTL.LE.0)WRITE(ICOUT,656)(ILAB(J),J=1,NUMWDL) IF(NUMCTL.LE.0)CALL DPWRST('XXX','BUG ') IF(NUMCTL.LE.0)GOTO659 IF(IL.EQ.1)WRITE(ICOUT,656)(ILAB(J),J=1,NUMWDL), 1 (IB(K),K=1,MIN(NUMCTL,108)) IF(IL.EQ.1)CALL DPWRST('XXX','BUG ') IF(IL.GE.2)WRITE(ICOUT,656)(IBLANK ,J=1,NUMWDL), 1 (IB(K),K=1,MIN(NUMCTL,108)) 656 FORMAT(5A4,108A1) IF(IL.GE.2)CALL DPWRST('XXX','BUG ') 655 CONTINUE 659 CONTINUE GOTO700 C 660 CONTINUE IF(NUMCTL.LE.0)WRITE(ICOUT,666)(ILAB(J),J=1,NUMWDL) IF(NUMCTL.LE.0)CALL DPWRST('XXX','BUG ') IF(NUMCTL.LE.0)GOTO669 IF(IL.EQ.1)WRITE(ICOUT,666)(ILAB(J),J=1,NUMWDL), 1 (IB(K),K=1,MIN(NUMCTL,104)) IF(IL.EQ.1)CALL DPWRST('XXX','BUG ') IF(IL.GE.2)WRITE(ICOUT,666)(IBLANK ,J=1,NUMWDL), 1 (IB(K),K=1,MIN(NUMCTL,104)) 666 FORMAT(6A4,104A1) IF(IL.GE.2)CALL DPWRST('XXX','BUG ') 665 CONTINUE 669 CONTINUE GOTO700 C 670 CONTINUE IF(NUMCTL.LE.0)WRITE(ICOUT,676)(ILAB(J),J=1,NUMWDL) IF(NUMCTL.LE.0)CALL DPWRST('XXX','BUG ') IF(NUMCTL.LE.0)GOTO679 IF(IL.EQ.1)WRITE(ICOUT,676)(ILAB(J),J=1,NUMWDL), 1 (IB(K),K=1,MIN(NUMCTL,100)) IF(IL.EQ.1)CALL DPWRST('XXX','BUG ') IF(IL.GE.2)WRITE(ICOUT,676)(IBLANK ,J=1,NUMWDL), 1 (IB(K),K=1,MIN(NUMCTL,100)) 676 FORMAT(7A4,100A1) IF(IL.GE.2)CALL DPWRST('XXX','BUG ') 675 CONTINUE 679 CONTINUE GOTO700 C 680 CONTINUE IF(NUMCTL.LE.0)WRITE(ICOUT,686)(ILAB(J),J=1,NUMWDL) IF(NUMCTL.LE.0)CALL DPWRST('XXX','BUG ') IF(NUMCTL.LE.0)GOTO689 IF(IL.EQ.1)WRITE(ICOUT,686)(ILAB(J),J=1,NUMWDL), 1 (IB(K),K=1,MIN(NUMCTL,96)) IF(IL.EQ.1)CALL DPWRST('XXX','BUG ') IF(IL.GE.2)WRITE(ICOUT,686)(IBLANK ,J=1,NUMWDL), 1 (IB(K),K=1,MIN(NUMCTL,96)) 686 FORMAT(8A4,96A1) IF(IL.GE.2)CALL DPWRST('XXX','BUG ') 685 CONTINUE 689 CONTINUE GOTO700 C 690 CONTINUE IF(NUMCTL.LE.0)WRITE(ICOUT,696)(ILAB(J),J=1,NUMWDL) IF(NUMCTL.LE.0)CALL DPWRST('XXX','BUG ') IF(NUMCTL.LE.0)GOTO699 IF(IL.EQ.1)WRITE(ICOUT,696)(ILAB(J),J=1,NUMWDL), 1 (IB(K),K=1,MIN(NUMCTL,92)) IF(IL.EQ.1)CALL DPWRST('XXX','BUG ') IF(IL.GE.2)WRITE(ICOUT,696)(IBLANK ,J=1,NUMWDL), 1 (IB(K),K=1,MIN(NUMCTL,92)) 696 FORMAT(9A4,92A1) IF(IL.GE.2)CALL DPWRST('XXX','BUG ') 695 CONTINUE 699 CONTINUE GOTO700 C 700 CONTINUE IF(IL.LT.100)GOTO710 WRITE(ICOUT,701) 701 FORMAT('***** INTERNAL ERROR IN DPFUIP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,702) 702 FORMAT('INFINITE LOOP--IL = 100') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,703)NCF,L,IBUF,ILAST,IL 703 FORMAT('NCF,L,IBUF,ILAST,IL = ',I8,I8,2X,A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') GOTO9000 710 CONTINUE IF(IBUF.EQ.'YES')GOTO800 GOTO850 C 800 CONTINUE DO810I=1,IEND L=L+1 IB(L)=ICH(I) 810 CONTINUE IBUF='NO' C IF(ILAST.EQ.'YES')GOTO300 IF(ILAST.EQ.'NO')GOTO100 C 850 CONTINUE IF(ILAST.EQ.'YES')GOTO9000 IF(ILAST.EQ.'NO')GOTO100 C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPRIF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICF,L,IBUF,ILAST,IL,NUMCTL 9012 FORMAT('ICF,L,IBUF,ILAST,IL,NUMCTL = ',2I8,2X,A4,2X,A4,2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)(IB(I),I=1,MIN(NUMCTL,120)) 9013 FORMAT('IB(.) = ',120A1) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END