SUBROUTINE DPECHO(IANS,IWIDTH)
C
C PURPOSE--ECHO THE CURRENT COMMAND LINE.
C THIS IS ESPECIALLY USEFUL WHEN A SET OF
C DATAPLOT COMMANDS ARE 'ADDED' IN BULK
C FROM A MACRO ON MASS STORAGE.
C INPUT ARGUMENTS--IANS (A HOLLERITH VECTOR WHOSE
C I-TH ELEMENT CONTAINS THE
C I-TH CHARACTER OF THE
C ORIGINAL INPUT COMMAND LINE.
C --IWIDTH (AN INTEGER VARIABLE WHICH
C CONTAINS THE NUMBER OF CHARACTERS
C IN THE ORIGINAL COMMAND LINE.
C OUTPUT ARGUMENTS--NONE
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 1978.
C UPDATED --NOVEMBER 1980.
C UPDATED --MARCH 1982.
C UPDATED --MAY 1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IANS
C
CHARACTER*4 ISTAR
CHARACTER*4 IBLANK
C
C---------------------------------------------------------------------
C
DIMENSION IANS(*)
C
C---------------------------------------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
ISTAR='*'
IBLANK=' '
C
ISTART=1
IF(IWIDTH.LE.0)GOTO240
DO200I=1,IWIDTH
IREV=IWIDTH-I+1
IF(IANS(IREV).NE.' ')GOTO220
200 CONTINUE
ISTOP=ISTART
GOTO260
220 CONTINUE
ISTOP=IREV
GOTO260
240 CONTINUE
ISTOP=1
GOTO260
260 CONTINUE
C
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
ISTOP8=ISTOP+8
WRITE(ICOUT,261)(ISTAR,I=1,ISTOP8)
261 FORMAT(6X,124A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,261)ISTAR,ISTAR,IBLANK,IBLANK,
1(IANS(I),I=ISTART,ISTOP),IBLANK,IBLANK,ISTAR,ISTAR
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,261)(ISTAR,I=1,ISTOP8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
C
290 CONTINUE
RETURN
END
SUBROUTINE DPECSW(IHARG,NUMARG,
1IECHO,IFOUND,IERROR)
C
C PURPOSE--SPECIFY THE ECHO SWITCH WHICH IN TURN
C DETERMINES WHETHER ENTERED COMMANDS WILL BE
C ECHOED BACK (IN A BOX FOR ACCENTUATION)
C TO THE TERMINAL.
C THIS CAPABILITY IS USEFUL FOR MONITORING THE
C PROGRESS OF A MACRO WHICH HAS BEEN ADDED
C FROM MASS STORAGE.
C THE SPECIFIED ECHO SWITCH SPECIFICATION
C WILL BE PLACED IN THE HOLLERITH VARIABLE IECHO.
C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR)
C --NUMARG (AN INTEGER VARIABLE)
C OUTPUT ARGUMENTS--IECHO (A HOLLERITH VARIABLE)
C --IFOUND ('YES' OR 'NO' )
C --IERROR ('YES' OR 'NO' )
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-921-3651
C NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C OF THE NATIONAL BUREAU OF STANDARDS.
C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C MODIFIED, OR OTHERWISE USED IN A CONTEXT
C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--82/7
C ORIGINAL VERSION--OCTOBER 1978.
C UPDATED --NOVEMBER 1980.
C UPDATED --MARCH 1982.
C UPDATED --MAY 1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IHARG
CHARACTER*4 IECHO
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 IHOLD
C
C---------------------------------------------------------------------
C
DIMENSION IHARG(*)
C
C---------------------------------------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
IFOUND='NO'
IERROR='NO'
C
1110 CONTINUE
IF(NUMARG.LE.0)GOTO1150
IF(IHARG(NUMARG).EQ.'ON')GOTO1150
IF(IHARG(NUMARG).EQ.'OFF')GOTO1160
IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
IF(IHARG(NUMARG).EQ.'DEFA')GOTO1160
GOTO1150
C
1150 CONTINUE
IHOLD='ON'
GOTO1180
C
1160 CONTINUE
IHOLD='OFF'
GOTO1180
C
1180 CONTINUE
IFOUND='YES'
IECHO=IHOLD
C
IF(IFEEDB.EQ.'OFF')GOTO1189
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1181)IECHO
1181 FORMAT('THE ECHO SWITCH HAS JUST BEEN SET TO ',
1A4)
CALL DPWRST('XXX','BUG ')
1189 CONTINUE
GOTO1199
C
1199 CONTINUE
RETURN
END
SUBROUTINE DPEINL(ICAPSW,IFORSW,ISUBRO,IBUGA2,IBUGA3,IBUGQ,
1 IFOUND,IERROR)
C
C PURPOSE--PERFORM AN INTERLABORATORY STUDY ACCORDING TO
C ASTM E 691 STANDARD.
C
C THE DATA CONSISTS OF DATA GROUPED BY MATERIALS AND
C LABS. EACH COMINATION OF MATERIAL AND LAB IS REFERRED
C TO AS A CELL AND IT IS ASSUMED THAT THE CELLS HAVE
C THE SAME NUMBER OF REPLICATIONS.
C
C THERE ARE 4 BASIC
C QUANTITIES COMPUTED:
C 1) REPEATABILITY STANDARD DEVIATION
C 2) REPRODUCABILITY STANDARD DEVIATION
C 3) H CONSISTENCY STATISTIC
C 4) K CONSISTENCY STATISTIC
C THESE ARE ALL NOW AVAILABLE AS SEPARATE COMMANDS.
C THE PRIMARY FUNCTION OF THIS
C
C E691 INTERLAB Y LABID MATID
C
C COMMAND IS TO GENERATE THE FOLLOWING 4 TABLES BASED
C ON THESE BASIC QUANTITIES:
C 1) FOR EACH MATERIAL, PRINT
C A) LAB ID
C B) Cell Average
C C) Cell Standard Deviation
C D) Deviation of Cell Average from Overall Average
C (for that material)
C E) h Consistency Statistic for each cell
C F) k Consistency Statistic for each cell
C 2) A TWO-WAY TABLE (ROWS ARE LABS AND COLUMNS ARE
C MATERIALS) OF THE h CONSISTENCY STATISTIC
C 3) A TWO-WAY TABLE (ROWS ARE LABS AND COLUMNS ARE
C MATERIALS) OF THE k CONSISTENCY STATISTIC
C 4) A TABLE SUMMARIZING THE PRECISION STATISTICS
C FOR EACH MATERIAL.
C WRITTEN BY--JAMES FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C INFORMATION TECHNOLOGY LABORATORY
C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLGY
C GAITHERSBURG, MD 20899-8980
C PHONE--301-975-2855
C NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--2005/2
C ORIGINAL VERSION--FEBRUARY 2005.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES----------------
C
CHARACTER*4 ICAPSW
CHARACTER*4 IFORSW
CHARACTER*4 ISUBRO
CHARACTER*4 IWRITE
CHARACTER*4 IBUGA2
CHARACTER*4 IBUGA3
CHARACTER*4 IBUGQ
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 IH
CHARACTER*4 IH2
CHARACTER*4 IHWUSE
CHARACTER*4 MESSAG
CHARACTER*4 ICASEQ
CHARACTER*4 IHLEFT
CHARACTER*4 IHLEF2
CHARACTER*4 IHRIGH
CHARACTER*4 IHRIG2
CHARACTER*4 IHRI21
CHARACTER*4 IHRI22
CHARACTER*4 IHFACT
CHARACTER*4 IHFAC2
C
CHARACTER*4 ISUBN0
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
REAL KCV
C
C----------------------------------------------------------------
C
INCLUDE 'DPCOPA.INC'
C
DIMENSION Y1(MAXOBV)
DIMENSION Y2(MAXOBV)
DIMENSION Y3(MAXOBV)
C
DIMENSION Z1(MAXOBV)
DIMENSION Z2(MAXOBV)
DIMENSION Z3(MAXOBV)
DIMENSION Z4(MAXOBV)
DIMENSION Z5(MAXOBV)
DIMENSION Z6(MAXOBV)
DIMENSION Z7(MAXOBV)
DIMENSION Z8(MAXOBV)
DIMENSION Z9(MAXOBV)
DIMENSION Z10(MAXOBV)
DIMENSION Z11(MAXOBV)
DIMENSION Z12(MAXOBV)
DIMENSION Z13(MAXOBV)
DIMENSION Z14(MAXOBV)
C
INCLUDE 'DPCOZZ.INC'
EQUIVALENCE (GARBAG(IGARB1),Y1(1))
EQUIVALENCE (GARBAG(IGARB2),Y2(1))
EQUIVALENCE (GARBAG(IGARB3),Y3(1))
EQUIVALENCE (GARBAG(IGARB4),Z1(1))
EQUIVALENCE (GARBAG(IGARB5),Z2(1))
EQUIVALENCE (GARBAG(IGARB7),Z3(1))
EQUIVALENCE (GARBAG(IGARB9),Z4(1))
EQUIVALENCE (GARBAG(JGAR11),Z5(1))
EQUIVALENCE (GARBAG(JGAR12),Z6(1))
EQUIVALENCE (GARBAG(JGAR13),Z7(1))
EQUIVALENCE (GARBAG(JGAR14),Z8(1))
EQUIVALENCE (GARBAG(JGAR15),Z9(1))
EQUIVALENCE (GARBAG(JGAR16),Z10(1))
EQUIVALENCE (GARBAG(JGAR17),Z11(1))
EQUIVALENCE (GARBAG(JGAR18),Z12(1))
EQUIVALENCE (GARBAG(JGAR19),Z13(1))
EQUIVALENCE (GARBAG(JGAR20),Z14(1))
C
DIMENSION ICOLIV(10)
DIMENSION NIV(10)
C
C-----COMMON----------------------------------------------------
C
INCLUDE 'DPCOSU.INC'
INCLUDE 'DPCOHO.INC'
INCLUDE 'DPCOHK.INC'
INCLUDE 'DPCODA.INC'
INCLUDE 'DPCOST.INC'
C
C----------------------------------------------------------------
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='DPEI'
ISUBN2='LA '
C
MAXCP1=MAXCOL+1
MAXCP2=MAXCOL+2
MAXCP3=MAXCOL+3
MAXCP4=MAXCOL+4
MAXCP5=MAXCOL+5
MAXCP6=MAXCOL+6
C
IERROR='NO'
C
MAXV2=100
MINN2=2
C
ICASEQ='UNKN'
C
C *********************************************
C ** TREAT THE E691 INTERLAB ANALYSIS CASE **
C *********************************************
C
IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'EINL')THEN
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPEINL--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ
52 FORMAT('IBUGA2,IBUGA3,IBUGQ = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
ENDIF
C
C ***************************
C ** STEP 1-- **
C ** EXTRACT THE COMMAND **
C ***************************
C
ISTEPN='1'
IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'EINL')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(NUMARG.GE.2.AND.ICOM.EQ.'E691'.AND.
1 IHARG(1).EQ.'INTE'.AND.IHARG(2).EQ.'ANAL')THEN
ILASTC=2
ELSEIF(NUMARG.GE.1.AND.ICOM.EQ.'E691'.AND.
1 IHARG(1).EQ.'INTE')THEN
ILASTC=1
ELSE
IFOUND='NO'
GOTO9000
ENDIF
C
IFOUND='YES'
CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
C
C **************************************************
C ** STEP 2-- **
C ** CHECK FOR THE PROPER NUMBER OF INPUT **
C ** ARGUMENTS. **
C **************************************************
C
ISTEPN='2'
IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'EINL')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
MINNA=2
MAXNA=100
CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,
1IERROR)
IF(IERROR.EQ.'YES')GOTO9000
C
C ********************************************
C ** STEP 3-- **
C ** CHECK THE VALIDITY OF ARGUMENT 1 **
C ** (THIS WILL BE THE RESPONSE VARIABLE) **
C ********************************************
C
ISTEPN='3'
IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'EINL')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IHLEFT=IHARG(1)
IHLEF2=IHARG2(1)
IHWUSE='V'
MESSAG='YES'
CALL CHECKN(IHLEFT,IHLEF2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
ICOLL=IVALUE(ILOCV)
NLEFT=IN(ILOCV)
C
C *************************************************
C ** STEP 4-- **
C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS**
C ** (NLEFT) **
C ** FOR THE RESPONSE VARIABLE IS 2 OR MORE. **
C *************************************************
C
ISTEPN='4'
IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'EINL')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(NLEFT.LT.MINN2)THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,311)
311 FORMAT('***** ERROR IN E691 INTERLAB ANALYSIS--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,312)
312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR WHICH AN')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,313)
313 FORMAT(' E691 INTERLAB ANALYSIS WAS TO HAVE BEEN')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,315)MINN2
315 FORMAT(' PERFORMED MUST BE ',I8,' OR LARGER; SUCH WAS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,316)NLEFT
316 FORMAT(' NOT THE CASE HERE. NLEFT = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,318)
318 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)THEN
WRITE(ICOUT,319)(IANS(I),I=1,MAX(IWIDTH,80))
319 FORMAT(80A1)
CALL DPWRST('XXX','BUG ')
ENDIF
IERROR='YES'
GOTO9000
ENDIF
C
C *****************************************
C ** STEP 5-- **
C ** CHECK TO SEE THE TYPE CASE-- **
C ** 1) UNQUALIFIED (THAT IS, FULL); **
C ** 2) SUBSET/EXCEPT; OR **
C ** 3) FOR. **
C *****************************************
C
ISTEPN='5'
IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'EINL')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ICASEQ='FULL'
ILOCQ=NUMARG+1
IF(NUMARG.LT.1)GOTO490
DO400J=1,NUMARG
J1=J
IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO410
IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO410
IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO420
400 CONTINUE
GOTO490
410 CONTINUE
ICASEQ='SUBS'
ILOCQ=J1
GOTO490
420 CONTINUE
ICASEQ='FOR'
ILOCQ=J1
GOTO490
490 CONTINUE
IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'EINL')THEN
WRITE(ICOUT,491)NUMARG,ILOCQ
491 FORMAT('NUMARG,ILOCQ = ',2I8)
CALL DPWRST('XXX','BUG ')
ENDIF
C
C ******************************************
C ** STEP 6-- **
C ** CHECK FOR A VALID NUMBER **
C ** OF VARIABLES (3). **
C ** CHECK THE VALIDITY OF EACH **
C ** OF THE VARIABLES (THAT IS, FOR EACH **
C ** OF THE VARIABLES, DOES THE NAME **
C ** EXIST IN THE TABLE? DOES THE NUMBER**
C ** OF ELEMENTS AGREE WITH THE NUMBER **
C ** OF ELEMENTS IN THE FIRST VARIABLE? **
C ******************************************
C
ISTEPN='6'
IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'EINL')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
NUMVAR=ILOCQ-1
IF(NUMVAR.LT.3 .OR. NUMVAR.GT.100)THEN
WRITE(ICOUT,511)
511 FORMAT('***** ERROR IN E691 INTERLAB ANALYSIS--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,512)
512 FORMAT(' FOR AN E691 INTERLAB ANALYSIS, THE NUMBER OF')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,514)MAXV2
514 FORMAT(' VARIABLES MUST BE AT LEAST 3 AND AT MOST ',
1 I8,' ;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,515)
515 FORMAT(' SUCH WAS NOT THE CASE HERE; THE SPECIFIED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,517)NUMVAR
517 FORMAT(' NUMBER OF VARIABLES WAS ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,518)
518 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)THEN
WRITE(ICOUT,519)(IANS(I),I=1,MAX(80,IWIDTH))
519 FORMAT(80A1)
CALL DPWRST('XXX','BUG ')
ENDIF
IERROR='YES'
GOTO9000
ENDIF
C
DO530IFAC=2,NUMVAR
J=IFAC
IHFACT=IHARG(J)
IHFAC2=IHARG2(J)
IHWUSE='V'
MESSAG='YES'
CALL CHECKN(IHFACT,IHFAC2,IHWUSE,
1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
IF(IFAC.EQ.2)THEN
IHRIGH=IHFACT
IHRIG2=IHFAC2
ELSEIF(IFAC.EQ.3)THEN
IHRI21=IHFACT
IHRI22=IHFAC2
ENDIF
ICOLIV(IFAC-1)=IVALUE(ILOCV)
NIV(IFAC-1)=IN(ILOCV)
IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'EINL')THEN
WRITE(ICOUT,532)IFAC,IHFACT,IHFAC2,ICOLIV(IFAC-1),NIV(IFAC-1)
532 FORMAT('IFAC,IHFACT,IHFAC2,ICOLIV(IFAC-1),NIV(IFAC-1) = ',
1 I8,2X,A4,2X,A4,I8,I8)
CALL DPWRST('XXX','BUG ')
ENDIF
530 CONTINUE
C
DO540IFAC=1,NUMVAR-1
IF(NIV(IFAC).NE.NLEFT)THEN
WRITE(ICOUT,551)
551 FORMAT('***** ERROR IN E691 INTERLAB ANALYSIS--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,552)
552 FORMAT(' FOR A E691 INTERLAB ANALYSIS, THE NUMBER OF')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,554)
554 FORMAT(' ELEMENTS IN EACH VARIABLE SHOULD BE THE SAME;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,557)
557 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
DO565IFAC2=1,NUMVAR
IF(IFAC2.EQ.1)THEN
NELEM=NLEFT
ELSE
NELEM=NIV(IFAC2-1)
ENDIF
WRITE(ICOUT,566)IHARG(IFAC2),IHARG2(IFAC2),NELEM
566 FORMAT(' VARIABLE',A4,A4,' HAS ',I8,' ELEMENTS')
CALL DPWRST('XXX','BUG ')
565 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,567)
567 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)THEN
WRITE(ICOUT,568)(IANS(I),I=1,MAX(80,IWIDTH))
568 FORMAT(80A1)
CALL DPWRST('XXX','BUG ')
ENDIF
IERROR='YES'
GOTO9000
ENDIF
540 CONTINUE
C
C *****************************************
C ** STEP 7-- **
C ** BRANCH TO THE APPROPRIATE SUBCASE; **
C ** THEN FORM THE RESPONSE VARIABLE **
C ** AND THE FACTORS **
C *****************************************
C
ISTEPN='7'
IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'EINL')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(ICASEQ.EQ.'FULL')GOTO610
IF(ICASEQ.EQ.'SUBS')GOTO620
IF(ICASEQ.EQ.'FOR')GOTO630
C
610 CONTINUE
DO615I=1,NLEFT
ISUB(I)=1
615 CONTINUE
NQ=NLEFT
GOTO650
C
620 CONTINUE
NIOLD=NLEFT
CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
NQ=NIOLD
GOTO650
C
630 CONTINUE
NIOLD=NLEFT
CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
NQ=NFOR
GOTO650
C
650 CONTINUE
J=0
IMAX=NLEFT
IF(NQ.LT.NLEFT)IMAX=NQ
DO660I=1,IMAX
IF(ISUB(I).EQ.0)GOTO660
J=J+1
C
IJ=MAXN*(ICOLL-1)+I
IF(ICOLL.LE.MAXCOL)Y1(J)=V(IJ)
IF(ICOLL.EQ.MAXCP1)Y1(J)=PRED(I)
IF(ICOLL.EQ.MAXCP2)Y1(J)=RES(I)
IF(ICOLL.EQ.MAXCP3)Y1(J)=YPLOT(I)
IF(ICOLL.EQ.MAXCP4)Y1(J)=XPLOT(I)
IF(ICOLL.EQ.MAXCP5)Y1(J)=X2PLOT(I)
IF(ICOLL.EQ.MAXCP6)Y1(J)=TAGPLO(I)
C
IFAC=1
ICOLR=ICOLIV(IFAC)
IJ=MAXN*(ICOLR-1)+I
IF(ICOLR.LE.MAXCOL)Y2(J)=V(IJ)
IF(ICOLR.EQ.MAXCP1)Y2(J)=PRED(I)
IF(ICOLR.EQ.MAXCP2)Y2(J)=RES(I)
IF(ICOLR.EQ.MAXCP3)Y2(J)=YPLOT(I)
IF(ICOLR.EQ.MAXCP4)Y2(J)=XPLOT(I)
IF(ICOLR.EQ.MAXCP5)Y2(J)=X2PLOT(I)
IF(ICOLR.EQ.MAXCP6)Y2(J)=TAGPLO(I)
C
IFAC=2
ICOLR=ICOLIV(IFAC)
IJ=MAXN*(ICOLR-1)+I
IF(ICOLR.LE.MAXCOL)Y3(J)=V(IJ)
IF(ICOLR.EQ.MAXCP1)Y3(J)=PRED(I)
IF(ICOLR.EQ.MAXCP2)Y3(J)=RES(I)
IF(ICOLR.EQ.MAXCP3)Y3(J)=YPLOT(I)
IF(ICOLR.EQ.MAXCP4)Y3(J)=XPLOT(I)
IF(ICOLR.EQ.MAXCP5)Y3(J)=X2PLOT(I)
IF(ICOLR.EQ.MAXCP6)Y3(J)=TAGPLO(I)
C
660 CONTINUE
NS=J
C
C **************************************************
C ** STEP 8-- **
C ** PREPARE FOR ENTRANCE INTO DPMAN2-- **
C **************************************************
C
ISTEPN='8'
IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'EINL')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IH='ALPH'
IH2='A '
IHWUSE='P'
MESSAG='NO'
CALL CHECKN(IH,IH2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
IF(IERROR.EQ.'YES')THEN
ALPHA=0.005
ELSE
ALPHA=VALUE(ILOCP)
ENDIF
IF(ALPHA.LE.0.0 .OR. ALPHA.GE.1.0)ALPHA=0.005
IF(ALPHA.GT.0.50)ALPHA=1.0 - ALPHA
C
C ***********************************************
C ** STEP 9-- **
C ** CARRY OUT THE E691 INTERLAB ANALYSIS **
C ***********************************************
C
ISTEPN='9'
IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'EINL')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'EINL')THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,711)
711 FORMAT('***** FROM DPEINL, AS WE ARE ABOUT TO CALL DPEIN2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,712)NLEFT,MAXN,NS,NUMVAR
712 FORMAT('NLEFT,MAXN,NS,NUMVAR = ',4I8)
CALL DPWRST('XXX','BUG ')
DO715I=1,NS
WRITE(ICOUT,716)I,Y(I),Y2(I),Y3(I)
716 FORMAT('I,Y1(I),Y2(I),Y3(I) = ',
1 I6,2X,3G15.7)
CALL DPWRST('XXX','BUG ')
715 CONTINUE
WRITE(ICOUT,731)IBUGA3
731 FORMAT('IBUGA3 = ',A4)
CALL DPWRST('XXX','BUG ')
ENDIF
C
IWRITE='OFF'
CALL DPEIN2(Y1,Y2,Y3,NS,
1Z1,Z2,Z3,Z4,Z5,Z6,Z7,Z8,Z9,Z10,Z11,Z12,Z13,Z14,
1IHLEFT,IHLEF2,IHRIGH,IHRIG2,IHRI21,IHRI22,
1ALPHA,HCV,KCV,
1IWRITE,
1IFORSW,
1ICAPSW,ICAPTY,
1ISUBRO,IBUGA3,IERROR)
C
C ***************************************
C ** STEP 10-- **
C ** UPDATE INTERNAL DATAPLOT TABLES **
C ***************************************
C
ISTEPN='10'
IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'EINL')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IH='HCV '
IH2=' '
VALUE0=HCV
CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
1IANS,IWIDTH,IBUGA3,IERROR)
C
IH='KCV '
IH2=' '
VALUE0=KCV
CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
1IANS,IWIDTH,IBUGA3,IERROR)
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'EINL')THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPEINL--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGA2,IBUGA3
9012 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)NS,NUMVAR
9014 FORMAT('NS,NUMVAR = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)ICASEQ
9015 FORMAT('ICASEQ = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9016)IFOUND,IERROR
9016 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
ENDIF
C
RETURN
END
SUBROUTINE DPEIN2(Y,X1,X2,N,XIDTEM,XIDTE2,
1XBAR,XBARI,SDI,SDXBRI,DXBARI,H,AK,SRPT,SRPRD,
1TEMP1,TEMP2,TAG,
1IHLEFT,IHLEF2,IHRIGH,IHRIG2,IHRI21,IHRI22,
1ALPHA,HCV,KCV,
1IWRITE,
1IFORSW,
1ICAPSW,ICAPTY,
1ISUBRO,IBUGA3,IERROR)
C
C PURPOSE--PERFORM AN INTERLABORATORY STUDY ACCORDING TO
C ASTM E 691 STANDARD.
C
C THE DATA CONSISTS OF DATA GROUPED BY MATERIALS AND
C LABS. EACH COMINATION OF MATERIAL AND LAB IS REFERRED
C TO AS A CELL AND IT IS ASSUMED THAT THE CELLS HAVE
C THE SAME NUMBER OF REPLICATIONS.
C
C THERE ARE 4 BASIC
C QUANTITIES COMPUTED:
C 1) REPEATABILITY STANDARD DEVIATION
C 2) REPRODUCABILITY STANDARD DEVIATION
C 3) H CONSISTENCY STATISTIC
C 4) K CONSISTENCY STATISTIC
C THESE ARE ALL NOW AVAILABLE AS SEPARATE COMMANDS.
C THE PRIMARY FUNCTION OF THIS
C
C E691 INTERLAB Y LABID MATID
C
C COMMAND IS TO GENERATE THE FOLLOWING 4 TABLES BASED
C ON THESE BASIC QUANTITIES:
C 1) FOR EACH MATERIAL, PRINT
C A) LAB ID
C B) Cell Average
C C) Cell Standard Deviation
C D) Deviation of Cell Average from Overall Average
C (for that material)
C E) h Consistency Statistic for each cell
C F) k Consistency Statistic for each cell
C 2) A TWO-WAY TABLE (ROWS ARE LABS AND COLUMNS ARE
C MATERIALS) OF THE h CONSISTENCY STATISTIC
C 3) A TWO-WAY TABLE (ROWS ARE LABS AND COLUMNS ARE
C MATERIALS) OF THE k CONSISTENCY STATISTIC
C 4) A TABLE SUMMARIZING THE PRECISION STATISTICS
C FOR EACH MATERIAL.
C PRINTING--YES
C SUBROUTINES NEEDED--FCDF
C WRITTEN BY--JAMES FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C INFORMATION TECHNOLOGY LABORATORY
C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLGY
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 LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--2005/2
C ORIGINAL VERSION--FEBRUARY 2005.
C UPDATED --OCTOBER 2006. CALL LIST TO TPPF
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES--------------
C
CHARACTER*4 IFORSW
CHARACTER*4 ICAPSW
CHARACTER*4 ICAPTY
CHARACTER*4 ISUBRO
CHARACTER*4 ISUBN0
CHARACTER*4 IBUGA3
CHARACTER*4 IERROR
C
CHARACTER*4 IWRITE
CHARACTER*4 IPTEMP
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
CHARACTER*4 IHLEFT
CHARACTER*4 IHLEF2
CHARACTER*4 IHRIGH
CHARACTER*4 IHRIG2
CHARACTER*4 IHRI21
CHARACTER*4 IHRI22
C
CHARACTER*1 IBASLC
C
CHARACTER*20 IFORMT
CHARACTER*10 IFRMT2
CHARACTER*10 IFRMT3
CHARACTER*25 IFRMT4
CHARACTER*40 IFRMT5
CHARACTER*1 IEQUAL(200)
C
INCLUDE 'DPCOF2.INC'
C
CHARACTER*80 IFILE1
CHARACTER*12 ISTAT1
CHARACTER*12 IFORM1
CHARACTER*12 IACCE1
CHARACTER*12 IPROT1
CHARACTER*12 ICURS1
CHARACTER*4 IERRF1
CHARACTER*4 IENDF1
CHARACTER*4 IREWI1
C
CHARACTER*80 IFILE2
CHARACTER*12 ISTAT2
CHARACTER*12 IFORM2
CHARACTER*12 IACCE2
CHARACTER*12 IPROT2
CHARACTER*12 ICURS2
CHARACTER*4 IERRF2
CHARACTER*4 IENDF2
CHARACTER*4 IREWI2
C
CHARACTER*80 IFILE3
CHARACTER*12 ISTAT3
CHARACTER*12 IFORM3
CHARACTER*12 IACCE3
CHARACTER*12 IPROT3
CHARACTER*12 ICURS3
CHARACTER*4 IERRF3
CHARACTER*4 IENDF3
CHARACTER*4 IREWI3
C
CHARACTER*80 IFILE4
CHARACTER*12 ISTAT4
CHARACTER*12 IFORM4
CHARACTER*12 IACCE4
CHARACTER*12 IPROT4
CHARACTER*12 ICURS4
CHARACTER*4 IERRF4
CHARACTER*4 IENDF4
CHARACTER*4 IREWI4
C
REAL KCV
C
DOUBLE PRECISION DSUM
DOUBLE PRECISION DXREP
DOUBLE PRECISION XREPRD
C
C----------------------------------------------------------------
C
REAL Y(*)
REAL X1(*)
REAL X2(*)
REAL XIDTEM(*)
REAL XIDTE2(*)
REAL XBAR(*)
REAL XBARI(*)
REAL SDI(*)
REAL SDXBRI(*)
REAL DXBARI(*)
REAL H(*)
REAL AK(*)
REAL SRPT(*)
REAL SRPRD(*)
REAL TEMP1(*)
REAL TEMP2(*)
REAL TAG(*)
C
INCLUDE 'DPCOST.INC'
C
PARAMETER (MAXHED=50)
INTEGER IWIDTH(MAXHED)
INTEGER NUMDI2(MAXHED)
CHARACTER*8 ALIGN(MAXHED)
CHARACTER*8 VALIGN(MAXHED)
COMMON/HTML4/IWIDTH,NUMDI2,ALIGN,VALIGN
CHARACTER*25 IVALUE(MAXHED)
INTEGER NCHAR(MAXHED)
REAL AVALUE(MAXHED)
C
LOGICAL IFLAG1
LOGICAL IFLAG2
LOGICAL IFLAG3
C
CHARACTER*132 ITTEMP
CHARACTER*132 IHEAD
C
CHARACTER*4 IRTFMD
COMMON/COMRTF/IRTFMD
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT------------------------------------------------
C
IERROR='NO'
C
ISUBN1='DPEI'
ISUBN2='L2 '
C
NUMDIG=4
IF(IFORSW.EQ.'1')NUMDIG=2
IF(IFORSW.EQ.'2')NUMDIG=2
IF(IFORSW.EQ.'3')NUMDIG=3
IF(IFORSW.EQ.'4')NUMDIG=4
IF(IFORSW.EQ.'5')NUMDIG=5
IF(IFORSW.EQ.'6')NUMDIG=6
IF(IFORSW.EQ.'7')NUMDIG=7
IF(IFORSW.EQ.'8')NUMDIG=7
IF(IFORSW.EQ.'9')NUMDIG=7
IF(IFORSW.EQ.'0')NUMDIG=7
C
IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'EIN2')THEN
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPEIN2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)N
52 FORMAT('N = ',I8)
CALL DPWRST('XXX','BUG ')
DO55I=1,N
WRITE(ICOUT,56)I,Y(I),X1(I),X2(I)
56 FORMAT('I,Y(I),X1(I),X2(I) = ',I8,3G15.7)
CALL DPWRST('XXX','BUG ')
55 CONTINUE
ENDIF
C
C ********************************************
C ** STEP 1-- **
C ** CHECK THE INPUT ARGUMENTS FOR ERRORS **
C ********************************************
C
IF(N.LT.2)THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,101)
101 FORMAT('***** ERROR IN E691 INTERLAB ANALYSIS--')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,102)
102 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE ',
1 'E691 INTERLAB ANALYSIS')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,103)N
103 FORMAT(' MUST BE AT LEAST 2; THE ENTERED NUMBER OF ',
1 'OBSERVATIONS = ',I8)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
IERROR='YES'
GOTO9000
ENDIF
C
C **************************************************
C ** STEP 1.1-- **
C ** OPEN THE STORAGE FILES **
C **************************************************
C
ISTEPN='1.1'
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'EIN2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IOUNI1=IST1NU
IFILE1=IST1NA
ISTAT1=IST1ST
IFORM1=IST1FO
IACCE1=IST1AC
IPROT1=IST1PR
ICURS1=IST1CS
ISUBN0='EIN2'
IERRF1='NO'
C
IREWI1='ON'
CALL DPOPFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1,
1IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR)
IF(IERRF1.EQ.'YES')GOTO9000
C
IOUNI2=IST2NU
IFILE2=IST2NA
ISTAT2=IST2ST
IFORM2=IST2FO
IACCE2=IST2AC
IPROT2=IST2PR
ICURS2=IST2CS
ISUBN0='EIN2'
IERRF2='NO'
C
IREWI2='ON'
CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
1IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR)
IF(IERRF2.EQ.'YES')GOTO9000
C
IOUNI3=IST3NU
IFILE3=IST3NA
ISTAT3=IST3ST
IFORM3=IST3FO
IACCE3=IST3AC
IPROT3=IST3PR
ICURS3=IST3CS
ISUBN0='EIN2'
IERRF3='NO'
C
IREWI3='ON'
CALL DPOPFI(IOUNI3,IFILE3,ISTAT3,IFORM3,IACCE3,IPROT3,ICURS3,
1IREWI3,ISUBN0,IERRF3,IBUGA3,ISUBRO,IERROR)
IF(IERRF4.EQ.'YES')GOTO9000
C
IOUNI4=IST4NU
IFILE4=IST4NA
ISTAT4=IST4ST
IFORM4=IST4FO
IACCE4=IST4AC
IPROT4=IST4PR
ICURS4=IST4CS
ISUBN0='EIN2'
IERRF4='NO'
C
IREWI4='ON'
CALL DPOPFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4,
1IREWI4,ISUBN0,IERRF4,IBUGA3,ISUBRO,IERROR)
IF(IERRF4.EQ.'YES')GOTO9000
C
C ***********************************************
C ** STEP 2.1-- **
C ** PERFORM THE BASIC CALCULATIONS. OBTAIN: **
C ** 1) REPEATABILITY STANDARD DEVIATION **
C ** 2) REPRODUCABILITY STANDARD DEVIATION **
C ** 3) H CONSISTENCY STATISTIC **
C ** 4) K CONSISTENCY STATISTIC **
C ***********************************************
C
ISTEPN='2.1'
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'EIN2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IWRITE='OFF'
CALL DISTIN(X1,N,IWRITE,XIDTEM,NUMSE1,IBUGA3,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
CALL SORT(XIDTEM,NUMSE1,XIDTEM)
CALL DISTIN(X2,N,IWRITE,XIDTE2,NUMSE2,IBUGA3,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
CALL SORT(XIDTE2,NUMSE2,XIDTEM)
NLAB=NUMSE1
NMAT=NUMSE2
C
IF(NLAB.LT.2 .OR. NLAB.GE.N)THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,101)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,212)
212 FORMAT(' FOR THE E691 INTERLAB COMMAND, THE SECOND ',
1 'VARIABLE IS THE')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,214)
214 FORMAT(' LAB ID VARIABLE. THE NUMBER OF LABS SHOULD ',
1 'BE AT LEAST 2')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,216)
216 FORMAT(' AND LESS THAN THE NUMBER OF POINTS. SUCH WAS ',
1 'NOT THE CASE HERE.')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,218)NLAB
218 FORMAT(' THE NUMBER OF UNIQUE LAB IDS = ',I8)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,219)N
219 FORMAT(' THE TOTAL NUMBER OF POINTS = ',I8)
CALL DPWRST('XXX','WRIT')
IERROR='YES'
GOTO9000
ENDIF
C
IF(NMAT.LT.2 .OR. NMAT.GE.N)THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,101)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,222)
222 FORMAT(' FOR THE E691 INTERLAB COMMAND, THE THIRD ',
1 'VARIABLE IS THE')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,224)
224 FORMAT(' MATERIAL ID VARIABLE. THE NUMBER OF LABS ',
1 'SHOULD BE AT LEAST 2')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,226)
226 FORMAT(' AND LESS THAN THE NUMBER OF POINTS. SUCH WAS ',
1 'NOT THE CASE HERE.')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,228)NMAT
228 FORMAT(' THE NUMBER OF UNIQUE MATERIAL IDS = ',I8)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,229)N
229 FORMAT(' THE TOTAL NUMBER OF POINTS = ',I8)
CALL DPWRST('XXX','WRIT')
IERROR='YES'
GOTO9000
ENDIF
C
ISTEPN='2.2'
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'EIN2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
J=0
NOUT=0
DO1110ISET2=1,NUMSE2
C
C STEP 1: COMPUTE OVERALL MEAN FOR CURRENT MATERIAL
C
K=0
DO1120I=1,N
IF(XIDTE2(ISET2).EQ.X2(I))THEN
K=K+1
TEMP1(K)=Y(I)
ENDIF
1120 CONTINUE
NTEMP=K
CALL MEAN(TEMP1,NTEMP,IWRITE,XMEAN,IBUGA3,IERROR)
XBAR(ISET2)=XMEAN
C
DSUM=0.0D0
DO1130ISET1=1,NUMSE1
C
NOUT=(ISET2-1)*NUMSE1 + ISET1
TAG(NOUT)=REAL(ISET2)
C
K=0
DO1140I=1,N
IF(XIDTEM(ISET1).EQ.X1(I).AND.XIDTE2(ISET2).EQ.X2(I))THEN
K=K+1
TEMP1(K)=Y(I)
ENDIF
1140 CONTINUE
NTEMP=K
C
IF(ISET1.EQ.1 .AND. ISET2.EQ.1)THEN
NHOLD=NTEMP
ELSE
IF(NTEMP.NE.NHOLD)THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,101)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1141)ISET1,ISET2
1141 FORMAT(' FOR LAB ',I8,' AND MATERIAL ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1143)NHOLD,NTEMP
1143 FORMAT(' ',I8,' ELEMENTS EXPECTED BUT ',I8,
1 ' ELEMENTS FOUND.')
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
ENDIF
ENDIF
C
CALL MEAN(TEMP1,NTEMP,IWRITE,XMEAN,IBUGA3,IERROR)
CALL SD(TEMP1,NTEMP,IWRITE,XSD,IBUGA3,IERROR)
DSUM=DSUM + DBLE(XSD)**2
XBARI(NOUT)=XMEAN
SDI(NOUT)=XSD
AK(NOUT)=SDI(NOUT)
DXBARI(NOUT)=XBARI(NOUT) - XBAR(ISET2)
H(NOUT)=XBARI(NOUT) - XBAR(ISET2)
TEMP2(ISET1)=XBARI(NOUT)
C
IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ONS2')THEN
WRITE(ICOUT,1146)ISET1,ISET2,XBAR(ISET2),XBARI(NOUT)
1146 FORMAT('ISET1,ISET2,XBAR(ISET2),XBARI(NOUT) = ',
1 2I8,2G15.7)
CALL DPWRST('XXX','BUG ')
ENDIF
C
1130 CONTINUE
C
CALL SD(TEMP2,NUMSE1,IWRITE,XSD,IBUGA3,IERROR)
SDXBRI(ISET2)=XSD
DXREP=DSQRT(DSUM/DBLE(NUMSE1))
SRPT(ISET2)=REAL(DXREP)
C
DXREP=DSUM/DBLE(NUMSE1)
XREPRD=DSQRT(DBLE(XSD**2) + DXREP*DBLE(NHOLD-1)/DBLE(NHOLD))
SRPRD(ISET2)=REAL(MAX(DSQRT(DXREP),XREPRD))
C
DO1150I=(ISET2-1)*NUMSE1+1,ISET2*NUMSE1
H(I)=H(I)/SDXBRI(ISET2)
AK(I)=AK(I)/SRPT(ISET2)
1150 CONTINUE
C
1110 CONTINUE
NOUT=NUMSE1*NUMSE2
C
ANLAB=REAL(NLAB)
IDF=NLAB-2
ALP2=1.0 - (ALPHA/2.0)
CALL TPPF(ALP2,REAL(IDF),TVAL)
HCV=(ANLAB - 1.0)*TVAL/SQRT(ANLAB*(TVAL**2 + ANLAB - 2.0))
HCV=REAL(INT(HCV*100.0 + 0.5))
HCV=HCV/100.0
IDF1=NHOLD-1
IDF2=(NHOLD-1)*(NLAB-1)
ALP2=1.0 - ALPHA
CALL FPPF(ALP2,IDF1,IDF2,FVAL)
KCV=SQRT(ANLAB/(1.0 + (ANLAB-1.0)/FVAL))
KCV=REAL(INT(KCV*100.0 + 0.5))
KCV=KCV/100.0
C
C ***********************************************
C ** STEP 3.1-- **
C ** WRITE COMPUTED INFORMATION TO FILE **
C ***********************************************
C
ISTEPN='3.1'
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'EIN2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ICNT=0
DO3100ISET2=1,NUMSE2
IMAT=INT(XIDTE2(ISET2)+0.5)
DO3110ISET1=1,NUMSE1
ILAB=INT(XIDTEM(ISET1)+0.5)
ICNT=ICNT+1
WRITE(IOUNI1,3119)IMAT,ILAB,XBARI(ICNT),SDI(ICNT),
1 DXBARI(ICNT),H(ICNT),AK(ICNT)
3119 FORMAT(I8,1X,I8,3(1X,E15.7),2(1X,F10.2))
3110 CONTINUE
3100 CONTINUE
C
ICNT=0
IFORMT=' '
IFORMT(1:15)='(I8,1X, F10.2)'
IF(NMAT.LE.9)THEN
WRITE(IFORMT(9:9),'(I1)')NMAT
ELSE
WRITE(IFORMT(8:9),'(I2)')NMAT
ENDIF
DO3200ISET1=1,NUMSE1
ILAB=INT(XIDTEM(ISET1)+0.5)
WRITE(IOUNI2,IFORMT)ILAB,(H(II),II=ILAB,NMAT*NLAB,NUMSE1)
WRITE(IOUNI3,IFORMT)ILAB,(AK(II),II=ILAB,NMAT*NLAB,NUMSE1)
3200 CONTINUE
C
AR=2.8
DO3400ISET2=1,NUMSE2
IMAT=INT(XIDTE2(ISET2)+0.5)
AR1=2.8*SRPT(ISET2)
AR2=2.8*SRPRD(ISET2)
WRITE(IOUNI4,3419)IMAT,XBAR(ISET2),SDXBRI(ISET2),
1 SRPT(ISET2),SRPRD(ISET2),AR1,AR2
3419 FORMAT(I8,4(1X,E15.7),2(1X,F7.2))
3400 CONTINUE
C
ISTEPN='3.2'
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'EIN2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IENDF1='OFF'
IREWI1='ON'
CALL DPCLFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1,
1IENDF1,IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR)
IF(IERRF1.EQ.'YES')GOTO9000
C
IENDF2='OFF'
IREWI2='ON'
CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
1IENDF2,IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR)
IF(IERRF2.EQ.'YES')GOTO9000
C
IENDF3='OFF'
IREWI3='ON'
CALL DPCLFI(IOUNI3,IFILE3,ISTAT3,IFORM3,IACCE3,IPROT3,ICURS3,
1IENDF3,IREWI3,ISUBN0,IERRF3,IBUGA3,ISUBRO,IERROR)
IF(IERRF3.EQ.'YES')GOTO9000
C
IENDF4='OFF'
IREWI4='ON'
CALL DPCLFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4,
1IENDF4,IREWI4,ISUBN0,IERRF4,IBUGA3,ISUBRO,IERROR)
IF(IERRF4.EQ.'YES')GOTO9000
C
C
C ***********************************************
C ** STEP 2.1-- **
C ** PERFORM THE BASIC CALCULATIONS. OBTAIN: **
C ** 1) REPEATABILITY STANDARD DEVIATION **
C ** 2) REPRODUCABILITY STANDARD DEVIATION **
C ** 3) H CONSISTENCY STATISTIC **
C ** 4) K CONSISTENCY STATISTIC **
C ***********************************************
C
ISTEPN='2.1'
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'EIN2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IPRINT.EQ.'ON')THEN
IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN
C
C WRITE HEADER LINE
C
ITTEMP=' '
NCTEMP=0
IFLAG1=.TRUE.
IFLAG2=.FALSE.
CALL DPHTM1(ITTEMP,NCTEMP,IFLAG1,IFLAG2)
C
ITTEMP(1:NCTABT)=ITABTI(1:NCTABT)
NCTEMP=NCTABT
WRITE(ICOUT,5001)
5001 FORMAT('')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5002)
5002 FORMAT('INTERLABORATRY ANALYSIS (BASED ON E 691 - 99)',
1 '
')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5003)
5003 FORMAT('')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5005)
5005 FORMAT('
')
CALL DPWRST('XXX','WRIT')
C
C TABLE 1
C
ICNT=0
IFRMT5=' '
IFRMT5(1:34)='(2X,I4,4X,3(1X,F15.7),2(1X,F10.2))'
WRITE(IFRMT5(20:20),'(I1)')NUMDIG
C
DO5100ISET2=1,NUMSE2
IMAT=INT(XIDTE2(ISET2)+0.5)
IFLAG1=.FALSE.
IFLAG2=.TRUE.
NSTRT=NCTABT+1
ITTEMP(NSTRT:NSTRT+31)='
Initial Preparation of Test'
ITTEMP(NSTRT+32:NSTRT+58)=' Result Data for Material: '
WRITE(ITTEMP(NSTRT+59:NSTRT+60),'(I2)')IMAT
NCTEMP=NSTRT+60
CALL DPHTM1(ITTEMP,NCTEMP,IFLAG1,IFLAG2)
C
DO5105ISET1=1,MIN(NUMSE1+1,MAXHED)
IWIDTH(ISET1)=75
VALIGN(ISET1)='BOTTOM'
ALIGN(ISET1)='RIGHT'
NUMDI2(ISET1)=-2
5105 CONTINUE
ALIGN(1)='CENTER'
NUMDI2(1)=0
NUMDI2(2)=NUMDIG
NUMDI2(3)=NUMDIG
NUMDI2(4)=NUMDIG
NUMDI2(5)=2
NUMDI2(6)=2
IVALUE(1)='Laboratory
Number'
NCHAR(1)=20
IVALUE(2)='Cell
Mean'
NCHAR(2)=12
IVALUE(3)='Cell
SD'
NCHAR(3)=10
IVALUE(4)='d'
NCHAR(4)=8
IVALUE(5)='h'
NCHAR(5)=8
IVALUE(6)='k'
NCHAR(6)=8
NHEAD=6
IFLAG1=.TRUE.
IFLAG2=.TRUE.
CALL DPHTM4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2)
C
NCHAR(1)=0
IVALUE(1)=' '
DO5110ISET1=1,NUMSE1
ICNT=ICNT+1
AVALUE(1)=XIDTEM(ISET1)
AVALUE(2)=XBARI(ICNT)
AVALUE(3)=SDI(ICNT)
AVALUE(4)=DXBARI(ICNT)
AVALUE(5)=H(ICNT)
AVALUE(6)=AK(ICNT)
CALL DPHTM5(IVALUE,NCHAR(1),AVALUE,NHEAD)
5110 CONTINUE
C
CALL DPHTM6(NHEAD)
IFLAG1=.TRUE.
IFLAG2=.FALSE.
CALL DPHTM2(IFLAG1,IFLAG2,NHEAD)
WRITE(ICOUT,5115)
5115 FORMAT('
')
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,5147)
5147 FORMAT('')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5131)XBAR(ISET2)
5131 FORMAT('Average of cell averages = ',F12.5,'
')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5133)SDXBRI(ISET2)
5133 FORMAT('Standard deviation of cell averages = ',F12.5,
1 '
')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5135)SRPT(ISET2)
5135 FORMAT('Repeatability standard deviation = ',F12.5,'
')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5137)SRPRD(ISET2)
5137 FORMAT('Reproducability standard deviation = ',F12.5,
1 '
')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5148)
5148 FORMAT('
')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5005)
CALL DPWRST('XXX','WRIT')
5100 CONTINUE
C
C TABLE 2
C
IFLAG1=.FALSE.
IFLAG2=.TRUE.
ITTEMP(NCTABT+1:NCTABT+2)='-h'
NCTEMP=NCTABT+2
CALL DPHTM1(ITTEMP,NCTEMP,IFLAG1,IFLAG2)
NHEAD=NUMSE2+1
CALL DPHTM6(NHEAD)
C
5201 FORMAT(' ')
5203 FORMAT(' | ')
5204 FORMAT(' ')
5205 FORMAT(' | ')
5207 FORMAT(' Material')
5208 FORMAT(' | ')
5209 FORMAT('
')
WRITE(ICOUT,5201)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5203)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5204)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5208)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5205)NUMSE2
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5207)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5208)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5209)
CALL DPWRST('XXX','WRIT')
C
DO5215ISET1=1,MIN(NUMSE2+2,MAXHED)
IWIDTH(ISET1)=75
VALIGN(ISET1)='BOTTOM'
ALIGN(ISET1)='RIGHT'
NUMDI2(ISET1)=-2
5215 CONTINUE
ALIGN(1)='CENTER'
NUMDI2(1)=0
IVALUE(1)='Laboratory'
NCHAR(1)=10
DO5217II=2,NMAT+1
NUMDI2(II)=2
WRITE(IVALUE(II)(1:2),'(I2)')II-1
NCHAR(II)=2
5217 CONTINUE
NHEAD=NMAT+1
IFLAG1=.TRUE.
IFLAG2=.TRUE.
CALL DPHTM4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2)
C
NCHAR(1)=0
IVALUE(1)=' '
ALIGN(2)='CENTER'
NHEAD=NMAT+1
NSTOP=NMAT*NLAB
DO5220ISET1=1,NLAB
ILAB=INT(XIDTEM(ISET1)+0.5)
AVALUE(1)=XIDTEM(ISET1)
ICNT=1
DO5225II=ILAB,NSTOP,NLAB
ICNT=ICNT+1
AVALUE(ICNT)=H(II)
5225 CONTINUE
CALL DPHTM5(IVALUE(1),NCHAR(1),AVALUE,NHEAD)
5220 CONTINUE
C
CALL DPHTM6(NHEAD)
IFLAG1=.TRUE.
IFLAG2=.FALSE.
CALL DPHTM2(IFLAG1,IFLAG2,NHEAD)
WRITE(ICOUT,5235)
5235 FORMAT('
')
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,5241)HCV
5241 FORMAT('Critical Value = ',F7.2,'
')
CALL DPWRST('XXX','WRIT')
C
C TABLE 3
C
IFLAG1=.FALSE.
IFLAG2=.TRUE.
ITTEMP(NCTABT+1:NCTABT+2)='-k'
NCTEMP=NCTABT+2
CALL DPHTM1(ITTEMP,NCTEMP,IFLAG1,IFLAG2)
NHEAD=NUMSE2+1
CALL DPHTM6(NHEAD)
C
5301 FORMAT(' ')
5303 FORMAT(' | ')
5304 FORMAT(' ')
5305 FORMAT(' | ')
5307 FORMAT(' Material')
5308 FORMAT(' | ')
5309 FORMAT('
')
WRITE(ICOUT,5301)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5303)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5304)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5308)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5305)NUMSE2
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5307)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5308)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,5309)
CALL DPWRST('XXX','WRIT')
C
DO5315ISET1=1,MIN(NUMSE2+2,MAXHED)
IWIDTH(ISET1)=75
VALIGN(ISET1)='BOTTOM'
ALIGN(ISET1)='RIGHT'
NUMDI2(ISET1)=-2
5315 CONTINUE
ALIGN(1)='CENTER'
NUMDI2(1)=0
IVALUE(1)='Laboratory'
NCHAR(1)=10
DO5317II=2,NMAT+1
NUMDI2(II)=2
WRITE(IVALUE(II)(1:2),'(I2)')II-1
NCHAR(II)=2
5317 CONTINUE
NHEAD=NMAT+1
IFLAG1=.TRUE.
IFLAG2=.TRUE.
CALL DPHTM4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2)
C
ALIGN(2)='CENTER'
NCHAR(1)=0
NHEAD=NMAT+1
NSTOP=NMAT*NLAB
NINC=NLAB
DO5320ISET1=1,NLAB
ILAB=INT(XIDTEM(ISET1)+0.5)
AVALUE(1)=XIDTEM(ISET1)
ICNT=1
DO5325II=ILAB,NSTOP,NINC
ICNT=ICNT+1
AVALUE(ICNT)=AK(II)
5325 CONTINUE
CALL DPHTM5(IVALUE(1),NCHAR(1),AVALUE,NHEAD)
5320 CONTINUE
C
CALL DPHTM6(NHEAD)
IFLAG1=.TRUE.
IFLAG2=.FALSE.
CALL DPHTM2(IFLAG1,IFLAG2,NHEAD)
WRITE(ICOUT,5335)
5335 FORMAT('
')
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,5341)KCV
5341 FORMAT('Critical Value = ',F7.2,'
')
CALL DPWRST('XXX','WRIT')
C
C TABLE 4
C
IFLAG1=.FALSE.
IFLAG2=.TRUE.
ITTEMP(NCTABT+1:NCTABT+21)='-Precision Statistics'
NCTEMP=NCTABT+21
CALL DPHTM1(ITTEMP,NCTEMP,IFLAG1,IFLAG2)
NHEAD=NUMSE2+1
C
DO5415ISET1=1,6
IWIDTH(ISET1)=75
VALIGN(ISET1)='BOTTOM'
ALIGN(ISET1)='RIGHT'
NUMDI2(ISET1)=NUMDIG
5415 CONTINUE
NUMDI2(1)=0
NUMDI2(6)=2
NUMDI2(7)=2
IVALUE(1)='Material'
NCHAR(1)=8
IVALUE(2)='Xbar'
NCHAR(2)=11
IVALUE(3)='sx'
NCHAR(3)=19
IVALUE(4)='sr'
NCHAR(4)=19
IVALUE(5)='sR'
NCHAR(5)=19
IVALUE(6)='r'
NCHAR(6)=8
IVALUE(7)='R'
NCHAR(7)=8
NHEAD=7
IFLAG1=.TRUE.
IFLAG2=.TRUE.
CALL DPHTM4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2)
C
AR=2.8
NCHAR(1)=0
NHEAD=7
DO5430ISET2=1,NUMSE2
AVALUE(1)=XIDTE2(ISET2)
AVALUE(2)=XBAR(ISET2)
AVALUE(3)=SDXBRI(ISET2)
AVALUE(4)=SRPT(ISET2)
AVALUE(5)=SRPRD(ISET2)
AR1=2.8*SRPT(ISET2)
AR2=2.8*SRPRD(ISET2)
AVALUE(6)=AR1
AVALUE(7)=AR2
CALL DPHTM5(IVALUE,NCHAR(1),AVALUE,NHEAD)
5430 CONTINUE
C
CALL DPHTM6(NHEAD)
IFLAG1=.TRUE.
IFLAG2=.FALSE.
CALL DPHTM2(IFLAG1,IFLAG2,NHEAD)
WRITE(ICOUT,5435)
5435 FORMAT('
')
CALL DPWRST('XXX','WRIT')
C
C RESET MODE
C
IFLAG1=.FALSE.
IFLAG2=.TRUE.
NHEAD=0
CALL DPHTM2(IFLAG1,IFLAG2,NHEAD)
C
ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN
C
C WRITE HEADER LINE
C
IFLAG1=.TRUE.
IFLAG2=.FALSE.
IFLAG3=.TRUE.
CALL DPLAT6(IFLAG1,IFLAG2,IFLAG3)
C
CALL DPCONA(92,IBASLC)
IFLAG1=.FALSE.
IFLAG2=.TRUE.
IHEAD(1:46)='INTERLABORATRY ANALYSIS (BASED ON E 691 - 99)'
NHEAD=46
CALL DPLAT8(IHEAD,NHEAD,IFLAG1,IFLAG2)
NHEAD=0
C
C TABLE 1
C
ITTEMP(1:NCTABT)=ITABTI(1:NCTABT)
NCTEMP=NCTABT
ICNT=0
IFRMT5=' '
IFRMT5(1:34)='(2X,I4,4X,3(1X,F15.7),2(1X,F10.2))'
WRITE(IFRMT5(20:20),'(I1)')NUMDIG
C
DO6100ISET2=1,NUMSE2
C
IMAT=INT(XIDTE2(ISET2)+0.5)
C
IHEAD(1:27)='Initial Preparation of Test'
IHEAD(28:54)=' Result Data for Material: '
WRITE(IHEAD(55:56),'(I2)')IMAT
NHEAD=56
IFLAG1=.TRUE.
IF(ISET2.EQ.1)IFLAG1=.FALSE.
CALL DPLAT1(ITTEMP,NCTEMP,IHEAD,NHEAD,IFLAG1)
C
DO6105ISET1=1,MIN(NUMSE1+1,MAXHED)
IWIDTH(ISET1)=0
VALIGN(ISET1)=' '
ALIGN(ISET1)='r'
NUMDI2(ISET1)=-2
6105 CONTINUE
ALIGN(1)='c'
NUMDI2(1)=0
NUMDI2(2)=NUMDIG
NUMDI2(3)=NUMDIG
NUMDI2(4)=NUMDIG
NUMDI2(5)=2
NUMDI2(6)=2
IVALUE(1)='Laboratory Number'
NCHAR(1)=17
IVALUE(2)='Cell Mean'
NCHAR(2)=9
IVALUE(3)='Cell SD'
NCHAR(3)=7
IVALUE(4)='${d}$'
NCHAR(4)=5
IVALUE(5)='h'
IVALUE(5)='${h}$'
NCHAR(5)=5
IVALUE(6)='${k}$'
NCHAR(6)=5
NHEAD=6
IFLAG1=.TRUE.
IFLAG2=.TRUE.
IFLAG3=.TRUE.
CALL DPLAT4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2,IFLAG3)
C
NCHAR(1)=0
IVALUE(1)=' '
IFLAG1=.FALSE.
DO6110ISET1=1,NUMSE1
ICNT=ICNT+1
AVALUE(1)=XIDTEM(ISET1)
AVALUE(2)=XBARI(ICNT)
AVALUE(3)=SDI(ICNT)
AVALUE(4)=DXBARI(ICNT)
AVALUE(5)=H(ICNT)
AVALUE(6)=AK(ICNT)
IF(ISET1.EQ.NUMSE1)IFLAG1=.TRUE.
CALL DPLAT5(IVALUE,NCHAR(1),AVALUE,NHEAD,IFLAG1)
6110 CONTINUE
C
IFLAG1=.TRUE.
IFLAG2=.FALSE.
IFLAG3=.FALSE.
CALL DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD)
C
IHEAD(1:28)='Average of cell averages = '
NCHAR(1)=28
CALL DPLAT7(IHEAD,NCHAR(1),XBAR(ISET2))
IHEAD(1:39)='Standard Deviation of cell averages = '
NCHAR(1)=39
CALL DPLAT7(IHEAD,NCHAR(1),SDXBRI(ISET2))
IHEAD(1:36)='Repeatability Standard Deviation = '
NCHAR(1)=36
CALL DPLAT7(IHEAD,NCHAR(1),SRPT(ISET2))
IHEAD(1:38)='Reproducability Standard Deviation = '
NCHAR(1)=38
CALL DPLAT7(IHEAD,NCHAR(1),SRPT(ISET2))
IFLAG1=.FALSE.
IFLAG2=.TRUE.
IFLAG3=.FALSE.
CALL DPLAT6(IFLAG1,IFLAG2,IFLAG3)
6100 CONTINUE
C
C TABLE 2
C
ITTEMP(NCTABT+1:NCTABT+2)='-h'
NCTEMP=NCTABT+2
NHEAD=0
IFLAG1=.TRUE.
CALL DPLAT1(IHEAD,NHEAD,ITTEMP,NCTEMP,IFLAG1)
NHEAD=NUMSE2+1
IFLAG1=.FALSE.
IHEAD(1:8)='Material'
NHEAD=8
IFLAG2=.FALSE.
CALL DPLAT8(IHEAD,NHEAD,IFLAG1,IFLAG2)
C
DO6215ISET1=1,MIN(NUMSE2+1,MAXHED)
IWIDTH(ISET1)=75
VALIGN(ISET1)='BOTTOM'
ALIGN(ISET1)='r'
NUMDI2(ISET1)=-2
6215 CONTINUE
ALIGN(1)='c'
NUMDI2(1)=0
IVALUE(1)='Laboratory'
NCHAR(1)=10
DO6217II=2,NMAT+1
NUMDI2(II)=2
WRITE(IVALUE(II)(1:2),'(I2)')II-1
NCHAR(II)=2
6217 CONTINUE
NHEAD=NMAT+1
IFLAG1=.TRUE.
IFLAG2=.TRUE.
IFLAG3=.TRUE.
CALL DPLAT4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2,IFLAG3)
C
NCHAR(1)=0
IVALUE(1)=' '
NHEAD=NMAT+1
NSTOP=NMAT*NLAB
IFLAG1=.FALSE.
DO6220ISET1=1,NLAB
ILAB=INT(XIDTEM(ISET1)+0.5)
AVALUE(1)=XIDTEM(ISET1)
ICNT=1
DO6225II=ILAB,NSTOP,NLAB
ICNT=ICNT+1
AVALUE(ICNT)=H(II)
6225 CONTINUE
IF(ISET1.EQ.NLAB)IFLAG1=.TRUE.
CALL DPLAT5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1)
6220 CONTINUE
C
IFLAG1=.TRUE.
IFLAG2=.FALSE.
IFLAG3=.FALSE.
CALL DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD)
C
IHEAD(1:18)='Critical Value = '
NCHAR(1)=18
CALL DPLAT7(IHEAD,NCHAR(1),HCV)
IFLAG1=.FALSE.
IFLAG2=.TRUE.
IFLAG3=.FALSE.
CALL DPLAT6(IFLAG1,IFLAG2,IFLAG3)
C
C TABLE 3
C
ITTEMP(NCTABT+1:NCTABT+2)='-k'
NCTEMP=NCTABT+2
NHEAD=0
IFLAG1=.TRUE.
CALL DPLAT1(IHEAD,NHEAD,ITTEMP,NCTEMP,IFLAG1)
NHEAD=NUMSE2+1
IFLAG1=.FALSE.
IHEAD(1:8)='Material'
NHEAD=8
IFLAG2=.FALSE.
CALL DPLAT8(IHEAD,NHEAD,IFLAG1,IFLAG2)
C
DO6315ISET1=1,MIN(NUMSE2+1,MAXHED)
IWIDTH(ISET1)=75
VALIGN(ISET1)='BOTTOM'
ALIGN(ISET1)='r'
NUMDI2(ISET1)=-2
6315 CONTINUE
ALIGN(1)='c'
NUMDI2(1)=0
IVALUE(1)='Laboratory'
NCHAR(1)=10
DO6317II=2,NMAT+1
NUMDI2(II)=2
WRITE(IVALUE(II)(1:2),'(I2)')II-1
NCHAR(II)=2
6317 CONTINUE
NHEAD=NMAT+1
IFLAG1=.TRUE.
IFLAG2=.TRUE.
IFLAG3=.TRUE.
CALL DPLAT4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2,IFLAG3)
C
NCHAR(1)=0
IVALUE(1)=' '
NHEAD=NMAT+1
NSTOP=NMAT*NLAB
IFLAG1=.FALSE.
DO6320ISET1=1,NLAB
ILAB=INT(XIDTEM(ISET1)+0.5)
AVALUE(1)=XIDTEM(ISET1)
ICNT=1
DO6325II=ILAB,NSTOP,NLAB
ICNT=ICNT+1
AVALUE(ICNT)=AK(II)
6325 CONTINUE
IF(ISET1.EQ.NLAB)IFLAG1=.TRUE.
CALL DPLAT5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1)
6320 CONTINUE
C
IFLAG1=.TRUE.
IFLAG2=.FALSE.
IFLAG3=.FALSE.
CALL DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD)
C
IHEAD(1:18)='Critical Value = '
NCHAR(1)=18
CALL DPLAT7(IHEAD,NCHAR(1),KCV)
IFLAG1=.FALSE.
IFLAG2=.TRUE.
IFLAG3=.FALSE.
CALL DPLAT6(IFLAG1,IFLAG2,IFLAG3)
C
C TABLE 4
C
ITTEMP(NCTABT+1:NCTABT+21)='-Precision Statistics'
NCTEMP=NCTABT+21
NHEAD=0
IFLAG1=.TRUE.
CALL DPLAT1(IHEAD,NHEAD,ITTEMP,NCTEMP,IFLAG1)
NHEAD=NUMSE2+1
C
DO6415ISET1=1,6
IWIDTH(ISET1)=75
VALIGN(ISET1)='BOTTOM'
ALIGN(ISET1)='r'
NUMDI2(ISET1)=NUMDIG
6415 CONTINUE
NUMDI2(1)=0
NUMDI2(6)=2
NUMDI2(7)=2
IVALUE(1)='Material'
NCHAR(1)=8
IVALUE(2)='$ bar{X}$'
IVALUE(2)(2:2)=IBASLC
NCHAR(2)=9
IVALUE(3)='$s_{x}$'
NCHAR(3)=7
IVALUE(4)='$s_{r}$'
NCHAR(4)=7
IVALUE(5)='$s_{R}$'
NCHAR(5)=7
IVALUE(6)='r'
NCHAR(6)=1
IVALUE(7)='R'
NCHAR(7)=1
NHEAD=7
IFLAG1=.TRUE.
IFLAG2=.TRUE.
IFLAG3=.TRUE.
CALL DPLAT4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2,IFLAG3)
C
AR=2.8
NCHAR(1)=0
NHEAD=7
IFLAG1=.FALSE.
DO6430ISET2=1,NUMSE2
AVALUE(1)=XIDTE2(ISET2)
AVALUE(2)=XBAR(ISET2)
AVALUE(3)=SDXBRI(ISET2)
AVALUE(4)=SRPT(ISET2)
AVALUE(5)=SRPRD(ISET2)
AR1=2.8*SRPT(ISET2)
AR2=2.8*SRPRD(ISET2)
AVALUE(6)=AR1
AVALUE(7)=AR2
IF(ISET2.EQ.NUMSE2)IFLAG1=.TRUE.
CALL DPLAT5(IVALUE,NCHAR(1),AVALUE,NHEAD,IFLAG1)
6430 CONTINUE
C
C END TABLE AND RESET "ASIS" MODE
C
IFLAG1=.TRUE.
IFLAG2=.TRUE.
IFLAG3=.TRUE.
CALL DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD)
C
ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF ')THEN
C
6591 FORMAT(A1,'f',I1)
IF(IRTFFP.EQ.'Times New Roman')THEN
ITEMP=0
ELSEIF(IRTFFP.EQ.'Lucida Sans')THEN
ITEMP=6
ELSEIF(IRTFFP.EQ.'Arial')THEN
ITEMP=2
ELSEIF(IRTFFP.EQ.'Bookman')THEN
ITEMP=3
ELSEIF(IRTFFP.EQ.'Georgia')THEN
ITEMP=4
ELSEIF(IRTFFP.EQ.'Tahoma')THEN
ITEMP=5
ELSEIF(IRTFFP.EQ.'Verdana')THEN
ITEMP=7
ELSE
ITEMP=0
ENDIF
C
C WRITE HEADER LINE
C
IRTFMD='OFF'
CALL DPCONA(92,IBASLC)
IFLAG1=.TRUE.
IHEAD(1:46)='INTERLABORATRY ANALYSIS (BASED ON E 691 - 99)'
NHEAD=46
CALL DPRTF8(IHEAD,NHEAD,ITEMP,IFLAG1)
NHEAD=0
C
C TABLE 1
C
ITTEMP(1:NCTABT)=ITABTI(1:NCTABT)
NCTEMP=NCTABT
ICNT=0
IFRMT5=' '
IFRMT5(1:34)='(2X,I4,4X,3(1X,F15.7),2(1X,F10.2))'
WRITE(IFRMT5(20:20),'(I1)')NUMDIG
C
IDEFPS=20
IFRST=IRTFPS*1400/IDEFPS
IINC1=IRTFPS*1440/IDEFPS
IINC2=IRTFPS*800/IDEFPS
DO6605ISET1=1,6
VALIGN(ISET1)='b'
ALIGN(ISET1)='r'
NUMDI2(ISET1)=-2
6605 CONTINUE
IWIDTH(1)=IFRST
ALIGN(1)='c'
DO6608I=2,4
IWIDTH(I)=IWIDTH(I-1) + IINC1
6608 CONTINUE
IWIDTH(5)=IWIDTH(4) + IINC2
IWIDTH(6)=IWIDTH(5) + IINC2
NUMDI2(1)=0
NUMDI2(2)=NUMDIG
NUMDI2(3)=NUMDIG
NUMDI2(4)=NUMDIG
NUMDI2(5)=2
NUMDI2(6)=2
IVALUE(2)=' b Cell line Mean'
IVALUE(2)(1:1)=IBASLC
IVALUE(2)(8:8)=IBASLC
NCHAR(2)=17
IVALUE(3)=' b Cell line SD'
IVALUE(3)(1:1)=IBASLC
IVALUE(3)(8:8)=IBASLC
NCHAR(3)=15
IVALUE(4)=' b i d'
IVALUE(4)(1:1)=IBASLC
IVALUE(4)(3:3)=IBASLC
NCHAR(4)=6
IVALUE(5)=' b i h'
IVALUE(5)(1:1)=IBASLC
IVALUE(5)(3:3)=IBASLC
NCHAR(5)=6
IVALUE(6)=' b i k'
IVALUE(6)(1:1)=IBASLC
IVALUE(6)(3:3)=IBASLC
NCHAR(6)=6
NHEAD=6
IFLAG1=.TRUE.
IFLAG2=.TRUE.
C
DO6600ISET2=1,NUMSE2
C
IMAT=INT(XIDTE2(ISET2)+0.5)
IFLAG1=.TRUE.
IFLAG2=.TRUE.
C
IHEAD(1:27)='Initial Preparation of Test'
IHEAD(28:54)=' Result Data for Material: '
WRITE(IHEAD(55:56),'(I2)')IMAT
NHEAD=56
CALL DPRTF1(ITTEMP,NCTEMP,IHEAD,NHEAD)
C
IVALUE(1)=' b Laboratory line Number'
IVALUE(1)(1:1)=IBASLC
IVALUE(1)(14:14)=IBASLC
NCHAR(1)=25
NHEAD=6
CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2)
C
DO6615II=2,6
ALIGN(II)='r'
6615 CONTINUE
NCHAR(1)=0
IVALUE(1)=' '
IFLAG1=.FALSE.
DO6610ISET1=1,NUMSE1
ICNT=ICNT+1
AVALUE(1)=XIDTEM(ISET1)
AVALUE(2)=XBARI(ICNT)
AVALUE(3)=SDI(ICNT)
AVALUE(4)=DXBARI(ICNT)
AVALUE(5)=H(ICNT)
AVALUE(6)=AK(ICNT)
IF(ISET1.EQ.NUMSE1)IFLAG1=.TRUE.
CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1)
6610 CONTINUE
C
CALL DPRTF6(NHEAD)
IFLAG1=.TRUE.
IFLAG2=.FALSE.
CCCCC CALL DPRTF2(IFLAG1,IFLAG2,NHEAD)
C
IF(IRTFFF.EQ.'Courier New')THEN
ITEMP=1
ELSEIF(IRTFFF.EQ.'Lucida Console')THEN
ITEMP=8
ENDIF
WRITE(ICOUT,6591)IBASLC,ITEMP
CALL DPWRST(ICOUT,'WRIT')
IHEAD(1:39)='Average of cell averages = '
NCHAR(1)=39
CALL DPRTF7(IHEAD,NCHAR(1),XBAR(ISET2))
IHEAD(1:39)='Standard Deviation of cell averages = '
NCHAR(1)=39
CALL DPRTF7(IHEAD,NCHAR(1),SDXBRI(ISET2))
IHEAD(1:39)='Repeatability Standard Deviation = '
NCHAR(1)=39
CALL DPRTF7(IHEAD,NCHAR(1),SRPT(ISET2))
IHEAD(1:39)='Reproducability Standard Deviation = '
NCHAR(1)=39
CALL DPRTF7(IHEAD,NCHAR(1),SRPT(ISET2))
C
CALL DPRTF6(NHEAD)
CALL DPRTF6(NHEAD)
IF(IRTFFP.EQ.'Times New Roman')THEN
ITEMP=0
ELSEIF(IRTFFP.EQ.'Lucida Sans')THEN
ITEMP=6
ELSEIF(IRTFFP.EQ.'Arial')THEN
ITEMP=2
ELSEIF(IRTFFP.EQ.'Bookman')THEN
ITEMP=3
ELSEIF(IRTFFP.EQ.'Georgia')THEN
ITEMP=4
ELSEIF(IRTFFP.EQ.'Tahoma')THEN
ITEMP=5
ELSEIF(IRTFFP.EQ.'Verdana')THEN
ITEMP=7
ENDIF
WRITE(ICOUT,6591)IBASLC,ITEMP
CALL DPWRST(ICOUT,'WRIT')
C
6600 CONTINUE
C
C TABLE 2
C
C TABLES 2 AND 3 HAVE A VARIABLE NUMBER OF COLUMNS. BASED ON:
C 1) NMAT + 2 COLUMNS (2 COLUMNS FOR LABORATORY LABEL)
C 2) THERE 1,440 TWIPS PER INCH
C 3) FOR DEFAULT POINT SIZE (10), A WIDTH OF 800 TWIPS PER COLUMN
C SEEMS TO WORK WELL
C DETERMINE A MAXIMUM POINT SIZE.
C
AINC=6.5*1440.0/REAL(NMAT+2)
AMXPS=AINC/80.0
IMXPS=INT(AMXPS+0.99)
IF(IRTFPS.GT.IMXPS)THEN
IPTSZ=IMXPS
IF(2*IMXPS.LE.9)THEN
WRITE(ICOUT,6702)IBASLC,2*IMXPS
6702 FORMAT(A1,'fs',I1)
CALL DPWRST(ICOUT,'WRIT')
ELSEIF(2*IMXPS.LE.9)THEN
WRITE(ICOUT,6703)IBASLC,2*IMXPS
6703 FORMAT(A1,'fs',I2)
CALL DPWRST(ICOUT,'WRIT')
ENDIF
ELSE
IPTSZ=IRTFPS
ENDIF
C
IINC1=80*IPTSZ
C
ITTEMP(NCTABT+1:NCTABT+2)='-h'
NCTEMP=NCTABT+2
NHEAD=0
CALL DPRTF1(IHEAD,NHEAD,ITTEMP,NCTEMP)
C
IWIDTH(1)=2*IINC1
IWIDTH(2)=IWIDTH(1) + NUMSE2*IINC1
ALIGN(1)='c'
ALIGN(2)='c'
VALIGN(1)='b'
VALIGN(2)='b'
NHEAD=2
IFLAG1=.TRUE.
IFLAG1=.TRUE.
IVALUE(1)=' '
NCHAR(1)=1
IVALUE(2)(1:8)='Material'
NCHAR(2)=8
CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2)
C
NUMDI2(1)=0
IWIDTH(1)=2*IINC1
DO6705ISET1=2,MIN(NUMSE2+1,MAXHED)
VALIGN(ISET1)='b'
ALIGN(ISET1)='r'
NUMDI2(ISET1)=2
IWIDTH(ISET1)=IWIDTH(ISET1-1) + IINC1
6705 CONTINUE
ALIGN(1)='c'
C
IVALUE(1)='Laboratory'
NCHAR(1)=10
DO6717II=2,MIN(NUMSE2+1,MAXHED)
WRITE(IVALUE(II)(1:2),'(I2)')II-1
NCHAR(II)=2
6717 CONTINUE
NHEAD=MIN(NUMSE2+1,MAXHED)
IFLAG1=.TRUE.
IFLAG2=.TRUE.
CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2)
C
NCHAR(1)=0
IVALUE(1)=' '
NHEAD=NMAT+1
NSTOP=NMAT*NLAB
IFLAG1=.FALSE.
DO6720ISET1=1,NLAB
ILAB=INT(XIDTEM(ISET1)+0.5)
AVALUE(1)=XIDTEM(ISET1)
ICNT=1
DO6725II=ILAB,NSTOP,NLAB
ICNT=ICNT+1
AVALUE(ICNT)=H(II)
6725 CONTINUE
IF(ISET1.EQ.NLAB)IFLAG1=.TRUE.
CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1)
6720 CONTINUE
C
CALL DPRTF6(NHEAD)
IFLAG1=.TRUE.
IFLAG2=.FALSE.
CCCCC CALL DPRTF2(IFLAG1,IFLAG2,NHEAD)
C
IHEAD(1:18)='Critical Value = '
NCHAR(1)=18
CALL DPRTF7(IHEAD,NCHAR(1),HCV)
CALL DPRTF6(NHEAD)
CALL DPRTF6(NHEAD)
C
C TABLE 3
C
ITTEMP(NCTABT+1:NCTABT+2)='-k'
NCTEMP=NCTABT+2
NHEAD=0
CALL DPRTF1(IHEAD,NHEAD,ITTEMP,NCTEMP)
C
IWIDTH(1)=2*IINC1
IWIDTH(2)=IWIDTH(1) + NUMSE2*IINC1
ALIGN(1)='c'
ALIGN(2)='c'
VALIGN(1)='b'
VALIGN(2)='b'
NHEAD=2
IFLAG1=.TRUE.
IFLAG1=.TRUE.
IVALUE(1)=' '
NCHAR(1)=1
IVALUE(2)(1:8)='Material'
NCHAR(2)=8
CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2)
C
NUMDI2(1)=0
IWIDTH(1)=2*IINC1
DO6805ISET1=2,MIN(NUMSE2+1,MAXHED)
VALIGN(ISET1)='b'
ALIGN(ISET1)='r'
NUMDI2(ISET1)=2
IWIDTH(ISET1)=IWIDTH(ISET1-1) + IINC1
6805 CONTINUE
ALIGN(1)='c'
C
IVALUE(1)='Laboratory'
NCHAR(1)=10
DO6817II=2,MIN(NUMSE2+1,MAXHED)
WRITE(IVALUE(II)(1:2),'(I2)')II-1
NCHAR(II)=2
6817 CONTINUE
NHEAD=MIN(NUMSE2+1,MAXHED)
IFLAG1=.TRUE.
IFLAG2=.TRUE.
CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2)
C
NCHAR(1)=0
IVALUE(1)=' '
NHEAD=NMAT+1
NSTOP=NMAT*NLAB
IFLAG1=.FALSE.
DO6820ISET1=1,NLAB
ILAB=INT(XIDTEM(ISET1)+0.5)
AVALUE(1)=XIDTEM(ISET1)
ICNT=1
DO6825II=ILAB,NSTOP,NLAB
ICNT=ICNT+1
AVALUE(ICNT)=AK(II)
6825 CONTINUE
IF(ISET1.EQ.NLAB)IFLAG1=.TRUE.
CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1)
6820 CONTINUE
C
CALL DPRTF6(NHEAD)
IFLAG1=.TRUE.
IFLAG2=.FALSE.
CCCCC CALL DPRTF2(IFLAG1,IFLAG2,NHEAD)
C
IHEAD(1:18)='Critical Value = '
NCHAR(1)=18
CALL DPRTF7(IHEAD,NCHAR(1),KCV)
CALL DPRTF6(NHEAD)
CALL DPRTF6(NHEAD)
IF(IRTFPS.GT.IMXPS)THEN
IF(2*IRTFPS.LE.9)THEN
WRITE(ICOUT,6702)IBASLC,2*IRTFPS
CALL DPWRST(ICOUT,'WRIT')
ELSEIF(2*IRTFPS.LE.9)THEN
WRITE(ICOUT,6703)IBASLC,2*IRTFPS
CALL DPWRST(ICOUT,'WRIT')
ENDIF
ENDIF
C
C TABLE 4
C
ITTEMP(NCTABT+1:NCTABT+21)='-Precision Statistics'
NCTEMP=NCTABT+21
NHEAD=0
IFLAG1=.TRUE.
CALL DPRTF1(IHEAD,NHEAD,ITTEMP,NCTEMP)
NHEAD=NUMSE2+1
C
IDEFPS=20
IFRST=IRTFPS*1400/IDEFPS
IINC1=IRTFPS*1400/IDEFPS
IINC2=IRTFPS*800/IDEFPS
DO6915ISET1=1,7
VALIGN(ISET1)='b'
ALIGN(ISET1)='r'
NUMDI2(ISET1)=NUMDIG
6915 CONTINUE
ALIGN(1)='c'
IWIDTH(1)=IFRST
DO6918I=2,5
IWIDTH(I)=IWIDTH(I-1) + IINC1
6918 CONTINUE
IWIDTH(6)=IWIDTH(5) + IINC2
IWIDTH(7)=IWIDTH(6) + IINC2
NUMDI2(1)=0
NUMDI2(6)=2
NUMDI2(7)=2
IVALUE(1)=' b Material'
IVALUE(1)(1:1)=IBASLC
NCHAR(1)=11
IVALUE(2)=' b Xbar'
IVALUE(2)(1:1)=IBASLC
NCHAR(2)=7
IVALUE(3)=' b i s{ sub x}'
IVALUE(3)(1:1)=IBASLC
IVALUE(3)(3:3)=IBASLC
IVALUE(3)(8:8)=IBASLC
NCHAR(3)=14
IVALUE(4)=' b i s{ sub r}'
IVALUE(4)(1:1)=IBASLC
IVALUE(4)(3:3)=IBASLC
IVALUE(4)(8:8)=IBASLC
NCHAR(4)=14
IVALUE(5)=' b i s{ sub R}'
IVALUE(5)(1:1)=IBASLC
IVALUE(5)(3:3)=IBASLC
IVALUE(5)(8:8)=IBASLC
NCHAR(5)=14
IVALUE(6)=' b i r'
IVALUE(6)(1:1)=IBASLC
IVALUE(6)(3:3)=IBASLC
NCHAR(6)=6
IVALUE(7)=' b i R'
IVALUE(7)(1:1)=IBASLC
IVALUE(7)(3:3)=IBASLC
NCHAR(7)=6
NHEAD=7
IFLAG1=.TRUE.
IFLAG2=.TRUE.
CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2)
C
AR=2.8
NCHAR(1)=0
NHEAD=7
IFLAG1=.FALSE.
DO6930ISET2=1,NUMSE2
AVALUE(1)=XIDTE2(ISET2)
AVALUE(2)=XBAR(ISET2)
AVALUE(3)=SDXBRI(ISET2)
AVALUE(4)=SRPT(ISET2)
AVALUE(5)=SRPRD(ISET2)
AR1=2.8*SRPT(ISET2)
AR2=2.8*SRPRD(ISET2)
AVALUE(6)=AR1
AVALUE(7)=AR2
IF(ISET2.EQ.NUMSE2)IFLAG1=.TRUE.
CALL DPRTF5(IVALUE,NCHAR(1),AVALUE,NHEAD,IFLAG1)
6930 CONTINUE
C
CALL DPRTF6(NHEAD)
CALL DPRTF6(NHEAD)
IF(IRTFFP.EQ.'Times New Roman')THEN
ITEMP=0
ELSEIF(IRTFFP.EQ.'Lucida Sans')THEN
ITEMP=6
ELSEIF(IRTFFP.EQ.'Arial')THEN
ITEMP=2
ELSEIF(IRTFFP.EQ.'Bookman')THEN
ITEMP=3
ELSEIF(IRTFFP.EQ.'Georgia')THEN
ITEMP=4
ELSEIF(IRTFFP.EQ.'Tahoma')THEN
ITEMP=5
ELSEIF(IRTFFP.EQ.'Verdana')THEN
ITEMP=7
ELSE
ITEMP=0
ENDIF
WRITE(ICOUT,6591)IBASLC,ITEMP
CALL DPWRST(ICOUT,'WRIT')
C
IRTFMD='VERB'
C
ELSE
ISTEPN='7.1'
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'EIN2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C HEADER
C
IFRMT2='(A )'
WRITE(IFRMT2(3:4),'(I2)')NCTABT
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,7001)
7001 FORMAT(15X,'INTERLABORATORY ANALYSIS (BASED ON E 691 - 99 ',
1 'STANDARD)')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
C
C TABLE 1
C
ICNT=0
IFRMT5=' '
IFRMT5(1:34)='(2X,I4,4X,3(1X,F15.7),2(1X,F10.2))'
WRITE(IFRMT5(20:20),'(I1)')NUMDIG
C
DO7100ISET2=1,NUMSE2
IMAT=INT(XIDTE2(ISET2)+0.5)
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,IFRMT2)ITABTI(1:NCTABT)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,7013)IMAT
7013 FORMAT('Initial Preparation of Test Result Data for ',
1 'Material: ',I8)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,7015)
7015 FORMAT('=================================================',
1 '===============================')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,7017)
7017 FORMAT('Laboratory Cell Cell',
1 ' ',
1 ' ')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,7018)
7018 FORMAT(' Number Mean SD',
1 ' d',
1 ' h k')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,7015)
CALL DPWRST('XXX','WRIT')
DO7110ISET1=1,NUMSE1
ILAB=INT(XIDTEM(ISET1)+0.5)
ICNT=ICNT+1
WRITE(ICOUT,IFRMT5)ILAB,XBARI(ICNT),SDI(ICNT),
1 DXBARI(ICNT),H(ICNT),AK(ICNT)
CALL DPWRST('XXX','WRIT')
7110 CONTINUE
C
WRITE(ICOUT,7015)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,7131)XBAR(ISET2)
7131 FORMAT(2X,'Average of cell averages = ',F12.5)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,7133)SDXBRI(ISET2)
7133 FORMAT(2X,'Standard deviation of cell averages = ',F12.5)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,7135)SRPT(ISET2)
7135 FORMAT(2X,'Repeatability standard deviation = ',F12.5)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,7137)SRPRD(ISET2)
7137 FORMAT(2X,'Reproducability standard deviation = ',F12.5)
CALL DPWRST('XXX','WRIT')
7100 CONTINUE
C
C TABLE 2
C
C NOTE: DETERMINE HOW MANY MATERIALS CAN REASONABLY BE PRINTED FOR
C THE TABLE (I.E., DOES THE TABLE NEED TO BE PRINTED IN
C MORE THAN 1 ITERATION).
C
NITEMS=(ILPRCO - 11)/10
NIT=(NMAT/NITEMS) + 1
IF(MOD(NMAT,NITEMS).EQ.0)NIT=NIT-1
C
DO7200ITER=1,MAX(NIT,1)
C
IFRST=(ITER-1)*NITEMS + 1
ILAST=MIN(ITER*NITEMS,NMAT)
NTEMP=ILAST-IFRST+1
C
IFRMT2='(A ,A2)'
WRITE(IFRMT2(3:4),'(I2)')NCTABT
NEQ=11 + NTEMP*10
IFRMT3=' '
IFRMT3(1:7)='( A1)'
WRITE(IFRMT3(2:4),'(I3)')NEQ
DO7201I=1,MIN(NEQ,200)
IEQUAL(I)='='
7201 CONTINUE
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,IFRMT2)ITABTI(1:NCTABT),'-h'
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,IFRMT3)(IEQUAL(JJ),JJ=1,NEQ)
CALL DPWRST('XXX','WRIT')
IFRMT4=' '
IFRMT4='( X,A8)'
NSPAC=6 + (NTEMP*10/2)
WRITE(IFRMT4(2:4),'(I3)')NSPAC
WRITE(ICOUT,IFRMT4)'Material'
CALL DPWRST('XXX','WRIT')
IFRMT4=' '
IFRMT4='(A10,2X, (2X,I5,3X))'
WRITE(IFRMT4(9:11),'(I3)')NTEMP
WRITE(ICOUT,IFRMT4)'Laboratory',
1 (INT(XIDTE2(JJ)+0.5),JJ=IFRST,ILAST)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,IFRMT3)(IEQUAL(JJ),JJ=1,NEQ)
CALL DPWRST('XXX','WRIT')
ICNT=0
IFORMT=' '
IFORMT(1:15)='(I6,5X, F10.2)'
IF(NTEMP.LE.9)THEN
WRITE(IFORMT(9:9),'(I1)')NTEMP
ELSE
WRITE(IFORMT(8:9),'(I2)')NTEMP
ENDIF
C
DO7290ISET1=1,NUMSE1
ILAB=INT(XIDTEM(ISET1)+0.5)
NSTRT=ILAB + (IFRST-1)*NUMSE1
NSTOP=ILAST*NLAB
WRITE(ICOUT,IFORMT)ILAB,(H(II),II=NSTRT,NSTOP,NUMSE1)
CALL DPWRST('XXX','WRIT')
7290 CONTINUE
WRITE(ICOUT,IFRMT3)(IEQUAL(JJ),JJ=1,NEQ)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,7229)HCV
7229 FORMAT(2X,'CRITICAL VALUE = ',F7.2)
CALL DPWRST('XXX','WRIT')
7200 CONTINUE
C
C TABLE 3
C
C NOTE: DETERMINE HOW MANY MATERIALS CAN REASONABLY BE PRINTED FOR
C THE TABLE (I.E., DOES THE TABLE NEED TO BE PRINTED IN
C MORE THAN 1 ITERATION).
C
NITEMS=(ILPRCO - 11)/10
NIT=(NMAT/NITEMS) + 1
IF(MOD(NMAT,NITEMS).EQ.0)NIT=NIT-1
C
DO7300ITER=1,MAX(NIT,1)
C
IFRST=(ITER-1)*NITEMS + 1
ILAST=MIN(ITER*NITEMS,NMAT)
NTEMP=ILAST-IFRST+1
C
NEQ=11 + NTEMP*10
IFRMT3=' '
IFRMT3(1:7)='( A1)'
WRITE(IFRMT3(2:4),'(I3)')NEQ
DO7301I=1,MIN(NEQ,200)
IEQUAL(I)='='
7301 CONTINUE
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,IFRMT2)ITABTI(1:NCTABT),'-k'
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,IFRMT3)(IEQUAL(JJ),JJ=1,NEQ)
C
IFRMT4=' '
IFRMT4='( X,A8)'
NSPAC=6 + (NTEMP*10/2)
WRITE(IFRMT4(2:4),'(I3)')NSPAC
WRITE(ICOUT,IFRMT4)'Material'
CALL DPWRST('XXX','WRIT')
IFRMT4=' '
IFRMT4='(A10,2X, (2X,I5,3X))'
WRITE(IFRMT4(9:11),'(I3)')NTEMP
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,IFRMT4)'Laboratory',
1 (INT(XIDTE2(JJ)+0.5),JJ=IFRST,ILAST)
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,IFRMT3)(IEQUAL(JJ),JJ=1,NEQ)
CALL DPWRST('XXX','WRIT')
ICNT=0
IFORMT=' '
IFORMT(1:15)='(I6,5X, F10.2)'
IF(NTEMP.LE.9)THEN
WRITE(IFORMT(9:9),'(I1)')NTEMP
ELSE
WRITE(IFORMT(8:9),'(I2)')NTEMP
ENDIF
C
DO7390ISET1=1,NUMSE1
ILAB=INT(XIDTEM(ISET1)+0.5)
NSTRT=ILAB + (IFRST-1)*NUMSE1
NSTOP=ILAST*NLAB
WRITE(ICOUT,IFORMT)ILAB,(AK(II),II=NSTRT,NSTOP,NUMSE1)
CALL DPWRST('XXX','WRIT')
7390 CONTINUE
WRITE(ICOUT,IFRMT3)(IEQUAL(JJ),JJ=1,NEQ)
CALL DPWRST('XXX','WRIT')
7300 CONTINUE
WRITE(ICOUT,7329)KCV
7329 FORMAT(2X,'CRITICAL VALUE = ',F7.2)
CALL DPWRST('XXX','WRIT')
C
C TABLE 4
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
IFRMT2='(A ,A21)'
WRITE(IFRMT2(3:4),'(I2)')NCTABT
NEQ=88
IFRMT3=' '
IFRMT3(1:7)='( A1)'
WRITE(IFRMT3(2:4),'(I3)')NEQ
DO7401I=1,MIN(NEQ,500)
IEQUAL(I)='='
7401 CONTINUE
C
IFRMT5=' '
IFRMT5(1:30)='(I5,3X,4(1X,F15.7),2(1X,F7.2))'
WRITE(IFRMT5(17:17),'(I1)')NUMDIG
C
WRITE(ICOUT,IFRMT2)ITABTI(1:NCTABT),'-Precision Statistics'
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,IFRMT3)(IEQUAL(JJ),JJ=1,NEQ)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,7417)
7417 FORMAT('Material Xbar s(x)',
1 ' s(r) ',
1 ' s(R) r R')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,IFRMT3)(IEQUAL(JJ),JJ=1,NEQ)
CALL DPWRST('XXX','WRIT')
C
AR=2.8
DO7400ISET2=1,NUMSE2
IMAT=INT(XIDTE2(ISET2)+0.5)
AR1=2.8*SRPT(ISET2)
AR2=2.8*SRPRD(ISET2)
WRITE(ICOUT,IFRMT5)IMAT,XBAR(ISET2),SDXBRI(ISET2),
1 SRPT(ISET2),SRPRD(ISET2),AR1,AR2
CALL DPWRST('XXX','WRIT')
7400 CONTINUE
WRITE(ICOUT,IFRMT3)(IEQUAL(JJ),JJ=1,NEQ)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
C
ENDIF
ENDIF
C
IF(IFEEDB.EQ.'OFF')GOTO8099
IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')GOTO8099
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8005)
8005 FORMAT('THE FOLLOWING VARIABLES WERE WRITTEN TO THE FILE ',
1 'dpst1f.dat:')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8011)
8011 FORMAT(' 1. MATERIAL ID')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8013)
8013 FORMAT(' 2. LAB ID')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8021)
8021 FORMAT(' 3. CELL AVERAGE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8023)
8023 FORMAT(' 4. CELL STANDARD DEVIATION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8025)
8025 FORMAT(' 5. CELL AVERAGE - OVERALL AVERAGE FOR MATERIAL')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8027)
8027 FORMAT(' 6. H-CONSISTENCY STATISTIC')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8029)
8029 FORMAT(' 7. VARIANCE OF MEAN OF LAB')
CALL DPWRST('XXX','BUG ')
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8041)
8041 FORMAT('THE H-CONSISTECNY STATISTICS WERE WRITTEN TO THE FILE ',
1 'dpst2f.dat:')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8043)
8043 FORMAT(' THE ROWS REPRESENT THE LAB AND THE COLUMNS REPRESENT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8045)
8045 FORMAT(' THE MATERIALS.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8051)
8051 FORMAT('THE K-CONSISTECNY STATISTICS WERE WRITTEN TO THE FILE ',
1 'dpst3f.dat:')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8053)
8053 FORMAT(' THE ROWS REPRESENT THE LAB AND THE COLUMNS REPRESENT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8055)
8055 FORMAT(' THE MATERIALS.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
C
WRITE(ICOUT,8071)
8071 FORMAT('THE FOLLOWING VARIABLES WERE WRITTEN TO THE FILE ',
1 'dpst4f.dat:')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8073)
8073 FORMAT(' 1. MATERIAL ID')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8075)
8075 FORMAT(' 2. MEAN OF THE CELL AVERAGES')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8077)
8077 FORMAT(' 3. STANDARD DEVIATION OF THE CELL AVERAGES')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8079)
8079 FORMAT(' 4. REPEATABILITY STANDARD DEVIATION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8081)
8081 FORMAT(' 5. REPRODUCABILITY STANDARD DEVIATION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8083)
8083 FORMAT(' 6. 95% REPEATABILITY STANDARD DEVIATION LIMIT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8085)
8085 FORMAT(' 7. 95% REPRODUCABILITY STANDARD DEVIATION LIMIT')
CALL DPWRST('XXX','BUG ')
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8091)
8091 FORMAT(' H- AND K-CONSISTENCY STATISTIC CRITICAL VALUES ',
1 'SAVED AS INTERNAL PARAMETERS HCV AND KCV.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
C
8099 CONTINUE
GOTO9000
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'EIN2')THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPEIN2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IERROR,IBUGA3
9012 FORMAT('IERROR,IBUGA3 = ',A4,1X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)N
9013 FORMAT('N = ',2I8)
CALL DPWRST('XXX','BUG ')
ENDIF
C
RETURN
END
SUBROUTINE DPELL2(X1,Y1,X2,Y2,X3,Y3,
1IFIG,
1ILINPA,ILINCO,PLINTH,
1AREGBA,
1IREBLI,IREBCO,PREBTH,
1IREFSW,IREFCO,
1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
1PTEXHE,PTEXWI,PTEXVG,PTEXHG)
C
C PURPOSE--DRAW A ELLIPSE
C WITH ONE END OF THE MAJOR AXIS AT (X1,Y1)
C WITH ONE END OF THE MINOR AXIS AT (X2,Y2)
C AND THE OTHER END OF MAJOR AXIS AT (X3,Y3).
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-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--APRIL 1981.
C UPDATED --MAY 1982.
C UPDATED --JANUARY 1989. MODIFY CALLS TO DPDRPL (ALAN)
C UPDATED --FEBRUARY 1994. ARRAY TO GARBAGE COMMON
C
C-----NON-COMMON VARIABLES-------------------------------------
C
CHARACTER*4 IPATT2
CHARACTER*4 IFIG
C
CHARACTER*4 ILINPA
CHARACTER*4 ILINCO
C
CHARACTER*4 IREBLI
CHARACTER*4 IREBCO
CHARACTER*4 IREFSW
CHARACTER*4 IREFCO
CHARACTER*4 IREPTY
CHARACTER*4 IREPLI
CHARACTER*4 IREPCO
C
CHARACTER*4 IPATT
CHARACTER*4 ICOLF
CHARACTER*4 ICOLP
CHARACTER*4 ICOL
CHARACTER*4 IFLAG
C
DIMENSION PX(1000)
DIMENSION PY(1000)
CCCCC FEBRUARY 1994. ADD FOLLOWING SECTION
INCLUDE 'DPCOPA.INC'
INCLUDE 'DPCOZ2.INC'
EQUIVALENCE (G2RBAG(IGAR11),PX(1))
EQUIVALENCE (G2RBAG(IGAR12),PY(1))
CCCCC END CHANGE
CCCCC DIMENSION PX3(1000)
CCCCC DIMENSION PY3(1000)
C
DIMENSION ILINPA(*)
DIMENSION ILINCO(*)
DIMENSION PLINTH(*)
C
DIMENSION AREGBA(*)
DIMENSION IREBLI(*)
DIMENSION IREBCO(*)
DIMENSION PREBTH(*)
DIMENSION IREFSW(*)
DIMENSION IREFCO(*)
DIMENSION IREPTY(*)
DIMENSION IREPLI(*)
DIMENSION IREPCO(*)
DIMENSION PREPTH(*)
DIMENSION PREPSP(*)
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCOGR.INC'
INCLUDE 'DPCOBE.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'ELL2')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPELL2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)X1,Y1
53 FORMAT('X1,Y1 = ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)X2,Y2
54 FORMAT('X2,Y2 = ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,55)X3,Y3
55 FORMAT('X3,Y3 = ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,59)IFIG
59 FORMAT('IFIG = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,62)AREGBA(1)
62 FORMAT('AREGBA(1) = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
1A4,2X,A4,2X,A4,2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,69)PTEXHE,PTEXWI
69 FORMAT('PTEXHE,PTEXWI= ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,70)PTEXVG,PTEXHG
70 FORMAT('PTEXVG,PTEXHG= ',2E15.6)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4
79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C *********************************
C ** STEP 1-- **
C ** DETERMINE THE COORDINATES **
C ** FOR THE ELLIPSE **
C *********************************
C
DELX=X3-X1
DELY=Y3-Y1
ALEN=0.0
TERM=DELX**2+DELY**2
IF(TERM.GT.0.0)ALEN=SQRT(TERM)
A=ALEN/2.0
C
IF(ABS(DELX).GE.0.00001)THETA=ATAN(DELY/DELX)
IF(ABS(DELX).LT.0.00001.AND.DELY.GE.0.0)THETA=3.1415926/2.0
IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0)THETA=-3.1415926/2.0
C
XCENT=(X1+X3)/2.0
YCENT=(Y1+Y3)/2.0
C
DELX2=X2-XCENT
DELY2=Y2-YCENT
ALEN=0.0
TERM=DELX2**2+DELY2**2
IF(TERM.GT.0.0)ALEN=SQRT(TERM)
B=ALEN
C
K=0
C
X=0.0
Y=0.0
CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
K=K+1
PX(K)=XP
PY(K)=YP
C
DO3010I=181,541,5
IREV=541-I+181
PHI2=IREV-1
PHI2=PHI2*(2.0*3.1415926)/360.0
X=A*COS(PHI2)+A
Y=B*SIN(PHI2)
CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
K=K+1
PX(K)=XP
PY(K)=YP
3010 CONTINUE
C
NP=K
C
C ***********************
C ** STEP 2-- **
C ** FILL THE FIGURE **
C ** (IF CALLED FOR) **
C ***********************
C
IF(IREFSW(1).EQ.'OFF')GOTO2190
IPATT=IREPTY(1)
IPATT2='SOLI'
PTHICK=PREPTH(1)
PXGAP=PREPSP(1)
PYGAP=PREPSP(1)
ICOLF=IREFCO(1)
ICOLP=IREPCO(1)
CALL DPFIRE(PX,PY,NP,
1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2)
2190 CONTINUE
C
C ***************************
C ** STEP 3-- **
C ** DRAW OUT THE FIGURE **
C ***************************
C
IPATT=ILINPA(1)
PTHICK=PLINTH(1)
ICOL=ILINCO(1)
IFLAG='ON'
CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3,
CCCCC1IFIG,IPATT,PTHICK,ICOL)
CALL DPDRPL(PX,PY,NP,
1IFIG,IPATT,PTHICK,ICOL,
1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'ELL2')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPELL2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)DELX,DELY,DELX2,DELY2
9012 FORMAT('DELX,DELY,DELX2,DELY2 = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)XCENT,YCENT,A,B,THETA
9013 FORMAT('XCENT,YCENT,A,B,THETA = ',5E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)NP
9014 FORMAT('NP = ',I8)
CALL DPWRST('XXX','BUG ')
DO9015I=1,NP
WRITE(ICOUT,9016)I,PX(I),PY(I)
9016 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7)
CALL DPWRST('XXX','BUG ')
9015 CONTINUE
WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4
9039 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPELLI(IHARG,IARGT,ARG,NUMARG,
1PXSTAR,PYSTAR,
1PXEND,PYEND,
1ILINPA,ILINCO,PLINTH,
1AREGBA,
1IREBLI,IREBCO,PREBTH,
1IREFSW,IREFCO,
1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
1IGRASW,IDIASW,
1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
1NUMDEV,
1IDMANU,IDMODE,IDMOD2,IDMOD3,
1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
1UNITSW,
1IBUGD2,IFOUND,IERROR)
C
C PURPOSE--DRAW ONE OR MORE ELLIPSES
C (DEPENDING ON HOW MANY NUMBERS ARE PROVIDED).
C THE COORDINATES ARE IN STANDARDIZED UNITS
C OF 0 TO 100.
C NOTE--THE INPUT COORDINATES DEFINE 3 SUCCESSIVE POINTS
C AROUND THE ELLIPSE--AT THE ENDS OF AXES.
C NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 3
C AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*3 = 6.
C NOTE--IF 4 NUMBERS ARE PROVIDED,
C THEN THE DRAWN ELLIPSE WILL GO
C FROM THE LAST CURSOR POSITION
C (ASSUMED TO BE AT ONE END OF MAJOR AXIS)
C THROUGH THE (X,Y) POINT
C (EITHER ABSOLUTE OR RELATIVE)
C AS DEFINED BY THE FIRST AND SECOND NUMBERS
C (ASSUMED TO BE AT ONE END OF MINOR AXIS),
C TO THE (X,Y) POINT
C (EITHER ABSOLUTE OR RELATIVE)
C AS DEFINED BY THE THIRD AND FOURTH NUMBERS
C (ASSUMED TO BE AT THE OTHER END OF MAJOR AXIS),
C AND THEN BACK TO THE OTHER END OF THE MINOR AXIS,
C AND CONTINUING BACK THE START POINT TO CLOSE THE ELLIPSE.
C NOTE--IF 6 NUMBERS ARE PROVIDED,
C THEN THE DRAWN ELLIPSE WILL GO
C FROM THE ABSOLUTE (X,Y) POSITION
C AS RESULTING FORM THE FIRST AND SECOND NUMBERS
C (ASSUMED TO BE AT ONE END OF MAJOR AXIS),
C THROUGH THE (X,Y) POINT
C (EITHER ABSOLUTE OR RELATIVE)
C AS DEFINED BY THE THIRD AND FOURTH NUMBERS
C (ASSUMED TO BE AT ONE END OF MINOR AXIS),
C TO THE (X,Y) POINT
C (EITHER ABSOLUTE OR RELATIVE)
C AS DEFINED BY THE FIFTH AND SIXTH NUMBERS
C (ASSUMED TO BE AT THE OTHER END OF MAJOR AXIS),
C AND THEN BACK TO THE OTHER END OF THE MINOR AXIS,
C AND CONTINUING BACK THE START POINT TO CLOSE THE ELLIPSE.
C NOTE--AND SO FORTH FOR 10, 14, 18, ... NUMBERS.
C INPUT ARGUMENTS--IHARG
C --IARGT
C --ARG
C --NUMARG
C --PXSTAR
C --PYSTAR
C OUTPUT ARGUMENTS--PXEND
C --PYEND
C --IFOUND ('YES' OR 'NO' )
C --IERROR ('YES' OR 'NO' )
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-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--APRIL 1981.
C UPDATED --MARCH 1982.
C UPDATED --MAY 1982.
C UPDATED --NOVEMBER 1982.
C UPDATED --JANUARY 1989. CALL LIST FOR OFFSET VAR (ALAN)
C UPDATED --MARCH 1997. SUPPORT FOR DEVICE FONT (ALAN)
C UPDATED --JULY 1997. SUPPORT FOR "DATA" UNITS (ALAN)
C
C-----NON-COMMON VARIABLES-----------------------------------------
C
CHARACTER*4 IHARG
CHARACTER*4 IARGT
C
CHARACTER*4 ILINPA
CHARACTER*4 ILINCO
C
CHARACTER*4 IREBLI
CHARACTER*4 IREBCO
CHARACTER*4 IREFSW
CHARACTER*4 IREFCO
CHARACTER*4 IREPTY
CHARACTER*4 IREPLI
CHARACTER*4 IREPCO
C
CHARACTER*4 IGRASW
CHARACTER*4 IDIASW
C
CHARACTER*4 IDMANU
CHARACTER*4 IDMODE
CHARACTER*4 IDMOD2
CHARACTER*4 IDMOD3
CHARACTER*4 IDPOWE
CHARACTER*4 IDCONT
CHARACTER*4 IDCOLO
CCCCC ADD FOLLOWING LINE MARCH 1997.
CHARACTER*4 IDFONT
CCCCC ADD FOLLOWING LINE JULY 1997.
CHARACTER*4 UNITSW
C
CHARACTER*4 IFOUND
CHARACTER*4 IBUGD2
CHARACTER*4 IERROR
CHARACTER*4 ISUBRO
C
CHARACTER*4 IFIG
CHARACTER*4 IBELSW
CHARACTER*4 IERASW
CHARACTER*4 IBACCO
CHARACTER*4 ICOPSW
CHARACTER*4 ITYPEO
C
DIMENSION IHARG(*)
DIMENSION IARGT(*)
DIMENSION ARG(*)
C
DIMENSION ILINPA(*)
DIMENSION ILINCO(*)
DIMENSION PLINTH(*)
C
DIMENSION AREGBA(*)
DIMENSION IREBLI(*)
DIMENSION IREBCO(*)
DIMENSION PREBTH(*)
DIMENSION IREFSW(*)
DIMENSION IREFCO(*)
DIMENSION IREPTY(*)
DIMENSION IREPLI(*)
DIMENSION IREPCO(*)
DIMENSION PREPTH(*)
DIMENSION PREPSP(*)
C
DIMENSION IDMANU(*)
DIMENSION IDMODE(*)
DIMENSION IDMOD2(*)
DIMENSION IDMOD3(*)
DIMENSION IDPOWE(*)
DIMENSION IDCONT(*)
DIMENSION IDCOLO(*)
CCCCC ADD FOLLOWING LINE MARCH 1997.
DIMENSION IDFONT(*)
DIMENSION IDNVPP(*)
DIMENSION IDNHPP(*)
DIMENSION IDUNIT(*)
C
DIMENSION IDNVOF(*)
DIMENSION IDNHOF(*)
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCOGR.INC'
INCLUDE 'DPCOBE.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
IFOUND='NO'
IERROR='NO'
IERRG4=IERROR
CCCCC IBUGG4=IBUGD2
CCCCC ISUBG4=ISUBRO
C
ILOCFN=0
NUMNUM=0
C
X1=0.0
Y1=0.0
X2=0.0
Y2=0.0
C
IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'ELLI')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPELLI--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)NUMARG
53 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
DO55I=1,NUMARG
WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I)
56 FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2X,A4,2X,A4,E15.7)
CALL DPWRST('XXX','BUG ')
55 CONTINUE
WRITE(ICOUT,57)PXSTAR,PYSTAR
57 FORMAT('PXSTAR,PYSTAR = ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,58)PXEND,PYEND
58 FORMAT('PXEND,PYEND = ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,62)AREGBA(1)
62 FORMAT('AREGBA(1) = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
1A4,2X,A4,2X,A4,2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,69)PTEXHE,PTEXWI
69 FORMAT('PTEXHE,PTEXWI= ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,70)PTEXVG,PTEXHG
70 FORMAT('PTEXVG,PTEXHG= ',2E15.6)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,76)IGRASW,IDIASW
76 FORMAT('IGRASW,IDIASW = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC
77 FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG
78 FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,80)NUMDEV
80 FORMAT('NUMDEV= ',I8)
CALL DPWRST('XXX','BUG ')
DO81I=1,NUMDEV
WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I)
82 FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ',
1A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I)
83 FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ',
1A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I)
84 FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ',
1I8,I8,I8)
CALL DPWRST('XXX','BUG ')
81 CONTINUE
WRITE(ICOUT,87)IFOUND
87 FORMAT('IFOUND= ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,88)IBUGG4,ISUBG4,IERRG4
88 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,89)IBUGD2,IERROR
89 FORMAT('IBUGD2,IERROR= ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
IFIG='ELLI'
NUMPT=3
NUMPT2=2*NUMPT
C
C ********************************
C ** STEP 0-- **
C ** STEP THROUGH EACH DEVICE **
C ********************************
C
IF(NUMDEV.LE.0)GOTO9000
DO8000IDEVIC=1,NUMDEV
C
IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000
C
IMANUF=IDMANU(IDEVIC)
IMODEL=IDMODE(IDEVIC)
IMODE2=IDMOD2(IDEVIC)
IMODE3=IDMOD3(IDEVIC)
IGCONT=IDCONT(IDEVIC)
IGCOLO=IDCOLO(IDEVIC)
CCCCC ADD FOLLOWING LINE MARCH 1997.
IGFONT=IDFONT(IDEVIC)
NUMVPP=IDNVPP(IDEVIC)
NUMHPP=IDNHPP(IDEVIC)
ANUMVP=NUMVPP
ANUMHP=NUMHPP
C AUGUST 1988. ADD OFFSET VARIABLE
IOFFSV=IDNVOF(IDEVIC)
IOFFSH=IDNHOF(IDEVIC)
C
IGUNIT=IDUNIT(IDEVIC)
C
C ************************************
C ** STEP 1-- **
C ** CARRY OUT OPENING OPERATIONS **
C ** ON THE GRAPHICS DEVICES **
C ************************************
C
CALL DPOPDE
C
IBELSW='OFF'
NUMRIN=0
IERASW='OFF'
IBACCO='JUNK'
C
CALL DPOPPL(IGRASW,
1IBELSW,NUMRIN,IERASW,
1IBACCO)
C
C *****************************************
C ** STEP 2-- **
C ** SEARCH FOR COMMAND SPECIFICATIONS **
C *****************************************
C
IF(NUMARG.GE.2.AND.
1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB')
1GOTO1111
IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND.
1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')
1GOTO1112
IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND.
1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')
1GOTO1113
GOTO1130
C
1111 CONTINUE
ITYPEO='ABSO'
ILOCFN=1
GOTO1119
C
1112 CONTINUE
ITYPEO='ABSO'
ILOCFN=2
GOTO1119
C
1113 CONTINUE
ITYPEO='RELA'
ILOCFN=2
GOTO1119
1119 CONTINUE
C
IF(ILOCFN.GT.NUMARG)GOTO1129
DO1120I=ILOCFN,NUMARG
IF(IARGT(I).EQ.'NUMB')GOTO1120
GOTO1129
1120 CONTINUE
IFOUND='YES'
GOTO1149
1129 CONTINUE
GOTO1130
C
1130 CONTINUE
IERRG4='YES'
WRITE(ICOUT,1131)
1131 FORMAT('***** ERROR IN DPELLI--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1132)
1132 FORMAT(' ILLEGAL FORM FOR DRAW ',
1'COMMAND.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1134)
1134 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ',
1'PROPER FORM--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1135)
1135 FORMAT(' SUPPOSE IT IS DESIRED TO DRAW AN ELLIPSE ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1136)
1136 FORMAT(' WITH ONE END OF MAJOR AXIS AT THE POINT 20 20 ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1137)
1137 FORMAT(' ONE END OF THE MINOR AXIS AT THE POINT 30 10')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1138)
1138 FORMAT(' AND WITH THE OTHER END OF THE MAJOR AXIS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1139)
1139 FORMAT(' AT THE POINT 40 20')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1141)
1141 FORMAT(' THEN THE ALLOWABLE FORMS ARE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1142)
1142 FORMAT(' ELLIPSE 20 20 30 10 40 20 ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1143)
1143 FORMAT(' ELLIPSE ABSOLUTE 20 20 30 10 40 20 ')
CALL DPWRST('XXX','BUG ')
GOTO9000
1149 CONTINUE
C
C ****************************
C ** STEP 3-- **
C ** DRAW OUT THE LINE(S) **
C ****************************
C
NUMNUM=NUMARG-ILOCFN+1
IF(NUMNUM.LT.NUMPT2)GOTO1151
GOTO1152
C
1151 CONTINUE
J=ILOCFN-1
X1=PXSTAR
Y1=PYSTAR
GOTO1159
C
1152 CONTINUE
J=ILOCFN
IF(J.GT.NUMARG)GOTO1190
X1=ARG(J)
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,IBUGD2,ISUBRO,IERROR)
J=J+1
IF(J.GT.NUMARG)GOTO1190
Y1=ARG(J)
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBRO,IERROR)
GOTO1159
1159 CONTINUE
C
1160 CONTINUE
J=J+1
IF(J.GT.NUMARG)GOTO1190
X2=ARG(J)
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR)
IF(ITYPEO.EQ.'RELA')X2=X1+X2
J=J+1
IF(J.GT.NUMARG)GOTO1190
Y2=ARG(J)
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR)
IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2
C
1170 CONTINUE
J=J+1
IF(J.GT.NUMARG)GOTO1190
X3=ARG(J)
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X3,X3,IBUGD2,ISUBRO,IERROR)
IF(ITYPEO.EQ.'RELA')X3=X2+X3
J=J+1
IF(J.GT.NUMARG)GOTO1190
Y3=ARG(J)
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y3,Y3,IBUGD2,ISUBRO,IERROR)
IF(ITYPEO.EQ.'RELA')Y3=Y2+Y3
C
CALL DPELL2(X1,Y1,X2,Y2,X3,Y3,
1IFIG,
1ILINPA,ILINCO,PLINTH,
1AREGBA,
1IREBLI,IREBCO,PREBTH,
1IREFSW,IREFCO,
1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
1PTEXHE,PTEXWI,PTEXVG,PTEXHG)
C
X1=X3
Y1=Y3
C
GOTO1160
1190 CONTINUE
C
PXEND=X3
PYEND=Y3
C
C ************************************
C ** STEP 4-- **
C ** CARRY OUT CLOSING OPERATIONS **
C ** ON THE GRAPHICS DEVICES **
C ************************************
C
ICOPSW='OFF'
NUMCOP=0
CALL DPCLPL(ICOPSW,NUMCOP,
1PGRAXF,PGRAYF,
1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
1PDIAHE,PDIAWI,PDIAVG,PDIAHG)
C
CALL DPCLDE
C
8000 CONTINUE
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'ELLI')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPELLI--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)ILOCFN,NUMNUM
9012 FORMAT('ILOCFN,NUMNUM = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)X1,Y1,X2,Y2,X3,Y3
9013 FORMAT('X1,Y1,X2,Y2,X3,Y3 = ',6E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)PXSTAR,PYSTAR
9015 FORMAT('PXSTAR,PYSTAR = ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9016)PXEND,PYEND
9016 FORMAT('PXEND,PYEND = ',2E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9017)IFIG
9017 FORMAT('IFIG = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9027)IFOUND
9027 FORMAT('IFOUND = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9028)IBUGG4,ISUBG4,IERRG4
9028 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9029)IBUGD2,IERROR
9029 FORMAT('IBUGD2,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPENMU(IMPSW,
1IERASV,
1PWXMIS,PWXMAS,PWYMIS,PWYMAS,
1IERASW,
1PWXMIN,PWXMAX,PWYMIN,PWYMAX,
1IBUGP2,IFOUND,IERROR)
C
C PURPOSE--END (TERMINATE) THE MULTIPLOT PROCESS
C INPUT ARGUMENTS--
C IMPSW = MULTIPLOT SWITCH (OFF OR ON)
C IERASV
C PWXMIS
C PWXMAS
C PWYMIS
C PWYMAS
C IBUGP2
C OUTPUT ARGUMENTS--
C IMPSW
C IERASW
C PWXMIN
C PWXMAX
C PWYMIN
C PWYMAX
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--86/7
C ORIGINAL VERSION--MARCH 1986.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IMPSW
CHARACTER*4 IERASV
CHARACTER*4 IERASW
CHARACTER*4 IBUGP2
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CCCCC CHARACTER*4 IHWUSE
CCCCC CHARACTER*4 MESSAG
CCCCC CHARACTER*4 IHWORD
CCCCC CHARACTER*4 IHWOR2
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
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='DPEN'
ISUBN2='MU '
C
IFOUND='NO'
IERROR='NO'
C
IF(IBUGP2.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPENMU--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)IBUGP2,IFOUND,IERROR
53 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,81)IMPSW
81 FORMAT('IMPSW = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,82)IERASV
82 FORMAT('IERASV = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,83)PWXMIS,PWXMAS,PWYMIS,PWYMAS
83 FORMAT('PWXMIS,PWXMAS,PWYMIS,PWYMAS = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,84)IERASW
84 FORMAT('IERASW = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,85)PWXMIN,PWXMAX,PWYMIN,PWYMAX
85 FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C *********************************************
C ** TREAT THE END OF MULTIPLOT CASE **
C *********************************************
C
1150 CONTINUE
IMPSW='OFF'
IERASW=IERASV
PWXMIN=PWXMIS
PWXMAX=PWXMAS
PWYMIN=PWYMIS
PWYMAX=PWYMAS
GOTO1180
C
1180 CONTINUE
IFOUND='YES'
C
IF(IFEEDB.EQ.'OFF')GOTO1189
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1181)
1181 FORMAT('THE MULTIPLOT SWITCH HAS JUST BEEN SET ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1182)
1182 FORMAT('TO OFF')
CALL DPWRST('XXX','BUG ')
1189 CONTINUE
GOTO9000
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGP2.EQ.'OFF')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPENMU--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)IBUGP2,IFOUND,IERROR
9013 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9041)IMPSW
9041 FORMAT('IMPSW = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9042)IERASV
9042 FORMAT('IERASV = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9043)PWXMIS,PWXMAS,PWYMIS,PWYMAS
9043 FORMAT('PWXMIS,PWXMAS,PWYMIS,PWYMAS = ',4E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9044)IERASW
9044 FORMAT('IERASW = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9045)PWXMIN,PWXMAX,PWYMIN,PWYMAX
9045 FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4E15.7)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPEPM2(Y,N,ICASPL,MAXNXT,MINMAX,IGEPDF,
1ISEED,NSAMP,
1P,GAMMSV,SCALSV,ALOCSV,TEMP1,
1ALOC,SCALE,SHAPE,
1IBUGA3,ISUBRO,IERROR)
C
C PURPOSE--ESTIMATE THE PARAMETERS OF A DISTRIBUTION USING
C THE ELEMENTAL PERCENTILE METHOD DESCRIBED BY
C CASTILLO, ET. AL. (SEE REFERENCE).
C
C SUPPORTED DISTRIBUTIONS ARE:
C
C 1) GENERALIZED PARETO
C 2) GENERALIZED EXTREME VALUE
C
C REFERENCE--CASTILLO, HADI, BALAKRISHNAN, SARABIA, "EXTREME
C VALUE AND RELATED MODELS WITH APPLICATIONS IN
C ENGINEERING AND SCIENCE", WILEY, 2005.
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C INFORMATION TECHNOLOGY LABORATORY
C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C GAITHERSBURG, MD 20899-8980
C PHONE--301-975-2899
C NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--2005/6
C ORIGINAL VERSION--JUNE 2005.
C UPDATED --AUGUST 2005. DUNRAN WAS FIXED TO GO FROM
C 0 TO N. THIS ROUTINE WAS
C MODIFIED TO CALL A VERSION
C THAT GOES FROM 1 TO N.
C
C---------------------------------------------------------------------
C
CHARACTER*4 ICASPL
CHARACTER*4 IGEPDF
CHARACTER*4 IBUGA3
CHARACTER*4 ISUBRO
CHARACTER*4 IERROR
C
DIMENSION Y(*)
DIMENSION P(*)
DIMENSION GAMMSV(*)
DIMENSION SCALSV(*)
DIMENSION ALOCSV(*)
DIMENSION TEMP1(*)
DIMENSION XRAN(3)
C
DOUBLE PRECISION XIN
DOUBLE PRECISION XJN
DOUBLE PRECISION XRN
DOUBLE PRECISION XNN
DOUBLE PRECISION PIN
DOUBLE PRECISION PJN
DOUBLE PRECISION PRN
DOUBLE PRECISION PNN
DOUBLE PRECISION DIJR
DOUBLE PRECISION AIJ
DOUBLE PRECISION AJI
DOUBLE PRECISION AIR
DOUBLE PRECISION AJR
DOUBLE PRECISION CI
DOUBLE PRECISION CR
DOUBLE PRECISION PJNSV
DOUBLE PRECISION DELTA0
DOUBLE PRECISION DTERM1
DOUBLE PRECISION EPS
DOUBLE PRECISION EPS2
DOUBLE PRECISION SIG
DOUBLE PRECISION XLOWER
DOUBLE PRECISION XUPPER
DOUBLE PRECISION XMID
DOUBLE PRECISION FXLOW
DOUBLE PRECISION FXUPP
DOUBLE PRECISION FCS
DOUBLE PRECISION XRML
C
INTEGER R
C
CHARACTER*4 IWRITE
CHARACTER*4 ISTEPN
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
C
CHARACTER*4 IFEESV
CHARACTER*4 IPRISV
CHARACTER*4 ICAPSW
CHARACTER*4 ICAPTY
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 EPS /0.00001D0/
DATA SIG /1.0D-5/
DATA MAXIT /300/
C
C-----START POINT-----------------------------------------------------
C
ISUBN1='DPEP'
ISUBN2='M2 '
IWRITE='OFF'
C
C ****************************************************
C ** STEP 1-- **
C ** A. SORT THE DATA **
C ** B. COMPUTE THE P(I,N) = I/(N+1) **
C ****************************************************
C
CALL SORT(Y,N,Y)
DO110I=1,N
P(I)=REAL(I)/REAL(N+1)
110 CONTINUE
C
C ****************************************************
C ** STEP 2-- **
C ** GENERATE EPM ESTIMATES FOR GIVEN DISTRIBUTION **
C ****************************************************
C
ISTEPN='2'
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'EPM2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(ICASPL.EQ.'GPAR' .AND. N.GT.45)GOTO1000
IF(ICASPL.EQ.'GPAR' .AND. N.LE.45)GOTO1500
IF(ICASPL.EQ.'GEV ')GOTO2000
GOTO9000
C
C GENERAL ALGORITHM FOR GENERALIZED PARETO GIVEN ON PAGES 274-275
C OF CASTILLO, ET.AL.
C
C FOR N <= 45, COMPUTE FOR ALL SUBSETS ((45 2) = 990). IF N > 45,
C COMPUTE NSAMP RANDOM SUBSETS (GENERATE AT LEAST 1,000).
C
1000 CONTINUE
C
XNN=DBLE(Y(N))
PNN=DBLE(P(N))
PJNSV=DBLE(P(1))
NCNT=0
EPS2=1.0D-12
DO1100II=1,NSAMP
C
NTEMP=2
CALL DUNRA2(NTEMP,N,ISEED,XRAN)
I=XRAN(1)
J=XRAN(2)
IF(I.GT.J)THEN
ITEMP=I
I=J
J=ITEMP
ENDIF
C
XIN=DBLE(Y(I))
XJN=DBLE(Y(J))
IF(XIN.EQ.XJN)GOTO1100
PIN=DBLE(P(I))
PJN=DBLE(P(J))
CCCCC IF(PJN.EQ.PJNSV)GOTO1100
CCCCC PJNSV=PJN
DELTA0=(XIN/XJN) - (DLOG(1.0D0-PIN)/DLOG(1.0D0-PJN))
IF(DELTA0.GT.0.0D0)THEN
XLOWER=EPS2
XUPPER=DLOG(1.0D0-XIN/XNN)/DLOG(1.0D0-PIN)
ELSE
XLOWER=DLOG(XIN/XNN)/DLOG((1.0D0-PIN)/(1.0D0-PNN))
XUPPER=-EPS2
ENDIF
ICNT=0
FXLOW=XIN*(1.0D0 - (1.0D0 - PJN)**XLOWER) -
1 XJN*(1.0D0 - (1.0D0 - PIN)**XLOWER)
FXUPP=XIN*(1.0D0 - (1.0D0 - PJN)**XUPPER) -
1 XJN*(1.0D0 - (1.0D0 - PIN)**XUPPER)
C
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'EPM2')THEN
WRITE(ICOUT,1003)
1003 FORMAT('DPEPM2: GENERALIZED PARETO')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1005)I,J,XIN,XJN,XNN
1005 FORMAT('I,J,XIN,XJN,XNN = ',2I8,3G15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1007)PIN,PJN,PNN
1007 FORMAT('PIN,PJN,PNN = ',3G15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1009)FXLOW,FXUPP
1009 FORMAT('FXLOW,FXUPP = ',2G15.7)
CALL DPWRST('XXX','BUG ')
ENDIF
C
1110 CONTINUE
XMID=(XLOWER+XUPPER)*0.5D0
FCS=XIN*(1.0D0 - (1.0D0 - PJN)**XMID) -
1 XJN*(1.0D0 - (1.0D0 - PIN)**XMID)
IF(FCS*FXLOW.GT.0.0D0)THEN
XLOWER=XMID
FXLOW=FCS
ELSE
XUPPER=XMID
FXUPP=FCS
ENDIF
XRML=XUPPER - XLOWER
IF(XRML.LE.SIG .OR. ABS(FCS).LE.EPS)THEN
NCNT=NCNT+1
GAMMSV(NCNT)=REAL(XMID)
CCCCC SCALSV(NCNT)=REAL(XMID*XJN/(1.0D0 - (1.0D0 - PJN)**XMID))
SCALSV(NCNT)=REAL(XJN/(1.0D0 - (1.0D0 - PJN)**XMID))
GOTO1100
ELSE
ICNT = ICNT + 1
IF(ICNT.LE.MAXIT)GOTO1110
CCCCC WRITE(ICOUT,1130)J
C1130 FORMAT('***** ITERATION ',I8,' OF GENERALIZED PARERO')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,1133)
C1133 FORMAT(' ELEMENTAL PERCENTILE ESTIMATION DID NOT ',
CCCCC1 'DID NOT CONVERGE.')
CCCCC CALL DPWRST('XXX','BUG ')
GOTO1100
ENDIF
C
1100 CONTINUE
C
CALL MEDIAN(GAMMSV,NCNT,IWRITE,TEMP1,MAXNXT,SHAPE,IBUGA3,IERROR)
CALL MEDIAN(SCALSV,NCNT,IWRITE,TEMP1,MAXNXT,XMED,IBUGA3,IERROR)
SCALE=SHAPE*XMED
IF(IGEPDF.EQ.'SIMI')SHAPE=-SHAPE
GOTO9000
C
1500 CONTINUE
C
XNN=DBLE(Y(N))
PNN=DBLE(P(N))
PJNSV=DBLE(P(1))
NCNT=0
EPS2=1.0D-12
DO1600I=1,N-1
DO1610J=I+1,N
C
XIN=DBLE(Y(I))
XJN=DBLE(Y(J))
IF(XIN.EQ.XJN)GOTO1610
PIN=DBLE(P(I))
PJN=DBLE(P(J))
IF(PJN.EQ.PJNSV)GOTO1610
PJNSV=PJN
DELTA0=(XIN/XJN) - (DLOG(1.0D0-PIN)/DLOG(1.0D0-PJN))
IF(DELTA0.GT.0.0D0)THEN
XLOWER=EPS2
XUPPER=DLOG(1.0D0-XIN/XNN)/DLOG(1.0D0-PIN)
ELSE
XLOWER=DLOG(XIN/XNN)/DLOG((1.0D0-PIN)/(1.0D0-PNN))
XUPPER=-EPS2
ENDIF
ICNT=0
FXLOW=XIN*(1.0D0 - (1.0D0 - PJN)**XLOWER) -
1 XJN*(1.0D0 - (1.0D0 - PIN)**XLOWER)
FXUPP=XIN*(1.0D0 - (1.0D0 - PJN)**XUPPER) -
1 XJN*(1.0D0 - (1.0D0 - PIN)**XUPPER)
C
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'EPM2')THEN
WRITE(ICOUT,1503)
1503 FORMAT('DPEPM2: GENERALIZED PARETO')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1505)I,J,XIN,XJN,XNN
1505 FORMAT('I,J,XIN,XJN,XNN = ',2I8,3G15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1507)PIN,PJN,PNN
1507 FORMAT('PIN,PJN,PNN = ',3G15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1509)FXLOW,FXUPP
1509 FORMAT('FXLOW,FXUPP = ',2G15.7)
CALL DPWRST('XXX','BUG ')
ENDIF
C
1630 CONTINUE
XMID=(XLOWER+XUPPER)*0.5D0
FCS=XIN*(1.0D0 - (1.0D0 - PJN)**XMID) -
1 XJN*(1.0D0 - (1.0D0 - PIN)**XMID)
IF(FCS*FXLOW.GT.0.0D0)THEN
XLOWER=XMID
FXLOW=FCS
ELSE
XUPPER=XMID
FXUPP=FCS
ENDIF
XRML=XUPPER - XLOWER
IF(XRML.LE.SIG .OR. ABS(FCS).LE.EPS)THEN
NCNT=NCNT+1
GAMMSV(NCNT)=REAL(XMID)
SCALSV(NCNT)=REAL(XJN/(1.0D0 - (1.0D0 - PJN)**XMID))
GOTO1630
ELSE
ICNT = ICNT + 1
IF(ICNT.LE.MAXIT)GOTO1630
CCCCC WRITE(ICOUT,1640)J
C1640 FORMAT('***** ITERATION ',I8,' OF GENERALIZED PARERO')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,1643)
C1643 FORMAT(' ELEMENTAL PERCENTILE ESTIMATION DID NOT ',
CCCCC1 'DID NOT CONVERGE.')
CCCCC CALL DPWRST('XXX','BUG ')
GOTO1610
ENDIF
C
1610 CONTINUE
1600 CONTINUE
C
CALL MEDIAN(GAMMSV,NCNT,IWRITE,TEMP1,MAXNXT,SHAPE,IBUGA3,IERROR)
CALL MEDIAN(SCALSV,NCNT,IWRITE,TEMP1,MAXNXT,XMED,IBUGA3,IERROR)
SCALE=SHAPE*XMED
IF(IGEPDF.EQ.'SIMI')SHAPE=-SHAPE
GOTO9000
C
C GENERAL ALGORITHM FOR GENERALIZED EXTREME VALUE GIVEN ON
C PAGES 220-223 CASTILLO, ET.AL.
C
2000 CONTINUE
C
XNN=DBLE(Y(N))
PNN=DBLE(P(N))
NCNT=0
EPS2=1.0D-12
DO2100II=1,NSAMP
C
NTEMP=3
CCCCC CALL DUNRAN(NTEMP,N,ISEED,XRAN)
CALL DUNRA2(NTEMP,N,ISEED,XRAN)
CALL SORT(XRAN,NTEMP,XRAN)
I=XRAN(1)
J=XRAN(2)
R=XRAN(3)
C
XIN=DBLE(Y(I))
XJN=DBLE(Y(J))
XRN=DBLE(Y(R))
XNN=DBLE(Y(N))
IF(XIN.EQ.XJN)GOTO2100
IF(XJN.EQ.XRN)GOTO2100
PIN=DBLE(P(I))
PJN=DBLE(P(J))
PRN=DBLE(P(R))
PNN=DBLE(P(N))
AIR=DLOG(PIN)/DLOG(PRN)
AJR=DLOG(PJN)/DLOG(PRN)
AIJ=DLOG(PIN)/DLOG(PJN)
AJI=DLOG(PJN)/DLOG(PIN)
DIJR=(XJN-XRN)/(XIN-XRN)
IF(DIJR.LT.DLOG(AJR)/DLOG(AIR))THEN
XLOWER=EPS2
XUPPER=DLOG(DIJR)/DLOG(AJI)
ELSE
XLOWER=DLOG(1.0D0-DIJR)/DLOG(AJR)
XUPPER=-EPS2
ENDIF
ICNT=0
FXLOW=(1.0D0 - AJR**XLOWER)/(1.0D0 - AIR**XLOWER) - DIJR
FXUPP=(1.0D0 - AJR**XUPPER)/(1.0D0 - AIR**XUPPER) - DIJR
C
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'EPM2')THEN
WRITE(ICOUT,2003)
2003 FORMAT('DPEPM2: GENERALIZED EXTREME VALUE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2005)I,J,XIN,XJN,XRN
2005 FORMAT('I,J,XIN,XJN,XRN = ',2I8,3G15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2007)PIN,PJN,PRN
2007 FORMAT('PIN,PJN,PRN = ',3G15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2006)AIR,AJR,AIJ,AJI
2006 FORMAT('AIR,AJR,AIJ,AJI = ',4G15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2009)DIJR,FXLOW,FXUPP
2009 FORMAT('DIJR,FXLOW,FXUPP = ',3G15.7)
CALL DPWRST('XXX','BUG ')
ENDIF
C
2110 CONTINUE
XMID=(XLOWER+XUPPER)*0.5D0
FCS=(1.0D0 - AJR**XMID)/(1.0D0 - AIR**XMID) - DIJR
IF(FCS*FXLOW.GT.0.0D0)THEN
XLOWER=XMID
FXLOW=FCS
ELSE
XUPPER=XMID
FXUPP=FCS
ENDIF
XRML=XUPPER - XLOWER
IF(XRML.LE.SIG .OR. ABS(FCS).LE.EPS)THEN
NCNT=NCNT+1
GAMMSV(NCNT)=REAL(XMID)
CR=-DLOG(PRN)
CI=-DLOG(PIN)
DSCALE=XMID*(XIN-XRN)/(CR**XMID - CI**XMID)
SCALSV(NCNT)=REAL(XMID*(XIN-XRN)/(CR**XMID - CI**XMID))
DLOC=XIN - DSCALE*DLOG(CI)
ALOCSV(NCNT)=REAL(DLOC)
GOTO2100
ELSE
ICNT = ICNT + 1
IF(ICNT.LE.MAXIT)GOTO2110
CCCCC WRITE(ICOUT,2130)J
C2130 FORMAT('***** ITERATION ',I8,' OF GENERALIZED EXTREME ',
CCCCC1 'VALUE')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,2133)
C2133 FORMAT(' ELEMENTAL PERCENTILE ESTIMATION DID NOT ',
CCCCC1 'CONVERGE.')
CCCCC CALL DPWRST('XXX','BUG ')
GOTO2100
ENDIF
C
2100 CONTINUE
C
CALL MEDIAN(GAMMSV,NCNT,IWRITE,TEMP1,MAXNXT,SHAPE,IBUGA3,IERROR)
CALL MEDIAN(SCALSV,NCNT,IWRITE,TEMP1,MAXNXT,SCALE,IBUGA3,IERROR)
CALL MEDIAN(ALOCSV,NCNT,IWRITE,TEMP1,MAXNXT,ALOC,IBUGA3,IERROR)
GOTO9000
C
9000 CONTINUE
C
RETURN
END
SUBROUTINE DPERAS(IHARG,IARGT,IARG,NUMARG,
1IBACCO,
1IGRASW,IDIASW,
1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
1NUMDEV,
1IDMANU,IDMODE,IDMOD2,IDMOD3,
1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
1IDFONT,
1ICAPSW,
1IBUGD2,ISUBRO,IFOUND,IERROR)
C
C PURPOSE--CARRY OUT AN IMMEDIATE ERASE OF THE SCREEN
C FOR DISPLAY TERMINALS
C (OR SKIP TO A NEW PAGE FOR PAPER-OUTPUT TERMINALS
C AND THE BATCH HIGH-SPEED PRINTER)
C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR)
C --IARGT (A CHARACTER VECTOR)
C --IARG (AN INTEGER VECTOR)
C --NUMARG
C OUTPUT ARGUMENTS--IFOUND ('YES' OR 'NO')
C --IERROR ('YES' OR 'NO' )
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-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 --APRIL 1982.
C UPDATED --MAY 1982.
C UPDATED --MAY 1989. IDNVOF/HOF ADDED TO INPUT ARGS (ALAN)
C TO FIX POSTSCRIPT SCALING PROBLEM
C UPDATED --MARCH 1990. PATCH FOR X11 (CHECK PICTURE POINTS)
C UPDATED --MAY 1992. AUTO CLOSE/OPEN OF DEVICE 3 (JJF)
C UPDATED --MAY 1992. DEBUG STATEMENTS
C UPDATED --MAY 1992. IBUGXX, ISUBXX, IERRXX
C UPDATED --NOVEMBER 1996. QWIN, BUG FIX
C UPDATED --MARCH 1997. SUPPORT FOR DEVICE FONT (ALAN)
C UPDATED --SEPTEMBER 2002. ICAPSW
C
C-----NON-COMMON VARIABLES----------------------------------------
C
CHARACTER*4 IHARG
CHARACTER*4 IARGT
C
CHARACTER*4 IBACCO
C
CHARACTER*4 ICAPSW
C
CHARACTER*4 IGRASW
CHARACTER*4 IDIASW
C
CHARACTER*4 IDMANU
CHARACTER*4 IDMODE
CHARACTER*4 IDMOD2
CHARACTER*4 IDMOD3
C
CHARACTER*4 IDPOWE
CHARACTER*4 IDCONT
CHARACTER*4 IDCOLO
CCCCC ADD FOLLOWING LINE MARCH 1997.
CHARACTER*4 IDFONT
C
CHARACTER*4 IFOUND
CHARACTER*4 IBUGD2
CHARACTER*4 ISUBRO
CHARACTER*4 IERROR
C
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
CHARACTER*4 ICOPSJ
C
CCCCC THE FOLLOWING 3 LINES WERE ADDED MAY 1992 (JJF)
CHARACTER*4 IBUGXX
CHARACTER*4 ISUBXX
CHARACTER*4 IERRXX
C
C---------------------------------------------------------------------
C
DIMENSION IHARG(*)
DIMENSION IARGT(*)
DIMENSION IARG(*)
C
DIMENSION IDMANU(*)
DIMENSION IDMODE(*)
DIMENSION IDMOD2(*)
DIMENSION IDMOD3(*)
C
DIMENSION IDPOWE(*)
DIMENSION IDCONT(*)
DIMENSION IDCOLO(*)
CCCCC ADD FOLLOWING LINE MARCH 1997.
DIMENSION IDFONT(*)
DIMENSION IDNVPP(*)
DIMENSION IDNHPP(*)
DIMENSION IDUNIT(*)
C
CCCCC THE FOLLOWING 2 LINES WERE ADDED MAY 1989
CCCCC TO FIX POSTSCRIPT TRANSLATION PROBLEM (ALAN) MAY 1989
DIMENSION IDNVOF(*)
DIMENSION IDNHOF(*)
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCOGR.INC'
INCLUDE 'DPCOBE.INC'
CCCCC THE FOLLOWING LINE WAS ADDED MAY 1992 (JJF)
INCLUDE 'DPCOF2.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
ISUBN1='DPER'
ISUBN2='SC '
C
IFOUND='NO'
IERROR='NO'
C
IBUGG4=IBUGD2
ISUBG4=ISUBRO
IERRG4=IERROR
C
IF(IBUGD2.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('AT THE BEGINNING OF DPERAS--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)IBUGD2,IBUGG4
53 FORMAT('IBUGD2,IBUGG4 = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)IFOUND,IERROR
54 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 2 LINES WERE ADDED MAY 1992
WRITE(ICOUT,55)IPL2CS
55 FORMAT('IPL2CS = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,60)NUMARG
60 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
DO61I=1,NUMARG
WRITE(ICOUT,62)I,IHARG(I),IARGT(I),IARG(I)
62 FORMAT('I,IHARG(I),IARGT(I),IARG(I) = ',
1I8,2X,A4,2X,A4,2X,I8)
CALL DPWRST('XXX','BUG ')
61 CONTINUE
WRITE(ICOUT,70)NUMDEV
70 FORMAT('NUMDEV = ',I8)
CALL DPWRST('XXX','BUG ')
DO71I=1,NUMDEV
WRITE(ICOUT,72)I,IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I)
72 FORMAT('I,IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ',
1I8,2X,A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,73)I,IDPOWE(I),IDCONT(I),IDCOLO(I)
73 FORMAT('I,IDPOWE(I),IDCONT(I),IDCOLO(I) = ',
1I8,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,74)I,IDNVPP(I),IDNHPP(I),IDUNIT(I)
74 FORMAT('I,IDNVPP(I),IDNHPP(I),IDUNIT(I) = ',
1I8,2X,I8,2X,I8,2X,I8)
CALL DPWRST('XXX','BUG ')
71 CONTINUE
WRITE(ICOUT,82)IMANUF,IMODEL,IMODE2,IMODE3
82 FORMAT('IMANUF,IMODEL,IMODE2,IMODE3 = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,83)IGCONT,IGCOLO
83 FORMAT('IGCONT,IGCOLO = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,84)NUMVPP,NUMHPP,ANUMVP,ANUMHP
84 FORMAT('NUMVPP,NUMHPP,ANUMVP,ANUMHP = ',2I8,2E15.7)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C ********************************************************
C ** STEP 1-- **
C ** EXTRACT NEEDED INFORMATION FROM THE COMMAND LINE **
C ********************************************************
C
IF(NUMARG.LE.0)GOTO1120
IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DELA')GOTO9000
GOTO1120
C
1120 CONTINUE
IFOUND='YES'
C
CCCCC THE FOLLOWING 7 LINES WERE ADDED MAY 1992 (JJF)
CCCCC TO AUTOMATICALLY CLOSE/OPEN DEVICE 3 MAY 1992
CCCCC WHENEVER AN INITIALIZATION/ERASE IS DONE MAY 1992
CCCCC (SEE ALSO DPERAS AND MAINOD) MAY 1992
C
IBUGXX=IBUGG4
ISUBXX=ISUBG4
IERRXX=IERRG4
IF(IPL2CS.EQ.'OPEN')
1CALL DPDEV(3,'CLOS','POST',ICAPSW,IBUGXX,ISUBXX,IERRXX)
IF(IPL2CS.EQ.'CLOSED')
1CALL DPDEV(3,'OPEN','POST',ICAPSW,IBUGXX,ISUBXX,IERRXX)
C
C ********************************
C ** STEP 2-- **
C ** STEP THROUGH EACH DEVICE **
C ********************************
C
IF(NUMDEV.LE.0)GOTO9000
DO8000IDEVIC=1,NUMDEV
C
IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000
C
IMANUF=IDMANU(IDEVIC)
IMODEL=IDMODE(IDEVIC)
IMODE2=IDMOD2(IDEVIC)
IMODE3=IDMOD3(IDEVIC)
IGCONT=IDCONT(IDEVIC)
IGCOLO=IDCOLO(IDEVIC)
CCCCC ADD FOLLOWING LINE MARCH 1997.
IGFONT=IDFONT(IDEVIC)
NUMVPP=IDNVPP(IDEVIC)
NUMHPP=IDNHPP(IDEVIC)
ANUMVP=NUMVPP
ANUMHP=NUMHPP
IGUNIT=IDUNIT(IDEVIC)
C
C ******************************************************
C ** STEP 2.1-- **
C ** TREAT THE ERASE CASE FOR PRINTERS **
C ** AND DISCRETE TERMINALS **
C ** (SKIP TO NEXT PAGE) ZZ
C ******************************************************
C
ISTEPN='2.1'
IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IGCONT.EQ.'ON')GOTO1190
WRITE(ICOUT,998)
998 FORMAT(1H1)
CALL DPWRST('XXX','BUG ')
GOTO8000
1190 CONTINUE
C
C ****************************************
C ** STEP 2.2-- **
C ** TREAT THE ERASE CASE **
C ** FOR CONTINUOUS TERMINALS. **
C ****************************************
C
ISTEPN='2.2'
IF(IBUGD2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IBUGD2.EQ.'ON')WRITE(ICOUT,1205)
1205 FORMAT('*** FROM DPERAS--AN ERASE SHOULD TAKE PLACE NOW ***')
IF(IBUGD2.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
CALL DPERSC(IBACCO)
CCCCC FOLLOWING LINES ADDED FOR X11 (PICTURE POINTS MAY BE DYNAMICALLY
CCCCC CHANGED BY ERASE SCREEN ROUTINE, MAKE SURE HAVE UP-TO-DATE VALUES).
CCCCC FIX BUG IN FOLLOWING NOVEMBER 1996.
IF(IMANUF.EQ.'X11')THEN
NUMVPP=ANUMVP+0.5
NUMHPP=ANUMHP+0.5
CCCCC IDNVPP(I)=NUMVPP
CCCCC IDNHPP(I)=NUMHPP
IDNVPP(IDEVIC)=NUMVPP
IDNHPP(IDEVIC)=NUMHPP
ENDIF
CCCCC END CHANGE
CCCCC FOLLOWING LINES ADDED FOR QWIN (PICTURE POINTS MAY BE DYNAMICALLY
CCCCC CHANGED BY ERASE SCREEN ROUTINE, MAKE SURE HAVE UP-TO-DATE
CCCCC VALUES). NOVEMBER 1996.
IF(IMANUF.EQ.'QWIN')THEN
NUMVPP=ANUMVP+0.5
NUMHPP=ANUMHP+0.5
IDNVPP(IDEVIC)=NUMVPP
IDNHPP(IDEVIC)=NUMHPP
ENDIF
C
IF(IBUGD2.EQ.'ON')WRITE(ICOUT,1206)
1206 FORMAT('*** AN ERASE SHOULD HAVE JUST TAKEN PLACE ***')
IF(IBUGD2.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
C ************************************
C ** STEP 2.2B-- **
C ** CARRY OUT CLOSING OPERATIONS **
C ** ON THE GRAPHICS DEVICES **
C ************************************
C
ICOPSJ='OFF'
NUMCOJ=0
CALL DPCLPL(ICOPSJ,NUMCOJ,
1PGRAXF,PGRAYF,
1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
1PDIAHE,PDIAWI,PDIAVG,PDIAHG)
C
CALL DPCLDE
C
GOTO8000
C
8000 CONTINUE
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGD2.EQ.'OFF')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('AT THE END OF DPERAS--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)IBUGD2,IBUGG4
9013 FORMAT('IBUGD2,IBUGG4 = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)IFOUND,IERROR
9014 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 2 LINES WERE ADDED MAY 1992
WRITE(ICOUT,9015)IPL2CS
9015 FORMAT('IPL2CS = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9020)NUMARG
9020 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
DO9021I=1,NUMARG
WRITE(ICOUT,9022)I,IHARG(I),IARGT(I),IARG(I)
9022 FORMAT('I,IHARG(I),IARGT(I),IARG(I) = ',
1I8,2X,A4,2X,A4,2X,I8)
CALL DPWRST('XXX','BUG ')
9021 CONTINUE
WRITE(ICOUT,9030)NUMDEV
9030 FORMAT('NUMDEV = ',I8)
CALL DPWRST('XXX','BUG ')
DO9031I=1,NUMDEV
WRITE(ICOUT,9032)I,IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I)
9032 FORMAT('I,IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ',
1I8,2X,A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9033)I,IDPOWE(I),IDCONT(I),IDCOLO(I)
9033 FORMAT('I,IDPOWE(I),IDCONT(I),IDCOLO(I) = ',
1I8,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9034)I,IDNVPP(I),IDNHPP(I),IDUNIT(I)
9034 FORMAT('I,IDNVPP(I),IDNHPP(I),IDUNIT(I) = ',
1I8,2X,I8,2X,I8,2X,I8)
CALL DPWRST('XXX','BUG ')
9031 CONTINUE
WRITE(ICOUT,9042)IMANUF,IMODEL,IMODE2,IMODE3
9042 FORMAT('IMANUF,IMODEL,IMODE2,IMODE3 = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9043)IGCONT,IGCOLO
9043 FORMAT('IGCONT,IGCOLO = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9044)NUMVPP,NUMHPP,ANUMVP,ANUMHP
9044 FORMAT('NUMVPP,NUMHPP,ANUMVP,ANUMHP = ',2I8,2E15.7)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPERBA(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ICONT,
1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
C
C PURPOSE--GENERATE AN ERROR BAR 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-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/11
C ORIGINAL VERSION--OCTOBER 1988.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 ICASPL
CHARACTER*4 IAND1
CHARACTER*4 IAND2
CHARACTER*4 ICONT
CHARACTER*4 IBUGG2
CHARACTER*4 IBUGG3
CHARACTER*4 IBUGQ
CHARACTER*4 ISUBRO
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 IHWUSE
CHARACTER*4 MESSAG
CHARACTER*4 ICASEQ
CHARACTER*4 IH1
CHARACTER*4 IH2
CCCCC CHARACTER*4 IERRO2
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
INCLUDE 'DPCOPA.INC'
C
DIMENSION Z1(MAXOBV)
DIMENSION Z2(MAXOBV)
DIMENSION Z3(MAXOBV)
DIMENSION Z4(MAXOBV)
DIMENSION Z5(MAXOBV)
DIMENSION Z6(MAXOBV)
CCCCC FOLLOWING LINES ADDED FEBRUARY, 1994
INCLUDE 'DPCOZ2.INC'
EQUIVALENCE (G2RBAG(IGAR11),Z1(1))
EQUIVALENCE (G2RBAG(IGAR12),Z2(1))
EQUIVALENCE (G2RBAG(IGAR13),Z3(1))
EQUIVALENCE (G2RBAG(IGAR14),Z4(1))
EQUIVALENCE (G2RBAG(IGAR15),Z5(1))
EQUIVALENCE (G2RBAG(IGAR16),Z6(1))
CCCCC END CHANGE
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCOHK.INC'
INCLUDE 'DPCODA.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
IERROR='NO'
C
ISUBN1='DPER'
ISUBN2='BA '
C
MAXCP1=MAXCOL+1
MAXCP2=MAXCOL+2
MAXCP3=MAXCOL+3
MAXCP4=MAXCOL+4
MAXCP5=MAXCOL+5
MAXCP6=MAXCOL+6
C
C *************************************
C ** TREAT THE ERROR BAR PLOT CASE **
C *************************************
C
IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'ERBA')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPERBA--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBUGG2,IBUGG3,IBUGQ,ISUBRO
52 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)ICASPL,IAND1,IAND2,ICONT
53 FORMAT('ICASPL,IAND1,IAND2,ICONT = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C ***************************
C ** STEP 11-- **
C ** EXTRACT THE COMMAND **
C ***************************
C
ISTEPN='11'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ERBA')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ICASPL='ERBA'
C
IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')GOTO1110
IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BAR'.AND.
1IHARG(2).EQ.'PLOT')GOTO1120
GOTO1180
C
1110 CONTINUE
ILASTC=1
CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
GOTO1180
C
1120 CONTINUE
ILASTC=2
CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
GOTO1180
C
1180 CONTINUE
IFOUND='YES'
GOTO1190
C
1190 CONTINUE
C
C ***********************************************************
C ** STEP 12-- **
C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. **
C ***********************************************************
C
ISTEPN='12'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ERBA')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
MINNA=1
MAXNA=100
CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
C
C *****************************************
C ** STEP 13-- **
C ** CHECK TO SEE THE TYPE SUBCASE **
C ** (BASED ON THE QUALIFIER)-- **
C ** 1) UNQUALIFIED (THAT IS, FULL); **
C ** 2) SUBSET/EXCEPT; OR **
C ** 3) FOR. **
C *****************************************
C
ISTEPN='13'
IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ICASEQ='FULL'
ILOCQ=NUMARG+1
IF(NUMARG.LT.1)GOTO1380
DO1300J=1,NUMARG
J1=J
IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO1310
IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO1310
IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO1320
1300 CONTINUE
GOTO1390
1310 CONTINUE
ICASEQ='SUBS'
ILOCQ=J1
GOTO1390
1320 CONTINUE
ICASEQ='FOR'
ILOCQ=J1
GOTO1390
C
1380 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1381)
1381 FORMAT('***** INTERNAL ERROR IN DPERBA')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1382)
1382 FORMAT(' AT BRANCH POINT 1381--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1383)
1383 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1384)
1384 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1385)NUMARG
1385 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1386)
1386 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,1387)(IANS(I),I=1,IWIDTH)
1387 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
1390 CONTINUE
IF(IBUGG2.EQ.'OFF')GOTO1395
WRITE(ICOUT,1391)NUMARG,ILOCQ,ICASEQ
1391 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4)
CALL DPWRST('XXX','BUG ')
1395 CONTINUE
C
C **************************************************
C ** STEP 14-- **
C ** DETERMINE THE NUMBER OF VARIABLES **
C ** TO BE INCLUDED AS PLOT COMPONENTS **
C **************************************************
C
ISTEPN='14'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ERBA')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
NUMV2=ILOCQ-1
IF(NUMV2.GE.2.AND.NUMV2.LE.6)GOTO1490
C
WRITE(ICOUT,1411)
1411 FORMAT('***** ERROR IN DPERBA--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1412)
1412 FORMAT(' ILLEGAL SYNTAX--THE NUMBER OF VARIABLES ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1413)
1413 FORMAT(' TO BE INCLUDED AS ARGUMENTS ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1414)
1414 FORMAT(' IN AN ERROR BAR PLOT COMMAND')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1415)
1415 FORMAT(' MUST BE AT LEAST 2 AND AT MOST 6;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1416)NUMV2
1416 FORMAT(' SUCH WAS NOT THE CASE HERE. NUMV2 = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1417)
1417 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,1418)(IANS(I),I=1,IWIDTH)
1418 FORMAT(80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
1490 CONTINUE
C
C ***************************************
C ** STEP 15-- **
C ** CHECK THE VALIDITY OF EACH **
C ** OF THE VARIABLES. **
C ***************************************
C
ISTEPN='15'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ERBA')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
DO1500I=1,NUMV2
IH1=IHARG(I)
IH2=IHARG2(I)
IHWUSE='V'
MESSAG='YES'
CALL CHECKN(IH1,IH2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
IF(I.EQ.1)ICOL1=IVALUE(ILOCV)
IF(I.EQ.2)ICOL2=IVALUE(ILOCV)
IF(I.EQ.3)ICOL3=IVALUE(ILOCV)
IF(I.EQ.4)ICOL4=IVALUE(ILOCV)
IF(I.EQ.5)ICOL5=IVALUE(ILOCV)
IF(I.EQ.6)ICOL6=IVALUE(ILOCV)
IF(I.EQ.1)N1=IN(ILOCV)
IF(I.EQ.2)N2=IN(ILOCV)
IF(I.EQ.3)N3=IN(ILOCV)
IF(I.EQ.4)N4=IN(ILOCV)
IF(I.EQ.5)N5=IN(ILOCV)
IF(I.EQ.6)N6=IN(ILOCV)
1500 CONTINUE
C
C **************************************************
C ** STEP 16-- **
C ** CHECK THAT ALL ARGUMENTS **
C ** HAVE THE SAME NUMBER OF OBSERVATIONS. **
C **************************************************
C
ISTEPN='16'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ERBA')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(N2.NE.N1)GOTO1610
IF(NUMV2.LE.2)GOTO1690
IF(N3.NE.N1)GOTO1610
IF(NUMV2.LE.3)GOTO1690
IF(N4.NE.N1)GOTO1610
IF(NUMV2.LE.4)GOTO1690
IF(N5.NE.N1)GOTO1610
IF(NUMV2.LE.5)GOTO1690
IF(N6.NE.N1)GOTO1610
GOTO1690
C
1610 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1611)
1611 FORMAT('***** ERROR IN DPERBA--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1612)
1612 FORMAT(' FOR AN ERROR BAR PLOT,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1613)
1613 FORMAT(' ALL VARIABLES MUST HAVE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1614)
1614 FORMAT(' THE SAME NUMBER OF ELEMENTS;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1615)
1615 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1621)N1
1621 FORMAT('THE FIRST VARIABLE HAD ',I8,' ELEMENTS;')
CALL DPWRST('XXX','BUG ')
IF(NUMV2.LE.1)GOTO1690
WRITE(ICOUT,1622)N2
1622 FORMAT('THE SECOND VARIABLE HAD ',I8,' ELEMENTS;')
CALL DPWRST('XXX','BUG ')
IF(NUMV2.LE.2)GOTO1690
WRITE(ICOUT,1623)N3
1623 FORMAT('THE THIRD VARIABLE HAD ',I8,' ELEMENTS;')
CALL DPWRST('XXX','BUG ')
IF(NUMV2.LE.3)GOTO1690
WRITE(ICOUT,1624)N4
1624 FORMAT('THE FOURTH VARIABLE HAD ',I8,' ELEMENTS;')
CALL DPWRST('XXX','BUG ')
IF(NUMV2.LE.4)GOTO1690
WRITE(ICOUT,1625)N5
1625 FORMAT('THE FIFTH VARIABLE HAD ',I8,' ELEMENTS;')
CALL DPWRST('XXX','BUG ')
IF(NUMV2.LE.5)GOTO1690
WRITE(ICOUT,1626)N6
1626 FORMAT('THE SIXTH VARIABLE HAD ',I8,' ELEMENTS;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1627)
1627 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,1628)(IANS(I),I=1,IWIDTH)
1628 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
1690 CONTINUE
C
C *************************************************
C ** STEP 21-- **
C ** BRANCH TO THE APPROPRIATE SUBCASE; **
C ** (BASED ON THE QUALIFIER) **
C ** THEN FOR EACH OF THE RESPONSE VARIABLES **
C ** EXTRACT THE DATA SUBSET **
C ** (USUALLY ONLY 1 OBSERVATION) **
C ** AND ALSO EXTRACT THE **
C ** MIN AND MAX FOR THE FULL VARIABLE **
C *************************************************
C
ISTEPN='21'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ERBA')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(ICASEQ.EQ.'FULL')GOTO2110
IF(ICASEQ.EQ.'SUBS')GOTO2120
IF(ICASEQ.EQ.'FOR')GOTO2130
C
2110 CONTINUE
DO2115I=1,N1
ISUB(I)=1
2115 CONTINUE
NQ=N1
GOTO2150
C
2120 CONTINUE
NIOLD=N1
CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
NQ=NIOLD
GOTO2150
C
2130 CONTINUE
NIOLD=N1
CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
NQ=NFOR
GOTO2150
C
2150 CONTINUE
J=0
IMAX=N1
IF(NQ.LT.N1)IMAX=NQ
DO2160I=1,IMAX
IF(ISUB(I).EQ.0)GOTO2160
J=J+1
C
IJ=MAXN*(ICOL1-1)+I
IF(ICOL1.LE.MAXCOL)Z1(J)=V(IJ)
IF(ICOL1.EQ.MAXCP1)Z1(J)=PRED(I)
IF(ICOL1.EQ.MAXCP2)Z1(J)=RES(I)
IF(ICOL1.EQ.MAXCP3)Z1(J)=YPLOT(I)
IF(ICOL1.EQ.MAXCP4)Z1(J)=XPLOT(I)
IF(ICOL1.EQ.MAXCP5)Z1(J)=X2PLOT(I)
IF(ICOL1.EQ.MAXCP6)Z1(J)=TAGPLO(I)
C
IF(NUMV2.LE.1)GOTO2160
IJ=MAXN*(ICOL2-1)+I
IF(ICOL2.LE.MAXCOL)Z2(J)=V(IJ)
IF(ICOL2.EQ.MAXCP1)Z2(J)=PRED(I)
IF(ICOL2.EQ.MAXCP2)Z2(J)=RES(I)
IF(ICOL2.EQ.MAXCP3)Z2(J)=YPLOT(I)
IF(ICOL2.EQ.MAXCP4)Z2(J)=XPLOT(I)
IF(ICOL2.EQ.MAXCP5)Z2(J)=X2PLOT(I)
IF(ICOL2.EQ.MAXCP6)Z2(J)=TAGPLO(I)
C
IF(NUMV2.LE.2)GOTO2160
IJ=MAXN*(ICOL3-1)+I
IF(ICOL3.LE.MAXCOL)Z3(J)=V(IJ)
IF(ICOL3.EQ.MAXCP1)Z3(J)=PRED(I)
IF(ICOL3.EQ.MAXCP3)Z3(J)=RES(I)
IF(ICOL3.EQ.MAXCP3)Z3(J)=YPLOT(I)
IF(ICOL3.EQ.MAXCP4)Z3(J)=XPLOT(I)
IF(ICOL3.EQ.MAXCP5)Z3(J)=X2PLOT(I)
IF(ICOL3.EQ.MAXCP6)Z3(J)=TAGPLO(I)
C
IF(NUMV2.LE.3)GOTO2160
IJ=MAXN*(ICOL4-1)+I
IF(ICOL4.LE.MAXCOL)Z4(J)=V(IJ)
IF(ICOL4.EQ.MAXCP1)Z4(J)=PRED(I)
IF(ICOL4.EQ.MAXCP4)Z4(J)=RES(I)
IF(ICOL4.EQ.MAXCP3)Z4(J)=YPLOT(I)
IF(ICOL4.EQ.MAXCP4)Z4(J)=XPLOT(I)
IF(ICOL4.EQ.MAXCP5)Z4(J)=X2PLOT(I)
IF(ICOL4.EQ.MAXCP6)Z4(J)=TAGPLO(I)
C
IF(NUMV2.LE.4)GOTO2160
IJ=MAXN*(ICOL5-1)+I
IF(ICOL5.LE.MAXCOL)Z5(J)=V(IJ)
IF(ICOL5.EQ.MAXCP1)Z5(J)=PRED(I)
IF(ICOL5.EQ.MAXCP5)Z5(J)=RES(I)
IF(ICOL5.EQ.MAXCP3)Z5(J)=YPLOT(I)
IF(ICOL5.EQ.MAXCP4)Z5(J)=XPLOT(I)
IF(ICOL5.EQ.MAXCP5)Z5(J)=X2PLOT(I)
IF(ICOL5.EQ.MAXCP6)Z5(J)=TAGPLO(I)
C
IF(NUMV2.LE.5)GOTO2160
IJ=MAXN*(ICOL6-1)+I
IF(ICOL6.LE.MAXCOL)Z6(J)=V(IJ)
IF(ICOL6.EQ.MAXCP1)Z6(J)=PRED(I)
IF(ICOL6.EQ.MAXCP6)Z6(J)=RES(I)
IF(ICOL6.EQ.MAXCP3)Z6(J)=YPLOT(I)
IF(ICOL6.EQ.MAXCP4)Z6(J)=XPLOT(I)
IF(ICOL6.EQ.MAXCP5)Z6(J)=X2PLOT(I)
IF(ICOL6.EQ.MAXCP6)Z6(J)=TAGPLO(I)
C
2160 CONTINUE
NLOCAL=J
C
C *************************************************************
C ** STEP 31-- **
C ** FORM THE VERTICAL AND HORIZONTAL AXIS **
C ** VALUES Y(.) AND X(.) FOR THE PLOT. **
C ** DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S **
C ** FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE LINE, **
C ** AND THE UPPER CONFIDENCE LINE. **
C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). **
C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). **
C *************************************************************
C
ISTEPN='8'
IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ERBA')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CALL DPERB2(Z1,Z2,Z3,Z4,Z5,Z6,NLOCAL,NUMV2,ICASPL,ICONT,
1Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'ERBA')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPERBA--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGG2,IBUGG3,IBUGQ,ISUBRO
9012 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)IFOUND,IERROR
9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
9014 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
1I8,I8,I8,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9041)NLOCAL,NUMV2
9041 FORMAT('NLOCAL,NUMV2 = ',2I8)
CALL DPWRST('XXX','BUG ')
IF(NLOCAL.LE.0)GOTO9044
DO9042I=1,NLOCAL
WRITE(ICOUT,9043)I,Z1(I),Z2(I),Z3(I),Z4(I),Z5(I),Z6(I)
9043 FORMAT('I,Z1(I),Z2(I),Z3(I),Z4(I),Z5(I),Z6(I) = ',I8,6E10.3)
CALL DPWRST('XXX','BUG ')
9042 CONTINUE
9044 CONTINUE
WRITE(ICOUT,9051)NPLOTP
9051 FORMAT('NPLOTP = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NPLOTP.LE.0)GOTO9054
DO9052I=1,NPLOTP
WRITE(ICOUT,9053)I,Y(I),X(I),D(I)
9053 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
CALL DPWRST('XXX','BUG ')
9052 CONTINUE
9054 CONTINUE
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPERB2(Z1,Z2,Z3,Z4,Z5,Z6,N,NUMV2,ICASPL,ICONT,
1Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
C
C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
C THAT WILL DEFINE AN ERROR BAR 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-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/12
C ORIGINAL VERSION--DECEMBER 1988.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 ICASPL
CHARACTER*4 ICONT
CHARACTER*4 IBUGG3
CHARACTER*4 ISUBRO
CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
DIMENSION Z1(*)
DIMENSION Z2(*)
DIMENSION Z3(*)
DIMENSION Z4(*)
DIMENSION Z5(*)
DIMENSION Z6(*)
C
DIMENSION Y2(*)
DIMENSION X2(*)
DIMENSION D2(*)
C
C---------------------------------------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'ERB2')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPERB2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBUGG3,ISUBRO,IERROR
52 FORMAT('IBUGG3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)ICASPL,ICONT
53 FORMAT('ICASPL,ICONT = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)NUMV2
54 FORMAT('NUMV2 = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,61)N
61 FORMAT('N = ',I8)
CALL DPWRST('XXX','BUG ')
DO62I=1,N
WRITE(ICOUT,63)I,Z1(I),Z2(I),Z3(I),Z4(I),Z5(I),Z6(I)
63 FORMAT('I,Z1(I),Z2(I),Z3(I),Z4(I),Z5(I),Z6(I) = ',I8,6E10.3)
CALL DPWRST('XXX','BUG ')
62 CONTINUE
90 CONTINUE
C
NUMCPL=11
J=0
JD=0
C
DO1100I=1,N
C
YMID=Z1(I)
C
YMAX=YMID+Z2(I)
C
IF(NUMV2.LE.3)YMIN=YMID-Z2(I)
IF(NUMV2.GE.4)YMIN=YMID-Z3(I)
C
IF(NUMV2.LE.2)XMID=I
IF(NUMV2.EQ.3)XMID=Z3(I)
IF(NUMV2.GE.4)XMID=Z4(I)
C
IF(NUMV2.LE.4)XLEF=XMID
IF(NUMV2.GE.5)XLEF=XMID-Z5(I)
C
IF(NUMV2.LE.4)XRIG=XMID
IF(NUMV2.EQ.5)XRIG=XMID+Z5(I)
IF(NUMV2.EQ.6)XRIG=XMID+Z6(I)
C
CALL DPCHLI(ICONT,NUMCPL,YMID,YMID,XMID,XMID,J,JD,Y2,X2,D2,IERROR)
CALL DPCHLI(ICONT,NUMCPL,YMAX,YMAX,XMID,XMID,J,JD,Y2,X2,D2,IERROR)
CALL DPCHLI(ICONT,NUMCPL,YMIN,YMIN,XMID,XMID,J,JD,Y2,X2,D2,IERROR)
CALL DPCHLI(ICONT,NUMCPL,YMID,YMID,XLEF,XLEF,J,JD,Y2,X2,D2,IERROR)
CALL DPCHLI(ICONT,NUMCPL,YMID,YMID,XRIG,XRIG,J,JD,Y2,X2,D2,IERROR)
CALL DPCHLI(ICONT,NUMCPL,YMAX,YMIN,XMID,XMID,J,JD,Y2,X2,D2,IERROR)
CALL DPCHLI(ICONT,NUMCPL,YMID,YMID,XLEF,XRIG,J,JD,Y2,X2,D2,IERROR)
C
1100 CONTINUE
C
N2=J
NPLOTV=3
GOTO9000
C
C ******************
C ** STEP 90-- **
C ** EXIT **
C ******************
C
9000 CONTINUE
IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'ERB2')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPERB2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGG3,ISUBRO,IERROR
9012 FORMAT('IBUGG3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)ICASPL,ICONT
9013 FORMAT('ICASPL,ICONT = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)NUMV2
9014 FORMAT('NUMV2 = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9021)N2,NPLOTV
9021 FORMAT('N2,NPLOTV = ',2I8)
CALL DPWRST('XXX','BUG ')
DO9022I=1,N2
WRITE(ICOUT,9023)I,Y2(I),X2(I),D2(I)
9023 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,3E10.3)
CALL DPWRST('XXX','BUG ')
9022 CONTINUE
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPERDE(IHARG,IARGT,ARG,NUMARG,DEFERD,
1ERASDE,IFOUND,IERROR)
C
C PURPOSE--DEFINE THE ERASE DELAY FACTOR.
C THE SPECIFIED ERASE DELAY FACTOR WILL BE PLACED
C IN THE FLOATING POINT VARIABLE ERASDE.
C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR)
C --IARGT (A HOLLERITH VECTOR)
C --ARG (A FLOATING POINT VECTOR)
C --NUMARG (AN INTEGER VARIABLE)
C --DEFERD (A FLOATING POINT VARIABLE)
C OUTPUT ARGUMENTS--ERASDE (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
IF(NUMARG.EQ.0)GOTO1199
IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DELA')GOTO1110
GOTO1199
C
1110 CONTINUE
IF(IHARG(NUMARG).EQ.'DELA')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 DPERDE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1122)
1122 FORMAT(' ILLEGAL FORM FOR ERASE DELAY ',
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 TO DOUBLE ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1126)
1126 FORMAT(' THE DELAY TIME WHILE SCREEN ERASURES ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1127)
1127 FORMAT(' ARE BEING CARRIED OUT, ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1130)
1130 FORMAT(' THEN THE ALLOWABLE FORM IS--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1131)
1131 FORMAT(' ERASE DELAY 2 ')
CALL DPWRST('XXX','BUG ')
GOTO1199
C
1150 CONTINUE
HOLD=DEFERD
GOTO1180
C
1160 CONTINUE
HOLD=ARG(NUMARG)
GOTO1180
C
1180 CONTINUE
IFOUND='YES'
CCCCC ERASDE=HOLD
AIMAX=2**(NUMBPC*NUMCPW-2)
IF(HOLD.LT.AIMAX)ERASDE=HOLD
IF(HOLD.GE.AIMAX)ERASDE=AIMAX
C
IF(IFEEDB.EQ.'OFF')GOTO1189
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1181)ERASDE
1181 FORMAT('THE ERASE DELAY FACTOR HAS JUST BEEN SET TO ',
1E15.7)
CALL DPWRST('XXX','BUG ')
1189 CONTINUE
GOTO1199
C
1199 CONTINUE
RETURN
END
SUBROUTINE DPERSC(IBACCO)
C
C PURPOSE--ERASE THE SCREEN
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 --JANUARY 1989. SEND BKGD COLOR TO GRERSC
C (FOR METAFILE) (ALAN)
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
CHARACTER*4 IBACCO
C
CHARACTER*4 ICASE
CHARACTER*4 ICOL
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
ICASE='9999'
C
IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'ERSC')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPERSC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBACCO
52 FORMAT('IBACCO = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)IMANUF,IMODEL
53 FORMAT('IMANUF,IMODEL = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)IGCOLO
54 FORMAT('IGCOLO = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,59)IBUGG4
59 FORMAT('IBUGG4 = ',A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C **********************************************
C ** STEP 1-- **
C ** BRANCH TO THE COLOR OR NON-COLOR CASES **
C **********************************************
C
IF(IGCOLO.EQ.'OFF')GOTO1100
GOTO1200
C
C ********************************
C ** STEP 1-- **
C ** TREAT THE NON-COLOR CASE **
C ********************************
C
1100 CONTINUE
JCOL=0
CALL GRERSC(JCOL,IBACCO)
GOTO9000
C
C ****************************************************
C ** STEP 2-- **
C ** TREAT THE COLOR CASE **
C ** STEP 2.1-- **
C ** TRANSLATE THE CHARACTER REPRESENTATION **
C ** OF THE BACKGROUND COLOR **
C ** INTO A NUMERIC REPRESENTATION **
C ** WHICH CAN BE UNDERSTOOD BY THE **
C ** GRAPHICS DEVICE. **
C ** STEP 2.2-- **
C ** SET THE BACKGROUND COLOR **
C ** ON THE GRAPHICS DEVICE. **
C ** STEP 2.3-- **
C ** ERASE THE SCREEN **
C ****************************************************
C
1200 CONTINUE
CCCCC ICASE='REGI'
ICASE='BACK'
ICOL=IBACCO
CALL GRTRCO(ICASE,ICOL,JCOL)
CALL GRSECO(ICASE,ICOL,JCOL)
CALL GRERSC(JCOL,ICOL)
GOTO9000
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'ERSC')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPERSC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBACCO,ICOL,JCOL
9012 FORMAT('IBACCO,ICOL,JCOL = ',A4,2X,A4,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)ICASE
9013 FORMAT('ICASE = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)IMANUF,IMODEL
9014 FORMAT('IMANUF,IMODEL = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)IBUGG4,ISUBG4,IERRG4
9015 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPEXA2(Y,X,N,ITYPE,B1,K1,K2,IBUGA3,B2,IERROR)
C
C PURPOSE--SOLVE FOR THE COEFFICIENTS FOR AN
C EXACT FIT OF A FUNCTION OF THE FORM
C Y = F(X) = POLYNOMIAL/POLYNOMIAL
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 1978.
C UPDATED --OCTOBER 1978.
C UPDATED --FEBRUARY 1981.
C UPDATED --JULY 1981.
C UPDATED --AUGUST 1981.
C UPDATED --MAY 1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 ITYPE
CHARACTER*4 IBUGA3
CHARACTER*4 IERROR
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
DIMENSION Y(*)
DIMENSION X(*)
DIMENSION ITYPE(*)
DIMENSION B1(*)
DIMENSION B2(*)
C
DIMENSION A(25,25)
DIMENSION A2(25,25)
DIMENSION A3(25,25)
DIMENSION RIGHT(25)
DIMENSION RIGHT2(25)
DIMENSION B3(25)
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='DPEX'
ISUBN2='A2 '
C
IERROR='NO'
C
IF(IBUGA3.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPEXA2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBUGA3
52 FORMAT('IBUGA3 = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)N,K1,K2
53 FORMAT('N,K1,K2 = ',3I8)
CALL DPWRST('XXX','BUG ')
KTEMP=K1+K2
DO55I=1,KTEMP
WRITE(ICOUT,56)I,Y(I),X(I),ITYPE(I),B1(I)
56 FORMAT('I,Y(.),X(.),ITYPE(.),B1(.) = ',I8,2E15.7,2X,A4,E15.7)
CALL DPWRST('XXX','BUG ')
55 CONTINUE
90 CONTINUE
C
C ********************************************
C ** STEP 1-- **
C ** FORM THE MATIX FOR THE LINEAR SYSTEM **
C ********************************************
C
ISTEPN='1'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
K1P1=K1+1
K1P5=K1+5
K1P6=K1+6
K1P10=K1+10
K1P11=K1+11
K1P15=K1+15
K1P16=K1+16
K1P20=K1+20
K1P21=K1+21
K1PK2=K1+K2
C
DO100J=1,K1
DO110I=1,N
IF(J.EQ.1)A(I,J)=1.0
IF(J.GT.1)A(I,J)=X(I)**(J-1)
110 CONTINUE
100 CONTINUE
C
DO200J=1,K2
K1PJ=K1+J
DO210I=1,N
IF(J.EQ.1)A(I,K1PJ)=1.0
IF(J.GT.1)A(I,K1PJ)=X(I)**(J-1)
A(I,K1PJ)=-Y(I)*A(I,K1PJ)
210 CONTINUE
200 CONTINUE
C
K=K1+K2
DO250I=1,N
IF(IBUGA3.EQ.'ON')WRITE(ICOUT,255)(A(I,J),J=1,K)
255 FORMAT('A(.,.) = ',10E12.6)
IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
250 CONTINUE
C
C *************************************************
C ** STEP 2-- **
C ** FORM THE RIGHT SIDE FOR THE LINEAR SYSTEM **
C *************************************************
C
ISTEPN='2'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
DO300I=1,N
RIGHT(I)=0.0
300 CONTINUE
C
DO400J=1,K
IF(ITYPE(J).EQ.'K')GOTO410
GOTO400
410 CONTINUE
DO500I=1,N
RIGHT(I)=RIGHT(I)-A(I,J)
500 CONTINUE
400 CONTINUE
C
C ***********************************************
C ** STEP 3-- **
C ** ADJUST THE MATRIX FOR THE LINEAR SYSTEM **
C ***********************************************
C
ISTEPN='3'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
J2=0
DO600J=1,K
IF(ITYPE(J).EQ.'K')GOTO600
J2=J2+1
DO700I=1,N
A2(I,J2)=A(I,J)
700 CONTINUE
600 CONTINUE
C
C *********************************
C ** STEP 4-- **
C ** TRIANGULARIZE THE SYSTEM, **
C ** THEN BACKSOLVE. **
C *********************************
C
ISTEPN='4'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IBUGA3.EQ.'OFF')GOTO790
WRITE(ICOUT,711)N
711 FORMAT('N = ',I8)
CALL DPWRST('XXX','BUG ')
DO720I=1,N
WRITE(ICOUT,721)(A2(I,J),J=1,N),RIGHT(I)
721 FORMAT('A2(I,.),RIGHT(I) = ',11E10.3)
CALL DPWRST('XXX','BUG ')
720 CONTINUE
790 CONTINUE
C
CALL TRIA25(A2,N,N,RIGHT,A3,RIGHT2,IBUGA3)
CALL BACK25(A3,N,N,RIGHT2,B3,IBUGA3)
C
C *****************************
C ** STEP 5-- **
C ** COPY THE COEFFICIENTS **
C *****************************
C
ISTEPN='5'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IU=0
DO800J=1,K
IF(IBUGA3.EQ.'ON')WRITE(ICOUT,811)J,IU,ITYPE(J),B1(J),B2(J),B3(J)
811 FORMAT('J,IU,ITYPE(J),B1(J),B2(J),B3(J) = ',2I6,2X,A4,3F10.4)
IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
IF(ITYPE(J).EQ.'K')GOTO850
IU=IU+1
B2(J)=B3(IU)
GOTO800
850 CONTINUE
B2(J)=B1(J)
800 CONTINUE
C
C ****************************
C ** STEP 6-- **
C ** WRITE EVERYTHING OUT **
C ****************************
C
ISTEPN='6'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IDEG1=K1-1
IDEG2=K2-1
C
IF(IPRINT.EQ.'OFF')GOTO2990
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1001)
1001 FORMAT('EXACT RATIONAL FUNCTION FIT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1002)N
1002 FORMAT(' NUMBER OF POINTS IN FIRST SET = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1003)IDEG1
1003 FORMAT(' DEGREE OF NUMERATOR = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1004)IDEG2
1004 FORMAT(' DEGREE OF DENOMINATOR = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
IF(K1.EQ.1)GOTO1010
IF(K1.EQ.2)GOTO1020
IF(K1.EQ.3)GOTO1030
IF(K1.EQ.4)GOTO1040
IF(K1.EQ.5)GOTO1050
IF(K1.EQ.6)GOTO1060
IF(K1.EQ.7)GOTO1070
IF(K1.EQ.8)GOTO1080
IF(K1.EQ.9)GOTO1090
IF(K1.EQ.10)GOTO1100
IF(K1.EQ.11)GOTO1110
IF(K1.EQ.12)GOTO1120
IF(K1.EQ.13)GOTO1130
IF(K1.EQ.14)GOTO1140
IF(K1.EQ.15)GOTO1150
IF(K1.EQ.16)GOTO1160
IF(K1.EQ.17)GOTO1170
IF(K1.EQ.18)GOTO1180
IF(K1.EQ.19)GOTO1190
IF(K1.EQ.20)GOTO1200
IF(K1.EQ.21)GOTO1210
C
1010 CONTINUE
WRITE(ICOUT,1011)(B2(I),I=1,K1)
1011 FORMAT('NUMERATOR --A0 =',5E15.7)
CALL DPWRST('XXX','BUG ')
GOTO1990
1020 CONTINUE
WRITE(ICOUT,1021)(B2(I),I=1,K1)
1021 FORMAT('NUMERATOR --A0 A1 =',5E15.7)
CALL DPWRST('XXX','BUG ')
GOTO1990
1030 CONTINUE
WRITE(ICOUT,1031)(B2(I),I=1,K1)
1031 FORMAT('NUMERATOR --A0 A1 A2 =',5E16.3)
CALL DPWRST('XXX','BUG ')
GOTO1990
1040 CONTINUE
WRITE(ICOUT,1041)(B2(I),I=1,K1)
1041 FORMAT('NUMERATOR --A0 A1 A2 A3 =',5E15.7)
CALL DPWRST('XXX','BUG ')
GOTO1990
1050 CONTINUE
WRITE(ICOUT,1051)(B2(I),I=1,K1)
1051 FORMAT('NUMERATOR --A0 A1 A2 A3 A4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
GOTO1990
1060 CONTINUE
WRITE(ICOUT,1061)(B2(I),I=1,5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1062)(B2(I),I=6,K1)
1061 FORMAT('NUMERATOR --A0 A1 A2 A3 A4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
1062 FORMAT(' --A5 =',5E15.7)
GOTO1990
1070 CONTINUE
WRITE(ICOUT,1071)(B2(I),I=1,5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1072)(B2(I),I=6,K1)
1071 FORMAT('NUMERATOR --A0 A1 A2 A3 A4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
1072 FORMAT(' --A5 A6 =',5E15.7)
GOTO1990
1080 CONTINUE
WRITE(ICOUT,1081)(B2(I),I=1,5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1082)(B2(I),I=6,K1)
1081 FORMAT('NUMERATOR --A0 A1 A2 A3 A4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
1082 FORMAT(' --A5 A6 A7 =',5E15.7)
GOTO1990
1090 CONTINUE
WRITE(ICOUT,1091)(B2(I),I=1,5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1092)(B2(I),I=6,K1)
1091 FORMAT('NUMERATOR --A0 A1 A2 A3 A4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
1092 FORMAT(' --A5 A6 A7 A8 =',5E15.7)
GOTO1990
1100 CONTINUE
WRITE(ICOUT,1101)(B2(I),I=1,5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1102)(B2(I),I=6,K1)
1101 FORMAT('NUMERATOR --A0 A1 A2 A3 A4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
1102 FORMAT(' --A5 A6 A7 A8 A9 =',5E15.7)
GOTO1990
1110 CONTINUE
WRITE(ICOUT,1111)(B2(I),I=1,5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1112)(B2(I),I=6,10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1113)(B2(I),I=11,K1)
1111 FORMAT('NUMERATOR --A0 A1 A2 A3 A4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
1112 FORMAT(' --A5 A6 A7 A8 A9 =',5E15.7)
1113 FORMAT(' --A10 =',5E15.7)
GOTO1990
1120 CONTINUE
WRITE(ICOUT,1121)(B2(I),I=1,5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1122)(B2(I),I=6,10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1123)(B2(I),I=11,K1)
1121 FORMAT('NUMERATOR --A0 A1 A2 A3 A4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
1122 FORMAT(' --A5 A6 A7 A8 A9 =',5E15.7)
1123 FORMAT(' --A10 A11 =',5E15.7)
GOTO1990
1130 CONTINUE
WRITE(ICOUT,1131)(B2(I),I=1,5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1132)(B2(I),I=6,10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1133)(B2(I),I=11,K1)
1131 FORMAT('NUMERATOR --A0 A1 A2 A3 A4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
1132 FORMAT(' --A5 A6 A7 A8 A9 =',5E15.7)
1133 FORMAT(' --A10 A11 A12 =',5E15.7)
GOTO1990
1140 CONTINUE
WRITE(ICOUT,1141)(B2(I),I=1,5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1142)(B2(I),I=6,10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1143)(B2(I),I=11,K1)
1141 FORMAT('NUMERATOR --A0 A1 A2 A3 A4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
1142 FORMAT(' --A5 A6 A7 A8 A9 =',5E15.7)
1143 FORMAT(' --A10 A11 A12 A13 =',5E15.7)
GOTO1990
1150 CONTINUE
WRITE(ICOUT,1151)(B2(I),I=1,5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1152)(B2(I),I=6,10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1153)(B2(I),I=11,K1)
1151 FORMAT('NUMERATOR --A0 A1 A2 A3 A4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
1152 FORMAT(' --A5 A6 A7 A8 A9 =',5E15.7)
1153 FORMAT(' --A10 A11 A12 A13 A14 =',5E15.7)
GOTO1990
1160 CONTINUE
WRITE(ICOUT,1161)(B2(I),I=1,5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1162)(B2(I),I=6,10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1163)(B2(I),I=11,15)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1164)(B2(I),I=16,K1)
1161 FORMAT('NUMERATOR --A0 A1 A2 A3 A4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
1162 FORMAT(' --A5 A6 A7 A8 A9 =',5E15.7)
1163 FORMAT(' --A10 A11 A12 A13 A14 =',5E15.7)
1164 FORMAT(' --A15 =',5E15.7)
GOTO1990
1170 CONTINUE
WRITE(ICOUT,1171)(B2(I),I=1,5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1172)(B2(I),I=6,10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1173)(B2(I),I=11,15)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1174)(B2(I),I=16,K1)
1171 FORMAT('NUMERATOR --A0 A1 A2 A3 A4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
1172 FORMAT(' --A5 A6 A7 A8 A9 =',5E15.7)
1173 FORMAT(' --A10 A11 A12 A13 A14 =',5E15.7)
1174 FORMAT(' --A15 A16 =',5E15.7)
GOTO1990
1180 CONTINUE
WRITE(ICOUT,1181)(B2(I),I=1,5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1182)(B2(I),I=6,10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1183)(B2(I),I=11,15)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1184)(B2(I),I=16,K1)
1181 FORMAT('NUMERATOR --A0 A1 A2 A3 A4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
1182 FORMAT(' --A5 A6 A7 A8 A9 =',5E15.7)
1183 FORMAT(' --A10 A11 A12 A13 A14 =',5E15.7)
1184 FORMAT(' --A15 A16 A17 =',5E15.7)
GOTO1990
1190 CONTINUE
WRITE(ICOUT,1191)(B2(I),I=1,5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1192)(B2(I),I=6,10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1193)(B2(I),I=11,15)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1194)(B2(I),I=16,K1)
1191 FORMAT('NUMERATOR --A0 A1 A2 A3 A4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
1192 FORMAT(' --A5 A6 A7 A8 A9 =',5E15.7)
1193 FORMAT(' --A10 A11 A12 A13 A14 =',5E15.7)
1194 FORMAT(' --A15 A16 A17 A18 =',5E15.7)
GOTO1990
1200 CONTINUE
WRITE(ICOUT,1201)(B2(I),I=1,5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1202)(B2(I),I=6,10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1203)(B2(I),I=11,15)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1204)(B2(I),I=16,K1)
1201 FORMAT('NUMERATOR --A0 A1 A2 A3 A4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
1202 FORMAT(' --A5 A6 A7 A8 A9 =',5E15.7)
1203 FORMAT(' --A10 A11 A12 A13 A14 =',5E15.7)
1204 FORMAT(' --A15 A16 A17 A18 A19 =',5E15.7)
GOTO1990
1210 CONTINUE
WRITE(ICOUT,1211)(B2(I),I=1,5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1212)(B2(I),I=6,10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1213)(B2(I),I=11,15)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1214)(B2(I),I=16,20)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1215)(B2(I),I=21,K1)
1211 FORMAT('NUMERATOR --A0 A1 A2 A3 A4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
1212 FORMAT(' --A5 A6 A7 A8 A9 =',5E15.7)
1213 FORMAT(' --A10 A11 A12 A13 A14 =',5E15.7)
1214 FORMAT(' --A15 A16 A17 A18 A19 =',5E15.7)
1215 FORMAT(' --A20 =',5E15.7)
GOTO1990
1990 CONTINUE
C
IF(K2.EQ.1)GOTO2010
IF(K2.EQ.2)GOTO2020
IF(K2.EQ.3)GOTO2030
IF(K2.EQ.4)GOTO2040
IF(K2.EQ.5)GOTO2050
IF(K2.EQ.6)GOTO2060
IF(K2.EQ.7)GOTO2070
IF(K2.EQ.8)GOTO2080
IF(K2.EQ.9)GOTO2090
IF(K2.EQ.10)GOTO2100
IF(K2.EQ.11)GOTO2110
IF(K2.EQ.12)GOTO2120
IF(K2.EQ.13)GOTO2130
IF(K2.EQ.14)GOTO2140
IF(K2.EQ.15)GOTO2150
IF(K2.EQ.16)GOTO2160
IF(K2.EQ.17)GOTO2170
IF(K2.EQ.18)GOTO2180
IF(K2.EQ.19)GOTO2190
IF(K2.EQ.20)GOTO2200
IF(K2.EQ.21)GOTO2210
C
2010 CONTINUE
WRITE(ICOUT,2011)(B2(I),I=K1P1,K1PK2)
2011 FORMAT('DENOMINATOR--B0 =',5E15.7)
CALL DPWRST('XXX','BUG ')
GOTO2990
2020 CONTINUE
WRITE(ICOUT,2021)(B2(I),I=K1P1,K1PK2)
2021 FORMAT('DENOMINATOR--B0 B1 =',5E15.7)
CALL DPWRST('XXX','BUG ')
GOTO2990
2030 CONTINUE
WRITE(ICOUT,2031)(B2(I),I=K1P1,K1PK2)
2031 FORMAT('DENOMINATOR--B0 B1 B2 =',5E16.3)
CALL DPWRST('XXX','BUG ')
GOTO2990
2040 CONTINUE
WRITE(ICOUT,2041)(B2(I),I=K1P1,K1PK2)
2041 FORMAT('DENOMINATOR--B0 B1 B2 B3 =',5E15.7)
CALL DPWRST('XXX','BUG ')
GOTO2990
2050 CONTINUE
WRITE(ICOUT,2051)(B2(I),I=K1P1,K1PK2)
2051 FORMAT('DENOMINATOR--B0 B1 B2 B3 B4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
GOTO2990
2060 CONTINUE
WRITE(ICOUT,2061)(B2(I),I=K1P1,K1P5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2062)(B2(I),I=K1P6,K1PK2)
2061 FORMAT('DENOMINATOR--B0 B1 B2 B3 B4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
2062 FORMAT(' --B5 =',5E15.7)
GOTO2990
2070 CONTINUE
WRITE(ICOUT,2071)(B2(I),I=K1P1,K1P5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2072)(B2(I),I=K1P6,K1PK2)
2071 FORMAT('DENOMINATOR--B0 B1 B2 B3 B4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
2072 FORMAT(' --B5 B6 =',5E15.7)
GOTO2990
2080 CONTINUE
WRITE(ICOUT,2081)(B2(I),I=K1P1,K1P5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2082)(B2(I),I=K1P6,K1PK2)
2081 FORMAT('DENOMINATOR--B0 B1 B2 B3 B4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
2082 FORMAT(' --B5 B6 B7 =',5E15.7)
GOTO2990
2090 CONTINUE
WRITE(ICOUT,2091)(B2(I),I=K1P1,K1P5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2092)(B2(I),I=K1P6,K1PK2)
2091 FORMAT('DENOMINATOR--B0 B1 B2 B3 B4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
2092 FORMAT(' --B5 B6 B7 B8 =',5E15.7)
GOTO2990
2100 CONTINUE
WRITE(ICOUT,2101)(B2(I),I=K1P1,K1P5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2102)(B2(I),I=K1P6,K1PK2)
2101 FORMAT('DENOMINATOR--B0 B1 B2 B3 B4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
2102 FORMAT(' --B5 B6 B7 B8 B9 =',5E15.7)
GOTO2990
2110 CONTINUE
WRITE(ICOUT,2111)(B2(I),I=K1P1,K1P5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2112)(B2(I),I=K1P6,K1P10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2113)(B2(I),I=K1P11,K1PK2)
2111 FORMAT('DENOMINATOR--B0 B1 B2 B3 B4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
2112 FORMAT(' --B5 B6 B7 B8 B9 =',5E15.7)
2113 FORMAT(' --B10 =',5E15.7)
GOTO2990
2120 CONTINUE
WRITE(ICOUT,2121)(B2(I),I=K1P1,K1P5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2122)(B2(I),I=K1P6,K1P10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2123)(B2(I),I=K1P11,K1PK2)
2121 FORMAT('DENOMINATOR--B0 B1 B2 B3 B4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
2122 FORMAT(' --B5 B6 B7 B8 B9 =',5E15.7)
2123 FORMAT(' --B10 B11 =',5E15.7)
GOTO2990
2130 CONTINUE
WRITE(ICOUT,2131)(B2(I),I=K1P1,K1P5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2132)(B2(I),I=K1P6,K1P10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2133)(B2(I),I=K1P11,K1PK2)
2131 FORMAT('DENOMINATOR--B0 B1 B2 B3 B4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
2132 FORMAT(' --B5 B6 B7 B8 B9 =',5E15.7)
2133 FORMAT(' --B10 B11 B12 =',5E15.7)
GOTO2990
2140 CONTINUE
WRITE(ICOUT,2141)(B2(I),I=K1P1,K1P5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2142)(B2(I),I=K1P6,K1P10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2143)(B2(I),I=K1P11,K1PK2)
2141 FORMAT('DENOMINATOR--B0 B1 B2 B3 B4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
2142 FORMAT(' --B5 B6 B7 B8 B9 =',5E15.7)
2143 FORMAT(' --B10 B11 B12 B13 =',5E15.7)
GOTO2990
2150 CONTINUE
WRITE(ICOUT,2151)(B2(I),I=K1P1,K1P5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2152)(B2(I),I=K1P6,K1P10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2153)(B2(I),I=K1P11,K1PK2)
2151 FORMAT('DENOMINATOR--B0 B1 B2 B3 B4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
2152 FORMAT(' --B5 B6 B7 B8 B9 =',5E15.7)
2153 FORMAT(' --B10 B11 B12 B13 B14 =',5E15.7)
GOTO2990
2160 CONTINUE
WRITE(ICOUT,2161)(B2(I),I=K1P1,K1P5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2162)(B2(I),I=K1P6,K1P10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2163)(B2(I),I=K1P11,K1P15)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2164)(B2(I),I=K1P16,K1PK2)
2161 FORMAT('DENOMINATOR--B0 B1 B2 B3 B4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
2162 FORMAT(' --B5 B6 B7 B8 B9 =',5E15.7)
2163 FORMAT(' --B10 B11 B12 B13 B14 =',5E15.7)
2164 FORMAT(' --B15 =',5E15.7)
GOTO2990
2170 CONTINUE
WRITE(ICOUT,2171)(B2(I),I=K1P1,K1P5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2172)(B2(I),I=K1P6,K1P10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2173)(B2(I),I=K1P11,K1P15)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2174)(B2(I),I=K1P16,K1PK2)
2171 FORMAT('DENOMINATOR--B0 B1 B2 B3 B4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
2172 FORMAT(' --B5 B6 B7 B8 B9 =',5E15.7)
2173 FORMAT(' --B10 B11 B12 B13 B14 =',5E15.7)
2174 FORMAT(' --B15 B16 =',5E15.7)
GOTO2990
2180 CONTINUE
WRITE(ICOUT,2181)(B2(I),I=K1P1,K1P5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2182)(B2(I),I=K1P6,K1P10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2183)(B2(I),I=K1P11,K1P15)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2184)(B2(I),I=K1P16,K1PK2)
2181 FORMAT('DENOMINATOR--B0 B1 B2 B3 B4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
2182 FORMAT(' --B5 B6 B7 B8 B9 =',5E15.7)
2183 FORMAT(' --B10 B11 B12 B13 B14 =',5E15.7)
2184 FORMAT(' --B15 B16 B17 =',5E15.7)
GOTO2990
2190 CONTINUE
WRITE(ICOUT,2191)(B2(I),I=K1P1,K1P5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2192)(B2(I),I=K1P6,K1P10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2193)(B2(I),I=K1P11,K1P15)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2194)(B2(I),I=K1P16,K1PK2)
2191 FORMAT('DENOMINATOR--B0 B1 B2 B3 B4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
2192 FORMAT(' --B5 B6 B7 B8 B9 =',5E15.7)
2193 FORMAT(' --B10 B11 B12 B13 B14 =',5E15.7)
2194 FORMAT(' --B15 B16 B17 B18 =',5E15.7)
GOTO2990
2200 CONTINUE
WRITE(ICOUT,2201)(B2(I),I=K1P1,K1P5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2202)(B2(I),I=K1P6,K1P10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2203)(B2(I),I=K1P11,K1P15)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2204)(B2(I),I=K1P16,K1PK2)
2201 FORMAT('DENOMINATOR--B0 B1 B2 B3 B4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
2202 FORMAT(' --B5 B6 B7 B8 B9 =',5E15.7)
2203 FORMAT(' --B10 B11 B12 B13 B14 =',5E15.7)
2204 FORMAT(' --B15 B16 B17 B18 B19 =',5E15.7)
GOTO2990
2210 CONTINUE
WRITE(ICOUT,2211)(B2(I),I=K1P1,K1P5)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2212)(B2(I),I=K1P6,K1P10)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2213)(B2(I),I=K1P11,K1P15)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2214)(B2(I),I=K1P16,K1P20)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2215)(B2(I),I=K1P21,K1PK2)
2211 FORMAT('DENOMINATOR--B0 B1 B2 B3 B4 =',5E15.7)
CALL DPWRST('XXX','BUG ')
2212 FORMAT(' --B5 B6 B7 B8 B9 =',5E15.7)
2213 FORMAT(' --B10 B11 B12 B13 B14 =',5E15.7)
2214 FORMAT(' --B15 B16 B17 B18 B19 =',5E15.7)
2215 FORMAT(' --B20 =',5E15.7)
GOTO2990
2990 CONTINUE
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGA3.EQ.'OFF')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPEXA2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGA3,IERROR
9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)N,K1,K2
9013 FORMAT('N,K1,K2 = ',3I8)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPEXAC(IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
C
C PURPOSE--CARRY OUT AN EXACT RATIONAL FUNCTION FIT.
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 1978.
C UPDATED --JUNE 1978.
C UPDATED --JULY 1978.
C UPDATED --OCTOBER 1978.
C UPDATED --NOVEMBER 1978.
C UPDATED --FEBRUARY 1981.
C UPDATED --JULY 1981.
C UPDATED --AUGUST 1981.
C UPDATED --SEPTEMBER 1981.
C UPDATED --NOVEMBER 1981.
C UPDATED --MARCH 1982.
C UPDATED --MAY 1982.
C UPDATED --MARCH 1988. ADD LOFCDF
C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON
C UPDATED --NOVEMBER 1993. ALLOW SPACES AROUND /
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IBUGA2
CHARACTER*4 IBUGA3
CHARACTER*4 IBUGQ
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 ICASEQ
CHARACTER*4 IHWUSE
CHARACTER*4 MESSAG
CHARACTER*4 ITYPE
CHARACTER*4 IREPU
CHARACTER*4 IRESU
CHARACTER*4 IH2
CHARACTER*4 IH
CHARACTER*4 ICH
CHARACTER*4 ICH1A
CHARACTER*4 ICH2A
CHARACTER*4 ICH1B
CHARACTER*4 ICH2B
CHARACTER*4 IHFACT
CHARACTER*4 IHFAC2
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
INCLUDE 'DPCOPA.INC'
C
DIMENSION F1(MAXOBV)
DIMENSION F2(MAXOBV)
DIMENSION F3(MAXOBV)
DIMENSION F4(MAXOBV)
C
DIMENSION PRED2(MAXOBV)
DIMENSION RES2(MAXOBV)
C
CCCCC DIMENSION W(MAXOBV)
C
DIMENSION ITYPE(100)
DIMENSION B1(100)
DIMENSION B2(100)
C
CCCCC FOLLOWING LINES ADDED JUNE, 1990
INCLUDE 'DPCOZZ.INC'
EQUIVALENCE (GARBAG(IGARB1),F1(1))
EQUIVALENCE (GARBAG(IGARB2),F2(1))
EQUIVALENCE (GARBAG(IGARB3),F3(1))
EQUIVALENCE (GARBAG(IGARB4),F4(1))
EQUIVALENCE (GARBAG(IGARB5),PRED2(1))
EQUIVALENCE (GARBAG(IGARB6),RES2(1))
EQUIVALENCE (GARBAG(IGARB7),B1(1))
EQUIVALENCE (GARBAG(IGARB7+100),B2(1))
CCCCC END CHANGE
DIMENSION ICOLIV(10)
DIMENSION NIV(10)
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='DPEX'
ISUBN2='AC '
C
MAXCP1=MAXCOL+1
MAXCP2=MAXCOL+2
MAXCP3=MAXCOL+3
MAXCP4=MAXCOL+4
MAXCP5=MAXCOL+5
MAXCP6=MAXCOL+6
C
IERROR='NO'
C
MINN2=2
MAXFAC=4
C
C **************************************************
C ** TREAT THE EXACT RATIONAL FUNCTION FIT CASE **
C **************************************************
C
IF(IBUGA2.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPEXAC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBUGA2,IBUGA3
52 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)IBUGQ
53 FORMAT('IBUGQ = ',A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C ***************************
C ** STEP 1-- **
C ** EXTRACT THE COMMAND **
C ***************************
C
ISTEPN='1'
IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(NUMARG.GE.2.AND.ICOM.EQ.'EXAC'.AND.
1IHARG(2).EQ.'FIT ')GOTO112
C
IF(NUMARG.GE.3.AND.ICOM.EQ.'EXAC'.AND.
1IHARG(3).EQ.'FIT ')GOTO113
C
IF(NUMARG.GE.4.AND.ICOM.EQ.'EXAC'.AND.
1IHARG(4).EQ.'FIT ')GOTO114
C
IF(NUMARG.GE.5.AND.ICOM.EQ.'EXAC'.AND.
1IHARG(5).EQ.'FIT ')GOTO115
C
IF(NUMARG.GE.6.AND.ICOM.EQ.'EXAC'.AND.
1IHARG(6).EQ.'FIT ')GOTO116
C
IFOUND='NO'
GOTO9000
C
112 CONTINUE
ILASTC=2
CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
GOTO180
C
113 CONTINUE
ILASTC=3
CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
GOTO180
C
114 CONTINUE
ILASTC=4
CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
GOTO180
C
115 CONTINUE
ILASTC=5
CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
GOTO180
C
116 CONTINUE
ILASTC=6
CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
GOTO180
C
180 CONTINUE
IFOUND='YES'
GOTO190
C
190 CONTINUE
C
C *******************************************************
C ** STEP 2-- **
C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. **
C *******************************************************
C
ISTEPN='2'
IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
MINNA=2
MAXNA=100
CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,
1IERROR)
IF(IERROR.EQ.'YES')GOTO9000
C
C *****************************************
C ** STEP 3-- **
C ** CHECK TO SEE THE TYPE CASE-- **
C ** 1) UNQUALIFIED (THAT IS, FULL); **
C ** 2) SUBSET/EXCEPT; OR **
C ** 3) FOR. **
C *****************************************
C
ISTEPN='3'
IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ICASEQ='FULL'
ILOCQ=NUMARG+1
IF(NUMARG.LT.1)GOTO290
DO200J=1,NUMARG
J1=J
IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO210
IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO210
IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO220
200 CONTINUE
GOTO290
210 CONTINUE
ICASEQ='SUBS'
ILOCQ=J1
GOTO290
220 CONTINUE
ICASEQ='FOR'
ILOCQ=J1
GOTO290
290 CONTINUE
IF(IBUGA2.EQ.'OFF')GOTO295
WRITE(ICOUT,291)NUMARG,ILOCQ
291 FORMAT('NUMARG,ILOCQ = ',2I8)
CALL DPWRST('XXX','BUG ')
295 CONTINUE
C
C **************************************************************
C ** STEP 5-- **
C ** CHECK THE VALIDITY OF THE VARIABLES. **
C ** CHECK THAT THERE ARE EXACTLY 2 OR EXACTLY 4 VARIABLES. **
C ** CHECK THE VALIDITY OF EACH OF THE VARIABLES. **
C ** DOES THE VARIABLE NAME EXIST IN THE TABLE? **
C ** IS THE NUMBER OF ELEMENTS FOR EACH VARIABLE POSITIVE? **
C ** DOES THE NUMBER OF ELEMENTS IN VARIABLE 2 **
C ** AGREE WITH THE NUMBER OF ELEMENTS IN VARIABLE 1? **
C ** IF VARIABLES 3 AND 4 EXIST, **
C ** DOES THE NUMBER OF ELEMENTS IN VARIABLE 4 **
C ** AGREE WITH THE NUMBER OF ELEMENTS IN VARIABLE 3? **
C **************************************************************
C
ISTEPN='5'
IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
NUMFAC=ILOCQ-1
IF(1.LE.NUMFAC.AND.NUMFAC.LE.MAXFAC)GOTO509
WRITE(ICOUT,501)
501 FORMAT('***** ERROR IN DPEXAC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,502)
502 FORMAT(' FOR AN EXACT RATIONAL FUNCTION FIT,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,503)
503 FORMAT(' THE NUMBER OF VARIABLES MUST BE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,504)
504 FORMAT(' EXACTLY 2 OR EXACTLY 4;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,505)
505 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,506)NUMFAC
506 FORMAT(' THE SPECIFIED NUMBER OF VARIABLES WAS ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,507)
507 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,508)(IANS(I),I=1,IWIDTH)
508 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
509 CONTINUE
C
DO510IFAC=1,NUMFAC
IHFACT=IHARG(IFAC)
IHFAC2=IHARG2(IFAC)
IHWUSE='V'
MESSAG='YES'
CALL CHECKN(IHFACT,IHFAC2,IHWUSE,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
IF(IERROR.EQ.'YES')GOTO9000
ICOLIV(IFAC)=IVALUE(ILOCV)
NIV(IFAC)=IN(ILOCV)
IF(IBUGA2.EQ.'ON')WRITE(ICOUT,665)IFAC,IHFACT,IHFAC2,ILOCV,
1IVALUE(ILOCV)
665 FORMAT('IFAC,IHFACT,IHFAC2,ILOCV,IVALUE(ILOCV) = ',
1I8,2X,A4,2X,A4,I8,I8)
IF(IBUGA2.EQ.'ON')CALL DPWRST('XXX','BUG ')
IF(IBUGA2.EQ.'ON')WRITE(ICOUT,666)IFAC,IHFACT,IHFAC2,ICOLIV(IFAC),
1NIV(IFAC)
666 FORMAT('IFAC,IHFACT,IHFAC2,ICOLIV(IFAC),NIV(IFAC) = ',
1I8,2X,A4,2X,A4,I8,I8)
IF(IBUGA2.EQ.'ON')CALL DPWRST('XXX','BUG ')
510 CONTINUE
C
DO515IFAC=1,NUMFAC
IF(NIV(IFAC).GE.1)GOTO515
GOTO520
515 CONTINUE
NEXACT=NIV(1)
GOTO529
C
520 CONTINUE
WRITE(ICOUT,521)
521 FORMAT('***** ERROR IN DPEXAC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,522)
522 FORMAT(' FOR AN EXACT RATIONAL FUNCTION FIT,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,523)
523 FORMAT(' ALL VARIABLES MUST HAVE AT LEAST 1 ELEMENT;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,524)
524 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
DO525J=1,NUMFAC
WRITE(ICOUT,526)IHARG(J),IHARG2(J),NIV(J)
526 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8,' ELEMENTS')
CALL DPWRST('XXX','BUG ')
525 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,527)
527 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,528)(IANS(I),I=1,IWIDTH)
528 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
529 CONTINUE
C
IF(NUMFAC.LE.2.AND.NIV(2).EQ.NIV(1))GOTO549
IF(NUMFAC.GE.3.AND.NIV(2).EQ.NIV(1).AND.NIV(4).EQ.NIV(3))GOTO549
WRITE(ICOUT,531)
531 FORMAT('***** ERROR IN DPEXAC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,532)
532 FORMAT(' FOR AN EXACT RATIONAL FUNCTION FIT,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,533)
533 FORMAT(' THE NUMBER OF ELEMENTS IN VARIABLE 2 MUST')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,534)
534 FORMAT(' EQUAL THE NUMBER OF ELEMENTS IN VARIABLE 1;')
CALL DPWRST('XXX','BUG ')
IF(NUMFAC.GE.3)WRITE(ICOUT,536)
536 FORMAT(' AND THE NUMBER OF ELEMENTS IN VARIABLE 4 MUST')
IF(NUMFAC.GE.3)CALL DPWRST('XXX','BUG ')
IF(NUMFAC.GE.3)WRITE(ICOUT,537)
537 FORMAT(' EQUAL THE NUMBER OF ELEMENTS IN VARIABLE 3;')
IF(NUMFAC.GE.3)CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,538)
538 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
DO545J=1,NUMFAC
WRITE(ICOUT,546)IHARG(J),IHARG2(J),NIV(J)
546 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8,' ELEMENTS')
CALL DPWRST('XXX','BUG ')
545 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,547)
547 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,548)(IANS(I),I=1,IWIDTH)
548 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
549 CONTINUE
C
590 CONTINUE
C
C ***************************************
C ** STEP 6-- **
C ** EXTRACT THE EXACT-FIT VARIABLES **
C ***************************************
C
ISTEPN='6'
IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
J=0
DO560I=1,NEXACT
J=J+1
C
IFAC=1
ICOLR=ICOLIV(IFAC)
IJ=MAXN*(ICOLR-1)+I
IF(ICOLR.LE.MAXCOL)F1(J)=V(IJ)
IF(ICOLR.EQ.MAXCP1)F1(J)=PRED(I)
IF(ICOLR.EQ.MAXCP2)F1(J)=RES(I)
IF(ICOLR.EQ.MAXCP3)F1(J)=YPLOT(I)
IF(ICOLR.EQ.MAXCP4)F1(J)=XPLOT(I)
IF(ICOLR.EQ.MAXCP5)F1(J)=X2PLOT(I)
IF(ICOLR.EQ.MAXCP6)F1(J)=TAGPLO(I)
C
IFAC=2
ICOLR=ICOLIV(IFAC)
IJ=MAXN*(ICOLR-1)+I
IF(ICOLR.LE.MAXCOL)F2(J)=V(IJ)
IF(ICOLR.EQ.MAXCP1)F2(J)=PRED(I)
IF(ICOLR.EQ.MAXCP2)F2(J)=RES(I)
IF(ICOLR.EQ.MAXCP3)F2(J)=YPLOT(I)
IF(ICOLR.EQ.MAXCP4)F2(J)=XPLOT(I)
IF(ICOLR.EQ.MAXCP5)F2(J)=X2PLOT(I)
IF(ICOLR.EQ.MAXCP6)F2(J)=TAGPLO(I)
C
560 CONTINUE
C
C *********************************************
C ** STEP 7-- **
C ** BRANCH TO THE APPROPRIATE SUBCASE; **
C ** THEN FORM THE RESPONSE VARIABLE **
C ** AND THE FACTORS. **
C *********************************************
C
ISTEPN='7'
IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(NUMFAC.GE.3)N34=NIV(3)
C
IF(NUMFAC.LE.2)NLEFT=NEXACT
IF(NUMFAC.GE.3)NLEFT=N34
C
IF(ICASEQ.EQ.'FULL')GOTO610
IF(ICASEQ.EQ.'SUBS')GOTO620
IF(ICASEQ.EQ.'FOR')GOTO630
C
610 CONTINUE
DO615I=1,NLEFT
ISUB(I)=1
615 CONTINUE
NQ=NLEFT
GOTO650
C
620 CONTINUE
NIOLD=NLEFT
CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
NQ=NIOLD
GOTO650
C
630 CONTINUE
NIOLD=NLEFT
CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
NQ=NFOR
GOTO650
C
650 CONTINUE
C
IF(NUMFAC.LE.2)GOTO699
J=0
DO670I=1,NLEFT
J=J+1
C
IFAC=3
ICOLR=ICOLIV(IFAC)
IJ=MAXN*(ICOLR-1)+I
IF(ICOLR.LE.MAXCOL)F3(J)=V(IJ)
IF(ICOLR.EQ.MAXCP1)F3(J)=PRED(I)
IF(ICOLR.EQ.MAXCP2)F3(J)=RES(I)
IF(ICOLR.EQ.MAXCP3)F3(J)=YPLOT(I)
IF(ICOLR.EQ.MAXCP4)F3(J)=XPLOT(I)
IF(ICOLR.EQ.MAXCP5)F3(J)=X2PLOT(I)
IF(ICOLR.EQ.MAXCP6)F3(J)=TAGPLO(I)
C
IFAC=4
ICOLR=ICOLIV(IFAC)
IJ=MAXN*(ICOLR-1)+I
IF(ICOLR.LE.MAXCOL)F4(J)=V(IJ)
IF(ICOLR.EQ.MAXCP1)F4(J)=PRED(I)
IF(ICOLR.EQ.MAXCP2)F4(J)=RES(I)
IF(ICOLR.EQ.MAXCP3)F4(J)=YPLOT(I)
IF(ICOLR.EQ.MAXCP4)F4(J)=XPLOT(I)
IF(ICOLR.EQ.MAXCP5)F4(J)=X2PLOT(I)
IF(ICOLR.EQ.MAXCP6)F4(J)=TAGPLO(I)
C
670 CONTINUE
C
699 CONTINUE
C
C ****************************************
C ** STEP 8-- **
C ** DETERMINE THE DEGREES **
C ** OF THE NUMERATOR AND DENOMINATOR **
C ****************************************
C
ISTEPN='8'
IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
DO700J=1,IWIDTH
J2=J
IF(IANS(J).EQ.'/')GOTO710
700 CONTINUE
C
WRITE(ICOUT,701)
701 FORMAT('***** ERROR IN DPEXAC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,702)
702 FORMAT(' NO / FOUND ON ENTERED COMMAND LINE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,703)
703 FORMAT(' THEREFORE, DEGREE OF NUMERATOR UNKNOWN, AND')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,704)
704 FORMAT(' DEGREE OF DENOMINATOR UNKNOWN.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,705)
705 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,706)(IANS(I),I=1,IWIDTH)
706 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
710 CONTINUE
J2M1=J2-1
J2M2=J2-2
IF(J2M1.GE.1)GOTO720
C
WRITE(ICOUT,711)
711 FORMAT('***** ERROR IN DPEXAC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,712)
712 FORMAT(' THE LOCATED / WAS FOUND AS THE FIRST')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,713)
713 FORMAT(' CHARACTER OF THE ENTERED COMMAND LINE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,714)
714 FORMAT(' THEREFORE, DEGREE OF NUMERATOR UNKNOWN.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,715)
715 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,716)(IANS(I),I=1,IWIDTH)
716 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
720 CONTINUE
ICH1B=IANS(J2M1)
IF(J2M1.GE.2)ICH2B=IANS(J2M2)
IF(J2M1.EQ.1)ICH2B=' '
C
IF(ICH2B.EQ.' '.AND.ICH1B.EQ.'0')GOTO750
IF(ICH2B.EQ.' '.AND.ICH1B.EQ.'1')GOTO751
IF(ICH2B.EQ.' '.AND.ICH1B.EQ.'2')GOTO752
IF(ICH2B.EQ.' '.AND.ICH1B.EQ.'3')GOTO753
IF(ICH2B.EQ.' '.AND.ICH1B.EQ.'4')GOTO754
IF(ICH2B.EQ.' '.AND.ICH1B.EQ.'5')GOTO755
IF(ICH2B.EQ.' '.AND.ICH1B.EQ.'6')GOTO756
IF(ICH2B.EQ.' '.AND.ICH1B.EQ.'7')GOTO757
IF(ICH2B.EQ.' '.AND.ICH1B.EQ.'8')GOTO758
IF(ICH2B.EQ.' '.AND.ICH1B.EQ.'9')GOTO759
IF(ICH2B.EQ.'1'.AND.ICH1B.EQ.'0')GOTO760
IF(ICH2B.EQ.'1'.AND.ICH1B.EQ.'1')GOTO761
IF(ICH2B.EQ.'1'.AND.ICH1B.EQ.'2')GOTO762
IF(ICH2B.EQ.'1'.AND.ICH1B.EQ.'3')GOTO763
IF(ICH2B.EQ.'1'.AND.ICH1B.EQ.'4')GOTO764
IF(ICH2B.EQ.'1'.AND.ICH1B.EQ.'5')GOTO765
IF(ICH2B.EQ.'1'.AND.ICH1B.EQ.'6')GOTO766
IF(ICH2B.EQ.'1'.AND.ICH1B.EQ.'7')GOTO767
IF(ICH2B.EQ.'1'.AND.ICH1B.EQ.'8')GOTO768
IF(ICH2B.EQ.'1'.AND.ICH1B.EQ.'9')GOTO769
IF(ICH2B.EQ.'2'.AND.ICH1B.EQ.'0')GOTO770
CCCCC THE FOLLOWING 10 LINES WERE ADDED NOVEMBER 1993
IF(ICH2B.EQ.'0'.AND.ICH1B.EQ.' ')GOTO750
IF(ICH2B.EQ.'1'.AND.ICH1B.EQ.' ')GOTO751
IF(ICH2B.EQ.'2'.AND.ICH1B.EQ.' ')GOTO752
IF(ICH2B.EQ.'3'.AND.ICH1B.EQ.' ')GOTO753
IF(ICH2B.EQ.'4'.AND.ICH1B.EQ.' ')GOTO754
IF(ICH2B.EQ.'5'.AND.ICH1B.EQ.' ')GOTO755
IF(ICH2B.EQ.'6'.AND.ICH1B.EQ.' ')GOTO756
IF(ICH2B.EQ.'7'.AND.ICH1B.EQ.' ')GOTO757
IF(ICH2B.EQ.'8'.AND.ICH1B.EQ.' ')GOTO758
IF(ICH2B.EQ.'9'.AND.ICH1B.EQ.' ')GOTO759
C
WRITE(ICOUT,721)
721 FORMAT('***** ERROR IN DPEXAC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,722)
722 FORMAT(' FOR AN EXACT RATIONAL FUNCTION FIT,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,723)
723 FORMAT(' THE DEGREE FOR THE NUMERATOR MUST BE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,724)
724 FORMAT(' BETWEEN 0 AND 20 (INCLUSIVELY);')
CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 2 LINES WERE CHANGED NOVEMBER 1993
WRITE(ICOUT,725)ICH1B,ICH2B
725 FORMAT(' SUCH WAS NOT THE CASE HERE.',A1,',',A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,726)
726 FORMAT(' (REMINDER--THERE SHOULD BE NO BLANK')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,727)
727 FORMAT(' BETWEEN THE DEGREE NUMBER AND THE /).')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,728)
728 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,729)(IANS(I),I=1,IWIDTH)
729 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
750 IDEGN=0
GOTO799
751 IDEGN=1
GOTO799
752 IDEGN=2
GOTO799
753 IDEGN=3
GOTO799
754 IDEGN=4
GOTO799
755 IDEGN=5
GOTO799
756 IDEGN=6
GOTO799
757 IDEGN=7
GOTO799
758 IDEGN=8
GOTO799
759 IDEGN=9
GOTO799
760 IDEGN=10
GOTO799
761 IDEGN=11
GOTO799
762 IDEGN=12
GOTO799
763 IDEGN=13
GOTO799
764 IDEGN=14
GOTO799
765 IDEGN=15
GOTO799
766 IDEGN=16
GOTO799
767 IDEGN=17
GOTO799
768 IDEGN=18
GOTO799
769 IDEGN=19
GOTO799
770 IDEGN=20
GOTO799
799 CONTINUE
C
J2P1=J2+1
J2P2=J2+2
IF(J2P1.LE.IWIDTH)GOTO820
C
WRITE(ICOUT,811)
811 FORMAT('***** ERROR IN DPEXAC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,812)
812 FORMAT(' THE LOCATED / WAS FOUND AS THE LAST')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,813)
813 FORMAT(' CHARACTER OF THE ENTERED COMMAND LINE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,814)
814 FORMAT(' THEREFORE, DEGREE OF DENOMINATOR UNKNOWN.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,815)
815 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,816)(IANS(I),I=1,IWIDTH)
816 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
820 CONTINUE
ICH1A=IANS(J2P1)
IF(J2P1.GE.2)ICH2A=IANS(J2P2)
IF(J2P1.EQ.1)ICH2A=' '
C
IF(ICH1A.EQ.'0'.AND.ICH2A.EQ.' ')GOTO850
IF(ICH1A.EQ.'1'.AND.ICH2A.EQ.' ')GOTO851
IF(ICH1A.EQ.'2'.AND.ICH2A.EQ.' ')GOTO852
IF(ICH1A.EQ.'3'.AND.ICH2A.EQ.' ')GOTO853
IF(ICH1A.EQ.'4'.AND.ICH2A.EQ.' ')GOTO854
IF(ICH1A.EQ.'5'.AND.ICH2A.EQ.' ')GOTO855
IF(ICH1A.EQ.'6'.AND.ICH2A.EQ.' ')GOTO856
IF(ICH1A.EQ.'7'.AND.ICH2A.EQ.' ')GOTO857
IF(ICH1A.EQ.'8'.AND.ICH2A.EQ.' ')GOTO858
IF(ICH1A.EQ.'9'.AND.ICH2A.EQ.' ')GOTO859
IF(ICH1A.EQ.'1'.AND.ICH2A.EQ.'0')GOTO860
IF(ICH1A.EQ.'1'.AND.ICH2A.EQ.'1')GOTO861
IF(ICH1A.EQ.'1'.AND.ICH2A.EQ.'2')GOTO862
IF(ICH1A.EQ.'1'.AND.ICH2A.EQ.'3')GOTO863
IF(ICH1A.EQ.'1'.AND.ICH2A.EQ.'4')GOTO864
IF(ICH1A.EQ.'1'.AND.ICH2A.EQ.'5')GOTO865
IF(ICH1A.EQ.'1'.AND.ICH2A.EQ.'6')GOTO866
IF(ICH1A.EQ.'1'.AND.ICH2A.EQ.'7')GOTO867
IF(ICH1A.EQ.'1'.AND.ICH2A.EQ.'8')GOTO868
IF(ICH1A.EQ.'1'.AND.ICH2A.EQ.'9')GOTO869
IF(ICH1A.EQ.'2'.AND.ICH2A.EQ.'0')GOTO870
CCCCC THE FOLLOWING 10 LINES WERE ADDED NOVEMBER 1993
IF(ICH1A.EQ.' '.AND.ICH2A.EQ.'0')GOTO850
IF(ICH1A.EQ.' '.AND.ICH2A.EQ.'1')GOTO851
IF(ICH1A.EQ.' '.AND.ICH2A.EQ.'2')GOTO852
IF(ICH1A.EQ.' '.AND.ICH2A.EQ.'3')GOTO853
IF(ICH1A.EQ.' '.AND.ICH2A.EQ.'4')GOTO854
IF(ICH1A.EQ.' '.AND.ICH2A.EQ.'5')GOTO855
IF(ICH1A.EQ.' '.AND.ICH2A.EQ.'6')GOTO856
IF(ICH1A.EQ.' '.AND.ICH2A.EQ.'7')GOTO857
IF(ICH1A.EQ.' '.AND.ICH2A.EQ.'8')GOTO858
IF(ICH1A.EQ.' '.AND.ICH2A.EQ.'9')GOTO859
C
WRITE(ICOUT,821)
821 FORMAT('***** ERROR IN DPEXAC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,822)
822 FORMAT(' FOR AN EXACT RATIONAL FUNCTION FIT,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,823)
823 FORMAT(' THE DEGREE FOR THE DENOMINATOR MUST BE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,824)
824 FORMAT(' BETWEEN 0 AND 20 (INCLUSIVELY);')
CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 2 LINES WERE CHANGED NOVEMBER 1993
WRITE(ICOUT,825)ICH1A,ICH2A
825 FORMAT(' SUCH WAS NOT THE CASE HERE.',A1,',',A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,826)
826 FORMAT(' (REMINDER--THERE SHOULD BE NO BLANK')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,827)
827 FORMAT(' BETWEEN THE DEGREE NUMBER AND THE /).')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,828)
828 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,829)(IANS(I),I=1,IWIDTH)
829 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
850 IDEGD=0
GOTO899
851 IDEGD=1
GOTO899
852 IDEGD=2
GOTO899
853 IDEGD=3
GOTO899
854 IDEGD=4
GOTO899
855 IDEGD=5
GOTO899
856 IDEGD=6
GOTO899
857 IDEGD=7
GOTO899
858 IDEGD=8
GOTO899
859 IDEGD=9
GOTO899
860 IDEGD=10
GOTO899
861 IDEGD=11
GOTO899
862 IDEGD=12
GOTO899
863 IDEGD=13
GOTO899
864 IDEGD=14
GOTO899
865 IDEGD=15
GOTO899
866 IDEGD=16
GOTO899
867 IDEGD=17
GOTO899
868 IDEGD=18
GOTO899
869 IDEGD=19
GOTO899
870 IDEGD=20
GOTO899
899 CONTINUE
C
K1=IDEGN+1
K2=IDEGD+1
K=K1+K2
KM1=K-1
C
IF(NEXACT.EQ.KM1)GOTO920
WRITE(ICOUT,901)
901 FORMAT('***** ERROR IN DPEXAC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,902)
902 FORMAT(' FOR AN EXACT RATIONAL FUNCTION FIT,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,903)
903 FORMAT(' THE NUMBER OF ELEMENTS IN THE FIRST VARIABLE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,904)
904 FORMAT(' (THAT IS, THE NUMBER OF POINTS TO BE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,905)
905 FORMAT(' EXACTLY FITTED) MUST =')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,906)
906 FORMAT(' THE NUMBER OF COEFFICIENTS TO BE ESTIMATED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,907)
907 FORMAT(' (THAT IS, MUST = (DEGREE OF NUMERATOR + 1) +')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,908)
908 FORMAT(' (DEGREE OF DENOMINATOR + 1) - 1 );')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,909)
909 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,910)NEXACT
910 FORMAT(' NUMBER OF FIT POINTS FROM FIRST VARIABLE = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,911)KM1
911 FORMAT(' NUMBER OF ESTIMATED COEFFICIENTS = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,912)IDEGN
912 FORMAT(' DEGREE OF NUMERATOR = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,913)IDEGD
913 FORMAT(' DEGREE OF DENOMINATOR = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,914)
914 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,915)(IANS(I),I=1,IWIDTH)
915 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
920 CONTINUE
DO930I=1,K
ITYPE(I)='U'
B1(I)=999.0
930 CONTINUE
K1P1=K1+1
ITYPE(K1P1)='K'
B1(K1P1)=1.0
C
C ************************************
C ** STEP 9-- **
C ** CARRY OUT THE EXACT RATIONAL **
C ** FUNCTION FIT. **
C ************************************
C
ISTEPN='9'
IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IBUGA2.EQ.'OFF')GOTO689
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,681)
681 FORMAT('***** FROM DPEXAC, AS WE ARE ABOUT TO CALL DPEXA2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,682)NEXACT,MAXN,K1,K2,NUMFAC,N34,NLEFT
682 FORMAT('NEXACT,MAXN,K1,K2,NUMFAC,N34,NLEFT = ',7I8)
CALL DPWRST('XXX','BUG ')
DO685I=1,NEXACT
WRITE(ICOUT,686)I,F1(I),F2(I)
686 FORMAT('I,F1(I),F2(I) = ',I8,2E15.7)
CALL DPWRST('XXX','BUG ')
685 CONTINUE
CCCCC IBUGA3='ABCD'
WRITE(ICOUT,687)IBUGA3
687 FORMAT('IBUGA3 = ',A4)
CALL DPWRST('XXX','BUG ')
689 CONTINUE
C
CALL DPEXA2(F1,F2,NEXACT,ITYPE,B1,K1,K2,IBUGA3,B2,IERROR)
C
C ***************************************************
C ** STEP 10-- **
C ** IF A SECOND SET OF POINTS EXISTS **
C ** (THAT IS, IF VARIABLES 3 AND 4 **
C ** HAVE BEEN SPECIFIED), **
C ** THEN COMPUTE PREDICTED VALUES AND RESIDUALS **
C ** FOR THIS SECOND SET OF POINTS **
C ** BASED ON THE EXACT-FIT COEFFICIENTS **
C ** DERIVED FROM THE FIRST SET OF POINTS **
C ** (THAT IS, FROM VARIABLES 1 AND 2). **
C ***************************************************
C
ISTEPN='10'
IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CCCCC DO980I=1,NLEFT
CCCCC W(I)=1.0
CC980 CONTINUE
C
DO1000I=1,NLEFT
C
J=1
ANUM=B2(J)
IF(K1.LE.1)GOTO1150
IF(NUMFAC.EQ.2)GOTO1120
IF(NUMFAC.EQ.4)GOTO1140
GOTO1150
C
1120 CONTINUE
DO1125J=2,K1
ANUM=ANUM+B2(J)*F2(I)**(J-1)
1125 CONTINUE
GOTO1150
C
1140 CONTINUE
DO1145J=2,K1
ANUM=ANUM+B2(J)*F4(I)**(J-1)
1145 CONTINUE
GOTO1150
C
1150 CONTINUE
C
J=1
K1PJ=K1+J
ADEN=B2(K1PJ)
IF(K2.LE.1)GOTO1250
IF(NUMFAC.EQ.2)GOTO1220
IF(NUMFAC.EQ.4)GOTO1240
GOTO1250
C
1220 CONTINUE
DO1225J=2,K2
K1PJ=K1+J
ADEN=ADEN+B2(K1PJ)*F2(I)**(J-1)
1225 CONTINUE
GOTO1250
C
1240 CONTINUE
DO1245J=2,K2
K1PJ=K1+J
ADEN=ADEN+B2(K1PJ)*F4(I)**(J-1)
1245 CONTINUE
GOTO1250
C
1250 CONTINUE
C
PRED2(I)=ANUM/ADEN
IF(NUMFAC.EQ.2)RES2(I)=F1(I)-PRED2(I)
IF(NUMFAC.EQ.4)RES2(I)=F3(I)-PRED2(I)
1000 CONTINUE
C
IF(IBUGA2.EQ.'OFF')GOTO1390
DO1380I=1,NLEFT
WRITE(ICOUT,1381)I,F1(I),F2(I),F3(I),F4(I),PRED2(I),RES2(I)
1381 FORMAT('I,F1(I),F2(I),F3(I),F4(I),PRED2(I),RES2(I) = ',
1I8,6E10.3)
CALL DPWRST('XXX','BUG ')
1380 CONTINUE
1390 CONTINUE
C
SUM=0.0
DO1500I=1,NLEFT
SUM=SUM+RES2(I)**2
1500 CONTINUE
RESSS=SUM
RESSD=0.0
IRESDF=NLEFT-KM1
RESDF=IRESDF
IF(IRESDF.LE.0)GOTO1510
RESV=RESSS/RESDF
IF(RESV.GT.0.0)RESSD=SQRT(RESV)
IF(RESV.LE.0.0)RESSD=0.0
1510 CONTINUE
C
ANLEFT=NLEFT
SUM=0.0
DO1600I=1,NLEFT
SUM=SUM+ABS(RES2(I))
1600 CONTINUE
RESMA=SUM/ANLEFT
C
AMAXR=RES2(1)
AMINR=RES2(1)
DO1700I=1,NLEFT
IF(RES2(I).GT.AMAXR)AMAXR=RES2(I)
IF(RES2(I).LT.AMINR)AMINR=RES2(I)
1700 CONTINUE
ABSMAX=ABS(AMAXR)
ABSMIN=ABS(AMINR)
ABSMM=ABSMAX
IF(ABSMIN.GT.ABSMAX)ABSMM=ABSMIN
C
IF(NUMFAC.EQ.2)GOTO1999
IF(IPRINT.EQ.'OFF')GOTO1999
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1901)
1901 FORMAT(' APPLICATION OF EXACT-FIT COEFFICIENTS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1902)
1902 FORMAT(' TO SECOND PAIR OF VARIABLES--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1903)NLEFT
1903 FORMAT(' NUMBER OF POINTS IN SECOND SET = ',
1I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1904)KM1
1904 FORMAT(' NUMBER OF ESTIMATED COEFFICIENTS = ',
1I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1905)IRESDF
1905 FORMAT(' RESIDUAL DEGREES OF FREEDOM = ',
1I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1911)RESSS
1911 FORMAT(' RESIDUAL SUM OF SQUARES = ',
1E15.8)
CALL DPWRST('XXX','BUG ')
IF(IRESDF.GE.1)WRITE(ICOUT,1912)RESSD
1912 FORMAT(' RESIDUAL STANDARD DEVIATION (DENOM=N-P) = ',
1E15.8)
IF(IRESDF.GE.1)CALL DPWRST('XXX','BUG ')
IF(IRESDF.LE.0)WRITE(ICOUT,1913)RESSD
1913 FORMAT(' RESIDUAL STANDARD DEVIATION = ',
1'UNDEFINED (SINCE NON-POSITIVE DEGREES OF FREEDOM)')
IF(IRESDF.LE.0)CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1914)RESMA
1914 FORMAT(' AVERAGE ABSOLUTE RESIDUAL (DENOM=N) = ',
1E15.8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1915)AMAXR
1915 FORMAT(' LARGEST (IN MAGNITUDE) POSITIVE RESIDUAL = ',
1E15.8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1916)AMINR
1916 FORMAT(' LARGEST (IN MAGNITUDE) NEGATIVE RESIDUAL = ',
1E15.8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1917)ABSMM
1917 FORMAT(' LARGEST (IN MAGNITUDE) ABSOLUTE RESIDUAL = ',
1E15.8)
CALL DPWRST('XXX','BUG ')
1999 CONTINUE
C
C ***************************************
C ** STEP 11-- **
C ** UPDATE DATAPLOT INTERNAL TABLES **
C ***************************************
C
7000 CONTINUE
C
ISTEPN='11'
IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
NLEFT=NLEFT
C
ICOLPR=MAXCP1
ICOLRE=MAXCP2
C
CCCCC IREPU='ON' MARCH 1988
CCCCC IRESU='ON' MARCH 1988
C THE FOLLOWING CORRECTION WAS BASED ON
C COMMENTS FROM DAVE EVANS MARCH 1988
CCCCC IREPU='ON'
IREPU='OFF'
REPSD=(-999.99)
REPDF=(-999.99)
ALFCDF=(-999.99)
C
IRESU='ON'
C
CALL UPDAPR(ICOLPR,ICOLRE,PRED2,RES2,PRED,RES,ISUB,NLEFT,
1IREPU,REPSD,REPDF,IRESU,RESSD,RESDF,ALFCDF,
1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1IANS,IWIDTH,ILOCN,IBUGA3,IERROR)
C
L=0
DO7600J=1,K1
L=L+1
IH2=' '
IF(J.EQ.1)IH='A0'
IF(J.EQ.2)IH='A1'
IF(J.EQ.3)IH='A2'
IF(J.EQ.4)IH='A3'
IF(J.EQ.5)IH='A4'
IF(J.LE.5)GOTO7640
IF(J.EQ.6)IH='A5'
IF(J.EQ.7)IH='A6'
IF(J.EQ.8)IH='A7'
IF(J.EQ.9)IH='A8'
IF(J.EQ.10)IH='A9'
IF(J.LE.10)GOTO7640
IF(J.EQ.11)IH='A10'
IF(J.EQ.12)IH='A11'
IF(J.EQ.13)IH='A12'
IF(J.EQ.14)IH='A13'
IF(J.EQ.15)IH='A14'
IF(J.LE.15)GOTO7640
IF(J.EQ.16)IH='A15'
IF(J.EQ.17)IH='A16'
IF(J.EQ.18)IH='A17'
IF(J.EQ.19)IH='A18'
IF(J.EQ.20)IH='A19'
IF(J.LE.20)GOTO7640
IF(J.EQ.21)IH='A20'
C
7640 CONTINUE
DO7650I=1,NUMNAM
I2=I
IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND.
1IUSE(I).EQ.'P')GOTO7680
7650 CONTINUE
IF(NUMNAM.LT.MAXNAM)GOTO7670
WRITE(ICOUT,7651)
7651 FORMAT('***** ERROR IN DPEXAC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7652)
7652 FORMAT(' THE TOTAL NUMBER OF (VARIABLE + PARAMETER)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7653)MAXNAM
7653 FORMAT(' NAMES MUST BE AT MOST ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7654)
7654 FORMAT(' SUCH WAS NOT THE CASE HERE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7655)
7655 FORMAT(' THE MAXIMUM ALLOWABLE NUMBER OF NAMES')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7656)
7656 FORMAT(' WAS JUST EXCEEDED.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7657)
7657 FORMAT(' SUGGESTED ACTION--ENTER STAT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7658)
7658 FORMAT(' TO DETERMINE THE IMPORTANT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7659)
7659 FORMAT(' (VERSUS UNIMPORTANT) VARIABLES')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7660)
7660 FORMAT(' AND PARAMETERS, AND THEN REUSE SOME')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7661)
7661 FORMAT(' OF THE NAMES.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7662)
7662 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,7663)(IANS(I),I=1,IWIDTH)
7663 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
7670 CONTINUE
NUMNAM=NUMNAM+1
ILOC=NUMNAM
IHNAME(ILOC)=IH
IHNAM2(ILOC)=IH2
IUSE(ILOC)='P'
VALUE(ILOC)=B2(L)
GOTO7600
C
7680 CONTINUE
VALUE(I2)=B2(L)
GOTO7600
C
7600 CONTINUE
C
DO7700J=1,K2
L=L+1
IH2=' '
IF(J.EQ.1)IH='B0'
IF(J.EQ.2)IH='B1'
IF(J.EQ.3)IH='B2'
IF(J.EQ.4)IH='B3'
IF(J.EQ.5)IH='B4'
IF(J.LE.5)GOTO7740
IF(J.EQ.6)IH='B5'
IF(J.EQ.7)IH='B6'
IF(J.EQ.8)IH='B7'
IF(J.EQ.9)IH='B8'
IF(J.EQ.10)IH='B9'
IF(J.LE.10)GOTO7740
IF(J.EQ.11)IH='B10'
IF(J.EQ.12)IH='B11'
IF(J.EQ.13)IH='B12'
IF(J.EQ.14)IH='B13'
IF(J.EQ.15)IH='B14'
IF(J.LE.15)GOTO7740
IF(J.EQ.16)IH='B15'
IF(J.EQ.17)IH='B16'
IF(J.EQ.18)IH='B17'
IF(J.EQ.19)IH='B18'
IF(J.EQ.20)IH='B19'
IF(J.LE.20)GOTO7740
IF(J.EQ.21)IH='B20'
C
7740 CONTINUE
DO7750I=1,NUMNAM
I2=I
IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND.
1IUSE(I).EQ.'P')GOTO7780
7750 CONTINUE
IF(NUMNAM.LT.MAXNAM)GOTO7770
WRITE(ICOUT,7751)
7751 FORMAT('***** ERROR IN DPEXAC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7752)
7752 FORMAT(' THE TOTAL NUMBER OF (VARIABLE + PARAMETER)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7753)MAXNAM
7753 FORMAT(' NAMES MUST BE AT MOST ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7754)
7754 FORMAT(' SUCH WAS NOT THE CASE HERE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7755)
7755 FORMAT(' THE MAXIMUM ALLOWABLE NUMBER OF NAMES')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7756)
7756 FORMAT(' WAS JUST EXCEEDED.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7757)
7757 FORMAT(' SUGGESTED ACTION--ENTER STAT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7758)
7758 FORMAT(' TO DETERMINE THE IMPORTANT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7759)
7759 FORMAT(' (VERSUS UNIMPORTANT) VARIABLES')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7760)
7760 FORMAT(' AND PARAMETERS, AND THEN REUSE SOME')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7761)
7761 FORMAT(' OF THE NAMES.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,7762)
7762 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,7763)(IANS(I),I=1,IWIDTH)
7763 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
7770 CONTINUE
NUMNAM=NUMNAM+1
ILOC=NUMNAM
IHNAME(ILOC)=IH
IHNAM2(ILOC)=IH2
IUSE(ILOC)='P'
VALUE(ILOC)=B2(L)
GOTO7700
C
7780 CONTINUE
VALUE(I2)=B2(L)
GOTO7700
C
7700 CONTINUE
C
C ***************************************
C ** STEP 12-- **
C ** ENTER THE FORTRAN EXPRESSION **
C ** FOR THE RATIONAL FUNCTION MODEL **
C ** INTO MODEL(.) **
C ** FOR FURTHER USE **
C ** VIA THE FIT COMMAND. **
C ***************************************
C
8000 CONTINUE
C
ISTEPN='12'
IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
I=0
I=I+1
MODEL(I)='Y'
I=I+1
MODEL(I)='='
I=I+1
MODEL(I)='('
C
DO8100J=1,K1
IF(J.EQ.1)GOTO8110
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)='+'
8110 CONTINUE
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)='A'
IF(J.EQ.1)ICH='0'
IF(J.EQ.2)ICH='1'
IF(J.EQ.3)ICH='2'
IF(J.EQ.4)ICH='3'
IF(J.EQ.5)ICH='4'
IF(J.LE.5)GOTO8120
IF(J.EQ.6)ICH='5'
IF(J.EQ.7)ICH='6'
IF(J.EQ.8)ICH='7'
IF(J.EQ.9)ICH='8'
IF(J.EQ.10)ICH='9'
IF(J.LE.10)GOTO8120
IF(J.EQ.11)ICH='0'
IF(J.EQ.12)ICH='1'
IF(J.EQ.13)ICH='2'
IF(J.EQ.14)ICH='3'
IF(J.EQ.15)ICH='4'
IF(J.LE.15)GOTO8120
IF(J.EQ.16)ICH='5'
IF(J.EQ.17)ICH='6'
IF(J.EQ.18)ICH='7'
IF(J.EQ.19)ICH='8'
IF(J.EQ.20)ICH='9'
IF(J.LE.20)GOTO8120
IF(J.EQ.21)ICH='0'
C
8120 CONTINUE
IF(J.LE.20)GOTO8130
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)='2'
8130 CONTINUE
IF(J.LE.10)GOTO8140
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)='1'
8140 CONTINUE
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)=ICH
IF(J.LE.1)GOTO8100
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)='*'
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)='X'
IF(J.LE.2)GOTO8100
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)='*'
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)='*'
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)='ICH'
8100 CONTINUE
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)=')'
C
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)='/'
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)='('
C
DO8200J=1,K2
IF(J.EQ.1)GOTO8210
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)='+'
8210 CONTINUE
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)='B'
IF(J.EQ.1)ICH='0'
IF(J.EQ.2)ICH='1'
IF(J.EQ.3)ICH='2'
IF(J.EQ.4)ICH='3'
IF(J.EQ.5)ICH='4'
IF(J.LE.5)GOTO8220
IF(J.EQ.6)ICH='5'
IF(J.EQ.7)ICH='6'
IF(J.EQ.8)ICH='7'
IF(J.EQ.9)ICH='8'
IF(J.EQ.10)ICH='9'
IF(J.LE.10)GOTO8220
IF(J.EQ.11)ICH='0'
IF(J.EQ.12)ICH='1'
IF(J.EQ.13)ICH='2'
IF(J.EQ.14)ICH='3'
IF(J.EQ.15)ICH='4'
IF(J.LE.15)GOTO8220
IF(J.EQ.16)ICH='5'
IF(J.EQ.17)ICH='6'
IF(J.EQ.18)ICH='7'
IF(J.EQ.19)ICH='8'
IF(J.EQ.20)ICH='9'
IF(J.LE.20)GOTO8220
IF(J.EQ.21)ICH='0'
C
8220 CONTINUE
IF(J.LE.20)GOTO8230
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)='2'
8230 CONTINUE
IF(J.LE.10)GOTO8240
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)='1'
8240 CONTINUE
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)=ICH
IF(J.LE.1)GOTO8200
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)='*'
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)='X'
IF(J.LE.2)GOTO8200
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)='*'
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)='*'
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)='ICH'
8200 CONTINUE
I=I+1
IF(I.GT.80)GOTO8150
MODEL(I)=')'
NUMCHA=I
GOTO8290
C
8150 CONTINUE
WRITE(ICOUT,8251)
8251 FORMAT('***** NOTE FROM DPEXAC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8252)
8252 FORMAT(' THE FORTRAN EXPRESSION FOR THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8253)
8253 FORMAT(' RATIONAL FUNCTION THAT WAS BEING')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8254)
8254 FORMAT(' AUTOMATICALLY ENTERED INTO AN')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8255)
8255 FORMAT(' INTERNAL DATAPLOT ARRAY NAMED MODEL(.)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8256)
8256 FORMAT(' WAS NOT COMPLETED DUE TO THE FACT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8257)
8257 FORMAT(' THAT THE FORTRAN EXPRESSION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8258)
8258 FORMAT(' FOR THIS RATIONAL FUNCTION IS IN EXCESS OF')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8259)
8259 FORMAT(' THE ARRAY LIMIT OF 80 CHARACTERS.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8260)
8260 FORMAT(' (NOTE--THIS DOES NOT AFFECT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8261)
8261 FORMAT(' THE VALIDITY OF THE PRECEEDING')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8262)
8262 FORMAT(' EXACT RATIONAL FUNCTION FIT.)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8263)
8263 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,8264)(IANS(I),I=1,IWIDTH)
8264 FORMAT(' ',80A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
C
8290 CONTINUE
C
GOTO9000
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGA2.EQ.'OFF')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPEXAC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGA2,IBUGA3
9012 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)IBUGQ
9013 FORMAT('IBUGQ = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)NEXACT,N34,K1,K2,NLEFT
9014 FORMAT('NEXACT,N34,K1,K2,NLEFT = ',5I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)ICASEQ
9015 FORMAT('ICASEQ = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9016)IFOUND,IERROR
9016 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPEXIN(IHARG,IARGT,IARG,NUMARG,ISTART,ISTOP,
1MININT,MAXINT,
1ITAB,NTAB,MAXTAB,
1IBUGS2,ISUBRO,IERROR)
C
C PURPOSE--SCAN THE ARGUMENTS IN IHARG(.)
C AND EXTRACT THE INTEGER SEQUENCES
C ALLOWING FOR THE USE OF THE TO CONNECTOR
C TO IMPLY ALL INTERMEDIATE INTEGERS.
C EXAMPLE--12 9 4 2 (IN THE INPUT VECTOR IHARG(.))
C WOULD BECOME
C 12 9 4 2 (IN THE OUTPUT VECTOR ITAB(.))
C EXAMPLE--12 TO 9 6 4 TO 2 (IN THE INPUT VECTOR IHARG(.))
C WOULD BECOME
C 12 11 10 9 6 4 3 2 (IN THE OUTPUT VECTOR ITAB(.))
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/7
C ORIGINAL VERSION--APRIL 1986.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IHARG
CHARACTER*4 IARGT
C
DIMENSION IHARG(*)
DIMENSION IARGT(*)
DIMENSION IARG(*)
DIMENSION ITAB(*)
C
CHARACTER*4 IBUGS2
CHARACTER*4 ISUBRO
CHARACTER*4 IERROR
C
CHARACTER*4 ITOSW
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='DPEX'
ISUBN2='IN '
C
IERROR='NO'
C
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'EXIN')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPEXIN--')
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)NUMARG
54 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NUMARG.LE.0)GOTO59
DO55I=1,NUMARG
WRITE(ICOUT,56)I,IHARG(I),IARGT(I),IARG(I)
56 FORMAT('I,IHARG(I),IARGT(I),IARG(I) = ',I8,2X,A4,2X,A4,I8)
CALL DPWRST('XXX','BUG ')
55 CONTINUE
59 CONTINUE
WRITE(ICOUT,61)ISTART,ISTOP
61 FORMAT('ISTART,ISTOP = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,62)MININT,MAXINT
62 FORMAT('MININT,MAXINT = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,63)MAXTAB
63 FORMAT('MAXTAB = ',I8)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C **************************************
C ** STEP 11-- **
C ** INITIALIZE THE OUTPUT VARIABLES **
C **************************************
C
ISTEPN='11'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXIN')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
NTAB=0
DO1100I=1,MAXTAB
ITAB(I)=(-999)
1100 CONTINUE
C
IF(NUMARG.LE.0)GOTO9000
C
C *******************************************
C ** STEP 12-- **
C ** CHECK THE INPUT ARGUMENTS **
C *******************************************
C
ISTEPN='12'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXIN')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(ISTART.GE.1.AND.ISTOP.GE.1.AND.
1 ISTART.LE.NUMARG.AND.ISTOP.LE.NUMARG)GOTO1219
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1211)
1211 FORMAT('***** ERROR IN DPEXIN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1212)
1212 FORMAT(' ISTART OR ISTOP IS < 1 OR > NUMARG .')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1213)ISTART
1213 FORMAT(' ISTART = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1214)ISTOP
1214 FORMAT(' ISTOP = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1215)NUMARG
1215 FORMAT(' NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
1219 CONTINUE
C
IF(ISTART.LE.ISTOP)GOTO1229
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1221)
1221 FORMAT('***** ERROR IN DPEXIN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1222)
1222 FORMAT(' ISTART IS GREATER THAN ISTOP')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1223)ISTART
1223 FORMAT(' ISTART = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1224)ISTOP
1224 FORMAT(' ISTOP = ',I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
1229 CONTINUE
C
IF(MININT.GE.1.AND.MAXINT.GE.1.AND.
1 MININT.LE.MAXTAB.AND.MAXINT.LE.MAXTAB)GOTO1239
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1231)
1231 FORMAT('***** ERROR IN DPEXIN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1232)
1232 FORMAT(' MININT OR MAXINT IS < 1 OR > MAXTAB .')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1233)MININT
1233 FORMAT(' MININT = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1234)MAXINT
1234 FORMAT(' MAXINT = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1235)MAXTAB
1235 FORMAT(' MAXTAB = ',I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
1239 CONTINUE
C
IF(MININT.LE.MAXINT)GOTO1249
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1241)
1241 FORMAT('***** ERROR IN DPEXIN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1242)
1242 FORMAT(' MININT IS GREATER THAN MAXINT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1243)MININT
1243 FORMAT(' MININT = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1244)MAXINT
1244 FORMAT(' MAXINT = ',I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
1249 CONTINUE
C
DO1250I=ISTART,ISTOP
I2=I
IF(IARGT(I).EQ.'NUMB')GOTO1250
IF(IHARG(I).EQ.'TO ')GOTO1250
GOTO1260
1250 CONTINUE
GOTO1269
C
1260 CONTINUE
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1261)
1261 FORMAT('***** ERROR IN DPEXIN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1262)
1262 FORMAT(' AN ERROR OCCURRED IN PARSING A SEQUENCE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1263)
1263 FORMAT(' IN SUCH A SEQUENCE, EVERY WORD')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1264)
1264 FORMAT(' MUST BE A PRE-EXISTING PARAMETER, OR')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1265)
1265 FORMAT(' MUST BE THE WORD TO .')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1266)
1266 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1267)IHARG(I2)
1267 FORMAT(' THE OFFENDING WORD WAS ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1268)I2,IARGT(I2),IARG(I2)
1268 FORMAT(' I2,IARGT(I2),IARG(I2) = ',I8,2X,A4,I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
1269 CONTINUE
C
DO1270I=ISTART,ISTOP
I2=I
IF(IHARG(I).EQ.'TO ')GOTO1270
IX=IARG(I2)
IF(MININT.LE.IX.AND.IX.LE.MAXINT)GOTO1270
GOTO1280
1270 CONTINUE
GOTO1299
C
1280 CONTINUE
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1281)
1281 FORMAT('***** ERROR IN DPEXIN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1282)
1282 FORMAT(' AN ERROR OCCURRED IN PARSING A SEQUENCE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1283)
1283 FORMAT(' IN SUCH A SEQUENCE, EVERY PARAMETER')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1284)MININT
1284 FORMAT(' MUST BE BETWEEN ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1285)MAXINT
1285 FORMAT(' AND ',I8,' (INCLUSIVE).')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1286)
1286 FORMAT(' SUCH WAS NOT THE CASE HERE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1287)I2
1287 FORMAT(' ARGUMENT ',I8,' WAS OUT-OF-BOUNDS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1288)IHARG(I2)
1288 FORMAT(' THE ARGUMENT = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1289)IX
1289 FORMAT(' ITS VALUE = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1290)MININT
1290 FORMAT(' ALLOWABLE MINIMUM = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1291)MAXINT
1291 FORMAT(' ALLOWABLE MAXIMUM = ',I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
1299 CONTINUE
C
I=ISTART
I2=I
IF(IHARG(I).EQ.'TO ')GOTO1310
GOTO1319
1310 CONTINUE
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1311)
1311 FORMAT('***** ERROR IN DPEXIN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1312)
1312 FORMAT(' AN ERROR OCCURRED IN PARSING A SEQUENCE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1313)
1313 FORMAT(' THE FIRST WORD IN THE SEQUENCE WAS TO')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1314)I2,ISTART
1314 FORMAT('I2,ISTART = ',2I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
1319 CONTINUE
C
I=ISTOP
I2=I
IF(IHARG(I).EQ.'TO ')GOTO1320
GOTO1329
1320 CONTINUE
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1321)
1321 FORMAT('***** ERROR IN DPEXIN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1322)
1322 FORMAT(' AN ERROR OCCURRED IN PARSING A SEQUENCE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1323)
1323 FORMAT(' THE LAST WORD IN THE SEQUENCE WAS TO')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1324)I2,ISTART
1324 FORMAT('I2,ISTART = ',2I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
1329 CONTINUE
C
C ************************************
C ** STEP 21-- **
C ** GENERATE THE SEQUENCE **
C ************************************
C
ISTEPN='21'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXIN')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ITOSW='OFF'
K=0
NTAB=0
DO2100I=ISTART,ISTOP
IF(IHARG(I).EQ.'TO ')GOTO2110
IF(ITOSW.EQ.'ON')GOTO2120
GOTO2130
C
2110 CONTINUE
ITOSW='ON'
GOTO2100
C
2120 CONTINUE
IV2=IARG(I)
IF(IV1.LT.IV2)GOTO2121
GOTO2126
2121 CONTINUE
DO2122J=IV1,IV2
IF(J.EQ.IV1)GOTO2122
K=K+1
IF(K.GT.MAXTAB)GOTO2180
ITAB(K)=J
2122 CONTINUE
GOTO2129
2126 CONTINUE
DO2127J=IV2,IV1
IF(J.EQ.IV2)GOTO2127
JREV=IV1-J+IV2
K=K+1
IF(K.GT.MAXTAB)GOTO2180
ITAB(K)=JREV
2127 CONTINUE
GOTO2129
2129 CONTINUE
ITOSW='OFF'
GOTO2100
C
2130 CONTINUE
K=K+1
IF(K.GT.MAXTAB)GOTO2180
IV1=IARG(I)
ITAB(K)=IV1
GOTO2100
C
2100 CONTINUE
NTAB=K
GOTO9000
C
2180 CONTINUE
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2181)
2181 FORMAT('***** ERROR IN DPEXIN--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2182)
2182 FORMAT(' AN ERROR OCCURRED IN FORMING A SEQUENCE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2183)
2183 FORMAT(' THE NUMBER OF ELEMENTS RESULTING')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2184)
2184 FORMAT(' FROM FORMING SUCH A SEQUENCE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2185)MAXTAB
2185 FORMAT(' MUST NOT EXCEED ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2186)
2186 FORMAT(' BUT JUST HAS.')
CALL DPWRST('XXX','BUG ')
KM1=K-1
WRITE(ICOUT,2187)KM1,ITAB(KM1)
2187 FORMAT(' KM1,ITAB(KM1) = ',2I8)
CALL DPWRST('XXX','BUG ')
GOTO9000
2189 CONTINUE
C
C ****************
C ** STEP 90-- **
C ** EXIT. **
C ****************
C
9000 CONTINUE
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'EXIN')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPEXIN--')
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)NUMARG
9014 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NUMARG.LE.0)GOTO9019
DO9015I=1,NUMARG
WRITE(ICOUT,9016)I,IHARG(I),IARGT(I),IARG(I)
9016 FORMAT('I,IHARG(I),IARGT(I),IARG(I) = ',I8,2X,A4,2X,A4,I8)
CALL DPWRST('XXX','BUG ')
9015 CONTINUE
9019 CONTINUE
WRITE(ICOUT,9021)ISTART,ISTOP
9021 FORMAT('ISTART,ISTOP = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9022)MININT,MAXINT
9022 FORMAT('MININT,MAXINT = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9031)NTAB,MAXTAB
9031 FORMAT('NTAB,MAXTAB = ',2I8)
CALL DPWRST('XXX','BUG ')
IF(NTAB.LE.0)GOTO9039
DO9032I=1,NTAB
WRITE(ICOUT,9033)I,ITAB(I)
9033 FORMAT('I,ITAB(I) = ',2I8)
CALL DPWRST('XXX','BUG ')
9032 CONTINUE
9039 CONTINUE
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPEXIT(IBUGS2,ISUBRO,IFOUND,IERROR)
C
C PURPOSE--EXIT FROM DATAPLOT.
C NOTE--IN THE PROCESS OF EXITING, CERTAIN FILE OPERATIONS
C MUST BE DONE TO KEEP FILES TIDY.
C IN PARTICULAR, CLOSE NO FILES PER SE,
C BUT DO PUT END OF FILE MARKS ON SOME FILES.
C FOR MOST FILES, NOTHING AT ALL NEED BE DONE.
C NOTE--FOR ANY FILES THAT ARE ALREADY CLOSED
C (E.G., THE DATAPLOT PERMANENT FILES
C SUCH AS MESSAGE, NEWS, HELP, ETC.,
C PLUS OTHER FILES SUCH AS SAVE, LIST, ETC.)--
C DO NOTHING.
C NOTE--FOR ANY FILES THAT ARE OPEN
C AND MAY HAVE HAD WRITING GO INTO THE FILE,
C (E.G., THE WRITE FILE, THE PLOT1-FILE,
C THE PLOT-2 FILE, ETC.)--
C PUT AN END OF FILE, BUT DO NOT CLOSE IT.
C NOTE--ON SOME COMPUTER SYSTEMS, CLOSING A FILE--
C ESPECIALLY A 'TEMPORARY' FILE--HAS THE
C EFFECT OF DELETING THE FILE FROM THE SYSTEM
C WHICH MEANS THE USER HAS NO ACCESS TO IT
C AFTER EXITING OUT OF DATAPLOT. THIS IS
C COUNTER-PRODUCTIVE FOR SOME OF THE
C DATAPLOT-CREATED FILES SUCH AS THE PLOT-1
C FILE, THE PLOT-2 FILE, AND THE CONCLUSIONS FILE.
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 1977.
C UPDATED --APRIL 1979.
C UPDATED --NOVEMBER 1980.
C UPDATED --MARCH 1982.
C UPDATED --MAY 1982.
C UPDATED --JANUARY 1986.
C UPDATED --FEBRUARY 1989. CALL GREXIT (ALAN HECKERT))
C UPDATED --AUGUST 1986. CLOSE & EXIT WINDOW SYSTEM
C UPDATED --AUGUST 1986. WINDOW SYSTEM COMMON
C UPDATED --JULY 1991. COMMENT OUT WINDOW SYS.
C UPDATED --APRIL 1992. FIX PC DEVICE 2 CLOSE EXIT BOMB
C UPDATED --MAY 1992. ADD ----- TO OUTPUT
C UPDATED --MARCH 1997. SUPPORT FOR DEVICE FONT (ALAN)
C UPDATED --FEBRUARY 2006. ONLY CALL GREXIT IF DEVICE
C POWER IS ON
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IBUGS2
CHARACTER*4 ISUBRO
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*80 IFILE
CHARACTER*12 ISTAT
CHARACTER*12 IFORM
CHARACTER*12 IACCES
CHARACTER*12 IPROT
CHARACTER*12 ICURST
CCCCC CHARACTER*4 IENDFI
CCCCC CHARACTER*4 IREWIN
CHARACTER*4 ISUBN0
CHARACTER*4 IERRFI
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
CHARACTER*4 IPOWER
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCOF2.INC'
INCLUDE 'DPCOHO.INC'
INCLUDE 'DPCOPA.INC'
INCLUDE 'DPCOPC.INC'
INCLUDE 'DPCOGR.INC'
CCCCC THE FOLLOWING WINDOW SYSTEM COMMON WAS ADDED AUGUST 1990
INCLUDE 'DPCOWI.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
IFOUND='YES'
IERROR='NO'
C
ISUBN1='DPEX'
ISUBN2='IT '
C
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'EXIT')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPEXIT--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBUGS2,ISUBRO
52 FORMAT('IBUGS2,ISUBRO = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)IHOST1,IHOST2,ISITE
53 FORMAT('IHOST1,IHOST2,ISITE = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,61)IWRINU,IWRIST,IWRICS
61 FORMAT('IWRINU,IWRIST,IWRICS = ',I8,2X,A12,2X,A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,62)IWRINA
62 FORMAT('IWRINA = ',A80)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,63)ICRENU,ICREST,ICRECS
63 FORMAT('ICRENU,ICREST,ICRECS = ',I8,2X,A12,2X,A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,64)ICRENA
64 FORMAT('ICRENA = ',A80)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,71)IPL1NU,IPL1ST,IPL1CS
71 FORMAT('IPL1NU,IPL1ST,IPL1CS = ',I8,2X,A12,2X,A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,72)IPL1NA
72 FORMAT('IPL1NA = ',A80)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,73)IPL2NU,IPL2ST,IPL2CS
73 FORMAT('IPL2NU,IPL2ST,IPL2CS = ',I8,2X,A12,2X,A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,74)IPL2NA
74 FORMAT('IPL2NA = ',A80)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,75)ICONNU,ICONST,ICONCS
75 FORMAT('ICONNU,ICONST,ICONCS = ',I8,2X,A12,2X,A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,76)ICONNA
76 FORMAT('ICONNA = ',A80)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
CCCCC THE FOLLOWING ENTIRE SECTION (DECTION 20) WAS INSERTED (FEBRUARY 1989)
CCCCC BY ALAN BECAUSE SOME DEVICES, NAMELY LASER PRINTERS, (FEBRUARY 1989)
CCCCC MAY NEED A "TERMINATE" ROUTINE (FEBRUARY 1989)
C
C ********************************************
C ** STEP 20-- **
C ** CALL GREXIT FOR EACH DEVICE **
C ********************************************
C
ISTEPN='20'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXIT')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
DO1000IDEV=1,NUMDEV
CCCCC THE FOLLOWING 2 LINES WERE ADDED APRIL 1992 (ALAN)
CCCCC TO PREVENT PC EXIT BOMB APRIL 1992 (ALAN)
CCCCC AFTER DEVICE 2 CLOSE APRIL 1992 (ALAN)
IF(IDEV.EQ.2.AND.IPL1CS.EQ.'CLOSED')GOTO1000
IF(IDEV.EQ.3.AND.IPL2CS.EQ.'CLOSED')GOTO1000
IPOWER=IDPOWE(IDEV)
IMANUF=IDMANU(IDEV)
IMODEL=IDMODE(IDEV)
IMODE2=IDMOD2(IDEV)
IMODE3=IDMOD3(IDEV)
IGCODE=IDCODE(IDEV)
IGUNIT=IDUNIT(IDEV)
NUMHPP=IDNHPP(IDEV)
ANUMHP=NUMHPP
NUMVPP=IDNVPP(IDEV)
ANUMVP=NUMVPP
IGCOLO=IDCOLO(IDEV)
CCCCC ADD FOLLOWING LINE MARCH 1997.
IGFONT=IDFONT(IDEV)
IGBAUD=IDBAUD(IDEV)
ISOFT=IDSOFT(IDEV)
ISOFT2=IDSOF2(IDEV)
ISOFT3=IDSOF3(IDEV)
IF(IPOWER.EQ.'ON')CALL GREXIT
1000 CONTINUE
C
C ********************************************
C ** STEP 21-- **
C ** IF THE WRITE FILE IS STILL OPEN, **
C ** PUT AN END OF FILE ON IT. **
C ********************************************
C
ISTEPN='21'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXIT')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IOUNIT=IWRINU
IFILE=IWRINA
ISTAT=IWRIST
IFORM=IWRIFO
IACCES=IWRIAC
IPROT=IWRIPR
ICURST=IWRICS
ISUBN0='EXIT'
IERRFI='NO'
C
IF(ISTAT.EQ.'NONE')GOTO2190
IF(ICURST.EQ.'CLOSED')GOTO2190
ENDFILE IOUNIT
2190 CONTINUE
C
C ********************************************
C ** STEP 22-- **
C ** IF THE MACRO FILE IS STILL OPEN, **
C ** PUT AN END OF FILE ON IT. **
C ********************************************
C
ISTEPN='22'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXIT')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IOUNIT=ICRENU
IFILE=ICRENA
ISTAT=ICREST
IFORM=ICREFO
IACCES=ICREAC
IPROT=ICREPR
ICURST=ICRECS
ISUBN0='EXIT'
IERRFI='NO'
C
IF(ISTAT.EQ.'NONE')GOTO2290
IF(ICURST.EQ.'CLOSED')GOTO2290
ENDFILE IOUNIT
2290 CONTINUE
C
C ********************************************
C ** STEP 23-- **
C ** IF THE PLOT-1 FILE IS STILL OPEN, **
C ** PUT AN END OF FILE ON IT. **
C ********************************************
C
ISTEPN='23'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXIT')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IOUNIT=IPL1NU
IFILE=IPL1NA
ISTAT=IPL1ST
IFORM=IPL1FO
IACCES=IPL1AC
IPROT=IPL1PR
ICURST=IPL1CS
ISUBN0='EXIT'
IERRFI='NO'
C
IF(ISTAT.EQ.'NONE')GOTO2390
IF(ICURST.EQ.'CLOSED')GOTO2390
ENDFILE IOUNIT
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 2 LINES WERE ADDED MAY 1992 (JJF)
WRITE(ICOUT,2310)
2310 FORMAT('-----------------------------------------------')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2311)
2311 FORMAT('NOTE--DEVICE 2 (A FILE CONTAINING PLOT IMAGES) ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2312)
2312 FORMAT(' HAS JUST BEEN CLOSED.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2313)IOUNIT
2313 FORMAT(' FILE NUMBER = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2314)IFILE
2314 FORMAT(' FILE NAME = ',A80)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2316)
2316 FORMAT('NOTE--TO EXAMINE THE FILE, USE ANY EDITOR,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2317)
2317 FORMAT(' AND SIMPLY PRINT THE FILE CONTENTS.')
CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING LINE WAS ADDED MAY 1992 (JJF)
WRITE(ICOUT,2310)
CALL DPWRST('XXX','BUG ')
C
IF(ISITE.EQ.'NBS'.AND.IHOST1.EQ.'VAX')GOTO2320
GOTO2339
2320 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2321)
2321 FORMAT('NOTE--IF THIS FILE CONTAINS TEKTRONIX 4014 IMAGES,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2322)
2322 FORMAT(' THEN TO SEND THIS FILE TO THE LASER PRINTER,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2323)
2323 FORMAT(' ENTER LPLOT DPPL1F.DAT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
2339 CONTINUE
C
2390 CONTINUE
C
C ********************************************
C ** STEP 24-- **
C ** IF THE PLOT-2 FILE IS STILL OPEN, **
C ** PUT AN END OF FILE ON IT. **
C ********************************************
C
ISTEPN='24'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXIT')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IOUNIT=IPL2NU
IFILE=IPL2NA
ISTAT=IPL2ST
IFORM=IPL2FO
IACCES=IPL2AC
IPROT=IPL2PR
ICURST=IPL2CS
ISUBN0='EXIT'
IERRFI='NO'
C
IF(ISTAT.EQ.'NONE')GOTO2490
IF(ICURST.EQ.'CLOSED')GOTO2490
ENDFILE IOUNIT
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 2 LINES WERE ADDED MAY 1992 (JJF)
WRITE(ICOUT,2410)
2410 FORMAT('-----------------------------------------------')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2411)
2411 FORMAT('NOTE--DEVICE 3 (A FILE CONTAINING PLOT IMAGES) ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2412)
2412 FORMAT(' HAS JUST BEEN CLOSED.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2413)IOUNIT
2413 FORMAT(' FILE NUMBER = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2414)IFILE
2414 FORMAT(' FILE NAME = ',A80)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2416)
2416 FORMAT('NOTE--TO EXAMINE THE FILE, USE ANY EDITOR,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2417)
2417 FORMAT(' AND SIMPLY PRINT THE FILE CONTENTS.')
CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING LINE WAS ADDED MAY 1992 (JJF)
WRITE(ICOUT,2410)
CALL DPWRST('XXX','BUG ')
C
IF(ISITE.EQ.'NBS'.AND.IHOST1.EQ.'VAX')GOTO2420
GOTO2439
2420 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2421)
2421 FORMAT('NOTE--IF THIS FILE CONTAINS TEKTRONIX 4014 IMAGES,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2422)
2422 FORMAT(' THEN TO SEND THIS FILE TO THE LASER PRINTER,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2423)
2423 FORMAT(' ENTER LPLOT DPPL2F.DAT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
2439 CONTINUE
C
2490 CONTINUE
C
C ********************************************
C ** STEP 25-- **
C ** IF THE CONCLUSIONS FILE IS STILL OPEN,**
C ** PUT AN END OF FILE ON IT. **
C ********************************************
C
ISTEPN='25'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXIT')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IOUNIT=ICONNU
IFILE=ICONNA
ISTAT=ICONST
IFORM=ICONFO
IACCES=ICONAC
IPROT=ICONPR
ICURST=ICONCS
ISUBN0='EXIT'
IERRFI='NO'
C
IF(ISTAT.EQ.'NONE')GOTO2590
IF(ICURST.EQ.'CLOSED')GOTO2590
ENDFILE IOUNIT
2590 CONTINUE
C
C ***************************
C ** STEP 80-- **
C ** WRITE OUT A MESSAGE **
C ***************************
C
8000 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8011)
8011 FORMAT('THIS IS AN EXIT FROM DATAPLOT.')
CALL DPWRST('XXX','BUG ')
C
CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 1990
C ***********************************
C ** IF IN A WINDOW SYSTEM, **
C ** CLOSE THE WINDOW, AND **
C ** EXIT FROM THE WINDOW SYSTEM **
C ***********************************
C
CCCCC THE FOLLOWING WAS COMMENTED OUT IN JULY 1991 JJF
C
CCCCC IF(IWINSY.EQ.'NONE')GOTO8190
CCCCC CALL WISEWI(1)
CCCCC CALL WICLWI('OFF ','OFF ')
CCCCC CALL WIEXWS('OFF ')
C8190 CONTINUE
C
C ****************
C ** STEP 90-- **
C ** EXIT. **
C ****************
C
9000 CONTINUE
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'EXIT')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPEXIT--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGS2,ISUBRO
9012 FORMAT('IBUGS2,ISUBRO = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)IHOST1,IHOST2,ISITE
9013 FORMAT('IHOST1,IHOST2,ISITE = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9021)IWRINU,IWRIST,IWRICS
9021 FORMAT('IWRINU,IWRIST,IWRICS = ',I8,2X,A12,2X,A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9022)IWRINA
9022 FORMAT('IWRINA = ',A80)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9023)ICRENU,ICREST,ICRECS
9023 FORMAT('ICRENU,ICREST,ICRECS = ',I8,2X,A12,2X,A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9024)ICRENA
9024 FORMAT('ICRENA = ',A80)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9031)IPL1NU,IPL1ST,IPL1CS
9031 FORMAT('IPL1NU,IPL1ST,IPL1CS = ',I8,2X,A12,2X,A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9032)IPL1NA
9032 FORMAT('IPL1NA = ',A80)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9033)IPL2NU,IPL2ST,IPL2CS
9033 FORMAT('IPL2NU,IPL2ST,IPL2CS = ',I8,2X,A12,2X,A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9034)IPL2NA
9034 FORMAT('IPL2NA = ',A80)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9035)ICONNU,ICONST,ICONCS
9035 FORMAT('ICONNU,ICONST,ICONCS = ',I8,2X,A12,2X,A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9036)ICONNA
9036 FORMAT('ICONNA = ',A80)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9041)IFOUND,IERROR
9041 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
STOP
END
SUBROUTINE DPEXEC(IANSEX,IWIDEX,IBUGMA,IFOUND,IERROR)
C
C PURPOSE--TRANSFORM THE STRING (WITH ALL SUBSTITUTIONS MADE)
C FOR THE EXECUTE STRING COMMAND
C INPUT --A COMMAND LINE STARTING WITH EXECUTE STRING
C (THIS COMMAND LINE IS IN IANS(.)--IN COMMON)
C OUTPUT --A TRANSFORMED COMMAND LINE IN WHICH THE 2 LEAD WORDS
C EXECUTE STRING HAVE BEEN DELETED,
C AND THE TRAILING WORDS BECOME THE NEW COMMAND LINE.
C NOTE ALSO THAT IF ANY OF THE TRAILING WORDS ARE FUNCTION
C (= STRING) NAMES, THEN THE WORDS THEMSELVES WILL HAVE BEEN
C REPLACED BY THE STRINGS.
C (THE OUTPUT STRING IS IN IANSEX(.))
C EXAMPLE--LET FUNCTION F = CALIBRATION ANALYSIS
C EXECUTE STRING TITLE F
C WILL RESULT IN THE FOLLOWING COMMAND LINE--
C TITLE CALIBRATION ANALYSIS
C BEING EXECUTED.
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--85/7
C ORIGINAL VERSION--JULY 1985.
C UPDATED --FEBRUARY 1994. CHECK FOR X CHART, X CONTROL CHART
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*1 IANSEX
C
CHARACTER*4 IBUGMA
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 ICASE
CHARACTER*4 IF4
C
CHARACTER*4 IWD1
CHARACTER*4 IWD2
CHARACTER*4 IWD12
CHARACTER*4 IWD22
CHARACTER*4 IFOUN1
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
DIMENSION IANSEX(*)
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCOPA.INC'
INCLUDE 'DPCOHK.INC'
INCLUDE 'DPCODA.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
ISUBN1='DPEX'
ISUBN2='EC '
C
IFOUND='NO'
IERROR='NO'
ICASE='NONE'
IFOUN1='NO'
C
C ******************************************
C ** TREAT THE EXECUTE STRING CASE **
C ******************************************
C
IF(IBUGMA.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPEXEC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBUGMA,IFOUND,IERROR
52 FORMAT('IBUGMA,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)NUMNAM
53 FORMAT('NUMNAM = ',I8)
CALL DPWRST('XXX','BUG ')
DO55I=1,NUMNAM
WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I)
56 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I)=',
1I8,2X,A4,A4,2X,A4,I8,I8)
CALL DPWRST('XXX','BUG ')
55 CONTINUE
WRITE(ICOUT,57)NUMCHF,MAXCHF
57 FORMAT('NUMCHF,MAXCHF = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,60)(IFUNC(I),I=1,MAXCHF)
60 FORMAT('IFUNC(.) = ',120A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,61)IWIDTH,MAXWID
61 FORMAT('IWIDTH,MAXWID = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,62)(IANS(I),I=1,IWIDTH)
62 FORMAT('(IANS(.) = ',110A1)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C **********************************
C ** STEP 11-- **
C ** INITIALIZE SOME VARIABLES. **
C **********************************
C
ISTEPN='11'
IF(IBUGMA.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IWIDEX=(-999)
MAXN2=MAXCHF
MAXN3=MAXCHF
C
DO1100I=1,1000
IANSEX(I)=' '
1100 CONTINUE
C
C ***********************************************************
C ** STEP 12-- **
C ** CHECK TO SEE IF HAVE THE EXECUTE STRING COMMAND **
C ***********************************************************
C
ISTEPN='12'
IF(IBUGMA.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IWIDTH.EQ.1.AND.
1IANS(1).EQ.'X')GOTO1210
C
IF(IWIDTH.GE.2.AND.
1IANS(1).EQ.'X'.AND.IANS(2).EQ.' ')GOTO1210
C
IF(IWIDTH.GE.14.AND.
1IANS(1).EQ.'E'.AND.IANS(2).EQ.'X'.AND.
1IANS(3).EQ.'E'.AND.IANS(4).EQ.'C'.AND.
1IANS(5).EQ.'U'.AND.IANS(6).EQ.'T'.AND.
1IANS(7).EQ.'E'.AND.IANS(8).EQ.' '.AND.
1IANS(9).EQ.'S'.AND.IANS(10).EQ.'T'.AND.
1IANS(11).EQ.'R'.AND.IANS(12).EQ.'I'.AND.
1IANS(13).EQ.'N'.AND.IANS(14).EQ.'G')GOTO1220
C
GOTO1230
C
1210 CONTINUE
CCCCC CHECK FOR X CHART OR X CONTROL CHART. FEBRUARY 1994.
IF(IWIDTH.GE.7.AND.
1IANS(1).EQ.'X'.AND.IANS(2).EQ.' '.AND.
1IANS(3).EQ.'C'.AND.IANS(4).EQ.'H'.AND.
1IANS(5).EQ.'A'.AND.IANS(6).EQ.'R'.AND.
1IANS(7).EQ.'T')GOTO1230
IF(IWIDTH.GE.15.AND.
1IANS(1).EQ.'X'.AND.IANS(2).EQ.' '.AND.
1IANS(3).EQ.'C'.AND.IANS(4).EQ.'O'.AND.
1IANS(5).EQ.'N'.AND.IANS(6).EQ.'T'.AND.
1IANS(7).EQ.'R'.AND.IANS(8).EQ.'O'.AND.
1IANS(9).EQ.'L'.AND.IANS(10).EQ.' '.AND.
1IANS(11).EQ.'C'.AND.IANS(12).EQ.'H'.AND.
1IANS(13).EQ.'A'.AND.IANS(14).EQ.'R'.AND.
1IANS(15).EQ.'T')GOTO1230
IF(IWIDTH.GE.6.AND.
1IANS(1).EQ.'X'.AND.IANS(2).EQ.' '.AND.
1IANS(3).EQ.'C'.AND.IANS(4).EQ.'O'.AND.
1IANS(5).EQ.'N'.AND.IANS(6).EQ.'T')GOTO1230
IFOUND='YES'
ICASE='X '
GOTO1290
C
1220 CONTINUE
IFOUND='YES'
ICASE='EXEC'
GOTO1290
C
1230 CONTINUE
IFOUND='NO'
ICASE='NONE'
GOTO9000
C
1290 CONTINUE
C
C ***************************************************************
C ** STEP 13-- **
C ** EXTRACT THE RIGHT-SIDE **
C ** EXPRESSION FROM THE INPUT COMMAND LINE **
C ** (STARTING WITH THE FIRST NON-BLANK LOCATION AFTER THE **
C ** WORD STRING OF EXECUTE STRING **
C ** AND ENDING WITH THE END OF THE LINE **
C ***************************************************************
C
ISTEPN='13'
IF(IBUGMA.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IWD1='X '
IWD12=' '
IF(ICASE.EQ.'EXEC')IWD1='STRI'
IF(ICASE.EQ.'EXEC')IWD12='NG '
IWD2=' '
IWD22=' '
CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2,
1IFUNC2,N2,IBUGMA,IFOUN1,IERROR)
IF(IFOUN1.EQ.'NO')GOTO1310
IF(IERROR.EQ.'YES')GOTO1310
GOTO1390
C
1310 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1311)
1311 FORMAT('***** ERROR IN DPEXEC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1312)
1312 FORMAT(' INTERNAL ERROR--AT 3101 AFTER CALL TO DPEXST.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1313)
1313 FORMAT(' ERROR IN EXTRACTING TRAILING STRING.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1315)
1315 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,1316)(IANS(I),I=1,IWIDTH)
1316 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1317)IFOUN1,IERROR
1317 FORMAT('IFOUN1,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
1390 CONTINUE
C
C ***********************************************************
C ** STEP 14-- **
C ** DETERMINE IF THE EXPRESSION HAS ANY STRING NAMES **
C ** INBEDDED. IF SO, REPLACE THE STRING NAMES **
C ** BY EACH STRING 'S DEFINITION. DO SO REPEATEDLY **
C ** UNTIL ALL STRING REFERENCES HAVE BEEN ANNIHILATED **
C ** AND THE EXPRESSION IS LEFT ONLY WITH **
C ** CONSTANTS, PARAMETERS, AND VARIABLES--NO STRING S. **
C ** PLACE THE RESULTING FUNCTIONAL EXPRESSION INTO IFUNC3(.) **
C ***********************************************************
C
ISTEPN='14'
IF(IBUGMA.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CALL DPEXFU(IFUNC2,N2,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP,
1NUMNAM,IANS,IWIDTH,IFUNC,NUMCHF,MAXCHF,IFUNC3,N3,MAXN3,
1IBUGMA,IERROR)
IF(IERROR.EQ.'YES')GOTO1410
GOTO1490
C
1410 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1411)
1411 FORMAT('***** ERROR IN DPEXEC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1412)
1412 FORMAT(' INTERNAL ERROR--AT 1401 AFTER CALL TO DPEXFU.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1413)
1413 FORMAT(' ERROR IN TRANSFORMING TRAILING STRING.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1415)
1415 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,1416)(IANS(I),I=1,IWIDTH)
1416 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1417)IERROR
1417 FORMAT('IERROR = ',A4)
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
1490 CONTINUE
C
C *******************************************
C ** STEP 15-- **
C ** FORM THE TRANSFORMED COMMAND STRING **
C *******************************************
C
ISTEPN='15'
IF(IBUGMA.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
IWIDEX=N3
IF(N3.LT.0)IWIDEX=0
IF(N3.GT.MAXWID)IWIDEX=MAXWID
IF(IWIDEX.LE.0)GOTO1590
DO1500I=1,IWIDEX
IF4=IFUNC3(I)
IANSEX(I)=IF4(1:1)
1500 CONTINUE
1590 CONTINUE
C
C ****************
C ** STEP 90-- **
C ** EXIT. **
C ****************
C
9000 CONTINUE
IF(IBUGMA.EQ.'OFF')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPEXEC--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGMA,IFOUND,IERROR,ICASE
9012 FORMAT('IBUGMA,IFOUND,IERROR,ICASE = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)IFOUN1
9013 FORMAT('IFOUN1 = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)NUMNAM
9014 FORMAT('NUMNAM = ',I8)
CALL DPWRST('XXX','BUG ')
DO9015I=1,NUMNAM
WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I)
9016 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I)=',
1I8,2X,A4,A4,2X,A4,I8,I8)
CALL DPWRST('XXX','BUG ')
9015 CONTINUE
WRITE(ICOUT,9017)N2,N3,NUMCHF,MAXN2,MAXN3,MAXCHF
9017 FORMAT('N2,N3,NUMCHF,MAXN2,MAXN3,MAXCHF = ',6I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9018)(IFUNC2(I),I=1,N2)
9018 FORMAT('IFUNC2(.) = ',120A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9019)(IFUNC3(I),I=1,N3)
9019 FORMAT('IFUNC3(.) = ',120A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9020)(IFUNC(I),I=1,MAXCHF)
9020 FORMAT('IFUNC(.) = ',120A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9021)IWIDEX
9021 FORMAT('IWIDEX = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9022)(IANSEX(I),I=1,IWIDEX)
9022 FORMAT('(IANSEX(.) = ',110A1)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPEXFU(IFUNC2,N2,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP,
1NUMNAM,IANS,IWIDTH,IFUNC,NUMCHF,MAXCHF,IFUNC3,N3,MAXN3,
1IBUGA3,IERROR)
C
C PURPOSE--SCAN A STRING FOR FUNCTION NAMES;
C REPLACE FUNCTION NAMES BY FUNCTION EXPRESSIONS;
C DO SO RECURSIVELY UNTIL ALL FUNCTION NAMES
C HAVE BEEN ANNIHILATED AND THERE REMAINS ONLY
C AN EXPRESSION IN CONSTANTS, PARAMETERS,
C VARIABLES--NO FUNCTIONS.
C NOTE--THE INPUT STRING IS IN IFUNC2(.).
C THE OUTPUT EXPRESSION WILL BE IN IFUNC3(.).
C NOTE--IF SO DESIRED, THE OUTPUT VECTOR IFUNC3(.)
C MAY BE IDENTICAL TO THE INPUT VECTOR IFUNC2(.).
C
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-921-3651
C NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C OF THE NATIONAL BUREAU OF STANDARDS.
C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C MODIFIED, OR OTHERWISE USED IN A CONTEXT
C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--82/7
C ORIGINAL VERSION--DECEMBER 1978.
C UPDATED --JANUARY 1979.
C UPDATED --JANUARY 1981.
C UPDATED --JUNE 1981.
C UPDATED --MAY 1982.
C UPDATED --MAY 1982.
C UPDATED --APRIL 2005. SINCE FUNCTIONS NO LONGER
C STORED IN UPPER CASE,
C NEED TO CONVERT EXTRACTED
C FUNCTION TO UPPER CASE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IFUNC2
CHARACTER*4 IHNAME
CHARACTER*4 IHNAM2
CHARACTER*4 IUSE
CHARACTER*4 IANS
CHARACTER*4 IFUNC
CHARACTER*4 IFUNC3
CHARACTER*4 IBUGA3
CHARACTER*4 IERROR
C
CHARACTER*4 IFOUNN
CHARACTER*4 ICH
CHARACTER*4 IX1
CHARACTER*4 IX2
CHARACTER*4 IHOUT
CHARACTER*4 IWD1
CHARACTER*4 IWD12
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
DIMENSION IFUNC2(*)
DIMENSION IHNAME(*)
DIMENSION IHNAM2(*)
DIMENSION IUSE(*)
DIMENSION IVSTAR(*)
DIMENSION IVSTOP(*)
DIMENSION IANS(*)
DIMENSION IFUNC(*)
DIMENSION IFUNC3(*)
C
DIMENSION ICH(8)
C
DIMENSION IHOUT(10)
C
C---------------------------------------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
ISUBN1='DPEX'
ISUBN2='FU '
C
NUMASC=4
NUMAS2=2*NUMASC
C
IFOUNN='NO'
IEND=0
ISTART=0
ISTOP=0
J2=0
ILENEX=0
ILENFN=0
IDEL=0
N3PDEL=0
C
C ***************************
C ** EXTRACT A FUNCTION. **
C ***************************
C
IF(IBUGA3.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,71)
71 FORMAT('***** AT THE BEGINNING OF DPEXFU--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,72)N2
72 FORMAT('N2 = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,73)(IFUNC2(I),I=1,MIN(N2,115))
73 FORMAT('IFUNC2(.) = ',115A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,74)NUMCHF
74 FORMAT('NUMCHF = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,75)(IFUNC(I),I=1,MIN(NUMCHF,115))
75 FORMAT('IFUNC(.) = ',115A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,77)NUMNAM
77 FORMAT('NUMNAM = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,78)
78 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I) = ')
CALL DPWRST('XXX','BUG ')
IF(NUMNAM.LE.0)GOTO90
DO80I=1,NUMNAM
WRITE(ICOUT,81)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I)
81 FORMAT(I8,2X,A4,A4,2X,A4,2X,I8,2X,I8)
CALL DPWRST('XXX','BUG ')
80 CONTINUE
90 CONTINUE
C
C **********************************
C ** STEP 1-- **
C ** INITIALIZE SOME VARIABLES. **
C **********************************
C
ISTEPN='1'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IERROR='NO'
NUMPAS=100
C
C **********************************************
C ** STEP 2-- **
C ** COPY THE INITIAL CONTENTS OF IFUNC2(.) **
C ** INTO IFUNC3(.). **
C ** SET N3 INITIALLY = N2. **
C **********************************************
C
DO120I=1,N2
IFUNC3(I)=IFUNC2(I)
120 CONTINUE
N3=N2
C
C ***************************************************************
C ** STEP 3-- **
C ** MAKE A MAXIMUM OF 100 INDEPENDENT MULTI-NAME **
C ** PASSES AT THE CONTINUOUSLY-UPDATED STRING IN IFUNC3(.). **
C ** EACH INDEPENDENT MULTI-NAME PASS CONSISTS OF **
C ** GOING THROUGH ALL THE FUNCTION NAMES IN THE INTERNAL **
C ** DATAPLOT TABLE, SEEING IF EACH ONE OCCURS IN IFUNC3(.), **
C ** AND THEN REPLACING THE FUNCTION NAME IN IFUNC3(.) **
C ** BY THE DEFINED FUNCTION EXPRESSION. **
C ** WHEN IFUNC3(.) NO LONGER CONTAINS ANY FUNCTION NAMES, **
C ** THEN TERMINATE THE PASSES. **
C ***************************************************************
C
ISTEPN='3'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
DO1100IPASS=1,NUMPAS
C
C *****************************************************
C ** STEP 3.1-- **
C ** FOR A GIVEN INDEPENDENT MULTI-NAME PASS, **
C ** EXAMINE (SWEEP THROUGH) ALL THE FUNCTION **
C ** NAMES IN THE INTERNAL DATAPLOT TABLE. **
C ** FOR A GIVEN FUNCTION NAME, EXAMINE THE **
C ** CURRENT STRING IN IFUNC3(.) TO DETERMINE **
C ** IF THIS PARTICULAR FUNCTION NAME OCCURS **
C ** ANYWHERE IN THE STRING. **
C *****************************************************
C
ISTEPN='3.1'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IFOUNN='NO'
DO2100INAME=1,NUMNAM
IF(IUSE(INAME).EQ.'F')GOTO2190
GOTO2100
2190 CONTINUE
C
C **************************************************
C ** STEP 3.2-- **
C ** FOR A GIVEN NAME IN THE TABLE, **
C ** DECOMPOSE THE NAME INTO 1-CHARACTER WORDS. **
C **************************************************
C
ISTEPN='3.2'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IWD1=IHNAME(INAME)
IWD12=IHNAM2(INAME)
IF(IWD1.EQ.' ')GOTO3080
GOTO3090
3080 CONTINUE
WRITE(ICOUT,3081)
3081 FORMAT('***** ERROR IN DPEXFU--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3082)
3082 FORMAT(' A FUNCTION NAME ENCOUNTERED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3083)
3083 FORMAT(' IN THE INTERNAL DATAPLOT TABLE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3084)
3084 FORMAT(' CONSISTED OF ALL BLANKS.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3085)INAME
3085 FORMAT(' IT WAS NAME NUMBER ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3086)
3086 FORMAT(' IN THE PARAMETER/VARIABLE/FUNCTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3087)
3087 FORMAT(' TABLE.')
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
3090 CONTINUE
C
CCCCC CALL DPXH1H(IWD1,ICH,IEND,IBUGA3)
DO3195I=1,NUMAS2
ICH(I)=' '
3195 CONTINUE
C
J=0
IF(IWD1.EQ.' ')IEND=0
IF(IWD1.EQ.' ')GOTO3390
IX1=IWD1
ISTR2=0
ILEN1=NUMBPC
ILEN2=ILEN1
DO3200I=1,NUMASC
J=J+1
IX2=' '
ISTR1=(I-1)*NUMBPC
CALL DPCHEX(ISTR1,ILEN1,IX1,ISTR2,ILEN2,IX2)
ICH(J)=IX2
3200 CONTINUE
C
IF(IWD12.EQ.' ')GOTO3290
IX1=IWD12
ISTR2=0
ILEN1=NUMBPC
ILEN2=ILEN1
DO3250I=1,NUMASC
J=J+1
IX2=' '
ISTR1=(I-1)*NUMBPC
CALL DPCHEX(ISTR1,ILEN1,IX1,ISTR2,ILEN2,IX2)
ICH(J)=IX2
3250 CONTINUE
3290 CONTINUE
C
K=0
DO3300I=1,J
K=K+1
IF(ICH(I).EQ.' ')GOTO3350
3300 CONTINUE
IEND=K
GOTO3390
3350 CONTINUE
IEND=K-1
3390 CONTINUE
C
IF(IBUGA3.EQ.'OFF')GOTO3399
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3391)
3391 FORMAT('***** FROM THE MIDDLE OF DPEXFU--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3392)IPASS,INAME,IWD1,IWD12,IEND
3392 FORMAT('IPASS,INAME,IWD1,IWD12,IEND = ',I8,I8,2X,A4,2X,A4,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3393)(ICH(I),I=1,8)
3393 FORMAT('ICH(.)--',120A1)
CALL DPWRST('XXX','BUG ')
3399 CONTINUE
C
C *************************************************
C ** STEP 3.3-- **
C ** SEARCH THE CURRENT STRING TO SEE IF THIS **
C ** PARTICULAR FUNCTION NAME IS ANYWHERE **
C ** IN THE STRING. **
C ** ALSO CHECK TO SEE IF A FOUND STRING **
C ** IS VALID UNTO ITSELF BY CHECKING IF IT **
C ** IS PRECEDED AND SUCCEEDED BY THE **
C ** USUAL TYPE OF SEPARATORS AS FOUND **
C ** IN MATHEMATICAL EXPRESSIONS **
C ** (+, -, *, /, PARENTHESIS, OR SPACE. **
C *************************************************
C
ISTEPN='3.3'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ISTART=-99
ISTOP=-99
NUMTNF=0
4000 CONTINUE
DO4100I=1,N3
I2=I
IF(IFUNC3(I).EQ.ICH(1))GOTO4190
GOTO4100
4190 CONTINUE
C
DO4200J=1,IEND
J2=I2+J-1
C ***** THE FOLLOWING CORRECTIVE LINE INSERTED IN AUGUST 1983 *****
IF(J2.GT.N3)GOTO4100
IF(IFUNC3(J2).EQ.ICH(J))GOTO4200
GOTO4100
4200 CONTINUE
C
ISTART=I2
ISTOP=J2
C
ISTAM1=ISTART-1
IF(ISTAM1.LT.1.OR.ISTAM1.GT.N3)GOTO4390
IF(IFUNC3(ISTAM1).EQ.' ')GOTO4390
IF(IFUNC3(ISTAM1).EQ.'(')GOTO4390
IF(IFUNC3(ISTAM1).EQ.'+')GOTO4390
IF(IFUNC3(ISTAM1).EQ.'-')GOTO4390
IF(IFUNC3(ISTAM1).EQ.'*')GOTO4390
IF(IFUNC3(ISTAM1).EQ.'/')GOTO4390
IF(IFUNC3(ISTAM1).EQ.'**')GOTO4390
GOTO4100
4390 CONTINUE
C
ISTOP1=ISTOP+1
IF(ISTOP1.LT.1.OR.ISTOP1.GT.N3)GOTO4490
IF(IFUNC3(ISTOP1).EQ.' ')GOTO4490
IF(IFUNC3(ISTOP1).EQ.')')GOTO4490
IF(IFUNC3(ISTOP1).EQ.'+')GOTO4490
IF(IFUNC3(ISTOP1).EQ.'-')GOTO4490
IF(IFUNC3(ISTOP1).EQ.'*')GOTO4490
IF(IFUNC3(ISTOP1).EQ.'/')GOTO4490
IF(IFUNC3(ISTOP1).EQ.'**')GOTO4490
GOTO4100
4490 CONTINUE
C
IFOUNN='YES'
C
C ***********************************************************
C ** STEP 3.4-- **
C ** HAVING FOUND AN OCCURRANCE OF A GIVEN FUNCTION NAME **
C ** SOMEWHERE IN THE CURRENT STRING IFUNC3(.), **
C ** 1) DETERMINE THE LENGTH OF THE FUNCTION EXPRESSION **
C ** ABOUT TO BE SUBSTITUTED (INTO IFUNC3(.)) **
C ** IN PLACE OF THE FUNCTION NAME. **
C ** 2) MOVE THE SEGMENT OF THE STRING IN IFUNC3(.) **
C ** WHICH IS BEYOND THE FOUND FUNCTION NAME OVER **
C ** AN APPROPRIATE NUMBER OF SPACES. **
C ** 3) ACTUALLY INSERT THE FUNCTION EXPRESSION **
C ** INTO IFUNC3(.) IN PLACE OF THE FUNCTION NAME **
C ** (PRECEDED AND SUCCEEDED BY PARENTHESES). **
C ** 4) UPDATE THE CURRENT LENGTH N3 OF IFUNC3(.). **
C ** 5) LOOP BACK AND COMPLETELY REEXAMINE IFUNC3(.) FOR **
C ** ADDITIONAL OCCURRANCES OF THIS FUNCTION NAME. **
C ***********************************************************
C
C
ISTEPN='3.4'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ISTAR2=IVSTAR(INAME)
ISTOP2=IVSTOP(INAME)
ILENEX=ISTOP2-ISTAR2+1
ILENFN=IEND
IDEL=ILENEX-ILENFN
IDEL=IDEL+2
C
N3PDEL=N3+IDEL
IF(N3PDEL.LE.MAXN3)GOTO5090
WRITE(ICOUT,5001)
5001 FORMAT('***** ERROR IN DPEXFU--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5002)
5002 FORMAT(' ERROR CAUSED IN FORMATION OF FUNCTION--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5005)
5005 FORMAT(' THE TOTAL NUMBER OF CHARACTERS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5006)MAXCHF
5006 FORMAT(' FOR THE FUNCTION MAY NOT EXCEED ',
1I8,'.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5007)
5007 FORMAT(' SUCH AN OVERFLOW CONDITION HAS JUST')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5008)
5008 FORMAT(' BEEN ENCOUNTERED.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5018)
5018 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5019)(IANS(K),K=1,MIN(IWIDTH,100))
5019 FORMAT(' ',100A1)
CALL DPWRST('XXX','BUG ')
C
IERROR='YES'
GOTO9000
5090 CONTINUE
C
IPOINT=ISTOP
IHOUT(1)=')'
NOUT=1
CALL DPSIAS(IPOINT,IFUNC3,N3,IHOUT,NOUT,IBUGA3,IERROR)
C
IPOINT=ISTART-1
IHOUT(1)='('
NOUT=1
CALL DPSIAS(IPOINT,IFUNC3,N3,IHOUT,NOUT,IBUGA3,IERROR)
C
IPOIN1=ISTART+1
IPOIN2=ISTOP+1
CALL DPSIRS(IFUNC3,N3,IPOIN1,IPOIN2,IFUNC,NUMCHF,ISTAR2,ISTOP2,
1IBUGA3,IERROR)
C
CCCCC APRIL 2005. CONVERT NEW FUNCTION TO UPPER CASE.
C
DO5201II=1,N3
IJUNK=ICHAR(IFUNC3(II)(1:1))
IF(IJUNK.GE.97 .AND. IJUNK.LE.122)THEN
IJUNK=IJUNK-32
IFUNC3(II)(1:1)=CHAR(IJUNK)
ENDIF
5201 CONTINUE
C
NUMTNF=NUMTNF+1
IF(NUMTNF.LE.MAXN3)GOTO4100
C
C WRITE(ICOUT,5301)
5301 FORMAT('***** ERROR IN DPEXFU--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5302)
5302 FORMAT(' FOR A GIVEN MULTI-NAME PASS,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5303)(ICH(K),K=1,IEND)
5303 FORMAT(' FOR A PARTICULAR FUNCTION NAME (= ',10A1,')')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5304)MAXN3
5304 FORMAT(' THE NAME OCCURRED MORE THAN ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5305)
5305 FORMAT(' TIMES ON THE LINE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5307)
5307 FORMAT(' POSSIBLE CAUSE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5308)
5308 FORMAT(' AN IMPROPER INFINITELY-RECURSIVE ORIGINAL')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5309)
5309 FORMAT(' FUNCTION DEFINITION THAT HAD BEEN')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5310)(ICH(K),K=1,IEND)
5310 FORMAT(' PREVIOUSLY MADE FOR ',10A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5311)
5311 FORMAT(' EXAMPLE--LET FUNCTION F1=F1*F1')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5312)
5312 FORMAT(' SOLUTION--CORRECT THE ORIGINAL')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5313)(ICH(K),K=1,IEND)
5313 FORMAT(' DEFINITION FOR THE FUNCTION ',10A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5314)
5314 FORMAT(' SO THAT IT IS AN EXPRESSION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5315)
5315 FORMAT(' IN TERMS OF CONSTANTS, PARAMETERS,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5316)
5316 FORMAT(' AND VARIABLES--NOT UNENDINGLY')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5317)
5317 FORMAT(' RECURSIVE IN ITS OWN FUNCTION NAME.')
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
4100 CONTINUE
C
2100 CONTINUE
IF(IFOUNN.EQ.'NO')GOTO9000
C
1100 CONTINUE
C
WRITE(ICOUT,5901)
5901 FORMAT('***** ERROR IN DPEXFU--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5902)
5902 FORMAT(' THE NUMBER OF INDEPENDENT,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5903)
5903 FORMAT(' MULTI-NAME PASSES TO DETERMINE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5904)
5904 FORMAT(' THE EXPLICIT UNDERLYING FUNCTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5905)
5905 FORMAT(' HAS JUST EXCEEDED THE ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5906)
5906 FORMAT(' MAXIMUM ALLOWABLE NUMBER OF ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5907)
5907 FORMAT(' POSSIBLE CAUSE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5908)
5908 FORMAT(' AN IMPROPER INFINITELY-RECURSIVE ORIGINAL')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5909)
5909 FORMAT(' FUNCTION DEFINITION THAT HAD BEEN')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5910)
5910 FORMAT(' PREVIOUSLY MADE FOR ONE OR MORE FUNCTIONS.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5911)
5911 FORMAT(' EXAMPLE--LET FUNCTION F1=F1*F2')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5912)
5912 FORMAT(' SOLUTION--CORRECT THE ORIGINAL')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5913)
5913 FORMAT(' DEFINITION FOR SOME FUNCTION.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5914)
5914 FORMAT(' SO THAT IT IS AN EXPRESSION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5915)
5915 FORMAT(' IN TERMS OF CONSTANTS, PARAMETERS,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5916)
5916 FORMAT(' AND VARIABLES--NOT UNENDINGLY')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,5917)
5917 FORMAT(' RECURSIVE IN ITS OWN FUNCTION NAME.')
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
C ****************
C ** STEP 4-- **
C ** EXIT. **
C ****************
C
9000 CONTINUE
C
ISTEPN='4'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IBUGA3.EQ.'OFF')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPEXFU--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)ISTAR2,ISTOP2,ILENEX,ILENFN,IDEL,N3PDEL
9012 FORMAT('ISTAR2,ISTOP2,ILENEX,ILENFN,IDEL,N3PDEL = ',6I4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)ISTART,ISTOP,IFOUNN
9013 FORMAT('ISTART,ISTOP,IFOUNN = ',2I8,3X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)IPOINT,IPOIN1,IPOIN2
9014 FORMAT('IPOINT,IPOIN1,IPOIN2 = ',3I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)IEND
9015 FORMAT('IEND = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9016)(ICH(I),I=1,8)
9016 FORMAT('ICH(.) = ',10A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9017)N3
9017 FORMAT('N3 = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9018)(IFUNC3(I),I=1,MIN(N3,115))
9018 FORMAT('IFUNC3(.) = ',115A1)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPEXP1(ICOM,ICOM2,ICOMT,ICOMI,
1IHARG,IHARG2,IARGT,IARG,NUMARG,
1IEXPSW,
1IEX1CO,IEX1AL,
1IEX2CO,IEX2AL,
1IEX3CO,IEX3AL,
1IEX4CO,IEX4AL,
1IEX5CO,IEX5AL,
1IEXPCO,IEXPAL,
1IANS,IWIDTH,IBUGEX,IBUGE2,ISUBRO,IFOUND,IERROR)
C
C PURPOSE--DETERMINE IF DATAPLOT'S EXPERT SYSTEM
C COMMAND IS BEING INVOKED AND/OR
C DETERMINE IF A USER'S MENU DESIGNATION IS VALID.
C THIS SUBROUTINE IN TURN CALLS DPEXP2
C WHICH READS THE DESIGNATED MENU
C FROM (ONE OF) DATAPLOT'S EXPERT SUB-SYSTEM FILE(S),
C AND WRITES THE MENU OUT TO SCREEN.
C INPUT ARGUMENTS--ICOM ETC.
C OUTPUT ARGUMENTS--IEXPSW, IEXPCO, AND IEXPAL
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--FEBRUARY 1985.
C UPDATED --JANUARY 1986.
C UPDATED --FEBRUARY 1989. FORMATS DUE TO 2X NOS LOWER CASE CHAR
C UPDATED --SEPTEMBER 1993. CHECK:'EXPE' ==> 'EXPERT '
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 ICOM
CHARACTER*4 ICOM2
CHARACTER*4 ICOMT
C
CHARACTER*4 IHARG
CHARACTER*4 IHARG2
CHARACTER*4 IARGT
C
CHARACTER*4 IEXPSW
C
CHARACTER*12 IEX1CO
CHARACTER*4 IEX1AL
C
CHARACTER*12 IEX2CO
CHARACTER*4 IEX2AL
C
CHARACTER*12 IEX3CO
CHARACTER*4 IEX3AL
C
CHARACTER*12 IEX4CO
CHARACTER*4 IEX4AL
C
CHARACTER*12 IEX5CO
CHARACTER*4 IEX5AL
C
CHARACTER*12 IEXPCO
CHARACTER*4 IEXPAL
C
CHARACTER*4 IANS
CHARACTER*4 IBUGEX
CHARACTER*4 IBUGE2
CHARACTER*4 ISUBRO
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 IH11
CHARACTER*4 IH12
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
DIMENSION IHARG(*)
DIMENSION IHARG2(*)
DIMENSION IARGT(*)
DIMENSION IARG(*)
C
DIMENSION IANS(*)
C
C-----COMMON----------------------------------------------------------
C
CCCCC INCLUDE 'DPCOFO.INC'
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='DPEX'
ISUBN2='P1 '
C
IFOUND='NO'
IERROR='NO'
C
IEXPAL='OFF'
C
MAXCPS=12
C
I2=(-999)
C
IF(IBUGEX.EQ.'OFF'.AND.ISUBRO.NE.'EXP1')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPEXP1--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IEXPSW
52 FORMAT('IEXPSW = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,71)IEX1CO,IEX1AL
71 FORMAT('IEX1CO,IEX1AL = ',A12,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,72)IEX2CO,IEX2AL
72 FORMAT('IEX2CO,IEX2AL = ',A12,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,73)IEX3CO,IEX3AL
73 FORMAT('IEX3CO,IEX3AL = ',A12,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,74)IEX4CO,IEX4AL
74 FORMAT('IEX4CO,IEX4AL = ',A12,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,75)IEX5CO,IEX5AL
75 FORMAT('IEX5CO,IEX5AL = ',A12,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,76)IEXPCO,IEXPAL
76 FORMAT('IEXPCO,IEXPAL = ',A12,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,81)IWIDTH
81 FORMAT('IWIDTH = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,82)(IANS(I),I=1,80)
82 FORMAT('(IANS(I),I=1,80) = ',80A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,83)IBUGEX,IBUGE2,IERROR
83 FORMAT('IBUGEX,IBUGE2,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C **************************************************************
C ** STEP 11-- **
C ** DETERMINE IF HAVE AN EXPERT COMMAND, OR **
C ** IF HAVE A MENU RESPONSE NUMBER TO A MENU, OR **
C ** IF HAVE NEITHER. **
C **************************************************************
C
1100 CONTINUE
ISTEPN='11'
IF(IBUGEX.EQ.'ON'.OR.ISUBRO.EQ.'EXP1')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CCCCC THE FOLLOWING LINE WAS CHANGED SEPTEMBER 1993
CCCCC TO AVOID CONFLICT WITH EXPECTED LOSS PLOT SEPTEMBER 1993
CCCCC IF(ICOM.EQ.'EXPE')GOTO1200
IF(ICOM.EQ.'EXPE'.AND.ICOM2.EQ.'RT ')GOTO1200
IF(ICOM.EQ.'.')GOTO9000
IF(ICOM.EQ.' ')GOTO9000
CCCCC IF(NUMARG.LE.0.AND.ICOM.EQ.' ')GOTO2100
IF(NUMARG.LE.0.AND.ICOMT.EQ.'NUMB'.AND.ICOMI.EQ.0)GOTO2300
IF(NUMARG.LE.0.AND.ICOMT.EQ.'NUMB'.AND.ICOMI.GT.0)GOTO1500
IF(NUMARG.LE.0.AND.ICOMT.EQ.'NUMB'.AND.ICOMI.LT.0)GOTO1600
GOTO9000
C
C ***************************************
C ** STEP 12-- **
C ** TREAT THE CASE WHEN HAVE **
C ** AN EXPLICIT EXPERT COMMAND **
C ***************************************
C
1200 CONTINUE
ISTEPN='12'
IF(IBUGEX.EQ.'ON'.OR.ISUBRO.EQ.'EXP1')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(NUMARG.LE.0)GOTO2100
IF(IHARG(1).EQ.'LAST')GOTO2100
IF(IHARG(1).EQ.'?')GOTO2100
IF(IHARG(1).EQ.'ALL')IEXPAL='ON'
IF(IHARG(1).EQ.'ALL')GOTO2100
C
IF(IHARG(1).EQ.'UP')GOTO1300
IF(IHARG(1).EQ.'PRIO')GOTO1300
IF(IHARG(1).EQ.'PREV')GOTO1300
IF(IHARG(1).EQ.'BEFO')GOTO1300
C
GOTO1400
C
C ****************************************
C ** STEP 13 -- **
C ** TREAT THE EXPERT UP # CASE **
C ****************************************
C
1300 CONTINUE
ISTEPN='13'
IF(IBUGEX.EQ.'ON'.OR.ISUBRO.EQ.'EXP1')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IEXPCO.EQ.'0 ')IEXPSW='TOP'
IF(IEXPCO.EQ.'0 ')GOTO2100
IF(IEXPCO.EQ.' ')IEXPSW='TOP'
IF(IEXPCO.EQ.' ')GOTO2100
C
NLOOP=1
IF(NUMARG.GE.2.AND.IARGT(2).EQ.'NUMB')NLOOP=IARG(2)
IF(NLOOP.LE.1)NLOOP=1
C
DO1310ILOOP=1,NLOOP
C
DO1320I=1,MAXCPS
IREV=MAXCPS-I+1
IF(IEXPCO(IREV:IREV).EQ.'.')GOTO1325
IEXPCO(IREV:IREV)=' '
1320 CONTINUE
GOTO1310
1325 CONTINUE
IEXPCO(IREV:IREV)=' '
GOTO1310
C
1310 CONTINUE
GOTO2100
C
C *************************************
C ** STEP 14-- **
C ** TREAT THE EXPERT # CASE **
C *************************************
C
1400 CONTINUE
ISTEPN='14'
IF(IBUGEX.EQ.'ON'.OR.ISUBRO.EQ.'EXP1')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(NUMARG.GE.2.AND.IHARG(1).EQ.'DATA'.AND.
1IHARG(2).EQ.'ANAL')GOTO1490
IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'MATH')GOTO1490
IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'GRAP')GOTO1490
IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'DATA'.AND.
1IHARG2(1).EQ.'PLOT')GOTO1490
C
IH11=IHARG(1)
IH12=IHARG2(1)
IEXPCO(1:4)=IH11(1:4)
IEXPCO(5:8)=IH12(1:4)
IEXPCO(9:12)=' '
C
1490 CONTINUE
GOTO2100
C
C *****************************************
C ** STEP 15-- **
C ** TREAT THE # CASE **
C ** (AS IN RESPONDING TO A MENU **
C ** BY SPECIFYING A MENU ITEM CHOICE) **
C *****************************************
C
1500 CONTINUE
ISTEPN='15'
IF(IBUGEX.EQ.'ON'.OR.ISUBRO.EQ.'EXP1')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IEXPSW.EQ.'TOP')IEXPCO='0 '
IF(IEXPSW.EQ.'TOP')GOTO2100
C
IF(IEXPCO(1:1).EQ.'0')GOTO1510
GOTO1520
C
1510 CONTINUE
I2=0
GOTO1530
C
1520 CONTINUE
DO1525I=1,MAXCPS
I2=I
IF(IEXPCO(I2:I2).EQ.' ')GOTO1526
1525 CONTINUE
GOTO1539
1526 CONTINUE
IEXPCO(I2:I2)='.'
GOTO1530
C
1530 CONTINUE
DO1535J=1,4
I2=I2+1
IF(I2.GT.MAXCPS)GOTO1539
IEXPCO(I2:I2)=ICOM(J:J)
1535 CONTINUE
1539 CONTINUE
GOTO2100
C
C *****************************************
C ** STEP 16-- **
C ** TREAT THE -# CASE **
C ** (AS IN CALLING FOR PRIOR MENUS **
C *****************************************
C
1600 CONTINUE
ISTEPN='16'
IF(IBUGEX.EQ.'ON'.OR.ISUBRO.EQ.'EXP1')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IEXPCO.EQ.'0 ')IEXPSW='TOP'
IF(IEXPCO.EQ.'0 ')GOTO2100
IF(IEXPCO.EQ.' ')IEXPSW='TOP'
IF(IEXPCO.EQ.' ')GOTO2100
C
NLOOP=1
IF(ICOMT.EQ.'NUMB')NLOOP=(-ICOMI)
C
IF(NLOOP.LE.0)GOTO1619
DO1610ILOOP=1,NLOOP
C
DO1620I=1,MAXCPS
IREV=MAXCPS-I+1
IF(IEXPCO(IREV:IREV).EQ.'.')GOTO1621
IEXPCO(IREV:IREV)=' '
1620 CONTINUE
GOTO1610
1621 CONTINUE
IEXPCO(IREV:IREV)=' '
GOTO1610
C
1610 CONTINUE
C
1619 CONTINUE
GOTO2100
C
C *************************************************
C ** STEP 17-- **
C ** STRIP OFF TRAILING PERIOD (IF ONE EXISTS) **
C *************************************************
C
1700 CONTINUE
ISTEPN='17'
IF(IBUGEX.EQ.'ON'.OR.ISUBRO.EQ.'EXP1')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
DO1710I=1,MAXCPS
IREV=MAXCPS-I+1
IF(IEXPCO(IREV:IREV).NE.' ')GOTO1711
1710 CONTINUE
GOTO1790
1711 CONTINUE
IF(IEXPCO(IREV:IREV).EQ.'.')IEXPCO(IREV:IREV)=' '
GOTO1790
1790 CONTINUE
C
C *********************************************
C ** STEP 21-- **
C ** BRANCH BETWEEN THE OVERALL MENU **
C ** OR THE GENERAL MENU WITHIN EACH AREA. **
C *********************************************
C
2100 CONTINUE
ISTEPN='21'
IF(IBUGEX.EQ.'ON'.OR.ISUBRO.EQ.'EXP1')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IFOUND='YES'
IF(IEXPCO.EQ.' ')IEXPCO='0 '
IF(ICOM.EQ.'EXPE'.AND.NUMARG.LE.0)GOTO2200
IF(IEXPSW.EQ.'TOP'.AND.NUMARG.LE.0.AND.
1ICOM.EQ.' ')GOTO2200
IF(IEXPSW.EQ.'TOP'.AND.NUMARG.LE.0.AND.
1ICOMT.EQ.'NUMB'.AND.ICOMI.LE.0)GOTO2200
GOTO2300
C
C **********************************************
C ** STEP 22-- **
C ** WRITE (TO THE SCREEN) THE OVERALL MENU **
C **********************************************
C
2200 CONTINUE
ISTEPN='22'
IF(IBUGEX.EQ.'ON'.OR.ISUBRO.EQ.'EXP1')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IEXPSW='TOP'
C
WRITE(ICOUT,2211)IESCC,IFFC
2211 FORMAT(2A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2212)IESCC
2212 FORMAT(A1,'8')
CALL DPWRST('XXX','BUG ')
C
WRITE(ICOUT,2221)
2221 FORMAT(
* 'Enter HELP EXPERT ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2222)
2222 FORMAT(
*'for a brief description of DATAPLOT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2223)
2223 FORMAT(
*'Expert Subsystem scope ',
* 'and conventions')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2230)
2230 FORMAT(' GENERAL TOPIC AREAS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2231)
2231 FORMAT(' ',
*' 1. Data Analysis ',
*'(partially implemented)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2232)
2232 FORMAT(' ',
*' 2. Mathematics ',
*'(not yet implemented)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2233)
2233 FORMAT(' ',
*' 3. Graphics (not yet implemented)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2234)
2234 FORMAT(' ',
* ' 4. DATAPLOT (not yet implemented)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2241)
2241 FORMAT(
*'To select a menu item, ',
*'enter 1 through 4')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
C ****************************************
C ** STEP 23-- **
C ** READ THE EXPERT FILE **
C ** AND WRITE (TO THE SCREEN) A MENU **
C ****************************************
C
2300 CONTINUE
ISTEPN='23'
IF(IBUGEX.EQ.'ON'.OR.ISUBRO.EQ.'EXP1')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(NUMARG.GE.2.AND.IHARG(1).EQ.'DATA'.AND.
1IHARG(2).EQ.'ANAL')GOTO2331
IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'MATH')GOTO2332
IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'GRAP')GOTO2333
IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'DATA'.AND.
1IHARG2(1).EQ.'PLOT')GOTO2334
C
IF(IEXPSW.EQ.'TOP'.AND.NUMARG.GE.1.AND.
1IARGT(1).EQ.'NUMB')GOTO2310
C
IF(IEXPSW.EQ.'TOP'.AND.NUMARG.EQ.0.AND.
1ICOMT.EQ.'NUMB')GOTO2320
C
GOTO2390
C
2310 CONTINUE
IF(IARG(1).EQ.1)GOTO2331
IF(IARG(1).EQ.2)GOTO2332
IF(IARG(1).EQ.3)GOTO2333
IF(IARG(1).EQ.4)GOTO2334
GOTO2390
C
2320 CONTINUE
IF(ICOMI.EQ.1)GOTO2331
IF(ICOMI.EQ.2)GOTO2332
IF(ICOMI.EQ.3)GOTO2333
IF(ICOMI.EQ.4)GOTO2334
GOTO2390
C
2331 CONTINUE
IEXPSW='DATA'
CCCCC IEXPCO='0 '
GOTO2390
C
2332 CONTINUE
IEXPSW='MATH'
CCCCC IEXPCO='0 '
GOTO2390
C
2333 CONTINUE
IEXPSW='GRAP'
CCCCC IEXPCO='0 '
GOTO2390
C
2334 CONTINUE
IEXPSW='DATP'
CCCCC IEXPCO='0 '
GOTO2390
C
2390 CONTINUE
CALL DPEXP2(IEXPSW,
1IEXPCO,IEXPAL,
1IANS,IWIDTH,IBUGE2,ISUBRO,IFOUND,IERROR)
C
IF(IEXPSW.EQ.'DATA')IEX1CO=IEXPCO
IF(IEXPSW.EQ.'MATH')IEX2CO=IEXPCO
IF(IEXPSW.EQ.'GRAP')IEX3CO=IEXPCO
IF(IEXPSW.EQ.'DATP')IEX4CO=IEXPCO
C
GOTO9000
C
C ****************
C ** STEP 90-- **
C ** EXIT. **
C ****************
C
9000 CONTINUE
IF(IBUGEX.EQ.'OFF'.AND.ISUBRO.NE.'EXP1')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPEXP1--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IEXPSW
9012 FORMAT('IEXPSW = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9031)IEX1CO,IEX1AL
9031 FORMAT('IEX1CO,IEX1AL = ',A12,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9032)IEX2CO,IEX2AL
9032 FORMAT('IEX2CO,IEX2AL = ',A12,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9033)IEX3CO,IEX3AL
9033 FORMAT('IEX3CO,IEX3AL = ',A12,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9034)IEX4CO,IEX4AL
9034 FORMAT('IEX4CO,IEX4AL = ',A12,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9035)IEX5CO,IEX5AL
9035 FORMAT('IEX5CO,IEX5AL = ',A12,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9036)IEXPCO,IEXPAL
9036 FORMAT('IEXPCO,IEXPAL = ',A12,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9049)IBUGEX,IBUGE2,IFOUND,IERROR
9049 FORMAT('IBUGEX,IBUGE2,IFOUND,IERROR = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPEXP2(IEXPSW,
1IEXPCO,IEXPAL,
1IANS,IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR)
C
C PURPOSE--READ THE DESIGNATED MENU
C FROM (ONE OF) DATAPLOT'S EXPERT SUB-SYSTEM FILE(S),
C AND WRITE THE MENU OUT TO SCREEN.
C INPUT ARGUMENTS--IEXPSW (A HOLLARITH VARIABLE
C IDENTIFYING WHICH SUB-SYSTEM.
C --IEXPCO (A HOLLARITH VARIABLE
C CONTAINING A MENU IDENTIFICATION STRING.
C --IEXPAL (A HOLLARITH VARIABLE (ON/OFF)
C CONTAINING A SWITCH SETTING AS TO WHETHER
C ALL OF THE TOPIC MENU SHOULD BE PRINTED OUT.
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--FEBRAURY 1985.
C UPDATED --JANUARY 1986.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IEXPSW
CHARACTER*12 IEXPCO
CHARACTER*4 IEXPAL
C
CHARACTER*4 IANS
CHARACTER*4 IBUGS2
CHARACTER*4 ISUBRO
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*80 IFILE
CHARACTER*12 ISTAT
CHARACTER*12 IFORM
CHARACTER*12 IACCES
CHARACTER*12 IPROT
CHARACTER*12 ICURST
CHARACTER*4 ISUBN0
CHARACTER*4 IERRFI
CHARACTER*4 IENDFI
CHARACTER*4 IREWIN
C
CHARACTER*12 ITABID
C
CHARACTER*80 ICTEXT
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
DIMENSION ITABID(500)
DIMENSION ITABLN(500)
C
DIMENSION IANS(*)
C
C-----COMMON----------------------------------------------------------
C
CCCCC INCLUDE 'DPCOFO.INC'
INCLUDE 'DPCOF2.INC'
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
NUMSEC=(-999)
JSEC=(-999)
ISKIP=(-999)
ISTART=(-999)
I2=(-999)
C
IFOUND='YES'
IERROR='NO'
C
ISUBN1='DPEX'
ISUBN2='P2 '
C
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'EXP2')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPEXP2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IEXPSW
52 FORMAT('IEXPSW = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)IEXPCO,IEXPAL
53 FORMAT('IEXPCO,IEXPAL = ',A12,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,55)IBUGS2,ISUBRO,IERROR
55 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C **************************
C ** STEP 11-- **
C ** COPY OVER VARIABLES **
C **************************
C
ISTEPN='11'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXP2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IEXPSW.EQ.'DATA')GOTO1110
IF(IEXPSW.EQ.'MATH')GOTO1120
IF(IEXPSW.EQ.'GRAP')GOTO1130
IF(IEXPSW.EQ.'DATP')GOTO1140
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1101)
1101 FORMAT('***** INTERNAL ERROR IN DPEXP2 ',
1'AT BRANCH POINT 1101--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1102)
1102 FORMAT(' IEXPSW SHOULD BE ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1103)
1103 FORMAT(' DATA, MATH, GRAP, OR DATP, ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1104)
1104 FORMAT(' BUT IS NOT.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1105)IEXPSW
1105 FORMAT(' IEXPSW = ',A4)
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
1110 CONTINUE
IOUNIT=IEX1NU
IFILE=IEX1NA
ISTAT=IEX1ST
IFORM=IEX1FO
IACCES=IEX1AC
IPROT=IEX1PR
ICURST=IEX1CS
ISUBN0='EXP2'
IERRFI='NO'
GOTO1190
C
1120 CONTINUE
IOUNIT=IEX2NU
IFILE=IEX2NA
ISTAT=IEX2ST
IFORM=IEX2FO
IACCES=IEX2AC
IPROT=IEX2PR
ICURST=IEX2CS
ISUBN0='EXP2'
IERRFI='NO'
GOTO1190
C
1130 CONTINUE
IOUNIT=IEX3NU
IFILE=IEX3NA
ISTAT=IEX3ST
IFORM=IEX3FO
IACCES=IEX3AC
IPROT=IEX3PR
ICURST=IEX3CS
ISUBN0='EXP2'
IERRFI='NO'
GOTO1190
C
1140 CONTINUE
IOUNIT=IEX4NU
IFILE=IEX4NA
ISTAT=IEX4ST
IFORM=IEX4FO
IACCES=IEX4AC
IPROT=IEX4PR
ICURST=IEX4CS
ISUBN0='EXP2'
IERRFI='NO'
GOTO1190
C
1190 CONTINUE
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'EXP2')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)IBUGS2,ISUBRO,ISUBN0,IERRFI
1196 FORMAT('IBUGS2,ISUBRO,ISUBN0,IERRFI = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
1199 CONTINUE
C
C ***********************************************
C ** STEP 12-- **
C ** CHECK TO SEE IF THIS EXPERT FILE EXISTS **
C ***********************************************
C
ISTEPN='12'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXP2')
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 DPEXP2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1212)
1212 FORMAT(' THE EXPERT SUB-SYSTEM')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1213)
1213 FORMAT(' CANNOT BE ENTERED FOR THIS TOPIC 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 EXPERT MENUS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1216)
1216 FORMAT(' IS NOT YET AVAILABLE FOR THIS TOPIC.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1217)ISTAT,IEXPSW
1217 FORMAT('ISTAT,IEXPSW = ',A12,2X,A12)
CALL DPWRST('XXX','BUG ')
GOTO9000
1290 CONTINUE
C
C *********************
C ** STEP 20-- **
C ** OPEN THE FILE **
C *********************
C
ISTEPN='20'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXP2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IREWIN='ON'
CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
IF(IERRFI.EQ.'YES')GOTO9000
C
C ************************************************************
C ** STEP 41-- **
C ** READ IN FILE INFORMATION **
C ** FROM THE BEGINNING LINES OF THE FILE. **
C ** THESE LEAD LINES CONTAIN **
C ** THE STARTING LINE NUMBER OF EACH SECTION **
C ** IN THE FILE (ATABLN) (F10.0 FORMAT), AND **
C ** THE IDENTIFIER FOR EACH SECTION **
C ** IN THE FILE (ITABID(.) (A12 FORMAT). **
C ************************************************************
C
NUMSEC=0
DO4120I=1,100000
READ(IOUNIT,4121,END=4180)ATABLN,ITABID(I)
4121 FORMAT(F10.0,A12)
IF(ITABID(I).EQ.' ')GOTO4129
NUMSEC=NUMSEC+1
ITABLN(I)=ATABLN+0.5
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXP2')
1WRITE(ICOUT,4122)I,ATABLN,ITABLN(I),ITABID(I)
4122 FORMAT('I,ATABLN,ITABLN(I),ITABID(I) = ',I8,E15.7,I8,2X,A12)
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXP2')
1CALL DPWRST('XXX','BUG ')
4120 CONTINUE
4129 CONTINUE
ANUMSE=NUMSEC
GOTO4190
C
4180 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4181)
4181 FORMAT('***** INTERNAL ERROR IN DPEXP2 ',
1'AT BRANCH POINT 4181--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4182)
4182 FORMAT(' AN UNEXPECTED END OF FILE WAS ENCOUNTERED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4183)
4183 FORMAT(' WHILE READING THE LOOK-UP TABLE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4184)
4184 FORMAT(' WITHIN A DATAPLOT EXPERT SUB-SYSTEM FILE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4185)IFILE
4185 FORMAT(' IFILE = ',A80)
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
4190 CONTINUE
C
C *******************************************************
C ** STEP 42-- **
C ** BASED ON THE CODE STRING IN IEXPCO **
C ** DO A TABLE LOOK-UP WHICH WILL SPECIFY **
C ** THE ABSOLUTE LINE NUMBER IN THE FILE **
C ** WHERE THE SECTION WITH THAT CODE WORD STARTS **
C *******************************************************
C
ISTEPN='42'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXP2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
DO4200I=1,NUMSEC
I2=I
IF(IEXPCO.EQ.ITABID(I))GOTO4210
4200 CONTINUE
JSEC=1
4210 CONTINUE
JSEC=I2
C
ISTART=ITABLN(JSEC)
C
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'EXP2')GOTO4290
WRITE(ICOUT,4211)
4211 FORMAT('***** FROM 4211 IN MIDDLE OF DPEXP2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4213)JSEC,ISTART
4213 FORMAT('JSEC,ISTART = ',2I8)
CALL DPWRST('XXX','BUG ')
4290 CONTINUE
C
C *************************************************
C ** STEP 43-- **
C ** READ DOWN IN THE FILE TO **
C ** THE LINE BEFORE WHERE THE SECTION STARTS **
C *************************************************
C
ISTEPN='43'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXP2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
REWIND(IOUNIT)
C
ISKIP=ISTART-1
IF(ISKIP.LE.0)GOTO4319
DO4310I=1,ISKIP
READ(IOUNIT,4315,END=4380)
4315 FORMAT()
4310 CONTINUE
4319 CONTINUE
GOTO4390
C
4380 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4381)
4381 FORMAT('***** INTERNAL ERROR IN DPEXP2 ',
1'AT BRANCH POINT 4381--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4382)
4382 FORMAT(' AN UNEXPECTED END OF FILE WAS ENCOUNTERED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4383)
4383 FORMAT(' WHILE CARRYING OUT SKIPS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4384)
4384 FORMAT(' WITHIN A DATAPLOT EXPERT SUB-SYSTEM FILE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4385)IFILE
4385 FORMAT(' IFILE = ',A80)
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
4390 CONTINUE
C
C ***************************************************
C ** STEP 45-- **
C ** FOR THIS TARGET SECTION-- **
C ** 1) SKIP OVER 2 HEADER LINES **
C ** 2) READ IN (AND WRITE OUT) THE TEXT **
C ** FOR THE SECTION-- **
C ** (THIS IS WHAT THE ANALYST WILL SEE **
C ** ON THE SCREEN). **
C ** THE LAST LINE OF THE TEXT IS **
C ** A LINE OF HYPHENS (THIS LINE IS **
C ** NOT PRINTED OUT). **
C ** 3) READ IN (AND STORE) THE NUMBER OF **
C ** MENU ITEMS THAT WERE OFFERED **
C ** 4) READ IN (AND STORE) THE CODE WORD **
C ** (= SUBSEQUENT BRANCH POINT) **
C ** FOR EACH MENU ITEM **
C ***************************************************
C
ISTEPN='45'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXP2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
READ(IOUNIT,4505,END=4580)
4505 FORMAT()
READ(IOUNIT,4505,END=4580)
C
WRITE(ICOUT,4511)IESCC,IFFC
4511 FORMAT(2A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4512)IESCC
4512 FORMAT(A1,'8')
CALL DPWRST('XXX','BUG ')
C
CCCCC WRITE(ICOUT,4513)IEXPCO
C4513 FORMAT(58X,A12)
CCCCC CALL DPWRST('XXX','BUG ')
C
DO4520I=1,100000
C
READ(IOUNIT,4521,END=4580)ICTEXT
4521 FORMAT(A80)
CCCCC IF(ICTEXT(1:5).EQ.'SSSSS')GOTO4590 DECEMBER 1986
CCCCC IF(ICTEXT(1:5).EQ.'EEEEE')GOTO4590 DECEMBER 1986
IF(ICTEXT(1:5).EQ.'-----')GOTO4590
C
DO4530J=1,80
JREV=80-J+1
IF(ICTEXT(JREV:JREV).NE.' ')GOTO4535
4530 CONTINUE
JREV=1
4535 CONTINUE
IF(JREV.LE.0)WRITE(ICOUT,999)
IF(JREV.LE.0)CALL DPWRST('XXX','BUG ')
IF(JREV.GE.1)WRITE(ICOUT,4536)(ICTEXT(K:K),K=1,JREV)
4536 FORMAT(80A1)
IF(JREV.GE.1)CALL DPWRST('XXX','BUG ')
C
4520 CONTINUE
C
4580 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4581)
4581 FORMAT('***** INTERNAL ERROR IN DPEXP2 ',
1'AT BRANCH POINT 4581--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4582)
4582 FORMAT(' AN UNEXPECTED END OF FILE WAS ENCOUNTERED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4583)
4583 FORMAT(' WHILE READING WITHIN THE TARGET SECTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4584)
4584 FORMAT(' WITHIN A DATAPLOT EXPERT SUB-SYSTEM FILE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4585)IFILE
4585 FORMAT(' IFILE = ',A80)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,4586)JSEC,ISTART
4586 FORMAT('JSEC,ISTART = ',2I8)
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO5000
4589 CONTINUE
C
4590 CONTINUE
C
C **************************************
C ** STEP 50-- **
C ** CLOSE THIS EXPERT FILE. **
C **************************************
C
5000 CONTINUE
C
ISTEPN='50'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXP2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IENDFI='OFF'
IREWIN='ON'
CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
IF(IERRFI.EQ.'YES')GOTO9000
C
C ****************
C ** STEP 90-- **
C ** EXIT. **
C ****************
C
9000 CONTINUE
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'EXP2')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPEXP2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGS2,ISUBRO,IERROR
9012 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9021)IOUNIT
9021 FORMAT('IOUNIT = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9022)IFILE
9022 FORMAT('IFILE = ',A80)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9023)ISTAT
9023 FORMAT('ISTAT = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9024)IFORM
9024 FORMAT('IFORM = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9025)IACCES
9025 FORMAT('IACCES = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9026)IPROT
9026 FORMAT('IPROT = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9027)ICURST
9027 FORMAT('ICURST = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9028)IENDFI
9028 FORMAT('IENDFI = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9029)IREWIN
9029 FORMAT('IREWIN = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9031)ISUBN0
9031 FORMAT('ISUBN0 = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9032)IERRFI
9032 FORMAT('IERRFI = ',A12)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9051)ISKIP,ISTART,I2
9051 FORMAT('ISKIP,ISTART,I2 = ',3I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9052)IEXPSW
9052 FORMAT('IEXPSW = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9054)IEXPCO,IEXPAL
9054 FORMAT('IEXPCO,IEXPAL = ',A12,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9061)NUMSEC
9061 FORMAT('NUMSEC = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9062)JSEC,ITABLN(JSEC),ITABID(JSEC)
9062 FORMAT('JSEC,ITABLN(JSEC),ITABID(JSEC) = ',2I8,2X,A12)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,
1IHARG,IHARG2,NUMARG,
1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM,
1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILLOUT,IVOUT,VOUT,IUOUT,
1INOUT,IBUGA3,IERROR)
C
C PURPOSE--SCAN THE ARGUMENTS OF THE COMMAND LINE
C FOR A KEY WORD AND EXTRACT INFORMATION
C ABOUT A SELECTED ARGUMENT AFTER THE KEY WORD.
C
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-921-3651
C NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C OF THE NATIONAL BUREAU OF STANDARDS.
C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C MODIFIED, OR OTHERWISE USED IN A CONTEXT
C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--82/7
C ORIGINAL VERSION--JANUARY 1979.
C UPDATED --MARCH 1979.
C UPDATED --JULY 1981.
C UPDATED --MAY 1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IKEY
CHARACTER*4 IKEY2
CHARACTER*4 IHARG
CHARACTER*4 IHARG2
CHARACTER*4 INCLUN
CHARACTER*4 IANS
CHARACTER*4 IHNAME
CHARACTER*4 IHNAM2
CHARACTER*4 IUSE
CHARACTER*4 IFOUN1
CHARACTER*4 IFOUN2
CHARACTER*4 IHOUT
CHARACTER*4 IHOUT2
CHARACTER*4 IUOUT
CHARACTER*4 IBUGA3
CHARACTER*4 IERROR
C
CHARACTER*4 IVALID
CHARACTER*4 IANS2
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
DIMENSION IHARG(*)
DIMENSION IHARG2(*)
DIMENSION IANS(*)
DIMENSION IHNAME(*)
DIMENSION IHNAM2(*)
DIMENSION IVALUE(*)
DIMENSION VALUE(*)
DIMENSION IUSE(*)
DIMENSION IN(*)
C
DIMENSION IANS2(50)
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='DPEX'
ISUBN2='QU '
C
IF(IBUGA3.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPEXQU--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IKEY,IKEY2,ISHIFT,ILOCA,ILOCB
52 FORMAT('IKEY,IKEY2,ISHIFT,ILOCA,ILOCB = ',A4,A4,I8,2X,I8,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)IWIDTH
53 FORMAT('IWIDTH = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)(IANS(I),I=1,IWIDTH)
54 FORMAT('IANS(.) = ',120A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,55)NUMARG
55 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
DO57I=1,NUMARG
WRITE(ICOUT,58)I,IHARG(I),IHARG2(I)
58 FORMAT('I,IHARG(I),IHARG2(I) = ',I8,2X,A4,A4)
CALL DPWRST('XXX','BUG ')
57 CONTINUE
90 CONTINUE
C
C **********************************
C ** STEP 1-- **
C ** INITIALIZE SOME VARIABLES. **
C **********************************
C
ISTEPN='1'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IFOUN1='NO'
IFOUN2='NO'
IHOUT='JUNK'
IHOUT2='JUNK'
ILLOUT=-99
IVOUT=-99
VOUT=-99
IUOUT='U'
INOUT=-99
IERROR='NO'
C
C *****************************************
C ** STEP 2-- **
C ** SEARCH THE COMMAND LINE ARGUMENTS **
C ** FOR THE WORD CONTAINED IN IKEY. **
C ** STORE THE LOCATION IN ILOC1. **
C *****************************************
C
ISTEPN='2'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
DO200I=ILOCA,ILOCB
I2=I
IF(IHARG(I).EQ.IKEY.AND.IHARG2(I).EQ.IKEY2)GOTO210
200 CONTINUE
IFOUN1='NO'
IFOUN2='NO'
GOTO9000
210 CONTINUE
IFOUN1='YES'
ILOC1=I2
C
C ***************************************************
C ** STEP 3-- **
C ** SEARCH FOR THE COMMAND LINE ARGUMENT **
C ** SHIFTED ISHIFT ARGUMENTS TO THE RIGHT **
C ** OF THE KEY WORD. **
C ** STORE THE LOCATION IN ILOC2. **
C ** STORE THE FOUND WORD IN IHOUT. **
C ***************************************************
C
ISTEPN='3'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
I2=I2+ISHIFT
IF(ILOCA.LE.I2.AND.I2.LE.ILOCB)GOTO310
IFOUN2='NO'
GOTO9000
310 CONTINUE
IFOUN2='YES'
ILOC2=I2
IHOUT=IHARG(ILOC2)
IHOUT2=IHARG2(ILOC2)
C
C **************************************************************
C ** STEP 4-- **
C ** DETERMINE THE CHARACTERISTICS OF **
C ** THIS SECOND ARGUMENT-- **
C ** ILLOUT = LINE NUMBER IN IHNAME(.)LIST; **
C ** IVOUT = INTEGER VALUE ASSOCIATED WITH IT **
C ** (E.G., COLUMN NUMBER FOR A VARIABLE); **
C ** VOUT = FLOATING POINT VALUE ASSOCIATED WITH IT **
C ** (E.G., VALUE OF A PARAMETER OR CONSTANT); **
C ** IUOUT = TYPE OF ARGUMENT **
C ** (V = VARIABLE, P = PARAMETER, **
C ** C = CONSTANT, U = UNKNOWN); **
C ** INOUT = INTEGER VALUE DENOTING **
C ** THE NUMBER OF OBSERVATIONS IN THE COLUMN **
C ** FOR A VARIABLE. **
C **************************************************************
C
ISTEPN='4'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C *****************************************
C ** STEP 4.1-- **
C ** SEARCH FOR VARIABLE OR PARAMETER. **
C *****************************************
C
IF(NUMNAM.LE.0)GOTO408
DO400I=1,NUMNAM
I2=I
CCCCC IF(INCLUN.EQ.'NO'.AND.IHNAME(I).EQ.'1 '.AND.
CCCCC1IHNAM2(I).EQ.' '.AND.IUSE(I).EQ.'V')GOTO400
CCCCC IF(INCLUN.EQ.'NO'.AND.IHNAME(I).EQ.'2 '.AND.
CCCCC1IHNAM2(I).EQ.' '.AND.IUSE(I).EQ.'V')GOTO400
CCCCC IF(INCLUN.EQ.'NO'.AND.IHNAME(I).EQ.'3 '.AND.
CCCCC1IHNAM2(I).EQ.' '.AND.IUSE(I).EQ.'V')GOTO400
CCCCC IF(INCLUN.EQ.'NO'.AND.IHNAME(I).EQ.'4 '.AND.
CCCCC1IHNAM2(I).EQ.' '.AND.IUSE(I).EQ.'V')GOTO400
CCCCC IF(INCLUN.EQ.'NO'.AND.IHNAME(I).EQ.'5 '.AND.
CCCCC1IHNAM2(I).EQ.' '.AND.IUSE(I).EQ.'V')GOTO400
CCCCC IF(INCLUN.EQ.'NO'.AND.IHNAME(I).EQ.'6 '.AND.
CCCCC1IHNAM2(I).EQ.' '.AND.IUSE(I).EQ.'V')GOTO400
CCCCC IF(INCLUN.EQ.'NO'.AND.IHNAME(I).EQ.'7 '.AND.
CCCCC1IHNAM2(I).EQ.' '.AND.IUSE(I).EQ.'V')GOTO400
CCCCC IF(INCLUN.EQ.'NO'.AND.IHNAME(I).EQ.'8 '.AND.
CCCCC1IHNAM2(I).EQ.' '.AND.IUSE(I).EQ.'V')GOTO400
CCCCC IF(INCLUN.EQ.'NO'.AND.IHNAME(I).EQ.'9 '.AND.
CCCCC1IHNAM2(I).EQ.' '.AND.IUSE(I).EQ.'V')GOTO400
CCCCC IF(INCLUN.EQ.'NO'.AND.IHNAME(I).EQ.'10 '.AND.
CCCCC1IHNAM2(I).EQ.' '.AND.IUSE(I).EQ.'V')GOTO400
IF(IHOUT.EQ.IHNAME(I).AND.IHOUT2.EQ.IHNAM2(I).AND.
1IUSE(I).EQ.'P')GOTO409
IF(IHOUT.EQ.IHNAME(I).AND.IHOUT2.EQ.IHNAM2(I).AND.
1IUSE(I).EQ.'V')GOTO409
400 CONTINUE
408 CONTINUE
GOTO419
409 CONTINUE
C
ILLOUT=I2
IVOUT=IVALUE(I2)
VOUT=VALUE(I2)
IUOUT=IUSE(I2)
INOUT=IN(I2)
GOTO9000
419 CONTINUE
C
C **************************************************************
C ** STEP 4.2-- **
C ** EXTRACT THE 1H HOLLERITH REPRESENTATION **
C ** OF IHOUT. **
C ** COPY ALSO THE 1H CONTINUATION OF THE WORD IF EXISTENT. **
C **************************************************************
C
ISTEPN='4.2'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CALL DPWDST(IKEY,IKEY2,ISHIFT,IHOUT,IHOUT2,IANS,IWIDTH,
1IANS2,N2,IBUGA3,IERROR)
C
C ********************************
C ** STEP 4.3-- **
C ** TREAT THE CONSTANT CASE. **
C ********************************
C
ISTEPN='4.3'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CALL DPHOCO(IANS2,N2,IVALID,VALCON,IBUGA3,IERROR)
IF(IVALID.EQ.'YES')GOTO460
GOTO469
460 CONTINUE
IVOUT=VALCON
VOUT=VALCON
IUOUT='N'
INOUT=0
GOTO9000
469 CONTINUE
C
C *********************************************
C ** STEP 4.4-- **
C ** TREAT THE ELEMENT OF A VARIABLE CASE. **
C *********************************************
C
ISTEPN='4.4'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CCCCC CALL DPHOEV(IANS2,N2,IV,IHNAME,IHNAM2,IUSE,IVALUE,VALUE,
CCCCC1IUSE,NUMNAM,IFOUND,VALEV,IBUGA3,IERROR)
CCCCC IF(IFOUND.EQ.'YES')GOTO475
CCCCC GOTO479
CC475 CONTINUE
CCCCC IVOUT=VALEV
CCCCC VOUT=VALEV
CCCCC IVOUT='EV'
CCCCC INOUT=0
CCCCC GOTO9000
CC479 CONTINUE
CCCCCC
CCCCC IUOUT='U'
CC489 CONTINUE
C
C ****************
C ** STEP 90-- **
C ** EXIT. **
C ****************
C
9000 CONTINUE
C
IF(IBUGA3.EQ.'OFF')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPEXQU--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)ILOC1,ILOC2,IFOUN1,IFOUN2
9012 FORMAT('ILOC1,ILOC2,IFOUN1,IFOUN2 = ',I8,I8,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)IHOUT,IHOUT2,ILLOUT,IVOUT,VOUT,IUOUT,INOUT
9013 FORMAT('IHOUT,IHOUT2,ILLOUT,IVOUT,VOUT,IUOUT,INOUT = ',
1A4,A4,I8,I8,E15.7,2X,A4,2X,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)IERROR
9014 FORMAT('IERROR = ',A4)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPEXS1(ISTRIN,ISTART,ISTOP,K,MESSAG,
1ICOL1,ICOL2,ISTRI2,NCSTR2,
1IBUGS2,ISUBRO,IERROR)
C
C PURPOSE--SCAN THE CHARACTER*130 STRING ISTRIN
C BETWEEN COLUMNS ISTART TO ISTOP
C AND EXTRACT THE K-TH STRING.
C DEBLANK THIS STRING, PLACE IT INTO
C THE CHARACTER*130 STRING ISTRI2,
C AND PLACE THE LENGTH OF
C THE STRING INTO NCSTR2.
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--JANUARY 1988.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*130 ISTRIN
CHARACTER*130 ISTRI2
CHARACTER*4 IBUGS2
CHARACTER*4 ISUBRO
CHARACTER*4 IERROR
C
CHARACTER*4 MESSAG
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='DPEX'
ISUBN2='S1 '
C
IERROR='NO'
C
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'EXS1')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPEXS1--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)MESSAG,IBUGS2,ISUBRO,IERROR
53 FORMAT('MESSAG,IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)(ISTRIN(J:J),J=1,100)
54 FORMAT('(ISTRIN(J:J),J=1,100) = ',100A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,55)ISTART,ISTOP
55 FORMAT('ISTART,ISTOP = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,56)K
56 FORMAT('K = ',I8)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C **************************************
C ** STEP 11-- **
C ** INITIALIZE THE OUTPUT VARIABLES **
C **************************************
C
ISTEPN='11'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXS1')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
DO1100I=1,130
ISTRI2(I:I)=' '
1100 CONTINUE
NCSTR2=0
C
C *******************************************
C ** STEP 12-- **
C ** CHECK THE INPUT ARGUMENTS **
C *******************************************
C
ISTEPN='12'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXS1')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(ISTART.GE.1.AND.ISTOP.GE.1.AND.
1 ISTART.LE.130.AND.ISTOP.LE.130)GOTO1219
IF(MESSAG.EQ.'OFF')GOTO1218
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1211)
1211 FORMAT('***** ERROR IN DPEXS1--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1212)
1212 FORMAT(' ISTART OR ISTOP IS < 1 OR > 130. ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1213)ISTART
1213 FORMAT(' ISTART = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1214)ISTOP
1214 FORMAT(' ISTOP = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1216)(ISTRIN(I:I),I=1,100)
1216 FORMAT(' (ISTRIN(I:I),I=1,100) = ',100A1)
CALL DPWRST('XXX','BUG ')
1218 CONTINUE
IERROR='YES'
GOTO9000
1219 CONTINUE
C
IF(ISTART.LE.ISTOP)GOTO1229
IF(MESSAG.EQ.'OFF')GOTO1228
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1221)
1221 FORMAT('***** ERROR IN DPEXS1--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1222)
1222 FORMAT(' ISTART EXCEEDS ISTOP')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1223)ISTART
1223 FORMAT(' ISTART = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1224)ISTOP
1224 FORMAT(' ISTOP = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1216)(ISTRIN(I:I),I=1,100)
1226 FORMAT(' (ISTRIN(I:I),I=1,100) = ',100A1)
CALL DPWRST('XXX','BUG ')
1228 CONTINUE
IERROR='YES'
GOTO9000
1229 CONTINUE
C
IF(K.GE.1)GOTO1239
IF(MESSAG.EQ.'OFF')GOTO1238
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1231)
1231 FORMAT('***** ERROR IN DPEXS1--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1232)
1232 FORMAT(' K IS LESS THAN 1 .')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1233)K
1233 FORMAT(' K = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1236)(ISTRIN(I:I),I=1,100)
1236 FORMAT(' (ISTRIN(I:I),I=1,100) = ',100A1)
CALL DPWRST('XXX','BUG ')
1238 CONTINUE
IERROR='YES'
GOTO9000
1239 CONTINUE
C
C ************************************************
C ** STEP 21-- **
C ** IDENTIFY THE COLUMNS WHERE **
C ** THE K -TH STRING RESIDES **
C ** ICOL1 = START COLUMN OF A STRING **
C ** ICOL2 = STOP COLUMN OF A STRING **
C ************************************************
C
ICOL2=ISTART-1
DO2100ILOOP=1,K
C
ICOL1=ISTOP+1
IMIN=ICOL2+1
IF(IMIN.GT.ISTOP)GOTO2119
DO2110I=IMIN,ISTOP
I2=I
IF(ISTRIN(I:I).NE.' ')GOTO2115
2110 CONTINUE
ICOL1=ISTOP+1
GOTO2119
2115 CONTINUE
ICOL1=I2
GOTO2119
2119 CONTINUE
C
ICOL2=ISTOP
IMIN=ICOL1+1
IF(IMIN.GT.ISTOP)GOTO2129
DO2120I=IMIN,ISTOP
I2=I
IF(ISTRIN(I:I).EQ.' ')GOTO2125
2120 CONTINUE
ICOL2=ISTOP
GOTO2129
2125 CONTINUE
ICOL2=I2-1
GOTO2129
2129 CONTINUE
IF(ICOL1.GE.ISTART.AND.ICOL2.GE.ISTART.AND.
1 ICOL1.LE.ISTOP.AND.ICOL2.LE.ISTOP)GOTO2139
IF(MESSAG.EQ.'OFF')GOTO2138
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2131)
2131 FORMAT('***** ERROR IN DPEXS1--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2132)
2132 FORMAT(' ICOL1 OR ICOL2 IS < ISTART OR > ISTOP. ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2133)ICOL1
2133 FORMAT(' ICOL1 = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2134)ICOL2
2134 FORMAT(' ICOL2 = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2135)ISTART
2135 FORMAT(' ISTART = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2136)ISTOP
2136 FORMAT(' ISTOP = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2137)(ISTRIN(I:I),I=1,100)
2137 FORMAT(' (ISTRIN(I:I),I=1,100) = ',100A1)
CALL DPWRST('XXX','BUG ')
2138 CONTINUE
IERROR='YES'
GOTO9000
2139 CONTINUE
C
IF(ICOL1.LE.ICOL2)GOTO2149
IF(MESSAG.EQ.'OFF')GOTO2148
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2141)
2141 FORMAT('***** ERROR IN DPEXS1--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2142)
2142 FORMAT(' ICOL1 EXCEEDS ICOL2')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2143)ICOL1
2143 FORMAT(' ICOL1 = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2144)ICOL2
2144 FORMAT(' ICOL2 = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1216)(ISTRIN(I:I),I=1,100)
2146 FORMAT(' (ISTRIN(I:I),I=1,100) = ',100A1)
CALL DPWRST('XXX','BUG ')
2148 CONTINUE
IERROR='YES'
GOTO9000
2149 CONTINUE
C
2100 CONTINUE
C
C *********************************************
C ** STEP 22-- **
C ** COPY THE K -TH STRING INTO ISTRI2 **
C *********************************************
C
ISTEPN='22'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXS1')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
J=0
DO2200I=ICOL1,ICOL2
J=J+1
ISTRI2(J:J)=ISTRIN(I:I)
2200 CONTINUE
NCSTR2=J
C
C ****************
C ** STEP 90-- **
C ** EXIT. **
C ****************
C
9000 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'EXS1')GOTO9090
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPEXS1--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)MESSAG,IBUGS2,ISUBRO,IERROR
9013 FORMAT('MESSAG,IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)(ISTRIN(J:J),J=1,100)
9014 FORMAT('(ISTRIN(J:J),J=1,100) = ',100A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)ISTART,ISTOP
9015 FORMAT('ISTART,ISTOP = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9016)K
9016 FORMAT('K = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9021)ICOL1,ICOL2
9021 FORMAT('ICOL1, ICOL2 = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9022)NCSTR2
9022 FORMAT('NCSTR2 = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NCSTR2.GE.1)WRITE(ICOUT,9023)(ISTRI2(I:I),I=1,NCSTR2)
9023 FORMAT('(ISTRI2(I:I),I=1,NCSTR2) = ',100A1)
IF(NCSTR2.GE.1)CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPEXS2(IFOLOC,IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,
1IANS,IWIDTH,
1IHPN,IHPN2,ASTART,AINC,ASTOP,NUMINC,ILALOC,IBUGA3,IFOUND,IERROR)
C
C NOTE--THIS SUBROUTINE IS IDENTICAL TO SUBROUTINE DPEXSE
C AND HAS BEEN CREATED SO AS TO ACHIEVE
C STORAGE ECONOMY IN THE MAPPING/LOADING.
C
C PURPOSE--EXTRACT THE SEQUENCE OF VALUES
C AS DICTATED BY A FOR SPECIFICATION.
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-921-3651
C NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C OF THE NATIONAL BUREAU OF STANDARDS.
C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C MODIFIED, OR OTHERWISE USED IN A CONTEXT
C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--82/7
C ORIGINAL VERSION--OCTOBER 1981.
C UPDATED --NOVEMBER 1981.
C UPDATED --MARCH 1982.
C UPDATED --MAY 1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IHARG
CHARACTER*4 IHARG2
CHARACTER*4 IARGT
CHARACTER*4 IANS
CHARACTER*4 IHPN
CHARACTER*4 IHPN2
CHARACTER*4 IBUGA3
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 IVDU11
CHARACTER*4 IVDU12
CHARACTER*4 IVDU21
CHARACTER*4 IVDU22
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
DIMENSION IANS(*)
C
DIMENSION IHARG(*)
DIMENSION IHARG2(*)
DIMENSION IARGT(*)
DIMENSION IARG(*)
DIMENSION ARG(*)
C
C
C---------------------------------------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
ISUBN1='DPEX'
ISUBN2='S2 '
C
IERROR='NO'
IFOUND='NO'
C
IFOUND='YES'
C
IF(IBUGA3.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPEXS2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IFOLOC
52 FORMAT('IFOLOC = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)NUMARG
54 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
DO55I=1,NUMARG
WRITE(ICOUT,56)I,IHARG(I),IHARG2(I),ARG(I)
56 FORMAT('I,IHARG(I),IHARG2(I),ARG(I) = ',I8,2X,A4,2X,A4,E15.7)
CALL DPWRST('XXX','BUG ')
55 CONTINUE
90 CONTINUE
C
C *******************************************************
C ** STEP 3-- **
C ** DETERMINE THE NAME OF THE NEXT DUMMY VARIABLE **
C ** (IT NEVER GETS STORED PERMANENTLY) **
C ** IMMEDIATELY FOLLOWING THE 'FOR' KEYWORD **
C *******************************************************
C
ISTEPN='3'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IFOLOC.LT.NUMARG)GOTO3139
WRITE(ICOUT,3121)
3121 FORMAT('***** ERROR IN DPEXS2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3122)
3122 FORMAT(' THE FOR WAS THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3123)
3123 FORMAT(' FINAL WORD ON THE COMMAND LINE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3124)
3124 FORMAT(' THE WORD FOR SHOULD HAVE BEEN FOLLOWED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3125)
3125 FORMAT(' BY 5 WORDS --')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3126)
3126 FORMAT(' 1) A DUMMY VARIABLE NAME;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3127)
3127 FORMAT(' 2) AN EQUAL SIGN;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3128)
3128 FORMAT(' 3) ONE LIMIT (LOWER OR UPPER) ',
1'FOR THE DUMMY VARIABLE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3129)
3129 FORMAT(' 4) THE INCREMENT FOR THE DUMMY VARIABLE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3130)
3130 FORMAT(' 5) THE OTHER LIMIT (UPPER OR LOWER) ',
1'FOR THE DUMMY VARIABLE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3136)
3136 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,3137)(IANS(I),I=1,IWIDTH)
3137 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
3139 CONTINUE
IFOLP1=IFOLOC+1
IVDU11=IHARG(IFOLP1)
IVDU12=IHARG2(IFOLP1)
C
C *******************************************************
C ** STEP 3.1-- **
C ** DETERMINE THE NAME OF THE DUMMY VARIABLE **
C ** (IT NEVER GETS STORED PERMANENTLY) **
C ** IMMEDIATELY FOLLOWING THE 'FOR' KEYWORD **
C *******************************************************
C
ISTEPN='3.1'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IFOLP2=IFOLOC+2
IF(IFOLOC.GT.NUMARG)GOTO3159
IF(IHARG(IFOLOC).EQ.'FOR')GOTO3169
C3150 CONTINUE
3159 CONTINUE
C
IBRAN=3161
WRITE(ICOUT,3161)
3161 FORMAT('***** ERROR IN DPEXS2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3162)
3162 FORMAT(' THE FOR NOT FOUND,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3163)
3163 FORMAT(' EVEN THOUGH THE STRING = WAS FOUND.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3164)
3164 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,3165)(IANS(I),I=1,IWIDTH)
3165 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
3169 CONTINUE
C
IF(IFOLOC.LT.NUMARG)GOTO3189
WRITE(ICOUT,3171)
3171 FORMAT('***** ERROR IN DPEXS2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3172)
3172 FORMAT(' THE FOR WAS THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3173)
3173 FORMAT(' FINAL WORD ON THE COMMAND LINE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3174)
3174 FORMAT(' THE WORD FOR SHOULD HAVE BEEN FOLLOWED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3175)
3175 FORMAT(' BY 5 WORDS --')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3176)
3176 FORMAT(' 1) A DUMMY VARIABLE NAME;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3177)
3177 FORMAT(' 2) AN EQUAL SIGN;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3178)
3178 FORMAT(' 3) ONE LIMIT (LOWER OR UPPER) ',
1'FOR THE DUMMY VARIABLE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3179)
3179 FORMAT(' 4) THE INCREMENT FOR THE DUMMY VARIABLE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3180)
3180 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,3186)
3186 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,3187)(IANS(I),I=1,IWIDTH)
3187 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
3189 CONTINUE
IFOLP1=IFOLOC+1
IVDU21=IHARG(IFOLP1)
IVDU22=IHARG2(IFOLP1)
C
C *******************************************
C ** STEP 4-- **
C ** EVALUATE THE FUNCTION OVER **
C ** THE VARIOUS POINTS IN THE INTERVAL. **
C *******************************************
C
ISTEPN='4'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IFOLP1=IFOLOC+1
IFOLP3=IFOLOC+3
IFOLP4=IFOLOC+4
IFOLP5=IFOLOC+5
C
IHPN=IHARG(IFOLP1)
IHPN2=IHARG2(IFOLP1)
C
ASTART=ARG(IFOLP3)
C
AINC=0.0
IF(IFOLP4.GT.NUMARG)GOTO3240
IF(IHARG(IFOLP4).EQ.'FOR '.AND.IHARG2(IFOLP4).EQ.' ')GOTO3240
IF(IHARG(IFOLP4).EQ.'SUBS'.AND.IHARG2(IFOLP4).EQ.'ET ')GOTO3240
IF(IHARG(IFOLP4).EQ.'EXCE'.AND.IHARG2(IFOLP4).EQ.'PT ')GOTO3240
AINC=ARG(IFOLP4)
3240 CONTINUE
C
ASTOP=ASTART
IF(IFOLP4.GT.NUMARG)GOTO3250
IF(IHARG(IFOLP4).EQ.'FOR '.AND.IHARG2(IFOLP4).EQ.' ')GOTO3250
IF(IHARG(IFOLP4).EQ.'SUBS'.AND.IHARG2(IFOLP4).EQ.'ET ')GOTO3250
IF(IHARG(IFOLP4).EQ.'EXCE'.AND.IHARG2(IFOLP4).EQ.'PT ')GOTO3250
ASTOP=ARG(IFOLP5)
3250 CONTINUE
C
NUMINC=0
IF(AINC.NE.0.0)NUMINC=(ASTOP-ASTART)/AINC
IF(NUMINC.LT.0)NUMINC=-NUMINC
NUMINC=NUMINC+1
C
ILALOC=IFOLP3
IF(IFOLP4.GT.NUMARG)GOTO3260
IF(IHARG(IFOLP4).EQ.'FOR '.AND.IHARG2(IFOLP4).EQ.' ')GOTO3260
IF(IHARG(IFOLP4).EQ.'SUBS'.AND.IHARG2(IFOLP4).EQ.'ET ')GOTO3260
IF(IHARG(IFOLP4).EQ.'EXCE'.AND.IHARG2(IFOLP4).EQ.'PT ')GOTO3260
ILALOC=IFOLP5
3260 CONTINUE
C
C ******************
C ** STEP 90-- **
C ** EXIT **
C ******************
C
9000 CONTINUE
IF(IBUGA3.EQ.'OFF')GOTO9090
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPEXS2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IHPN,IHPN2
9012 FORMAT('IHPN,IHPN2 = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)ASTART,AINC,ASTOP
9013 FORMAT('ASTART,AINC,ASTOP = ',3E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)NUMINC
9014 FORMAT('NUMINC = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)ILALOC
9015 FORMAT('ILALOC = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9016)IFOUND,IERROR
9016 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPEXS3(ISEED,XMAT,N,NUMFAC,Y,
1IBUGA3,ISUBRO,IERROR)
C
CCCCC SUBROUTINE DPEXS3(ISIMID,IAUTH,IBOOK,IPAGE,
CCCCC1GMEAN,INDEXB,B,NUMB,
CCCCC1GSD,INDEXS,S,NUMS,
CCCCC1DMINT,DMSLOP,
CCCCC1DSINT,DSSLOP,
C
C PURPOSE--GENERATE SIMULATED RESPONSES
C FROM AN EXPERIMENTAL MODEL.
C INPUT ARGUMENTS--IPAGE = PAGE NUMBER
C ISEED = CURRENT VALUE OF RANDOM NUMBER SEED
C X1 = FACTOR 1
C X2 = FACTOR 2
C X3 = FACTOR 3
C .
C .
C .
C N = NUMBER OF ELEMENTS IN EACH FACTOR.
C NUMFAC = NUMBER OF FACTORS PROVIDED.
C OUTPUT ARGUMENTS--Y = A SINGLE PRECISION VECTOR
C INTO WHICH THE GENERATED
C SIMULATED RESPONSE WILL BE PLACED.
C OUTPUT--A SIMULATED SAMPLE OF SIZE N
C FROM THE MODEL
C Y = F(X1,X2,X3, ...) + RANDOM ERROR
C + DMINT + DMSLOP*TIME + RANDOM ERROR
C WHERE (FOR EXAMPLE)
C F(X1,X2,X3) =
C B0 + 0.5 * [ B1*X1 + B2*X2 + B3*X3 +
C B12*X1*X2 + B13*X1*X3 + B23*X2*X3 +
C B123*X1*X2*X3) ]
C WHERE
C XK = TAKES ON 2 VALUES: +1 AND -1
C AND WHERE
C B0 = 71.25
C B1 = 23
C B2 = -5
C B3 = 1.5
C B12 = 1.5
C B13 = 10
C B23 = 0
C B123 = 0.5
C AND
C SD(ERROR) = 0.1
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 (1966)
C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C DENOTED BY QUOTES RATHER THAN NH.
C VERSION NUMBER--89.1
C ORIGINAL VERSION--JANUARY 1989.
C UPDATED --APRIL 1992. NUMCOL TO NUMFAC
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IBUGA3
CHARACTER*4 ISUBRO
CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
DIMENSION Y(*)
C
DIMENSION XMAT(20,20)
C
DIMENSION IDIGIT(10)
C
DIMENSION DET(100)
C
DIMENSION Z1(100)
DIMENSION SRAND1(100)
DIMENSION RAND1(100)
C
DIMENSION TIME(100)
C
DIMENSION Z2(100)
DIMENSION SRAND2(100)
DIMENSION RAND2(100)
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCOPA.INC'
INCLUDE 'DPCODE.INC'
C
C---------------------------------------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'DEX3')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPEXS3--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBUGA3
52 FORMAT('IBUGA3 = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)ISIMID,N,NUMFAC
53 FORMAT('ISIMID,N,NUMFAC = ',3I8)
CALL DPWRST('XXX','BUG ')
DO56I=1,N
CCCCC THE FOLLOWING 2 LINES WERE CHANGED APRIL 1992 (ALAN)
CCCCC WRITE(ICOUT,57)I,(XMAT(I,J),J=1,NUMCOL)
CCC57 FORMAT('I,(XMAT(I,J),J=1,NUMCOL) = ',I8,10F7.1)
CCCCC CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,57)I,(XMAT(I,J),J=1,NUMFAC)
57 FORMAT('I,(XMAT(I,J),J=1,NUMFAC) = ',I8,10F7.1)
CALL DPWRST('XXX','BUG ')
56 CONTINUE
90 CONTINUE
C
HALF=0.5
C
C **************************************************
C ** STEP 11-- **
C ** DEFINE THE DEFAULT MODEL **
C **************************************************
C
IF(ISIMID.LE.1)GOTO1100
GOTO1190
C
1100 CONTINUE
GMEAN=71.25
NUMB=7
INDEXB(1)=1
INDEXB(2)=2
INDEXB(3)=3
INDEXB(4)=12
INDEXB(5)=13
INDEXB(6)=23
INDEXB(7)=123
B(1)=23.0
B(2)=(-5.0)
B(3)=1.5
B(4)=1.5
B(5)=10.0
B(6)=0.0
B(7)=0.5
C
CCCCC GSD=0.1
GSD=0.0
NUMS=0
C
DMINT=0.0
DMSLOP=0.0
C
DSINT=0.0
DSSLOP=0.0
C
1190 CONTINUE
C
C **************************************************
C ** STEP 21-- **
C ** COMPUTE THE DETERMINISTIC COMPONENT **
C **************************************************
C
IF(N.LE.0)GOTO2119
DO2110I=1,N
SUM=0.0
SUM=SUM+GMEAN
C
IF(NUMB.LE.0)GOTO2129
DO2120J=1,NUMB
TERM1=B(J)
TERM2=1.0
J2=INDEXB(J)
CALL EXTDIG(J2,IDIGIT,NDIGIT,IBUGA3,IERROR)
C
IF(NDIGIT.LE.0)GOTO2139
DO2130K=1,NDIGIT
L=IDIGIT(K)
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DEX3')
1WRITE(ICOUT,2131)NDIGIT,K,L,I,TERM2,XMAT(I,L)
2131 FORMAT('NDIGIT,K,L,I,TERM2,XMAT(I,L) = ',4I8,2E15.7)
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DEX3')
1CALL DPWRST('XXX','BUG ')
TERM2=TERM2*XMAT(I,L)
2130 CONTINUE
2139 CONTINUE
C
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DEX3')
1WRITE(ICOUT,2132)I,SUM,TERM1,TERM2
2132 FORMAT('I,SUM,TERM1,TERM2 = ',I8,3E15.7)
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DEX3')
1CALL DPWRST('XXX','BUG ')
SUM=SUM+HALF*TERM1*TERM2
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DEX3')
1WRITE(ICOUT,2133)I,SUM,TERM1,TERM2
2133 FORMAT('I,SUM,TERM1,TERM2 = ',I8,3E15.7)
IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DEX3')
1CALL DPWRST('XXX','BUG ')
2120 CONTINUE
2129 CONTINUE
C
DET(I)=SUM
CCCCC WRITE(ICOUT,778)I,DET(I)
CC778 FORMAT('I,DET(I) = ',I8,E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
2110 CONTINUE
2119 CONTINUE
C
C **************************************************
C ** STEP 22-- **
C ** COMPUTE THE RANDOM COMPONENT **
C **************************************************
C
CALL NORRAN(N,ISEED,Z1)
C
IF(N.LE.0)GOTO2219
DO2210I=1,N
SUM=0.0
SUM=SUM+GSD
C
IF(NUMS.LE.0)GOTO2229
DO2220J=1,NUMS
TERM1=S(J)
TERM2=1.0
J2=INDEXS(J)
CALL EXTDIG(J2,IDIGIT,NDIGIT,IBUGA3,IERROR)
C
IF(NDIGIT.LE.0)GOTO2239
DO2230K=1,NDIGIT
L=IDIGIT(K)
TERM2=TERM2*XMAT(I,L)
2230 CONTINUE
2239 CONTINUE
C
SUM=SUM+HALF*TERM1*TERM2
2220 CONTINUE
2229 CONTINUE
C
SRAND1(I)=SUM
RAND1(I)=Z1(I)*SRAND1(I)
2210 CONTINUE
2219 CONTINUE
C
C **************************************************
C ** STEP 23-- **
C ** COMPUTE THE CONTRIBUTION DUE TO A **
C ** CHANGE IN LOCATION WITH TIME (DRIFT) **
C **************************************************
C
DO2300I=1,N
AI=I
TIME(I)=DMINT*DMSLOP*AI
2300 CONTINUE
C
C **************************************************
C ** STEP 24-- **
C ** COMPUTE THE CONTRIBUTION DUE TO A **
C ** CHANGE IN VARIATION WITH TIME **
C **************************************************
C
CALL NORRAN(N,ISEED,Z2)
DO2400I=1,N
AI=I
SRAND2(I)=DSINT+DSSLOP*AI
RAND2(I)=Z2(I)*SRAND2(I)
2400 CONTINUE
C
C **************************************************
C ** STEP 29-- **
C ** COMPUTE THE FINAL RESPONSE = **
C ** SUM OF ALL CONTRIBUTIONS **
C **************************************************
C
DO2900I=1,N
Y(I)=DET(I)+RAND1(I)+TIME(I)+RAND2(I)
CCCCC WRITE(ICOUT,779)I,DET(I),RAND1(I),Y(I)
CC779 FORMAT('I,DET(I),RAND1(I),Y(I) = ',I8,3E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2911)I,Y(I),(XMAT(I,J),J=1,NUMFAC)
2911 FORMAT(I4,'--','RESULT = ',F10.5,5X,15F7.2)
CALL DPWRST('XXX','BUG ')
2900 CONTINUE
C
C **************************************************
C ** STEP 90-- **
C ** EXIT **
C **************************************************
C
9000 CONTINUE
IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'DEX3')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPEXS3--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGA3
9012 FORMAT('IBUGA3 = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)ISIMID,N,NUMFAC
9013 FORMAT('ISIMID,N,NUMFAC = ',3I8)
CALL DPWRST('XXX','BUG ')
DO9016I=1,N
WRITE(ICOUT,9017)I,XMAT(I,1),XMAT(I,2),XMAT(I,3),Y(I)
9017 FORMAT('I,XMAT(I,1),XMAT(I,2),XMAT(I,3),Y(I) = ',I8,6E11.4)
CALL DPWRST('XXX','BUG ')
9016 CONTINUE
WRITE(ICOUT,9021)GMEAN
9021 FORMAT('GMEAN = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9022)TERM1,TERM2,SUM
9022 FORMAT('TERM1,TERM2,SUM = ',3E15.7)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPEXSE(IFOLOC,IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,
1IANS,IWIDTH,
1IHPN,IHPN2,ASTART,AINC,ASTOP,NUMINC,ILALOC,IBUGA3,IFOUND,IERROR)
C
C PURPOSE--EXTRACT THE SEQUENCE OF VALUES
C AS DICTATED BY A FOR SPECIFICATION.
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-921-3651
C NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C OF THE NATIONAL BUREAU OF STANDARDS.
C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C MODIFIED, OR OTHERWISE USED IN A CONTEXT
C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--82/7
C ORIGINAL VERSION--OCTOBER 1981.
C UPDATED --NOVEMBER 1981.
C UPDATED --MARCH 1982.
C UPDATED --MAY 1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IHARG
CHARACTER*4 IHARG2
CHARACTER*4 IARGT
CHARACTER*4 IANS
CHARACTER*4 IHPN
CHARACTER*4 IHPN2
CHARACTER*4 IBUGA3
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 IVDU11
CHARACTER*4 IVDU12
CHARACTER*4 IVDU21
CHARACTER*4 IVDU22
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
DIMENSION IANS(*)
C
DIMENSION IHARG(*)
DIMENSION IHARG2(*)
DIMENSION IARGT(*)
DIMENSION IARG(*)
DIMENSION ARG(*)
C
C
C---------------------------------------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
ISUBN1='DPEX'
ISUBN2='SE '
C
IERROR='NO'
IFOUND='NO'
C
IFOUND='YES'
C
IF(IBUGA3.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPEXSE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IFOLOC
52 FORMAT('IFOLOC = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)NUMARG
54 FORMAT('NUMARG = ',I8)
CALL DPWRST('XXX','BUG ')
DO55I=1,NUMARG
WRITE(ICOUT,56)I,IHARG(I),IHARG2(I),ARG(I)
56 FORMAT('I,IHARG(I),IHARG2(I),ARG(I) = ',I8,2X,A4,2X,A4,E15.7)
CALL DPWRST('XXX','BUG ')
55 CONTINUE
90 CONTINUE
C
C *******************************************************
C ** STEP 3-- **
C ** DETERMINE THE NAME OF THE NEXT DUMMY VARIABLE **
C ** (IT NEVER GETS STORED PERMANENTLY) **
C ** IMMEDIATELY FOLLOWING THE 'FOR' KEYWORD **
C *******************************************************
C
ISTEPN='3'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IFOLOC.LT.NUMARG)GOTO3139
WRITE(ICOUT,3121)
3121 FORMAT('***** ERROR IN DPEXSE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3122)
3122 FORMAT(' THE FOR WAS THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3123)
3123 FORMAT(' FINAL WORD ON THE COMMAND LINE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3124)
3124 FORMAT(' THE WORD FOR SHOULD HAVE BEEN FOLLOWED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3125)
3125 FORMAT(' BY 5 WORDS --')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3126)
3126 FORMAT(' 1) A DUMMY VARIABLE NAME;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3127)
3127 FORMAT(' 2) AN EQUAL SIGN;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3128)
3128 FORMAT(' 3) ONE LIMIT (LOWER OR UPPER) ',
1'FOR THE DUMMY VARIABLE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3129)
3129 FORMAT(' 4) THE INCREMENT FOR THE DUMMY VARIABLE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3130)
3130 FORMAT(' 5) THE OTHER LIMIT (UPPER OR LOWER) ',
1'FOR THE DUMMY VARIABLE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3136)
3136 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,3137)(IANS(I),I=1,IWIDTH)
3137 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
3139 CONTINUE
IFOLP1=IFOLOC+1
IVDU11=IHARG(IFOLP1)
IVDU12=IHARG2(IFOLP1)
C
C *******************************************************
C ** STEP 3.1-- **
C ** DETERMINE THE NAME OF THE DUMMY VARIABLE **
C ** (IT NEVER GETS STORED PERMANENTLY) **
C ** IMMEDIATELY FOLLOWING THE 'FOR' KEYWORD **
C *******************************************************
C
ISTEPN='3.1'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IFOLP2=IFOLOC+2
IF(IFOLOC.GT.NUMARG)GOTO3159
IF(IHARG(IFOLOC).EQ.'FOR')GOTO3169
C3150 CONTINUE
3159 CONTINUE
C
IBRAN=3161
WRITE(ICOUT,3161)
3161 FORMAT('***** ERROR IN DPEXSE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3162)
3162 FORMAT(' THE FOR NOT FOUND,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3163)
3163 FORMAT(' EVEN THOUGH THE STRING = WAS FOUND.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3164)
3164 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,3165)(IANS(I),I=1,IWIDTH)
3165 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
3169 CONTINUE
C
IF(IFOLOC.LT.NUMARG)GOTO3189
WRITE(ICOUT,3171)
3171 FORMAT('***** ERROR IN DPEXSE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3172)
3172 FORMAT(' THE FOR WAS THE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3173)
3173 FORMAT(' FINAL WORD ON THE COMMAND LINE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3174)
3174 FORMAT(' THE WORD FOR SHOULD HAVE BEEN FOLLOWED')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3175)
3175 FORMAT(' BY 5 WORDS --')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3176)
3176 FORMAT(' 1) A DUMMY VARIABLE NAME;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3177)
3177 FORMAT(' 2) AN EQUAL SIGN;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3178)
3178 FORMAT(' 3) ONE LIMIT (LOWER OR UPPER) ',
1'FOR THE DUMMY VARIABLE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3179)
3179 FORMAT(' 4) THE INCREMENT FOR THE DUMMY VARIABLE;')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3180)
3180 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,3186)
3186 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,3187)(IANS(I),I=1,IWIDTH)
3187 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
3189 CONTINUE
IFOLP1=IFOLOC+1
IVDU21=IHARG(IFOLP1)
IVDU22=IHARG2(IFOLP1)
C
C *******************************************
C ** STEP 4-- **
C ** EVALUATE THE FUNCTION OVER **
C ** THE VARIOUS POINTS IN THE INTERVAL. **
C *******************************************
C
ISTEPN='4'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IFOLP1=IFOLOC+1
IFOLP3=IFOLOC+3
IFOLP4=IFOLOC+4
IFOLP5=IFOLOC+5
C
IHPN=IHARG(IFOLP1)
IHPN2=IHARG2(IFOLP1)
C
ASTART=ARG(IFOLP3)
C
AINC=0.0
IF(IFOLP4.GT.NUMARG)GOTO3240
IF(IHARG(IFOLP4).EQ.'FOR '.AND.IHARG2(IFOLP4).EQ.' ')GOTO3240
IF(IHARG(IFOLP4).EQ.'SUBS'.AND.IHARG2(IFOLP4).EQ.'ET ')GOTO3240
IF(IHARG(IFOLP4).EQ.'EXCE'.AND.IHARG2(IFOLP4).EQ.'PT ')GOTO3240
AINC=ARG(IFOLP4)
3240 CONTINUE
C
ASTOP=ASTART
IF(IFOLP4.GT.NUMARG)GOTO3250
IF(IHARG(IFOLP4).EQ.'FOR '.AND.IHARG2(IFOLP4).EQ.' ')GOTO3250
IF(IHARG(IFOLP4).EQ.'SUBS'.AND.IHARG2(IFOLP4).EQ.'ET ')GOTO3250
IF(IHARG(IFOLP4).EQ.'EXCE'.AND.IHARG2(IFOLP4).EQ.'PT ')GOTO3250
ASTOP=ARG(IFOLP5)
3250 CONTINUE
C
NUMINC=0
IF(AINC.NE.0.0)NUMINC=(ASTOP-ASTART)/AINC
IF(NUMINC.LT.0)NUMINC=-NUMINC
NUMINC=NUMINC+1
C
ILALOC=IFOLP3
IF(IFOLP4.GT.NUMARG)GOTO3260
IF(IHARG(IFOLP4).EQ.'FOR '.AND.IHARG2(IFOLP4).EQ.' ')GOTO3260
IF(IHARG(IFOLP4).EQ.'SUBS'.AND.IHARG2(IFOLP4).EQ.'ET ')GOTO3260
IF(IHARG(IFOLP4).EQ.'EXCE'.AND.IHARG2(IFOLP4).EQ.'PT ')GOTO3260
ILALOC=IFOLP5
3260 CONTINUE
C
C ******************
C ** STEP 90-- **
C ** EXIT **
C ******************
C
9000 CONTINUE
IF(IBUGA3.EQ.'OFF')GOTO9090
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPEXSE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IHPN,IHPN2
9012 FORMAT('IHPN,IHPN2 = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)ASTART,AINC,ASTOP
9013 FORMAT('ASTART,AINC,ASTOP = ',3E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)NUMINC
9014 FORMAT('NUMINC = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)ILALOC
9015 FORMAT('ILALOC = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9016)IFOUND,IERROR
9016 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPEXSI(ISEED,XTEMP1,XTEMP2,MAXNXT,ICASAN,
1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
C
C PURPOSE--CARRY OUT AN EXPERIMENTAL SIMULATION
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/6
C ORIGINAL VERSION--MAY 1989.
C UPDATED --JULY 1989. CHAR*4 STATEMENTS FOR IDEXEF & IEXSIA
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 ICASAN
CHARACTER*4 ISUBRO
CHARACTER*4 IBUGA2
CHARACTER*4 IBUGA3
CHARACTER*4 IBUGQ
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 IDEXEF
CHARACTER*4 IEXSIA
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
DIMENSION XTEMP1(*)
DIMENSION XTEMP2(*)
C
DIMENSION XMAT(20,20)
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCOPA.INC'
INCLUDE 'DPCOHK.INC'
INCLUDE 'DPCODA.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
IERROR='NO'
C
ISUBN1='DPEX'
ISUBN2='SI '
C
MAXCP1=MAXCOL+1
MAXCP2=MAXCOL+2
MAXCP3=MAXCOL+3
MAXCP4=MAXCOL+4
MAXCP5=MAXCOL+5
MAXCP6=MAXCOL+6
C
MAXV2=2
MINN2=2
C
ICOLL=0
ICOLX=0
ICOLXI=0
C
NUMVAR=0
NUMCOM=0
NUMFAC=0
C
IEXSIA='NONP'
IDEXEF='STAT'
C
C *********************************************
C ** TREAT THE EXPERIMENTAL SIMULATION CASE **
C *********************************************
C
IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'EXSI')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPEXSI--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO
52 FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',
1A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)ICASAN
53 FORMAT('ICASAN = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)ISEED
54 FORMAT('ISEED = ',I8)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C *****************************************************
C ** STEP 11-- **
C ** EXTRACT THE COMMAND **
C ** DETERMINE THE LOCATION (IN IHARG(.)) **
C ** OF THE WORD SIMULATION OR RUN **
C ** PLACE IT IN ILASTC . **
C ** THEN SHIFT LEFT THE ENTIRE COMMAND LINE **
C ** SO THAT THE FIRST VARIABLE ARGUMENT **
C ** IS MOVED TO IHARG(1) **
C *****************************************************
C
IF(ICOM.EQ.'RUN')GOTO590
IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SIMU')GOTO501
IFOUND='NO'
GOTO9000
C
501 CONTINUE
ILASTC=1
CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
C
590 CONTINUE
IFOUND='YES'
C
C ***********************************************************
C ** STEP 21-- **
C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. **
C ***********************************************************
C
ISTEPN='21'
IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'EXSI')
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 22- **
C ** EXTRACT EACH ARGUMENT **
C ** TREAT THE ALL-NUMBER/PARAMETER CASE **
C **************************************************
C
NUMROW=1
NUMCOL=NUMARG
DO2200J=1,NUMARG
XMAT(1,J)=ARG(J)
2200 CONTINUE
C
C **************************************************
C ** STEP 31-- **
C ** GENERATE A SIMULATED VALUE(S) **
C **************************************************
C
CALL DPEXS3(ISEED,XMAT,NUMROW,NUMCOL,Y,
1IBUGA3,ISUBRO,IERROR)
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'EXSI')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPEXSI--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)ISUBRO,IBUGA2,IBUGA3,IBUGQ
9012 FORMAT('ISUBRO,IBUGA2,IBUGA3,IBUGQ = ',
1A4,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)ICASAN
9014 FORMAT('ICASAN = ',A4)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPEXSS(X1,Y1,D1,N1,DTARG,
1X2,Y2,N2,DHIT,
1IBUGU2,ISUBRO,IERROR)
C
C PURPOSE--EXTRACT A SUBSET.
C GIVEN THE VECTORS X1 AND Y1 CONTAINING N1
C COORDINATES, AND THE VECTOR D1 CONTAINING
C TAG INFORMATION, EXTRACT A SUBSET.
C TWO CAPABILITITIES EXIST--
C CASE 1--IF DTARG IS SET AT CPUMIN,
C THEN SEARCH THE D1 VECTOR FOR EACH
C TAG VALUE. THE FIRST SUCH TAG VALUE
C WHICH OCCURS MULTIPLE TIMES WILL
C HAVE ITS X AND Y VALUES EXTRACTED
C AND PLACED IN X2 AND Y2.
C THE EXTRACTED NUMBER OF OBSERVATIONS
C WILL BE PLACED IN N2.
C THE SUCCESSFUL TAG VALUE WILL BE PLACED
C IN DHIT.
C IF NO MULTIPLE VALUES ARE FOUND,
C THEN DHIT WILL BE SET AT THE LAST TAG
C VALUE EXAMINED, AND N2 WILL BE SET TO 1.
C IF MORE THAN ONE TAG VALUE HAS MULTIPLES,
C ONLY THE FIRST WILL BE USED; THE OTHERS
C WILL BE IGNORED.
C CASE 2--IF DTARG IS SET AT SOME FINITE VALUE,
C THEN THE SUBSET IS EXTRACTED AND PLACED
C IN X2 AND Y2, AND THE OUTPUT
C NUMBER OF OBSERVATIONS IS PLACED IN N2.
C DHIT IS SET TO DTARG.
C IF NO OCCURRANCES ARE FOUND,
C THEN N2 WILL BE SET TO 0.
C CAUTION--THE OUTPUT VECTORS X2 AND Y2
C MUST NOT BE THE SAME AS THE
C INPUT VECTORS X AND Y IN THE CALLING SEQUENCE.
C ORIGINAL VERSION--SEPTEMBER 1988
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IBUGU2
CHARACTER*4 ISUBRO
CHARACTER*4 IERROR
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CCCCC CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
DIMENSION X1(*)
DIMENSION Y1(*)
DIMENSION D1(*)
DIMENSION X2(*)
DIMENSION Y2(*)
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='DPEX'
ISUBN2='SS '
C
IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'EXSS')GOTO50
GOTO90
50 CONTINUE
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPEXSS--')
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,53)CPUMIN
53 FORMAT('CPUMIN = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,61)N1,DTARG
61 FORMAT('N1,DTARG = ',I8,E15.7)
CALL DPWRST('XXX','BUG ')
DO62I=1,N1
WRITE(ICOUT,63)I,X1(I),Y1(I),D1(I)
63 FORMAT('I,X1(I),Y1(I),D1(I) = ',I8,3E15.7)
CALL DPWRST('XXX','BUG ')
62 CONTINUE
90 CONTINUE
C
C **************************************************
C ** STEP 10-- **
C ** BRANCH TO THE APPROPRIATE CASE **
C **************************************************
C
IF(DTARG.EQ.CPUMIN)GOTO1100
GOTO1200
C
C **************************************************
C ** STEP 11-- **
C ** TREAT THE FLOATING TAG CASE **
C **************************************************
C
1100 CONTINUE
C
N2=0
DHIT=DTARG
IF(N1.LE.1)GOTO1190
C
N1M1=N1-1
DO1110I=1,N1M1
DTARG2=D1(I)
IP1=I+1
C
ICOUNT=0
ICOUNT=ICOUNT+1
X2(ICOUNT)=X1(I)
Y2(ICOUNT)=Y1(I)
C
DO1120J=IP1,N1
IF(D1(J).EQ.DTARG2)GOTO1130
GOTO1120
1130 CONTINUE
ICOUNT=ICOUNT+1
X2(ICOUNT)=X1(J)
Y2(ICOUNT)=Y1(J)
1120 CONTINUE
C
IF(ICOUNT.GE.2)GOTO1140
GOTO1110
C
1140 CONTINUE
N2=ICOUNT
DHIT=DTARG2
GOTO1190
C
1110 CONTINUE
C
1190 CONTINUE
GOTO9000
C
C **************************************************
C ** STEP 12-- **
C ** TREAT THE PRE-SPECIFIED FINITE TAG CASE **
C **************************************************
C
1200 CONTINUE
C
DTARG2=DTARG
C
ICOUNT=0
DO1220J=1,N1
IF(D1(J).EQ.DTARG2)GOTO1230
GOTO1220
1230 CONTINUE
ICOUNT=ICOUNT+1
X2(ICOUNT)=X1(J)
Y2(ICOUNT)=Y1(J)
1220 CONTINUE
N2=ICOUNT
DHIT=DTARG2
C
1290 CONTINUE
GOTO9000
C
C **************************************************
C ** STEP 90-- **
C ** EXIT. **
C **************************************************
C
9000 CONTINUE
IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'EXSS')GOTO9010
GOTO9090
9010 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE BEGINNING OF DPEXSS--')
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,9013)CPUMIN
9013 FORMAT('CPUMIN = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9021)N1,DTARG
9021 FORMAT('N1,DTARG = ',I8,E15.7)
CALL DPWRST('XXX','BUG ')
DO9022I=1,N1
WRITE(ICOUT,9023)I,X1(I),Y1(I),D1(I)
9023 FORMAT('I,X1(I),Y1(I),D1(I) = ',I8,3E15.7)
CALL DPWRST('XXX','BUG ')
9022 CONTINUE
WRITE(ICOUT,9031)N2,DHIT
9031 FORMAT('N2,DHIT = ',I8,E15.7)
CALL DPWRST('XXX','BUG ')
DO9032I=1,N2
WRITE(ICOUT,9033)I,X2(I),Y2(I)
9033 FORMAT('I,X2(I),Y2(I) = ',I8,2E15.7)
CALL DPWRST('XXX','BUG ')
9032 CONTINUE
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXCHF,
1IFUNC2,N2,IBUGA3,IFOUND,IERROR)
C
C PURPOSE--EXTRACT A STRING.
C THE EXTRACTED STRING WILL BE DEFINED
C BY THE FIRST NON-BLANK CHARACTER AFTER
C THE WORD (OR THE COMPLETION OF THE WORD)
C DEFINED BY IWD1 AND IWD12,
C AND CONTINUE UNTIL THE LAST NON-BLANK CHARACTER
C BEFORE THE WORD DEFINED BY IWD2 AND IWD22.
C (E.G., IF IWD1 = 'DERI' AND IWD12 = 'VATI', THEN THE STRING
C WILL BEGIN WITH THE FIRST NON-BLANK CHARACTER
C AFTER 'DERIVATIVE', 'DERIVATIXXX', ETC.).
C THE STRING WILL FINISH WITH THE LAST NON-BLANK CHARACTER BEFORE IWD2 AND
C IWD22. THE SCAN WILL COVER THE ENTIRE LINE.
C NOTE THE FOLLOWING CONVENTIONS--
C IF IWD1 = ' ', THE EXTRACTED STRING WILL START WITH THE
C FIRST WORD OF THE LINE (INCLUSIVE).
C IF IWD2 = ' ', THE EXTRACTED STRING WILL STOP WITH THE
C LAST WORD OF THE LINE (INCLUSIVE).
C NOTE--ONLY THE STRING EXTRACTION IS DONE--
C NO FUNCTION REPLACEMENT IS DONE.
C OUTPUT ARGUMENTS--IFUNC2 = THE HOLLERITH VARIABLE
C CONTAINING THE EXTRACTED
C STRING (1 CHARACTER PER WORD).
C --N2 = THE INTEGER NUMBER OF A1 CHARACTERS
C IN THE EXTRACTED 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--82/7
C ORIGINAL VERSION--JANUARY 1979.
C UPDATED --MAY 1982.
C ORIGINAL VERSION--FEBRUARY 1979.
C UPDATED --JANUARY 1981.
C UPDATED --JUNE 1981.
C UPDATED --AUGUST 1981.
C UPDATED --JUNE 1989. FIX MIS-PARSING OF LET S = ABCFORDEF
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IANS
CHARACTER*4 IWD1
CHARACTER*4 IWD12
CHARACTER*4 IWD2
CHARACTER*4 IWD22
CHARACTER*4 IFUNC2
CHARACTER*4 IBUGA3
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
C
CHARACTER*4 ICH1
CHARACTER*4 ICH2
CHARACTER*4 IX1
CHARACTER*4 IX2
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
DIMENSION IANS(*)
DIMENSION IFUNC2(*)
C
DIMENSION ICH1(8)
DIMENSION ICH2(8)
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='DPEX'
ISUBN2='ST '
C
NUMASC=4
NUMAS2=2*NUMASC
C
IEND1=0
IEND2=0
ILOCST=0
ILOC1=0
I2=0
J2=0
ISTART=0
ILOC2=0
ISTOP=0
C
C ***************************
C ** EXTRACT A FUNCTION. **
C ***************************
C
IF(IBUGA3.EQ.'OFF')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,91)
91 FORMAT('***** AT THE BEGINNING OF DPEXST--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,92)IWIDTH
92 FORMAT('IWIDTH = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,93)(IANS(I),I=1,IWIDTH)
93 FORMAT('IANS(.) = ',115A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,94)IWD1,IWD12
94 FORMAT('IWD1,IWD12 = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,95)IWD2,IWD22
95 FORMAT('IWD2,IWD22 = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C **********************************
C ** STEP 1-- **
C ** INITIALIZE SOME VARIABLES. **
C **********************************
C
ISTEPN='1'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IERROR='NO'
IFOUND='NO'
C
N2=0
DO100I=1,MAXCHF
IFUNC2(I)=' '
100 CONTINUE
C
DO110I=1,NUMAS2
ICH1(I)=' '
ICH2(I)=' '
110 CONTINUE
C
C **************************************************************
C ** STEP 2-- **
C ** DECOMPOSE THE 2 TARGET WORDS INTO INDIVIDUAL CHARACTERS.**
C **************************************************************
C
J=0
IF(IWD1.EQ.' ')GOTO390
IX1=IWD1
ISTAR2=0
ILEN1=NUMBPC
ILEN2=ILEN1
DO200I=1,NUMASC
J=J+1
IX2=' '
ISTAR1=(I-1)*NUMBPC
CALL DPCHEX(ISTAR1,ILEN1,IX1,ISTAR2,ILEN2,IX2)
ICH1(J)=IX2
200 CONTINUE
C
IF(IWD12.EQ.' ')GOTO290
IX1=IWD12
ISTAR2=0
ILEN1=NUMBPC
ILEN2=ILEN1
DO250I=1,NUMASC
J=J+1
IX2=' '
ISTAR1=(I-1)*NUMBPC
CALL DPCHEX(ISTAR1,ILEN1,IX1,ISTAR2,ILEN2,IX2)
ICH1(J)=IX2
250 CONTINUE
290 CONTINUE
C
K=0
DO300I=1,J
K=K+1
IF(ICH1(I).EQ.' ')GOTO350
300 CONTINUE
IEND1=K
GOTO390
350 CONTINUE
IEND1=K-1
390 CONTINUE
C
J=0
IF(IWD2.EQ.' ')GOTO590
IX1=IWD2
ISTAR2=0
ILEN1=NUMBPC
ILEN2=ILEN1
DO400I=1,NUMASC
J=J+1
IX2=' '
ISTAR1=(I-1)*NUMBPC
CALL DPCHEX(ISTAR1,ILEN1,IX1,ISTAR2,ILEN2,IX2)
ICH2(J)=IX2
400 CONTINUE
C
IF(IWD22.EQ.' ')GOTO490
IX1=IWD22
ISTAR2=0
ILEN1=NUMBPC
ILEN2=ILEN1
DO450I=1,NUMASC
J=J+1
IX2=' '
ISTAR1=(I-1)*NUMBPC
CALL DPCHEX(ISTAR1,ILEN1,IX1,ISTAR2,ILEN2,IX2)
ICH2(J)=IX2
450 CONTINUE
490 CONTINUE
C
K=0
DO500I=1,J
K=K+1
IF(ICH2(I).EQ.' ')GOTO550
500 CONTINUE
IEND2=K
GOTO590
550 CONTINUE
IEND2=K-1
590 CONTINUE
C
C ***************************************************************
C ** STEP 3-- **
C ** EXTRACT THE **
C ** EXPRESSION FROM THE INPUT COMMAND LINE. **
C ** START WITH THE FIRST NON-BLANK CHARACTER AFTER THE **
C ** WORD (OR THE CONTINUATION OF THE WORD) **
C ** DEFINED IN IWD1 AND IWD12, **
C ** AND END WITH THE FIRST NON-BLANK CHARACTER **
C ** BEFORE THE WORD DEFINED IN IWD2 AND IWD22. **
C ** NOTE THAT IF IWD1 = ' ', THEN THIS IS TO BE INTERPRETED **
C ** AS STARTING WITH THE FIRST NON-BLANK CHARACTER AFTER **
C ** (BUT NOT INCLUDING) THE EQUAL SIGN. **
C ** NOTE THAT IF IWD2 = ' ', THEN THIS IS TO BE INTERPRETED **
C ** AS ENDING WITH THE FIRST NON-BLANK CHARACTER UP TO **
C ** (AND INCLUDING) THE END OF THE LINE. **
C ** THE EXTRACTED FUNCTION WILL BE PUT INTO IFUNC2(.). **
C ** THE NUMBER OF CHARACTERS IN IFUNC2(.) WILL BE N2. **
C ***************************************************************
C
ISTEPN='3'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IWIDTH.GE.1)GOTO1109
IBRAN=1100
WRITE(ICOUT,1101)
1101 FORMAT('INTERNAL ERROR IN DPEXST--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1102)IBRAN
1102 FORMAT('AT BRANCH POINT = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1103)
1103 FORMAT('IWIDTH IS NON-POSITIVE FOR FUNCTION EXTRACTION.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1104)IWIDTH
1104 FORMAT('IWIDTH = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1105)
1105 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,1106)(IANS(I),I=1,IWIDTH)
1106 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
1109 CONTINUE
C
C *************************************************
C ** STEP 3.2-- **
C ** SEARCH FOR THE STRING DEFINED BY THE **
C ** CHARACTERS IN IWD1 AND IWD12. **
C *************************************************
C
ISTEPN='3.2'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ILOCST=0
ILOC1=(-99)
IF(IWD1.EQ.' ')ILOC1=ILOCST
IF(IWD1.EQ.' ')GOTO3290
IMIN=ILOCST+1
IF(IMIN.GT.IWIDTH)GOTO3290
DO3210I=IMIN,IWIDTH
I2=I
IF(IANS(I).EQ.ICH1(1))GOTO3215
GOTO3210
3215 CONTINUE
DO3212J=1,IEND1
J2=I2+J-1
IF(IANS(J2).EQ.ICH1(J))GOTO3212
GOTO3210
3212 CONTINUE
ILOC1=J2
GOTO3290
3210 CONTINUE
IF(IBUGA3.EQ.'OFF')GOTO3259
WRITE(ICOUT,3251)
3251 FORMAT('***** BUG-MODE DIAGNOSTIC IN DPEXST--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3252)IWD1,IWD12
3252 FORMAT(' NO ',A4,A4,' FOUND AFTER EQUAL SIGN.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3253)
3253 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,3254)(IANS(I),I=1,IWIDTH)
3254 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
3259 CONTINUE
IFOUND='NO'
GOTO9000
3290 CONTINUE
C
C ********************************************
C ** STEP 3.3-- **
C ** DETERMINE IF THERE IS A CONTINUATION **
C ** OF THE WORD DEFINED BY IWD1 AND IWD12.**
C ********************************************
C
ISTEPN='3.3'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(IWD1.EQ.' ')GOTO3390
IF(IEND1.NE.NUMAS2)GOTO3390
IMIN=ILOC1+1
IF(IMIN.GT.IWIDTH)GOTO3319
DO3300I=IMIN,IWIDTH
I2=I
IF(IANS(I).EQ.' ')GOTO3310
3300 CONTINUE
ILOC1=I2+1
GOTO3319
3310 CONTINUE
ILOC1=I2-1
3319 CONTINUE
C
IF(ILOC1.GE.1)GOTO3359
WRITE(ICOUT,3351)
3351 FORMAT('***** ERROR IN DPEXST--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3352)IWD1,IWD12
3352 FORMAT(' NO ',A4,A4,' FOUND AFTER EQUAL SIGN.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3353)
3353 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,3354)(IANS(I),I=1,IWIDTH)
3354 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
3359 CONTINUE
C
IF(ILOC1.LT.IWIDTH)GOTO3369
WRITE(ICOUT,3361)
3361 FORMAT('***** ERROR IN DPEXST--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3362)IWD1,IWD12
3362 FORMAT(' ',A4,A4,' IS LAST WORD ON COMMAND LINE.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3363)
3363 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,3364)(IANS(I),I=1,IWIDTH)
3364 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
3369 CONTINUE
C
3390 CONTINUE
C
C ********************************************
C ** STEP 3.4-- **
C ** SEARCH FOR FIRST NON-BLANK CHARACTER **
C ** AFTER THE WORD (OR THE CONTINUATION **
C ** OF THE WORD) DEFINED BY IWD1 AND IWD12.**
C ********************************************
C
ISTEPN='3.4'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ISTART=(-99)
IMIN=ILOC1+1
IF(IMIN.GT.IWIDTH)GOTO3419
DO3410I=IMIN,IWIDTH
I2=I
IF(IANS(I).NE.' ')GOTO3415
3410 CONTINUE
GOTO3419
3415 CONTINUE
ISTART=I2
3419 CONTINUE
C
IF(ISTART.GE.1)GOTO3459
WRITE(ICOUT,3451)
3451 FORMAT('***** ERROR IN DPEXST--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3452)IWD1,IWD12
3452 FORMAT(' ALL CHARACTERS AFTER ',A4,A4,' ARE BLANK.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3453)
3453 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,3454)(IANS(I),I=1,IWIDTH)
3454 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
3459 CONTINUE
C
C *************************************************
C ** STEP 3.5-- **
C ** SEARCH FOR FIRST OCCURRANCE OF CHARACTER **
C ** DEFINED BY IWD2. **
C *************************************************
C
ISTEPN='3.5'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ILOC2=(-99)
IF(IWD2.EQ.' ')ILOC2=IWIDTH+1
IF(IWD2.EQ.' ')GOTO3590
C THE FOLLOWING LINE WAS ENTERED (SEPT 1987)
C TO HANDLE THE PROBLEM THAT AROSE WHEN THE RIGHT HAND SIDE OF
C THE EQUAL SIGN CONSISTED OF ONLY 1 CHARACTER, AS IN
C LET FUNCTION ABC = F
IF(IWD2.EQ.'FOR'.AND.ISTART.EQ.IWIDTH)GOTO3511
IMIN=ISTART+1
IF(IMIN.GT.IWIDTH)GOTO3590
DO3510I=IMIN,IWIDTH
I2=I
IF(IANS(I).EQ.ICH2(1))GOTO3515
GOTO3510
3515 CONTINUE
DO3512J=1,IEND2
J2=I2+J-1
IF(IANS(J2).EQ.ICH2(J))GOTO3512
GOTO3510
3512 CONTINUE
ILOC2=I2-1
GOTO3590
3510 CONTINUE
3511 CONTINUE
IF(IBUGA3.EQ.'OFF')GOTO3559
WRITE(ICOUT,3551)
3551 FORMAT('***** BUG-MODE DIAGNOSTIC IN DPEXST--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3552)IWD2,IWD22
3552 FORMAT(' NO ',A4,A4,' FOUND AFTER EQUAL SIGN.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3553)
3553 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,3554)(IANS(I),I=1,IWIDTH)
3554 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
3559 CONTINUE
IFOUND='NO'
GOTO9000
3590 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 1989
CCCCC TO CORRECT MIS-PARSING OF LET STRING S = ABCFORDEF JUNE 1989
IF(IWD2.EQ.'FOR'.AND.ILOC2.GE.1)GOTO3591
GOTO3599
3591 CONTINUE
DO3592I=ILOC2,IWIDTH
IF(IANS(I).EQ.'=')GOTO3599
3592 CONTINUE
IFOUND='NO'
GOTO9000
3599 CONTINUE
C
C ********************************************
C ** STEP 3.6-- **
C ** SEARCH FOR FIRST NON-BLANK CHARACTER **
C ** BEFORE THE WORD DEFINED BY IWD2. **
C ********************************************
C
ISTEPN='3.6'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ISTOP=(-99)
IMAX=ILOC2-1
IF(IMAX.LT.ISTART)GOTO3619
DO3610I=ISTART,IMAX
IREV=IMAX-I+ISTART
IF(IANS(IREV).NE.' ')GOTO3615
3610 CONTINUE
GOTO3619
3615 CONTINUE
ISTOP=IREV
3619 CONTINUE
C
IF(ISTOP.GE.1)GOTO3659
WRITE(ICOUT,3651)
3651 FORMAT('***** ERROR IN DPEXST--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3652)IWD2,IWD22
3652 FORMAT(' ALL CHARACTERS BEFORE ',A4,A4,' ARE BLANK.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3653)
3653 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,3654)(IANS(I),I=1,IWIDTH)
3654 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
3659 CONTINUE
C
IF(ISTART.LE.ISTOP)GOTO3919
IBRAN=3910
WRITE(ICOUT,3911)
3911 FORMAT('INTERNAL ERROR IN DPEXST--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3912)IBRAN
3912 FORMAT('AT BRANCH POINT = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3913)
3913 FORMAT('ISTART GREATER THAN ISTOP FOR FUNCTION EXTRACTION')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3914)ISTART,ISTOP
3914 FORMAT('ISTART, ISTOP = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,3915)
3915 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--')
CALL DPWRST('XXX','BUG ')
IF(IWIDTH.GE.1)WRITE(ICOUT,3916)(IANS(I),I=1,IWIDTH)
3916 FORMAT(' ',100A1)
IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
3919 CONTINUE
C
C **********************************
C ** STEP 4-- **
C ** COPY OUT THE STRING AS IS. **
C ** COPY IT INTO IFUNC2(.). **
C **********************************
C
ISTEPN='4'
IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
J=0
DO4000I=ISTART,ISTOP
J=J+1
IFUNC2(J)=IANS(I)
4000 CONTINUE
N2=J
C
IFOUND='YES'
C
C ****************
C ** STEP 5-- **
C ** EXIT. **
C ****************
C
9000 CONTINUE
C
IF(IBUGA3.EQ.'OFF')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPEXST--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IEND1,IEND2
9012 FORMAT('IEND1,IEND2 = ',I8,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)(ICH1(I),I=1,8)
9013 FORMAT('ICH1(I),I=1,8)--',80A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)(ICH2(I),I=1,8)
9014 FORMAT('ICH2(I),I=1,8)--',80A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)ILOCST,ILOC1,ISTART,ISTOP,ILOC2
9015 FORMAT('ILOCST,ILOC1,ISTART,ISTOP,ILOC2 = ',5I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9016)IFOUND,IERROR
9016 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9017)N2
9017 FORMAT('N2 = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9018)(IFUNC2(I),I=1,N2)
9018 FORMAT('IFUNC2(.) = ',115A1)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPEXTE(IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR)
C
C PURPOSE--EXTEND A VARIABLE X BY APPENDING VARIABLE Y
C TO THE END OF X.
C EXAMPLE--EXTEND X Y
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-921-3651
C NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C OF THE NATIONAL BUREAU OF STANDARDS.
C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C MODIFIED, OR OTHERWISE USED IN A CONTEXT
C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--82/7
C ORIGINAL VERSION (IN DPLET)--APRIL 1984.
C UPDATED --JUNE 1990. ADD ISUBRO ARGUMENT
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IBUGS2
CHARACTER*4 IBUGQ
CHARACTER*4 IFOUND
CHARACTER*4 IERROR
CCCCC FOLLOWING LINE ADDED JUNE, 1990.
CHARACTER*4 ISUBRO
C
CHARACTER*4 IVAR11
CHARACTER*4 IVAR12
CHARACTER*4 IVAR21
CHARACTER*4 IVAR22
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
C-----COMMON----------------------------------------------------------
C
INCLUDE 'DPCOPA.INC'
INCLUDE 'DPCOHK.INC'
INCLUDE 'DPCODA.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
ISUBN1='DPEX'
ISUBN2='TE '
C
MAXCP1=MAXCOL+1
MAXCP2=MAXCOL+2
MAXCP3=MAXCOL+3
MAXCP4=MAXCOL+4
MAXCP5=MAXCOL+5
MAXCP6=MAXCOL+6
C
IFOUND='YES'
IERROR='NO'
C
I2=0
N1=0
N2=0
ICOL1=0
ICOL2=0
C
IVAR11='UNKN'
IVAR12='UNKN'
IVAR21='UNKN'
IVAR22='UNKN'
ILIST1=(-999)
ILIST2=(-999)
N1PN2=(-999)
N1PI=(-999)
IJ1=(-999)
IJ2=(-999)
N1NEW=(-999)
IROW1=(-999)
IROWN=(-99)
C
C **********************************************
C ** TREAT THE CASE OF EXTENDING A VARIABLE **
C ** WITH THE CONTENTS OF ANOTHER VARIABLE. **
C **********************************************
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 DPEXTE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBUGS2,IBUGQ
52 FORMAT('IBUGS2,IBUGQ = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C *******************************************************
C ** STEP 2-- **
C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. **
C *******************************************************
C
ISTEPN='2'
IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
MINNA=2
MAXNA=100
CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,
1IERROR)
IF(IERROR.EQ.'YES')GOTO9000
C
C ****************************************************************
C ** STEP 3--
C ** EXAMINE THE FIRST VARIABLE.
C ** IS IT IN THE TABLE?
C ** IS IT A VARIABLE?
C ** IVAR11 AND IVAR12 = THE NAME OF THE FIRST VARIABLE.
C ** ILIST1 = THE LINE IN THE INTERNAL TABLE
C ** WHERE THE FIRST VARIABLE IS FOUND.
C ** ICOL1 = THE DATA COLUMN FOR THE FIRST VARIABLE.
C ** N1 = THE NUMBER OF OBSERVATIONS FOR THE FIRST VARIABLE.
C ****************************************************************
C
ISTEPN='3'
IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IVAR11=IHARG(1)
IVAR12=IHARG2(1)
C
DO310I=1,NUMNAM
I2=I
IF(IVAR11.EQ.IHNAME(I).AND.IVAR12.EQ.IHNAM2(I).AND.
1IUSE(I).EQ.'V')GOTO380
IF(IVAR11.EQ.IHNAME(I).AND.IVAR12.EQ.IHNAM2(I).AND.
1IUSE(I).NE.'V')GOTO330
310 CONTINUE
C
320 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,321)
321 FORMAT('***** ERROR IN DPEXTE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,322)
322 FORMAT(' THE FIRST VARIABLE NAME REFERENCED ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,323)IVAR11,IVAR12
323 FORMAT(' (= ',A4,A4,')')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,324)
324 FORMAT(' WAS NOT FOUND IN THE INTERNAL NAME TABLE,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,325)
325 FORMAT(' SUGGESTED ACTION--USE THE STATUS COMMAND')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,326)
326 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES.')
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
330 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,331)
331 FORMAT('***** ERROR IN DPEXTE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,332)
332 FORMAT(' THE FIRST VARIABLE NAME REFERENCED ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,333)IVAR11,IVAR12
333 FORMAT(' (= ',A4,A4,')')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,334)
334 FORMAT(' SHOULD HAVE BEEN A VARIABLE, BUT WAS NOT.')
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
380 CONTINUE
ILIST1=I2
ICOL1=IVALUE(ILIST1)
N1=IN(ILIST1)
C
C ****************************************************************
C ** STEP 4--
C ** EXAMINE THE SECOND VARIABLE.
C ** IS IT IN THE TABLE?
C ** IS IT A VARIABLE?
C ** IVAR21 AND IVAR22 = THE NAME OF THE SECOND VARIABLE.
C ** ILIST2 = THE LINE IN THE INTERNAL TABLE
C ** WHERE THE SECOND VARIABLE IS FOUND.
C ** ICOL2 = THE DATA COLUMN FOR THE SECOND VARIABLE.
C ** N2 = THE NUMBER OF OBSERVATIONS FOR THE SECOND VARIABLE.
C ****************************************************************
C
ISTEPN='4'
IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IVAR21=IHARG(2)
IVAR22=IHARG2(2)
C
DO410I=1,NUMNAM
I2=I
IF(IVAR21.EQ.IHNAME(I).AND.IVAR22.EQ.IHNAM2(I).AND.
1IUSE(I).EQ.'V')GOTO480
IF(IVAR21.EQ.IHNAME(I).AND.IVAR22.EQ.IHNAM2(I).AND.
1IUSE(I).NE.'V')GOTO430
410 CONTINUE
C
420 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,421)
421 FORMAT('***** ERROR IN DPEXTE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,422)
422 FORMAT(' THE SECOND VARIABLE NAME REFERENCED ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,423)IVAR21,IVAR22
423 FORMAT(' (= ',A4,A4,')')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,424)
424 FORMAT(' WAS NOT FOUND IN THE INTERNAL NAME TABLE,')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,425)
425 FORMAT(' SUGGESTED ACTION--USE THE STATUS COMMAND')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,426)
426 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES.')
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
430 CONTINUE
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,431)
431 FORMAT('***** ERROR IN DPEXTE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,432)
432 FORMAT(' THE SECOND VARIABLE NAME REFERENCED ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,433)IVAR21,IVAR22
433 FORMAT(' (= ',A4,A4,')')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,434)
434 FORMAT(' SHOULD HAVE BEEN A VARIABLE, BUT WAS NOT.')
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
480 CONTINUE
ILIST2=I2
ICOL2=IVALUE(ILIST2)
N2=IN(ILIST2)
C
ISTEPN='6'
IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C ***********************************************
C ** STEP 6-- **
C ** DO A PRELIMINARY CHECK-- **
C ** WILL APPENDING VARIABLE 2 TO VARIABLE 1 **
C ** MAKE VARIABLE 1 TOO LONG? **
C ** (THAT IS, WILL IT EXCEED MAXN)? **
C ***********************************************
C
N1PN2=N1+N2
IF(N1PN2.LE.MAXN)GOTO690
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,621)
621 FORMAT('***** ERROR IN DPEXTE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,622)IVAR11,IVAR12
622 FORMAT(' THE EXTENSION OF VARIABLE ',A4,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,623)IVAR21,IVAR22
623 FORMAT(' BY VARIABLE ',A4,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,624)IVAR11,IVAR12
624 FORMAT(' WILL MAKE VARIABLE ',A4,A4,' TOO LONG.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,625)IVAR11,IVAR12,N1
625 FORMAT(' NUMBER OF OBSERVATIONS IN ',A4,A4,' = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,626)IVAR21,IVAR22,N2
626 FORMAT(' NUMBER OF OBSERVATIONS IN ',A4,A4,' = ' ,I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,627)IVAR11,IVAR12,N1PN2
627 FORMAT(' NEW NUMBER OF OBSERVATIONS IN ',A4,A4,
1' WOULD = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,628)MAXN
628 FORMAT(' ALLOWABLE NUMBER OF OBSERVATIONS = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,629)
629 FORMAT(' THEREFORE, NO EXTENSION CARRIED OUT.')
CALL DPWRST('XXX','BUG ')
IERROR='YES'
GOTO9000
C
690 CONTINUE
C
C ****************************************************
C ** STEP 10-- **
C ** APPEND VARIABLE 2 ONTO THE END OF VARIABLE 1 **
C ****************************************************
C
ISTEPN='10'
IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
DO2100I=1,N2
N1PI=N1+I
IJ1=MAXN*(ICOL1-1)+N1PI
IJ2=MAXN*(ICOL2-1)+I
IF(ICOL1.LE.MAXCOL)V(IJ1)=V(IJ2)
IF(ICOL1.EQ.MAXCP1)PRED(N1PI)=Y(IJ2)
IF(ICOL1.EQ.MAXCP2)RES(N1PI)=Y(IJ2)
2100 CONTINUE
N1NEW=N1PI
C
C *******************************************
C ** STEP 11-- **
C ** CARRY OUT THE LIST UPDATING AND **
C ** GENERATE THE INFORMATIVE PRINTING. **
C *******************************************
C
ISTEPN='11'
IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IHNAME(ILIST1)=IVAR11
IHNAM2(ILIST1)=IVAR12
IUSE(ILIST1)='V'
IVALUE(ILIST1)=ICOL1
VALUE(ILIST1)=ICOL1
IN(ILIST1)=N1NEW
C
DO2400J4=1,NUMNAM
IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOL1)GOTO2405
GOTO2400
2405 CONTINUE
IUSE(J4)='V'
IVALUE(J4)=ICOL1
VALUE(J4)=ICOL1
IN(J4)=N1NEW
2400 CONTINUE
C
IF(IPRINT.EQ.'OFF')GOTO2459
IF(IFEEDB.EQ.'OFF')GOTO2459
NNUM=N2
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2411)IVAR11,IVAR12,NNUM
2411 FORMAT('THE NUMBER OF VALUES ADDED TO ',
1'THE VARIABLE ',A4,A4,' = ',I8)
CALL DPWRST('XXX','BUG ')
C
IROW1=N1+1
IROWN=N1+N2
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
IJ=MAXN*(ICOL1-1)+IROW1
IF(ICOL1.LE.MAXCOL)WRITE(ICOUT,2421)IVAR11,IVAR12,V(IJ),
1IROW1
IF(ICOL1.LE.MAXCOL)CALL DPWRST('XXX','BUG ')
IF(ICOL1.EQ.MAXCP1)WRITE(ICOUT,2421)IVAR11,IVAR12,PRED(IROW1),
1IROW1
IF(ICOL1.EQ.MAXCP1)CALL DPWRST('XXX','BUG ')
IF(ICOL1.EQ.MAXCP2)WRITE(ICOUT,2421)IVAR11,IVAR12,RES(IROW1),
1IROW1
2421 FORMAT('THE FIRST VALUE ADDED TO ',A4,A4,
1' = ',E15.7,' (ROW ',I6,')')
IF(ICOL1.EQ.MAXCP2)CALL DPWRST('XXX','BUG ')
IJ=MAXN*(ICOL1-1)+IROWN
IF(ICOL1.LE.MAXCOL.AND.
1NNUM.NE.1)WRITE(ICOUT,2431)NNUM,IVAR11,IVAR12,V(IJ),IROWN
IF(ICOL1.LE.MAXCOL.AND.
1NNUM.NE.1)CALL DPWRST('XXX','BUG ')
IF(ICOL1.EQ.MAXCP1.AND.
1NNUM.NE.1)WRITE(ICOUT,2431)NNUM,IVAR11,IVAR12,PRED(IROWN),IROWN
IF(ICOL1.EQ.MAXCP1.AND.
1NNUM.NE.1)CALL DPWRST('XXX','BUG ')
IF(ICOL1.EQ.MAXCP2.AND.
1NNUM.NE.1)WRITE(ICOUT,2431)NNUM,IVAR11,IVAR12,RES(IROWN),IROWN
2431 FORMAT('THE LAST (',I5,'-TH) VALUE ADDED TO ',A4,A4,
1' = ',E15.7,' (ROW ',I6,')')
IF(ICOL1.EQ.MAXCP2.AND.
1NNUM.NE.1)CALL DPWRST('XXX','BUG ')
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2453)IVAR11,IVAR12,N1NEW
2453 FORMAT('THE NEW LENGTH OF ',
1'THE VARIABLE ',A4,A4,' = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
2459 CONTINUE
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
IF(IBUGS2.EQ.'OFF')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPEXTE--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IFOUND,IERROR
9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)IBUGS2,IBUGQ
9013 FORMAT('IBUGS2,IBUGQ = ',A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9021)IVAR11,IVAR12,ILIST1,ICOL1,N1
9021 FORMAT('IVAR11,IVAR12,ILIST1,ICOL1,N1 = ',A4,2X,A4,3I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9022)IVAR22,IVAR22,ILIST2,ICOL2,N2
9022 FORMAT('IVAR22,IVAR22,ILIST2,ICOL2,N2 = ',A4,2X,A4,3I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9023)N1PI,N1PN2,N1NEW,IROW1,IROWN,IJ1,IJ2
9023 FORMAT('N1PI,N1PN2,N1NEW,IROW1,IROWN,IJ1,IJ2 = ',6I8)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPEXTL(IHRE11,IHRE12,IHRE21,IHRE22,
1KNUMB,IVAL1,IVAL2,IBUGS2,ISUBRO,IERROR)
C
C PURPOSE--EXTRACT "TO" LIMITS.
C DO A CHARACTER-BY-CHARACTER COMPARISON
C OF IHRE11/IHRE12 AND IHRE21/IHRE22,
C AND NOTE (THIS WILL BECOME KNUMB)
C WHERE THE TRAILING NUMBERS BEGIN.
C THEN EXTRACT THE 2 TRAILING NUMERIC STRINGS
C AND CONVERT
C THESE 2 NUMBERS INTO INTEGERS (IVAL1 AND IVAL2)
C
C ORIGINAL VERSION--DECEMBER 1986.
C
C---------------------------------------------------------------------
C
CHARACTER*4 IHRE11
CHARACTER*4 IHRE12
CHARACTER*4 IHRE21
CHARACTER*4 IHRE22
CHARACTER*4 IBUGS2
CHARACTER*4 ISUBRO
CHARACTER*4 IERROR
C
CHARACTER*4 IVALI3
CHARACTER*4 IVALI4
CHARACTER*8 IS1
CHARACTER*8 IS2
CHARACTER*4 IS3
CHARACTER*4 IS4
C
CHARACTER*1 IC
C
DIMENSION IS3(8)
DIMENSION IS4(8)
C
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
KDIFF=(-999)
KNUMB=(-999)
IVAL1=(-999)
IVAL2=(-999)
IERROR='NO'
C
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'EXTL')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPEXTL--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBUGS2,ISUBRO,IERROR
52 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)IHRE11,IHRE12,IHRE21,IHRE22
53 FORMAT('IHRE11,IHRE12,IHRE21,IHRE22 = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C ****************************************************
C ** STEP 11-- **
C ** FORM IS1 WHICH WILL BE A CHARACTER*8 **
C ** COMBINATION OF IHRE11 AND IHRE12. **
C ** COPY IHRE11 INTO THE FIRST HALF OF IS1. **
C ** COPY IHRE12 INTO THE SECOND HALF OF IS1. **
C ** FORM IS2 WHICH WILL BE A CHARACTER*8 **
C ** COMBINATION OF IHRE21 AND IHRE22. **
C ** COPY IHRE21 INTO THE FIRST HALF OF IS2. **
C ** COPY IHRE22 INTO THE SECOND HALF OF IS2. **
C ** FORM IS3 WHICH WILL BE A 8-TERM VECTOR **
C ** VERSION OF IS1. **
C ** FORM IS4 WHICH WILL BE A 8-TERM VECTOR **
C ** VERSION OF IS2. **
C ****************************************************
C
IS1(1:8)=' '
IS2(1:8)=' '
IS1(1:4)=IHRE11
IS1(5:8)=IHRE12
IS2(1:4)=IHRE21
IS2(5:8)=IHRE22
C
DO 1100 K=1,8
IS3(K)=' '
IS4(K)=' '
IS3(K)=IS1(K:K)
IS4(K)=IS2(K:K)
1100 CONTINUE
C
C ****************************************************
C ** STEP 12-- **
C ** FORM IS3 WHICH WILL BE A 8-TERM VECTOR **
C ** DETERMINE THE LENGTH OF THE NON-BLANK **
C ** PART OF IS3. **
C ** DETERMINE THE LENGTH OF THE NON-BLANK **
C ** PART OF IS4. **
C ****************************************************
C
DO1210K=1,8
KREV=8-K+1
IF(IS3(KREV).NE.' ')GOTO1219
1210 CONTINUE
KREV=0
1219 CONTINUE
NS3=KREV
C
DO1220K=1,8
KREV=8-K+1
IF(IS4(KREV).NE.' ')GOTO1229
1220 CONTINUE
KREV=0
1229 CONTINUE
NS4=KREV
C
C *******************************************
C ** STEP 13-- **
C ** DETERMINE THE POSITION (1 TO 8) **
C ** WHEREBY IS1 AND IS2 **
C ** (OR EQUIVALENTLY IS3 AND IS4) **
C ** FIRST DIFFER. **
C *******************************************
C
C
DO1300K=1,8
KDIFF=K
IF(IS3(K).NE.IS4(K))GOTO1390
1300 CONTINUE
C
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1311)
1311 FORMAT('***** ERROR IN DPEXTL--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1312)
1312 FORMAT(' NO DIFFERENCE FOUND IN ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1313)
1313 FORMAT(' THE 2 REFERENCE STRINGS')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1314)
1314 FORMAT(' IN ATTEMPTING TO EXTRACT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1315)
1315 FORMAT(' LIMITS IN CONNECTION WITH THE TO KEYWORD.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1316)IS1
1316 FORMAT(' IS1 = ',A8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1317)IS2
1317 FORMAT(' IS2 = ',A8)
CALL DPWRST('XXX','BUG ')
GOTO9000
C
1390 CONTINUE
C
C *************************************************
C ** STEP 14-- **
C ** STEP BACK TO SEE IF PREVIOUS CHARACTERS **
C ** ARE DIGITS **
C *************************************************
C
KNUMB=KDIFF
KDIFM1=KDIFF-1
IF(KDIFM1.LE.0)GOTO1490
DO1400K=1,KDIFM1
KREV=KDIFM1-K+1
IC=IS1(KREV:KREV)
CALL DPCOAN(IC,IX)
IF(IX.LE.47)GOTO1490
IF(IX.GE.58)GOTO1490
KNUMB=KREV
1400 CONTINUE
1490 CONTINUE
K31=KNUMB
K32=NS3
K41=KNUMB
K42=NS4
C
C *************************************************
C ** STEP 15-- **
C ** EXTRACT THE TRAILING DIFFERERING STRING **
C ** FOR IS1 AND CONVERT IT TO AN INTEGER. **
C ** EXTRACT THE TRAILING DIFFERERING STRING **
C ** FOR IS2 AND CONVERT IT TO AN INTEGER. **
C *************************************************
C
CALL DPCOHI(K31,K32,IS3,NS3,IVALI3,VALCO3,IVALC3,
1IBUGS2,IERROR)
CALL DPCOHI(K41,K42,IS4,NS4,IVALI4,VALCO4,IVALC4,
1IBUGS2,IERROR)
C
IVAL1=IVALC3
IVAL2=IVALC4
C
C *****************
C ** STEP 90-- **
C ** EXIT. **
C *****************
C
9000 CONTINUE
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'EXTL')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPEXTL--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGS2,ISUBRO,IERROR
9012 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)IHRE11,IHRE12,IHRE21,IHRE22
9013 FORMAT('IHRE11,IHRE12,IHRE21,IHRE22 = ',A4,2X,A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)KDIFF,KNUMB,IVAL1,IVAL2
9014 FORMAT('KDIFF,KNUMB,IVAL1,IVAL2 = ',4I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)IS1,NS3,K31,K32
9015 FORMAT('IS1,NS3,K31,K32 = ',A8,2X,3I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9016)IVALI3,VALCO3,IVALC3,IVAL1
9016 FORMAT('IVALI3,VALCO3,IVALC3,IVAL1 = ',A4,E15.7,2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9017)IS2,NS4,K41,K42
9017 FORMAT('IS2,NS4,K41,K42 = ',A8,2X,3I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9018)IVALI4,VALCO4,IVALC4,IVAL2
9018 FORMAT('IVALI4,VALCO4,IVALC4,IVAL2 = ',A4,E15.7,2I8)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPEXWO(ISTRIN,ISTART,ISTOP,IWORD,
1ICOL1,ICOL2,ISTRI2,NCSTR2,
1IBUGS2,ISUBRO,IERROR)
C
C PURPOSE--SCAN THE CHARACTER*80 VARIABLE ISTRIN
C BETWEEN COLUMNS ISTART TO ISTOP
C AND EXTRACT THE IWORD-TH WORD
C IN THAT INTERVAL.
C PLACE THE FIRST AND LAST COLUMNS
C OF THE IWORD-TH WORD INTO ICOL1 AND ICOL2,
C PLACE THE IWORD-TH WORD ITSELF INTO
C THE CHARACTER*80 VARIABLE ISTRI2;
C PLACE THE NUMBER OF CHARACTERS IN THIS
C IWORD-TH WORD INTO NCSTR2.
C THE CHARACTER*80 STRING ISTRI2,
C AND PLACE THE LENGTH OF
C THE STRING INTO NCSTR2.
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 UPDATED --APRIL 1997. DO NOT RESTRICT TO 80 CHARACTERS
C UPDATED --JULY 2002. ALLOW WORD TO BE ENCLOSED IN
C QUOTES (PC FILE NAMES CAN
C HAVE SPACES)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CCCCC USE DUMMY DIMENSIONING TO REMOVE ARTIFICIAL RESTRICTION ON
CCCCC 80 CHARACTERS. APRIL 1997.
CCCCC CHARACTER*80 ISTRIN
CCCCC CHARACTER*80 ISTRI2
CHARACTER*(*) ISTRIN
CHARACTER*(*) ISTRI2
CHARACTER*4 IBUGS2
CHARACTER*4 ISUBRO
CHARACTER*4 IERROR
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
INCLUDE 'DPCOST.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
CHARACTER*4 IFEEDB
CHARACTER*4 IPRINT
CHARACTER*240 ICOUT
C
COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
COMMON /PRINT/IFEEDB,IPRINT
COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
ISUBN1='DPEX'
ISUBN2='WO '
C
IERROR='NO'
C
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'EXWO')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPEXWO--')
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,MIN(100,ISTOP))
54 FORMAT('(ISTRIN(J:J),J=1,100) = ',100A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,55)ISTART,ISTOP
55 FORMAT('ISTART,ISTOP = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,56)IWORD
56 FORMAT('IWORD = ',I8)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C **************************************
C ** STEP 11-- **
C ** INITIALIZE THE OUTPUT VARIABLES **
C **************************************
C
ISTEPN='11'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXWO')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ICOL1=(-999)
ICOL2=(-999)
NCSTR2=(-999)
CCCCC FOLLOWING CHANGED APRIL 1997
ISTRI2=' '
CCCCC DO1100I=1,80
DO1100I=1,ISTOP
ISTRI2(I:I)=' '
1100 CONTINUE
C
C *******************************************
C ** STEP 12-- **
C ** CHECK THE INPUT ARGUMENTS **
C *******************************************
C
ISTEPN='12'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXWO')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CCCCC NO CHECK ON UPPER LIMIT. APRIL 1997.
CCCCC IF(ISTART.GE.1.AND.ISTOP.GE.1.AND.
CCCCC1 ISTART.LE.80.AND.ISTOP.LE.80)GOTO1219
IF(ISTART.GE.1.AND.ISTOP.GE.1)GOTO1219
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1211)
1211 FORMAT('***** ERROR IN DPEXWO--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1212)
C1212 FORMAT(' ISTART OR ISTOP IS < 1 OR > 80. ')
1212 FORMAT(' ISTART OR ISTOP IS < 1. ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1213)ISTART
1213 FORMAT(' ISTART = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1214)ISTOP
1214 FORMAT(' ISTOP = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1216)(ISTRIN(I:I),I=1,MIN(100,ISTOP))
1216 FORMAT(' (ISTRIN(I:I),I=1,100) = ',100A1)
CALL DPWRST('XXX','BUG ')
GOTO9000
1219 CONTINUE
C
IF(ISTART.LE.ISTOP)GOTO1229
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1221)
1221 FORMAT('***** ERROR IN DPEXWO--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1222)
1222 FORMAT(' ISTART EXCEEDS ISTOP')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1223)ISTART
1223 FORMAT(' ISTART = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1224)ISTOP
1224 FORMAT(' ISTOP = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1216)(ISTRIN(I:I),I=1,MIN(100,ISTOP))
1226 FORMAT(' (ISTRIN(I:I),I=1,100) = ',100A1)
CALL DPWRST('XXX','BUG ')
GOTO9000
1229 CONTINUE
C
IF(IWORD.GE.1)GOTO1239
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1231)
1231 FORMAT('***** ERROR IN DPEXWO--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1232)
1232 FORMAT(' IWORD IS LESS THAN 1 .')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1233)IWORD
1233 FORMAT(' IWORD = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1236)(ISTRIN(I:I),I=1,MIN(ISTOP,100))
1236 FORMAT(' (ISTRIN(I:I),I=1,100) = ',100A1)
CALL DPWRST('XXX','BUG ')
GOTO9000
1239 CONTINUE
C
C ************************************************
C ** STEP 21-- **
C ** IDENTIFY THE COLUMNS WHERE **
C ** THE IWORD-TH STRING RESIDES **
C ** ICOL1 = START COLUMN OF A STRING **
C ** ICOL2 = STOP COLUMN OF A STRING **
C ************************************************
C
ICOL2=ISTART-1
DO2100ILOOP=1,IWORD
C
ICOL1=ISTOP+1
IMIN=ICOL2+1
IF(IMIN.GT.ISTOP)GOTO2119
IQUOTE=0
DO2110I=IMIN,ISTOP
I2=I
IF(ISTRIN(I:I).NE.' ' .AND. ISTRIN(I:I).NE.'-')THEN
IF(IFILQU.EQ.'ON' .AND. ISTRIN(I:I).EQ.'"')IQUOTE=1
GOTO2115
ENDIF
2110 CONTINUE
ICOL1=ISTOP+1
GOTO2119
2115 CONTINUE
ICOL1=I2
GOTO2119
2119 CONTINUE
C
ICOL2=ISTOP
IMIN=ICOL1+1
IF(IMIN.GT.ISTOP)GOTO2129
DO2120I=IMIN,ISTOP
I2=I
IF(IQUOTE.EQ.0)THEN
IF(ISTRIN(I:I).EQ.' ' .OR. ISTRIN(I:I).EQ.'-')GOTO2125
ELSE
IF(ISTRIN(I:I).EQ.'"')GOTO2126
ENDIF
2120 CONTINUE
ICOL2=ISTOP
GOTO2129
2125 CONTINUE
ICOL2=I2-1
GOTO2129
2126 CONTINUE
ICOL2=I2
GOTO2129
2129 CONTINUE
C
IF(ICOL1.GE.ISTART.AND.ICOL2.GE.ISTART.AND.
1 ICOL1.LE.ISTOP.AND.ICOL2.LE.ISTOP)GOTO2139
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2131)
2131 FORMAT('***** ERROR IN DPEXWO--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2132)
2132 FORMAT(' ICOL1 OR ICOL2 IS < ISTART OR > ISTOP. ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2133)ICOL1
2133 FORMAT(' ICOL1 = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2134)ICOL2
2134 FORMAT(' ICOL2 = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2135)ISTART
2135 FORMAT(' ISTART = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2136)ISTOP
2136 FORMAT(' ISTOP = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2137)(ISTRIN(I:I),I=1,80)
2137 FORMAT(' (ISTRIN(I:I),I=1,80) = ',80A1)
CALL DPWRST('XXX','BUG ')
GOTO9000
2139 CONTINUE
C
IF(ICOL1.LE.ICOL2)GOTO2149
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2141)
2141 FORMAT('***** ERROR IN DPEXWO--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2142)
2142 FORMAT(' ICOL1 EXCEEDS ICOL2')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2143)ICOL1
2143 FORMAT(' ICOL1 = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2144)ICOL2
2144 FORMAT(' ICOL2 = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1216)(ISTRIN(I:I),I=1,MIN(80,ISTOP))
2146 FORMAT(' (ISTRIN(I:I),I=1,80) = ',80A1)
CALL DPWRST('XXX','BUG ')
GOTO9000
2149 CONTINUE
C
2100 CONTINUE
C
C *********************************************
C ** STEP 22-- **
C ** COPY THE IWORD-TH STRING INTO ISTRI2 **
C *********************************************
C
ISTEPN='22'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXWO')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
J=0
DO2200I=ICOL1,ICOL2
J=J+1
ISTRI2(J:J)=ISTRIN(I:I)
2200 CONTINUE
NCSTR2=J
C
C ****************
C ** STEP 90-- **
C ** EXIT. **
C ****************
C
9000 CONTINUE
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'EXWO')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPEXWO--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)IBUGS2,ISUBRO,IERROR
9013 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,9014)(ISTRIN(J:J),J=1,80)
WRITE(ICOUT,9014)(ISTRIN(J:J),J=1,MIN(100,ISTOP))
9014 FORMAT('(ISTRIN(J:J),J=1,100) = ',100A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)ISTART,ISTOP
9015 FORMAT('ISTART,ISTOP = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9016)IWORD
9016 FORMAT('IWORD = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9021)ICOL1,ICOL2
9021 FORMAT('ICOL1, ICOL2 = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9022)NCSTR2
9022 FORMAT('NCSTR2 = ',I8)
CALL DPWRST('XXX','BUG ')
IF(NCSTR2.GE.1)THEN
WRITE(ICOUT,9023)(ISTRI2(I:I),I=1,MIN(100,NCSTR2))
9023 FORMAT('(ISTRI2(I:I),I=1,NCSTR2) = ',100A1)
CALL DPWRST('XXX','BUG ')
ENDIF
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPEXW2(IFUNC2,N2,ISTART,ISTOP,IWORD,
1ICOL1,ICOL2,IFUNC3,N3,
1IBUGS2,ISUBRO,IERROR)
C
C PURPOSE--SCAN THE CHARACTER*4 DIMENSIONED VARIABLE IFUNC2
C BETWEEN COLUMNS ISTART TO ISTOP
C AND EXTRACT THE IWORD-TH WORD
C IN THAT INTERVAL.
C PLACE THE FIRST AND LAST COLUMNS
C OF THE IWORD-TH WORD INTO ICOL1 AND ICOL2,
C PLACE THE IWORD-TH WORD ITSELF INTO
C THE CHARACTER*4 DIMENSIONED VARIABLE IFUNC3;
C PLACE THE NUMBER OF CHARACTERS IN THIS
C IWORD-TH WORD INTO N3.
C
C NOTE--THIS SUBROUTINE IS SIMILAR
C (ALTHOUGH THE INPUT ARGUMENT STRUCTURE DIFFERS
C BY 2 EXTRA ARGUMENTS),
C TO SUBROUTINE DPEXWO EXCEPT
C DPEXWO OPERATES ON UNDIMENSIONED
C CHARACTER*80 VARIABLES IFUNC2 AND IFUNC3,
C WHEREAS THIS SUBROUTINE DPEXW2
C OPERATES ON CHARACTER*4 DIMENSIONED
C VARIABLES IFUNC2 AND IFUNC3.
C THE FACT THAT THE VARIABLES ARE HERE DIMENSIONED
C BECAUSE THEY ARE THEN NOT RESTRICTED
C TO 80, OR 132, OR WHATEVER.
C NOTE--EVEN THOUGH VARIABLES IFUNC2 AND IFUNC3
C ARE CHARACTER*4, THERE IS NO ESSENTIAL
C USE BEING MADE OF POSITIONS 2, 3, AND 4, AND SO
C (IF CHANGES WERE MADE IN THE CALLING ROUTINE),
C IFUNC2 AND IFUNC3 COULD JUST AS WELL
C HAVE BEEN CHARACTER*1 .
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-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/7
C ORIGINAL VERSION--JULY 1986.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CHARACTER*4 IFUNC2
CHARACTER*4 IFUNC3
CHARACTER*4 IBUGS2
CHARACTER*4 ISUBRO
CHARACTER*4 IERROR
C
CHARACTER*4 ISUBN1
CHARACTER*4 ISUBN2
CHARACTER*4 ISTEPN
C
DIMENSION IFUNC2(*)
DIMENSION IFUNC3(*)
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='DPEX'
ISUBN2='W2 '
C
IERROR='NO'
C
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'EXW2')GOTO90
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,51)
51 FORMAT('***** AT THE BEGINNING OF DPEXW2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,52)IBUGS2,ISUBRO,IERROR
52 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,53)N2
53 FORMAT('N2 = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,54)(IFUNC2(J),J=1,100)
54 FORMAT('(IFUNC2(J),J=1,100) = ',100A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,55)ISTART,ISTOP
55 FORMAT('ISTART,ISTOP = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,56)IWORD
56 FORMAT('IWORD = ',I8)
CALL DPWRST('XXX','BUG ')
90 CONTINUE
C
C **************************************
C ** STEP 11-- **
C ** INITIALIZE THE OUTPUT VARIABLES **
C **************************************
C
ISTEPN='11'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXW2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
ICOL1=(-999)
ICOL2=(-999)
N3=(-999)
DO1100I=1,N2
IFUNC3(I)=' '
1100 CONTINUE
C
C *******************************************
C ** STEP 12-- **
C ** CHECK THE INPUT ARGUMENTS **
C *******************************************
C
ISTEPN='12'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXW2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
IF(ISTART.GE.1.AND.ISTOP.GE.1.AND.
1 ISTART.LE.N2.AND.ISTOP.LE.N2)GOTO1219
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1211)
1211 FORMAT('***** ERROR IN DPEXW2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1212)N2
1212 FORMAT(' ISTART OR ISTOP IS < 1 OR > ',I8,'.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1213)ISTART
1213 FORMAT(' ISTART = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1214)ISTOP
1214 FORMAT(' ISTOP = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1216)(IFUNC2(I),I=1,100)
1216 FORMAT(' (IFUNC2(I),I=1,100) = ',100A1)
CALL DPWRST('XXX','BUG ')
GOTO9000
1219 CONTINUE
C
IF(ISTART.LE.ISTOP)GOTO1229
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1221)
1221 FORMAT('***** ERROR IN DPEXW2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1222)
1222 FORMAT(' ISTART EXCEEDS ISTOP')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1223)ISTART
1223 FORMAT(' ISTART = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1224)ISTOP
1224 FORMAT(' ISTOP = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1216)(IFUNC2(I),I=1,100)
1226 FORMAT(' (IFUNC2(I),I=1,100) = ',100A1)
CALL DPWRST('XXX','BUG ')
GOTO9000
1229 CONTINUE
C
IF(IWORD.GE.1)GOTO1239
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1231)
1231 FORMAT('***** ERROR IN DPEXW2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1232)
1232 FORMAT(' IWORD IS LESS THAN 1 .')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1233)IWORD
1233 FORMAT(' IWORD = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1236)(IFUNC2(I),I=1,100)
1236 FORMAT(' (IFUNC2(I),I=1,100) = ',100A1)
CALL DPWRST('XXX','BUG ')
GOTO9000
1239 CONTINUE
C
C ************************************************
C ** STEP 21-- **
C ** IDENTIFY THE COLUMNS WHERE **
C ** THE IWORD-TH STRING RESIDES **
C ** ICOL1 = START COLUMN OF A STRING **
C ** ICOL2 = STOP COLUMN OF A STRING **
C ************************************************
C
ICOL2=ISTART-1
DO2100ILOOP=1,IWORD
C
ICOL1=ISTOP+1
IMIN=ICOL2+1
IF(IMIN.GT.ISTOP)GOTO2119
DO2110I=IMIN,ISTOP
I2=I
IF(IFUNC2(I).NE.' ')GOTO2115
2110 CONTINUE
ICOL1=ISTOP+1
GOTO2119
2115 CONTINUE
ICOL1=I2
GOTO2119
2119 CONTINUE
C
ICOL2=ISTOP
IMIN=ICOL1+1
IF(IMIN.GT.ISTOP)GOTO2129
DO2120I=IMIN,ISTOP
I2=I
IF(IFUNC2(I).EQ.' ')GOTO2125
2120 CONTINUE
ICOL2=ISTOP
GOTO2129
2125 CONTINUE
ICOL2=I2-1
GOTO2129
2129 CONTINUE
IF(ICOL1.GE.ISTART.AND.ICOL2.GE.ISTART.AND.
1 ICOL1.LE.ISTOP.AND.ICOL2.LE.ISTOP)GOTO2139
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2131)
2131 FORMAT('***** ERROR IN DPEXW2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2132)
2132 FORMAT(' ICOL1 OR ICOL2 IS < ISTART OR > ISTOP. ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2133)ICOL1
2133 FORMAT(' ICOL1 = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2134)ICOL2
2134 FORMAT(' ICOL2 = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2135)ISTART
2135 FORMAT(' ISTART = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2136)ISTOP
2136 FORMAT(' ISTOP = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2137)(IFUNC2(I),I=1,100)
2137 FORMAT(' (IFUNC2(I),I=1,100) = ',100A1)
CALL DPWRST('XXX','BUG ')
GOTO9000
2139 CONTINUE
C
IF(ICOL1.LE.ICOL2)GOTO2149
IERROR='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2141)
2141 FORMAT('***** ERROR IN DPEXW2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2142)
2142 FORMAT(' ICOL1 EXCEEDS ICOL2')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2143)ICOL1
2143 FORMAT(' ICOL1 = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2144)ICOL2
2144 FORMAT(' ICOL2 = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1216)(IFUNC2(I),I=1,100)
2146 FORMAT(' (IFUNC2(I),I=1,100) = ',100A1)
CALL DPWRST('XXX','BUG ')
GOTO9000
2149 CONTINUE
C
2100 CONTINUE
C
C *********************************************
C ** STEP 22-- **
C ** COPY THE IWORD-TH STRING INTO IFUNC3 **
C *********************************************
C
ISTEPN='22'
IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'EXW2')
1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
J=0
DO2200I=ICOL1,ICOL2
J=J+1
IFUNC3(J)=IFUNC2(I)
2200 CONTINUE
N3=J
C
C ****************
C ** STEP 90-- **
C ** EXIT. **
C ****************
C
9000 CONTINUE
IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'EXW2')GOTO9090
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9011)
9011 FORMAT('***** AT THE END OF DPEXW2--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9012)IBUGS2,ISUBRO,IERROR
9012 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9013)N2
9013 FORMAT('N2 = ',A4)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9014)(IFUNC2(J),J=1,100)
9014 FORMAT('(IFUNC2(J),J=1,100) = ',100A1)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9015)ISTART,ISTOP
9015 FORMAT('ISTART,ISTOP = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9016)IWORD
9016 FORMAT('IWORD = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9021)ICOL1,ICOL2
9021 FORMAT('ICOL1, ICOL2 = ',2I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9022)N3
9022 FORMAT('N3 = ',I8)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,9023)(IFUNC3(I),I=1,100)
9023 FORMAT('(IFUNC3(I),I=1,N3) = ',100A1)
CALL DPWRST('XXX','BUG ')
9090 CONTINUE
C
RETURN
END
SUBROUTINE DPEYCO(IHARG,IARGT,ARG,NUMARG,
1AEYEXC,AEYEYC,AEYEZC,
1X3DEYE,Y3DEYE,Z3DEYE,
1IFOUND,IERROR)
C
C PURPOSE--DEFINE THE (X,Y,Z) EYE COORDINATES CONTAINED IN THE
C 3 VARAIBLES AEYEXC,AEYEYC,AEYEZC
C SUCH EYE COORDINATES ARE USED IN 3-DIMENSIONAL PLOTS.
C COMMAND = EYE (COORDINATES) ... ... ...
C NOTE--LOGIC HEREIN ASSUMES THE WORD COORDINATES HAS BEEN
C SHIFTED OUT (DONE IN MAIPC4).
C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR)
C --IARGT (A HOLLERITH VECTOR)
C --ARG (A FLOATING POINT VECTOR)
C --NUMARG
C OUTPUT ARGUMENTS--AEYEXC = X-COORDINATE OF EYE
C --AEYEYC = Y-COORDINATE OF EYE
C --AEYEZC = Z-COORDINATE OF EYE
C --IFOUND ('YES' OR 'NO' )
C --IERROR ('YES' OR 'NO' )
C WRITTEN BY--JAMES J. FILLIBEN
C STATISTICAL ENGINEERING DIVISION
C CENTER FOR APPLIED MATHEMATICS
C NATIONAL BUREAU OF STANDARDS
C WASHINGTON, D. C. 20234
C PHONE--301-921-3651
C NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C OF THE NATIONAL BUREAU OF STANDARDS.
C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C MODIFIED, OR OTHERWISE USED IN A CONTEXT
C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C LANGUAGE--ANSI FORTRAN (1977)
C VERSION NUMBER--82/7
C ORIGINAL VERSION--NOVEMBER 1978.
C UPDATED --SEPTEMBER 1980.
C UPDATED --MAY 1982.
C UPDATED --SEPTEMBER 1993. REWRITE ALL
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
C ********************************************
C ** STEP 1-- **
C ** BRANCH ACCORDING TO THE CASE **
C ********************************************
C
IF(NUMARG.EQ.0)GOTO1000
IF(NUMARG.GE.1)THEN
IF(IHARG(NUMARG).EQ.'ON')GOTO1000
IF(IHARG(NUMARG).EQ.'OFF')GOTO1000
IF(IHARG(NUMARG).EQ.'AUTO')GOTO1000
IF(IHARG(NUMARG).EQ.'DEFA')GOTO1000
IF(IHARG(NUMARG).EQ.'?')GOTO3000
IF(IARGT(1).EQ.'NUMB'.OR.IARGT(2).EQ.'NUMB'.OR.
1 IARGT(3).EQ.'NUMB')GOTO2000
GOTO8000
ENDIF
C
C ********************************************
C ** STEP 11-- **
C ** TREAT THE DEFAULT CASE-- **
C ********************************************
C
1000 CONTINUE
IFOUND='YES'
AEYEXC=CPUMIN
AEYEYC=CPUMIN
AEYEZC=CPUMIN
IF(IFEEDB.EQ.'ON')THEN
WRITE(ICOUT,999)
999 FORMAT(1X)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1011)
1011 FORMAT('THE (X,Y,Z) EYE COORDINATES HAVE JUST BEEN SET')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1012)
1012 FORMAT('TO AUTOMATICALLY FLOAT WITH THE DATA.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1013)
1013 FORMAT('THE (X,Y,Z) EYE COORDINATES WILL BE')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1021)
1021 FORMAT(' X = XMIN + 3 * (XMAX - XMIN)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1022)
1022 FORMAT(' Y = YMIN + 3 * (YMAX - YMIN)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,1023)
1023 FORMAT(' Z = ZMIN + 3 * (ZMAX - ZMIN)')
CALL DPWRST('XXX','BUG ')
ENDIF
GOTO9000
C
C ********************************************
C ** STEP 12-- **
C ** TREAT THE USER-SPEC CASE-- **
C ********************************************
C
2000 CONTINUE
IFOUND='YES'
IF(IARGT(1).EQ.'NUMB'.AND.IHARG(1).NE.'.')THEN
AEYEXC=ARG(1)
X3DEYE=ARG(1)
ENDIF
IF(IARGT(2).EQ.'NUMB'.AND.IHARG(2).NE.'.')THEN
AEYEYC=ARG(2)
Y3DEYE=ARG(2)
ENDIF
IF(IARGT(3).EQ.'NUMB'.AND.IHARG(3).NE.'.')THEN
AEYEZC=ARG(3)
Z3DEYE=ARG(3)
ENDIF
IF(IFEEDB.EQ.'ON')THEN
WRITE(ICOUT,999)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2011)
2011 FORMAT('THE (X,Y,Z) EYE COORDINATES HAVE JUST BEEN SET TO')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2021)AEYEXC
2021 FORMAT(' X = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2022)AEYEYC
2022 FORMAT(' Y = ',E15.7)
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,2023)AEYEZC
2023 FORMAT(' Z = ',E15.7)
CALL DPWRST('XXX','BUG ')
ENDIF
GOTO9000
C
C ********************************************
C ** STEP 13-- **
C ** TREAT THE ? CASE-- **
C ** DUMP OUT CURRENT AND DEFAULT VALUES. **
C ********************************************
C
3000 CONTINUE
IFOUND='YES'
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,3011)
3011 FORMAT('THE CURRENT (X,Y,Z) EYE COORDINATES ARE')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,3021)X3DEYE
3021 FORMAT(' X = ',E15.7)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,3022)Y3DEYE
3022 FORMAT(' Y = ',E15.7)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,3023)Z3DEYE
3023 FORMAT(' Z = ',E15.7)
CALL DPWRST('XXX','WRIT')
C
WRITE(ICOUT,999)
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,3031)
3031 FORMAT('THE DEFAULT (X,Y,Z) EYE COORDINATES ARE')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,3041)
3041 FORMAT(' X = XMIN + 3 * (XMAX - XMIN)')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,3042)
3042 FORMAT(' Y = YMIN + 3 * (YMAX - YMIN)')
CALL DPWRST('XXX','WRIT')
WRITE(ICOUT,3043)
3043 FORMAT(' Z = ZMIN + 3 * (ZMAX - ZMIN)')
CALL DPWRST('XXX','WRIT')
GOTO9000
C
C ********************************************
C ** STEP 14-- **
C ** TREAT THE ERROR CASE **
C ********************************************
C
8000 CONTINUE
IERROR='YES'
WRITE(ICOUT,8011)
8011 FORMAT('***** ERROR IN DPEYCO--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8012)
8012 FORMAT(' ILLEGAL FORM FOR EYE COORDINATES ',
1'COMMAND.')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8014)
8014 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ',
1'PROPER FORM--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8015)
8015 FORMAT(' SUPPOSE IT IS DESIRED TO POSITION ')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8016)
8016 FORMAT(' THE AXES EYE FOR A 3 DIMENSIONAL PLOT')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8017)
8017 FORMAT(' AT (IN UNITS OF THE PLOTTED DATA)--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8018)
8018 FORMAT(' (X=500, Y=25000, Z=.03)')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8019)
8019 FORMAT(' THEN THE ALLOWABLE FORM IS--')
CALL DPWRST('XXX','BUG ')
WRITE(ICOUT,8020)
8020 FORMAT(' EYE COORDINATES 500 2500 .03')
CALL DPWRST('XXX','BUG ')
GOTO9000
C
C *****************
C ** STEP 90-- **
C ** EXIT **
C *****************
C
9000 CONTINUE
RETURN
END