SUBROUTINE DPSEPA(IHARG,IHARG2,IARGT,IARG,NUMARG,IDEFPA, CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC CCCCC SUBROUTINE DPSEPA(IHARG,IARGT,IARG,NUMARG,IDEFPA, 1MAXSEG,ISEGPA,IFOUND,IERROR) C C PURPOSE--DEFINE THE PATTERN FOR A SEGMENT. C THE PATTERN FOR SEGMENT I WILL BE PLACED C IN THE I-TH ELEMENT OF THE HOLLERITH C VECTOR ISEGPA(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFPA C --MAXSEG C OUTPUT ARGUMENTS--ISEGPA (A HOLLERITH VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C PATTERN FOR SEGMENT I. 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--89/2 C ORIGINAL VERSION--JANUARY 1989. C UPDATED --AUGUST 1995. DASH2 BUG C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CCCCC AUGUST 1995. ADD FOLLOWING LINE CHARACTER*4 IHARG2 CHARACTER*4 IARGT CHARACTER*4 IDEFPA CHARACTER*4 ISEGPA CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) CCCCC AUGUST 1995. ADD FOLLOWING LINE DIMENSION IHARG2(*) DIMENSION IARGT(*) DIMENSION IARG(*) C DIMENSION ISEGPA(*) 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.'PATT')GOTO1110 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'PATT')GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.1)GOTO1120 IF(IHARG(2).EQ.'ON')GOTO1120 IF(IHARG(2).EQ.'OFF')GOTO1120 IF(IHARG(2).EQ.'AUTO')GOTO1120 IF(IHARG(2).EQ.'DEFA')GOTO1120 GOTO1125 C 1120 CONTINUE IHOLD=IDEFPA GOTO1130 C 1125 CONTINUE IHOLD=IHARG(2) IF(IHOLD.EQ.'DASH'.AND.IHARG2(2).EQ.'2')IHOLD='DA2' IF(IHOLD.EQ.'DASH'.AND.IHARG2(2).EQ.'3')IHOLD='DA3' IF(IHOLD.EQ.'DASH'.AND.IHARG2(2).EQ.'4')IHOLD='DA4' IF(IHOLD.EQ.'DASH'.AND.IHARG2(2).EQ.'5')IHOLD='DA5' GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXSEG ISEGPA(I)=IHOLD 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1149 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)ISEGPA(I) 1136 FORMAT('ALL SEGMENT PATTERNS HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1149 CONTINUE GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPSEPA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE SEGMENT ... PATTERN COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE SEGMENT IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' SEGMENT 3 PATTERN SOLID') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXSEG)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPSEPA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE SEGMENT ... PATTERN COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF SEGMENTS MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXSEG 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'SEGMENT.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.2)GOTO1170 IF(IHARG(3).EQ.'ON')GOTO1170 IF(IHARG(3).EQ.'OFF')GOTO1170 IF(IHARG(3).EQ.'AUTO')GOTO1170 IF(IHARG(3).EQ.'DEFA')GOTO1170 GOTO1175 C 1170 CONTINUE IHOLD=IDEFPA GOTO1180 C 1175 CONTINUE IHOLD=IHARG(3) IF(IHOLD.EQ.'DASH'.AND.IHARG2(3).EQ.'2')IHOLD='DA2' IF(IHOLD.EQ.'DASH'.AND.IHARG2(3).EQ.'3')IHOLD='DA3' IF(IHOLD.EQ.'DASH'.AND.IHARG2(3).EQ.'4')IHOLD='DA4' IF(IHOLD.EQ.'DASH'.AND.IHARG2(3).EQ.'5')IHOLD='DA5' GOTO1180 C 1180 CONTINUE IFOUND='YES' ISEGPA(I)=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,ISEGPA(I) 1186 FORMAT('THE PATTERN FOR SEGMENT ',I8, 1' HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPSEQ(IHARG,IARGT,IARG,NUMARG, 1ISEQSW,NUMSEQ,IFOUND,IERROR) C C PURPOSE--DEFINE THE SEQUENCE SWITCH ISEQSW C AND THE START SEQUENCE NUMBER NUMSEQ . C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (AN INTEGER VECTOR) C --NUMARG C OUTPUT ARGUMENTS--ISEQSW ('ON' OR 'OFF') C --NUMSEQ (AN INTEGER) 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-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--NOVEMBER 1978. C UPDATED --SEPTEMBER 1980. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 ISEQSW 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)GOTO1110 IF(NUMARG.EQ.1)GOTO1120 IF(NUMARG.GE.2)GOTO1130 GOTO1190 C 1110 CONTINUE ISEQSW='ON' NUMSEQ=1 GOTO1150 C 1120 CONTINUE IF(IHARG(1).EQ.'ON')GOTO1122 IF(IHARG(1).EQ.'OFF')GOTO1124 IF(IHARG(1).EQ.'AUTO')GOTO1122 IF(IHARG(1).EQ.'DEFA')GOTO1124 IF(IARGT(1).EQ.'NUMB')GOTO1126 GOTO1190 C 1122 CONTINUE ISEQSW='ON' NUMSEQ=1 GOTO1150 C 1124 CONTINUE ISEQSW='OFF' NUMSEQ=1 GOTO1160 C 1126 CONTINUE ISEQSW='ON' NUMSEQ=IARG(1) GOTO1150 C 1130 CONTINUE IF(IHARG(1).EQ.'ON')GOTO1132 IF(IHARG(1).EQ.'OFF')GOTO1134 IF(IHARG(1).EQ.'AUTO')GOTO1132 IF(IHARG(1).EQ.'DEFA')GOTO1134 GOTO1190 C 1132 CONTINUE ISEQSW='ON' IF(IARGT(2).EQ.'NUMB')NUMSEQ=IARG(2) IF(IARGT(2).NE.'NUMB')NUMSEQ=1 GOTO1150 C 1134 CONTINUE ISEQSW='OFF' NUMSEQ=1 GOTO1160 C 1150 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1159 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT('THE SEQUENCE SWITCH HAS JUST BEEN TURNED ON') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)NUMSEQ 1156 FORMAT('(STARTING WITH SEQUENCE NUMBER ',I8,')') CALL DPWRST('XXX','BUG ') 1159 CONTINUE GOTO1180 C 1160 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1169 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1165) 1165 FORMAT('THE SEQUENCE SWITCH HAS JUST BEEN TURNED OFF') CALL DPWRST('XXX','BUG ') 1169 CONTINUE GOTO1180 C 1180 CONTINUE IFOUND='YES' GOTO1190 C 1190 CONTINUE RETURN END SUBROUTINE DPSEQU(IBUGA3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE A SEQUENCE. C GENERATE ELEMENTS OF A SEQUENCE C BY THE FORM (FOR EXAMPLE) LET Y = SEQUENCE 1 .01 10 C OR BY THE ALTERNATE FORM LET Y = 1 .01 10 C (FOR A FULL VARIABLE OR PART OF A VARIABLE). C OUTPUT--NECESSARILY A VARIABLE. C EXAMPLE--LET Y = 1 .01 10 (A FULL VARIABLE) C --LET Y = 1 .01 10 SUBSET 2 3 5 (A PARTIAL VAR.) C --LET Y = 1 .01 10 FOR I = 1 2 10 (A PARTIAL VAR.) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION (IN DPLET)--DECEMBER 1977. C UPDATED --MAY 1982. C ORIGINAL VERSION AS A SEPARATE SUBROUTINE--MARCH 1978. C UPDATED --JUNE 1978. C UPDATED --JULY 1978. C UPDATED --NOVEMBER 1978. C UPDATED --JUNE 1981. C UPDATED --JULY 1981. C UPDATED --SEPTEMBER 1981. C UPDATED --OCTOBER 1981. C UPDATED --NOVEMBER 1981. C UPDATED --APRIL 1987. C UPDATED --DECEMBER 1988. SHORTEN: LET Y = SEQU X C UPDATED --DECEMBER 1988. PARAM TO VAR COLUMN BUG C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 NEWNAM CHARACTER*4 NEWCOL CHARACTER*4 ILEFT CHARACTER*4 ILEFT2 CHARACTER*4 IH CHARACTER*4 IH2 C CCCCC THE FOLLOWING LINE WAS INSERTED (DECEMBER 1988) CCCCC TO FIX A PARAMETER TO VARIABLE COLUMN BUG (DECEMBER 1988) CHARACTER*4 IPTOV C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPSE' ISUBN2='QU ' 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 I2=0 NLEFT=0 ICOLL=0 N2=0 NRAWSE=0 NNUM=0 NS2=0 NS2MOD=0 C START=0.0 REPS=1.0 AINC=0.0 STOP=0.0 C ILEFT='UNKN' ILEFT2='UNKN' C CCCCC THE FOLLOWING LINE WAS INSERTED (DECEMBER 1988) CCCCC TO FIX A PARAMETER TO VARIABLE COLUMN BUG (DECEMBER 1988) IPTOV='NO' C C ******************************************************** C ** TREAT THE SUBCASE OF GENERATING ELEMENTS ** C ** (EXPRESSED ON THE RIGHT AS 3 CONSTANTS-- ** C ** START VALUE, INCREMENT, STOP VALUE) ** C ** 1) FOR A FULL VARIABLE, OR ** C ** 2) FOR PART OF A VARIABLE. ** C ******************************************************** C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSEQU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,IBUGQ 52 FORMAT('IBUGA3,IBUGQ = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************** C ** STEP 1-- ** C ** INITIALIZE SOME VARIABLES. ** C ********************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NEWNAM='NO' NEWCOL='NO' C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=5 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C **************************************************************** C ** STEP 3-- * C ** EXAMINE THE LEFT-HAND SIDE-- * C ** IS THE PARAMETER OR VARIABLE NAME TO LEFT OF = SIGN * C ** ALREADY IN THE NAME LIST? * C ** NOTE THAT ILEFT IS THE NAME OF THE VARIABLE * C ** ON THE LEFT. * C ** NOTE THAT ILISTL IS THE LINE IN THE TABLE * C ** OF THE NAME ON THE LEFT. * C ** NOTE THAT ICOLL IS THE DATA COLUMN (1 TO 12) * C ** FOR THE NAME OF THE LEFT. * C **************************************************************** C ISTEPN='3' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC ILEFT=IHOL(2) CCCCC ILEFT2=IHOL2(2) ILEFT=IHARG(1) ILEFT2=IHARG2(1) DO310I=1,NUMNAM I2=I IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO329 IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO380 310 CONTINUE NEWNAM='YES' ILISTL=NUMNAM+1 IF(ILISTL.GT.MAXNAM)GOTO320 GOTO330 C 320 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,321) 321 FORMAT('***** ERROR IN DPSEQU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,322) 322 FORMAT(' THE NUMBER OF VARIABLE AND/OR PARAMETER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,323)MAXNAM 323 FORMAT(' NAMES HAS JUST EXCEEDED THE MAX ALLOWABLE ', 1I8,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,324) 324 FORMAT(' SUGGESTED ACTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,325) 325 FORMAT(' ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,326) 326 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,327) 327 FORMAT(' AND THEN REDEFINE (REUSE) SOME OF THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,328) 328 FORMAT(' ALREADY-USED NAMES') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 329 CONTINUE CCCCC THE FOLLOWING LINE WAS INSERTED (DECEMBER 1988) CCCCC TO FIX A PARAMETER TO VARIABLE COLUMN BUG (DECEMBER 1988) IPTOV='YES' ILISTL=I2 GOTO330 C 330 CONTINUE NLEFT=0 ICOLL=NUMCOL+1 IF(ICOLL.GT.MAXCOL)GOTO340 GOTO390 C 340 CONTINUE WRITE(ICOUT,341) 341 FORMAT('***** ERROR IN DPSEQU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,342) 342 FORMAT(' THE NUMBER OF DATA COLUMNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,343)MAXCOL 343 FORMAT(' HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,344) 344 FORMAT(' SUGGESTED ACTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,345) 345 FORMAT(' ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,346) 346 FORMAT(' TO FIND OUT THE FULL LIST OF USED COLUMNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,347) 347 FORMAT(' AND THEN OVERWRITE SOME COLUMNS. EXAMPLE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,348) 348 FORMAT(' IF LET X = 1 2 9 FAILED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,349) 349 FORMAT(' THEN ONE MIGHT ENTER NAME X 7') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,350) 350 FORMAT(' (THEREBY EQUATING THE NAME X WITH COLUMN 7') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,351) 351 FORMAT(' FOLLOWED BY LET X = 1 2 9') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,352) 352 FORMAT(' (WHICH WILL ACTUALLY OVERWRITE COLUMN 7') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,353) 353 FORMAT(' WITH THE NUMERIC CONSTANTS 3.14)') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 380 CONTINUE ILISTL=I2 ICOLL=IVALUE(ILISTL) NLEFT=IN(ILISTL) C 390 CONTINUE C C **************************************************************** C ** STEP 4-- * C ** EXAMINE THE RIGHT-HAND SIDE-- * C ** DO WE HAVE 3 OR 4 CONSTANTS, * C ** OR 3 OR 4 PARAMETERS, * C ** OR A MIXTURE OF CONSTANTS AND PARAMETERS? * C ** (ALL OF THE ABOVE ARE ALLOWED.) * C **************************************************************** C ISTEPN='4' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC THE FOLLOWING 2 LINES WERE COMMENTED OUT (DECEMBER 1988) CCCCC AND REPLACED BY THE SUCCEEDING 2 LINES (DECEMBER 1988) CCCCC SO THAT SEQUENCE NEED NOT BE SPELLED OUT FULLY. (DECEMBER 1988) CCCCC IF(IHARG(3).EQ.'SEQU'.AND.IHARG2(3).EQ.'ENCE'.AND. CCCCC1NUMARG.GE.6)GOTO1290 IF(IHARG(3).EQ.'SEQU'.AND. 1NUMARG.GE.6)GOTO1290 IF(NUMARG.GE.5)GOTO1290 1210 CONTINUE WRITE(ICOUT,1211) 1211 FORMAT('***** ERROR IN DPSEQU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212) 1212 FORMAT(' ILLEGAL SYNTAX FOR LET COMMAND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1213) 1213 FORMAT(' THERE SHOULD BE AT LEAST 3') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1214) 1214 FORMAT(' NUMBERS OR WORDS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215) 1215 FORMAT(' TO THE RIGHT OF SEQUENCE OR =') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1216) 1216 FORMAT(' FOR THIS TYPE OF LET COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1217) 1217 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') NUMAM2=NUMARG-2 WRITE(ICOUT,1218)NUMAM2 1218 FORMAT(' NUMBER OF SUCH NUMBERS/WORDS FOUND = ',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 CCCCC THE FOLLOWING LINE WAS COMMENTED OUT (DECEMBER 1988) CCCCC AND REPLACED BY THE SUCCEEDING LINE (DECEMBER 1988) CCCCC SO THAT SEQUENCE NEED NOT BE SPELLED OUT FULLY. (DECEMBER 1988) CCCCC IF(IHARG(3).EQ.'SEQU'.AND.IHARG2(3).EQ.'ENCE')GOTO1302 IF(IHARG(3).EQ.'SEQU')GOTO1302 1301 CONTINUE NUMPAR=4 IF(NUMARG.LE.5)NUMPAR=3 IF(IHARG(6).EQ.'SUBS'.AND.IHARG2(6).EQ.'ET')NUMPAR=3 IF(IHARG(6).EQ.'EXCE'.AND.IHARG2(6).EQ.'PT')NUMPAR=3 IF(IHARG(6).EQ.'FOR'.AND.IHARG2(6).EQ.' ')NUMPAR=3 GOTO1309 1302 CONTINUE NUMPAR=4 IF(NUMARG.LE.6)NUMPAR=3 IF(IHARG(7).EQ.'SUBS'.AND.IHARG2(7).EQ.'ET')NUMPAR=3 IF(IHARG(7).EQ.'EXCE'.AND.IHARG2(7).EQ.'PT')NUMPAR=3 IF(IHARG(7).EQ.'FOR'.AND.IHARG2(7).EQ.' ')NUMPAR=3 GOTO1309 1309 CONTINUE C 1310 CONTINUE ILOCA=3 CCCCC THE FOLLOWING LINE WAS COMMENTED OUT (DECEMBER 1988) CCCCC AND REPLACED BY THE SUCCEEDING LINE (DECEMBER 1988) CCCCC SO THAT SEQUENCE NEED NOT BE SPELLED OUT FULLY. (DECEMBER 1988) CCCCC IF(IHARG(3).EQ.'SEQU'.AND.IHARG2(3).EQ.'ENCE')ILOCA=4 IF(IHARG(3).EQ.'SEQU')ILOCA=4 IF(IARGT(ILOCA).EQ.'NUMB')GOTO1311 IF(IARGT(ILOCA).EQ.'WORD')GOTO1312 GOTO1370 1311 CONTINUE START=ARG(ILOCA) GOTO1319 1312 CONTINUE IH=IHARG(ILOCA) IH2=IHARG2(ILOCA) IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 START=VALUE(ILOC) 1319 CONTINUE C 1320 CONTINUE REPS=1.0 IF(NUMPAR.LE.3)GOTO1329 ILOCA=ILOCA+1 IF(IARGT(ILOCA).EQ.'NUMB')GOTO1321 IF(IARGT(ILOCA).EQ.'WORD')GOTO1322 GOTO1370 1321 CONTINUE REPS=ARG(ILOCA) GOTO1329 1322 CONTINUE IH=IHARG(ILOCA) IH2=IHARG2(ILOCA) IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 REPS=VALUE(ILOC) 1329 CONTINUE C 1330 CONTINUE ILOCA=ILOCA+1 IF(IARGT(ILOCA).EQ.'NUMB')GOTO1331 IF(IARGT(ILOCA).EQ.'WORD')GOTO1332 GOTO1370 1331 CONTINUE AINC=ARG(ILOCA) GOTO1339 1332 CONTINUE IH=IHARG(ILOCA) IH2=IHARG2(ILOCA) IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 AINC=VALUE(ILOC) 1339 CONTINUE C 1340 CONTINUE ILOCA=ILOCA+1 IF(IARGT(ILOCA).EQ.'NUMB')GOTO1341 IF(IARGT(ILOCA).EQ.'WORD')GOTO1342 GOTO1370 1341 CONTINUE STOP=ARG(ILOCA) GOTO1349 1342 CONTINUE IH=IHARG(ILOCA) IH2=IHARG2(ILOCA) IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 STOP=VALUE(ILOC) 1349 CONTINUE GOTO1390 C 1370 CONTINUE WRITE(ICOUT,1371) 1371 FORMAT('***** INTERNAL ERROR IN DPSEQU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1372) 1372 FORMAT(' AN ARGUMENT TYPE WHICH SHOULD BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1373) 1373 FORMAT(' EITHER A NUMBER OR A WORD, IS NEITHER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1374)IHARG(ILOCA),IHARG2(ILOCA) 1374 FORMAT(' ARGUMENT = ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1375)ILOCA 1375 FORMAT(' LOCATION IN ARGUMENT LIST = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1376)IARGT(ILOCA) 1376 FORMAT(' ARGUMENT TYPE = ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1377) 1377 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1378)(IANS(I),I=1,IWIDTH) 1378 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1390 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 IFOUND='YES' C C ************************************************************** C ** STEP 6-- ** C ** GENERATE NRAWSE NUMBERS ** C ** IN THE RAW SEQUENCE. ** C ** STORE THEM TEMPORARILY IN ** C ** THE VECTOR Y(.). ** C ** GENERATE THE VALUES FOR THE VARIABLE. ** C ** IT IS OF THE FORM-- ** C ** LET Z = CONSTANT1 CONSTANT2 CONSTANT3 ** C ** LET Z = PARAMETER1 PARAMETER2 PARAMETER3 ** C ** NOTE THAT COULD ALSO HAVE ** C ** LET Z = CONSTANT1 PARAMETER2 PARAMETER3 ** C ** AND ALL OTHER SUCH MIXTURES. ** C ** THIS IS THE IMPLICIT GENERATE COMMAND ** C ** WHICH GENERATES A VARIABLES STARTING WITH ** C ** THE VALUE CONSTANT1 AND INCREMENTING BY CONSTANT2 ** C ** UNTIL IT ARIVES AT THE LAST VALUE NOT LARGER (SMALLER) ** C ** THAN CONSTANT3. ** C ** THE OUTPUT IS NECESSARILY A VARIABLE. ** C ************************************************************** C ISTEPN='6' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(AINC.EQ.0.0)N2=MAXN IF(AINC.NE.0.0)N2=((STOP-START)/AINC) IF(N2.LT.0)N2=-N2 N2=N2+10 IF(N2.GT.MAXN)N2=MAXN C IREP=1 IF(REPS.LE.1.0)IREP=1 IF(REPS.GT.1.0)IREP=REPS+0.5 C K=0 DO1400I=1,N2 AI=I YCALC=START+(AI-1.0)*AINC DO1410J=1,IREP K=K+1 IF(K.GT.MAXN)GOTO1450 Y(K)=YCALC 1410 CONTINUE IF(I.EQ.1)GOTO1400 IF(AINC.EQ.0.0)GOTO1400 IF(START.LT.STOP.AND.YCALC.GT.STOP)GOTO1460 IF(START.GT.STOP.AND.YCALC.LT.STOP)GOTO1460 1400 CONTINUE NRAWSE=K GOTO1490 1450 CONTINUE NRAWSE=K-1 GOTO1490 1460 CONTINUE NRAWSE=K-IREP GOTO1490 1490 CONTINUE C C *********************************************************** C ** STEP 7-- ** C ** IF CALLED FOR (THAT IS, IF IBUGA3 IS ON), ** C ** PRINT OUT THE INTERMEDIATE VARIABLE Y(.). ** C ** THIS IS USEFUL FOR DIAGNOSTIC PURPOSES ** C ** IN REVIEWING THE OUTPUT FROM THIS SUBROUTINE. ** C *********************************************************** C ISTEPN='7' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA3.EQ.'OFF')GOTO1590 WRITE(ICOUT,1551) 1551 FORMAT('OUTPUT FROM MIDDLE OF DPSEQU AFTER THE RAW SEQUENCE ', 1'HAS BEEN GENERATED--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1552)NRAWSE 1552 FORMAT('NRAWSE = ',I8) CALL DPWRST('XXX','BUG ') IF(NRAWSE.LE.0)GOTO1590 DO1554I=1,NRAWSE WRITE(ICOUT,1555)I,Y(I) 1555 FORMAT('I,Y(I) = ',I8,F12.5) CALL DPWRST('XXX','BUG ') 1554 CONTINUE C 1590 CONTINUE C C ***************************************** C ** STEP 8-- ** 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='8' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO1670 DO1610J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO1620 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO1620 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO1630 1610 CONTINUE GOTO1680 C 1620 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO1680 C 1630 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO1680 C 1670 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1671) 1671 FORMAT('***** INTERNAL ERROR IN DPSEQU') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1672) 1672 FORMAT(' AT BRANCH POINT 1671--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1673) 1673 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1674) 1674 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1675)NUMARG 1675 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1676) 1676 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1677)(IANS(I),I=1,IWIDTH) 1677 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1680 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO1690 WRITE(ICOUT,1681)NUMARG,ILOCQ,ICASEQ 1681 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') C 1690 CONTINUE C C ****************************************************** C ** STEP 9-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE ** C ** (BASED ON THE QUALIFIER); ** C ** DETERMINE THE NUMBER (= NNUM) ** C ** OF NUMBERS TO BE GENERATED. ** C ** NOTE THAT THE VARIABLE NIISUB ** C ** IS THE LENGTH OF THE RESULTING ** C ** VARIABLE ISUB(.). ** C ** NOTE THAT DPFOR AUTOMATICALLY EXTENDS ** C ** THE INPUT LENGTH OF ISUB(.) IF NECESSARY. ** C ** (HENCE THE REDEFINITION OF NIISUB TO NINEW ** C ** AFTER THE CALL TO DPFOR. ** C ****************************************************** C ISTEPN='9' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO1710 IF(ICASEQ.EQ.'SUBS')GOTO1720 IF(ICASEQ.EQ.'FOR')GOTO1730 C 1710 CONTINUE CCCCC IF(NEWNAM.EQ.'NO')NIISUB=NLEFT CCCCC IF(NEWNAM.EQ.'YES')NIISUB=NRAWSE NIISUB=NRAWSE DO1715I=1,NIISUB ISUB(I)=1 1715 CONTINUE NS=NIISUB NNUM=NIISUB GOTO1750 C 1720 CONTINUE NIISUB=MAXN CALL DPSUBS(NIISUB,ILOCS,NS,IBUGQ,IERROR) NNUM=NS GOTO1750 C 1730 CONTINUE IF(NEWNAM.EQ.'NO')NIISUB=NLEFT IF(NEWNAM.EQ.'YES')NIISUB=MAXN CALL DPFOR(NIISUB,NINEW,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NIISUB=NINEW NNUM=NS GOTO1750 C 1750 CONTINUE C C ****************************************************** C ** STEP 10-- ** C ** COPY THE SEQUENCE ** C ** FROM THE INTERMEDIATE VECTOR Y(.) ** C ** TO THE APPROPRIATE COLUMN ** C ** (BASED ON THE QUALIFIER--FULL, SUBSET, OR FOR) ** C ** IN THE INTERNAL DATAPLOT DATA TABLE. ** C ****************************************************** C ISTEPN='10' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NS2=0 NS2MOD=0 DO2100I=1,NIISUB IJ=MAXN*(ICOLL-1)+I IF(ISUB(I).EQ.0)GOTO2100 NS2=NS2+1 NS2MOD=NS2MOD+1 IF(NS2.EQ.1)IROW1=I IF(NS2MOD.GT.NRAWSE)NS2MOD=NS2MOD-NRAWSE IF(ICOLL.LE.MAXCOL)V(IJ)=Y(NS2MOD) IF(ICOLL.EQ.MAXCP1)PRED(I)=Y(NS2MOD) IF(ICOLL.EQ.MAXCP2)RES(I)=Y(NS2MOD) IF(ICOLL.EQ.MAXCP3)YPLOT(I)=Y(NS2MOD) IF(ICOLL.EQ.MAXCP4)XPLOT(I)=Y(NS2MOD) IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=Y(NS2MOD) IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=Y(NS2MOD) IROWN=I 2100 CONTINUE NNUM=NS2 C C ******************************************* C ** STEP 11-- ** C ** CARRY OUT THE LIST UPDATING AND ** C ** GENERATE THE INFORMATIVE PRINTING. ** C ******************************************* C ISTEPN='11' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.GE.NRAWSE)NINEW=NLEFT IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.LT.NRAWSE)NINEW=NRAWSE IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'YES')NINEW=NIISUB IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.GE.IROWN)NINEW=NLEFT IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.LT.IROWN)NINEW=IROWN IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'YES')NINEW=IROWN IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.GE.IROWN)NINEW=NLEFT IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.LT.IROWN)NINEW=IROWN IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'YES')NINEW=IROWN C IHNAME(ILISTL)=ILEFT IHNAM2(ILISTL)=ILEFT2 IUSE(ILISTL)='V' IVALUE(ILISTL)=ICOLL VALUE(ILISTL)=ICOLL IN(ILISTL)=NINEW C CCCCC IUSE(ICOLL)='V' CCCCC IVALUE(ICOLL)=ICOLL CCCCC VALUE(ICOLL)=ICOLL CCCCC IN(ICOLL)=NINEW C IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1 IF(NEWNAM.EQ.'YES')NUMCOL=NUMCOL+1 CCCCC THE FOLLOWING LINE WAS INSERTED (DECEMBER 1988) CCCCC TO FIX A PARAMETER TO VARIABLE COLUMN BUG (DECEMBER 1988) IF(NEWNAM.EQ.'NO'.AND.IPTOV.EQ.'YES')NUMCOL=NUMCOL+1 C DO2400J4=1,NUMNAM IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)GOTO2405 GOTO2400 2405 CONTINUE IUSE(J4)='V' IVALUE(J4)=ICOLL VALUE(J4)=ICOLL IN(J4)=NINEW 2400 CONTINUE C IF(IPRINT.EQ.'OFF')GOTO2459 IF(IFEEDB.EQ.'OFF')GOTO2459 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2411)ILEFT,ILEFT2,NNUM 2411 FORMAT('THE NUMBER OF VALUES GENERATED FOR ', 1'THE VARIABLE ',A4,A4,' = ',I8) CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') C IJ=MAXN*(ICOLL-1)+IROW1 IF(ICOLL.LE.MAXCOL)THEN WRITE(ICOUT,2421)ILEFT,ILEFT2,V(IJ),IROW1 2421 FORMAT('THE FIRST COMPUTED VALUE OF ', 1 A4,A4,' = ',E15.7,' (ROW ',I6,')') CALL DPWRST('XXX','BUG ') ELSE IF(ICOLL.EQ.MAXCP1)THEN WRITE(ICOUT,2421)ILEFT,ILEFT2,PRED(IROW1),IROW1 CALL DPWRST('XXX','BUG ') ELSE IF(ICOLL.EQ.MAXCP2)THEN WRITE(ICOUT,2421)ILEFT,ILEFT2,RES(IROW1),IROW1 CALL DPWRST('XXX','BUG ') ELSE IF(ICOLL.EQ.MAXCP3)THEN WRITE(ICOUT,2421)ILEFT,ILEFT2,YPLOT(IROW1),IROW1 CALL DPWRST('XXX','BUG ') ELSE IF(ICOLL.EQ.MAXCP4)THEN WRITE(ICOUT,2421)ILEFT,ILEFT2,XPLOT(IROW1),IROW1 CALL DPWRST('XXX','BUG ') ELSE IF(ICOLL.EQ.MAXCP5)THEN WRITE(ICOUT,2421)ILEFT,ILEFT2,X2PLOT(IROW1),IROW1 CALL DPWRST('XXX','BUG ') ELSE IF(ICOLL.EQ.MAXCP6)THEN WRITE(ICOUT,2421)ILEFT,ILEFT2,TAGPLO(IROW1),IROW1 CALL DPWRST('XXX','BUG ') ENDIF C IJ=MAXN*(ICOLL-1)+IROWN IF(NNUM.NE.1)THEN IF(ICOLL.LE.MAXCOL)THEN WRITE(ICOUT,2431)NNUM,ILEFT,ILEFT2,V(IJ),IROWN 2431 FORMAT('THE LAST (',I5,'-TH) COMPUTED VALUE OF ', 1 A4,A4,' = ',E15.7,' (ROW ',I6,')') CALL DPWRST('XXX','BUG ') ELSE IF(ICOLL.EQ.MAXCP1)THEN WRITE(ICOUT,2431)NNUM,ILEFT,ILEFT2,PRED(IROWN),IROWN CALL DPWRST('XXX','BUG ') ELSE IF(ICOLL.EQ.MAXCP2)THEN WRITE(ICOUT,2431)NNUM,ILEFT,ILEFT2,RES(IROWN),IROWN CALL DPWRST('XXX','BUG ') ELSE IF(ICOLL.EQ.MAXCP3)THEN WRITE(ICOUT,2431)NNUM,ILEFT,ILEFT2,YPLOT(IROWN),IROWN CALL DPWRST('XXX','BUG ') ELSE IF(ICOLL.EQ.MAXCP4)THEN WRITE(ICOUT,2431)NNUM,ILEFT,ILEFT2,XPLOT(IROWN),IROWN CALL DPWRST('XXX','BUG ') ELSE IF(ICOLL.EQ.MAXCP5)THEN WRITE(ICOUT,2431)NNUM,ILEFT,ILEFT2,X2PLOT(IROWN),IROWN CALL DPWRST('XXX','BUG ') ELSE IF(ICOLL.EQ.MAXCP6)THEN WRITE(ICOUT,2431)NNUM,ILEFT,ILEFT2,TAGPLO(IROWN),IROWN CALL DPWRST('XXX','BUG ') ENDIF ENDIF C IF(NNUM.NE.1)GOTO2449 WRITE(ICOUT,2441) 2441 FORMAT('SINCE THE GENERATED SAMPLE SIZE WAS ONLY 1,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2442) 2442 FORMAT('THE ABOVE VALUE WAS THE SOLE VALUE COMPUTED.') CALL DPWRST('XXX','BUG ') 2449 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2451)ILEFT,ILEFT2,ICOLL 2451 FORMAT('THE CURRENT COLUMN FOR ', 1'THE VARIABLE ',A4,A4,' = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2453)ILEFT,ILEFT2,NINEW 2453 FORMAT('THE CURRENT LENGTH OF ', 1'THE VARIABLE ',A4,A4,' = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 2459 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSEQU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGA3,IBUGQ 9013 FORMAT('IBUGA3,IBUGQ = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)MAXN,N2,NRAWSE,NS2,NS2MOD,NNUM 9015 FORMAT('MAXN,N2,NRAWSE,NS2,NS2MOD,NNUM = ',6I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NS,NIISUB,NNUM 9016 FORMAT('NS,NIISUB,NNUM = ',I8,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)START,REPS,AINC,STOP 9017 FORMAT('START,REPS,AINC,STOP = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)NLEFT,NRAWSE,NIISUB,IROW1,IROWN,NINEW 9018 FORMAT('NLEFT,NRAWSE,NIISUB,IROW1,IROWN,NINEW = ',6I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)ILEFT,ILEFT2,NEWNAM,ICOLL,NINEW 9019 FORMAT('ILEFT,ILEFT2,NEWNAM,ICOLL,NINEW = ',A4,A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)REPS,IREP 9021 FORMAT('REPS,IREP = ',E15.7,I8) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE INSERTED (DECEMBER 1988) CCCCC TO FIX A PARAMETER TO VARIABLE COLUMN BUG (DECEMBER 1988) WRITE(ICOUT,9022)IPTOV,NUMCOL 9022 FORMAT('IPTOV,NUMCOL = ',A4,I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPSERI(IFROW1,IFROW2,IFCOL1,IFCOL2,ISKIP,INTINF, CCCCC MARCH 1996. ADD IMALEV TO ARGUMENT LIST 1IMACRO,IMACNU,IMACCS,IOSW,IMALEV, 1IREARW, 1ICOMCH,ICOMSW, CCCCC FEBRUARY 2003: ADD FOLLOWING LINE 1NUMRCM, 1IFCOLL,IFCOLU, 1IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR) CCCCC ICOMCH, ICOMSW ADDED TO ARGUMENT LIST MAY, 1990. C C PURPOSE--READ IN THE VALUES OF A VARIABLE. C THE DATA IS LISTED SERIALLY ACROSS C A LINE IMAGE C (E.G., X(1) X(2) X(3) ETC.) C THE DATA IS READ FROM A MASS STORAGE FILE C OR (IF NO FILE GIVEN) FROM THE DEFAULT INPUT UNIT C (WHICH WILL BE THE TERMINAL). C ASSUMPTION--THE INPUT FILE ALREADY EXISTS; C (THAT IS, DATAPLOT WILL AUTOMATICALLY C OPEN THE FILE C VIA (ON THE UNIVAC 1108), BY AN @ASG,AX ...) C BUT WILL NOT AUTOMATICALLY CREATE THE FILE C VIA (ON THE UNIVAC 1108), BY AN @ASG,UP ...)) C ASSUMPTION--THE COMPUTER SYSTEM IS SUCH THAT C EQUATING THE FILE NAME TO C THE FORTRAN NUMERIC DESIGNATION C OF 31 (OR HOWEVER THE VARIABLE IREANU IS DEFINED C IN INITFO) IS PERMISSIBLE. C NOTE--INPUT FOR THE READ COMMAND MAY POTENTIALLY C COME FROM 2 DIFFERENT SOURCES-- C 1) THE TERMINAL ITSELF; C 2) A FILE; C DIFFERENT SYSTEMS ALLOW DIFFERENT COMBINATIONS C OF THE ABOVE. C ALL SYSTEMS WILL ALLOW INPUT FROM THER TERMINAL ITSELF; C MOST SYSTEMS WILL ALLOW INPUT FROM A FILE; C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--86/1 C ORIGINAL VERSION--NOVEMBER 1980. C UPDATED --JANUARY 1981. C UPDATED --JUNE 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --DECEMBER 1985. C UPDATED --FEBRUARY 1988. (DEACT. COL. LIM. IF READ NON-FILE) C UPDATED --DECEMBER 1988. CORRECT BOMB ON 2ND READ PARAMETER C UPDATED --MAY 1989. FIX IRIS PROBLEM--LOOP MAX & CPUMAX C UPDATED --MAY 1990. 1) CHECK FOR COMMENT CHARACTER C 2) ERROR CHECK FOR FORMATTED READ C UPDATED --JULY 1990. ICOMFL RENAMED AS ICOMSW C UPDATED --SEPTEMBER 1995. ROW LIMITS & BLANK LINES PROBLEM C UPDATED --FEBRUARY 2003. SUPPORT FOR LONGER DATA LINES C UPDATED --DECEMBER 2004. DO NOT ALLOW TERMINAL READ C WHILE RUNNING THE GUI. C UPDATED --APRIL 2005. ARGUMENT LIST TO DPREAL C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IMACRO CHARACTER*12 IMACCS C CHARACTER*4 IOSW C CHARACTER*4 IBUGS2 CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ICASEQ CHARACTER*4 ICASEA CHARACTER*4 IECASE CHARACTER*4 ISTOR1 CHARACTER*4 ISTOR2 CHARACTER*4 ISTOR3 CHARACTER*4 IEND CHARACTER*4 JVNAM1 CHARACTER*4 JPNAM1 CHARACTER*4 JMNAM1 CHARACTER*4 JFNAM1 CHARACTER*4 JUNAM1 CHARACTER*4 JENAM1 CHARACTER*4 JVNAM2 CHARACTER*4 JPNAM2 CHARACTER*4 JMNAM2 CHARACTER*4 JFNAM2 CHARACTER*4 JUNAM2 CHARACTER*4 JENAM2 CHARACTER*4 IH1 CHARACTER*4 IH2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 IOFILE CHARACTER*4 IOTERM C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IPROT CHARACTER*12 ICURST CHARACTER*4 IENDFI CHARACTER*4 IREWIN CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI C CHARACTER*80 ICANS CCCCC CHARACTER*80 ISTRIN C CHARACTER*4 ICASRE C CHARACTER*4 ICASTO C CHARACTER*4 IREARW C FOLLOWING 3 LINES MAY, 1990. CCCCC CHARACTER*80 IAJUNK CHARACTER*4 ICOMCH CHARACTER*4 ICOMSW CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1995 CHARACTER*4 LINETY C CHARACTER*4 IB C INTEGER IFCOLL(*) INTEGER IFCOLU(*) INTEGER ITYPE(50) C PARAMETER (MAXRDV=100) PARAMETER (MAXCHV=20) C DIMENSION JVNAM1(MAXRDV) DIMENSION JPNAM1(MAXRDV) DIMENSION JMNAM1(MAXRDV) DIMENSION JFNAM1(MAXRDV) DIMENSION JUNAM1(MAXRDV) DIMENSION JENAM1(MAXRDV) C CCCCC DIMENSION NIV(MAXRDV) C DIMENSION JVNAM2(MAXRDV) DIMENSION JPNAM2(MAXRDV) DIMENSION JMNAM2(MAXRDV) DIMENSION JFNAM2(MAXRDV) DIMENSION JUNAM2(MAXRDV) DIMENSION JENAM2(MAXRDV) C DIMENSION IEN(MAXRDV) DIMENSION IECOL2(MAXRDV) DIMENSION IECASE(MAXRDV) DIMENSION PVAL(MAXRDV) DIMENSION IFSTA2(MAXRDV) DIMENSION IFSTO2(MAXRDV) C DIMENSION X0(140) CHARACTER*24 IXC(140) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOFO.INC' INCLUDE 'DPCOF2.INC' INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOST.INC' C DIMENSION ISTOR1(MAXRCL) DIMENSION ISTOR2(MAXRCL) DIMENSION ISTOR3(MAXRCL) DIMENSION IB(MAXRCL) 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='DPSE' ISUBN2='RI ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C IFOUND='YES' IERROR='NO' C IOFILE='-999' IOTERM='-999' C CCCCC THE FOLLOWING LINE WAS INSERTED MAY 1989 IBILLI=INT(10.0**9 + 0.01) C I2=0 NUMVRD=0 C ICASRE='VARI' MAXN2=MAXCHF C NCALL=0 NCOLS=0 C C *************************** C ** TREAT THE READ CASE ** C *************************** C MAXV2=100 MAXP2=100 MAXM2=100 MAXF2=100 MAXU2=100 MAXE2=100 CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1995 LINETY='-999' C C IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSERI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IFROW1,IFROW2 52 FORMAT('IFROW1,IFROW2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IFCOL1,IFCOL2,NUMRCM 53 FORMAT('IFCOL1,IFCOL2,NUMRCM = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ISKIP,INTINF,IBUGS2,IBUGQ 54 FORMAT('ISKIP,INTINF,IBUGS2,IBUGQ = ',I8,I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IOSW 55 FORMAT('IOSW = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)IMACRO,IMACNU,IMACCS 56 FORMAT('IMACRO,IMACNU,IMACCS = ',A4,I8,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,58)IRD,IRD2 58 FORMAT('IRD,IRD2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)IBUGS2,ISUBRO,IERROR 63 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)IWIDTH 64 FORMAT('IWIDTH = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,65)(IANSLC(I),I=1,IWIDTH) 65 FORMAT('(IANSLC(I),I=1,IWIDTH) = ',80A1) CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,71)IREANU 71 FORMAT('IREANU = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)IREANA 72 FORMAT('IREANA = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)IREAST 73 FORMAT('IREAST = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,74)IREAFO 74 FORMAT('IREAFO = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,75)IREAAC 75 FORMAT('IREAAC = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,76)IREAFO 76 FORMAT('IREAFO = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,77)IREACS 77 FORMAT('IREACS = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,86)IREARW 86 FORMAT('IREARW = ',A4) CALL DPWRST('XXX','BUG ') ENDIF C C ******************************************************* C ** STEP 1-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='1' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LT.1)THEN IERROR='YES' GOTO8800 ENDIF C C ******************************************************* C ** STEP 2A-- ** C ** DETERMINE THE TYPE OF READ CASE-- ** C ** 1) FROM TERMINAL; ** C ** 2) FROM FILE; ** C ** NOTE--IOTERM WILL = 'YES' ONLY IN EXPLICIT ** C ** TERMINAL CASE. ** C ** (THAT IS, ONLY WHEN INPUT IOSW ** C ** = 'TERM') ** C ** NOTE--IOFILE WILL = 'YES' ONLY IN FILE CASE. ** C ******************************************************* C ISTEPN='2A' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C 200 CONTINUE IWORD=3 CALL DPFILE(IANSLC,IWIDTH,IWORD, 1IOFILE,IBUGS2,ISUBRO,IERROR) C IOTERM='NO' IF(IOFILE.EQ.'NO'.AND.IOSW.EQ.'TERM')IOTERM='YES' C CCCCC DECEMBER 2004. IF GUI RUNNING, DO NOT ALLOW TERMINAL READ. C IF(IOFILE.EQ.'NO' .AND. IGUIFL.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,211) 211 FORMAT('***** ERROR FROM READ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,213) 213 FORMAT(' TERMINAL READS (I.E., READ WITH NO FILE NAME ', 1 'SPECIFIED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,215) 215 FORMAT(' ARE NOT PERMITTED WHEN RUNNING DATAPLOT FROM ', 1 'THE GRAPHICAL USER INTERFACE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,217) 217 FORMAT(' ALTERNATIVELY, YOU CAN DO ONE OF THE FOLLOWING:') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,219) 219 FORMAT(' 1) YOU CAN ENTER THE DATA DIRECTLY FROM THE ', 1 'DATASHEET.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,221) 221 FORMAT(' 2) FROM THE COMMAND LINE WINDOW, YOU CAN USE ', 1 'THE DATA COMMAND AS FOLLOWS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,223) 223 FORMAT(' LET Y = DATA value1 value2 ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,225) 225 FORMAT(' 3) THE FIRST TWO METHODS ARE USEFUL FOR SMALL ', 1 'AMOUNTS OF DATA.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,227) 227 FORMAT(' FOR MORE THAN A FEW DATA POINTS, IT IS ', 1 'RECOMMENDED THAT YOU') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,229) 229 FORMAT(' CREATE THE DATA IN AN ASCII FILE AND THEN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,231) 231 FORMAT(' READ THE DATA FROM THAT FILE.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C C ************************************* C ** STEP 2B-- ** C ** IF HAVE THE FILE INPUT CASE-- ** C ** COPY OVER VARIABLES ** C ************************************* C ISTEPN='2B' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IOFILE.EQ.'NO')GOTO1190 C IOUNIT=IREANU IFILE=IREANA ISTAT=IREAST IFORM=IREAFO IACCES=IREAAC IPROT=IREAPR ICURST=IREACS C ISUBN0='SERI' IERRFI='NO' C IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI')THEN WRITE(ICOUT,1183)IOUNIT 1183 FORMAT('IOUNIT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1184)IFILE 1184 FORMAT('IFILE = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1185)ISTAT,IFORM,IACCES,IPROT,ICURST 1185 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ', 1 A12,2X,A12,2X,A12,2X,A12,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)ISUBN0,IERRFI 1186 FORMAT('ISUBN0,IERRFI = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF C 1190 CONTINUE C C *********************************************** C ** STEP 2C-- ** C ** IF HAVE THE FILE INPUT CASE-- ** C ** CHECK TO SEE IF THE READ FILE MAY EXIST ** C *********************************************** C ISTEPN='2C' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IOFILE.EQ.'YES' .AND. ISTAT.EQ.'NONE')THEN IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** IMPLEMENTATION ERROR IN SERIAL READ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212) 1212 FORMAT(' THE DESIRED READING CANNOT BE CARRIED OUT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1214) 1214 FORMAT(' BECAUSE THE INTERNAL VARIABLE IREAST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215) 1215 FORMAT(' WHICH ALLOWS SUCH READING HAS BEEN SET TO ', 1 ' NONE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1217)ISTAT,IREAST 1217 FORMAT('ISTAT,IREAST = ',A12,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1218) 1218 FORMAT(' ALL READING MUST BE DONE DIRECTLY FROM THE ', 1 'TERMINAL.') CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C C ************************************* C ** STEP 2D-- ** C ** IF HAVE THE FILE INPUT CASE-- ** C ** EXTRACT THE FILE NAME ** C ************************************* C ISTEPN='2D' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IOFILE.EQ.'YES')THEN C DO1310I=1,80 ICANS(I:I)=IANSLC(I) 1310 CONTINUE C ISTART=1 ISTOP=IWIDTH IWORD=3 CALL DPEXWO(ICANS,ISTART,ISTOP,IWORD, 1 ICOL1,ICOL2,IFILE,NCFILE, 1 IBUGS2,ISUBRO,IERROR) C IF(NCFILE.LT.1)THEN IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1341) 1341 FORMAT('***** ERROR IN SERIAL READ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1342) 1342 FORMAT(' A USER FILE NAME IS REQUIRED IN THE ', 1 'READ COMMAND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1344) 1344 FORMAT(' (FOR EXAMPLE, READ CALIB.DAT X Y Z)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1345) 1345 FORMAT(' BUT NONE WAS GIVEN HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1346) 1346 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,1347)(IANSLC(I),I=1,IWIDTH) 1347 FORMAT(' ',80A1) ELSE WRITE(ICOUT,999) ENDIF CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C ENDIF C C ************************************* C ** STEP 2E-- ** C ** IF HAVE THE FILE INPUT CASE-- ** C ** OPEN THE FILE ** C ************************************* C ISTEPN='2E' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IOFILE.EQ.'YES')THEN C IREWIN='ON' IF(IREACS(1:4).EQ.'CLOS')THEN CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IREACS='OPEN' ENDIF IF(IERRFI.EQ.'YES')GOTO9000 ENDIF C C ****************************************** C ** STEP 2F-- ** C ** FOR THE 2 CASES-- ** C ** 1) TERMINAL INPUT; ** C ** 2) FILE INPUT; ** C ** DEFINE THE INPUT READ UNIT NUMBER, ** C ** AND OTHER VARIABLES NEEDED ** C ** FOR UPCOMING READS. ** C ****************************************** C ISTEPN='2F' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IRD2=IRD CCCCC IF(IMACST.EQ.'OPFI')IRD2=IMACNU CCCCC MARCH 1996. BUG IF READ DONE WITHIN A MACRO AFTER A NESTED MACRO CCCCC CALLED. CCCCC IF(IMACCS.EQ.'OPEN')IRD2=IMACNU IF(IMACCS.EQ.'OPEN'.OR.IMALEV.GE.1)THEN IRD2=IMACNU+IMALEV-1 ENDIF IF(IOFILE.EQ.'YES')IRD2=IREANU IF(IOTERM.EQ.'YES')IRD2=IRD C IOUNIT=IRD2 IDEV='SERI' C C ***************************************** C ** STEP 3-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='3' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO390 DO300J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO310 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO310 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO320 300 CONTINUE GOTO390 310 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO390 320 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO390 390 CONTINUE IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI')THEN WRITE(ICOUT,391)NUMARG,ILOCQ 391 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') ENDIF C C ******************************************************* C ** STEP 4-- ** C ** DETERMINE THE TYPE AND NUMBER OF ITEMS ** C ** TO BE READ . ** C ** NUMALL = TOTAL NUMBER OF READ ITEMS ** C ** (AS DETERMINED BY INCLUDING ONLY ALL ** C ** BEFORE 'SUBSET' OR 'EXCEPT' OR 'FOR') ** C ** NUMV = NUMBER OF VARIABLES TO BE READ ; ** C ** NUMP = NUMBER OF PARAMETERS TO BE READ ; ** C ** NUMM = NUMBER OF MODELS TO BE READ ** C ** (SHOULD = 0 OR 1) ** C ** NUMF = NUMBER OF FUNCTIONS TO BE READ ** C ** NUMU = NUMBER OF UNKNOWNS TO BE READ ; ** C ** NUME = TOTAL NUMBER OF READ ITEMS ** C ** (SHOULD = NUMALL); ** C ******************************************************* C ISTEPN='4' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMALL=ILOCQ-1 IF(IOFILE.EQ.'YES')NUMALL=ILOCQ-2 C IV=0 IP=0 IM=0 IF=0 IU=0 IE=0 IH1=' ' IH2=' ' JMIN=2 IF(IOFILE.EQ.'YES')JMIN=3 JMAX=ILOCQ-1 IF(JMIN.GT.JMAX)GOTO4290 DO4200J=JMIN,JMAX IH1=IHARG(J) IH2=IHARG2(J) C C *************** C THE FOLLOWING CODE ALLOWS THE TO KEYWORD C TO BE ACTIVATED, AS IN C SERIAL READ FILE.EXT Y1 TO Y10 C DECEMBER 1986 C *************** C ICASTO='OFF' IF (IH1.EQ.'TO ')GOTO4210 GOTO4220 C 4210 CONTINUE ICASTO='ON' JM1=J-1 JP1=J+1 CALL DPEXTL(IHARG(JM1),IHARG2(JM1),IHARG(JP1),IHARG2(JP1), 1 KNUMB,IVAL1,IVAL2,IBUGS2,ISUBRO,IERROR) C IVA1P1=IVAL1+1 IVA2M1=IVAL2-1 IF(IVA1P1.GT.IVA2M1)GOTO4200 IVAL=IVAL1 4215 CONTINUE IVAL=IVAL+1 IF(IVAL.GE.IVAL2)GOTO4200 C CALL DPAPNU(IHARG(JM1),IHARG2(JM1),KNUMB,IVAL, 1 IH1,IH2,IBUGS2,ISUBRO,IERROR) GOTO4220 C 4220 CONTINUE ICASEA=' ' DO4300I=1,NUMNAM I2=I IF(IH1.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I))GOTO4305 GOTO4300 4305 CONTINUE IF(IUSE(I).EQ.'V')GOTO4310 IF(IUSE(I).EQ.'P')GOTO4320 IF(IUSE(I).EQ.'M')GOTO4330 IF(IUSE(I).EQ.'F')GOTO4340 4300 CONTINUE ICASEA='U' GOTO4350 C 4310 CONTINUE ICASEA='V' IV=IV+1 IF(IV.GT.MAXV2)GOTO4370 JVNAM1(IV)=IH1 JVNAM2(IV)=IH2 GOTO4370 C 4320 CONTINUE ICASEA='P' IP=IP+1 IF(IP.GT.MAXP2)GOTO4370 CCCCC THE FOLLOWING 2 CORRECTIONS WERE MADE IN DECEMBER 1988 CCCCC TO CORRECT THE BOMB OF READ PARAMETER UPON 2ND USAGE CCCCC JPNAM1(IV)=IH1 CCCCC JPNAM2(IV)=IH2 JPNAM1(IP)=IH1 JPNAM2(IP)=IH2 PVAL(IP)=VALUE(I2) C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4321) 4321 FORMAT('***** ERROR IN SERIAL READ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4322) 4322 FORMAT(' A NAME IN THE LIST OF VARIABLES TO BE READ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4324) 4324 FORMAT(' INCLUDED THE NAME OF A PREVIOUSLY-DEFINED ', 1 'PARAMETER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4326)IH1,IH2 4326 FORMAT(' THE NAME OF THE PARAMETER WAS ',2A4,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4327) 4327 FORMAT(' NO READ WAS CARRIED OUT.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8800 C 4330 CONTINUE ICASEA='M' IM=IM+1 IF(IM.GT.MAXM2)GOTO4370 JMNAM1(IM)=IH1 JMNAM2(IM)=IH2 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4331) 4331 FORMAT('***** ERROR IN SERIAL READ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4332) 4332 FORMAT(' A NAME IN THE LIST OF VARIABLES TO BE READ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4334) 4334 FORMAT(' INCLUDED THE NAME OF A PREVIOUSLY-DEFINED ', 1 'MODEL.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4336)IH1,IH2 4336 FORMAT(' THE NAME OF THE MODEL WAS ',2A4,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4337) 4337 FORMAT(' NO READ WAS CARRIED OUT.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8800 C 4340 CONTINUE ICASEA='F' IF=IF+1 IF(IF.GT.MAXF2)GOTO4370 JFNAM1(IF)=IH1 JFNAM2(IF)=IH2 IFSTA2(IF)=IVSTAR(I2) IFSTO2(IF)=IVSTOP(I2) C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4341) 4341 FORMAT('***** ERROR IN SERIAL READ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4342) 4342 FORMAT(' A NAME IN THE LIST OF VARIABLES TO BE READ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4344) 4344 FORMAT(' INCLUDED THE NAME OF A PREVIOUSLY-DEFINED ', 1 'FUNCTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4346)IH1,IH2 4346 FORMAT(' THE NAME OF THE FUNCTION WAS ',2A4,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4347) 4347 FORMAT(' NO READ WAS CARRIED OUT.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8800 C 4350 CONTINUE ICASEA='U' IU=IU+1 IF(IU.GT.MAXU2)GOTO4370 JUNAM1(IU)=IH1 JUNAM2(IU)=IH2 GOTO4370 C 4370 CONTINUE IE=IE+1 IF(IE.GT.MAXE2)GOTO4380 JENAM1(IE)=IH1 JENAM2(IE)=IH2 IECASE(IE)='NEW' IF(ICASEA.EQ.'V')IECASE(IE)='OLD' IECOL2(IE)=-1 IF(ICASEA.EQ.'V')IECOL2(IE)=IVALUE(I2) CCCCC NOVEMBER 2002. FIX FOLLOWING LINE FOR "TO" CASE. CCCCC GOTO4200 GOTO4280 C 4380 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4381) 4381 FORMAT('***** ERROR IN SERIAL READ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4382) 4382 FORMAT(' THE NUMBER OF NAMES IN THE READ COMMAND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4383) 4383 FORMAT(' HAS JUST EXCEEDED THE ALLOWABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4384)MAXE2 4384 FORMAT(' MAXIMUM (',I5,')') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8800 C 4280 CONTINUE IF(ICASTO.EQ.'ON')GOTO4215 C 4200 CONTINUE 4290 CONTINUE NUMV=IV NUMP=IP NUMM=IM NUMF=IF NUMU=IU NUME=IE C IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI')THEN WRITE(ICOUT,4411)NUMALL,NUMV,NUMP,NUMM,NUMF,NUMU,NUME 4411 FORMAT('NUMALL,NUMV,NUMP,NUMM,NUMF,NUMU,NUME = ',7I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4412) 4412 FORMAT('I,JVNAM1(I),JVNAM2(I),JPNAM1(I),JPNAM2(I), 1 JMNAM1(I),JMNAM2(I),JFNAM1(I),JFNAM2(I),JUNAM1(I),JUNAM2(I)') CALL DPWRST('XXX','BUG ') DO4420I=1,15 WRITE(ICOUT,4421)I,JVNAM1(I),JVNAM2(I),JPNAM1(I),JPNAM2(I), 1 JMNAM1(I),JMNAM2(I),JFNAM1(I),JFNAM2(I),JUNAM1(I),JUNAM2(I) 4421 FORMAT(I8,5X,2A4,1X,2A4,1X,2A4,1X,2A4,1X,2A4) CALL DPWRST('XXX','BUG ') 4420 CONTINUE ENDIF C C *************************************************** C ** STEP 5-- ** C ** CHECK FOR A VALID NUMBER ** C ** (1 TO 100) OF VARIABLES TO BE READ ** C ** (NOTE--THIS DOES NOT INCLUDE PARAMETERS ** C ** OR MODELS IN THE ABOVE COUNT-- ** C ** ONLY VARIABLES.) ** C ** CHECK FOR A VALID NUMBER ** C ** (0 TO 100) OF CONSTANTS TO BE READ . ** C ** CHECK FOR A VALID NUMBER ** C ** (0 TO 100) OF MODELS TO BE READ . ** C ** CHECK FOR A VALID NUMBER ** C ** (0 TO 100) OF FUNCTIONS TO BE READ . ** C ** CHECK FOR A VALID NUMBER ** C ** (1 TO 100) OF UNKNOWNS TO BE READ . ** C *************************************************** C IF(NUMV.LT.0 .OR. NUMV.GT.MAXV2)THEN C WRITE(ICOUT,511) 511 FORMAT('***** ERROR IN SERIAL READ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,512) 512 FORMAT(' FOR A READ, THE NUMBER OF VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,513) 513 FORMAT(' (NOT COUNTING PARAMETERS OR MODELS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,514)MAXV2 514 FORMAT(' MUST BE AT MOST ',I8,' ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,515) 515 FORMAT(' SUCH WAS NOT THE CASE HERE; THE SPECIFIED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,517)NUMV 517 FORMAT(' NUMBER OF VARIABLES TO BE READ WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,518)MAXV2 518 FORMAT(' NOTE--ONLY THE FIRST ',I8,' VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,519) 519 FORMAT(' WILL BE READ .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,520) 520 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,521)(IANSLC(I),I=1,MAX(80,IWIDTH)) 521 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF C ENDIF C IF(NUMP.LT.0 .OR. NUMP.GT.MAXP2)THEN WRITE(ICOUT,531) 531 FORMAT('***** ERROR IN SERIAL READ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,532) 532 FORMAT(' FOR A READ, THE NUMBER OF PARAMETERS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,534)MAXP2 534 FORMAT(' (CONSTANTS) MUST BE AT MOST ',I8,' ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,535) 535 FORMAT(' SUCH WAS NOT THE CASE HERE; THE SPECIFIED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,537)NUMP 537 FORMAT(' NUMBER OF PARAMETERS TO BE READ WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,538)MAXP2 538 FORMAT(' NOTE--ONLY THE FIRST ',I8,' PARAMETERS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,539) 539 FORMAT(' WILL BE READ .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,540) 540 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,541)(IANSLC(I),I=1,MAX(80,IWIDTH)) 541 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF C ENDIF C IF(NUMM.LT.0 .OR. NUMM.GT.MAXM2)THEN C WRITE(ICOUT,551) 551 FORMAT('***** ERROR IN SERIAL READ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,552) 552 FORMAT(' FOR A READ, THE NUMBER OF MODELS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,554)MAXM2 554 FORMAT(' MUST BE AT MOST ',I8,' ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,555) 555 FORMAT(' SUCH WAS NOT THE CASE HERE; THE SPECIFIED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,557)NUMM 557 FORMAT(' NUMBER OF MODELS TO BE READ WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,558)MAXM2 558 FORMAT(' NOTE--ONLY THE FIRST ',I8,' MODELS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) 559 FORMAT(' WILL BE READ .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,560) 560 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,561)(IANSLC(I),I=1,MAX(80,IWIDTH)) 561 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF C ENDIF C IF(NUMF.LT.0 .OR. NUMM.GT.MAXF2)THEN C WRITE(ICOUT,571) 571 FORMAT('***** ERROR IN SERIAL READ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,572) 572 FORMAT(' FOR A READ, THE NUMBER OF FUNCTIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,574)MAXF2 574 FORMAT(' MUST BE AT MOST ',I8,' ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,575) 575 FORMAT(' SUCH WAS NOT THE CASE HERE; THE SPECIFIED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,577)NUMF 577 FORMAT(' NUMBER OF FUNCTIONS TO BE READ WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,578)MAXF2 578 FORMAT(' NOTE--ONLY THE FIRST ',I8,' FUNCTIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,579) 579 FORMAT(' WILL BE READ .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,560) 580 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,581)(IANSLC(I),I=1,MAX(80,IWIDTH)) 581 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF C ENDIF C IF(NUMU.LT.0 .OR. NUMU.GT.MAXU2)THEN C WRITE(ICOUT,611) 611 FORMAT('***** ERROR IN SERIAL READ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,612) 612 FORMAT(' FOR A READ, THE NUMBER OF UNKNOWNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,614)MAXU2 614 FORMAT(' MUST BE AT MOST ',I8,' ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,615) 615 FORMAT(' SUCH WAS NOT THE CASE HERE; THE SPECIFIED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,617)NUMU 617 FORMAT(' NUMBER OF UNKNOWNS TO BE READ WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,618)MAXU2 618 FORMAT(' NOTE--ONLY THE FIRST ',I8,' UNKNOWNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,619) 619 FORMAT(' WILL BE READ .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,620) 620 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,621)(IANSLC(I),I=1,MAX(80,IWIDTH)) 621 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF C ENDIF C IF(NUME.LT.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4451) 4451 FORMAT('***** ERROR IN SERIAL READ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4452) 4452 FORMAT(' NO VARIABLE NAMES WERE PROVIDED IN THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4453) 4453 FORMAT(' READ STATEMENT, HENCE NO READ WAS CARRIED OUT.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4454) 4454 FORMAT(' ILLUSTRATIVE EXAMPLE TO DEMONSTRATE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4455) 4455 FORMAT(' THE PROPER FORM FOR THE READ COMMAND--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4456) 4456 FORMAT(' SUPPOSE THE ANALYST WISHES TO READ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4457) 4457 FORMAT(' DATA FROM THE FILE CALIB.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4458) 4458 FORMAT(' INTO THE INTERNAL VARIABLES Y, X1, AND X2;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4459) 4459 FORMAT(' THIS IS DONE BY ENTERING THE COMMAND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4460) 4460 FORMAT(' READ CALIB. Y X1 X2') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8800 ENDIF C C ******************************************************* C ** STEP 6-- ** C ** THOSE NAMES WHICH ARE OF THE UNKNOWN CATEGORY ** C ** WILL BECOME FUTURE VARIABLES. ** C ** ASSIGN THESE VARIABLES TO THE NEXT AVAILABLE ** C ** COLUMNS, AND UPDATE THE NAME TABLE ACCORDINGLY. ** C ******************************************************* C IF(NUME.GT.0)THEN INAM=NUMNAM ICOL=NUMCOL DO700IE=1,NUME IF(IECOL2(IE).GE.1)GOTO700 INAM=INAM+1 ICOL=ICOL+1 C IF(INAM.GT.MAXNAM)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,711) 711 FORMAT('***** ERROR IN SERIAL READ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,712) 712 FORMAT(' THE NUMBER OF NAMES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,713) 713 FORMAT(' (PARAMETERS + VARIABLES + FUNCTIONS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,714) 714 FORMAT(' HAS JUST EXCEEDED THE MAXIMUM SIZE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,715)MAXNAM 715 FORMAT(' (',I5,') OF THE INTERNAL NAME TABLE.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8800 ENDIF C IF(ICOL.GT.MAXCOL)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,721) 721 FORMAT('***** ERROR IN SERIAL READ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,722) 722 FORMAT(' THE NUMBER OF COLUMNS IN THE INTERNAL ', 1 'DATAPLOT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,724) 724 FORMAT(' DATA ARRAY HAS JUST EXCEEDED THE ALLOWABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,725)MAXCOL 725 FORMAT(' MAXIMUM (',I5,')') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8800 ENDIF C IHNAME(INAM)=JENAM1(IE) IHNAM2(INAM)=JENAM2(IE) IUSE(INAM)='V' IVALUE(INAM)=ICOL IECOL2(IE)=ICOL IN(INAM)=0 700 CONTINUE NUMNAM=INAM NUMCOL=ICOL ENDIF C IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,791)NUMNAM,NUMCOL 791 FORMAT('NUMNAM,NUMCOL = ',I8,I8) CALL DPWRST('XXX','BUG ') ENDIF C C ******************************************************* C ** STEP 7-- ** C ** FIRST, BRANCH TO THE APPROPRIATE SUBCASE ** C ** (DEPENDING ON WHETHER UNQUALIFIED, SUBSET OR FOR);* C ** THE DETERMINE THE LENGTH OF THE LONGEST ** C ** VARIABLE TO BE READ IN ; ** C ** THEN READ IN THE VARIABLES ** C ** THAT WERE SPECIFIED. ** C ******************************************************* C ISTEPN='7' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MAXNRD=MAXN IF(ICASEQ.EQ.'FULL')GOTO7310 IF(ICASEQ.EQ.'SUBS')GOTO7320 IF(ICASEQ.EQ.'FOR')GOTO7330 C 7310 CONTINUE DO7315I=1,MAXNRD ISUB(I)=1 7315 CONTINUE NQ2=MAXNRD GOTO7350 C 7320 CONTINUE NIOLD=MAXNRD CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ2=NIOLD GOTO7350 C 7330 CONTINUE NIOLD=MAXNRD CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ2=NFOR GOTO7350 C 7350 CONTINUE C C ******************************************* C ** STEP 8-- ** C ** IF A DATA ROW MINIMUM EXISTS AND SO ** C ** OUR ATTENTION IS FOCUSED ONLY ON ** C ** CERTAIN ROWS OF THE DATA FILE, ** C ** THEN GO DOWN TO THE FIRST SUCH ROW ** C ** IN THE FILE. ** C ******************************************* C ISTEPN='8' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IFROW1.LE.1)GOTO7369 IFRMIN=1 IFRMAX=IFROW1-1 IF(IFRMIN.GT.IFRMAX)GOTO7369 MINCO2=1 MAXCO2=NUMRCM IF(IRD2.EQ.IRD)MAXCO2=80 IFCOL3=IFCOL1 IFCOL4=IFCOL2 C THE FOLLOWING 2 LINES WERE INSERTED FEBRUARY 1988 C TO "TURN OFF" THE COLUMN LIMITS IF READING FROM A C NON-FILE (THAT IS, IF READING FROM THE TERMINAL OR WITHIN A C MACRO). IF(IOFILE.EQ.'NO')IFCOL3=MINCO2 IF(IOFILE.EQ.'NO')IFCOL4=MAXCO2 IF(IRD2.EQ.IRD.AND.IFCOL4.GT.MAXCO2)IFCOL4=MAXCO2 C DO7360IFROW=IFRMIN,IFRMAX IF(IOFILE.EQ.'NO')THEN READ(IRD2,7362,END=7363)IJUNK 7362 FORMAT(A1) ELSEIF(IOFILE.EQ.'YES')THEN NUMCHA=-1 CALL DPREFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 IA,NUMCHA, 1 ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) ENDIF C IF(IERROR.EQ.'YES')GOTO8800 IF(IA(1).EQ.'E'.AND.IA(2).EQ.'O'.AND.IA(3).EQ.'F'.AND. 1 NUMCHA.EQ.3)GOTO7363 GOTO7360 7363 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7364) 7364 FORMAT('***** ERROR IN SERIAL READ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7365) 7365 FORMAT(' END OF FILE ENCOUNTERED WHILE SKIPPING OVER', 1 'HEADER LINES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7367) 7367 FORMAT(' NOTE SKIP AND ROW LIMITS SETTINGS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7368)ISKIP,IFROW1,IFROW2 7368 FORMAT(' ISKIP,IFROW1,IFROW2 = ',3I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8800 C 7360 CONTINUE 7369 CONTINUE C C ******************************************* C ** STEP 9-- ** C ** IN ADDITION, IF HEADER (= NON-DATA) ** C ** LINES EXIST WHICH ARE TO BE SKIPPED ** C ** OVER IN THE READ, DO SO HERE. ** C ******************************************* C ISTEPN='9' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IOFILE.EQ.'NO')GOTO7389 C IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IF(IFROW1.LE.1)THEN WRITE(ICOUT,7371) 7371 FORMAT('THE NUMBER OF HEADER LINES') CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,7372) 7372 FORMAT('THE NUMBER OF (ADDITIONAL) HEADER LINES') CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,7373)ISKIP 7373 FORMAT(' BEING SKIPPED = ',I6) CALL DPWRST('XXX','BUG ') ENDIF C IF(ISKIP.LE.0)GOTO7389 IFRMIN=IFROW1 IFRMAX=IFROW1+ISKIP-1 IF(IFRMIN.GT.IFRMAX)GOTO7389 MINCO2=1 MAXCO2=NUMRCM IF(IRD2.EQ.IRD)MAXCO2=80 IFCOL3=IFCOL1 IFCOL4=IFCOL2 C THE FOLLOWING 2 LINES WERE INSERTED FEBRUARY 1988 C TO "TURN OFF" THE COLUMN LIMITS IF READING FROM A NON-FILE C (THAT IS, IF READING FROM THE TERMINAL OR WITHIN A MACRO). IF(IOFILE.EQ.'NO')THEN IFCOL3=MINCO2 IFCOL4=MAXCO2 ENDIF IF(IRD2.EQ.IRD.AND.IFCOL4.GT.MAXCO2)IFCOL4=MAXCO2 DO7380IFROW=IFRMIN,IFRMAX IF(IOFILE.EQ.'NO')THEN READ(IRD2,7382,END=7383)IJUNK 7382 FORMAT(A1) ELSE IF(IOFILE.EQ.'YES')THEN NUMCHA=-1 CALL DPREFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 IA,NUMCHA, 1 ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) ENDIF C IF(IERROR.EQ.'YES')GOTO8800 IF(IA(1).EQ.'E'.AND.IA(2).EQ.'O'.AND.IA(3).EQ.'F'.AND. 1 NUMCHA.EQ.3)GOTO7383 GOTO7380 C 7383 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7384) 7384 FORMAT('***** ERROR IN SERIAL READ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7385) 7385 FORMAT(' END OF FILE ENCOUNTERED WHILE SKIPPING ', 1 'HEADER LINES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7387) 7387 FORMAT(' NOTE SKIP AND ROW LIMITS SETTINGS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7388)ISKIP,IFROW1,IFROW2 7388 FORMAT(' ISKIP,IFROW1,IFROW2 = ',3I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8800 C 7380 CONTINUE 7389 CONTINUE C C ************************ C ** STEP 10-- ** C ** READ IN THE DATA ** C ************************ C ISTEPN='10' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7210)NUME 7210 FORMAT('NUME = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7211)IRD,IRD2 7211 FORMAT('IRD,IRD2 = ',I8,I8) CALL DPWRST('XXX','BUG ') ENDIF C DO7260I=1,MAXRCL ISTOR1(I)=' ' ISTOR2(I)=' ' ISTOR3(I)=' ' IB(I)=' ' 7260 CONTINUE C IF(NUME.GT.0)THEN DO7300I=1,NUME IEN(I)=0 7300 CONTINUE ENDIF C MINCO2=1 MAXCO2=NUMRCM IF(IRD2.EQ.IRD)MAXCO2=80 IFCOL3=IFCOL1 IFCOL4=IFCOL2 C THE FOLLOWING 2 LINES WERE INSERTED FEBRUARY 1988 C TO "TURN OFF" THE COLUMN LIMITS IF READING FROM A NON-FILE C (THAT IS, IF READING FROM THE TERMINAL OR WITHIN A MACRO). IF(IOFILE.EQ.'NO')THEN IFCOL3=MINCO2 IFCOL4=MAXCO2 ENDIF IF(IRD2.EQ.IRD.AND.IFCOL4.GT.MAXCO2)IFCOL4=MAXCO2 C I=0 C IE2=0 IE3=0 C NUMLRD=0 IENDTY=1 IFRMIN=IFROW1+ISKIP IFRMAX=IFROW2 IF(IHOST1.EQ.'CDC'.AND.IFRMAX.GT.130000)IFRMAX=130000 CCCCC THE FOLLOWING LINE WAS INSERTED APRIL 1989 IF(IFRMAX.GE.IBILLI)IFRMAX=IBILLI IF(IFRMIN.GT.IFRMAX)GOTO7470 DO7400IFROW=IFRMIN,IFRMAX CALL DPREAL(IRD2,IFCOL3,IFCOL4,MINCO2,MAXCO2,X0,NUMDPL, 1 IXC,NXC, 1 ICASRE,IFUNC2,N2,MAXN2, 1 IMACRO,IMACNU,IMACCS, 1 IANSLC,IWIDTH,IREACS,ISTOR1,ISTOR2,IEND,NUMLRD, 1 IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 ICOMCH,ICOMSW,LINETY,IGRPAU, 1 IFCOLL,IFCOLU,ITYPE,NCOLS,NCALL,IREADL, 1 PREAMV,MAXRDV,MAXCHV, 1 IDECPT, 1 IB, 1 IERRFI,IBUGS2,ISUBRO,IERROR) CCCCC ICOMCH AND ICOMFFL ADDED TO ARGUMENT LIST MAY, 1990. CCCCC THE LINETY ARGUMENT ADDED ABOVE SEPTEMBER 1995 CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1995 IF(LINETY.EQ.'BLAN')GOTO7400 NUMLRD=NUMLRD+1 C IF(IERROR.EQ.'YES')GOTO8800 IF(IFROW.EQ.IFRMIN)THEN DO7425K=1,132 ISTOR3(K)=ISTOR2(K) 7425 CONTINUE GOTO7440 ENDIF IF(IEND.EQ.'YES')GOTO7480 GOTO7440 C 7440 CONTINUE IF(NUMDPL.LE.0)GOTO7468 DO7465ID=1,NUMDPL IE2=IE2+1 IE3=IE3+1 IF(IE2.GT.NUME)IE2=1 C 7450 CONTINUE IF(IE2.GT.1)GOTO7460 I=I+1 C IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7451) 7451 FORMAT('***** FROM THE MIDDLE OF DPSERI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7452)IFROW,IFRMIN,IFRMAX 7452 FORMAT('IFROW,IFRMIN,IFRMAX = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7453)I,ISUB(I),NUME 7453 FORMAT('I,ISUB(I),NUME = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7454)MAXN,MAXCOL,MAXCP1,MAXCP2 7454 FORMAT('MAXN,MAXCOL,MAXCP1,MAXCP2 = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7455)X0(1),X0(2),X0(3) 7455 FORMAT('X0(1),X0(2),X0(3) = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7456)IECOL2(1),IECOL2(2),IECOL2(3) 7456 FORMAT('IECOL2(1),IECOL2(2),IECOL2(3) = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7457)IEN(1),IEN(2),IEN(3) 7457 FORMAT('IEN(1),IEN(2),IEN(3) = ',3I8) CALL DPWRST('XXX','BUG ') ENDIF C IF(I.GT.MAXN)GOTO7480 IF(ISUB(I).EQ.1)GOTO7460 GOTO7450 C 7460 CONTINUE IE=IE2 Z0=X0(ID) ICOLVJ=IECOL2(IE) IJ=MAXN*(ICOLVJ-1)+I IF(ICOLVJ.LE.MAXCOL)V(IJ)=Z0 IF(ICOLVJ.EQ.MAXCP1)PRED(I)=Z0 IF(ICOLVJ.EQ.MAXCP2)RES(I)=Z0 IF(ICOLVJ.EQ.MAXCP3)YPLOT(I)=Z0 IF(ICOLVJ.EQ.MAXCP4)XPLOT(I)=Z0 IF(ICOLVJ.EQ.MAXCP5)X2PLOT(I)=Z0 IF(ICOLVJ.EQ.MAXCP6)TAGPLO(I)=Z0 IEN(IE)=I C IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI')THEN WRITE(ICOUT,7461)IE,Z0,MAXN,ICOLVJ,I,IJ 7461 FORMAT('IE,Z0,MAXN,ICOLVJ,I,IJ = ',I8,E15.7,I8,I8,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7462)MAXCOL,MAXCP1,MAXCP2 7462 FORMAT('MAXCOL,MAXCP1,MAXCP2 = ',I8,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7463)IEN(IE) 7463 FORMAT('IEN(IE) = ',I8) CALL DPWRST('XXX','BUG ') ENDIF C 7465 CONTINUE NUMVRD=IE3 IF(NUME.LE.IE3)NUMVRD=NUME GOTO7469 7468 CONTINUE NUMVRD=IE2-1 GOTO7469 7469 CONTINUE C 7400 CONTINUE 7470 CONTINUE C IENDTY=2 GOTO7490 7480 CONTINUE IENDTY=1 NUMLRD=NUMLRD-1 GOTO7490 7490 CONTINUE C C ***************************** C ** STEP 11-- ** C ** UPDATE THE NAME TABLE ** C ***************************** C ISTEPN='11' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMVRD.GT.0)THEN DO7610IE=1,NUMVRD N=IEN(IE) ICOLVJ=IECOL2(IE) DO7620J=1,NUMNAM IF(IUSE(J).EQ.'V'.AND.IVALUE(J).EQ.ICOLVJ)GOTO7625 GOTO7620 7625 CONTINUE IUSE(J)='V' IVALUE(J)=ICOLVJ IF(N.GT.IN(J))IN(J)=N IVSTAR(J)=MAXN*(ICOLVJ-1)+1 IVSTOP(J)=MAXN*(ICOLVJ-1)+N 7620 CONTINUE 7610 CONTINUE ENDIF C NUMVRP=NUMVRD+1 IF(NUMVRP.LE.NUME)THEN DO7650IE=NUMVRP,NUME IEREV=NUME-IE+NUMVRP IF(IECASE(IEREV).EQ.'NEW')THEN INAM=NUMNAM IHNAME(INAM)=' ' IHNAM2(INAM)=' ' IUSE(INAM)=' ' IVALUE(INAM)=0 IN(INAM)=0 NUMNAM=NUMNAM-1 NUMCOL=NUMCOL-1 ENDIF 7650 CONTINUE ENDIF GOTO7900 C 7900 CONTINUE C C ************************************* C ** STEP 12-- ** C ** WRITE OUT SUMMARY INFORMATION ** C ** ABOUT THE FILE THAT WAS READ ** C ************************************* C ISTEPN='12' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8100) 8100 FORMAT('INPUT DATA FILE SUMMARY INFORMATION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8101)IRD2 8101 FORMAT('INPUT UNIT DEVICE NUMBER = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8102)IFCOL3,IFCOL4 8102 FORMAT('INPUT FILE COLUMN LIMITS = ',I8,4X,I8) CALL DPWRST('XXX','BUG ') IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI')THEN WRITE(ICOUT,1111)IFROW2,INTINF 1111 FORMAT('IFROW2,INTINF = ',I11,2X,I11) CALL DPWRST('XXX','BUG ') ENDIF IF(IFROW2.EQ.INTINF)THEN WRITE(ICOUT,8103)IFROW1 8103 FORMAT('INPUT FILE ROW LIMITS = ',I8,4X,'INFINITY') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8104)IFROW1,IFROW2 8104 FORMAT('INPUT FILE ROW LIMITS = ',I8,4X,I8) CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,8105)ISKIP 8105 FORMAT('NUMBER OF HEADER LINES SKIPPED = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8106)NUMLRD 8106 FORMAT('NUMBER OF DATA LINES READ = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8107)NUMVRD 8107 FORMAT('NUMBER OF VARIABLES READ = ',I8) CALL DPWRST('XXX','BUG ') C IFRST=IFCOL3 IF(IFRST+240-1.GE.IFCOL4)THEN ILAST=IFCOL4 ELSE ILAST=IFRST+240-1 ENDIF C WRITE(ICOUT,8111) 8111 FORMAT('THE SCANNED REGION OF THE FIRST DATA LINE READ = ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8112)(ISTOR3(J),J=IFRST,ILAST) 8112 FORMAT(240A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8113) 8113 FORMAT('THE SCANNED REGION OF THE LAST DATA LINE READ = ') CALL DPWRST('XXX','BUG ') IF(IENDTY.EQ.1)THEN WRITE(ICOUT,8114)(ISTOR1(J),J=IFRST,ILAST) CALL DPWRST('XXX','BUG ') ELSEIF(IENDTY.EQ.2)THEN WRITE(ICOUT,8114)(ISTOR2(J),J=IFRST,ILAST) CALL DPWRST('XXX','BUG ') ENDIF 8114 FORMAT(240A1) ENDIF C C ********************************************* C ** STEP 13-- ** C ** PRINT OUT SUMMARY INFORMATION ** C ** ABOUT THE VARAIBLES THAT WERE READ IN ** C ********************************************* C IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8211) 8211 FORMAT('VARIABLE COLUMN OBS/VARIABLE') CALL DPWRST('XXX','BUG ') C DO8200IE=1,NUME IH1=JENAM1(IE) IH2=JENAM2(IE) DO8300I=1,NUMNAM I2=I IF(IH1.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I))THEN WRITE(ICOUT,8311)IH1,IH2,IVALUE(I2),IN(I2) 8311 FORMAT(A4,A4,1X,I8,5X,I8) CALL DPWRST('XXX','BUG ') ENDIF 8300 CONTINUE 8200 CONTINUE ENDIF C C *************************************** C ** STEP 88-- ** C ** FOR THE FILE CASE, ** C ** CLOSE THE FILE. ** C *************************************** C 8800 CONTINUE ISTEPN='88' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI')THEN CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) WRITE(ICOUT,8803)IOFILE,ICURST,IREARW 8803 FORMAT('IOFILE,ICURST,IREARW = ',A4,A12,A4) CALL DPWRST('XXX','BUG ') ENDIF C IF(IOFILE.EQ.'YES'.AND.IREACS.EQ.'OPEN')THEN IENDFI='OFF' IREWIN='ON' IF(IREARW.EQ.'ON')THEN CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 IENDFI,IREWIN,ISUBN0,IERRFI, 1 IBUGS2,ISUBRO,IERROR) IREACS='CLOSED' ENDIF ENDIF C C ****************************************** C ** STEP 89-- ** C ** IF THE MACRO STATUS IS OPEN ** C ** THEN CHANGE IDEV FROM READ TO MACR ** C ****************************************** C 8900 CONTINUE CCCCC IF(IMACST.EQ.'OPFI')IDEV='MACR' CCCCC IF(IMACCS.EQ.'OPEN')IDEV='MACR' C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'SERI')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSERI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFROW1,IFROW2,ICASRE 9012 FORMAT('IFROW1,IFROW2,ICASRE = ',2I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IFCOL1,IFCOL2 9013 FORMAT('IFCOL1,IFCOL2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ISKIP,INTINF,IBUGS2,IBUGQ 9014 FORMAT('ISKIP,INTINF,IBUGS2,IBUGQ = ',I8,I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IFOUND,IERROR 9015 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)IMACRO,IMACNU,IMACCS 9016 FORMAT('IMACRO,IMACNU,IMACCS = ',A4,I8,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)IRD,IRD2 9017 FORMAT('IRD,IRD2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)IOSW,IOFILE,IOTERM 9018 FORMAT('IOSW,IOFILE,IOTERM = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)IBUGS2,ISUBRO,IERROR 9019 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)IOUNIT 9021 FORMAT('IOUNIT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)IFILE 9022 FORMAT('IFILE = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9023)ISTAT 9023 FORMAT('ISTAT = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9024)IFORM 9024 FORMAT('IFORM = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9025)IACCES 9025 FORMAT('IACCES = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9026)IPROT 9026 FORMAT('IPROT = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9027)ICURST 9027 FORMAT('ICURST = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9028)IENDFI 9028 FORMAT('IENDFI = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9029)IREWIN 9029 FORMAT('IREWIN = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9031)ISUBN0 9031 FORMAT('ISUBN0 = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9032)IERRFI 9032 FORMAT('IERRFI = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9071)IREARW 9071 FORMAT('IREARW = ',A4) CALL DPWRST('XXX','BUG ') ENDIF C RETURN END SUBROUTINE DPSESB(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE A SEASONAL SUBSERIES PLOT C (USED IN TIME SERIES TO IDENTIFY SEASONALITY) 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/2 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 ISUBRO CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASQ CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(MAXOBV) DIMENSION X1(MAXOBV) DIMENSION YTEMP(MAXOBV) INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),Y1(1)) EQUIVALENCE (GARBAG(IGARB2),X1(1)) EQUIVALENCE (GARBAG(IGARB3),YTEMP(1)) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C ISUBN1='DPSE' ISUBN2='SB ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=2 MINN2=3 C ICOLV2=0 C IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'SESB')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSESB--') 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)MAXCOL 54 FORMAT('MAXCOL = ',I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************************* C ** TREAT THE SEASONAL SUBSERIES PLOT ** C ******************************************* C C ******************************************* C ** STEP 1-- ** C ** SEARCH FOR SEASONAL SUBSERIES PLOT ** C ******************************************* C ISTEPN='11' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SESB') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASPL='SESB' IF(NUMARG.GE.2.AND. 1ICOM.EQ.'SEAS'.AND.IHARG(1).EQ.'SUBS'.AND.IHARG(2).EQ.'PLOT') 1GOTO111 C ICASPL=' ' IFOUND='NO' GOTO9000 C 111 CONTINUE ILASTC=2 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 180 CONTINUE IFOUND='YES' GOTO190 C 190 CONTINUE C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SESB') 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 IF(ICASPL.EQ.'SESB')GOTO270 C 260 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,261) 261 FORMAT('***** INTERNAL ERROR IN DPSESB') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,262) 262 FORMAT(' AT BRANCH POINT 261--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,263) 263 FORMAT(' ICASPL NOT EQUAL TO SESB') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,266)ICASPL 266 FORMAT(' ICASPL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,267) 267 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,268)(IANS(I),I=1,MIN(80,IWIDTH)) 268 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 270 CONTINUE MAXV2=1 GOTO290 C 290 CONTINUE C C ******************************************** C ** STEP 11-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='11' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SESB') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(1) IHLEF2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) C C ****************************************************** C ** STEP 12-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS ** C ** (NLEFT) FOR THE RESPONSE VARIABLE IS POSITIVE. ** C ****************************************************** C ISTEPN='12' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SESB') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO1290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** ERROR IN DPSESB--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212)IHLEFT,IHLEF2 1212 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS ', 1'IN VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1213) 1213 FORMAT(' (FOR WHICH A SEASONAL SUBSERIES PLOT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1214) 1214 FORMAT(' IS TO BE GENERATED)') 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) 1217 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1218)(IANS(I),I=1,MIN(80,IWIDTH)) 1218 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1290 CONTINUE C C ***************************************** C ** STEP 21-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='21' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SESB') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO2190 DO2100J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO2110 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO2110 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO2120 2100 CONTINUE GOTO2190 2110 CONTINUE ICASQ='SUBS' ILOCQ=J1 GOTO2190 2120 CONTINUE ICASQ='FOR' ILOCQ=J1 GOTO2190 2190 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'SESB')GOTO2195 WRITE(ICOUT,2191)NUMARG,ILOCQ 2191 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 2195 CONTINUE C C *********************************************** C ** STEP 22-- ** C ** CHECK FOR A VALID NUMBER ** C ** OF VARIABLES ** C ** (EXACTLY 1 ** C ** FOR A SEASONAL SUBSERIES PLOT). ** C *********************************************** C ISTEPN='22' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SESB') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IF(1.LE.NUMV2.AND.NUMV2.LE.MAXV2)GOTO2209 GOTO2250 C 2209 CONTINUE IF(NUMV2.LE.1)GOTO2290 C 2250 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2251) 2251 FORMAT('***** ERROR IN DPSESB--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2252) 2252 FORMAT(' FOR A SEASONAL SUBSERIES PLOT,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2253) 2253 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2254) 2254 FORMAT(' MUST BE EXACTLY 1 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2255) 2255 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2256) 2256 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2257)NUMV2 2257 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2258) 2258 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2259)(IANS(I),I=1,MIN(80,IWIDTH)) 2259 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 2290 CONTINUE C C ********************************************** C ** STEP 31-- ** C ** FORM THE VARIABLE Y1(.) ** C ** WHICH WILL CONTAIN THE VARIABLE; ** C ** FORM THIS VARIABLE BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C ********************************************** C ISTEPN='31' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SESB') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASQ.EQ.'FULL')GOTO3110 IF(ICASQ.EQ.'SUBS')GOTO3120 IF(ICASQ.EQ.'FOR')GOTO3130 C 3110 CONTINUE DO3115I=1,NLEFT ISUB(I)=1 3115 CONTINUE NQ=NLEFT GOTO3150 C 3120 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO3150 C 3130 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO3150 C 3150 CONTINUE IF(NQ.GE.MINN2)GOTO3160 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3151) 3151 FORMAT('***** ERROR IN DPSESB--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3152) 3152 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3153)IHLEFT,IHLEF2 3153 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3154) 3154 FORMAT(' (FOR WHICH AN AUTO OR CROSS-PERIODOGRAM ', 1'ANALYSIS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3155) 3155 FORMAT(' IS TO BE FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3156)MINN2 3156 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3157) 3157 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3158) 3158 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3159)(IANS(I),I=1,MIN(80,IWIDTH)) 3159 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3160 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO3170I=1,IMAX IF(ISUB(I).EQ.0)GOTO3170 J=J+1 C IJ=MAXN*(ICOLL-1)+I IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SESB') 1WRITE(ICOUT,3166)I,J,IJ,ICOLL,MAXCOL,MAXN,V(IJ) 3166 FORMAT('I,J,IJ,ICOLL,MAXCOL,MAXN,V(IJ) = ',6I8,E15.7) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SESB') 1CALL DPWRST('XXX','BUG ') 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) CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1992 CCCCC IF(ICOLL.EQ.MAXCP31)Y1(J)=TAGPLO(I) IF(ICOLL.EQ.MAXCP6)Y1(J)=TAGPLO(I) C 3170 CONTINUE NS=J C C *********************************************** C ** STEP 3.2A-- ** C ** CHECK FOR PARAMETER PERIOD ** C *********************************************** C IHP='PERI' IHP2='OD ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN PERIOD=12.0 ELSE PERIOD=VALUE(ILOCP) ENDIF C C *********************************************** C ** STEP 3.2B-- ** C ** CHECK FOR PARAMETER START ** C *********************************************** C IHP='STAR' IHP2='T ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN ISTART=1 ELSE ISTART=INT(VALUE(ILOCP)+0.5) ENDIF IF(ISTART.LT.1)ISTART=1 C C C ******************************************************* C ** STEP 41-- ** C ** FORM THE VERTICAL AND HORIZONTALAXIS ** C ** VARIABLES (Y(.) AND X(.), RESPECTIVELY)FOR THE ** C ** PLOT. FORM THE CURVE DESIGNATION VARIABLED(.) . ** C ** THIS WILL BE ALL ONES. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES(NPLOTV). ** C ******************************************************* C ISTEPN='41' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SESB') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPSES2(Y1,NS,X1,YTEMP,ICASPL,MAXN, 1Y,X,D,NPLOTP,NPLOTV, 1PERIOD,ISTART, 1IBUGG3,ISUBRO,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'SESB')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSESB--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') IF(NPLOTP.LE.0)GOTO9090 DO9015I=1,NPLOTP WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSES2(Y1,N,X1,YTEMP,ICASPL,MAXN, 1Y,X,D,NPLOTP,NPLOTV, 1PERIOD,ISTART, 1IBUGG3,ISUBRO,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE A SEASONAL SUBSERIES PLOT C INPUT ARGUMENTS--Y1 = THE SINGLE PRECISION VECTOR OF C (UNSORTED) OBSERVATIONS C FOR THE FIRST VARIABLE. C N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C CAUTION--THE INPUT VARIABLE Y1(.) WILL BE CHANGED HEREIN C (IT WILL BE SORTED) 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/2 C ORIGINAL VERSION--FEBRUARY 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IBUGG3 CHARACTER*4 IWRITE CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION Y1(*) DIMENSION X1(*) DIMENSION YTEMP(*) C DIMENSION Y(*) DIMENSION X(*) DIMENSION D(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPSE' ISUBN2='S2 ' C IERROR='NO' C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'SES2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSES2--') 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)N,ICASPL,MAXN 53 FORMAT('N,ICASPL,MAXN = ',I8,2X,A4,I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Y1(I) 56 FORMAT('I, Y1(I), = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.GE.3)GOTO119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN DPSES2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' MUST BE AT LEAST 2;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114)N 114 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 119 CONTINUE C HOLD=Y1(1) DO120I=1,N IF(Y1(I).NE.HOLD)GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** ERROR IN DPSES2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,122) 122 FORMAT(' ALL ELEMENTS IN Y1 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123)HOLD 123 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 129 CONTINUE C C ****************************************************** C ** STEP 12-- ** C ** COMPUTE COORDINATES FOR SEASONAL SUBSERIES PLOT ** C ** CREATE A SEASONAL INDEX VARIABLE FIRST ** C ****************************************************** C C IPER=INT(PERIOD+0.5) IF(IPER.LT.1)IPER=12 C DO1210I=1,N K=I+ISTART-1 X1(I)=MOD(K-1,IPER) + 1 1210 CONTINUE C C ****************************************************** C ** STEP 13-- ** C ** FOR EACH VALUE OF THE PERIOD, COMPUTE ** C ** 1) THE NUMER OF ELEMENTS ** C ** 2) THE MEAN OF THE ELEMENTS ** C ****************************************************** C IWRITE='OFF' XCOOR=0.0 NPLOTP=0 DO1300J=1,IPER NELEM=0 DO1310I=1,N IF(X1(I).EQ.J)THEN NELEM=NELEM+1 YTEMP(NELEM)=Y1(I) ENDIF 1310 CONTINUE IF(NELEM.LT.1)GOTO1300 CALL MEAN(YTEMP,NELEM,IWRITE,YMEAN,IBUGG3,IERROR) DO1320L=1,NELEM XCOOR=XCOOR+1.0 IF(L.EQ.1)XCSAVE=XCOOR NPLOTP=NPLOTP+1 X(NPLOTP)=XCOOR Y(NPLOTP)=YTEMP(L) D(NPLOTP)=REAL(2*J-1) 1320 CONTINUE NPLOTP=NPLOTP+1 X(NPLOTP)=XCSAVE Y(NPLOTP)=YMEAN D(NPLOTP)=REAL(2*J) NPLOTP=NPLOTP+1 X(NPLOTP)=XCOOR Y(NPLOTP)=YMEAN D(NPLOTP)=REAL(2*J) XCOOR=XCOOR+1.0 1300 CONTINUE C NPLOTV=2 GOTO9000 C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'SES2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSES2--') 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)N,ICASPL,MAXN 9013 FORMAT('N,ICASPL,MAXN = ',I8,2X,A4,I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N WRITE(ICOUT,9016)I,Y1(I) 9016 FORMAT('I, Y1(I), = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9021)NPLOTP,NPLOTV 9021 FORMAT('NPLOTP,NPLOTV = ',2I8) CALL DPWRST('XXX','BUG ') DO9022I=1,NPLOTP WRITE(ICOUT,9023)I,Y(I),X(I),D(I) 9023 FORMAT('I,Y(I),X(I),D(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 9022 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSETH(IHARG,IARGT,IARG,ARG,NUMARG,PDEFTH, 1MAXSEG,PSEGTH,IFOUND,IERROR) C C PURPOSE--DEFINE THE THICKNESS FOR A SEGMENT. C THE THICKNESS FOR SEGMENT I WILL BE PLACED C IN THE I-TH ELEMENT OF THE REAL C VECTOR PSEGTH(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --ARG C --NUMARG C --PDEFTH C --MAXSEG C OUTPUT ARGUMENTS--PSEGTH (A REAL VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C THICKNESS FOR SEGMENT I. 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--89/2 C ORIGINAL VERSION--JANUARY 1989. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT REAL PDEFTH REAL PSEGTH CHARACTER*4 IFOUND CHARACTER*4 IERROR C REAL PHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) DIMENSION ARG(*) C DIMENSION PSEGTH(*) 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.'THIC')GOTO1110 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'THIC')GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.1)GOTO1120 IF(IHARG(2).EQ.'ON')GOTO1120 IF(IHARG(2).EQ.'OFF')GOTO1120 IF(IHARG(2).EQ.'AUTO')GOTO1120 IF(IHARG(2).EQ.'DEFA')GOTO1120 GOTO1125 C 1120 CONTINUE PHOLD=PDEFTH GOTO1130 C 1125 CONTINUE PHOLD=ARG(2) GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXSEG PSEGTH(I)=PHOLD 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1149 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)PSEGTH(I) 1136 FORMAT('ALL SEGMENT THICKNESSS HAVE JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') 1149 CONTINUE GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPSETH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE SEGMENT ... THICKNESS COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE SEGMENT IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' SEGMENT 3 THICKNESS 0.3') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXSEG)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPSETH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE SEGMENT ... THICKNESS COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF SEGMENTS MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXSEG 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'SEGMENT.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.2)GOTO1170 IF(IHARG(3).EQ.'ON')GOTO1170 IF(IHARG(3).EQ.'OFF')GOTO1170 IF(IHARG(3).EQ.'AUTO')GOTO1170 IF(IHARG(3).EQ.'DEFA')GOTO1170 GOTO1175 C 1170 CONTINUE PHOLD=PDEFTH GOTO1180 C 1175 CONTINUE PHOLD=ARG(3) GOTO1180 C 1180 CONTINUE IFOUND='YES' PSEGTH(I)=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,PSEGTH(I) 1186 FORMAT('THE THICKNESS FOR SEGMENT ',I8, 1' HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPSHI3(IANS,IWIDTH,ITARWD,IANS2,IWIDT2) C C NOTE--THIS SUBROUTINE IS IDENTICAL TO THE DPSHI2 SUBROUTINE C AND HAS BEEN CREATED TO ACHIEVE STORAGE ECONOMY IN MAPPING. C C PURPOSE--SEARCH THE VECTOR IANS(.) FOR THE C ITARWD-TH WORD. FORM THE VECTOR C IANS2(.) WHICH IS THE SAME AS IANS(.) C EXCEPT ALL CHARACTERS UP TO THE BEGINNING C OF THE ITARWD-TH WORD HAS BEEN OMITTED. C THE VECTOR IANS2(.) THUS BEGINS C WITH THE ITARWD-TH WORD. C INPUT ARGUMENTS--IANS (A HOLLERITH VECTOR WHOSE C I-TH ELEMENT CONTAINS THE C I-TH CHARACTER OF THE C ORIGINAL INPUT COMMAND LINE. C --IWIDTH (AN INTEGER VARIABLE WHICH C CONTAINS THE NUMBER OF CHARACTERS C IN THE ORIGINAL COMMAND LINE. C --ITARWD (AN INTEGER VARIABLE WHICH C CONTAINS THE NUMBER OF THE WORD C WHICH IS BEING SEARCHED FOR. C OUTPUT ARGUMENTS--IANS2 (A HOLLERITH VECTOR WHOSE C I-TH ELEMENT CONTAINS THE C I-TH CHARACTER OF THE C SHIFTED COMMAND LINE. C --IWIDT2 (AN INTEGER VARIABLE WHICH C CONTAINS THE NUMBER OF CHARACTERS C IN THE SHIFTED COMMAND LINE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--NOVEMBER 1980. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IANS CHARACTER*4 IANS2 C C--------------------------------------------------------------------- C DIMENSION IANS(*) DIMENSION IANS2(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C ********************************** C ** STEP 1-- ** C ** SEARCH FOR THE FIRST BLANK ** C ********************************** C DO100I=1,IWIDTH I2=I IF(IANS(I).EQ.' ')GOTO190 100 CONTINUE I2=IWIDTH+1 GOTO190 190 CONTINUE C C ************************************* C ** STEP 2-- ** C ** SEARCH FOR THE NEXT NON-BLANK ** C ************************************* C IMIN=I2+1 IMAX=IWIDTH IF(IMIN.GT.IMAX)GOTO250 DO200I=IMIN,IMAX I3=I IF(IANS(I).NE.' ')GOTO290 200 CONTINUE I3=IWIDTH+1 GOTO290 250 CONTINUE I3=IWIDTH+1 GOTO290 290 CONTINUE C C *********************************** C ** STEP 3-- ** C ** COMPUTE IANS2(.) AND IWIDT2 ** C *********************************** C J=0 IMIN=I3 IMAX=IWIDTH IF(IMIN.GT.IMAX)GOTO350 DO300I=IMIN,IMAX J=J+1 IANS2(J)=IANS(I) 300 CONTINUE 350 CONTINUE IWIDT2=J C 900 CONTINUE RETURN END SUBROUTINE DPSHPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IANGLU,MAXNPP, 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--FORM A SHIFT PLOT C PLOT Y(Q) - X(Q) VERSUS X(Q) C WHERE X(Q) IS THE QTH QUANTILE OF X AND Y(Q) C IS THE CORRESPONDING QTH QUANTILE OF Y. C SUPPORT TWO VARIATIONS. IF THREE VARIABLES ARE C SPECIFIED, THEN THE THIRD VARIABLE ARE THE QUANTILES C THAT ARE PLOTTED. IF ONLY TWO VARIABLES ARE C SPECIFIED, THE COMPUTE THE QUANTILES CORRESPONDING C TO X VALUES. THE X IS THE DATA FOR A CONTROL GROUP C AND Y IS THE DATA FROM AN EXPERIMENTAL GROUP. C REFERENCE--"INTRODUCTION TO ROBUST ESTIMATION AND HYPOTHESIS C TESTING", RAND R. WILCOX, ACADEMIC PRESS, 1997. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2003/2 C ORIGINAL VERSION--FEBRUARY 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IANGLU CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ICASEQ C CHARACTER*4 IHRI11 CHARACTER*4 IHRI12 CHARACTER*4 IHRI21 CHARACTER*4 IHRI22 CHARACTER*4 IHRI31 CHARACTER*4 IHRI32 CHARACTER*4 IHRI41 CHARACTER*4 IHRI42 CHARACTER*4 IHRIX1 CHARACTER*4 IHRIX2 C CHARACTER*4 IERRO4 C CHARACTER*4 ICTAR1 CHARACTER*4 ICTAR2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' DIMENSION Y1(MAXOBV) DIMENSION Y2(MAXOBV) DIMENSION Y3(MAXOBV) DIMENSION Y4(MAXOBV) DIMENSION XD(MAXOBV) DIMENSION YD(MAXOBV) C INCLUDE 'DPCOZZ.INC' DIMENSION YLARGE(MAXOBV) DIMENSION YSMALL(MAXOBV) EQUIVALENCE (GARBAG(IGARB1),Y1(1)) EQUIVALENCE (GARBAG(IGARB2),Y2(1)) EQUIVALENCE (GARBAG(IGARB3),Y3(1)) EQUIVALENCE (GARBAG(IGARB4),Y4(1)) EQUIVALENCE (GARBAG(IGARB5),XD(1)) EQUIVALENCE (GARBAG(IGARB6),YD(1)) EQUIVALENCE (GARBAG(IGARB7),YLARGE(1)) EQUIVALENCE (GARBAG(IGARB8),YSMALL(1)) C C-----COMMON---------------------------------------------------------- C 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 ISUBN1='DPSH' ISUBN2='PL ' C IFOUND='NO' IERROR='NO' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MINN2=2 C IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'SHPL')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSHPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPLOTV,NPLOTP,NS 52 FORMAT('NPLOTV,NPLOTP,NS = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IANGLU,IBUGG2,IBUGG3,IBUGQ 54 FORMAT('IANGLU,IBUGG2,IBUGG3,IBUGQ = ', 1A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)ICASPL,MAXN 56 FORMAT('ICASPL,MAXN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,57)IFOUND,IERROR 57 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,58)MAXNPP 58 FORMAT('MAXNPP = ',I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************************* C ** TREAT THE SHIFT PLOT CASE ** C ******************************************* C C *************************** C ** STEP 11-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='11' IF(NUMARG.GE.1 .AND. IHARG(1).EQ.'PLOT')THEN ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE GOTO9000 ENDIF IFOUND='YES' ICASPL='SHPL' C C **************************************************** C ** STEP 12-- ** C ** CARRY OUT A GENERAL CHECK FOR THE ** C ** PROPER NUMBER OF INPUT ARGUMENTS ** C ** (IT SHOULD BE EXACTLY 2). ** C **************************************************** C ISTEPN='12' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SHPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=2 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ***************************************** C ** STEP 13-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='13' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SHPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO1390 DO1300J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO1310 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO1310 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO1320 1300 CONTINUE GOTO1390 1310 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO1390 1320 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO1390 1390 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'SHPL')GOTO1395 WRITE(ICOUT,1391)ICASEQ,NUMARG,ILOCQ 1391 FORMAT('ICASEQ,NUMARG,ILOCQ = ',A4,2X,2I8) CALL DPWRST('XXX','BUG ') 1395 CONTINUE C C **************************************************** C ** STEP 14-- ** C ** CARRY OUT A SPECIFIC CHECK FOR THE ** C ** PROPER NUMBER OF INPUT ARGUMENTS ** C ** (IT SHOULD BE EITHER 2 OR 3. ** C **************************************************** C ISTEPN='14' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SHPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMVAR=ILOCQ-1 IF(NUMVAR.EQ.2 .OR. NUMVAR.EQ.3)GOTO1490 C 1410 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1411) 1411 FORMAT('***** ERROR IN DPSHPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1412) 1412 FORMAT(' FOR A SHIFT PLOT, THE NUMBER OF VARIABLES MUST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1419) 1419 FORMAT(' BE EITHER 2 OR 3; SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1422)NUMVAR 1422 FORMAT(' THE SPECIFIED NUMBER OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1423) 1423 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,1424)(IANS(I),I=1,MIN(IWIDTH,80)) 1424 FORMAT(' ',80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 C 1490 CONTINUE C C **************************************************** C ** STEP 15-- * C ** EXAMINE THE VARIABLES-- * C ** HAS EACH VARIABLE * C ** ALREADY BEEN DEFINED? * C ** NOTE THAT ILISR1, ILISR2, * C ** IS THE LINE IN THE TABLE * C ** OF THE FIRST, SECOND VARIABLE * C ** RESPECTIVELY. * C ** NOTE THAT ICOLR1, ICOLR2, * C ** IS THE DATA COLUMN (1 TO 10+6) * C ** OF THE FIRST, SECOND VARIABLE * C ** RESPECTIVELY. * C **************************************************** C ISTEPN='15' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SHPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICTAR1='FIRS' ICTAR2='T ' ILOCR1=1 IHRI11=IHARG(ILOCR1) IHRI12=IHARG2(ILOCR1) IHRIX1=IHRI11 IHRIX2=IHRI12 DO1510I=1,NUMNAM I2=I IF(IHRI11.EQ.IHNAME(I).AND.IHRI12.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO1519 IF(IHRI11.EQ.IHNAME(I).AND.IHRI12.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO1560 1510 CONTINUE GOTO1570 1519 CONTINUE ILISR1=I2 ICOLR1=IVALUE(ILISR1) NIRIG1=IN(ILISR1) C ICTAR1='SECO' ICTAR2='ND ' ILOCR2=2 IHRI21=IHARG(ILOCR2) IHRI22=IHARG2(ILOCR2) IHRIX1=IHRI21 IHRIX2=IHRI22 DO1520I=1,NUMNAM I2=I IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO1529 IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO1560 1520 CONTINUE GOTO1570 1529 CONTINUE ILISR2=I2 ICOLR2=IVALUE(ILISR2) NIRIG2=IN(ILISR2) C IF(NUMVAR.EQ.3)THEN ICTAR1='THIR' ICTAR2='D ' ILOCR3=3 IHRI31=IHARG(ILOCR3) IHRI32=IHARG2(ILOCR3) IHRIX1=IHRI31 IHRIX2=IHRI22 DO1530I=1,NUMNAM I2=I IF(IHRI31.EQ.IHNAME(I).AND.IHRI32.EQ.IHNAM2(I).AND. 1 IUSE(I).EQ.'V')GOTO1539 IF(IHRI31.EQ.IHNAME(I).AND.IHRI32.EQ.IHNAM2(I).AND. 1 IUSE(I).EQ.'P')GOTO1560 1530 CONTINUE GOTO1570 1539 CONTINUE ILISR3=I2 ICOLR3=IVALUE(ILISR3) NIRIG3=IN(ILISR3) ENDIF GOTO1590 C 1560 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1561) 1561 FORMAT('***** ERROR IN DPSHPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1562)ICTAR1,ICTAR2,IHRIX1,IHRIX2 1562 FORMAT(' THE SPECIFIED ',A4,A4,' ARGUMENT (',A4,A4,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1565) 1565 FORMAT(' WAS FOUND IN THE INTERNAL NAME LIST, BUT AS A') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1567) 1567 FORMAT(' PARAMETER AND NOT AS A VARIABLE AS IT SHOULD BE ', 1 'HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1568) 1568 FORMAT(' THE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1569)(IANS(I),I=1,MIN(IWIDTH,80)) 1569 FORMAT(80A1) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1570 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1571) 1571 FORMAT('***** ERROR IN DPSHPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1572)ICTAR1,ICTAR2,IHRIX1,IHRIX2 1572 FORMAT(' THE SPECIFIED ',A4,A4,' ARGUMENT (',A4,A4,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1575) 1575 FORMAT(' WAS NOT FOUND IN THE INTERNAL NAME LIST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1576) 1576 FORMAT(' OF AVAILABLE VARIABLE NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1578) 1578 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,1579)(IANS(I),I=1,MIN(IWIDTH,80)) 1579 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 C 1590 CONTINUE C C ********************************************* C ** STEP 32-- ** C ** FORM THE VECTOR ISUB(.) ** C ** DEPENDING ON THE TYPE OF CASE ** C ** FOR THE QUALIFIER. ** C ** BRANCH TO THE PROPER CASE. ** C ********************************************* C ISTEPN='32' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SHPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NLOCAL=NIRIG1 IF(NIRIG2.GT.NIRIG1)NLOCAL=NIRIG2 IF(NUMVAR.EQ.3 .AND. NIRIG3.GT.NLOCAL)NLOCAL=NIRIG3 C IF(ICASEQ.EQ.'FULL')GOTO3210 IF(ICASEQ.EQ.'SUBS')GOTO3220 IF(ICASEQ.EQ.'FOR')GOTO3230 C 3210 CONTINUE DO3215I=1,NLOCAL ISUB(I)=1 3215 CONTINUE NQ=NLOCAL GOTO3250 C 3220 CONTINUE NIOLD=NLOCAL CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4) NQ=NIOLD GOTO3250 C 3230 CONTINUE NIOLD=NLOCAL CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERRO4) NQ=NFOR GOTO3250 C 3250 CONTINUE IF(NQ.GE.MINN2)GOTO3290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3251) 3251 FORMAT('***** ERROR IN DPSHPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3252) 3252 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3254)IHRI11,IHRI12 3254 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3256) 3256 FORMAT(' (FOR WHICH A SHIFT PLOT IS TO BE FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3257)MINN2 3257 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3258)NQ 3258 FORMAT(' SUCH WAS NOT THE CASE HERE (NQ = ',I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3259) 3259 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,3260)(IANS(I),I=1,IWIDTH) 3260 FORMAT(' ',80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 C 3290 CONTINUE C C ********************************************** C ** STEP 33-- ** C ** FORM THE SUBSETTED VARIABLES ** C ** Y1(.) ** C ** Y2(.) ** C ** Y3(.) ** C ** CONTAINING ** C ** THE EXPERMIMENTAL GROUP VARIABLE ** C ** THE CONTROL GROUP VARIABLE ** C ** THE OPTIONAL QUANTILE VARIABLE ** C ** RESPECTIVELY. ** C ********************************************** C ISTEPN='33' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SHPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C J=0 IMAX=NIRIG1 IF(NQ.LT.NIRIG1)IMAX=NQ DO3310I=1,IMAX IF(ISUB(I).EQ.0)GOTO3310 J=J+1 IJ=MAXN*(ICOLR1-1)+I IF(ICOLR1.LE.MAXCOL)Y1(J)=V(IJ) IF(ICOLR1.EQ.MAXCP1)Y1(J)=PRED(I) IF(ICOLR1.EQ.MAXCP2)Y1(J)=RES(I) IF(ICOLR1.EQ.MAXCP3)Y1(J)=YPLOT(I) IF(ICOLR1.EQ.MAXCP4)Y1(J)=XPLOT(I) IF(ICOLR1.EQ.MAXCP5)Y1(J)=X2PLOT(I) IF(ICOLR1.EQ.MAXCP6)Y1(J)=TAGPLO(I) 3310 CONTINUE NS1=J C J=0 IMAX=NIRIG2 IF(NQ.LT.NIRIG2)IMAX=NQ DO3320I=1,IMAX IF(ISUB(I).EQ.0)GOTO3320 J=J+1 IJ=MAXN*(ICOLR2-1)+I IF(ICOLR2.LE.MAXCOL)Y2(J)=V(IJ) IF(ICOLR2.EQ.MAXCP1)Y2(J)=PRED(I) IF(ICOLR2.EQ.MAXCP2)Y2(J)=RES(I) IF(ICOLR2.EQ.MAXCP3)Y2(J)=YPLOT(I) IF(ICOLR2.EQ.MAXCP4)Y2(J)=XPLOT(I) IF(ICOLR2.EQ.MAXCP5)Y2(J)=X2PLOT(I) IF(ICOLR2.EQ.MAXCP6)Y2(J)=TAGPLO(I) 3320 CONTINUE NS2=J C IF(NUMVAR.EQ.3)THEN J=0 IMAX=NIRIG3 IF(NQ.LT.NIRIG3)IMAX=NQ DO3330I=1,IMAX IF(ISUB(I).EQ.0)GOTO3330 J=J+1 IJ=MAXN*(ICOLR3-1)+I IF(ICOLR3.LE.MAXCOL)Y3(J)=V(IJ) IF(ICOLR3.EQ.MAXCP1)Y3(J)=PRED(I) IF(ICOLR3.EQ.MAXCP2)Y3(J)=RES(I) IF(ICOLR3.EQ.MAXCP3)Y3(J)=YPLOT(I) IF(ICOLR3.EQ.MAXCP4)Y3(J)=XPLOT(I) IF(ICOLR3.EQ.MAXCP5)Y3(J)=X2PLOT(I) IF(ICOLR3.EQ.MAXCP6)Y3(J)=TAGPLO(I) 3330 CONTINUE NS3=J ENDIF C C ********************************************* C ** STEP 34-- ** C ** CHECK TO MAKE SURE THAT ** C ** AFTER SUBSETTING, EACH OF ** C ** THE 3 VARIABLES HAS AT LEAST ** C ** 2 POINTS (THE MINIMUM NEEDED ** C ** TO YIELD A PLOT). ** C ********************************************* C ISTEPN='34' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SHPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NS1.LT.MINN2)GOTO3450 IF(NS2.LT.MINN2)GOTO3450 IF(NUMVAR.EQ.3 .AND. NS3.LT.MINN2)GOTO3450 GOTO3490 C 3450 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3451) 3451 FORMAT('***** ERROR IN DPSHPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3452) 3452 FORMAT(' AFTER THE SPECIFIED SUBSETTING HAS BEEN DONE,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3454) 3454 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3456) 3456 FORMAT(' (FOR WHICH A SHIFT PLOT IS TO BE FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3457)MINN2 3457 FORMAT(' MUST BE ',I8,' OR LARGER; SUCH WAS NOT THE CASE ', 1 'HERE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3459)NS1,NS2,NS3 3459 FORMAT('(NS1, NS2, NS3 = ',3I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3460) 3460 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,3461)(IANS(I),I=1,MIN(IWIDTH,80)) 3461 FORMAT(' ',80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 C 3490 CONTINUE C C **************************************************** C ** STEP 41-- * C ** FORM THE VERTICAL AND HORIZONTAL AXIS * C ** VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR * C ** THE PLOT. * C ** FORM THE CURVE DESIGNATION VARIABLE D(.) . * C ** THIS WILL BE BOTH ONES FOR BOTH CASES * C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). * C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). * C **************************************************** C ISTEPN='41' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SHPL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPSHP2(Y1,NS1,Y2,NS2,Y3,NS3,NUMVAR,ICASPL,MAXN, 1Y,X,D,NPLOTP,NPLOTV, 1Y4,IQUAME,IQUASE, 1IBUGG3,ISUBRO,IERROR) C C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'SHPL')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSHPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ICASPL,MAXN,NUMVAR 9014 FORMAT('ICASPL,MAXN,NUMVAR = ',A4,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NIRIG1,NIRIG2,NIRIG3 9015 FORMAT('NIRIG1,NIRIG2,NIRIG3 = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NLOCAL,NQ,MINN2 9016 FORMAT('NLOCAL,NQ,MINN2 = ',3I8) CALL DPWRST('XXX','BUG ') IF(NPLOTP.LE.0)GOTO9029 DO9020I=1,NPLOTP WRITE(ICOUT,9021)I,Y(I),X(I),D(I) 9021 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9020 CONTINUE 9029 CONTINUE WRITE(ICOUT,9051)IHRI11,IHRI12 9051 FORMAT('IHRI11,IHRI12 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9052)IHRI21,IHRI22 9052 FORMAT('IHRI21,IHRI22 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9055)IHRI31,IHRI32 9055 FORMAT('IHRI31,IHRI32 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9053)NS1,NS2,NS 9053 FORMAT('NS1,NS2,NS3 = ',3I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPSHP2(Y,NY,X,NX,Z,NZ,NUMVAR,ICASPL,MAXN, 1Y2,X2,D2,N2,NPLOTV, 1YTEMP,IQUAME,IQUASE, 1IBUGG3,ISUBRO,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE A SHIFT PLOT. FOR THIS, C PLOT Y(Q) - X(Q) VERSUS X(Q) (THAT IS, THE C DIFFERENCE IN THE QUANTILES VERSUS THE QUANTILES). C WHERE X(Q) IS THE QTH QUANTILE OF X AND Y(Q) C IS THE CORRESPONDING QTH QUANTILE OF Y. C SUPPORT TWO VARIATIONS. IF THREE VARIABLES ARE C SPECIFIED, THEN THE THIRD VARIABLE ARE THE QUANTILES C THAT ARE PLOTTED. IF ONLY TWO VARIABLES ARE C SPECIFIED, THE COMPUTE THE QUANTILES CORRESPONDING C TO X VALUES. THE X IS THE DATA FOR A CONTROL GROUP C AND Y IS THE DATA FROM AN EXPERIMENTAL GROUP. C SIMILAR PURPOSE TO QUANTILE-QUANTILE OR TUKEY MEAN C DIFFERENCE PLOT. C TWO CASES: C 1) IF ONLY TWO VARIABLES, THEN COMPUTE THE QUANTILES C AT THE X POINTS. C 2) IF A THIRD VARIABLE PRESENT, THESE DEFINE THE C DESIRED QUANTILES. C REFERENCE--"INTRODUCTION TO ROBUST ESTIMATION AND HYPOTHESIS C TESTING", RAND R. WILCOX, ACADEMIC PRESS, 1997. 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/3 C ORIGINAL VERSION--FEBRUARY 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ICASE CHARACTER*4 ICASPL CHARACTER*4 IQUAME CHARACTER*4 IQUASE CHARACTER*4 IQUAM2 CHARACTER*4 IWRITE C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X(*) DIMENSION Z(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) C DIMENSION YTEMP(*) 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='DPSH' ISUBN2='P2 ' C IERROR='NO' C ICASE=ICASPL IQUAM2=IQUAME C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'SHP2')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSHP2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGG3,ISUBRO 52 FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,MAXN,NX,NPLOTV,NUMVAR 53 FORMAT('ICASPL,MAXN,NX,NPLOTV,NUMVAR = ',A4,2X,I8,I8,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)NY 60 FORMAT(' NY = ',I8) CALL DPWRST('XXX','BUG ') IF(NY.LE.0)GOTO63 DO61I=1,NY WRITE(ICOUT,62)I,Y(I) 62 FORMAT('I,Y(I) = ',I8,E12.5) CALL DPWRST('XXX','BUG ') 61 CONTINUE 63 CONTINUE WRITE(ICOUT,70)NX 70 FORMAT(' NX = ',I8) CALL DPWRST('XXX','BUG ') IF(NX.LE.0)GOTO73 DO71I=1,NX WRITE(ICOUT,72)I,X(I) 72 FORMAT('I,X(I) = ',I8,E12.5) CALL DPWRST('XXX','BUG ') 71 CONTINUE 73 CONTINUE WRITE(ICOUT,80)NZ 80 FORMAT(' NZ = ',I8) CALL DPWRST('XXX','BUG ') IF(NZ.LE.0)GOTO83 DO81I=1,NZ WRITE(ICOUT,72)I,Z(I) 82 FORMAT('I,X(I) = ',I8,E12.5) CALL DPWRST('XXX','BUG ') 81 CONTINUE 83 CONTINUE ENDIF C C ******************************************** C ** STEP 11-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(NUMVAR.EQ.3 .AND. NZ.LE.1)GOTO1110 IF(NY.LE.1.OR.NX.LE.1)GOTO1110 GOTO1119 C 1110 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) 1111 FORMAT('***** ERROR IN DPSHP2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) 1112 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113) 1113 FORMAT(' MUST BE AT LEAST 1;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1114)NY,NX 1114 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',2I6) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1119 CONTINUE C HOLD=Y(1) DO1130I=1,NY IF(Y(I).NE.HOLD)GOTO1139 1130 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1131) 1131 FORMAT('***** ERROR IN DPSHP2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1132) 1132 FORMAT(' ALL INPUT RESPONSE VARIABLE ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1133)HOLD 1133 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1139 CONTINUE C HOLD=X(1) DO1140I=1,NX IF(X(I).NE.HOLD)GOTO1149 1140 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPSHP2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' ALL INPUT RESPONSE VARIABLE ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143)HOLD 1143 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1149 CONTINUE C IF(NUMVAR.LT.3)GOTO1199 HOLD=Z(1) DO1150I=1,NZ IF(Z(I).NE.HOLD)GOTO1159 1150 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPSHP2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' ALL INPUT RESPONSE VARIABLE ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153)HOLD 1153 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1159 CONTINUE C DO1160I=1,NZ IF(Z(I).LT.0.0 .OR. Z(I).GT.1.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1161) 1161 FORMAT('***** ERROR IN DPSHP2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1162) 1162 FORMAT(' A SPECIFIED QUANTILE WAS OUTSIDE THE ALLOWABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1163) 1163 FORMAT(' (0,1) INTERVAL.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF 1160 CONTINUE 1169 CONTINUE C 1199 CONTINUE C C **************************************************** C ** STEP 21-- ** C ** SORT THE INPUT VARIABLES ** C **************************************************** C CALL SORT(X,NX,X) CALL SORT(Y,NY,Y) IF(NUMVAR.EQ.3)CALL SORT(Z,NZ,Z) C C ***************************************** C ** STEP 22-- ** C ** CASE 1: THIRD VARIABLE NOT ** C ** SPECIFIED (SO BASE QUANTILES ON ** C ** THE X VARIABLE). FOR THIS CASE, ** C ** Q = I/N, X(Q) = X(I). ** C ***************************************** C IWRITE='OFF' C IF(NUMVAR.EQ.2)THEN DO2200I=1,NX Z(I)=REAL(I)/REAL(NX) 2200 CONTINUE IF(NX.EQ.NY)THEN DO2210I=1,NX X2(I)=X(I) Y2(I)=Y(I) - X(I) D2(I)=1.0 2210 CONTINUE N2=NX ELSE DO2260I=1,NX XQUANT=X(I) QNT=Z(I) CALL QUANT(QNT,Y,NY,IWRITE,YTEMP,MAXN, 1 IQUAM2, 1 YQUANT,IBUGG3,IERROR) X2(I)=X(I) Y2(I)=YQUANT - XQUANT D2(I)=1.0 2260 CONTINUE N2=NX ENDIF C C ***************************************** C ** STEP 22-- ** C ** CASE 2: THIRD VARIABLE WAS ** C ** SPECIFIED (SO BASE QUANTILES ON ** C ** THIS VARIABLE). ** C ***************************************** C ELSE DO2360I=1,NZ QNT=Z(I) CALL QUANT(QNT,X,NX,IWRITE,YTEMP,MAXN, 1 IQUAM2, 1 XQUANT,IBUGG3,IERROR) CALL QUANT(QNT,Y,NY,IWRITE,YTEMP,MAXN, 1 IQUAM2, 1 YQUANT,IBUGG3,IERROR) X2(I)=XQUANT Y2(I)=YQUANT - XQUANT D2(I)=1.0 2360 CONTINUE N2=NZ ENDIF C NPLOTV=3 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'SHP2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSHP2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,MAXN,N2,IERROR 9012 FORMAT('ICASPL,MAXN,N2,IERROR = ',A4,I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICASE 9013 FORMAT('ICASE = ',A4) CALL DPWRST('XXX','BUG ') DO9015I=1,N2 WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I) 9016 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE ENDIF C RETURN END SUBROUTINE DPSIAS(ISTART,IW,NW,IHOUT,NOUT,IBUGA3,IERROR) C C PURPOSE--ADD A STRING INTO IW. C THE STRING IS LOCATED IN IHOUT(.). C THE LOCATION IN IW(.) WHERE THE STRING C IS TO BE INSERTED IS AT ISTART. C THE STRING WILL BE INSERTED BETWEEN C LOCATIONS ISTART AND ISTART+1. C THE PREVIOUS CONTENTS OF LOCATIONS C ISTART AND LARGER WILL BE AUTOMATICALLY C SHIFTED TO THE RIGHT. C THE CONTENTS OF IW(ISTART) WILL NOT BE OVERWRITTEN. C THE CONTENTS OF IW(ISTART), IW(ISTART+1), ETC. C WILL BE DISPLACED ACCORDING TO THE LENGTH C OF THE INSERTED STRING. C NOTE--THE INPUT ARGUMENTS IW(.) AND NW C AND ALTERED BY THIS SUBROUTINE. C NOTE--IF NOUT = 0 OR NEGATIVE, THEN THE CONVENTION C HAS BEEN TAKEN TO LEAVE IW(.) AND NW UNCHANGED. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--FEBRUARY 1979. C UPDATED --JUNE 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IW CHARACTER*4 IHOUT CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IW(*) DIMENSION IHOUT(*) 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 ISHIFT=0 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 DPSIAS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ISTART,NW,NOUT 52 FORMAT('ISTART,NW,NOUT = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)(IHOUT(I),I=1,MIN(NOUT,100)) 53 FORMAT('(IHOUT(.) = ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)(IW(I),I=1,MIN(NW,100)) 54 FORMAT('(IW(.) = ',100A1) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ***************************** C ** STEP 1-- ** C ** INSERT THE STRING. ** C ***************************** C IF(NOUT.GT.0)ISHIFT=NOUT IF(NOUT.LE.0)ISHIFT=0 IMIN=ISTART+1 IMAX=NW IF(IMIN.GT.IMAX)GOTO150 DO100I=IMIN,IMAX IPS=I+ISHIFT IREV=IMAX-I+IMIN IREVPS=IREV+ISHIFT IF(IREVPS.GE.IREV)IW(IREVPS)=IW(IREV) IF(IREVPS.LT.IREV)IW(IPS)=IW(I) 100 CONTINUE 150 CONTINUE NW=NW+ISHIFT C J=ISTART IF(NOUT.LE.0)GOTO250 DO200I=1,NOUT J=J+1 IW(J)=IHOUT(I) 200 CONTINUE 250 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSIAS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NW 9012 FORMAT('NW = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)(IW(I),I=1,MIN(NW,100)) 9013 FORMAT('(IW(.) = ',115A1) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPSIA0(IW,NW,IBUGA3,IERROR) C C PURPOSE--ELIMINATE SUPERFLUOUS ADDITIONS C (AND SUBTRACTIONS) BY 0 AND BY (0) . C NOTE--THE INPUT ARGUEMNTS IW(.) AND NW C ARE ALTERED BY THIS SUBROUTINE. C ORIGINAL VERSION--JANUARY 1979. C UPDATED --JANUARY 1981. C C--------------------------------------------------------------------- C CHARACTER*4 IW CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C DIMENSION IW(*) 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' IMIN=1 I2=1 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 DPSIA0--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NW 52 FORMAT('NW = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NW WRITE(ICOUT,56)I,IW(I) 56 FORMAT('I,IW(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ***************************************** C ** STEP 1-- ** C ** SET UP A LARGE DO LOOP ** C ** FOR MULTIPLE PASSES THROUGH IW(.) ** C ** FOR THE SEARCH FOR 0 . ** C ***************************************** C NUMPAS=1000 DO100IPASS=1,NUMPAS C C **************************** C ** STEP 2-- ** C ** SEARCH FOR 0 . ** C **************************** C IF(IPASS.EQ.1)IMIN=1 IF(IPASS.GE.2)IMIN=I2+1 IF(IMIN.GT.NW)GOTO990 DO200I=IMIN,NW I2=I IF(IW(I).EQ.'0 ')GOTO210 200 CONTINUE GOTO990 C 210 CONTINUE I=I2 IM1=I-1 IP1=I+1 C C *********************************** C ** STEP 3-- ** C ** TEST FOR THE +0 CASE. ** C *********************************** C IF(IM1.LT.1)GOTO390 IF(IW(IM1).EQ.'+ ')GOTO310 IF(IW(IM1).EQ.'- ')GOTO310 GOTO100 C 310 CONTINUE IF(IP1.GT.NW)GOTO330 IF(IW(IP1).EQ.'+ ')GOTO330 IF(IW(IP1).EQ.'- ')GOTO330 IF(IW(IP1).EQ.') ')GOTO320 GOTO100 C 320 CONTINUE IM2=I-2 IF(IM2.LE.0)GOTO100 IF(IW(IM2).EQ.'( ')GOTO325 GOTO330 C 325 CONTINUE ISTART=IM1 ISTOP=IM1 CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR) I2=ISTART-1 GOTO100 C 330 CONTINUE ISTART=IM1 ISTOP=I CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR) I2=ISTART-1 GOTO100 C 390 CONTINUE C C *********************************** C ** STEP 4-- ** C ** TEST FOR THE 0+ CASE. ** C *********************************** C IF(IP1.GT.NW)GOTO490 IF(IW(IP1).EQ.'+ ')GOTO410 IF(IW(IP1).EQ.'- ')GOTO410 GOTO100 C 410 CONTINUE IF(IM1.LT.1)GOTO420 IF(IW(IM1).EQ.'+ ')GOTO420 IF(IW(IM1).EQ.'- ')GOTO420 IF(IW(IM1).EQ.'/ ')GOTO420 IF(IW(IM1).EQ.'( ')GOTO420 GOTO100 C 420 CONTINUE ISTART=I ISTOP=IP1 CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR) I2=ISTART-1 GOTO100 C 490 CONTINUE C 100 CONTINUE C 990 CONTINUE C C ***************************************** C ** STEP 11-- ** C ** SET UP A LARGE DO LOOP ** C ** FOR MULTIPLE PASSES THROUGH IW(.) ** C ** FOR THE SEARCH FOR (0) . ** C ***************************************** C NUMPAS=1000 DO1100IPASS=1,NUMPAS C C **************************** C ** STEP 12-- ** C ** SEARCH FOR (0) . ** C **************************** C IF(IPASS.EQ.1)IMIN=2 IF(IPASS.GE.2)IMIN=I2+1 NWM1=NW-1 IF(IMIN.LT.2)GOTO1990 IF(IMIN.GT.NWM1)GOTO1990 DO1200I=IMIN,NWM1 I2=I IM1=I-1 IP1=I+1 IF(IW(IM1).EQ.'( '.AND.IW(I).EQ.'0 '.AND. 1 IW(IP1).EQ.') ')GOTO1210 1200 CONTINUE GOTO1990 C 1210 CONTINUE I=I2 IM1=I-1 IP1=I+1 IM2=I-2 IP2=I+2 C C *********************************** C ** STEP 13-- ** C ** TEST FOR THE *(0) CASE. ** C *********************************** C IF(IM2.LT.1)GOTO1390 IF(IW(IM2).EQ.'+ ')GOTO1310 IF(IW(IM2).EQ.'- ')GOTO1310 GOTO1100 C 1310 CONTINUE IF(IP2.GT.NW)GOTO1320 IF(IW(IP2).EQ.'+ ')GOTO1320 IF(IW(IP2).EQ.'- ')GOTO1320 IF(IW(IP2).EQ.') ')GOTO1320 GOTO1100 C 1320 CONTINUE ISTART=IM2 ISTOP=IP1 CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR) I2=ISTART-1 GOTO1100 C 1390 CONTINUE C C *********************************** C ** STEP 14-- ** C ** TEST FOR THE (0)* CASE. ** C *********************************** C IF(IP2.GT.NW)GOTO1490 IF(IW(IP2).EQ.'+ ')GOTO1410 IF(IW(IP2).EQ.'- ')GOTO1410 GOTO1100 C 1410 CONTINUE IF(IM2.LT.1)GOTO1420 IF(IW(IM2).EQ.'+ ')GOTO1420 IF(IW(IM2).EQ.'- ')GOTO1420 IF(IW(IM2).EQ.'( ')GOTO1420 GOTO1100 C 1420 CONTINUE ISTART=IM1 ISTOP=IP2 CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR) I2=ISTART-1 GOTO1100 C 1490 CONTINUE C 1100 CONTINUE C 1990 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSIA0--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NW 9012 FORMAT('NW = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NW WRITE(ICOUT,9016)I,IW(I) 9016 FORMAT('I,IW(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSIA2(IW,NW,IBUGA3,ISUBRO,IERROR) C C PURPOSE--SIMPLIFY AN ENTIRE EXPRESSION BY PERFORMING C CERTAIN SIMPLE BINARY ARITHMETIC OPERATIONS C INVOLVING INTEGERS AND WITHIN PARENTHESES. C IF INTERNAL STRING IS AN INTEGER C AND OF LENGTH 1 C (OR IF INTERNAL STRING IS REDUCABLE C TO AN INTEGER OF LENGTH 1) C THEN ELIMINATE THE IMMEDIATELY PRECEDING AND C THE IMMMEDIATELY TRAILING PARENTHESIS. C NOTE--THE INPUT ARGUMENTS IW(.) AND NW C ARE ALTERED BY THIS SUBROUTINE. C ORIGINAL VERSION--JANUARY 1979. C UPDATED --JANUARY 1981. C C--------------------------------------------------------------------- C CHARACTER*4 IW CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C DIMENSION IW(*) 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' IMIN=1 IRIGHT=1 ILEFT=1 C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'SIA2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSIA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,ISUBRO,IERROR 52 FORMAT('IBUGA3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NW 53 FORMAT('NW = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NW WRITE(ICOUT,56)I,IW(I) 56 FORMAT('I,IW(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ***************************************** C ** STEP 1-- ** C ** SET UP A LARGE DO LOOP ** C ** FOR MULTIPLE PASSES THROUGH IW(.) ** C ***************************************** C NUMPAS=1000 DO100IPASS=1,NUMPAS ISUM=0 C C ********************************************** C ** STEP 3-- ** C ** SEARCH FOR THE NEXT RIGHT PARENTHESIS. ** C ********************************************** C IF(IPASS.EQ.1)IMIN=1 IF(IPASS.GE.2)IMIN=IRIGHT+1 IF(IMIN.GT.NW)GOTO9000 C DO300I=IMIN,NW I2=I IF(IW(I).EQ.') ')GOTO350 300 CONTINUE GOTO9000 350 CONTINUE IRIGHT=I2 ISUM=ISUM+1 C C ********************************************** C ** STEP 4-- ** C ** SEARCH FOR THE NEXT (IN REVERSE ORDER) ** C ** LEFT PARENTHESIS. ** C ********************************************** C IMAX=IRIGHT-1 IF(IMAX.LT.1)GOTO9000 C DO400I=1,IMAX IREV=IMAX-I+1 IF(IW(IREV).EQ.'( ')GOTO401 IF(IW(IREV).EQ.') ')GOTO402 GOTO400 401 CONTINUE ISUM=ISUM-1 IF(ISUM.EQ.0)ILEFT=IREV IF(ISUM.EQ.0)GOTO490 GOTO400 402 CONTINUE ISUM=ISUM+1 GOTO400 400 CONTINUE C WRITE(ICOUT,411) 411 FORMAT('***** ERROR IN DPSIA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,412) 412 FORMAT(' NUMBER OF LEFT PARENTHESES DOES NOT EQUAL') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,413) 413 FORMAT(' NUMBER OF RIGHT PARENTHESES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,414) 414 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,415)(IW(I),I=1,NW) 415 FORMAT(' ',115A1) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 490 CONTINUE C C ****************************************** C ** STEP 5-- ** C ** CHECK INTERNAL STRING; ** C ** SIMPLIFY IF POSSIBLE. ** C ****************************************** C ISTART=ILEFT+1 ISTOP=IRIGHT-1 CALL DPSIS2(ISTART,ISTOP,IW,NW,IBUGA3,ISUBRO,IERROR) C 100 CONTINUE C C **************** C ** STEP 90-- ** C ** EXIT. ** C **************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'SIA2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSIA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,ISUBRO,IERROR 9012 FORMAT('IBUGA3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NW 9013 FORMAT('NW = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NW WRITE(ICOUT,9016)I,IW(I) 9016 FORMAT('I,IW(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSIEP(ISTART,ISTOP,IW,NW,IBUGA3,IERROR) C C PURPOSE--ELIMINATE EXTRA PARENTHESES. C GIVEN THAT PARENTHESES EXIST AT LOCATIONS C ISTART AND ISTOP C (A LEFT PARENTHESIS EXISTS AT LOCATION ISTART; C A RIGHT PARENTHESIS EXISTS AT LOCATION ISTOP). C WORK OUTWARD FROM THESE PARENTHESES C AND ELIMINATE REDUNDANT PAIRS OF PARENTHESES. C NOTE--THE PARENTHESES AT LOCATIONS C ISTART AND ISTOP ARE NOT THEMSELVES C ELIMINATED. C NOTE--THE 5 INPUT ARGUMENTS ARE ALL ALTERED C BY THIS SUBROUTINE. C ORIGINAL VERSION--JANUARY 1979. C UPDATED-- FEBRUARY 1979. C UPDATED-- JANUARY 1981. C C--------------------------------------------------------------------- C CHARACTER*4 IW CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C DIMENSION IW(*) C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSIEP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ISTART,ISTOP,NW 52 FORMAT('ISTART,ISTOP,NW = ',3I8) CALL DPWRST('XXX','BUG ') DO55I=1,NW WRITE(ICOUT,56)I,IW(I) 56 FORMAT('I,IW(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ********************************************************* C ** STEP 1-- ** C ** DETERMINE THE NUMBER OF EXTRA SETS OF PARENTHESES ** C ** (NOT COUNTING THE SET AT ISTART AND ISTOP). ** C ********************************************************* C NUMEXT=0 DO100I=1,1000 J1=ISTART-I J2=ISTOP+I IF(J1.LT.1.OR.J1.GT.NW)GOTO190 IF(J2.LT.1.OR.J2.GT.NW)GOTO190 IF(IW(J1).EQ.'( '.AND.IW(J2).EQ.') ')GOTO150 GOTO190 150 CONTINUE NUMEXT=NUMEXT+1 100 CONTINUE 190 CONTINUE C C *********************************************** C ** STEP 2-- ** C ** ELIMINATE THE EXTRA SETS OF PARENTHESES ** C ** (LEAVING ONLY THE ORIGINAL PAIR). ** C *********************************************** C IF(NUMEXT.LE.0)GOTO290 C IMIN=ISTOP+1 IMAX=ISTOP+NUMEXT CALL DPSIES(IMIN,IMAX,IW,NW,IBUGA3,IERROR) C IMIN=ISTART-NUMEXT IMAX=ISTART-1 CALL DPSIES(IMIN,IMAX,IW,NW,IBUGA3,IERROR) C ISTAR2=ISTART-NUMEXT IWITHI=ISTOP-ISTART-1 ISTOP2=ISTAR2+IWITHI+1 C ISTART=ISTAR2 ISTOP=ISTOP2 C 290 CONTINUE C C ****************************************** C ** STEP 3-- ** C ** CHECK TO SEE IF A SINGLE PAIR (.) ** C ** WITH A 1-CHARACTER INTERNAL STRING ** C ** CAN BE COLLAPSED TO JUST ** C ** THE 1-CHARACTER INTERNAL STRING ** C ** (EXAMPLE--(X) TO X ). ** C ** THIS CAN BE DONE PROVIDING THE ** C ** PREVIOUS WORD TO (.) IS ** C ** NOT A LIBRARY FUNCTION. ** C ** ***** CAUTION ***** ** C ** IF SUCH A REDUCTION IS MADE, ** C ** ISTART AND ISTOP WILL END UP ** C ** WITH THE SAME VALUE ** C ** AND THIS VALUE WILL BE TECHNICALLY ** C ** INCORRECT BECAUSE THERE WILL ** C ** BE NEITHER A LEFT PARENTHESES NOR A ** C ** RIGHT PARENTHESES REMAINING AT ** C ** ISTART AND ISTOP--BUT RATHER ** C ** ONLY THE 1-CHARACTER INTERNAL ** C ** STRING WILL REMAIN THERE. ** C ** IF UNEXPLAINED PROBLEMS ARISE ** C ** IN SOME OF THE CALLING ROUTINES, ** C ** THIS TECHNICALITY MAY BE THE CAUSE ** C ** OF THE PROBLEM. ** C ****************************************** C ISTAP2=ISTART+2 IF(ISTOP.EQ.ISTAP2)GOTO410 GOTO490 C 410 CONTINUE ISTAM1=ISTART-1 IF(ISTAM1.LE.0)GOTO450 IF(IW(ISTAM1).EQ.'+ ')GOTO450 IF(IW(ISTAM1).EQ.'- ')GOTO450 IF(IW(ISTAM1).EQ.'* ')GOTO450 IF(IW(ISTAM1).EQ.'/ ')GOTO450 IF(IW(ISTAM1).EQ.'** ')GOTO450 IF(IW(ISTAM1).EQ.'( ')GOTO450 GOTO490 C 450 CONTINUE IMIN=ISTOP IMAX=ISTOP CALL DPSIES(IMIN,IMAX,IW,NW,IBUGA3,IERROR) C IMIN=ISTART IMAX=ISTART CALL DPSIES(IMIN,IMAX,IW,NW,IBUGA3,IERROR) C ISTOP=ISTART C 490 CONTINUE C C **************** C ** STEP 4-- ** C ** EXIT. ** C **************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSIEP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ISTART,ISTOP,NW 9012 FORMAT('ISTART,ISTOP,NW = ',3I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NW WRITE(ICOUT,9016)I,IW(I) 9016 FORMAT('I,IW(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR) C C PURPOSE--SIMPLIFY AN EXPRESSION BY REMOVING C THE STRING STARTING WITH ISTART (INCLUSIVE) C THROUGH ISTOP (INCLUSIVE). C NOTE--THE INPUT ARGUMENTS IW(.) (FOR FIRST 4 CHARACTERS), AND C NW (= NUMBER OF ELEMENTS IN IW(.) C ARE ALTERED BY THIS SUBROUTINE. C NOTE--IT IS PERMISSABLE TO HAVE ISTART AND C ISTOP BEING THE SAME--THUS EFFECTIVELY C ELIMINATING A STRING OF LENGTH 1. C ORIGINAL VERSION--JANUARY 1979. C UPDATED --JANUARY 1981. C C--------------------------------------------------------------------- C CHARACTER*4 IW CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C DIMENSION IW(*) C C-----COMMON VARIABLES (GENERAL)---------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSIES--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ISTART,ISTOP,NW 52 FORMAT('ISTART,ISTOP,NW = ',3I8) CALL DPWRST('XXX','BUG ') DO55I=1,NW WRITE(ICOUT,56)I,IW(I) 56 FORMAT('I,IW(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ***************************** C ** STEP 1-- ** C ** ELIMINATE THE STRING. ** C ***************************** C J=ISTART-1 IMIN=ISTOP+1 IMAX=NW IF(IMIN.GT.IMAX)GOTO150 DO100I=IMIN,IMAX J=J+1 IW(J)=IW(I) 100 CONTINUE 150 CONTINUE NW=J C C ***************** C ** STEP 2-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSIES--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NW 9012 FORMAT('NW = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NW WRITE(ICOUT,9016)I,IW(I) 9016 FORMAT('I,IW(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSIE0(IW,NW,IBUGA3,IERROR) C C PURPOSE--ELIMINATE SUPERFLUOUS EXPONENTIATIONS C BY 0. C NOTE--THE INPUT ARGUEMNTS IW(.) AND NW C ARE ALTERED BY THIS SUBROUTINE. C ORIGINAL VERSION--JANUARY 1979. C UPDATED --JANUARY 1981. C C--------------------------------------------------------------------- C CHARACTER*4 IW CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C DIMENSION IW(*) 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='DPSI' ISUBN2='E0 ' C IERROR='NO' IMIN=1 I2=1 KREV=1 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 DPSIE0--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NW 52 FORMAT('NW = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NW WRITE(ICOUT,56)I,IW(I) 56 FORMAT('I,IW(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ***************************************** C ** STEP 1-- ** C ** SET UP A LARGE DO LOOP ** C ** FOR MULTIPLE PASSES THROUGH IW(.) ** C ** FOR THE SEARCH FOR 0 . ** C ***************************************** C NUMPAS=1000 DO100IPASS=1,NUMPAS C C **************************** C ** STEP 2-- ** C ** SEARCH FOR 0 . ** C **************************** C NWM1=NW-1 NWP1=NW+1 C IF(IPASS.EQ.1)IMIN=1 IF(IPASS.GE.2)IMIN=I2+1 IF(IMIN.GE.NWP1)GOTO990 DO200I=IMIN,NW I2=I IF(IW(I).EQ.'0 ')GOTO210 200 CONTINUE GOTO990 C 210 CONTINUE I=I2 IM1=I-1 IM2=I-2 IM3=I-3 IP1=I+1 IP2=I+2 IP3=I+3 C IB=IM1 IF(IB.LE.0)GOTO100 IF(IW(IB).EQ.'** '.AND.IW(I).EQ.'0 ')GOTO310 IB=IM2 IF(IB.LE.0)GOTO100 IF(IW(IB).EQ.'* '.AND.IW(IM1).EQ.'* '.AND. 1IW(I).EQ.'0 ')GOTO310 GOTO100 C C *********************************** C ** STEP 3-- ** C ** TEST FOR THE **0 CASE. ** C *********************************** C 310 CONTINUE IF(IP1.GE.NWP1)GOTO320 IF(IW(IP1).EQ.'+ ')GOTO320 IF(IW(IP1).EQ.'- ')GOTO320 IF(IP1.EQ.NW.AND.IW(IP1).EQ.'* ')GOTO320 IF(IP1.LE.NWM1.AND.IW(IP1).EQ.'* '.AND.IW(IP2).NE.'* ')GOTO320 IF(IW(IP1).EQ.'/ ')GOTO320 IF(IW(IP1).EQ.'( ')GOTO320 GOTO100 C 320 CONTINUE IRIGHT=IB-1 IF(IRIGHT.LE.0)GOTO100 ILEFT=IRIGHT IF(IW(IRIGHT).EQ.') ')GOTO333 GOTO339 333 CONTINUE ISUM=0 DO335K=1,IRIGHT KREV=IRIGHT-K+1 IF(IW(KREV).EQ.') ')ISUM=ISUM+1 IF(IW(KREV).EQ.'( ')ISUM=ISUM-1 IF(ISUM.EQ.0)GOTO337 335 CONTINUE ILEFT=0 337 CONTINUE ILEFT=KREV 339 CONTINUE C ISTART=ILEFT+1 ISTOP=I CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR) I2=ISTART-1 IW(I2)='1 ' GOTO100 C 390 CONTINUE C 100 CONTINUE C 990 CONTINUE C C ***************************************** C ** STEP 11-- ** C ** SET UP A LARGE DO LOOP ** C ** FOR MULTIPLE PASSES THROUGH IW(.) ** C ** FOR THE SEARCH FOR (0) . ** C ***************************************** C NUMPAS=1000 DO1100IPASS=1,NUMPAS C C *************************** C ** STEP 12-- ** C ** SEARCH FOR (0) . ** C *************************** C NWM1=NW-1 NWP1=NW+1 C IF(IPASS.EQ.1)IMIN=1 IF(IPASS.GE.2)IMIN=I2+1 IF(IMIN.LE.0)GOTO1990 IF(IMIN.GT.NWM1)GOTO1990 DO1200I=IMIN,NWM1 I2=I IM1=I-1 IP1=I+1 IF(IW(IM1).EQ.'( '.AND.IW(I).EQ.'0 '.AND. 1 IW(IP1).EQ.') ')GOTO1210 1200 CONTINUE GOTO1990 C 1210 CONTINUE I=I2 IM1=I-1 IM2=I-2 IM3=I-3 IP1=I+1 IP2=I+2 IP3=I+3 C IB=IM2 IF(IB.LE.0)GOTO1100 IF(IW(IB).EQ.'** '.AND.IW(I).EQ.'0 ')GOTO1310 IB=IM3 IF(IB.LE.0)GOTO1100 IF(IW(IB).EQ.'* '.AND.IW(IM2).EQ.'* '.AND. 1IW(I).EQ.'0 ')GOTO1310 GOTO1100 C C *********************************** C ** STEP 13-- ** C ** TEST FOR THE **(0) CASE. ** C *********************************** C 1310 CONTINUE IF(IP2.GE.NWP1)GOTO1320 IF(IW(IP2).EQ.'+ ')GOTO1320 IF(IW(IP2).EQ.'- ')GOTO1320 IF(IP2.EQ.NW.AND.IW(IP2).EQ.'* ')GOTO1320 IF(IP2.LE.NWM1.AND.IW(IP2).EQ.'* '.AND.IW(IP3).NE.'* ') 1GOTO1320 IF(IW(IP2).EQ.'/ ')GOTO1320 IF(IW(IP2).EQ.'( ')GOTO1320 GOTO1100 C 1320 CONTINUE IRIGHT=IB-1 IF(IRIGHT.LE.0)GOTO1100 ILEFT=IRIGHT IF(IW(IRIGHT).EQ.') ')GOTO1333 GOTO1339 1333 CONTINUE ISUM=0 DO1335K=1,IRIGHT KREV=IRIGHT-K+1 IF(IW(KREV).EQ.') ')ISUM=ISUM+1 IF(IW(KREV).EQ.'( ')ISUM=ISUM-1 IF(ISUM.EQ.0)GOTO1337 1335 CONTINUE ILEFT=0 1337 CONTINUE ILEFT=KREV 1339 CONTINUE C ISTART=ILEFT+1 ISTOP=IP1 CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR) I2=ISTART-1 IW(I2)='1 ' GOTO1100 C 1390 CONTINUE C 1100 CONTINUE C 1990 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSIE0--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NW 9012 FORMAT('NW = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NW WRITE(ICOUT,9016)I,IW(I) 9016 FORMAT('I,IW(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSIE1(IW,NW,IBUGA3,IERROR) C C PURPOSE--ELIMINATE SUPERFLUOUS EXPONENTIATIONS C BY 1. C NOTE--THE INPUT ARGUEMNTS IW(.) AND NW C ARE ALTERED BY THIS SUBROUTINE. C ORIGINAL VERSION--JANUARY 1979. C UPDATED --JANUARY 1981. C C--------------------------------------------------------------------- C CHARACTER*4 IW CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C DIMENSION IW(*) 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='DPSI' ISUBN2='E1 ' C IERROR='NO' IMIN=1 I2=1 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 DPSIE1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NW 52 FORMAT('NW = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NW WRITE(ICOUT,56)I,IW(I) 56 FORMAT('I,IW(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ***************************************** C ** STEP 1-- ** C ** SET UP A LARGE DO LOOP ** C ** FOR MULTIPLE PASSES THROUGH IW(.) ** C ** FOR THE SEARCH FOR 1 . ** C ***************************************** C NUMPAS=1000 DO100IPASS=1,NUMPAS C C **************************** C ** STEP 2-- ** C ** SEARCH FOR 1 . ** C **************************** C NWM1=NW-1 NWP1=NW+1 C IF(IPASS.EQ.1)IMIN=1 IF(IPASS.GE.2)IMIN=I2+1 IF(IMIN.GE.NWP1)GOTO990 DO200I=IMIN,NW I2=I IF(IW(I).EQ.'1 ')GOTO210 200 CONTINUE GOTO990 C 210 CONTINUE I=I2 IM1=I-1 IM2=I-2 IM3=I-3 IP1=I+1 IP2=I+2 IP3=I+3 C C *********************************** C ** STEP 3-- ** C ** TEST FOR THE **1 CASE. ** C *********************************** C IB=IM1 IF(IB.LE.0)GOTO100 IF(IW(IB).EQ.'** '.AND.IW(I).EQ.'1 ')GOTO310 IB=IM2 IF(IB.LE.0)GOTO100 IF(IW(IB).EQ.'* '.AND.IW(IM1).EQ.'* '.AND. 1IW(I).EQ.'1 ')GOTO310 GOTO100 C 310 CONTINUE IF(IP1.GE.NWP1)GOTO320 IF(IW(IP1).EQ.'+ ')GOTO320 IF(IW(IP1).EQ.'- ')GOTO320 IF(IP1.EQ.NW.AND.IW(IP1).EQ.'* ')GOTO320 IF(IP1.LE.NWM1.AND.IW(IP1).EQ.'* '.AND.IW(IP2).NE.'* ')GOTO320 IF(IW(IP1).EQ.'/ ')GOTO320 IF(IW(IP1).EQ.') ')GOTO320 GOTO100 C 320 CONTINUE ISTART=IB ISTOP=I CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR) I2=ISTART-1 GOTO100 C 390 CONTINUE C 100 CONTINUE C 990 CONTINUE C C ***************************************** C ** STEP 11-- ** C ** SET UP A LARGE DO LOOP ** C ** FOR MULTIPLE PASSES THROUGH IW(.) ** C ** FOR THE SEARCH FOR (1) . ** C ***************************************** C NUMPAS=1000 DO1100IPASS=1,NUMPAS C C **************************** C ** STEP 12-- ** C ** SEARCH FOR (1) . ** C **************************** C NWM1=NW-1 NWP1=NW+1 C IF(IPASS.EQ.1)IMIN=1 IF(IPASS.GE.2)IMIN=I2+1 IF(IMIN.LE.0)GOTO1990 IF(IMIN.GT.NWM1)GOTO1990 DO1200I=IMIN,NWM1 I2=I IM1=I-1 IP1=I+1 IF(IW(IM1).EQ.'( '.AND.IW(I).EQ.'1 '.AND. 1 IW(IP1).EQ.') ')GOTO1210 1200 CONTINUE GOTO1990 C 1210 CONTINUE I=I2 IM1=I-1 IM2=I-2 IM3=I-3 IP1=I+1 IP2=I+2 IP3=I+3 C C *********************************** C ** STEP 13-- ** C ** TEST FOR THE **(1) CASE. ** C *********************************** C IB=IM2 IF(IB.LE.0)GOTO1100 IF(IW(IB).EQ.'** '.AND.IW(I).EQ.'1 ')GOTO1310 IB=IM3 IF(IB.LE.0)GOTO1100 IF(IW(IB).EQ.'* '.AND.IW(IM2).EQ.'* '.AND. 1IW(I).EQ.'1 ')GOTO1310 GOTO1100 C 1310 CONTINUE IF(IP2.GE.NWP1)GOTO1320 IF(IW(IP2).EQ.'+ ')GOTO1320 IF(IW(IP2).EQ.'- ')GOTO1320 IF(IP2.EQ.NW.AND.IW(IP2).EQ.'* ')GOTO1320 IF(IP2.LE.NWM1.AND.IW(IP2).EQ.'* '.AND.IW(IP3).NE.'* ') 1GOTO1320 IF(IW(IP2).EQ.'/ ')GOTO1320 IF(IW(IP2).EQ.') ')GOTO1320 GOTO1100 C 1320 CONTINUE ISTART=IB ISTOP=IP1 CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR) I2=ISTART-1 GOTO1100 C 1390 CONTINUE C 1100 CONTINUE C 1990 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSIE1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NW 9012 FORMAT('NW = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NW WRITE(ICOUT,9016)I,IW(I) 9016 FORMAT('I,IW(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSIFL(IW,NW,IBUGA3,IERROR) C C PURPOSE--SIMPLIFY AN EXPRESSION BY REMOVING C ALL REDUNDANT PARENTHESES C AT THE BEGINNING AND END. C NOTE--THE INPUT ARGUMENTS IW(.) AND NW C ARE ALTERED BY THIS SUBROUTINE. C ORIGINAL VERSION--JANUARY 1979. C UPDATED --JANUARY 1981. C C--------------------------------------------------------------------- C CHARACTER*4 IW CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C DIMENSION IW(*) 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 IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSIFL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NW 52 FORMAT('NW = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NW WRITE(ICOUT,56)I,IW(I) 56 FORMAT('I,IW(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ***************************************** C ** STEP 1-- ** C ** SET UP A LARGE DO LOOP ** C ** FOR MULTIPLE PASSES THROUGH IW(.) ** C ***************************************** C NUMPAS=1000 DO100IPASS=1,NUMPAS C C **************************************** C ** STEP 2-- ** C ** DETERMINE IF THE FIRST CHARACTER ** C ** IS A LEFT PARENTHESIS. ** C ** DETERMINE IF THE LAST CHARACTER ** C ** IS A RIGHT PARENTHESIS. ** C **************************************** C IF(NW.LE.0)GOTO9000 IF(IW(1).EQ.'( '.AND.IW(NW).EQ.') ')GOTO290 GOTO9000 C 290 CONTINUE C C *********************************************** C ** STEP 3-- ** C ** DETERMINE IF THE RIGHT PARENTHESIS ** C ** IN THE LAST LOCATION IS THE COMPLEMENT ** C ** TO THE LEFT PARENTHESIS ** C ** IN THE FIRST LOCATION. ** C *********************************************** C ISUM=0 IMIN=1 IMAX=NW DO300I=IMIN,IMAX IF(IW(I).EQ.'( ')GOTO301 IF(IW(I).EQ.') ')GOTO302 GOTO300 301 CONTINUE ISUM=ISUM-1 ILOC0=I IF(ISUM.EQ.0)GOTO350 GOTO300 302 CONTINUE ISUM=ISUM+1 ILOC0=I IF(ISUM.EQ.0)GOTO350 GOTO300 300 CONTINUE C WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPSIFL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312) 312 FORMAT(' NUMBER OF LEFT PARENTHESES DOES NOT EQUAL') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) 313 FORMAT(' NUMBER OF RIGHT PARENTHESES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)(IW(I),I=1,NW) 315 FORMAT(' ',115A1) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 350 CONTINUE IF(ILOC0.EQ.NW)GOTO390 GOTO9000 390 CONTINUE C C ************************************* C ** STEP 4-- ** C ** ELIMINATE THE PARENTHESES IN ** C ** LOCATION 1 AND LOCATION NW. ** C ** RESET THE VALUE IN NW. ** C ************************************* C ISTART=1 ISTOP=1 CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR) C ISTART=NW ISTOP=NW CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR) C 100 CONTINUE C C **************** C ** STEP 90-- ** C ** EXIT. ** C **************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSIFL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NW 9012 FORMAT('NW = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NW WRITE(ICOUT,9016)I,IW(I) 9016 FORMAT('I,IW(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSIFN (X, N, KODE, M, ANS, NZ, IERR) C***BEGIN PROLOGUE DPSIFN C***PURPOSE Compute derivatives of the Psi function. C***LIBRARY SLATEC C***CATEGORY C7C C***TYPE DOUBLE PRECISION (PSIFN-S, DPSIFN-D) C***KEYWORDS DERIVATIVES OF THE GAMMA FUNCTION, POLYGAMMA FUNCTION, C PSI FUNCTION C***AUTHOR Amos, D. E., (SNLA) C***DESCRIPTION C C The following definitions are used in DPSIFN: C C Definition 1 C PSI(X) = d/dx (ln(GAMMA(X)), the first derivative of C the log GAMMA function. C Definition 2 C K K C PSI(K,X) = d /dx (PSI(X)), the K-th derivative of PSI(X). C ___________________________________________________________________ C DPSIFN computes a sequence of SCALED derivatives of C the PSI function; i.e. for fixed X and M it computes C the M-member sequence C C ((-1)**(K+1)/GAMMA(K+1))*PSI(K,X) C for K = N,...,N+M-1 C C where PSI(K,X) is as defined above. For KODE=1, DPSIFN returns C the scaled derivatives as described. KODE=2 is operative only C when K=0 and in that case DPSIFN returns -PSI(X) + LN(X). That C is, the logarithmic behavior for large X is removed when KODE=2 C and K=0. When sums or differences of PSI functions are computed C the logarithmic terms can be combined analytically and computed C separately to help retain significant digits. C C Note that CALL DPSIFN(X,0,1,1,ANS) results in C ANS = -PSI(X) C C Input X is DOUBLE PRECISION C X - Argument, X .gt. 0.0D0 C N - First member of the sequence, 0 .le. N .le. 100 C N=0 gives ANS(1) = -PSI(X) for KODE=1 C -PSI(X)+LN(X) for KODE=2 C KODE - Selection parameter C KODE=1 returns scaled derivatives of the PSI C function. C KODE=2 returns scaled derivatives of the PSI C function EXCEPT when N=0. In this case, C ANS(1) = -PSI(X) + LN(X) is returned. C M - Number of members of the sequence, M.ge.1 C C Output ANS is DOUBLE PRECISION C ANS - A vector of length at least M whose first M C components contain the sequence of derivatives C scaled according to KODE. C NZ - Underflow flag C NZ.eq.0, A normal return C NZ.ne.0, Underflow, last NZ components of ANS are C set to zero, ANS(M-K+1)=0.0, K=1,...,NZ C IERR - Error flag C IERR=0, A normal return, computation completed C IERR=1, Input error, no computation C IERR=2, Overflow, X too small or N+M-1 too C large or both C IERR=3, Error, N too large. Dimensioned C array TRMR(NMAX) is not large enough for N C C The nominal computational accuracy is the maximum of unit C roundoff (=D1MACH(4)) and 1.0D-18 since critical constants C are given to only 18 digits. C C PSIFN is the single precision version of DPSIFN. C C *Long Description: C C The basic method of evaluation is the asymptotic expansion C for large X.ge.XMIN followed by backward recursion on a two C term recursion relation C C W(X+1) + X**(-N-1) = W(X). C C This is supplemented by a series C C SUM( (X+K)**(-N-1) , K=0,1,2,... ) C C which converges rapidly for large N. Both XMIN and the C number of terms of the series are calculated from the unit C roundoff of the machine environment. C C***REFERENCES Handbook of Mathematical Functions, National Bureau C of Standards Applied Mathematics Series 55, edited C by M. Abramowitz and I. A. Stegun, equations 6.3.5, C 6.3.18, 6.4.6, 6.4.9 and 6.4.10, pp.258-260, 1964. C D. E. Amos, A portable Fortran subroutine for C derivatives of the Psi function, Algorithm 610, ACM C Transactions on Mathematical Software 9, 4 (1983), C pp. 494-502. C***ROUTINES CALLED D1MACH, I1MACH C***REVISION HISTORY (YYMMDD) C 820601 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890911 Removed unnecessary intrinsics. (WRB) C 891006 Cosmetic changes to prologue. (WRB) C 891006 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE DPSIFN INCLUDE 'DPCOMC.INC' C INTEGER I, IERR, J, K, KODE, M, MM, MX, N, NMAX, NN, NP, NX, NZ, * FN INTEGER I1MACH DOUBLE PRECISION ANS, ARG, B, DEN, ELIM, EPS, FLN, * FX, RLN, RXSQ, R1M4, R1M5, S, SLOPE, T, TA, TK, TOL, TOLS, TRM, * TRMR, TSS, TST, TT, T1, T2, WDTOL, X, XDMLN, XDMY, XINC, XLN, * XM, XMIN, XQ, YINT DIMENSION B(22), TRM(22), TRMR(100), ANS(*) SAVE NMAX, B DATA NMAX /100/ C----------------------------------------------------------------------- C BERNOULLI NUMBERS C----------------------------------------------------------------------- DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10), * B(11), B(12), B(13), B(14), B(15), B(16), B(17), B(18), B(19), * B(20), B(21), B(22) /1.00000000000000000D+00, * -5.00000000000000000D-01,1.66666666666666667D-01, * -3.33333333333333333D-02,2.38095238095238095D-02, * -3.33333333333333333D-02,7.57575757575757576D-02, * -2.53113553113553114D-01,1.16666666666666667D+00, * -7.09215686274509804D+00,5.49711779448621554D+01, * -5.29124242424242424D+02,6.19212318840579710D+03, * -8.65802531135531136D+04,1.42551716666666667D+06, * -2.72982310678160920D+07,6.01580873900642368D+08, * -1.51163157670921569D+10,4.29614643061166667D+11, * -1.37116552050883328D+13,4.88332318973593167D+14, * -1.92965793419400681D+16/ C C***FIRST EXECUTABLE STATEMENT DPSIFN IERR = 0 NZ=0 IF (X.LE.0.0D0) IERR=1 IF (N.LT.0) IERR=1 IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 IF (M.LT.1) IERR=1 IF (IERR.NE.0) RETURN MM=M NX = MIN(-I1MACH(15),I1MACH(16)) R1M5 = D1MACH(5) R1M4 = D1MACH(4)*0.5D0 WDTOL = MAX(R1M4,0.5D-18) C----------------------------------------------------------------------- C ELIM = APPROXIMATE EXPONENTIAL OVER AND UNDERFLOW LIMIT C----------------------------------------------------------------------- ELIM = 2.302D0*(NX*R1M5-3.0D0) XLN = LOG(X) 41 CONTINUE NN = N + MM - 1 FN = NN T = (FN+1)*XLN C----------------------------------------------------------------------- C OVERFLOW AND UNDERFLOW TEST FOR SMALL AND LARGE X C----------------------------------------------------------------------- IF (ABS(T).GT.ELIM) GO TO 290 IF (X.LT.WDTOL) GO TO 260 C----------------------------------------------------------------------- C COMPUTE XMIN AND THE NUMBER OF TERMS OF THE SERIES, FLN+1 C----------------------------------------------------------------------- RLN = R1M5*I1MACH(14) RLN = MIN(RLN,18.06D0) FLN = MAX(RLN,3.0D0) - 3.0D0 YINT = 3.50D0 + 0.40D0*FLN SLOPE = 0.21D0 + FLN*(0.0006038D0*FLN+0.008677D0) XM = YINT + SLOPE*FN MX = INT(XM) + 1 XMIN = MX IF (N.EQ.0) GO TO 50 XM = -2.302D0*RLN - MIN(0.0D0,XLN) ARG = XM/N ARG = MIN(0.0D0,ARG) EPS = EXP(ARG) XM = 1.0D0 - EPS IF (ABS(ARG).LT.1.0D-3) XM = -ARG FLN = X*XM/EPS XM = XMIN - X IF (XM.GT.7.0D0 .AND. FLN.LT.15.0D0) GO TO 200 50 CONTINUE XDMY = X XDMLN = XLN XINC = 0.0D0 IF (X.GE.XMIN) GO TO 60 NX = INT(X) XINC = XMIN - NX XDMY = X + XINC XDMLN = LOG(XDMY) 60 CONTINUE C----------------------------------------------------------------------- C GENERATE W(N+MM-1,X) BY THE ASYMPTOTIC EXPANSION C----------------------------------------------------------------------- T = FN*XDMLN T1 = XDMLN + XDMLN T2 = T + XDMLN TK = MAX(ABS(T),ABS(T1),ABS(T2)) IF (TK.GT.ELIM) GO TO 380 TSS = EXP(-T) TT = 0.5D0/XDMY T1 = TT TST = WDTOL*TT IF (NN.NE.0) T1 = TT + 1.0D0/FN RXSQ = 1.0D0/(XDMY*XDMY) TA = 0.5D0*RXSQ T = (FN+1)*TA S = T*B(3) IF (ABS(S).LT.TST) GO TO 80 TK = 2.0D0 DO 70 K=4,22 T = T*((TK+FN+1)/(TK+1.0D0))*((TK+FN)/(TK+2.0D0))*RXSQ TRM(K) = T*B(K) IF (ABS(TRM(K)).LT.TST) GO TO 80 S = S + TRM(K) TK = TK + 2.0D0 70 CONTINUE 80 CONTINUE S = (S+T1)*TSS IF (XINC.EQ.0.0D0) GO TO 100 C----------------------------------------------------------------------- C BACKWARD RECUR FROM XDMY TO X C----------------------------------------------------------------------- NX = INT(XINC) NP = NN + 1 IF (NX.GT.NMAX) GO TO 390 IF (NN.EQ.0) GO TO 160 XM = XINC - 1.0D0 FX = X + XM C----------------------------------------------------------------------- C THIS LOOP SHOULD NOT BE CHANGED. FX IS ACCURATE WHEN X IS SMALL C----------------------------------------------------------------------- DO 90 I=1,NX TRMR(I) = FX**(-NP) S = S + TRMR(I) XM = XM - 1.0D0 FX = X + XM 90 CONTINUE 100 CONTINUE ANS(MM) = S IF (FN.EQ.0) GO TO 180 C----------------------------------------------------------------------- C GENERATE LOWER DERIVATIVES, J.LT.N+MM-1 C----------------------------------------------------------------------- IF (MM.EQ.1) RETURN DO 150 J=2,MM FN = FN - 1 TSS = TSS*XDMY T1 = TT IF (FN.NE.0) T1 = TT + 1.0D0/FN T = (FN+1)*TA S = T*B(3) IF (ABS(S).LT.TST) GO TO 120 TK = 4 + FN DO 110 K=4,22 TRM(K) = TRM(K)*(FN+1)/TK IF (ABS(TRM(K)).LT.TST) GO TO 120 S = S + TRM(K) TK = TK + 2.0D0 110 CONTINUE 120 CONTINUE S = (S+T1)*TSS IF (XINC.EQ.0.0D0) GO TO 140 IF (FN.EQ.0) GO TO 160 XM = XINC - 1.0D0 FX = X + XM DO 130 I=1,NX TRMR(I) = TRMR(I)*FX S = S + TRMR(I) XM = XM - 1.0D0 FX = X + XM 130 CONTINUE 140 CONTINUE MX = MM - J + 1 ANS(MX) = S IF (FN.EQ.0) GO TO 180 150 CONTINUE RETURN C----------------------------------------------------------------------- C RECURSION FOR N = 0 C----------------------------------------------------------------------- 160 CONTINUE DO 170 I=1,NX S = S + 1.0D0/(X+NX-I) 170 CONTINUE 180 CONTINUE IF (KODE.EQ.2) GO TO 190 ANS(1) = S - XDMLN RETURN 190 CONTINUE IF (XDMY.EQ.X) RETURN XQ = XDMY/X ANS(1) = S - LOG(XQ) RETURN C----------------------------------------------------------------------- C COMPUTE BY SERIES (X+K)**(-(N+1)) , K=0,1,2,... C----------------------------------------------------------------------- 200 CONTINUE NN = INT(FLN) + 1 NP = N + 1 T1 = (N+1)*XLN T = EXP(-T1) S = T DEN = X DO 210 I=1,NN DEN = DEN + 1.0D0 TRM(I) = DEN**(-NP) S = S + TRM(I) 210 CONTINUE ANS(1) = S IF (N.NE.0) GO TO 220 IF (KODE.EQ.2) ANS(1) = S + XLN 220 CONTINUE IF (MM.EQ.1) RETURN C----------------------------------------------------------------------- C GENERATE HIGHER DERIVATIVES, J.GT.N C----------------------------------------------------------------------- TOL = WDTOL/5.0D0 DO 250 J=2,MM T = T/X S = T TOLS = T*TOL DEN = X DO 230 I=1,NN DEN = DEN + 1.0D0 TRM(I) = TRM(I)/DEN S = S + TRM(I) IF (TRM(I).LT.TOLS) GO TO 240 230 CONTINUE 240 CONTINUE ANS(J) = S 250 CONTINUE RETURN C----------------------------------------------------------------------- C SMALL X.LT.UNIT ROUND OFF C----------------------------------------------------------------------- 260 CONTINUE ANS(1) = X**(-N-1) IF (MM.EQ.1) GO TO 280 K = 1 DO 270 I=2,MM ANS(K+1) = ANS(K)/X K = K + 1 270 CONTINUE 280 CONTINUE IF (N.NE.0) RETURN IF (KODE.EQ.2) ANS(1) = ANS(1) + XLN RETURN 290 CONTINUE IF (T.GT.0.0D0) GO TO 380 NZ=0 IERR=2 RETURN 380 CONTINUE NZ=NZ+1 ANS(MM)=0.0D0 MM=MM-1 IF (MM.EQ.0) RETURN GO TO 41 390 CONTINUE NZ=0 IERR=3 RETURN END SUBROUTINE DPSIGN(XTEMP1,XTEMP2,MAXNXT, 1ICAPSW, 1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--CARRY OUT A SIGN TEST C (1-SAMPLE OR A PAIRED 2-SAMPLE) C EXAMPLE--SIGN TEST Y MU C SIGN TEST MU Y C SIGN TEST Y1 Y2 C SIGN TEST Y1 Y2 D0 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--99/6 C ORIGINAL VERSION--JUNE 1999. C UPDATED --OCTOBER 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 ICAPSW 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 C CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 ISUBN0 C C--------------------------------------------------------------------- C DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOSU.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOST.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPSI' ISUBN2='GN ' 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 NUMVAR=(-999) 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 SIGN TEST CASE ** C ******************************** C IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'SIGN')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSIGN--') 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'.OR.ISUBRO.EQ.'SIGN') 1CALL 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 COULD BE A VARIABLE, ** C ** A PARAMETER, OR A NUMBER). ** C **************************************** C ISTEPN='11' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IH11=IHARG(1) IH12=IHARG2(1) IF(IARGT(1).EQ.'NUMB')GOTO1110 IHWUSE='VORP' MESSAG='YES' CALL CHECKN(IH11,IH12,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHWUSE='V' MESSAG='YES' CALL CHECKN(IH11,IH12,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO1110 GOTO1120 1110 CONTINUE VALUE1=ARG(1) IUSE1='P' GOTO1190 1120 CONTINUE IUSE1=IUSE(ILOCV) ICOL1=IVALUE(ILOCV) N1=IN(ILOCV) GOTO1190 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 DPSIGN--') 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 A SIGN 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) IF(IARGT(2).EQ.'NUMB')GOTO2110 IHWUSE='VORP' MESSAG='YES' CALL CHECKN(IH21,IH22,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHWUSE='V' MESSAG='YES' CALL CHECKN(IH21,IH22,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO2110 GOTO2120 2110 CONTINUE VALUE2=ARG(2) IUSE2='P' GOTO2190 2120 CONTINUE IUSE2=IUSE(ILOCV) ICOL2=IVALUE(ILOCV) N2=IN(ILOCV) GOTO2190 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'.OR.ISUBRO.EQ.'SIGN') 1CALL 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 DPSIGN--') 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 A SIGN 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 23-- ** C ** CHECK THE VALIDITY OF ARGUMENT 3 ** C ** THIS IS AN OPTIONAL ARGUMENT, BUT ** C ** IF PRESENT MUST BE A NUMBER OR A ** C ** PARAMETER ** C **************************************** C ISTEPN='31' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SIGN') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C D0=0.0 IF(NUMARG.LT.3)GOTO2390 IH31=IHARG(3) IH32=IHARG2(3) IF(IH31.EQ.'SUBS'.AND.IH32.EQ.'ET ')GOTO2390 IF(IH31.EQ.'FOR '.AND.IH32.EQ.' ')GOTO2390 IF(IH31.EQ.'EXCE'.AND.IH32.EQ.'PT ')GOTO2390 IF(IARGT(3).EQ.'NUMB')GOTO2310 IHWUSE='P' MESSAG='YES' CALL CHECKN(IH31,IH32,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 D0=VALUE(ILOCV) GOTO2390 2310 CONTINUE D0=ARG(3) GOTO2390 2390 CONTINUE C C ***************************************************** C ** STEP 31-- ** C ** FOR A SIGN TEST, ** C ** AT LEAST ONE OF THE FIRST 2 ARGUMENTS ** C ** MUST BE A VARIABLE. ** C ** CHECK FOR THIS. ** C ** IF ONLY 1 ARGUMENT IS A VARIABLE, ** C ** THIS IMPLIES A 1-SAMPLE SIGN TEST. ** C ** (IF SO, COPY THE OTHER ARGUMENT AS THE TARGET ** C ** MU VALUE). ** C ** IF BOTH ARGUMENTS ARE VARIABLES, ** C ** THIS IMPLIES A 2-SAMPLE SIGN TEST. ** C ***************************************************** C ISTEPN='31' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SIGN') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IUSE1.EQ.'V'.AND.IUSE2.NE.'V')GOTO3110 IF(IUSE1.NE.'V'.AND.IUSE2.EQ.'V')GOTO3120 IF(IUSE1.EQ.'V'.AND.IUSE2.EQ.'V')GOTO3130 GOTO3140 C 3110 CONTINUE NUMVAR=1 ILOCV=1 AMU0=VALUE2 D0=(-999.0) GOTO3190 3120 CONTINUE NUMVAR=1 ILOCV=2 AMU0=VALUE1 D0=(-999.0) GOTO3190 3130 CONTINUE NUMVAR=2 ILOCV=(-999) AMU0=(-999.0) GOTO3190 C 3140 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3141) 3141 FORMAT('***** ERROR IN DPSIGN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3142) 3142 FORMAT(' FOR A SIGN TEST,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3143) 3143 FORMAT(' EITHER THE FIRST ARGUMENT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3144) 3144 FORMAT(' OR THE SECOND ARGUMENT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3145) 3145 FORMAT(' (OR BOTH ARGUMENTS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3146) 3146 FORMAT(' MUST BE A VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3147) 3147 FORMAT(' (AS OPPOSED TO A PARAMETER OR FUNCTION).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3148) 3148 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3149) 3149 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3150)(IANS(I),I=1,IWIDTH) 3150 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3190 CONTINUE C C ***************************************************** C ** STEP 32-- ** C ** FOR A 2-SAMPLE SIGN TEST, ** C ** BOTH VARIABLES MUST HAVE THE SAME NUMBER OF ** C ** OBSERVATIONS (I.E., PAIRED SAMPLES) ** C ***************************************************** C ISTEPN='32' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SIGN') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(N1.EQ.N2.OR.NUMVAR.EQ.1)GOTO3290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3211) 3211 FORMAT('***** ERROR IN DPSIGN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3212) 3212 FORMAT(' FOR A 2-SAMPLE SIGN TEST,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3213) 3213 FORMAT(' BOTH VARIABLES MUST HAVE THE SAME NUMBER OF') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3218) 3218 FORMAT(' OBSERVATIONS. SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3220)IH11,IH12,N1 3220 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3222)IH21,IH22,N2 3222 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3239) 3239 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3250)(IANS(I),I=1,IWIDTH) 3250 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3290 CONTINUE C 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'.AND.ISUBRO.NE.'SIGN')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'.OR.ISUBRO.EQ.'SIGN') 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 DPSIGN--') 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 A SIGN 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'.OR.ISUBRO.EQ.'SIGN') 1CALL 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 DPSIGN--') 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 A SIGN 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 IF(NS1.EQ.NS2.OR.NUMVAR.LT.2)GOTO4390 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4351) 4351 FORMAT('***** ERROR IN DPSIGN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4352) 4352 FORMAT(' AFTER THE APPROPRIATE SUBSETS HAVE BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4353) 4353 FORMAT(' THE NUMBER OF OBSERVATIONS FROM THE TWO ', 1'VARIABLES ARE NOT EQUAL.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4354)IH11,IH12,NS1 4354 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4355)IH21,IH22,NS2 4355 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4358) 4358 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,4359)(IANS(I),I=1,IWIDTH) 4359 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 4390 CONTINUE C C ********************************* C ** STEP 52-- ** C ** CARRY OUT THE SIGN TEST ** C ********************************* C ISTEPN='52' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SIGN') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'SIGN')GOTO5290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5211) 5211 FORMAT('***** FROM DPSIGN, AS WE ARE ABOUT TO CALL DPSIG2--') 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 WRITE(ICOUT,5231)IBUGA3 5231 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') 5290 CONTINUE C CALL DPSIG2(Y,NS1,X,NS2,AMU0,D0,NUMVAR,ILOCV, 1XTEMP1,XTEMP2,MAXNXT, 1STATV1,STATV2,STATC1,STATC2, 1CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 1ICAPTY,ICAPSW, 1IBUGA3,ISUBRO,IERROR) C C *************************************** C ** STEP 61-- ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C ISTEPN='61' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SIGN') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ISUBN0='DPSI' C IH='STAT' IH2='VALP' VALUE0=STATV1 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='STAT' IH2='VALM' VALUE0=STATV2 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='STAT' IH2='CDFP' VALUE0=STATC1 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='STAT' IH2='CDFM' VALUE0=STATC2 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTL' IH2='OW90' VALUE0=CUTL90 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTU' IH2='PP90' VALUE0=CUTU90 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='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 DPSIGN--') 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 DPSIG2(Y1,N1,Y2,N2,AMU0,D0,NUMVAR,ILOCV, 1XTEMP1,XTEMP2,MAXNXT, 1STATV1,STATV2,STATC1,STATC2, 1CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99, 1ICAPTY,ICAPSW, 1IBUGA3,ISUBRO,IERROR) C C PURPOSE--THIS ROUTINE CARRIES OUT A SIGN TEST C (1-SAMPLE OR 2-SAMPLE) C EXAMPLE--SIGN TEST Y MU C SIGN TEST MU Y C SIGN TEST Y1 Y2 C SIGN TEST Y1 Y2 D0 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 (BUT N1 SHOULD EQUAL N2) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--99/6 C ORIGINAL VERSION--JUNE 1999. C UPDATED --AUGUST 2000. BIG FIX FOR ICONC2 C UPDATED --AUGUST 2002. MODIFY OUTPUT FOR BETTER C CLARITY C UPDATED --OCTOBER 2004. SUPPORT FOR HTML/LATEX C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICAPTY CHARACTER*4 ICAPSW CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 IWRITE CHARACTER*4 IBASLC C 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='DPSI' ISUBN2='G2 ' C IERROR='NO' C N=(-99) C IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SIGN')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,51) 51 FORMAT('**** AT THE BEGINNING OF DPSIG2--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,53)NUMVAR,ILOCV 53 FORMAT('NUMVAR,ILOCV = ',E15.7,I8,I8) 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),Y2(I) 57 FORMAT('I,Y1(I),Y2(I) = ',I8,2E15.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.'SIG2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(N1.LT.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1111) 1111 FORMAT('***** ERROR IN SIGN TEST--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1112) 1112 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE VARIABLES ', 1 'IS NON-POSITIVE') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1113)N1 1113 FORMAT('SAMPLE SIZE = ',I8) CALL DPWRST('XXX','WRIT') IERROR='YES' GOTO9000 ENDIF C IF(N1.EQ.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1121) 1121 FORMAT('***** NOTE FROM SIGN TEST--VARIABLE 1 ', 1 'HAS ONLY 1 ELEMENT') CALL DPWRST('XXX','WRIT') GOTO9000 ENDIF 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 SIGN TEST--VARIABLE 1 ', 1'HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','WRIT') GOTO9000 1139 CONTINUE C IF(NUMVAR.LT.2)GOTO1239 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 SIGN TEST--VARIABLE 2 ', 1'HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','WRIT') GOTO9000 1239 CONTINUE C 1290 CONTINUE C C ************************************ C ** STEP 21-- ** C ** BRANCH DEPENDING ON WHETHER ** C ** 1-SAMPLE SIGN TEST OR ** C ** 2-SAMPLE SIGN TEST. ** C ************************************ C ISTEPN='21' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SIG2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMVAR.EQ.1)GOTO3100 GOTO4100 C C ********************************* C ** STEP 31-- ** C ** CARRY OUT CALCULATIONS ** C ** FOR A 1-SAMPLE SIGN TEST ** C ********************************* C 3100 CONTINUE C ISTEPN='31' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SIG2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IWRITE='OFF' C NTEMP=0 RMINUS=0.0 RPLUS=0.0 DO3200I=1,N1 ADIFF=Y1(I) - AMU0 IF(ADIFF.LT.0.0)THEN NTEMP=NTEMP+1 RMINUS=RMINUS+1.0 ELSEIF(ADIFF.GT.0.0)THEN NTEMP=NTEMP+1 RPLUS=RPLUS+1.0 ENDIF 3200 CONTINUE CALL BINCDF(RMINUS,0.5,NTEMP,RMCDF) CALL BINCDF(RPLUS,0.5,NTEMP,RPCDF) C ICONC1='REJECT' ICONC2='REJECT' ICONC3='REJECT' C CCCCC AUGUST 2002. FIX FOLLOWING LINES. CCCCC IF(RPCDF.GT.0.05)ICONC1='ACCEPT' CCCCC IF(RPCDF.GT.0.05 .AND. RPCDF.LT.0.950)ICONC2='ACCEPT' CCCCC IF(RPCDF.GT.0.05 .AND. RPCDF.LT.0.950)ICONC2='ACCEPT' CCCCC IF(RMCDF.GT.0.05)ICONC3='ACCEPT' IF(RPCDF.LE.0.05)ICONC1='ACCEPT' IF(RMCDF.LE.0.05)ICONC3='ACCEPT' IF(RPCDF.LE.0.025 .OR. RMCDF.LE.0.025)ICONC2='ACCEPT' C STATV1=RPLUS STATV2=RMINUS STATC1=RPCDF STATC2=RMCDF CALL BINPPF(.050,0.5,NTEMP,CUTL90) CALL BINPPF(.950,0.5,NTEMP,CUTU90) CALL BINPPF(.025,0.5,NTEMP,CUTL95) CALL BINPPF(.975,0.5,NTEMP,CUTU95) CALL BINPPF(.005,0.5,NTEMP,CUTL99) CALL BINPPF(.995,0.5,NTEMP,CUTU99) C C ********************************* C ** STEP 32-- ** C ** WRITE OUT EVERYTHING ** C ** FOR A 2-SAMPLE SIGN TEST ** C ********************************* C ISTEPN='32' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SIG2') 1CALL 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('') 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('

') 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 ONE SAMPLE SIGN TEST}')
 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$ Median & = & ',
     1       G15.7,2X,A1,A1)
 8022 FORMAT(5X,'$H_a$ Median ($',A1,'ne$) & ',
     1       G15.7,2X,A1,A1)
 8023 FORMAT(5X,' &   & ',2X,A1,A1)
 8024 FORMAT(5X,'{',A1,'bf Sample:} &   & ',2X,A1,A1)
 8025 FORMAT(5X,'Number of Observations & = & ',I8,2X,A1,A1)
 8026 FORMAT(5X,'Number of Positive Differences & = & ',I8,2X,A1,A1)
 8027 FORMAT(5X,'Number of Negative Differences & = & ',I8,2X,A1,A1)
 8028 FORMAT(5X,'Sign Test Statistic CDF Value (R+) & = & ',
     1       G15.7,2X,A1,A1)
 8029 FORMAT(5X,'Sign Test Statistic CDF Value (R-) & = & ',
     1       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)AMU0,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8022)IBASLC,AMU0,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        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)INT(RPLUS+0.5),IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8027)INT(RMINUS+0.5),IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8028)RPCDF,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8029)RMCDF,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')
        WRITE(ICOUT,999)
        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 Alternative} & {',A1,
     1       'bf Alternative}',2X,A1,A1)
 8122 FORMAT(5X,'{',A1,'bf Alternative} & {',A1,
     1       'bf Hypothesis} & {',A1,'bf Hypothesis}',
     1       2X,A1,A1)
 8123 FORMAT(5X,'{',A1,'bf Hypothesis} & {',A1,
     1       'bf Acceptance Interval} & {',A1,
     1       'bf Conclusion}',2X,A1,A1)
 8124 FORMAT(5X,'Median $',A1,'ne$ ',G15.7,' & (0,0.5) & ',
     1       ' & (0,0.025), (0.975,1) & ',
     1       A6,2X,A1,A1)
 8125 FORMAT(5X,'Median < ',G15.7,' & (0,0.5) & ',A6,2X,A1,A1)
 8126 FORMAT(5X,'Median > ',G15.7,' & (0,0.5) & ',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
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8122)IBASLC,IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8123)IBASLC,IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8140)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8124)IBASLC,AMU0,ICONC1,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8125)AMU0,ICONC2,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8126)AMU0,ICONC3,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,3211)
 3211   FORMAT('              ONE SAMPLE SIGN TEST')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3213)AMU0
 3213   FORMAT('H0: POPULATION MEDIAN = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3221)N1
 3221   FORMAT('SAMPLE SIZE                        = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3223)INT(RPLUS+0.5)
 3223   FORMAT('NUMBER OF POSITIVE DIFFERENCES     = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3225)INT(RMINUS+0.5)
 3225   FORMAT('NUMBER OF NEGATIVE DIFFERENCES     = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3227)RPCDF
 3227   FORMAT('SIGN TEST STATISTIC CDF VALUE (R+) = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3229)RMCDF
 3229   FORMAT('SIGN TEST STATISTIC CDF VALUE (R-) = ',G15.7)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,3258)
 3258   FORMAT(12X,
     1  '               ALTERNATIVE-                    ALTERNATIVE-')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3259)
 3259   FORMAT(
     1  'ALTERNATIVE-   ',12X,
     1  'HYPOTHESIS                     HYPOTHESIS')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3261)
 3261   FORMAT(
     1  'HYPOTHESIS     ',12X,
     1  'ACCEPTANCE INTERVAL            CONCLUSION')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3263)AMU0,ICONC2
 3263   FORMAT(
     1  'MEDIAN <> ',G15.7,
     1  '  R+: (0,0.025), R-: (0,0.025)   ',A6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3262)AMU0,ICONC1
 3262   FORMAT(
     1  'MU1 <     ',G15.7,
     1  '  (R+) (0,0.05)                  ',A6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3264)AMU0,ICONC3
 3264   FORMAT(
     1  'MU1 >     ',G15.7,
     1  '  (R-) (0,0.05)                  ',A6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
 3290   CONTINUE
      ENDIF
      ENDIF
C
      GOTO9000
C
C
C               *********************************
C               **  STEP 41--                  **
C               **  CARRY OUT CALCULATIONS     **
C               **  FOR A 2-SAMPLE SIGN TEST   **
C               *********************************
C
 4100 CONTINUE
C
      ISTEPN='41'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SIG2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IWRITE='OFF'
C
      NTEMP=0
      RMINUS=0.0
      RPLUS=0.0
      DO4200I=1,N1
        ADIFF=Y1(I) - Y2(I) - D0
        IF(ADIFF.LT.0.0)THEN
          NTEMP=NTEMP+1
          RMINUS=RMINUS+1.0
        ELSEIF(ADIFF.GT.0.0)THEN
          NTEMP=NTEMP+1
          RPLUS=RPLUS+1.0
        ENDIF
 4200 CONTINUE
      CALL BINCDF(RMINUS,0.5,NTEMP,RMCDF)
      CALL BINCDF(RPLUS,0.5,NTEMP,RPCDF)
C
      ICONC1='REJECT'
      ICONC2='REJECT'
      ICONC3='REJECT'
C
CCCCC AUGUST 2002.  FIX FOLLOWING LINES
CCCCC IF(RPCDF.GT.0.05)ICONC1='ACCEPT'
CCCCC IF(RPCDF.GT.0.05 .AND. RPCDF.LT.0.950)ICONC2='ACCEPT'
CCCCC IF(RPCDF.GT.0.025 .AND. RPCDF.LT.0.975)ICONC2='ACCEPT'
CCCCC IF(RMCDF.GT.0.05)ICONC3='ACCEPT'
C
      IF(RPCDF.LE.0.05)ICONC1='ACCEPT'
      IF(RMCDF.LE.0.05)ICONC3='ACCEPT'
      IF(RPCDF.LE.0.025 .OR. RMCDF.LE.0.025)ICONC2='ACCEPT'
C
      STATV1=RPLUS
      STATV2=RMINUS
      STATC1=RPCDF
      STATC2=RMCDF
      CALL BINPPF(.050,0.5,NTEMP,CUTL90)
      CALL BINPPF(.950,0.5,NTEMP,CUTU90)
      CALL BINPPF(.025,0.5,NTEMP,CUTL95)
      CALL BINPPF(.975,0.5,NTEMP,CUTU95)
      CALL BINPPF(.005,0.5,NTEMP,CUTL99)
      CALL BINPPF(.995,0.5,NTEMP,CUTU99)
C
C               *********************************
C               **   STEP 42--                 **
C               **   WRITE OUT EVERYTHING      **
C               **   FOR A 2-SAMPLE SIGN TEST  **
C               *********************************
C
      ISTEPN='42'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SIG2')
     1CALL 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
 5501   FORMAT('
') WRITE(ICOUT,5501) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C C STEP 2: START TABLE AND DEFINE A CAPTION C 5511 FORMAT('') 5594 FORMAT('

') WRITE(ICOUT,5591) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5593) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5594) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) C C STEP 2: START TABLE AND DEFINE A CAPTION C 5611 FORMAT('

') 5694 FORMAT('
')
        WRITE(ICOUT,5691)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5693)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5694)
        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
 8501 FORMAT(A1,'end{verbatim}')
 8503 FORMAT(A1,'begin{table}')
 8507 FORMAT(5X,'$ ',A1,1X,A1,' $ ',A1,A1,' ')
 8509 FORMAT(A1,'begin{center}')
 8511 FORMAT(5X,'{',A1,'bf TWO SAMPLE (PAIRED) SIGN TEST}')
 8513 FORMAT(A1,'end{center}')
 8515 FORMAT(5X,'} ',A1,A1)
C
        CALL DPCONA(92,IBASLC)
C
        WRITE(ICOUT,8501)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8503)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8509)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8511)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8507)IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8507)IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8513)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
C STEP 2: START TABULAR ENVIRONMENT, WRITE SUBSESQUENT ROWS, END
C         TABULAR ENVIRONMENT
C
 8520 FORMAT(5X,A1,'begin{tabular} {lcr}')
 8521 FORMAT(5X,'$H_0$: $Median_1$ & = & $Median_2$ ',
     1       2X,A1,A1)
88521 FORMAT(5X,'$H_0$: $Median_1$ - $Median_2$ & eq & ',
     1       G15.7,2X,A1,A1)
 8522 FORMAT(5X,'$H_a$: $Median_1$ & ',A1,'ne & $Median_2$ ',
     1       2X,A1,A1)
88522 FORMAT(5X,'$H_a$: $Median_1$ - $Median_2$ & ',A1,'ne & ',
     1       G15.7,2X,A1,A1)
 8523 FORMAT(5X,' &   & ',2X,A1,A1)
 8524 FORMAT(5X,'{',A1,'bf Sample:} &   & ',2X,A1,A1)
 8525 FORMAT(5X,'Number of Observations & = & ',I8,2X,A1,A1)
 8526 FORMAT(5X,'Number of Positive Differences & = & ',I8,2X,A1,A1)
 8527 FORMAT(5X,'Number of Negative Differences & = & ',I8,2X,A1,A1)
 8528 FORMAT(5X,'Sign Test Statistic CDF Value (R+) & = & ',
     1       G15.7,2X,A1,A1)
 8529 FORMAT(5X,'Sign Test Statistic CDF Value (R-) & = & ',
     1       G15.7,2X,A1,A1)
 8540 FORMAT(5X,A1,'hline')
 8549 FORMAT(A1,'end{tabular}')
        WRITE(ICOUT,8509)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8520)IBASLC
        CALL DPWRST('XXX','WRIT')
        IF(D0.EQ.0.0)THEN
          WRITE(ICOUT,8521)IBASLC,IBASLC
        ELSE
          WRITE(ICOUT,88521)D0,IBASLC,IBASLC
        ENDIF
        CALL DPWRST('XXX','WRIT')
        IF(D0.EQ.0.0)THEN
          WRITE(ICOUT,8522)IBASLC,IBASLC,IBASLC
        ELSE
          WRITE(ICOUT,88522)IBASLC,D0,IBASLC,IBASLC
        ENDIF
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8523)IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8524)IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8525)N1,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8526)INT(RPLUS+0.5),IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8527)INT(RMINUS+0.5),IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8528)RPCDF,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8529)RMCDF,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8549)IBASLC
        CALL DPWRST('XXX','WRIT')
C
C STEP 3: END TABLE ENVIRONMENT, RESET ASIS MODE
C
 8591 FORMAT(A1,'end{center}')
        WRITE(ICOUT,8591)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
C  STEP 1: START TABLE ENVIRONMENT, WRITE A HEADER, AND
C          WRITE A TABLE CAPTION
C
 8609 FORMAT(A1,'begin{center}')
 8613 FORMAT(A1,'end{center}')
 8615 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
 8620 FORMAT(5X,A1,'begin{tabular} {ccc}')
 8621 FORMAT(5X,'& {',A1,'bf Alternative} & {',A1,
     1       'bf Alternative}',2X,A1,A1)
 8622 FORMAT(5X,'{',A1,'bf Alternative} & {',A1,
     1       'bf Hypothesis} & {',A1,'bf Hypothesis}',
     1       2X,A1,A1)
 8623 FORMAT(5X,'{',A1,'bf Hypothesis} & {',A1,
     1       'bf Acceptance Interval} & {',A1,
     1       'bf Conclusion}',2X,A1,A1)
 8624 FORMAT(5X,'$Median_1 ',A1,'ne Median_2$ ',' & (0,0.5) & ',
     1       ' & (0,0.025), (0.975,1) & ',
     1       A6,2X,A1,A1)
88624 FORMAT(5X,'$Median_1 - Median_2 ',A1,'ne $ ',G15.7,
     1       ' & (0,0.5) & ',
     1       ' & (0,0.025), (0.975,1) & ',
     1       A6,2X,A1,A1)
 8625 FORMAT(5X,'$Median_1$ < $Median_2$ & (0,0.5) & ',A6,2X,A1,A1)
88625 FORMAT(5X,'$Median_1$ - $Median_2$ < ',G15.7,
     1       ' & (0,0.5) & ',A6,2X,A1,A1)
 8626 FORMAT(5X,'$Median_1$ > $Median_2$ & (0,0.5) & ',A6,2X,A1,A1)
88626 FORMAT(5X,'$Median_1$ - $Median_2$ > ',G15.7,
     1       ' & (0,0.5) & ',A6,2X,A1,A1)
 8640 FORMAT(5X,A1,'hline')
 8649 FORMAT(A1,'end{tabular}')
        WRITE(ICOUT,8609)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8620)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8621)IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8622)IBASLC,IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8623)IBASLC,IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8640)IBASLC
        CALL DPWRST('XXX','WRIT')
        IF(D0.EQ.0.0)THEN
          WRITE(ICOUT,8624)IBASLC,ICONC1,IBASLC,IBASLC
        ELSE
          WRITE(ICOUT,88624)IBASLC,D0,ICONC1,IBASLC,IBASLC
        ENDIF
        CALL DPWRST('XXX','WRIT')
        IF(D0.EQ.0.0)THEN
          WRITE(ICOUT,8625)ICONC1,IBASLC,IBASLC
        ELSE
          WRITE(ICOUT,88625)D0,ICONC1,IBASLC,IBASLC
        ENDIF
        CALL DPWRST('XXX','WRIT')
        IF(D0.EQ.0.0)THEN
          WRITE(ICOUT,8626)ICONC1,IBASLC,IBASLC
        ELSE
          WRITE(ICOUT,88626)D0,ICONC1,IBASLC,IBASLC
        ENDIF
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8649)IBASLC
        CALL DPWRST('XXX','WRIT')
C
C STEP 3: END TABLE ENVIRONMENT, RESET ASIS MODE
C
 8691 FORMAT(A1,'end{center}')
 8693 FORMAT(A1,'end{table}')
 8699 FORMAT(A1,'begin{verbatim}')
        WRITE(ICOUT,8691)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8693)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8699)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(
     1  '           TWO SAMPLE (PAIRED) SIGN TEST')
        CALL DPWRST('XXX','WRIT')
        IF(D0.EQ.0.0)THEN
          WRITE(ICOUT,4213)
 4213     FORMAT('H0: TWO POPULATION MEDIANS ARE EQUAL')
          CALL DPWRST('XXX','WRIT')
        ELSE
          WRITE(ICOUT,4215)D0
 4215     FORMAT('H0: THE DIFFERENCE OF TWO POPULATION MEDIANS = ',
     1           G15.7)
          CALL DPWRST('XXX','WRIT')
        ENDIF
        WRITE(ICOUT,4221)N1
 4221   FORMAT('SAMPLE SIZE                        = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4223)INT(RPLUS+0.5)
 4223   FORMAT('NUMBER OF POSITIVE DIFFERENCES     = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4225)INT(RMINUS+0.5)
 4225   FORMAT('NUMBER OF NEGATIVE DIFFERENCES     = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4227)RPCDF
 4227   FORMAT('SIGN TEST STATISTIC CDF VALUE (R+) = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4229)RMCDF
 4229   FORMAT('SIGN TEST STATISTIC CDF VALUE (R-) = ',G15.7)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,4258)
 4258   FORMAT(8X,
     1'               ALTERNATIVE-                   ALTERNATIVE-')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4259)
 4259   FORMAT(
     1  'ALTERNATIVE-',11X,
     1  'HYPOTHESIS                     HYPOTHESIS')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4261)
 4261   FORMAT(
     1  'HYPOTHESIS',13X,
     1  'ACCEPTANCE INTERVAL            CONCLUSION')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4263)ICONC2
 4263   FORMAT(
     1  'MEDIAN1 <> MEDIAN2     R+: (0,0.025), R-: (0,0.025)   ',A6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4262)ICONC1
 4262   FORMAT(
     1  'MEDIAN1 < MEDIAN2      (R+) (0,0.05)                  ',A6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4264)ICONC3
 4264   FORMAT(
     1  'MEIDAN1 > MEDIAN2      (R-) (0,0.05)                  ',A6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
 4290   CONTINUE
      ENDIF
      ENDIF
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'SIGN')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPSIG2--')
      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,9013)AMU0,D0,NUMVAR,ILOCV
 9013 FORMAT('AMU0,D0,NUMVAR,ILOCV = ',2E15.7,I8,I8)
      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 DPSIIS(ISTART,IW,NW,IHOUT,NOUT,IBUGA3,IERROR)
C
C     PURPOSE--INSERT A STRING INTO IW.
C              THE STRING IS LOCATED IN IHOUT(.).
C              THE LOCATION IN IW(.) WHERE THE STRING
C              IS TO BE INSERTED IS AT ISTART.
C              THE CONTENTS OF IW(ISTART) WILL BE OVERWRITTEN.
C              THE CONTENTS OF IW(ISTART+1), IW(ISTART+2), ETC.
C              WILL BE DISPLACED ACCORDING TO THE LENGTH
C              OF THE INSERTED STRING.
C     NOTE--THE INPUT ARGUMENTS IW(.) AND NW
C           AND ALTERED BY THIS SUBROUTINE.
C     NOTE--IF NOUT = 0 OR NEGATIVE, THEN THE CONVENTION
C           HAS BEEN TAKEN TO SHIFT THE REMAINING
C           STRING IN IW(.) STARTING AT ISTART+1
C           OVER 1 LOCATION SO THAT IT WOULD THEN
C           START AT ISTART.
C     ORIGINAL VERSION--JANUARY   1979.
C     UPDATED         --JANUARY   1981.
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IW
      CHARACTER*4 IHOUT
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
      DIMENSION IW(*)
      DIMENSION IHOUT(*)
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='DPSI'
      ISUBN2='IS  '
C
      IERROR='NO'
C
      ISHIFT=(-999)
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,81)
   81 FORMAT('***** AT THE BEGINNING OF DPSIIS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,82)ISTART,NW,NOUT
   82 FORMAT('ISTART,NW,NOUT = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,83)(IHOUT(I),I=1,NOUT)
   83 FORMAT('(IHOUT(.) = ',100A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,84)(IW(I),I=1,NW)
   84 FORMAT('(IW(.) = ',100A1)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               *****************************
C               **  STEP 1--               **
C               **  INSERT    THE STRING.  **
C               *****************************
C
      IF(NOUT.GE.0)ISHIFT=NOUT-1
      IF(NOUT.LT.0)ISHIFT=(-1)
      IMIN=ISTART+1
      IMAX=NW
      IF(IMIN.GT.IMAX)GOTO150
      DO100I=IMIN,IMAX
      IPS=I+ISHIFT
      IREV=IMAX-I+IMIN
      IREVPS=IREV+ISHIFT
      IF(IREVPS.GE.IREV)IW(IREVPS)=IW(IREV)
      IF(IREVPS.LT.IREV)IW(IPS)=IW(I)
  100 CONTINUE
  150 CONTINUE
      NW=NW+ISHIFT
C
      J=ISTART-1
      IF(NOUT.LE.0)GOTO250
      DO200I=1,NOUT
      J=J+1
      IW(J)=IHOUT(I)
  200 CONTINUE
  250 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPSIIS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)NW
 9012 FORMAT('NW = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)(IW(I),I=1,NW)
 9013 FORMAT('(IW(.) = ',115A1)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPSING(IHARG,NUMARG,IDEFPR,IHMXPR,
     1IPREC,IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE PREICSION SWITCH
C              AS SINGLE PRECISION.
C              THIS IN TURN SPECIFIES THAT SUBSEQUENT
C              CALCULATIONS WILL ALL BE CARRIED OUT
C              IN SINGLE PRECISION.
C              THE SPECIFIED PRECISION SWITCH SPECIFICATION
C              WILL BE PLACED IN THE HOLLERITH VARIABLE IPREC.
C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
C                     --NUMARG (AN INTEGER VARIABLE)
C                     --IDEFPR (A  HOLLERITH VARIABLE)
C                     --IHMXPR (A  HOLLERITH VARIABLE)
C     OUTPUT ARGUMENTS--IPREC  (A HOLLERITH VARIABLE)
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1980.
C     UPDATED         --SEPTEMBER 1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IDEFPR
      CHARACTER*4 IHMXPR
      CHARACTER*4 IPREC
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IHOLD
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IFOUND='NO'
      IERROR='NO'
C
      IFOUND='YES'
C
 1110 CONTINUE
      IF(NUMARG.LE.0)GOTO1120
      IF(IHARG(NUMARG).EQ.'ON')GOTO1130
      IF(IHARG(NUMARG).EQ.'OFF')GOTO1120
      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1130
      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1120
      GOTO1130
C
 1120 CONTINUE
      IHOLD=IDEFPR
      GOTO1160
C
 1130 CONTINUE
      IHOLD='SING'
      GOTO1160
C
 1160 CONTINUE
      IF(IHOLD.EQ.'DOUB'.AND.IHMXPR.EQ.'SING')GOTO1170
      IF(IHOLD.EQ.'TRIP'.AND.IHMXPR.EQ.'SING')GOTO1170
      IF(IHOLD.EQ.'TRIP'.AND.IHMXPR.EQ.'DOUB')GOTO1170
      IF(IHOLD.EQ.'QUAD'.AND.IHMXPR.EQ.'SING')GOTO1170
      IF(IHOLD.EQ.'QUAD'.AND.IHMXPR.EQ.'DOUB')GOTO1170
      IF(IHOLD.EQ.'QUAD'.AND.IHMXPR.EQ.'TRIP')GOTO1170
      GOTO1180
C
 1170 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1172)
 1172 FORMAT('***** ERROR IN DPSING--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1173)
 1173 FORMAT('      THE DESIRED PRECISION IS HIGHER')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1174)
 1174 FORMAT('      THAN PERMITTED ON THIS COMPUTER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1175)IHOLD
 1175 FORMAT('      DESIRED PRECISION           = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1176)IHMXPR
 1176 FORMAT('      MAXIMUM ALLOWABLE PRECISION = ',A4)
      CALL DPWRST('XXX','BUG ')
      GOTO1199
C
 1180 CONTINUE
      IPREC=IHOLD
C
      IF(IFEEDB.EQ.'OFF')GOTO1189
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1188)IPREC
 1188 FORMAT('THE PRECISION SWITCH HAS JUST BEEN SET TO ',
     1A4)
      CALL DPWRST('XXX','BUG ')
 1189 CONTINUE
      GOTO1199
C
 1199 CONTINUE
      RETURN
      END
      SUBROUTINE DPSIP0(IW,NW,IBUGA3,IERROR)
C
C     PURPOSE--ELIMINATE SUPERFLUOUS MULTIPLICATIONS
C              (BUT NOT DIVISIONS) BY 0 AND BY (0)   .
C     NOTE--THE INPUT ARGUEMNTS IW(.) AND NW
C           ARE ALTERED BY THIS SUBROUTINE.
C     ORIGINAL VERSION--JANUARY   1979.
C     UPDATED         --JANUARY   1981.
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IW
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISTEPN
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
      CHARACTER*4 IFOUND
C
      DIMENSION IW(*)
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='DPSI'
      ISUBN2='P0  '
C
      IERROR='NO'
      IMIN=1
      I2=1
      IM1=1
      IP1=1
      KREV=1
      K2=1
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 DPSIP0--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)NW
   52 FORMAT('NW = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NW
      WRITE(ICOUT,56)I,IW(I)
   56 FORMAT('I,IW(I) = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               *****************************************
C               **  STEP 1--                           **
C               **  SET UP A LARGE DO LOOP             **
C               **  FOR MULTIPLE PASSES THROUGH IW(.)  **
C               **  FOR THE SEARCH FOR    1    .       **
C               *****************************************
C
      IFOUND='NO'
      NUMPAS=1000
      DO1100IPASS=1,NUMPAS
      ISTEPN='1100'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C               ****************************
C               **  STEP 2--              **
C               **  SEARCH FOR    0    .  **
C               ****************************
C
      NWM1=NW-1
      NWP1=NW+1
C
      IF(IPASS.EQ.1)IMIN=1
      IF(IPASS.GE.2.AND.IFOUND.EQ.'YES')IMIN=I2
      IF(IPASS.GE.2.AND.IFOUND.EQ.'NO')IMIN=I2+1
      IFOUND='NO'
      IF(IMIN.GE.NWP1)GOTO1990
      DO200I=IMIN,NW
      I2=I
      IF(IW(I).EQ.'0   ')GOTO210
  200 CONTINUE
      GOTO990
C
  210 CONTINUE
      ISTEPN='210'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      I=I2
      IM1=I-1
      IM2=I-2
      IM3=I-3
      IP1=I+1
      IP2=I+2
      IP3=I+3
C
C               ***********************************
C               **  STEP 3--                     **
C               **  TEST FOR THE    *0    CASE.  **
C               ***********************************
C
      IF(IM1.LE.0)GOTO390
      IF(IM1.EQ.1.AND.IW(IM1).EQ.'*   ')GOTO310
      IF(IM1.GE.2.AND.IW(IM1).EQ.'*   '.AND.IW(IM2).NE.'*   ')GOTO310
CCCCC IF(IW(IM1).EQ.'/   ')GOTO310
      GOTO100
C
  310 CONTINUE
      ISTEPN='310'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IF(IP1.GE.NWP1)GOTO320
      IF(IW(IP1).EQ.'+   ')GOTO320
      IF(IW(IP1).EQ.'-   ')GOTO320
      IF(IP1.EQ.NW.AND.IW(IP1).EQ.'*   ')GOTO320
      IF(IP1.LE.NWM1.AND.IW(IP1).EQ.'*   '.AND.IW(IP2).NE.'*   ')GOTO320
      IF(IW(IP1).EQ.'/   ')GOTO320
      IF(IW(IP1).EQ.')   ')GOTO320
      GOTO100
C
  320 CONTINUE
      ISTEPN='320'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IB=IM1
      IRIGHT=IB-1
      IF(IRIGHT.LE.0)GOTO100
      ILEFT=IRIGHT
      IF(IW(IRIGHT).EQ.')   ')GOTO333
      GOTO339
  333 CONTINUE
      ISTEPN='333'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      ISUM=0
      DO335K=1,IRIGHT
      KREV=IRIGHT-K+1
      IF(IW(KREV).EQ.')   ')ISUM=ISUM+1
      IF(IW(KREV).EQ.'(   ')ISUM=ISUM-1
      IF(ISUM.EQ.0)GOTO337
  335 CONTINUE
      ILEFT=0
  337 CONTINUE
      ILEFT=KREV
  339 CONTINUE
      ISTEPN='339'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ISTART=ILEFT+1
      ISTOP=I
      CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR)
      I2=ISTART-1
      IW(I2)='0   '
      IFOUND='YES'
      GOTO1100
C
  390 CONTINUE
      ISTEPN='390'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C               ***********************************
C               **  STEP 4--                     **
C               **  TEST FOR THE    0*    CASE.  **
C               ***********************************
C
      IF(IP1.GE.NWP1)GOTO490
      IF(IP1.EQ.NW.AND.IW(IP1).EQ.'*   ')GOTO410
      IF(IP1.LE.NWM1.AND.IW(IP1).EQ.'*   '.AND.IW(IP2).NE.'*   ')GOTO410
      IF(IW(IP1).EQ.'/   ')GOTO410
      GOTO100
C
  410 CONTINUE
      ISTEPN='410'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IF(IM1.LE.0)GOTO420
      IF(IW(IM1).EQ.'+   ')GOTO420
      IF(IW(IM1).EQ.'-   ')GOTO420
      IF(IM1.EQ.1.AND.IW(IM1).EQ.'*   ')GOTO420
      IF(IM1.GE.2.AND.IW(IM1).EQ.'*   '.AND.IW(IM2).NE.'*   ')GOTO420
CCCCC IF(IW(IM1).EQ.'/   ')GOTO420
      IF(IW(IM1).EQ.'(   ')GOTO420
      GOTO100
C
  420 CONTINUE
      ISTEPN='420'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IB=IP1
      ILEFT=IB+1
      IF(ILEFT.GE.NWP1)GOTO100
      IRIGHT=ILEFT
      IF(IW(ILEFT).EQ.'(   ')GOTO433
      GOTO439
  433 CONTINUE
      ISTEPN='433'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      ISUM=0
      DO435K=ILEFT,NW
      K2=K
      IF(IW(K).EQ.'(   ')ISUM=ISUM-1
      IF(IW(K).EQ.')   ')ISUM=ISUM+1
      IF(ISUM.EQ.0)GOTO437
  435 CONTINUE
      IRIGHT=NW+1
  437 CONTINUE
      IRIGHT=K2
  439 CONTINUE
      ISTEPN='439'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ISTART=I+1
      ISTOP=IRIGHT
      CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR)
      I2=ISTART-1
      IW(I2)='0   '
      IFOUND='YES'
      GOTO1100
C
  490 CONTINUE
      ISTEPN='490'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
  100 CONTINUE
      ISTEPN='100'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
  990 CONTINUE
      ISTEPN='990'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NWM1=NW-1
      IF(IM1.LE.0)GOTO1100
      IF(IP1.GE.NWP1)GOTO1100
      IF(IW(IM1).EQ.'(   '.AND.IW(I).EQ.'0   '.AND.
     1   IW(IP1).EQ.')   ')GOTO1210
      GOTO1100
C
 1210 CONTINUE
      ISTEPN='1210'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IM1=I-1
      IM2=I-2
      IM3=I-3
      IP1=I+1
      IP2=I+2
      IP3=I+3
C
C               ***********************************
C               **  STEP 13--                    **
C               **  TEST FOR THE   *(0)   CASE.  **
C               ***********************************
C
      IF(IM2.LE.0)GOTO1390
      IF(IM2.EQ.1.AND.IW(IM2).EQ.'*   ')GOTO1310
      IF(IM2.GE.2.AND.IW(IM2).EQ.'*   '.AND.IW(IM3).NE.'*   ')GOTO1310
CCCCC IF(IW(IM2).EQ.'/   ')GOTO1310
      GOTO1100
C
 1310 CONTINUE
      ISTEPN='1310'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IF(IP2.GE.NWP1)GOTO1320
      IF(IW(IP2).EQ.'+   ')GOTO1320
      IF(IW(IP2).EQ.'-   ')GOTO1320
      IF(IP2.EQ.NW.AND.IW(IP2).EQ.'*   ')GOTO1320
      IF(IP2.LE.NWM1.AND.IW(IP2).EQ.'*   '.AND.IW(IP3).NE.'*   ')
     1GOTO1320
      IF(IW(IP2).EQ.'/   ')GOTO1320
      IF(IW(IP2).EQ.')   ')GOTO1320
      GOTO1100
C
 1320 CONTINUE
      ISTEPN='1320'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IB=IM2
      IRIGHT=IB-1
      IF(IRIGHT.LE.0)GOTO1100
      ILEFT=IRIGHT
      IF(IW(IRIGHT).EQ.')   ')GOTO1333
      GOTO1339
 1333 CONTINUE
      ISTEPN='1333'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      ISUM=0
      DO1335K=1,IRIGHT
      KREV=IRIGHT-K+1
      IF(IW(KREV).EQ.')   ')ISUM=ISUM+1
      IF(IW(KREV).EQ.'(   ')ISUM=ISUM-1
      IF(ISUM.EQ.0)GOTO1337
 1335 CONTINUE
      ILEFT=0
 1337 CONTINUE
      ILEFT=KREV
 1339 CONTINUE
      ISTEPN='1339'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ISTART=ILEFT+1
      ISTOP=IP1
      CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR)
      I2=ISTART-1
      IW(I2)='0   '
      IFOUND='YES'
      GOTO1100
C
 1390 CONTINUE
      ISTEPN='1390'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C               ***********************************
C               **  STEP 14--                    **
C               **  TEST FOR THE   (0)*   CASE.  **
C               ***********************************
C
      IF(IP2.GE.NWP1)GOTO1490
      IF(IP2.EQ.NW.AND.IW(IP2).EQ.'*   ')GOTO1410
      IF(IP2.LE.NWM1.AND.IW(IP2).EQ.'*   '.AND.IW(IP3).NE.'*   ')
     1GOTO1410
      IF(IW(IP2).EQ.'/   ')GOTO1410
      GOTO1100
C
 1410 CONTINUE
      ISTEPN='1410'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IF(IM2.LE.0)GOTO1420
      IF(IW(IM2).EQ.'+   ')GOTO1420
      IF(IW(IM2).EQ.'-   ')GOTO1420
      IF(IM2.EQ.1.AND.IW(IM2).EQ.'*   ')GOTO1420
      IF(IM2.GE.2.AND.IW(IM2).EQ.'*   '.AND.IW(IM3).NE.'*   ')GOTO1420
CCCCC IF(IW(IM2).EQ.'/   ')GOTO1420
      IF(IW(IM2).EQ.'(   ')GOTO1420
      GOTO1100
C
 1420 CONTINUE
      ISTEPN='1420'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IB=IP2
      ILEFT=IB+1
      IF(ILEFT.GE.NWP1)GOTO1100
      IRIGHT=ILEFT
      IF(IW(ILEFT).EQ.'(   ')GOTO1433
      GOTO1439
 1433 CONTINUE
      ISTEPN='1433'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      ISUM=0
      DO1435K=ILEFT,NW
      K2=K
      IF(IW(K).EQ.'(   ')ISUM=ISUM-1
      IF(IW(K).EQ.')   ')ISUM=ISUM+1
      IF(ISUM.EQ.0)GOTO1437
 1435 CONTINUE
      IRIGHT=NW+1
 1437 CONTINUE
      IRIGHT=K2
 1439 CONTINUE
      ISTEPN='1439'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ISTART=I
      ISTOP=IRIGHT
      CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR)
      I2=ISTART-1
      IW(I2)='0   '
      IFOUND='YES'
      GOTO1100
C
 1490 CONTINUE
      ISTEPN='1490'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
 1100 CONTINUE
      ISTEPN='1101'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
 1990 CONTINUE
      ISTEPN='1990'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPSIP0--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)NW
 9012 FORMAT('NW = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NW
      WRITE(ICOUT,9016)I,IW(I)
 9016 FORMAT('I,IW(I) = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPSIP1(IW,NW,IBUGA3,IERROR)
C
C     PURPOSE--ELIMINATE SUPERFLUOUS MULTIPLICATIONS
C              (AND DIVISIONS) BY 1 AND BY (1)   .
C     NOTE--THE INPUT ARGUEMNTS IW(.) AND NW
C           ARE ALTERED BY THIS SUBROUTINE.
C     ORIGINAL VERSION--JANUARY   1979.
C     UPDATED         --JANUARY   1981.
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IW
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
      DIMENSION IW(*)
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='DPSI'
      ISUBN2='P1  '
C
      IERROR='YES'
C
      IMIN=1
      I2=1
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 DPSIP1--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)NW
   52 FORMAT('NW = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NW
      WRITE(ICOUT,56)I,IW(I)
   56 FORMAT('I,IW(I) = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               *****************************************
C               **  STEP 1--                           **
C               **  SET UP A LARGE DO LOOP             **
C               **  FOR MULTIPLE PASSES THROUGH IW(.) **
C               **  FOR THE SEARCH FOR    1    .       **
C               *****************************************
C
      NUMPAS=1000
      DO100IPASS=1,NUMPAS
C
C               ****************************
C               **  STEP 2--              **
C               **  SEARCH FOR    1    .  **
C               ****************************
C
      NWM1=NW-1
      NWP1=NW+1
C
      IF(IPASS.EQ.1)IMIN=1
      IF(IPASS.GE.2)IMIN=I2+1
      IF(IMIN.GE.NWP1)GOTO990
      DO200I=IMIN,NW
      I2=I
      IF(IW(I).EQ.'1   ')GOTO210
  200 CONTINUE
      GOTO990
C
  210 CONTINUE
      I=I2
      IM1=I-1
      IM2=I-2
      IM3=I-3
      IP1=I+1
      IP2=I+2
      IP3=I+3
C
C               ***********************************
C               **  STEP 3--                     **
C               **  TEST FOR THE    *1    CASE.  **
C               ***********************************
C
      IF(IM1.LE.0)GOTO390
      IF(IM1.EQ.1.AND.IW(IM1).EQ.'*   ')GOTO310
      IF(IM1.GE.2.AND.IW(IM1).EQ.'*   '.AND.IW(IM2).NE.'*   ')GOTO310
      IF(IW(IM1).EQ.'/   ')GOTO310
      GOTO100
C
  310 CONTINUE
      IF(IP1.GE.NWP1)GOTO320
      IF(IW(IP1).EQ.'+   ')GOTO320
      IF(IW(IP1).EQ.'-   ')GOTO320
      IF(IP1.EQ.NW.AND.IW(IP1).EQ.'*   ')GOTO320
      IF(IP1.LE.NWM1.AND.IW(IP1).EQ.'*   '.AND.IW(IP2).NE.'*   ')GOTO320
      IF(IW(IP1).EQ.'/   ')GOTO320
      IF(IW(IP1).EQ.')   ')GOTO320
      GOTO100
C
  320 CONTINUE
      ISTART=IM1
      ISTOP=I
      CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR)
      I2=ISTART-1
      GOTO100
C
  390 CONTINUE
C
C               ***********************************
C               **  STEP 4--                     **
C               **  TEST FOR THE    1*    CASE.  **
C               ***********************************
C
      IF(IP1.GE.NWP1)GOTO490
      IF(IP1.EQ.NW.AND.IW(IP1).EQ.'*   ')GOTO410
      IF(IP1.LE.NWM1.AND.IW(IP1).EQ.'*   '.AND.IW(IP2).NE.'*   ')GOTO410
      GOTO100
C
  410 CONTINUE
      IF(IM1.LE.0)GOTO420
      IF(IW(IM1).EQ.'+   ')GOTO420
      IF(IW(IM1).EQ.'-   ')GOTO420
      IF(IM1.EQ.1.AND.IW(IM1).EQ.'*   ')GOTO420
      IF(IM1.GE.2.AND.IW(IM1).EQ.'*   '.AND.IW(IM2).NE.'*   ')GOTO420
      IF(IW(IM1).EQ.'/   ')GOTO420
      IF(IW(IM1).EQ.'(   ')GOTO420
      GOTO100
C
  420 CONTINUE
      ISTART=I
      ISTOP=IP1
      CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR)
      I2=ISTART-1
      GOTO100
C
  490 CONTINUE
C
  100 CONTINUE
C
  990 CONTINUE
C
C               *****************************************
C               **  STEP 11--                          **
C               **  SET UP A LARGE DO LOOP             **
C               **  FOR MULTIPLE PASSES THROUGH IW(.) **
C               **  FOR THE SEARCH FOR    (1)    .     **
C               *****************************************
C
      NUMPAS=1000
      DO1100IPASS=1,NUMPAS
C
C               ****************************
C               **  STEP 12--             **
C               **  SEARCH FOR   (1)   .  **
C               ****************************
C
      NWM1=NW-1
      NWP1=NW+1
C
      IF(IPASS.EQ.1)IMIN=1
      IF(IPASS.GE.2)IMIN=I2+1
      NWM1=NW-1
      IF(IMIN.LE.0)GOTO1990
CCCCC IF(IMIN.GE.NWP1M1)GOTO1990
      IF(IMIN.GE.NW)GOTO1990
      DO1200I=IMIN,NWM1
      I2=I
      IM1=I-1
      IP1=I+1
      IF(IW(IM1).EQ.'(   '.AND.IW(I).EQ.'1   '.AND.
     1   IW(IP1).EQ.')   ')GOTO1210
 1200 CONTINUE
      GOTO1990
C
 1210 CONTINUE
      I=I2
      IM1=I-1
      IM2=I-2
      IM3=I-3
      IP1=I+1
      IP2=I+2
      IP3=I+3
C
C               ***********************************
C               **  STEP 13--                    **
C               **  TEST FOR THE   *(1)   CASE.  **
C               ***********************************
C
      IF(IM2.LE.0)GOTO1390
      IF(IM2.EQ.1.AND.IW(IM2).EQ.'*   ')GOTO1310
      IF(IM2.GE.2.AND.IW(IM2).EQ.'*   '.AND.IW(IM3).NE.'*   ')GOTO1310
      IF(IW(IM2).EQ.'/   ')GOTO1310
      GOTO1100
C
 1310 CONTINUE
      IF(IP2.GE.NWP1)GOTO1320
      IF(IW(IP2).EQ.'+   ')GOTO1320
      IF(IW(IP2).EQ.'-   ')GOTO1320
      IF(IP2.EQ.NW.AND.IW(IP2).EQ.'*   ')GOTO1320
      IF(IP2.LE.NWM1.AND.IW(IP2).EQ.'*   '.AND.IW(IP3).NE.'*   ')
     1GOTO1320
      IF(IW(IP2).EQ.'/   ')GOTO1320
      IF(IW(IP2).EQ.')   ')GOTO1320
      GOTO1100
C
 1320 CONTINUE
      ISTART=IM2
      ISTOP=IP1
      CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR)
      I2=ISTART-1
      GOTO1100
C
 1390 CONTINUE
C
C               ***********************************
C               **  STEP 14--                    **
C               **  TEST FOR THE   (1)*   CASE.  **
C               ***********************************
C
      IF(IP2.GE.NWP1)GOTO1490
      IF(IP2.EQ.NW.AND.IW(IP2).EQ.'*   ')GOTO1410
      IF(IP2.LE.NWM1.AND.IW(IP2).EQ.'*   '.AND.IW(IP3).NE.'*   ')
     1GOTO1410
      GOTO1100
C
 1410 CONTINUE
      IF(IM2.LE.0)GOTO1420
      IF(IW(IM2).EQ.'+   ')GOTO1420
      IF(IW(IM2).EQ.'-   ')GOTO1420
      IF(IM2.EQ.1.AND.IW(IM2).EQ.'*   ')GOTO1420
      IF(IM2.GE.2.AND.IW(IM2).EQ.'*   '.AND.IW(IM3).NE.'*   ')
     1GOTO1420
      IF(IW(IM2).EQ.'/   ')GOTO1420
      IF(IW(IM2).EQ.'(   ')GOTO1420
      GOTO1100
C
 1420 CONTINUE
      ISTART=IM1
      ISTOP=IP2
      CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR)
      I2=ISTART-1
      GOTO1100
C
 1490 CONTINUE
C
 1100 CONTINUE
C
 1990 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPSIP1--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)NW
 9012 FORMAT('NW = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NW
      WRITE(ICOUT,9016)I,IW(I)
 9016 FORMAT('I,IW(I) = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPSIPA(IW,NW,IBUGA3,IERROR)
C
C     PURPOSE--SIMPLIFY AN ENTIRE EXPRESSION BY REMOVING
C              ALL REDUNDANT PARENTHESES.
C     NOTE--THE INPUT ARGUMENTS IW(.) AND NW
C           ARE ALTERED BY THIS SUBROUTINE.
C     ORIGINAL VERSION--JANUARY  1979.
C     UPDATED         --JANUARY   1981.
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IW
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
      DIMENSION IW(*)
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='DPSI'
      ISUBN2='PA  '
C
      IERROR='NO'
      IMIN=1
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 DPSIPA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)NW
   52 FORMAT('NW = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NW
      WRITE(ICOUT,56)I,IW(I)
   56 FORMAT('I,IW(I) = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               *****************************************
C               **  STEP 1--                           **
C               **  SET UP A LARGE DO LOOP             **
C               **  FOR MULTIPLE PASSES THROUGH IW(.)  **
C               *****************************************
C
      NUMPAS=1000
      DO100IPASS=1,NUMPAS
      ISUM=0
C
C               **********************************************
C               **  STEP 3--                                **
C               **  SEARCH FOR THE NEXT RIGHT PARENTHESIS.  **
C               **********************************************
C
      IF(IPASS.EQ.1)IMIN=1
      IF(IPASS.GE.2)IMIN=IRIGHT+1
      IF(IMIN.GT.NW)GOTO9000
C
      DO300I=IMIN,NW
      I2=I
      IF(IW(I).EQ.')   ')GOTO350
  300 CONTINUE
      GOTO9000
  350 CONTINUE
      IRIGHT=I2
      ISUM=ISUM+1
C
C               **********************************************
C               **  STEP 4--                                **
C               **  SEARCH FOR THE NEXT (IN REVERSE ORDER)  **
C               **  LEFT PARENTHESIS.                       **
C               **********************************************
C
      IMAX=IRIGHT-1
      IF(IMAX.LT.1)GOTO9000
C
      DO400I=1,IMAX
      IREV=IMAX-I+1
      IF(IW(IREV).EQ.'(   ')GOTO401
      IF(IW(IREV).EQ.')   ')GOTO402
      GOTO400
  401 CONTINUE
      ISUM=ISUM-1
      IF(ISUM.EQ.0)ILEFT=IREV
      IF(ISUM.EQ.0)GOTO490
      GOTO400
  402 CONTINUE
      ISUM=ISUM+1
      GOTO400
  400 CONTINUE
C
      WRITE(ICOUT,411)
  411 FORMAT('***** ERROR IN DPSIPA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,412)
  412 FORMAT('      NUMBER OF LEFT PARENTHESES DOES NOT EQUAL')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,413)
  413 FORMAT('      NUMBER OF RIGHT PARENTHESES.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,414)
  414 FORMAT('      THE STRING BEING OPERATED ON IS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      DO415I=1,NW
      WRITE(ICOUT,416)I,IW(I)
  416 FORMAT('I,IW(I) = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
  415 CONTINUE
      IERROR='YES'
      GOTO9000
C
  490 CONTINUE
C
C               *************************************
C               **  STEP 5--                       **
C               **  REDUCE REDUNDANT PARENTHESES   **
C               **  IN THIS VICINITY.              **
C               *************************************
C
      CALL DPSIEP(ILEFT,IRIGHT,IW,NW,IBUGA3,IERROR)
C
  100 CONTINUE
C
C               ****************
C               **  STEP 6--  **
C               **  EXIT.     **
C               ****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPSIPA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)NW
 9012 FORMAT('NW = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NW
      WRITE(ICOUT,9016)I,IW(I)
 9016 FORMAT('I,IW(I) = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPSIRS(IW1,NW1,ISTAR1,ISTOP1,IW2,NW2,ISTAR2,ISTOP2,
     1IBUGA3,IERROR)
C
C     PURPOSE--REPLACE THE STRING IN IW1(.)
C              RESIDING IN LOCATIONS ISTAR1 TO ISTOP1
C              (INCLUSIVELY)
C              BY THE STRING IN IW2(.)
C              RESIDING IN LOCATIONS ISTAR2 TO ISTOP2
C              (INCLUSIVELY)
C              DISPLACE THE ELEMENTS IN IW1(.)
C              BEYOND THE FIELD OF INTEREST APPROPRIATELY.
C              ACCORDINGLY ADJUST THE VALUE OF NW1 =
C              THE NUMBER OF ELEMENTS IN IW1(.).
C     NOTE--THE INPUT ARGUMENTS IW1(.) AND NW1
C           AND ALTERED BY THIS SUBROUTINE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--JANUARY  1979.
C     UPDATED         --JUNE      1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IW1
      CHARACTER*4 IW2
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
      DIMENSION IW1(*)
      DIMENSION IW2(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPSIRS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ISTAR1,ISTOP1,NW1
   52 FORMAT('ISTAR1,ISTOP1,NW1 = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)(IW1(I),I=1,MIN(NW1,100))
   53 FORMAT('(IW1(.) = ',100A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)ISTAR2,ISTOP2,NW2
   54 FORMAT('ISTAR2,ISTOP2,NW2 = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)(IW2(I),I=1,MIN(100,NW2))
   55 FORMAT('(IW2(.) = ',100A1)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               *****************************
C               **  STEP 1--               **
C               **  INSERT    THE STRING.  **
C               *****************************
C
      ILEN1=ISTOP1-ISTAR1+1
      ILEN2=ISTOP2-ISTAR2+1
      ISHIFT=ILEN2-ILEN1
      IMIN=ISTOP1+1
      IMAX=NW1
      IF(IMIN.GT.IMAX)GOTO150
      DO100I=IMIN,IMAX
      IPS=I+ISHIFT
      IREV=IMAX-I+IMIN
      IREVPS=IREV+ISHIFT
      IF(IREVPS.GE.IREV)IW1(IREVPS)=IW1(IREV)
      IF(IREVPS.LT.IREV)IW1(IPS)=IW1(I)
  100 CONTINUE
  150 CONTINUE
      NW1=NW1+ISHIFT
C
      J=ISTAR1-1
      DO200I=ISTAR2,ISTOP2
      J=J+1
      IW1(J)=IW2(I)
  200 CONTINUE
  250 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPSIRS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)ISTAR1,ISTOP1,NW1
 9012 FORMAT('ISTAR1,ISTOP1,NW1 = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)(IW1(I),I=1,MIN(NW1,100))
 9013 FORMAT('(IW1(.) = ',100A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)ISTAR2,ISTOP2,NW2
 9014 FORMAT('ISTAR2,ISTOP2,NW2 = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)(IW2(I),I=1,MIN(NW2,100))
 9015 FORMAT('(IW2(.) = ',100A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)ILEN1,ILEN2,ISHIFT
 9021 FORMAT('ILEN1,ILEN2,ISHIFT = ',3I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPSISI(IW,NW,IBUGA3,IERROR)
C
C     PURPOSE--ELIMINATE SUPERFLUOUS JUXTAPOSITIONS
C              OF + AND - SIGNS.
C     NOTE--THE INPUT ARGUEMNTS IW(.) AND NW
C           ARE ALTERED BY THIS SUBROUTINE.
C     ORIGINAL VERSION--JANUARY  1979.
C     UPDATED         --JANUARY  1981.
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IW
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      DIMENSION IW(*)
C
C-----COMMON VARIABLES (GENERAL)-----------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPSISI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)NW
   52 FORMAT('NW = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NW
      WRITE(ICOUT,56)I,IW(I)
   56 FORMAT('I,IW(I) = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               *****************************************
C               **  STEP 1--                           **
C               **  SET UP A LARGE DO LOOP             **
C               **  FOR MULTIPLE PASSES THROUGH IW(.)  **
C               **  FOR THE SEARCH FOR SIGNS  .        **
C               *****************************************
C
      NUMPAS=1000
      DO100IPASS=1,NUMPAS
C
C               ****************************
C               **  STEP 2--              **
C               **  SEARCH FOR  SIGNS  .  **
C               ****************************
C
      NWM1=NW-1
      IF(NWM1.LT.1)GOTO9000
      DO200I=1,NW
      I2=I
      IP1=I+1
      IF(IW(I).EQ.'+   '.AND.IW(IP1).EQ.'+   ')GOTO210
      IF(IW(I).EQ.'+   '.AND.IW(IP1).EQ.'-   ')GOTO220
      IF(IW(I).EQ.'-   '.AND.IW(IP1).EQ.'+   ')GOTO230
      IF(IW(I).EQ.'-   '.AND.IW(IP1).EQ.'-   ')GOTO240
  200 CONTINUE
      GOTO9000
C
  210 CONTINUE
      ISTART=IP1
      ISTOP=ISTART
      CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR)
      GOTO100
C
  220 CONTINUE
      ISTART=I2
      ISTOP=ISTART
      CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR)
      GOTO100
C
  230 CONTINUE
      ISTART=IP1
      ISTOP=ISTART
      CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR)
      GOTO100
C
  240 CONTINUE
      ISTART=IP1
      ISTOP=ISTART
      CALL DPSIES(ISTART,ISTOP,IW,NW,IBUGA3,IERROR)
      IW(I2)='+   '
      GOTO100
C
  100 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPSISI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)NW
 9012 FORMAT('NW = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NW
      WRITE(ICOUT,9016)I,IW(I)
 9016 FORMAT('I,IW(I) = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPSIS2(ISTART,ISTOP,IW,NW,IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--SIMPLIFY CERTAIN STRINGS
C              INVOLVING SIMPLE (= BINARY) ARITHMETIC OPERATIONS
C              (ADDITION, SUBTRACTION, MULTIPLICATION,
C              AND EXPONENTIATION--NOT DIVISION)
C              OF 2 SINGLE-DIGIT INTEGERS WITH THE OUTPUT BEING NECESSARILY INTE
C              THE INTERNAL STRING STARTS WITH ISTART (INCLUSIVE)
C              AND STOPS WITH ISTOP (INCLUSIVE).
C              ALSO, IF THE STRING HAS LENGTH OF ONLY 1
C              (OR IS REDUCED TO LENGTH OF ONLY 1),
C              THEN AN ADDITIONAL STEP IS TAKEN IN
C              THE ELIMINATION OF THE ASSUMED PARENTHESES AT
C              LOCATIONS ISTART-1 AND ISTOP+1.
C     NOTE--THE INPUT ARGUMENTS IW(.) AND NW
C           AND ALTERED BY THIS SUBROUTINE.
C     ORIGINAL VERSION--JANUARY   1979.
C     UPDATED         --JANUARY   1981.
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IW
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
      CHARACTER*4 IOP
      CHARACTER*4 IVALID
      CHARACTER*4 IHOUT
C
      DIMENSION IW(*)
C
      DIMENSION IHOUT(80)
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='DPSI'
      ISUBN2='S2  '
C
      IERROR='NO'
C
      IOP='UNKN'
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'SIS2')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPSIS2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3,ISUBRO,IERROR
   52 FORMAT('IBUGA3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)ISTART,ISTOP,NW
   53 FORMAT('ISTART,ISTOP,NW = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)(IW(I),I=1,MIN(NW,100))
   54 FORMAT('(IW(.) = ',100A1)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               *******************************************
C               **  STEP 0--                             **
C               **  DETERMINE THE LENGTH OF THE STRING.  **
C               **  CHECK FOR LENGTH OF STRING = 1.      **
C               **  IF FOUND, AND IF AN INTEGER,         **
C               **  THEN ELIMINATE THE LEADING           **
C               **  AND TRAILING PARENTHESES.            **
C               **  CHECK FOR LENGTH OF STRING = 3.      **
C               **  IF FOUND, CONTINUE ON.               **
C               *******************************************
C
      ILEN=ISTOP-ISTART+1
      IF(ILEN.EQ.1)GOTO210
      IF(ILEN.EQ.3)GOTO230
      IF(ILEN.EQ.4)GOTO240
      GOTO9000
C
C               *********************************
C               **  STEP 1--                   **
C               **  TREAT THE LENGTH = 1 CASE  **
C               *********************************
C
  210 CONTINUE
C
C               **********************************
C               **  STEP 1.1--                  **
C               **  CONVERT THE WORD            **
C               **  FROM HOLLARITH TO INTEGER.  **
C               **********************************
C
      IMIN=ISTART
      IMAX=ISTART
      CALL DPCOHI(IMIN,IMAX,IW,NW,IVALID,VAL1,IVAL1,
     1IBUGA3,IERROR)
      IF(IERROR.EQ.'YES'.OR.IVALID.EQ.'NO')GOTO9000
C
C               ********************************************
C               **  STEP 1.2--                            **
C               **  CHECK FOR PRIOR AND POST PARENTHESES  **
C               **  AND ELIMINATE THEM.                   **
C               ********************************************
C
      ISTAM1=ISTART-1
      ISTAP1=ISTART+1
      IF(ISTAM1.LT.1)GOTO9000
      IF(ISTAP1.GT.NW)GOTO9000
      IF(IW(ISTAM1).EQ.'(   '.AND.IW(ISTAP1).EQ.')   ')GOTO215
      GOTO9000
C
  215 CONTINUE
      JMIN=ISTART+1
      JMAX=ISTART+1
      CALL DPSIES(JMIN,JMAX,IW,NW,IBUGA3,IERROR)
      JMIN=ISTART-1
      JMAX=ISTART-1
      CALL DPSIES(JMIN,JMAX,IW,NW,IBUGA3,IERROR)
      GOTO9000
C
C               **********************************
C               **  STEP 3--                    **
C               **  TREAT THE LENGTH = 3 CASE.  **
C               **********************************
C
  230 CONTINUE
C
C               ***************************************
C               **  STEP 3.1--                       **
C               **  CONVERT FIRST WORD OUT OF THE 3  **
C               **  FROM HOLLARITH TO INTEGER.       **
C               **  CONVERT LAST  WORD OUT OF THE 3  **
C               **  FROM HOLLARITH TO INTEGER.       **
C               **  DETERMINE TYPE OF OPERATION      **
C               **  BY EXAMINING THE SECOND WORD     **
C               **  OUT OF THE 3.                    **
C               ***************************************
C
      IMIN=ISTART
      IMAX=ISTART
      CALL DPCOHI(IMIN,IMAX,IW,NW,IVALID,VAL1,IVAL1,
     1IBUGA3,IERROR)
      IF(IERROR.EQ.'YES'.OR.IVALID.EQ.'NO')GOTO9000
C
      IMIN=ISTOP
      IMAX=ISTOP
      CALL DPCOHI(IMIN,IMAX,IW,NW,IVALID,VAL2,IVAL2,
     1IBUGA3,IERROR)
      IF(IERROR.EQ.'YES'.OR.IVALID.EQ.'NO')GOTO9000
C
      ILOC=ISTART+1
      IF(IW(ILOC).EQ.'+   ')IOP='+   '
      IF(IW(ILOC).EQ.'-   ')IOP='-   '
      IF(IW(ILOC).EQ.'*   ')IOP='*   '
CCCCC IF(IW(ILOC).EQ.'/   ')IOP='/   '
      IF(IW(ILOC).EQ.'**  ')IOP='**  '
      IF(IOP.EQ.'UNKN')GOTO9000
C
C               *******************************************
C               **  STEP 3.2--                           **
C               **  CARRY OUT THE ARITHMETIC OPERATION.  **
C               *******************************************
C
      IF(IOP.EQ.'+   ')IRES=IVAL1+IVAL2
      IF(IOP.EQ.'-   ')IRES=IVAL1-IVAL2
      IF(IOP.EQ.'*   ')IRES=IVAL1*IVAL2
CCCCC IF(IOP.EQ.'/   ')IRES=IVAL1/IVAL2
      IF(IOP.EQ.'**  ')IRES=IVAL1**IVAL2
C
C               **********************************
C               **  STEP 3.3--                  **
C               **  CONVERT RESULT              **
C               **  FROM INTEGER TO HOLLARITH.  **
C               **********************************
C
      CALL DPCOIH(IRES,IHOUT,NOUT,IVALID,IBUGA3,ISUBRO,IERROR)
C
C               ************************************************************
C               **  STEP 3.4--                                            **
C               **  ELIMINATE THE LAST 2 WORDS OF THE                     **
C               **  ORIGINAL 3-WORD STRING,                               **
C               ************************************************************
C
      JMIN=ISTOP-1
      JMAX=ISTOP
      CALL DPSIES(JMIN,JMAX,IW,NW,IBUGA3,IERROR)
C
C               *****************************
C               **  STEP 3.5--             **
C               **  INSERT RESULT STRING   **
C               **  (OF LENGTH NOUT)       **
C               **  INTO IW                **
C               **  (STARTING AT           **
C               **  LOCATION ISTART).      **
C               *****************************
C
      CALL DPSIIS(ISTART,IW,NW,IHOUT,NOUT,IBUGA3,IERROR)
C
C               ************************************************************
C               **  STEP 3.6--                                            **
C               **  IF THE INSERTED STRING HAD LENGTH = 1,                **
C               **  (SO THAT THE CURRENT EXPRESSION INSIDE THE            **
C               **  PARENTHESES NOW HAS INTERNAL LENGTH OF 1)             **
C               **  ELIMINATE THE PARENTHESES.                            **
C               ************************************************************
C
      IF(NOUT.NE.1)GOTO9000
C
      ISTAM1=ISTART-1
      ISTAP1=ISTART+1
      IF(ISTAM1.LT.1)GOTO9000
      IF(ISTAP1.GT.NW)GOTO9000
      IF(IW(ISTAM1).EQ.'(   '.AND.IW(ISTAP1).EQ.')   ')GOTO235
      GOTO9000
C
  235 CONTINUE
      JMIN=ISTART+1
      JMAX=ISTART+1
      CALL DPSIES(JMIN,JMAX,IW,NW,IBUGA3,IERROR)
      JMIN=ISTART-1
      JMAX=ISTART-1
      CALL DPSIES(JMIN,JMAX,IW,NW,IBUGA3,IERROR)
      GOTO9000
C
C               **********************************
C               **  STEP 4--                    **
C               **  TREAT THE LENGTH = 4 CASE.  **
C               **********************************
C
  240 CONTINUE
C
C               ***************************************
C               **  STEP 4.1--                       **
C               **  CONVERT FIRST WORD OUT OF THE 4  **
C               **  FROM HOLLARITH TO INTEGER.       **
C               **  CONVERT LAST  WORD OUT OF THE 4  **
C               **  FROM HOLLARITH TO INTEGER.       **
C               **  DETERMINE TYPE OF OPERATION      **
C               **  BY EXAMINING THE SECOND AND      **
C               **  THIRD WORDS OUT OF THE 4.        **
C               ***************************************
C
      IMIN=ISTART
      IMAX=ISTART
      CALL DPCOHI(IMIN,IMAX,IW,NW,IVALID,VAL1,IVAL1,
     1IBUGA3,IERROR)
      IF(IERROR.EQ.'YES'.OR.IVALID.EQ.'NO')GOTO9000
C
      IMIN=ISTOP
      IMAX=ISTOP
      CALL DPCOHI(IMIN,IMAX,IW,NW,IVALID,VAL2,IVAL2,
     1IBUGA3,IERROR)
      IF(IERROR.EQ.'YES'.OR.IVALID.EQ.'NO')GOTO9000
C
      ILOC=ISTART+1
      ILOCP1=ILOC+1
      IF(IW(ILOC).EQ.'*   '.AND.IW(ILOCP1).EQ.'*   ')IOP='**  '
      IF(IOP.EQ.'UNKN')GOTO9000
C
C               *******************************************
C               **  STEP 4.2--                           **
C               **  CARRY OUT THE ARITHMETIC OPERATION.  **
C               *******************************************
C
      IF(IOP.EQ.'**  ')IRES=IVAL1**IVAL2
C
C               **********************************
C               **  STEP 4.3--                  **
C               **  CONVERT RESULT              **
C               **  FROM INTEGER TO HOLLARITH.  **
C               **********************************
C
      CALL DPCOIH(IRES,IHOUT,NOUT,IVALID,IBUGA3,ISUBRO,IERROR)
C
C               ************************************************************
C               **  STEP 4.4--                                            **
C               **  ELIMINATE THE LAST 3 WORDS OF THE                     **
C               **  ORIGINAL 4-WORD STRING,                               **
C               ************************************************************
C
      JMIN=ISTOP-2
      JMAX=ISTOP
      CALL DPSIES(JMIN,JMAX,IW,NW,IBUGA3,IERROR)
C
C               *****************************
C               **  STEP 4.5--             **
C               **  INSERT RESULT STRING   **
C               **  (OF LENGTH NOUT)       **
C               **  INTO IW                **
C               **  (STARTING AT           **
C               **  LOCATION ISTART).      **
C               *****************************
C
      CALL DPSIIS(ISTART,IW,NW,IHOUT,NOUT,IBUGA3,IERROR)
C
C               ************************************************************
C               **  STEP 4.6--                                            **
C               **  IF THE INSERTED STRING HAD LENGTH = 1,                **
C               **  (SO THAT THE CURRENT EXPRESSION INSIDE THE            **
C               **  PARENTHESES NOW HAS INTERNAL LENGTH OF 1)             **
C               **  ELIMINATE THE PARENTHESES.                            **
C               ************************************************************
C
      IF(NOUT.NE.1)GOTO9000
C
      ISTAM1=ISTART-1
      ISTAP1=ISTART+1
      IF(ISTAM1.LT.1)GOTO9000
      IF(ISTAP1.GT.NW)GOTO9000
      IF(IW(ISTAM1).EQ.'(   '.AND.IW(ISTAP1).EQ.')   ')GOTO245
      GOTO9000
C
  245 CONTINUE
      JMIN=ISTART+1
      JMAX=ISTART+1
      CALL DPSIES(JMIN,JMAX,IW,NW,IBUGA3,IERROR)
      JMIN=ISTART-1
      JMAX=ISTART-1
      CALL DPSIES(JMIN,JMAX,IW,NW,IBUGA3,IERROR)
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'SIS2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPSIS2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,ISUBRO,IERROR
 9012 FORMAT('IBUGA3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)NW
 9013 FORMAT('NW = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)(IW(I),I=1,MIN(NW,115))
 9014 FORMAT('(IW(.) = ',115A1)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPSKIP(IHARG,IARGT,IARG,NUMARG,IDEFSK,
     1ISKIP,IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE NUMBER OF LINES TO BE SKIPPED
C              AT THE BEGINNING OF A READ COMMAND
C              OR A SERIAL READ COMMAND.
C              THIS ALLOWS TEXT AND HEADER LINES TO BE
C              SKIPPED OVER AT THE BEGINNING OF A DATA FILE.
C              THE SPECIFIED NUMBER OF SKIP LINES WILL BE PLACED
C              IN THE FLOATING POINT VARIABLE ISKIP.
C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
C                     --IARGT  (A  HOLLERITH VECTOR)
C                     --IARG   (AN INTEGER VECTOR)
C                     --NUMARG (AN INTEGER VARIABLE)
C                     --IDEFSK (AN INTEGER VARIABLE)
C     OUTPUT ARGUMENTS--ISKIP  (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-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER 1980.
C     UPDATED         --MAY       1982.
C     UPDATED         --SEPTEMBER 1993.  ALLOW SKIP ----
C     UPDATED         --OCTOBER   1997.  FIX SKIP ----
C     UPDATED         --OCTOBER   1997.  SET SKIP AUTOMATIC
C                                        EQUIVALENT TO SKIP ----
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
 1110 CONTINUE
      IF(NUMARG.LE.0)GOTO1150
      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
CCCCC OCTOBER 1997.  MAKE "SKIP AUTOMATIC" EQUIVALENT TO A "SKIP ----"
CCCCC IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1170
      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
CCCCC THE FOLLOWING LINE WAS ADDED    SEPTEMBER 1993
      IF(IHARG(NUMARG).EQ.'----')GOTO1170
CCCCC THE FOLLOWING LINE WAS FIXED, COMMAND PARSING RETURNS A SINGLE
CCCCC "-".     OCTOBER 1997
      IF(IHARG(NUMARG).EQ.'-')GOTO1170
      IF(IHARG(NUMARG).EQ.'?')GOTO8100
      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160
      GOTO1120
C
 1120 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,1121)
 1121 FORMAT('***** ERROR IN DPSKIP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1122)
 1122 FORMAT('      ILLEGAL FORM FOR SKIP ',
     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 SKIP OVER 3 NON-DATA LINES ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1127)
 1127 FORMAT('      AT THE BEGINNING OF READS AND SERIAL READS,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1128)
 1128 FORMAT('      THEN THE ALLOWABLE FORM IS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1129)
 1129 FORMAT('      SKIP 3 ')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1150 CONTINUE
      ISKIP=IDEFSK
      GOTO1180
C
 1160 CONTINUE
      ISKIP=IARG(NUMARG)
      GOTO1180
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1993
 1170 CONTINUE
      IFOUND='YES'
      ISKIP=-1
      IF(IFEEDB.EQ.'OFF')GOTO1179
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1171)
 1171 FORMAT('HEADER LINES WILL BE SKIPPED UNITL A LINE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1172)
 1172 FORMAT('    WITH    ----    IS ENCOUNTERED')
      CALL DPWRST('XXX','BUG ')
 1179 CONTINUE
      GOTO9000
C
 1180 CONTINUE
      IFOUND='YES'
      IF(IFEEDB.EQ.'OFF')GOTO1189
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)
 1181 FORMAT('THE NUMBER OF HEADER LINES TO BE SKIPPED ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)ISKIP
 1182 FORMAT('    HAS JUST BEEN SET TO ',I8)
      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)ISKIP
 8111 FORMAT('THE CURRENT NUMBER OF LINES TO BE SKIPPED IS ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8112)IDEFSK
 8112 FORMAT('THE DEFAULT NUMBER OF LINES TO BE SKIPPED IS ',I8)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE DPSLOC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
     1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
C
C     PURPOSE--GENERATE A SPREAD-LOCATION (S-L) 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--99/8
C     ORIGINAL VERSION--AUGUST    1999.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 IAND1
      CHARACTER*4 IAND2
      CHARACTER*4 IBUGG2
      CHARACTER*4 IBUGG3
      CHARACTER*4 IBUGQ
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IHWUSE
      CHARACTER*4 MESSAG
      CHARACTER*4 ICASEQ
      CHARACTER*4 IHLEFT
      CHARACTER*4 IHLEF2
      CHARACTER*4 IHHOR
      CHARACTER*4 IHHOR2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Y1(MAXOBV)
      DIMENSION X1(MAXOBV)
C
      DIMENSION XIDTEM(MAXOBV)
      DIMENSION TEMP(MAXOBV)
      DIMENSION TEMP2(MAXOBV)
      INCLUDE 'DPCOZZ.INC'
      EQUIVALENCE (GARBAG(IGARB1),X1(1))
      EQUIVALENCE (GARBAG(IGARB2),Y1(1))
      EQUIVALENCE (GARBAG(IGARB3),XIDTEM(1))
      EQUIVALENCE (GARBAG(IGARB4),TEMP(1))
      EQUIVALENCE (GARBAG(IGARB5),TEMP2(1))
C
C-----COMMON----------------------------------------------------
C
      INCLUDE 'DPCOHK.INC'
      INCLUDE 'DPCODA.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------
C
      IERROR='NO'
C
      ISUBN1='DPHO'
      ISUBN2='MO  '
C
      MAXCP1=MAXCOL+1
      MAXCP2=MAXCOL+2
      MAXCP3=MAXCOL+3
      MAXCP4=MAXCOL+4
      MAXCP5=MAXCOL+5
      MAXCP6=MAXCOL+6
C
      MAXV2=2
      MINN2=2
C
      ICOLH=0
C
C               *******************************************
C               **  TREAT THE SPREAD-LOCATION PLOT CASE  **
C               *******************************************
C
      IF(IBUGG2.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPSLOC--')
      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
      ICASPL='SLOC'
C
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')GOTO111
C
      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LOCA'.AND.
     1IHARG(2).EQ.'PLOT')GOTO112
      GOTO119
C
  111 CONTINUE
      ILASTC=1
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO119
C
  112 CONTINUE
      ILASTC=2
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO119
C
  119 CONTINUE
      IFOUND='YES'
      GOTO190
C
  190 CONTINUE
C
C               *************************************************
C               **  STEP 1--                                   **
C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS
C               **************************************************
C
      ISTEPN='1'
      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      MINNA=2
      MAXNA=100
      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
C               ********************************************
C               **  STEP 2--                              **
C               **  CHECK THE VALIDITY OF ARGUMENT 1      **
C               **  (THIS WILL BE THE RESPONSE VARIABLE)  **
C               ********************************************
C
      ISTEPN='2'
      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IHLEFT=IHARG(1)
      IHLEF2=IHARG2(1)
      IHWUSE='V'
      MESSAG='YES'
      CALL CHECKN(IHLEFT,IHLEF2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      ICOLL=IVALUE(ILOCV)
      NLEFT=IN(ILOCV)
      IF(IBUGG2.EQ.'ON')WRITE(ICOUT,211)IHLEFT,ICOLL,NLEFT
  211 FORMAT('IHLEFT,ICOLL,NLEFT = ',A4,I8,I8)
      IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
C               **************************************************
C               **  STEP 3--                                    **
C               **  CHECK THAT THE INPUT NUMBER OF OBSERVATIONS **
C               **  (NLEFT)                                     **
C               **  FOR THE RESPONSE VARIABLE IS 2 OR LARGER.   **
C               **************************************************
C
      ISTEPN='3'
      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NLEFT.GE.MINN2)GOTO390
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,311)
  311 FORMAT('***** ERROR IN DPSLOC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,312)
  312 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,321)
  321 FORMAT('      (FOR WHICH A SPREAD-LOCATION PLOT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,325)
  325 FORMAT('      WAS TO HAVE BEEN FORMED)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,326)MINN2
  326 FORMAT('      MUST BE ',I8,' OR LARGER;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,327)
  327 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,328)
  328 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,329)(IANS(I),I=1,IWIDTH)
  329 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 DPSLOC')
      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,MIN(IWIDTH,80))
  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 (IT MUST), THEN **
C               **  THIS                                        **
C               **  INDICATES THAT THE VALUES IN THE            **
C               **  FIRST VARIABLE ARE TO BE GROUPED            **
C               **  BASED ON VALUES OF THE SECOND VARIABLE;     **
C               **  THAT IS, THE SECOND VARAIBLE DEFINES THE    **
C               **  GROUP NUMBERS WITHIN WHICH THE MEANS AND    **
C               **  STANDARD DEVIATIONS ARE TO BE COMPUTED.     **
C               **  THE VALUES IN THE SECOND VARIABLE           **
C               **  ARE THE X VALUES FOR EACH MEAN, STANDARD    **
C               **  DEVIATION,                                  **
C               **  ETC.  IN THE RESULTING I   PLOT     .       **
C               **  THE VALUES IN THE SECOND VARIABLE           **
C               **  NEED NOT HAVE BEEN PREVIOUSLY               **
C               **  SORTED OR HAVE COMMON VALUES ADJACENT.      **
C               **  IF WE HAVE THE 2-VARIABLE CASE,             **
C               **  CHECK THE VALIDITY OF THE SECOND (X) VARIABLE.
C               **************************************************
C
      ISTEPN='5'
      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NUMV2=ILOCQ-1
      IF(NUMV2.EQ.2)GOTO530
      GOTO510
C
  510 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,511)
  511 FORMAT('***** ERROR IN DPSLOC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,512)
  512 FORMAT('      FOR A SPREAD-LOCATION PLOT, ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,518)
  518 FORMAT('      THE NUMBER OF VARIABLES ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,519)
  519 FORMAT('      MUST BE EXACTLY 2  ;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,520)
  520 FORMAT('      SUCH WAS NOT THE CASE HERE;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,521)
  521 FORMAT('      THE SPECIFIED NUMBER')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,522)NUMV2
  522 FORMAT('      OF VARIABLES WAS ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,523)
  523 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,524)(IANS(I),I=1,MIN(IWIDTH,80))
  524 FORMAT('      ',80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
  530 CONTINUE
      IHHOR=IHARG(2)
      IHHOR2=IHARG2(2)
      IHWUSE='V'
      MESSAG='YES'
      CALL CHECKN(IHHOR,IHHOR2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      ICOLH=IVALUE(ILOCV)
      NHOR=IN(ILOCV)
      IF(IBUGG2.EQ.'ON')WRITE(ICOUT,531)IHHOR,ICOLH,NHOR
  531 FORMAT('IHHOR,ICOLH,NHOR   = ',A4,I8,I8)
      IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
      IF(NHOR.NE.NLEFT)GOTO570
      GOTO590
C
  570 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,571)
  571 FORMAT('***** ERROR IN DPSLOC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,572)
  572 FORMAT('      FOR A SPREAD-LOCATION PLOT, ')
      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  (RESPONSE VALUES)--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,584)IHLEFT,NLEFT
  584 FORMAT('                  ',A4,'  HAS ',I8,' ELEMENTS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,585)
  585 FORMAT('      THE SECOND VARIABLE  (HORIZIZONTAL AXIS ',
     1'VALUES)--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,586)IHHOR,NHOR
  586 FORMAT('                  ',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,MIN(IWIDTH,80))
  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 SECOND VARIABLE (IF EXISTENT)      **
C               *************************************************
C
      ISTEPN='6'
      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ICASEQ.EQ.'FULL')GOTO610
      IF(ICASEQ.EQ.'SUBS')GOTO620
      IF(ICASEQ.EQ.'FOR')GOTO630
C
  610 CONTINUE
      DO615I=1,NLEFT
      ISUB(I)=1
  615 CONTINUE
      NQ=NLEFT
      GOTO650
C
  620 CONTINUE
      NIOLD=NLEFT
      CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
      NQ=NIOLD
      GOTO650
C
  630 CONTINUE
      NIOLD=NLEFT
      CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
      NQ=NFOR
      GOTO650
C
  650 CONTINUE
      J=0
      IMAX=NLEFT
      IF(NQ.LT.NLEFT)IMAX=NQ
      DO660I=1,IMAX
      IF(ISUB(I).EQ.0)GOTO660
      J=J+1
C
      IJ=MAXN*(ICOLL-1)+I
      IF(ICOLL.LE.MAXCOL)Y1(J)=V(IJ)
      IF(ICOLL.EQ.MAXCP1)Y1(J)=PRED(I)
      IF(ICOLL.EQ.MAXCP2)Y1(J)=RES(I)
      IF(ICOLL.EQ.MAXCP3)Y1(J)=YPLOT(I)
      IF(ICOLL.EQ.MAXCP4)Y1(J)=XPLOT(I)
      IF(ICOLL.EQ.MAXCP5)Y1(J)=X2PLOT(I)
      IF(ICOLL.EQ.MAXCP6)Y1(J)=TAGPLO(I)
      IF(NUMV2.LE.1)GOTO660
C
      IJ=MAXN*(ICOLH-1)+I
      IF(ICOLH.LE.MAXCOL)X1(J)=V(IJ)
      IF(ICOLH.EQ.MAXCP1)X1(J)=PRED(I)
      IF(ICOLH.EQ.MAXCP2)X1(J)=RES(I)
      IF(ICOLH.EQ.MAXCP3)X1(J)=YPLOT(I)
      IF(ICOLH.EQ.MAXCP4)X1(J)=XPLOT(I)
      IF(ICOLH.EQ.MAXCP5)X1(J)=X2PLOT(I)
      IF(ICOLH.EQ.MAXCP6)X1(J)=TAGPLO(I)
C
  660 CONTINUE
      NLOCAL=J
C
C               **************************************************
C               **  STEP 8--                                    **
C               **  FORM THE VERTICAL AND HORIZONTAL AXIS       **
C               **  VALUES Y(.) AND X(.) FOR THE PLOT.          **
C               **  DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S **
C               **  FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE **
C               **  LINE,                                       **
C               **  AND THE UPPER CONFIDENCE LINE.              **
C               **  DEFINE THE NUMBER OF PLOT POINTS  (NPLOTP). **
C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV)**
C               **************************************************
C
      ISTEPN='8'
      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
  809 CONTINUE
      CALL DPSLO2(Y1,X1,NLOCAL,NUMV2,ICASPL,ISIZE,
     1XIDTEM,TEMP,TEMP2,MAXOBV,
     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 DPSLOC--')
      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)ISIZE
 9014 FORMAT('ISIZE = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NPLOTP.LE.0)GOTO9090
      DO9015I=1,NPLOTP
      WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPSLO2(Y,X,N,NUMV2,ICASPL,ISIZE,
     1XIDTEM,TEMP,TEMP2,MAXOBV,
     1Y2,X2,D2,N2,NPLOTV,IBUGG3,IERROR)
C
C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
C              THAT WILL DEFINE AN SPREAD-LOCATION 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--99/8
C     ORIGINAL VERSION--AUGUST    1999.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES--------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 IBUGG3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C----------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION Y2(*)
      DIMENSION X2(*)
      DIMENSION D2(*)
C
      DIMENSION XIDTEM(*)
      DIMENSION TEMP(*)
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='DPSL'
      ISUBN2='O2  '
C
      I2=0
      AN=0.0
C
      N50=1
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.GE.1)GOTO39
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,31)
   31 FORMAT('***** ERROR IN DPSLO2--')
      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 DPSLO2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)
   47 FORMAT('      THE NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,48)
   48 FORMAT('      WAS EXACTLY EQUAL TO 1.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
   49 CONTINUE
C
      HOLD=Y(1)
      DO60I=1,N
      IF(Y(I).NE.HOLD)GOTO69
   60 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)
   61 FORMAT('***** ERROR IN DPSLO2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)
   62 FORMAT('      ALL RESPONSE VARIABLE ELEMENTS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,63)HOLD
   63 FORMAT('      ARE IDENTICALLY EQUAL TO ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
   69 CONTINUE
C
      IF(IBUGG3.EQ.'OFF')GOTO90
      WRITE(ICOUT,70)
   70 FORMAT('AT THE BEGINNING OF DPSLO2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)N,ICASPL,NUMV2
   71 FORMAT('N,ICASPL,NUMV2 = ',I8,2X,A4,I8)
      CALL DPWRST('XXX','BUG ')
      DO72I=1,N
      WRITE(ICOUT,73)I,Y(I),X(I)
   73 FORMAT('I, Y(I), X(I) = ',I8,2F15.7)
      CALL DPWRST('XXX','BUG ')
   72 CONTINUE
   90 CONTINUE
C
C               *************************************************
C               **  STEP 1--                                   **
C               **  DETERMINE THE NUMBER OF DISTINCT VALUES    **
C               **  FOR VARIABLE 2 (THE GROUP VARIABLE).       **
C               **  IF ALL VALUES ARE DISTINCT, THEN THIS      **
C               **  IMPLIES WE HAVE THE NO REPLICATION CASE    **
C               **  WHICH IS AN ERROR CONDITION FOR A          **
C               **  SPREAD-LOCATION PLOT .                     **
C               *************************************************
C
      ISTEPN='1'
      IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NUMSET=0
      DO160I=1,N
      IF(NUMSET.EQ.0)GOTO165
      DO170J=1,NUMSET
      IF(X(I).EQ.XIDTEM(J))GOTO160
  170 CONTINUE
  165 CONTINUE
      NUMSET=NUMSET+1
      XIDTEM(NUMSET)=X(I)
  160 CONTINUE
      CALL SORT(XIDTEM,NUMSET,XIDTEM)
C
      XID1=XIDTEM(1)
      XID2=XIDTEM(NUMSET)
C
  190 CONTINUE
C
      IF(NUMSET.EQ.0)WRITE(ICOUT,191)
  191 FORMAT('ERROR IN DPSLO2   SUBROUTINE--NUMSET = 0')
      IF(NUMSET.EQ.0)CALL DPWRST('XXX','BUG ')
      IF(NUMSET.EQ.0)GOTO9000
      IF(NUMSET.EQ.0)IERROR='YES'
C
      IF(NUMSET.EQ.N)WRITE(ICOUT,192)
  192 FORMAT('ERROR IN DPSLO2   SUBROUTINE--NUMSET = N')
      IF(NUMSET.EQ.N)CALL DPWRST('XXX','BUG ')
      IF(NUMSET.EQ.N)IERROR='YES'
      IF(NUMSET.EQ.N)GOTO9000
C
C               ************************************************
C               **  STEP 4--                                  **
C               **  DETERMINE PLOT COORDINATES                **
C               ************************************************
C
 1100 CONTINUE
C
      ISTEPN='4'
      IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      J=0
      ITAG=1
      DO1110ISET=1,NUMSET
C
      K=0
      DO1120I=1,N
      IF(X(I).EQ.XIDTEM(ISET))K=K+1
      IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I)
 1120 CONTINUE
      NI=K
C
      IF(IBUGG3.EQ.'ON')WRITE(ICOUT,1121)ISET,XIDTEM(ISET),NI
 1121 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8)
      IF(IBUGG3.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
      IF(NI.LE.1)GOTO1110
      CALL SORT(TEMP,NI,TEMP)
      IWRITE='OFF'
      SUM=0.0
      CALL MEDIAN(TEMP,NI,IWRITE,TEMP2,MAXOBV,XMED,IBUGG3,IERROR)
      ITAG=ITAG+1
      JSTART=J+1
      DO1130I=1,NI
        J=J+1
        Y2(J)=ABS(TEMP(I)-XMED)
        X2(J)=XMED
        D2(J)=REAL(ITAG)
 1130 CONTINUE
C
      CALL MEDIAN(Y2(JSTART),NI,IWRITE,TEMP2,MAXOBV,XMED2,IBUGG3,
     1            IERROR)
      DO1140I=JSTART,J
        Y2(I)=SQRT(Y2(I))
 1140 CONTINUE
      J=J+1
      Y2(J)=SQRT(XMED2)
      X2(J)=XMED
      D2(J)=1.0
C
 1110 CONTINUE
C
      N2=J
      NPLOTV=2
      GOTO9000
C
C               ******************
C               **   STEP 90--  **
C               **   EXIT       **
C               ******************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPSLO2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)ICASPL,N,NUMSET,N2,IERROR
 9012 FORMAT('ICASPL,N,NUMSET,N2,IERROR = ',A4,3I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)NUMV2
 9013 FORMAT('NUMV2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)AN,NI
 9014 FORMAT('AN,NI = ',E15.7,I8)
      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 DPSMO2(Y,W,N,ICASSM,IFILWI,IDEGRE,IRSTRI,NUMCRS,MAXCRS,
     1TEMP,MAXN,
     1RESSD,RESDF,PRED2,RES2,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE PERFORMS A SMOOTHING
C              OF THE DATA IN THE INPUT VECTOR Y.
C     NOTE--ASSUMPTION--DATA ARE EQUALLY-SPACED.
C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR
C                                OF EQUALLY-SPACED OBSERVATIONS
C                                TO BE SMOOTHED.
C                       N      = THE INTEGER NUMBER OF
C                                OBSERVATIONS IN THE VECTOR Y.
C                       IFILWI = THE ODD INTEGER WIDTH OF THE
C                                SMOOTHING FUNCTION.
C                                (IFILWI MUST BE ODD,
C                                MUST BE BETWEEN 1 AND 999
C                                (INCLUSIVE),
C                                AND MUST BE BETWEEN IDEGRE+1 AND N
C                                (INCLUSIVE)).
C                       IDEGRE = THE INTEGER DEGREE OF THE LEAST
C                                SQUARES POLYNOMIAL.
C                                (IDEGRE MUST BE BETWEEN 0 AND 5,
C                                INCLUSIVE).
C     OUTPUT ARGUMENTS--PRED2  = THE SINGLE PRECISION VECTOR
C                                OF 'PREDICTED' OR SMOOTHED
C                                VALUES.
C                       RES2   = THE SINGLE PRECISION VECTOR
C                                OF RESIDUALS.
C                                (THE I-TH RESIDUAL IS THE DIFFERENCE
C                                BETWEEN THE I-TH INPUT VALUE AND
C                                THE I-TH SMOOTHED VALUE--
C                                RES2(I) = Y(I) - PRED2(I)).
C                       S      = THE SINGLE PRECISION VALUE OF THE
C                                RESIDUAL STANDARD DEVIATION
C                                (A MEASURE OF THE GOODNESS OF
C                                THE FIT OR THE SMOOTHING).
C     OUTPUT--COMPUTED (MOVING) LEAST SQUARES SMOOTHED VALUES,
C             RESIDUALS, AND THE RESIDUAL STANDARD DEVIATION.
C     PRINTING--YES (6 LINES)
C               OF INFORMATION INVOLVING
C               THE NUMBER OF OBSERVATIONS,
C               THE DEGREE OF THE SMOOTHING FUNCTION,
C               THE WIDTH  OF THE SMOOTHING FUNCTION,
C               THE STANDARD DEVIATION OF THE ORIGINAL
C               (UNSMOOTHED) DATA ABOUT THE SAMPLE MEAN,
C               THE STANDARD DEVIATION OF THE RESIDUALS
C               AFTER A (MOVING) AVERAGE SMOOTHING WITH
C               THE SAME WIDTH (IFILWI),
C               AND THE STANDARD DEVIATION OF THE RESIDUALS
C               AFTER THE LEAST SQUARES SMOOTHING WITH
C               DEGREE IDEGRE AND WIDTH IFILWI.
C     RESTRICTIONS--THERE IS NO UPPER LIMIT RESTRICTION ON N.
C                   IDEGRE MUST BE BETWEEN 0 AND 5 (INCLUSIVE).
C                   IFILWI MUST BE ODD,
C                          MUST BE BETWEEN 1 AND 999 (INCLUSIVE), AND
C                          MUST BE BETWEEN IDEGRE+1 AND N (INCLUSIVE).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--MACHINE-INDEPENDENT ANSI FORTRAN (1977)
C     COMMENT--NEAR THE ENDS OF THE DATA SET WHERE
C              THE SMOOTHING FUNCTION GOES 'OFF THE END',
C              THE PREDICTED VALUE IS ASSIGNED THE VALUE OF THE
C              OBSERVATION ITSELF.  THIS IS DUE TO THE
C              COMPLICATED FORM OF THE NON-SYMMETRIC WEIGHTING
C              FOR THE LEAST SQUARES SMOOTHING NEAR THE ENDPOINTS.
C              THIS WILL BE CORRECTED IN THE FUTURE.
C     REFERENCE--HILDEBRAND, F. B.  INTRODUCTION TO NUMERICAL
C                ANALYSISY PAGES 295-302, ESPECIALLY 301.
C              --RALSTON, A.  A FIRST COURSE IN NUMERICAL ANALYSIS,
C                PAGES 250-254.
C              --SAVITSKY, A. AND GOLAY, M. J. E.  'SMOOTHING AND
C                DIFFERENTIATION OF DATA BY SIMPLIFIED LEAST
C                SQUARES PROCEDURES', ANALYTICAL CHEMISTRY,
C                JULY, 1964, PAGES 1627-1639.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--MAY       1975.
C     UPDATED         --JULY      1976.
C     UPDATED         --JUNE      1978.
C     UPDATED         --FEBRUARY  1981.
C     UPDATED         --JULY      1981.
C     UPDATED         --MARCH     1982.
C     UPDATED         --MAY       1982.
C     UPDATED         --JULY      1983.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASSM
      CHARACTER*4 IRSTRI
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ICASS2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION W(*)
      DIMENSION PRED2(*)
      DIMENSION RES2(*)
C
      DIMENSION IRSTRI(*)
      DIMENSION TEMP(*)
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='DPSM'
      ISUBN2='O2  '
C
      IERROR='NO'
C
      MAXDEG=6
      MAXWIN=MAXN-1
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 DPSMO2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)N,IBUGA3
   52 FORMAT('N,IBUGA3 = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)ICASSM,IFILWI,IDEGRE
   53 FORMAT('ICASSM,IFILWI,IDEGRE = ',A4,2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)NUMCRS,MAXCRS
   54 FORMAT('NUMCRS,MAXCRS = ',I8,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)(IRSTRI(I),I=1,MAXCRS)
   55 FORMAT('IRSTRI(.) = ',30A1)
      CALL DPWRST('XXX','BUG ')
      DO56I=1,N
      WRITE(ICOUT,57)I,Y(I),W(I)
   57 FORMAT('I,Y(I),W(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   56 CONTINUE
   90 CONTINUE
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICASS2='OTSM'
      IF(ICASSM.EQ.'SM')ICASS2='SM'
      IF(ICASSM.EQ.'0SM')ICASS2='SM'
      IF(ICASSM.EQ.'1SM')ICASS2='SM'
      IF(ICASSM.EQ.'2SM')ICASS2='SM'
      IF(ICASSM.EQ.'3SM')ICASS2='SM'
      IF(ICASSM.EQ.'4SM')ICASS2='SM'
      IF(ICASSM.EQ.'5SM')ICASS2='SM'
      IF(ICASSM.EQ.'6SM')ICASS2='SM'
      IF(ICASSM.EQ.'7SM')ICASS2='SM'
      IF(ICASSM.EQ.'8SM')ICASS2='SM'
      IF(ICASSM.EQ.'9SM')ICASS2='SM'
      IF(ICASSM.EQ.'10SM')ICASS2='SM'
      IF(ICASSM.EQ.'ROSM')ICASS2='ROSM'
C
      IF(N.LT.1)GOTO110
      GOTO119
  110 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN DPSMO2--THE NUMBER OF OBSERVATIONS ',
     1'IN THE RESPONSE VARIABLE IS NON-POSITIVE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)N
  112 FORMAT('SAMPLE SIZE = ',I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  119 CONTINUE
C
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** NOTE FROM DPSMO2--THE RESPONSE VARIABLE ',
     1'ONLY HAS 1 ELEMENT')
      CALL DPWRST('XXX','BUG ')
      DO122I=1,N
      PRED2(I)=Y(I)
      RES2(I)=0.0
  122 CONTINUE
      GOTO9000
  129 CONTINUE
C
      HOLD=Y(1)
      DO135I=2,N
      IF(Y(I).NE.HOLD)GOTO139
  135 CONTINUE
  130 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,131)HOLD
  131 FORMAT('***** NOTE FROM DPSMO2--THE RESPONSE VARIABLE ',
     1'HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      DO132I=1,N
      PRED2(I)=Y(I)
      RES2(I)=0.0
  132 CONTINUE
      GOTO9000
  139 CONTINUE
C
      IF(IFILWI.GT.N)GOTO140
      GOTO149
  140 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,141)
  141 FORMAT('***** ERROR IN DPSMO2--THE WIDTH OF THE SMOOTHING ',
     1' WINDOW MUST NOT BE LARGER THAN THE SAMPLE SIZE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,142)IFILWI,N
  142 FORMAT('      WIDTH = ',I8,' SAMPLE SIZE = ',I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  149 CONTINUE
C
      IF(IFILWI.GT.MAXWIN)GOTO150
      GOTO159
  150 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,151)MAXWIN
  151 FORMAT('***** ERROR IN DPSMO2--THE WIDTH OF THE SMOOTHING ',
     1'WINDOW MUST NOT BE LARGER THAN ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,152)IFILWI
  152 FORMAT('WIDTH = ',I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  159 CONTINUE
C
      IF(IFILWI.EQ.1)GOTO160
      GOTO169
  160 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,161)
  161 FORMAT('***** NOTE FROM DPSMO2--THE WIDTH OF THE SMOOTHING ',
     1'WINDOW IS 1')
      CALL DPWRST('XXX','BUG ')
      DO162I=1,N
      PRED2(I)=Y(I)
      RES2(I)=0.0
  162 CONTINUE
      IERROR='YES'
      GOTO9000
  169 CONTINUE
C
      IF(IFILWI.EQ.N)GOTO170
      GOTO179
  170 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,171)
  171 FORMAT('***** ERROR IN DPSMO2--THE WIDTH OF THE SMOOTHING ',
     1'WINDOW IS IDENTICAL TO THE SAMPLE SIZE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,172)IFILWI,N
  172 FORMAT('WIDTH = ',I8,' SAMPLE SIZE = ',I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  179 CONTINUE
C
      IEVODD=IFILWI-2*(IFILWI/2)
      IF(IEVODD.EQ.0)GOTO180
      GOTO189
  180 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,181)
  181 FORMAT('***** ERROR IN DPSMO2--THE WIDTH OF THE SMOOTHIN ',
     1'WINDOW MUST BE ODD (AS OPPOSED TO EVEN')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,182)
  182 FORMAT('WIDTH = ',I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  189 CONTINUE
C
      IF(IFILWI.LE.0)GOTO200
      GOTO209
  200 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,201)
  201 FORMAT('***** ERROR IN DPSMO2--THE WIDTH OF THE SMOOTHING ',
     1'WINDOW WAS NON-POSITIVE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,202)IFILWI
  202 FORMAT('WIDTH = ',I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  209 CONTINUE
C
      IF(ICASSM.NE.'SM')GOTO229
      IF(IDEGRE.GE.IFILWI)GOTO220
      GOTO229
  220 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,221)
  221 FORMAT('***** ERROR IN DPSMO2--THE DEGREE OF THE SMOOTHING ',
     1'FUNCTION MUST BE SMALLER THAN THE SMOOTHING WIDTH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,222)IDEGRE,IFILWI
  222 FORMAT('DEGREE = ',I8,' WIDTH = ',I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  229 CONTINUE
C
      IF(ICASSM.NE.'SM')GOTO239
      IF(IDEGRE.GT.MAXDEG)GOTO230
      GOTO239
  230 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,231)MAXDEG
  231 FORMAT('***** ERROR IN DPSMO2--THE DEGREE OF THE SMOOTHING ',
     1'FUNCTION MUST NOT EXCEED ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,232)IDEGRE
  232 FORMAT('DEGREE = ',I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  239 CONTINUE
C
      IF(ICASSM.NE.'SM')GOTO249
      IWM1=IFILWI-1
      IF(IDEGRE.EQ.IWM1)GOTO240
      GOTO249
  240 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,241)
  241 FORMAT('***** NOTE FROM DPSMO2--THE DEGREE OF THE SMOOTHING ',
     1'FUNCTION WAS ONE LESS THAN THE WIDTH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,242)IFILWI
  242 FORMAT('      THEREFORE, THE SMOOTHED VALUES WILL BE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,243)
  243 FORMAT('      IDENTICAL TO THE RAW DATA VALUES.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,244)IDEGRE,IFILWI
  244 FORMAT('DEGREE = ',I8,' WIDTH = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO245I=1,N
      PRED2(I)=Y(I)
      RES2(I)=Y(I)
  245 CONTINUE
      GOTO9000
  249 CONTINUE
C
CCCCC IF(ICASS2.EQ.'ROSM')GOTO260
CCCCC GOTO269
CC260 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,261)
CC261 FORMAT('***** ERROR IN DPSMO2--THE ROBUST SMOOTHING')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,262)
CC262 FORMAT('      CAPABILITY IS NOT YET AVAILABLE')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC IERROR='YES'
CCCCC GOTO9000
CC269 CONTINUE
C
  290 CONTINUE
C
C               ************************************************
C               **  STEP 2--                                  **
C               **  BRANCH TO THE APPROPRIATE SMOOTHING CASE  **
C               ************************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IFILWI.LE.0)IFILWI=3
      IF(IFILWI.GE.1)IFILWI=IFILWI
      IEVODD=IFILWI-2*(IFILWI/2)
      IF(IEVODD.EQ.0)IFILWI=IFILWI+1
C
      WIDTH=IFILWI
      IWHALF=(IFILWI/2)+1
      M=IFILWI/2
      AM=M
C
      IF(ICASSM.EQ.'0SM')GOTO1100
      IF(ICASSM.EQ.'1SM')GOTO1100
      IF(ICASSM.EQ.'2SM')GOTO1120
      IF(ICASSM.EQ.'3SM')GOTO1120
      IF(ICASSM.EQ.'4SM')GOTO1140
      IF(ICASSM.EQ.'5SM')GOTO1140
      IF(ICASSM.EQ.'6SM')GOTO1160
      IF(ICASSM.EQ.'7SM')GOTO1160
      IF(ICASSM.EQ.'8SM')GOTO1180
      IF(ICASSM.EQ.'9SM')GOTO1180
      IF(ICASSM.EQ.'10SM')GOTO1200
C
      IF(ICASSM.EQ.'SM'.AND.IDEGRE.EQ.0)GOTO1100
      IF(ICASSM.EQ.'SM'.AND.IDEGRE.EQ.1)GOTO1100
      IF(ICASSM.EQ.'SM'.AND.IDEGRE.EQ.2)GOTO1120
      IF(ICASSM.EQ.'SM'.AND.IDEGRE.EQ.3)GOTO1120
      IF(ICASSM.EQ.'SM'.AND.IDEGRE.EQ.4)GOTO1140
      IF(ICASSM.EQ.'SM'.AND.IDEGRE.EQ.5)GOTO1140
      IF(ICASSM.EQ.'SM'.AND.IDEGRE.EQ.6)GOTO1160
      IF(ICASSM.EQ.'SM'.AND.IDEGRE.EQ.7)GOTO1160
      IF(ICASSM.EQ.'SM'.AND.IDEGRE.EQ.8)GOTO1180
      IF(ICASSM.EQ.'SM'.AND.IDEGRE.EQ.8)GOTO1180
      IF(ICASSM.EQ.'SM'.AND.IDEGRE.EQ.10)GOTO1200
C
      IF(ICASSM.EQ.'MESM')GOTO2100
      IF(ICASSM.EQ.'MDSM')GOTO2200
      IF(ICASSM.EQ.'MMSM')GOTO2300
      IF(ICASSM.EQ.'MRSM')GOTO2400
      IF(ICASSM.EQ.'UQSM')GOTO2500
      IF(ICASSM.EQ.'LQSM')GOTO2600
      IF(ICASSM.EQ.'MXSM')GOTO2700
      IF(ICASSM.EQ.'MNSM')GOTO2800
      IF(ICASSM.EQ.'TRSM')GOTO2900
      IF(ICASSM.EQ.'HMSM')GOTO3000
C
      IF(ICASSM.EQ.'ROSM')GOTO3100
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)
  811 FORMAT('***** INTERNAL ERROR IN DPSMO2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,812)
  812 FORMAT('      ICASSM NOT ONE OF THE ALLOWABLE TYPES--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,813)
  813 FORMAT('      SM, 0SM, 1SM, ..., 10SM, ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,814)
  814 FORMAT('      MESM, MDSM, MMSM, MRSM, UQSM, LQSM, MXSM, ',
     1'MNSM,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,815)
  815 FORMAT('      TRSM, OR ROSM')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,816)ICASSM
  816 FORMAT('      ICASSM = ',A4)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
C               **********************************************
C               **  STEP 3--                                **
C               **  TREAT THE LEAST SQUARES SMOOTHING CASE  **
C               **********************************************
C
C               ********************************************
C               **  STEP 3.1--                            **
C               **  DETERMINE LEAST SQUARES COEFFICIENTS  **
C               **  FOR THE SPECIFIED DEGREE AND WIDTH    **
C               ********************************************
C
 1100 CONTINUE
      ISTEPN='3.1'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      FACTOR=1.0/WIDTH
      DO1101I=1,IWHALF
      IREV=IFILWI-I+1
      TEMP(I)=FACTOR
      TEMP(IREV)=TEMP(I)
 1101 CONTINUE
      GOTO1900
C
 1120 CONTINUE
      FACTOR=3.0/((4.0*AM*AM-1.0)*(2.0*AM+3.0))
      DO1121I=1,IWHALF
      IREV=IFILWI-I+1
      R=I-M-1
      TEMP(I)=FACTOR*((3.0*AM*AM+3.0*AM-1.0)-(5.0*R*R))
      TEMP(IREV)=TEMP(I)
 1121 CONTINUE
      GOTO1900
C
 1140 CONTINUE
      FACTOR=15.0/(4.0*(4.0*AM*AM-1.0)*(4.0*AM*AM-9.0)*(2.0*AM+5.0))
      DO1141I=1,IWHALF
      IREV=IFILWI-I+1
      R=I-M-1
      TERM1=15.0*(AM**4)+30.0*(AM**3)-35.0*(AM**2)-50.0*AM+12.0
      TERM2=35.0*(2.0*(AM**2)+2.0*AM-3.0)*(R**2)
      TERM3=63.0*(R**4)
      TEMP(I)=FACTOR*(TERM1-TERM2+TERM3)
      TEMP(IREV)=TEMP(I)
 1141 CONTINUE
      GOTO1900
C
 1160 CONTINUE
      GOTO1290
C
 1180 CONTINUE
      GOTO1290
C
 1200 CONTINUE
      GOTO1290
C
 1290 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1291)
 1291 FORMAT('***** ERROR IN DPSMO2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1292)
 1292 FORMAT('      THE CURRENT MAXIMUM ALLOWABLE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1293)
 1293 FORMAT('      DEGREE FOR LEAST SQUARES SMOOTHING')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1294)MAXDEG
 1294 FORMAT('      IS DEGREE ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1295)IDEGRE
 1295 FORMAT('      THE SPECIFIED DEGREE = ',I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
C               **********************************************
C               **  STEP 3.2--                              **
C               **  COMPUTE SMOOTHED (= PREDICTED) VALUES.  **
C               **********************************************
C
 1900 CONTINUE
      ISTEPN='3.2'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO1910I=1,N
      JMIN=I-M
      JMAX=I+M
      IF(JMIN.LT.1.OR.JMAX.GT.N)GOTO1930
      SUM=0.0
      ICOUNT=0
      DO1920J=JMIN,JMAX
      ICOUNT=ICOUNT+1
      SUM=SUM+TEMP(ICOUNT)*Y(J)
 1920 CONTINUE
      PRED2(I)=SUM
      GOTO1910
 1930 CONTINUE
      PRED2(I)=Y(I)
 1910 CONTINUE
      GOTO5000
C
C               ***********************************
C               **  STEP 4--                     **
C               **  TREAT THE FOLLOWING CASES--  **
C               **     1) MOVING MEAN            **
C               **     2) MOVING MEDIAN          **
C               **     3) MOVING MIDMEAN         **
C               **     4) MOVING MIDRANGE        **
C               **     5) MOVING UPPER QUARTILE  **
C               **     6) MOVING LOWER QUARTILE  **
C               **     7) MOVING MINIMUM         **
C               **     8) MOVING MAXIMUM         **
C               **     9) MOVING TRIANGLE        **
C               **    10) HAMMING                **
C               ***********************************
C
C               *************************************
C               **  STEP 4.1--                     **
C               **  TREAT THE MOVING AVERAGE CASE  **
C               *************************************
C
 2100 CONTINUE
      ISTEPN='4.1'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      WIDTH=IFILWI
      IWHALF=(IFILWI/2)+1
      M=IFILWI/2
      COEF=1.0/WIDTH
C
      DO2110I=1,N
      JMIN=I-M
      JMAX=I+M
      IF(JMIN.LT.1.OR.JMAX.GT.N)GOTO2150
      SUM=0.0
      ICOUNT=0
      DO2120J=JMIN,JMAX
      ICOUNT=ICOUNT+1
      SUM=SUM+COEF*Y(J)
 2120 CONTINUE
      PRED2(I)=SUM
      GOTO2110
 2150 CONTINUE
      PRED2(I)=Y(I)
 2110 CONTINUE
C
      GOTO5000
C
C               ************************************
C               **  STEP 4.2--                    **
C               **  TREAT THE MOVING MEDIAN CASE  **
C               ************************************
C
 2200 CONTINUE
      ISTEPN='4.2'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      WIDTH=IFILWI
      IWHALF=(IFILWI/2)+1
      HALFSQ=IWHALF*IWHALF
      M=IFILWI/2
C
      DO2210I=1,N
      JMIN=I-M
      JMAX=I+M
      IF(JMIN.LT.1.OR.JMAX.GT.N)GOTO2250
      SUM=0.0
      ICOUNT=0
      DO2220J=JMIN,JMAX
      ICOUNT=ICOUNT+1
      TEMP(ICOUNT)=Y(J)
 2220 CONTINUE
      CALL SORT(TEMP,IFILWI,TEMP)
      PRED2(I)=TEMP(IWHALF)
      GOTO2210
 2250 CONTINUE
      PRED2(I)=Y(I)
 2210 CONTINUE
C
      GOTO5000
C
C               *************************************
C               **  STEP 4.3--                     **
C               **  TREAT THE MOVING MIDMEAN CASE  **
C               *************************************
C
 2300 CONTINUE
      ISTEPN='4.3'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      P1=0.25
      P2=0.25
C
      WIDTH=IFILWI
      IWHALF=(IFILWI/2)+1
      HALFSQ=IWHALF*IWHALF
      M=IFILWI/2
C
      DO2310I=1,N
      JMIN=I-M
      JMAX=I+M
      IF(JMIN.LT.1.OR.JMAX.GT.N)GOTO2370
      SUM=0.0
      ICOUNT=0
      DO2320J=JMIN,JMAX
      ICOUNT=ICOUNT+1
      TEMP(ICOUNT)=Y(J)
 2320 CONTINUE
      CALL SORT(TEMP,IFILWI,TEMP)
      IWP1=P1*WIDTH+0.0001
      ISTART=IWP1+1
      IWP2=P2*WIDTH+0.0001
      ISTOP=IFILWI-IWP2
      SUM=0.0
      K=0
      IF(ISTART.GT.ISTOP)GOTO2360
      DO2330L=ISTART,ISTOP
      K=K+1
      SUM=SUM+TEMP(L)
 2330 CONTINUE
      AK=K
      YMIDM=SUM/AK
      GOTO2380
 2360 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2361)
 2361 FORMAT('***** INTERNAL ERROR IN MMMSMO SUBROUTINE--',
     1 'THE START INDEX IS HIGHER THAN THE STOP INDEX ',
     1'IN DO LOOP 2330')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 2380 CONTINUE
      PRED2(I)=YMIDM
      GOTO2310
 2370 CONTINUE
      PRED2(I)=Y(I)
 2310 CONTINUE
C
      GOTO5000
C
C               **************************************
C               **  STEP 4.4--                      **
C               **  TREAT THE MOVING MIDRANGE CASE  **
C               **************************************
C
 2400 CONTINUE
      ISTEPN='4.4'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      WIDTH=IFILWI
      M=IFILWI/2
C
      DO2410I=1,N
      JMIN=I-M
      JMAX=I+M
      IF(JMIN.LT.1.OR.JMAX.GT.N)GOTO2450
      SUM=0.0
      ICOUNT=0
      DO2420J=JMIN,JMAX
      ICOUNT=ICOUNT+1
      TEMP(ICOUNT)=Y(J)
 2420 CONTINUE
      CALL SORT(TEMP,IFILWI,TEMP)
      PRED2(I)=(TEMP(1)+TEMP(IFILWI))/2.0
      GOTO2410
 2450 CONTINUE
      PRED2(I)=Y(I)
 2410 CONTINUE
C
      GOTO5000
C
C               ********************************************
C               **  STEP 4.5--                            **
C               **  TREAT THE MOVING UPPER QUARTILE CASE  **
C               ********************************************
C
 2500 CONTINUE
      ISTEPN='4.5'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      WIDTH=IFILWI
      P1=0.25
      IWP1=P1*WIDTH+0.0001
      IWP2=IFILWI-IWP1
      M=IFILWI/2
C
      DO2510I=1,N
      JMIN=I-M
      JMAX=I+M
      IF(JMIN.LT.1.OR.JMAX.GT.N)GOTO2550
      SUM=0.0
      ICOUNT=0
      DO2520J=JMIN,JMAX
      ICOUNT=ICOUNT+1
      TEMP(ICOUNT)=Y(J)
 2520 CONTINUE
      CALL SORT(TEMP,IFILWI,TEMP)
      PRED2(I)=TEMP(IWP2)
      GOTO2510
 2550 CONTINUE
      PRED2(I)=Y(I)
 2510 CONTINUE
C
      GOTO5000
C
C               ********************************************
C               **  STEP 4.6--                            **
C               **  TREAT THE MOVING LOWER QUARTILE CASE  **
C               ********************************************
C
 2600 CONTINUE
      ISTEPN='4.6'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      WIDTH=IFILWI
      P1=0.25
      IWP1=P1*WIDTH+0.0001
      M=IFILWI/2
C
      DO2610I=1,N
      JMIN=I-M
      JMAX=I+M
      IF(JMIN.LT.1.OR.JMAX.GT.N)GOTO2650
      SUM=0.0
      ICOUNT=0
      DO2620J=JMIN,JMAX
      ICOUNT=ICOUNT+1
      TEMP(ICOUNT)=Y(J)
 2620 CONTINUE
      CALL SORT(TEMP,IFILWI,TEMP)
      PRED2(I)=TEMP(IWP1)
      GOTO2610
 2650 CONTINUE
      PRED2(I)=Y(I)
 2610 CONTINUE
C
C               *************************************
C               **  STEP 4.7--                     **
C               **  TREAT THE MOVING MAXIMUM CASE  **
C               *************************************
C
 2700 CONTINUE
      ISTEPN='4.7'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      WIDTH=IFILWI
      M=IFILWI/2
C
      DO2710I=1,N
      JMIN=I-M
      JMAX=I+M
      IF(JMIN.LT.1.OR.JMAX.GT.N)GOTO2750
      YMAX=Y(JMIN)
      DO2720J=JMIN,JMAX
      IF(Y(J).GT.YMAX)YMAX=Y(J)
 2720 CONTINUE
      PRED2(I)=YMAX
      GOTO2710
 2750 CONTINUE
      PRED2(I)=Y(I)
 2710 CONTINUE
C
      GOTO5000
C
C               *************************************
C               **  STEP 4.8--                     **
C               **  TREAT THE MOVING MINIMUM CASE  **
C               *************************************
C
 2800 CONTINUE
      ISTEPN='4.8'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      WIDTH=IFILWI
      M=IFILWI/2
C
      DO2810I=1,N
      JMIN=I-M
      JMAX=I+M
      IF(JMIN.LT.1.OR.JMAX.GT.N)GOTO2850
      YMIN=Y(JMIN)
      DO2820J=JMIN,JMAX
      IF(Y(J).LT.YMIN)YMIN=Y(J)
 2820 CONTINUE
      PRED2(I)=YMIN
      GOTO2810
 2850 CONTINUE
      PRED2(I)=Y(I)
 2810 CONTINUE
C
      GOTO5000
C
C               *******************************************
C               **  STEP 4.9--                           **
C               **  TREAT THE TRIANGULAR SMOOTHING CASE  **
C               *******************************************
C
 2900 CONTINUE
      ISTEPN='4.9'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      WIDTH=IFILWI
      IWHALF=(IFILWI/2)+1
      HALFSQ=IWHALF*IWHALF
      M=IFILWI/2
C
      DO2910I=1,N
      JMIN=I-M
      JMAX=I+M
      IF(JMIN.LT.1.OR.JMAX.GT.N)GOTO2950
      SUM=0.0
      ICOUNT=0
      DO2920J=JMIN,JMAX
      ICOUNT=ICOUNT+1
      IF(ICOUNT.LE.IWHALF)COEF=ICOUNT
      IF(ICOUNT.GT.IWHALF)COEF=IFILWI-ICOUNT+1
      COEF=COEF/HALFSQ
      SUM=SUM+COEF*Y(J)
 2920 CONTINUE
      PRED2(I)=SUM
      GOTO2910
 2950 CONTINUE
      PRED2(I)=Y(I)
 2910 CONTINUE
C
      GOTO5000
C
C               *******************************************
C               **  STEP 4.10--                          **
C               **  TREAT THE HAMMING  SMOOTHING CASE    **
C               *******************************************
C
 3000 CONTINUE
      ISTEPN='4.10'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      WIDTH=3
      IWHALF=2
      HALFSQ=IWHALF*IWHALF
      M=1
C
      DO3010I=1,N
      JMIN=I-M
      JMAX=I+M
      IF(JMIN.LT.1.OR.JMAX.GT.N)GOTO3050
      SUM=0.0
      ICOUNT=0
      DO3020J=JMIN,JMAX
      ICOUNT=ICOUNT+1
      IF(ICOUNT.LE.IWHALF)COEF=ICOUNT
      IF(ICOUNT.GT.IWHALF)COEF=IFILWI-ICOUNT+1
      COEF=COEF/HALFSQ
      SUM=SUM+COEF*Y(J)
 3020 CONTINUE
      PRED2(I)=SUM
      GOTO3010
 3050 CONTINUE
      PRED2(I)=Y(I)
 3010 CONTINUE
C
      GOTO5000
C
C               ***************************************
C               **  STEP 5--                         **
C               **  TREAT THE ROBUST SMOOTHING CASE  **
C               ***************************************
C
 3100 CONTINUE
      ISTEPN='5'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,3191)
C3191 FORMAT('***** ERROR IN DPSMO2--')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,3192)
C3192 FORMAT('      THE ROBUST SMOOTHING CAPABILITY')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,3193)
C3193 FORMAT('      IS NOT YET AVAILABLE IN DATAPLOT.')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC IERROR='YES'
CCCCC GOTO9000
C
      CALL DP3RSR(Y,TEMP,N,PRED2,RES2,IBUGA3,IERROR)
      GOTO5000
C
C               *************************
C               **  STEP 11--          **
C               **  COMPUTE RESIDUALS  **
C               *************************
C
 5000 CONTINUE
      ISTEPN='11'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO5050I=1,N
      RES2(I)=Y(I)-PRED2(I)
 5050 CONTINUE
C
C               *********************************************************
C               **  STEP 12--                                          **
C               **  COMPUTE VARIOUS MEASURES OF    GOODNESS OF FIT   --    **
C               **    1) THE STANDARD DEVIATION AND                    **
C               **       THE AVERAGE ABSOLUTE DEVIATION                **
C               **       OF THE RAW DATA                               **
C               **       (THAT IS, THE UNSMOOTHED DATA);               **
C               **    2) THE STANDARD DEVIATION AND                    **
C               **       THE AVERAGE ABSOLUTE DEVIATION                **
C               **       OF THE RESIDUALS FROM THE                     **
C               **       MOVING AVERAGE FIT WITH THE SPECIFIED WIDTH;  **
C               **    3) THE STANDARD DEVIATION AND                    **
C               **       THE AVERAGE ABSOLUTE DEVIATION                **
C               **       OF THE RESIDUALS FROM THE                     **
C               **       MOVING LEAST SQUARES FIT WITH THE             **
C               **       SPECIFIED DEGREE AND WIDTH.                   **
C               *********************************************************
C
 5100 CONTINUE
      ISTEPN='12'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C
      AN=N
      SUM=0.0
      DO5150I=1,N
      SUM=SUM+Y(I)
 5150 CONTINUE
      YBAR=SUM/AN
C
      SUMSQ=0.0
      SUMAB=0.0
      DO5155I=1,N
      RESY=Y(I)-YBAR
      SUMSQ=SUMSQ+RESY*RESY
      SUMAB=SUMAB+ABS(RESY)
 5155 CONTINUE
      VARY=SUMSQ/(AN-1.0)
      SDY=0.0
      IF(VARY.GT.0.0)SDY=SQRT(VARY)
      AARY=SUMAB/AN
C
      SUMSQ=0.0
      SUMAB=0.0
      DO5160I=1,N
      JMIN=I-M
      JMAX=I+M
      IF(JMIN.LT.1.OR.JMAX.GT.N)GOTO5160
      SUM=0.0
      DO5165J=JMIN,JMAX
      SUM=SUM+(1.0/WIDTH)*Y(J)
 5165 CONTINUE
      PREDMA=SUM
      RESMA=Y(I)-PREDMA
      SUMSQ=SUMSQ+RESMA*RESMA
      SUMAB=SUMAB+ABS(RESMA)
 5160 CONTINUE
      VARMA=SUMSQ/(AN-1.0)
      SDMA=0.0
      IF(VARMA.GT.0.0)SDMA=SQRT(VARMA)
      AARMA=SUMAB/AN
C
      DENOM=N-1
      SUMSQ=0.0
      SUMAB=0.0
      DO5170I=1,N
      SUMSQ=SUMSQ+RES2(I)**2
      SUMAB=SUMAB+ABS(RES2(I))
 5170 CONTINUE
      VAR=SUMSQ/DENOM
      S=0.0
      IF(VAR.GT.0.0)S=SQRT(VAR)
      RESDF=DENOM
      RESSD=S
      RESAAR=SUMAB/AN
C
C               ****************************
C               **  STEP 13--             **
C               **  WRITE EVERYTHING OUT  **
C               ****************************
C
 6000 CONTINUE
      ISTEPN='13'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IPRINT.EQ.'OFF')GOTO6190
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6105)
 6105 FORMAT('SMOOTHING')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
C
      IF(ICASS2.EQ.'SM')WRITE(ICOUT,6111)
 6111 FORMAT('      SMOOTHING FUNCTION--LEAST SQUARES')
      IF(ICASS2.EQ.'SM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'MESM')WRITE(ICOUT,6112)
 6112 FORMAT('      SMOOTHING FUNCTION--MOVING MEAN')
      IF(ICASSM.EQ.'MESM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'MDSM')WRITE(ICOUT,6113)
 6113 FORMAT('      SMOOTHING FUNCTION--MOVING MEDIAN')
      IF(ICASSM.EQ.'MDSM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'MMSM')WRITE(ICOUT,6114)
 6114 FORMAT('      SMOOTHING FUNCTION--MOVING MIDMEAN')
      IF(ICASSM.EQ.'MMSM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'MRSM')WRITE(ICOUT,6115)
 6115 FORMAT('      SMOOTHING FUNCTION--MOVING MIDRANGE')
      IF(ICASSM.EQ.'MRSM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'UQSM')WRITE(ICOUT,6116)
 6116 FORMAT('      SMOOTHING FUNCTION--MOVING UPPER QUARTILE')
      IF(ICASSM.EQ.'UQSM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'LQSM')WRITE(ICOUT,6117)
 6117 FORMAT('      SMOOTHING FUNCTION--MOVING LOWER QUARTILE')
      IF(ICASSM.EQ.'LQSM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'MXSM')WRITE(ICOUT,6118)
 6118 FORMAT('      SMOOTHING FUNCTION--MOVING MAXIMUM')
      IF(ICASSM.EQ.'MXSM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'MNSM')WRITE(ICOUT,6119)
 6119 FORMAT('      SMOOTHING FUNCTION--MOVING MINIMUM')
      IF(ICASSM.EQ.'MNSM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'TRSM')WRITE(ICOUT,6120)
 6120 FORMAT('      SMOOTHING FUNCTION--MOVING TRIANGLE')
      IF(ICASSM.EQ.'TRSM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'HMSM')WRITE(ICOUT,6121)
 6121 FORMAT('      SMOOTHING FUNCTION--HAMMING')
      IF(ICASSM.EQ.'HMSM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'ROSM')WRITE(ICOUT,6122)
 6122 FORMAT('      SMOOTHING FUNCTION--ROBUST (3RSR)')
      IF(ICASSM.EQ.'ROSM')CALL DPWRST('XXX','BUG ')
C
      WRITE(ICOUT,6131)N
 6131 FORMAT('      NUMBER OF OBSERVATIONS       = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(ICASS2.EQ.'LSSQ')WRITE(ICOUT,6132)IFILWI
 6132 FORMAT('      WIDTH  OF SMOOTHING FUNCTION = ',I8)
      IF(ICASS2.EQ.'LSSQ')CALL DPWRST('XXX','BUG ')
      IF(ICASS2.EQ.'OTSQ')WRITE(ICOUT,6132)IFILWI
      IF(ICASS2.EQ.'OTSQ')CALL DPWRST('XXX','BUG ')
      IF(ICASS2.EQ.'LSSQ')WRITE(ICOUT,6133)IDEGRE
 6133 FORMAT('      DEGREE OF SMOOTHING FUNCTION = ',I8)
      IF(ICASS2.EQ.'LSSQ')CALL DPWRST('XXX','BUG ')
      IF(ICASS2.EQ.'ROSM')WRITE(ICOUT,6134)(IRSTRI(I),I=1,30)
 6134 FORMAT('      DEFINING STRING              = ',30A1)
      IF(ICASS2.EQ.'ROSM')CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6135)
 6135 FORMAT('****************************************************',
     1'*******************')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6136)
 6136 FORMAT('*                               * ','   RESIDUAL    ',
     1' * ','   AVERAGE     ',' *')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6137)
 6137 FORMAT('*                               * ','   STANDARD    ',
     1' * ','   ABSOLUTE    ',' *')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6138)
 6138 FORMAT('*                               * ','   DEVIATION   ',
     1' * ','   RESIDUAL    ',' *')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6139)
 6139 FORMAT('*                               * ',' (DIVISOR=N-1) ',
     1' * ','  (DIVISOR=N)  ',' *')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6135)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6141)SDY,AARY
 6141 FORMAT('* NO SMOOTHING                  * ',F15.7,' * ',F15.7,
     1' *')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6142)
 6142 FORMAT('* (RAW DATA)',5X,'         ',4X,'  * ',15X,' * ',15X,
     1' *')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6143)
 6143 FORMAT('*           ',5X,'         ',4X,'  * ',15X,' * ',15X,
     1' *')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6144)SDMA,AARMA
 6144 FORMAT('* MOVING AVERAGE SMOOTHING      * ',F15.7,' * ',F15.7,
     1' *')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6145)IFILWI
 6145 FORMAT('* WIDTH =',I8,'         ',4X,'  * ',15X,' * ',15X,
     1' *')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6143)
      CALL DPWRST('XXX','BUG ')
C
      IF(ICASS2.EQ.'SM')WRITE(ICOUT,6151)RESSD,RESAAR
 6151 FORMAT('* LEAST SQUARES SMOOTHING       * ',F15.7,' * ',F15.7,
     1' *')
      IF(ICASS2.EQ.'SM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'MESM')WRITE(ICOUT,6152)RESSD,RESAAR
 6152 FORMAT('* MOVING MEAN SMOOTHING         * ',F15.7,' * ',F15.7,
     1' *')
      IF(ICASSM.EQ.'MESM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'MDSM')WRITE(ICOUT,6153)RESSD,RESAAR
 6153 FORMAT('* MOVING MEDIAN SMOOTHING       * ',F15.7,' * ',F15.7,
     1' *')
      IF(ICASSM.EQ.'MDSM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'MMSM')WRITE(ICOUT,6154)RESSD,RESAAR
 6154 FORMAT('* MOVING MIDMEAN SMOOTHING      * ',F15.7,' * ',F15.7,
     1' *')
      IF(ICASSM.EQ.'MMSM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'MRSM')WRITE(ICOUT,6155)RESSD,RESAAR
 6155 FORMAT('* MOVING MIDRANGE SMOOTHING     * ',F15.7,' * ',F15.7,
     1' *')
      IF(ICASSM.EQ.'MRSM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'UQSM')WRITE(ICOUT,6156)RESSD,RESAAR
 6156 FORMAT('* MOVING UPPER QUAR. SMOOTHING  * ',F15.7,' * ',F15.7,
     1' *')
      IF(ICASSM.EQ.'UQSM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'LQSM')WRITE(ICOUT,6157)RESSD,RESAAR
 6157 FORMAT('* MOVING LOWER QUAR. SMOOTHING  * ',F15.7,' * ',F15.7,
     1' *')
      IF(ICASSM.EQ.'LQSM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'MXSM')WRITE(ICOUT,6158)RESSD,RESAAR
 6158 FORMAT('* MOVING MAXIMUM SMOOTHING      * ',F15.7,' * ',F15.7,
     1' *')
      IF(ICASSM.EQ.'MXSM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'MNSM')WRITE(ICOUT,6159)RESSD,RESAAR
 6159 FORMAT('* MOVING MINIMUM SMOOTHING      * ',F15.7,' * ',F15.7,
     1' *')
      IF(ICASSM.EQ.'MNSM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'TRSM')WRITE(ICOUT,6160)RESSD,RESAAR
 6160 FORMAT('* MOVING TRIANGLE SMOOTHING     * ',F15.7,' * ',F15.7,
     1' *')
      IF(ICASSM.EQ.'TRSM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'HMSM')WRITE(ICOUT,6161)RESSD,RESAAR
 6161 FORMAT('* HAMMING SMOOTHING             * ',F15.7,' * ',F15.7,
     1' *')
      IF(ICASSM.EQ.'HMSM')CALL DPWRST('XXX','BUG ')
      IF(ICASSM.EQ.'ROSM')WRITE(ICOUT,6162)RESSD,RESAAR
 6162 FORMAT('* ROBUST SMOOTHING (3RSR)       * ',F15.7,' * ',F15.7,
     1' *')
      IF(ICASSM.EQ.'ROSM')CALL DPWRST('XXX','BUG ')
C
      IF(ICASS2.EQ.'SM')WRITE(ICOUT,6171)IFILWI,IDEGRE
 6171 FORMAT('* WIDTH =',I8,' DEGREE =',I4,'  * ',15X,' * ',15X,
     1' *')
      IF(ICASS2.EQ.'SM')CALL DPWRST('XXX','BUG ')
      IF(ICASS2.EQ.'OTSM')WRITE(ICOUT,6172)IFILWI
 6172 FORMAT('* WIDTH =',I8,'         ',4X,'  * ',15X,' * ',15X,
     1' *')
      IF(ICASS2.EQ.'OTSM')CALL DPWRST('XXX','BUG ')
      IF(ICASS2.EQ.'ROSM')WRITE(ICOUT,6173)(IRSTRI(I),I=1,30)
 6173 FORMAT('* ',30A1,'* ',15X,' * ',15X,
     1' *')
      IF(ICASS2.EQ.'ROSM')CALL DPWRST('XXX','BUG ')
C
      WRITE(ICOUT,6135)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
 6190 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPSMO2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)N,IBUGA3,IERROR
 9012 FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)ICASSM,ICASS2,IFILWI,IDEGRE
 9013 FORMAT('ICASSM,ICASS2,IFILWI,IDEGRE = ',A4,2X,A4,2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)NUMCRS,MAXCRS
 9014 FORMAT('NUMCRS,MAXCRS = ',I8,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)(IRSTRI(I),I=1,MAXCRS)
 9015 FORMAT('IRSTRI(.) = ',30A1)
      CALL DPWRST('XXX','BUG ')
      DO9016I=1,N
      WRITE(ICOUT,9017)I,Y(I),W(I),PRED2(I),RES2(I)
 9017 FORMAT('I,Y(I),W(I),PRED2(I),RES2(I) = ',I8,4E15.7)
      CALL DPWRST('XXX','BUG ')
 9016 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPSMOO(IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
C
C     PURPOSE--CARRY OUT A SMOOTHING OPERATION.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--JUNE      1978.
C     UPDATED         --JULY      1978.
C     UPDATED         --NOVEMBER  1978.
C     UPDATED         --JULY      1979.
C     UPDATED         --FEBRUARY  1981.
C     UPDATED         --JULY      1981.
C     UPDATED         --SEPTEMBER 1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --JULY      1983.
C     UPDATED         --MARCH     1988.      ADD LOFCDF
C     UPDATED         --JUNE      1990.      TEMPORARY ARRAYS TO GARBAGE COMMON
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 IRSTRI
      CHARACTER*4 ICASSM
      CHARACTER*4 IHWUSE
      CHARACTER*4 MESSAG
      CHARACTER*4 ICASEQ
      CHARACTER*4 IREPU
      CHARACTER*4 IRESU
      CHARACTER*4 IHLEFT
      CHARACTER*4 IHLEF2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION TEMP(MAXOBV)
      DIMENSION IRSTRI(30)
C
      DIMENSION PRED2(MAXOBV)
      DIMENSION RES2(MAXOBV)
C
      DIMENSION W(MAXOBV)
C
CCCCC FOLLOWING LINES ADDED JUNE, 1990
      INCLUDE 'DPCOZZ.INC'
      EQUIVALENCE (GARBAG(IGARB1),TEMP(1))
      EQUIVALENCE (GARBAG(IGARB2),PRED2(1))
      EQUIVALENCE (GARBAG(IGARB3),RES2(1))
      EQUIVALENCE (GARBAG(IGARB4),W(1))
CCCCC END CHANGE
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOHK.INC'
      INCLUDE 'DPCOSU.INC'
      INCLUDE 'DPCODA.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IERROR='NO'
C
      ISUBN1='DPSM'
      ISUBN2='OO  '
C
      MAXCP1=MAXCOL+1
      MAXCP2=MAXCOL+2
      MAXCP3=MAXCOL+3
      MAXCP4=MAXCOL+4
      MAXCP5=MAXCOL+5
      MAXCP6=MAXCOL+6
C
      MAXV2=1
      MINN2=2
C
      ICASEQ='UNKN'
C
      MAXCRS=30
      NUMCRS=0
      DO10I=1,MAXCRS
      IRSTRI(I)=' '
   10 CONTINUE
C
C               ********************************
C               **  TREAT THE SMOOTHING CASE  **
C               ********************************
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 DPSMOO--')
      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 ')
   90 CONTINUE
C
C               ***************************
C               **  STEP 1--             **
C               **  EXTRACT THE COMMAND  **
C               ***************************
C
      ISTEPN='1'
      IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C               *********************************
C               **  STEP 1.1--                 **
C               **  SEARCH FOR SMOOTH          **
C               **  (WITH UNSPECIFIED DEGREE)  **
C               *********************************
C
      ICASSM='SM'
C
      IF(ICOM.EQ.'SMOO')GOTO110
C
C               *******************************************
C               **  STEP 1.2--                           **
C               **  SEARCH FOR ROBUST         SMOOTHING  **
C               *******************************************
C
      ICASSM='ROSM'
C
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'ROBU'.AND.IHARG(1).EQ.'SMOO')GOTO111
C
C               *******************************************
C               **  STEP 1.3--                           **
C               **  SEARCH FOR MOVING AVERAGE SMOOTHING  **
C               *******************************************
C
      ICASSM='MESM'
C
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'MOVI'.AND.IHARG(1).EQ.'AVER'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'MOVI'.AND.IHARG(1).EQ.'MEAN'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'MOVI'.AND.IHARG(1).EQ.'XBAR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'AVER'.AND.IHARG(1).EQ.'SMOO')GOTO111
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'MEAN'.AND.IHARG(1).EQ.'SMOO')GOTO111
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'XBAR'.AND.IHARG(1).EQ.'SMOO')GOTO111
C
C               *******************************************
C               **  STEP 1.4--                           **
C               **  SEARCH FOR MOVING MEDIAN   SMOOTHING  **
C               *******************************************
C
      ICASSM='MDSM'
C
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'MOVI'.AND.IHARG(1).EQ.'MEDI'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'MEDI'.AND.IHARG(1).EQ.'SMOO')GOTO111
C
C               *******************************************
C               **  STEP 1.5--                           **
C               **  SEARCH FOR MOVING MIDMEAN SMOOTHING  **
C               *******************************************
C
      ICASSM='MMSM'
C
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'MOVI'.AND.IHARG(1).EQ.'MIDM'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'MIDM'.AND.IHARG(1).EQ.'SMOO')GOTO111
C
C               *******************************************
C               **  STEP 1.6--                           **
C               **  SEARCH FOR MOVING MIDRANGE SMOOTHING **
C               *******************************************
C
      ICASSM='MRSM'
C
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'MOVI'.AND.IHARG(1).EQ.'MIDR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'MIDR'.AND.IHARG(1).EQ.'SMOO')GOTO111
C
C               **************************************************
C               **  STEP 1.7--                                  **
C               **  SEARCH FOR MOVING UPPER QUARTILE SMOOTHING  **
C               **************************************************
C
      ICASSM='UQSM'
C
      IF(NUMARG.GE.3.AND.
     1ICOM.EQ.'MOVI'.AND.IHARG(1).EQ.'UPPE'.AND.IHARG(2).EQ.'QUAR'.AND.
     1IHARG(3).EQ.'SMOO')GOTO113
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'UPPE'.AND.IHARG(1).EQ.'QUAR'.AND.
     1IHARG(2).EQ.'SMOO')GOTO112
C
C               **************************************************
C               **  STEP 1.8--                                  **
C               **  SEARCH FOR MOVING LOWER QUARTILE SMOOTHING  **
C               **************************************************
C
      ICASSM='LQSM'
C
      IF(NUMARG.GE.3.AND.
     1ICOM.EQ.'MOVI'.AND.IHARG(1).EQ.'LOWE'.AND.IHARG(2).EQ.'QUAR'.AND.
     1IHARG(3).EQ.'SMOO')GOTO113
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'LOWE'.AND.IHARG(1).EQ.'QUAR'.AND.
     1IHARG(2).EQ.'SMOO')GOTO112
C
C               *******************************************
C               **  STEP 1.9--                           **
C               **  SEARCH FOR MOVING MAXIMUM  SMOOTHING **
C               *******************************************
C
      ICASSM='MXSM'
C
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'MOVI'.AND.IHARG(1).EQ.'MAXI'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'MAXI'.AND.IHARG(1).EQ.'SMOO')GOTO111
C
C               *******************************************
C               **  STEP 1.10--                          **
C               **  SEARCH FOR MOVING MINIMUM  SMOOTHING **
C               *******************************************
C
      ICASSM='MNSM'
C
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'MOVI'.AND.IHARG(1).EQ.'MINI'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'MIDR'.AND.IHARG(1).EQ.'SMOO')GOTO111
C
C               *********************************************
C               **  STEP 1.11--                            **
C               **  SEARCH FOR MOVING TRIANGULAR SMOOTHING **
C               *********************************************
C
      ICASSM='TRSM'
C
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'MOVI'.AND.IHARG(1).EQ.'TRIA'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'TRIA'.AND.IHARG(1).EQ.'SMOO')GOTO111
C
C               *********************************************
C               **  STEP 1.12--                            **
C               **  SEARCH FOR HAMMING SMOOTHING **
C               *********************************************
C
      ICASSM='HMSM'
C
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'MOVI'.AND.IHARG(1).EQ.'HAMM'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'HAMM'.AND.IHARG(1).EQ.'SMOO')GOTO111
C
C               *******************************************
C               **  STEP 1.20--                          **
C               **  SEARCH FOR 0-TH DEGREE    SMOOTHING  **
C               *******************************************
C
      ICASSM='0SM'
C
      IF(NUMARG.GE.3.AND.
     1ICOM.EQ.'0'.AND.IHARG(1).EQ.'TH'.AND.IHARG(2).EQ.'DEGR'.AND.
     1IHARG(3).EQ.'SMOO')GOTO113
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'0TH'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'ZERO'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'0'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'0'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'ZERO'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'CONS'.AND.IHARG(1).EQ.'SMOO')GOTO111
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'RECT'.AND.IHARG(1).EQ.'SMOO')GOTO111
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'FLAT'.AND.IHARG(1).EQ.'SMOO')GOTO111
C
C               *******************************************
C               **  STEP 1.21--                          **
C               **  SEARCH FOR 1-ST DEGREE    SMOOTHING  **
C               *******************************************
C
      ICASSM='1SM'
C
      IF(NUMARG.GE.3.AND.
     1ICOM.EQ.'1'.AND.IHARG(1).EQ.'ST'.AND.IHARG(2).EQ.'DEGR'.AND.
     1IHARG(3).EQ.'SMOO')GOTO113
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'1ST'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'FIRS'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'1'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'ONE'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'1'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'ONE'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'LINE'.AND.IHARG(1).EQ.'SMOO')GOTO111
C
C               *******************************************
C               **  STEP 1.22--                          **
C               **  SEARCH FOR 2-ND DEGREE    SMOOTHING  **
C               *******************************************
C
      ICASSM='2SM'
C
      IF(NUMARG.GE.3.AND.
     1ICOM.EQ.'2'.AND.IHARG(1).EQ.'ND'.AND.IHARG(2).EQ.'DEGR'.AND.
     1IHARG(3).EQ.'SMOO')GOTO113
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'2ND'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'SECO'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'2'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'TWO'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'2'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'TWO'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'QUAD'.AND.IHARG(1).EQ.'SMOO')GOTO111
C
C               *******************************************
C               **  STEP 1.23--                          **
C               **  SEARCH FOR 3-RD DEGREE    SMOOTHING  **
C               *******************************************
C
      ICASSM='3SM'
C
      IF(NUMARG.GE.3.AND.
     1ICOM.EQ.'3'.AND.IHARG(1).EQ.'RD'.AND.IHARG(2).EQ.'DEGR'.AND.
     1IHARG(3).EQ.'SMOO')GOTO113
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'3RD'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'THIR'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'3'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'THRE'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'3'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'THRE'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'CUBI'.AND.IHARG(1).EQ.'SMOO')GOTO111
C
C               *******************************************
C               **  STEP 1.24--                          **
C               **  SEARCH FOR 4-TH DEGREE    SMOOTHING  **
C               *******************************************
C
      ICASSM='4SM'
C
      IF(NUMARG.GE.3.AND.
     1ICOM.EQ.'4'.AND.IHARG(1).EQ.'TH'.AND.IHARG(2).EQ.'DEGR'.AND.
     1IHARG(3).EQ.'SMOO')GOTO113
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'4TH'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'FOUR'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'4'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'FOUR'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'4'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'FOUR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'QUAR'.AND.IHARG(1).EQ.'SMOO')GOTO111
C
C               *******************************************
C               **  STEP 1.25--                          **
C               **  SEARCH FOR 5-TH DEGREE    SMOOTHING  **
C               *******************************************
C
      ICASSM='5SM'
C
      IF(NUMARG.GE.3.AND.
     1ICOM.EQ.'5'.AND.IHARG(1).EQ.'TH'.AND.IHARG(2).EQ.'DEGR'.AND.
     1IHARG(3).EQ.'SMOO')GOTO113
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'5TH'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'FIFT'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'5'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'FIVE'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'5'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'FIVE'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'QUIN'.AND.IHARG(1).EQ.'SMOO')GOTO111
C
C               *******************************************
C               **  STEP 1.26--                          **
C               **  SEARCH FOR 6-TH DEGREE    SMOOTHING  **
C               *******************************************
C
      ICASSM='6SM'
C
      IF(NUMARG.GE.3.AND.
     1ICOM.EQ.'6'.AND.IHARG(1).EQ.'TH'.AND.IHARG(2).EQ.'DEGR'.AND.
     1IHARG(3).EQ.'SMOO')GOTO113
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'6TH'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'SIXT'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'6'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'SIX'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'6'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'SIX'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'SEXT'.AND.IHARG(1).EQ.'SMOO')GOTO111
C
C               *******************************************
C               **  STEP 1.27--                          **
C               **  SEARCH FOR 7-TH DEGREE    SMOOTHING  **
C               *******************************************
C
      ICASSM='7SM'
C
      IF(NUMARG.GE.3.AND.
     1ICOM.EQ.'7'.AND.IHARG(1).EQ.'TH'.AND.IHARG(2).EQ.'DEGR'.AND.
     1IHARG(3).EQ.'SMOO')GOTO113
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'7TH'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'SEVE'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'7'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'SEVE'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'7'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'SEVE'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'SEPT'.AND.IHARG(1).EQ.'SMOO')GOTO111
C
C               *******************************************
C               **  STEP 1.28--                          **
C               **  SEARCH FOR 8-TH DEGREE    SMOOTHING  **
C               *******************************************
C
      ICASSM='8SM'
C
      IF(NUMARG.GE.3.AND.
     1ICOM.EQ.'8'.AND.IHARG(1).EQ.'TH'.AND.IHARG(2).EQ.'DEGR'.AND.
     1IHARG(3).EQ.'SMOO')GOTO113
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'8TH'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'EIGH'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'8'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'EIGH'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'8'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'EIGH'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'QUIN'.AND.IHARG(1).EQ.'SMOO')GOTO111
C
C               *******************************************
C               **  STEP 1.29--                          **
C               **  SEARCH FOR 9-TH DEGREE    SMOOTHING  **
C               *******************************************
C
      ICASSM='9SM'
C
      IF(NUMARG.GE.3.AND.
     1ICOM.EQ.'9'.AND.IHARG(1).EQ.'TH'.AND.IHARG(2).EQ.'DEGR'.AND.
     1IHARG(3).EQ.'SMOO')GOTO113
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'9TH'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'NINT'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'9'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'NINE'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'9'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'NINE'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'NONI'.AND.IHARG(1).EQ.'SMOO')GOTO111
C
C               *******************************************
C               **  STEP 1.20--                          **
C               **  SEARCH FOR 10-TH DEGREE   SMOOTHING  **
C               *******************************************
C
      ICASSM='10SM'
C
      IF(NUMARG.GE.3.AND.
     1ICOM.EQ.'10'.AND.IHARG(1).EQ.'TH'.AND.IHARG(2).EQ.'DEGR'.AND.
     1IHARG(3).EQ.'SMOO')GOTO113
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'10TH'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'TENT'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'10'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'TEN'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'10'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'TEN'.AND.IHARG(2).EQ.'SMOO')
     1GOTO112
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'DEXI'.AND.IHARG(1).EQ.'SMOO')GOTO111
C
C               ********************************************
C               **  STEP 1.31--                           **
C               **  SINCE VALID COMMAND NOT FOUND, EXIT.  **
C               ********************************************
C
      ICASSM='    '
C
      IFOUND='NO'
      GOTO9000
C
  110 CONTINUE
      ILASTC=0
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO180
C
  111 CONTINUE
      ILASTC=1
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO180
C
  112 CONTINUE
      ILASTC=2
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO180
C
  113 CONTINUE
      ILASTC=3
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO180
C
  180 CONTINUE
      IFOUND='YES'
      GOTO190
C
  190 CONTINUE
C
C               *******************************************************
C               **  STEP 2--                                         **
C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
C               *******************************************************
C
      ISTEPN='2'
      IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      MINNA=1
      MAXNA=100
      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,
     1IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
C               ********************************************
C               **  STEP 3--                              **
C               **  CHECK THE VALIDITY OF ARGUMENT 1      **
C               **  (THIS WILL BE THE RESPONSE VARIABLE)  **
C               ********************************************
C
      ISTEPN='3'
      IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IHLEFT=IHARG(1)
      IHLEF2=IHARG2(1)
      IHWUSE='V'
      MESSAG='YES'
      CALL CHECKN(IHLEFT,IHLEF2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      ICOLL=IVALUE(ILOCV)
      NLEFT=IN(ILOCV)
C
C               ***********************************************************
C               **  STEP 4--                                             **
C               **  CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT)  **
C               **  FOR THE RESPONSE VARIABLE IS 2 OR MORE.              **
C               ***********************************************************
C
      ISTEPN='4'
      IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NLEFT.GE.MINN2)GOTO390
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,311)
  311 FORMAT('***** ERROR IN DPSMOO--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,312)
  312 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,313)
  313 FORMAT('      (FOR WHICH AN SMOOTHING ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,314)
  314 FORMAT('      WAS TO HAVE BEEN CARRIED OUT)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,315)MINN2
  315 FORMAT('      MUST BE ',I8,' OR LARGER;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,316)
  316 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,317)
  317 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,318)(IANS(I),I=1,IWIDTH)
  318 FORMAT(80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  390 CONTINUE
C
C               *****************************************
C               **  STEP 5--                           **
C               **  CHECK TO SEE THE TYPE CASE--       **
C               **    1) UNQUALIFIED (THAT IS, FULL);  **
C               **    2) SUBSET/EXCEPT; OR             **
C               **    3) FOR.                          **
C               *****************************************
C
      ISTEPN='5'
      IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICASEQ='FULL'
      ILOCQ=NUMARG+1
      IF(NUMARG.LT.1)GOTO490
      DO400J=1,NUMARG
      J1=J
      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ') GOTO410
      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ') GOTO410
      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ') GOTO420
  400 CONTINUE
      GOTO490
  410 CONTINUE
      ICASEQ='SUBS'
      ILOCQ=J1
      GOTO490
  420 CONTINUE
      ICASEQ='FOR'
      ILOCQ=J1
      GOTO490
  490 CONTINUE
      IF(IBUGA2.EQ.'OFF')GOTO495
      WRITE(ICOUT,491)NUMARG,ILOCQ
  491 FORMAT('NUMARG,ILOCQ = ',2I8)
      CALL DPWRST('XXX','BUG ')
  495 CONTINUE
C
C               *********************************************
C               **  STEP 5--                               **
C               **  TEMPORARILY FORM THE VARIABLE Y(.)     **
C               **  WHICH WILL HOLD THE RESPONSE VARIABLE. **
C               **  FORM THIS VARIABLE BY                  **
C               **  BRANCHING TO THE APPROPRIATE SUBCASE   **
C               **  (FULL, SUBSET, OR FOR).                **
C               *********************************************
C
      ISTEPN='5'
      IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ICASEQ.EQ.'FULL')GOTO510
      IF(ICASEQ.EQ.'SUBS')GOTO520
      IF(ICASEQ.EQ.'FOR')GOTO530
C
  510 CONTINUE
      DO515I=1,NLEFT
      ISUB(I)=1
  515 CONTINUE
      NQ=NLEFT
      GOTO550
C
  520 CONTINUE
      NIOLD=NLEFT
      CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
      NQ=NIOLD
      GOTO550
C
  530 CONTINUE
      NIOLD=NLEFT
      CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
      NQ=NFOR
      GOTO550
C
  550 CONTINUE
      IF(NQ.GE.MINN2)GOTO560
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,551)
  551 FORMAT('***** ERROR IN DPSMOO--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,552)
  552 FORMAT('      AFTER THE APPROPRIATE SUBSET HAS BEEN ',
     1'EXTRACTED,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,553)IHLEFT,IHLEF2
  553 FORMAT('      THE NUMBER OF OBSERVATIONS REMAINING',
     1'FROM VARIABLE ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,554)
  554 FORMAT('      (FOR WHICH SMOOTHING ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,555)
  555 FORMAT('      IS TO BE DONE)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,556)MINN2
  556 FORMAT('      MUST BE ',I8,' OR LARGER;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,557)
  557 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,558)
  558 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,559)(IANS(I),I=1,IWIDTH)
  559 FORMAT('      ',80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
  560 CONTINUE
      J=0
      IMAX=NLEFT
      IF(NQ.LT.NLEFT)IMAX=NQ
      DO570I=1,IMAX
      IF(ISUB(I).EQ.0)GOTO570
      J=J+1
C
      IJ=MAXN*(ICOLL-1)+I
      IF(ICOLL.LE.MAXCOL)Y(J)=V(IJ)
      IF(ICOLL.EQ.MAXCP1)Y(J)=PRED(I)
      IF(ICOLL.EQ.MAXCP2)Y(J)=RES(I)
      IF(ICOLL.EQ.MAXCP3)Y(J)=YPLOT(I)
      IF(ICOLL.EQ.MAXCP4)Y(J)=XPLOT(I)
      IF(ICOLL.EQ.MAXCP5)Y(J)=X2PLOT(I)
      IF(ICOLL.EQ.MAXCP6)Y(J)=TAGPLO(I)
C
  570 CONTINUE
      NS=J
C
C               ***********************************************************
C               **  STEP 6--                                             **
C               **  DETERMINE IF THE ANALYST                             **
C               **  HAS SPECIFIED THE WIDTH                              **
C               **  DESIRED FOR THE SMOOTHING FUNCTION.                  **
C               **  THIS IS DONE BY PRIOR USE OF THE                     **
C               **  FILTER WIDTH    COMMAND.                             **
C               **  IF FOUND, USE THE SPECIFIED VALUE                    **
C               **  (WHICH MUST BE BETWEEN 1 AND 1000, INCLUSIVE);       **
C               **  IF NOT FOUND, USE THE DEFAULT VALUE                  **
C               **  (USUALLY 11) WHICH WILL BE DEFINED                   **
C               **  IN THE SUBROUTINE DPSMO2.                            **
C               **  DETERMINE IF THE ANALYST                             **
C               **  HAS SPECIFIED THE DEGREE                             **
C               **  DESIRED FOR THE SMOOTHING FUNCTION.                  **
C               **  THIS IS DONE BY PRIOR USE OF THE                     **
C               **  POLYNOMIAL DEGREE    COMMAND.                        **
C               **  IF FOUND, USE THE SPECIFIED VALUE                    **
C               **  (WHICH MUST BE BETWEEN 1 AND 1000, INCLUSIVE);       **
C               **  IF NOT FOUND, USE THE DEFAULT VALUE                  **
C               **  (USUALLY 1) WHICH WILL BE DEFINED                    **
C               **  IN THE SUBROUTINE DPSMO2.                            **
C               ***********************************************************
C
      ISTEPN='6'
      IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(FILWID.EQ.CPUMIN)IFILWI=3
      IF(FILWID.NE.CPUMIN)IFILWI=FILWID+0.5
C
      IDEGRE=IDEG
      IF(IDEG.LT.0)IDEGRE=1
      IF(ICASSM.EQ.'0SM')IDEGRE=0
      IF(ICASSM.EQ.'1SM')IDEGRE=1
      IF(ICASSM.EQ.'2SM')IDEGRE=2
      IF(ICASSM.EQ.'3SM')IDEGRE=3
      IF(ICASSM.EQ.'4SM')IDEGRE=4
      IF(ICASSM.EQ.'5SM')IDEGRE=5
      IF(ICASSM.EQ.'6SM')IDEGRE=6
      IF(ICASSM.EQ.'7SM')IDEGRE=7
      IF(ICASSM.EQ.'8SM')IDEGRE=8
      IF(ICASSM.EQ.'9SM')IDEGRE=9
      IF(ICASSM.EQ.'10SM')IDEGRE=10
C
C               *******************************************
C               **  STEP 7--                             **
C               **  FOR THE ROBUST SMOOTHING CASE ONLY,  **
C               **  EXTRACT THE DEFINING STRING.         **
C               *******************************************
C
      ISTEPN='7'
      IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CCCCC IF(ICASSM.EQ.'ROSM')GOTO810
      GOTO990
C
  810 CONTINUE
      IMAX=IWIDTH-5
      IF(IMAX.LT.1)GOTO829
      DO820I=1,IMAX
      IP1=I+1
      IP2=I+2
      IP3=I+3
      IP4=I+4
      IP5=I+5
      IF(IANS(I).EQ.'R'.AND.IANS(IP1).EQ.'O'.AND.
     1IANS(IP2).EQ.'B'.AND.IANS(IP3).EQ.'U'.AND.
     1IANS(IP4).EQ.'S'.AND.IANS(IP5).EQ.'T')GOTO839
  820 CONTINUE
  829 CONTINUE
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,831)
  831 FORMAT('***** INTERNAL ERROR IN DPSMOO--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,832)
  832 FORMAT('      THE 6A1 STRING   ROBUST   NOT FOUND')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,833)
  833 FORMAT('      ON THE COMMAND LINE EVEN THOUGH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,834)
  834 FORMAT('      THE CASE WAS PREVIOUSLY IDENTIFIED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,835)
  835 FORMAT('      AS BEING THE ROBUST SMOOTHING CASE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,836)ICASSM,IFILWI
  836 FORMAT('ICASSM,IFILWI = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,837)
  837 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,838)(IANS(I),I=1,IWIDTH)
  838 FORMAT('      ',120A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  839 CONTINUE
      IEND1=IP5
C
  840 CONTINUE
      IEND1P=IEND1+1
      IF(IEND1P.GT.IWIDTH)GOTO859
      DO850I=IEND1P,IWIDTH
      I2=I
      IF(IANS(I).NE.' ')GOTO869
  850 CONTINUE
  859 CONTINUE
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,861)
  861 FORMAT('***** ERROR IN DPSMOO--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,862)
  862 FORMAT('      THE WORD     ROBUST   ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,863)
  863 FORMAT('      SHOULD HAVE BEEN (BUT WAS NOT)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,864)
  864 FORMAT('      FOLLOWED BY A CHARACTER STRING')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,865)
  865 FORMAT('      DEFINING THE DESIRED ROBUST SMOOTHER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,866)ICASSM,IFILWI
  866 FORMAT('ICASSM,IFILWI = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,867)
  867 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,868)(IANS(I),I=1,IWIDTH)
  868 FORMAT('      ',120A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  869 CONTINUE
      ISTAR2=I2
C
  870 CONTINUE
      ICOUNT=0
      IF(ISTAR2.GT.IWIDTH)GOTO889
      DO880I=ISTAR2,IWIDTH
      IF(IANS(I).EQ.' ')GOTO899
      ICOUNT=ICOUNT+1
      IF(ICOUNT.GT.MAXCRS)GOTO889
      IRSTRI(ICOUNT)=IANS(I)
  880 CONTINUE
      GOTO899
  889 CONTINUE
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,891)
  891 FORMAT('***** ERROR IN DPSMOO--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,892)
  892 FORMAT('      THE CHARACTER STRING WHICH DEFINES')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,893)
  893 FORMAT('      THE DESIRED ROBUST SMOOTHER')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,894)
  894 FORMAT('      HAS EXCEEDED THE MAXIMUM ALLOWABLE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,895)MAXCRS
  895 FORMAT('      LENGTH OF ',I8,' CHARACTERS.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,897)
  897 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,898)(IANS(I),I=1,IWIDTH)
  898 FORMAT('      ',120A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  899 CONTINUE
      NUMCRS=ICOUNT
C
  990 CONTINUE
C
C               ****************************************************************
C               **  STEP 8--
C               **  PREPARE FOR ENTRANCE INTO DPSMO2--
C               **  SET THE WEIGHT VECTOR TO UNITY THROUGHOUT.
C               ****************************************************************
C
      ISTEPN='8'
      IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO1110I=1,NS
      W(I)=1.0
 1110 CONTINUE
C
C               *********************************
C               **  STEP 9--                   **
C               **  FORM THE SMOOTHED VALUES.  **
C               *********************************
C
      ISTEPN='9'
      IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IBUGA2.EQ.'OFF')GOTO1290
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1211)
 1211 FORMAT('***** FROM DPSMOO, AS WE ARE ABOUT TO CALL DPSMO2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1212)NLEFT,MAXN,NS
 1212 FORMAT('NLEFT,MAXN,NS = ',3I8)
      CALL DPWRST('XXX','BUG ')
      DO1215I=1,NS
      WRITE(ICOUT,1216)I,Y(I),W(I)
 1216 FORMAT('I,Y(I),W(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 1215 CONTINUE
CCCCC IBUGA3='ABCD'
      WRITE(ICOUT,1231)IBUGA3
 1231 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
 1290 CONTINUE
C
      CALL DPSMO2(Y,W,NS,ICASSM,IFILWI,IDEGRE,IRSTRI,NUMCRS,MAXCRS,
     1TEMP,MAXN,
     1RESSD,RESDF,PRED2,RES2,
     1IBUGA3,IERROR)
C
C               ***************************************
C               **  STEP 10--                        **
C               **  UPDATE INTERNAL DATAPLOT TABLES  **
C               ***************************************
C
      ISTEPN='10'
      IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICOLPR=MAXCP1
      ICOLRE=MAXCP2
C
C     THE FOLLOWING CORRECTION WAS BASED ON
C     COMMENTS FROM DAVE EVANS     AUGUST 1987
CCCCC IREPU='ON'
      IREPU='OFF'
      REPSD=(-999.0)
      REPDF=(-999.0)
      ALFCDF=(-999.99)
C
      IRESU='ON'
C
      CALL UPDAPR(ICOLPR,ICOLRE,PRED2,RES2,PRED,RES,ISUB,NLEFT,
     1IREPU,REPSD,REPDF,IRESU,RESSD,RESDF,ALFCDF,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,ILOCN,IBUGA3,IERROR)
C
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 DPSMOO--')
      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)NS,ICASSM
 9014 FORMAT('NS,ICASSM = ',I8,2X,A4)
      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