SUBROUTINE DPPROF(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
C
C PURPOSE--GENERATE A PROFILE PLOT--
C A MULTIVARIATE TECHNICQUE WHICH PLOTS A STANDARDIZED (0 TO 1)
C VARIABLE VERSUS DUMMY VARIABLE NUMBER.
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--88/2
C ORIGINAL VERSION--FEBRUARY 1988.
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 ISUBRO
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 IHWUSE
CHARACTER*4 MESSAG
CHARACTER*4 ICASEQ
CCCCC CHARACTER*4 IH
CCCCC CHARACTER*4 IH2
CCCCC CHARACTER*4 IERRO2
CHARACTER*4 IHRIGH
CHARACTER*4 IHRIG2
CCCCC CHARACTER*4 IHHOR
CCCCC CHARACTER*4 IHHOR2
CHARACTER*4 IWRITE
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
INCLUDE 'DPCOPA.INC'
C
DIMENSION Z1(MAXOBV)
DIMENSION Z2(MAXOBV)
DIMENSION Z3(MAXOBV)
DIMENSION YSUB(MAXOBV)
DIMENSION YFULL(MAXOBV)
DIMENSION XTEMP(MAXOBV)
CCCCC FOLLOWING LINES ADDED JUNE, 1990
INCLUDE 'DPCOZZ.INC'
EQUIVALENCE (GARBAG(IGARB1),Z1(1))
EQUIVALENCE (GARBAG(IGARB2),Z2(1))
EQUIVALENCE (GARBAG(IGARB3),Z3(1))
EQUIVALENCE (GARBAG(IGARB4),YSUB(1))
EQUIVALENCE (GARBAG(IGARB5),YFULL(1))
EQUIVALENCE (GARBAG(IGARB6),XTEMP(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'
C
ISUBN1='DPPR'
ISUBN2='OF '
C
MAXCP1=MAXCOL+1
MAXCP2=MAXCOL+2
MAXCP3=MAXCOL+3
MAXCP4=MAXCOL+4
MAXCP5=MAXCOL+5
MAXCP6=MAXCOL+6
C
MAXV2=2
MINN2=2
C
ICOLH=0
C
C ***********************************
C ** TREAT THE PROFILE PLOT CASE **
C ***********************************
C
IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PROF')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPPROF--')
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 ')
90 CONTINUE
C
C ***************************
C ** STEP 1-- **
C ** EXTRACT THE COMMAND **
C ***************************
C
ISTEPN='11'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PROF')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ICASPL='PROF'
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 ***********************************************************
C
ISTEPN='2'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PROF')
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 11-- **
C ** FOR A PROFILE PLOT, **
C ** WE MUST HAVE A SUBSET OR FOR **
C ** SO AS TO INDICATE EXACTLY WHICH **
C ** CAR, ETC. THE SINGLE PROFILE PLOT **
C ** WILL BE FORMED FOR. **
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.'PROF')
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
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1181)
1181 FORMAT('***** ERROR IN DPPROF')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1182)
1182 FORMAT(' AT BRANCH POINT 481--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1183)
1183 FORMAT(' NUMARG LESS THAN 1.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1184)
1184 FORMAT(' POSSIBLE CAUSE--AN OMITTED (BUT NEEDED)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1185)
1185 FORMAT(' SUBSET/EXCEPT/FOR QUALIIFICATION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1186)
1186 FORMAT(' AT THE END OF THE PROFILE PLOT COMMAND.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1187)
1187 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,1188)(IANS(I),I=1,IWIDTH)
1188 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
1190 CONTINUE
IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PROF')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 **************************************************
C
ISTEPN='12'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PROF')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
NUMVAR=ILOCQ-1
IF(NUMVAR.GE.1)GOTO1290
C
WRITE(ICOUT,1211)
1211 FORMAT('***** ERROR IN DPPROF--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1212)
1212 FORMAT(' THE NUMBER OF VARIABLES ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1213)
1213 FORMAT(' TO BE INCLUDED AS COMPONENTS ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1214)
1214 FORMAT(' IN A PROFILE PLOT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1215)
1215 FORMAT(' MUST BE 1 OR LARGER;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1216)
1216 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1217)
1217 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,1218)(IANS(I),I=1,IWIDTH)
1218 FORMAT(80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
RETURN
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. **
C ***************************************
C
ISTEPN='13'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PROF')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
DO1300I=1,NUMVAR
C
IHRIGH=IHARG(I)
IHRIG2=IHARG2(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(NRIGHT.GE.MINN2)GOTO1390
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1311)
1311 FORMAT('***** ERROR IN DPPROF--')
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 PROFILE 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)WRITE(ICOUT,1329)(IANS(J),J=1,IWIDTH)
1329 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
1390 CONTINUE
C
1300 CONTINUE
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.'PROF')
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.'PROF')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
DO2200K=1,NUMVAR
IHRIGH=IHARG(K)
IHRIG2=IHARG2(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 DPPROF AT POINT 2210--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2212)
2212 FORMAT(' THE VARIABLE ',I4,I4)
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.'PROF')
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.'PROF')
1CALL DPWRST('XXX','BUG ')
IF(ICOLR.LE.MAXCOL)YSUB(J)=V(IJ)
IF(ICOLR.EQ.MAXCP1)YSUB(J)=PRED(I)
IF(ICOLR.EQ.MAXCP2)YSUB(J)=RES(I)
IF(ICOLR.EQ.MAXCP3)YSUB(J)=YPLOT(I)
IF(ICOLR.EQ.MAXCP4)YSUB(J)=XPLOT(I)
IF(ICOLR.EQ.MAXCP5)YSUB(J)=X2PLOT(I)
IF(ICOLR.EQ.MAXCP6)YSUB(J)=TAGPLO(I)
2240 CONTINUE
NLOCAL=J
NSUB=NLOCAL
C
J=0
IMAX=NRIGHT
DO2250I=1,IMAX
J=J+1
IJ=MAXN*(ICOLR-1)+I
IF(ICOLR.LE.MAXCOL)YFULL(J)=V(IJ)
IF(ICOLR.EQ.MAXCP1)YFULL(J)=PRED(I)
IF(ICOLR.EQ.MAXCP2)YFULL(J)=RES(I)
IF(ICOLR.EQ.MAXCP3)YFULL(J)=YPLOT(I)
IF(ICOLR.EQ.MAXCP4)YFULL(J)=XPLOT(I)
IF(ICOLR.EQ.MAXCP5)YFULL(J)=X2PLOT(I)
IF(ICOLR.EQ.MAXCP6)YFULL(J)=TAGPLO(I)
2250 CONTINUE
NFULL=J
C
IWRITE='OFF'
CALL MEDIAN(YSUB,NSUB,IWRITE,XTEMP,MAXN,XMED,IBUGG3,IERROR)
CALL MINIM(YFULL,NFULL,IWRITE,XMIN,IBUGG3,IERROR)
CALL MAXIM(YFULL,NFULL,IWRITE,XMAX,IBUGG3,IERROR)
Z1(K)=XMED
Z2(K)=XMIN
Z3(K)=XMAX
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(.) TO 1'S, 2'S, AND 3'S **
C ** FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE LINE, **
C ** AND THE UPPER CONFIDENCE LINE. **
C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). **
C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). **
C *************************************************************
C
ISTEPN='8'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PROF')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CALL DPPRO2(Z1,Z2,Z3,NZ,ICASPL,
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.'PROF')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPPROF--')
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)NSUB
9021 FORMAT('NSUB = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NSUB.LE.0)GOTO9024
DO9022I=1,NSUB
WRITE(ICOUT,9023)I,YSUB(I)
9023 FORMAT('I,YSUB(I) = ',I8,E15.7)
CALL DPWRST('XXX','BUG ')
9022 CONTINUE
9024 CONTINUE
WRITE(ICOUT,9031)NFULL
9031 FORMAT('NFULL = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NFULL.LE.0)GOTO9034
DO9032I=1,NFULL
WRITE(ICOUT,9033)I,YFULL(I)
9033 FORMAT('I,YFULL(I) = ',I8,E15.7)
CALL DPWRST('XXX','BUG ')
9032 CONTINUE
9034 CONTINUE
WRITE(ICOUT,9041)NZ
9041 FORMAT('NZ = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NZ.LE.0)GOTO9044
DO9042I=1,NZ
WRITE(ICOUT,9043)I,Z1(I),Z2(I),Z3(I)
9043 FORMAT('I,Z1(I),Z2(I),Z3(I) = ',I8,3E15.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)
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 DPPROJ(ICOM,IHARG,NUMARG,I3DPRO,
1IFOUND,IERROR)
C
C PURPOSE--DEFINE THE 3-D PROJECTION SWITCH I3DPRO.
C THE 2 SETTINGS ARE
C 1) ORTHOGRAPHIC (THE DEFAULT)
C 2) PERSPECTIVE
C INPUT ARGUMENTS--ICOM
C --IHARG (A HOLLERITH VECTOR)
C --NUMARG
C OUTPUT ARGUMENTS--I3DPRO ('ORTH' OR 'PERS')
C --IFOUND ('YES' OR 'NO' )
C --IERROR ('YES' OR 'NO' )
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DI3DPROION
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--88/10
C ORIGINAL VERSION--SEPTEMBER 1988.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 ICOM
CHARACTER*4 IHARG
CHARACTER*4 I3DPRO
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(ICOM.EQ.'ORTH')GOTO1110
IF(ICOM.EQ.'PERS')GOTO1120
IF(ICOM.EQ.'PROJ')GOTO1130
C
1110 CONTINUE
IF(NUMARG.LE.0)GOTO1150
IF(IHARG(1).EQ.'ON')GOTO1150
IF(IHARG(1).EQ.'OFF')GOTO1160
GOTO1199
C
1120 CONTINUE
IF(NUMARG.LE.0)GOTO1160
IF(IHARG(1).EQ.'ON')GOTO1160
IF(IHARG(1).EQ.'OFF')GOTO1150
GOTO1199
C
1130 CONTINUE
IF(NUMARG.LE.0)GOTO1150
IF(IHARG(1).EQ.'ON')GOTO1150
IF(IHARG(1).EQ.'OFF')GOTO1160
IF(IHARG(1).EQ.'AUTO')GOTO1150
IF(IHARG(1).EQ.'DEFA')GOTO1150
IF(IHARG(1).EQ.'ORTH')GOTO1150
IF(IHARG(1).EQ.'PERS')GOTO1160
GOTO1199
C
1150 CONTINUE
I3DPRO='ORTH'
GOTO1180
C
1160 CONTINUE
I3DPRO='PERS'
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)
1181 FORMAT('THE PROJECTION SWITCH (AFFECTING 3-D PLOTS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1182)I3DPRO
1182 FORMAT(' HAS JUST BEEN SET TO ',A4)
CALL DPWRST('XXX','BUG ')
1189 CONTINUE
GOTO1199
C
1199 CONTINUE
RETURN
END
SUBROUTINE DPPROM(IHARG,NUMARG,IPROSW,IFOUND,IERROR)
C
C PURPOSE--DEFINE THE PROMPT SWITCH IPROSW.
C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR)
C --NUMARG
C OUTPUT ARGUMENTS--IPROSW ('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--86/1
C ORIGINAL VERSION--DECEMBER 1985.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IHARG
CHARACTER*4 IPROSW
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
DIMENSION IHARG(*)
C
C---------------------------------------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
IFOUND='NO'
IERROR='NO'
C
IF(NUMARG.EQ.0)GOTO1150
IF(NUMARG.GE.1)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
IPROSW='ON'
GOTO1180
C
1160 CONTINUE
IPROSW='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)IPROSW
1181 FORMAT('THE PROMPT SWITCH HAS JUST BEEN TURNED ',
1A4)
CALL DPWRST('XXX','BUG ')
1189 CONTINUE
GOTO1199
C
1199 CONTINUE
RETURN
END
SUBROUTINE DPPRO2(Z1,Z2,Z3,NZ,ICASPL,
1Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
C
C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
C THAT WILL DEFINE
C A PROFILE PLOT
C (USEFUL FOR MULTIVARIATE ANALYSIS).
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--88/2
C ORIGINAL VERSION--JANUARY 1988.
C UPDATED --APRIL 1992. DELETE K
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 Z1(*)
DIMENSION Z2(*)
DIMENSION Z3(*)
C
DIMENSION Y2(*)
DIMENSION X2(*)
DIMENSION D2(*)
C
C---------------------------------------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
ISUBN1='DPPR'
ISUBN2='O2 '
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 DPPRO2--')
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.'PRO2')GOTO90
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,71)
71 FORMAT('***** AT THE BEGINNING OF DPPRO2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,72)ICASPL,NZ,N2,NPLOTV
72 FORMAT('ICASPL,NZ,N2,NPLOTV = ',A4,2X,3I8)
CALL DPWRST('XXX','BUG ')
IF(NZ.LE.0)GOTO83
DO81I=1,NZ
WRITE(ICOUT,82)I,Z1(I),Z2(I),Z3(I)
82 FORMAT('I,Z1(I),Z2(I),Z3(I) = ',I8,2E12.5)
CALL DPWRST('XXX','BUG ')
81 CONTINUE
83 CONTINUE
90 CONTINUE
C
C ****************************************
C ** STEP 11-- **
C ** DETERMINE PLOT COORDINATES **
C ****************************************
C
J=0
DO1100I=1,NZ
ANUM=Z1(I)-Z2(I)
ADEN=Z3(I)-Z2(I)
P=0.0
IF(ADEN.GT.0.0)P=ANUM/ADEN
J=J+1
Y2(J)=P
X2(J)=J
D2(J)=1.0
1100 CONTINUE
N2=J
NPLOTV=2
GOTO9000
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'PRO2')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPPRO2--')
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 THE FOLLOWING 2 LINES WERE FIXED APRIL 1992
CCCCC WRITE(ICOUT,9013)NZ,J,K
C9013 FORMAT('NZ,J,K = ',3I8)
CCCCC CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)NZ,J
9013 FORMAT('NZ,J = ',2I8)
CALL DPWRST('XXX','BUG ')
IF(NZ.LE.0)GOTO9023
DO9021I=1,NZ
WRITE(ICOUT,9022)I,Z1(I),Z2(I),Z3(I)
9022 FORMAT('I,Z1(I),Z2(I),Z3(I) = ',I8,2E12.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,Y2(I),X2(I),D2(I)
9036 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2)
CALL DPWRST('XXX','BUG ')
9035 CONTINUE
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPPRPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1IANGLU,MAXNPP,
1CLLIMI,CLWIDT,
1ICONT,NUMHPP,NUMVPP,IMANUF,
1XMATN,YMATN,XMITN,YMITN,
1ISQUAR,
1IVGMSW,IHGMSW,
1IMPSW,IMPNR,IMPNC,IMPCO,
1PMXMIN,PMXMAX,PMYMIN,PMYMAX,
1TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
1ALOWFR,ALOWDG,
1IFORSW,
1ANOPL1,ANOPL2,ISEED,IBOOSS,BARHEF,BARWEF,
1ICAPSW,
1IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,
1IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
1IFOUND,IERROR)
C
C PURPOSE--GENERATE EITHER
C 1) A PARTIAL REGRESSION PLOT
C 2) A PARTIAL LEVERAGE PLOT
C 3) A PARTIAL RESIDUAL PLOT
C 4) A CCPR PLOT
C FOR EXAMPLE, THE COMMAND
C PARTIAL REGRESSION PLOT Y X1 TO XK
C WILL GENERATE PARTIAL REGRESSION PLOTS OF Y VS X1,
C Y VS X2, ETC. AS A MULTIPLOT ON A SINGLE PAGE.
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--2002/6
C ORIGINAL VERSION--JUNE 2002.
C UPDATED --FEBRUARY 2005. CALL LIST TO MAINAN
C UPDATED --MARCH 2006. CALL LIST TO MAINGR
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES---------------
C
INCLUDE 'DPCOPA.INC'
C
CHARACTER*4 ICASPL
CHARACTER*4 ICASP2
CHARACTER*4 ICAPSW
CHARACTER*4 ICASAN
CHARACTER*4 ICASEQ
CHARACTER*4 ICONT
CHARACTER*4 IAND1
CHARACTER*4 IAND2
CHARACTER*4 IANGLU
CHARACTER*4 IFORSW
CHARACTER*4 IFTEXP
CHARACTER*4 IFTORD
CHARACTER*4 ICPSWZ
C
CHARACTER*4 IBUGG2
CHARACTER*4 IBUGG3
CHARACTER*4 IBUGUG
CHARACTER*4 IBUGU2
CHARACTER*4 IBUGU3
CHARACTER*4 IBUGU4
CHARACTER*4 IBUGCO
CHARACTER*4 IBUGEV
CHARACTER*4 IBUGQ
C
CHARACTER*4 ISUBRO
CHARACTER*4 ISUBN0
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 IEMPTY
CHARACTER*4 IERAS2
CHARACTER*4 IFENC2
CHARACTER*4 IPPTB2
CHARACTER*4 ISORS2
CHARACTER*4 ISQUAR
CHARACTER*4 IVGMSW
CHARACTER*4 IHGMSW
CHARACTER*4 IREPCH
CHARACTER*4 IMPSW
CHARACTER*4 IMPSW3
CHARACTER*4 IFPLFZ
CHARACTER*4 IFPLTZ
CHARACTER*4 IFPLPZ
CHARACTER*4 IFPLLZ
CHARACTER*4 IFPLL2
CHARACTER*4 IFPLXZ
CHARACTER*4 IFPLYZ
CHARACTER*4 IFPLDZ
CHARACTER*4 IFPLZT
CHARACTER*4 IFPLZ2
CHARACTER*4 IFPLZ3
CHARACTER*4 IFPLZ4
C
CHARACTER*4 IFEED9
C
CHARACTER*4 IMANUF
C
CHARACTER*4 ICHAP2(100)
CHARACTER*4 ILINP2(100)
CHARACTER*4 ISPIS2(100)
CHARACTER*4 IBARS2(100)
CHARACTER*4 IX1TSV
CHARACTER*4 IX2TSV
CHARACTER*4 IY1TSV
CHARACTER*4 IY2TSV
CHARACTER*4 IX1ZSV
CHARACTER*4 IX2ZSV
CHARACTER*4 IY1ZSV
CHARACTER*4 IY2ZSV
CHARACTER*4 IY1MNS
CHARACTER*4 IY1MXS
CHARACTER*4 IY1LJ2
CHARACTER*4 IY1LD2
CHARACTER*4 IY2MNS
CHARACTER*4 IY2MXS
CHARACTER*4 IX1MNS
CHARACTER*4 IX1MXS
CHARACTER*4 IX2MNS
CHARACTER*4 IX2MXS
CHARACTER*4 IX1FSV
CHARACTER*4 IX2FSV
CHARACTER*4 IY1FSV
CHARACTER*4 IY2FSV
CHARACTER*4 ILFLAX
CHARACTER*4 ILFLAY
CHARACTER*4 IFPLLD
CHARACTER*4 IFPLDI
CHARACTER*4 IX1LT2(MAXCH)
CHARACTER*4 IX2LT2(MAXCH)
CHARACTER*4 IY1LT2(MAXCH)
CHARACTER*4 IY2LT2(MAXCH)
CHARACTER*4 ITITSV(MAXCH)
CHARACTER*4 IPLOTT
CCCCC CHARACTER*4 ISUBSZ
C
CHARACTER*80 IFILE5
CHARACTER*12 ISTAT5
CHARACTER*12 IFORM5
CHARACTER*12 IACCE5
CHARACTER*12 IPROT5
CHARACTER*12 ICURS5
CHARACTER*4 IERRF5
CHARACTER*4 IENDF5
CHARACTER*4 IREWI5
INCLUDE 'DPCOF2.INC'
C
CHARACTER*4 ICT
CHARACTER*4 IC2T
CHARACTER*4 IHT(5)
CHARACTER*4 IH2T(5)
CHARACTER*4 ISU2SW(MAXSUB)
C
C MAXY IS THE MAXIMUM NUMBER OF VARIABLES TO USE IN CREATING THE
C PARTIAL REGRESSION PLOT CURVE
C
PARAMETER(MAXY=50)
C
DIMENSION IVARN1(MAXY)
DIMENSION IVARN2(MAXY)
DIMENSION ILIS(MAXY)
DIMENSION ICOLL(MAXY)
C
CHARACTER*4 IHRIGH
CHARACTER*4 IHRIG2
CHARACTER*4 IHWUSE
CHARACTER*4 MESSAG
CHARACTER*4 ISTEPN
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 IVARN1
CHARACTER*4 IVARN2
CCCCC CHARACTER*4 IWRITE
C
DIMENSION TEMP(*)
DIMENSION TEMP2(*)
DIMENSION TEMP3(*)
DIMENSION XTEMP1(*)
DIMENSION XTEMP2(*)
C
C-----COMMON------------------------------------------------------
C
C
INCLUDE 'DPCOZZ.INC'
INCLUDE 'DPCOPC.INC'
INCLUDE 'DPCOHK.INC'
INCLUDE 'DPCODA.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
IFOUND='YES'
IERROR='NO'
C
ISUBN1='DPPR'
ISUBN2='PL '
C
IF(ICASPL.NE.'CCPR')ICASPL='PRPL'
IFPLLD='ON'
IFPLDI='LINE'
IBOOSS=100
C
IFLAGV=5
C
C ***********************************************
C ** TREAT THE PARTIAL REGRESSION PLOT CASE **
C ***********************************************
C
IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PRPL')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPPRPL--')
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 ')
WRITE(ICOUT,54)NUMARG
54 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NUMARG.LE.0)GOTO69
DO61I=1,NUMARG
WRITE(ICOUT,62)I,IHARG(I),IARGT(I)
62 FORMAT('I,IHARG(I),IARGT(I) = ',I8,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
61 CONTINUE
69 CONTINUE
WRITE(ICOUT,71)IFPLLA
71 FORMAT('IFPLLA = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,72)IFPLTA
72 FORMAT('IFPLTA = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,73)IFPLPT
73 FORMAT('IFPLPT = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,74)IFPLFI
74 FORMAT('IFPLFI = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,75)IFPLFR
75 FORMAT('IFPLFR = ',A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C ******************************************************
C ** STEP 1-- **
C ** SHIFT COMMAND LINE ARGMENTS **
C ******************************************************
C
ISTEPN='1'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PRPL')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(NUMARG.GE.2.AND.IHARG(1).EQ.'REGR'.AND.IHARG(2).EQ.'PLOT')THEN
ICASPL='PREG'
ISHIFT=2
CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
1 IBUGG2,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
ENDIF
C
C SYNONYM: ADDED VARIABLE PLOT
C
IF(NUMARG.GE.2.AND.IHARG(1).EQ.'VARI'.AND.IHARG(2).EQ.'PLOT')THEN
ICASPL='PREG'
ISHIFT=2
CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
1 IBUGG2,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
ENDIF
C
IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LEVE'.AND.IHARG(2).EQ.'PLOT')THEN
ICASPL='PLEV'
ISHIFT=2
CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
1 IBUGG2,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
ENDIF
C
IF(NUMARG.GE.2.AND.IHARG(1).EQ.'RESI'.AND.IHARG(2).EQ.'PLOT')THEN
ICASPL='PRES'
ISHIFT=2
CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
1 IBUGG2,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
ENDIF
C
IF(ICASPL.EQ.'CCPR'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')THEN
ISHIFT=1
CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
1 IBUGG2,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
ENDIF
C
C SYNONYM: COMPONENT PLUS RESIDUAL PLOT
C
IF(NUMARG.GE.3.AND.IHARG(1).EQ.'PLUS'.AND.IHARG(2).EQ.'RESI'.AND.
1 IHARG(3).EQ.'PLOT')THEN
ICASPL='PRES'
ISHIFT=3
CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
1 IBUGG2,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
ENDIF
C
ICOM='FIT '
ICOM2=' '
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.'PRPL')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
MINN2=2
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.'PRPL')
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.'PRPL')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 **************************************************
C
ISTEPN='12'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PRPL')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
JMIN=1
JMAX=ILOCQ-1
CALL EXTVAR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXY,
1IHNAME,IHNAM2,IUSE,NUMNAM,
1IVARN1,IVARN2,NUMVAR,IBUGG2,ISUBRO,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
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. **
C ***************************************
C
ISTEPN='13'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PRPL')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
MAXCP1=MAXCOL+1
MAXCP2=MAXCOL+2
MAXCP3=MAXCOL+3
MAXCP4=MAXCOL+4
MAXCP5=MAXCOL+5
MAXCP6=MAXCOL+6
C
IFLAG=0
IFLAG2=0
DO1300I=1,NUMVAR
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
NTEMP=IN(ILOCV)
IF(I.EQ.1)THEN
NRIGHT=NTEMP
ELSE
NRIGH2=NTEMP
IF(NTEMP.NE.NRIGHT)IFLAG=1
ENDIF
ILIS(I)=ILOCV
C
IF(NTEMP.GT.MINN2)GOTO1390
C
1309 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1311)
1311 FORMAT('***** ERROR IN DPPRPL--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1312)
1312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR WHICH A')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1321)
1321 FORMAT(' PARTIAL REGRESSION PLOT WAS TO HAVE BEEN FORMED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1326)MINN2
1326 FORMAT(' MUST BE ',I8,' OR LARGER; SUCH WAS NOT THE CASE',
1' HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1327)I,NTEMP
1327 FORMAT(' VARIABLE ',I8,' HAS ',I8,' OBSERVATIONS.')
WRITE(ICOUT,1328)
1328 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,1329)(IANS(J),J=1,MIN(IWIDTH,100))
1329 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
1390 CONTINUE
C
1300 CONTINUE
C
C
C ******************************************************
C ** STEP 1.4-- **
C ** CHECK THAT VARIABLES HAVE THE SAME NUMBER OF **
C ** ELEMENTS. **
C ******************************************************
C
1400 CONTINUE
ISTEPN='1.4'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PRPL')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
1410 CONTINUE
IF(IFLAG.EQ.1)THEN
WRITE(ICOUT,1411)
1411 FORMAT('***** ERROR IN DPPRPL--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1413)
1413 FORMAT(' THE NUMBER OF OBSERVATIONS FOR EACH OF THE',
1 'VARIABLES')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1414)
CALL DPWRST('XXX','BUG ')
1414 FORMAT(' MUST BE THE SAME; SUCH WAS NOT THE CASE HERE.')
DO1417I=1,NUMVAR
I2=ILIS(I)
WRITE(ICOUT,1416)IVARN1(I),IVARN2(I),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(I),I=1,MIN(IWIDTH,100))
1421 FORMAT(' ',100A1)
CALL DPWRST('XXX','BUG ')
ENDIF
IERROR='YES'
GOTO9000
ENDIF
C
C **************************************************
C ** STEP 0.5-- **
C ** PERFORM MULTILINEAR FIT **
C **************************************************
C
ISTEPN='0.5'
IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PRPL')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ICPSWZ='OFF'
CALL MAINAN(ICASAN,ISEED,ANOPL1,ANOPL2,
1TEMP,TEMP2,XTEMP1,XTEMP2,MAXNXT,
1IFTEXP,IFTORD,
1ALOWFR,ALOWDG,
1IBOOSS,
1ICPSWZ,
1IFORSW,
1IBUGG2,IBUGG2,IBUGG3,
1IBUGCO,IBUGEV,IBUGQ,ISUBRO,IFOUND,IERROR)
C
C **************************************************
C ** STEP 1-- **
C ** SAVE INITIAL SETTINGS **
C **************************************************
C
ISTEPN='1'
IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PRPL')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
PXMN2=PXMIN
PXMX2=PXMAX
PYMN2=PYMIN
PYMX2=PYMAX
PWXMN2=PWXMIN
PWXMX2=PWXMAX
PWYMN2=PWYMIN
PWYMX2=PWYMAX
IF(IFPLFR.EQ.'DEFA')THEN
PXMIN=0.0
PXMAX=100.0
PYMIN=0.0
PYMAX=100.0
ENDIF
C
IERAS2=IERASW
IFENC2=IFENSW
IPPTB2=IPPTBI
ISORS2=ISORSW
C
ILFLAX='OFF'
ILFLAY='OFF'
IF(IY1MIN.EQ.'FIXE'.AND.IY1MAX.EQ.'FIXE')THEN
ILFLAY='ON'
ENDIF
IF(IX1MIN.EQ.'FIXE'.AND.IX2MAX.EQ.'FIXE')THEN
ILFLAX='ON'
ENDIF
C
IX1TSV=IX1TSW
IX2TSV=IX2TSW
IY1TSV=IY1TSW
IY2TSV=IY2TSW
IX1ZSV=IX1ZSW
IX2ZSV=IX2ZSW
IY1ZSV=IY1ZSW
IY2ZSV=IY2ZSW
PX1LD2=PX1LDS
PX2LD2=PX2LDS
PY1LD2=PY1LDS
PY1LA2=PY1LAN
IY1LJ2=IY1LJU
IY1LD2=IY1LDI
GY1MNS=GY1MIN
GY1MXS=GY1MAX
GY2MNS=GY2MIN
GY2MXS=GY2MAX
GX1MNS=GX1MIN
GX1MXS=GX1MAX
GX2MNS=GX2MIN
GX2MXS=GX2MAX
IY1MNS=IY1MIN
IY1MXS=IY1MAX
IY2MNS=IY2MIN
IY2MXS=IY2MAX
IX1MNS=IX1MIN
IX1MXS=IX1MAX
IX2MNS=IX2MIN
IX2MXS=IX2MAX
IX1FSV=IX1FSW
IX2FSV=IX2FSW
IY1FSV=IY1FSW
IY2FSV=IY2FSW
PX1ZD2=PX1ZDS
PX2ZD2=PX2ZDS
PY1ZD2=PY1ZDS
PY2ZD2=PY2ZDS
DO1495I=1,100
ICHAP2(I)=ICHAPA(I)
ILINP2(I)=ILINPA(I)
ISPIS2(I)=ISPISW(I)
IBARS2(I)=ISPISW(I)
1495 CONTINUE
C
DO1500I=1,MAXCH
IX1LT2(I)=IX1LTE(I)
IX2LT2(I)=IX2LTE(I)
IY1LT2(I)=IY1LTE(I)
IY2LT2(I)=IY2LTE(I)
1500 CONTINUE
NCX1L2=NCX1LA
NCX2L2=NCX2LA
NCY1L2=NCY1LA
NCY2L2=NCY2LA
C
IFPLL2=IFPLLA
IFPLTZ=IFPLTA
IFPLFZ=IFPLFR
IFPLPZ=IFPLPT
IFPLLZ=IFPLLD
IFPLZT=IFPLST
IFPLZ2=IFPLS2
IFPLZ3=IFPLS3
IFPLZ4=IFPLS4
IFPLXZ=IFPLXA
IFPLYZ=IFPLYA
IFPLDZ=IFPLDI
IF(IFPLFR.EQ.'USER'.AND.IFPLLA.EQ.'BOX')IFPLLA='ON'
IF(IFPLFR.EQ.'CONN')IFPLFR='DEFA'
IF(IFPLLA.EQ.'BOX ')THEN
IFPLLD='ON'
IF(IFPLDI.EQ.'BLAN')IFPLDI='LINE'
ENDIF
C
IFEED9=IFEEDB
C
DO110I=1,MAXCH
ITITSV(I)=ITITTE(I)
110 CONTINUE
NCTITS=NCTITL
PTITDZ=PTITDS
C
DO1530I=1,NUMVAR
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
ICOLL(I)=IVALUE(ILOCV)
1530 CONTINUE
C
IOUNI5=IST5NU
IFILE5=IST5NA
ISTAT5=IST5ST
IFORM5=IST5FO
IACCE5=IST5AC
IPROT5=IST5PR
ICURS5=IST5CS
ISUBN0='SPMA'
IERRF5='NO'
C
IREWI5='ON'
CALL DPOPFI(IOUNI5,IFILE5,ISTAT5,IFORM5,IACCE5,IPROT5,ICURS5,
1IREWI5,ISUBN0,IERRF5,IBUGG3,ISUBRO,IERROR)
IF(IERRF5.EQ.'YES')IOUNI5=0
C
IMPSW3=IMPSW
IMPCO2=IMPCO
IMPNR2=IMPNR
IMPNC2=IMPNC
IMPSW='ON'
IMPCO=1
C
NPLOTS=NUMVAR-1
C
IF(IMPNR*IMPNC.LT.NPLOTS)THEN
IMPNC=INT(SQRT(REAL(NPLOTS-1)))+1
IMPNR=1
IF(NPLOTS.GE.11)THEN
IMPNR=INT(NPLOTS/IMPNC)+1
ELSEIF(NPLOTS.GE.7)THEN
IMPNR=3
ELSEIF(NPLOTS.GE.3)THEN
IMPNR=2
ENDIF
ENDIF
C
IROWT=IMPNR
ICOLT=IMPNC
IF(IFPLLA.EQ.'BOX')THEN
IMPNR=IMPNR+1
IMPNC=IMPNC+1
IROWT=IROWT+1
ICOLT=ICOLT+1
ENDIF
C
C *************************************
C ** STEP 21-- **
C ** GENERATE THE PLOTS **
C *************************************
C
2100 CONTINUE
ISTEPN='21'
IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'DPPRPL')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(ICASPL.EQ.'PREG')THEN
ICT='PART'
IC2T='IAL '
NCCOMM=2
IHT(1)='REGR'
IH2T(1)='ESSI'
IHT(2)='PLOT'
IH2T(2)=' '
IPLOTT='PREG'
ELSEIF(ICASPL.EQ.'PLEV')THEN
ICT='PART'
IC2T='IAL '
NCCOMM=2
IHT(1)='LEVE'
IH2T(1)='RAGE'
IHT(2)='PLOT'
IH2T(2)=' '
IPLOTT='PLEV'
ELSEIF(ICASPL.EQ.'PRES')THEN
ICT='PART'
IC2T='IAL '
NCCOMM=2
IHT(1)='RESI'
IH2T(1)='DUAL'
IHT(2)='PLOT'
IH2T(2)=' '
IPLOTT='PRES'
ELSEIF(ICASPL.EQ.'CCPR')THEN
ICT='CCPR'
IC2T=' '
NCCOMM=1
IHT(1)='PLOT'
IH2T(1)=' '
IPLOTT='CCPR'
ELSE
ICT='PART'
IC2T='IAL '
NCCOMM=2
IHT(1)='REGR'
IH2T(1)='ESSI'
IPLOTT='PREG'
ENDIF
GOTO5299
C
C **************************************************
C ** GENERATE ONE OF THE FOLLOWING COMMANDS **
C ** PARTIAL REGRESSION PLOT Y X1 X2 .... XI **
C ** PARTIAL RESIDUAL PLOT Y X1 X2 .... XI **
C ** PARTIAL LEVERAGE PLOT Y X1 X2 .... XI **
C ** WHERE XI IS THE SPECIFIC VARIABLE THE **
C ** PLOT IS BEING GENERATED FOR. **
C **************************************************
5299 CONTINUE
C
IF(NPLOTS.LT.1)GOTO8000
C
ISHIFT=NCCOMM
CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
1 IBUGG2,IERROR)
ICOM=ICT
ICOM2=IC2T
IF(NCCOMM.GT.0)THEN
DO5301II=1,NCCOMM
IHARG(II)=IHT(II)
IHARG2(II)=IH2T(II)
IARG(II)=0
ARG(II)=0.0
IARGT(II)='WORD'
5301 CONTINUE
ENDIF
IFRST=NCCOMM+2
NUMARG=NUMARG+1
IHARG(NUMARG)=' '
IHARG2(NUMARG)=' '
IARG(NUMARG)=0
ARG(NUMARG)=0.0
IARGT(NUMARG)=IARGT(IFRST)
NARGT=NUMARG
C
IPLOT=0
IF(IFPLLA.EQ.'BOX')THEN
NPLOTS=NPLOTS+IMPNR+IMPNC-1
ENDIF
DO5300IRES=1,IROWT
DO5400IFAC=1,ICOLT
C
IPLOT=IPLOT+1
IF(IPLOT.GT.NPLOTS)GOTO8000
IHARG(NUMARG)=IHARG(IFRST+IPLOT-1)
IHARG2(NUMARG)=IHARG2(IFRST+IPLOT-1)
IARG(NUMARG)=IARG(IFRST+IPLOT-1)
ARG(NUMARG)=ARG(IFRST+IPLOT-1)
IARGT(NUMARG)=IARGT(IFRST+IPLOT-1)
C
IXLIST=IFAC
IROW=INT(IPLOT/IMPNC)+1
IF(MOD(IPLOT,IMPNC).EQ.0)IROW=IROW-1
ICOL=MOD(IPLOT,IMPNC)
IF(ICOL.EQ.0)ICOL=IMPNC
C
IEMPTY='NO'
ITEMP=IFAC
IF(IFPLLA.EQ.'BOX')THEN
ICOL=ICOL-1
ITEMP=IFAC-1
IF(ITEMP.EQ.0)IEMPTY='YES'
IF(IROW.EQ.IMPNR)IEMPTY='YES'
ENDIF
C
IF(IEMPTY.EQ.'YES')THEN
DO5304I=1,MAXSUB
ISU2SW(I)=ISUBSW(I)
ISUBSW(I)='OFF'
5304 CONTINUE
ENDIF
IOPTN=3
IDX=1
IDY=1
ICASP2='FACT'
C
CCCCC NOTE: DPSPM4 IMPLEMENTS "SUB-REGIONS" ON PLOTS. THESE DON'T
CCCCC SEEM PARTICULARLY RELEVANT FOR THESE PLOTS, SO COMMENT
CCCCC OUT FOR NOW. HOWEVER, LEAVE IN CASE WE DECIDE LATER TO
CCCCC IMPLEMENT THEM.
C
CCCCC CALL DPSPM4(ICASP2,IOPTN,IDX,IDY,
CCCCC1 ISUBNU,ISUBSW,
CCCCC1 ASUBXL,ASUBXU,ASUBYL,ASUBYU,
CCCCC1 ISUBN9,ISUBSZ,
CCCCC1 ASBXL2,ASBXU2,ASBYL2,ASBYU2,
CCCCC1 PFPXSL,PFPXSU,PFPYSL,PFPYSU,
CCCCC1 IBUGG2,ISUBRO,IERROR)
C
ICASP2=ICASPL
IRES2=IRES
IXLST2=IXLIST+1
IX=IFAC+1
CALL DPSPM1(ICASP2,IVARN1,IVARN2,ICOLL,
1 IMPNR,IMPNC,IROW,ICOL,IRES2,IX,IPLOT,
1 NPLOTS,NUMVAR,
1 ICHAP2,ILINP2,
1 GY1MNS,GY1MXS,GY2MNS,GY2MXS,
1 GX1MNS,GX1MXS,GX2MNS,GX2MXS,
1 IY1MNS,IY1MXS,IY2MNS,IY2MXS,
1 IX1MNS,IX1MXS,IX2MNS,IX2MXS,
1 IX1TSV,IX2TSV,IY1TSV,IY2TSV,
1 IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
1 PX1LD2,PX2LD2,
1 IY1LJ2,IY1LD2,PY1LD2,PY1LA2,
1 IX1LT2,IX2LT2,IY1LT2,IY2LT2,
1 NCX1L2,NCX2L2,NCY1L2,NCY2L2,
1 PFPXLL,PFPXUL,PFPYLL,PFPYUL,IXLST2,
1 IFPLLA,IFPLLD,IPLOTT,IFPLFR,IFPLXA,IFPLYA,
1 IFPLDI,
1 IFPLTD,PFPLTD,IVNMEX,
1 IBUGG2,ISUBRO)
C
IF(IEMPTY.EQ.'YES')THEN
DO5306I=1,100
ICHAPA(I)='BLAN'
ILINPA(I)='BLAN'
ISPISW(I)='OFF'
IBARSW(I)='OFF'
5306 CONTINUE
ENDIF
C
CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL,
1 MAXNPP,ISEED,IBOOSS,
1 IX1TSV,IX2TSV,IY1TSV,IY2TSV,
1 IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
1 BARHEF,BARWEF,
1 IRHSTG,IHSTCW,
1 ICAPSW,IFORSW,
1 IAND1,IAND2,ICONT,NUMHPP,NUMVPP,
1 TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
1 ISUBRO,IFOUND,IERROR)
C
CCCCC NOTE: DPSPM3 SETS AN X2LABEL BASED ON CORRELATION, EFFECT
CCCCC SIZE, OR NUMBER OF REJECTIONS. THIS DOESN"T SEEM
CCCCC PARTICULARLY USEFUL FOR THESE PLOTS, SO COMMENT OUT
CCCCC FOR NOW. HOWEVER, LEAVE CODE HERE IN CASE WE DECIDE TO
CCCCC ACTIVATE LATER.
C
CCCCC IF(IEMPTY.EQ.'NO')THEN
CCCCC CALL DPSPM3(ICASPL,IOUNI5,
CCCCC1 IROW,ICOL,
CCCCC1 PX2LD2,NPLOTP,
CCCCC1 IFORSW,
CCCCC1 IFPX2L,ISPX2P,ISPX2S,
CCCCC1 IHRIGH,IHRIG2,IHWUSE,
CCCCC1 ISUBN1,ISUBN2,MESSAG,
CCCCC1 IBUGG2,ISUBRO,IERROR)
CCCCC ENDIF
C
ICONT=IDCONT(1)
NUMHPP=IDNHPP(1)
IMPARG=2
CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,NUMHPP,
1 XMATN,YMATN,XMITN,YMITN,
1 ISQUAR,
1 IVGMSW,IHGMSW,
1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,
1 IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,
1 YPLOT,XPLOT,X2PLOT,TAGPLO,
1 IMPSW,IMPNR,IMPNC,IMPCO,
1 IMPARG,
1 PMXMIN,PMXMAX,PMYMIN,PMYMAX,
1 MAXCOL,
1 DSIZE,DSYMB,DCOLOR,DFILL,
1 ICAPSW,
1 IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
1 IERROR)
IF(IERROR.EQ.'NO')IAND1=IAND2
IF(IERROR.EQ.'YES')GOTO5499
C
IF(IFPLFI.EQ.'NONE')GOTO5499
IF(IEMPTY.EQ.'YES')GOTO5499
C
IMPCO=IMPCO-1
IF(IMPCO.LE.1)IERASW='OFF'
C
CALL DPSPM2(ICASPL,IVARN1,IVARN2,ICOLL,NUMVAR,NPLOTP,
1 IRES,IX,ICHAP2,ILINP2,
1 TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
1 ALOWFR,ALOWDG,
1 IANGLU,MAXNPP,IAND1,IAND2,
1 IFPLFI,IFPLTA,
1 XMATN,YMATN,XMITN,YMITN,
1 ISQUAR,
1 IVGMSW,IHGMSW,
1 IMPSW,IMPNR,IMPNC,IMPCO,
1 IREPCH,
1 PMXMIN,PMXMAX,PMYMIN,PMYMAX,
1 IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,
1 IBUGUG,IBUGU2,IBUGU3,IBUGU4,
1 ISUBRO,IFOUND,IERROR)
IF(IERROR.EQ.'YES')GOTO5499
5499 CONTINUE
IERROR='NO'
C
ISHIFT=NCCOMM
CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
1 IBUGG2,IERROR)
ICOM=ICT
ICOM2=IC2T
IF(NCCOMM.GT.0)THEN
DO5491II=1,NCCOMM
IHARG(II)=IHT(II)
IHARG2(II)=IH2T(II)
IARG(II)=0
ARG(II)=0.0
IARGT(II)='WORD'
5491 CONTINUE
ENDIF
IFRST=NCCOMM+2
IHARG(NUMARG)=' '
IHARG2(NUMARG)=' '
IARG(NUMARG)=0
ARG(NUMARG)=0.0
IARGT(NUMARG)=IARGT(IFRST)
NARGT=NUMARG
C
5490 CONTINUE
PX1LDS=PX1LD2
GX1MIN=GX1MNS
GX1MAX=GX1MXS
GX2MIN=GX2MNS
GX2MAX=GX2MXS
GY1MIN=GY1MNS
GY1MAX=GY1MXS
GY2MIN=GY2MNS
GY2MAX=GY2MXS
IX1MIN=IX1MNS
IX1MAX=IX1MXS
IX2MIN=IX2MNS
IX2MAX=IX2MXS
IY1MIN=IY1MNS
IY1MAX=IY1MXS
IY2MIN=IY2MNS
IY2MAX=IY2MXS
PX1ZDS=PX1ZD2
PX2ZDS=PX2ZD2
PY1ZDS=PY1ZD2
PY2ZDS=PY2ZD2
IF(IEMPTY.EQ.'YES')THEN
DO5407I=1,MAXSUB
ISUBSW(I)=ISU2SW(I)
5407 CONTINUE
ENDIF
DO5408I=1,100
ICHAPA(I)=ICHAP2(I)
ILINPA(I)=ILINP2(I)
ISPISW(I)=ISPIS2(I)
IBARSW(I)=IBARS2(I)
5408 CONTINUE
IF(IERROR.EQ.'YES')GOTO5400
C
5400 CONTINUE
5300 CONTINUE
GOTO8000
C
C
C **************************************************
C ** STEP 28-- **
C ** REINSTATE INITIAL SETTINGS **
C **************************************************
C
8000 CONTINUE
2800 CONTINUE
ISTEPN='28'
IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'4PLO')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
IF(IBUGG3.EQ.'ON')WRITE(ICOUT,8807)IMANUF,NUMDEV,IDMANU(1)
8807 FORMAT('IMANUF,NUMDEV,IDMANU(1) = ',A4,I8,2X,A4)
IF(IBUGG3.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
PWXMIN=PWXMN2
PWXMAX=PWXMX2
PWYMIN=PWYMN2
PWYMAX=PWYMX2
PXMIN=PXMN2
PXMAX=PXMX2
PYMIN=PYMN2
PYMAX=PYMX2
GX1MIN=GX1MNS
GX1MAX=GX1MXS
GX2MIN=GX2MNS
GX2MAX=GX2MXS
GY1MIN=GY1MNS
GY1MAX=GY1MXS
GY2MIN=GY2MNS
GY2MAX=GY2MXS
IX1MIN=IX1MNS
IX1MAX=IX1MXS
IX2MIN=IX2MNS
IX2MAX=IX2MXS
IY1MIN=IY1MNS
IY1MAX=IY1MXS
IY2MIN=IY2MNS
IY2MAX=IY2MXS
IX1TSW=IX1TSV
IX2TSW=IX2TSV
IY1TSW=IY1TSV
IY2TSW=IY2TSV
IX1ZSW=IX1ZSV
IX2ZSW=IX2ZSV
IY1ZSW=IY1ZSV
IY2ZSW=IY2ZSV
PX1LDS=PX1LD2
PX2LDS=PX2LD2
PY1LDS=PY1LD2
PY1LAN=PY1LA2
IY1LJU=IY1LJ2
IY1LDI=IY1LD2
PX1ZDS=PX1ZD2
PX2ZDS=PX2ZD2
PY1ZDS=PY1ZD2
PY2ZDS=PY2ZD2
C
DO8820I=1,100
ICHAPA(I)=ICHAP2(I)
ILINPA(I)=ILINP2(I)
ISPISW(I)=ISPIS2(I)
IBARSW(I)=IBARS2(I)
8820 CONTINUE
C
IMPSW='OFF'
IMPCO=1
IMPNR=IMPNR2
IMPNC=IMPNC2
C
IERASW='ON'
IFENSW=IFENC2
ISORSW=ISORS2
IPPTBI=IPPTB2
C
DO8500I=1,MAXCH
IX1LTE(I)=IX1LT2(I)
IX2LTE(I)=IX2LT2(I)
IY1LTE(I)=IY1LT2(I)
IY2LTE(I)=IY2LT2(I)
8500 CONTINUE
NCX1LA=NCX1L2
NCX2LA=NCX2L2
NCY1LA=NCY1L2
NCY2LA=NCY2L2
C
IFPLLA=IFPLL2
IFPLTA=IFPLTZ
IFPLFR=IFPLFZ
IFPLPT=IFPLPZ
IFPLLD=IFPLLZ
IFPLXA=IFPLXZ
IFPLYA=IFPLYZ
IFPLDI=IFPLDZ
IFPLST=IFPLZT
IFPLS2=IFPLZ2
IFPLS3=IFPLZ3
IFPLS4=IFPLZ4
C
IFEEDB=IFEED9
C
DO8809I=1,MAXCH
ITITTE(I)=ITITSV(I)
8809 CONTINUE
NCTITL=NCTITS
C
IENDF5='OFF'
IREWI5='ON'
IF(IOUNI5.GT.0)
1CALL DPCLFI(IOUNI5,IFILE5,ISTAT5,IFORM5,IACCE5,IPROT5,ICURS5,
1IENDF5,IREWI5,ISUBN0,IERRF5,IBUGG3,ISUBRO,IERROR)
IF(IERRF5.EQ.'YES')GOTO9000
C
PTITDS=PTITDZ
IF(IERROR.EQ.'YES')GOTO9000
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 DPPRPL--')
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)NUMARG
9014 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NUMARG.LE.0)GOTO9029
DO9021I=1,NUMARG
WRITE(ICOUT,9022)I,IHARG(I),IARGT(I)
9022 FORMAT('I,IHARG(I),IARGT(I) = ',I8,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
9021 CONTINUE
9029 CONTINUE
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPPRPO(ICOM,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
1IPPDE1,IPPDE2,
1IBUGS2,ISUBRO,IFOUND,IERROR)
C
C PURPOSE--DEFINE PREPLOT/POSTPLOT DEVICE
C THAT IS, THE CURRENT DEVICE IN WHICH
C THE USER WANTS A USER-SPECIFIED
C PREPLOT LINE TO BE WRITTEN OUT,
C AND A USER-DEFINED POSTPLOT LINE
C TO BE WRITTEN OUT.
C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR)
C --NUMARG (AN INTEGER VARIABLE)
C OUTPUT ARGUMENTS--IPPDE1 (A HOLLERITH VARIABLE)
C IPPDE2 (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--86/9
C ORIGINAL VERSION--OCTOBER 1986.
C UPDATED --FEBRUARY 1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 ICOM
CHARACTER*4 IHARG
CHARACTER*4 IHARG2
CCCCC CHARACTER*4 IARG JULY 1987
CCCCC CHARACTER*4 ARG JULY 1987
CHARACTER*4 IARGT
C
CHARACTER*4 IPPDE1
CHARACTER*4 IPPDE2
CHARACTER*4 IBUGS2
CHARACTER*4 ISUBRO
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 IHOLD1
CHARACTER*4 IHOLD2
C
CHARACTER*4 IHARG1
C
C---------------------------------------------------------------------
C
DIMENSION IHARG(*)
DIMENSION IHARG2(*)
DIMENSION IARG(*)
DIMENSION ARG(*)
DIMENSION IARGT(*)
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
IHARG1=IHARG(1)
C
IF(ICOM.EQ.'PRE')GOTO1109
IF(ICOM.EQ.'PREP')GOTO1109
IF(ICOM.EQ.'POST')GOTO1109
ISHIFT=1
CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
1IBUGS2,IERROR)
1109 CONTINUE
C
1110 CONTINUE
IF(NUMARG.LE.0)GOTO1120
C
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(NUMARG.EQ.1.AND.IHARG(1).EQ.'POST')GOTO1120
IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'DEVI')GOTO1120
IF(NUMARG.EQ.1)GOTO1130
C
IF(NUMARG.EQ.2.AND.IHARG(1).EQ.'POST'
1 .AND.IHARG(2).EQ.'DEVI')GOTO1120
IF(NUMARG.EQ.2.AND.IHARG(1).EQ.'POST'
1 .AND.IHARG(2).NE.'DEVI')GOTO1130
IF(NUMARG.EQ.2.AND.IHARG(1).EQ.'DEVI')GOTO1130
C
IF(NUMARG.EQ.3.AND.IHARG(1).EQ.'POST'
1 .AND.IHARG(2).EQ.'DEVI')GOTO1130
IF(NUMARG.EQ.3.AND.IHARG(1).EQ.'POST'
1 .AND.IHARG(2).NE.'DEVI')GOTO1140
IF(NUMARG.EQ.3.AND.IHARG(1).EQ.'DEVI')GOTO1140
C
GOTO1140
C
1120 CONTINUE
IHOLD1='NONE'
IHOLD2=' '
GOTO1180
C
1130 CONTINUE
IHOLD1=IHARG(NUMARG)
IHOLD2=' '
GOTO1180
C
1140 CONTINUE
NUMAM1=NUMARG-1
IHOLD1=IHARG(NUMAM1)
IHOLD2=IHARG(NUMARG)
GOTO1180
C
1180 CONTINUE
IPPDE1=IHOLD1
IPPDE2=IHOLD2
C
IF(IFEEDB.EQ.'OFF')GOTO1189
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1188)IPPDE1,IPPDE2
1188 FORMAT('THE PREPLOT/POSTPLOT DEVICE HAS JUST BEEN SET TO ',
1A4,2X,A4)
CALL DPWRST('XXX','BUG ')
1189 CONTINUE
GOTO1199
C
1199 CONTINUE
RETURN
END
SUBROUTINE DPPRSW(IHARG,NUMARG,
1IPRIN2,IFOUND,IERROR)
C
C PURPOSE--SPECIFY THE PRINTING SWITCH WHICH IN TURN
C DETERMINES WHETHER ANY SUBSEQUENT NON-GRAPHICAL OUTPUT
C WILL BE PRINTED OR NOT.
C THIS CAPABILITY IS USEFUL IF ONE WISHES TO SUPPRESS
C OUTPUT FROM ALL PRELIMINARY AND INTERMEDIATE
C CALCULATIONS AND JUST HAVE THE FINAL PLOTS THEMSELVES
C APPEAR ON THE SCREEN.
C THE SPECIFIED PRINTING SWITCH SPECIFICATION
C WILL BE PLACED IN THE HOLLERITH VARIABLE IPRIN2.
C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR)
C --NUMARG (AN INTEGER VARIABLE)
C OUTPUT ARGUMENTS--IPRIN2 (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 --FEBRUARY 1982.
C UPDATED --MAY 1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IHARG
CHARACTER*4 IPRIN2
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')GOTO1160
IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
GOTO1199
C
1150 CONTINUE
IHOLD='ON'
GOTO1180
C
1160 CONTINUE
IHOLD='OFF'
GOTO1180
C
1180 CONTINUE
IFOUND='YES'
IPRIN2=IHOLD
IPRINT=IPRIN2
C
IF(IFEEDB.EQ.'OFF')GOTO1189
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1181)IPRIN2
1181 FORMAT('THE PRINTING SWITCH HAS JUST BEEN SET TO ',
1A4)
CALL DPWRST('XXX','BUG ')
1189 CONTINUE
GOTO1199
C
1199 CONTINUE
RETURN
END
SUBROUTINE DPPYRA(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 PYRAMIDS
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 VERTICES
C OF THE FRONT FACE OF THE PYRAMID.
C NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 3
C AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*3 = 6.
C NOTE--IF 4 NUMBERS ARE PROVIDED,
C THEN THE DRAWN PYRAMID WILL GO
C FROM THE LAST CURSOR POSITION
C (ASSUMED TO BE AT VERTEX 1)
C THROUGH THE (X,Y) POINT
C (EITHER ABSOLUTE OR RELATIVE)
C AS DEFINED BY THE FIRST AND SECOND NUMBERS
C (ASSUMED TO BE AT VERTEX 2)
C TO THE (X,Y) POINT
C (EITHER ABSOLUTE OR RELATIVE)
C AS DEFINED BY THE THIRD AND FOURTH NUMBERS
C (ASSUMED TO BE AT VERTEX 3)
C AND CONTINUING BACK THE START POINT TO CLOSE THE PYRAMID.
C NOTE--IF 6 NUMBERS ARE PROVIDED,
C THEN THE DRAWN PYRAMID WILL GO
C FROM THE ABSOLUTE (X,Y) POSITION
C AS RESULTING FORM THE FIRST AND SECOND NUMBERS
C (ASSUMED TO BE AT VERTEX 1)
C THROUGH THE (X,Y) POINT
C (EITHER ABSOLUTE OR RELATIVE)
C AS DEFINED BY THE THIRD AND FOURTH NUMBERS
C (ASSUMED TO BE AT VERTEX 2)
C TO THE (X,Y) POINT
C (EITHER ABSOLUTE OR RELATIVE)
C AS DEFINED BY THE FIFTH AND SIXTH NUMBERS
C (ASSUMED TO BE AT VERTEX 3)
C AND THEN CONTINUING BACK THE START POINT TO CLOSE THE PYRAMID.
C NOTE--AND SO FORTH FOR 10, 14, 18, ... 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--87/5
C ORIGINAL VERSION--APRIL 1987.
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.'PYRA')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPPYRA--')
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='PYRA'
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)
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 DPPYRA--')
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 PYRAMID WITH ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1136)
1136 FORMAT(' FRONT FACE VERTICES (20,20), (50,20), (35,40)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1141)
1141 FORMAT(' THEN ALLOWABLE FORMS ARE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1142)
1142 FORMAT(' PYRAMID 20 20 50 20 35 40')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1143)
1143 FORMAT(' PYRAMID ABSOLUTE 20 20 50 20 35 40')
CALL DPWRST('XXX','BUG ')
GOTO9000
1149 CONTINUE
C
C ****************************
C ** STEP 3-- **
C ** DRAW OUT THE LINE(S) **
C ****************************
C
NUMNUM=NUMARG-ILOCFN+1
IF(NUMNUM.LT.NUMPT2)GOTO1151
GOTO1152
C
1151 CONTINUE
J=ILOCFN-1
X1=PXSTAR
Y1=PYSTAR
GOTO1159
C
1152 CONTINUE
J=ILOCFN
IF(J.GT.NUMARG)GOTO1190
X1=ARG(J)
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,IBUGD2,ISUBRO,IERROR)
J=J+1
IF(J.GT.NUMARG)GOTO1190
Y1=ARG(J)
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBRO,IERROR)
GOTO1159
1159 CONTINUE
C
1160 CONTINUE
J=J+1
IF(J.GT.NUMARG)GOTO1190
X2=ARG(J)
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR)
IF(ITYPEO.EQ.'RELA')X2=X1+X2
J=J+1
IF(J.GT.NUMARG)GOTO1190
Y2=ARG(J)
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR)
IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2
C
1170 CONTINUE
J=J+1
IF(J.GT.NUMARG)GOTO1190
X3=ARG(J)
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X3,X3,IBUGD2,ISUBRO,IERROR)
IF(ITYPEO.EQ.'RELA')X3=X2+X3
J=J+1
IF(J.GT.NUMARG)GOTO1190
Y3=ARG(J)
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y3,Y3,IBUGD2,ISUBRO,IERROR)
IF(ITYPEO.EQ.'RELA')Y3=Y2+Y3
C
CALL DPPYR2(X1,Y1,X2,Y2,X3,Y3,
1IFIG,
1ILINPA,ILINCO,PLINTH,
1AREGBA,
1IREBLI,IREBCO,PREBTH,
1IREFSW,IREFCO,
1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
1PTEXHE,PTEXWI,PTEXVG,PTEXHG)
C
X1=X3
Y1=Y3
C
GOTO1160
1190 CONTINUE
C
PXEND=X3
PYEND=Y3
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.'PYRA')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPPYRA--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)ILOCFN,NUMNUM
9012 FORMAT('ILOCFN,NUMNUM = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)X1,Y1,X2,Y2,X3,Y3
9013 FORMAT('X1,Y1,X2,Y2,X3,Y3 = ',6E15.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 DPPYR2(X1,Y1,X2,Y2,X3,Y3,
1IFIG,
1ILINPA,ILINCO,PLINTH,
1AREGBA,
1IREBLI,IREBCO,PREBTH,
1IREFSW,IREFCO,
1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
1PTEXHE,PTEXWI,PTEXVG,PTEXHG)
C
C PURPOSE--DRAW A PYRAMID
C WITH FRONT FACE VERTICES AT (X1,Y1),
C (X2,Y2), AND (X3,Y3).
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--87/5
C ORIGINAL VERSION--APRIL 1987.
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.'PYR2')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPPYR2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)X1,Y1
53 FORMAT('X1,Y1 = ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)X2,Y2
54 FORMAT('X2,Y2 = ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,59)IFIG
59 FORMAT('IFIG = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,62)AREGBA(1)
62 FORMAT('AREGBA(1) = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
1A4,2X,A4,2X,A4,2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,69)PTEXHE,PTEXWI
69 FORMAT('PTEXHE,PTEXWI= ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,70)PTEXVG,PTEXHG
70 FORMAT('PTEXVG,PTEXHG= ',2E15.6)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4
79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C *********************************
C ** STEP 1-- **
C ** SET THE SPECS **
C ** WHICH CONTROL THE **
C ** APPEARANCE OF THE **
C ** RESULTING CUBE. **
C *********************************
C
DELX21=ABS(X2-X1)
DELY32=ABS(Y3-Y2)
C
P3DX=0.1
P3DY=0.3
C
C *************************
C ** STEP 2-- **
C ** FILL THE FIGURE **
C ** (IF CALLED FOR) **
C *************************
C
IF(IREFSW(1).EQ.'OFF')GOTO2190
C
IPATT=IREPTY(1)
PTHICK=PREPTH(1)
PXGAP=PREPSP(1)
PYGAP=PREPSP(1)
ICOLF=IREFCO(1)
ICOLP=IREPCO(1)
C
IF(IREFSW(1).EQ.'ON')GOTO2110
IF(IREFSW(1).EQ.'ONF')GOTO2110
IF(IREFSW(1).EQ.'ONS')GOTO2120
IF(IREFSW(1).EQ.'ONFS')GOTO2110
IF(IREFSW(1).EQ.'ONSF')GOTO2110
C
C ********************************
C ** STEP 2.1-- **
C ** FRONT FACE ONLY **
C ********************************
C
2110 CONTINUE
PX(1)=X1
PY(1)=Y1
C
PX(2)=X2
PY(2)=Y2
C
PX(3)=X3
PY(3)=Y3
C
PX(4)=X1
PY(4)=Y1
C
NP=4
C
IPATT2='SOLI'
CALL DPFIRE(PX,PY,NP,
1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2)
C
IF(IREFSW(1).EQ.'ON')GOTO2120
IF(IREFSW(1).EQ.'ONF')GOTO2190
IF(IREFSW(1).EQ.'ONS')GOTO2120
IF(IREFSW(1).EQ.'ONFS')GOTO2120
IF(IREFSW(1).EQ.'ONSF')GOTO2120
C
C ********************************
C ** STEP 2.2-- **
C ** SIDE (= RIGHT) FACE ONLY **
C ********************************
C
2120 CONTINUE
PX(1)=X3
PY(1)=Y3
C
PX(2)=X2-P3DX*DELX21
PY(2)=Y2+P3DY*DELY32
C
PX(3)=X2
PY(3)=Y2
C
PX(4)=X3
PY(4)=Y3
C
NP=4
C
IPATT2='SOLI'
CALL DPFIRE(PX,PY,NP,
1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2)
C
GOTO2190
C
2190 CONTINUE
C
C ***************************
C ** STEP 3-- **
C ** DRAW OUT THE FIGURE **
C ***************************
C
IPATT=ILINPA(1)
PTHICK=PLINTH(1)
ICOL=ILINCO(1)
C
PX(1)=X1
PY(1)=Y1
C
PX(2)=X2
PY(2)=Y2
C
PX(3)=X3
PY(3)=Y3
C
PX(4)=X1
PY(4)=Y1
C
NP=4
C
IFLAG='ON'
CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3,
CCCCC1IFIG,IPATT,PTHICK,ICOL)
CALL DPDRPL(PX,PY,NP,
1IFIG,IPATT,PTHICK,ICOL,
1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
C
PX(1)=X3
PY(1)=Y3
C
PX(2)=X2-0.1*DELX21
PY(2)=Y2+0.3*DELY32
C
PX(3)=X2
PY(3)=Y2
C
NP=3
C
IFLAG='ON'
CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3,
CCCCC1IFIG,IPATT,PTHICK,ICOL)
CALL DPDRPL(PX,PY,NP,
1IFIG,IPATT,PTHICK,ICOL,
1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'PYR2')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPPYR2--')
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,9021)IREFSW(1),IREFCO(1)
9021 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9022)DELX21,DELY32,P3DX,P3DY
9022 FORMAT('DELX21,DELY32,P3DX,P3DY = ',4E15.7)
CALL DPWRST('XXX','BUG ')
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 DPQCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
C
C PURPOSE--GENERATE ONE OF THE FOLLOWING Q (= QUESENBERRY)
C CONTROL CHARTS--
C 1) Q MEAN
C 2) Q RANGE
C 3) Q STANDARD DEVIATION
C 4) Q CUSUM
C 5) Q P
C 6) Q PN
C 7) Q C
C 8) Q U
C REFERENCE--QUESENBERRY, CHARLES P. SPC Q CHARTS FOR START-UP
C PROCESSES AND SHORT OR LONG RUNS.
C JOURNAL OF QUALITY TECNOLOGY, JULY 1991,
C PAGES 213-224.
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--93/12
C ORIGINAL VERSION--DECEMBER 1993.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 ICASPL
CHARACTER*4 IAND1
CHARACTER*4 IAND2
CHARACTER*4 ICONT
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 IH
CHARACTER*4 IH2
CHARACTER*4 IERRO2
CHARACTER*4 IHLEFT
CHARACTER*4 IHLEF2
CHARACTER*4 IHHOR
CHARACTER*4 IHHOR2
C
CHARACTER*4 IHEXT
CHARACTER*4 IHEXT2
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
INCLUDE 'DPCOPA.INC'
C
DIMENSION Y1(MAXOBV)
DIMENSION Y2(MAXOBV)
DIMENSION X1(MAXOBV)
C
DIMENSION XIDTEM(MAXOBV)
DIMENSION TEMP(MAXOBV)
DIMENSION TEMP2(MAXOBV)
INCLUDE 'DPCOZZ.INC'
EQUIVALENCE (GARBAG(IGARB1),X1(1))
EQUIVALENCE (GARBAG(IGARB2),Y1(1))
EQUIVALENCE (GARBAG(IGARB3),Y2(1))
EQUIVALENCE (GARBAG(IGARB4),XIDTEM(1))
EQUIVALENCE (GARBAG(IGARB5),TEMP(1))
EQUIVALENCE (GARBAG(IGARB6),TEMP2(1))
C
C-----COMMON----------------------------------------------------------
C
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='DPQC'
ISUBN2='C '
C
MAXCP1=MAXCOL+1
MAXCP2=MAXCOL+2
MAXCP3=MAXCOL+3
MAXCP4=MAXCOL+4
MAXCP5=MAXCOL+5
MAXCP6=MAXCOL+6
C
MAXV2=2
MINN2=2
C
ICOLH=0
C
C **************************************
C ** TREAT THE Q CONTROL CHART CASE **
C **************************************
C
IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PQCC')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPQCC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)ICASPL,IAND1,IAND2
52 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)ICONT,IBUGG2,IBUGG3,IBUGQ
53 FORMAT('ICONT,IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)ISUBRO
54 FORMAT('ISUBRO = ',A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C ***************************
C ** STEP 1-- **
C ** EXTRACT THE COMMAND **
C ***************************
C
ISTEPN='1'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ICOM=IHARG(1)
ICOM2=IHARG2(1)
ISHIFT=1
CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
1IBUGG2,IERROR)
C
C ***************************************
C ** STEP 1.1-- **
C ** SEARCH FOR Q MEAN CONTROL CHART **
C ***************************************
C
ICASPL='MECC'
C
IF(NUMARG.GE.3.AND.
1ICOM.EQ.'X'.AND.IHARG(1).EQ.'BAR'.AND.IHARG(2).EQ.'CONT'.AND.
1IHARG(3).EQ.'CHAR')GOTO113
IF(NUMARG.GE.2.AND.
1ICOM.EQ.'XBAR'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR')
1GOTO112
IF(NUMARG.GE.2.AND.
1ICOM.EQ.'MEAN'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR')
1GOTO112
IF(NUMARG.GE.2.AND.
1ICOM.EQ.'AVER'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR')
1GOTO112
IF(NUMARG.GE.1.AND.
1ICOM.EQ.'CONT'.AND.IHARG(1).EQ.'CHAR')
1GOTO111
IF(NUMARG.GE.1.AND.
1ICOM.EQ.'MEAN'.AND.IHARG(1).EQ.'CHAR')
1GOTO111
IF(NUMARG.GE.1.AND.
1ICOM.EQ.'XBAR'.AND.IHARG(1).EQ.'CHAR')
1GOTO111
IF(NUMARG.GE.1.AND.
1ICOM.EQ.'AVER'.AND.IHARG(1).EQ.'CHAR')
1GOTO111
C
C ************************************************
C ** STEP 1.2-- **
C ** SEARCH FOR Q STANDARD DEV. CONTROL CHART **
C ************************************************
C
ICASPL='SDCC'
C
IF(NUMARG.GE.3.AND.
1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'DEVI'.AND.IHARG(2).EQ.'CONT'.AND.
1IHARG(3).EQ.'CHAR')GOTO113
IF(NUMARG.GE.2.AND.
1ICOM.EQ.'SD'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR')
1GOTO112
IF(NUMARG.GE.2.AND.
1ICOM.EQ.'S'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR')
1GOTO112
IF(NUMARG.GE.1.AND.
1ICOM.EQ.'SD'.AND.IHARG(1).EQ.'CHAR')
1GOTO111
IF(NUMARG.GE.1.AND.
1ICOM.EQ.'S'.AND.IHARG(1).EQ.'CHAR')
1GOTO111
C
C ****************************************
C ** STEP 1.3-- **
C ** SEARCH FOR Q RANGE CONTROL CHART **
C ****************************************
C
ICASPL='RACC'
C
IF(NUMARG.GE.2.AND.
1ICOM.EQ.'RANG'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR')
1GOTO112
IF(NUMARG.GE.2.AND.
1ICOM.EQ.'R'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR')
1GOTO112
IF(NUMARG.GE.1.AND.
1ICOM.EQ.'RANG'.AND.IHARG(1).EQ.'CHAR')
1GOTO111
IF(NUMARG.GE.1.AND.
1ICOM.EQ.'R'.AND.IHARG(1).EQ.'CHAR')
1GOTO111
C
C ****************************************
C ** STEP 1.4-- **
C ** SEARCH FOR Q CUSUM CONTROL CHART **
C ****************************************
C
ICASPL='CUCC'
C
IF(NUMARG.GE.3.AND.
1ICOM.EQ.'CUMU'.AND.IHARG(1).EQ.'SUM'.AND.IHARG(2).EQ.'CONT'.AND.
1IHARG(3).EQ.'CHAR')GOTO113
IF(NUMARG.GE.2.AND.
1ICOM.EQ.'CUSU'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR')
1GOTO112
C
C ****************************************
C ** STEP 1.5-- **
C ** SEARCH FOR Q P CONTROL CHART **
C ****************************************
C
ICASPL='PCC'
C
IF(NUMARG.GE.2.AND.
1ICOM.EQ.'P'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR')
1GOTO112
IF(NUMARG.GE.1.AND.
1ICOM.EQ.'P'.AND.IHARG(1).EQ.'CHAR')
1GOTO111
C
C ****************************************
C ** STEP 1.6-- **
C ** SEARCH FOR Q PN CONTROL CHART **
C ****************************************
C
ICASPL='PNCC'
C
IF(NUMARG.GE.2.AND.
1ICOM.EQ.'PN'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR')
1GOTO112
IF(NUMARG.GE.1.AND.
1ICOM.EQ.'PN'.AND.IHARG(1).EQ.'CHAR')
1GOTO111
IF(NUMARG.GE.2.AND.
1ICOM.EQ.'NP'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR')
1GOTO112
IF(NUMARG.GE.1.AND.
1ICOM.EQ.'NP'.AND.IHARG(1).EQ.'CHAR')
1GOTO111
C
C ****************************************
C ** STEP 1.7-- **
C ** SEARCH FOR Q C CONTROL CHART **
C ****************************************
C
ICASPL='CCC'
C
IF(NUMARG.GE.2.AND.
1ICOM.EQ.'C'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR')
1GOTO112
IF(NUMARG.GE.1.AND.
1ICOM.EQ.'C'.AND.IHARG(1).EQ.'CHAR')
1GOTO111
C
C ****************************************
C ** STEP 1.8-- **
C ** SEARCH FOR Q U CONTROL CHART **
C ****************************************
C
ICASPL='UCC'
C
IF(NUMARG.GE.2.AND.
1ICOM.EQ.'U'.AND.IHARG(1).EQ.'CONT'.AND.IHARG(2).EQ.'CHAR')
1GOTO112
IF(NUMARG.GE.1.AND.
1ICOM.EQ.'U'.AND.IHARG(1).EQ.'CHAR')
1GOTO111
C
ICASPL=' '
C
IFOUND='NO'
GOTO9000
C
111 CONTINUE
ILASTC=1
CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
GOTO180
C
112 CONTINUE
ILASTC=2
CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
GOTO180
C
113 CONTINUE
ILASTC=3
CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
GOTO180
C
180 CONTINUE
IFOUND='YES'
GOTO190
C
190 CONTINUE
C
C ***********************************************************
C ** STEP 1-- **
C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. **
C ***********************************************************
C
ISTEPN='1'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC')
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-- **
C ** CHECK THE VALIDITY OF ARGUMENT 1 **
C ** (THIS WILL BE THE RESPONSE VARIABLE) **
C ********************************************
C
ISTEPN='2'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC')
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.'PQCC')THEN
WRITE(ICOUT,211)IHLEFT,ICOLL,NLEFT
211 FORMAT('IHLEFT,ICOLL,NLEFT = ',A4,I8,I8)
CALL DPWRST('XXX','BUG ')
ENDIF
C
C ***************************************************************
C ** STEP 3-- **
C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) **
C ** FOR THE RESPONSE VARIABLE IS 2 OR LARGER. **
C ***************************************************************
C
ISTEPN='3'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(NLEFT.GE.MINN2)GOTO390
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,311)
311 FORMAT('***** ERROR IN DPQCC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,312)
312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS')
CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'MECC')WRITE(ICOUT,321)
321 FORMAT(' (FOR WHICH A Q MEAN CONTROL CHART ')
IF(ICASPL.EQ.'MECC')CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'SDCC')WRITE(ICOUT,322)
322 FORMAT(' (FOR WHICH A Q STANDARD DEVIATION CONTROL CHART ')
IF(ICASPL.EQ.'SDCC')CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'RACC')WRITE(ICOUT,323)
323 FORMAT(' (FOR WHICH A Q RANGE CONTROL CHART ')
IF(ICASPL.EQ.'RACC')CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'CUCC')WRITE(ICOUT,324)
324 FORMAT(' (FOR WHICH A Q CUSUM CONTROL CHART ')
IF(ICASPL.EQ.'CUCC')CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'PCC')WRITE(ICOUT,325)
325 FORMAT(' (FOR WHICH A Q P CONTROL CHART ')
IF(ICASPL.EQ.'PCC')CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'PNCC')WRITE(ICOUT,326)
326 FORMAT(' (FOR WHICH A Q NP CONTROL CHART ')
IF(ICASPL.EQ.'PNCC')CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'CCC')WRITE(ICOUT,327)
327 FORMAT(' (FOR WHICH A Q C CONTROL CHART ')
IF(ICASPL.EQ.'CCC')CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'UCC')WRITE(ICOUT,328)
328 FORMAT(' (FOR WHICH A Q U CONTROL CHART ')
IF(ICASPL.EQ.'UCC')CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,334)
334 FORMAT(' WAS TO HAVE BEEN FORMED)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,335)MINN2
335 FORMAT(' MUST BE ',I8,' OR LARGER;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,336)
336 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,337)
337 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,338)(IANS(I),I=1,IWIDTH)
338 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
390 CONTINUE
C
C *****************************************
C ** STEP 4-- **
C ** CHECK TO SEE THE TYPE SUBCASE **
C ** (BASED ON THE QUALIFIER)-- **
C ** 1) UNQUALIFIED (THAT IS, FULL); **
C ** 2) SUBSET/EXCEPT; OR **
C ** 3) FOR. **
C *****************************************
C
ISTEPN='4'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ICASEQ='FULL'
ILOCQ=NUMARG+1
IF(NUMARG.LT.1)GOTO480
DO400J=1,NUMARG
J1=J
IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO410
IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO410
IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO420
400 CONTINUE
GOTO490
410 CONTINUE
ICASEQ='SUBS'
ILOCQ=J1
GOTO490
420 CONTINUE
ICASEQ='FOR'
ILOCQ=J1
GOTO490
C
480 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,481)
481 FORMAT('***** INTERNAL ERROR IN DPQCC')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,482)
482 FORMAT(' AT BRANCH POINT 481--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,483)
483 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,484)
484 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,485)NUMARG
485 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,486)
486 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,487)(IANS(I),I=1,IWIDTH)
487 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
490 CONTINUE
IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'PQCC')GOTO495
WRITE(ICOUT,491)NUMARG,ILOCQ,ICASEQ
491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4)
CALL DPWRST('XXX','BUG ')
495 CONTINUE
C
C ************************************************************
C ** STEP 5-- **
C ** IF A SECOND ARGUMENT EXISTS, THEN THIS **
C ** INDICATES THAT THE VALUES IN THE **
C ** FIRST VARIABLE ARE TO BE GROUPED **
C ** BASED ON VALUES OF THE SECOND VARIABLE; **
C ** THAT IS, THE SECOND VARAIBLE DEFINES THE **
C ** GROUP NUMBERS WITHIN WHICH THE MEANS, **
C ** STANDARD DEVIATIONS, RANGES, AND **
C ** CUMULATIVE SUMS ARE TO BE COMPUTED. **
C ** THE VALUES IN THE SECOND VARIABLE **
C ** ARE THE X VALUES FOR EACH MEAN, STANDARD DEVIATION, **
C ** ETC. IN THE RESULTING Q CONTROL CHART. **
C ** THE VALUES IN THE SECOND VARIABLE **
C ** NEED NOT HAVE BEEN PREVIOUSLY **
C ** SORTED OR HAVE COMMON VALUES ADJACENT. **
C ** IF WE HAVE THE 2-VARIABLE CASE, **
C ** CHECK THE VALIDITY OF THE SECOND (X) VARIABLE. **
C ************************************************************
C
ISTEPN='5'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
NUMV2=ILOCQ-1
IF(NUMV2.EQ.1)GOTO599
IF(NUMV2.EQ.2)GOTO530
IF(NUMV2.EQ.3)GOTO540
GOTO510
C
510 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,511)
511 FORMAT('***** ERROR IN DPQCC--')
CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'MECC')WRITE(ICOUT,512)
512 FORMAT(' FOR A Q MEAN CONTROL CHART, ')
IF(ICASPL.EQ.'MECC')CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'SDCC')WRITE(ICOUT,513)
513 FORMAT(' FOR A Q STANDARD DEVIATION CONTROL CHART, ')
IF(ICASPL.EQ.'SDCC')CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'RACC')WRITE(ICOUT,514)
514 FORMAT(' FOR A Q RANGE CONTROL CHART, ')
IF(ICASPL.EQ.'RACC')CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'CUCC')WRITE(ICOUT,515)
515 FORMAT(' FOR A Q CUSUM CONTROL CHART, ')
IF(ICASPL.EQ.'CUCC')CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'PCC')WRITE(ICOUT,516)
516 FORMAT(' (FOR WHICH A Q P CONTROL CHART ')
IF(ICASPL.EQ.'PCC')CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'PNCC')WRITE(ICOUT,517)
517 FORMAT(' (FOR WHICH A Q NP CONTROL CHART ')
IF(ICASPL.EQ.'PNCC')CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'CCC')WRITE(ICOUT,518)
518 FORMAT(' (FOR WHICH A Q C CONTROL CHART ')
IF(ICASPL.EQ.'CCC')CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'UCC')WRITE(ICOUT,519)
519 FORMAT(' (FOR WHICH A Q U CONTROL CHART ')
IF(ICASPL.EQ.'UCC')CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,523)
523 FORMAT(' THE NUMBER OF VARIABLES ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,524)
524 FORMAT(' MUST BE EITHER 1 OR 2 ;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,525)
525 FORMAT(' SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,526)
526 FORMAT(' THE SPECIFIED NUMBER')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,527)NUMV2
527 FORMAT(' OF VARIABLES WAS ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,528)
528 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,529)(IANS(I),I=1,IWIDTH)
529 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
530 CONTINUE
IHHOR=IHARG(2)
IHHOR2=IHARG2(2)
IHWUSE='V'
MESSAG='YES'
CALL CHECKN(IHHOR,IHHOR2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
ICOLH=IVALUE(ILOCV)
NHOR=IN(ILOCV)
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC')THEN
WRITE(ICOUT,531)IHHOR,ICOLH,NHOR
531 FORMAT('IHHOR,ICOLH,NHOR = ',A4,I8,I8)
CALL DPWRST('XXX','BUG ')
ENDIF
IF(NHOR.NE.NLEFT)GOTO570
GOTO599
C
540 CONTINUE
C IHEXT AS IN "EXTRA"
IHEXT=IHARG(2)
IHEXT2=IHARG2(2)
IHWUSE='V'
MESSAG='YES'
CALL CHECKN(IHEXT,IHEXT2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
ICOLE=IVALUE(ILOCV)
NEXT=IN(ILOCV)
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC')THEN
WRITE(ICOUT,541)IHEXT,ICOLE,NEXT
541 FORMAT('IHEXT,ICOLE,NEXT = ',A4,I8,I8)
CALL DPWRST('XXX','BUG ')
ENDIF
IF(NEXT.NE.NLEFT)GOTO570
C
IHHOR=IHARG(3)
IHHOR2=IHARG2(3)
IHWUSE='V'
MESSAG='YES'
CALL CHECKN(IHHOR,IHHOR2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
ICOLH=IVALUE(ILOCV)
NHOR=IN(ILOCV)
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC')THEN
WRITE(ICOUT,542)IHHOR,ICOLH,NHOR
542 FORMAT('IHHOR,ICOLH,NHOR = ',A4,I8,I8)
CALL DPWRST('XXX','BUG ')
ENDIF
IF(NHOR.NE.NLEFT)GOTO570
GOTO599
C
570 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,571)
571 FORMAT('***** ERROR IN DPQCC--')
CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'MECC')WRITE(ICOUT,572)
572 FORMAT(' FOR A Q MEAN CONTROL CHART, ')
IF(ICASPL.EQ.'MECC')CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'SDCC')WRITE(ICOUT,573)
573 FORMAT(' FOR A Q STANDARD DEVIATION CONTROL CHART,')
IF(ICASPL.EQ.'SDCC')CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'RACC')WRITE(ICOUT,574)
574 FORMAT(' FOR A Q RANGE CONTROL CHART, ')
IF(ICASPL.EQ.'RACC')CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'CUCC')WRITE(ICOUT,575)
575 FORMAT(' FOR A Q CUSUM CONTROL CHART,')
IF(ICASPL.EQ.'CUCC')CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'PCC')WRITE(ICOUT,576)
576 FORMAT(' (FOR WHICH A P CONTROL CHART ')
IF(ICASPL.EQ.'PCC')CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'PNCC')WRITE(ICOUT,577)
577 FORMAT(' (FOR WHICH A NP CONTROL CHART ')
IF(ICASPL.EQ.'PNCC')CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'CCC')WRITE(ICOUT,578)
578 FORMAT(' (FOR WHICH A Q C CONTROL CHART ')
IF(ICASPL.EQ.'CCC')CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'UCC')WRITE(ICOUT,579)
579 FORMAT(' (FOR WHICH A Q U CONTROL CHART ')
IF(ICASPL.EQ.'UCC')CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,584)
584 FORMAT(' WHEN HAVE 2 (OR 3) VARAIBLES SPECIFIED, ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,585)
585 FORMAT(' THE NUMBER OF ELEMENTS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,586)
586 FORMAT(' IN THE 2 (OR 3) VARIABLES ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,587)
587 FORMAT(' MUST BE THE SAME; ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,588)
588 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,589)
589 FORMAT(' THE FIRST VARIABLE (RESPONSE VALUES)--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,590)IHLEFT,NLEFT
590 FORMAT(' ',A4,' HAS ',I8,' ELEMENTS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,591)
591 FORMAT(' THE 2ND VARIABLE--')
CALL DPWRST('XXX','BUG ')
IF(NUMV2.EQ.3)WRITE(ICOUT,592)IHEXT,NEXT
IF(NUMV2.EQ.3)CALL DPWRST('XXX','BUG ')
IF(NUMV2.EQ.2)WRITE(ICOUT,592)IHHOR,NHOR
592 FORMAT(' ',A4,' HAS ',I8,' ELEMENTS')
IF(NUMV2.EQ.2)CALL DPWRST('XXX','BUG ')
IF(NUMV2.EQ.3)WRITE(ICOUT,593)
593 FORMAT(' THE 3ND VARIABLE (HORIZ. AXIS VALUES)--')
IF(NUMV2.EQ.3)CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,594)IHHOR,NHOR
594 FORMAT(' ',A4,' HAS ',I8,' ELEMENTS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,595)
595 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,596)(IANS(I),I=1,IWIDTH)
596 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
599 CONTINUE
C
C *************************************************
C ** STEP 6-- **
C ** BRANCH TO THE APPROPRIATE SUBCASE; **
C ** (BASED ON THE QUALIFIER) **
C ** THEN FORM THE RESPONSE VARIABLE **
C ** AND THE SECOND VARIABLE (IF EXISTENT) **
C *************************************************
C
ISTEPN='6'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(ICASEQ.EQ.'FULL')GOTO610
IF(ICASEQ.EQ.'SUBS')GOTO620
IF(ICASEQ.EQ.'FOR')GOTO630
C
610 CONTINUE
DO615I=1,NLEFT
ISUB(I)=1
615 CONTINUE
NQ=NLEFT
GOTO650
C
620 CONTINUE
NIOLD=NLEFT
CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
NQ=NIOLD
GOTO650
C
630 CONTINUE
NIOLD=NLEFT
CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
NQ=NFOR
GOTO650
C
650 CONTINUE
J=0
IMAX=NLEFT
IF(NQ.LT.NLEFT)IMAX=NQ
DO660I=1,IMAX
IF(ISUB(I).EQ.0)GOTO660
J=J+1
C
IJ=MAXN*(ICOLL-1)+I
IF(ICOLL.LE.MAXCOL)Y1(J)=V(IJ)
IF(ICOLL.EQ.MAXCP1)Y1(J)=PRED(I)
IF(ICOLL.EQ.MAXCP2)Y1(J)=RES(I)
IF(ICOLL.EQ.MAXCP3)Y1(J)=YPLOT(I)
IF(ICOLL.EQ.MAXCP4)Y1(J)=XPLOT(I)
IF(ICOLL.EQ.MAXCP5)Y1(J)=X2PLOT(I)
IF(ICOLL.EQ.MAXCP6)Y1(J)=TAGPLO(I)
IF(NUMV2.LE.1)GOTO660
C
IF(NUMV2.EQ.2)GOTO652
GOTO653
C
652 CONTINUE
IJ=MAXN*(ICOLH-1)+I
IF(ICOLH.LE.MAXCOL)X1(J)=V(IJ)
IF(ICOLH.EQ.MAXCP1)X1(J)=PRED(I)
IF(ICOLH.EQ.MAXCP2)X1(J)=RES(I)
IF(ICOLH.EQ.MAXCP3)X1(J)=YPLOT(I)
IF(ICOLH.EQ.MAXCP4)X1(J)=XPLOT(I)
IF(ICOLH.EQ.MAXCP5)X1(J)=X2PLOT(I)
IF(ICOLH.EQ.MAXCP6)X1(J)=TAGPLO(I)
GOTO660
C
653 CONTINUE
IJ=MAXN*(ICOLE-1)+I
IF(ICOLE.LE.MAXCOL)Y2(J)=V(IJ)
IF(ICOLE.EQ.MAXCP1)Y2(J)=PRED(I)
IF(ICOLE.EQ.MAXCP2)Y2(J)=RES(I)
IF(ICOLE.EQ.MAXCP3)Y2(J)=YPLOT(I)
IF(ICOLE.EQ.MAXCP4)Y2(J)=XPLOT(I)
IF(ICOLE.EQ.MAXCP5)Y2(J)=X2PLOT(I)
IF(ICOLE.EQ.MAXCP6)Y2(J)=TAGPLO(I)
C
IJ=MAXN*(ICOLH-1)+I
IF(ICOLH.LE.MAXCOL)X1(J)=V(IJ)
IF(ICOLH.EQ.MAXCP1)X1(J)=PRED(I)
IF(ICOLH.EQ.MAXCP2)X1(J)=RES(I)
IF(ICOLH.EQ.MAXCP3)X1(J)=YPLOT(I)
IF(ICOLH.EQ.MAXCP4)X1(J)=XPLOT(I)
IF(ICOLH.EQ.MAXCP5)X1(J)=X2PLOT(I)
IF(ICOLH.EQ.MAXCP6)X1(J)=TAGPLO(I)
GOTO660
C
660 CONTINUE
NLOCAL=J
C
C ****************************************************************
C ** STEP 8-- **
C ** DETERMINE IF THE ANALYST **
C ** HAS SPECIFIED
C ** LSL (LOWER SPEC LIMIT)
C ** USL (UPPER SPEC LIMIT)
C ** USLCOST (UPPER SPEC LIMIT COST)
C ** TARGET
C ** FOR THE Q CONTROL CHART ANALYSIS. **
C ****************************************************************
C
ISTEPN='8'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CCLSL=CPUMIN
IH='LSL '
IH2=' '
IHWUSE='P'
MESSAG='NO'
CALL CHECKN(IH,IH2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
IF(IERRO2.EQ.'NO')CCLSL=VALUE(ILOCP)
C
CCUSL=CPUMIN
IH='USL '
IH2=' '
IHWUSE='P'
MESSAG='NO'
CALL CHECKN(IH,IH2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
IF(IERRO2.EQ.'NO')CCUSL=VALUE(ILOCP)
C
CCTARG=CPUMIN
IH='TARG'
IH2='ET '
IHWUSE='P'
MESSAG='NO'
CALL CHECKN(IH,IH2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
IF(IERRO2.EQ.'NO')CCTARG=VALUE(ILOCP)
C
C *************************************************************
C ** STEP 9-- **
C ** COMPUTE THE APPROPRIATE Q CONTROL CHART STATISTIC-- **
C ** MEAN, STANDARD DEVIATION, RANGE, CUSUM, **
C ** P, NP, C, U. **
C ** COMPUTE CONFIDENCE LINES. **
C ** FORM THE VERTICAL AND HORIZONTAL AXIS **
C ** VALUES Y(.) AND X(.) FOR THE PLOT. **
C ** DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S **
C ** FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE LINE, **
C ** AND THE UPPER CONFIDENCE LINE. **
C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). **
C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). **
C *************************************************************
C
ISTEPN='8'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PQCC')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
809 CONTINUE
CALL DPQCC2(Y1,Y2,X1,NLOCAL,NUMV2,ICASPL,ISIZE,ICONT,
1XIDTEM,TEMP,TEMP2,CCLSL,CCUSL,CCTARG,
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.'PQCC')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPQCC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IFOUND,IERROR
9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
9013 FORMAT('PNLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
1I8,I8,I8,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)ISIZE
9014 FORMAT('ISIZE = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NPLOTP.LE.0)GOTO9090
DO9015I=1,NPLOTP
WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
CALL DPWRST('XXX','BUG ')
9015 CONTINUE
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPQCC2(Y,YN,X,N,NUMV2,ICASPL,ISIZE,ICONT,
1XIDTEM,TEMP,TEMP2,CCLSL,CCUSL,CCTARG,
1Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
C
C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
C THAT WILL DEFINE A Q (= QUESENBERRY) CONTROL CHART
C OF THE FOLLOWING TYPES--
C 1) Q MEAN CONTROL CHART Y X
C 2) Q STANDARD DEVIATION CONTROL CHART Y X
C 3) Q RANGE CONTROL CHART Y X
C 4) Q CUSUM CONTROL CHART Y X
C 5) Q P CONTROL CHART NUMDEF NUMTOT X
C 6) Q PN CONTROL CHART NUMDEF NUMTOT X
C 7) Q U CONTROL CHART NUMDEF SIZE X
C 8) Q P CONTROL CHART NUMDEF SIZE X
C NOTE--USE P AND PN CHARTS IF KNOW HOW MANY ITEMS HAVE DEFECTS
C --USE U AND C CHARTS IF KNOW HOW MANY DEFECTS
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C 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 REFERENCE--QUESENBERRY, CHARLES P. SPC Q CHARTS FOR START-UP
C PROCESSES AND SHORT OR LONG RUNS.
C JOURNAL OF QUALITY TECNOLOGY, JULY 1991,
C PAGES 213-224.
C REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
C REFERENCE--ISHIKAWA, GUIDE TO QUALITY CONTROL
C LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--93/12
C ORIGINAL VERSION--DECEMBER 1993.
C UPDATED --OCTOBER 2006. CALL LIST TO TCDF
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 ICASPL
CHARACTER*4 ICONT
CHARACTER*4 IBUGG3
CHARACTER*4 ISUBRO
CHARACTER*4 IERROR
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
DIMENSION Y(*)
DIMENSION YN(*)
DIMENSION X(*)
DIMENSION Y2(*)
DIMENSION X2(*)
DIMENSION D2(*)
C
DIMENSION XIDTEM(*)
DIMENSION TEMP(*)
DIMENSION TEMP2(*)
C
DIMENSION A3(30)
DIMENSION C4(30)
DIMENSION B3(30)
DIMENSION B4(30)
DIMENSION D22(30)
DIMENSION D3(30)
DIMENSION D4(30)
C
C---------------------------------------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
DATA(A3(I),I= 1, 25)
1/9.999,2.659,1.954,1.628,1.427,
1 1.287,1.182,1.099,1.032,0.975,
1 0.927,0.886,0.850,0.817,0.789,
1 0.763,0.739,0.718,0.698,0.680,
1 0.663,0.647,0.633,0.619,0.606/
DATA(C4(I),I= 1, 25)
1/9.9999,0.7979,0.8862,0.9213,0.9400,
1 0.9515,0.9594,0.9650,0.9693,0.9727,
1 0.9754,0.9776,0.9794,0.9810,0.9823,
1 0.9835,0.9845,0.9854,0.9862,0.9869,
1 0.9876,0.9882,0.9887,0.9892,0.9896/
DATA(B3(I),I= 1, 25)
1/0.000,0.000,0.000,0.000,0.000,0.030,0.118,0.185,0.239,0.284,
1 0.321,0.354,0.382,0.406,0.428,0.448,0.466,0.482,0.497,0.510,
1 0.523,0.534,0.545,0.555,0.565/
DATA(B4(I),I= 1, 25)
1/9.999,3.267,2.568,2.266,2.089,1.970,1.882,1.815,1.761,1.716,
1 1.679,1.646,1.618,1.594,1.572,1.552,1.534,1.518,1.503,1.490,
1 1.477,1.466,1.455,1.445,1.435/
DATA(D22(I),I= 1, 25)
1/9.999,3.686,4.358,4.698,4.918,5.078,5.203,5.307,5.394,5.469,
1 5.534,5.592,5.646,5.693,5.737,5.779,5.817,5.854,5.888,5.922,
1 5.950,5.979,6.006,6.031,6.058/
DATA(D3(I),I= 1, 25)
1/0.000,0.000,0.000,0.000,0.000,0.000,0.076,0.136,0.184,0.223,
1 0.256,0.284,0.308,0.329,0.348,0.364,0.379,0.392,0.404,0.414,
1 0.425,0.434,0.443,0.452,0.459/
DATA(D4(I),I= 1, 25)
1/9.999,3.267,2.575,2.282,2.115,2.004,1.924,1.864,1.816,1.777,
1 1.744,1.716,1.692,1.671,1.652,1.636,1.621,1.608,1.596,1.586,
1 1.575,1.566,1.557,1.548,1.541/
C
C-----START POINT-----------------------------------------------------
C
ISUBN1='DPQC'
ISUBN2='C2 '
C
I2=0
ISIZE2=0
C
AN=0.0
XBARG=0.0
SDG=0.0
RANGEG=0.0
YUPPER=0.0
YLOWER=0.0
C
ANUMSE=0.0
SDI=0.0
SIGMAE=0.0
RANGEE=0.0
SADJ=0.0
RADJ=0.0
C
C CHECK THE INPUT ARGUMENTS FOR ERRORS
C
IF(N.GE.1)GOTO39
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,31)
31 FORMAT('***** ERROR IN DPQCC2--')
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 DPQCC2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,47)
47 FORMAT(' THE NUMBER OF OBSERVATIONS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,48)
48 FORMAT(' WAS EXACTLY EQUAL TO 1.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
49 CONTINUE
C
HOLD=Y(1)
DO60I=1,N
IF(Y(I).NE.HOLD)GOTO69
60 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,61)
61 FORMAT('***** ERROR IN DPQCC2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,62)
62 FORMAT(' ALL RESPONSE VARIABLE ELEMENTS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,63)HOLD
63 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
69 CONTINUE
C
IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'QCC2')GOTO90
WRITE(ICOUT,70)
70 FORMAT('AT THE BEGINNING OF DPQCC2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,71)N,ICASPL,NUMV2,ISIZE,ICONT
71 FORMAT('N,ICASPL,NUMV2,ISIZE,ICONT = ',I8,2X,A4,I8,I8,2X,A4)
CALL DPWRST('XXX','BUG ')
DO72I=1,N
WRITE(ICOUT,73)I,Y(I),X(I)
73 FORMAT('I, Y(I), X(I) = ',I8,3F15.7)
CALL DPWRST('XXX','BUG ')
72 CONTINUE
IF(NUMV2.LE.2)GOTO79
DO75I=1,N
WRITE(ICOUT,76)I,YN(I),X(I)
76 FORMAT('I,YN(I),X(I) = ',I8,2E15.7)
CALL DPWRST('XXX','BUG ')
75 CONTINUE
79 CONTINUE
90 CONTINUE
C
C ********************************************************
C ** STEP 1-- **
C ** DETERMINE THE NUMBER OF DISTINCT VALUES **
C ** FOR VARIABLE 2 (THE GROUP VARIABLE). **
C ** IF ALL VALUES ARE DISTINCT, THEN THIS **
C ** IMPLIES WE HAVE THE NO REPLICATION CASE **
C ** WHICH IS AN ERROR CONDITION FOR A Q CONTROL CHART. **
C ********************************************************
C
ISTEPN='1'
IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
NUMSET=(-999)
IF(NUMV2.EQ.1)GOTO199
IF(NUMV2.EQ.2)GOTO150
C
150 CONTINUE
NUMSET=0
DO160I=1,N
IF(NUMSET.EQ.0)GOTO165
DO170J=1,NUMSET
IF(X(I).EQ.XIDTEM(J))GOTO160
170 CONTINUE
165 CONTINUE
NUMSET=NUMSET+1
XIDTEM(NUMSET)=X(I)
160 CONTINUE
CALL SORT(XIDTEM,NUMSET,XIDTEM)
C
190 CONTINUE
C
IF(NUMSET.GE.1)GOTO194
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,191)
191 FORMAT('***** ERROR IN DPQCC2 SUBROUTINE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,192)
192 FORMAT(' NUMBER OF SETS NUMSET = 0 ')
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
194 CONTINUE
C
IF(ICASPL.EQ.'PCC')GOTO199
IF(ICASPL.EQ.'PNCC')GOTO199
IF(ICASPL.EQ.'UCC')GOTO199
IF(ICASPL.EQ.'CCC')GOTO199
C
IF(NUMSET.NE.N)GOTO199
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,195)
195 FORMAT('***** ERROR IN DPQCC2 SUBROUTINE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,196)
196 FORMAT(' NUMBER OF SETS NUMSET IDENTICAL TO ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,197)
197 FORMAT(' NUMBER OF OBSERVATIONS N .')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,198)NUMSET
198 FORMAT(' NUMSET = N = ',I8)
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
199 CONTINUE
C
AN=N
ANUMSE=NUMSET
C
C *******************************************
C ** STEP 3.0-- **
C ** DETERMINE STATISTICS FOR THE ENTIRE **
C ** DATA SET **
C *******************************************
C
1000 CONTINUE
C
ISTEPN='3.0'
IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(NUMV2.EQ.1)GOTO1090
C
SUMXBG=0.0
SUMSDG=0.0
SUMRAG=0.0
SUMSIE=0.0
SUMRIE=0.0
J=0
DO1010ISET=1,NUMSET
J=J+1
C
K=0
DO1020I=1,N
IF(X(I).EQ.XIDTEM(ISET))K=K+1
IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I)
1020 CONTINUE
NI=K
ANI=NI
C
SUM=0.0
IF(NI.LE.0)GOTO1040
DO1030I=1,NI
SUM=SUM+TEMP(I)
1030 CONTINUE
XBARI=SUM/ANI
C
SUM=0.0
DO1032I=1,NI
SUM=SUM+(TEMP(I)-XBARI)**2
1032 CONTINUE
DENOM=ANI-1.0
VARI=0.0
IF(NI.GE.2)VARI=SUM/DENOM
SDI=0.0
IF(VARI.GT.0.0)SDI=SQRT(VARI)
C
XTMIN=TEMP(1)
XTMAX=TEMP(1)
DO1034I=1,NI
IF(TEMP(I).LT.XTMIN)XTMIN=TEMP(I)
IF(TEMP(I).GT.XTMAX)XTMAX=TEMP(I)
1034 CONTINUE
RANGEI=XTMAX-XTMIN
GOTO1049
C
1040 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1041)
1041 FORMAT('***** INTERNAL ERROR IN DPQCC2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1042)
1042 FORMAT('NI FOR SOME CLASS = 0')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1043)ISET,XIDTEM(ISET),NI
1043 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8)
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
1049 CONTINUE
C
SUMXBG=SUMXBG+ANI*XBARI
SUMSDG=SUMSDG+ANI*SDI
SUMRAG=SUMRAG+ANI*RANGEI
C4LARG=1.0
IF(NI.LE.25)SUMSIE=SUMSIE+SDI/C4(NI)
IF(NI.GE.26)SUMSIE=SUMSIE+SDI/C4LARG
D22LAR=2.0*SQRT(2.0*ALOG(2.0*ANI))
IF(NI.LE.25)SUMRIE=SUMRIE+RANGEI/D22(NI)
IF(NI.GE.26)SUMRIE=SUMRIE+RANGEI/D22LAR
C
IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'QCC2')GOTO1069
WRITE(ICOUT,1061)ISET,NI,ANI
1061 FORMAT('ISET,NI,ANI = ',I8,I8,E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1062)XBARI
1062 FORMAT('XBARI = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1063)SDI,C4(NI),C4LARG,SUMSIE
1063 FORMAT('SDI,C4(NI),C4LARG,SUMSIE = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1064)RANGEI,D22(NI),D22LAR,SUMRIE
1064 FORMAT('RANGEI,D22(NI),D22LAR,SUMRIE = ',4E15.7)
CALL DPWRST('XXX','BUG ')
1069 CONTINUE
C
1010 CONTINUE
C
XBARG=SUMXBG/AN
SDG=SUMSDG/AN
RANGEG=SUMRAG/AN
SIGMAE=SUMSIE/ANUMSE
RANGEE=SUMRIE/ANUMSE
C
1090 CONTINUE
C
C **************************************************************
C ** STEP 4-- **
C ** IN ORDER TO DETERMINE THE PROPER PLOT COOORDINATES **
C ** FOR THE DESIRED PLOT, **
C ** BRANCH TO THE PROPER SUBCASE-- **
C ** 1) Q MEAN CONTROL CHART; **
C ** 2) Q STANDARD DEVIATION CONTROL CHART; **
C ** 3) Q RANGE CONTROL CHART; **
C ** 4) Q CUSUM CONTROL CHART; **
C ** 5) Q P CONTROL CHART; **
C ** 6) Q PN CONTROL CHART; **
C ** 7) Q C CONTROL CHART; **
C ** 8) Q U CONTROL CHART; **
C **************************************************************
C
ISTEPN='4'
IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(ICASPL.EQ.'MECC')GOTO1100
IF(ICASPL.EQ.'SDCC')GOTO1200
IF(ICASPL.EQ.'RACC')GOTO1300
IF(ICASPL.EQ.'CUCC')GOTO1400
IF(ICASPL.EQ.'PCC')GOTO1500
IF(ICASPL.EQ.'PNCC')GOTO1600
IF(ICASPL.EQ.'UCC')GOTO1700
IF(ICASPL.EQ.'CCC')GOTO1800
C
1050 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1051)
1051 FORMAT('***** INTERNAL ERROR IN DPQCC2')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1052)
1052 FORMAT(' AT BRANCH POINT 261--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1053)
1053 FORMAT(' ICASPL NOT EQUAL ONE OF THE ALLOWABLE 8--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1054)
1054 FORMAT(' MECC, SDCC, RACC, CSCC, PCC, PNCC, UCC, CCC.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1056)ICASPL
1056 FORMAT(' ICASPL = ',A4)
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
C *******************************************
C ** STEP 5.1-- **
C ** TREAT THE Q MEAN CONTROL CHART CASE **
C *******************************************
C
1100 CONTINUE
C
ISTEPN='5.1'
IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
J=0
DO1110K=3,N
KM1=K-1
AKM1=KM1
KM2=K-2
C
SUM=0.0
DO1120I=1,KM1
SUM=SUM+Y(I)
1120 CONTINUE
XBAKM1=SUM/AKM1
C
SUM=0.0
DO1130I=1,KM1
SUM=SUM+(Y(I)-XBAKM1)**2
1130 CONTINUE
SKM1=SQRT(SUM/(AKM1-1.0))
C
ANUM=Y(K)-XBAKM1
ADENOM=SKM1*SQRT((1.0/AKM1)+1.0)
RATIO=ANUM/ADENOM
CCCCC CALL TCDF(RATIO,KM2,CDF)
CALL TCDF(RATIO,REAL(KM2),CDF)
CALL NORPPF(CDF,PPF)
J=J+1
Y2(J)=PPF
X2(J)=J
D2(J)=1.0
1110 CONTINUE
N2=J
NPLOTV=2
GOTO9000
C
C **********************************************************
C ** STEP 5.2-- **
C ** TREAT THE Q STANDARD DEVIATION CONTROL CHART CASE **
C **********************************************************
C
1200 CONTINUE
C
ISTEPN='5.2'
IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
J=0
DO1210ISET=1,NUMSET
C
K=0
DO1220I=1,N
IF(X(I).EQ.XIDTEM(ISET))K=K+1
IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I)
1220 CONTINUE
NI=K
ANI=NI
C
IF(NI.GE.1)GOTO1239
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1231)
1231 FORMAT('***** INTERNAL ERROR IN DPQCC2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1232)
1232 FORMAT('NI FOR SOME CLASS = 0')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1233)ISET,XIDTEM(ISET),NI
1233 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8)
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
1239 CONTINUE
C
SUM=0.0
DO1240I=1,NI
SUM=SUM+TEMP(I)
1240 CONTINUE
XBARI=SUM/ANI
C
IF(NI.LE.1)GOTO1210
C
SUM=0.0
DO1250I=1,NI
SUM=SUM+(TEMP(I)-XBARI)**2
1250 CONTINUE
DENOM=ANI-1.0
VARI=0.0
IF(NI.GE.2)VARI=SUM/DENOM
SDI=0.0
IF(VARI.GT.0.0)SDI=SQRT(VARI)
C
C4LARG=1.0
IF(NI.LE.25)SADJ=C4(NI)*SIGMAE
IF(NI.GE.26)SADJ=C4LARG*SIGMAE
C
YMID=SADJ
C
B4LARG=1.0+3.0/SQRT(2.0*(ANI-1.0))
IF(NI.LE.25)YUPPER=B4(NI)*SADJ
IF(NI.GE.26)YUPPER=B4LARG*SADJ
C
B3LARG=1.0-3.0/SQRT(2.0*(ANI-1.0))
IF(NI.LE.25)YLOWER=B3(NI)*SADJ
IF(NI.GE.26)YLOWER=B3LARG*SADJ
C
IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'QCC2')GOTO1269
WRITE(ICOUT,1261)ISET,NI,ANI
1261 FORMAT('ISET,NI,ANI = ',I8,I8,E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1262)XBARI
1262 FORMAT('XBARI = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1263)SDI,C4(NI),C4LARG,SIGMAE,SADJ
1263 FORMAT('SDI,C4(NI),C4LARG,SIGMAE,SADJ = ',5E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1264)SADJ,YMID
1264 FORMAT('SADJ,YMID = ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1265)NI,ANI,B4(NI),B4LARG,YUPPER
1265 FORMAT('NI,ANI,B4(NI),B4LARG,YUPPER = ',I8,4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1266)NI,ANI,B3(NI),B3LARG,YLOWER
1266 FORMAT('NI,ANI,B3(NI),B3LARG,YLOWER = ',I8,4E15.7)
CALL DPWRST('XXX','BUG ')
1269 CONTINUE
C
J=J+1
Y2(J)=SDI
X2(J)=XIDTEM(ISET)
D2(J)=1.0
C
J=J+1
Y2(J)=YMID
X2(J)=XIDTEM(ISET)
D2(J)=2.0
C
J=J+1
Y2(J)=YUPPER
X2(J)=XIDTEM(ISET)
D2(J)=3.0
C
J=J+1
Y2(J)=YLOWER
X2(J)=XIDTEM(ISET)
D2(J)=4.0
C
IF(CCTARG.EQ.CPUMIN)GOTO1271
J=J+1
Y2(J)=CCTARG
X2(J)=XIDTEM(ISET)
D2(J)=5.0
1271 CONTINUE
C
IF(CCUSL.EQ.CPUMIN)GOTO1272
J=J+1
Y2(J)=CCUSL
X2(J)=XIDTEM(ISET)
D2(J)=6.0
1272 CONTINUE
C
IF(CCLSL.EQ.CPUMIN)GOTO1273
J=J+1
Y2(J)=CCLSL
X2(J)=XIDTEM(ISET)
D2(J)=7.0
1273 CONTINUE
C
1210 CONTINUE
N2=J
NPLOTV=3
GOTO9000
C
C ********************************************
C ** STEP 5.3-- **
C ** TREAT THE Q RANGE CONTROL CHART CASE **
C ********************************************
C
1300 CONTINUE
C
ISTEPN='5.3'
IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
D4FACT=1.25
D3FACT=1.0/1.25
C
J=0
DO1310ISET=1,NUMSET
C
K=0
DO1320I=1,N
IF(X(I).EQ.XIDTEM(ISET))K=K+1
IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I)
1320 CONTINUE
NI=K
ANI=NI
C
IF(NI.GE.1)GOTO1339
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1331)
1331 FORMAT('***** INTERNAL ERROR IN DPQCC2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1332)
1332 FORMAT('NI FOR SOME CLASS = 0')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1333)ISET,XIDTEM(ISET),NI
1333 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8)
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
1339 CONTINUE
C
IF(NI.LE.1)GOTO1310
C
XTMIN=TEMP(1)
XTMAX=TEMP(1)
DO1340I=1,NI
IF(TEMP(I).LT.XTMIN)XTMIN=TEMP(I)
IF(TEMP(I).GT.XTMAX)XTMAX=TEMP(I)
1340 CONTINUE
RANGEI=XTMAX-XTMIN
C
D22LAR=2.0*SQRT(2.0*ALOG(2.0*ANI))
IF(NI.LE.25)RADJ=D22(NI)*RANGEE
IF(NI.GE.26)RADJ=D22LAR*RANGEE
C
YMID=RADJ
C
D4LARG=1.0+3.0*D4FACT/SQRT(2.0*(ANI-1.0))
IF(NI.LE.25)YUPPER=D4(NI)*RADJ
IF(NI.GE.26)YUPPER=D4LARG*RADJ
C
D3LARG=1.0-3.0*D3FACT/SQRT(2.0*(ANI-1.0))
IF(NI.LE.25)YLOWER=D3(NI)*RADJ
IF(NI.GE.26)YLOWER=D3LARG*RADJ
C
IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'QCC2')GOTO1369
WRITE(ICOUT,1361)ISET,NI,ANI
1361 FORMAT('ISET,NI,ANI = ',I8,I8,E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1362)RANGEI
1362 FORMAT('RANGEI = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1363)RANGEI,D22(NI),D22LAR,RANGEE,SADJ
1363 FORMAT('RANGEI,D22(NI),D22LAR,RANGEE,SADJ = ',5E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1364)RADJ,YMID
1364 FORMAT('RADJ,YMID = ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1365)NI,ANI,D4(NI),D4LARG,YUPPER
1365 FORMAT('NI,ANI,D4(NI),D4LARG,YUPPER = ',I8,4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1366)NI,ANI,D3(NI),D3LARG,YLOWER
1366 FORMAT('NI,ANI,D3(NI),D3LARG,YLOWER = ',I8,4E15.7)
CALL DPWRST('XXX','BUG ')
1369 CONTINUE
C
J=J+1
Y2(J)=RANGEI
X2(J)=XIDTEM(ISET)
D2(J)=1.0
C
J=J+1
Y2(J)=YMID
X2(J)=XIDTEM(ISET)
D2(J)=2.0
C
J=J+1
Y2(J)=YUPPER
X2(J)=XIDTEM(ISET)
D2(J)=3.0
C
J=J+1
Y2(J)=YLOWER
X2(J)=XIDTEM(ISET)
D2(J)=4.0
C
IF(CCTARG.EQ.CPUMIN)GOTO1371
J=J+1
Y2(J)=CCTARG
X2(J)=XIDTEM(ISET)
D2(J)=5.0
1371 CONTINUE
C
IF(CCUSL.EQ.CPUMIN)GOTO1372
J=J+1
Y2(J)=CCUSL
X2(J)=XIDTEM(ISET)
D2(J)=6.0
1372 CONTINUE
C
IF(CCLSL.EQ.CPUMIN)GOTO1373
J=J+1
Y2(J)=CCLSL
X2(J)=XIDTEM(ISET)
D2(J)=7.0
1373 CONTINUE
C
1310 CONTINUE
N2=J
NPLOTV=3
GOTO9000
C
C ******************************************************
C ** STEP 5.4-- **
C ** DETERMINE PLOT COORDINATES **
C ** FOR THE Q CUSUM CONTROL CHART PLOT SUBCASE. **
C ******************************************************
C
1400 CONTINUE
C
ISTEPN='3.4'
IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
WRITE(ICOUT,1405)
1405 FORMAT('CUSUM CAPABILITY NOT YET AVAILABLE.')
CALL DPWRST('XXX','BUG ')
GOTO9000
C
C ********************************************************
C ** STEP 5.5-- **
C ** TREAT THE Q P CONTROL CHART CASE **
C ** PROPORTION DEFECTIVE PER BATCH (SUBSAMPLE) **
C ** NUMBER DEFECTIVE PER BATCH / TOTAL NUMBER IN BATCH
C ** THE INPUT IS A DUAL SERIES--
C ** 1) NUMBER OF DEFECTIVE ITEMS IN THE SUBSAMPLE
C ** 2) TOTAL NUMBER OF ITEMS IN THE SAMPLE
C ** THE CONFIDENCE BAND IS GOTTEN BY ASSUMING BINOMIAL**
C ********************************************************
C
1500 CONTINUE
C
ISTEPN='5.5'
IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
SUM1=0.0
SUM2=0.0
DO1510ISET=1,NUMSET
SUM1=SUM1+Y(ISET)
SUM2=SUM2+YN(ISET)
1510 CONTINUE
CTOTAL=SUM1
ANTOT=SUM2
PBARG=CTOTAL/ANTOT
PRBARG=100.0*PBARG
C
J=0
DO1550ISET=1,NUMSET
C
CI=Y(ISET)
ANI=YN(ISET)
NI=ANI+0.5
IF(NI.LE.0)GOTO1550
C
PI=CI/ANI
PROPI=100.0*PI
TAGI=XIDTEM(ISET)
C
J=J+1
Y2(J)=PROPI
X2(J)=TAGI
D2(J)=1.0
C
J=J+1
YMID=PRBARG
Y2(J)=YMID
X2(J)=TAGI
D2(J)=2.0
C
J=J+1
VARPI=0.0
IF(ANI.GT.0.0)VARPI=PBARG*(1.0-PBARG)/ANI
SDPI=0.0
IF(VARPI.GT.0.0)SDPI=SQRT(VARPI)
SDPRI=100.0*SDPI
YUPPER=YMID+3.0*SDPRI
IF(YUPPER.GT.100.0)YUPPER=100.0
Y2(J)=YUPPER
X2(J)=TAGI
D2(J)=3.0
C
J=J+1
YLOWER=YMID-3.0*SDPRI
IF(YLOWER.LT.0.0)YLOWER=0.0
Y2(J)=YLOWER
X2(J)=TAGI
D2(J)=4.0
C
IF(CCTARG.EQ.CPUMIN)GOTO1571
J=J+1
Y2(J)=CCTARG
X2(J)=XIDTEM(ISET)
D2(J)=5.0
1571 CONTINUE
C
IF(CCUSL.EQ.CPUMIN)GOTO1572
J=J+1
Y2(J)=CCUSL
X2(J)=XIDTEM(ISET)
D2(J)=6.0
1572 CONTINUE
C
IF(CCLSL.EQ.CPUMIN)GOTO1573
J=J+1
Y2(J)=CCLSL
X2(J)=XIDTEM(ISET)
D2(J)=7.0
1573 CONTINUE
C
1550 CONTINUE
N2=J
NPLOTV=3
GOTO9000
C
C ********************************************************
C ** STEP 5.6-- **
C ** TREAT THE Q PN CONTROL CHART CASE **
C ** TOTAL NUMBER DEFECTIVE IN A BATCH (SUBSAMPLE) **
C ** SUM UP THE NUMBER OF DEFECTIVES PER BATCH (SUBSAMPLE)
C ** THE NUMBER WILL BE A NON-NEGATIVE INTEGER
C ** THE INPUT IS A DUAL SERIES--
C ** 1) NUMBER OF DEFECTIVE ITEMS IN THE SUBSAMPLE
C ** 2) TOTAL NUMBER OF ITEMS IN THE SAMPLE
C ** THE CONFIDENCE BAND IS GOTTEN BY ASSUMING BINOMIAL**
C ** NOTE--THE PN CHART SHOULD BE USED ONLY WHEN
C ** THE SUBSAMPLE SIZE IS CONSTANT.
C ** FOR VARYING SUBSAMPLE SIZE, USE THE P CHART
C ** (ISHIKAWA, GUIDE TO QUALITY CONTROL, PAGE 77)
C ********************************************************
C
1600 CONTINUE
C
ISTEPN='5.6'
IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
SUM1=0.0
SUM2=0.0
ANUMSE=NUMSET
DO1610ISET=1,NUMSET
SUM1=SUM1+Y(ISET)
SUM2=SUM2+YN(ISET)
1610 CONTINUE
CTOTAL=SUM1
ANTOT=SUM2
PBARG=CTOTAL/ANTOT
ANBARG=ANTOT/ANUMSE
CBARG=PBARG*ANBARG
C
J=0
DO1650ISET=1,NUMSET
C
CI=Y(ISET)
ANI=YN(ISET)
NI=ANI+0.5
IF(NI.LE.0)GOTO1650
C
PI=CI/ANI
TAGI=XIDTEM(ISET)
C
J=J+1
Y2(J)=CI
X2(J)=TAGI
D2(J)=1.0
C
J=J+1
YMID=CBARG
Y2(J)=YMID
X2(J)=TAGI
D2(J)=2.0
C
J=J+1
VARCI=0.0
IF(ANBARG.GT.0.0)VARCI=ANBARG*PBARG*(1.0-PBARG)
SDCI=0.0
IF(VARCI.GT.0.0)SDCI=SQRT(VARCI)
YUPPER=YMID+3.0*SDCI
Y2(J)=YUPPER
X2(J)=TAGI
D2(J)=3.0
C
J=J+1
YLOWER=YMID-3.0*SDCI
IF(YLOWER.LT.0.0)YLOWER=0.0
Y2(J)=YLOWER
X2(J)=TAGI
D2(J)=4.0
C
IF(CCTARG.EQ.CPUMIN)GOTO1671
J=J+1
Y2(J)=CCTARG
X2(J)=XIDTEM(ISET)
D2(J)=5.0
1671 CONTINUE
C
IF(CCUSL.EQ.CPUMIN)GOTO1672
J=J+1
Y2(J)=CCUSL
X2(J)=XIDTEM(ISET)
D2(J)=6.0
1672 CONTINUE
C
IF(CCLSL.EQ.CPUMIN)GOTO1673
J=J+1
Y2(J)=CCLSL
X2(J)=XIDTEM(ISET)
D2(J)=7.0
1673 CONTINUE
C
1650 CONTINUE
N2=J
NPLOTV=3
GOTO9000
C
C ********************************************************
C ** STEP 5.7-- **
C ** TREAT THE Q U CONTROL CHART CASE (POISSON) **
C ** DEFECTIVE PER UNIT
C ** DEFECTIVE PER UNIT AREA
C ** NUMBER DEFECTIVE PER SUB-BATCH / LENGTH OR AREA
C ** THE INPUT IS A DUAL SERIES--
C ** 1) NUMBER OF DEFECTIVE ITEMS IN THE SUBSAMPLE
C ** 2) LENGTH OR AREA OF THE ITEM
C ** THE CONFIDENCE BAND IS GOTTEN BY ASSUMING POISSON**
C ********************************************************
C
1700 CONTINUE
C
ISTEPN='5.7'
IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
SUM1=0.0
SUM2=0.0
DO1710ISET=1,NUMSET
SUM1=SUM1+Y(ISET)
SUM2=SUM2+YN(ISET)
1710 CONTINUE
CTOTAL=SUM1
SIZTOT=SUM2
CBARG=CTOTAL/SIZTOT
C
J=0
DO1750ISET=1,NUMSET
C
CI=Y(ISET)
SIZEI=YN(ISET)
NSIZEI=SIZEI+0.5
IF(NSIZEI.LE.0)GOTO1750
C
TAGI=XIDTEM(ISET)
C
J=J+1
Y2(J)=(-1.0)
IF(SIZEI.NE.0.0)Y2(J)=CI/SIZEI
X2(J)=TAGI
D2(J)=1.0
C
J=J+1
YMID=CBARG
Y2(J)=YMID
X2(J)=TAGI
D2(J)=2.0
C
J=J+1
VARCI=0.0
IF(ANI.GT.0.0)VARCI=CBARG/SIZEI
SDCI=0.0
IF(VARCI.GT.0.0)SDCI=SQRT(VARCI)
YUPPER=YMID+3.0*SDCI
Y2(J)=YUPPER
X2(J)=TAGI
D2(J)=3.0
C
J=J+1
YLOWER=YMID-3.0*SDCI
IF(YLOWER.LT.0.0)YLOWER=0.0
Y2(J)=YLOWER
X2(J)=TAGI
D2(J)=4.0
C
IF(CCTARG.EQ.CPUMIN)GOTO1771
J=J+1
Y2(J)=CCTARG
X2(J)=XIDTEM(ISET)
D2(J)=5.0
1771 CONTINUE
C
IF(CCUSL.EQ.CPUMIN)GOTO1772
J=J+1
Y2(J)=CCUSL
X2(J)=XIDTEM(ISET)
D2(J)=6.0
1772 CONTINUE
C
IF(CCLSL.EQ.CPUMIN)GOTO1773
J=J+1
Y2(J)=CCLSL
X2(J)=XIDTEM(ISET)
D2(J)=7.0
1773 CONTINUE
C
1750 CONTINUE
N2=J
NPLOTV=3
GOTO9000
C
C ********************************************************
C ** STEP 5.8-- **
C ** TREAT THE Q C CONTROL CHART CASE (POISSON) **
C ** TOTAL NUMBER DEFECTIVE IN A BATCH (SUBSAMPLE) **
C ** SUM OF DEFECTIVES IN A BATCH (SUBSAMPLE) **
C ** THE INPUT IS USUALLY A SERIES OF INTEGERS **
C ** THE VALUE WILL BE A NON-NEGATIVE INTEGER **
C ** THE CONFIDENCE BAND IS GOTTEN BY ASSUMING POISSON**
C ** NOTE--THE C CHART SHOULD BE USED ONLY WHEN
C ** THE SUBSAMPLE SIZE IS CONSTANT.
C ** FOR VARYING SUBSAMPLE SIZE, USE THE U CHART
C ** (ISHIKAWA, GUIDE TO QUALITY CONTROL, PAGE 77)
C ********************************************************
C
1800 CONTINUE
C
ISTEPN='5.8'
IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QCC2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
SUM1=0.0
SUM2=0.0
ANUMSE=NUMSET
DO1810ISET=1,NUMSET
SUM1=SUM1+Y(ISET)
IF(NUMV2.LE.2)SUM2=SUM2+1
IF(NUMV2.GE.3)SUM2=SUM2+YN(ISET)
1810 CONTINUE
CTOTAL=SUM1
CBARG=CTOTAL/ANUMSE
C
J=0
DO1850ISET=1,NUMSET
C
CI=Y(ISET)
SIZEI=YN(ISET)
NSIZEI=SIZEI+0.5
IF(NSIZEI.LE.0)GOTO1850
C
TAGI=XIDTEM(ISET)
C
J=J+1
Y2(J)=CI
X2(J)=TAGI
D2(J)=1.0
C
J=J+1
YMID=CBARG
Y2(J)=YMID
X2(J)=TAGI
D2(J)=2.0
C
J=J+1
VARCI=0.0
IF(ANI.GT.0.0)VARCI=CBARG
SDCI=0.0
IF(VARCI.GT.0.0)SDCI=SQRT(VARCI)
YUPPER=YMID+3.0*SDCI
Y2(J)=YUPPER
X2(J)=TAGI
D2(J)=3.0
C
J=J+1
YLOWER=YMID-3.0*SDCI
IF(YLOWER.LT.0.0)YLOWER=0.0
Y2(J)=YLOWER
X2(J)=TAGI
D2(J)=4.0
C
IF(CCTARG.EQ.CPUMIN)GOTO1871
J=J+1
Y2(J)=CCTARG
X2(J)=XIDTEM(ISET)
D2(J)=5.0
1871 CONTINUE
C
IF(CCUSL.EQ.CPUMIN)GOTO1872
J=J+1
Y2(J)=CCUSL
X2(J)=XIDTEM(ISET)
D2(J)=6.0
1872 CONTINUE
C
IF(CCLSL.EQ.CPUMIN)GOTO1873
J=J+1
Y2(J)=CCLSL
X2(J)=XIDTEM(ISET)
D2(J)=7.0
1873 CONTINUE
C
1850 CONTINUE
N2=J
NPLOTV=3
GOTO9000
C
C ******************
C ** STEP 90-- **
C ** EXIT **
C ******************
C
9000 CONTINUE
IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'QCC2')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPQCC2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)ICASPL,N,NUMSET,N2,IERROR
9012 FORMAT('ICASPL,N,NUMSET,N2,IERROR = ',A4,3I8,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)NUMV2,ISIZE
9013 FORMAT('NUMV2,ISIZE = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)AN,XBARG,SDG,RANGEG
9014 FORMAT('AN,XBARG,SDG,RANGEG = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)ANUMSE,SIGMAE,RANGEE
9015 FORMAT('ANUMSE,SIGMAE,RANGEE = ',3E15.7)
CALL DPWRST('XXX','BUG ')
DO9020I=1,N2
WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I)
9021 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2)
CALL DPWRST('XXX','BUG ')
9020 CONTINUE
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPQUAD(IHARG,NUMARG,IDEFPR,IHMXPR,
1IPREC,IFOUND,IERROR)
C
C PURPOSE--DEFINE THE PREICSION SWITCH
C AS QUADRUPLE PRECISION.
C THIS IN TURN SPECIFIES THAT SUBSEQUENT
C CALCULATIONS WILL ALL BE CARRIED OUT
C IN QUADRUPLE PRECISION.
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')GOTO1130
IF(IHARG(NUMARG).EQ.'OFF')GOTO1120
IF(IHARG(NUMARG).EQ.'AUTO')GOTO1130
IF(IHARG(NUMARG).EQ.'DEFA')GOTO1120
GOTO1130
C
1120 CONTINUE
IHOLD=IDEFPR
GOTO1160
C
1130 CONTINUE
IHOLD='QUAD'
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 DPQUAD--')
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 DPQUAN(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1IANGLU,MAXNPP,
1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
C
C PURPOSE--FORM A QUANTILE PLOT
C (USEFUL FOR DISTRIBUTIONALLY COMPARING 2 DATA SETS).
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--87/5
C ORIGINAL VERSION--MAY 1987.
C UPDATED --MARCH 1988. ACTIVATE QUANTILE-QUANTILE
C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON
C MOVE SOME DIMENSIONS FROM DPQUA2
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 ICASPL
CHARACTER*4 IAND1
CHARACTER*4 IAND2
CHARACTER*4 IANGLU
CHARACTER*4 IBUGG2
CHARACTER*4 IBUGG3
CHARACTER*4 IBUGQ
CHARACTER*4 ISUBRO
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 ICASEQ
C
CHARACTER*4 IHRI11
CHARACTER*4 IHRI12
CHARACTER*4 IHRI21
CHARACTER*4 IHRI22
CCCCC CHARACTER*4 IHRI31
CCCCC CHARACTER*4 IHRI32
CCCCC CHARACTER*4 IHRI41
CCCCC CHARACTER*4 IHRI42
CHARACTER*4 IHRIX1
CHARACTER*4 IHRIX2
C
CHARACTER*4 IERRO4
C
CHARACTER*4 ICTAR1
CHARACTER*4 ICTAR2
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
INCLUDE 'DPCOPA.INC'
DIMENSION Y1(MAXOBV)
DIMENSION Y2(MAXOBV)
DIMENSION Y3(MAXOBV)
DIMENSION Y4(MAXOBV)
DIMENSION XD(MAXOBV)
DIMENSION YD(MAXOBV)
CCCCC FOLLOWING LINES ADDED JUNE, 1990
INCLUDE 'DPCOZZ.INC'
DIMENSION YLARGE(MAXOBV)
DIMENSION YSMALL(MAXOBV)
EQUIVALENCE (GARBAG(IGARB1),Y1(1))
EQUIVALENCE (GARBAG(IGARB2),Y2(1))
EQUIVALENCE (GARBAG(IGARB3),Y3(1))
EQUIVALENCE (GARBAG(IGARB4),Y4(1))
EQUIVALENCE (GARBAG(IGARB5),XD(1))
EQUIVALENCE (GARBAG(IGARB6),YD(1))
EQUIVALENCE (GARBAG(IGARB7),YLARGE(1))
EQUIVALENCE (GARBAG(IGARB8),YSMALL(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
ISUBN1='DPQU'
ISUBN2='AN '
C
IFOUND='NO'
IERROR='NO'
C
MAXCP1=MAXCOL+1
MAXCP2=MAXCOL+2
MAXCP3=MAXCOL+3
MAXCP4=MAXCOL+4
MAXCP5=MAXCOL+5
MAXCP6=MAXCOL+6
C
MINN2=2
C
IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'QUAN')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPQUAN--')
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,IBUGQ
54 FORMAT('IANGLU,IBUGG2,IBUGG3,IBUGQ = ',
1A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,56)ICASPL,MAXN
56 FORMAT('ICASPL,MAXN = ',A4,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,57)IFOUND,IERROR
57 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,58)MAXNPP
58 FORMAT('MAXNPP = ',I8)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C ***********************************
C ** TREAT THE QUANTILE PLOT CASE **
C ***********************************
C
C ***************************
C ** STEP 11-- **
C ** EXTRACT THE COMMAND **
C ***************************
C
ISTEPN='11'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'QUAN')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CCCCC IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')GOTO1111 MARCH 1988
IF(NUMARG.GE.2.AND.IHARG(1).EQ.'QUAN'.AND.
1 IHARG(2).EQ.'PLOT')GOTO1112
GOTO9000
C
C1111 CONTINUE
CCCCC ILASTC=1
CCCCC CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
CCCCC GOTO1190
C
1112 CONTINUE
ILASTC=2
CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
GOTO1190
C
1190 CONTINUE
IFOUND='YES'
ICASPL='QUAN'
C
C ********************************************************
C ** STEP 12-- **
C ** CARRY OUT A GENERAL CHECK FOR THE **
C ** PROPER NUMBER OF INPUT ARGUMENTS **
C ** (IT SHOULD BE EXACTLY 2). **
C ********************************************************
C
ISTEPN='12'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'QUAN')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
MINNA=2
MAXNA=100
CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
C
C *****************************************
C ** STEP 13-- **
C ** CHECK TO SEE THE TYPE CASE-- **
C ** 1) UNQUALIFIED (THAT IS, FULL); **
C ** 2) SUBSET/EXCEPT; OR **
C ** 3) FOR. **
C *****************************************
C
ISTEPN='13'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'QUAN')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ICASEQ='FULL'
ILOCQ=NUMARG+1
IF(NUMARG.LT.1)GOTO1390
DO1300J=1,NUMARG
J1=J
IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO1310
IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO1310
IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO1320
1300 CONTINUE
GOTO1390
1310 CONTINUE
ICASEQ='SUBS'
ILOCQ=J1
GOTO1390
1320 CONTINUE
ICASEQ='FOR'
ILOCQ=J1
GOTO1390
1390 CONTINUE
IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'QUAN')GOTO1395
WRITE(ICOUT,1391)ICASEQ,NUMARG,ILOCQ
1391 FORMAT('ICASEQ,NUMARG,ILOCQ = ',A4,2X,2I8)
CALL DPWRST('XXX','BUG ')
1395 CONTINUE
C
C ********************************************************
C ** STEP 14-- **
C ** CARRY OUT A SPECIFIC CHECK FOR THE **
C ** PROPER NUMBER OF INPUT ARGUMENTS **
C ** (IT SHOULD BE EXACTLY 2). **
C ********************************************************
C
ISTEPN='14'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'QUAN')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
NUMVAR=ILOCQ-1
IF(NUMVAR.EQ.2)GOTO1490
GOTO1410
C
1410 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1411)
1411 FORMAT('***** ERROR IN DPQUAN--')
CALL DPWRST('XXX','BUG ')
IF(ICASPL.EQ.'MECC')WRITE(ICOUT,1412)
1412 FORMAT(' FOR A QUANTILE PLOT, ')
IF(ICASPL.EQ.'MECC')CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1418)
1418 FORMAT(' THE NUMBER OF VARIABLES ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1419)
1419 FORMAT(' MUST BE EXACTLY 2 ;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1420)
1420 FORMAT(' SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1421)
1421 FORMAT(' THE SPECIFIED NUMBER')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1422)NUMVAR
1422 FORMAT(' OF VARIABLES WAS ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1423)
1423 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,1424)(IANS(I),I=1,IWIDTH)
1424 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
1490 CONTINUE
C
C ****************************************************************
C ** STEP 15-- *
C ** EXAMINE THE VARIABLES-- *
C ** HAS EACH VARIABLE *
C ** ALREADY BEEN DEFINED? *
C ** NOTE THAT ILISR1, ILISR2, *
C ** IS THE LINE IN THE TABLE *
C ** OF THE FIRST, SECOND VARIABLE *
C ** RESPECTIVELY. *
C ** NOTE THAT ICOLR1, ICOLR2, *
C ** IS THE DATA COLUMN (1 TO 10+6) *
C ** OF THE FIRST, SECOND VARIABLE *
C ** RESPECTIVELY. *
C ****************************************************************
C
ISTEPN='15'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'QUAN')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ICTAR1='FIRS'
ICTAR2='T '
ILOCR1=1
IHRI11=IHARG(ILOCR1)
IHRI12=IHARG2(ILOCR1)
IHRIX1=IHRI11
IHRIX2=IHRI12
DO1510I=1,NUMNAM
I2=I
IF(IHRI11.EQ.IHNAME(I).AND.IHRI12.EQ.IHNAM2(I).AND.
1IUSE(I).EQ.'V')GOTO1519
IF(IHRI11.EQ.IHNAME(I).AND.IHRI12.EQ.IHNAM2(I).AND.
1IUSE(I).EQ.'P')GOTO1560
1510 CONTINUE
GOTO1570
1519 CONTINUE
ILISR1=I2
ICOLR1=IVALUE(ILISR1)
NIRIG1=IN(ILISR1)
C
ICTAR1='SECO'
ICTAR2='ND '
ILOCR2=2
IHRI21=IHARG(ILOCR2)
IHRI22=IHARG2(ILOCR2)
IHRIX1=IHRI21
IHRIX2=IHRI22
DO1520I=1,NUMNAM
I2=I
IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I).AND.
1IUSE(I).EQ.'V')GOTO1529
IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I).AND.
1IUSE(I).EQ.'P')GOTO1560
1520 CONTINUE
GOTO1570
1529 CONTINUE
ILISR2=I2
ICOLR2=IVALUE(ILISR2)
NIRIG2=IN(ILISR2)
GOTO1590
C
1560 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1561)
1561 FORMAT('***** ERROR IN DPQUAN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1562)ICTAR1,ICTAR2
1562 FORMAT(' THE SPECIFIED ',A4,A4,' ARGUMENT ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1563)IHRIX1,IHRIX2
1563 FORMAT(' (',A4,A4,')')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1565)
1565 FORMAT(' WAS FOUND IN THE INTERNAL NAME LIST,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1566)
1566 FORMAT(' BUT AS A PARAMETER,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1567)
1567 FORMAT(' AND NOT AS A VARIABLE AS IT SHOULD BE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1568)
1568 FORMAT(' THE COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1569)(IANS(I),I=1,IWIDTH)
1569 FORMAT(80A1)
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
1570 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1571)
1571 FORMAT('***** ERROR IN DPQUAN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1572)ICTAR1,ICTAR2
1572 FORMAT(' THE SPECIFIED ',A4,A4,' ARGUMENT ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1573)IHRIX1,IHRIX2
1573 FORMAT(' (',A4,A4,')')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1575)
1575 FORMAT(' WAS NOT FOUND IN THE INTERNAL NAME LIST')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1576)
1576 FORMAT(' OF AVAILABLE VARIABLE NAMES.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1577)IHRI11,IHRI12
1577 FORMAT(' THE VARIABLE IN QUESTION WAS ',A4,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1578)
1578 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,1579)(IANS(I),I=1,IWIDTH)
1579 FORMAT(80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
1590 CONTINUE
C
C *********************************************
C ** STEP 32-- **
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='32'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'QUAN')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
NLOCAL=NIRIG1
IF(NIRIG2.GT.NIRIG1)NLOCAL=NIRIG2
C
IF(ICASEQ.EQ.'FULL')GOTO3210
IF(ICASEQ.EQ.'SUBS')GOTO3220
IF(ICASEQ.EQ.'FOR')GOTO3230
C
3210 CONTINUE
DO3215I=1,NLOCAL
ISUB(I)=1
3215 CONTINUE
NQ=NLOCAL
GOTO3250
C
3220 CONTINUE
NIOLD=NLOCAL
CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4)
NQ=NIOLD
GOTO3250
C
3230 CONTINUE
NIOLD=NLOCAL
CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
1NLOCAL,ILOCS,NS,IBUGQ,IERRO4)
NQ=NFOR
GOTO3250
C
3250 CONTINUE
IF(NQ.GE.MINN2)GOTO3290
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3251)
3251 FORMAT('***** ERROR IN DPQUAN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3252)
3252 FORMAT(' AFTER THE APPROPRIATE SUBSET ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3253)
3253 FORMAT(' HAS BEEN EXTRACTED,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3254)IHRI11,IHRI12
3254 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING',
1'FROM VARIABLE ',A4,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3255)
3255 FORMAT(' (FOR WHICH A QUANTILE PLOT ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3256)
3256 FORMAT(' IS TO BE FORMED)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3257)MINN2
3257 FORMAT(' MUST BE ',I8,' OR LARGER;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3258)NQ
3258 FORMAT(' SUCH WAS NOT THE CASE HERE (NQ = ',I8,')')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3259)
3259 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,3260)(IANS(I),I=1,IWIDTH)
3260 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
3290 CONTINUE
C
C **********************************************
C ** STEP 33-- **
C ** FORM THE SUBSETTED VARIABLES **
C ** Y1(.) **
C ** Y2(.) **
C ** CONTAINING **
C ** THE VERTICAL AXIS VARIABLE **
C ** THE HORIZONTAL AXIS VARIABLE **
C ** RESPECTIVELY. **
C **********************************************
C
ISTEPN='33'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'QUAN')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
J=0
IMAX=NIRIG1
IF(NQ.LT.NIRIG1)IMAX=NQ
DO3310I=1,IMAX
IF(ISUB(I).EQ.0)GOTO3310
J=J+1
IJ=MAXN*(ICOLR1-1)+I
IF(ICOLR1.LE.MAXCOL)Y1(J)=V(IJ)
IF(ICOLR1.EQ.MAXCP1)Y1(J)=PRED(I)
IF(ICOLR1.EQ.MAXCP2)Y1(J)=RES(I)
IF(ICOLR1.EQ.MAXCP3)Y1(J)=YPLOT(I)
IF(ICOLR1.EQ.MAXCP4)Y1(J)=XPLOT(I)
IF(ICOLR1.EQ.MAXCP5)Y1(J)=X2PLOT(I)
IF(ICOLR1.EQ.MAXCP6)Y1(J)=TAGPLO(I)
3310 CONTINUE
NS1=J
C
J=0
IMAX=NIRIG2
IF(NQ.LT.NIRIG2)IMAX=NQ
DO3320I=1,IMAX
IF(ISUB(I).EQ.0)GOTO3320
J=J+1
IJ=MAXN*(ICOLR2-1)+I
IF(ICOLR2.LE.MAXCOL)Y2(J)=V(IJ)
IF(ICOLR2.EQ.MAXCP1)Y2(J)=PRED(I)
IF(ICOLR2.EQ.MAXCP2)Y2(J)=RES(I)
IF(ICOLR2.EQ.MAXCP3)Y2(J)=YPLOT(I)
IF(ICOLR2.EQ.MAXCP4)Y2(J)=XPLOT(I)
IF(ICOLR2.EQ.MAXCP5)Y2(J)=X2PLOT(I)
IF(ICOLR2.EQ.MAXCP6)Y2(J)=TAGPLO(I)
3320 CONTINUE
NS2=J
C
C *********************************************
C ** STEP 34-- **
C ** CHECK TO MAKE SURE THAT **
C ** AFTER SUBSETTING, EACH OF **
C ** THE 2 VARIABLES HAS AT LEAST **
C ** 2 POINTS (THE MINIMUM NEEDED **
C ** TO YIELD A PLOT). **
C *********************************************
C
ISTEPN='34'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'QUAN')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ICOUN1=0
IF(NS1.LE.2)ICOUN1=NS1
IF(NS1.LE.2)GOTO3419
DO3410I=1,NS1
IF(Y1(I).LE.-0.0001.OR.Y1(I).GE.0.0001)ICOUN1=ICOUN1+1
3410 CONTINUE
3419 CONTINUE
IF(ICOUN1.LE.MINN2)GOTO3450
C
ICOUN2=0
IF(NS2.LE.2)ICOUN2=NS2
IF(NS2.LE.2)GOTO3429
DO3420I=1,NS2
IF(Y2(I).LE.-0.0001.OR.Y2(I).GE.0.0001)ICOUN2=ICOUN2+1
3420 CONTINUE
3429 CONTINUE
IF(ICOUN2.LE.MINN2)GOTO3450
GOTO3490
C
3450 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3451)
3451 FORMAT('***** ERROR IN DPQUAN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3452)
3452 FORMAT(' AFTER THE SPECIFIED SUBSETTING ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3453)
3453 FORMAT(' HAS BEEN DONE,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3454)
3454 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3455)
3455 FORMAT(' (FOR WHICH A QUANTILE PLOT ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3456)
3456 FORMAT(' IS TO BE FORMED)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3457)MINN2
3457 FORMAT(' MUST BE ',I8,' OR LARGER;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3458)
3458 FORMAT(' SUCH WAS NOT THE CASE HERE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3459)ICOUN1,ICOUN2
3459 FORMAT('(ICOUN1, ICOUN2 = ',2I8,')')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3460)
3460 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,3461)(IANS(I),I=1,IWIDTH)
3461 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
3490 CONTINUE
C
C ****************************************************************
C ** STEP 41-- *
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='41'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'QUAN')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
NS=NS1
IF(NS2.GT.NS1)NS=NS2
CCCCC JUNE, 1990. MOVE DIMENSION OF YLARGE, YSMALL FROM DPQUA2
CALL DPQUA2(Y1,NS1,Y2,NS2,ICASPL,MAXN,
1Y,X,D,NPLOTP,NPLOTV,
1YLARGE,YSMALL,
1IBUGG3,ISUBRO,IERROR)
C
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'QUAN')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPQUAN--')
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)ICASPL,MAXN,NUMVAR
9014 FORMAT('ICASPL,MAXN,NUMVAR = ',A4,I8,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)NIRIG1,NIRIG2
9015 FORMAT('NIRIG1,NIRIG2 = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9016)NLOCAL,NQ,MINN2
9016 FORMAT('NLOCAL,NQ,MINN2 = ',3I8)
CALL DPWRST('XXX','BUG ')
IF(NPLOTP.LE.0)GOTO9029
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
9029 CONTINUE
WRITE(ICOUT,9031)ICOUN1,ICOUN2
9031 FORMAT('ICOUN1,ICOUN2 = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9051)IHRI11,IHRI12
9051 FORMAT('IHRI11,IHRI12 = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9052)IHRI21,IHRI22
9052 FORMAT('IHRI21,IHRI22 = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9053)NS1,NS2,NS
9053 FORMAT('NS1,NS2,NS = ',3I8)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPQUA2(Y,NY,X,NX,ICASPL,MAXN,
1Y2,X2,D2,N2,NPLOTV,
1YLARGE,YSMALL,
1IBUGG3,ISUBRO,IERROR)
CCCCC JUNE, 1990. MOVE DIMENSION OF YLARGE, YSMALL TO DPQUA2
C
C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
C THAT WILL DEFINE
C A QUANTILE PLOT
C (USEFUL FOR DISTRIBUTIONALLY COMPARING 2 DATA SETS).
C NOTE--THE QUANTILES FOR THE FIRST ARGUMENT WILL APPEAR VERTICALLY;
C THE QUANTILES FOR THE SECOND ARGUMENT WILL APPEAR HORIZONTALLY.
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--87/6
C ORIGINAL VERSION--JUNE 1987.
C UPDATED --MARCH 1988. PUT IN DIAGONAL REFERENCE LINE
C UPDATED --JUNE 1990. MOVE SOME DIMENSIONS TO DPQUAN
C UPDATED --APRIL 1992. N TO NX IN DEBUG STATEMENTS
C UPDATED --NOVEMBER 1994. EQUATE ICASE TO ICASPL
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IBUGG3
CHARACTER*4 ISUBRO
CHARACTER*4 IERROR
C
CHARACTER*4 ICASE
CCCCC ADD FOLLOWING LINE NOVEMBER 1994.
CHARACTER*4 ICASPL
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
INCLUDE 'DPCOPA.INC'
C
DIMENSION Y(*)
DIMENSION X(*)
DIMENSION Y2(*)
DIMENSION X2(*)
DIMENSION D2(*)
C
CCCCC MOVE DIMENSION TO DPQUAN (JUNE, 1990)
CCCCC DIMENSION YLARGE(MAXOBV)
CCCCC DIMENSION YSMALL(MAXOBV)
DIMENSION YLARGE(*)
DIMENSION YSMALL(*)
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='DPQU'
ISUBN2='A2 '
C
IERROR='NO'
C
CCCCC ADD FOLLOWING LINE NOVEMBER 1994.
ICASE=ICASPL
C
ANY=NY
ANX=NX
C
IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'QUA2')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPQUA2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBUGG3,ISUBRO
52 FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 2 LINES WERE FIXED APRIL 1992
CCCCC WRITE(ICOUT,53)ICASPL,MAXN,N,NPLOTV
CCC53 FORMAT('ICASPL,MAXN,N,NPLOTV = ',A4,2X,I8,I8,I8)
CCCCC CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)ICASPL,MAXN,NX,NPLOTV
53 FORMAT('ICASPL,MAXN,NX,NPLOTV = ',A4,2X,I8,I8,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,60)NY
60 FORMAT(' NY = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NY.LE.0)GOTO63
DO61I=1,NY
WRITE(ICOUT,62)I,Y(I)
62 FORMAT('I,Y(I) = ',I8,E12.5)
CALL DPWRST('XXX','BUG ')
61 CONTINUE
63 CONTINUE
WRITE(ICOUT,70)NX
70 FORMAT(' NX = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NX.LE.0)GOTO73
DO71I=1,NX
WRITE(ICOUT,72)I,X(I)
72 FORMAT('I,X(I) = ',I8,E12.5)
CALL DPWRST('XXX','BUG ')
71 CONTINUE
73 CONTINUE
90 CONTINUE
C
C ********************************************
C ** STEP 11-- **
C ** CHECK THE INPUT ARGUMENTS FOR ERRORS **
C ********************************************
C
IF(NY.GE.1.AND.NX.GE.1)GOTO1119
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1111)
1111 FORMAT('***** ERROR IN DPQUA2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1112)
1112 FORMAT(' THE NUMBER OF OBSERVATIONS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1113)
1113 FORMAT(' MUST BE AT LEAST 1;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1114)NY,NX
1114 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',2I6)
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
1119 CONTINUE
C
IF(NY.GE.2.AND.NX.GE.2)GOTO1129
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1121)
1121 FORMAT('***** ERROR IN DPQUA2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1122)
1122 FORMAT(' THE NUMBER OF OBSERVATIONS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1123)
1123 FORMAT(' WAS EXACTLY EQUAL TO 1.')
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
1129 CONTINUE
C
HOLD=Y(1)
DO1130I=1,NY
IF(Y(I).NE.HOLD)GOTO1139
1130 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1131)
1131 FORMAT('***** ERROR IN DPQUA2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1132)
1132 FORMAT(' ALL INPUT RESPONSE VARIABLE ELEMENTS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1133)HOLD
1133 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
1139 CONTINUE
C
HOLD=X(1)
DO1140I=1,NY
IF(X(I).NE.HOLD)GOTO1149
1140 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1141)
1141 FORMAT('***** ERROR IN DPQUA2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1142)
1142 FORMAT(' ALL INPUT RESPONSE VARIABLE ELEMENTS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1143)HOLD
1143 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
1149 CONTINUE
C
C ****************************************************
C ** STEP 21-- **
C ** SORT Y AND SORT X **
C ****************************************************
C
CALL SORT(X,NX,X)
CALL SORT(Y,NY,Y)
C
C *****************************************
C ** STEP 22-- **
C ** DETERMINE THE TYPE CASE **
C ** EQUAL SAMPLE SIZES OR NOT) **
C ** AND BRANCH ACORDINGLY **
C *****************************************
C
ICASE='UNEQ'
IF(NY.EQ.NX)ICASE='EQUA'
IF(ICASE.EQ.'EQUA')GOTO5100
C
C **************************************************
C ** STEP 23-- **
C ** DETERMINE THE SMALLER OF THE 2-- **
C ** NY OR NX **
C ** DETERMINE THE LARGER OF THE 2-- **
C ** NY OR NX **
C **************************************************
C
NSMALL=NX
IF(NY.LT.NX)NSMALL=NY
ANSMAL=NSMALL
C
NLARGE=NX
IF(NY.GT.NX)NLARGE=NY
ANLARG=NLARGE
C
C ****************************************************
C ** STEP 24-- **
C ** STEP THROUGH THE VARIOUS SORTED VALUES OF **
C ** THE SMALLER OF Y OR X. **
C ** COMPUTE A CORRESPONDING PERCENTAGE. **
C ** ESTIMATE THIS PERCENT POINT **
C ** IN THE LARGER OF Y OR X. **
C ****************************************************
C
DO2400I=1,NSMALL
AI=I
PSMALL=(AI-0.5)/ANSMAL
IF(NY.LE.NX)YSMALL(I)=Y(I)
IF(NY.GT.NX)YSMALL(I)=X(I)
C
PLARGE=0.0
DO2410J=1,NLARGE
AJ=J
J2=J
J2M1=J2-1
PPRIOR=PLARGE
PLARGE=(AJ-0.5)/ANLARG
IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QUA2')
1WRITE(ICOUT,777)I,J,J2,J2M1,PSMALL,PLARGE,PPRIOR
777 FORMAT('I,J,J2,J2M1,PSMALL,PLARGE,PPRIOR = ',4I8,3E15.7)
IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'QUA2')
1CALL DPWRST('XXX','BUG ')
IF(PLARGE.LT.PSMALL)GOTO2410
IF(PLARGE.EQ.PSMALL)GOTO2411
GOTO2412
C
2411 CONTINUE
IF(NY.LE.NX)YLARGE(I)=X(J2)
IF(NY.GT.NX)YLARGE(I)=Y(J2)
GOTO2400
C
2412 CONTINUE
RATIO=(PSMALL-PPRIOR)/(PLARGE-PPRIOR)
IF(NY.LE.NX)YLARGE(I)=RATIO*X(J2M1)+(1.0-RATIO)*X(J2)
IF(NY.GT.NX)YLARGE(I)=RATIO*Y(J2M1)+(1.0-RATIO)*Y(J2)
GOTO2400
C
2410 CONTINUE
C
2400 CONTINUE
C
C *******************************************
C ** STEP 51-- **
C ** FORM PLOT COORDINATES **
C *******************************************
C
5100 CONTINUE
IF(ICASE.EQ.'EQUA')GOTO5110
GOTO5120
C
5110 CONTINUE
J=0
DO5111I=1,NY
J=J+1
Y2(J)=Y(J)
X2(J)=X(J)
D2(J)=1.0
5111 CONTINUE
CCCCC N2=J MARCH 1988
CCCCC NPLOTV=2 MARCH 1988
GOTO5180
C
5120 CONTINUE
J=0
DO5121I=1,NSMALL
J=J+1
IF(NY.LE.NX)Y2(J)=YSMALL(I)
IF(NY.GT.NX)Y2(J)=YLARGE(I)
IF(NY.LE.NX)X2(J)=YLARGE(I)
IF(NY.GT.NX)X2(J)=YSMALL(I)
D2(J)=1.0
5121 CONTINUE
CCCCC N2=J MARCH 1988
CCCCC NPLOTV=2 MARCH 1988
GOTO5180
C
CCCCC THE FOLLOWING SECTION WAS INSERTED MARCH 1988
5180 CONTINUE
AMIN=X(1)
IF(Y(1).LT.X(1))AMIN=Y(1)
J=J+1
Y2(J)=AMIN
X2(J)=AMIN
D2(J)=2.0
C
AMAX=X(NX)
IF(Y(NY).GT.X(NX))AMAX=Y(NY)
J=J+1
Y2(J)=AMAX
X2(J)=AMAX
D2(J)=2.0
C
N2=J
NPLOTV=3
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 DPQUA2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)ICASPL,MAXN,N2,IERROR
9012 FORMAT('ICASPL,MAXN,N2,IERROR = ',A4,I8,I8,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)ICASE
9013 FORMAT('ICASE = ',A4)
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
WRITE(ICOUT,9031)NLARGE
9031 FORMAT('NLARGE = ',I8)
CALL DPWRST('XXX','BUG ')
DO9032I=1,NLARGE
WRITE(ICOUT,9033)I,YLARGE(I)
9033 FORMAT('I,YLARGE(I) = ',I8,E15.7)
CALL DPWRST('XXX','BUG ')
9032 CONTINUE
WRITE(ICOUT,9041)NSMALL
9041 FORMAT('NSMALL = ',I8)
CALL DPWRST('XXX','BUG ')
DO9042I=1,NSMALL
WRITE(ICOUT,9043)I,YSMALL(I)
9043 FORMAT('I,YSMALL(I) = ',I8,E15.7)
CALL DPWRST('XXX','BUG ')
9042 CONTINUE
WRITE(ICOUT,9051)NY,NX,NSMALL,NLARGE
9051 FORMAT('NY,NX,NSMALL,NLARGE = ',4I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9052)RATIO
9052 FORMAT('RATIO = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9053)AMIN,AMAX
9053 FORMAT('AMIN,AMAX = ',2E15.7)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPQUCO(XTEMP1,XTEMP2,MAXNXT,ICASAN,
1ICAPSW,
1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
C
C PURPOSE--GENERATE CONFIDENCE LIMITS FOR QUANTILES (MEDIAN IS
C A SPECIAL CASE). METHOD BASED ON MARITZ-JARRETT
C ESTIMATE FOR STANDARD ERROR.
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 REFERENCE--"INTRODUCTION TO ROBUST ESTIMATION AND HYPOTHESIS
C TESTING", RAND R. WILCOX, ACADEMIC PRESS, 1997.
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--2003/2
C ORIGINAL VERSION--FEBRUARY 2003.
C UPDATED --OCTOBER 2003. SUPPORT FOR HTML, LATEX OUTPUT
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IBUGA2
CHARACTER*4 IBUGA3
CHARACTER*4 IBUGQ
CHARACTER*4 ISUBRO
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
CHARACTER*4 IHP
CHARACTER*4 IHP2
C
CHARACTER*4 IHWUSE
CHARACTER*4 MESSAG
CHARACTER*4 ICASEQ
CHARACTER*4 IHLEFT
CHARACTER*4 IHLEF2
CCCCC CHARACTER*4 IH21
CCCCC CHARACTER*4 IH22
C
CHARACTER*4 ICASAN
CHARACTER*4 ICAPSW
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
INCLUDE 'DPCOPA.INC'
C
DIMENSION XTEMP1(*)
DIMENSION XTEMP2(*)
C
DIMENSION W(MAXOBV)
C
INCLUDE 'DPCOZZ.INC'
EQUIVALENCE (GARBAG(IGARB1),W(1))
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCOHK.INC'
INCLUDE '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='DPTM'
ISUBN2='CO '
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
MINN2=3
C
IFOUND='YES'
C
NLEFT=0
N2=0
C
ICASEQ='UNKN'
C
C *****************************************************
C ** TREAT THE QUANTILE CONFIDENCE LIMITS CASE **
C *****************************************************
C
IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUCO')THEN
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPQUCO--')
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,57)ICASAN
57 FORMAT('ICASAN = ',A4)
CALL DPWRST('XXX','BUG ')
ENDIF
C
C *******************************************************
C ** STEP 2-- **
C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. **
C *******************************************************
C
ISTEPN='2'
IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUCO')
1CALL 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'.OR.ISUBRO.EQ.'QUCO')
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)
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'.OR.ISUBRO.EQ.'QUCO')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(NLEFT.GE.MINN2)GOTO390
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,311)
311 FORMAT('***** ERROR IN DPQUCO--')
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 QUANTILE 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,MAX(IWIDTH,80))
318 FORMAT(80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
390 CONTINUE
C
C *****************************************
C ** STEP 5-- **
C ** CHECK TO SEE THE TYPE CASE-- **
C ** 1) UNQUALIFIED (THAT IS, FULL); **
C ** 2) SUBSET/EXCEPT; OR **
C ** 3) FOR. **
C *****************************************
C
ISTEPN='5'
IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'ON')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ICASEQ='FULL'
ILOCQ=NUMARG+1
IF(NUMARG.LT.1)GOTO490
DO400J=1,NUMARG
J1=J
IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO410
IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO410
IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO420
400 CONTINUE
GOTO490
410 CONTINUE
ICASEQ='SUBS'
ILOCQ=J1
GOTO490
420 CONTINUE
ICASEQ='FOR'
ILOCQ=J1
GOTO490
490 CONTINUE
IF(IBUGA2.EQ.'OFF')GOTO495
WRITE(ICOUT,491)NUMARG,ILOCQ
491 FORMAT('NUMARG,ILOCQ = ',2I8)
CALL DPWRST('XXX','BUG ')
495 CONTINUE
C
C *********************************************
C ** STEP 5-- **
C ** TEMPORARILY FORM THE VARIABLE Y(.) **
C ** WHICH WILL HOLD THE RESPONSE VARIABLE. **
C ** FORM THIS VARIABLE BY **
C ** BRANCHING TO THE APPROPRIATE SUBCASE **
C ** (FULL, SUBSET, OR FOR). **
C *********************************************
C
ISTEPN='5'
IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUCO')
1CALL 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 DPQUCO--')
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 QUANTILE 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)
C
570 CONTINUE
NS=J
C
C ******************************************************
C ** STEP 8--
C ** PREPARE FOR ENTRANCE INTO DPQUC2--
C ** SET THE WEIGHT VECTOR TO UNITY THROUGHOUT.
C ******************************************************
C
ISTEPN='8'
IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUCO')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
DO1110I=1,NS
W(I)=1.0
1110 CONTINUE
C
C ******************************************************
C ** STEP 9-- **
C ** DETERMINE VALUE OF TRIMMING CONSTANTS (OBTAINED **
C ** FROM PARAMETER P100) **
C ******************************************************
C
IF(ICASAN.EQ.'MECI')THEN
P100=0.50
ELSE
IHP='P100'
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
P100=VALUE(ILOCP)
IF(P100.GE.1.0 .AND. P100.LE.100.0)P100=P100/100.0
ENDIF
C
IF(0.0.LE.P100.AND.P100.LE.1.0)GOTO11589
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11581)
11581 FORMAT('***** ERROR IN DPQUCO--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11582)
11582 FORMAT('THE QUANTILE FOR WHICH THE CONFIDENCE INTERVAL IS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11583)
11583 FORMAT('MTO BE COMPUTED MUST BE BETWEEN 0 AND 1, BUT WAS NOT.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11584)P100
11584 FORMAT('PARAMETER P100 = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11586)
11586 FORMAT('USE THE LET COMMAND TO PRE-DEFINE P100:')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11587)
11587 FORMAT(' LET P1 = 0.5')
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
11589 CONTINUE
C
C *********************************
C ** STEP 9-- **
C ** FORM THE CONFIDENCE LIMITS **
C *********************************
C
ISTEPN='9'
IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUCO')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUCO')THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1211)
1211 FORMAT('***** FROM DPQUCO, AS WE ARE ABOUT TO CALL DPBWC2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1212)NLEFT,MAXN,NS
1212 FORMAT('NLEFT,MAXN,NS = ',3I8)
CALL DPWRST('XXX','BUG ')
DO1215I=1,NS
WRITE(ICOUT,1216)I,Y(I),W(I)
1216 FORMAT('I,Y(I),W(I) = ',I8,2E15.7)
CALL DPWRST('XXX','BUG ')
1215 CONTINUE
CCCCC IBUGA3='ABCD'
WRITE(ICOUT,1231)IBUGA3
1231 FORMAT('IBUGA3 = ',A4)
CALL DPWRST('XXX','BUG ')
ENDIF
C
CALL DPQUC2(Y,W,NS,X,NS2,XTEMP1,XTEMP2,MAXNXT,
1P100,
1ICAPSW,ICAPTY,
1ICASAN,IBUGA3,ISUBRO,IERROR)
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'QUCO')THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPQUCO--')
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 ')
ENDIF
C
RETURN
END
SUBROUTINE DPQUC2(Y,W,N,X,N2,XTEMP1,XTEMP2,MAXNXT,
1P100,
1ICAPSW,ICAPTY,
1ICASAN,IBUGA3,ISUBRO,IERROR)
C
C PURPOSE--THIS ROUTINE GENERATES QUANTILE CONFIDENCE LIMITS
C FOR THE DATA IN THE INPUT VECTOR Y.
C THE MEDIAN IS A SPECIAL CASE. SPECIFICALLY,
C X(0.5) +/- NORPPF(1-ALPHA/2)*QUASE
C WHERE QUASE IS THE MARITZ-JARRETT ESTIMATE OF
C THE QUANTILE STANDARD ERROR.
C METHOD FROM PAGE 87 OF THE RAND WILCOX BOOK
C "INTRODUCTION TO ROBUST ESTIMATION AND HYPOTHESIS
C TESTING", ACADEMIC PRESS, 1997.
C ALSO VIA THE HETTMANSPERGER-SHEATHER INTERPOLATION
C METHOD (ALSO PAGE 87 OF WILCOX).
C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR
C OF OBSERVATIONS
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--2003/2
C ORIGINAL VERSION--FEBRUARY 2003.
C UPDATED --OCTOBER 2003. SUPPORT FOR HTML, LATEX OUTPUT
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IBUGA3
CHARACTER*4 ISUBRO
CHARACTER*4 IERROR
C
CHARACTER*4 IWRITE
CHARACTER*4 ICASAN
CHARACTER*4 IQUASE
CHARACTER*4 IQUAME
CHARACTER*4 ICAPSW
CHARACTER*4 ICAPTY
CHARACTER*1 IBASLC
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
DIMENSION Y(*)
DIMENSION X(*)
DIMENSION W(*)
DIMENSION XTEMP1(*)
DIMENSION XTEMP2(*)
C
DIMENSION CONF(10)
DIMENSION T(10)
DIMENSION TSDM(10)
DIMENSION ALOWER(10)
DIMENSION AUPPER(10)
DIMENSION ALOWE2(10)
DIMENSION AUPPE2(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='DPQU'
ISUBN2='C2 '
C
IQUAME='ORDE'
IQUASE='MJ'
IERROR='NO'
C
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'QUC2')THEN
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,51)
51 FORMAT('**** AT THE BEGINNING OF DPQUC2--')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,52)N,P100,IBUGA3
52 FORMAT('N,P100,IBUGA3 = ',I8,2X,E15.7,2X,A4)
CALL DPWRST('XXX','WRIT')
DO56I=1,N
WRITE(ICOUT,57)I,Y(I),W(I),X(I)
57 FORMAT('I,Y(I),W(I),X(I) = ',I8,3E15.7)
CALL DPWRST('XXX','WRIT')
56 CONTINUE
WRITE(ICOUT,58)ICASAN
58 FORMAT('ICASAN = ',A4)
CALL DPWRST('XXX','WRIT')
ENDIF
C
C ********************************************
C ** STEP 1-- **
C ** CHECK THE INPUT ARGUMENTS FOR ERRORS **
C ********************************************
C
ISTEPN='1'
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'QUC2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(N.GT.3)GOTO119
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,111)
111 FORMAT('***** ERROR IN DPQUC2--THE NUMBER OF OBSERVATIONS ',
1'IN THE RESPONSE VARIABLE IS LESS THAN 3')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,112)N
112 FORMAT('SAMPLE SIZE = ',I8)
CALL DPWRST('XXX','WRIT')
IERROR='YES'
GOTO9000
119 CONTINUE
C
HOLD=Y(1)
DO135I=2,N
IF(Y(I).NE.HOLD)GOTO139
135 CONTINUE
130 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,131)HOLD
131 FORMAT('***** NOTE FROM DPQUC2--THE RESPONSE VARIABLE ',
1'HAS ALL ELEMENTS = ',E15.7)
CALL DPWRST('XXX','WRIT')
GOTO9000
139 CONTINUE
C
C ***************************************************
C ** STEP 3-- **
C ** COMPUTE THE QUANTILE ESTIMATE **
C ** COMPUTE THE QUANTILE STANDARD ERROR **
C ***************************************************
C
C
ISTEPN='3'
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'QUC2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IWRITE='OFF'
C
IF(ICASAN.EQ.'MECI')THEN
CALL MEDIAN(Y,N,IWRITE,XTEMP1,MAXNXT,XQUANT,IBUGA3,IERROR)
ELSE
CALL QUANT(P100,Y,N,IWRITE,XTEMP1,MAXNXT,IQUAME,XQUANT,
1 IBUGA3,IERROR)
ENDIF
CALL QUANSE(P100,Y,N,IWRITE,XTEMP1,MAXNXT,IQUASE,XQUASE,
1IBUGA3,IERROR)
C
C ***************************************
C ** STEP 4-- **
C ** COMPUTE CONFIDENCE LIMITS **
C ** FOR VARIOUS PROBABILITY VALUES. **
C ***************************************
C
ISTEPN='4'
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'QUC2')
1CALL 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
DO1400I=1,8
PCONF=CONF(I)/100.0
CDF=0.5+PCONF/2.0
CALL NORPPF(CDF,T(I))
TSDM(I)=T(I)*XQUASE
ALOWER(I)=XQUANT-TSDM(I)
AUPPER(I)=XQUANT+TSDM(I)
1400 CONTINUE
C
C ***************************************
C ** STEP 5-- **
C ** COMPUTE CONFIDENCE LIMITS **
C ** FOR HETTMANSPERGER-SHEATHER **
C ** INTERPOLATION METHOD. **
C ***************************************
C
IF(ICASAN.EQ.'MECI')THEN
P=0.5
AN=REAL(N)
CALL SORT(Y,N,Y)
DO2010I=1,8
ALPHA=(100.0-CONF(I))/100.
CALL BINPPF(ALPHA/2.0,P,N,AK)
CALL BINCDF(AN-AK,P,N,CDF1)
CALL BINCDF(AK-1.0,P,N,CDF2)
GK=CDF1-CDF2
IF(GK.GE.1.0-ALPHA)THEN
CALL BINCDF(AN-AK-1.0,P,N,CDF1)
CALL BINCDF(AK-1.0,P,N,CDF2)
GKP1=CDF1-CDF2
AKP=AK+1.0
ELSE
AK=AK-1.0
CALL BINCDF(AN-AK,P,N,CDF1)
CALL BINCDF(AK-1.0,P,N,CDF2)
GKP1=CDF1-CDF2
AKP=AK+1.0
ENDIF
ANMK=AN-AK
ANMKP=ANMK+1.0
AIVAR=(GK-1.0+ALPHA)/(GK-GKP1)
ALAMB=((AN-AK)*AIVAR)/(AK+(AN-2.0*AK)*AIVAR)
ALOWE2(I)=ALAMB*Y(INT(AKP)) + (1.0-ALAMB)*Y(INT(AK))
AUPPE2(I)=ALAMB*Y(INT(ANMK)) + (1.0-ALAMB)*Y(INT(ANMKP))
2010 CONTINUE
ENDIF
C
C ****************************
C ** STEP 7-- **
C ** WRITE EVERYTHING OUT **
C ****************************
C
ISTEPN='7'
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'QUC2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IPRINT.EQ.'ON')THEN
CCCCC OCTOBER 2003: WRITE OUTPUT IN HTML FORMAT
IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN
C
C STEP 1: END ASIS MODE AND WRITE A HEADER
C
5001 FORMAT('')
5004 FORMAT('
')
WRITE(ICOUT,5001)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5004)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
C
C STEP 2: START TABLE AND DEFINE A CAPTION
C
5011 FORMAT('')
5013 FORMAT('')
5015 FORMAT(' ')
5017 FORMAT(' Confidence Limits for Median
')
5018 FORMAT(' (Based on Maritz-Jarrett Standard Error for ',
1 'Quantiles)')
5019 FORMAT(' ')
5021 FORMAT(' Confidence Limits for Quantile ',
1 '(Q0 = ',F6.3,')
')
WRITE(ICOUT,5011)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5013)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5015)
CALL DPWRST('XXX','WRIT')
IF(ICASAN.EQ.'MECI')THEN
WRITE(ICOUT,5017)
ELSE
WRITE(ICOUT,5021)P100
ENDIF
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5018)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5019)
CALL DPWRST('XXX','WRIT')
C
C STEP 3: DEFINE DATA ROW
C
5041 FORMAT(' ')
5043 FORMAT(' | ')
5045 FORMAT(' Number of Observations:')
5047 FORMAT(' | ')
5049 FORMAT(' ')
5031 FORMAT(' ',G15.7)
5033 FORMAT(' ',I8)
5039 FORMAT(' |
')
5051 FORMAT(' Estimate of Median:')
5052 FORMAT(' Estimate of Quantile:')
5053 FORMAT(' Quantile Standard Error:')
WRITE(ICOUT,5041)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5043)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5045)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5049)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5033)N
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5039)
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,5041)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5043)
CALL DPWRST('XXX','WRIT')
IF(ICASAN.EQ.'MECI')THEN
WRITE(ICOUT,5051)
ELSE
WRITE(ICOUT,5052)
ENDIF
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5049)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5031)XQUANT
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5039)
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,5041)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5043)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5053)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5049)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5031)XQUASE
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5039)
CALL DPWRST('XXX','WRIT')
C
C STEP 4: END THE TABLE AND RESET ASIS MODE
C
5091 FORMAT('
')
5093 FORMAT('
')
5099 FORMAT('')
WRITE(ICOUT,5091)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5093)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
C
C STEP 2B: START TABLE AND DEFINE A CAPTION
C
WRITE(ICOUT,5004)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5011)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5013)
CALL DPWRST('XXX','WRIT')
C
C STEP 3B: DEFINE HEADER ROW
C
5121 FORMAT(' ')
5123 FORMAT(' | ')
5127 FORMAT(' | ')
5139 FORMAT('
')
5131 FORMAT(' Confidence
Value (%)')
5132 FORMAT(' Z
Value')
5133 FORMAT(' Z X Standard Error)')
5134 FORMAT(' Lower
Limit')
5135 FORMAT(' Upper
Limit')
5161 FORMAT(' ')
5162 FORMAT('
')
WRITE(ICOUT,5121)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5123)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5131)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5127)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5123)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5132)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5127)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5123)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5133)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5127)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5123)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5134)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5127)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5123)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5135)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5127)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5139)
CALL DPWRST('XXX','WRIT')
C
C FOLLOWING ADDS A RULE LINE BETWEEN HEADER AND DATA LINES
C
WRITE(ICOUT,5041)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5161)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5162)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5039)
CALL DPWRST('XXX','WRIT')
C
C STEP 4: DEFINE DATA ROW
C
5141 FORMAT(' | ')
5143 FORMAT(' | ')
5147 FORMAT(' | ')
5151 FORMAT(' ',F8.3)
5152 FORMAT(' ',G12.6)
5149 FORMAT('
')
DO5180I=1,8
WRITE(ICOUT,5141)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5143)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5151)CONF(I)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5147)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5143)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5151)T(I)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5147)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5143)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5152)TSDM(I)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5147)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5143)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5152)ALOWER(I)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5147)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5143)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5152)AUPPER(I)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5147)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5149)
CALL DPWRST('XXX','WRIT')
5180 CONTINUE
C
C STEP 4: END THE TABLE AND RESET ASIS MODE
C
5191 FORMAT('')
5193 FORMAT('')
5199 FORMAT('')
WRITE(ICOUT,5191)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5193)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5199)
CALL DPWRST('XXX','WRIT')
C
CCCCC WRITE OUTPUT IN LATEX FORMAT
ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN
C
C STEP 1: END ASIS FORMAT, START TABLE ENVIRONMENT, WRITE A HEADER, AND
C WRITE A TABLE CAPTION
C
8001 FORMAT(A1,'end{verbatim}')
8003 FORMAT(A1,'begin{table}')
8007 FORMAT(5X,'$ ',A1,1X,A1,' $ ',A1,A1,' ')
8009 FORMAT(A1,'begin{center}')
8011 FORMAT(5X,'{',A1,'bf Confidence Limits for the Median }',2X,A1,A1)
8013 FORMAT(A1,'end{center}')
8016 FORMAT(5X,'{',A1,'bf Confidence Limits for Quantile ($Q_0$ = ',
1 F6.3,'}',2X,A1,A1)
8017 FORMAT(5X,'{',A1,'bf (Based on the Maritz-Jarrett Standard ',
1 'Error)}')
C
CALL DPCONA(92,IBASLC)
C
WRITE(ICOUT,8001)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8003)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8009)IBASLC
CALL DPWRST('XXX','WRIT')
IF(ICASAN.EQ.'MECI')THEN
WRITE(ICOUT,8011)IBASLC,IBASLC,IBASLC
CALL DPWRST('XXX','WRIT')
ELSE
WRITE(ICOUT,8016)IBASLC,P100,IBASLC,IBASLC
CALL DPWRST('XXX','WRIT')
ENDIF
WRITE(ICOUT,8017)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8007)IBASLC,IBASLC,IBASLC,IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8007)IBASLC,IBASLC,IBASLC,IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8013)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
C
C STEP 2: START TABULAR ENVIRONMENT, WRITE SUBSESQUENT ROWS, END
C TABULAR ENVIRONMENT
C
8020 FORMAT(5X,A1,'begin{tabular} {lr}')
8021 FORMAT(5X,'Number of Observations: & ',I8,2X,A1,A1)
8022 FORMAT(5X,'Estimate of the Median: & ',G15.7,2X,A1,A1)
8023 FORMAT(5X,'Estimate of the Quantile: & ',G15.7,2X,A1,A1)
8024 FORMAT(5X,'Quantile Standard Error: & ',G15.7,2X,A1,A1)
8025 FORMAT(5X,'Degrees of Freedom: & ',I8,2X,A1,A1)
8049 FORMAT(5X,A1,'end{tabular}')
WRITE(ICOUT,8009)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8020)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8021)N,IBASLC,IBASLC
CALL DPWRST('XXX','WRIT')
IF(ICASAN.EQ.'MECI')THEN
WRITE(ICOUT,8022)XQUANT,IBASLC,IBASLC
ELSE
WRITE(ICOUT,8023)XQUANT,IBASLC,IBASLC
ENDIF
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8024)XQUASE,IBASLC,IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8049)IBASLC
CALL DPWRST('XXX','WRIT')
C
C STEP 3: END TABLE ENVIRONMENT, RESET ASIS MODE
C
8091 FORMAT(A1,'end{table}')
8093 FORMAT(A1,'end{center}')
WRITE(ICOUT,8093)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
C
C STEP 2: START TABULAR ENVIRONMENT, WRITE SUBSESQUENT ROWS, END
C TABULAR ENVIRONMENT
C
8120 FORMAT(5X,A1,'begin{tabular} {ccccc}')
8121 FORMAT(5X,'{',A1,'bf Confidence} & {',A1,'bf Z } & & ',
1 '{',A1,'bf Lower } & {',A1,'bf Upper}',2X,A1,A1)
8122 FORMAT(5X,'{',A1,'bf Value (',A1,'%) } & {',A1,'bf Value} & {',A1,
1 'bf Z x Standard Error)} & {',A1,'bf Limit} & {',A1,
1 'bf Limit }',2X,A1,A1)
8123 FORMAT(5X,2(F8.3,' & '),2(G12.6,' & '),G12.6,2X,A1,A1)
8130 FORMAT(5X,A1,'hline')
WRITE(ICOUT,8009)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8120)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8121)IBASLC,IBASLC,IBASLC,IBASLC,IBASLC,IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8122)IBASLC,IBASLC,IBASLC,IBASLC,IBASLC,IBASLC,
1 IBASLC,IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8130)IBASLC
CALL DPWRST('XXX','WRIT')
DO8160I=1,8
WRITE(ICOUT,8123)CONF(I),T(I),TSDM(I),ALOWER(I),AUPPER(I),
1 IBASLC,IBASLC
CALL DPWRST('XXX','WRIT')
8160 CONTINUE
WRITE(ICOUT,8049)IBASLC
CALL DPWRST('XXX','WRIT')
C
C STEP 3: END TABLE ENVIRONMENT, RESET ASIS MODE
C
8199 FORMAT(A1,'begin{verbatim}')
WRITE(ICOUT,8093)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8091)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8199)IBASLC
CALL DPWRST('XXX','WRIT')
C
C PLACEHOLDER FOR RTF FORMAT OUTPUT
C
ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN
C
C
ELSE
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
IF(ICASAN.EQ.'MECI')THEN
WRITE(ICOUT,810)
810 FORMAT(
1' CONFIDENCE LIMITS FOR MEDIAN')
CALL DPWRST('XXX','WRIT')
ELSE
WRITE(ICOUT,811)P100
811 FORMAT(
1' CONFIDENCE LIMITS FOR QUANTILE (Q0 = ',
1F6.3,')')
CALL DPWRST('XXX','WRIT')
ENDIF
WRITE(ICOUT,812)
812 FORMAT(
1' (BASED ON MARITZ-JARRETT STANDARD ERROR ',
1'FOR QUANTILES)')
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,815)N
815 FORMAT(
1' NUMBER OF OBSERVATIONS = ',I8)
CALL DPWRST('XXX','WRIT')
IF(ICASAN.EQ.'MECI')THEN
WRITE(ICOUT,821)XQUANT
821 FORMAT(
1' ESTIMATE OF MEDIAN = ',G15.7)
CALL DPWRST('XXX','WRIT')
ELSE
WRITE(ICOUT,822)XQUANT
822 FORMAT(
1' ESTIMATE OF QUANTILE = ',G15.7)
CALL DPWRST('XXX','WRIT')
ENDIF
WRITE(ICOUT,823)XQUASE
823 FORMAT(
1' QUANTILE STANDARD ERROR = ',G15.7)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,832)
832 FORMAT(
1' CONFIDENCE Z Z X STDERR LOWER UPPER ')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,833)
833 FORMAT(
1' VALUE (%) 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),T(I),TSDM(I),ALOWER(I),AUPPER(I)
841 FORMAT(
1' ',F8.3,F8.3,2X,G12.6,2X,G12.6,2X,G12.6)
CALL DPWRST('XXX','WRIT')
840 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
ENDIF
ENDIF
C
IF(ICASAN.NE.'MECI')GOTO9000
IF(IPRINT.EQ.'ON')THEN
CCCCC OCTOBER 2003: WRITE OUTPUT IN HTML FORMAT
IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN
C
C STEP 1: END ASIS MODE AND WRITE A HEADER
C
5501 FORMAT('')
5504 FORMAT('
')
WRITE(ICOUT,5501)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5504)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
C
C STEP 2: START TABLE AND DEFINE A CAPTION
C
5561 FORMAT('')
5563 FORMAT('')
5565 FORMAT(' ')
5567 FORMAT(' Confidence Limits for the Median
')
5568 FORMAT(' (Based on Hettmansperger-Sheather)')
5569 FORMAT(' ')
WRITE(ICOUT,5561)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5563)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5565)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5567)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5568)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5569)
CALL DPWRST('XXX','WRIT')
C
C STEP 3: DEFINE DATA ROW
C
5541 FORMAT(' ')
5543 FORMAT(' | ')
5545 FORMAT(' Number of Observations:')
5547 FORMAT(' | ')
5549 FORMAT(' ')
5531 FORMAT(' ',G15.7)
5533 FORMAT(' ',I8)
5539 FORMAT(' |
')
5556 FORMAT(' Estimate of Median:')
WRITE(ICOUT,5541)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5543)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5545)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5547)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5549)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5533)N
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5547)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5539)
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,5541)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5543)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5556)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5547)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5549)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5531)XQUANT
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5547)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5539)
CALL DPWRST('XXX','WRIT')
C
C STEP 4: END THE TABLE AND RESET ASIS MODE
C
5591 FORMAT('
')
5593 FORMAT('
')
5599 FORMAT('')
WRITE(ICOUT,5591)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5593)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
C
C STEP 2B: START TABLE AND DEFINE A CAPTION
C
WRITE(ICOUT,5504)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5561)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5563)
CALL DPWRST('XXX','WRIT')
C
C STEP 3B: DEFINE HEADER ROW
C
5621 FORMAT(' ')
5623 FORMAT(' | ')
5627 FORMAT(' | ')
5639 FORMAT('
')
5631 FORMAT(' Confidence
Value (%)')
5634 FORMAT(' Lower
Limit')
5635 FORMAT(' Upper
Limit')
5661 FORMAT(' ')
5662 FORMAT('
')
WRITE(ICOUT,5621)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5623)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5631)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5627)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5623)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5634)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5627)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5623)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5635)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5627)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5639)
CALL DPWRST('XXX','WRIT')
C
C FOLLOWING ADDS A RULE LINE BETWEEN HEADER AND DATA LINES
C
WRITE(ICOUT,5541)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5661)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5662)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5547)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5539)
CALL DPWRST('XXX','WRIT')
C
C STEP 4: DEFINE DATA ROW
C
5641 FORMAT(' | ')
5643 FORMAT(' | ')
5647 FORMAT(' | ')
5651 FORMAT(' ',F8.3)
5652 FORMAT(' ',G12.6)
5649 FORMAT('
')
DO5680I=1,8
WRITE(ICOUT,5641)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5643)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5651)CONF(I)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5647)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5643)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5652)ALOWE2(I)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5647)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5643)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5652)AUPPE2(I)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5647)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5649)
CALL DPWRST('XXX','WRIT')
5680 CONTINUE
C
C STEP 4: END THE TABLE AND RESET ASIS MODE
C
5691 FORMAT('')
5693 FORMAT('')
5699 FORMAT('')
WRITE(ICOUT,5691)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5693)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5699)
CALL DPWRST('XXX','WRIT')
C
CCCCC WRITE OUTPUT IN LATEX FORMAT
ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN
C
C STEP 1: END ASIS FORMAT, START TABLE ENVIRONMENT, WRITE A HEADER, AND
C WRITE A TABLE CAPTION
C
8501 FORMAT(A1,'end{verbatim}')
8503 FORMAT(A1,'begin{table}')
8507 FORMAT(5X,'$ ',A1,1X,A1,' $ ',A1,A1,' ')
8509 FORMAT(A1,'begin{center}')
8511 FORMAT(5X,'{',A1,'bf Confidence Limits for the Median }',
1 2X,A1,A1)
8517 FORMAT(5X,'{',A1,'bf (Based on Hettmansperger-Sheather)}')
8513 FORMAT(A1,'end{center}')
C
CALL DPCONA(92,IBASLC)
C
WRITE(ICOUT,8501)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8503)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8509)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8511)IBASLC,IBASLC,IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8517)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8507)IBASLC,IBASLC,IBASLC,IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8507)IBASLC,IBASLC,IBASLC,IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8513)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
C
C STEP 2: START TABULAR ENVIRONMENT, WRITE SUBSESQUENT ROWS, END
C TABULAR ENVIRONMENT
C
8520 FORMAT(5X,A1,'begin{tabular} {lr}')
8521 FORMAT(5X,'Number of Observations: & ',I8,2X,A1,A1)
8522 FORMAT(5X,'Estimate of the Median: & ',G15.7,2X,A1,A1)
8549 FORMAT(5X,A1,'end{tabular}')
WRITE(ICOUT,8509)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8520)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8521)N,IBASLC,IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8522)XQUANT,IBASLC,IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8549)IBASLC
CALL DPWRST('XXX','WRIT')
C
C STEP 3: END TABLE ENVIRONMENT, RESET ASIS MODE
C
8591 FORMAT(A1,'end{table}')
8593 FORMAT(A1,'end{center}')
WRITE(ICOUT,8593)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
C
C STEP 2: START TABULAR ENVIRONMENT, WRITE SUBSESQUENT ROWS, END
C TABULAR ENVIRONMENT
C
8620 FORMAT(5X,A1,'begin{tabular} {ccc}')
8621 FORMAT(5X,'{',A1,'bf Confidence} & {',A1,'bf Lower} & {',A1,
1 'bf Upper}',2X,A1,A1)
8622 FORMAT(5X,'{',A1,'bf Value (',A1,'%)} & {',A1,
1 'bf Limit} & {',A1,'bf Limit}',2X,A1,A1)
8623 FORMAT(5X,F8.3,' & ',G12.6,' & ',G12.6,2X,A1,A1)
8630 FORMAT(5X,A1,'hline')
WRITE(ICOUT,8509)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8620)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8621)IBASLC,IBASLC,IBASLC,IBASLC,IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8622)IBASLC,IBASLC,IBASLC,IBASLC,IBASLC,IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8630)IBASLC
CALL DPWRST('XXX','WRIT')
DO8660I=1,8
WRITE(ICOUT,8623)CONF(I),ALOWE2(I),AUPPE2(I),IBASLC,IBASLC
CALL DPWRST('XXX','WRIT')
8660 CONTINUE
WRITE(ICOUT,8549)IBASLC
CALL DPWRST('XXX','WRIT')
C
C STEP 3: END TABLE ENVIRONMENT, RESET ASIS MODE
C
8699 FORMAT(A1,'begin{verbatim}')
WRITE(ICOUT,8593)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8591)IBASLC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,8699)IBASLC
CALL DPWRST('XXX','WRIT')
C
C PLACEHOLDER FOR RTF FORMAT OUTPUT
C
ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN
C
C
ELSE
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,910)
910 FORMAT(
1' CONFIDENCE LIMITS FOR MEDIAN')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,912)
912 FORMAT(
1 ' (BASED ON HETTMANSPERGER-SHEATHER ',
1 ' INTERPOLATION)')
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,915)N
915 FORMAT(
1 ' NUMBER OF OBSERVATIONS = ',I9)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,921)XQUANT
921 FORMAT(
1 ' ESTIMATE OF MEDIAN = ',G15.7)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,932)
932 FORMAT(
1' CONFIDENCE LOWER UPPER ')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,933)
933 FORMAT(
1' VALUE (%) LIMIT LIMIT ')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,934)
934 FORMAT(
1'---------------------------------------------------------------')
CALL DPWRST('XXX','WRIT')
DO940I=1,8
WRITE(ICOUT,941)CONF(I),ALOWE2(I),AUPPE2(I)
941 FORMAT(
1' ',F9.3,2X,G12.6,2X,G12.6)
CALL DPWRST('XXX','WRIT')
940 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
ENDIF
ENDIF
C
GOTO9000
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'QUC2')THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPQUC2--')
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),W(I)
9017 FORMAT('I,Y(I),W(I) = ',I8,2E15.7)
CALL DPWRST('XXX','WRIT')
9016 CONTINUE
ENDIF
C
RETURN
END
SUBROUTINE DPQUER(IANSLC,IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR)
C
C PURPOSE--ENTER A QUERY AT THE END OF THE DATAPLOT QUERY FILE
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--86/1
C ORIGINAL VERSION--OCTOBER 1981.
C UPDATED --NOVEMBER 1981.
C UPDATED --MAY 1982.
C UPDATED --DECEMBER 1985.
C UPDATED --JANUARY 1989. GENERALIZE APPEND OPERATION (ALAN)
C UPDATED --APRIL 1989. FIX ILLEGAL TRANSFER TO END OF LOOP
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IANSLC
CHARACTER*4 IBUGS2
CHARACTER*4 ISUBRO
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*80 IFILE
CHARACTER*12 ISTAT
CHARACTER*12 IFORM
CHARACTER*12 IACCES
CHARACTER*12 IPROT
CHARACTER*12 ICURST
CHARACTER*4 IENDFI
CHARACTER*4 IREWIN
CHARACTER*4 ISUBN0
CHARACTER*4 IERRFI
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
CHARACTER*4 IANSI
CHARACTER*80 ICANS
CHARACTER*80 ICQUER
CHARACTER*1 ICJUNK
C AUGUST,1987 BUG FIX: SOME MACHINES DO NOT ALLOW FILES TO BE
C APPENDED TO (CAN NOT READ AND WRITE TO THE SAME FILE). IN
C PARTICULAR, THE UNIVAC 1100/80'S AND CYBER MACHINES.
C SOLUTION IS TO STORE THE QUERY, CLOSE AND RE-OPEN THE FILE
C AND WRITE OUT THE STORED LINES.
PARAMETER (MAXQRY=100)
CHARACTER*80 ICJNK2(MAXQRY)
C END FIX
C
DIMENSION IANSLC(*)
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCOF2.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
ISUBN1='DPQU'
ISUBN2='ER '
C
IFOUND='YES'
IERROR='NO'
C
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'QUER')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPQUER--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)IBUGS2,ISUBRO,IERROR
53 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)IWIDTH
54 FORMAT('IWIDTH = ',I8)
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,55)(IANSLC(I),I=1,IWIDTH)
55 FORMAT('(IANSLC(I),I=1,IWIDTH) = ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,61)IQUENU
61 FORMAT('IQUENU = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,62)IQUENA
62 FORMAT('IQUENA = ',A80)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,63)IQUEST
63 FORMAT('IQUEST = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,64)IQUEFO
64 FORMAT('IQUEFO = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,65)IQUEAC
65 FORMAT('IQUEAC = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,66)IQUEFO
66 FORMAT('IQUEFO = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,67)IQUECS
67 FORMAT('IQUECS = ',A12)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C **************************
C ** STEP 11-- **
C ** COPY OVER VARIABLES **
C **************************
C
ISTEPN='11'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'QUER')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IOUNIT=IQUENU
IFILE=IQUENA
ISTAT=IQUEST
IFORM=IQUEFO
IACCES=IQUEAC
IPROT=IQUEPR
ICURST=IQUECS
C
ISUBN0='QUER'
IERRFI='NO'
C
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'QUER')GOTO1199
WRITE(ICOUT,1193)IOUNIT
1193 FORMAT('IOUNIT = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1194)IFILE
1194 FORMAT('IFILE = ',A80)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1195)ISTAT,IFORM,IACCES,IPROT,ICURST
1195 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',
1A12,2X,A12,2X,A12,2X,A12,2X,A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1196)ISUBN0,IERRFI
1196 FORMAT('ISUBN0,IERRFI = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
1199 CONTINUE
C
C ********************************************
C ** STEP 12-- **
C ** CHECK TO SEE IF QUERY FILE EXISTS **
C ********************************************
C
ISTEPN='12'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'QUER')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(ISTAT.EQ.'NONE')GOTO1200
GOTO1290
1200 CONTINUE
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1211)
1211 FORMAT('***** ERROR IN DPQUER--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1212)
1212 FORMAT(' THE ENTERED QUERY')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1213)
1213 FORMAT(' CANNOT BE RECORDED BECAUSE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1214)
1214 FORMAT(' THE REQUIRED SYSTEM MASS STORAGE FILE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1215)
1215 FORMAT(' WHICH STORES SUCH QUERIES')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1216)
1216 FORMAT(' IS NOT AVAILABLE AT THIS INSTALLATION.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1217)ISTAT,IQUEST
1217 FORMAT('ISTAT,IQUEST = ',A12,2X,A12)
CALL DPWRST('XXX','BUG ')
GOTO9000
1290 CONTINUE
C
C ****************************
C ** STEP 13-- **
C ** EXTRACT THE QUERY **
C ****************************
C
ISTEPN='13'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'MAIL')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
DO1310I=1,80
IANSI=IANSLC(I)
ICANS(I:I)=IANSI(1:1)
1310 CONTINUE
C
ISTART=1
ISTOP=IWIDTH
IWORD=2
CALL DPEXWO(ICANS,ISTART,ISTOP,IWORD,
1ICOL1,ICOL2,ICQUER,NCQUER,
1IBUGS2,ISUBRO,IERROR)
C
IF(NCQUER.GE.1)GOTO1329
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1321)
1321 FORMAT('***** ERROR IN DPQUER--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1322)
1322 FORMAT(' A MESSAGE IS REQUIRED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1323)
1323 FORMAT(' IN THE QUERY COMMAND')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1324)
1324 FORMAT(' (FOR EXAMPLE, QUERY WHAT IS DEFAULT COLOR?)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1325)
1325 FORMAT(' BUT NO MESSAGE WAS GIVEN HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1326)
1326 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,1327)(IANSLC(I),I=1,IWIDTH)
1327 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IF(IWIDTH.LE.0)WRITE(ICOUT,999)
IF(IWIDTH.LE.0)CALL DPWRST('XXX','BUG ')
GOTO9000
1329 CONTINUE
C
J=0
IF(ICOL1.GT.IWIDTH)GOTO1339
DO1330I=ICOL1,IWIDTH
J=J+1
ICQUER(J:J)=ICANS(I:I)
1330 CONTINUE
NCQUER=J
1339 CONTINUE
C
CALL DPDB80(ICQUER,JMAX,IBUGS2,ISUBRO,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
NCQUER=JMAX
C
IF(NCQUER.GE.1)GOTO1349
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1341)
1341 FORMAT('***** ERROR IN DPQUER--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1342)
1342 FORMAT(' A MESSAGE IS REQUIRED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1343)
1343 FORMAT(' IN THE QUERY COMMAND')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1344)
1344 FORMAT(' (FOR EXAMPLE, QUERY HOW DO I GENERATE ',
1'3-D PLOTS?)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1345)
1345 FORMAT(' BUT NONE WAS GIVEN HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1346)
1346 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,1347)(IANSLC(I),I=1,IWIDTH)
1347 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IF(IWIDTH.LE.0)WRITE(ICOUT,999)
IF(IWIDTH.LE.0)CALL DPWRST('XXX','BUG ')
GOTO9000
1349 CONTINUE
C
1390 CONTINUE
C
C *********************
C ** STEP 31-- **
C ** OPEN THE FILE **
C *********************
C
ISTEPN='31'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'QUER')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IREWIN='ON'
CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
IF(IERRFI.EQ.'YES')GOTO9000
C
C **********************************************
C ** STEP 41-- **
C ** READ THE FILE. **
C ** FIND THE LAST LINE OF THE FILE. **
C **********************************************
C
ISTEPN='41'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'QUER')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
NUMLIN=0
DO4120I=1,100000
I2=I
READ(IOUNIT,4121,END=4129)ICJUNK
4121 FORMAT(A1)
4120 CONTINUE
4129 CONTINUE
NUMLIN=I2-1
IF(NUMLIN.LE.0)NUMLIN=0
4190 CONTINUE
C BUG FIX
NUMSKP=0
IF(NUMLIN.LE.MAXQRY)GOTO4195
NUMSKP=NUMLIN-MAXQRY
4195 CONTINUE
C END FIX
C
C ************************
C ** STEP 42-- **
C ** REWIND THE FILE. **
C ************************
C
ISTEPN='42'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'QUER')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
REWIND IOUNIT
C
C **********************************************
C ** STEP 43-- **
C ** READ THE FILE **
C ** DOWN TO THE LAST LINE OF THE FILE. **
C **********************************************
C
ISTEPN='43'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'QUER')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(NUMLIN.LE.0)GOTO4390
C BUG FIX
CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1989
CCCCC IF(NUMSKP.LT.1)GOTO4310
IF(NUMSKP.LT.1)GOTO4311
DO4310I=1,NUMSKP
READ(IOUNIT,4321,END=4390)ICJUNK
4300 CONTINUE
4310 CONTINUE
CCCCC THE FOLLOWING LINE WAS INSERTED APRIL 1989
4311 CONTINUE
DO4315I=NUMSKP+1,NUMLIN
READ(IOUNIT,4316,END=4390)ICJNK2(I)
4315 CONTINUE
4316 FORMAT(A80)
CCCCC DO4320I=1,NUMLIN
CCCCC READ(IOUNIT,4321,END=4390)ICJUNK
4321 FORMAT(A1)
C4320 CONTINUE
C END FIX
4390 CONTINUE
C BUG FIX: CLOSE THE FILE, OPEN IT AND WRITE OUT STORED LINES
C
C ***********************
C ** STEP 431-- **
C ** CLOSE THE FILE. **
C ***********************
C
ISTEPN='431'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'QUER')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IENDFI='ON'
IREWIN='ON'
CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
C
C *********************
C ** STEP 432- **
C ** OPEN THE FILE **
C *********************
C
ISTEPN='432'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'QUER')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IREWIN='ON'
CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
IF(IERRFI.EQ.'YES')GOTO9000
C
NTEMP=NUMLIN-NUMSKP
DO4350I=1,NTEMP
WRITE(IOUNIT,4351)ICJNK2(I)
4350 CONTINUE
4351 FORMAT(A80)
C END FIX
C
C
C **********************************************
C ** STEP 44-- **
C ** WRITE TO THE FILE. **
C ** APPEND THE QUERY TO THE FILE. **
C **********************************************
C
ISTEPN='44'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'QUER')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
WRITE(IOUNIT,4421)(ICQUER(J:J),J=1,NCQUER)
4421 FORMAT(80A1)
C
C ***********************
C ** STEP 51-- **
C ** CLOSE THE FILE. **
C ***********************
C
ISTEPN='51'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'QUER')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IENDFI='ON'
IREWIN='ON'
CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
C
C ****************
C ** STEP 90-- **
C ** EXIT. **
C ****************
C
9000 CONTINUE
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'QUER')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPQUER--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGS2,ISUBRO,IERROR
9012 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9021)IOUNIT
9021 FORMAT('IOUNIT = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9022)IFILE
9022 FORMAT('IFILE = ',A80)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9023)ISTAT
9023 FORMAT('ISTAT = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9024)IFORM
9024 FORMAT('IFORM = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9025)IACCES
9025 FORMAT('IACCES = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9026)IPROT
9026 FORMAT('IPROT = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9027)ICURST
9027 FORMAT('ICURST = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9028)IENDFI
9028 FORMAT('IENDFI = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9029)IREWIN
9029 FORMAT('IREWIN = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9031)ISUBN0
9031 FORMAT('ISUBN0 = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9032)IERRFI
9032 FORMAT('IERRFI = ',A12)
CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,9041)IQUERY
C9041 FORMAT('IQUERY = ',A4)
CCCCC CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPRAND(ICASRA,ISEED,ILOCNU,
1IBUGA3,IBUGQ,IFOUND,IERROR)
C
C PURPOSE--GENERATE RANDOM NUMBERS
C FROM 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
C 16) EXTREME VALUE TYPE 1
C 17) EXTREME VALUE TYPE 2
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 GAUSSIAN MAY 1990
C 26) WALD MAY 1990
C 27) RECIPROCAL INVERSE GAUSSIAN MAY 1990
C 28) FATIGUE LIFE MAY 1990
C 29) GENERALIZED PARETO DECEMBER 1993
C 30) POWER FUNCTION APRIL 1995
C 31) HYPERGEOMETRIC AUGUST 1995
C 32) NON-CENTRAL CHI-SQUARE AUGUST 1995
C 33) NON-CENTRAL F AUGUST 1995
C 34) DOUBLY NON-CENTRAL F AUGUST 1995
C 35) FOLDED NORMAL OCTOBER 1995
C 36) HALF-CAUCHY OCTOBER 1995
C 37) NORMAL MIXTURE MAY 1998
C 38) POWER LAW JUNE 1998
C 39) GENERALIZED TUKEY-LAMBDA AUGUST 2001
C 40) INVERTED WEIBULL SEPTEMBER 2001
C 41) DOUBLE WEIBULL OCTOBER 2001
C 42) DOUBLE GAMMA OCTOBER 2001
C 43) LOG GAMMA OCTOBER 2001
C 44) INVERTED GAMMA OCTOBER 2001
C 45) COSINE OCTOBER 2001
C 46) ANGLIT OCTOBER 2001
C 47) HYPERBOLIC SECANT OCTOBER 2001
C 48) ARCSIN OCTOBER 2001
C 49) LOG DOUBLE EXPONENTIAL OCTOBER 2001
C 50) GENERALIZED EXTREM VALU OCTOBER 2001
C 51) EXPONENTIATED WEIBULL OCTOBER 2001
C 52) GOMPERTZ OCTOBER 2001
C 53) HALF-LOGISTIC OCTOBER 2001
C 54) POWER EXPONENTIAL OCTOBER 2001
C 55) ALPHA OCTOBER 2001
C 56) BRADFORD OCTOBER 2001
C 57) RECIPROCAL OCTOBER 2001
C 58) JOHNSON SB OCTOBER 2001
C 59) JOHNSON SU OCTOBER 2001
C 60) POWER NORMAL OCTOBER 2001
C 61) LOG-LOGISTIC OCTOBER 2001
C 62) GEOMETRIC EXTR EXPO NOVEMBER 2001
C 63) POWER LOGNORMAL NOVEMBER 2001
C 64) BETA-BINOMIAL DECEMBER 2001
C 65) TWO-SIDED POWER MAY 2002
C 66) BIWEIBULL MAY 2002
C 66) LOGARITHMIC SERIES AUGUST 2002
C 67) G-AND-H JANUARY 2003
C 68) SLASH JANUARY 2003
C 69) LANDAU APRIL 2003
C 70) INVERTED BETA MAY 2003
C 71) ERROR (=SUBBOTIN MAY 2003
C =EXPONENTIAL POWER
C =GENERAL ERROR)
C 72) TRAPEZOID JUNE 2003
C 73) VON MISES JUNE 2003
C 74) PARETO SECOND KIND JUNE 2003
C 75) WRAPPED CAUCHY JUNE 2003
C 76) GENERALIZED TRAPEZOID JUNE 2003
C 77) TRUNCATED NORMAL JULY 2003
C 78) CHI JULY 2003
C 79) FOLDED CAUCHY JULY 2003
C 80) MIELKE'S BETA-KAPPA JULY 2003
C 81) GENERALIZED EXPONENTIAL JULY 2003
C 82) TRUNCATED EXPONENTIAL JULY 2003
C 83) GENERALIZED GAMMA SEPTEMBER 2003
C 84) FOLDED T NOVEMBER 2003
C 85) SKEWED NORMAL NOVEMBER 2003
C 86) SKEWED T NOVEMBER 2003
C 87) ZIPF NOVEMBER 2003
C (RENAME AS ZETA) MAY 2006
C 88) GOMPERTZ-MAKEHAM DECEMBER 2003
C 89) GENERALIZED INVERSE GAUSSIAN DECEMBER 2003
C (NOT ACTIVATED YET)
C 90) LOG SKEWED NORMAL MARCH 2004
C 91) LOG SKEWED T MARCH 2004
C 92) NON-CENTRAL T MARCH 2004
C 93) DOUBLY NON-CENTRAL T MARCH 2004
C 94) GENERALIZED HALF-LOGISTIC MARCH 2004
C 95) GENERALIZED LOGISTIC MARCH 2004
C 96) POLYA MARCH 2004
C 97) HERMITE APRIL 2004
C 98) YULE APRIL 2004
C 99) WARING APRIL 2004
C 100) GENERALIZED WARING APRIL 2004
C 101) NON-CENTRAL BETA MAY 2004
C 102) DOUBLY NON-CENTRAL BETA MAY 2004
C 103) SKEW DOUBLE EXPONENTIAL JUNE 2004
C 104) ASYMMETRIC DOUBLE EXPONENTIAL JUNE 2004
C 105) MAXWELL JUNE 2004
C 106) RAYLEIGH JUNE 2004
C 107) MCLEISH AUGUST 2004
C 108) BESSEL I-FUNCTION AUGUST 2004
C 109) BESSEL K-FUNCTION AUGUST 2004 (NOT WORK)
C 110) GENERALIZED MCLEISH SEPTEMBER 2004
C 111) HYPERBOLIC SEPTEMBER 2004 (NOT WORK)
C 112) GENERALIZED LOGISTIC TYPE 5 FEBRUARY 2006
C 113) WAKEBY FEBRUARY 2006
C 114) BETA NORMAL MARCH 2006
C 115) GENERALIZED LOGISTIC TYPE 2 MARCH 2006
C 116) GENERALIZED LOGISTIC TYPE 3 MARCH 2006
C 117) GENERALIZED LOGISTIC TYPE 4 MARCH 2006
C 118) ASYMMETRIC LOG DOUBLE EXPONENTIAL MARCH 2006
C 119) BETA GEOMETRIC MAY 2006
C 120) BOREL TANNER MAY 2006
C 121) LAGRANGE POISSON JUNE 2006
C 122) LEADS IN COIN TOSSING JUNE 2006
C (DISCRETE ARCSINE)
C 123) MATCHING JUNE 2006
C 124) CLASSICAL OCCUPANCY JUNE 2006 (NOT ACTIVE)
C 125) LOG BETA JUNE 2006
C 126) POLYA AEPPLI JUNE 2006
C 127) LOST GAMES JUNE 2006
C 128) NEYMAN TYPE A JUNE 2006 (NOT ACTIVE)
C 129) DXG JUNE 2006 (NOT ACTIVE)
C 130) GENERALIZED LOGARITHMIC SERIES JUNE 2006
C 131) GENERALIZED NEGATIVE BINOMIAL JULY 2006
C 132) GEETA JULY 2006
C 133) QUASI BINOMIAL TYPE I JULY 2006
C 134) CONSUL AUGUST 2006
C 135) LAGRANGE KATZ AUGUST 2006 (NOT ACTIVE)
C 136) KATZ SEPTEMBER 2006 (NOT ACTIVE)
C 137) DISCRETE WEIBULL NOVEMBER 2006
C 138) GENERALIZED LOST GAMES NOVEMBER 2006
C
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C INFORMATION TECHNOLOGY LABORATORY
C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C GAITHERSBURG, MD 20899-8980
C PHONE--301-975-2855
C NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C OF THE NATIONAL 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 --MAY 1978.
C UPDATED --NOVEMBER 1978.
C UPDATED --JUNE 1981.
C UPDATED --SEPTEMBER 1981.
C UPDATED --OCTOBER 1981.
C UPDATED --MARCH 1982.
C UPDATED --MAY 1982.
C UPDATED --DECEMBER 1988. DISCRETE UNIFORM
C UPDATED --DECEMBER 1988. BOOTSTRAP INDEX
C UPDATED --DECEMBER 1988. RANDOM PERMUTATION
C UPDATED --JANUARY 1989. JACKNIFE INDEX
C UPDATED --MAY 1993. MINMAX FOR EV1/EV2/WEIB DIST.
C UPDATED --OCTOBER 1993. JACKNIFE INDEX TO DPMATC
C UPDATED --DECEMBER 1993. GENERALIZED PARETO
C UPDATED --MARCH 1994. DPCOS2.INC
C UPDATED --APRIL 1995. POWER FUNCTION
C UPDATED --AUGUST 1995. HYPERGEOMETRIC, NON-CENTRAL
C CHI-SQUARE, SINGLY AND DOUBLY
C NON-CENTRAL F
C UPDATED --MAY 1998. NORMAL MIXTURE
C UPDATED --JUNE 1998. POWER LAW
C UPDATED --AUGUST 2001. GENERALIZED LAMBDA
C UPDATED --SEPTEMBER 2001. INVERTED WEIBULL
C UPDATED --OCTOBER 2001. DOUBLE WEIBULL
C UPDATED --OCTOBER 2001. DOUBLE GAMMA
C UPDATED --OCTOBER 2001. LOG GAMMA
C UPDATED --OCTOBER 2001. INVERTED GAMMA
C UPDATED --OCTOBER 2001. COSINE
C UPDATED --OCTOBER 2001. ANGLIT
C UPDATED --OCTOBER 2001. HYPERBOLIC SECANT
C UPDATED --OCTOBER 2001. ARCSIN
C UPDATED --OCTOBER 2001. LOG DOUBLE EXPONENTIAL
C UPDATED --OCTOBER 2001. GENERALIZED EXTREME VALUE
C UPDATED --OCTOBER 2001. EXPONENTIATED WEIBULL
C UPDATED --OCTOBER 2001. GOMPERTZ
C UPDATED --OCTOBER 2001. HALF-LOGISTIC
C UPDATED --OCTOBER 2001. POWER EXPONENTIAL
C UPDATED --OCTOBER 2001. ALPHA
C UPDATED --OCTOBER 2001. BRADFORD
C UPDATED --OCTOBER 2001. RECIPROCAL
C UPDATED --OCTOBER 2001. JOHNSON SU
C UPDATED --OCTOBER 2001. JOHNSON SB
C UPDATED --OCTOBER 2001. POWER NORMAL
C UPDATED --OCTOBER 2001. LOG-LOGISTIC
C UPDATED --NOVEMBER 2001. GEOMETRIC EXTREME EXPO
C UPDATED --NOVEMBER 2001. POWER LOGNORMAL
C UPDATED --DECEMBER 2001. BETA-BINOMIAL
C UPDATED --MAY 2002. TWO-SIDED POWER
C UPDATED --MAY 2002. BIWEIBULL
C UPDATED --AUGUST 2002. LOGARITHMIC SERIES
C UPDATED --JANUARY 2003. G-AND-H, SLASH
C UPDATED --APRIL 2003. ADD SHAPE PARAMETER FOR
C LOGNORMAL
C UPDATED --APRIL 2003. LANDAU
C UPDATED --MAY 2003. INVERTED BETA
C UPDATED --MAY 2003. ERROR (=SUBBOTIN=EXPOENTIAL
C POWER=GENERAL ERROR)
C UPDATED --JUNE 2003. TRAPEZOID, VON MISES,
C PARETO SECOND KIND,
C WRAPPED CAUCHY,
C GENERALIZED TRAPEZOID
C UPDATED --JULY 2003. CHI, TRUNCATED NORMAL,
C FOLDED CAUCHY,
C MIELKE'S BETA-KAPPA,
C GENERALIZED EXPONENTIAL,
C TRUNCATED EXPONENTIAL
C UPDATED --SEPTEMBER 2003. GENERALIZED GAMMA
C UPDATED --NOVEMBER 2003. FOLDED T
C UPDATED --NOVEMBER 2003. SKEWED NORMAL
C UPDATED --NOVEMBER 2003. SKEWED T
C UPDATED --NOVEMBER 2003. ZIPF
C UPDATED --DECEMBER 2003. GOMPERTZ-MAKEHAM
C UPDATED --DECEMBER 2003. GENERALIZED INVERSE GAUSSIAN
C (NOT IMPLEMENTED YET)
C UPDATED --MARCH 2004. LOG SKEWED NORMAL
C UPDATED --MARCH 2004. LOG SKEWED T
C UPDATED --MARCH 2004. ALTERNATE DEFINITION OF
C GEOMETRIC
C UPDATED --MARCH 2004. NON-CENTRAL T
C UPDATED --MARCH 2004. DOUBLY NON-CENTRAL T
C UPDATED --MARCH 2004. GENERALIZED HALF-LOGISTIC
C UPDATED --MARCH 2004. GENERALIZED LOGISTIC
C UPDATED --MARCH 2004. POLYA
C UPDATED --APRIL 2004. HERMITE
C UPDATED --APRIL 2004. YULE
C UPDATED --APRIL 2004. WARING
C UPDATED --APRIL 2004. GENERALIZED WARING
C UPDATED --MAY 2004. NON-CENTRAL BETA
C UPDATED --MAY 2004. DOUBLY NON-CENTRAL BETA
C UPDATED --MAY 2004. REAL VALUES FOR CHI-SQUARE
C RANDOM NUMBERS
C UPDATED --MAY 2004. NON-CENTRAL CHI-SQUARE AS
C SEPARATE SUBROUTINE
C UPDATED --JUNE 2004. SKEW DOUBLE EXPONENTIAL
C UPDATED --JUNE 2004. ASYMMETRIC DOUBLE EXPONENTIAL
C UPDATED --JUNE 2004. ARGUMENT LIST TO GEPRAN
C UPDATED --JUNE 2004. MAXWELL, RAYLEIGH
C UPDATED --JULY 2004. ALTERNATE DEFINITIION FOR
C GOMPERTZ-MAKEHAM
C UPDATED --OCTOBER 2004. FOR PARETO, TREAT A AS A
C SHAPE PARAMETER
C UPDATED --JULY 2005. CALL LIST TO LGARAN AND SNRAN
C UPDATED --FEBRUARY 2006. GENERALIZED LOGISTIC TYPE 5
C UPDATED --FEBRUARY 2006. WAKEBY
C UPDATED --FEBRUARY 2006. ARGUMENT LIST TO GLDRAN
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 DOUBLE EXPONENTIAL
C UPDATED --MAY 2006. BETA GEOMETRIC
C UPDATED --MAY 2006. RENAME ZIPF AS ZETA
C UPDATED --MAY 2006. BOREL-TANNER
C UPDATED --MAY 2006. BETA-NEGATIVE BINOMIAL AS
C SYNOMYM FOR GENERALIZED
C WARING
C UPDATED --JUNE 2006. LAGRANGE-POISSON
C UPDATED --JUNE 2006. LEADS IN COIN TOSSING
C UPDATED --JUNE 2006. MATCHING
C UPDATED --JUNE 2006. CLASSICAL OCCUPANCY
C UPDATED --JUNE 2006. LOG BETA
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 1
C UPDATED --AUGUST 2006. CONSUL
C UPDATED --AUGUST 2006. LAGRANGE KATZ
C UPDATED --SEPTEMBER 2006. KATZ
C UPDATED --OCTOBER 2006. FRACTIONAL DEGREES OF
C FREEDOM FOR T DISTRIBUTION
C UPDATED --NOVEMBER 2006. DISCRETE WEIBULL
C UPDATED --NOVEMBER 2006. GENERALIZED LOST GAMES
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 ICASRA
CHARACTER*4 IBUGA3
CHARACTER*4 IBUGQ
CHARACTER*4 IWRITE
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 NEWNAM
CHARACTER*4 NEWCOL
CHARACTER*4 MESSAG
CHARACTER*4 ICASEQ
CHARACTER*4 IHWUSE
CHARACTER*4 IHP
CHARACTER*4 IHP2
CHARACTER*4 ILEFT
CHARACTER*4 ILEFT2
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
CHARACTER*26 IDIST
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCOPA.INC'
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) MARCH 1994
INCLUDE 'DPCOS2.INC'
CCCCC AUGUST 1995. ADD FOLLOWING LINE
DIMENSION XTEMP(1)
CCCCC MARCH 2004. ADD FOLLOWING LINE
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-----DATA STATEMENTS-------------------------------------------------
C
DATA EPS/0.000001/
DATA ALAMLG/0.00001/
C
C-----START POINT-----------------------------------------------------
C
ISUBN1='DPRA'
ISUBN2='N '
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
IFOUND='YES'
C
NS2=0
C
C ***********************************************
C ** TREAT THE RANDOM NUMBER GENERATION CASE **
C ** 1) FOR A FULL VARIABLE, OR **
C ** 2) FOR PART OF A VARIABLE. **
C ***********************************************
C
IF(IBUGA3.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBUGA3,IBUGQ
52 FORMAT('IBUGA3,IBUGQ = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)ICASRA,ISEED,ILOCNU
53 FORMAT('ICASRA,ISEED,ILOCNU = ',A4,I8,I8)
CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 2 LINES WERE ADDED MAY 1993
WRITE(ICOUT,61)MINMAX
61 FORMAT('MINMAX = ',I8)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C **********************************
C ** STEP 1-- **
C ** INITIALIZE SOME VARIABLES. **
C **********************************
C
ISTEPN='1'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
NEWNAM='NO'
NEWCOL='NO'
C
C *******************************************************
C ** STEP 2-- **
C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. **
C *******************************************************
C
ISTEPN='2'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
MINNA=3
MAXNA=100
CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,
1IERROR)
IF(IERROR.EQ.'YES')GOTO9000
C
C ****************************************************************
C ** STEP 3-- *
C ** EXAMINE THE LEFT-HAND SIDE-- *
C ** IS THE PARAMETER OR VARIABLE NAME TO LEFT OF = SIGN *
C ** ALREADY IN THE NAME LIST? *
C ** NOTE THAT ILEFT IS THE NAME OF THE VARIABLE *
C ** ON THE LEFT. *
C ** NOTE THAT ILISTL IS THE LINE IN THE TABLE *
C ** OF THE NAME ON THE LEFT. *
C ** NOTE THAT ICOLL IS THE DATA COLUMN (1 TO 12) *
C ** FOR THE NAME OF THE LEFT. *
C ****************************************************************
C
ISTEPN='3'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CCCCC ILEFT=IHOL(2)
CCCCC ILEFT2=IHOL2(2)
ILEFT=IHARG(1)
ILEFT2=IHARG2(1)
DO310I=1,NUMNAM
I2=I
IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND.
1IUSE(I).EQ.'P')GOTO329
IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND.
1IUSE(I).EQ.'V')GOTO380
310 CONTINUE
NEWNAM='YES'
ILISTL=NUMNAM+1
IF(ILISTL.GT.MAXNAM)GOTO320
GOTO330
C
320 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,321)
321 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,322)
322 FORMAT(' THE NUMBER OF VARIABLE AND/OR PARAMETER')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,323)MAXNAM
323 FORMAT(' NAMES HAS JUST EXCEEDED THE MAX ALLOWABLE ',
1I8,' .')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,324)
324 FORMAT(' SUGGESTED ACTION--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,325)
325 FORMAT(' ENTER STAT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,326)
326 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,327)
327 FORMAT(' AND THEN REDEFINE (REUSE) SOME OF THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,328)
328 FORMAT(' ALREADY-USED NAMES')
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
329 CONTINUE
ILISTL=I2
GOTO330
C
330 CONTINUE
NLEFT=0
ICOLL=NUMCOL+1
IF(ICOLL.GT.MAXCOL)GOTO340
GOTO390
C
340 CONTINUE
WRITE(ICOUT,341)
341 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,342)
342 FORMAT(' THE NUMBER OF DATA COLUMNS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,343)MAXCOL
343 FORMAT(' HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,' .')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,344)
344 FORMAT(' SUGGESTED ACTION--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,345)
345 FORMAT(' ENTER STAT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,346)
346 FORMAT(' TO FIND OUT THE FULL LIST OF USED COLUMNS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,347)
347 FORMAT(' AND THEN OVERWRITE SOME COLUMNS. EXAMPLE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,348)
348 FORMAT(' IF LET X(I) = 3.14 FAILED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,349)
349 FORMAT(' THEN ONE MIGHT ENTER NAME X 7')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,350)
350 FORMAT(' (THEREBY EQUATING THE NAME X WITH COLUMN 7')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,351)
351 FORMAT(' FOLLOWED BY LET X = 3.14')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,352)
352 FORMAT(' (WHICH WILL ACTUALLY OVERWRITE COLUMN 7')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,353)
353 FORMAT(' WITH THE NUMERIC CONSTANTS 3.14)')
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
380 CONTINUE
ILISTL=I2
ICOLL=IVALUE(ILISTL)
NLEFT=IN(ILISTL)
C
390 CONTINUE
C
C *******************************************************
C ** STEP 4-- **
C ** CHECK THAT THE INPUT CASE (ICASRA) **
C ** IS ONE OF THE ALLOWABLE 100+ DISTRIBUTIONS **
C *******************************************************
C
ISTEPN='2'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(ICASRA.EQ.'UNIF')GOTO490
IF(ICASRA.EQ.'NORM')GOTO490
IF(ICASRA.EQ.'LOGI')GOTO490
IF(ICASRA.EQ.'DOUB')GOTO490
IF(ICASRA.EQ.'CAUC')GOTO490
IF(ICASRA.EQ.'LAMB')GOTO490
IF(ICASRA.EQ.'LOGN')GOTO490
IF(ICASRA.EQ.'HALF')GOTO490
IF(ICASRA.EQ.'T')GOTO490
IF(ICASRA.EQ.'CHIS')GOTO490
IF(ICASRA.EQ.'F')GOTO490
IF(ICASRA.EQ.'EXPO')GOTO490
IF(ICASRA.EQ.'GAMM')GOTO490
IF(ICASRA.EQ.'BETA')GOTO490
IF(ICASRA.EQ.'WEIB')GOTO490
IF(ICASRA.EQ.'EXV1')GOTO490
IF(ICASRA.EQ.'EXV2')GOTO490
IF(ICASRA.EQ.'PARE')GOTO490
IF(ICASRA.EQ.'BINO')GOTO490
IF(ICASRA.EQ.'GEOM')GOTO490
IF(ICASRA.EQ.'POIS')GOTO490
IF(ICASRA.EQ.'NEGB')GOTO490
IF(ICASRA.EQ.'SEMI')GOTO490
IF(ICASRA.EQ.'TRIA')GOTO490
IF(ICASRA.EQ.'DIUN')GOTO490
IF(ICASRA.EQ.'BOOT')GOTO490
IF(ICASRA.EQ.'PERM')GOTO490
CCCCC OCTOBER 1993. JACKNIFE INDEX IN DPMATC
CCCCC IF(ICASRA.EQ.'JACK')GOTO490
IF(ICASRA.EQ.'IG')GOTO490
IF(ICASRA.EQ.'WALD')GOTO490
IF(ICASRA.EQ.'RIG')GOTO490
IF(ICASRA.EQ.'FL')GOTO490
CCCCC THE FOLLOWING LINE WAS ADDED DECEMBER 1993
IF(ICASRA.EQ.'GEP')GOTO490
CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1995
IF(ICASRA.EQ.'POWF')GOTO490
CCCCC THE FOLLOWING 4 LINES WERE ADDED AUGUST 1995
IF(ICASRA.EQ.'HYPE')GOTO490
IF(ICASRA.EQ.'NCCS')GOTO490
IF(ICASRA.EQ.'NCF ')GOTO490
IF(ICASRA.EQ.'DNCF')GOTO490
CCCCC THE FOLLOWING 2 LINES WERE ADDED OCTOBER 1995
IF(ICASRA.EQ.'FNRM')GOTO490
IF(ICASRA.EQ.'HFCA')GOTO490
CCCCC THE FOLLOWING LINE WAS ADDED MAY 1998
IF(ICASRA.EQ.'NMRM')GOTO490
CCCCC THE FOLLOWING LINE WAS ADDED JUNE 1998
IF(ICASRA.EQ.'POWL')GOTO490
CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 2001
IF(ICASRA.EQ.'GLAM')GOTO490
CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 2001
IF(ICASRA.EQ.'IWEI')GOTO490
CCCCC THE FOLLOWING 10 LINES WERE ADDED OCTOBER 2001
IF(ICASRA.EQ.'DWEI')GOTO490
IF(ICASRA.EQ.'DGAM')GOTO490
IF(ICASRA.EQ.'LGAM')GOTO490
IF(ICASRA.EQ.'IGAM')GOTO490
IF(ICASRA.EQ.'COSI')GOTO490
IF(ICASRA.EQ.'ANGL')GOTO490
IF(ICASRA.EQ.'HSEC')GOTO490
IF(ICASRA.EQ.'ARCS')GOTO490
IF(ICASRA.EQ.'LDEX')GOTO490
IF(ICASRA.EQ.'GEVA')GOTO490
IF(ICASRA.EQ.'EWEI')GOTO490
IF(ICASRA.EQ.'GOMP')GOTO490
IF(ICASRA.EQ.'HALO')GOTO490
IF(ICASRA.EQ.'POEX')GOTO490
IF(ICASRA.EQ.'ALPH')GOTO490
IF(ICASRA.EQ.'BRAD')GOTO490
IF(ICASRA.EQ.'RECI')GOTO490
IF(ICASRA.EQ.'JOSB')GOTO490
IF(ICASRA.EQ.'JOSU')GOTO490
IF(ICASRA.EQ.'PNOR')GOTO490
IF(ICASRA.EQ.'LLOG')GOTO490
CCCCC THE FOLLOWING 2 LINES WERE ADDED NOVEMBER 2001
IF(ICASRA.EQ.'GEEE')GOTO490
IF(ICASRA.EQ.'PLNO')GOTO490
IF(ICASRA.EQ.'BBIN')GOTO490
IF(ICASRA.EQ.'POLY')GOTO490
IF(ICASRA.EQ.'STSP')GOTO490
IF(ICASRA.EQ.'BIWE')GOTO490
IF(ICASRA.EQ.'LOGS')GOTO490
IF(ICASRA.EQ.'GH ')GOTO490
IF(ICASRA.EQ.'SLAS')GOTO490
IF(ICASRA.EQ.'LAND')GOTO490
IF(ICASRA.EQ.'IBET')GOTO490
IF(ICASRA.EQ.'ERRO')GOTO490
IF(ICASRA.EQ.'TRAP')GOTO490
IF(ICASRA.EQ.'VONM')GOTO490
IF(ICASRA.EQ.'WRCA')GOTO490
IF(ICASRA.EQ.'PAR2')GOTO490
IF(ICASRA.EQ.'GTRA')GOTO490
IF(ICASRA.EQ.'TNOR')GOTO490
IF(ICASRA.EQ.'CHI ')GOTO490
IF(ICASRA.EQ.'FCAU')GOTO490
IF(ICASRA.EQ.'BKAP')GOTO490
IF(ICASRA.EQ.'GEXP')GOTO490
IF(ICASRA.EQ.'TEXP')GOTO490
IF(ICASRA.EQ.'GGD ')GOTO490
IF(ICASRA.EQ.'FT ')GOTO490
IF(ICASRA.EQ.'SKWN')GOTO490
IF(ICASRA.EQ.'SKWT')GOTO490
IF(ICASRA.EQ.'ZIPF')GOTO490
IF(ICASRA.EQ.'ZETA')GOTO490
IF(ICASRA.EQ.'GMAK')GOTO490
IF(ICASRA.EQ.'GIG ')GOTO490
IF(ICASRA.EQ.'SKLN')GOTO490
IF(ICASRA.EQ.'SKLT')GOTO490
IF(ICASRA.EQ.'NCT ')GOTO490
IF(ICASRA.EQ.'DNCT')GOTO490
IF(ICASRA.EQ.'GHLO')GOTO490
IF(ICASRA.EQ.'GLOG')GOTO490
IF(ICASRA.EQ.'HERM')GOTO490
IF(ICASRA.EQ.'YULE')GOTO490
IF(ICASRA.EQ.'WARI')GOTO490
IF(ICASRA.EQ.'GWAR')GOTO490
IF(ICASRA.EQ.'BENB')GOTO490
IF(ICASRA.EQ.'NCBE')GOTO490
IF(ICASRA.EQ.'DNCB')GOTO490
IF(ICASRA.EQ.'SKDE')GOTO490
IF(ICASRA.EQ.'ASDE')GOTO490
IF(ICASRA.EQ.'MAXW')GOTO490
IF(ICASRA.EQ.'RAYL')GOTO490
IF(ICASRA.EQ.'GASD')GOTO490
IF(ICASRA.EQ.'MCLE')GOTO490
IF(ICASRA.EQ.'BESI')GOTO490
IF(ICASRA.EQ.'BESK')GOTO490
IF(ICASRA.EQ.'GMCL')GOTO490
IF(ICASRA.EQ.'HBOL')GOTO490
IF(ICASRA.EQ.'G5LO')GOTO490
IF(ICASRA.EQ.'WAKE')GOTO490
IF(ICASRA.EQ.'BNOR')GOTO490
IF(ICASRA.EQ.'G2LO')GOTO490
IF(ICASRA.EQ.'G3LO')GOTO490
IF(ICASRA.EQ.'G4LO')GOTO490
IF(ICASRA.EQ.'ALDE')GOTO490
IF(ICASRA.EQ.'BGEO')GOTO490
IF(ICASRA.EQ.'BTAN')GOTO490
IF(ICASRA.EQ.'LPOI')GOTO490
IF(ICASRA.EQ.'LCTO')GOTO490
IF(ICASRA.EQ.'MATC')GOTO490
IF(ICASRA.EQ.'OCCU')GOTO490
IF(ICASRA.EQ.'LBET')GOTO490
IF(ICASRA.EQ.'PAEP')GOTO490
IF(ICASRA.EQ.'LOST')GOTO490
IF(ICASRA.EQ.'GLSE')GOTO490
IF(ICASRA.EQ.'GNBI')GOTO490
IF(ICASRA.EQ.'GEET')GOTO490
IF(ICASRA.EQ.'QBTI')GOTO490
IF(ICASRA.EQ.'CONS')GOTO490
IF(ICASRA.EQ.'LAGK')GOTO490
IF(ICASRA.EQ.'KATZ')GOTO490
IF(ICASRA.EQ.'DISW')GOTO490
IF(ICASRA.EQ.'GLGA')GOTO490
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,401)
401 FORMAT('***** INTERNAL ERROR IN DPRAND')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,402)
402 FORMAT(' AT BRANCH POINT 4001--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,403)
403 FORMAT(' ICASRA NOT EQUAL ONE OF THE ALLOWABLE 100+--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,404)
404 FORMAT(' UNIF, NORM, LOGI, DOUB, CAUC, ETC.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,405)ICASRA
405 FORMAT(' VALUE OF ICASRA = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,406)
406 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,407)(IANS(I),I=1,IWIDTH)
407 FORMAT(80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
490 CONTINUE
C
C *****************************************
C ** STEP 6-- **
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='6'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ICASEQ='FULL'
ILOCQ=NUMARG+1
IF(NUMARG.LT.1)GOTO670
DO610J=1,NUMARG
J1=J
IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO620
IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO620
IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO630
610 CONTINUE
GOTO680
C
620 CONTINUE
ICASEQ='SUBS'
ILOCQ=J1
GOTO680
C
630 CONTINUE
ICASEQ='FOR'
ILOCQ=J1
GOTO680
C
670 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,671)
671 FORMAT('***** INTERNAL ERROR IN DPRAND')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,672)
672 FORMAT(' AT BRANCH POINT 5081--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,673)
673 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,674)
674 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,675)NUMARG
675 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,676)
676 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,677)(IANS(I),I=1,IWIDTH)
677 FORMAT(80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
680 CONTINUE
IF(IBUGA3.EQ.'OFF')GOTO690
WRITE(ICOUT,681)NUMARG,ILOCQ,ICASEQ
681 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4)
CALL DPWRST('XXX','BUG ')
C
690 CONTINUE
C
C ******************************************************
C ** STEP 7-- **
C ** BRANCH TO THE APPROPRIATE SUBCASE **
C ** (BASED ON THE QUALIFIER); **
C ** DETERMINE THE NUMBER (= NRAN) **
C ** OF RANDOM NUMBERS TO BE GENERATED. **
C ** NOTE THAT THE VARIABLE NIISUB **
C ** IS THE LENGTH OF THE RESULTING **
C ** VARIABLE ISUB(.). **
C ** NOTE THAT DPFOR AUTOMATICALLY EXTENDS **
C ** THE INPUT LENGTH OF ISUB(.) IF NECESSARY. **
C ** (HENCE THE REDEFINITION OF NIISUB TO NINEW **
C ** AFTER THE CALL TO DPFOR. **
C ******************************************************
C
ISTEPN='7'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CCCCC OCTOBER 1993. JACKNIFE INDEX TO DPMATC.
CCCCC IF(ICASRA.EQ.'JACK')GOTO1280
IF(ICASEQ.EQ.'FULL')GOTO710
IF(ICASEQ.EQ.'SUBS')GOTO720
IF(ICASEQ.EQ.'FOR')GOTO730
C
710 CONTINUE
IF(NEWNAM.EQ.'NO')NIISUB=NLEFT
IF(NEWNAM.EQ.'YES')NIISUB=MAXN
DO715I=1,NIISUB
ISUB(I)=1
715 CONTINUE
NRAN=NIISUB
GOTO750
C
720 CONTINUE
NIISUB=MAXN
CALL DPSUBS(NIISUB,ILOCS,NS,IBUGQ,IERROR)
NRAN=NS
GOTO750
C
730 CONTINUE
IF(NEWNAM.EQ.'NO')NIISUB=NLEFT
IF(NEWNAM.EQ.'YES')NIISUB=MAXN
CALL DPFOR(NIISUB,NINEW,IROW1,IROWN,
1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
NIISUB=NINEW
NRAN=NS
GOTO750
C
750 CONTINUE
C
C ******************************************
C ** STEP 8-- **
C ** GENERATE NRAN RANDOM NUMBERS **
C ** FROM THE SPECIFIED DISTRIBUTION. **
C ** STORE THEM TEMPORARILY IN **
C ** THE VECTOR Y(.). **
C ******************************************
C
ISTEPN='8'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(ICASRA.EQ.'UNIF')GOTO1010
IF(ICASRA.EQ.'NORM')GOTO1020
IF(ICASRA.EQ.'LOGI')GOTO1030
IF(ICASRA.EQ.'DOUB')GOTO1040
IF(ICASRA.EQ.'CAUC')GOTO1050
IF(ICASRA.EQ.'LAMB')GOTO1060
IF(ICASRA.EQ.'LOGN')GOTO1070
IF(ICASRA.EQ.'HALF')GOTO1080
IF(ICASRA.EQ.'T')GOTO1090
IF(ICASRA.EQ.'CHIS')GOTO1100
IF(ICASRA.EQ.'F')GOTO1110
IF(ICASRA.EQ.'EXPO')GOTO1120
IF(ICASRA.EQ.'GAMM')GOTO1130
IF(ICASRA.EQ.'BETA')GOTO1140
IF(ICASRA.EQ.'WEIB')GOTO1150
IF(ICASRA.EQ.'EXV1')GOTO1160
IF(ICASRA.EQ.'EXV2')GOTO1170
IF(ICASRA.EQ.'PARE')GOTO1180
IF(ICASRA.EQ.'BINO')GOTO1190
IF(ICASRA.EQ.'GEOM')GOTO1200
IF(ICASRA.EQ.'POIS')GOTO1210
IF(ICASRA.EQ.'NEGB')GOTO1220
IF(ICASRA.EQ.'SEMI')GOTO1230
IF(ICASRA.EQ.'TRIA')GOTO1240
IF(ICASRA.EQ.'DIUN')GOTO1250
IF(ICASRA.EQ.'BOOT')GOTO1260
IF(ICASRA.EQ.'PERM')GOTO1270
CCCCC OCTOBER 1993. JACKNIFE INDEX TO DPMATC
CCCCC IF(ICASRA.EQ.'JACK')GOTO1280
CCCCC THE FOLLOWING 4 LINES WERE ADDED MAY 1990
IF(ICASRA.EQ.'IG')GOTO1290
IF(ICASRA.EQ.'WALD')GOTO1300
IF(ICASRA.EQ.'RIG')GOTO1310
IF(ICASRA.EQ.'FL')GOTO1320
CCCCC THE FOLLOWING LINE WAS ADDED DECEMBER 1993
IF(ICASRA.EQ.'GEP')GOTO1330
CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1995
IF(ICASRA.EQ.'POWF')GOTO1340
CCCCC THE FOLLOWING 4 LINES WERE ADDED AUGUST 1995
IF(ICASRA.EQ.'HYPE')GOTO1350
IF(ICASRA.EQ.'NCCS')GOTO1360
IF(ICASRA.EQ.'NCF ')GOTO1370
IF(ICASRA.EQ.'DNCF')GOTO1380
CCCCC THE FOLLOWING 2 LINES WERE ADDED OCTOBER 1995
IF(ICASRA.EQ.'FNRM')GOTO1390
IF(ICASRA.EQ.'HFCA')GOTO1400
CCCCC THE FOLLOWING LINE WAS ADDED MAY 1998
IF(ICASRA.EQ.'NMRM')GOTO1410
CCCCC THE FOLLOWING LINE WAS ADDED JUNE 1998
IF(ICASRA.EQ.'POWL')GOTO1440
CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 2001
IF(ICASRA.EQ.'GLAM')GOTO1460
CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 2001
IF(ICASRA.EQ.'IWEI')GOTO1480
CCCCC THE FOLLOWING 10 LINES WERE ADDED OCTOBER 2001
IF(ICASRA.EQ.'DWEI')GOTO1490
IF(ICASRA.EQ.'DGAM')GOTO1500
IF(ICASRA.EQ.'LGAM')GOTO1510
IF(ICASRA.EQ.'IGAM')GOTO1520
IF(ICASRA.EQ.'COSI')GOTO1530
IF(ICASRA.EQ.'ANGL')GOTO1540
IF(ICASRA.EQ.'HSEC')GOTO1550
IF(ICASRA.EQ.'ARCS')GOTO1560
IF(ICASRA.EQ.'LDEX')GOTO1570
IF(ICASRA.EQ.'GEVA')GOTO1580
CCCCC THE FOLLOWING 10 LINES WERE ADDED OCTOBER 2001
IF(ICASRA.EQ.'EWEI')GOTO1590
IF(ICASRA.EQ.'GOMP')GOTO1600
IF(ICASRA.EQ.'HALO')THEN
IFLGHL=0
GOTO1610
ENDIF
IF(ICASRA.EQ.'GHLO')THEN
IFLGHL=1
GOTO1610
ENDIF
IF(ICASRA.EQ.'POEX')GOTO1620
IF(ICASRA.EQ.'ALPH')GOTO1630
IF(ICASRA.EQ.'BRAD')GOTO1640
IF(ICASRA.EQ.'RECI')GOTO1650
IF(ICASRA.EQ.'JOSB')GOTO1660
IF(ICASRA.EQ.'JOSU')GOTO1670
IF(ICASRA.EQ.'PNOR')GOTO1680
IF(ICASRA.EQ.'LLOG')GOTO1690
IF(ICASRA.EQ.'GEEE')GOTO1700
IF(ICASRA.EQ.'PLNO')GOTO1710
IF(ICASRA.EQ.'BBIN')GOTO1730
IF(ICASRA.EQ.'POLY')GOTO1730
IF(ICASRA.EQ.'STSP')GOTO1760
IF(ICASRA.EQ.'BIWE')GOTO1790
IF(ICASRA.EQ.'LOGS')GOTO1850
IF(ICASRA.EQ.'GH ')GOTO1860
IF(ICASRA.EQ.'SLAS')GOTO1880
IF(ICASRA.EQ.'LAND')GOTO1890
IF(ICASRA.EQ.'IBET')GOTO1900
IF(ICASRA.EQ.'ERRO')GOTO1920
IF(ICASRA.EQ.'TRAP')GOTO1930
IF(ICASRA.EQ.'VONM')GOTO1940
IF(ICASRA.EQ.'PAR2')GOTO1950
IF(ICASRA.EQ.'WRCA')GOTO1960
IF(ICASRA.EQ.'GTRA')GOTO1970
IF(ICASRA.EQ.'TNOR')GOTO2010
IF(ICASRA.EQ.'CHI ')GOTO2040
IF(ICASRA.EQ.'FCAU')GOTO2050
IF(ICASRA.EQ.'BKAP')GOTO2060
IF(ICASRA.EQ.'GEXP')GOTO2090
IF(ICASRA.EQ.'TEXP')GOTO2120
IF(ICASRA.EQ.'GGD ')GOTO2150
IF(ICASRA.EQ.'FT ')GOTO2170
IF(ICASRA.EQ.'SKWN')GOTO2180
IF(ICASRA.EQ.'SKWT')GOTO2190
IF(ICASRA.EQ.'ZETA')GOTO2200
IF(ICASRA.EQ.'GMAK')GOTO2210
IF(ICASRA.EQ.'GIG ')GOTO2240
IF(ICASRA.EQ.'SKLN')GOTO2270
IF(ICASRA.EQ.'SKLT')GOTO2280
IF(ICASRA.EQ.'NCT ')GOTO2300
IF(ICASRA.EQ.'DNCT')GOTO2310
IF(ICASRA.EQ.'GLOG')GOTO2330
IF(ICASRA.EQ.'HERM')GOTO2340
IF(ICASRA.EQ.'YULE')GOTO2360
IF(ICASRA.EQ.'WARI')GOTO2370
IF(ICASRA.EQ.'GWAR')GOTO2390
IF(ICASRA.EQ.'BENB')GOTO2390
IF(ICASRA.EQ.'NCBE')GOTO2420
IF(ICASRA.EQ.'DNCB')GOTO2450
IF(ICASRA.EQ.'SKDE')GOTO2490
IF(ICASRA.EQ.'ASDE')GOTO2500
IF(ICASRA.EQ.'MAXW')GOTO2520
IF(ICASRA.EQ.'RAYL')GOTO2530
IF(ICASRA.EQ.'GASD')GOTO2540
IF(ICASRA.EQ.'MCLE')GOTO2560
IF(ICASRA.EQ.'BESI')GOTO2570
IF(ICASRA.EQ.'BESK')GOTO2600
IF(ICASRA.EQ.'GMCL')GOTO2630
IF(ICASRA.EQ.'HBOL')GOTO2650
IF(ICASRA.EQ.'G5LO')GOTO2670
IF(ICASRA.EQ.'WAKE')GOTO2680
IF(ICASRA.EQ.'BNOR')GOTO2700
IF(ICASRA.EQ.'G2LO')GOTO2720
IF(ICASRA.EQ.'G3LO')GOTO2730
IF(ICASRA.EQ.'G4LO')GOTO2740
IF(ICASRA.EQ.'ALDE')GOTO2770
IF(ICASRA.EQ.'BGEO')GOTO2800
IF(ICASRA.EQ.'ZIPF')GOTO2820
IF(ICASRA.EQ.'BTAN')GOTO2840
IF(ICASRA.EQ.'LPOI')GOTO2860
IF(ICASRA.EQ.'LCTO')GOTO2880
IF(ICASRA.EQ.'MATC')GOTO2890
CCCCC IF(ICASRA.EQ.'OCCU')GOTO2900
IF(ICASRA.EQ.'LBET')GOTO2910
IF(ICASRA.EQ.'PAEP')GOTO2950
IF(ICASRA.EQ.'LOST')GOTO2970
IF(ICASRA.EQ.'GLSE')GOTO3010
IF(ICASRA.EQ.'GNBI')GOTO3040
IF(ICASRA.EQ.'GEET')GOTO3070
IF(ICASRA.EQ.'QBTI')GOTO3110
IF(ICASRA.EQ.'CONS')GOTO3140
IF(ICASRA.EQ.'LAGK')GOTO3180
IF(ICASRA.EQ.'KATZ')GOTO3210
IF(ICASRA.EQ.'DISW')GOTO3230
IF(ICASRA.EQ.'GLGA')GOTO3250
C
5950 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5951)
5951 FORMAT('***** INTERNAL ERROR IN DPRAND')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5952)
5952 FORMAT(' AT BRANCH POINT 1951--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5953)
5953 FORMAT(' ICASRA NOT EQUAL ONE OF THE ALLOWABLE 24--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5954)
5954 FORMAT(' UNIF, NORM, LOGI, DOUB, CAUC, ETC.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5955)
5955 FORMAT(' EVEN THOUGH ICASRA HAD ALREADY PASSED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5956)ICASRA
5956 FORMAT(' THIS TEST ONCE BEFORE. VALUE OF ICASRA = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5957)
5957 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,5958)(IANS(I),I=1,IWIDTH)
5958 FORMAT(80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
1010 CONTINUE
CALL UNIRAN(NRAN,ISEED,Y)
GOTO2990
C
1020 CONTINUE
CALL NORRAN(NRAN,ISEED,Y)
GOTO2990
C
1030 CONTINUE
CALL LOGRAN(NRAN,ISEED,Y)
GOTO2990
C
1040 CONTINUE
CALL DEXRAN(NRAN,ISEED,Y)
GOTO2990
C
1050 CONTINUE
CALL CAURAN(NRAN,ISEED,Y)
GOTO2990
C
1060 CONTINUE
IHP='LAMB'
IHP2='DA '
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
ALAMBA=VALUE(ILOCP)
C
IF(-ALAMLG.LE.ALAMBA.AND.ALAMBA.LE.ALAMLG)GOTO1065
GOTO1067
C
1065 CONTINUE
CALL LOGRAN(NRAN,ISEED,Y)
GOTO2990
C
1067 CONTINUE
CALL LAMRAN(NRAN,ALAMBA,ISEED,Y)
GOTO2990
C
1070 CONTINUE
C
IHP='SIGM'
IHP2='A '
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')THEN
SIGMA=1.0
ELSE
SIGMA=VALUE(ILOCP)
ENDIF
C
IF(SIGMA.LE.0.0)THEN
WRITE(ICOUT,1071)
1071 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1072)
1072 FORMAT(' THE SPECIFIED SHAPE PARAMETER SIGMA FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1073)
1073 FORMAT(' LOGNORMAL DISTRIBUTION MUST BE POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1075)
1075 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1076)SIGMA
1076 FORMAT(' THE SPECIFIED VALUE OF SIGMA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL LGNRAN(NRAN,SIGMA,ISEED,Y)
GOTO2990
C
1080 CONTINUE
CALL HFNRAN(NRAN,ISEED,Y)
GOTO2990
C
1090 CONTINUE
IHP='NU '
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
ANU=VALUE(ILOCP)
C
IF(ANU.GE.0.0)GOTO1097
WRITE(ICOUT,1091)
1091 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1092)
1092 FORMAT(' THE SPECIFIED TAIL LENGTH PARAMETER NU FOR THE T')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1094)
1094 FORMAT(' DISTRIBUTION MUST BE POSITIVE; SUCH WAS NOT THE ',
1 'CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1096)ANU
1096 FORMAT(' THE SPECIFIED VALUE OF NU = ',F12.5)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1097 CONTINUE
CALL TRAN(NRAN,ANU,ISEED,Y)
GOTO2990
C
1100 CONTINUE
IHP='NU '
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
ANU=VALUE(ILOCP)
C
IF(ANU.GE.0.0)GOTO1107
WRITE(ICOUT,1101)
1101 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1102)
1102 FORMAT(' THE SPECIFIED SHAPE PARAMETER NU FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1103)
1103 FORMAT(' CHI-SQUARED DISTRIBUTION MUST BE POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1105)
1105 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1106)ANU
1106 FORMAT(' THE SPECIFIED VALUE OF NU = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1107 CONTINUE
CALL CHSRAN(NRAN,ANU,ISEED,Y)
GOTO2990
C
1110 CONTINUE
IHP='NU1 '
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
ANU1=VALUE(ILOCP)
C
IHP='NU2 '
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
ANU2=VALUE(ILOCP)
C
IF(ANU1.GT.0.0.AND.ANU2.GT.0.0)GOTO1117
WRITE(ICOUT,1111)
1111 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1112)
1112 FORMAT(' THE SPECIFIED SHAPE PARAMETERS NU1 AND NU2')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1113)
1113 FORMAT(' FOR THE F DISTRIBUTION MUST BE POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1115)
1115 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1116)ANU1,ANU2
1116 FORMAT(' THE SPECIFIED VALUES OF NU1 AND NU2 = ',F12.5,
1' AND ',F12.5, '(RESPECTIVELY)')
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1117 CONTINUE
CALL FRAN(NRAN,ANU1,ANU2,ISEED,Y)
GOTO2990
C
1120 CONTINUE
CALL EXPRAN(NRAN,ISEED,Y)
GOTO2990
C
1130 CONTINUE
IHP='GAMM'
IHP2='A '
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
GAMMA=VALUE(ILOCP)
C
IF(GAMMA.GT.0)GOTO1137
WRITE(ICOUT,1131)
1131 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1132)
1132 FORMAT(' THE SPECIFIED SHAPE PARAMETER GAMMA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1133)
1133 FORMAT(' FOR THE GAMMA DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1134)
1134 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1135)
1135 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1136)GAMMA
1136 FORMAT(' THE SPECIFIED VALUE OF GAMMA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1137 CONTINUE
CALL GAMRAN(NRAN,GAMMA,ISEED,Y)
GOTO2990
C
1140 CONTINUE
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(ALPHA.GT.0.0.AND.BETA.GE.0.0)GOTO1147
WRITE(ICOUT,1141)
1141 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1142)
1142 FORMAT(' THE SPECIFIED SHAPE PARAMETERS ',
1'ALPHA AND BETA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1143)
1143 FORMAT(' FOR THE BETA DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1144)
1144 FORMAT(' MUST BE POSITIVE; SUCH WAS NOT THE CASE HERE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1146)ALPHA,BETA
1146 FORMAT(' THE SPECIFIED VALUES OF ALPHA AND BETA = ',
1E15.7,' AND ',E15.7, '(RESPECTIVELY)')
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1147 CONTINUE
CALL BETRAN(NRAN,ALPHA,BETA,ISEED,Y)
GOTO2990
C
1150 CONTINUE
IHP='GAMM'
IHP2='A '
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
GAMMA=VALUE(ILOCP)
C
IF(GAMMA.GT.0)GOTO1157
WRITE(ICOUT,1151)
1151 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1152)
1152 FORMAT(' THE SPECIFIED SHAPE PARAMETER GAMMA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1153)
1153 FORMAT(' FOR THE WEIBULL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1154)
1154 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1155)
1155 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1156)GAMMA
1156 FORMAT(' THE SPECIFIED VALUE OF GAMMA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1157 CONTINUE
CCCCC THE FOLLOWING LINE WAS CHANGED MAY 1993
CCCCC CALL WEIRAN(NRAN,GAMMA,ISEED,Y)
CALL WEIRAN(NRAN,GAMMA,MINMAX,ISEED,Y)
GOTO2990
C
1160 CONTINUE
CCCCC THE FOLLOWING LINE WAS CHANGED MAY 1993
CCCCC CALL EV1RAN(NRAN,ISEED,Y)
CALL EV1RAN(NRAN,MINMAX,ISEED,Y)
GOTO2990
C
1170 CONTINUE
IHP='GAMM'
IHP2='A '
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
GAMMA=VALUE(ILOCP)
C
IF(GAMMA.GT.0)GOTO1177
WRITE(ICOUT,1171)
1171 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1172)
1172 FORMAT(' THE SPECIFIED SHAPE PARAMETER GAMMA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1173)
1173 FORMAT(' FOR THE EXTREME VALUE TYPE 2 DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1174)
1174 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1175)
1175 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1176)GAMMA
1176 FORMAT(' THE SPECIFIED VALUE OF GAMMA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1177 CONTINUE
CCCCC THE FOLLOWING LINE WAS CHANGE MAY 1993
CCCCC CALL EV2RAN(NRAN,GAMMA,ISEED,Y)
CALL EV2RAN(NRAN,GAMMA,MINMAX,ISEED,Y)
GOTO2990
C
1180 CONTINUE
IHP='GAMM'
IHP2='A '
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
GAMMA=VALUE(ILOCP)
C
IF(GAMMA.LE.0.0)THEN
WRITE(ICOUT,1181)
1181 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1182)
1182 FORMAT(' THE SPECIFIED SHAPE PARAMETER GAMMA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1183)
1183 FORMAT(' FOR THE PARETO DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1184)
1184 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1185)
1185 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1186)GAMMA
1186 FORMAT(' THE SPECIFIED VALUE OF GAMMA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='A '
IHP2=' '
IHWUSE='P'
MESSAG='NO'
CALL CHECKN(IHP,IHP2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
IF(IERROR.EQ.'YES')THEN
A=1.0
ELSE
A=VALUE(ILOCP)
ENDIF
C
IF(A.LE.0.0)THEN
WRITE(ICOUT,11181)
11181 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11182)
11182 FORMAT(' THE SPECIFIED SHAPE PARAMETER A')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11183)
11183 FORMAT(' FOR THE PARETO DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11184)
11184 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11185)
11185 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11186)A
11186 FORMAT(' THE SPECIFIED VALUE OF A = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL PARRAN(NRAN,GAMMA,A,ISEED,Y)
GOTO2990
C
1190 CONTINUE
IHP='N '
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
NPAR=VALUE(ILOCP)+EPS
C
IHP='P '
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
P=VALUE(ILOCP)
C
IF(NPAR.GE.1.AND.0.0.LT.P.AND.P.LT.1.0)GOTO1197
WRITE(ICOUT,1191)
1191 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1192)
1192 FORMAT(' THE SPECIFIED INTEGER NUMBER OF TRIALS ',
1'PARAMETER N')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1193)
1193 FORMAT(' FOR THE BINOMIAL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1194)
1194 FORMAT(' MUST BE 1 OR LARGER, AND')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1195)
1195 FORMAT(' THE SPECIFIED PROBABILITY OF SUCCESS ',
1'PARAMETER P')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1196)
1196 FORMAT(' MUST BE BETWEEN 0 AND 1 (EXCLUSIVELY);')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8197)
8197 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1199)NPAR,P
1199 FORMAT(' THE SPECIFIED VALUES OF N AND P = ',I8,
1' AND ',E15.7,' (RESPECTIVELY)')
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1197 CONTINUE
CALL BINRAN(NRAN,P,NPAR,ISEED,Y)
GOTO2990
C
1200 CONTINUE
IHP='P '
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
P=VALUE(ILOCP)
C
IF(0.0.LT.P.AND.P.LT.1.0)GOTO1207
WRITE(ICOUT,1201)
1201 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1202)
1202 FORMAT(' THE SPECIFIED PROBABILITY OF SUCCESS ',
1'PARAMETER P')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1203)
1203 FORMAT(' FOR THE GEOMETRIC DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1204)
1204 FORMAT(' MUST BE BETWEEN 0 AND 1 (EXCLUSIVELY);')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1205)
1205 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1206)P
1206 FORMAT(' THE SPECIFIED VALUE OF P = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1207 CONTINUE
IF(IGEODF.EQ.'DLMF')THEN
CALL GE2RAN(NRAN,P,ISEED,Y)
ELSE
CALL GEORAN(NRAN,P,ISEED,Y)
ENDIF
GOTO2990
C
1210 CONTINUE
IHP='LAMB'
IHP2='DA '
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
ALAMBA=VALUE(ILOCP)
C
IF(ALAMBA.GT.0)GOTO1217
WRITE(ICOUT,1211)
1211 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1212)
1212 FORMAT(' THE SPECIFIED SHAPE PARAMETER LAMBDA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1213)
1213 FORMAT(' FOR THE POISSON DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1214)
1214 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1215)
1215 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1216)ALAMBA
1216 FORMAT(' THE SPECIFIED VALUE OF LAMBDA = ',I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1217 CONTINUE
CALL POIRAN(NRAN,ALAMBA,ISEED,Y)
GOTO2990
C
1220 CONTINUE
IHP='P '
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
P=VALUE(ILOCP)
C
IHP='K '
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
AK=VALUE(ILOCP)
C
IF(0.0.LT.P.AND.P.LT.1.0.AND.0.LT.AK)GOTO1227
WRITE(ICOUT,1221)
1221 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1222)
1222 FORMAT(' THE SPECIFIED PROBABILITY OF SUCCESS ',
1'PARAMETER P')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1223)
1223 FORMAT(' FOR THE NEGATIVE BINOMIAL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1224)
1224 FORMAT(' MUST BE BETWEEN 0 AND 1 (EXCLUSIVELY); AND')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1225)
1225 FORMAT(' THE SPECIFIED NUMBER OF SUCCESSES ',
1'PARAMETER K')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1226)
1226 FORMAT(' MUST BE 1 OR LARGER;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8227)
8227 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1229)P,AK
1229 FORMAT(' THE SPECIFIED VALUES OF P AND K = ',F10.5,
1' AND ',F10.5,' (RESPECTIVELY)')
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1227 CONTINUE
CALL NBRAN(NRAN,P,AK,ISEED,Y)
GOTO2990
C
1230 CONTINUE
C
IHP='R '
IHP2=' '
IHWUSE='P'
MESSAG='NO'
CALL CHECKN(IHP,IHP2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
IF(IERROR.EQ.'YES')THEN
R=1.0
ELSE
R=VALUE(ILOCP)
ENDIF
C
IF(R.LE.0.0)THEN
WRITE(ICOUT,1231)
1231 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1232)
1232 FORMAT(' THE SPECIFIED SHAPE PARAMETER R')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1233)
1233 FORMAT(' FOR THE SEMI-CIRCULAR DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1234)
1234 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1235)
1235 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1236)R
1236 FORMAT(' THE SPECIFIED VALUE OF R = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL SEMRAN(NRAN,R,ISEED,Y)
GOTO2990
C
1240 CONTINUE
C
ZLOWLM=-1.0
ZUPPLM=1.0
C
IHP='LOWL'
IHP2='IMIT'
IHWUSE='P'
MESSAG='NO'
CALL CHECKN(IHP,IHP2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
IF(IERROR.EQ.'YES')THEN
ZLOWLM=-1.0
ELSE
ZLOWLM=VALUE(ILOCP)
ENDIF
C
IHP='UPPL'
IHP2='IMIT'
IHWUSE='P'
MESSAG='NO'
CALL CHECKN(IHP,IHP2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
IF(IERROR.EQ.'YES')THEN
ZUPPLM=1.0
ELSE
ZUPPLM=VALUE(ILOCP)
ENDIF
ALOWLM=MIN(ZLOWLM,ZUPPLM)
AUPPLM=MAX(ZLOWLM,ZUPPLM)
C
IHP='C '
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
C=VALUE(ILOCP)
C
IF(C.LE.ALOWLM .OR. C.GE.AUPPLM)THEN
WRITE(ICOUT,1241)
1241 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1242)
1242 FORMAT(' THE SPECIFIED SHAPE PARAMETER C FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1243)
1243 FORMAT(' TRIANGULAR DISTRIBUTION MUST BE IN THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1244)ALOWLM,AUPPLM
1244 FORMAT(' INTERVAL (',G15.7,',',G15.7,');')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1245)
1245 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1246)C
1246 FORMAT(' THE SPECIFIED VALUE OF C = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL TRIRAN(NRAN,C,ALOWLM,AUPPLM,ISEED,Y)
GOTO2990
C
1250 CONTINUE
IHP='N '
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
NPAR=VALUE(ILOCP)+EPS
C
IF(NPAR.GE.1)GOTO1257
WRITE(ICOUT,1251)
1251 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1252)
1252 FORMAT(' THE SPECIFIED INTEGER NUMBER OF ITEMS ',
1'PARAMETER N')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1253)
1253 FORMAT(' FOR THE DISCRETE UNIFORM DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1254)
1254 FORMAT(' MUST BE 1 OR LARGER;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8197)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1259)NPAR
1259 FORMAT(' THE SPECIFIED VALUE OF N = ',I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1257 CONTINUE
CALL DUNRAN(NRAN,NPAR,ISEED,Y)
GOTO2990
C
1260 CONTINUE
IF(NRAN.GE.1)GOTO1267
WRITE(ICOUT,1261)
1261 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1262)
1262 FORMAT(' THE SPECIFIED INTEGER NUMBER OF ITEMS ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1263)
1263 FORMAT(' IN THE BOOTSTRAP INDEX')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1264)
1264 FORMAT(' MUST BE 1 OR LARGER;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8197)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1269)NRAN
1269 FORMAT(' THE SPECIFIED NUMBER OF ITEMS = ',I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1267 CONTINUE
CCCCC CALL DUNRAN(NRAN,NRAN,ISEED,Y)
CALL DUNRA2(NRAN,NRAN,ISEED,Y)
GOTO2990
C
1270 CONTINUE
IF(NRAN.GE.1)GOTO1277
WRITE(ICOUT,1271)
1271 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1272)
1272 FORMAT(' THE SPECIFIED INTEGER NUMBER OF ITEMS ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1273)
1273 FORMAT(' IN THE RANDOM PERMUTATION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1274)
1274 FORMAT(' MUST BE 1 OR LARGER;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8197)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1279)NRAN
1279 FORMAT(' THE SPECIFIED NUMBER OF ITEMS = ',I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1277 CONTINUE
CALL RANPER(NRAN,ISEED,Y)
GOTO2990
C
CCCCC OCTOBER 1993. THIS CODE IS NO LONGER ACTIVE. MOVED TO DPMATC.
1280 CONTINUE
IF(NRAN.GE.1)GOTO1287
WRITE(ICOUT,1281)
1281 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1282)
1282 FORMAT(' THE SPECIFIED INTEGER NUMBER OF ITEMS ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1283)
1283 FORMAT(' IN THE (RANDOM) JACKNIFE INDEX')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1284)
1284 FORMAT(' MUST BE 1 OR LARGER;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8197)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1289)NRAN
1289 FORMAT(' THE SPECIFIED NUMBER OF ITEMS = ',I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1287 CONTINUE
CALL RANPER(NRAN,ISEED,Y)
DO1288I=1,NRAN
AI=I
IYI=Y(I)+0.1
IF(IYI.EQ.NRAN)Y(I)=0.0
IF(IYI.NE.NRAN)Y(I)=AI
1288 CONTINUE
GOTO2990
C
CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1990
1290 CONTINUE
IHP='GAMM'
IHP2='A '
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
GAMMA=VALUE(ILOCP)
C
IHP='MU '
IHP2=' '
IHWUSE='P'
MESSAG='NO'
CALL CHECKN(IHP,IHP2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
IF(IERROR.EQ.'YES')THEN
AMU=1.0
ELSE
AMU=VALUE(ILOCP)
ENDIF
C
IF(GAMMA.LE.0)THEN
WRITE(ICOUT,1291)
1291 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1292)
1292 FORMAT(' THE SPECIFIED SHAPE PARAMETER GAMMA FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1293)
1293 FORMAT(' INVERSE GAUSSIAN DISTRIBUTION MUST BE STRICTLY')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1294)
1294 FORMAT(' LARGER THAN 0; SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1295)GAMMA
1295 FORMAT(' THE SPECIFIED VALUE OF GAMMA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IF(AMU.LE.0)THEN
WRITE(ICOUT,1296)
1296 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1297)
1297 FORMAT(' THE SPECIFIED SHAPE PARAMETER MU FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1298)
1298 FORMAT(' INVERSE GAUSSIAN DISTRIBUTION MUST BE STRICTLY')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1299)
1299 FORMAT(' LARGER THAN 0; SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,91299)AMU
91299 FORMAT(' THE SPECIFIED VALUE OF MU = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL IGRAN(NRAN,GAMMA,AMU,ISEED,Y)
GOTO2990
C
CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1990
1300 CONTINUE
IHP='GAMM'
IHP2='A '
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
GAMMA=VALUE(ILOCP)
C
IF(GAMMA.GT.0)GOTO1307
WRITE(ICOUT,1301)
1301 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1302)
1302 FORMAT(' THE SPECIFIED SHAPE PARAMETER GAMMA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1303)
1303 FORMAT(' FOR THE WALD DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1304)
1304 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1305)
1305 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1306)GAMMA
1306 FORMAT(' THE SPECIFIED VALUE OF GAMMA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1307 CONTINUE
CALL WALRAN(NRAN,GAMMA,ISEED,Y)
GOTO2990
C
CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1990
1310 CONTINUE
IHP='GAMM'
IHP2='A '
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
GAMMA=VALUE(ILOCP)
C
IF(GAMMA.LE.0.0)THEN
WRITE(ICOUT,1311)
1311 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1312)
1312 FORMAT(' THE SPECIFIED SHAPE PARAMETER GAMMA FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1313)
1313 FORMAT(' RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION MUST')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1314)
1314 FORMAT(' BE STRICTLY LARGER THAN 0; SUCH WAS NOT THE ',
1 'CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1315)GAMMA
1315 FORMAT(' THE SPECIFIED VALUE OF GAMMA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='MU '
IHP2=' '
IHWUSE='P'
MESSAG='NO'
CALL CHECKN(IHP,IHP2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
IF(IERROR.EQ.'YES')THEN
AMU=1.0
ELSE
AMU=VALUE(ILOCP)
ENDIF
C
IF(AMU.LE.0.0)THEN
WRITE(ICOUT,1316)
1316 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1317)
1317 FORMAT(' THE SPECIFIED SHAPE PARAMETER MU FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1318)
1318 FORMAT(' RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION MUST')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1319)
1319 FORMAT(' BE STRICTLY LARGER THAN 0; SUCH WAS NOT THE ',
1 'CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,91315)AMU
91315 FORMAT(' THE SPECIFIED VALUE OF AMU = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL RIGRAN(NRAN,GAMMA,AMU,ISEED,Y)
GOTO2990
C
CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1990
1320 CONTINUE
IHP='GAMM'
IHP2='A '
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
GAMMA=VALUE(ILOCP)
C
IF(GAMMA.GT.0)GOTO1327
WRITE(ICOUT,1321)
1321 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1322)
1322 FORMAT(' THE SPECIFIED SHAPE PARAMETER GAMMA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1323)
1323 FORMAT(' FOR THE FATIGUE LIFE DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1324)
1324 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1325)
1325 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1326)GAMMA
1326 FORMAT(' THE SPECIFIED VALUE OF GAMMA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1327 CONTINUE
CALL FLRAN(NRAN,GAMMA,ISEED,Y)
GOTO2990
C
CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 1993
1330 CONTINUE
IHP='GAMM'
IHP2='A '
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
GAMMA=VALUE(ILOCP)
C
CALL GEPRAN(NRAN,GAMMA,MINMAX,IGEPDF,ISEED,Y)
GOTO2990
C
CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1995
1340 CONTINUE
IHP='C '
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
C=VALUE(ILOCP)
C
CALL POWRAN(NRAN,C,ISEED,Y)
GOTO2990
C
CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 1995
1350 CONTINUE
IHP='K '
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
AK=VALUE(ILOCP)
C
IHP='N '
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
AN=VALUE(ILOCP)
C
IHP='M '
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
AM=VALUE(ILOCP)
C
NN1=INT(AN+0.5)
NN2=INT(AM-AN+0.5)
KK=INT(AK+0.5)
DO1352II=1,NRAN
CALL HYPRAN(KK,NN1,NN2,ISEED,JX)
IF(JX.EQ.-1)THEN
WRITE(ICOUT,1354)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1356)INT(AK),INT(AM),INT(AN)
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
ENDIF
1354 FORMAT('****** ERROR IN GENERATING HYPERGEOMETRIC RANDOM ',
1'NUMBERS.')
1356 FORMAT(' THE VALUES OF K, M, AND N = ',3I8)
Y(II)=REAL(JX)
1352 CONTINUE
GOTO2990
C
CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 1995
1360 CONTINUE
IHP='NU '
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
ANU=VALUE(ILOCP)
IF(ANU.LE.0.0)THEN
WRITE(ICOUT,1361)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1362)ANU
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
ENDIF
1361 FORMAT('****** ERROR IN GENERATING NON-CENTRAL CHI-SQUARE ',
1'RANDOM NUMBERS.')
1362 FORMAT(' THE VALUE OF NU (= ',F15.7,') IS NON-POSITIVE')
C
IHP='LAMB'
IHP2='DA '
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
ALAMBA=VALUE(ILOCP)
IF(ALAMBA.LT.0.0)THEN
WRITE(ICOUT,1363)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1364)ALAMBA
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
ENDIF
1363 FORMAT('****** ERROR IN GENERATING NON-CENTRAL CHI-SQUARE ',
1'RANDOM NUMBERS.')
1364 FORMAT(' THE VALUE OF LAMBDA (= ',F15.7,') IS LESS THAN 0.')
C
CALL NCCRAN(NRAN,ANU,ALAMBA,ISEED,Y)
GOTO2990
C
CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 1995
1370 CONTINUE
IHP='NU1 '
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
ANU1=VALUE(ILOCP)
IF(ANU1.LE.0.0)THEN
WRITE(ICOUT,1371)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1372)ANU1
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
ENDIF
1371 FORMAT('****** ERROR IN GENERATING NON-CENTRAL F RANDOM ',
1'NUMBERS.')
1372 FORMAT(' THE VALUE OF NU1 (= ',F15.7,') IS LESS THAN 1.')
C
IHP='NU2 '
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
ANU2=VALUE(ILOCP)
IF(ANU2.LT.1.0)THEN
WRITE(ICOUT,1373)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1374)ANU
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
ENDIF
1373 FORMAT('****** ERROR IN GENERATING NON-CENTRAL F RANDOM ',
1'NUMBERS.')
1374 FORMAT(' THE VALUE OF NU2 (= ',F15.7,') IS LESS THAN 1.')
C
IHP='LAMB'
IHP2='DA '
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
ALAMB1=VALUE(ILOCP)
IF(ALAMB1.LT.0.0)THEN
WRITE(ICOUT,1375)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1376)ALAMB1
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
ENDIF
1375 FORMAT('****** ERROR IN GENERATING NON-CENTRAL F RANDOM ',
1'NUMBERS.')
1376 FORMAT(' THE VALUE OF LAMBDA (= ',F15.7,') IS LESS THAN ',
1'0.')
C
CALL NCFRAN(NRAN,ANU1,ANU2,ALAMB1,ISEED,Y)
GOTO2990
C
CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 1995
1380 CONTINUE
IHP='NU1 '
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
ANU1=VALUE(ILOCP)
IF(ANU1.LE.0.0)THEN
WRITE(ICOUT,1381)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1382)ANU1
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
ENDIF
1381 FORMAT('****** ERROR IN GENERATING DOUBLY NON-CENTRAL F RANDOM ',
1'NUMBERS.')
1382 FORMAT(' THE VALUE OF NU1 (= ',F15.7,') IS LESS THAN 1.')
C
IHP='NU2 '
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
ANU2=VALUE(ILOCP)
IF(ANU2.LE.0.0)THEN
WRITE(ICOUT,1383)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1384)ANU2
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
ENDIF
1383 FORMAT('****** ERROR IN GENERATING DOUBLY NON-CENTRAL F RANDOM ',
1'NUMBERS.')
1384 FORMAT(' THE VALUE OF NU2 (= ',F15.7,') IS LESS THAN 1.')
C
IHP='LAMB'
IHP2='DA1 '
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
ALAMB1=VALUE(ILOCP)
IF(ALAMB1.LT.0.0)THEN
WRITE(ICOUT,1385)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1386)ALAMB1
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
ENDIF
1385 FORMAT('****** ERROR IN GENERATING DOUBLY NON-CENTRAL F RANDOM ',
1'NUMBERS.')
1386 FORMAT(' THE VALUE OF LAMBDA1 (= ',F15.7,') IS LESS THAN ',
1'0.')
C
IHP='LAMB'
IHP2='DA2 '
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
ALAMB2=VALUE(ILOCP)
IF(ALAMB2.LT.0.0)THEN
WRITE(ICOUT,1387)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1388)ALAMB2
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
ENDIF
1387 FORMAT('****** ERROR IN GENERATING DOUBLY NON-CENTRAL F RANDOM ',
1'NUMBERS.')
1388 FORMAT(' THE VALUE OF LAMBDA2 (= ',F15.7,') IS LESS THAN ',
1'0.')
C
CALL DNFRAN(NRAN,ANU1,ANU2,ALAMB1,ALAMB2,ISEED,Y)
GOTO2990
C
1390 CONTINUE
IHP='MU '
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
U=VALUE(ILOCP)
C
IHP='SD '
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
SD=VALUE(ILOCP)
C
IF(SD.GT.0.0)GOTO1397
WRITE(ICOUT,1391)
1391 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1392)
1392 FORMAT(' THE SPECIFIED SHAPE PARAMETER SD')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1393)
1393 FORMAT(' FOR THE FOLDED NORMAL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1394)
1394 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1395)
1395 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1396)SD
1396 FORMAT(' THE SPECIFIED VALUE OF SD = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1397 CONTINUE
CALL FNRRAN(NRAN,U,SD,ISEED,Y)
GOTO2990
C
1400 CONTINUE
CALL HFCRAN(NRAN,ISEED,Y)
GOTO2990
C
1410 CONTINUE
C
IHP='U1 '
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
U1=VALUE(ILOCP)
C
IHP='U2 '
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
U2=VALUE(ILOCP)
C
IHP='SD1 '
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
SD1=VALUE(ILOCP)
C
IF(SD1.GE.0.0)GOTO1417
WRITE(ICOUT,1411)
1411 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1412)
1412 FORMAT(' THE SPECIFIED SHAPE PARAMETER SD1')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1413)
1413 FORMAT(' FOR THE NORMAL MIXTURE DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1414)
1414 FORMAT(' MUST BE GREATER THAN 0.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1415)
1415 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1416)SD1
1416 FORMAT(' THE SPECIFIED VALUE OF SD1 = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1417 CONTINUE
C
IHP='SD2 '
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
SD2=VALUE(ILOCP)
C
IF(SD2.GE.0.0)GOTO1427
WRITE(ICOUT,1421)
1421 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1422)
1422 FORMAT(' THE SPECIFIED SHAPE PARAMETER SD2')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1423)
1423 FORMAT(' FOR THE NORMAL MIXTURE DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1424)
1424 FORMAT(' MUST BE GREATER THAN 0.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1425)
1425 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1426)SD2
1426 FORMAT(' THE SPECIFIED VALUE OF SD2 = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1427 CONTINUE
C
IHP='P '
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
P=VALUE(ILOCP)
C
IF(P.GE.0.0.AND.P.LE.1.0)GOTO1437
WRITE(ICOUT,1431)
1431 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1432)
1432 FORMAT(' THE SPECIFIED SHAPE PARAMETER P')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1433)
1433 FORMAT(' FOR THE NORMAL MIXTURE DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1434)
1434 FORMAT(' MUST BE IN THE INTERVAL (0,1).')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1435)
1435 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1436)P
1436 FORMAT(' THE SPECIFIED VALUE OF P = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1437 CONTINUE
C
CALL NMXRAN(NRAN,U1,SD1,U2,SD2,P,ISEED,Y)
GOTO2990
C
1440 CONTINUE
C
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(ALPHA.GT.0.0)GOTO1447
WRITE(ICOUT,1441)
1441 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1442)
1442 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1443)
1443 FORMAT(' FOR THE POWER LAW DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1444)
1444 FORMAT(' MUST BE GREATER THAN 0.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1445)
1445 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1446)ALPHA
1446 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
1447 CONTINUE
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(BETA.GT.0.0)GOTO1457
WRITE(ICOUT,1451)
1451 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1452)
1452 FORMAT(' THE SPECIFIED SHAPE PARAMETER BETA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1453)
1453 FORMAT(' FOR THE POWER LAW DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1454)
1454 FORMAT(' MUST BE GREATER THAN 0.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1455)
1455 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1456)BETA
1456 FORMAT(' THE SPECIFIED VALUE OF BETA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
1457 CONTINUE
C
CALL PWLRAN(NRAN,ALPHA,BETA,ISEED,Y)
GOTO2990
C
1460 CONTINUE
C
IHP='LAMB'
IHP2='DA3 '
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
ALAMB3=VALUE(ILOCP)
C
IHP='LAMB'
IHP2='DA4 '
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
ALAMB4=VALUE(ILOCP)
C
IF(IGLDDF.EQ.'RAMB')THEN
IWRITE='ERRO'
CALL GLDCHK(ALAMB3,ALAMB4,ALOWER,AUPPER,IFLAG,ISIGN,IWRITE)
IF(IFLAG.EQ.1)THEN
IERROR='YES'
GOTO9000
ENDIF
ENDIF
C
CALL GLDRAN(NRAN,ALAMB3,ALAMB4,IGLDDF,ISEED,Y)
GOTO2990
C
1480 CONTINUE
C
IHP='GAMM'
IHP2='A '
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
GAMMA=VALUE(ILOCP)
C
IF(GAMMA.LE.0.0)THEN
WRITE(ICOUT,1481)
1481 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1482)
1482 FORMAT(' THE SPECIFIED SHAPE PARAMETER GAMMA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1483)
1483 FORMAT(' FOR THE INVERTED WEIBULL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1484)
1484 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1485)
1485 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1486)GAMMA
1486 FORMAT(' THE SPECIFIED VALUE OF GAMMA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL IWERAN(NRAN,GAMMA,ISEED,Y)
GOTO2990
C
1490 CONTINUE
C
IHP='GAMM'
IHP2='A '
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
GAMMA=VALUE(ILOCP)
C
IF(GAMMA.LE.0.0)THEN
WRITE(ICOUT,1491)
1491 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1492)
1492 FORMAT(' THE SPECIFIED SHAPE PARAMETER GAMMA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1493)
1493 FORMAT(' FOR THE DOUBLE WEIBULL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1494)
1494 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1495)
1495 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1496)GAMMA
1496 FORMAT(' THE SPECIFIED VALUE OF GAMMA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL DWERAN(NRAN,GAMMA,ISEED,Y)
GOTO2990
C
1500 CONTINUE
C
IHP='GAMM'
IHP2='A '
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
GAMMA=VALUE(ILOCP)
C
IF(GAMMA.LE.0.0)THEN
WRITE(ICOUT,1501)
1501 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1502)
1502 FORMAT(' THE SPECIFIED SHAPE PARAMETER GAMMA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1503)
1503 FORMAT(' FOR THE DOUBLE GAMMA DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1504)
1504 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1505)
1505 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1506)GAMMA
1506 FORMAT(' THE SPECIFIED VALUE OF GAMMA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL DGARAN(NRAN,GAMMA,ISEED,Y)
GOTO2990
C
1510 CONTINUE
C
IHP='GAMM'
IHP2='A '
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
GAMMA=VALUE(ILOCP)
C
IF(GAMMA.LE.0.0)THEN
WRITE(ICOUT,1511)
1511 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1512)
1512 FORMAT(' THE SPECIFIED SHAPE PARAMETER GAMMA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1513)
1513 FORMAT(' FOR THE LOG GAMMA DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1514)
1514 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1515)
1515 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1516)GAMMA
1516 FORMAT(' THE SPECIFIED VALUE OF GAMMA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL LGARAN(NRAN,GAMMA,ILGADF,ISEED,Y)
GOTO2990
C
1520 CONTINUE
C
IHP='GAMM'
IHP2='A '
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
GAMMA=VALUE(ILOCP)
C
IF(GAMMA.LE.0.0)THEN
WRITE(ICOUT,1521)
1521 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1522)
1522 FORMAT(' THE SPECIFIED SHAPE PARAMETER GAMMA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1523)
1523 FORMAT(' FOR THE INVERTED GAMMA DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1524)
1524 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1525)
1525 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1526)GAMMA
1526 FORMAT(' THE SPECIFIED VALUE OF GAMMA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL IGARAN(NRAN,GAMMA,ISEED,Y)
GOTO2990
C
1530 CONTINUE
CALL COSRAN(NRAN,ISEED,Y)
GOTO2990
C
1540 CONTINUE
CALL ANGRAN(NRAN,ISEED,Y)
GOTO2990
C
1550 CONTINUE
CALL HSERAN(NRAN,ISEED,Y)
GOTO2990
C
1560 CONTINUE
CALL ARSRAN(NRAN,ISEED,Y)
GOTO2990
C
1570 CONTINUE
C
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(ALPHA.LE.0.0)THEN
WRITE(ICOUT,1571)
1571 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1572)
1572 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1573)
1573 FORMAT(' FOR THE LOG DOUBLE EXPONENTIAL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1574)
1574 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1575)
1575 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1576)ALPHA
1576 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL LDERAN(NRAN,ALPHA,ISEED,Y)
GOTO2990
C
1580 CONTINUE
C
IHP='GAMM'
IHP2='A '
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
GAMMA=VALUE(ILOCP)
C
CALL GEVRAN(NRAN,GAMMA,MINMAX,ISEED,Y)
GOTO2990
C
1590 CONTINUE
C
IHP='GAMM'
IHP2='A '
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
GAMMA=VALUE(ILOCP)
C
IHP='THET'
IHP2='A '
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
THETA=VALUE(ILOCP)
C
IF(GAMMA.LE.0.0)THEN
WRITE(ICOUT,1591)
1591 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1592)
1592 FORMAT(' THE SPECIFIED SHAPE PARAMETER GAMMA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1593)
1593 FORMAT(' FOR THE EXPONENTIATED WEIBULL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1594)
1594 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1595)
1595 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1596)GAMMA
1596 FORMAT(' THE SPECIFIED VALUE OF GAMMA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
IF(THETA.LE.0.0)THEN
WRITE(ICOUT,11591)
11591 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11592)
11592 FORMAT(' THE SPECIFIED SHAPE PARAMETER THETA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11593)
11593 FORMAT(' FOR THE EXPONENTIATED WEIBULL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11594)
11594 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11595)
11595 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11596)THETA
11596 FORMAT(' THE SPECIFIED VALUE OF THETA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL EWERAN(NRAN,GAMMA,THETA,ISEED,Y)
GOTO2990
C
1600 CONTINUE
C
IHP='C '
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
C=VALUE(ILOCP)
C
IHP='B '
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
B=VALUE(ILOCP)
C
IF(C.LE.1.0)THEN
WRITE(ICOUT,1601)
1601 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1602)
1602 FORMAT(' THE SPECIFIED SHAPE PARAMETER C')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1603)
1603 FORMAT(' FOR THE GOMPERTZ DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1604)
1604 FORMAT(' MUST BE STRICTLY LARGER THAN 1;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1605)
1605 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1606)C
1606 FORMAT(' THE SPECIFIED VALUE OF C = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
IF(B.LE.0.0)THEN
WRITE(ICOUT,11601)
11601 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11602)
11602 FORMAT(' THE SPECIFIED SHAPE PARAMETER B')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11603)
11603 FORMAT(' FOR THE GOMPERTZ DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11604)
11604 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11605)
11605 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11606)B
11606 FORMAT(' THE SPECIFIED VALUE OF B = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL GOMRAN(NRAN,C,B,ISEED,Y)
GOTO2990
C
1610 CONTINUE
C
IF(IFLGHL.EQ.1)THEN
IHP='GAMM'
IHP2='A '
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
GAMMA=VALUE(ILOCP)
C
IF(GAMMA.LE.0.0)THEN
WRITE(ICOUT,11611)
11611 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11612)
11612 FORMAT(' THE SPECIFIED SHAPE PARAMETER GAMMA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11613)
11613 FORMAT(' FOR THE GENERALIZED HALF-LOGISTIC ',
1 'DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11614)
11614 FORMAT(' MUST BE IN THE INTERVAL (0,5]')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11615)
11615 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11616)GAMMA
11616 FORMAT(' THE SPECIFIED VALUE OF GAMMA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
ELSE
GAMMA=-1.0
ENDIF
C
CALL HFLRAN(NRAN,GAMMA,ISEED,Y)
GOTO2990
C
1620 CONTINUE
C
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(ALPHA.LE.0.0)THEN
WRITE(ICOUT,1621)
1621 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1622)
1622 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1623)
1623 FORMAT(' FOR THE POWER EXPONENTIAL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1624)
1624 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1625)
1625 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1626)ALPHA
1626 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
IF(BETA.LE.0.0)THEN
WRITE(ICOUT,11621)
11621 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11622)
11622 FORMAT(' THE SPECIFIED SHAPE PARAMETER BETA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11623)
11623 FORMAT(' FOR THE POWER EXPONENTIAL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11624)
11624 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11625)
11625 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11626)BETA
11626 FORMAT(' THE SPECIFIED VALUE OF BETA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL PEXRAN(NRAN,ALPHA,BETA,ISEED,Y)
GOTO2990
C
1630 CONTINUE
C
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(ALPHA.LE.0.0)THEN
WRITE(ICOUT,1631)
1631 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1632)
1632 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1633)
1633 FORMAT(' FOR THE ALPHA DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1634)
1634 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1635)
1635 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1636)ALPHA
1636 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
IF(BETA.LE.0.0)THEN
WRITE(ICOUT,11631)
11631 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11632)
11632 FORMAT(' THE SPECIFIED SHAPE PARAMETER BETA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11633)
11633 FORMAT(' FOR THE ALPHA DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11634)
11634 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11635)
11635 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,11636)BETA
11636 FORMAT(' THE SPECIFIED VALUE OF BETA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL ALPRAN(NRAN,ALPHA,BETA,ISEED,Y)
GOTO2990
C
1640 CONTINUE
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(BETA.LE.0.0)THEN
WRITE(ICOUT,1641)
1641 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1642)
1642 FORMAT(' THE SPECIFIED SHAPE PARAMETER BETA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1643)
1643 FORMAT(' FOR THE BRADFORD DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1644)
1644 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1645)
1645 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1646)BETA
1646 FORMAT(' THE SPECIFIED VALUE OF BETA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL BRARAN(NRAN,BETA,ISEED,Y)
GOTO2990
C
1650 CONTINUE
C
IHP='B '
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
B=VALUE(ILOCP)
C
IF(B.LE.0.0)THEN
WRITE(ICOUT,1651)
1651 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1652)
1652 FORMAT(' THE SPECIFIED SHAPE PARAMETER B')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1653)
1653 FORMAT(' FOR THE RECIPROCAL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1654)
1654 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1655)
1655 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1656)B
1656 FORMAT(' THE SPECIFIED VALUE OF B = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL RECRAN(NRAN,B,ISEED,Y)
GOTO2990
C
1660 CONTINUE
C
IHP='ALPH'
IHP2='A1 '
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
ALPHA1=VALUE(ILOCP)
C
IHP='ALPH'
IHP2='A2 '
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
ALPHA2=VALUE(ILOCP)
C
IF(ALPHA2.LE.0.0)THEN
WRITE(ICOUT,1661)
1661 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1662)
1662 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA2')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1663)
1663 FORMAT(' FOR THE JOHNSON SB DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1664)
1664 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1665)
1665 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1666)ALPHA2
1666 FORMAT(' THE SPECIFIED VALUE OF ALPHA2 = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL JSBRAN(NRAN,ALPHA1,ALPHA2,ISEED,Y)
GOTO2990
C
1670 CONTINUE
C
IHP='ALPH'
IHP2='A1 '
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
ALPHA1=VALUE(ILOCP)
C
IHP='ALPH'
IHP2='A2 '
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
ALPHA2=VALUE(ILOCP)
C
IF(ALPHA2.LE.0.0)THEN
WRITE(ICOUT,1671)
1671 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1672)
1672 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA2')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1673)
1673 FORMAT(' FOR THE JOHNSON SB DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1674)
1674 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1675)
1675 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1676)ALPHA2
1676 FORMAT(' THE SPECIFIED VALUE OF ALPHA2 = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL JSURAN(NRAN,ALPHA1,ALPHA2,ISEED,Y)
GOTO2990
C
1680 CONTINUE
C
IHP='P '
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
P=VALUE(ILOCP)
C
IF(P.LE.0.0)THEN
WRITE(ICOUT,1681)
1681 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1682)
1682 FORMAT(' THE SPECIFIED SHAPE PARAMETER P')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1683)
1683 FORMAT(' FOR THE POWER NORMAL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1684)
1684 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1685)
1685 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1686)P
1686 FORMAT(' THE SPECIFIED VALUE OF P = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL PNRRAN(NRAN,P,ISEED,Y)
GOTO2990
C
1690 CONTINUE
C
IHP='DELT'
IHP2='A '
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
DELTA=VALUE(ILOCP)
C
IF(DELTA.LE.0.0)THEN
WRITE(ICOUT,1691)
1691 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1692)
1692 FORMAT(' THE SPECIFIED SHAPE PARAMETER DELTA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1693)
1693 FORMAT(' FOR THE LOG-LOGISTIC DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1694)
1694 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1695)
1695 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1696)DELTA
1696 FORMAT(' THE SPECIFIED VALUE OF DELTA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL LLGRAN(NRAN,DELTA,ISEED,Y)
GOTO2990
C
1700 CONTINUE
C
IHP='GAMM'
IHP2='A '
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
GAMMA=VALUE(ILOCP)
C
IF(GAMMA.LE.0.0)THEN
WRITE(ICOUT,1701)
1701 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1702)
1702 FORMAT(' THE SPECIFIED SHAPE PARAMETER GAMMA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1703)
1703 FORMAT(' FOR THE GEOMETRIC EXTREME EXPONENTIAL ',
1 'DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1704)
1704 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1705)
1705 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1706)GAMMA
1706 FORMAT(' THE SPECIFIED VALUE OF GAMMA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL GEERAN(NRAN,GAMMA,ISEED,Y)
GOTO2990
C
1710 CONTINUE
C
IHP='P '
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
P=VALUE(ILOCP)
C
IF(P.LE.0.0)THEN
WRITE(ICOUT,1711)
1711 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1712)
1712 FORMAT(' THE SPECIFIED SHAPE PARAMETER P')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1713)
1713 FORMAT(' FOR THE POWER LOGNORMAL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1714)
1714 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1715)
1715 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1716)P
1716 FORMAT(' THE SPECIFIED VALUE OF P = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='SD '
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')THEN
SD=1.0
ELSE
SD=VALUE(ILOCP)
ENDIF
C
IF(SD.LE.0.0)THEN
WRITE(ICOUT,1721)
1721 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1722)
1722 FORMAT(' THE SPECIFIED SHAPE PARAMETER SD')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1723)
1723 FORMAT(' FOR THE POWER LOGNORMAL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1724)
1724 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1725)
1725 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1726)SD
1726 FORMAT(' THE SPECIFIED VALUE OF SD = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL PLNRAN(NRAN,P,SD,ISEED,Y)
GOTO2990
C
1730 CONTINUE
C
IF(ICASRA.EQ.'POLY')THEN
IDIST='POLYA DISTRIBUTION'
ELSE
IDIST='BETA-BINOMIAL DISTRIBUTION'
ENDIF
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(ALPHA.LE.0.0)THEN
WRITE(ICOUT,1731)
1731 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1732)
1732 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1733)IDIST
1733 FORMAT(' FOR THE ',A26)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1734)
1734 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1735)
1735 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1736)ALPHA
1736 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(BETA.LE.0.0)THEN
WRITE(ICOUT,1741)
1741 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1742)
1742 FORMAT(' THE SPECIFIED SHAPE PARAMETER BETA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1743)IDIST
1743 FORMAT(' FOR THE ',A26)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1744)
1744 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1745)
1745 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1746)BETA
1746 FORMAT(' THE SPECIFIED VALUE OF BETA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='N '
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
N=INT(VALUE(ILOCP)+0.5)
C
IF(N.LT.1)THEN
WRITE(ICOUT,1751)
1751 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1752)
1752 FORMAT(' THE SPECIFIED SHAPE PARAMETER N')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1753)IDIST
1753 FORMAT(' FOR THE ',A26)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1754)
1754 FORMAT(' MUST BE AT LEAST 1;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1755)
1755 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1756)N
1756 FORMAT(' THE SPECIFIED VALUE OF N = ',I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IF(ICASRA.EQ.'POLY')THEN
CALL BBNRAN(ALPHA,BETA,N,NRAN,ISEED,Y)
ELSE
CALL BBNRAN(BETA,ALPHA,N,NRAN,ISEED,Y)
ENDIF
GOTO2990
C
1760 CONTINUE
C
IHP='THET'
IHP2='A '
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
THETA=VALUE(ILOCP)
C
IF(THETA.LT.0.0 .OR.THETA.GT.1.0)THEN
WRITE(ICOUT,1761)
1761 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1762)
1762 FORMAT(' THE SPECIFIED SHAPE PARAMETER THETA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1763)
1763 FORMAT(' FOR THE TWO-SIDED POWER DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1764)
1764 FORMAT(' MUST BE IN THE INTERVAL (0,1);')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1765)
1765 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1766)THETA
1766 FORMAT(' THE SPECIFIED VALUE OF THETA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='N '
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
AN=VALUE(ILOCP)
C
IF(AN.LE.0.0)THEN
WRITE(ICOUT,1771)
1771 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1772)
1772 FORMAT(' THE SPECIFIED SHAPE PARAMETER N')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1773)
1773 FORMAT(' FOR THE TWO-SIDED POWER DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1774)
1774 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1775)
1775 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1776)AN
1776 FORMAT(' THE SPECIFIED VALUE OF N = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL TSPRAN(NRAN,THETA,AN,ISEED,Y)
GOTO2990
C
1790 CONTINUE
C
IHP='SCAL'
IHP2='E1 '
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
ASCAL1=VALUE(ILOCP)
C
IF(ASCAL1.LE.0.0)THEN
WRITE(ICOUT,1791)
1791 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1792)
1792 FORMAT(' THE SPECIFIED SHAPE PARAMETER SCALE1')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1793)
1793 FORMAT(' FOR THE BIWEIBULL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1794)
1794 FORMAT(' MUST BE STRICTLY POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1795)
1795 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1796)ASCAL1
1796 FORMAT(' THE SPECIFIED VALUE OF SCALE1 = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='GAMM'
IHP2='A1 '
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
GAMMA1=VALUE(ILOCP)
C
IF(GAMMA1.LE.0.0)THEN
WRITE(ICOUT,1801)
1801 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1802)
1802 FORMAT(' THE SPECIFIED SHAPE PARAMETER GAMMA1')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1803)
1803 FORMAT(' FOR THE BIWEIBULL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1804)
1804 FORMAT(' MUST BE STRICTLY POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1805)
1805 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1806)GAMMA1
1806 FORMAT(' THE SPECIFIED VALUE OF GAMMA1 = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='SCAL'
IHP2='E2 '
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
ASCAL2=VALUE(ILOCP)
C
IF(ASCAL2.LE.0.0)THEN
WRITE(ICOUT,1811)
1811 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1812)
1812 FORMAT(' THE SPECIFIED SHAPE PARAMETER SCALE2')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1813)
1813 FORMAT(' FOR THE BIWEIBULL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1814)
1814 FORMAT(' MUST BE STRICTLY POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1815)
1815 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1816)ASCAL2
1816 FORMAT(' THE SPECIFIED VALUE OF SCALE2 = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='GAMM'
IHP2='A2 '
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
GAMMA2=VALUE(ILOCP)
C
IF(GAMMA2.LE.0.0)THEN
WRITE(ICOUT,1821)
1821 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1822)
1822 FORMAT(' THE SPECIFIED SHAPE PARAMETER GAMMA2')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1823)
1823 FORMAT(' FOR THE BIWEIBULL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1824)
1824 FORMAT(' MUST BE STRICTLY POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1825)
1825 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1826)GAMMA2
1826 FORMAT(' THE SPECIFIED VALUE OF GAMMA2 = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='LOC2'
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
ALOC2=VALUE(ILOCP)
C
IF(ALOC2.LE.0.0)THEN
WRITE(ICOUT,1831)
1831 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1832)
1832 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALOC2')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1833)
1833 FORMAT(' FOR THE BIWEIBULL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1834)
1834 FORMAT(' MUST BE STRICTLY POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1835)
1835 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1836)ALOC2
1836 FORMAT(' THE SPECIFIED VALUE OF LOC2 = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL BWERAN(NRAN,ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,ISEED,Y)
GOTO2990
C
1850 CONTINUE
IHP='THET'
IHP2='A '
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
THETA=VALUE(ILOCP)
C
IF(0.0.LT.THETA.AND.THETA.LT.1.0)GOTO1857
WRITE(ICOUT,1851)
1851 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1852)
1852 FORMAT(' THE SPECIFIED SHAPE PARAMETER THETA FOR THE ',
1'LOGARITHMIC SERIES DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1854)
1854 FORMAT(' MUST BE BETWEEN 0 AND 1 (EXCLUSIVELY); SUCH WAS',
1' NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1856)THETA
1856 FORMAT(' THE SPECIFIED VALUE OF THETA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1857 CONTINUE
CALL DLGRAN(NRAN,THETA,ISEED,Y)
GOTO2990
C
1860 CONTINUE
IHP='G '
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
G=VALUE(ILOCP)
C
IF(G.GE.0.0)GOTO1867
WRITE(ICOUT,1861)
1861 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1862)
1862 FORMAT(' THE SPECIFIED SHAPE PARAMETER G FOR THE ',
1'G-AND-H DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1864)
1864 FORMAT(' MUST BE NON-NEGATIVE; SUCH WAS NOT THE CASE ',
1' HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1866)G
1866 FORMAT(' THE SPECIFIED VALUE OF G = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1867 CONTINUE
C
IHP='H '
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
AH=VALUE(ILOCP)
C
IF(AH.GE.0.0)GOTO1877
WRITE(ICOUT,1871)
1871 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1872)
1872 FORMAT(' THE SPECIFIED SHAPE PARAMETER H FOR THE ',
1'G-AND-H DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1874)
1874 FORMAT(' MUST BE NON-NEGATIVE; SUCH WAS NOT THE CASE ',
1' HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1876)AH
1876 FORMAT(' THE SPECIFIED VALUE OF H = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1877 CONTINUE
CALL GHRAN(NRAN,G,AH,ISEED,Y)
GOTO2990
C
1880 CONTINUE
CALL SLARAN(NRAN,ISEED,Y)
GOTO2990
C
1890 CONTINUE
CALL LANRAN(NRAN,ISEED,Y)
GOTO2990
C
1900 CONTINUE
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(ALPHA.LE.0.0)THEN
WRITE(ICOUT,1901)
1901 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1902)
1902 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA FOR THE ',
1 'INVERTED BETA DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1904)
1904 FORMAT(' MUST BE POSITIVE; SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1906)ALPHA
1906 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(BETA.LE.0.0)THEN
WRITE(ICOUT,1911)
1911 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1912)
1912 FORMAT(' THE SPECIFIED SHAPE PARAMETER BETA FOR THE ',
1 'INVERTED BETA DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1914)
1914 FORMAT(' MUST BE POSITIVE; SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1916)BETA
1916 FORMAT(' THE SPECIFIED VALUE OF BETA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
CALL IBRAN(NRAN,ALPHA,BETA,ISEED,Y)
GOTO2990
C
1920 CONTINUE
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(ALPHA.LT.1.0)THEN
WRITE(ICOUT,1921)
1921 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1922)
1922 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA FOR THE ',
1 'ERROR DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1924)
1924 FORMAT(' MUST BE POSITIVE; SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1926)ALPHA
1926 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL ERRRAN(NRAN,ALPHA,ISEED,Y)
GOTO2990
C
1930 CONTINUE
IHP='A '
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
A=VALUE(ILOCP)
C
IHP='B '
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
B=VALUE(ILOCP)
C
IHP='C '
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
C=VALUE(ILOCP)
C
IHP='D '
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
DZ=VALUE(ILOCP)
C
IF(A.GT.B .OR. B.GT.C .OR. C.GT.DZ)THEN
WRITE(ICOUT,1932)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1933)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1934)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1936)A,B,C,DZ
CALL DPWRST('XXX','BUG ')
PDF=0.0
GOTO9000
ENDIF
1932 FORMAT(
1'***** FATAL ERROR--FOR THE TRAPEZOID DISTRIBUTION, THE FOUR')
1933 FORMAT(
1' SHAPE PARAMETERS (A, B, C, D) MUST SATISFY')
1934 FORMAT(
1' A <= B <= C <= D')
1936 FORMAT(
1' A, B, C, D = ',4E15.7)
C
CALL TRARAN(NRAN,A,B,C,DZ,ISEED,Y)
GOTO2990
C
1940 CONTINUE
IHP='B '
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
B=VALUE(ILOCP)
C
IF(B.LE.0.0)THEN
WRITE(ICOUT,1941)
1941 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1942)
1942 FORMAT(' THE SPECIFIED SHAPE PARAMETER B FOR THE ',
1 'VON MISES DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1944)
1944 FORMAT(' MUST BE POSITIVE; SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1946)B
1946 FORMAT(' THE SPECIFIED VALUE OF B = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL VONRAN(NRAN,B,ISEED,Y)
GOTO2990
C
1950 CONTINUE
IHP='GAMM'
IHP2='A '
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
GAMMA=VALUE(ILOCP)
C
IF(GAMMA.LE.0.0)THEN
WRITE(ICOUT,1951)
1951 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1952)
1952 FORMAT(' THE SPECIFIED SHAPE PARAMETER GAMMA FOR THE ',
1 'PARETO SECOND KIND DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1953)
1953 FORMAT(' MUST BE POSITIVE; SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1954)GAMMA
1954 FORMAT(' THE SPECIFIED VALUE OF GAMMA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='A '
IHP2=' '
IHWUSE='P'
MESSAG='NO'
CALL CHECKN(IHP,IHP2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
IF(IERROR.EQ.'YES')THEN
A=1.0
ELSE
A=VALUE(ILOCP)
ENDIF
C
IF(A.LE.0.0)THEN
WRITE(ICOUT,1951)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1956)
1956 FORMAT(' THE SPECIFIED SHAPE PARAMETER A FOR THE ',
1 'PARETO SECOND KIND DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1957)
1957 FORMAT(' MUST BE POSITIVE; SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1958)A
1958 FORMAT(' THE SPECIFIED VALUE OF A = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL PA2RAN(NRAN,GAMMA,A,ISEED,Y)
GOTO2990
C
1960 CONTINUE
IHP='P '
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
P=VALUE(ILOCP)
C
IF(P.LT.0.0.OR.P.GE.1.0)THEN
WRITE(ICOUT,1961)
1961 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1962)
1962 FORMAT(' THE SPECIFIED SHAPE PARAMETER P FOR THE ',
1 'WRAPPED CAUCHY DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1964)
1964 FORMAT(' MUST BE IN THE INTERVAL (0,1]; SUCH WAS NOT THE ',
1 'CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1966)P
1966 FORMAT(' THE SPECIFIED VALUE OF P = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL WCARAN(NRAN,P,ISEED,Y)
GOTO2990
C
1970 CONTINUE
IHP='A '
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
A=VALUE(ILOCP)
C
IHP='B '
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
B=VALUE(ILOCP)
C
IHP='C '
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
C=VALUE(ILOCP)
C
IHP='D '
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
DZ=VALUE(ILOCP)
C
IHP='NU1 '
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
ANU1=VALUE(ILOCP)
C
IHP='NU3 '
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
ANU3=VALUE(ILOCP)
C
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(A.GT.B .OR. B.GT.C .OR. C.GT.DZ)THEN
WRITE(ICOUT,1972)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1973)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1974)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1976)A,B,C,DZ
CALL DPWRST('XXX','BUG ')
PDF=0.0
GOTO9000
ENDIF
1972 FORMAT(
1'***** FATAL ERROR--FOR THE GENERALIZED TRAPEZOID DISTRIBUTION,')
1973 FORMAT(
1' THE FOUR SHAPE PARAMETERS (A, B, C, D) MUST SATISFY')
1974 FORMAT(
1' A <= B <= C <= D')
1976 FORMAT(
1' A, B, C, D = ',4E15.7)
C
IF(ALPHA.LE.0.0)THEN
WRITE(ICOUT,1981)
1981 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1982)
1982 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA FOR THE ',
1 'GENERALIZED TRAPEZOID DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1984)
1984 FORMAT(' MUST BE POSITIVE; SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1986)ALPHA
1986 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IF(ANU1.LE.0.0)THEN
WRITE(ICOUT,1991)
1991 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1992)
1992 FORMAT(' THE SPECIFIED SHAPE PARAMETER ANU1 FOR THE ',
1 'GENERALIZED TRAPEZOID DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1994)
1994 FORMAT(' MUST BE POSITIVE; SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1996)ANU1
1996 FORMAT(' THE SPECIFIED VALUE OF ANU1 = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IF(ANU3.LE.0.0)THEN
WRITE(ICOUT,2001)
2001 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2002)
2002 FORMAT(' THE SPECIFIED SHAPE PARAMETER ANU3 FOR THE ',
1 'GENERALIZED TRAPEZOID DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2004)
2004 FORMAT(' MUST BE POSITIVE; SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2006)ANU3
2006 FORMAT(' THE SPECIFIED VALUE OF ANU3 = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL GTRRAN(NRAN,A,B,C,DZ,ANU1,ANU3,ALPHA,ISEED,Y)
GOTO2990
C
2010 CONTINUE
IHP='A '
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
A=VALUE(ILOCP)
C
IHP='B '
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
B=VALUE(ILOCP)
C
IF(A.GT.B)THEN
ATEMP=A
A=B
B=ATEMP
ENDIF
C
IHP='MU '
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
U=VALUE(ILOCP)
C
IHP='SD '
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
SD=VALUE(ILOCP)
C
IF(A.EQ.B)THEN
WRITE(ICOUT,2011)
2011 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2012)
2012 FORMAT(' FOR THE TRUNCATED NORMAL DISTRIBUTION, THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2014)
2014 FORMAT(' TRUNCATION BOUNDS A AND B SHOULD NOT BE EQUAL;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2015)
2015 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2016)A,B
2016 FORMAT(' THE SPECIFIED VALUES OF A, B = ',2E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IF(SD.LE.0.0)THEN
WRITE(ICOUT,2021)
2021 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2022)
2022 FORMAT(' THE SPECIFIED STANDARD DEVIATION PARAMETER SD')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2024)
2024 FORMAT(' FOR THE TRUNCATED NORMAL DISTRIBUTION MUST BE ',
1 'POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2025)
2025 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2026)SD
2026 FORMAT(' THE SPECIFIED VALUE OF SD = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL TNRRAN(NRAN,A,B,U,SD,ISEED,Y)
GOTO2990
C
2040 CONTINUE
IHP='NU '
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
NU=VALUE(ILOCP)+EPS
ANU=REAL(NU)
C
IF(ANU.LT.0.9999)THEN
WRITE(ICOUT,2041)
2041 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2042)
2042 FORMAT(' THE SPECIFIED INTEGER SHAPE PARAMETER NU FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2044)
2044 FORMAT(' CHI DISTRIBUTION MUST BE 1 OR LARGER;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2045)
2045 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2046)NU
2046 FORMAT(' THE SPECIFIED VALUE OF NU = ',I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL CHRAN(NRAN,ANU,ISEED,Y)
GOTO2990
C
2050 CONTINUE
IHP='LOC '
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
ALOC=VALUE(ILOCP)
C
IHP='SCAL'
IHP2='E '
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
ASCALE=VALUE(ILOCP)
C
IF(ASCALE.LE.0.0)THEN
WRITE(ICOUT,2051)
2051 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2052)
2052 FORMAT(' THE SPECIFIED SCALE PARAMETER SCALE FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2054)
2054 FORMAT(' FOLDED CAUCHY DISTRIBUTION MUST BE POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2055)
2055 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2056)ASCALE
2056 FORMAT(' THE SPECIFIED VALUE OF SCALE = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL FCARAN(NRAN,ALOC,ASCALE,ISEED,Y)
GOTO2990
C
2060 CONTINUE
IHP='K '
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
AK=VALUE(ILOCP)
C
IF(AK.LE.0.0)THEN
WRITE(ICOUT,2061)
2061 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2062)
2062 FORMAT(' THE SPECIFIED SHAPE PARAMETER, K, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2064)
2064 FORMAT(' MIELKE BETA-KAPPA DISTRIBUTION MUST BE POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2065)
2065 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2066)AK
2066 FORMAT(' THE SPECIFIED VALUE OF K = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(BETA.LE.0.0)THEN
WRITE(ICOUT,2071)
2071 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2072)
2072 FORMAT(' THE SPECIFIED SHAPE PARAMETER, BETA, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2074)
2074 FORMAT(' MIELKE BETA-KAPPA DISTRIBUTION MUST BE POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2075)
2075 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2076)BETA
2076 FORMAT(' THE SPECIFIED VALUE OF BETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='THET'
IHP2='A '
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
THETA=VALUE(ILOCP)
C
IF(THETA.LE.0.0)THEN
WRITE(ICOUT,2081)
2081 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2082)
2082 FORMAT(' THE SPECIFIED SHAPE PARAMETER, THETA, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2084)
2084 FORMAT(' MIELKE BETA-KAPPA DISTRIBUTION MUST BE POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2085)
2085 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2086)THETA
2086 FORMAT(' THE SPECIFIED VALUE OF THETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL KAPRAN(NRAN,AK,BETA,THETA,ISEED,Y)
GOTO2990
C
2090 CONTINUE
IHP='LAMB'
IHP2='DA1 '
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
ALAM1=VALUE(ILOCP)
C
IF(ALAM1.LE.0.0)THEN
WRITE(ICOUT,2091)
2091 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2092)
2092 FORMAT(' THE SPECIFIED SHAPE PARAMETER, LAMBDA1, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2094)
2094 FORMAT(' GENERALIZED EXPONENTIAL DISTRIBUTION MUST BE ',
1 'POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2095)
2095 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2096)ALAM1
2096 FORMAT(' THE SPECIFIED VALUE OF LAMBDA1 = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='LAMB'
IHP2='DA12'
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
ALAM12=VALUE(ILOCP)
C
IF(ALAM12.LE.0.0)THEN
WRITE(ICOUT,2101)
2101 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2102)
2102 FORMAT(' THE SPECIFIED SHAPE PARAMETER, LAMBDA12, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2104)
2104 FORMAT(' GENERALIZED EXPONENTIAL DISTRIBUTION MUST BE ',
1 'POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2105)
2105 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2106)ALAM12
2106 FORMAT(' THE SPECIFIED VALUE OF LAMBDA12 = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='S '
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
S=VALUE(ILOCP)
C
IF(S.LE.0.0)THEN
WRITE(ICOUT,2111)
2111 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2112)
2112 FORMAT(' THE SPECIFIED SHAPE PARAMETER, S, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2114)
2114 FORMAT(' GENERALIZED EXPONENTIAL DISTRIBUTION MUST BE ',
1 'POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2115)
2115 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2116)S
2116 FORMAT(' THE SPECIFIED VALUE OF S = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL GEXRAN(NRAN,ALAM12,ALAM12,S,ISEED,Y)
GOTO2990
C
2120 CONTINUE
IHP='X0 '
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
X0=VALUE(ILOCP)
C
IF(X0.LE.0.0)THEN
WRITE(ICOUT,2121)
2121 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2122)
2122 FORMAT(' THE SPECIFIED TRUNCATION PARAMETER, X0, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2124)
2124 FORMAT(' TRUNCATED EXPONENTIAL DISTRIBUTION MUST BE ',
1 'POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2125)
2125 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2126)X0
2126 FORMAT(' THE SPECIFIED VALUE OF X0 = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='M '
IHP2=' '
IHWUSE='P'
MESSAG='NO'
CALL CHECKN(IHP,IHP2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
IF(IERROR.EQ.'YES')THEN
AM=0.0
ELSE
AM=VALUE(ILOCP)
ENDIF
C
IF(AM.LT.0.0)THEN
WRITE(ICOUT,2131)
2131 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2132)
2132 FORMAT(' THE SPECIFIED LOCATION PARAMETER, M, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2134)
2134 FORMAT(' TRUNCATED EXPONENTIAL DISTRIBUTION MUST BE ',
1 'NON-NEGATIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2135)
2135 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2136)AM
2136 FORMAT(' THE SPECIFIED VALUE OF M = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
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')THEN
SD=0.0
ELSE
SD=VALUE(ILOCP)
ENDIF
C
IF(SD.LE.0.0)THEN
WRITE(ICOUT,2141)
2141 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2142)
2142 FORMAT(' THE SPECIFIED SCALE PARAMETER, SD, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2144)
2144 FORMAT(' TRUNCATED EXPONENTIAL DISTRIBUTION MUST BE ',
1 'POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2145)
2145 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2146)SD
2146 FORMAT(' THE SPECIFIED VALUE OF SD = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL TNERAN(NRAN,X0,AM,SD,ISEED,Y)
GOTO2990
C
2150 CONTINUE
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(ALPHA.LE.0.0)THEN
WRITE(ICOUT,2151)
2151 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2152)
2152 FORMAT(' THE SPECIFIED SHAPE PARAMETER, ALPHA, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2154)
2154 FORMAT(' GENERALIZED GAMMA DISTRIBUTION MUST BE ',
1 'POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2155)
2155 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2156)ALPHA
2156 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='C '
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
C=VALUE(ILOCP)
C
IF(C.EQ.0.0)THEN
WRITE(ICOUT,2161)
2161 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2162)
2162 FORMAT(' THE SPECIFIED SHAPE PARAMETER, C, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2164)
2164 FORMAT(' GENERALIZED GAMMA DISTRIBUTION MUST NOT BE ',
1 'ZERO;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2165)
2165 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2166)C
2166 FORMAT(' THE SPECIFIED VALUE OF C = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL GGDRAN(NRAN,ALPHA,C,ISEED,Y)
GOTO2990
C
2170 CONTINUE
IHP='NU '
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
ANU=VALUE(ILOCP)
NU=INT(ANU+0.5)
C
IF(NU.LT.1)THEN
WRITE(ICOUT,2171)
2171 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2172)
2172 FORMAT(' THE SPECIFIED SHAPE PARAMETER, NU, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2174)
2174 FORMAT(' FOLDED T DISTRIBUTION MUST BE A POSITIVE ',
1 'INTEGER;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2175)
2175 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2176)NU
2176 FORMAT(' THE SPECIFIED VALUE OF NU = ',I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL FTRAN(NRAN,NU,ISEED,Y)
GOTO2990
C
2180 CONTINUE
IHP='LAMB'
IHP2='DA '
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
ALMBDA=VALUE(ILOCP)
C
CALL SNRAN(NRAN,ALMBDA,ISKNDF,ISEED,Y)
GOTO2990
C
2190 CONTINUE
IHP='NU '
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
ANU=VALUE(ILOCP)
NU=INT(ANU+0.5)
C
IHP='LAMB'
IHP2='DA '
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
ALMBDA=VALUE(ILOCP)
C
IF(NU.LT.1)THEN
WRITE(ICOUT,2191)
2191 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2192)
2192 FORMAT(' THE SPECIFIED SHAPE PARAMETER, NU, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2194)
2194 FORMAT(' SKEWED T DISTRIBUTION MUST BE A POSITIVE ',
1 'INTEGER;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2195)
2195 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2196)NU
2196 FORMAT(' THE SPECIFIED VALUE OF NU = ',I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL STRAN(NRAN,NU,ALMBDA,ISEED,Y)
GOTO2990
C
2200 CONTINUE
C
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(ALPHA.LT.1.0)THEN
WRITE(ICOUT,2201)
2201 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2202)
2202 FORMAT(' THE SPECIFIED SHAPE PARAMETER, ALPHA, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2204)
2204 FORMAT(' ZETA DISTRIBUTION MUST BE > 1. SUCH WAS NOT ',
1 'THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2206)ALPHA
2206 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL ZETRAN(NRAN,ALPHA,ISEED,Y)
GOTO2990
C
2210 CONTINUE
IF(IMAKDF.EQ.'DLMF')THEN
IHP='XI '
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
XI=VALUE(ILOCP)
C
IF(XI.LE.0.0)THEN
WRITE(ICOUT,2211)
2211 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2212)
2212 FORMAT(' THE SPECIFIED SHAPE PARAMETER, XI, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2214)
2214 FORMAT(' COMPERTZ-MAKEHAM DISTRIBUTION MUST BE ',
1 'POSITIVE. SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2216)XI
2216 FORMAT(' THE SPECIFIED VALUE OF XI = ',
1 G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='LAMB'
IHP2='DA '
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
ALAMB=VALUE(ILOCP)
C
IF(ALAMB.LE.0.0)THEN
WRITE(ICOUT,2221)
2221 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2222)
2222 FORMAT(' THE SPECIFIED SHAPE PARAMETER, LAMBDA, ',
1 'FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2224)
2224 FORMAT(' COMPERTZ-MAKEHAM DISTRIBUTION MUST BE ',
1 'POSITIVE. SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2226)ALAMB
2226 FORMAT(' THE SPECIFIED VALUE OF ALAMB = ',
1 G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='THET'
IHP2='A '
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
THETA=VALUE(ILOCP)
C
IF(THETA.LT.0.0)THEN
WRITE(ICOUT,2231)
2231 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2232)
2232 FORMAT(' THE SPECIFIED SHAPE PARAMETER, THETA, ',
1 'FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2234)
2234 FORMAT(' COMPERTZ-MAKEHAM DISTRIBUTION MUST BE ',
1 'POSITIVE. SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2236)THETA
2236 FORMAT(' THE SPECIFIED VALUE OF THETA = ',
1 G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL MAKRAN(NRAN,XI,ALAMB,THETA,ISEED,Y)
ELSEIF(IMAKDF.EQ.'MEEK')THEN
IHP='GAMM'
IHP2='A '
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
GAMMA=VALUE(ILOCP)
C
IF(GAMMA.LE.0.0)THEN
WRITE(ICOUT,22211)
22211 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,22212)
22212 FORMAT(' THE SPECIFIED SHAPE PARAMETER, GAMMA, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,22214)
22214 FORMAT(' COMPERTZ-MAKEHAM DISTRIBUTION MUST BE ',
1 'POSITIVE. SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,22216)GAMMA
22216 FORMAT(' THE SPECIFIED VALUE OF GAMMA = ',
1 G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='LAMB'
IHP2='DA '
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
ALAMB=VALUE(ILOCP)
C
IF(ALAMB.LT.0.0)THEN
WRITE(ICOUT,22221)
22221 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,22222)
22222 FORMAT(' THE SPECIFIED SHAPE PARAMETER, LAMBDA, ',
1 'FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,22224)
22224 FORMAT(' COMPERTZ-MAKEHAM DISTRIBUTION MUST BE ',
1 'NON-NEGATIVE. SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,22226)ALAMB
22226 FORMAT(' THE SPECIFIED VALUE OF ALAMB = ',
1 G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='K '
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
AK=VALUE(ILOCP)
C
IF(AK.LE.0.0)THEN
WRITE(ICOUT,22231)
22231 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,22232)
22232 FORMAT(' THE SPECIFIED SHAPE PARAMETER, K, ',
1 'FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,22234)
22234 FORMAT(' COMPERTZ-MAKEHAM DISTRIBUTION MUST BE ',
1 'POSITIVE. SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,22236)AK
22236 FORMAT(' THE SPECIFIED VALUE OF K = ',
1 G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
XI=GAMMA/AK
THETA=ALAMB/GAMMA
ALAMB=AK
CALL MAKRAN(NRAN,XI,ALAMB,THETA,ISEED,Y)
ELSEIF(IMAKDF.EQ.'REPA')THEN
C
IHP='ZETA'
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
ZETA=VALUE(ILOCP)
C
IHP='ETA '
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
ETA=VALUE(ILOCP)
C
IF(ETA.LT.0.0)THEN
WRITE(ICOUT,32231)
32231 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,32232)
32232 FORMAT(' THE SPECIFIED SHAPE PARAMETER, ETA, ',
1 'FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,32234)
32234 FORMAT(' COMPERTZ-MAKEHAM DISTRIBUTION MUST BE ',
1 'NON-NEGATIVE. SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,32236)ETA
32236 FORMAT(' THE SPECIFIED VALUE OF ETA = ',
1 G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL MA2RAN(NRAN,ZETA,ETA,ISEED,Y)
ENDIF
GOTO2990
C
2240 CONTINUE
IHP='CHI '
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
CHI=VALUE(ILOCP)
C
IF(CHI.LE.0.0)THEN
WRITE(ICOUT,2241)
2241 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2242)
2242 FORMAT(' THE SPECIFIED SHAPE PARAMETER, CHI, FOR THE ',
1 'GENERALIZE INVERSE GAUSSIAN')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2244)
2244 FORMAT(' DISTRIBUTION MUST BE POSITIVE. SUCH WAS NOT ',
1 'THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2246)CHI
2246 FORMAT(' THE SPECIFIED VALUE OF CHI = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='LAMB'
IHP2='DA '
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
ALAMB=VALUE(ILOCP)
C
IF(ALAMB.LE.0.0)THEN
WRITE(ICOUT,2251)
2251 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2252)
2252 FORMAT(' THE SPECIFIED SHAPE PARAMETER, LAMBDA, FOR ',
1 'THE GENERALIZED INVERSE GAUSSIAN')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2254)
2254 FORMAT(' DISTRIBUTION MUST BE POSITIVE. SUCH WAS NOT ',
1 'THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2256)ALAMB
2256 FORMAT(' THE SPECIFIED VALUE OF ALAMB = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='THET'
IHP2='A '
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
THETA=VALUE(ILOCP)
C
IF(THETA.LT.0.0)THEN
WRITE(ICOUT,2261)
2261 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2262)
2262 FORMAT(' THE SPECIFIED SHAPE PARAMETER, LAMBDA, FOR THE',
1 ' GENERALIZED INVERSE GAUSSIAN')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2264)
2264 FORMAT(' DISTRIBUTION MUST BE POSITIVE. SUCH WAS NOT ',
1 'THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2266)THETA
2266 FORMAT(' THE SPECIFIED VALUE OF THETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL GIGRAN(NRAN,CHI,ALAMB,THETA,ISEED,Y)
GOTO2990
C
2270 CONTINUE
IHP='LAMB'
IHP2='DA '
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
ALMBDA=VALUE(ILOCP)
C
CCCCC DEFAULT SD PARAMETER TO 1
C
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')THEN
SD=1.0
ELSE
SD=VALUE(ILOCP)
ENDIF
C
IF(SD.LE.0.0)THEN
WRITE(ICOUT,2271)
2271 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2272)
2272 FORMAT(' THE SPECIFIED SHAPE PARAMETER, SD, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2274)
2274 FORMAT(' LOG-SKEW-NORMAL DISTRIBUTION MUST BE ',
1 'POSITIVE. SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2276)SD
2276 FORMAT(' THE SPECIFIED VALUE OF SD = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL LSNRAN(NRAN,ALMBDA,SD,ISEED,Y)
GOTO2990
C
2280 CONTINUE
IHP='LAMB'
IHP2='DA '
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
ALMBDA=VALUE(ILOCP)
C
CCCCC DEFAULT SD PARAMETER TO 1
C
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')THEN
SD=1.0
ELSE
SD=VALUE(ILOCP)
ENDIF
C
IF(SD.LE.0.0)THEN
WRITE(ICOUT,2281)
2281 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2282)
2282 FORMAT(' THE SPECIFIED SHAPE PARAMETER, SD, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2284)
2284 FORMAT(' LOG-SKEW-T DISTRIBUTION MUST BE ',
1 'POSITIVE. SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2286)SD
2286 FORMAT(' THE SPECIFIED VALUE OF SD = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='NU '
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
NU=INT(VALUE(ILOCP)+0.5)
C
IF(NU.LE.0)THEN
WRITE(ICOUT,2291)
2291 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2292)
2292 FORMAT(' THE SPECIFIED SHAPE PARAMETER, NU, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2294)
2294 FORMAT(' LOG-SKEW-T DISTRIBUTION MUST BE ',
1 'POSITIVE. SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2296)NU
2296 FORMAT(' THE SPECIFIED VALUE OF NU = ',I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
CALL LSTRAN(NRAN,NU,ALMBDA,SD,ISEED,Y)
GOTO2990
C
2300 CONTINUE
C
IHP='LAMB'
IHP2='DA '
IHWUSE='P'
MESSAG='YES'
CALL CHECKN(IHP,IHP2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
ALAMB=VALUE(ILOCP)
C
IHP='NU '
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
ANU=VALUE(ILOCP)
C
IF(ANU.LE.0.0)THEN
WRITE(ICOUT,2301)
2301 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2302)
2302 FORMAT(' THE SPECIFIED SHAPE PARAMETER, NU, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2304)
2304 FORMAT(' NON-CENTRAL T DISTRIBUTION MUST BE ',
1 'POSITIVE. SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2306)ANU
2306 FORMAT(' THE SPECIFIED VALUE OF NU = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL NCTRAN(NRAN,ANU,ALAMB,ISEED,Y)
GOTO2990
C
2310 CONTINUE
IHP='LAMB'
IHP2='DA1 '
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
ALAMB1=VALUE(ILOCP)
C
IHP='LAMB'
IHP2='DA2 '
IHWUSE='P'
MESSAG='NO'
CALL CHECKN(IHP,IHP2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
ALAMB2=VALUE(ILOCP)
C
IHP='NU '
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
ANU=VALUE(ILOCP)
C
IF(ANU.LE.0.0)THEN
WRITE(ICOUT,2311)
2311 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2312)
2312 FORMAT(' THE SPECIFIED SHAPE PARAMETER, NU, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2314)
2314 FORMAT(' DOUBLY NON-CENTRAL T DISTRIBUTION MUST BE ',
1 'POSITIVE. SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2316)ANU
2316 FORMAT(' THE SPECIFIED VALUE OF ANU = ',F12.5)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
CALL DNTRAN(NRAN,ANU,ALAMB1,ALAMB2,ISEED,Y)
GOTO2990
C
2330 CONTINUE
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(ALPHA.LE.0.0)THEN
WRITE(ICOUT,2331)
2331 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2332)
2332 FORMAT(' THE SPECIFIED SHAPE PARAMETER, ALPHA, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2334)
2334 FORMAT(' GENERALIZED LOGISTIC DISTRIBUTION MUST BE ',
1 'POSITIVE. SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2336)ALPHA
2336 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
CALL GLORAN(NRAN,ALPHA,ISEED,Y)
GOTO2990
C
2340 CONTINUE
C
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(ALPHA.LE.0.0)THEN
WRITE(ICOUT,2341)
2341 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2342)
2342 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2343)IDIST
2343 FORMAT(' FOR THE HERMITE DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2344)
2344 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2345)
2345 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2346)ALPHA
2346 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(BETA.LE.0.0)THEN
WRITE(ICOUT,2351)
2351 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2352)
2352 FORMAT(' THE SPECIFIED SHAPE PARAMETER BETA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2353)IDIST
2353 FORMAT(' FOR THE ',A26)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2354)
2354 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2355)
2355 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2356)BETA
2356 FORMAT(' THE SPECIFIED VALUE OF BETA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL HERRAN(ALPHA,BETA,NRAN,ISEED,Y)
GOTO2990
C
2360 CONTINUE
C
IHP='P '
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
P=VALUE(ILOCP)
C
IF(P.LT.0.1)THEN
WRITE(ICOUT,2361)
2361 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2362)
2362 FORMAT(' THE SPECIFIED SHAPE PARAMETER P')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2363)IDIST
2363 FORMAT(' FOR THE YULE DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2364)
2364 FORMAT(' MUST BE >= 0.1; SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2366)P
2366 FORMAT(' THE SPECIFIED VALUE OF P = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL YULRAN(NRAN,P,ISEED,Y)
GOTO2990
C
2370 CONTINUE
C
IHP='A '
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
A=VALUE(ILOCP)
C
IF(A.LE.0.0)THEN
WRITE(ICOUT,2371)
2371 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2372)
2372 FORMAT(' THE SPECIFIED SHAPE PARAMETER KAPPA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2373)IDIST
2373 FORMAT(' FOR THE WARING DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2374)
2374 FORMAT(' MUST BE > 0; SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2375)A
2375 FORMAT(' THE SPECIFIED VALUE OF A = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='C '
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
C=VALUE(ILOCP)
C
IF(C.LE.0.0)THEN
WRITE(ICOUT,2376)
2376 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2377)
2377 FORMAT(' THE SPECIFIED SHAPE PARAMETER C')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2378)
2378 FORMAT(' FOR THE WARING DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2379)
2379 FORMAT(' MUST BE > 0; SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2380)C
2380 FORMAT(' THE SPECIFIED VALUE OF C = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IF(C.LE.A)THEN
WRITE(ICOUT,2381)
2381 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2382)
2382 FORMAT(' THE SPECIFIED SHAPE PARAMETER C MUST BE GREATER')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2383)
2383 FORMAT(' THAN THE SPECIFIED PARAMETER A FOR THE WARING ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2384)
2384 FORMAT(' DISTRIBUTION; SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2386)C
2386 FORMAT(' THE SPECIFIED VALUE OF C = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2387)A
2387 FORMAT(' THE SPECIFIED VALUE OF A = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
B=1.0
BETA=A
ALPHA=C-A
CALL GWARAN(NRAN,BETA,B,ALPHA,ISEED,Y)
GOTO2990
C
2390 CONTINUE
C
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(ALPHA.LE.0.0)THEN
WRITE(ICOUT,2391)
2391 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2392)
2392 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2393)IDIST
2393 FORMAT(' FOR THE BETA-NEGATIVE BINOMIAL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2394)
2394 FORMAT(' MUST BE > 0; SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2396)ALPHA
2396 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(BETA.LE.0.0)THEN
WRITE(ICOUT,2401)
2401 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2402)
2402 FORMAT(' THE SPECIFIED SHAPE PARAMETER BETA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2403)IDIST
2403 FORMAT(' FOR THE BETA-NEGATIVE BINOMIAL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2404)
2404 FORMAT(' MUST BE >= 0; SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2406)BETA
2406 FORMAT(' THE SPECIFIED VALUE OF BETA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='K '
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
AK=VALUE(ILOCP)
C
IF(AK.LE.0.0)THEN
WRITE(ICOUT,2411)
2411 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2412)
2412 FORMAT(' THE SPECIFIED SHAPE PARAMETER AK')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2413)IDIST
2413 FORMAT(' FOR THE BETA-NEGATIVE BINOMIAL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2414)
2414 FORMAT(' MUST BE > 0; SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2416)AK
2416 FORMAT(' THE SPECIFIED VALUE OF K = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL GWARAN(NRAN,ALPHA,BETA,AK,ISEED,Y)
GOTO2990
C
2420 CONTINUE
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(ALPHA.LE.0.0)THEN
WRITE(ICOUT,2421)
2421 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2422)
2422 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2423)
2423 FORMAT(' FOR THE NON-CENTRAL BETA DISTRIBUTION MUST BE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2424)
2424 FORMAT(' POSITIVE; SUCH WAS NOT THE CASE HERE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2426)ALPHA
2426 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(BETA.LE.0.0)THEN
WRITE(ICOUT,2431)
2431 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2432)
2432 FORMAT(' THE SPECIFIED SHAPE PARAMETER BETA FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2433)
2433 FORMAT(' FOR THE NON-CENTRAL BETA DISTRIBUTION MUST BE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2434)
2434 FORMAT(' POSITIVE; SUCH WAS NOT THE CASE HERE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2436)BETA
2436 FORMAT(' THE SPECIFIED VALUE OF BETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='LAMB'
IHP2='DA '
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
ALAMB=VALUE(ILOCP)
C
IF(ALAMB.LE.0.0)THEN
WRITE(ICOUT,2441)
2441 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2442)
2442 FORMAT(' THE SPECIFIED NON-CENTRALITY PARAMETER LAMBDA ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2443)
2443 FORMAT(' FOR THE NON-CENTRAL BETA DISTRIBUTION MUST BE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2444)
2444 FORMAT(' POSITIVE; SUCH WAS NOT THE CASE HERE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2446)ALAMB
2446 FORMAT(' THE SPECIFIED VALUE OF LAMBDA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL NCBRAN(NRAN,ALPHA,BETA,ALAMB,ISEED,Y)
GOTO2990
C
2450 CONTINUE
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(ALPHA.LE.0.0)THEN
WRITE(ICOUT,2451)
2451 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2452)
2452 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2453)
2453 FORMAT(' FOR THE DOUBLY NON-CENTRAL BETA DISTRIBUTION ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2454)
2454 FORMAT(' MUST BE POSITIVE; SUCH WAS NOT THE CASE HERE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2456)ALPHA
2456 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(BETA.LE.0.0)THEN
WRITE(ICOUT,2461)
2461 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2462)
2462 FORMAT(' THE SPECIFIED SHAPE PARAMETER BETA FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2463)
2463 FORMAT(' FOR THE DOUBLY NON-CENTRAL BETA DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2464)
2464 FORMAT(' MUST BE POSITIVE; SUCH WAS NOT THE CASE HERE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2466)BETA
2466 FORMAT(' THE SPECIFIED VALUE OF BETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='LAMB'
IHP2='DA1 '
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
ALAMB1=VALUE(ILOCP)
C
IF(ALAMB1.LE.0.0)THEN
WRITE(ICOUT,2471)
2471 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2472)
2472 FORMAT(' THE SPECIFIED NON-CENTRALITY PARAMETER LAMBDA1')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2473)
2473 FORMAT(' FOR THE DOUBLY NON-CENTRAL BETA DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2474)
2474 FORMAT(' MUST BE POSITIVE; SUCH WAS NOT THE CASE HERE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2476)ALAMB1
2476 FORMAT(' THE SPECIFIED VALUE OF LAMBDA1 = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='LAMB'
IHP2='DA2 '
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
ALAMB2=VALUE(ILOCP)
C
IF(ALAMB2.LE.0.0)THEN
WRITE(ICOUT,2481)
2481 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2482)
2482 FORMAT(' THE SPECIFIED NON-CENTRALITY PARAMETER LAMBDA2')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2483)
2483 FORMAT(' FOR THE DOUBLY NON-CENTRAL BETA DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2484)
2484 FORMAT(' MUST BE POSITIVE; SUCH WAS NOT THE CASE HERE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2486)ALAMB2
2486 FORMAT(' THE SPECIFIED VALUE OF LAMBDA2 = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL DNBRAN(NRAN,ALPHA,BETA,ALAMB1,ALAMB2,ISEED,Y)
GOTO2990
C
2490 CONTINUE
IHP='LAMB'
IHP2='DA '
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
ALMBDA=VALUE(ILOCP)
C
IF(ALMBDA.LT.0.0)THEN
WRITE(ICOUT,2491)
2491 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2492)
2492 FORMAT(' THE SPECIFIED SHAPE PARAMETER LAMBDA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2493)
2493 FORMAT(' FOR THE SKEW DOUBLE EXPONENTIAL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2494)
2494 FORMAT(' MUST BE NON-NEGATIVE; SUCH WAS NOT THE CASE ',
1 'HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2496)ALMBDA
2496 FORMAT(' THE SPECIFIED VALUE OF LAMBDA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL SDERAN(NRAN,ALMBDA,ISEED,Y)
GOTO2990
C
2500 CONTINUE
IF(IADEDF.EQ.'K')THEN
IHP='K '
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
AK=VALUE(ILOCP)
C
IF(AK.LE.0.0)THEN
WRITE(ICOUT,2501)
2501 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2502)
2502 FORMAT(' THE SPECIFIED SHAPE PARAMETER K FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2503)
2503 FORMAT(' ASYMMETIC DOUBLE EXPONENTIAL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2504)
2504 FORMAT(' MUST BE POSITIVE; SUCH WAS NOT THE CASE ',
1 'HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2506)AK
2506 FORMAT(' THE SPECIFIED VALUE OF K = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL ADERAN(NRAN,AK,IADEDF,ISEED,Y)
ELSE
IHP='MU '
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
AMU=VALUE(ILOCP)
CALL ADERAN(NRAN,AMU,IADEDF,ISEED,Y)
ENDIF
GOTO2990
C
2520 CONTINUE
C
IHP='SIGM'
IHP2='A '
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')THEN
SIGMA=1.0
ELSE
SIGMA=VALUE(ILOCP)
ENDIF
C
IF(SIGMA.LE.0.0)THEN
WRITE(ICOUT,2521)
2521 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2522)
2522 FORMAT(' THE SPECIFIED SHAPE PARAMETER SIGMA FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2523)
2523 FORMAT(' MAXWELL DISTRIBUTION MUST BE POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2525)
2525 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2526)SIGMA
2526 FORMAT(' THE SPECIFIED VALUE OF SIGMA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL MAXRAN(NRAN,SIGMA,ISEED,Y)
GOTO2990
C
2530 CONTINUE
C
CALL RAYRAN(NRAN,ISEED,Y)
GOTO2990
C
2540 CONTINUE
CCCCC IF(IADEDF.EQ.'K')THEN
IHP='K '
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
AK=VALUE(ILOCP)
C
IF(AK.LE.0.0)THEN
WRITE(ICOUT,2541)
2541 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2542)
2542 FORMAT(' THE SPECIFIED SHAPE PARAMETER K FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2543)
2543 FORMAT(' GENERALIZED ASYMMETIC DOUBLE EXPONENTIAL ',
1 'DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2544)
2544 FORMAT(' MUST BE POSITIVE; SUCH WAS NOT THE CASE ',
1 'HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2546)AK
2546 FORMAT(' THE SPECIFIED VALUE OF K = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='TAU '
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
TAU=VALUE(ILOCP)
C
IF(TAU.LE.0.0)THEN
WRITE(ICOUT,2551)
2551 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2552)
2552 FORMAT(' THE SPECIFIED SHAPE PARAMETER TAU FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2553)
2553 FORMAT(' GENERALIZED ASYMMETIC DOUBLE EXPONENTIAL ',
1 'DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2554)
2554 FORMAT(' MUST BE POSITIVE; SUCH WAS NOT THE CASE ',
1 'HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2556)TAU
2556 FORMAT(' THE SPECIFIED VALUE OF TAU = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL GALRAN(NRAN,AK,TAU,IADEDF,ISEED,Y)
CCCCC ELSE
CCCCC IHP='MU '
CCCCC IHP2=' '
CCCCC IHWUSE='P'
CCCCC MESSAG='YES'
CCCCC CALL CHECKN(IHP,IHP2,IHWUSE,
CCCCC1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
CCCCC1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
CCCCC IF(IERROR.EQ.'YES')GOTO9000
CCCCC AMU=VALUE(ILOCP)
CCCCC CALL ADERAN(NRAN,AMU,IADEDF,ISEED,Y)
CCCCC ENDIF
GOTO2990
C
2560 CONTINUE
C
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
CALL MCLRAN(NRAN,ALPHA,ISEED,Y)
GOTO2990
C
2570 CONTINUE
IF(IBEIDF.EQ.'1')THEN
IHP='SIGM'
IHP2='A1SQ'
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
S1SQ=VALUE(ILOCP)
C
IF(S1SQ.LE.0.0)THEN
WRITE(ICOUT,2571)
2571 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2572)
2572 FORMAT(' THE SPECIFIED SHAPE PARAMETER, SIGMA1SQ, FOR ',
1 'THE BESSEL I-FUNCTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2574)
2574 FORMAT(' DISTRIBUTION MUST BE POSITIVE. SUCH WAS ',
1 'NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2576)S1SQ
2576 FORMAT(' THE SPECIFIED VALUE OF SIGMA1SQ = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='SIGM'
IHP2='A2SQ'
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
S2SQ=VALUE(ILOCP)
C
IF(S2SQ.LE.0.0)THEN
WRITE(ICOUT,2581)
2581 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2582)
2582 FORMAT(' THE SPECIFIED SHAPE PARAMETER, SIGMA1SQ, FOR ',
1 'THE BESSEL I-FUNCTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2584)
2584 FORMAT(' DISTRIBUTION MUST BE POSITIVE. SUCH WAS ',
1 'NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2586)S2SQ
2586 FORMAT(' THE SPECIFIED VALUE OF SIGMA1SQ = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='NU '
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
ANU=VALUE(ILOCP)
C
IF(ANU.LE.0.0)THEN
WRITE(ICOUT,2591)
2591 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2592)
2592 FORMAT(' THE SPECIFIED SHAPE PARAMETER, NU, FOR ',
1 'THE BESSEL I-FUNCTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2594)
2594 FORMAT(' DISTRIBUTION MUST BE POSITIVE. SUCH WAS ',
1 'NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2596)ANU
2596 FORMAT(' THE SPECIFIED VALUE OF NU = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL BEIRAN(NRAN,S1SQ,S2SQ,ANU,IBEIDF,ISEED,Y)
GOTO2990
ELSE
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
IF(B.LE.0.0)THEN
WRITE(ICOUT,22571)
22571 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,22572)
22572 FORMAT(' THE SPECIFIED SHAPE PARAMETER, B, FOR ',
1 'THE BESSEL I-FUNCTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,22574)
22574 FORMAT(' DISTRIBUTION MUST BE POSITIVE. SUCH WAS ',
1 'NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,22576)B
22576 FORMAT(' THE SPECIFIED VALUE OF B = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
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
IF(C.LE.0.0)THEN
WRITE(ICOUT,22581)
22581 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,22582)
22582 FORMAT(' THE SPECIFIED SHAPE PARAMETER, C, FOR ',
1 'THE BESSEL I-FUNCTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,22584)
22584 FORMAT(' DISTRIBUTION MUST BE POSITIVE. SUCH WAS ',
1 'NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,22586)C
22586 FORMAT(' THE SPECIFIED VALUE OF C = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='M '
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
AM=VALUE(ILOCP)
C
IF(AM.LE.0.5)THEN
WRITE(ICOUT,22591)
22591 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,22592)
22592 FORMAT(' THE SPECIFIED SHAPE PARAMETER, M, FOR ',
1 'THE BESSEL I-FUNCTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,22594)
22594 FORMAT(' DISTRIBUTION MUST BE POSITIVE. SUCH WAS ',
1 'NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,22596)AM
22596 FORMAT(' THE SPECIFIED VALUE OF M = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL BEIRAN(NRAN,B,C,AM,IBEIDF,ISEED,Y)
GOTO2990
ENDIF
C
2600 CONTINUE
IHP='SIGM'
IHP2='A1SQ'
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
S1SQ=VALUE(ILOCP)
C
IF(S1SQ.LE.0.0)THEN
WRITE(ICOUT,2601)
2601 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2602)
2602 FORMAT(' THE SPECIFIED SHAPE PARAMETER, SIGMA1SQ, FOR ',
1 'THE BESSEL K-FUNCTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2604)
2604 FORMAT(' DISTRIBUTION MUST BE POSITIVE. SUCH WAS NOT ',
1 'THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2606)S1SQ
2606 FORMAT(' THE SPECIFIED VALUE OF SIGMA1SQ = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='SIGM'
IHP2='A2SQ'
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
S2SQ=VALUE(ILOCP)
C
IF(S2SQ.LE.0.0)THEN
WRITE(ICOUT,2611)
2611 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2612)
2612 FORMAT(' THE SPECIFIED SHAPE PARAMETER, SIGMA1SQ, FOR ',
1 'THE BESSEL K-FUNCTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2614)
2614 FORMAT(' DISTRIBUTION MUST BE POSITIVE. SUCH WAS NOT ',
1 'THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2616)S2SQ
2616 FORMAT(' THE SPECIFIED VALUE OF SIGMA1SQ = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='NU '
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
ANU=VALUE(ILOCP)
C
IF(ANU.LE.0.0)THEN
WRITE(ICOUT,2621)
2621 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2622)
2622 FORMAT(' THE SPECIFIED SHAPE PARAMETER, NU, FOR ',
1 'THE BESSEL I-FUNCTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2624)
2624 FORMAT(' DISTRIBUTION MUST BE POSITIVE. SUCH WAS NOT ',
1 'THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2626)ANU
2626 FORMAT(' THE SPECIFIED VALUE OF NU = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CCCCC CALL BEKRAN(NRAN,S1SQ,S2SQ,ANU,ISEED,Y)
GOTO2990
C
2630 CONTINUE
C
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(ALPHA.LE.0.0)THEN
WRITE(ICOUT,2631)
2631 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2632)
2632 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2633)
2633 FORMAT(' FOR THE GENERALIZED MCLEISH DISTRIBUTION ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2634)
2634 FORMAT(' MUST BE POSITIVE; SUCH WAS NOT THE CASE HERE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2636)ALPHA
2636 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
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
IF(ABS(A).GE.1.0)THEN
WRITE(ICOUT,2641)
2641 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2642)
2642 FORMAT(' THE ABSOLUTE VALUE OF THE SPECIFIED SHAPE ',
1 'PARAMETER A FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2643)
2643 FORMAT(' FOR THE GENERALIZED MCLEISH DISTRIBUTION ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2644)
2644 FORMAT(' MUST BE LESS THAN 1; SUCH WAS NOT THE CASE ',
1 'HERE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2646)A
2646 FORMAT(' THE SPECIFIED VALUE OF A = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL GMCRAN(NRAN,ALPHA,A,ISEED,Y)
GOTO2990
C
2650 CONTINUE
C
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(ALPHA.LE.0.0)THEN
WRITE(ICOUT,2651)
2651 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2652)
2652 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2653)
2653 FORMAT(' FOR THE HYPERBOLIC DISTRIBUTION ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2654)
2654 FORMAT(' MUST BE POSITIVE; SUCH WAS NOT THE CASE HERE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2656)ALPHA
2656 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='XI '
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
XI=VALUE(ILOCP)
C
IF(XI.LE.0.0)THEN
WRITE(ICOUT,2661)
2661 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2662)
2662 FORMAT(' THE SPECIFIED SHAPE PARAMETER XI FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2663)
2663 FORMAT(' FOR THE HYPERBOLIC DISTRIBUTION ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2664)
2664 FORMAT(' MUST BE POSITIVE; SUCH WAS NOT THE CASE ',
1 'HERE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2666)XI
2666 FORMAT(' THE SPECIFIED VALUE OF XI = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CCCCC CALL HBORAN(NRAN,ALPHA,XI,ISEED,Y)
GOTO2990
C
2670 CONTINUE
C
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
CALL GL5RAN(NRAN,ALPHA,ISEED,Y)
GOTO2990
C
2680 CONTINUE
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IHP='GAMM'
IHP2='A '
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
GAMMA=VALUE(ILOCP)
C
IHP='DELT'
IHP2='A '
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
DELTA=VALUE(ILOCP)
C
IFLAG=0
SCALE=1.0
IF(BETA+DELTA.LE.0.0.AND.
1 (BETA.NE.0.0.OR.GAMMA.NE.0.0.OR.DELTA.NE.0.0))IFLAG=1
IF(SCALE.EQ.0.0.AND.BETA.NE.0.0)IFLAG=1
IF(GAMMA.EQ.0.0.AND.DELTA.NE.0.0)IFLAG=1
IF(GAMMA.LT.0.0.OR.SCALE+GAMMA.LT.0.0)IFLAG=1
IF(SCALE.EQ.0.0.AND.GAMMA.EQ.0.0)IFLAG=1
C
IF(IFLAG.EQ.1)THEN
WRITE(ICOUT,2681)
2681 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2682)
2682 FORMAT(' THE VALUES FOR THE SPECIFIED SHAPE PARAMETERS ',
1 'BETA, GAMMA, AND DELTA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2683)
2683 FORMAT(' ARE INVALID FOR THE WAKEBY DISTRIBUTION. THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2684)
2684 FORMAT(' FOLLOWING CONDITIONS ARE INVALID:')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2686)
2686 FORMAT(' 1. BETA + DELTA <= 0 AND')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2688)
2688 FORMAT(' BETA <> 0 OR GAMMA <>0 OR DELTA <>0')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2690)
2690 FORMAT(' 2. SCALE = 0 AND BETA <> 0')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2692)
2692 FORMAT(' 3. GAMMA = 0 AND DELTA <> 0')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2694)
2694 FORMAT(' 4. GAMMA < 0 OR SCALE + GAMMA < 0')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2696)
2696 FORMAT(' 5. SCALE = 0 AND GAMMA = 0')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2697)ALPHA
2697 FORMAT(' THE SPECIFIED VALUE OF BETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2698)GAMMA
2698 FORMAT(' THE SPECIFIED VALUE OF GAMMA = ',G15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2699)DELTA
2699 FORMAT(' THE SPECIFIED VALUE OF DELTA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL WAKRAN(NRAN,BETA,GAMMA,DELTA,ISEED,Y)
GOTO2990
C
2700 CONTINUE
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(ALPHA.LE.0.0)THEN
WRITE(ICOUT,2701)
2701 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2702)
2702 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA FOR THE ',
1 'BETA-NORMAL')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2704)
2704 FORMAT(' DISTRIBUTION MUST BE POSITIVE; SUCH WAS ',
1 'NOT THE CASE HERE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2706)ALPHA
2706 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',G15.7)
CALL DPWRST('XXX','BUG ')
ENDIF
C
IF(BETA.LE.0.0)THEN
WRITE(ICOUT,2711)
2711 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2712)
2712 FORMAT(' THE SPECIFIED SHAPE PARAMETER BETA FOR THE ',
1 'BETA-NORMAL')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2714)
2714 FORMAT(' DISTRIBUTION MUST BE POSITIVE; SUCH WAS ',
1 'NOT THE CASE HERE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2716)BETA
2716 FORMAT(' THE SPECIFIED VALUE OF BETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
ENDIF
C
CALL BNORAN(NRAN,ALPHA,BETA,ISEED,Y)
GOTO2990
C
2720 CONTINUE
C
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(ALPHA.LE.0.0)THEN
WRITE(ICOUT,2721)
2721 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2722)
2722 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA FOR THE ',
1 'GENERALIZED LOGISTIC (TYPE 2)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2724)
2724 FORMAT(' DISTRIBUTION MUST BE POSITIVE; SUCH WAS ',
1 'NOT THE CASE HERE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2726)ALPHA
2726 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',G15.7)
CALL DPWRST('XXX','BUG ')
ENDIF
C
CALL GL2RAN(NRAN,ALPHA,ISEED,Y)
GOTO2990
C
2730 CONTINUE
C
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(ALPHA.LE.0.0)THEN
WRITE(ICOUT,2731)
2731 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2732)
2732 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA FOR THE ',
1 'GENERALIZED LOGISTIC (TYPE 3)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2734)
2734 FORMAT(' DISTRIBUTION MUST BE POSITIVE; SUCH WAS ',
1 'NOT THE CASE HERE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2736)ALPHA
2736 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',G15.7)
CALL DPWRST('XXX','BUG ')
ENDIF
C
CALL GL3RAN(NRAN,ALPHA,ISEED,Y)
GOTO2990
C
2740 CONTINUE
C
IHP='P '
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
P=VALUE(ILOCP)
C
IHP='Q '
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
Q=VALUE(ILOCP)
C
IF(P.LE.0.0)THEN
WRITE(ICOUT,2741)
2741 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2742)
2742 FORMAT(' THE SPECIFIED SHAPE PARAMETER P FOR THE ',
1 'GENERALIZED LOGISTIC (TYPE 4)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2744)
2744 FORMAT(' DISTRIBUTION MUST BE POSITIVE; SUCH WAS ',
1 'NOT THE CASE HERE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2746)ALPHA
2746 FORMAT(' THE SPECIFIED VALUE OF P = ',G15.7)
CALL DPWRST('XXX','BUG ')
ENDIF
C
IF(Q.LE.0.0)THEN
WRITE(ICOUT,2751)
2751 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2752)
2752 FORMAT(' THE SPECIFIED SHAPE PARAMETER Q FOR THE ',
1 'GENERALIZED LOGISTIC (TYPE 4)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2754)
2754 FORMAT(' DISTRIBUTION MUST BE POSITIVE; SUCH WAS ',
1 'NOT THE CASE HERE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2756)ALPHA
2756 FORMAT(' THE SPECIFIED VALUE OF Q = ',G15.7)
CALL DPWRST('XXX','BUG ')
ENDIF
C
CALL GL4RAN(NRAN,P,Q,ISEED,Y)
GOTO2990
C
2770 CONTINUE
C
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(ALPHA.LE.0.0)THEN
WRITE(ICOUT,2771)
2771 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2772)
2772 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2773)
2773 FORMAT(' ASYMMETRIC LOG DOUBLE EXPONENTIAL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2774)
2774 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2775)
2775 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2776)ALPHA
2776 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(BETA.LE.0.0)THEN
WRITE(ICOUT,2781)
2781 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2782)
2782 FORMAT(' THE SPECIFIED SHAPE PARAMETER BETA FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2783)
2783 FORMAT(' ASYMMETRIC LOG DOUBLE EXPONENTIAL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2784)
2784 FORMAT(' MUST BE STRICTLY LARGER THAN 0;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2785)
2785 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2786)BETA
2786 FORMAT(' THE SPECIFIED VALUE OF BETA = ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL ALDRAN(NRAN,ALPHA,BETA,ISEED,Y)
GOTO2990
C
2800 CONTINUE
C
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(ALPHA.LE.0.0)THEN
WRITE(ICOUT,2801)
2801 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2802)
2802 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2803)
2803 FORMAT(' BETA-GEOMETRIC DISTRIBUTION MUST BE POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2805)
2805 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2806)ALPHA
2806 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(BETA.LE.0.0)THEN
WRITE(ICOUT,2811)
2811 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2812)
2812 FORMAT(' THE SPECIFIED SHAPE PARAMETER BETA FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2814)
2814 FORMAT(' BETA-GEOMETRIC DISTRIBUTION MUST BE POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2815)
2815 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2816)BETA
2816 FORMAT(' THE SPECIFIED VALUE OF BETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL BGERAN(ALPHA,BETA,NRAN,ISEED,Y,IBGEDF)
GOTO2990
C
2820 CONTINUE
C
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(ALPHA.LT.1.0)THEN
WRITE(ICOUT,2821)
2821 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2822)
2822 FORMAT(' THE SPECIFIED SHAPE PARAMETER, ALPHA, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2824)
2824 FORMAT(' ZIPF DISTRIBUTION MUST BE > 1. SUCH WAS NOT ',
1 'THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2826)ALPHA
2826 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='N '
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
NPAR=INT(VALUE(ILOCP)+0.5)
C
IF(NPAR.LE.1)THEN
WRITE(ICOUT,2831)
2831 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2832)
2832 FORMAT(' THE SPECIFIED SHAPE PARAMETER, N, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2834)
2834 FORMAT(' ZIPF DISTRIBUTION MUST BE > 1. SUCH WAS NOT ',
1 'THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2836)NPAR
2836 FORMAT(' THE SPECIFIED VALUE OF N = ',I15)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL ZIPRAN(NRAN,ALPHA,NPAR,ISEED,Y)
GOTO2990
C
2840 CONTINUE
C
IHP='LAMB'
IHP2='DA '
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
ALAMB=VALUE(ILOCP)
C
IF(ALAMB.LE.0.0 .OR. ALAMB.GE.1.0)THEN
WRITE(ICOUT,2841)
2841 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2842)
2842 FORMAT(' THE SPECIFIED SHAPE PARAMETER, LAMBDA, FOR THE',
1 'BOREL-TANNER')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2844)
2844 FORMAT(' DISTRIBUTION MUST BE IN THE INTERVAL (0,1). ',
1 'SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2846)ALAMB
2846 FORMAT(' THE SPECIFIED VALUE OF LAMBDA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='K '
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
AK=VALUE(ILOCP)
IK=INT(AK+0.5)
C
IF(IK.LT.1)THEN
WRITE(ICOUT,2851)
2851 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2852)
2852 FORMAT(' THE SPECIFIED SHAPE PARAMETER, K, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2854)
2854 FORMAT(' BOREL-TANNER DISTRIBUTION MUST BE >= 1. ',
1 'SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2856)IK
2856 FORMAT(' THE SPECIFIED VALUE OF K = ',I15)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL BTARAN(NRAN,ALAMB,AK,ISEED,Y)
GOTO2990
C
2860 CONTINUE
C
IHP='LAMB'
IHP2='DA '
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
ALAMB=VALUE(ILOCP)
C
IF(ALAMB.LE.0.0 .OR. ALAMB.GE.1.0)THEN
WRITE(ICOUT,2861)
2861 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2862)
2862 FORMAT(' THE SPECIFIED SHAPE PARAMETER, LAMBDA, FOR THE',
1 'LAGRANGE-POISSON')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2864)
2864 FORMAT(' DISTRIBUTION MUST BE IN THE INTERVAL (0,1). ',
1 'SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2866)ALAMB
2866 FORMAT(' THE SPECIFIED VALUE OF LAMBDA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='THET'
IHP2='A '
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
THETA=VALUE(ILOCP)
C
IF(THETA.LE.0.0)THEN
WRITE(ICOUT,2871)
2871 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2872)
2872 FORMAT(' THE SPECIFIED SHAPE PARAMETER, THETA, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2874)
2874 FORMAT(' LAGRANGE-POISSON DISTRIBUTION MUST BE > 0. ',
1 'SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2876)THETA
2876 FORMAT(' THE SPECIFIED VALUE OF THETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL LPORAN(NRAN,ALAMB,THETA,ISEED,Y)
GOTO2990
C
2880 CONTINUE
C
IHP='N '
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
NPAR=INT(VALUE(ILOCP)+0.5)
C
IF(NPAR.LT.1)THEN
WRITE(ICOUT,2881)
2881 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2882)
2882 FORMAT(' THE SPECIFIED SHAPE PARAMETER, N, FOR THE',
1 'LEADS IN COIN TOSSING')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2884)
2884 FORMAT(' DISTRIBUTION MUST BE >= 1. ',
1 'SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2886)NPAR
2886 FORMAT(' THE SPECIFIED VALUE OF NPAR = ',I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL LCTRAN(NRAN,NPAR,ISEED,Y)
GOTO2990
C
2890 CONTINUE
C
IHP='K '
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
IK=INT(VALUE(ILOCP)+0.5)
C
IF(IK.LT.1)THEN
WRITE(ICOUT,2891)
2891 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2892)
2892 FORMAT(' THE SPECIFIED SHAPE PARAMETER, K, FOR THE',
1 'LEADS IN COIN TOSSING')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2894)
2894 FORMAT(' DISTRIBUTION MUST BE >= 1. ',
1 'SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2896)IK
2896 FORMAT(' THE SPECIFIED VALUE OF K = ',I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL MATRAN(NRAN,IK,ISEED,Y)
GOTO2990
C
2910 CONTINUE
C
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(ALPHA.LE.0.0)THEN
WRITE(ICOUT,2911)
2911 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2912)
2912 FORMAT(' THE SPECIFIED SHAPE PARAMETER ALPHA FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2913)
2913 FORMAT(' LOG-BETA DISTRIBUTION MUST BE POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2915)
2915 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2916)ALPHA
2916 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(BETA.LE.0.0)THEN
WRITE(ICOUT,2921)
2921 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2922)
2922 FORMAT(' THE SPECIFIED SHAPE PARAMETER BETA FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2924)
2924 FORMAT(' LOG-BETA DISTRIBUTION MUST BE POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2925)
2925 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2926)BETA
2926 FORMAT(' THE SPECIFIED VALUE OF BETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='C '
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
C=VALUE(ILOCP)
C
IF(C.LE.0.0)THEN
WRITE(ICOUT,2931)
2931 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2932)
2932 FORMAT(' THE SPECIFIED LOWER LIMIT PARAMETER C FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2934)
2934 FORMAT(' LOG-BETA DISTRIBUTION MUST BE POSITIVE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2935)
2935 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2936)C
2936 FORMAT(' THE SPECIFIED VALUE OF C = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='D '
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
DVAL=VALUE(ILOCP)
C
IF(DVAL.LE.C)THEN
WRITE(ICOUT,2941)
2941 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2942)
2942 FORMAT(' THE SPECIFIED UPPER LIMIT PARAMETER D FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2944)
2944 FORMAT(' LOG-BETA DISTRIBUTION MUST BE GREATER THAN ',
1 'THE LOWER LIMIT PARAMETER C;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2945)
2945 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2946)C
2946 FORMAT(' THE SPECIFIED VALUE OF C = ',G15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2948)D
2948 FORMAT(' THE SPECIFIED VALUE OF D = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL LBERAN(NRAN,ALPHA,BETA,C,DVAL,ISEED,Y)
GOTO2990
C
2950 CONTINUE
C
IHP='THET'
IHP2='A '
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
THETA=VALUE(ILOCP)
C
IF(THETA.LE.0.0)THEN
WRITE(ICOUT,2951)
2951 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2952)
2952 FORMAT(' THE SPECIFIED SHAPE PARAMETER, THETA, FOR THE',
1 'POLYA-AEPPLI')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2954)
2954 FORMAT(' DISTRIBUTION MUST BE POSITIVE. SUCH WAS NOT ',
1 'THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2956)THETA
2956 FORMAT(' THE SPECIFIED VALUE OF THETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='P '
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
P=VALUE(ILOCP)
C
IF(P.LE.0.0 .OR. P.GE.1.0)THEN
WRITE(ICOUT,2961)
2961 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2962)
2962 FORMAT(' THE SPECIFIED SHAPE PARAMETER, P, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2964)
2964 FORMAT(' POLYA-AEPPLI DISTRIBUTION MUST BE IN THE ',
1 'INTERVAL (0,1). SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2966)P
2966 FORMAT(' THE SPECIFIED VALUE OF P = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL PAPRAN(NRAN,THETA,P,ISEED,Y)
GOTO2990
C
2970 CONTINUE
C
IHP='R '
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
IR=INT(VALUE(ILOCP)+0.5)
C
IF(IR.LT.0)THEN
WRITE(ICOUT,2971)
2971 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2972)
2972 FORMAT(' THE SPECIFIED SHAPE PARAMETER, R, FOR THE',
1 'LOST GAMES')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2974)
2974 FORMAT(' DISTRIBUTION MUST BE NON-NEGATIVE. SUCH WAS ',
1 'NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2976)IR
2976 FORMAT(' THE SPECIFIED VALUE OF R = ',I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='P '
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
P=VALUE(ILOCP)
C
IF(P.LE.0.5 .OR. P.GE.1.0)THEN
WRITE(ICOUT,2981)
2981 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2982)
2982 FORMAT(' THE SPECIFIED SHAPE PARAMETER, P, FOR THE ',
1 'LOST GAMES')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2984)
2984 FORMAT(' DISTRIBUTION MUST BE IN THE INTERVAL (0.5,1).',
1 ' SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2986)P
2986 FORMAT(' THE SPECIFIED VALUE OF P = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL LOSRAN(NRAN,P,IR,ISEED,Y)
GOTO2990
C
3010 CONTINUE
C
IHP='THET'
IHP2='A '
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
THETA=VALUE(ILOCP)
C
IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN
WRITE(ICOUT,3011)
3011 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3012)
3012 FORMAT(' THE SPECIFIED SHAPE PARAMETER, THETA, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3013)
3013 FORMAT(' GENERALIZED LOGARITHMIC SERIES DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3014)
3014 FORMAT(' MUST BE IN THE INTERVAL (0,1). SUCH WAS ',
1 'NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3016)THETA
3016 FORMAT(' THE SPECIFIED VALUE OF THETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(BETA.LE.1.0 .OR. BETA.GE.1.0/THETA)THEN
WRITE(ICOUT,3021)
3021 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3022)
3022 FORMAT(' THE SPECIFIED SHAPE PARAMETER, BETA, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3023)
3023 FORMAT(' GENERALIZED LOGARITHMIC SERIES DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3024)1.0/THETA
3024 FORMAT(' MUST BE IN THE INTERVAL (0.5,',G15.7,').',
1 ' SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3026)P
3026 FORMAT(' THE SPECIFIED VALUE OF P = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL GLSRAN(NRAN,THETA,BETA,ISEED,Y)
GOTO2990
C
3040 CONTINUE
C
IHP='THET'
IHP2='A '
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
THETA=VALUE(ILOCP)
C
IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN
WRITE(ICOUT,3041)
3041 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3042)
3042 FORMAT(' THE SPECIFIED SHAPE PARAMETER, THETA, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3043)
3043 FORMAT(' GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3044)
3044 FORMAT(' MUST BE IN THE INTERVAL (0,1). SUCH WAS ',
1 'NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3046)THETA
3046 FORMAT(' THE SPECIFIED VALUE OF THETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(BETA.LE.1.0 .OR. BETA.GE.1.0/THETA)THEN
WRITE(ICOUT,3051)
3051 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3052)
3052 FORMAT(' THE SPECIFIED SHAPE PARAMETER, BETA, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3053)
3053 FORMAT(' GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3054)1.0/THETA
3054 FORMAT(' MUST BE IN THE INTERVAL (0.5,',G15.7,').',
1 ' SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3056)BETA
3056 FORMAT(' THE SPECIFIED VALUE OF BETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='M '
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
AM=VALUE(ILOCP)
C
IF(AM.LE.0.0)THEN
WRITE(ICOUT,3061)
3061 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3062)
3062 FORMAT(' THE SPECIFIED SHAPE PARAMETER, M, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3063)
3063 FORMAT(' GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3064)
3064 FORMAT(' MUST BE POSITIVE. SUCH WAS NOT THE CASE ',
1 'HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3066)AM
3066 FORMAT(' THE SPECIFIED VALUE OF AM = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL GNBRAN(NRAN,THETA,BETA,AM,ISEED,Y)
GOTO2990
C
3070 CONTINUE
C
IF(IGETDF.EQ.'THET')THEN
IHP='THET'
IHP2='A '
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
SHAPE=VALUE(ILOCP)
C
IF(SHAPE.LE.0.0 .OR. SHAPE.GE.1.0)THEN
WRITE(ICOUT,3071)
3071 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3072)
3072 FORMAT(' THE SPECIFIED SHAPE PARAMETER, THETA, FOR ',
1 'THE GEETA DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3074)
3074 FORMAT(' MUST BE IN THE INTERVAL (0,1). SUCH WAS ',
1 'NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3076)SHAPE
3076 FORMAT(' THE SPECIFIED VALUE OF THETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
ELSE
IHP='MU '
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
SHAPE=VALUE(ILOCP)
C
IF(SHAPE.LT.1.0)THEN
WRITE(ICOUT,3081)
3081 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3082)
3082 FORMAT(' THE SPECIFIED SHAPE PARAMETER, MU, FOR ',
1 'THE GEETA DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3084)
3084 FORMAT(' MUST BE GREATER THAN OR EQUAL TO 1. SUCH ',
1 'WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3086)SHAPE
3086 FORMAT(' THE SPECIFIED VALUE OF MU = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
ENDIF
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(IGETDF.EQ.'THET')THEN
IF(BETA.LE.1.0 .OR. BETA.GE.1.0/SHAPE)THEN
WRITE(ICOUT,3091)
3091 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3092)
3092 FORMAT(' THE SPECIFIED SHAPE PARAMETER, BETA, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3093)
3093 FORMAT(' GEETA DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3094)1.0/SHAPE
3094 FORMAT(' MUST BE IN THE INTERVAL (1,',G15.7,').',
1 ' SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3096)BETA
3096 FORMAT(' THE SPECIFIED VALUE OF BETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
ELSE
IF(BETA.LE.1.0)THEN
WRITE(ICOUT,3101)
3101 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3102)
3102 FORMAT(' THE SPECIFIED SHAPE PARAMETER, BETA, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3103)
3103 FORMAT(' GEETA DISTRIBUTION MUST BE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3104)
3104 FORMAT(' GREATER THAN 1. SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3106)BETA
3106 FORMAT(' THE SPECIFIED VALUE OF BETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
ENDIF
C
CALL GETRAN(NRAN,SHAPE,BETA,IGETDF,ISEED,Y)
GOTO2990
C
3110 CONTINUE
C
IHP='P '
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
P=VALUE(ILOCP)
C
IF(P.LT.0.0 .OR. P.GT.1.0)THEN
WRITE(ICOUT,3111)
3111 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3112)
3112 FORMAT(' THE SPECIFIED SHAPE PARAMETER, P, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3113)
3113 FORMAT(' QUASI BINOMIAL TYPE I DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3114)
3114 FORMAT(' MUST BE IN THE INTERVAL (0,1). SUCH WAS ',
1 'NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3116)P
3116 FORMAT(' THE SPECIFIED VALUE OF P = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='M '
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
AM=VALUE(ILOCP)
C
IF(AM.LT.0.0)THEN
WRITE(ICOUT,3121)
3121 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3122)
3122 FORMAT(' THE SPECIFIED SHAPE PARAMETER, M, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3123)
3123 FORMAT(' QUASI BINOMIAL TYPE I DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3124)
3124 FORMAT(' MUST BE POSITIVE. SUCH WAS NOT THE CASE ',
1 'HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3126)AM
3126 FORMAT(' THE SPECIFIED VALUE OF AM = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='PHI '
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
PHI=VALUE(ILOCP)
C
IM=INT(AM+0.5)
AM=REAL(IM)
ALOWLM=-P/AM
AUPPLM=(1.0-P)/AM
IF(PHI.LE.ALOWLM .OR. PHI.GE.AUPPLM)THEN
WRITE(ICOUT,3131)
3131 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3132)
3132 FORMAT(' THE SPECIFIED SHAPE PARAMETER, PHI, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3133)
3133 FORMAT(' QUASI BINOMIAL TYPE I DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3134)ALOWLM,AUPPLM
3134 FORMAT(' MUST BE IN THE INTERVAL (',
1 G15.7,',',G15.7,').',
1 ' SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3136)PHI
3136 FORMAT(' THE SPECIFIED VALUE OF PHI = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL QBIRAN(NRAN,P,PHI,AM,ISEED,Y)
GOTO2990
C
3140 CONTINUE
C
IF(ICONDF.EQ.'THET')THEN
IHP='THET'
IHP2='A '
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
SHAPE=VALUE(ILOCP)
C
IF(SHAPE.LE.0.0 .OR. SHAPE.GE.1.0)THEN
WRITE(ICOUT,3141)
3141 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3142)
3142 FORMAT(' THE SPECIFIED SHAPE PARAMETER, THETA, FOR ',
1 'THE CONSUL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3144)
3144 FORMAT(' MUST BE IN THE INTERVAL (0,1). SUCH WAS ',
1 'NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3146)SHAPE
3146 FORMAT(' THE SPECIFIED VALUE OF THETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
ELSE
IHP='MU '
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
SHAPE=VALUE(ILOCP)
C
IF(SHAPE.LT.0.0)THEN
WRITE(ICOUT,3151)
3151 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3152)
3152 FORMAT(' THE SPECIFIED SHAPE PARAMETER, MU, FOR ',
1 'THE CONSUL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3154)
3154 FORMAT(' MUST BE GREATER THAN OR EQUAL TO 1. SUCH ',
1 'WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3156)SHAPE
3156 FORMAT(' THE SPECIFIED VALUE OF MU = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
ENDIF
C
IHP='M '
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
AM=VALUE(ILOCP)
C
IF(ICONDF.EQ.'THET')THEN
IF(AM.LE.1.0 .OR. AM.GE.1.0/SHAPE)THEN
WRITE(ICOUT,3161)
3161 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3162)
3162 FORMAT(' THE SPECIFIED SHAPE PARAMETER, M, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3163)
3163 FORMAT(' CONSUL DISTRIBUTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3164)1.0/SHAPE
3164 FORMAT(' MUST BE IN THE INTERVAL (0.5,',G15.7,').',
1 ' SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3166)AM
3166 FORMAT(' THE SPECIFIED VALUE OF M = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
ELSE
IF(AM.LE.1.0)THEN
WRITE(ICOUT,3171)
3171 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3172)
3172 FORMAT(' THE SPECIFIED SHAPE PARAMETER, M, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3173)
3173 FORMAT(' CONSUL DISTRIBUTION MUST BE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3174)
3174 FORMAT(' GREATER THAN 1. SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3176)AM
3176 FORMAT(' THE SPECIFIED VALUE OF M = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
ENDIF
C
CALL CONRAN(NRAN,SHAPE,AM,ICONDF,ISEED,Y)
GOTO2990
C
3180 CONTINUE
C
IHP='A '
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
A=VALUE(ILOCP)
C
IF(A.LE.0.0)THEN
WRITE(ICOUT,3181)
3181 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3182)
3182 FORMAT(' THE SPECIFIED SHAPE PARAMETER, A, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3183)
3183 FORMAT(' LAGRANGE KATZ DISTRIBUTION MUST BE POSITIVE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3184)
3184 FORMAT(' SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3186)A
3186 FORMAT(' THE SPECIFIED VALUE OF A = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(BETA.GE.1.0)THEN
WRITE(ICOUT,3191)
3191 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3192)
3192 FORMAT(' THE SPECIFIED SHAPE PARAMETER, BETA, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3193)
3193 FORMAT(' LAGRANGE KATZ DISTRIBUTION MUST BE LESS THAN OR')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3194)1.0/THETA
3194 FORMAT(' OR EQUAL TO 1. SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3196)BETA
3196 FORMAT(' THE SPECIFIED VALUE OF BETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='B '
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
B=VALUE(ILOCP)
C
IF(B.LE.-BETA)THEN
WRITE(ICOUT,3201)
3201 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3202)
3202 FORMAT(' THE SPECIFIED SHAPE PARAMETER, B, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3203)
3203 FORMAT(' LAGRANGE KATZ DISTRIBUTION MUST BE GREATER')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3204)
3204 FORMAT(' THAN OR EQUAL TO -BETA. SUCH WAS NOT THE ',
1 'CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3206)B
3206 FORMAT(' THE SPECIFIED VALUE OF B = ',G15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3208)BETA
3208 FORMAT(' THE SPECIFIED VALUE OF BETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL LKRAN(NRAN,A,B,BETA,ISEED,Y)
GOTO2990
C
3210 CONTINUE
C
IHP='ALPH'
IHP2='A '
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
ALPHA=VALUE(ILOCP)
C
IF(ALPHA.LE.0.0)THEN
WRITE(ICOUT,3211)
3211 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3212)
3212 FORMAT(' THE SPECIFIED SHAPE PARAMETER, ALPHA, FOR')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3213)
3213 FORMAT(' THE KATZ DISTRIBUTION MUST BE POSITIVE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3214)
3214 FORMAT(' SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3216)A
3216 FORMAT(' THE SPECIFIED VALUE OF ALPHA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(BETA.GE.1.0)THEN
WRITE(ICOUT,3221)
3221 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3222)
3222 FORMAT(' THE SPECIFIED SHAPE PARAMETER, BETA, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3223)
3223 FORMAT(' KATZ DISTRIBUTION MUST BE LESS THAN OR')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3224)1.0/THETA
3224 FORMAT(' OR EQUAL TO 1. SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3226)BETA
3226 FORMAT(' THE SPECIFIED VALUE OF BETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
B=0.0
C
CALL LKRAN(NRAN,ALPHA,B,BETA,ISEED,Y)
GOTO2990
C
3230 CONTINUE
C
IHP='Q '
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
Q=VALUE(ILOCP)
C
IF(Q.LE.0.0 .OR. Q.GE.1.0)THEN
WRITE(ICOUT,3231)
3231 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3232)
3232 FORMAT(' THE SPECIFIED SHAPE PARAMETER, Q, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3233)
3233 FORMAT(' DISCRETE WEIBULL DISTRIBUTION MUST BE IN ',
1 'THE INTERVAL (0,1).')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3234)
3234 FORMAT(' SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3236)Q
3236 FORMAT(' THE SPECIFIED VALUE OF Q = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='BETA'
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
BETA=VALUE(ILOCP)
C
IF(BETA.LE.0.0)THEN
WRITE(ICOUT,3241)
3241 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3242)
3242 FORMAT(' THE SPECIFIED SHAPE PARAMETER, BETA, FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3243)
3243 FORMAT(' DISCRETE WEIBULL DISTRIBUTION MUST BE POSITIVE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3244)
3244 FORMAT(' SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3246)BETA
3246 FORMAT(' THE SPECIFIED VALUE OF BETA = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL DIWRAN(NRAN,Q,BETA,ISEED,Y)
GOTO2990
C
3250 CONTINUE
C
IHP='J '
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
J=INT(VALUE(ILOCP)+0.5)
C
IF(J.LT.0)THEN
WRITE(ICOUT,3251)
3251 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3252)
3252 FORMAT(' THE SPECIFIED SHAPE PARAMETER, J, FOR THE',
1 'GENERALIZED LOST GAMES')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3254)
3254 FORMAT(' DISTRIBUTION MUST BE NON-NEGATIVE. SUCH WAS ',
1 'NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3256)J
3256 FORMAT(' THE SPECIFIED VALUE OF J = ',I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='P '
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
P=VALUE(ILOCP)
C
IF(P.LE.0.5 .OR. P.GE.1.0)THEN
WRITE(ICOUT,3261)
3261 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3262)
3262 FORMAT(' THE SPECIFIED SHAPE PARAMETER, P, FOR THE ',
1 'GENERALIZED LOST GAMES')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3264)
3264 FORMAT(' DISTRIBUTION MUST BE IN THE INTERVAL (0.5,1).',
1 ' SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3266)P
3266 FORMAT(' THE SPECIFIED VALUE OF P = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IHP='A '
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
A=VALUE(ILOCP)
C
IF(A.LE.0.0)THEN
WRITE(ICOUT,3271)
3271 FORMAT('***** ERROR IN DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3272)
3272 FORMAT(' THE SPECIFIED SHAPE PARAMETER, A, FOR THE ',
1 'GENERALIZED LOST GAMES')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3274)
3274 FORMAT(' DISTRIBUTION MUST BE POSITIVE. ',
1 ' SUCH WAS NOT THE CASE HERE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3276)A
3276 FORMAT(' THE SPECIFIED VALUE OF A = ',G15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
CALL GLGRAN(NRAN,P,J,A,ISEED,Y)
GOTO2990
C
2990 CONTINUE
C
C ******************************************************
C ** STEP 8-- **
C ** IF CALLED FOR (THAT IS, IF IBUGA3 IS ON), **
C ** PRINT OUT THE INTERMEDIATE VARIABLE Y(.). **
C ** THIS IS USEFUL FOR DIAGNOSTIC PURPOSES **
C ** IN REVIEWING THE OUTPUT FROM THIS SUBROUTINE. **
C ******************************************************
C
ISTEPN='9'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IBUGA3.EQ.'ON')THEN
WRITE(ICOUT,4011)
4011 FORMAT('OUTPUT FROM MIDDLE OF DPRAND AFTER ALL XXXRAN ',
1 'HAVE BEEN CALLED--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4012)NRAN
4012 FORMAT('NRAN = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NRAN.GE.1)THEN
DO4014I=1,NRAN
WRITE(ICOUT,4015)I,Y(I)
4015 FORMAT('I,Y(I) = ',I8,F12.5)
CALL DPWRST('XXX','BUG ')
4014 CONTINUE
ENDIF
ENDIF
C
C ******************************************************
C ** STEP 9-- **
C ** COPY THE RANDOM NUMBERS **
C ** FROM THE INTERMEDIATE VECTOR Y(.) **
C ** TO THE APPROPRIATE COLUMN **
C ** (BASED ON THE QUALIFIER--FULL, SUBSET, OR FOR) **
C ** IN THE INTERNAL DATAPLOT DATA TABLE. **
C ******************************************************
C
ISTEPN='10'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
NS2=0
DO4060I=1,NIISUB
IJ=MAXN*(ICOLL-1)+I
IF(ISUB(I).EQ.0)GOTO4060
NS2=NS2+1
IF(ICOLL.LE.MAXCOL)V(IJ)=Y(NS2)
IF(ICOLL.EQ.MAXCP1)PRED(I)=Y(NS2)
IF(ICOLL.EQ.MAXCP2)RES(I)=Y(NS2)
IF(ICOLL.EQ.MAXCP3)YPLOT(I)=Y(NS2)
IF(ICOLL.EQ.MAXCP4)XPLOT(I)=Y(NS2)
IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=Y(NS2)
IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=Y(NS2)
IF(NS2.EQ.1)IROW1=I
IROWN=I
4060 CONTINUE
C
C *******************************************
C ** STEP 10-- **
C ** CARRY OUT THE LIST UPDATING AND **
C ** GENERATE THE INFORMATIVE PRINTING. **
C *******************************************
C
ISTEPN='11'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'NO')NINEW=NLEFT
IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'YES')NINEW=MAXN
IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND.
1NLEFT.GE.IROWN)NINEW=NLEFT
IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND.
1NLEFT.LT.IROWN)NINEW=IROWN
IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'YES')NINEW=IROWN
IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND.
1NLEFT.GE.IROWN)NINEW=NLEFT
IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND.
1NLEFT.LT.IROWN)NINEW=IROWN
IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'YES')NINEW=IROWN
C
IHNAME(ILISTL)=ILEFT
IHNAM2(ILISTL)=ILEFT2
IUSE(ILISTL)='V'
IVALUE(ILISTL)=ICOLL
VALUE(ILISTL)=ICOLL
IN(ILISTL)=NINEW
C
CCCCC IUSE(ICOLL)='V'
CCCCC IVALUE(ICOLL)=ICOLL
CCCCC VALUE(ICOLL)=ICOLL
CCCCC IN(ICOLL)=NINEW
C
IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
IF(NEWNAM.EQ.'YES')NUMCOL=NUMCOL+1
C
DO4600J4=1,NUMNAM
IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)GOTO4605
GOTO4600
4605 CONTINUE
IUSE(J4)='V'
IVALUE(J4)=ICOLL
VALUE(J4)=ICOLL
IN(J4)=NINEW
4600 CONTINUE
C
IF(IPRINT.EQ.'OFF')GOTO4559
IF(IFEEDB.EQ.'OFF')GOTO4559
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4511)ILEFT,ILEFT2,NS2
4511 FORMAT('THE NUMBER OF VALUES GENERATED FOR ',
1'THE VARIABLE ',A4,A4,' = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
C
IJ=MAXN*(ICOLL-1)+IROW1
IF(ICOLL.LE.MAXCOL)THEN
WRITE(ICOUT,4521)ILEFT,ILEFT2,V(IJ),IROW1
4521 FORMAT('THE FIRST COMPUTED VALUE OF ',
1 A4,A4,' = ',E15.7,' (ROW ',I6,')')
CALL DPWRST('XXX','BUG ')
ELSE IF(ICOLL.EQ.MAXCP1)THEN
WRITE(ICOUT,4521)ILEFT,ILEFT2,PRED(IROW1),IROW1
CALL DPWRST('XXX','BUG ')
ELSE IF(ICOLL.EQ.MAXCP2)THEN
WRITE(ICOUT,4521)ILEFT,ILEFT2,RES(IROW1),IROW1
CALL DPWRST('XXX','BUG ')
ELSE IF(ICOLL.EQ.MAXCP3)THEN
WRITE(ICOUT,4521)ILEFT,ILEFT2,YPLOT(IROW1),IROW1
CALL DPWRST('XXX','BUG ')
ELSE IF(ICOLL.EQ.MAXCP4)THEN
WRITE(ICOUT,4521)ILEFT,ILEFT2,XPLOT(IROW1),IROW1
CALL DPWRST('XXX','BUG ')
ELSE IF(ICOLL.EQ.MAXCP5)THEN
WRITE(ICOUT,4521)ILEFT,ILEFT2,X2PLOT(IROW1),IROW1
CALL DPWRST('XXX','BUG ')
ELSE IF(ICOLL.EQ.MAXCP6)THEN
WRITE(ICOUT,4521)ILEFT,ILEFT2,TAGPLO(IROW1),IROW1
CALL DPWRST('XXX','BUG ')
ENDIF
C
IJ=MAXN*(ICOLL-1)+IROWN
IF(NS2.NE.1)THEN
IF(ICOLL.LE.MAXCOL)THEN
WRITE(ICOUT,4531)NS2,ILEFT,ILEFT2,V(IJ),IROWN
4531 FORMAT('THE LAST (',I5,'-TH) COMPUTED VALUE OF ',
1 A4,A4,' = ',E15.7,' (ROW ',I6,')')
CALL DPWRST('XXX','BUG ')
ELSE IF(ICOLL.EQ.MAXCP1)THEN
WRITE(ICOUT,4531)NS2,ILEFT,ILEFT2,PRED(IROWN),IROWN
CALL DPWRST('XXX','BUG ')
ELSE IF(ICOLL.EQ.MAXCP2)THEN
WRITE(ICOUT,4531)NS2,ILEFT,ILEFT2,RES(IROWN),IROWN
CALL DPWRST('XXX','BUG ')
ELSE IF(ICOLL.EQ.MAXCP3)THEN
WRITE(ICOUT,4531)NS2,ILEFT,ILEFT2,YPLOT(IROWN),IROWN
CALL DPWRST('XXX','BUG ')
ELSE IF(ICOLL.EQ.MAXCP4)THEN
WRITE(ICOUT,4531)NS2,ILEFT,ILEFT2,XPLOT(IROWN),IROWN
CALL DPWRST('XXX','BUG ')
ELSE IF(ICOLL.EQ.MAXCP5)THEN
WRITE(ICOUT,4531)NS2,ILEFT,ILEFT2,X2PLOT(IROWN),IROWN
CALL DPWRST('XXX','BUG ')
ELSE IF(ICOLL.EQ.MAXCP6)THEN
WRITE(ICOUT,4531)NS2,ILEFT,ILEFT2,TAGPLO(IROWN),IROWN
CALL DPWRST('XXX','BUG ')
ENDIF
ENDIF
IF(NS2.NE.1)GOTO4590
WRITE(ICOUT,4546)
4546 FORMAT('SINCE THE GENERATED SAMPLE SIZE WAS ONLY 1,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4542)
4542 FORMAT('THE ABOVE VALUE WAS THE SOLE VALUE COMPUTED.')
CALL DPWRST('XXX','BUG ')
4590 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4612)ILEFT,ILEFT2,ICOLL
4612 FORMAT('THE CURRENT COLUMN FOR ',
1'THE VARIABLE ',A4,A4,' = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4613)ILEFT,ILEFT2,NINEW
4613 FORMAT('THE CURRENT LENGTH OF ',
1'THE VARIABLE ',A4,A4,' = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
4559 CONTINUE
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGA3.EQ.'OFF')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPRAND--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IFOUND,IERROR
9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)IBUGA3,IBUGQ
9013 FORMAT('IBUGA3,IBUGQ = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)ICASRA,ISEED,ILOCNU
9014 FORMAT('ICASRA,ISEED,ILOCNU = ',A4,I8,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)NS2
9015 FORMAT('NS2 = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9016)NS,NIISUB,NRAN
9016 FORMAT('NS,NIISUB,NRAN = ',I8,I8,I8)
CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 2 LINES WERE ADDED MAY 1993
WRITE(ICOUT,9021)MINMAX
9021 FORMAT('MINMAX = ',I8)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPRAW(X,FREQ,NX,IWRITE,MAXNXT,Y,NY,IBUGA3,IERROR)
C
C PURPOSE--SOMETIMES DATA IS MADE AVAILABLE AS A FREQUENCY
C TABLE. HOWEVER, FOR A PARTICULAR TYPE OF ANALSYSIS
C YOU MAY NEED THE DATA IN RAW (I.E., IF YOU HAVE
C A FREQUENCY OF 10 FOR THE VALUE 1, SIMPLY GENERATE
C THE VALUE 1 TEN TIMES). NEED TO CHECK FOR ARRAY
C EXCEEDING MAXIMUM ALLOWABLE.
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C INFORMATION TECHNOLOGY LABORATORY
C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C GAITHERSBURG, MD 20899-8980
C PHONE--301-975-2855
C NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C MODIFIED, OR OTHERWISE USED IN A CONTEXT
C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--2004/4
C ORIGINAL VERSION--APRIL 2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IWRITE
CHARACTER*4 IBUGA3
CHARACTER*4 IERROR
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
DIMENSION X(*)
DIMENSION Y(*)
DIMENSION FREQ(*)
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='DPRA'
ISUBN2='W '
C
IERROR='NO'
C
IF(IBUGA3.EQ.'ON')THEN
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPRAW--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBUGA3
52 FORMAT('IBUGA3 = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)NX,MAXNXT
53 FORMAT('NX,MAXNXT = ',2I8)
CALL DPWRST('XXX','BUG ')
DO55I=1,NX
WRITE(ICOUT,56)I,X(I),FREQ(I)
56 FORMAT('I,X(I), FREQ(I) = ',I8,2E15.7)
CALL DPWRST('XXX','BUG ')
55 CONTINUE
ENDIF
C
C **************************************
C ** CONVERT FROM FREQUENCY TO RAW **
C **************************************
C
IF(NX.LT.1)THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,101)
101 FORMAT('***** ERROR--NUMBER OF CLASSES FOR FREQUENCY TO ',
1 'RAW COMMAND IS LESS THAN 1.')
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
ENDIF
C
NY=0
DO200I=1,NX
C
NTEMP=INT(FREQ(I)+0.5)
IF(NTEMP.LT.1)THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,201)I,FREQ(I)
201 FORMAT('***** ERROR--CLASS ',I8,' HAS NON-POSITIVE ',
1 'FREQUENCY (= ',F12.5,')')
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
ENDIF
C
NTOT=NY+NTEMP
IF(NTOT.GT.MAXNXT)THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,203)MAXNXT
203 FORMAT('***** ERROR--MAXIMUM NUMBER OF ROWS (',I8,') ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,205)
205 FORMAT(' IN CONVERTING FREQUENCY DATA TO RAW DATA.')
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
ENDIF
C
DO210J=1,NTEMP
NY=NY+1
Y(NY)=X(I)
210 CONTINUE
200 CONTINUE
C
C *****************
C ** STEP 90-- **
C ** EXIT. **
C *****************
C
9000 CONTINUE
C
IF(IBUGA3.EQ.'ON')THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPRAW--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGA3,IERROR
9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)NX,NY
9013 FORMAT('NX,NY = ',2I8)
CALL DPWRST('XXX','BUG ')
DO9015I=1,NY
WRITE(ICOUT,9016)I,Y(I)
9016 FORMAT('I,Y(I) = ',I8,E15.7)
CALL DPWRST('XXX','BUG ')
9015 CONTINUE
ENDIF
C
RETURN
END
SUBROUTINE DPRBCO(IHARG,NUMARG,IDERBC,MAXREG,IREBCO,
1IBUGP2,IFOUND,IERROR)
C
C PURPOSE--DEFINE THE REGION BORDER COLORS = THE COLORS
C OF THE BORDER LINE AROUND THE REGIONS.
C THESE ARE LOCATED IN THE VECTOR IREBCO(.).
C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR)
C --NUMARG
C --IDERBC
C --MAXREG
C --IBUGP2 ('ON' OR 'OFF' )
C OUTPUT ARGUMENTS--IREBCO (A CHARACTER VECTOR)
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--DECEMBER 1983.
C UPDATED --MAY 1994. PRINT MESSAGE STATING THAT
C THIS IS AN OBSOLETE COMMAND
C (USE LINE COLOR COMMAND).
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IHARG
CHARACTER*4 IDERBC
CHARACTER*4 IREBCO
C
CHARACTER*4 IBUGP2
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 IHOLD1
CHARACTER*4 IHOLD2
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
DIMENSION IHARG(*)
DIMENSION IREBCO(*)
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
ISUBN1='DPRB'
ISUBN2='CO '
C
NUMREG=0
IHOLD1='-999'
IHOLD2='-999'
C
IF(IBUGP2.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPRBCO--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)MAXREG,NUMREG
53 FORMAT('MAXREG,NUMREG = ',I8,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)IHOLD1,IHOLD2
54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,55)IDERBC
55 FORMAT('IDERBC = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,60)NUMARG
60 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
DO65I=1,NUMARG
WRITE(ICOUT,66)IHARG(I)
66 FORMAT('IHARG(I) = ',A4)
CALL DPWRST('XXX','BUG ')
65 CONTINUE
WRITE(ICOUT,70)IREBCO(1)
70 FORMAT('IREBCO(1) = ',A4)
CALL DPWRST('XXX','BUG ')
DO75I=1,10
WRITE(ICOUT,76)I,IREBCO(I)
76 FORMAT('I,IREBCO(I) = ',I8,2X,A4)
CALL DPWRST('XXX','BUG ')
75 CONTINUE
90 CONTINUE
C
C **************************************
C ** STEP 1-- **
C ** BRANCH TO THE APPROPRIATE CASE **
C **************************************
C
ISTEPN='1'
IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(NUMARG.LE.1)GOTO9000
IF(NUMARG.EQ.2)GOTO1120
IF(NUMARG.EQ.3)GOTO1130
IF(NUMARG.EQ.4)GOTO1140
GOTO1150
C
1120 CONTINUE
GOTO1200
C
1130 CONTINUE
IF(IHARG(3).EQ.'ALL')IHOLD1=' '
IF(IHARG(3).EQ.'ALL')GOTO1300
GOTO1200
C
1140 CONTINUE
IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4)
IF(IHARG(3).EQ.'ALL')GOTO1300
IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3)
IF(IHARG(4).EQ.'ALL')GOTO1300
GOTO1200
C
1150 CONTINUE
GOTO1200
C
C *************************************************
C ** STEP 2-- **
C ** TREAT THE SINGLE SPECIFICATION CASE **
C *************************************************
C
1200 CONTINUE
ISTEPN='2'
IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(NUMARG.LE.2)GOTO1210
GOTO1220
C
1210 CONTINUE
NUMREG=1
IREBCO(1)=IDERBC
GOTO1270
C
1220 CONTINUE
NUMREG=NUMARG-2
IF(NUMREG.GT.MAXREG)NUMREG=MAXREG
DO1225I=1,NUMREG
J=I+2
IHOLD1=IHARG(J)
IHOLD2=IHOLD1
IF(IHOLD1.EQ.'ON')IHOLD2=IDERBC
IF(IHOLD1.EQ.'OFF')IHOLD2=IDERBC
IF(IHOLD1.EQ.'AUTO')IHOLD2=IDERBC
IF(IHOLD1.EQ.'DEFA')IHOLD2=IDERBC
IREBCO(I)=IHOLD2
1225 CONTINUE
GOTO1270
C
1270 CONTINUE
IF(IFEEDB.EQ.'OFF')GOTO1279
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
DO1278I=1,NUMREG
WRITE(ICOUT,1276)I,IREBCO(I)
1276 FORMAT('THE COLOR OF REGION BORDER ',I6,
1' HAS JUST BEEN SET TO ',A4)
CALL DPWRST('XXX','BUG ')
1278 CONTINUE
1279 CONTINUE
IFOUND='YES'
GOTO9000
C
C **************************
C ** STEP 3-- **
C ** TREAT THE ALL CASE **
C **************************
C
1300 CONTINUE
ISTEPN='3'
IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
NUMREG=MAXREG
IHOLD2=IHOLD1
IF(IHOLD1.EQ.'ON')IHOLD2=IDERBC
IF(IHOLD1.EQ.'OFF')IHOLD2=IDERBC
IF(IHOLD1.EQ.'AUTO')IHOLD2=IDERBC
IF(IHOLD1.EQ.'DEFA')IHOLD2=IDERBC
DO1315I=1,NUMREG
IREBCO(I)=IHOLD2
1315 CONTINUE
GOTO1370
C
1370 CONTINUE
IF(IFEEDB.EQ.'OFF')GOTO1319
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
I=1
WRITE(ICOUT,1316)IREBCO(I)
1316 FORMAT('THE COLOR OF ALL REGION BORDERS',
1' HAS JUST BEEN SET TO ',A4)
CALL DPWRST('XXX','BUG ')
1319 CONTINUE
IFOUND='YES'
CCCCC FOLLOWING SECTION ADDED MAY 1994.
WRITE(ICOUT,2100)
2100 FORMAT('****** WARNING. THE REGION BORDER COLOR COMMAND IS')
CALL DPWRST('XXX','BUG')
WRITE(ICOUT,2101)
2101 FORMAT(' NOT USED. THE BORDER COLOR FOR REGIONS IS')
CALL DPWRST('XXX','BUG')
WRITE(ICOUT,2102)
2102 FORMAT(' SET WITH THE LINE COLOR COMMAND. ******')
CALL DPWRST('XXX','BUG')
GOTO9000
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGP2.EQ.'OFF')GOTO9090
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPRBCO--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)MAXREG,NUMREG
9013 FORMAT('MAXREG,NUMREG = ',I8,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)IHOLD1,IHOLD2
9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)IDERBC
9015 FORMAT('IDERBC = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9020)NUMARG
9020 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
DO9025I=1,NUMARG
WRITE(ICOUT,9026)IHARG(I)
9026 FORMAT('IHARG(I) = ',A4)
CALL DPWRST('XXX','BUG ')
9025 CONTINUE
WRITE(ICOUT,9030)IREBCO(1)
9030 FORMAT('IREBCO(1) = ',A4)
CALL DPWRST('XXX','BUG ')
DO9035I=1,10
WRITE(ICOUT,9036)I,IREBCO(I)
9036 FORMAT('I,IREBCO(I) = ',I8,2X,A4)
CALL DPWRST('XXX','BUG ')
9035 CONTINUE
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPRBLI(IHARG,IHARG2,NUMARG,IDERBL,MAXREG,IREBLI,
CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC
CCCCC SUBROUTINE DPRBLI(IHARG,NUMARG,IDERBL,MAXREG,IREBLI,
1IBUGP2,IFOUND,IERROR)
C
C PURPOSE--DEFINE THE BORDER LINES = THE LINES TYPES
C OF THE BORDER AROUND THE REGIONS.
C THESE ARE LOCATED IN THE VECTOR IREBLI(.).
C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR)
C --NUMARG
C --IDERBL
C --MAXREG
C --IBUGP2 ('ON' OR 'OFF' )
C OUTPUT ARGUMENTS--IREBLI (A CHARACTER VECTOR)
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--DECEMBER 1983.
C UPDATED --MAY 1994. PRINT MESSAGE SAYING TO USE THE
C LINE COMMAND INSTEAD.
C UPDATED --AUGUST 1995. DASH2 BUG
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IHARG
CCCCC AUGUST 1995. ADD FOLLOWING LINE
CHARACTER*4 IHARG2
CHARACTER*4 IDERBL
CHARACTER*4 IREBLI
C
CHARACTER*4 IBUGP2
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 IHOLD1
CHARACTER*4 IHOLD2
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
DIMENSION IHARG(*)
CCCCC AUGUST 1995. ADD FOLLOWING LINE
DIMENSION IHARG2(*)
DIMENSION IREBLI(*)
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
ISUBN1='DPRB'
ISUBN2='LI '
C
NUMREG=0
IHOLD1='-999'
IHOLD2='-999'
C
IF(IBUGP2.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPRBLI--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)MAXREG,NUMREG
53 FORMAT('MAXREG,NUMREG = ',I8,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)IHOLD1,IHOLD2
54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,55)IDERBL
55 FORMAT('IDERBL = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,60)NUMARG
60 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
DO65I=1,NUMARG
WRITE(ICOUT,66)IHARG(I)
66 FORMAT('IHARG(I) = ',A4)
CALL DPWRST('XXX','BUG ')
65 CONTINUE
WRITE(ICOUT,70)IREBLI(1)
70 FORMAT('IREBLI(1) = ',A4)
CALL DPWRST('XXX','BUG ')
DO75I=1,10
WRITE(ICOUT,76)I,IREBLI(I)
76 FORMAT('I,IREBLI(I) = ',I8,2X,A4)
CALL DPWRST('XXX','BUG ')
75 CONTINUE
90 CONTINUE
C
C **************************************
C ** STEP 1-- **
C ** BRANCH TO THE APPROPRIATE CASE **
C **************************************
C
ISTEPN='1'
IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(NUMARG.LE.2)GOTO9000
IF(NUMARG.EQ.3)GOTO1130
IF(NUMARG.EQ.4)GOTO1140
IF(NUMARG.EQ.5)GOTO1150
GOTO1160
C
1130 CONTINUE
GOTO1200
C
1140 CONTINUE
IF(IHARG(5).EQ.'ALL')IHOLD1=' '
IF(IHARG(5).EQ.'ALL')GOTO1300
GOTO1200
C
1150 CONTINUE
CCCCC APRIL 1996. CHANGE IHOLD TO IHOLD1 BELOW
IF(IHARG(5).EQ.'ALL')THEN
IHOLD1=IHARG(6)
IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'2')IHOLD1='DA2'
IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'3')IHOLD1='DA3'
IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'4')IHOLD1='DA4'
IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'5')IHOLD1='DA5'
GOTO1300
ENDIF
IF(IHARG(6).EQ.'ALL')THEN
IHOLD1=IHARG(5)
IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'2')IHOLD1='DA2'
IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'3')IHOLD1='DA3'
IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'4')IHOLD1='DA4'
IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'5')IHOLD1='DA5'
GOTO1300
ENDIF
GOTO1200
C
1160 CONTINUE
GOTO1200
C
C *************************************************
C ** STEP 2-- **
C ** TREAT THE SINGLE SPECIFICATION CASE **
C *************************************************
C
1200 CONTINUE
ISTEPN='2'
IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(NUMARG.LE.3)GOTO1210
GOTO1220
C
1210 CONTINUE
NUMREG=1
IREBLI(1)=' '
GOTO1270
C
1220 CONTINUE
NUMREG=NUMARG-3
IF(NUMREG.GT.MAXREG)NUMREG=MAXREG
DO1225I=1,NUMREG
J=I+3
IHOLD1=IHARG(J)
IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'2')IHOLD1='DA2'
IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'3')IHOLD1='DA3'
IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'4')IHOLD1='DA4'
IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'5')IHOLD1='DA5'
IHOLD2=IHOLD1
IF(IHOLD1.EQ.'ON')IHOLD2='SOLI'
IF(IHOLD1.EQ.'OFF')IHOLD2=' '
IF(IHOLD1.EQ.'AUTO')IHOLD2=IDERBL
IF(IHOLD1.EQ.'DEFA')IHOLD2=IDERBL
IREBLI(I)=IHOLD2
1225 CONTINUE
GOTO1270
C
1270 CONTINUE
IF(IFEEDB.EQ.'OFF')GOTO1279
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
DO1278I=1,NUMREG
WRITE(ICOUT,1276)I,IREBLI(I)
1276 FORMAT('THE LINE TYPE FOR REGION BORDER ',I6,
1' HAS JUST BEEN SET TO ',A4)
CALL DPWRST('XXX','BUG ')
1278 CONTINUE
1279 CONTINUE
IFOUND='YES'
GOTO9000
C
C **************************
C ** STEP 3-- **
C ** TREAT THE ALL CASE **
C **************************
C
1300 CONTINUE
ISTEPN='3'
IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
NUMREG=MAXREG
IHOLD2=IHOLD1
IF(IHOLD1.EQ.'ON')IHOLD2='SOLI'
IF(IHOLD1.EQ.'OFF')IHOLD2=' '
IF(IHOLD1.EQ.'AUTO')IHOLD2=IDERBL
IF(IHOLD1.EQ.'DEFA')IHOLD2=IDERBL
DO1315I=1,NUMREG
IREBLI(I)=IHOLD2
1315 CONTINUE
GOTO1370
C
1370 CONTINUE
IF(IFEEDB.EQ.'OFF')GOTO1319
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
I=1
WRITE(ICOUT,1316)IREBLI(I)
1316 FORMAT('THE LINE TYPE FOR ALL REGION BORDERS',
1' HAS JUST BEEN SET TO ',A4)
CALL DPWRST('XXX','BUG ')
1319 CONTINUE
IFOUND='YES'
CCCCC ADD FOLLOWING SECTION MAY 1994.
WRITE(ICOUT,2100)
2100 FORMAT('****** WARNING. THE REGION BORDER LINE COMMAND IS')
CALL DPWRST('XXX','BUG')
WRITE(ICOUT,2101)
2101 FORMAT(' NOT USED. THE BORDER LINE STYLE FOR')
CALL DPWRST('XXX','BUG')
WRITE(ICOUT,2102)
2102 FORMAT(' REGIONS IS SET WITH THE LINE COLOR COMMAND.*****')
CALL DPWRST('XXX','BUG')
GOTO9000
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGP2.EQ.'OFF')GOTO9090
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPRBLI--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)MAXREG,NUMREG
9013 FORMAT('MAXREG,NUMREG = ',I8,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)IHOLD1,IHOLD2
9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)IDERBL
9015 FORMAT('IDERBL = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9020)NUMARG
9020 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
DO9025I=1,NUMARG
WRITE(ICOUT,9026)IHARG(I)
9026 FORMAT('IHARG(I) = ',A4)
CALL DPWRST('XXX','BUG ')
9025 CONTINUE
WRITE(ICOUT,9030)IREBLI(1)
9030 FORMAT('IREBLI(1) = ',A4)
CALL DPWRST('XXX','BUG ')
DO9035I=1,10
WRITE(ICOUT,9036)I,IREBLI(I)
9036 FORMAT('I,IREBLI(I) = ',I8,2X,A4)
CALL DPWRST('XXX','BUG ')
9035 CONTINUE
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPRBTH(IHARG,IARGT,ARG,NUMARG,PDERBT,MAXREG,PREBTH,
1IBUGP2,IFOUND,IERROR)
C
C PURPOSE--DEFINE THE REGION (BORDER) LINE THICKNESSES = THE THICKNESSES
C OF THE BORDER LINE AROUND THE REGIONS.
C THESE ARE LOCATED IN THE VECTOR PREBTH(.).
C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR)
C --IARGT (A CHARACTER VECTOR)
C --ARG
C --NUMARG
C --PDERBT
C --MAXREG
C --IBUGP2 ('ON' OR 'OFF' )
C OUTPUT ARGUMENTS--PREBTH (A FLOATING POINT VECTOR)
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--DECEMBER 1983.
C UPDATED --MAY 1994. PRINT MESSAGE TO USE LINE
C THICKNESS COMMAND INSTEAD.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IHARG
CHARACTER*4 IARGT
C
CHARACTER*4 IBUGP2
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 IHOLD1
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
DIMENSION IHARG(*)
DIMENSION IARGT(*)
DIMENSION ARG(*)
DIMENSION PREBTH(*)
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
ISUBN1='DPRB'
ISUBN2='TH '
C
NUMREG=0
IHOLD1='-999'
HOLD1=-999.0
HOLD2=-999.0
C
IF(IBUGP2.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPRBTH--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)MAXREG,NUMREG
53 FORMAT('MAXREG,NUMREG = ',I8,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2
54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,55)PDERBT
55 FORMAT('PDERBT = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,60)NUMARG
60 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
DO65I=1,NUMARG
WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I)
66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
CALL DPWRST('XXX','BUG ')
65 CONTINUE
WRITE(ICOUT,70)PREBTH(1)
70 FORMAT('PREBTH(1) = ',E15.7)
CALL DPWRST('XXX','BUG ')
DO75I=1,10
WRITE(ICOUT,76)I,PREBTH(I)
76 FORMAT('I,PREBTH(I) = ',I8,2X,E15.7)
CALL DPWRST('XXX','BUG ')
75 CONTINUE
90 CONTINUE
C
C **************************************
C ** STEP 1-- **
C ** BRANCH TO THE APPROPRIATE CASE **
C **************************************
C
ISTEPN='1'
IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(NUMARG.LE.1)GOTO9000
IF(NUMARG.EQ.2)GOTO1120
IF(NUMARG.EQ.3)GOTO1130
IF(NUMARG.EQ.4)GOTO1140
GOTO1150
C
1120 CONTINUE
GOTO1200
C
1130 CONTINUE
IF(IHARG(3).EQ.'ALL')IHOLD1=' '
IF(IHARG(3).EQ.'ALL')HOLD1=PDERBT
IF(IHARG(3).EQ.'ALL')GOTO1300
GOTO1200
C
1140 CONTINUE
IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4)
IF(IHARG(3).EQ.'ALL')HOLD1=ARG(4)
IF(IHARG(3).EQ.'ALL')GOTO1300
IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3)
IF(IHARG(4).EQ.'ALL')HOLD1=ARG(3)
IF(IHARG(4).EQ.'ALL')GOTO1300
GOTO1200
C
1150 CONTINUE
GOTO1200
C
C *************************************************
C ** STEP 2-- **
C ** TREAT THE SINGLE SPECIFICATION CASE **
C *************************************************
C
1200 CONTINUE
ISTEPN='2'
IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(NUMARG.LE.2)GOTO1210
GOTO1220
C
1210 CONTINUE
NUMREG=1
PREBTH(1)=PDERBT
GOTO1270
C
1220 CONTINUE
NUMREG=NUMARG-2
IF(NUMREG.GT.MAXREG)NUMREG=MAXREG
DO1225I=1,NUMREG
J=I+2
IHOLD1=IHARG(J)
HOLD1=ARG(J)
HOLD2=HOLD1
IF(IHOLD1.EQ.'ON')HOLD2=PDERBT
IF(IHOLD1.EQ.'OFF')HOLD2=PDERBT
IF(IHOLD1.EQ.'AUTO')HOLD2=PDERBT
IF(IHOLD1.EQ.'DEFA')HOLD2=PDERBT
PREBTH(I)=HOLD2
1225 CONTINUE
GOTO1270
C
1270 CONTINUE
IF(IFEEDB.EQ.'OFF')GOTO1279
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
DO1278I=1,NUMREG
WRITE(ICOUT,1276)I,PREBTH(I)
1276 FORMAT('THE THICKNESS OF REGION BORDER ',I6,
1' HAS JUST BEEN SET TO ',E15.7)
CALL DPWRST('XXX','BUG ')
1278 CONTINUE
1279 CONTINUE
IFOUND='YES'
GOTO9000
C
C **************************
C ** STEP 3-- **
C ** TREAT THE ALL CASE **
C **************************
C
1300 CONTINUE
ISTEPN='3'
IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
NUMREG=MAXREG
HOLD2=HOLD1
IF(IHOLD1.EQ.'ON')HOLD2=PDERBT
IF(IHOLD1.EQ.'OFF')HOLD2=PDERBT
IF(IHOLD1.EQ.'AUTO')HOLD2=PDERBT
IF(IHOLD1.EQ.'DEFA')HOLD2=PDERBT
DO1315I=1,NUMREG
PREBTH(I)=HOLD2
1315 CONTINUE
GOTO1370
C
1370 CONTINUE
IF(IFEEDB.EQ.'OFF')GOTO1319
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
I=1
WRITE(ICOUT,1316)PREBTH(I)
1316 FORMAT('THE THICKNESS OF ALL REGION BORDERS',
1' HAS JUST BEEN SET TO ',E15.7)
CALL DPWRST('XXX','BUG ')
1319 CONTINUE
IFOUND='YES'
CCCCC ADD FOLLOWING SECTION MAY 1994.
WRITE(ICOUT,2100)
2100 FORMAT('****** WARNING. THE REGION THICKNESS COMMAND IS')
CALL DPWRST('XXX','BUG')
WRITE(ICOUT,2101)
2101 FORMAT(' NOT USED. THE BORDER THICKNESS FOR REGIONS')
CALL DPWRST('XXX','BUG')
WRITE(ICOUT,2102)
2102 FORMAT(' IS SET WITH THE LINE THICKNESS COMMAND. ******')
CALL DPWRST('XXX','BUG')
GOTO9000
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGP2.EQ.'OFF')GOTO9090
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPRBTH--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)MAXREG,NUMREG
9013 FORMAT('MAXREG,NUMREG = ',I8,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2
9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)PDERBT
9015 FORMAT('PDERBT = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9020)NUMARG
9020 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
DO9025I=1,NUMARG
WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I)
9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
CALL DPWRST('XXX','BUG ')
9025 CONTINUE
WRITE(ICOUT,9030)PREBTH(1)
9030 FORMAT('PREBTH(1) = ',E15.7)
CALL DPWRST('XXX','BUG ')
DO9035I=1,10
WRITE(ICOUT,9036)I,PREBTH(I)
9036 FORMAT('I,PREBTH(I) = ',I8,2X,E15.7)
CALL DPWRST('XXX','BUG ')
9035 CONTINUE
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPRCIL(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1IBUGD2,IFOUND,IERROR)
C
C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES
C FOR ROMAN COMPLEX ITALIC LOWER CASE.
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--87/4
C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981.
C UPDATED --MAY 1982.
C UPDATED --MARCH 1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 ICHAR2
CHARACTER*4 IOP
CHARACTER*4 IBUGD2
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
DIMENSION IOP(*)
DIMENSION X(*)
DIMENSION Y(*)
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
NUMCO=1
ISTART=1
ISTOP=1
NC=1
C
C ******************************************
C ** TREAT THE ROMAN SIMPLEX UPPER CASE **
C ** HERSHEY CHARACTER SET CASE **
C ******************************************
C
C
IF(IBUGD2.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPRCIL--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)ICHAR2
52 FORMAT('ICHAR2 = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR
59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C **************************************************
C ** STEP 1-- **
C ** SEARCH FOR THE INPUT CHARACTER(S). **
C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. **
C **************************************************
C
CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND)
IF(IFOUND.EQ.'NO')GOTO9000
C
IF(ICHARN.LE.10)GOTO1010
GOTO1019
1010 CONTINUE
CALL DRCIL1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1IBUGD2,IFOUND,IERROR)
GOTO9000
1019 CONTINUE
C
IF(11.LE.ICHARN.AND.ICHARN.LE.20)GOTO1020
GOTO1029
1020 CONTINUE
CALL DRCIL2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1IBUGD2,IFOUND,IERROR)
GOTO9000
1029 CONTINUE
C
IF(ICHARN.GE.21)GOTO1030
GOTO1039
1030 CONTINUE
CALL DRCIL3(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1IBUGD2,IFOUND,IERROR)
GOTO9000
1039 CONTINUE
C
IFOUND='NO'
GOTO9000
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGD2.EQ.'OFF')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPRCIL--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR
9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)ICHAR2,ICHARN
9013 FORMAT('ICHAR2,ICHARN = ',A4,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO
9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8)
CALL DPWRST('XXX','BUG ')
IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019
DO9015I=1,NUMCO
WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I)
9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2)
CALL DPWRST('XXX','BUG ')
9015 CONTINUE
9019 CONTINUE
WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS
9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPRCIN(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1IBUGD2,IFOUND,IERROR)
C
C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES
C FOR ROMAN COMPLEX ITALIC NUMERIC.
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--87/4
C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981.
C UPDATED --MAY 1982.
C UPDATED --MARCH 1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 ICHAR2
CHARACTER*4 IOP
CHARACTER*4 IBUGD2
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
DIMENSION IOP(*)
DIMENSION X(*)
DIMENSION Y(*)
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
NUMCO=1
ISTART=1
ISTOP=1
NC=1
C
C ******************************************
C ** TREAT THE ROMAN SIMPLEX UPPER CASE **
C ** HERSHEY CHARACTER SET CASE **
C ******************************************
C
C
IF(IBUGD2.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPRCIN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)ICHAR2
52 FORMAT('ICHAR2 = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR
59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C **************************************************
C ** STEP 1-- **
C ** SEARCH FOR THE INPUT CHARACTER(S). **
C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. **
C **************************************************
C
CALL DPCHNU(ICHAR2,ICHARN,IBUGD2,IFOUND)
IF(IFOUND.EQ.'NO')GOTO9000
C
IF(ICHARN.LE.8)GOTO1010
GOTO1019
1010 CONTINUE
CALL DRCIN1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1IBUGD2,IFOUND,IERROR)
GOTO9000
1019 CONTINUE
C
IF(ICHARN.GE.9)GOTO1020
GOTO1029
1020 CONTINUE
CALL DRCIN2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1IBUGD2,IFOUND,IERROR)
GOTO9000
1029 CONTINUE
C
IFOUND='NO'
GOTO9000
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGD2.EQ.'OFF')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPRCIN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR
9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)ICHAR2,ICHARN
9013 FORMAT('ICHAR2,ICHARN = ',A4,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO
9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8)
CALL DPWRST('XXX','BUG ')
IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019
DO9015I=1,NUMCO
WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I)
9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2)
CALL DPWRST('XXX','BUG ')
9015 CONTINUE
9019 CONTINUE
WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS
9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPRCIU(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1IBUGD2,IFOUND,IERROR)
C
C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES
C FOR ROMAN COMPLEX ITALIC UPPER CASE.
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--87/4
C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981.
C UPDATED --MAY 1982.
C UPDATED --MARCH 1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 ICHAR2
CHARACTER*4 IOP
CHARACTER*4 IBUGD2
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
DIMENSION IOP(*)
DIMENSION X(*)
DIMENSION Y(*)
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
NUMCO=1
ISTART=1
ISTOP=1
NC=1
C
C ******************************************
C ** TREAT THE ROMAN SIMPLEX UPPER CASE **
C ** HERSHEY CHARACTER SET CASE **
C ******************************************
C
C
IF(IBUGD2.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPRCIU--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)ICHAR2
52 FORMAT('ICHAR2 = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR
59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C **************************************************
C ** STEP 1-- **
C ** SEARCH FOR THE INPUT CHARACTER(S). **
C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. **
C **************************************************
C
CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND)
IF(IFOUND.EQ.'NO')GOTO9000
C
IF(ICHARN.LE.14)GOTO1010
GOTO1019
1010 CONTINUE
CALL DRCIU1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1IBUGD2,IFOUND,IERROR)
GOTO9000
1019 CONTINUE
C
IF(ICHARN.GE.15)GOTO1020
GOTO1029
1020 CONTINUE
CALL DRCIU2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1IBUGD2,IFOUND,IERROR)
GOTO9000
1029 CONTINUE
C
IFOUND='NO'
GOTO9000
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGD2.EQ.'OFF')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPRCIU--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR
9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)ICHAR2,ICHARN
9013 FORMAT('ICHAR2,ICHARN = ',A4,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO
9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8)
CALL DPWRST('XXX','BUG ')
IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019
DO9015I=1,NUMCO
WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I)
9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2)
CALL DPWRST('XXX','BUG ')
9015 CONTINUE
9019 CONTINUE
WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS
9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPRCL(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1IBUGD2,IFOUND,IERROR)
C
C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES
C FOR ROMAN COMPLEX LOWER CASE.
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--87/4
C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981.
C UPDATED --MAY 1982.
C UPDATED --MARCH 1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 ICHAR2
CHARACTER*4 IOP
CHARACTER*4 IBUGD2
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
DIMENSION IOP(*)
DIMENSION X(*)
DIMENSION Y(*)
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
NUMCO=1
ISTART=1
ISTOP=1
NC=1
C
C ******************************************
C ** TREAT THE ROMAN SIMPLEX UPPER CASE **
C ** HERSHEY CHARACTER SET CASE **
C ******************************************
C
C
IF(IBUGD2.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPRCL--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)ICHAR2
52 FORMAT('ICHAR2 = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR
59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C **************************************************
C ** STEP 1-- **
C ** SEARCH FOR THE INPUT CHARACTER(S). **
C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. **
C **************************************************
C
CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND)
IF(IFOUND.EQ.'NO')GOTO9000
C
IF(ICHARN.LE.12)GOTO1010
GOTO1019
1010 CONTINUE
CALL DRCL1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1IBUGD2,IFOUND,IERROR)
GOTO9000
1019 CONTINUE
C
IF(ICHARN.GE.13)GOTO1020
GOTO1029
1020 CONTINUE
CALL DRCL2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1IBUGD2,IFOUND,IERROR)
GOTO9000
1029 CONTINUE
C
IFOUND='NO'
GOTO9000
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGD2.EQ.'OFF')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPRCL--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR
9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)ICHAR2,ICHARN
9013 FORMAT('ICHAR2,ICHARN = ',A4,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO
9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8)
CALL DPWRST('XXX','BUG ')
IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019
DO9015I=1,NUMCO
WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I)
9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2)
CALL DPWRST('XXX','BUG ')
9015 CONTINUE
9019 CONTINUE
WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS
9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPRCN(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1IBUGD2,IFOUND,IERROR)
C
C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES
C FOR ROMAN COMPLEX NUMERIC.
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--87/4
C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981.
C UPDATED --MAY 1982.
C UPDATED --MARCH 1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 ICHAR2
CHARACTER*4 IOP
CHARACTER*4 IBUGD2
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
DIMENSION IOP(*)
DIMENSION X(*)
DIMENSION Y(*)
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
NUMCO=1
ISTART=1
ISTOP=1
NC=1
C
C ******************************************
C ** TREAT THE ROMAN SIMPLEX UPPER CASE **
C ** HERSHEY CHARACTER SET CASE **
C ******************************************
C
C
IF(IBUGD2.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPRCN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)ICHAR2
52 FORMAT('ICHAR2 = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR
59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C **************************************************
C ** STEP 1-- **
C ** SEARCH FOR THE INPUT CHARACTER(S). **
C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. **
C **************************************************
C
CALL DPCHNU(ICHAR2,ICHARN,IBUGD2,IFOUND)
IF(IFOUND.EQ.'NO')GOTO9000
C
IF(ICHARN.LE.9)GOTO1010
GOTO1019
1010 CONTINUE
CALL DRCN1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1IBUGD2,IFOUND,IERROR)
GOTO9000
1019 CONTINUE
C
IF(ICHARN.GE.10)GOTO1020
GOTO1029
1020 CONTINUE
CALL DRCN2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1IBUGD2,IFOUND,IERROR)
GOTO9000
1029 CONTINUE
C
IFOUND='NO'
GOTO9000
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGD2.EQ.'OFF')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPRCN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR
9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)ICHAR2,ICHARN
9013 FORMAT('ICHAR2,ICHARN = ',A4,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO
9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8)
CALL DPWRST('XXX','BUG ')
IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019
DO9015I=1,NUMCO
WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I)
9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2)
CALL DPWRST('XXX','BUG ')
9015 CONTINUE
9019 CONTINUE
WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS
9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPRCS(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1IBUGD2,IFOUND,IERROR)
C
C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES
C FOR ROMAN COMPLEX SYMBOLS.
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--87/4
C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981.
C UPDATED --MARCH 1982.
C UPDATED --MAY 1982.
C UPDATED --MARCH 1987.
C UPDATED --MAY 1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 ICHAR2
CHARACTER*4 IOP
CHARACTER*4 IBUGD2
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 IOPERA
C
C---------------------------------------------------------------------
C
DIMENSION IOP(*)
DIMENSION X(*)
DIMENSION Y(*)
C
DIMENSION IOPERA(300)
DIMENSION IX(300)
DIMENSION IY(300)
C
DIMENSION IXMIND(30)
DIMENSION IXMAXD(30)
DIMENSION IXDELD(30)
DIMENSION ISTARD(30)
DIMENSION NUMCOO(30)
C
C---------------------------------------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C DEFINE CHARACTER 2210--. (PERIOD)
C
DATA IOPERA( 1),IX( 1),IY( 1)/'MOVE', 0, -7/
DATA IOPERA( 2),IX( 2),IY( 2)/'DRAW', -1, -8/
DATA IOPERA( 3),IX( 3),IY( 3)/'DRAW', 0, -9/
DATA IOPERA( 4),IX( 4),IY( 4)/'DRAW', 1, -8/
DATA IOPERA( 5),IX( 5),IY( 5)/'DRAW', 0, -7/
C
DATA IXMIND( 1)/ -5/
DATA IXMAXD( 1)/ 5/
DATA IXDELD( 1)/ 10/
DATA ISTARD( 1)/ 1/
DATA NUMCOO( 1)/ 5/
C
C DEFINE CHARACTER 2211--, (COMMA)
C
DATA IOPERA( 6),IX( 6),IY( 6)/'MOVE', 0, -9/
DATA IOPERA( 7),IX( 7),IY( 7)/'DRAW', -1, -8/
DATA IOPERA( 8),IX( 8),IY( 8)/'DRAW', 0, -7/
DATA IOPERA( 9),IX( 9),IY( 9)/'DRAW', 1, -8/
DATA IOPERA( 10),IX( 10),IY( 10)/'DRAW', 1, -10/
DATA IOPERA( 11),IX( 11),IY( 11)/'DRAW', 0, -12/
DATA IOPERA( 12),IX( 12),IY( 12)/'DRAW', -1, -13/
C
DATA IXMIND( 2)/ -5/
DATA IXMAXD( 2)/ 5/
DATA IXDELD( 2)/ 10/
DATA ISTARD( 2)/ 6/
DATA NUMCOO( 2)/ 7/
C
C DEFINE CHARACTER 2212--: (COLON)
C
DATA IOPERA( 13),IX( 13),IY( 13)/'MOVE', 0, 5/
DATA IOPERA( 14),IX( 14),IY( 14)/'DRAW', -1, 4/
DATA IOPERA( 15),IX( 15),IY( 15)/'DRAW', 0, 3/
DATA IOPERA( 16),IX( 16),IY( 16)/'DRAW', 1, 4/
DATA IOPERA( 17),IX( 17),IY( 17)/'DRAW', 0, 5/
DATA IOPERA( 18),IX( 18),IY( 18)/'MOVE', 0, -7/
DATA IOPERA( 19),IX( 19),IY( 19)/'DRAW', -1, -8/
DATA IOPERA( 20),IX( 20),IY( 20)/'DRAW', 0, -9/
DATA IOPERA( 21),IX( 21),IY( 21)/'DRAW', 1, -8/
DATA IOPERA( 22),IX( 22),IY( 22)/'DRAW', 0, -7/
C
DATA IXMIND( 3)/ -5/
DATA IXMAXD( 3)/ 5/
DATA IXDELD( 3)/ 10/
DATA ISTARD( 3)/ 13/
DATA NUMCOO( 3)/ 10/
C
C DEFINE CHARACTER 2213--; (SEMICOLON)
C
DATA IOPERA( 23),IX( 23),IY( 23)/'MOVE', 0, 5/
DATA IOPERA( 24),IX( 24),IY( 24)/'DRAW', -1, 4/
DATA IOPERA( 25),IX( 25),IY( 25)/'DRAW', 0, 3/
DATA IOPERA( 26),IX( 26),IY( 26)/'DRAW', 1, 4/
DATA IOPERA( 27),IX( 27),IY( 27)/'DRAW', 0, 5/
DATA IOPERA( 28),IX( 28),IY( 28)/'MOVE', 0, -9/
DATA IOPERA( 29),IX( 29),IY( 29)/'DRAW', -1, -8/
DATA IOPERA( 30),IX( 30),IY( 30)/'DRAW', 0, -7/
DATA IOPERA( 31),IX( 31),IY( 31)/'DRAW', 1, -8/
DATA IOPERA( 32),IX( 32),IY( 32)/'DRAW', 1, -10/
DATA IOPERA( 33),IX( 33),IY( 33)/'DRAW', 0, -12/
DATA IOPERA( 34),IX( 34),IY( 34)/'DRAW', -1, -13/
C
DATA IXMIND( 4)/ -5/
DATA IXMAXD( 4)/ 5/
DATA IXDELD( 4)/ 10/
DATA ISTARD( 4)/ 23/
DATA NUMCOO( 4)/ 12/
C
C DEFINE CHARACTER 2214--! (EXCLAMATION POINT)
C
DATA IOPERA( 35),IX( 35),IY( 35)/'MOVE', 0, 12/
DATA IOPERA( 36),IX( 36),IY( 36)/'DRAW', -1, 10/
DATA IOPERA( 37),IX( 37),IY( 37)/'DRAW', 0, -2/
DATA IOPERA( 38),IX( 38),IY( 38)/'DRAW', 1, 10/
DATA IOPERA( 39),IX( 39),IY( 39)/'DRAW', 0, 12/
DATA IOPERA( 40),IX( 40),IY( 40)/'MOVE', 0, 10/
DATA IOPERA( 41),IX( 41),IY( 41)/'DRAW', 0, 4/
DATA IOPERA( 42),IX( 42),IY( 42)/'MOVE', 0, -7/
DATA IOPERA( 43),IX( 43),IY( 43)/'DRAW', -1, -8/
DATA IOPERA( 44),IX( 44),IY( 44)/'DRAW', 0, -9/
DATA IOPERA( 45),IX( 45),IY( 45)/'DRAW', 1, -8/
DATA IOPERA( 46),IX( 46),IY( 46)/'DRAW', 0, -7/
C
DATA IXMIND( 5)/ -5/
DATA IXMAXD( 5)/ 5/
DATA IXDELD( 5)/ 10/
DATA ISTARD( 5)/ 35/
DATA NUMCOO( 5)/ 12/
C
C DEFINE CHARACTER 2215--? (QUESTION MARK)
C
DATA IOPERA( 47),IX( 47),IY( 47)/'MOVE', -5, 8/
DATA IOPERA( 48),IX( 48),IY( 48)/'DRAW', -4, 7/
DATA IOPERA( 49),IX( 49),IY( 49)/'DRAW', -5, 6/
DATA IOPERA( 50),IX( 50),IY( 50)/'DRAW', -6, 7/
DATA IOPERA( 51),IX( 51),IY( 51)/'DRAW', -6, 8/
DATA IOPERA( 52),IX( 52),IY( 52)/'DRAW', -5, 10/
DATA IOPERA( 53),IX( 53),IY( 53)/'DRAW', -4, 11/
DATA IOPERA( 54),IX( 54),IY( 54)/'DRAW', -2, 12/
DATA IOPERA( 55),IX( 55),IY( 55)/'DRAW', 1, 12/
DATA IOPERA( 56),IX( 56),IY( 56)/'DRAW', 4, 11/
DATA IOPERA( 57),IX( 57),IY( 57)/'DRAW', 5, 10/
DATA IOPERA( 58),IX( 58),IY( 58)/'DRAW', 6, 8/
DATA IOPERA( 59),IX( 59),IY( 59)/'DRAW', 6, 6/
DATA IOPERA( 60),IX( 60),IY( 60)/'DRAW', 5, 4/
DATA IOPERA( 61),IX( 61),IY( 61)/'DRAW', 4, 3/
DATA IOPERA( 62),IX( 62),IY( 62)/'DRAW', 0, 1/
DATA IOPERA( 63),IX( 63),IY( 63)/'DRAW', 0, -2/
DATA IOPERA( 64),IX( 64),IY( 64)/'MOVE', 1, 12/
DATA IOPERA( 65),IX( 65),IY( 65)/'DRAW', 3, 11/
DATA IOPERA( 66),IX( 66),IY( 66)/'DRAW', 4, 10/
DATA IOPERA( 67),IX( 67),IY( 67)/'DRAW', 5, 8/
DATA IOPERA( 68),IX( 68),IY( 68)/'DRAW', 5, 6/
DATA IOPERA( 69),IX( 69),IY( 69)/'DRAW', 4, 4/
DATA IOPERA( 70),IX( 70),IY( 70)/'DRAW', 2, 2/
DATA IOPERA( 71),IX( 71),IY( 71)/'MOVE', 0, -7/
DATA IOPERA( 72),IX( 72),IY( 72)/'DRAW', -1, -8/
DATA IOPERA( 73),IX( 73),IY( 73)/'DRAW', 0, -9/
DATA IOPERA( 74),IX( 74),IY( 74)/'DRAW', 1, -8/
DATA IOPERA( 75),IX( 75),IY( 75)/'DRAW', 0, -7/
C
DATA IXMIND( 6)/ -9/
DATA IXMAXD( 6)/ 9/
DATA IXDELD( 6)/ 18/
DATA ISTARD( 6)/ 47/
DATA NUMCOO( 6)/ 29/
C
C DEFINE CHARACTER 2272--& (AMPERSAND)
C
DATA IOPERA( 76),IX( 76),IY( 76)/'MOVE', 9, 4/
DATA IOPERA( 77),IX( 77),IY( 77)/'DRAW', 8, 3/
DATA IOPERA( 78),IX( 78),IY( 78)/'DRAW', 9, 2/
DATA IOPERA( 79),IX( 79),IY( 79)/'DRAW', 10, 3/
DATA IOPERA( 80),IX( 80),IY( 80)/'DRAW', 10, 4/
DATA IOPERA( 81),IX( 81),IY( 81)/'DRAW', 9, 5/
DATA IOPERA( 82),IX( 82),IY( 82)/'DRAW', 8, 5/
DATA IOPERA( 83),IX( 83),IY( 83)/'DRAW', 7, 4/
DATA IOPERA( 84),IX( 84),IY( 84)/'DRAW', 6, 2/
DATA IOPERA( 85),IX( 85),IY( 85)/'DRAW', 4, -3/
DATA IOPERA( 86),IX( 86),IY( 86)/'DRAW', 2, -6/
DATA IOPERA( 87),IX( 87),IY( 87)/'DRAW', 0, -8/
DATA IOPERA( 88),IX( 88),IY( 88)/'DRAW', -2, -9/
DATA IOPERA( 89),IX( 89),IY( 89)/'DRAW', -5, -9/
DATA IOPERA( 90),IX( 90),IY( 90)/'DRAW', -8, -8/
DATA IOPERA( 91),IX( 91),IY( 91)/'DRAW', -9, -6/
DATA IOPERA( 92),IX( 92),IY( 92)/'DRAW', -9, -3/
DATA IOPERA( 93),IX( 93),IY( 93)/'DRAW', -8, -1/
DATA IOPERA( 94),IX( 94),IY( 94)/'DRAW', -2, 3/
DATA IOPERA( 95),IX( 95),IY( 95)/'DRAW', 0, 5/
DATA IOPERA( 96),IX( 96),IY( 96)/'DRAW', 1, 7/
DATA IOPERA( 97),IX( 97),IY( 97)/'DRAW', 1, 9/
DATA IOPERA( 98),IX( 98),IY( 98)/'DRAW', 0, 11/
DATA IOPERA( 99),IX( 99),IY( 99)/'DRAW', -2, 12/
DATA IOPERA( 100),IX( 100),IY( 100)/'DRAW', -4, 11/
DATA IOPERA( 101),IX( 101),IY( 101)/'DRAW', -5, 9/
DATA IOPERA( 102),IX( 102),IY( 102)/'DRAW', -5, 7/
DATA IOPERA( 103),IX( 103),IY( 103)/'DRAW', -4, 4/
DATA IOPERA( 104),IX( 104),IY( 104)/'DRAW', -2, 1/
DATA IOPERA( 105),IX( 105),IY( 105)/'DRAW', 3, -6/
DATA IOPERA( 106),IX( 106),IY( 106)/'DRAW', 5, -8/
DATA IOPERA( 107),IX( 107),IY( 107)/'DRAW', 8, -9/
DATA IOPERA( 108),IX( 108),IY( 108)/'DRAW', 9, -9/
DATA IOPERA( 109),IX( 109),IY( 109)/'DRAW', 10, -8/
DATA IOPERA( 110),IX( 110),IY( 110)/'DRAW', 10, -7/
DATA IOPERA( 111),IX( 111),IY( 111)/'MOVE', -5, -9/
DATA IOPERA( 112),IX( 112),IY( 112)/'DRAW', -7, -8/
DATA IOPERA( 113),IX( 113),IY( 113)/'DRAW', -8, -6/
DATA IOPERA( 114),IX( 114),IY( 114)/'DRAW', -8, -3/
DATA IOPERA( 115),IX( 115),IY( 115)/'DRAW', -7, -1/
DATA IOPERA( 116),IX( 116),IY( 116)/'DRAW', -5, 1/
DATA IOPERA( 117),IX( 117),IY( 117)/'MOVE', -5, 7/
DATA IOPERA( 118),IX( 118),IY( 118)/'DRAW', -4, 5/
DATA IOPERA( 119),IX( 119),IY( 119)/'DRAW', 4, -6/
DATA IOPERA( 120),IX( 120),IY( 120)/'DRAW', 6, -8/
DATA IOPERA( 121),IX( 121),IY( 121)/'DRAW', 8, -9/
C
DATA IXMIND( 7)/ -12/
DATA IXMAXD( 7)/ 13/
DATA IXDELD( 7)/ 25/
DATA ISTARD( 7)/ 76/
DATA NUMCOO( 7)/ 46/
C
C DEFINE CHARACTER 2274--$ (DOLLAR SIGN)
C
DATA IOPERA( 122),IX( 122),IY( 122)/'MOVE', -2, 16/
DATA IOPERA( 123),IX( 123),IY( 123)/'DRAW', -2, -13/
DATA IOPERA( 124),IX( 124),IY( 124)/'MOVE', 2, 16/
DATA IOPERA( 125),IX( 125),IY( 125)/'DRAW', 2, -13/
DATA IOPERA( 126),IX( 126),IY( 126)/'MOVE', 6, 9/
DATA IOPERA( 127),IX( 127),IY( 127)/'DRAW', 5, 8/
DATA IOPERA( 128),IX( 128),IY( 128)/'DRAW', 6, 7/
DATA IOPERA( 129),IX( 129),IY( 129)/'DRAW', 7, 8/
DATA IOPERA( 130),IX( 130),IY( 130)/'DRAW', 7, 9/
DATA IOPERA( 131),IX( 131),IY( 131)/'DRAW', 5, 11/
DATA IOPERA( 132),IX( 132),IY( 132)/'DRAW', 2, 12/
DATA IOPERA( 133),IX( 133),IY( 133)/'DRAW', -2, 12/
DATA IOPERA( 134),IX( 134),IY( 134)/'DRAW', -5, 11/
DATA IOPERA( 135),IX( 135),IY( 135)/'DRAW', -7, 9/
DATA IOPERA( 136),IX( 136),IY( 136)/'DRAW', -7, 7/
DATA IOPERA( 137),IX( 137),IY( 137)/'DRAW', -6, 5/
DATA IOPERA( 138),IX( 138),IY( 138)/'DRAW', -5, 4/
DATA IOPERA( 139),IX( 139),IY( 139)/'DRAW', -3, 3/
DATA IOPERA( 140),IX( 140),IY( 140)/'DRAW', 3, 1/
DATA IOPERA( 141),IX( 141),IY( 141)/'DRAW', 5, 0/
DATA IOPERA( 142),IX( 142),IY( 142)/'DRAW', 7, -2/
DATA IOPERA( 143),IX( 143),IY( 143)/'MOVE', -7, 7/
DATA IOPERA( 144),IX( 144),IY( 144)/'DRAW', -5, 5/
DATA IOPERA( 145),IX( 145),IY( 145)/'DRAW', -3, 4/
DATA IOPERA( 146),IX( 146),IY( 146)/'DRAW', 3, 2/
DATA IOPERA( 147),IX( 147),IY( 147)/'DRAW', 5, 1/
DATA IOPERA( 148),IX( 148),IY( 148)/'DRAW', 6, 0/
DATA IOPERA( 149),IX( 149),IY( 149)/'DRAW', 7, -2/
DATA IOPERA( 150),IX( 150),IY( 150)/'DRAW', 7, -6/
DATA IOPERA( 151),IX( 151),IY( 151)/'DRAW', 5, -8/
DATA IOPERA( 152),IX( 152),IY( 152)/'DRAW', 2, -9/
DATA IOPERA( 153),IX( 153),IY( 153)/'DRAW', -2, -9/
DATA IOPERA( 154),IX( 154),IY( 154)/'DRAW', -5, -8/
DATA IOPERA( 155),IX( 155),IY( 155)/'DRAW', -7, -6/
DATA IOPERA( 156),IX( 156),IY( 156)/'DRAW', -7, -5/
DATA IOPERA( 157),IX( 157),IY( 157)/'DRAW', -6, -4/
DATA IOPERA( 158),IX( 158),IY( 158)/'DRAW', -5, -5/
DATA IOPERA( 159),IX( 159),IY( 159)/'DRAW', -6, -6/
C
DATA IXMIND( 8)/ -10/
DATA IXMAXD( 8)/ 10/
DATA IXDELD( 8)/ 20/
DATA ISTARD( 8)/ 122/
DATA NUMCOO( 8)/ 38/
C
C DEFINE CHARACTER 2220--/ (SLASH)
C
DATA IOPERA( 160),IX( 160),IY( 160)/'MOVE', 9, 16/
DATA IOPERA( 161),IX( 161),IY( 161)/'DRAW', -9, -16/
C
DATA IXMIND( 9)/ -11/
DATA IXMAXD( 9)/ 11/
DATA IXDELD( 9)/ 22/
DATA ISTARD( 9)/ 160/
DATA NUMCOO( 9)/ 2/
C
C DEFINE CHARACTER 2221--( (LEFT PARENTHESES)
C
DATA IOPERA( 162),IX( 162),IY( 162)/'MOVE', 4, 16/
DATA IOPERA( 163),IX( 163),IY( 163)/'DRAW', 2, 14/
DATA IOPERA( 164),IX( 164),IY( 164)/'DRAW', 0, 11/
DATA IOPERA( 165),IX( 165),IY( 165)/'DRAW', -2, 7/
DATA IOPERA( 166),IX( 166),IY( 166)/'DRAW', -3, 2/
DATA IOPERA( 167),IX( 167),IY( 167)/'DRAW', -3, -2/
DATA IOPERA( 168),IX( 168),IY( 168)/'DRAW', -2, -7/
DATA IOPERA( 169),IX( 169),IY( 169)/'DRAW', 0, -11/
DATA IOPERA( 170),IX( 170),IY( 170)/'DRAW', 2, -14/
DATA IOPERA( 171),IX( 171),IY( 171)/'DRAW', 4, -16/
DATA IOPERA( 172),IX( 172),IY( 172)/'MOVE', 2, 14/
DATA IOPERA( 173),IX( 173),IY( 173)/'DRAW', 0, 10/
DATA IOPERA( 174),IX( 174),IY( 174)/'DRAW', -1, 7/
DATA IOPERA( 175),IX( 175),IY( 175)/'DRAW', -2, 2/
DATA IOPERA( 176),IX( 176),IY( 176)/'DRAW', -2, -2/
DATA IOPERA( 177),IX( 177),IY( 177)/'DRAW', -1, -7/
DATA IOPERA( 178),IX( 178),IY( 178)/'DRAW', 0, -10/
DATA IOPERA( 179),IX( 179),IY( 179)/'DRAW', 2, -14/
C
DATA IXMIND( 10)/ -7/
DATA IXMAXD( 10)/ 7/
DATA IXDELD( 10)/ 14/
DATA ISTARD( 10)/ 162/
DATA NUMCOO( 10)/ 18/
C
C DEFINE CHARACTER 2222--) (RIGHT PARENTHESES)
C
DATA IOPERA( 180),IX( 180),IY( 180)/'MOVE', -4, 16/
DATA IOPERA( 181),IX( 181),IY( 181)/'DRAW', -2, 14/
DATA IOPERA( 182),IX( 182),IY( 182)/'DRAW', 0, 11/
DATA IOPERA( 183),IX( 183),IY( 183)/'DRAW', 2, 7/
DATA IOPERA( 184),IX( 184),IY( 184)/'DRAW', 3, 2/
DATA IOPERA( 185),IX( 185),IY( 185)/'DRAW', 3, -2/
DATA IOPERA( 186),IX( 186),IY( 186)/'DRAW', 2, -7/
DATA IOPERA( 187),IX( 187),IY( 187)/'DRAW', 0, -11/
DATA IOPERA( 188),IX( 188),IY( 188)/'DRAW', -2, -14/
DATA IOPERA( 189),IX( 189),IY( 189)/'DRAW', -4, -16/
DATA IOPERA( 190),IX( 190),IY( 190)/'MOVE', -2, 14/
DATA IOPERA( 191),IX( 191),IY( 191)/'DRAW', 0, 10/
DATA IOPERA( 192),IX( 192),IY( 192)/'DRAW', 1, 7/
DATA IOPERA( 193),IX( 193),IY( 193)/'DRAW', 2, 2/
DATA IOPERA( 194),IX( 194),IY( 194)/'DRAW', 2, -2/
DATA IOPERA( 195),IX( 195),IY( 195)/'DRAW', 1, -7/
DATA IOPERA( 196),IX( 196),IY( 196)/'DRAW', 0, -10/
DATA IOPERA( 197),IX( 197),IY( 197)/'DRAW', -2, -14/
C
DATA IXMIND( 11)/ -7/
DATA IXMAXD( 11)/ 7/
DATA IXDELD( 11)/ 14/
DATA ISTARD( 11)/ 180/
DATA NUMCOO( 11)/ 18/
C
C DEFINE CHARACTER 2219--* (ASTERISK)
C
DATA IOPERA( 198),IX( 198),IY( 198)/'MOVE', 0, 12/
DATA IOPERA( 199),IX( 199),IY( 199)/'DRAW', 0, 0/
DATA IOPERA( 200),IX( 200),IY( 200)/'MOVE', -5, 9/
DATA IOPERA( 201),IX( 201),IY( 201)/'DRAW', 5, 3/
DATA IOPERA( 202),IX( 202),IY( 202)/'MOVE', 5, 9/
DATA IOPERA( 203),IX( 203),IY( 203)/'DRAW', -5, 3/
C
DATA IXMIND( 12)/ -8/
DATA IXMAXD( 12)/ 8/
DATA IXDELD( 12)/ 16/
DATA ISTARD( 12)/ 198/
DATA NUMCOO( 12)/ 6/
C
C DEFINE CHARACTER 2231--- (HYPHEN OR MINUS SIGN)
C
DATA IOPERA( 204),IX( 204),IY( 204)/'MOVE', -9, 0/
DATA IOPERA( 205),IX( 205),IY( 205)/'DRAW', 9, 0/
C
DATA IXMIND( 13)/ -13/
DATA IXMAXD( 13)/ 13/
DATA IXDELD( 13)/ 26/
DATA ISTARD( 13)/ 204/
DATA NUMCOO( 13)/ 2/
C
C DEFINE CHARACTER 2232--+ (PLUS SIGN)
C
DATA IOPERA( 206),IX( 206),IY( 206)/'MOVE', 0, 9/
DATA IOPERA( 207),IX( 207),IY( 207)/'DRAW', 0, -9/
DATA IOPERA( 208),IX( 208),IY( 208)/'MOVE', -9, 0/
DATA IOPERA( 209),IX( 209),IY( 209)/'DRAW', 9, 0/
C
DATA IXMIND( 14)/ -13/
DATA IXMAXD( 14)/ 13/
DATA IXDELD( 14)/ 26/
DATA ISTARD( 14)/ 206/
DATA NUMCOO( 14)/ 4/
C
C DEFINE CHARACTER 2238--= (EQUAL SIGN)
C
DATA IOPERA( 210),IX( 210),IY( 210)/'MOVE', -9, 3/
DATA IOPERA( 211),IX( 211),IY( 211)/'DRAW', 9, 3/
DATA IOPERA( 212),IX( 212),IY( 212)/'MOVE', -9, -3/
DATA IOPERA( 213),IX( 213),IY( 213)/'DRAW', 9, -3/
C
DATA IXMIND( 15)/ -13/
DATA IXMAXD( 15)/ 13/
DATA IXDELD( 15)/ 26/
DATA ISTARD( 15)/ 210/
DATA NUMCOO( 15)/ 4/
C
C DEFINE CHARACTER 2216--' (SINGLE QUOTE)
C
DATA IOPERA( 214),IX( 214),IY( 214)/'MOVE', 0, 12/
DATA IOPERA( 215),IX( 215),IY( 215)/'DRAW', -1, 5/
DATA IOPERA( 216),IX( 216),IY( 216)/'MOVE', 1, 12/
DATA IOPERA( 217),IX( 217),IY( 217)/'DRAW', -1, 5/
C
DATA IXMIND( 16)/ -4/
DATA IXMAXD( 16)/ 4/
DATA IXDELD( 16)/ 8/
DATA ISTARD( 16)/ 214/
DATA NUMCOO( 16)/ 4/
C
C DEFINE CHARACTER 2217-- (DOUBLE QUOTE)
C
DATA IOPERA( 218),IX( 218),IY( 218)/'MOVE', -4, 12/
DATA IOPERA( 219),IX( 219),IY( 219)/'DRAW', -5, 5/
DATA IOPERA( 220),IX( 220),IY( 220)/'MOVE', -3, 12/
DATA IOPERA( 221),IX( 221),IY( 221)/'DRAW', -5, 5/
DATA IOPERA( 222),IX( 222),IY( 222)/'MOVE', 4, 12/
DATA IOPERA( 223),IX( 223),IY( 223)/'DRAW', 3, 5/
DATA IOPERA( 224),IX( 224),IY( 224)/'MOVE', 5, 12/
DATA IOPERA( 225),IX( 225),IY( 225)/'DRAW', 3, 5/
C
DATA IXMIND( 17)/ -8/
DATA IXMAXD( 17)/ 8/
DATA IXDELD( 17)/ 16/
DATA ISTARD( 17)/ 218/
DATA NUMCOO( 17)/ 8/
C
C DEFINE CHARACTER 2218-- (DEGREES)
C
DATA IOPERA( 226),IX( 226),IY( 226)/'MOVE', -1, 12/
DATA IOPERA( 227),IX( 227),IY( 227)/'DRAW', -3, 11/
DATA IOPERA( 228),IX( 228),IY( 228)/'DRAW', -4, 9/
DATA IOPERA( 229),IX( 229),IY( 229)/'DRAW', -4, 7/
DATA IOPERA( 230),IX( 230),IY( 230)/'DRAW', -3, 5/
DATA IOPERA( 231),IX( 231),IY( 231)/'DRAW', -1, 4/
DATA IOPERA( 232),IX( 232),IY( 232)/'DRAW', 1, 4/
DATA IOPERA( 233),IX( 233),IY( 233)/'DRAW', 3, 5/
DATA IOPERA( 234),IX( 234),IY( 234)/'DRAW', 4, 7/
DATA IOPERA( 235),IX( 235),IY( 235)/'DRAW', 4, 9/
DATA IOPERA( 236),IX( 236),IY( 236)/'DRAW', 3, 11/
DATA IOPERA( 237),IX( 237),IY( 237)/'DRAW', 1, 12/
DATA IOPERA( 238),IX( 238),IY( 238)/'DRAW', -1, 12/
C
DATA IXMIND( 18)/ -7/
DATA IXMAXD( 18)/ 7/
DATA IXDELD( 18)/ 14/
DATA ISTARD( 18)/ 226/
DATA NUMCOO( 18)/ 13/
C
C DEFINE CHARACTER 2747-- (NO SPACE BLANK)
C
DATA IOPERA( 239),IX( 239),IY( 239)/'MOVE', 0, -32/
DATA IOPERA( 240),IX( 240),IY( 240)/'MOVE', 0, -32/
C
DATA IXMIND( 19)/ 0/
DATA IXMAXD( 19)/ 0/
DATA IXDELD( 19)/ 0/
DATA ISTARD( 19)/ 239/
DATA NUMCOO( 19)/ 2/
C
C DEFINE CHARACTER 2748-- (HALF SPACE BLANK)
C
DATA IOPERA( 241),IX( 241),IY( 241)/'MOVE', -4, -32/
DATA IOPERA( 242),IX( 242),IY( 242)/'MOVE', 4, -32/
C
DATA IXMIND( 20)/ -4/
DATA IXMAXD( 20)/ 4/
DATA IXDELD( 20)/ 8/
DATA ISTARD( 20)/ 241/
DATA NUMCOO( 20)/ 2/
C
C DEFINE CHARACTER 2749-- (FULL SPACE BLANK)
C
DATA IOPERA( 243),IX( 243),IY( 243)/'MOVE', -8, -32/
DATA IOPERA( 244),IX( 244),IY( 244)/'MOVE', 8, -32/
C
DATA IXMIND( 21)/ -8/
DATA IXMAXD( 21)/ 8/
DATA IXDELD( 21)/ 16/
DATA ISTARD( 21)/ 243/
DATA NUMCOO( 21)/ 2/
C
C DEFINE CHARACTER 2252-- (LEFT APOSTRAPHE)
C
DATA IOPERA( 245),IX( 245),IY( 245)/'MOVE', 1, 12/
DATA IOPERA( 246),IX( 246),IY( 246)/'DRAW', 0, 11/
DATA IOPERA( 247),IX( 247),IY( 247)/'DRAW', -1, 9/
DATA IOPERA( 248),IX( 248),IY( 248)/'DRAW', -1, 7/
DATA IOPERA( 249),IX( 249),IY( 249)/'DRAW', 0, 6/
DATA IOPERA( 250),IX( 250),IY( 250)/'DRAW', 1, 7/
DATA IOPERA( 251),IX( 251),IY( 251)/'DRAW', 0, 8/
C
DATA IXMIND( 22)/ -5/
DATA IXMAXD( 22)/ 5/
DATA IXDELD( 22)/ 10/
DATA ISTARD( 22)/ 245/
DATA NUMCOO( 22)/ 7/
C
C DEFINE CHARACTER 2251-- (RIGHT APOSTRAPHE)
C
DATA IOPERA( 252),IX( 252),IY( 252)/'MOVE', 0, 10/
DATA IOPERA( 253),IX( 253),IY( 253)/'DRAW', -1, 11/
DATA IOPERA( 254),IX( 254),IY( 254)/'DRAW', 0, 12/
DATA IOPERA( 255),IX( 255),IY( 255)/'DRAW', 1, 11/
DATA IOPERA( 256),IX( 256),IY( 256)/'DRAW', 1, 9/
DATA IOPERA( 257),IX( 257),IY( 257)/'DRAW', 0, 7/
DATA IOPERA( 258),IX( 258),IY( 258)/'DRAW', -1, 6/
C
DATA IXMIND( 23)/ -5/
DATA IXMAXD( 23)/ 5/
DATA IXDELD( 23)/ 10/
DATA ISTARD( 23)/ 252/
DATA NUMCOO( 23)/ 7/
C
C DEFINE CHARACTER XXX--| (KEYBOARD VERTICAL BAR)
C
DATA IOPERA( 259),IX( 259),IY( 259)/'MOVE', 0, 12/
DATA IOPERA( 260),IX( 260),IY( 260)/'DRAW', 0, -9/
C
C
DATA IXMIND( 24)/ -4/
DATA IXMAXD( 24)/ 4/
DATA IXDELD( 24)/ 8/
DATA ISTARD( 24)/ 259/
DATA NUMCOO( 24)/ 2/
C
C-----START POINT-----------------------------------------------------
C
IFOUND='NO'
IERROR='NO'
C
NUMCO=1
ISTART=1
ISTOP=1
NC=1
C
C ******************************************
C ******************************************
C ** TREAT THE ROMAN SIMPLEX UPPER CASE **
C ** HERSHEY CHARACTER SET CASE **
C ******************************************
C ******************************************
C
C
IF(IBUGD2.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPRCS--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)ICHAR2
52 FORMAT('ICHAR2 = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR
59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C **************************************************
C **************************************************
C ** STEP 1-- **
C ** SEARCH FOR THE INPUT CHARACTER(S). **
C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. **
C **************************************************
C **************************************************
C
CALL DPCHSY(ICHAR2,ICHARN,IBUGD2,IFOUND)
IF(IFOUND.EQ.'NO')GOTO9000
GOTO1000
C
C **************************************
C **************************************
C ** STEP 2-- **
C ** EXTRACT THE COORDINATES **
C ** FOR THIS PARTICULAR CHARACTER. **
C **************************************
C **************************************
C
1000 CONTINUE
ISTART=ISTARD(ICHARN)
NC=NUMCOO(ICHARN)
ISTOP=ISTART+NC-1
J=0
DO1100I=ISTART,ISTOP
J=J+1
IOP(J)=IOPERA(I)
X(J)=IX(I)
Y(J)=IY(I)
1100 CONTINUE
NUMCO=J
IXMINS=IXMIND(ICHARN)
IXMAXS=IXMAXD(ICHARN)
IXDELS=IXDELD(ICHARN)
C
GOTO9000
C
C *****************
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C *****************
C
9000 CONTINUE
IF(IBUGD2.EQ.'OFF')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPRCS--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR
9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)ICHAR2,ICHARN
9013 FORMAT('ICHAR2,ICHARN = ',A4,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO
9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8)
CALL DPWRST('XXX','BUG ')
IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019
DO9015I=1,NUMCO
WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I)
9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2)
CALL DPWRST('XXX','BUG ')
9015 CONTINUE
9019 CONTINUE
WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS
9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPRCSL(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1IBUGD2,IFOUND,IERROR)
C
C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES
C FOR ROMAN COMPLEX SCRIPT LOWER CASE.
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--87/4
C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981.
C UPDATED --MAY 1982.
C UPDATED --MARCH 1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 ICHAR2
CHARACTER*4 IOP
CHARACTER*4 IBUGD2
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
DIMENSION IOP(*)
DIMENSION X(*)
DIMENSION Y(*)
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
NUMCO=1
ISTART=1
ISTOP=1
NC=1
C
C ******************************************
C ** TREAT THE ROMAN SIMPLEX UPPER CASE **
C ** HERSHEY CHARACTER SET CASE **
C ******************************************
C
C
IF(IBUGD2.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPRCSL--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)ICHAR2
52 FORMAT('ICHAR2 = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR
59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C **************************************************
C ** STEP 1-- **
C ** SEARCH FOR THE INPUT CHARACTER(S). **
C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. **
C **************************************************
C
CALL DPCHAL(ICHAR2,ICHARN,IBUGD2,IFOUND)
IF(IFOUND.EQ.'NO')GOTO9000
C
IF(ICHARN.LE.12)GOTO1010
GOTO1019
1010 CONTINUE
CALL DRCSL1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1IBUGD2,IFOUND,IERROR)
GOTO9000
1019 CONTINUE
C
IF(13.LE.ICHARN.AND.ICHARN.LE.23)GOTO1020
GOTO1029
1020 CONTINUE
CALL DRCSL2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1IBUGD2,IFOUND,IERROR)
GOTO9000
1029 CONTINUE
C
IF(ICHARN.GE.24)GOTO1030
GOTO1039
1030 CONTINUE
CALL DRCSL3(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
1IBUGD2,IFOUND,IERROR)
GOTO9000
1039 CONTINUE
C
IFOUND='NO'
GOTO9000
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGD2.EQ.'OFF')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPRCSL--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR
9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)ICHAR2,ICHARN
9013 FORMAT('ICHAR2,ICHARN = ',A4,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO
9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8)
CALL DPWRST('XXX','BUG ')
IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019
DO9015I=1,NUMCO
WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I)
9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2)
CALL DPWRST('XXX','BUG ')
9015 CONTINUE
9019 CONTINUE
WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS
9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END