SUBROUTINE DPFACT(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 A FACTOR PLOT C THAT IS, C FACTOR PLOT Y X1 X2 X3 X4 X5 X6 C PLOTS Y VS X1, Y VS X2, ETC. AS A MULTIPLOT ON C 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--99/10 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--OCTOBER 1999. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES--------------- C INCLUDE 'DPCOPA.INC' C CHARACTER*4 ICASPL CHARACTER*4 ICAPSW CHARACTER*4 ICASEQ CCCCC CHARACTER*4 ICASAN CHARACTER*4 ICONT CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IANGLU CHARACTER*4 IFORSW 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 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 FACTOR 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='DPFACT' ISUBN2=' ' C ICASPL='FACT' IFPLLD='ON' IFPLDI='LINE' C IFLAGV=5 C C ***************************************** C ** TREAT THE FACTOR PLOT CASE ** C ***************************************** C IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'FACT')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPFACT--') 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.'FACT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(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 ICOM='PLOT' 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.'FACT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINN2=2 MINNA=2 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.'FACT') 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.'FACT')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.'FACT') 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.'FACT') 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(NRIGH2.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 DPFACT--') 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(' FACTOR 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.'FACT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IFLAG.EQ.0)GOTO1490 IF(IFPLPT.EQ.'HIST')GOTO1490 IF(IFPLPT.EQ.'PERC')GOTO1490 IF(IFPLPT.EQ.'RUNS')GOTO1490 IF(IFPLPT.EQ.'SPEC')GOTO1490 IF(IFPLPT.EQ.'LAG ')GOTO1490 IF(IFPLPT.EQ.'AUTO ')GOTO1490 C 1410 CONTINUE WRITE(ICOUT,1411) 1411 FORMAT('***** ERROR IN DPFACT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1413) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1414) CALL DPWRST('XXX','BUG ') 1413 FORMAT(' THE NUMBER OF OBSERVATIONS FOR EACH OF THE', 1'VARIABLES') 1414 FORMAT(' MUST BE THE SAME; SUCH WAS NOT THE CASE HERE.') DO1417I=1,NUMVAR I2=ILIS(I) WRITE(ICOUT,1416)IVARN1(I2),IVARN2(I2),IN(I2) 1416 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8,' 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)WRITE(ICOUT,1421)(IANS(I),I=1,MIN(IWIDTH,100)) 1421 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1490 CONTINUE C C ************************************************** C ** STEP 1-- ** C ** SAVE INITIAL SETTINGS ** C ************************************************** C ISTEPN='1' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'FACT') 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' CCCCC IFPLXA='BOTT' CCCCC IFPLYA='LEFT' IF(IFPLDI.EQ.'BLAN')IFPLDI='LINE' ENDIF C IFEED9=IFEEDB C IF(IFPLPT.EQ.'YOUD')THEN IFPLTA='ON' ENDIF C IFEED9=IFEEDB C DO110I=1,MAXCH ITITSV(I)=ITITTE(I) 110 CONTINUE NCTITS=NCTITL PTITDZ=PTITDS C IF(IFPLTA.EQ.'ON')THEN ISHIFT=ILOCQ-1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ISHIFT=NUMVAR-1 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 DO1509I=1,NUMVAR-1 IHARG(I)=IVARN1(I) IHARG2(I)=IVARN2(I) 1509 CONTINUE NUMVAR=NUMVAR-1 IF(IFPLPT.EQ.'HIST'.OR.IFPLPT.EQ.'RUNS'.OR.IFPLPT.EQ.'PERC'.OR. 1 IFPLPT.EQ.'AUTO'.OR.IFPLPT.EQ.'SPEC'.OR.IFPLPT.EQ.'LAG ')THEN IF(NUMVAR.LT.1)GOTO9000 ELSE IF(NUMVAR.LT.2)GOTO9000 ENDIF ILOCQ=ILOCQ-1 ENDIF 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 IFPLRV=INT(PFPLRV+0.5) IF(IFPLRV.LT.1)IFPLRV=1 NPLOTS=NUMVAR IFACTV=NPLOTS-IFPLRV IF(IFACTV.LT.1)THEN IFACTV=1 IFPLRV=NPLOTS-1 ENDIF C NPLOTS=IFPLRV*IFACTV C IF(IFPLRV.GT.1)THEN IMPNR=IFPLRV IMPNC=IFACTV ELSEIF(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=IFPLRV ICOLT=IFACTV IF(IFPLLA.EQ.'BOX')THEN IMPNR=IMPNR+1 IMPNC=IMPNC+1 IROWT=IFPLRV+1 ICOLT=IFACTV+1 ENDIF C C ************************************* C ** STEP 21-- ** C ** GENERATE THE SCATTER PLOTS ** C ************************************* C 2100 CONTINUE ISTEPN='21' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'DPFACT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C C 2-VARIABLE PLOTS C IF(IFPLPT.EQ.'PLOT')THEN ICT='PLOT' IC2T=' ' NCCOMM=0 IPLOTT='FPLO' GOTO5299 ENDIF IF(IFPLPT.EQ.'STAT')THEN ICT=IFPLST IC2T=IFPLS2 NCCOMM=0 IF(IFPLS3.NE.' ')THEN NCCOMM=NCCOMM+1 IHT(NCCOMM)=IFPLS3 IH2T(NCCOMM)=IFPLS4 ENDIF NCCOMM=NCCOMM+1 IHT(NCCOMM)='STAT' IH2T(NCCOMM)='ISTI' NCCOMM=NCCOMM+1 IHT(NCCOMM)='PLOT' IH2T(NCCOMM)=' ' IPLOTT='STAT' GOTO5299 ENDIF IF(IFPLPT.EQ.'BIHI')THEN ICT='RELA' IC2T='TIVE' IHT(1)='BIHI' IH2T(1)='STOG' NCCOMM=1 IPLOTT='BIHI' GOTO5299 ENDIF IF(IFPLPT.EQ.'QQPL')THEN ICT='QUAN' IC2T='TILE' IHT(1)='QUAN' IH2T(1)='TILE' IHT(2)='PLOT' IH2T(2)=' ' NCCOMM=2 IPLOTT='QQFP' GOTO5299 ENDIF IF(IFPLPT.EQ.'BOXC')THEN ICT='BOX ' IC2T=' ' IHT(1)='COX ' IH2T(1)=' ' IHT(2)='LINE' IH2T(2)='ARIT' IHT(3)='PLOT' IH2T(3)=' ' NCCOMM=3 IPLOTT='BOXC' GOTO5299 ENDIF C C UNIVARIATE PLOTS C IF(IFPLPT.EQ.'HIST'.OR.IFPLPT.EQ.'PERC'.OR.IFPLPT.EQ.'RUNS'.OR. 1 IFPLPT.EQ.'SPEC'.OR.IFPLPT.EQ.'LAG '.OR.IFPLPT.EQ.'AUTO'.OR. 1 IFPLPT.EQ.'PROB'.OR.IFPLPT.EQ.'PPCC')THEN IFPLRV=NUMVAR NPLOTS=NUMVAR IFACTV=0 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 ENDIF IF(IFPLLA.EQ.'BOX')IFPLLA='ON' C IF(IFPLPT.EQ.'HIST')THEN ICT='RELA' IC2T='TIVE' IHT(1)='HIST' IH2T(1)='OGRA' NCCOMM=1 IPLOTT='HIST' GOTO5999 ENDIF IF(IFPLPT.EQ.'RUNS')THEN ICT='RUN ' IC2T=' ' IHT(1)='SEQU' IH2T(1)='ENCE' IHT(1)='PLOT' IH2T(1)=' ' NCCOMM=2 IPLOTT='RUNS' GOTO5999 ENDIF IF(IFPLPT.EQ.'PERC')THEN ICT='PERC' IC2T='CENT' IHT(1)='POIN' IH2T(1)='T ' IHT(2)='PLOT' IH2T(2)=' ' NCCOMM=2 IPPTB2=IPPTBI IPPTBI='UNBI' IPLOTT='PERC' GOTO5999 ENDIF IF(IFPLPT.EQ.'AUTO')THEN ICT='AUTO' IC2T='CORR' IHT(1)='PLOT' IH2T(1)=' ' NCCOMM=1 IPLOTT='AUTO' GOTO5999 ENDIF IF(IFPLPT.EQ.'SPEC')THEN ICT='SPEC' IC2T='TRAL' IHT(1)='PLOT' IH2T(1)=' ' NCCOMM=1 IPLOTT='SPEC' GOTO5999 ENDIF IF(IFPLPT.EQ.'LAG ')THEN ICT='LAG ' IC2T=' ' IHT(1)='PLOT' IH2T(1)=' ' NCCOMM=1 IPLOTT='LAG ' GOTO5999 ENDIF IF(IFPLPT.EQ.'PROB')THEN IF(IFPLP1.EQ.' ')THEN ICT='NORM' IC2T='AL ' IHT(1)='PROB' IH2T(1)='ABIL' IHT(2)='PLOT' IH2T(2)=' ' NCCOMM=2 ELSE ICT=IFPLP1 IC2T=' ' NCCOMM=0 IF(IFPLP2.NE.' ')THEN NCCOMM=NCCOMM+1 IHT(NCCOMM)=IFPLP2 IH2T(NCCOMM)=' ' ENDIF IF(IFPLP3.NE.' ')THEN NCCOMM=NCCOMM+1 IHT(NCCOMM)=IFPLP3 IH2T(NCCOMM)=' ' ENDIF IF(IFPLP4.NE.' ')THEN NCCOMM=NCCOMM+1 IHT(NCCOMM)=IFPLP4 IH2T(NCCOMM)=' ' ENDIF IF(IFPLP5.NE.' ')THEN NCCOMM=NCCOMM+1 IHT(NCCOMM)=IFPLP5 IH2T(NCCOMM)=' ' ENDIF NCCOMM=NCCOMM+1 IHT(NCCOMM)='PROB' IH2T(NCCOMM)='ABIL' NCCOMM=NCCOMM+1 IHT(NCCOMM)='PLOT' IH2T(NCCOMM)=' ' ENDIF IPLOTT='PROB' GOTO5999 ENDIF IF(IFPLPT.EQ.'PPCC')THEN ICT=IFPLC1 IC2T=' ' NCCOMM=0 IF(IFPLC2.NE.' ')THEN NCCOMM=NCCOMM+1 IHT(NCCOMM)=IFPLC2 IH2T(NCCOMM)=' ' ENDIF IF(IFPLC3.NE.' ')THEN NCCOMM=NCCOMM+1 IHT(NCCOMM)=IFPLC3 IH2T(NCCOMM)=' ' ENDIF IF(IFPLC4.NE.' ')THEN NCCOMM=NCCOMM+1 IHT(NCCOMM)=IFPLC4 IH2T(NCCOMM)=' ' ENDIF IF(IFPLC5.NE.' ')THEN NCCOMM=NCCOMM+1 IHT(NCCOMM)=IFPLC5 IH2T(NCCOMM)=' ' ENDIF NCCOMM=NCCOMM+1 IHT(NCCOMM)='PPCC' IH2T(NCCOMM)=' ' NCCOMM=NCCOMM+1 IHT(NCCOMM)='PLOT' IH2T(NCCOMM)=' ' IPLOTT='PPCC' GOTO5999 ENDIF C C ************************************* C ** GENERATE 2-VARIABLE PLOTS ** C ************************************* 5299 CONTINUE C IF(NPLOTS.LT.1)GOTO8000 C ISHIFT=ILOCQ-1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ISHIFT=NCCOMM+2 IF(IFPLTA.EQ.'ON')ISHIFT=ISHIFT+1 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) 5301 CONTINUE ENDIF IHARG(NCCOMM+1)=IVARN1(1) IHARG2(NCCOMM+1)=IVARN2(1) IHARG(NCCOMM+2)=IVARN1(2) IHARG2(NCCOMM+2)=IVARN2(2) IF(IFPLTA.EQ.'ON')THEN IHARG(NCCOMM+3)=IVARN1(NUMVAR+1) IHARG2(NCCOMM+3)=IVARN2(NUMVAR+1) ENDIF 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 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(IRES.LE.IFPLRV)THEN IHARG(NCCOMM+1)=IVARN1(IRES) IHARG2(NCCOMM+1)=IVARN2(IRES) IDY=IRES ELSE IHARG(NCCOMM+1)=IVARN1(IFPLRV) IHARG2(NCCOMM+1)=IVARN2(IFPLRV) IDY=IFPLRV ENDIF C IX=IFPLRV+ITEMP IDX=ITEMP IF(IDX.LE.0)IDX=1 IF(IX.GT.IFPLRV)THEN IHARG(NCCOMM+2)=IVARN1(IX) IHARG2(NCCOMM+2)=IVARN2(IX) ELSE IHARG(NCCOMM+2)=IVARN1(IFPLRV+1) IHARG2(NCCOMM+2)=IVARN2(IFPLRV+1) ENDIF C IF(IEMPTY.EQ.'YES')THEN DO5304I=1,MAXSUB ISU2SW(I)=ISUBSW(I) ISUBSW(I)='OFF' 5304 CONTINUE ENDIF IOPTN=3 CALL DPSPM4(ICASPL,IOPTN,IDX,IDY, 1 ISUBNU,ISUBSW, 1 ASUBXL,ASUBXU,ASUBYL,ASUBYU, 1 ISUBN9,ISUBSZ, 1 ASBXL2,ASBXU2,ASBYL2,ASBYU2, 1 PFPXSL,PFPXSU,PFPYSL,PFPYSU, 1 IBUGG2,ISUBRO,IERROR) C ICASPL='FACT' CALL DPSPM1(ICASPL,IVARN1,IVARN2,ICOLL, 1 IMPNR,IMPNC,IROW,ICOL,IRES,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,IXLIST, 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) IF(IEMPTY.EQ.'NO')THEN CALL DPSPM3(ICASPL,IOUNI5, 1 IROW,ICOL, 1 PX2LD2,NPLOTP, 1 IFORSW, 1 IFPX2L,ISPX2P,ISPX2S, 1 IHRIGH,IHRIG2,IHWUSE, 1 ISUBN1,ISUBN2,MESSAG, 1 IBUGG2,ISUBRO,IERROR) 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(IFPLPT.NE.'PLOT')GOTO5499 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' ISHIFT=NARGT-NUMARG IF(ISHIFT.GT.0)THEN CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ELSEIF(ISHIFT.LT.0)THEN ISHIFT=-ISHIFT CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ENDIF ICOM=ICT ICOM2=IC2T IF(NCCOMM.GT.0)THEN DO5401II=1,NCCOMM IHARG(II)=IHT(II) IHARG2(II)=IH2T(II) 5401 CONTINUE ENDIF IHARG(NCCOMM+1)=IVARN1(1) IHARG2(NCCOMM+1)=IVARN2(1) IHARG(NCCOMM+2)=IVARN1(1) IHARG2(NCCOMM+2)=IVARN2(1) IF(IFPLTA.EQ.'ON')THEN IHARG(NCCOMM+3)=IVARN1(NUMVAR+1) IHARG2(NCCOMM+3)=IVARN2(NUMVAR+1) ENDIF 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 ** GENERATE 1-VARIABLE PLOTS ** C ************************************* 5999 CONTINUE C IF(NPLOTS.LT.1)GOTO8000 C ISHIFT=ILOCQ-1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ISHIFT=NCCOMM+1 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ICOM=ICT ICOM2=IC2T DO6001II=1,NCCOMM IHARG(II)=IHT(II) IHARG2(II)=IH2T(II) 6001 CONTINUE IHARG(NCCOMM+1)=IVARN1(1) IHARG2(NCCOMM+1)=IVARN2(1) NARGT=NUMARG C IPLOT=0 DO6100IRES=1,IFPLRV C IHARG(NCCOMM+1)=IVARN1(IRES) IHARG2(NCCOMM+1)=IVARN2(IRES) IPLOT=IPLOT+1 C IX=0 IXLIST=1 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' IF(IFPLLA.EQ.'BOX')THEN ICOL=ICOL-1 IF(ICOL.EQ.0)IEMPTY='YES' IF(IROW.EQ.IMPNR)IEMPTY='YES' ENDIF C IF(IEMPTY.EQ.'YES')THEN DO6104I=1,MAXSUB ISU2SW(I)=ISUBSW(I) ISUBSW(I)='OFF' 6104 CONTINUE ENDIF IOPTN=3 IDY=IRES IDX=1 CALL DPSPM4(ICASPL,IOPTN,IDX,IDY, 1 ISUBNU,ISUBSW, 1 ASUBXL,ASUBXU,ASUBYL,ASUBYU, 1 ISUBN9,ISUBSZ, 1 ASBXL2,ASBXU2,ASBYL2,ASBYU2, 1 PFPXSL,PFPXSU,PFPYSL,PFPYSU, 1 IBUGG2,ISUBRO,IERROR) C ICASPL='FACT' CALL DPSPM1(ICASPL,IVARN1,IVARN2,ICOLL, 1 IMPNR,IMPNC,IROW,ICOL,IRES,IRES,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,IXLIST, 1 IFPLLA,IFPLLD,IPLOTT,IFPLFR,IFPLXA,IFPLYA, 1 IFPLDI, 1 IFPLTD,PFPLTD,IVNMEX, 1 IBUGG2,ISUBRO) C IF(IEMPTY.EQ.'YES')THEN DO6106I=1,100 ICHAPA(I)='BLAN' ILINPA(I)='BLAN' ISPISW(I)='OFF' IBARSW(I)='OFF' 6106 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) IF(IEMPTY.EQ.'NO')THEN CALL DPSPM3(ICASPL,IOUNI5, 1 IROW,ICOL, 1 PX2LD2,NPLOTP, 1 IFORSW, 1 IFPX2L,ISPX2P,ISPX2S, 1 IHRIGH,IHRIG2,IHWUSE, 1 ISUBN1,ISUBN2,MESSAG, 1 IBUGG2,ISUBRO,IERROR) ENDIF C ISHIFT=NARGT-NUMARG IF(ISHIFT.GT.0)THEN CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ELSEIF(ISHIFT.LT.0)THEN ISHIFT=-ISHIFT CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ENDIF ICOM=ICT ICOM2=IC2T DO6101II=1,NCCOMM IHARG(II)=IHT(II) IHARG2(II)=IH2T(II) 6101 CONTINUE IHARG(NCCOMM+1)=IVARN1(1) IHARG2(NCCOMM+1)=IVARN2(1) C C ************************************************** C ** STEP 25-- ** C ** PLOT THE CURRENT PLOT ** C ************************************************** 6190 CONTINUE ICONT=IDCONT(1) NUMHPP=IDNHPP(1) IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'FACT')THEN WRITE(ICOUT,6197)IMANUF,NUMDEV,IDMANU(1) 6197 FORMAT('IMANUF,NUMDEV,IDMANU(1) = ',A4,I8,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF 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 PX1LDS=PX1LD2 PX1ZDS=PX1ZD2 PX2ZDS=PX2ZD2 PY1ZDS=PY1ZD2 PY2ZDS=PY2ZD2 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 IF(IEMPTY.EQ.'YES')THEN DO6107I=1,MAXSUB ISUBSW(I)=ISU2SW(I) 6107 CONTINUE ENDIF DO6108I=1,100 ICHAPA(I)=ICHAP2(I) ILINPA(I)=ILINP2(I) ISPISW(I)=ISPIS2(I) IBARSW(I)=IBARS2(I) 6108 CONTINUE C 6100 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 CCCCC IMPSW=IMPSW3 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 DPFACT--') 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 DPFAIR(NPTS,NLAB, 1AMEAN,ASD,N, 1XFAIR,XFAIS2,SEFWK1,SEFWK2, 1DLOWFW,DHIGFW,DLOWF2,DHIGF2,DLOWF3,DHIGF3, 1IWRITE, 1ICAPSW,ICAPTY,IFLAG9, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--IMPLEMENT FAIRWEATHER APPROACH TO CONSENSUS MEANS C PRINTING--YES C SUBROUTINES NEEDED--NONE C REFERENCES--ADAPTED FROM MATLAB SCRIPT PROVIDED BY C ANDREW RUHKIN OF THE NIST STATISTICAL C ENGINEERING DIVISION C --FAIRWEATHER (1972), "A METHOD FOR OBTAINING C AN EXACT CONFIDENCE INTERVAL FOR THE COMMON C MEAN OF SEVERAL NORMAL POPULATIONS", C APPLIED STATISTICS, 21, PP. 229-233. C --M. G. COX (2002), "THE EVALUATION OF KEY C COMPARISON DATA", METROLOGIA, 39, PP. 589-595. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/4 C ORIGINAL VERSION--APRIL 2006. C UPDATED --OCTOBER 2006. CALL LIST TO TPPF C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------- C IMPLICIT DOUBLE PRECISION (A-H, O-Z) C CHARACTER*4 ICAPSW CHARACTER*4 ICAPTY CHARACTER*4 ISUBRO CHARACTER*4 ISUBN0 CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IWRITE C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*1 IBASLC C CHARACTER*20 IMETH C REAL AMEAN(*) REAL ASD(*) C REAL APPF REAL XFAIR REAL XFAIS2 REAL SEFWK1 REAL SEFWK2 C LOGICAL IFLAG9 C INTEGER N(*) C C---------------------------------------------------------------- C INCLUDE 'DPCOST.INC' C PARAMETER (MAXHED=50) INTEGER IWIDTH(MAXHED) INTEGER NUMDI2(MAXHED) CHARACTER*8 ALIGN(MAXHED) CHARACTER*8 VALIGN(MAXHED) COMMON/HTML4/IWIDTH,NUMDI2,ALIGN,VALIGN CHARACTER*45 IVALUE(MAXHED) INTEGER NCHAR(MAXHED) REAL AVALUE(MAXHED) C LOGICAL IFLAG1 LOGICAL IFLAG2 LOGICAL IFLAG3 C CHARACTER*132 ITTEMP CHARACTER*132 IHEAD C CHARACTER*4 IRTFMD COMMON/COMRTF/IRTFMD C REAL CPUMIN REAL CPUMAX 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='DPGR' ISUBN2='AY ' C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FAIR')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPFAIR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPTS,NLAB 52 FORMAT('NPTS,NLAB = ',2I8) CALL DPWRST('XXX','BUG ') ENDIF C C STEP 1: COMPUTE THE FAIRWEATHER CONSENSUS MEAN C IFLAG9=.TRUE. DSUM1=0.0D0 DO910I=1,NLAB DNI=DBLE(N(I)) IF(N(I).GT.5)THEN DSUM1=DSUM1 + (DNI-3.0D0)/(DNI-1.0D0) ELSE IFLAG9=.FALSE. XFAIR=0.0 DLOWFW=0.0D0 DHIGFW=0.0D0 GOTO9000 ENDIF 910 CONTINUE DU1=DSUM1 C DSUM1=0.0D0 DO920I=1,NLAB DNI=DBLE(N(I)) DVARI=DBLE(ASD(I))**2 CK=(DNI-3.0D0)/(DNI-1.0D0) CF=CK/DU1 U=DVARI/DNI WF=CF/DSQRT(U) DSUM1=DSUM1 + WF 920 CONTINUE DSS=DSUM1 C DSUM1=0.0D0 DO930I=1,NLAB DNI=DBLE(N(I)) DMEAN=DBLE(AMEAN(I)) DVARI=DBLE(ASD(I))**2 CK=(DNI-3.0D0)/(DNI-1.0D0) CF=CK/DU1 U=DVARI/DNI WF=CF/DSQRT(U) DWI=WF/DSS DSUM1=DSUM1 + DWI*DMEAN 930 CONTINUE XFAIR=REAL(DSUM1) C DP=DBLE(NLAB) DPP=1.0D0/DBLE(NLAB-1) DRR=DP**(DP*DPP/2.0D0) IDF=NLAB-1 ALPHA=0.975 CALL TPPF(REAL(ALPHA),REAL(IDF),APPF) DPH=DBLE(APPF)/DRR/(DSQRT(DP-1.0D0)) C DSUM2=0.0D0 DSUM3=0.0D0 DSUM4=0.0D0 DSUM5=0.0D0 C DPROD1=1.0D0 DO940I=1,NLAB DNI=DBLE(N(I)) DMEAN=DBLE(AMEAN(I)) DVARI=DBLE(ASD(I))**2 CK=(DNI-3.0D0)/(DNI-1.0D0) CF=CK/DU1 U=DVARI/DNI WF=CF/DSQRT(U) DWI=WF/DSS DSUM2=DSUM2 + DWI*(DMEAN - DBLE(XFAIR))**2 DPROD1=DPROD1*DWI DSUM3=DSUM3 + CF*CF/(DNI-5.0D0) DSUM4=DSUM4 + WF**4/(CK*CK*(DNI-5.0D0)) DSUM5=DSUM5 + WF**2/CK 940 CONTINUE DPROD1=DPROD1**DPP DRI=DPH*DSQRT(DSUM2)/DSQRT(DPROD1) SU2=DSUM3 SU=DSUM4 UD=DSUM5 NR=INT(4.0D0 + (1.0D0/SU2)) ALPHA=0.975 CALL TPPF(REAL(ALPHA),REAL(NR),APPF) FC=DSQRT((DBLE(NR)-2.0D0)/(DBLE(NR)*DU1)) TF=FC*DBLE(APPF) NU=INT(4.0 + (UD*UD/SU)) C DLOWF2=DBLE(XFAIR) - (TF/DSS) DHIGF2=DBLE(XFAIR) + (TF/DSS) C CALL TPPF(REAL(ALPHA),REAL(NU),APPF) RC=DSQRT(UD*(DBLE(NU) - 2.0D0)/DBLE(NU)) DLOWF3=DBLE(XFAIR) - (RC*DBLE(APPF)) DHIGF3=DBLE(XFAIR) + (RC*DBLE(APPF)) C C DLOWFW=DBLE(XFAIR) - DRI DHIGFW=DBLE(XFAIR) + DRI C IF(IPRINT.EQ.'ON')THEN IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN C WRITE(ICOUT,5107) 5107 FORMAT('') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5170) 5170 FORMAT(' 11. Method: Fairweather') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5155) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5171) 5171 FORMAT('      ', 1 'Estimate of Consensus Mean:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)XFAIR CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5176) 5176 FORMAT('      ', 1 'Lower 95% (Fairweather) Confidence Limit:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)REAL(DLOWF2) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5177) 5177 FORMAT('      ', 1 'Upper 95% (Fairweather) Confidence Limit:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)REAL(DHIGF2) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5182) 5182 FORMAT('      ', 1 'Lower 95% (Ruhkin) Confidence Limit:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)REAL(DLOWFW) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5183) 5183 FORMAT('      ', 1 'Upper 95% (Ruhkin) Confidence Limit:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)REAL(DHIGFW) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5184) 5184 FORMAT('      ', 1 'Note: Fairweather Best Usage:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5155) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5185) 5185 FORMAT('      ', 1 '         ', 1 'Minimum within Lab Sample Size > 5
') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5155) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN C CALL DPCONA(92,IBASLC) C 8002 FORMAT(A1,'begin{table}') 8005 FORMAT(A1,'begin{center}') 8006 FORMAT(5X,A1,'begin{tabular} {lr}') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8002)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8005)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8006)IBASLC CALL DPWRST('XXX','WRIT') C 8011 FORMAT(5X,'{',A1,'bf 11. Method: Fairweather:} & ', 1 2X,A1,A1) 8012 FORMAT(5X,'Estimate of Consensus Mean: & ', 1 F15.7,2X,A1,A1) C WRITE(ICOUT,8011)IBASLC,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8012)XFAIR,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') C 8021 FORMAT(5X,'Lower 95',A1,'% (Fairweather) Confidence ', 1 'Interval: & ',F15.7,2X,A1,A1) 8022 FORMAT(5X,'Upper 95',A1,'% (Fairweather) Confidence ', 1 'Interval: & ',F15.7,2X,A1,A1) 8026 FORMAT(5X,'Lower 95',A1,'% (Ruhkin) Confidence Interval: & ', 1 F15.7,2X,A1,A1) 8027 FORMAT(5X,'Upper 95',A1,'% (Ruhkin) Confidence Interval: & ', 1 F15.7,2X,A1,A1) 8028 FORMAT(5X,'Note: Fairweather Best Usage: & ', 1 2X,A1,A1) 8029 FORMAT(5X,' Minimum within Lab Size > 5 & ', 1 2X,A1,A1) WRITE(ICOUT,8026)IBASLC,REAL(DLOWF2),IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8027)IBASLC,REAL(DHIGF2),IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8026)IBASLC,REAL(DLOWFW),IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8027)IBASLC,REAL(DHIGFW),IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8028)IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8029)IBASLC,IBASLC CALL DPWRST('XXX','WRIT') C 8030 FORMAT(A1,'end{tabular}') 8031 FORMAT(A1,'end{center}') 8032 FORMAT(A1,'end{table}') WRITE(ICOUT,8030)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8031)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8032)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF ')THEN C CALL DPCONA(92,IBASLC) C 6191 FORMAT(A1,'f',I1) IF(IRTFFF.EQ.'Courier New')THEN ITEMP=1 ELSEIF(IRTFFF.EQ.'Lucida Console')THEN ITEMP=8 ELSE ITEMP=1 ENDIF WRITE(ICOUT,6191)IBASLC,ITEMP CALL DPWRST(ICOUT,'WRIT') C NCOL=4 IDEFPS=20 IFRST=IRTFPS*5500/IDEFPS IINC1=IRTFPS*1540/IDEFPS C DO6105ISET1=1,NCOL VALIGN(ISET1)='b' ALIGN(ISET1)='r' IF(NUMDI2(ISET1).LT.0.OR.NUMDI2(ISET1).GT.9)NUMDI2(ISET1)=7 6105 CONTINUE ALIGN(1)='l' NUMDI2(1)=0 NUMDI2(2)=7 C IWIDTH(1)=IFRST IWIDTH(2)=IWIDTH(1) + IINC1 C ITTEMP=' ' NCTEMP=0 NHEAD=0 C CALL DPRTF1(ITTEMP,NCTEMP,IHEAD,NHEAD) C NHEAD=2 IFLAG1=.FALSE. IFLAG2=.FALSE. C IVALUE(1)=' b 11. Method: Fairweather' IVALUE(1)(1:1)=IBASLC NCHAR(1)=27 IVALUE(2)=' ' NCHAR(2)=0 CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) C IFLAG1=.FALSE. NHEAD=1 C NCHAR(1)=30 IVALUE(1)=' Estimate of Consensus Mean:' AVALUE(2)=XFAIR CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=44 IVALUE(1)=' Lower 95% (Fairweather) Confidence Limit:' AVALUE(2)=REAL(DLOWF2) CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=44 IVALUE(1)=' Upper 95% (Fairweather) Confidence Limit:' AVALUE(2)=REAL(DHIGF2) CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=39 IVALUE(1)=' Lower 95% (Ruhkin) Confidence Limit:' AVALUE(2)=REAL(DLOWFW) CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=39 IVALUE(1)=' Upper 95% (Ruhkin) Confidence Limit:' AVALUE(2)=REAL(DHIGFW) CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C IVALUE(1)=' Note: Fairweather Best Usage:' NCHAR(1)=34 IVALUE(2)=' ' NCHAR(2)=0 CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) C IVALUE(1)=' Minimum Within Lab Size > 5' NCHAR(1)=35 IVALUE(2)=' ' NCHAR(2)=0 CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) C CALL DPRTF6(NHEAD) IFLAG1=.TRUE. IFLAG2=.FALSE. C ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'WOML')THEN ELSE C IF(.NOT.IFLAG9)GOTO9000 C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4001) 4001 FORMAT('11. Method: Fairweather') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4002)XFAIR 4002 FORMAT(' Estimate of Consensus Mean: ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4006)NR 4006 FORMAT(' Degrees of Freedom (Fairweather): ', 1 I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4007)NU 4007 FORMAT(' Degrees of Freedom (Cox): ', 1 I8) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4021)REAL(DLOWF2) 4021 FORMAT(' Lower 95% (Fairweather) Confidence Limit: ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4022)REAL(DHIGF2) 4022 FORMAT(' Upper 95% (Fairweather) Confidence Limit: ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4023)REAL(DLOWF3) 4023 FORMAT(' Lower 95% (Cox) Confidence Limit: ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4024)REAL(DHIGF3) 4024 FORMAT(' Upper 95% (Cox) Confidence Limit: ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4025)REAL(DLOWFW) 4025 FORMAT(' Lower 95% (Ruhkin) Confidence Limit: ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4026)REAL(DHIGFW) 4026 FORMAT(' Upper 95% (Ruhkin) Confidence Limit: ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4031) 4031 FORMAT(' Note: Fairweather Best Usage:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4032) 4032 FORMAT(' Minimum Sample Size for Lab', 1 ' > 5') CALL DPWRST('XXX','WRIT') C ENDIF ENDIF C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FAIR')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPFAIR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IERROR 9012 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPTS,NLAB 9013 FORMAT('NPTS,NLAB = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)XFAIR,XFAIS2 9014 FORMAT('XFAIR,XFAIS2 = ',2G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)DLOWFW,DHIGFW 9015 FORMAT('DLOWFW,DHIGFW = ',2G15.7) CALL DPWRST('XXX','BUG ') ENDIF C RETURN END SUBROUTINE DPFEED(IHARG,NUMARG, 1IFEED2,IFOUND,IERROR) C C PURPOSE--SPECIFY THE FEEDBACK SWITCH WHICH IN TURN C DETERMINES WHETHER ANY SUBSEQUENT FEEDBACK OUTPUT C (LIKE, SAY, FROM A SUBSET SPECIFICATION) C WILL BE PRINTED OR NOT. C THIS CAPABILITY IS USEFUL IF ONE WISHES TO SUPPRESS C FEEDBACK OUTPUT FROM ALL SWITCH SETTING COMMANDS C SO AS TO NOT CLUTTER UP THE SCREEN C IN FORMING (FOR EXAMPLE) DIAGRAMMATIC GRAPHICS. C THE SPECIFIED FEEDBACK SWITCH SPECIFICATION C WILL BE PLACED IN THE HOLLERITH VARIABLE IFEED2. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG (AN INTEGER VARIABLE) C OUTPUT ARGUMENTS--IFEED2 (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--MAY 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IFEED2 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' IFEED2=IHOLD IFEEDB=IFEED2 C CCCCC GOTO1189 CCCCC IF(IFEEDB.EQ.'OFF')GOTO1189 CCCCC WRITE(ICOUT,999) CC999 FORMAT(1X) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1181)IFEED2 C1181 FORMAT('THE FEEDBACK SWITCH HAS JUST BEEN SET TO ', CCCCC CALL DPWRST('XXX','BUG ') CCCCC1A4) C1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPFENC(IHARG,NUMARG, 1IFENSW,IFOUND,IERROR) C C PURPOSE--SPECIFY THE FENCE SWITCH WHICH IN TURN C DETERMINES WHETHER SUCCEEDING BOX PLOTS WILL HAVE C VALUES BEYOND THE INNER FENCE AND OUTER FENCE INDICATED. C THE SPECIFIED FENCE SWITCH SPECIFICATION C WILL BE PLACED IN THE CHARACTER VARIABLE IFENSW. C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG (AN INTEGER VARIABLE) C OUTPUT ARGUMENTS--IFENSW (A CHARACTER 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--83/7 C ORIGINAL VERSION--JULY 1983. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IFENSW 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')GOTO1160 GOTO1150 C 1150 CONTINUE IHOLD='ON' GOTO1180 C 1160 CONTINUE IHOLD='OFF' GOTO1180 C 1180 CONTINUE IFOUND='YES' IFENSW=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IFENSW 1181 FORMAT('THE FENCE SWITCH (FOR BOX PLOTS) HAS JUST ', 1'BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPFICN(ICOM,IHARG,IHARG2,IARGT,ARG,NUMARG, 1IPARNC,IPANC2,IPAROP,PARLIM,NUMCON,MAXCON,IFOUND,IERROR,IBUG) C C PURPOSE--DEFINE CONSTRAINTS TO BE USED C IN CONJUNCTION WITH THE FIT COMMAND C (AND THE PRE-FIT COMMAND). C THE SPECIFIED CONSTRAINED PARAMETER NAME WILL BE PLACED C IN AN ELEMENT OF THE HOLLERITH VARIABLES C IPARNC(.) AND IPANC2(.). C THE SPECIFIED MATHEMATICAL OPERATION C (< OR <= OR = OR >= OR >) C INVOLVED WITH THE CONSTRAINT C WILL BE PLACED IN THE CORRESPONDING ELEMENT C OF THE HOLLARIRTH VECTOR IPAROP(.). C THE SPECIFIED NUMBER WHICH SERVES AS THE BOUNDARY VALUE C IN THE CONSTRAINT WILL BE PLACED IN THE CORRESPONDING C ELEMENT OF THE FLOATING POINT VECTOR PARLIM(.). C INPUT ARGUMENTS--ICOM (A HOLLERITH VECTOR) C --IHARG (A HOLLERITH VECTOR) C --IHARG2 (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --ARG (A FLOATING POINT VECTOR) C --NUMARG (AN INTEGER VARIABLE) C OUTPUT ARGUMENTS--IPARNC (A HOLLERITH VECTOR) C --IPANC2 (A HOLLERITH VECTOR) C --IPAROP (A HOLLERITH VECTOR) C --PARLIM (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--JUNE 1979. C UPDATED --JULY 1979. C UPDATED --DECEMBER 1980. C UPDATED --JANUARY 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICOM CHARACTER*4 IHARG CHARACTER*4 IHARG2 CHARACTER*4 IARGT CHARACTER*4 IPARNC CHARACTER*4 IPANC2 CHARACTER*4 IPAROP CHARACTER*4 IFOUND CHARACTER*4 IERROR CHARACTER*4 IBUG C CHARACTER*4 IH1 CHARACTER*4 IH2 CHARACTER*4 NEWCON C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IHARG2(*) DIMENSION IARGT(*) DIMENSION ARG(*) C DIMENSION IPARNC(*) DIMENSION IPANC2(*) DIMENSION IPAROP(*) DIMENSION PARLIM(*) 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='DPFI' ISUBN2='CN ' C ICON=0 C NEWCON='UNKN' C IF(IBUG.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61) 61 FORMAT('***** AT THE BEGINNING OF DPFICN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)NUMARG 62 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)ICOM 63 FORMAT('ICOM = ',A4) CALL DPWRST('XXX','BUG ') IF(NUMARG.LE.0)GOTO67 DO65I=1,NUMARG WRITE(ICOUT,66)I,IHARG(I),IHARG2(I),ARG(I) 66 FORMAT('I,IHARG(I),IHARG2(I),ARG(I) = ', 1I8,2X,A4,2X,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') 65 CONTINUE 67 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)NUMCON,MAXCON,NEWCON,IBUG 72 FORMAT('NUMCON,MAXCON,NEWCON,IBUG = ',I8,I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') IF(NUMCON.LE.0)GOTO77 DO75I=1,NUMCON WRITE(ICOUT,76)I,IPARNC(I),IPANC2(I),IPAROP(I),PARLIM(I) 76 FORMAT('I,IPARNC(I),IPANC2(I),IPAROP(I),PARLIM(I) = ', 1I8,2X,A4,2X,A4,2X,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') 75 CONTINUE 77 CONTINUE C 90 CONTINUE C C ********************************************** C ** STEP 1-- ** C ** DETERMINE IF HAVE THE TOTAL RESET CASE ** C ********************************************** C ISTEPN='1' IF(IBUG.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IFOUND='NO' IERROR='NO' C IF(NUMARG.GE.1.AND.ICOM.EQ.'FIT'.AND.IHARG(1).EQ.'CONS'.AND. 1IHARG2(1).EQ.'TRAI')GOTO100 GOTO900 C 100 CONTINUE IF(NUMARG.LE.1)GOTO110 IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ON')GOTO110 IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'OFF')GOTO110 IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'AUTO')GOTO110 IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'DEFA')GOTO110 GOTO190 C 110 CONTINUE IFOUND='YES' DO120I=1,MAXCON IPARNC(I)=' ' IPANC2(I)=' ' IPAROP(I)='NONE' PARLIM(I)=CPUMIN 120 CONTINUE NUMCON=0 C IF(IFEEDB.EQ.'OFF')GOTO129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('ALL PARAMETERS HAVE JUST BEEN SET SO AS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,122) 122 FORMAT(' TO BE UNCONSTRAINED') CALL DPWRST('XXX','BUG ') 129 CONTINUE GOTO900 C 190 CONTINUE C C ******************************************************** C ** STEP 2-- ** C ** DETERMINE IF NAME OF PARAMETER TO BE CONSTRAINED ** C ** ALREADY EXISTS IN CONSTRAINT TABLE. ** C ******************************************************** C ISTEPN='2' IF(IBUG.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IH1=IHARG(2) IH2=IHARG2(2) C CC NEWCON='NO' CC ICON=0 CC IF(NUMCON.LE.0)GOTO220 CC DO200I=1,NUMCON CC I2=I CC IF(IH1.EQ.IPARNC(I).AND.IH2.EQ.IPANC2(I))GOTO210 CC200 CONTINUE CC GOTO220 CC CC210 CONTINUE CC ICON=I2 CC GOTO290 CC 220 CONTINUE ICON=NUMCON+1 IF(ICON.LE.MAXCON)GOTO229 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,221) 221 FORMAT('***** ERROR IN DPFICN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,222) 222 FORMAT(' THE NUMBER OF CONSTRAINTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,224) 224 FORMAT(' HAS JUST EXCEEDED THE MAXIMUM SIZE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,225)MAXCON 225 FORMAT(' (',I5,') OF THE INTERNAL CONSTRAINT TABLE.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO900 229 CONTINUE C NEWCON='YES' NUMCON=ICON GOTO290 C 290 CONTINUE C C *********************************************** C ** STEP 3-- ** C ** ENTER THE PARAMETER NAME (IF NECESSARY) ** C ** INTO THE NAME VECTORS IPARNC(.) AND ** C ** IPANC2(.) ** C *********************************************** C ISTEPN='3' IF(IBUG.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IPARNC(ICON)=IH1 IPANC2(ICON)=IH2 C C ****************************************** C ** STEP 4-- ** C ** ENTER THE CONSTRAINT OPERATION ** C ** INTO THE OPERATION VECTOR IPAROP(.) ** C ****************************************** C ISTEPN='4' IF(IBUG.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IPAROP(ICON)='NONE' IF(NUMARG.LE.3)GOTO410 IF(IHARG(3).EQ.'ON')GOTO410 IF(IHARG(3).EQ.'OFF')GOTO410 IF(IHARG(3).EQ.'DEFA')GOTO410 IF(IHARG(3).EQ.'AUTO')GOTO410 C IF(IHARG(3).EQ.'<'.AND.IHARG(4).NE.'=')GOTO420 IF(IHARG(3).EQ.'<'.AND.IHARG(4).EQ.'=')GOTO430 IF(IHARG(3).EQ.'='.AND.IHARG(4).EQ.'<')GOTO430 IF(IHARG(3).EQ.'='.AND.IHARG(4).NE.'<'.AND. 1IHARG(4).NE.'>')GOTO440 IF(IHARG(3).EQ.'>'.AND.IHARG(4).EQ.'=')GOTO450 IF(IHARG(3).EQ.'='.AND.IHARG(4).EQ.'>')GOTO450 IF(IHARG(3).EQ.'>'.AND.IHARG(4).NE.'=')GOTO460 GOTO470 C 410 CONTINUE IPAROP(ICON)='NONE' GOTO490 C 420 CONTINUE IPAROP(ICON)='<' GOTO490 C 430 CONTINUE IPAROP(ICON)='<=' GOTO490 C 440 CONTINUE IPAROP(ICON)='=' GOTO490 C 450 CONTINUE IPAROP(ICON)='>=' GOTO490 C 460 CONTINUE IPAROP(ICON)='>' GOTO490 C 470 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,471) 471 FORMAT('ERROR IN DPFICN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,472) 472 FORMAT(' THE SECOND ARGUMENT IN THE FIT CONSTRAINT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,473) 473 FORMAT(' COMMAND SHOULD BE ONE OF THE FOLLOWING 5 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,474) 474 FORMAT(' MATHEMATICAL OPERATIONS-- < <= = >= >') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,475) 475 FORMAT(' OR SHOULD BE ONE OF THE FOLLOWING 4 WORDS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,476) 476 FORMAT(' ON OFF AUTOMATIC DEFAULT,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,477) 477 FORMAT(' BUT WAS NOT.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,478) 478 FORMAT(' THE FOLLOWING ILLUSTRATIVE EXAMPLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,479) 479 FORMAT(' DEMONSTRATES THE ALLOWABLE FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,480) 480 FORMAT(' SUPPOSE THE ANALYST WISHES TO') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,481) 481 FORMAT(' CONSTRAIN THE PARAMETER ALPHA IN A FIT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,482) 482 FORMAT(' TO BE STRICTLY GREATER THAN 0 AND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,483) 483 FORMAT(' ALSO TO BE LESS THAN OR EQUAL TO 100,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,484) 484 FORMAT(' THEN THE FOLLOWING MAY BE ENTERED--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,485) 485 FORMAT(' FIT CONSTRAINT ALPHA > 0') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,486) 486 FORMAT(' FIT CONSTRAINT ALPHA <= 100') CALL DPWRST('XXX','BUG ') IF(NEWCON.EQ.'NO')GOTO489 NUMCON=NUMCON-1 IPARNC(ICON)=' ' IPANC2(ICON)=' ' 489 CONTINUE GOTO900 C 490 CONTINUE C C ************************************** C ** STEP 5-- ** C ** ENTER THE CONSTRAINT LIMITS ** C ** INTO THE VECTOR PARLIM(.) ** C ************************************** C ISTEPN='5' IF(IBUG.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPAROP(ICON).EQ.'NONE')GOTO590 IF(IARGT(NUMARG).EQ.'NUMB')GOTO510 GOTO570 C 510 CONTINUE IFOUND='YES' PARLIM(ICON)=ARG(NUMARG) GOTO590 C 570 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,571) 571 FORMAT('ERROR IN DPFICN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,572) 572 FORMAT(' THE THIRD ARGUMENT IN THE FIT CONSTRAINT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,573) 573 FORMAT(' COMMAND SHOULD BE A NUMBER ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,574) 574 FORMAT(' OR A PREVIOUSLY-DEFINED PARAMETER,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,575) 575 FORMAT(' BUT WAS NOT.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,576) 576 FORMAT(' THE FOLLOWING ILLUSTRATIVE EXAMPLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,577) 577 FORMAT(' DEMONSTRATES THE ALLOWABLE FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,578) 578 FORMAT(' SUPPOSE THE ANALYST WISHES TO') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,579) 579 FORMAT(' CONSTRAIN THE PARAMETER ALPHA IN A FIT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,480) 580 FORMAT(' TO BE STRICTLY GREATER THAN 0 AND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,581) 581 FORMAT(' ALSO TO BE LESS THAN OR EQUAL TO 100,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,582) 582 FORMAT(' THEN THE FOLLOWING MAY BE ENTERED--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,583) 583 FORMAT(' FIT CONSTRAINT ALPHA > 0') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,584) 584 FORMAT(' FIT CONSTRAINT ALPHA <= 100') CALL DPWRST('XXX','BUG ') IF(NEWCON.EQ.'NO')GOTO589 NUMCON=NUMCON-1 IPARNC(ICON)=' ' IPANC2(ICON)=' ' 589 CONTINUE GOTO900 590 CONTINUE C C **************************** C ** STEP 6-- ** C ** WRITE OUT A MESSAGE. ** C **************************** C ISTEPN='6' IF(IBUG.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPAROP(ICON).EQ.'NONE')GOTO610 IF(IPAROP(ICON).EQ.'<')GOTO620 IF(IPAROP(ICON).EQ.'<=')GOTO630 IF(IPAROP(ICON).EQ.'=')GOTO640 IF(IPAROP(ICON).EQ.'>=')GOTO650 IF(IPAROP(ICON).EQ.'>')GOTO660 GOTO690 C 610 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO619 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,611)IPARNC(ICON),IPANC2(ICON) 611 FORMAT('THE PARAMETER ',A4,A4,' HAS JUST BEEN SET') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,612) 612 FORMAT(' SO AS TO BE UNCONSTRAINED') CALL DPWRST('XXX','BUG ') 619 CONTINUE GOTO670 C 620 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO629 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,621)IPARNC(ICON),IPANC2(ICON) 621 FORMAT('THE PARAMETER ',A4,A4,' HAS JUST BEEN CONSTRAINED ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,622)PARLIM(ICON) 622 FORMAT(' TO BE STRICTLY LESS THAN ',E15.7) CALL DPWRST('XXX','BUG ') 629 CONTINUE GOTO690 C 630 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO639 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,631)IPARNC(ICON),IPANC2(ICON) 631 FORMAT('THE PARAMETER ',A4,A4,' HAS JUST BEEN CONSTRAINED ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,632)PARLIM(ICON) 632 FORMAT(' TO BE LESS THAN OR EQUAL TO ',E15.7) CALL DPWRST('XXX','BUG ') 639 CONTINUE GOTO690 C 640 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO649 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,641)IPARNC(ICON),IPANC2(ICON) 641 FORMAT('THE PARAMETER ',A4,A4,' HAS JUST BEEN CONSTRAINED ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,642)PARLIM(ICON) 642 FORMAT(' TO BE IDENTICALLY EQUAL TO ',E15.7) CALL DPWRST('XXX','BUG ') 649 CONTINUE GOTO690 C 650 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO659 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,651)IPARNC(ICON),IPANC2(ICON) 651 FORMAT('THE PARAMETER ',A4,A4,' HAS JUST BEEN CONSTRAINED ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,652)PARLIM(ICON) 652 FORMAT(' TO BE GREATER THAN OR EQUAL TO ',E15.7) CALL DPWRST('XXX','BUG ') 659 CONTINUE GOTO690 C 660 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO669 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,661)IPARNC(ICON),IPANC2(ICON) 661 FORMAT('THE PARAMETER ',A4,A4,' HAS JUST BEEN CONSTRAINED ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,662)PARLIM(ICON) 662 FORMAT(' TO BE STRICTLY GREATER THAN ',E15.7) CALL DPWRST('XXX','BUG ') 669 CONTINUE GOTO690 C 670 CONTINUE NUMCO2=NUMCON IF(NUMCON.LE.0)GOTO679 DO671I=1,NUMCON IF(I.GT.NUMCO2)GOTO679 I2=I IF(IH1.EQ.IPARNC(I).AND.IH2.EQ.IPANC2(I))GOTO672 GOTO671 C 672 CONTINUE J=I JM1=J-1 JMIN=I+1 JMAX=NUMCO2 IF(JMIN.GT.JMAX)GOTO674 DO673J=JMIN,JMAX JM1=J-1 IPARNC(JM1)=IPARNC(J) IPANC2(JM1)=IPANC2(J) IPAROP(JM1)=IPAROP(J) PARLIM(JM1)=PARLIM(J) 673 CONTINUE 674 CONTINUE NUMCO2=JM1 C 671 CONTINUE 679 CONTINUE NUMCON=NUMCO2 GOTO690 C 690 CONTINUE C C **************** C ** STEP 9-- ** C ** EXIT ** C **************** C 900 CONTINUE IF(IBUG.EQ.'OFF')GOTO990 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,901) 901 FORMAT('***** AT THE END OF DPFICN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,902)NUMCON,MAXCON,NEWCON,IBUG 902 FORMAT('NUMCON,MAXCON,NEWCON,IBUG = ',I8,I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,903)ICON 903 FORMAT('ICON = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMCON.LE.0)GOTO990 DO910I=1,NUMCON WRITE(ICOUT,911)I,IPARNC(I),IPANC2(I),IPAROP(I),PARLIM(I) 911 FORMAT('I,IPARNC(I),IPANC2(I),IPAROP(I),PARLIM(I) = ', 1I8,2X,A4,2X,A4,2X,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') 910 CONTINUE 990 CONTINUE C RETURN END SUBROUTINE DPFIFO(IHARG,NUMARG, 1IOUTTY,IFOUND,IERROR) C C PURPOSE--SET THE FORMAT/TYPE SWITCH FOR THE OUTPUT FILE. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG (AN INTEGER VARIABLE) C OUTPUT ARGUMENTS--IOUTTY (A HOLLERITH VARIABLE) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--92/4 C ORIGINAL VERSION--MARCH 1992. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IOUTTY CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C 1110 CONTINUE IF(NUMARG.LE.0)GOTO1150 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 IF(IHARG(NUMARG).EQ.'?')GOTO1160 GOTO1170 C 1150 CONTINUE IHOLD='ASCI' GOTO1180 C 1160 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1169 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1161)IOUTTY 1161 FORMAT('THE CURRENT FORMAT OF THE OUTPUT FILE IS ',A4) CALL DPWRST('XXX','BUG ') 1169 CONTINUE IFOUND='YES' GOTO1199 C 1170 CONTINUE IHOLD=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' IOUTTY=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IOUTTY 1181 FORMAT('THE OUTPUT FILE FORMAT SWITCH HAS JUST ', 1'BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPFIIT(IHARG,IARGT,IARG,NUMARG,IDEFFI, 1IFITIT,IFOUND,IERROR) C C PURPOSE--DEFINE THE UPPER BOUND FOR THE NUMBER OF FIT ITERATIONS. C THE SPECIFIED FIT ITERATION VALUE WILL BE PLACED C IN THE INTEGER VARIABLE IFITIT. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (AN INTEGER VECTOR) C --NUMARG (AN INTEGER VARIABLE) C --IDEFFI (AN INTEGER VARIABLE) C OUTPUT ARGUMENTS--IFITIT (AN INTEGER VARIABLE) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--NOVEMBER 1980. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(NUMARG.EQ.0)GOTO1199 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'=')GOTO1199 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ITER')GOTO1110 GOTO1199 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ITER')GOTO1150 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 GOTO1120 C 1120 CONTINUE IERROR='YES' WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPFIIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' ILLEGAL FORM FOR FIT ITERATIONS ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1124) 1124 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1125) 1125 FORMAT(' SUPPOSE THE THE ANALYST WILL BE CARRYING OUT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1126) 1126 FORMAT(' A NON-LINEAR FIT , ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1127) 1127 FORMAT(' AND SUPPOSE THE ANALYST WISHES TO TERMINATE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1128) 1128 FORMAT(' THE FIT IF THE NUMBER OF ITERATIONS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1129) 1129 FORMAT(' HAPPENS TO REACH 30;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1130) 1130 FORMAT(' THEN THE ALLOWABLE FORM IS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1131) 1131 FORMAT(' FIT ITERATIONS 30 ') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE IHOLD=IDEFFI GOTO1180 C 1160 CONTINUE IHOLD=IARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' IFITIT=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IFITIT 1181 FORMAT('THE FIT ITERATIONS HAVE JUST BEEN SET TO ', 1I8) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPFILE(IANS,IWIDTH,IWORD, 1IOFILE,IBUGS2,ISUBRO,IERROR) C C PURPOSE--SCAN THE IWORD-TH WORD OF THE INPUT LINE. C AND DETERMINE IF IT IS A FILE NAME. C THE CRITERION IS THAT IF THAT WORD C CONTAINS THE CHARACTER IFCHAR , C THEN IT IS CONSIDERED A FILE NAME, C OTHERWISE IT IS CONSIDERED NOT TO BE A FILE NAME. C OUTPUT ARGUMENT--IOFILE ('YES' OR 'NO') C NOTE--THIS SUBROUTINE IS "SYSTEM-DEPENDENT" IN THE SENSE C THAT IFCHAR MAY DIFFER FROM ONE SYSTEM TO ANOTHER. C NOTE--IFCHAR IS SET AT TIMPLEMENTATION TIME C IN THE SUBROUTINE INITFO. C NOTE--THE DEFAULT SETTING FOR IFCHAR IS . (= PERIOD). C THUS YOU MAY ENTER READ X. Y Z C TO TELL DATAPLOT TO READ VARIABLES Y AND Z C FROM FILE X C AS OPPOSED TO ENTERING READ X Y Z C TO TELL DATAPLOT TO READ VARIABLES X, Y, AND Z C FROM THE TERMINAL. C READ X. Y Z 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--NOVEMBER 1977. C UPDATED --OCTOBER 1978. C UPDATED --NOVEMBER 1980. C UPDATED --JUNE 1981. C UPDATED --MAY 1982. C UPDATED --DECEMBER 1986. C UPDATED --DECEMBER 1988. DESLATTES FILE NAME INSIDE QUOTE PROBLEM C UPDATED --JULY 2002. OPTION (IFILQU=ON/OFF) TO C DETERMINE IF FILE NAME CAN C BE ENCLOSED IN QUOTES C UPDATED --JULY 2003. BUG: EVEN THOUGH FILE NAMES C MAY BE RESTRICTED TO 80 C CHARACTERS, THE COMMAND LINE C CONTAINING THEM CAN BE C LONGER. ADJUST DIMENSIONING C TO ACCOUNT FOR THIS. ALSO ADD C CHECK FOR FILE NAMES EXCEEDING C 80 CHARACTERS. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IANS CHARACTER*4 IOFILE CHARACTER*4 IBUGS2 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 IANSI CCCCC CHARACTER*80 ICANS CCCCC CHARACTER*80 ISTRIN CHARACTER*255 ICANS CHARACTER*255 ISTRIN C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C DIMENSION IANS(*) C PARAMETER (MAXFNC=80) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOF2.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 ISUBN1='DPFI' ISUBN2='LE ' C IERROR='NO' C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'FILE')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPFILE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IWIDTH,IWORD 52 FORMAT('IWIDTH,IWORD = ',2I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,53)(IANS(I),I=1,MIN(100,IWIDTH)) 53 FORMAT('IANS(.) = ',100A1) CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,54)IFCHAR 54 FORMAT('IFCHAR = ',A1) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *************************************** C ** STEP 1-- ** C ** DETERMINE IF HAVE THE FILE CASE ** C *************************************** C ISTEPN='1' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'FILE') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1110I=1,MIN(255,IWIDTH) IANSI=IANS(I) ICANS(I:I)=IANSI(1:1) 1110 CONTINUE C ISTART=1 ISTOP=IWIDTH CALL DPEXWO(ICANS,ISTART,ISTOP,IWORD, 1ICOL1,ICOL2,ISTRIN,NCSTRI, 1IBUGS2,ISUBRO,IERROR) C IOFILE='NO' IF(NCSTRI.LE.0)GOTO1290 C THE FOLLOWING LINE WAS INSERTED DECEMBER 1988 TO C SOLVE THE DESLATTES PROBLEM WRITE "(EXAMPLE--ABC.DEF)" C JULY 2002: MAKE QUOTE OPTIONAL (PC FILES CAN HAVE SPACES, C SO ENCLOSE IN QUOTES TO EXTRACT) CCCCC IF(ICANS(1:1).EQ.'"')GOTO1290 IF(ICANS(1:1).EQ.'"' .AND. IFILQU.EQ.'OFF')GOTO1290 IF(ICOL1.GT.ICOL2)GOTO1290 DO1200I=ICOL1,ICOL2 IF(ICANS(I:I).EQ.IFCHAR)GOTO1250 1200 CONTINUE GOTO1290 1250 CONTINUE IOFILE='YES' NC=ICOL2-ICOL1+1 IF(IFILQU.EQ.'ON' .AND. ICANS(ICOL1:ICOL1).EQ.'"')NC=NC-1 IF(IFILQU.EQ.'ON' .AND. ICANS(ICOL2:ICOL2).EQ.'"')NC=NC-1 IF(NC.GT.MAXFNC)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1251)MAXFNC 1251 FORMAT('***** FATAL ERROR: FILE NAME EXCEEDS MAXIMUM ', 1 'LENGTH OF ',I8,' CHARACTERS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1253)NC 1253 FORMAT(' REQUESTED FILE NAME HAS ',I8,' CHARACTERS.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF GOTO1290 1290 CONTINUE C C **************** C ** STEP 90-- ** C ** EXIT. ** C **************** C 9000 CONTINUE IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'FILE')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPFILE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IWIDTH,IWORD 9012 FORMAT('IWIDTH,IWORD = ',2I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,9013)(IANS(I),I=1,MIN(100,IWIDTH)) 9013 FORMAT('IANS(.) = ',100A1) CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,9014)IFCHAR 9014 FORMAT('IFCHAR = ',A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)ICOL1,ICOL2,NCSTRI 9015 FORMAT('ICOL1,ICOL2,NCSTRI = ',3I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,9021)(ICANS(I:I),I=1,MIN(100,IWIDTH)) 9021 FORMAT('ICANS(.:.) = ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)(ISTRIN(I:I),I=1,MIN(100,IWIDTH)) 9022 FORMAT('ISTRIN(.:.) = ',100A1) CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,9031)IBUGS2,IERROR 9031 FORMAT('IBUGS2,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9032)IOFILE 9032 FORMAT('IOFILE = ',A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPFIL2(ICHAR,IMIN,IMAX,IANS2,IWID, 1LOCCHA,NAM,NPACKC,IBUG,IERROR) C C PURPOSE--EXTRACT QUALIFIER, FILE, OR SUBFILE C NAME FROM A STRING. C INPUT ARGUMENTS--IMIN = INTEGER VARIABLE C CONTAINING THE START LOCATION C (IN THE VECTOR IANS2(.)) C FOR THE SEARCH. C --IMAX = INTEGER VARIABLE C CONTAINING THE STOP LOCATION C (IN THE VECTOR IANS2(.)) C FOR THE SEARCH. C --ICHAR = HOLLERITH VARIABLE GIVING C THE SOUGHT-AFTER CHARACTER C IN THE SEARCH. C --IANS2 = HOLLERITH VECTOR BEING SEARCHED. C --IWID = THE NUMBER OF ELEMENTS C IN THE HOLLERITH VECTOR IANS2(.) C OUTPUT ARGUMENTS--LOCCHA = INTEGER VARIABLE C CONTAINING THE LOCATION C (IN THE VECTR IANS2(.)) C WHERE THE CHARACTER WAS FOUND. C --NAM = HOLLERITH VECTOR C INTO WHICH THE PACKED NAME C IS PLACED. C --NPACKC = INTEGER VARIABLE C CONTAINING THE NUMBER OF WORDS C IN THE VARIABLE NAM(.) FOR C THE PACKED VERSION OF THE C QUALIFIER, FILE, AND/OR SUBFILE NAME C (WHERE THE WORDS ARE PACKED-- C 4, 6, 10, ETC. CHARACTERS PER WORD). C NOTE--IF THE NAME DOES NOT EXIST, C THE LOCCHA IS SET TO IMIN-1, C NAM(.) IS FILLED WITH BLANKS, C AND NPACKC IS SET TO 0 . C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--JUNE 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR CHARACTER*4 IANS2 CHARACTER*4 NAM CHARACTER*4 IBUG CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IANS2(*) DIMENSION NAM(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IERROR='NO' C IF(IBUG.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPFIL2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHAR,IMIN,IMAX 52 FORMAT('ICHAR,IMIN,IMAX = ',A4,2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IWID 53 FORMAT('IWID = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)(IANS2(I),I=1,IWID) 54 FORMAT('IANS2(.)--',120A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IBUG,IERROR 55 FORMAT('IBUG,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C **************************************** C ** STEP 1-- ** C ** ZERO-OUT AND BLANK-OUT ** C ** THE OUTPUT VARIABLES AND VECTOR. ** C **************************************** C LOCCHA=IMIN-1 NPACKC=0 C DO1110J=1,10 NAM(J)=' ' 1110 CONTINUE C C ******************************************* C ** STEP 2-- ** C ** SEARCH FOR THE TARGET CHARACTER; ** C ** DETERMINE ITS LOCATION IN IANS2(.); ** C ** PLACE THE LOCATION VALUE IN LOCCHA. ** C ******************************************* C IF(ICHAR.EQ.'END')GOTO1126 IF(IMAX.LE.0)GOTO1190 IF(IMIN.GT.IMAX)GOTO1190 DO1120I=IMIN,IMAX I2=I IF(IBUG.EQ.'ON')WRITE(ICOUT,1111)I,IANS2(I),ICHAR 1111 FORMAT('I,IANS2(I),ICHAR = ',I6,A6,A6) IF(IBUG.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(IANS2(I).EQ.ICHAR)GOTO1125 1120 CONTINUE GOTO1190 1125 CONTINUE LOCCHA=I2 GOTO1129 1126 CONTINUE LOCCHA=IMAX+1 GOTO1129 1129 CONTINUE C C ************************************************* C ** STEP 3-- ** C ** EXTRACT THE NAME BETWEEN LOCATION IMIN ** C ** AND THE LOCATION OF THE TARGET CHARACTER. ** C ** PACK THE NAME INTO NAM(.) ** C ** COMPUTE NPACKC = THE NUMBER OF PACKED WORDS** C ** IN NAM(.) NEEDED FOR THE NAME. ** C ************************************************* C NUMCH=0 IMAX2=LOCCHA-1 IF(IMAX2.LE.0)GOTO1190 IF(IMIN.GT.IMAX2)GOTO1190 DO1130I=IMIN,IMAX2 CCCCC J=((I-IMIN)/NUMBPC)+1 J=((I-IMIN)/NUMCPW)+1 IF(IANS2(I).EQ.' ')GOTO1130 NUMCH=NUMCH+1 ISTAR3=(NUMBPC*(NUMCH-1)) - (NUMBPW*(J-1)) ISTAR3=IABS(ISTAR3) CALL DPCHEX(0,NUMBPC,IANS2(I),ISTAR3,NUMBPC,NAM(J)) 1130 CONTINUE NPACKC=J 1139 CONTINUE C 1190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUG.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPFIL2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICHAR,IMIN,IMAX 9012 FORMAT('ICHAR,IMIN,IMAX = ',A4,2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IWID 9013 FORMAT('IWID = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)(IANS2(I),I=1,IWID) 9014 FORMAT('IANS2(.)--',120A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IBUG,IERROR 9015 FORMAT('IBUG,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)LOCCHA,NPACKC 9016 FORMAT('LOCCHA,NPACKC = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)(NAM(I),I=1,10) 9017 FORMAT('NAM(.)--',10A6) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPFILL(IHARG,NUMARG, 1IDEFFI, 1ITEXFI, 1IBUGD2,ISUBRO,IFOUND,IERROR) C C PURPOSE--DEFINE THE FILL SWITCH (ON OR OFF) FOR C TEXT SCRIPT AND OTHER DIAGRAMMATIC FIGURES C ON A PLOT. C THE FILL SWITCH WILL BE PLACED C IN THE CHARACTER VARIABLE ITEXFI. C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEFFI C --IBUGD2 C OUTPUT ARGUMENTS--ITEXFI C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--APRIL 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFFI CHARACTER*4 ITEXFI CHARACTER*4 IBUGD2 CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(IBUGD2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPFILL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IDEFFI 53 FORMAT('IDEFFI = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NUMARG 54 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NUMARG WRITE(ICOUT,56)I,IHARG(I) 56 FORMAT('I,IHARG(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ************************************ C ** TREAT THE FILL CASE ** C ************************************ C IF(NUMARG.LE.0)GOTO1161 IF(IHARG(NUMARG).EQ.'ON')GOTO1161 IF(IHARG(NUMARG).EQ.'OFF')GOTO1162 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1161 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165 GOTO1170 C 1161 CONTINUE ITEXFI='ON' GOTO1180 C 1162 CONTINUE ITEXFI='OFF' GOTO1180 C 1165 CONTINUE ITEXFI=IDEFFI GOTO1180 C 1170 CONTINUE IERROR='YES' WRITE(ICOUT,1171) 1171 FORMAT('***** ERROR IN DPFILL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1172) 1172 FORMAT(' ILLEGAL ENTRY FOR FILL ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1173) 1173 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1174) 1174 FORMAT(' SUPPOSE THE THE ANALYST WISHES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1175) 1175 FORMAT(' TO HAVE ALL TEXT AND FIGURES FILLED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1177) 1177 FORMAT(' THEN ALLOWABLE FORMS ARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1178) 1178 FORMAT(' FILL ON ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1179) 1179 FORMAT(' FILL ') CALL DPWRST('XXX','BUG ') GOTO9000 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE FILL (FOR TEXT AND FIGURES) ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)ITEXFI 1182 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE 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 DPFILL') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IDEFFI,ITEXFI 9013 FORMAT('IDEFFI,ITEXFI = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPFIMA(PXMIN,PYMIN,PXMAX,PYMAX, 1ICASPL,ICAS3D, 1IMARCO) C C PURPOSE--FILL THE MARGIN REGION ON THE SCREEN C (THE REGION OUTSIDE THE FRAME LINES). C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--83.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C UPDATED --FEBRUARY 1988. STAR PLOT C UPDATED --JUNE 1988. CALL TO GRFIRE C UPDATED --JANUARY 1989. MODIFY CALL TO GRFIRE (ALAN) C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 ICASPL CHARACTER*4 ICAS3D C CHARACTER*4 IMARCO C CHARACTER*4 IFIG CHARACTER*4 IPATT CHARACTER*4 ICOLB CHARACTER*4 ICOLP C CHARACTER*4 ICOL C CHARACTER*4 ICASE C CHARACTER*4 IHORPA CHARACTER*4 IVERPA CHARACTER*4 IDUPPA CHARACTER*4 IDDOPA C CHARACTER*4 IPATT2 C DIMENSION PX(10) DIMENSION PY(10) 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 C-----START POINT----------------------------------------------------- C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'FIMA')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPFIMA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)PXMIN,PYMIN,PXMAX,PYMAX 52 FORMAT('PXMIN,PYMIN,PXMAX,PYMAX = ',4F10.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,ICAS3D 53 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IMARCO 54 FORMAT('IMARCO = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGG4,ISUBG4,IERRG4 59 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C IPATT2='SOLI' C IF(ICASPL.EQ.'PIEC')GOTO9000 IF(ICASPL.EQ.'STAR')GOTO9000 IF(ICAS3D.EQ.'ON')GOTO9000 C C ********************************** C ** STEP 0-- ** C ** COPY OVER THE MARGIN COLOR ** C ********************************** C ICASE='REGI' IFIG='BOX' IPATT='SOLI' IF(IGCOLO.EQ.'OFF')IPATT='EMPT' PTHICK=0.0 PXGAP=0.0 PYGAP=0.0 ICOLB=IMARCO ICOLP=IMARCO C C ********************************************** C ** STEP 1-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE FILL COLOR ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C ICOL=ICOLB CALL GRTRCO(ICASE,ICOL,JCOL) JCOLB=JCOL C C ******************************* C ** STEP 2-- ** C ** SET THE FILL COLOR ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CALL GRSECO(ICASE,ICOL,JCOL) C C ********************************************** C ** STEP 3-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE FILL PATTERN ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C CALL GRTRPA(ICASE,IPATT,PXGAP,PYGAP, 1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXGAP2,PYGAP2) C C ******************************* C ** STEP 4-- ** C ** SET THE FILL PATTERN ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CALL GRSEPA(ICASE,IPATT,PXGAP,PYGAP, 1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXGAP2,PYGAP2) C C ********************************************** C ** STEP 5-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE PATTERN COLOR ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C ICOL=ICOLP CALL GRTRCO(ICASE,ICOL,JCOL) JCOLP=JCOL C C ******************************* C ** STEP 6-- ** C ** SET THE PATTERN COLOR ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CALL GRSECO(ICASE,ICOL,JCOL) C C ********************************************** C ** STEP 7-- ** C ** TRANSLATE THE DESIRED ** C ** LINE THICKNESS (OF THE PATTERN) ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C CALL GRTRTH(ICASE,PTHICK,JTHICK,PTHIC2) C C ******************************* C ** STEP 8-- ** C ** SET THE LINE THICKNESS ** C ** (OF THE PATTERN) ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CALL GRSETH(ICASE,PTHICK,JTHICK,PTHIC2) C C *********************************** C ** STEP 11-- ** C ** FILL THE REGION ** C ** BELOW THE BOTTOM FRAME LINE ** C *********************************** C PX(1)=0.0 PY(1)=0.0 PX(2)=100.0 PY(2)=0.0 PX(3)=100.0 PY(3)=PYMIN PX(4)=0.0 PY(4)=PYMIN NP=4 CALL GRFIRE(PX,PY,NP,IFIG, 1IPATT,JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXGAP2,PYGAP2, 1PTHICK,JTHICK,PTHIC2, 1ICOLB,JCOLB,ICOLP,JCOLP, 1IPATT2) C C ******************************************** C ** STEP 12-- ** C ** FILL THE REGION ** C ** TO THE RIGHT OF THE RIGHT FRAME LINE ** C ******************************************** C PX(1)=PXMAX PY(1)=PYMIN PX(2)=100.0 PY(2)=PYMIN PX(3)=100.0 PY(3)=100.0 PX(4)=PXMAX PY(4)=100.0 NP=4 CALL GRFIRE(PX,PY,NP,IFIG, 1IPATT,JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXGAP2,PYGAP2, 1PTHICK,JTHICK,PTHIC2, 1ICOLB,JCOLB,ICOLP,JCOLP, 1IPATT2) C C ******************************** C ** STEP 13-- ** C ** FILL THE REGION ** C ** ABOVE THE TOP FRAME LINE ** C ******************************** C PX(1)=0.0 PY(1)=PYMAX PX(2)=PXMAX PY(2)=PYMAX PX(3)=PXMAX PY(3)=100.0 PX(4)=0.0 PY(4)=100.0 NP=4 CALL GRFIRE(PX,PY,NP,IFIG, 1IPATT,JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXGAP2,PYGAP2, 1PTHICK,JTHICK,PTHIC2, 1ICOLB,JCOLB,ICOLP,JCOLP, 1IPATT2) C C ****************************************** C ** STEP 14-- ** C ** FILL THE REGION ** C ** TO THE LEFT OF THE LEFT FRAME LINE ** C ****************************************** C PX(1)=0.0 PY(1)=PYMIN PX(2)=PXMIN PY(2)=PYMIN PX(3)=PXMIN PY(3)=PYMAX PX(4)=0.0 PY(4)=PYMAX NP=4 CALL GRFIRE(PX,PY,NP,IFIG, 1IPATT,JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXGAP2,PYGAP2, 1PTHICK,JTHICK,PTHIC2, 1ICOLB,JCOLB,ICOLP,JCOLP, 1IPATT2) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'FIMA')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPFIMA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)PXMIN,PYMIN,PXMAX,PYMAX 9012 FORMAT('PXMIN,PYMIN,PXMAX,PYMAX = ',4F10.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICASPL,ICAS3D 9013 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IMARCO 9014 FORMAT('IMARCO = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IFIG,IPATT,ICOLB,ICOLP 9015 FORMAT('IFIG,IPATT,ICOLB,ICOLP = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)IBUGG4,ISUBG4,IERRG4 9019 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPFIPW(IHARG,IARGT,ARG,NUMARG,DEFFPW, 1FITPOW,IFOUND,IERROR) C C PURPOSE--DEFINE THE POWER IN THE FIT CRITERION C IN THE FIT COMMAND (AND THE PRE-FIT COMMAND). C THE SPECIFIED FIT POWER VALUE WILL BE PLACED C IN THE FLOATING POINT VARIABLE FITPOW. C NOTE--POWER = 2 YIELDS THE LEAST SQUARES CRITERION. C --POWER = 1 YIELDS THE L1 CRITERION. C --POWER = INFINITY YIELDS THE MINIMAX CRITERION. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --ARG (A FLOATING POINT VECTOR) C --NUMARG (AN INTEGER VARIABLE) C --DEFFPW (A FLOATING POINT VARIABLE) C OUTPUT ARGUMENTS--FITPOW (A FLOATING POINT VARIABLE) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--NOVEMBER 1980. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(NUMARG.EQ.0)GOTO1199 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'=')GOTO1199 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'POWE')GOTO1110 GOTO1199 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'POWE')GOTO1150 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 GOTO1120 C 1120 CONTINUE IERROR='YES' WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPFIPW--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' ILLEGAL FORM FOR FIT POWER ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1124) 1124 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1125) 1125 FORMAT(' SUPPOSE THE THE ANALYST WILL BE CARRYING OUT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1126) 1126 FORMAT(' A FIT , ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1127) 1127 FORMAT(' AND SUPPOSE THE ANALYST WISHES TO USE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1128) 1128 FORMAT(' POWER OF 1.5 IN THE FIT CRITERION; ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1130) 1130 FORMAT(' THEN THE ALLOWABLE FORM IS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1131) 1131 FORMAT(' FIT POWER 1.5 ') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE HOLD=DEFFPW GOTO1180 C 1160 CONTINUE HOLD=ARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' FITPOW=HOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)FITPOW 1181 FORMAT('THE FIT POWER HAS JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPFIRE(PX,PY,NP, 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP, 1IPATT2) C ABOVE LINE ADDED SEPTEMBER, 1987 C CONTAINS THE PATTERN FOR THE LINE (I.E., SOLID DASH, ETC.) C C C PURPOSE--FOR A GENERAL GRAPHICS DEVICE, C FILL THE REGION C DEFINED BY THE VERTICES AS GIVEN C IN THE PX(.) AND PY(.) VECTORS. C THIS REGION HAS SPECIFIED FILL PATTERN, C BACKGROUND COLOR, PATTERN LINE THICKNESS, C PATTERN LINE GAPCING, AND PATTERN COLOR. C C NOTE--THE COORDINATES IN (PX(.),PY(.)) ARE IN C STANDARDIZED (0.0 TO 100.0) UNITS. C NOTE--THERE ARE NP SUCH COORDINATE PAIRS. C (BUT NP SHOULD ALWAYS = 2 FOR THIS SUBROUTINE). C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--83.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C UPDATED --JANUARY 1989. ADDED PARAMETER TO CALL LIST (ALAN) C UPDATED --JANUARY 1989. MODIFY CALL TO GRFIRE (ALAN) C UPDATED --JANUARY 1989. BUGS FOR BAR PLOT COMMAND (ALAN) C UPDATED --MARCH 1990. MOVE CALL TO SEPA BEFORE COLOR C ROUTINES. EITHER SET PATTERN C OR FILL COLOR, BUT NOT BOTH (PATTERN C COLOR WAS OVER-RIDING FILL COLOR) C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 IFIG CHARACTER*4 IPATT CHARACTER*4 ICOL CHARACTER*4 ICOLF CHARACTER*4 ICOLP C CHARACTER*4 ICASE C CHARACTER*4 IHORPA CHARACTER*4 IVERPA CHARACTER*4 IDUPPA CHARACTER*4 IDDOPA C CHARACTER*4 IPATT2 C DIMENSION PX(*) DIMENSION PY(*) 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 C-----START POINT----------------------------------------------------- C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'FIRE')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPFIRE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NP 54 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NP WRITE(ICOUT,56)PX(I),PY(I) 56 FORMAT('PX(I),PY(I) = ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,61)IFIG 61 FORMAT('IFIG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)IPATT 62 FORMAT('IPATT = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)PTHICK 63 FORMAT('PTHICK = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)PXGAP,PYGAP 64 FORMAT('PXGAP,PYGAP = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,65)ICOLF 65 FORMAT('ICOLF = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,66)ICOLP 66 FORMAT('ICOLP = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4 69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C ICASE='REGI' C FOLLOWING BLOCK MOVED MARCH, 1990. PATTERN COLOR WAS C OVERRIDING FILL COLOR. DETERMINE WHICH ONE TO CALL C (EITHER PATTERN OR FILL, BUT NOT BOTH) C C ********************************************** C ** STEP X-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE FILL PATTERN ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C CALL GRTRPA(ICASE,IPATT,PXGAP,PYGAP, 1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXGAP2,PYGAP2) C C ******************************* C ** STEP X-- ** C ** SET THE FILL PATTERN ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CALL GRSEPA(ICASE,IPATT,PXGAP,PYGAP, 1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXGAP2,PYGAP2) C IF(IPATT.EQ.'SOLI')GOTO1099 IF(IPATT.EQ.'FILL')GOTO1099 GOTO1199 1099 CONTINUE C C ********************************************** C ** STEP 1-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE FILL COLOR ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C ICOL=ICOLF CALL GRTRCO(ICASE,ICOL,JCOL) JCOLF=JCOL C C ******************************* C ** STEP 2-- ** C ** SET THE FILL COLOR ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CALL GRSECO(ICASE,ICOL,JCOL) C FOLLOWING LINE ADDED MARCH 1990. GOTO1999 C C ********************************************** C ** STEP 3-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE FILL PATTERN ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C CCCCC CALL GRTRPA(ICASE,IPATT,PXGAP,PYGAP, CCCCC1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXGAP2,PYGAP2) C C ******************************* C ** STEP 4-- ** C ** SET THE FILL PATTERN ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CCCCC CALL GRSEPA(ICASE,IPATT,PXGAP,PYGAP, CCCCC1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXGAP2,PYGAP2) C C ********************************************** C ** STEP 5-- ** C ** TRANSLATE THE CHARACTER REPRESENTATION ** C ** OF THE PATTERN COLOR ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C CCCCC FOLLOWING LINE ADDED MARCH 1990. 1199 CONTINUE ICOL=ICOLP CALL GRTRCO(ICASE,ICOL,JCOL) JCOLP=JCOL C C ******************************* C ** STEP 6-- ** C ** SET THE PATTERN COLOR ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CALL GRSECO(ICASE,ICOL,JCOL) CCCCC FOLLOWING LINE ADDED MARCH 1990. 1999 CONTINUE C C ********************************************** C ** STEP 7-- ** C ** TRANSLATE THE DESIRED ** C ** LINE THICKNESS (OF THE PATTERN) ** C ** INTO A NUMERIC REPRESENTATION ** C ** WHICH CAN BE UNDERSTOOD BY THE ** C ** GRAPHICS DEVICE. ** C ********************************************** C CALL GRTRTH(ICASE,PTHICK,JTHICK,PTHIC2) C C ******************************* C ** STEP 8-- ** C ** SET THE LINE THICKNESS ** C ** (OF THE PATTERN) ** C ** ON THE GRAPHICS DEVICE. ** C ******************************* C CALL GRSETH(ICASE,PTHICK,JTHICK,PTHIC2) C C ********************* C ** STEP 11-- ** C ** FILL THE BOX ** C ********************* C CALL GRFIRE(PX,PY,NP,IFIG, 1IPATT,JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXGAP2,PYGAP2, 1PTHICK,JTHICK,PTHIC2, 1ICOLF,JCOLF,ICOLP,JCOLP, 1IPATT2) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'FIRE')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPFIRE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NP 9014 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NP WRITE(ICOUT,9016)PX(I),PY(I) 9016 FORMAT('PX(I),PY(I) = ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9021)IFIG 9021 FORMAT('IFIG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)IPATT,JPATT 9022 FORMAT('IPATT,JPATT = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9023)PTHICK,JTHICK,PTHIC2 9023 FORMAT('PTHICK,JTHICK,PTHIC2 = ',E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9024)PXGAP,PYGAP 9024 FORMAT('PXGAP,PYGAP = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9025)ICOLF,JCOLF 9025 FORMAT('ICOLF,JCOLF = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9026)ICOLP,JCOLP 9026 FORMAT('ICOLP,JCOLP = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4 9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPFISD(IHARG,IARGT,ARG,NUMARG,DEFFSD, 1FITSD,IFOUND,IERROR) C C PURPOSE--DEFINE THE LOWER BOUND FOR THE FIT STANDARD DEVIATION. C THE RESIDUAL STANDARD DEVIATION AFTER EACH C ITERATION OF A FIT WILL BE COMPARED C TO THE SPECIFIED FIT STANDARD DEVIATION. C THE SPECIFIED FIT STANDARD DEVIATION VALUE WILL BE PLACED C IN THE FLOATING POINT VARIABLE FITSD. C THE RESIDUAL STANDARD DEVIATION WILL BE C COMPARED TO THE FIT STANDARD DEVIATION VALUE. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --ARG (A FLOATING POINT VECTOR) C --NUMARG (AN INTEGER VARIABLE) C --DEFFSD (A FLOATING POINT VARIABLE) C OUTPUT ARGUMENTS--FITSD (A FLOATING POINT VARIABLE) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--NOVEMBER 1980. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(NUMARG.EQ.0)GOTO1199 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'=')GOTO1199 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'STAN'.AND. 1IHARG(2).EQ.'DEVI')GOTO1110 GOTO1199 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'DEVI')GOTO1150 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 GOTO1120 C 1120 CONTINUE IERROR='YES' WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPFISD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' ILLEGAL FORM FOR FIT STANDARD DEVIATION ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1124) 1124 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1125) 1125 FORMAT(' SUPPOSE THE THE ANALYST WILL BE CARRYING OUT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1126) 1126 FORMAT(' A NON-LINEAR FIT , ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1127) 1127 FORMAT(' AND SUPPOSE THE ANALYST WISHES TO TERMINATE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1128) 1128 FORMAT(' THE FIT ITERATIONS WHENEVER THE RESIDUAL ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1129) 1129 FORMAT(' STANDARD DEVIATION REACHES .0001 OR SMALLER; ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1130) 1130 FORMAT(' THEN THE ALLOWABLE FORM IS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1131) 1131 FORMAT(' FIT STANDARD DEVIATION .0001 ') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE HOLD=DEFFSD GOTO1180 C 1160 CONTINUE HOLD=ARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' FITSD=HOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)FITSD 1181 FORMAT('THE FIT STANDARD DEVIATION HAS JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPFITH(IHARG,IARGT,ARG,NUMARG,PDEFFT,MAXFIL,PFILTH, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE FILL THICKNESSES. C THESE ARE LOCATED IN THE VECTOR PFILTH(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --IARGT (A CHARACTER VECTOR) C --ARG C --NUMARG C --PDEFFT C --MAXFIL C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--PFILTH (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 C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG 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 PFILTH(*) 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 NUMFIL=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 DPFITH--') 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)MAXFIL,NUMFIL 53 FORMAT('MAXFIL,NUMFIL = ',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)PDEFFT 55 FORMAT('PDEFFT = ',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)PFILTH(1) 70 FORMAT('PFILTH(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,PFILTH(I) 76 FORMAT('I,PFILTH(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.0)GOTO9000 IF(NUMARG.EQ.1)GOTO1110 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 GOTO1140 C 1110 CONTINUE GOTO1200 C 1120 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=' ' IF(IHARG(2).EQ.'ALL')HOLD1=PDEFFT IF(IHARG(2).EQ.'ALL')GOTO1300 GOTO1200 C 1130 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(2).EQ.'ALL')HOLD1=ARG(3) IF(IHARG(2).EQ.'ALL')GOTO1300 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2) IF(IHARG(3).EQ.'ALL')HOLD1=ARG(2) IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE GOTO1200 C C ************************************************* C ** STEP 2-- ** C ** TREAT THE INDIVIDUAL SPECIFICATIONS CASE ** C ************************************************* C 1200 CONTINUE ISTEPN='2' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.1)GOTO1210 GOTO1220 C 1210 CONTINUE NUMFIL=1 PFILTH(1)=PDEFFT GOTO1270 C 1220 CONTINUE NUMFIL=NUMARG-1 IF(NUMFIL.GT.MAXFIL)NUMFIL=MAXFIL DO1225I=1,NUMFIL J=I+1 IHOLD1=IHARG(J) HOLD1=ARG(J) HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEFFT IF(IHOLD1.EQ.'OFF')HOLD2=PDEFFT IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFFT IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFFT PFILTH(I)=HOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMFIL WRITE(ICOUT,1276)I,PFILTH(I) 1276 FORMAT('FILL THICKNESS ',I6,' HAS JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') 1278 CONTINUE 1279 CONTINUE IFOUND='YES' GOTO9000 C C ************************** C ** STEP 2-- ** C ** TREAT THE ALL CASE ** C ************************** C 1300 CONTINUE ISTEPN='3' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMFIL=MAXFIL HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEFFT IF(IHOLD1.EQ.'OFF')HOLD2=PDEFFT IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFFT IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFFT DO1315I=1,NUMFIL PFILTH(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)PFILTH(I) 1316 FORMAT('ALL FILL THICKNESSES HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1319 CONTINUE IFOUND='YES' 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 DPFITH--') 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)MAXFIL,NUMFIL 9013 FORMAT('MAXFIL,NUMFIL = ',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)PDEFFT 9015 FORMAT('PDEFFT = ',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)PFILTH(1) 9030 FORMAT('PFILTH(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,PFILTH(I) 9036 FORMAT('I,PFILTH(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPFIWI(IHARG,IARGT,ARG,NUMARG,DEFFW, 1FILWID,IFOUND,IERROR) C C PURPOSE--DEFINE THE WIDTH (USUALLY INTEGER) OF THE FILTER C FOR A SMOOTHING OPERATION C FOR USE IN THE SMOOTH COMMAND. C THE SPECIFIED WIDTH WILL BE PLACED C IN THE FLOATING POINT VARIABLE FILWID. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --ARG (A HOLLERITH VECTOR) C --NUMARG (AN INTEGER VARIABLE) C --DEFFW (A FLOATING POINT VARIABLE) C OUTPUT ARGUMENTS--FILWID (A FLOATING POINT INTEGER 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--MAY 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) 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(NUMARG.EQ.1.AND.IHARG(1).EQ.'WIDT')GOTO1150 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 GOTO1120 C 1120 CONTINUE IERROR='YES' WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPFIWI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' ILLEGAL FORM FOR FILTER WIDTH ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1124) 1124 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1125) 1125 FORMAT(' SUPPOSE THE THE ANALYST WISHES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1126) 1126 FORMAT(' TO SET THE FILTER WIDTH = 7 OBSERVATIONS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1127) 1127 FORMAT(' FOR SOME SMOOTHING OPERATION,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1128) 1128 FORMAT(' THEN AN ALLOWABLE FORM IS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1129) 1129 FORMAT(' FILTER WIDTH 7 ') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE HOLD=DEFFW GOTO1180 C 1160 CONTINUE HOLD=ARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' FILWID=HOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)FILWID 1181 FORMAT('THE FILTER WIDTH HAS JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPFLTE(YTEMP,XTEMP,MAXNXT, 1IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) C C PURPOSE--CARRY OUT F TEST FOR SHIFT IN LOCATION C EXAMPLE--F LOCATION TEST Y X C REFERENCE--XX C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--97/9 C ORIGINAL VERSION--SEPTEMBER 1997. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ C CHARACTER*4 IH11 CHARACTER*4 IH12 CHARACTER*4 IH21 CHARACTER*4 IH22 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 IUSE1 CHARACTER*4 IUSE2 C CCCCC MAY 1995. ADD FOLLOWING DECLARATIONS CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IHOST1 CHARACTER*4 ISUBN0 C C--------------------------------------------------------------------- C DIMENSION YTEMP(*) DIMENSION XTEMP(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION YMEAN(MAXOBV) DIMENSION YBARIV(MAXOBV) DIMENSION DTAG(MAXOBV) C INCLUDE 'DPCOZZ.INC' EQUIVALENCE(GARBAG(IGARB1),YBARIV(1)) EQUIVALENCE(GARBAG(IGARB2),DTAG(1)) EQUIVALENCE(GARBAG(IGARB3),YMEAN(1)) 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='DPFL' ISUBN2='TE ' 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 N1=(-999) N2=(-999) C NS1=(-999) NS2=(-999) C IUSE1='-999' IUSE2='-999' C ILOCV=(-999) C VALUE1=(-999.0) VALUE2=(-999.0) C ICOL1=(-999) ICOL2=(-999) C MINN2=2 C IFOUND='YES' C NLEFT=0 C ICASEQ='UNKN' C C ************************************** C ** TREAT THE F LOCATION TEST CASE ** C ************************************** C IF(IBUGA2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPFLTE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA2,IBUGA3 52 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGQ 53 FORMAT('IBUGQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)MAXNXT 55 FORMAT('MAXNXT = ',I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=2 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C **************************************** C ** STEP 11-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS SHULD BE A VARIABLE.) ** C **************************************** C ISTEPN='11' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IH11=IHARG(1) IH12=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IH11,IH12,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) C IF(IERROR.EQ.'YES')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPFLTE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' FOR F LOCATION TEST,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1145) 1145 FORMAT(' BOTH ARGUMENTS MUST BE A VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1146) 1146 FORMAT(' (AS OPPOSED TO A PARAMETER OR FUNCTION).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1147) 1147 FORMAT(' ARGUMENT 1 WAS NOT A VARIABLE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1148) 1148 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1150)(IANS(I),I=1,IWIDTH) 1150 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C IUSE1=IUSE(ILOCV) ICOL1=IVALUE(ILOCV) N1=IN(ILOCV) 1190 CONTINUE C C ******************************************************* C ** STEP 12-- ** C ** IF ARGUMENT 1 IS A VARIABLE, ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (N1) ** C ** FOR ARGUMENT 1 IS 2 OR MORE. ** C ******************************************************* C ISTEPN='12' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IUSE1.NE.'V')GOTO1290 IF(N1.GE.MINN2)GOTO1290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** ERROR IN DPFLTE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212) 1212 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1213) 1213 FORMAT(' (FOR WHICH F LOCATION TEST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1214) 1214 FORMAT(' WAS TO HAVE BEEN CARRIED OUT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215)MINN2 1215 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1216) 1216 FORMAT(' SUCH WAS NOT THE CASE HERE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1217)IH11,IH12 1217 FORMAT(' FOR VARIABLE ',A4,A4,' WHICH HAD') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1218)N1 1218 FORMAT(' NUMBER OF OBSERVATIONS = ',I8,';') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1219) 1219 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1220)(IANS(I),I=1,IWIDTH) 1220 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1290 CONTINUE C C **************************************** C ** STEP 21-- ** C ** CHECK THE VALIDITY OF ARGUMENT 2 ** C ** (THIS SHOULD ALSO BE A VARIABLE) ** C **************************************** C ISTEPN='21' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IH21=IHARG(2) IH22=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IH21,IH22,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) C IF(IERROR.EQ.'YES')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2141) 2141 FORMAT('***** ERROR IN DPFLTE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2142) 2142 FORMAT(' FOR F LOCATION TEST,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2145) 2145 FORMAT(' BOTH ARGUMENTS MUST BE A VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2146) 2146 FORMAT(' (AS OPPOSED TO A PARAMETER OR FUNCTION).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2147) 2147 FORMAT(' ARGUMENT 2 WAS NOT A VARIABLE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2148) 2148 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2150)(IANS(I),I=1,IWIDTH) 2150 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C IUSE2=IUSE(ILOCV) ICOL2=IVALUE(ILOCV) N2=IN(ILOCV) 2190 CONTINUE C C ******************************************************** C ** STEP 22-- ** C ** IF ARGUMENT 2 IS A VARIABLE, ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (N2) ** C ** FOR ARGUMENT 2 IS THE SAME AS ARGUMENT 1. ** C ******************************************************** C ISTEPN='22' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IUSE2.NE.'V')GOTO2290 IF(N2.EQ.N1)GOTO2290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2211) 2211 FORMAT('***** ERROR IN DPFLTE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2212) 2212 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2213) 2213 FORMAT(' (FOR VARIABLE 2 OF F LOCATION TEST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2214) 2214 FORMAT(' MUST BE THE SAME AS VARIABLE 1') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2215) 2215 FORMAT(' SUCH WAS NOT THE CASE HERE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2216)N1,N2 2216 FORMAT(' N1 = ',I8,' N2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2219) 2219 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2220)(IANS(I),I=1,IWIDTH) 2220 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2290 CONTINUE C C ***************************************** C ** STEP 40-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='40' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO4090 DO4000J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO4010 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO4010 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO4020 4000 CONTINUE GOTO4090 4010 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO4090 4020 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO4090 4090 CONTINUE IF(IBUGA2.EQ.'OFF')GOTO4095 WRITE(ICOUT,4091)NUMARG,ILOCQ 4091 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 4095 CONTINUE C C *********************************************** C ** STEP 41-- ** C ** TEMPORARILY FORM THE VARIABLE Y(.) ** C ** WHICH WILL HOLD THE DATA FROM SAMPLE 1. ** C ** FORM THIS VARIABLE BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C *********************************************** C IF(IUSE1.NE.'V')GOTO4190 C ISTEPN='41' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO4110 IF(ICASEQ.EQ.'SUBS')GOTO4120 IF(ICASEQ.EQ.'FOR')GOTO4130 C 4110 CONTINUE DO4115I=1,N1 ISUB(I)=1 4115 CONTINUE NQ=N1 GOTO4150 C 4120 CONTINUE NIOLD=N1 CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO4150 C 4130 CONTINUE NIOLD=N1 CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO4150 C 4150 CONTINUE IF(NQ.GE.MINN2)GOTO4160 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4151) 4151 FORMAT('***** ERROR IN DPFLTE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4152) 4152 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4153)IH11,IH12 4153 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4154) 4154 FORMAT(' (FOR WHICH F LOCATION TEST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4155) 4155 FORMAT(' IS TO BE CARRIED OUT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4156)MINN2 4156 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4157)NQ 4157 FORMAT(' SUCH WAS NOT THE CASE HERE. (N = ',I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4158) 4158 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,4159)(IANS(I),I=1,IWIDTH) 4159 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 4160 CONTINUE J=0 IMAX=N1 IF(NQ.LT.N1)IMAX=NQ DO4170I=1,IMAX IF(ISUB(I).EQ.0)GOTO4170 J=J+1 C IJ=MAXN*(ICOL1-1)+I IF(ICOL1.LE.MAXCOL)Y(J)=V(IJ) IF(ICOL1.EQ.MAXCP1)Y(J)=PRED(I) IF(ICOL1.EQ.MAXCP2)Y(J)=RES(I) IF(ICOL1.EQ.MAXCP3)Y(J)=YPLOT(I) IF(ICOL1.EQ.MAXCP4)Y(J)=XPLOT(I) IF(ICOL1.EQ.MAXCP5)Y(J)=X2PLOT(I) IF(ICOL1.EQ.MAXCP6)Y(J)=TAGPLO(I) C 4170 CONTINUE NS1=J C 4190 CONTINUE C C *********************************************** C ** STEP 42-- ** C ** TEMPORARILY FORM THE VARIABLE X(.) ** C ** WHICH WILL HOLD THE DATA FROM SAMPLE 2. ** C ** FORM THIS VARIABLE BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C *********************************************** C IF(IUSE2.NE.'V')GOTO4290 C ISTEPN='42' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO4210 IF(ICASEQ.EQ.'SUBS')GOTO4220 IF(ICASEQ.EQ.'FOR')GOTO4230 C 4210 CONTINUE DO4215I=1,N2 ISUB(I)=1 4215 CONTINUE NQ=N2 GOTO4250 C 4220 CONTINUE NIOLD=N2 CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO4250 C 4230 CONTINUE NIOLD=N2 CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO4250 C 4250 CONTINUE IF(NQ.GE.MINN2)GOTO4260 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4251) 4251 FORMAT('***** ERROR IN DPFLTE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4252) 4252 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4253)IH21,IH22 4253 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4254) 4254 FORMAT(' (FOR WHICH F LOCATION TEST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4255) 4255 FORMAT(' IS TO BE CARRIED OUT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4256)MINN2 4256 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4257)NQ 4257 FORMAT(' SUCH WAS NOT THE CASE HERE. (N = ',I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4258) 4258 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,4259)(IANS(I),I=1,IWIDTH) 4259 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 4260 CONTINUE J=0 IMAX=N2 IF(NQ.LT.N2)IMAX=NQ DO4270I=1,IMAX IF(ISUB(I).EQ.0)GOTO4270 J=J+1 C IJ=MAXN*(ICOL2-1)+I IF(ICOL2.LE.MAXCOL)X(J)=V(IJ) IF(ICOL2.EQ.MAXCP1)X(J)=PRED(I) IF(ICOL2.EQ.MAXCP2)X(J)=RES(I) IF(ICOL2.EQ.MAXCP3)X(J)=YPLOT(I) IF(ICOL2.EQ.MAXCP4)X(J)=XPLOT(I) IF(ICOL2.EQ.MAXCP5)X(J)=X2PLOT(I) IF(ICOL2.EQ.MAXCP6)X(J)=TAGPLO(I) C 4270 CONTINUE NS2=J C 4290 CONTINUE C C ********************************* C ** STEP 52-- ** C ** DO F LOCATION TEST ** C ********************************* C ISTEPN='52' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'OFF')GOTO5290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5211) 5211 FORMAT('***** FROM DPFLTE, AS WE ARE ABOUT TO CALL DPFLT2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5212)N1,N2,NS1,NS2,MAXN 5212 FORMAT('N1,N2,NS1,NS2,MAXN = ',5I8) CALL DPWRST('XXX','BUG ') DO5215I=1,NS1 WRITE(ICOUT,5216)I,Y(I) 5216 FORMAT('I,Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 5215 CONTINUE DO5217I=1,NS1 WRITE(ICOUT,5218)I,Y(I) 5218 FORMAT('I,Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 5217 CONTINUE CCCCC IBUGA3='ABCD' WRITE(ICOUT,5231)IBUGA3 5231 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') 5290 CONTINUE C CALL DPFLT2(Y,X,NS1, 1YTEMP,XTEMP,YMEAN,YBARIV,DTAG,MAXNXT, 1STATVA,STATCD,CUT0,CUT50,CUT75,CUT90,CUT95,CUT99,CUT999, 1IBUGA3,IERROR) C C *************************************** C ** STEP 61-- ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C ISTEPN='61' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ISUBN0='DPLT' C IH='STAT' IH2='VAL ' VALUE0=STATVA CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='STAT' IH2='CDF ' VALUE0=STATCD CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF0 ' VALUE0=CUT0 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF50' VALUE0=CUT50 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF75' VALUE0=CUT75 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF90' VALUE0=CUT90 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF95' VALUE0=CUT95 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF99' VALUE0=CUT99 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='F999' VALUE0=CUT99 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPFLTE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA2,IBUGA3 9012 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGQ 9013 FORMAT('IBUGQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NLEFT,NS 9014 FORMAT('NLEFT,NS = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)ICASEQ 9015 FORMAT('ICASEQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)IFOUND,IERROR 9016 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPFLT2(Y,TAG,N, 1YTEMP,XTEMP,YMEAN,YBARIV,DTAG,MAXNXT, 1STATVA,STATCD,CUT0,CUT50,CUT75,CUT90,CUT95,CUT99,CUT999, 1IBUGA3,IERROR) C C PURPOSE--THIS ROUTINE CARRIES OUT AN F TEST FOR SHIFT IN LOCATION C EXAMPLE--F LOCATION'S TEST Y TAG C REFERENCE--XX C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--97/9 C ORIGINAL VERSION--SEPTEMBER 1997. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IWRITE C CHARACTER*6 ICONC1 CHARACTER*6 ICONC2 CHARACTER*6 ICONC3 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C DOUBLE PRECISION DSUM1 C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION TAG(*) DIMENSION DTAG(*) DIMENSION YTEMP(*) DIMENSION XTEMP(*) DIMENSION YMEAN(*) DIMENSION YBARIV(*) 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='DPBT' ISUBN2='E2 ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,51) 51 FORMAT('**** AT THE BEGINNING OF DPFLT2--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,55)N 55 FORMAT('N = ',I8) CALL DPWRST('XXX','WRIT') DO56I=1,N WRITE(ICOUT,57)I,Y(I) 57 FORMAT('I,Y(I) = ',I8,E15.7) CALL DPWRST('XXX','WRIT') 56 CONTINUE WRITE(ICOUT,65)N 65 FORMAT('N = ',I8) CALL DPWRST('XXX','WRIT') DO66I=1,N WRITE(ICOUT,67)I,TAG(I) 67 FORMAT('I,TAG(I) = ',I8,E15.7) CALL DPWRST('XXX','WRIT') 66 CONTINUE 90 CONTINUE C C ******************************************** C ** STEP 11-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C ISTEPN='11' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(N.GE.1)GOTO1119 WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1111) 1111 FORMAT('***** ERROR IN DPFLT2--THE NUMBER OF OBSERVATIONS ', 1'FOR VARIABLE 1 IS NON-POSITIVE') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1112)N 1112 FORMAT('SAMPLE SIZE = ',I8) CALL DPWRST('XXX','WRIT') IERROR='YES' GOTO9000 1119 CONTINUE C IF(N.EQ.1)GOTO1120 GOTO1129 1120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1121) 1121 FORMAT('***** NOTE FROM DPFLT2--VARIABLE 1 ', 1'HAS ONLY 1 ELEMENT') CALL DPWRST('XXX','WRIT') GOTO9000 1129 CONTINUE C HOLD=Y(1) DO1135I=2,N IF(Y(I).NE.HOLD)GOTO1139 1135 CONTINUE 1130 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1131)HOLD 1131 FORMAT('***** NOTE FROM DPFLT2--VARIABLE 1 ', 1'HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','WRIT') GOTO9000 1139 CONTINUE C IF(N.GE.1)GOTO1219 WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1211) 1211 FORMAT('***** ERROR IN DPFLT2--THE NUMBER OF OBSERVATIONS ', 1'FOR VARIABLE 2 IS NON-POSITIVE') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1212)N 1212 FORMAT('SAMPLE SIZE = ',I8) CALL DPWRST('XXX','WRIT') IERROR='YES' GOTO9000 1219 CONTINUE C IF(N.EQ.1)GOTO1220 GOTO1229 1220 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1221) 1221 FORMAT('***** NOTE FROM DPFLT2--VARIABLE 2 ', 1'HAS ONLY 1 ELEMENT') CALL DPWRST('XXX','WRIT') GOTO9000 1229 CONTINUE C HOLD=TAG(1) DO1235I=2,N IF(TAG(I).NE.HOLD)GOTO1239 1235 CONTINUE 1230 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1231)HOLD 1231 FORMAT('***** NOTE FROM DPFLT2--VARIABLE 2 ', 1'HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','WRIT') GOTO9000 1239 CONTINUE C 1290 CONTINUE C C ****************************** C ** STEP 41-- ** C ** CARRY OUT CALCULATIONS ** C ** FOR F LOCATION TEST ** C ****************************** C 4100 CONTINUE C ISTEPN='41' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IWRITE='OFF' CALL DISTIN(TAG,N,IWRITE,DTAG,NUMDIS,IBUGA3,IERROR) C CALL MEAN(Y,N,IWRITE,YBAR,IBUGA3,IERROR) C IF(IBUGA3.EQ.'ON')THEN WRITE(ICOUT,4901)YBAR 4901 FORMAT('YBAR = ',G15.7) CALL DPWRST('XXX','BUG') DO4905I=1,N WRITE(ICOUT,4906)I,TAG(I),DTAG(I),Y(I) 4906 FORMAT('I,TAG(I),DTAG(I),Y(I)=',I8,3G15.7) CALL DPWRST('XXX','BUG') 4905 CONTINUE ENDIF C DO5200IDIS=1,NUMDIS J=0 DO5300I=1,N IF(TAG(I).EQ.DTAG(IDIS))THEN J=J+1 YTEMP(J)=Y(I) ENDIF 5300 CONTINUE CALL MEAN(YTEMP,J,IWRITE,YMEAN(IDIS),IBUGA3,IERROR) DO5400I=1,N IF(TAG(I).EQ.DTAG(IDIS))YBARIV(I)=YMEAN(IDIS) 5400 CONTINUE 5200 CONTINUE C IF(IBUGA3.EQ.'ON')THEN DO5205I=1,N WRITE(ICOUT,5206)I,TAG(I),DTAG(I),YBARIV(I) 5206 FORMAT('I,TAG(I),DTAG(I),YBARIV(I)=',I8,3G15.7) CALL DPWRST('XXX','BUG') 5205 CONTINUE ENDIF C DSUM1=0.D0 DO6100I=1,N DSUM1=DSUM1 + (YBARIV(I)-YBAR)**2 6100 CONTINUE SSQ=SNGL(DSUM1) NUMDF=NUMDIS-1 ANUMMS=SSQ/REAL(NUMDF) C DSUM1=0.D0 DO6200I=1,N DSUM1=DSUM1 + (Y(I)-YBARIV(I))**2 6200 CONTINUE SSQ=SNGL(DSUM1) IDENDF=N-NUMDIS DENMS=SSQ/REAL(IDENDF) C IF(IBUGA3.EQ.'ON')THEN WRITE(ICOUT,6201)ANUMMS,DENMS 6201 FORMAT('ANUMMS,DENMS=',2G15.7) CALL DPWRST('XXX','BUG') ENDIF C STATVA=ANUMMS/DENMS CALL FCDF(STATVA,NUMDF,IDENDF,STATCD) C KM1=NUMDIS-1 NMK=N-NUMDIS C CUT0=0.0 CALL FPPF(.50,KM1,NMK,CUT50) CALL FPPF(.75,KM1,NMK,CUT75) CALL FPPF(.90,KM1,NMK,CUT90) CALL FPPF(.95,KM1,NMK,CUT95) CALL FPPF(.99,KM1,NMK,CUT99) CALL FPPF(.999,KM1,NMK,CUT999) C ICONC1='REJECT' ICONC2='REJECT' ICONC3='REJECT' C IF(0.000.LE.STATCD.AND.STATCD.LE.0.950)ICONC2='ACCEPT' C C ****************************** C ** STEP 42-- ** C ** WRITE OUT EVERYTHING ** C ** FOR F LOCATION'S TEST ** C ****************************** C ISTEPN='42' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'OFF')GOTO7290 WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7211) 7211 FORMAT(' F-TEST FOR SHIFT IN LOCATION') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7212) 7212 FORMAT(' (ASSUMPTION: NORMALITY)') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,7222) 7222 FORMAT('1. STATISTICS') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7224)N 7224 FORMAT(6X,'NUMBER OF OBSERVATIONS = ',I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7226)NUMDIS 7226 FORMAT(6X,'NUMBER OF GROUPS = ',I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7228)STATVA 7228 FORMAT(6X,'F LOCATION TEST STATISTIC = ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7240) WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') 7240 FORMAT('2. PERCENT POINTS OF THE REFERENCE DISTRIBUTION') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7241) 7241 FORMAT(' FOR F LOCATION TEST STATISTIC') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,7345)CUT0 7345 FORMAT(6X,'0 % POINT = ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7346)CUT50 7346 FORMAT(6X,'50 % POINT = ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7347)CUT75 7347 FORMAT(6X,'75 % POINT = ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7348)CUT90 7348 FORMAT(6X,'90 % POINT = ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7349)CUT95 7349 FORMAT(6X,'95 % POINT = ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7350)CUT99 7350 FORMAT(6X,'99 % POINT = ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7351)CUT999 7351 FORMAT(6X,'99.9 % POINT = ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7247)100.*STATCD,STATVA 7247 FORMAT(6X,G15.7,' % Point: ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,7261) 7261 FORMAT('3. CONCLUSION (AT THE 5% LEVEL):') CALL DPWRST('XXX','WRIT') IF(STATVA.LE.CUT95)THEN WRITE(ICOUT,7262) 7262 FORMAT(6X,'THERE IS NO SHIFT IN LOCATION.') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7263) 7263 FORMAT(6X,'THUS: HOMOGENOUS WITH RESPECT TO LOCATION.') CALL DPWRST('XXX','WRIT') ELSE WRITE(ICOUT,7272) 7272 FORMAT(6X,'THERE IS A SHIFT IN LOCATION.') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7273) 7273 FORMAT(6X,'THUS: NOT HOMOGENOUS WITH RESPECT TO LOCATION.') CALL DPWRST('XXX','WRIT') ENDIF WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') 7290 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPFLT2--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,9012)N,IBUGA3,IERROR 9012 FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,9015)N 9015 FORMAT('N = ',I8) CALL DPWRST('XXX','WRIT') DO9016I=1,N WRITE(ICOUT,9017)I,Y(I) 9017 FORMAT('I,Y(I) = ',I8,E15.7) CALL DPWRST('XXX','WRIT') 9016 CONTINUE WRITE(ICOUT,9025)N 9025 FORMAT('N = ',I8) CALL DPWRST('XXX','WRIT') DO9026I=1,N WRITE(ICOUT,9027)I,TAG(I) 9027 FORMAT('I,TAG(I) = ',I8,E15.7) CALL DPWRST('XXX','WRIT') 9026 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPFONT(IHARG,NUMARG, 1IDEFFO, 1ITEXFO, 1IBUGD2,ISUBRO,IFOUND,IERROR) C C PURPOSE--DEFINE THE FONT TYPE FOR C TITLE, LABEL, AND LEGEND SCRIPT C ON A PLOT. C THE FONT FOR THE SCRIPT WILL BE PLACED C IN THE CHARACTER VARIABLE ITEXFO. C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEFFO C --IBUGD2 C OUTPUT ARGUMENTS--ITEXFO 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--SEPTEMBER 1980. C UPDATED --APRIL 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFFO CHARACTER*4 ITEXFO CHARACTER*4 IBUGD2 CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(IBUGD2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPFONT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IDEFFO 53 FORMAT('IDEFFO = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NUMARG 54 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NUMARG WRITE(ICOUT,56)I,IHARG(I) 56 FORMAT('I,IHARG(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C *************************** C ** TREAT THE FONT CASE ** C *************************** C 1110 CONTINUE IF(NUMARG.LE.0)GOTO1120 IF(IHARG(NUMARG).EQ.'ON')GOTO1120 IF(IHARG(NUMARG).EQ.'OFF')GOTO1120 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1120 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1120 IF(IHARG(NUMARG).EQ.'?')GOTO8100 GOTO1140 C 1120 CONTINUE ITEXFO=IDEFFO GOTO1180 C 1140 CONTINUE IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'SIMP')GOTO1141 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'DUPL')GOTO1142 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'TRIP')GOTO1143 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'COMP')GOTO1144 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'TRIP'.AND. 1IHARG(2).EQ.'ITAL')GOTO1145 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'TRII')GOTO1145 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'COMP'.AND. 1IHARG(2).EQ.'ITAL')GOTO1146 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'COMI')GOTO1146 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SIMP'.AND. 1IHARG(2).EQ.'SCRI')GOTO1147 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'SIMS')GOTO1147 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'COMP'.AND. 1IHARG(2).EQ.'SCRI')GOTO1148 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'COMS')GOTO1148 C IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEKT')GOTO1151 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEK')GOTO1151 C IF(NUMARG.GE.2.AND.IHARG(1).EQ.'HEWL'.AND. 1IHARG(2).EQ.'PACK')GOTO1152 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'HP')GOTO1152 C 1130 CONTINUE IERROR='YES' WRITE(ICOUT,1131) 1131 FORMAT('***** ERROR IN DPFONT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1132) 1132 FORMAT(' ILLEGAL ENTRY FOR FONT ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1133) 1133 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1134) 1134 FORMAT(' SUPPOSE THE THE ANALYST WISHES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1135) 1135 FORMAT(' TO SET THE FONT TO TRIPLEX ITALIC ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1136) 1136 FORMAT(' FOR PLOT TITLES, LABELS, ETC.,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1137) 1137 FORMAT(' THEN 2 ALLOWABLE FORMS ARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1138) 1138 FORMAT(' FONT TRIPLEX ITALIC ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1139) 1139 FORMAT(' FONT TRII ') CALL DPWRST('XXX','BUG ') GOTO9000 C 1141 CONTINUE ITEXFO='SIMP' GOTO1180 C 1142 CONTINUE ITEXFO='DUPL' GOTO1180 C 1143 CONTINUE ITEXFO='TRIP' GOTO1180 C 1144 CONTINUE ITEXFO='COMP' GOTO1180 C 1145 CONTINUE ITEXFO='TRII' GOTO1180 C 1146 CONTINUE ITEXFO='COMI' GOTO1180 C 1147 CONTINUE ITEXFO='SIMS' GOTO1180 C 1148 CONTINUE ITEXFO='COMS' GOTO1180 C 1151 CONTINUE ITEXFO='TEKT' GOTO1180 C 1152 CONTINUE ITEXFO='HEWL' GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE FONT (FOR PLOT SCRIPT AND TEXT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)ITEXFO 1182 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO9000 C C ******************************************** C ** STEP 81-- ** C ** TREAT THE ? CASE-- ** C ** DUMP OUT CURRENT AND DEFAULT VALUES. ** C ******************************************** C 8100 CONTINUE IFOUND='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8111)ITEXFO 8111 FORMAT('THE CURRENT FONT IS ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8112)IDEFFO 8112 FORMAT('THE DEFAULT FONT IS ',A4) CALL DPWRST('XXX','BUG ') GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGD2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPFONT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IDEFFO,ITEXFO 9013 FORMAT('IDEFFO,ITEXFO = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPFOR(NIOLD,NINEW,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) C C PURPOSE--DEFINE AN INTEGER 0-1 VECTOR ISUB C WHICH WILL BE USED IN OTHER SUBROUTINES C FOR EXTRACTING SUBSETS. C ALLOWABLE FORMS--FOR XX < XX C FOR XX <= XX C FOR XX = XX C FOR XX = XX XX XX C FOR XX = XX TO XX C FOR XX >= XX C FOR XX > XX C INPUT ARGUMENTS--NIOLD = THE ORIGINAL NUMBER OF C ELEMENTS (ROWS) FOR THE LEFT-SIDE VARIABLE. C (IT MAY BE ZERO). C OUTPUT ARGUMENTS--NINEW = THE NEW NUMBER OF ELEMENTS (ROWS) C FOR THE LEFT-SIDE VARIABLE. C NINEW EQUALS MAX(NIOLD,IROWN) C --IROW1 = THE FIRST ROW TO BE CHANGED. C --IROWN = THE LAST ROW TO BE CHANGED. C NOTE THAT IF THE WORD 'FOR' IS NOT IN THE ARGUMENT LIST, C THEN THE OUTPUT PARAMETER WILL BE SET TO NUMARG+1. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--JANUARY 1978. C UPDATED --JANUARY 1978. C UPDATED --FEBRUARY 1978. C UPDATED --JULY 1978. C UPDATED --OCTOBER 1978. C UPDATED --NOVEMBER 1978. C UPDATED --NOVEMBER 1980. C UPDATED --JANUARY 1981. C UPDATED --JULY 1981. C UPDATED --SEPTEMBER 1981. C UPDATED --OCTOBER 1981. C UPDATED --DECEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGQ CHARACTER*4 IERROR C CHARACTER*4 MESSAG CHARACTER*4 IHWUSE CHARACTER*4 IH CHARACTER*4 IH2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPFO' ISUBN2='R ' C IERROR='NO' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C ILOCF=0 NUMIT=0 I2=0 C C ************************** C ** TREAT THE FOR CASE ** C ************************** C IF(IBUGQ.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPFOR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NIOLD,NINEW,IROW1,IROWN 52 FORMAT('NIOLD,NINEW,IROW1,IROWN = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NLOCAL,ILOCS,NS 53 FORMAT('NLOCAL,ILOCS,NS = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGQ,IERROR 54 FORMAT('IBUGQ,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)NUMARG,NUMNAM,MAXNAM,N,MAXN 55 FORMAT('NUMARG,NUMNAM,MAXNAM,N,MAXN = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)IWIDTH,NLOCAL,ILOCF 56 FORMAT('IWIDTH,NLOCAL,ILOCF = ',3I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C **************************************************************** C ** STEP 1-- C ** INITIALIZE THE SUBSET SIZE (NS) TO MAXN. C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. C ** ALSO CHECK THAT THE RELEVANT NUMBER OF OBSERVATIONS (NLOCAL) C ** IS POSITIVE. C **************************************************************** C ISTEPN='1' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NLOCAL=MAXN NS=MAXN ILOCF=NUMARG+1 MINNA=0 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IF(NLOCAL.GE.1)GOTO190 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN DPFOR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' (FROM WHICH A SUBSET WAS TO HAVE BEEN ', 1'EXTRACTED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' IS 0') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 190 CONTINUE C C ************************************************* C ** STEP 2-- ** C ** INITIALIZE ALL ELEMENTS IN ISUB(.) TO 1 . ** C ************************************************* C ISTEPN='2' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO200I=1,NLOCAL ISUB(I)=1 200 CONTINUE C C ************************************************ C ** STEP 3.1-- ** C ** CHECK TO SEE IF HAVE THE 'FOR' CASE. ** C ** LOCATE THE POSITION IN THE ARGUMENT LIST ** C ** OF THE LAST OCCURRANCE OF THE WORD 'FOR'. ** C ************************************************ C ISTEPN='3.1' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ILOCF=-1 IF(NUMARG.LE.0)GOTO9000 DO300J=1,NUMARG JP1=J+1 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' '.AND. 1IHARG(JP1).EQ.'I '.AND.IHARG2(JP1).EQ.' '.AND. 1JP1.LE.NUMARG)GOTO350 GOTO300 350 CONTINUE ILOCF=J 300 CONTINUE IF(ILOCF.EQ.-1)GOTO360 GOTO390 360 CONTINUE ILOCF=NUMARG+1 GOTO9000 390 CONTINUE C C ************************************************* C ** STEP 3.2-- ** C ** IF EXISTENT, ** C ** PACK < = INTO <= ** C ** PACK = < INTO =< ** C ** PACK > = INTO >= ** C ** PACK = > INTO => ** C ** THIS IS BECAUSE = SIGNS ARE AUTOMATICALLY ** C ** GIVEN A SPACE IN DPTYPE AND TREATED AS ** C ** AS A SEPARATE WORD. ** C ** NOTE THAT NUMARG WILL BE CHANGED. ** C ************************************************* C ISTEPN='3.2' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL ADJUS2(IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) C C *********************************************** C ** STEP 4-- ** C ** CHECK THAT FOR IS SUCCEEDED BY AT LEAST ** C ** 3 OTHER ARGUMENTS. ** C *********************************************** C ISTEPN='4' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ILOCF3=ILOCF+3 IF(ILOCF3.GT.NUMARG)GOTO400 GOTO480 400 CONTINUE WRITE(ICOUT,401) 401 FORMAT('***** ERROR IN DPFOR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,402) 402 FORMAT(' THE WORD FOR SHOULD HAVE BEEN FOLLOWED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,403) 403 FORMAT(' BY EXACTLY 3 OR BY EXACTLY 5 WORDS --') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,404) 404 FORMAT(' 1) A DUMMY VARIABLE NAME;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,405) 405 FORMAT(' 2) AN EQUAL SIGN;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,406) 406 FORMAT(' 3) ONE LIMIT (LOWER OR UPPER) ', 1'FOR THE DUMMY VARIABLE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,409) 409 FORMAT(' 4) THE INCREMENT FOR THE DUMMY VARIABLE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,410) 410 FORMAT(' 5) THE OTHER LIMIT (UPPER OR LOWER) ', 1'FOR THE DUMMY VARIABLE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,421) 421 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,422)(IANS(I),I=1,IWIDTH) 422 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 480 CONTINUE C C ************************************* C ** STEP 5-- ** C ** FORM THE 3 INTERNAL VALUES-- ** C ** START, AINC, AND STOP. ** C ************************************* C ISTEPN='5' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ILOCF2=ILOCF+2 ILOCF3=ILOCF+3 ILOCF4=ILOCF+4 ILOCF5=ILOCF+5 C ILOCA=ILOCF3 IF(IARGT(ILOCA).EQ.'NUMB')GOTO511 IF(IARGT(ILOCA).EQ.'WORD')GOTO512 GOTO570 511 CONTINUE START=ARG(ILOCA) IF(IHARG(ILOCF2).EQ.'= ')GOTO519 AINC=0.0 STOP=ARG(ILOCA) IF(IHARG(ILOCF2).EQ.'< ')START=1.0 IF(IHARG(ILOCF2).EQ.'< ')AINC=1.0 IF(IHARG(ILOCF2).EQ.'< ')STOP=ARG(ILOCA)-1.0 IF(IHARG(ILOCF2).EQ.'< ')GOTO539 IF(IHARG(ILOCF2).EQ.'<= ')START=1.0 IF(IHARG(ILOCF2).EQ.'<= ')AINC=1.0 IF(IHARG(ILOCF2).EQ.'<= ')STOP=ARG(ILOCA) IF(IHARG(ILOCF2).EQ.'<= ')GOTO539 IF(IHARG(ILOCF2).EQ.'=< ')START=1.0 IF(IHARG(ILOCF2).EQ.'=< ')AINC=1.0 IF(IHARG(ILOCF2).EQ.'=< ')STOP=ARG(ILOCA) IF(IHARG(ILOCF2).EQ.'=< ')GOTO539 IF(IHARG(ILOCF2).EQ.'>= ')START=ARG(ILOCA) IF(IHARG(ILOCF2).EQ.'>= ')AINC=1.0 IF(IHARG(ILOCF2).EQ.'>= ')STOP=NIOLD IF(IHARG(ILOCF2).EQ.'>= ')GOTO539 IF(IHARG(ILOCF2).EQ.'=> ')START=ARG(ILOCA) IF(IHARG(ILOCF2).EQ.'=> ')AINC=1.0 IF(IHARG(ILOCF2).EQ.'=> ')STOP=NIOLD IF(IHARG(ILOCF2).EQ.'=> ')GOTO539 IF(IHARG(ILOCF2).EQ.'> ')START=ARG(ILOCA)+1.0 IF(IHARG(ILOCF2).EQ.'> ')AINC=1.0 IF(IHARG(ILOCF2).EQ.'> ')STOP=NIOLD IF(IHARG(ILOCF2).EQ.'> ')GOTO539 GOTO519 512 CONTINUE IH=IHARG(ILOCA) IH2=IHARG2(ILOCA) MESSAG='YES' IHWUSE='P' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 START=VALUE(ILOC) IF(IHARG(ILOCF2).EQ.'= ')GOTO519 AINC=0.0 STOP=VALUE(ILOC) IF(IHARG(ILOCF2).EQ.'< ')START=1.0 IF(IHARG(ILOCF2).EQ.'< ')AINC=1.0 IF(IHARG(ILOCF2).EQ.'< ')STOP=VALUE(ILOC)-1.0 IF(IHARG(ILOCF2).EQ.'< ')GOTO539 IF(IHARG(ILOCF2).EQ.'<= ')START=1.0 IF(IHARG(ILOCF2).EQ.'<= ')AINC=1.0 IF(IHARG(ILOCF2).EQ.'<= ')STOP=VALUE(ILOC) IF(IHARG(ILOCF2).EQ.'<= ')GOTO539 IF(IHARG(ILOCF2).EQ.'=< ')START=1.0 IF(IHARG(ILOCF2).EQ.'=< ')AINC=1.0 IF(IHARG(ILOCF2).EQ.'=< ')STOP=VALUE(ILOC) IF(IHARG(ILOCF2).EQ.'=< ')GOTO539 IF(IHARG(ILOCF2).EQ.'>= ')START=VALUE(ILOC) IF(IHARG(ILOCF2).EQ.'>= ')AINC=1.0 IF(IHARG(ILOCF2).EQ.'>= ')STOP=NIOLD IF(IHARG(ILOCF2).EQ.'>= ')GOTO539 IF(IHARG(ILOCF2).EQ.'=> ')START=VALUE(ILOC) IF(IHARG(ILOCF2).EQ.'=> ')AINC=1.0 IF(IHARG(ILOCF2).EQ.'=> ')STOP=NIOLD IF(IHARG(ILOCF2).EQ.'=> ')GOTO539 IF(IHARG(ILOCF2).EQ.'> ')START=VALUE(ILOC)+1.0 IF(IHARG(ILOCF2).EQ.'> ')AINC=1.0 IF(IHARG(ILOCF2).EQ.'> ')STOP=NIOLD IF(IHARG(ILOCF2).EQ.'> ')GOTO539 519 CONTINUE C ILOCA=ILOCF4 IF(ILOCA.GT.NUMARG)GOTO521 IF(ILOCA.EQ.NUMARG.AND.IHARG(ILOCA).EQ.'AND'.AND. 1IHARG2(ILOCA).EQ.' ')GOTO521 IF(IARGT(ILOCA).EQ.'NUMB')GOTO522 IF(IARGT(ILOCA).EQ.'WORD'.AND.IHARG(ILOCA).EQ.'TO ')GOTO523 IF(IARGT(ILOCA).EQ.'WORD'.AND.IHARG(ILOCA).NE.'TO ')GOTO524 GOTO570 521 CONTINUE AINC=0.0 GOTO529 522 CONTINUE AINC=ARG(ILOCA) GOTO529 523 CONTINUE AINC=1.0 GOTO529 524 CONTINUE IH=IHARG(ILOCA) IH2=IHARG2(ILOCA) MESSAG='YES' IHWUSE='P' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 AINC=VALUE(ILOC) GOTO529 529 CONTINUE C ILOCA=ILOCF5 IF(ILOCA.GT.NUMARG)GOTO531 IF(ILOCA.EQ.NUMARG.AND.IHARG(ILOCA).EQ.'AND'.AND. 1IHARG2(ILOCA).EQ.' ')GOTO531 IF(IARGT(ILOCA).EQ.'NUMB')GOTO532 IF(IARGT(ILOCA).EQ.'WORD')GOTO533 GOTO570 531 CONTINUE STOP=START GOTO539 532 CONTINUE STOP=ARG(ILOCA) GOTO539 533 CONTINUE IH=IHARG(ILOCA) IH2=IHARG2(ILOCA) MESSAG='YES' IHWUSE='P' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 STOP=VALUE(ILOC) GOTO539 539 CONTINUE GOTO580 C 570 CONTINUE WRITE(ICOUT,571) 571 FORMAT('***** INTERNAL ERROR IN DPFOR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,572) 572 FORMAT(' AN ARGUMENT TYPE WHICH SHOULD BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,573) 573 FORMAT(' EITHER A NUMBER OR A WORD, IS NEITHER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,574)IHARG(ILOCA),IHARG2(ILOCA) 574 FORMAT(' ARGUMENT = ',2A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,575)ILOCA 575 FORMAT(' LOCATION IN ARGUMENT LIST = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,576)IARGT(ILOCA) 576 FORMAT(' ARGUMENT TYPE = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,577) 577 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,578)(IANS(I),I=1,IWIDTH) 578 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 580 CONTINUE IF(START.EQ.STOP)AINC=0.0 IF(START.LT.STOP.AND.AINC.LT.0.0)AINC=-AINC IF(START.GT.STOP.AND.AINC.GT.0.0)AINC=-AINC C C ***************************************************** C ** STEP 6-- ** C ** FORM THE ISUB(.) VECTOR; ** C ** DETERMINE ALSO-- ** C ** THE FIRST ROW CHANGED (IROW1), ** C ** THE ROW INCREMENT (IROWIN), ** C ** THE LAST ROW CHANGED (IROWN), ** C ** THE NUMBER OF ROWS CHANGED (NS), ** C ** AND THE OUTPUT NUMBER OF ROWS (NINEW). ** C ** (THAT IS, THE SUBSET SAMPLE SIZE). ** C ***************************************************** C ISTEPN='6' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO600I=1,MAXN ISUB(I)=0 600 CONTINUE C IF(AINC.EQ.0.0)NUMIT=1 IF(AINC.NE.0.0)NUMIT=(STOP-START)/AINC IF(NUMIT.LT.0)NUMIT=-NUMIT NUMIT=NUMIT+1 C L2=0 DO620I=1,NUMIT I2=I I2M1=I2-1 AI=I RESULT=START+(AI-1.0)*AINC IF(I.EQ.1)GOTO622 IF(AINC.EQ.0.0)GOTO670 IF(START.EQ.STOP)GOTO670 IF(START.LT.STOP.AND.RESULT.GT.STOP)GOTO670 IF(START.GT.STOP.AND.RESULT.LT.STOP)GOTO670 622 CONTINUE L2=L2+1 C IF(L2.LE.MAXN)GOTO639 WRITE(ICOUT,632) 632 FORMAT('***** ERROR IN DPFOR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,633) 633 FORMAT(' THE NUMBER OF GENERATED POINTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,634)MAXN 634 FORMAT(' HAS JUST EXCEEDED ',I8,' *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,635) 635 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,636)(IANS(K),K=1,IWIDTH) 636 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 639 CONTINUE C XTEMP=RESULT ITEMP=XTEMP+0.5 IF(ITEMP.LE.MAXN)GOTO649 WRITE(ICOUT,642) 642 FORMAT('***** ERROR IN DPFOR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,643) 643 FORMAT(' A REFERENCED ROW NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,644)MAXN 644 FORMAT(' HAS JUST EXCEEDED ',I8,' *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,645) 645 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,646)(IANS(K),K=1,IWIDTH) 646 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 649 CONTINUE C IF(ITEMP.GE.1)GOTO659 WRITE(ICOUT,652) 652 FORMAT('***** ERROR IN DPFOR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,653) 653 FORMAT(' A REFERENCED ROW NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,654) 654 FORMAT(' IS SMALLER THAN 1 .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,655) 655 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,656)(IANS(K),K=1,IWIDTH) 656 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 659 CONTINUE C ISUB(ITEMP)=1.0 IF(I.EQ.1)IROW1=ITEMP IROWN=ITEMP 620 CONTINUE C NS=I2 GOTO690 670 CONTINUE NS=I2M1 690 CONTINUE NINEW=NIOLD IF(IROWN.GT.NIOLD)NINEW=IROWN IROWIN=AINC+0.5 C C ************************************************* C ** STEP 7-- ** C ** WRITE OUT A MESSAGE INDICATING ** C ** THE FIRST ROW CHANGED (IROW1), ** C ** THE ROW INCREMENT (IROWIN), ** C ** THE LAST ROW CHANGED (IROWN), ** C ** THE INPUT NUMBER OF ROWS (NIOLD), ** C ** THE NUMBER OF ROWS CHANGED (NS), ** C ** AND THE OUTPUT NUMBER OF ROWS (NINEW). ** C ** (THAT IS, THE SUBSET SAMPLE SIZE). ** C ** ALSO, CHECK THAT NS IS POSITIVE. ** C ************************************************* C ISTEPN='7' IF(IBUGQ.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IFEEDB.EQ.'OFF')GOTO709 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,701) 701 FORMAT('***** NOTE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,702)IROW1 702 FORMAT(' ROW START = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,703)IROWIN 703 FORMAT(' ROW INCREMENT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,704)IROWN 704 FORMAT(' ROW STOP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,705)NIOLD 705 FORMAT(' INPUT NUMBER OF ROWS = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,706)NS 706 FORMAT(' NUMBER OF ROWS AFFECTED = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,707)NINEW 707 FORMAT(' OUTPUT NUMBER OF ROWS = ',I8) CALL DPWRST('XXX','BUG ') 709 CONTINUE C CCCCC IF(NS.GE.1)GOTO790 CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,711) CC711 FORMAT('***** ERROR IN DPFOR--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,712) CC712 FORMAT(' THE SUBSET IS EMPTY--IT HAS NO ELEMENTS IN IT.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC IERROR='YES' CCCCC GOTO9000 C 790 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGQ.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPFOR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NIOLD,NINEW,IROW1,IROWN 9012 FORMAT('NIOLD,NINEW,IROW1,IROWN = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NLOCAL,ILOCS,NS 9013 FORMAT('NLOCAL,ILOCS,NS = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IBUGQ,IERROR 9014 FORMAT('IBUGQ,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NUMARG,NUMNAM,MAXNAM,N,MAXN 9015 FORMAT('NUMARG,NUMNAM,MAXNAM,N,MAXN = ',5I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)IWIDTH,NLOCAL,ILOCF 9016 FORMAT('IWIDTH,NLOCAL,ILOCF = ',3I8) CALL DPWRST('XXX','BUG ') DO9020I=1,NIOLD WRITE(ICOUT,9021)I,ISUB(I) 9021 FORMAT('I,ISUB(I) = ',2I8) CALL DPWRST('XXX','BUG ') 9020 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPFRAC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ICONT, 1IANGLU,ISEED, CCCCC JULY 1993. ADD FOLLOWING LINE. 1IFRAIT,IFRATY, 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--GENERATE A FRACTAL PLOT C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89/1 C ORIGINAL VERSION--DECEMBER 1988. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C UPDATED --APRIL 1992. MAXCP7 AND MAXCP... MISTAKES C UPDATED --JULY 1993. ADD FRACTAL ITERATIONS AND C FRACTAL TYPE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 ICONT CHARACTER*4 IANGLU 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 IH1 CHARACTER*4 IH2 CCCCC CHARACTER*4 IERRO2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN CCCCC JULY 1993. ADD FOLLOWING LINE. CHARACTER*4 IFRATY C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Z1(MAXOBV) DIMENSION Z2(MAXOBV) DIMENSION Z3(MAXOBV) DIMENSION Z4(MAXOBV) DIMENSION Z5(MAXOBV) DIMENSION Z6(MAXOBV) DIMENSION Z7(MAXOBV) C DIMENSION W(MAXOBV) DIMENSION U(MAXPOP) 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),Z4(1)) EQUIVALENCE (GARBAG(IGARB5),Z5(1)) EQUIVALENCE (GARBAG(IGARB6),Z6(1)) EQUIVALENCE (GARBAG(IGARB7),Z7(1)) EQUIVALENCE (GARBAG(IGARB7),W(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='DPFR' ISUBN2='AC ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C C ************************************* C ** TREAT THE FRACTAL PLOT CASE ** C ************************************* C IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'FRAC')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPFRAC--') 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,ICONT 53 FORMAT('ICASPL,IAND1,IAND2,ICONT = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IANGLU,ISEED,MAXPOP 54 FORMAT('IANGLU,ISEED,MAXPOP = ',A4,2I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *************************** C ** STEP 11-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='11' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FRAC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASPL='FRAC' C IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')GOTO1110 GOTO1180 C 1110 CONTINUE ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' GOTO1190 C 1190 CONTINUE C C *********************************************************** C ** STEP 12-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C *********************************************************** C ISTEPN='12' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FRAC') 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 13-- ** 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='13' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO1380 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 C 1380 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1381) 1381 FORMAT('***** INTERNAL ERROR IN DPFRAC') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1382) 1382 FORMAT(' AT BRANCH POINT 1381--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1383) 1383 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1384) 1384 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1385)NUMARG 1385 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1386) 1386 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1387)(IANS(I),I=1,IWIDTH) 1387 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1390 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO1395 WRITE(ICOUT,1391)NUMARG,ILOCQ,ICASEQ 1391 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 1395 CONTINUE C C ************************************************** C ** STEP 14-- ** C ** DETERMINE THE NUMBER OF VARIABLES ** C ** TO BE INCLUDED AS PLOT COMPONENTS ** C ************************************************** C ISTEPN='14' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FRAC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IF(NUMV2.GE.6.AND.NUMV2.LE.7)GOTO1490 C WRITE(ICOUT,1411) 1411 FORMAT('***** ERROR IN DPFRAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1412) 1412 FORMAT(' ILLEGAL SYNTAX--THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1413) 1413 FORMAT(' TO BE INCLUDED AS ARGUMENTS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1414) 1414 FORMAT(' IN A FRACTAL PLOT COMMAND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1415) 1415 FORMAT(' MUST BE AT LEAST 6 AND AT MOST 7;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1416)NUMV2 1416 FORMAT(' SUCH WAS NOT THE CASE HERE. NUMV2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1417) 1417 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1418)(IANS(I),I=1,IWIDTH) 1418 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1490 CONTINUE C C *************************************** C ** STEP 15-- ** C ** CHECK THE VALIDITY OF EACH ** C ** OF THE VARIABLES. ** C *************************************** C ISTEPN='15' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FRAC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1500I=1,NUMV2 IH1=IHARG(I) IH2=IHARG2(I) IHWUSE='V' MESSAG='YES' CALL CHECKN(IH1,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(I.EQ.1)ICOL1=IVALUE(ILOCV) IF(I.EQ.2)ICOL2=IVALUE(ILOCV) IF(I.EQ.3)ICOL3=IVALUE(ILOCV) IF(I.EQ.4)ICOL4=IVALUE(ILOCV) IF(I.EQ.5)ICOL5=IVALUE(ILOCV) IF(I.EQ.6)ICOL6=IVALUE(ILOCV) IF(I.EQ.7)ICOL7=IVALUE(ILOCV) IF(I.EQ.1)N1=IN(ILOCV) IF(I.EQ.2)N2=IN(ILOCV) IF(I.EQ.3)N3=IN(ILOCV) IF(I.EQ.4)N4=IN(ILOCV) IF(I.EQ.5)N5=IN(ILOCV) IF(I.EQ.6)N6=IN(ILOCV) IF(I.EQ.7)N7=IN(ILOCV) 1500 CONTINUE C C ************************************************** C ** STEP 16-- ** C ** CHECK THAT ALL ARGUMENTS ** C ** HAVE THE SAME NUMBER OF OBSERVATIONS. ** C ************************************************** C ISTEPN='16' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FRAC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(N2.NE.N1)GOTO1610 IF(NUMV2.LE.2)GOTO1690 IF(N3.NE.N1)GOTO1610 IF(NUMV2.LE.3)GOTO1690 IF(N4.NE.N1)GOTO1610 IF(NUMV2.LE.4)GOTO1690 IF(N5.NE.N1)GOTO1610 IF(NUMV2.LE.5)GOTO1690 IF(N6.NE.N1)GOTO1610 IF(NUMV2.LE.6)GOTO1690 IF(N7.NE.N1)GOTO1610 GOTO1690 C 1610 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1611) 1611 FORMAT('***** ERROR IN DPFRAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1612) 1612 FORMAT(' FOR A FRACTAL PLOT,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1613) 1613 FORMAT(' ALL VARIABLES MUST HAVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1614) 1614 FORMAT(' THE SAME NUMBER OF ELEMENTS;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1615) 1615 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1621)N1 1621 FORMAT('THE FIRST VARIABLE HAD ',I8,' ELEMENTS;') CALL DPWRST('XXX','BUG ') IF(NUMV2.LE.1)GOTO1690 WRITE(ICOUT,1622)N2 1622 FORMAT('THE SECOND VARIABLE HAD ',I8,' ELEMENTS;') CALL DPWRST('XXX','BUG ') IF(NUMV2.LE.2)GOTO1690 WRITE(ICOUT,1623)N3 1623 FORMAT('THE THIRD VARIABLE HAD ',I8,' ELEMENTS;') CALL DPWRST('XXX','BUG ') IF(NUMV2.LE.3)GOTO1690 WRITE(ICOUT,1624)N4 1624 FORMAT('THE FOURTH VARIABLE HAD ',I8,' ELEMENTS;') CALL DPWRST('XXX','BUG ') IF(NUMV2.LE.4)GOTO1690 WRITE(ICOUT,1625)N5 1625 FORMAT('THE FIFTH VARIABLE HAD ',I8,' ELEMENTS;') CALL DPWRST('XXX','BUG ') IF(NUMV2.LE.5)GOTO1690 WRITE(ICOUT,1626)N6 1626 FORMAT('THE SIXTH VARIABLE HAD ',I8,' ELEMENTS;') CALL DPWRST('XXX','BUG ') IF(NUMV2.LE.6)GOTO1690 WRITE(ICOUT,1627)N7 1627 FORMAT('THE SEVENTH VARIABLE HAD ',I8,' ELEMENTS;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1628) 1628 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1629)(IANS(I),I=1,IWIDTH) 1629 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1690 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.'FRAC') 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,N1 ISUB(I)=1 2115 CONTINUE NQ=N1 GOTO2150 C 2120 CONTINUE NIOLD=N1 CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO2150 C 2130 CONTINUE NIOLD=N1 CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO2150 C 2150 CONTINUE J=0 IMAX=N1 IF(NQ.LT.N1)IMAX=NQ DO2160I=1,IMAX IF(ISUB(I).EQ.0)GOTO2160 J=J+1 C IJ=MAXN*(ICOL1-1)+I IF(ICOL1.LE.MAXCOL)Z1(J)=V(IJ) IF(ICOL1.EQ.MAXCP1)Z1(J)=PRED(I) IF(ICOL1.EQ.MAXCP2)Z1(J)=RES(I) IF(ICOL1.EQ.MAXCP3)Z1(J)=YPLOT(I) IF(ICOL1.EQ.MAXCP4)Z1(J)=XPLOT(I) IF(ICOL1.EQ.MAXCP5)Z1(J)=X2PLOT(I) IF(ICOL1.EQ.MAXCP6)Z1(J)=TAGPLO(I) C IF(NUMV2.LE.1)GOTO2160 IJ=MAXN*(ICOL2-1)+I IF(ICOL2.LE.MAXCOL)Z2(J)=V(IJ) IF(ICOL2.EQ.MAXCP1)Z2(J)=PRED(I) IF(ICOL2.EQ.MAXCP2)Z2(J)=RES(I) IF(ICOL2.EQ.MAXCP3)Z2(J)=YPLOT(I) IF(ICOL2.EQ.MAXCP4)Z2(J)=XPLOT(I) IF(ICOL2.EQ.MAXCP5)Z2(J)=X2PLOT(I) IF(ICOL2.EQ.MAXCP6)Z2(J)=TAGPLO(I) C IF(NUMV2.LE.2)GOTO2160 IJ=MAXN*(ICOL3-1)+I IF(ICOL3.LE.MAXCOL)Z3(J)=V(IJ) IF(ICOL3.EQ.MAXCP1)Z3(J)=PRED(I) CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1992 CCCCC IF(ICOL3.EQ.MAXCP3)Z3(J)=RES(I) IF(ICOL3.EQ.MAXCP2)Z3(J)=RES(I) IF(ICOL3.EQ.MAXCP3)Z3(J)=YPLOT(I) IF(ICOL3.EQ.MAXCP4)Z3(J)=XPLOT(I) IF(ICOL3.EQ.MAXCP5)Z3(J)=X2PLOT(I) IF(ICOL3.EQ.MAXCP6)Z3(J)=TAGPLO(I) C IF(NUMV2.LE.3)GOTO2160 IJ=MAXN*(ICOL4-1)+I IF(ICOL4.LE.MAXCOL)Z4(J)=V(IJ) IF(ICOL4.EQ.MAXCP1)Z4(J)=PRED(I) CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1992 CCCCC IF(ICOL4.EQ.MAXCP4)Z4(J)=RES(I) IF(ICOL4.EQ.MAXCP2)Z4(J)=RES(I) IF(ICOL4.EQ.MAXCP3)Z4(J)=YPLOT(I) IF(ICOL4.EQ.MAXCP4)Z4(J)=XPLOT(I) IF(ICOL4.EQ.MAXCP5)Z4(J)=X2PLOT(I) IF(ICOL4.EQ.MAXCP6)Z4(J)=TAGPLO(I) C IF(NUMV2.LE.4)GOTO2160 IJ=MAXN*(ICOL5-1)+I IF(ICOL5.LE.MAXCOL)Z5(J)=V(IJ) IF(ICOL5.EQ.MAXCP1)Z5(J)=PRED(I) CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1992 CCCCC IF(ICOL5.EQ.MAXCP5)Z5(J)=RES(I) IF(ICOL5.EQ.MAXCP2)Z5(J)=RES(I) IF(ICOL5.EQ.MAXCP3)Z5(J)=YPLOT(I) IF(ICOL5.EQ.MAXCP4)Z5(J)=XPLOT(I) IF(ICOL5.EQ.MAXCP5)Z5(J)=X2PLOT(I) IF(ICOL5.EQ.MAXCP6)Z5(J)=TAGPLO(I) C IF(NUMV2.LE.5)GOTO2160 IJ=MAXN*(ICOL6-1)+I IF(ICOL6.LE.MAXCOL)Z6(J)=V(IJ) IF(ICOL6.EQ.MAXCP1)Z6(J)=PRED(I) CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1992 CCCCC IF(ICOL6.EQ.MAXCP6)Z6(J)=RES(I) IF(ICOL6.EQ.MAXCP2)Z6(J)=RES(I) IF(ICOL6.EQ.MAXCP3)Z6(J)=YPLOT(I) IF(ICOL6.EQ.MAXCP4)Z6(J)=XPLOT(I) IF(ICOL6.EQ.MAXCP5)Z6(J)=X2PLOT(I) IF(ICOL6.EQ.MAXCP6)Z6(J)=TAGPLO(I) C IF(NUMV2.LE.6)GOTO2160 IJ=MAXN*(ICOL7-1)+I IF(ICOL7.LE.MAXCOL)Z7(J)=V(IJ) IF(ICOL7.EQ.MAXCP1)Z7(J)=PRED(I) CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1992 CCCCC IF(ICOL7.EQ.MAXCP7)Z7(J)=RES(I) IF(ICOL7.EQ.MAXCP2)Z7(J)=RES(I) IF(ICOL7.EQ.MAXCP3)Z7(J)=YPLOT(I) IF(ICOL7.EQ.MAXCP4)Z7(J)=XPLOT(I) IF(ICOL7.EQ.MAXCP5)Z7(J)=X2PLOT(I) CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1992 CCCCC IF(ICOL7.EQ.MAXCP7)Z6(J)=TAGPLO(I) IF(ICOL7.EQ.MAXCP6)Z7(J)=TAGPLO(I) C 2160 CONTINUE NLOCAL=J C C ************************************************************* C ** STEP 31-- ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ************************************************************* C ISTEPN='8' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'FRAC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMV2.LE.6)GOTO3110 GOTO3119 3110 CONTINUE DO3111I=1,NLOCAL Z7(I)=1.0 3111 CONTINUE 3119 CONTINUE C CALL DPFRA2(Z1,Z2,Z3,Z4,Z5,Z6,Z7,NLOCAL,NUMV2,ICASPL,ICONT, 1IANGLU,ISEED,W,U,MAXPOP, CCCCC JULY 1993. ADD FOLLOWING LINE (FRACTAL ITERATIONS, FRACTAL TYPE) 1IFRAIT,IFRATY, 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.'FRAC')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPFRAC--') 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)ICASPL,IAND1,IAND2,ICONT 9014 FORMAT('ICASPL,IAND1,IAND2,ICONT = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IANGLU,ISEED,MAXPOP 9015 FORMAT('IANGLU,ISEED,MAXPOP = ',A4,2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9016 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9041)NLOCAL,NUMV2 9041 FORMAT('NLOCAL,NUMV2 = ',2I8) CALL DPWRST('XXX','BUG ') IF(NLOCAL.LE.0)GOTO9044 DO9042I=1,NLOCAL WRITE(ICOUT,9043)I,Z1(I),Z2(I),Z3(I),Z4(I),Z5(I),Z6(I) 9043 FORMAT('I,Z1(I),Z2(I),Z3(I),Z4(I),Z5(I),Z6(I) = ',I8,6E10.3) 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 DPFRA2(Z1,Z2,Z3,Z4,Z5,Z6,Z7,N,NUMV2,ICASPL,ICONT, 1IANGLU,ISEED,W,U,MAXPOP, CCCCC JULY 1993. ADD FOLLOWING LINE 1IFRAIT,IFRATY, 1Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE AN FRACTAL PLOT C NOTE--Z1 = INITIAL ROTATION C Z2 = X-SCALING C Z3 = Y-SCALING C Z4 = FINAL ROTATION C Z5 = X-TRANSLATION C Z6 = Y-TRANSLATION C Z7 = PROBABILITY WEIGHTING FOR EACH REGION C REFERENCE--WILLIAM DOUGLAS WITHERS, NAVAL ACADEMY 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/12 C ORIGINAL VERSION--DECEMBER 1988. C UPDATED --JULY 1993. FRACTAL ITERATIONS, FRACTAL C TYPE. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 ICONT CHARACTER*4 IANGLU CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR CCCCC JULY 1993. ADD FOLLOWING LINE. CHARACTER*4 IFRATY C C--------------------------------------------------------------------- C DIMENSION Z1(*) DIMENSION Z2(*) DIMENSION Z3(*) DIMENSION Z4(*) DIMENSION Z5(*) DIMENSION Z6(*) DIMENSION Z7(*) C DIMENSION W(*) DIMENSION U(*) C DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) C DIMENSION A11(100) DIMENSION A12(100) DIMENSION A21(100) DIMENSION A22(100) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'FRA2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPFRA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGG3,ISUBRO,IERROR 52 FORMAT('IBUGG3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,ICONT,IANGLU,ISEED,MAXPOP 53 FORMAT('ICASPL,ICONT,IANGLU,ISEED,MAXPOP = ', 1A4,2X,A4,2X,A4,2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NUMV2 54 FORMAT('NUMV2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)N 61 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO62I=1,N WRITE(ICOUT,63)I,Z1(I),Z2(I),Z3(I),Z4(I),Z5(I),Z6(I),Z7(I) 63 FORMAT('I,Z1(I),Z2(I),Z3(I),Z4(I),Z5(I),Z6(I),Z7(I) = ', 1I8,7E9.2) CALL DPWRST('XXX','BUG ') 62 CONTINUE 90 CONTINUE C CONST=1.0 IF(IANGLU.EQ.'DEGR')CONST=2*3.14159/360.0 CCCCC JULY 1993. BRANCH ACCORDING TO CASE. C C WHITHER'S FORMAT C IF(IFRATY.EQ.'WHIT')THEN DO1100I=1,N C ALPHA=Z1(I) SCALEX=Z2(I) SCALEY=Z3(I) BETA=Z4(I) C SINALP=SIN(CONST*ALPHA) COSALP=COS(CONST*ALPHA) SINBET=SIN(CONST*BETA) COSBET=COS(CONST*BETA) A11(I)=COSALP*COSBET*SCALEX-SINALP*SINBET*SCALEY A12(I)=(-SINALP*COSBET*SCALEX-COSALP*SINBET*SCALEY) A21(I)=COSALP*SINBET*SCALEX+SINALP*COSBET*SCALEY A22(I)=(-SINALP*SINBET*SCALEX+COSALP*COSBET*SCALEY) C 1100 CONTINUE C C BARNSLEY ROTATION ANGLE FORMAT C ELSEIF(IFRATY.EQ.'ANGL')THEN DO1110I=1,N C ALPHA=Z1(I) SCALEX=Z2(I) SCALEY=Z3(I) BETA=Z4(I) C A11(I)=SCALEX*COS(ALPHA) A12(I)=-SCALEY*SIN(BETA) A21(I)=SCALEX*SIN(ALPHA) A22(I)=SCALEY*COS(BETA) C 1110 CONTINUE C C BARNSLEY STANDARD FORMAT C ELSE DO1120I=1,N A11(I)=Z1(I) A12(I)=Z2(I) A21(I)=Z3(I) A22(I)=Z4(I) 1120 CONTINUE ENDIF C SUM=0.0 DO1210I=1,N SUM=SUM+Z7(I) 1210 CONTINUE C DO1220I=1,N W(I)=Z7(I)/SUM 1220 CONTINUE C CUM=0.0 DO1230I=1,N CUM=CUM+W(I) W(I)=CUM 1230 CONTINUE C CCCCC JULY 1993. ADD FOLLOWING LINES CCCCC NU=MAXPOP NU=IFRAIT IF(NU.GT.MAXPOP)NU=IFRAIT CCCCC END CHANGE CALL UNIRAN(NU,ISEED,U) C XNEW=0.0 YNEW=0.0 K=0 JCUT=20 DO1310J=1,NU C UJ=U(J) DO1320I=1,N INDEX=I IF(UJ.LE.W(I))GOTO1329 1320 CONTINUE 1329 CONTINUE C XOLD=XNEW YOLD=YNEW XTEMP=A11(INDEX)*XOLD+A12(INDEX)*YOLD YTEMP=A21(INDEX)*XOLD+A22(INDEX)*YOLD XNEW=XTEMP+Z5(INDEX) YNEW=YTEMP+Z6(INDEX) IF(J.LE.JCUT)GOTO1310 IF(J.GT.JCUT)K=K+1 X2(K)=XNEW Y2(K)=YNEW D2(K)=1.0 1310 CONTINUE C N2=K NPLOTV=2 GOTO9000 C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'FRA2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPFRA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGG3,ISUBRO,IERROR 9012 FORMAT('IBUGG3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICASPL,ICONT,IANGLU,ISEED,MAXPOP 9013 FORMAT('ICASPL,ICONT,IANGLU,ISEED,MAXPOP = ', 1A4,2X,A4,2X,A4,2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)N 9021 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO9022I=1,N WRITE(ICOUT,9023)A11(I),A12(I),A21(I),A22(I) 9023 FORMAT('A11(I),A12(I),A21(I),A22(I) = ',4E15.7) CALL DPWRST('XXX','BUG ') 9022 CONTINUE DO9024I=1,N WRITE(ICOUT,9025)I,W(I) 9025 FORMAT('I,W(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 9024 CONTINUE WRITE(ICOUT,9051)NUMV2 9051 FORMAT('NUMV2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9052)N2,NPLOTV 9052 FORMAT('N2,NPLOTV = ',2I8) CALL DPWRST('XXX','BUG ') DO9053I=1,N2 CCCCC WRITE(ICOUT,9054)I,U(I),X2(I),Y2(I) 9054 FORMAT('I,U(I),X2(I),Y2(I) = ',I8,3E15.7) CCCCC CALL DPWRST('XXX','BUG ') 9053 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPFRAM(ICOM,IHARG,NUMARG, 1IX1FSW,IX2FSW,IY1FSW,IY2FSW, CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1993 1FRASTY, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE FRAME SWITCHES (ON/OFF) C FOR ANY OF THE 4 FRAME LINES. C SUCH FRAME SWITCHES DEFINE WHETHER OR NOT C EACH OF THE 4 FRAME LINES EXISTS. C THE CONTENTS OF A FRAME SWITCH ARE C ON OR OFF. C THE FRAME SWITCHES FOR THE 4 FRAME LINES C ARE CONTAINED IN THE 4 VARIABLES C IX1FSW,IX2FSW,IY1FSW,IY2FSW. C INPUT ARGUMENTS--ICOM C --IHARG (A HOLLERITH VECTOR) C --NUMARG C OUTPUT ARGUMENTS--IX1FSW (A HOLLERITH VECTOR) C --IX2FSW (A HOLLERITH VECTOR) C --IY1FSW (A HOLLERITH VECTOR) C --IY2FSW (A HOLLERITH 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--OCTOBER 1980. C UPDATED --MAY 1982. C UPDATED --SEPTEMBER 1993. 3-D C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICOM CHARACTER*4 IHARG C CHARACTER*4 IX1FSW CHARACTER*4 IX2FSW CHARACTER*4 IY1FSW CHARACTER*4 IY2FSW C CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1993 CHARACTER*4 FRASTY C 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.GE.1.AND.IHARG(1).EQ.'CORN')GOTO1900 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COOR')GOTO1900 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO1900 C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1993 CCCCC TO ALLOW FOR 3-D FRAME STYLE SETTINGS SEPTEMBER 1993 C ***************************************************** C ** TREAT THE CASE WHEN ** C ** THE 3D FRAME STYLE IS TO BE CHANGED ** C ***************************************************** C IF(ICOM.EQ.'3DFR')GOTO1000 GOTO1099 C 1000 CONTINUE IF(NUMARG.LE.0)GOTO1010 IF(IHARG(NUMARG).EQ.'ON')GOTO1010 IF(IHARG(NUMARG).EQ.'OFF')GOTO1020 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1010 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1010 IF(IHARG(NUMARG).EQ.'?')GOTO1030 GOTO1020 C 1010 CONTINUE IFOUND='YES' FRASTY='3PRO' IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011) 1011 FORMAT('THE 3D FRAME SWITCH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1012) 1012 FORMAT('HAS JUST BEEN SET TO 3PRONG') CALL DPWRST('XXX','BUG ') GOTO1900 ENDIF C 1020 CONTINUE IFOUND='YES' C IF(IHARG(1).EQ.'OFF'.OR.IHARG(1).EQ.'NONE')THEN FRASTY='OFF' IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1021) 1021 FORMAT('HAS JUST BEEN SET TO OFF') CALL DPWRST('XXX','BUG ') ENDIF GOTO1900 ENDIF C IF(IHARG(1).EQ.'3PRO')THEN FRASTY='3PRO' IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1022) 1022 FORMAT('HAS JUST BEEN SET TO 3PRONG') CALL DPWRST('XXX','BUG ') ENDIF GOTO1900 ENDIF C IF(IHARG(1).EQ.'3PLA')THEN FRASTY='3PLA' IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1023) 1023 FORMAT('HAS JUST BEEN SET TO 3PLANE') CALL DPWRST('XXX','BUG ') ENDIF GOTO1900 ENDIF C IF(IHARG(1).EQ.'CUBE'.OR.IHARG(1).EQ.'BOX')THEN FRASTY='BOX' IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1024) 1024 FORMAT('HAS JUST BEEN SET TO BOX') CALL DPWRST('XXX','BUG ') ENDIF GOTO1900 ENDIF C IF(IHARG(1).EQ.'ZIGZ')THEN FRASTY='ZIGZ' IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1025) 1025 FORMAT('HAS JUST BEEN SET TO ZIGZAG') CALL DPWRST('XXX','BUG ') ENDIF GOTO1900 ENDIF C 1030 CONTINUE IFOUND='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1031) 1031 FORMAT('THE 3D FRAME SWITCH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1032)FRASTY 1032 FORMAT('HAS THE CURRENT SETTING = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1033) 1033 FORMAT('ALLOWABLE SETTINGS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1034) 1034 FORMAT(' 3PRONG') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1035) 1035 FORMAT(' 3PLANE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1036) 1036 FORMAT(' BOX') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1037) 1037 FORMAT(' ZIGZAG') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1038) 1038 FORMAT(' OFF') CALL DPWRST('XXX','BUG ') GOTO1900 C 1099 CONTINUE C C ***************************************************** C ** TREAT THE CASE WHEN ** C ** BOTH HORIZONTAL FRAME LINES ARE TO BE CHANGED ** C ***************************************************** C IF(ICOM.EQ.'XFRA')GOTO1100 GOTO1199 C 1100 CONTINUE IF(NUMARG.LE.0)GOTO1110 IF(IHARG(NUMARG).EQ.'ON')GOTO1110 IF(IHARG(NUMARG).EQ.'OFF')GOTO1120 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1110 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1110 IERROR='YES' GOTO1900 C 1110 CONTINUE IFOUND='YES' IX1FSW='ON' IX2FSW='ON' C IF(IFEEDB.EQ.'OFF')GOTO1119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1115) 1115 FORMAT('THE XFRAME SWITCH (FOR BOTH HORIZONTAL FRAME LINES) ', 1'HAS JUST BEEN TURNED ON') CALL DPWRST('XXX','BUG ') 1119 CONTINUE GOTO1900 C 1120 CONTINUE IFOUND='YES' IX1FSW='OFF' IX2FSW='OFF' C IF(IFEEDB.EQ.'OFF')GOTO1129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1125) 1125 FORMAT('THE XFRAME SWITCH (FOR BOTH HORIZONTAL FRAME LINES) ', 1'HAS JUST BEEN TURNED OFF') CALL DPWRST('XXX','BUG ') 1129 CONTINUE GOTO1900 C 1199 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE BOTTOM HORIZONTAL FRAME LINE IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X1FR')GOTO1200 GOTO1299 C 1200 CONTINUE IF(NUMARG.LE.0)GOTO1210 IF(IHARG(NUMARG).EQ.'ON')GOTO1210 IF(IHARG(NUMARG).EQ.'OFF')GOTO1220 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1210 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1210 IERROR='YES' GOTO1900 C 1210 CONTINUE IFOUND='YES' IX1FSW='ON' C IF(IFEEDB.EQ.'OFF')GOTO1219 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215) 1215 FORMAT('THE X1FRAME SWITCH (FOR THE BOTTOM HORIZONTAL ', 1'FRAME LINE ONLY) HAS JUST BEEN TURNED ON') CALL DPWRST('XXX','BUG ') 1219 CONTINUE GOTO1900 C 1220 CONTINUE IFOUND='YES' IX1FSW='OFF' C IF(IFEEDB.EQ.'OFF')GOTO1229 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1225) 1225 FORMAT('THE X1FRAME SWITCH (FOR THE BOTTOM HORIZONTAL ', 1'FRAME LINE ONLY) HAS JUST BEEN TURNED OFF') CALL DPWRST('XXX','BUG ') 1229 CONTINUE GOTO1900 C 1299 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE TOP HORIZONTAL FRAME LINE IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X2FR')GOTO1300 GOTO1399 C 1300 CONTINUE IF(NUMARG.LE.0)GOTO1310 IF(IHARG(NUMARG).EQ.'ON')GOTO1310 IF(IHARG(NUMARG).EQ.'OFF')GOTO1320 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1310 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1310 IERROR='YES' GOTO1900 C 1310 CONTINUE IFOUND='YES' IX2FSW='ON' C IF(IFEEDB.EQ.'OFF')GOTO1319 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1315) 1315 FORMAT('THE X2FRAME SWITCH (FOR THE TOP HORIZONTAL ', 1'FRAME LINE ONLY) HAS JUST BEEN TURNED ON') CALL DPWRST('XXX','BUG ') 1319 CONTINUE GOTO1900 C 1320 CONTINUE IFOUND='YES' IX2FSW='OFF' C IF(IFEEDB.EQ.'OFF')GOTO1329 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1325) 1325 FORMAT('THE X2FRAME SWITCH (FOR THE TOP HORIZONTAL ', 1'FRAME LINE ONLY) HAS JUST BEEN TURNED OFF') CALL DPWRST('XXX','BUG ') 1329 CONTINUE GOTO1900 C 1399 CONTINUE C C *************************************************** C ** TREAT THE CASE WHEN ** C ** BOTH VERTICAL FRAME LINES ARE TO BE CHANGED ** C *************************************************** C IF(ICOM.EQ.'YFRA')GOTO1400 GOTO1499 C 1400 CONTINUE IF(NUMARG.LE.0)GOTO1410 IF(IHARG(NUMARG).EQ.'ON')GOTO1410 IF(IHARG(NUMARG).EQ.'OFF')GOTO1420 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1410 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1410 IERROR='YES' GOTO1900 C 1410 CONTINUE IFOUND='YES' IY1FSW='ON' IY2FSW='ON' C IF(IFEEDB.EQ.'OFF')GOTO1419 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1415) 1415 FORMAT('THE YFRAME SWITCH (FOR BOTH VERTICAL FRAME LINES) ', 1'HAS JUST BEEN TURNED ON') CALL DPWRST('XXX','BUG ') 1419 CONTINUE GOTO1900 C 1420 CONTINUE IFOUND='YES' IY1FSW='OFF' IY2FSW='OFF' C IF(IFEEDB.EQ.'OFF')GOTO1429 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1425) 1425 FORMAT('THE YFRAME SWITCH (FOR BOTH VERTICAL FRAME LINES) ', 1'HAS JUST BEEN TURNED OFF') CALL DPWRST('XXX','BUG ') 1429 CONTINUE GOTO1900 C 1499 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE LEFT VERTICAL FRAME LINE IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y1FR')GOTO1500 GOTO1599 C 1500 CONTINUE IF(NUMARG.LE.0)GOTO1510 IF(IHARG(NUMARG).EQ.'ON')GOTO1510 IF(IHARG(NUMARG).EQ.'OFF')GOTO1520 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1510 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1510 IERROR='YES' GOTO1900 C 1510 CONTINUE IFOUND='YES' IY1FSW='ON' C IF(IFEEDB.EQ.'OFF')GOTO1519 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1515) 1515 FORMAT('THE Y1FRAME SWITCH (FOR THE LEFT VERTICAL ', 1'FRAME LINE ONLY) HAS JUST BEEN TURNED ON') CALL DPWRST('XXX','BUG ') 1519 CONTINUE GOTO1900 C 1520 CONTINUE IFOUND='YES' IY1FSW='OFF' C IF(IFEEDB.EQ.'OFF')GOTO1529 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1525) 1525 FORMAT('THE Y1FRAME SWITCH (FOR THE LEFT VERTICAL ', 1'FRAME LINE ONLY) HAS JUST BEEN TURNED OFF') CALL DPWRST('XXX','BUG ') 1529 CONTINUE GOTO1900 C 1599 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE RIGHT VERTCIAL FRAME LINE IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y2FR')GOTO1600 GOTO1699 C 1600 CONTINUE IF(NUMARG.LE.0)GOTO1610 IF(IHARG(NUMARG).EQ.'ON')GOTO1610 IF(IHARG(NUMARG).EQ.'OFF')GOTO1620 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1610 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1610 IERROR='YES' GOTO1900 C 1610 CONTINUE IFOUND='YES' IY2FSW='ON' C IF(IFEEDB.EQ.'OFF')GOTO1619 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1615) 1615 FORMAT('THE Y2FRAME SWITCH (FOR THE RIGHT VERTICAL ', 1'FRAME LINE ONLY) HAS JUST BEEN TURNED ON') CALL DPWRST('XXX','BUG ') 1619 CONTINUE GOTO1900 C 1620 CONTINUE IFOUND='YES' IY2FSW='OFF' C IF(IFEEDB.EQ.'OFF')GOTO1629 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1625) 1625 FORMAT('THE Y2FRAME SWITCH (FOR THE RIGHT VERTICAL ', 1'FRAME LINE ONLY) HAS JUST BEEN TURNED OFF') CALL DPWRST('XXX','BUG ') 1629 CONTINUE GOTO1900 C 1699 CONTINUE C C ************************************************** C ** TREAT THE CASE WHEN ** C ** THE ENTIRE 4-SIDED FRAME IS TO BE CHANGED ** C ************************************************** C IF(ICOM.EQ.'XYFR')GOTO1700 IF(ICOM.EQ.'YXFR')GOTO1700 IF(ICOM.EQ.'FRAM')GOTO1700 GOTO1799 C 1700 CONTINUE IF(NUMARG.LE.0)GOTO1710 IF(IHARG(NUMARG).EQ.'ON')GOTO1710 IF(IHARG(NUMARG).EQ.'OFF')GOTO1720 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1710 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1710 IERROR='YES' GOTO1900 C 1710 CONTINUE IFOUND='YES' IX1FSW='ON' IX2FSW='ON' IY1FSW='ON' IY2FSW='ON' C IF(IFEEDB.EQ.'OFF')GOTO1719 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1715) 1715 FORMAT('THE FRAME SWITCH (FOR THE ENTIRE 4-SIDED FRAME) ', 1'HAS JUST BEEN TURNED ON') CALL DPWRST('XXX','BUG ') 1719 CONTINUE GOTO1900 C 1720 CONTINUE IFOUND='YES' IX1FSW='OFF' IX2FSW='OFF' IY1FSW='OFF' IY2FSW='OFF' C IF(IFEEDB.EQ.'OFF')GOTO1729 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1725) 1725 FORMAT('THE FRAME SWITCH (FOR THE ENTIRE 4-SIDED FRAME) ', 1'HAS JUST BEEN TURNED OFF') CALL DPWRST('XXX','BUG ') 1729 CONTINUE GOTO1900 C 1799 CONTINUE C 1900 CONTINUE RETURN END SUBROUTINE DPFRCC(IHARG,IHARG2,IARGT,ARG,NUMARG, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,IANS,IWIDTH, 1PXMIN,PXMAX,PYMIN,PYMAX,IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE FRAME CORNER COORDINATES C (LOWER LEFT AND UPPER RIGHT) C WHICH IN TURN WILL DEFINE THE SIZE AND SHAPE C OF THE PLOT FRAME. C THE 2 PAIRS OF COORDINATES ARE CONTAINED IN THE C 4 VARIABLES PXMIN,PYMIN AND PXMAX,PYMAX C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --ARG (A FLOATING POINT VECTOR) C --NUMARG C OUTPUT ARGUMENTS--PXMIN = X COOR. FOR LOWER LEFT CORNER C --PXMAX = X COOR. FOR UPPER RIGHT CORNER C --PYMIN = Y COOR. FOR LOWER LEFT CORNER C --PYMAX = Y COOR. FOR UPPER RIGHT CORNER C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--NOVEMBER 1978. C UPDATED --SEPTEMBER 1980. C UPDATED --MARCH 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IHARG2 CHARACTER*4 IARGT CHARACTER*4 IHNAME CHARACTER*4 IHNAM2 CHARACTER*4 IUSE CHARACTER*4 IANS CHARACTER*4 IBUGP2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 IHWORD CHARACTER*4 IHWOR2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IHARG2(*) DIMENSION IARGT(*) DIMENSION ARG(*) C DIMENSION IHNAME(*) DIMENSION IHNAM2(*) DIMENSION IUSE(*) DIMENSION IN(*) DIMENSION IVALUE(*) DIMENSION VALUE(*) DIMENSION IANS(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPFR' ISUBN2='CC ' C IFOUND='NO' IERROR='NO' 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 DPFRCC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IFOUND,IERROR 52 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)PXMIN,PXMAX,PYMIN,PYMAX 53 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4E15.7) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************** C ** TREAT THE FRAME COORDINATES CASE ** C ************************************************** C IF(NUMARG.LE.1)GOTO1150 GOTO1110 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 IF(NUMARG.GE.2)GOTO1175 GOTO1120 C 1120 CONTINUE IERROR='YES' WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPFRCC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' ILLEGAL FORM FOR FRAME CORNER COORDINATES ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1124) 1124 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1125) 1125 FORMAT(' SUPPOSE IT IS DESIRED TO POSITION ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1126) 1126 FORMAT(' THE LOWER LEFT CORNER OF THE FRAME') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1127) 1127 FORMAT(' 10% ACROSS THE PAGE AND 20% UP THE PAGE, AND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1128) 1128 FORMAT(' THE UPPER RIGHT CORNER OF THE FRAME') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1129) 1129 FORMAT(' 90% ACROSS THE PAGE AND 80% UP THE PAGE,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1130) 1130 FORMAT(' THEN THE ALLOWABLE FORM IS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1131) 1131 FORMAT(' FRAME CORNER COORDINATES 10 20 90 80') CALL DPWRST('XXX','BUG ') GOTO9000 C 1150 CONTINUE PXMIN=15. PYMIN=20. PXMAX=85. PYMAX=90. GOTO1180 C 1175 CONTINUE DO1176J=2,NUMARG IF(IARGT(J).EQ.'NUMB')GOTO1177 GOTO1178 1177 CONTINUE IF(J.EQ.2)PXMIN=ARG(J) IF(J.EQ.3)PYMIN=ARG(J) IF(J.EQ.4)PXMAX=ARG(J) IF(J.EQ.5)PYMAX=ARG(J) GOTO1176 1178 CONTINUE IHWORD=IHARG(J) IHWOR2=IHARG2(J) IHWUSE='P' MESSAG='YES' CALL CHECKN(IHWORD,IHWOR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(J.EQ.2)PXMIN=VALUE(ILOC) IF(J.EQ.3)PYMIN=VALUE(ILOC) IF(J.EQ.4)PXMAX=VALUE(ILOC) IF(J.EQ.5)PYMAX=VALUE(ILOC) 1176 CONTINUE GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1185) 1185 FORMAT('THE FRAME CORNER COORDINATES HAVE JUST BEEN SET ', 1'AS FOLLOWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)PXMIN,PYMIN 1186 FORMAT(' (X,Y) FOR LOWER LEFT CORNER OF FRAME = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1187)PXMAX,PYMAX 1187 FORMAT(' (X,Y) FOR UPPER RIGHT CORNER OF FRAME = ',2E15.7) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGP2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPFRCC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)PXMIN,PXMAX,PYMIN,PYMAX 9013 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPFRCL(ICOM,IHARG,NUMARG, 1IDEFCO, 1IX1FCO,IX2FCO,IY1FCO,IY2FCO, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE FRAME COLOR SWITCHES C FOR ANY OF THE 4 FRAME LINES. C SUCH FRAME COLOR SWITCHES DEFINE THE COLOR C FOR EACH OF THE 4 FRAME LINES. C THE CONTENTS OF A FRAME COLOR SWITCH ARE C A COLOR. C THE FRAME COLOR SWITCHES FOR THE 4 FRAME LINES C ARE CONTAINED IN THE 4 VARIABLES C IX1FCO,IX2FCO,IY1FCO,IY2FCO. C INPUT ARGUMENTS--ICOM C --IHARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFCO C OUTPUT ARGUMENTS--IX1FCO (A HOLLERITH VECTOR) C --IX2FCO (A HOLLERITH VECTOR) C --IY1FCO (A HOLLERITH VECTOR) C --IY2FCO (A HOLLERITH 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--OCTOBER 1980. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICOM CHARACTER*4 IHARG CHARACTER*4 IDEFCO C CHARACTER*4 IX1FCO CHARACTER*4 IX2FCO CHARACTER*4 IY1FCO CHARACTER*4 IY2FCO C CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) C C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(NUMARG.LE.0)GOTO1900 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO1090 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 1IHARG(2).EQ.'COLO')GOTO1090 GOTO1900 1090 CONTINUE C C ***************************************************** C ** TREAT THE CASE WHEN ** C ** BOTH HORIZONTAL FRAMES ARE TO BE CHANGED ** C ***************************************************** C IF(ICOM.EQ.'XFRA')GOTO1100 GOTO1199 C 1100 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 IF(IHARG(NUMARG).EQ.'COLO')GOTO1150 GOTO1160 C 1150 CONTINUE IHOLD=IDEFCO GOTO1180 C 1160 CONTINUE IHOLD=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' IX1FCO=IHOLD IX2FCO=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE FRAME COLOR (FOR BOTH HORIZONTAL ', 1'FRAME LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)IHOLD 1182 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1900 C 1199 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE BOTTOM HORIZONTAL FRAME IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X1FR')GOTO1200 GOTO1299 C 1200 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1250 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 IF(IHARG(NUMARG).EQ.'COLO')GOTO1250 GOTO1260 C 1250 CONTINUE IHOLD=IDEFCO GOTO1280 C 1260 CONTINUE IHOLD=IHARG(NUMARG) GOTO1280 C 1280 CONTINUE IFOUND='YES' IX1FCO=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1289 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1281) 1281 FORMAT('THE FRAME COLOR (FOR THE BOTTOM HORIZONTAL ', 1'FRAME LINE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1282)IHOLD 1282 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1289 CONTINUE GOTO1900 C 1299 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE TOP HORIZONTAL FRAME IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X2FR')GOTO1300 GOTO1399 C 1300 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1350 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 IF(IHARG(NUMARG).EQ.'COLO')GOTO1350 GOTO1360 C 1350 CONTINUE IHOLD=IDEFCO GOTO1380 C 1360 CONTINUE IHOLD=IHARG(NUMARG) GOTO1380 C 1380 CONTINUE IFOUND='YES' IX2FCO=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1389 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1381) 1381 FORMAT('THE FRAME COLOR (FOR THE TOP HORIZONTAL ', 1'FRAME LINE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1382)IHOLD 1382 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1389 CONTINUE GOTO1900 C 1399 CONTINUE C C ***************************************************** C ** TREAT THE CASE WHEN ** C ** BOTH VERTICAL FRAMES ARE TO BE CHANGED ** C ***************************************************** C IF(ICOM.EQ.'YFRA')GOTO1400 GOTO1499 C 1400 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1450 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 IF(IHARG(NUMARG).EQ.'COLO')GOTO1450 GOTO1460 C 1450 CONTINUE IHOLD=IDEFCO GOTO1480 C 1460 CONTINUE IHOLD=IHARG(NUMARG) GOTO1480 C 1480 CONTINUE IFOUND='YES' IY1FCO=IHOLD IY2FCO=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1489 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1481) 1481 FORMAT('THE FRAME COLOR (FOR BOTH VERTICAL ', 1'FRAME LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1482)IHOLD 1482 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1489 CONTINUE GOTO1900 C 1499 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE LEFT VERTICAL FRAME IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y1FR')GOTO1500 GOTO1599 C 1500 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1550 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 IF(IHARG(NUMARG).EQ.'COLO')GOTO1550 GOTO1560 C 1550 CONTINUE IHOLD=IDEFCO GOTO1580 C 1560 CONTINUE IHOLD=IHARG(NUMARG) GOTO1580 C 1580 CONTINUE IFOUND='YES' IY1FCO=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1589 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1581) 1581 FORMAT('THE FRAME COLOR (FOR THE LEFT VERTICAL ', 1'FRAME LINE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1582)IHOLD 1582 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1589 CONTINUE GOTO1900 C 1599 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE RIGHT VERTICAL FRAME IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y2FR')GOTO1600 GOTO1699 C 1600 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1650 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 IF(IHARG(NUMARG).EQ.'COLO')GOTO1650 GOTO1660 C 1650 CONTINUE IHOLD=IDEFCO GOTO1680 C 1660 CONTINUE IHOLD=IHARG(NUMARG) GOTO1680 C 1680 CONTINUE IFOUND='YES' IY2FCO=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1689 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1681) 1681 FORMAT('THE FRAME COLOR (FOR THE RIGHT VERTICAL ', 1'FRAME LINE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1682)IHOLD 1682 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1689 CONTINUE GOTO1900 C 1699 CONTINUE C C ***************************************************** C ** TREAT THE CASE WHEN ** C ** ALL 4 FRAME FRAME LINES ARE TO BE CHANGED ** C ***************************************************** C IF(ICOM.EQ.'FRAM')GOTO1700 IF(ICOM.EQ.'XYFR')GOTO1700 IF(ICOM.EQ.'YXFR')GOTO1700 GOTO1799 C 1700 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1750 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 IF(IHARG(NUMARG).EQ.'COLO')GOTO1750 GOTO1760 C 1750 CONTINUE IHOLD=IDEFCO GOTO1780 C 1760 CONTINUE IHOLD=IHARG(NUMARG) GOTO1780 C 1780 CONTINUE IFOUND='YES' IX1FCO=IHOLD IX2FCO=IHOLD IY1FCO=IHOLD IY2FCO=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1789 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1781) 1781 FORMAT('THE FRAME COLOR (FOR ALL 4 ', 1'FRAME LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1782)IHOLD 1782 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1789 CONTINUE GOTO1900 C 1799 CONTINUE C 1900 CONTINUE RETURN END SUBROUTINE DPFRE2(Y,X,N,ICASPL,IRELAT,IDATSW,CLWID,XSTART,XSTOP, 1Y2,X2,D2,N2,NPLOTV,IBUGG3,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE C 1) A FREQUENCY PLOT, C 2) A RELATIVE FREQUENCY PLOT C (THAT IS, WITH AREA = 1). C 3) A CUMULATIVE FREQUENCY PLOT C 4) A RELATIVE CUMULATIVE FREQUENCY PLOT C (THAT IS, WITH MAX ORDINATE = 1). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--APRIL 1978. C UPDATED --MAY 1978. C UPDATED --JUNE 1978. C UPDATED --OCTOBER 1978. C UPDATED --MARCH 1979. C UPDATED --APRIL 1979. C UPDATED --JANUARY 1981. C UPDATED --AUGUST 1981. C UPDATED --OCTOBER 1981. C UPDATED --DECEMBER 1981. C UPDATED --APRIL 1982. C UPDATED --MAY 1982. C UPDATED --DECEMBER 1999. CHECK FOR POINTS OUTSIDE INTERVAL C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IRELAT CHARACTER*4 IDATSW CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*4 IWRIT2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X(*) 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='DPFR' ISUBN2='E2 ' C IERROR='NO' C AN3=0.0 DENOM=0.0 CUMFJ=0.0 C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.GE.1)GOTO39 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN DPFRE2--') 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 DPFRE2--') 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=X(1) DO60I=1,N IF(X(I).NE.HOLD)GOTO69 60 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61) 61 FORMAT('***** ERROR IN DPFRE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' ALL INPUT HORIZONTAL AXIS ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)HOLD 63 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 69 CONTINUE C IF(IBUGG3.EQ.'OFF')GOTO80 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70) 70 FORMAT('***** AT THE BEGINNING OF DPFRE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)IDATSW 71 FORMAT('IDATSW = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)N,CLWID,XSTART,XSTOP 72 FORMAT('N,CLWID,XSTART,XSTOP = ',I6,3E15.7) CALL DPWRST('XXX','BUG ') DO73I=1,N WRITE(ICOUT,74)I,Y(I),X(I) 74 FORMAT('I, Y(I), X(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 73 CONTINUE 80 CONTINUE C C ********************************************** C ** STEP 2-- ** C ** IF NECESSARY, ** C ** DETERMINE CLASS WIDTH, ** C ** START VALUE, STOP VALUE, ** C ** AND NUMBER OF CLASSES. ** C ********************************************** C IF(IDATSW.EQ.'RAW')GOTO110 IF(IDATSW.EQ.'FREQ')GOTO150 C 110 CONTINUE IF(CLWID.NE.CPUMIN.AND.XSTART.NE.CPUMIN.AND. 1XSTOP.NE.CPUMAX)GOTO119 IWRIT2='OFF' CALL MEAN(X,N,IWRIT2,XMEAN,IBUGG3,IERROR) CALL SD(X,N,IWRIT2,XSD,IBUGG3,IERROR) IF(CLWID.EQ.CPUMIN)CLWID=0.3*XSD IF(XSTART.EQ.CPUMIN)XSTART=XMEAN-6.0*XSD IF(XSTOP.EQ.CPUMAX)XSTOP=XMEAN+6.0*XSD 119 CONTINUE GOTO180 C 150 CONTINUE CALL SORT(X,N,D2) NM1=N-1 CLWID=D2(2)-D2(1) DO160I=1,NM1 IP1=I+1 DELI=D2(IP1)-D2(I) IF(DELI.LT.CLWID)CLWID=DELI 160 CONTINUE XSTART=D2(1)-(CLWID/2.0) XSTOP=D2(N)+(CLWID/2.0) GOTO180 C 180 CONTINUE TOTWID=XSTOP-XSTART ANUMCL=TOTWID/CLWID NUMCLA=ANUMCL+1.0 C J=NUMCLA-1 AJ=J CLMAXJ=XSTART+AJ*CLWID ABSDEL=ABS(CLMAXJ-XSTOP) IF(ABSDEL.LE.0.0001)NUMCLA=NUMCLA-1 C C ******************************************************* C ** STEP 3-- ** C ** DETERMINE THE FREQUENCY (COUNTS) FOR EACH CLASS ** C ******************************************************* C DO300J=1,NUMCLA D2(J)=0.0 300 CONTINUE C IF(IDATSW.EQ.'RAW')GOTO410 IF(IDATSW.EQ.'FREQ')GOTO510 C 410 CONTINUE IABOVE=0 IBELOW=0 DO420I=1,N DO430J=1,NUMCLA J2=J AJ=J IF(X(I).LT.XSTART)THEN IBELOW=IBELOW+1 GOTO420 ENDIF IF(X(I).GT.XSTOP)THEN IABOVE=IABOVE+1 GOTO420 ENDIF CLMINJ=XSTART+(AJ-1.0)*CLWID CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP IF(CLMINJ.LE.X(I).AND.X(I).LT.CLMAXJ)GOTO440 430 CONTINUE GOTO420 440 CONTINUE D2(J2)=D2(J2)+1.0 420 CONTINUE C C FOR THIS RAW DATA CASE, C TREAT THE SPECIAL CASE OF EQUALITY C WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS C J=NUMCLA DO450I=1,N AJ=J CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP IF(X(I).EQ.CLMAXJ)D2(J)=D2(J)+1.0 450 CONTINUE GOTO590 C 510 CONTINUE IABOVE=0 IBELOW=0 DO520I=1,N DO530J=1,NUMCLA J2=J AJ=J IF(X(I).LT.XSTART)THEN IBELOW=IBELOW+1 GOTO520 ENDIF IF(X(I).GT.XSTOP)THEN IABOVE=IABOVE+1 GOTO520 ENDIF CLMINJ=XSTART+(AJ-1.0)*CLWID CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP IF(CLMINJ.LE.X(I).AND.X(I).LT.CLMAXJ)GOTO540 530 CONTINUE GOTO520 540 CONTINUE D2(J2)=D2(J2)+Y(I) 520 CONTINUE C C FOR THIS FREQUENCY DATA CASE, C TREAT THE SPECIAL CASE OF EQUALITY C WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS C (ALTHOUGH THIS SHOULD NOT HAPPEN WITH THE IDATSW = 'FREQ' CASE.) C J=NUMCLA DO550I=1,N AJ=J CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP IF(X(I).EQ.CLMAXJ)D2(J)=D2(J)+Y(I) 550 CONTINUE GOTO590 C 590 CONTINUE IF(IBELOW.GE.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1591)IBELOW,XSTART 1591 FORMAT('***** WARNING: ',I8,' DATA POINTS ARE BELOW THE ', 1 'MINIMUM CLASS VALUE OF ',G15.7) CALL DPWRST('XXX','BUG ') ENDIF IF(IABOVE.GE.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1691)IABOVE,XSTOP 1691 FORMAT('***** WARNING: ',I8,' DATA POINTS ARE ABOVE THE ', 1 'MAXIMUM CLASS VALUE OF ',G15.7) CALL DPWRST('XXX','BUG ') ENDIF IF(IBUGG3.EQ.'OFF')GOTO595 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,591) 591 FORMAT('***** IN THE MIDDLE OF DPFRE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,592)CLWID,XSTART,XSTOP,TOTWID,ANUMCL,NUMCLA 592 FORMAT('CLWID,XSTART,XSTOP,TOTWID,ANUMCL,NUMCLA= ',5E11.4,I8) CALL DPWRST('XXX','BUG ') DO593J=1,NUMCLA AJ=J CLMINJ=XSTART+(AJ-1.0)*CLWID CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP FJ=D2(J) WRITE(ICOUT,594)J,CLMINJ,CLMAXJ,FJ 594 FORMAT('J,CLMINJ,CLMAXJ,FJ = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 593 CONTINUE 595 CONTINUE C C ********************************** C ** STEP 4-- ** C ** DETERMINE PLOT COORDINATES ** C ********************************** C IF(ICASPL.EQ.'FREQ')GOTO1100 IF(ICASPL.EQ.'CUMF')GOTO1200 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011) 1011 FORMAT('***** INTERNAL ERROR IN DPFRE2 ', 1'AT BRANCH POINT 1011--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1012) 1012 FORMAT(' ICASPL SHOULD BE EITHER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1013) 1013 FORMAT(' FREQ OR CUMF, BUT IS NEITHER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1014)ICASPL 1014 FORMAT(' ICASPL = ',A4) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1100 CONTINUE SUM=0.0 DO1110J=1,NUMCLA FJ=D2(J) SUM=SUM+FJ 1110 CONTINUE AN3=SUM C DENOM=1.0 IF(IRELAT.EQ.'ON')DENOM=AN3 C K=0 C K=K+1 J=1 AJ=J CLMINJ=XSTART+(AJ-1.0)*CLWID CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP X2(K)=CLMINJ-((CLMAXJ-CLMINJ)/2.0) Y2(K)=0.0 C DO1120J=1,NUMCLA K=K+1 AJ=J CLMINJ=XSTART+(AJ-1.0)*CLWID CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP FJ=D2(J) X2(K)=(CLMINJ+CLMAXJ)/2.0 Y2(K)=FJ/DENOM 1120 CONTINUE C K=K+1 J=NUMCLA AJ=J CLMINJ=XSTART+(AJ-1.0)*CLWID CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP X2(K)=CLMAXJ+((CLMAXJ-CLMINJ)/2.0) Y2(K)=0.0 C N2=K NPLOTV=2 C K=0 C K=K+1 D2(K)=1.0 C DO1130J=1,NUMCLA K=K+1 D2(K)=1.0 1130 CONTINUE C K=K+1 D2(K)=1.0 C GOTO9000 C 1200 CONTINUE SUM=0.0 DO1210J=1,NUMCLA FJ=D2(J) SUM=SUM+FJ 1210 CONTINUE AN3=SUM C DENOM=1.0 IF(IRELAT.EQ.'ON')DENOM=AN3 C K=0 SUM=0.0 C K=K+1 J=1 AJ=J CLMINJ=XSTART+(AJ-1.0)*CLWID CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP X2(K)=CLMINJ-((CLMAXJ-CLMINJ)/2.0) Y2(K)=0.0 C DO1220J=1,NUMCLA K=K+1 AJ=J CLMINJ=XSTART+(AJ-1.0)*CLWID CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP FJ=D2(J) SUM=SUM+FJ CUMFJ=SUM X2(K)=(CLMINJ+CLMAXJ)/2.0 Y2(K)=CUMFJ/DENOM 1220 CONTINUE C K=K+1 J=NUMCLA AJ=J CLMINJ=XSTART+(AJ-1.0)*CLWID CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP X2(K)=CLMAXJ+((CLMAXJ-CLMINJ)/2.0) Y2(K)=CUMFJ/DENOM C N2=K NPLOTV=2 C K=0 C K=K+1 D2(K)=1.0 C DO1230J=1,NUMCLA K=K+1 D2(K)=1.0 1230 CONTINUE C K=K+1 D2(K)=1.0 C GOTO9000 C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPFRE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,IRELAT,IERROR,N2 9012 FORMAT('ICASPL,IRELAT,IERROR,N2 = ',A4,2X,A4,2X,A4,2X,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IDATSW,AN3,DENOM 9013 FORMAT('IDATSW,AN3,DENOM = ',A4,2X,E15.8,E15.8) 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 9090 CONTINUE C RETURN END SUBROUTINE DPFREQ(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1CLLIMI,CLWIDT,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE ONE OF THE FOLLOWING 4 PLOTS-- C 1) FREQUENCY PLOT; C 2) RELATIVE FREQUENCY PLOT; C 3) CUMULATIVE FREQUENCY PLOT; C 4) RELATIVE CUMULATIVE FREQUENCY PLOT; C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--APRIL 1978. C UPDATED --JUNE 1978. C UPDATED --JULY 1978. C UPDATED --OCTOBER 1978. C UPDATED --APRIL 1979. C UPDATED --JANUARY 1981. C UPDATED --OCTOBER 1981. C UPDATED --MAY 1982. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IRELAT CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IDATSW CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHRIGH CHARACTER*4 IHRIG2 CHARACTER*4 IERRO4 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION CLLIMI(*) DIMENSION CLWIDT(*) C DIMENSION Y1(MAXOBV) DIMENSION X1(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),X1(1)) EQUIVALENCE (GARBAG(IGARB2),Y1(1)) CCCCC END CHANGE C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C ISUBN1='DPFR' ISUBN2='EQ ' 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 ICOLR=0 C C ********************************************** C ** TREAT THE FREQUENCY PLOT AND ** C ** RELATED STATISTICAL DISTRIBUTION PLOTS ** C ********************************************** C IF(IBUGG2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPFREQ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICASPL,IAND1,IAND2 52 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ 53 FORMAT('IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'FREQ'.AND.IHARG(1).EQ.'PLOT')GOTO110 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'RELA'.AND.IHARG(1).EQ.'FREQ'.AND.IHARG(2).EQ.'PLOT') 1GOTO120 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'CUMU'.AND.IHARG(1).EQ.'FREQ'.AND.IHARG(2).EQ.'PLOT') 1GOTO130 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'RELA'.AND.IHARG(1).EQ.'CUMU'.AND.IHARG(2).EQ.'FREQ'.AND. 1IHARG(3).EQ.'PLOT')GOTO140 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'CUMU'.AND.IHARG(1).EQ.'RELA'.AND.IHARG(2).EQ.'FREQ'.AND. 1IHARG(3).EQ.'PLOT')GOTO140 C IFOUND='NO' GOTO9000 C 110 CONTINUE ICASPL='FREQ' IRELAT='OFF' ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 120 CONTINUE ICASPL='FREQ' IRELAT='ON' ILASTC=2 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 130 CONTINUE ICASPL='CUMF' IRELAT='OFF' ILASTC=2 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 140 CONTINUE ICASPL='CUMF' IRELAT='ON' 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 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='1' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ******************************************** C ** STEP 2-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='2' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(1) IHLEF2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,211)IHLEFT,IHLEF2,ICOLL,NLEFT 211 FORMAT('IHLEFT,IHLEF2,ICOLL,NLEFT = ',A4,2X,A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') C C *************************************************************** C ** STEP 3-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS POSITIVE. ** C *************************************************************** C ISTEPN='3' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO390 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPFREQ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312) 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'FREQ'.AND.IRELAT.EQ.'OFF')WRITE(ICOUT,321) 321 FORMAT(' (FOR WHICH A FREQUENCY PLOT ') IF(ICASPL.EQ.'FREQ'.AND.IRELAT.EQ.'OFF')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'FREQ'.AND.IRELAT.EQ.'ON')WRITE(ICOUT,322) 322 FORMAT(' (FOR WHICH A RELATIVE FREQUENCY PLOT ') IF(ICASPL.EQ.'FREQ'.AND.IRELAT.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'CUMF'.AND.IRELAT.EQ.'OFF')WRITE(ICOUT,323) 323 FORMAT(' (FOR WHICH A CUMULATIVE FREQUENCY PLOT ') IF(ICASPL.EQ.'CUMF'.AND.IRELAT.EQ.'OFF')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'CUMF'.AND.IRELAT.EQ.'ON')WRITE(ICOUT,324) 324 FORMAT(' (FOR WHICH A RELATIVE CUMULATIVE FREQUENCY ', 1'PLOT ') IF(ICASPL.EQ.'CUMF'.AND.IRELAT.EQ.'ON')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' WAS TO HAVE BEEN FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)MINN2 315 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,316) 316 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,317) 317 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,318)(IANS(I),I=1,IWIDTH) 318 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 390 CONTINUE C C ***************************************** C ** STEP 4-- ** C ** CHECK TO SEE THE TYPE SUBCASE ** C ** (BASED ON THE QUALIFIER)-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='4' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO480 DO400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO420 400 CONTINUE GOTO490 410 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO490 420 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO490 C 480 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,481) 481 FORMAT('***** INTERNAL ERROR IN DPFREQ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,482) 482 FORMAT(' AT BRANCH POINT 481--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,483) 483 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,484) 484 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,485)NUMARG 485 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,486) 486 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,487)(IANS(I),I=1,IWIDTH) 487 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 490 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ,ICASEQ 491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C ****************************************************** C ** STEP 5-- ** C ** IF A SECOND ARGUMENT EXISTS, THEN THIS ** C ** INDICATES THAT THE VALUES IN THE ** C ** FIRST VARIABLE ARE NOT DATA POINTS ** C ** BUT ALREADY-COMPUTED FREQUENCIES, ** C ** AND THE VALUES IN THE SECOND VARIABLE ** C ** ARE THE CORRESPONDING X VALUES FOR EACH ** C ** FREQUENCY. IF WE HAVE THE 2-VARIABLE CASE, ** C ** CHECK THE VALIDITY OF THE SECOND (X) VARIABLE. ** C ****************************************************** C ISTEPN='5' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IDATSW='RAW' IF(NUMV2.EQ.1)IDATSW='RAW' IF(NUMV2.EQ.1)GOTO590 IF(NUMV2.EQ.2)IDATSW='FREQ' IF(NUMV2.EQ.2)GOTO509 GOTO550 C 509 CONTINUE IHRIGH=IHARG(2) IHRIG2=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHRIGH,IHRIG2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLR=IVALUE(ILOCV) NRIGHT=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,511)IHRIGH,IHRIG2,ICOLR,NRIGHT 511 FORMAT('IHRIGH,IHRIG2,ICOLR,NRIGHT = ',A4,2X,A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') 510 CONTINUE C IF(NRIGHT.NE.NLEFT)GOTO570 GOTO590 C 550 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,551) 551 FORMAT('***** ERROR IN DPFREQ--') CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'FREQ'.AND.IRELAT.EQ.'OFF')WRITE(ICOUT,552) 552 FORMAT(' FOR A FREQUENCY PLOT, ') IF(ICASPL.EQ.'FREQ'.AND.IRELAT.EQ.'OFF')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'FREQ'.AND.IRELAT.EQ.'ON')WRITE(ICOUT,553) 553 FORMAT(' FOR A RELATIVE FREQUENCY PLOT, ') IF(ICASPL.EQ.'FREQ'.AND.IRELAT.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'CUMF'.AND.IRELAT.EQ.'OFF')WRITE(ICOUT,554) 554 FORMAT(' FOR A CUMULATIVE FREQUENCY PLOT, ') IF(ICASPL.EQ.'CUMF'.AND.IRELAT.EQ.'OFF')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'CUMF'.AND.IRELAT.EQ.'ON')WRITE(ICOUT,555) 555 FORMAT(' FOR A RELATIVE CUMULATIVE FREQUENCY PLOT, ') IF(ICASPL.EQ.'CUMF'.AND.IRELAT.EQ.'ON')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,558) 558 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) 559 FORMAT(' MUST BE EITHER 1 OR 2 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,560) 560 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,561) 561 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,562)NUMV2 562 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,563) 563 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,564)(IANS(I),I=1,IWIDTH) 564 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 570 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,571) 571 FORMAT('***** ERROR IN DPFREQ--') CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'FREQ'.AND.IRELAT.EQ.'OFF')WRITE(ICOUT,572) 572 FORMAT(' FOR A FREQUENCY PLOT, ') IF(ICASPL.EQ.'FREQ'.AND.IRELAT.EQ.'OFF')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'FREQ'.AND.IRELAT.EQ.'ON')WRITE(ICOUT,573) 573 FORMAT(' FOR A RELATIVE FREQUENCY PLOT, ') IF(ICASPL.EQ.'FREQ'.AND.IRELAT.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'CUMF'.AND.IRELAT.EQ.'OFF')WRITE(ICOUT,574) 574 FORMAT(' FOR A CUMULATIVE FREQUENCY PLOT, ') IF(ICASPL.EQ.'CUMF'.AND.IRELAT.EQ.'OFF')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'CUMF'.AND.IRELAT.EQ.'ON')WRITE(ICOUT,575) 575 FORMAT(' FOR A RELATIVE CUMULATIVE FREQUENCY PLOT, ') IF(ICASPL.EQ.'CUMF'.AND.IRELAT.EQ.'ON')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,578) 578 FORMAT(' WHEN HAVE 2 VARIABLES SPECIFIED, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,579) 579 FORMAT(' THE NUMBER OF ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,580) 580 FORMAT(' IN THE 2 VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,581) 581 FORMAT(' MUST BE THE SAME; ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,582) 582 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,583) 583 FORMAT(' THE FIRST VARIABLE (FREQUENCIES)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,584)IHLEFT,IHLEF2,NLEFT 584 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,585) 585 FORMAT(' THE SECOND VARIABLE (HORIZ. AXIS VALUES)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,586)IHRIGH,IHRIG2,NRIGHT 586 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,587) 587 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,588)(IANS(I),I=1,IWIDTH) 588 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 590 CONTINUE C C ***************************************** C ** STEP 6-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** (BASED ON THE QUALIFIER) ** C ** THEN FORM THE RESPONSE VARIABLE ** C ** AND THE FACTORS ** C ** AND CARRY OUT THE PLOTS. ** C ***************************************** C ISTEPN='6' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO610 IF(ICASEQ.EQ.'SUBS')GOTO620 IF(ICASEQ.EQ.'FOR')GOTO630 C 610 CONTINUE DO615I=1,NLEFT ISUB(I)=1 615 CONTINUE NQ=NLEFT GOTO650 C 620 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4) NQ=NIOLD GOTO650 C 630 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO650 C 650 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO660I=1,IMAX IF(ISUB(I).EQ.0)GOTO660 J=J+1 C IF(NUMV2.LE.1)GOTO651 GOTO652 C 651 CONTINUE IJ=MAXN*(ICOLL-1)+I IF(ICOLL.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLL.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLL.EQ.MAXCP2)X1(J)=RES(I) IF(ICOLL.EQ.MAXCP3)X1(J)=YPLOT(I) IF(ICOLL.EQ.MAXCP4)X1(J)=XPLOT(I) IF(ICOLL.EQ.MAXCP5)X1(J)=X2PLOT(I) IF(ICOLL.EQ.MAXCP6)X1(J)=TAGPLO(I) GOTO660 C 652 CONTINUE IJ=MAXN*(ICOLR-1)+I IF(ICOLR.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLR.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLR.EQ.MAXCP2)X1(J)=RES(I) IF(ICOLR.EQ.MAXCP3)X1(J)=YPLOT(I) IF(ICOLR.EQ.MAXCP4)X1(J)=XPLOT(I) IF(ICOLR.EQ.MAXCP5)X1(J)=X2PLOT(I) IF(ICOLR.EQ.MAXCP6)X1(J)=TAGPLO(I) 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) GOTO660 C 660 CONTINUE NLOCAL=J C C **************************************************************** C ** STEP 7-- C ** DETERMINE IF THE ANALYST C ** HAS SPECIFIED 1) THE CLASS WIDTH, C ** 2) THE MIN POINT OF THE FIRST CELL, C ** 3) THE MAX POINT OF THE LAST CELL, C ** FOR THE DISTRIBUTIONAL ANALYSIS. C ** IF NON-DEFAULT, USE THE SPECIFIED VALUES. C ** IF DEFAULT, USE THE DEFAULT VALUES-- C ** 1) CLASS WIDTH = .3 OF A SAMPLE STANDARD DEVIATION; C ** 2) START = SAMPLE MEAN - 6*(SAMPLE STANDARD DEVIATION); C ** 3) STOP = SAMPLE MEAN + 6*(SAMPLE STANDARD DEVIATION); C ** NOTE THAT THE DEFAULT SETTINGS ARE IN FACT C **************************************************************** C ISTEPN='7' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CLWID=CLWIDT(1) XSTART=CLLIMI(1) XSTOP=CLLIMI(2) C C ***************************************************** C ** STEP 8-- ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** C ** RESET THE VECTOR D(.) TO ALL ONES. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ***************************************************** C CALL DPFRE2(Y1,X1,NLOCAL,ICASPL,IRELAT,IDATSW,CLWID,XSTART,XSTOP, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPFREQ--') 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)IRELAT,CLWID,XSTART,XSTOP 9014 FORMAT('IRELAT,CLWID,XSTART,XSTOP = ',A4,2X,3E15.7) CALL DPWRST('XXX','BUG ') IF(NPLOTP.LE.0)GOTO9090 DO9015I=1,NPLOTP WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPFRIE(YTEMP,XTEMP,MAXNXT, 1ICAPSW, 1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--CARRY OUT FRIEDMAN TEST C NON-PARAMETRIC TWO-WAY ANOVA C EXAMPLE--FRIEDMAN TEST Y X1 X2 C REFERENCE--XX 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/10 C ORIGINAL VERSION--OCTOBER 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICAPSW CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ C CHARACTER*4 IH11 CHARACTER*4 IH12 CHARACTER*4 IH21 CHARACTER*4 IH22 CHARACTER*4 IH31 CHARACTER*4 IH32 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 IUSE1 CHARACTER*4 IUSE2 CHARACTER*4 IUSE3 C CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IHOST1 CHARACTER*4 ISUBN0 C C--------------------------------------------------------------------- C DIMENSION YTEMP(*) DIMENSION XTEMP(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION XTEMP2(MAXOBV) DIMENSION DBLOCK(MAXOBV) DIMENSION DTREAT(MAXOBV) DIMENSION YRANK(MAXOBV) DIMENSION RJ(MAXOBV) C INCLUDE 'DPCOZZ.INC' EQUIVALENCE(GARBAG(IGARB1),XTEMP2(1)) EQUIVALENCE(GARBAG(IGARB2),DBLOCK(1)) EQUIVALENCE(GARBAG(IGARB3),DTREAT(1)) EQUIVALENCE(GARBAG(IGARB4),YRANK(1)) EQUIVALENCE(GARBAG(IGARB5),RJ(1)) 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='DPFR' ISUBN2='IE ' 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 N1=(-999) N2=(-999) C NS1=(-999) NS2=(-999) C IUSE1='-999' IUSE2='-999' C ILOCV=(-999) C VALUE1=(-999.0) VALUE2=(-999.0) C ICOL1=(-999) ICOL2=(-999) C MINN2=4 C IFOUND='YES' C NLEFT=0 C ICASEQ='UNKN' C C ****************************************** C ** TREAT THE FRIEDMAN TEST CASE ** C ****************************************** C IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRIE')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPFRIE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ 52 FORMAT('IBUGA2,IBUGA3,IBUBQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICAPSW,ICAPTY 53 FORMAT('ICAPSW,ICAPTY = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)MAXNXT 55 FORMAT('MAXNXT = ',I8) 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')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 11-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS SHULD BE A VARIABLE.) ** C **************************************** C ISTEPN='11' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRIE') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IH11=IHARG(1) IH12=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IH11,IH12,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) C IF(IERROR.EQ.'YES')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN FRIEDMAN TEST--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' FOR THE FRIEDMAN TEST, THE FIRST ARGUMENT (THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1145) 1145 FORMAT(' RESPONSE VARIABLE) MUST BE A VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1146) 1146 FORMAT(' (AS OPPOSED TO A PARAMETER OR FUNCTION).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1147) 1147 FORMAT(' ARGUMENT 1 WAS NOT A VARIABLE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1148) 1148 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,1150)(IANS(I),I=1,MIN(IWIDTH,80)) 1150 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C IUSE1=IUSE(ILOCV) ICOL1=IVALUE(ILOCV) N1=IN(ILOCV) 1190 CONTINUE C C ******************************************************* C ** STEP 12-- ** C ** IF ARGUMENT 1 IS A VARIABLE, ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (N1) ** C ** FOR ARGUMENT 1 IS 4 OR MORE. ** C ******************************************************* C ISTEPN='12' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRIE') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IUSE1.EQ.'V' .AND. N1.LE.MINN2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** ERROR IN FRIEDMAN TEST--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212) 1212 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR WHICH THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1214) 1214 FORMAT(' FRIEDMAN TEST WAS TO HAVE BEEN CARRIED OUT MUST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1216)MINN2 1216 FORMAT(' BE ',I8,' OR LARGER; SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1218)IH11,IH12,N1 1218 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1219) 1219 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,1220)(IANS(I),I=1,MIN(IWIDTH,80)) 1220 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C C **************************************** C ** STEP 21-- ** C ** CHECK THE VALIDITY OF ARGUMENT 2 ** C ** (THIS SHOULD ALSO BE A VARIABLE) ** C **************************************** C ISTEPN='21' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRIE') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IH21=IHARG(2) IH22=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IH21,IH22,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) C IF(IERROR.EQ.'YES')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2141) 2141 FORMAT('***** ERROR IN THE FRIEDMAN TEST--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2142) 2142 FORMAT(' FOR THE FRIEDMAN TEST, THE SECOND ARGUMENT (THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2145) 2145 FORMAT(' FIRST FACTOR (= BLOCK) VARIABLE) MUST BE A') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2146) 2146 FORMAT(' VARIABLE (AS OPPOSED TO A PARAMETER OR') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2147) 2147 FORMAT(' FUNCTION). ARGUMENT 2 WAS NOT A VARIABLE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2148) 2148 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2150)(IANS(I),I=1,MIN(IWIDTH,80)) 2150 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C IUSE2=IUSE(ILOCV) ICOL2=IVALUE(ILOCV) N2=IN(ILOCV) C C ******************************************************* C ** STEP 21B-- ** C ** IF ARGUMENT 2 IS A VARIABLE, ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (N2) ** C ** FOR ARGUMENT 2 IS THE SAME AS ARGUMENT 1. ** C ******************************************************* C ISTEPN='21B' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRIE') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IUSE2.EQ.'V' .AND. N1.NE.N2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2161) 2161 FORMAT('***** ERROR IN THE FRIEDMAN TEST--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2162) 2162 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR VARIABLE 2') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2163) 2163 FORMAT(' OF THE FRIEDMAN TEST MUST BE THE SAME AS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2165) 2165 FORMAT(' VARIABLE 1. SUCH WAS NOT THE CASE HERE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2166)N1,N2 2166 FORMAT(' N1 = ',I8,' N2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2169) 2169 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2170)(IANS(I),I=1,MIN(IWIDTH,80)) 2170 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C C **************************************** C ** STEP 22-- ** C ** CHECK THE VALIDITY OF ARGUMENT 3 ** C ** (THIS SHOULD ALSO BE A VARIABLE) ** C **************************************** C ISTEPN='22' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRIE') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IH31=IHARG(3) IH32=IHARG2(3) IHWUSE='V' MESSAG='YES' CALL CHECKN(IH31,IH32,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) C IF(IERROR.EQ.'YES')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2241) 2241 FORMAT('***** ERROR IN THE FRIEDMAN TEST--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2242) 2242 FORMAT(' FOR THE FRIEDMAN TEST, THE THIRD ARGUMENT (THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2245) 2245 FORMAT(' SECOND FACTOR (= TREATMENT) VARIABLE) MUST BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2246) 2246 FORMAT(' A VARIABLE (AS OPPOSED TO A PARAMETER OR') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2247) 2247 FORMAT(' FUNCTION). ARGUMENT 3 WAS NOT A VARIABLE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2248) 2248 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2250)(IANS(I),I=1,MIN(IWIDTH,80)) 2250 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C IUSE3=IUSE(ILOCV) ICOL3=IVALUE(ILOCV) N3=IN(ILOCV) C C ******************************************************* C ** STEP 21B-- ** C ** IF ARGUMENT 3 IS A VARIABLE, ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (N3) ** C ** FOR ARGUMENT 3 IS THE SAME AS ARGUMENT 1. ** C ******************************************************* C ISTEPN='22B' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRIE') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IUSE3.EQ.'V' .AND. N1.NE.N3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2261) 2261 FORMAT('***** ERROR IN THE FRIEDMAN TEST--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2262) 2262 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR VARIABLE 3') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2263) 2263 FORMAT(' OF THE FRIEDMAN TEST MUST BE THE SAME AS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2265) 2265 FORMAT(' VARIABLE 1. SUCH WAS NOT THE CASE HERE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2266)N1,N3 2266 FORMAT(' N1 = ',I8,' N3 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2269) 2269 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2270)(IANS(I),I=1,MIN(IWIDTH,80)) 2270 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C C ***************************************** C ** STEP 40-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='40' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO4090 DO4000J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO4010 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO4010 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO4020 4000 CONTINUE GOTO4090 4010 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO4090 4020 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO4090 4090 CONTINUE IF(IBUGA2.EQ.'OFF')GOTO4095 WRITE(ICOUT,4091)NUMARG,ILOCQ 4091 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 4095 CONTINUE C C *********************************************** C ** STEP 41-- ** C ** TEMPORARILY FORM THE VARIABLE Y(.) ** C ** WHICH WILL HOLD THE DATA FROM SAMPLE 1. ** C ** FORM THIS VARIABLE BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C *********************************************** C ISTEPN='41' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO4110 IF(ICASEQ.EQ.'SUBS')GOTO4120 IF(ICASEQ.EQ.'FOR')GOTO4130 C 4110 CONTINUE DO4115I=1,N1 ISUB(I)=1 4115 CONTINUE NQ=N1 GOTO4150 C 4120 CONTINUE NIOLD=N1 CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO4150 C 4130 CONTINUE NIOLD=N1 CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO4150 C 4150 CONTINUE IF(NQ.LE.MINN2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4151) 4151 FORMAT('***** ERROR IN THE FRIEDMAN TEST--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4152) 4152 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4153)IH11,IH12 4153 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING FROM ', 1 'VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4154) 4154 FORMAT(' (FOR WHICH THE FRIEDMAN TEST IS TO BE CARRIED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4156)MINN2 4156 FORMAT(' OUT) MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4157)NQ 4157 FORMAT(' SUCH WAS NOT THE CASE HERE. (N = ',I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4158) 4158 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,4159)(IANS(I),I=1,MIN(IWIDTH,80)) 4159 FORMAT(' ',80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C J=0 IMAX=N1 IF(NQ.LT.N1)IMAX=NQ DO4170I=1,IMAX IF(ISUB(I).EQ.0)GOTO4170 J=J+1 C IJ=MAXN*(ICOL1-1)+I IF(ICOL1.LE.MAXCOL)Y(J)=V(IJ) IF(ICOL1.EQ.MAXCP1)Y(J)=PRED(I) IF(ICOL1.EQ.MAXCP2)Y(J)=RES(I) IF(ICOL1.EQ.MAXCP3)Y(J)=YPLOT(I) IF(ICOL1.EQ.MAXCP4)Y(J)=XPLOT(I) IF(ICOL1.EQ.MAXCP5)Y(J)=X2PLOT(I) IF(ICOL1.EQ.MAXCP6)Y(J)=TAGPLO(I) C IJ=MAXN*(ICOL2-1)+I IF(ICOL2.LE.MAXCOL)X(J)=V(IJ) IF(ICOL2.EQ.MAXCP1)X(J)=PRED(I) IF(ICOL2.EQ.MAXCP2)X(J)=RES(I) IF(ICOL2.EQ.MAXCP3)X(J)=YPLOT(I) IF(ICOL2.EQ.MAXCP4)X(J)=XPLOT(I) IF(ICOL2.EQ.MAXCP5)X(J)=X2PLOT(I) IF(ICOL2.EQ.MAXCP6)X(J)=TAGPLO(I) C IJ=MAXN*(ICOL3-1)+I IF(ICOL2.LE.MAXCOL)XTEMP2(J)=V(IJ) IF(ICOL2.EQ.MAXCP1)XTEMP2(J)=PRED(I) IF(ICOL2.EQ.MAXCP2)XTEMP2(J)=RES(I) IF(ICOL2.EQ.MAXCP3)XTEMP2(J)=YPLOT(I) IF(ICOL2.EQ.MAXCP4)XTEMP2(J)=XPLOT(I) IF(ICOL2.EQ.MAXCP5)XTEMP2(J)=X2PLOT(I) IF(ICOL2.EQ.MAXCP6)XTEMP2(J)=TAGPLO(I) C 4170 CONTINUE NS1=J C C ********************************** C ** STEP 52-- ** C ** CARRY OUT THE FRIEDMAN TEST ** C ********************************** C ISTEPN='52' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRIE') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FRIE')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5211) 5211 FORMAT('***** FROM DPFRIE, AS WE ARE ABOUT TO CALL DPFRI2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5212)N1,N2,N3,NS1,MAXN 5212 FORMAT('N1,N2,N3,NS1,MAXN = ',5I8) CALL DPWRST('XXX','BUG ') DO5215I=1,NS1 WRITE(ICOUT,5216)I,Y(I),X(I),XTEMP2(I) 5216 FORMAT('I,Y(I),X(I),XTEMP2(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 5215 CONTINUE WRITE(ICOUT,5231)IBUGA3 5231 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') ENDIF C CALL DPFRI2(Y,X,XTEMP2,NS1, 1YTEMP,XTEMP,YRANK,RJ,DBLOCK,DTREAT,MAXNXT, 1STATVA,STATCD,CUT0,CUT50,CUT75,CUT90,CUT95,CUT99,CUT999, 1ICAPSW,ICAPTY, 1IBUGA3,ISUBRO,IERROR) C C *************************************** C ** STEP 61-- ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C ISTEPN='61' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRIE') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ISUBN0='DPFR' C IH='STAT' IH2='VAL ' VALUE0=STATVA CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='STAT' IH2='CDF ' VALUE0=STATCD CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF0 ' VALUE0=CUT0 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF50' VALUE0=CUT50 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF75' VALUE0=CUT75 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF90' VALUE0=CUT90 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF95' VALUE0=CUT95 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF99' VALUE0=CUT99 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='F999' VALUE0=CUT99 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FRI2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPFRIE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA2,IBUGA3,IBUGQ 9012 FORMAT('IBUGA2,IBUGA3,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)N1,N2,N3,NS1 9014 FORMAT('N1,N2,N3,NS1 = ',4I8) 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 DPFRIT(IHARG,IARGT,ARG,NUMARG,IDEFFI, 1IFRAIT,IFOUND,IERROR) C C PURPOSE--DEFINE THE FRACTAL ITERATIONS C THIS DEFINES THE MAXIMUM NUMBER OF POINTS TO C PLOT FOR FRACTAL PLOTS. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --ARG (A FLOATING POINT VECTOR) C --NUMARG (AN INTEGER VARIABLE) C --IDEFFI (A FLOATING POINT VARIABLE) C OUTPUT ARGUMENTS--IFRAIT (AN INTEGER VARIABLE) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY-ALAN HECKERT C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--93/7 C ORIGINAL VERSION--JULY 1993. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(NUMARG.EQ.0)GOTO1199 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ITER')GOTO1110 GOTO1199 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 GOTO1120 C 1120 CONTINUE IERROR='YES' WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPFRIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' ILLEGAL FORM FOR FRACTAL ITERATIONS ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1124) 1124 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1131) 1131 FORMAT(' FRACTAL ITERATIONS 20000') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE IHOLD=IDEFFI GOTO1180 C 1160 CONTINUE IHOLD=ARG(NUMARG)+0.5 IF(IHOLD.LE.0)IHOLD=IDEFFI GOTO1180 C 1180 CONTINUE IFOUND='YES' IFRAIT=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IFRAIT 1181 FORMAT('THE FRACTAL ITERATIONS HAS JUST BEEN SET TO ', 1I8) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPFRI2(Y,BLOCK,TREAT,N, 1YTEMP,XTEMP,YRANK,RJ,DBLOCK,DTREAT,MAXNXT, 1STATVA,STATCD,CUT0,CUT50,CUT75,CUT90,CUT95,CUT99,CUT999, 1ICAPSW,ICAPTY, 1IBUGA3,ISUBRO,IERROR) C C PURPOSE--THIS ROUTINE CARRIES OUT FRIEDMAN'S TEST C NON-PARAMETRIC TWO-WAY ANOVA C EXAMPLE--FRIEDMAN TEST Y BLOCK TREAT C REFERENCE--"PRACTICAL NON-PARAMETRIC STATSTICS", CONOVER, 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/10 C ORIGINAL VERSION--OCTOBER 2003. C UPDATED --JANUARY 2006. FIX BUG IN RANKING C (UNCORRECTED VERSION WORKS C IF DATA ARE RANKS WITHIN C THE BLOCK). C UPDATED --JANUARY 2006. SOME INFO THAT WAS SUPPOSSED C TO GO TO DPST2F.DAT WAS C GOING TO DPST1F.DAT C UPDATED --OCTOBER 2006. CALL LIST TO TPPF C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICAPSW CHARACTER*4 ICAPTY CHARACTER*1 IBASLC CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 IWRITE C CHARACTER*6 ICONC1 CHARACTER*6 ICONC2 CHARACTER*6 ICONC3 C CHARACTER*4 ISUBN0 CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*3 IATEMP C DOUBLE PRECISION DSUM1 C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION BLOCK(*) DIMENSION TREAT(*) DIMENSION YRANK(*) DIMENSION RJ(*) DIMENSION DBLOCK(*) DIMENSION DTREAT(*) DIMENSION YTEMP(*) DIMENSION XTEMP(*) C INCLUDE 'DPCOF2.INC' C CHARACTER*80 IFILE1 CHARACTER*12 ISTAT1 CHARACTER*12 IFORM1 CHARACTER*12 IACCE1 CHARACTER*12 IPROT1 CHARACTER*12 ICURS1 CHARACTER*4 IERRF1 CHARACTER*4 IENDF1 CHARACTER*4 IREWI1 C CHARACTER*80 IFILE2 CHARACTER*12 ISTAT2 CHARACTER*12 IFORM2 CHARACTER*12 IACCE2 CHARACTER*12 IPROT2 CHARACTER*12 ICURS2 CHARACTER*4 IERRF2 CHARACTER*4 IENDF2 CHARACTER*4 IREWI2 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPFR' ISUBN2='I2 ' C IERROR='NO' C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRI2')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,51) 51 FORMAT('**** AT THE BEGINNING OF DPFRI2--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,55)N 55 FORMAT('N = ',I8) CALL DPWRST('XXX','WRIT') DO56I=1,N WRITE(ICOUT,57)I,Y(I),BLOCK(I),TREAT(I) 57 FORMAT('I,Y(I),BLOCK(I),TREAT(I) = ',I8,3E15.7) CALL DPWRST('XXX','WRIT') 56 CONTINUE ENDIF C C ******************************************** C ** STEP 11-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C ISTEPN='11' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRI2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C HOLD=Y(1) DO1135I=2,N IF(Y(I).NE.HOLD)GOTO1139 1135 CONTINUE 1130 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1131)HOLD 1131 FORMAT('***** NOTE FROM FRIEDMAN TEST--RESPONSE VARIABLE ', 1 'HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','WRIT') GOTO9000 1139 CONTINUE C HOLD=BLOCK(1) DO1235I=2,N IF(BLOCK(I).NE.HOLD)GOTO1239 1235 CONTINUE 1230 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1231)HOLD 1231 FORMAT('***** NOTE FROM FRIEDMAN TEST--FIRST FACTOR VARIABLE ', 1 'HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','WRIT') GOTO9000 1239 CONTINUE C HOLD=TREAT(1) DO1335I=2,N IF(TREAT(I).NE.HOLD)GOTO1339 1335 CONTINUE 1330 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1331)HOLD 1331 FORMAT('***** NOTE FROM FRIEDMAN TEST--SECOND FACTOR VARIABLE ', 1 'HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','WRIT') GOTO9000 1339 CONTINUE C C ****************************** C ** STEP 41-- ** C ** CARRY OUT CALCULATIONS ** C ** FOR FRIEDMAN TEST ** C ****************************** C ISTEPN='41' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IWRITE='OFF' C C STEP 1: COMPUTE NUMBER OF DISTINCT BLOCKS AND TREATMENTS C CALL DISTIN(BLOCK,N,IWRITE,DBLOCK,NBLOCK,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 CALL DISTIN(TREAT,N,IWRITE,DTREAT,NTREAT,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C STEP 2: COMPUTE TREATMENT RANKS WITHIN EACH BLOCK C DO4010I=1,N YRANK(I)=-1.0 4010 CONTINUE C DO4110I=1,NBLOCK HOLD=DBLOCK(I) ICOUNT=0 DO4120J=1,N IF(BLOCK(J).EQ.HOLD)THEN ICOUNT=ICOUNT+1 YTEMP(ICOUNT)=Y(J) ENDIF 4120 CONTINUE CALL RANK(YTEMP,ICOUNT,IWRITE,XTEMP,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOUNT=0 DO4130J=1,N IF(BLOCK(J).EQ.HOLD)THEN ICOUNT=ICOUNT+1 CCCCC 2006/1: EXTRACT RANKING CORRECTLY! CCCCC YTEMP(ICOUNT)=Y(J) CCCCC YRANK(J)=YTEMP(ICOUNT) YRANK(J)=XTEMP(ICOUNT) ENDIF 4130 CONTINUE 4110 CONTINUE IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRI2')THEN DO4140I=1,N WRITE(ICOUT,4142)I,Y(I),YRANK(I) 4142 FORMAT('I,Y(I),YRANK(I) = ',I8,E15.7,F12.2) CALL DPWRST('XXX','BUG ') 4140 CONTINUE ENDIF C C STEP 3: NOW COMPUTE RANK SUMS FOR EACH TREATMENT C DO4210I=1,NTREAT HOLD=DTREAT(I) DSUM1=0.0D0 DO4220J=1,N IF(TREAT(J).EQ.HOLD)THEN DSUM1=DSUM1 + DBLE(YRANK(J)) ENDIF 4220 CONTINUE RJ(I)=REAL(DSUM1) 4210 CONTINUE IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRI2')THEN DO4240I=1,NTREAT WRITE(ICOUT,4242)I,RJ(I) 4242 FORMAT('I,RJ(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 4240 CONTINUE ENDIF C C STEP 4: NOW COMPUTE VARIOUS QUANTITIES BASED ON RJ C ANB=REAL(NBLOCK) AK=REAL(NTREAT) C1=ANB*AK*(AK+1.0)**2/4.0 DSUM1=0.0D0 DO4310I=1,N DSUM1=DSUM1 + DBLE(YRANK(I))**2 4310 CONTINUE A1=REAL(DSUM1) DSUM1=0.0D0 DO4320I=1,NTREAT DSUM1=DSUM1 + RJ(I)**2 4320 CONTINUE T1=(AK-1.0)*(REAL(DSUM1)-ANB*C1)/(A1-C1) T2=(ANB-1.0)*T1/(ANB*(AK-1.0) - T1) C STATVA=T2 NUMDF1=NTREAT-1 NUMDF2=(NBLOCK-1)*(NTREAT-1) CALL FCDF(STATVA,NUMDF1,NUMDF2,STATCD) C CUT0=0.0 CALL FPPF(.50,NUMDF1,NUMDF2,CUT50) CALL FPPF(.75,NUMDF1,NUMDF2,CUT75) CALL FPPF(.90,NUMDF1,NUMDF2,CUT90) CALL FPPF(.95,NUMDF1,NUMDF2,CUT95) CALL FPPF(.99,NUMDF1,NUMDF2,CUT99) CALL FPPF(.999,NUMDF1,NUMDF2,CUT999) C IDF=(NBLOCK-1)*(NTREAT-1) CALL TPPF(0.95,REAL(IDF),T95) CALL TPPF(0.975,REAL(IDF),T975) CALL TPPF(0.995,REAL(IDF),T995) TERM1=(A1-C1)*2.0*ANB/((ANB-1.0)*(AK-1.0)) TERM2=1.0 - T1/(ANB*(AK-1.0)) CONTRA=SQRT(TERM1*TERM2) CONTR1=T95*CONTRA CONTR2=T975*CONTRA CONTR3=T995*CONTRA C ICONC1='ACCEPT' ICONC2='ACCEPT' ICONC3='ACCEPT' C IF(STATVA.GT.CUT95)ICONC2='REJECT' C C ***************************** C ** STEP 42- ** C ** WRITE OUT THE TABLE ** C ***************************** C ISTEPN='42' IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRI2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOUNI1=IST1NU IFILE1=IST1NA ISTAT1=IST1ST IFORM1=IST1FO IACCE1=IST1AC IPROT1=IST1PR ICURS1=IST1CS ISUBN0='FRI2' IERRF1='NO' C IREWI1='ON' CALL DPOPFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IOUNI2=IST2NU IFILE2=IST2NA ISTAT2=IST2ST IFORM2=IST2FO IACCE2=IST2AC IPROT2=IST2PR ICURS2=IST2CS ISUBN0='FRI2' IERRF2='NO' C IREWI2='ON' CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C WRITE(IOUNI1,2005) 2005 FORMAT(4X,'RESPONSE',13X,'RANK',11X,'BLOCK',8X,'TREATMENT') DO2010I=1,N WRITE(IOUNI1,2011)Y(I),YRANK(I),BLOCK(I),TREAT(I) 2011 FORMAT(1X,E15.7,F15.2,F15.2,F15.2) 2010 CONTINUE C WRITE(IOUNI2,2021)CONTRA 2021 FORMAT(1X,'Contrast term: ',E15.7) WRITE(IOUNI2,2022)CONTR1 2022 FORMAT(1X,'Contrast term*t(0.95): ',E15.7) WRITE(IOUNI2,2023)CONTR2 2023 FORMAT(1X,'Contrast term*t(0.975): ',E15.7) WRITE(IOUNI2,2024)CONTR3 2024 FORMAT(1X,'Contrast term*t(0.995): ',E15.7) WRITE(IOUNI2,2025) 2025 FORMAT(10X,'I',10X,'J',8X,'R(I)-R(J)') C DO2030I=1,NTREAT DO2039J=1,NTREAT IF(I.LT.J)THEN ADIFF=RJ(I)-RJ(J) IATEMP=' ' IF(ABS(ADIFF).GE.CONTR1)IATEMP(1:1)='*' IF(ABS(ADIFF).GE.CONTR2)IATEMP(2:2)='*' IF(ABS(ADIFF).GE.CONTR3)IATEMP(3:3)='*' WRITE(IOUNI2,2037)I,J,ADIFF,IATEMP 2037 FORMAT(3X,I8,3X,I8,5X,E15.7,A3) ENDIF 2039 CONTINUE 2030 CONTINUE C IENDF1='OFF' IREWI1='ON' CALL DPCLFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1IENDF1,IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IENDF2='OFF' IREWI2='ON' CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1IENDF2,IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C C ****************************** C ** STEP 43-- ** C ** WRITE OUT EVERYTHING ** C ** FOR FRIEDMAN TEST ** C ****************************** C ISTEPN='43' IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRI2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'ON')THEN IF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'HTML')THEN C C STEP 1: WRITE HEADER C WRITE(ICOUT,5001) 5001 FORMAT('') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5002) 5002 FORMAT('
') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5003) 5003 FORMAT('FRIEDMAN TEST FOR IDENTICAL TREATMENT ', 1 'EFFECTS') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5004) 5004 FORMAT('


') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C C STEP 2: START LIST C WRITE(ICOUT,5005) 5005 FORMAT('
    ') CALL DPWRST('XXX','WRIT') C C STEP 2A: LIST ITEM 1 C WRITE(ICOUT,5006) 5006 FORMAT('
  1. Statistics:') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5007) 5007 FORMAT('

    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5011) 5011 FORMAT(' ') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) 5021 FORMAT(' ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) 5023 FORMAT(' ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) 5026 FORMAT(' ') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5041) 5041 FORMAT(' Number of Blocks:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5029)NBLOCK CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5042) 5042 FORMAT(' Number of Treatments:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5029)NTREAT CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) 5043 FORMAT(' Friedman Test Statstic (Original):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)T1 5051 FORMAT(' ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5044) 5044 FORMAT(' A1 (Sum of Squares of Ranks):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)A1 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5045) 5045 FORMAT(' C1 (Correction Factor):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)C1 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5046) 5046 FORMAT(' Friedman Test Statistic (Conover):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)STATVA CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5091) 5091 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5025) 5025 FORMAT(' Number of Observations:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) 5027 FORMAT(' ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5029)N 5029 FORMAT(' ',I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) 5028 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5007) CALL DPWRST('XXX','WRIT') C C STEP 2B: LIST ITEM 2 C WRITE(ICOUT,5066) 5066 FORMAT('

  2. Percent Points of the F Reference ', 1 'Distribution
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5067) 5067 FORMAT(' for Friedman Test Statistic:') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5007) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5011) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5071) 5071 FORMAT(' 0 Percent Point:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT0 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5072) 5072 FORMAT(' 50 Percent Point:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT50 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5073) 5073 FORMAT(' 75 Percent Point:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT75 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5074) 5074 FORMAT(' 90 Percent Point:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT90 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5075) 5075 FORMAT(' 95 Percent Point:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT95 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5076) 5076 FORMAT(' 99 Percent Point:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT99 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5077) 5077 FORMAT(' 99.9 Percent Point:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT999 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5078)100.0*STATCD 5078 FORMAT('
    ',G15.7,' Percent Point:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5052)STATVA 5052 FORMAT('
    ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5091) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5007) CALL DPWRST('XXX','WRIT') C C STEP 2C: LIST ITEM 3 C WRITE(ICOUT,5081) 5081 FORMAT('
  3. Conclusion (at the 5% level):') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5007) CALL DPWRST('XXX','WRIT') IF(STATVA.LE.CUT95)THEN WRITE(ICOUT,5087)NTREAT 5087 FORMAT(' The ',I8,' treatments have identical ', 1 'effects.') ELSE WRITE(ICOUT,5088)NTREAT 5088 FORMAT(' The ',I8,' treatments do not have ', 1 'identical effects.') ENDIF CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5093) 5093 FORMAT('
') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5095) 5095 FORMAT('
')
        CALL DPWRST('XXX','WRIT')
C
      ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'LATE')THEN
 8001   FORMAT('{',A1,'bf FRIEDMAN TEST FOR IDENTICAL TREATMENT ',
     1         'EFFECTS}')
 8002   FORMAT(A1,'begin{table}')
 8003   FORMAT(A1,'end{table}')
 8004   FORMAT(A1,'begin{center}')
 8005   FORMAT(A1,'end{center}')
 8006   FORMAT(A1,'end{verbatim}')
 8007   FORMAT(5X,'$ ',A1,1X,A1,' $ ',A1,A1)
 8011   FORMAT(A1,'begin{enumerate}')
 8012   FORMAT(A1,'end{enumerate}')
C
        CALL DPCONA(92,IBASLC)
C
        WRITE(ICOUT,8006)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8004)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8002)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8001)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,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8011)IBASLC
        CALL DPWRST('XXX','WRIT')
C
 8020   FORMAT(11X,A1,'newline')
 8021   FORMAT(5X,A1,'item Statistics:')
 8022   FORMAT(5X,A1,'item Percent Points of the F Reference ',
     1         'Distribution:')
 8023   FORMAT(5X,A1,'item Conclusion (at the 5',A1,'% level):')
 8030   FORMAT(11X,A1,'begin{tabular} {lr}')
 8031   FORMAT(11X,'Number of Observations: & ',I8,2X,A1,A1)
 8032   FORMAT(11X,'Number of Blocks: & ',I8,2X,A1,A1)
 8033   FORMAT(11X,'Number of Treatments: & ',I8,2X,A1,A1)
 8034   FORMAT(11X,'Friedman Test Statistic (Original): & ',G15.7,
     1         2X,A1,A1)
 8035   FORMAT(11X,'A1 (Sum of Squares of Ranks): & ',G15.7,2X,A1,A1)
 8036   FORMAT(11X,'C1 (Correction Factor): & ',G15.7,2X,A1,A1)
 8037   FORMAT(11X,'Friedman Test Statistic (Conover): & ',
     1         G15.7,2X,A1,A1)
 8040   FORMAT(11X,A1,'end{tabular}')
 8041   FORMAT(11X,G15.7,' Percent Point: & ',G15.7,2X,A1,A1)
 8042   FORMAT(11X,'The ',I8,' treatments have identical effects.',
     1         2X,A1,A1)
 8043   FORMAT(11X,'The ',I8,' treatments do not have identical ',
     1         'effects.',2X,A1,A1)
 8044   FORMAT(11X,'0      Percent Point: & ',G15.7,2X,A1,A1)
 8045   FORMAT(11X,'50     Percent Point: & ',G15.7,2X,A1,A1)
 8046   FORMAT(11X,'90     Percent Point: & ',G15.7,2X,A1,A1)
 8047   FORMAT(11X,'95     Percent Point: & ',G15.7,2X,A1,A1)
 8048   FORMAT(11X,'99     Percent Point: & ',G15.7,2X,A1,A1)
 8049   FORMAT(11X,'99.9   Percent Point: & ',G15.7,2X,A1,A1)
C
        WRITE(ICOUT,8021)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8020)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8030)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8031)N,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8032)NBLOCK,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8033)NTREAT,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8034)T1,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8035)A1,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8036)C1,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8037)STATVA,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8040)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,8022)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8020)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8030)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8044)CUT0,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8045)CUT50,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8046)CUT90,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8047)CUT95,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8048)CUT99,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8049)CUT999,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8041)100.*STATCD,STATVA,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8040)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,8023)IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8020)IBASLC
        CALL DPWRST('XXX','WRIT')
        IF(STATVA.LE.CUT95)THEN
          WRITE(ICOUT,8042)NTREAT,IBASLC,IBASLC
          CALL DPWRST('XXX','WRIT')
        ELSE
          WRITE(ICOUT,8043)NTREAT,IBASLC,IBASLC
          CALL DPWRST('XXX','WRIT')
        ENDIF
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
 8051   FORMAT(A1,'end{enumerate}')
 8052   FORMAT(A1,'begin{verbatim}')
        WRITE(ICOUT,8051)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8003)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8005)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8052)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
      ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'RTF')THEN
C
      ELSE
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7211)
 7211   FORMAT('              FRIEDMAN TEST FOR TWO-WAY ANOVA')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,7220)
 7220   FORMAT('1. STATISTICS')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7221)N
 7221   FORMAT(6X,'NUMBER OF OBSERVATIONS              = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7222)NBLOCK
 7222   FORMAT(6X,'NUMBER OF BLOCKS                    = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7223)NTREAT
 7223   FORMAT(6X,'NUMBER OF TREATMENTS                = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7224)T1
 7224   FORMAT(6X,'FRIEDMAN TEST STATISTIC (ORIGINAL)  = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7225)A1
 7225   FORMAT(6X,'A1 (SUM OF SQUARES OF RANKS)        = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7226)C1
 7226   FORMAT(6X,'C1 (CORRECTION FACTOR)              = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7228)STATVA
 7228   FORMAT(6X,'FRIEDMAN TEST STATISTIC (CONOVER)   = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7240)
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7240)
 7240   FORMAT('2. PERCENT POINTS OF THE F REFERENCE DISTRIBUTION')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7241)
 7241   FORMAT('   FOR FRIEDMAN TEST STATISTIC')
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,7265)CUT0
 7265   FORMAT(6X,'0          % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7266)CUT50
 7266   FORMAT(6X,'50         % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7267)CUT75
 7267   FORMAT(6X,'75         % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7268)CUT90
 7268   FORMAT(6X,'90         % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7269)CUT95
 7269   FORMAT(6X,'95         % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7270)CUT99
 7270   FORMAT(6X,'99         % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7271)CUT999
 7271   FORMAT(6X,'99.9       % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7280)100.*STATCD,STATVA
 7280   FORMAT(6X,G15.7,'   % Point:  ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,7291)
 7291   FORMAT('3. CONCLUSION (AT THE 5% LEVEL):')
        CALL DPWRST('XXX','WRIT')
        IF(STATVA.LE.CUT95)THEN
          WRITE(ICOUT,7293)NTREAT
 7293     FORMAT(6X,'THE ',I8,' TREATMENTS HAVE IDENTICAL EFFECTS')
          CALL DPWRST('XXX','WRIT')
        ELSE
          WRITE(ICOUT,7295)NTREAT
 7295     FORMAT(6X,'THE ',I8,' TREATMENTS DO NOT HAVE IDENTICAL ',
     1           'EFFECTS')
          CALL DPWRST('XXX','WRIT')
        ENDIF
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        IF(IFEEDB.EQ.'ON')THEN
          WRITE(ICOUT,9212)
 9212     FORMAT(6X,'RESPONSE, RANKED RESPONSE, BLOCK AND TREATMENT ',
     1           ' WRITTEN TO FILE DPST1F.DAT')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,9214)
 9214     FORMAT(6X,'TREATMENT RANKS AND COMPARISONS WRITTEN TO FILE ',
     1           ' DPST2F.DAT')
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
      ENDIF
      ENDIF
C
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRI2')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF DPFRI2--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9012)N,IBUGA3,IERROR
 9012   FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9015)N
 9015   FORMAT('N = ',I8)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE DPFRPA(ICOM,IHARG,IHARG2,NUMARG,
CCCCC AUGUST 1995.  ADD IHARG2 FOR DASH2, ETC
CCCCC SUBROUTINE DPFRPA(ICOM,IHARG,NUMARG,
     1IDEFPA,
     1IX1FPA,IX2FPA,IY1FPA,IY2FPA,
     1IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE FRAME PATTERN SWITCHES
C              FOR ANY OF THE 4 FRAME LINES.
C              SUCH FRAME PATTERN SWITCHES DEFINE THE PATTERN
C              FOR EACH OF THE 4 FRAME LINES.
C              THE CONTENTS OF A FRAME PATTERN SWITCH ARE
C              A PATTERN.
C              THE FRAME PATTERN SWITCHES FOR THE 4 FRAME LINES
C              ARE CONTAINED IN THE 4 VARIABLES
C              IX1FPA,IX2FPA,IY1FPA,IY2FPA.
C     INPUT  ARGUMENTS--ICOM
C                     --IHARG  (A  HOLLERITH VECTOR)
C                     --NUMARG
C                     --IDEFPA
C     OUTPUT ARGUMENTS--IX1FPA (A HOLLERITH VECTOR)
C                     --IX2FPA (A HOLLERITH VECTOR)
C                     --IY1FPA (A HOLLERITH VECTOR)
C                     --IY2FPA (A HOLLERITH VECTOR)
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--ALAN HECKERT
C                 COMPUTER SERVICES DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1980.
C     UPDATED         --MAY       1982.
C     UPDATED         --AUGUST    1995.  DASH2 BUG
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICOM
      CHARACTER*4 IHARG
CCCCC AUGUST 1995.  ADD FOLLOWING LINE
      CHARACTER*4 IHARG2
      CHARACTER*4 IDEFPA
C
      CHARACTER*4 IX1FPA
      CHARACTER*4 IX2FPA
      CHARACTER*4 IY1FPA
      CHARACTER*4 IY2FPA
C
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IHOLD
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
CCCCC AUGUST 1995.  ADD FOLLOWING LINE
      DIMENSION IHARG2(*)
C
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IFOUND='NO'
      IERROR='NO'
C
      IF(NUMARG.LE.0)GOTO1900
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PATT')GOTO1090
      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND.
     1IHARG(2).EQ.'PATT')GOTO1090
      GOTO1900
 1090 CONTINUE
C
C               *****************************************************
C               **  TREAT THE CASE WHEN                            **
C               **  BOTH HORIZONTAL FRAMES    ARE TO BE CHANGED    **
C               *****************************************************
C
      IF(ICOM.EQ.'XFRA')GOTO1100
      GOTO1199
C
 1100 CONTINUE
      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
      IF(IHARG(NUMARG).EQ.'PATT')GOTO1150
      GOTO1160
C
 1150 CONTINUE
      IHOLD=IDEFPA
      GOTO1180
C
 1160 CONTINUE
      IHOLD=IHARG(NUMARG)
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'2')IHOLD='DA2'
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'3')IHOLD='DA3'
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'4')IHOLD='DA4'
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'5')IHOLD='DA5'
      GOTO1180
C
 1180 CONTINUE
      IFOUND='YES'
      IX1FPA=IHOLD
      IX2FPA=IHOLD
C
      IF(IFEEDB.EQ.'OFF')GOTO1189
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)
 1181 FORMAT('THE FRAME PATTERN (FOR BOTH HORIZONTAL ',
     1'FRAME LINES)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)IHOLD
 1182 FORMAT('HAS JUST BEEN SET TO ',A4)
      CALL DPWRST('XXX','BUG ')
 1189 CONTINUE
      GOTO1900
C
 1199 CONTINUE
C
C               **************************************************************
C               **  TREAT THE CASE WHEN                                     **
C               **  ONLY THE BOTTOM HORIZONTAL FRAME IS      TO BE CHANGED  **
C               **************************************************************
C
      IF(ICOM.EQ.'X1FR')GOTO1200
      GOTO1299
C
 1200 CONTINUE
      IF(IHARG(NUMARG).EQ.'ON')GOTO1250
      IF(IHARG(NUMARG).EQ.'OFF')GOTO1250
      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250
      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250
      IF(IHARG(NUMARG).EQ.'PATT')GOTO1250
      GOTO1260
C
 1250 CONTINUE
      IHOLD=IDEFPA
      GOTO1280
C
 1260 CONTINUE
      IHOLD=IHARG(NUMARG)
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'2')IHOLD='DA2'
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'3')IHOLD='DA3'
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'4')IHOLD='DA4'
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'5')IHOLD='DA5'
      GOTO1280
C
 1280 CONTINUE
      IFOUND='YES'
      IX1FPA=IHOLD
C
      IF(IFEEDB.EQ.'OFF')GOTO1289
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1281)
 1281 FORMAT('THE FRAME PATTERN (FOR THE BOTTOM HORIZONTAL ',
     1'FRAME LINE)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1282)IHOLD
 1282 FORMAT('HAS JUST BEEN SET TO ',A4)
      CALL DPWRST('XXX','BUG ')
 1289 CONTINUE
      GOTO1900
C
 1299 CONTINUE
C
C               **************************************************************
C               **  TREAT THE CASE WHEN                                     **
C               **  ONLY THE TOP    HORIZONTAL FRAME IS      TO BE CHANGED  **
C               **************************************************************
C
      IF(ICOM.EQ.'X2FR')GOTO1300
      GOTO1399
C
 1300 CONTINUE
      IF(IHARG(NUMARG).EQ.'ON')GOTO1350
      IF(IHARG(NUMARG).EQ.'OFF')GOTO1350
      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350
      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350
      IF(IHARG(NUMARG).EQ.'PATT')GOTO1350
      GOTO1360
C
 1350 CONTINUE
      IHOLD=IDEFPA
      GOTO1380
C
 1360 CONTINUE
      IHOLD=IHARG(NUMARG)
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'2')IHOLD='DA2'
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'3')IHOLD='DA3'
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'4')IHOLD='DA4'
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'5')IHOLD='DA5'
      GOTO1380
C
 1380 CONTINUE
      IFOUND='YES'
      IX2FPA=IHOLD
C
      IF(IFEEDB.EQ.'OFF')GOTO1389
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1381)
 1381 FORMAT('THE FRAME PATTERN (FOR THE TOP HORIZONTAL ',
     1'FRAME LINE)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1382)IHOLD
 1382 FORMAT('HAS JUST BEEN SET TO ',A4)
      CALL DPWRST('XXX','BUG ')
 1389 CONTINUE
      GOTO1900
C
 1399 CONTINUE
C
C               *****************************************************
C               **  TREAT THE CASE WHEN                            **
C               **  BOTH VERTICAL   FRAMES    ARE TO BE CHANGED    **
C               *****************************************************
C
      IF(ICOM.EQ.'YFRA')GOTO1400
      GOTO1499
C
 1400 CONTINUE
      IF(IHARG(NUMARG).EQ.'ON')GOTO1450
      IF(IHARG(NUMARG).EQ.'OFF')GOTO1450
      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450
      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450
      IF(IHARG(NUMARG).EQ.'PATT')GOTO1450
      GOTO1460
C
 1450 CONTINUE
      IHOLD=IDEFPA
      GOTO1480
C
 1460 CONTINUE
      IHOLD=IHARG(NUMARG)
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'2')IHOLD='DA2'
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'3')IHOLD='DA3'
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'4')IHOLD='DA4'
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'5')IHOLD='DA5'
      GOTO1480
C
 1480 CONTINUE
      IFOUND='YES'
      IY1FPA=IHOLD
      IY2FPA=IHOLD
C
      IF(IFEEDB.EQ.'OFF')GOTO1489
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1481)
 1481 FORMAT('THE FRAME PATTERN (FOR BOTH VERTICAL ',
     1'FRAME LINES)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1482)IHOLD
 1482 FORMAT('HAS JUST BEEN SET TO ',A4)
      CALL DPWRST('XXX','BUG ')
 1489 CONTINUE
      GOTO1900
C
 1499 CONTINUE
C
C               **************************************************************
C               **  TREAT THE CASE WHEN                                     **
C               **  ONLY THE LEFT   VERTICAL   FRAME IS      TO BE CHANGED  **
C               **************************************************************
C
      IF(ICOM.EQ.'Y1FR')GOTO1500
      GOTO1599
C
 1500 CONTINUE
      IF(IHARG(NUMARG).EQ.'ON')GOTO1550
      IF(IHARG(NUMARG).EQ.'OFF')GOTO1550
      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550
      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550
      IF(IHARG(NUMARG).EQ.'PATT')GOTO1550
      GOTO1560
C
 1550 CONTINUE
      IHOLD=IDEFPA
      GOTO1580
C
 1560 CONTINUE
      IHOLD=IHARG(NUMARG)
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'2')IHOLD='DA2'
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'3')IHOLD='DA3'
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'4')IHOLD='DA4'
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'5')IHOLD='DA5'
      GOTO1580
C
 1580 CONTINUE
      IFOUND='YES'
      IY1FPA=IHOLD
C
      IF(IFEEDB.EQ.'OFF')GOTO1589
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1581)
 1581 FORMAT('THE FRAME PATTERN (FOR THE LEFT VERTICAL ',
     1'FRAME LINE)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1582)IHOLD
 1582 FORMAT('HAS JUST BEEN SET TO ',A4)
      CALL DPWRST('XXX','BUG ')
 1589 CONTINUE
      GOTO1900
C
 1599 CONTINUE
C
C               **************************************************************
C               **  TREAT THE CASE WHEN                                     **
C               **  ONLY THE RIGHT  VERTICAL   FRAME IS      TO BE CHANGED  **
C               **************************************************************
C
      IF(ICOM.EQ.'Y2FR')GOTO1600
      GOTO1699
C
 1600 CONTINUE
      IF(IHARG(NUMARG).EQ.'ON')GOTO1650
      IF(IHARG(NUMARG).EQ.'OFF')GOTO1650
      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650
      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650
      IF(IHARG(NUMARG).EQ.'PATT')GOTO1650
      GOTO1660
C
 1650 CONTINUE
      IHOLD=IDEFPA
      GOTO1680
C
 1660 CONTINUE
      IHOLD=IHARG(NUMARG)
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'2')IHOLD='DA2'
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'3')IHOLD='DA3'
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'4')IHOLD='DA4'
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'5')IHOLD='DA5'
      GOTO1680
C
 1680 CONTINUE
      IFOUND='YES'
      IY2FPA=IHOLD
C
      IF(IFEEDB.EQ.'OFF')GOTO1689
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1681)
 1681 FORMAT('THE FRAME PATTERN (FOR THE RIGHT VERTICAL ',
     1'FRAME LINE)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1682)IHOLD
 1682 FORMAT('HAS JUST BEEN SET TO ',A4)
      CALL DPWRST('XXX','BUG ')
 1689 CONTINUE
      GOTO1900
C
 1699 CONTINUE
C
C               *****************************************************
C               **  TREAT THE CASE WHEN                            **
C               **  ALL 4 FRAME FRAME LINES ARE TO BE CHANGED      **
C               *****************************************************
C
      IF(ICOM.EQ.'FRAM')GOTO1700
      IF(ICOM.EQ.'XYFR')GOTO1700
      IF(ICOM.EQ.'YXFR')GOTO1700
      GOTO1799
C
 1700 CONTINUE
      IF(IHARG(NUMARG).EQ.'ON')GOTO1750
      IF(IHARG(NUMARG).EQ.'OFF')GOTO1750
      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750
      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750
      IF(IHARG(NUMARG).EQ.'PATT')GOTO1750
      GOTO1760
C
 1750 CONTINUE
      IHOLD=IDEFPA
      GOTO1780
C
 1760 CONTINUE
      IHOLD=IHARG(NUMARG)
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'2')IHOLD='DA2'
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'3')IHOLD='DA3'
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'4')IHOLD='DA4'
      IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'5')IHOLD='DA5'
      GOTO1780
C
 1780 CONTINUE
      IFOUND='YES'
      IX1FPA=IHOLD
      IX2FPA=IHOLD
      IY1FPA=IHOLD
      IY2FPA=IHOLD
C
      IF(IFEEDB.EQ.'OFF')GOTO1789
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1781)
 1781 FORMAT('THE FRAME PATTERN (FOR ALL 4 ',
     1'FRAME LINES)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1782)IHOLD
 1782 FORMAT('HAS JUST BEEN SET TO ',A4)
      CALL DPWRST('XXX','BUG ')
 1789 CONTINUE
      GOTO1900
C
 1799 CONTINUE
C
 1900 CONTINUE
      RETURN
      END
      SUBROUTINE DPFRTE(XTEMP1,MAXNXT,
     1ICASAN,ICAPSW,
     1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
C
C     PURPOSE--PERFORM EITHER A FREQUENCY OR FREQUENCY WITHIN A BLOCK
C              TEST FOR RANDOMNESS
C     EXAMPLE--FREQUENCY TEST Y
C              FREQUENCY WITHIN A BLOCK TEST Y
C     REFERENCE--A STATISTICAL TEST SUITE FOR RANDOM AND PSUEDORANDOM
C                NUMBER GENERATORS FOR CRYPTOGRAPHIC APPLICATIONS,
C                ANDREW RUHKIN, JUAN SOTO, JAMES NECHVATAL, MILES SMID,
C                ELAINE BARKER, STEFAN LEIGH, MARK LEVENSON,
C                MARK VANGEL, DAVID BANKS, ALAN HECKERT, JAMES DRAY,
C                SAN VO.  NIST SPECIAL PUBLICATION 800-22,
C                OCTOBER 2000, PP. 14-16.
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--2003/11
C     ORIGINAL VERSION--NOVEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASAN
      CHARACTER*4 ICAPSW
C
      CHARACTER*4 IBUGA2
      CHARACTER*4 IBUGA3
      CHARACTER*4 IBUGQ
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 MESSAG
      CHARACTER*4 ICASEQ
C
      CHARACTER*4 IHWUSE
      CHARACTER*4 IH11
      CHARACTER*4 IH12
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      CHARACTER*4 IUSE1
      CHARACTER*4 IUSE2
C
      CHARACTER*4 IH
      CHARACTER*4 IH2
      CHARACTER*4 IHOST1
      CHARACTER*4 ISUBN0
C
C---------------------------------------------------------------------
C
      DIMENSION XTEMP1(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION YTEMP1(MAXOBV)
      DIMENSION YTEMP2(MAXOBV)
      DIMENSION YTEMP3(MAXOBV)
      INCLUDE 'DPCOZZ.INC'
      EQUIVALENCE (GARBAG(IGARB1),YTEMP1(1))
      EQUIVALENCE (GARBAG(IGARB2),YTEMP2(1))
      EQUIVALENCE (GARBAG(IGARB3),YTEMP3(1))
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='DPFR'
      ISUBN2='TE  '
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
      N1=(-999)
      N2=(-999)
C
      NS1=(-999)
      NS2=(-999)
C
      IUSE1='-999'
      IUSE2='-999'
C
      ILOCV=(-999)
C
      VALUE1=(-999.0)
      VALUE2=(-999.0)
C
      ICOL1=(-999)
      ICOL2=(-999)
C
      MINN2=2
C
      IFOUND='YES'
C
      NLEFT=0
C
      ICASEQ='UNKN'
C
C               ********************************************
C               **  TREAT THE FREQUENCY        TEST CASE  **
C               ********************************************
C
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRTE')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF DPFRTE--')
        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 ')
      ENDIF
C
C               *******************************************************
C               **  STEP 2--                                         **
C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
C               *******************************************************
C
      ISTEPN='2'
      IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      MINNA=1
      MAXNA=100
      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,
     1IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
C               ****************************************
C               **  STEP 11--                         **
C               **  CHECK THE VALIDITY OF ARGUMENT 1  **
C               **  (THIS SHULD BE A VARIABLE.)       **
C               ****************************************
C
      ISTEPN='11'
      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FRTE')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IH11=IHARG(1)
      IH12=IHARG2(1)
      IHWUSE='V'
      MESSAG='YES'
      CALL CHECKN(IH11,IH12,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
C
      IF(IERROR.EQ.'YES')THEN
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1141)
 1141    FORMAT('***** ERROR IN DPFRTE--')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1142)
 1142    FORMAT('      FOR THE FREQUENCY TEST,')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1145)
 1145    FORMAT('      THE ARGUMENT MUST BE A VARIABLE')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1146)
 1146    FORMAT('      (AS OPPOSED TO A PARAMETER OR FUNCTION).')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1147)
 1147    FORMAT('      ARGUMENT 1 WAS NOT A VARIABLE HERE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1148)
 1148    FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
         CALL DPWRST('XXX','BUG ')
         IF(IWIDTH.GE.1)WRITE(ICOUT,1150)(IANS(I),I=1,MIN(IWIDTH,80))
 1150    FORMAT(80A1)
         IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
         IERROR='YES'
         GOTO9000
      ENDIF
C
      IUSE1=IUSE(ILOCV)
      ICOL1=IVALUE(ILOCV)
      N1=IN(ILOCV)
 1190 CONTINUE
C
C               *******************************************************
C               **  STEP 12--                                        **
C               **  IF ARGUMENT 1 IS A VARIABLE,                     **
C               **  CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (N1) **
C               **  FOR ARGUMENT 1 IS 2 OR MORE.                     **
C               *******************************************************
C
      ISTEPN='12'
      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FRTE')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IUSE1.NE.'V')GOTO1290
      IF(N1.GE.MINN2)GOTO1290
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1211)
 1211 FORMAT('***** ERROR IN DPFRTE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1212)
 1212 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1213)
 1213 FORMAT('      (FOR WHICH THE FREQUENCY TEST ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1214)
 1214 FORMAT('      WAS TO HAVE BEEN CARRIED OUT)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1215)MINN2
 1215 FORMAT('      MUST BE ',I8,' OR LARGER;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1216)
 1216 FORMAT('      SUCH WAS NOT THE CASE HERE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1217)IH11,IH12
 1217 FORMAT('      FOR VARIABLE ',A4,A4,' WHICH HAD')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1218)N1
 1218 FORMAT('      NUMBER OF OBSERVATIONS = ',I8,';')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1219)
 1219 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)THEN
        WRITE(ICOUT,1220)(IANS(I),I=1,MIN(80,IWIDTH))
 1220   FORMAT(80A1)
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IERROR='YES'
      GOTO9000
 1290 CONTINUE
C
C               *****************************************
C               **  STEP 40--                          **
C               **  CHECK TO SEE THE TYPE CASE--       **
C               **    1) UNQUALIFIED (THAT IS, FULL);  **
C               **    2) SUBSET/EXCEPT; OR             **
C               **    3) FOR.                          **
C               *****************************************
C
      ISTEPN='40'
      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FRTE')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICASEQ='FULL'
      ILOCQ=NUMARG+1
      IF(NUMARG.LT.1)GOTO4090
      DO4000J=1,NUMARG
      J1=J
      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ') GOTO4010
      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ') GOTO4010
      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ') GOTO4020
 4000 CONTINUE
      GOTO4090
 4010 CONTINUE
      ICASEQ='SUBS'
      ILOCQ=J1
      GOTO4090
 4020 CONTINUE
      ICASEQ='FOR'
      ILOCQ=J1
      GOTO4090
 4090 CONTINUE
      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FRTE')THEN
        WRITE(ICOUT,4091)NUMARG,ILOCQ
 4091   FORMAT('NUMARG,ILOCQ = ',2I8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               ***********************************************
C               **  STEP 41--                                **
C               **  TEMPORARILY FORM THE VARIABLE Y(.)       **
C               **  WHICH WILL HOLD THE DATA  FROM SAMPLE 1. **
C               **  FORM THIS VARIABLE BY                    **
C               **  BRANCHING TO THE APPROPRIATE SUBCASE     **
C               **  (FULL, SUBSET, OR FOR).                  **
C               ***********************************************
C
      IF(IUSE1.NE.'V')GOTO4190
C
      ISTEPN='41'
      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FRTE')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ICASEQ.EQ.'FULL')GOTO4110
      IF(ICASEQ.EQ.'SUBS')GOTO4120
      IF(ICASEQ.EQ.'FOR')GOTO4130
C
 4110 CONTINUE
      DO4115I=1,N1
      ISUB(I)=1
 4115 CONTINUE
      NQ=N1
      GOTO4150
C
 4120 CONTINUE
      NIOLD=N1
      CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
      NQ=NIOLD
      GOTO4150
C
 4130 CONTINUE
      NIOLD=N1
      CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
      NQ=NFOR
      GOTO4150
C
 4150 CONTINUE
      IF(NQ.GE.MINN2)GOTO4160
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4151)
 4151 FORMAT('***** ERROR IN DPFRTE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4152)
 4152 FORMAT('      AFTER THE APPROPRIATE SUBSET HAS BEEN ',
     1'EXTRACTED,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4153)IH11,IH12
 4153 FORMAT('      THE NUMBER OF OBSERVATIONS REMAINING',
     1'FROM VARIABLE ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4154)
 4154 FORMAT('      (FOR WHICH THE FREQUENCY TEST ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4155)
 4155 FORMAT('      IS TO BE CARRIED OUT)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4156)MINN2
 4156 FORMAT('      MUST BE ',I8,' OR LARGER;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4157)NQ
 4157 FORMAT('      SUCH WAS NOT THE CASE HERE.  (N = ',I8,')')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4158)
 4158 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)THEN
        WRITE(ICOUT,4159)(IANS(I),I=1,MIN(80,IWIDTH))
 4159   FORMAT('      ',80A1)
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IERROR='YES'
      GOTO9000
C
 4160 CONTINUE
      J=0
      IMAX=N1
      IF(NQ.LT.N1)IMAX=NQ
      DO4170I=1,IMAX
      IF(ISUB(I).EQ.0)GOTO4170
      J=J+1
C
      IJ=MAXN*(ICOL1-1)+I
      IF(ICOL1.LE.MAXCOL)Y(J)=V(IJ)
      IF(ICOL1.EQ.MAXCP1)Y(J)=PRED(I)
      IF(ICOL1.EQ.MAXCP2)Y(J)=RES(I)
      IF(ICOL1.EQ.MAXCP3)Y(J)=YPLOT(I)
      IF(ICOL1.EQ.MAXCP4)Y(J)=XPLOT(I)
      IF(ICOL1.EQ.MAXCP5)Y(J)=X2PLOT(I)
      IF(ICOL1.EQ.MAXCP6)Y(J)=TAGPLO(I)
C
 4170 CONTINUE
      NS1=J
C
 4190 CONTINUE
C
C               ***********************************
C               **  STEP 52--                    **
C               **  DO THE FREQUENCY TEST        **
C               ***********************************
C
      ISTEPN='52'
      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FRTE')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FRTE')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5211)
 5211   FORMAT('***** FROM DPFRTE, AS WE ARE ABOUT TO CALL DPFRT2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5212)N1,N2,NS1,NS2,MAXN
 5212   FORMAT('N1,N2,NS1,NS2,MAXN = ',5I8)
        CALL DPWRST('XXX','BUG ')
        DO5215I=1,NS1
          WRITE(ICOUT,5216)I,Y(I)
 5216     FORMAT('I,Y(I) = ',I8,2E15.7)
          CALL DPWRST('XXX','BUG ')
 5215   CONTINUE
        WRITE(ICOUT,5231)IBUGA3
 5231   FORMAT('IBUGA3 = ',A4)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 5790 CONTINUE
C
      IF(ICASAN.EQ.'FBTE')THEN
        IH11='M   '
        IH12='    '
        IHWUSE='P'
        MESSAG='NO'
        CALL CHECKN(IH11,IH12,IHWUSE,
     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
        IF(IERROR.EQ.'NO')THEN
          AM=VALUE(ILOCP)
          M=INT(AM+0.5)
        ELSE
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5811)
 5811     FORMAT('***** ERROR: FOR FREQUENCY WITHIN A BLOCK TEST, THE')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5812)
 5812     FORMAT('      DESIRED BLOCK SIZE WAS NOT SET.  TO SET THE')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5813)
 5813     FORMAT('      BLOCK SIZE, ENTER THE COMMAND')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5814)
 5814     FORMAT('      LET M = value')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
          GOTO9000
        ENDIF
        IF(M.LT.20)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5821)
 5821     FORMAT('***** WARNING: FOR THE FREQUENCY WITHIN A BLOCK ',
     1           'TEST, THE ')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5822)
 5822     FORMAT('      RECOMMENDATION FOR THE MINIMUM BLOCK SIZE')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5823)M
 5823     FORMAT('      IS 20.  THE SPECIFIED BLOCK SIZE IS ',I8)
          CALL DPWRST('XXX','BUG ')
        ENDIF
      ENDIF
C
      CALL DPFRT2(Y,NS1,
     1XTEMP1,MAXNXT,
     1ICAPSW,ICAPTY,ICASAN,M,
     1STATVA,STATCD,CUT0,CUT50,CUT75,CUT90,CUT95,CUT99,
     1YTEMP1,YTEMP2,YTEMP3,
     1ISUBRO,IBUGA3,IERROR)
C
C               ***************************************
C               **  STEP 61--                        **
C               **  UPDATE INTERNAL DATAPLOT TABLES  **
C               ***************************************
C
      ISTEPN='61'
      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FRTE')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ISUBN0='DPFR'
C
      IH='STAT'
      IH2='VAL '
      VALUE0=STATVA
      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,IBUGA2,IERROR)
C
      IH='STAT'
      IH2='CDF '
      VALUE0=STATCD
      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,IBUGA2,IERROR)
C
      IH='CUTO'
      IH2='FF50'
      VALUE0=CUT50
      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,IBUGA2,IERROR)
C
      IH='CUTO'
      IH2='FF75'
      VALUE0=CUT75
      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,IBUGA2,IERROR)
C
      IH='CUTO'
      IH2='FF90'
      VALUE0=CUT90
      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,IBUGA2,IERROR)
C
      IH='CUTO'
      IH2='FF95'
      VALUE0=CUT95
      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,IBUGA2,IERROR)
C
      IH='CUTO'
      IH2='FF99'
      VALUE0=CUT99
      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,IBUGA2,IERROR)
 
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FRTE')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF DPFRTE--')
        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 DPFRT2(Y,N,
     1XTEMP,MAXNXT,
     1ICAPSW,ICAPTY,ICASAN,M,
     1STATVA,STATCD,CUT0,CUT50,CUT75,CUT90,CUT95,CUT99,
     1YTEMP1,YTEMP2,YTEMP3,
     1ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE CARRIES OUT EITHER THE FREQUENCY TEST
C              FOR RANDOMNESS OR THE FREQUENCY WITHIN A BLOCK TEST
C              FOR RANDOMNESS.
C     EXAMPLE--FREQUENCY TEST Y
C              FREQUENCY WITHIN A BLOCK TEST Y
C     REFERENCE--A STATISTICAL TEST SUITE FOR RANDOM AND PSUEDORANDOM
C                NUMBER GENERATORS FOR CRYPTOGRAPHIC APPLICATIONS,
C                ANDREW RUHKIN, JUAN SOTO, JAMES NECHVATAL, MILES SMID,
C                ELAINE BARKER, STEFAN LEIGH, MARK LEVENSON,
C                MARK VANGEL, DAVID BANKS, ALAN HECKERT, JAMES DRAY,
C                SAN VO.  NIST SPECIAL PUBLICATION 800-22,
C                OCTOBER 2000, PP. 14-18.
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--2003/11
C     ORIGINAL VERSION--NOVEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICAPSW
      CHARACTER*4 ICAPTY
      CHARACTER*4 ICASAN
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
C
      CHARACTER*1 IBASLC
C
      CHARACTER*6 ICONC1
      CHARACTER*6 ICONC2
      CHARACTER*6 ICONC3
      CHARACTER*6 ICONC4
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION XTEMP(*)
      DIMENSION YTEMP1(*)
      DIMENSION YTEMP2(*)
      DIMENSION YTEMP3(*)
C
      DOUBLE PRECISION DRESLT
      DOUBLE PRECISION DGAMIP
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='DPFR'
      ISUBN2='T2  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRT2')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF DPFRT2--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3
   52   FORMAT('IBUGA3 = ',A4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,55)N
   55   FORMAT('N = ',I8)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,N
          WRITE(ICOUT,57)I,Y(I)
   57     FORMAT('I,Y(I) = ',I8,E15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 11--                             **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      ISTEPN='11'
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FRT2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(N.LE.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1111)
 1111   FORMAT('***** ERROR IN FREQUENCY RANDOMNESS TEST.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1113)
 1113   FORMAT('      AT LEAST SIX OBSERVATIONS REQUIRED.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1115)N
 1115   FORMAT('SAMPLE SIZE = ',I8)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      HOLD=Y(1)
      DO1135I=2,N
      IF(Y(I).NE.HOLD)GOTO1139
 1135 CONTINUE
 1130 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,1131)HOLD
 1131 FORMAT('***** NOTE FROM FREQUENCY RANDOMNESS TEST--VARIABLE ',
     1'HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','WRIT')
      IERROR='YES'
      GOTO9000
 1139 CONTINUE
C
C               *******************************
C               **  STEP 2--                 **
C               **  COMPUTE THE NUMBER OF    **
C               **  DISTINCT VALUES.         **
C               *******************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRT2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IWRITE='NO'
      CALL DISTIN(Y,N,IWRITE,YTEMP1,NDIST,IBUGA3,IERROR)
C
      IF(IERROR.EQ.'YES')GOTO9000
      IF(NDIST.GT.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2001)
 2001   FORMAT('***** ERROR IN FREQUENCY RANDOMNESS TEST.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2003)
 2003   FORMAT('      FOR FREQUENCY TEST, AT MOST TWO DISTINCT ',
     1         'VALUES ARE ALLOWED.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2005)NDIST
 2005   FORMAT('      NUMBER OF DISTINCT VALUES = ',I8)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(ICASAN.EQ.'FRTE')GOTO2000
      IF(ICASAN.EQ.'FBTE')GOTO3000
C
 2000 CONTINUE
      IF(NDIST.EQ.1)THEN
        DO2010I=1,N
          YTEMP2(I)=1.0
 2010   CONTINUE
      ELSE
        ALOW=MIN(YTEMP1(1),YTEMP1(2))
        AHIGH=MAX(YTEMP1(1),YTEMP1(2))
        SN=0.0
        DO2020I=1,N
          IF(Y(I).EQ.ALOW)THEN
            SN=SN - 1.0
          ELSE
            SN=SN + 1.0
          ENDIF
 2020   CONTINUE
      ENDIF
C
C               ******************************
C               **  STEP 42--               **
C               **  CARRY OUT CALCULATIONS  **
C               **  FOR FREQUENCY     TEST  **
C               ******************************
C
 4400 CONTINUE
C
      ISTEPN='42'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IWRITE='OFF'
C
      STATVA=ABS(SN)/SQRT(REAL(N))
C
      ARG1=STATVA
      CALL NORCDF(ARG1,RESULT)
      TERM=2.0*RESULT-1.0
      STATCD=1.0-TERM
CCCCC CDF2=100.0*STATCD
C
      CUT0=0.
C
      ALPHA=.5
      P2=1.0-ALPHA/2.0
      CALL NORPPF(P2,CUT50)
C
      ALPHA=.25
      P2=1.0-ALPHA/2.0
      CALL NORPPF(P2,CUT75)
C
      ALPHA=.10
      P2=1.0-ALPHA/2.0
      CALL NORPPF(P2,CUT90)
C
      ALPHA=.05
      P2=1.0-ALPHA/2.0
      CALL NORPPF(P2,CUT95)
C
      ALPHA=.025
      P2=1.0-ALPHA/2.0
      CALL NORPPF(P2,CUT975)
C
      ALPHA=.01
      P2=1.0-ALPHA/2.0
      CALL NORPPF(P2,CUT99)
C
      ICONC1='REJECT'
      ICONC2='REJECT'
      ICONC3='REJECT'
      ICONC4='REJECT'
C
C               *********************************
C               **   STEP 52--                 **
C               **   WRITE OUT EVERYTHING      **
C               **   FOR FREQUENCY TEST        **
C               *********************************
C
      ISTEPN='52'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IPRINT.EQ.'ON')THEN
      IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN
        WRITE(ICOUT,5101)
 5101   FORMAT('
') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5108) 5108 FORMAT('
') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5102) 5102 FORMAT('FREQUENCY TEST FOR RANDONNESS') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5109) 5109 FORMAT('
') CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5104) C5104 FORMAT('

') CCCCC WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5105) 5105 FORMAT('
    ') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5206) 5206 FORMAT('
  1. Hypotheis:
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5208) 5208 FORMAT(' H0: The data are random
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5210) 5210 FORMAT(' Ha: The data are not random
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5107) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5106) 5106 FORMAT('
  2. Statistics:') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5107) 5107 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5111) 5111 FORMAT(' ') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) 5121 FORMAT(' ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) 5123 FORMAT(' ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) 5126 FORMAT(' ') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5142) 5142 FORMAT(' Sum of +1 and -1 Values:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5154)SN CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5146) 5146 FORMAT(' Frequency Test Statstic Value:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5154)STATVA 5154 FORMAT(' ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5191) 5191 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5125) 5125 FORMAT(' Number of Observations:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) 5127 FORMAT(' ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5129)N 5129 FORMAT(' ',I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) 5128 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5107) CALL DPWRST('XXX','WRIT') C CCCCC WRITE(ICOUT,5164) C5164 FORMAT('
  3. Percent Points of Reference Half-Normal ', CCCCC1 ' Distribution (Critical Values):
    ') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5165) C5165 FORMAT(' (Reject Hypothesis of Randomness if test ', CCCCC1 ' statistic value') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5166) C5166 FORMAT(' is greater than percent point value.') CCCCC CALL DPWRST('XXX','WRIT') C CCCCC WRITE(ICOUT,5107) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5111) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5121) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5123) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5167) C5167 FORMAT(' 90% Point:') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5127) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5126) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5151)CUT90 C5151 FORMAT(' ',G15.7) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5127) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5128) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5121) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5123) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5168) C5168 FORMAT(' 95% Point:') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5127) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5126) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5151)CUT95 CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5127) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5128) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5121) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5123) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5169) C5169 FORMAT(' 97.5% Point:') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5127) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5126) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5151)CUT975 CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5127) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5128) CCCCC CALL DPWRST('XXX','WRIT') C CCCCC WRITE(ICOUT,5121) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5123) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5170) C5170 FORMAT(' 99% Point:') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5127) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5126) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5151)CUT99 CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5127) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5128) CCCCC CALL DPWRST('XXX','WRIT') C CCCCC WRITE(ICOUT,5121) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5123) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5172) C5172 FORMAT(' P-Value:') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5127) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5126) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5151)STATCD CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5127) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5128) CCCCC CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5173)STATCD 5173 FORMAT('
  4. P-Value = ',G15.7,'
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5174) 5174 FORMAT(' (Reject hypothesis of randomness if P-Value ', 1 'is less than alpha)') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5107) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5107) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5176) 5176 FORMAT('
  5. Conclusion (at the 5% Level):') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5107) CALL DPWRST('XXX','WRIT') IF(STATVA.LT.CUT95)THEN WRITE(ICOUT,5180) CALL DPWRST('XXX','WRIT') 5180 FORMAT(' The data are random.') ELSE WRITE(ICOUT,5190) CALL DPWRST('XXX','WRIT') 5190 FORMAT(' The data are not random.') ENDIF WRITE(ICOUT,5997) 5997 FORMAT('
') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5999) 5999 FORMAT('
')
        CALL DPWRST('XXX','WRIT')
C
      ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN
 8001   FORMAT('{',A1,'bf FREQUENCY TEST FOR RANDOMNESS}',2X,A1,A1)
 8002   FORMAT(A1,'begin{table}')
 8003   FORMAT(A1,'end{table}')
 8007   FORMAT(A1,'begin{center}')
 8008   FORMAT(A1,'end{center}')
 8012   FORMAT(A1,'end{verbatim}')
 8017   FORMAT(A1,'begin{enumerate}')
 8018   FORMAT(A1,'end{enumerate}')
 8019   FORMAT(5X,'$ ',A1,1X,A1,' $ ',A1,A1)
C
        CALL DPCONA(92,IBASLC)
C
        WRITE(ICOUT,8012)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8007)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8002)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8001)IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8019)IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8019)IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8017)IBASLC
        CALL DPWRST('XXX','WRIT')
C
 8020   FORMAT(5X,A1,'item Hypothesis:')
 8021   FORMAT(5X,A1,'item Statistics:')
 8022   FORMAT(5X,A1,'item Critical Values:')
 8023   FORMAT(5X,A1,'item Conclusion (at the 5',A1,'% level):')
 8030   FORMAT(11X,A1,'begin{tabular} {lr}')
 8031   FORMAT(11X,'Number of Observations: & ',I8,2X,A1,A1)
 8032   FORMAT(11X,'Sum of +1 and -1 Values: & ',G15.7,2X,A1,A1)
 8034   FORMAT(11X,'Frequency Test Statistic Value: & ',
     1         G15.7,2X,A1,A1)
 8040   FORMAT(11X,A1,'end{tabular}')
 8151   FORMAT(11X,'$H_0$: The data are random ')
 8152   FORMAT(11X,'$H_a$: The data are not random')
C
        WRITE(ICOUT,8020)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8050)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8151)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8050)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8152)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,8021)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8050)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8030)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8031)N,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8032)SN,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8034)STATVA,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8040)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,8022)IBASLC
        CALL DPWRST('XXX','WRIT')
C
C8041   FORMAT(11X,'90',A1,'% Point: & ',G15.7,2X,A1,A1)
C8042   FORMAT(11X,'95',A1,'% Point: & ',G15.7,2X,A1,A1)
C8043   FORMAT(11X,'97.5',A1,'% Point: & ',G15.7,2X,A1,A1)
C8044   FORMAT(11X,'99',A1,'% Point: & ',G15.7,2X,A1,A1)
 8046   FORMAT(11X,'P-Value of Statistic: & ',G15.7,2X,A1,A1)
 8047   FORMAT(11X,'(Reject hypothesis of randomness if p-value ',
     1         'is less than $',A1,'alpha$) & ',2X,A1,A1)
        WRITE(ICOUT,8050)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8030)IBASLC
        CALL DPWRST('XXX','WRIT')
CCCCC   WRITE(ICOUT,8041)IBASLC,CUT90,IBASLC,IBASLC
CCCCC   CALL DPWRST('XXX','WRIT')
CCCCC   WRITE(ICOUT,8042)IBASLC,CUT95,IBASLC,IBASLC
CCCCC   CALL DPWRST('XXX','WRIT')
CCCCC   WRITE(ICOUT,8043)IBASLC,CUT975,IBASLC,IBASLC
CCCCC   CALL DPWRST('XXX','WRIT')
CCCCC   WRITE(ICOUT,8044)IBASLC,CUT99,IBASLC,IBASLC
CCCCC   CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8046)STATCD,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8047)IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8040)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,8023)IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8050)IBASLC
        CALL DPWRST('XXX','WRIT')
C
 8050   FORMAT(11X,A1,'newline')
 8091   FORMAT(A1,'end{enumerate}')
 8092   FORMAT(A1,'begin{verbatim}')
        IF(STATVA.LT.CUT95)THEN
          WRITE(ICOUT,8051)
          CALL DPWRST('XXX','WRIT')
 8051     FORMAT('        The data are random.')
        ELSE
          WRITE(ICOUT,8061)
          CALL DPWRST('XXX','WRIT')
 8061     FORMAT('        The data are not random.')
        ENDIF
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8091)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8003)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8008)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8092)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
      ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN
C  JUST A PLACEHOLDER FOR NOW.
C
      ELSE
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5211)
 5211   FORMAT('              FREQUENCY TEST FOR RANDOMNESS')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,5231)
 5231   FORMAT('1. HYPOTHESIS:')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5232)
 5232   FORMAT(3X,'H0: THE DATA ARE RANDOM')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5233)
 5233   FORMAT(3X,'HA: THE DATA ARE NOT RANDOM')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,5241)
 5241   FORMAT('2. STATISTICS:')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5242)N
 5242   FORMAT(3X,'NUMBER OF OBSERVATIONS      = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5343)SN
 5343   FORMAT(3X,'SUM OF +1 AND -1 VALUES     = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5349)STATVA
 5349   FORMAT(3X,'FREQUENCY TEST STATISTIC    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
CCCCC   WRITE(ICOUT,5438)
C5438   FORMAT('2. PERCENT POINTS OF THE REFERENCE HALF-NORMAL ',
CCCCC1         'DISTRIBUTION')
CCCCC   CALL DPWRST('XXX','WRIT')
CCCCC   WRITE(ICOUT,5439)
C5439   FORMAT('   (REJECT HYPOTHESIS OF RANDOMNESS IF TEST STATISTIC ',
CCCCC1         'VALUE')
CCCCC   CALL DPWRST('XXX','WRIT')
CCCCC   WRITE(ICOUT,5440)
C5440   FORMAT('   IS GREATER THAN PERCENT POINT VALUE)')
CCCCC   CALL DPWRST('XXX','WRIT')
CCCCC   WRITE(ICOUT,5441)
C5441   FORMAT(3X,'FOR FREQUENCY TEST STATISTIC')
CCCCC   CALL DPWRST('XXX','WRIT')
CCCCC   WRITE(ICOUT,5445)CUT0
C5445   FORMAT(6X,'0          % POINT    = ',G15.7)
CCCCC   CALL DPWRST('XXX','WRIT')
CCCCC   WRITE(ICOUT,5446)CUT50
C5446   FORMAT(6X,'50         % POINT    = ',G15.7)
CCCCC   CALL DPWRST('XXX','WRIT')
CCCCC   WRITE(ICOUT,5447)CUT75
C5447   FORMAT(6X,'75         % POINT    = ',G15.7)
CCCCC   CALL DPWRST('XXX','WRIT')
CCCCC   WRITE(ICOUT,5448)CUT90
C5448   FORMAT(6X,'90         % POINT    = ',G15.7)
CCCCC   CALL DPWRST('XXX','WRIT')
CCCCC   WRITE(ICOUT,5449)CUT95
C5449   FORMAT(6X,'95         % POINT    = ',G15.7)
CCCCC   CALL DPWRST('XXX','WRIT')
CCCCC   WRITE(ICOUT,5450)CUT975
C5450   FORMAT(6X,'97.5       % POINT    = ',G15.7)
CCCCC   CALL DPWRST('XXX','WRIT')
CCCCC   WRITE(ICOUT,5451)CUT99
C5451   FORMAT(6X,'99         % POINT    = ',G15.7)
CCCCC   CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5453)STATCD
 5453   FORMAT('3. P-VALUE OF STATISTIC  = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5454)
 5454   FORMAT('   (REJECT HYPOTHESIS OF RANDOMNESS IF P-VALUE IS ',
     1         'LESS THAN ALPHA)')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5561)
 5561   FORMAT('4. CONCLUSION (AT THE 5% LEVEL):')
        CALL DPWRST('XXX','WRIT')
        IF(STATVA.LT.CUT95)THEN
          WRITE(ICOUT,5563)
 5563     FORMAT(3X,'THE DATA ARE RANDOM.')
          CALL DPWRST('XXX','WRIT')
        ELSE
          WRITE(ICOUT,5565)
 5565     FORMAT(3X,'THE DATA ARE NOT RANDOM.')
          CALL DPWRST('XXX','WRIT')
        ENDIF
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
      ENDIF
      ENDIF
      GOTO9000
C
 3000 CONTINUE
C
      NBLOCK=N/M
      AMNSZ=0.01*REAL(N)
C
      IF(NBLOCK.GE.100)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3011)
 3011   FORMAT('***** WARNING: THE NUMBER OF BLOCKS IS GREATER')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3012)
 3012   FORMAT('      THAN THE RECOMMENDED MAXIMUM OF 100.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3013)N
 3013   FORMAT('      SAMPLE SIZE       = ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3014)M
 3014   FORMAT('      BLOCK SIZE        = ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3015)NBLOCK
 3015   FORMAT('      NUMBER OF BLOCKS  = ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IF(M.LE.INT(AMNSZ))THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3021)
 3021   FORMAT('***** WARNING: THE BLOCK SIZE IS LESS THAN THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3022)INT(AMNSZ)
 3022   FORMAT('      RECOMMENDED MINIMUM OF ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3023)N
 3023   FORMAT('      SAMPLE SIZE                     = ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3024)M
 3024   FORMAT('      BLOCK SIZE                      = ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3025)NBLOCK
 3025   FORMAT('      NUMBER OF BLOCKS                = ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3026)INT(AMNSZ)
 3026   FORMAT('      RECOMMENDED MINIMUM BLOCK SIZE  = ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IF(M.GT.N)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3031)
 3031   FORMAT('***** ERROR: THE BLOCK SIZE IS GREATER THAN THE ',
     1         'SAMPLE SIZE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3033)N
 3033   FORMAT('      SAMPLE SIZE                     = ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3034)M
 3034   FORMAT('      BLOCK SIZE                      = ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3035)NBLOCK
 3035   FORMAT('      NUMBER OF BLOCKS                = ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3036)INT(AMNSZ)
 3036   FORMAT('      RECOMMENDED MINIMUM BLOCK SIZE  = ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(NDIST.NE.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3041)NDIST
 3041   FORMAT('***** ERROR: THE RESPONSE VARIBLE CONTAINS ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3043)
 3043   FORMAT('      DISTINCT VALUES.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      ALOW=MIN(YTEMP1(1),YTEMP1(2))
      AHIGH=MAX(YTEMP1(1),YTEMP1(2))
      AM=REAL(M)
C
      SUM=0.0
      DO3110K=1,NBLOCK
        ISTRT=(K-1)*M+1
        ISTOP=K*M
        AONES=0
        DO3120I=ISTRT,ISTOP
          IF(Y(I).EQ.AHIGH)AONES=AONES+1.0
 3120   CONTINUE
        API=AONES/AM
        SUM=SUM + (API-0.5)**2
 3110 CONTINUE
C
      STATVA=4.0*AM*SUM
      DRESLT=1.0D0 - DGAMIP(DBLE(NBLOCK)/2.0D0,DBLE(STATVA)/2.0D0)
      STATCD=SNGL(DRESLT)
C
      ICONC1='REJECT'
      ICONC2='REJECT'
      ICONC3='REJECT'
      ICONC4='REJECT'
C
C               *********************************
C               **   STEP 62--                 **
C               **   WRITE OUT EVERYTHING      **
C               **   FOR FREQUENCY TEST        **
C               *********************************
C
      ISTEPN='62'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IPRINT.EQ.'ON')THEN
      IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN
        WRITE(ICOUT,5601)
 5601   FORMAT('
') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5608) 5608 FORMAT('
') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5602) 5602 FORMAT('FREQUENCY WITHIN A BLOCK TEST FOR RANDONNESS') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5609) 5609 FORMAT('
') CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5604) C5604 FORMAT('

') CCCCC WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5605) 5605 FORMAT('
    ') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5706) 5706 FORMAT('
  1. Hypotheis:
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5708) 5708 FORMAT(' H0: The data are random
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5710) 5710 FORMAT(' Ha: The data are not random
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5607) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5606) 5606 FORMAT('
  2. Statistics:') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5607) 5607 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5611) 5611 FORMAT(' ') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5621) 5621 FORMAT(' ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5623) 5623 FORMAT(' ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5626) 5626 FORMAT(' ') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5621) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5623) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5642) 5642 FORMAT(' Block Size:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5627) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5626) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5629)M CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5627) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5628) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5621) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5623) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5643) 5643 FORMAT(' Number of Observations Within a Block:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5627) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5626) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5629)NBLOCK CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5627) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5628) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5621) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5623) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5646) 5646 FORMAT(' Frequency Test Statstic Value:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5627) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5626) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5654)STATVA 5654 FORMAT(' ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5627) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5628) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5991) 5991 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5625) 5625 FORMAT(' Number of Observations:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5627) 5627 FORMAT(' ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5629)N 5629 FORMAT(' ',I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5627) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5628) 5628 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5607) CALL DPWRST('XXX','WRIT') C CCCCC WRITE(ICOUT,5664) C5664 FORMAT('
  3. Percent Points of Reference Half-Normal ', CCCCC1 ' Distribution (Critical Values):
    ') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5665) C5665 FORMAT(' (Reject Hypothesis of Randomness if test ', CCCCC1 ' statistic value') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5666) C5666 FORMAT(' is greater than percent point value.') CCCCC CALL DPWRST('XXX','WRIT') C CCCCC WRITE(ICOUT,5607) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5611) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5621) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5623) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5667) C5667 FORMAT(' 90% Point:') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5627) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5626) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5651)CUT90 C5651 FORMAT(' ',G15.7) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5627) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5628) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5621) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5623) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5668) C5668 FORMAT(' 95% Point:') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5627) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5626) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5651)CUT95 CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5627) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5628) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5621) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5623) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5669) C5669 FORMAT(' 97.5% Point:') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5627) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5626) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5651)CUT975 CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5627) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5628) CCCCC CALL DPWRST('XXX','WRIT') C CCCCC WRITE(ICOUT,5621) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5623) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5670) C5670 FORMAT(' 99% Point:') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5627) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5626) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5651)CUT99 CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5627) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5628) CCCCC CALL DPWRST('XXX','WRIT') C CCCCC WRITE(ICOUT,5621) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5623) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5672) C5672 FORMAT(' P-Value:') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5627) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5626) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5651)STATCD CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5627) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5628) CCCCC CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5673)STATCD 5673 FORMAT('
  4. P-Value = ',G15.7,'
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5674) 5674 FORMAT(' (Reject hypothesis of randomness if P-Value ', 1 'is less than alpha)') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5607) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5607) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5676) 5676 FORMAT('
  5. Conclusion (at the 5% Level):') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5607) CALL DPWRST('XXX','WRIT') IF(STATCD.GE.0.05)THEN WRITE(ICOUT,5680) CALL DPWRST('XXX','WRIT') 5680 FORMAT(' The data are random.') ELSE WRITE(ICOUT,5690) CALL DPWRST('XXX','WRIT') 5690 FORMAT(' The data are not random.') ENDIF WRITE(ICOUT,5997) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5999) CALL DPWRST('XXX','WRIT') C ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN 8501 FORMAT('{',A1,'bf FREQUENCY WITHIN A BLOCK TEST FOR ', 1 'RANDOMNESS}',2X,A1,A1) 8502 FORMAT(A1,'begin{table}') 8503 FORMAT(A1,'end{table}') 8507 FORMAT(A1,'begin{center}') 8508 FORMAT(A1,'end{center}') 8512 FORMAT(A1,'end{verbatim}') 8517 FORMAT(A1,'begin{enumerate}') 8518 FORMAT(A1,'end{enumerate}') 8519 FORMAT(5X,'$ ',A1,1X,A1,' $ ',A1,A1) C CALL DPCONA(92,IBASLC) C WRITE(ICOUT,8512)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8507)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8502)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8501)IBASLC,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8519)IBASLC,IBASLC,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8519)IBASLC,IBASLC,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8517)IBASLC CALL DPWRST('XXX','WRIT') C 8520 FORMAT(5X,A1,'item Hypothesis:') 8521 FORMAT(5X,A1,'item Statistics:') 8522 FORMAT(5X,A1,'item Critical Values:') 8523 FORMAT(5X,A1,'item Conclusion (at the 5',A1,'% level):') 8530 FORMAT(11X,A1,'begin{tabular} {lr}') 8531 FORMAT(11X,'Number of Observations: & ',I8,2X,A1,A1) 8532 FORMAT(11X,'Block Size: & ',I8,2X,A1,A1) 8533 FORMAT(11X,'Number of Observations Within a Block: & ', 1 I8,2X,A1,A1) 8534 FORMAT(11X,'Frequency Within a Block Test Statistic Value:', 1 ' & ',G15.7,2X,A1,A1) 8540 FORMAT(11X,A1,'end{tabular}') 8651 FORMAT(11X,'$H_0$: The data are random ') 8652 FORMAT(11X,'$H_a$: The data are not random') C WRITE(ICOUT,8520)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8550)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8651) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8550)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8652) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,8521)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8550)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8530)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8531)N,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8532)M,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8533)NBLOCK,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8534)STATVA,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8540)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,8522)IBASLC CALL DPWRST('XXX','WRIT') C C8541 FORMAT(11X,'90',A1,'% Point: & ',G15.7,2X,A1,A1) C8542 FORMAT(11X,'95',A1,'% Point: & ',G15.7,2X,A1,A1) C8543 FORMAT(11X,'97.5',A1,'% Point: & ',G15.7,2X,A1,A1) C8544 FORMAT(11X,'99',A1,'% Point: & ',G15.7,2X,A1,A1) 8546 FORMAT(11X,'P-Value of Statistic: & ',G15.7,2X,A1,A1) 8547 FORMAT(11X,'(Reject hypothesis of randomness if p-value ', 1 'is less than $',A1,'alpha$) & ',2X,A1,A1) WRITE(ICOUT,8550)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8530)IBASLC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,8541)IBASLC,CUT90,IBASLC,IBASLC CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,8542)IBASLC,CUT95,IBASLC,IBASLC CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,8543)IBASLC,CUT975,IBASLC,IBASLC CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,8544)IBASLC,CUT99,IBASLC,IBASLC CCCCC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8546)STATCD,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8547)IBASLC,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8540)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,8523)IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8550)IBASLC CALL DPWRST('XXX','WRIT') C 8550 FORMAT(11X,A1,'newline') 8591 FORMAT(A1,'end{enumerate}') 8592 FORMAT(A1,'begin{verbatim}') IF(STATCD.GE.0.05)THEN WRITE(ICOUT,8551) CALL DPWRST('XXX','WRIT') 8551 FORMAT(' The data are random.') ELSE WRITE(ICOUT,8561) CALL DPWRST('XXX','WRIT') 8561 FORMAT(' The data are not random.') ENDIF WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8591)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8503)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8508)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8592)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN C JUST A PLACEHOLDER FOR NOW. C ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7211) 7211 FORMAT(' FREQUENCY WITHIN A BLOCK TEST FOR ', 1 'RANDOMNESS') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,7231) 7231 FORMAT('1. HYPOTHESIS:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7232) 7232 FORMAT(3X,'H0: THE DATA ARE RANDOM') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7233) 7233 FORMAT(3X,'HA: THE DATA ARE NOT RANDOM') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,7241) 7241 FORMAT('2. STATISTICS:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7242)N 7242 FORMAT(3X,'NUMBER OF OBSERVATIONS = ',I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7243)M 7243 FORMAT(3X,'BLOCK SIZE = ',I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7244)NBLOCK 7244 FORMAT(3X,'NUMBER OF OBSERVATIONS WITHIN A BLOCK = ',I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7349)STATVA 7349 FORMAT(3X,'FREQUENCY WITHIN A BLOCK TEST STATISTIC = ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C CCCCC WRITE(ICOUT,5438) C5438 FORMAT('2. PERCENT POINTS OF THE REFERENCE HALF-NORMAL ', CCCCC1 'DISTRIBUTION') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5439) C5439 FORMAT(' (REJECT HYPOTHESIS OF RANDOMNESS IF TEST STATISTIC ', CCCCC1 'VALUE') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5440) C5440 FORMAT(' IS GREATER THAN PERCENT POINT VALUE)') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5441) C5441 FORMAT(3X,'FOR FREQUENCY TEST STATISTIC') CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5445)CUT0 C5445 FORMAT(6X,'0 % POINT = ',G15.7) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5446)CUT50 C5446 FORMAT(6X,'50 % POINT = ',G15.7) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5447)CUT75 C5447 FORMAT(6X,'75 % POINT = ',G15.7) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5448)CUT90 C5448 FORMAT(6X,'90 % POINT = ',G15.7) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5449)CUT95 C5449 FORMAT(6X,'95 % POINT = ',G15.7) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5450)CUT975 C5450 FORMAT(6X,'97.5 % POINT = ',G15.7) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,5451)CUT99 C5451 FORMAT(6X,'99 % POINT = ',G15.7) CCCCC CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7453)STATCD 7453 FORMAT('3. P-VALUE OF STATISTIC = ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7454) 7454 FORMAT(' (REJECT HYPOTHESIS OF RANDOMNESS IF P-VALUE IS ', 1 'LESS THAN ALPHA)') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7561) 7561 FORMAT('4. CONCLUSION (AT THE 5% LEVEL):') CALL DPWRST('XXX','WRIT') IF(STATCD.GE.0.05)THEN WRITE(ICOUT,7563) 7563 FORMAT(3X,'THE DATA ARE RANDOM.') CALL DPWRST('XXX','WRIT') ELSE WRITE(ICOUT,7565) 7565 FORMAT(3X,'THE DATA ARE NOT RANDOM.') CALL DPWRST('XXX','WRIT') ENDIF WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C ENDIF ENDIF GOTO9000 C GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FRT2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPFRT2--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,9012)N,IBUGA3,IERROR 9012 FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,9015)N 9015 FORMAT('N = ',I8) CALL DPWRST('XXX','WRIT') DO9016I=1,N WRITE(ICOUT,9017)I,Y(I),XTEMP(I) 9017 FORMAT('I,Y(I),XTEMP(I) = ',I8,2E15.7) CALL DPWRST('XXX','WRIT') 9016 CONTINUE ENDIF C RETURN END SUBROUTINE DPFRTH(ICOM,IHARG,ARG,NUMARG, 1PDEFTH, 1PFRATH, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE FRAME THICKNESS C CURRENTLY ALL 4 FRAME LINES MUST C BE SET TO THE SAME THICKNESS. C THE FRAME THICKNESS SWITCHES FOR THE FRAME C IS CONTAINED IN THE VARIABLE C PFRATH C INPUT ARGUMENTS--ICOM C --IHARG (A HOLLERITH VECTOR) C --NUMARG C --PDEFCO C OUTPUT ARGUMENTS--PFRATH (A REAL VARIABLE) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--ALAN HECKERT C COMPUTER SERVICES DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--OCTOBER 1980. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICOM CHARACTER*4 IHARG C CHARACTER*4 IFOUND CHARACTER*4 IERROR C REAL PHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION ARG(*) C C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(NUMARG.LE.0)GOTO1900 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'THIC')GOTO1090 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 1IHARG(2).EQ.'THIC')GOTO1090 GOTO1900 1090 CONTINUE C C ***************************************************** C ** TREAT THE CASE WHEN ** C ** BOTH HORIZONTAL FRAMES ARE TO BE CHANGED ** C ***************************************************** C IF(ICOM.EQ.'XFRA')GOTO1100 GOTO1199 C 1100 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 IF(IHARG(NUMARG).EQ.'THIC')GOTO1150 GOTO1160 C 1150 CONTINUE PHOLD=PDEFTH GOTO1180 C 1160 CONTINUE PHOLD=ARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' PFRATH=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE FRAME THICKNESS (FOR ALL FRAME LINES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)PHOLD 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1900 C 1199 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE BOTTOM HORIZONTAL FRAME IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X1FR')GOTO1200 GOTO1299 C 1200 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1250 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 IF(IHARG(NUMARG).EQ.'THIC')GOTO1250 GOTO1260 C 1250 CONTINUE PHOLD=PDEFTH GOTO1280 C 1260 CONTINUE PHOLD=ARG(NUMARG) GOTO1280 C 1280 CONTINUE IFOUND='YES' PFRATH=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1289 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1281) 1281 FORMAT('THE FRAME THICKNESS (FOR ALL FRAME LINES) ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1282)PHOLD 1282 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1289 CONTINUE GOTO1900 C 1299 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE TOP HORIZONTAL FRAME IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X2FR')GOTO1300 GOTO1399 C 1300 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1350 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 IF(IHARG(NUMARG).EQ.'THIC')GOTO1350 GOTO1360 C 1350 CONTINUE PHOLD=PDEFTH GOTO1380 C 1360 CONTINUE PHOLD=ARG(NUMARG) GOTO1380 C 1380 CONTINUE IFOUND='YES' PFRATH=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1389 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1381) 1381 FORMAT('THE FRAME THICKNESS (FOR ALL FRAME LINES) ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1382)PHOLD 1382 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1389 CONTINUE GOTO1900 C 1399 CONTINUE C C ***************************************************** C ** TREAT THE CASE WHEN ** C ** BOTH VERTICAL FRAMES ARE TO BE CHANGED ** C ***************************************************** C IF(ICOM.EQ.'YFRA')GOTO1400 GOTO1499 C 1400 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1450 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 IF(IHARG(NUMARG).EQ.'THIC')GOTO1450 GOTO1460 C 1450 CONTINUE PHOLD=PDEFTH GOTO1480 C 1460 CONTINUE PHOLD=ARG(NUMARG) GOTO1480 C 1480 CONTINUE IFOUND='YES' PFRATH=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1489 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1481) 1481 FORMAT('THE FRAME THICKNESS (FOR ALL FRAME LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1482)PHOLD 1482 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1489 CONTINUE GOTO1900 C 1499 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE LEFT VERTICAL FRAME IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y1FR')GOTO1500 GOTO1599 C 1500 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1550 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 IF(IHARG(NUMARG).EQ.'THIC')GOTO1550 GOTO1560 C 1550 CONTINUE PHOLD=PDEFTH GOTO1580 C 1560 CONTINUE PHOLD=ARG(NUMARG) GOTO1580 C 1580 CONTINUE IFOUND='YES' PFRATH=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1589 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1581) 1581 FORMAT('THE FRAME THICKNESS (FOR ALL FRAME LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1582)PHOLD 1582 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1589 CONTINUE GOTO1900 C 1599 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE RIGHT VERTICAL FRAME IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y2FR')GOTO1600 GOTO1699 C 1600 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1650 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 IF(IHARG(NUMARG).EQ.'THIC')GOTO1650 GOTO1660 C 1650 CONTINUE PHOLD=PDEFTH GOTO1680 C 1660 CONTINUE PHOLD=ARG(NUMARG) GOTO1680 C 1680 CONTINUE IFOUND='YES' PFRATH=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1689 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1681) 1681 FORMAT('THE FRAME THICKNESS (FOR ALL FRAME LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1682)PHOLD 1682 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1689 CONTINUE GOTO1900 C 1699 CONTINUE C C ***************************************************** C ** TREAT THE CASE WHEN ** C ** ALL 4 FRAME FRAME LINES ARE TO BE CHANGED ** C ***************************************************** C IF(ICOM.EQ.'FRAM')GOTO1700 IF(ICOM.EQ.'XYFR')GOTO1700 IF(ICOM.EQ.'YXFR')GOTO1700 GOTO1799 C 1700 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1750 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 IF(IHARG(NUMARG).EQ.'THIC')GOTO1750 GOTO1760 C 1750 CONTINUE PHOLD=PDEFTH GOTO1780 C 1760 CONTINUE PHOLD=ARG(NUMARG) GOTO1780 C 1780 CONTINUE IFOUND='YES' PFRATH=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1789 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1781) 1781 FORMAT('THE FRAME THICKNESS (FOR ALL 4 ', 1'FRAME LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1782)PHOLD 1782 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1789 CONTINUE GOTO1900 C 1799 CONTINUE C 1900 CONTINUE RETURN END SUBROUTINE DPFRTY(IHARG,NUMARG, 1IDEFFT, 1IFRATY, 1IBUGS2,IFOUND,IERROR) C C PURPOSE--DEFINE THE FRACTAL TYPE C CAN BE (DEFAULT IS BARNSLEY) C THIS SWITCH CONTROLS HOW THE ARGUMENTS TO THE C FRACTAL PLOT COMMAND ARE INTERPERTED. C C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG (AN INTEGER VARIABLE) C --IDEFFT (A CHARACTER VARIABLE) C --IBUGS2 (A CHARACTER VARIABLE) C OUTPUT ARGUMENTS--IFRATY (A CHARACTER 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--93/7 C ORIGINAL VERSION--JULY 1993. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFFT CHARACTER*4 IFRATY CHARACTER*4 IBUGS2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(IBUGS2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPFRTY--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IDEFFT 53 FORMAT('IDEFFT = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NUMARG 54 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NUMARG WRITE(ICOUT,56)I,IHARG(I) 56 FORMAT('I,IHARG(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C IFOUND='NO' IERROR='NO' C IF(NUMARG.LE.1)GOTO1150 IF(NUMARG.GT.2)GOTO9000 C 1120 CONTINUE IF(IHARG(2).EQ.'AUTO')GOTO1150 IF(IHARG(2).EQ.'DEFA')GOTO1150 GOTO1160 C 1150 CONTINUE IHOLD=IDEFFT GOTO1180 C 1160 CONTINUE IHOLD=IHARG(2) IF(IHOLD.EQ.'BARN')GOTO1180 IF(IHOLD.EQ.'WHIT')GOTO1180 IF(IHOLD.EQ.'ROTA')IHOLD='ANGL' IF(IHOLD.EQ.'ANGL')GOTO1180 GOTO1170 C 1170 CONTINUE IERROR='YES' IFOUND='YES' WRITE(ICOUT,1171)IHOLD 1171 FORMAT('THE FRACTAL TYPE SWITCH ',A4,' IS NOT RECOGNIZED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1172) 1172 FORMAT('IT SHOLUD BE: BARNSLEY, WHITHERS, OR ANGLE') CALL DPWRST('XXX','BUG ') GOTO9000 C 1180 CONTINUE IFOUND='YES' IFRATY=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IFRATY 1181 FORMAT('THE FRACTAL TYPE SWITCH HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO9000 C 9000 CONTINUE IF(IBUGS2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPFRTY') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGS2,IFOUND,IERROR 9012 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IDEFFT,IFRATY 9013 FORMAT('IDEFFT,IFRATY = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPFTES(XTEMP1,XTEMP2,MAXNXT, 1ICAPSW, 1IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) C C PURPOSE--CARRY OUT AN F TEST C (1-SAMPLE OR 2-SAMPLE) CCCCC THE FOLLOWING 3 LINES WERE ADDED FEBRUARY 1994 C EXAMPLE--F TEST Y MU C F TEST MU Y C F TEST Y1 Y2 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--JULY 1984. C UPDATED --FEBRUARY 1994. ADD COMMENTS ABOVE C UPDATED --DECEMBER 1994. COPY F TEST PARAMETERS C UPDATED --JANUARY 2004. SUPPORT FOR HTML, LATEX C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR CHARACTER*4 ICAPSW C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ C CHARACTER*4 IH11 CHARACTER*4 IH12 CHARACTER*4 IH21 CHARACTER*4 IH22 C CCCCC MAY 1995. ADD FOLLOWING DECLARATIONS CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IHOST1 CHARACTER*4 ISUBN0 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 IUSE1 CHARACTER*4 IUSE2 C C--------------------------------------------------------------------- C DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' 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 CCCCC ISUBN1='DPTT' ISUBN1='DPFT' ISUBN2='ES ' 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 N1=(-999) N2=(-999) C NS1=(-999) NS2=(-999) C IUSE1='-999' IUSE2='-999' C ILOCV=(-999) C VALUE1=(-999.0) VALUE2=(-999.0) C ICOL1=(-999) ICOL2=(-999) C MINN2=2 C IFOUND='YES' C NLEFT=0 C ICASEQ='UNKN' C C ******************************** C ** TREAT THE F TEST CASE ** C ******************************** C IF(IBUGA2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPFTES--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA2,IBUGA3 52 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGQ 53 FORMAT('IBUGQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)MAXNXT 55 FORMAT('MAXNXT = ',I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=2 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C **************************************** C ** STEP 11-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS SHULD BE A VARIABLE.) ** C **************************************** C ISTEPN='11' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IH11=IHARG(1) IH12=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IH11,IH12,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) C IF(IERROR.EQ.'YES')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPFTES--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' FOR AN F TEST,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1145) 1145 FORMAT(' BOTH ARGUMENTS MUST BE A VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1146) 1146 FORMAT(' (AS OPPOSED TO A PARAMETER OR FUNCTION).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1147) 1147 FORMAT(' ARGUMENT 1 WAS NOT A VARIABLE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1148) 1148 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1150)(IANS(I),I=1,IWIDTH) 1150 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C IUSE1=IUSE(ILOCV) ICOL1=IVALUE(ILOCV) N1=IN(ILOCV) 1190 CONTINUE C C ******************************************************** C ** STEP 12-- ** C ** IF ARGUMENT 1 IS A VARIABLE, ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (N1) ** C ** FOR ARGUMENT 1 IS 2 OR MORE. ** C ******************************************************** C ISTEPN='12' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IUSE1.NE.'V')GOTO1290 IF(N1.GE.MINN2)GOTO1290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** ERROR IN DPFTES--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212) 1212 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1213) 1213 FORMAT(' (FOR WHICH AN F TEST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1214) 1214 FORMAT(' WAS TO HAVE BEEN CARRIED OUT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215)MINN2 1215 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1216) 1216 FORMAT(' SUCH WAS NOT THE CASE HERE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1217)IH11,IH12 1217 FORMAT(' FOR VARIABLE ',A4,A4,' WHICH HAD') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1218)N1 1218 FORMAT(' NUMBER OF OBSERVATIONS = ',I8,';') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1219) 1219 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1220)(IANS(I),I=1,IWIDTH) 1220 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1290 CONTINUE C C **************************************** C ** STEP 21-- ** C ** CHECK THE VALIDITY OF ARGUMENT 2 ** C ** (THIS COULD BE A VARIABLE, ** C ** A PARAMETER, OR A NUMBER). ** C **************************************** C ISTEPN='21' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IH21=IHARG(2) IH22=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IH21,IH22,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) C IF(IERROR.EQ.'YES')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2141) 2141 FORMAT('***** ERROR IN DPFTES--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2142) 2142 FORMAT(' FOR AN F TEST,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2145) 2145 FORMAT(' BOTH ARGUMENTS MUST BE A VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2146) 2146 FORMAT(' (AS OPPOSED TO A PARAMETER OR FUNCTION).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2147) 2147 FORMAT(' ARGUMENT 2 WAS NOT A VARIABLE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2148) 2148 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2150)(IANS(I),I=1,IWIDTH) 2150 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C IUSE2=IUSE(ILOCV) ICOL2=IVALUE(ILOCV) N2=IN(ILOCV) 2190 CONTINUE C C ******************************************************** C ** STEP 22-- ** C ** IF ARGUMENT 2 IS A VARIABLE, ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (N2) ** C ** FOR ARGUMENT 2 IS 2 OR MORE. ** C ******************************************************** C ISTEPN='22' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IUSE2.NE.'V')GOTO2290 IF(N2.GE.MINN2)GOTO2290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2211) 2211 FORMAT('***** ERROR IN DPFTES--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2212) 2212 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2213) 2213 FORMAT(' (FOR WHICH AN F TEST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2214) 2214 FORMAT(' WAS TO HAVE BEEN CARRIED OUT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2215)MINN2 2215 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2216) 2216 FORMAT(' SUCH WAS NOT THE CASE HERE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2217)IH21,IH22 2217 FORMAT(' FOR VARIABLE ',A4,A4,' WHICH HAD') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2218)N2 2218 FORMAT(' NUMBER OF OBSERVATIONS = ',I8,';') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2219) 2219 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2220)(IANS(I),I=1,IWIDTH) 2220 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2290 CONTINUE C C ***************************************** C ** STEP 40-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='40' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO4090 DO4000J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO4010 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO4010 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO4020 4000 CONTINUE GOTO4090 4010 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO4090 4020 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO4090 4090 CONTINUE IF(IBUGA2.EQ.'OFF')GOTO4095 WRITE(ICOUT,4091)NUMARG,ILOCQ 4091 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 4095 CONTINUE C C *********************************************** C ** STEP 41-- ** C ** TEMPORARILY FORM THE VARIABLE Y(.) ** C ** WHICH WILL HOLD THE DATA FROM SAMPLE 1. ** C ** FORM THIS VARIABLE BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C *********************************************** C IF(IUSE1.NE.'V')GOTO4190 C ISTEPN='41' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO4110 IF(ICASEQ.EQ.'SUBS')GOTO4120 IF(ICASEQ.EQ.'FOR')GOTO4130 C 4110 CONTINUE DO4115I=1,N1 ISUB(I)=1 4115 CONTINUE NQ=N1 GOTO4150 C 4120 CONTINUE NIOLD=N1 CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO4150 C 4130 CONTINUE NIOLD=N1 CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO4150 C 4150 CONTINUE IF(NQ.GE.MINN2)GOTO4160 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4151) 4151 FORMAT('***** ERROR IN DPFTES--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4152) 4152 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4153)IH11,IH12 4153 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4154) 4154 FORMAT(' (FOR WHICH AN F TEST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4155) 4155 FORMAT(' IS TO BE CARRIED OUT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4156)MINN2 4156 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4157)NQ 4157 FORMAT(' SUCH WAS NOT THE CASE HERE. (N = ',I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4158) 4158 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,4159)(IANS(I),I=1,IWIDTH) 4159 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 4160 CONTINUE J=0 IMAX=N1 IF(NQ.LT.N1)IMAX=NQ DO4170I=1,IMAX IF(ISUB(I).EQ.0)GOTO4170 J=J+1 C IJ=MAXN*(ICOL1-1)+I IF(ICOL1.LE.MAXCOL)Y(J)=V(IJ) IF(ICOL1.EQ.MAXCP1)Y(J)=PRED(I) IF(ICOL1.EQ.MAXCP2)Y(J)=RES(I) IF(ICOL1.EQ.MAXCP3)Y(J)=YPLOT(I) IF(ICOL1.EQ.MAXCP4)Y(J)=XPLOT(I) IF(ICOL1.EQ.MAXCP5)Y(J)=X2PLOT(I) IF(ICOL1.EQ.MAXCP6)Y(J)=TAGPLO(I) C 4170 CONTINUE NS1=J C 4190 CONTINUE C C *********************************************** C ** STEP 42-- ** C ** TEMPORARILY FORM THE VARIABLE X(.) ** C ** WHICH WILL HOLD THE DATAN FROM SAMPLE 2. ** C ** FORM THIS VARIABLE BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C *********************************************** C IF(IUSE2.NE.'V')GOTO4290 C ISTEPN='42' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO4210 IF(ICASEQ.EQ.'SUBS')GOTO4220 IF(ICASEQ.EQ.'FOR')GOTO4230 C 4210 CONTINUE DO4215I=1,N2 ISUB(I)=1 4215 CONTINUE NQ=N2 GOTO4250 C 4220 CONTINUE NIOLD=N2 CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO4250 C 4230 CONTINUE NIOLD=N2 CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO4250 C 4250 CONTINUE IF(NQ.GE.MINN2)GOTO4260 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4251) 4251 FORMAT('***** ERROR IN DPFTES--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4252) 4252 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4253)IH21,IH22 4253 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4254) 4254 FORMAT(' (FOR WHICH AN F TEST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4255) 4255 FORMAT(' IS TO BE CARRIED OUT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4256)MINN2 4256 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4257)NQ 4257 FORMAT(' SUCH WAS NOT THE CASE HERE. (N = ',I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4258) 4258 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,4259)(IANS(I),I=1,IWIDTH) 4259 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 4260 CONTINUE J=0 IMAX=N2 IF(NQ.LT.N2)IMAX=NQ DO4270I=1,IMAX IF(ISUB(I).EQ.0)GOTO4270 J=J+1 C IJ=MAXN*(ICOL2-1)+I IF(ICOL2.LE.MAXCOL)X(J)=V(IJ) IF(ICOL2.EQ.MAXCP1)X(J)=PRED(I) IF(ICOL2.EQ.MAXCP2)X(J)=RES(I) IF(ICOL2.EQ.MAXCP3)X(J)=YPLOT(I) IF(ICOL2.EQ.MAXCP4)X(J)=XPLOT(I) IF(ICOL2.EQ.MAXCP5)X(J)=X2PLOT(I) IF(ICOL2.EQ.MAXCP6)X(J)=TAGPLO(I) C 4270 CONTINUE NS2=J C 4290 CONTINUE C C ********************************* C ** STEP 52-- ** C ** CARY OUT THE F TEST ** C ********************************* C ISTEPN='52' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'OFF')GOTO5290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5211) 5211 FORMAT('***** FROM DPFTES, AS WE ARE ABOUT TO CALL DPTTE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5212)N1,N2,NS1,NS2,MAXN 5212 FORMAT('N1,N2,NS1,NS2,MAXN = ',5I8) CALL DPWRST('XXX','BUG ') DO5215I=1,NS1 WRITE(ICOUT,5216)I,Y(I) 5216 FORMAT('I,Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 5215 CONTINUE DO5217I=1,NS1 WRITE(ICOUT,5218)I,Y(I) 5218 FORMAT('I,Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 5217 CONTINUE CCCCC IBUGA3='ABCD' WRITE(ICOUT,5231)IBUGA3 5231 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') 5290 CONTINUE C CCCCC THE FOLLOWING CALL WAS CHANGED DECEMBER 1994 CALL DPFTE2(Y,NS1,X,NS2, CCCCC1XTEMP1,XTEMP2,MAXNXT,IBUGA3,IERROR) 1XTEMP1,XTEMP2,MAXNXT, 1ICAPSW,ICAPTY, 1STATVA,STANU1,STANU2,POOLSD,STATCD, 1CUTL95,CUTU95,CUTL99,CUTU99, 1IBUGA3,IERROR) C CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 1994 C *************************************** C ** STEP 61-- ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C ISTEPN='61' CCCCC MAY 1995. CCCCC IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC MAY 1995. RENAME CCCCC ISUBN0='DPTT' ISUBN0='DPFT' C IH='STAT' IH2='VAL ' VALUE0=STATVA CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='STAT' IH2='NU1 ' VALUE0=STANU1 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='STAT' IH2='NU2 ' VALUE0=STANU2 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='POOL' IH2='SD ' VALUE0=POOLSD CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='STAT' IH2='CDF ' VALUE0=STATCD CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTL' IH2='OW95' VALUE0=CUTL95 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTU' IH2='PP95' VALUE0=CUTU95 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTL' IH2='OW99' VALUE0=CUTL99 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTU' IH2='PP99' VALUE0=CUTU99 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPFTES--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA2,IBUGA3 9012 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGQ 9013 FORMAT('IBUGQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NLEFT,NS 9014 FORMAT('NLEFT,NS = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)ICASEQ 9015 FORMAT('ICASEQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)IFOUND,IERROR 9016 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPFTE2(Y1,N1,Y2,N2, CCCCC THE FOLLOWING LINE WAS CHANGED DECEMBER 1994 CCCCC1XTEMP1,XTEMP2,MAXNXT,IBUGA3,IERROR) 1XTEMP1,XTEMP2,MAXNXT, 1ICAPSW,ICAPTY, 1STATVA,STANU1,STANU2,POOLSD,STATCD, 1CUTL95,CUTU95,CUTL99,CUTU99, 1IBUGA3,IERROR) C C PURPOSE--THIS ROUTINE CARRIES OUT AN F TEST C (NECESSARILY 2-SAMPLE) CCCCC THE FOLLOWING 3 LINES WERE ADDED FEBRUARY 1994 C EXAMPLE--F TEST Y1 Y2 C SAMPLE 1 IS IN INPUT VECTOR Y1 C (WITH N1 OBSERVATIONS). C SAMPLE 2 IS IN INPUT VECTOR Y2 C (WITH N2 OBSERVATIONS). 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--94/2 C ORIGINAL VERSION--FEBRUARY 1994. C UPDATED --DECEMBER 1994. COPY F TEST PARAMETERS C UPDATED --JANUARY 2004. SUPPORT FOR HTML, LATEX C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA3 CHARACTER*4 IERROR CHARACTER*4 ICAPSW CHARACTER*4 ICAPTY C CHARACTER*4 IWRITE CHARACTER*4 IBASLC C CCCCC THE FOLLOWING 3 LINES WERE ADDED FEBRUARY 1994 CHARACTER*6 ICONC1 CHARACTER*6 ICONC2 CHARACTER*6 ICONC3 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Y1(*) DIMENSION Y2(*) DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPCO' ISUBN2='F2 ' C IERROR='NO' C N=(-99) C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,51) 51 FORMAT('**** AT THE BEGINNING OF DPFTE2--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','WRIT') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,55)N1 55 FORMAT('N1 = ',I8) CALL DPWRST('XXX','WRIT') DO56I=1,N1 WRITE(ICOUT,57)I,Y1(I) 57 FORMAT('I,Y1(I) = ',I8,E15.7) CALL DPWRST('XXX','WRIT') 56 CONTINUE WRITE(ICOUT,65)N2 65 FORMAT('N2 = ',I8) CALL DPWRST('XXX','WRIT') DO66I=1,N2 WRITE(ICOUT,67)I,Y2(I) 67 FORMAT('I,Y2(I) = ',I8,E15.7) CALL DPWRST('XXX','WRIT') 66 CONTINUE 90 CONTINUE C C ******************************************** C ** STEP 11-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C ISTEPN='11' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(N1.GE.1)GOTO1119 WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1111) 1111 FORMAT('***** ERROR IN DPFTE2--THE NUMBER OF OBSERVATIONS ', 1'FOR VARIABLE 1 IS NON-POSITIVE') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1112)N1 1112 FORMAT('SAMPLE SIZE = ',I8) CALL DPWRST('XXX','WRIT') IERROR='YES' GOTO9000 1119 CONTINUE C IF(N1.EQ.1)GOTO1120 GOTO1129 1120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1121) 1121 FORMAT('***** NOTE FROM DPFTE2--VARIABLE 1 ', 1'HAS ONLY 1 ELEMENT') CALL DPWRST('XXX','WRIT') GOTO9000 1129 CONTINUE C HOLD=Y1(1) DO1135I=2,N1 IF(Y1(I).NE.HOLD)GOTO1139 1135 CONTINUE 1130 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1131)HOLD 1131 FORMAT('***** NOTE FROM DPFTE2--VARIABLE 1 ', 1'HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','WRIT') GOTO9000 1139 CONTINUE C IF(N2.GE.1)GOTO1219 WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1211) 1211 FORMAT('***** ERROR IN DPFTE2--THE NUMBER OF OBSERVATIONS ', 1'FOR VARIABLE 2 IS NON-POSITIVE') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1212)N2 1212 FORMAT('SAMPLE SIZE = ',I8) CALL DPWRST('XXX','WRIT') IERROR='YES' GOTO9000 1219 CONTINUE C IF(N2.EQ.1)GOTO1220 GOTO1229 1220 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1221) 1221 FORMAT('***** NOTE FROM DPFTE2--VARIABLE 2 ', 1'HAS ONLY 1 ELEMENT') CALL DPWRST('XXX','WRIT') GOTO9000 1229 CONTINUE C HOLD=Y2(1) DO1235I=2,N2 IF(Y2(I).NE.HOLD)GOTO1239 1235 CONTINUE 1230 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1231)HOLD 1231 FORMAT('***** NOTE FROM DPFTE2--VARIABLE 2 ', 1'HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','WRIT') GOTO9000 1239 CONTINUE C 1290 CONTINUE C C ****************************** C ** STEP 41-- ** C ** CARRY OUT CALCULATIONS ** C ** FOR AN F TEST ** C ****************************** C 4100 CONTINUE C ISTEPN='41' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IWRITE='OFF' C CALL MEAN(Y1,N1,IWRITE,Y1MEAN,IBUGA3,IERROR) CALL SD(Y1,N1,IWRITE,Y1SD,IBUGA3,IERROR) Y1VAR=Y1SD**2 C CALL MEAN(Y2,N2,IWRITE,Y2MEAN,IBUGA3,IERROR) CALL SD(Y2,N2,IWRITE,Y2SD,IBUGA3,IERROR) Y2VAR=Y2SD**2 C AN1=N1 AN2=N2 C CCCCC THE FOLLOWING LINE WAS FIXED DECEMBER 1994 CCCCC IF(S1.GE.S2)THEN IF(Y1SD.GE.Y2SD)THEN SDNUM=Y1SD SDDEN=Y2SD IDFNUM=N1-1 IDFDEN=N2-1 ELSE SDNUM=Y2SD SDDEN=Y1SD IDFNUM=N2-1 IDFDEN=N1-1 ENDIF RATIO=(SDNUM/SDDEN)**2 CALL FCDF(RATIO,IDFNUM,IDFDEN,CDF) DFNUM=IDFNUM DFDEN=IDFDEN C ICONC1='REJECT' ICONC2='REJECT' ICONC3='REJECT' C CCCCC IF(0.000.LE.CDF.AND.CDF.LE.0.950)ICONC1='ACCEPT' CCCCC IF(0.025.LE.CDF.AND.CDF.LE.0.975)ICONC2='ACCEPT' CCCCC IF(0.050.LE.CDF.AND.CDF.LE.1.000)ICONC3='ACCEPT' IF(0.000.LE.CDF.AND.CDF.LE.0.950)ICONC2='ACCEPT' C CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 1994 POOLSS=DFNUM*SDNUM*SDNUM+DFDEN*SDDEN*SDDEN POOLDF=DFNUM+DFDEN POOLVA=0.0 IF(POOLDF.GT.0.0)POOLVA=POOLSS/POOLDF POOLSD=0.0 IF(POOLVA.GT.0.0)POOLSD=SQRT(POOLVA) C CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 1994 STATVA=RATIO STATCD=CDF STANU1=IDFNUM STANU2=IDFDEN CUTL95=0.0 CALL FPPF(.95,IDFNUM,IDFDEN,CUTU95) CUTL99=0.0 CALL FPPF(.99,IDFNUM,IDFDEN,CUTU99) C C ****************************** C ** STEP 42-- ** C ** WRITE OUT EVERYTHING ** C ** FOR AN F TEST ** C ****************************** C ISTEPN='42' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'ON')THEN IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN C C STEP 1: END ASIS MODE AND WRITE A HEADER C 5001 FORMAT('') WRITE(ICOUT,5001) 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(' ') WRITE(ICOUT,5011) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5013) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5015) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5017) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5019) CALL DPWRST('XXX','WRIT') C C STEP 4: DEFINE DATA ROW C 5041 FORMAT(' ') 5043 FORMAT(' ') 5048 FORMAT(' ') 5060 FORMAT(' =') 5057 FORMAT('  ') 5058 FORMAT(' <>') 5061 FORMAT(' H0: ', 1 'sigma1 = sigma2') 5062 FORMAT(' Ha: ', 1 'sigma1 <> sigma2') WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5061) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5057) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5059) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5062) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5057) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5059) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5057) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5057) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5059) CALL DPWRST('XXX','WRIT') C 5071 FORMAT(' Sample 1:') WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5071) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5048) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5057) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5057) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5059) CALL DPWRST('XXX','WRIT') C 5072 FORMAT(' Number of Observations') WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5072) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5048) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5060) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5052)N1 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5059) CALL DPWRST('XXX','WRIT') C 5073 FORMAT(' Mean') WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5073) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5048) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5060) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)Y1MEAN CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5059) CALL DPWRST('XXX','WRIT') C 5074 FORMAT(' Standard Deviation') WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5074) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5048) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5060) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)Y1SD CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5059) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5057) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5048) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5057) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5057) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5059) CALL DPWRST('XXX','WRIT') C 5076 FORMAT(' Sample 2:') WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5076) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5048) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5057) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5057) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5059) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5072) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5048) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5060) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5052)N2 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5059) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5073) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5048) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5060) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)Y2MEAN CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5059) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5074) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5048) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5060) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)Y2SD CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5059) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5057) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5048) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5057) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5057) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5059) CALL DPWRST('XXX','WRIT') C 5081 FORMAT(' Test:') WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5081) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5048) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5057) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5057) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5059) CALL DPWRST('XXX','WRIT') C 5082 FORMAT(' Standard Deviation (Numerator)') WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5082) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5048) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5060) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)SDNUM CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5059) CALL DPWRST('XXX','WRIT') C 5083 FORMAT(' Standard Deviation (Denominator)') WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5083) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5048) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5060) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)SDDEN CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5059) CALL DPWRST('XXX','WRIT') C 5084 FORMAT(' F-Test Statistic Value') WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5084) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5048) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5060) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)RATIO CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5059) CALL DPWRST('XXX','WRIT') C 5085 FORMAT(' Degrees of Freedom (Numerator)') WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5085) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5048) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5060) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5052)INT(DFNUM+0.5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5059) CALL DPWRST('XXX','WRIT') C 5086 FORMAT(' Degrees of Freedom (Denomerator)') WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5086) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5048) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5060) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5052)INT(DFDEN+0.5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5059) CALL DPWRST('XXX','WRIT') C 5087 FORMAT(' F-Test CDF Value') WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5087) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5048) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5060) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CDF CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5059) CALL DPWRST('XXX','WRIT') C C C STEP 4: END THE TABLE AND RESET ASIS MODE C 5091 FORMAT('
      ') 5017 FORMAT(' TWO SAMPLE F-TEST FOR EQUAL STANDARD ', 1 'DEVIATION') 5019 FORMAT('
      ') 5047 FORMAT(' ') 5049 FORMAT(' ') 5051 FORMAT(' ',G15.7) 5052 FORMAT(' ',I8) 5055 FORMAT(' ',A8) 5059 FORMAT('
      ') 5093 FORMAT('
    ') 5094 FORMAT('

    ') WRITE(ICOUT,5091) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5093) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5094) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) C C STEP 2: START TABLE AND DEFINE A CAPTION C 5111 FORMAT('

      ') 5113 FORMAT('') WRITE(ICOUT,5111) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5113) CALL DPWRST('XXX','WRIT') C C STEP 3: DEFINE HEADER ROW C 5121 FORMAT(' ') 5123 FORMAT(' ') 5139 FORMAT(' ') 5161 FORMAT(' ') 5243 FORMAT(' ') 5259 FORMAT(' ') 5261 FORMAT(' sigma1 = sigma2') 5262 FORMAT(' (0.000,0.950)') 5263 FORMAT(' ',A6) WRITE(ICOUT,5241) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5243) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5261) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5247) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5243) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5262) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5247) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5243) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5263)ICONC2 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5247) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5259) CALL DPWRST('XXX','WRIT') C C STEP 4: END THE TABLE AND RESET ASIS MODE C 5191 FORMAT('
      ') 5127 FORMAT('
      ') 5162 FORMAT('
      ') 5171 FORMAT(' Null
      Hypothesis') 5172 FORMAT(' Null Hypothesis
      Acceptance Interval') 5173 FORMAT(' Null Hypothesis
      Conclusion') WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5171) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5172) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5173) 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,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5161) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5162) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5247) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5139) CALL DPWRST('XXX','WRIT') C C STEP 4: DEFINE DATA ROW C 5241 FORMAT('
      ') 5247 FORMAT('
      ') 5193 FORMAT('
    ') 5194 FORMAT('
    ')
        WRITE(ICOUT,5191)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5193)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5194)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        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 TWO SAMPLE F-TEST FOR EQUAL STANDARD ',
     1       'DEVIATIONS}')
 8013 FORMAT(A1,'end{center}')
 8015 FORMAT(5X,'} ',A1,A1)
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,8009)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8011)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} {lcr}')
 8021 FORMAT(5X,'$H_0$: $',A1,'sigma_1$  = $',A1,'sigma_2$  & & ',
     1       2X,A1,A1)
 8022 FORMAT(5X,'$H_a$: $',A1,'sigma_1$  = $',A1,'sigma_2$ & & ',
     1       2X,A1,A1)
 8023 FORMAT(5X,' &   & ',2X,A1,A1)
 8024 FORMAT(5X,'{',A1,'bf Sample 1:} &   & ',2X,A1,A1)
 8025 FORMAT(5X,'Number of Observations & = & ',I8,2X,A1,A1)
 8026 FORMAT(5X,'Mean & = & ',G15.7,2X,A1,A1)
 8027 FORMAT(5X,'Standard Deviation & = & ',
     1       G15.7,2X,A1,A1)
 8028 FORMAT(5X,'{',A1,'bf Test:} &   & ',2X,A1,A1)
 8029 FORMAT(5X,'Standard Deviation (Numerator) & = & ',
     1       G15.7,2X,A1,A1)
 8030 FORMAT(5X,'Standard Deviation (Denomerator) & = & ',
     1       G15.7,2X,A1,A1)
 8031 FORMAT(5X,'F-Test Statistic & = & ',G15.7,2X,A1,A1)
 8032 FORMAT(5X,'Degrees of Freedom (Numerator) & = & ',I8,2X,A1,A1)
 8033 FORMAT(5X,'Degrees of Freedom (Denomerator) & = & ',I8,2X,A1,A1)
 8034 FORMAT(5X,'F-Test Statistic CDF Value & = & ',G15.7,2X,A1,A1)
 8040 FORMAT(5X,A1,'hline')
 8049 FORMAT(A1,'end{tabular}')
        WRITE(ICOUT,8009)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8020)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8021)IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8022)IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,8023)IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8024)IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8025)N1,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8026)Y1MEAN,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8027)Y1SD,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8023)IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,8023)IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8024)IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8025)N2,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8026)Y2MEAN,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8027)Y2SD,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8023)IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,8028)IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8029)SDNUM,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8030)SDDEN,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8031)RATIO,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8032)INT(DFNUM + 0.5),IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8033)INT(DFDEN + 0.5),IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8034)CDF,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{center}')
        WRITE(ICOUT,8091)IBASLC
        CALL DPWRST('XXX','WRIT')
C
C  STEP 1: START TABLE ENVIRONMENT, WRITE A HEADER, AND
C          WRITE A TABLE CAPTION
C
 8109 FORMAT(A1,'begin{center}')
 8113 FORMAT(A1,'end{center}')
 8115 FORMAT(5X,'} ',A1,A1)
C
        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} {ccc}')
 8121 FORMAT(5X,'{',A1,'bf Null} & {',A1,
     1       'bf Null Hypothesis} & {',A1,'bf Null Hypothesis}',
     1       2X,A1,A1)
 8122 FORMAT(5X,'{',A1,'bf Hypothesis} & {',A1,
     1       'bf Acceptance Interval} & {',A1,
     1       'bf Conclusion}',2X,A1,A1)
 8124 FORMAT(5X,'$',A1,'sigma_1 =  ',A1,'sigma_2 $ ',
     1       ' & (0.000,0.950) & ',A6,2X,A1,A1)
 8140 FORMAT(5X,A1,'hline')
 8149 FORMAT(A1,'end{tabular}')
        WRITE(ICOUT,8109)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8120)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8121)IBASLC,IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8122)IBASLC,IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8140)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8124)IBASLC,IBASLC,ICONC2,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8149)IBASLC
        CALL DPWRST('XXX','WRIT')
C
C STEP 3: END TABLE ENVIRONMENT, RESET ASIS MODE
C
 8191   FORMAT(A1,'end{center}')
 8193   FORMAT(A1,'end{table}')
 8199   FORMAT(A1,'begin{verbatim}')
        WRITE(ICOUT,8191)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8193)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8199)IBASLC
        CALL DPWRST('XXX','WRIT')
CCCCC WRITE IN RTF (RICH TEXT FORMAT)
      ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN
      ELSE
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4211)
 4211   FORMAT('    TWO SAMPLE F-TEST FOR EQUAL STANDARD DEVIATIONS')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4213)
 4213   FORMAT('NULL HYPOTHESIS:            SIGMA1 = SIGMA2')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4215)
 4215   FORMAT('ALTERNATIVE HYPOTHESIS:     SIGMA1 NOT EQUAL SIGMA2')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,4220)
 4220   FORMAT('SAMPLE 1:')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4221)N1
 4221   FORMAT(3X,'NUMBER OF OBSERVATIONS             = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4222)Y1MEAN
 4222   FORMAT(3X,'MEAN                               = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4223)Y1SD
 4223   FORMAT(3X,'STANDARD DEVIATION                 = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,4230)
 4230   FORMAT('SAMPLE 2:')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4231)N2
 4231   FORMAT(3X,'NUMBER OF OBSERVATIONS             = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4232)Y2MEAN
 4232   FORMAT(3X,'MEAN                               = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4233)Y2SD
 4233   FORMAT(3X,'STANDARD DEVIATION                 = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,4241)
 4241   FORMAT('TEST:')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4242)SDNUM
 4242   FORMAT(3X,'STANDARD DEVIATION (NUMERATOR)     = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4243)SDDEN
 4243   FORMAT(3X,'STANDARD DEVIATION (DENOMINATOR)   = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4244)RATIO
 4244   FORMAT(3X,'F-TEST STATISTIC VALUE             = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4245)DFNUM
 4245   FORMAT(3X,'DEGREES OF FREEDOM (NUMERATOR)     = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4246)DFDEN
 4246   FORMAT(3X,'DEGREES OF FREEDOM (DENOMINATOR)   = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4247)CDF
 4247   FORMAT(3X,'F-TEST STATISTIC CDF VALUE         = ',F11.6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,4260)
 4260   FORMAT('  NULL          NULL HYPOTHESIS        NULL ',
     1         'HYPOTHESIS')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4261)
 4261   FORMAT('  HYPOTHESIS    ACCEPTANCE INTERVAL    CONCLUSION')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4262)ICONC2
 4262   FORMAT('SIGMA1 = SIGMA2    (0.000,0.950)         ',A6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
      ENDIF
      ENDIF
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPFTE2--')
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,9012)N,IBUGA3,IERROR
 9012 FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,9015)N1
 9015 FORMAT('N1 = ',I8)
      CALL DPWRST('XXX','WRIT')
      DO9016I=1,N1
      WRITE(ICOUT,9017)I,Y1(I)
 9017 FORMAT('I,Y1(I) = ',I8,E15.7)
      CALL DPWRST('XXX','WRIT')
 9016 CONTINUE
      WRITE(ICOUT,9025)N2
 9025 FORMAT('N2 = ',I8)
      CALL DPWRST('XXX','WRIT')
      DO9026I=1,N2
      WRITE(ICOUT,9027)I,Y2(I)
 9027 FORMAT('I,Y2(I) = ',I8,E15.7)
      CALL DPWRST('XXX','WRIT')
 9026 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPFUEV(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,
     1IA,PARAM,IPARN,IPARN2,
     1IFOUNZ,IBEGIN,IEND,ITYPE,IHOL,IHOL2,INT1,FLOAT1,IERRO1,
     1NUMCL,NUMPL,NUMAOL,ITYW1L,ICAT1L,INLI1L,ITYW2L,
     1NUMCR,NUMPR,NUMAOR,ITYW1R,ICAT1R,INLI1R,ITYW2R,
     1IANGLU,IBUGA3,IBUGCO,IBUGEV,IBUGQ,IFOUND,IERROR)
C
C     PURPOSE--TREAT THE TYPE 6 LET CASE--
C              COMPUTING A GENERAL FUNCTION
C              (FOR A PARAMETER, A FULL VARIABLE,
C              OR PART OF A VARIABLE).
C     OUTPUT--A PARAMETER OR A VARIABLE.
C     EXAMPLE--IN THE FOLLOWING EXAMPLES,
C              A REPRESENTS A PREVIOUSLY-DEFINED PARAMETER
C              B REPRESENTS A PREVIOUSLY-DEFINED PARAMETER
C              X REPRESENTS A PREVIOUSLY-DEFINED VARIABLE (VECTOR)
C              Y REPRESENTS A PREVIOUSLY-DEFINED VARIABLE (VECTOR)
C              U REPRESENTS AN UNYET-DEFINED TERM
C              I REPRESENTS A DUMMY VARIABLE
C                     --LET A    = I                         (ILLEGAL)
C                     --LET A    = X(2)                      (A PARAMETER)
C                     --LET A    = 3*SIN(4)                  (A PARAMETER)
C                     --LET A    = B*SIN(B)                  (A PARAMETER)
C                     --LET A    = X*SIN(X)                  (ILLEGAL)
C
C                     --LET Y    = I                         (ILLEGAL)
C                     --LET Y    = X(2)                      (ILLEGAL)
C                     --LET Y    = 3*SIN(4)                  (ILLEGAL)
C                     --LET Y    = B*SIN(B)                  (ILLEGAL)
C                     --LET Y    = X*SIN(X)                  (A FULL VARIABLE)
C
C                     --LET Y(I) = I                         (A FULL VARIABLE)
C                     --LET Y(I) = X(2)                      (A FULL VARIABLE)
C                     --LET Y(I) = 3*SIN(4)                  (A FULL VARIABLE)
C                     --LET Y(I) = B*SIN(B)                  (A FULL VARIABLE)
C                     --LET Y(I) = X*SIN(X)                  (A FULL VARIABLE)
C
C                     --LET Y(2) = I                         (ILLEGAL)
C                     --LET Y(2) = X(2)                      (AN EL. OF A VAR.)
C                     --LET Y(2) = 3*SIN(4)                  (AN EL. OF A VAR.)
C                     --LET Y(2) = B*SIN(B)                  (AN EL. OF A VAR.)
C                     --LET Y(2) = X*SIN(X)                  (ILLEGAL)
C
C                     --LET U    = I                         (ILLEGAL)
C                     --LET U    = X(2)                      (A PARAMETER)
C                     --LET U    = 3*SIN(4)                  (A PARAMETER)
C                     --LET U    = B*SIN(B)                  (A PARAMETER)
C                     --LET U    = X*SIN(X)                  (A FULL VARIABLE)
C
C                     --LET U(I) = I                         (ILLEGAL)
C                     --LET U(I) = X(2)                      (ILLEGAL)
C                     --LET U(I) = 3*SIN(4)                  (ILLEGAL)
C                     --LET U(I) = B*SIN(B)                  (ILLEGAL)
C                     --LET U(I) = X*SIN(X)                  (A FULL VARIABLE)
C
C                     --LET U(2) = I                         (ILLEGAL)
C                     --LET U(2) = X(2)                      (AN EL. OF A VAR.)
C                     --LET U(2) = 3*SIN(4)                  (AN EL. OF A VAR.)
C                     --LET U(2) = B*SIN(B)                  (AN EL. OF A VAR.)
C                     --LET U(2) = X*SIN(X)                  (ILLEGAL)
C                ********************************
C
C                     --LET A    = I         SUBSET 2 3 5    (ILLEGAL)
C                     --LET A    = X(2)      SUBSET 2 3 5    (ILLEGAL)
C                     --LET A    = 3*SIN(4)  SUBSET 2 3 5    (ILLEGAL)
C                     --LET A    = B*SIN(B)  SUBSET 2 3 5    (ILLEGAL)
C                     --LET A    = X*SIN(X)  SUBSET 2 3 5    (ILLEGAL)
C
C                     --LET Y    = I         SUBSET 2 3 5    (A PARTIAL VAR.)
C                     --LET Y    = X(2)      SUBSET 2 3 5    (A PARTIAL VAR.)
C                     --LET Y    = 3*SIN(4)  SUBSET 2 3 5    (A PARTIAL VAR.)
C                     --LET Y    = B*SIN(B)  SUBSET 2 3 5    (A PARTIAL VAR.)
C                     --LET Y    = X*SIN(X)  SUBSET 2 3 5    (A PARTIAL VAR.)
C
C                     --LET Y(I) = I         SUBSET 2 3 5    (A PARTIAL VAR.)
C                     --LET Y(I) = X(2)      SUBSET 2 3 5    (A PARTIAL VAR.)
C                     --LET Y(I) = 3*SIN(4)  SUBSET 2 3 5    (A PARTIAL VAR.)
C                     --LET Y(I) = B*SIN(B)  SUBSET 2 3 5    (A PARTIAL VAR.)
C                     --LET Y(I) = X*SIN(X)  SUBSET 2 3 5    (A PARTIAL VAR.)
C
C                     --LET Y(2) = I         SUBSET 2 3 5    (ILLEGAL)
C                     --LET Y(2) = X(2)      SUBSET 2 3 5    (ILLEGAL)
C                     --LET Y(2) = 3*SIN(4)  SUBSET 2 3 5    (ILLEGAL)
C                     --LET Y(2) = B*SIN(B)  SUBSET 2 3 5    (ILLEGAL)
C                     --LET Y(2) = X*SIN(X)  SUBSET 2 3 5    (ILLEGAL)
C
C                     --LET U    = I         SUBSET 2 3 5    (A PARTIAL VAR.)
C                     --LET U    = X(2)      SUBSET 2 3 5    (A PARTIAL VAR.)
C                     --LET U    = 3*SIN(4)  SUBSET 2 3 5    (A PARTIAL VAR.)
C                     --LET U    = B*SIN(B)  SUBSET 2 3 5    (A PARTIAL VAR.)
C                     --LET U    = X*SIN(X)  SUBSET 2 3 5    (A PARTIAL VAR.)
C
C                     --LET U(I) = I         SUBSET 2 3 5    (A PARTIAL VAR.)
C                     --LET U(I) = X(2)      SUBSET 2 3 5    (A PARTIAL VAR.)
C                     --LET U(I) = 3*SIN(4)  SUBSET 2 3 5    (A PARTIAL VAR.)
C                     --LET U(I) = B*SIN(B)  SUBSET 2 3 5    (A PARTIAL VAR.)
C                     --LET U(I) = X*SIN(X)  SUBSET 2 3 5    (A PARTIAL VAR.)
C
C                     --LET U(2) = I         SUBSET 2 3 5    (ILLEGAL)
C                     --LET U(2) = X(2)      SUBSET 2 3 5    (ILLEGAL)
C                     --LET U(2) = 3*SIN(4)  SUBSET 2 3 5    (ILLEGAL)
C                     --LET U(2) = B*SIN(B)  SUBSET 2 3 5    (ILLEGAL)
C                     --LET U(2) = X*SIN(X)  SUBSET 2 3 5    (ILLEGAL)
C
C                ********************************
C
C                     --LET A    = I         FOR I = 1 2 10  (ILLEGAL)
C                     --LET A    = X(2)      FOR I = 1 2 10  (ILLEGAL)
C                     --LET A    = 3*SIN(4)  FOR I = 1 2 10  (ILLEGAL)
C                     --LET A    = B*SIN(B)  FOR I = 1 2 10  (ILLEGAL)
C                     --LET A    = X*SIN(X)  FOR I = 1 2 10  (ILLEGAL)
C
C                     --LET Y    = I         FOR I = 1 2 10  (A PARTIAL VAR.)
C                     --LET Y    = X(2)      FOR I = 1 2 10  (A PARTIAL VAR.)
C                     --LET Y    = 3*SIN(4)  FOR I = 1 2 10  (A PARTIAL VAR.)
C                     --LET Y    = B*SIN(B)  FOR I = 1 2 10  (A PARTIAL VAR.)
C                     --LET Y    = X*SIN(X)  FOR I = 1 2 10  (A PARTIAL VAR.)
C
C                     --LET Y(I) = I         FOR I = 1 2 10  (A PARTIAL VAR.)
C                     --LET Y(I) = X(2)      FOR I = 1 2 10  (A PARTIAL VAR.)
C                     --LET Y(I) = 3*SIN(4)  FOR I = 1 2 10  (A PARTIAL VAR.)
C                     --LET Y(I) = B*SIN(B)  FOR I = 1 2 10  (A PARTIAL VAR.)
C                     --LET Y(I) = X*SIN(X)  FOR I = 1 2 10  (A PARTIAL VAR.)
C
C                     --LET Y(2) = I         FOR I = 1 2 10  (ILLEGAL)
C                     --LET Y(2) = X(2)      FOR I = 1 2 10  (ILLEGAL)
C                     --LET Y(2) = 3*SIN(4)  FOR I = 1 2 10  (ILLEGAL)
C                     --LET Y(2) = B*SIN(B)  FOR I = 1 2 10  (ILLEGAL)
C                     --LET Y(2) = X*SIN(X)  FOR I = 1 2 10  (ILLEGAL)
C
C                     --LET U    = I         FOR I = 1 2 10  (A PARTIAL VAR.)
C                     --LET U    = X(2)      FOR I = 1 2 10  (A PARTIAL VAR.)
C                     --LET U    = 3*SIN(4)  FOR I = 1 2 10  (A PARTIAL VAR.)
C                     --LET U    = B*SIN(B)  FOR I = 1 2 10  (A PARTIAL VAR.)
C                     --LET U    = X*SIN(X)  FOR I = 1 2 10  (A PARTIAL VAR.)
C
C                     --LET U(I) = I         FOR I = 1 2 10  (A PARTIAL VAR.)
C                     --LET U(I) = X(2)      FOR I = 1 2 10  (A PARTIAL VAR.)
C                     --LET U(I) = 3*SIN(4)  FOR I = 1 2 10  (A PARTIAL VAR.)
C                     --LET U(I) = B*SIN(B)  FOR I = 1 2 10  (A PARTIAL VAR.)
C                     --LET U(I) = X*SIN(X)  FOR I = 1 2 10  (A PARTIAL VAR.)
C
C                     --LET U(2) = I         FOR I = 1 2 10  (ILLEGAL)
C                     --LET U(2) = X(2)      FOR I = 1 2 10  (ILLEGAL)
C                     --LET U(2) = 3*SIN(4)  FOR I = 1 2 10  (ILLEGAL)
C                     --LET U(2) = B*SIN(B)  FOR I = 1 2 10  (ILLEGAL)
C                     --LET U(2) = X*SIN(X)  FOR I = 1 2 10  (ILLEGAL)
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION (IN DPLET)--DECEMBER 1977.
C     ORIGINAL VERSION AS A SEPARATE SUBROUTINE--MARCH 1978.
C     UPDATED         --MAY       1982.
C     UPDATED         --JULY      1978.
C     UPDATED         --NOVEMBER  1978.
C     UPDATED         --FEBRUARY  1979.
C     UPDATED         --MARCH     1979.
C     UPDATED         --JUNE      1981.
C     UPDATED         --SEPTEMBER 1981.
C     UPDATED         --OCTOBER   1981.
C     UPDATED         --NOVEMBER  1981.
C     UPDATED         --JANUARY   1982.
C     UPDATED         --APRIL     1982.
C     UPDATED         --MARCH     1986.
C     UPDATED         --JANUARY   1988.  CUTOFF VALUE FOR CDC COMPUTERS
C     UPDATED         --MARCH     1988.  FIX LET PRED=... SUBSET/FOR/ALL
C     UPDATED         --DECEMBER  1988.  FIX LET Y(K) = X(K) INSIDE LOOP
C     UPDATED         --FEBRUARY  1989.  CUTOFF VALUE FOR CDC 205 COMPUTER
C     UPDATED         --MARCH     2003.  FOR PARAMETERS, CHECK FOR
C                                        IVALUE > LARGEST MACHINE
C                                        INTEGER
C     UPDATED         --FEBRUARY  2005.  IF FUNCTION DEFINED WITH
C                                        "LET STRING", CASE PRESERVED.
C                                        WHEN FUNCTION EXTRACTED IN
C                                        THIS CONTEXT, NEED TO
C                                        CONVERT LOWER CASE TO UPPER
C                                        CASE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ITYPEH
      CHARACTER*4 IW21HO
      CHARACTER*4 IW22HO
      CHARACTER*4 IA
      CHARACTER*4 IPARN
      CHARACTER*4 IPARN2
      CHARACTER*4 IFOUNZ
      CHARACTER*4 ITYPE
      CHARACTER*4 IHOL
      CHARACTER*4 IHOL2
      CHARACTER*4 IERRO1
      CHARACTER*4 ITYW1L
      CHARACTER*4 ICAT1L
      CHARACTER*4 INLI1L
      CHARACTER*4 ITYW2L
      CHARACTER*4 ITYW1R
      CHARACTER*4 ICAT1R
      CHARACTER*4 INLI1R
      CHARACTER*4 ITYW2R
      CHARACTER*4 IANGLU
      CHARACTER*4 IBUGA3
      CHARACTER*4 IBUGCO
      CHARACTER*4 IBUGEV
      CHARACTER*4 IBUGQ
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWD1
      CHARACTER*4 IWD2
      CHARACTER*4 IWD12
      CHARACTER*4 IWD22
      CHARACTER*4 IVOLDR
      CHARACTER*4 IVOLR2
      CHARACTER*4 IHWUSE
      CHARACTER*4 MESSAG
      CHARACTER*4 NEWNAM
      CHARACTER*4 NEWCOL
      CHARACTER*4 IVNEWR
      CHARACTER*4 IVNER2
      CHARACTER*4 ICASEL
      CHARACTER*4 ICASER
      CHARACTER*4 ICASEQ
      CHARACTER*4 ICASIF
      CHARACTER*4 IPJ
      CHARACTER*4 IPJ2
      CHARACTER*4 IHSET
      CHARACTER*4 IHSET2
      CHARACTER*4 ILEFT
      CHARACTER*4 ILEFT2
      CHARACTER*4 IRIGHT
      CHARACTER*4 IRIGH2
      CHARACTER*4 IARG4F
      CHARACTER*4 IARG4T
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION IFOUNZ(*)
      DIMENSION IBEGIN(*)
      DIMENSION IEND(*)
      DIMENSION ITYPE(*)
      DIMENSION IHOL(*)
      DIMENSION IHOL2(*)
      DIMENSION INT1(*)
      DIMENSION FLOAT1(*)
      DIMENSION IERRO1(*)
C
      DIMENSION ITYPEH(*)
      DIMENSION IW21HO(*)
      DIMENSION IW22HO(*)
      DIMENSION W2HOLD(*)
C
      DIMENSION IA(*)
      DIMENSION PARAM(*)
      DIMENSION IPARN(*)
      DIMENSION IPARN2(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOHK.INC'
      INCLUDE 'DPCODA.INC'
      INCLUDE 'DPCOHO.INC'
      INCLUDE 'DPCOMC.INC'
C
      CHARACTER*4 IFSAVE
      DIMENSION IFSAVE(MAXF1)
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='DPFU'
      ISUBN2='EV  '
C
C  CONVERT FUNCTION TABLE TO UPPER CASE, BUT SAVE ORIGINAL FIRST
C
      DO10I=1,NUMCHF
        IFSAVE(I)=IFUNC(I)
CCCCC   CALL DPCOAN(IFSAVE(I)(1:1),IATEMP)
CCCCC   IF(IATEMP.GE.97 .AND. IATEMP.LE.122)THEN
CCCCC     IATEMP=IATEMP-32
CCCCC     CALL DPCONA(IATEMP,IFSAVE(I)(1:1))
CCCCC   ENDIF
   10 CONTINUE
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
C               *******************************************************
C               **  TREAT THE CASE OF A GENERAL FUNCTION EVALUATION  **
C               **        1) FOR A PARAMETER,                        **
C               **        2) FOR A FULL VARIABLE, OR                 **
C               **        3) 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 DPFUEV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IBUGCO,IBUGEV
   53 FORMAT('IBUGCO,IBUGEV = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)IBUGQ
   54 FORMAT('IBUGQ = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)IANGLU
   55 FORMAT('IANGLU = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,57)NUMNAM
   57 FORMAT('NUMNAM = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO60I=1,NUMNAM
      WRITE(ICOUT,61)I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I)
   61 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) = ',
     1I8,2X,A4,2X,A4,2X,A4,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   60 CONTINUE
   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
      MAXN2=MAXCHF
      MAXN3=MAXCHF
      MAXN4=MAXCHF
C
      IF(IBUGA3.EQ.'OFF')GOTO99
      WRITE(ICOUT,91)
   91 FORMAT('I,IFOUNZ(I),ITYPE(I),IHOL(I),IHOL2(I),INT1(I),',
     1'FLOAT1(I)--')
      CALL DPWRST('XXX','BUG ')
      DO92I=1,30
      WRITE(ICOUT,93)I,IFOUNZ(I),ITYPE(I),IHOL(I),IHOL2(I),INT1(I),
     1FLOAT1(I)
   93 FORMAT(I3,2X,A4,2X,A4,2X,A4,2X,A4,2X,I8,2X,E15.7)
      CALL DPWRST('XXX','BUG ')
   92 CONTINUE
   99 CONTINUE
C
C               ****************************************************************
C               **  STEP 2--                                                   *
C               **  EXAMINE THE LEFT-HAND SIDE--                               *
C               **  IS THE PARAMETER OR VARIABLE NAME TO LEFT OF = SIGN        *
C               **  ALREADY IN THE NAME LIST?                                  *
C               **  IS IT A PARAMETER OR A VARIABLE?                           *
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               **  WHEN THIS STEP IS FINISHED,                                *
C               **  ICASEL   WILL HAVE ONE OF THE FOLLOWING 3 VALUES--         *
C               **           1) PARAM                                          *
C               **           2) VAR                                            *
C               **           3) UNKNOWN (YET TO BE DEFINED; DEPENDS ON RIGHT). *
C               ****************************************************************
C               ****************************************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICASEL='UNKN'
      ILEFT=IHOL(2)
      ILEFT2=IHOL2(2)
      DO2000I=1,NUMNAM
      I2=I
      IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND.
     1IUSE(I).EQ.'P')GOTO2500
      IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND.
     1IUSE(I).EQ.'V')GOTO2600
 2000 CONTINUE
      ICASEL='UNKN'
      NEWNAM='YES'
      ILISTL=NUMNAM+1
      IF(ILISTL.GT.MAXNAM)GOTO2800
      GOTO2900
C
 2500 CONTINUE
      ICASEL='PARA'
      ILISTL=I2
      GOTO2900
C
 2600 CONTINUE
      ICASEL='VAR'
      ILISTL=I2
      ICOLL=IVALUE(ILISTL)
      NILEFT=IN(ILISTL)
      GOTO2900
C
 2800 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2801)
 2801 FORMAT('***** ERROR IN DPFUEV AT 2801--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2802)
 2802 FORMAT('      THE NUMBER OF VARIABLE AND/OR PARAMETER')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2803)MAXNAM
 2803 FORMAT('      NAMES HAS JUST EXCEEDED THE MAX ALLOWABLE ',
     1I8,'  .')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2804)
 2804 FORMAT('      SUGGESTED ACTION--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2805)
 2805 FORMAT('      ENTER      STAT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2806)
 2806 FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2807)
 2807 FORMAT('      AND THEN REDEFINE (REUSE) SOME OF THE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2808)
 2808 FORMAT('      ALREADY-USED NAMES')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO19000
C
 2900 CONTINUE
C
C               **************************************************
C               **  STEP 3--                                    **
C               **  EXAMINE THE RIGHT-HAND SIDE--               **
C               **  1)  FIRST, SCREEN OUT THE DUMMY             **
C               **      AND THE ELEMENT SPECIFICATION CASES;    **
C               **  2)  THEN EXTRACT THE FUNCTIONAL EXPRESSION; **
C               **  3)  DETERMINE THE TYPE OF QUALIFIERS--      **
C               **      A)  NONE (= FULL = UNQUALIFIED);        **
C               **      B)  SUBSET/EXCEPT; OR                   **
C               **      C)  FOR.                                **
C               **  4)  EXAMINE THE FUNCTION    AL EXPRESSION   **
C               **      FOR PARAMETERS AND VARIABLES.           **
C               **  WHEN THIS STEP IS FINISHED,                 **
C               **  ICASER  WILL BE FULLY DETERMINED AND        **
C               **  WILL HAVE ONE OF THE FOLLOWING 4 VALUES--   **
C               **          1) DUMMY;                           **
C               **          2) ELEMENT;                         **
C               **          3) PARAM (NO VARIABLES);            **
C               **          4) VAR (AT LEAST ONE VARIABLE).     **
C               **  WHEN THIS STEP IS FINISHED,                 **
C               **  ICASEQ  WILL BE FILLY DETERMINED AND        **
C               **  WILL HAVE ONE OF THE FOLLOWING 3 VALUES--   **
C               **          1) FULL;                            **
C               **          2) SUBSET/EXCEPT OR;                **
C               **          3) FOR.                             **
C               **************************************************
C
      ISTEPN='3'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICASER='UNKN'
      ICASEQ='UNKN'
      IF(NUMCR.EQ.1.AND.NUMPR.EQ.0.AND.NUMAOR.EQ.0.
     1AND.ITYW1R.EQ.'WORD'.AND.INLI1R.EQ.'NO')GOTO3010
      IF(1.LE.NUMCR.AND.NUMCR.LE.4.AND.NUMPR.EQ.2.AND.NUMAOR.EQ.0.
     1AND.ITYW1R.EQ.'WORD'.AND.ICAT1R.EQ.'VARP'.
     1AND.INLI1R.EQ.'YES'.AND.ITYW2R.EQ.'NUMB')GOTO3020
      IF(1.LE.NUMCR.AND.NUMCR.LE.4.AND.NUMPR.EQ.2.AND.NUMAOR.EQ.0.
     1AND.ITYW1R.EQ.'WORD'.AND.ICAT1R.EQ.'VARP'.
     1AND.INLI1R.EQ.'YES'.AND.ITYW2R.EQ.'WORD')GOTO3020
      GOTO3090
C
 3010 CONTINUE
      ICASER='DUMM'
      IF(IFOUNZ(11).EQ.'NO'.AND.IFOUNZ(21).EQ.'NO')ICASEQ='FULL'
      IF(IFOUNZ(11).EQ.'YES')ICASEQ='SUBS'
      IF(IFOUNZ(21).EQ.'YES')ICASEQ='FOR'
      GOTO3990
C
 3020 CONTINUE
      ICASER='ELEM'
      IRIGHT=IHOL(7)
      IRIGH2=IHOL2(7)
      DO3030I=1,NUMNAM
      I2=I
      IF(IRIGHT.EQ.IHNAME(I).AND.IRIGH2.EQ.IHNAM2(I).AND.
     1IUSE(I).EQ.'P')GOTO3040
      IF(IRIGHT.EQ.IHNAME(I).AND.IRIGH2.EQ.IHNAM2(I).AND.
     1IUSE(I).EQ.'V')GOTO3050
 3030 CONTINUE
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3031)
 3031 FORMAT('***** ERROR IN DPFUEV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3032)
 3032 FORMAT('      THE VARIABLE NAME ON THE RIGHT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3033)
 3033 FORMAT('      OF THE = SIGN')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3034)
 3034 FORMAT('      WAS NOT FOUND IN THE INTERNAL NAME LIST.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3035)
 3035 FORMAT('      THE COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3036)(IANS(I),I=1,IWIDTH)
 3036 FORMAT(80A1)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO19000
C
 3040 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3041)
 3041 FORMAT('***** ERROR IN DPFUEV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3042)
 3042 FORMAT('      THE VARIABLE NAME ON THE RIGHT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3043)
 3043 FORMAT('      OF THE = SIGN')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3044)
 3044 FORMAT('      WAS FOUND IN THE INTERNAL NAME LIST,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3045)
 3045 FORMAT('      BUT AS A PARAMETER,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3046)
 3046 FORMAT('      AND NOT AS A VARIABLE AS IT SHOULD BE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3047)
 3047 FORMAT('      THE COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3048)(IANS(I),I=1,IWIDTH)
 3048 FORMAT(80A1)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO19000
C
 3050 CONTINUE
      ILISTR=I2
      ICOLR=IVALUE(ILISTR)
      NIRIGH=IN(ILISTR)
C
      IARGIR=INT1(9)
      IF(1.LE.IARGIR.AND.IARGIR.LE.MAXN)GOTO3060
      WRITE(ICOUT,3061)
 3061 FORMAT('***** ERROR IN DPFUEV')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3062)
 3062 FORMAT('      THE SPECIFIED ARGUMENT (ROW NUMBER)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3063)
 3063 FORMAT('      ON THE RIGHT SIDE OF THE = SIGN')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3064)
 3064 FORMAT('      IS SMALLER THAN 1 OR')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3065)
 3065 FORMAT('      LARGER THAN THE MAXIMUM ALLOWABLE NUMBER  ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3066)MAXN
 3066 FORMAT('      (',I6,')  FOR A GIVEN VARIABLE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3067)IARGIR
 3067 FORMAT('      THE VALUE (IARGIR) = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3068)
 3068 FORMAT('      THE COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3069)(IANS(I),I=1,IWIDTH)
 3069 FORMAT(80A1)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO19000
C
 3060 CONTINUE
      IF(IFOUNZ(11).EQ.'NO'.AND.IFOUNZ(21).EQ.'NO')ICASEQ='FULL'
      IF(IFOUNZ(11).EQ.'YES')ICASEQ='SUBS'
      IF(IFOUNZ(21).EQ.'YES')ICASEQ='FOR'
      GOTO3990
C
 3090 CONTINUE
      ICASEQ='UNKN'
C
C     LOCATE THE EQUAL SIGN.
C
      DO3100I=1,IWIDTH
      I2=I
      IF(IANS(I).EQ.'=')GOTO3150
 3100 CONTINUE
      GOTO3400
 3150 CONTINUE
      ISTART=I2
C
      IF(ISTART.GT.IWIDTH)GOTO3400
      DO3200I=ISTART,IWIDTH
      I2=I
      IP1=I+1
      IP2=I+2
      IP3=I+3
      IP4=I+4
      IP5=I+5
      IP6=I+6
      IP7=I+7
      IF(IP7.GT.IWIDTH)GOTO3230
      IF(IANS(I).EQ.' '.AND.IANS(IP1).EQ.'S'.AND.IANS(IP2).EQ.'U'
     1.AND.IANS(IP3).EQ.'B'.AND.IANS(IP4).EQ.'S'.AND.IANS(IP5).EQ.'E'
     1.AND.IANS(IP6).EQ.'T'.AND.IANS(IP7).EQ.' ')GOTO3250
      IF(IANS(I).EQ.' '.AND.IANS(IP1).EQ.'F'.AND.IANS(IP2).EQ.'O'
     1.AND.IANS(IP3).EQ.'R'.AND.IANS(IP4).EQ.' ')GOTO3270
      IF(IANS(I).EQ.' '.AND.IANS(IP1).EQ.'I'.AND.IANS(IP2).EQ.'F'
     1.AND.IANS(IP3).EQ.' ')GOTO3280
 3200 CONTINUE
C
 3230 CONTINUE
      ICASEQ='FULL'
      ISTOP=IWIDTH
      GOTO3290
C
 3250 CONTINUE
      ICASEQ='SUBS'
      ISTOP=I2
      GOTO3290
C
 3270 CONTINUE
      ICASEQ='FOR'
      ISTOP=I2
      GOTO3290
C
 3280 CONTINUE
      ICASEQ='IF'
      ISTOP=I2
      GOTO3290
C
 3290 CONTINUE
C
C               ***************************************
C               **  STEP 3.1--                       **
C               **  EXTRACT THE UNDERLYING FUNCTION  **
C               **  FROM FUNCTION DEFINITIONS.       **
C               ***************************************
C
      ISTEPN='3.1'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CCCCC J=0
CCCCC IMIN=ISTART+1
CCCCC DO3370I=IMIN,ISTOP
CCCCC J=J+1
CCCCC IA(J)=IANS(I)
C3370 CONTINUE
CCCCC NUMCHA=J
C
      IWD1='=   '
      IWD12='    '
      IF(ICASEQ.EQ.'FULL')IWD2='    '
      IF(ICASEQ.EQ.'FULL')IWD22='    '
      IF(ICASEQ.EQ.'SUBS'.AND.IHOL(11).EQ.'SUBS')IWD2='SUBS'
      IF(ICASEQ.EQ.'SUBS'.AND.IHOL(11).EQ.'SUBS')IWD22='ET  '
      IF(ICASEQ.EQ.'SUBS'.AND.IHOL(11).EQ.'EXCE')IWD2='EXCE'
      IF(ICASEQ.EQ.'SUBS'.AND.IHOL(11).EQ.'EXCE')IWD22='PT  '
      IF(ICASEQ.EQ.'FOR ')IWD2='FOR '
      IF(ICASEQ.EQ.'FOR ')IWD22='    '
      IF(ICASEQ.EQ.'IF  ')IWD2='IF  '
      IF(ICASEQ.EQ.'IF  ')IWD22='    '
      CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2,
     1IFUNC2,N2,IBUGA3,IFOUND,IERROR)
      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3011)
 3011 FORMAT('***** FROM DPFUEV, AFTER  THE CALL TO DPEXST--')
      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IF(IERROR.EQ.'YES')GOTO19000
      IF(IFOUND.EQ.'YES')GOTO3379
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3371)
 3371 FORMAT('***** ERROR IN DPFUEV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3372)
 3372 FORMAT('      INVALID COMMAND FORM FOR FUNCTION EVALUATION.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3373)
 3373 FORMAT('      GENERAL FORM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3374)
 3374 FORMAT('      LET ... = ...  ',
     1'SUBSET ... ... ...')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3375)
 3375 FORMAT('      THE ENTIRE COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,3376)(IANS(I),I=1,IWIDTH)
 3376 FORMAT('      ',100A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO19000
 3379 CONTINUE
C
      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3012)
 3012 FORMAT('***** FROM DPFUEV, BEFORE THE CALL TO DPEXFU--')
      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
      DO3018I=1,N2
        IA(I)=IFUNC2(I)
        ITEMP=ICHAR(IFUNC2(I)(1:1))
        IF(ITEMP.GE.97 .AND. ITEMP.LE.122)THEN
          ITEMP=ITEMP-32
          IFUNC2(I)(1:1)=CHAR(ITEMP)
        ENDIF
 3018 CONTINUE
C
      CALL DPEXFU(IFUNC2,N2,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP,
     1NUMNAM,IANS,IWIDTH,IFUNC,NUMCHF,MAXCHF,IFUNC3,N3,MAXN3,
     1IBUGA3,IERROR)
      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3013)
 3013 FORMAT('***** FROM DPFUEV, AFTER  THE CALL TO DPEXFU--')
      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IF(IERROR.EQ.'YES')GOTO19000
C
      J=0
      DO3380I=1,N3
        J=J+1
        IA(J)=IFUNC3(I)
        ITEMP=ICHAR(IA(J)(1:1))
        IF(ITEMP.GE.97 .AND. ITEMP.LE.122)THEN
          ITEMP=ITEMP-32
          IA(J)(1:1)=CHAR(ITEMP)
        ENDIF
 3380 CONTINUE
      NUMCHA=J
      GOTO3500
C
 3400 CONTINUE
      WRITE(ICOUT,3411)
 3411 FORMAT('***** INTERNAL ERROR IN DPFUEV')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3412)
 3412 FORMAT('      AT BRANCH POINT 3400--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3413)
 3413 FORMAT('      ISTART GREATER THAN ISTOP.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3418)
 3418 FORMAT('      THE COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3419)(IANS(I),I=1,IWIDTH)
 3419 FORMAT(80A1)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO19000
C
 3500 CONTINUE
      ICASER='UNKN'
C
      IPASS=1
      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3014)
 3014 FORMAT('***** FROM DPFUEV, BEFORE THE CALL TO COMPIM--')
      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
      CALL COMPIM(IA,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPAR,
     1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,AJUNK,
     1IBUGCO,IBUGEV,IERROR)
      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3015)
 3015 FORMAT('***** FROM DPFUEV, AFTER  THE CALL TO COMPIM--')
      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IF(IERROR.EQ.'YES')GOTO19000
C
      NUMP=0
      NUMV=0
      NIOLDR=0
      IVOLDR='JUNK'
      IVOLR2='JUNK'
      IF(NUMPAR.EQ.0)GOTO3900
      DO3600J=1,NUMPAR
      DO3700I=1,NUMNAM
      I2=I
      IF(IPARN(J).EQ.IHNAME(I).AND.IPARN2(J).EQ.IHNAM2(I).AND.
     1IUSE(I).EQ.'P')GOTO3850
      IF(IPARN(J).EQ.IHNAME(I).AND.IPARN2(J).EQ.IHNAM2(I).AND.
     1IUSE(I).EQ.'V')GOTO3870
 3700 CONTINUE
      GOTO3800
C
 3850 CONTINUE
      NUMP=NUMP+1
      GOTO3600
C
 3870 CONTINUE
      NUMV=NUMV+1
      NIRIGH=IN(I2)
      NIOLDR=NINEWR
      IVOLDR=IVNEWR
      IVOLR2=IVNER2
      NINEWR=IN(I2)
      IVNEWR=IHNAME(I2)
      IVNER2=IHNAM2(I2)
      IF(NUMV.GE.2.AND.NINEWR.NE.NIOLDR)GOTO3820
      GOTO3600
C
 3600 CONTINUE
      GOTO3900
C
 3800 CONTINUE
      WRITE(ICOUT,3801)
 3801 FORMAT('***** ERROR IN DPFUEV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3802)
 3802 FORMAT('      A VARIABLE OR PARAMETER NAME USED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3803)
 3803 FORMAT('      IN AN EXPRESSION IS NOT YET DEFINED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3804)IPARN(J),IPARN2(J)
 3804 FORMAT('      VARIABLE OR PARAMETER NAME = ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      GOTO3809
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,3805)
C3805 FORMAT('      CURRENT LIST OF DEFINED VARIABLES AND ',
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC1'PARAMETERS--')
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC DO3806I2=1,NUMNAM
CCCCC WRITE(ICOUT,3807)IHNAME(I2),IHNAM2(I2),IUSE(I2),IVALUE(I2),
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC1VALUE(I2),IN(I2)
C3807 FORMAT(6X,A4,A4,6X,A4,6X,I6,6X,E15.6,I6)
C3806 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,3808)(IA(I),I=1,NUMCHA)
C3808 FORMAT('      FUNCTION EXPRESSION--'100A1)
CCCCC CALL DPWRST('XXX','BUG ')
 3809 CONTINUE
      IERROR='YES'
      GOTO19000
C
 3820 CONTINUE
      WRITE(ICOUT,3821)
 3821 FORMAT('***** ERROR IN DPFUEV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3822)
 3822 FORMAT('      ALL VARIABLES USED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3823)
 3823 FORMAT('      IN A FUNCTIONAL EXPRESSION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3824)
 3824 FORMAT('      MUST HAVE THE SAME LENGTH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3825)
 3825 FORMAT('      (NUMBER OF ELEMENTS);')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3826)
 3826 FORMAT('      SUCH WAS NOT THE CASE HERE FOR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3827)IVOLDR,IVOLR2,NIOLDR
 3827 FORMAT('      VARIABLE ',A4,A4,' WITH ',I8,' ELEMENTS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3828)IVNEWR,IVNER2,NINEWR
 3828 FORMAT('      VARIABLE ',A4,A4,' WITH ',I8,' ELEMENTS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3829)
 3829 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,3830)(IANS(I),I=1,IWIDTH)
 3830 FORMAT(80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO19000
C
 3900 CONTINUE
      ICASER='VAR'
      IF(NUMV.LE.0)ICASER='PARA'
C
 3990 CONTINUE
C
C               *******************************
C               **  STEP 4--                 **
C               **  DETERMINE THE SUBCASE    **
C               **  AND BRANCH ACCORDINGLY.  **
C               *******************************
C
      ISTEPN='4'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IARG4F=IFOUNZ(4)
      IARG4T=ITYPE(4)
      IARG4I=INT1(4)
      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,4001)ICASEL,ICASER,ICASEQ,
     1IARG4F,IARG4T
 4001 FORMAT('***** IN DPFUEV, AT START OF STEP 4; ',
     1'ICASEL,ICASER,ICASEQ,IARG4F,IARG4T = ',
     1A4,1X,A4,1X,A4,1X,A4,1X,A4)
      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
      IF(ICASEQ.EQ.'FULL')GOTO4100
      IF(ICASEQ.EQ.'SUBS')GOTO4200
      IF(ICASEQ.EQ.'FOR')GOTO4300
      IF(ICASEQ.EQ.'IF')GOTO4100
C
 4100 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO4119
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4111)
 4111 FORMAT('***** IN MIDDLE OF DPFUEV, AT 4100--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4112)ICASEL,ICASER,IHOL(4),IHOL2(4)
 4112 FORMAT('ICASEL,ICASER,IHOL(4),IHOL2(4) = ',
     1A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4113)IARG4F,IARG4T,IARG4I
 4113 FORMAT('IARG4F,IARG4T,IARG4I = ',A4,2X,A4,I8)
      CALL DPWRST('XXX','BUG ')
 4119 CONTINUE
C
      IF(ICASEL.EQ.'PARA'.AND.IARG4F.EQ.'NO'.AND.ICASER.EQ.'PARA')
     1GOTO5000
      IF(ICASEL.EQ.'PARA'.AND.IARG4F.EQ.'NO'.AND.ICASER.EQ.'ELEM')
     1GOTO5000
      IF(ICASEL.EQ.'VAR'.AND.IARG4F.EQ.'NO'.AND.ICASER.EQ.'VAR')
     1GOTO7000
C
      IF(ICASEL.EQ.'VAR'.AND.IARG4F.EQ.'YES'.AND.IHOL(4).EQ.'I   '.AND.
     1IHOL2(4).EQ.'    ')GOTO6000
      IF(ICASEL.EQ.'VAR'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD'.AND.
     1IARG4I.LE.0)GOTO7000
      IF(ICASEL.EQ.'VAR'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD'.AND.
     1IARG4I.GE.1)GOTO6000
      IF(ICASEL.EQ.'VAR'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'NUMB'
     1.AND.ICASER.EQ.'PARA')GOTO6000
      IF(ICASEL.EQ.'VAR'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'NUMB'
     1.AND.ICASER.EQ.'ELEM')GOTO6000
C
      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'NO'.AND.ICASER.EQ.'PARA')
     1GOTO5000
      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'NO'.AND.ICASER.EQ.'ELEM')
     1GOTO5000
      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'NO'.AND.ICASER.EQ.'VAR')
     1GOTO7000
C
      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD'
     1.AND.IARG4I.LE.0.AND.ICASER.EQ.'VAR')GOTO7000
      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD'
     1.AND.IARG4I.GE.1.AND.ICASER.EQ.'VAR')GOTO6000
      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD'
     1.AND.IARG4I.GE.1.AND.ICASER.EQ.'PARA')GOTO6000
CCCCC THE FOLLOWING 2 LINES WERE INSERTED TO SOLVE    (DECEMBER 1988)
CCCCC THE PROBLEM OF AN ERROR MESSAGE AND NO-ACTION    (DECEMBER 1988)
CCCCC FROM (E.G.,) LET Y(K) = X(K) INSIDE A LOOP   (DECEMBER 1988)
      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD'
     1.AND.IARG4I.GE.1.AND.ICASER.EQ.'ELEM')GOTO6000
      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'NUMB'
     1.AND.ICASER.EQ.'PARA')GOTO6000
      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'NUMB'
     1.AND.ICASER.EQ.'ELEM')GOTO6000
      GOTO4800
C
 4200 CONTINUE
      IF(ICASEL.EQ.'VAR'.AND.IARG4F.EQ.'NO')
     1GOTO8000
      IF(ICASEL.EQ.'VAR'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD')
     1GOTO8000
      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'NO')
     1GOTO8000
      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD')
     1GOTO8000
      GOTO4800
C
 4300 CONTINUE
      IF(ICASEL.EQ.'VAR'.AND.IARG4F.EQ.'NO')
     1GOTO9000
      IF(ICASEL.EQ.'VAR'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD')
     1GOTO9000
      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'NO')
     1GOTO9000
      IF(ICASEL.EQ.'UNKN'.AND.IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD')
     1GOTO9000
      GOTO4800
C
 4800 CONTINUE
      WRITE(ICOUT,4811)
 4811 FORMAT('***** ERROR IN DPFUEV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4812)
 4812 FORMAT('      ILLEGAL SYNTAX FOR LET COMMAND')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4814)
 4814 FORMAT('      POSSIBLE CAUSE--UNDEFINED PARAMETER/VARIABLE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4815)
 4815 FORMAT('      ON RIGHT-HAND SIDE OF EQUAL SIGN.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4816)ICASEL,ICASER,ICASEQ
 4816 FORMAT(6X,'ICASEL, ICASER, ICASEQ = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4818)
 4818 FORMAT('      THE COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4819)(IANS(I),I=1,IWIDTH)
 4819 FORMAT(80A1)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO19000
C
C               *****************************************************
C               **  STEP 5--                                       **
C               **  TREAT THE PARAMETER CASE.                      **
C               **  EXAMPLES--                                     **
C               **            LET A    = X(2)                      **
C               **            LET A    = 3*SIN(4)                  **
C               **            LET A    = B*SIN(B)                  **
C               **            LET U    = X(2)                      **
C               **            LET U    = 3*SIN(4)                  **
C               **            LET U    = B*SIN(B)                  **
C               **  WHERE A WAS A PREVIOUSLY-DEFINED PARAMETER     **
C               **  AND WHERE U WAS PREVIOUSLY UNDEFINED.          **
C               **  CARRY OUT THE LIST UPDATING  AND               **
C               **  GENERATE THE INFORMATIVE PRINTING.             **
C               **  THEN EXIT.                                     **
C               *****************************************************
C
 5000 CONTINUE
      ISTEPN='5'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ICASEQ.EQ.'IF')GOTO5050
      GOTO5090
 5050 CONTINUE
      ICASIF='TRUE'
      IHSET=IHOL(12)
      IHSET2=IHOL2(12)
      IHWUSE='P'
      MESSAG='YES'
      CALL CHECKN(IHSET,IHSET2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
      IF(IERROR.EQ.'YES')GOTO19000
C
      NISET=IN(ILOC)
      CALL DPIF(ILOCS,ICASIF,IBUGQ,IERROR)
 5090 CONTINUE
C
      IF(ICASER.EQ.'ELEM')GOTO5200
      IF(ICASER.EQ.'PARA')GOTO5300
C
 5100 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5101)
 5101 FORMAT('***** INTERNAL ERROR IN DPFUEV')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5102)
 5102 FORMAT('      AT BRANCH POINT 5101--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5103)ICASER
 5103 FORMAT('      ICASER = ',A4,' DETECTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5104)
 5104 FORMAT('      IN STEP 5 (PARAMETER CALCULATION).')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5106)
 5106 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,5107)(IANS(I),I=1,IWIDTH)
 5107 FORMAT(80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO19000
C
 5200 CONTINUE
      IF(ICASEQ.EQ.'IF'.AND.ICASIF.EQ.'FALS')GOTO5119
      IARG9I=INT1(9)
      IJ=MAXN*(ICOLR-1)+IARG9I
      IF(ICOLR.LE.MAXCOL)RIGHT=V(IJ)
      IF(ICOLR.EQ.MAXCP1)RIGHT=PRED(IARG9I)
      IF(ICOLR.EQ.MAXCP2)RIGHT=RES(IARG9I)
      IF(ICOLR.EQ.MAXCP3)RIGHT=YPLOT(IARG9I)
      IF(ICOLR.EQ.MAXCP4)RIGHT=XPLOT(IARG9I)
      IF(ICOLR.EQ.MAXCP5)RIGHT=X2PLOT(IARG9I)
      IF(ICOLR.EQ.MAXCP6)RIGHT=TAGPLO(IARG9I)
      GOTO5500
C
 5300 CONTINUE
      IF(ICASEQ.EQ.'IF'.AND.ICASIF.EQ.'FALS')GOTO5119
      IF(NUMPAR.LE.0)GOTO5490
      DO5400J=1,NUMPAR
      IPJ=IPARN(J)
      IPJ2=IPARN2(J)
      DO5450I=1,NUMNAM
      I2=I
      IF(IPJ.EQ.IHNAME(I).AND.IPJ2.EQ.IHNAM2(I).AND.
     1IUSE(I).EQ.'P')GOTO5460
 5450 CONTINUE
      GOTO5480
 5460 CONTINUE
      PARAM(J)=VALUE(I2)
 5400 CONTINUE
      GOTO5490
C
 5480 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5481)
 5481 FORMAT('***** INTERNAL ERROR IN DPFUEV')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5482)
 5482 FORMAT('      AT BRANCH POINT 5481--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5483)
 5483 FORMAT('      PARAMETER NAME FOR FUNCTION EVALUATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5484)
 5484 FORMAT('      NOT FOUND IN INTERNAL LIST.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5485)IPJ,IPJ2
 5485 FORMAT('      PARAMETER NAME = ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5486)
 5486 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,5487)(IANS(I),I=1,IWIDTH)
 5487 FORMAT(80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO19000
C
 5490 CONTINUE
      IPASS=2
      CALL COMPIM(IA,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPAR,
     1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,RIGHT,
     1IBUGCO,IBUGEV,IERROR)
      IF(IERROR.EQ.'YES')GOTO19000
      GOTO5500
C
 5500 CONTINUE
      IFOUND='YES'
      IHNAME(ILISTL)=ILEFT
      IHNAM2(ILISTL)=ILEFT2
      IUSE(ILISTL)='P'
      VALUE(ILISTL)=RIGHT
CCCCC IVALUE(ILISTL)=VALUE(ILISTL)+0.5
C
CCCCC MARCH 2002.  CHANGE CODE BELOW.  BASE ON LARGEST INTEGER AS
CCCCC GIVEN IN DPCOMC.
CCCCC CUTOFF=2**(NUMBPW-3)
C3/02 ICUTMX=NUMBPW
C3/02 IF(IHOST1.EQ.'CDC '.OR.IHOST1.EQ.'CYBE')ICUTMX=48
CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1989
C3/02 IF(IHOST1.EQ.'205 ')ICUTMX=48
C3/02 CUTOFF=2**(ICUTMX-3)
      CUTOFF=REAL(I1MACH(9)-1)
C
      IF((-CUTOFF).LE.RIGHT.AND.RIGHT.LE.CUTOFF)THEN
        IVALUE(ILISTL)=RIGHT+0.5
      ELSEIF(RIGHT.GT.CUTOFF)THEN
        IVALUE(ILISTL)=I1MACH(9)-1
      ELSEIF(RIGHT.LT.(-CUTOFF))THEN
        IVALUE(ILISTL)=-(I1MACH(9)-1)
      ELSE
        IVALUE(ILISTL)=0
      ENDIF
      IN(ILISTL)=1
C
      IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
C
      IF(IPRINT.EQ.'OFF')GOTO5119
      IF(IFEEDB.EQ.'OFF')GOTO5119
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5111)ILEFT,ILEFT2,RIGHT
 5111 FORMAT('THE COMPUTED VALUE OF THE CONSTANT ',
     1A4,A4,' = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
 5119 CONTINUE
      GOTO19000
C
C               *****************************************************
C               **  STEP 6--                                       **
C               **  TREAT THE ELEMENT SPECIFICATION CASE.          **
C               **  EXAMPLES--                                     **
C               **            LET Y(2) = X(2)                      **
C               **            LET Y(2) = 3*SIN(4)                  **
C               **            LET Y(2) = B*SIN(B)                  **
C               **            LET U(2) = X(2)                      **
C               **            LET U(2) = 3*SIN(4)                  **
C               **            LET U(2) = B*SIN(B)                  **
C               **  WHERE Y WAS A PREVIOUSLY-DEFINED VARIABLE      **
C               **  AND WHERE U WAS PREVIOUSLY UNDEFINED.          **
C               **  CARRY OUT THE LIST UPDATING  AND               **
C               **  GENERATE THE INFORMATIVE PRINTING.             **
C               **  THEN EXIT.                                     **
C               *****************************************************
C
 6000 CONTINUE
      ISTEPN='6'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IARG4I=INT1(4)
C
      IF(1.LE.IARG4I.AND.IARG4I.LE.MAXN)GOTO6050
      WRITE(ICOUT,6061)
 6061 FORMAT('***** ERROR IN DPFUEV')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6062)IARG4I,ILEFT,ILEFT2
 6062 FORMAT('      THE SPECIFIED ROW (',I8,') OF VARIABLE ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6063)
 6063 FORMAT('      ON THE LEFT SIDE OF THE EQUAL SIGN')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6064)
 6064 FORMAT('      WAS LESS THAN 1 OR')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6065)MAXN
 6065 FORMAT('      GREATER THAN THE MAX ALLOWABLE ',I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO19000
C
 6050 CONTINUE
      IF(ICASEL.EQ.'VAR')ICOLL=IVALUE(ILISTL)
      IF(ICASEL.EQ.'UNKN')ICOLL=NUMCOL+1
      IF(ICOLL.LE.MAXCOL)GOTO6090
      WRITE(ICOUT,6051)
 6051 FORMAT('***** ERROR IN DPFUEV AT 6051--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6052)
 6052 FORMAT('      THE NUMBER OF DATA COLUMNS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6053)MAXCOL
 6053 FORMAT('      HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,'  .')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6054)
 6054 FORMAT('      SUGGESTED ACTION--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6055)
 6055 FORMAT('      ENTER      STAT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6056)
 6056 FORMAT('      TO FIND OUT THE FULL LIST OF USED COLUMNS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6057)
 6057 FORMAT('      AND THEN OVERWRITE SOME COLUMN.   ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6058)
 6058 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,6059)(IANS(I),I=1,IWIDTH)
 6059 FORMAT(80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO19000
C
 6090 CONTINUE
      IF(ICASEL.EQ.'VAR'.AND.IARG4I.LE.NILEFT)NINEW=NILEFT
      IF(ICASEL.EQ.'VAR'.AND.IARG4I.GT.NILEFT)NINEW=IARG4I
      IF(ICASEL.EQ.'UNKN')NINEW=IARG4I
C
      IF(ICASER.EQ.'ELEM')GOTO6200
      IF(ICASER.EQ.'PARA')GOTO6300
C
 6100 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6101)
 6101 FORMAT('***** INTERNAL ERROR IN DPFUEV')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6102)
 6102 FORMAT('      AT BRANCH POINT 6101--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6103)ICASER
 6103 FORMAT('      ICASER = ',A4,' DETECTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6104)
 6104 FORMAT('      IN STEP 6 (ELEMENT CALCULATION).')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6106)
 6106 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,6107)(IANS(I),I=1,IWIDTH)
 6107 FORMAT(80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO19000
C
 6200 CONTINUE
      IARG9I=INT1(9)
      IJ=MAXN*(ICOLR-1)+IARG9I
      IF(ICOLR.LE.MAXCOL)RIGHT=V(IJ)
      IF(ICOLR.EQ.MAXCP1)RIGHT=PRED(IARG9I)
      IF(ICOLR.EQ.MAXCP2)RIGHT=RES(IARG9I)
      IF(ICOLR.EQ.MAXCP3)RIGHT=YPLOT(IARG9I)
      IF(ICOLR.EQ.MAXCP4)RIGHT=XPLOT(IARG9I)
      IF(ICOLR.EQ.MAXCP5)RIGHT=X2PLOT(IARG9I)
      IF(ICOLR.EQ.MAXCP6)RIGHT=TAGPLO(IARG9I)
      IJ=MAXN*(ICOLL-1)+IARG4I
      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
      IF(ICOLL.EQ.MAXCP1)PRED(IARG4I)=RIGHT
      IF(ICOLL.EQ.MAXCP2)RES(IARG4I)=RIGHT
      IF(ICOLL.EQ.MAXCP3)YPLOT(IARG4I)=RIGHT
      IF(ICOLL.EQ.MAXCP4)XPLOT(IARG4I)=RIGHT
      IF(ICOLL.EQ.MAXCP5)X2PLOT(IARG4I)=RIGHT
      IF(ICOLL.EQ.MAXCP6)TAGPLO(IARG4I)=RIGHT
      GOTO6500
C
 6300 CONTINUE
      IF(NUMPAR.LE.0)GOTO6490
      DO6400J=1,NUMPAR
      IPJ=IPARN(J)
      IPJ2=IPARN2(J)
      DO6450I=1,NUMNAM
      I2=I
      IF(IPJ.EQ.IHNAME(I).AND.IPJ2.EQ.IHNAM2(I).AND.
     1IUSE(I).EQ.'P')GOTO6460
 6450 CONTINUE
      GOTO6480
 6460 CONTINUE
      PARAM(J)=VALUE(I2)
 6400 CONTINUE
      GOTO6490
C
 6480 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6481)
 6481 FORMAT('***** INTERNAL ERROR IN DPFUEV')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6482)
 6482 FORMAT('      AT BRANCH POINT 6481--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6483)
 6483 FORMAT('      PARAMETER NAME FOR FUNCTION EVALUATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6484)
 6484 FORMAT('      NOT FOUND IN INTERNAL LIST.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6485)IPJ,IPJ2
 6485 FORMAT('      PARAMETER NAME = ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6486)
 6486 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,6487)(IANS(I),I=1,IWIDTH)
 6487 FORMAT(80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO19000
C
 6490 CONTINUE
      IPASS=2
      CALL COMPIM(IA,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPAR,
     1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,RIGHT,
     1IBUGCO,IBUGEV,IERROR)
      IF(IERROR.EQ.'YES')GOTO19000
      IJ=MAXN*(ICOLL-1)+IARG4I
      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
      IF(ICOLL.EQ.MAXCP1)PRED(IARG4I)=RIGHT
      IF(ICOLL.EQ.MAXCP2)RES(IARG4I)=RIGHT
      IF(ICOLL.EQ.MAXCP3)YPLOT(IARG4I)=RIGHT
      IF(ICOLL.EQ.MAXCP4)XPLOT(IARG4I)=RIGHT
      IF(ICOLL.EQ.MAXCP5)X2PLOT(IARG4I)=RIGHT
      IF(ICOLL.EQ.MAXCP6)TAGPLO(IARG4I)=RIGHT
      GOTO6500
C
 6500 CONTINUE
      IFOUND='YES'
      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
      DO6600J4=1,NUMNAM
      IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)GOTO6605
      GOTO6600
 6605 CONTINUE
      IUSE(J4)='V'
      IVALUE(J4)=ICOLL
      VALUE(J4)=ICOLL
      IN(J4)=NINEW
 6600 CONTINUE
C
      IF(IPRINT.EQ.'OFF')GOTO6119
      IF(IFEEDB.EQ.'OFF')GOTO6119
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6111)ILEFT,ILEFT2,IARG4I,RIGHT
 6111 FORMAT('THE COMPUTED VALUE OF ',
     1A4,A4,'(',I6,') = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6112)ILEFT,ILEFT2,ICOLL
 6112 FORMAT('THE CURRENT COLUMN FOR ',
     1'THE VARIABLE ',A4,A4,' = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6113)ILEFT,ILEFT2,NINEW
 6113 FORMAT('THE CURRENT LENGTH OF  ',
     1'THE VARIABLE ',A4,A4,' = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
 6119 CONTINUE
      GOTO19000
C
C               *****************************************************
C               **  STEP 7--                                       **
C               **  TREAT THE FULL VARIABLE CASE.                  **
C               **  EXAMPLES--                                     **
C               **            LET Y    = X*SIN(X)                  **
C               **            LET Y(I) = I                         **
C               **            LET Y(I) = X(2)                      **
C               **            LET Y(I) = 3*SIN(4)                  **
C               **            LET Y(I) = B*SIN(B)                  **
C               **            LET Y(I) = X*SIN(X)                  **
C               **            LET U    = X*SIN(X)                  **
C               **            LET U(I) = X*SIN(X)                  **
C               **  WHERE Y WAS A PREVIOUSLY-DEFINED VARIABLE      **
C               **  AND WHERE U WAS PREVIOUSLY UNDEFINED.          **
C               **  THEN JUMP TO STEP NUMBER 10 BELOW              **
C               **  FOR THE THE LIST UPDATING AND                  **
C               **  GENERATE THE INFORMATIVE PRINTING.             **
C               **  THEN EXIT.                                     **
C               *****************************************************
C
 7000 CONTINUE
      ISTEPN='7'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ICASEL.EQ.'VAR')ICOLL=IVALUE(ILISTL)
      IF(ICASEL.EQ.'UNKN')ICOLL=NUMCOL+1
CCCCC IF(ILEFT.EQ.'PRED'.AND.ILEFT2.EQ.'    ')GOTO7090  MARCH 1988
CCCCC IF(ILEFT.EQ.'RES '.AND.ILEFT2.EQ.'    ')GOTO7090  MARCH 1988
      IF(ICOLL.LE.MAXCOL)GOTO7090
CCCCC THE FOLLOWING LINE WAS INSERTED MARCH 1988
CCCCC TO FIX THE PROBLEM OF LET PRED = ... SUBSET ...
CCCCC YIELDING A "TOO MANY VARIABLES" MESSAGE
      IF(ICASEL.EQ.'VAR')GOTO7090
      WRITE(ICOUT,7051)
 7051 FORMAT('***** ERROR IN DPFUEV AT 7051--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,7052)ICOLL
 7052 FORMAT('      THE NUMBER OF DATA COLUMNS (',I8,')')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,7053)MAXCOL
 7053 FORMAT('      HAS JUST EXCEEDED THE MAX ALLOWABLE (',I8,').')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,7054)
 7054 FORMAT('      SUGGESTED ACTION--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,7055)
 7055 FORMAT('      ENTER      STAT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,7056)
 7056 FORMAT('      TO FIND OUT THE FULL LIST OF USED COLUMNS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,7057)
 7057 FORMAT('      AND THEN OVERWRITE SOME COLUMN.   ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,7058)
 7058 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,7059)(IANS(I),I=1,IWIDTH)
 7059 FORMAT(80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO19000
C
 7090 CONTINUE
      NINEW=NILEFT
      IF(ICASER.EQ.'VAR')NINEW=NIRIGH
C
      IF(ICASER.EQ.'DUMM')GOTO7100
      IF(ICASER.EQ.'ELEM')GOTO7200
      IF(ICASER.EQ.'PARA')GOTO7300
      IF(ICASER.EQ.'VAR')GOTO7300
C
 7100 CONTINUE
      NS2=0
      DO7150I=1,NINEW
      NS2=NS2+1
      RIGHT=I
      IJ=MAXN*(ICOLL-1)+I
      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
      IF(ICOLL.EQ.MAXCP1)PRED(I)=RIGHT
      IF(ICOLL.EQ.MAXCP2)RES(I)=RIGHT
      IF(ICOLL.EQ.MAXCP3)YPLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP4)XPLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=RIGHT
      IF(NS2.EQ.1)IROW1=I
      IROWN=I
 7150 CONTINUE
      GOTO10000
C
 7200 CONTINUE
      IARG9I=INT1(9)
      IJ=MAXN*(ICOLR-1)+IARG9I
      IF(ICOLR.LE.MAXCOL)RIGHT=V(IJ)
      IF(ICOLR.EQ.MAXCP1)RIGHT=PRED(IARG9I)
      IF(ICOLR.EQ.MAXCP2)RIGHT=RES(IARG9I)
      IF(ICOLR.EQ.MAXCP3)RIGHT=YPLOT(IARG9I)
      IF(ICOLR.EQ.MAXCP4)RIGHT=XPLOT(IARG9I)
      IF(ICOLR.EQ.MAXCP5)RIGHT=X2PLOT(IARG9I)
      IF(ICOLR.EQ.MAXCP6)RIGHT=TAGPLO(IARG9I)
      NS2=0
      DO7250I=1,NINEW
      NS2=NS2+1
      IJ=MAXN*(ICOLL-1)+I
      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
      IF(ICOLL.EQ.MAXCP1)PRED(I)=RIGHT
      IF(ICOLL.EQ.MAXCP2)RES(I)=RIGHT
      IF(ICOLL.EQ.MAXCP3)YPLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP4)XPLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=RIGHT
      IF(NS2.EQ.1)IROW1=I
      IROWN=I
 7250 CONTINUE
      GOTO10000
C
 7300 CONTINUE
      IPASS=2
      NS2=0
      DO7350I=1,NINEW
      NS2=NS2+1
C
      IF(NUMPAR.LE.0)GOTO7390
      DO7355J=1,NUMPAR
      IPJ=IPARN(J)
      IPJ2=IPARN2(J)
      DO7356K=1,NUMNAM
      K2=K
      IF(IPJ.EQ.IHNAME(K).AND.IPJ2.EQ.IHNAM2(K).AND.
     1IUSE(K).EQ.'P')GOTO7360
      IF(IPJ.EQ.IHNAME(K).AND.IPJ2.EQ.IHNAM2(K).AND.
     1IUSE(K).EQ.'V')GOTO7370
 7356 CONTINUE
      GOTO7380
C
 7360 CONTINUE
      PARAM(J)=VALUE(K2)
      GOTO7355
C
 7370 CONTINUE
      ICOLK2=IVALUE(K2)
      IJ=MAXN*(ICOLK2-1)+I
      IF(ICOLK2.LE.MAXCOL)PARAM(J)=V(IJ)
      IF(ICOLK2.EQ.MAXCP1)PARAM(J)=PRED(I)
      IF(ICOLK2.EQ.MAXCP2)PARAM(J)=RES(I)
      IF(ICOLK2.EQ.MAXCP3)PARAM(J)=YPLOT(I)
      IF(ICOLK2.EQ.MAXCP4)PARAM(J)=XPLOT(I)
      IF(ICOLK2.EQ.MAXCP5)PARAM(J)=X2PLOT(I)
      IF(ICOLK2.EQ.MAXCP6)PARAM(J)=TAGPLO(I)
 7355 CONTINUE
      GOTO7390
C
 7380 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,7381)
 7381 FORMAT('***** INTERNAL ERROR IN DPFUEV')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,7382)
 7382 FORMAT('      AT BRANCH POINT 7381--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,7383)
 7383 FORMAT('      PARAMETER/VARIABLE NAME FOR FUNCTION ',
     1'EVALUATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,7384)
 7384 FORMAT('      NOT FOUND IN INTERNAL LIST.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,7385)IPJ,IPJ2
 7385 FORMAT('      PARAMETER/VARIABLE NAME = ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,7386)
 7386 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,7387)(IANS(I3),I3=1,IWIDTH)
 7387 FORMAT(80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO19000
C
 7390 CONTINUE
      CALL COMPIM(IA,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPAR,
     1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,RIGHT,
     1IBUGCO,IBUGEV,IERROR)
      IF(IERROR.EQ.'YES')GOTO19000
      IJ=MAXN*(ICOLL-1)+I
      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
      IF(ICOLL.EQ.MAXCP1)PRED(I)=RIGHT
      IF(ICOLL.EQ.MAXCP2)RES(I)=RIGHT
      IF(ICOLL.EQ.MAXCP3)YPLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP4)XPLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=RIGHT
      IF(NS2.EQ.1)IROW1=I
      IROWN=I
 7350 CONTINUE
      GOTO10000
C
C               *****************************************************
C               **  STEP 8--                                       **
C               **  TREAT THE PARTIAL VARIABLE SUBSET CASE.        **
C               **  EXAMPLES--                                     **
C               **            LET Y    = I         SUBSET 2 3 5    **
C               **            LET Y    = X(2)      SUBSET 2 3 5    **
C               **            LET Y    = 3*SIN(4)  SUBSET 2 3 5    **
C               **            LET Y    = B*SIN(B)  SUBSET 2 3 5    **
C               **            LET Y    = X*SIN(X)  SUBSET 2 3 5    **
C               **            LET Y(I) = I         SUBSET 2 3 5    **
C               **            LET Y(I) = X(2)      SUBSET 2 3 5    **
C               **            LET Y(I) = 3*SIN(4)  SUBSET 2 3 5    **
C               **            LET Y(I) = B*SIN(B)  SUBSET 2 3 5    **
C               **            LET Y(I) = X*SIN(X)  SUBSET 2 3 5    **
C               **            LET U    = I         SUBSET 2 3 5    **
C               **            LET U    = X(2)      SUBSET 2 3 5    **
C               **            LET U    = 3*SIN(4)  SUBSET 2 3 5    **
C               **            LET U    = B*SIN(B)  SUBSET 2 3 5    **
C               **            LET U    = X*SIN(X)  SUBSET 2 3 5    **
C               **            LET U(I) = I         SUBSET 2 3 5    **
C               **            LET U(I) = X(2)      SUBSET 2 3 5    **
C               **            LET U(I) = 3*SIN(4)  SUBSET 2 3 5    **
C               **            LET U(I) = B*SIN(B)  SUBSET 2 3 5    **
C               **            LET U(I) = X*SIN(X)  SUBSET 2 3 5    **
C               **  WHERE Y WAS A PREVIOUSLY-DEFINED VARIABLE      **
C               **  AND WHERE U WAS PREVIOUSLY UNDEFINED.          **
C               **  THEN JUMP TO STEP NUMBER 10 BELOW              **
C               **  FOR THE THE LIST UPDATING  AND                 **
C               **  GENERATE THE INFORMATIVE PRINTING.             **
C               **  THEN EXIT.                                     **
C               *****************************************************
C
 8000 CONTINUE
      ISTEPN='8'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ICASEL.EQ.'VAR')ICOLL=IVALUE(ILISTL)
      IF(ICASEL.EQ.'UNKN')ICOLL=NUMCOL+1
      IF(ICOLL.LE.MAXCOL)GOTO8090
CCCCC THE FOLLOWING LINE WAS INSERTED MARCH 1988
CCCCC TO FIX THE PROBLEM OF LET PRED = ... SUBSET ...
CCCCC YIELDING A "TOO MANY VARIABLES" MESSAGE
      IF(ICASEL.EQ.'VAR')GOTO8090
      WRITE(ICOUT,8051)
 8051 FORMAT('***** ERROR IN DPFUEV AT 8051--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8052)
 8052 FORMAT('      THE NUMBER OF DATA COLUMNS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8053)MAXCOL
 8053 FORMAT('      HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,'  .')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8054)
 8054 FORMAT('      SUGGESTED ACTION--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8055)
 8055 FORMAT('      ENTER      STAT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8056)
 8056 FORMAT('      TO FIND OUT THE FULL LIST OF USED COLUMNS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8057)
 8057 FORMAT('      AND THEN OVERWRITE SOME COLUMN.   ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8058)
 8058 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,8059)(IANS(I),I=1,IWIDTH)
 8059 FORMAT(80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO19000
C
 8090 CONTINUE
      IHSET=IHOL(12)
      IHSET2=IHOL2(12)
      IHWUSE='V'
      MESSAG='YES'
      CALL CHECKN(IHSET,IHSET2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
      IF(IERROR.EQ.'YES')GOTO19000
C
      NISET=IN(ILOC)
      CALL DPSUBS(NISET,ILOCS,NS,IBUGQ,IERROR)
C
      NINEW=NISET
      IF(ICASER.EQ.'VAR')NINEW=NIRIGH
C
      IF(ICASER.EQ.'DUMM')GOTO8100
      IF(ICASER.EQ.'ELEM')GOTO8200
      IF(ICASER.EQ.'PARA')GOTO8300
      IF(ICASER.EQ.'VAR')GOTO8300
C
 8100 CONTINUE
      NS2=0
      DO8150I=1,NISET
      IF(ISUB(I).EQ.0)GOTO8150
      NS2=NS2+1
      RIGHT=I
      IJ=MAXN*(ICOLL-1)+I
      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
      IF(ICOLL.EQ.MAXCP1)PRED(I)=RIGHT
      IF(ICOLL.EQ.MAXCP2)RES(I)=RIGHT
      IF(ICOLL.EQ.MAXCP3)YPLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP4)XPLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=RIGHT
      IF(NS2.EQ.1)IROW1=I
      IROWN=I
 8150 CONTINUE
      GOTO10000
C
 8200 CONTINUE
      IARG9I=INT1(9)
      IJ=MAXN*(ICOLR-1)+IARG9I
C ???????????
      IF(ICOLR.LE.MAXCOL)RIGHT=V(IJ)
      IF(ICOLR.EQ.MAXCP1)RIGHT=PRED(IARG9I)
      IF(ICOLR.EQ.MAXCP2)RIGHT=RES(IARG9I)
      IF(ICOLR.EQ.MAXCP3)RIGHT=YPLOT(IARG9I)
      IF(ICOLR.EQ.MAXCP4)RIGHT=XPLOT(IARG9I)
      IF(ICOLR.EQ.MAXCP5)RIGHT=X2PLOT(IARG9I)
      IF(ICOLR.EQ.MAXCP6)RIGHT=TAGPLO(IARG9I)
      NS2=0
      DO8250I=1,NISET
      IF(ISUB(I).EQ.0)GOTO8250
      NS2=NS2+1
      IJ=MAXN*(ICOLL-1)+I
      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
      IF(ICOLL.EQ.MAXCP1)PRED(I)=RIGHT
      IF(ICOLL.EQ.MAXCP2)RES(I)=RIGHT
      IF(ICOLL.EQ.MAXCP3)YPLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP4)XPLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=RIGHT
      IF(NS2.EQ.1)IROW1=I
      IROWN=I
 8250 CONTINUE
      GOTO10000
C
 8300 CONTINUE
      IPASS=2
      IMAX=NISET
      IF(NINEW.LT.IMAX)IMAX=NINEW
      NS2=0
      DO8350I=1,IMAX
      IF(ISUB(I).EQ.0)GOTO8350
      NS2=NS2+1
C
      IF(NUMPAR.LE.0)GOTO8390
      DO8355J=1,NUMPAR
      IPJ=IPARN(J)
      IPJ2=IPARN2(J)
      DO8356K=1,NUMNAM
      K2=K
      IF(IPJ.EQ.IHNAME(K).AND.IPJ2.EQ.IHNAM2(K).AND.
     1IUSE(K).EQ.'P')GOTO8360
      IF(IPJ.EQ.IHNAME(K).AND.IPJ2.EQ.IHNAM2(K).AND.
     1IUSE(K).EQ.'V')GOTO8370
 8356 CONTINUE
      GOTO8380
C
 8360 CONTINUE
      PARAM(J)=VALUE(K2)
      GOTO8355
C
 8370 CONTINUE
      ICOLK2=IVALUE(K2)
      IJ=MAXN*(ICOLK2-1)+I
      IF(ICOLK2.LE.MAXCOL)PARAM(J)=V(IJ)
      IF(ICOLK2.EQ.MAXCP1)PARAM(J)=PRED(I)
      IF(ICOLK2.EQ.MAXCP2)PARAM(J)=RES(I)
      IF(ICOLK2.EQ.MAXCP3)PARAM(J)=YPLOT(I)
      IF(ICOLK2.EQ.MAXCP4)PARAM(J)=XPLOT(I)
      IF(ICOLK2.EQ.MAXCP5)PARAM(J)=X2PLOT(I)
      IF(ICOLK2.EQ.MAXCP6)PARAM(J)=TAGPLO(I)
 8355 CONTINUE
      GOTO8390
C
 8380 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8381)
 8381 FORMAT('***** INTERNAL ERROR IN DPFUEV')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8382)
 8382 FORMAT('      AT BRANCH POINT 8381--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8383)
 8383 FORMAT('      PARAMETER/VARIABLE NAME FOR FUNCTION ',
     1'EVALUATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8384)
 8384 FORMAT('      NOT FOUND IN INTERNAL LIST.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8385)IPJ,IPJ2
 8385 FORMAT('      PARAMETER/VARIABLE NAME = ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8386)
 8386 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,8387)(IANS(I3),I3=1,IWIDTH)
 8387 FORMAT(80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO19000
C
 8390 CONTINUE
      CALL COMPIM(IA,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPAR,
     1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,RIGHT,
     1IBUGCO,IBUGEV,IERROR)
      IF(IERROR.EQ.'YES')GOTO19000
      IJ=MAXN*(ICOLL-1)+I
      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
      IF(ICOLL.EQ.MAXCP1)PRED(I)=RIGHT
      IF(ICOLL.EQ.MAXCP2)RES(I)=RIGHT
      IF(ICOLL.EQ.MAXCP3)YPLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP4)XPLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=RIGHT
      IF(NS2.EQ.1)IROW1=I
      IROWN=I
 8350 CONTINUE
      GOTO10000
C
C               *****************************************************
C               **  STEP 9--                                       **
C               **  TREAT THE PARTIAL VARIABLE FOR CASE.           **
C               **  EXAMPLES--                                     **
C               **            LET Y    = I         FOR I = 1 2 10  **
C               **            LET Y    = X(2)      FOR I = 1 2 10  **
C               **            LET Y    = 3*SIN(4)  FOR I = 1 2 10  **
C               **            LET Y    = B*SIN(B)  FOR I = 1 2 10  **
C               **            LET Y    = X*SIN(X)  FOR I = 1 2 10  **
C               **            LET Y(I) = I         FOR I = 1 2 10  **
C               **            LET Y(I) = X(2)      FOR I = 1 2 10  **
C               **            LET Y(I) = 3*SIN(4)  FOR I = 1 2 10  **
C               **            LET Y(I) = B*SIN(B)  FOR I = 1 2 10  **
C               **            LET Y(I) = X*SIN(X)  FOR I = 1 2 10  **
C               **            LET U    = I         FOR I = 1 2 10  **
C               **            LET U    = X(2)      FOR I = 1 2 10  **
C               **            LET U    = 3*SIN(4)  FOR I = 1 2 10  **
C               **            LET U    = B*SIN(B)  FOR I = 1 2 10  **
C               **            LET U    = X*SIN(X)  FOR I = 1 2 10  **
C               **            LET U(I) = I         FOR I = 1 2 10  **
C               **            LET U(I) = X(2)      FOR I = 1 2 10  **
C               **            LET U(I) = 3*SIN(4)  FOR I = 1 2 10  **
C               **            LET U(I) = B*SIN(B)  FOR I = 1 2 10  **
C               **            LET U(I) = X*SIN(X)  FOR I = 1 2 10  **
C               **  WHERE Y WAS A PREVIOUSLY-DEFINED VARIABLE      **
C               **  AND WHERE U WAS PREVIOUSLY UNDEFINED.          **
C               **  THEN JUMP TO STEP NUMBER 10 BELOW              **
C               **  FOR THE THE LIST UPDATING  AND                 **
C               **  GENERATE THE INFORMATIVE PRINTING.             **
C               **  THEN EXIT.                                     **
C               *****************************************************
C
 9000 CONTINUE
      ISTEPN='9'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ICASEL.EQ.'VAR')ICOLL=IVALUE(ILISTL)
      IF(ICASEL.EQ.'UNKN')ICOLL=NUMCOL+1
      IF(ICOLL.LE.MAXCOL)GOTO9090
CCCCC THE FOLLOWING LINE WAS INSERTED MARCH 1988
CCCCC TO FIX THE PROBLEM OF LET PRED = ... SUBSET ...
CCCCC YIELDING A "TOO MANY VARIABLES" MESSAGE
      IF(ICASEL.EQ.'VAR')GOTO9090
      WRITE(ICOUT,9051)
 9051 FORMAT('***** ERROR IN DPFUEV AT 9051--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9052)
 9052 FORMAT('      THE NUMBER OF DATA COLUMNS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9053)MAXCOL
 9053 FORMAT('      HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,'  .')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9054)
 9054 FORMAT('      SUGGESTED ACTION--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9055)
 9055 FORMAT('      ENTER      STAT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9056)
 9056 FORMAT('      TO FIND OUT THE FULL LIST OF USED COLUMNS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9057)
 9057 FORMAT('      AND THEN OVERWRITE SOME COLUMN.   ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9058)
 9058 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,9059)(IANS(I),I=1,IWIDTH)
 9059 FORMAT(80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO19000
C
 9090 CONTINUE
      NIOLD=IN(ILISTL)
      CALL DPFOR(NIOLD,NIFOR,IROW1,IROWN,
     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
C
      NINEW=NIFOR
      IF(ICASER.EQ.'VAR')NINEW=NIRIGH
C
      IF(ICASER.EQ.'DUMM')GOTO9100
      IF(ICASER.EQ.'ELEM')GOTO9200
      IF(ICASER.EQ.'PARA')GOTO9300
      IF(ICASER.EQ.'VAR')GOTO9300
C
 9100 CONTINUE
      NS2=0
      DO9150I=1,NIFOR
      IF(ISUB(I).EQ.0)GOTO9150
      NS2=NS2+1
      RIGHT=I
      IJ=MAXN*(ICOLL-1)+I
      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
      IF(ICOLL.EQ.MAXCP1)PRED(I)=RIGHT
      IF(ICOLL.EQ.MAXCP2)RES(I)=RIGHT
      IF(ICOLL.EQ.MAXCP3)YPLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP4)XPLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=RIGHT
      IF(NS2.EQ.1)IROW1=I
      IROWN=I
 9150 CONTINUE
      GOTO10000
C
 9200 CONTINUE
      IARG9I=INT1(9)
      IJ=MAXN*(ICOLR-1)+IARG9I
      IF(ICOLR.LE.MAXCOL)RIGHT=V(IJ)
      IF(ICOLR.EQ.MAXCP1)RIGHT=PRED(IARG9I)
      IF(ICOLR.EQ.MAXCP2)RIGHT=RES(IARG9I)
      IF(ICOLR.EQ.MAXCP3)RIGHT=YPLOT(IARG9I)
      IF(ICOLR.EQ.MAXCP4)RIGHT=XPLOT(IARG9I)
      IF(ICOLR.EQ.MAXCP5)RIGHT=X2PLOT(IARG9I)
      IF(ICOLR.EQ.MAXCP6)RIGHT=TAGPLO(IARG9I)
      NS2=0
      DO9250I=1,NIFOR
      IF(ISUB(I).EQ.0)GOTO9250
      NS2=NS2+1
      IJ=MAXN*(ICOLL-1)+I
      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
      IF(ICOLL.EQ.MAXCP1)PRED(I)=RIGHT
      IF(ICOLL.EQ.MAXCP2)RES(I)=RIGHT
      IF(ICOLL.EQ.MAXCP3)YPLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP4)XPLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=RIGHT
      IF(NS2.EQ.1)IROW1=I
      IROWN=I
 9250 CONTINUE
      GOTO10000
C
 9300 CONTINUE
      IPASS=2
      IMAX=NIFOR
      IF(NINEW.LT.IMAX)IMAX=NINEW
      NS2=0
      DO9350I=1,IMAX
      IF(ISUB(I).EQ.0)GOTO9350
      NS2=NS2+1
C
      IF(NUMPAR.LE.0)GOTO9390
      DO9355J=1,NUMPAR
      IPJ=IPARN(J)
      IPJ2=IPARN2(J)
      DO9356K=1,NUMNAM
      K2=K
      IF(IPJ.EQ.IHNAME(K).AND.IPJ2.EQ.IHNAM2(K).AND.
     1IUSE(K).EQ.'P')GOTO9360
      IF(IPJ.EQ.IHNAME(K).AND.IPJ2.EQ.IHNAM2(K).AND.
     1IUSE(K).EQ.'V')GOTO9370
 9356 CONTINUE
      GOTO9380
C
 9360 CONTINUE
      PARAM(J)=VALUE(K2)
      GOTO9355
C
 9370 CONTINUE
      ICOLK2=IVALUE(K2)
      IJ=MAXN*(ICOLK2-1)+I
      IF(ICOLK2.LE.MAXCOL)PARAM(J)=V(IJ)
      IF(ICOLK2.EQ.MAXCP1)PARAM(J)=PRED(I)
      IF(ICOLK2.EQ.MAXCP2)PARAM(J)=RES(I)
      IF(ICOLK2.EQ.MAXCP3)PARAM(J)=YPLOT(I)
      IF(ICOLK2.EQ.MAXCP4)PARAM(J)=XPLOT(I)
      IF(ICOLK2.EQ.MAXCP5)PARAM(J)=X2PLOT(I)
      IF(ICOLK2.EQ.MAXCP6)PARAM(J)=TAGPLO(I)
 9355 CONTINUE
      GOTO9390
C
 9380 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9381)
 9381 FORMAT('***** INTERNAL ERROR IN DPFUEV')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9382)
 9382 FORMAT('      AT BRANCH POINT 9381--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9393)
 9393 FORMAT('      PARAMETER/VARIABLE NAME FOR FUNCTION ',
     1'EVALUATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9384)
 9384 FORMAT('      NOT FOUND IN INTERNAL LIST.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9385)IPJ,IPJ2
 9385 FORMAT('      PARAMETER/VARIABLE NAME = ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9386)
 9386 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,9387)(IANS(I3),I3=1,IWIDTH)
 9387 FORMAT(80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO19000
C
 9390 CONTINUE
      CALL COMPIM(IA,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPAR,
     1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,RIGHT,
     1IBUGCO,IBUGEV,IERROR)
      IF(IERROR.EQ.'YES')GOTO19000
      IJ=MAXN*(ICOLL-1)+I
      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
      IF(ICOLL.EQ.MAXCP1)PRED(I)=RIGHT
      IF(ICOLL.EQ.MAXCP2)RES(I)=RIGHT
      IF(ICOLL.EQ.MAXCP3)YPLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP4)XPLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=RIGHT
      IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=RIGHT
      IF(NS2.EQ.1)IROW1=I
      IROWN=I
 9350 CONTINUE
      GOTO10000
C
C               *******************************************
C               **  STEP 10--                            **
C               **  CARRY OUT THE LIST UPDATING AND      **
C               **  GENERATE THE INFORMATIVE PRINTING    **
C               **  FOR STEP NUMBERS 7, 8, AND 9 ABOVE.  **
C               *******************************************
C
10000 CONTINUE
      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
      DO10100J4=1,NUMNAM
      IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)GOTO10105
      GOTO10100
10105 CONTINUE
      IUSE(J4)='V'
      IVALUE(J4)=ICOLL
      VALUE(J4)=ICOLL
      IN(J4)=NINEW
10100 CONTINUE
C
      IF(IPRINT.EQ.'OFF')GOTO10099
      IF(IFEEDB.EQ.'OFF')GOTO10099
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,10011)ILEFT,ILEFT2,NS2
10011 FORMAT('THE NUMBER OF VALUES GENERATED FOR ',
     1'THE VARIABLE ',A4,A4,' = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IJ=MAXN*(ICOLL-1)+IROW1
      IF(ICOLL.LE.MAXCOL)WRITE(ICOUT,10021)ILEFT,ILEFT2,V(IJ),IROW1
10021 FORMAT('THE FIRST          COMPUTED VALUE OF ',A4,A4,
     1' = ',E13.6,' (ROW ',I5,')')
      IF(ICOLL.LE.MAXCOL)CALL DPWRST('XXX','BUG ')
      IF(ICOLL.EQ.MAXCP1)WRITE(ICOUT,10021)ILEFT,ILEFT2,PRED(IROW1),
     1IROW1
      IF(ICOLL.EQ.MAXCP1)CALL DPWRST('XXX','BUG ')
      IF(ICOLL.EQ.MAXCP2)WRITE(ICOUT,10021)ILEFT,ILEFT2,RES(IROW1),IROW1
      IF(ICOLL.EQ.MAXCP2)CALL DPWRST('XXX','BUG ')
      IF(ICOLL.EQ.MAXCP3)WRITE(ICOUT,10021)ILEFT,ILEFT2,YPLOT(IROW1),
     1IROW1
      IF(ICOLL.EQ.MAXCP3)CALL DPWRST('XXX','BUG ')
      IF(ICOLL.EQ.MAXCP4)WRITE(ICOUT,10021)ILEFT,ILEFT2,XPLOT(IROW1),
     1IROW1
      IF(ICOLL.EQ.MAXCP4)CALL DPWRST('XXX','BUG ')
      IF(ICOLL.EQ.MAXCP5)WRITE(ICOUT,10021)ILEFT,ILEFT2,X2PLOT(IROW1),
     1IROW1
      IF(ICOLL.EQ.MAXCP5)CALL DPWRST('XXX','BUG ')
      IF(ICOLL.EQ.MAXCP6)WRITE(ICOUT,10021)ILEFT,ILEFT2,TAGPLO(IROW1),
     1IROW1
      IF(ICOLL.EQ.MAXCP6)CALL DPWRST('XXX','BUG ')
C
      IJ=MAXN*(ICOLL-1)+IROWN
      IF(ICOLL.LE.MAXCOL.AND.
     1NS2.NE.1)WRITE(ICOUT,10031)NS2,ILEFT,ILEFT2,V(IJ),IROWN
10031 FORMAT('THE LAST (',I5,'TH) COMPUTED VALUE OF ',A4,A4,
     1' = ',E13.6,' (ROW ',I5,')')
      IF(ICOLL.LE.MAXCOL.AND.
     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
      IF(ICOLL.EQ.MAXCP1.AND.
     1NS2.NE.1)WRITE(ICOUT,10031)NS2,ILEFT,ILEFT2,PRED(IROWN),IROWN
      IF(ICOLL.EQ.MAXCP1.AND.
     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
      IF(ICOLL.EQ.MAXCP2.AND.
     1NS2.NE.1)WRITE(ICOUT,10031)NS2,ILEFT,ILEFT2,YPLOT(IROWN),IROWN
      IF(ICOLL.EQ.MAXCP2.AND.
     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
      IF(ICOLL.EQ.MAXCP3.AND.
     1NS2.NE.1)WRITE(ICOUT,10031)NS2,ILEFT,ILEFT2,XPLOT(IROWN),IROWN
      IF(ICOLL.EQ.MAXCP3.AND.
     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
      IF(ICOLL.EQ.MAXCP4.AND.
     1NS2.NE.1)WRITE(ICOUT,10031)NS2,ILEFT,ILEFT2,X2PLOT(IROWN),IROWN
      IF(ICOLL.EQ.MAXCP4.AND.
     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
      IF(ICOLL.EQ.MAXCP5.AND.
     1NS2.NE.1)WRITE(ICOUT,10031)NS2,ILEFT,ILEFT2,TAGPLO(IROWN),IROWN
      IF(ICOLL.EQ.MAXCP5.AND.
     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
      IF(ICOLL.EQ.MAXCP6.AND.
     1NS2.NE.1)WRITE(ICOUT,10031)NS2,ILEFT,ILEFT2,RES(IROWN),IROWN
      IF(ICOLL.EQ.MAXCP6.AND.
     1NS2.NE.1)CALL DPWRST('XXX','BUG ')
      IF(NS2.NE.1)GOTO10090
      WRITE(ICOUT,10041)
10041 FORMAT('SINCE THE GENERATED SAMPLE SIZE WAS ONLY 1,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,10042)
10042 FORMAT('THE ABOVE VALUE WAS THE SOLE VALUE COMPUTED.')
      CALL DPWRST('XXX','BUG ')
10090 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,10092)ILEFT,ILEFT2,ICOLL
10092 FORMAT('THE CURRENT COLUMN FOR ',
     1'THE VARIABLE ',A4,A4,' = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,10093)ILEFT,ILEFT2,NINEW
10093 FORMAT('THE CURRENT LENGTH OF  ',
     1'THE VARIABLE ',A4,A4,' = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
10099 CONTINUE
      GOTO19000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
19000 CONTINUE
C
C  RESTORE ORIGINAL FUNCTION TABLE
C
      DO19001I=1,NUMCHF
        IFUNC(I)=IFSAVE(I)
19001 CONTINUE
C
      IF(IBUGA3.EQ.'OFF')GOTO19090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,19011)
19011 FORMAT('***** AT THE END       OF DPFUEV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,19012)IBUGA3
19012 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,19013)IBUGCO,IBUGEV
19013 FORMAT('IBUGCO,IBUGEV = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,19014)IBUGQ
19014 FORMAT('IBUGQ = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,19015)IANGLU
19015 FORMAT('IANGLU = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,19016)IFOUND,IERROR
19016 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,19017)NUMNAM
19017 FORMAT('NUMNAM = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,19018)ICASEQ,ICASIF
19018 FORMAT('ICASEQ,ICASIF = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      DO19020I=1,NUMNAM
      WRITE(ICOUT,19021)I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I)
19021 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) = ',
     1I8,2X,A4,2X,A4,2X,A4,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
19020 CONTINUE
19090 CONTINUE
C
      RETURN
      END