SUBROUTINE DPDB80(ISTRIN,JMAX,IBUGS2,ISUBRO,IERROR)
C
C PURPOSE--DETERMINE THE LAST NON-BLANK
C CHARACTER IN THE CHARACTER*80
C VARIABLE ISTRIN .
C (THIS IS USEFUL FOR DEBLANKING A STRING.)
C
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-921-3651
C NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C OF THE NATIONAL BUREAU OF STANDARDS.
C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C MODIFIED, OR OTHERWISE USED IN A CONTEXT
C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--86/1
C ORIGINAL VERSION--DECEMBER 1985.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*80 ISTRIN
CHARACTER*4 IBUGS2
CHARACTER*4 ISUBRO
CHARACTER*4 IERROR
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
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='DPDB'
ISUBN2='80 '
C
IERROR='NO'
JMAX=0
C
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'DB80')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPDB80--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)IBUGS2,ISUBRO,IERROR
53 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)(ISTRIN(J:J),J=1,80)
54 FORMAT('(ISTRIN(J:J),J=1,80) = ',80A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,55)JMAX
55 FORMAT('JMAX = ',I8)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C **************************
C ** STEP 1-- **
C ** DETERMINE THE LAST **
C ** NON-BLANK CHARACTER **
C **************************
C
ISTEPN='1'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'DB80')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
DO1100I=1,80
IREV=80-I+1
IF(ISTRIN(IREV:IREV).EQ.' ')GOTO1100
GOTO1150
1100 CONTINUE
JMAX=0
GOTO1190
1150 CONTINUE
JMAX=IREV
GOTO1190
1190 CONTINUE
C
C
C ****************
C ** STEP 90-- **
C ** EXIT. **
C ****************
C
9000 CONTINUE
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'DB80')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPDB80--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)IBUGS2,ISUBRO,IERROR
9013 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)(ISTRIN(J:J),J=1,80)
9014 FORMAT('(ISTRIN(J:J),J=1,80) = ',80A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)JMAX
9015 FORMAT('JMAX = ',I8)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPDCNT(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
C
C PURPOSE--GENERATE A DEX CONTOUR PLOT--
C THE COMMAND HAS THE FOLLOWING FORMAT:
C DEX CONTOUR PLOT Z X1 X2 YCONT
C WHERE X1 AND X2 ARE RESTRICTED TO HAVING VALUES
C IN THE (-1,1) INTERVAL.
C EXAMPLE--DEX CONTOUR PLOT Z X1 X2
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/12
C ORIGINAL VERSION--DECEMBER 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 ISUBRO
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
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 IH
CHARACTER*4 IH1
CHARACTER*4 IH2
CHARACTER*4 IHWUSE
CHARACTER*4 MESSAG
C
CHARACTER*4 IREPU
CHARACTER*4 IRESU
C
CHARACTER*4 ICASEQ
C
CHARACTER*4 ISUBN0
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
INCLUDE 'DPCOPA.INC'
C
DIMENSION Z(MAXOBV)
DIMENSION X1(MAXOBV)
DIMENSION X2(MAXOBV)
DIMENSION YCONT(MAXOBV)
DIMENSION U1JUNK(MAXOBV)
DIMENSION ZTEMP(MAXOBV)
DIMENSION TEMP1(MAXOBV)
DIMENSION X1TEMP(MAXOBV)
DIMENSION X2TEMP(MAXOBV)
DIMENSION PRED2(MAXOBV)
DIMENSION RES2(MAXOBV)
C
INCLUDE 'DPCOZZ.INC'
EQUIVALENCE (GARBAG(IGARB1),Z(1))
EQUIVALENCE (GARBAG(IGARB2),X1(1))
EQUIVALENCE (GARBAG(IGARB3),X2(1))
EQUIVALENCE (GARBAG(IGARB4),YCONT(1))
EQUIVALENCE (GARBAG(IGARB5),TEMP1(1))
EQUIVALENCE (GARBAG(IGARB6),U1JUNK(1))
EQUIVALENCE (GARBAG(IGARB7),PRED2(1))
EQUIVALENCE (GARBAG(IGARB8),RES2(1))
EQUIVALENCE (GARBAG(IGARB9),X1TEMP(1))
EQUIVALENCE (GARBAG(IGAR10),X2TEMP(1))
EQUIVALENCE (GARBAG(JGAR11),ZTEMP(1))
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCOST.INC'
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
IERROR='NO'
IFOUND='NO'
C
ISUBN1='DPDC'
ISUBN2='NT '
C
ICASPL='DCON'
C
MAXCP1=MAXCOL+1
MAXCP2=MAXCOL+2
MAXCP3=MAXCOL+3
MAXCP4=MAXCOL+4
MAXCP5=MAXCOL+5
MAXCP6=MAXCOL+6
C
MAXV2=6
MINN2=1
C
ICOLH=0
C
C ****************************************
C ** TREAT THE DEX CONTOUR PLOT CASE **
C ****************************************
C
IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'DCNT')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPDCNT--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBUGG2,IBUGG3,IBUGQ,ISUBRO
52 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)ICASPL,IAND1,IAND2
53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)MAXN
54 FORMAT('MAXN = ',I8)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C ***************************
C ** STEP 1-- **
C ** EXTRACT THE COMMAND **
C ***************************
C
ISTEPN='11'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DCNT')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CONT'.AND.
1 IHARG(2).EQ.'PLOT')GOTO112
GOTO119
C
112 CONTINUE
ILASTC=2
CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
GOTO119
C
119 CONTINUE
IFOUND='YES'
GOTO190
C
190 CONTINUE
C
C *******************************************************
C ** STEP 2-- **
C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. **
C ** AT LEAST 1 REQUIRED **
C *******************************************************
C
ISTEPN='2'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DCNT')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
MINNA=1
MAXNA=100
CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
C
C *****************************************
C ** STEP 2.1-- **
C ** CHECK TO SEE THE TYPE CASE-- **
C ** 1) UNQUALIFIED (THAT IS, FULL); **
C ** 2) SUBSET/EXCEPT; OR **
C ** 3) FOR. **
C *****************************************
C
ISTEPN='2.1'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DCNT')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ICASEQ='FULL'
ILOCQ=NUMARG+1
IF(NUMARG.LT.1)GOTO2190
DO2100J=1,NUMARG
J1=J
IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO2110
IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO2110
IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO2120
2100 CONTINUE
GOTO2190
2110 CONTINUE
ICASEQ='SUBS'
ILOCQ=J1
GOTO2190
2120 CONTINUE
ICASEQ='FOR'
ILOCQ=J1
GOTO2190
2190 CONTINUE
IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'DCNT')GOTO2195
WRITE(ICOUT,2191)NUMARG,ILOCQ
2191 FORMAT('NUMARG,ILOCQ = ',2I8)
CALL DPWRST('XXX','BUG ')
2195 CONTINUE
C
C **************************************************
C ** STEP 2.2-- **
C ** DETERMINE THE NUMBER OF VARIABLES **
C ** TO BE INCLUDED AS PLOT COMPONENTS **
C **************************************************
C
ISTEPN='2.2'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DCNT')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
NUMV2=ILOCQ-1
IF(NUMV2.EQ.4)GOTO2290
C
WRITE(ICOUT,2211)
2211 FORMAT('***** ERROR IN DPDCNT--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2212)
2212 FORMAT(' ILLEGAL SYNTAX--THE NUMBER OF VARIABLES ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2213)
2213 FORMAT(' TO BE INCLUDED AS ARGUMENTS ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2214)
2214 FORMAT(' IN A DEX CONTOUR PLOT COMMAND')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2215)
2215 FORMAT(' MUST BE EXACTLY 4;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2216)NUMV2
2216 FORMAT(' SUCH WAS NOT THE CASE HERE. NUMV2 = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2217)
2217 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,2218)(IANS(I),I=1,MIN(80,IWIDTH))
2218 FORMAT(80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
2290 CONTINUE
C
C ***************************************
C ** STEP 2.3 **
C ** CHECK THE VALIDITY OF EACH **
C ** OF THE VARIABLES. **
C ***************************************
C
ISTEPN='2.3'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DCNT')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
DO2300I=1,NUMV2
IH1=IHARG(I)
IH2=IHARG2(I)
IHWUSE='V'
MESSAG='YES'
CALL CHECKN(IH1,IH2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
IF(I.EQ.1)THEN
ICOL1=IVALUE(ILOCV)
N1=IN(ILOCV)
IHRI11=IH1
IHRI12=IH2
ENDIF
IF(I.EQ.2)THEN
ICOL2=IVALUE(ILOCV)
N2=IN(ILOCV)
IHRI21=IH1
IHRI22=IH2
ENDIF
IF(I.EQ.3)THEN
ICOL3=IVALUE(ILOCV)
N3=IN(ILOCV)
IHRI31=IH1
IHRI32=IH2
ENDIF
IF(I.EQ.4)THEN
ICOL4=IVALUE(ILOCV)
N4=IN(ILOCV)
IHRI41=IH1
IHRI42=IH2
ENDIF
2300 CONTINUE
C
C **************************************************
C ** STEP 2.4-- **
C ** CHECK THAT FIRST THREE ARGUMENTS **
C ** HAVE THE SAME NUMBER OF OBSERVATIONS. **
C **************************************************
C
ISTEPN='2.4'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DCNT')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(N2.NE.N1.OR.N3.NE.N1.OR.N1.NE.N2)THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2411)
2411 FORMAT('***** ERROR IN DPDCNT--FOR A DEX CONTOUR PLOT,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2413)
2413 FORMAT(' THE FIRST THREE VARIABLES MUST HAVE THE SAME')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2415)
2415 FORMAT(' NUMER OF ELEMENTS; SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2421)N1
2421 FORMAT('THE FIRST VARIABLE HAD ',I8,' ELEMENTS;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2422)N2
2422 FORMAT('THE SECOND VARIABLE HAD ',I8,' ELEMENTS;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2423)N3
2423 FORMAT('THE THIRD VARIABLE HAD ',I8,' ELEMENTS;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2427)
2427 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,2428)(IANS(I),I=1,MIN(80,IWIDTH))
2428 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
ENDIF
C
C ******************************************************
C ** STEP 2.5-- **
C ** CHECK THAT VARIABLES HAVE AT LEAST 1 ELEMENT **
C ******************************************************
C
4100 CONTINUE
ISTEPN='2.5'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DCNT')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(N1.GE.1.AND.N4.GE.1)GOTO2590
C
2510 CONTINUE
WRITE(ICOUT,2511)
2511 FORMAT('***** ERROR IN DPDCNT--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2513)
2513 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE VARIABLES')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2514)
2514 FORMAT(' MUST BE AT LEAST 1;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2515)
2515 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2516)IHRI11,IHRI12,N1
2516 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2517)IHRI41,IHRI42,N4
2517 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2520)
2520 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,2521)(IANS(I),I=1,MIN(100,IWIDTH))
2521 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
2590 CONTINUE
C
C *************************************************
C ** STEP 3-- **
C ** BRANCH TO THE APPROPRIATE SUBCASE; **
C ** (BASED ON THE QUALIFIER) **
C ** THEN FOR EACH OF THE RESPONSE VARIABLES **
C ** EXTRACT THE DATA SUBSET **
C *************************************************
C
ISTEPN='3'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DCNT')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(ICASEQ.EQ.'FULL')GOTO3010
IF(ICASEQ.EQ.'SUBS')GOTO3020
IF(ICASEQ.EQ.'FOR')GOTO3030
C
3010 CONTINUE
DO3015I=1,N1
ISUB(I)=1
3015 CONTINUE
NQ=N1
GOTO3050
C
3020 CONTINUE
NIOLD=N1
CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
NQ=NIOLD
GOTO3050
C
3030 CONTINUE
NIOLD=N1
CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
NQ=NFOR
GOTO3050
C
3050 CONTINUE
J=0
IMAX=N1
IF(NQ.LT.N1)IMAX=NQ
DO3060I=1,IMAX
IF(ISUB(I).EQ.0)GOTO3060
J=J+1
C
IJ=MAXN*(ICOL1-1)+I
IF(ICOL1.LE.MAXCOL)Z(J)=V(IJ)
IF(ICOL1.EQ.MAXCP1)Z(J)=PRED(I)
IF(ICOL1.EQ.MAXCP2)Z(J)=RES(I)
IF(ICOL1.EQ.MAXCP3)Z(J)=YPLOT(I)
IF(ICOL1.EQ.MAXCP4)Z(J)=XPLOT(I)
IF(ICOL1.EQ.MAXCP5)Z(J)=X2PLOT(I)
IF(ICOL1.EQ.MAXCP6)Z(J)=TAGPLO(I)
C
IJ=MAXN*(ICOL2-1)+I
IF(ICOL2.LE.MAXCOL)X1(J)=V(IJ)
IF(ICOL2.EQ.MAXCP1)X1(J)=PRED(I)
IF(ICOL2.EQ.MAXCP2)X1(J)=RES(I)
IF(ICOL2.EQ.MAXCP3)X1(J)=YPLOT(I)
IF(ICOL2.EQ.MAXCP4)X1(J)=XPLOT(I)
IF(ICOL2.EQ.MAXCP5)X1(J)=X2PLOT(I)
IF(ICOL2.EQ.MAXCP6)X1(J)=TAGPLO(I)
C
IJ=MAXN*(ICOL3-1)+I
IF(ICOL3.LE.MAXCOL)X2(J)=V(IJ)
IF(ICOL3.EQ.MAXCP1)X2(J)=PRED(I)
IF(ICOL3.EQ.MAXCP3)X2(J)=RES(I)
IF(ICOL3.EQ.MAXCP3)X2(J)=YPLOT(I)
IF(ICOL3.EQ.MAXCP4)X2(J)=XPLOT(I)
IF(ICOL3.EQ.MAXCP5)X2(J)=X2PLOT(I)
IF(ICOL3.EQ.MAXCP6)X2(J)=TAGPLO(I)
C
3060 CONTINUE
NZ=J
C
J=0
IMAX=N4
DO3070I=1,IMAX
J=J+1
C
IJ=MAXN*(ICOL4-1)+I
IF(ICOL3.LE.MAXCOL)YCONT(J)=V(IJ)
IF(ICOL3.EQ.MAXCP1)YCONT(J)=PRED(I)
IF(ICOL3.EQ.MAXCP3)YCONT(J)=RES(I)
IF(ICOL3.EQ.MAXCP3)YCONT(J)=YPLOT(I)
IF(ICOL3.EQ.MAXCP4)YCONT(J)=XPLOT(I)
IF(ICOL3.EQ.MAXCP5)YCONT(J)=X2PLOT(I)
IF(ICOL3.EQ.MAXCP6)YCONT(J)=TAGPLO(I)
C
3070 CONTINUE
C
C *******************************************************
C ** STEP 8-- **
C ** FORM THE VERTICAL AND HORIZONTAL AXIS **
C ** VALUES Y(.) AND X(.) FOR THE PLOT. **
C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). **
C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). **
C *******************************************************
C
ISTEPN='5'
IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'DCNT')GOTO5099
CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
WRITE(ICOUT,5001)NLOCAL,ICASPL
5001 FORMAT('NLOCAL,ICASPL=',I5,1X,A4)
CALL DPWRST('XXX','BUG ')
5099 CONTINUE
C
CALL DPDCN2(Z,X1,X2,YCONT,NZ,N4,ICASPL,NUMV2,
1PRED2,RES2,ZTEMP,U1JUNK,TEMP1,X1TEMP,X2TEMP,
1Y,X,D,X3D,
1B1,B2,B12,STATVA,NCDF,CUTL95,CUTU95,
1IDCPDI,IDCPFI,
1N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
NPLOTP=N2
C
C ***************************************
C ** STEP 9-- **
C ** UPDATE INTERNAL DATAPLOT TABLES **
C ***************************************
C
7000 CONTINUE
C
ISTEPN='9'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DCNT')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ICOLPR=MAXCP1
ICOLRE=MAXCP2
IREPU='OFF'
IRESU='OFF'
CALL UPDAPR(ICOLPR,ICOLRE,PRED2,RES2,PRED,RES,ISUB,NZ,
1IREPU,REPSD,REPDF,IRESU,RESSD,RESDF,ALFCDF,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1IANS,IWIDTH,ILOCN,IBUGG3,IERROR)
C
ISUBN0='DCNT'
IBUGG2='OFF'
IBUGG3='OFF'
C
IH='B1 '
IH2=' '
VALUE0=B1
CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
1IANS,IWIDTH,IBUGG2,IERROR)
C
IH='B2 '
IH2=' '
VALUE0=B2
CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
1IANS,IWIDTH,IBUGG2,IERROR)
C
IH='B12 '
IH2=' '
VALUE0=B12
CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
1IANS,IWIDTH,IBUGG2,IERROR)
C
IH='STAT'
IH2='VAL '
VALUE0=STATVA
CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
1IANS,IWIDTH,IBUGG2,IERROR)
C
IH='STAT'
IH2='NU '
VALUE0=REAL(NCDF)
CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
1IANS,IWIDTH,IBUGG2,IERROR)
C
IH='CUTL'
IH2='OW95'
VALUE0=CUTL95
CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
1IANS,IWIDTH,IBUGG2,IERROR)
C
IH='CUTU'
IH2='PP95'
VALUE0=CUTU95
CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
1IANS,IWIDTH,IBUGG2,IERROR)
C
C
C *****************
C ** STEP 9-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'DCNT')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPDCNT--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGG2,IBUGG3,IBUGQ,ISUBRO
9012 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)IFOUND,IERROR
9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)NPLOTV,NPLOTP,NLOCAL,ICASPL,IAND1,IAND2
9014 FORMAT('NPLOTV,NPLOTP,NLOCAL,ICASPL,IAND1,IAND2 = ',
1I8,I8,I8,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9041)NLOCAL
9041 FORMAT('NLOCAL = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9051)NPLOTP
9051 FORMAT('NPLOTP = ',I8)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPDCN2(Z,X1,X2,YCONT,NZ,NCONT,ICASPL,NUMV2,
1PRED,RES,ZTEMP,U1JUNK,TEMP1,X1TEMP,X2TEMP,
1Y,X,D,X3D,
1B1,B2,B12,TESTST,NCDF,CUTOF1,CUTOF2,
1IDCPDI,IDCPFI,
1N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
C
C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
C THAT WILL DEFINE
C A DEX CONTOUR 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/12
C ORIGINAL VERSION--DECEMBER 1999.
C UPDATED --OCTOBER 2006. CALL LIST TO TPPF
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 ICASPL
CHARACTER*4 IDCPDI
CHARACTER*4 IDCPFI
CHARACTER*4 IBUGG3
CHARACTER*4 ISUBRO
CHARACTER*4 IERROR
C
CHARACTER*4 IWRITE
CHARACTER*4 ICONC
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
DIMENSION Z(*)
DIMENSION X1(*)
DIMENSION X2(*)
DIMENSION YCONT(*)
C
DIMENSION PRED(*)
DIMENSION RES(*)
DIMENSION ZTEMP(*)
DIMENSION U1JUNK(*)
DIMENSION TEMP1(*)
DIMENSION X1TEMP(*)
DIMENSION X2TEMP(*)
C
DIMENSION Y(*)
DIMENSION X(*)
DIMENSION D(*)
DIMENSION X3D(*)
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='DPDC'
ISUBN2='N2 '
IWRITE='OFF'
C
IERROR='NO'
C
C ********************************************
C ** STEP 1-- **
C ** CHECK THE INPUT ARGUMENTS FOR ERRORS **
C ********************************************
C
IF(NZ.GE.1)GOTO39
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,31)
31 FORMAT('***** ERROR IN DPDCN2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,32)
32 FORMAT(' THE NUMBER OF OBSERVATIONS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,33)
33 FORMAT(' MUST BE AT LEAST 1;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,34)NZ
34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
39 CONTINUE
C
IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'DCN2')GOTO90
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,71)
71 FORMAT('***** AT THE BEGINNING OF DPDCN2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,72)ICASPL,NZ,N2,NPLOTV,NUMV2
72 FORMAT('ICASPL,NZ,N2,NPLOTV,NUMV2 = ',A4,2X,4I8)
CALL DPWRST('XXX','BUG ')
IF(NZ.LE.0)GOTO83
81 CONTINUE
83 CONTINUE
90 CONTINUE
C
C ****************************************
C ** STEP 4-- **
C ** PLOT INNER SAMPLING SQUARE **
C ** AND A CENTER POINT (IF IT EXISTS) **
C ****************************************
C
ITAG=0
N2=0
C
ITAG=ITAG+1
ATOL=0.00001
J=0
DO510I=1,NZ
X1VAL=ABS(X1(I)-(-1.0))
X2VAL=ABS(X2(I)-(-1.0))
IF(ABS(X1VAL).LE.ATOL.AND.ABS(X2VAL).LE.ATOL)THEN
J=J+1
X1TEMP(J)=X1(I)
X2TEMP(J)=X2(I)
ZTEMP(J)=Z(I)
ENDIF
510 CONTINUE
NPTS=J
IF(NPTS.GT.0)THEN
CALL MEAN(ZTEMP,NPTS,IWRITE,YMM,IBUGG3,IERROR)
N2=N2+1
X(N2)=-1.1
Y(N2)=-1.2
D(N2)=REAL(ITAG)
X3D(N2)=YMM
ENDIF
C
J=0
DO520I=1,NZ
X1VAL=ABS(X1(I)-(1.0))
X2VAL=ABS(X2(I)-(-1.0))
IF(ABS(X1VAL).LE.ATOL.AND.ABS(X2VAL).LE.ATOL)THEN
J=J+1
X1TEMP(J)=X1(I)
X2TEMP(J)=X2(I)
ZTEMP(J)=Z(I)
ENDIF
520 CONTINUE
NPTS=J
IF(NPTS.GT.0)THEN
CALL MEAN(ZTEMP,NPTS,IWRITE,YPM,IBUGG3,IERROR)
N2=N2+1
X(N2)=1.1
Y(N2)=-1.2
D(N2)=REAL(ITAG)
X3D(N2)=YPM
ENDIF
C
J=0
DO530I=1,NZ
X1VAL=ABS(X1(I)-(-1.0))
X2VAL=ABS(X2(I)-(1.0))
IF(ABS(X1VAL).LE.ATOL.AND.ABS(X2VAL).LE.ATOL)THEN
J=J+1
X1TEMP(J)=X1(I)
X2TEMP(J)=X2(I)
ZTEMP(J)=Z(I)
ENDIF
530 CONTINUE
NPTS=J
IF(NPTS.GT.0)THEN
CALL MEAN(ZTEMP,NPTS,IWRITE,YMP,IBUGG3,IERROR)
N2=N2+1
X(N2)=-1.1
Y(N2)=1.1
D(N2)=REAL(ITAG)
X3D(N2)=YMP
ENDIF
C
J=0
DO540I=1,NZ
X1VAL=ABS(X1(I)-(1.0))
X2VAL=ABS(X2(I)-(1.0))
IF(ABS(X1VAL).LE.ATOL.AND.ABS(X2VAL).LE.ATOL)THEN
J=J+1
X1TEMP(J)=X1(I)
X2TEMP(J)=X2(I)
ZTEMP(J)=Z(I)
ENDIF
540 CONTINUE
NPTS=J
IF(NPTS.GT.0)THEN
CALL MEAN(ZTEMP,NPTS,IWRITE,YPP,IBUGG3,IERROR)
N2=N2+1
X(N2)=1.1
Y(N2)=1.1
D(N2)=REAL(ITAG)
X3D(N2)=YPP
ENDIF
C
ATOL=0.00001
J=0
DO400I=1,NZ
X1VAL=ABS(X1(I))
X2VAL=ABS(X2(I))
IF(ABS(X1VAL).LE.ATOL.AND.ABS(X2VAL).LE.ATOL)THEN
J=J+1
X1TEMP(J)=X1(I)
X2TEMP(J)=X2(I)
ZTEMP(J)=Z(I)
ENDIF
400 CONTINUE
NCENT=J
IF(NCENT.GT.0)THEN
CALL MEAN(ZTEMP,NCENT,IWRITE,YCP,IBUGG3,IERROR)
CALL SD(ZTEMP,NCENT,IWRITE,YSD,IBUGG3,IERROR)
N2=N2+1
X(N2)=0.1
Y(N2)=0.1
D(N2)=REAL(ITAG)
X3D(N2)=YCP
C
N2=N2+1
ITAG=ITAG+1
X(N2)=0.0
Y(N2)=0.0
D(N2)=REAL(ITAG)
ENDIF
C
ITAG=ITAG+1
N2=N2+1
X(N2)=-1.0
Y(N2)=-1.0
D(N2)=REAL(ITAG)
X3D(N2)=0.0
N2=N2+1
X(N2)=1.0
Y(N2)=-1.0
D(N2)=REAL(ITAG)
X3D(N2)=0.0
N2=N2+1
X(N2)=1.0
Y(N2)=1.0
D(N2)=REAL(ITAG)
X3D(N2)=0.0
N2=N2+1
X(N2)=-1.0
Y(N2)=1.0
D(N2)=REAL(ITAG)
X3D(N2)=0.0
N2=N2+1
X(N2)=-1.0
Y(N2)=-1.0
D(N2)=REAL(ITAG)
X3D(N2)=0.0
C
C
C ****************************************
C ** STEP 1-- **
C ** EXTRACT POINTS WHERE X1, X2 ARE **
C ** EQUAL TO +/- 1. **
C ** COMPUTE B1, B2, B12 **
C ****************************************
C
ATOL=0.00001
J=0
DO100I=1,NZ
X1VAL=ABS(X1(I))
X2VAL=ABS(X2(I))
IF(ABS(X1VAL-1.0).LE.ATOL.AND.ABS(X2VAL-1.0).LE.ATOL)THEN
J=J+1
X1TEMP(J)=X1(I)
X2TEMP(J)=X2(I)
ZTEMP(J)=Z(I)
ENDIF
100 CONTINUE
IF(J.LE.0)THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,111)
111 FORMAT('***** ERROR IN DPDCN2--')
WRITE(ICOUT,113)
113 FORMAT(' NONE OF THE X1, X2 PAIRS EQUAL TO +/- 1')
IERROR='YES'
GOTO9000
ENDIF
NEDGE=J
C
CALL MEAN(ZTEMP,NEDGE,IWRITE,AMU,IBUGG3,IERROR)
AMEDGE=AMU
DO120I=1,NEDGE
TEMP1(I)=Z(I)*X1TEMP(I)
120 CONTINUE
CALL MEAN(TEMP1,NEDGE,IWRITE,AMU2,IBUGG3,IERROR)
B1=2.0*AMU2
C
DO130I=1,NEDGE
TEMP1(I)=Z(I)*X2TEMP(I)
130 CONTINUE
CALL MEAN(TEMP1,NEDGE,IWRITE,AMU2,IBUGG3,IERROR)
B2=2.0*AMU2
C
DO140I=1,NEDGE
TEMP1(I)=Z(I)*X1TEMP(I)*X2TEMP(I)
140 CONTINUE
CALL MEAN(TEMP1,NEDGE,IWRITE,AMU2,IBUGG3,IERROR)
B12=2.0*AMU2
C
C ****************************************
C ** STEP 2-- **
C ** COMPUTE RESIDUALS, PREDICTED **
C ** VALUES EVERYWHERE **
C ****************************************
C
DO210I=1,NZ
PRED(I)=AMU+0.5*(B1*X1(I)+B2*X2(I)+B12*X1(I)*X2(I))
RES(I)=Z(I)-PRED(I)
210 CONTINUE
C
C ****************************************
C ** STEP 3-- **
C ** GENERATE THE CONTOUR VALUES **
C ****************************************
C
AVAL=-2.0
AINC=0.05
DO310I=1,81
U1JUNK(I)=AVAL
AVAL=AVAL+AINC
310 CONTINUE
C
CALL SORT(YCONT,NCONT,YCONT)
IF(IDCPDI.EQ.'MINI')THEN
IFRST=1
ILAST=NCONT
INC=1
ELSE
IFRST=NCONT
ILAST=1
INC=-1
ENDIF
C
DO330ICONT=IFRST,ILAST,INC
Y0=YCONT(ICONT)
ATEMP=2.0*(Y0-AMU)
ITAG=ITAG+1
DO320I=1,81
ANUM=ATEMP-B1*U1JUNK(I)
ADEN=B2+B12*U1JUNK(I)
AVAL=ANUM/ADEN
IF(AVAL.GE.-2.0 .AND.AVAL.LE.2.0)THEN
N2=N2+1
Y(N2)=ANUM/ADEN
X(N2)=U1JUNK(I)
D(N2)=REAL(ITAG)
X3D(N2)=0.0
ENDIF
320 CONTINUE
330 CONTINUE
C
C ****************************************
C ** STEP 6-- **
C ** GENERATE THE T-TEST FOR CURVATURE **
C ****************************************
C
IF(NCENT.GE.2.AND.NEDGE.GE.1)THEN
STATNM=0.0
STATDN=0.0
TESTST=0.0
NCDF=0
STATNM=AMEDGE-YCP
AJUNK1=1.0/REAL(NEDGE)
AJUNK2=1.0/REAL(NCENT)
STATDN=YSD*SQRT(AJUNK1+AJUNK2)
IF(STATDN.EQ.0.0)GOTO699
TESTST=STATNM/STATDN
NCDF=NCENT-1
AP=0.975
CALL TPPF(AP,REAL(NCDF),CUTOF2)
CUTOF1=-CUTOF2
ICONC='NO'
IF(TESTST.LT.CUTOF1 .OR. TESTST.GT.CUTOF2)ICONC='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,611)
611 FORMAT('----- DEX CONTOUR PLOT TEST FOR CURVATURE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,613)NCENT
613 FORMAT(' NUMBER OF CENTER POINTS = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,615)YCP
615 FORMAT(' MEAN OF CENTER POINTS = ',G15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,617)YSD
617 FORMAT(' STANDARD DEVIATION OF CENTER POINTS = ',G15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,623)NEDGE
623 FORMAT(' NUMBER OF EDGE POINTS = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,625)AMEDGE
625 FORMAT(' MEAN OF EDGE POINTS = ',G15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,631)TESTST
631 FORMAT(' CURVATURE CHECK: T TEST STATISTIC = ',G15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,633)NCDF
633 FORMAT(' T DEGREES OF FREEDOM = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,635)CUTOF1
635 FORMAT(' LOWER T CRITICAL VALUE = ',G15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,637)CUTOF2
637 FORMAT(' UPPER T CRITICAL VALUE = ',G15.7)
CALL DPWRST('XXX','BUG ')
IF(ICONC.EQ.'NO')THEN
WRITE(ICOUT,641)
641 FORMAT(' CONCLUSION: THERE IS NO CURVATURE')
CALL DPWRST('XXX','BUG ')
ELSE
WRITE(ICOUT,643)
643 FORMAT(' CONCLUSION: THERE IS CURVATURE')
CALL DPWRST('XXX','BUG ')
ENDIF
699 CONTINUE
ELSE
NDF=0
TESTST=0.0
CUTOF1=0.0
CUTOF2=0.0
ENDIF
8000 CONTINUE
NPLOTV=3
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'DCN2')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPDCN2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)ICASPL,NZ,N2,IERROR
9012 FORMAT('ICASPL,NZ,N2,IERROR = ',A4,2I8,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)N2
9013 FORMAT('N2 = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NZ.LE.0)GOTO9023
DO9021I=1,NZ
WRITE(ICOUT,9022)I,Z(I),X1(I),X2(I)
9022 FORMAT('I,Z(I),X1(I),X2(I) = ',I8,4E12.5)
CALL DPWRST('XXX','BUG ')
9021 CONTINUE
9023 CONTINUE
WRITE(ICOUT,9031)N2,NPLOTV
9031 FORMAT('N2,NPLOTV = ',2I8)
CALL DPWRST('XXX','BUG ')
DO9035I=1,N2
WRITE(ICOUT,9036)I,Y(I),X(I),D(I)
9036 FORMAT('I,Y(I),X(I),D(I) = ',I8,2E15.7,F9.2)
CALL DPWRST('XXX','BUG ')
9035 CONTINUE
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPDECL(IHARG,IHARG2,IARGT,IARG,NUMARG,
1IDEFDC,
1NUMDEV,MAXDEV,
1IDMANU,IDMODE,IDMOD2,IDMOD3,
1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
1IBUGO2,IFOUND,IERROR)
C
C PURPOSE--DEFINE THE COLOR STATUS (ON/OFF) FOR AN OUTPUT DEVICE.
C THE COLOR (ON/OFF) FOR DEVICE I
C WILL BE PLACED IN THE I-TH ELEMENT OF THE CHARACTER
C VECTOR IDCOLO(.).
C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR)
C --IHARG2 (A CHARACTER VECTOR)
C --IARGT (A CHARACTER VECTOR)
C --IARG (A CHARACTER VECTOR)
C --NUMARG
C --IDEFDC
C --MAXDEV
C OUTPUT ARGUMENTS--IDCONT (A CHARACTER VECTOR
C WHOSE I-TH ELEMENT CONTAINS THE
C COLOR (ON/OFF) FOR DEVICE I.
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--OCTOBER 1980.
C UPDATED --MAY 1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IHARG
CHARACTER*4 IHARG2
CHARACTER*4 IARGT
C
CHARACTER*4 IDEFDC
C
CHARACTER*4 IDMANU
CHARACTER*4 IDMODE
CHARACTER*4 IDMOD2
CHARACTER*4 IDMOD3
C
CHARACTER*4 IDPOWE
CHARACTER*4 IDCONT
CHARACTER*4 IDCOLO
C
CHARACTER*4 IBUGO2
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 IHOLD
C
C---------------------------------------------------------------------
C
DIMENSION IHARG(*)
DIMENSION IHARG2(*)
DIMENSION IARGT(*)
DIMENSION IARG(*)
C
DIMENSION IDMANU(*)
DIMENSION IDMODE(*)
DIMENSION IDMOD2(*)
DIMENSION IDMOD3(*)
C
DIMENSION IDPOWE(*)
DIMENSION IDCONT(*)
DIMENSION IDCOLO(*)
DIMENSION IDNVPP(*)
DIMENSION IDNHPP(*)
DIMENSION IDUNIT(*)
C
C---------------------------------------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
IFOUND='NO'
IERROR='NO'
C
IF(NUMARG.LE.0)GOTO9000
IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO1110
IF(NUMARG.GE.2.AND.IHARG(2).EQ.'COLO')GOTO1140
GOTO9000
C
1110 CONTINUE
IF(NUMARG.LE.1)GOTO1120
IF(IHARG(2).EQ.'ON')GOTO1120
IF(IHARG(2).EQ.'OFF')GOTO1125
IF(IHARG(2).EQ.'AUTO')GOTO1120
IF(IHARG(2).EQ.'DEFA')GOTO1127
GOTO1120
C
1120 CONTINUE
IHOLD='ON'
GOTO1130
C
1125 CONTINUE
IHOLD='OFF'
GOTO1130
C
1127 CONTINUE
IHOLD=IDEFDC
GOTO1130
C
1130 CONTINUE
IFOUND='YES'
DO1135I=1,NUMDEV
IDCOLO(I)=IHOLD
1135 CONTINUE
C
IF(IFEEDB.EQ.'OFF')GOTO1139
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1136)IHOLD
1136 FORMAT('THE COLOR FOR ALL DEVICES HAS JUST BEEN SET TO ',
1A4)
CALL DPWRST('XXX','BUG ')
1139 CONTINUE
GOTO9000
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 DPDECL--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1142)
1142 FORMAT(' IN THE DEVICE ... COLOR COMMAND,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1143)
1143 FORMAT(' THE DEVICE IS IDENTIFIED BY A NUMBER, AS IN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1144)
1144 FORMAT(' DEVICE 3 COLOR ON')
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1150 CONTINUE
I=IARG(1)
IF(1.LE.I.AND.I.LE.MAXDEV)GOTO1160
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1151)
1151 FORMAT('***** ERROR IN DPDECL--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1152)
1152 FORMAT(' IN THE DEVICE ... COLOR COMMAND,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1153)
1153 FORMAT(' THE NUMBER OF DEVICES MUST BE ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1154)MAXDEV
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'DEVICE.')
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1160 CONTINUE
IF(NUMARG.LE.2)GOTO1170
IF(IHARG(3).EQ.'ON')GOTO1170
IF(IHARG(3).EQ.'OFF')GOTO1175
IF(IHARG(3).EQ.'AUTO')GOTO1170
IF(IHARG(3).EQ.'DEFA')GOTO1177
GOTO1170
C
1170 CONTINUE
IHOLD='ON'
GOTO1180
C
1175 CONTINUE
IHOLD='OFF'
GOTO1180
C
1177 CONTINUE
IHOLD=IDEFDC
GOTO1180
C
1180 CONTINUE
IFOUND='YES'
IDCOLO(I)=IHOLD
C
IF(IFEEDB.EQ.'OFF')GOTO1199
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1181)I
1181 FORMAT(' DEVICE --',I4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1182)IDUNIT(I)
1182 FORMAT(' I/O UNIT --',I4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1183)IDMANU(I)
1183 FORMAT(' MANUFACTURER --',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1184)IDMODE(I),IDMOD2(I),IDMOD3(I)
1184 FORMAT(' MODEL --',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1185)IDPOWE(I)
1185 FORMAT(' POWER --',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1186)IDCONT(I)
1186 FORMAT(' CONTINUITY --',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1187)IDCOLO(I)
1187 FORMAT(' COLOR --',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1188)IDNHPP(I)
1188 FORMAT(' HORIZONTAL PIXELS--',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1189)IDNVPP(I)
1189 FORMAT(' VERTICAL PIXELS--',I8)
CALL DPWRST('XXX','BUG ')
1199 CONTINUE
GOTO9000
C
9000 CONTINUE
RETURN
END
SUBROUTINE DPDECN(IHARG,IHARG2,IARGT,IARG,NUMARG,
1IDEFCN,
1NUMDEV,MAXDEV,
1IDMANU,IDMODE,IDMOD2,IDMOD3,
1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
1IBUGO2,IFOUND,IERROR)
C
C PURPOSE--DEFINE THE CONTINUITY STATUS (ON/OFF) FOR AN OUTPUT DEVICE.
C A DEVICE IS CONSIDERED CONTINUOUS IF IT IS CAPABLE
C OF DRAWING A CONTINUOUS LINE SEGMENT.
C FOR EXAMPLE, THE TEKTRONIX 4014 IS CONTINUOUS;
C THE TEXAS INSTRUMENT SILENT 700 IS NOT CONTINUOUS.
C THE CONTINUITY (ON/OFF) FOR DEVICE I
C WILL BE PLACED IN THE I-TH ELEMENT OF THE CHARACTER
C VECTOR IDCONT(.).
C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR)
C --IHARG2 (A CHARACTER VECTOR)
C --IARGT (A CHARACTER VECTOR)
C --IARG (A CHARACTER VECTOR)
C --NUMARG
C --IDEFCN
C --MAXDEV
C OUTPUT ARGUMENTS--IDCONT (A CHARACTER VECTOR
C WHOSE I-TH ELEMENT CONTAINS THE
C CONTINUITY (ON/OFF) FOR DEVICE I.
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--OCTOBER 1980.
C UPDATED --MAY 1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IHARG
CHARACTER*4 IHARG2
CHARACTER*4 IARGT
C
CHARACTER*4 IDEFCN
C
CHARACTER*4 IDMANU
CHARACTER*4 IDMODE
CHARACTER*4 IDMOD2
CHARACTER*4 IDMOD3
C
CHARACTER*4 IDPOWE
CHARACTER*4 IDCONT
CHARACTER*4 IDCOLO
C
CHARACTER*4 IBUGO2
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 IHOLD
C
C---------------------------------------------------------------------
C
DIMENSION IHARG(*)
DIMENSION IHARG2(*)
DIMENSION IARGT(*)
DIMENSION IARG(*)
C
DIMENSION IDMANU(*)
DIMENSION IDMODE(*)
DIMENSION IDMOD2(*)
DIMENSION IDMOD3(*)
C
DIMENSION IDPOWE(*)
DIMENSION IDCONT(*)
DIMENSION IDCOLO(*)
DIMENSION IDNVPP(*)
DIMENSION IDNHPP(*)
DIMENSION IDUNIT(*)
C
C---------------------------------------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
IFOUND='NO'
IERROR='NO'
C
IF(NUMARG.LE.0)GOTO9000
IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CONT')GOTO1110
IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CONT')GOTO1140
GOTO9000
C
1110 CONTINUE
IF(NUMARG.LE.1)GOTO1120
IF(IHARG(2).EQ.'ON')GOTO1120
IF(IHARG(2).EQ.'OFF')GOTO1125
IF(IHARG(2).EQ.'AUTO')GOTO1120
IF(IHARG(2).EQ.'DEFA')GOTO1127
GOTO1120
C
1120 CONTINUE
IHOLD='ON'
GOTO1130
C
1125 CONTINUE
IHOLD='OFF'
GOTO1130
C
1127 CONTINUE
IHOLD=IDEFCN
GOTO1130
C
1130 CONTINUE
IFOUND='YES'
DO1135I=1,NUMDEV
IDCONT(I)=IHOLD
1135 CONTINUE
C
IF(IFEEDB.EQ.'OFF')GOTO1139
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1136)IHOLD
1136 FORMAT('THE CONTINUITY FOR ALL DEVICES HAS JUST BEEN SET TO ',
1A4)
CALL DPWRST('XXX','BUG ')
1139 CONTINUE
GOTO9000
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 DPDECN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1142)
1142 FORMAT(' IN THE DEVICE ... CONTINUITY COMMAND,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1143)
1143 FORMAT(' THE DEVICE IS IDENTIFIED BY A NUMBER, AS IN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1144)
1144 FORMAT(' DEVICE 3 CONTINUITY ON')
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1150 CONTINUE
I=IARG(1)
IF(1.LE.I.AND.I.LE.MAXDEV)GOTO1160
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1151)
1151 FORMAT('***** ERROR IN DPDECN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1152)
1152 FORMAT(' IN THE DEVICE ... CONTINUITY COMMAND,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1153)
1153 FORMAT(' THE NUMBER OF DEVICES MUST BE ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1154)MAXDEV
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'DEVICE.')
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1160 CONTINUE
IF(NUMARG.LE.2)GOTO1170
IF(IHARG(3).EQ.'ON')GOTO1170
IF(IHARG(3).EQ.'OFF')GOTO1175
IF(IHARG(3).EQ.'AUTO')GOTO1170
IF(IHARG(3).EQ.'DEFA')GOTO1177
GOTO1170
C
1170 CONTINUE
IHOLD='ON'
GOTO1180
C
1175 CONTINUE
IHOLD='OFF'
GOTO1180
C
1177 CONTINUE
IHOLD=IDEFCN
GOTO1180
C
1180 CONTINUE
IFOUND='YES'
IDCONT(I)=IHOLD
C
IF(IFEEDB.EQ.'OFF')GOTO1199
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1181)I
1181 FORMAT(' DEVICE --',I4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1182)IDUNIT(I)
1182 FORMAT(' I/O UNIT --',I4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1183)IDMANU(I)
1183 FORMAT(' MANUFACTURER --',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1184)IDMODE(I),IDMOD2(I),IDMOD3(I)
1184 FORMAT(' MODEL --',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1185)IDPOWE(I)
1185 FORMAT(' POWER --',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1186)IDCONT(I)
1186 FORMAT(' CONTINUITY --',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1187)IDCOLO(I)
1187 FORMAT(' COLOR --',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1188)IDNHPP(I)
1188 FORMAT(' HORIZONTAL PIXELS--',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1189)IDNVPP(I)
1189 FORMAT(' VERTICAL PIXELS--',I8)
CALL DPWRST('XXX','BUG ')
1199 CONTINUE
GOTO9000
C
9000 CONTINUE
RETURN
END
SUBROUTINE DPDECO(IANS,IWIDTH,IHARG,NUMARG,
1IDEFCM,IWIDDC,IDEFC,IBUGS2,IFOUND,IERROR)
C
C PURPOSE--EXTRACT THE STRING TO BE USED AS A DEFAULT COMMAND;
C SAVE THIS STRING FOR USE IN MAIN
C WHEN NO MATCH FORUND FOR A GIVEN COMMAND.
C NOTE--A CHECK IS CONTAINED HEREIN WHICH RESTRICTS
C THE MAXIMUM NUMBER OF CHARACTERS IN THE DEFAULT
C COMMAND TO BE 40 CHARACTERS.
C INPUT ARGUMENTS--IANS (A HOLLERITH VECTOR)
C --IWIDTH
C --IHARG (A HOLLERITH VECTOR)
C --NUMARG
C OUTPUT ARGUMENTS--IDEFCM
C --IWIDDC
C --IDEFC
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--JUNE 1981.
C UPDATED --SEPTEMBER 1980.
C UPDATED --MAY 1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IANS
CHARACTER*4 IHARG
CHARACTER*4 IDEFCM
CHARACTER*4 IDEFC
CHARACTER*4 IBUGS2
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
DIMENSION IANS(*)
DIMENSION IHARG(*)
C
DIMENSION IDEFC(*)
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(IBUGS2.NE.'ON')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPDECO--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)IDEFCM,IWIDDC
53 FORMAT('IDEFCM,IWIDDC = ',A4,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)(IDEFC(I),I=1,IWIDDC)
54 FORMAT('IDEFC(.)--',120A1)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C *******************************************
C ** STEP 1-- **
C ** DETERMINE THE SECOND WORD (COMMAND) **
C ** IN THE ASSUMED COMMAND STRING **
C ** (DEFAULT COMMNAD) **
C *******************************************
C
DO100I=1,IWIDTH
I2=I
IP1=I+1
IP2=I+2
IP3=I+3
IP4=I+4
IP5=I+5
IP6=I+6
IF(IANS(I).EQ.'C'.AND.IANS(IP1).EQ.'O'
1.AND.IANS(IP2).EQ.'M'.AND.IANS(IP3).EQ.'M'
1.AND.IANS(IP4).EQ.'A'.AND.IANS(IP5).EQ.'N'
1.AND.IANS(IP6).EQ.'D')
1GOTO190
C
100 CONTINUE
WRITE(ICOUT,101)
101 FORMAT('***** ERROR IN DPDECO--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,102)
102 FORMAT(' THE WORD COMMAND NOT FOUND.')
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO800
190 CONTINUE
C
C **********************************************************
C ** STEP 2-- **
C ** DEFINE THE START POSITION (ISTART) FOR THE STRING. **
C ** DEFINE THE STOP POSITION (ISTOP) FOR THE STRING. **
C ********************************************************
C
IFOUND='YES'
ISTART=I2+8
ISTOP=0
IF(ISTART.GT.IWIDTH)GOTO329
DO320I=ISTART,IWIDTH
IREV=IWIDTH-I+ISTART
IF(IANS(IREV).NE.' ')GOTO325
320 CONTINUE
GOTO329
325 CONTINUE
ISTOP=IREV
329 CONTINUE
C
C *****************************************
C ** STEP 4-- **
C ** COPY OVER THE STRING OF INTEREST. **
C *****************************************
C
IF(NUMARG.LE.1)GOTO359
IF(NUMARG.LE.2.AND.IHARG(NUMARG).EQ.'ON')GOTO359
IF(NUMARG.LE.2.AND.IHARG(NUMARG).EQ.'OFF')GOTO359
IF(NUMARG.LE.2.AND.IHARG(NUMARG).EQ.'AUTO')GOTO359
IF(NUMARG.LE.2.AND.IHARG(NUMARG).EQ.'DEFA')GOTO359
C
IF(ISTART.GT.ISTOP)GOTO359
IF(ISTOP.EQ.0)GOTO359
J=0
DO350I=ISTART,ISTOP
J=J+1
IDEFC(J)=IANS(I)
IF(J.GE.40)GOTO355
350 CONTINUE
355 CONTINUE
IDEFCM='ON'
IWIDDC=J
GOTO800
359 CONTINUE
C
C ************************************
C ** STEP 5-- **
C ** TREAT THE EMPTY-STRING CASE. **
C ************************************
C
IDEFCM='OFF'
IWIDDC=0
DO410I=1,40
IDEFC(I)=' '
410 CONTINUE
GOTO800
C
C ***************************
C ** STEP 6-- **
C ** PRINT OUT A MESSAGE **
C ***************************
C
800 CONTINUE
IF(IFEEDB.EQ.'OFF')GOTO819
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,811)
811 FORMAT('THE DEFAULT COMMAND HAS JUST BEEN SET TO')
CALL DPWRST('XXX','BUG ')
IF(IWIDDC.EQ.0)WRITE(ICOUT,999)
IF(IWIDDC.EQ.0)CALL DPWRST('XXX','BUG ')
IF(IWIDDC.GE.1)WRITE(ICOUT,812)(IDEFC(I),I=1,IWIDDC)
812 FORMAT(10X,120A1)
IF(IWIDDC.GE.1)CALL DPWRST('XXX','BUG ')
819 CONTINUE
GOTO9000
C
C ****************
C ** STEP 7-- **
C ** EXIT **
C ****************
C
9000 CONTINUE
IF(IBUGS2.NE.'ON')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPDECO--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IDEFCM,IWIDDC
9012 FORMAT('IDEFCM,IWIDDC(1) = ',A4,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)(IDEFC(I),I=1,IWIDDC)
9013 FORMAT('IDEFC(.) --',120A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)IFOUND,IERROR
9014 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPDEDE(IHARG,IARG,NUMARG,IDEDED,
1IDEXDE,IFOUND,IERROR)
C
C PURPOSE--DEFINE THE DESIGN OF EXPERIMENT PLOT DEPTH
C INTO THE INTERACTION TERMS
C 1 = MAIN EFFECTS ONLY
C 2 = UP TO 2-TERM INTERACTIONS
C 3 = UP TO 3-TERM INTERACTIONS
C ETC.
C INPUT ARGUMENTS--IHARG (A HOLLARITH VECTOR)
C --IARG (AN INTEGER VECTOR)
C --NUMARG
C --IDEDED
C OUTPUT ARGUMENTS--IDEXDE
C --IFOUND ('YES' OR 'NO' )
C --IERROR ('YES' OR 'NO' )
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-975-2855
C NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C OF THE NATIONAL BUREAU OF STANDARDS.
C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C MODIFIED, OR OTHERWISE USED IN A CONTEXT
C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--89/5
C ORIGINAL VERSION--MAY 1989.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IHARG
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
DIMENSION IHARG(*)
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.LE.0)GOTO1900
C
1100 CONTINUE
IF(NUMARG.EQ.1)GOTO1150
IF(IHARG(2).EQ.'ON')GOTO1150
IF(IHARG(2).EQ.'OFF')GOTO1150
IF(IHARG(2).EQ.'AUTO')GOTO1150
IF(IHARG(2).EQ.'DEFA')GOTO1150
GOTO1160
C
1150 CONTINUE
IHOLD=IDEDED
GOTO1180
C
1160 CONTINUE
IHOLD=IARG(NUMARG)
GOTO1180
C
1180 CONTINUE
IFOUND='YES'
IDEXDE=IHOLD
C
IF(IFEEDB.EQ.'OFF')GOTO1189
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1181)
1181 FORMAT('THE DESIGN OF EXPERIMENT DEPTH')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1182)
1182 FORMAT('(INTO THE INTERACTION TERMS)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1183)IHOLD
1183 FORMAT('HAS JUST BEEN SET TO ',I8)
CALL DPWRST('XXX','BUG ')
1189 CONTINUE
GOTO1900
C
1199 CONTINUE
C
1900 CONTINUE
RETURN
END
SUBROUTINE DPDEDL(Y,X,PX,NP,NUMSET,
1ICASPL,ICAS3D,
1ISPISW,ASPIBA,MAXSPI,
1IBARSW,ABARBA,ABARWI,MAXBAR,XDELMN,
1GX1MIN,GX1MAX,GY1MIN,GY1MAX,
1GX2MIN,GX2MAX,GY2MIN,GY2MAX,
1IX1MIN,IX1MAX,IY1MIN,IY1MAX,
1IX2MIN,IX2MAX,IY2MIN,IY2MAX,
1DX1MIN,DX1MAX,DY1MIN,DY1MAX,
1DX2MIN,DX2MAX,DY2MIN,DY2MAX,
1IHORSW)
C
C PURPOSE--COMPUTE ACTUAL DATA LIMITS
C FOR POTENTIAL USE IN SETTING
C LIMITS FOR ALL 4 FRAME LINES
C NOTE--IN THE EVENT THAT THE FRAME LIMITS HAVE BEEN FIXED
C (AS OPPOSED TO FLOATING),
C THEN COMPUTE THE ACTUAL DATA LIMITS ONLY FOR THOSE
C DATA POINTS RESIDING WITHIN THE FIXED LIMITS.
C
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-921-3651
C NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C OF THE NATIONAL BUREAU OF STANDARDS.
C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C MODIFIED, OR OTHERWISE USED IN A CONTEXT
C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--83.6
C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983.
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
CHARACTER*4 ICASPL
CHARACTER*4 ICAS3D
C
CHARACTER*4 IX1MIN
CHARACTER*4 IX1MAX
CHARACTER*4 IY1MIN
CHARACTER*4 IY1MAX
C
CHARACTER*4 IX2MIN
CHARACTER*4 IX2MAX
CHARACTER*4 IY2MIN
CHARACTER*4 IY2MAX
C
CHARACTER*4 ISPISW
CHARACTER*4 IBARSW
C
CHARACTER*4 IBAR
CHARACTER*4 ISAVE
C
CHARACTER*4 IHORSW
C
DIMENSION Y(*)
DIMENSION X(*)
DIMENSION PX(*)
C
DIMENSION ISPISW(*)
DIMENSION ASPIBA(*)
DIMENSION IBARSW(*)
DIMENSION ABARBA(*)
DIMENSION ABARWI(*)
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCOGR.INC'
INCLUDE 'DPCOBE.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
DEL=-999.0
AWIDTH=-999.0
BAMIN=-999.0
BAMAX=-999.0
C
IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEDL')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPDEDL--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)NP,NUMSET
52 FORMAT('NP,NUMSET = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)MAXSPI,MAXBAR
53 FORMAT('MAXSPI,MAXBAR = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)ICASPL,ICAS3D,XDELMN
54 FORMAT('ICASPL,ICAS3D,XDELMN = ',A4,2X,A4,2X,E15.7)
CALL DPWRST('XXX','BUG ')
IF(NP.LE.3)GOTO59
DO55I=1,3
WRITE(ICOUT,56)I,X(I),Y(I)
56 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
CALL DPWRST('XXX','BUG ')
55 CONTINUE
NPM2=NP-2
DO57I=NPM2,NP
WRITE(ICOUT,58)I,X(I),Y(I)
58 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
CALL DPWRST('XXX','BUG ')
57 CONTINUE
59 CONTINUE
WRITE(ICOUT,61)GX1MIN,GY1MIN,GX1MAX,GY1MAX
61 FORMAT('GX1MIN,GY1MIN,GX1MAX,GY1MAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,62)GX2MIN,GY2MIN,GX2MAX,GY2MAX
62 FORMAT('GX2MIN,GY2MIN,GX2MAX,GY2MAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,63)IX1MIN,IY1MIN,IX1MAX,IY1MAX
63 FORMAT('IX1MIN,IY1MIN,IX1MAX,IY1MAX = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,64)IX2MIN,IY2MIN,IX2MAX,IY2MAX
64 FORMAT('IX2MIN,IY2MIN,IX2MAX,IY2MAX = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,65)DX1MIN,DY1MIN,DX1MAX,DY1MAX
65 FORMAT('DX1MIN,DY1MIN,DX1MAX,DY1MAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,66)DX2MIN,DY2MIN,DX2MAX,DY2MAX
66 FORMAT('DX2MIN,DY2MIN,DX2MAX,DY2MAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
IMAX=NUMSET
IF(IMAX.GT.MAXSPI)IMAX=MAXSPI
DO71I=1,IMAX
WRITE(ICOUT,72)I,ISPISW(I),ASPIBA(I)
72 FORMAT('I,ISPISW(I),ASPIBA(I) = ',I8,2X,A4,2X,E15.7)
CALL DPWRST('XXX','BUG ')
71 CONTINUE
IMAX=NUMSET
IF(IMAX.GT.MAXBAR)IMAX=MAXBAR
DO73I=1,IMAX
WRITE(ICOUT,74)I,IBARSW(I),ABARBA(I),ABARWI(I)
74 FORMAT('I,IBARSW(I),ABARBA(I),ABARWI(I)= ',I8,2X,A4,2X,2E15.7)
CALL DPWRST('XXX','BUG ')
73 CONTINUE
WRITE(ICOUT,79)IHORSW
79 FORMAT('IHORSW=',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,89)IBUGG4,ISUBG4,IERRG4
89 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C ***********************************************************
C ** STEP 1-- **
C ** IF ANY OF THE BAR SWITCHES ARE ON, **
C ** DETERMINE THE MINIMUM NON-ZERO DIFFERENCE **
C ** (XDELMN) BETWEEN X-VARIABLE VALUES. **
C ** THIS VALUE (XDELMN) IS USED TO DEFINE THE BAR WIDTH **
C ** IN BAR PLOTS WHEN THE WIDTH IS ALLOWED TO "FLOAT" **
C ** WITH THE DATA. **
C ** THIS VALUE IS USED IN THE DPDRBA SUBROUTINE. **
C ***********************************************************
C
ISAVE=IBARSW(1)
IBAR='OFF'
IF(ICASPL.EQ.'HIST')IBARSW(1)='ON'
IF(ICASPL.EQ.'CUMH')IBARSW(1)='ON'
IF(ICASPL.EQ.'BARP')IBARSW(1)='ON'
IF(ICASPL.EQ.'ROOT')IBARSW(1)='ON'
IF(ICASPL.EQ.'CUMR')IBARSW(1)='ON'
IF(ICASPL.EQ.'BIHI')IBARSW(1)='ON'
XDELMN=CPUMAX
IF(NUMSET.LE.0)GOTO1090
IMAX=NUMSET
IF(IMAX.GT.MAXBAR)IMAX=MAXBAR
DO1010I=1,IMAX
IF(IBARSW(I).EQ.'ON')GOTO1019
1010 CONTINUE
GOTO1090
1019 CONTINUE
IBAR='ON'
C
IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEDL')GOTO1012
WRITE(ICOUT,1011)IHORSW,NP,IBAR
1011 FORMAT('IHORSW,NP,IBAR=',A4,2X,I4,2X,A4)
CALL DPWRST('XXX','BUG ')
1012 CONTINUE
C
C SEPTEMBER, 1987: IF HORIZONTAL SWITCH IS ON, REVERSE
IF(IHORSW.EQ.'ON')GOTO1092
C END CHANGE
CALL DPSORT(X,NP,PX)
IF(NP.LE.1)GOTO1090
DO1020I=2,NP
IM1=I-1
DEL=PX(I)-PX(IM1)
IF(DEL.LE.0.0)GOTO1020
IF(DEL.LT.XDELMN)XDELMN=DEL
1020 CONTINUE
GOTO1090
C SEPTEMBER, 1987 CHANGE
1092 CONTINUE
IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEDL')GOTO1032
WRITE(ICOUT,1031)IHORSW,NP,IBAR
1031 FORMAT('HORIZONTAL CASE,IHORSW,NP,IBAR=',A4,2X,I4,2X,A4)
CALL DPWRST('XXX','BUG ')
1032 CONTINUE
C
CALL DPSORT(Y,NP,PX)
IF(NP.LE.1)GOTO1090
DO1095I=2,NP
IM1=I-1
DEL=PX(I)-PX(IM1)
IF(DEL.LE.0.0)GOTO1095
IF(DEL.LT.XDELMN)XDELMN=DEL
1095 CONTINUE
1090 CONTINUE
C
IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEDL')GOTO1022
WRITE(ICOUT,1021)IHORSW,NP,IBAR
1021 FORMAT('IHORSW,NP,IBAR=',A4,2X,I4,2X,A4)
CALL DPWRST('XXX','BUG ')
1022 CONTINUE
C END CHANGE
C
C **********************************************
C ** STEP 2-- **
C ** DETERMINE ACTUAL LIMITS FOR X VARIABLE **
C **********************************************
C
TXMIN=CPUMAX
TXMAX=CPUMIN
C
XMIN=CPUMAX
XMAX=CPUMIN
IF(NP.LE.0)GOTO1119
DO1110I=1,NP
IF(IX1MIN.EQ.'FIXE'.AND.X(I).LT.GX1MIN)GOTO1110
IF(IX1MAX.EQ.'FIXE'.AND.X(I).GT.GX1MAX)GOTO1110
CCCCC JULY 1996. FOLLOWING CODE EXCLUDES VALUES THAT ARE
CCCCC "OUT OF RANGE" ON THE Y-AXIS. SPECIAL CASE WHERE UPPER AND
CCCCC LOWER LIMIT ARE EQUAL, INCLUDE ALL VALUES.
IF(GY1MIN.NE.GY1MAX)THEN
IF(IY1MIN.EQ.'FIXE'.AND.Y(I).LT.GY1MIN)GOTO1110
IF(IY1MAX.EQ.'FIXE'.AND.Y(I).GT.GY1MAX)GOTO1110
ENDIF
IF(X(I).LT.XMIN)XMIN=X(I)
IF(X(I).GT.XMAX)XMAX=X(I)
1110 CONTINUE
TXMIN=XMIN
TXMAX=XMAX
1119 CONTINUE
C
BWMIN=CPUMAX
BWMAX=CPUMIN
IF(NUMSET.LE.0)GOTO1139
IMAX=NUMSET
IF(IMAX.GT.MAXBAR)IMAX=MAXBAR
DO1130I=1,IMAX
IF(IBARSW(I).EQ.'OFF')GOTO1130
AWIDTH=ABARWI(I)
IF(ABARWI(I).EQ.CPUMIN)AWIDTH=XDELMN
IF(AWIDTH.GT.BWMAX)BWMAX=AWIDTH
1130 CONTINUE
BAMIN=XMIN
BAMAX=XMAX
IF(XMIN.NE.CPUMAX.AND.BWMAX.NE.CPUMIN)BAMIN=XMIN-BWMAX/2.0
CCCCC IF(XMAX.NE.CPUMIN.AND.BWMIN.NE.CPUMAX)BAMAX=XMAX+BWMAX/2.0
IF(XMAX.NE.CPUMIN.AND.BWMAX.NE.CPUMIN)BAMAX=XMAX+BWMAX/2.0
IF(BAMIN.LT.TXMIN)TXMIN=BAMIN
IF(BAMAX.GT.TXMAX)TXMAX=BAMAX
1139 CONTINUE
C
DX1MIN=TXMIN
DX2MIN=TXMIN
DX1MAX=TXMAX
DX2MAX=TXMAX
IF(DX1MIN.EQ.CPUMAX)DX1MIN=X(1)
IF(DX2MIN.EQ.CPUMAX)DX2MIN=X(1)
IF(DX1MAX.EQ.CPUMIN)DX1MAX=X(1)
IF(DX2MAX.EQ.CPUMIN)DX2MAX=X(1)
C
C **********************************************
C ** STEP 3-- **
C ** DETERMINE ACTUAL LIMITS FOR Y VARIABLE **
C **********************************************
C
TYMIN=CPUMAX
TYMAX=CPUMIN
C
YMIN=CPUMAX
YMAX=CPUMIN
IF(NP.LE.0)GOTO1119
DO1210I=1,NP
CCCCC JULY 1996. FOLLOWING CODE EXCLUDES VALUES THAT ARE
CCCCC "OUT OF RANGE" ON THE Y-AXIS. SPECIAL CASE WHERE UPPER AND
CCCCC LOWER LIMIT ARE EQUAL, INCLUDE ALL VALUES.
IF(GX1MIN.NE.GX1MAX)THEN
IF(IX1MIN.EQ.'FIXE'.AND.X(I).LT.GX1MIN)GOTO1210
IF(IX1MAX.EQ.'FIXE'.AND.X(I).GT.GX1MAX)GOTO1210
ENDIF
IF(IY1MIN.EQ.'FIXE'.AND.Y(I).LT.GY1MIN)GOTO1210
IF(IY1MAX.EQ.'FIXE'.AND.Y(I).GT.GY1MAX)GOTO1210
IF(Y(I).LT.YMIN)YMIN=Y(I)
IF(Y(I).GT.YMAX)YMAX=Y(I)
1210 CONTINUE
TYMIN=YMIN
TYMAX=YMAX
1219 CONTINUE
C
SBMIN=CPUMAX
SBMAX=CPUMIN
IF(NUMSET.LE.0)GOTO1229
IMAX=NUMSET
IF(IMAX.GT.MAXSPI)IMAX=MAXSPI
DO1220I=1,IMAX
IF(ISPISW(I).EQ.'OFF')GOTO1220
IF(ASPIBA(I).LT.SBMIN)SBMIN=ASPIBA(I)
IF(ASPIBA(I).GT.SBMAX)SBMAX=ASPIBA(I)
1220 CONTINUE
IF(SBMIN.LT.TYMIN)TYMIN=SBMIN
IF(SBMAX.GT.TYMAX)TYMAX=SBMAX
1229 CONTINUE
C
BBMIN=CPUMAX
BBMAX=CPUMIN
IF(NUMSET.LE.0)GOTO1239
IMAX=NUMSET
IF(IMAX.GT.MAXBAR)IMAX=MAXBAR
DO1230I=1,IMAX
IF(IBARSW(I).EQ.'OFF')GOTO1230
IF(ABARBA(I).LT.BBMIN)BBMIN=ABARBA(I)
IF(ABARBA(I).GT.BBMAX)BBMAX=ABARBA(I)
1230 CONTINUE
IF(BBMIN.LT.TYMIN)TYMIN=BBMIN
IF(BBMAX.GT.TYMAX)TYMAX=BBMAX
1239 CONTINUE
C
DY1MIN=TYMIN
DY2MIN=TYMIN
DY1MAX=TYMAX
DY2MAX=TYMAX
IF(DY1MIN.EQ.CPUMAX)DY1MIN=Y(1)
IF(DY2MIN.EQ.CPUMAX)DY2MIN=Y(1)
IF(DY1MAX.EQ.CPUMIN)DY1MAX=Y(1)
IF(DY2MAX.EQ.CPUMIN)DY2MAX=Y(1)
C
8000 CONTINUE
IBARSW(1)=ISAVE
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEDL')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPDEDL--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)NP,NUMSET
9012 FORMAT('NP,NUMSET = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)MAXSPI,MAXBAR
9013 FORMAT('MAXSPI,MAXBAR = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)ICASPL,ICAS3D,XDELMN,AWIDTH
9014 FORMAT('ICASPL,ICAS3D,XDELMN,AWIDTH = ',A4,2X,A4,2X,2E15.7)
CALL DPWRST('XXX','BUG ')
IF(NP.LE.3)GOTO9019
DO9015I=1,3
WRITE(ICOUT,9016)I,X(I),Y(I)
9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
CALL DPWRST('XXX','BUG ')
9015 CONTINUE
NPM2=NP-2
DO9017I=NPM2,NP
WRITE(ICOUT,9018)I,X(I),Y(I)
9018 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
CALL DPWRST('XXX','BUG ')
9017 CONTINUE
9019 CONTINUE
WRITE(ICOUT,9021)GX1MIN,GY1MIN,GX1MAX,GY1MAX
9021 FORMAT('GX1MIN,GY1MIN,GX1MAX,GY1MAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9022)GX2MIN,GY2MIN,GX2MAX,GY2MAX
9022 FORMAT('GX2MIN,GY2MIN,GX2MAX,GY2MAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9023)IX1MIN,IY1MIN,IX1MAX,IY1MAX
9023 FORMAT('IX1MIN,IY1MIN,IX1MAX,IY1MAX = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9024)IX2MIN,IY2MIN,IX2MAX,IY2MAX
9024 FORMAT('IX2MIN,IY2MIN,IX2MAX,IY2MAX = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9025)DX1MIN,DY1MIN,DX1MAX,DY1MAX
9025 FORMAT('DX1MIN,DY1MIN,DX1MAX,DY1MAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9026)DX2MIN,DY2MIN,DX2MAX,DY2MAX
9026 FORMAT('DX2MIN,DY2MIN,DX2MAX,DY2MAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
IMAX=NUMSET
IF(IMAX.GT.MAXSPI)IMAX=MAXSPI
DO9031I=1,IMAX
WRITE(ICOUT,9032)I,ISPISW(I),ASPIBA(I)
9032 FORMAT('I,ISPISW(I),ASPIBA(I) = ',I8,2X,A4,2X,E15.7)
CALL DPWRST('XXX','BUG ')
9031 CONTINUE
IMAX=NUMSET
IF(IMAX.GT.MAXBAR)IMAX=MAXBAR
DO9033I=1,IMAX
WRITE(ICOUT,9034)I,IBARSW(I),ABARBA(I),ABARWI(I)
9034 FORMAT('I,IBARSW(I),ABARBA(I),ABARWI(I)= ',I8,2X,A4,2X,2E15.7)
CALL DPWRST('XXX','BUG ')
9033 CONTINUE
WRITE(ICOUT,9041)XMIN,XMAX,BWMIN,BWMAX
9041 FORMAT('XMIN,XMAX,BWMIN,BWMAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9042)BAMIN,BAMAX,TXMIN,TXMAX
9042 FORMAT('BAMIN,BAMAX,TXMIN,TXMAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9043)YMIN,YMAX,SBMIN,SBMAX
9043 FORMAT('YMIN,YMAX,SBMIN,SBMAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9044)BBMIN,BBMAX,TYMIN,TYMAX
9044 FORMAT('BBMIN,BBMAX,TYMIN,TYMAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9051)IBAR,DEL,XDELMN,ISAVE
9051 FORMAT('IBAR,DEL,XDELMN,ISAVE = ',A4,2E15.7,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9059)IBUGG4,ISUBG4,IERRG4
9059 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPDEFI(IHARG,IHARG2,IHARLC,IHARL2,NUMARG,
1ICOM3,ICOM4,ICOM5,NUMCOM,NCOM5,
1ICPREP,NCPREP,ICPOST,NCPOST,
1ICPREH,NCPREH,ICPOSH,NCPOSH,
1IBUGS2,ISUBRO,IFOUND,IERROR)
C
C PURPOSE--CREATE USER-DEFINED COMMANDS.
C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR)
C --IHARG2 (A CHARACTER VECTOR)
C --IHARLC (A CHARACTER VECTOR)
C --IHARL2 (A CHARACTER VECTOR)
C --NUMARG
C OUTPUT ARGUMENTS--ICOM3
C ICOM4
C ICOM5
C NUMCOM
C NCOM5
C IFOUND
C IERROR
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/6
C ORIGINAL VERSION--FEBRUARY 1986.
C UPDATED --AUGUST 1986.
C UPDATED --SEPTEMBER 1987. (PREHELP AND POSTHELP)
C
C-----NON-COMMON VARIABLES----------------------------------------
C
CHARACTER*4 IHARG
CHARACTER*4 IHARG2
CHARACTER*4 IHARLC
CHARACTER*4 IHARL2
C
CHARACTER*4 ICOM3
CHARACTER*4 ICOM4
CHARACTER*40 ICOM5
C
CHARACTER*40 ICPREP
CHARACTER*40 ICPOST
CHARACTER*40 ICPREH
CHARACTER*40 ICPOSH
C
CHARACTER*40 ICOM5J
CHARACTER*4 IC4
CHARACTER*1 IC1
CHARACTER*4 IC4LC
CHARACTER*1 IC1LC
CHARACTER*40 ISTRIN
C
CHARACTER*4 IBUGS2
CHARACTER*4 ISUBRO
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CCCCC CHARACTER*4 ISTEPN
C
DIMENSION IHARG(*)
DIMENSION IHARG2(*)
DIMENSION IHARLC(*)
DIMENSION IHARL2(*)
DIMENSION ICOM3(*)
DIMENSION ICOM4(*)
DIMENSION ICOM5(*)
DIMENSION NCOM5(*)
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCONP.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='DPDE'
ISUBN2='FI '
C
IFOUND='YES'
IERROR='NO'
C
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'DEFI')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('AT THE BEGINNING OF DPDEFI--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)IBUGS2,ISUBRO
53 FORMAT('IBUGS2,ISUBRO = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,55)NUMARG
55 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NUMARG.LE.0)GOTO59
DO56I=1,NUMARG
WRITE(ICOUT,57)I,IHARG(I),IHARLC(I)
57 FORMAT('I,IHARG(I),IHARLC(I) = ',I8,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
56 CONTINUE
59 CONTINUE
WRITE(ICOUT,61)NUMCOM
61 FORMAT('NUMCOM = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NUMCOM.LE.0)GOTO65
DO62I=1,NUMCOM
CCCCC WRITE(ICOUT,63)I,ICOM3(I),ICOM4(I),NCOM5(I),ICOM5(I)
CCC63 FORMAT('I,ICOM3(I),ICOM4(I),NCOM5(I),ICOM5(I) = ',
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC1I8,2X,A4,2X,A4,I8,A40)
62 CONTINUE
65 CONTINUE
WRITE(ICOUT,66)IFOUND,IERROR
66 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,71)NCPREP
71 FORMAT('NCPREP = ',A4)
CALL DPWRST('XXX','BUG ')
IF(NCPREP.LE.0)GOTO74
DO72I=1,NCPREP
WRITE(ICOUT,73)I,ICPREP(I:I)
73 FORMAT('I,ICPREP(I:I) = ',I8,2X,A1,4X)
CALL DPWRST('XXX','BUG ')
72 CONTINUE
74 CONTINUE
WRITE(ICOUT,76)NCPOST
76 FORMAT('NCPOST = ',A4)
CALL DPWRST('XXX','BUG ')
IF(NCPOST.LE.0)GOTO79
DO77I=1,NCPOST
WRITE(ICOUT,78)I,ICPOST(I:I)
78 FORMAT('I,ICPOST(I:I) = ',I8,2X,A1,4X)
CALL DPWRST('XXX','BUG ')
77 CONTINUE
79 CONTINUE
WRITE(ICOUT,81)NCPREH
81 FORMAT('NCPREH = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NCPREH.LE.0)GOTO84
DO82I=1,NCPREH
WRITE(ICOUT,83)I,ICPREH(I:I)
83 FORMAT('I,ICPREH(I:I) = ',I8,2X,A1,4X)
CALL DPWRST('XXX','BUG ')
82 CONTINUE
84 CONTINUE
WRITE(ICOUT,86)NCPOSH
86 FORMAT('NCPOSH = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NCPOSH.LE.0)GOTO89
DO87I=1,NCPOSH
WRITE(ICOUT,88)I,ICPOSH(I:I)
88 FORMAT('I,ICPOSH(I:I) = ',I8,2X,A1,4X)
CALL DPWRST('XXX','BUG ')
87 CONTINUE
89 CONTINUE
90 CONTINUE
C
C ***************************************************
C ** STEP 11-- **
C ** DETERMINE THE ELEMENT NUMBER FOR THE COMMAND.**
C ** IS IT AN EXISTING USER-DEFINED COMMAND? **
C ** IS IT A NEW USER-DEFINED COMMAND? **
C ***************************************************
C
IF(NUMARG.LE.0)GOTO1180
C
I2=1
IF(NUMCOM.LE.0)GOTO1190
DO1100I=1,NUMCOM
I2=I
IF(IHARG(1).EQ.ICOM3(I).AND.IHARG2(1).EQ.ICOM4(I))GOTO1190
1100 CONTINUE
I2=NUMCOM+1
GOTO1190
C
1180 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1181)
1181 FORMAT('***** ERROR IN SUBROUTINE DPDEFI--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1182)
1182 FORMAT(' WHEN USING THE DEFINE COMMAND,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1183)
1183 FORMAT(' YOU MUST HAVE SOME ENTRY')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1184)
1184 FORMAT(' AFTER THE WORD DEFINE ;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1185)
1185 FORMAT(' BUT NONE WAS GIVEN HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1186)NUMARG
1186 FORMAT(' NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
1190 CONTINUE
C
C *************************************************
C ** STEP 12-- **
C ** EXTRACT THE NAME OF THE COMMAND. **
C *************************************************
C
ICOM3(I2)=IHARG(1)
ICOM4(I2)=IHARG2(1)
C
C ***************************************************
C ** STEP 12-- **
C ** EXTRACT THE ASCII SEQUENCE. **
C ***************************************************
C
ISTRIN(1:40)=' '
ICOM5(I2)=ISTRIN(1:40)
NCOM5(I2)=0
C
J=0
IF(NUMARG.LE.1)GOTO1290
DO1200I=2,NUMARG
J=J+1
C
IC4=IHARG(I)
IC1=IC4(1:1)
C
IC4LC=IHARLC(I)
IC1LC=IC4LC(1:1)
C
IF(IC4(2:4).EQ.' ')GOTO1210
IF(IC4(1:3).EQ.'ESC')IC1LC=IESCC
IF(IC4(1:3).EQ.'ESC')GOTO1210
C
IF(IC4(1:3).EQ.'NUL')IC1LC=INULC
IF(IC4(1:3).EQ.'SOH')IC1LC=ISOHC
IF(IC4(1:3).EQ.'STX')IC1LC=ISTXC
IF(IC4(1:3).EQ.'ETX')IC1LC=IETXC
IF(IC4(1:3).EQ.'EOT')IC1LC=IEOTC
IF(IC4(1:3).EQ.'ENQ')IC1LC=IENQC
IF(IC4(1:3).EQ.'ACK')IC1LC=IACKC
IF(IC4(1:3).EQ.'BEL')IC1LC=IBELC
IF(IC4(1:2).EQ.'BS')IC1LC=IBSC
IF(IC4(1:3).EQ.'HTX')IC1LC=IHTC
IF(IC4(1:2).EQ.'LF')IC1LC=ILFC
IF(IC4(1:2).EQ.'VT')IC1LC=IVTC
IF(IC4(1:2).EQ.'FF')IC1LC=IFFC
IF(IC4(1:2).EQ.'CR')IC1LC=ICRC
IF(IC4(1:2).EQ.'SO')IC1LC=ISOC
IF(IC4(1:2).EQ.'SI')IC1LC=ISIC
IF(IC4(1:3).EQ.'DLE')IC1LC=IDLEC
IF(IC4(1:3).EQ.'DC1')IC1LC=IDC1C
IF(IC4(1:3).EQ.'DC2')IC1LC=IDC2C
IF(IC4(1:3).EQ.'DC3')IC1LC=IDC3C
IF(IC4(1:3).EQ.'DC4')IC1LC=IDC4C
IF(IC4(1:3).EQ.'NAK')IC1LC=INAKC
IF(IC4(1:3).EQ.'SYN')IC1LC=ISYNC
IF(IC4(1:3).EQ.'ETB')IC1LC=IETBC
IF(IC4(1:3).EQ.'CAN')IC1LC=ICANC
IF(IC4(1:2).EQ.'EM')IC1LC=IEMC
IF(IC4(1:3).EQ.'SUB')IC1LC=ISUBC
CCCCC IF(IC4(1:3).EQ.'ESC')IC1LC=IESCC
IF(IC4(1:2).EQ.'FS')IC1LC=IFSC
IF(IC4(1:2).EQ.'GS')IC1LC=IGSC
IF(IC4(1:2).EQ.'RS')IC1LC=IRSC
IF(IC4(1:2).EQ.'US')IC1LC=IUSC
IF(IC4(1:3).EQ.'SPA')IC1LC=' '
IF(IC4(1:2).EQ.'SP')IC1LC=' '
IF(IC4(1:3).EQ.'BLA')IC1LC=' '
IF(IC4(1:2).EQ.'BL')IC1LC=' '
C
1210 CONTINUE
ISTRIN(J:J)=IC1LC
1200 CONTINUE
C
1290 CONTINUE
ICOM5(I2)=ISTRIN(1:40)
NCOM5(I2)=J
IF(I2.GT.NUMCOM)NUMCOM=I2
C
C ***************************************************
C ** STEP 13-- **
C ** CHECK FOR THE USER-COMMAND PREPLOT **
C ** IF FOUND, COPY IT. **
C ** CHECK FOR THE USER-COMMAND POSTPLOT **
C ** IF FOUND, COPY IT. **
C ***************************************************
C
IF(IHARG(1).EQ.'PREP'.AND.IHARG2(1).EQ.'LOT')GOTO1310
IF(IHARG(1).EQ.'POST'.AND.IHARG2(1).EQ.'PLOT')GOTO1320
GOTO1390
1310 CONTINUE
NCPREP=NCOM5(I2)
ICPREP(1:40)=ICOM5(I2)
GOTO1390
1320 CONTINUE
NCPOST=NCOM5(I2)
ICPOST(1:40)=ICOM5(I2)
GOTO1390
1390 CONTINUE
C
C ***************************************************
C ** STEP 14-- **
C ** CHECK FOR THE USER-COMMAND PREHELP **
C ** IF FOUND, COPY IT. **
C ** CHECK FOR THE USER-COMMAND POSTHELP **
C ** IF FOUND, COPY IT. **
C ***************************************************
C
IF(IHARG(1).EQ.'PREH'.AND.IHARG2(1).EQ.'ELP')GOTO1410
IF(IHARG(1).EQ.'POST'.AND.IHARG2(1).EQ.'HELP')GOTO1420
GOTO1490
1410 CONTINUE
NCPREH=NCOM5(I2)
ICPREH(1:40)=ICOM5(I2)
GOTO1490
1420 CONTINUE
NCPOSH=NCOM5(I2)
ICPOSH(1:40)=ICOM5(I2)
GOTO1490
1490 CONTINUE
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'DEFI')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('AT THE END OF DPDEFI--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)IBUGS2,ISUBRO
9013 FORMAT('IBUGS2,ISUBRO = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)NUMARG
9015 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NUMARG.LE.0)GOTO9019
DO9016I=1,NUMARG
WRITE(ICOUT,9017)I,IHARG(I),IHARLC(I)
9017 FORMAT('I,IHARG(I),IHARLC(I) = ',I8,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
9016 CONTINUE
9019 CONTINUE
WRITE(ICOUT,9021)I2,NUMCOM
9021 FORMAT('I2,NUMCOM = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9022)I2,ICOM3(I2),ICOM4(I2),NCOM5(I2)
9022 FORMAT('I2,ICOM3(I2),ICOM4(I2),NCOM5(I2) = ',
1I8,2X,A4,2X,A4,I8)
CALL DPWRST('XXX','BUG ')
IMAX=NCOM5(I)
IF(IMAX.LE.0)GOTO9033
ICOM5J=ICOM5(I)
DO9031I=1,IMAX
WRITE(ICOUT,9032)I,ICOM5J(I:I)
9032 FORMAT('I,ICOM5J(I:I) = ',I8,2X,A1,2X)
CALL DPWRST('XXX','BUG ')
9031 CONTINUE
9033 CONTINUE
IF(NUMCOM.LE.0)GOTO9043
DO9041I=1,NUMCOM
CCCCC WRITE(ICOUT,9042)I,ICOM3(I),ICOM4(I),NCOM5(I),ICOM5(I)
C9042 FORMAT('I,ICOM3(I),ICOM4(I),NCOM5(I),ICOM5(I) = ',
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC1I8,2X,A4,2X,A4,I8,A40)
9041 CONTINUE
9043 CONTINUE
WRITE(ICOUT,9051)IFOUND,IERROR
9051 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9061)IC4,IC1
9061 FORMAT('IC4,IC1 = ',A4,2X,A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9062)IC4LC,IC1LC
9062 FORMAT('IC4LC,IC1LC = ',A4,2X,A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9071)NCPREP
9071 FORMAT('NCPREP = ',A4)
CALL DPWRST('XXX','BUG ')
IF(NCPREP.LE.0)GOTO9074
DO9072I=1,NCPREP
WRITE(ICOUT,9073)I,ICPREP(I:I)
9073 FORMAT('I,ICPREP(I:I) = ',I8,2X,A1,4X)
CALL DPWRST('XXX','BUG ')
9072 CONTINUE
9074 CONTINUE
WRITE(ICOUT,9076)NCPOST
9076 FORMAT('NCPOST = ',A4)
CALL DPWRST('XXX','BUG ')
IF(NCPOST.LE.0)GOTO9079
DO9077I=1,NCPOST
WRITE(ICOUT,9078)I,ICPOST(I:I)
9078 FORMAT('I,ICPOST(I:I) = ',I8,2X,A1,4X)
CALL DPWRST('XXX','BUG ')
9077 CONTINUE
9079 CONTINUE
WRITE(ICOUT,9081)NCPREH
9081 FORMAT('NCPREH = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NCPREH.LE.0)GOTO9084
DO9082I=1,NCPREH
WRITE(ICOUT,9083)I,ICPREH(I:I)
9083 FORMAT('I,ICPREH(I:I) = ',I8,2X,A1,4X)
CALL DPWRST('XXX','BUG ')
9082 CONTINUE
9084 CONTINUE
WRITE(ICOUT,9086)NCPOSH
9086 FORMAT('NCPOSH = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NCPOSH.LE.0)GOTO9089
DO9087I=1,NCPOSH
WRITE(ICOUT,9088)I,ICPOSH(I:I)
9088 FORMAT('I,ICPOSH(I:I) = ',I8,2X,A1,4X)
CALL DPWRST('XXX','BUG ')
9087 CONTINUE
9089 CONTINUE
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPDEFL(ICASPL,ICAS3D,
1DX1MIN,DX1MAX,DY1MIN,DY1MAX,
1DX2MIN,DX2MAX,DY2MIN,DY2MAX,
1GX1MIN,GX1MAX,GY1MIN,GY1MAX,
1GX2MIN,GX2MAX,GY2MIN,GY2MAX,
1IX1MIN,IX1MAX,IY1MIN,IY1MAX,
1IX2MIN,IX2MAX,IY2MIN,IY2MAX,
1IX1TSC,IX2TSC,IY1TSC,IY2TSC,
1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
1FX2MIN,FX2MAX,FY2MIN,FY2MAX,
1NMJX1T,NMJX2T,NMJY1T,NMJY2T)
C
C PURPOSE--TRANSFORM OBSERVED DATA LIMITS
C OR GIVEN LIMITS
C INTO ACTUAL FRAME LIMITS
C (WHICH MAY OR MAY NOT BE NEAT--
C DEPENDING ON THE SPECIFICATION)
C FOR ALL 4 FRAME LINES.
C
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-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--83.6
C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983.
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
CHARACTER*4 ICASPL
CHARACTER*4 ICAS3D
C
CHARACTER*4 IX1MIN
CHARACTER*4 IX1MAX
CHARACTER*4 IY1MIN
CHARACTER*4 IY1MAX
C
CHARACTER*4 IX2MIN
CHARACTER*4 IX2MAX
CHARACTER*4 IY2MIN
CHARACTER*4 IY2MAX
C
CHARACTER*4 IX1TSC
CHARACTER*4 IX2TSC
CHARACTER*4 IY1TSC
CHARACTER*4 IY2TSC
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCOGR.INC'
INCLUDE 'DPCOBE.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEFL')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPDEFL--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)DX1MIN,DY1MIN,DX1MAX,DY1MAX
52 FORMAT('DX1MIN,DY1MIN,DX1MAX,DY1MAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)DX2MIN,DY2MIN,DX2MAX,DY2MAX
53 FORMAT('DX2MIN,DY2MIN,DX2MAX,DY2MAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)GX1MIN,DY1MIN,GX1MAX,DY1MAX
54 FORMAT('GX1MIN,DY1MIN,GX1MAX,DY1MAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,55)GX2MIN,DY2MIN,GX2MAX,DY2MAX
55 FORMAT('GX2MIN,DY2MIN,GX2MAX,DY2MAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,56)IX1MIN,IY1MIN,IX1MAX,IY1MAX
56 FORMAT('IX1MIN,IY1MIN,IX1MAX,IY1MAX = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,57)IX2MIN,IY2MIN,IX2MAX,IY2MAX
57 FORMAT('IX2MIN,IY2MIN,IX2MAX,IY2MAX = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,58)IX1TSC,IX2TSC,IY1TSC,IY2TSC
58 FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,61)FX1MIN,FX1MAX,FY1MIN,FY1MAX
61 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,62)FX2MIN,FX2MAX,FY2MIN,FY2MAX
62 FORMAT('FX2MIN,FX2MAX,FY2MIN,FY2MAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,63)ICASPL,ICAS3D
63 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,64)NMJX1T,NMJX2T,NMJY1T,NMJY2T
64 FORMAT('NMJX1T,NMJX2T,NMJY1T,NMJY2T = ',4I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4
69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C ******************************************************
C ** STEP 1-- **
C ** DETERMINE FRAME LIMITS ON BOTTOM HORIZONTAL AXIS **
C ******************************************************
C
CALL DPDEF2(DX1MIN,DX1MAX,GX1MIN,GX1MAX,IX1MIN,IX1MAX,IX1TSC,
1FX1MIN,FX1MAX,NMJX1T)
IF(IERRG4.EQ.'YES')GOTO9000
C
C ******************************************************
C ** STEP 2-- **
C ** DETERMINE FRAME LIMITS ON TOP HORIZONTAL AXIS **
C ******************************************************
C
CALL DPDEF2(DX2MIN,DX2MAX,GX2MIN,GX2MAX,IX2MIN,IX2MAX,IX2TSC,
1FX2MIN,FX2MAX,NMJX2T)
IF(IERRG4.EQ.'YES')GOTO9000
C
C ******************************************************
C ** STEP 3-- **
C ** DETERMINE FRAME LIMITS ON LEFT VERTICAL AXIS **
C ******************************************************
C
CALL DPDEF2(DY1MIN,DY1MAX,GY1MIN,GY1MAX,IY1MIN,IY1MAX,IY1TSC,
1FY1MIN,FY1MAX,NMJY1T)
IF(IERRG4.EQ.'YES')GOTO9000
C
C ******************************************************
C ** STEP 4-- **
C ** DETERMINE FRAME LIMITS ON RIGHT VERTICAL AXIS **
C ******************************************************
C
CALL DPDEF2(DY2MIN,DY2MAX,GY2MIN,GY2MAX,IY2MIN,IY2MAX,IY2TSC,
1FY2MIN,FY2MAX,NMJY2T)
IF(IERRG4.EQ.'YES')GOTO9000
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEFL')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPDEFL--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)DX1MIN,DY1MIN,DX1MAX,DY1MAX
9012 FORMAT('DX1MIN,DY1MIN,DX1MAX,DY1MAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)DX1MIN,DY1MIN,DX1MAX,DY1MAX
9013 FORMAT('DX1MIN,DY1MIN,DX1MAX,DY1MAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)GX1MIN,DY1MIN,GX1MAX,DY1MAX
9014 FORMAT('GX1MIN,DY1MIN,GX1MAX,DY1MAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)GX2MIN,DY2MIN,GX2MAX,DY2MAX
9015 FORMAT('GX2MIN,DY2MIN,GX2MAX,DY2MAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9016)IX1MIN,IY1MIN,IX1MAX,IY1MAX
9016 FORMAT('IX1MIN,IY1MIN,IX1MAX,IY1MAX = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9017)IX2MIN,IY2MIN,IX2MAX,IY2MAX
9017 FORMAT('IX2MIN,IY2MIN,IX2MAX,IY2MAX = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9018)IX1TSC,IX2TSC,IY1TSC,IY2TSC
9018 FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9021)FX1MIN,FX1MAX,FY1MIN,FY1MAX
9021 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9022)FX2MIN,FX2MAX,FY2MIN,FY2MAX
9022 FORMAT('FX2MIN,FX2MAX,FY2MIN,FY2MAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9023)ICASPL,ICAS3D
9023 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9024)NMJX1T,NMJX2T,NMJY1T,NMJY2T
9024 FORMAT('NMJX1T,NMJX2T,NMJY1T,NMJY2T = ',4I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4
9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPDEF2(DMIN,DMAX,GMIN,GMAX,IMIN,IMAX,ITICSC,
1FMIN,FMAX,NUMMAJ)
C
C PURPOSE--TRANSFORM OBSERVED DATA LIMITS
C OR GIVEN LIMITS
C INTO ACTUAL FRAME LIMITS
C (WHICH MAY OR MAY NOT BE NEAT--
C DEPENDING ON THE SPECIFICATION)
C FOR A SINGLE FRAME LINE.
C NOTE--ALGORITHM SUGGESTED BY WALTER LIGGETT
C NATIONAL BUREAU OF STANDARDS
C INTERESTING TEST PROBLEMS--156 AND 234
C
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-921-3651
C NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C OF THE NATIONAL BUREAU OF STANDARDS.
C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C MODIFIED, OR OTHERWISE USED IN A CONTEXT
C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--83.6
C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983.
C UPDATED --??? 19??. WEIBULL SCALE
C UPDATED --JUNE 1990. NORMAL SCALE
C UPDATED --JULY 1996. ALLOW UPPER AND LOWER BOUND
C TO BE EQUAL
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
CHARACTER*4 IMIN
CHARACTER*4 IMAX
CHARACTER*4 ITICSC
C
DIMENSION WEIB21(25)
CCCCC THE FOLLOWING LINE WAS ADDED JUNE 1990
DIMENSION ANORM(27)
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCOGR.INC'
INCLUDE 'DPCOBE.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS---------------------------------------------------
C
DATA WEIB21( 1),WEIB21( 2),WEIB21( 3),WEIB21( 4),WEIB21( 5),
1 WEIB21( 6),WEIB21( 7),WEIB21( 8),WEIB21( 9),WEIB21(10),
1 WEIB21(11),WEIB21(12),WEIB21(13),WEIB21(14),WEIB21(15),
1 WEIB21(16),WEIB21(17),WEIB21(18),WEIB21(19),WEIB21(20),
1 WEIB21(21)
1/0.000001,0.00001,0.0001,0.001,0.01,0.1,
1 0.5,1.0,5.0,10.0,20.0,30.0,40.0,50.0,
1 60.0,70.0,80.0,90.0,95.0,99.0,99.9/
C
CCCCC THE FOLLOWING DATA STATEMENT WAS ADDED JUNE 1990
DATA ANORM( 1),ANORM( 2),ANORM( 3),ANORM( 4),ANORM( 5),
1 ANORM( 6),ANORM( 7),ANORM( 8),ANORM( 9),ANORM(10),
1 ANORM(11),ANORM(12),ANORM(13),ANORM(14),ANORM(15),
1 ANORM(16),ANORM(17),ANORM(18),ANORM(19),ANORM(20),
1 ANORM(21),ANORM(22),ANORM(23),ANORM(24),ANORM(25),
1 ANORM(26),ANORM(27)
1/0.000001,0.00001,0.0001,0.001,0.01,0.1,0.5,
1 1.0,5.0,10.0,20.0,30.0,40.0,
1 50.0,
1 60.0,70.0,80.0,90.0,95.0,99.0,
1 99.5,99.9,99.99,99.999,99.9999,99.99999,99.999999/
C
C-----START POINT-----------------------------------------------------
C
RTMINP=(-999.0)
RTMAXP=(-999.00)
ANUM=0.0
EXPMIN=0.0
EXPMAX=0.0
IEXMIN=0
IEXMAX=0
AEXMIN=0.0
AEXMAX=0.0
DELMIN=0.0
DELMAX=0.0
ATMIN=0.0
ATMAX=0.0
IEXP=0
IRTMIN=0
IRTMAX=0
RTMIN=0.0
RTMAX=0.0
ANMIN=0.0
ANMAX=0.0
C
AHUNDR=100.0
C
IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEF2')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPDEF2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)DMIN,DMAX
52 FORMAT('DMIN, DMAX = ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)GMIN,GMAX
53 FORMAT('GMIN, GMAX = ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)IMIN,IMAX
54 FORMAT('IMIN, IMAX = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,55)ITICSC
55 FORMAT('ITICSC = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,56)NUMMAJ
56 FORMAT('NUMMAJ = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,59)IBUGG4,ISUBG4,IERRG4
59 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C *******************************************************
C ** STEP 1-- **
C ** AS A STARTER FOR THE LINEAR, LOG,
C ** WEIBULL, AND NORMAL CASES,
C ** TREAT THE FIXED OR FLOATING CASE **
C *******************************************************
C
FMINOL=FMIN
FMAXOL=FMAX
C
AMIN=DMIN
AMAX=DMAX
IF(IMIN.EQ.'FIXE')AMIN=GMIN
IF(IMAX.EQ.'FIXE')AMAX=GMAX
C
IF(AMIN.LT.AMAX)GOTO1190
HOLD=AMIN
AMAX=AMIN
AMIN=HOLD
1190 CONTINUE
C
C *****************************************
C ** STEP 2-- **
C ** TREAT THE LOG SCALE CASE **
C ** (WHICH WILL AUTOMATICALLY BE NEAT **
C ** WITH FULL CYCLES RESULTING) **
C *****************************************
C
IF(ITICSC.EQ.'LOG')GOTO1200
GOTO1290
C
1200 CONTINUE
IF(AMIN.LE.0.0)ANUM=AMIN
IF(AMIN.LE.0.0)GOTO1210
IF(AMAX.LE.0.0)ANUM=AMAX
IF(AMAX.LE.0.0)GOTO1210
GOTO1219
C
1210 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1211)
1211 FORMAT('***** ERROR IN DPDEF2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1212)
1212 FORMAT(' WHILE COMPUTING FRAME LIMITS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1213)
1213 FORMAT(' FOR A LOG SCALE PLOT,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1214)
1214 FORMAT(' THE LOG OF A NON-POSITIVE NUMBER ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1215)
1215 FORMAT(' WAS ENCOUNTERED.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1216)ANUM
1216 FORMAT(' THE NUMBER = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1217)
1217 FORMAT(' CORRECTIVE ACTION--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1218)
1218 FORMAT(' CHANGE DATA OR CHANGE LIMITS.')
CALL DPWRST('XXX','BUG ')
IERRG4='YES'
GOTO9000
1219 CONTINUE
C
IF(AMIN.EQ.AMAX)THEN
EXPMIN=ALOG10(AMIN)
IF(EXPMIN.LT.0.0)EXPMIN=EXPMIN-1.0
IEXMIN=EXPMIN
FMIN=10.0**IEXMIN
FMAX=FMIN
GOTO9000
ENDIF
C
EXPMIN=ALOG10(AMIN)
IF(EXPMIN.LT.0.0)EXPMIN=EXPMIN-1.0
EXPMAX=ALOG10(AMAX)
IEXMIN=EXPMIN
IEXMAX=EXPMAX
AEXMIN=IEXMIN
AEXMAX=IEXMAX
DELMIN=EXPMIN-AEXMIN
DELMAX=EXPMAX-AEXMAX
IF(DELMAX.GE.0.00001)IEXMAX=IEXMAX+1
IF(IEXMAX.EQ.IEXMIN)IEXMAX=IEXMIN+1
C
FMIN=10.0**IEXMIN
FMAX=10.0**IEXMAX
GOTO9000
C
1290 CONTINUE
C
C *****************************************
C ** STEP 3-- **
C ** TREAT THE WEIBULL SCALE CASE **
C ** (WHICH WILL AUTOMATICALLY BE NEAT) **
C *****************************************
C
IF(ITICSC.EQ.'WEIB')GOTO1300
GOTO1390
C
1300 CONTINUE
IF(AMIN.LE.0.0.OR.AMIN.GE.AHUNDR)ANUM=AMIN
IF(AMIN.LE.0.0.OR.AMIN.GE.AHUNDR)GOTO1310
IF(AMAX.LE.0.0.OR.AMAX.GE.AHUNDR)ANUM=AMAX
IF(AMAX.LE.0.0.OR.AMAX.GE.AHUNDR)GOTO1310
GOTO1319
C
1310 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1311)
1311 FORMAT('***** ERROR IN DPDEF2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1312)
1312 FORMAT(' WHILE COMPUTING FRAME LIMITS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1313)
1313 FORMAT(' FOR A WEIBULL SCALE PLOT,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1314)
1314 FORMAT(' THE LOG OF A NUMBER OUTSIDE OF ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1315)
1315 FORMAT(' THE 0 TO 100 RANGE WAS ENCOUNTERED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1316)ANUM
1316 FORMAT(' THE NUMBER = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1317)
1317 FORMAT(' CORRECTIVE ACTION--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1318)
1318 FORMAT(' CHANGE DATA OR CHANGE LIMITS.')
CALL DPWRST('XXX','BUG ')
IERRG4='YES'
GOTO9000
1319 CONTINUE
C
NUMMA2=NUMMAJ
IF(NUMMAJ.LE.16)NUMMA2=16
IF(NUMMAJ.GE.21)NUMMA2=21
C
I1=1+(21-NUMMA2)
I2=21
C
FMIN=WEIB21(I1)
FMAX=WEIB21(I2)
C
GOTO9000
C
1390 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 1990
C *****************************************
C ** STEP 4-- **
C ** TREAT THE NORMAL SCALE CASE **
C ** (WHICH WILL AUTOMATICALLY BE NEAT) **
C *****************************************
C
IF(ITICSC.EQ.'NORM')GOTO1400
GOTO1490
C
1400 CONTINUE
CCCCC IF(AMIN.LE.0.0.OR.AMIN.GE.AHUNDR)ANUM=AMIN
CCCCC IF(AMIN.LE.0.0.OR.AMIN.GE.AHUNDR)GOTO1410
CCCCC IF(AMAX.LE.0.0.OR.AMAX.GE.AHUNDR)ANUM=AMAX
CCCCC IF(AMAX.LE.0.0.OR.AMAX.GE.AHUNDR)GOTO1410
GOTO1419
C
1410 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1411)
1411 FORMAT('***** ERROR IN DPDEF2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1412)
1412 FORMAT(' WHILE COMPUTING FRAME LIMITS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1413)
1413 FORMAT(' FOR A NORMAL SCALE PLOT,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1414)
1414 FORMAT(' A NUMBER OUTSIDE OF ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1415)
1415 FORMAT(' THE 0 TO 100 RANGE WAS ENCOUNTERED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1416)ANUM
1416 FORMAT(' THE NUMBER = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1417)
1417 FORMAT(' CORRECTIVE ACTION--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1418)
1418 FORMAT(' CHANGE DATA OR CHANGE LIMITS.')
CALL DPWRST('XXX','BUG ')
IERRG4='YES'
GOTO9000
1419 CONTINUE
C
NUMMA2=NUMMAJ
IF(NUMMAJ.LE.15)NUMMA2=15
IF(NUMMAJ.GE.27)NUMMA2=27
IHALF=NUMMA2/2
I1=14-IHALF
I2=14+IHALF
IF(I1.LE.1)I1=1
IF(I2.GE.27)I2=27
C
FMIN=ANORM(I1)
FMAX=ANORM(I2)
C
GOTO9000
C
1490 CONTINUE
C
C ************************************
C ** STEP 34-- **
C ** TREAT THE EQUALITY CASE **
C ** WHICH WILL AUTOMATICALLY GET **
C ** ARTIFICIAL, NON-EQUAL LIMITS **
C ************************************
C
IF(AMIN.EQ.AMAX)GOTO4400
GOTO4490
C
4400 CONTINUE
IF(AMIN.EQ.0.0)ATMIN=-1.0
IF(AMIN.EQ.0.0)ATMAX=1.0
IF(AMIN.LT.0.0)ATMIN=1.05*AMIN
IF(AMIN.LT.0.0)ATMAX=0.95*AMIN
IF(AMIN.GT.0.0)ATMIN=0.95*AMIN
IF(AMIN.GT.0.0)ATMAX=1.05*AMIN
FMIN=ATMIN
FMAX=ATMAX
GOTO9000
C
4490 CONTINUE
C
C ***************************************
C ** STEP 35-- **
C ** COMPUTE NEAT, NON-LOG LIMITS **
C ***************************************
C
ATMIN=AMIN
ATMAX=AMAX
IEXP=0
4500 CONTINUE
ATDEL=ATMAX-ATMIN
IF(IBUGG4.EQ.'ON')WRITE(ICOUT,4505)ATMIN,ATMAX,ATDEL,IEXP
4505 FORMAT('ATMIN,ATMAX,ATDEL,IEXP = ',3E15.7,I8)
IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ')
IF(ATDEL.LT.1.0)GOTO4510
IF(ATDEL.GT.10.0)GOTO4520
GOTO4530
C
4510 CONTINUE
ATMIN=ATMIN*10.0
ATMAX=ATMAX*10.0
IEXP=IEXP+1
GOTO4500
C
4520 CONTINUE
ATMIN=ATMIN/10.0
ATMAX=ATMAX/10.0
IEXP=IEXP-1
GOTO4500
C
4530 CONTINUE
CALL DPDEF3(ATMIN,ATMAX,RTMIN,RTMAX)
C
4590 CONTINUE
DENOM=10.0**IEXP
ANMIN=RTMIN/DENOM
ANMAX=RTMAX/DENOM
C
FMIN=AMIN
FMAX=AMAX
IF(IMIN.EQ.'FLOA')FMIN=ANMIN
IF(IMAX.EQ.'FLOA')FMAX=ANMAX
GOTO9000
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEF2')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPDEF2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)DMIN,DMAX
9012 FORMAT('DMIN, DMAX = ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)GMIN,GMAX
9013 FORMAT('GMIN, GMAX = ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)IMIN,IMAX
9014 FORMAT('IMIN, IMAX = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)ITICSC
9015 FORMAT('ITICSC = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9016)FMIN,FMAX
9016 FORMAT('FMIN, FMAX = ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9017)NUMMAJ
9017 FORMAT('NUMMAJ = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9021)EXPMIN,EXPMAX
9021 FORMAT('EXPMIN,EXPMAX = ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9022)IEXMIN,IEXMAX
9022 FORMAT('IEXMIN,IEXMAX = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9031)IEXP
9031 FORMAT('IEXP = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9032)ATMIN,ATMAX
9032 FORMAT('ATMIN, ATMAX = ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9033)IRTMIN,IRTMAX
9033 FORMAT('IRTMIN,IRTMAX = ',4X,I8,4X,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9034)RTMIN,RTMAX
9034 FORMAT('RTMIN, RTMAX = ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9035)ANMIN,ANMAX
9035 FORMAT('ANMIN,ANMAX = ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9036)AMIN,AMAX,EXPMIN,EXPMAX,IEXMIN,IEXMAX
9036 FORMAT('AMIN,AMAX,EXPMIN,EXPMAX,IEXMIN,IEXMAX = ',4E15.7,2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9037)AEXMIN,AEXMAX,DELMIN,DELMAX
9037 FORMAT('AEXMIN,AEXMAX,DELMIN,DELMAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9041)AMIN,ATMIN,IRTMIN,RTMIN,RTMINP,ANMIN,FMIN
9041 FORMAT('AMIN,ATMIN,IRTMIN,RTMIN,RTMINP,ANMIN,FMIN = ',
12E11.3,I8,4E11.3)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9042)AMAX,ATMAX,IRTMIN,RTMAX,RTMAXP,ANMAX,FMAX
9042 FORMAT('AMAX,ATMAX,IRTMAX,RTMAX,RTMAXP,ANMAX,FMAX = ',
12E11.3,I8,4E11.3)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4
9039 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPDEF3(ATMIN,ATMAX,RTMIN,RTMAX)
C
C PURPOSE--TRANSFORM LIMITS (WHICH ARE SUCH
C THAT THERE DIFFERENCE IS BETWEEN 1 AND 10)
C INTO NEAT LIMITS.
C NOTE--ALGORITHM SUGGESTED BY WALTER LIGGETT
C NATIONAL BUREAU OF STANDARDS
C INTERESTING TEST PROBLEMS--156 AND 234
C
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-921-3651
C NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C OF THE NATIONAL BUREAU OF STANDARDS.
C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C MODIFIED, OR OTHERWISE USED IN A CONTEXT
C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--83.6
C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983.
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
CHARACTER*4 ICMIN
CHARACTER*4 ICMAX
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCOGR.INC'
INCLUDE 'DPCOBE.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
IRTMIN=(-999)
IRTMAX=(-999)
RTMINP=(-999.0)
RTMAXP=(-999.0)
C
EPS=0.00001
ONEMEP=1.0-EPS
ONEPEP=1.0+EPS
C
IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEF3')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPDEF3--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)ATMIN,ATMAX
52 FORMAT('ATMIN,ATMAX = ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)EPS
53 FORMAT('EPS = ',E15.7)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
1100 CONTINUE
CALL CKINTE(ATMIN,EPS,ONEMEP,ONEPEP,ICMIN,IRTMIN)
CALL CKINTE(ATMAX,EPS,ONEMEP,ONEPEP,ICMAX,IRTMAX)
RTMIN=IRTMIN
RTMAX=IRTMAX
IF(ICMIN.EQ.'YES'.AND.ICMAX.EQ.'YES')GOTO9000
C
1120 CONTINUE
IF(ICMIN.EQ.'YES')GOTO1129
IRTMIN=ATMIN
IF(ATMIN.LT.0.0)IRTMIN=ATMIN-1.0
RTMIN=IRTMIN
CCCCC RTMINP=RTMIN+0.5
CCCCC IF(RTMINP.LE.ATMIN)RTMIN=RTMINP
1129 CONTINUE
C
1130 CONTINUE
IF(ICMAX.EQ.'YES')GOTO1139
IRTMAX=ATMAX+1.0
IF(ATMAX.LT.0.0)IRTMAX=ATMAX
RTMAX=IRTMAX
CCCCC RTMAXP=RTMAX-0.5
CCCCC IF(RTMAXP.GE.ATMAX)RTMAX=RTMAXP
1139 CONTINUE
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEF3')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPDEF3--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9021)ATMIN,IRTMIN,RTMINP,RTMIN
9021 FORMAT('ATMIN,IRTMIN,RTMINP,RTMIN = ',
1E15.7,I8,E15.7,E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9022)ATMAX,IRTMAX,RTMAXP,RTMAX
9022 FORMAT('ATMAX,IRTMAX,RTMAXP,RTMAX = ',
1E15.7,I8,E15.7,E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9025)EPS,ONEMEP,ONEPEP
9025 FORMAT('EPS,ONEMEP,ONEPEP = ',3E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9026)ICMIN,ICMAX
9026 FORMAT('ICMIN,ICMAX = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4
9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
CCCCC DEBUG TRACE,INIT
CCCCC AT 90
CCCCC TRACE ON
END
SUBROUTINE DPDEFN(ICOM,IHARG,IHARG2,IARGT,IARG,NUMARG,
1IBUGO2,ISUBRO,IFOUND,IERROR)
C
C PURPOSE--SHOW DEVICE FONTS. THIS COMMAND IS INTENDED
C FOR DEVICES WHICH SUPPORT VARIOUS HARDWARE FONTS
C (RIGHT NOW, LIMITED TO POSTSCRIPT).
C INPUT ARGUMENTS--ICOM (A CHARACTER VECTOR)
C --IHARG (A CHARACTER VECTOR)
C --IHARG2 (A CHARACTER VECTOR)
C --IARGT (A CHARACTER VECTOR)
C --IARG (A CHARACTER VECTOR)
C --NUMARG
C OUTPUT ARGUMENTS--
C --IFOUND ('YES' OR 'NO' )
C --IERROR ('YES' OR 'NO' )
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-975-2855
C NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C OF THE NATIONAL BUREAU OF STANDARDS.
C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C MODIFIED, OR OTHERWISE USED IN A CONTEXT
C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--82/7
C ORIGINAL VERSION--OCTOBER 1991.
C UPDATED --SEPTEMBER 1993. FIX MULTI-LINE FORMATS
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 ICOM
CHARACTER*4 IHARG
CHARACTER*4 IHARG2
CHARACTER*4 IARGT
C
CHARACTER*4 IBUGO2
CHARACTER*4 ISUBRO
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*40 ICPREH
CHARACTER*4 IRESP
CHARACTER*40 IPSTAL(100)
C
C---------------------------------------------------------------------
C
DIMENSION IHARG(*)
DIMENSION IHARG2(*)
DIMENSION IARGT(*)
DIMENSION IARG(*)
C
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCODV.INC'
INCLUDE 'DPCOBE.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
DATA (IPSTAL(I),I=1,15)/
1 'TIMES ROMAN',
2 'TIMES ITALIC',
3 'TIMES BOLD',
4 'TIMES BOLD ITALIC',
5 'HELVETICA',
6 'HELVETICA OBLIQUE',
7 'HELVETICA BOLD',
8 'HELVETICA BOLD OBLIQUE',
9 'COURIER',
* 'COURIER OBLIQUE',
1 'COURIER BOLD',
2 'COURIER BOLD OBLIQUE',
3 'AVANT GARDE',
4 'AVANT GARDE BOOK OBLIQUE',
5 'AVANT GARDE DEMI'/
DATA (IPSTAL(I),I=16,30)/
1 'AVANT GARDE DEMI OBLIQUE',
2 'BOOK DEMI',
3 'BOOK DEMI ITALIC',
4 'BOOK LIGHT',
5 'BOOK LIGHT ITALIC',
6 'HELVETICA NARROW',
7 'HELVETICA NARROW BOLD',
8 'HELVETICA NARROW BOLD OBLIQUE',
9 'HELVETICA NARROW OBLIQUE',
* 'CENTURY',
1 'CENTURY BOLD',
2 'CENTURY ITALIC',
3 'CENTURY BOLD ITALIC',
4 'PALATINO',
5 'PALATINO BOLD'/
DATA (IPSTAL(I),I=31,45)/
1 'PALATINO ITALIC',
2 'PALATINO BOLD ITALIC',
3 'ZAPF',
4 'SYMBOL',
5 ' ',
6 ' ',
7 ' ',
8 ' ',
9 ' ',
* ' ',
1 ' ',
2 ' ',
3 ' ',
4 ' ',
5 ' '/
DATA (IPSTAL(I),I=46,60)/
1 ' ',
2 ' ',
3 ' ',
4 ' ',
5 ' ',
6 ' ',
7 ' ',
8 ' ',
9 ' ',
* ' ',
1 ' ',
2 ' ',
3 ' ',
4 ' ',
5 ' '/
DATA (IPSTAL(I),I=61,75)/
1 ' ',
2 ' ',
3 ' ',
4 ' ',
5 ' ',
6 ' ',
7 ' ',
8 ' ',
9 ' ',
* ' ',
1 ' ',
2 ' ',
3 ' ',
4 ' ',
5 ' '/
DATA (IPSTAL(I),I=76,90)/
1 ' ',
2 ' ',
3 ' ',
4 ' ',
5 ' ',
6 ' ',
7 ' ',
8 ' ',
9 ' ',
* ' ',
1 ' ',
2 ' ',
3 ' ',
4 ' ',
5 ' '/
DATA (IPSTAL(I),I=91,100)/
1 ' ',
2 ' ',
3 ' ',
4 ' ',
5 ' ',
6 ' ',
7 ' ',
8 ' ',
9 ' ',
* ' '/
C
C-----START POINT-----------------------------------------------------
C
IFOUND='NO'
IERROR='NO'
IBUGG4='OFF'
ISUBG4='-999'
C
IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEFN')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('AT THE BEGINNING OF DPDEFN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)IBUGO2
53 FORMAT('IBUGO2 = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,60)IFOUND,IERROR
60 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,68)NUMARG
68 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
DO70I=1,NUMARG
WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I)
71 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I) = ',
1 I8,2X,A4,2X,A4,2X,A4,2X,I8)
CALL DPWRST('XXX','BUG ')
70 CONTINUE
90 CONTINUE
C
IF(ICOM.EQ.'POST')GOTO4100
C
C *****************************************
C ** POSTSCRIPT CASE **
C *****************************************
C
4100 CONTINUE
C
IF(IHARG(1).EQ.'FONT'.AND. IHARG(2).EQ.'SHOW')GOTO4800
IF(IHARG(1).EQ.'FONT'.AND. IHARG(2).EQ.'LIST')GOTO4800
IF(IHARG(1).EQ.'FONT'.AND. IHARG(2).EQ.'PRIN')GOTO4800
IF(IHARG(1).EQ.'FONT'.AND. IHARG(2).EQ.'DEFA')GOTO4500
IF(IHARG(1).EQ.'FONT'.AND. IHARG(2).EQ.' ')GOTO4800
IF(IHARG(1).EQ.'FONT')GOTO4110
IF(IHARG(1).EQ.'SHOW')GOTO4800
IF(IHARG(1).EQ.'LIST')GOTO4800
IF(IHARG(1).EQ.'PRIN')GOTO4800
GOTO9000
C
4110 CONTINUE
IARGFN=3
GOTO4190
C
4120 CONTINUE
IARGFN=2
GOTO4190
C
4190 CONTINUE
IFOUND='YES'
IF(IHARG(IARGFN).EQ.' ')GOTO4800
IF(IHARG(IARGFN).EQ.'AUTO')GOTO4500
IF(IHARG(IARGFN).EQ.'DEFA')GOTO4500
IF(IHARG(IARGFN).EQ.'ON ')GOTO4500
IF(IHARG(IARGFN).EQ.'LIST')GOTO4800
IF(IHARG(IARGFN).EQ.'SHOW')GOTO4800
IF(IHARG(IARGFN).EQ.'PRIN')GOTO4800
GOTO4600
C
C SET DEFAULT POSTSCRIPT FONT
C
4500 CONTINUE
IFOUND='YES'
IPSTFN='HELB'
IF(IFEEDB.EQ.'OFF')GOTO4519
WRITE(ICOUT,4508)IPSTFN
4508 FORMAT('THE POSTSCRIPT FONT HAS BEEN SET TO ',A4)
CALL DPWRST('XXX','BUG ')
4519 CONTINUE
GOTO9000
C
C SET POSTSCRIPT FONT. THIS CODE HAS NOT BEEN WRITTEN YET.
C
4600 CONTINUE
GOTO9000
C
C LIST AVAILABLE POSTSCRIPT FONTS
C
4800 CONTINUE
IFOUND='YES'
IHELMX=24
NCPREH=0
ICPREH=' '
IRESP='YES'
IBUGO2='OFF'
NUMLPR=4
DO4810I=1,IPSTMF
NUMLPR=NUMLPR+3
IF(NUMLPR.GE.IHELMX)THEN
CALL DPMORE(NUMLPR,NCPREH,ICPREH,IRESP,IBUGO2,IERROR)
NUMLPR=0
IF(IRESP.EQ.'NO')GOTO9000
END IF
CCCCC THE FOLLOWING FORMAT STATEMENT WAS SPLIT SEPTEMBER 1993
WRITE(ICOUT,4811)IPSTT2(I)
4811 FORMAT('POSTSCRIPT FONT: ',A40)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4812)IPSTT1(I)
4812 FORMAT(' SET POSTSCRIPT FONT ',A4,' OR')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4813)IPSTAL(I)
4813 FORMAT(' SET POSTSCRIPT FONT ',A40)
CALL DPWRST('XXX','BUG ')
4810 CONTINUE
GOTO9000
C
4910 CONTINUE
IERROR='YES'
GOTO9000
C
9000 CONTINUE
IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEFN')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('AT THE END OF DPDEFN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)IBUGO2
9013 FORMAT('IBUGO2 = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)IBUGG4,ISUBG4
9014 FORMAT('IBUGG4,ISUBG4 = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9020)IFOUND,IERROR
9020 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9028)NUMARG
9028 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
DO9030I=1,NUMARG
WRITE(ICOUT,9031)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I)
9031 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I) = ',
1I8,2X,A4,2X,A4,2X,A4,2X,I8)
CALL DPWRST('XXX','BUG ')
9030 CONTINUE
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPDEFR(IHARG,IARGT,ARG,NUMARG,DEFDMF,
1DEMOFR,IFOUND,IERROR)
C
C PURPOSE--DEFINE THE FREQUENCY AS INPUT IN COMPLEX
C DEMODULATION.
C THE SPECIFIED FREQUENCY VALUE WILL BE PLACED
C IN THE FLOATING POINT VARIABLE DEMOFR.
C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR)
C --IARGT (A HOLLERITH VECTOR)
C --ARG (A FLOATING POINT VECTOR)
C --NUMARG (AN INTEGER VARIABLE)
C --DEFDMF (A FLOATING POINT VARIABLE)
C OUTPUT ARGUMENTS--DEMOFR (A FLOATING POINT VARIABLE)
C --IFOUND ('YES' OR 'NO' )
C --IERROR ('YES' OR 'NO' )
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-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 IHARG
CHARACTER*4 IARGT
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
DIMENSION IHARG(*)
DIMENSION IARGT(*)
DIMENSION ARG(*)
C
C---------------------------------------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
IFOUND='NO'
IERROR='NO'
C
1110 CONTINUE
IF(NUMARG.LE.1)GOTO1150
IF(IHARG(NUMARG).EQ.'ON')GOTO1150
IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
IF(IHARG(NUMARG).EQ.'?')GOTO8100
IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160
GOTO1120
C
1120 CONTINUE
IERROR='YES'
WRITE(ICOUT,1121)
1121 FORMAT('***** ERROR IN DPDEFR--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1122)
1122 FORMAT(' ILLEGAL FORM FOR DEMODULATION FREQUENCY ',
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 ANALYST DESIRES THE ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1126)
1126 FORMAT(' FREQUENCY FOR DEMODULATION ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1127)
1127 FORMAT(' TO BE .25 (OBSERVATIONS PER UNIT TIME)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1129)
1129 FORMAT(' THEN THE ALLOWABLE FORM IS--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1130)
1130 FORMAT(' DEMODULATION FREQUENCY .25 ')
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1150 CONTINUE
HOLD=DEFDMF
GOTO1180
C
1160 CONTINUE
HOLD=ARG(NUMARG)
GOTO1180
C
1180 CONTINUE
IFOUND='YES'
DEMOFR=HOLD
C
IF(IFEEDB.EQ.'OFF')GOTO1189
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1181)DEMOFR
1181 FORMAT('THE DEMODULATION FREQUENCY HAS JUST BEEN SET TO ',
1E15.7)
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)DEMOFR
8111 FORMAT('THE CURRENT DEMODULATION FREQUENCY IS ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8112)DEFDMF
8112 FORMAT('THE DEFAULT DEMODULATION FREQUENCY IS ',E15.7)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
RETURN
END
SUBROUTINE DPDEFT(IHARG,IHARG2,IARGT,IARG,NUMARG,
1IDEFFN,
1NUMDEV,MAXDEV,
1IDMANU,IDMODE,IDMOD2,IDMOD3,
1IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT,
1IBUGO2,IFOUND,IERROR)
C
C PURPOSE--DEFINE THE FONT (TEKT/SIMP/...) FOR AN OUTPUT DEVICE.
C THE FONT FOR DEVICE I
C WILL BE PLACED IN THE I-TH ELEMENT OF THE CHARACTER
C VECTOR IDFONT(.).
C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR)
C --IHARG2 (A CHARACTER VECTOR)
C --IARGT (A CHARACTER VECTOR)
C --IARG (A CHARACTER VECTOR)
C --NUMARG
C --IDEFFN
C --MAXDEV
C OUTPUT ARGUMENTS--IDFONT (A CHARACTER VECTOR
C WHOSE I-TH ELEMENT CONTAINS THE
C FONT (ON/OFF) FOR DEVICE I.
C --IFOUND ('YES' OR 'NO' )
C --IERROR ('YES' OR 'NO' )
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-975-2855
C NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C OF THE NATIONAL BUREAU OF STANDARDS.
C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C MODIFIED, OR OTHERWISE USED IN A CONTEXT
C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--96/7
C ORIGINAL VERSION--JULY 1996.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IHARG
CHARACTER*4 IHARG2
CHARACTER*4 IARGT
C
CHARACTER*4 IDEFFN
C
CHARACTER*4 IDMANU
CHARACTER*4 IDMODE
CHARACTER*4 IDMOD2
CHARACTER*4 IDMOD3
C
CHARACTER*4 IDPOWE
CHARACTER*4 IDCONT
CHARACTER*4 IDCOLO
CHARACTER*4 IDFONT
C
CHARACTER*4 IBUGO2
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 IHOLD
C
C---------------------------------------------------------------------
C
DIMENSION IHARG(*)
DIMENSION IHARG2(*)
DIMENSION IARGT(*)
DIMENSION IARG(*)
C
DIMENSION IDMANU(*)
DIMENSION IDMODE(*)
DIMENSION IDMOD2(*)
DIMENSION IDMOD3(*)
C
DIMENSION IDPOWE(*)
DIMENSION IDCONT(*)
DIMENSION IDCOLO(*)
DIMENSION IDFONT(*)
DIMENSION IDNVPP(*)
DIMENSION IDNHPP(*)
DIMENSION IDUNIT(*)
C
C---------------------------------------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
IFOUND='NO'
IERROR='NO'
C
IF(NUMARG.LE.0)GOTO9000
IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FONT')GOTO1110
IF(NUMARG.GE.2.AND.IHARG(2).EQ.'FONT')GOTO1140
GOTO9000
C
1110 CONTINUE
IF(NUMARG.LE.1)GOTO1120
IF(IHARG(2).EQ.'ON')GOTO1120
IF(IHARG(2).EQ.'OFF')GOTO1125
IF(IHARG(2).EQ.'AUTO')GOTO1127
IF(IHARG(2).EQ.'DEFA')GOTO1127
GOTO1128
C
1120 CONTINUE
IHOLD='SIMP'
GOTO1130
C
1125 CONTINUE
IHOLD='OFF'
GOTO1130
C
1127 CONTINUE
IHOLD=IDEFFN
GOTO1130
C
1128 CONTINUE
IHOLD=IHARG(NUMARG)
GOTO1130
C
1130 CONTINUE
IFOUND='YES'
DO1135I=1,NUMDEV
IDFONT(I)=IHOLD
1135 CONTINUE
C
IF(IFEEDB.EQ.'OFF')GOTO1139
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1136)IHOLD
1136 FORMAT('THE FONT FOR ALL DEVICES HAS JUST BEEN SET TO ',
1A4)
CALL DPWRST('XXX','BUG ')
1139 CONTINUE
GOTO9000
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 DPDEFT--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1142)
1142 FORMAT(' IN THE DEVICE ... FONT COMMAND,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1143)
1143 FORMAT(' THE DEVICE IS IDENTIFIED BY A NUMBER, AS IN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1144)
1144 FORMAT(' DEVICE 3 FONT TEKTRONIX')
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1150 CONTINUE
I=IARG(1)
IF(1.LE.I.AND.I.LE.MAXDEV)GOTO1160
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1151)
1151 FORMAT('***** ERROR IN DPDEFT--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1152)
1152 FORMAT(' IN THE DEVICE ... FONT COMMAND,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1153)
1153 FORMAT(' THE NUMBER OF DEVICES MUST BE ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1154)MAXDEV
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'DEVICE.')
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1160 CONTINUE
IF(NUMARG.LE.2)GOTO1170
IF(IHARG(3).EQ.'ON')GOTO1170
IF(IHARG(3).EQ.'OFF')GOTO1175
IF(IHARG(3).EQ.'AUTO')GOTO1177
IF(IHARG(3).EQ.'DEFA')GOTO1177
GOTO1178
C
1170 CONTINUE
IHOLD='SIMP'
GOTO1180
C
1175 CONTINUE
IHOLD='OFF'
GOTO1180
C
1177 CONTINUE
IHOLD=IDEFFN
GOTO1180
C
1178 CONTINUE
IHOLD=IHARG(NUMARG)
GOTO1180
C
1180 CONTINUE
IFOUND='YES'
IDFONT(I)=IHOLD
C
IF(IFEEDB.EQ.'OFF')GOTO1199
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1181)I
1181 FORMAT(' DEVICE --',I4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1182)IDUNIT(I)
1182 FORMAT(' I/O UNIT --',I4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1183)IDMANU(I)
1183 FORMAT(' MANUFACTURER --',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1184)IDMODE(I),IDMOD2(I),IDMOD3(I)
1184 FORMAT(' MODEL --',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1185)IDPOWE(I)
1185 FORMAT(' POWER --',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1186)IDCONT(I)
1186 FORMAT(' CONTINUITY --',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1187)IDCOLO(I)
1187 FORMAT(' COLOR --',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1188)IDNHPP(I)
1188 FORMAT(' HORIZONTAL PIXELS--',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1189)IDNVPP(I)
1189 FORMAT(' VERTICAL PIXELS--',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1191)IDFONT(I)
1191 FORMAT(' FONT --',A4)
CALL DPWRST('XXX','BUG ')
1199 CONTINUE
GOTO9000
C
9000 CONTINUE
RETURN
END
SUBROUTINE DPDEGR(IHARG,IARGT,IARG,NUMARG,IDEFDG,
1IDEG,IFOUND,IERROR)
C
C PURPOSE--DEFINE THE INTEGER DEGREE OF THE POLYNOMIAL
C FOR USE IN THE FIT, PRE-FIT, SPLINE FIT, AND SMOOTH COMMANDS.
C THE SPECIFIED DEGREE WILL BE PLACED
C IN THE FLOATING POINT VARIABLE IDEG.
C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR)
C --IARGT (A HOLLERITH VECTOR)
C --IARG (AN INTEGER VECTOR)
C --NUMARG (AN INTEGER VARIABLE)
C --IDEFDG (AN INTEGER VARIABLE)
C OUTPUT ARGUMENTS--IDEG (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
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(NUMARG.EQ.1.AND.IHARG(1).EQ.'DEGR')GOTO1150
IF(IHARG(NUMARG).EQ.'ON')GOTO1150
IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160
GOTO1120
C
1120 CONTINUE
IERROR='YES'
WRITE(ICOUT,1121)
1121 FORMAT('***** ERROR IN DPDEGR--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1122)
1122 FORMAT(' ILLEGAL FORM FOR DEGREE ',
1'COMMAND.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1124)
1124 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ',
1'PROPER FORM--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1125)
1125 FORMAT(' SUPPOSE THE THE ANALYST WISHES ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1126)
1126 FORMAT(' TO SET THE DEGREE = 3 ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1127)
1127 FORMAT(' FOR SOME SMOOTHING OR FITTING OPERATION,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1128)
1128 FORMAT(' THEN AN ALLOWABLE FORM IS--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1129)
1129 FORMAT(' DEGREE 3 ')
CALL DPWRST('XXX','BUG ')
GOTO1199
C
1150 CONTINUE
IHOLD=IDEFDG
GOTO1180
C
1160 CONTINUE
IHOLD=IARG(NUMARG)
GOTO1180
C
1180 CONTINUE
IFOUND='YES'
IDEG=IHOLD
C
IF(IFEEDB.EQ.'OFF')GOTO1189
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1181)IDEG
1181 FORMAT('THE POLYNOMIAL DEGREE HAS JUST BEEN SET TO ',
1I8)
CALL DPWRST('XXX','BUG ')
1189 CONTINUE
GOTO1199
C
1199 CONTINUE
RETURN
END
SUBROUTINE DPDEGP(Y,N,
1XTEMP,MAXNXT,
1GAMMA,A,SDG,THRESH,
1GAMMA2,ALOC,SCALE,
1IGEPDF,ICAPSW,ICAPTY,
1PPOTTO,
1ISUBRO,IBUGA3,IERROR)
C
C PURPOSE--THIS ROUTINE COMPUTES THE DEHAAN
C ESTIMATES FOR THE GENERALIZED PARETO DISTRIBUTION.
C THIS IS USED IN EXTREME VALUE APPLICATIONS.
C EXAMPLE--DEHAAN Y
C REFERENCE--DeHaan (1994). "Extreme Value Theory and
C Applications", Edited by Galambos, Lechner, and
C Simiu, Kluwer Academic Publishers, Boston,
C pp. 93-122.
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C INFORMATION TECHNOLOGY LABORATORY
C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C GAITHERSBURG, MD 20899-8980
C PHONE--301-975-2855
C NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C OF THE NATIONAL BUREAU OF STANDARDS.
C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C MODIFIED, OR OTHERWISE USED IN A CONTEXT
C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--98/5
C ORIGINAL VERSION--MAY 1998.
C UPDATED --APRIL 2005. NUMEROUS CORRECTIONS AND
C ENHANCEMENTS
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IGEPDF
CHARACTER*4 ICAPSW
CHARACTER*4 ICAPTY
CHARACTER*4 ISUBRO
CHARACTER*4 IBUGA3
CHARACTER*4 IERROR
C
CHARACTER*4 IWRITE
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
CHARACTER*8 ISIGN1
CHARACTER*8 ISIGN2
C
C---------------------------------------------------------------------
C
DOUBLE PRECISION DGAMMA
DOUBLE PRECISION DA
DOUBLE PRECISION DB
EXTERNAL DGAMMA
DIMENSION Y(*)
DIMENSION XTEMP(*)
C
C---------------------------------------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
DATA PI / 3.1415926535/
DATA MINSIZ / 5/
C
C-----START POINT-----------------------------------------------------
C
ISUBN1='DPDE'
ISUBN2='GP '
C
IERROR='NO'
C
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DEGP')THEN
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,51)
51 FORMAT('**** AT THE BEGINNING OF DPDEGP--')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,52)IBUGA3
52 FORMAT('IBUGA3 = ',A4)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,53)THRESH,MINSIZ
53 FORMAT('THRESH,MINSIZ = ',G15.7,I8)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,55)N,PPOTTO
55 FORMAT('N,PPOTTO = ',I8,2X,G15.7)
CALL DPWRST('XXX','WRIT')
DO56I=1,MAX(N,100)
WRITE(ICOUT,57)I,Y(I)
57 FORMAT('I,Y(I) = ',I8,G15.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.'DEGP')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(N.LT.MINSIZ)THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,1111)
1111 FORMAT('***** ERROR IN DEHAAN GENERALIZED PARETO ',
1 'ESTIMATION--')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,1112)
1112 FORMAT(' THE NUMBER OF OBSERVATIONS IS LESS THAN THE')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,1113)MINSIZ
1113 FORMAT(' MINIMUM REQUIRED OF ',I8)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,1114)N
1114 FORMAT('THE NUMBER OF OBSERVATIONS = ',I8)
CALL DPWRST('XXX','WRIT')
IERROR='YES'
GOTO9000
ENDIF
C
HOLD=Y(1)
DO1135I=2,N
IF(Y(I).NE.HOLD)GOTO1139
1135 CONTINUE
1130 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,1111)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,1133)HOLD
1133 FORMAT(' THE INPUT DATA HAS ALL ELEMENTS EQUAL TO ',G15.7)
CALL DPWRST('XXX','WRIT')
IERROR='YES'
GOTO9000
1139 CONTINUE
C
C ********************************************
C ** STEP 21-- **
C ** CARRY OUT CALCULATIONS **
C ** FOR DEHAAN ESTIMATE **
C ** SORT THE DATA **
C ** AND IDENTIFY POINTS ABOVE THE THRESHOLD*
C ********************************************
C
2100 CONTINUE
C
ISTEPN='21'
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DEGP')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CALL SORT(Y,N,Y)
EPS=0.0001
IF(THRESH.LE.0.0)THRESH=Y(1)-EPS
DO2110I=1,N
IF(Y(I).GT.THRESH)THEN
IFRST=I
GOTO2119
ENDIF
2110 CONTINUE
IFIRST=N+1
2119 CONTINUE
C
NUSE=N-IFRST+1
IF(NUSE.LT.2)THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,1111)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,2121)
2121 FORMAT(' NO POINTS ARE ABOVE THE THRESHOLD.')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,2123)THRESH
2123 FORMAT(' THRESHOLD = ',G15.7)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,2125)Y(N)
2125 FORMAT(' MAXIMUM DATA POINT = ',G15.7)
CALL DPWRST('XXX','WRIT')
IERROR='YES'
GOTO9000
ENDIF
C
IF(Y(IFRST).LT.0.0)THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,1111)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,2131)
2131 FORMAT(' NEGATIVE VALUES ENCOUNTERED IN THE INPUT ',
1 'DATA.')
CALL DPWRST('XXX','WRIT')
IERROR='YES'
GOTO9000
ENDIF
C
CALL DEHAAN(Y(IFRST),NUSE,GAMMA,SDG,KK,ANM1)
C
U=Y(IFRST)
IF(GAMMA.GE.0.0)THEN
RHO1=1.0
ELSE
RHO1=1.0/(1.0-GAMMA)
ENDIF
A=U*ANM1/RHO1
C
IWRITE='OFF'
CALL MEAN(Y(IFRST),NUSE,IWRITE,XMEAN,IBUGA3,IERROR)
CALL SD(Y(IFRST),NUSE,IWRITE,XSD,IBUGA3,IERROR)
IF(GAMMA.LT.-PPOTTO)THEN
GAMMA2=-1.0/GAMMA
DA=DGAMMA(DBLE((GAMMA2+1.0)/GAMMA2))
DB=DGAMMA(DBLE((GAMMA2+2.0)/GAMMA2)) - DA*DA
IF(DB.GT.0.0D0)THEN
SCALE=XSD/REAL(DSQRT(DB))
ALOC=XMEAN + SCALE*REAL(DA)
ELSE
SCALE=0.0
ALOC=0.0
ENDIF
ELSEIF(ABS(GAMMA).LE.PPOTTO)THEN
SCALE=XSD*SQRT(6.0)/PI
ALOC=XMEAN - 0.57722*SCALE
ELSE
ENDIF
C
C DEPENDING ON WHAT DEFINITION OF GENERALIZED PARETO PREFERRED,
C REVERSE SIGN OF GAMMA.
C
IF(IGEPDF.EQ.'SIMI')THEN
GAMMSV=GAMMA
ISIGN1='NEGATIVE'
ISIGN2='POSITIVE'
ELSE
GAMMSV=-GAMMA
ISIGN1='POSITIVE'
ISIGN2='NEGATIVE'
ENDIF
C
C *********************************
C ** STEP 42-- **
C ** WRITE OUT EVERYTHING **
C ** FOR DEHAAN ESTIMATE **
C *********************************
C
ISTEPN='42'
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DEGP')
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('')
5002 FORMAT('')
5003 FORMAT('DeHaan Parameter Estimation for the ',
1 'Generalized Pareto Distribution')
5004 FORMAT('')
5005 FORMAT('
')
WRITE(ICOUT,5001)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5002)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5003)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5004)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5005)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
C
C STEP 2: START TABLE AND DEFINE A CAPTION
C
5011 FORMAT('')
5013 FORMAT('')
WRITE(ICOUT,5011)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5013)
CALL DPWRST('XXX','WRIT')
C
C STEP 4: DEFINE DATA ROW
C
5041 FORMAT(' ')
5043 FORMAT(' | ')
5045 FORMAT(' Number of Observations:')
5061 FORMAT(' Threshold:')
5062 FORMAT(' Number of Observations Above the Threshold:')
5063 FORMAT(' Estimate of Shape Parameter Gamma:')
5064 FORMAT(' Standard Deviation of Gamma:')
5065 FORMAT(' Estimate of Scale Parameter A:')
5066 FORMAT(' For ',A8,' gamma, the generalized Pareto ',
1 'distribution is')
5067 FORMAT(' equivalent to a reverse Weibull (SET ',
1 'MINMAX MAX) with:')
5068 FORMAT(' Estimate of Location Parameter:')
5069 FORMAT(' Estimate of Scale Parameter:')
5070 FORMAT(' For gamma = zero, the generalized Pareto ',
1 'distribution is')
5071 FORMAT(' equivalent to a Gumbel distribution with:')
5047 FORMAT(' | ')
5049 FORMAT(' ')
5051 FORMAT(' ',G15.7)
5053 FORMAT(' ',I8)
5055 FORMAT(' ')
5059 FORMAT(' |
')
C
WRITE(ICOUT,5041)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5043)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5045)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5049)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5053)N
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5059)
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,5041)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5043)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5061)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5049)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5051)THRESH
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5059)
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,5041)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5043)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5062)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5049)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5053)NUSE
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5059)
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,5041)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5043)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5055)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5049)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5055)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5059)
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,5041)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5043)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5063)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5049)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5051)GAMMSV
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5059)
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,5041)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5043)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5064)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5049)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5051)SDG
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5059)
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,5041)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5043)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5065)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5049)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5051)A
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5059)
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,5041)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5043)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5055)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5049)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5055)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5059)
CALL DPWRST('XXX','WRIT')
C
IF(GAMMA.LT.-PPOTTO)THEN
C
WRITE(ICOUT,5041)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5043)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5066)ISIGN1
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5067)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5049)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5055)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5059)
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,5041)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5043)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5063)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5049)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5051)GAMMA2
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5059)
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,5041)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5043)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5068)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5049)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5051)ALOC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5059)
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,5041)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5043)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5069)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5049)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5051)SCALE
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5059)
CALL DPWRST('XXX','WRIT')
C
ELSEIF(ABS(GAMMA).LE.PPOTTO)THEN
C
WRITE(ICOUT,5041)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5043)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5070)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5071)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5049)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5055)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5059)
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,5041)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5043)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5068)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5049)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5051)ALOC
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5059)
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,5041)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5043)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5069)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5049)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5051)SCALE
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5047)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5059)
CALL DPWRST('XXX','WRIT')
C
ELSE
ENDIF
C
C STEP 4: END THE TABLE AND RESET ASIS MODE
C
5091 FORMAT('
')
5093 FORMAT('
')
5099 FORMAT('')
WRITE(ICOUT,5091)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5093)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5099)
CALL DPWRST('XXX','WRIT')
C
ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN
ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN
ELSE
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,4211)
4211 FORMAT(10X,'DEHAAN ESTIMATION FOR THE GENERALIZED PARETO ',
1 'DISTRIBUTION')
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,4242)N
4242 FORMAT('NUMBER OF OBSERVATIONS = ',I8)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,4250)THRESH
4250 FORMAT('THRESHOLD = ',G15.7)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,4252)NUSE
4252 FORMAT('NUMBER OF OBSERVATIONS ABOVE THE THRESHOLD = ',I8)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,4343)GAMMSV
4343 FORMAT('ESTIMATE OF SHAPE PARAMETER GAMMA = ',G15.7)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,4354)SDG
4354 FORMAT('STANDARD DEVIATION OF GAMMA = ',G15.7)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,4243)A
4243 FORMAT('SCALE PARAMETER A = ',G15.7)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
C
IF(GAMMA.LT.-PPOTTO)THEN
WRITE(ICOUT,4500)ISIGN1
4500 FORMAT('FOR ',A8,' GAMMA, THE GENERALIZED PARETO IS ',
1 'EQUIVALENT TO ')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,4501)
4501 FORMAT('A REVERSE WEIBULL (SET MINMAX MAX) WITH:')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,4502)GAMMA2
4502 FORMAT('SHAPE PARAMETER GAMMA = ',G15.7)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,4504)ALOC
4504 FORMAT('LOCATION PARAMETER = ',G15.7)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,4506)SCALE
4506 FORMAT('SCALE PARAMETER = ',G15.7)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
ELSEIF(ABS(GAMMA).LE.PPOTTO)THEN
WRITE(ICOUT,4600)
4600 FORMAT('FOR GAMMA = ZERO, THE GENERALIZED PARETO IS ',
1 'EQUIVALENT TO ')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,4602)
4602 FORMAT('AN EXTREME VALUE TYPE I (GUMBEL) WITH:')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,4604)ALOC
4604 FORMAT('LOCATION PARAMETER = ',G15.7)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,4606)SCALE
4606 FORMAT('SCALE PARAMETER = ',G15.7)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
ELSE
WRITE(ICOUT,4700)ISIGN2
4700 FORMAT('FOR ',A8,' GAMMA, THE GENERALIZED PARETO IS ',
1 'EQUIVALENT TO ')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,4702)
4702 FORMAT('A (MAXIMUM) EXTREME VALUE TYPE II (FRECHET)')
CALL DPWRST('XXX','WRIT')
ENDIF
C
ENDIF
ENDIF
C
IF(IFEEDB.EQ.'ON')THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4941)
4941 FORMAT('GAMMA, SDGAMMA, AND A WILL BE SAVED AS INTERNAL ',
1 'PARAMETERS.')
CALL DPWRST('XXX','BUG ')
IF(GAMMA.LT.-PPOTTO)THEN
WRITE(ICOUT,4951)
4951 FORMAT('THE REVERSE WEIBULL PARAMETERS WILL BE SAVED AS')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,4953)
4953 FORMAT('THE INTERNAL PARAMETERS GAMMA2, LOC, AND SCALE, ',
1 ' RESPECTIVELY.')
CALL DPWRST('XXX','WRIT')
ELSEIF(ABS(GAMMA).LE.PPOTTO)THEN
WRITE(ICOUT,4961)
4961 FORMAT('THE GUMBEL PARAMETERS WILL BE SAVED AS THE ',
1 'INTERNAL PARAMETERS LOC AND SCALE, RESPECTIVELY.')
CALL DPWRST('XXX','BUG ')
ENDIF
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
ENDIF
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'DEGP')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPDEGP--')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,9012)N,IBUGA3,IERROR
9012 FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,9015)N
9015 FORMAT('N = ',I8)
CALL DPWRST('XXX','WRIT')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPDEHA(IHARG,NUMARG,IDEFHA,
1IDEXHA,IFOUND,IERROR)
C
C PURPOSE--DEFINE THE DESIGN OF EXPERIMENT HORIZONTAL AXIS
C (FACTORS OR TERMS)
C (DEFAULT = FACTORS)
C --IHARG (A HOLLERITH VECTOR)
C INPUT ARGUMENTS--IHARG (A HOLLARITH VECTOR)
C --NUMARG
C --IDEFHA
C OUTPUT ARGUMENTS--IDEXHA (A HOLLERITH VARIABLE
C --IFOUND ('YES' OR 'NO' )
C --IERROR ('YES' OR 'NO' )
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-975-2855
C NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C OF THE NATIONAL BUREAU OF STANDARDS.
C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C MODIFIED, OR OTHERWISE USED IN A CONTEXT
C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--89/5
C ORIGINAL VERSION--MAY 1989.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IHARG
CHARACTER*4 IDEFHA
CHARACTER*4 IDEXHA
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 IHOLD
C
C---------------------------------------------------------------------
C
DIMENSION IHARG(*)
C
C---------------------------------------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
IFOUND='NO'
IERROR='NO'
C
IF(NUMARG.LE.1)GOTO1900
C
1100 CONTINUE
IF(NUMARG.EQ.2)GOTO1150
IF(IHARG(3).EQ.'ON')GOTO1150
IF(IHARG(3).EQ.'OFF')GOTO1150
IF(IHARG(3).EQ.'AUTO')GOTO1150
IF(IHARG(3).EQ.'DEFA')GOTO1150
GOTO1160
C
1150 CONTINUE
IHOLD=IDEFHA
GOTO1180
C
1160 CONTINUE
IHOLD=IHARG(NUMARG)
GOTO1180
C
1180 CONTINUE
IFOUND='YES'
IDEXHA=IHOLD
C
IF(IFEEDB.EQ.'OFF')GOTO1189
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1181)
1181 FORMAT('THE DESIGN OF EXPERIMENT HORIZONTAL AXIS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1182)IHOLD
1182 FORMAT('HAS JUST BEEN SET TO ',A4)
CALL DPWRST('XXX','BUG ')
1189 CONTINUE
GOTO1900
C
1199 CONTINUE
C
1900 CONTINUE
RETURN
END
SUBROUTINE DPDEHL(X,Y,Z,D,X2,Y2,NPLOTP,
1XEYE,YEYE,ZEYE,
1XOUT,YOUT,TAGOUT,NOUT,NTRACE,
1IBUGU2,ISUBRO,IERROR)
C
C PURPOSE--GIVEN THE VECTORS OF THE ALREADY-TRANSFORMED
C 3D-TO-2D DATA, DETERMINE WHERE THE
C HIDDEN LINES ARE AND REMOVE THEM--
C FORM UPDATED VECTORS CONTAINING ONLY THE
C VISIBLE LINES.
C METHOD USED = FLOATING HORIZON
C REFERENCE--ROGERS, DAVID F. (1985). PROCEDURAL
C ELEMENTS FOR COMPUTER GRAPHICS.
C MCGRAW-HILL, NEW YORK, PAGE 197-201.
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--88/9
C ORIGINAL VERSION--AUGUST 1988.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IBUGU2
CHARACTER*4 ISUBRO
CHARACTER*4 IERROR
CHARACTER*4 IWRITE
C
CHARACTER*4 IVIS
C
CCCCC CHARACTER*4 ICASEF
C
CHARACTER*4 ICNEAR
CHARACTER*4 IXCASE
CHARACTER*4 IYCASE
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CCCCC CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
DIMENSION Z(*)
DIMENSION X(*)
DIMENSION Y(*)
DIMENSION Y2(*)
DIMENSION X2(*)
DIMENSION D(*)
C
DIMENSION XOUT(*)
DIMENSION YOUT(*)
DIMENSION TAGOUT(*)
C
DIMENSION AUPPER(1000)
DIMENSION ALOWER(1000)
DIMENSION XHORIZ(1000)
C
DIMENSION XD(1000)
DIMENSION YD(1000)
C
DIMENSION XS(1000)
DIMENSION YS(1000)
DIMENSION IVIS(1000)
C
DIMENSION XTEMP(1000)
DIMENSION YTEMP(1000)
DIMENSION DTEMP(1000)
CCCCC FOLLOWING LINES ADDED MAY 1995
INCLUDE 'DPCOPA.INC'
INCLUDE 'DPCOZ2.INC'
EQUIVALENCE (G2RBAG(IGAR31),AUPPER(1))
EQUIVALENCE (G2RBAG(IGAR32),ALOWER(1))
EQUIVALENCE (G2RBAG(IGAR33),XHORIZ(1))
EQUIVALENCE (G2RBAG(IGAR34),XD(1))
EQUIVALENCE (G2RBAG(IGAR35),YD(1))
EQUIVALENCE (G2RBAG(IGAR36),XS(1))
EQUIVALENCE (G2RBAG(IGAR37),YS(1))
EQUIVALENCE (G2RBAG(IGAR38),XTEMP(1))
EQUIVALENCE (G2RBAG(IGAR39),YTEMP(1))
EQUIVALENCE (G2RBAG(IGAR40),DTEMP(1))
CCCCC END CHANGE
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='DPDE'
ISUBN2='HL '
C
NHORP=300
CCCCC NHORP=1000
C
IPASS=0
C
IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEHL')GOTO50
GOTO90
50 CONTINUE
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPDEHL--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IPASS
52 FORMAT('IPASS = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)IBUGU2,ISUBRO,IERROR
53 FORMAT('IBUGU2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)NPLOTP
54 FORMAT('NPLOTP = ',I8)
CALL DPWRST('XXX','BUG ')
DO55I=1,NPLOTP
WRITE(ICOUT,56)I,X(I),Y(I),Z(I),D(I),X2(I),Y2(I)
56 FORMAT('I,X(I),Y(I),Z(I),D(I),X2(I),Y2(I) = ',I8,6E13.4)
CALL DPWRST('XXX','BUG ')
55 CONTINUE
WRITE(ICOUT,61)XEYE,YEYE,ZEYE
61 FORMAT('XEYE,YEYE,ZEYE = ',3E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,71)NOUT,NTRACE
71 FORMAT('NOUT,NTRACE = ',2I8)
CALL DPWRST('XXX','BUG ')
IF(NOUT.LE.0)GOTO79
DO72I=1,NOUT
WRITE(ICOUT,73)I,XOUT(I),YOUT(I),TAGOUT(I)
73 FORMAT('I,XOUT(I),YOUT(I),TAGOUT(I) = ',I8)
CALL DPWRST('XXX','BUG ')
72 CONTINUE
79 CONTINUE
90 CONTINUE
C
C ******************************************
C ** STEP 11-- **
C ** DETERMINE WHICH OF THE 4 CORNERS-- **
C ** 1. (XMIN,YMIN) **
C ** 2. (XMAX,YMIN) **
C ** 3. (XMIN,YMAX) **
C ** 4. (XMAX,YMAX) **
C ** IS CLOSEST TO THE EYE POINT. **
C ******************************************
C
NX=NPLOTP
NY=NPLOTP
ND=NPLOTP
C
CALL DISTIN(X,NX,IWRITE,XD,NXD,IBUGU2,IERROR)
CALL DISTIN(Y,NY,IWRITE,YD,NYD,IBUGU2,IERROR)
C
XMIN=XD(1)
XMAX=XD(1)
DO1110I=1,NXD
IF(XD(I).LT.XMIN)XMIN=XD(I)
IF(XD(I).GT.XMAX)XMAX=XD(I)
1110 CONTINUE
C
YMIN=YD(1)
YMAX=YD(1)
DO1120I=1,NYD
IF(YD(I).LT.YMIN)YMIN=YD(I)
IF(YD(I).GT.YMAX)YMAX=YD(I)
1120 CONTINUE
C
XMIN2=(XMIN-XEYE)/(XMAX-XMIN)
YMIN2=(YMIN-YEYE)/(YMAX-YMIN)
XMAX2=(XMAX-XEYE)/(XMAX-XMIN)
YMAX2=(YMAX-YEYE)/(YMAX-YMIN)
ALEN1=XMIN2**2+YMIN2**2
ALEN2=XMAX2**2+YMIN2**2
ALEN3=XMIN2**2+YMAX2**2
ALEN4=XMAX2**2+YMAX2**2
C
IF(ALEN1.LE.ALEN2.AND.ALEN1.LE.ALEN3.AND.
1ALEN1.LE.ALEN4)GOTO1210
IF(ALEN2.LE.ALEN1.AND.ALEN2.LE.ALEN3.AND.
1ALEN2.LE.ALEN4)GOTO1220
IF(ALEN3.LE.ALEN1.AND.ALEN3.LE.ALEN2.AND.
1ALEN3.LE.ALEN4)GOTO1230
GOTO1240
C
1210 CONTINUE
ICNEAR='X1Y1'
IXCASE='SL'
IYCASE='SL'
GOTO1290
1220 CONTINUE
ICNEAR='X2Y1'
IXCASE='LS'
IYCASE='SL'
GOTO1290
1230 CONTINUE
ICNEAR='X1Y2'
IXCASE='SL'
IYCASE='LS'
GOTO1290
1240 CONTINUE
ICNEAR='X2Y2'
IXCASE='LS'
IYCASE='LS'
GOTO1290
1290 CONTINUE
C
C **************************************************
C ** STEP 12-- **
C ** DETERMINE THE ORDER IN WHICH THE X VALUES **
C ** WILL BE PROCESSED. **
C ** DETERMINE THE ORDER IN WHICH THE Y VALUES **
C ** WILL BE PROCESSED. **
C **************************************************
C
IF(IXCASE.EQ.'LS')CALL SORTDE(XD,NXD,XD)
IF(IYCASE.EQ.'LS')CALL SORTDE(YD,NYD,YD)
C
C **************************************************
C ** STEP 13-- **
C ** EXTRACT ALL DISTINCT SCREEN **
C ** HORIZONTAL VALUES. **
C ** SORT THEM LEFT TO RIGHT **
C ** (SMALLEST TO LARGEST).
C **************************************************
C
X2MIN=X2(1)
X2MAX=X2(1)
DO1300I=1,NPLOTP
IF(X2(I).LT.X2MIN)X2MIN=X2(I)
IF(X2(I).GT.X2MAX)X2MAX=X2(I)
1300 CONTINUE
C
C **************************************************
C ** STEP 21-- **
C ** FORM THE VISIBLE TRACES FOR THE Y SLICES-- **
C ** 1. LOOP THROUGH EACH Y TRACE; **
C ** 2. EXTRACT THE SCREEN HORIZONTAL AND **
C ** VERTICAL VALUES FOR A GIVEN SLICE; **
C ** 3. FORM THE OUTPUT VISIBLE TRACE FOR **
C ** A GIVEN SLICE. **
C **************************************************
C
ILOOP=0
DO2100IYD=1,NYD
YTARG=YD(IYD)
C
IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEHL')
1WRITE(ICOUT,2101)IYD,NYD,YTARG
2101 FORMAT('SEARCH FOR Y SLICE--IYD,NYD,YTARG = ',2I8,E15.7)
IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEHL')
1CALL DPWRST('XXX','BUG ')
C
ICOUNT=0
DO2110I=1,NPLOTP
IF(Y(I).EQ.YTARG)GOTO2120
GOTO2110
2120 CONTINUE
ICOUNT=ICOUNT+1
XTEMP(ICOUNT)=X2(I)
YTEMP(ICOUNT)=Y2(I)
DTEMP(ICOUNT)=D(I)
2110 CONTINUE
NTEMP=ICOUNT
C
DTARG=CPUMIN
CALL DPEXSS(XTEMP,YTEMP,DTEMP,NTEMP,DTARG,
1XS,YS,NS,DHIT,
1IBUGU2,ISUBRO,IERROR)
C
IF(NS.LE.1)GOTO2100
ILOOP=ILOOP+1
C
IF(IBUGU2.NE.'ON'.AND.ISUBRO.NE.'DEHL')GOTO2139
WRITE(ICOUT,2131)NS,ILOOP
2131 FORMAT('Y SLICE--NS,ILOOP = ',2I8)
CALL DPWRST('XXX','BUG ')
DO2132I=1,NS
WRITE(ICOUT,2133)I,XS(I),YS(I)
2133 FORMAT('Y SLICE--I,XS(I),YS(I) = ',I8,2E15.7)
CALL DPWRST('XXX','BUG ')
2132 CONTINUE
2139 CONTINUE
C
CALL DPDEH2(XS,YS,IVIS,NS,ILOOP,
1XHORIZ,AUPPER,ALOWER,NHORP,X2MIN,X2MAX,
1XOUT,YOUT,TAGOUT,NOUT,NTRACE,
1IBUGU2,ISUBRO,IERROR)
C
2100 CONTINUE
C
C **************************************************
C ** STEP 22-- **
C ** FORM THE VISIBLE TRACES FOR THE X SLICES-- **
C ** 1. LOOP THROUGH EACH X TRACE; **
C ** 2. EXTRACT THE SCREEN HORIZONTAL AND **
C ** VERTICAL VALUES FOR A GIVEN SLICE; **
C ** 3. FORM THE OUTPUT VISIBLE TRACE FOR **
C ** A GIVEN SLICE. **
C **************************************************
C
ILOOP=0
DO2200IXD=1,NXD
XTARG=XD(IXD)
IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEHL')
1WRITE(ICOUT,2201)IXD,NXD,XTARG
2201 FORMAT('SEARCH FOR X SLICE--IXD,NXD,XTARG = ',2I8,E15.7)
IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEHL')
1CALL DPWRST('XXX','BUG ')
C
ICOUNT=0
DO2210I=1,NPLOTP
IF(X(I).EQ.XTARG)GOTO2220
GOTO2210
2220 CONTINUE
ICOUNT=ICOUNT+1
XTEMP(ICOUNT)=X2(I)
YTEMP(ICOUNT)=Y2(I)
DTEMP(ICOUNT)=D(I)
2210 CONTINUE
NTEMP=ICOUNT
C
DTARG=CPUMIN
CALL DPEXSS(XTEMP,YTEMP,DTEMP,NTEMP,DTARG,
1XS,YS,NS,DHIT,
1IBUGU2,ISUBRO,IERROR)
C
IF(NS.LE.1)GOTO2200
ILOOP=ILOOP+1
C
IF(IBUGU2.NE.'ON'.AND.ISUBRO.NE.'DEHL')GOTO2239
WRITE(ICOUT,2231)NS,ILOOP
2231 FORMAT('X SLICE--NS,ILOOP = ',2I8)
CALL DPWRST('XXX','BUG ')
DO2232I=1,NS
WRITE(ICOUT,2233)I,XS(I),YS(I)
2233 FORMAT('X SLICE--I,XS(I),YS(I) = ',I8,2E15.7)
CALL DPWRST('XXX','BUG ')
2232 CONTINUE
2239 CONTINUE
C
CALL DPDEH2(XS,YS,IVIS,NS,ILOOP,
1XHORIZ,AUPPER,ALOWER,NHORP,X2MIN,X2MAX,
1XOUT,YOUT,TAGOUT,NOUT,NTRACE,
1IBUGU2,ISUBRO,IERROR)
C
2200 CONTINUE
C
C **************************************************
C ** STEP 90-- **
C ** EXIT. **
C **************************************************
C
9000 CONTINUE
IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEHL')GOTO9010
GOTO9090
9010 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPDEHL--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IPASS
9012 FORMAT('IPASS = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)IBUGU2,ISUBRO,IERROR
9013 FORMAT('IBUGU2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)NPLOTP
9014 FORMAT('NPLOTP = ',I8)
CALL DPWRST('XXX','BUG ')
DO9015I=1,NPLOTP
WRITE(ICOUT,9016)I,X(I),Y(I),Z(I),D(I),X2(I),Y2(I)
9016 FORMAT('I,X(I),Y(I),Z(I),D(I),X2(I),Y2(I) = ',I8,6E12.4)
CALL DPWRST('XXX','BUG ')
9015 CONTINUE
WRITE(ICOUT,9021)XEYE,YEYE,ZEYE
9021 FORMAT('XEYE,YEYE,ZEYE = ',3E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9022)XMIN,XMAX,YMIN,YMAX
9022 FORMAT('XMIN,XMAX,YMIN,YMAX = ',3E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9031)NOUT,NTRACE
9031 FORMAT('NOUT,NTRACE = ',2I8)
CALL DPWRST('XXX','BUG ')
IF(NOUT.LE.0)GOTO9039
DO9032I=1,NOUT
WRITE(ICOUT,9033)I,XOUT(I),YOUT(I),TAGOUT(I)
9033 FORMAT('I,XOUT(I),YOUT(I),TAGOUT(I) = ',I8,3E15.7)
CALL DPWRST('XXX','BUG ')
9032 CONTINUE
9039 CONTINUE
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPDEH2(XS,YS,IVIS,NS,ILOOP,
1XHORIZ,AUPPER,ALOWER,NHORP,X2MIN,X2MAX,
1XOUT,YOUT,TAGOUT,NOUT,NTRACE,
1IBUGU2,ISUBRO,IERROR)
C
C PURPOSE--GIVEN THE SCREEN COORDINATES OF A TRACE,
C AND THE CURRENT HORIZON TABLE,
C DETERMINE WHAT PART OF THE INPUT TRACE
C IS VISIBLE, AND
C FORM THE APPROPRIATE VISIBLE OUTPUT TRACE.
C METHOD USED = FLOATING HORIZON
C REFERENCE--ROGERS, DAVID F. (1985). PROCEDURAL
C ELEMENTS FOR COMPUTER GRAPHICS.
C MCGRAW-HILL, NEW YORK, PAGE 197-201.
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--88/10
C ORIGINAL VERSION--SEPTEMBER 1988.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IVIS
C
CHARACTER*4 IBUGU2
CHARACTER*4 ISUBRO
CHARACTER*4 IERROR
C
CHARACTER*4 ICASEF
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
DIMENSION XS(1000)
DIMENSION YS(1000)
DIMENSION IVIS(1000)
C
DIMENSION XHORIZ(1000)
DIMENSION AUPPER(1000)
DIMENSION ALOWER(1000)
C
DIMENSION XOUT(*)
DIMENSION YOUT(*)
DIMENSION TAGOUT(*)
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
C
ISUBN1='DPDE'
ISUBN2='H2 '
C
IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')GOTO50
GOTO90
50 CONTINUE
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPDEH2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBUGU2,ISUBRO,IERROR
52 FORMAT('IBUGU2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,55)NS,ILOOP
55 FORMAT('NS,ILOOP = ',2I8)
CALL DPWRST('XXX','BUG ')
DO56I=1,NS
WRITE(ICOUT,57)I,XS(I),YS(I),IVIS(I)
57 FORMAT('I,XS(I),YS(I),IVIS(I) = ',I8,2E15.7,2X,A4)
CALL DPWRST('XXX','BUG ')
56 CONTINUE
WRITE(ICOUT,61)NHORP,X2MIN,X2MAX
61 FORMAT('NHORP,X2MIN,X2MAX = ',I8,2E15.7)
CALL DPWRST('XXX','BUG ')
DO62I=1,NHORP
WRITE(ICOUT,63)I,XHORIZ(I),AUPPER(I),ALOWER(I)
63 FORMAT('I,XHORIZ(I),AUPPER(I),ALOWER(I) = ',I8,3E15.7)
CALL DPWRST('XXX','BUG ')
62 CONTINUE
WRITE(ICOUT,71)NOUT,NTRACE
71 FORMAT('NOUT,NTRACE = ',2I8)
CALL DPWRST('XXX','BUG ')
DO72I=1,NOUT
WRITE(ICOUT,73)I,XOUT(I),YOUT(I),TAGOUT(I)
73 FORMAT('I,XOUT(I),YOUT(I),TAGOUT(I) = ',I8,3E15.7)
CALL DPWRST('XXX','BUG ')
72 CONTINUE
90 CONTINUE
C
C **************************************************
C ** STEP 21-- **
C ** SORT THE INPUT TRACE **
C ** BY THE HORIZONTAL AXIS SCREEN VALUES, AND **
C ** CARRY ALONG THE VERTICAL AXIS SCREEN VALUES.**
C **************************************************
C
CALL SORTC(XS,YS,NS,XS,YS)
C
IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')GOTO2180
GOTO2189
2180 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2181)
2181 FORMAT('***** FROM THE MIDDLE OF DPDEH2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2182)ILOOP
2182 FORMAT(' AFTER THE SORT OF NEW SLICE # ',I8)
CALL DPWRST('XXX','BUG ')
DO2185I=1,NS
WRITE(ICOUT,2186)I,XS(I),YS(I)
2186 FORMAT('I,XS(I),YS(I) = ',I8,3E15.7)
CALL DPWRST('XXX','BUG ')
2185 CONTINUE
2189 CONTINUE
C
C **************************************************
C ** STEP 22-- **
C ** BRANCH DEPENDING ON WHETHER THIS IS SLICE 1 **
C ** (THE NEAREST SLICE), OR **
C ** WHETHER IT IS A MORE DISTANT SLICE. **
C **************************************************
C
IF(ILOOP.EQ.1)GOTO3000
GOTO4000
C
C **************************************************
C ** STEP 30-- **
C ----------** TREAT THE FIRST (= NEAR) SLICE SUBCASE. **----------
C **************************************************
C
3000 CONTINUE
ISTEPN='30'
IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C **************************************************
C ** STEP 31-- **
C ** FOR THE FIRST (= NEAR) SLICE SUBCASE **
C ** INITIALIZE THE HORIZON ARRAYS. **
C **************************************************
C
DO3110I=1,NHORP
AUPPER(I)=CPUMIN
ALOWER(I)=CPUMAX
3110 CONTINUE
C
ANHORP=NHORP
DO3120I=1,NHORP
AI=I
P=(AI-1.0)/(ANHORP-1.0)
XHORIZ(I)=X2MIN+P*(X2MAX-X2MIN)
3120 CONTINUE
C
C **************************************************
C ** STEP 32-- **
C ** FOR THE FIRST (= NEAR) SLICE SUBCASE **
C ** FORM THE OUTPUT DRAW VECTOR. **
C **************************************************
C
NTRACE=NTRACE+1
DO3200I=1,NS
NOUT=NOUT+1
XOUT(NOUT)=XS(I)
YOUT(NOUT)=YS(I)
TAGOUT(NOUT)=NTRACE
3200 CONTINUE
C
C **************************************************
C ** STEP 33-- **
C ** FOR THE FIRST (= NEAR) SLICE SUBCASE, **
C ** FILL THE UPPER HORIZON TABLES DIRECTLY **
C **************************************************
C
DO3300I=1,NS
CALL HORIND(XS(I),X2MIN,X2MAX,1,NHORP,I2,IBUGU2,ISUBRO,IERROR)
IF(YS(I).GT.AUPPER(I2))AUPPER(I2)=YS(I)
CCCCC IF(YS(I).LT.ALOWER(I2))ALOWER(I2)=YS(I)
3300 CONTINUE
C
C **************************************************
C ** STEP 34-- **
C ** FOR THE FIRST (= NEAR) SLICE SUBCASE, **
C ** FILL THE LOWER HORIZON TABLES WITH THE **
C ** GLOBAL MIN FOR THIS FIRST SLICE. **
C ** "PAINTED WALL" **
C **************************************************
C
Y3MIN=YS(1)
DO3410I=1,NS
IF(YS(I).LT.Y3MIN)Y3MIN=YS(I)
3410 CONTINUE
CCCCC DO3420I=1,NS
DO3420I=1,NHORP
CCCCC CALL HORIND(XS(I),X2MIN,X2MAX,1,NHORP,I2,IBUGU2,ISUBRO,IERROR)
I2=I
IF(Y3MIN.LT.ALOWER(I2))ALOWER(I2)=Y3MIN
3420 CONTINUE
C
C **************************************************
C ** STEP 35-- **
C ** FOR THE FIRST (= NEAR) SLICE SUBCASE, **
C ** FILL IN (INTERPOLATE) THE HORIZON TABLES **
C ** (IF NEEDED). **
C **************************************************
C
I=1
CALL HORIND(XS(I),X2MIN,X2MAX,1,NHORP,IPREV,IBUGU2,ISUBRO,IERROR)
DO3500I=2,NS
CALL HORIND(XS(I),X2MIN,X2MAX,1,NHORP,ICUR,IBUGU2,ISUBRO,IERROR)
IDEL=ICUR-IPREV
ICASEF='BOTH'
IF(IDEL.GE.2)
1CALL FILLHT(IPREV,ICUR,AUPPER,ALOWER,XHORIZ,NHORP,ICASEF,
1IBUGU2,ISUBRO,IERROR)
IPREV=ICUR
3500 CONTINUE
C
GOTO9000
C
C ******************************************************
C ** STEP 40-- **
C ----------** TREAT THE OTHER (= FARTHER AWAY) SLICE SUBCASE **----------
C ******************************************************
C
4000 CONTINUE
ISTEPN='40'
IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C *****************************************************
C ** STEP 41-- **
C ** FOR THE OTHER (= FARTHER AWAY) SLICE SUBCASE, **
C ** DETERMINE VISIBILITY. **
C *****************************************************
C
DO4100I=1,NS
CALL HORIND(XS(I),X2MIN,X2MAX,1,NHORP,I2,IBUGU2,ISUBRO,IERROR)
IVIS(I)='YES'
IF(YS(I).LT.AUPPER(I2).AND.YS(I).GT.ALOWER(I2))IVIS(I)='NO'
IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')
1WRITE(ICOUT,4111)I,YS(I),IVIS(I),I2,ALOWER(I2),AUPPER(I2)
4111 FORMAT('I,YS(I),IVIS(I),I2,ALOWER(I2),AUPPER(I2) = ',
1I8,E15.7,2X,A4,I8,2E15.7)
IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')
1CALL DPWRST('XXX','BUG ')
4100 CONTINUE
C
C *****************************************************
C ** STEP 42-- **
C ** FOR THE OTHER (= FARTHER AWAY) SLICE SUBCASE, **
C ** FORM THE OUTPUT DRAW VECTOR, **
C ** FILL THE HORIZON TABLES, **
C ** FILL IN THE HORIZON TABLES (IF NEEDED) **
C *****************************************************
C
DO4200I=1,NS
C
IF(I.EQ.1)GOTO4210
GOTO4220
C
4210 CONTINUE
CALL HORIND(XS(I),X2MIN,X2MAX,1,NHORP,ICHORI,IBUGU2,ISUBRO,IERROR)
IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')
1WRITE(ICOUT,777)I,YS(I),IVIS(I),I2,ALOWER(I2),AUPPER(I2)
777 FORMAT('I,YS(I),IVIS(I),I2,ALOWER(I2),AUPPER(I2) = ',
1I8,E15.7,2X,A4,I8,2E15.7)
IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')
1CALL DPWRST('XXX','BUG ')
IF(IVIS(I).EQ.'YES')GOTO4211
GOTO4219
4211 CONTINUE
NTRACE=NTRACE+1
NOUT=NOUT+1
XOUT(NOUT)=XS(I)
YOUT(NOUT)=YS(I)
TAGOUT(NOUT)=NTRACE
4219 CONTINUE
IPHORI=ICHORI
GOTO4200
C
4220 CONTINUE
IP=I-1
IC=I
CALL HORIND(XS(I),X2MIN,X2MAX,1,NHORP,ICHORI,IBUGU2,ISUBRO,IERROR)
IPASS=IPASS+1
IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')WRITE(ICOUT,4221)
CCCCC1IPASS,ILOOP,I,IP,YTARG,XS(IP)
1IPASS,ILOOP,I,IP,XS(IP)
4221 FORMAT('FROM DPDEH2, BEFORE CALL TO DPDETR--',
CCCCC1'IPASS,ILOOP,I,IP,YTARG,XS(IP) = ',4I8,2E15.7)
1'IPASS,ILOOP,I,IP,XS(IP) = ',4I8,2E15.7)
IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')CALL DPWRST('XXX','BUG ')
IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')WRITE(ICOUT,4222)
1I,IP,IC,IVIS(IP),IVIS(IC)
4222 FORMAT('I,IP,IC,IVIS(IP),IVIS(IC) = ',3I8,2X,A4,2X,A4)
IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')CALL DPWRST('XXX','BUG ')
CALL DPDETR(IP,IC,XS,YS,IVIS,NS,
1IPHORI,ICHORI,AUPPER,ALOWER,XHORIZ,NHORP,
1X2MIN,X2MAX,IPASS,
1XOUT,YOUT,TAGOUT,NOUT,NTRACE,
1IBUGU2,ISUBRO,IERROR)
IPHORI=ICHORI
C
4200 CONTINUE
C
GOTO9000
C
C **************************************************
C ** STEP 90-- **
C ** EXIT. **
C **************************************************
C
9000 CONTINUE
C
IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')GOTO9010
GOTO9090
9010 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPDEH2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGU2,ISUBRO,IERROR
9012 FORMAT('IBUGU2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)NS,ILOOP
9015 FORMAT('NS,ILOOP = ',2I8)
CALL DPWRST('XXX','BUG ')
DO9016I=1,NS
WRITE(ICOUT,9017)I,XS(I),YS(I),IVIS(I)
9017 FORMAT('I,XS(I),YS(I),IVIS(I) = ',I8,2E15.7,2X,A4)
CALL DPWRST('XXX','BUG ')
9016 CONTINUE
WRITE(ICOUT,9021)NHORP,X2MIN,X2MAX
9021 FORMAT('NHORP,X2MIN,X2MAX = ',I8,2E15.7)
CALL DPWRST('XXX','BUG ')
DO9022I=1,NHORP
WRITE(ICOUT,9023)I,XHORIZ(I),AUPPER(I),ALOWER(I)
9023 FORMAT('I,XHORIZ(I),AUPPER(I),ALOWER(I) = ',I8,3E15.7)
CALL DPWRST('XXX','BUG ')
9022 CONTINUE
WRITE(ICOUT,9024)IPHORI,ICHORI
9024 FORMAT('IPHORI,ICHORI = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9031)NOUT,NTRACE
9031 FORMAT('NOUT,NTRACE = ',2I8)
CALL DPWRST('XXX','BUG ')
DO9032I=1,NOUT
WRITE(ICOUT,9033)I,XOUT(I),YOUT(I),TAGOUT(I)
9033 FORMAT('I,XOUT(I),YOUT(I),TAGOUT(I) = ',I8,3E15.7)
CALL DPWRST('XXX','BUG ')
9032 CONTINUE
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPDELE(IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR)
CCCCC SUBROUTINE DPDELE(IBUGS2,IBUGQ,IFOUND,IERROR)
CCCCC THE THIRD ARGUMENT (ISUBRO) ABOVE WAS ADDED SEPTEMBER 1995
C
C PURPOSE--TREAT THE DELETE CASE--
C DELETE SPECIFIED ELEMENTS OF A VARIABLE
C AND PACK THE REMAINING ELEMENTS
C INTO THE FIRST AVAILABLE LOCATIONS;
C REDEFINE THE LENGTH OF THE PACKED VARIABLE.
C INPUT --NECESSARILY A VARIABLE.
C OUTPUT--NECESSARILY A VARIABLE.
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--MARCH 1978.
C UPDATED --MAY 1978.
C UPDATED --JUNE 1978.
C UPDATED --JULY 1978.
C UPDATED --NOVEMBER 1978.
C UPDATED --NOVEMBER 1980.
C UPDATED --JANUARY 1981.
C UPDATED --AUGUST 1981.
C UPDATED --OCTOBER 1981.
C UPDATED --DECEMBER 1981.
C UPDATED --MARCH 1982.
C UPDATED --MAY 1982.
C UPDATED --OCTOBER 1993. ADD DELETE MATRIX.
C UPDATED --FEBRUARY 1994. EQUIVALENCE TO GARBAGE COMMON
C UPDATED --DECEMBER 1994. SUPP. ERROR MESS. IF NOT EXIST
C UPDATED --SEPTEMBER 1995. ALLOW DELETE Y7 TO Y15
C UPDATED --OCTOBER 1997. REINITIALIZE DELETED VALUES TO
C 0 INSTEAD OF CPUMIN.
C UPDATED --JANUARY 2000. SUPPORT FOR VARIABLE LABELS
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IBUGS2
CHARACTER*4 IBUGQ
CCCCC THE FOLLOWING LINE WAS ADDED SEPTEBMER 1995
CHARACTER*4 ISUBRO
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 ICASEQ
CHARACTER*4 ISTRIN
CHARACTER*4 ISTRI2
CHARACTER*4 INEX
CHARACTER*4 IHWUSE
CHARACTER*4 MESSAG
CHARACTER*4 IFOUCO
CHARACTER*4 IFOULP
CHARACTER*4 IFOURP
CHARACTER*4 IFOURN
CHARACTER*4 IFOUVN
CHARACTER*4 IHVARJ
CHARACTER*4 IHVRJ2
CHARACTER*4 IVN
CHARACTER*4 IVN2
CHARACTER*4 IHSET
CHARACTER*4 IHSET2
CHARACTER*4 IERRO1
CHARACTER*4 ITYPCO
CHARACTER*4 IHOLCO
CHARACTER*4 IHLCO2
CHARACTER*4 ITYPLP
CHARACTER*4 IHOLLP
CHARACTER*4 IHLLP2
CHARACTER*4 ITYPRP
CHARACTER*4 IHOLRP
CHARACTER*4 IHLRP2
CHARACTER*4 ITYPRN
CHARACTER*4 IHOLRN
CHARACTER*4 IHLRN2
CHARACTER*4 ITYPVN
CHARACTER*4 IHOLVN
CHARACTER*4 IHLVN2
C
CCCCC THE FOLLOWING 16 LINES WERE ADDED SEPTEMBER 1995
CHARACTER*4 IH1
CHARACTER*4 IH2
CHARACTER*4 ICASTO
CHARACTER*4 IECASE
C
CHARACTER*4 JVNAM1
CHARACTER*4 JPNAM1
CHARACTER*4 JMNAM1
CHARACTER*4 JFNAM1
CHARACTER*4 JUNAM1
CHARACTER*4 JENAM1
C
CHARACTER*4 JVNAM2
CHARACTER*4 JPNAM2
CHARACTER*4 JMNAM2
CHARACTER*4 JFNAM2
CHARACTER*4 JUNAM2
CHARACTER*4 JENAM2
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
CCCCC APRIL 1996. ADD FOLLOWING LINE
CHARACTER*4 ICASEA
C
C---------------------------------------------------------------------
C
INCLUDE 'DPCOPA.INC'
C
DIMENSION ILISTV(100)
DIMENSION TEMP(MAXOBV)
C
DIMENSION IVN(100)
DIMENSION IVN2(100)
DIMENSION IRN(100)
CCCCC FOLLOWING LINES ADDED FEBRUARY, 1994
CCCCC INCLUDE 'DPCOZ2.INC'
CCCCC EQUIVALENCE (G2RBAG(IGAR11),TEMP(1))
CCCCC END CHANGE
C
CCCCC THE FOLLOWING 13 LINES WERE ADDED SEPTEMBER 1995
DIMENSION JVNAM1(100)
DIMENSION JPNAM1(100)
DIMENSION JMNAM1(100)
DIMENSION JFNAM1(100)
DIMENSION JUNAM1(100)
DIMENSION JENAM1(100)
C
DIMENSION JVNAM2(100)
DIMENSION JPNAM2(100)
DIMENSION JMNAM2(100)
DIMENSION JFNAM2(100)
DIMENSION JUNAM2(100)
DIMENSION JENAM2(100)
C
DIMENSION NIV(100)
C
CCCCC DIMENSION IEN(100)
DIMENSION IECOL2(100)
DIMENSION IECASE(100)
DIMENSION PVAL(100)
DIMENSION IFSTA2(100)
DIMENSION IFSTO2(100)
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCOHK.INC'
INCLUDE 'DPCODA.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
ISUBN1='DPDE'
ISUBN2='LE '
C
IPASS=0
NUMDEL=0
ISAVE=0
IROD1O=0
IRODNO=0
IROW1O=0
IROWNO=0
ILQP1=0
C
TEMPD=0.0
VALD1O=0.0
VALDNO=0.0
VAL1O=0.0
VALNO=0.0
CCCCC FEBRUARY 1993. ADD FOLLOWING INITIALIZATION
DO30I=1,100
ILISTV(I)=0
30 CONTINUE
C
C *************************************************
C ** TREAT THE DELETE CASE **
C ** DELETE SPECIFIC ELEMENTS OF A VECTOR **
C ** AND PACK REMAINING ELEMENTS **
C ** INTO THE FIRST AVAILABLE LOCATIONS. **
C *************************************************
C
IFOUND='YES'
IERROR='NO'
C
MAXDEL=100
MAXCP1=MAXCOL+1
MAXCP2=MAXCOL+2
MAXCP3=MAXCOL+3
MAXCP4=MAXCOL+4
MAXCP5=MAXCOL+5
MAXCP6=MAXCOL+6
C
CCCCC THE FOLLOWING 6 LINES WERE ADDED SEPTEMBER 1995
MAXV2=100
MAXP2=100
MAXM2=100
MAXF2=100
MAXU2=100
MAXE2=100
C
IF(IBUGS2.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPDELE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBUGS2,IERROR
52 FORMAT('IBUGS2,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)MAXNAM,NUMNAM
53 FORMAT('MAXNAM,NUMNAM = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)MAXN,MAXCOL,NUMCOL
54 FORMAT('MAXN,MAXCOL,NUMCOL = ',3I8)
CALL DPWRST('XXX','BUG ')
DO60I=1,NUMNAM
WRITE(ICOUT,61)I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I)
61 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) = ',
1I8,2X,A4,A4,2X,A4,I8,E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,62)I,IHNAME(I),IHNAM2(I),IN(I),IVSTAR(I),IVSTOP(I)
62 FORMAT('I,IHNAME(I),IHNAM2(I),IN(I),IVSTAR(I),IVSTOP(I) = ',
1I8,2X,A4,A4,6X,I8,I8,I8)
CALL DPWRST('XXX','BUG ')
60 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
DO70J=1,NUMCOL
IJ=MAXN*(J-1)+1
WRITE(ICOUT,71)J,MAXN,IJ,V(IJ)
71 FORMAT('J,MAXN,IJ,V(IJ) = ',I8,I8,I8,E15.7)
CALL DPWRST('XXX','BUG ')
70 CONTINUE
90 CONTINUE
C *******************************************************
C ** STEP 1-- **
C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. **
C *******************************************************
C
ISTEPN='1'
IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(NUMARG.GE.1)GOTO190
IERROR='YES'
GOTO8900
190 CONTINUE
IFOUND='YES'
C
C ***********************************************************
C ** STEP 2-- **
C ** DETERMINE THE SUBCASE BASED ON THE QUALIFIER. **
C ** SCAN TO CHECK IF 'SUBSET' OR 'FOR' IS PRESENT. **
C ** IF NOT PRESENT, THEN HAVE CASE 1-- **
C ** EXAMPLE--DELETE X(4) Y(1) Z(46) **
C ** IF PRESENT, THEN HAVE CASE 2-- **
C ** EXAMPLE--DELETE X Y Z FOR I = 1 1 10 **
C ** DETERMINE THE LOCATION IN THE ARGUMENT LIST **
C ** OF 'SUBSET' OR 'FOR'. **
C ** BRANCH TO THE APPROPRIATE SUBCASE **
C ** FULL VERSUS SUBSET/FOR. **
C ***********************************************************
C
ISTEPN='2'
IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ILOCQ=1
ICASEQ='UNKN'
IF(NUMARG.LE.0)GOTO290
DO210J=1,NUMARG
J2=J
IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO220
IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO220
IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO230
210 CONTINUE
ICASEQ='FULL'
ILOCQ=NUMARG+1
CCCCC THE FOLLOWING LINE WAS FIXED SEPTEBMER 1995
CCCCC GOTO300
GOTO290
C
220 CONTINUE
ICASEQ='SUBS'
ILOCQ=J2
CCCCC THE FOLLOWING LINE WAS FIXED SEPTEBMER 1995
CCCCC GOTO7000
GOTO290
C
230 CONTINUE
ICASEQ='FOR'
ILOCQ=J2
CCCCC THE FOLLOWING LINE WAS FIXED SEPTEBMER 1995
CCCCC GOTO7000
GOTO290
C
290 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1995
CCCCC TO ALLOW COMMANDS SUCH AS DELETE Y1 TO Y10 SEPTEMBER 1995
C ****************************************************************
C ** STEP 2.5--
C ** TREAT THE TO KEYWORD CASE
C ** AS IN DELETE Y1 TO Y10
C ** EXPAND SUCH LINES LITERALLY.
C **
C ** DETERMINE THE TYPE AND NUMBER OF ITEMS
C ** TO BE DELETED .
C ** NUMALL = TOTAL NUMBER OF DELETED ITEMS
C ** (AS DETERMINED BY INCLUDING ONLY ALL BEFORE
C ** 'SUBSET' OR 'EXCEPT' OR 'FOR')
C ** NUMV = NUMBER OF VARIABLES TO BE DELETED ;
C ** NUMP = NUMBER OF PARAMETERS TO BE DELETED ;
C ** NUMM = NUMBER OF MODELS TO BE DELETED (SHOULD = 0 OR 1)
C ** NUMF = NUMBER OF FUNCTIONS TO BE DELETED
C ** NUMU = NUMBER OF UNKNOWNS TO BE DELETED ;
C ** NUME = TOTAL NUMBER OF DELETED ITEMS (SHOULD = NUMALL);
C ****************************************************************
C
ISTEPN='4'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'DELE')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IV=0
IP=0
IM=0
IF=0
IU=0
IE=0
C
JMIN=1
JMAX=ILOCQ-1
C
IVALMA=0
NUMALL=0
NUMALL=JMAX-JMIN+1
IF(JMIN.GT.JMAX)GOTO4290
DO4200J=JMIN,JMAX
IH1=IHARG(J)
IH2=IHARG2(J)
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
C
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
NIV(IV)=IN(I2)
GOTO4370
C
4320 CONTINUE
ICASEA='P'
IP=IP+1
IF(IP.GT.MAXP2)GOTO4370
JPNAM1(IP)=IH1
JPNAM2(IP)=IH2
PVAL(IP)=VALUE(I2)
GOTO4370
C
4330 CONTINUE
ICASEA='M'
IM=IM+1
IF(IM.GT.MAXM2)GOTO4370
JMNAM1(IM)=IH1
JMNAM2(IM)=IH2
GOTO4370
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)
GOTO4370
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)
IF(ICASEA.EQ.'P')IECASE(IE)='OLD'
IF(ICASEA.EQ.'F')IECASE(IE)='OLD'
GOTO4280
C
4380 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4381)
4381 FORMAT('***** ERROR IN DPDELE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4382)
4382 FORMAT(' THE NUMBER OF NAMES IN THE DELETE 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'
GOTO9000
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.'OFF'.AND.ISUBRO.NE.'DELE')GOTO4429
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),
1JMNAM1(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),
1JMNAM1(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
4429 CONTINUE
C
IF(ICASEQ.EQ.'FULL')GOTO300
IF(ICASEQ.EQ.'SUBS')GOTO7000
IF(ICASEQ.EQ.'FOR')GOTO7000
GOTO300
C
C ***********************************************************
C ** STEP 3-- **
C ** FOR THE FULL CASE, **
C ** EXTRACT EACH VARIABLE NAME AND EACH ARGUMENT VALUE. **
C ***********************************************************
C
300 CONTINUE
ISTEPN='3'
IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IPASS=0
IPASS=IPASS+1
C
IF(1.LE.IPASS.AND.IPASS.LE.MAXDEL)GOTO310
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,301)
301 FORMAT('***** ERROR IN DPDELE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,302)
302 FORMAT(' THE DELETE COMMAND REQUIRES THAT ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,303)
303 FORMAT(' THE NUMBER OF VARIABLES WITH ELEMENTS ',
1'TO BE DELETED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,304)IPASS
304 FORMAT(' BE BETWEEN 1 AND ',I8,' (INCLUSIVE);')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,305)NUMDEL
305 FORMAT(' THE SPECIFIED NUMBER WAS ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,306)
306 FORMAT(' THE INPUT COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,307)(IANS(I),I=1,IWIDTH)
307 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO8900
C
310 CONTINUE
IF(IPASS.GE.2)ISAVE=IENDRP
C
C ****************************************************************
C ** STEP 3.1--
C ** IF THIS IS THE FIRST PASS ON THIS LINE (AND ONLY FOR PASS 1)
C ** SEARCH FOR DELETE (OTHERWISE SKIP THIS STEP)
C ** SEARCH BETWEEN COLUMN 1 AND THE END OF THE LINE (INCLUSIVE).
C ****************************************************************
C
ISTEPN='3.1'
IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IPASS.GE.2)GOTO319
C
ISTAR1=1
ISTOP1=IWIDTH
ISTRIN='DELE'
ISTRI2='TE '
INEX='II'
CALL DPTY3B(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGS2,
1 IFOUCO,IBEGCO,IENDCO,
1 ITYPCO,IHOLCO,IHLCO2,INT1CO,FLOACO,IERRO1)
IF(IFOUCO.EQ.'YES')GOTO319
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,311)
311 FORMAT('***** INTERNAL ERROR IN DPDELE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,312)
312 FORMAT(' THE WORD DELETE NOT FOUND')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,313)
313 FORMAT(' ON THE ENTERED INPUT COMMAND LINE.')
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(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO8900
C
319 CONTINUE
C
C ****************************************************************
C ** STEP 3.2--
C ** SEARCH FOR LEFT PARENTHESIS;
C ** IF THIS IS THE FIRST PASS FOR THIS LINE,
C ** SEARCH BETWEEN DELETE AND END OF LINE
C ** (IF NO LEFT PARENTHESIS FOUND AT ALL, JUMP TO 7000).
C ** IF THIS IS THE SECOND (OR HIGHER) PASS FOR THIS LINE,
C ** SEARCH BETWEEN PREVIOUS RIGHT PARENTHESIS AND
C ** END OF LINE.
C ****************************************************************
C
ISTEPN='3.2'
IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IPASS.LE.1)ISTAR1=IENDCO+1
IF(IPASS.GE.2)ISTAR1=ISAVE+1
ISTOP1=IWIDTH
ISTRIN='('
INEX='II'
CALL DPTY3B(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGS2,
1 IFOULP,IBEGLP,IENDLP,
1 ITYPLP,IHOLLP,IHLLP2,INT1LP,FLOALP,IERRO1)
IF(IFOULP.EQ.'YES')GOTO338
IF(IFOULP.EQ.'NO'.AND.IPASS.GE.2)GOTO399
GOTO7000
338 CONTINUE
C
C ****************************************************************
C ** STEP 3.3--
C ** SEARCH FOR RIGHT PARENTHESIS;
C ** SEARCH BETWEEN LEFT PARENTHESIS AND END OF LINE.
C ****************************************************************
C
ISTEPN='3.3'
IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ISTAR1=IENDLP+1
ISTOP1=IWIDTH
ISTRIN=')'
INEX='II'
CALL DPTY3B(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGS2,
1 IFOURP,IBEGRP,IENDRP,
1 ITYPRP,IHOLRP,IHLRP2,INT1RP,FLOARP,IERRO1)
IF(IFOURP.EQ.'YES')GOTO358
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,341)
341 FORMAT('***** ERROR IN DPDELE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,342)
342 FORMAT(' WHEN THE DELETE COMMAND IS USED ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,343)
343 FORMAT(' WITHOUT A SUBSET QUALIFICATION, OR')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,344)
344 FORMAT(' WITHOUT A FOR QUALIFICATION,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,345)
345 FORMAT(' THEN ONLY INDIVIDUAL ELEMENTS ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,346)
346 FORMAT(' OF A VARIABLE MAY BE DELETED.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,347)
347 FORMAT(' SUCH INDIVIDUAL ELEMENTS ARE ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,348)
348 FORMAT(' SPECIFIED BY A VARIABLE NAME FOLLOWED BY A')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,349)
349 FORMAT(' PAIR OF PARENTHSES WITH A ROW NUMBER WITHIN;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,350)
350 FORMAT(' HOWEVER, A RIGHT PARENTHESIS IS MISSING HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,351)
351 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,352)(IANS(I),I=1,IWIDTH)
352 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO8900
C
358 CONTINUE
C
C ****************************************************************
C ** STEP 3.4--
C ** SEARCH FOR ROW NUMBER;
C ** SEARCH BETWEEN LEFT PARENTHESIS AND RIGHT PARENTH
C ****************************************************************
C
ISTEPN='3.4'
IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ISTAR1=IENDLP
ISTOP1=IENDRP
ISTRIN='(;)'
INEX='EE'
CALL DPTY3B(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGS2,
1 IFOURN,IBEGRN,IENDRN,
1 ITYPRN,IHOLRN,IHLRN2,INT1RN,FLOARN,IERRO1)
IF(IFOURN.EQ.'YES')GOTO378
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,361)
361 FORMAT('***** ERROR IN DPDELE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,362)
362 FORMAT(' WHEN THE DELETE COMMAND IS USED ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,363)
363 FORMAT(' WITHOUT A SUBSET QUALIFICATION, OR')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,364)
364 FORMAT(' WITHOUT A FOR QUALIFICATION,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,365)
365 FORMAT(' THEN ONLY INDIVIDUAL ELEMENTS ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,366)
366 FORMAT(' OF A VARIABLE MAY BE DELETED.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,367)
367 FORMAT(' SUCH INDIVIDUAL ELEMENTS ARE ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,368)
368 FORMAT(' SPECIFIED BY A VARIABLE NAME FOLLOWED BY A')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,369)
369 FORMAT(' PAIR OF PARENTHSES WITH A ROW NUMBER WITHIN;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,370)
370 FORMAT(' HOWEVER, A ROW NUMBER IS MISSING HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,371)
371 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,352)(IANS(I),I=1,IWIDTH)
372 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO8900
C
378 CONTINUE
C
C ****************************************************************
C ** STEP 3.5--
C ** SEARCH FOR VARIABLE NAME;
C ** IF THIS IS THE FIRST PASS FOR THIS LINE,
C ** SEARCH BETWEEN DELETE AND LEFT PARENTHESIS;
C ** IF THIS IS THE SECOND (OR HIGHER) PASS FOR THIS LINE,
C ** SEARCH BETWEEN PREVIOUS RIGHT PARENTHESIS AND
C ** THE NEXT LEFT PARENTHESIS.
C ****************************************************************
C
ISTEPN='3.5'
IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IPASS.LE.1)ISTAR1=IENDCO+1
IF(IPASS.GE.2)ISTAR1=ISAVE+1
ISTOP1=IENDLP
ISTRIN='!;('
INEX='IE'
CALL DPTY3B(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGS2,
1 IFOUVN,IBEGVN,IENDVN,
1 ITYPVN,IHOLVN,IHLVN2,INT1VN,FLOAVN,IERRO1)
IF(IFOUVN.EQ.'YES')GOTO398
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,381)
381 FORMAT('***** ERROR IN DPDELE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,382)
382 FORMAT(' WHEN THE DELETE COMMAND IS USED ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,383)
383 FORMAT(' WITHOUT A SUBSET QUALIFICATION, OR')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,384)
384 FORMAT(' WITHOUT A FOR QUALIFICATION,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,385)
385 FORMAT(' THEN ONLY INDIVIDUAL ELEMENTS ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,386)
386 FORMAT(' OF A VARIABLE MAY BE DELETED.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,387)
387 FORMAT(' SUCH INDIVIDUAL ELEMENTS ARE ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,388)
388 FORMAT(' SPECIFIED BY A VARIABLE NAME FOLLOWED BY A')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,389)
389 FORMAT(' PAIR OF PARENTHSES WITH A ROW NUMBER WITHIN;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,390)
390 FORMAT(' HOWEVER, A VARIABLE NAME IS MISSING HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,391)
391 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,392)(IANS(I),I=1,IWIDTH)
392 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO8900
C
398 CONTINUE
IVN(IPASS)=IHOLVN
IVN2(IPASS)=IHLVN2
IRN(IPASS)=INT1RN
C
GOTO300
C
399 CONTINUE
NUMDEL=IPASS-1
C
C ***************************************************************
C ** STEP 4-- **
C ** FOR THE FULL CASE, **
C ** CHECK TO MAKE SURE ALL VARIABLES WITH DELETIONS **
C ** ARE, IN FACT, IN THE INTERNAL LIST, **
C ** AND ARE, IN FACT, VARIABLES (AS OPPOSED TO PARAMETERS). **
C ***************************************************************
C
400 CONTINUE
C
ISTEPN='4'
IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
DO420J=1,NUMDEL
J2=J
IHVARJ=IVN(J)
IHVRJ2=IVN2(J)
DO430I=1,NUMNAM
I2=I
IF(IHVARJ.EQ.IHNAME(I).AND.IHVRJ2.EQ.IHNAM2(I).AND.
1IUSE(I).EQ.'V')GOTO440
IF(IHVARJ.EQ.IHNAME(I).AND.IHVRJ2.EQ.IHNAM2(I).AND.
1IUSE(I).EQ.'M')GOTO440
IF(IHVARJ.EQ.IHNAME(I).AND.IHVRJ2.EQ.IHNAM2(I).AND.
1IUSE(I).EQ.'P')GOTO450
430 CONTINUE
C
ILISTV(J2)=(-5)
GOTO420
C
440 CONTINUE
ILISTV(J2)=I2
GOTO420
C
450 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,451)
451 FORMAT('***** ERROR IN DPDELE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,452)
452 FORMAT(' A VARIABLE WITH ELEMENTS TO BE DELETED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,454)
454 FORMAT(' WAS FOUND IN THE INTERNAL NAME LIST,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,455)
455 FORMAT(' BUT AS A PARAMETER,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,456)
456 FORMAT(' AND NOT AS A VARIABLE AS IT SHOULD BE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,457)IHVARJ,IHVRJ2
457 FORMAT(' THE VARIABLE NAME WAS ',2A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,458)
458 FORMAT(' THE COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,459)(IANS(I),I=1,IWIDTH)
459 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO8900
C
420 CONTINUE
C
C *****************************************
C ** STEP 5-- **
C ** TREAT THE FULL CASE. **
C ** CARRY OUT THE DELETING, **
C ** AND THE SUBSEQUENT PACKING, **
C ** DO THE LIST UPDATING, AND **
C ** PRODUCE SOME INFORMATIVE PRINTING. **
C *****************************************
C
ISTEPN='5'
IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
DO500J=1,NUMDEL
IHVARJ=IVN(J)
IHVRJ2=IVN2(J)
IROWD=IRN(J)
ILIST2=ILISTV(J)
CCCCC THE FOLLOWING LINE WAS INSERTED DECEMBER 1994
IF(ILIST2.LE.0)GOTO500
NIVARJ=IN(ILIST2)
ICOLVJ=IVALUE(ILIST2)
CCCCC OCTOBER 1993. ADD FOLLOWING LINE
INCLVJ=IVALU2(ILIST2)
IMAX=NIVARJ
IF(1.LE.IROWD.AND.IROWD.LE.IMAX)GOTO539
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,531)
531 FORMAT('***** ERROR IN DPDELE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,532)IROWD
532 FORMAT(' THE SPECIFIED ROW ELEMENT (= ROW ',I8,')')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,533)IHVARJ,IHVRJ2
533 FORMAT(' TO BE DELETED FROM VARIABLE ',2A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,534)
534 FORMAT(' WAS SMALLER THAN 1, OR')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,535)IMAX
535 FORMAT(' WAS LARGER THAN THE CURRENT (= ',I8,')')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,536)
536 FORMAT(' NUMBER OF ELEMENTS IN THIS VARIABLE.')
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO8900
C
539 CONTINUE
C
NS2=0
ND2=0
DO550I=1,IMAX
IF(I.EQ.IROWD)GOTO560
GOTO570
C
560 CONTINUE
ND2=ND2+1
IJ=MAXN*(ICOLVJ-1)+I
IF(ICOLVJ.LE.MAXCOL)TEMPD=V(IJ)
IF(ICOLVJ.EQ.MAXCP1)TEMPD=PRED(I)
IF(ICOLVJ.EQ.MAXCP2)TEMPD=RES(I)
IF(ICOLVJ.EQ.MAXCP3)TEMPD=YPLOT(I)
IF(ICOLVJ.EQ.MAXCP4)TEMPD=XPLOT(I)
IF(ICOLVJ.EQ.MAXCP5)TEMPD=X2PLOT(I)
IF(ICOLVJ.EQ.MAXCP6)TEMPD=TAGPLO(I)
IF(ND2.EQ.1)IROD1O=I
IRODNO=I
IF(ND2.EQ.1)VALD1O=TEMPD
VALDNO=TEMPD
GOTO550
C
570 CONTINUE
NS2=NS2+1
IJ=MAXN*(ICOLVJ-1)+I
IF(ICOLVJ.LE.MAXCOL)TEMP(NS2)=V(IJ)
IF(ICOLVJ.EQ.MAXCP1)TEMP(NS2)=PRED(I)
IF(ICOLVJ.EQ.MAXCP2)TEMP(NS2)=RES(I)
IF(ICOLVJ.EQ.MAXCP3)TEMP(NS2)=YPLOT(I)
IF(ICOLVJ.EQ.MAXCP4)TEMP(NS2)=XPLOT(I)
IF(ICOLVJ.EQ.MAXCP5)TEMP(NS2)=X2PLOT(I)
IF(ICOLVJ.EQ.MAXCP6)TEMP(NS2)=TAGPLO(I)
IF(NS2.EQ.1)IROW1O=I
IROWNO=I
IF(NS2.EQ.1)VAL1O=TEMP(NS2)
VALNO=TEMP(NS2)
GOTO550
C
550 CONTINUE
NIOLD=NIVARJ
NINEW=NS2
IROW1N=1
IROWNN=NS2
C
IF(NS2.GE.1)GOTO580
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,581)
581 FORMAT('***** INTERNAL ERROR IN DPDELE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,582)
582 FORMAT(' FOR THE FULL (UNQUALIFIED) CASE,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,583)
583 FORMAT(' SINCE THE RESULTING NS2 = 0,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,584)
584 FORMAT(' THE NUMBER OF ELEMENTS DELETED = 0')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,585)IHVARJ,IHVRJ2,IMAX,IROWD
585 FORMAT(' IHVARJ, IHVRJ2, IMAX, IROWD = ',2A4,I8,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,590)
590 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,591)(IANS(I),I=1,IWIDTH)
591 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO8900
C
580 CONTINUE
DO600I=1,NS2
IJ=MAXN*(ICOLVJ-1)+I
IF(ICOLVJ.LE.MAXCOL)V(IJ)=TEMP(I)
IF(ICOLVJ.EQ.MAXCP1)PRED(I)=TEMP(I)
IF(ICOLVJ.EQ.MAXCP2)RES(I)=TEMP(I)
IF(ICOLVJ.EQ.MAXCP3)YPLOT(I)=TEMP(I)
IF(ICOLVJ.EQ.MAXCP4)XPLOT(I)=TEMP(I)
IF(ICOLVJ.EQ.MAXCP5)X2PLOT(I)=TEMP(I)
IF(ICOLVJ.EQ.MAXCP6)TAGPLO(I)=TEMP(I)
600 CONTINUE
C
DO602J4=1,NUMNAM
IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLVJ)GOTO605
GOTO602
605 CONTINUE
IUSE(J4)='V'
IVALUE(J4)=ICOLVJ
CCCCC OCTOBER 1993. ADD FOLLOWING LINE
IVALU2(J4)=INCLVJ
VALUE(J4)=ICOLVJ
IN(J4)=NINEW
IVSTAR(J4)=MAXN*(ICOLVJ-1)+1
IVSTOP(J4)=MAXN*(ICOLVJ-1)+NINEW
602 CONTINUE
C
IF(IFEEDB.EQ.'OFF')GOTO629
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,611)IHVARJ,IHVRJ2,NIOLD
611 FORMAT('VARIABLE ',2A4,'--OLD NUMBER OF ELEMENTS = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,612)NINEW
612 FORMAT(' NEW NUMBER OF ELEMENTS = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,613)VALD1O
613 FORMAT(' FIRST VALUE DELETED = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,614)IROD1O
614 FORMAT(' (DELETED FROM ROW ',I8,')')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,615)VALDNO
615 FORMAT(' LAST VALUE DELETED = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,616)IRODNO
616 FORMAT(' (DELETED FROM ROW ',I8,')')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,617)VAL1O
617 FORMAT(' FIRST VALUE RETAINED = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,618)IROW1O,IROW1N
618 FORMAT(' (MOVED FROM ROW ',I8,
1' TO ROW ',I8,')')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,619)VALNO
619 FORMAT(' LAST VALUE RETAINED = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,620)IROWNO,IROWNN
620 FORMAT(' (MOVED FROM ROW ',I8,
1' TO ROW ',I8,')')
CALL DPWRST('XXX','BUG ')
629 CONTINUE
C
500 CONTINUE
C
GOTO8900
C
C ***************************************************************
C ** STEP 7-- **
C ** FOR THE SUBSET AND FOR CASES **
C ** (AND WHEN DELETING ENTIRE VARIABLES),
C ** CHECK TO MAKE SURE ALL VARIABLES WITH DELETIONS **
C ** ARE, IN FACT, IN THE INTERNAL LIST. **
C ***************************************************************
C
7000 CONTINUE
C
ISTEPN='7'
IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CCCCC NUMDEL=ILOCQ-1
CCCCC IF(NUMDEL.LE.0.OR.NUMDEL.GT.MAXDEL)THEN
IF(NUME.LE.0.OR.NUME.GT.MAXE2)THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7101)
7101 FORMAT('***** ERROR IN DPDELE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7102)
7102 FORMAT(' THE DELETE COMMAND REQUIRES THAT ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7103)
7103 FORMAT(' THE NUMBER OF VARIABLES WITH ELEMENTS ',
1 'TO BE DELETED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7104)MAXE2
7104 FORMAT(' BE BETWEEN 1 AND ',I8,' (INCLUSIVE);')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7105)NUME
7105 FORMAT(' THE SPECIFIED NUMBER WAS ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7106)
7106 FORMAT(' THE INPUT COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,7107)(IANS(I),I=1,IWIDTH)
7107 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO8900
ENDIF
C
J2=0
DO7200J=1,NUME
IHVARJ=JENAM1(J)
IHVRJ2=JENAM2(J)
DO7300I=1,NUMNAM
I2=I
IF(IHVARJ.EQ.IHNAME(I).AND.IHVRJ2.EQ.IHNAM2(I).AND.
1 IUSE(I).EQ.'V')GOTO7400
IF(IHVARJ.EQ.IHNAME(I).AND.IHVRJ2.EQ.IHNAM2(I).AND.
1 IUSE(I).EQ.'P')GOTO7500
IF(IHVARJ.EQ.IHNAME(I).AND.IHVRJ2.EQ.IHNAM2(I).AND.
1 IUSE(I).EQ.'M')GOTO7450
7300 CONTINUE
C
CCCCC ILISTV(J2)=(-5)
GOTO7200
C
7400 CONTINUE
J2=J2+1
ILISTV(J2)=I2
GOTO7200
CCCCC OCTOBER 1993. HANDLE MATRIX CASE. NEED TO DELETE EACH OF THE
CCCCC VARIABLES AS WELL.
7450 CONTINUE
IN(I2)=-1
NCOL=IVALU2(I2) - IVALUE(I2) + 1
ISTART=I2+1
ISTOP=ISTART+NCOL-1
DO7455II=ISTART,ISTOP
IN(II)=-1
7455 CONTINUE
GOTO7200
C
CCCCC OCTOBER 1993. TO DELETE A PARAMETER, USE THE FACT THAT DPUPDV
CCCCC REMOVES ANY NAME WHERE IN(.)=0. SET IN(.) TO ZERO.
CCCCC JUNE 1994. SET TO -1 (SOME INTERNALLY SET PARAMETERS DO
CCCCC NOT SET IN(.), SO BE MORE EXPLICIT.
7500 CONTINUE
CCCCC IN(I2)=0
IN(I2)=-1
GOTO7200
C
7200 CONTINUE
NDONE=J2
C
C *****************************************
C ** STEP 8-- **
C ** TREAT THE SUBSET AND FOR CASES **
C ** AND CERTAIN FULL CASES. **
C ** CARRY OUT THE DELETING, **
C ** AND THE SUBSEQUENT PACKING, **
C ** DO THE LIST UPDATING, AND **
C ** PRODUCE SOME INFORMATIVE PRINTING. **
C *****************************************
C
ISTEPN='8'
IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(ICASEQ.EQ.'FULL')GOTO8100
ILQP1=ILOCQ+1
IF(ILQP1.LE.NUMARG)GOTO8100
IF(ICASEQ.EQ.'FOR')GOTO8030
GOTO8010
C
8010 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8011)
8011 FORMAT('***** ERROR IN DPDELE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8012)
8012 FORMAT(' THE WORD SUBSET WAS THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8013)
8013 FORMAT(' FINAL WORD ON THE COMMAND LINE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8014)
8014 FORMAT(' THE WORD SUBSET SHOULD HAVE BEEN FOLLOWED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8015)
8015 FORMAT(' BY EITHER 2 OR 3 ARGUMENTS--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8016)
8016 FORMAT(' THE FIRST ARGUMENT SPECIFIES THE SUBSET ',
1'VARIABLE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8017)
8017 FORMAT(' THE SECOND AND (IF EXISTENT) THIRD ARGUMENTS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8018)
8018 FORMAT(' SPECIFY THE VALUE OR INTERVAL')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8019)
8019 FORMAT(' (OF THE SUBSET VARIABLE) WHICH DEFINES')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8020)
8020 FORMAT(' THE SUBSET OF INTEREST.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8021)
8021 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,8022)(IANS(I),I=1,IWIDTH)
8022 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO8900
C
8030 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8031)
8031 FORMAT('***** ERROR IN DPDELE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8032)
8032 FORMAT(' THE WORD FOR WAS THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8033)
8033 FORMAT(' FINAL WORD ON THE COMMAND LINE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8034)
8034 FORMAT(' THE WORD FOR SHOULD HAVE BEEN FOLLOWED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8035)
8035 FORMAT(' BY EXACTLY 3 OR BY EXACTLY 5 WORDS --')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8036)
8036 FORMAT(' 1) A DUMMY VARIABLE NAME;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8037)
8037 FORMAT(' 2) AN EQUAL SIGN;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8038)
8038 FORMAT(' 3) ONE LIMIT (LOWER OR UPPER) ',
1'FOR THE DUMMY VARIABLE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8039)
8039 FORMAT(' 4) THE INCREMENT FOR THE DUMMY VARIABLE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9040)
9040 FORMAT(' 5) THE OTHER LIMIT (UPPER OR LOWER) ',
1'FOR THE DUMMY VARIABLE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9041)
9041 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,9042)(IANS(I),I=1,IWIDTH)
9042 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO8900
C
8100 CONTINUE
IF(ICASEQ.EQ.'FULL')GOTO8130
IF(ICASEQ.EQ.'FOR')GOTO8120
IHSET=IHARG(ILQP1)
IHSET2=IHARG2(ILQP1)
IHWUSE='V'
MESSAG='YES'
CALL CHECKN(IHSET,IHSET2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
GOTO8110
C
8110 CONTINUE
NISET=IN(ILOC)
CALL DPSUBS(NISET,ILOCS,NS,IBUGQ,IERROR)
NQ=NISET
GOTO8200
C
8120 CONTINUE
NIOLD=MAXN
CALL DPFOR(NIOLD,NINEW,IROW1,IROWN,
1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
NQ=NINEW
GOTO8200
C
8130 CONTINUE
DO8135I=1,MAXN
ISUB(I)=1
8135 CONTINUE
NQ=MAXN
GOTO8200
C
8200 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
DO8300J=1,NUME
IHVARJ=JENAM1(J)
IHVRJ2=JENAM2(J)
ILIST2=ILISTV(J)
IF(ILIST2.LE.0)GOTO8300
NIVARJ=IN(ILIST2)
CCCCC OCTOBER 1993. SKIP FOR PARAMETER
IF(NIVARJ.EQ.0)GOTO8300
ICOLVJ=IVALUE(ILIST2)
CCCCC OCTOBER 1993. ADD FOLLOWING LINE
INCLVJ=IVALU2(ILIST2)
NS2=0
ND2=0
IMAX=NQ
IF(NIVARJ.LT.NQ)IMAX=NIVARJ
DO8400I=1,IMAX
IF(ISUB(I).EQ.0)GOTO8450
C
ND2=ND2+1
IJ=MAXN*(ICOLVJ-1)+I
IF(ICOLVJ.LE.MAXCOL)TEMPD=V(IJ)
IF(ICOLVJ.EQ.MAXCP1)TEMPD=PRED(I)
IF(ICOLVJ.EQ.MAXCP2)TEMPD=RES(I)
IF(ICOLVJ.EQ.MAXCP3)TEMPD=YPLOT(I)
IF(ICOLVJ.EQ.MAXCP4)TEMPD=XPLOT(I)
IF(ICOLVJ.EQ.MAXCP5)TEMPD=X2PLOT(I)
IF(ICOLVJ.EQ.MAXCP6)TEMPD=TAGPLO(I)
IF(ND2.EQ.1)IROD1O=I
IRODNO=I
IF(ND2.EQ.1)VALD1O=TEMPD
VALDNO=TEMPD
GOTO8400
C
8450 CONTINUE
NS2=NS2+1
IJ=MAXN*(ICOLVJ-1)+I
IF(ICOLVJ.LE.MAXCOL)TEMP(NS2)=V(IJ)
IF(ICOLVJ.EQ.MAXCP1)TEMP(NS2)=PRED(I)
IF(ICOLVJ.EQ.MAXCP2)TEMP(NS2)=RES(I)
IF(ICOLVJ.EQ.MAXCP3)TEMP(NS2)=YPLOT(I)
IF(ICOLVJ.EQ.MAXCP4)TEMP(NS2)=XPLOT(I)
IF(ICOLVJ.EQ.MAXCP5)TEMP(NS2)=X2PLOT(I)
IF(ICOLVJ.EQ.MAXCP6)TEMP(NS2)=TAGPLO(I)
IF(NS2.EQ.1)IROW1O=I
IROWNO=I
IF(NS2.EQ.1)VAL1O=TEMP(NS2)
VALNO=TEMP(NS2)
GOTO8400
C
8400 CONTINUE
NIOLD=NIVARJ
NINEW=NS2
IROW1N=1
IROWNN=NS2
C
IF(ND2.GE.1)GOTO8550
IERROR='YES'
GOTO8900
C
8550 CONTINUE
DO8500I=1,NS2
IJ=MAXN*(ICOLVJ-1)+I
IF(ICOLVJ.LE.MAXCOL)V(IJ)=TEMP(I)
IF(ICOLVJ.EQ.MAXCP1)PRED(I)=TEMP(I)
IF(ICOLVJ.EQ.MAXCP2)RES(I)=TEMP(I)
IF(ICOLVJ.EQ.MAXCP3)YPLOT(I)=TEMP(I)
IF(ICOLVJ.EQ.MAXCP4)XPLOT(I)=TEMP(I)
IF(ICOLVJ.EQ.MAXCP5)X2PLOT(I)=TEMP(I)
IF(ICOLVJ.EQ.MAXCP6)TAGPLO(I)=TEMP(I)
8500 CONTINUE
C
CCCCC OCTOBER 1997. REINIITIALIZE DELETED VALUES TO ZERO
CCCCC INSTEAD OF CPUMIN.
NS2P1=NS2+1
IF(NS2P1.GT.IMAX)GOTO8569
DO8560I=NS2P1,IMAX
IJ=MAXN*(ICOLVJ-1)+I
CCCCC IF(ICOLVJ.LE.MAXCOL)V(IJ)=CPUMIN
CCCCC IF(ICOLVJ.EQ.MAXCP1)PRED(I)=CPUMIN
CCCCC IF(ICOLVJ.EQ.MAXCP2)RES(I)=CPUMIN
CCCCC IF(ICOLVJ.EQ.MAXCP3)YPLOT(I)=CPUMIN
CCCCC IF(ICOLVJ.EQ.MAXCP4)XPLOT(I)=CPUMIN
CCCCC IF(ICOLVJ.EQ.MAXCP5)X2PLOT(I)=CPUMIN
CCCCC IF(ICOLVJ.EQ.MAXCP6)TAGPLO(I)=CPUMIN
IF(ICOLVJ.LE.MAXCOL)V(IJ)=0.0
IF(ICOLVJ.EQ.MAXCP1)PRED(I)=0.0
IF(ICOLVJ.EQ.MAXCP2)RES(I)=0.0
IF(ICOLVJ.EQ.MAXCP3)YPLOT(I)=0.0
IF(ICOLVJ.EQ.MAXCP4)XPLOT(I)=0.0
IF(ICOLVJ.EQ.MAXCP5)X2PLOT(I)=0.0
IF(ICOLVJ.EQ.MAXCP6)TAGPLO(I)=0.0
8560 CONTINUE
8569 CONTINUE
C
DO8600J4=1,NUMNAM
IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLVJ)GOTO8605
GOTO8600
8605 CONTINUE
IUSE(J4)='V'
IVALUE(J4)=ICOLVJ
CCCCC OCTOBER 1993. ADD FOLLOWING LINE
IVALU2(J4)=INCLVJ
VALUE(J4)=ICOLVJ
IN(J4)=NINEW
IVSTAR(J4)=MAXN*(ICOLVJ-1)+1
IVSTOP(J4)=MAXN*(ICOLVJ-1)+NINEW
8600 CONTINUE
C
IF(IFEEDB.EQ.'OFF')GOTO8629
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8611)IHVARJ,IHVRJ2,NIOLD
8611 FORMAT('VARIABLE ',2A4,'--OLD NUMBER OF ELEMENTS = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8612)NINEW
8612 FORMAT(' NEW NUMBER OF ELEMENTS = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8613)VALD1O
8613 FORMAT(' FIRST VALUE DELETED = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8614)IROD1O
8614 FORMAT(' (DELETED FROM ROW ',I8,')')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8615)VALDNO
8615 FORMAT(' LAST VALUE DELETED = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8616)IRODNO
8616 FORMAT(' (DELETED FROM ROW ',I8,')')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8617)VAL1O
8617 FORMAT(' FIRST VALUE RETAINED = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8618)IROW1O,IROW1N
8618 FORMAT(' (MOVED FROM ROW ',I8,
1 ' TO ROW ',I8,' )')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8619)VALNO
8619 FORMAT(' LAST VALUE RETAINED = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8620)IROWNO,IROWNN
8620 FORMAT(' (MOVED FROM ROW ',I8,
1 ' TO ROW ',I8,')')
CALL DPWRST('XXX','BUG ')
8629 CONTINUE
C
8300 CONTINUE
C
GOTO8900
C
C **********************************
C ** STEP 9-- **
C ** UPDATE INTERNAL DATA ARRAY **
C ** (IF NECESSARY) **
C **********************************
C
8900 CONTINUE
C
ISTEPN='9'
IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CCCCC OCTOBER 1993. ADD ARGUMENT TO LIST
CCCCC CALL DPUPDV(IHNAME,IHNAM2,IUSE,IVALUE,VALUE,IN,
CALL DPUPDV(IHNAME,IHNAM2,IUSE,IVALUE,IVALU2,VALUE,IN,
1IVARLB,
1IVSTAR,IVSTOP,MAXNAM,NUMNAM,V,MAXN,MAXCOL,NUMCOL,
1IBUGS2,IERROR)
C
C *****************
C ** STEP 90-- **
C ** EXIT. **
C *****************
C
9000 CONTINUE
IF(IBUGS2.EQ.'OFF')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPDELE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGS2,IERROR
9012 FORMAT('IBUGS2,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)MAXNAM,NUMNAM
9013 FORMAT('MAXNAM,NUMNAM = ',3I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)MAXN,MAXCOL,NUMCOL
9014 FORMAT('MAXN,MAXCOL,NUMCOL = ',3I8)
CALL DPWRST('XXX','BUG ')
DO9020I=1,NUMNAM
WRITE(ICOUT,9021)I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I)
9021 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) = ',
1I8,2X,A4,A4,2X,A4,I8,E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9022)I,IHNAME(I),IHNAM2(I),IN(I),IVSTAR(I),IVSTOP(I)
9022 FORMAT('I,IHNAME(I),IHNAM2(I),IN(I),IVSTAR(I),IVSTOP(I) = ',
1I8,2X,A4,A4,6X,I8,I8,I8)
CALL DPWRST('XXX','BUG ')
9020 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
DO9030J=1,NUMCOL
IJ=MAXN*(J-1)+1
WRITE(ICOUT,9031)J,MAXN,IJ,V(IJ)
9031 FORMAT('J,MAXN,IJ,V(IJ) = ',I8,I8,I8,E15.7)
CALL DPWRST('XXX','BUG ')
9030 CONTINUE
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPDELI(Y,X,PX,NP,NUMSET,
1ICASPL,ICAS3D,
1XDELMN)
C
C PURPOSE--DETERMINE DATA LIMITS, FRAME LIMITS,
C AND TIC COORDINATES FOR A PLOT.
C
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-921-3651
C NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C OF THE NATIONAL BUREAU OF STANDARDS.
C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C MODIFIED, OR OTHERWISE USED IN A CONTEXT
C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--83.6
C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983.
C UPDATED--MAY 1990. ADD VARIABLES TO DPDETM CALL LIST
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
CHARACTER*4 ICASPL
CHARACTER*4 ICAS3D
C
DIMENSION Y(*)
DIMENSION X(*)
DIMENSION PX(*)
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCOPA.INC'
INCLUDE 'DPCOPC.INC'
INCLUDE 'DPCOGR.INC'
INCLUDE 'DPCOBE.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DELI')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPDELI--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IMANUF,IMODEL
52 FORMAT('IMANUF,IMODEL = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)NP,NUMSET,XDELMN
54 FORMAT('NP,NUMSET,XDELMN = ',2I8,E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,55)ICASPL,ICAS3D
55 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,59)IBUGG4,ISUBG4,IERRG4
59 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,70)ITICUN
70 FORMAT('ITICUN = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,71)PX1TOL,PX2TOL,PY1TOB,PY2TOB
71 FORMAT('PX1TOL,PX2TOL,PY1TOB,PY2TOB = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,72)PX1TOR,PX2TOR,PY1TOT,PY2TOT
72 FORMAT('PX1TOR,PX2TOR,PY1TOT,PY2TOT = ',4E15.7)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C ************************************
C ** STEP 1-- **
C ** DETERMINE ACTUAL DATA LIMITS **
C ** (IN UNITS OF THE DATA) **
C ************************************
C
CALL DPDEDL(Y,X,PX,NP,NUMSET,
1ICASPL,ICAS3D,
1ISPISW,ASPIBA,MAXSPI,
1IBARSW,ABARBA,ABARWI,MAXBAR,XDELMN,
1GX1MIN,GX1MAX,GY1MIN,GY1MAX,
1GX2MIN,GX2MAX,GY2MIN,GY2MAX,
1IX1MIN,IX1MAX,IY1MIN,IY1MAX,
1IX2MIN,IX2MAX,IY2MIN,IY2MAX,
1DX1MIN,DX1MAX,DY1MIN,DY1MAX,
1DX2MIN,DX2MAX,DY2MIN,DY2MAX,
1IHORSW)
C IHORSW ADDED SEPTEMBER, 1987
C
C *************************************
C ** STEP 2-- **
C ** DETERMINE ACTUAL FRAME LIMITS **
C ** (IN UNITS OF THE DATA) **
C *************************************
C
CALL DPDEFL(ICASPL,ICAS3D,
1DX1MIN,DX1MAX,DY1MIN,DY1MAX,
1DX2MIN,DX2MAX,DY2MIN,DY2MAX,
1GX1MIN,GX1MAX,GY1MIN,GY1MAX,
1GX2MIN,GX2MAX,GY2MIN,GY2MAX,
1IX1MIN,IX1MAX,IY1MIN,IY1MAX,
1IX2MIN,IX2MAX,IY2MIN,IY2MAX,
1IX1TSC,IX2TSC,IY1TSC,IY2TSC,
1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
1FX2MIN,FX2MAX,FY2MIN,FY2MAX,
1NMJX1T,NMJX2T,NMJY1T,NMJY2T)
CCCCC NOVEMBER 1997. SAVE FRAME LIMITS BEFORE AFFECTED BY
CCCCC TIC OFFSET VALUES.
FX1MNZ=FX1MIN
FX1MXZ=FX1MAX
FX2MNZ=FX2MIN
FX2MXZ=FX2MAX
FY1MNZ=FY1MIN
FY1MXZ=FY1MAX
FY2MNZ=FY2MIN
FY2MXZ=FY2MAX
C
IF(IERRG4.EQ.'YES')GOTO9000
C
C *********************************************
C ** STEP 3-- **
C ** DETERMINE ACTUAL TIC MARK COORDINATES **
C ** (IN BOTH STANDARDIZED 0 TO 100 UNITS, **
C ** AND IN DATA UNITS) **
C *********************************************
C
CCCCC ADDED TIC OFFSET VARIABLES TO CALL LIST MAY, 1990.
C
CALL DPDETM(PXMIN,PYMIN,PXMAX,PYMAX,
1ICASPL,ICAS3D,
1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
1FX2MIN,FX2MAX,FY2MIN,FY2MAX,
1IX1TSW,IX2TSW,IY1TSW,IY2TSW,
1IX1JSW,IX2JSW,IY1JSW,IY2JSW,
1NMJX1T,NMJX2T,NMJY1T,NMJY2T,
1IX1TSC,IX2TSC,IY1TSC,IY2TSC,
1PX1COO,PX2COO,PY1COO,PY2COO,
1X1COOR,X2COOR,Y1COOR,Y2COOR,
1NX1COO,NX2COO,NY1COO,NY2COO,
1IX1NSW,IX2NSW,IY1NSW,IY2NSW,
1NMNX1T,NMNX2T,NMNY1T,NMNY2T,
1PX1CMN,PX2CMN,PY1CMN,PY2CMN,
1X1COMN,X2COMN,Y1COMN,Y2COMN,
1NX1CMN,NX2CMN,NY1CMN,NY2CMN,
1PX1TOL,PX2TOL,PY1TOB,PY2TOB,
1PX1TOR,PX2TOR,PY1TOT,PY2TOT,
1ITICUN)
IF(IERRG4.EQ.'YES')GOTO9000
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DELI')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPDELI--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IMANUF,IMODEL
9012 FORMAT('IMANUF,IMODEL = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)NP,NUMSET,XDELMN
9014 FORMAT('NP,NUMSET,XDELMN = ',2I8,E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)ICASPL,ICAS3D
9015 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9019)IBUGG4,ISUBG4,IERRG4
9019 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPDEMN(IHARG,IHARG2,IARGT,IARG,NUMARG,
1IPL1NU,IPL1NA,
1IPL2NU,IPL2NA,
1IPL1CS,IPL2CS,
1IDEFMA,IDEFMO,IDEFM2,IDEFM3,
1IDEFPO,IDEFCN,IDEFDC,IDEFVP,IDEFHP,IDEFUN,
1NUMDEV,MAXDEV,
1IDMANU,IDMODE,IDMOD2,IDMOD3,
1IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT,
1IDNVOF,IDNHOF,
1ICAPSW,ICAPNU,
1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
C JUNE 1992. IPL1CS, IPL2CS ADDED TO ARGUMENT LIST
C
C PURPOSE--DEFINE THE MANUFACTURER AND MODEL FOR AN OUTPUT DEVICE.
C THE MANUFACTURER AND MODEL WILL BE PLACED
C IN THE I-TH ELEMENT OF THE VECTORS
C IDMANU, IDMODE, IDMOD2, AND IDMOD3.
C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR)
C --IHARG2 (A CHARACTER VECTOR)
C --IARGT (A CHARACTER VECTOR)
C --IARG (A CHARACTER VECTOR)
C --NUMARG
C --IDEFMA
C --IDEFMO
C --IDEFM2
C --IDEFM3
C --MAXDEV
C OUTPUT ARGUMENTS--
C --IDMANU
C --IDMODE
C --IDMOD2
C --IDMOD3
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--OCTOBER 1980.
C UPDATED --MAY 1982.
C UPDATED --FEBRUARY 1989. POSTSCRIPT, QUIC, PCL, ETC. (ALAN)
C UPDATED --MAY 1989. POSTSCRIPT TRANSLATION FIX (ALAN)
C UPDATED --MARCH 1990. X11 FIX
C UPDATED --MAY 1990. HP-GL MODEL NUMBERS
C UPDATED --MAY 1990. DISTINCTION BETWEEN OFF AND CLOSE
C UPDATED --APRIL 1992. CALL GREXIT IF CLOSE (ALAN)
C UPDATED --MAY 1992. SKIP MESSAGE FOR DEVICE 3
C UPDATED --JUNE 1992. DON'T CALL GRINDE FOR ON
C UPDATED --JUNE 1992. IF DEVICE, CHECK IF STATUS IS OPEN
C UPDATED --AUGUST 1992. FIX FOR HP-GL (LASER JET III)
C UPDATED --MARCH 1995. SYNONYMS FOR POSTSCRIPT
C UPDATED --OCTOBER 1996. QWIN PATCH
C UPDATED --FEBRUARY 2001. GD AND GDI DEVICES SHOULD NOT OPEN OUTPUT
C FILE (DONE BY UNDERLYING C ROUTINES)
C PASS IGDFLG TO DPDEP2
C UPDATED --SEPTEMBER 2002. ICAPSW
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IHARG
CHARACTER*4 IHARG2
CHARACTER*4 IARGT
C
CHARACTER*80 IPL1NA
CHARACTER*80 IPL2NA
C FOLLOWING 2 LINES JUNE 1992
CHARACTER*12 IPL1CS
CHARACTER*12 IPL2CS
C
CHARACTER*4 ICAPSW
C
CHARACTER*4 IDEFMA
CHARACTER*4 IDEFMO
CHARACTER*4 IDEFM2
CHARACTER*4 IDEFM3
C
CHARACTER*4 IDEFPO
CHARACTER*4 IDEFCN
CHARACTER*4 IDEFDC
C
CHARACTER*4 IDMANU
CHARACTER*4 IDMODE
CHARACTER*4 IDMOD2
CHARACTER*4 IDMOD3
C
CHARACTER*4 IDPOWE
CHARACTER*4 IDCONT
CHARACTER*4 IDCOLO
CHARACTER*4 IDFONT
C
CHARACTER*4 IBUGO2
CHARACTER*4 ISUBRO
CHARACTER*4 IANS
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 IOPERA
CHARACTER*4 IGENID
CHARACTER*4 IGDFLG
CHARACTER*4 IFOUN2
C
CHARACTER*4 ISAVE
C
C---------------------------------------------------------------------
C
DIMENSION IHARG(*)
DIMENSION IHARG2(*)
DIMENSION IARGT(*)
DIMENSION IARG(*)
C
DIMENSION IDMANU(*)
DIMENSION IDMODE(*)
DIMENSION IDMOD2(*)
DIMENSION IDMOD3(*)
C
DIMENSION IDPOWE(*)
DIMENSION IDCONT(*)
DIMENSION IDCOLO(*)
DIMENSION IDFONT(*)
DIMENSION IDNVPP(*)
DIMENSION IDNHPP(*)
DIMENSION IDUNIT(*)
DIMENSION IDNVOF(*)
DIMENSION IDNHOF(*)
C
DIMENSION IANS(*)
C
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCOGR.INC'
INCLUDE 'DPCOBE.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
IFOUND='NO'
IERROR='NO'
IBUGG4='OFF'
ISUBG4='-999'
ISAVE='-999'
C
IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEMN')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('AT THE BEGINNING OF DPDEMN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)IBUGO2,ISUBRO
53 FORMAT('IBUGO2,ISUBRO = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,60)IFOUND,IERROR
60 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,68)NUMARG
68 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
DO70I=1,NUMARG
WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I)
71 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I) = ',
1I8,2X,A4,2X,A4,2X,A4,2X,I8)
CALL DPWRST('XXX','BUG ')
70 CONTINUE
WRITE(ICOUT,75)IPL1CS,IPL2CS
75 FORMAT('IPL1CS,IPL2CS=',A4,1X,A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
CCCCC FEBRUARY, 1989. CHECK IF MODEL ="ON" OR "OFF". IF SO, DO NOT TREAT AS
CCCCC AS A DEVICE. WILL BE HANDLED SEPARATELY IN MAINOD.
C
CCCCC IF(IHARG(NUMARG).EQ.'ON')GOTO9000
CCCCC IF(IHARG(NUMARG).EQ.'OPEN')GOTO9000
CCCCC IF(IHARG(NUMARG).EQ.'OFF')GOTO9000
CCCCC IF(IHARG(NUMARG).EQ.'CLOS')GOTO9000
C END FIX
IF(NUMARG.LE.0)GOTO1199
IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MANU')GOTO1110
IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MODE')GOTO1110
IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MANU')GOTO1140
IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MODE')GOTO1140
CCCCC GOTO1199
GOTO1140
C
C ***************************************************************
C ** FEBRAURY, 1989: HANDLE "ON" AND "OFF" SEPARETELY. THESE WILL **
C ** TURN THE DEVICE POWER "ON" AND "OFF", BUT WILL NOT RESET **
C ** THE DEVICE TYPE OR OTHER SETTINGS. DO THIS WAY SO CAN **
C ** TOGGLE A DEVICE "ON" AND "OFF". **
C ***************************************************************
C
C MAY, 1990. DISTINGUISH BETWEEN OFF AND CLOSE. BOTH WILL TURN THE
C POWER SWITCH OFF, BUT CLOSE WILL ALSO CLOSE THE FILE.
1110 CONTINUE
IF(IHARG(NUMARG).EQ.'ON')GOTO1112
IF(IHARG(NUMARG).EQ.'OPEN')GOTO1112
IF(IHARG(NUMARG).EQ.'OFF')GOTO1116
IF(IHARG(NUMARG).EQ.'CLOS')GOTO1118
IF(IHARG(NUMARG).EQ.'AUTO')GOTO1120
IF(IHARG(NUMARG).EQ.'DEFA')GOTO1120
IF(NUMARG.LE.1)GOTO1120
GOTO1125
C
1120 CONTINUE
DO1121I=1,NUMDEV
IDMANU(I)=IDEFMA
IDMODE(I)=IDEFMO
IDMOD2(I)=IDEFM2
IDMOD3(I)=IDEFM3
IDPOWE(I)=IDEFPO
IDCONT(I)=IDEFCN
IDCOLO(I)=IDEFDC
IDNVPP(I)=IDEFVP
IDNHPP(I)=IDEFHP
IDUNIT(I)=IDEFUN
1121 CONTINUE
GOTO1130
C
1112 CONTINUE
DO1114I=1,NUMDEV
IDPOWE(I)='ON'
1114 CONTINUE
GOTO1130
C
1116 CONTINUE
DO1117I=1,NUMDEV
IDPOWE(I)='OFF'
1117 CONTINUE
GOTO1130
C
1118 CONTINUE
DO1119I=1,NUMDEV
IDPOWE(I)='OFF'
1119 CONTINUE
GOTO1130
C
C FEBRUARY,1989. "QMS" WILL BE SET TO "QUIC". "LASER JET" TO PCL.
1125 CONTINUE
C JUNE 1992. FOLLOWING FOR DEBUGGING PURPOSES
IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEMN')GOTO1124
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1123)
1123 FORMAT('IN LOOP 1125')
CALL DPWRST('XXX','BUG ')
1124 CONTINUE
C
DO1127I=1,NUMDEV
K=2
IF(K.LE.NUMARG)IDMANU(I)=IHARG(K)
IF(K.GT.NUMARG)IDMANU(I)=' '
ISAVE=IDMANU(I)
IF(ISAVE.EQ.'HPGL')IDMANU(I)='HP '
IF(ISAVE.EQ.'QMS')IDMANU(I)='QUIC'
IF(ISAVE.EQ.'TELA')IDMANU(I)='QUIC'
IF(ISAVE.EQ.'LASE')IDMANU(I)='PCL '
IF(ISAVE.EQ.'PS ')IDMANU(I)='POST'
K=K+1
IF(K.LE.NUMARG)IDMODE(I)=IHARG(K)
IF(K.GT.NUMARG)IDMODE(I)=' '
C FOLLOWING LINE MOVED TO BELOW
CCCCC IF(ISAVE.EQ.'HPGL')IDMODE(I)='GL '
IF(ISAVE.EQ.'LASE'.AND.IDMODE(I).EQ.'JET')IDMODE(I)=' '
K=K+1
IF(K.LE.NUMARG)IDMOD2(I)=IHARG(K)
IF(K.GT.NUMARG)IDMOD2(I)=' '
K=K+1
IF(K.LE.NUMARG)IDMOD3(I)=IHARG(K)
IF(K.GT.NUMARG)IDMOD3(I)=' '
C FOLLOWING BLOCK ADDED TO CHECK FOR HPGL MODEL NUMBERS
IF(ISAVE.EQ.'HPGL')THEN
IDMOD3(I)=IDMOD2(I)
IDMOD2(I)=IDMODE(I)
IDMODE(I)='GL '
END IF
C END CHANGES
CCCCC MARCH 1995. ADD FOLLOWING 4 LINES
IF(ISAVE.EQ.'EPS ')IDMANU(I)='POST'
IF(ISAVE.EQ.'EPS ')IDMODE(I)='ENCA'
IF(ISAVE.EQ.'ENCA')IDMANU(I)='POST'
IF(ISAVE.EQ.'ENCA')IDMODE(I)='ENCA'
C
CALL GRSEPP(I,
1IPL1NU,
1IPL2NU,
1IDMANU,IDMODE,IDMOD2,IDMOD3,
1IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT,
1IDNVOF,IDNHOF,
1IBUGO2,IFOUN2,IERROR)
1127 CONTINUE
GOTO1130
C
1130 CONTINUE
IFOUND='YES'
C
IF(IFEEDB.EQ.'OFF')GOTO1139
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1136)
1136 FORMAT('THE MANUFACTURER FOR ALL DEVICES HAS JUST BEEN')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1137)IDMANU(1),IDMODE(1),IDMOD2(1),IDMOD3(1)
1137 FORMAT('SET TO ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
1139 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 DPDEMN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1142)
1142 FORMAT(' IN THE DEVICE ... MANUFACTURER COMMAND,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1143)
1143 FORMAT(' THE DEVICE IS IDENTIFIED BY A NUMBER, AS IN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1144)
1144 FORMAT(' DEVICE 2 MANUFACTURER FR-80')
CALL DPWRST('XXX','BUG ')
GOTO1199
C
1150 CONTINUE
I=IARG(1)
IF(1.LE.I.AND.I.LE.MAXDEV)GOTO1160
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1151)
1151 FORMAT('***** ERROR IN DPDEMN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1152)
1152 FORMAT(' IN THE DEVICE ... MANUFACTURER COMMAND,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1153)
1153 FORMAT(' THE NUMBER OF DEVICES MUST BE ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1154)MAXDEV
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'DEVICE.')
CALL DPWRST('XXX','BUG ')
GOTO1199
C
C ***************************************************************
C ** FEBRUARY, 1989: HANDLE "ON" AND "OFF" SEPARETELY. THESE WILL **
C ** TURN THE DEVICE POWER "ON" AND "OFF", BUT WILL NOT RESET **
C ** THE DEVICE TYPE OR OTHER SETTINGS. DO THIS WAY SO CAN **
C ** TOGGLE A DEVICE "ON" AND "OFF". **
C ***************************************************************
C
C MAY, 1990. DISTINGUISH BETWEEN OFF AND CLOSE. BOTH WILL TURN THE
C POWER SWITCH OFF, BUT CLOSE WILL ALSO CLOSE THE FILE.
C
1160 CONTINUE
IF(IHARG(NUMARG).EQ.'ON')GOTO1162
CCCCC JUNE 1992. HANDLE ON AND OPEN CASE DIFFERENTLY
CCCCC IF(IHARG(NUMARG).EQ.'OPEN')GOTO1162
IF(IHARG(NUMARG).EQ.'OPEN')GOTO1163
IF(IHARG(NUMARG).EQ.'OFF')GOTO1167
IF(IHARG(NUMARG).EQ.'CLOS')GOTO1168
IF(IHARG(NUMARG).EQ.'AUTO')GOTO1170
IF(IHARG(NUMARG).EQ.'DEFA')GOTO1170
IF(NUMARG.LE.2)GOTO1175
GOTO1175
C
1170 CONTINUE
IF(I.GT.NUMDEV)NUMDEV=I
IDMANU(I)=IDEFMA
IDMODE(I)=IDEFMO
IDMOD2(I)=IDEFM2
IDMOD3(I)=IDEFM3
IDPOWE(I)=IDEFPO
IDCONT(I)=IDEFCN
IDCOLO(I)=IDEFDC
IDNVPP(I)=IDEFVP
IDNHPP(I)=IDEFHP
IDUNIT(I)=IDEFUN
GOTO1180
C
1162 CONTINUE
IF(I.GT.NUMDEV)NUMDEV=I
IDPOWE(I)='ON'
GOTO1180
C
CCCCC JUNE 1992. FOLLOWING BLOCK ADDED.
1163 CONTINUE
IF(I.EQ.2.AND.IPL1CS(1:4).EQ.'OPEN')THEN
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3163)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3164)
CALL DPWRST('XXX','BUG ')
GOTO1199
ENDIF
3163 FORMAT('***** ERROR IN DPDEMN--')
3164 FORMAT(' DEVICE 2 IS ALREADY OPEN')
IF(I.EQ.3.AND.IPL2CS(1:4).EQ.'OPEN')THEN
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3173)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3174)
CALL DPWRST('XXX','BUG ')
GOTO1199
ENDIF
3173 FORMAT('***** ERROR IN DPDEMN--')
3174 FORMAT(' DEVICE 3 IS ALREADY OPEN')
IF(I.GT.NUMDEV)NUMDEV=I
IDPOWE(I)='ON'
IOPERA='OPEN'
GOTO1179
CCCCC END JUNE 1992 CHANGE
C
1167 CONTINUE
IF(I.GT.NUMDEV)NUMDEV=I
IDPOWE(I)='OFF'
GOTO1180
C
1168 CONTINUE
IF(I.GT.NUMDEV)NUMDEV=I
IDPOWE(I)='OFF'
IOPERA='CLOS'
GOTO1179
C
C FEBRUARY,1989. "QMS" WILL BE SET TO "QUIC". "LASER JET" TO PCL.
C
1175 CONTINUE
CCCCC JUNE 1992. DON"T RE-OPEN DEVICE IF ALREADY OPEN
C JUNE 1992. FOLLOWING FOR DEBUGGING PURPOSES
IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEMN')GOTO1174
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1173)I,IPL1CS,IPL2CS
1173 FORMAT('IN LOOP 1175, I,IPL1CS,IPL2CS=',I4,A4,A4)
CALL DPWRST('XXX','BUG ')
1174 CONTINUE
C
IF(I.EQ.2.AND.IPL1CS(1:4).EQ.'OPEN')THEN
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3163)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3164)
CALL DPWRST('XXX','BUG ')
GOTO1199
ENDIF
IF(I.EQ.3.AND.IPL2CS(1:4).EQ.'OPEN')THEN
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3173)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3174)
CALL DPWRST('XXX','BUG ')
GOTO1199
ENDIF
CCCCC END JUNE 1992 CHANGES
IF(I.GT.NUMDEV)NUMDEV=I
K=2
IF(IHARG(2).EQ.'MANU')K=3
IF(IHARG(2).EQ.'MODE')K=3
IF(K.LE.NUMARG)IDMANU(I)=IHARG(K)
IF(K.GT.NUMARG)IDMANU(I)=' '
ISAVE=IDMANU(I)
IF(ISAVE.EQ.'HPGL')IDMANU(I)='HP '
IF(ISAVE.EQ.'QMS')IDMANU(I)='QUIC'
IF(ISAVE.EQ.'TELA')IDMANU(I)='QUIC'
IF(ISAVE.EQ.'LASE')IDMANU(I)='PCL '
IF(ISAVE.EQ.'PS ')IDMANU(I)='POST'
K=K+1
IF(K.LE.NUMARG)IDMODE(I)=IHARG(K)
C FOLLOWING LINE MOVED TO BELOW TO CHECK FOR HP-GL MODEL NUMBERS
CCCCC IF(ISAVE.EQ.'HPGL')IDMODE(I)='GL '
IF(ISAVE.EQ.'LASE'.AND.IDMODE(I).EQ.'JET')IDMODE(I)=' '
IF(K.GT.NUMARG)IDMODE(I)=' '
K=K+1
IF(K.LE.NUMARG)IDMOD2(I)=IHARG(K)
IF(K.GT.NUMARG)IDMOD2(I)=' '
K=K+1
IF(K.LE.NUMARG)IDMOD3(I)=IHARG(K)
IF(K.GT.NUMARG)IDMOD3(I)=' '
C FOLLOWING BLOCK ADDED TO CHECK FOR HPGL MODEL NUMBERS
IF(ISAVE.EQ.'HPGL')THEN
IDMOD3(I)=IDMOD2(I)
IDMOD2(I)=IDMODE(I)
IDMODE(I)='GL '
END IF
C END CHANGES
CCCCC MARCH 1995. ADD FOLLOWING 4 LINES
IF(ISAVE.EQ.'EPS ')IDMANU(I)='POST'
IF(ISAVE.EQ.'EPS ')IDMODE(I)='ENCA'
IF(ISAVE.EQ.'ENCA')IDMANU(I)='POST'
IF(ISAVE.EQ.'ENCA')IDMODE(I)='ENCA'
C
CALL GRSEPP(I,
1IPL1NU,
1IPL2NU,
1IDMANU,IDMODE,IDMOD2,IDMOD3,
1IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT,
1IDNVOF,IDNHOF,
1IBUGO2,IFOUN2,IERROR)
CCCCC JUNE 1992. DISTINGUISH BETWEEN ON AND OPEN
IOPERA='OPEN'
GOTO1179
CCCCC GOTO1180
C
1180 CONTINUE
C
IOPERA=IDPOWE(I)
C FOLLOWING LINE ADDED MAU, 1990 (DEVICE ... CLOSE)
1179 CONTINUE
C
C FEBRUARY,1989. SEPARATE UNITS FOR GRAPHICS AND ALPHANUMERIC OUTPUT.
C SAME ON MOST SYSTEMS, BUT CDC NOS/VE REQUIRES DIFFERENT ATTRIBUTES
C FOR GRAPHICS AND ALPANUMERIC OUTPUT.
CCCCC IGENNU=IPR
IGENNU=IPRGR
C
IF(I.EQ.1)THEN
IGENID='SCRE'
IF(IDMANU(1).EQ.'LATE'.AND.ICAPSW.EQ.'ON')THEN
IGENNU=ICAPNU
IPRGR=IGENNU
ELSE
IGENNU=IPRGR
ENDIF
ENDIF
IF(I.EQ.2)IGENNU=IPL1NU
IF(I.EQ.2)IGENID='PLO1'
C
IF(I.EQ.3)IGENNU=IPL2NU
IF(I.EQ.3)IGENID='PLO2'
C
IF(I.GE.4)IGENNU=IDUNIT(I)
IF(I.GE.4)IGENID='GENE'
C
IGDFLG='OFF'
IF(IDMANU(I).EQ.'GD '.OR.IDMANU(I).EQ.'GDI ')IGDFLG='ON'
C
CCCCC IF(IGENNU.NE.IPR)
CCCCC IF(IGENNU.NE.IPRGR)
CALL DPDEP2(IOPERA,IGENNU,IGENID,IGDFLG,
1ICAPSW,
1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
C
IF(IERROR.EQ.'YES')GOTO9000
C
CCCCC JUNE 1992. FOLLOWINF LINE ADDED
IF(IOPERA.EQ.'OPEN')GOTO2000
IF(IOPERA.EQ.'ON')GOTO2000
GOTO2090
2000 CONTINUE
IMANUF=IDMANU(I)
IMODEL=IDMODE(I)
CCCCC AUGUST 1992. FOLLOWING 2 LINES ADDED FOR HPGL LASERJET
IMODE2=IDMOD2(I)
IMODE3=IDMOD3(I)
IGUNIT=IDUNIT(I)
C
C FEBRUARY 2006: DEVICE 1 LATEX OUTPUT SHOULD GO TO CAPTURE
C FILE IF CAPTURE SWITCH IS ON.
C
IF(IMANUF.EQ.'LATE' .AND. I.EQ.1 .AND. ICAPSW.EQ.'ON')THEN
IGUNIT=ICAPNU
ENDIF
C
IBUGG4=IBUGO2
C FOLLOWING LINE ADDED FEBRUARY, 1989 FOR POSTSCRIPT DEVICE
ANUMVP=IDNVPP(I)
C FOLLOWING LINE ADDED MARCH, 1990 FOR X11 DEVICE
ANUMHP=IDNHPP(I)
CCCCC THE FOLLOWING 2 LINES WERE ADDED MAY 1989
CCCCC TO FIX POSTSCRIPT TRANSLATION (ALAN) MAY 1989
IOFFSV=IDNVOF(I)
IOFFSH=IDNHOF(I)
CCCCC JUNE 1992. ONLY CALL FOR OPEN CASE (NOT FOR ON)
CCCCC CALL GRINDE
IF(IOPERA.EQ.'OPEN')CALL GRINDE
CCCCC FOLLOWING THREE LINES ADDED MARCH, 1990. X11 LIBRARY CAN
CCCCC DYNAMICALLY CHANGE THE NUMBER OF PICTURE POINTS.
IF(IMANUF.NE.'X11'.AND.IMANUF.NE.'QWIN')GOTO2090
IDNVPP(I)=ANUMVP
IDNHPP(I)=ANUMHP
2090 CONTINUE
C
IFOUND='YES'
CCCCC THE FOLLOWING 3 LINES WERE ADDED MAY 1992 (JJF)
IF(NUMARG.GE.1)THEN
IF(IARGT(1).EQ.'NUMB'.AND.IARG(1).EQ.3)GOTO1199
ENDIF
IF(IFEEDB.EQ.'OFF')GOTO1199
IF(IDMANU(I).EQ.'LATE' .AND. I.EQ.1 .AND. ICAPSW.EQ.'ON')
1GOTO1199
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1181)I
1181 FORMAT(' DEVICE --',I4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1182)IDUNIT(I)
1182 FORMAT(' I/O UNIT --',I4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1183)IDMANU(I)
1183 FORMAT(' MANUFACTURER --',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1184)IDMODE(I),IDMOD2(I),IDMOD3(I)
1184 FORMAT(' MODEL --',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1185)IDPOWE(I)
1185 FORMAT(' POWER --',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1186)IDCONT(I)
1186 FORMAT(' CONTINUITY --',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1187)IDCOLO(I)
1187 FORMAT(' COLOR --',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1188)IDNHPP(I)
1188 FORMAT(' HORIZONTAL PIXELS--',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1189)IDNVPP(I)
1189 FORMAT(' VERTICAL PIXELS--',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
IF(I.EQ.2)WRITE(ICOUT,1192)IPL1NA
1192 FORMAT(' FILE NAME (LOCAL)--',A80)
IF(I.EQ.2)CALL DPWRST('XXX','BUG ')
IF(I.EQ.3)WRITE(ICOUT,1193)IPL2NA
1193 FORMAT(' FILE NAME (LOCAL)--',A80)
IF(I.EQ.3)CALL DPWRST('XXX','BUG ')
1199 CONTINUE
GOTO9000
C
9000 CONTINUE
IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEMN')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('AT THE END OF DPDEMN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)IBUGO2
9013 FORMAT('IBUGO2 = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)IBUGG4,ISUBG4
9014 FORMAT('IBUGG4,ISUBG4 = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)IOPERA,IMANUF,IMODEL
9015 FORMAT('IOPERA,IMANUF,IMODEL = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9020)IFOUND,IERROR
9020 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9028)NUMARG
9028 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
DO9030I=1,NUMARG
WRITE(ICOUT,9031)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I)
9031 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I) = ',
1I8,2X,A4,2X,A4,2X,A4,2X,I8)
CALL DPWRST('XXX','BUG ')
9030 CONTINUE
WRITE(ICOUT,9041)IHARG(2),ISAVE,IDMANU(1),IDMODE(1)
9041 FORMAT('IHARG(2),ISAVE,IDMANU(1),IDMODE(1) = ',
1A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPDEPM(ICOM,IHARG,IHARG2,IARGT,IARG,NUMARG,
1IBUGO2,ISUBRO,IFOUND,IERROR)
C
C PURPOSE--DEFINE A PEN MAP (I.E., ASSOCIATE A COLOR WITH AN INDEX
C NUMBER FOR A DEVICE). THIS COMMAND IS INTENDED FOR PEN
C PLOTTERS HAVE PEN SLOTS WHICH CAN BE LOADED WITH WHATEVER
C COLOR PEN THE LOCAL OPERATOR DESIRES. DATAPLOT WILL USE
C A DEFAULT MAPPING. THIS COMMAND ALLOWS A USER CONFIGURABLE
C MAPPING TO OVERRIDE THE DEFAULT. CURRENTLY, THE HPGL, ZETA,
C AND CALCOMP DEVICES ARE SUPPORTED. THE OTHER 2 PLOTTERS
C CURRENTLY SUPPORTED (HP 7221 AND TEKTRONIX 4662) ARE
C RATHER OBSOLETE, SO DATAPLOT CODE HAS NOT BEEN UPDATED
C TO SUPPORT THEM THIS WAY (I.E., ONLY THE DEFAULT MAPPING
C AVAILABLE).
C INPUT ARGUMENTS--ICOM (A CHARACTER VECTOR)
C --IHARG (A CHARACTER VECTOR)
C --IHARG2 (A CHARACTER VECTOR)
C --IARGT (A CHARACTER VECTOR)
C --IARG (A CHARACTER VECTOR)
C --NUMARG
C OUTPUT ARGUMENTS--
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--MAY 1990.
C UPDATED --JANUARY 1991. REGIS SUPPORT
C UPDATED --JUNE 1991. ADD SHOW X11 COLORS COMMAND
C UPDATED --APRIL 1992. SHORTEN COLORS AFTER IZETPM(.)
C TO 4 CHARACTERS (BUT NO NOTE NOTED)
C UPDATED --AUGUST 1992. DATAPLOT COLORS HAVE BEEN
C REDEFINED IN A CONSISTENT
C MANNER FOR ALL DEVICES.
C UPDATE SHOW COLORS COMMANDS TO
C REFLECT THIS.
C UPDATED --SEPTEMBER 1993. SPLIT MULTI-LINE FORMATS
C UPDATED --MARCH 1995. ? AS SYNONYM FOR SHOW
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 ICOM
CHARACTER*4 IHARG
CHARACTER*4 IHARG2
CHARACTER*4 IARGT
C
CHARACTER*4 IBUGO2
CHARACTER*4 ISUBRO
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 ICOL
C
CHARACTER*40 ICPREH
CHARACTER*4 IRESP
C
CHARACTER*4 IGRAY
CHARACTER*4 IDEV
CHARACTER*4 IDEV2
C
CCCCC CHARACTER*25 IRGCLR(64)
CCCCC CHARACTER*8 IRGNAM(64)
CCCCC CHARACTER*25 IXCLR(67)
CCCCC CHARACTER*8 IXNAM(67)
CHARACTER*4 CJUNK
PARAMETER(MAXCLR=89)
CHARACTER*25 ICLR(MAXCLR)
CHARACTER*8 INAM(MAXCLR)
INTEGER J4027(MAXCLR)
INTEGER J4105(MAXCLR)
INTEGER JPLOT4(MAXCLR)
INTEGER JPLOT8(MAXCLR)
INTEGER J2622(MAXCLR)
INTEGER JCGM(MAXCLR)
INTEGER JSUN(MAXCLR)
INTEGER JX11(MAXCLR)
INTEGER JPC(MAXCLR)
INTEGER JREGIS(MAXCLR)
INTEGER JTEMP(MAXCLR)
INTEGER JREG2(64)
C
C---------------------------------------------------------------------
C
DIMENSION IHARG(*)
DIMENSION IHARG2(*)
DIMENSION IARGT(*)
DIMENSION IARG(*)
C
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCODV.INC'
INCLUDE 'DPCOBE.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C TEKTRONIX 4027
C
DATA (J4027(I),I=1,MAXCLR)/
1 0, 7, 1, 3, 2, 6, 5, 3, 4, 4,
2 2, 3, 3, 1, 7, 0, 3, 5, 3, 1,
3 3, 2, 6, 3, 6, 4, 2, 4, 4, 7,
4 1, 4, 0, 3, 2, 1, 3, 3, 2, 4,
5 6, 2, 3, 2, 6, 6, 3, 3, 5, 6,
6 2, 1, 6, 6, 4, 2, 6, 3, 3, 2,
7 3, 4, 4, 6, 6, 4, 2, 3, 3, 3,
8 3, 3, 3, 3, 2, 2, 2, 4, 4, 4,
9 5, 5, 5, 1, 1, 1, 6, 6, 6/
C TEKTRONIX 4105, GENERAL, GENERAL CODED
C
DATA (J4105(I),I=1,MAXCLR)/
1 1, 0, 2, 4, 3, 6, 2, 5, 7, 7,
2 3, 4, 4, 2, 0, 1, 4, 2, 4, 2,
3 4, 3, 6, 4, 6, 7, 3, 7, 7, 0,
4 2, 7, 1, 4, 3, 2, 4, 4, 3, 7,
5 6, 3, 4, 3, 6, 6, 4, 4, 2, 6,
6 3, 2, 6, 6, 7, 3, 6, 4, 4, 3,
7 4, 7, 7, 6, 6, 7, 3, 5, 4, 4,
8 4, 5, 5, 5, 3, 3, 3, 7, 7, 7,
9 7, 7, 7, 2, 2, 2, 6, 6, 6/
C
C PLOTTERS WITH 4 PENS (TEKTRONIX 4662, HP-7221, CALCOMP, ZETA, HP-GL)
C
DATA (JPLOT4(I),I=1,MAXCLR)/
1 1, 1, 2, 3, 4, 4, 2, 3, 2, 2,
2 4, 3, 3, 2, 1, 1, 3, 2, 3, 2,
3 3, 4, 2, 3, 2, 2, 4, 2, 2, 1,
4 2, 2, 1, 3, 4, 2, 3, 3, 4, 2,
5 2, 4, 3, 4, 2, 2, 3, 3, 2, 2,
6 4, 2, 2, 2, 2, 4, 2, 3, 3, 4,
7 3, 2, 2, 2, 2, 2, 4, 3, 3, 3,
8 3, 3, 3, 3, 4, 4, 4, 2, 2, 2,
9 2, 2, 2, 2, 2, 2, 4, 4, 4/
C
C PLOTTERS WITH 8 PENS (HP-GL, CALCOMP, ZETA)
C
DATA (JPLOT8(I),I=1,MAXCLR)/
1 1, 1, 2, 3, 4, 5, 6, 7, 8, 8,
2 4, 7, 3, 2, 1, 1, 3, 8, 3, 2,
3 3, 4, 5, 3, 5, 8, 4, 8, 8, 1,
4 2, 8, 1, 3, 4, 5, 7, 3, 4, 8,
5 5, 4, 7, 4, 5, 5, 3, 3, 6, 5,
6 4, 2, 5, 5, 8, 4, 5, 7, 3, 4,
7 3, 8, 8, 5, 5, 8, 4, 7, 3, 3,
8 3, 7, 7, 7, 4, 4, 4, 8, 8, 8,
9 6, 6, 6, 2, 2, 2, 5, 5, 5/
C
C HP-2622 AND RELATED TERMINALS
C
DATA (J2622(I),I=1,MAXCLR)/
1 7, 0, 1, 4, 2, 5, 3, 6, 3, 3,
2 2, 6, 4, 1, 0, 7, 6, 3, 4, 1,
3 4, 2, 5, 4, 5, 3, 2, 3, 3, 0,
4 1, 3, 7, 6, 2, 5, 6, 4, 2, 3,
5 5, 2, 6, 2, 5, 5, 4, 4, 3, 5,
6 2, 1, 5, 5, 3, 2, 5, 6, 4, 2,
7 4, 3, 3, 5, 5, 3, 2, 6, 4, 4,
8 4, 6, 6, 6, 2, 2, 2, 3, 3, 3,
9 3, 3, 3, 1, 1, 1, 5, 5, 5/
C
C DIRECT RGB DEVICES (CGM, POSTSCRIPT)
C
DATA (JCGM(I),I=1,MAXCLR)/
1 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,
2 11, 12, 13, 14, 15, 16, 17, 18, 19, 20,
3 21, 22, 23, 24, 25, 26, 27, 28, 29, 30,
4 31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
5 41, 42, 43, 44, 45, 46, 47, 48, 49, 50,
6 51, 52, 53, 54, 55, 56, 57, 58, 59, 60,
7 61, 62, 63, 64, 65, 66, 67, 68, 69, 70,
8 71, 72, 73, 74, 75, 76, 77, 78, 79, 80,
9 81, 82, 83, 84, 85, 86, 87, 88, 89/
C
C SUN
C
DATA (JSUN(I),I=1,MAXCLR)/
1 7, 5, 1, 3, 2, 6, 4, 3, 4, 4,
2 2, 3, 3, 1, 0, 7, 3, 4, 3, 1,
3 3, 2, 6, 3, 6, 4, 2, 4, 4, 0,
4 1, 4, 7, 3, 2, 6, 3, 3, 2, 4,
5 6, 2, 3, 2, 6, 6, 3, 3, 1, 6,
6 2, 1, 6, 6, 4, 2, 6, 3, 3, 2,
7 3, 4, 4, 6, 6, 4, 2, 3, 3, 3,
8 3, 3, 3, 3, 2, 2, 2, 4, 4, 4,
9 4, 4, 4, 1, 1, 1, 6, 6, 6/
C
C X11
C
DATA (JX11(I),I=1,MAXCLR)/
1 1, 0, 4, 5, 2, 6, 8, 7, 3, 9,
2 10, 11, 12, 13, 14, 15, 16, 17, 18, 19,
3 20, 21, 22, 23, 24, 25, 26, 27, 28, 29,
4 30, 31, 32, 33, 34, 35, 36, 37, 38, 39,
5 40, 41, 42, 43, 44, 45, 46, 47, 48, 49,
6 50, 51, 52, 53, 54, 55, 56, 57, 58, 59,
7 60, 61, 62, 63, 64, 65, 66, 67, 68, 69,
8 70, 71, 72, 73, 74, 75, 76, 77, 78, 79,
9 80, 81, 82, 83, 84, 85, 86, 87, 88/
C
C REGIS
C
DATA (JREGIS(I),I=1,MAXCLR)/
1 62, 3, 47, 4, 23, 39, 41, 18, 63, 64,
2 24, 8, 60, 51, 35, 37, 1, 3, 5, 17,
3 6, 25, 43, 7, 57, 19, 26, 20, 21, 35,
4 48, 38, 36, 9, 27, 40, 2, 10, 28, 22,
5 44, 29, 11, 30, 58, 49, 12, 13, 50, 42,
6 31, 45, 46, 57, 52, 32, 53, 14, 15, 33,
7 16, 54, 55, 56, 59, 61, 34, 18, 4, 4,
8 4, 18, 18, 18, 23, 23, 23, 63, 63, 63,
9 41, 41, 41, 47, 47, 47, 39, 39, 39/
DATA (JREG2(I),I=1,64)/
1 17, 37, 2, 4, 19, 21, 24, 12, 34, 38,
2 43, 47, 48, 58, 59, 60, 20, 8, 26, 28,
3 29, 40, 5, 11, 22, 27, 35, 39, 42, 44,
4 51, 56, 60, 67, 15, 33, 16, 32, 6, 36,
5 7, 50, 23, 41, 52, 53, 3, 31, 46, 49,
6 14, 55, 57, 62, 63, 64, 25, 45, 65, 13,
7 66, 1, 9, 10/
C
C IBM-PC
C
DATA (JPC(I),I=1,MAXCLR)/
1 15, 0, 4, 1, 2, 5, 14, 3, 14, 14,
2 2, 9, 1, 4, 8, 10, 3, 6, 9, 12,
3 1, 2, 5, 1, 5, 14, 2, 14, 14, 7,
4 12, 14, 10, 9, 2, 5, 11, 9, 2, 14,
5 5, 2, 9, 2, 13, 5, 1, 1, 4, 13,
6 2, 4, 5, 5, 14, 2, 5, 11, 1, 2,
7 1, 6, 14, 5, 5, 14, 2, 11, 1, 1,
8 1, 3, 3, 3, 2, 2, 2, 14, 14, 14,
9 14, 14, 14, 4, 4, 4, 5, 5, 5/
C
C
C COMMENT OUT FOLLOWING, USE SAME TABLES FOR ALL DEVICES
C
CCCCC DATA (IRGCLR(I),I=1,15)/
CCCCC1 'Aquamarine',
CCCCC2 'Aquamarine, Medium',
CCCCC3 'Black',
CCCCC4 'Blue',
CCCCC5 'Blue, Cadet',
CCCCC6 'Blue, Cornflower',
CCCCC7 'Blue, Dark Slate',
CCCCC8 'Blue, Light',
CCCCC9 'Blue, Light Steel',
CCCCC* 'Blue, Medium',
CCCCC1 'Blue, Medium Slate',
CCCCC2 'Blue, Midnight',
CCCCC3 'Blue, Navy',
CCCCC4 'Blue, Sky',
CCCCC5 'Blue, Slate'/
CCCCC DATA (IRGCLR(I),I=16,30)/
CCCCC1 'Blue, Steel',
CCCCC2 'Coral',
CCCCC3 'Cyan',
CCCCC4 'Firebrick',
CCCCC5 'Gold',
CCCCC6 'Goldenrod',
CCCCC7 'Goldenrod, Medium',
CCCCC8 'Green',
CCCCC9 'Green, Dark',
CCCCC* 'Green, Dark Olive',
CCCCC1 'Green, Forest',
CCCCC2 'Green, Lime',
CCCCC3 'Green, Medium Forest',
CCCCC4 'Green, Medium Sea',
CCCCC5 'Green, Medium Spring'/
CCCCC DATA (IRGCLR(I),I=31,45)/
CCCCC1 'Greeen, Pale',
CCCCC2 'Green, Sea',
CCCCC3 'Green, Spring',
CCCCC4 'Green, Yellow',
CCCCC5 'Grey, Dark Slate',
CCCCC6 'Grey, Dim',
CCCCC7 'Grey, Light',
CCCCC8 'Khaki',
CCCCC9 'Magenta',
CCCCC* 'Maroon',
CCCCC1 'Orange',
CCCCC2 'Orchid',
CCCCC3 'Orchid, Dark',
CCCCC4 'Orchid, Medium',
CCCCC5 'Pink'/
CCCCC DATA (IRGCLR(I),I=46,60)/
CCCCC1 'Plum',
CCCCC2 'Red',
CCCCC3 'Red, Indian',
CCCCC4 'Red, Medium Violet',
CCCCC5 'Red, Orange',
CCCCC6 'Red, Violet',
CCCCC7 'Salmon',
CCCCC8 'Sienna',
CCCCC9 'Tan',
CCCCC* 'Thistle',
CCCCC1 'Turquoise',
CCCCC2 'Turqoise, Dark',
CCCCC3 'Turqoise, Medium',
CCCCC4 'Violet',
CCCCC5 'Violet, Blue'/
CCCCC DATA (IRGCLR(I),I=61,64)/
CCCCC1 'Wheat',
CCCCC2 'White',
CCCCC3 'Yellow',
CCCCC4 'Yellow, Green'/
C
CCCCC DATA (IRGNAM(I),I=1,15)/
CCCCC1 'AQUA',
CCCCC2 '2',
CCCCC3 'BLACK',
CCCCC4 'BLUE',
CCCCC5 '5',
CCCCC6 '6',
CCCCC7 '7',
CCCCC8 '8',
CCCCC9 '9',
CCCCC* '10',
CCCCC1 '11',
CCCCC2 '12',
CCCCC3 '13',
CCCCC4 '14',
CCCCC5 '15'/
CCCCC DATA (IRGNAM(I),I=16,30)/
CCCCC1 '16',
CCCCC2 'CORAL',
CCCCC3 'CYAN',
CCCCC4 'FIREBRIC',
CCCCC5 'GOLD',
CCCCC6 '21',
CCCCC7 '22',
CCCCC8 'GREEN',
CCCCC9 '24',
CCCCC* '25',
CCCCC1 '26',
CCCCC2 '27',
CCCCC3 '28',
CCCCC4 '29',
CCCCC5 '30'/
CCCCC DATA (IRGNAM(I),I=31,45)/
CCCCC1 '31',
CCCCC2 '32',
CCCCC3 '33',
CCCCC4 '34',
CCCCC5 'GREY',
CCCCC6 '36',
CCCCC7 '37',
CCCCC8 'KHAKI',
CCCCC9 'MAGENTA',
CCCCC* 'MAROON',
CCCCC1 'ORANGE',
CCCCC2 'ORCHID',
CCCCC3 '43',
CCCCC4 '44',
CCCCC5 'PINK'/
CCCCC DATA (IRGNAM(I),I=46,60)/
CCCCC1 'PLUM',
CCCCC2 'RED',
CCCCC3 '48',
CCCCC4 '49',
CCCCC5 '50',
CCCCC6 '51',
CCCCC7 'SALMON',
CCCCC8 'SIENNA',
CCCCC9 'TAN',
CCCCC* 'THISTLE',
CCCCC1 'TURQUOIS',
CCCCC2 '57',
CCCCC3 '58',
CCCCC4 'VIOLET',
CCCCC5 '60'/
CCCCC DATA (IRGNAM(I),I=61,64)/
CCCCC1 'WHEAT',
CCCCC2 'WHITE',
CCCCC3 'YELLOW',
CCCCC4 '64'/
C
C AUGUST 1992.
C CHANGE IXCLR TO ICLR, IXNAM TO INAM, REORDER TO MATCH NEW ORDER.
C
CCCCC DATA (IXCLR(I),I=1,15)/
DATA (ICLR(I),I=1,15)/
1 'White',
2 'Black',
3 'Red',
4 'Blue',
5 'Green',
6 'Magenta',
7 'Orange',
8 'Cyan',
9 'Yellow',
* 'Yellow Green',
1 'Dark Green',
2 'Light Blue',
3 'Blue Violet',
4 'Violet Red',
5 'Dark Slate Gray'/
CCCCC DATA (IXCLR(I),I=16,30)/
DATA (ICLR(I),I=16,30)/
1 'Light Gray',
2 'Aquamarine',
3 'Brown',
4 'Cadet Blue',
5 'Coral',
6 'Cornflower Blue',
7 'Dark Olive Green',
8 'Dark Orchid',
9 'Dark Slate Blue',
* 'Dark Turquoise',
1 'Firebrick',
2 'Forest Green',
3 'Gold',
4 'Goldenrod',
5 'Gray'/
CCCCC DATA (IXCLR(I),I=31,45)/
DATA (ICLR(I),I=31,45)/
1 'Indian Red',
2 'Khaki',
3 'Dim Gray',
4 'Light Blue Steel',
5 'Lime Green',
6 'Maroon',
7 'Medium Aquamarine',
8 'Medium Blue',
9 'Medium Forest Green',
* 'Medium Goldenrod',
1 'Medium Orchid',
2 'Medium Sea Green',
3 'Medium Slate Blue',
4 'Medium Spring Green',
5 'Medium Turquoise'/
CCCCC DATA (IXCLR(I),I=46,60)/
DATA (ICLR(I),I=46,60)/
1 'Medium Violet Red',
2 'Midnight Blue',
3 'Navy',
4 'Orange Red',
5 'Orchid',
6 'Pale Green',
7 'Pink',
8 'Plum',
9 'Purple',
* 'Salmon',
1 'Sea Green',
2 'Sienna',
3 'Sky Blue',
4 'Slate Blue',
5 'Spring Green'/
CCCCC DATA (IXCLR(I),I=61,66)/
DATA (ICLR(I),I=61,75)/
1 'Steel Blue',
2 'Tan',
3 'Thistle',
4 'Turquoise',
5 'Violet',
6 'Wheat',
7 'Green Yellow',
8 'Light Cyan',
9 'Blue2',
* 'Blue3',
1 'Blue4',
2 'Cyan2',
3 'Cyan3',
4 'Cyan4',
5 'Green2'/
DATA (ICLR(I),I=76,MAXCLR)/
1 'Green3',
2 'Green4',
3 'Yellow2',
4 'Yellow3',
5 'Yellow4',
6 'Orange2',
7 'Orange3',
8 'Orange4',
9 'Red2',
* 'Red3',
1 'Red4',
2 'Magenta2',
3 'Magenta3',
4 'Magenta4'/
C
CCCCC DATA (IXNAM(I),I=1,15)/
DATA (INAM(I),I=1,15)/
1 'WHITE',
2 'BLACK',
3 'RED',
4 'BLUE',
5 'GREEN',
6 'MAGENTA',
7 'ORANGE',
8 'CYAN',
9 'YELLOW',
* 'YGRE',
1 'DGRE',
2 'LBLU',
3 'VBLU',
4 'VRED',
5 'DGRA'/
CCCCC DATA (IXNAM(I),I=16,30)/
DATA (INAM(I),I=16,30)/
1 'LGRA',
2 'AQUA',
3 'BROWN',
4 'CABL',
5 'CORAL',
6 'CBLU',
7 'DOGR',
8 'DORC',
9 'DSBL',
* 'DTUR',
1 'FIRE',
2 'FGRE',
3 'GOLD',
4 'GLDR',
5 'GRAY'/
CCCCC DATA (IXNAM(I),I=31,45)/
DATA (INAM(I),I=31,45)/
1 'IRED',
2 'KHAKI',
3 'DMGR',
4 'LSBL',
5 'LGRE',
6 'MAROON',
7 'MAQU',
8 'MBLU',
9 'MFGR',
* 'MGLD',
1 'MORC',
2 'MSGR',
3 'MSBL',
4 'MSPG',
5 'MTUR'/
CCCCC DATA (IXNAM(I),I=46,60)/
DATA (INAM(I),I=46,60)/
1 'MVRD',
2 'MDBL',
3 'NAVY',
4 'ORED',
5 'ORCHID',
6 'PGRE',
7 'PINK',
8 'PLUM',
9 'PURPLE',
* 'SALMON',
1 'SGRE',
2 'SIENNA',
3 'SKBL',
4 'SBLU',
5 'SPGR'/
CCCCC DATA (IXNAM(I),I=61,66)/
DATA (INAM(I),I=61,75)/
1 'STBL',
2 'TAN',
3 'THISTLE',
4 'TURQ',
5 'VIOLET',
6 'WHEAT',
7 'GYEL',
8 'LCYA',
9 'BLU2',
* 'BLU3',
1 'BLU4',
2 'CYA2',
3 'CYA3',
4 'CYA4',
5 'GRE2'/
DATA (INAM(I),I=76,MAXCLR)/
1 'GRE3',
2 'GRE4',
3 'YEL2',
4 'YEL3',
5 'YEL4',
6 'ORA2',
7 'ORA3',
8 'ORA4',
9 'RED2',
* 'RED3',
1 'RED4',
2 'MAG2',
3 'MAG3',
4 'MAG4'/
C
C-----START POINT-----------------------------------------------------
C
IFOUND='NO'
IERROR='NO'
IBUGG4='OFF'
ISUBG4='-999'
C
IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEPM')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('AT THE BEGINNING OF DPDEPM--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)IBUGO2
53 FORMAT('IBUGO2 = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,60)IFOUND,IERROR
60 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,68)NUMARG
68 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
DO70I=1,NUMARG
WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I)
71 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I) = ',
1I8,2X,A4,2X,A4,2X,A4,2X,I8)
CALL DPWRST('XXX','BUG ')
70 CONTINUE
WRITE(ICOUT,72)IHPGPF
72 FORMAT('IHPGPF=',A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
IF(ICOM.EQ.'HPGL')GOTO1100
IF(ICOM.EQ.'HP-G')GOTO1100
IF(ICOM.EQ.'ZETA')GOTO2100
IF(ICOM.EQ.'CALC')GOTO3100
IF(ICOM.EQ.'REGI')GOTO4100
IF(ICOM.EQ.'X11')GOTO5100
C ADD FOLLOWING LINE AUGUST 1992.
IF(ICOM.EQ.'SHOW')GOTO6100
C
C *****************************************
C ** HPGL CASE **
C *****************************************
C
1100 CONTINUE
IF(IHARG(1).EQ.'PEN'.AND.IHARG(2).EQ.'MAP')GOTO1110
IF(IHARG(1).EQ.'COLO'.AND.IHARG(2).EQ.'MAP')GOTO1110
IF(IHARG(1).EQ.'PEN')GOTO1120
IF(IHARG(1).EQ.'MAP')GOTO1120
IF(IHARG(1).EQ.'COLO')GOTO1120
C
1110 CONTINUE
IARGCL=3
IARGIN=4
GOTO1190
C
1120 CONTINUE
IARGCL=2
IARGIN=3
GOTO1190
C
1190 CONTINUE
IFOUND='YES'
IF(NUMARG.LT.IARGCL)GOTO1910
IF(IHARG(IARGCL).EQ.'AUTO')GOTO1500
IF(IHARG(IARGCL).EQ.'DEFA')GOTO1500
IF(IHARG(IARGCL).EQ.'ON ')GOTO1600
IF(IHARG(IARGCL).EQ.'OFF ')GOTO1700
IF(IHARG(IARGCL).EQ.'LIST')GOTO1800
IF(IHARG(IARGCL).EQ.'SHOW')GOTO1800
IF(IHARG(IARGCL).EQ.'? ')GOTO1800
IF(IHARG(IARGCL).EQ.'PRIN')GOTO1800
IF(NUMARG.LT.IARGIN)GOTO1920
C
ICOL=IHARG(IARGCL)
INDEX=IARG(IARGIN)
IF(INDEX.LT.1.OR.INDEX.GT.16)GOTO1930
IHPGPM(INDEX)=ICOL
IHPGPF='ON'
IF(IFEEDB.EQ.'OFF')WRITE(ICOUT,1490)IHPGPM(INDEX),INDEX
1490 FORMAT('COLOR ',A4,' WILL SELECT PEN ',I2,' FOR HP-GL')
IF(IFEEDB.EQ.'OFF')CALL DPWRST('XXX','BUG ')
GOTO9000
C
1500 CONTINUE
IF(IHPGCL.LE.4)THEN
IHPGPM(1)='BLACK'
IHPGPM(2)='RED '
IHPGPM(3)='BLUE'
IHPGPM(4)='GREEN'
DO1510J=5,16
ITEMP=MOD(J-1,4)+1
IHPGPM(J)=IHPGPM(ITEMP)
1510 CONTINUE
ELSE
IHPGPM(1)='BLACK'
IHPGPM(2)='RED '
IHPGPM(3)='BLUE'
IHPGPM(4)='GREEN'
IHPGPM(5)='MAGENTA'
IHPGPM(6)='ORANGE'
IHPGPM(7)='CYAN'
IHPGPM(8)='YELLOW'
DO1520J=9,16
ITEMP=J-8
IHPGPM(J)=IHPGPM(ITEMP)
1520 CONTINUE
END IF
GOTO9000
C
1600 CONTINUE
IHPGPF='ON'
GOTO9000
C
1700 CONTINUE
IHPGPF='OFF'
GOTO9000
C
1800 CONTINUE
WRITE(ICOUT,1805)
1805 FORMAT('FOR THE HP-GL PENPLOTTER:')
CALL DPWRST('XXX','BUG ')
DO1810I=1,16
WRITE(ICOUT,1811)IHPGPM(I),I
CALL DPWRST('XXX','BUG ')
1810 CONTINUE
1811 FORMAT('COLOR ',A8,' SET TO PEN ',I2)
GOTO9000
C
1910 CONTINUE
IERROR='YES'
WRITE(ICOUT,1911)
1911 FORMAT('NO COLOR SPECIFIED FOR HPGL PEN MAP COMMAND.')
CALL DPWRST('XXX','BUG ')
GOTO9000
1920 CONTINUE
IERROR='YES'
WRITE(ICOUT,1921)
1921 FORMAT('NO INDEX SPECIFIED FOR HPGL PEN MAP COMMAND.')
CALL DPWRST('XXX','BUG ')
GOTO9000
1930 CONTINUE
IERROR='YES'
WRITE(ICOUT,1931)
1931 FORMAT('INVALID INDEX SPECIFIED FOR HPGL PEN MAP COMMAND.')
CALL DPWRST('XXX','BUG ')
GOTO9000
C
C *****************************************
C ** ZETA CASE **
C *****************************************
C
2100 CONTINUE
IF(IHARG(1).EQ.'PEN'.AND.IHARG(2).EQ.'MAP')GOTO2110
IF(IHARG(1).EQ.'COLO'.AND.IHARG(2).EQ.'MAP')GOTO2110
IF(IHARG(1).EQ.'PEN')GOTO2120
IF(IHARG(1).EQ.'MAP')GOTO2120
IF(IHARG(1).EQ.'MAP')GOTO2120
IF(IHARG(1).EQ.'COLO')GOTO2120
C
2110 CONTINUE
IARGCL=3
IARGIN=4
GOTO2190
C
2120 CONTINUE
IARGCL=2
IARGIN=3
GOTO2190
C
2190 CONTINUE
IFOUND='YES'
IF(NUMARG.LT.IARGCL)GOTO2910
IF(IHARG(IARGCL).EQ.'AUTO')GOTO2500
IF(IHARG(IARGCL).EQ.'DEFA')GOTO2500
IF(IHARG(IARGCL).EQ.'ON ')GOTO2600
IF(IHARG(IARGCL).EQ.'OFF ')GOTO2700
IF(IHARG(IARGCL).EQ.'LIST')GOTO2800
IF(IHARG(IARGCL).EQ.'SHOW')GOTO2800
IF(IHARG(IARGCL).EQ.'? ')GOTO2800
IF(IHARG(IARGCL).EQ.'PRIN')GOTO2800
IF(NUMARG.LT.IARGIN)GOTO2920
C
ICOL=IHARG(IARGCL)
INDEX=IARG(IARGIN)
IF(INDEX.LT.1.OR.INDEX.GT.26)GOTO2930
IZETPM(INDEX)=ICOL
IZETPF='ON'
IF(IFEEDB.EQ.'OFF')WRITE(ICOUT,2490)IZETPM(INDEX),INDEX
2490 FORMAT('COLOR ',A4,' WILL SELECT PEN ',I2,' FOR ZETA')
IF(IFEEDB.EQ.'OFF')CALL DPWRST('XXX','BUG ')
GOTO9000
C
2500 CONTINUE
IF(IZETCL.LE.4)THEN
IZETPM(1)='BLAC'
IZETPM(2)='RED '
IZETPM(3)='BLUE'
IZETPM(4)='GREE'
DO2510J=5,16
ITEMP=MOD(J-1,4)+1
IZETPM(J)=IZETPM(ITEMP)
2510 CONTINUE
ELSE
IZETPM(1)='BLAC'
IZETPM(2)='RED '
IZETPM(3)='BLUE'
IZETPM(4)='GREE'
IZETPM(5)='MAGE'
IZETPM(6)='ORAN'
IZETPM(7)='CYAN'
IZETPM(8)='YELL'
DO2520J=9,16
ITEMP=J-8
IZETPM(J)=IZETPM(ITEMP)
2520 CONTINUE
END IF
GOTO9000
C
2600 CONTINUE
IZETPF='ON'
GOTO9000
C
2700 CONTINUE
IZETPF='OFF'
GOTO9000
C
2800 CONTINUE
WRITE(ICOUT,2805)
2805 FORMAT('FOR THE ZETA PENPLOTTER:')
CALL DPWRST('XXX','BUG ')
DO2810I=1,16
WRITE(ICOUT,2811)IZETPM(I),I
CALL DPWRST('XXX','BUG ')
2810 CONTINUE
2811 FORMAT('COLOR ',A8,' SET TO PEN ',I2)
GOTO9000
C
2910 CONTINUE
IERROR='YES'
WRITE(ICOUT,2911)
2911 FORMAT('NO COLOR SPECIFIED FOR ZETA PEN MAP COMMAND.')
CALL DPWRST('XXX','BUG ')
GOTO9000
2920 CONTINUE
IERROR='YES'
WRITE(ICOUT,2921)
2921 FORMAT('NO INDEX SPECIFIED FOR ZETA PEN MAP COMMAND.')
CALL DPWRST('XXX','BUG ')
GOTO9000
2930 CONTINUE
IERROR='YES'
WRITE(ICOUT,2931)
2931 FORMAT('INVALID INDEX SPECIFIED FOR ZETA PEN MAP COMMAND.')
CALL DPWRST('XXX','BUG ')
GOTO9000
C
C *****************************************
C ** CALCOMP CASE **
C *****************************************
C
3100 CONTINUE
IF(IHARG(1).EQ.'PEN'.AND.IHARG(2).EQ.'MAP')GOTO3110
IF(IHARG(1).EQ.'COLO'.AND.IHARG(2).EQ.'MAP')GOTO3110
IF(IHARG(1).EQ.'PEN')GOTO3120
IF(IHARG(1).EQ.'MAP')GOTO3120
IF(IHARG(1).EQ.'MAP')GOTO3120
IF(IHARG(1).EQ.'COLO')GOTO3120
C
3110 CONTINUE
IARGCL=3
IARGIN=4
GOTO3390
C
3120 CONTINUE
IARGCL=2
IARGIN=3
GOTO3390
C
3390 CONTINUE
IFOUND='YES'
IF(NUMARG.LT.IARGCL)GOTO3910
IF(IHARG(IARGCL).EQ.'AUTO')GOTO3500
IF(IHARG(IARGCL).EQ.'DEFA')GOTO3500
IF(IHARG(IARGCL).EQ.'ON ')GOTO3600
IF(IHARG(IARGCL).EQ.'OFF ')GOTO3700
IF(IHARG(IARGCL).EQ.'LIST')GOTO3800
IF(IHARG(IARGCL).EQ.'PRIN')GOTO3800
IF(IHARG(IARGCL).EQ.'SHOW')GOTO3800
IF(IHARG(IARGCL).EQ.'? ')GOTO3800
IF(NUMARG.LT.IARGIN)GOTO3920
C
ICOL=IHARG(IARGCL)
INDEX=IARG(IARGIN)
IF(INDEX.LT.1.OR.INDEX.GT.16)GOTO3930
ICALPM(INDEX)=ICOL
ICALPF='ON'
IF(IFEEDB.EQ.'OFF')WRITE(ICOUT,3490)ICALPM(INDEX),INDEX
3490 FORMAT('COLOR ',A4,' WILL SELECT PEN ',I2,' FOR CALCOMP ')
IF(IFEEDB.EQ.'OFF')CALL DPWRST('XXX','BUG ')
GOTO9000
C
3500 CONTINUE
IF(ICALCL.LE.4)THEN
ICALPM(1)='BLAC'
ICALPM(2)='RED '
ICALPM(3)='GREE'
ICALPM(4)='BLUE'
DO3510J=5,16
ITEMP=MOD(J-1,4)+1
ICALPM(J)=ICALPM(ITEMP)
3510 CONTINUE
ELSE
ICALPM(1)='BLAC'
ICALPM(2)='RED '
ICALPM(3)='GREE'
ICALPM(4)='BLUE'
ICALPM(5)='MAGE'
ICALPM(6)='ORAN'
ICALPM(7)='CYAN'
ICALPM(8)='YELL'
DO3520J=9,16
ITEMP=J-8
ICALPM(J)=ICALPM(ITEMP)
3520 CONTINUE
END IF
GOTO9000
C
3600 CONTINUE
ICALPF='ON'
GOTO9000
C
3700 CONTINUE
ICALPF='OFF'
GOTO9000
C
3800 CONTINUE
WRITE(ICOUT,3805)
3805 FORMAT('FOR THE CALCOMP PENPLOTTER:')
CALL DPWRST('XXX','BUG ')
DO3810I=1,16
WRITE(ICOUT,3811)ICALPM(I),I
CALL DPWRST('XXX','BUG ')
3810 CONTINUE
3811 FORMAT('COLOR ',A8,' SET TO PEN ',I2)
GOTO9000
C
3910 CONTINUE
IERROR='YES'
WRITE(ICOUT,3911)
3911 FORMAT('NO COLOR SPECIFIED FOR CALCOMP PEN MAP COMMAND.')
CALL DPWRST('XXX','BUG ')
GOTO9000
3920 CONTINUE
IERROR='YES'
WRITE(ICOUT,3921)
3921 FORMAT('NO INDEX SPECIFIED FOR CALCOMP PEN MAP COMMAND.')
CALL DPWRST('XXX','BUG ')
GOTO9000
3930 CONTINUE
IERROR='YES'
WRITE(ICOUT,3931)
3931 FORMAT('INVALID INDEX SPECIFIED FOR CALCOMP PEN MAP COMMAND.')
CALL DPWRST('XXX','BUG ')
GOTO9000
C
C *****************************************
C ** REGIS CASE **
C *****************************************
C
4100 CONTINUE
C
IF(IHARG(1).EQ.'PEN'.AND.IHARG(2).EQ.'MAP')GOTO4110
IF(IHARG(1).EQ.'COLO'.AND.IHARG(2).EQ.'MAP')GOTO4110
IF(IHARG(1).EQ.'PEN')GOTO4120
IF(IHARG(1).EQ.'MAP')GOTO4120
IF(IHARG(1).EQ.'COLO')GOTO4120
C
4110 CONTINUE
IARGCL=3
IARGIN=4
GOTO4190
C
4120 CONTINUE
IARGCL=2
IARGIN=3
GOTO4190
C
4190 CONTINUE
IFOUND='YES'
IF(NUMARG.LT.IARGCL)GOTO4910
IF(IHARG(IARGCL).EQ.'AUTO')GOTO4500
IF(IHARG(IARGCL).EQ.'DEFA')GOTO4500
IF(IHARG(IARGCL).EQ.'ON ')GOTO4500
IF(IHARG(IARGCL).EQ.'OFF ')GOTO9000
IF(IHARG(IARGCL).EQ.'LIST')GOTO4800
IF(IHARG(IARGCL).EQ.'SHOW')GOTO4800
IF(IHARG(IARGCL).EQ.'? ')GOTO4800
IF(IHARG(IARGCL).EQ.'PRIN')GOTO4800
IF(NUMARG.LT.IARGIN)GOTO4920
C
ICOL=IHARG(IARGCL)
INDEX=IARG(IARGIN)
IF(INDEX.LT.1.OR.INDEX.GT.16)GOTO4930
C
C AUGUST 1992. FOLLOWING LIST MODIFIED TO REFLECT CURRENTLY
C SUPPORTED NAMES AND INDICES.
C
DO4150I=1,MAXCLR
IF(ICOL.EQ.INAM(I)(1:4))THEN
JINDEX=I-1
GOTO4159
ENDIF
4150 CONTINUE
IF(ICOL.EQ.'DGRY')JINDEX=14
IF(ICOL.EQ.'LGRY')JINDEX=15
IF(ICOL.EQ.'GREY')JINDEX=29
IF(ICOL.EQ.'LRED')JINDEX=83
IF(ICOL.EQ.'LMAG')JINDEX=86
IF(ICOL.EQ.'SKYB')JINDEX=57
4159 CONTINUE
C
C CHECK FOR INDEX (0 THROUGH MAXCLR-1)
C
CJUNK=' '
DO4191I=0,9
WRITE(CJUNK(1:1),'(I1)')I
IF(ICOL(1:4).EQ.CJUNK(1:4))THEN
JINDEX=I
GOTO4194
ENDIF
4191 CONTINUE
4194 CONTINUE
CJUNK=' '
DO4196I=10,MAXCLR-1
WRITE(CJUNK(1:2),'(I2)')I
IF(ICOL(1:4).EQ.CJUNK(1:4))THEN
JINDEX=I
GOTO4199
ENDIF
4196 CONTINUE
4199 CONTINUE
C
C CHECK FOR GREY SCALE (G0 - G100)
C
IF(ICOL.EQ.'G0')JINDEX=1
IF(ICOL.EQ.'G100')JINDEX=0
IF(ICOL(1:1).EQ.'G')THEN
CJUNK=' '
DO4181I=1,9
WRITE(CJUNK(1:1),'(I1)')I
IF(ICOL(2:4).EQ.CJUNK(1:3))THEN
JINDEX=-I
GOTO4184
ENDIF
4181 CONTINUE
4184 CONTINUE
CJUNK=' '
DO4186I=10,99
WRITE(CJUNK(1:2),'(I2)')I
IF(ICOL(2:4).EQ.CJUNK(1:3))THEN
JINDEX=-I
GOTO4189
ENDIF
4186 CONTINUE
4189 CONTINUE
ENDIF
IF(JINDEX.LT.0)JINDEX=1
C
CCCCC IREGPM(INDEX)=JCOL
IREGPM(INDEX)=JREGIS(JINDEX)
IF(IFEEDB.EQ.'ON')WRITE(ICOUT,4490)INDEX,ICOL
4490 FORMAT('REGIS WILL USE COLOR MAP ',I2,' FOR COLOR ',A4)
IF(IFEEDB.EQ.'ON')CALL DPWRST('XXX','BUG ')
GOTO9000
C
4500 CONTINUE
CCCCC IREGPM(1)=62
CCCCC IREGPM(2)=63
CCCCC IREGPM(3)=47
CCCCC IREGPM(4)=3
CCCCC IREGPM(5)=23
CCCCC IREGPM(6)=18
CCCCC IREGPM(7)=4
CCCCC IREGPM(8)=41
CCCCC IREGPM(9)=59
CCCCC IREGPM(10)=39
CCCCC IREGPM(11)=64
CCCCC IREGPM(12)=54
CCCCC IREGPM(13)=20
CCCCC IREGPM(14)=51
CCCCC IREGPM(15)=37
CCCCC IREGPM(16)=35
IREGPM(1)=1
IREGPM(2)=9
IREGPM(3)=3
IREGPM(4)=2
IREGPM(5)=5
IREGPM(6)=8
IREGPM(7)=4
IREGPM(8)=7
IREGPM(9)=64
IREGPM(10)=6
IREGPM(11)=10
IREGPM(12)=62
IREGPM(13)=28
IREGPM(14)=14
IREGPM(15)=16
IREGPM(16)=15
IF(IFEEDB.EQ.'OFF')GOTO4519
WRITE(ICOUT,4506)
4506 FORMAT('FOR REGIS, THE DEFAULT COLORS ARE:')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4507)
4507 FORMAT('COLOR MAP COLOR NAME')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4508)
4508 FORMAT('========= ==========')
CALL DPWRST('XXX','BUG ')
DO4510I=1,IREGMC
CCCCC WRITE(ICOUT,4511)I,IRGCLR(IREGPM(I))
CCCCC CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4511)I,ICLR(IREGPM(I))
CALL DPWRST('XXX','BUG ')
4510 CONTINUE
4511 FORMAT(I2,8X,A25)
4519 CONTINUE
GOTO9000
C
4800 CONTINUE
IDEV='REGI'
IDEV2=' '
GOTO6200
C
4910 CONTINUE
IERROR='YES'
WRITE(ICOUT,4911)
4911 FORMAT('NO COLOR SPECIFIED FOR REGIS PEN MAP COMMAND.')
CALL DPWRST('XXX','BUG ')
GOTO9000
4920 CONTINUE
IERROR='YES'
WRITE(ICOUT,4921)
4921 FORMAT('NO INDEX SPECIFIED FOR REGIS PEN MAP COMMAND.')
CALL DPWRST('XXX','BUG ')
GOTO9000
4930 CONTINUE
IERROR='YES'
WRITE(ICOUT,4931)
4931 FORMAT('INVALID INDEX SPECIFIED FOR REGIS PEN MAP COMMAND.')
CALL DPWRST('XXX','BUG ')
GOTO9000
C
C *****************************************
C ** X11 CASE **
C ** CURRENTLY ONLY SUPPORT **
C ** X11 COLORS SHOW (OR SIMILIAR) **
C *****************************************
C
5100 CONTINUE
C
IF(IHARG(1).EQ.'PEN'.AND.IHARG(2).EQ.'MAP')GOTO5110
IF(IHARG(1).EQ.'COLO'.AND.IHARG(2).EQ.'MAP')GOTO5110
IF(IHARG(1).EQ.'PEN')GOTO5120
IF(IHARG(1).EQ.'MAP')GOTO5120
IF(IHARG(1).EQ.'COLO')GOTO5120
C
5110 CONTINUE
IARCL=3
GOTO5190
C
5120 CONTINUE
IARGCL=2
GOTO5190
C
5190 CONTINUE
IFOUND='YES'
IF(IHARG(IARGCL).EQ.'AUTO')GOTO5800
IF(IHARG(IARGCL).EQ.'DEFA')GOTO5800
IF(IHARG(IARGCL).EQ.'ON ')GOTO5800
IF(IHARG(IARGCL).EQ.'OFF ')GOTO9000
IF(IHARG(IARGCL).EQ.'LIST')GOTO5800
IF(IHARG(IARGCL).EQ.'SHOW')GOTO5800
IF(IHARG(IARGCL).EQ.'? ')GOTO5800
IF(IHARG(IARGCL).EQ.'PRIN')GOTO5800
GOTO5800
C
5800 CONTINUE
CCCCC THE FOLLOWING FORMAT STATEMENT WAS SPLIT SEPTEMBER 1993
CCCCC WRITE(ICOUT,5805)
WRITE(ICOUT,5801)
5801 FORMAT('COLORS FOR THE X11 TERMINAL:')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5802)
5802 FORMAT('COLOR',24X,'NAME',6X,'INDEX')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5803)
5803 FORMAT('=====',24X,'====',6X,'=====')
CALL DPWRST('XXX','BUG ')
IHELMX=24
NCPREH=0
ICPREH=' '
IRESP='YES'
IBUGO2='OFF'
NUMLPR=4
DO5810I=1,MAXCLR
NUMLPR=NUMLPR+1
IF(NUMLPR.GE.IHELMX)THEN
CALL DPMORE(NUMLPR,NCPREH,ICPREH,IRESP,IBUGO2,IERROR)
NUMLPR=0
IF(IRESP.EQ.'NO')GOTO9000
END IF
WRITE(ICOUT,5811)ICLR(I),INAM(I),I
CALL DPWRST('XXX','BUG ')
5810 CONTINUE
5811 FORMAT(A25,5X,A8,2X,I2)
GOTO9000
C
C *****************************************
C ** SHOW COLORS CASE **
C *****************************************
C
6100 CONTINUE
C
IF(IHARG(1).EQ.'COLO'.AND.NUMARG.LE.1)GOTO6800
IF(IHARG(1).EQ.'COLO'.AND.NUMARG.GE.2)GOTO6130
IF(IHARG(2).EQ.'COLO')GOTO6140
IF(IHARG(3).EQ.'COLO')GOTO6150
GOTO9000
C
6130 CONTINUE
IDEV=IHARG(2)
IDEV2=IHARG(3)
GOTO6200
C
6140 CONTINUE
IDEV=IHARG(1)
IDEV2=' '
GOTO6200
C
6150 CONTINUE
IDEV=IHARG(1)
IDEV2=IHARG(2)
GOTO6200
C
6200 CONTINUE
IFOUND='YES'
IGRAY='NO'
IF((IDEV.EQ.'TEKT'.AND.IDEV2.EQ.'4027'))THEN
DO6201I=1,MAXCLR
JTEMP(I)=J4027(I)
JINDEX=2
IF(JTEMP(I).EQ.0)JINDEX=1
IF(JTEMP(I).EQ.1)JINDEX=3
IF(JTEMP(I).EQ.2)JINDEX=5
IF(JTEMP(I).EQ.3)JINDEX=4
IF(JTEMP(I).EQ.4)JINDEX=9
IF(JTEMP(I).EQ.5)JINDEX=7
IF(JTEMP(I).EQ.6)JINDEX=54
IF(JTEMP(I).EQ.7)JINDEX=2
JTEMP(I)=JINDEX
6201 CONTINUE
ELSEIF((IDEV.EQ.'TEKT'.AND.IDEV2.EQ.'4105').OR.
1 (IDEV.EQ.'TEKT'.AND.IDEV2.EQ.'4113').OR.
1 (IDEV.EQ.'TEKT'.AND.IDEV2.EQ.'4115').OR.
1 (IDEV.EQ.'GENE'))THEN
DO6202I=1,MAXCLR
JTEMP(I)=J4105(I)
JINDEX=2
IF(JTEMP(I).EQ.0)JINDEX=2
IF(JTEMP(I).EQ.1)JINDEX=1
IF(JTEMP(I).EQ.2)JINDEX=3
IF(JTEMP(I).EQ.3)JINDEX=5
IF(JTEMP(I).EQ.4)JINDEX=4
IF(JTEMP(I).EQ.5)JINDEX=8
IF(JTEMP(I).EQ.6)JINDEX=6
IF(JTEMP(I).EQ.7)JINDEX=9
JTEMP(I)=JINDEX
6202 CONTINUE
ELSEIF((IDEV(1:2).EQ.'HP'.AND.IDEV2.EQ.'2622').OR.
1 (IDEV(1:2).EQ.'HP'.AND.IDEV2.EQ.'2623').OR.
1 (IDEV(1:2).EQ.'HP'.AND.IDEV2.EQ.'2627').OR.
1 (IDEV(1:2).EQ.'HP'.AND.IDEV2.EQ.'2647'))THEN
DO6205I=1,MAXCLR
JTEMP(I)=J2622(I)
JINDEX=2
IF(JTEMP(I).EQ.0)JINDEX=2
IF(JTEMP(I).EQ.1)JINDEX=3
IF(JTEMP(I).EQ.2)JINDEX=5
IF(JTEMP(I).EQ.3)JINDEX=9
IF(JTEMP(I).EQ.4)JINDEX=4
IF(JTEMP(I).EQ.5)JINDEX=6
IF(JTEMP(I).EQ.6)JINDEX=8
IF(JTEMP(I).EQ.7)JINDEX=1
JTEMP(I)=JINDEX
6205 CONTINUE
ELSEIF((IDEV.EQ.'TEKT'.AND.IDEV2.EQ.'4662').OR.
1 (IDEV.EQ.'CALC'.AND.ICALCL.LE.4).OR.
1 (IDEV.EQ.'ZETA'.AND.IZETCL.LE.4).OR.
1 (IDEV(1:2).EQ.'HP'.AND.IDEV2.EQ.'7221').OR.
1 (IDEV(1:2).EQ.'HP'.AND.IHPGCL.LE.4))THEN
DO6203I=1,MAXCLR
JTEMP(I)=JPLOT4(I)
JINDEX=1
IF(JTEMP(I).EQ.1)JINDEX=2
IF(JTEMP(I).EQ.2)JINDEX=3
IF(JTEMP(I).EQ.3)JINDEX=4
IF(JTEMP(I).EQ.4)JINDEX=5
JTEMP(I)=JINDEX
6203 CONTINUE
ELSEIF(
1 (IDEV.EQ.'CALC'.AND.ICALCL.GT.4).OR.
1 (IDEV.EQ.'ZETA'.AND.IZETCL.GT.4).OR.
1 (IDEV(1:2).EQ.'HP'.AND.IHPGCL.GT.4))THEN
DO6204I=1,MAXCLR
JTEMP(I)=JPLOT8(I)
JINDEX=2
IF(JTEMP(I).EQ.1)JINDEX=2
IF(JTEMP(I).EQ.2)JINDEX=3
IF(JTEMP(I).EQ.3)JINDEX=4
IF(JTEMP(I).EQ.4)JINDEX=5
IF(JTEMP(I).EQ.5)JINDEX=6
IF(JTEMP(I).EQ.6)JINDEX=7
IF(JTEMP(I).EQ.7)JINDEX=8
IF(JTEMP(I).EQ.8)JINDEX=9
JTEMP(I)=JINDEX
6204 CONTINUE
ELSEIF((IDEV.EQ.'CGM').OR.
1 (IDEV.EQ.'POST'))THEN
DO6206I=1,MAXCLR
JTEMP(I)=JCGM(I)
6206 CONTINUE
IF(IDEV.EQ.'POST')IGRAY='YES'
ELSEIF((IDEV.EQ.'SUN '))THEN
DO6207I=1,MAXCLR
JTEMP(I)=JSUN(I)
JINDEX=2
IF(JTEMP(I).EQ.0)JINDEX=2
IF(JTEMP(I).EQ.1)JINDEX=3
IF(JTEMP(I).EQ.2)JINDEX=5
IF(JTEMP(I).EQ.3)JINDEX=4
IF(JTEMP(I).EQ.4)JINDEX=9
IF(JTEMP(I).EQ.5)JINDEX=2
IF(JTEMP(I).EQ.6)JINDEX=6
IF(JTEMP(I).EQ.7)JINDEX=1
JTEMP(I)=JINDEX
6207 CONTINUE
ELSEIF((IDEV.EQ.'REGI'))THEN
DO6208I=1,MAXCLR
JTEMP(I)=JREGIS(I)
JINDEX=JREG2(JTEMP(I))
JTEMP(I)=JINDEX
6208 CONTINUE
ELSEIF((IDEV.EQ.'X11'))THEN
DO6209I=1,MAXCLR
JTEMP(I)=JCGM(I)
6209 CONTINUE
IGRAY='YES'
ELSEIF(IDEV.EQ.'PC'.OR.
1 IDEV.EQ.'IBM'.OR.
1 IDEV.EQ.'TURB'.OR.
1 IDEV.EQ.'VGA')THEN
DO6210I=1,MAXCLR
JTEMP(I)=JPC(I)
JINDEX=2
IF(JTEMP(I).EQ.0)JINDEX=2
IF(JTEMP(I).EQ.1)JINDEX=4
IF(JTEMP(I).EQ.2)JINDEX=5
IF(JTEMP(I).EQ.3)JINDEX=8
IF(JTEMP(I).EQ.4)JINDEX=3
IF(JTEMP(I).EQ.5)JINDEX=6
IF(JTEMP(I).EQ.6)JINDEX=18
IF(JTEMP(I).EQ.7)JINDEX=30
IF(JTEMP(I).EQ.8)JINDEX=15
IF(JTEMP(I).EQ.9)JINDEX=12
IF(JTEMP(I).EQ.10)JINDEX=16
IF(JTEMP(I).EQ.11)JINDEX=68
IF(JTEMP(I).EQ.12)JINDEX=84
IF(JTEMP(I).EQ.13)JINDEX=87
IF(JTEMP(I).EQ.14)JINDEX=9
IF(JTEMP(I).EQ.15)JINDEX=1
JTEMP(I)=JINDEX
6210 CONTINUE
ELSE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,6221)IDEV,IDEV2
6221 FORMAT('DEVICE ',A4,1X,A4,' NOT RECOGNIZED')
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,6255)IDEV,IDEV2
6255 FORMAT('THE FOLLOWING SHOWS THE COLOR MAPPING FOR DEVICE: ',
11X,A4,1X,A4)
CALL DPWRST('XXX','BUG ')
IF(IGRAY.EQ.'YES')THEN
WRITE(ICOUT,6261)
6261 FORMAT('THIS DEVICE SUPPORTS GRAY SCALE')
CALL DPWRST('XXX','BUG ')
ELSE
WRITE(ICOUT,6262)
6262 FORMAT('THIS DEVICE DOES NOT SUPPORT GRAY SCALE')
CALL DPWRST('XXX','BUG ')
ENDIF
C
CCCCC THE FOLLOWING FORMAT WAS SPLIT SEPTEMBER 1993
CCCCC WRITE(ICOUT,6270)
WRITE(ICOUT,6271)
6271 FORMAT(5X,24X,'DATAPLOT',2X,'DATAPLOT',2X,'DEVICE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,6272)
6272 FORMAT('COLOR',24X,'NAME',6X,'INDEX',5X,'COLOR')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,6273)
6273 FORMAT('=====',24X,'========',2X,'========',2X,'======')
CALL DPWRST('XXX','BUG ')
C
IHELMX=24
NCPREH=0
ICPREH=' '
IRESP='YES'
IBUGO2='OFF'
NUMLPR=6
DO6280I=1,MAXCLR
NUMLPR=NUMLPR+1
IF(NUMLPR.GE.IHELMX)THEN
CALL DPMORE(NUMLPR,NCPREH,ICPREH,IRESP,IBUGO2,IERROR)
NUMLPR=0
IF(IRESP.EQ.'NO')GOTO9000
END IF
WRITE(ICOUT,6281)ICLR(I),INAM(I),I-1,INAM(JTEMP(I))
CALL DPWRST('XXX','BUG ')
6280 CONTINUE
6281 FORMAT(A24,5X,A8,2X,I2,8X,A8)
GOTO9000
C
6800 CONTINUE
IFOUND='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING SECTION STATMENT WAS CHANGED SEPTEMBER 1993
CCCCC WRITE(ICOUT,6805)
WRITE(ICOUT,6801)
6801 FORMAT('THE FOLLOWING IS A LIST OF COLORS THAT DATAPLOT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,6802)
6802 FORMAT('CURRENTLY RECOGNIZES. ALL DEVICES RECOGNIZE THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,6803)
6803 FORMAT('SAME COLOR NAMES. HOWEVER, MOST DEVICES ONLY SUPPORT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,6804)
6804 FORMAT('A SUBSET OF THIS LIST. AN UNSUPPORTED COLOR WILL BE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,6805)
6805 FORMAT('MAPPED TO A SUPPORTED COLOR. IN ADDITION, GRAY SCALE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,6806)
6806 FORMAT('CAN BE REQUESTED BY USING G0 (BLACK) THROUGH G100')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,6807)
6807 FORMAT('(WHITE). HOWEVER, ONLY A FEW DEVICES ACTUALLY SUPPORT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,6808)
6808 FORMAT('GRAY SCALE (POSTSCRIPT, X11). OTHER DEVICES WILL MAP')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,6809)
6809 FORMAT('ALL GRAY SCALES TO EITHER BLACK OR WHITE.')
CALL DPWRST('XXX','BUG ')
C
C THE FOLLOWING FORMAT WAS SPLIT SEPTEMBER 1993
CCCCC WRITE(ICOUT,6811)
WRITE(ICOUT,6811)
6811 FORMAT('SUPPORTED COLORS:')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,6812)
6812 FORMAT('COLOR',24X,'NAME',6X,'INDEX')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,6813)
6813 FORMAT('=====',24X,'====',6X,'=====')
CALL DPWRST('XXX','BUG ')
C
IHELMX=24
NCPREH=0
ICPREH=' '
IRESP='YES'
IBUGO2='OFF'
NUMLPR=13
DO6820I=1,MAXCLR
NUMLPR=NUMLPR+1
IF(NUMLPR.GE.IHELMX)THEN
CALL DPMORE(NUMLPR,NCPREH,ICPREH,IRESP,IBUGO2,IERROR)
NUMLPR=0
IF(IRESP.EQ.'NO')GOTO9000
END IF
WRITE(ICOUT,6821)ICLR(I),INAM(I),I-1
6821 FORMAT(A24,5X,A8,2X,I2)
CALL DPWRST('XXX','BUG ')
6820 CONTINUE
GOTO9000
C
9000 CONTINUE
IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEPM')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('AT THE END OF DPDEPM--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)IBUGO2
9013 FORMAT('IBUGO2 = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)IBUGG4,ISUBG4
9014 FORMAT('IBUGG4,ISUBG4 = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9020)IFOUND,IERROR
9020 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9028)NUMARG
9028 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
DO9030I=1,NUMARG
WRITE(ICOUT,9031)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I)
9031 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I) = ',
1I8,2X,A4,2X,A4,2X,A4,2X,I8)
CALL DPWRST('XXX','BUG ')
9030 CONTINUE
WRITE(ICOUT,9032)IHPGPF
9032 FORMAT('IHPGPF=',A4)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPDEP2(IOPERA,IGENNU,IGENID,IGDFLG,
1ICAPSW,
1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
C
C PURPOSE--TURN ON OR TURN OFF
C (DEPENDING ON THE CONTENTS OF IOPERA)
C A DEVICE BY CARRYING OUT
C APPROPRIATE (OPEN OR CLOSE) FILE OPERATIONS.
C THIS IS USED FOR TURNING ON OR OFF
C ALTERNATE PLOTTING DEVICES.
C INPUT ARGUMENTS--IOPERA (A CHARACTER VARIABLE
C DESCRIBING THE DESIRED OPERATION
C (OPEN OR CLOSE)
C --IGENNU (AN INTEGER VALUE
C BY WHICH THE PLOT FILE/SUBFILE
C MAY BE REFERENCED IN A FORTRAN
C I/O STATEMENT.
C --IGENID (A CHARACTER VARIABLE
C CONTAINING IDENTIFICATION INFORMATION
C FOR THE PLOT FILE/SUBFILE
C (E.G., PLO1, PLO2, GENE, ETC.)
C --IANS (A CHARACTER VECTOR)
C --IWIDTH (AN INTEGER VARIABLE)
C OUTPUT ARGUMENTS--IFOUND ('YES' OR 'NO' )
C --IERROR ('YES' OR 'NO' )
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-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--JUNE 1978.
C UPDATED --APRIL 1979.
C UPDATED --OCTOBER 1980.
C UPDATED --OCTOBER 1981.
C UPDATED --FEBRUARY 1982.
C UPDATED --MAY 1982.
C UPDATED --JANUARY 1986.
C UPDATED --MAY 1988.
C UPDATED --MAY 1990. REACTIVE "CLOSE" CODE
C UPDATED --APRIL 1992. FIX BUG FOR "CLOSE"
C CALL GREXIT IF "CLOSE"
C UPDATED --MAY 1992. IFOUND NO --> YES
C UPDATED --MAY 1992. ADD DEBUG STATEMENTS
C UPDATED --MAY 1992. FIX IPL1CS,IPL2CS
C UPDATED --FEBRUARY 2001. IGDFLG
C UPDATED --SEPTEMBER 2002. HTML CAPTURE FOR GD AND
C SVG DEVICES
C UPDATED --JANUARY 2003. HTML CAPTURE FOR POSTSCRIPT
C UPDATED --JANUARY 2003. SUPPORT FOR IPSTDV (CONVERT
C POSTSCRIPT OUTPUT TO: JPEG,
C PDF, TIFF, PBM USING
C GHOSTSCRIPT
C UPDATED --SEPTEMBER 2003. LATEX CAPTURE FOR POSTSCRIPT
C UPDATED --FEBRUARY 2006. CALL GREXIT FOR DEVICE 1
C UPDATED --MARCH 2006. CHECK IF ANOTHER PROCESS
C MIGHT HAVE PLOT FILE LOCKED.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IOPERA
CHARACTER*4 IGENID
CHARACTER*4 IGDFLG
CHARACTER*4 IANS
CHARACTER*4 IBUGO2
CHARACTER*4 ISUBRO
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 ICAPSW
C
CHARACTER*80 IFILE
CHARACTER*12 ISTAT
CHARACTER*12 IFORM
CHARACTER*12 IACCES
CHARACTER*12 IPROT
CHARACTER*12 ICURST
CHARACTER*4 IENDFI
CHARACTER*4 IREWIN
CHARACTER*4 ISUBN0
CHARACTER*4 IERRFI
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
CHARACTER*256 ISTRIN
C
CHARACTER*80 IFIL2
CHARACTER*1 IQUOTE
CHARACTER*1 IBASLC
CHARACTER*4 IEXIST
CHARACTER*12 IFWRIT
CHARACTER*12 IFORMT
C
DIMENSION IANS(*)
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCOFO.INC'
INCLUDE 'DPCOF2.INC'
CCCCC FOLLOWING THREE INCLUDE FILES NEEDED TO CALL GREXIT
INCLUDE 'DPCOPA.INC'
INCLUDE 'DPCOPC.INC'
INCLUDE 'DPCOGR.INC'
C
INCLUDE 'DPCOSU.INC'
INCLUDE 'DPCOHO.INC'
INCLUDE 'DPCOST.INC'
C
LOGICAL IOPPLO
COMMON/OPNPLT/IOPPLO
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
CCCCC THE FOLLOWING LINE WAS FIXED MAY 1992 (JJF)
CCCCC AS PART OF FIX FOR PRINT PLOT COMMAND MAY 1992 (JJF)
CCCCC IFOUND='NO'
IFOUND='YES'
IERROR='NO'
C
ISUBN1='DPDE'
ISUBN2='P2 '
C
IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEP2')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPDEP2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IDEV,IOPERA,IGENNU,IGENID
52 FORMAT('IDEV,IOPERA,IGENNU,IGENID = ',
1A4,2X,A4,2X,I8,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)IBUGO2,IERROR
53 FORMAT('IBUGO2,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)IWIDTH
54 FORMAT('IWIDTH = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,55)(IANS(I),I=1,IWIDTH)
55 FORMAT('IANS(.) = ',120A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,61)IPL1NU
61 FORMAT('IPL1NU = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,62)IPL1NA
62 FORMAT('IPL1NA = ',A80)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,63)IPL1ST
63 FORMAT('IPL1ST = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,64)IPL1FO
64 FORMAT('IPL1FO = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,65)IPL1AC
65 FORMAT('IPL1AC = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,66)IPL1FO
66 FORMAT('IPL1FO = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,67)IPL1CS
67 FORMAT('IPL1CS = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,71)IPL2NU
71 FORMAT('IPL2NU = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,72)IPL2NA
72 FORMAT('IPL2NA = ',A80)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,73)IPL2ST
73 FORMAT('IPL2ST = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,74)IPL2FO
74 FORMAT('IPL2FO = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,75)IPL2AC
75 FORMAT('IPL2AC = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,76)IPL2FO
76 FORMAT('IPL2FO = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,77)IPL2CS
77 FORMAT('IPL2CS = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,81)IOPERA,IDEV,IPL1CS,IPL2CS
81 FORMAT('IOPERA,IDEV,IPL1CS,IPL2CS = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,83)IMANUF,IMODEL
83 FORMAT('IMANUF,IMODEL = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C **************************
C ** STEP 11-- **
C ** COPY OVER VARIABLES **
C **************************
C
ISTEPN='11'
IF(IBUGO2.EQ.'ON'.OR.ISUBRO.EQ.'DEP2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IGENID.EQ.'PLO1')GOTO1110
IF(IGENID.EQ.'PLO2')GOTO1120
IF(IGENID.EQ.'SCRE')GOTO1290
GOTO1120
C
1110 CONTINUE
IOUNIT=IPL1NU
IFILE=IPL1NA
ISTAT=IPL1ST
IFORM=IPL1FO
IACCES=IPL1AC
IPROT=IPL1PR
ICURST=IPL1CS
ISUBN0='DEP2'
IERRFI='NO'
GOTO1190
C
1120 CONTINUE
IOUNIT=IPL2NU
IFILE=IPL2NA
ISTAT=IPL2ST
IFORM=IPL2FO
IACCES=IPL2AC
IPROT=IPL2PR
ICURST=IPL2CS
ISUBN0='DEP2'
IERRFI='NO'
GOTO1190
C
1190 CONTINUE
IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEP2')GOTO1199
WRITE(ICOUT,1193)IOUNIT
1193 FORMAT('IOUNIT = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1194)IFILE
1194 FORMAT('IFILE = ',A80)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1195)ISTAT,IFORM,IACCES,IPROT,ICURST
1195 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',
1A12,2X,A12,2X,A12,2X,A12,2X,A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1196)ISUBN0,IERRFI
1196 FORMAT('ISUBN0,IERRFI = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
1199 CONTINUE
C
C *******************************************
C ** STEP 12-- **
C ** CHECK TO SEE IF PLOT FILE MAY EXIST **
C *******************************************
C
ISTEPN='12'
IF(IBUGO2.EQ.'ON'.OR.ISUBRO.EQ.'DEP2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(ISTAT.EQ.'NONE')GOTO1200
GOTO1290
1200 CONTINUE
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1211)
1211 FORMAT('***** ERROR IN DPDEP2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1212)
1212 FORMAT(' THE DESIRED PLOTS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1213)
1213 FORMAT(' CANNOT BE STORED ON FILE BECAUSE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1214)
1214 FORMAT(' THE REQUIRED SYSTEM MASS STORAGE FILE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1215)
1215 FORMAT(' WHICH STORES SUCH PLOTS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1216)
1216 FORMAT(' IS NOT AVAILABLE AT THIS INSTALLATION.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1217)ISTAT,IPL1ST,IPL2ST
1217 FORMAT('ISTAT,IPL1ST,IPL2ST = ',A12,2X,A12,2X,A12)
CALL DPWRST('XXX','BUG ')
GOTO9000
1290 CONTINUE
C
C *****************************************
C ** STEP 20-- **
C ** BRANCH TO THE APPROPRIATE CASE-- **
C ** 1) OPEN THE PLOT FILE; **
C ** 2) CLOSE THE PLOT FILE. **
C *****************************************
C
ISTEPN='20'
IF(IBUGO2.EQ.'ON'.OR.ISUBRO.EQ.'DEP2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IOPERA.EQ.'ON ')GOTO2100
CCCCC FOLLOWING LINE ADDED MAY, 1990.
IF(IOPERA.EQ.'OPEN')GOTO2100
GOTO2200
C
C ******************************************
C ** STEP 21-- **
C ** OPEN THE PLOT FILE. **
C ** PRIOR VERSIONS OF DATAPLOT HAD **
C ** OPEN, BUT NO REWIND **
C ******************************************
C
C NOTE: MARCH 2006. ADD A CALL TO DPINF2 TO CHECK IF FILE
C CAN BE OPENED IN "WRITE" MODE. UNDER WINDOWS (INTEL
C COMPILER), ANOTHER DATAPLOT PROCESS CAN HAVE A LOCK
C ON THE PLOT FILE WHICH CAN CAUSE THE CURRENT SESSION
C TO HANG.
C
C NOTE: UNFORTUNETELY, DPINQF2 DOESN'T QUITE DO THE TRICK
C (IT SIMPLY RETURNS AN "UNKNOWN" STATUS REGARDLESS
C OF WHETHER A PREVIOUS PROCESS WAS RUNNING OR NOT).
C FOR WINDOWS, WE REDEFINED THE "PROTECTION" OPTION
C TO BE "WRITE" FOR THE PLOT FILES. THIS WILL CAUSE
C THE OPEN TO FAIL IF ANOTHER PROCESS HAS THE PLOT
C FILE LOCKED. ONE ADDITIONAL COMPLICATION IS THAT
C DATAPLOT WILL TRY TO OPEN THE FILE IN THE DATAPLOT
C DIRECTORIES IF THE INITIAL OPEN FAILS. FOR THIS
C REASON, WE WILL SET A FLAG IN A COMMON BLOCK SO
C THAT DPOPFI WILL KNOW NOT TO TRY AND OPEN THE
C FILE IN THE DATAPLOT SUB-DIRECTORIES.
C
2100 CONTINUE
ISTEPN='21'
IF(IBUGO2.EQ.'ON'.OR.ISUBRO.EQ.'DEP2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IDEV=IGENID
C MAY, 1988. DON'T OPEN IF ALREADY OPEN
IF(IDEV.EQ.'PLO1'.AND.IPL1CS.EQ.'OPEN')GOTO2199
IF(IDEV.EQ.'PLO2'.AND.IPL2CS.EQ.'OPEN')GOTO2199
IF(IDEV.EQ.'SCRE')GOTO2199
C
IF(IGDFLG.EQ.'ON')GOTO2198
C
IFGPID=0
2109 CONTINUE
IOPPLO=.TRUE.
IREWIN='OFF'
CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
1IREWIN,ISUBN0,IERRFI,IBUGO2,ISUBRO,IERROR)
IOPPLO=.FALSE.
IF(IERROR.EQ.'YES')THEN
IF(IGENID.EQ.'PLO1')IPL1CS='CLOSED'
IF(IGENID.EQ.'PLO2')IPL2CS='CLOSED'
C
IF(IFGPID.EQ.1)THEN
WRITE(ICOUT,2181)
2181 FORMAT('***** WARNING: DATAPLOT STILL UNABLE TO OPEN ',
1 'THE PLOT FILE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2183)
2183 FORMAT(' THE PLOT FILE WILL NOT BE GENERATED.')
CALL DPWRST('XXX','BUG ')
GOTO9000
ENDIF
C
IFGPID=1
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2111)
2111 FORMAT('***** WARNING: DATAPLOT UNABLE TO OPEN THE PLOT FILE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2113)IFILE
2113 FORMAT(' ',A80)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2115)
2115 FORMAT(' IN WRITE MODE. LIKELY CAUSES ARE:')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2117)
2117 FORMAT(' 1. YOU ARE TRYING TO OPEN THE FILE IN A ',
1 'READ ONLY DIRECTORY.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2119)
2119 FORMAT(' 2. ANOTHER DATAPLOT PROCESS IS ACTIVE AND ',
1 'HAS A LOCK ON THE FILE.')
CALL DPWRST('XXX','BUG ')
IF(IHOST1.EQ.'IBM-' .AND. ICOMPI.EQ.'MS-F')THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2121)
2121 FORMAT(' 3. ON THE WINDOWS PLATFORM, IF A PREVIOUS ',
1 'GUI SESSION DID NOT CLOSE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2123)
2123 FORMAT(' CLEANLY, THE UNDERLYING DATAPLOT ',
1 'EXECUTABLE MAY STILL BE RUNNING')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2125)
2125 FORMAT(' AND HAVE A LOCK ON THE FILE. TO CLEAR ',
1 'THESE, AFTER EXITING THE CURRENT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2127)
2127 FORMAT(' ENTER "CNTRL-ALT-DEL" TO BRING UP THE ',
1 'TASK MANAGER AND THEN SELECT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2129)
2129 FORMAT(' "PROCESSES". DELETE ANY OCCURENCES OF ',
1 '"DPLAHEY.EXE".')
CALL DPWRST('XXX','BUG ')
ENDIF
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
C
IF(ITMPFI.EQ.'PID')THEN
IFGPID=1
WRITE(ICOUT,2131)
2131 FORMAT(' DATAPLOT WILL APPEND THE PROCESS-ID TO THE ',
1 'FILE NAME AND TRY AGAIN.')
CALL DPWRST('XXX','BUG ')
CALL DPPID2(IPID,ISUBRO,IERROR)
IF(IPID.LE.0)THEN
IERROR='YES'
GOTO9000
ELSE
2139 CONTINUE
IF(IPID.LT.10)THEN
NCH=1
ELSEIF(IPID.LT.100)THEN
NCH=2
ELSEIF(IPID.LT.1000)THEN
NCH=3
ELSEIF(IPID.LT.10000)THEN
NCH=4
ELSEIF(IPID.LT.100000)THEN
NCH=5
ELSEIF(IPID.LT.1000000)THEN
NCH=6
ELSE
IPID=IPID/10
GOTO2139
ENDIF
IFORMT=' '
IFORMT='(I )'
WRITE(IFORMT(3:3),'(I1)')NCH
ENDIF
IF(IGENID.EQ.'PLO1')THEN
NLAST=80-NCH-1
DO2141I=72,1,-1
NLAST=I
IF(IPL1NA(I:I).NE.' ')GOTO2149
2141 CONTINUE
2149 CONTINUE
IPL1NA(NLAST+1:NLAST+1)='.'
WRITE(IPL1NA(NLAST+2:NLAST+NCH-1),IFORMT)IPID
IFILE(1:80)=IPL1NA(1:80)
ELSEIF(IGENID.EQ.'PLO2')THEN
NLAST=80-NCH-1
DO2151I=72,1,-1
NLAST=I
IF(IPL2NA(I:I).NE.' ')GOTO2159
2151 CONTINUE
2159 CONTINUE
IPL2NA(NLAST+1:NLAST+1)='.'
WRITE(IPL2NA(NLAST+2:NLAST+NCH+1),IFORMT)IPID
IFILE(1:80)=IPL2NA(1:80)
ENDIF
GOTO2109
ELSE
IERROR='YES'
GOTO9000
ENDIF
ENDIF
C
IF(IFGPID.EQ.1)THEN
WRITE(ICOUT,2161)
2161 FORMAT(' PLOT FILE OPENED AS:')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2163)IFILE
2163 FORMAT(' ',A80)
CALL DPWRST('XXX','BUG ')
ENDIF
C
2198 CONTINUE
IF(IGENID.EQ.'PLO1')IPL1CS='OPEN'
IF(IGENID.EQ.'PLO2')IPL2CS='OPEN'
C
2199 CONTINUE
GOTO9000
C
C ******************************************
C ** STEP 22-- **
C ** CLOSE THE PLOT FILE. **
C ** PRIOR VERSIONS OF DATAPLOT HAD **
C ** ENDFILE, BUT NO REWIND AND NO CLOSE **
C ******************************************
C
C MAY, 1990. REACTIVATE CLOSE FILE (WITH "SYSTEM" COMMAND, CAN NOW
C PRINT A PLOT FILE WITHOUT EXITING DATAPLOT ON SOME SYSTEMS, BUT
C NEED PLOT FILE TO BE CLOSED IN ORDER TO DO SO).
C
2200 CONTINUE
C
IDEV=IGENID
C
ISTEPN='22'
IF(IBUGO2.EQ.'ON'.OR.ISUBRO.EQ.'DEP2')THEN
CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
WRITE(ICOUT,2211)IOPERA,IDEV,IPL1CS,IPL2CS
2211 FORMAT('IOPERA,IDEV,IPL1CS,IPL2CS = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
ENDIF
C
IF(IOPERA.NE.'CLOS')GOTO9000
C
C FOLLOWING 3 LINES MAY, 1990. DON'T CLOSE IF NOT OPEN
IF(IDEV.EQ.'PLO1'.AND.IPL1CS.NE.'OPEN')GOTO2299
IF(IDEV.EQ.'PLO2'.AND.IPL2CS.NE.'OPEN')GOTO2299
C
CCCCC APRIL 1992. NEED TO CALL GREXIT IF CLOSE DEVICE. NEEDED IN
CCCCC PARTICULAR FOR LASER PRINTERS SUCH AS POSTSCRIPT TO GET THE
CCCCC LAST PAGE PRINTED.
IF(IDEV.EQ.'PLO1')IJUNK=2
IF(IDEV.EQ.'PLO2')IJUNK=3
IF(IDEV.EQ.'SCRE')IJUNK=1
IF(IJUNK.LE.0 .OR. IJUNK.GT.3)GOTO9000
IMANUF=IDMANU(IJUNK)
IMODEL=IDMODE(IJUNK)
IMODE2=IDMOD2(IJUNK)
IMODE3=IDMOD3(IJUNK)
IGCODE=IDCODE(IJUNK)
IGUNIT=IDUNIT(IJUNK)
NUMHPP=IDNHPP(IJUNK)
ANUMHP=NUMHPP
NUMVPP=IDNVPP(IJUNK)
ANUMVP=NUMVPP
IGCOLO=IDCOLO(IJUNK)
CCCCC ADD FOLLOWING LINE MARCH 1997.
IGFONT=IDFONT(IJUNK)
IGBAUD=IDBAUD(IJUNK)
ISOFT=IDSOFT(IJUNK)
ISOFT2=IDSOF2(IJUNK)
ISOFT3=IDSOF3(IJUNK)
C
IF(IDEV.EQ.'SCRE'.AND.ICAPSW.EQ.'ON')THEN
IGUNIT=IGENNU
ENDIF
C
CALL GREXIT
IF(IDEV.EQ.'SCR')GOTO9000
C
IENDFI='ON'
IREWIN='OFF'
C MAY, 1990. UNCOMMENTED FOLLOWING 3 LINES
IF(IGDFLG.EQ.'ON')GOTO2298
CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGO2,ISUBRO,IERROR)
IF(IERRFI.EQ.'YES')GOTO9000
2298 CONTINUE
C MAY, 1988. DO ENDFILE ONLY IN DPEXIT.
C MAY, 1990. UNCOMMENT
C APRIL, 1992. ENDFILE OF CLOSED FILE CAUSES PC VERSION TO
C BOMB. ENDFILE SHOULD BE HANDLED (IF NEEDED) IN DPCLFI.
CCCCC ENDFILE IOUNIT
C
CCCCC THE FOLLOWING 2 LINES WERE FIXED MAY 1992 (JJF)
CCCCC IPL1CS='CLOSED'
CCCCC IPL2CS='CLOSED'
IF(IDEV.EQ.'PLO1')IPL1CS='CLOSED'
IF(IDEV.EQ.'PLO2')IPL2CS='CLOSED'
CCCCC JANUARY 2003. FOR POSTSCRIPT OUTPUT, IF IPSTDV SET TO
CCCCC JPEG, PDG, TIFF, PBM, PNG, PPM, OR PPN, THEN USE GHOSTSCRIPT
CCCCC TO MAKE THE APPROPRIATE IMAGE FILE (ORIGINAL POSTSCRIPT FILE
CCCCC WILL NOT BE CHANGED). IF CAPTURE HTML HAS BEEN ENTERED,
CCCCC HANDLE SEPARATELY.
C
IF(ICAPSW.EQ.'OFF'.OR.ICAPTY.NE.'HTML'.OR.ICAPTY.NE.'LATE')THEN
ICON=0
IF(IPSTDV.EQ.'JPEG')ICON=1
IF(IPSTDV.EQ.'TIFF')ICON=1
IF(IPSTDV.EQ.'PDF ')ICON=1
IF(IPSTDV.EQ.'PBM ')ICON=1
IF(IPSTDV.EQ.'PNG ')ICON=1
IF(IPSTDV.EQ.'PGM ')ICON=1
IF(IPSTDV.EQ.'PPM ')ICON=1
IF(IPSTDV.EQ.'PNM ')ICON=1
IF(IMANUF.EQ.'POST'.AND.ICON.GT.0)THEN
C
C CURRENTLY ONLY AVAILABLE FOR WINDOWS AND UNIX.
C
C DETERMINE NAME FOR JPEG FILE
C
IF(IOPSY1.EQ.'UNIX' .OR. IHOST1.EQ.'IBM-')THEN
ILAST=80
IPEROD=0
DO2641I=80,1,-1
IF(IFILE(I:I).NE.' ')THEN
ILAST=I
GOTO2645
ENDIF
2641 CONTINUE
GOTO9000
2645 CONTINUE
DO2646I=80,1,-1
IF(IFILE(I:I).EQ.'.')THEN
IPEROD=I
GOTO2649
ENDIF
2646 CONTINUE
2649 CONTINUE
IF(IPEROD.GT.0)THEN
IFIL2=' '
IFIL2(1:IPEROD)=IFILE(1:IPEROD)
IF(IPSTDV.EQ.'JPEG')THEN
IFIL2(IPEROD+1:IPEROD+3)='jpg'
NCTEMP=IPEROD+3
ELSEIF(IPSTDV.EQ.'PDF ')THEN
IFIL2(IPEROD+1:IPEROD+3)='pdf'
NCTEMP=IPEROD+3
ELSEIF(IPSTDV.EQ.'TIFF')THEN
IFIL2(IPEROD+1:IPEROD+3)='tif'
NCTEMP=IPEROD+3
ELSEIF(IPSTDV.EQ.'PBM ')THEN
IFIL2(IPEROD+1:IPEROD+3)='pbm'
NCTEMP=IPEROD+3
ELSEIF(IPSTDV.EQ.'PGM ')THEN
IFIL2(IPEROD+1:IPEROD+3)='pgm'
NCTEMP=IPEROD+3
ELSEIF(IPSTDV.EQ.'PNG ')THEN
IFIL2(IPEROD+1:IPEROD+3)='png'
NCTEMP=IPEROD+3
ELSEIF(IPSTDV.EQ.'PNM ')THEN
IFIL2(IPEROD+1:IPEROD+3)='pnm'
NCTEMP=IPEROD+3
ELSEIF(IPSTDV.EQ.'PPM ')THEN
IFIL2(IPEROD+1:IPEROD+3)='ppm'
NCTEMP=IPEROD+3
ENDIF
ELSE
IF(ILAST.GT.76)GOTO9000
IFIL2=' '
IFIL2(1:ILAST)=IFILE(1:ILAST)
IF(IPSTDV.EQ.'JPEG')THEN
IFIL2(ILAST+1:ILAST+4)='.jpg'
NCTEMP=ILAST+4
ELSEIF(IPSTDV.EQ.'PDF ')THEN
IFIL2(ILAST+1:ILAST+4)='.pdf'
NCTEMP=ILAST+4
ELSEIF(IPSTDV.EQ.'TIFF')THEN
IFIL2(ILAST+1:ILAST+4)='.tif'
NCTEMP=ILAST+4
ELSEIF(IPSTDV.EQ.'PBM ')THEN
IFIL2(ILAST+1:ILAST+4)='.pbm'
NCTEMP=ILAST+4
ELSEIF(IPSTDV.EQ.'PGM ')THEN
IFIL2(ILAST+1:ILAST+4)='.pgm'
NCTEMP=ILAST+4
ELSEIF(IPSTDV.EQ.'PNG ')THEN
IFIL2(ILAST+1:ILAST+4)='.png'
NCTEMP=ILAST+4
ELSEIF(IPSTDV.EQ.'PNM ')THEN
IFIL2(ILAST+1:ILAST+4)='.pnm'
NCTEMP=ILAST+4
ELSEIF(IPSTDV.EQ.'PPM ')THEN
IFIL2(ILAST+1:ILAST+4)='.ppm'
NCTEMP=ILAST+4
ENDIF
ENDIF
C
C RUN GHOSTSCRIPT TO CONVERT FROM POSTSCRIPT TO REQUESTED FORMAT
C
IQUOTE='"'
CALL DPCONA(92,IBASLC)
ISTRIN=' '
IF(NCGHPA.GT.0)THEN
ISTRIN(1:NCGHPA)=IGSTPA(1:NCGHPA)
N0=NCGHPA
IF(IGSTPA(NCGHPA:NCGHPA).NE.IBASLC)THEN
N0=N0+1
ISTRIN(N0:N0)=IBASLC
ENDIF
ELSE
N0=0
ENDIF
IF(IOPSY1.EQ.'UNIX')THEN
N0=N0+1
ISTRIN(N0:N0+2)='gs '
N0=N0+2
ELSEIF(IHOST1.EQ.'IBM-')THEN
N0=N0+1
ISTRIN(N0:N0+12)='GSWIN32C.EXE '
N0=N0+13
ENDIF
N0=N0+1
ISTRIN(N0:N0+29)='-dNOPAUSE -dBATCH -q -sDEVICE='
N0=N0+30
IF(IPSTDV.EQ.'JPEG')THEN
ISTRIN(N0:N0+4)='jpeg '
N0=N0+5
ELSEIF(IPSTDV.EQ.'PDF ')THEN
ISTRIN(N0:N0+8)='pdfwrite '
N0=N0+9
ELSEIF(IPSTDV.EQ.'TIFF')THEN
ISTRIN(N0:N0+7)='tifflzw '
N0=N0+8
ELSEIF(IPSTDV.EQ.'PBM ')THEN
ISTRIN(N0:N0+3)='pbm '
N0=N0+4
ELSEIF(IPSTDV.EQ.'PGM ')THEN
ISTRIN(N0:N0+3)='pgm '
N0=N0+4
ELSEIF(IPSTDV.EQ.'PNG ')THEN
IF(IHOST1.EQ.'IBM-')THEN
ISTRIN(N0:N0+5)='png16 '
N0=N0+6
ELSE
ISTRIN(N0:N0+3)='png '
N0=N0+4
ENDIF
ELSEIF(IPSTDV.EQ.'PNM ')THEN
ISTRIN(N0:N0+3)='pnm '
N0=N0+4
ELSEIF(IPSTDV.EQ.'PPM ')THEN
ISTRIN(N0:N0+3)='ppm '
N0=N0+4
ENDIF
ISTRIN(N0:N0+12)='-sOutputFile='
N0=N0+13
ISTRIN(N0:N0)=IQUOTE
N0=N0+1
ISTRIN(N0:N0+NCTEMP-1)=IFIL2(1:NCTEMP)
N0=N0+NCTEMP
ISTRIN(N0:N0)=IQUOTE
N0=N0+1
ISTRIN(N0:N0)=' '
N0=N0+1
ISTRIN(N0:N0+ILAST-1)=IFILE(1:ILAST)
N0=N0+ILAST-1
CALL DPSYS2(ISTRIN,N0,ISUBRO,IERROR)
ENDIF
C
ENDIF
ENDIF
C
CCCCC SEPTEMBER 2002. IF,
CCCCCC 1) CAPTURE SWITCH ON
CCCCC 2) CAPTURE IS IN HTML FORMAT
CCCCC 3) DEVICE IS SVG OR GD
CCCCC THEN PUT A "![]()
')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
C
IF(IMANUF.EQ.'GD')THEN
WRITE(ICOUT,2307)
2307 FORMAT('![DATAPLOT GRAPH]()
CALL DPWRST()
')
CALL DPWRST('XXX','WRIT')
ELSEIF(IMANUF.EQ.'SVG')THEN
WRITE(ICOUT,2327)
2327 FORMAT('